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: |
3519b83598db4fc5c71c95732a12b7b5 |
User & Date: | arthurcnorman@users.sourceforge.net on 2020-04-21 19:40:01 |
Other Links: | manifest | tags |
2021-03-01
| ||
00:11:36 | Updating .gitignore check-in: 3f9ee8c811 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: 3519b83598 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: 1d536d6d33 user: schoepf@users.sourceforge.net tags: master, trunk | |
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",x); procedure !*cerror x; begin scalar i; i:=wrs Nil; printf( "%n *** CERROR: %r %n ",x); wrs i; return list list('cerror,x); end; put('cerror,'asmpseudoop,'printcomment); DefCmacro !*cerror; END; |
Added psl-1983/20-comp/dec20-cmac.b version [f899d40a63].
cannot compute difference between binary files
Added psl-1983/20-comp/dec20-cmac.build version [e71c0c58c1].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | CompileTime << on EolInStringOK; macro procedure !* U; NIL; flag('(TagNumber InumP), 'lose); >>; imports '(dec20-comp); in "pc:tags.red"$ in "dec20-cmac.sl"$ |
Added psl-1983/20-comp/dec20-cmac.ctl version [db44bdace9].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ; Rebuild the CMAC module @term page 0 @get psl:rlisp @st *load build; *build "DEC20-CMAC"; *quit; @reset . @term page 24 |
Added psl-1983/20-comp/dec20-cmac.log version [765aa5e4eb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | LINK FROM GRISS, TTY 141 [DO: Execution of PS:<PSL.20-COMP>DEC20-CMAC.CTL.2 started at 22-Aug-82 09:28:39] TOPS-20 Command processor 5(712) End of <GRISS>COMAND.CMD.10 @; Rebuild the CMAC module term page 0 @def PL: dsK:, Plap: @psl:rlisp PSL 3.0 Rlisp, 19-Aug-82 [1] load build; NIL [2] build "DEC20-CMAC"; FASLOUT: IN files; or type in expressions When all done execute FASLEND; CompileTime << on EolInStringOK; macro procedure !* U; NIL; flag('(TagNumber InumP), 'lose); >>; imports '(dec20-comp); in "pc:tags.red"$ in "dec20-cmac.sl"$ *** Function `BITMASK' has been redefined BITMASK *** Function `BIT' has been redefined BIT EXPANDBIT *** `INUMP' has not been defined, because it is flagged LOSE *** `TAGNUMBER' has not been defined, because it is flagged LOSE IMMEDIATEP MEMORYP NEGATIVEIMMEDIATEP EIGHTEENP NONINDIRECTP FAKEREGISTERNUMBERP !*FOREIGNLINK *** Init code length is 184 *** Garbage collection starting *** GC 3: time 3082 ms *** 70801 recovered, 774 stable, 28425 active, 70801 free *** Garbage collection starting *** GC 4: time 4127 ms *** 18114 recovered, 29161 stable, 52724 active, 18115 free !*!*FASL!*!*INITCODE!*!*NIL [3] quit; @ [DO: Execution finished at 22-Aug-82 09:31:16] |
Added psl-1983/20-comp/dec20-cmac.sl version [6f161aff54].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-CMAC.SL - Patterns and predicates for Dec-20 PSL cmacro expansion % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 January 1982 % Copyright (c) 1982 University of Utah % % <PSL.20-COMP>20-CMAC.SL.1, 21 October 1982, Griss % Fixed foreign function for CROSS compiler % <PSL.20-COMP>20-CMAC.SL.1, 24-Feb-82 12:08:45, Edit by BENSON % Adapted VAX version for Dec-20 (fluid '(AddressingUnitsPerItem CharactersPerWord StackDirection !*ImmediateQuote AddressingUnitsPerFunctionCell)) (setq AddressingUnitsPerItem 1) (setq CharactersPerWord 5) (setq AddressingUnitsPerFunctionCell 1) (setq StackDirection 1) (setq !*ImmediateQuote NIL) (* (* "MkItem may be used when evaluating WConst expressions.") (de MkItem (TagPart InfPart) (lor (lsh TagPart 27) (land InfPart 16#7ffffff))) ) (ds BitMask (Start End) (land (lsh -1 (minus Start)) (lsh -1 (difference 35 End)))) (dm Bit (U) (progn (setq U (cdr U)) (cond ((null U) 0) (t (ExpandBit U))))) (de ExpandBit (U) (cond ((null (cdr U)) (list 'lsh 1 (list 'difference 35 (car U)))) (t (list 'lor (list 'lsh 1 (list 'difference 35 (car U))) (ExpandBit (cdr U)))))) (* "InumP tells what numbers can be immediate operands on the target machine.") (de InumP (Expression) (and (FixP Expression) (leq Expression 8#777777) % 8#177777777777 for extended (geq Expression (minus 8#1000000)))) % 8#200000000000 (de TagNumber (X) (cond ((IDP X) (get 'ID 'WConst)) ((PairP X) (get 'PAIR 'WConst)) ((StringP X) (get 'STR 'WConst)) ((InumP X) (cond ((MinusP X) 31) (t 0))) ((CodeP X) (get 'CODE 'WConst)) ((FloatP X) (get 'FltN 'WConst)) ((VectorP X) (get 'VECT 'WConst)) ((FixP X) (get 'FixN 'WConst)))) (de ImmediateP (X) (or (EqCar X 'Immediate) (and (FixP X) (leq X 8#777777) (geq X (minus 8#777777))))) (de MemoryP (X) (not (ImmediateP X))) (de NegativeImmediateP (X) (and (FixP X) (MinusP X) (geq X (minus 8#777777)))) (de EighteenP (X) (equal X 18)) (de NonIndirectP (Expression) (not (EqCar Expression 'Indirect))) (de FakeRegisterNumberP (Expression) (and (IntP Expression) (GreaterP Expression 5))) (* "Leave Indexed and Indirect alone in recursive c-macro") (flag '(Indexed Indirect UnImmediate) 'TerminalOperand) (DefAnyreg CAR AnyregCAR ((RegisterP) (Indexed SOURCE 0)) ((move REGISTER SOURCE) (Indexed REGISTER 0))) (DefAnyreg CDR AnyregCDR ((RegisterP) (Indexed SOURCE 1)) ((move REGISTER SOURCE) (Indexed REGISTER 1))) (DefAnyreg QUOTE AnyregQUOTE ((Null) (REG NIL)) ((EqTP) (FLUID T)) ((InumP) SOURCE) ((QUOTE SOURCE))) (DefAnyreg WVAR AnyregWVAR ((RegisterNameP) (REG SOURCE)) ((WVAR SOURCE))) (DefAnyreg MEMORY AnyregMEMORY ((RegisterP AnyP) (Indexed SOURCE ARGTWO)) ((AddressConstantP ZeroP) (UnImmediate SOURCE)) ((NonIndirectP ZeroP) (Indirect SOURCE)) ((!*MOVE SOURCE REGISTER) (Indexed REGISTER ARGTWO))) (DefAnyreg FRAME AnyregFRAME ((Indexed (REG st) SOURCE))) (DefAnyreg REG AnyregREG ((FakeRegisterNumberP) (ExtraReg SOURCE)) ((REG SOURCE))) (DefCMacro !*Call ((InternallyCallableP) (pushj (reg st) (InternalEntry ARGONE))) ((pushj (reg st) (Entry ARGONE)))) (DefCMacro !*JCall ((InternallyCallableP) (jrst (InternalEntry ARGONE))) ((jrst (Entry ARGONE)))) (DefCMacro !*Move (Equal) ((ZeroP AnyP) (setzm ARGTWO)) ((MinusOneP AnyP) (setom ARGTWO)) ((NegativeImmediateP RegisterP) (movni ARGTWO (minus ARGONE))) ((ImmediateP RegisterP) (hrrzi ARGTWO ARGONE)) ((AnyP RegisterP) (move ARGTWO ARGONE)) ((RegisterP AnyP) (movem ARGONE ARGTWO)) ((!*MOVE ARGONE (reg t1)) (movem (reg t1) ARGTWO))) (DefCMacro !*Alloc ((ZeroP)) ((adjsp (REG st) ARGONE))) (DefCMacro !*DeAlloc ((ZeroP)) ((adjsp (REG st) (minus ARGONE)))) (DefCMacro !*Exit ((!*DeAlloc ARGONE) (popj (reg st) 0))) (DefCMacro !*Jump ((jrst ARGONE))) (DefCMacro !*Lbl (ARGONE)) (DefCMacro !*WPlus2 ((AnyP OneP) (aos ARGONE)) ((AnyP MinusOneP) (sos ARGONE)) ((AnyP RegisterP) (addm ARGTWO ARGONE)) ((RegisterP NegativeImmediateP) (subi ARGONE (minus ARGTWO))) ((RegisterP ImmediateP) (addi ARGONE ARGTWO)) ((RegisterP AnyP) (add ARGONE ARGTWO)) ((!*MOVE ARGTWO (reg t2)) (addm (reg t2) ARGONE))) (DefCMacro !*WDifference ((AnyP OneP) (sos ARGONE)) ((AnyP MinusOneP) (aos ARGONE)) ((RegisterP NegativeImmediateP) (addi ARGONE (minus ARGTWO))) ((RegisterP ImmediateP) (subi ARGONE ARGTWO)) ((RegisterP AnyP) (sub ARGONE ARGTWO)) ((!*WMINUS (reg t2) ARGTWO) (addm (reg t2) ARGONE))) (DefCMacro !*WTimes2 ((AnyP MinusOneP) (!*WMINUS ARGONE ARGONE)) ((RegisterP NegativeImmediateP) (imul ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (imuli ARGONE ARGTWO)) ((RegisterP AnyP) (imul ARGONE ARGTWO)) ((AnyP RegisterP) (imulm ARGTWO ARGONE)) ((!*MOVE ARGTWO (reg t2)) (imulm (reg t2) ARGONE))) (DefCMacro !*WAnd ((RegisterP NegativeImmediateP) (and ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (andi ARGONE ARGTWO)) ((RegisterP AnyP) (and ARGONE ARGTWO)) ((AnyP RegisterP) (andm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (andm (reg t2) ARGONE))) (DefCMacro !*WOr ((RegisterP NegativeImmediateP) (ior ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (iori ARGONE ARGTWO)) ((RegisterP AnyP) (ior ARGONE ARGTWO)) ((AnyP RegisterP) (iorm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (iorm (reg t2) ARGONE))) (DefCMacro !*WXOr ((RegisterP NegativeImmediateP) (xor ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (xori ARGONE ARGTWO)) ((RegisterP AnyP) (xor ARGONE ARGTWO)) ((AnyP RegisterP) (xorm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (xorm (reg t2) ARGONE))) (DefCMacro !*AShift ((RegisterP ImmediateP) (ash ARGONE ARGTWO)) ((RegisterP RegisterP) (ash ARGONE (Indexed ARGTWO 0))) ((RegisterP AnyP) (move (reg t2) ARGTWO) (ash ARGONE (Indexed (reg t2) 0))) ((AnyP ImmediateP) (move (reg t3) ARGONE) (ash (reg t3) ARGTWO) (movem (reg t3) ARGONE)) ((AnyP RegisterP) (move (reg t3) ARGONE) (ash (reg t3) (Indexed ARGTWO 0)) (movem (reg t3) ARGONE)) ((move (reg t2) ARGTWO) (move (reg t3) ARGONE) (ash (reg t3) (Indexed (reg t2) 0)) (movem (reg t3) ARGONE))) (DefCMacro !*WShift ((RegisterP ImmediateP) (lsh ARGONE ARGTWO)) ((RegisterP RegisterP) (lsh ARGONE (Indexed ARGTWO 0))) ((RegisterP AnyP) (move (reg t2) ARGTWO) (lsh ARGONE (Indexed (reg t2) 0))) ((AnyP ImmediateP) (move (reg t3) ARGONE) (lsh (reg t3) ARGTWO) (movem (reg t3) ARGONE)) ((AnyP RegisterP) (move (reg t3) ARGONE) (lsh (reg t3) (Indexed ARGTWO 0)) (movem (reg t3) ARGONE)) ((move (reg t2) ARGTWO) (move (reg t3) ARGONE) (lsh (reg t3) (Indexed (reg t2) 0)) (movem (reg t3) ARGONE))) (DefCMacro !*WNot (Equal (setcmm ARGONE)) ((RegisterP AnyP) (setcm ARGONE ARGTWO)) ((AnyP RegisterP) (setcam ARGTWO ARGONE)) ((move (reg t1) ARGTWO) (setcam (reg t1) ARGONE))) (DefCMacro !*WMinus (Equal (movns ARGONE)) ((RegisterP AnyP) (movn ARGONE ARGTWO)) ((AnyP RegisterP) (movnm ARGTWO ARGONE)) ((move (reg t1) ARGTWO) (movnm (reg t1) ARGONE))) (DefCMacro !*MkItem ((RegisterP ImmediateP) (tlz ARGONE 2#111110000000000000) (tlo ARGONE (lsh ARGTWO 13))) ((AnyP RegisterP) (dpb ARGTWO (lit (fullword (FieldPointer ARGONE 0 5))))) ((!*MOVE ARGTWO (reg t1)) (dpb (reg t1) (lit (fullword (FieldPointer ARGONE 0 5)))))) (DefCMacro !*JumpType ((RegisterP ZeroP) (tlnn ARGONE 2#111110000000000000) (jrst ARGTHREE)) ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 5)))) (!*JUMPEQ ARGTHREE (reg t6) ARGTWO))) (DefCMacro !*JumpNotType ((RegisterP ZeroP) (tlne ARGONE 2#111110000000000000) (jrst ARGTHREE)) ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 5)))) (!*JUMPNOTEQ ARGTHREE (reg t6) ARGTWO))) (DefCMacro !*JumpInType ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 5)))) (caig (reg t6) ARGTWO) (jrst ARGTHREE) (cain (reg t6) 31) (jrst ARGTHREE))) % (WConst NegInt) (DefCMacro !*JumpNotInType ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 5)))) (cain (reg t6) 31) % (WConst NegInt) (jrst TEMPLABEL) (caile (reg t6) ARGTWO) (jrst ARGTHREE) TEMPLABEL)) (DefCMacro !*JumpEQ ((RegisterP ZeroP) (jumpe ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpe ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipn ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipn ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camn ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camn ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (cain ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (cain ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camn ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camn ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpNotEQ ((RegisterP ZeroP) (jumpn ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpn ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipe ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipe ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (came ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (came ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caie ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caie ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (came ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (came ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPNOTEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPNOTEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWLessP ((RegisterP ZeroP) (jumpl ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpg ARGTWO ARGTHREE)) ((RegisterP OneP) (jumple ARGONE ARGTHREE)) ((MinusOneP RegisterP) (jumpge ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipge ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skiple ARGTWO) (jrst ARGTHREE)) ((AnyP OneP) (skipg ARGONE) (jrst ARGTHREE)) ((MinusOneP AnyP) (skipl ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camge ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camle ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caige ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caile ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camge ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camle ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWLESSP ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWLESSP ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWGreaterP ((RegisterP ZeroP) (jumpg ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpl ARGTWO ARGTHREE)) ((RegisterP MinusOneP) (jumpge ARGONE ARGTHREE)) ((OneP RegisterP) (jumple ARGTWO ARGTHREE)) ((AnyP ZeroP) (skiple ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipge ARGTWO) (jrst ARGTHREE)) ((AnyP MinusOneP) (skipl ARGONE) (jrst ARGTHREE)) ((OneP AnyP) (skipg ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camle ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camge ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caile ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caige ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camle ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camge ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWGreaterP ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWGreaterP ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWLEQ ((RegisterP ZeroP) (jumple ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpge ARGTWO ARGTHREE)) ((RegisterP MinusOneP) (jumpl ARGONE ARGTHREE)) ((OneP RegisterP) (jumpg ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipg ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipl ARGTWO) (jrst ARGTHREE)) ((AnyP MinusOneP) (skipge ARGONE) (jrst ARGTHREE)) ((OneP AnyP) (skiple ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camg ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (caml ARGTWO (lit ARGTHREE)) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caig ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (cail ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camg ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (caml ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWLEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWLEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWGEQ ((RegisterP ZeroP) (jumpge ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumple ARGTWO ARGTHREE)) ((RegisterP OneP) (jumpg ARGONE ARGTHREE)) ((MinusOneP RegisterP) (jumpl ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipl ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipg ARGTWO) (jrst ARGTHREE)) ((AnyP OneP) (skiple ARGONE) (jrst ARGTHREE)) ((MinusOneP AnyP) (skipge ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (caml ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camg ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (cail ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caig ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (caml ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camg ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWGEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWGEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*Push ((ImmediateP) (push (reg st) (lit (fullword ARGONE)))) ((push (reg st) ARGONE))) (DefCMacro !*Pop ((ImmediateP) (pop (reg st) (lit (fullword ARGONE)))) ((pop (reg st) ARGONE))) (DefCMacro !*Freerstr ((jsp (reg t5) (Entry FastUnbind)) (fullword ARGONE))) (DefCMacro !*Loc ((RegisterP AnyP) (movei ARGONE ARGTWO)) ((movei (reg t2) ARGTWO) (movem (reg t2) ARGONE))) (DefCMacro !*Field ((RegisterP AnyP ZeroP EighteenP) (hlrz ARGONE ARGTWO)) ((RegisterP AnyP EighteenP EighteenP) (hrrz ARGONE ARGTWO)) ((AnyP RegisterP ZeroP EighteenP) (hlrzm ARGTWO ARGONE)) ((AnyP RegisterP EighteenP EighteenP) (hrrzm ARGTWO ARGONE)) ((RegisterP) (ldb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR))))) ((ldb (reg t2) (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))) (movem (reg t2) ARGONE))) (DefCMacro !*SignedField ((RegisterP AnyP ZeroP EighteenP) (hlre ARGONE ARGTWO)) ((RegisterP AnyP EighteenP EighteenP) (hrre ARGONE ARGTWO)) ((AnyP RegisterP ZeroP EighteenP) (hlrem ARGTWO ARGONE)) ((AnyP RegisterP EighteenP EighteenP) (hrrem ARGTWO ARGONE)) ((RegisterP) % could optimize to use tlne tlo trne tro (ldb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))) (tdne ARGONE (lit (fullword (bit ARGTHREE)))) (tdo ARGONE (lit (fullword (bitmask 0 ARGTHREE))))) ((ldb (reg t2) (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))) (tdne (reg t2) (lit (fullword (bit ARGTHREE)))) (tdo (reg t2) (lit (fullword (bitmask 0 ARGTHREE)))) (movem (reg t2) ARGONE))) (DefCMacro !*PutField ((RegisterP) (dpb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR))))) ((!*MOVE ARGONE (reg t1)) (dpb (reg t1) (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))))) (DefCMacro !*ADJSP ((RegisterP ImmediateP) (adjsp ARGONE ARGTWO)) ((RegisterP RegisterP) (adjsp ARGONE (Indexed ARGTWO 0))) ((RegisterP) (move (reg t2) ARGTWO) (adjsp ARGONE (Indexed (reg t2) 0))) ((move (reg t1) ARGONE) (!*ADJSP (reg t1) ARGTWO) (movem (reg t1) ARGONE))) (DefList '((WQuotient ((idiv (reg 1) (reg 2)))) (WRemainder ((idiv (reg 1) (reg 2)) (move (reg 1) (reg 2))))) 'OpenCode) (!&Tworeg '(WQuotient WRemainder)) (loadtime (DefList '((Byte ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 7)))) (ldb (reg 1) (reg 2)))) (PutByte ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 7)))) (dpb (reg 3) (reg 2)))) (HalfWord ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 18)))) (ldb (reg 1) (reg 2)))) (PutHalfWord ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 18)))) (dpb (reg 3) (reg 2)))) (BitTable ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 2)))) (ldb (reg 1) (reg 2)))) (PutBitTable ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 2)))) (dpb (reg 3) (reg 2))))) 'OpenCode)) (loadtime (!&TwoReg '(Byte PutByte HalfWord PutHalfWord BitTable PutBitTable))) (DefList '((IDApply0 ((pushj (reg st) (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ((pushj (reg st) (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ((pushj (reg st) (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ((pushj (reg st) (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ((pushj (reg st) (Indexed (reg 5) (WArray SymFnc)))))) 'OpenCode) (DefList '((IDApply0 ((jrst (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ((jrst (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ((jrst (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ((jrst (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ((jrst (Indexed (reg 5) (WArray SymFnc)))))) 'ExitOpenCode) (DefList '((CodeApply0 ((pushj (reg st) (Indexed (reg 1) 0)))) (CodeApply1 ((pushj (reg st) (Indexed (reg 2) 0)))) (CodeApply2 ((pushj (reg st) (Indexed (reg 3) 0)))) (CodeApply3 ((pushj (reg st) (Indexed (reg 4) 0)))) (CodeApply4 ((pushj (reg st) (Indexed (reg 5) 0))))) 'OpenCode) (DefList '((CodeApply0 ((jrst (Indexed (reg 1) 0)))) (CodeApply1 ((jrst (Indexed (reg 2) 0)))) (CodeApply2 ((jrst (Indexed (reg 3) 0)))) (CodeApply3 ((jrst (Indexed (reg 4) 0)))) (CodeApply4 ((jrst (Indexed (reg 5) 0))))) 'ExitOpenCode) (DefList '((AddressApply0 ((pushj (reg st) (Indexed (reg 1) 0)))) (AddressApply1 ((pushj (reg st) (Indexed (reg 2) 0)))) (AddressApply2 ((pushj (reg st) (Indexed (reg 3) 0)))) (AddressApply3 ((pushj (reg st) (Indexed (reg 4) 0)))) (AddressApply4 ((pushj (reg st) (Indexed (reg 5) 0))))) 'OpenCode) (DefList '((AddressApply0 ((jrst (Indexed (reg 1) 0)))) (AddressApply1 ((jrst (Indexed (reg 2) 0)))) (AddressApply2 ((jrst (Indexed (reg 3) 0)))) (AddressApply3 ((jrst (Indexed (reg 4) 0)))) (AddressApply4 ((jrst (Indexed (reg 5) 0))))) 'ExitOpenCode) (* "*FEQ, *FGreaterP and !*FLessP can only occur once in a function.") (DefList '((!*WFix ((fix (reg 1) (indexed (reg 1) 0)))) (!*WFloat ((fltr (reg 2) (reg 2)) (movem (reg 2) (indexed (reg 1) 0)) (setzm (indexed (reg 1) 1)))) (!*FAssign ((dmove (reg 2) (indexed (reg 2) 0)) (dmovem (reg 2) (indexed (reg 1) 0)))) (!*FEQ ((dmove (reg 3) (indexed (reg 2) 0)) (came (reg 3) (indexed (reg 1) 0)) (jrst !*NotEQ!*) (camn (reg 4) (indexed (reg 1) 1)) !*NotEQ!* (move (reg 1) (reg nil)))) (!*FGreaterP ((dmove (reg 3) (indexed (reg 2) 0)) (camge (reg 3) (indexed (reg 1) 0)) (jrst !*IsGreaterP!*) (camn (reg 3) (indexed (reg 1) 0)) (caml (reg 4) (indexed (reg 1) 1)) (move (reg 1) (reg nil)) !*IsGreaterP!*)) (!*FLessP ((dmove (reg 3) (indexed (reg 2) 0)) (camle (reg 3) (indexed (reg 1) 0)) (jrst !*IsLessP!*) (camn (reg 3) (indexed (reg 1) 0)) (camg (reg 4) (indexed (reg 1) 1)) (move (reg 1) (reg nil)) !*IsLessP!*)) (!*FPlus2 ((dmove (reg 3) (indexed (reg 3) 0)) (dfad (reg 3) (indexed (reg 2) 0)) (dmovem (reg 3) (indexed (reg 1) 0)))) (!*FDifference ((dmove (reg 4) (indexed (reg 2) 0)) (dfsb (reg 4) (indexed (reg 3) 0)) (dmovem (reg 4) (indexed (reg 1) 0)))) (!*FTimes2 ((dmove (reg 3) (indexed (reg 3) 0)) (dfmp (reg 3) (indexed (reg 2) 0)) (dmovem (reg 3) (indexed (reg 1) 0)))) (!*FQuotient ((dmove (reg 4) (indexed (reg 2) 0)) (dfdv (reg 4) (indexed (reg 3) 0)) (dmovem (reg 4) (indexed (reg 1) 0))))) 'OpenCode) % Later, do as FORTRAN call? (DE !*ForeignLink (FunctionName FunctionType NumberOfArguments) (prog NIL (CodeDeclareExternal FunctionName) % To emit Extern (return (LIST (LIST 'Pushj '(REG st) (LIST 'InternalEntry FunctionName)))) )) (DefCMacro !*ForeignLink) |
Added psl-1983/20-comp/dec20-comp.b version [1d6b922eb4].
cannot compute difference between binary files
Added psl-1983/20-comp/dec20-comp.build version [146b2a4ce1].
> | 1 | in "dec20-comp.red"$ |
Added psl-1983/20-comp/dec20-comp.ctl version [76873d392f].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ; Rebuild the COMP module @term page 0 @get psl:rlisp @st *load build; *build "DEC20-COMP"; *quit; @reset . @term page 24 |
Added psl-1983/20-comp/dec20-comp.red version [9f6adacebd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-COMP.RED - Compiler patterns for Dec-20 PSL, plus a few cmacro expanders % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 January 1982 % Copyright (c) 1982 University of Utah % % <PSL.20-COMP>20-COMP.RED.1, 25-Feb-82 16:34:42, Edit by BENSON % Converted from VAX version PUT('TVPAT,'PATTERN,'( !®MEM ('!*DESTROY DEST) ((DEST ANY) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((ANY DEST) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((USESDEST ANY) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((ANY USESDEST) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) (ANY ('!*LOAD DEST '(QUOTE T)) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*LBL L1)))); PUT('TVPAT1,'PATTERN,'( !®MEM ('!*DESTROY DEST) ((DEST) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((USESDEST) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) (ANY ('!*LOAD DEST '(QUOTE T)) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*LBL L1)))); PUT('TSTPAT,'PATTERN,'( NIL !&FIXREGTEST ((REGN ANY) (MAC DEST A1 A2)) (ANY (MAC DEST A2 A1)))); PUT('TSTPATC,'PATTERN,'( NIL !&SETREGS1 ((REGN ANY) (MAC DEST A1 A2)) (ANY (P2 DEST A2 A1)))); PUT('TSTPAT2, 'PATTERN, '( NIL !&SETREGS1 (ANY (MAC DEST A1 P2)))); PUT('SETQPAT,'PATTERN,'( NIL NIL ((NOVAL ANY NOTANYREG) ('!*STORE A2 A1)) ((NOVAL DEST ANY) ('!*STORE A2 DEST)) ((NOVAL USESDEST ANY) ('!*LOAD T1 A2) ('!*STORE T1 A1)) ((NOVAL ANY ANY) ('!*LOAD DEST A2) ('!*STORE DEST A1)) ((ANY DEST) ('!*STORE DEST A1)) ((DEST ANY) ('!*STORE A2 DEST)) ((USESDEST ANY) ('!*STORE A2 A1) ('!*STORE A2 DEST)) (ANY ('!*LOAD DEST A2) ('!*STORE DEST A1)))); PUT('RPLACPAT,'PATTERN,'( NIL NIL ((NOVAL ANY ANY) ('!*STORE A2 (MAC A1))) ((DEST ANY) ('!*STORE A2 (MAC A1))) ((USESDEST ANY) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) ((ANY DEST) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) ((ANY USESDEST) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) (ANY ('!*LOAD DEST A1) ('!*STORE A2 (MAC DEST))))); PUT('ASSOCPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY DEST) (MAC A2 A1)) ((USESDEST USESDEST) ('!*LOAD T1 A1) ('!*LOAD DEST A2) (MAC DEST T1)) ((ANY USESDEST) ('!*LOAD DEST A2) (MAC DEST A1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('SUBPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY DEST) ('!*WMINUS DEST DEST) ('!*WPLUS2 A2 A1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('NONASSOCPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY USESDEST) ('!*LOAD T1 A2) ('!*LOAD DEST A1) (MAC DEST T1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('FIELDPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2 A3)) (ANY (MAC DEST A1 A2 A3)))); PUT('PUTFIELDPAT,'PATTERN,'( NIL NIL ((NOVAL ANY ANY ANY ANY) (MAC A1 A2 A3 A4)) (ANY (MAC A1 A2 A3 A4) ('!*STORE A1 DEST)))); PUT('UNARYPAT,'PATTERN,'( !&NOANYREG ('!*SET DEST (FN A1)) (ANY (MAC DEST A1)))); PUT('MODMEMPAT,'PATTERN,'( NIL NIL (ANY (MAC A1 A2)))); PUT('MODMEMPAT1,'PATTERN,'( NIL NIL (ANY (MAC A1 A1)))); lisp procedure !*LamBind(Regs, FLst); begin scalar X, Y; FLst := reverse cdr FLst; Regs := reverse cdr Regs; while FLst do << if null Regs then X := 0 else << X := cadr car Regs; Regs := cdr Regs >>; Y := list('halfword, X, list('IDLoc, cadar FLst)) . Y; FLst := cdr FLst >>; return '(jsp (reg t5) (Entry FastBind)) . Y; end; DefCMacro !*Lambind; lisp procedure !*JumpOn(Register, LowerBound, UpperBound, LabelList); begin scalar ExitLbl, BaseLbl, Result; ExitLbl := GenSym(); BaseLbl := GenSym(); Result := NIL . NIL; TConc(Result,if LowerBound < 0 then list('caml, Register, list('lit, LowerBound)) else list('cail, Register, LowerBound)); TConc(Result,if UpperBound < 0 then list('camle, Register, list('lit, UpperBound)) else list('caile, Register, UpperBound)); TConc(Result,list('jrst, ExitLbl)); TConc(Result, list('jrst, list('Indirect, list('Indexed, Register, list('difference, BaseLbl, LowerBound))))); TConc(Result, BaseLbl); for each X in LabelList do TConc(Result, list('fullword, cadr X)); TConc(Result, ExitLbl); return car Result; end; DefCMacro !*JumpOn; END; |
Added psl-1983/20-comp/dec20-cross.ctl version [a6c083b0f8].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | @get PSL:RLISP @st *Options!*:=NIL; % Force reload of ALL *LoadDirectories!*:='("pl:"); % Only look at <psl.lap> *load(zboot, syslisp, if!-system, lap!-to!-asm); *load(dec20!-comp,dec20!-cmac,dec20!-asm); * %/ old:? remflag('(extrareg),'terminaloperand); * %/ to fix HRRZI for ExtraReg... why was it here *off usermode; *Date!* := "Dec 20 cross compiler"; *Dumplisp "S:DEC20-CROSS.EXE"; *Quit; @reset . |
Added psl-1983/20-comp/dec20-cross.log version [9b53ebb62a].
cannot compute difference between binary files
Added psl-1983/20-comp/dec20-data-machine.red version [c3a9b522c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-DATA-MACHINE.RED - Lisp item constructors & selectors for Dec-20 Syslisp % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 July 1981 % Copyright (c) 1981 University of Utah % % <PSL.20-COMP>20-DATA-MACHINE.RED.1, 25-Feb-82 17:24:56, Edit by BENSON % Converted from VAX version (which was previously converted from 20 version!) % Primitives handled by the compiler are BYTE, PUTBYTE, GETMEM, PUTMEM, % MKITEM, FIELD, SIGNEDFIELD, PUTFIELD fluid '(system_list!*); system_list!* := '(Dec20 PDP10 Tops20 KL10); BothTimes << exported WConst TagStartingBit = 0, TagBitLength = 5, InfStartingBit = 18, InfBitLength = 18, GCStartingBit = 5, GCBitLength = 13, AddressingUnitsPerItem = 1, CharactersPerWord = 5, BitsPerWord = 36, AddressingUnitsPerFunctionCell = 1, StackDirection = 1; >>; syslsp macro procedure GCField U; list('Field, cadr U, '(WConst GCStartingBit), '(WConst GCBitLength)); syslsp macro procedure PutGCField U; list('PutField, cadr U, '(WConst GCStartingBit), '(WConst GCBitLength), caddr U); % Retrieve the address stored in the function cell syslsp macro procedure SymFnc U; list('WGetV, '(WConst SymFnc), cadr U); syslsp macro procedure PutSymFnc U; list('WPutV, '(WConst SymFnc), cadr U, caddr U); % Macros for building stack pointers syslsp macro procedure MakeStackPointerFromAddress U; list('WOr, list('WShift, list('WDifference, 0, caddr U), 18), list('WDifference, cadr U, 1)); syslsp macro procedure MakeAddressFromStackPointer U; list('Field, cadr U, 18, 18); put('AdjustStackPointer,'OpenFn,'(NonAssocPat !*ADJSP)); lisp procedure !*ADJSP(Arg1, Arg2); Expand2OperandCMacro(Arg1, Arg2, '!*ADJSP); put('EOF, 'CharConst, char cntrl Z); END; |
Added psl-1983/20-comp/dec20-lap.build version [6aa584e0d8].
> > > > > > | 1 2 3 4 5 6 | CompileTime << load Syslisp; >>; in "p20:system-faslout.red"$ in "dec20-lap.red"$ in "instrs.sl"$ |
Added psl-1983/20-comp/dec20-lap.red version [9d9077cc2b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-LAP.RED - Dec-20 PSL assembler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 February 1982 % Copyright (c) 1982 University of Utah % fluid '(LabelOffsets!* CurrentOffset!* CodeSize!* CodeBase!* Entries!* ForwardInternalReferences!* NewBitTableEntry!* LapReturnValue!* !*WritingFaslFile InitOffset!* !*PGWD !*PWrds); CompileTime << flag('(SaveEntry DefineEntries DepositInstruction OpcodeValue OperandValue DepositWord DepositWordExpression DepositHalfWords LabelValue DepositItem DepositHalfWordIDNumber FindLabels OneLapLength MakeRelocInf MakeRelocWord), 'InternalFunction); smacro procedure LabelP X; atom X; >>; LoadTime << !*PWrds := T; >>; lisp procedure Lap U; begin scalar LapReturnValue!*, LabelOffsets!*, Entries!*; if not !*WritingFaslFile then CurrentOffset!* := 0; U := Pass1Lap U; FindLabels U; if !*PGWD then for each X in U do if atom X then Prin2 X else PrintF(" %p%n", X); if not !*WritingFaslFile then CodeBase!* := GTBPS CodeSize!*; for each X in U do if not LabelP X then if first X = '!*entry then SaveEntry X else DepositInstruction X; DefineEntries(); if not !*WritingFaslFile and !*PWrds then ErrorPrintF("*** %p: base %o, length %d words", for each X in Entries!* collect first car X, CodeBase!*, CodeSize!*); return MkCODE LapReturnValue!*; end; lisp procedure SaveEntry X; if second X = '!*!*!*Code!*!*Pointer!*!*!* then LapReturnValue!* := % Magic token that tells LAP to return (if !*WritingFaslFile then CurrentOffset!* % a code pointer else IPlus2(CodeBase!*, CurrentOffset!*)) else if not !*WritingFaslFile then << Entries!* := (rest X . CurrentOffset!*) . Entries!*; if not LapReturnValue!* then LapReturnValue!* := IPlus2(CodeBase!*, CurrentOffset!*) >> else if second X = '!*!*Fasl!*!*InitCode!*!* then InitOffset!* := CurrentOffset!* else if FlagP(second X, 'InternalFunction) then put(second X, 'InternalEntryOffset, CurrentOffset!*) else << FindIDNumber second X; DFPrintFasl list('PutEntry, MkQuote second X, MkQuote third X, CurrentOffset!*) >>; lisp procedure DefineEntries(); for each X in Entries!* do PutD(first car X, second car X, MkCODE IPlus2(CodeBase!*, cdr X)); lisp procedure DepositInstruction X; % % Legal forms are: % (special_form . any) % (opcode) % (opcode address) % (opcode ac address) % begin scalar Op, Y, A, E; return if (Y := get(first X, 'InstructionDepositFunction)) then Apply(Y, list X) else << NewBitTableEntry!* := 0; Op := OpcodeValue first X; if null(Y := rest X) then A := E := 0 else << E := OperandValue first Y; if null(Y := rest Y) then A := 0 else << A := E; E := OperandValue first Y >> >>; UpdateBitTable(1, NewBitTableEntry!*); DepositAllFields(Op, A, E) >>; end; lisp procedure DepositAllFields(Op, A, E); << @IPlus2(CodeBase!*, CurrentOffset!*) := ILOR(ILSH(Op, 27), ILOR(ILSH(A, 23), E)); CurrentOffset!* := IAdd1 CurrentOffset!* >>; lisp procedure OpcodeValue U; if PosIntP U then U else get(U, 'OpcodeValue) or StdError BldMsg("Unknown opcode %r", U); lisp procedure OperandValue U; % % Legal forms are: % number % other atom (label) % (special . any) fluid, global, etc. % (indexed register address) % (indirect other_op) % begin scalar X; return if PosIntP U then U else if NegIntP U then ILAND(U, 8#777777) else if LabelP U then LabelValue U else if (X := get(first U, 'OperandValueFunction)) then Apply(X, list U) else if (X := WConstEvaluable U) then OperandValue X else StdError BldMsg("Unknown operand %r", U); end; lisp procedure BinaryOperand U; % % (op x x) can occur in expressions % begin scalar X; return if (X := WConstEvaluable U) then X else << X := if GetD first U then first U else get(first U, 'DOFN); U := rest U; if NumberP first U then Apply(X, list(first U, LabelValue second U)) else if NumberP second U then Apply(X, list(LabelValue first U, second U)) else StdError BldMsg("Expression too complicated in LAP %r", U) >>; end; % Add others to this list if they arise put('difference, 'OperandValueFunction, 'BinaryOperand); put('WPlus2, 'OperandValueFunction, 'BinaryOperand); lisp procedure RegisterOperand U; begin scalar V; U := second U; return if PosIntP U then U else if (V := get(U, 'RegisterNumber)) then V else StdError BldMsg("Unknown register %r", U); end; put('REG, 'OperandValueFunction, 'RegisterOperand); DefList('((nil 0) (t1 6) (t2 7) (t3 8) (t4 9) (t5 10) (t6 11) (st 8#17)), 'RegisterNumber); lisp procedure ImmediateOperand U; OperandValue second U; % immediate does nothing on the PDP10 put('immediate, 'OperandValueFunction, 'ImmediateOperand); lisp procedure IndexedOperand U; begin scalar V; V := OperandValue second U; U := OperandValue third U; return ILOR(ILSH(V, 18), U); end; put('indexed, 'OperandValueFunction, 'IndexedOperand); lisp procedure LapValueCell U; ValueCellLocation second U; DefList('((fluid LapValueCell) (!$fluid LapValueCell) (global LapValueCell) (!$global LapValueCell)), 'OperandValueFunction); lisp procedure LapEntry U; FunctionCellLocation second U; put('entry, 'OperandValueFunction, 'LapEntry); lisp procedure LapInternalEntry U; begin scalar X; U := second U; NewBitTableEntry!* := const RELOC_HALFWORD; return if (X := Atsoc(U, LabelOffsets!*)) then << X := cdr X; if !*WritingFaslFile then X else IPlus2(CodeBase!*, X) >> else << if not !*WritingFaslFile then FunctionCellLocation U else if (X := get(U, 'InternalEntryOffset)) then X else << ForwardInternalReferences!* := (CurrentOffset!* . U) . ForwardInternalReferences!*; 0 >> >>; % will be modified later end; put('InternalEntry, 'OperandValueFunction, 'LapInternalEntry); lisp procedure DepositWordBlock X; for each Y in cdr X do DepositWordExpression Y; put('fullword, 'InstructionDepositFunction, 'DepositWordBlock); lisp procedure DepositHalfWordBlock X; begin scalar L, R; X := rest X; while not null X do << L := first X; X := rest X; if null X then R := 0 else << R := first X; X := rest X >>; DepositHalfWords(L, R) >>; end; put('halfword, 'InstructionDepositFunction, 'DepositHalfWordBlock); CommentOutCode << lisp procedure DepositByteBlock X; case length X of 0: DepositWord 0; 1: DepositBytes(first X, 0, 0, 0, 0); 2: DepositBytes(first X, second X, 0, 0, 0); 3: DepositBytes(first X, second X, third X, 0, 0); 4: DepositBytes(first X, second X, third X, fourth X, 0); default: << DepositBytes(first X, second X, third X, fourth X, fourth rest X); DepositByteBlock rest rest rest rest rest X >>; end; put('byte, 'InstructionDepositFunction, 'DepositByteBlock); >>; lisp procedure DepositString X; begin scalar Y; X := StrInf second X; Y := StrPack StrLen X; for I := 1 step 1 until Y do DepositWord @IPlus2(X, I); end; put('string, 'InstructionDepositFunction, 'DepositString); lisp procedure DepositFloat X; % this will not work in cross-assembly << X := second X; % don't need to strip tag on PDP10 DepositWord FloatHighOrder X; DepositWord FloatLowOrder X >>; put('float, 'InstructionDepositFunction, 'DepositFloat); lisp procedure DepositWord X; << @IPlus2(CodeBase!*, CurrentOffset!*) := X; UpdateBitTable(1, 0); CurrentOffset!* := IAdd1 CurrentOffset!* >>; lisp procedure DepositWordExpression X; % Only limited expressions now handled begin scalar Y; return if FixP X then DepositWord Int2Sys X else if LabelP X then << @IPlus2(CodeBase!*, CurrentOffset!*) := LabelValue X; UpdateBitTable(1, const RELOC_HALFWORD); CurrentOffset!* := IAdd1 CurrentOffset!* >> else if first X = 'MkItem then DepositItem(second X, third X) else if first X = 'FieldPointer then DepositFieldPointer(second X, third X, fourth X) else if (Y := WConstEvaluable X) then DepositWord Int2Sys Y else StdError BldMsg("Expression too complicated %r", X); end; lisp procedure DepositHalfWords(L, R); begin scalar Y; if not (FixP L or (L := WConstEvaluable L)) then StdError "Left half too complex"; if PairP R and first R = 'IDLoc then DepositHalfWordIDNumber(L, second R) else if (Y := WConstEvaluable R) then DepositWord ILOR(ILSH(L, 18), Y) else StdError BldMsg("Halfword expression too complicated %r", R); end; lisp procedure LabelValue U; begin scalar V; return if CodeP U then Inf U else if (V := Atsoc(U, LabelOffsets!*)) then << V := cdr V; if !*WritingFaslFile then << NewBitTableEntry!* := const RELOC_HALFWORD; V >> else IPlus2(CodeBase!*, V) >> else StdError BldMsg("Unknown label %r in LAP", U); end; lisp procedure DepositItem(TagPart, InfPart); if not !*WritingFaslFile then DepositWord MkItem(TagPart, if LabelP InfPart then LabelValue InfPart else if first InfPart = 'IDLoc then IDInf second InfPart else StdError BldMsg("Unknown inf in MkItem %r", InfPart)) else << if LabelP InfPart then @IPlus2(CodeBase!*, CurrentOffset!*) := % RELOC_CODE_OFFSET = 0 MkItem(TagPart, LabelValue InfPart) else if first InfPart = 'IDLoc then @IPlus2(CodeBase!*, CurrentOffset!*) := MkItem(TagPart, MakeRelocInf(const RELOC_ID_NUMBER, FindIDNumber second InfPart)) else StdError BldMsg("Unknown inf in MkItem %r", InfPart); CurrentOffset!* := IAdd1 CurrentOffset!*; UpdateBitTable(1, const RELOC_INF) >>; lisp procedure DepositHalfWordIDNumber(LHS, X); if not !*WritingFaslFile or ILEQ(IDInf X, 128) then DepositWord ILOR(ILSH(LHS, 18), IDInf X) else << @IPlus2(CodeBase!*, CurrentOffset!*) := ILOR(ILSH(LHS, 18), MakeRelocHalfWord(const RELOC_ID_NUMBER, FindIDNumber X)); CurrentOffset!* := IAdd1 CurrentOffset!*; UpdateBitTable(1, const RELOC_HALFWORD) >>; lisp procedure SystemFaslFixup(); << while not null ForwardInternalReferences!* do << Field(@IPlus2(CodeBase!*, car first ForwardInternalReferences!*), 18, 18) := get(cdr first ForwardInternalReferences!*, 'InternalEntryOffset) or << ErrorPrintF( "***** %r not defined in this module; normal function call being used", cdr first ForwardInternalReferences!*); MakeRelocHalfWord(const RELOC_FUNCTION_CELL, FindIDNumber cdr first ForwardInternalReferences!*) >>; ForwardInternalReferences!* := cdr ForwardInternalReferences!* >>; MapObl function lambda(X); RemProp(X, 'InternalEntryOffset) >>; fluid '(LapCodeList!*); lisp procedure FindLabels LapCodeList!*; << CodeSize!* := 0; for each X in LapCodeList!* do CodeSize!* := IPlus2(CodeSize!*, OneLapLength X) >>; lisp procedure OneLapLength U; begin scalar X; return if atom U then << LabelOffsets!* := (U . IPlus2(CurrentOffset!*, CodeSize!*)) . LabelOffsets!*; 0 >> else if (X := get(car U, 'LapLength)) then if PosIntP X then X else Apply(X, list U) else % minor klugde for long constants << if length U = 3 and FixP(X := third U) and not ImmediateP X then begin scalar Y; RPlaca(rest rest U, Y := StringGensym()); NConc(LapCodeList!*, list(Y, list('fullword, X))); end; 1 >>; end; DefList('((!*entry LapEntryLength) (float 2) (string LapStringLength) (fullword LapWordLength) (halfword LapHalfwordLength) (byte LapByteLength)), 'LapLength); lisp procedure LapEntryLength U; << LabelOffsets!* := (second U . IPlus2(CurrentOffset!*, CodeSize!*)) . LabelOffsets!*; 0 >>; lisp procedure LapStringLength U; StrPack StrLen StrInf second U; lisp procedure LapWordLength U; length rest U; lisp procedure LapHalfwordLength U; ILSH(IAdd1 length rest U, -1); lisp procedure LapByteLength U; StrPack length rest U; on SysLisp; syslsp procedure DepositFieldPointer(Opr, Start, Len); << LispVar NewBitTableEntry!* := 0; Opr := OperandValue Opr; @IPlus2(LispVar CodeBase!*, LispVar CurrentOffset!*) := ILOR(ILSH(36 - (Start + Len), 30), ILOR(ILSH(Len, 24), Opr)); UpdateBitTable(1, LispVar NewBitTableEntry!*); LispVar CurrentOffset!* := IAdd1 LispVar CurrentOffset!* >>; syslsp procedure IndirectOperand U; ILOR(ILSH(1, 22), OperandValue second U); put('Indirect, 'OperandValueFunction, 'IndirectOperand); % ExtraRegLocation is in 20-FASL put('ExtraReg, 'OperandValueFunction, 'ExtraRegLocation); syslsp procedure MakeRelocWord(RelocTag, RelocInf); LSH(RelocTag, 34) + Field(RelocInf, 2, 34); syslsp procedure MakeRelocInf(RelocTag, RelocInf); LSH(RelocTag, 16) + Field(RelocInf, 20, 16); syslsp procedure MakeRelocHalfWord(RelocTag, RelocInf); LSH(RelocTag, 16) + Field(RelocInf, 20, 16); off SysLisp; END; |
Added psl-1983/20-comp/instrs.sl version [4adc372329].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (compiletime (dm DEFINEOPCODERANGEFROM (U) (prog (start args) (setq start (sub1 (second U))) (setq args (second (third U))) (return (cons 'progn (foreach X in args collect (list 'put (mkquote X) ''opcodevalue (setq start (add1 start)))))))) ) (DEFINEOPCODERANGEFROM 68 (QUOTE (JSYS ADJSP))) (DEFINEOPCODERANGEFROM 91 (QUOTE (ADJBP))) (DEFINEOPCODERANGEFROM 72 (QUOTE (DFAD DFSB DFMP DFDV))) (DEFINEOPCODERANGEFROM 80 (QUOTE (DMOVE DMOVN FIX))) (DEFINEOPCODERANGEFROM 84 (QUOTE (DMOVEM DMOVNM FIXR FLTR UFA DFN FSC IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ROT LSH JFFO ASHC ROTC LSHC))) (DEFINEOPCODERANGEFROM 168 (QUOTE (EXCH BLT AOBJP AOBJN JRST JFCL XCT MAP PUSHJ PUSH POP POPJ JSR JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM CAML CAME CAMLE CAMA CAMGE CAMN CAMG))) (DEFINEOPCODERANGEFROM 208 (QUOTE (JUMP JUMPL JUMPE JUMPLE JUMPA JUMPGE JUMPN JUMPG SKIP SKIPL SKIPE SKIPLE SKIPA SKIPGE SKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE SOSLE SOSA SOSGE SOSN SOSG))) (DEFINEOPCODERANGEFROM 256 (QUOTE (SETZ SETZI SETZM SETZB AND ANDI ANDM ANDB ANDCA ANDCAI ANDCAM ANDCAB SETM SETMI SETMM SETMB ANDCM ANDCMI ANDCMM ANDCMB))) (DEFINEOPCODERANGEFROM 276 (QUOTE (SETA SETAI SETAM SETAB XOR XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBI ANDCBM ANDCBB EQV EQVI EQVM EQVB SETCA SETCAI SETCAM SETCAB ORCA ORCAI ORCAM ORCAB SETCM SETCMI SETCMM SETCMB ORCM ORCMI ORCMM ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB))) (DEFINEOPCODERANGEFROM 320 (QUOTE (HLL HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE HLREI HLREM HLRES))) (DEFINEOPCODERANGEFROM 384 (QUOTE (TRN TLN TRNE TLNE TRNA TLNA TRNN TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLCE TRCA TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO TSO TDOE TSOE TDOA TSOA TDON TSON))) |
Added psl-1983/20-comp/non-kl-comp.build version [bdf81b657f].
> | 1 | in "non-kl-comp.sl"$ |
Added psl-1983/20-comp/non-kl-comp.sl version [ad003746ff].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % NON-KL-COMP.SL - Patches to compiler for KI processor % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP-20>NON-KL-COMP.SL.6, 13-Oct-82 13:39:27, Edit by BENSON % Removed unnecessary patch of floating point arith for DMOVE (setq system_list* (delete 'KL10 system_list*))_ (DefCMacro !*Alloc ((ZeroP)) ((add (REG st) (lit (halfword ARGONE ARGONE))) (jumpge (REG st) (Entry StackOverflow)))) (DefCMacro !*DeAlloc ((ZeroP)) ((sub (REG st) (lit (halfword ARGONE ARGONE))))) (ForEach X in '(Byte PutByte HalfWord PutHalfWord BitTable PutBitTable) do (RemProp X 'OpenCode) (RemProp X 'Destroys)) (RemProp 'AdjustStackPointer 'OpenFn) (dm AdjustStackPointer (U) (list 'WPlus2 (cadr U) (list 'WPlus2 (caddr U) (list 'WShift (caddr U) 18)))) |
Added psl-1983/20-comp/readme version [197e9cf974].
> > | 1 2 | This directory contains sources which are specific to the Dec-20 version of Portable Standard LISP. |
Added psl-1983/20-comp/tenex-asm.build version [2641aa43e9].
> | 1 | in "tenex-asm.sl"$ |
Added psl-1983/20-comp/tenex-asm.sl version [74aec1d48a].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % TENEX-ASM.SL - Patch to 20-ASM for TENEX % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 May 1982 % Copyright (c) 1982 University of Utah % % Not much to do... (de CodeFileHeader () (CodePrintF " search stenex%n radix 10%n")) |
Added psl-1983/20-comp/tenex-build-patch.ctl version [9d229aa9a6].
> > > > > > > | 1 2 3 4 5 6 7 | ; Run this after BUILD-20-CROSS.CTL S:DEC20-CROSS load Tenex!-Asm, Non!-KL!-Comp; system_list!* := Delete('Tops20, system_list!*); system_list!* := Delete('KL10, system_list!*); system_list!* := Adjoin('Tenex, system_list!*); DumpLisp "S:TENEX-CROSS.EXE"; |
Added psl-1983/20-comp/tenex-build-patch.log version [3efcabd598].
cannot compute difference between binary files
Added psl-1983/20-comp/test-dec20-cross.mic version [9135ba5e71].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @reset RLISP @PSL:RLISP *Options!* := nil; % Force reload *load(zboot, syslisp, if!-system, lap!-to!-asm); *load(dec20!-comp,dec20!-cmac,dec20!-asm); *remflag(''(extrareg),''terminaloperand); *off usermode; *Date!* := "Dec 20 cross compiler"; *Dumplisp "S:DEC20-CROSS.EXE"; *Quit; |
Added psl-1983/20-dist.lpt version [155f9bf099].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Utah Symbolic Computation Group April 1982 Operating Note No. 62 Release Notes DEC-20 V3.1 PSL System DEC-20 V3.1 PSL System DEC-20 V3.1 PSL System M. L. Griss, E. Benson and R. R. Kessler Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 8 March 1983 ABSTRACT ABSTRACT ABSTRACT This note describes how to install the DEC-20 version of PSL. Work supported in part by the National Science Foundation under Grants MCS80-07034 and MCS81-21750, and by development grants from Boeing, Patil Systems, Lucas Film, Wicat and Hewlett Packard. DEC-20 PSL Release Page 2 1. INTRODUCTION 1. INTRODUCTION 1. INTRODUCTION The attached DUMPER format tape contains most of the files needed to use and maintain the DEC-20 PSL system. At UTAH we have a <PSL> main directory, with a number of sub-directories, each containing a separate class of file, such as common interpreter and compiler sources, DEC-20 sources, VAX sources, 68000 sources, help files, etc. This multi-directory structure enables us to manage the sources for all machines in a reasonable way. Most people running PSL on the DEC-20 will not be interested in all of the files, and certainly will not want to have them all on line. We have therefore created the tape to enable either a multi-directory or single directory model; a set of logical device definitions will be TAKEn by the user (usually inserted in the LOGIN.CMD file). Each separate distribution directory is a separate SAVESET on the attached dumper format tape, and so may be individually restored into a common (<PSL> at Utah) directory, or into appropriate sub-directories (<PSL.*> at Utah). 2. DISCLAIMER 2. DISCLAIMER 2. DISCLAIMER Please be aware that this is a PRELIMINARY release, and some of the files and documentation are not quite complete; we may also have forgotten some files, or sent incorrect versions. We are releasing this preliminary version to you at this time to enhance our collaborative research, and we expect the files to continue to change quite rapidly as the system and distribution is tested. For these reasons please: a. Make a note of ANY problems, concerns, suggestions you have, and send this information to us to aid in improving the system and this distribution mechanism. b. Please do not REDISTRIBUTE any of these files, listings or machine readable form to anyone, and try to restrict access to a small group of users. DEC-20 PSL Release Page 3 3. CONTENTS OF THE TAPE 3. CONTENTS OF THE TAPE 3. CONTENTS OF THE TAPE Attached to this note is a copy of the DUMPER run that created the tape, indicating the savesets, the file names, and sizes needed to restore each saveset. The tape contains the following SAVESETS (current logical names are included in [] after each saveset definition): PSL The executable files (PSL.EXE and RLISP.EXE), this 20-DIST.DOC file, .CMD files to define appropriate logical names and a sample message to announce PSL availability. Also, included are a number of news files announcing new features and changes, some files associated with the NMODE editor and a version of psl (PSLCOMP.EXE) that will compile the argument on the execution line. [psl:] COMP Common compiler, LAP, FASL sources. [pc:] 20COMP DEC-20 specific compiler, LAP and FASL sources. [p20c:] DOC Miscellaneous documentation files, including random notes on new features. [pd:] DOCNMODE NMODE documentation files. [pnd:] EMODE The EMODE screen editor sources and documentation to permit Driver Customization. *.b files for drivers other than TELERAY are on LAP directory, have to load after loading EMODE itself. [pe:] GLISP An object oriented LISP. [pg:] HELP A set of *.HLP files, describing major modules. [ph:] KERNEL Machine Independent kernel sources. [pk:] DEC-20 PSL Release Page 4 P20 DecSystem 20 dependent kernel sources. [p20:] LAP Mostly binary FASL (*.B) files, with some LISP files (*.LAP) for loading multiple .B files of loadable (optional) modules. [pl:] LPT The PSL manual in printable form (has overprinting and underlining), as SCRIBE .LPT files. [plpt:] NMODE The NMODE text editor sources, which is a newer version of EMODE developed at HP Research Laboratories. [pn:] NONKERNEL The sources that are not in the kernel, but are kernel related. [pnk:] PT A set of timing and test files. [pt:] PT20 DecSystem 20 specific test files. [p20t:] UTIL Sources for most utilities, useful as examples of PSL and RLISP code, and for customization. [pu:] WINDOWS The window support functions used by NMODE. [pw:] DEC-20 PSL Release Page 5 4. INSTALLING PSL 4. INSTALLING PSL 4. INSTALLING PSL When installing the PSL system, you have two options for the directory structure. You may utilize a single directory for all of the file, or you may create a directory tree using subdirectories. The Utah group utilizes a directory tree structure and recommends its use when installing a "full" system (that includes all of the sources and the capability of rebuilding any part of the system). However, if only a minimal system is desired, it can be accomplished using a single directory. 4.1. Retrieve Control Files 4.1. Retrieve Control Files 4.1. Retrieve Control Files Whether building a single directory system or multiple directory system, logical name definition files and file restore control files must be first retrieved. Therefore, first mount the dumper tape, at 1600 BPI (verify that there is no write ring in the tape). Then, define X: as the appropriate tape device, MTAn:, or use MOUNT if running a labeled tape system: @DEFINE X: MTAn: or @MOUNT TAPE X: @ASSIGN X: Restore from the first saveset (PSL) the .cmd and .ctl files @DUMPER *tape X: *density 1600 *files *account system-default *restore <*>*.c* *.* *rewind *exit These files will be restored to your connected directory, and should be copied to your main PSL directory after their creation. 4.2. Create a single subdirectory 4.2. Create a single subdirectory 4.2. Create a single subdirectory Create a directory, call it <name> and define a logical device PSL: (a size of about 2600 should be sufficient). Any <name> will do, since the logical device name PSL: will be used. DEC-20 PSL Release Page 6 @DEF PSL: <name> Copy the minimal-* restored files to PSL @COPY minimal-*.* PSL:*.* Now edit the file PSL:minimal-logical-names.cmd to reflect the your choice of <name>. Also put @TAKE <name>minimal-logical-names.cmd in your LOGIN.CMD. Finally, restore the minimal system by DOing the minimal- restore.ctl file: @DO MINIMAL-RESTORE @DEASSIGN X: or @DISMOUNT X: DEC-20 PSL Release Page 7 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM If you plan to do much source modification, or a significant number of rebuilds, or maintain a compatible multiple-machine version of PSL, or attempt retargeting of PSL, a multiple- directory structure such as that at UTAH should be built. The file FULL-LOGICAL-NAMES.CMD, retrieved above should be used as a guide to building the sub-directories. We use at least 16 sub-directories for the Common Sources and DEC-20 specific sources, and have at least an extra two for each new machine. Consult the 20-DIST.LOG file supplied with the PSL tape as a guide for the amount of space required for each sub-directory. The current set of directories for DEC-20 PSL, the logical names that we use, and rough space estimate follows. Build the sub-directories with a somewhat larger working space allocation. Now edit the file PSL:full-logical-names.cmd to reflect the your choice of <name>. Also put @TAKE <name>full-logical-names.cmd in your LOGIN.CMD. 4.4. Build Sub-Directories 4.4. Build Sub-Directories 4.4. Build Sub-Directories Then use the system command, BUILD, to build each sub-directory with the name Pxxx:, as follows. Assistance from the system manager may be required to permit the creation of sub-directories, and the appropriate choice of sub-directory parameters: @BUILD Pxxx: @@PERM nnnn ! choose appropriate size @@WORK wwww ! nnnn+extra @@FILES-ONLY ! Can't login @@GEN 2 ! Retain 1 previous version @@PROTECTION 777700 ! Give group access @@DEFAULT 777700 @ ! that are permitted access To make this process easier, we have created a control file: CREATE-DIRECTORIES.CTL that will build all of the subdirectories with sizes such that restoration of the files will succeed. Therefore, after editing the full-logical-names.cmd file above to reflect the correct logical names, simply DO the CTL file (some systems use MIC instead of DO, so that may be substituted in the following examples) : DEC-20 PSL Release Page 8 @DO CREATE-DIRECTORIES.CTL This will create directories with the following sizes (note the recommended names): define psl: <psl> ! Executable files and misc. ! -- About 6300 for all psl ! -- 1000 for it alone define pc: <psl.comp> ! Compiler sources ! -- 125 pages define p20c: <psl.20-comp> ! 20 Specific Compiler sources ! -- 75 pages define pd: <psl.doc> ! Documentation files ! -- 275 pages define pnd: <psl.doc-nmode> ! NMODE documentation files ! -- 150 pages define pe: <psl.emode> ! EMODE support and drivers ! -- 225 pages define pg: <psl.glisp> ! GLISP sources ! -- 425 pages define ph: <psl.help> ! Help files ! -- 125 pages define pk: <psl.kernel> ! Kernel Source files ! -- 225 pages define p20k: <psl.20-kernel> ! 20 Specific Kernel Sources ! -- 500 pages define pl: <psl.lap> ! LAP files ! -- 700 pages define plpt: <psl.lpt> ! Printer version of Docs ! -- 450 pages define pn: <psl.nmode> ! NMODE editor files ! -- 375 pages define pnk: <psl.nonkernel> ! Nonkernel Sources ! -- 5 pages define pt: <psl.tests> ! Test files ! -- 200 pages define p20t: <psl.20-tests> ! 20 Specific Test files ! -- 600 pages define pu: <psl.util> ! Utility program sources ! -- 600 pages define p20u: <psl.20-util> ! 20 Specific Utility files ! -- 75 pages define pw: <psl.windows> ! NMODE Window files ! -- 75 pages Finally, restore the full system by DOing the full-restore.ctl file: DEC-20 PSL Release Page 9 @DO FULL-RESTORE @DEASSIGN X: or @DISMOUNT X: 4.5. Announce the System 4.5. Announce the System 4.5. Announce the System Send out a Message to all those interested in using PSL. The file BBOARD.MSG is a suggested start. Edit as you see fit, but please REMIND people not to re-distribute the PSL system and sources. You may also want to set the directory protection to 775200 and limit access only to those that you feel should have access at this time. 4.6. Summary of Restoration Process 4.6. Summary of Restoration Process 4.6. Summary of Restoration Process In summary, first retrieve the cmd and ctl files from the first saveset on the DUMPER tape. Then choose a single or multiple directory system and edit the appropriate logical name file to reflect the directory name(s). If creating a multiple directory system use the create-directories.ctl control file to build each directory. Then run the appropriate file retrieval control file. Finally, announce the system to any interested users. 5. REBUILDING LOADABLE MODULES 5. REBUILDING LOADABLE MODULES 5. REBUILDING LOADABLE MODULES Most of the utilities, and many of the more experimental parts of the system are kept as binary FASL files (with extensions .b) on the PL: directory. EMODE and NMODE are currently the only major sub-systems that have there own set of sub-directories. In some cases (usually large sub-systems, or sub-systems that share modules) there are a number of .B files, and a .LAP file that loads each .B file in turn. The PSL LOAD function will look first for a .B file, then a .LAP file first on the user directory, then on PL: (both this "search" path and the order of extensions can be changed). In order to ease the task of rebuilding and modifying the .B files, we have a small utility, BUILD. To use BUILD for a module you call xxxx, prepare a file called xxxx.BUILD, which has RLISP syntax commands for loading the appropriate source files. The file can also have various CompileTime options, including the loading of various .B files to set up the correct compilation environment. DEC-20 PSL Release Page 10 Then run PSL:RLISP, LOAD BUILD; and finally enter BUILD 'xxxx; this will do a FASLOUT to "PL:xxxx", input the xxxx.BUILD file, and finally close the FASL file. The target file "PL:xxxx" is constructed using the variable "BuildFileFormat!*", initialized in the file PU:Build.Red . For example, consider the contents of PU:Gsort.Build: CompileTime load Syslisp; in "gsort.red"$ Note that the SYSLISP module is required, since some of the fast sorting functions in GSORT are written in SYSLISP mode. GSORT is then rebuilt by the sequence: PSL:RLISP LOAD BUILD; BUILD 'GSORT; QUIT; This is such a common sequence that a MIC file (MIC is a parameterized DO facility) PU:BUILD.MIC is provided, and is used by passing the module name to MIC, after connecting to PU: @mic BUILD GSORT is all that is required. 6. REBUILDING THE INTERPRETER 6. REBUILDING THE INTERPRETER 6. REBUILDING THE INTERPRETER A running `rlisp' is required to rebuild the basic interpreter, since the entire system is written in itself. The kernel modules, rather than being compiled to FASL files, are compiled _____ ____ to assembly code (MACRO) and linked using the system loader LINK. ____ _____ _____ ___ The command file P20C:DEC20-cross.CTL is executed to produce the _ _____ _____ cross compiler, S:DEC20-cross (S: should be set to an appropriate scratch directory). The modules in the kernel are represented by ___ _____ __ ______ __ __ the files P20:*.build. There is a program PU:kernel.sl or __ ______ _ PL:kernel.b which generates command files for building the kernel DEC-20 PSL Release Page 11 ___ __ ______ ___ __ when parameterized for Tops-20 by P20:20-kernel-gen.sl. The specific modules which are in the kernel are only listed in this ______ file, in the call to the function kernel. This generates a file ____ ___ ____ _____ xxxx.CTL for each xxxx.build. 6.1. Complete Kernel Rebuild 6.1. Complete Kernel Rebuild 6.1. Complete Kernel Rebuild A complete rebuild is accomplished by the following steps. At Utah we use a <scratch> directory for some intermediate files. Define S: to be this directory or some other appropriate location that can be deleted when done. Below we use @SUBMIT xxxx.CTL to run batch jobs; on some systems, @DO xxxx.CTL can be used instead, or on others, @MIC xxxx.CTL may be used. Begin by defining S: as <scratch> or other scratch directory: @DEFINE S: <scratch> Now connect to <psl.20-comp> and rebuild NEW-DEC20-CROSS.EXE: @CONN P20C: @SUBMIT NEW-DEC20-CROSS.CTL Copy the <psl.comp>BARE-PSL.SYM to 20.SYM, and regenerate the appropriate .CTL files. This saves the old 20.SYM as PREVIOUS-20.SYM: @CONN P20: @SUBMIT P20:FRESH-KERNEL.CTL Rebuild each module (xxxx) in turn, using its xxxx.CTL. This creates xxxx.MAC and Dxxxx.MAC files, and assembles each to make xxxx.REL and Dxxxx.REL. The entire set is submitted with the file ALL-KERNEL.CTL, which submits each file in turn. (Note that these must be done sequentially, not simultaneously. If you have more than one batch stream, make sure that these are run one at a time): @SUBMIT ALL-KERNEL.CTL DEC-20 PSL Release Page 12 Build the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: @SUBMIT P20:MAIN.CTL Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @SUBMIT P20:PSL-LINK.CTL Execute and save as PSL.EXE, reading appropriate xxxx.INIT files (note, each site usually customizes the PSL environment to suit their needs, therefore we recommend that you create your own version of Make-psl.ctl to perform this task). @SUBMIT P20:MAKE-PSL.CTL Finally, run MAKE-RLISP.CTL as needed: @SUBMIT P20:MAKE-RLISP.CTL Rlisp.exe and Psl.exe will be saved on the <PSL> directory. You now may want to delete any xxx.log files that where created. @DEL P20:*.LOG @DEL P20C:*.LOG 6.2. Partial or Incremental Kernel Rebuild 6.2. Partial or Incremental Kernel Rebuild 6.2. Partial or Incremental Kernel Rebuild Often, only a single kernel file needs to be changed, and a complete rebuild is not needed. The PSL kernel building process permits a (semi-)independent rebuilding of modules, by maintaining the 20.SYM file to record Identifier Numbers, etc. The 20.SYM file from the recent full-rebuild, and xxxx.INIT files are required, as are the "xxxx.REL" and "Dxxxx.REL". The partial rebuild will replace the "mmmm.REL", "Dmmmm.REL" and "mmmm.INIT" files, modify "20.SYM", and then rebuild the MAIN module. Assuming that a recent full rebuild has been done, a partial rebuild of module "mmmm", is accomplished by the following steps. As above, S: is required for "Scratch" space. DEC-20 PSL Release Page 13 Define S: as <scratch> or other scratch directory: @DEFINE S: <scratch> Rebuild DEC20-CROSS.EXE, if needed: @SUBMIT P20C:DEC20-CROSS.CTL Rebuild the module (mmmm), using its mmmm.CTL. This creates mmmm.MAC and Dmmmm.MAC files, and assembled each to make mmmm.REL and Dmmmm.REL. See the file ALL-KERNEL.CTL for current modules. @SUBMIT P20:mmmm.CTL Other modules can be done after this Rebuild the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: (This step can be omitted if 20.SYM has not been changed by the incremental recompilation.) @SUBMIT P20:MAIN.CTL Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @SUBMIT P20:PSL-LINK.CTL Execute and save as PSL.EXE, reading appropriate xxxx.INIT files: @SUBMIT P20:MAKE-PSL.CTL Finally, run MAKE-RLISP as needed: @SUBMIT P20:MAKE-RLISP.CTL Note that 20.SYM may be changed slightly to reflect any new symbols encountered, and certain generated symbols. Occasionally, DEC-20 PSL Release Page 14 repeated building of certain modules can cause 20.SYM to grow, and then a full rebuild may be required. 6.3. Rebuilding RLISP.EXE from PSL.EXE 6.3. Rebuilding RLISP.EXE from PSL.EXE 6.3. Rebuilding RLISP.EXE from PSL.EXE The PSL executable file, PSL.EXE, is a fairly bare system, and is usually extended by loading appropriate utilities, and then saving this as a new executable. We have provided RLISP.EXE, which includes the compiler, and the RLISP parser. RLISP.EXE is built from PSL.EXE by the following commands: @TAKE PSL:minimal-logical-names.cmd @PSL:PSL.EXE (LOAD COMPILER RLISP INIT-FILE) % Also LOAD any other modules that % should be in your "standard" system (SAVESYSTEM "PSL 3.1 Rlisp" "PSL:rlisp.exe" '((Read-init-file "rlisp"))) % The string is the Welcome Message, the save file % name and the startup expression to read rlisp.init. (QUIT) We have provided a command file, P20:MAKE-RLISP.CTL for this purpose. Edit it to reflect any modules that local usage desires in the basic system (EMODE, PRLISP, USEFUL, etc. are common choices). In a similar fashion, a customized PSL.EXE could be maintained instead of the "bare" version we provide. In order to avoid destroying PSL entirely, we suggest that you maintain a copy of the supplied PSL.EXE as BARE-PSL.EXE, and customize your PSL.EXE from it. 7. RELATIONSHIP TO PSL 3.0 7. RELATIONSHIP TO PSL 3.0 7. RELATIONSHIP TO PSL 3.0 This new version 3.1 is a complete release, and totally replaces the previous PSL 3.0 that underwent limited __ ___ ___ ___ __ ____ ___ distribution. The files pd:bug-fix.log and pd:bugs.txt record many of the changes and bug fixes that occurred since version 3.0. DEC-20 PSL Release Page 15 8. FUTURE UPDATES 8. FUTURE UPDATES 8. FUTURE UPDATES It is currently envisioned that future updates will still be complete releases. It is therefore suggested that you a. Retain this distribution tape in case you may have to compare files. b. Do not make any changes on these distributed directories. If you must make your own bug fixes, it is suggested that you put the changed files on some ____ other directories, such as pnew:. They can then be compared with any new files sent out in subsequent releases. DEC-20 PSL Release Page i Table of Contents Table of Contents Table of Contents 1. INTRODUCTION 2 2. DISCLAIMER 2 3. CONTENTS OF THE TAPE 3 4. INSTALLING PSL 5 4.1. Retrieve Control Files 5 4.2. Create a single subdirectory 5 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 7 4.4. Build Sub-Directories 7 4.5. Announce the System 9 4.6. Summary of Restoration Process 9 5. REBUILDING LOADABLE MODULES 9 6. REBUILDING THE INTERPRETER 10 6.1. Complete Kernel Rebuild 11 6.2. Partial or Incremental Kernel Rebuild 12 6.3. Rebuilding RLISP.EXE from PSL.EXE 14 7. RELATIONSHIP TO PSL 3.0 14 8. FUTURE UPDATES 15 |
Added psl-1983/20-kernel/20-kernel-gen.ctl version [0fb43c4149].
> > > | 1 2 3 | @psl:psl *(lapin "p20:20-kernel-gen.sl") *(quit) |
Added psl-1983/20-kernel/20-kernel-gen.sl version [827c70bc8a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-KERNEL-GEN.SL - Generate scripts for building Dec-20 PSL kernel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.20-INTERP>20-KERNEL-GEN.SL.15, 7-Jun-82 12:48:19, Edit by BENSON % Converted kernel-file-name* to all-kernel-script... % <PSL.20-INTERP>20-KERNEL-GEN.SL.14, 6-Jun-82 05:29:21, Edit by GRISS % Add kernel-file-name* (compiletime (load kernel)) (compiletime (setq *EOLInStringOK T)) (loadtime (imports '(kernel))) (setq command-file-name* "%w.ctl") (setq command-file-format* "define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut ""%w""; in ""%w.build""; ASMEnd; quit; compile %w.mac, d%w.mac delete %w.mac, d%w.mac ") (setq init-file-name* "psl.init") (setq init-file-format* "(lapin ""%w.init"") ") (setq all-kernel-script-name* "all-kernel.ctl") (setq all-kernel-script-format* "submit %w.ctl ") (setq code-object-file-name* "%w.rel") (setq data-object-file-name* "d%w.rel") (setq link-script-name* "psl-link.ctl") (setq link-script-format* "cd S: define DSK:, DSK:, P20: LINK /nosymbol nil.rel /set:.low.:202 %e /save s:bpsl.exe /go ") (setq script-file-name-separator* " ") (kernel '(types randm alloc arith debg error eval extra fasl io macro prop symbl sysio tloop main heap)) |
Added psl-1983/20-kernel/20.sym version [d07e412040].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !') ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADQUOTEDEXPRESSION)) (PUT (QUOTE !() ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADLISTORDOTTEDPAIR)) (PUT (QUOTE !)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADRIGHTPAREN)) (PUT (QUOTE ![) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADVECTOR)) (PUT (MKID (CHAR EOF)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADEOF)) (INITOBLIST) (PUT (QUOTE EOF) ( QUOTE CHARCONST) (CHAR (CNTRL Z)))))) (SETQ ORDEREDIDLIST!* (QUOTE (ID2INT NONIDERROR INT2ID TYPEERROR NONINTEGERERROR INT2SYS LISP2CHAR NONCHARACTERERROR INT2CODE SYS2INT GTFIXN ID2STRING STRING2VECTOR GTVECT NONSTRINGERROR VECTOR2STRING GTSTR NONVECTORERROR LIST2STRING LENGTH NONPAIRERROR STRING2LIST CONS LIST2VECTOR VECTOR2LIST GETV BLDMSG STDERROR INDEXERROR PUTV UPBV EVECTORP EGETV EPUTV EUPBV INDX RANGEERROR NONSEQUENCEERROR SETINDX SUB SUBSEQ GTWRDS GTHALFWORDS NCONS TCONC SETSUB SETSUBSEQ CONCAT APPEND SIZE MKSTRING NONPOSITIVEINTEGERERROR MAKE!-BYTES MAKE!-HALFWORDS MAKE!-WORDS MAKE!-VECTOR STRING VECTOR CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP CAR CDR RPLACA RPLACD FIXP DIGIT LITER EQN LISPEQUAL STRINGEQUAL EQSTR EQUAL CAAAAR CAAAR CAAADR CAADAR CAADR CAADDR CADAAR CADAR CADADR CADDAR CADDR CADDDR CDAAAR CDAAR CDAADR CDADAR CDADR CDADDR CDDAAR CDDAR CDDADR CDDDAR CDDDR CDDDDR CAAR CADR CDAR CDDR SAFECAR SAFECDR ATOM CONSTANTP NULL NUMBERP EXPT MKQUOTE LIST3 CONTINUABLEERROR GREATERP DIFFERENCE MINUSP TIMES2 ADD1 QUOTIENT PLUS2 LIST EVLIS QUOTE EXPR DE LIST2 LIST4 PUTD FUNCTION LAMBDA FEXPR DF MACRO DM NEXPR DN SETQ EVAL SET PROG2 PROGN EVPROGN AND EVAND OR EVOR COND EVCOND NOT ABS MINUS DIVIDE ZEROP REMAINDER XCONS MAX ROBUSTEXPAND MAX2 LESSP MIN MIN2 PLUS TIMES MAP FASTAPPLY MAPC MAPCAN NCONC MAPCON MAPCAR MAPLIST ASSOC SASSOC PAIR SUBLIS DEFLIST PUT DELETE MEMBER MEMQ REVERSE SUBST EXPAND CHANNELPRINT CHANNELPRIN1 CHANNELTERPRI PRINT OUT!* NEQ NE GEQ LEQ EQCAR EXPRP GETD MACROP FEXPRP NEXPRP COPYD RECIP FIRST SECOND THIRD FOURTH REST REVERSIP SUBSTIP DELETIP DELQ DEL DELQIP ATSOC ASS MEM RASSOC DELASC DELASCIP DELATQ DELATQIP SUBLA RPLACW LASTCAR LASTPAIR COPY NTH SUB1 PNTH ACONC LCONC MAP2 MAPC2 CHANNELPRIN2T CHANNELPRIN2 PRIN2T CHANNELSPACES CHANNELWRITECHAR SPACES CHANNELTAB CHANNELPOSN TAB FILEP PUTC SPACES2 CHANNELSPACES2 LIST2SET LIST2SETQ ADJOIN ADJOINQ UNION UNIONQ XN XNQ INTERSECTION INTERSECTIONQ KNOWN!-FREE!-SPACE GTHEAP FATALERROR !%RECLAIM GC!-TRAP GC!-TRAP!-LEVEL SET!-GC!-TRAP!-LEVEL DELHEAP GTCONSTSTR GTBPS GTEVECT GTFLTN GTID RECLAIM DELBPS GTWARRAY DELWARRAY COPYSTRINGTOFROM COPYSTRING COPYWARRAY COPYVECTORTOFROM COPYVECTOR COPYWRDSTOFROM COPYWRDS TOTALCOPY MKVECT MKEVECTOR MKEVECT LIST5 !*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL ERRORPRINTF TIMC QUIT RETURNNIL RETURNFIRSTARG LAND LOR LXOR LSHIFT LSH LNOT FIX FLOAT ONEP DEBUG TR EVLOAD TRST QEDITFNS !*EXPERT !*VERBOSE EDITF EDIT YESP PROMPTSTRING!* FASTBIND TERPRI EDITORREADER!* EDITORPRINTER!* FASTUNBIND READ CL HELP BREAK EHELP PL UP OK DISPLAYHELPFILE EDITOR IGNOREDINBACKTRACE!* INTERPRETERFUNCTIONS!* INTERPBACKTRACE PRINTF BACKTRACE RETURNADDRESSP ADDR2ID VERBOSEBACKTRACE OPTIONS!* WRITECHAR CHANNELWRITEUNKNOWNITEM CODE!-ADDRESS!-TO!-SYMBOL PRIN1 ERROR NO YES RDS ERROUT!* WRS ERRORSET CURSYM!* !*SEMICOL!* ERRORFORM!* !*CONTINUABLEERROR EMSG!* !*BREAK !*EMSGP MAXBREAKLEVEL!* BREAKLEVEL!* FLATSIZE USAGETYPEERROR NONNUMBERERROR NONWORDS NONIOCHANNELERROR !*BACKTRACE !*INNER!*BACKTRACE THROW !$ERROR!$ ERRSET CATCH CATCHSETUP THROWSIGNAL!* !%UNCATCH CHANNELNOTOPEN CHANNELERROR WRITEONLYCHANNEL READONLYCHANNEL ILLEGALSTANDARDCHANNELCLOSE IOERROR CODEAPPLY CODEEVALAPPLY BINDEVAL LBIND1 COMPILEDCALLINGINTERPRETED BSTACKOVERFLOW RESTOREENVIRONMENT !*LAMBDALINK UNDEFINEDFUNCTION UNBINDN APPLY FUNBOUNDP FCODEP GETFCODEPOINTER GET VALUECELL GETFNTYPE !&!&VALUE!&!& THROWTAG!* CATCH!-ALL UNWIND!-ALL !&!&THROWN!&!& !$UNWIND!-PROTECT!$ !&!&TAG!&!& !%THROW UNWIND!-PROTECT !*CATCH !*THROW RESET CAPTUREENVIRONMENT !%CLEAR!-CATCH!-STACK PROGBODY!* PROGJUMPTABLE!* PROG PBIND1 !$PROG!$ GO RETURN SYSTEM_LIST!* DATE DUMPLISP BINARYOPENREAD DEC20OPEN BINARYOPENWRITE VALUECELLLOCATION !*WRITINGFASLFILE NEWBITTABLEENTRY!* FINDIDNUMBER MAKERELOCHALFWORD EXTRAREGLOCATION FUNCTIONCELLLOCATION FASLIN INTERN PUTENTRY LOADDIRECTORIES!* LOADEXTENSIONS!* !*VERBOSELOAD !*PRINTLOADNAMES LOAD LOAD1 RELOAD EVRELOAD !*USERMODE !*REDEFMSG !*INSIDELOAD !*LOWER PENDINGLOADS!* IMPORTS PRETTYPRINT DEFSTRUCT STEP MINI EMODE INVOKE RCREF CREFON COMPILER COMPD FASLOUT BUG EXEC MM TERMINALINPUTHANDLER COMPRESSREADCHAR DEC20WRITECHAR TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR !$EOL!$ CHANNELREADCHAR READCHAR IN!* CHANNELUNREADCHAR UNREADCHAR OPEN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT SYSTEMOPENFILESPECIAL SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!* SPECIAL OUTPUT INPUT CLOSE SYSTEMMARKASCLOSEDCHANNEL SPECIALRDSACTION!* STDIN!* SPECIALWRSACTION!* STDOUT!* CHANNELEJECT EJECT CHANNELLINELENGTH LINELENGTH POSN CHANNELLPOSN LPOSN CHANNELREADCH !*RAISE READCH PRINC CHANNELPRINC CURRENTREADMACROINDICATOR!* CHANNELREADTOKENWITHHOOKS CHANNELREADTOKEN TOKTYPE!* CURRENTSCANTABLE!* CHANNELREAD LISPSCANTABLE!* LISPREADMACRO MAKEINPUTAVAILABLE !*INSIDESTRUCTUREREAD CHANNELREADEOF !$EOF!$ CHANNELREADQUOTEDEXPRESSION CHANNELREADLISTORDOTTEDPAIR CHANNELREADRIGHTPAREN CHANNELREADVECTOR !*COMPRESSING !*EOLINSTRINGOK NEWID MAKESTRINGINTOLISPINTEGER DIGITTONUMBER PACKAGE CURRENTPACKAGE!* GLOBAL RATOM READLINE CHANNELREADLINE OUTPUTBASE!* IDESCAPECHAR!* CHANNELWRITESTRING WRITESTRING CHANNELWRITESYSINTEGER CHANNELWRITEBITSTRAUX WRITESYSINTEGER CHANNELWRITEFIXNUM CHANNELWRITEINTEGER CHANNELWRITESYSFLOAT WRITEFLOAT CHANNELWRITEFLOAT CHANNELPRINTSTRING CHANNELWRITEID CHANNELWRITEUNBOUND CHANNELPRINTID CHANNELPRINTUNBOUND CHANNELWRITECODEPOINTER CHANNELWRITEBLANKOREOL CHANNELWRITEPAIR PRINLEVEL PRINLENGTH RECURSIVECHANNELPRIN2 CHANNELPRINTPAIR RECURSIVECHANNELPRIN1 CHANNELWRITEVECTOR CHANNELPRINTVECTOR CHANNELWRITEEVECTOR OBJECT!-GET!-HANDLER!-QUIETLY CHANNELPRIN CHANNELPRINTEVECTOR CHANNELWRITEWORDS CHANNELWRITEHALFWORDS CHANNELWRITEBYTES PRIN2 FORMATFORPRINTF!* PRIN2L ERRPRIN CHANNELPRINTF EXPLODEENDPOINTER!* EXPLODE EXPLODE2 FLATSIZE2 COMPRESSERROR COMPRESSLIST!* CLEARCOMPRESSCHANNEL COMPRESS IMPLODE CHANNELTYI CHANNELTYO TYI TYO COMMENTOUTCODE COMPILETIME BOTHTIMES LOADTIME STARTUPTIME CONTERROR OTHERWISE DEFAULT CASE RANGE SETF EXPANDSETF SETF!-EXPAND ASSIGN!-OP ONOFF!* MKFLAGVAR SIMPFG ON OFF !#ARG DS DEFCONST EVDEFCONST CONST STRINGGENSYM STRINGGENSYM!* FOREACH COLLECT JOIN CONC IN DO EXIT !$LOOP!$ NEXT WHILE REPEAT FOR GENSYM MK!*SQ SIMP BIN FLAMBDALINKP MAKEFUNBOUND MAKEFLAMBDALINK MAKEFCODE PROP SETPROP FLAGP TYPE FLAG FLAG1 REMFLAG REMFLAG1 REMPROP REMPROPL UNBOUNDP VARTYPE FLUID FLUID1 FLUIDP GLOBAL1 GLOBALP UNFLUID UNFLUID1 REMD !*COMP USER LOSE CODE!-NUMBER!-OF!-ARGUMENTS BSTACKUNDERFLOW CLEARBINDINGS MAKEUNBOUND HASHFUNCTION REMOB INTERNP INTERNGENSYM MAPOBL GLOBALLOOKUP GLOBALINSTALL GLOBALREMOVE INITOBLIST DEC20READCHAR !*ECHO CLEARIO DEC20CLOSECHANNEL !*DEFN BREAKVALUE!* !*QUITBREAK BREAKIN!* BREAKOUT!* TOPLOOPNAME!* TOPLOOPEVAL!* BREAKEVAL!* BREAKNAME!* TOPLOOPPRINT!* TOPLOOPREAD!* TOPLOOP !$BREAK!$ BREAKEVAL BREAKFUNCTION BREAKQUIT BREAKCONTINUE BREAKRETRY HELPBREAK BREAKERRMSG BREAKEDIT TOPLOOPLEVEL!* HISTORYCOUNT!* LISPBANNER!* !*OUTPUT SEMIC!* HISTORYLIST!* !*TIME TIME !*NONIL !$EXITTOPLOOP!$ DFPRINT!* IGNORE INP REDO ANS HIST CLEAR STANDARDLISP PRINTWITHFRESHLINE SAVESYSTEM INITFORMS!* EVALINITFORMS DSKIN DSKINEVAL LAPIN))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 841)) (SETQ STRINGGENSYM!* (QUOTE "L3692")) (PUT (QUOTE TWOARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1368")) (PUT (QUOTE RELOAD) (QUOTE ENTRYPOINT) (QUOTE RELOAD)) (PUT (QUOTE RELOAD) (QUOTE IDNUMBER) (QUOTE 568)) (PUT (QUOTE TWOARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1385")) (PUT (QUOTE INTLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1515")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE NEQ) (QUOTE ENTRYPOINT) (QUOTE NEQ)) (PUT (QUOTE NEQ) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE LIST2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0059")) (PUT (QUOTE LIST2STRING) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE SPECIALRDSACTION!*) (QUOTE IDNUMBER) (QUOTE 614)) (FLAG (QUOTE (SPECIALRDSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GLOBALLOOKUP) (QUOTE ENTRYPOINT) (QUOTE "L3479")) (PUT (QUOTE GLOBALLOOKUP) (QUOTE IDNUMBER) (QUOTE 787)) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L2911")) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE IDNUMBER) (QUOTE 702)) (PUT (QUOTE DEFSTRUCT) (QUOTE ENTRYPOINT) (QUOTE "L2240")) (PUT (QUOTE DEFSTRUCT) (QUOTE IDNUMBER) (QUOTE 577)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE MAKERELOCHALFWORD) (QUOTE IDNUMBER) (QUOTE 556)) (PUT (QUOTE BACKTRACE1) (QUOTE ENTRYPOINT) (QUOTE "L1704")) (PUT (QUOTE DO) (QUOTE IDNUMBER) (QUOTE 740)) (PUT (QUOTE THROWSIGNAL!*) (QUOTE IDNUMBER) (QUOTE 500)) (FLAG (QUOTE (THROWSIGNAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE REMFLAG) (QUOTE ENTRYPOINT) (QUOTE "L3218")) (PUT (QUOTE REMFLAG) (QUOTE IDNUMBER) (QUOTE 761)) (PUT (QUOTE PRINLEVEL) (QUOTE IDNUMBER) (QUOTE 677)) (FLAG (QUOTE (PRINLEVEL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EJECT) (QUOTE ENTRYPOINT) (QUOTE EJECT)) (PUT (QUOTE EJECT) (QUOTE IDNUMBER) (QUOTE 619)) (PUT (QUOTE LISPREADMACRO) (QUOTE IDNUMBER) (QUOTE 637)) (PUT (QUOTE STRING2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0068")) (PUT (QUOTE STRING2LIST) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE EXIT) (QUOTE ENTRYPOINT) (QUOTE EXIT)) (PUT (QUOTE EXIT) (QUOTE IDNUMBER) (QUOTE 741)) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3527")) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 794)) (PUT (QUOTE ONEARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1397")) (PUT (QUOTE STRING2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0041")) (PUT (QUOTE STRING2VECTOR) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1851")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE BACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1699")) (PUT (QUOTE BACKTRACE) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1847")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 507)) (PUT (QUOTE RETURNNIL) (QUOTE ENTRYPOINT) (QUOTE "L1422")) (PUT (QUOTE RETURNNIL) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2584")) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 661)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1109")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE GENSYM) (QUOTE ENTRYPOINT) (QUOTE GENSYM)) (PUT (QUOTE GENSYM) (QUOTE IDNUMBER) (QUOTE 747)) (PUT (QUOTE ONEARGPREDICATEDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1410")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1716")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE IDNUMBER) (QUOTE 466)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L3533")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 603)) (PUT (QUOTE !*EMSGP) (QUOTE IDNUMBER) (QUOTE 485)) (PUT (QUOTE !*EMSGP) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE TYI) (QUOTE ENTRYPOINT) (QUOTE TYI)) (PUT (QUOTE TYI) (QUOTE IDNUMBER) (QUOTE 707)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3141")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 519)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L1732")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 744)) (PUT (QUOTE STANDARDLISP) (QUOTE ENTRYPOINT) (QUOTE "L3650")) (PUT (QUOTE STANDARDLISP) (QUOTE IDNUMBER) (QUOTE 833)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE !*OUTPUT) (QUOTE IDNUMBER) (QUOTE 819)) (PUT (QUOTE !*OUTPUT) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SECOND) (QUOTE ENTRYPOINT) (QUOTE SECOND)) (PUT (QUOTE SECOND) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 693)) (PUT (QUOTE CURSYM!*) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE CHANNELTYI) (QUOTE ENTRYPOINT) (QUOTE "L2917")) (PUT (QUOTE CHANNELTYI) (QUOTE IDNUMBER) (QUOTE 705)) (PUT (QUOTE FLOATREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1471")) (PUT (QUOTE SASSOC) (QUOTE ENTRYPOINT) (QUOTE SASSOC)) (PUT (QUOTE SASSOC) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE ADDR2ID) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE GC!-TRAP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE ROBUSTEXPAND) (QUOTE ENTRYPOINT) (QUOTE "L0815")) (PUT (QUOTE ROBUSTEXPAND) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE INTREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1470")) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 8209)) (PUT (QUOTE TWOARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1369")) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE DEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3609")) (PUT (QUOTE CURRENTPACKAGE!*) (QUOTE IDNUMBER) (QUOTE 652)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE ENTRYPOINT) (QUOTE "L2048")) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 538)) (PUT (QUOTE SETSUBSEQ) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE SETSUBSEQ) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE PNTH) (QUOTE ENTRYPOINT) (QUOTE PNTH)) (PUT (QUOTE PNTH) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE PACKAGE) (QUOTE ENTRYPOINT) (QUOTE "L2572")) (PUT (QUOTE PACKAGE) (QUOTE IDNUMBER) (QUOTE 651)) (PUT (QUOTE MAKEDS) (QUOTE ENTRYPOINT) (QUOTE MAKEDS)) (PUT (QUOTE !*USERMODE) (QUOTE IDNUMBER) (QUOTE 570)) (FLAG (QUOTE (!*USERMODE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*REDEFMSG) (QUOTE IDNUMBER) (QUOTE 571)) (PUT (QUOTE !*REDEFMSG) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SAVE!-INTO!-FILE) (QUOTE ENTRYPOINT) (QUOTE "L2114")) (PUT (QUOTE CHANNELPRINTID) (QUOTE ENTRYPOINT) (QUOTE "L2617")) (PUT (QUOTE CHANNELPRINTID) (QUOTE IDNUMBER) (QUOTE 672)) (PUT (QUOTE BUG) (QUOTE ENTRYPOINT) (QUOTE BUG)) (PUT (QUOTE BUG) (QUOTE IDNUMBER) (QUOTE 587)) (PUT (QUOTE DEFAULT) (QUOTE IDNUMBER) (QUOTE 716)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE INITIALVALUE) (QUOTE (EVAL APPLY FASTAPPLY CODEAPPLY CODEEVALAPPLY CATCH ERRORSET EVPROGN TOPLOOP BREAKEVAL BINDEVAL BREAK MAIN))) (PUT (QUOTE CLEAR) (QUOTE IDNUMBER) (QUOTE 832)) (PUT (QUOTE LPOSN) (QUOTE ENTRYPOINT) (QUOTE LPOSN)) (PUT (QUOTE LPOSN) (QUOTE IDNUMBER) (QUOTE 624)) (PUT (QUOTE DOPNTH) (QUOTE ENTRYPOINT) (QUOTE DOPNTH)) (PUT (QUOTE BREAKOUT!*) (QUOTE IDNUMBER) (QUOTE 799)) (FLAG (QUOTE (BREAKOUT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE STRINGGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3050")) (PUT (QUOTE STRINGGENSYM) (QUOTE IDNUMBER) (QUOTE 733)) (PUT (QUOTE FLOATSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1531")) (PUT (QUOTE TAB) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE TAB) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1144")) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L3274")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 772)) (PUT (QUOTE MEMBER) (QUOTE ENTRYPOINT) (QUOTE MEMBER)) (PUT (QUOTE MEMBER) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE EXPRP) (QUOTE ENTRYPOINT) (QUOTE EXPRP)) (PUT (QUOTE EXPRP) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE LNOT) (QUOTE ENTRYPOINT) (QUOTE LNOT)) (PUT (QUOTE LNOT) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE ONEARGPREDICATEDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1409")) (PUT (QUOTE ACONC) (QUOTE ENTRYPOINT) (QUOTE ACONC)) (PUT (QUOTE ACONC) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE PRETTYPRINT) (QUOTE ENTRYPOINT) (QUOTE "L2236")) (PUT (QUOTE PRETTYPRINT) (QUOTE IDNUMBER) (QUOTE 576)) (PUT (QUOTE !$PROG!$) (QUOTE IDNUMBER) (QUOTE 543)) (PUT (QUOTE ERRSET) (QUOTE ENTRYPOINT) (QUOTE ERRSET)) (PUT (QUOTE ERRSET) (QUOTE IDNUMBER) (QUOTE 497)) (PUT (QUOTE DIVIDE) (QUOTE ENTRYPOINT) (QUOTE DIVIDE)) (PUT (QUOTE DIVIDE) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELETE) (QUOTE ENTRYPOINT) (QUOTE DELETE)) (PUT (QUOTE DELETE) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE NONINTEGER2ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1391")) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 611)) (PUT (QUOTE PRINLENGTH) (QUOTE IDNUMBER) (QUOTE 678)) (FLAG (QUOTE (PRINLENGTH)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE XNQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE XNQ) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE TYO) (QUOTE ENTRYPOINT) (QUOTE TYO)) (PUT (QUOTE TYO) (QUOTE IDNUMBER) (QUOTE 708)) (PUT (QUOTE REMD) (QUOTE ENTRYPOINT) (QUOTE REMD)) (PUT (QUOTE REMD) (QUOTE IDNUMBER) (QUOTE 774)) (PUT (QUOTE !*THROW) (QUOTE ENTRYPOINT) (QUOTE "L2036")) (PUT (QUOTE !*THROW) (QUOTE IDNUMBER) (QUOTE 535)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0686")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE ERRORFORM!*) (QUOTE IDNUMBER) (QUOTE 481)) (FLAG (QUOTE (ERRORFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*INSIDELOAD) (QUOTE IDNUMBER) (QUOTE 572)) (FLAG (QUOTE (!*INSIDELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1567")) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 511)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE MAP) (QUOTE ENTRYPOINT) (QUOTE MAP)) (PUT (QUOTE MAP) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE FOURTH) (QUOTE ENTRYPOINT) (QUOTE FOURTH)) (PUT (QUOTE FOURTH) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE LXOR) (QUOTE ENTRYPOINT) (QUOTE LXOR)) (PUT (QUOTE LXOR) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE COMPD) (QUOTE ENTRYPOINT) (QUOTE COMPD)) (PUT (QUOTE COMPD) (QUOTE IDNUMBER) (QUOTE 585)) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2711")) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE IDNUMBER) (QUOTE 683)) (PUT (QUOTE UNFLUID1) (QUOTE ENTRYPOINT) (QUOTE "L3279")) (PUT (QUOTE UNFLUID1) (QUOTE IDNUMBER) (QUOTE 773)) (PUT (QUOTE BOTHTIMES) (QUOTE ENTRYPOINT) (QUOTE "L2921")) (PUT (QUOTE BOTHTIMES) (QUOTE IDNUMBER) (QUOTE 711)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2275")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L3172")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 521)) (PUT (QUOTE VALUECELL) (QUOTE ENTRYPOINT) (QUOTE "L3388")) (PUT (QUOTE VALUECELL) (QUOTE IDNUMBER) (QUOTE 523)) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2678")) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE IDNUMBER) (QUOTE 680)) (PUT (QUOTE WRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2596")) (PUT (QUOTE WRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 663)) (PUT (QUOTE BACKTRACERANGE) (QUOTE ENTRYPOINT) (QUOTE "L1696")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L1095")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE DIGIT) (QUOTE ENTRYPOINT) (QUOTE DIGIT)) (PUT (QUOTE DIGIT) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE FASLIN) (QUOTE ENTRYPOINT) (QUOTE FASLIN)) (PUT (QUOTE FASLIN) (QUOTE IDNUMBER) (QUOTE 559)) (PUT (QUOTE LIST2SETQ) (QUOTE ENTRYPOINT) (QUOTE "L1060")) (PUT (QUOTE LIST2SETQ) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 838)) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2598")) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE IDNUMBER) (QUOTE 665)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE PUTC) (QUOTE ENTRYPOINT) (QUOTE PUTC)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE DELASC) (QUOTE ENTRYPOINT) (QUOTE DELASC)) (PUT (QUOTE DELASC) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE FOREACH) (QUOTE ENTRYPOINT) (QUOTE "L3070")) (PUT (QUOTE FOREACH) (QUOTE IDNUMBER) (QUOTE 735)) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1214")) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 786)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L1881")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 512)) (PUT (QUOTE MM) (QUOTE ENTRYPOINT) (QUOTE MM)) (PUT (QUOTE MM) (QUOTE IDNUMBER) (QUOTE 589)) (PUT (QUOTE FLOATINTARG) (QUOTE ENTRYPOINT) (QUOTE "L1565")) (PUT (QUOTE MKEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1184")) (PUT (QUOTE MKEVECTOR) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE MAKEBUFINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2420")) (PUT (QUOTE DELASCIP) (QUOTE ENTRYPOINT) (QUOTE "L0957")) (PUT (QUOTE DELASCIP) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE ZEROP) (QUOTE ENTRYPOINT) (QUOTE ZEROP)) (PUT (QUOTE ZEROP) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE IDNUMBER) (QUOTE 816)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE INITIALVALUE) (QUOTE -1)) (PUT (QUOTE FLOATGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1511")) (PUT (QUOTE GLOBALREMOVE) (QUOTE ENTRYPOINT) (QUOTE "L3486")) (PUT (QUOTE GLOBALREMOVE) (QUOTE IDNUMBER) (QUOTE 789)) (PUT (QUOTE NTHENTRY) (QUOTE ENTRYPOINT) (QUOTE "L3627")) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2390")) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE IDNUMBER) (QUOTE 645)) (PUT (QUOTE GCERROR) (QUOTE ENTRYPOINT) (QUOTE "L1281")) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE DELASCIP1) (QUOTE ENTRYPOINT) (QUOTE "L0950")) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 599)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE INTLSHIFT) (QUOTE ENTRYPOINT) (QUOTE "L1502")) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MAPC2) (QUOTE ENTRYPOINT) (QUOTE MAPC2)) (PUT (QUOTE MAPC2) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE ANS) (QUOTE ENTRYPOINT) (QUOTE ANS)) (PUT (QUOTE ANS) (QUOTE IDNUMBER) (QUOTE 830)) (PUT (QUOTE HIST) (QUOTE ENTRYPOINT) (QUOTE HIST)) (PUT (QUOTE HIST) (QUOTE IDNUMBER) (QUOTE 831)) (PUT (QUOTE EVALINITFORMS) (QUOTE ENTRYPOINT) (QUOTE "L3658")) (PUT (QUOTE EVALINITFORMS) (QUOTE IDNUMBER) (QUOTE 837)) (PUT (QUOTE EDITORPRINTER!*) (QUOTE IDNUMBER) (QUOTE 447)) (FLAG (QUOTE (EDITORPRINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LOOKUPORADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3412")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1091")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE ENTRYPOINT) (QUOTE "L2781")) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE IDNUMBER) (QUOTE 690)) (PUT (QUOTE EXPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2900")) (PUT (QUOTE EXPLODE) (QUOTE IDNUMBER) (QUOTE 697)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SPECIAL) (QUOTE IDNUMBER) (QUOTE 609)) (PUT (QUOTE RCREF) (QUOTE IDNUMBER) (QUOTE 582)) (PUT (QUOTE EVRELOAD) (QUOTE ENTRYPOINT) (QUOTE "L2197")) (PUT (QUOTE EVRELOAD) (QUOTE IDNUMBER) (QUOTE 569)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE INITIALVALUE) (QUOTE (COND PROG AND OR PROGN SETQ))) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 633)) (FLAG (QUOTE (TOKTYPE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INTSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1530")) (PUT (QUOTE MIN) (QUOTE ENTRYPOINT) (QUOTE MIN)) (PUT (QUOTE MIN) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE INP) (QUOTE ENTRYPOINT) (QUOTE INP)) (PUT (QUOTE INP) (QUOTE IDNUMBER) (QUOTE 828)) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2724")) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE IDNUMBER) (QUOTE 684)) (PUT (QUOTE CHANNELPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2352")) (PUT (QUOTE CHANNELPOSN) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE FLAGP) (QUOTE ENTRYPOINT) (QUOTE FLAGP)) (PUT (QUOTE FLAGP) (QUOTE IDNUMBER) (QUOTE 757)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1855")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 508)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE REMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1469")) (PUT (QUOTE REMAINDER) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE !*VERBOSELOAD) (QUOTE IDNUMBER) (QUOTE 564)) (FLAG (QUOTE (!*VERBOSELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1131")) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE ID2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0036")) (PUT (QUOTE ID2STRING) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE REDO) (QUOTE ENTRYPOINT) (QUOTE REDO)) (PUT (QUOTE REDO) (QUOTE IDNUMBER) (QUOTE 829)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L2890")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 694)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L1090")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1116")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2879")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE !*VERBOSE) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (!*VERBOSE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L3356")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 780)) (PUT (QUOTE EUPBV) (QUOTE ENTRYPOINT) (QUOTE EUPBV)) (PUT (QUOTE EUPBV) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1092")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE NEWBITTABLEENTRY!*) (QUOTE IDNUMBER) (QUOTE 554)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2577")) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 659)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0607")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE GETV) (QUOTE ENTRYPOINT) (QUOTE GETV)) (PUT (QUOTE GETV) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE !*INSIDESTRUCTUREREAD) (QUOTE IDNUMBER) (QUOTE 639)) (FLAG (QUOTE (!*INSIDESTRUCTUREREAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1516")) (PUT (QUOTE MARKFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1206")) (PUT (QUOTE CL) (QUOTE IDNUMBER) (QUOTE 450)) (FLAG (QUOTE (CL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MACROP) (QUOTE ENTRYPOINT) (QUOTE MACROP)) (PUT (QUOTE MACROP) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CONTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2929")) (PUT (QUOTE CONTERROR) (QUOTE IDNUMBER) (QUOTE 714)) (PUT (QUOTE FLOATONEP) (QUOTE ENTRYPOINT) (QUOTE "L1576")) (PUT (QUOTE ONEP) (QUOTE ENTRYPOINT) (QUOTE ONEP)) (PUT (QUOTE ONEP) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE LOAD) (QUOTE ENTRYPOINT) (QUOTE LOAD)) (PUT (QUOTE LOAD) (QUOTE IDNUMBER) (QUOTE 566)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE VECTOR) (QUOTE ENTRYPOINT) (QUOTE VECTOR)) (PUT (QUOTE VECTOR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE GTHEAP1) (QUOTE ENTRYPOINT) (QUOTE "L1097")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1104")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1862")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 509)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE IDNUMBER) (QUOTE 562)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE INITIALVALUE) (QUOTE ("" "pl:"))) (PUT (QUOTE WRITENUMBER1) (QUOTE ENTRYPOINT) (QUOTE "L2588")) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE THIRD) (QUOTE ENTRYPOINT) (QUOTE THIRD)) (PUT (QUOTE THIRD) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE SETF) (QUOTE ENTRYPOINT) (QUOTE SETF)) (PUT (QUOTE SETF) (QUOTE IDNUMBER) (QUOTE 719)) (PUT (QUOTE QEDNTH) (QUOTE ENTRYPOINT) (QUOTE QEDNTH)) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2132")) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE IDNUMBER) (QUOTE 557)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 691)) (PUT (QUOTE LASTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L1000")) (PUT (QUOTE LASTPAIR) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE ERRORSET) (QUOTE ENTRYPOINT) (QUOTE "L1831")) (PUT (QUOTE ERRORSET) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE COMPILER) (QUOTE IDNUMBER) (QUOTE 584)) (PUT (QUOTE UPDATEREGION) (QUOTE ENTRYPOINT) (QUOTE "L1291")) (PUT (QUOTE VECTOR2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0083")) (PUT (QUOTE VECTOR2LIST) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PUTV) (QUOTE ENTRYPOINT) (QUOTE PUTV)) (PUT (QUOTE PUTV) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE YESP) (QUOTE ENTRYPOINT) (QUOTE YESP)) (PUT (QUOTE YESP) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE NCONC) (QUOTE ENTRYPOINT) (QUOTE NCONC)) (PUT (QUOTE NCONC) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE IGNORE) (QUOTE IDNUMBER) (QUOTE 827)) (PUT (QUOTE RETURNADDRESSP) (QUOTE ENTRYPOINT) (QUOTE "L2098")) (PUT (QUOTE RETURNADDRESSP) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L1111")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE HELP) (QUOTE ENTRYPOINT) (QUOTE HELP)) (PUT (QUOTE HELP) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE IDNUMBER) (QUOTE 657)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE INITIALVALUE) (QUOTE 10)) (PUT (QUOTE LOADTIME) (QUOTE ENTRYPOINT) (QUOTE "L2922")) (PUT (QUOTE LOADTIME) (QUOTE IDNUMBER) (QUOTE 712)) (PUT (QUOTE ID2INT) (QUOTE ENTRYPOINT) (QUOTE ID2INT)) (PUT (QUOTE ID2INT) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE ENTRYPOINT) (QUOTE "L2453")) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE IDNUMBER) (QUOTE 632)) (PUT (QUOTE THROWAUX) (QUOTE ENTRYPOINT) (QUOTE "L2052")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1093")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE DFPRINT!*) (QUOTE IDNUMBER) (QUOTE 826)) (FLAG (QUOTE (DFPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !%THROW) (QUOTE ENTRYPOINT) (QUOTE !%THROW)) (PUT (QUOTE !%THROW) (QUOTE IDNUMBER) (QUOTE 532)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 654)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 626)) (PUT (QUOTE !*RAISE) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE NEXPRP) (QUOTE ENTRYPOINT) (QUOTE NEXPRP)) (PUT (QUOTE NEXPRP) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE MKFLAGVAR) (QUOTE ENTRYPOINT) (QUOTE "L2985")) (PUT (QUOTE MKFLAGVAR) (QUOTE IDNUMBER) (QUOTE 724)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 443)) (FLAG (QUOTE (PROMPTSTRING!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE STRINGEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0487")) (PUT (QUOTE STRINGEQUAL) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE NE) (QUOTE ENTRYPOINT) (QUOTE NE)) (PUT (QUOTE NE) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2887")) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 593)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 612)) (PUT (QUOTE BREAKVALUE!*) (QUOTE IDNUMBER) (QUOTE 796)) (FLAG (QUOTE (BREAKVALUE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FINDIDNUMBER) (QUOTE IDNUMBER) (QUOTE 555)) (PUT (QUOTE BREAKEDIT) (QUOTE ENTRYPOINT) (QUOTE "L3586")) (PUT (QUOTE BREAKEDIT) (QUOTE IDNUMBER) (QUOTE 815)) (PUT (QUOTE TIMES) (QUOTE ENTRYPOINT) (QUOTE TIMES)) (PUT (QUOTE TIMES) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE ENTRYPOINT) (QUOTE "L2383")) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE IDNUMBER) (QUOTE 644)) (PUT (QUOTE FLOATMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1548")) (PUT (QUOTE EXEC) (QUOTE ENTRYPOINT) (QUOTE EXEC)) (PUT (QUOTE EXEC) (QUOTE IDNUMBER) (QUOTE 588)) (PUT (QUOTE DELQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0913")) (PUT (QUOTE EMODE) (QUOTE ENTRYPOINT) (QUOTE EMODE)) (PUT (QUOTE EMODE) (QUOTE IDNUMBER) (QUOTE 580)) (PUT (QUOTE READLINE) (QUOTE ENTRYPOINT) (QUOTE "L2564")) (PUT (QUOTE READLINE) (QUOTE IDNUMBER) (QUOTE 655)) (PUT (QUOTE INTMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1547")) (PUT (QUOTE DEFNPRINT1) (QUOTE ENTRYPOINT) (QUOTE "L3620")) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1112")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2696")) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE IDNUMBER) (QUOTE 682)) (PUT (QUOTE EVECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE EVECTORP) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 596)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE OBJECT!-GET!-HANDLER!-QUIETLY) (QUOTE IDNUMBER) (QUOTE 685)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2654")) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE IDNUMBER) (QUOTE 676)) (PUT (QUOTE !*LOWER) (QUOTE IDNUMBER) (QUOTE 573)) (FLAG (QUOTE (!*LOWER)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DUMPLISP) (QUOTE ENTRYPOINT) (QUOTE "L2111")) (PUT (QUOTE DUMPLISP) (QUOTE IDNUMBER) (QUOTE 548)) (PUT (QUOTE EVAND) (QUOTE ENTRYPOINT) (QUOTE EVAND)) (PUT (QUOTE EVAND) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE ASSIGN!-OP) (QUOTE IDNUMBER) (QUOTE 722)) (PUT (QUOTE PLUS) (QUOTE ENTRYPOINT) (QUOTE PLUS)) (PUT (QUOTE PLUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 792)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE !$UNWIND!-PROTECT!$) (QUOTE IDNUMBER) (QUOTE 530)) (PUT (QUOTE COMPRESS) (QUOTE ENTRYPOINT) (QUOTE "L2915")) (PUT (QUOTE COMPRESS) (QUOTE IDNUMBER) (QUOTE 703)) (PUT (QUOTE MAPCON) (QUOTE ENTRYPOINT) (QUOTE MAPCON)) (PUT (QUOTE MAPCON) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE MAPCAR) (QUOTE ENTRYPOINT) (QUOTE MAPCAR)) (PUT (QUOTE MAPCAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1737")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE SUBLIS) (QUOTE ENTRYPOINT) (QUOTE SUBLIS)) (PUT (QUOTE SUBLIS) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE MAKEBUFINTOID) (QUOTE ENTRYPOINT) (QUOTE "L2411")) (PUT (QUOTE TOPLOOPNAME!*) (QUOTE IDNUMBER) (QUOTE 800)) (FLAG (QUOTE (TOPLOOPNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKNAME!*) (QUOTE IDNUMBER) (QUOTE 803)) (FLAG (QUOTE (BREAKNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3566")) (PUT (QUOTE BREAKEVAL) (QUOTE IDNUMBER) (QUOTE 808)) (PUT (QUOTE PROG) (QUOTE ENTRYPOINT) (QUOTE PROG)) (PUT (QUOTE PROG) (QUOTE IDNUMBER) (QUOTE 541)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE IDNUMBER) (QUOTE 630)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE INITIALVALUE) (QUOTE LISPREADMACRO)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE CHANNELWRITEID) (QUOTE ENTRYPOINT) (QUOTE "L2608")) (PUT (QUOTE CHANNELWRITEID) (QUOTE IDNUMBER) (QUOTE 670)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE ASMSYMBOL) (QUOTE "L2282")) (PUT (QUOTE JFNOFCHANNEL) (QUOTE WARRAY) (QUOTE JFNOFCHANNEL)) (PUT (QUOTE CHANNELLPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2353")) (PUT (QUOTE CHANNELLPOSN) (QUOTE IDNUMBER) (QUOTE 623)) (PUT (QUOTE STRINGGENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3051")) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE FLOAT) (QUOTE ENTRYPOINT) (QUOTE FLOAT)) (PUT (QUOTE FLOAT) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 8000)) (PUT (QUOTE FLOATZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1467")) (PUT (QUOTE INDX) (QUOTE ENTRYPOINT) (QUOTE INDX)) (PUT (QUOTE INDX) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 515)) (PUT (QUOTE INTZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1571")) (PUT (QUOTE FLOATADD1) (QUOTE ENTRYPOINT) (QUOTE "L1521")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1798")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L2597")) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE IDNUMBER) (QUOTE 664)) (PUT (QUOTE EPUTV) (QUOTE ENTRYPOINT) (QUOTE EPUTV)) (PUT (QUOTE EPUTV) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE DECLAREFLUIDORGLOBAL) (QUOTE ENTRYPOINT) (QUOTE "L3247")) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 636)) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2303")) (PUT (QUOTE UNREADCHAR) (QUOTE IDNUMBER) (QUOTE 601)) (PUT (QUOTE MAKE!-WORDS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE MAKE!-WORDS) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2134")) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE IDNUMBER) (QUOTE 558)) (PUT (QUOTE SIMPFG) (QUOTE IDNUMBER) (QUOTE 725)) (PUT (QUOTE SETPROP) (QUOTE ENTRYPOINT) (QUOTE "L3179")) (PUT (QUOTE SETPROP) (QUOTE IDNUMBER) (QUOTE 756)) (PUT (QUOTE SPECIALREADFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 606)) (FLAG (QUOTE (SPECIALREADFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CHANNELPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2898")) (PUT (QUOTE CHANNELPRINTF) (QUOTE IDNUMBER) (QUOTE 695)) (PUT (QUOTE OR) (QUOTE ENTRYPOINT) (QUOTE OR)) (PUT (QUOTE OR) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE MKQUOTE) (QUOTE ENTRYPOINT) (QUOTE "L0871")) (PUT (QUOTE MKQUOTE) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE !*PRINTLOADNAMES) (QUOTE IDNUMBER) (QUOTE 565)) (FLAG (QUOTE (!*PRINTLOADNAMES)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 472)) (PUT (QUOTE EDITORREADER!*) (QUOTE IDNUMBER) (QUOTE 446)) (FLAG (QUOTE (EDITORREADER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETF!-EXPAND) (QUOTE IDNUMBER) (QUOTE 721)) (PUT (QUOTE SETSUB) (QUOTE ENTRYPOINT) (QUOTE SETSUB)) (PUT (QUOTE SETSUB) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE SIZE) (QUOTE ENTRYPOINT) (QUOTE SIZE)) (PUT (QUOTE SIZE) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE CHANNELREAD) (QUOTE ENTRYPOINT) (QUOTE "L2361")) (PUT (QUOTE CHANNELREAD) (QUOTE IDNUMBER) (QUOTE 635)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 536)) (PUT (QUOTE !&!&VALUE!&!&) (QUOTE IDNUMBER) (QUOTE 525)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L3236")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 763)) (PUT (QUOTE CHANNELSPACES) (QUOTE ENTRYPOINT) (QUOTE "L1046")) (PUT (QUOTE CHANNELSPACES) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE PRINTF2) (QUOTE ENTRYPOINT) (QUOTE "L2850")) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3490")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 790)) (PUT (QUOTE LOSE) (QUOTE IDNUMBER) (QUOTE 777)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L1870")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 510)) (PUT (QUOTE LISPEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0449")) (PUT (QUOTE LISPEQUAL) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE CLEARIO1) (QUOTE ENTRYPOINT) (QUOTE "L3503")) (PUT (QUOTE UNION) (QUOTE ENTRYPOINT) (QUOTE UNION)) (PUT (QUOTE UNION) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE DELQIP) (QUOTE ENTRYPOINT) (QUOTE DELQIP)) (PUT (QUOTE DELQIP) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE CHANNELTAB) (QUOTE ENTRYPOINT) (QUOTE "L1050")) (PUT (QUOTE CHANNELTAB) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE BIGFLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1421")) (PUT (QUOTE INTLNOT) (QUOTE ENTRYPOINT) (QUOTE "L1540")) (PUT (QUOTE DSKINDEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3681")) (PUT (QUOTE MAX) (QUOTE ENTRYPOINT) (QUOTE MAX)) (PUT (QUOTE MAX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE INSTANTIATEINFORM) (QUOTE ENTRYPOINT) (QUOTE "L2991")) (PUT (QUOTE COPYWRDS) (QUOTE ENTRYPOINT) (QUOTE "L1147")) (PUT (QUOTE COPYWRDS) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L3504")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 793)) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE ENTRYPOINT) (QUOTE "L1208")) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L1163")) (PUT (QUOTE CHANNELPRINT) (QUOTE ENTRYPOINT) (QUOTE "L0822")) (PUT (QUOTE CHANNELPRINT) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE IDNUMBER) (QUOTE 563)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE INITIALVALUE) (QUOTE ((".b" . FASLIN) ( ".lap" . LAPIN) (".sl" . LAPIN)))) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE UPDATEITEM) (QUOTE ENTRYPOINT) (QUOTE "L1295")) (PUT (QUOTE SAVESYSTEM) (QUOTE ENTRYPOINT) (QUOTE "L3656")) (PUT (QUOTE SAVESYSTEM) (QUOTE IDNUMBER) (QUOTE 835)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE FEXPRP) (QUOTE ENTRYPOINT) (QUOTE FEXPRP)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2357")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE THROW) (QUOTE ENTRYPOINT) (QUOTE THROW)) (PUT (QUOTE THROW) (QUOTE IDNUMBER) (QUOTE 495)) (PUT (QUOTE FIX) (QUOTE ENTRYPOINT) (QUOTE FIX)) (PUT (QUOTE FIX) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0395")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE INITIALVALUE) (QUOTE 1000)) (PUT (QUOTE TCONC) (QUOTE ENTRYPOINT) (QUOTE TCONC)) (PUT (QUOTE TCONC) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1128")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE !*QUITBREAK) (QUOTE IDNUMBER) (QUOTE 797)) (FLAG (QUOTE (!*QUITBREAK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CONST) (QUOTE ENTRYPOINT) (QUOTE CONST)) (PUT (QUOTE CONST) (QUOTE IDNUMBER) (QUOTE 732)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 767)) (PUT (QUOTE EGETV) (QUOTE ENTRYPOINT) (QUOTE EGETV)) (PUT (QUOTE EGETV) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L1895")) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE IDNUMBER) (QUOTE 516)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE DS) (QUOTE ENTRYPOINT) (QUOTE DS)) (PUT (QUOTE DS) (QUOTE IDNUMBER) (QUOTE 729)) (PUT (QUOTE WORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0446")) (PUT (QUOTE INTERNGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3465")) (PUT (QUOTE INTERNGENSYM) (QUOTE IDNUMBER) (QUOTE 785)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1844")) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 506)) (PUT (QUOTE COMPRESSLIST!*) (QUOTE IDNUMBER) (QUOTE 701)) (FLAG (QUOTE (COMPRESSLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1140")) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2899")) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 594)) (PUT (QUOTE SPECIALWRSACTION!*) (QUOTE IDNUMBER) (QUOTE 616)) (FLAG (QUOTE (SPECIALWRSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE TOPLOOPPRINT!*) (QUOTE IDNUMBER) (QUOTE 804)) (FLAG (QUOTE (TOPLOOPPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODE!-ADDRESS!-TO!-SYMBOL) (QUOTE IDNUMBER) (QUOTE 470)) (PUT (QUOTE MAPLIST) (QUOTE ENTRYPOINT) (QUOTE "L0747")) (PUT (QUOTE MAPLIST) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1772")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE !*EXPERT) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*EXPERT)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CONC) (QUOTE IDNUMBER) (QUOTE 738)) (PUT (QUOTE CHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2814")) (PUT (QUOTE CHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE PRINTF1) (QUOTE ENTRYPOINT) (QUOTE "L2849")) (PUT (QUOTE !*COMP) (QUOTE IDNUMBER) (QUOTE 775)) (FLAG (QUOTE (!*COMP)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1219")) (PUT (QUOTE ABS) (QUOTE ENTRYPOINT) (QUOTE ABS)) (PUT (QUOTE ABS) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1807")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 491)) (PUT (QUOTE OTHERWISE) (QUOTE IDNUMBER) (QUOTE 715)) (PUT (QUOTE FASLOUT) (QUOTE ENTRYPOINT) (QUOTE "L2265")) (PUT (QUOTE FASLOUT) (QUOTE IDNUMBER) (QUOTE 586)) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2765")) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE IDNUMBER) (QUOTE 689)) (PUT (QUOTE SUBSEQ) (QUOTE ENTRYPOINT) (QUOTE SUBSEQ)) (PUT (QUOTE SUBSEQ) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE LSHIFT) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSHIFT) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L1780")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L3417")) (PUT (QUOTE MARKFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1215")) (PUT (QUOTE XCHANGE) (QUOTE ENTRYPOINT) (QUOTE "L1637")) (PUT (QUOTE COMPRESSERROR) (QUOTE ENTRYPOINT) (QUOTE "L2914")) (PUT (QUOTE COMPRESSERROR) (QUOTE IDNUMBER) (QUOTE 700)) (PUT (QUOTE READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2290")) (PUT (QUOTE READCHAR) (QUOTE IDNUMBER) (QUOTE 598)) (PUT (QUOTE FLOATDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1436")) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 634)) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UPDATESYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1290")) (PUT (QUOTE GCMESSAGE) (QUOTE ENTRYPOINT) (QUOTE "L1212")) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE CHANNELREADCH) (QUOTE ENTRYPOINT) (QUOTE "L2354")) (PUT (QUOTE CHANNELREADCH) (QUOTE IDNUMBER) (QUOTE 625)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COPYVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1143")) (PUT (QUOTE COPYVECTOR) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 641)) (FLAG (QUOTE (!$EOF!$)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DELQ) (QUOTE ENTRYPOINT) (QUOTE DELQ)) (PUT (QUOTE DELQ) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1792")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1193")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE CREFON) (QUOTE ENTRYPOINT) (QUOTE CREFON)) (PUT (QUOTE CREFON) (QUOTE IDNUMBER) (QUOTE 583)) (PUT (QUOTE FOR) (QUOTE ENTRYPOINT) (QUOTE FOR)) (PUT (QUOTE FOR) (QUOTE IDNUMBER) (QUOTE 746)) (PUT (QUOTE BIN) (QUOTE IDNUMBER) (QUOTE 750)) (PUT (QUOTE DSKINEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3679")) (PUT (QUOTE DSKINEVAL) (QUOTE IDNUMBER) (QUOTE 839)) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE ENTRYPOINT) (QUOTE "L2358")) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE IDNUMBER) (QUOTE 631)) (PUT (QUOTE INT2CODE) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE INT2CODE) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE BREAK) (QUOTE ENTRYPOINT) (QUOTE BREAK)) (PUT (QUOTE BREAK) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1891")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3524")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 613)) (PUT (QUOTE INTADD1) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE FLAG) (QUOTE ENTRYPOINT) (QUOTE FLAG)) (PUT (QUOTE FLAG) (QUOTE IDNUMBER) (QUOTE 759)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2294")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 471)) (PUT (QUOTE IN) (QUOTE IDNUMBER) (QUOTE 739)) (PUT (QUOTE REMOB) (QUOTE ENTRYPOINT) (QUOTE REMOB)) (PUT (QUOTE REMOB) (QUOTE IDNUMBER) (QUOTE 783)) (PUT (QUOTE BREAKFUNCTION) (QUOTE IDNUMBER) (QUOTE 809)) (PUT (QUOTE HEAPTRAPPED) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPPED) (QUOTE ASMSYMBOL) (QUOTE "L1094")) (PUT (QUOTE HEAPTRAPPED) (QUOTE WVAR) (QUOTE HEAPTRAPPED)) (PUT (QUOTE !*EOLINSTRINGOK) (QUOTE IDNUMBER) (QUOTE 647)) (FLAG (QUOTE (!*EOLINSTRINGOK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3406")) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE MIN2) (QUOTE ENTRYPOINT) (QUOTE MIN2)) (PUT (QUOTE MIN2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ASS) (QUOTE ENTRYPOINT) (QUOTE ASS)) (PUT (QUOTE ASS) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE VARTYPE) (QUOTE IDNUMBER) (QUOTE 766)) (PUT (QUOTE HISTPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3638")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2302")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE IDNUMBER) (QUOTE 600)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE ENTRYPOINT) (QUOTE "L2636")) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE FLUID1) (QUOTE ENTRYPOINT) (QUOTE FLUID1)) (PUT (QUOTE FLUID1) (QUOTE IDNUMBER) (QUOTE 768)) (PUT (QUOTE EVDEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3045")) (PUT (QUOTE EVDEFCONST) (QUOTE IDNUMBER) (QUOTE 731)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE CASE) (QUOTE ENTRYPOINT) (QUOTE CASE)) (PUT (QUOTE CASE) (QUOTE IDNUMBER) (QUOTE 717)) (PUT (QUOTE SCANNERERROR) (QUOTE ENTRYPOINT) (QUOTE "L2482")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE ENTRYPOINT) (QUOTE "L1423")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE !*DEFN) (QUOTE IDNUMBER) (QUOTE 795)) (FLAG (QUOTE (!*DEFN)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0427")) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 840)) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE STRINGGENSYM!*) (QUOTE IDNUMBER) (QUOTE 734)) (FLAG (QUOTE (STRINGGENSYM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE HELPBREAK) (QUOTE ENTRYPOINT) (QUOTE "L3579")) (PUT (QUOTE HELPBREAK) (QUOTE IDNUMBER) (QUOTE 813)) (PUT (QUOTE UNMAP!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L2113")) (PUT (QUOTE !*CATCH) (QUOTE ENTRYPOINT) (QUOTE "L2035")) (PUT (QUOTE !*CATCH) (QUOTE IDNUMBER) (QUOTE 534)) (PUT (QUOTE MINUSP) (QUOTE ENTRYPOINT) (QUOTE MINUSP)) (PUT (QUOTE MINUSP) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BPSSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPSSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BPSSIZE) (QUOTE WCONST) (QUOTE 100000)) (PUT (QUOTE IMPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2916")) (PUT (QUOTE IMPLODE) (QUOTE IDNUMBER) (QUOTE 704)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1795")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE FASTBIND) (QUOTE ENTRYPOINT) (QUOTE "L3367")) (PUT (QUOTE FASTBIND) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1918")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2601")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 668)) (PUT (QUOTE CHECKLINEFIT) (QUOTE ENTRYPOINT) (QUOTE "L2574")) (PUT (QUOTE !%UNCATCH) (QUOTE ENTRYPOINT) (QUOTE "L2047")) (PUT (QUOTE !%UNCATCH) (QUOTE IDNUMBER) (QUOTE 501)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L1804")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE WCONST) (QUOTE 8)) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2629")) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE IDNUMBER) (QUOTE 673)) (PUT (QUOTE HASHFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L3419")) (PUT (QUOTE HASHFUNCTION) (QUOTE IDNUMBER) (QUOTE 782)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1509")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE MAPC) (QUOTE ENTRYPOINT) (QUOTE MAPC)) (PUT (QUOTE MAPC) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1838")) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 504)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE IDNUMBER) (QUOTE 546)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE INITIALVALUE) (QUOTE (DEC20 PDP10 TOPS20 KL10))) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE MAKESTRINGINTOBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2540")) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE IDNUMBER) (QUOTE 817)) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE UPBV) (QUOTE ENTRYPOINT) (QUOTE UPBV)) (PUT (QUOTE UPBV) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE LCONC) (QUOTE ENTRYPOINT) (QUOTE LCONC)) (PUT (QUOTE LCONC) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE EDCOPY) (QUOTE ENTRYPOINT) (QUOTE EDCOPY)) (PUT (QUOTE FLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1557")) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1775")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 489)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 542)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE DEL) (QUOTE ENTRYPOINT) (QUOTE DEL)) (PUT (QUOTE DEL) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE MAKE!-BYTES) (QUOTE ENTRYPOINT) (QUOTE "L0343")) (PUT (QUOTE MAKE!-BYTES) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE FIRST) (QUOTE ENTRYPOINT) (QUOTE FIRST)) (PUT (QUOTE FIRST) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE DATE) (QUOTE ENTRYPOINT) (QUOTE DATE)) (PUT (QUOTE DATE) (QUOTE IDNUMBER) (QUOTE 547)) (PUT (QUOTE SEMIC!*) (QUOTE IDNUMBER) (QUOTE 820)) (FLAG (QUOTE (SEMIC!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DOTCONTEXTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2373")) (PUT (QUOTE SYSPOWEROF2P) (QUOTE ENTRYPOINT) (QUOTE "L2538")) (PUT (QUOTE LOAD1) (QUOTE ENTRYPOINT) (QUOTE LOAD1)) (PUT (QUOTE LOAD1) (QUOTE IDNUMBER) (QUOTE 567)) (PUT (QUOTE LISP2CHAR) (QUOTE ENTRYPOINT) (QUOTE "L0023")) (PUT (QUOTE LISP2CHAR) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE MEM) (QUOTE ENTRYPOINT) (QUOTE MEM)) (PUT (QUOTE MEM) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE EHELP) (QUOTE ENTRYPOINT) (QUOTE EHELP)) (PUT (QUOTE EHELP) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE EDIT0) (QUOTE ENTRYPOINT) (QUOTE EDIT0)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE MAKEBUFINTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2415")) (PUT (QUOTE INTMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1566")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L3529")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 605)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1801")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE INTERPBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1695")) (PUT (QUOTE INTERPBACKTRACE) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE !$ERROR!$) (QUOTE IDNUMBER) (QUOTE 496)) (PUT (QUOTE INTGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1510")) (PUT (QUOTE UNMAP!-PAGES) (QUOTE ENTRYPOINT) (QUOTE "L2116")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2348")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE IDNUMBER) (QUOTE 620)) (PUT (QUOTE TOPLOOPEVAL!*) (QUOTE IDNUMBER) (QUOTE 801)) (FLAG (QUOTE (TOPLOOPEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE USER) (QUOTE IDNUMBER) (QUOTE 776)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE SCANPOSSIBLEDIPHTHONG) (QUOTE ENTRYPOINT) (QUOTE "L2476")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L3512")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 590)) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE ENTRYPOINT) (QUOTE "L2367")) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE IDNUMBER) (QUOTE 642)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE EXPANDSETF) (QUOTE ENTRYPOINT) (QUOTE "L2965")) (PUT (QUOTE EXPANDSETF) (QUOTE IDNUMBER) (QUOTE 720)) (PUT (QUOTE GO) (QUOTE ENTRYPOINT) (QUOTE GO)) (PUT (QUOTE GO) (QUOTE IDNUMBER) (QUOTE 544)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 617)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3520")) (PUT (QUOTE REST) (QUOTE ENTRYPOINT) (QUOTE REST)) (PUT (QUOTE REST) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE SIMP) (QUOTE IDNUMBER) (QUOTE 749)) (PUT (QUOTE INVOKE) (QUOTE ENTRYPOINT) (QUOTE INVOKE)) (PUT (QUOTE INVOKE) (QUOTE IDNUMBER) (QUOTE 581)) (PUT (QUOTE !*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 493)) (FLAG (QUOTE (!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !&!&TAG!&!&) (QUOTE IDNUMBER) (QUOTE 531)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 758)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE TR) (QUOTE ENTRYPOINT) (QUOTE TR)) (PUT (QUOTE TR) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE UP) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE EMSG!*) (QUOTE IDNUMBER) (QUOTE 483)) (FLAG (QUOTE (EMSG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKE!-VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0374")) (PUT (QUOTE MAKE!-VECTOR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE FLATSIZE) (QUOTE ENTRYPOINT) (QUOTE "L2904")) (PUT (QUOTE FLATSIZE) (QUOTE IDNUMBER) (QUOTE 488)) (PUT (QUOTE PROGBODY!*) (QUOTE IDNUMBER) (QUOTE 539)) (FLAG (QUOTE (PROGBODY!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SPECIALWRITEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 607)) (FLAG (QUOTE (SPECIALWRITEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE READINBUF) (QUOTE ENTRYPOINT) (QUOTE "L2407")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE ENTRYPOINT) (QUOTE "L2032")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE IDNUMBER) (QUOTE 533)) (PUT (QUOTE SUBSTIP1) (QUOTE ENTRYPOINT) (QUOTE "L0883")) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0612")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE INTLXOR) (QUOTE ENTRYPOINT) (QUOTE "L1495")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3157")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 752)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE HISTORYLIST!*) (QUOTE IDNUMBER) (QUOTE 821)) (FLAG (QUOTE (HISTORYLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNIONQ) (QUOTE ENTRYPOINT) (QUOTE UNIONQ)) (PUT (QUOTE UNIONQ) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE MAKESTRINGINTOSYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2418")) (PUT (QUOTE NTH) (QUOTE ENTRYPOINT) (QUOTE NTH)) (PUT (QUOTE NTH) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE PL) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE JOIN) (QUOTE IDNUMBER) (QUOTE 737)) (PUT (QUOTE SUBSTIP) (QUOTE ENTRYPOINT) (QUOTE "L0888")) (PUT (QUOTE SUBSTIP) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE TIME) (QUOTE ENTRYPOINT) (QUOTE TIME)) (PUT (QUOTE TIME) (QUOTE IDNUMBER) (QUOTE 823)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE SPECIALCLOSEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 608)) (FLAG (QUOTE (SPECIALCLOSEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 755)) (PUT (QUOTE STARTUPTIME) (QUOTE ENTRYPOINT) (QUOTE "L2922")) (PUT (QUOTE STARTUPTIME) (QUOTE IDNUMBER) (QUOTE 713)) (PUT (QUOTE INTERSECTIONQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE INTERSECTIONQ) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE !$BREAK!$) (QUOTE IDNUMBER) (QUOTE 807)) (PUT (QUOTE EDITOR) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE FLOATQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1453")) (PUT (QUOTE BREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 487)) (PUT (QUOTE BREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1763")) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE MAKEBUFINTOSYSNUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2417")) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L2632")) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE IDNUMBER) (QUOTE 674)) (PUT (QUOTE BINARYOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L2123")) (PUT (QUOTE BINARYOPENREAD) (QUOTE IDNUMBER) (QUOTE 549)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2276")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE INT2SYS) (QUOTE ENTRYPOINT) (QUOTE "L0016")) (PUT (QUOTE INT2SYS) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L3343")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 778)) (PUT (QUOTE ON) (QUOTE ENTRYPOINT) (QUOTE ON)) (PUT (QUOTE ON) (QUOTE IDNUMBER) (QUOTE 726)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1125")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE INTPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1426")) (PUT (QUOTE TIMC) (QUOTE ENTRYPOINT) (QUOTE TIMC)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L3499")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 592)) (PUT (QUOTE INTQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1452")) (PUT (QUOTE PROG2) (QUOTE ENTRYPOINT) (QUOTE PROG2)) (PUT (QUOTE PROG2) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE MK!*SQ) (QUOTE IDNUMBER) (QUOTE 748)) (PUT (QUOTE LIST2SET) (QUOTE ENTRYPOINT) (QUOTE "L1054")) (PUT (QUOTE LIST2SET) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE YES) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE REMPROPL) (QUOTE ENTRYPOINT) (QUOTE "L3242")) (PUT (QUOTE REMPROPL) (QUOTE IDNUMBER) (QUOTE 764)) (PUT (QUOTE FLAG1) (QUOTE ENTRYPOINT) (QUOTE FLAG1)) (PUT (QUOTE FLAG1) (QUOTE IDNUMBER) (QUOTE 760)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3353")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 514)) (PUT (QUOTE !*WRITINGFASLFILE) (QUOTE IDNUMBER) (QUOTE 553)) (PUT (QUOTE DELETIP1) (QUOTE ENTRYPOINT) (QUOTE "L0894")) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1789")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 490)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 518)) (PUT (QUOTE OFF) (QUOTE ENTRYPOINT) (QUOTE OFF)) (PUT (QUOTE OFF) (QUOTE IDNUMBER) (QUOTE 727)) (PUT (QUOTE QEDITFNS) (QUOTE IDNUMBER) (QUOTE 437)) (FLAG (QUOTE (QEDITFNS)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1247")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE ENTRYPOINT) (QUOTE "L1045")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE COLLECT) (QUOTE IDNUMBER) (QUOTE 736)) (PUT (QUOTE GLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3268")) (PUT (QUOTE GLOBAL1) (QUOTE IDNUMBER) (QUOTE 770)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE ENTRYPOINT) (QUOTE "L2637")) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE IDNUMBER) (QUOTE 675)) (PUT (QUOTE !*INNER!*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 494)) (FLAG (QUOTE (!*INNER!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRING) (QUOTE ENTRYPOINT) (QUOTE "L1135")) (PUT (QUOTE COPYSTRING) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3352")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 537)) (PUT (QUOTE RDTTY) (QUOTE ENTRYPOINT) (QUOTE RDTTY)) (PUT (QUOTE TOTALCOPY) (QUOTE ENTRYPOINT) (QUOTE "L1149")) (PUT (QUOTE TOTALCOPY) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE OPTIONS!*) (QUOTE IDNUMBER) (QUOTE 467)) (FLAG (QUOTE (OPTIONS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L3192")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 524)) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1107")) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE LINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2351")) (PUT (QUOTE LINELENGTH) (QUOTE IDNUMBER) (QUOTE 621)) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE ENTRYPOINT) (QUOTE "L2594")) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE IDNUMBER) (QUOTE 662)) (PUT (QUOTE RANGE) (QUOTE IDNUMBER) (QUOTE 718)) (PUT (QUOTE PUTENTRY) (QUOTE ENTRYPOINT) (QUOTE "L2189")) (PUT (QUOTE PUTENTRY) (QUOTE IDNUMBER) (QUOTE 561)) (PUT (QUOTE BREAKERRMSG) (QUOTE ENTRYPOINT) (QUOTE "L3582")) (PUT (QUOTE BREAKERRMSG) (QUOTE IDNUMBER) (QUOTE 814)) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2603")) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE IDNUMBER) (QUOTE 669)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2903")) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 595)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE INT2ID) (QUOTE ENTRYPOINT) (QUOTE INT2ID)) (PUT (QUOTE INT2ID) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE INTDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1435")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3348")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 513)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE MAX2) (QUOTE ENTRYPOINT) (QUOTE MAX2)) (PUT (QUOTE MAX2) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE VALUECELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2130")) (PUT (QUOTE VALUECELLLOCATION) (QUOTE IDNUMBER) (QUOTE 552)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE PRINC) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRINC) (QUOTE IDNUMBER) (QUOTE 628)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2278")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE MINI) (QUOTE ENTRYPOINT) (QUOTE MINI)) (PUT (QUOTE MINI) (QUOTE IDNUMBER) (QUOTE 579)) (PUT (QUOTE EXPLODE2) (QUOTE ENTRYPOINT) (QUOTE "L2901")) (PUT (QUOTE EXPLODE2) (QUOTE IDNUMBER) (QUOTE 698)) (PUT (QUOTE !*TIME) (QUOTE IDNUMBER) (QUOTE 822)) (FLAG (QUOTE (!*TIME)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2279")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE PAIR) (QUOTE ENTRYPOINT) (QUOTE PAIR)) (PUT (QUOTE PAIR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE REVERSIP) (QUOTE ENTRYPOINT) (QUOTE "L0878")) (PUT (QUOTE REVERSIP) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2615")) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE IDNUMBER) (QUOTE 671)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2136")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 560)) (PUT (QUOTE LISPBANNER!*) (QUOTE IDNUMBER) (QUOTE 818)) (PUT (QUOTE LISPBANNER!*) (QUOTE INITIALVALUE) (QUOTE "Portable Standard LISP")) (PUT (QUOTE RANGEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1736")) (PUT (QUOTE RANGEERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE PENDINGLOADS!*) (QUOTE IDNUMBER) (QUOTE 574)) (FLAG (QUOTE (PENDINGLOADS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE QUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1451")) (PUT (QUOTE QUOTIENT) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE SPACES) (QUOTE ENTRYPOINT) (QUOTE SPACES)) (PUT (QUOTE SPACES) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0033")) (PUT (QUOTE UNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3376")) (PUT (QUOTE UNBOUNDP) (QUOTE IDNUMBER) (QUOTE 765)) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2735")) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE IDNUMBER) (QUOTE 687)) (PUT (QUOTE CATCH) (QUOTE ENTRYPOINT) (QUOTE CATCH)) (PUT (QUOTE CATCH) (QUOTE IDNUMBER) (QUOTE 498)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE IDNUMBER) (QUOTE 658)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE INITIALVALUE) (QUOTE 33)) (PUT (QUOTE CHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1850")) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 503)) (PUT (QUOTE WRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2580")) (PUT (QUOTE WRITESTRING) (QUOTE IDNUMBER) (QUOTE 660)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1204")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE CHANNELREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2285")) (PUT (QUOTE CHANNELREADCHAR) (QUOTE IDNUMBER) (QUOTE 597)) (PUT (QUOTE DELATQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0972")) (PUT (QUOTE SPACES2) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE SPACES2) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3351")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 779)) (PUT (QUOTE ASSOC) (QUOTE ENTRYPOINT) (QUOTE ASSOC)) (PUT (QUOTE ASSOC) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE IMPORTS) (QUOTE ENTRYPOINT) (QUOTE "L2227")) (PUT (QUOTE IMPORTS) (QUOTE IDNUMBER) (QUOTE 575)) (PUT (QUOTE EQN) (QUOTE ENTRYPOINT) (QUOTE EQN)) (PUT (QUOTE EQN) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE DELETIP) (QUOTE ENTRYPOINT) (QUOTE "L0900")) (PUT (QUOTE DELETIP) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE FLOATTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1444")) (PUT (QUOTE REPEAT) (QUOTE ENTRYPOINT) (QUOTE REPEAT)) (PUT (QUOTE REPEAT) (QUOTE IDNUMBER) (QUOTE 745)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE AND) (QUOTE ENTRYPOINT) (QUOTE AND)) (PUT (QUOTE AND) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE EXPLODEENDPOINTER!*) (QUOTE IDNUMBER) (QUOTE 696)) (FLAG (QUOTE (EXPLODEENDPOINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L3161")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 753)) (PUT (QUOTE HEAPSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE HEAPSIZE) (QUOTE WCONST) (QUOTE 90000)) (PUT (QUOTE !&!&THROWN!&!&) (QUOTE IDNUMBER) (QUOTE 529)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2908")) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 591)) (PUT (QUOTE RECIP) (QUOTE ENTRYPOINT) (QUOTE RECIP)) (PUT (QUOTE RECIP) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 486)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE DELATQIP) (QUOTE ENTRYPOINT) (QUOTE "L0978")) (PUT (QUOTE DELATQIP) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE READCH) (QUOTE ENTRYPOINT) (QUOTE READCH)) (PUT (QUOTE READCH) (QUOTE IDNUMBER) (QUOTE 627)) (PUT (QUOTE INITFORMS!*) (QUOTE IDNUMBER) (QUOTE 836)) (FLAG (QUOTE (INITFORMS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 769)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L3495")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 791)) (PUT (QUOTE TOPLOOP) (QUOTE ENTRYPOINT) (QUOTE "L3604")) (PUT (QUOTE TOPLOOP) (QUOTE IDNUMBER) (QUOTE 806)) (PUT (QUOTE LITER) (QUOTE ENTRYPOINT) (QUOTE LITER)) (PUT (QUOTE LITER) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE NEXT) (QUOTE ENTRYPOINT) (QUOTE NEXT)) (PUT (QUOTE NEXT) (QUOTE IDNUMBER) (QUOTE 743)) (PUT (QUOTE !$EXITTOPLOOP!$) (QUOTE IDNUMBER) (QUOTE 825)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1191")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE !*NONIL) (QUOTE IDNUMBER) (QUOTE 824)) (FLAG (QUOTE (!*NONIL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNWIND!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L2008")) (PUT (QUOTE UNWIND!-ALL) (QUOTE IDNUMBER) (QUOTE 528)) (PUT (QUOTE XINS) (QUOTE ENTRYPOINT) (QUOTE XINS)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1813")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 492)) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2749")) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE IDNUMBER) (QUOTE 688)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE STACKSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE STACKSIZE) (QUOTE WCONST) (QUOTE 10000)) (PUT (QUOTE DEFLIST) (QUOTE ENTRYPOINT) (QUOTE "L0782")) (PUT (QUOTE DEFLIST) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE CHANNELTYO) (QUOTE ENTRYPOINT) (QUOTE "L2918")) (PUT (QUOTE CHANNELTYO) (QUOTE IDNUMBER) (QUOTE 706)) (PUT (QUOTE CHANNELREADLINE) (QUOTE ENTRYPOINT) (QUOTE "L2568")) (PUT (QUOTE CHANNELREADLINE) (QUOTE IDNUMBER) (QUOTE 656)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1903")) (PUT (QUOTE SUB) (QUOTE ENTRYPOINT) (QUOTE SUB)) (PUT (QUOTE SUB) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1884")) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CHANNELSPACES2) (QUOTE ENTRYPOINT) (QUOTE "L1050")) (PUT (QUOTE CHANNELSPACES2) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE BREAKIN!*) (QUOTE IDNUMBER) (QUOTE 798)) (FLAG (QUOTE (BREAKIN!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L2281")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE VECTOR2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0049")) (PUT (QUOTE VECTOR2STRING) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE CHANNELREADEOF) (QUOTE ENTRYPOINT) (QUOTE "L2364")) (PUT (QUOTE CHANNELREADEOF) (QUOTE IDNUMBER) (QUOTE 640)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1117")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE FIXP) (QUOTE ENTRYPOINT) (QUOTE FIXP)) (PUT (QUOTE FIXP) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE ADJOIN) (QUOTE ENTRYPOINT) (QUOTE ADJOIN)) (PUT (QUOTE ADJOIN) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2370")) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE IDNUMBER) (QUOTE 643)) (PUT (QUOTE EXPAND) (QUOTE ENTRYPOINT) (QUOTE EXPAND)) (PUT (QUOTE EXPAND) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE HALFWORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0478")) (PUT (QUOTE MAKEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L1418")) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0332")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE CHANNELTERPRI) (QUOTE ENTRYPOINT) (QUOTE "L2356")) (PUT (QUOTE CHANNELTERPRI) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LASTCAR) (QUOTE ENTRYPOINT) (QUOTE "L0996")) (PUT (QUOTE LASTCAR) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE INTERNP) (QUOTE ENTRYPOINT) (QUOTE "L3451")) (PUT (QUOTE INTERNP) (QUOTE IDNUMBER) (QUOTE 784)) (PUT (QUOTE UPDATEALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1209")) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0635")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE !*BREAK) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE !*BREAK) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE THROWTAG!*) (QUOTE IDNUMBER) (QUOTE 526)) (FLAG (QUOTE (THROWTAG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EXPT) (QUOTE ENTRYPOINT) (QUOTE EXPT)) (PUT (QUOTE EXPT) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE EVOR) (QUOTE ENTRYPOINT) (QUOTE EVOR)) (PUT (QUOTE EVOR) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE MAPCAN) (QUOTE ENTRYPOINT) (QUOTE MAPCAN)) (PUT (QUOTE MAPCAN) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE LAND) (QUOTE ENTRYPOINT) (QUOTE LAND)) (PUT (QUOTE LAND) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE LSH) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSH) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE COMPILETIME) (QUOTE ENTRYPOINT) (QUOTE "L2920")) (PUT (QUOTE COMPILETIME) (QUOTE IDNUMBER) (QUOTE 710)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE PAGEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE PAGEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2280")) (PUT (QUOTE PAGEPOSITION) (QUOTE WARRAY) (QUOTE PAGEPOSITION)) (PUT (QUOTE STEP) (QUOTE ENTRYPOINT) (QUOTE STEP)) (PUT (QUOTE STEP) (QUOTE IDNUMBER) (QUOTE 578)) (PUT (QUOTE DEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3041")) (PUT (QUOTE DEFCONST) (QUOTE IDNUMBER) (QUOTE 730)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 522)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 653)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1434")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE BPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPS) (QUOTE ASMSYMBOL) (QUOTE BPS)) (PUT (QUOTE BPS) (QUOTE WARRAY) (QUOTE BPS)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2301")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1810")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE EQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0449")) (PUT (QUOTE EQUAL) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 648)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2277")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE ENTRYPOINT) (QUOTE "L2053")) (PUT (QUOTE NO) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE INTLAND) (QUOTE ENTRYPOINT) (QUOTE "L1482")) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE MAKEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3381")) (PUT (QUOTE MAKEUNBOUND) (QUOTE IDNUMBER) (QUOTE 781)) (PUT (QUOTE RPLACEALL) (QUOTE ENTRYPOINT) (QUOTE "L1638")) (PUT (QUOTE READONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1841")) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 505)) (PUT (QUOTE CATCHSETUPAUX) (QUOTE ENTRYPOINT) (QUOTE "L2040")) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE INTHISCASE) (QUOTE ENTRYPOINT) (QUOTE "L2948")) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE BREAKEVAL!*) (QUOTE IDNUMBER) (QUOTE 802)) (FLAG (QUOTE (BREAKEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COMMENTOUTCODE) (QUOTE ENTRYPOINT) (QUOTE "L2919")) (PUT (QUOTE COMMENTOUTCODE) (QUOTE IDNUMBER) (QUOTE 709)) (PUT (QUOTE HEAP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAP) (QUOTE ASMSYMBOL) (QUOTE HEAP)) (PUT (QUOTE HEAP) (QUOTE WARRAY) (QUOTE HEAP)) (PUT (QUOTE COPYWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1136")) (PUT (QUOTE COPYWARRAY) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE INTTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1443")) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE LIST2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0075")) (PUT (QUOTE LIST2VECTOR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE SUBST) (QUOTE ENTRYPOINT) (QUOTE SUBST)) (PUT (QUOTE SUBST) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE DECLAREFLUIDORGLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3251")) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L3357")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 517)) (PUT (QUOTE BREAKRETRY) (QUOTE ENTRYPOINT) (QUOTE "L3574")) (PUT (QUOTE BREAKRETRY) (QUOTE IDNUMBER) (QUOTE 812)) (PUT (QUOTE !*COMPRESSING) (QUOTE IDNUMBER) (QUOTE 646)) (FLAG (QUOTE (!*COMPRESSING)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE XN) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE XN) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE LOR) (QUOTE ENTRYPOINT) (QUOTE LOR)) (PUT (QUOTE LOR) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L1783")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0804")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE WRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2845")) (PUT (QUOTE WRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 667)) (PUT (QUOTE ONOFF!*) (QUOTE ENTRYPOINT) (QUOTE "L2976")) (PUT (QUOTE ONOFF!*) (QUOTE IDNUMBER) (QUOTE 723)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L3146")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 751)) (PUT (QUOTE FLATSIZE2) (QUOTE ENTRYPOINT) (QUOTE "L2905")) (PUT (QUOTE FLATSIZE2) (QUOTE IDNUMBER) (QUOTE 699)) (PUT (QUOTE PROGJUMPTABLE!*) (QUOTE IDNUMBER) (QUOTE 540)) (FLAG (QUOTE (PROGJUMPTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE NONINTEGER1ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1394")) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1199")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0821")) (PUT (QUOTE FUNCTION) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE NUMBERP) (QUOTE ENTRYPOINT) (QUOTE "L0642")) (PUT (QUOTE NUMBERP) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE TOPLOOPREAD!*) (QUOTE IDNUMBER) (QUOTE 805)) (FLAG (QUOTE (TOPLOOPREAD!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKCONTINUE) (QUOTE ENTRYPOINT) (QUOTE "L3570")) (PUT (QUOTE BREAKCONTINUE) (QUOTE IDNUMBER) (QUOTE 811)) (PUT (QUOTE CONCAT) (QUOTE ENTRYPOINT) (QUOTE CONCAT)) (PUT (QUOTE CONCAT) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE SETMACROREFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L3003")) (PUT (QUOTE !*SEMICOL!*) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE INTONEP) (QUOTE ENTRYPOINT) (QUOTE "L1575")) (PUT (QUOTE COPY) (QUOTE ENTRYPOINT) (QUOTE COPY)) (PUT (QUOTE COPY) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE EDITF) (QUOTE ENTRYPOINT) (QUOTE EDITF)) (PUT (QUOTE EDITF) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1786")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE CHANNELEJECT) (QUOTE ENTRYPOINT) (QUOTE "L2343")) (PUT (QUOTE CHANNELEJECT) (QUOTE IDNUMBER) (QUOTE 618)) (PUT (QUOTE SUBLA) (QUOTE ENTRYPOINT) (QUOTE SUBLA)) (PUT (QUOTE SUBLA) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 615)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE FASTUNBIND) (QUOTE ENTRYPOINT) (QUOTE "L3370")) (PUT (QUOTE FASTUNBIND) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE RASSOC) (QUOTE ENTRYPOINT) (QUOTE RASSOC)) (PUT (QUOTE RASSOC) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE STATICINTFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L1386")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE ENTRYPOINT) (QUOTE "L3653")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE IDNUMBER) (QUOTE 834)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 610)) (PUT (QUOTE EVLOAD) (QUOTE ENTRYPOINT) (QUOTE EVLOAD)) (PUT (QUOTE EVLOAD) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE CATCH!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1996")) (PUT (QUOTE CATCH!-ALL) (QUOTE IDNUMBER) (QUOTE 527)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE ENTRYPOINT) (QUOTE "L1835")) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 502)) (PUT (QUOTE SETINDX) (QUOTE ENTRYPOINT) (QUOTE "L0159")) (PUT (QUOTE SETINDX) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L3540")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 604)) (PUT (QUOTE ADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3402")) (PUT (QUOTE ADJOINQ) (QUOTE ENTRYPOINT) (QUOTE "L1066")) (PUT (QUOTE ADJOINQ) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE MAKEBUFINTOFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2425")) (PUT (QUOTE CATCHSETUP) (QUOTE ENTRYPOINT) (QUOTE "L2039")) (PUT (QUOTE CATCHSETUP) (QUOTE IDNUMBER) (QUOTE 499)) (PUT (QUOTE BREAKQUIT) (QUOTE ENTRYPOINT) (QUOTE "L3569")) (PUT (QUOTE BREAKQUIT) (QUOTE IDNUMBER) (QUOTE 810)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L3536")) (PUT (QUOTE GENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3460")) (PUT (QUOTE FORMATFORPRINTF!*) (QUOTE IDNUMBER) (QUOTE 692)) (FLAG (QUOTE (FORMATFORPRINTF!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DIGITTONUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2534")) (PUT (QUOTE DIGITTONUMBER) (QUOTE IDNUMBER) (QUOTE 650)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 520)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L3167")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 754)) (PUT (QUOTE GLOBALINSTALL) (QUOTE ENTRYPOINT) (QUOTE "L3483")) (PUT (QUOTE GLOBALINSTALL) (QUOTE IDNUMBER) (QUOTE 788)) (PUT (QUOTE CHANNELPRIN) (QUOTE IDNUMBER) (QUOTE 686)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE DISPLAYHELPFILE) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE !$LOOP!$) (QUOTE IDNUMBER) (QUOTE 742)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L3271")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 771)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1192")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2536")) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE IDNUMBER) (QUOTE 649)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L2107")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 602)) (PUT (QUOTE UPDATEHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1296")) (PUT (QUOTE RETURN) (QUOTE ENTRYPOINT) (QUOTE RETURN)) (PUT (QUOTE RETURN) (QUOTE IDNUMBER) (QUOTE 545)) (PUT (QUOTE BINARYOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L2128")) (PUT (QUOTE BINARYOPENWRITE) (QUOTE IDNUMBER) (QUOTE 551)) (PUT (QUOTE ONEARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1396")) (PUT (QUOTE INTLOR) (QUOTE ENTRYPOINT) (QUOTE INTLOR)) (PUT (QUOTE ONEARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1405")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1207")) (PUT (QUOTE CHANNELPRINC) (QUOTE ENTRYPOINT) (QUOTE "L2357")) (PUT (QUOTE CHANNELPRINC) (QUOTE IDNUMBER) (QUOTE 629)) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2824")) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 681)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE REMFLAG1) (QUOTE ENTRYPOINT) (QUOTE "L3225")) (PUT (QUOTE REMFLAG1) (QUOTE IDNUMBER) (QUOTE 762)) (PUT (QUOTE !*CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 482)) (FLAG (QUOTE (!*CONTINUABLEERROR)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE VECTOREQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0466")) (PUT (QUOTE INTERSECTION) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE INTERSECTION) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE ENTRYPOINT) (QUOTE "L2573")) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE IDNUMBER) (QUOTE 638)) (PUT (QUOTE EVAND1) (QUOTE ENTRYPOINT) (QUOTE EVAND1)) (PUT (QUOTE RPLACW) (QUOTE ENTRYPOINT) (QUOTE RPLACW)) (PUT (QUOTE RPLACW) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE FINDFIRST) (QUOTE ENTRYPOINT) (QUOTE "L1640")) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L3534")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 550)) (PUT (QUOTE MKEVECT) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE COMPACTHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1210")) (PUT (QUOTE CHANNELWRITEBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2586")) (PUT (QUOTE QUIT) (QUOTE ENTRYPOINT) (QUOTE QUIT)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE TRST) (QUOTE ENTRYPOINT) (QUOTE TRST)) (PUT (QUOTE TRST) (QUOTE IDNUMBER) (QUOTE 436)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FILEP) (QUOTE ENTRYPOINT) (QUOTE FILEP)) (PUT (QUOTE FILEP) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE FLOATPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1427")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2600")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE IDNUMBER) (QUOTE 666)) (PUT (QUOTE !#ARG) (QUOTE IDNUMBER) (QUOTE 728)) (PUT (QUOTE MAP2) (QUOTE ENTRYPOINT) (QUOTE MAP2)) (PUT (QUOTE MAP2) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE EDIT) (QUOTE ENTRYPOINT) (QUOTE EDIT)) (PUT (QUOTE EDIT) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE STRING) (QUOTE ENTRYPOINT) (QUOTE STRING)) (PUT (QUOTE STRING) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2796")) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 679)) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE ENTRYPOINT) (QUOTE "L1223")) (PUT (QUOTE OK) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE POSN) (QUOTE ENTRYPOINT) (QUOTE POSN)) (PUT (QUOTE POSN) (QUOTE IDNUMBER) (QUOTE 622)) |
Added psl-1983/20-kernel/all-kernel.ctl version [2150df11e6].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | submit types.ctl submit randm.ctl submit alloc.ctl submit arith.ctl submit debg.ctl submit error.ctl submit eval.ctl submit extra.ctl submit fasl.ctl submit io.ctl submit macro.ctl submit prop.ctl submit symbl.ctl submit sysio.ctl submit tloop.ctl submit heap.ctl |
Added psl-1983/20-kernel/all-kernel.log version [8d03c73254].
cannot compute difference between binary files
Added psl-1983/20-kernel/alloc.ctl version [e3dc70fdc8].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "alloc"; in "alloc.build"; ASMEnd; quit; compile alloc.mac, dalloc.mac delete alloc.mac, dalloc.mac |
Added psl-1983/20-kernel/alloc.init version [90df9184c9].
> | 1 | (FLUID (QUOTE (!*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL))) |
Added psl-1983/20-kernel/alloc.log version [6ded50773a].
cannot compute difference between binary files
Added psl-1983/20-kernel/alloc.rel version [ad2d7bec83].
cannot compute difference between binary files
Added psl-1983/20-kernel/apply-lap.red version [9d186bbfb2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % APPLY-LAP.RED - LAP support for EVAL and APPLY % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.NEW>APPLY-LAP.RED.2, 9-Dec-82 18:13:02, Edit by PERDUE % Modified UndefinedFunction to make it continuable CompileTime flag('(FastLambdaApply), 'InternalFunction); on SysLisp; external WVar BndStkPtr, BndStkUpperBound; % TAG( CodeApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeApply expr 2) %. CodeApply(CodePointer, ArgList) % % r1 is code pointer, r2 is list of arguments % (!*MOVE (reg 1) (reg t1)) (!*MOVE (reg 2) (reg t2)) (!*MOVE (WConst 1) (reg t3)) Loop (!*JUMPNOTTYPE (MEMORY (REG T1) (WConst 0)) (reg t2) PAIR) % jump to code if list is exhauseted (!*MOVE (CAR (reg t2)) (reg t4)) (!*MOVE (reg t4) (MEMORY (reg t3) 0)) % load argument register (!*MOVE (CDR (reg t2)) (reg t2)) (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % skip if neq MaxRegs+1 (!*MOVE (WConst ArgumentBlock) (reg t3)) % else switch to extra args (!*JUMPWLEQ (Label Loop) (reg t3) (WConst (plus2 9 (WConst ArgumentBlock)))) (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( CodeEvalApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeEvalApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := Eval car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeEvalApply expr 2) %. CodeApply(CodePointer, EvLis Args) % % r1 is code pointer, r2 is list of arguments to be evaled % (!*PUSH (reg 1)) % code pointer goes on the bottom (!*PUSH (WConst 0)) % then arg count Loop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label Done) (reg 2) PAIR) (!*JUMPWLESSP (Label ArgOverflow) (frame 1) (WConst -15)) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 2)) % save the cdr (!*CALL Eval) % eval the car (!*POP (reg 2)) % grab the list in r2 again (!*POP (reg 3)) % get count in r3 (!*WDIFFERENCE (reg 3) (WConst 1)) % decrement count (!*PUSH (reg 1)) % push the evaled arg (!*PUSH (reg 3)) % and the decremented count (!*JUMP (Label Loop)) Done (!*POP (reg 3)) % count in r3, == -no. of args to pop (!*JUMP (MEMORY (reg 3) (Label ZeroArgs))) % indexed jump (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 9)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 8)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 7)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 6)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 5)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 4)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 3)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 2)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 1)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 0)) (WConst 0))) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) ZeroArgs (!*POP (reg t1)) % code pointer in (reg t1) (!*JUMP (MEMORY (reg t1) (WConst 0))) % jump to address ArgOverflow (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( BindEval ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure BindEval(Formals, Args); % begin scalar N; % N := 0; % while PairP Args and PairP Formals do % << N := N + 1; % Push Eval car ArgList; % Push car Formals; % ArgList := cdr ArgList >>; % if PairP Args or PairP Formals then return -1; % for I := 1 step 1 until N do % LBind1(Pop(), Pop()); % return N; % end; lap '((!*entry BindEval expr 2) %. BindEval(FormalsList, ArgsToBeEvaledList); % % r1 is list of formals, r2 is list of arguments to be evaled % (!*PUSH (WConst 0)) % count on the bottom (!*MOVE (WConst 0) (reg 4)) (!*MOVE (reg 1) (reg 3)) % shift arg1 to r3 EvalLoop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label DoneEval) (reg 2) PAIR) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 3)) % save the formals (!*PUSH (reg 2)) % save the rest of args (!*CALL Eval) % eval the car (!*POP (reg 2)) % save then rest of arglist (!*POP (reg 3)) % and the rest of formals (!*POP (reg 4)) % and the count (!*JUMPNOTTYPE (Label ReturnError) (reg 3) PAIR) % if it's not a pair, then error (!*WPLUS2 (reg 4) (WConst 1)) % increment the count (!*MOVE (CAR (reg 3)) (reg 5)) (!*MOVE (CDR (reg 3)) (reg 3)) (!*PUSH (reg 1)) % push the evaluated argument (!*PUSH (reg 5)) % and next formal (!*PUSH (reg 4)) % and new count (!*JUMP (Label EvalLoop)) ReturnError (!*WSHIFT (reg 4) (WConst 1)) % multiply count by 2 (hrl (reg 4) (reg 4)) % in both halves (sub (reg st) (reg 4)) % move the stack ptr back (!*MOVE (WConst -1) (reg 1)) % return -1 as error indicator (!*EXIT 0) DoneEval (!*DEALLOC 1) % removed saved values at top of stack (!*JUMPTYPE (Label ReturnError) (reg 3) PAIR) % if more formals, error (!*MOVE (reg 4) (reg 3)) % r3 gets decremented, r4 saved for return BindLoop (!*JUMPEQ (Label NormalReturn) (reg 3) (WConst 0)) % if count is zero, then return (!*POP (reg 1)) % pop ID to bind (!*POP (reg 2)) % and value (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*CALL LBind1) (!*POP (reg 4)) (!*POP (reg 3)) (soja (reg 3) BindLoop) NormalReturn (!*MOVE (reg 4) (reg 1)) % return count (!*EXIT 0) ); % TAG( CompiledCallingInterpreted ) % This is pretty gross, but it is essentially the same as LambdaApply, taking % values from the argument registers instead of a list. % if this could be written in Syslisp, it would look something like this: % syslsp procedure CompiledCallingInterpreted IDOfFunction; % begin scalar LForm, LArgs, N, Result; % LForm := get(IDOfFunction, '!*LambdaLink); % LArgs := cadr LForm; % LForm := cddr LForm; % N := 1; % while PairP LArgs do % << LBind1(car LArgs, ArgumentRegister[N]; % LArgs := cdr LArgs; % N := N + 1 >>; % Result := EvProgN LForm; % UnBindN(N - 1); % return Result; % end; lap '((!*entry CompiledCallingInterpreted expr 0) %. link for lambda % % called by JSP T5, from function cell % (!*MOVE (reg t5) (reg t1)) (!*WDIFFERENCE (reg t1) (WConst (plus2 (WConst SymFnc) 1))) (!*MKITEM (reg t1) (WConst BtrTag)) (!*PUSH (reg t1)) % make stack mark for btrace (!*MOVE (MEMORY (reg t1) (WConst SymPrp)) (reg t1)) % load prop list LoopFindProp (!*JUMPNOTTYPE (Label PropNotFound) (reg t1) PAIR) (!*MOVE (CAR (reg t1)) (reg t2)) % get car of prop list (!*MOVE (CDR (reg t1)) (reg t1)) % cdr down (!*JUMPNOTTYPE (Label LoopFindProp) (reg t2) PAIR) (!*MOVE (CAR (reg t2)) (reg t3)) % its a pair, look at car (!*JUMPNOTEQ (Label LoopFindProp) (reg t3) '!*LambdaLink) (!*MOVE (CDR (reg t2)) (reg t2)) % yes, get lambda form (!*entry FastLambdaApply expr 0) % called from FastApply (!*MOVE (CDR (reg t2)) (reg t2)) % get cdr of lambda form (!*MOVE (CDR (reg t2)) (reg t1)) % save cddr in (reg t1) (!*MOVE (CAR (reg t2)) (reg t2)) % cadr of lambda == arg list (!*MOVE (WConst 1) (reg t3)) % pointer to arg register in t3 (!*MOVE (WVar BndStkPtr) (reg t4)) % binding stack pointer in t4 (!*PUSH (reg t4)) % save it on the stack LoopBindingFormals (!*JUMPNOTTYPE (Label DoneBindingFormals) (reg t2) PAIR) (!*WPLUS2 (reg t4) (WConst 2)) % adjust binding stack pointer up 2 (caml (reg t4) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (!*MOVE (CAR (reg t2)) (reg t5)) % get formal in t5 (hrrzm (reg t5) (Indexed (reg t4) -1)) % store ID number in BndStk (!*MOVE (MEMORY (reg t5) (WArray SymVal)) (reg t6)) % get old value (!*MOVE (reg t6) (MEMORY (reg t4) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t6)) % get reg value in t6 (!*MOVE (reg t6) (MEMORY (reg t5) (WConst SymVal))) % put in value cell (!*MOVE (CDR (reg t2)) (reg t2)) % cdr down argument list (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % Go to extra args? (movei (reg t3) (WArray ArgumentBlock)) % Yes (!*JUMP (Label LoopBindingFormals)) % No DoneBindingFormals (!*MOVE (reg t4) (WVar BndStkPtr)) % store binding stack (!*MOVE (reg t1) (reg 1)) % get cddr of lambda form to eval (!*CALL EvProgN) % implicit progn (exch (reg 1) (Indexed (reg st) 0)) % save result, get old bind stk ptr (!*CALL RestoreEnvironment) (!*POP (reg 1)) % restore old bindings and pickup value (!*EXIT 1) % throw away backtrace mark and return PropNotFound (!*MOVE (QUOTE "Internal error in function calling mechanism; consult a wizard") (reg 1)) (!*JCALL StdError) ); % TAG( FastApply ) lap '((!*entry FastApply expr 0) %. Apply with arguments loaded % % Called with arguments in the registers and functional form in (reg t1) % (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*JUMPEQ (MEMORY (reg t1) (WConst SymFnc)) (reg t2) (WConst ID)) (!*JUMPEQ (MEMORY (reg t1) (WConst 0)) (reg t2) (WConst CODE)) (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR)) (!*MOVE (CAR (reg t1)) (reg t2)) (!*JUMPNOTEQ IllegalFunctionalForm (reg t2) (QUOTE LAMBDA)) (!*MOVE (reg t1) (reg t2)) % put lambda form in (reg t2) (!*PUSH '()) % align stack (!*JCALL FastLambdaApply) IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form %r in Apply") (reg 1)) (!*MOVE (reg t1) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); % TAG( UndefinedFunction ) lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code % % also called by JSP T5, % (!*WDIFFERENCE (reg t5) (wconst 1)) % T5 now points to the function entry slot of the atom that % is undefined as a function. % We will push the entry address onto the stack and transfer % to it by a POPJ at the end of this routine. (!*PUSH (reg t5)) (!*PUSH (reg 1)) % Save all the regs (including fakes) (args) (!*PUSH (reg 2)) (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*WDIFFERENCE (reg t5) (WConst SymFnc)) (!*MKITEM (reg t5) (WConst ID)) (!*MOVE (reg t5) (reg 2)) (!*MOVE (QUOTE "Undefined function %r called from compiled code") (reg 1)) (!*CALL BldMsg) (!*MOVE (reg 1) (reg 2)) (!*MOVE (WConst 0) (reg 1)) (!*MOVE (reg NIL) (reg 3)) (!*CALL ContinuableError) (!*POP (reg 15)) % Restore all those possible arguments (!*POP (reg 14)) (!*POP (reg 13)) (!*POP (reg 12)) (!*POP (reg 11)) (!*POP (reg 10)) (!*POP (reg 9)) (!*POP (reg 8)) (!*POP (reg 7)) (!*POP (reg 6)) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (!*EXIT 0) ); off SysLisp; END; |
Added psl-1983/20-kernel/arith.ctl version [c16d352751].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "arith"; in "arith.build"; ASMEnd; quit; compile arith.mac, darith.mac delete arith.mac, darith.mac |
Added psl-1983/20-kernel/arith.init version [a7ffc6f8bf].
Added psl-1983/20-kernel/arith.log version [7d541a60ba].
cannot compute difference between binary files
Added psl-1983/20-kernel/arith.rel version [092003b6d1].
cannot compute difference between binary files
Added psl-1983/20-kernel/bare-psl.sym version [14527ad530].
> > > > | 1 2 3 4 | (setq OrderedIDList!* (NCons NIL)) (setq UncompiledExpressions!* (NCons NIL)) (setq ToBeCompiledExpressions!* (NCons NIL)) (setq NextIDNumber!* 129) |
Added psl-1983/20-kernel/cvtmail.:ej version [d6ecc2a559].
cannot compute difference between binary files
Added psl-1983/20-kernel/cvtmail.emacs version [ceef4a190e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | !~Filename~:! !For dealing with PSL bug reports.! CVTMAIL !Cut Header:! !C Removes unwanted fields from a mail header. One must already be positioned at the start of a mail header. Cursor is left at the beginning of the next mail header.! [1 [2 k .u1 -l .,.+9:fb------- !* Kill preceding mail trailer, if any! "L -l ki '"# q1j' MM&_Fix_Mail-From l !* Skip initial date line! !loop! !* Kill uninteresting header lines! .u1 l .-q1-2"E Odone' q1j .,.+6:fbFrom:_ "LOmatch' .,.+9:fbSubject:_ "LOmatch' .,.+7:fbClass:_ "LOmatch' k Oloop !match! l Oloop !done! MM^R_Set/Pop_Mark <MM&_Header? !* Find a mail header line! q0"E l'"# 1;' !* Exit loop if found! > -l 2MM^R_Indent_Rigidly !* Indent the body of the message! l !& Header?:! !C -1 if current line is header line else 0.! .u0 0l z-.-24 :"G Onomatch' 3a-- "N Onomatch' 7a-- "N Onomatch' 13a-: "N Onomatch' 16a-: "N Onomatch' 19a-- "N Onomatch' 23a-, "N Onomatch' q0j -1u0 !nomatch! q0j 0u0 !& Fix Mail-From:! !C Fixes up any initial "Mail-from:" line. Some "date" lines actually begin with "Mail-from" and contain additional information not wanted here. Cursor is left at the beginning of the same line it started on.! .,.+10:FBMail-from: :"L Oend' 0l iDate: 1MM^R_Kill_Word 1MM^R_Kill_Word 1MM^R_Kill_Word 1MM^R_Kill_Word !end! 0l !Reverse Mail List:! !C Reverses a bufferful of mail messages. The idea is to move forward through the file putting messages found later in front of all found sooner.! [0 [1 [2 [3 .u2 !* q2 has loc of last header found! < .-z "E ' !* Stop reversing if at end of buffer! < !* Find "end of message"! l !* Go to next line! .-z @; !* Exit if at end of buffer! MM&_Header? q0 :@; !* Exit if header line (q0 nonzero)! > !* End of message now found! q2u1 !* Now q1 has prev. header! .u2 !* q2 has next header loc! q1,q2x3 !* Save message in q3! q1,q2k !* Kill message! bj g3 !* Put at front of buffer! q2j !* Go to where left off! > |
Added psl-1983/20-kernel/dalloc.rel version [ecbbc32e10].
cannot compute difference between binary files
Added psl-1983/20-kernel/darith.rel version [208207b6ff].
cannot compute difference between binary files
Added psl-1983/20-kernel/ddebg.rel version [7cb75599b6].
cannot compute difference between binary files
Added psl-1983/20-kernel/debg.ctl version [1049f624a3].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "debg"; in "debg.build"; ASMEnd; quit; compile debg.mac, ddebg.mac delete debg.mac, ddebg.mac |
Added psl-1983/20-kernel/debg.init version [b3fc2d6e9f].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (PUT (QUOTE TR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE TRST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (QEDITFNS !*EXPERT !*VERBOSE PROMPTSTRING!* EDITORREADER!* EDITORPRINTER!* CL))) (UNFLUID (QUOTE (CL))) (PUT (QUOTE EDIT) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITF) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITOR) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (FLUID (QUOTE (IGNOREDINBACKTRACE!* OPTIONS!* INTERPRETERFUNCTIONS!*))) |
Added psl-1983/20-kernel/debg.log version [23605f3cf8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 15:32:02 BATCON Version 104(4133) GLXLIB Version 1(527) Job DEBG Req #258 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 796 Input from => PS:<PSL.KERNEL.20>DEBG.CTL.2 Output to => PS:<PSL.KERNEL.20>DEBG.LOG 15:32:03 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 15:32:03 MONTR @SET TIME-LIMIT 1200 15:32:03 MONTR @LOGIN KESSLER SMALL 15:32:07 MONTR Job 12 on TTY225 7-Mar-83 15:32:07 15:32:07 MONTR Previous login at 7-Mar-83 15:29:04 15:32:08 MONTR There is 1 other job logged in as user KESSLER 15:32:31 MONTR @ 15:32:31 MONTR [PS Mounted] 15:32:31 MONTR 15:32:31 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 15:32:31 MONTR define DSK: DSK:, P20:, PI: 15:32:32 MONTR @S:DEC20-CROSS.EXE 15:32:35 USER Dec 20 cross compiler 15:32:36 USER [8] ASMOut "debg"; 15:32:38 USER ASMOUT: IN files; or type in expressions 15:32:38 USER When all done execute ASMEND; 15:33:11 USER [9] in "debg.build"; 15:33:11 USER % 15:33:11 USER % DEBG.BUILD - Minor debugging tools in the interpreter 15:33:11 USER % 15:33:11 USER % Author: Eric Benson 15:33:11 USER % Symbolic Computation Group 15:33:11 USER % Computer Science Dept. 15:33:11 USER % University of Utah 15:33:11 USER % Date: 19 May 1982 15:33:11 USER % Copyright (c) 1982 University of Utah 15:33:12 USER % 15:33:12 USER 15:33:12 USER PathIn "mini-trace.red"$ 15:33:13 USER *** Function `TR' has been redefined 15:33:14 USER *** Function `TRST' has been redefined 15:33:15 USER % simple function tracing 15:33:15 USER PathIn "mini-editor.red"$ 15:33:46 USER *** Garbage collection starting 15:34:08 USER *** GC 4: time 3081 ms 15:34:08 USER *** 76422 recovered, 564 stable, 13013 active, 76423 free 15:34:12 USER 15:34:12 USER PathIn "backtrace.red"$ % Stack backtrace 15:34:21 USER [10] ASMEnd; 15:34:50 USER NIL 15:34:51 USER [11] quit; 15:34:52 MONTR @compile debg.mac, ddebg.mac 15:34:58 USER MACRO: .MAIN 15:35:08 USER MACRO: .MAIN 15:35:09 USER 15:35:09 USER EXIT 15:35:09 MONTR @delete debg.mac, ddebg.mac 15:35:09 MONTR DEBG.MAC.1 [OK] 15:35:09 MONTR DDEBG.MAC.1 [OK] 15:35:09 MONTR @ 15:35:15 MONTR Killed by OPERATOR, TTY 221 15:35:15 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 225, 15:35:15 MONTR at 7-Mar-83 15:35:14, Used 0:00:55 in 0:03:07 |
Added psl-1983/20-kernel/debg.rel version [722f00949b].
cannot compute difference between binary files
Added psl-1983/20-kernel/derror.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/20-kernel/deval.rel version [d97d731af5].
cannot compute difference between binary files
Added psl-1983/20-kernel/dextra.rel version [f67a44f637].
cannot compute difference between binary files
Added psl-1983/20-kernel/dfasl.rel version [ab260c6efd].
cannot compute difference between binary files
Added psl-1983/20-kernel/dheap.rel version [554e89886d].
cannot compute difference between binary files
Added psl-1983/20-kernel/dio.rel version [9b32eea120].
cannot compute difference between binary files
Added psl-1983/20-kernel/dmacro.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/20-kernel/dmain.mac version [baa1191025].
more than 10,000 changes
Added psl-1983/20-kernel/dmain.rel version [6ea8cdee1f].
cannot compute difference between binary files
Added psl-1983/20-kernel/dprop.rel version [421cbc9ea7].
cannot compute difference between binary files
Added psl-1983/20-kernel/drandm.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/20-kernel/dsymbl.rel version [0075d86440].
cannot compute difference between binary files
Added psl-1983/20-kernel/dsysio.rel version [b991baa3d8].
cannot compute difference between binary files
Added psl-1983/20-kernel/dtloop.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/20-kernel/dtypes.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/20-kernel/dumplisp.red version [0a95f0bce4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DUMPLISP.RED - Dump running Lisp into a file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL-20>DUMPLISP.RED.2, 5-Oct-82 10:57:34, Edit by BENSON % Removed DumpFileName!* added filename arg to Dumplisp % <PSL.20-INTERP>DUMPLISP.RED.7, 3-Sep-82 10:22:46, Edit by BENSON % Fixed page boundary bug when unmapping stack CompileTime << flag('(unmap!-space unmap!-pages save!-into!-file), 'InternalFunction); >>; on Syslisp; external WVar HeapLast, HeapUpperBound, NextBPS, LastBPS, StackUpperBound; syslsp procedure DumpLisp Filename; << if not StringP Filename then StdError "Dumplisp requires a filename argument"; Reclaim; unmap!-space(HeapLast, HeapUpperBound); unmap!-space(NextBPS, LastBPS); %% Add some slack to the end of the stack fo the call to unmap-space! unmap!-space(MakeAddressFromStackPointer ST + 10, StackUpperBound); save!-into!-file Filename >>; syslsp procedure unmap!-space(Lo, Hi); begin scalar LoPage, HiPage; LoPage := LSH(Lo + 8#777, -9); HiPage := LSH(Hi - 8#1000, -9); return if not (LoPage >= HiPage) then unmap!-pages(LoPage, HiPage - LoPage); end; lap '((!*entry unmap!-pages expr 2) (hrlzi 3 2#100000000000000000) % pm%cnt in AC3 (hrr 3 2) % page count in rh AC3 (hrlzi 2 8#400000) % .fhslf in lh AC2 (hrr 2 1) % starting page in rh AC2 (!*MOVE (WConst -1) (REG 1)) % -1 in AC1 (pmap) % do it (!*EXIT 0) ); lap '((!*entry save!-into!-file expr 1) (!*MOVE (reg 1) (reg 5)) % save in 5 (move 2 1) % file name in 2 (hrli 2 8#10700) % make a byte pointer (hrlzi 1 2#100000000000000001) % gj%fou + gj%sht (gtjfn) (jrst CouldntOpen) (hrli 1 8#400000) % .fhslf (hrrzi 2 2#101010000000000000) % ss%cpy, ss%rd, ss%exe, all pages (hrli 2 -8#1000) % for Release 4 and before, 1000 pages %/ Change previous line to following line for extended addressing % (tlo 2 8#400000) % large negative number (!*MOVE (WConst 0) (REG 3)) (ssave) (!*MOVE (WConst 0) (REG 1)) (!*EXIT 0) CouldntOpen (!*MOVE '"Couldn't GTJFN `%w' for Dumplisp" (reg 1)) (!*MOVE (reg 5) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); off Syslisp; END; |
Added psl-1983/20-kernel/error.ctl version [4360224b98].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "error"; in "error.build"; ASMEnd; quit; compile error.mac, derror.mac delete error.mac, derror.mac |
Added psl-1983/20-kernel/error.init version [83b8b0a3d6].
> > > > > > > | 1 2 3 4 5 6 7 | (FLUID (QUOTE (!*CONTINUABLEERROR ERRORFORM!* BREAKLEVEL!* MAXBREAKLEVEL!* !*EMSGP))) (GLOBAL (QUOTE (EMSG!*))) (GLOBAL (QUOTE (EMSG!*))) (FLUID (QUOTE (!*BACKTRACE !*INNER!*BACKTRACE !*EMSGP !*BREAK BREAKLEVEL!* MAXBREAKLEVEL!* !*CONTINUABLEERROR))) (PUT (QUOTE ERRSET) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/20-kernel/error.log version [ff134c8350].
cannot compute difference between binary files
Added psl-1983/20-kernel/error.rel version [9aef48dada].
cannot compute difference between binary files
Added psl-1983/20-kernel/eval.ctl version [d15fef9f1d].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "eval"; in "eval.build"; ASMEnd; quit; compile eval.mac, deval.mac delete eval.mac, deval.mac |
Added psl-1983/20-kernel/eval.init version [bb976ec1cc].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (FLUID (QUOTE (THROWSIGNAL!* EMSG!* THROWTAG!*))) (PUT (QUOTE CATCH!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CATCH) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !*CATCH) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (PROGJUMPTABLE!* PROGBODY!*))) (PUT (QUOTE PROG) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE GO) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/20-kernel/eval.log version [5b58c88d85].
cannot compute difference between binary files
Added psl-1983/20-kernel/eval.rel version [95584f7484].
cannot compute difference between binary files
Added psl-1983/20-kernel/extra.ctl version [fe2d6a05a0].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "extra"; in "extra.build"; ASMEnd; quit; compile extra.mac, dextra.mac delete extra.mac, dextra.mac |
Added psl-1983/20-kernel/extra.init version [f580ab836a].
> > | 1 2 | (FLUID (QUOTE (SYSTEM_LIST!*))) (COPYD (QUOTE EXITLISP) (QUOTE QUIT)) |
Added psl-1983/20-kernel/extra.log version [8c9788500e].
cannot compute difference between binary files
Added psl-1983/20-kernel/extra.rel version [d492a38145].
cannot compute difference between binary files
Added psl-1983/20-kernel/fasl.ctl version [13a33350de].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "fasl"; in "fasl.build"; ASMEnd; quit; compile fasl.mac, dfasl.mac delete fasl.mac, dfasl.mac |
Added psl-1983/20-kernel/fasl.init version [98e5ba2983].
> > > > > > > > | 1 2 3 4 5 6 7 8 | (FLUID (QUOTE (LOADDIRECTORIES!* LOADEXTENSIONS!* PENDINGLOADS!* !*LOWER !*REDEFMSG !*USERMODE !*INSIDELOAD !*VERBOSELOAD !*PRINTLOADNAMES OPTIONS!*))) (PUT (QUOTE LOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE RELOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DEFSTRUCT) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE HELP) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE CREF) (QUOTE SIMPFG) (QUOTE ((T (CREFON)) (NIL (CREFOFF))))) (PUT (QUOTE SYSLISP) (QUOTE SIMPFG) (QUOTE ((T (LOAD SYSLISP))))) |
Added psl-1983/20-kernel/fasl.log version [3498d4d4fd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 15:48:41 BATCON Version 104(4133) GLXLIB Version 1(527) Job FASL Req #262 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 800 Input from => PS:<PSL.KERNEL.20>FASL.CTL.2 Output to => PS:<PSL.KERNEL.20>FASL.LOG 15:48:42 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 15:48:42 MONTR @SET TIME-LIMIT 1200 15:48:42 MONTR @LOGIN KESSLER SMALL 15:48:46 MONTR Job 13 on TTY225 7-Mar-83 15:48:46 15:48:46 MONTR Previous login at 7-Mar-83 15:44:26 15:48:46 MONTR There is 1 other job logged in as user KESSLER 15:48:59 MONTR @ 15:48:59 MONTR [PS Mounted] 15:48:59 MONTR 15:48:59 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 15:48:59 MONTR define DSK: DSK:, P20:, PI: 15:49:03 MONTR @S:DEC20-CROSS.EXE 15:49:05 USER Dec 20 cross compiler 15:49:07 USER [8] ASMOut "fasl"; 15:49:08 USER ASMOUT: IN files; or type in expressions 15:49:09 USER When all done execute ASMEND; 15:50:57 USER [9] in "fasl.build"; 15:50:59 USER % 15:50:59 USER % FASL.BUILD - Files used for Fasl in the interpreter 15:50:59 USER % 15:50:59 USER % Author: Eric Benson 15:50:59 USER % Symbolic Computation Group 15:50:59 USER % Computer Science Dept. 15:50:59 USER % University of Utah 15:50:59 USER % Date: 19 May 1982 15:50:59 USER % Copyright (c) 1982 University of Utah 15:50:59 USER % 15:50:59 USER 15:50:59 USER PathIn "system-faslout.red"$ 15:51:02 USER PathIn "system-faslin.red"$ 15:51:12 USER PathIn "faslin.red"$ 15:51:42 USER *** Garbage collection starting 15:52:01 USER *** GC 4: time 3388 ms 15:52:01 USER *** 68004 recovered, 564 stable, 21432 active, 68004 free 15:52:15 USER 15:52:15 USER PathIn "load.red"$ 15:52:18 USER *** Function `LOAD' has been redefined 15:52:21 USER *** Function `RELOAD' has been redefined 15:52:35 USER % Standard module FASL loader 15:52:35 USER PathIn "autoload.red"$ % stubs to load modules 15:52:53 USER [10] ASMEnd; 15:53:51 USER *** Garbage collection starting 15:54:19 USER *** GC 5: time 3087 ms 15:54:19 USER *** 73806 recovered, 13587 stable, 2607 active, 73806 free 15:54:51 USER NIL 15:54:52 USER [11] quit; 15:54:55 MONTR @compile fasl.mac, dfasl.mac 15:55:01 USER MACRO: .MAIN 15:55:09 USER MACRO: .MAIN 15:55:10 USER 15:55:10 USER EXIT 15:55:13 MONTR @delete fasl.mac, dfasl.mac 15:55:13 MONTR FASL.MAC.1 [OK] 15:55:14 MONTR DFASL.MAC.1 [OK] 15:55:20 MONTR @ 15:55:27 MONTR Killed by OPERATOR, TTY 221 15:55:27 MONTR Killed Job 13, User KESSLER, Account SMALL, TTY 225, 15:55:27 MONTR at 7-Mar-83 15:55:26, Used 0:01:14 in 0:06:40 |
Added psl-1983/20-kernel/fasl.rel version [d6ff155aea].
cannot compute difference between binary files
Added psl-1983/20-kernel/fast-binder.red version [65b143359d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FAST-BINDER.RED - Fast binding and unbinding routines in LAP for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 July 1981 % Copyright (c) 1981 University of Utah % on SysLisp; external WVar BndStkPtr, % The binding stack pointer BndStkLowerBound, % Bottom of the binding stack BndStkUpperBound; % Top of the binding stack % TAG( FastBind ) lap '((!*Entry FastBind expr 0) % Bind IDs to values in registers % % FastBind is called with JSP T5, followed by % regnum,,idnum % ... % (!*MOVE (WVar BndStkPtr) (reg t2)) % load binding stack pointer Loop (!*MOVE (Indexed (reg t5) (WConst 0)) (reg t1)) % get next entry (tlnn (reg t1) 8#777000) % if it's not an instruction (!*JUMP (Label MoreLeft)) % keep binding (!*MOVE (reg t2) (WVar BndStkPtr)) % Otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 0))) % and return MoreLeft (!*WPLUS2 (reg t2) (WConst 2)) % add 2 to binding stack pointer (caml (reg t2) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (hlrz (reg t3) (reg t1)) % stick register number in t3 (caile (reg t3) (WConst MaxRealRegs)) % is it a real register? (!*WPLUS2 (reg t3) % no, move to arg block (WConst (difference (WArray ArgumentBlock) (plus (WConst MaxRealRegs) 1)))) (hrrzm (reg t1) (Indexed (reg t2) (WConst -1))) % store ID number in BndStk (!*MOVE (MEMORY (reg t1) (WConst SymVal)) (reg t4)) % get old value for ID in t4 (!*MOVE (reg t4) (MEMORY (reg t2) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t3)) % get reg value in t3 (!*MOVE (reg t3) (MEMORY (reg t1) (WConst SymVal))) % store in ID value cell (aoja (reg t5) Loop) % try again ); % TAG( FastUnBind ) lap '((!*Entry FastUnBind expr 0) % Unbind last N entries in bind stack % % FastUnBind is called with JSP T5, followed by word containing count to % unbind. % (!*MOVE (WVar BndStkPtr) (reg t1)) % get binding stack pointer in t1 (!*MOVE (MEMORY (reg t5) (WConst 0)) (reg t2)) % count in t2 Loop (!*JUMPWGREATERP (Label MoreLeft) (reg t2) (WConst 0)) % continue if count is > zero (!*MOVE (reg t1) (WVar BndStkPtr)) % otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 1))) % and return MoreLeft (camge (reg t1) (WVar BndStkLowerBound)) % check for underflow (!*JCALL BStackUnderflow) (dmove (reg t3) (Indexed (reg t1) -1)) % get ID # in t3, value in t4 (!*MOVE (reg t4) (MEMORY (reg t3) (WConst SymVal))) % restore to value cell (!*WDIFFERENCE (reg t1) (WConst 2)) % adjust binding stack pointer -2 (soja (reg t2) Loop) % and count down by 1, then try again ); off SysLisp; END; |
Added psl-1983/20-kernel/fresh-kernel.ctl version [c603c0893f].
> > > > > | 1 2 3 4 5 | rename 20.SYM PREVIOUS-20.SYM copy PC:BARE-PSL.SYM 20.SYM ; To regenerate the .CTL files: ; PSL:PSL ; (dskin "20-kernel-gen.sl") |
Added psl-1983/20-kernel/fresh-kernel.log version [d228261f26].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20>FRESH-KERNEL.CTL.3 started at 7-Mar-83 15:11:40] TOPS-20 Command processor 5(712)-1 @rename 20.SYM PREVIOUS-20.SYM %No such filename - 20.SYM @copy PC:BARE-PSL.SYM 20.SYM <PSL.COMP>BARE-PSL.SYM.1 => 20.SYM.27 [OK] @; To regenerate the .CTL files: ; PSL:PSL ; (dskin "20-kernel-gen.sl") [DO: Execution finished at 7-Mar-83 15:11:56] |
Added psl-1983/20-kernel/fresh.mic version [941abc70a4].
> > > > > > > > | 1 2 3 4 5 6 7 8 | ;; Independant compilation of a DEC20 program ; ; MIC FRESH modulename ; ; Initialize for new sequence of builds ; @delete 'a.SYM @copy P20:bare-20.sym 'A.sym |
Added psl-1983/20-kernel/function-primitives.red version [22e70d1d8c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FUNCTION-PRIMITIVES.RED - primitives used by PUTD/GETD and EVAL/APPLY % P20: version % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 August 1981 % Copyright (c) 1981 University of Utah % % Every ID has a "function cell". It does not necessarily contain a legal % Lisp item, and therefore should not be accessed directly by Lisp functions. % In this implementation the function cell contains an instruction to be % executed. There are 3 possibilites for this instruction, for which the % following predicates and updating functions exist: % % FUnBoundP(ID) -- the function is not defined % FLambdaLinkP(ID) -- the function is interpreted % FCodeP(ID) -- the function is compiled % % MakeFUnBound(ID) -- undefine the function % MakeFLambdaLink(ID) -- specify that the function is interpreted % MakeFCode(ID, CodePtr) -- specify that the function is compiled, % and that the code resides at the address % associated with CodePtr % % GetFCodePointer(ID) -- returns the contents of the function cell as a % code pointer % These functions currently check that they have proper arguments, but this may % change since they are only used by functions that have checked them already. % Note that MakeFCode is necessarily machine-dependent -- this file currently % contains the PDP-10 version. This function should be moved to a file of % system-dependent routines. Of course, other things in this file will % probably have to change for a different machine as well. on SysLisp; internal WVar UnDefn = 8#265500000000 + &SymFnc IDLoc UndefinedFunction; internal WVar LamLnk = 8#265500000000 % JSP T5,xxx + &SymFnc IDLoc CompiledCallingInterpreted; % currently the WVars UnDefn and LamLnk contain the instructions which will % be found in the function cells of undefined and interpreted functions. syslsp procedure FUnBoundP U; %. does U not have a function defn? if IDP U then SymFnc U eq UnDefn else NonIDError(U, 'FUnBoundP); syslsp procedure FLambdaLinkP U; %. is U an interpreted function? if IDP U then SymFnc U eq LamLnk else NonIDError(U, 'FLambdaLinkP); syslsp procedure FCodeP U; %. is U a compiled function? if IDP U then SymFnc U neq UnDefn and SymFnc U neq LamLnk else NonIDError(U, 'FCodeP); syslsp procedure MakeFUnBound U; %. Make U an undefined function if IDP U then << SymFnc U := UnDefn; NIL >> else NonIDError(U, 'MakeFUnBound); syslsp procedure MakeFLambdaLink U; %. Make U an interpreted function if IDP U then << SymFnc U := LamLnk; NIL >> else NonIDError(U, 'MakeFLambdaLink); syslsp procedure MakeFCode(U, CodePtr); %. Make U a compiled function if IDP U then if CodeP CodePtr then << SymFnc U := CodePtr; PutField(SymFnc U, 0, 9, 8#254); % JRST NIL >> else NonIDError(U, 'MakeFCode); syslsp procedure GetFCodePointer U; %. Get code pointer for U if IDP U then MkCODE SymFnc U else NonIDError(U, 'GetFCodePointer); off SysLisp; END; |
Added psl-1983/20-kernel/gc.red version [08b9a25308].
> | 1 | in "compacting-gc.red"$ |
Added psl-1983/20-kernel/global-data.red version [0a173e0d61].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLOBAL-DATA.RED - Data used by everyone % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 September 1981 % Revised: 31 January 1983 % Copyright (c) 1981 University of Utah % % 31-Jan-83 Nancy Kendzierski % Increased BPSSize to 100000 from 90000; decreased HeapSize to 90000 % from 100000. on SysLisp; exported WConst MaxSymbols = 8000, HeapSize = 90000, MaxObArray = 8209, % first prime above 8192 StackSize = 10000, BPSSize = 100000; exported WConst CompressedBinaryRadix = 8; external WArray SymNam, SymVal, SymFnc, SymPrp; external WVar NextSymbol; exported WConst MaxRealRegs = 5, MaxArgs = 15; external WArray ArgumentBlock; external WArray HashTable; off SysLisp; END; |
Added psl-1983/20-kernel/heap.build version [3923a49f69].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % % HEAP.BUILD - Declaration of the heap and BPS % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 May 1982 % Copyright (c) 1982 University of Utah % on Syslisp; exported WArray BPS[BPSSize], Heap[HeapSize]; off Syslisp; END; |
Added psl-1983/20-kernel/heap.ctl version [e189dba0dc].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "heap"; in "heap.build"; ASMEnd; quit; compile heap.mac, dheap.mac delete heap.mac, dheap.mac |
Added psl-1983/20-kernel/heap.init version [a7ffc6f8bf].
Added psl-1983/20-kernel/heap.log version [8cee160820].
cannot compute difference between binary files
Added psl-1983/20-kernel/heap.rel version [be8f5b533e].
cannot compute difference between binary files
Added psl-1983/20-kernel/ibmize.clu version [84b94746fb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IBMIZE -- Extract underline and boldface info. from a % lineprinter file (and convert for the IBM) % % Control chararacters handled: TAB, NL, FF, CR % Other control characters assumed to be printing. % Tab stops assumed every 8 columns. % 9/14/82 Added handling of empty lines at end of page. % Somewhat ugly change. % The pgstream represents the state of output. Pgline % is the current line within the page, beginning at 1. % Emptycount keeps track of saved up lines with no visible % contents. These will be output if a nonempty line arrives % before end of page. pgstream = record[pgline: int, s: stream, emptycount: int] ac = array[char] % Line with possible underscore and/or boldface u_b_line = record[line: array[char], underscore: array[bool], bold: array[bool]] LINE_LENGTH = 150 % maximum printing length of output line main = proc () sin: stream := get_io("read", "Input file: ", "lpt") except others: return end sout: stream := get_io("write", "Output file: ", "ibm") except others: return end process_file(sin, pgstream${s: sout, pgline: 1, emptycount: 0}) stream$close(sin) stream$close(sout) end main % process_file(sin: stream, lout: pgstream) % Reads from sin until end of file, process each line to make % overstriking work, and keeps track of the position on the current % page, inserting form feeds as it deems necessary. process_file = proc (sin: stream, lout: pgstream) oline: u_b_line := u_b_line${line: ac$fill(0, LINE_LENGTH, ' '), underscore: array[bool]$fill(0, LINE_LENGTH, false), bold: array[bool]$fill(0, LINE_LENGTH, false)} sout: stream := lout.s while true do process_line(sin, lout, oline) end except others: end %% stream$putc(sout,'\p') end process_file process_line = proc (sin: stream, lout: pgstream, oline: u_b_line) signals (done) sout: stream := lout.s line: string := get_line(sin) except others: signal done end %% Insert FF if needed. %% if lout.pgline > 60 cand ~ char$equal(string$fetch(line,1),'\p') %% then %% stream$putc (sout, '\p') %% lout.pgline := 1 %% lout.emptycount := 0 %% end for i: int in int$from_to(0,LINE_LENGTH - 1) do oline.line[i] := ' ' oline.underscore[i] := false oline.bold[i] := false end col: int := 0 for c: char in string$chars (line) do %% Special handling for non-printing chars and '_' if c = ' ' then col := col + 1 elseif c = '\r' then col := 0 elseif c = '\n' then lout.pgline := lout.pgline + 1 elseif c = '\b' then col := col - 1 elseif c = '\t' then col := col + 8 - (col // 8) elseif c = '\p' then col := 0 lout.pgline := 1 elseif c = '_' then oline.underscore[col] := true col := col + 1 else oc: char := oline.line[col] if oc = ' ' then oline.line[col] := c elseif oc = c then oline.bold[col] := true end col := col + 1 end end emptyp: bool := true for i: int in int$from_to(0,LINE_LENGTH - 1) do if oline.line[i] ~= ' ' cor oline.underscore[i] then emptyp := false break; end end if emptyp then lout.emptycount := lout.emptycount + 1 else %% Put out any saved-up empty lines first for i:int in int$from_to(1,lout.emptycount) do stream$putc(sout,'\n') end lout.emptycount := 0 %% Print out everything involved in the line. output_line(oline, sout) end %% Print the formfeed that came with (terminating) the line. if char$equal('\p',string$fetch(line,string$size(line))) then stream$putc(sout,'\p') %% Throw away any empty lines just preceding \p lout.emptycount := 0 elseif ~emptyp then stream$putc(sout,'\n') end end process_line % output_line(oline, sout: stream) output_line = proc(oline: u_b_line, sout: stream) high: int := line_high(oline) for i: int in int$from_to (0, high) do stream$putc(sout, oline.line[i]) if oline.underscore[i] then stream$putc(sout, '\b') stream$putc(sout, '_') end end %% stream$putc (sout, '\n') end output_line % line_high (line: u_b_line) returns (int) % Returns the index in the line of the last printing character. % If none exists, returns the minimum index minus 1. line_high = proc(oline: u_b_line) returns (int) for i: int in int$from_to_by(ac$high(oline.line), ac$low(oline.line), -1) do if oline.line[i] ~= ' ' cor oline.underscore[i] then return(i) end end return(ac$low(oline.line) - 1) end line_high % get_line (sin: stream) returns (string) signals (end_of_file) % Reads from the stream characters through the first \n or \p. % If end of file is reached before any characters are entered, % end of file is signalled, otherwise not. % All characters read are returned. get_line = proc (sin: stream) returns (string) signals (end_of_file) a: ac := ac$new () while true do c: char := stream$getc_image (sin) except others: if ac$size (a) = 0 then signal end_of_file end break end ac$addh (a, c) if c = '\n' cor c = '\p' then break end end %% if ac$top (a) = '\r' then ac$remh (a) end except when bounds: end return (string$ac2s (a)) end get_line %%% Defines: get_line line_high main output_line process_file process_line %%% Edited: 14 September 1982 10:41:36 %%% Uses: get_io %%% Written: 14 September 1982 10:45:04 |
Added psl-1983/20-kernel/ibmize.cluprog version [3c26af48ff].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | %%% DebugFile: ps:<hp-psl.misc>ibmize.debug %%% ExecutableFile: ps:<hp-psl.misc>ibmize.exe %%% MainProcedure: main %%% MakeFile: ps:<hp-psl.misc>ibmize.cmd %%% Optimize: F %%% ProgramFile: ps:<hp-psl.misc>ibmize.cluprog %%% SourceFiles: ps:<hp-psl.misc>ibmize.clu ps:<clu.tlib>msg.clu %%% ps:<perdue.utils>get_io.clu %%% XloadFile: ps:<hp-psl.misc>ibmize.xload |
Added psl-1983/20-kernel/ibmize.cmd version [8f3cf0ef6b].
> | 1 | tlink &ps:<hp-psl.misc>ibmize.xload \search:<clu.tlib> \main:main ^ps:<hp-psl.misc>ibmize.exe |
Added psl-1983/20-kernel/ibmize.debug version [6e92fe65d2].
> | 1 | tlink &ps:<hp-psl.misc>ibmize.xload \search:<clu.tlib> \debug |
Added psl-1983/20-kernel/ibmize.exe version [00938c60b2].
cannot compute difference between binary files
Added psl-1983/20-kernel/ibmize.tbin version [5e18c9147d].
cannot compute difference between binary files
Added psl-1983/20-kernel/ibmize.xload version [ece3362003].
> > > | 1 2 3 | ps:<hp-psl.misc>ibmize ps:<clu.tlib>msg ps:<perdue.utils>get_io |
Added psl-1983/20-kernel/io-data.red version [60828e281d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-DATA.RED - Data structures used by input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>IO-DATA.RED.2, 29-Dec-82 12:19:36, Edit by PERDUE % Added PagePosition array to support LPOSN on SysLisp; internal WConst MaxTokenSize = 5000; exported WString TokenBuffer[MaxTokenSize]; exported WConst MaxChannels = 31; exported WArray ReadFunction = ['TerminalInputHandler, 'WriteOnlyChannel, 'WriteOnlyChannel, 'CompressReadChar, 'WriteOnlyChannel, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], WriteFunction = ['ReadOnlyChannel, 'Dec20WriteChar, 'ToStringWriteChar, 'ExplodeWriteChar, 'FlatSizeWriteChar, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], CloseFunction = ['IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], UnReadBuffer[MaxChannels], LinePosition[MaxChannels], PagePosition[MaxChannels], MaxLine = [0, 80,80, 10000, 10000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], JFNOfChannel = [8#100,8#101,-1,-1,-1, 0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]; off SysLisp; global '(!$EOL!$); LoadTime(!$EOL!$ := '! ); END; |
Added psl-1983/20-kernel/io.ctl version [465e3ae11a].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "io"; in "io.build"; ASMEnd; quit; compile io.mac, dio.mac delete io.mac, dio.mac |
Added psl-1983/20-kernel/io.init version [01052781df].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | (GLOBAL (QUOTE (!$EOL!$))) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!*))) (GLOBAL (QUOTE (SPECIALRDSACTION!* SPECIALWRSACTION!* IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!*))) (GLOBAL (QUOTE (OUT!*))) (FLUID (QUOTE (!*RAISE))) (FLUID (QUOTE (CURRENTREADMACROINDICATOR!* CURRENTSCANTABLE!* !*INSIDESTRUCTUREREAD))) (GLOBAL (QUOTE (TOKTYPE!* LISPSCANTABLE!* IN!* !$EOF!$))) (FLUID (QUOTE (CURRENTSCANTABLE!* !*RAISE !*COMPRESSING !*EOLINSTRINGOK))) (FLUID (QUOTE (OUTPUTBASE!* PRINLENGTH PRINLEVEL CURRENTSCANTABLE!* IDESCAPECHAR!* !*LOWER))) (GLOBAL (QUOTE (LISPSCANTABLE!*))) (FLUID (QUOTE (FORMATFORPRINTF!*))) (FLUID (QUOTE (EXPLODEENDPOINTER!* COMPRESSLIST!* !*COMPRESSING))) (GLOBAL (QUOTE (IN!* OUT!*))) |
Added psl-1983/20-kernel/io.log version [1aa560e0c6].
cannot compute difference between binary files
Added psl-1983/20-kernel/io.rel version [ab35d4e5de].
cannot compute difference between binary files
Added psl-1983/20-kernel/killdir.mic version [297e7de366].
> > > > | 1 2 3 4 | build ss:<psl.'A> kill |
Added psl-1983/20-kernel/macro.ctl version [44fcd1710b].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "macro"; in "macro.build"; ASMEnd; quit; compile macro.mac, dmacro.mac delete macro.mac, dmacro.mac |
Added psl-1983/20-kernel/macro.init version [86d5c6a27d].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (PUT (QUOTE COMMENTOUTCODE) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (COMMENTOUTCODE COMPILETIME)) (QUOTE IGNORE)) (FLAG (QUOTE (BOTHTIMES)) (QUOTE EVAL)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE IGNORE)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE EVAL)) (PUT (QUOTE CONTERROR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CASE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE SETF) (QUOTE TYPE) (QUOTE MACRO)) (DEFLIST (QUOTE ((GETV PUTV) (CAR RPLACA) (CDR RPLACD) (INDX SETINDX) (SUB SETSUB) (NTH (LAMBDA (L I X) (RPLACA (PNTH L I) X) X)) (EVAL SET) (VALUE SET))) (QUOTE ASSIGN!-OP)) (PUT (QUOTE ON) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE OFF) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (ON OFF)) (QUOTE IGNORE)) (PUT (QUOTE DS) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DEFCONST) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (DEFCONST)) (QUOTE EVAL)) (PUT (QUOTE CONST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (STRINGGENSYM!*))) (SETQ STRINGGENSYM!* (COPYSTRING "L0000")) (PUT (QUOTE FOREACH) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE EXIT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE NEXT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE WHILE) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE REPEAT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE FOR) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/20-kernel/macro.log version [fab66ab8b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 16:04:44 BATCON Version 104(4133) GLXLIB Version 1(527) Job MACRO Req #264 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 802 Input from => PS:<PSL.KERNEL.20>MACRO.CTL.2 Output to => PS:<PSL.KERNEL.20>MACRO.LOG 16:04:44 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 16:04:44 MONTR @SET TIME-LIMIT 1200 16:04:45 MONTR @LOGIN KESSLER SMALL 16:04:48 MONTR Job 13 on TTY225 7-Mar-83 16:04:48 16:04:48 MONTR Previous login at 7-Mar-83 15:55:36 16:04:48 MONTR There is 1 other job logged in as user KESSLER 16:04:57 MONTR @ 16:04:57 MONTR [PS Mounted] 16:04:57 MONTR 16:04:57 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 16:04:57 MONTR define DSK: DSK:, P20:, PI: 16:04:58 MONTR @S:DEC20-CROSS.EXE 16:05:00 USER Dec 20 cross compiler 16:05:03 USER [8] ASMOut "macro"; 16:05:07 USER ASMOUT: IN files; or type in expressions 16:05:07 USER When all done execute ASMEND; 16:06:20 USER [9] in "macro.build"; 16:06:21 USER % 16:06:21 USER % MACRO.BUILD - Files of macros defined in the interpreter 16:06:21 USER % 16:06:21 USER % Author: Eric Benson 16:06:21 USER % Symbolic Computation Group 16:06:21 USER % Computer Science Dept. 16:06:21 USER % University of Utah 16:06:21 USER % Date: 19 May 1982 16:06:21 USER % Copyright (c) 1982 University of Utah 16:06:21 USER % 16:06:21 USER 16:06:21 USER % <PSL.KERNEL>MACRO.BUILD.2, 2-Feb-83 15:36:40, Edit by PERDUE 16:06:21 USER % Removed char.red. It is now pnk:char-macro.red 16:06:21 USER 16:06:21 USER PathIn "eval-when.red"$ 16:06:22 USER *** Function `COMMENTOUTCODE' has been redefined 16:06:26 USER % control evaluation time 16:06:26 USER PathIn "cont-error.red"$ 16:06:31 USER *** Function `CONTERROR' has been redefined 16:06:44 USER % macro for ContinuableError 16:06:44 USER PathIn "lisp-macros.red"$ 16:06:56 USER *** Function `SETF' has been redefined 16:06:57 USER % Various macros for readability 16:06:58 USER PathIn "onoff.red"$ 16:07:01 USER *** Function `ON' has been redefined 16:07:02 USER *** Function `OFF' has been redefined 16:07:02 USER *** Garbage collection starting 16:07:27 USER *** GC 4: time 3242 ms 16:07:27 USER *** 73050 recovered, 564 stable, 16385 active, 73051 free 16:07:37 USER % (on xxx yyy) and (off xxx yyy) 16:07:37 USER PathIn "define-smacro.red"$ 16:07:57 USER *** Function `DS' has been redefined 16:08:15 USER 16:08:15 USER PathIn "defconst.red"$ 16:08:16 USER *** Function `DEFCONST' has been redefined 16:08:18 USER *** Function `CONST' has been redefined 16:08:19 USER 16:08:19 USER PathIn "string-gensym.red"$ 16:08:23 USER PathIn "loop-macros.red"$ 16:08:25 USER *** Function `FOREACH' has been redefined 16:08:31 USER *** Function `EXIT' has been redefined 16:08:32 USER *** Function `NEXT' has been redefined 16:08:32 USER *** Function `WHILE' has been redefined 16:08:34 USER *** Function `REPEAT' has been redefined 16:08:43 USER *** Function `FOR' has been redefined 16:08:44 USER *** Garbage collection starting 16:09:04 USER *** GC 5: time 2950 ms 16:09:04 USER *** 70120 recovered, 16605 stable, 3275 active, 70120 free 16:09:13 USER % Various macros for readability 16:09:14 USER [10] ASMEnd; 16:10:31 USER NIL 16:10:32 USER [11] quit; 16:10:33 MONTR @compile macro.mac, dmacro.mac 16:10:37 USER MACRO: .MAIN 16:10:51 USER MACRO: .MAIN 16:10:52 USER 16:10:52 USER EXIT 16:10:52 MONTR @delete macro.mac, dmacro.mac 16:10:56 MONTR MACRO.MAC.1 [OK] 16:10:56 MONTR DMACRO.MAC.1 [OK] 16:10:56 MONTR @ 16:10:58 MONTR Killed by OPERATOR, TTY 221 16:10:58 MONTR Killed Job 13, User KESSLER, Account SMALL, TTY 225, 16:10:58 MONTR at 7-Mar-83 16:10:58, Used 0:01:27 in 0:06:10 |
Added psl-1983/20-kernel/macro.rel version [5eb374c75c].
cannot compute difference between binary files
Added psl-1983/20-kernel/main-start.red version [afac7fb3ce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MAIN-START.RED - First routine called on startup % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>MAIN-START.RED.4, 5-Oct-82 10:42:14, Edit by BENSON % Added call to EvalInitForms in MAIN!. on SysLisp; internal WConst StackSize = 4000; internal WArray Stack[StackSize]; exported WVar StackLowerBound = &Stack[0], StackUpperBound = &Stack[StackSize]; external WVar ST; internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1; % 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs exported WArray ArgumentBlock[MaxArgBlock]; exported WArray HashTable[MaxObArray/2]; lap '((!*entry Main!. expr 0) Forever (move (reg st) (lit (halfword (minus (WConst StackSize)) (difference (WConst Stack) 1)))) (move (reg nil) (fluid nil)) (!*CALL pre!-main) (jrst Forever) ); syslsp procedure Reset(); Throw('Reset, 'Reset); syslsp procedure pre!-main(); << ClearBindings(); ClearIO(); EvalInitForms(); if Catch('Reset, Main()) = 'Reset then pre!-main() >>; syslsp procedure Main(); %. initialization function % % A new system can be created by redefining this function to call whatever % top loop is desired. % << InitCode(); % special code accumulated in compiler SymFnc IDLoc Main := SymFnc IDLoc StandardLisp; % don't do it again StandardLisp() >>; off SysLisp; END; |
Added psl-1983/20-kernel/main.ctl version [1d9c233eeb].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "main"; in "main.build"; ASMEnd; quit; compile main.mac, dmain.mac delete main.mac, dmain.mac |
Added psl-1983/20-kernel/main.init version [a7ffc6f8bf].
Added psl-1983/20-kernel/main.log version [d6f8b30d25].
cannot compute difference between binary files
Added psl-1983/20-kernel/main.mac version [ae9021b687].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 | search monsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern STACK extern L1191 extern L2107 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.:L3694: MOVE 15,L3693 MOVE 0,SYMVAL+128 PUSHJ 15,SYMFNC+842 JRST L3694 L3693: byte(18)-4000,STACK-1 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 2,L3695 MOVE 1,L3695 JRST SYMFNC+495 L3695: <30_31>+536 0 ; (!*ENTRY PRE!-MAIN EXPR 0) L3697: intern L3697 ADJSP 15,2 L3698: PUSHJ 15,SYMFNC+780 PUSHJ 15,SYMFNC+793 PUSHJ 15,SYMFNC+837 MOVE 1,L3696 PUSHJ 15,SYMFNC+499 MOVEM 1,0(15) CAME 0,SYMVAL+500 JRST L3699 PUSHJ 15,SYMFNC+843 MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+501 MOVE 1,-1(15) L3699: CAMN 1,L3696 JRST L3698 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L3696: <30_31>+536 0 ; (!*ENTRY MAIN EXPR 0) MAIN: intern MAIN PUSHJ 15,SYMFNC+844 MOVE 6,833+SYMFNC MOVEM 6,843+SYMFNC JRST SYMFNC+833 0 ; (!*ENTRY INITCODE EXPR 0) L3716: intern L3716 MOVE 3,L3700 MOVE 2,L3701 MOVE 1,L3702 PUSHJ 15,SYMFNC+308 MOVE 3,L3700 MOVE 2,L3701 MOVE 1,L3703 PUSHJ 15,SYMFNC+308 MOVE 3,L3704 MOVE 2,L3705 MOVE 1,L3706 PUSHJ 15,SYMFNC+308 MOVE 3,L3707 MOVE 2,L3705 MOVE 1,L3708 PUSHJ 15,SYMFNC+308 MOVE 3,L3709 MOVE 2,L3705 MOVE 1,L3710 PUSHJ 15,SYMFNC+308 MOVE 3,L3711 MOVE 2,L3705 MOVE 1,L3712 PUSHJ 15,SYMFNC+308 MOVE 3,L3713 MOVE 2,L3705 HRRZI 1,26 TLZ 1,253952 TLO 1,245760 PUSHJ 15,SYMFNC+308 PUSHJ 15,SYMFNC+790 HRRZI 3,26 MOVE 2,L3714 MOVE 1,L3715 JRST SYMFNC+308 L3715: <30_31>+845 L3714: <30_31>+846 L3713: <30_31>+640 L3712: <30_31>+91 L3711: <30_31>+645 L3710: <30_31>+41 L3709: <30_31>+644 L3708: <30_31>+40 L3707: <30_31>+643 L3706: <30_31>+39 L3705: <30_31>+637 L3704: <30_31>+642 L3703: <30_31>+254 L3702: <30_31>+272 L3701: <30_31>+758 L3700: <30_31>+262 L3717: <30_31>+269 <9_31>+L3718 L3718: <30_31>+518 <9_31>+L3719 L3719: <30_31>+296 <9_31>+L3720 L3720: <30_31>+508 <9_31>+L3721 L3721: <30_31>+509 <9_31>+L3722 L3722: <30_31>+498 <9_31>+L3723 L3723: <30_31>+478 <9_31>+L3724 L3724: <30_31>+273 <9_31>+L3725 L3725: <30_31>+806 <9_31>+L3726 L3726: <30_31>+808 <9_31>+L3727 L3727: <30_31>+510 <9_31>+L3728 L3728: <30_31>+452 <9_31>+L3729 L3729: <30_31>+843 <30_31>+128 intern L3717 L3730: <30_31>+278 <9_31>+L3731 L3731: <30_31>+541 <9_31>+L3732 L3732: <30_31>+274 <9_31>+L3733 L3733: <30_31>+276 <9_31>+L3734 L3734: <30_31>+272 <9_31>+L3735 L3735: <30_31>+268 <30_31>+128 intern L3730 L3736: <30_31>+847 <9_31>+L3737 L3737: <30_31>+848 <9_31>+L3738 L3738: <30_31>+849 <9_31>+L3739 L3739: <30_31>+850 <30_31>+128 intern L3736 L3740: <4_31>+L3741 <9_31>+L3742 L3741: -1 byte(7)0 L3742: <4_31>+L3743 <30_31>+128 L3743: 2 byte(7)112,108,58,0 intern L3740 L3744: <9_31>+L3745 <9_31>+L3746 L3745: <4_31>+L3747 <30_31>+559 L3746: <9_31>+L3748 <9_31>+L3749 L3747: 1 byte(7)46,98,0 L3748: <4_31>+L3750 <30_31>+840 L3749: <9_31>+L3751 <30_31>+128 L3750: 3 byte(7)46,108,97,112,0 L3751: <4_31>+L3752 <30_31>+840 L3752: 2 byte(7)46,115,108,0 intern L3744 L3753: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_31>+851 intern L3753 L3754: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_31>+851 intern L3754 L3755: 21 byte(7)80,111,114,116,97,98,108,101,32,83,116,97,110,100,97,114,100,32,76,73,83,80,0 intern L3755 L3756: 0 byte(7)0,0 intern L3756 L3757: 0 byte(7)1,0 intern L3757 L3758: 0 byte(7)2,0 intern L3758 L3759: 0 byte(7)3,0 intern L3759 L3760: 0 byte(7)4,0 intern L3760 L3761: 0 byte(7)5,0 intern L3761 L3762: 0 byte(7)6,0 intern L3762 L3763: 0 byte(7)7,0 intern L3763 L3764: 0 byte(7)8,0 intern L3764 L3765: 0 byte(7)9,0 intern L3765 L3766: 0 byte(7)10,0 intern L3766 L3767: 0 byte(7)11,0 intern L3767 L3768: 0 byte(7)12,0 intern L3768 L3769: 0 byte(7)13,0 intern L3769 L3770: 0 byte(7)14,0 intern L3770 L3771: 0 byte(7)15,0 intern L3771 L3772: 0 byte(7)16,0 intern L3772 L3773: 0 byte(7)17,0 intern L3773 L3774: 0 byte(7)18,0 intern L3774 L3775: 0 byte(7)19,0 intern L3775 L3776: 0 byte(7)20,0 intern L3776 L3777: 0 byte(7)21,0 intern L3777 L3778: 0 byte(7)22,0 intern L3778 L3779: 0 byte(7)23,0 intern L3779 L3780: 0 byte(7)24,0 intern L3780 L3781: 0 byte(7)25,0 intern L3781 L3782: 0 byte(7)26,0 intern L3782 L3783: 0 byte(7)27,0 intern L3783 L3784: 0 byte(7)28,0 intern L3784 L3785: 0 byte(7)29,0 intern L3785 L3786: 0 byte(7)30,0 intern L3786 L3787: 0 byte(7)31,0 intern L3787 L3788: 0 byte(7)32,0 intern L3788 L3789: 0 byte(7)33,0 intern L3789 L3790: 0 byte(7)34,0 intern L3790 L3791: 0 byte(7)35,0 intern L3791 L3792: 0 byte(7)36,0 intern L3792 L3793: 0 byte(7)37,0 intern L3793 L3794: 0 byte(7)38,0 intern L3794 L3795: 0 byte(7)39,0 intern L3795 L3796: 0 byte(7)40,0 intern L3796 L3797: 0 byte(7)41,0 intern L3797 L3798: 0 byte(7)42,0 intern L3798 L3799: 0 byte(7)43,0 intern L3799 L3800: 0 byte(7)44,0 intern L3800 L3801: 0 byte(7)45,0 intern L3801 L3802: 0 byte(7)46,0 intern L3802 L3803: 0 byte(7)47,0 intern L3803 L3804: 0 byte(7)48,0 intern L3804 L3805: 0 byte(7)49,0 intern L3805 L3806: 0 byte(7)50,0 intern L3806 L3807: 0 byte(7)51,0 intern L3807 L3808: 0 byte(7)52,0 intern L3808 L3809: 0 byte(7)53,0 intern L3809 L3810: 0 byte(7)54,0 intern L3810 L3811: 0 byte(7)55,0 intern L3811 L3812: 0 byte(7)56,0 intern L3812 L3813: 0 byte(7)57,0 intern L3813 L3814: 0 byte(7)58,0 intern L3814 L3815: 0 byte(7)59,0 intern L3815 L3816: 0 byte(7)60,0 intern L3816 L3817: 0 byte(7)61,0 intern L3817 L3818: 0 byte(7)62,0 intern L3818 L3819: 0 byte(7)63,0 intern L3819 L3820: 0 byte(7)64,0 intern L3820 L3821: 0 byte(7)65,0 intern L3821 L3822: 0 byte(7)66,0 intern L3822 L3823: 0 byte(7)67,0 intern L3823 L3824: 0 byte(7)68,0 intern L3824 L3825: 0 byte(7)69,0 intern L3825 L3826: 0 byte(7)70,0 intern L3826 L3827: 0 byte(7)71,0 intern L3827 L3828: 0 byte(7)72,0 intern L3828 L3829: 0 byte(7)73,0 intern L3829 L3830: 0 byte(7)74,0 intern L3830 L3831: 0 byte(7)75,0 intern L3831 L3832: 0 byte(7)76,0 intern L3832 L3833: 0 byte(7)77,0 intern L3833 L3834: 0 byte(7)78,0 intern L3834 L3835: 0 byte(7)79,0 intern L3835 L3836: 0 byte(7)80,0 intern L3836 L3837: 0 byte(7)81,0 intern L3837 L3838: 0 byte(7)82,0 intern L3838 L3839: 0 byte(7)83,0 intern L3839 L3840: 0 byte(7)84,0 intern L3840 L3841: 0 byte(7)85,0 intern L3841 L3842: 0 byte(7)86,0 intern L3842 L3843: 0 byte(7)87,0 intern L3843 L3844: 0 byte(7)88,0 intern L3844 L3845: 0 byte(7)89,0 intern L3845 L3846: 0 byte(7)90,0 intern L3846 L3847: 0 byte(7)91,0 intern L3847 L3848: 0 byte(7)92,0 intern L3848 L3849: 0 byte(7)93,0 intern L3849 L3850: 0 byte(7)94,0 intern L3850 L3851: 0 byte(7)95,0 intern L3851 L3852: 0 byte(7)96,0 intern L3852 L3853: 0 byte(7)97,0 intern L3853 L3854: 0 byte(7)98,0 intern L3854 L3855: 0 byte(7)99,0 intern L3855 L3856: 0 byte(7)100,0 intern L3856 L3857: 0 byte(7)101,0 intern L3857 L3858: 0 byte(7)102,0 intern L3858 L3859: 0 byte(7)103,0 intern L3859 L3860: 0 byte(7)104,0 intern L3860 L3861: 0 byte(7)105,0 intern L3861 L3862: 0 byte(7)106,0 intern L3862 L3863: 0 byte(7)107,0 intern L3863 L3864: 0 byte(7)108,0 intern L3864 L3865: 0 byte(7)109,0 intern L3865 L3866: 0 byte(7)110,0 intern L3866 L3867: 0 byte(7)111,0 intern L3867 L3868: 0 byte(7)112,0 intern L3868 L3869: 0 byte(7)113,0 intern L3869 L3870: 0 byte(7)114,0 intern L3870 L3871: 0 byte(7)115,0 intern L3871 L3872: 0 byte(7)116,0 intern L3872 L3873: 0 byte(7)117,0 intern L3873 L3874: 0 byte(7)118,0 intern L3874 L3875: 0 byte(7)119,0 intern L3875 L3876: 0 byte(7)120,0 intern L3876 L3877: 0 byte(7)121,0 intern L3877 L3878: 0 byte(7)122,0 intern L3878 L3879: 0 byte(7)123,0 intern L3879 L3880: 0 byte(7)124,0 intern L3880 L3881: 0 byte(7)125,0 intern L3881 L3882: 0 byte(7)126,0 intern L3882 L3883: 0 byte(7)127,0 intern L3883 L3884: 2 byte(7)78,73,76,0 intern L3884 L3885: 5 byte(7)73,68,50,73,78,84,0 intern L3885 L3886: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L3886 L3887: 5 byte(7)73,78,84,50,73,68,0 intern L3887 L3888: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L3888 L3889: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L3889 L3890: 6 byte(7)73,78,84,50,83,89,83,0 intern L3890 L3891: 8 byte(7)76,73,83,80,50,67,72,65,82,0 intern L3891 L3892: 16 byte(7)78,79,78,67,72,65,82,65,67,84,69,82,69,82,82,79,82,0 intern L3892 L3893: 7 byte(7)73,78,84,50,67,79,68,69,0 intern L3893 L3894: 6 byte(7)83,89,83,50,73,78,84,0 intern L3894 L3895: 5 byte(7)71,84,70,73,88,78,0 intern L3895 L3896: 8 byte(7)73,68,50,83,84,82,73,78,71,0 intern L3896 L3897: 12 byte(7)83,84,82,73,78,71,50,86,69,67,84,79,82,0 intern L3897 L3898: 5 byte(7)71,84,86,69,67,84,0 intern L3898 L3899: 13 byte(7)78,79,78,83,84,82,73,78,71,69,82,82,79,82,0 intern L3899 L3900: 12 byte(7)86,69,67,84,79,82,50,83,84,82,73,78,71,0 intern L3900 L3901: 4 byte(7)71,84,83,84,82,0 intern L3901 L3902: 13 byte(7)78,79,78,86,69,67,84,79,82,69,82,82,79,82,0 intern L3902 L3903: 10 byte(7)76,73,83,84,50,83,84,82,73,78,71,0 intern L3903 L3904: 5 byte(7)76,69,78,71,84,72,0 intern L3904 L3905: 11 byte(7)78,79,78,80,65,73,82,69,82,82,79,82,0 intern L3905 L3906: 10 byte(7)83,84,82,73,78,71,50,76,73,83,84,0 intern L3906 L3907: 3 byte(7)67,79,78,83,0 intern L3907 L3908: 10 byte(7)76,73,83,84,50,86,69,67,84,79,82,0 intern L3908 L3909: 10 byte(7)86,69,67,84,79,82,50,76,73,83,84,0 intern L3909 L3910: 3 byte(7)71,69,84,86,0 intern L3910 L3911: 5 byte(7)66,76,68,77,83,71,0 intern L3911 L3912: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L3912 L3913: 9 byte(7)73,78,68,69,88,69,82,82,79,82,0 intern L3913 L3914: 3 byte(7)80,85,84,86,0 intern L3914 L3915: 3 byte(7)85,80,66,86,0 intern L3915 L3916: 7 byte(7)69,86,69,67,84,79,82,80,0 intern L3916 L3917: 4 byte(7)69,71,69,84,86,0 intern L3917 L3918: 4 byte(7)69,80,85,84,86,0 intern L3918 L3919: 4 byte(7)69,85,80,66,86,0 intern L3919 L3920: 3 byte(7)73,78,68,88,0 intern L3920 L3921: 9 byte(7)82,65,78,71,69,69,82,82,79,82,0 intern L3921 L3922: 15 byte(7)78,79,78,83,69,81,85,69,78,67,69,69,82,82,79,82,0 intern L3922 L3923: 6 byte(7)83,69,84,73,78,68,88,0 intern L3923 L3924: 2 byte(7)83,85,66,0 intern L3924 L3925: 5 byte(7)83,85,66,83,69,81,0 intern L3925 L3926: 5 byte(7)71,84,87,82,68,83,0 intern L3926 L3927: 10 byte(7)71,84,72,65,76,70,87,79,82,68,83,0 intern L3927 L3928: 4 byte(7)78,67,79,78,83,0 intern L3928 L3929: 4 byte(7)84,67,79,78,67,0 intern L3929 L3930: 5 byte(7)83,69,84,83,85,66,0 intern L3930 L3931: 8 byte(7)83,69,84,83,85,66,83,69,81,0 intern L3931 L3932: 5 byte(7)67,79,78,67,65,84,0 intern L3932 L3933: 5 byte(7)65,80,80,69,78,68,0 intern L3933 L3934: 3 byte(7)83,73,90,69,0 intern L3934 L3935: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L3935 L3936: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L3936 L3937: 9 byte(7)77,65,75,69,45,66,89,84,69,83,0 intern L3937 L3938: 13 byte(7)77,65,75,69,45,72,65,76,70,87,79,82,68,83,0 intern L3938 L3939: 9 byte(7)77,65,75,69,45,87,79,82,68,83,0 intern L3939 L3940: 10 byte(7)77,65,75,69,45,86,69,67,84,79,82,0 intern L3940 L3941: 5 byte(7)83,84,82,73,78,71,0 intern L3941 L3942: 5 byte(7)86,69,67,84,79,82,0 intern L3942 L3943: 4 byte(7)67,79,68,69,80,0 intern L3943 L3944: 1 byte(7)69,81,0 intern L3944 L3945: 5 byte(7)70,76,79,65,84,80,0 intern L3945 L3946: 3 byte(7)66,73,71,80,0 intern L3946 L3947: 2 byte(7)73,68,80,0 intern L3947 L3948: 4 byte(7)80,65,73,82,80,0 intern L3948 L3949: 6 byte(7)83,84,82,73,78,71,80,0 intern L3949 L3950: 6 byte(7)86,69,67,84,79,82,80,0 intern L3950 L3951: 2 byte(7)67,65,82,0 intern L3951 L3952: 2 byte(7)67,68,82,0 intern L3952 L3953: 5 byte(7)82,80,76,65,67,65,0 intern L3953 L3954: 5 byte(7)82,80,76,65,67,68,0 intern L3954 L3955: 3 byte(7)70,73,88,80,0 intern L3955 L3956: 4 byte(7)68,73,71,73,84,0 intern L3956 L3957: 4 byte(7)76,73,84,69,82,0 intern L3957 L3958: 2 byte(7)69,81,78,0 intern L3958 L3959: 8 byte(7)76,73,83,80,69,81,85,65,76,0 intern L3959 L3960: 10 byte(7)83,84,82,73,78,71,69,81,85,65,76,0 intern L3960 L3961: 4 byte(7)69,81,83,84,82,0 intern L3961 L3962: 4 byte(7)69,81,85,65,76,0 intern L3962 L3963: 5 byte(7)67,65,65,65,65,82,0 intern L3963 L3964: 4 byte(7)67,65,65,65,82,0 intern L3964 L3965: 5 byte(7)67,65,65,65,68,82,0 intern L3965 L3966: 5 byte(7)67,65,65,68,65,82,0 intern L3966 L3967: 4 byte(7)67,65,65,68,82,0 intern L3967 L3968: 5 byte(7)67,65,65,68,68,82,0 intern L3968 L3969: 5 byte(7)67,65,68,65,65,82,0 intern L3969 L3970: 4 byte(7)67,65,68,65,82,0 intern L3970 L3971: 5 byte(7)67,65,68,65,68,82,0 intern L3971 L3972: 5 byte(7)67,65,68,68,65,82,0 intern L3972 L3973: 4 byte(7)67,65,68,68,82,0 intern L3973 L3974: 5 byte(7)67,65,68,68,68,82,0 intern L3974 L3975: 5 byte(7)67,68,65,65,65,82,0 intern L3975 L3976: 4 byte(7)67,68,65,65,82,0 intern L3976 L3977: 5 byte(7)67,68,65,65,68,82,0 intern L3977 L3978: 5 byte(7)67,68,65,68,65,82,0 intern L3978 L3979: 4 byte(7)67,68,65,68,82,0 intern L3979 L3980: 5 byte(7)67,68,65,68,68,82,0 intern L3980 L3981: 5 byte(7)67,68,68,65,65,82,0 intern L3981 L3982: 4 byte(7)67,68,68,65,82,0 intern L3982 L3983: 5 byte(7)67,68,68,65,68,82,0 intern L3983 L3984: 5 byte(7)67,68,68,68,65,82,0 intern L3984 L3985: 4 byte(7)67,68,68,68,82,0 intern L3985 L3986: 5 byte(7)67,68,68,68,68,82,0 intern L3986 L3987: 3 byte(7)67,65,65,82,0 intern L3987 L3988: 3 byte(7)67,65,68,82,0 intern L3988 L3989: 3 byte(7)67,68,65,82,0 intern L3989 L3990: 3 byte(7)67,68,68,82,0 intern L3990 L3991: 6 byte(7)83,65,70,69,67,65,82,0 intern L3991 L3992: 6 byte(7)83,65,70,69,67,68,82,0 intern L3992 L3993: 3 byte(7)65,84,79,77,0 intern L3993 L3994: 8 byte(7)67,79,78,83,84,65,78,84,80,0 intern L3994 L3995: 3 byte(7)78,85,76,76,0 intern L3995 L3996: 6 byte(7)78,85,77,66,69,82,80,0 intern L3996 L3997: 3 byte(7)69,88,80,84,0 intern L3997 L3998: 6 byte(7)77,75,81,85,79,84,69,0 intern L3998 L3999: 4 byte(7)76,73,83,84,51,0 intern L3999 L4000: 15 byte(7)67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L4000 L4001: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L4001 L4002: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L4002 L4003: 5 byte(7)77,73,78,85,83,80,0 intern L4003 L4004: 5 byte(7)84,73,77,69,83,50,0 intern L4004 L4005: 3 byte(7)65,68,68,49,0 intern L4005 L4006: 7 byte(7)81,85,79,84,73,69,78,84,0 intern L4006 L4007: 4 byte(7)80,76,85,83,50,0 intern L4007 L4008: 3 byte(7)76,73,83,84,0 intern L4008 L4009: 4 byte(7)69,86,76,73,83,0 intern L4009 L4010: 4 byte(7)81,85,79,84,69,0 intern L4010 L4011: 3 byte(7)69,88,80,82,0 intern L4011 L4012: 1 byte(7)68,69,0 intern L4012 L4013: 4 byte(7)76,73,83,84,50,0 intern L4013 L4014: 4 byte(7)76,73,83,84,52,0 intern L4014 L4015: 3 byte(7)80,85,84,68,0 intern L4015 L4016: 7 byte(7)70,85,78,67,84,73,79,78,0 intern L4016 L4017: 5 byte(7)76,65,77,66,68,65,0 intern L4017 L4018: 4 byte(7)70,69,88,80,82,0 intern L4018 L4019: 1 byte(7)68,70,0 intern L4019 L4020: 4 byte(7)77,65,67,82,79,0 intern L4020 L4021: 1 byte(7)68,77,0 intern L4021 L4022: 4 byte(7)78,69,88,80,82,0 intern L4022 L4023: 1 byte(7)68,78,0 intern L4023 L4024: 3 byte(7)83,69,84,81,0 intern L4024 L4025: 3 byte(7)69,86,65,76,0 intern L4025 L4026: 2 byte(7)83,69,84,0 intern L4026 L4027: 4 byte(7)80,82,79,71,50,0 intern L4027 L4028: 4 byte(7)80,82,79,71,78,0 intern L4028 L4029: 6 byte(7)69,86,80,82,79,71,78,0 intern L4029 L4030: 2 byte(7)65,78,68,0 intern L4030 L4031: 4 byte(7)69,86,65,78,68,0 intern L4031 L4032: 1 byte(7)79,82,0 intern L4032 L4033: 3 byte(7)69,86,79,82,0 intern L4033 L4034: 3 byte(7)67,79,78,68,0 intern L4034 L4035: 5 byte(7)69,86,67,79,78,68,0 intern L4035 L4036: 2 byte(7)78,79,84,0 intern L4036 L4037: 2 byte(7)65,66,83,0 intern L4037 L4038: 4 byte(7)77,73,78,85,83,0 intern L4038 L4039: 5 byte(7)68,73,86,73,68,69,0 intern L4039 L4040: 4 byte(7)90,69,82,79,80,0 intern L4040 L4041: 8 byte(7)82,69,77,65,73,78,68,69,82,0 intern L4041 L4042: 4 byte(7)88,67,79,78,83,0 intern L4042 L4043: 2 byte(7)77,65,88,0 intern L4043 L4044: 11 byte(7)82,79,66,85,83,84,69,88,80,65,78,68,0 intern L4044 L4045: 3 byte(7)77,65,88,50,0 intern L4045 L4046: 4 byte(7)76,69,83,83,80,0 intern L4046 L4047: 2 byte(7)77,73,78,0 intern L4047 L4048: 3 byte(7)77,73,78,50,0 intern L4048 L4049: 3 byte(7)80,76,85,83,0 intern L4049 L4050: 4 byte(7)84,73,77,69,83,0 intern L4050 L4051: 2 byte(7)77,65,80,0 intern L4051 L4052: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L4052 L4053: 3 byte(7)77,65,80,67,0 intern L4053 L4054: 5 byte(7)77,65,80,67,65,78,0 intern L4054 L4055: 4 byte(7)78,67,79,78,67,0 intern L4055 L4056: 5 byte(7)77,65,80,67,79,78,0 intern L4056 L4057: 5 byte(7)77,65,80,67,65,82,0 intern L4057 L4058: 6 byte(7)77,65,80,76,73,83,84,0 intern L4058 L4059: 4 byte(7)65,83,83,79,67,0 intern L4059 L4060: 5 byte(7)83,65,83,83,79,67,0 intern L4060 L4061: 3 byte(7)80,65,73,82,0 intern L4061 L4062: 5 byte(7)83,85,66,76,73,83,0 intern L4062 L4063: 6 byte(7)68,69,70,76,73,83,84,0 intern L4063 L4064: 2 byte(7)80,85,84,0 intern L4064 L4065: 5 byte(7)68,69,76,69,84,69,0 intern L4065 L4066: 5 byte(7)77,69,77,66,69,82,0 intern L4066 L4067: 3 byte(7)77,69,77,81,0 intern L4067 L4068: 6 byte(7)82,69,86,69,82,83,69,0 intern L4068 L4069: 4 byte(7)83,85,66,83,84,0 intern L4069 L4070: 5 byte(7)69,88,80,65,78,68,0 intern L4070 L4071: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,0 intern L4071 L4072: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4072 L4073: 12 byte(7)67,72,65,78,78,69,76,84,69,82,80,82,73,0 intern L4073 L4074: 4 byte(7)80,82,73,78,84,0 intern L4074 L4075: 3 byte(7)79,85,84,42,0 intern L4075 L4076: 2 byte(7)78,69,81,0 intern L4076 L4077: 1 byte(7)78,69,0 intern L4077 L4078: 2 byte(7)71,69,81,0 intern L4078 L4079: 2 byte(7)76,69,81,0 intern L4079 L4080: 4 byte(7)69,81,67,65,82,0 intern L4080 L4081: 4 byte(7)69,88,80,82,80,0 intern L4081 L4082: 3 byte(7)71,69,84,68,0 intern L4082 L4083: 5 byte(7)77,65,67,82,79,80,0 intern L4083 L4084: 5 byte(7)70,69,88,80,82,80,0 intern L4084 L4085: 5 byte(7)78,69,88,80,82,80,0 intern L4085 L4086: 4 byte(7)67,79,80,89,68,0 intern L4086 L4087: 4 byte(7)82,69,67,73,80,0 intern L4087 L4088: 4 byte(7)70,73,82,83,84,0 intern L4088 L4089: 5 byte(7)83,69,67,79,78,68,0 intern L4089 L4090: 4 byte(7)84,72,73,82,68,0 intern L4090 L4091: 5 byte(7)70,79,85,82,84,72,0 intern L4091 L4092: 3 byte(7)82,69,83,84,0 intern L4092 L4093: 7 byte(7)82,69,86,69,82,83,73,80,0 intern L4093 L4094: 6 byte(7)83,85,66,83,84,73,80,0 intern L4094 L4095: 6 byte(7)68,69,76,69,84,73,80,0 intern L4095 L4096: 3 byte(7)68,69,76,81,0 intern L4096 L4097: 2 byte(7)68,69,76,0 intern L4097 L4098: 5 byte(7)68,69,76,81,73,80,0 intern L4098 L4099: 4 byte(7)65,84,83,79,67,0 intern L4099 L4100: 2 byte(7)65,83,83,0 intern L4100 L4101: 2 byte(7)77,69,77,0 intern L4101 L4102: 5 byte(7)82,65,83,83,79,67,0 intern L4102 L4103: 5 byte(7)68,69,76,65,83,67,0 intern L4103 L4104: 7 byte(7)68,69,76,65,83,67,73,80,0 intern L4104 L4105: 5 byte(7)68,69,76,65,84,81,0 intern L4105 L4106: 7 byte(7)68,69,76,65,84,81,73,80,0 intern L4106 L4107: 4 byte(7)83,85,66,76,65,0 intern L4107 L4108: 5 byte(7)82,80,76,65,67,87,0 intern L4108 L4109: 6 byte(7)76,65,83,84,67,65,82,0 intern L4109 L4110: 7 byte(7)76,65,83,84,80,65,73,82,0 intern L4110 L4111: 3 byte(7)67,79,80,89,0 intern L4111 L4112: 2 byte(7)78,84,72,0 intern L4112 L4113: 3 byte(7)83,85,66,49,0 intern L4113 L4114: 3 byte(7)80,78,84,72,0 intern L4114 L4115: 4 byte(7)65,67,79,78,67,0 intern L4115 L4116: 4 byte(7)76,67,79,78,67,0 intern L4116 L4117: 3 byte(7)77,65,80,50,0 intern L4117 L4118: 4 byte(7)77,65,80,67,50,0 intern L4118 L4119: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,84,0 intern L4119 L4120: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4120 L4121: 5 byte(7)80,82,73,78,50,84,0 intern L4121 L4122: 12 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,0 intern L4122 L4123: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L4123 L4124: 5 byte(7)83,80,65,67,69,83,0 intern L4124 L4125: 9 byte(7)67,72,65,78,78,69,76,84,65,66,0 intern L4125 L4126: 10 byte(7)67,72,65,78,78,69,76,80,79,83,78,0 intern L4126 L4127: 2 byte(7)84,65,66,0 intern L4127 L4128: 4 byte(7)70,73,76,69,80,0 intern L4128 L4129: 3 byte(7)80,85,84,67,0 intern L4129 L4130: 6 byte(7)83,80,65,67,69,83,50,0 intern L4130 L4131: 13 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,50,0 intern L4131 L4132: 7 byte(7)76,73,83,84,50,83,69,84,0 intern L4132 L4133: 8 byte(7)76,73,83,84,50,83,69,84,81,0 intern L4133 L4134: 5 byte(7)65,68,74,79,73,78,0 intern L4134 L4135: 6 byte(7)65,68,74,79,73,78,81,0 intern L4135 L4136: 4 byte(7)85,78,73,79,78,0 intern L4136 L4137: 5 byte(7)85,78,73,79,78,81,0 intern L4137 L4138: 1 byte(7)88,78,0 intern L4138 L4139: 2 byte(7)88,78,81,0 intern L4139 L4140: 11 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,0 intern L4140 L4141: 12 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,81,0 intern L4141 L4142: 15 byte(7)75,78,79,87,78,45,70,82,69,69,45,83,80,65,67,69,0 intern L4142 L4143: 5 byte(7)71,84,72,69,65,80,0 intern L4143 L4144: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L4144 L4145: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L4145 L4146: 6 byte(7)71,67,45,84,82,65,80,0 intern L4146 L4147: 12 byte(7)71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4147 L4148: 16 byte(7)83,69,84,45,71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4148 L4149: 6 byte(7)68,69,76,72,69,65,80,0 intern L4149 L4150: 9 byte(7)71,84,67,79,78,83,84,83,84,82,0 intern L4150 L4151: 4 byte(7)71,84,66,80,83,0 intern L4151 L4152: 6 byte(7)71,84,69,86,69,67,84,0 intern L4152 L4153: 5 byte(7)71,84,70,76,84,78,0 intern L4153 L4154: 3 byte(7)71,84,73,68,0 intern L4154 L4155: 6 byte(7)82,69,67,76,65,73,77,0 intern L4155 L4156: 5 byte(7)68,69,76,66,80,83,0 intern L4156 L4157: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L4157 L4158: 8 byte(7)68,69,76,87,65,82,82,65,89,0 intern L4158 L4159: 15 byte(7)67,79,80,89,83,84,82,73,78,71,84,79,70,82,79,77,0 intern L4159 L4160: 9 byte(7)67,79,80,89,83,84,82,73,78,71,0 intern L4160 L4161: 9 byte(7)67,79,80,89,87,65,82,82,65,89,0 intern L4161 L4162: 15 byte(7)67,79,80,89,86,69,67,84,79,82,84,79,70,82,79,77,0 intern L4162 L4163: 9 byte(7)67,79,80,89,86,69,67,84,79,82,0 intern L4163 L4164: 13 byte(7)67,79,80,89,87,82,68,83,84,79,70,82,79,77,0 intern L4164 L4165: 7 byte(7)67,79,80,89,87,82,68,83,0 intern L4165 L4166: 8 byte(7)84,79,84,65,76,67,79,80,89,0 intern L4166 L4167: 5 byte(7)77,75,86,69,67,84,0 intern L4167 L4168: 8 byte(7)77,75,69,86,69,67,84,79,82,0 intern L4168 L4169: 6 byte(7)77,75,69,86,69,67,84,0 intern L4169 L4170: 4 byte(7)76,73,83,84,53,0 intern L4170 L4171: 2 byte(7)42,71,67,0 intern L4171 L4172: 6 byte(7)71,67,84,73,77,69,42,0 intern L4172 L4173: 5 byte(7)71,67,75,78,84,42,0 intern L4173 L4174: 14 byte(7)72,69,65,80,45,87,65,82,78,45,76,69,86,69,76,0 intern L4174 L4175: 10 byte(7)69,82,82,79,82,80,82,73,78,84,70,0 intern L4175 L4176: 3 byte(7)84,73,77,67,0 intern L4176 L4177: 3 byte(7)81,85,73,84,0 intern L4177 L4178: 8 byte(7)82,69,84,85,82,78,78,73,76,0 intern L4178 L4179: 13 byte(7)82,69,84,85,82,78,70,73,82,83,84,65,82,71,0 intern L4179 L4180: 3 byte(7)76,65,78,68,0 intern L4180 L4181: 2 byte(7)76,79,82,0 intern L4181 L4182: 3 byte(7)76,88,79,82,0 intern L4182 L4183: 5 byte(7)76,83,72,73,70,84,0 intern L4183 L4184: 2 byte(7)76,83,72,0 intern L4184 L4185: 3 byte(7)76,78,79,84,0 intern L4185 L4186: 2 byte(7)70,73,88,0 intern L4186 L4187: 4 byte(7)70,76,79,65,84,0 intern L4187 L4188: 3 byte(7)79,78,69,80,0 intern L4188 L4189: 4 byte(7)68,69,66,85,71,0 intern L4189 L4190: 1 byte(7)84,82,0 intern L4190 L4191: 5 byte(7)69,86,76,79,65,68,0 intern L4191 L4192: 3 byte(7)84,82,83,84,0 intern L4192 L4193: 7 byte(7)81,69,68,73,84,70,78,83,0 intern L4193 L4194: 6 byte(7)42,69,88,80,69,82,84,0 intern L4194 L4195: 7 byte(7)42,86,69,82,66,79,83,69,0 intern L4195 L4196: 4 byte(7)69,68,73,84,70,0 intern L4196 L4197: 3 byte(7)69,68,73,84,0 intern L4197 L4198: 3 byte(7)89,69,83,80,0 intern L4198 L4199: 12 byte(7)80,82,79,77,80,84,83,84,82,73,78,71,42,0 intern L4199 L4200: 7 byte(7)70,65,83,84,66,73,78,68,0 intern L4200 L4201: 5 byte(7)84,69,82,80,82,73,0 intern L4201 L4202: 12 byte(7)69,68,73,84,79,82,82,69,65,68,69,82,42,0 intern L4202 L4203: 13 byte(7)69,68,73,84,79,82,80,82,73,78,84,69,82,42,0 intern L4203 L4204: 9 byte(7)70,65,83,84,85,78,66,73,78,68,0 intern L4204 L4205: 3 byte(7)82,69,65,68,0 intern L4205 L4206: 1 byte(7)67,76,0 intern L4206 L4207: 3 byte(7)72,69,76,80,0 intern L4207 L4208: 4 byte(7)66,82,69,65,75,0 intern L4208 L4209: 4 byte(7)69,72,69,76,80,0 intern L4209 L4210: 1 byte(7)80,76,0 intern L4210 L4211: 1 byte(7)85,80,0 intern L4211 L4212: 1 byte(7)79,75,0 intern L4212 L4213: 14 byte(7)68,73,83,80,76,65,89,72,69,76,80,70,73,76,69,0 intern L4213 L4214: 5 byte(7)69,68,73,84,79,82,0 intern L4214 L4215: 18 byte(7)73,71,78,79,82,69,68,73,78,66,65,67,75,84,82,65,67,69,42,0 intern L4215 L4216: 20 byte(7)73,78,84,69,82,80,82,69,84,69,82,70,85,78,67,84,73,79,78,83,42,0 intern L4216 L4217: 14 byte(7)73,78,84,69,82,80,66,65,67,75,84,82,65,67,69,0 intern L4217 L4218: 5 byte(7)80,82,73,78,84,70,0 intern L4218 L4219: 8 byte(7)66,65,67,75,84,82,65,67,69,0 intern L4219 L4220: 13 byte(7)82,69,84,85,82,78,65,68,68,82,69,83,83,80,0 intern L4220 L4221: 6 byte(7)65,68,68,82,50,73,68,0 intern L4221 L4222: 15 byte(7)86,69,82,66,79,83,69,66,65,67,75,84,82,65,67,69,0 intern L4222 L4223: 7 byte(7)79,80,84,73,79,78,83,42,0 intern L4223 L4224: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L4224 L4225: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,75,78,79,87,78,73,84,69,77,0 intern L4225 L4226: 21 byte(7)67,79,68,69,45,65,68,68,82,69,83,83,45,84,79,45,83,89,77,66,79,76,0 intern L4226 L4227: 4 byte(7)80,82,73,78,49,0 intern L4227 L4228: 4 byte(7)69,82,82,79,82,0 intern L4228 L4229: 1 byte(7)78,79,0 intern L4229 L4230: 2 byte(7)89,69,83,0 intern L4230 L4231: 2 byte(7)82,68,83,0 intern L4231 L4232: 6 byte(7)69,82,82,79,85,84,42,0 intern L4232 L4233: 2 byte(7)87,82,83,0 intern L4233 L4234: 7 byte(7)69,82,82,79,82,83,69,84,0 intern L4234 L4235: 6 byte(7)67,85,82,83,89,77,42,0 intern L4235 L4236: 8 byte(7)42,83,69,77,73,67,79,76,42,0 intern L4236 L4237: 9 byte(7)69,82,82,79,82,70,79,82,77,42,0 intern L4237 L4238: 16 byte(7)42,67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L4238 L4239: 4 byte(7)69,77,83,71,42,0 intern L4239 L4240: 5 byte(7)42,66,82,69,65,75,0 intern L4240 L4241: 5 byte(7)42,69,77,83,71,80,0 intern L4241 L4242: 13 byte(7)77,65,88,66,82,69,65,75,76,69,86,69,76,42,0 intern L4242 L4243: 10 byte(7)66,82,69,65,75,76,69,86,69,76,42,0 intern L4243 L4244: 7 byte(7)70,76,65,84,83,73,90,69,0 intern L4244 L4245: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L4245 L4246: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L4246 L4247: 7 byte(7)78,79,78,87,79,82,68,83,0 intern L4247 L4248: 16 byte(7)78,79,78,73,79,67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4248 L4249: 9 byte(7)42,66,65,67,75,84,82,65,67,69,0 intern L4249 L4250: 15 byte(7)42,73,78,78,69,82,42,66,65,67,75,84,82,65,67,69,0 intern L4250 L4251: 4 byte(7)84,72,82,79,87,0 intern L4251 L4252: 6 byte(7)36,69,82,82,79,82,36,0 intern L4252 L4253: 5 byte(7)69,82,82,83,69,84,0 intern L4253 L4254: 4 byte(7)67,65,84,67,72,0 intern L4254 L4255: 9 byte(7)67,65,84,67,72,83,69,84,85,80,0 intern L4255 L4256: 11 byte(7)84,72,82,79,87,83,73,71,78,65,76,42,0 intern L4256 L4257: 7 byte(7)37,85,78,67,65,84,67,72,0 intern L4257 L4258: 13 byte(7)67,72,65,78,78,69,76,78,79,84,79,80,69,78,0 intern L4258 L4259: 11 byte(7)67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4259 L4260: 15 byte(7)87,82,73,84,69,79,78,76,89,67,72,65,78,78,69,76,0 intern L4260 L4261: 14 byte(7)82,69,65,68,79,78,76,89,67,72,65,78,78,69,76,0 intern L4261 L4262: 26 byte(7)73,76,76,69,71,65,76,83,84,65,78,68,65,82,68,67,72,65,78,78,69,76,67,76,79,83,69,0 intern L4262 L4263: 6 byte(7)73,79,69,82,82,79,82,0 intern L4263 L4264: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L4264 L4265: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L4265 L4266: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L4266 L4267: 5 byte(7)76,66,73,78,68,49,0 intern L4267 L4268: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L4268 L4269: 13 byte(7)66,83,84,65,67,75,79,86,69,82,70,76,79,87,0 intern L4269 L4270: 17 byte(7)82,69,83,84,79,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4270 L4271: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L4271 L4272: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L4272 L4273: 6 byte(7)85,78,66,73,78,68,78,0 intern L4273 L4274: 4 byte(7)65,80,80,76,89,0 intern L4274 L4275: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L4275 L4276: 5 byte(7)70,67,79,68,69,80,0 intern L4276 L4277: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L4277 L4278: 2 byte(7)71,69,84,0 intern L4278 L4279: 8 byte(7)86,65,76,85,69,67,69,76,76,0 intern L4279 L4280: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L4280 L4281: 8 byte(7)38,38,86,65,76,85,69,38,38,0 intern L4281 L4282: 8 byte(7)84,72,82,79,87,84,65,71,42,0 intern L4282 L4283: 8 byte(7)67,65,84,67,72,45,65,76,76,0 intern L4283 L4284: 9 byte(7)85,78,87,73,78,68,45,65,76,76,0 intern L4284 L4285: 9 byte(7)38,38,84,72,82,79,87,78,38,38,0 intern L4285 L4286: 15 byte(7)36,85,78,87,73,78,68,45,80,82,79,84,69,67,84,36,0 intern L4286 L4287: 6 byte(7)38,38,84,65,71,38,38,0 intern L4287 L4288: 5 byte(7)37,84,72,82,79,87,0 intern L4288 L4289: 13 byte(7)85,78,87,73,78,68,45,80,82,79,84,69,67,84,0 intern L4289 L4290: 5 byte(7)42,67,65,84,67,72,0 intern L4290 L4291: 5 byte(7)42,84,72,82,79,87,0 intern L4291 L4292: 4 byte(7)82,69,83,69,84,0 intern L4292 L4293: 17 byte(7)67,65,80,84,85,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4293 L4294: 17 byte(7)37,67,76,69,65,82,45,67,65,84,67,72,45,83,84,65,67,75,0 intern L4294 L4295: 8 byte(7)80,82,79,71,66,79,68,89,42,0 intern L4295 L4296: 13 byte(7)80,82,79,71,74,85,77,80,84,65,66,76,69,42,0 intern L4296 L4297: 3 byte(7)80,82,79,71,0 intern L4297 L4298: 5 byte(7)80,66,73,78,68,49,0 intern L4298 L4299: 5 byte(7)36,80,82,79,71,36,0 intern L4299 L4300: 1 byte(7)71,79,0 intern L4300 L4301: 5 byte(7)82,69,84,85,82,78,0 intern L4301 L4302: 11 byte(7)83,89,83,84,69,77,95,76,73,83,84,42,0 intern L4302 L4303: 3 byte(7)68,65,84,69,0 intern L4303 L4304: 7 byte(7)68,85,77,80,76,73,83,80,0 intern L4304 L4305: 13 byte(7)66,73,78,65,82,89,79,80,69,78,82,69,65,68,0 intern L4305 L4306: 8 byte(7)68,69,67,50,48,79,80,69,78,0 intern L4306 L4307: 14 byte(7)66,73,78,65,82,89,79,80,69,78,87,82,73,84,69,0 intern L4307 L4308: 16 byte(7)86,65,76,85,69,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4308 L4309: 15 byte(7)42,87,82,73,84,73,78,71,70,65,83,76,70,73,76,69,0 intern L4309 L4310: 16 byte(7)78,69,87,66,73,84,84,65,66,76,69,69,78,84,82,89,42,0 intern L4310 L4311: 11 byte(7)70,73,78,68,73,68,78,85,77,66,69,82,0 intern L4311 L4312: 16 byte(7)77,65,75,69,82,69,76,79,67,72,65,76,70,87,79,82,68,0 intern L4312 L4313: 15 byte(7)69,88,84,82,65,82,69,71,76,79,67,65,84,73,79,78,0 intern L4313 L4314: 19 byte(7)70,85,78,67,84,73,79,78,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4314 L4315: 5 byte(7)70,65,83,76,73,78,0 intern L4315 L4316: 5 byte(7)73,78,84,69,82,78,0 intern L4316 L4317: 7 byte(7)80,85,84,69,78,84,82,89,0 intern L4317 L4318: 15 byte(7)76,79,65,68,68,73,82,69,67,84,79,82,73,69,83,42,0 intern L4318 L4319: 14 byte(7)76,79,65,68,69,88,84,69,78,83,73,79,78,83,42,0 intern L4319 L4320: 11 byte(7)42,86,69,82,66,79,83,69,76,79,65,68,0 intern L4320 L4321: 14 byte(7)42,80,82,73,78,84,76,79,65,68,78,65,77,69,83,0 intern L4321 L4322: 3 byte(7)76,79,65,68,0 intern L4322 L4323: 4 byte(7)76,79,65,68,49,0 intern L4323 L4324: 5 byte(7)82,69,76,79,65,68,0 intern L4324 L4325: 7 byte(7)69,86,82,69,76,79,65,68,0 intern L4325 L4326: 8 byte(7)42,85,83,69,82,77,79,68,69,0 intern L4326 L4327: 8 byte(7)42,82,69,68,69,70,77,83,71,0 intern L4327 L4328: 10 byte(7)42,73,78,83,73,68,69,76,79,65,68,0 intern L4328 L4329: 5 byte(7)42,76,79,87,69,82,0 intern L4329 L4330: 12 byte(7)80,69,78,68,73,78,71,76,79,65,68,83,42,0 intern L4330 L4331: 6 byte(7)73,77,80,79,82,84,83,0 intern L4331 L4332: 10 byte(7)80,82,69,84,84,89,80,82,73,78,84,0 intern L4332 L4333: 8 byte(7)68,69,70,83,84,82,85,67,84,0 intern L4333 L4334: 3 byte(7)83,84,69,80,0 intern L4334 L4335: 3 byte(7)77,73,78,73,0 intern L4335 L4336: 4 byte(7)69,77,79,68,69,0 intern L4336 L4337: 5 byte(7)73,78,86,79,75,69,0 intern L4337 L4338: 4 byte(7)82,67,82,69,70,0 intern L4338 L4339: 5 byte(7)67,82,69,70,79,78,0 intern L4339 L4340: 7 byte(7)67,79,77,80,73,76,69,82,0 intern L4340 L4341: 4 byte(7)67,79,77,80,68,0 intern L4341 L4342: 6 byte(7)70,65,83,76,79,85,84,0 intern L4342 L4343: 2 byte(7)66,85,71,0 intern L4343 L4344: 3 byte(7)69,88,69,67,0 intern L4344 L4345: 1 byte(7)77,77,0 intern L4345 L4346: 19 byte(7)84,69,82,77,73,78,65,76,73,78,80,85,84,72,65,78,68,76,69,82,0 intern L4346 L4347: 15 byte(7)67,79,77,80,82,69,83,83,82,69,65,68,67,72,65,82,0 intern L4347 L4348: 13 byte(7)68,69,67,50,48,87,82,73,84,69,67,72,65,82,0 intern L4348 L4349: 16 byte(7)84,79,83,84,82,73,78,71,87,82,73,84,69,67,72,65,82,0 intern L4349 L4350: 15 byte(7)69,88,80,76,79,68,69,87,82,73,84,69,67,72,65,82,0 intern L4350 L4351: 16 byte(7)70,76,65,84,83,73,90,69,87,82,73,84,69,67,72,65,82,0 intern L4351 L4352: 4 byte(7)36,69,79,76,36,0 intern L4352 L4353: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,65,82,0 intern L4353 L4354: 7 byte(7)82,69,65,68,67,72,65,82,0 intern L4354 L4355: 2 byte(7)73,78,42,0 intern L4355 L4356: 16 byte(7)67,72,65,78,78,69,76,85,78,82,69,65,68,67,72,65,82,0 intern L4356 L4357: 9 byte(7)85,78,82,69,65,68,67,72,65,82,0 intern L4357 L4358: 3 byte(7)79,80,69,78,0 intern L4358 L4359: 21 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,73,78,80,85,84,0 intern L4359 L4360: 22 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,79,85,84,80,85,84,0 intern L4360 L4361: 20 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,83,80,69,67,73,65,76,0 intern L4361 L4362: 19 byte(7)83,80,69,67,73,65,76,82,69,65,68,70,85,78,67,84,73,79,78,42,0 intern L4362 L4363: 20 byte(7)83,80,69,67,73,65,76,87,82,73,84,69,70,85,78,67,84,73,79,78,42,0 intern L4363 L4364: 20 byte(7)83,80,69,67,73,65,76,67,76,79,83,69,70,85,78,67,84,73,79,78,42,0 intern L4364 L4365: 6 byte(7)83,80,69,67,73,65,76,0 intern L4365 L4366: 5 byte(7)79,85,84,80,85,84,0 intern L4366 L4367: 4 byte(7)73,78,80,85,84,0 intern L4367 L4368: 4 byte(7)67,76,79,83,69,0 intern L4368 L4369: 24 byte(7)83,89,83,84,69,77,77,65,82,75,65,83,67,76,79,83,69,68,67,72,65,78,78,69,76,0 intern L4369 L4370: 16 byte(7)83,80,69,67,73,65,76,82,68,83,65,67,84,73,79,78,42,0 intern L4370 L4371: 5 byte(7)83,84,68,73,78,42,0 intern L4371 L4372: 16 byte(7)83,80,69,67,73,65,76,87,82,83,65,67,84,73,79,78,42,0 intern L4372 L4373: 6 byte(7)83,84,68,79,85,84,42,0 intern L4373 L4374: 11 byte(7)67,72,65,78,78,69,76,69,74,69,67,84,0 intern L4374 L4375: 4 byte(7)69,74,69,67,84,0 intern L4375 L4376: 16 byte(7)67,72,65,78,78,69,76,76,73,78,69,76,69,78,71,84,72,0 intern L4376 L4377: 9 byte(7)76,73,78,69,76,69,78,71,84,72,0 intern L4377 L4378: 3 byte(7)80,79,83,78,0 intern L4378 L4379: 11 byte(7)67,72,65,78,78,69,76,76,80,79,83,78,0 intern L4379 L4380: 4 byte(7)76,80,79,83,78,0 intern L4380 L4381: 12 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,0 intern L4381 L4382: 5 byte(7)42,82,65,73,83,69,0 intern L4382 L4383: 5 byte(7)82,69,65,68,67,72,0 intern L4383 L4384: 4 byte(7)80,82,73,78,67,0 intern L4384 L4385: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,67,0 intern L4385 L4386: 25 byte(7)67,85,82,82,69,78,84,82,69,65,68,77,65,67,82,79,73,78,68,73,67,65,84,79,82,42,0 intern L4386 L4387: 24 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,87,73,84,72,72,79,79,75,83,0 intern L4387 L4388: 15 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,0 intern L4388 L4389: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L4389 L4390: 16 byte(7)67,85,82,82,69,78,84,83,67,65,78,84,65,66,76,69,42,0 intern L4390 L4391: 10 byte(7)67,72,65,78,78,69,76,82,69,65,68,0 intern L4391 L4392: 13 byte(7)76,73,83,80,83,67,65,78,84,65,66,76,69,42,0 intern L4392 L4393: 12 byte(7)76,73,83,80,82,69,65,68,77,65,67,82,79,0 intern L4393 L4394: 17 byte(7)77,65,75,69,73,78,80,85,84,65,86,65,73,76,65,66,76,69,0 intern L4394 L4395: 19 byte(7)42,73,78,83,73,68,69,83,84,82,85,67,84,85,82,69,82,69,65,68,0 intern L4395 L4396: 13 byte(7)67,72,65,78,78,69,76,82,69,65,68,69,79,70,0 intern L4396 L4397: 4 byte(7)36,69,79,70,36,0 intern L4397 L4398: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,81,85,79,84,69,68,69,88,80,82,69,83,83,73,79,78,0 intern L4398 L4399: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,83,84,79,82,68,79,84,84,69,68,80,65,73,82,0 intern L4399 L4400: 20 byte(7)67,72,65,78,78,69,76,82,69,65,68,82,73,71,72,84,80,65,82,69,78,0 intern L4400 L4401: 16 byte(7)67,72,65,78,78,69,76,82,69,65,68,86,69,67,84,79,82,0 intern L4401 L4402: 11 byte(7)42,67,79,77,80,82,69,83,83,73,78,71,0 intern L4402 L4403: 13 byte(7)42,69,79,76,73,78,83,84,82,73,78,71,79,75,0 intern L4403 L4404: 4 byte(7)78,69,87,73,68,0 intern L4404 L4405: 24 byte(7)77,65,75,69,83,84,82,73,78,71,73,78,84,79,76,73,83,80,73,78,84,69,71,69,82,0 intern L4405 L4406: 12 byte(7)68,73,71,73,84,84,79,78,85,77,66,69,82,0 intern L4406 L4407: 6 byte(7)80,65,67,75,65,71,69,0 intern L4407 L4408: 14 byte(7)67,85,82,82,69,78,84,80,65,67,75,65,71,69,42,0 intern L4408 L4409: 5 byte(7)71,76,79,66,65,76,0 intern L4409 L4410: 4 byte(7)82,65,84,79,77,0 intern L4410 L4411: 7 byte(7)82,69,65,68,76,73,78,69,0 intern L4411 L4412: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,78,69,0 intern L4412 L4413: 10 byte(7)79,85,84,80,85,84,66,65,83,69,42,0 intern L4413 L4414: 12 byte(7)73,68,69,83,67,65,80,69,67,72,65,82,42,0 intern L4414 L4415: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,84,82,73,78,71,0 intern L4415 L4416: 10 byte(7)87,82,73,84,69,83,84,82,73,78,71,0 intern L4416 L4417: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4417 L4418: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,73,84,83,84,82,65,85,88,0 intern L4418 L4419: 14 byte(7)87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4419 L4420: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,73,88,78,85,77,0 intern L4420 L4421: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,78,84,69,71,69,82,0 intern L4421 L4422: 19 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,70,76,79,65,84,0 intern L4422 L4423: 9 byte(7)87,82,73,84,69,70,76,79,65,84,0 intern L4423 L4424: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,76,79,65,84,0 intern L4424 L4425: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,83,84,82,73,78,71,0 intern L4425 L4426: 13 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,68,0 intern L4426 L4427: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,66,79,85,78,68,0 intern L4427 L4428: 13 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,73,68,0 intern L4428 L4429: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,85,78,66,79,85,78,68,0 intern L4429 L4430: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,79,68,69,80,79,73,78,84,69,82,0 intern L4430 L4431: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,76,65,78,75,79,82,69,79,76,0 intern L4431 L4432: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,80,65,73,82,0 intern L4432 L4433: 8 byte(7)80,82,73,78,76,69,86,69,76,0 intern L4433 L4434: 9 byte(7)80,82,73,78,76,69,78,71,84,72,0 intern L4434 L4435: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4435 L4436: 15 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,80,65,73,82,0 intern L4436 L4437: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4437 L4438: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,86,69,67,84,79,82,0 intern L4438 L4439: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,86,69,67,84,79,82,0 intern L4439 L4440: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,69,86,69,67,84,79,82,0 intern L4440 L4441: 25 byte(7)79,66,74,69,67,84,45,71,69,84,45,72,65,78,68,76,69,82,45,81,85,73,69,84,76,89,0 intern L4441 L4442: 10 byte(7)67,72,65,78,78,69,76,80,82,73,78,0 intern L4442 L4443: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,69,86,69,67,84,79,82,0 intern L4443 L4444: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,87,79,82,68,83,0 intern L4444 L4445: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,72,65,76,70,87,79,82,68,83,0 intern L4445 L4446: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,89,84,69,83,0 intern L4446 L4447: 4 byte(7)80,82,73,78,50,0 intern L4447 L4448: 15 byte(7)70,79,82,77,65,84,70,79,82,80,82,73,78,84,70,42,0 intern L4448 L4449: 5 byte(7)80,82,73,78,50,76,0 intern L4449 L4450: 6 byte(7)69,82,82,80,82,73,78,0 intern L4450 L4451: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,70,0 intern L4451 L4452: 17 byte(7)69,88,80,76,79,68,69,69,78,68,80,79,73,78,84,69,82,42,0 intern L4452 L4453: 6 byte(7)69,88,80,76,79,68,69,0 intern L4453 L4454: 7 byte(7)69,88,80,76,79,68,69,50,0 intern L4454 L4455: 8 byte(7)70,76,65,84,83,73,90,69,50,0 intern L4455 L4456: 12 byte(7)67,79,77,80,82,69,83,83,69,82,82,79,82,0 intern L4456 L4457: 12 byte(7)67,79,77,80,82,69,83,83,76,73,83,84,42,0 intern L4457 L4458: 19 byte(7)67,76,69,65,82,67,79,77,80,82,69,83,83,67,72,65,78,78,69,76,0 intern L4458 L4459: 7 byte(7)67,79,77,80,82,69,83,83,0 intern L4459 L4460: 6 byte(7)73,77,80,76,79,68,69,0 intern L4460 L4461: 9 byte(7)67,72,65,78,78,69,76,84,89,73,0 intern L4461 L4462: 9 byte(7)67,72,65,78,78,69,76,84,89,79,0 intern L4462 L4463: 2 byte(7)84,89,73,0 intern L4463 L4464: 2 byte(7)84,89,79,0 intern L4464 L4465: 13 byte(7)67,79,77,77,69,78,84,79,85,84,67,79,68,69,0 intern L4465 L4466: 10 byte(7)67,79,77,80,73,76,69,84,73,77,69,0 intern L4466 L4467: 8 byte(7)66,79,84,72,84,73,77,69,83,0 intern L4467 L4468: 7 byte(7)76,79,65,68,84,73,77,69,0 intern L4468 L4469: 10 byte(7)83,84,65,82,84,85,80,84,73,77,69,0 intern L4469 L4470: 8 byte(7)67,79,78,84,69,82,82,79,82,0 intern L4470 L4471: 8 byte(7)79,84,72,69,82,87,73,83,69,0 intern L4471 L4472: 6 byte(7)68,69,70,65,85,76,84,0 intern L4472 L4473: 3 byte(7)67,65,83,69,0 intern L4473 L4474: 4 byte(7)82,65,78,71,69,0 intern L4474 L4475: 3 byte(7)83,69,84,70,0 intern L4475 L4476: 9 byte(7)69,88,80,65,78,68,83,69,84,70,0 intern L4476 L4477: 10 byte(7)83,69,84,70,45,69,88,80,65,78,68,0 intern L4477 L4478: 8 byte(7)65,83,83,73,71,78,45,79,80,0 intern L4478 L4479: 5 byte(7)79,78,79,70,70,42,0 intern L4479 L4480: 8 byte(7)77,75,70,76,65,71,86,65,82,0 intern L4480 L4481: 5 byte(7)83,73,77,80,70,71,0 intern L4481 L4482: 1 byte(7)79,78,0 intern L4482 L4483: 2 byte(7)79,70,70,0 intern L4483 L4484: 3 byte(7)35,65,82,71,0 intern L4484 L4485: 1 byte(7)68,83,0 intern L4485 L4486: 7 byte(7)68,69,70,67,79,78,83,84,0 intern L4486 L4487: 9 byte(7)69,86,68,69,70,67,79,78,83,84,0 intern L4487 L4488: 4 byte(7)67,79,78,83,84,0 intern L4488 L4489: 11 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,0 intern L4489 L4490: 12 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,42,0 intern L4490 L4491: 6 byte(7)70,79,82,69,65,67,72,0 intern L4491 L4492: 6 byte(7)67,79,76,76,69,67,84,0 intern L4492 L4493: 3 byte(7)74,79,73,78,0 intern L4493 L4494: 3 byte(7)67,79,78,67,0 intern L4494 L4495: 1 byte(7)73,78,0 intern L4495 L4496: 1 byte(7)68,79,0 intern L4496 L4497: 3 byte(7)69,88,73,84,0 intern L4497 L4498: 5 byte(7)36,76,79,79,80,36,0 intern L4498 L4499: 3 byte(7)78,69,88,84,0 intern L4499 L4500: 4 byte(7)87,72,73,76,69,0 intern L4500 L4501: 5 byte(7)82,69,80,69,65,84,0 intern L4501 L4502: 2 byte(7)70,79,82,0 intern L4502 L4503: 5 byte(7)71,69,78,83,89,77,0 intern L4503 L4504: 4 byte(7)77,75,42,83,81,0 intern L4504 L4505: 3 byte(7)83,73,77,80,0 intern L4505 L4506: 2 byte(7)66,73,78,0 intern L4506 L4507: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L4507 L4508: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L4508 L4509: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L4509 L4510: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L4510 L4511: 3 byte(7)80,82,79,80,0 intern L4511 L4512: 6 byte(7)83,69,84,80,82,79,80,0 intern L4512 L4513: 4 byte(7)70,76,65,71,80,0 intern L4513 L4514: 3 byte(7)84,89,80,69,0 intern L4514 L4515: 3 byte(7)70,76,65,71,0 intern L4515 L4516: 4 byte(7)70,76,65,71,49,0 intern L4516 L4517: 6 byte(7)82,69,77,70,76,65,71,0 intern L4517 L4518: 7 byte(7)82,69,77,70,76,65,71,49,0 intern L4518 L4519: 6 byte(7)82,69,77,80,82,79,80,0 intern L4519 L4520: 7 byte(7)82,69,77,80,82,79,80,76,0 intern L4520 L4521: 7 byte(7)85,78,66,79,85,78,68,80,0 intern L4521 L4522: 6 byte(7)86,65,82,84,89,80,69,0 intern L4522 L4523: 4 byte(7)70,76,85,73,68,0 intern L4523 L4524: 5 byte(7)70,76,85,73,68,49,0 intern L4524 L4525: 5 byte(7)70,76,85,73,68,80,0 intern L4525 L4526: 6 byte(7)71,76,79,66,65,76,49,0 intern L4526 L4527: 6 byte(7)71,76,79,66,65,76,80,0 intern L4527 L4528: 6 byte(7)85,78,70,76,85,73,68,0 intern L4528 L4529: 7 byte(7)85,78,70,76,85,73,68,49,0 intern L4529 L4530: 3 byte(7)82,69,77,68,0 intern L4530 L4531: 4 byte(7)42,67,79,77,80,0 intern L4531 L4532: 3 byte(7)85,83,69,82,0 intern L4532 L4533: 3 byte(7)76,79,83,69,0 intern L4533 L4534: 23 byte(7)67,79,68,69,45,78,85,77,66,69,82,45,79,70,45,65,82,71,85,77,69,78,84,83,0 intern L4534 L4535: 14 byte(7)66,83,84,65,67,75,85,78,68,69,82,70,76,79,87,0 intern L4535 L4536: 12 byte(7)67,76,69,65,82,66,73,78,68,73,78,71,83,0 intern L4536 L4537: 10 byte(7)77,65,75,69,85,78,66,79,85,78,68,0 intern L4537 L4538: 11 byte(7)72,65,83,72,70,85,78,67,84,73,79,78,0 intern L4538 L4539: 4 byte(7)82,69,77,79,66,0 intern L4539 L4540: 6 byte(7)73,78,84,69,82,78,80,0 intern L4540 L4541: 11 byte(7)73,78,84,69,82,78,71,69,78,83,89,77,0 intern L4541 L4542: 5 byte(7)77,65,80,79,66,76,0 intern L4542 L4543: 11 byte(7)71,76,79,66,65,76,76,79,79,75,85,80,0 intern L4543 L4544: 12 byte(7)71,76,79,66,65,76,73,78,83,84,65,76,76,0 intern L4544 L4545: 11 byte(7)71,76,79,66,65,76,82,69,77,79,86,69,0 intern L4545 L4546: 9 byte(7)73,78,73,84,79,66,76,73,83,84,0 intern L4546 L4547: 12 byte(7)68,69,67,50,48,82,69,65,68,67,72,65,82,0 intern L4547 L4548: 4 byte(7)42,69,67,72,79,0 intern L4548 L4549: 6 byte(7)67,76,69,65,82,73,79,0 intern L4549 L4550: 16 byte(7)68,69,67,50,48,67,76,79,83,69,67,72,65,78,78,69,76,0 intern L4550 L4551: 4 byte(7)42,68,69,70,78,0 intern L4551 L4552: 10 byte(7)66,82,69,65,75,86,65,76,85,69,42,0 intern L4552 L4553: 9 byte(7)42,81,85,73,84,66,82,69,65,75,0 intern L4553 L4554: 7 byte(7)66,82,69,65,75,73,78,42,0 intern L4554 L4555: 8 byte(7)66,82,69,65,75,79,85,84,42,0 intern L4555 L4556: 11 byte(7)84,79,80,76,79,79,80,78,65,77,69,42,0 intern L4556 L4557: 11 byte(7)84,79,80,76,79,79,80,69,86,65,76,42,0 intern L4557 L4558: 9 byte(7)66,82,69,65,75,69,86,65,76,42,0 intern L4558 L4559: 9 byte(7)66,82,69,65,75,78,65,77,69,42,0 intern L4559 L4560: 12 byte(7)84,79,80,76,79,79,80,80,82,73,78,84,42,0 intern L4560 L4561: 11 byte(7)84,79,80,76,79,79,80,82,69,65,68,42,0 intern L4561 L4562: 6 byte(7)84,79,80,76,79,79,80,0 intern L4562 L4563: 6 byte(7)36,66,82,69,65,75,36,0 intern L4563 L4564: 8 byte(7)66,82,69,65,75,69,86,65,76,0 intern L4564 L4565: 12 byte(7)66,82,69,65,75,70,85,78,67,84,73,79,78,0 intern L4565 L4566: 8 byte(7)66,82,69,65,75,81,85,73,84,0 intern L4566 L4567: 12 byte(7)66,82,69,65,75,67,79,78,84,73,78,85,69,0 intern L4567 L4568: 9 byte(7)66,82,69,65,75,82,69,84,82,89,0 intern L4568 L4569: 8 byte(7)72,69,76,80,66,82,69,65,75,0 intern L4569 L4570: 10 byte(7)66,82,69,65,75,69,82,82,77,83,71,0 intern L4570 L4571: 8 byte(7)66,82,69,65,75,69,68,73,84,0 intern L4571 L4572: 12 byte(7)84,79,80,76,79,79,80,76,69,86,69,76,42,0 intern L4572 L4573: 12 byte(7)72,73,83,84,79,82,89,67,79,85,78,84,42,0 intern L4573 L4574: 10 byte(7)76,73,83,80,66,65,78,78,69,82,42,0 intern L4574 L4575: 6 byte(7)42,79,85,84,80,85,84,0 intern L4575 L4576: 5 byte(7)83,69,77,73,67,42,0 intern L4576 L4577: 11 byte(7)72,73,83,84,79,82,89,76,73,83,84,42,0 intern L4577 L4578: 4 byte(7)42,84,73,77,69,0 intern L4578 L4579: 3 byte(7)84,73,77,69,0 intern L4579 L4580: 5 byte(7)42,78,79,78,73,76,0 intern L4580 L4581: 12 byte(7)36,69,88,73,84,84,79,80,76,79,79,80,36,0 intern L4581 L4582: 7 byte(7)68,70,80,82,73,78,84,42,0 intern L4582 L4583: 5 byte(7)73,71,78,79,82,69,0 intern L4583 L4584: 2 byte(7)73,78,80,0 intern L4584 L4585: 3 byte(7)82,69,68,79,0 intern L4585 L4586: 2 byte(7)65,78,83,0 intern L4586 L4587: 3 byte(7)72,73,83,84,0 intern L4587 L4588: 4 byte(7)67,76,69,65,82,0 intern L4588 L4589: 11 byte(7)83,84,65,78,68,65,82,68,76,73,83,80,0 intern L4589 L4590: 17 byte(7)80,82,73,78,84,87,73,84,72,70,82,69,83,72,76,73,78,69,0 intern L4590 L4591: 9 byte(7)83,65,86,69,83,89,83,84,69,77,0 intern L4591 L4592: 9 byte(7)73,78,73,84,70,79,82,77,83,42,0 intern L4592 L4593: 12 byte(7)69,86,65,76,73,78,73,84,70,79,82,77,83,0 intern L4593 L4594: 4 byte(7)68,83,75,73,78,0 intern L4594 L4595: 8 byte(7)68,83,75,73,78,69,86,65,76,0 intern L4595 L4596: 4 byte(7)76,65,80,73,78,0 intern L4596 L4597: 4 byte(7)77,65,73,78,46,0 intern L4597 L4598: 7 byte(7)80,82,69,45,77,65,73,78,0 intern L4598 L4599: 3 byte(7)77,65,73,78,0 intern L4599 L4600: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L4600 L4601: 2 byte(7)69,79,70,0 intern L4601 L4602: 8 byte(7)67,72,65,82,67,79,78,83,84,0 intern L4602 L4603: 4 byte(7)68,69,67,50,48,0 intern L4603 L4604: 4 byte(7)80,68,80,49,48,0 intern L4604 L4605: 5 byte(7)84,79,80,83,50,48,0 intern L4605 L4606: 3 byte(7)75,76,49,48,0 intern L4606 L4607: 12 byte(7)76,73,83,80,68,73,80,72,84,72,79,78,71,0 intern L4607 end MAIN. |
Added psl-1983/20-kernel/main.mic version [279c8b6a77].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independent compilation a program for the 20 ;; MAIN module and data_segement, do last ; MIC MAIN modulename ; modulename=symboltablename @define DSK:, DSK:, P20:, PV:, PI: @delete 'A.mac @delete D'A.mac ;avoid obnoixous ^Q halts... @terminal length 0 @s:DEC20-CROSS.EXE off break; % avoid obnoxios breaks InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''T; ModName!*:='' 'A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @terminal length 24 @macro *'A.rel='A.mac *D'A.rel=D'A.mac |
Added psl-1983/20-kernel/main.rel version [654f6e7786].
cannot compute difference between binary files
Added psl-1983/20-kernel/make-bare-psl.ctl version [4708f55d52].
> > > > > > > | 1 2 3 4 5 6 7 | @define dsk: dsk:,p20: @S:BPSL.EXE *(lapin "psl.init") *(savesystem "Bare PSL 3.1" "s:bare-psl.exe" ()) *(quit) ;@rename S:BARE-PSL.EXE PSL:BARE-PSL.EXE ;@set file autokeep PSL:BARE-PSL.EXE |
Added psl-1983/20-kernel/make-bare-psl.log version [04c0015288].
cannot compute difference between binary files
Added psl-1983/20-kernel/make-nmode.ctl version [21b42b9020].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | @; This file constructs a version of NMODE, including @; @; The NMODE (EMACS-like) editor and Lisp interface. @; A set of "useful" things described in the manual. @; @; It creates a new executable file S:NMODE.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:NMODE.EXE. @; @delete s:nmode.exe, @expunge @ @psl:bare-psl random-argument-to-get-a-new-fork *(load useful nmode init-file) *(nmode-initialize) *(setq nmode-auto-start t) *(savesystem "NMODE PSL 3.1" "s:nmode.exe" nil) %((read-init-file "nmode"))) *(quit) @reset . |
Added psl-1983/20-kernel/make-psl.ctl version [5af5bcdea0].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | @; This file constructs a new PSL containing many useful things, including: @; @; The NMODE (EMACS-like) editor and Lisp interface. @; The Lisp Machine Defstruct Facility. @; A set of "useful" things described in the manual. @; @; It creates a new executable file S:PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:PSL.EXE. @; @delete s:psl.exe @expunge s: @psl:bare-psl random-argument-to-get-a-new-fork *(load useful nstruct debug find nmode init-file) *(nmode-initialize) *(nmode-switch-windows) % Switch to "OUTPUT" window *(set-message *"C-] E executes Lisp form on current line; C-] L gets normal PSL interface") *(savesystem "PSL 3.1" "s:psl.exe" '((read-init-file "psl"))) *(quit) @reset . @set file autokeep s:psl.exe |
Added psl-1983/20-kernel/make-pslcomp.ctl version [0e5ea9f21b].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | @; This file constructs a new PSLCOMP. @; @; It creates a new executable file S:PSLCOMP.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:PSLCOMP.EXE. @; @delete s:pslcomp.exe @expunge s: @psl:bare-psl random-argument-to-get-a-new-fork * (load pslcomp-main init-file) * % The following things are loaded because their definitions are useful * % when users compile things: * (load objects common strings pathnames fast-vector nstruct) * (savesystem "UTAH-PSL Compiler 3.1" * "s:pslcomp.exe" * '((read-init-file "pslcomp"))) * (quit) @reset . |
Added psl-1983/20-kernel/make-rlisp.ctl version [ecba1c7723].
> > > > > | 1 2 3 4 5 | @PSL:BARE-PSL.EXE random-argument-to-get-a-new-fork *(load rlisp compiler init-file) *(SaveSystem "PSL 3.1 RLisp" "S:RLISP.EXE" '((read-init-file "rlisp"))) *(quit) @reset . |
Added psl-1983/20-kernel/make-rlisp.log version [b1b064ae38].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20>MAKE-RLISP.CTL.1 started at 7-Mar-83 09:29:25] TOPS-20 Command processor 5(712)-1 @PSL:BARE-PSL.EXE random-argument-to-get-a-new-fork Bare PSL 3.1, 7-Mar-83 1 lisp> (load rlisp compiler init-file) *** FLUID `SEMIC*' cannot become GLOBAL *** FLUID `SEMIC*' cannot become GLOBAL *** FLUID `*OUTPUT' cannot become GLOBAL NIL 2 lisp> (SaveSystem "PSL 3.1 RLisp" "S:RLISP.EXE" '((read-init-file "rlisp"))) *** Garbage collection starting *** GC 2: time 841 ms *** 512 recovered, 32 stable, 6880 active, 83088 free NIL 3 lisp> (quit) @reset . @ [DO: Execution finished at 7-Mar-83 09:30:38] |
Added psl-1983/20-kernel/make-utah-psl.ctl version [b6bd3552fb].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @; This file constructs a new PSL containing many useful things, including: @; It creates a new executable file S:PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; @s:bare-psl random-argument-to-get-a-new-fork *(load init-file homedir) *(savesystem "PSL 3.1" "s:psl.exe" '((read-init-file "psl"))) *(quit) @reset . @set file autokeep s:psl.exe |
Added psl-1983/20-kernel/make-utah-psl.log version [6cc74b3091].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20>MAKE-UTAH-PSL.CTL.1 started at 7-Mar-83 09:26:47] TOPS-20 Command processor 5(712)-1 @; This file constructs a new PSL containing many useful things, including: @; It creates a new executable file S:PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; @psl:bare-psl random-argument-to-get-a-new-fork ?Unrecognized command - File not found - "psl:bare-psl" @ [DO: End of control file while searching for %ERR::] [DO: Execution aborted at 7-Mar-83 09:26:59] LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20>MAKE-UTAH-PSL.CTL.2 started at 7-Mar-83 09:27:25] TOPS-20 Command processor 5(712)-1 @; This file constructs a new PSL containing many useful things, including: @; It creates a new executable file S:PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; @s:bare-psl random-argument-to-get-a-new-fork Bare PSL 3.1, 7-Mar-83 1 lisp> (load init-file homedir) NIL 2 lisp> (savesystem "PSL 3.1" "s:psl.exe" '((read-init-file "psl"))) *** Garbage collection starting *** GC 2: time 443 ms *** 139 recovered, 32 stable, 789 active, 89179 free NIL 3 lisp> (quit) @reset . @set file autokeep s:psl.exe ?Does not match switch or keyword - "autokeep" @ [DO: End of control file while searching for %ERR::] [DO: Execution aborted at 7-Mar-83 09:27:48] |
Added psl-1983/20-kernel/mini-trace.red version [3cc15c79a2].
> > | 1 2 | PathIn "autoload-trace.red"$ END; |
Added psl-1983/20-kernel/module.mic version [32120b0eec].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; independant compilation a program for the 20 ; MIC MODULE modulename,symbolmname @define DSK:, DSK:, P20:, PI: @delete 'a.mac @delete D'a.mac ;avoid obnoixous ^Q halts... @terminal length 0 @s:DEC20-cross.exe off break; %kill obnoxious break loops off USERMODE ; InputSymFile!* := "'B.sym"$ OutputSymFile!* := "'B.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''NIL; ModName!*:='''A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @terminal length 24 @macro *'A.rel='A.mac *D'A.rel=D'A.mac |
Added psl-1983/20-kernel/newdir.mic version [3874d8ed57].
> > > > > > | 1 2 3 4 5 6 | build ss:<psl.'A> files dir 100 work 'B perm 'B |
Added psl-1983/20-kernel/nil.mac version [081f1872e6].
> > > > > | 1 2 3 4 5 | radix 10 loc 128 <30_31>+128 <30_31>+128 end |
Added psl-1983/20-kernel/nil.rel version [3d10995351].
cannot compute difference between binary files
Added psl-1983/20-kernel/non-kl-run.sl version [c29c5ba5e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % NON-KL-RUN.SL - Extra runtime support for KI processors % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 May 1982 % Copyright (c) 1982 University of Utah % % Basic problem is lack of ADJBP instruction (lap '((!*entry Byte expr 2) (idivi 2 5) % divide word offset by 5 (add 2 1) % add word address to word offset (ldb 1 (indexed 3 BytePointerTable)) % fetch byte using remainder (!*EXIT 0) (!*entry PutByte expr 3) (move 4 3) % save byte in 4 (idivi 2 5) (add 2 1) (dpb 4 (indexed 3 BytePointerTable)) (!*EXIT 0) BytePointerTable (fullword (FieldPointer (indexed 2 0) 0 7)) (fullword (FieldPointer (indexed 2 0) 7 7)) (fullword (FieldPointer (indexed 2 0) 14 7)) (fullword (FieldPointer (indexed 2 0) 21 7)) (fullword (FieldPointer (indexed 2 0) 28 7)) )) (lap '((!*entry BitTable expr 2) (idivi 2 18) % divide word offset by 18 (add 2 1) % add word address to word offset (ldb 1 (indexed 3 BytePointerTable)) % fetch byte using remainder (!*EXIT 0) (!*entry PutBitTable expr 3) (move 4 3) % save byte in 4 (idivi 2 18) (add 2 1) (dpb 4 (indexed 3 BytePointerTable)) (!*EXIT 0) BytePointerTable (fullword (FieldPointer (indexed 2 0) 0 2)) (fullword (FieldPointer (indexed 2 0) 2 2)) (fullword (FieldPointer (indexed 2 0) 4 2)) (fullword (FieldPointer (indexed 2 0) 6 2)) (fullword (FieldPointer (indexed 2 0) 8 2)) (fullword (FieldPointer (indexed 2 0) 10 2)) (fullword (FieldPointer (indexed 2 0) 12 2)) (fullword (FieldPointer (indexed 2 0) 14 2)) (fullword (FieldPointer (indexed 2 0) 16 2)) (fullword (FieldPointer (indexed 2 0) 18 2)) (fullword (FieldPointer (indexed 2 0) 20 2)) (fullword (FieldPointer (indexed 2 0) 22 2)) (fullword (FieldPointer (indexed 2 0) 24 2)) (fullword (FieldPointer (indexed 2 0) 26 2)) (fullword (FieldPointer (indexed 2 0) 28 2)) (fullword (FieldPointer (indexed 2 0) 30 2)) (fullword (FieldPointer (indexed 2 0) 32 2)) (fullword (FieldPointer (indexed 2 0) 34 2)) )) (lap '((!*entry HalfWord expr 2) (rot 2 -1) % make halfword offset into word offset (add 1 2) % add word base to word offset (jumpl 1 (lit (hrrz 1 (indexed 1 0)) % test sign bit (from rot) (!*EXIT 0))) (hlrz 1 (indexed 1 0)) (!*EXIT 0) )) (lap '((!*entry PutHalfWord expr 3) (rot 2 -1) (add 1 2) (jumpl 1 (lit (hrrm 3 (indexed 1 0)) (!*EXIT 0))) (hrlm 3 (indexed 1 0)) (!*EXIT 0) )) |
Added psl-1983/20-kernel/nonkl.build version [2cf72fccbc].
> | 1 | in "non-kl-run.sl"$ |
Added psl-1983/20-kernel/previous-20.sym version [207c4bba01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !') ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADQUOTEDEXPRESSION)) (PUT (QUOTE !() ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADLISTORDOTTEDPAIR)) (PUT (QUOTE !)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADRIGHTPAREN)) (PUT (QUOTE ![) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADVECTOR)) (PUT (MKID (CHAR EOF)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADEOF)) (INITOBLIST)))) (SETQ ORDEREDIDLIST!* (QUOTE (ID2INT NONIDERROR INT2ID TYPEERROR NONINTEGERERROR INT2SYS LISP2CHAR NONCHARACTERERROR INT2CODE SYS2INT GTFIXN ID2STRING STRING2VECTOR GTVECT NONSTRINGERROR VECTOR2STRING GTSTR NONVECTORERROR LIST2STRING LENGTH NONPAIRERROR STRING2LIST CONS LIST2VECTOR VECTOR2LIST GETV BLDMSG STDERROR INDEXERROR PUTV UPBV INDX RANGEERROR NONSEQUENCEERROR SETINDX SUB SUBSEQ GTWRDS GTHALFWORDS NCONS TCONC SETSUB SETSUBSEQ CONCAT APPEND SIZE MAKE!-STRING NONPOSITIVEINTEGERERROR MKSTRING MAKE!-BYTES MAKE!-HALFWORDS MAKE!-WORDS MAKE!-VECTOR STRING VECTOR CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP CAR CDR RPLACA RPLACD FIXP DIGIT LITER EQN LISPEQUAL STRINGEQUAL EQSTR EQUAL CAAAAR CAAAR CAAADR CAADAR CAADR CAADDR CADAAR CADAR CADADR CADDAR CADDR CADDDR CDAAAR CDAAR CDAADR CDADAR CDADR CDADDR CDDAAR CDDAR CDDADR CDDDAR CDDDR CDDDDR CAAR CADR CDAR CDDR SAFECAR SAFECDR ATOM CONSTANTP NULL NUMBERP EXPT MKQUOTE LIST3 CONTINUABLEERROR GREATERP DIFFERENCE MINUSP TIMES2 ADD1 QUOTIENT PLUS2 LIST EVLIS QUOTE EXPR DE LIST2 LIST4 PUTD FUNCTION LAMBDA FEXPR DF MACRO DM NEXPR DN SETQ EVAL SET PROG2 PROGN EVPROGN AND EVAND OR EVOR COND EVCOND NOT ABS MINUS DIVIDE ZEROP REMAINDER XCONS MAX ROBUSTEXPAND MAX2 LESSP MIN MIN2 PLUS TIMES MAP FASTAPPLY MAPC MAPCAN NCONC MAPCON MAPCAR MAPLIST ASSOC SASSOC PAIR SUBLIS DEFLIST PUT DELETE MEMBER MEMQ REVERSE SUBST EXPAND CHANNELPRINT CHANNELPRIN1 CHANNELTERPRI PRINT OUT!* NEQ NE GEQ LEQ EQCAR EXPRP GETD MACROP FEXPRP NEXPRP COPYD RECIP FIRST SECOND THIRD FOURTH REST REVERSIP SUBSTIP DELETIP DELQ DEL DELQIP ATSOC ASS MEM RASSOC DELASC DELASCIP DELATQ DELATQIP SUBLA RPLACW LASTCAR LASTPAIR COPY NTH SUB1 PNTH ACONC LCONC MAP2 MAPC2 CHANNELPRIN2T CHANNELPRIN2 PRIN2T CHANNELSPACES CHANNELWRITECHAR SPACES CHANNELTAB CHANNELPOSN TAB FILEP PUTC SPACES2 CHANNELSPACES2 LIST2SET LIST2SETQ ADJOIN ADJOINQ UNION UNIONQ XN XNQ INTERSECTION INTERSECTIONQ GTHEAP !%RECLAIM FATALERROR DELHEAP GTCONSTSTR GTBPS GTFLTN GTID RECLAIM DELBPS GTWARRAY DELWARRAY COPYSTRINGTOFROM COPYSTRING COPYWARRAY COPYVECTORTOFROM COPYVECTOR COPYWRDSTOFROM COPYWRDS TOTALCOPY MKVECT LIST5 !*GC GCTIME!* GCKNT!* ERRORPRINTF TIMC QUIT RETURNNIL RETURNFIRSTARG LAND LOR LXOR LSHIFT LSH LNOT FIX FLOAT ONEP DEBUG TR EVLOAD TRST QEDITFNS !*EXPERT !*VERBOSE EDITF EDIT YESP PROMPTSTRING!* FASTBIND TERPRI EDITORREADER!* EDITORPRINTER!* FASTUNBIND READ CL HELP BREAK EHELP PL UP OK DISPLAYHELPFILE EDITOR IGNOREDINBACKTRACE!* INTERPRETERFUNCTIONS!* INTERPBACKTRACE PRINTF BACKTRACE RETURNADDRESSP ADDR2ID VERBOSEBACKTRACE OPTIONS!* WRITECHAR CHANNELWRITEUNKNOWNITEM CODE!-ADDRESS!-TO!-SYMBOL PRIN1 ERROR NO YES RDS ERROUT!* WRS ERRORSET CURSYM!* !*SEMICOL!* ERRORFORM!* !*CONTINUABLEERROR EMSG!* !*BREAK !*EMSGP MAXBREAKLEVEL!* BREAKLEVEL!* FLATSIZE USAGETYPEERROR NONNUMBERERROR NONWORDS !*BACKTRACE !*INNER!*BACKTRACE THROW !$ERROR!$ CATCHSETUP THROWSIGNAL!* !%UNCATCH CHANNELNOTOPEN CHANNELERROR WRITEONLYCHANNEL READONLYCHANNEL ILLEGALSTANDARDCHANNELCLOSE IOERROR CODEAPPLY CODEEVALAPPLY BINDEVAL LBIND1 COMPILEDCALLINGINTERPRETED BSTACKOVERFLOW RESTOREENVIRONMENT !*LAMBDALINK UNDEFINEDFUNCTION UNBINDN APPLY FUNBOUNDP FCODEP GETFCODEPOINTER GET VALUECELL GETFNTYPE !&!&VALUE!&!& THROWTAG!* CATCH!-ALL CATCH UNWIND!-ALL !&!&THROWN!&!& !$UNWIND!-PROTECT!$ !&!&TAG!&!& !%THROW UNWIND!-PROTECT ERRSET !*CATCH !*THROW CAPTUREENVIRONMENT PROGBODY!* PROGJUMPTABLE!* PROG PBIND1 !$PROG!$ GO RETURN SYSTEM_LIST!* DATE DUMPLISP BINARYOPENREAD DEC20OPEN BINARYOPENWRITE VALUECELLLOCATION !*WRITINGFASLFILE NEWBITTABLEENTRY!* FINDIDNUMBER MAKERELOCHALFWORD EXTRAREGLOCATION FUNCTIONCELLLOCATION FASLIN INTERN PUTENTRY LOADDIRECTORIES!* LOADEXTENSIONS!* LOAD LOAD1 RELOAD EVRELOAD !*USERMODE !*REDEFMSG !*INSIDELOAD !*LOWER PENDINGLOADS!* IMPORTS PRETTYPRINT DEFSTRUCT STEP MINI EMODE INVOKE RCREF CREFON COMPILER COMPD FASLOUT BUG EXEC MM TERMINALINPUTHANDLER COMPRESSREADCHAR DEC20WRITECHAR TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR !$EOL!$ CHANNELREADCHAR READCHAR IN!* CHANNELUNREADCHAR UNREADCHAR OPEN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT SYSTEMOPENFILESPECIAL SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!* SPECIAL OUTPUT INPUT CLOSE SYSTEMMARKASCLOSEDCHANNEL SPECIALRDSACTION!* STDIN!* SPECIALWRSACTION!* STDOUT!* CHANNELEJECT EJECT CHANNELLINELENGTH LINELENGTH POSN CHANNELREADCH !*RAISE READCH PRINC CHANNELPRINC CURRENTREADMACROINDICATOR!* CHANNELREADTOKENWITHHOOKS CHANNELREADTOKEN TOKTYPE!* CURRENTSCANTABLE!* CHANNELREAD LISPSCANTABLE!* LISPREADMACRO MAKEINPUTAVAILABLE !*INSIDESTRUCTUREREAD CHANNELREADEOF !$EOF!$ CHANNELREADQUOTEDEXPRESSION CHANNELREADLISTORDOTTEDPAIR CHANNELREADRIGHTPAREN CHANNELREADVECTOR !*COMPRESSING !*EOLINSTRINGOK NEWID MAKESTRINGINTOLISPINTEGER PACKAGE CURRENTPACKAGE!* GLOBAL RATOM READLINE CHANNELREADLINE OUTPUTBASE!* IDESCAPECHAR!* CHANNELWRITESTRING WRITESTRING CHANNELWRITESYSINTEGER WRITESYSINTEGER CHANNELWRITEFIXNUM CHANNELWRITEINTEGER CHANNELWRITESYSFLOAT WRITEFLOAT CHANNELWRITEFLOAT CHANNELPRINTSTRING CHANNELWRITEID CHANNELWRITEUNBOUND CHANNELPRINTID CHANNELPRINTUNBOUND CHANNELWRITECODEPOINTER CHANNELWRITEBLANKOREOL CHANNELWRITEPAIR PRINLEVEL PRINLENGTH RECURSIVECHANNELPRIN2 CHANNELPRINTPAIR RECURSIVECHANNELPRIN1 CHANNELWRITEVECTOR CHANNELPRINTVECTOR CHANNELWRITEWORDS CHANNELWRITEHALFWORDS CHANNELWRITEBYTES PRIN2 FORMATFORPRINTF!* PRIN2L ERRPRIN CHANNELPRINTF EXPLODEENDPOINTER!* EXPLODE EXPLODE2 FLATSIZE2 COMPRESSERROR COMPRESSLIST!* CLEARCOMPRESSCHANNEL COMPRESS IMPLODE CHANNELTYI CHANNELTYO TYI TYO COMMENTOUTCODE COMPILETIME BOTHTIMES LOADTIME STARTUPTIME CONTERROR OTHERWISE DEFAULT CASE RANGE SETF EXPANDSETF SETF!-EXPAND ASSIGN!-OP CHAR DOCHAR CNTRL CONTROL CHARERROR META LOWER CHARCONST ONOFF!* MKFLAGVAR SIMPFG ON OFF !#ARG DS DEFCONST EVDEFCONST CONST STRINGGENSYM STRINGGENSYM!* FOREACH COLLECT JOIN CONC IN DO EXIT !$LOOP!$ NEXT WHILE REPEAT FOR GENSYM MK!*SQ SIMP BIN FLAMBDALINKP MAKEFUNBOUND MAKEFLAMBDALINK MAKEFCODE PROP SETPROP FLAGP TYPE FLAG FLAG1 REMFLAG REMFLAG1 REMPROP REMPROPL UNBOUNDP VARTYPE FLUID FLUID1 FLUIDP GLOBAL1 GLOBALP UNFLUID UNFLUID1 REMD !*COMP USER LOSE CODE!-NUMBER!-OF!-ARGUMENTS RESET BSTACKUNDERFLOW CLEARBINDINGS MAKEUNBOUND HASHFUNCTION REMOB INTERNP INTERNGENSYM MAPOBL GLOBALLOOKUP GLOBALINSTALL GLOBALREMOVE INITOBLIST DEC20READCHAR !*ECHO CLEARIO DEC20CLOSECHANNEL !*DEFN BREAKVALUE!* !*QUITBREAK BREAKIN!* BREAKOUT!* TOPLOOPNAME!* TOPLOOPEVAL!* BREAKEVAL!* BREAKNAME!* TOPLOOPPRINT!* TOPLOOPREAD!* TOPLOOP !$BREAK!$ BREAKEVAL BREAKFUNCTION BREAKQUIT BREAKCONTINUE BREAKRETRY HELPBREAK BREAKERRMSG BREAKEDIT TOPLOOPLEVEL!* HISTORYCOUNT!* LISPBANNER!* HISTORYLIST!* !*TIME TIME !$EXITTOPLOOP!$ DFPRINT!* IGNORE INP REDO ANS HIST CLEAR STANDARDLISP PRINTWITHFRESHLINE SAVESYSTEM INITFORMS!* EVALINITFORMS DSKIN DSKINEVAL LAPIN !%CLEAR!-CATCH!-STACK CHANNELLPOSN LPOSN DIGITTONUMBER !*OUTPUT SEMIC!* !*NONIL NONIOCHANNELERROR CHANNELWRITEEVECTOR OBJECT!-GET!-HANDLER!-QUIETLY CHANNELPRIN CHANNELPRINTEVECTOR EVECTORP EGETV EPUTV EUPBV EVECINF GTEVECT MKEVECTOR MKEVECT CHANNELWRITEBITSTRAUX))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 844)) (SETQ STRINGGENSYM!* (QUOTE "M1146")) (PUT (QUOTE INFBITLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE INFBITLENGTH) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE INFBITLENGTH) (QUOTE WCONST) (QUOTE 18)) (PUT (QUOTE TWOARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1319")) (PUT (QUOTE RELOAD) (QUOTE ENTRYPOINT) (QUOTE RELOAD)) (PUT (QUOTE RELOAD) (QUOTE IDNUMBER) (QUOTE 552)) (PUT (QUOTE TWOARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1336")) (PUT (QUOTE INTLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1465")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE NEQ) (QUOTE ENTRYPOINT) (QUOTE NEQ)) (PUT (QUOTE NEQ) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LIST2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0059")) (PUT (QUOTE LIST2STRING) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE SPECIALRDSACTION!*) (QUOTE IDNUMBER) (QUOTE 598)) (FLAG (QUOTE (SPECIALRDSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GLOBALLOOKUP) (QUOTE ENTRYPOINT) (QUOTE "L3389")) (PUT (QUOTE GLOBALLOOKUP) (QUOTE IDNUMBER) (QUOTE 772)) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L2793")) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE IDNUMBER) (QUOTE 678)) (PUT (QUOTE DEFSTRUCT) (QUOTE ENTRYPOINT) (QUOTE "L2164")) (PUT (QUOTE DEFSTRUCT) (QUOTE IDNUMBER) (QUOTE 561)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE MAKERELOCHALFWORD) (QUOTE IDNUMBER) (QUOTE 542)) (PUT (QUOTE BACKTRACE1) (QUOTE ENTRYPOINT) (QUOTE "L1654")) (PUT (QUOTE DO) (QUOTE IDNUMBER) (QUOTE 724)) (PUT (QUOTE THROWSIGNAL!*) (QUOTE IDNUMBER) (QUOTE 486)) (FLAG (QUOTE (THROWSIGNAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE REMFLAG) (QUOTE ENTRYPOINT) (QUOTE "L3122")) (PUT (QUOTE REMFLAG) (QUOTE IDNUMBER) (QUOTE 745)) (PUT (QUOTE PRINLEVEL) (QUOTE IDNUMBER) (QUOTE 657)) (FLAG (QUOTE (PRINLEVEL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EJECT) (QUOTE ENTRYPOINT) (QUOTE EJECT)) (PUT (QUOTE EJECT) (QUOTE IDNUMBER) (QUOTE 603)) (PUT (QUOTE LISPREADMACRO) (QUOTE IDNUMBER) (QUOTE 619)) (PUT (QUOTE STRING2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0068")) (PUT (QUOTE STRING2LIST) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE EXIT) (QUOTE ENTRYPOINT) (QUOTE EXIT)) (PUT (QUOTE EXIT) (QUOTE IDNUMBER) (QUOTE 725)) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3437")) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 779)) (PUT (QUOTE ONEARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1348")) (PUT (QUOTE STRING2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0041")) (PUT (QUOTE STRING2VECTOR) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1785")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE BACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1649")) (PUT (QUOTE BACKTRACE) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1781")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 493)) (PUT (QUOTE RETURNNIL) (QUOTE ENTRYPOINT) (QUOTE "L1373")) (PUT (QUOTE RETURNNIL) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2491")) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 642)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1075")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE GENSYM) (QUOTE ENTRYPOINT) (QUOTE GENSYM)) (PUT (QUOTE GENSYM) (QUOTE IDNUMBER) (QUOTE 731)) (PUT (QUOTE ONEARGPREDICATEDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1361")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1666")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 466)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L3443")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 587)) (PUT (QUOTE !*EMSGP) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE !*EMSGP) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE TYI) (QUOTE ENTRYPOINT) (QUOTE TYI)) (PUT (QUOTE TYI) (QUOTE IDNUMBER) (QUOTE 683)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3045")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 505)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L1682")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 728)) (PUT (QUOTE STANDARDLISP) (QUOTE ENTRYPOINT) (QUOTE "L3557")) (PUT (QUOTE STANDARDLISP) (QUOTE IDNUMBER) (QUOTE 815)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE !*OUTPUT) (QUOTE IDNUMBER) (QUOTE 827)) (PUT (QUOTE !*OUTPUT) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SECOND) (QUOTE ENTRYPOINT) (QUOTE SECOND)) (PUT (QUOTE SECOND) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 669)) (PUT (QUOTE CURSYM!*) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE CHANNELTYI) (QUOTE ENTRYPOINT) (QUOTE "L2799")) (PUT (QUOTE CHANNELTYI) (QUOTE IDNUMBER) (QUOTE 681)) (PUT (QUOTE FLOATREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1421")) (PUT (QUOTE SASSOC) (QUOTE ENTRYPOINT) (QUOTE SASSOC)) (PUT (QUOTE SASSOC) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ADDR2ID) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE ROBUSTEXPAND) (QUOTE ENTRYPOINT) (QUOTE "L0792")) (PUT (QUOTE ROBUSTEXPAND) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE INTREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1420")) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 8209)) (PUT (QUOTE TWOARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1320")) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE DEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3518")) (PUT (QUOTE CURRENTPACKAGE!*) (QUOTE IDNUMBER) (QUOTE 633)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE ENTRYPOINT) (QUOTE "L4346")) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 823)) (PUT (QUOTE SETSUBSEQ) (QUOTE ENTRYPOINT) (QUOTE "L0210")) (PUT (QUOTE SETSUBSEQ) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE PNTH) (QUOTE ENTRYPOINT) (QUOTE PNTH)) (PUT (QUOTE PNTH) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE PACKAGE) (QUOTE ENTRYPOINT) (QUOTE "L2480")) (PUT (QUOTE PACKAGE) (QUOTE IDNUMBER) (QUOTE 632)) (PUT (QUOTE MAKEDS) (QUOTE ENTRYPOINT) (QUOTE MAKEDS)) (PUT (QUOTE !*USERMODE) (QUOTE IDNUMBER) (QUOTE 554)) (FLAG (QUOTE (!*USERMODE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*REDEFMSG) (QUOTE IDNUMBER) (QUOTE 555)) (PUT (QUOTE !*REDEFMSG) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SAVE!-INTO!-FILE) (QUOTE ENTRYPOINT) (QUOTE "L2048")) (PUT (QUOTE CHANNELPRINTID) (QUOTE ENTRYPOINT) (QUOTE "L2523")) (PUT (QUOTE CHANNELPRINTID) (QUOTE IDNUMBER) (QUOTE 652)) (PUT (QUOTE BUG) (QUOTE ENTRYPOINT) (QUOTE BUG)) (PUT (QUOTE BUG) (QUOTE IDNUMBER) (QUOTE 571)) (PUT (QUOTE DEFAULT) (QUOTE IDNUMBER) (QUOTE 692)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE INITIALVALUE) (QUOTE (EVAL APPLY FASTAPPLY CODEAPPLY CODEEVALAPPLY CATCH ERRORSET EVPROGN TOPLOOP BREAKEVAL BINDEVAL BREAK MAIN))) (PUT (QUOTE CLEAR) (QUOTE IDNUMBER) (QUOTE 814)) (PUT (QUOTE LPOSN) (QUOTE ENTRYPOINT) (QUOTE LPOSN)) (PUT (QUOTE LPOSN) (QUOTE IDNUMBER) (QUOTE 825)) (PUT (QUOTE DOPNTH) (QUOTE ENTRYPOINT) (QUOTE DOPNTH)) (PUT (QUOTE BREAKOUT!*) (QUOTE IDNUMBER) (QUOTE 784)) (FLAG (QUOTE (BREAKOUT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE STRINGGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L2954")) (PUT (QUOTE STRINGGENSYM) (QUOTE IDNUMBER) (QUOTE 717)) (PUT (QUOTE FLOATSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1481")) (PUT (QUOTE TAB) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE TAB) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1110")) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L3178")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 756)) (PUT (QUOTE MEMBER) (QUOTE ENTRYPOINT) (QUOTE MEMBER)) (PUT (QUOTE MEMBER) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE EXPRP) (QUOTE ENTRYPOINT) (QUOTE EXPRP)) (PUT (QUOTE EXPRP) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE LNOT) (QUOTE ENTRYPOINT) (QUOTE LNOT)) (PUT (QUOTE LNOT) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE ONEARGPREDICATEDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1360")) (PUT (QUOTE ACONC) (QUOTE ENTRYPOINT) (QUOTE ACONC)) (PUT (QUOTE ACONC) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE PRETTYPRINT) (QUOTE ENTRYPOINT) (QUOTE "L2160")) (PUT (QUOTE PRETTYPRINT) (QUOTE IDNUMBER) (QUOTE 560)) (PUT (QUOTE !$PROG!$) (QUOTE IDNUMBER) (QUOTE 529)) (PUT (QUOTE ERRSET) (QUOTE ENTRYPOINT) (QUOTE ERRSET)) (PUT (QUOTE ERRSET) (QUOTE IDNUMBER) (QUOTE 521)) (PUT (QUOTE DIVIDE) (QUOTE ENTRYPOINT) (QUOTE DIVIDE)) (PUT (QUOTE DIVIDE) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE DELETE) (QUOTE ENTRYPOINT) (QUOTE DELETE)) (PUT (QUOTE DELETE) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE NONINTEGER2ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1342")) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 595)) (PUT (QUOTE PRINLENGTH) (QUOTE IDNUMBER) (QUOTE 658)) (FLAG (QUOTE (PRINLENGTH)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE XNQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE XNQ) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE TYO) (QUOTE ENTRYPOINT) (QUOTE TYO)) (PUT (QUOTE TYO) (QUOTE IDNUMBER) (QUOTE 684)) (PUT (QUOTE REMD) (QUOTE ENTRYPOINT) (QUOTE REMD)) (PUT (QUOTE REMD) (QUOTE IDNUMBER) (QUOTE 758)) (PUT (QUOTE !*THROW) (QUOTE ENTRYPOINT) (QUOTE "L1980")) (PUT (QUOTE !*THROW) (QUOTE IDNUMBER) (QUOTE 523)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0663")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE ERRORFORM!*) (QUOTE IDNUMBER) (QUOTE 470)) (FLAG (QUOTE (ERRORFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*INSIDELOAD) (QUOTE IDNUMBER) (QUOTE 556)) (FLAG (QUOTE (!*INSIDELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1517")) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 497)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE MAP) (QUOTE ENTRYPOINT) (QUOTE MAP)) (PUT (QUOTE MAP) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE FOURTH) (QUOTE ENTRYPOINT) (QUOTE FOURTH)) (PUT (QUOTE FOURTH) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE LXOR) (QUOTE ENTRYPOINT) (QUOTE LXOR)) (PUT (QUOTE LXOR) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE COMPD) (QUOTE ENTRYPOINT) (QUOTE COMPD)) (PUT (QUOTE COMPD) (QUOTE IDNUMBER) (QUOTE 569)) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2617")) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE IDNUMBER) (QUOTE 663)) (PUT (QUOTE UNFLUID1) (QUOTE ENTRYPOINT) (QUOTE "L3183")) (PUT (QUOTE UNFLUID1) (QUOTE IDNUMBER) (QUOTE 757)) (PUT (QUOTE BOTHTIMES) (QUOTE ENTRYPOINT) (QUOTE "L2803")) (PUT (QUOTE BOTHTIMES) (QUOTE IDNUMBER) (QUOTE 687)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2199")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L3076")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 507)) (PUT (QUOTE VALUECELL) (QUOTE ENTRYPOINT) (QUOTE "L3298")) (PUT (QUOTE VALUECELL) (QUOTE IDNUMBER) (QUOTE 509)) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2584")) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE IDNUMBER) (QUOTE 660)) (PUT (QUOTE WRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2502")) (PUT (QUOTE WRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 643)) (PUT (QUOTE BACKTRACERANGE) (QUOTE ENTRYPOINT) (QUOTE "L1646")) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE DIGIT) (QUOTE ENTRYPOINT) (QUOTE DIGIT)) (PUT (QUOTE DIGIT) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE FASLIN) (QUOTE ENTRYPOINT) (QUOTE FASLIN)) (PUT (QUOTE FASLIN) (QUOTE IDNUMBER) (QUOTE 545)) (PUT (QUOTE LIST2SETQ) (QUOTE ENTRYPOINT) (QUOTE "L1037")) (PUT (QUOTE LIST2SETQ) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 820)) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2504")) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE IDNUMBER) (QUOTE 645)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE PUTC) (QUOTE ENTRYPOINT) (QUOTE PUTC)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE DELASC) (QUOTE ENTRYPOINT) (QUOTE DELASC)) (PUT (QUOTE DELASC) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE FOREACH) (QUOTE ENTRYPOINT) (QUOTE "L2974")) (PUT (QUOTE FOREACH) (QUOTE IDNUMBER) (QUOTE 719)) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1165")) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 771)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L1815")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 498)) (PUT (QUOTE MM) (QUOTE ENTRYPOINT) (QUOTE MM)) (PUT (QUOTE MM) (QUOTE IDNUMBER) (QUOTE 573)) (PUT (QUOTE FLOATINTARG) (QUOTE ENTRYPOINT) (QUOTE "L1515")) (PUT (QUOTE MKEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L6227")) (PUT (QUOTE MKEVECTOR) (QUOTE IDNUMBER) (QUOTE 841)) (PUT (QUOTE MAKEBUFINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2329")) (PUT (QUOTE DELASCIP) (QUOTE ENTRYPOINT) (QUOTE "L0934")) (PUT (QUOTE DELASCIP) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE MAKE!-STRING) (QUOTE ENTRYPOINT) (QUOTE "L0309")) (PUT (QUOTE MAKE!-STRING) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE ZEROP) (QUOTE ENTRYPOINT) (QUOTE ZEROP)) (PUT (QUOTE ZEROP) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE IDNUMBER) (QUOTE 801)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE INITIALVALUE) (QUOTE -1)) (PUT (QUOTE FLOATGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1461")) (PUT (QUOTE GLOBALREMOVE) (QUOTE ENTRYPOINT) (QUOTE "L3396")) (PUT (QUOTE GLOBALREMOVE) (QUOTE IDNUMBER) (QUOTE 774)) (PUT (QUOTE NTHENTRY) (QUOTE ENTRYPOINT) (QUOTE "L3534")) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2299")) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE IDNUMBER) (QUOTE 627)) (PUT (QUOTE GCERROR) (QUOTE ENTRYPOINT) (QUOTE "L1232")) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE DELASCIP1) (QUOTE ENTRYPOINT) (QUOTE "L0927")) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 583)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE INTLSHIFT) (QUOTE ENTRYPOINT) (QUOTE "L1452")) (PUT (QUOTE CHARERROR) (QUOTE ENTRYPOINT) (QUOTE "L2874")) (PUT (QUOTE CHARERROR) (QUOTE IDNUMBER) (QUOTE 703)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE MAPC2) (QUOTE ENTRYPOINT) (QUOTE MAPC2)) (PUT (QUOTE MAPC2) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE ANS) (QUOTE ENTRYPOINT) (QUOTE ANS)) (PUT (QUOTE ANS) (QUOTE IDNUMBER) (QUOTE 812)) (PUT (QUOTE HIST) (QUOTE ENTRYPOINT) (QUOTE HIST)) (PUT (QUOTE HIST) (QUOTE IDNUMBER) (QUOTE 813)) (PUT (QUOTE EVALINITFORMS) (QUOTE ENTRYPOINT) (QUOTE "L3565")) (PUT (QUOTE EVALINITFORMS) (QUOTE IDNUMBER) (QUOTE 819)) (PUT (QUOTE EDITORPRINTER!*) (QUOTE IDNUMBER) (QUOTE 436)) (FLAG (QUOTE (EDITORPRINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LOOKUPORADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3322")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1069")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE ENTRYPOINT) (QUOTE "L2665")) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE IDNUMBER) (QUOTE 666)) (PUT (QUOTE EXPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2782")) (PUT (QUOTE EXPLODE) (QUOTE IDNUMBER) (QUOTE 673)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SPECIAL) (QUOTE IDNUMBER) (QUOTE 593)) (PUT (QUOTE RCREF) (QUOTE IDNUMBER) (QUOTE 566)) (PUT (QUOTE EVRELOAD) (QUOTE ENTRYPOINT) (QUOTE "L2131")) (PUT (QUOTE EVRELOAD) (QUOTE IDNUMBER) (QUOTE 553)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE INITIALVALUE) (QUOTE (COND PROG AND OR PROGN SETQ))) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 615)) (FLAG (QUOTE (TOKTYPE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INTSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1480")) (PUT (QUOTE MIN) (QUOTE ENTRYPOINT) (QUOTE MIN)) (PUT (QUOTE MIN) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE INP) (QUOTE ENTRYPOINT) (QUOTE INP)) (PUT (QUOTE INP) (QUOTE IDNUMBER) (QUOTE 810)) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L5551")) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE IDNUMBER) (QUOTE 831)) (PUT (QUOTE CHANNELPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2262")) (PUT (QUOTE CHANNELPOSN) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE FLAGP) (QUOTE ENTRYPOINT) (QUOTE FLAGP)) (PUT (QUOTE FLAGP) (QUOTE IDNUMBER) (QUOTE 741)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1789")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 494)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE REMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1419")) (PUT (QUOTE REMAINDER) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1097")) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE ID2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0036")) (PUT (QUOTE ID2STRING) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE REDO) (QUOTE ENTRYPOINT) (QUOTE REDO)) (PUT (QUOTE REDO) (QUOTE IDNUMBER) (QUOTE 811)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L2772")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 670)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L1067")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1082")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2761")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE !*VERBOSE) (QUOTE IDNUMBER) (QUOTE 428)) (FLAG (QUOTE (!*VERBOSE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L3266")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 765)) (PUT (QUOTE EUPBV) (QUOTE ENTRYPOINT) (QUOTE EUPBV)) (PUT (QUOTE EUPBV) (QUOTE IDNUMBER) (QUOTE 838)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1070")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE NEWBITTABLEENTRY!*) (QUOTE IDNUMBER) (QUOTE 540)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2485")) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 640)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0584")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE GETV) (QUOTE ENTRYPOINT) (QUOTE GETV)) (PUT (QUOTE GETV) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE !*INSIDESTRUCTUREREAD) (QUOTE IDNUMBER) (QUOTE 621)) (FLAG (QUOTE (!*INSIDESTRUCTUREREAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1466")) (PUT (QUOTE MARKFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1158")) (PUT (QUOTE CL) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (CL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MACROP) (QUOTE ENTRYPOINT) (QUOTE MACROP)) (PUT (QUOTE MACROP) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE CONTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2811")) (PUT (QUOTE CONTERROR) (QUOTE IDNUMBER) (QUOTE 690)) (PUT (QUOTE FLOATONEP) (QUOTE ENTRYPOINT) (QUOTE "L1526")) (PUT (QUOTE ONEP) (QUOTE ENTRYPOINT) (QUOTE ONEP)) (PUT (QUOTE ONEP) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE LOAD) (QUOTE ENTRYPOINT) (QUOTE LOAD)) (PUT (QUOTE LOAD) (QUOTE IDNUMBER) (QUOTE 550)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE VECTOR) (QUOTE ENTRYPOINT) (QUOTE VECTOR)) (PUT (QUOTE VECTOR) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1796")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 495)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE IDNUMBER) (QUOTE 548)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE INITIALVALUE) (QUOTE ("" "pl:"))) (PUT (QUOTE WRITENUMBER1) (QUOTE ENTRYPOINT) (QUOTE "L2497")) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE THIRD) (QUOTE ENTRYPOINT) (QUOTE THIRD)) (PUT (QUOTE THIRD) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE SETF) (QUOTE ENTRYPOINT) (QUOTE SETF)) (PUT (QUOTE SETF) (QUOTE IDNUMBER) (QUOTE 695)) (PUT (QUOTE QEDNTH) (QUOTE ENTRYPOINT) (QUOTE QEDNTH)) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2066")) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE IDNUMBER) (QUOTE 543)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 667)) (PUT (QUOTE LASTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L0977")) (PUT (QUOTE LASTPAIR) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE ERRORSET) (QUOTE ENTRYPOINT) (QUOTE "L1764")) (PUT (QUOTE ERRORSET) (QUOTE IDNUMBER) (QUOTE 467)) (PUT (QUOTE COMPILER) (QUOTE IDNUMBER) (QUOTE 568)) (PUT (QUOTE UPDATEREGION) (QUOTE ENTRYPOINT) (QUOTE "L1242")) (PUT (QUOTE VECTOR2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0083")) (PUT (QUOTE VECTOR2LIST) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PUTV) (QUOTE ENTRYPOINT) (QUOTE PUTV)) (PUT (QUOTE PUTV) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE YESP) (QUOTE ENTRYPOINT) (QUOTE YESP)) (PUT (QUOTE YESP) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE NCONC) (QUOTE ENTRYPOINT) (QUOTE NCONC)) (PUT (QUOTE NCONC) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE IGNORE) (QUOTE IDNUMBER) (QUOTE 809)) (PUT (QUOTE TAGBITLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TAGBITLENGTH) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE TAGBITLENGTH) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE RETURNADDRESSP) (QUOTE ENTRYPOINT) (QUOTE "L2032")) (PUT (QUOTE RETURNADDRESSP) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L1077")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE HELP) (QUOTE ENTRYPOINT) (QUOTE HELP)) (PUT (QUOTE HELP) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE IDNUMBER) (QUOTE 638)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE INITIALVALUE) (QUOTE 10)) (PUT (QUOTE LOADTIME) (QUOTE ENTRYPOINT) (QUOTE "L2804")) (PUT (QUOTE LOADTIME) (QUOTE IDNUMBER) (QUOTE 688)) (PUT (QUOTE ID2INT) (QUOTE ENTRYPOINT) (QUOTE ID2INT)) (PUT (QUOTE ID2INT) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE ENTRYPOINT) (QUOTE "L2359")) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE IDNUMBER) (QUOTE 614)) (PUT (QUOTE THROWAUX) (QUOTE ENTRYPOINT) (QUOTE "L1990")) (PUT (QUOTE DFPRINT!*) (QUOTE IDNUMBER) (QUOTE 808)) (FLAG (QUOTE (DFPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !%THROW) (QUOTE ENTRYPOINT) (QUOTE !%THROW)) (PUT (QUOTE !%THROW) (QUOTE IDNUMBER) (QUOTE 519)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 635)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 608)) (PUT (QUOTE !*RAISE) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE NEXPRP) (QUOTE ENTRYPOINT) (QUOTE NEXPRP)) (PUT (QUOTE NEXPRP) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE MKFLAGVAR) (QUOTE ENTRYPOINT) (QUOTE "L2889")) (PUT (QUOTE MKFLAGVAR) (QUOTE IDNUMBER) (QUOTE 708)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 432)) (FLAG (QUOTE (PROMPTSTRING!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE STRINGEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0464")) (PUT (QUOTE STRINGEQUAL) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE NE) (QUOTE ENTRYPOINT) (QUOTE NE)) (PUT (QUOTE NE) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2769")) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 577)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 596)) (PUT (QUOTE BREAKVALUE!*) (QUOTE IDNUMBER) (QUOTE 781)) (FLAG (QUOTE (BREAKVALUE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FINDIDNUMBER) (QUOTE IDNUMBER) (QUOTE 541)) (PUT (QUOTE BREAKEDIT) (QUOTE ENTRYPOINT) (QUOTE "L3496")) (PUT (QUOTE BREAKEDIT) (QUOTE IDNUMBER) (QUOTE 800)) (PUT (QUOTE TIMES) (QUOTE ENTRYPOINT) (QUOTE TIMES)) (PUT (QUOTE TIMES) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE ENTRYPOINT) (QUOTE "L2292")) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE IDNUMBER) (QUOTE 626)) (PUT (QUOTE FLOATMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1498")) (PUT (QUOTE EXEC) (QUOTE ENTRYPOINT) (QUOTE EXEC)) (PUT (QUOTE EXEC) (QUOTE IDNUMBER) (QUOTE 572)) (PUT (QUOTE DELQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0890")) (PUT (QUOTE EMODE) (QUOTE ENTRYPOINT) (QUOTE EMODE)) (PUT (QUOTE EMODE) (QUOTE IDNUMBER) (QUOTE 564)) (PUT (QUOTE READLINE) (QUOTE ENTRYPOINT) (QUOTE "L2472")) (PUT (QUOTE READLINE) (QUOTE IDNUMBER) (QUOTE 636)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE INTMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1497")) (PUT (QUOTE DEFNPRINT1) (QUOTE ENTRYPOINT) (QUOTE "L3527")) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1078")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2602")) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE IDNUMBER) (QUOTE 662)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 580)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE EVECTORP) (QUOTE ENTRYPOINT) (QUOTE "L5902")) (PUT (QUOTE EVECTORP) (QUOTE IDNUMBER) (QUOTE 835)) (PUT (QUOTE OBJECT!-GET!-HANDLER!-QUIETLY) (QUOTE IDNUMBER) (QUOTE 832)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2560")) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE IDNUMBER) (QUOTE 656)) (PUT (QUOTE !*LOWER) (QUOTE IDNUMBER) (QUOTE 557)) (FLAG (QUOTE (!*LOWER)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DUMPLISP) (QUOTE ENTRYPOINT) (QUOTE "L2045")) (PUT (QUOTE DUMPLISP) (QUOTE IDNUMBER) (QUOTE 534)) (PUT (QUOTE EVAND) (QUOTE ENTRYPOINT) (QUOTE EVAND)) (PUT (QUOTE EVAND) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE LOWER) (QUOTE IDNUMBER) (QUOTE 705)) (PUT (QUOTE ASSIGN!-OP) (QUOTE IDNUMBER) (QUOTE 698)) (PUT (QUOTE PLUS) (QUOTE ENTRYPOINT) (QUOTE PLUS)) (PUT (QUOTE PLUS) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 777)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE !$UNWIND!-PROTECT!$) (QUOTE IDNUMBER) (QUOTE 517)) (PUT (QUOTE COMPRESS) (QUOTE ENTRYPOINT) (QUOTE "L2797")) (PUT (QUOTE COMPRESS) (QUOTE IDNUMBER) (QUOTE 679)) (PUT (QUOTE MAPCON) (QUOTE ENTRYPOINT) (QUOTE MAPCON)) (PUT (QUOTE MAPCON) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE MAPCAR) (QUOTE ENTRYPOINT) (QUOTE MAPCAR)) (PUT (QUOTE MAPCAR) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1687")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE SUBLIS) (QUOTE ENTRYPOINT) (QUOTE SUBLIS)) (PUT (QUOTE SUBLIS) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE MAKEBUFINTOID) (QUOTE ENTRYPOINT) (QUOTE "L2320")) (PUT (QUOTE TOPLOOPNAME!*) (QUOTE IDNUMBER) (QUOTE 785)) (FLAG (QUOTE (TOPLOOPNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKNAME!*) (QUOTE IDNUMBER) (QUOTE 788)) (FLAG (QUOTE (BREAKNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3476")) (PUT (QUOTE BREAKEVAL) (QUOTE IDNUMBER) (QUOTE 793)) (PUT (QUOTE PROG) (QUOTE ENTRYPOINT) (QUOTE PROG)) (PUT (QUOTE PROG) (QUOTE IDNUMBER) (QUOTE 527)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE IDNUMBER) (QUOTE 612)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE INITIALVALUE) (QUOTE LISPREADMACRO)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE CHANNELWRITEID) (QUOTE ENTRYPOINT) (QUOTE "L2514")) (PUT (QUOTE CHANNELWRITEID) (QUOTE IDNUMBER) (QUOTE 650)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE ASMSYMBOL) (QUOTE "L2205")) (PUT (QUOTE JFNOFCHANNEL) (QUOTE WARRAY) (QUOTE JFNOFCHANNEL)) (PUT (QUOTE CHANNELLPOSN) (QUOTE ENTRYPOINT) (QUOTE "L4459")) (PUT (QUOTE CHANNELLPOSN) (QUOTE IDNUMBER) (QUOTE 824)) (PUT (QUOTE STRINGGENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L2955")) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE FLOAT) (QUOTE ENTRYPOINT) (QUOTE FLOAT)) (PUT (QUOTE FLOAT) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 8000)) (PUT (QUOTE FLOATZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1417")) (PUT (QUOTE INDX) (QUOTE ENTRYPOINT) (QUOTE INDX)) (PUT (QUOTE INDX) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE INTZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1521")) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 501)) (PUT (QUOTE FLOATADD1) (QUOTE ENTRYPOINT) (QUOTE "L1471")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1744")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L2503")) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE IDNUMBER) (QUOTE 644)) (PUT (QUOTE EPUTV) (QUOTE ENTRYPOINT) (QUOTE EPUTV)) (PUT (QUOTE EPUTV) (QUOTE IDNUMBER) (QUOTE 837)) (PUT (QUOTE DECLAREFLUIDORGLOBAL) (QUOTE ENTRYPOINT) (QUOTE "L3151")) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 618)) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2216")) (PUT (QUOTE UNREADCHAR) (QUOTE IDNUMBER) (QUOTE 585)) (PUT (QUOTE MAKE!-WORDS) (QUOTE ENTRYPOINT) (QUOTE "L0341")) (PUT (QUOTE MAKE!-WORDS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2068")) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE IDNUMBER) (QUOTE 544)) (PUT (QUOTE SIMPFG) (QUOTE IDNUMBER) (QUOTE 709)) (PUT (QUOTE SETPROP) (QUOTE ENTRYPOINT) (QUOTE "L3083")) (PUT (QUOTE SETPROP) (QUOTE IDNUMBER) (QUOTE 740)) (PUT (QUOTE SPECIALREADFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 590)) (FLAG (QUOTE (SPECIALREADFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CHANNELPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2780")) (PUT (QUOTE CHANNELPRINTF) (QUOTE IDNUMBER) (QUOTE 671)) (PUT (QUOTE OR) (QUOTE ENTRYPOINT) (QUOTE OR)) (PUT (QUOTE OR) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE MKQUOTE) (QUOTE ENTRYPOINT) (QUOTE "L0848")) (PUT (QUOTE MKQUOTE) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE EDITORREADER!*) (QUOTE IDNUMBER) (QUOTE 435)) (FLAG (QUOTE (EDITORREADER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GCSTARTINGBIT) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE GCSTARTINGBIT) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE GCSTARTINGBIT) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE SETF!-EXPAND) (QUOTE IDNUMBER) (QUOTE 697)) (PUT (QUOTE SETSUB) (QUOTE ENTRYPOINT) (QUOTE SETSUB)) (PUT (QUOTE SETSUB) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE SIZE) (QUOTE ENTRYPOINT) (QUOTE SIZE)) (PUT (QUOTE SIZE) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE CHANNELREAD) (QUOTE ENTRYPOINT) (QUOTE "L2270")) (PUT (QUOTE CHANNELREAD) (QUOTE IDNUMBER) (QUOTE 617)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 763)) (PUT (QUOTE !&!&VALUE!&!&) (QUOTE IDNUMBER) (QUOTE 511)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L3140")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 747)) (PUT (QUOTE CHANNELSPACES) (QUOTE ENTRYPOINT) (QUOTE "L1023")) (PUT (QUOTE CHANNELSPACES) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE PRINTF2) (QUOTE ENTRYPOINT) (QUOTE "L2732")) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3400")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 775)) (PUT (QUOTE LOSE) (QUOTE IDNUMBER) (QUOTE 761)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L1804")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 496)) (PUT (QUOTE LISPEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0426")) (PUT (QUOTE LISPEQUAL) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE CLEARIO1) (QUOTE ENTRYPOINT) (QUOTE "L3413")) (PUT (QUOTE UNION) (QUOTE ENTRYPOINT) (QUOTE UNION)) (PUT (QUOTE UNION) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE DELQIP) (QUOTE ENTRYPOINT) (QUOTE DELQIP)) (PUT (QUOTE DELQIP) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CHANNELTAB) (QUOTE ENTRYPOINT) (QUOTE "L1027")) (PUT (QUOTE CHANNELTAB) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE BIGFLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1372")) (PUT (QUOTE INTLNOT) (QUOTE ENTRYPOINT) (QUOTE "L1490")) (PUT (QUOTE DSKINDEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3588")) (PUT (QUOTE MAX) (QUOTE ENTRYPOINT) (QUOTE MAX)) (PUT (QUOTE MAX) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE INSTANTIATEINFORM) (QUOTE ENTRYPOINT) (QUOTE "L2895")) (PUT (QUOTE COPYWRDS) (QUOTE ENTRYPOINT) (QUOTE "L1113")) (PUT (QUOTE COPYWRDS) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L3414")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 778)) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE ENTRYPOINT) (QUOTE "L1160")) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L1129")) (PUT (QUOTE CHANNELPRINT) (QUOTE ENTRYPOINT) (QUOTE "L0799")) (PUT (QUOTE CHANNELPRINT) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE IDNUMBER) (QUOTE 549)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE INITIALVALUE) (QUOTE ((".b" . FASLIN) ( ".lap" . LAPIN) (".sl" . LAPIN)))) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE UPDATEITEM) (QUOTE ENTRYPOINT) (QUOTE "L1246")) (PUT (QUOTE SAVESYSTEM) (QUOTE ENTRYPOINT) (QUOTE "L3563")) (PUT (QUOTE SAVESYSTEM) (QUOTE IDNUMBER) (QUOTE 817)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE FEXPRP) (QUOTE ENTRYPOINT) (QUOTE FEXPRP)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2266")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE THROW) (QUOTE ENTRYPOINT) (QUOTE THROW)) (PUT (QUOTE THROW) (QUOTE IDNUMBER) (QUOTE 483)) (PUT (QUOTE FIX) (QUOTE ENTRYPOINT) (QUOTE FIX)) (PUT (QUOTE FIX) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0372")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE TCONC) (QUOTE ENTRYPOINT) (QUOTE TCONC)) (PUT (QUOTE TCONC) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1094")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE !*QUITBREAK) (QUOTE IDNUMBER) (QUOTE 782)) (FLAG (QUOTE (!*QUITBREAK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE CONST) (QUOTE ENTRYPOINT) (QUOTE CONST)) (PUT (QUOTE CONST) (QUOTE IDNUMBER) (QUOTE 716)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 751)) (PUT (QUOTE EGETV) (QUOTE ENTRYPOINT) (QUOTE EGETV)) (PUT (QUOTE EGETV) (QUOTE IDNUMBER) (QUOTE 836)) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L1829")) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE IDNUMBER) (QUOTE 502)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE DS) (QUOTE ENTRYPOINT) (QUOTE DS)) (PUT (QUOTE DS) (QUOTE IDNUMBER) (QUOTE 713)) (PUT (QUOTE WORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE INTERNGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3375")) (PUT (QUOTE INTERNGENSYM) (QUOTE IDNUMBER) (QUOTE 770)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1778")) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 492)) (PUT (QUOTE COMPRESSLIST!*) (QUOTE IDNUMBER) (QUOTE 677)) (FLAG (QUOTE (COMPRESSLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1106")) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2781")) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 578)) (PUT (QUOTE SPECIALWRSACTION!*) (QUOTE IDNUMBER) (QUOTE 600)) (FLAG (QUOTE (SPECIALWRSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE TOPLOOPPRINT!*) (QUOTE IDNUMBER) (QUOTE 789)) (FLAG (QUOTE (TOPLOOPPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODE!-ADDRESS!-TO!-SYMBOL) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE MAPLIST) (QUOTE ENTRYPOINT) (QUOTE "L0724")) (PUT (QUOTE MAPLIST) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1718")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE !*EXPERT) (QUOTE IDNUMBER) (QUOTE 427)) (FLAG (QUOTE (!*EXPERT)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CONC) (QUOTE IDNUMBER) (QUOTE 722)) (PUT (QUOTE CHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2697")) (PUT (QUOTE CHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE PRINTF1) (QUOTE ENTRYPOINT) (QUOTE "L2731")) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE WCONST) (QUOTE 1)) (PUT (QUOTE !*COMP) (QUOTE IDNUMBER) (QUOTE 759)) (FLAG (QUOTE (!*COMP)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1170")) (PUT (QUOTE ABS) (QUOTE ENTRYPOINT) (QUOTE ABS)) (PUT (QUOTE ABS) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1753")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE OTHERWISE) (QUOTE IDNUMBER) (QUOTE 691)) (PUT (QUOTE FASLOUT) (QUOTE ENTRYPOINT) (QUOTE "L2189")) (PUT (QUOTE FASLOUT) (QUOTE IDNUMBER) (QUOTE 570)) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2649")) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE IDNUMBER) (QUOTE 665)) (PUT (QUOTE SUBSEQ) (QUOTE ENTRYPOINT) (QUOTE SUBSEQ)) (PUT (QUOTE SUBSEQ) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE LSHIFT) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSHIFT) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L1726")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L3327")) (PUT (QUOTE MARKFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1166")) (PUT (QUOTE XCHANGE) (QUOTE ENTRYPOINT) (QUOTE "L1587")) (PUT (QUOTE COMPRESSERROR) (QUOTE ENTRYPOINT) (QUOTE "L2796")) (PUT (QUOTE COMPRESSERROR) (QUOTE IDNUMBER) (QUOTE 676)) (PUT (QUOTE READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2208")) (PUT (QUOTE READCHAR) (QUOTE IDNUMBER) (QUOTE 582)) (PUT (QUOTE FLOATDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1386")) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 616)) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UPDATESYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1241")) (PUT (QUOTE GCMESSAGE) (QUOTE ENTRYPOINT) (QUOTE "L1164")) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE CHANNELREADCH) (QUOTE ENTRYPOINT) (QUOTE "L2263")) (PUT (QUOTE CHANNELREADCH) (QUOTE IDNUMBER) (QUOTE 607)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE COPYVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1109")) (PUT (QUOTE COPYVECTOR) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 623)) (FLAG (QUOTE (!$EOF!$)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DELQ) (QUOTE ENTRYPOINT) (QUOTE DELQ)) (PUT (QUOTE DELQ) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1738")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1147")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE CREFON) (QUOTE ENTRYPOINT) (QUOTE CREFON)) (PUT (QUOTE CREFON) (QUOTE IDNUMBER) (QUOTE 567)) (PUT (QUOTE FOR) (QUOTE ENTRYPOINT) (QUOTE FOR)) (PUT (QUOTE FOR) (QUOTE IDNUMBER) (QUOTE 730)) (PUT (QUOTE BIN) (QUOTE IDNUMBER) (QUOTE 734)) (PUT (QUOTE DSKINEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3586")) (PUT (QUOTE DSKINEVAL) (QUOTE IDNUMBER) (QUOTE 821)) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE ENTRYPOINT) (QUOTE "L2267")) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE IDNUMBER) (QUOTE 613)) (PUT (QUOTE INT2CODE) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE INT2CODE) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE BREAK) (QUOTE ENTRYPOINT) (QUOTE BREAK)) (PUT (QUOTE BREAK) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1825")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3434")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 597)) (PUT (QUOTE INTADD1) (QUOTE ENTRYPOINT) (QUOTE "L1470")) (PUT (QUOTE FLAG) (QUOTE ENTRYPOINT) (QUOTE FLAG)) (PUT (QUOTE FLAG) (QUOTE IDNUMBER) (QUOTE 743)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2210")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE IN) (QUOTE IDNUMBER) (QUOTE 723)) (PUT (QUOTE REMOB) (QUOTE ENTRYPOINT) (QUOTE REMOB)) (PUT (QUOTE REMOB) (QUOTE IDNUMBER) (QUOTE 768)) (PUT (QUOTE BREAKFUNCTION) (QUOTE IDNUMBER) (QUOTE 794)) (PUT (QUOTE !*EOLINSTRINGOK) (QUOTE IDNUMBER) (QUOTE 629)) (FLAG (QUOTE (!*EOLINSTRINGOK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3316")) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE MIN2) (QUOTE ENTRYPOINT) (QUOTE MIN2)) (PUT (QUOTE MIN2) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE ASS) (QUOTE ENTRYPOINT) (QUOTE ASS)) (PUT (QUOTE ASS) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE VARTYPE) (QUOTE IDNUMBER) (QUOTE 750)) (PUT (QUOTE HISTPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3545")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2215")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE IDNUMBER) (QUOTE 584)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE ENTRYPOINT) (QUOTE "L2542")) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE FLUID1) (QUOTE ENTRYPOINT) (QUOTE FLUID1)) (PUT (QUOTE FLUID1) (QUOTE IDNUMBER) (QUOTE 752)) (PUT (QUOTE EVDEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L2949")) (PUT (QUOTE EVDEFCONST) (QUOTE IDNUMBER) (QUOTE 715)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CASE) (QUOTE ENTRYPOINT) (QUOTE CASE)) (PUT (QUOTE CASE) (QUOTE IDNUMBER) (QUOTE 693)) (PUT (QUOTE SCANNERERROR) (QUOTE ENTRYPOINT) (QUOTE "L2388")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE ENTRYPOINT) (QUOTE "L1374")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE !*DEFN) (QUOTE IDNUMBER) (QUOTE 780)) (FLAG (QUOTE (!*DEFN)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0404")) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 822)) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0331")) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE STRINGGENSYM!*) (QUOTE IDNUMBER) (QUOTE 718)) (FLAG (QUOTE (STRINGGENSYM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE HELPBREAK) (QUOTE ENTRYPOINT) (QUOTE "L3489")) (PUT (QUOTE HELPBREAK) (QUOTE IDNUMBER) (QUOTE 798)) (PUT (QUOTE UNMAP!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L2047")) (PUT (QUOTE !*CATCH) (QUOTE ENTRYPOINT) (QUOTE "L1979")) (PUT (QUOTE !*CATCH) (QUOTE IDNUMBER) (QUOTE 522)) (PUT (QUOTE EVECINF) (QUOTE IDNUMBER) (QUOTE 839)) (PUT (QUOTE MINUSP) (QUOTE ENTRYPOINT) (QUOTE MINUSP)) (PUT (QUOTE MINUSP) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE BPSSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPSSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BPSSIZE) (QUOTE WCONST) (QUOTE 100000)) (PUT (QUOTE IMPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2798")) (PUT (QUOTE IMPLODE) (QUOTE IDNUMBER) (QUOTE 680)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1741")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE FASTBIND) (QUOTE ENTRYPOINT) (QUOTE "L3277")) (PUT (QUOTE FASTBIND) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1852")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2507")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 648)) (PUT (QUOTE CHECKLINEFIT) (QUOTE ENTRYPOINT) (QUOTE "L2482")) (PUT (QUOTE !%UNCATCH) (QUOTE ENTRYPOINT) (QUOTE "L1986")) (PUT (QUOTE !%UNCATCH) (QUOTE IDNUMBER) (QUOTE 487)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L1750")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE WCONST) (QUOTE 8)) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2535")) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE IDNUMBER) (QUOTE 653)) (PUT (QUOTE HASHFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L3329")) (PUT (QUOTE HASHFUNCTION) (QUOTE IDNUMBER) (QUOTE 767)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1459")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE MAPC) (QUOTE ENTRYPOINT) (QUOTE MAPC)) (PUT (QUOTE MAPC) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1772")) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 490)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE IDNUMBER) (QUOTE 532)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE INITIALVALUE) (QUOTE (DEC20 PDP10 TOPS20 KL10))) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE MAKESTRINGINTOBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2444")) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE IDNUMBER) (QUOTE 802)) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE UPBV) (QUOTE ENTRYPOINT) (QUOTE UPBV)) (PUT (QUOTE UPBV) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE LCONC) (QUOTE ENTRYPOINT) (QUOTE LCONC)) (PUT (QUOTE LCONC) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE EDCOPY) (QUOTE ENTRYPOINT) (QUOTE EDCOPY)) (PUT (QUOTE FLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1507")) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1721")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 528)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE DEL) (QUOTE ENTRYPOINT) (QUOTE DEL)) (PUT (QUOTE DEL) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAKE!-BYTES) (QUOTE ENTRYPOINT) (QUOTE "L0320")) (PUT (QUOTE MAKE!-BYTES) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE FIRST) (QUOTE ENTRYPOINT) (QUOTE FIRST)) (PUT (QUOTE FIRST) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE DATE) (QUOTE ENTRYPOINT) (QUOTE DATE)) (PUT (QUOTE DATE) (QUOTE IDNUMBER) (QUOTE 533)) (PUT (QUOTE SEMIC!*) (QUOTE IDNUMBER) (QUOTE 828)) (FLAG (QUOTE (SEMIC!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DOTCONTEXTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2282")) (PUT (QUOTE SYSPOWEROF2P) (QUOTE ENTRYPOINT) (QUOTE "L2442")) (PUT (QUOTE GCBITLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE GCBITLENGTH) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE GCBITLENGTH) (QUOTE WCONST) (QUOTE 13)) (PUT (QUOTE LOAD1) (QUOTE ENTRYPOINT) (QUOTE LOAD1)) (PUT (QUOTE LOAD1) (QUOTE IDNUMBER) (QUOTE 551)) (PUT (QUOTE LISP2CHAR) (QUOTE ENTRYPOINT) (QUOTE "L0023")) (PUT (QUOTE LISP2CHAR) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE MEM) (QUOTE ENTRYPOINT) (QUOTE MEM)) (PUT (QUOTE MEM) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE EHELP) (QUOTE ENTRYPOINT) (QUOTE EHELP)) (PUT (QUOTE EHELP) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE DOCHAR) (QUOTE ENTRYPOINT) (QUOTE DOCHAR)) (PUT (QUOTE DOCHAR) (QUOTE IDNUMBER) (QUOTE 700)) (PUT (QUOTE EDIT0) (QUOTE ENTRYPOINT) (QUOTE EDIT0)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE MAKEBUFINTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2324")) (PUT (QUOTE INTMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1516")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L3439")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 589)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1747")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE INTERPBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1645")) (PUT (QUOTE INTERPBACKTRACE) (QUOTE IDNUMBER) (QUOTE 450)) (PUT (QUOTE !$ERROR!$) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE INTGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1460")) (PUT (QUOTE UNMAP!-PAGES) (QUOTE ENTRYPOINT) (QUOTE "L2050")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2258")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE IDNUMBER) (QUOTE 604)) (PUT (QUOTE TOPLOOPEVAL!*) (QUOTE IDNUMBER) (QUOTE 786)) (FLAG (QUOTE (TOPLOOPEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE USER) (QUOTE IDNUMBER) (QUOTE 760)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE SCANPOSSIBLEDIPHTHONG) (QUOTE ENTRYPOINT) (QUOTE "L8129")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L3422")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 574)) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE ENTRYPOINT) (QUOTE "L2276")) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE IDNUMBER) (QUOTE 624)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE EXPANDSETF) (QUOTE ENTRYPOINT) (QUOTE "L2847")) (PUT (QUOTE EXPANDSETF) (QUOTE IDNUMBER) (QUOTE 696)) (PUT (QUOTE GO) (QUOTE ENTRYPOINT) (QUOTE GO)) (PUT (QUOTE GO) (QUOTE IDNUMBER) (QUOTE 530)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 601)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L1068")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3430")) (PUT (QUOTE REST) (QUOTE ENTRYPOINT) (QUOTE REST)) (PUT (QUOTE REST) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE SIMP) (QUOTE IDNUMBER) (QUOTE 733)) (PUT (QUOTE INVOKE) (QUOTE ENTRYPOINT) (QUOTE INVOKE)) (PUT (QUOTE INVOKE) (QUOTE IDNUMBER) (QUOTE 565)) (PUT (QUOTE !*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 481)) (FLAG (QUOTE (!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !&!&TAG!&!&) (QUOTE IDNUMBER) (QUOTE 518)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 742)) (PUT (QUOTE TAGSTARTINGBIT) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TAGSTARTINGBIT) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE TAGSTARTINGBIT) (QUOTE WCONST) (QUOTE 0)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE TR) (QUOTE ENTRYPOINT) (QUOTE TR)) (PUT (QUOTE TR) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE UP) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE EMSG!*) (QUOTE IDNUMBER) (QUOTE 472)) (FLAG (QUOTE (EMSG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKE!-VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0351")) (PUT (QUOTE MAKE!-VECTOR) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE CHAR) (QUOTE ENTRYPOINT) (QUOTE CHAR)) (PUT (QUOTE CHAR) (QUOTE IDNUMBER) (QUOTE 699)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE FLATSIZE) (QUOTE ENTRYPOINT) (QUOTE "L2786")) (PUT (QUOTE FLATSIZE) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE PROGBODY!*) (QUOTE IDNUMBER) (QUOTE 525)) (FLAG (QUOTE (PROGBODY!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SPECIALWRITEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 591)) (FLAG (QUOTE (SPECIALWRITEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE READINBUF) (QUOTE ENTRYPOINT) (QUOTE "L2316")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE ENTRYPOINT) (QUOTE "L1966")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE IDNUMBER) (QUOTE 520)) (PUT (QUOTE SUBSTIP1) (QUOTE ENTRYPOINT) (QUOTE "L0860")) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0589")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE INTLXOR) (QUOTE ENTRYPOINT) (QUOTE "L1445")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3061")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 736)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE HISTORYLIST!*) (QUOTE IDNUMBER) (QUOTE 804)) (FLAG (QUOTE (HISTORYLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNIONQ) (QUOTE ENTRYPOINT) (QUOTE UNIONQ)) (PUT (QUOTE UNIONQ) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE MAKESTRINGINTOSYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2327")) (PUT (QUOTE NTH) (QUOTE ENTRYPOINT) (QUOTE NTH)) (PUT (QUOTE NTH) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE PL) (QUOTE IDNUMBER) (QUOTE 443)) (PUT (QUOTE JOIN) (QUOTE IDNUMBER) (QUOTE 721)) (PUT (QUOTE SUBSTIP) (QUOTE ENTRYPOINT) (QUOTE "L0865")) (PUT (QUOTE SUBSTIP) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE TIME) (QUOTE ENTRYPOINT) (QUOTE TIME)) (PUT (QUOTE TIME) (QUOTE IDNUMBER) (QUOTE 806)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 840)) (PUT (QUOTE SPECIALCLOSEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 592)) (FLAG (QUOTE (SPECIALCLOSEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 739)) (PUT (QUOTE STARTUPTIME) (QUOTE ENTRYPOINT) (QUOTE "L2804")) (PUT (QUOTE STARTUPTIME) (QUOTE IDNUMBER) (QUOTE 689)) (PUT (QUOTE INTERSECTIONQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE INTERSECTIONQ) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE !$BREAK!$) (QUOTE IDNUMBER) (QUOTE 792)) (PUT (QUOTE EDITOR) (QUOTE IDNUMBER) (QUOTE 447)) (PUT (QUOTE CHARACTERSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHARACTERSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE CHARACTERSPERWORD) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE FLOATQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1403")) (PUT (QUOTE BREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE BREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1711")) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE MAKEBUFINTOSYSNUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2326")) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L2538")) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE IDNUMBER) (QUOTE 654)) (PUT (QUOTE BINARYOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L2057")) (PUT (QUOTE BINARYOPENREAD) (QUOTE IDNUMBER) (QUOTE 535)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2200")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE META) (QUOTE IDNUMBER) (QUOTE 704)) (PUT (QUOTE INT2SYS) (QUOTE ENTRYPOINT) (QUOTE "L0016")) (PUT (QUOTE INT2SYS) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L3253")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 762)) (PUT (QUOTE ON) (QUOTE ENTRYPOINT) (QUOTE ON)) (PUT (QUOTE ON) (QUOTE IDNUMBER) (QUOTE 710)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1091")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE INTPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1376")) (PUT (QUOTE STACKDIRECTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKDIRECTION) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE STACKDIRECTION) (QUOTE WCONST) (QUOTE 1)) (PUT (QUOTE TIMC) (QUOTE ENTRYPOINT) (QUOTE TIMC)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L3409")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 576)) (PUT (QUOTE INTQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1402")) (PUT (QUOTE PROG2) (QUOTE ENTRYPOINT) (QUOTE PROG2)) (PUT (QUOTE PROG2) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE MK!*SQ) (QUOTE IDNUMBER) (QUOTE 732)) (PUT (QUOTE LIST2SET) (QUOTE ENTRYPOINT) (QUOTE "L1031")) (PUT (QUOTE LIST2SET) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE YES) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE REMPROPL) (QUOTE ENTRYPOINT) (QUOTE "L3146")) (PUT (QUOTE REMPROPL) (QUOTE IDNUMBER) (QUOTE 748)) (PUT (QUOTE FLAG1) (QUOTE ENTRYPOINT) (QUOTE FLAG1)) (PUT (QUOTE FLAG1) (QUOTE IDNUMBER) (QUOTE 744)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3263")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 500)) (PUT (QUOTE !*WRITINGFASLFILE) (QUOTE IDNUMBER) (QUOTE 539)) (PUT (QUOTE DELETIP1) (QUOTE ENTRYPOINT) (QUOTE "L0871")) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1735")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 504)) (PUT (QUOTE OFF) (QUOTE ENTRYPOINT) (QUOTE OFF)) (PUT (QUOTE OFF) (QUOTE IDNUMBER) (QUOTE 711)) (PUT (QUOTE QEDITFNS) (QUOTE IDNUMBER) (QUOTE 426)) (FLAG (QUOTE (QEDITFNS)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1198")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE ENTRYPOINT) (QUOTE "L1022")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE COLLECT) (QUOTE IDNUMBER) (QUOTE 720)) (PUT (QUOTE GLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3172")) (PUT (QUOTE GLOBAL1) (QUOTE IDNUMBER) (QUOTE 754)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 438)) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE ENTRYPOINT) (QUOTE "L2543")) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE IDNUMBER) (QUOTE 655)) (PUT (QUOTE !*INNER!*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 482)) (FLAG (QUOTE (!*INNER!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRING) (QUOTE ENTRYPOINT) (QUOTE "L1101")) (PUT (QUOTE COPYSTRING) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3262")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 524)) (PUT (QUOTE RDTTY) (QUOTE ENTRYPOINT) (QUOTE RDTTY)) (PUT (QUOTE TOTALCOPY) (QUOTE ENTRYPOINT) (QUOTE "L1115")) (PUT (QUOTE TOTALCOPY) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE OPTIONS!*) (QUOTE IDNUMBER) (QUOTE 456)) (FLAG (QUOTE (OPTIONS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L3096")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 510)) (PUT (QUOTE LINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2261")) (PUT (QUOTE LINELENGTH) (QUOTE IDNUMBER) (QUOTE 605)) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE ENTRYPOINT) (QUOTE "M0663")) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE IDNUMBER) (QUOTE 843)) (PUT (QUOTE RANGE) (QUOTE IDNUMBER) (QUOTE 694)) (PUT (QUOTE PUTENTRY) (QUOTE ENTRYPOINT) (QUOTE "L2123")) (PUT (QUOTE PUTENTRY) (QUOTE IDNUMBER) (QUOTE 547)) (PUT (QUOTE BREAKERRMSG) (QUOTE ENTRYPOINT) (QUOTE "L3492")) (PUT (QUOTE BREAKERRMSG) (QUOTE IDNUMBER) (QUOTE 799)) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2509")) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE IDNUMBER) (QUOTE 649)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2785")) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 579)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE INT2ID) (QUOTE ENTRYPOINT) (QUOTE INT2ID)) (PUT (QUOTE INT2ID) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE INTDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1385")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3258")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 499)) (PUT (QUOTE ADDRESSINGUNITSPERITEM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ADDRESSINGUNITSPERITEM) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ADDRESSINGUNITSPERITEM) (QUOTE WCONST) (QUOTE 1)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MAX2) (QUOTE ENTRYPOINT) (QUOTE MAX2)) (PUT (QUOTE MAX2) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE VALUECELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2064")) (PUT (QUOTE VALUECELLLOCATION) (QUOTE IDNUMBER) (QUOTE 538)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE PRINC) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRINC) (QUOTE IDNUMBER) (QUOTE 610)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2202")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE MINI) (QUOTE ENTRYPOINT) (QUOTE MINI)) (PUT (QUOTE MINI) (QUOTE IDNUMBER) (QUOTE 563)) (PUT (QUOTE EXPLODE2) (QUOTE ENTRYPOINT) (QUOTE "L2783")) (PUT (QUOTE EXPLODE2) (QUOTE IDNUMBER) (QUOTE 674)) (PUT (QUOTE !*TIME) (QUOTE IDNUMBER) (QUOTE 805)) (FLAG (QUOTE (!*TIME)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2203")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE PAIR) (QUOTE ENTRYPOINT) (QUOTE PAIR)) (PUT (QUOTE PAIR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE REVERSIP) (QUOTE ENTRYPOINT) (QUOTE "L0855")) (PUT (QUOTE REVERSIP) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2521")) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE IDNUMBER) (QUOTE 651)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2070")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 546)) (PUT (QUOTE LISPBANNER!*) (QUOTE IDNUMBER) (QUOTE 803)) (PUT (QUOTE LISPBANNER!*) (QUOTE INITIALVALUE) (QUOTE "Portable Standard LISP")) (PUT (QUOTE RANGEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1686")) (PUT (QUOTE RANGEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE CHARCONST) (QUOTE IDNUMBER) (QUOTE 706)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE PENDINGLOADS!*) (QUOTE IDNUMBER) (QUOTE 558)) (FLAG (QUOTE (PENDINGLOADS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE QUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1401")) (PUT (QUOTE QUOTIENT) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE SPACES) (QUOTE ENTRYPOINT) (QUOTE SPACES)) (PUT (QUOTE SPACES) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0033")) (PUT (QUOTE UNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3286")) (PUT (QUOTE UNBOUNDP) (QUOTE IDNUMBER) (QUOTE 749)) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L5562")) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE IDNUMBER) (QUOTE 834)) (PUT (QUOTE CATCH) (QUOTE ENTRYPOINT) (QUOTE CATCH)) (PUT (QUOTE CATCH) (QUOTE IDNUMBER) (QUOTE 514)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE IDNUMBER) (QUOTE 639)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE INITIALVALUE) (QUOTE 33)) (PUT (QUOTE CHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1784")) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 489)) (PUT (QUOTE WRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2488")) (PUT (QUOTE WRITESTRING) (QUOTE IDNUMBER) (QUOTE 641)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1156")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE CHANNELREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2206")) (PUT (QUOTE CHANNELREADCHAR) (QUOTE IDNUMBER) (QUOTE 581)) (PUT (QUOTE DELATQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0949")) (PUT (QUOTE SPACES2) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE SPACES2) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3261")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 764)) (PUT (QUOTE ASSOC) (QUOTE ENTRYPOINT) (QUOTE ASSOC)) (PUT (QUOTE ASSOC) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE IMPORTS) (QUOTE ENTRYPOINT) (QUOTE "L2153")) (PUT (QUOTE IMPORTS) (QUOTE IDNUMBER) (QUOTE 559)) (PUT (QUOTE EQN) (QUOTE ENTRYPOINT) (QUOTE EQN)) (PUT (QUOTE EQN) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE DELETIP) (QUOTE ENTRYPOINT) (QUOTE "L0877")) (PUT (QUOTE DELETIP) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE FLOATTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1394")) (PUT (QUOTE REPEAT) (QUOTE ENTRYPOINT) (QUOTE REPEAT)) (PUT (QUOTE REPEAT) (QUOTE IDNUMBER) (QUOTE 729)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE AND) (QUOTE ENTRYPOINT) (QUOTE AND)) (PUT (QUOTE AND) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE EXPLODEENDPOINTER!*) (QUOTE IDNUMBER) (QUOTE 672)) (FLAG (QUOTE (EXPLODEENDPOINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L3065")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 737)) (PUT (QUOTE HEAPSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE HEAPSIZE) (QUOTE WCONST) (QUOTE 90000)) (PUT (QUOTE !&!&THROWN!&!&) (QUOTE IDNUMBER) (QUOTE 516)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2790")) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 575)) (PUT (QUOTE RECIP) (QUOTE ENTRYPOINT) (QUOTE RECIP)) (PUT (QUOTE RECIP) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE DELATQIP) (QUOTE ENTRYPOINT) (QUOTE "L0955")) (PUT (QUOTE DELATQIP) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE SCANPOSSIBLEDIPTHONG) (QUOTE ENTRYPOINT) (QUOTE "L2382")) (PUT (QUOTE READCH) (QUOTE ENTRYPOINT) (QUOTE READCH)) (PUT (QUOTE READCH) (QUOTE IDNUMBER) (QUOTE 609)) (PUT (QUOTE INITFORMS!*) (QUOTE IDNUMBER) (QUOTE 818)) (FLAG (QUOTE (INITFORMS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 753)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L3405")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 776)) (PUT (QUOTE TOPLOOP) (QUOTE ENTRYPOINT) (QUOTE "L3513")) (PUT (QUOTE TOPLOOP) (QUOTE IDNUMBER) (QUOTE 791)) (PUT (QUOTE LITER) (QUOTE ENTRYPOINT) (QUOTE LITER)) (PUT (QUOTE LITER) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE NEXT) (QUOTE ENTRYPOINT) (QUOTE NEXT)) (PUT (QUOTE NEXT) (QUOTE IDNUMBER) (QUOTE 727)) (PUT (QUOTE !$EXITTOPLOOP!$) (QUOTE IDNUMBER) (QUOTE 807)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1145")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE !*NONIL) (QUOTE IDNUMBER) (QUOTE 829)) (FLAG (QUOTE (!*NONIL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNWIND!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1942")) (PUT (QUOTE UNWIND!-ALL) (QUOTE IDNUMBER) (QUOTE 515)) (PUT (QUOTE XINS) (QUOTE ENTRYPOINT) (QUOTE XINS)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L5785")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 830)) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2633")) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE IDNUMBER) (QUOTE 664)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE STACKSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE STACKSIZE) (QUOTE WCONST) (QUOTE 10000)) (PUT (QUOTE DEFLIST) (QUOTE ENTRYPOINT) (QUOTE "L0759")) (PUT (QUOTE DEFLIST) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE CHANNELTYO) (QUOTE ENTRYPOINT) (QUOTE "L2800")) (PUT (QUOTE CHANNELTYO) (QUOTE IDNUMBER) (QUOTE 682)) (PUT (QUOTE CHANNELREADLINE) (QUOTE ENTRYPOINT) (QUOTE "L2476")) (PUT (QUOTE CHANNELREADLINE) (QUOTE IDNUMBER) (QUOTE 637)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1837")) (PUT (QUOTE SUB) (QUOTE ENTRYPOINT) (QUOTE SUB)) (PUT (QUOTE SUB) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1818")) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CHANNELSPACES2) (QUOTE ENTRYPOINT) (QUOTE "L1027")) (PUT (QUOTE CHANNELSPACES2) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE BREAKIN!*) (QUOTE IDNUMBER) (QUOTE 783)) (FLAG (QUOTE (BREAKIN!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L2204")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE VECTOR2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0049")) (PUT (QUOTE VECTOR2STRING) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE CHANNELREADEOF) (QUOTE ENTRYPOINT) (QUOTE "L2273")) (PUT (QUOTE CHANNELREADEOF) (QUOTE IDNUMBER) (QUOTE 622)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1083")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE FIXP) (QUOTE ENTRYPOINT) (QUOTE FIXP)) (PUT (QUOTE FIXP) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE ADJOIN) (QUOTE ENTRYPOINT) (QUOTE ADJOIN)) (PUT (QUOTE ADJOIN) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2279")) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE IDNUMBER) (QUOTE 625)) (PUT (QUOTE EXPAND) (QUOTE ENTRYPOINT) (QUOTE EXPAND)) (PUT (QUOTE EXPAND) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE HALFWORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0455")) (PUT (QUOTE MAKEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L1369")) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0309")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE CHANNELTERPRI) (QUOTE ENTRYPOINT) (QUOTE "L2265")) (PUT (QUOTE CHANNELTERPRI) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE LASTCAR) (QUOTE ENTRYPOINT) (QUOTE "L0973")) (PUT (QUOTE LASTCAR) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE INTERNP) (QUOTE ENTRYPOINT) (QUOTE "L3361")) (PUT (QUOTE INTERNP) (QUOTE IDNUMBER) (QUOTE 769)) (PUT (QUOTE UPDATEALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1161")) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0612")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE CONTROL) (QUOTE IDNUMBER) (QUOTE 702)) (PUT (QUOTE !*BREAK) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE !*BREAK) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE THROWTAG!*) (QUOTE IDNUMBER) (QUOTE 512)) (FLAG (QUOTE (THROWTAG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EXPT) (QUOTE ENTRYPOINT) (QUOTE EXPT)) (PUT (QUOTE EXPT) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE EVOR) (QUOTE ENTRYPOINT) (QUOTE EVOR)) (PUT (QUOTE EVOR) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE MAPCAN) (QUOTE ENTRYPOINT) (QUOTE MAPCAN)) (PUT (QUOTE MAPCAN) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE LAND) (QUOTE ENTRYPOINT) (QUOTE LAND)) (PUT (QUOTE LAND) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE LSH) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSH) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE COMPILETIME) (QUOTE ENTRYPOINT) (QUOTE "L2802")) (PUT (QUOTE COMPILETIME) (QUOTE IDNUMBER) (QUOTE 686)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE PAGEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE PAGEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L4410")) (PUT (QUOTE PAGEPOSITION) (QUOTE WARRAY) (QUOTE PAGEPOSITION)) (PUT (QUOTE STEP) (QUOTE ENTRYPOINT) (QUOTE STEP)) (PUT (QUOTE STEP) (QUOTE IDNUMBER) (QUOTE 562)) (PUT (QUOTE DEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L2945")) (PUT (QUOTE DEFCONST) (QUOTE IDNUMBER) (QUOTE 714)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 508)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 634)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1384")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE BPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPS) (QUOTE ASMSYMBOL) (QUOTE BPS)) (PUT (QUOTE BPS) (QUOTE WARRAY) (QUOTE BPS)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2214")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1756")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE EQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0426")) (PUT (QUOTE EQUAL) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 630)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2201")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE ENTRYPOINT) (QUOTE "L1991")) (PUT (QUOTE NO) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE INTLAND) (QUOTE ENTRYPOINT) (QUOTE "L1432")) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE MAKEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3291")) (PUT (QUOTE MAKEUNBOUND) (QUOTE IDNUMBER) (QUOTE 766)) (PUT (QUOTE RPLACEALL) (QUOTE ENTRYPOINT) (QUOTE "L1588")) (PUT (QUOTE READONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1775")) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 491)) (PUT (QUOTE CATCHSETUPAUX) (QUOTE ENTRYPOINT) (QUOTE "L1984")) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE INTHISCASE) (QUOTE ENTRYPOINT) (QUOTE "L2830")) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE BREAKEVAL!*) (QUOTE IDNUMBER) (QUOTE 787)) (FLAG (QUOTE (BREAKEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COMMENTOUTCODE) (QUOTE ENTRYPOINT) (QUOTE "L2801")) (PUT (QUOTE COMMENTOUTCODE) (QUOTE IDNUMBER) (QUOTE 685)) (PUT (QUOTE HEAP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAP) (QUOTE ASMSYMBOL) (QUOTE HEAP)) (PUT (QUOTE HEAP) (QUOTE WARRAY) (QUOTE HEAP)) (PUT (QUOTE COPYWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1102")) (PUT (QUOTE COPYWARRAY) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE INTTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1393")) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LIST2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0075")) (PUT (QUOTE LIST2VECTOR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE SUBST) (QUOTE ENTRYPOINT) (QUOTE SUBST)) (PUT (QUOTE SUBST) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE DECLAREFLUIDORGLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3155")) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L3267")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 503)) (PUT (QUOTE BREAKRETRY) (QUOTE ENTRYPOINT) (QUOTE "L3484")) (PUT (QUOTE BREAKRETRY) (QUOTE IDNUMBER) (QUOTE 797)) (PUT (QUOTE !*COMPRESSING) (QUOTE IDNUMBER) (QUOTE 628)) (FLAG (QUOTE (!*COMPRESSING)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE XN) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE XN) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE LOR) (QUOTE ENTRYPOINT) (QUOTE LOR)) (PUT (QUOTE LOR) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L1729")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0781")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE WRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2727")) (PUT (QUOTE WRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 647)) (PUT (QUOTE ONOFF!*) (QUOTE ENTRYPOINT) (QUOTE "L2880")) (PUT (QUOTE ONOFF!*) (QUOTE IDNUMBER) (QUOTE 707)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L3050")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 735)) (PUT (QUOTE FLATSIZE2) (QUOTE ENTRYPOINT) (QUOTE "L2787")) (PUT (QUOTE FLATSIZE2) (QUOTE IDNUMBER) (QUOTE 675)) (PUT (QUOTE PROGJUMPTABLE!*) (QUOTE IDNUMBER) (QUOTE 526)) (FLAG (QUOTE (PROGJUMPTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE NONINTEGER1ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1345")) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1153")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0798")) (PUT (QUOTE FUNCTION) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE NUMBERP) (QUOTE ENTRYPOINT) (QUOTE "L0619")) (PUT (QUOTE NUMBERP) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE TOPLOOPREAD!*) (QUOTE IDNUMBER) (QUOTE 790)) (FLAG (QUOTE (TOPLOOPREAD!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKCONTINUE) (QUOTE ENTRYPOINT) (QUOTE "L3480")) (PUT (QUOTE BREAKCONTINUE) (QUOTE IDNUMBER) (QUOTE 796)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE WCONST) (QUOTE 18)) (PUT (QUOTE CONCAT) (QUOTE ENTRYPOINT) (QUOTE CONCAT)) (PUT (QUOTE CONCAT) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE SETMACROREFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L2907")) (PUT (QUOTE !*SEMICOL!*) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE INTONEP) (QUOTE ENTRYPOINT) (QUOTE "L1525")) (PUT (QUOTE COPY) (QUOTE ENTRYPOINT) (QUOTE COPY)) (PUT (QUOTE COPY) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE EDITF) (QUOTE ENTRYPOINT) (QUOTE EDITF)) (PUT (QUOTE EDITF) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1732")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE CHANNELEJECT) (QUOTE ENTRYPOINT) (QUOTE "L2253")) (PUT (QUOTE CHANNELEJECT) (QUOTE IDNUMBER) (QUOTE 602)) (PUT (QUOTE SUBLA) (QUOTE ENTRYPOINT) (QUOTE SUBLA)) (PUT (QUOTE SUBLA) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 599)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE FASTUNBIND) (QUOTE ENTRYPOINT) (QUOTE "L3280")) (PUT (QUOTE FASTUNBIND) (QUOTE IDNUMBER) (QUOTE 437)) (PUT (QUOTE RASSOC) (QUOTE ENTRYPOINT) (QUOTE RASSOC)) (PUT (QUOTE RASSOC) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE STATICINTFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L1337")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE ENTRYPOINT) (QUOTE "L3560")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE IDNUMBER) (QUOTE 816)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 594)) (PUT (QUOTE EVLOAD) (QUOTE ENTRYPOINT) (QUOTE EVLOAD)) (PUT (QUOTE EVLOAD) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE CATCH!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1930")) (PUT (QUOTE CATCH!-ALL) (QUOTE IDNUMBER) (QUOTE 513)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE ENTRYPOINT) (QUOTE "L1769")) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 488)) (PUT (QUOTE SETINDX) (QUOTE ENTRYPOINT) (QUOTE "L0136")) (PUT (QUOTE SETINDX) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L3450")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 588)) (PUT (QUOTE ADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3312")) (PUT (QUOTE ADJOINQ) (QUOTE ENTRYPOINT) (QUOTE "L1043")) (PUT (QUOTE ADJOINQ) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE MAKEBUFINTOFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2333")) (PUT (QUOTE CATCHSETUP) (QUOTE ENTRYPOINT) (QUOTE "L1983")) (PUT (QUOTE CATCHSETUP) (QUOTE IDNUMBER) (QUOTE 485)) (PUT (QUOTE BREAKQUIT) (QUOTE ENTRYPOINT) (QUOTE "L3479")) (PUT (QUOTE BREAKQUIT) (QUOTE IDNUMBER) (QUOTE 795)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L3446")) (PUT (QUOTE GENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3370")) (PUT (QUOTE FORMATFORPRINTF!*) (QUOTE IDNUMBER) (QUOTE 668)) (FLAG (QUOTE (FORMATFORPRINTF!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DIGITTONUMBER) (QUOTE ENTRYPOINT) (QUOTE "L4619")) (PUT (QUOTE DIGITTONUMBER) (QUOTE IDNUMBER) (QUOTE 826)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 506)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L3071")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 738)) (PUT (QUOTE GLOBALINSTALL) (QUOTE ENTRYPOINT) (QUOTE "L3393")) (PUT (QUOTE GLOBALINSTALL) (QUOTE IDNUMBER) (QUOTE 773)) (PUT (QUOTE CHANNELPRIN) (QUOTE IDNUMBER) (QUOTE 833)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE DISPLAYHELPFILE) (QUOTE IDNUMBER) (QUOTE 446)) (PUT (QUOTE !$LOOP!$) (QUOTE IDNUMBER) (QUOTE 726)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L3175")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 755)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1146")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2440")) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE IDNUMBER) (QUOTE 631)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L2041")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 586)) (PUT (QUOTE CNTRL) (QUOTE IDNUMBER) (QUOTE 701)) (PUT (QUOTE UPDATEHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1247")) (PUT (QUOTE RETURN) (QUOTE ENTRYPOINT) (QUOTE RETURN)) (PUT (QUOTE RETURN) (QUOTE IDNUMBER) (QUOTE 531)) (PUT (QUOTE BINARYOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L2062")) (PUT (QUOTE BINARYOPENWRITE) (QUOTE IDNUMBER) (QUOTE 537)) (PUT (QUOTE ONEARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1347")) (PUT (QUOTE INTLOR) (QUOTE ENTRYPOINT) (QUOTE INTLOR)) (PUT (QUOTE ONEARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1356")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1159")) (PUT (QUOTE CHANNELPRINC) (QUOTE ENTRYPOINT) (QUOTE "L2266")) (PUT (QUOTE CHANNELPRINC) (QUOTE IDNUMBER) (QUOTE 611)) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2707")) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 661)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE REMFLAG1) (QUOTE ENTRYPOINT) (QUOTE "L3129")) (PUT (QUOTE REMFLAG1) (QUOTE IDNUMBER) (QUOTE 746)) (PUT (QUOTE !*CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 471)) (FLAG (QUOTE (!*CONTINUABLEERROR)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE VECTOREQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0443")) (PUT (QUOTE INTERSECTION) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE INTERSECTION) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE ENTRYPOINT) (QUOTE "L2481")) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE IDNUMBER) (QUOTE 620)) (PUT (QUOTE EVAND1) (QUOTE ENTRYPOINT) (QUOTE EVAND1)) (PUT (QUOTE RPLACW) (QUOTE ENTRYPOINT) (QUOTE RPLACW)) (PUT (QUOTE RPLACW) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE FINDFIRST) (QUOTE ENTRYPOINT) (QUOTE "L1590")) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L3444")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 536)) (PUT (QUOTE MKEVECT) (QUOTE IDNUMBER) (QUOTE 842)) (PUT (QUOTE COMPACTHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1162")) (PUT (QUOTE CHANNELWRITEBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2496")) (PUT (QUOTE QUIT) (QUOTE ENTRYPOINT) (QUOTE QUIT)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE TRST) (QUOTE ENTRYPOINT) (QUOTE TRST)) (PUT (QUOTE TRST) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE FILEP) (QUOTE ENTRYPOINT) (QUOTE FILEP)) (PUT (QUOTE FILEP) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE FLOATPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1377")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2506")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE IDNUMBER) (QUOTE 646)) (PUT (QUOTE !#ARG) (QUOTE IDNUMBER) (QUOTE 712)) (PUT (QUOTE MAP2) (QUOTE ENTRYPOINT) (QUOTE MAP2)) (PUT (QUOTE MAP2) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE EDIT) (QUOTE ENTRYPOINT) (QUOTE EDIT)) (PUT (QUOTE EDIT) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE STRING) (QUOTE ENTRYPOINT) (QUOTE STRING)) (PUT (QUOTE STRING) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2680")) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 659)) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE ENTRYPOINT) (QUOTE "L1174")) (PUT (QUOTE OK) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE POSN) (QUOTE ENTRYPOINT) (QUOTE POSN)) (PUT (QUOTE POSN) (QUOTE IDNUMBER) (QUOTE 606)) |
Added psl-1983/20-kernel/prop.ctl version [0ac3eb7796].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "prop"; in "prop.build"; ASMEnd; quit; compile prop.mac, dprop.mac delete prop.mac, dprop.mac |
Added psl-1983/20-kernel/prop.init version [8caa9913cb].
> > | 1 2 | (FLUID (QUOTE (!*REDEFMSG !*USERMODE))) (FLUID (QUOTE (!*COMP PROMPTSTRING!*))) |
Added psl-1983/20-kernel/prop.log version [67f921b3b4].
cannot compute difference between binary files
Added psl-1983/20-kernel/prop.rel version [bb9cae38db].
cannot compute difference between binary files
Added psl-1983/20-kernel/psl-link.ctl version [a343e33f60].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | cd S: define DSK:, DSK:, P20: LINK /nosymbol p20:nil.rel /set:.low.:202 p20:types.rel p20:randm.rel p20:alloc.rel p20:arith.rel p20:debg.rel p20:error.rel p20:eval.rel p20:extra.rel p20:fasl.rel p20:io.rel p20:macro.rel p20:prop.rel p20:symbl.rel p20:sysio.rel p20:tloop.rel p20:main.rel p20:heap.rel p20:dtypes.rel p20:drandm.rel p20:dalloc.rel p20:darith.rel p20:ddebg.rel p20:derror.rel p20:deval.rel p20:dextra.rel p20:dfasl.rel p20:dio.rel p20:dmacro.rel p20:dprop.rel p20:dsymbl.rel p20:dsysio.rel p20:dtloop.rel p20:dmain.rel p20:dheap.rel /save s:bpsl.exe /go |
Added psl-1983/20-kernel/psl-link.log version [351390dad3].
cannot compute difference between binary files
Added psl-1983/20-kernel/psl.init version [d06c73fc9e].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | (lapin "types.init") (lapin "randm.init") (lapin "alloc.init") (lapin "arith.init") (lapin "debg.init") (lapin "error.init") (lapin "eval.init") (lapin "extra.init") (lapin "fasl.init") (lapin "io.init") (lapin "macro.init") (lapin "prop.init") (lapin "symbl.init") (lapin "sysio.init") (lapin "tloop.init") (lapin "main.init") (lapin "heap.init") |
Added psl-1983/20-kernel/randm.ctl version [e523fe7e1c].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "randm"; in "randm.build"; ASMEnd; quit; compile randm.mac, drandm.mac delete randm.mac, drandm.mac |
Added psl-1983/20-kernel/randm.init version [d73c12c5d1].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | (PUT (QUOTE LIST) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DE) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DF) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DM) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DN) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE SETQ) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE AND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE OR) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE COND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE MAX) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE MIN) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE PLUS) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE TIMES) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE FUNCTION) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE FIRST) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE SECOND) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE THIRD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE FOURTH) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE REST) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/20-kernel/randm.log version [7f611f3a62].
cannot compute difference between binary files
Added psl-1983/20-kernel/randm.rel version [73b1186515].
cannot compute difference between binary files
Added psl-1983/20-kernel/scan-table.red version [ae5195dc73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SCAN-TABLE.RED - Lisp character table for DEC-20 % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 November 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>SCAN-TABLE.RED.6, 10-Feb-83 16:12:38, Edit by PERDUE % Changed the "put EOF" to be a STARTUPTIME form % Edit by Cris Perdue, 28 Jan 1983 2039-PST % LispDipthong -> LispDiphthong fluid '(LispScanTable!* CurrentScanTable!*); LispScanTable!* := ' [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LispDiphthong]; CurrentScanTable!* := LispScanTable!*; % Done as "startuptime" because "char" is available at compile % time but not necessarily init time /csp startuptime put('EOF, 'CharConst, char cntrl Z); END; |
Added psl-1983/20-kernel/symbl.ctl version [e72f4dcc57].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "symbl"; in "symbl.build"; ASMEnd; quit; compile symbl.mac, dsymbl.mac delete symbl.mac, dsymbl.mac |
Added psl-1983/20-kernel/symbl.init version [a7ffc6f8bf].
Added psl-1983/20-kernel/symbl.log version [3bd068a435].
cannot compute difference between binary files
Added psl-1983/20-kernel/symbl.rel version [42c01c8e75].
cannot compute difference between binary files
Added psl-1983/20-kernel/sysio.ctl version [4123b5bef1].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "sysio"; in "sysio.build"; ASMEnd; quit; compile sysio.mac, dsysio.mac delete sysio.mac, dsysio.mac |
Added psl-1983/20-kernel/sysio.init version [8719f1db79].
> > > | 1 2 3 | (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!* ERROUT!* !*ECHO))) (FLUID (QUOTE (LISPSCANTABLE!* CURRENTSCANTABLE!*))) |
Added psl-1983/20-kernel/sysio.log version [1d97a666d2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 16:19:52 BATCON Version 104(4133) GLXLIB Version 1(527) Job SYSIO Req #267 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 805 Input from => PS:<PSL.KERNEL.20>SYSIO.CTL.2 Output to => PS:<PSL.KERNEL.20>SYSIO.LOG 16:19:53 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 16:19:53 MONTR @SET TIME-LIMIT 1200 16:19:54 MONTR @LOGIN KESSLER SMALL 16:19:57 MONTR Job 13 on TTY225 7-Mar-83 16:19:56 16:19:57 MONTR Previous login at 7-Mar-83 16:16:23 16:19:57 MONTR There is 1 other job logged in as user KESSLER 16:20:06 MONTR @ 16:20:06 MONTR [PS Mounted] 16:20:06 MONTR 16:20:06 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 16:20:06 MONTR define DSK: DSK:, P20:, PI: 16:20:08 MONTR @S:DEC20-CROSS.EXE 16:20:09 USER Dec 20 cross compiler 16:20:10 USER [8] ASMOut "sysio"; 16:20:11 USER ASMOUT: IN files; or type in expressions 16:20:11 USER When all done execute ASMEND; 16:21:12 USER [9] in "sysio.build"; 16:21:13 USER % 16:21:13 USER % SYSIO.BUILD - Files for system-dependent input and output 16:21:13 USER % 16:21:13 USER % Author: Eric Benson 16:21:13 USER % Symbolic Computation Group 16:21:13 USER % Computer Science Dept. 16:21:13 USER % University of Utah 16:21:13 USER % Date: 19 May 1982 16:21:14 USER % Copyright (c) 1982 University of Utah 16:21:14 USER % 16:21:14 USER 16:21:14 USER PathIn "system-io.red"$ % system dependent IO functions 16:21:28 USER PathIn "scan-table.red"$ 16:21:29 USER *** GLOBAL `LISPSCANTABLE!*' cannot become FLUID 16:21:31 USER % change scan table for system 16:21:31 USER [10] ASMEnd; 16:22:00 USER *** Garbage collection starting 16:22:16 USER *** GC 4: time 3296 ms 16:22:16 USER *** 72563 recovered, 564 stable, 16873 active, 72563 free 16:22:44 USER NIL 16:22:44 USER [11] quit; 16:22:46 MONTR @compile sysio.mac, dsysio.mac 16:22:51 USER MACRO: .MAIN 16:23:03 USER MACRO: .MAIN 16:23:04 USER 16:23:04 USER EXIT 16:23:07 MONTR @delete sysio.mac, dsysio.mac 16:23:08 MONTR SYSIO.MAC.1 [OK] 16:23:08 MONTR DSYSIO.MAC.1 [OK] 16:23:08 MONTR @ 16:23:11 MONTR Killed by OPERATOR, TTY 221 16:23:11 MONTR Killed Job 13, User KESSLER, Account SMALL, TTY 225, 16:23:11 MONTR at 7-Mar-83 16:23:13, Used 0:01:12 in 0:03:17 |
Added psl-1983/20-kernel/sysio.rel version [691cc1fa3b].
cannot compute difference between binary files
Added psl-1983/20-kernel/system-extras.red version [1de65c78d7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-EXTRAS.RED - System-specific functions for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 4 March 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL-20>SYSTEM-EXTRAS.RED.3, 5-Jan-83 16:46:34, Edit by PERDUE % Added ExitLISP, for the DEC-20 a synonym of QUIT fluid '(system_list!*); if_system(Tenex, if_system(KL10, system_list!* := '(Dec20 PDP10 Tenex KL10), system_list!* := '(Dec20 PDP10 Tenex)), system_list!* := '(Dec20 PDP10 Tops20 KL10)); lap '((!*entry Quit expr 0) (haltf) (!*MOVE '"Continued" (reg 1)) (!*EXIT 0) ); CopyD('ExitLISP, 'Quit); lap '((!*entry Date expr 0) (!*MOVE (WConst 8) (reg 1)) % allocate a 9 character string (!*CALL GtStr) (!*MOVE (reg 1) (reg 4)) % save it in 4 (!*WPLUS2 (reg 1) (WConst 1)) (hrli 1 8#440700) % create a byte pointer to it (!*MOVE (WConst -1) (reg 2)) % current date (hrlzi (reg 3) 2#0000000001) % ot%ntm, don't output time (odtim) (!*MOVE (reg 4) (reg 1)) (!*MKITEM (reg 1) (WConst STR)) % tag it as a string (!*EXIT 0) ); if_system(KL10, NIL, lap '((!*Entry StackOverflow expr 0) (sub (reg ST) (lit (halfword 1000 1000))) % back up stack (!*MOVE '"Stack overflow" (reg 1)) (!*JCALL StdError) )); on SysLisp; syslsp procedure ReturnAddressP X; begin scalar Y, Z; Z := SymFnc; return Field(X, 0, 18) = 2#011001000000000000 % PC flags and Field(@(X - 1), 0, 18) = 8#260740 % pushj 17, and (Y := Field(@(X - 1), 18, 18) - Z) > 0 and Y < MaxSymbols and MkID Y; end; off SysLisp; END; |
Added psl-1983/20-kernel/system-faslin.red version [94a9e89322].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-FASLIN.RED - Functions needed by faslin % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL-20>SYSTEM-FASLIN.RED.4, 7-Oct-82 13:37:56, Edit by BENSON % Changed 0 byte size to 36 byte size, for Tenex compatibility on Syslisp; syslsp procedure BinaryOpenRead FileName; begin scalar F; F := Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 36*of%bsz of%rd 2#100100000000000000010000000000000000); return if F eq 0 then ContError(99, "Couldn't open binary file for input", BinaryOpenRead FileName) else F; end; syslsp procedure BinaryOpenWrite FileName; begin scalar F; F := Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 36*of%bsz of%wr 2#100100000000000000001000000000000000); return if F eq 0 then ContError(99, "Couldn't open binary file for output", BinaryOpenWrite FileName) else F; end; syslsp procedure ValueCellLocation X; if not LispVar !*WritingFaslFile then &SymVal IDInf X else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_VALUE_CELL, FindIDNumber X) >>; syslsp procedure ExtraRegLocation X; << X := second X; if not LispVar !*WritingFaslFile then &ArgumentBlock[X - (MaxRealRegs + 1)] else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_VALUE_CELL, X + 8150) >> >>; syslsp procedure FunctionCellLocation X; if not LispVar !*WritingFaslFile then &SymFnc IDInf X else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_FUNCTION_CELL, FindIDNumber X) >>; off SysLisp; END; |
Added psl-1983/20-kernel/system-faslout.red version [636466d8a5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-FASLOUT.RED - 20-specific stuff for FASL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 February 1982 % Copyright (c) 1982 University of Utah % CompileTime DefConst(AddressingUnitsPerItem, 1, BitTableEntriesPerWord, 18, FASL_MAGIC_NUMBER, 99, RELOC_ID_NUMBER, 1, RELOC_VALUE_CELL, 2, RELOC_FUNCTION_CELL, 3, RELOC_WORD, 1, RELOC_HALFWORD, 2, RELOC_INF, 3); on SysLisp; CompileTime << smacro procedure RelocRightHalfTag X; Field(X, 18, 2); smacro procedure RelocRightHalfInf X; Field(X, 20, 16); smacro procedure RelocInfTag X; Field(X, 18, 2); smacro procedure RelocInfInf X; Field(X, 20, 16); smacro procedure RelocWordTag X; Field(X, 0, 2); smacro procedure RelocWordInf X; Field(X, 2, 34); smacro procedure PutRightHalf(Where, What); PutField(Where, 18, 18, What); put('RightHalf, 'Assign!-Op, 'PutRightHalf); >>; CompileTime DefList('((BinaryWrite ((bout))) (BinaryRead ((bin) (move (reg 1) (reg 2)))) (BinaryClose ((closf) (jfcl))) (BinaryWriteBlock ((hrli (reg 2) 8#444400) % point 36, (movns (reg 3)) (sout))) (BinaryReadBlock ((hrli (reg 2) 8#444400) % point 36, (movns (reg 3)) (sin)))), 'OpenCode); off Syslisp; END; |
Added psl-1983/20-kernel/system-gc.red version [f169e899f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-GC.RED - System dependent before and after GC hooks % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 March 1982 % Copyright (c) 1982 University of Utah % % Do nothing on the Dec-20 on Syslisp; CompileTime << syslsp smacro procedure BeforeGCSystemHook(); NIL; syslsp smacro procedure AfterGCSystemHook(); NIL; >>; off Syslisp; END; |
Added psl-1983/20-kernel/system-io.red version [8f8022ebca].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-IO.RED - System dependent IO routines for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 September 1981 % Copyright (c) 1981 University of Utah % global '(IN!* OUT!*); LoadTime << IN!* := 0; OUT!* := 1; >>; fluid '(StdIN!* StdOUT!* ErrOUT!* !*Echo); LoadTime << StdIN!* := 0; StdOUT!* := 1; ErrOUT!* := 1; >>; CompileTime flag('(RDTTY FindFreeChannel Dec20Open ContOpenError ClearIO1), 'InternalFunction); on SysLisp; external WArray JFNOfChannel, ReadFunction, WriteFunction, CLoseFunction; if_system(Tops20, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); if_system(Tenex, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (cain (reg 2) (WConst 8#37)) % TENEX EOL (!*MOVE (WConst 8#12) (reg 2)) % replace it with a linefeed (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); lap '((!*entry Dec20WriteChar expr 2) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) % get JFN for channel (!*JUMPEQ (Label CRLF) (reg 2) (WConst 8#12)) % if LF, echo CRLF (bout) % no, just echo char (!*EXIT 0) % return CRLF (!*MOVE (WConst 8#15) (reg 2)) % write carriage-return (bout) (!*MOVE (WConst 8#12) (reg 2)) % write linefeed (bout) (!*EXIT 0) % return ); internal WConst MaxTerminalBuffer = 200; internal WVar NextTerminalChar = 1; internal WString TerminalInputBuffer[MaxTerminalBuffer]; lap '((!*entry ClearIO1 expr 0) % % ^C from RDTTY and restart causes trouble, but we don't want a full RESET % (don't want to close files or kill forks), so we'll just do the % part of RESET that we want, for terminal input % (!*MOVE (WConst 8#100) (reg 1)) % .priin (rfmod) (tro 2 2#001111100001000000) % tt%wak + tt%eco + .ttasi, like RESET (sfmod) (!*EXIT 0) ); syslsp procedure ClearIO(); << ClearIO1(); TerminalInputBuffer[0] := -1; NextTerminalChar := 0; LispVar IN!* := LispVar STDIN!*; LispVar OUT!* := LispVar STDOUT!* >>; if_system(Tops20, lap '((!*entry RDTTY expr 3) (dmove (reg t1) (reg 1)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (dmove (reg 1) (reg t1)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (hrli (reg 1) 8#440700) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (hrli (reg 3) 8#440700) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf (jsys 8#523) % RDTTY (!*JUMP (Label CantRDTTY)) (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) CantRDTTY (!*MOVE (QUOTE "Can't read from terminal") (reg 1)) (!*JCALL IOError) )); if_system(Tenex, lap '((!*entry RDTTY expr 3) (move (reg t1) (reg 1)) (move (reg t2) (reg 2)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (move (reg 1) (reg t1)) (move (reg 2) (reg t2)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (hrli (reg 1) 8#440700) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (hrli (reg 3) 8#440700) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) % (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf % (jsys 8#523) % RDTTY % (!*JUMP (Label CantRDTTY)) (!*MOVE (WConst MaxTerminalBuffer) (reg 2)) % # of chars (setz 3 0) % clear 3 (jsys 8#611) % PSTIN, IMSSS JSYS (!*MOVE (WConst 8#12) (reg 3)) % put linefeed at end of buffer (dpb (reg 3) (reg 1)) % 1 points to end of what's been read (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) )); syslsp procedure TerminalInputHandler Chn; begin scalar Ch; while NextTerminalChar >= StrLen TerminalInputBuffer do << NextTerminalChar := 0; TerminalInputBuffer[0] := RDTTY(TerminalInputBuffer, MaxTerminalBuffer, if StringP LispVar PromptString!* then LispVar PromptString!* else ">") >>; Ch := StrByt(TerminalInputBuffer, NextTerminalChar); NextTerminalChar := NextTerminalChar + 1; return Ch; end; syslsp procedure FindFreeChannel(); begin scalar Chn; Chn := 0; while JfnOfChannel[Chn] neq 0 do << if Chn >= MaxChannels then IOError("No free channels left"); Chn := Chn + 1 >>; return Chn; end; syslsp procedure SystemMarkAsClosedChannel FileDes; JFNOfChannel[IntInf FileDes] := 0; lap '((!*entry Dec20CloseChannel expr 1) (!*MOVE (reg 1) (reg 2)) % save in case of error (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) (closf) (!*JUMP (Label CloseError)) (!*EXIT 0) CloseError (!*MOVE (QUOTE "Channel could not be closed") (reg 1)) (!*JCALL ChannelError) ); syslsp procedure SystemOpenFileSpecial FileName; << JFNOfChannel[FileName := FindFreeChannel()] := -1; FileName >>; syslsp procedure SystemOpenFileForInput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 7*of%bsz of%rd 2#000111000000000000010000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'INPUT); JFNOfChannel[Chn] := JFN; ReadFunction[Chn] := 'Dec20ReadChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; syslsp procedure SystemOpenFileForOutput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 7*of%bsz of%wr 2#000111000000000000001000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'OUTPUT); JFNOfChannel[Chn] := JFN; WriteFunction[Chn] := 'Dec20WriteChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; lap '((!*entry Dec20Open expr 3) % % Dec20Open(Filename string, GTJFN bits, OPENF bits) % (!*WPLUS2 (reg 1) (WConst 1)) % increment r1 to point to characters (hrli (reg 1) 8#440700) % turn r1 into a byte pointer (!*MOVE (reg 1) (reg 4)) % save filename string in r4 (!*MOVE (reg 2) (reg 1)) % GTJFN flag bits in r1 (!*MOVE (reg 4) (reg 2)) % string in r2 (gtjfn) (!*JUMP (Label CantOpen)) (!*MOVE (reg 3) (reg 2)) % OPENF bits in r2, JFN in r1 (openf) CantOpen (!*MOVE (WConst 0) (reg 1)) % return 0 on error (!*EXIT 0) % else return the JFN ); off SysLisp; lisp procedure ContOpenError(FileName, AccessMode); ContinuableError(99, BldMsg("`%s' cannot be open for %w", FileName, AccessMode), list('OPEN, MkSTR FileName, MkQuote AccessMode)); END; |
Added psl-1983/20-kernel/tags.fai version [5f1506948c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;MRC:<EMACS>TAGS.FAI.49, 10-Sep-81 12:22:29, Edit by ADMIN.JQJ ;add dummy SCRIBE routine. title tags search monsym subttl Definitions ifndef tnxsw,< ife .osfail-<sixbit /TENEX/>,< tnxsw __ -1>> ifndef tnxsw,< tnxsw __ 0> t20sw __ tnxsw define tnx <ifn tnxsw> define t20 <ifn t20sw> tnx,< prints \TENEX version. \ opdef pstin [jsys 611] > t20,< prints \TOPS-20 version. \> f_0 ; Flags t_7 ; Temp u_10 ; Temp s_11 ; String and temp s1_12 ; Second part for string n_13 ; Counter of functions found ch_14 ; Character l_15 ; Language type bp_16 ; Byte pointer p_17 ; Guess ; LH flags f%f1 __ 400000 ; Temp flags f%f2 __ 200000 ; RH flags f%oldf __ 400000 ; Using old tags file, not making one f%eoff __ 200000 ; EOF seen on old file f%lgvn __ 100000 ; Language specified by user with / opdef call [pushj p, 0] opdef ret [popj p, 0] opdef uerr [1b8] define error (x) < uerr [asciz /x/] > loc 41 call uuoh reloc subttl Impure storage tagjfb: block 2 ; Flags and jfns block 3 ; Device, dir, name point 7, [asciz /TAGS/] ; Extension block 4 injfn: 0 tagjfn: 0 oldjfn: 0 nfiles: 0 nfunct: 0 nchars: 0 filptr: 0 hdrptr: 0 zroptr: 0 indefq: 0 ; Non-zero => inside DEFINEQ for INTERLISP nparen: 0 ; <paren depth> - 1 for INTERLISP arpdp: 0 ; Pushdown pointer for [] paren pdl parpdl: block 100 ; Stack itself defext: block 10 strbsz __ 100 strbuf: block strbsz npdl __ 17 pdl: block npdl subttl Pure storage defjfb: gj%old!gj%cfm!gj%ifg!gj%xtn .priin,,.priou block 3 point 7, defext block 3 3 block 2 point 7, [asciz /*/] minus1:: zromsk: byte (7) 177, 177, 177, 177, 177 (1) 1 byte (7) 000, 177, 177, 177, 177 (1) 1 byte (7) 000, 000, 177, 177, 177 (1) 1 byte (7) 000, 000, 000, 177, 177 (1) 1 byte (7) 000, 000, 000, 000, 177 (1) 1 crlf: byte (7) 15, 12, 0 squozp: repeat "#"-0+1,<0> ; ^@ - # repeat "%"-"$"+1,<-1> ; $ - % repeat "-"-"&"+1,<0> ; & - - repeat "."-"."+1,<-1> ; . repeat "/"-"/"+1,<0> ; / repeat "9"-"0"+1,<-1> ; 0 - 9 repeat "@"-":"+1,<0> ; : - @ repeat "Z"-"A"+1,<-1> ; A - Z repeat "`"-"["+1,<0> ; [ - ` repeat "z"-"a"+1,<-1> ; a - z repeat 177-"{"+1,<0> ; { - rubout subttl Languages we know about ;lang(language name, default extension, dispatch tag prefix) ;The maximum length of the default extension is 5 characters. define langs < lang(BLISS,BLI,BLI) lang(BLISS11,B11,B11) lang(FAIL,FAI,FAI) lang(FORTRAN,FOR,FOR) lang(H316,H16,H16) lang(INTERLISP,ILSP,LSP) lang(MACLISP,LSP,MCL) lang(MACN11,M11,M11) lang(MACRO,MAC,MAC) lang(MIDAS,MID,MID) lang(PAL11X,P11,P11) lang(PSL,SL,SL) ; "Portable Standard Lisp" or "Standard Lisp" lang(REDUCE,RED,RED) ; Reduce and Rlisp files. lang(SAIL,SAI,SAI) lang(SCRIBE,MSS,SCR) lang(TECO,EMACS,TEC) > ; Indexes for languages define lang ' (x,y,z) < lt.'z __ nlangs nlangs __ nlangs+1 > nlangs __ 0 langs ; Table of filename extensions define lang ' (x,y,z) < <asciz /y/> > langex: langs ; Table of language names define lang(x,y,z) < [asciz /x/] > langtb: langs ; Table of dispatch routines for them define lang ' (x,y,z) < z'lin > langds: langs subttl Hairy string macro ; Reset string define strini (str) { define str {0,} } define strcn1 ' (str,str2,dummy,str1) { define str {0,str1'str2} } ; Add str2 to str1's current value define strcnc (str1,str2) { strcn1 (str1,str2,\str1) } define strget ' (ac,cond,dummy,str) { ifdif {str},{},{cam'cond ac, [ascii /str/]} ifidn {str},{},{cai'cond ac, 0} } ; Get the resultant string define strevl (ac,cond,str) { strget (ac,cond,\str) } ; Go to jmp if string in s and s1 matches str ; Or if jmp not spec, return unless matches define strmat (str, jmp) { strini(str1) strini(str2) strcnt __ 0 for char e {str} { ifl strcnt-5,{ strcnc(str1,char)} ifge strcnt-5,{ strcnc(str2,char)} strcnt __ strcnt+1 } purge strcnt strevl(s,n,str1) strevl(s1,e,str2) ifidn {jmp},{},{ret} ifdif {jmp},{},{caia jrst jmp} } subttl Main program go: reset setzb f, nfiles move p, [iowd npdl, pdl] call dorscn ; Check for filename in rscan line call filini ; Get output file hrroi 1, [asciz / Type filenames, end with blank line /] trnn f, f%oldf psout ; Unless using old file, give prompt setzm injfn ; Make sure we dont thing there's a file floop: call nxtfil ; Get the next file to do jrst done ; All done call inifil ; Set up to start this file lloop: call nxtlin ; Get the next line jrst lloopf ; End of this file call @langds(l) ; Do this line jrst lloop lloopf: call finfil ; Finish up this file jrst floop done: call finish ; Finish up the output tags file haltf jrst go subttl Top level subroutines ; Get command line dorscn: trz f, f%oldf ; Clear out flag t20,< setz 1, rscan tdza 1, 1 jumpe 1, cpopj ; No command line movni 3, (1) movei 1, .cttrm hrroi 2, strbuf sin ; Read command line move bp, [point 7, strbuf] dorsc1: ildb 1, bp cain 1, 12 ; EOL? ret ; Yes, return to get from tty caie 1, " " ; Space? jrst dorsc1 ; No, keep going > tnx,< movei 1, .priin bkjfn jfcl pbin ; Get terminator of command line caie 1, " " ret ; Return if not space to get from tty > ; Get file from command line t20,< dmove 1, [gj%old .nulio,,.nulio] dmovem 1, tagjfb movei 1, tagjfb ; Default to .TAGS move 2, bp > tnx,< movsi 1, (gj%old!gj%cfm!gj%msg) movem 1, tagjfb move 1, [.priin,,.priou] movem 1, tagjfb+.gjsrc movei 1, tagjfb setz 2, > gtjfn jrst dorscx move 2, [7b5+of%rd] openf jrst dorscx movem 1, oldjfn ; And save jfn of old file tro f, f%oldf ret dorscx: call jerror ; Print jsys error message haltf jrst go ; Set up output file filini: setzm defext ; Reset default extension trne f, f%oldf ; If reparsing, jrst filin2 ; Get next version of old file filin1: hrroi 1, [asciz / Output tags file: /] psout t20,< dmove 1, [gj%fou!gj%cfm!gj%msg .priin,,.priou] dmovem 1, tagjfb > tnx,< movsi 1, (gj%fou!gj%cfm!gj%msg) movem 1, tagjfb move 1, [.priin,,.priou] movem 1, tagjfb+.gjsrc > movei 1, tagjfb setz 2, gtjfn jrst filix1 move 2, [7b5+of%wr] ; Open for write openf jrst filix1 movem 1, tagjfn ret filin2: hrroi 1, strbuf move 2, oldjfn ; Name of old file move 3, [111100,,1] ; DEV:<DIR>NAM.EXT (no gen number) jfns movsi 1, (gj%fou!gj%sht) hrroi 2, strbuf gtjfn jrst filix2 move 2, [7b5+of%wr] openf jrst filix2 movem 1, tagjfn ret filix1: call jerror jrst filin1 ; Try again filix2: call jerror haltf jrst filini ; Get the next file to process nxtfil: trne f, f%oldf ; If from old file jrst nxtfl2 ; Read next one from that file nxtfl0: skipe 1, injfn ; See if more in this filespec gnjfn jrst nxtfl1 ; Nope andi 1, -1 move 2, [7b5+of%rd] openf jrst nxtfl0 aos (p) ; Will skip return trne f, f%lgvn ; If got language from user with /, ret ; Use it again, else jrst nxtf1e ; Try to match from extension nxtfl1: movei 1, "*" pbout ; Prompt movei 1, defjfb ; String with last default in it setz 2, gtjfn jrst nxtfx1 movem 1, injfn andi 1, -1 move 2, [7b5+of%rd] openf jrst nxtfx1 aos (p) ; Will skip return trz f, f%lgvn ; Reset language from user flag movei 1, .priin ; Get confirming char bkjfn ret pbin caie 1, "/" ; Was it a slash? jrst nxtf1e ; No, get language from extension tro f, f%lgvn ; Say language was given by user jrst getlng ; Get language from user and return nxtf1e: setz s, hrroi 1, s hrrz 2, injfn movsi 3, 000100 ; Just file type jfns movsi l, -nlangs ; Pointer for language options nxtf1f: came s, langex(l) ; Extension matches? aobjn l, nxtf1f ; No, keep trying jumpge l, getlnx ; If not found, go ask for it ret ; Else return nxtfx1: cain 1, gjfx33 ; Filename not spec? ret ; Yes, single return call jerror jrst nxtfl1 nxtfl2: trne f, f%eoff ; EOF last time ret ; Yes, single return this time then aos (p) ; Else prepare for skip return movsi 1, (gj%old!gj%fns!gj%sht) movei 2, .nulio hrl 2, oldjfn ; Source if old file gtjfn jrst nxtfx2 move 2, [7b5+of%rd] openf jrst nxtfx2 movem 1, injfn move 1, oldjfn ; Find language type in file nxtf2a: bin caie 2, "," ; Find the comma jrst nxtf2a setzm strbuf setzm strbuf+1 hrroi 2, strbuf movei 3, strbsz*5 movei 4, 15 ; Until CR sin setz 3, dpb 3, 2 ; Mark end of line with null nxtf2b: bin jumpe 2, nxtf2z ; Maybe EOF caie 2, 37 ; Find the ^_ jrst nxtf2b bin caie 2, 15 ; Followed by CRLF jrst nxtf2b bin caie 2, 12 jrst nxtf2b bin ; Peek next char bkjfn trn skipn 2 ; See if EOF now nxtf2c: tro f, f%eoff ; Yes, say so jrst getln2 ; Lookup language name nxtfx2: call jerror haltf jrst nxtfil nxtf2z: gtsts tlnn 2, (gs%eof) ; EOF? jrst nxtf2b ; No jrst nxtf2c ; Init variables for this file, etc. inifil: move 1, tagjfn ; Output file rfptr ; Get current position seto 2, movem 2, hdrptr ; Save pointer to start of this header hrrz 2, injfn move 3, [111100,,1] ; DEV:<DIR>NAM.EXT jfns t20,< hrroi 2, [asciz /.0 00000,/] > tnx,< hrroi 2, [asciz /;0 00000,/] > setz 3, sout rfptr ; Get current position in file seto 2, subi 2, 6 ; Position just before 1st of 0's movem 2, zroptr ; Save it for later andi l, -1 ; Clear any index hrro 2, langtb(l) ; Get language name sout hrroi 2, crlf sout setzb n, filptr ; Reset counters setzm nchars aos nfiles ; Count one more file cpopj: ret ; Get the next line nxtlin: move 1, nchars ; Get number of chars from last time addm 1, filptr ; Update current position in file hrrz 1, injfn hrroi 2, strbuf movei 3, strbsz*5 movei 4, 12 ; Read till LF sin subi 3, strbsz*5 ; Get number of characters read jumpe 3, cpopj ; None, EOF then movnm 3, nchars ; Save number of characters read move bp, [point 7, strbuf] cpopj1: aos (p) ret ; Skip return ; Finish up the current file finfil: move 1, tagjfn ; Output file hrroi 2, [byte (7) 37, 15, 12, 0] ; ^_CRLF setz 3, sout rfptr ; Get current position now setz 2, sub 2, hdrptr ; Less start of this block push p, 2 ; Save it move 2, zroptr ; Start of zero block sfptr error (SFPTR failed) pop p, 2 move 3, [no%lfl+no%zro+5b17+=10] ; Size in decimal nout trn seto 2, ; Back to then end now sfptr error (SFPTR failed) hrrz 2, injfn trne f, f%oldf ; If getting from the tty, jrst finfl2 hrroi 1, defext movsi 3, 000100 ; Set the default type for next time jfns finfl2: movei 1, .priou ; Tell the user what is happenning setz 3, jfns hrroi 2, [asciz / - /] sout movei 2, (n) ; Number of functions written movei 3, =10 nout trn hrroi 1, [asciz /. functions found. /] psout addm n, nfunct ; Keep track of grand totals move 1, injfn tlnn 1, (gj%dev!gj%dir!gj%nam!gj%ext) ; Wildcards given? tlza 1, -1 ; No, clear random bits hrli 1, (co%nrj) ; Yes, keep the jfn then for next time closf ; Done with the file trn ret ; Finish up everything finish: movei 1, .priou move 2, tagjfn ; Output file setz 3, jfns hrroi 2, [asciz / - /] sout movei 3, =10 move 2, nfunct ; Number of functions done nout trn hrroi 1, [asciz /. functions in /] psout movei 1, .priou move 2, nfiles ; Number of files used nout trn hrroi 1, [asciz /. files. /] psout move 1, tagjfn closf ; Close the output file trn ret subttl Lower level subroutines ; Get the language type getlnx: hrroi 1, [asciz /? Language type not recognised Please specify for /] psout movei 1, .priou hrrz 2, injfn setz 3, jfns hrroi 1, [asciz / : /] psout getlng: hrroi 1, strbuf t20,< move 2, [rd%rai+rd%crf+strbsz*5] setz 3, rdtty error (RDTTY failed) > tnx,< movei 2, strbsz*5 pstin > andi 2, -1 ; Get number of chars used subi 2, strbsz*5-1 ; Clear terminator too movm 2, 2 idivi 2, 5 ; Get number of words used move 3, zromsk(3) andcam 3, strbuf(2) setzm strbuf+1(2) ; Clear next word for good measure getln2: t20,< dmove s, strbuf ; Get first two words of string > tnx,< move s, strbuf move s1, strbuf+1 > movsi l, -nlangs camn s, [asciz /?/] jumpe s1, getln5 ; Try to help the guy out if he asks getln3: hrrz 2, langtb(l) came s, (2) ; First word matches? jrst getln4 ; No jumpe s1, cpopj ; If only one word, matched camn s1, 1(2) ret ; Found it. getln4: aobjn l, getln3 jrst getlnx ; Not found getln5: hrroi 1, [asciz / one of: /] psout getln6: hrro 1, langtb(l) psout hrroi 1, crlf psout aobjn l, getln6 jrst getlnx ; Write out line before the current LF outtlf: add bp, [7b5] skipge bp sub bp, [43b5+1] ldb ch, bp ; Get char before LF cain ch, 15 ; Is it CR? add bp, [7b5] ; Yes, back over it too ; Write out the beginning of the current line and the current position ; To the tags output file outtag: setz 3, idpb 3, bp ; Mark end with a null move 1, tagjfn ; Output file hrroi 2, strbuf sout ; Write out start of line movei 2, 177 ; And rubout bout movei 2, -strbuf(bp) ; Get number of words imuli 2, 5 ; Into characters ldb 3, [point 6, bp, 5] ; Get current position idivi 3, 7 subi 3, 4 sub 2, 3 ; Get current position add 2, filptr ; Make it absolute movei 3, =10 ; Decimal nout trn hrroi 2, crlf setz 3, sout ; And CRLF aoj n, ; Count another one done ret ; Error handler uuoh: movei 1, "?" pbout hrro 1, 40 psout haltf ret ; Print JSYS error message jerror: movei 1, "?" pbout movei 1, .priou hrloi 2, .fhslf setz 3, erstr trn trn hrroi 1, crlf psout ret subttl Language dependant subroutines ; Assembly language subroutines failin: m11lin: maclin: midlin: p11lin: h16lin: asmlin: setzb t, s asmln0: ildb ch, bp ; Get first character cain ch, "L"-100 ; Allow formfeed jrst asmln0 caie ch, "" ; For fail, cain ch, "^" ; Allow arrows at start of line caie l, lt.fai jrst asmln2 jrst asmln0 ; So get another char asmln1: movei t, (ch) ; Save previous char ildb ch, bp asmln2: skipe squozp(ch) ; Is this legal squoze char? aoja s, asmln1 ; Yes, keep looking asmln3: caie ch, ":" ; If it's a : or cain ch, "=" ; =, jrst asmln4 ; We found one maybe caie l, lt.fai ; For fail cain l, lt.p11 ; Or pal11x, caia ret cain ch, "_" ; Allow _ too jrst asmln4 caie ch, 11 ; And tabs before the :'s cain ch, " " ; Or spaces caia ret ; Else no tag here ildb ch, bp ; Get another char and try it jrst asmln3 asmln4: caie l, lt.m11 ; For MACN11 ... cain l, lt.p11 ; Or pal11x ... jrst asmln6 ; Check for local labels asmln5: jumpe s, cpopj ; = isnt a label (as in =24 for fail) cain t, "." ; If label is not just dot caie s, 1 jrst outtag ; Found one ret asmln6: move t, [point 7, strbuf] ; Start of line again asmln7: ildb ch, t cain ch, "L"-100 ; Dont be confused by ff jrst asmln7 cail ch, "0" ; See if it is a digit caile ch, "9" jrst asmln5 ; It isnt ret ; It is, flush it ; SCRIBE subroutine (null for now) scrlin: ret ; TECO subroutine teclin: ildb ch, bp ; Get first character caie ch, "!" ; Only lines starting with ! pass ret setz s, ; Reset found pointer tecln1: ildb ch, bp ; Get next character cain ch, 12 ; End of line jrst tecln2 ; Go see if we found anything caie ch, ":" ; Must have had : just before a ! jrst tecln1 ildb ch, bp ; Get next char cain ch, "!" move s, bp ; If label, save the current pointer jrst tecln1 tecln2: skipn bp, s ; Get last label we had ret ; None found jrst outtag ; And output that many ; SAIL subroutine sailin: call ratom ; Get the first word strmat SIMPLE, sailin strmat RECURSIVE, sailin strmat BOOLEAN, sailn3 strmat INTEGER, sailn3 strmat REAL, sailn3 strmat STRING, sailn3 sailn1: strmat PROCEDURE setz s, ; Reset paren level sailn2: ildb ch, bp ; Get a char cain ch, 12 ; If end of line jrst outtlf ; Write the whole line then cain ch, "(" ; Count one more left paren aoja s, sailn2 cain ch, ")" ; Count one less paren soja s, sailn2 cain ch, ";" ; Now, if to the ; jumple s, outtag ; Output it if not inside parens jrst sailn2 ; Else keep going sailn3: call ratom ; Get another word jrst sailn1 ; And try it ; Bliss subroutines b11lin: blilin: call ratom ; Get word strmat GLOBAL, bliln3 bliln1: strmat ROUTINE, bliln2 caie l, lt.bli ; Bliss-10 has FUNCTIONS too ret ; Not a function decl strmat FUNCTION bliln2: ildb ch, bp ; Get chars caie ch, "=" ; Until = cain ch, 12 ; Or end of this line jrst outtag jrst bliln2 bliln3: call ratom jrst bliln1 ; Fortran subroutine forlin: call ratom ; Get a word strmat PROGRAM,forln1 strmat SUBROUTINE,forln1 strmat DOUBLE,forln6 forln4: strmat INTEGER,forln7 strmat REAL,forln7 strmat COMPLEX,forln7 forln5: strmat FUNCTION forln1: ildb ch, bp ; Get a character cain ch, 12 ; If eol here, jrst outtlf ; Use whole line caie ch, "(" ; Look for start of args jrst forln1 forln2: movei s, 1 ; Init paren level forln3: ildb ch, bp ; Get character cain ch, 12 ; If eol, jrst outtlf ; Write whole line cain ch, "(" ; Keep track of paren level aoja s, forln3 cain ch, ")" ; And look for matching close sojle s, outtag jrst forln3 forln6: call ratom jrst forln4 forln7: call ratom jrst forln5 ; MACLISP subroutines mcllin: for zot e {(DEF} ; Do all lines that begin with (DEF { ildb ch, bp caie ch, "zot" ifg "zot"-100,{ cain ch, "zot"+40 caia } ret } movei u, 1 mclln1: ildb ch, bp cain ch, 12 jrst outtlf caie ch, " " jrst mclln1 sojge u, mclln1 jrst outtag ; INTERLISP routines lsplin: skipe indefq ; Already inside a DEFINEQ? jrst lspln1 ; Yes, see if this is a new form call ratom ; Else get the beginning of the line strmat {(DEFINEQ} ; And try for start of new one setom indefq ; Remember are inside one setzm nparen ; And initialize paren depth move t, [iowd 100, parpdl] ; Initialise bracket pdl lspln0: movem t, parpdp lspln1: ildb ch, bp ; Get next character cain ch, 12 ; End of line? ret cain ch, "%" ; Char quoted? jrst [ildb ch, bp ; Yes, just gobble one jrst lspln1] cain ch, "[" ; Super open paren jrst lspln4 cain ch, "]" ; Super close jrst lspln5 cain ch, "(" ; Go down a level jrst lspln2 cain ch, ")" ; Close one level of parens sosl nparen ; And see if this finishes the DEFINEQ jrst lspln1 ; Doesnt, get next character setzm indefq ; No longer inside a DEFINEQ ret ; Rest of this line no good to us lspln4: exch t, parpdp ; [ - save the curren paren depth push t, nparen exch t, parpdp ; And fall thru for one more open lspln2: aos t, nparen caie t, 1 ; Start of a new definition within the defineq? jrst lspln1 ; No, keep trying lspln3: ildb ch, bp ; Get next character cain ch, 12 ; End of line is end of atom of functions name jrst outtlf cain ch, " " ; Or a space also jrst outtag ; Yes, output this line then jrst lspln3 ; Keep looking lspln5: move t, parpdp ; ] - restore from last ] pop t, nparen jrst lspln0 ; And continue ; PSL routines ; Portable Standard Lisp (PSL) handler (simple minded version). Also ; handles other Utah flavors of Lisp. sllin: call ratom strmat {(DE},sl1 ; Look for one of "(DE", (Define Expr), strmat {(DF},sl1 ; "(DF", (Define Fexpr), strmat {(DM},sl1 ; "(DM", (Define Macro), strmat {(DN},sl1 ; "(DN", (Define Nexpr), strmat {(DS},sl1 ; "(DS", (Define Substitution Macro), strmat {(DEFUN},sl1 ; "(DEFUN", (Define Expr), strmat {(DEFVAR},sl1 ; "(DEFVAR", (Define fluid variable), strmat {(DEFCONST},sl1 ; "(DEFCONST", (Define constant), strmat {(LAP},sl1 ; "(LAP", ("Lisp Assembler Program"?) ; Might be better to look for "!*entry" ? strmat {(DEFMACRO},sl1 ; "(DEFMACRO", (an alternate way to define ; macros) strmat {(DEFFLAVOR},sl1 ; "(DEFFLAVOR", (Define Flavor), strmat {(DEFMETHOD} ; "(DEFMETHOD", (Define Method) sl1: ; Write the tag out ildb ch, bp ; Scan for end of line. cain ch, 12 ; (I.e. End of Line) jrst outtlf ; Write the line if EOL seen jrst sl1 ; Keep looping till found ; REDUCE subroutine redlin: call Satom ; Get the first word strmat SYMBOLIC, redlin ; ftypes (of REDUCE) strmat ALGEBRAIC, redlin strmat BOOLEAN, redlin strmat INTEGER, redlin strmat FEXPR, redlin strmat EXPR, redlin strmat LISP, redlin strmat MACRO, redlin strmat SMACRO, redlin strmat NMACRO, redlin strmat SYSLSP, redlin strmat LAP, redn2 ; Might be better to look for !*entry ? strmat MODE, redn2 strmat GLOBAL, redn1 redn1: strmat PROCEDURE setz s, ; Reset paren level jrst sailn2 redn2: ildb ch,bp ; get chars cain ch,"=" ; Until = jrst outtag cain ch,12 ; or until the end of line jrst outtlf jrst redn2 ; A hacked-up version of ratom to allow reading "RECORD!POINTER" ; Read the next word into s and s1 Satom: ildb ch, bp ; Get a character cain ch, 12 ; If end of line here jrst Satom3 ; Return to callers caller caie ch, " " ; Flush white space cain ch, 11 jrst Satom cain ch, "L"-100 ; Or ff jrst Satom setzb s, s1 move t, [point 7, s] movei u, =10 ; Max number of chars Satom1: caie ch, "!" cain ch, "" jrst satom ; Start over if "!" or "^X" cail ch, "a" caile ch, "z" caia trz ch, "a"-"A" ; Uppercase it idpb ch, t ildb ch, bp cain ch, "(" movei ch, " " ; Change "(" to space caile ch, " " ; Until terminator sojg u, Satom1 jumple u, Satom3 ; Too long for us add bp, [7b5] ; Back up over teminator ret ; And return Satom3: pop p, garb# ; Flush callers return ret ; And return to callers caller ; Read the next word into s and s1 ratom: ildb ch, bp ; Get a character cain ch, 12 ; If end of line here jrst ratom3 ; Return to callers caller caie ch, " " ; Flush white space cain ch, 11 jrst ratom cain ch, "L"-100 ; Or ff jrst ratom setzb s, s1 move t, [point 7, s] movei u, =10 ; Max number of chars ratom1: cail ch, "a" caile ch, "z" caia trz ch, "a"-"A" ; Uppercase it idpb ch, t ildb ch, bp caile ch, " " ; Until terminator sojg u, ratom1 jumple u, ratom3 ; Too long for us add bp, [7b5] ; Back up over teminator ret ; And return ratom3: pop p, garb# ; Flush callers return ret ; And return to callers caller ; Local modes: ; Mode: FAIL ; Comment col:40 ; Comment start:; ; End: end go |
Added psl-1983/20-kernel/test-psl-link.ctl version [c2cd7e98c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | cd S: define DSK:, DSK:, P20: LINK /nosymbol nil.rel /set:.low.:202 types.rel randm.rel alloc.rel arith.rel debg.rel error.rel eval.rel extra.rel fasl.rel io.rel macro.rel prop.rel symbl.rel sysio.rel tloop.rel main.rel heap.rel dtypes.rel drandm.rel dalloc.rel darith.rel ddebg.rel derror.rel deval.rel dextra.rel dfasl.rel dio.rel dmacro.rel dprop.rel dsymbl.rel dsysio.rel dtloop.rel dmain.rel dheap.rel /save s:bpsl.exe /go |
Added psl-1983/20-kernel/timc.red version [19f9edfc8f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % % TIMC.RED - get run time in milliseconds % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 October 1981 % Copyright (c) 1981 University of Utah % lap '((!*entry TimC expr 0) (!*MOVE (WConst -5) (reg 1)) (runtm) (!*EXIT 0) ); end; |
Added psl-1983/20-kernel/tloop.ctl version [09a0a83fde].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "tloop"; in "tloop.build"; ASMEnd; quit; compile tloop.mac, dtloop.mac delete tloop.mac, dtloop.mac |
Added psl-1983/20-kernel/tloop.init version [ff1584ad1a].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | (FLUID (QUOTE (!*BREAK !*QUITBREAK BREAKEVAL!* BREAKNAME!* BREAKVALUE!* ERRORFORM!* BREAKLEVEL!* MAXBREAKLEVEL!* TOPLOOPNAME!* TOPLOOPEVAL!* TOPLOOPREAD!* TOPLOOPPRINT!* !*DEFN BREAKIN!* BREAKOUT!*))) (DEFLIST (QUOTE ((Q BREAKQUIT) (!? HELPBREAK) (A RESET) (M BREAKERRMSG) (E BREAKEDIT) (C BREAKCONTINUE) (R BREAKRETRY) (I INTERPBACKTRACE) (V VERBOSEBACKTRACE) (T BACKTRACE))) (QUOTE BREAKFUNCTION)) (FLUID (QUOTE (TOPLOOPREAD!* TOPLOOPPRINT!* TOPLOOPEVAL!* TOPLOOPNAME!* TOPLOOPLEVEL!* HISTORYCOUNT!* HISTORYLIST!* PROMPTSTRING!* LISPBANNER!* !*EMSGP !*BACKTRACE !*TIME GCTIME!* !*DEFN DFPRINT!* !*OUTPUT SEMIC!* !*NONIL INITFORMS!*))) (FLUID (QUOTE (!*BREAK))) (PUT (QUOTE HIST) (QUOTE TYPE) (QUOTE NEXPR)) (FLAG (QUOTE (DSKIN)) (QUOTE IGNORE)) (FLUID (QUOTE (!*REDEFMSG !*ECHO))) |
Added psl-1983/20-kernel/tloop.log version [01368ee581].
cannot compute difference between binary files
Added psl-1983/20-kernel/tloop.rel version [3ce3909597].
cannot compute difference between binary files
Added psl-1983/20-kernel/trap.red version [4991d33e65].
> | 1 | end; |
Added psl-1983/20-kernel/types.ctl version [7001b60053].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "types"; in "types.build"; ASMEnd; quit; compile types.mac, dtypes.mac delete types.mac, dtypes.mac |
Added psl-1983/20-kernel/types.init version [30ff500f06].
> > | 1 2 | (PUT (QUOTE STRING) (QUOTE TYPE) (QUOTE NEXPR)) (PUT (QUOTE VECTOR) (QUOTE TYPE) (QUOTE NEXPR)) |
Added psl-1983/20-kernel/types.log version [a09c646656].
cannot compute difference between binary files
Added psl-1983/20-kernel/types.rel version [1625e13e84].
cannot compute difference between binary files
Added psl-1983/20-kernel/write-float.red version [5f6b3377e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % WRITE-FLOAT.RED - format a floating point number into a string % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 November 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>WRITE-FLOAT.RED.3, 28-Sep-82 15:44:53, Edit by BENSON % Changed DMOVE to 2 moves, so this will run on a KI10 Tenex lap '((!*entry WriteFloat expr 2) % convert float to string % % r1 is string pointer, r2 is pointer to 2 word float % puts characters in string buffer with terminating null char and count % (!*MOVE (reg 1) (reg t1)) % save pointer to string count (!*WPLUS2 (reg 1) (WConst 1)) % move to chars (hrli (reg 1) 8#440700) % make r1 a byte pointer (!*MOVE (reg 1) (reg t2)) % save starting byte pointer (move (reg 3) (Indexed (reg 2) 1)) % load r2 and r3 with the number (move (reg 2) (Indexed (reg 2) 0)) (move (reg 4) (lit (fullword 2#000010100000001000000000010000000000))) % fl%one + fl%pnt + 16 fl%rnd (dfout) (!*JUMP (Label Error)) (!*MOVE (WConst -1) (reg 4)) % count := -1 Count (!*JUMPEQ (Label DoneCounting) (reg 1) (reg t2)) % byte pointers equal? (ibp (reg t2)) (aoja (reg 4) Count) % Count := Count + 1 DoneCounting (!*MOVE (reg 4) (MEMORY (reg t1) (WConst 0))) % deposit count (!*MOVE (WConst 0) (reg 2)) (idpb (reg 4) (reg 1)) % deposit null byte (!*EXIT 0) Error (!*MOVE (QUOTE "Couldn't print float") (reg 1)) (!*JCALL IOError) ); END; |
Added psl-1983/20-tests/20-test-global-data.red version [b4dff7226f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 20-TEST-GLOBAL-DATA - Data used by everyone, test version % % Author: Eric Benson, M Griss, S Lowder % Computer Science Dept. % University of Utah % Date: 1 September 1981 % Copyright (c) 1981 University of Utah on SysLisp; % For testing with MAINn, see P20T:XXX-HEADER.RED % Want a small SYMTAB and HEAP exported WConst MaxSymbols = 1000, MaxChannels = 31, MaxObArray = 1000, MaxRealRegs = 5, MaxArgs = 15; % BitPositions for testing, etc: exported Wconst BitsPerWord=36; % The STACK stuff external WVAR ST, StackLowerBound, StackUpperBound; % "standard" Symbol table Data structures, handled % specially in Compiler external Warray Symnam,SymVal,SymFnc,SymPrp; external WVar NextSymbol; % For extra arguments not in Real registers external WArray ArgumentBlock; % For the Foreign Function Calling Protocol external Wvar Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8,Arg9, Arg10,Arg11,Arg12,Arg13,Arg14,Arg15; off SysLisp; END; |
Added psl-1983/20-tests/20-test.output version [86d7cb83aa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @@ex @@main1 LINK: Loading [LNKXCT MAIN1 execution] Call on Init AB 9 10 8 90 7 720 6 5040 5 30240 4 151200 3 604800 2 1814400 1 3628800 3628800 Ctime: 98662 ms, 98662 ms Ctime: 99412 ms, 750 ms Ctime: 99450 ms, 38 ms 7 Ctime: 99913 ms, 463 ms Quitting @NEWPAGE() @@ex @@main2 LINK: Loading [LNKXCT MAIN2 execution] Call on Init StrInf 55688 55688 Strlen 51 51 Byte 0 65 A 1 97 a 2 66 B 3 98 b 4 67 C 5 99 c 6 68 D 7 100 d 8 69 E 9 101 e 10 70 F String AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUnVvWwXxYyZz "----- Now input characters until #" 11223344556677 aaaabbbbccddeeffgg #"----- First Print Called" 1 ANATOM (1 . 2) (AA (B1 . B2 ) . B3 ) (AA (B1 ) ) Quitting @NEWPAGE() @@ex @@main3 LINK: Loading [LNKXCT MAIN3 execution] Call on Init "MAIN3: Casetest" Test case from -1 to 11 Will classify argument Show for N=-1, expect default case Show for N=0, expect 0 case Show for N=1, expect 1,2,3 case Show for N=2, expect 1,2,3 case Show for N=3, expect 1,2,3 case Show for N=4, expect default case Show for N=5, expect default case Show for N=6, expect 6 ... 10 case Show for N=7, expect 6 ... 10 case Show for N=8, expect 6 ... 10 case Show for N=9, expect 6 ... 10 case Show for N=10, expect 6 ... 10 case Show for N=11, expect default case Show for N=12, expect default case "MAIN3: test CONS" (2 . 1) (3 2 . 1) (4 3 2 . 1) (5 4 3 2 . 1) (6 5 4 3 2 . 1) (7 6 5 4 3 2 . 1) (8 7 6 5 4 3 2 . 1) (9 8 7 6 5 4 3 2 . 1) Quitting @NEWPAGE() @@ex @@main4 LINK: Loading [LNKXCT MAIN4 execution] 1. --- Test EQSTR ----- For EqStr(AB,AB) T should be T OK ------ ----- For EqStr(AB,AB) T should be T OK ------ ----- For EqStr(AB,Ab) NIL should be NIL OK ------ ----- For EqStr(AB,ABC) NIL should be NIL OK ------ 2. --- Test FindId on existing ID's Lookup string="A" Found In LookUpId=65 ----- For FindId(A) A should be A OK ------ Lookup string="AB" Found In LookUpId=190 ----- For FindId(AB) AB should be AB OK ------ 3. --- Test FindId on new ID, make sure same place Lookup string="ABC" Not Found in LookupId New ID# 192 Lookup string="ABC" Found In LookUpId=192 ----- For FindId(ABC) ABC should be ABC OK ------ Lookup string="FOO" Not Found in LookupId New ID# 193 Lookup string="ABC" Found In LookUpId=192 ----- For FindId(ABC) again ABC should be ABC OK ------ 4. --- Test RATOM loop. Type various ID's, STRING's and INTEGER's Move to next part of test by typing the id Q Inspect printout carefully NextSymbol =194 1 Item read= <0:1> 1 "123"Item read= <4:5890> "123" A Lookup string="A" Found In LookUpId=65 Item read= <30:65> A a Lookup string="a" Found In LookUpId=97 Item read= <30:97> a AA Lookup string="AA" Not Found in LookupId New ID# 194 Item read= <30:194> AA aa Lookup string="aa" Not Found in LookupId New ID# 195 Item read= <30:195> aa abc Lookup string="abc" Not Found in LookupId New ID# 196 Item read= <30:196> abc ABC Lookup string="ABC" Found In LookUpId=192 Item read= <30:192> ABC abc Lookup string="abc" Found In LookUpId=196 Item read= <30:196> abc Q Lookup string="Q" Found In LookUpId=81 Item read= <30:81> Q 5. --- Test READ loop. Type various S-expressions Move to next part of test by typing the id Q Inspect printout carefully 'A Item read= <9:5912> (QUOTE A ) (12 '(34) (5 (6))) Item read= <9:5930> (12 (QUOTE (34) ) (5 (6) ) ) Q Item read= <30:81> Q Quitting @NEWPAGE() @@ex @@main5 LINK: Loading [LNKXCT MAIN5 execution] (very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q 1 lisp> 1 1 2 lisp> 'A A 3 lisp> (SETQ A 3) 3 4 lisp> A 3 5 lisp> (PRINT (CONS A A)) (3 . 3) (3 . 3) 6 lisp> (QUIT) Quitting @NEWPAGE() @@ex @@main6 LINK: Loading %LNKFTH Fullword value RESET being truncated to halfword %LNKMDS Multiply-defined global symbol RESET Detected in module .MAIN from file DSK:SUB6.REL Defined value = 104000000147, this value = 163306 [LNKXCT MAIN6 execution] Test BINDING Primitives ----- For 3rd bound AA 3 should be 3 OK ------ ----- For 2rd bound AA NIL should be NIL OK ------ ----- For Original AA 1 should be 1 OK ------ MINI-PSL: A Read-Eval-Print Loop, terminate with Q 1 lisp> (DE FOO (X) (COND ((NULL X) 2) (T 3))) FOO 2 lisp> (FOO NIL) 2 3 lisp> (FOO 2) 3 4 lisp> (DF E (TIM) (TIMEEVAL TIM)) E 5 lisp> (TESTSETUP) (SETQ FOO (CADR (QUOTE (1 2 3) ) ) ) 6 lisp> (E EMPTYTEST 10000) Ctime: 118090 ms, 118090 ms Ctime: 118127 ms, 37 ms 37 7 lisp> (E SLOWEMPTYTEST 10000) Ctime: 118259 ms, 132 ms Ctime: 118413 ms, 154 ms 154 8 lisp> (E LISTONLYCDRTEST1) Ctime: 118534 ms, 121 ms Ctime: 120275 ms, 1741 ms 1741 9 lisp> (FUM) **** Uncompiled function in APPLY: FUM NIL NIL 10 lisp> (QUIT) Quitting |
Added psl-1983/20-tests/20io.mac version [e075133e46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; 20IO: simple 20 Support routines TITLE 20IO SEARCH MONSYM RADIX ^D10 ENTRY GETC20,PUTC20,INIT20,QUIT20,TIMC20,ERR20,PUTI20 ST=15 INIT20: HRROI 1,[Asciz/ Call on Init /] PSOUT JFCL POPJ ST,0 GETC20: PBIN JFCL POPJ ST,0 PUTC20: PBOUT JFCL CAIE 1,10 ; Is it EOL POPJ ST,0 ; No MOVEI 1,13 PBOUT JFCL MOVEI 1,10 POPJ ST,0 PUTI20: MOVEM 1,JUNK MOVE 2,1 MOVEI 1,^O101 MOVEI 3,^D10 NOUT JFCL MOVE 1,JUNK POPJ ST,0 ERR20: MOVEM 1,Junk HRROI 1,[ASCIZ/ *** ERR20: /] PSOUT MOVE 1,Junk PUSHJ ST,PUTI20 MOVEI 1,10 PBOUT HALTF HALTF POPJ ST,0 Junk: Block 1 QUIT20: Hrroi 1,[ASCIZ/ Quitting /] PSOUT HALTF TIMC20: MOVEI 1,-5 RUNTM JFCL MOVEM 1,NTIME ; Hrroi 1,[ASCIZ/ ;Ctime: /] ; PSOUT ; MOVE 1,NTIME ; PUSHJ ST,PutI20 ; Hrroi 1,[ASCIZ/ ms, /] ; PSOUT MOVE 1,NTIME ; SUB 1,OTIME ; PUSHJ ST,PutI20 ; Hrroi 1,[ASCIZ/ ms ; /] ; PSOUT MOVE 1,NTIME MOVEM 1,OTIME POPJ ST,0 Otime: 0 Ntime: 0 END |
Added psl-1983/20-tests/20io.rel version [79e2055c17].
cannot compute difference between binary files
Added psl-1983/20-tests/20main.mac version [17d23a1274].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ; 20-main: simple driver to test MACRO version of 20 tests TITLE MAIN SEARCH MONSYM RADIX ^D10 EXTERN INIT20,MAIN20,QUIT20 ST=15 MAIN: RESET MOVE ST,[-1000,Stack] PUSHJ ST,INIT20 PUSHJ ST,MAIN20 PUSHJ ST,QUIT20 stack: block 1000 END MAIN |
Added psl-1983/20-tests/20test.mac version [b1eb7a94bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; 20-TEST SIMPLE I/O TESTS, HANDCODED TITLE 20TEST ; MLG, 20 JULY 1982 SEARCH MONSYM RADIX ^D10 EXTERN GETC20,PUTC20,PUTI20,ERR20,TIMC20,QUIT20 ENTRY MAIN20 ST=15 MAIN20: MOVEI 1,1 PUSHJ ST, PUTI20 ; Print a 1 for first test MOVEI 1,10 PUSHJ ST, PUTC20 ; EOL to flush line MOVEI 1,2 PUSHJ ST, PUTI20 ; Second test MOVEI 1,65 PUSHJ ST, PUTC20 ; A capital A MOVEI 1,66 PUSHJ ST, PUTC20 ; A capital B MOVEI 1,10 PUSHJ ST, PUTC20 ; EOL to flush line MOVEI 1,3 PUSHJ ST, PUTI20 ; Third test, type in AB <cr> PUSHJ ST, GETC20 PUSHJ ST, PUTC20 ; Should print A65 PUSHJ ST, PUTI20 MOVEI 1,10 PUSHJ ST,PUTC20 PUSHJ ST, GETC20 PUSHJ ST, PUTC20 ; Should print B66 PUSHJ ST, PUTI20 MOVEI 1,10 PUSHJ ST,PUTC20 PUSHJ ST, GETC20 PUSHJ ST, PUTI20 ; should print 10 and EOL PUSHJ ST, PUTC20 MOVEI 1,10 PUSHJ ST,PUTC20 movei 1,4 pushj st, puti20 ; last test Pushj st,timc20 PushJ st, puti20 movei 1,100 pushj st, err20 movei 1,26 pushj st, putc20 ; eof to flush buffer movei 1,0 pushj st, quit20 POPJ ST, END |
Added psl-1983/20-tests/dec20-patches.sl version [527be39dd9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DEC20-PATCHES.SL % to convert to Portable, 2 reg for LINK model % From DEC20-Asm.RED % These will now be simpler than 20, just JRST % Should even be InternalEntry for efficiency, avoid circular defns % Right now, expect same as !%Store!-JCALL would install (SETQ UndefinedFunctionCellInstructions!* '((!*JCALL UndefinedFunction))) (SETQ LambdaFunctionCellInstructions!* '((!*JCALL CompiledCallingInterpreted))) (Put 'LinkReg 'RegisterName 12) (Put 'NargReg 'RegisterName 13) % From PC:Common-Cmacros.sl (de MakeLinkRegs(Fn Nargs) (cond ((FlagP Fn 'NoLinkage) NIL) (T (list (list '!*Move (list 'IdLoc FunctionName) '(reg LinkReg) ) (list '!*Move (list 'Wconst NumberofArguments) '(reg NargReg) ) )))) (FLAG '(IDapply0 IDapply1 IDapply2 IDapply3 IDapply4) 'NoLinkage) (de !*Link (FunctionName FunctionType NumberOfArguments) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments))) (t (append (MakeLinkRegs FunctionName NumberofArguments) (list (list '!*Call FunctionName)))))) (de !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) (cons (list '!*DeAlloc DeAllocCount) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments) '(!*Exit 0))) (t (Append (MakeLinkRegs FunctionName NumberofArguments) (list (list '!*JCall FunctionName))))))) (DefList '((IDApply0 ( (!*move (Wconst 0) (reg NargReg)) (!*move (reg 1) (reg LinkReg)) % (!*Wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ( (!*move (Wconst 1) (reg NargReg)) (!*move (reg 2) (reg LinkReg)) % (!*Wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ( (!*move (Wconst 2) (reg NargReg)) (!*move (reg 3) (reg LinkReg)) % (!*Wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ( (!*move (Wconst 3) (reg NargReg)) (!*move (reg 4) (reg LinkReg)) % (!*Wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ( (!*move (Wconst 4) (reg NargReg)) (!*move (reg 5) (reg LinkReg)) % (!*Wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 5) (WArray SymFnc))))) ) 'OpenCode) (DefList '((IDApply0 ( (!*move (Wconst 0) (reg NargReg)) (!*move (reg 1) (reg LinkReg)) % (!*wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ( (!*move (Wconst 1) (reg NargReg)) (!*move (reg 2) (reg LinkReg)) % (!*wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ( (!*move (Wconst 2) (reg NargReg)) (!*move (reg 3) (reg LinkReg)) % (!*wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ( (!*move (Wconst 3) (reg NargReg)) (!*move (reg 4) (reg LinkReg)) % (!*wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ( (!*move (Wconst 4) (reg NargReg)) (!*move (reg 5) (reg LinkReg)) % (!*wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 5) (WArray SymFnc))))) ) 'ExitOpenCode) % From PC:lap-to-asm.red (de DataPrintUndefinedFunctionCell () (Prog (OldOut) (setq OldOut (WRS DataOut!*)) (foreach X in (Pass1Lap UndefinedFunctionCellInstructions!*) do (ASMOutLap1 X)) (WRS OldOut))) (DSKIN "PC:P-LAMBIND.SL") % new SYSLISP bug, perhaps useful refefined it? (off usermode) (dm for(u) ( MkFor1 u)) |
Added psl-1983/20-tests/dfield.mac version [d6fe9e5e78].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 301 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+300 intern L0002 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <29_31>+133 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 block 50 SYMNAM: intern SYMNAM extern L0063 <4_31>+L0063 extern L0064 <4_31>+L0064 extern L0065 <4_31>+L0065 extern L0066 <4_31>+L0066 extern L0067 <4_31>+L0067 extern L0068 <4_31>+L0068 extern L0069 <4_31>+L0069 extern L0070 <4_31>+L0070 extern L0071 <4_31>+L0071 extern L0072 <4_31>+L0072 extern L0073 <4_31>+L0073 extern L0074 <4_31>+L0074 extern L0075 <4_31>+L0075 extern L0076 <4_31>+L0076 extern L0077 <4_31>+L0077 extern L0078 <4_31>+L0078 extern L0079 <4_31>+L0079 extern L0080 <4_31>+L0080 extern L0081 <4_31>+L0081 extern L0082 <4_31>+L0082 extern L0083 <4_31>+L0083 extern L0084 <4_31>+L0084 extern L0085 <4_31>+L0085 extern L0086 <4_31>+L0086 extern L0087 <4_31>+L0087 extern L0088 <4_31>+L0088 extern L0089 <4_31>+L0089 extern L0090 <4_31>+L0090 extern L0091 <4_31>+L0091 extern L0092 <4_31>+L0092 extern L0093 <4_31>+L0093 extern L0094 <4_31>+L0094 extern L0095 <4_31>+L0095 extern L0096 <4_31>+L0096 extern L0097 <4_31>+L0097 extern L0098 <4_31>+L0098 extern L0099 <4_31>+L0099 extern L0100 <4_31>+L0100 extern L0101 <4_31>+L0101 extern L0102 <4_31>+L0102 extern L0103 <4_31>+L0103 extern L0104 <4_31>+L0104 extern L0105 <4_31>+L0105 extern L0106 <4_31>+L0106 extern L0107 <4_31>+L0107 extern L0108 <4_31>+L0108 extern L0109 <4_31>+L0109 extern L0110 <4_31>+L0110 extern L0111 <4_31>+L0111 extern L0112 <4_31>+L0112 extern L0113 <4_31>+L0113 extern L0114 <4_31>+L0114 extern L0115 <4_31>+L0115 extern L0116 <4_31>+L0116 extern L0117 <4_31>+L0117 extern L0118 <4_31>+L0118 extern L0119 <4_31>+L0119 extern L0120 <4_31>+L0120 extern L0121 <4_31>+L0121 extern L0122 <4_31>+L0122 extern L0123 <4_31>+L0123 extern L0124 <4_31>+L0124 extern L0125 <4_31>+L0125 extern L0126 <4_31>+L0126 extern L0127 <4_31>+L0127 extern L0128 <4_31>+L0128 extern L0129 <4_31>+L0129 extern L0130 <4_31>+L0130 extern L0131 <4_31>+L0131 extern L0132 <4_31>+L0132 extern L0133 <4_31>+L0133 extern L0134 <4_31>+L0134 extern L0135 <4_31>+L0135 extern L0136 <4_31>+L0136 extern L0137 <4_31>+L0137 extern L0138 <4_31>+L0138 extern L0139 <4_31>+L0139 extern L0140 <4_31>+L0140 extern L0141 <4_31>+L0141 extern L0142 <4_31>+L0142 extern L0143 <4_31>+L0143 extern L0144 <4_31>+L0144 extern L0145 <4_31>+L0145 extern L0146 <4_31>+L0146 extern L0147 <4_31>+L0147 extern L0148 <4_31>+L0148 extern L0149 <4_31>+L0149 extern L0150 <4_31>+L0150 extern L0151 <4_31>+L0151 extern L0152 <4_31>+L0152 extern L0153 <4_31>+L0153 extern L0154 <4_31>+L0154 extern L0155 <4_31>+L0155 extern L0156 <4_31>+L0156 extern L0157 <4_31>+L0157 extern L0158 <4_31>+L0158 extern L0159 <4_31>+L0159 extern L0160 <4_31>+L0160 extern L0161 <4_31>+L0161 extern L0162 <4_31>+L0162 extern L0163 <4_31>+L0163 extern L0164 <4_31>+L0164 extern L0165 <4_31>+L0165 extern L0166 <4_31>+L0166 extern L0167 <4_31>+L0167 extern L0168 <4_31>+L0168 extern L0169 <4_31>+L0169 extern L0170 <4_31>+L0170 extern L0171 <4_31>+L0171 extern L0172 <4_31>+L0172 extern L0173 <4_31>+L0173 extern L0174 <4_31>+L0174 extern L0175 <4_31>+L0175 extern L0176 <4_31>+L0176 extern L0177 <4_31>+L0177 extern L0178 <4_31>+L0178 extern L0179 <4_31>+L0179 extern L0180 <4_31>+L0180 extern L0181 <4_31>+L0181 extern L0182 <4_31>+L0182 extern L0183 <4_31>+L0183 extern L0184 <4_31>+L0184 extern L0185 <4_31>+L0185 extern L0186 <4_31>+L0186 extern L0187 <4_31>+L0187 extern L0188 <4_31>+L0188 extern L0189 <4_31>+L0189 extern L0190 <4_31>+L0190 extern L0191 <4_31>+L0191 extern L0192 <4_31>+L0192 extern L0193 <4_31>+L0193 extern L0194 <4_31>+L0194 extern L0195 <4_31>+L0195 extern L0196 <4_31>+L0196 extern L0197 <4_31>+L0197 extern L0198 <4_31>+L0198 extern L0199 <4_31>+L0199 extern L0200 <4_31>+L0200 extern L0201 <4_31>+L0201 extern L0202 <4_31>+L0202 extern L0203 <4_31>+L0203 extern L0204 <4_31>+L0204 extern L0205 <4_31>+L0205 extern L0206 <4_31>+L0206 extern L0207 <4_31>+L0207 extern L0208 <4_31>+L0208 extern L0209 <4_31>+L0209 extern L0210 <4_31>+L0210 extern L0211 <4_31>+L0211 extern L0212 <4_31>+L0212 extern L0213 <4_31>+L0213 block 50 SYMFNC: intern SYMFNC JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 extern MAIN. jrst MAIN.## extern L0008 jrst L0008## extern INIT jrst INIT## extern GETC jrst GETC## extern TIMC jrst TIMC## extern PUTC jrst PUTC## extern QUIT jrst QUIT## extern PUTINT jrst PUTINT## extern L0006 jrst L0006## extern FLAG jrst FLAG## extern L0007 jrst L0007## extern MSG5 jrst MSG5## extern TESTOK jrst TESTOK## extern L0059 jrst L0059## JSP 10,SYMFNC+137 extern L0014 jrst L0014## extern L0028 jrst L0028## extern L0043 jrst L0043## extern L0061 jrst L0061## extern L0058 jrst L0058## extern L0060 jrst L0060## extern L0062 jrst L0062## block 50 L0003: intern L0003 151 end |
Added psl-1983/20-tests/dfoo.mac version [d2d2e9b655].
> > | 1 2 | radix 10 end |
Added psl-1983/20-tests/dfoo.rel version [dac78c6829].
cannot compute difference between binary files
Added psl-1983/20-tests/dmain1.mac version [8c9e946975].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 5001 intern STACK HEAP: block 50001 intern HEAP L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <30_31>+128 <30_31>+128 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <30_31>+128 <30_31>+128 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 <29_31>+151 <29_31>+152 <29_31>+153 <29_31>+154 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 <29_31>+160 <29_31>+161 block 339 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 339 SYMNAM: intern SYMNAM extern L0033 <4_31>+L0033 extern L0034 <4_31>+L0034 extern L0035 <4_31>+L0035 extern L0036 <4_31>+L0036 extern L0037 <4_31>+L0037 extern L0038 <4_31>+L0038 extern L0039 <4_31>+L0039 extern L0040 <4_31>+L0040 extern L0041 <4_31>+L0041 extern L0042 <4_31>+L0042 extern L0043 <4_31>+L0043 extern L0044 <4_31>+L0044 extern L0045 <4_31>+L0045 extern L0046 <4_31>+L0046 extern L0047 <4_31>+L0047 extern L0048 <4_31>+L0048 extern L0049 <4_31>+L0049 extern L0050 <4_31>+L0050 extern L0051 <4_31>+L0051 extern L0052 <4_31>+L0052 extern L0053 <4_31>+L0053 extern L0054 <4_31>+L0054 extern L0055 <4_31>+L0055 extern L0056 <4_31>+L0056 extern L0057 <4_31>+L0057 extern L0058 <4_31>+L0058 extern L0059 <4_31>+L0059 extern L0060 <4_31>+L0060 extern L0061 <4_31>+L0061 extern L0062 <4_31>+L0062 extern L0063 <4_31>+L0063 extern L0064 <4_31>+L0064 extern L0065 <4_31>+L0065 extern L0066 <4_31>+L0066 extern L0067 <4_31>+L0067 extern L0068 <4_31>+L0068 extern L0069 <4_31>+L0069 extern L0070 <4_31>+L0070 extern L0071 <4_31>+L0071 extern L0072 <4_31>+L0072 extern L0073 <4_31>+L0073 extern L0074 <4_31>+L0074 extern L0075 <4_31>+L0075 extern L0076 <4_31>+L0076 extern L0077 <4_31>+L0077 extern L0078 <4_31>+L0078 extern L0079 <4_31>+L0079 extern L0080 <4_31>+L0080 extern L0081 <4_31>+L0081 extern L0082 <4_31>+L0082 extern L0083 <4_31>+L0083 extern L0084 <4_31>+L0084 extern L0085 <4_31>+L0085 extern L0086 <4_31>+L0086 extern L0087 <4_31>+L0087 extern L0088 <4_31>+L0088 extern L0089 <4_31>+L0089 extern L0090 <4_31>+L0090 extern L0091 <4_31>+L0091 extern L0092 <4_31>+L0092 extern L0093 <4_31>+L0093 extern L0094 <4_31>+L0094 extern L0095 <4_31>+L0095 extern L0096 <4_31>+L0096 extern L0097 <4_31>+L0097 extern L0098 <4_31>+L0098 extern L0099 <4_31>+L0099 extern L0100 <4_31>+L0100 extern L0101 <4_31>+L0101 extern L0102 <4_31>+L0102 extern L0103 <4_31>+L0103 extern L0104 <4_31>+L0104 extern L0105 <4_31>+L0105 extern L0106 <4_31>+L0106 extern L0107 <4_31>+L0107 extern L0108 <4_31>+L0108 extern L0109 <4_31>+L0109 extern L0110 <4_31>+L0110 extern L0111 <4_31>+L0111 extern L0112 <4_31>+L0112 extern L0113 <4_31>+L0113 extern L0114 <4_31>+L0114 extern L0115 <4_31>+L0115 extern L0116 <4_31>+L0116 extern L0117 <4_31>+L0117 extern L0118 <4_31>+L0118 extern L0119 <4_31>+L0119 extern L0120 <4_31>+L0120 extern L0121 <4_31>+L0121 extern L0122 <4_31>+L0122 extern L0123 <4_31>+L0123 extern L0124 <4_31>+L0124 extern L0125 <4_31>+L0125 extern L0126 <4_31>+L0126 extern L0127 <4_31>+L0127 extern L0128 <4_31>+L0128 extern L0129 <4_31>+L0129 extern L0130 <4_31>+L0130 extern L0131 <4_31>+L0131 extern L0132 <4_31>+L0132 extern L0133 <4_31>+L0133 extern L0134 <4_31>+L0134 extern L0135 <4_31>+L0135 extern L0136 <4_31>+L0136 extern L0137 <4_31>+L0137 extern L0138 <4_31>+L0138 extern L0139 <4_31>+L0139 extern L0140 <4_31>+L0140 extern L0141 <4_31>+L0141 extern L0142 <4_31>+L0142 extern L0143 <4_31>+L0143 extern L0144 <4_31>+L0144 extern L0145 <4_31>+L0145 extern L0146 <4_31>+L0146 extern L0147 <4_31>+L0147 extern L0148 <4_31>+L0148 extern L0149 <4_31>+L0149 extern L0150 <4_31>+L0150 extern L0151 <4_31>+L0151 extern L0152 <4_31>+L0152 extern L0153 <4_31>+L0153 extern L0154 <4_31>+L0154 extern L0155 <4_31>+L0155 extern L0156 <4_31>+L0156 extern L0157 <4_31>+L0157 extern L0158 <4_31>+L0158 extern L0159 <4_31>+L0159 extern L0160 <4_31>+L0160 extern L0161 <4_31>+L0161 extern L0162 <4_31>+L0162 extern L0163 <4_31>+L0163 extern L0164 <4_31>+L0164 extern L0165 <4_31>+L0165 extern L0166 <4_31>+L0166 extern L0167 <4_31>+L0167 extern L0168 <4_31>+L0168 extern L0169 <4_31>+L0169 extern L0170 <4_31>+L0170 extern L0171 <4_31>+L0171 extern L0172 <4_31>+L0172 extern L0173 <4_31>+L0173 extern L0174 <4_31>+L0174 extern L0175 <4_31>+L0175 extern L0176 <4_31>+L0176 extern L0177 <4_31>+L0177 extern L0178 <4_31>+L0178 extern L0179 <4_31>+L0179 extern L0180 <4_31>+L0180 extern L0181 <4_31>+L0181 extern L0182 <4_31>+L0182 extern L0183 <4_31>+L0183 extern L0184 <4_31>+L0184 extern L0185 <4_31>+L0185 extern L0186 <4_31>+L0186 extern L0187 <4_31>+L0187 extern L0188 <4_31>+L0188 extern L0189 <4_31>+L0189 extern L0190 <4_31>+L0190 extern L0191 <4_31>+L0191 extern L0192 <4_31>+L0192 extern L0193 <4_31>+L0193 extern L0194 <4_31>+L0194 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 extern L0014 jrst L0014## extern MAIN. jrst MAIN.## extern INIT jrst INIT## JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 extern GETC jrst GETC## extern TIMC jrst TIMC## JRST SYMFNC+143 extern PUTC jrst PUTC## extern QUIT jrst QUIT## extern PUTINT jrst PUTINT## extern L0008 jrst L0008## extern L0009 jrst L0009## extern L0010 jrst L0010## JRST SYMFNC+143 JRST SYMFNC+143 JRST SYMFNC+143 extern FLAG jrst FLAG## extern L0011 jrst L0011## JRST SYMFNC+143 extern L0012 jrst L0012## JRST SYMFNC+143 extern L0013 jrst L0013## extern TERPRI jrst TERPRI## extern IFACT jrst IFACT## extern L0015 jrst L0015## extern L0021 jrst L0021## extern L0017 jrst L0017## extern FACT jrst FACT## extern L0022 jrst L0022## extern TAK jrst TAK## extern L0032 jrst L0032## block 339 L0003: intern L0003 162 end |
Added psl-1983/20-tests/dmain5.mac version [7b7f386fb7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 5001 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 HEAP: block 150001 intern HEAP L0183: HEAP+0 intern L0183 L0184: HEAP+150000 intern L0184 L0185: 0 intern L0185 L0186: 0 intern L0186 BPS: block 501 intern BPS L1005: BPS+0 intern L1005 L1006: BPS+0 intern L1006 L1007: BPS+500 intern L1007 L1008: BPS+500 intern L1008 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <29_31>+133 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 <29_31>+151 <29_31>+152 <29_31>+153 <30_31>+128 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 <29_31>+160 <29_31>+161 <29_31>+162 <29_31>+163 <29_31>+164 <29_31>+165 <29_31>+166 <29_31>+167 <29_31>+168 <29_31>+169 <29_31>+170 <29_31>+171 <29_31>+172 <29_31>+173 <29_31>+174 <29_31>+175 <29_31>+176 <29_31>+177 <29_31>+178 <29_31>+179 <29_31>+180 <29_31>+181 <29_31>+182 <29_31>+183 <29_31>+184 <29_31>+185 <29_31>+186 <29_31>+187 <29_31>+188 <29_31>+189 <29_31>+190 <29_31>+191 <29_31>+192 <29_31>+193 <29_31>+194 <29_31>+195 <29_31>+196 <29_31>+197 <29_31>+198 <29_31>+199 <29_31>+200 <29_31>+201 <29_31>+202 <29_31>+203 <29_31>+204 <29_31>+205 <29_31>+206 <29_31>+207 <29_31>+208 <29_31>+209 <29_31>+210 <29_31>+211 <29_31>+212 <29_31>+213 <29_31>+214 <29_31>+215 <29_31>+216 <29_31>+217 <29_31>+218 <29_31>+219 <29_31>+220 <29_31>+221 <29_31>+222 <29_31>+223 <29_31>+224 <29_31>+225 <29_31>+226 <29_31>+227 <29_31>+228 <29_31>+229 <29_31>+230 <29_31>+231 <29_31>+232 <29_31>+233 <29_31>+234 <29_31>+235 <29_31>+236 <29_31>+237 <29_31>+238 <29_31>+239 <29_31>+240 <30_31>+128 <29_31>+242 <30_31>+128 <30_31>+128 <29_31>+245 <29_31>+246 <29_31>+247 <29_31>+248 <29_31>+249 <29_31>+250 <29_31>+251 <29_31>+252 <29_31>+253 <29_31>+254 <29_31>+255 <29_31>+256 <29_31>+257 <29_31>+258 <29_31>+259 <29_31>+260 <29_31>+261 <29_31>+262 <29_31>+263 <29_31>+264 <29_31>+265 <29_31>+266 <29_31>+267 <29_31>+268 <29_31>+269 <29_31>+270 <29_31>+271 <29_31>+272 <29_31>+273 <29_31>+274 <29_31>+275 <29_31>+276 <29_31>+277 <29_31>+278 <29_31>+279 <29_31>+280 <29_31>+281 <29_31>+282 <29_31>+283 <29_31>+284 <29_31>+285 <29_31>+286 <29_31>+287 <29_31>+288 <29_31>+289 <29_31>+290 <29_31>+291 <29_31>+292 <29_31>+293 <29_31>+294 <29_31>+295 <29_31>+296 <29_31>+297 <29_31>+298 <29_31>+299 <29_31>+300 <29_31>+301 <29_31>+302 <29_31>+303 <29_31>+304 <29_31>+305 <29_31>+306 <29_31>+307 <29_31>+308 <29_31>+309 <29_31>+310 <29_31>+311 <29_31>+312 <29_31>+313 <29_31>+314 <29_31>+315 <29_31>+316 <29_31>+317 <29_31>+318 <29_31>+319 <29_31>+320 <29_31>+321 <29_31>+322 <29_31>+323 <29_31>+324 <29_31>+325 <29_31>+326 <29_31>+327 <29_31>+328 <29_31>+329 <29_31>+330 <29_31>+331 <29_31>+332 <29_31>+333 <29_31>+334 <29_31>+335 <29_31>+336 <29_31>+337 <29_31>+338 <29_31>+339 <29_31>+340 <29_31>+341 <30_31>+128 <29_31>+343 <29_31>+344 <29_31>+345 <29_31>+346 <29_31>+347 <29_31>+348 <30_31>+128 <30_31>+128 <29_31>+351 <29_31>+352 <29_31>+353 <29_31>+354 <29_31>+355 <29_31>+356 <29_31>+357 <29_31>+358 <29_31>+359 <29_31>+360 <29_31>+361 <29_31>+362 <30_31>+26 <29_31>+364 <29_31>+365 <29_31>+366 <29_31>+367 <29_31>+368 <29_31>+369 <29_31>+370 block 130 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 130 SYMNAM: intern SYMNAM extern L1105 <4_31>+L1105 extern L1106 <4_31>+L1106 extern L1107 <4_31>+L1107 extern L1108 <4_31>+L1108 extern L1109 <4_31>+L1109 extern L1110 <4_31>+L1110 extern L1111 <4_31>+L1111 extern L1112 <4_31>+L1112 extern L1113 <4_31>+L1113 extern L1114 <4_31>+L1114 extern L1115 <4_31>+L1115 extern L1116 <4_31>+L1116 extern L1117 <4_31>+L1117 extern L1118 <4_31>+L1118 extern L1119 <4_31>+L1119 extern L1120 <4_31>+L1120 extern L1121 <4_31>+L1121 extern L1122 <4_31>+L1122 extern L1123 <4_31>+L1123 extern L1124 <4_31>+L1124 extern L1125 <4_31>+L1125 extern L1126 <4_31>+L1126 extern L1127 <4_31>+L1127 extern L1128 <4_31>+L1128 extern L1129 <4_31>+L1129 extern L1130 <4_31>+L1130 extern L1131 <4_31>+L1131 extern L1132 <4_31>+L1132 extern L1133 <4_31>+L1133 extern L1134 <4_31>+L1134 extern L1135 <4_31>+L1135 extern L1136 <4_31>+L1136 extern L1137 <4_31>+L1137 extern L1138 <4_31>+L1138 extern L1139 <4_31>+L1139 extern L1140 <4_31>+L1140 extern L1141 <4_31>+L1141 extern L1142 <4_31>+L1142 extern L1143 <4_31>+L1143 extern L1144 <4_31>+L1144 extern L1145 <4_31>+L1145 extern L1146 <4_31>+L1146 extern L1147 <4_31>+L1147 extern L1148 <4_31>+L1148 extern L1149 <4_31>+L1149 extern L1150 <4_31>+L1150 extern L1151 <4_31>+L1151 extern L1152 <4_31>+L1152 extern L1153 <4_31>+L1153 extern L1154 <4_31>+L1154 extern L1155 <4_31>+L1155 extern L1156 <4_31>+L1156 extern L1157 <4_31>+L1157 extern L1158 <4_31>+L1158 extern L1159 <4_31>+L1159 extern L1160 <4_31>+L1160 extern L1161 <4_31>+L1161 extern L1162 <4_31>+L1162 extern L1163 <4_31>+L1163 extern L1164 <4_31>+L1164 extern L1165 <4_31>+L1165 extern L1166 <4_31>+L1166 extern L1167 <4_31>+L1167 extern L1168 <4_31>+L1168 extern L1169 <4_31>+L1169 extern L1170 <4_31>+L1170 extern L1171 <4_31>+L1171 extern L1172 <4_31>+L1172 extern L1173 <4_31>+L1173 extern L1174 <4_31>+L1174 extern L1175 <4_31>+L1175 extern L1176 <4_31>+L1176 extern L1177 <4_31>+L1177 extern L1178 <4_31>+L1178 extern L1179 <4_31>+L1179 extern L1180 <4_31>+L1180 extern L1181 <4_31>+L1181 extern L1182 <4_31>+L1182 extern L1183 <4_31>+L1183 extern L1184 <4_31>+L1184 extern L1185 <4_31>+L1185 extern L1186 <4_31>+L1186 extern L1187 <4_31>+L1187 extern L1188 <4_31>+L1188 extern L1189 <4_31>+L1189 extern L1190 <4_31>+L1190 extern L1191 <4_31>+L1191 extern L1192 <4_31>+L1192 extern L1193 <4_31>+L1193 extern L1194 <4_31>+L1194 extern L1195 <4_31>+L1195 extern L1196 <4_31>+L1196 extern L1197 <4_31>+L1197 extern L1198 <4_31>+L1198 extern L1199 <4_31>+L1199 extern L1200 <4_31>+L1200 extern L1201 <4_31>+L1201 extern L1202 <4_31>+L1202 extern L1203 <4_31>+L1203 extern L1204 <4_31>+L1204 extern L1205 <4_31>+L1205 extern L1206 <4_31>+L1206 extern L1207 <4_31>+L1207 extern L1208 <4_31>+L1208 extern L1209 <4_31>+L1209 extern L1210 <4_31>+L1210 extern L1211 <4_31>+L1211 extern L1212 <4_31>+L1212 extern L1213 <4_31>+L1213 extern L1214 <4_31>+L1214 extern L1215 <4_31>+L1215 extern L1216 <4_31>+L1216 extern L1217 <4_31>+L1217 extern L1218 <4_31>+L1218 extern L1219 <4_31>+L1219 extern L1220 <4_31>+L1220 extern L1221 <4_31>+L1221 extern L1222 <4_31>+L1222 extern L1223 <4_31>+L1223 extern L1224 <4_31>+L1224 extern L1225 <4_31>+L1225 extern L1226 <4_31>+L1226 extern L1227 <4_31>+L1227 extern L1228 <4_31>+L1228 extern L1229 <4_31>+L1229 extern L1230 <4_31>+L1230 extern L1231 <4_31>+L1231 extern L1232 <4_31>+L1232 extern L1233 <4_31>+L1233 extern L1234 <4_31>+L1234 extern L1235 <4_31>+L1235 extern L1236 <4_31>+L1236 extern L1237 <4_31>+L1237 extern L1238 <4_31>+L1238 extern L1239 <4_31>+L1239 extern L1240 <4_31>+L1240 extern L1241 <4_31>+L1241 extern L1242 <4_31>+L1242 extern L1243 <4_31>+L1243 extern L1244 <4_31>+L1244 extern L1245 <4_31>+L1245 extern L1246 <4_31>+L1246 extern L1247 <4_31>+L1247 extern L1248 <4_31>+L1248 extern L1249 <4_31>+L1249 extern L1250 <4_31>+L1250 extern L1251 <4_31>+L1251 extern L1252 <4_31>+L1252 extern L1253 <4_31>+L1253 extern L1254 <4_31>+L1254 extern L1255 <4_31>+L1255 extern L1256 <4_31>+L1256 extern L1257 <4_31>+L1257 extern L1258 <4_31>+L1258 extern L1259 <4_31>+L1259 extern L1260 <4_31>+L1260 extern L1261 <4_31>+L1261 extern L1262 <4_31>+L1262 extern L1263 <4_31>+L1263 extern L1264 <4_31>+L1264 extern L1265 <4_31>+L1265 extern L1266 <4_31>+L1266 extern L1267 <4_31>+L1267 extern L1268 <4_31>+L1268 extern L1269 <4_31>+L1269 extern L1270 <4_31>+L1270 extern L1271 <4_31>+L1271 extern L1272 <4_31>+L1272 extern L1273 <4_31>+L1273 extern L1274 <4_31>+L1274 extern L1275 <4_31>+L1275 extern L1276 <4_31>+L1276 extern L1277 <4_31>+L1277 extern L1278 <4_31>+L1278 extern L1279 <4_31>+L1279 extern L1280 <4_31>+L1280 extern L1281 <4_31>+L1281 extern L1282 <4_31>+L1282 extern L1283 <4_31>+L1283 extern L1284 <4_31>+L1284 extern L1285 <4_31>+L1285 extern L1286 <4_31>+L1286 extern L1287 <4_31>+L1287 extern L1288 <4_31>+L1288 extern L1289 <4_31>+L1289 extern L1290 <4_31>+L1290 extern L1291 <4_31>+L1291 extern L1292 <4_31>+L1292 extern L1293 <4_31>+L1293 extern L1294 <4_31>+L1294 extern L1295 <4_31>+L1295 extern L1296 <4_31>+L1296 extern L1297 <4_31>+L1297 extern L1298 <4_31>+L1298 extern L1299 <4_31>+L1299 extern L1300 <4_31>+L1300 extern L1301 <4_31>+L1301 extern L1302 <4_31>+L1302 extern L1303 <4_31>+L1303 extern L1304 <4_31>+L1304 extern L1305 <4_31>+L1305 extern L1306 <4_31>+L1306 extern L1307 <4_31>+L1307 extern L1308 <4_31>+L1308 extern L1309 <4_31>+L1309 extern L1310 <4_31>+L1310 extern L1311 <4_31>+L1311 extern L1312 <4_31>+L1312 extern L1313 <4_31>+L1313 extern L1314 <4_31>+L1314 extern L1315 <4_31>+L1315 extern L1316 <4_31>+L1316 extern L1317 <4_31>+L1317 extern L1318 <4_31>+L1318 extern L1319 <4_31>+L1319 extern L1320 <4_31>+L1320 extern L1321 <4_31>+L1321 extern L1322 <4_31>+L1322 extern L1323 <4_31>+L1323 extern L1324 <4_31>+L1324 extern L1325 <4_31>+L1325 extern L1326 <4_31>+L1326 extern L1327 <4_31>+L1327 extern L1328 <4_31>+L1328 extern L1329 <4_31>+L1329 extern L1330 <4_31>+L1330 extern L1331 <4_31>+L1331 extern L1332 <4_31>+L1332 extern L1333 <4_31>+L1333 extern L1334 <4_31>+L1334 extern L1335 <4_31>+L1335 extern L1336 <4_31>+L1336 extern L1337 <4_31>+L1337 extern L1338 <4_31>+L1338 extern L1339 <4_31>+L1339 extern L1340 <4_31>+L1340 extern L1341 <4_31>+L1341 extern L1342 <4_31>+L1342 extern L1343 <4_31>+L1343 extern L1344 <4_31>+L1344 extern L1345 <4_31>+L1345 extern L1346 <4_31>+L1346 extern L1347 <4_31>+L1347 extern L1348 <4_31>+L1348 extern L1349 <4_31>+L1349 extern L1350 <4_31>+L1350 extern L1351 <4_31>+L1351 extern L1352 <4_31>+L1352 extern L1353 <4_31>+L1353 extern L1354 <4_31>+L1354 extern L1355 <4_31>+L1355 extern L1356 <4_31>+L1356 extern L1357 <4_31>+L1357 extern L1358 <4_31>+L1358 extern L1359 <4_31>+L1359 extern L1360 <4_31>+L1360 extern L1361 <4_31>+L1361 extern L1362 <4_31>+L1362 extern L1363 <4_31>+L1363 extern L1364 <4_31>+L1364 extern L1365 <4_31>+L1365 extern L1366 <4_31>+L1366 extern L1367 <4_31>+L1367 extern L1368 <4_31>+L1368 extern L1369 <4_31>+L1369 extern L1370 <4_31>+L1370 extern L1371 <4_31>+L1371 extern L1372 <4_31>+L1372 extern L1373 <4_31>+L1373 extern L1374 <4_31>+L1374 extern L1375 <4_31>+L1375 extern L1376 <4_31>+L1376 extern L1377 <4_31>+L1377 extern L1378 <4_31>+L1378 extern L1379 <4_31>+L1379 extern L1380 <4_31>+L1380 extern L1381 <4_31>+L1381 extern L1382 <4_31>+L1382 extern L1383 <4_31>+L1383 extern L1384 <4_31>+L1384 extern L1385 <4_31>+L1385 extern L1386 <4_31>+L1386 extern L1387 <4_31>+L1387 extern L1388 <4_31>+L1388 extern L1389 <4_31>+L1389 extern L1390 <4_31>+L1390 extern L1391 <4_31>+L1391 extern L1392 <4_31>+L1392 extern L1393 <4_31>+L1393 extern L1394 <4_31>+L1394 extern L1395 <4_31>+L1395 extern L1396 <4_31>+L1396 extern L1397 <4_31>+L1397 extern L1398 <4_31>+L1398 extern L1399 <4_31>+L1399 extern L1400 <4_31>+L1400 extern L1401 <4_31>+L1401 extern L1402 <4_31>+L1402 extern L1403 <4_31>+L1403 extern L1404 <4_31>+L1404 extern L1405 <4_31>+L1405 extern L1406 <4_31>+L1406 extern L1407 <4_31>+L1407 extern L1408 <4_31>+L1408 extern L1409 <4_31>+L1409 extern L1410 <4_31>+L1410 extern L1411 <4_31>+L1411 extern L1412 <4_31>+L1412 extern L1413 <4_31>+L1413 extern L1414 <4_31>+L1414 extern L1415 <4_31>+L1415 extern L1416 <4_31>+L1416 extern L1417 <4_31>+L1417 extern L1418 <4_31>+L1418 extern L1419 <4_31>+L1419 extern L1420 <4_31>+L1420 extern L1421 <4_31>+L1421 extern L1422 <4_31>+L1422 extern L1423 <4_31>+L1423 extern L1424 <4_31>+L1424 extern L1425 <4_31>+L1425 extern L1426 <4_31>+L1426 extern L1427 <4_31>+L1427 extern L1428 <4_31>+L1428 extern L1429 <4_31>+L1429 extern L1430 <4_31>+L1430 extern L1431 <4_31>+L1431 extern L1432 <4_31>+L1432 extern L1433 <4_31>+L1433 extern L1434 <4_31>+L1434 extern L1435 <4_31>+L1435 extern L1436 <4_31>+L1436 extern L1437 <4_31>+L1437 extern L1438 <4_31>+L1438 extern L1439 <4_31>+L1439 extern L1440 <4_31>+L1440 extern L1441 <4_31>+L1441 extern L1442 <4_31>+L1442 extern L1443 <4_31>+L1443 extern L1444 <4_31>+L1444 extern L1445 <4_31>+L1445 extern L1446 <4_31>+L1446 extern L1447 <4_31>+L1447 extern L1448 <4_31>+L1448 extern L1449 <4_31>+L1449 extern L1450 <4_31>+L1450 extern L1451 <4_31>+L1451 extern L1452 <4_31>+L1452 extern L1453 <4_31>+L1453 extern L1454 <4_31>+L1454 extern L1455 <4_31>+L1455 extern L1456 <4_31>+L1456 extern L1457 <4_31>+L1457 extern L1458 <4_31>+L1458 extern L1459 <4_31>+L1459 extern L1460 <4_31>+L1460 extern L1461 <4_31>+L1461 extern L1462 <4_31>+L1462 extern L1463 <4_31>+L1463 extern L1464 <4_31>+L1464 extern L1465 <4_31>+L1465 extern L1466 <4_31>+L1466 extern L1467 <4_31>+L1467 extern L1468 <4_31>+L1468 extern L1469 <4_31>+L1469 extern L1470 <4_31>+L1470 extern L1471 <4_31>+L1471 extern L1472 <4_31>+L1472 extern L1473 <4_31>+L1473 extern L1474 <4_31>+L1474 extern L1475 <4_31>+L1475 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 extern L0024 jrst L0024## extern L0017 jrst L0017## extern L0026 jrst L0026## extern L0034 jrst L0034## extern PRTITM jrst PRTITM## extern PRIN1 jrst PRIN1## extern L0025 jrst L0025## extern L0028 jrst L0028## extern L0042 jrst L0042## extern PRIN2 jrst PRIN2## extern TERPRI jrst TERPRI## extern PRINT jrst PRINT## extern PRIN2T jrst PRIN2T## extern PUTC jrst PUTC## extern PBLANK jrst PBLANK## extern L0021 jrst L0021## extern L1022 jrst L1022## extern L1023 jrst L1023## JRST SYMFNC+348 extern QUIT jrst QUIT## extern ERROR jrst ERROR## extern L0093 jrst L0093## extern L0094 jrst L0094## JRST SYMFNC+348 extern L0095 jrst L0095## JRST SYMFNC+348 extern L0098 jrst L0098## extern L0099 jrst L0099## extern L0102 jrst L0102## extern L0103 jrst L0103## extern L0106 jrst L0106## JRST SYMFNC+348 extern L0156 jrst L0156## extern L0165 jrst L0165## JRST SYMFNC+348 JRST SYMFNC+348 extern L0172 jrst L0172## JRST SYMFNC+348 JRST SYMFNC+348 extern L1101 jrst L1101## extern L0177 jrst L0177## extern L0182 jrst L0182## JRST SYMFNC+348 extern L1026 jrst L1026## extern GTHEAP jrst GTHEAP## extern GTSTR jrst GTSTR## extern GTVECT jrst GTVECT## extern L0191 jrst L0191## extern GTID jrst GTID## extern L0192 jrst L0192## extern CONS jrst CONS## extern XCONS jrst XCONS## extern NCONS jrst NCONS## extern MKVECT jrst MKVECT## extern LIST2 jrst LIST2## extern LIST3 jrst LIST3## extern LIST4 jrst LIST4## extern LIST5 jrst LIST5## JRST SYMFNC+348 extern L0209 jrst L0209## extern EQSTR jrst EQSTR## extern L0222 jrst L0222## JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 extern L0224 jrst L0224## extern L0230 jrst L0230## extern L0233 jrst L0233## extern L0246 jrst L0246## extern DIGITP jrst DIGITP## extern L0237 jrst L0237## extern L0297 jrst L0297## extern READID jrst READID## extern RATOM jrst RATOM## extern WHITEP jrst WHITEP## extern GETC jrst GETC## extern L1021 jrst L1021## extern L0241 jrst L0241## extern L0252 jrst L0252## extern L0301 jrst L0301## extern INTERN jrst INTERN## extern L0295 jrst L0295## extern ALPHAP jrst ALPHAP## extern L0291 jrst L0291## extern L0270 jrst L0270## extern L0263 jrst L0263## extern L0330 jrst L0330## extern L0287 jrst L0287## extern L0299 jrst L0299## extern READ1 jrst READ1## extern READ jrst READ## extern L0310 jrst L0310## extern QUOTE jrst QUOTE## JRST SYMFNC+348 extern L0321 jrst L0321## JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 extern L0325 jrst L0325## extern L1019 jrst L1019## extern L0360 jrst L0360## extern L0334 jrst L0334## extern L1018 jrst L1018## extern L0339 jrst L0339## extern FCODEP jrst FCODEP## extern L0350 jrst L0350## extern L0355 jrst L0355## extern L0359 jrst L0359## JRST SYMFNC+348 extern L0370 jrst L0370## JRST SYMFNC+348 JRST SYMFNC+348 extern L0436 jrst L0436## extern L0365 jrst L0365## extern L0437 jrst L0437## JRST SYMFNC+348 extern L0371 jrst L0371## extern L1060 jrst L1060## extern L0375 jrst L0375## extern L0398 jrst L0398## extern L0402 jrst L0402## extern EVAL jrst EVAL## extern L0429 jrst L0429## extern L0425 jrst L0425## extern LBIND1 jrst LBIND1## extern GET jrst GET## extern L0443 jrst L0443## JRST SYMFNC+348 JRST SYMFNC+348 extern L0515 jrst L0515## extern L0674 jrst L0674## extern PLUS2 jrst PLUS2## extern MINUS jrst MINUS## JRST SYMFNC+348 JRST SYMFNC+348 extern ADD1 jrst ADD1## JRST SYMFNC+348 extern SUB1 jrst SUB1## extern L0471 jrst L0471## extern LESSP jrst LESSP## extern L0483 jrst L0483## extern TIMES2 jrst TIMES2## extern CAR jrst CAR## extern CDR jrst CDR## extern CAAR jrst CAAR## extern CADR jrst CADR## extern CDAR jrst CDAR## extern CDDR jrst CDDR## extern ATOM jrst ATOM## extern APPEND jrst APPEND## extern MEMQ jrst MEMQ## extern L0509 jrst L0509## extern EVLIS jrst EVLIS## extern PROGN jrst PROGN## extern EVCOND jrst EVCOND## extern COND jrst COND## extern SET jrst SET## extern SETQ jrst SETQ## JRST SYMFNC+348 extern DE jrst DE## JRST SYMFNC+348 extern DF jrst DF## JRST SYMFNC+348 extern DN jrst DN## JRST SYMFNC+348 extern DM jrst DM## JRST SYMFNC+348 extern LIST jrst LIST## extern ATSOC jrst ATSOC## extern GEQ jrst GEQ## extern LEQ jrst LEQ## extern EQCAR jrst EQCAR## JRST SYMFNC+348 extern COPYD jrst COPYD## extern DELATQ jrst DELATQ## extern PUT jrst PUT## extern L0569 jrst L0569## extern WHILE jrst WHILE## JRST SYMFNC+348 extern L0614 jrst L0614## extern L0620 jrst L0620## extern L0604 jrst L0604## extern L0665 jrst L0665## extern L0603 jrst L0603## extern APPLY jrst APPLY## extern L0607 jrst L0607## extern LENGTH jrst LENGTH## extern CODEP jrst CODEP## extern PAIRP jrst PAIRP## extern IDP jrst IDP## extern EQ jrst EQ## extern NULL jrst NULL## extern NOT jrst NOT## extern L0634 jrst L0634## extern MAPOBL jrst MAPOBL## extern L0642 jrst L0642## extern L0643 jrst L0643## JRST SYMFNC+348 extern L0646 jrst L0646## extern L0647 jrst L0647## extern PROP jrst PROP## extern L0660 jrst L0660## extern L0679 jrst L0679## JRST SYMFNC+348 JRST SYMFNC+348 extern L1009 jrst L1009## extern L1076 jrst L1076## extern MAIN. jrst MAIN.## extern INIT jrst INIT## JRST SYMFNC+348 JRST SYMFNC+348 extern TIMC jrst TIMC## extern DATE jrst DATE## extern L1017 jrst L1017## extern PUTINT jrst PUTINT## extern L1020 jrst L1020## JRST SYMFNC+348 JRST SYMFNC+348 extern FLAG jrst FLAG## JRST SYMFNC+348 extern L1034 jrst L1034## extern L1029 jrst L1029## extern SPACED jrst SPACED## extern DASHED jrst DASHED## extern DOTTED jrst DOTTED## extern L1051 jrst L1051## extern INF jrst INF## extern TAG jrst TAG## extern MKITEM jrst MKITEM## extern L1095 jrst L1095## JRST SYMFNC+348 JRST SYMFNC+348 extern L1098 jrst L1098## extern L1083 jrst L1083## JRST SYMFNC+348 JRST SYMFNC+348 JRST SYMFNC+348 extern L1104 jrst L1104## block 130 L0003: intern L0003 371 end |
Added psl-1983/20-tests/dmain5.rel version [d9511929ca].
cannot compute difference between binary files
Added psl-1983/20-tests/dmain6.mac version [03b5911709].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 5001 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 HEAP: block 150001 intern HEAP L0183: HEAP+0 intern L0183 L0184: HEAP+150000 intern L0184 L0185: 0 intern L0185 L0186: 0 intern L0186 BPS: block 501 intern BPS L1074: BPS+0 intern L1074 L1075: BPS+0 intern L1075 L1076: BPS+500 intern L1076 L1077: BPS+500 intern L1077 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <29_31>+133 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 <29_31>+151 <29_31>+152 <29_31>+153 <30_31>+128 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 <29_31>+160 <29_31>+161 <29_31>+162 <29_31>+163 <29_31>+164 <29_31>+165 <29_31>+166 <29_31>+167 <29_31>+168 <29_31>+169 <29_31>+170 <29_31>+171 <29_31>+172 <29_31>+173 <29_31>+174 <29_31>+175 <29_31>+176 <29_31>+177 <29_31>+178 <29_31>+179 <29_31>+180 <29_31>+181 <29_31>+182 <29_31>+183 <29_31>+184 <29_31>+185 <29_31>+186 <29_31>+187 <29_31>+188 <29_31>+189 <29_31>+190 <29_31>+191 <29_31>+192 <29_31>+193 <29_31>+194 <29_31>+195 <29_31>+196 <29_31>+197 <29_31>+198 <29_31>+199 <29_31>+200 <29_31>+201 <29_31>+202 <29_31>+203 <29_31>+204 <29_31>+205 <29_31>+206 <29_31>+207 <29_31>+208 <29_31>+209 <29_31>+210 <29_31>+211 <29_31>+212 <29_31>+213 <29_31>+214 <29_31>+215 <29_31>+216 <29_31>+217 <29_31>+218 <29_31>+219 <29_31>+220 <29_31>+221 <29_31>+222 <29_31>+223 <29_31>+224 <29_31>+225 <29_31>+226 <29_31>+227 <29_31>+228 <29_31>+229 <29_31>+230 <29_31>+231 <29_31>+232 <29_31>+233 <29_31>+234 <29_31>+235 <29_31>+236 <29_31>+237 <29_31>+238 <29_31>+239 <29_31>+240 <30_31>+128 <29_31>+242 <30_31>+128 <30_31>+128 <29_31>+245 <29_31>+246 <29_31>+247 <29_31>+248 <29_31>+249 <29_31>+250 <29_31>+251 <29_31>+252 <29_31>+253 <29_31>+254 <29_31>+255 <29_31>+256 <29_31>+257 <29_31>+258 <29_31>+259 <29_31>+260 <29_31>+261 <29_31>+262 <29_31>+263 <29_31>+264 <29_31>+265 <29_31>+266 <29_31>+267 <29_31>+268 <29_31>+269 <29_31>+270 <29_31>+271 <29_31>+272 <29_31>+273 <29_31>+274 <29_31>+275 <29_31>+276 <29_31>+277 <29_31>+278 <29_31>+279 <29_31>+280 <29_31>+281 <29_31>+282 <29_31>+283 <29_31>+284 <29_31>+285 <29_31>+286 <29_31>+287 <29_31>+288 <29_31>+289 <29_31>+290 <29_31>+291 <29_31>+292 <29_31>+293 <29_31>+294 <29_31>+295 <29_31>+296 <29_31>+297 <29_31>+298 <29_31>+299 <29_31>+300 <29_31>+301 <29_31>+302 <29_31>+303 <29_31>+304 <29_31>+305 <29_31>+306 <29_31>+307 <29_31>+308 <29_31>+309 <29_31>+310 <29_31>+311 <29_31>+312 <29_31>+313 <29_31>+314 <29_31>+315 <29_31>+316 <29_31>+317 <29_31>+318 <29_31>+319 <29_31>+320 <29_31>+321 <29_31>+322 <29_31>+323 <29_31>+324 <29_31>+325 <29_31>+326 <29_31>+327 <29_31>+328 <29_31>+329 <29_31>+330 <29_31>+331 <29_31>+332 <29_31>+333 <29_31>+334 <29_31>+335 <29_31>+336 <29_31>+337 <29_31>+338 <29_31>+339 <29_31>+340 <29_31>+341 <29_31>+342 <29_31>+343 <29_31>+344 <29_31>+345 <29_31>+346 <29_31>+347 <29_31>+348 <29_31>+349 <29_31>+350 <29_31>+351 <30_31>+128 <29_31>+353 <29_31>+354 <29_31>+355 <29_31>+356 <29_31>+357 <29_31>+358 <30_31>+128 <30_31>+128 <29_31>+361 <29_31>+362 <29_31>+363 <29_31>+364 <29_31>+365 <29_31>+366 <29_31>+367 <29_31>+368 <29_31>+369 <29_31>+370 <29_31>+371 <29_31>+372 <29_31>+373 <29_31>+374 <30_31>+26 <29_31>+376 <29_31>+377 <29_31>+378 <29_31>+379 <29_31>+380 <29_31>+381 <29_31>+382 <29_31>+383 <29_31>+384 <29_31>+385 <29_31>+386 <29_31>+387 <29_31>+388 <29_31>+389 <29_31>+390 <29_31>+391 <29_31>+392 <30_31>+128 <30_31>+128 <29_31>+395 <29_31>+396 <29_31>+397 <29_31>+398 <29_31>+399 <29_31>+400 <29_31>+401 <29_31>+402 <29_31>+403 <29_31>+404 <29_31>+405 <29_31>+406 <29_31>+407 <29_31>+408 <29_31>+409 <29_31>+410 <29_31>+411 <29_31>+412 block 88 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 88 SYMNAM: intern SYMNAM extern L1305 <4_31>+L1305 extern L1306 <4_31>+L1306 extern L1307 <4_31>+L1307 extern L1308 <4_31>+L1308 extern L1309 <4_31>+L1309 extern L1310 <4_31>+L1310 extern L1311 <4_31>+L1311 extern L1312 <4_31>+L1312 extern L1313 <4_31>+L1313 extern L1314 <4_31>+L1314 extern L1315 <4_31>+L1315 extern L1316 <4_31>+L1316 extern L1317 <4_31>+L1317 extern L1318 <4_31>+L1318 extern L1319 <4_31>+L1319 extern L1320 <4_31>+L1320 extern L1321 <4_31>+L1321 extern L1322 <4_31>+L1322 extern L1323 <4_31>+L1323 extern L1324 <4_31>+L1324 extern L1325 <4_31>+L1325 extern L1326 <4_31>+L1326 extern L1327 <4_31>+L1327 extern L1328 <4_31>+L1328 extern L1329 <4_31>+L1329 extern L1330 <4_31>+L1330 extern L1331 <4_31>+L1331 extern L1332 <4_31>+L1332 extern L1333 <4_31>+L1333 extern L1334 <4_31>+L1334 extern L1335 <4_31>+L1335 extern L1336 <4_31>+L1336 extern L1337 <4_31>+L1337 extern L1338 <4_31>+L1338 extern L1339 <4_31>+L1339 extern L1340 <4_31>+L1340 extern L1341 <4_31>+L1341 extern L1342 <4_31>+L1342 extern L1343 <4_31>+L1343 extern L1344 <4_31>+L1344 extern L1345 <4_31>+L1345 extern L1346 <4_31>+L1346 extern L1347 <4_31>+L1347 extern L1348 <4_31>+L1348 extern L1349 <4_31>+L1349 extern L1350 <4_31>+L1350 extern L1351 <4_31>+L1351 extern L1352 <4_31>+L1352 extern L1353 <4_31>+L1353 extern L1354 <4_31>+L1354 extern L1355 <4_31>+L1355 extern L1356 <4_31>+L1356 extern L1357 <4_31>+L1357 extern L1358 <4_31>+L1358 extern L1359 <4_31>+L1359 extern L1360 <4_31>+L1360 extern L1361 <4_31>+L1361 extern L1362 <4_31>+L1362 extern L1363 <4_31>+L1363 extern L1364 <4_31>+L1364 extern L1365 <4_31>+L1365 extern L1366 <4_31>+L1366 extern L1367 <4_31>+L1367 extern L1368 <4_31>+L1368 extern L1369 <4_31>+L1369 extern L1370 <4_31>+L1370 extern L1371 <4_31>+L1371 extern L1372 <4_31>+L1372 extern L1373 <4_31>+L1373 extern L1374 <4_31>+L1374 extern L1375 <4_31>+L1375 extern L1376 <4_31>+L1376 extern L1377 <4_31>+L1377 extern L1378 <4_31>+L1378 extern L1379 <4_31>+L1379 extern L1380 <4_31>+L1380 extern L1381 <4_31>+L1381 extern L1382 <4_31>+L1382 extern L1383 <4_31>+L1383 extern L1384 <4_31>+L1384 extern L1385 <4_31>+L1385 extern L1386 <4_31>+L1386 extern L1387 <4_31>+L1387 extern L1388 <4_31>+L1388 extern L1389 <4_31>+L1389 extern L1390 <4_31>+L1390 extern L1391 <4_31>+L1391 extern L1392 <4_31>+L1392 extern L1393 <4_31>+L1393 extern L1394 <4_31>+L1394 extern L1395 <4_31>+L1395 extern L1396 <4_31>+L1396 extern L1397 <4_31>+L1397 extern L1398 <4_31>+L1398 extern L1399 <4_31>+L1399 extern L1400 <4_31>+L1400 extern L1401 <4_31>+L1401 extern L1402 <4_31>+L1402 extern L1403 <4_31>+L1403 extern L1404 <4_31>+L1404 extern L1405 <4_31>+L1405 extern L1406 <4_31>+L1406 extern L1407 <4_31>+L1407 extern L1408 <4_31>+L1408 extern L1409 <4_31>+L1409 extern L1410 <4_31>+L1410 extern L1411 <4_31>+L1411 extern L1412 <4_31>+L1412 extern L1413 <4_31>+L1413 extern L1414 <4_31>+L1414 extern L1415 <4_31>+L1415 extern L1416 <4_31>+L1416 extern L1417 <4_31>+L1417 extern L1418 <4_31>+L1418 extern L1419 <4_31>+L1419 extern L1420 <4_31>+L1420 extern L1421 <4_31>+L1421 extern L1422 <4_31>+L1422 extern L1423 <4_31>+L1423 extern L1424 <4_31>+L1424 extern L1425 <4_31>+L1425 extern L1426 <4_31>+L1426 extern L1427 <4_31>+L1427 extern L1428 <4_31>+L1428 extern L1429 <4_31>+L1429 extern L1430 <4_31>+L1430 extern L1431 <4_31>+L1431 extern L1432 <4_31>+L1432 extern L1433 <4_31>+L1433 extern L1434 <4_31>+L1434 extern L1435 <4_31>+L1435 extern L1436 <4_31>+L1436 extern L1437 <4_31>+L1437 extern L1438 <4_31>+L1438 extern L1439 <4_31>+L1439 extern L1440 <4_31>+L1440 extern L1441 <4_31>+L1441 extern L1442 <4_31>+L1442 extern L1443 <4_31>+L1443 extern L1444 <4_31>+L1444 extern L1445 <4_31>+L1445 extern L1446 <4_31>+L1446 extern L1447 <4_31>+L1447 extern L1448 <4_31>+L1448 extern L1449 <4_31>+L1449 extern L1450 <4_31>+L1450 extern L1451 <4_31>+L1451 extern L1452 <4_31>+L1452 extern L1453 <4_31>+L1453 extern L1454 <4_31>+L1454 extern L1455 <4_31>+L1455 extern L1456 <4_31>+L1456 extern L1457 <4_31>+L1457 extern L1458 <4_31>+L1458 extern L1459 <4_31>+L1459 extern L1460 <4_31>+L1460 extern L1461 <4_31>+L1461 extern L1462 <4_31>+L1462 extern L1463 <4_31>+L1463 extern L1464 <4_31>+L1464 extern L1465 <4_31>+L1465 extern L1466 <4_31>+L1466 extern L1467 <4_31>+L1467 extern L1468 <4_31>+L1468 extern L1469 <4_31>+L1469 extern L1470 <4_31>+L1470 extern L1471 <4_31>+L1471 extern L1472 <4_31>+L1472 extern L1473 <4_31>+L1473 extern L1474 <4_31>+L1474 extern L1475 <4_31>+L1475 extern L1476 <4_31>+L1476 extern L1477 <4_31>+L1477 extern L1478 <4_31>+L1478 extern L1479 <4_31>+L1479 extern L1480 <4_31>+L1480 extern L1481 <4_31>+L1481 extern L1482 <4_31>+L1482 extern L1483 <4_31>+L1483 extern L1484 <4_31>+L1484 extern L1485 <4_31>+L1485 extern L1486 <4_31>+L1486 extern L1487 <4_31>+L1487 extern L1488 <4_31>+L1488 extern L1489 <4_31>+L1489 extern L1490 <4_31>+L1490 extern L1491 <4_31>+L1491 extern L1492 <4_31>+L1492 extern L1493 <4_31>+L1493 extern L1494 <4_31>+L1494 extern L1495 <4_31>+L1495 extern L1496 <4_31>+L1496 extern L1497 <4_31>+L1497 extern L1498 <4_31>+L1498 extern L1499 <4_31>+L1499 extern L1500 <4_31>+L1500 extern L1501 <4_31>+L1501 extern L1502 <4_31>+L1502 extern L1503 <4_31>+L1503 extern L1504 <4_31>+L1504 extern L1505 <4_31>+L1505 extern L1506 <4_31>+L1506 extern L1507 <4_31>+L1507 extern L1508 <4_31>+L1508 extern L1509 <4_31>+L1509 extern L1510 <4_31>+L1510 extern L1511 <4_31>+L1511 extern L1512 <4_31>+L1512 extern L1513 <4_31>+L1513 extern L1514 <4_31>+L1514 extern L1515 <4_31>+L1515 extern L1516 <4_31>+L1516 extern L1517 <4_31>+L1517 extern L1518 <4_31>+L1518 extern L1519 <4_31>+L1519 extern L1520 <4_31>+L1520 extern L1521 <4_31>+L1521 extern L1522 <4_31>+L1522 extern L1523 <4_31>+L1523 extern L1524 <4_31>+L1524 extern L1525 <4_31>+L1525 extern L1526 <4_31>+L1526 extern L1527 <4_31>+L1527 extern L1528 <4_31>+L1528 extern L1529 <4_31>+L1529 extern L1530 <4_31>+L1530 extern L1531 <4_31>+L1531 extern L1532 <4_31>+L1532 extern L1533 <4_31>+L1533 extern L1534 <4_31>+L1534 extern L1535 <4_31>+L1535 extern L1536 <4_31>+L1536 extern L1537 <4_31>+L1537 extern L1538 <4_31>+L1538 extern L1539 <4_31>+L1539 extern L1540 <4_31>+L1540 extern L1541 <4_31>+L1541 extern L1542 <4_31>+L1542 extern L1543 <4_31>+L1543 extern L1544 <4_31>+L1544 extern L1545 <4_31>+L1545 extern L1546 <4_31>+L1546 extern L1547 <4_31>+L1547 extern L1548 <4_31>+L1548 extern L1549 <4_31>+L1549 extern L1550 <4_31>+L1550 extern L1551 <4_31>+L1551 extern L1552 <4_31>+L1552 extern L1553 <4_31>+L1553 extern L1554 <4_31>+L1554 extern L1555 <4_31>+L1555 extern L1556 <4_31>+L1556 extern L1557 <4_31>+L1557 extern L1558 <4_31>+L1558 extern L1559 <4_31>+L1559 extern L1560 <4_31>+L1560 extern L1561 <4_31>+L1561 extern L1562 <4_31>+L1562 extern L1563 <4_31>+L1563 extern L1564 <4_31>+L1564 extern L1565 <4_31>+L1565 extern L1566 <4_31>+L1566 extern L1567 <4_31>+L1567 extern L1568 <4_31>+L1568 extern L1569 <4_31>+L1569 extern L1570 <4_31>+L1570 extern L1571 <4_31>+L1571 extern L1572 <4_31>+L1572 extern L1573 <4_31>+L1573 extern L1574 <4_31>+L1574 extern L1575 <4_31>+L1575 extern L1576 <4_31>+L1576 extern L1577 <4_31>+L1577 extern L1578 <4_31>+L1578 extern L1579 <4_31>+L1579 extern L1580 <4_31>+L1580 extern L1581 <4_31>+L1581 extern L1582 <4_31>+L1582 extern L1583 <4_31>+L1583 extern L1584 <4_31>+L1584 extern L1585 <4_31>+L1585 extern L1586 <4_31>+L1586 extern L1587 <4_31>+L1587 extern L1588 <4_31>+L1588 extern L1589 <4_31>+L1589 extern L1590 <4_31>+L1590 extern L1591 <4_31>+L1591 extern L1592 <4_31>+L1592 extern L1593 <4_31>+L1593 extern L1594 <4_31>+L1594 extern L1595 <4_31>+L1595 extern L1596 <4_31>+L1596 extern L1597 <4_31>+L1597 extern L1598 <4_31>+L1598 extern L1599 <4_31>+L1599 extern L1600 <4_31>+L1600 extern L1601 <4_31>+L1601 extern L1602 <4_31>+L1602 extern L1603 <4_31>+L1603 extern L1604 <4_31>+L1604 extern L1605 <4_31>+L1605 extern L1606 <4_31>+L1606 extern L1607 <4_31>+L1607 extern L1608 <4_31>+L1608 extern L1609 <4_31>+L1609 extern L1610 <4_31>+L1610 extern L1611 <4_31>+L1611 extern L1612 <4_31>+L1612 extern L1613 <4_31>+L1613 extern L1614 <4_31>+L1614 extern L1615 <4_31>+L1615 extern L1616 <4_31>+L1616 extern L1617 <4_31>+L1617 extern L1618 <4_31>+L1618 extern L1619 <4_31>+L1619 extern L1620 <4_31>+L1620 extern L1621 <4_31>+L1621 extern L1622 <4_31>+L1622 extern L1623 <4_31>+L1623 extern L1624 <4_31>+L1624 extern L1625 <4_31>+L1625 extern L1626 <4_31>+L1626 extern L1627 <4_31>+L1627 extern L1628 <4_31>+L1628 extern L1629 <4_31>+L1629 extern L1630 <4_31>+L1630 extern L1631 <4_31>+L1631 extern L1632 <4_31>+L1632 extern L1633 <4_31>+L1633 extern L1634 <4_31>+L1634 extern L1635 <4_31>+L1635 extern L1636 <4_31>+L1636 extern L1637 <4_31>+L1637 extern L1638 <4_31>+L1638 extern L1639 <4_31>+L1639 extern L1640 <4_31>+L1640 extern L1641 <4_31>+L1641 extern L1642 <4_31>+L1642 extern L1643 <4_31>+L1643 extern L1644 <4_31>+L1644 extern L1645 <4_31>+L1645 extern L1646 <4_31>+L1646 extern L1647 <4_31>+L1647 extern L1648 <4_31>+L1648 extern L1649 <4_31>+L1649 extern L1650 <4_31>+L1650 extern L1651 <4_31>+L1651 extern L1652 <4_31>+L1652 extern L1653 <4_31>+L1653 extern L1654 <4_31>+L1654 extern L1655 <4_31>+L1655 extern L1656 <4_31>+L1656 extern L1657 <4_31>+L1657 extern L1658 <4_31>+L1658 extern L1659 <4_31>+L1659 extern L1660 <4_31>+L1660 extern L1661 <4_31>+L1661 extern L1662 <4_31>+L1662 extern L1663 <4_31>+L1663 extern L1664 <4_31>+L1664 extern L1665 <4_31>+L1665 extern L1666 <4_31>+L1666 extern L1667 <4_31>+L1667 extern L1668 <4_31>+L1668 extern L1669 <4_31>+L1669 extern L1670 <4_31>+L1670 extern L1671 <4_31>+L1671 extern L1672 <4_31>+L1672 extern L1673 <4_31>+L1673 extern L1674 <4_31>+L1674 extern L1675 <4_31>+L1675 extern L1676 <4_31>+L1676 extern L1677 <4_31>+L1677 extern L1678 <4_31>+L1678 extern L1679 <4_31>+L1679 extern L1680 <4_31>+L1680 extern L1681 <4_31>+L1681 extern L1682 <4_31>+L1682 extern L1683 <4_31>+L1683 extern L1684 <4_31>+L1684 extern L1685 <4_31>+L1685 extern L1686 <4_31>+L1686 extern L1687 <4_31>+L1687 extern L1688 <4_31>+L1688 extern L1689 <4_31>+L1689 extern L1690 <4_31>+L1690 extern L1691 <4_31>+L1691 extern L1692 <4_31>+L1692 extern L1693 <4_31>+L1693 extern L1694 <4_31>+L1694 extern L1695 <4_31>+L1695 extern L1696 <4_31>+L1696 extern L1697 <4_31>+L1697 extern L1698 <4_31>+L1698 extern L1699 <4_31>+L1699 extern L1700 <4_31>+L1700 extern L1701 <4_31>+L1701 extern L1702 <4_31>+L1702 extern L1703 <4_31>+L1703 extern L1704 <4_31>+L1704 extern L1705 <4_31>+L1705 extern L1706 <4_31>+L1706 extern L1707 <4_31>+L1707 extern L1708 <4_31>+L1708 extern L1709 <4_31>+L1709 extern L1710 <4_31>+L1710 extern L1711 <4_31>+L1711 extern L1712 <4_31>+L1712 extern L1713 <4_31>+L1713 extern L1714 <4_31>+L1714 extern L1715 <4_31>+L1715 extern L1716 <4_31>+L1716 extern L1717 <4_31>+L1717 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 extern L0024 jrst L0024## extern L0017 jrst L0017## extern L0026 jrst L0026## extern L0034 jrst L0034## extern PRTITM jrst PRTITM## extern PRIN1 jrst PRIN1## extern L0025 jrst L0025## extern L0028 jrst L0028## extern L0042 jrst L0042## extern PRIN2 jrst PRIN2## extern TERPRI jrst TERPRI## extern PRINT jrst PRINT## extern PRIN2T jrst PRIN2T## extern PUTC jrst PUTC## extern PBLANK jrst PBLANK## extern L0021 jrst L0021## extern L1091 jrst L1091## extern L1092 jrst L1092## JRST SYMFNC+358 extern QUIT jrst QUIT## extern ERROR jrst ERROR## extern L0093 jrst L0093## extern L0094 jrst L0094## JRST SYMFNC+358 extern L0095 jrst L0095## JRST SYMFNC+358 extern L0098 jrst L0098## extern L0099 jrst L0099## extern L0102 jrst L0102## extern L0103 jrst L0103## extern L0106 jrst L0106## JRST SYMFNC+358 extern L0156 jrst L0156## extern L0165 jrst L0165## JRST SYMFNC+358 JRST SYMFNC+358 extern L0172 jrst L0172## JRST SYMFNC+358 extern L1029 jrst L1029## extern L1019 jrst L1019## extern L0177 jrst L0177## extern L0182 jrst L0182## JRST SYMFNC+358 extern L1095 jrst L1095## extern GTHEAP jrst GTHEAP## extern GTSTR jrst GTSTR## extern GTVECT jrst GTVECT## extern L0191 jrst L0191## extern GTID jrst GTID## extern L0192 jrst L0192## extern CONS jrst CONS## extern XCONS jrst XCONS## extern NCONS jrst NCONS## extern MKVECT jrst MKVECT## extern LIST2 jrst LIST2## extern LIST3 jrst LIST3## extern LIST4 jrst LIST4## extern LIST5 jrst LIST5## JRST SYMFNC+358 extern L0209 jrst L0209## extern EQSTR jrst EQSTR## extern L0222 jrst L0222## JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 extern L0224 jrst L0224## extern L0230 jrst L0230## extern L0233 jrst L0233## extern L0246 jrst L0246## extern DIGITP jrst DIGITP## extern L0237 jrst L0237## extern L0297 jrst L0297## extern READID jrst READID## extern RATOM jrst RATOM## extern WHITEP jrst WHITEP## extern GETC jrst GETC## extern L1090 jrst L1090## extern L0241 jrst L0241## extern L0252 jrst L0252## extern L0301 jrst L0301## extern INTERN jrst INTERN## extern L0295 jrst L0295## extern ALPHAP jrst ALPHAP## extern L0291 jrst L0291## extern L0270 jrst L0270## extern L0263 jrst L0263## extern L0330 jrst L0330## extern L0287 jrst L0287## extern L0299 jrst L0299## extern READ1 jrst READ1## extern READ jrst READ## extern L0310 jrst L0310## extern QUOTE jrst QUOTE## JRST SYMFNC+358 extern L0321 jrst L0321## JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 extern L0325 jrst L0325## extern L1088 jrst L1088## extern L0360 jrst L0360## extern L0334 jrst L0334## extern L1087 jrst L1087## extern L0339 jrst L0339## extern FCODEP jrst FCODEP## extern L0350 jrst L0350## extern L0355 jrst L0355## extern L0359 jrst L0359## JRST SYMFNC+358 extern L0370 jrst L0370## JRST SYMFNC+358 JRST SYMFNC+358 extern L0436 jrst L0436## extern L0365 jrst L0365## extern L0437 jrst L0437## JRST SYMFNC+358 extern L0371 jrst L0371## extern L1129 jrst L1129## extern L0375 jrst L0375## extern L0398 jrst L0398## extern L0402 jrst L0402## extern EVAL jrst EVAL## extern L0429 jrst L0429## extern L0425 jrst L0425## extern LBIND1 jrst LBIND1## extern GET jrst GET## extern L0443 jrst L0443## JRST SYMFNC+358 extern BLDMSG jrst BLDMSG## extern L0515 jrst L0515## extern L0674 jrst L0674## extern PLUS2 jrst PLUS2## extern MINUS jrst MINUS## JRST SYMFNC+358 JRST SYMFNC+358 extern ADD1 jrst ADD1## JRST SYMFNC+358 extern SUB1 jrst SUB1## extern L0471 jrst L0471## extern LESSP jrst LESSP## extern L0483 jrst L0483## extern TIMES2 jrst TIMES2## extern CAR jrst CAR## extern CDR jrst CDR## extern CAAR jrst CAAR## extern CADR jrst CADR## extern CDAR jrst CDAR## extern CDDR jrst CDDR## extern ATOM jrst ATOM## extern APPEND jrst APPEND## extern MEMQ jrst MEMQ## extern L0509 jrst L0509## extern EVLIS jrst EVLIS## extern PROGN jrst PROGN## extern EVCOND jrst EVCOND## extern COND jrst COND## extern SET jrst SET## extern SETQ jrst SETQ## extern PUTD jrst PUTD## extern DE jrst DE## JRST SYMFNC+358 extern DF jrst DF## JRST SYMFNC+358 extern DN jrst DN## JRST SYMFNC+358 extern DM jrst DM## JRST SYMFNC+358 extern LIST jrst LIST## extern ATSOC jrst ATSOC## extern GEQ jrst GEQ## extern LEQ jrst LEQ## extern EQCAR jrst EQCAR## extern GETD jrst GETD## extern COPYD jrst COPYD## extern DELATQ jrst DELATQ## extern PUT jrst PUT## extern L0569 jrst L0569## extern WHILE jrst WHILE## JRST SYMFNC+358 extern L0614 jrst L0614## extern L0620 jrst L0620## extern L0604 jrst L0604## extern L0665 jrst L0665## extern L0603 jrst L0603## extern APPLY jrst APPLY## extern L0607 jrst L0607## extern LENGTH jrst LENGTH## extern CODEP jrst CODEP## extern PAIRP jrst PAIRP## extern IDP jrst IDP## extern EQ jrst EQ## extern NULL jrst NULL## extern NOT jrst NOT## extern L0634 jrst L0634## extern MAPOBL jrst MAPOBL## extern L0642 jrst L0642## extern L0643 jrst L0643## JRST SYMFNC+358 extern L0646 jrst L0646## extern L0647 jrst L0647## extern PROP jrst PROP## extern L0660 jrst L0660## extern L0679 jrst L0679## JRST SYMFNC+358 JRST SYMFNC+358 extern RESET jrst RESET## extern L1010 jrst L1010## JRST SYMFNC+358 extern L1013 jrst L1013## extern L1014 jrst L1014## extern L1015 jrst L1015## JRST SYMFNC+358 extern L1018 jrst L1018## extern PBIND1 jrst PBIND1## extern L1032 jrst L1032## extern L1078 jrst L1078## extern L1148 jrst L1148## extern MAIN. jrst MAIN.## extern INIT jrst INIT## JRST SYMFNC+358 JRST SYMFNC+358 extern TIMC jrst TIMC## extern DATE jrst DATE## extern L1086 jrst L1086## extern PUTINT jrst PUTINT## extern L1089 jrst L1089## JRST SYMFNC+358 JRST SYMFNC+358 extern FLAG jrst FLAG## JRST SYMFNC+358 extern L1103 jrst L1103## extern L1098 jrst L1098## extern SPACED jrst SPACED## extern DASHED jrst DASHED## extern DOTTED jrst DOTTED## extern L1120 jrst L1120## extern INF jrst INF## extern TAG jrst TAG## extern MKITEM jrst MKITEM## extern TIME jrst TIME## extern L1134 jrst L1134## extern L1304 jrst L1304## JRST SYMFNC+358 extern L1163 jrst L1163## extern L1244 jrst L1244## extern L1282 jrst L1282## extern L1153 jrst L1153## JRST SYMFNC+358 extern L1254 jrst L1254## JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 extern L1270 jrst L1270## extern L1262 jrst L1262## JRST SYMFNC+358 extern L1245 jrst L1245## JRST SYMFNC+358 extern CBIND1 jrst CBIND1## JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 JRST SYMFNC+358 extern CBIND2 jrst CBIND2## JRST SYMFNC+358 JRST SYMFNC+358 block 88 L0003: intern L0003 413 end |
Added psl-1983/20-tests/dmain6.rel version [deac27c49a].
cannot compute difference between binary files
Added psl-1983/20-tests/dmain7.mac version [fa17cc9ee6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 | radix 10 STACK: block 5001 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 HEAP: block 150001 intern HEAP L0183: HEAP+0 intern L0183 L0184: HEAP+150000 intern L0184 L0185: 0 intern L0185 L0186: 0 intern L0186 BPS: block 501 intern BPS L1185: BPS+0 intern L1185 L1186: BPS+0 intern L1186 L1187: BPS+500 intern L1187 L1188: BPS+500 intern L1188 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <29_31>+133 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 <29_31>+151 <29_31>+152 <29_31>+153 1 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 <29_31>+160 <29_31>+161 <29_31>+162 <29_31>+163 <29_31>+164 <29_31>+165 <29_31>+166 <29_31>+167 <29_31>+168 <29_31>+169 <29_31>+170 <29_31>+171 <29_31>+172 <29_31>+173 <29_31>+174 <29_31>+175 <29_31>+176 <29_31>+177 <29_31>+178 <29_31>+179 <29_31>+180 <29_31>+181 <29_31>+182 <29_31>+183 <29_31>+184 <29_31>+185 <29_31>+186 <29_31>+187 <29_31>+188 <29_31>+189 <29_31>+190 <29_31>+191 <29_31>+192 <29_31>+193 <29_31>+194 <29_31>+195 <29_31>+196 <29_31>+197 <29_31>+198 <29_31>+199 <29_31>+200 <29_31>+201 <29_31>+202 <29_31>+203 <29_31>+204 <29_31>+205 <29_31>+206 <29_31>+207 <29_31>+208 <29_31>+209 <29_31>+210 <29_31>+211 <29_31>+212 <29_31>+213 <29_31>+214 <29_31>+215 <29_31>+216 <29_31>+217 <29_31>+218 <29_31>+219 <29_31>+220 <29_31>+221 <29_31>+222 <29_31>+223 <29_31>+224 <29_31>+225 <29_31>+226 <29_31>+227 <29_31>+228 <29_31>+229 <29_31>+230 <29_31>+231 <29_31>+232 <29_31>+233 <29_31>+234 <29_31>+235 <29_31>+236 <29_31>+237 <29_31>+238 <29_31>+239 <29_31>+240 <30_31>+128 <29_31>+242 <30_31>+128 <30_31>+128 <29_31>+245 <29_31>+246 <29_31>+247 <29_31>+248 <29_31>+249 <29_31>+250 <29_31>+251 <29_31>+252 <29_31>+253 <29_31>+254 <29_31>+255 <29_31>+256 <29_31>+257 <29_31>+258 <29_31>+259 <29_31>+260 <29_31>+261 <29_31>+262 <29_31>+263 <29_31>+264 <29_31>+265 <29_31>+266 <29_31>+267 <29_31>+268 <29_31>+269 <29_31>+270 <29_31>+271 <29_31>+272 <29_31>+273 <29_31>+274 <29_31>+275 <29_31>+276 <29_31>+277 <29_31>+278 <29_31>+279 <29_31>+280 <29_31>+281 <29_31>+282 <29_31>+283 <29_31>+284 <29_31>+285 <29_31>+286 <29_31>+287 <29_31>+288 <29_31>+289 <29_31>+290 <29_31>+291 <29_31>+292 <29_31>+293 <29_31>+294 <29_31>+295 <29_31>+296 <29_31>+297 <29_31>+298 <29_31>+299 <29_31>+300 <29_31>+301 <29_31>+302 <29_31>+303 <29_31>+304 <29_31>+305 <29_31>+306 <29_31>+307 <29_31>+308 <29_31>+309 <29_31>+310 <29_31>+311 <29_31>+312 <29_31>+313 <29_31>+314 <29_31>+315 <29_31>+316 <29_31>+317 <29_31>+318 <29_31>+319 <29_31>+320 <29_31>+321 <29_31>+322 <29_31>+323 <29_31>+324 <29_31>+325 <29_31>+326 <29_31>+327 <29_31>+328 <29_31>+329 <29_31>+330 <29_31>+331 <29_31>+332 <29_31>+333 <29_31>+334 <29_31>+335 <29_31>+336 <29_31>+337 <29_31>+338 <29_31>+339 5 <29_31>+341 <29_31>+342 <29_31>+343 <29_31>+344 <29_31>+345 <29_31>+346 <29_31>+347 <29_31>+348 <29_31>+349 <29_31>+350 <29_31>+351 <29_31>+352 <29_31>+353 <29_31>+354 <29_31>+355 <29_31>+356 <29_31>+357 <29_31>+358 <29_31>+359 <29_31>+360 <29_31>+361 <29_31>+362 <29_31>+363 <29_31>+364 <29_31>+365 <29_31>+366 <29_31>+367 <29_31>+368 <30_31>+10 <29_31>+370 <29_31>+371 <29_31>+372 <29_31>+373 <29_31>+374 <29_31>+375 <29_31>+376 <30_31>+26 <30_31>+128 <30_31>+128 <29_31>+380 <29_31>+381 <29_31>+382 <29_31>+383 <29_31>+384 0 0 1 6 <29_31>+389 <29_31>+390 <29_31>+391 <29_31>+392 <29_31>+393 <29_31>+394 <29_31>+395 <29_31>+396 <29_31>+397 <29_31>+398 <29_31>+399 <29_31>+400 <29_31>+401 <29_31>+402 <29_31>+403 <29_31>+404 <29_31>+405 <29_31>+406 <29_31>+407 <30_31>+128 <30_31>+128 <29_31>+410 <29_31>+411 <29_31>+412 <29_31>+413 <29_31>+414 <29_31>+415 <29_31>+416 <29_31>+417 <29_31>+418 <29_31>+419 <29_31>+420 <29_31>+421 <29_31>+422 <29_31>+423 <29_31>+424 <29_31>+425 <29_31>+426 <29_31>+427 <29_31>+428 <29_31>+429 <29_31>+430 <29_31>+431 <29_31>+432 <29_31>+433 <29_31>+434 <29_31>+435 <29_31>+436 <29_31>+437 <29_31>+438 <29_31>+439 <29_31>+440 <29_31>+441 <29_31>+442 <29_31>+443 <29_31>+444 <29_31>+445 <29_31>+446 <29_31>+447 <29_31>+448 <29_31>+449 <29_31>+450 <29_31>+451 <29_31>+452 <29_31>+453 <29_31>+454 <29_31>+455 <29_31>+456 <29_31>+457 <29_31>+458 <29_31>+459 <29_31>+460 <29_31>+461 <30_31>+128 <29_31>+463 <29_31>+464 <29_31>+465 block 35 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 35 SYMNAM: intern SYMNAM extern L1444 <4_31>+L1444 extern L1445 <4_31>+L1445 extern L1446 <4_31>+L1446 extern L1447 <4_31>+L1447 extern L1448 <4_31>+L1448 extern L1449 <4_31>+L1449 extern L1450 <4_31>+L1450 extern L1451 <4_31>+L1451 extern L1452 <4_31>+L1452 extern L1453 <4_31>+L1453 extern L1454 <4_31>+L1454 extern L1455 <4_31>+L1455 extern L1456 <4_31>+L1456 extern L1457 <4_31>+L1457 extern L1458 <4_31>+L1458 extern L1459 <4_31>+L1459 extern L1460 <4_31>+L1460 extern L1461 <4_31>+L1461 extern L1462 <4_31>+L1462 extern L1463 <4_31>+L1463 extern L1464 <4_31>+L1464 extern L1465 <4_31>+L1465 extern L1466 <4_31>+L1466 extern L1467 <4_31>+L1467 extern L1468 <4_31>+L1468 extern L1469 <4_31>+L1469 extern L1470 <4_31>+L1470 extern L1471 <4_31>+L1471 extern L1472 <4_31>+L1472 extern L1473 <4_31>+L1473 extern L1474 <4_31>+L1474 extern L1475 <4_31>+L1475 extern L1476 <4_31>+L1476 extern L1477 <4_31>+L1477 extern L1478 <4_31>+L1478 extern L1479 <4_31>+L1479 extern L1480 <4_31>+L1480 extern L1481 <4_31>+L1481 extern L1482 <4_31>+L1482 extern L1483 <4_31>+L1483 extern L1484 <4_31>+L1484 extern L1485 <4_31>+L1485 extern L1486 <4_31>+L1486 extern L1487 <4_31>+L1487 extern L1488 <4_31>+L1488 extern L1489 <4_31>+L1489 extern L1490 <4_31>+L1490 extern L1491 <4_31>+L1491 extern L1492 <4_31>+L1492 extern L1493 <4_31>+L1493 extern L1494 <4_31>+L1494 extern L1495 <4_31>+L1495 extern L1496 <4_31>+L1496 extern L1497 <4_31>+L1497 extern L1498 <4_31>+L1498 extern L1499 <4_31>+L1499 extern L1500 <4_31>+L1500 extern L1501 <4_31>+L1501 extern L1502 <4_31>+L1502 extern L1503 <4_31>+L1503 extern L1504 <4_31>+L1504 extern L1505 <4_31>+L1505 extern L1506 <4_31>+L1506 extern L1507 <4_31>+L1507 extern L1508 <4_31>+L1508 extern L1509 <4_31>+L1509 extern L1510 <4_31>+L1510 extern L1511 <4_31>+L1511 extern L1512 <4_31>+L1512 extern L1513 <4_31>+L1513 extern L1514 <4_31>+L1514 extern L1515 <4_31>+L1515 extern L1516 <4_31>+L1516 extern L1517 <4_31>+L1517 extern L1518 <4_31>+L1518 extern L1519 <4_31>+L1519 extern L1520 <4_31>+L1520 extern L1521 <4_31>+L1521 extern L1522 <4_31>+L1522 extern L1523 <4_31>+L1523 extern L1524 <4_31>+L1524 extern L1525 <4_31>+L1525 extern L1526 <4_31>+L1526 extern L1527 <4_31>+L1527 extern L1528 <4_31>+L1528 extern L1529 <4_31>+L1529 extern L1530 <4_31>+L1530 extern L1531 <4_31>+L1531 extern L1532 <4_31>+L1532 extern L1533 <4_31>+L1533 extern L1534 <4_31>+L1534 extern L1535 <4_31>+L1535 extern L1536 <4_31>+L1536 extern L1537 <4_31>+L1537 extern L1538 <4_31>+L1538 extern L1539 <4_31>+L1539 extern L1540 <4_31>+L1540 extern L1541 <4_31>+L1541 extern L1542 <4_31>+L1542 extern L1543 <4_31>+L1543 extern L1544 <4_31>+L1544 extern L1545 <4_31>+L1545 extern L1546 <4_31>+L1546 extern L1547 <4_31>+L1547 extern L1548 <4_31>+L1548 extern L1549 <4_31>+L1549 extern L1550 <4_31>+L1550 extern L1551 <4_31>+L1551 extern L1552 <4_31>+L1552 extern L1553 <4_31>+L1553 extern L1554 <4_31>+L1554 extern L1555 <4_31>+L1555 extern L1556 <4_31>+L1556 extern L1557 <4_31>+L1557 extern L1558 <4_31>+L1558 extern L1559 <4_31>+L1559 extern L1560 <4_31>+L1560 extern L1561 <4_31>+L1561 extern L1562 <4_31>+L1562 extern L1563 <4_31>+L1563 extern L1564 <4_31>+L1564 extern L1565 <4_31>+L1565 extern L1566 <4_31>+L1566 extern L1567 <4_31>+L1567 extern L1568 <4_31>+L1568 extern L1569 <4_31>+L1569 extern L1570 <4_31>+L1570 extern L1571 <4_31>+L1571 extern L1572 <4_31>+L1572 extern L1573 <4_31>+L1573 extern L1574 <4_31>+L1574 extern L1575 <4_31>+L1575 extern L1576 <4_31>+L1576 extern L1577 <4_31>+L1577 extern L1578 <4_31>+L1578 extern L1579 <4_31>+L1579 extern L1580 <4_31>+L1580 extern L1581 <4_31>+L1581 extern L1582 <4_31>+L1582 extern L1583 <4_31>+L1583 extern L1584 <4_31>+L1584 extern L1585 <4_31>+L1585 extern L1586 <4_31>+L1586 extern L1587 <4_31>+L1587 extern L1588 <4_31>+L1588 extern L1589 <4_31>+L1589 extern L1590 <4_31>+L1590 extern L1591 <4_31>+L1591 extern L1592 <4_31>+L1592 extern L1593 <4_31>+L1593 extern L1594 <4_31>+L1594 extern L1595 <4_31>+L1595 extern L1596 <4_31>+L1596 extern L1597 <4_31>+L1597 extern L1598 <4_31>+L1598 extern L1599 <4_31>+L1599 extern L1600 <4_31>+L1600 extern L1601 <4_31>+L1601 extern L1602 <4_31>+L1602 extern L1603 <4_31>+L1603 extern L1604 <4_31>+L1604 extern L1605 <4_31>+L1605 extern L1606 <4_31>+L1606 extern L1607 <4_31>+L1607 extern L1608 <4_31>+L1608 extern L1609 <4_31>+L1609 extern L1610 <4_31>+L1610 extern L1611 <4_31>+L1611 extern L1612 <4_31>+L1612 extern L1613 <4_31>+L1613 extern L1614 <4_31>+L1614 extern L1615 <4_31>+L1615 extern L1616 <4_31>+L1616 extern L1617 <4_31>+L1617 extern L1618 <4_31>+L1618 extern L1619 <4_31>+L1619 extern L1620 <4_31>+L1620 extern L1621 <4_31>+L1621 extern L1622 <4_31>+L1622 extern L1623 <4_31>+L1623 extern L1624 <4_31>+L1624 extern L1625 <4_31>+L1625 extern L1626 <4_31>+L1626 extern L1627 <4_31>+L1627 extern L1628 <4_31>+L1628 extern L1629 <4_31>+L1629 extern L1630 <4_31>+L1630 extern L1631 <4_31>+L1631 extern L1632 <4_31>+L1632 extern L1633 <4_31>+L1633 extern L1634 <4_31>+L1634 extern L1635 <4_31>+L1635 extern L1636 <4_31>+L1636 extern L1637 <4_31>+L1637 extern L1638 <4_31>+L1638 extern L1639 <4_31>+L1639 extern L1640 <4_31>+L1640 extern L1641 <4_31>+L1641 extern L1642 <4_31>+L1642 extern L1643 <4_31>+L1643 extern L1644 <4_31>+L1644 extern L1645 <4_31>+L1645 extern L1646 <4_31>+L1646 extern L1647 <4_31>+L1647 extern L1648 <4_31>+L1648 extern L1649 <4_31>+L1649 extern L1650 <4_31>+L1650 extern L1651 <4_31>+L1651 extern L1652 <4_31>+L1652 extern L1653 <4_31>+L1653 extern L1654 <4_31>+L1654 extern L1655 <4_31>+L1655 extern L1656 <4_31>+L1656 extern L1657 <4_31>+L1657 extern L1658 <4_31>+L1658 extern L1659 <4_31>+L1659 extern L1660 <4_31>+L1660 extern L1661 <4_31>+L1661 extern L1662 <4_31>+L1662 extern L1663 <4_31>+L1663 extern L1664 <4_31>+L1664 extern L1665 <4_31>+L1665 extern L1666 <4_31>+L1666 extern L1667 <4_31>+L1667 extern L1668 <4_31>+L1668 extern L1669 <4_31>+L1669 extern L1670 <4_31>+L1670 extern L1671 <4_31>+L1671 extern L1672 <4_31>+L1672 extern L1673 <4_31>+L1673 extern L1674 <4_31>+L1674 extern L1675 <4_31>+L1675 extern L1676 <4_31>+L1676 extern L1677 <4_31>+L1677 extern L1678 <4_31>+L1678 extern L1679 <4_31>+L1679 extern L1680 <4_31>+L1680 extern L1681 <4_31>+L1681 extern L1682 <4_31>+L1682 extern L1683 <4_31>+L1683 extern L1684 <4_31>+L1684 extern L1685 <4_31>+L1685 extern L1686 <4_31>+L1686 extern L1687 <4_31>+L1687 extern L1688 <4_31>+L1688 extern L1689 <4_31>+L1689 extern L1690 <4_31>+L1690 extern L1691 <4_31>+L1691 extern L1692 <4_31>+L1692 extern L1693 <4_31>+L1693 extern L1694 <4_31>+L1694 extern L1695 <4_31>+L1695 extern L1696 <4_31>+L1696 extern L1697 <4_31>+L1697 extern L1698 <4_31>+L1698 extern L1699 <4_31>+L1699 extern L1700 <4_31>+L1700 extern L1701 <4_31>+L1701 extern L1702 <4_31>+L1702 extern L1703 <4_31>+L1703 extern L1704 <4_31>+L1704 extern L1705 <4_31>+L1705 extern L1706 <4_31>+L1706 extern L1707 <4_31>+L1707 extern L1708 <4_31>+L1708 extern L1709 <4_31>+L1709 extern L1710 <4_31>+L1710 extern L1711 <4_31>+L1711 extern L1712 <4_31>+L1712 extern L1713 <4_31>+L1713 extern L1714 <4_31>+L1714 extern L1715 <4_31>+L1715 extern L1716 <4_31>+L1716 extern L1717 <4_31>+L1717 extern L1718 <4_31>+L1718 extern L1719 <4_31>+L1719 extern L1720 <4_31>+L1720 extern L1721 <4_31>+L1721 extern L1722 <4_31>+L1722 extern L1723 <4_31>+L1723 extern L1724 <4_31>+L1724 extern L1725 <4_31>+L1725 extern L1726 <4_31>+L1726 extern L1727 <4_31>+L1727 extern L1728 <4_31>+L1728 extern L1729 <4_31>+L1729 extern L1730 <4_31>+L1730 extern L1731 <4_31>+L1731 extern L1732 <4_31>+L1732 extern L1733 <4_31>+L1733 extern L1734 <4_31>+L1734 extern L1735 <4_31>+L1735 extern L1736 <4_31>+L1736 extern L1737 <4_31>+L1737 extern L1738 <4_31>+L1738 extern L1739 <4_31>+L1739 extern L1740 <4_31>+L1740 extern L1741 <4_31>+L1741 extern L1742 <4_31>+L1742 extern L1743 <4_31>+L1743 extern L1744 <4_31>+L1744 extern L1745 <4_31>+L1745 extern L1746 <4_31>+L1746 extern L1747 <4_31>+L1747 extern L1748 <4_31>+L1748 extern L1749 <4_31>+L1749 extern L1750 <4_31>+L1750 extern L1751 <4_31>+L1751 extern L1752 <4_31>+L1752 extern L1753 <4_31>+L1753 extern L1754 <4_31>+L1754 extern L1755 <4_31>+L1755 extern L1756 <4_31>+L1756 extern L1757 <4_31>+L1757 extern L1758 <4_31>+L1758 extern L1759 <4_31>+L1759 extern L1760 <4_31>+L1760 extern L1761 <4_31>+L1761 extern L1762 <4_31>+L1762 extern L1763 <4_31>+L1763 extern L1764 <4_31>+L1764 extern L1765 <4_31>+L1765 extern L1766 <4_31>+L1766 extern L1767 <4_31>+L1767 extern L1768 <4_31>+L1768 extern L1769 <4_31>+L1769 extern L1770 <4_31>+L1770 extern L1771 <4_31>+L1771 extern L1772 <4_31>+L1772 extern L1773 <4_31>+L1773 extern L1774 <4_31>+L1774 extern L1775 <4_31>+L1775 extern L1776 <4_31>+L1776 extern L1777 <4_31>+L1777 extern L1778 <4_31>+L1778 extern L1779 <4_31>+L1779 extern L1780 <4_31>+L1780 extern L1781 <4_31>+L1781 extern L1782 <4_31>+L1782 extern L1783 <4_31>+L1783 extern L1784 <4_31>+L1784 extern L1785 <4_31>+L1785 extern L1786 <4_31>+L1786 extern L1787 <4_31>+L1787 extern L1788 <4_31>+L1788 extern L1789 <4_31>+L1789 extern L1790 <4_31>+L1790 extern L1791 <4_31>+L1791 extern L1792 <4_31>+L1792 extern L1793 <4_31>+L1793 extern L1794 <4_31>+L1794 extern L1795 <4_31>+L1795 extern L1796 <4_31>+L1796 extern L1797 <4_31>+L1797 extern L1798 <4_31>+L1798 extern L1799 <4_31>+L1799 extern L1800 <4_31>+L1800 extern L1801 <4_31>+L1801 extern L1802 <4_31>+L1802 extern L1803 <4_31>+L1803 extern L1804 <4_31>+L1804 extern L1805 <4_31>+L1805 extern L1806 <4_31>+L1806 extern L1807 <4_31>+L1807 extern L1808 <4_31>+L1808 extern L1809 <4_31>+L1809 extern L1810 <4_31>+L1810 extern L1811 <4_31>+L1811 extern L1812 <4_31>+L1812 extern L1813 <4_31>+L1813 extern L1814 <4_31>+L1814 extern L1815 <4_31>+L1815 extern L1816 <4_31>+L1816 extern L1817 <4_31>+L1817 extern L1818 <4_31>+L1818 extern L1819 <4_31>+L1819 extern L1820 <4_31>+L1820 extern L1821 <4_31>+L1821 extern L1822 <4_31>+L1822 extern L1823 <4_31>+L1823 extern L1824 <4_31>+L1824 extern L1825 <4_31>+L1825 extern L1826 <4_31>+L1826 extern L1827 <4_31>+L1827 extern L1828 <4_31>+L1828 extern L1829 <4_31>+L1829 extern L1830 <4_31>+L1830 extern L1831 <4_31>+L1831 extern L1832 <4_31>+L1832 extern L1833 <4_31>+L1833 extern L1834 <4_31>+L1834 extern L1835 <4_31>+L1835 extern L1836 <4_31>+L1836 extern L1837 <4_31>+L1837 extern L1838 <4_31>+L1838 extern L1839 <4_31>+L1839 extern L1840 <4_31>+L1840 extern L1841 <4_31>+L1841 extern L1842 <4_31>+L1842 extern L1843 <4_31>+L1843 extern L1844 <4_31>+L1844 extern L1845 <4_31>+L1845 extern L1846 <4_31>+L1846 extern L1847 <4_31>+L1847 extern L1848 <4_31>+L1848 extern L1849 <4_31>+L1849 extern L1850 <4_31>+L1850 extern L1851 <4_31>+L1851 extern L1852 <4_31>+L1852 extern L1853 <4_31>+L1853 extern L1854 <4_31>+L1854 extern L1855 <4_31>+L1855 extern L1856 <4_31>+L1856 extern L1857 <4_31>+L1857 extern L1858 <4_31>+L1858 extern L1859 <4_31>+L1859 extern L1860 <4_31>+L1860 extern L1861 <4_31>+L1861 extern L1862 <4_31>+L1862 extern L1863 <4_31>+L1863 extern L1864 <4_31>+L1864 extern L1865 <4_31>+L1865 extern L1866 <4_31>+L1866 extern L1867 <4_31>+L1867 extern L1868 <4_31>+L1868 extern L1869 <4_31>+L1869 extern L1870 <4_31>+L1870 extern L1871 <4_31>+L1871 extern L1872 <4_31>+L1872 extern L1873 <4_31>+L1873 extern L1874 <4_31>+L1874 extern L1875 <4_31>+L1875 extern L1876 <4_31>+L1876 extern L1877 <4_31>+L1877 extern L1878 <4_31>+L1878 extern L1879 <4_31>+L1879 extern L1880 <4_31>+L1880 extern L1881 <4_31>+L1881 extern L1882 <4_31>+L1882 extern L1883 <4_31>+L1883 extern L1884 <4_31>+L1884 extern L1885 <4_31>+L1885 extern L1886 <4_31>+L1886 extern L1887 <4_31>+L1887 extern L1888 <4_31>+L1888 extern L1889 <4_31>+L1889 extern L1890 <4_31>+L1890 extern L1891 <4_31>+L1891 extern L1892 <4_31>+L1892 extern L1893 <4_31>+L1893 extern L1894 <4_31>+L1894 extern L1895 <4_31>+L1895 extern L1896 <4_31>+L1896 extern L1897 <4_31>+L1897 extern L1898 <4_31>+L1898 extern L1899 <4_31>+L1899 extern L1900 <4_31>+L1900 extern L1901 <4_31>+L1901 extern L1902 <4_31>+L1902 extern L1903 <4_31>+L1903 extern L1904 <4_31>+L1904 extern L1905 <4_31>+L1905 extern L1906 <4_31>+L1906 extern L1907 <4_31>+L1907 extern L1908 <4_31>+L1908 extern L1909 <4_31>+L1909 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern L0024 jrst L0024## extern L0017 jrst L0017## extern L0026 jrst L0026## extern L0034 jrst L0034## extern PRTITM jrst PRTITM## extern PRIN1 jrst PRIN1## extern L0025 jrst L0025## extern L0028 jrst L0028## extern L0042 jrst L0042## extern PRIN2 jrst PRIN2## extern TERPRI jrst TERPRI## extern PRINT jrst PRINT## extern PRIN2T jrst PRIN2T## extern PUTC jrst PUTC## extern PBLANK jrst PBLANK## extern L0021 jrst L0021## extern L1202 jrst L1202## extern L1203 jrst L1203## JRST SYMFNC+407 extern QUIT jrst QUIT## extern ERROR jrst ERROR## extern L0093 jrst L0093## extern L0094 jrst L0094## extern L1161 jrst L1161## extern L0095 jrst L0095## JRST SYMFNC+407 extern L0098 jrst L0098## extern L0099 jrst L0099## extern L0102 jrst L0102## extern L0103 jrst L0103## extern L0106 jrst L0106## JRST SYMFNC+407 extern L0156 jrst L0156## extern L0165 jrst L0165## JRST SYMFNC+407 JRST SYMFNC+407 extern L0172 jrst L0172## JRST SYMFNC+407 extern L1029 jrst L1029## extern L1019 jrst L1019## extern L0177 jrst L0177## extern L0182 jrst L0182## JRST SYMFNC+407 extern L1206 jrst L1206## extern GTHEAP jrst GTHEAP## extern GTSTR jrst GTSTR## extern GTVECT jrst GTVECT## extern L0191 jrst L0191## extern GTID jrst GTID## extern L0192 jrst L0192## extern CONS jrst CONS## extern XCONS jrst XCONS## extern NCONS jrst NCONS## extern MKVECT jrst MKVECT## extern LIST2 jrst LIST2## extern LIST3 jrst LIST3## extern LIST4 jrst LIST4## extern LIST5 jrst LIST5## JRST SYMFNC+407 extern L0209 jrst L0209## extern EQSTR jrst EQSTR## extern L0222 jrst L0222## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern L0224 jrst L0224## extern L0230 jrst L0230## extern L0233 jrst L0233## extern L0246 jrst L0246## extern DIGITP jrst DIGITP## extern L0237 jrst L0237## extern L0297 jrst L0297## extern READID jrst READID## extern RATOM jrst RATOM## extern WHITEP jrst WHITEP## extern GETC jrst GETC## extern L1201 jrst L1201## extern L0241 jrst L0241## extern L0252 jrst L0252## extern L0301 jrst L0301## extern INTERN jrst INTERN## extern L0295 jrst L0295## extern ALPHAP jrst ALPHAP## extern L0291 jrst L0291## extern L0270 jrst L0270## extern L0263 jrst L0263## extern L0330 jrst L0330## extern L0287 jrst L0287## extern L0299 jrst L0299## extern READ1 jrst READ1## extern READ jrst READ## extern L0310 jrst L0310## extern QUOTE jrst QUOTE## JRST SYMFNC+407 extern L0321 jrst L0321## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern L0325 jrst L0325## extern L1199 jrst L1199## extern L0360 jrst L0360## extern L0334 jrst L0334## extern L1198 jrst L1198## extern L0339 jrst L0339## extern FCODEP jrst FCODEP## extern L0350 jrst L0350## extern L0355 jrst L0355## extern L0359 jrst L0359## JRST SYMFNC+407 extern L0370 jrst L0370## JRST SYMFNC+407 JRST SYMFNC+407 extern L0436 jrst L0436## extern L0365 jrst L0365## extern L0437 jrst L0437## JRST SYMFNC+407 extern L0371 jrst L0371## extern L1240 jrst L1240## extern L0375 jrst L0375## extern L0398 jrst L0398## extern L0402 jrst L0402## extern EVAL jrst EVAL## extern L0429 jrst L0429## extern L0425 jrst L0425## extern LBIND1 jrst LBIND1## extern GET jrst GET## extern L0443 jrst L0443## JRST SYMFNC+407 extern BLDMSG jrst BLDMSG## extern L0515 jrst L0515## extern L0674 jrst L0674## extern PLUS2 jrst PLUS2## extern MINUS jrst MINUS## JRST SYMFNC+407 JRST SYMFNC+407 extern ADD1 jrst ADD1## JRST SYMFNC+407 extern SUB1 jrst SUB1## extern L0471 jrst L0471## extern LESSP jrst LESSP## extern L0483 jrst L0483## extern TIMES2 jrst TIMES2## extern CAR jrst CAR## extern CDR jrst CDR## extern CAAR jrst CAAR## extern CADR jrst CADR## extern CDAR jrst CDAR## extern CDDR jrst CDDR## extern ATOM jrst ATOM## extern APPEND jrst APPEND## extern MEMQ jrst MEMQ## extern L0509 jrst L0509## extern EVLIS jrst EVLIS## extern PROGN jrst PROGN## extern EVCOND jrst EVCOND## extern COND jrst COND## extern SET jrst SET## extern SETQ jrst SETQ## extern PUTD jrst PUTD## extern DE jrst DE## JRST SYMFNC+407 extern DF jrst DF## JRST SYMFNC+407 extern DN jrst DN## JRST SYMFNC+407 extern DM jrst DM## JRST SYMFNC+407 extern LIST jrst LIST## extern ATSOC jrst ATSOC## extern GEQ jrst GEQ## extern LEQ jrst LEQ## extern EQCAR jrst EQCAR## extern GETD jrst GETD## extern COPYD jrst COPYD## extern DELATQ jrst DELATQ## extern PUT jrst PUT## extern L0569 jrst L0569## extern WHILE jrst WHILE## JRST SYMFNC+407 extern L0614 jrst L0614## extern L0620 jrst L0620## extern L0604 jrst L0604## extern L0665 jrst L0665## extern L0603 jrst L0603## extern APPLY jrst APPLY## extern L0607 jrst L0607## extern LENGTH jrst LENGTH## extern CODEP jrst CODEP## extern PAIRP jrst PAIRP## extern IDP jrst IDP## extern EQ jrst EQ## extern NULL jrst NULL## extern NOT jrst NOT## extern L0634 jrst L0634## extern MAPOBL jrst MAPOBL## extern L0642 jrst L0642## extern L0643 jrst L0643## JRST SYMFNC+407 extern L0646 jrst L0646## extern L0647 jrst L0647## extern PROP jrst PROP## extern L0660 jrst L0660## extern L0679 jrst L0679## JRST SYMFNC+407 JRST SYMFNC+407 extern RESET jrst RESET## extern L1010 jrst L1010## JRST SYMFNC+407 extern L1013 jrst L1013## extern L1014 jrst L1014## extern L1015 jrst L1015## JRST SYMFNC+407 extern L1018 jrst L1018## extern PBIND1 jrst PBIND1## extern L1032 jrst L1032## extern L1074 jrst L1074## extern L1077 jrst L1077## extern L1075 jrst L1075## extern L1076 jrst L1076## extern L1087 jrst L1087## extern L1080 jrst L1080## extern L1115 jrst L1115## extern L1096 jrst L1096## extern L1092 jrst L1092## extern L1100 jrst L1100## JRST SYMFNC+407 extern L1102 jrst L1102## extern L1180 jrst L1180## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern RDS jrst RDS## extern WRS jrst WRS## extern OPEN jrst OPEN## extern CLOSE jrst CLOSE## extern L1117 jrst L1117## JRST SYMFNC+407 extern DSKIN jrst DSKIN## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern LAPIN jrst LAPIN## extern L1145 jrst L1145## extern L1149 jrst L1149## JRST SYMFNC+407 extern L1166 jrst L1166## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern L1138 jrst L1138## JRST SYMFNC+407 extern L1157 jrst L1157## extern L1150 jrst L1150## extern L1153 jrst L1153## extern L1165 jrst L1165## extern L1168 jrst L1168## extern L1174 jrst L1174## JRST SYMFNC+407 JRST SYMFNC+407 extern L1189 jrst L1189## extern L1408 jrst L1408## extern MAIN. jrst MAIN.## extern INIT jrst INIT## extern TIMC jrst TIMC## extern DATE jrst DATE## extern L1197 jrst L1197## extern PUTINT jrst PUTINT## extern L1200 jrst L1200## JRST SYMFNC+407 JRST SYMFNC+407 extern FLAG jrst FLAG## JRST SYMFNC+407 extern L1214 jrst L1214## extern L1209 jrst L1209## extern SPACED jrst SPACED## extern DASHED jrst DASHED## extern DOTTED jrst DOTTED## extern L1231 jrst L1231## extern INF jrst INF## extern TAG jrst TAG## extern MKITEM jrst MKITEM## extern TIME jrst TIME## extern L1245 jrst L1245## extern L1289 jrst L1289## extern L1285 jrst L1285## JRST SYMFNC+407 extern L1257 jrst L1257## JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 JRST SYMFNC+407 extern L1294 jrst L1294## extern L1297 jrst L1297## extern L1300 jrst L1300## extern L1303 jrst L1303## extern L1306 jrst L1306## extern L1311 jrst L1311## extern L1316 jrst L1316## extern L1319 jrst L1319## extern L1323 jrst L1323## extern L1328 jrst L1328## extern L1338 jrst L1338## extern L1333 jrst L1333## extern L1347 jrst L1347## extern L1343 jrst L1343## extern L1352 jrst L1352## extern FACT jrst FACT## extern L1359 jrst L1359## extern L1364 jrst L1364## extern L1368 jrst L1368## extern TAK jrst TAK## extern L1369 jrst L1369## extern GTAK jrst GTAK## extern L1373 jrst L1373## extern GTSTA jrst GTSTA## extern GTSTB jrst GTSTB## extern G0 jrst G0## extern G1 jrst G1## extern L1387 jrst L1387## extern L1385 jrst L1385## extern NNILS jrst NNILS## extern NILS jrst NILS## JRST SYMFNC+407 extern NR jrst NR## extern L1443 jrst L1443## extern IOTEST jrst IOTEST## block 35 L0003: intern L0003 466 end |
Added psl-1983/20-tests/dmain7.rel version [a12ee1a3f8].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub2.mac version [6391a604aa].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 end |
Added psl-1983/20-tests/dsub2.rel version [659b749f04].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub20.mac version [262d2e56bd].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 end |
Added psl-1983/20-tests/dsub3.mac version [49cc8eaf4a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 extern L0183 extern L0184 extern L0185 extern L0186 end |
Added psl-1983/20-tests/dsub3.rel version [48f2b87a39].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub4.mac version [7f9ba075b9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 BUFFER: block 21 intern BUFFER end |
Added psl-1983/20-tests/dsub4.rel version [e7bd89fda7].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub5.mac version [a09d66f45d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 L0369: block 16 intern L0369 end |
Added psl-1983/20-tests/dsub5.rel version [b3bcd310cb].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub6.mac version [7a0ef56c89].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 BNDSTK: block 2001 intern BNDSTK L1005: BNDSTK+0 intern L1005 L1006: BNDSTK+1999 intern L1006 L1007: BNDSTK+0 intern L1007 end |
Added psl-1983/20-tests/dsub6.rel version [f2b120ee35].
cannot compute difference between binary files
Added psl-1983/20-tests/dsub7.mac version [d3fea092b9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 L1103: block 1001 intern L1103 L1104: <30_31>+360 <30_31>+361 <30_31>+361 <30_31>+362 <30_31>+361 <30_31>+361 <30_31>+361 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 intern L1104 L1105: <30_31>+364 <30_31>+152 <30_31>+365 <30_31>+366 <30_31>+367 <30_31>+152 <30_31>+152 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 intern L1105 L1106: <30_31>+368 <30_31>+368 <30_31>+368 <30_31>+368 <30_31>+368 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 <30_31>+363 intern L1106 L1107: block 32 intern L1107 L1108: block 32 intern L1108 L1109: 0 80 80 10000 10000 80 80 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L1109 L1110: 1 2 3 3 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L1110 L1111: block 32 intern L1111 L1112: block 32 intern L1112 L1113: block 32 intern L1113 L1114: block 32 intern L1114 end |
Added psl-1983/20-tests/dsub7.rel version [777185e1a7].
cannot compute difference between binary files
Added psl-1983/20-tests/fiddle.bar version [d6e32eac4d].
> | 1 | THIS IS A STRING OF N |
Added psl-1983/20-tests/field.init version [d53707583f].
> | 1 | (FLAG '(INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20) 'INTERNALFUNCTION) |
Added psl-1983/20-tests/field.mac version [6892f3ef43].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L0005 JRST SYMFNC+130 L0005: byte(18)-300,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 INIT20 EXPR 1) ; (JRST (INTERNALENTRY INIT20)) ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 JRST INIT20 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) ; (JRST (INTERNALENTRY GETC20)) ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SETZM 1 JRST GETC20 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) ; (JRST (INTERNALENTRY TIMC20)) ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 JRST TIMC20 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTC20 EXPR 1) ; (JRST (INTERNALENTRY PUTC20)) ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC JRST PUTC20 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) ; (JRST (INTERNALENTRY QUIT20)) ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 JRST QUIT20 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) ; (JRST (INTERNALENTRY PUTI20)) ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT JRST PUTI20 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 1) ; (!*MOVE 1 (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINK ERR20 EXPR 1) ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) ; (!*ENTRY UNDEFINEDFUNCTION EXPR 1) L0006: intern L0006 HRRZI 1,1 PUSHJ 15,ERR20 ; (!*ENTRY FLAG EXPR 2) ; (!*MOVE 2 (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINK ERR20 EXPR 1) ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 ; (!*ENTRY !*WTIMES32 EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*ENTRY !*WTIMES32 EXPR 2) L0007: intern L0007 IMUL 1,2 POPJ 15,0 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE 'NIL (FRAME 1)) ; (MOVEM (REG NIL) (INDEXED (REG ST) 0)) ; (!*MOVE (WCONST 10) (REG 5)) ; (HRRZI (REG 5) 10) ; (!*MOVE (WCONST 32) (REG 4)) ; (HRRZI (REG 4) 32) ; (!*MOVE (WCONST 71) (REG 3)) ; (HRRZI (REG 3) 71) ; (!*MOVE (WCONST 83) (REG 2)) ; (HRRZI (REG 2) 83) ; (!*MOVE (WCONST 77) (REG 1)) ; (HRRZI (REG 1) 77) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 63) (REG 1)) ; (HRRZI (REG 1) 63) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*MOVE (WCONST 63) (REG 1)) ; (HRRZI (REG 1) 63) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*MOVE (WCONST 36) (FRAME 2)) ; (HRRZI (REG T1) 36) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*JUMPNOTEQ (LABEL G0005) (FRAME 2) (WCONST 64)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIE (REG T1) 64) ; (JRST (LABEL G0005)) ; (!*MOVE (WCONST 32374509039) (FRAME 1)) ; (MOVE (REG T1) 32374509039) ; (MOVEM (REG T1) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTEQ (LABEL G0006) (FRAME 2) (WCONST 32)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIE (REG T1) 32) ; (JRST (LABEL G0006)) ; (!*MOVE (WCONST 19088743) (FRAME 1)) ; (MOVE (REG T1) 19088743) ; (MOVEM (REG T1) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0006)) ; (!*JUMPNOTEQ (LABEL G0007) (FRAME 2) (WCONST 36)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIE (REG T1) 36) ; (JRST (LABEL G0007)) ; (!*MOVE (WCONST 305419896) (FRAME 1)) ; (MOVE (REG T1) 305419896) ; (MOVEM (REG T1) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0007)) ; (!*MOVE (WCONST 99) (REG 1)) ; (HRRZI (REG 1) 99) ; (!*LINK ERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY ERR)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK ASHIFTTEST EXPR 1) ; (PUSHJ (REG ST) (ENTRY ASHIFTTEST)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FIELDTEST EXPR 1) ; (PUSHJ (REG ST) (ENTRY FIELDTEST)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LSHIFTTEST EXPR 1) ; (PUSHJ (REG ST) (ENTRY LSHIFTTEST)) ; (!*LINK QUIT EXPR 0) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE 'NIL (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (!*ENTRY FIRSTCALL EXPR 0) L0008: intern L0008 ADJSP 15,2 MOVEM 0,0(15) HRRZI 5,10 HRRZI 4,32 HRRZI 3,71 HRRZI 2,83 HRRZI 1,77 PUSHJ 15,SYMFNC+140 HRRZI 1,63 PUSHJ 15,SYMFNC+141 HRRZI 1,63 PUSHJ 15,SYMFNC+142 HRRZI 6,36 MOVEM 6,-1(15) MOVE 6,-1(15) CAIE 6,64 JRST L0009 MOVE 6,[32374509039] MOVEM 6,0(15) JRST L0010 L0009: MOVE 6,-1(15) CAIE 6,32 JRST L0011 MOVE 6,[19088743] MOVEM 6,0(15) JRST L0010 L0011: MOVE 6,-1(15) CAIE 6,36 JRST L0012 MOVE 6,[305419896] MOVEM 6,0(15) JRST L0010 L0012: HRRZI 1,99 PUSHJ 15,SYMFNC+143 L0010: MOVE 1,0(15) PUSHJ 15,SYMFNC+144 MOVE 1,0(15) PUSHJ 15,SYMFNC+145 MOVE 1,0(15) PUSHJ 15,SYMFNC+146 PUSHJ 15,SYMFNC+135 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 ; (!*ENTRY ASHIFTTEST EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (WCONST 70) (REG 5)) ; (HRRZI (REG 5) 70) ; (!*MOVE (WCONST 73) (REG 4)) ; (HRRZI (REG 4) 73) ; (!*MOVE (WCONST 72) (REG 3)) ; (HRRZI (REG 3) 72) ; (!*MOVE (WCONST 83) (REG 2)) ; (HRRZI (REG 2) 83) ; (!*MOVE (WCONST 65) (REG 1)) ; (HRRZI (REG 1) 65) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 10) (REG 5)) ; (HRRZI (REG 5) 10) ; (!*MOVE (WCONST 32) (REG 4)) ; (HRRZI (REG 4) 32) ; (!*MOVE (WCONST 32) (REG 3)) ; (HRRZI (REG 3) 32) ; (!*MOVE (WCONST 32) (REG 2)) ; (HRRZI (REG 2) 32) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 10) (FRAME 2)) ; (HRRZI (REG T1) 10) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*WTIMES2 (FRAME 2) (WCONST 4)) ; (MOVE (REG T3) (INDEXED (REG ST) -1)) ; (ASH (REG T3) 2) ; (MOVEM (REG T3) (INDEXED (REG ST) -1)) ; (!*JUMPEQ (LABEL G0005) (FRAME 2) (WCONST 40)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIN (REG T1) 40) ; (JRST (LABEL G0005)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (WCONST -5) (FRAME 2)) ; (MOVNI (REG T1) (MINUS -5)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*WTIMES2 (FRAME 2) (WCONST 16)) ; (MOVE (REG T3) (INDEXED (REG ST) -1)) ; (ASH (REG T3) 4) ; (MOVEM (REG T3) (INDEXED (REG ST) -1)) ; (!*JUMPEQ (LABEL G0008) (FRAME 2) (WCONST -80)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMN (REG T1) (LIT (FULLWORD -80))) ; (JRST (LABEL G0008)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0007)) ; (JRST (LABEL G0007)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0007)) ; (!*MOVE (WCONST 6) (FRAME 2)) ; (HRRZI (REG T1) 6) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 4) (FRAME 1)) ; (HRRZI (REG T1) 4) ; (MOVEM (REG T1) (INDEXED (REG ST) 0)) ; (!*WTIMES2 (FRAME 2) (WCONST 4)) ; (MOVE (REG T3) (INDEXED (REG ST) -1)) ; (ASH (REG T3) 2) ; (MOVEM (REG T3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*WTIMES2 (REG 1) (WCONST 6)) ; (IMULI (REG 1) 6) ; (!*JUMPEQ (LABEL G0011) (FRAME 2) (REG 1)) ; (CAMN (REG 1) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0011)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0010)) ; (JRST (LABEL G0010)) ; (!*LBL (LABEL G0011)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0010)) ; (!*MOVE 'NIL (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD -80) ; (!*ENTRY ASHIFTTEST EXPR 1) L0014: intern L0014 ADJSP 15,2 HRRZI 5,70 HRRZI 4,73 HRRZI 3,72 HRRZI 2,83 HRRZI 1,65 PUSHJ 15,SYMFNC+140 HRRZI 5,10 HRRZI 4,32 HRRZI 3,32 HRRZI 2,32 HRRZI 1,84 PUSHJ 15,SYMFNC+140 HRRZI 6,10 MOVEM 6,-1(15) MOVE 8,-1(15) ASH 8,2 MOVEM 8,-1(15) MOVE 6,-1(15) CAIN 6,40 JRST L0015 HRRZI 1,49 PUSHJ 15,SYMFNC+142 JRST L0016 L0015: HRRZI 1,49 PUSHJ 15,SYMFNC+141 L0016: MOVNI 6,5 MOVEM 6,-1(15) MOVE 8,-1(15) ASH 8,4 MOVEM 8,-1(15) MOVE 6,-1(15) CAMN 6,L0013 JRST L0017 HRRZI 1,50 PUSHJ 15,SYMFNC+142 JRST L0018 L0017: HRRZI 1,50 PUSHJ 15,SYMFNC+141 L0018: HRRZI 6,6 MOVEM 6,-1(15) HRRZI 6,4 MOVEM 6,0(15) MOVE 8,-1(15) ASH 8,2 MOVEM 8,-1(15) MOVE 1,0(15) IMULI 1,6 CAMN 1,-1(15) JRST L0019 HRRZI 1,51 PUSHJ 15,SYMFNC+142 JRST L0020 L0019: HRRZI 1,51 PUSHJ 15,SYMFNC+141 L0020: MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L0013: -80 ; (!*ENTRY FIELDTEST EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 68) (REG 5)) ; (HRRZI (REG 5) 68) ; (!*MOVE (WCONST 76) (REG 4)) ; (HRRZI (REG 4) 76) ; (!*MOVE (WCONST 69) (REG 3)) ; (HRRZI (REG 3) 69) ; (!*MOVE (WCONST 73) (REG 2)) ; (HRRZI (REG 2) 73) ; (!*MOVE (WCONST 70) (REG 1)) ; (HRRZI (REG 1) 70) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 0) (WCONST 36)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 36)))) ; (!*JUMPEQ (LABEL G0005) (REG 1) (FRAME 1)) ; (CAMN (REG 1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0004)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 0) (WCONST 8)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 8)))) ; (!*JUMPEQ (LABEL G0008) (REG 1) (WCONST 1)) ; (CAIN (REG 1) 1) ; (JRST (LABEL G0008)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0007)) ; (JRST (LABEL G0007)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0007)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 8) (WCONST 8)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 8 8)))) ; (!*JUMPEQ (LABEL G0011) (REG 1) (WCONST 35)) ; (CAIN (REG 1) 35) ; (JRST (LABEL G0011)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0010)) ; (JRST (LABEL G0010)) ; (!*LBL (LABEL G0011)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0010)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 16) (WCONST 8)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 16 8)))) ; (!*JUMPEQ (LABEL G0014) (REG 1) (WCONST 69)) ; (CAIN (REG 1) 69) ; (JRST (LABEL G0014)) ; (!*MOVE (WCONST 52) (REG 1)) ; (HRRZI (REG 1) 52) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0013)) ; (JRST (LABEL G0013)) ; (!*LBL (LABEL G0014)) ; (!*MOVE (WCONST 52) (REG 1)) ; (HRRZI (REG 1) 52) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0013)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 24) (WCONST 8)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 24 8)))) ; (!*JUMPEQ (LABEL G0017) (REG 1) (WCONST 103)) ; (CAIN (REG 1) 103) ; (JRST (LABEL G0017)) ; (!*MOVE (WCONST 53) (REG 1)) ; (HRRZI (REG 1) 53) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0016)) ; (JRST (LABEL G0016)) ; (!*LBL (LABEL G0017)) ; (!*MOVE (WCONST 53) (REG 1)) ; (HRRZI (REG 1) 53) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0016)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 0) (WCONST 16)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 16)))) ; (!*JUMPEQ (LABEL G0020) (REG 1) (WCONST 291)) ; (CAIN (REG 1) 291) ; (JRST (LABEL G0020)) ; (!*MOVE (WCONST 54) (REG 1)) ; (HRRZI (REG 1) 54) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0019)) ; (JRST (LABEL G0019)) ; (!*LBL (LABEL G0020)) ; (!*MOVE (WCONST 54) (REG 1)) ; (HRRZI (REG 1) 54) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0019)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 16) (WCONST 16)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 16 16)))) ; (!*JUMPEQ (LABEL G0023) (REG 1) (WCONST 17767)) ; (CAIN (REG 1) 17767) ; (JRST (LABEL G0023)) ; (!*MOVE (WCONST 55) (REG 1)) ; (HRRZI (REG 1) 55) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0022)) ; (JRST (LABEL G0022)) ; (!*LBL (LABEL G0023)) ; (!*MOVE (WCONST 55) (REG 1)) ; (HRRZI (REG 1) 55) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0022)) ; (!*MOVE 'NIL (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 36)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 8)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 8 8)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 16 8)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 24 8)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 16)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 16 16)) ; (!*ENTRY FIELDTEST EXPR 1) L0028: intern L0028 PUSH 15,1 HRRZI 5,68 HRRZI 4,76 HRRZI 3,69 HRRZI 2,73 HRRZI 1,70 PUSHJ 15,SYMFNC+140 HRRZI 1,10 PUSHJ 15,SYMFNC+134 LDB 1,L0021 CAMN 1,0(15) JRST L0029 HRRZI 1,49 PUSHJ 15,SYMFNC+142 JRST L0030 L0029: HRRZI 1,49 PUSHJ 15,SYMFNC+141 L0030: LDB 1,L0022 CAIN 1,1 JRST L0031 HRRZI 1,50 PUSHJ 15,SYMFNC+142 JRST L0032 L0031: HRRZI 1,50 PUSHJ 15,SYMFNC+141 L0032: LDB 1,L0023 CAIN 1,35 JRST L0033 HRRZI 1,51 PUSHJ 15,SYMFNC+142 JRST L0034 L0033: HRRZI 1,51 PUSHJ 15,SYMFNC+141 L0034: LDB 1,L0024 CAIN 1,69 JRST L0035 HRRZI 1,52 PUSHJ 15,SYMFNC+142 JRST L0036 L0035: HRRZI 1,52 PUSHJ 15,SYMFNC+141 L0036: LDB 1,L0025 CAIN 1,103 JRST L0037 HRRZI 1,53 PUSHJ 15,SYMFNC+142 JRST L0038 L0037: HRRZI 1,53 PUSHJ 15,SYMFNC+141 L0038: LDB 1,L0026 CAIN 1,291 JRST L0039 HRRZI 1,54 PUSHJ 15,SYMFNC+142 JRST L0040 L0039: HRRZI 1,54 PUSHJ 15,SYMFNC+141 L0040: LDB 1,L0027 CAIN 1,17767 JRST L0041 HRRZI 1,55 PUSHJ 15,SYMFNC+142 JRST L0042 L0041: HRRZI 1,55 PUSHJ 15,SYMFNC+141 L0042: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L0021: point 36,0(15),35 L0022: point 8,0(15),7 L0023: point 8,0(15),15 L0024: point 8,0(15),23 L0025: point 8,0(15),31 L0026: point 16,0(15),15 L0027: point 16,0(15),31 ; (!*ENTRY LSHIFTTEST EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 70) (REG 5)) ; (HRRZI (REG 5) 70) ; (!*MOVE (WCONST 73) (REG 4)) ; (HRRZI (REG 4) 73) ; (!*MOVE (WCONST 72) (REG 3)) ; (HRRZI (REG 3) 72) ; (!*MOVE (WCONST 83) (REG 2)) ; (HRRZI (REG 2) 83) ; (!*MOVE (WCONST 76) (REG 1)) ; (HRRZI (REG 1) 76) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 10) (REG 5)) ; (HRRZI (REG 5) 10) ; (!*MOVE (WCONST 32) (REG 4)) ; (HRRZI (REG 4) 32) ; (!*MOVE (WCONST 32) (REG 3)) ; (HRRZI (REG 3) 32) ; (!*MOVE (WCONST 32) (REG 2)) ; (HRRZI (REG 2) 32) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (WCONST 36) (REG 3)) ; (HRRZI (REG 3) 36) ; (!*MOVE (WCONST 0) (REG 2)) ; (SETZM (REG 2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0006) (REG 1) (FRAME 1)) ; (CAMN (REG 1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0006)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (WCONST 49) (REG 1)) ; (HRRZI (REG 1) 49) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (WCONST 8) (REG 3)) ; (HRRZI (REG 3) 8) ; (!*MOVE (WCONST 0) (REG 2)) ; (SETZM (REG 2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0010) (REG 1) (WCONST 1)) ; (CAIN (REG 1) 1) ; (JRST (LABEL G0010)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0009)) ; (JRST (LABEL G0009)) ; (!*LBL (LABEL G0010)) ; (!*MOVE (WCONST 50) (REG 1)) ; (HRRZI (REG 1) 50) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0009)) ; (!*MOVE (WCONST 8) (REG 3)) ; (HRRZI (REG 3) 8) ; (!*MOVE (WCONST 8) (REG 2)) ; (HRRZI (REG 2) 8) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0014) (REG 1) (WCONST 35)) ; (CAIN (REG 1) 35) ; (JRST (LABEL G0014)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0013)) ; (JRST (LABEL G0013)) ; (!*LBL (LABEL G0014)) ; (!*MOVE (WCONST 51) (REG 1)) ; (HRRZI (REG 1) 51) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0013)) ; (!*MOVE (WCONST 8) (REG 3)) ; (HRRZI (REG 3) 8) ; (!*MOVE (WCONST 16) (REG 2)) ; (HRRZI (REG 2) 16) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0018) (REG 1) (WCONST 69)) ; (CAIN (REG 1) 69) ; (JRST (LABEL G0018)) ; (!*MOVE (WCONST 52) (REG 1)) ; (HRRZI (REG 1) 52) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0017)) ; (JRST (LABEL G0017)) ; (!*LBL (LABEL G0018)) ; (!*MOVE (WCONST 52) (REG 1)) ; (HRRZI (REG 1) 52) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0017)) ; (!*MOVE (WCONST 8) (REG 3)) ; (HRRZI (REG 3) 8) ; (!*MOVE (WCONST 24) (REG 2)) ; (HRRZI (REG 2) 24) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0022) (REG 1) (WCONST 103)) ; (CAIN (REG 1) 103) ; (JRST (LABEL G0022)) ; (!*MOVE (WCONST 53) (REG 1)) ; (HRRZI (REG 1) 53) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0021)) ; (JRST (LABEL G0021)) ; (!*LBL (LABEL G0022)) ; (!*MOVE (WCONST 53) (REG 1)) ; (HRRZI (REG 1) 53) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0021)) ; (!*MOVE (WCONST 16) (REG 3)) ; (HRRZI (REG 3) 16) ; (!*MOVE (WCONST 0) (REG 2)) ; (SETZM (REG 2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0026) (REG 1) (WCONST 291)) ; (CAIN (REG 1) 291) ; (JRST (LABEL G0026)) ; (!*MOVE (WCONST 54) (REG 1)) ; (HRRZI (REG 1) 54) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0025)) ; (JRST (LABEL G0025)) ; (!*LBL (LABEL G0026)) ; (!*MOVE (WCONST 54) (REG 1)) ; (HRRZI (REG 1) 54) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0025)) ; (!*MOVE (WCONST 16) (REG 3)) ; (HRRZI (REG 3) 16) ; (!*MOVE (WCONST 16) (REG 2)) ; (HRRZI (REG 2) 16) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EXTRACT EXPR 3) ; (PUSHJ (REG ST) (ENTRY EXTRACT)) ; (!*JUMPEQ (LABEL G0030) (REG 1) (WCONST 17767)) ; (CAIN (REG 1) 17767) ; (JRST (LABEL G0030)) ; (!*MOVE (WCONST 55) (REG 1)) ; (HRRZI (REG 1) 55) ; (!*LINK TESTERR EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTERR)) ; (!*JUMP (LABEL G0029)) ; (JRST (LABEL G0029)) ; (!*LBL (LABEL G0030)) ; (!*MOVE (WCONST 55) (REG 1)) ; (HRRZI (REG 1) 55) ; (!*LINK TESTOK EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTOK)) ; (!*LBL (LABEL G0029)) ; (!*MOVE 'NIL (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (!*ENTRY LSHIFTTEST EXPR 1) L0043: intern L0043 PUSH 15,1 HRRZI 5,70 HRRZI 4,73 HRRZI 3,72 HRRZI 2,83 HRRZI 1,76 PUSHJ 15,SYMFNC+140 HRRZI 5,10 HRRZI 4,32 HRRZI 3,32 HRRZI 2,32 HRRZI 1,84 PUSHJ 15,SYMFNC+140 HRRZI 3,36 SETZM 2 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAMN 1,0(15) JRST L0044 HRRZI 1,49 PUSHJ 15,SYMFNC+142 JRST L0045 L0044: HRRZI 1,49 PUSHJ 15,SYMFNC+141 L0045: HRRZI 3,8 SETZM 2 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,1 JRST L0046 HRRZI 1,50 PUSHJ 15,SYMFNC+142 JRST L0047 L0046: HRRZI 1,50 PUSHJ 15,SYMFNC+141 L0047: HRRZI 3,8 HRRZI 2,8 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,35 JRST L0048 HRRZI 1,51 PUSHJ 15,SYMFNC+142 JRST L0049 L0048: HRRZI 1,51 PUSHJ 15,SYMFNC+141 L0049: HRRZI 3,8 HRRZI 2,16 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,69 JRST L0050 HRRZI 1,52 PUSHJ 15,SYMFNC+142 JRST L0051 L0050: HRRZI 1,52 PUSHJ 15,SYMFNC+141 L0051: HRRZI 3,8 HRRZI 2,24 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,103 JRST L0052 HRRZI 1,53 PUSHJ 15,SYMFNC+142 JRST L0053 L0052: HRRZI 1,53 PUSHJ 15,SYMFNC+141 L0053: HRRZI 3,16 SETZM 2 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,291 JRST L0054 HRRZI 1,54 PUSHJ 15,SYMFNC+142 JRST L0055 L0054: HRRZI 1,54 PUSHJ 15,SYMFNC+141 L0055: HRRZI 3,16 HRRZI 2,16 MOVE 1,0(15) PUSHJ 15,SYMFNC+147 CAIN 1,17767 JRST L0056 HRRZI 1,55 PUSHJ 15,SYMFNC+142 JRST L0057 L0056: HRRZI 1,55 PUSHJ 15,SYMFNC+141 L0057: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY MSG5 EXPR 5) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 2) (FRAME 1)) ; (MOVEM (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 3) (FRAME 2)) ; (MOVEM (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 4) (FRAME 3)) ; (MOVEM (REG 4) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 5) (FRAME 4)) ; (MOVEM (REG 5) (INDEXED (REG ST) -3)) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*LINKE 4 PUTC EXPR 1) ; (ADJSP (REG ST) (MINUS 4)) ; (JRST (ENTRY PUTC)) ; (!*ENTRY MSG5 EXPR 5) MSG5: intern MSG5 ADJSP 15,4 MOVEM 2,0(15) MOVEM 3,-1(15) MOVEM 4,-2(15) MOVEM 5,-3(15) PUSHJ 15,SYMFNC+134 MOVE 1,0(15) PUSHJ 15,SYMFNC+134 MOVE 1,-1(15) PUSHJ 15,SYMFNC+134 MOVE 1,-2(15) PUSHJ 15,SYMFNC+134 MOVE 1,-3(15) ADJSP 15,-4 JRST SYMFNC+134 ; (!*ENTRY TESTNUM EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 32) (REG 5)) ; (HRRZI (REG 5) 32) ; (!*MOVE (WCONST 116) (REG 4)) ; (HRRZI (REG 4) 116) ; (!*MOVE (WCONST 115) (REG 3)) ; (HRRZI (REG 3) 115) ; (!*MOVE (WCONST 101) (REG 2)) ; (HRRZI (REG 2) 101) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK MSG5 EXPR 5) ; (PUSHJ (REG ST) (ENTRY MSG5)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*LINK PUTC EXPR 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE 'NIL (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (!*ENTRY TESTNUM EXPR 1) L0058: intern L0058 PUSH 15,1 HRRZI 5,32 HRRZI 4,116 HRRZI 3,115 HRRZI 2,101 HRRZI 1,84 PUSHJ 15,SYMFNC+140 MOVE 1,0(15) PUSHJ 15,SYMFNC+134 HRRZI 1,32 PUSHJ 15,SYMFNC+134 MOVE 1,0 ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY TESTERR EXPR 1) ; (!*ALLOC 0) ; (!*LINK TESTNUM EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTNUM)) ; (!*MOVE (WCONST 10) (REG 5)) ; (HRRZI (REG 5) 10) ; (!*MOVE (WCONST 32) (REG 4)) ; (HRRZI (REG 4) 32) ; (!*MOVE (WCONST 114) (REG 3)) ; (HRRZI (REG 3) 114) ; (!*MOVE (WCONST 114) (REG 2)) ; (HRRZI (REG 2) 114) ; (!*MOVE (WCONST 69) (REG 1)) ; (HRRZI (REG 1) 69) ; (!*LINKE 0 MSG5 EXPR 5) ; (JRST (ENTRY MSG5)) ; (!*ENTRY TESTERR EXPR 1) L0059: intern L0059 PUSHJ 15,SYMFNC+148 HRRZI 5,10 HRRZI 4,32 HRRZI 3,114 HRRZI 2,114 HRRZI 1,69 JRST SYMFNC+140 ; (!*ENTRY TESTOK EXPR 1) ; (!*ALLOC 0) ; (!*LINK TESTNUM EXPR 1) ; (PUSHJ (REG ST) (ENTRY TESTNUM)) ; (!*MOVE (WCONST 10) (REG 5)) ; (HRRZI (REG 5) 10) ; (!*MOVE (WCONST 32) (REG 4)) ; (HRRZI (REG 4) 32) ; (!*MOVE (WCONST 32) (REG 3)) ; (HRRZI (REG 3) 32) ; (!*MOVE (WCONST 107) (REG 2)) ; (HRRZI (REG 2) 107) ; (!*MOVE (WCONST 79) (REG 1)) ; (HRRZI (REG 1) 79) ; (!*LINKE 0 MSG5 EXPR 5) ; (JRST (ENTRY MSG5)) ; (!*ENTRY TESTOK EXPR 1) TESTOK: intern TESTOK PUSHJ 15,SYMFNC+148 HRRZI 5,10 HRRZI 4,32 HRRZI 3,32 HRRZI 2,107 HRRZI 1,79 JRST SYMFNC+140 ; (!*ENTRY MAKEMASK EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*WSHIFT (REG 1) (REG 2)) ; (LSH (REG 1) (INDEXED (REG 2) 0)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*ENTRY MAKEMASK EXPR 1) L0060: intern L0060 MOVE 2,1 HRRZI 1,1 LSH 1,0(2) SOS 1 POPJ 15,0 ; (!*ENTRY EXTRACT EXPR 3) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*LINK MAKEMASK EXPR 1) ; (PUSHJ (REG ST) (ENTRY MAKEMASK)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 2) (FRAME 3)) ; (ADD (REG 2) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 2) (WCONST -36)) ; (SUBI (REG 2) (MINUS -36)) ; (!*MOVE (REG 2) (FRAME 5)) ; (MOVEM (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*WSHIFT (REG 3) (REG 2)) ; (LSH (REG 3) (INDEXED (REG 2) 0)) ; (!*WAND (REG 1) (REG 3)) ; (AND (REG 1) (REG 3)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) ; (!*ENTRY EXTRACT EXPR 3) L0061: intern L0061 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,3 PUSHJ 15,SYMFNC+149 MOVEM 1,-3(15) MOVE 2,-1(15) ADD 2,-2(15) SUBI 2,36 MOVEM 2,-4(15) MOVE 3,0(15) LSH 3,0(2) AND 1,3 ADJSP 15,-5 POPJ 15,0 ; (!*ENTRY INITCODE EXPR 0) L0062: intern L0062 MOVE 1,0 POPJ 15,0 extern SYMPRP extern SYMVAL extern SYMNAM L0063: 0 byte(7)0,0 intern L0063 L0064: 0 byte(7)1,0 intern L0064 L0065: 0 byte(7)2,0 intern L0065 L0066: 0 byte(7)3,0 intern L0066 L0067: 0 byte(7)4,0 intern L0067 L0068: 0 byte(7)5,0 intern L0068 L0069: 0 byte(7)6,0 intern L0069 L0070: 0 byte(7)7,0 intern L0070 L0071: 0 byte(7)8,0 intern L0071 L0072: 0 byte(7)9,0 intern L0072 L0073: 0 byte(7)10,0 intern L0073 L0074: 0 byte(7)11,0 intern L0074 L0075: 0 byte(7)12,0 intern L0075 L0076: 0 byte(7)13,0 intern L0076 L0077: 0 byte(7)14,0 intern L0077 L0078: 0 byte(7)15,0 intern L0078 L0079: 0 byte(7)16,0 intern L0079 L0080: 0 byte(7)17,0 intern L0080 L0081: 0 byte(7)18,0 intern L0081 L0082: 0 byte(7)19,0 intern L0082 L0083: 0 byte(7)20,0 intern L0083 L0084: 0 byte(7)21,0 intern L0084 L0085: 0 byte(7)22,0 intern L0085 L0086: 0 byte(7)23,0 intern L0086 L0087: 0 byte(7)24,0 intern L0087 L0088: 0 byte(7)25,0 intern L0088 L0089: 0 byte(7)26,0 intern L0089 L0090: 0 byte(7)27,0 intern L0090 L0091: 0 byte(7)28,0 intern L0091 L0092: 0 byte(7)29,0 intern L0092 L0093: 0 byte(7)30,0 intern L0093 L0094: 0 byte(7)31,0 intern L0094 L0095: 0 byte(7)32,0 intern L0095 L0096: 0 byte(7)33,0 intern L0096 L0097: 0 byte(7)34,0 intern L0097 L0098: 0 byte(7)35,0 intern L0098 L0099: 0 byte(7)36,0 intern L0099 L0100: 0 byte(7)37,0 intern L0100 L0101: 0 byte(7)38,0 intern L0101 L0102: 0 byte(7)39,0 intern L0102 L0103: 0 byte(7)40,0 intern L0103 L0104: 0 byte(7)41,0 intern L0104 L0105: 0 byte(7)42,0 intern L0105 L0106: 0 byte(7)43,0 intern L0106 L0107: 0 byte(7)44,0 intern L0107 L0108: 0 byte(7)45,0 intern L0108 L0109: 0 byte(7)46,0 intern L0109 L0110: 0 byte(7)47,0 intern L0110 L0111: 0 byte(7)48,0 intern L0111 L0112: 0 byte(7)49,0 intern L0112 L0113: 0 byte(7)50,0 intern L0113 L0114: 0 byte(7)51,0 intern L0114 L0115: 0 byte(7)52,0 intern L0115 L0116: 0 byte(7)53,0 intern L0116 L0117: 0 byte(7)54,0 intern L0117 L0118: 0 byte(7)55,0 intern L0118 L0119: 0 byte(7)56,0 intern L0119 L0120: 0 byte(7)57,0 intern L0120 L0121: 0 byte(7)58,0 intern L0121 L0122: 0 byte(7)59,0 intern L0122 L0123: 0 byte(7)60,0 intern L0123 L0124: 0 byte(7)61,0 intern L0124 L0125: 0 byte(7)62,0 intern L0125 L0126: 0 byte(7)63,0 intern L0126 L0127: 0 byte(7)64,0 intern L0127 L0128: 0 byte(7)65,0 intern L0128 L0129: 0 byte(7)66,0 intern L0129 L0130: 0 byte(7)67,0 intern L0130 L0131: 0 byte(7)68,0 intern L0131 L0132: 0 byte(7)69,0 intern L0132 L0133: 0 byte(7)70,0 intern L0133 L0134: 0 byte(7)71,0 intern L0134 L0135: 0 byte(7)72,0 intern L0135 L0136: 0 byte(7)73,0 intern L0136 L0137: 0 byte(7)74,0 intern L0137 L0138: 0 byte(7)75,0 intern L0138 L0139: 0 byte(7)76,0 intern L0139 L0140: 0 byte(7)77,0 intern L0140 L0141: 0 byte(7)78,0 intern L0141 L0142: 0 byte(7)79,0 intern L0142 L0143: 0 byte(7)80,0 intern L0143 L0144: 0 byte(7)81,0 intern L0144 L0145: 0 byte(7)82,0 intern L0145 L0146: 0 byte(7)83,0 intern L0146 L0147: 0 byte(7)84,0 intern L0147 L0148: 0 byte(7)85,0 intern L0148 L0149: 0 byte(7)86,0 intern L0149 L0150: 0 byte(7)87,0 intern L0150 L0151: 0 byte(7)88,0 intern L0151 L0152: 0 byte(7)89,0 intern L0152 L0153: 0 byte(7)90,0 intern L0153 L0154: 0 byte(7)91,0 intern L0154 L0155: 0 byte(7)92,0 intern L0155 L0156: 0 byte(7)93,0 intern L0156 L0157: 0 byte(7)94,0 intern L0157 L0158: 0 byte(7)95,0 intern L0158 L0159: 0 byte(7)96,0 intern L0159 L0160: 0 byte(7)97,0 intern L0160 L0161: 0 byte(7)98,0 intern L0161 L0162: 0 byte(7)99,0 intern L0162 L0163: 0 byte(7)100,0 intern L0163 L0164: 0 byte(7)101,0 intern L0164 L0165: 0 byte(7)102,0 intern L0165 L0166: 0 byte(7)103,0 intern L0166 L0167: 0 byte(7)104,0 intern L0167 L0168: 0 byte(7)105,0 intern L0168 L0169: 0 byte(7)106,0 intern L0169 L0170: 0 byte(7)107,0 intern L0170 L0171: 0 byte(7)108,0 intern L0171 L0172: 0 byte(7)109,0 intern L0172 L0173: 0 byte(7)110,0 intern L0173 L0174: 0 byte(7)111,0 intern L0174 L0175: 0 byte(7)112,0 intern L0175 L0176: 0 byte(7)113,0 intern L0176 L0177: 0 byte(7)114,0 intern L0177 L0178: 0 byte(7)115,0 intern L0178 L0179: 0 byte(7)116,0 intern L0179 L0180: 0 byte(7)117,0 intern L0180 L0181: 0 byte(7)118,0 intern L0181 L0182: 0 byte(7)119,0 intern L0182 L0183: 0 byte(7)120,0 intern L0183 L0184: 0 byte(7)121,0 intern L0184 L0185: 0 byte(7)122,0 intern L0185 L0186: 0 byte(7)123,0 intern L0186 L0187: 0 byte(7)124,0 intern L0187 L0188: 0 byte(7)125,0 intern L0188 L0189: 0 byte(7)126,0 intern L0189 L0190: 0 byte(7)127,0 intern L0190 L0191: 2 byte(7)78,73,76,0 intern L0191 L0192: 4 byte(7)77,65,73,78,46,0 intern L0192 L0193: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L0193 L0194: 3 byte(7)73,78,73,84,0 intern L0194 L0195: 3 byte(7)71,69,84,67,0 intern L0195 L0196: 3 byte(7)84,73,77,67,0 intern L0196 L0197: 3 byte(7)80,85,84,67,0 intern L0197 L0198: 3 byte(7)81,85,73,84,0 intern L0198 L0199: 5 byte(7)80,85,84,73,78,84,0 intern L0199 L0200: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L0200 L0201: 3 byte(7)70,76,65,71,0 intern L0201 L0202: 8 byte(7)42,87,84,73,77,69,83,51,50,0 intern L0202 L0203: 3 byte(7)77,83,71,53,0 intern L0203 L0204: 5 byte(7)84,69,83,84,79,75,0 intern L0204 L0205: 6 byte(7)84,69,83,84,69,82,82,0 intern L0205 L0206: 2 byte(7)69,82,82,0 intern L0206 L0207: 9 byte(7)65,83,72,73,70,84,84,69,83,84,0 intern L0207 L0208: 8 byte(7)70,73,69,76,68,84,69,83,84,0 intern L0208 L0209: 9 byte(7)76,83,72,73,70,84,84,69,83,84,0 intern L0209 L0210: 6 byte(7)69,88,84,82,65,67,84,0 intern L0210 L0211: 6 byte(7)84,69,83,84,78,85,77,0 intern L0211 L0212: 7 byte(7)77,65,75,69,77,65,83,75,0 intern L0212 L0213: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L0213 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/20-tests/fresh.init version [a7ffc6f8bf].
Added psl-1983/20-tests/fresh.mic version [db2395ae05].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independant compilation of a PSL program ; ; MIC FRESH modulename ; ; Initialize for new sequence of builds ; @delete 'a.SYM @copy pc:bare-psl.sym 'A.sym @define DSK:, DSK:, PT:, P20:, PI: ;avoid obnoixous ^Q halts... @terminal length 0 @reset dec20-cross @s:DEC20-cross.exe off break; %kill obnoxious break loops off USERMODE ; InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''NIL; ModName!*:='''A; ASMOUT "FRESH"$ ASMEnd$ quit$ @terminal length 24 @delete Fresh.mac @delete DFresh.mac |
Added psl-1983/20-tests/junk.it version [3ba39ac3ed].
> > > | 1 2 3 | This is the Test.It file. It has 3 lines (this is Line 2) This is the last line. |
Added psl-1983/20-tests/junk.junk version [e713e948aa].
> > > | 1 2 3 | Line 1 Line 2 Line 3 (last) |
Added psl-1983/20-tests/main1.cmd version [f2564ec47d].
> > | 1 2 | main1,Dmain1,20io |
Added psl-1983/20-tests/main1.init version [d86574d3c4].
> > > > | 1 2 3 4 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/20-tests/main1.mac version [735de0b662].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern STACK extern HEAP extern L0001 extern L0002 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 129) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L0005 MOVE 0,SYMVAL+128 HRRZI 12,129 SETZM 13 JRST SYMFNC+129 L0005: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+132 HRRZI 6,1 MOVEM 6,SYMVAL+133 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+132 JRST L0006 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L0006: MOVE 1,SYMVAL+132 HRRZI 12,134 HRRZI 13,1 JRST SYMFNC+134 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 137) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+133 CAIE 7,1 JRST L0007 PUSHJ 15,PUTC20 POPJ 15,0 L0007: MOVE 2,1 MOVE 1,SYMVAL+133 HRRZI 12,137 HRRZI 13,2 JRST SYMFNC+137 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L0008: intern L0008 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L0009: intern L0009 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 1) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 1 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 1) L0010: intern L0010 MOVEM 12,SYMVAL+144 MOVEM 13,SYMVAL+145 JRST SYMFNC+146 ; (!*ENTRY FLAG EXPR 2) ; (!*MOVE 2 (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINK ERR20 EXPR 1) extern ERR20 ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) 2 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L0011: intern L0011 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 149) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L0012: intern L0012 HRRZI 12,149 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 151) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L0013: intern L0013 HRRZI 12,151 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 0) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 131) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*MOVE (WCONST 65) (REG 1)) ; (HRRZI (REG 1) 65) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 66) (REG 1)) ; (HRRZI (REG 1) 66) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINK IFACT EXPR 1) ; (HRRZI (REG LINKREG) 154) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY IFACT)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TESTFACT EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TESTFACT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TESTTAK EXPR 0) ; (HRRZI (REG LINKREG) 156) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TESTTAK)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY FIRSTCALL EXPR 0) L0014: intern L0014 HRRZI 12,131 SETZM 13 PUSHJ 15,SYMFNC+131 HRRZI 1,65 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 1,66 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 HRRZI 1,10 HRRZI 12,154 HRRZI 13,1 PUSHJ 15,SYMFNC+154 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 HRRZI 12,156 SETZM 13 PUSHJ 15,SYMFNC+156 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0 POPJ 15,0 ; (!*ENTRY TERPRI EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 0 ; (!*ENTRY TERPRI EXPR 0) TERPRI: intern TERPRI HRRZI 1,10 HRRZI 12,138 HRRZI 13,1 JRST SYMFNC+138 ; (!*ENTRY TESTFACT EXPR 0) ; (!*ALLOC 0) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 136) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 10000) (REG 1)) ; (HRRZI (REG 1) 10000) ; (!*LINK ARITHMETICTEST EXPR 1) ; (HRRZI (REG LINKREG) 157) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ARITHMETICTEST)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 136) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TESTFACT EXPR 0) L0015: intern L0015 HRRZI 12,136 SETZM 13 PUSHJ 15,SYMFNC+136 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 HRRZI 1,10000 HRRZI 12,157 HRRZI 13,1 PUSHJ 15,SYMFNC+157 HRRZI 12,136 SETZM 13 PUSHJ 15,SYMFNC+136 MOVE 1,0 POPJ 15,0 ; (!*ENTRY ARITHMETICTEST EXPR 1) ; (!*PUSH (WCONST 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (WCONST 9) (REG 1)) ; (HRRZI (REG 1) 9) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FACT)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY ARITHMETICTEST EXPR 1) L0017: intern L0017 PUSH 15,L0016 PUSH 15,1 L0018: MOVE 6,-1(15) CAMG 6,0(15) JRST L0019 MOVE 1,0 JRST L0020 L0019: HRRZI 1,9 HRRZI 12,158 HRRZI 13,1 PUSHJ 15,SYMFNC+158 AOS -1(15) JRST L0018 L0020: ADJSP 15,-2 POPJ 15,0 L0016: 0 ; (!*ENTRY TESTTAK EXPR 0) ; (!*ALLOC 0) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 136) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*MOVE (WCONST 6) (REG 3)) ; (HRRZI (REG 3) 6) ; (!*MOVE (WCONST 12) (REG 2)) ; (HRRZI (REG 2) 12) ; (!*MOVE (WCONST 18) (REG 1)) ; (HRRZI (REG 1) 18) ; (!*LINK TOPLEVELTAK EXPR 3) ; (HRRZI (REG LINKREG) 159) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TOPLEVELTAK)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 136) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TESTTAK EXPR 0) L0021: intern L0021 HRRZI 12,136 SETZM 13 PUSHJ 15,SYMFNC+136 HRRZI 3,6 HRRZI 2,12 HRRZI 1,18 HRRZI 12,159 HRRZI 13,3 PUSHJ 15,SYMFNC+159 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 HRRZI 12,136 SETZM 13 PUSHJ 15,SYMFNC+136 MOVE 1,0 POPJ 15,0 ; (!*ENTRY TOPLEVELTAK EXPR 3) ; (!*ALLOC 0) ; (!*LINKE 0 TAK EXPR 3) ; (HRRZI (REG LINKREG) 160) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY TAK)) 3 ; (!*ENTRY TOPLEVELTAK EXPR 3) L0022: intern L0022 HRRZI 12,160 HRRZI 13,3 JRST SYMFNC+160 ; (!*ENTRY TAK EXPR 3) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*JUMPWLESSP (LABEL G0004) (REG 2) (REG 1)) ; (CAMGE (REG 2) (REG 1)) ; (JRST (LABEL G0004)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 160) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 160) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 5)) ; (MOVEM (REG 1) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 160) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 5) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY TAK EXPR 3) TAK: intern TAK ADJSP 15,5 L0023: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) CAMGE 2,1 JRST L0024 MOVE 1,3 JRST L0025 L0024: SOS 1 HRRZI 12,160 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-3(15) MOVE 3,0(15) MOVE 2,-2(15) MOVE 1,-1(15) SOS 1 HRRZI 12,160 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-4(15) MOVE 3,-1(15) MOVE 2,0(15) MOVE 1,-2(15) SOS 1 HRRZI 12,160 HRRZI 13,3 PUSHJ 15,TAK MOVE 3,1 MOVE 2,-4(15) MOVE 1,-3(15) JRST L0023 L0025: ADJSP 15,-5 POPJ 15,0 ; (!*ENTRY FACT EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPWGEQ (LABEL G0004) (REG 1) (WCONST 2)) ; (CAIL (REG 1) 2) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY FACT)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 LONGTIMES EXPR 2) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 148) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY LONGTIMES)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY FACT EXPR 1) FACT: intern FACT PUSH 15,1 CAIL 1,2 JRST L0026 HRRZI 1,1 JRST L0027 L0026: SOS 1 HRRZI 12,158 HRRZI 13,1 PUSHJ 15,FACT MOVE 2,1 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,148 HRRZI 13,2 JRST SYMFNC+148 L0027: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY IFACT EXPR 1) ; (!*PUSH (WCONST 1)) ; (PUSH (REG ST) (LIT (FULLWORD 1))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0005) (FRAME 1) (WCONST 1)) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (CAIE (REG T1) 1) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LONGTIMES EXPR 2) ; (HRRZI (REG LINKREG) 148) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LONGTIMES)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (FRAME 1) (WCONST -1)) ; (SOS (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 153) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 1) 1 ; (!*ENTRY IFACT EXPR 1) IFACT: intern IFACT PUSH 15,L0028 PUSH 15,1 L0029: MOVE 6,0(15) CAIE 6,1 JRST L0030 MOVE 1,-1(15) JRST L0031 L0030: MOVE 2,-1(15) MOVE 1,0(15) HRRZI 12,148 HRRZI 13,2 PUSHJ 15,SYMFNC+148 MOVEM 1,-1(15) SOS 0(15) MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 MOVE 1,-1(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 HRRZI 12,153 SETZM 13 PUSHJ 15,SYMFNC+153 JRST L0029 L0031: ADJSP 15,-2 POPJ 15,0 L0028: 1 0 ; (!*ENTRY INITCODE EXPR 0) L0032: intern L0032 MOVE 1,0 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L0033: 0 byte(7)0,0 intern L0033 L0034: 0 byte(7)1,0 intern L0034 L0035: 0 byte(7)2,0 intern L0035 L0036: 0 byte(7)3,0 intern L0036 L0037: 0 byte(7)4,0 intern L0037 L0038: 0 byte(7)5,0 intern L0038 L0039: 0 byte(7)6,0 intern L0039 L0040: 0 byte(7)7,0 intern L0040 L0041: 0 byte(7)8,0 intern L0041 L0042: 0 byte(7)9,0 intern L0042 L0043: 0 byte(7)10,0 intern L0043 L0044: 0 byte(7)11,0 intern L0044 L0045: 0 byte(7)12,0 intern L0045 L0046: 0 byte(7)13,0 intern L0046 L0047: 0 byte(7)14,0 intern L0047 L0048: 0 byte(7)15,0 intern L0048 L0049: 0 byte(7)16,0 intern L0049 L0050: 0 byte(7)17,0 intern L0050 L0051: 0 byte(7)18,0 intern L0051 L0052: 0 byte(7)19,0 intern L0052 L0053: 0 byte(7)20,0 intern L0053 L0054: 0 byte(7)21,0 intern L0054 L0055: 0 byte(7)22,0 intern L0055 L0056: 0 byte(7)23,0 intern L0056 L0057: 0 byte(7)24,0 intern L0057 L0058: 0 byte(7)25,0 intern L0058 L0059: 0 byte(7)26,0 intern L0059 L0060: 0 byte(7)27,0 intern L0060 L0061: 0 byte(7)28,0 intern L0061 L0062: 0 byte(7)29,0 intern L0062 L0063: 0 byte(7)30,0 intern L0063 L0064: 0 byte(7)31,0 intern L0064 L0065: 0 byte(7)32,0 intern L0065 L0066: 0 byte(7)33,0 intern L0066 L0067: 0 byte(7)34,0 intern L0067 L0068: 0 byte(7)35,0 intern L0068 L0069: 0 byte(7)36,0 intern L0069 L0070: 0 byte(7)37,0 intern L0070 L0071: 0 byte(7)38,0 intern L0071 L0072: 0 byte(7)39,0 intern L0072 L0073: 0 byte(7)40,0 intern L0073 L0074: 0 byte(7)41,0 intern L0074 L0075: 0 byte(7)42,0 intern L0075 L0076: 0 byte(7)43,0 intern L0076 L0077: 0 byte(7)44,0 intern L0077 L0078: 0 byte(7)45,0 intern L0078 L0079: 0 byte(7)46,0 intern L0079 L0080: 0 byte(7)47,0 intern L0080 L0081: 0 byte(7)48,0 intern L0081 L0082: 0 byte(7)49,0 intern L0082 L0083: 0 byte(7)50,0 intern L0083 L0084: 0 byte(7)51,0 intern L0084 L0085: 0 byte(7)52,0 intern L0085 L0086: 0 byte(7)53,0 intern L0086 L0087: 0 byte(7)54,0 intern L0087 L0088: 0 byte(7)55,0 intern L0088 L0089: 0 byte(7)56,0 intern L0089 L0090: 0 byte(7)57,0 intern L0090 L0091: 0 byte(7)58,0 intern L0091 L0092: 0 byte(7)59,0 intern L0092 L0093: 0 byte(7)60,0 intern L0093 L0094: 0 byte(7)61,0 intern L0094 L0095: 0 byte(7)62,0 intern L0095 L0096: 0 byte(7)63,0 intern L0096 L0097: 0 byte(7)64,0 intern L0097 L0098: 0 byte(7)65,0 intern L0098 L0099: 0 byte(7)66,0 intern L0099 L0100: 0 byte(7)67,0 intern L0100 L0101: 0 byte(7)68,0 intern L0101 L0102: 0 byte(7)69,0 intern L0102 L0103: 0 byte(7)70,0 intern L0103 L0104: 0 byte(7)71,0 intern L0104 L0105: 0 byte(7)72,0 intern L0105 L0106: 0 byte(7)73,0 intern L0106 L0107: 0 byte(7)74,0 intern L0107 L0108: 0 byte(7)75,0 intern L0108 L0109: 0 byte(7)76,0 intern L0109 L0110: 0 byte(7)77,0 intern L0110 L0111: 0 byte(7)78,0 intern L0111 L0112: 0 byte(7)79,0 intern L0112 L0113: 0 byte(7)80,0 intern L0113 L0114: 0 byte(7)81,0 intern L0114 L0115: 0 byte(7)82,0 intern L0115 L0116: 0 byte(7)83,0 intern L0116 L0117: 0 byte(7)84,0 intern L0117 L0118: 0 byte(7)85,0 intern L0118 L0119: 0 byte(7)86,0 intern L0119 L0120: 0 byte(7)87,0 intern L0120 L0121: 0 byte(7)88,0 intern L0121 L0122: 0 byte(7)89,0 intern L0122 L0123: 0 byte(7)90,0 intern L0123 L0124: 0 byte(7)91,0 intern L0124 L0125: 0 byte(7)92,0 intern L0125 L0126: 0 byte(7)93,0 intern L0126 L0127: 0 byte(7)94,0 intern L0127 L0128: 0 byte(7)95,0 intern L0128 L0129: 0 byte(7)96,0 intern L0129 L0130: 0 byte(7)97,0 intern L0130 L0131: 0 byte(7)98,0 intern L0131 L0132: 0 byte(7)99,0 intern L0132 L0133: 0 byte(7)100,0 intern L0133 L0134: 0 byte(7)101,0 intern L0134 L0135: 0 byte(7)102,0 intern L0135 L0136: 0 byte(7)103,0 intern L0136 L0137: 0 byte(7)104,0 intern L0137 L0138: 0 byte(7)105,0 intern L0138 L0139: 0 byte(7)106,0 intern L0139 L0140: 0 byte(7)107,0 intern L0140 L0141: 0 byte(7)108,0 intern L0141 L0142: 0 byte(7)109,0 intern L0142 L0143: 0 byte(7)110,0 intern L0143 L0144: 0 byte(7)111,0 intern L0144 L0145: 0 byte(7)112,0 intern L0145 L0146: 0 byte(7)113,0 intern L0146 L0147: 0 byte(7)114,0 intern L0147 L0148: 0 byte(7)115,0 intern L0148 L0149: 0 byte(7)116,0 intern L0149 L0150: 0 byte(7)117,0 intern L0150 L0151: 0 byte(7)118,0 intern L0151 L0152: 0 byte(7)119,0 intern L0152 L0153: 0 byte(7)120,0 intern L0153 L0154: 0 byte(7)121,0 intern L0154 L0155: 0 byte(7)122,0 intern L0155 L0156: 0 byte(7)123,0 intern L0156 L0157: 0 byte(7)124,0 intern L0157 L0158: 0 byte(7)125,0 intern L0158 L0159: 0 byte(7)126,0 intern L0159 L0160: 0 byte(7)127,0 intern L0160 L0161: 2 byte(7)78,73,76,0 intern L0161 L0162: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L0162 L0163: 4 byte(7)77,65,73,78,46,0 intern L0163 L0164: 3 byte(7)73,78,73,84,0 intern L0164 L0165: 2 byte(7)73,78,42,0 intern L0165 L0166: 3 byte(7)79,85,84,42,0 intern L0166 L0167: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L0167 L0168: 3 byte(7)71,69,84,67,0 intern L0168 L0169: 3 byte(7)84,73,77,67,0 intern L0169 L0170: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L0170 L0171: 3 byte(7)80,85,84,67,0 intern L0171 L0172: 3 byte(7)81,85,73,84,0 intern L0172 L0173: 5 byte(7)80,85,84,73,78,84,0 intern L0173 L0174: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L0174 L0175: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L0175 L0176: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L0176 L0177: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L0177 L0178: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L0178 L0179: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L0179 L0180: 3 byte(7)70,76,65,71,0 intern L0180 L0181: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L0181 L0182: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L0182 L0183: 6 byte(7)76,79,78,71,68,73,86,0 intern L0183 L0184: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L0184 L0185: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L0185 L0186: 5 byte(7)84,69,82,80,82,73,0 intern L0186 L0187: 4 byte(7)73,70,65,67,84,0 intern L0187 L0188: 7 byte(7)84,69,83,84,70,65,67,84,0 intern L0188 L0189: 6 byte(7)84,69,83,84,84,65,75,0 intern L0189 L0190: 13 byte(7)65,82,73,84,72,77,69,84,73,67,84,69,83,84,0 intern L0190 L0191: 3 byte(7)70,65,67,84,0 intern L0191 L0192: 10 byte(7)84,79,80,76,69,86,69,76,84,65,75,0 intern L0192 L0193: 2 byte(7)84,65,75,0 intern L0193 L0194: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L0194 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/20-tests/main1.sym version [e4d6777ae6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION '(PROGN)) (SETQ ORDEREDIDLIST!* 'NIL) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* '129) (SETQ STRINGGENSYM!* '"L0004") (PUT 'INFBITLENGTH 'SCOPE 'EXTERNAL) (PUT 'INFBITLENGTH 'ASMSYMBOL 'NIL) (PUT 'INFBITLENGTH 'WCONST '18) (PUT 'ST 'SCOPE 'EXTERNAL) (PUT 'ST 'ASMSYMBOL 'NIL) (PUT 'ST 'WVAR 'ST) (PUT 'ARG14 'SCOPE 'EXTERNAL) (PUT 'ARG14 'ASMSYMBOL 'ARG14) (PUT 'ARG14 'WVAR 'ARG14) (PUT 'SYMFNC 'SCOPE 'EXTERNAL) (PUT 'SYMFNC 'ASMSYMBOL 'SYMFNC) (PUT 'SYMFNC 'WARRAY 'SYMFNC) (PUT 'MAXOBARRAY 'SCOPE 'EXTERNAL) (PUT 'MAXOBARRAY 'ASMSYMBOL 'NIL) (PUT 'MAXOBARRAY 'WCONST '500) (PUT 'ARG10 'SCOPE 'EXTERNAL) (PUT 'ARG10 'ASMSYMBOL 'ARG10) (PUT 'ARG10 'WVAR 'ARG10) (PUT 'SYMNAM 'SCOPE 'EXTERNAL) (PUT 'SYMNAM 'ASMSYMBOL 'SYMNAM) (PUT 'SYMNAM 'WARRAY 'SYMNAM) (PUT 'MAXREALREGS 'SCOPE 'EXTERNAL) (PUT 'MAXREALREGS 'ASMSYMBOL 'NIL) (PUT 'MAXREALREGS 'WCONST '5) (PUT 'SYMPRP 'SCOPE 'EXTERNAL) (PUT 'SYMPRP 'ASMSYMBOL 'SYMPRP) (PUT 'SYMPRP 'WARRAY 'SYMPRP) (PUT 'TAGBITLENGTH 'SCOPE 'EXTERNAL) (PUT 'TAGBITLENGTH 'ASMSYMBOL 'NIL) (PUT 'TAGBITLENGTH 'WCONST '5) (PUT 'BITSPERWORD 'SCOPE 'EXTERNAL) (PUT 'BITSPERWORD 'ASMSYMBOL 'NIL) (PUT 'BITSPERWORD 'WCONST '36) (PUT 'ARG13 'SCOPE 'EXTERNAL) (PUT 'ARG13 'ASMSYMBOL 'ARG13) (PUT 'ARG13 'WVAR 'ARG13) (PUT 'MAXSYMBOLS 'SCOPE 'EXTERNAL) (PUT 'MAXSYMBOLS 'ASMSYMBOL 'NIL) (PUT 'MAXSYMBOLS 'WCONST '500) (PUT 'ARG9 'SCOPE 'EXTERNAL) (PUT 'ARG9 'ASMSYMBOL 'ARG9) (PUT 'ARG9 'WVAR 'ARG9) (PUT 'GCSTARTINGBIT 'SCOPE 'EXTERNAL) (PUT 'GCSTARTINGBIT 'ASMSYMBOL 'NIL) (PUT 'GCSTARTINGBIT 'WCONST '5) (PUT 'ARG7 'SCOPE 'EXTERNAL) (PUT 'ARG7 'ASMSYMBOL 'ARG7) (PUT 'ARG7 'WVAR 'ARG7) (PUT 'ARG5 'SCOPE 'EXTERNAL) (PUT 'ARG5 'ASMSYMBOL 'ARG5) (PUT 'ARG5 'WVAR 'ARG5) (PUT 'ADDRESSINGUNITSPERFUNCTIONCELL 'SCOPE 'EXTERNAL) (PUT 'ADDRESSINGUNITSPERFUNCTIONCELL 'ASMSYMBOL 'NIL) (PUT 'ADDRESSINGUNITSPERFUNCTIONCELL 'WCONST '1) (PUT 'ARG3 'SCOPE 'EXTERNAL) (PUT 'ARG3 'ASMSYMBOL 'ARG3) (PUT 'ARG3 'WVAR 'ARG3) (PUT 'ARG1 'SCOPE 'EXTERNAL) (PUT 'ARG1 'ASMSYMBOL 'ARG1) (PUT 'ARG1 'WVAR 'ARG1) (PUT 'BPSSIZE 'SCOPE 'EXTERNAL) (PUT 'BPSSIZE 'ASMSYMBOL 'NIL) (PUT 'BPSSIZE 'WCONST '40) (PUT 'GCBITLENGTH 'SCOPE 'EXTERNAL) (PUT 'GCBITLENGTH 'ASMSYMBOL 'NIL) (PUT 'GCBITLENGTH 'WCONST '13) (PUT 'MAXCHANNELS 'SCOPE 'EXTERNAL) (PUT 'MAXCHANNELS 'ASMSYMBOL 'NIL) (PUT 'MAXCHANNELS 'WCONST '31) (PUT 'ARG12 'SCOPE 'EXTERNAL) (PUT 'ARG12 'ASMSYMBOL 'ARG12) (PUT 'ARG12 'WVAR 'ARG12) (PUT 'TAGSTARTINGBIT 'SCOPE 'EXTERNAL) (PUT 'TAGSTARTINGBIT 'ASMSYMBOL 'NIL) (PUT 'TAGSTARTINGBIT 'WCONST '0) (PUT 'CHARACTERSPERWORD 'SCOPE 'EXTERNAL) (PUT 'CHARACTERSPERWORD 'ASMSYMBOL 'NIL) (PUT 'CHARACTERSPERWORD 'WCONST '5) (PUT 'STACKDIRECTION 'SCOPE 'EXTERNAL) (PUT 'STACKDIRECTION 'ASMSYMBOL 'NIL) (PUT 'STACKDIRECTION 'WCONST '1) (PUT 'ADDRESSINGUNITSPERITEM 'SCOPE 'EXTERNAL) (PUT 'ADDRESSINGUNITSPERITEM 'ASMSYMBOL 'NIL) (PUT 'ADDRESSINGUNITSPERITEM 'WCONST '1) (PUT 'HEAPSIZE 'SCOPE 'EXTERNAL) (PUT 'HEAPSIZE 'ASMSYMBOL 'NIL) (PUT 'HEAPSIZE 'WCONST '50000) (PUT 'STACKLOWERBOUND 'SCOPE 'EXTERNAL) (PUT 'STACKLOWERBOUND 'ASMSYMBOL '"L0001") (PUT 'STACKLOWERBOUND 'WVAR 'STACKLOWERBOUND) (PUT 'MAXARGS 'SCOPE 'EXTERNAL) (PUT 'MAXARGS 'ASMSYMBOL 'NIL) (PUT 'MAXARGS 'WCONST '15) (PUT 'ARG15 'SCOPE 'EXTERNAL) (PUT 'ARG15 'ASMSYMBOL 'ARG15) (PUT 'ARG15 'WVAR 'ARG15) (PUT 'SYMVAL 'SCOPE 'EXTERNAL) (PUT 'SYMVAL 'ASMSYMBOL 'SYMVAL) (PUT 'SYMVAL 'WARRAY 'SYMVAL) (PUT 'ARGUMENTBLOCK 'SCOPE 'EXTERNAL) (PUT 'ARGUMENTBLOCK 'ASMSYMBOL '"L0004") (PUT 'ARGUMENTBLOCK 'WARRAY 'ARGUMENTBLOCK) (PUT 'ARG11 'SCOPE 'EXTERNAL) (PUT 'ARG11 'ASMSYMBOL 'ARG11) (PUT 'ARG11 'WVAR 'ARG11) (PUT 'ARG8 'SCOPE 'EXTERNAL) (PUT 'ARG8 'ASMSYMBOL 'ARG8) (PUT 'ARG8 'WVAR 'ARG8) (PUT 'NEXTSYMBOL 'SCOPE 'EXTERNAL) (PUT 'NEXTSYMBOL 'ASMSYMBOL '"L0003") (PUT 'NEXTSYMBOL 'WVAR 'NEXTSYMBOL) (PUT 'ARG6 'SCOPE 'EXTERNAL) (PUT 'ARG6 'ASMSYMBOL 'ARG6) (PUT 'ARG6 'WVAR 'ARG6) (PUT 'INFSTARTINGBIT 'SCOPE 'EXTERNAL) (PUT 'INFSTARTINGBIT 'ASMSYMBOL 'NIL) (PUT 'INFSTARTINGBIT 'WCONST '18) (PUT 'ARG4 'SCOPE 'EXTERNAL) (PUT 'ARG4 'ASMSYMBOL 'ARG4) (PUT 'ARG4 'WVAR 'ARG4) (PUT 'STACKUPPERBOUND 'SCOPE 'EXTERNAL) (PUT 'STACKUPPERBOUND 'ASMSYMBOL '"L0002") (PUT 'STACKUPPERBOUND 'WVAR 'STACKUPPERBOUND) (PUT 'ARG2 'SCOPE 'EXTERNAL) (PUT 'ARG2 'ASMSYMBOL 'ARG2) (PUT 'ARG2 'WVAR 'ARG2) |
Added psl-1983/20-tests/main2.cmd version [e95583b75a].
> > | 1 2 | main2,Dmain2,sub2,Dsub2,20io |
Added psl-1983/20-tests/main2.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/20-tests/main2.sym version [4a21ad5804].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 171)) (SETQ STRINGGENSYM!* (QUOTE "L0182")) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) |
Added psl-1983/20-tests/main3.cmd version [1f300e0572].
> > | 1 2 | main3,Dmain3,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/main3.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/20-tests/main3.sym version [05bfbf64c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR WQUOTIENT !%RECLAIM GTHEAP GTSTR GTVECT GTWARRAY GTID HARDCONS CONS XCONS NCONS MKVECT LIST2 LIST3 LIST4 LIST5 PUTBYTE MKSTRING))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 189)) (SETQ STRINGGENSYM!* (QUOTE "L0214")) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0183")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0185")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0184")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0192")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0186")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0191")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) |
Added psl-1983/20-tests/main4.cmd version [0ea02d84c5].
> > | 1 2 | main4,Dmain4,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/main4.init version [b85f7234c7].
> > > > > > > | 1 2 3 4 5 6 7 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (PUT (QUOTE SYMFNCBASE) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) |
Added psl-1983/20-tests/main4.sym version [b30ca49e76].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR WQUOTIENT !%RECLAIM GTHEAP GTSTR GTVECT GTWARRAY GTID HARDCONS CONS XCONS NCONS MKVECT LIST2 LIST3 LIST4 LIST5 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP LOOKUPID INITNEWID MAKEFUNBOUND UPPERCASEP ALPHANUMP READ1 READ READLIST QUOTE))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 224)) (SETQ STRINGGENSYM!* (QUOTE "L0313")) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0237")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0230")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0183")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0185")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0184")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0299")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0301")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE LOOKUPID) (QUOTE ENTRYPOINT) (QUOTE "L0270")) (PUT (QUOTE LOOKUPID) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0192")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0287")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0263")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0186")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0191")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0297")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0291")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0222")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0224")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0241")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0295")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0310")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 198)) |
Added psl-1983/20-tests/main5.cmd version [e6f64a08f4].
> > | 1 2 | main5,Dmain5,sub5,Dsub5,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/main5.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/20-tests/main5.mac version [6283ec5129].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern HEAP extern L0183 extern L0184 extern L0185 extern L0186 extern BPS extern L1005 extern L1006 extern L1007 extern L1008 ; (!*ENTRY INITHEAP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR HEAPLOWERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPLOWERBOUND)) ; (MOVEM (REG T1) (WVAR HEAPLAST)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (MOVEM (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INITHEAP EXPR 0) L1009: intern L1009 MOVE 6,L0183 MOVEM 6,L0185 SETZM 1 MOVEM 1,L0186 POPJ 15,0 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 339) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L1010 MOVE 0,SYMVAL+128 HRRZI 12,339 SETZM 13 JRST SYMFNC+339 L1010: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+342 HRRZI 6,1 MOVEM 6,SYMVAL+154 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 343) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+342 JRST L1011 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L1011: MOVE 1,SYMVAL+342 HRRZI 12,343 HRRZI 13,1 JRST SYMFNC+343 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 152) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+154 CAIE 7,1 JRST L1012 PUSHJ 15,PUTC20 POPJ 15,0 L1012: MOVE 2,1 MOVE 1,SYMVAL+154 HRRZI 12,152 HRRZI 13,2 JRST SYMFNC+152 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY DATE EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "No-Date-Yet") (REG 1)) ; (MOVE (REG 1) (QUOTE "No-Date-Yet")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1014: 10 byte(7)78,111,45,68,97,116,101,45,89,101,116,0 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE MOVE 1,L1013 POPJ 15,0 L1013: <4_31>+L1014 ; (!*ENTRY VERSIONNAME EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "DEC-20 test system") (REG 1)) ; (MOVE (REG 1) (QUOTE "DEC-20 test system")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1016: 17 byte(7)68,69,67,45,50,48,32,116,101,115,116,32,115,121,115,116,101,109,0 0 ; (!*ENTRY VERSIONNAME EXPR 0) L1017: intern L1017 MOVE 1,L1015 POPJ 15,0 L1015: <4_31>+L1016 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*ALLOC 0) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L1018: intern L1018 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L1019: intern L1019 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L1020: intern L1020 MOVEM 12,SYMVAL+349 MOVEM 13,SYMVAL+350 JRST SYMFNC+249 ; (!*ENTRY FLAG EXPR 2) ; (!*ALLOC 0) ; (!*MOVE 2 (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINKE 0 ERR20 EXPR 1) extern ERR20 ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 POPJ 15,0 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L1021: intern L1021 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L1022: intern L1022 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 352) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L1023: intern L1023 HRRZI 12,352 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY !%RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE " *** Dummy !%RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE " *** Dummy !%RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 353) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1025: 21 byte(7)32,42,42,42,32,68,117,109,109,121,32,33,37,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY !%RECLAIM EXPR 0) L1026: intern L1026 MOVE 1,L1024 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,353 SETZM 13 JRST SYMFNC+353 L1024: <4_31>+L1025 ; (!*ENTRY RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "*** Dummy RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Dummy RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 353) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1028: 18 byte(7)42,42,42,32,68,117,109,109,121,32,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY RECLAIM EXPR 0) L1029: intern L1029 MOVE 1,L1027 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,353 SETZM 13 JRST SYMFNC+353 L1027: <4_31>+L1028 ; (!*ENTRY HEAPINFO EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPLAST) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPLAST)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLOWERBOUND)) ; (SUB (REG 1) (WVAR HEAPLOWERBOUND)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items used, ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items used, ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPUPPERBOUND) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPUPPERBOUND)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLAST)) ; (SUB (REG 1) (WVAR HEAPLAST)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items left.") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items left.")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1032: 11 byte(7)32,73,116,101,109,115,32,108,101,102,116,46,0 L1033: 12 byte(7)32,73,116,101,109,115,32,117,115,101,100,44,32,0 0 ; (!*ENTRY HEAPINFO EXPR 0) L1034: intern L1034 HRRZI 2,1 MOVE 1,L0185 SUB 1,L0183 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1030 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 2,1 MOVE 1,L0184 SUB 1,L0185 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1031 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 SETZM 1 POPJ 15,0 L1031: <4_31>+L1032 L1030: <4_31>+L1033 ; (!*ENTRY SPACED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1036: 10 byte(7)32,32,32,32,32,32,32,32,32,32,32,0 1 ; (!*ENTRY SPACED EXPR 1) SPACED: intern SPACED PUSH 15,1 MOVE 1,L1035 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1035: <4_31>+L1036 ; (!*ENTRY DASHED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE "---------- ") (REG 1)) ; (MOVE (REG 1) (QUOTE "---------- ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1038: 10 byte(7)45,45,45,45,45,45,45,45,45,45,32,0 1 ; (!*ENTRY DASHED EXPR 1) DASHED: intern DASHED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1037 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1037: <4_31>+L1038 ; (!*ENTRY DOTTED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " ....... ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1040: 10 byte(7)32,32,32,46,46,46,46,46,46,46,32,0 1 ; (!*ENTRY DOTTED EXPR 1) DOTTED: intern DOTTED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1039 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1039: <4_31>+L1040 ; (!*ENTRY SHOULDBE EXPR 3) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE " ....... For ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... For ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " should be ") (REG 1)) ; (MOVE (REG 1) (QUOTE " should be ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAME (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE " [OK ]") (REG 1)) ; (MOVE (REG 1) (QUOTE " [OK ]")) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE " [BAD] *******") (REG 1)) ; (MOVE (REG 1) (QUOTE " [BAD] *******")) ; (!*LBL (LABEL G0006)) ; (!*LINKE 3 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1046: 15 byte(7)32,32,32,91,66,65,68,93,32,42,42,42,42,42,42,42,0 L1047: 6 byte(7)32,32,91,79,75,32,93,0 L1048: 10 byte(7)32,115,104,111,117,108,100,32,98,101,32,0 L1049: 0 byte(7)32,0 L1050: 14 byte(7)32,32,32,46,46,46,46,46,46,46,32,70,111,114,32,0 3 ; (!*ENTRY SHOULDBE EXPR 3) L1051: intern L1051 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,L1041 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1042 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1043 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 6,-1(15) CAME 6,-2(15) JRST L1052 MOVE 1,L1044 JRST L1053 L1052: MOVE 1,L1045 L1053: ADJSP 15,-3 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1045: <4_31>+L1046 L1044: <4_31>+L1047 L1043: <4_31>+L1048 L1042: <4_31>+L1049 L1041: <4_31>+L1050 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (!$FLUID UNDEFNNARG!*) (FRAME 2)) ; (MOVE (REG T1) (!$FLUID UNDEFNNARG!*)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*MOVE (!$FLUID UNDEFNCODE!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID UNDEFNCODE!*)) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE "Undefined Function ") (REG 1)) ; (MOVE (REG 1) (QUOTE "Undefined Function ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " called with ") (REG 1)) ; (MOVE (REG 1) (QUOTE " called with ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " args from compiled code") (REG 1)) ; (MOVE (REG 1) (QUOTE " args from compiled code")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L1057: 23 byte(7)32,97,114,103,115,32,102,114,111,109,32,99,111,109,112,105,108,101,100,32,99,111,100,101,0 L1058: 12 byte(7)32,99,97,108,108,101,100,32,119,105,116,104,32,0 L1059: 18 byte(7)85,110,100,101,102,105,110,101,100,32,70,117,110,99,116,105,111,110,32,0 0 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) L1060: intern L1060 ADJSP 15,2 MOVE 6,SYMVAL+350 MOVEM 6,-1(15) MOVE 1,SYMVAL+349 TLZ 1,253952 TLO 1,245760 MOVEM 1,0(15) MOVE 1,L1054 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1055 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1056 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L1056: <4_31>+L1057 L1055: <4_31>+L1058 L1054: <4_31>+L1059 ; (!*ENTRY INF EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY INF EXPR 1) INF: intern INF HRRZ 1,1 POPJ 15,0 ; (!*ENTRY TAG EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 0) (WCONST 5)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY TAG EXPR 1) TAG: intern TAG LDB 1,L1061 POPJ 15,0 L1061: point 5,1,4 ; (!*ENTRY MKITEM EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MKITEM (REG 1) (REG 3)) ; (DPB (REG 3) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 2 ; (!*ENTRY MKITEM EXPR 2) MKITEM: intern MKITEM MOVE 3,1 MOVE 1,2 DPB 3,L1062 POPJ 15,0 L1062: point 5,1,4 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (QUOTE NIL) (FRAME 1)) ; (MOVEM (REG NIL) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 341) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*LINK INITHEAP EXPR 0) ; (HRRZI (REG LINKREG) 338) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITHEAP)) ; (!*LINK TESTGET EXPR 0) ; (HRRZI (REG LINKREG) 362) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TESTGET)) ; (!*LINK INITEVAL EXPR 0) ; (HRRZI (REG LINKREG) 309) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITEVAL)) ; (!*MOVE (QUOTE "(very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q") (REG 1)) ; (MOVE (REG 1) (QUOTE "(very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " !*RAISE and !*PVAL have been set T") (REG 1)) ; (MOVE (REG 1) (QUOTE " !*RAISE and !*PVAL have been set T")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " Should be able to execute any COMPILED expressions") (REG 1)) ; (MOVE (REG 1) (QUOTE " Should be able to execute any COMPILED expressions")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " typed in. Run (TESTSERIES) when ready") (REG 1)) ; (MOVE (REG 1) (QUOTE " typed in. Run (TESTSERIES) when ready")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (!$FLUID DEBUG)) ; (MOVEM (REG 1) (!$FLUID DEBUG)) ; (!*LINK INITREAD EXPR 0) ; (HRRZI (REG LINKREG) 190) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITREAD)) ; (!*MOVE (WCONST 26) (REG 1)) ; (HRRZI (REG 1) 26) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (!$FLUID !$EOF!$)) ; (MOVEM (REG 1) (!$FLUID !$EOF!$)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*MOVE (REG 1) (!$FLUID !*RAISE)) ; (MOVEM (REG 1) (!$FLUID !*RAISE)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (QUOTE NIL)) ; (CAME (REG NIL) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0004)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " lisp> ") (REG 1)) ; (MOVE (REG 1) (QUOTE " lisp> ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTEQ (LABEL G0011) (REG 1) (QUOTE Q)) ; (CAME (REG 1) (QUOTE Q)) ; (JRST (LABEL G0011)) ; (!*MOVE (QUOTE T) (FRAME 2)) ; (MOVE (REG T1) (FLUID T)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0011)) ; (!*JUMPNOTEQ (LABEL G0012) (REG 1) (!$GLOBAL !$EOF!$)) ; (CAME (REG 1) (!$GLOBAL !$EOF!$)) ; (JRST (LABEL G0012)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " **** Top Level EOF ****") (REG 1)) ; (MOVE (REG 1) (QUOTE " **** Top Level EOF ****")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0012)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPEQ (LABEL G0005) (QUOTE NIL) (!$FLUID !*PVAL)) ; (CAMN (REG NIL) (!$FLUID !*PVAL)) ; (JRST (LABEL G0005)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) L1070: 23 byte(7)32,42,42,42,42,32,84,111,112,32,76,101,118,101,108,32,69,79,70,32,42,42,42,42,0 L1071: 6 byte(7)32,108,105,115,112,62,32,0 L1072: 43 byte(7)32,32,32,32,32,32,32,116,121,112,101,100,32,105,110,46,32,82,117,110,32,40,84,69,83,84,83,69,82,73,69,83,41,32,119,104,101,110,32,114,101,97,100,121,0 L1073: 56 byte(7)32,32,32,32,32,32,32,83,104,111,117,108,100,32,98,101,32,97,98,108,101,32,116,111,32,101,120,101,99,117,116,101,32,97,110,121,32,67,79,77,80,73,76,69,68,32,101,120,112,114,101,115,115,105,111,110,115,0 L1074: 40 byte(7)32,32,32,32,32,32,32,33,42,82,65,73,83,69,32,97,110,100,32,33,42,80,86,65,76,32,104,97,118,101,32,98,101,101,110,32,115,101,116,32,84,0 L1075: 56 byte(7)40,118,101,114,121,41,32,77,73,78,73,45,80,83,76,58,32,65,32,82,101,97,100,45,69,118,97,108,45,80,114,105,110,116,32,76,111,111,112,44,32,116,101,114,109,105,110,97,116,101,32,119,105,116,104,32,81,0 0 ; (!*ENTRY FIRSTCALL EXPR 0) L1076: intern L1076 ADJSP 15,3 MOVEM 0,0(15) MOVEM 0,-1(15) HRRZI 12,341 SETZM 13 PUSHJ 15,SYMFNC+341 HRRZI 12,338 SETZM 13 PUSHJ 15,SYMFNC+338 HRRZI 12,362 SETZM 13 PUSHJ 15,SYMFNC+362 HRRZI 12,309 SETZM 13 PUSHJ 15,SYMFNC+309 MOVE 1,L1063 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1064 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1065 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1066 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,0 MOVEM 1,SYMVAL+195 HRRZI 12,190 SETZM 13 PUSHJ 15,SYMFNC+190 HRRZI 1,26 TLZ 1,253952 TLO 1,245760 MOVEM 1,SYMVAL+363 SETZM -2(15) MOVE 1,SYMVAL+84 MOVEM 1,SYMVAL+191 L1077: CAME 0,-1(15) JRST L1078 AOS -2(15) MOVE 1,-2(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1067 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,0(15) CAME 1,L1068 JRST L1079 MOVE 6,SYMVAL+84 MOVEM 6,-1(15) JRST L1077 L1079: CAME 1,SYMVAL+363 JRST L1080 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1069 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 JRST L1077 L1080: HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0(15) HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 MOVEM 1,0(15) CAMN 0,SYMVAL+364 JRST L1077 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 JRST L1077 L1078: HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1069: <4_31>+L1070 L1068: <30_31>+81 L1067: <4_31>+L1071 L1066: <4_31>+L1072 L1065: <4_31>+L1073 L1064: <4_31>+L1074 L1063: <4_31>+L1075 ; (!*ENTRY TESTSERIES EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "TESTs called by TESTSERIES") (REG 1)) ; (MOVE (REG 1) (QUOTE "TESTs called by TESTSERIES")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 356) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*LINKE 0 TESTUNDEFINED EXPR 0) ; (HRRZI (REG LINKREG) 365) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY TESTUNDEFINED)) L1082: 25 byte(7)84,69,83,84,115,32,99,97,108,108,101,100,32,98,121,32,84,69,83,84,83,69,82,73,69,83,0 0 ; (!*ENTRY TESTSERIES EXPR 0) L1083: intern L1083 MOVE 1,L1081 HRRZI 12,356 HRRZI 13,1 PUSHJ 15,SYMFNC+356 HRRZI 12,365 SETZM 13 JRST SYMFNC+365 L1081: <4_31>+L1082 ; (!*ENTRY TESTGET EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Tests of GET and PUT") (REG 1)) ; (MOVE (REG 1) (QUOTE "Tests of GET and PUT")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 356) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (QUOTE FEE) (REG 2)) ; (MOVE (REG 2) (QUOTE FEE)) ; (!*MOVE (QUOTE FOO) (REG 1)) ; (MOVE (REG 1) (QUOTE FOO)) ; (!*LINK GET EXPR 2) ; (HRRZI (REG LINKREG) 258) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GET)) ; (!*MOVE (QUOTE NIL) (REG 3)) ; (MOVE (REG 3) (REG NIL)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "GET('FOO,'FEE)") (REG 1)) ; (MOVE (REG 1) (QUOTE "GET('FOO,'FEE)")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 358) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE FUM) (REG 3)) ; (MOVE (REG 3) (QUOTE FUM)) ; (!*MOVE (QUOTE FEE) (REG 2)) ; (MOVE (REG 2) (QUOTE FEE)) ; (!*MOVE (QUOTE FOO) (REG 1)) ; (MOVE (REG 1) (QUOTE FOO)) ; (!*LINK PUT EXPR 3) ; (HRRZI (REG LINKREG) 308) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY PUT)) ; (!*MOVE (QUOTE FUM) (REG 3)) ; (MOVE (REG 3) (QUOTE FUM)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "PUT('FOO,'FEE,'FUM)") (REG 1)) ; (MOVE (REG 1) (QUOTE "PUT('FOO,'FEE,'FUM)")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 358) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE FEE) (REG 2)) ; (MOVE (REG 2) (QUOTE FEE)) ; (!*MOVE (QUOTE FOO) (REG 1)) ; (MOVE (REG 1) (QUOTE FOO)) ; (!*LINK GET EXPR 2) ; (HRRZI (REG LINKREG) 258) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GET)) ; (!*MOVE (QUOTE FUM) (REG 3)) ; (MOVE (REG 3) (QUOTE FUM)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "GET('FOO,'FEE)") (REG 1)) ; (MOVE (REG 1) (QUOTE "GET('FOO,'FEE)")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 358) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE FEE) (REG 2)) ; (MOVE (REG 2) (QUOTE FEE)) ; (!*MOVE (QUOTE FOO) (REG 1)) ; (MOVE (REG 1) (QUOTE FOO)) ; (!*LINK REMPROP EXPR 2) ; (HRRZI (REG LINKREG) 334) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY REMPROP)) ; (!*MOVE (QUOTE FUM) (REG 3)) ; (MOVE (REG 3) (QUOTE FUM)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "REMPROP('FOO,'FEE)") (REG 1)) ; (MOVE (REG 1) (QUOTE "REMPROP('FOO,'FEE)")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 358) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE FEE) (REG 2)) ; (MOVE (REG 2) (QUOTE FEE)) ; (!*MOVE (QUOTE FOO) (REG 1)) ; (MOVE (REG 1) (QUOTE FOO)) ; (!*LINK GET EXPR 2) ; (HRRZI (REG LINKREG) 258) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GET)) ; (!*MOVE (QUOTE NIL) (REG 3)) ; (MOVE (REG 3) (REG NIL)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "GET('FOO,'FEE)") (REG 1)) ; (MOVE (REG 1) (QUOTE "GET('FOO,'FEE)")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 358) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1091: 17 byte(7)82,69,77,80,82,79,80,40,39,70,79,79,44,39,70,69,69,41,0 L1092: 18 byte(7)80,85,84,40,39,70,79,79,44,39,70,69,69,44,39,70,85,77,41,0 L1093: 13 byte(7)71,69,84,40,39,70,79,79,44,39,70,69,69,41,0 L1094: 19 byte(7)84,101,115,116,115,32,111,102,32,71,69,84,32,97,110,100,32,80,85,84,0 0 ; (!*ENTRY TESTGET EXPR 0) L1095: intern L1095 MOVE 1,L1084 HRRZI 12,356 HRRZI 13,1 PUSHJ 15,SYMFNC+356 MOVE 2,L1085 MOVE 1,L1086 HRRZI 12,258 HRRZI 13,2 PUSHJ 15,SYMFNC+258 MOVE 3,0 MOVE 2,1 MOVE 1,L1087 HRRZI 12,358 HRRZI 13,3 PUSHJ 15,SYMFNC+358 MOVE 3,L1088 MOVE 2,L1085 MOVE 1,L1086 HRRZI 12,308 HRRZI 13,3 PUSHJ 15,SYMFNC+308 MOVE 3,L1088 MOVE 2,1 MOVE 1,L1089 HRRZI 12,358 HRRZI 13,3 PUSHJ 15,SYMFNC+358 MOVE 2,L1085 MOVE 1,L1086 HRRZI 12,258 HRRZI 13,2 PUSHJ 15,SYMFNC+258 MOVE 3,L1088 MOVE 2,1 MOVE 1,L1087 HRRZI 12,358 HRRZI 13,3 PUSHJ 15,SYMFNC+358 MOVE 2,L1085 MOVE 1,L1086 HRRZI 12,334 HRRZI 13,2 PUSHJ 15,SYMFNC+334 MOVE 3,L1088 MOVE 2,1 MOVE 1,L1090 HRRZI 12,358 HRRZI 13,3 PUSHJ 15,SYMFNC+358 MOVE 2,L1085 MOVE 1,L1086 HRRZI 12,258 HRRZI 13,2 PUSHJ 15,SYMFNC+258 MOVE 3,0 MOVE 2,1 MOVE 1,L1087 HRRZI 12,358 HRRZI 13,3 PUSHJ 15,SYMFNC+358 MOVE 1,0 POPJ 15,0 L1090: <4_31>+L1091 L1089: <4_31>+L1092 L1088: <30_31>+367 L1087: <4_31>+L1093 L1086: <30_31>+368 L1085: <30_31>+369 L1084: <4_31>+L1094 ; (!*ENTRY TESTUNDEFINED EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Calling SHOULDBEUNDEFINED") (REG 1)) ; (MOVE (REG 1) (QUOTE "Calling SHOULDBEUNDEFINED")) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINKE 0 SHOULDBEUNDEFINED EXPR 1) ; (HRRZI (REG LINKREG) 230) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY SHOULDBEUNDEFINED)) L1097: 24 byte(7)67,97,108,108,105,110,103,32,83,72,79,85,76,68,66,69,85,78,68,69,70,73,78,69,68,0 0 ; (!*ENTRY TESTUNDEFINED EXPR 0) L1098: intern L1098 MOVE 1,L1096 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 HRRZI 1,1 HRRZI 12,230 HRRZI 13,1 JRST SYMFNC+230 L1096: <4_31>+L1097 ; (!*ENTRY UNBINDN EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "UNBIND only added at MAIN6") (REG 1)) ; (MOVE (REG 1) (QUOTE "UNBIND only added at MAIN6")) ; (!*LINKE 0 STDERROR EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY STDERROR)) L1100: 25 byte(7)85,78,66,73,78,68,32,111,110,108,121,32,97,100,100,101,100,32,97,116,32,77,65,73,78,54,0 1 ; (!*ENTRY UNBINDN EXPR 1) L1101: intern L1101 MOVE 1,L1099 HRRZI 12,158 HRRZI 13,1 JRST SYMFNC+158 L1099: <4_31>+L1100 ; (!*ENTRY LBIND1 EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "LBIND1 only added at MAIN6") (REG 1)) ; (MOVE (REG 1) (QUOTE "LBIND1 only added at MAIN6")) ; (!*LINKE 0 STDERROR EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY STDERROR)) L1103: 25 byte(7)76,66,73,78,68,49,32,111,110,108,121,32,97,100,100,101,100,32,97,116,32,77,65,73,78,54,0 2 ; (!*ENTRY LBIND1 EXPR 2) LBIND1: intern LBIND1 MOVE 1,L1102 HRRZI 12,158 HRRZI 13,1 JRST SYMFNC+158 L1102: <4_31>+L1103 0 ; (!*ENTRY INITCODE EXPR 0) L1104: intern L1104 MOVE 1,0 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L1105: 0 byte(7)0,0 intern L1105 L1106: 0 byte(7)1,0 intern L1106 L1107: 0 byte(7)2,0 intern L1107 L1108: 0 byte(7)3,0 intern L1108 L1109: 0 byte(7)4,0 intern L1109 L1110: 0 byte(7)5,0 intern L1110 L1111: 0 byte(7)6,0 intern L1111 L1112: 0 byte(7)7,0 intern L1112 L1113: 0 byte(7)8,0 intern L1113 L1114: 0 byte(7)9,0 intern L1114 L1115: 0 byte(7)10,0 intern L1115 L1116: 0 byte(7)11,0 intern L1116 L1117: 0 byte(7)12,0 intern L1117 L1118: 0 byte(7)13,0 intern L1118 L1119: 0 byte(7)14,0 intern L1119 L1120: 0 byte(7)15,0 intern L1120 L1121: 0 byte(7)16,0 intern L1121 L1122: 0 byte(7)17,0 intern L1122 L1123: 0 byte(7)18,0 intern L1123 L1124: 0 byte(7)19,0 intern L1124 L1125: 0 byte(7)20,0 intern L1125 L1126: 0 byte(7)21,0 intern L1126 L1127: 0 byte(7)22,0 intern L1127 L1128: 0 byte(7)23,0 intern L1128 L1129: 0 byte(7)24,0 intern L1129 L1130: 0 byte(7)25,0 intern L1130 L1131: 0 byte(7)26,0 intern L1131 L1132: 0 byte(7)27,0 intern L1132 L1133: 0 byte(7)28,0 intern L1133 L1134: 0 byte(7)29,0 intern L1134 L1135: 0 byte(7)30,0 intern L1135 L1136: 0 byte(7)31,0 intern L1136 L1137: 0 byte(7)32,0 intern L1137 L1138: 0 byte(7)33,0 intern L1138 L1139: 0 byte(7)34,0 intern L1139 L1140: 0 byte(7)35,0 intern L1140 L1141: 0 byte(7)36,0 intern L1141 L1142: 0 byte(7)37,0 intern L1142 L1143: 0 byte(7)38,0 intern L1143 L1144: 0 byte(7)39,0 intern L1144 L1145: 0 byte(7)40,0 intern L1145 L1146: 0 byte(7)41,0 intern L1146 L1147: 0 byte(7)42,0 intern L1147 L1148: 0 byte(7)43,0 intern L1148 L1149: 0 byte(7)44,0 intern L1149 L1150: 0 byte(7)45,0 intern L1150 L1151: 0 byte(7)46,0 intern L1151 L1152: 0 byte(7)47,0 intern L1152 L1153: 0 byte(7)48,0 intern L1153 L1154: 0 byte(7)49,0 intern L1154 L1155: 0 byte(7)50,0 intern L1155 L1156: 0 byte(7)51,0 intern L1156 L1157: 0 byte(7)52,0 intern L1157 L1158: 0 byte(7)53,0 intern L1158 L1159: 0 byte(7)54,0 intern L1159 L1160: 0 byte(7)55,0 intern L1160 L1161: 0 byte(7)56,0 intern L1161 L1162: 0 byte(7)57,0 intern L1162 L1163: 0 byte(7)58,0 intern L1163 L1164: 0 byte(7)59,0 intern L1164 L1165: 0 byte(7)60,0 intern L1165 L1166: 0 byte(7)61,0 intern L1166 L1167: 0 byte(7)62,0 intern L1167 L1168: 0 byte(7)63,0 intern L1168 L1169: 0 byte(7)64,0 intern L1169 L1170: 0 byte(7)65,0 intern L1170 L1171: 0 byte(7)66,0 intern L1171 L1172: 0 byte(7)67,0 intern L1172 L1173: 0 byte(7)68,0 intern L1173 L1174: 0 byte(7)69,0 intern L1174 L1175: 0 byte(7)70,0 intern L1175 L1176: 0 byte(7)71,0 intern L1176 L1177: 0 byte(7)72,0 intern L1177 L1178: 0 byte(7)73,0 intern L1178 L1179: 0 byte(7)74,0 intern L1179 L1180: 0 byte(7)75,0 intern L1180 L1181: 0 byte(7)76,0 intern L1181 L1182: 0 byte(7)77,0 intern L1182 L1183: 0 byte(7)78,0 intern L1183 L1184: 0 byte(7)79,0 intern L1184 L1185: 0 byte(7)80,0 intern L1185 L1186: 0 byte(7)81,0 intern L1186 L1187: 0 byte(7)82,0 intern L1187 L1188: 0 byte(7)83,0 intern L1188 L1189: 0 byte(7)84,0 intern L1189 L1190: 0 byte(7)85,0 intern L1190 L1191: 0 byte(7)86,0 intern L1191 L1192: 0 byte(7)87,0 intern L1192 L1193: 0 byte(7)88,0 intern L1193 L1194: 0 byte(7)89,0 intern L1194 L1195: 0 byte(7)90,0 intern L1195 L1196: 0 byte(7)91,0 intern L1196 L1197: 0 byte(7)92,0 intern L1197 L1198: 0 byte(7)93,0 intern L1198 L1199: 0 byte(7)94,0 intern L1199 L1200: 0 byte(7)95,0 intern L1200 L1201: 0 byte(7)96,0 intern L1201 L1202: 0 byte(7)97,0 intern L1202 L1203: 0 byte(7)98,0 intern L1203 L1204: 0 byte(7)99,0 intern L1204 L1205: 0 byte(7)100,0 intern L1205 L1206: 0 byte(7)101,0 intern L1206 L1207: 0 byte(7)102,0 intern L1207 L1208: 0 byte(7)103,0 intern L1208 L1209: 0 byte(7)104,0 intern L1209 L1210: 0 byte(7)105,0 intern L1210 L1211: 0 byte(7)106,0 intern L1211 L1212: 0 byte(7)107,0 intern L1212 L1213: 0 byte(7)108,0 intern L1213 L1214: 0 byte(7)109,0 intern L1214 L1215: 0 byte(7)110,0 intern L1215 L1216: 0 byte(7)111,0 intern L1216 L1217: 0 byte(7)112,0 intern L1217 L1218: 0 byte(7)113,0 intern L1218 L1219: 0 byte(7)114,0 intern L1219 L1220: 0 byte(7)115,0 intern L1220 L1221: 0 byte(7)116,0 intern L1221 L1222: 0 byte(7)117,0 intern L1222 L1223: 0 byte(7)118,0 intern L1223 L1224: 0 byte(7)119,0 intern L1224 L1225: 0 byte(7)120,0 intern L1225 L1226: 0 byte(7)121,0 intern L1226 L1227: 0 byte(7)122,0 intern L1227 L1228: 0 byte(7)123,0 intern L1228 L1229: 0 byte(7)124,0 intern L1229 L1230: 0 byte(7)125,0 intern L1230 L1231: 0 byte(7)126,0 intern L1231 L1232: 0 byte(7)127,0 intern L1232 L1233: 2 byte(7)78,73,76,0 intern L1233 L1234: 6 byte(7)80,82,73,78,49,73,68,0 intern L1234 L1235: 7 byte(7)80,82,73,78,49,73,78,84,0 intern L1235 L1236: 10 byte(7)80,82,73,78,49,83,84,82,73,78,71,0 intern L1236 L1237: 8 byte(7)80,82,73,78,49,80,65,73,82,0 intern L1237 L1238: 5 byte(7)80,82,84,73,84,77,0 intern L1238 L1239: 4 byte(7)80,82,73,78,49,0 intern L1239 L1240: 6 byte(7)80,82,73,78,50,73,68,0 intern L1240 L1241: 10 byte(7)80,82,73,78,50,83,84,82,73,78,71,0 intern L1241 L1242: 8 byte(7)80,82,73,78,50,80,65,73,82,0 intern L1242 L1243: 4 byte(7)80,82,73,78,50,0 intern L1243 L1244: 5 byte(7)84,69,82,80,82,73,0 intern L1244 L1245: 4 byte(7)80,82,73,78,84,0 intern L1245 L1246: 5 byte(7)80,82,73,78,50,84,0 intern L1246 L1247: 3 byte(7)80,85,84,67,0 intern L1247 L1248: 5 byte(7)80,66,76,65,78,75,0 intern L1248 L1249: 8 byte(7)80,82,73,78,49,73,78,84,88,0 intern L1249 L1250: 6 byte(7)76,79,78,71,68,73,86,0 intern L1250 L1251: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L1251 L1252: 3 byte(7)66,89,84,69,0 intern L1252 L1253: 3 byte(7)81,85,73,84,0 intern L1253 L1254: 4 byte(7)69,82,82,79,82,0 intern L1254 L1255: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L1255 L1256: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L1256 L1257: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L1257 L1258: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L1258 L1259: 3 byte(7)79,85,84,42,0 intern L1259 L1260: 10 byte(7)69,82,82,79,82,72,69,65,68,69,82,0 intern L1260 L1261: 11 byte(7)69,82,82,79,82,84,82,65,73,76,69,82,0 intern L1261 L1262: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L1262 L1263: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L1263 L1264: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L1264 L1265: 5 byte(7)80,82,73,78,49,84,0 intern L1265 L1266: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L1266 L1267: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L1267 L1268: 1 byte(7)70,78,0 intern L1268 L1269: 7 byte(7)79,70,70,69,78,68,69,82,0 intern L1269 L1270: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L1270 L1271: 11 byte(7)76,65,77,66,73,78,68,65,82,71,83,42,0 intern L1271 L1272: 6 byte(7)76,65,77,66,73,78,68,0 intern L1272 L1273: 6 byte(7)85,78,66,73,78,68,78,0 intern L1273 L1274: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1274 L1275: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1275 L1276: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L1276 L1277: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L1277 L1278: 5 byte(7)71,84,72,69,65,80,0 intern L1278 L1279: 4 byte(7)71,84,83,84,82,0 intern L1279 L1280: 5 byte(7)71,84,86,69,67,84,0 intern L1280 L1281: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L1281 L1282: 3 byte(7)71,84,73,68,0 intern L1282 L1283: 7 byte(7)72,65,82,68,67,79,78,83,0 intern L1283 L1284: 3 byte(7)67,79,78,83,0 intern L1284 L1285: 4 byte(7)88,67,79,78,83,0 intern L1285 L1286: 4 byte(7)78,67,79,78,83,0 intern L1286 L1287: 5 byte(7)77,75,86,69,67,84,0 intern L1287 L1288: 4 byte(7)76,73,83,84,50,0 intern L1288 L1289: 4 byte(7)76,73,83,84,51,0 intern L1289 L1290: 4 byte(7)76,73,83,84,52,0 intern L1290 L1291: 4 byte(7)76,73,83,84,53,0 intern L1291 L1292: 6 byte(7)80,85,84,66,89,84,69,0 intern L1292 L1293: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L1293 L1294: 4 byte(7)69,81,83,84,82,0 intern L1294 L1295: 7 byte(7)73,78,73,84,82,69,65,68,0 intern L1295 L1296: 5 byte(7)42,82,65,73,83,69,0 intern L1296 L1297: 2 byte(7)67,72,42,0 intern L1297 L1298: 3 byte(7)84,79,75,42,0 intern L1298 L1299: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L1299 L1300: 4 byte(7)68,69,66,85,71,0 intern L1300 L1301: 7 byte(7)83,69,84,82,65,73,83,69,0 intern L1301 L1302: 9 byte(7)67,76,69,65,82,87,72,73,84,69,0 intern L1302 L1303: 11 byte(7)67,76,69,65,82,67,79,77,77,69,78,84,0 intern L1303 L1304: 6 byte(7)82,69,65,68,83,84,82,0 intern L1304 L1305: 5 byte(7)68,73,71,73,84,80,0 intern L1305 L1306: 6 byte(7)82,69,65,68,73,78,84,0 intern L1306 L1307: 8 byte(7)65,76,80,72,65,69,83,67,80,0 intern L1307 L1308: 5 byte(7)82,69,65,68,73,68,0 intern L1308 L1309: 4 byte(7)82,65,84,79,77,0 intern L1309 L1310: 5 byte(7)87,72,73,84,69,80,0 intern L1310 L1311: 3 byte(7)71,69,84,67,0 intern L1311 L1312: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L1312 L1313: 13 byte(7)66,85,70,70,69,82,84,79,83,84,82,73,78,71,0 intern L1313 L1314: 8 byte(7)82,65,73,83,69,67,72,65,82,0 intern L1314 L1315: 11 byte(7)65,76,80,72,65,78,85,77,69,83,67,80,0 intern L1315 L1316: 5 byte(7)73,78,84,69,82,78,0 intern L1316 L1317: 6 byte(7)69,83,67,65,80,69,80,0 intern L1317 L1318: 5 byte(7)65,76,80,72,65,80,0 intern L1318 L1319: 9 byte(7)76,79,87,69,82,67,65,83,69,80,0 intern L1319 L1320: 7 byte(7)76,79,79,75,85,80,73,68,0 intern L1320 L1321: 8 byte(7)73,78,73,84,78,69,87,73,68,0 intern L1321 L1322: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L1322 L1323: 9 byte(7)85,80,80,69,82,67,65,83,69,80,0 intern L1323 L1324: 8 byte(7)65,76,80,72,65,78,85,77,80,0 intern L1324 L1325: 4 byte(7)82,69,65,68,49,0 intern L1325 L1326: 3 byte(7)82,69,65,68,0 intern L1326 L1327: 7 byte(7)82,69,65,68,76,73,83,84,0 intern L1327 L1328: 4 byte(7)81,85,79,84,69,0 intern L1328 L1329: 6 byte(7)83,65,70,69,67,68,82,0 intern L1329 L1330: 9 byte(7)83,89,77,70,78,67,66,65,83,69,0 intern L1330 L1331: 5 byte(7)87,80,76,85,83,50,0 intern L1331 L1332: 5 byte(7)83,89,77,70,78,67,0 intern L1332 L1333: 6 byte(7)87,84,73,77,69,83,50,0 intern L1333 L1334: 29 byte(7)65,68,68,82,69,83,83,73,78,71,85,78,73,84,83,80,69,82,70,85,78,67,84,73,79,78,67,69,76,76,0 intern L1334 L1335: 16 byte(7)83,72,79,85,76,68,66,69,85,78,68,69,70,73,78,69,68,0 intern L1335 L1336: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L1336 L1337: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L1337 L1338: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L1338 L1339: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L1339 L1340: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L1340 L1341: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L1341 L1342: 5 byte(7)70,67,79,68,69,80,0 intern L1342 L1343: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L1343 L1344: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L1344 L1345: 12 byte(7)67,79,68,69,80,82,73,77,73,84,73,86,69,0 intern L1345 L1346: 7 byte(7)67,79,68,69,80,84,82,42,0 intern L1346 L1347: 12 byte(7)83,65,86,69,82,69,71,73,83,84,69,82,83,0 intern L1347 L1348: 8 byte(7)67,79,68,69,70,79,82,77,42,0 intern L1348 L1349: 8 byte(7)67,79,68,69,78,65,82,71,42,0 intern L1349 L1350: 28 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,0 intern L1350 L1351: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L1351 L1352: 14 byte(7)70,65,83,84,76,65,77,66,68,65,65,80,80,76,89,0 intern L1352 L1353: 5 byte(7)76,65,77,66,68,65,0 intern L1353 L1354: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L1354 L1355: 22 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,65,85,88,0 intern L1355 L1356: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L1356 L1357: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L1357 L1358: 15 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,65,85,88,0 intern L1358 L1359: 3 byte(7)69,86,65,76,0 intern L1359 L1360: 10 byte(7)66,73,78,68,69,86,65,76,65,85,88,0 intern L1360 L1361: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L1361 L1362: 5 byte(7)76,66,73,78,68,49,0 intern L1362 L1363: 2 byte(7)71,69,84,0 intern L1363 L1364: 31 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,65,85,88,0 intern L1364 L1365: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L1365 L1366: 5 byte(7)66,76,68,77,83,71,0 intern L1366 L1367: 6 byte(7)69,86,80,82,79,71,78,0 intern L1367 L1368: 6 byte(7)83,89,83,50,73,78,84,0 intern L1368 L1369: 4 byte(7)80,76,85,83,50,0 intern L1369 L1370: 4 byte(7)77,73,78,85,83,0 intern L1370 L1371: 4 byte(7)87,65,68,68,49,0 intern L1371 L1372: 3 byte(7)69,76,83,69,0 intern L1372 L1373: 3 byte(7)65,68,68,49,0 intern L1373 L1374: 4 byte(7)87,83,85,66,49,0 intern L1374 L1375: 3 byte(7)83,85,66,49,0 intern L1375 L1376: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L1376 L1377: 4 byte(7)76,69,83,83,80,0 intern L1377 L1378: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L1378 L1379: 5 byte(7)84,73,77,69,83,50,0 intern L1379 L1380: 2 byte(7)67,65,82,0 intern L1380 L1381: 2 byte(7)67,68,82,0 intern L1381 L1382: 3 byte(7)67,65,65,82,0 intern L1382 L1383: 3 byte(7)67,65,68,82,0 intern L1383 L1384: 3 byte(7)67,68,65,82,0 intern L1384 L1385: 3 byte(7)67,68,68,82,0 intern L1385 L1386: 3 byte(7)65,84,79,77,0 intern L1386 L1387: 5 byte(7)65,80,80,69,78,68,0 intern L1387 L1388: 3 byte(7)77,69,77,81,0 intern L1388 L1389: 6 byte(7)82,69,86,69,82,83,69,0 intern L1389 L1390: 4 byte(7)69,86,76,73,83,0 intern L1390 L1391: 4 byte(7)80,82,79,71,78,0 intern L1391 L1392: 5 byte(7)69,86,67,79,78,68,0 intern L1392 L1393: 3 byte(7)67,79,78,68,0 intern L1393 L1394: 2 byte(7)83,69,84,0 intern L1394 L1395: 3 byte(7)83,69,84,81,0 intern L1395 L1396: 3 byte(7)80,85,84,68,0 intern L1396 L1397: 1 byte(7)68,69,0 intern L1397 L1398: 3 byte(7)69,88,80,82,0 intern L1398 L1399: 1 byte(7)68,70,0 intern L1399 L1400: 4 byte(7)70,69,88,80,82,0 intern L1400 L1401: 1 byte(7)68,78,0 intern L1401 L1402: 4 byte(7)78,69,88,80,82,0 intern L1402 L1403: 1 byte(7)68,77,0 intern L1403 L1404: 4 byte(7)77,65,67,82,79,0 intern L1404 L1405: 3 byte(7)76,73,83,84,0 intern L1405 L1406: 4 byte(7)65,84,83,79,67,0 intern L1406 L1407: 2 byte(7)71,69,81,0 intern L1407 L1408: 2 byte(7)76,69,81,0 intern L1408 L1409: 4 byte(7)69,81,67,65,82,0 intern L1409 L1410: 3 byte(7)71,69,84,68,0 intern L1410 L1411: 4 byte(7)67,79,80,89,68,0 intern L1411 L1412: 5 byte(7)68,69,76,65,84,81,0 intern L1412 L1413: 2 byte(7)80,85,84,0 intern L1413 L1414: 7 byte(7)73,78,73,84,69,86,65,76,0 intern L1414 L1415: 4 byte(7)87,72,73,76,69,0 intern L1415 L1416: 4 byte(7)70,84,89,80,69,0 intern L1416 L1417: 6 byte(7)76,65,77,66,68,65,80,0 intern L1417 L1418: 8 byte(7)71,69,84,76,65,77,66,68,65,0 intern L1418 L1419: 14 byte(7)76,65,77,66,68,65,69,86,65,76,65,80,80,76,89,0 intern L1419 L1420: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L1420 L1421: 10 byte(7)76,65,77,66,68,65,65,80,80,76,89,0 intern L1421 L1422: 4 byte(7)65,80,80,76,89,0 intern L1422 L1423: 7 byte(7)68,79,76,65,77,66,68,65,0 intern L1423 L1424: 5 byte(7)76,69,78,71,84,72,0 intern L1424 L1425: 4 byte(7)67,79,68,69,80,0 intern L1425 L1426: 4 byte(7)80,65,73,82,80,0 intern L1426 L1427: 2 byte(7)73,68,80,0 intern L1427 L1428: 1 byte(7)69,81,0 intern L1428 L1429: 3 byte(7)78,85,76,76,0 intern L1429 L1430: 2 byte(7)78,79,84,0 intern L1430 L1431: 6 byte(7)76,69,78,71,84,72,49,0 intern L1431 L1432: 5 byte(7)77,65,80,79,66,76,0 intern L1432 L1433: 10 byte(7)80,82,73,78,84,70,69,88,80,82,83,0 intern L1433 L1434: 10 byte(7)80,82,73,78,84,49,70,69,88,80,82,0 intern L1434 L1435: 5 byte(7)70,69,88,80,82,80,0 intern L1435 L1436: 13 byte(7)80,82,73,78,84,70,85,78,67,84,73,79,78,83,0 intern L1436 L1437: 13 byte(7)80,82,73,78,84,49,70,85,78,67,84,73,79,78,0 intern L1437 L1438: 3 byte(7)80,82,79,80,0 intern L1438 L1439: 6 byte(7)82,69,77,80,82,79,80,0 intern L1439 L1440: 7 byte(7)83,89,83,50,70,73,88,78,0 intern L1440 L1441: 13 byte(7)73,78,70,83,84,65,82,84,73,78,71,66,73,84,0 intern L1441 L1442: 11 byte(7)73,78,70,66,73,84,76,69,78,71,84,72,0 intern L1442 L1443: 7 byte(7)73,78,73,84,72,69,65,80,0 intern L1443 L1444: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L1444 L1445: 4 byte(7)77,65,73,78,46,0 intern L1445 L1446: 3 byte(7)73,78,73,84,0 intern L1446 L1447: 2 byte(7)73,78,42,0 intern L1447 L1448: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L1448 L1449: 3 byte(7)84,73,77,67,0 intern L1449 L1450: 3 byte(7)68,65,84,69,0 intern L1450 L1451: 10 byte(7)86,69,82,83,73,79,78,78,65,77,69,0 intern L1451 L1452: 5 byte(7)80,85,84,73,78,84,0 intern L1452 L1453: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L1453 L1454: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L1454 L1455: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L1455 L1456: 3 byte(7)70,76,65,71,0 intern L1456 L1457: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L1457 L1458: 7 byte(7)72,69,65,80,73,78,70,79,0 intern L1458 L1459: 6 byte(7)82,69,67,76,65,73,77,0 intern L1459 L1460: 5 byte(7)83,80,65,67,69,68,0 intern L1460 L1461: 5 byte(7)68,65,83,72,69,68,0 intern L1461 L1462: 5 byte(7)68,79,84,84,69,68,0 intern L1462 L1463: 7 byte(7)83,72,79,85,76,68,66,69,0 intern L1463 L1464: 2 byte(7)73,78,70,0 intern L1464 L1465: 2 byte(7)84,65,71,0 intern L1465 L1466: 5 byte(7)77,75,73,84,69,77,0 intern L1466 L1467: 6 byte(7)84,69,83,84,71,69,84,0 intern L1467 L1468: 4 byte(7)36,69,79,70,36,0 intern L1468 L1469: 4 byte(7)42,80,86,65,76,0 intern L1469 L1470: 12 byte(7)84,69,83,84,85,78,68,69,70,73,78,69,68,0 intern L1470 L1471: 9 byte(7)84,69,83,84,83,69,82,73,69,83,0 intern L1471 L1472: 2 byte(7)70,85,77,0 intern L1472 L1473: 2 byte(7)70,79,79,0 intern L1473 L1474: 2 byte(7)70,69,69,0 intern L1474 L1475: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L1475 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/20-tests/main5.rel version [74be4a6583].
cannot compute difference between binary files
Added psl-1983/20-tests/main5.sym version [e99e3e83c4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR WQUOTIENT !%RECLAIM GTHEAP GTSTR GTVECT GTWARRAY GTID HARDCONS CONS XCONS NCONS MKVECT LIST2 LIST3 LIST4 LIST5 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP LOOKUPID INITNEWID MAKEFUNBOUND UPPERCASEP ALPHANUMP READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED FUNBOUNDP !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK BLDMSG EVPROGN SYS2INT PLUS2 MINUS WADD1 ELSE ADD1 WSUB1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAR CDR CAAR CADR CDAR CDDR ATOM APPEND MEMQ REVERSE EVLIS PROGN EVCOND COND SET SETQ PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO LIST ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE FTYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP PAIRP IDP EQ NULL NOT LENGTH1 MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION PROP REMPROP SYS2FIXN INFSTARTINGBIT INFBITLENGTH))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 338)) (SETQ STRINGGENSYM!* (QUOTE "L1004")) (PUT (QUOTE INFBITLENGTH) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0643")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0237")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0321")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0325")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0569")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE FTYPE) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0515")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE WADD1) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0355")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0360")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0230")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0436")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0443") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0183")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0375")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0185")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0184")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0398")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0299")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0674")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0301")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 243)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0369")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WSUB1) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0370")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE LOOKUPID) (QUOTE ENTRYPOINT) (QUOTE "L0270")) (PUT (QUOTE LOOKUPID) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0660")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0425")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0192")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0287")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0263")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0634")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0603")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0471")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0647")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0186")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0330")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 244)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0191")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0297")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0291")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0665")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0620")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0646")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0614")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0402")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0679")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0607")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0222")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0339")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0642")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0604")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0437")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0371")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0483")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0429")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0224")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0509")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0334")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0241")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0295")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0350")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0310")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 241)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 198)) |
Added psl-1983/20-tests/main6.cmd version [9700268b13].
> > | 1 2 | main6,Dmain6,sub6,Dsub6,sub5,Dsub5,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/main6.init version [b74096dbf7].
> > > > > > | 1 2 3 4 5 6 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (GLOBAL (QUOTE (LAMBDA1 LAMBDA2 CODEFORM!*))) |
Added psl-1983/20-tests/main6.mac version [618f6a8945].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern HEAP extern L0183 extern L0184 extern L0185 extern L0186 extern BPS extern L1074 extern L1075 extern L1076 extern L1077 ; (!*ENTRY INITHEAP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR HEAPLOWERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPLOWERBOUND)) ; (MOVEM (REG T1) (WVAR HEAPLAST)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (MOVEM (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INITHEAP EXPR 0) L1078: intern L1078 MOVE 6,L0183 MOVEM 6,L0185 SETZM 1 MOVEM 1,L0186 POPJ 15,0 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 349) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L1079 MOVE 0,SYMVAL+128 HRRZI 12,349 SETZM 13 JRST SYMFNC+349 L1079: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+352 HRRZI 6,1 MOVEM 6,SYMVAL+154 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 353) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+352 JRST L1080 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L1080: MOVE 1,SYMVAL+352 HRRZI 12,353 HRRZI 13,1 JRST SYMFNC+353 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 152) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+154 CAIE 7,1 JRST L1081 PUSHJ 15,PUTC20 POPJ 15,0 L1081: MOVE 2,1 MOVE 1,SYMVAL+154 HRRZI 12,152 HRRZI 13,2 JRST SYMFNC+152 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY DATE EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "No-Date-Yet") (REG 1)) ; (MOVE (REG 1) (QUOTE "No-Date-Yet")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1083: 10 byte(7)78,111,45,68,97,116,101,45,89,101,116,0 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE MOVE 1,L1082 POPJ 15,0 L1082: <4_31>+L1083 ; (!*ENTRY VERSIONNAME EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "DEC-20 test system") (REG 1)) ; (MOVE (REG 1) (QUOTE "DEC-20 test system")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1085: 17 byte(7)68,69,67,45,50,48,32,116,101,115,116,32,115,121,115,116,101,109,0 0 ; (!*ENTRY VERSIONNAME EXPR 0) L1086: intern L1086 MOVE 1,L1084 POPJ 15,0 L1084: <4_31>+L1085 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*ALLOC 0) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L1087: intern L1087 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L1088: intern L1088 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L1089: intern L1089 MOVEM 12,SYMVAL+359 MOVEM 13,SYMVAL+360 JRST SYMFNC+249 ; (!*ENTRY FLAG EXPR 2) ; (!*ALLOC 0) ; (!*MOVE 2 (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINKE 0 ERR20 EXPR 1) extern ERR20 ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 POPJ 15,0 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L1090: intern L1090 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L1091: intern L1091 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 362) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L1092: intern L1092 HRRZI 12,362 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY !%RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE " *** Dummy !%RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE " *** Dummy !%RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 363) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1094: 21 byte(7)32,42,42,42,32,68,117,109,109,121,32,33,37,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY !%RECLAIM EXPR 0) L1095: intern L1095 MOVE 1,L1093 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,363 SETZM 13 JRST SYMFNC+363 L1093: <4_31>+L1094 ; (!*ENTRY RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "*** Dummy RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Dummy RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 363) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1097: 18 byte(7)42,42,42,32,68,117,109,109,121,32,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY RECLAIM EXPR 0) L1098: intern L1098 MOVE 1,L1096 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,363 SETZM 13 JRST SYMFNC+363 L1096: <4_31>+L1097 ; (!*ENTRY HEAPINFO EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPLAST) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPLAST)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLOWERBOUND)) ; (SUB (REG 1) (WVAR HEAPLOWERBOUND)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items used, ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items used, ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPUPPERBOUND) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPUPPERBOUND)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLAST)) ; (SUB (REG 1) (WVAR HEAPLAST)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items left.") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items left.")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1101: 11 byte(7)32,73,116,101,109,115,32,108,101,102,116,46,0 L1102: 12 byte(7)32,73,116,101,109,115,32,117,115,101,100,44,32,0 0 ; (!*ENTRY HEAPINFO EXPR 0) L1103: intern L1103 HRRZI 2,1 MOVE 1,L0185 SUB 1,L0183 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1099 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 2,1 MOVE 1,L0184 SUB 1,L0185 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1100 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 SETZM 1 POPJ 15,0 L1100: <4_31>+L1101 L1099: <4_31>+L1102 ; (!*ENTRY SPACED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1105: 10 byte(7)32,32,32,32,32,32,32,32,32,32,32,0 1 ; (!*ENTRY SPACED EXPR 1) SPACED: intern SPACED PUSH 15,1 MOVE 1,L1104 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1104: <4_31>+L1105 ; (!*ENTRY DASHED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE "---------- ") (REG 1)) ; (MOVE (REG 1) (QUOTE "---------- ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1107: 10 byte(7)45,45,45,45,45,45,45,45,45,45,32,0 1 ; (!*ENTRY DASHED EXPR 1) DASHED: intern DASHED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1106 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1106: <4_31>+L1107 ; (!*ENTRY DOTTED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " ....... ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1109: 10 byte(7)32,32,32,46,46,46,46,46,46,46,32,0 1 ; (!*ENTRY DOTTED EXPR 1) DOTTED: intern DOTTED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1108 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1108: <4_31>+L1109 ; (!*ENTRY SHOULDBE EXPR 3) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE " ....... For ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... For ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " should be ") (REG 1)) ; (MOVE (REG 1) (QUOTE " should be ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAME (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE " [OK ]") (REG 1)) ; (MOVE (REG 1) (QUOTE " [OK ]")) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE " [BAD] *******") (REG 1)) ; (MOVE (REG 1) (QUOTE " [BAD] *******")) ; (!*LBL (LABEL G0006)) ; (!*LINKE 3 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1115: 15 byte(7)32,32,32,91,66,65,68,93,32,42,42,42,42,42,42,42,0 L1116: 6 byte(7)32,32,91,79,75,32,93,0 L1117: 10 byte(7)32,115,104,111,117,108,100,32,98,101,32,0 L1118: 0 byte(7)32,0 L1119: 14 byte(7)32,32,32,46,46,46,46,46,46,46,32,70,111,114,32,0 3 ; (!*ENTRY SHOULDBE EXPR 3) L1120: intern L1120 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,L1110 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1111 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1112 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 6,-1(15) CAME 6,-2(15) JRST L1121 MOVE 1,L1113 JRST L1122 L1121: MOVE 1,L1114 L1122: ADJSP 15,-3 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1114: <4_31>+L1115 L1113: <4_31>+L1116 L1112: <4_31>+L1117 L1111: <4_31>+L1118 L1110: <4_31>+L1119 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (!$FLUID UNDEFNNARG!*) (FRAME 2)) ; (MOVE (REG T1) (!$FLUID UNDEFNNARG!*)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*MOVE (!$FLUID UNDEFNCODE!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID UNDEFNCODE!*)) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE "Undefined Function ") (REG 1)) ; (MOVE (REG 1) (QUOTE "Undefined Function ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " called with ") (REG 1)) ; (MOVE (REG 1) (QUOTE " called with ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " args from compiled code") (REG 1)) ; (MOVE (REG 1) (QUOTE " args from compiled code")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L1126: 23 byte(7)32,97,114,103,115,32,102,114,111,109,32,99,111,109,112,105,108,101,100,32,99,111,100,101,0 L1127: 12 byte(7)32,99,97,108,108,101,100,32,119,105,116,104,32,0 L1128: 18 byte(7)85,110,100,101,102,105,110,101,100,32,70,117,110,99,116,105,111,110,32,0 0 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) L1129: intern L1129 ADJSP 15,2 MOVE 6,SYMVAL+360 MOVEM 6,-1(15) MOVE 1,SYMVAL+359 TLZ 1,253952 TLO 1,245760 MOVEM 1,0(15) MOVE 1,L1123 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1124 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1125 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L1125: <4_31>+L1126 L1124: <4_31>+L1127 L1123: <4_31>+L1128 ; (!*ENTRY INF EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY INF EXPR 1) INF: intern INF HRRZ 1,1 POPJ 15,0 ; (!*ENTRY TAG EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 0) (WCONST 5)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY TAG EXPR 1) TAG: intern TAG LDB 1,L1130 POPJ 15,0 L1130: point 5,1,4 ; (!*ENTRY MKITEM EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MKITEM (REG 1) (REG 3)) ; (DPB (REG 3) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 2 ; (!*ENTRY MKITEM EXPR 2) MKITEM: intern MKITEM MOVE 3,1 MOVE 1,2 DPB 3,L1131 POPJ 15,0 L1131: point 5,1,4 ; (!*ENTRY BLDMSG EXPR 7) ; (!*ALLOC 7) ; (ADJSP (REG ST) 7) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 4) (FRAME 4)) ; (MOVEM (REG 4) (INDEXED (REG ST) -3)) ; (!*MOVE (REG 5) (FRAME 5)) ; (MOVEM (REG 5) (INDEXED (REG ST) -4)) ; (!*MOVE (REG 6) (FRAME 6)) ; (HRRZI (REG T1) (IMMEDIATE (EXTRAREG 6))) ; (MOVEM (REG T1) (INDEXED (REG ST) -5)) ; (!*MOVE (REG 7) (FRAME 7)) ; (HRRZI (REG T1) (IMMEDIATE (EXTRAREG 7))) ; (MOVEM (REG T1) (INDEXED (REG ST) -6)) ; (!*MOVE (QUOTE "BldMsg called") (REG 1)) ; (MOVE (REG 1) (QUOTE "BldMsg called")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (FRAME 4) (REG 4)) ; (MOVE (REG 4) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LIST4 EXPR 4) ; (HRRZI (REG LINKREG) 185) ; (HRRZI (REG NARGREG) 4) ; (PUSHJ (REG ST) (ENTRY LIST4)) ; (!*LINKE 7 PRINT EXPR 1) ; (ADJSP (REG ST) (MINUS 7)) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRINT)) L1133: 12 byte(7)66,108,100,77,115,103,32,99,97,108,108,101,100,0 7 ; (!*ENTRY BLDMSG EXPR 7) BLDMSG: intern BLDMSG ADJSP 15,7 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVEM 5,-4(15) HRRZI 6,L0004+0 MOVEM 6,-5(15) HRRZI 6,L0004+1 MOVEM 6,-6(15) MOVE 1,L1132 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 4,-3(15) MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) HRRZI 12,185 HRRZI 13,4 PUSHJ 15,SYMFNC+185 ADJSP 15,-7 HRRZI 12,140 HRRZI 13,1 JRST SYMFNC+140 L1132: <4_31>+L1133 ; (!*ENTRY TIME EXPR 0) ; (!*ALLOC 0) ; (!*LINKE 0 TIMC EXPR 0) ; (HRRZI (REG LINKREG) 354) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY TIMC)) 0 ; (!*ENTRY TIME EXPR 0) TIME: intern TIME HRRZI 12,354 SETZM 13 JRST SYMFNC+354 ; (!*ENTRY FUNCALL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 3)) ; (MOVE (REG 3) (REG 2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*LINKE 0 IDAPPLY1 EXPR 2) ; (HRRZI (REG NARGREG) 1) ; (MOVE (REG LINKREG) (REG 2)) ; (JRST (INDEXED (REG 2) (WARRAY SYMFNC))) 2 ; (!*ENTRY FUNCALL EXPR 2) L1134: intern L1134 MOVE 3,2 MOVE 2,1 MOVE 1,3 HRRZI 13,1 MOVE 12,2 JRST SYMFNC(2) ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (QUOTE NIL) (FRAME 1)) ; (MOVEM (REG NIL) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 351) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*LINK INITHEAP EXPR 0) ; (HRRZI (REG LINKREG) 348) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITHEAP)) ; (!*LINK INITEVAL EXPR 0) ; (HRRZI (REG LINKREG) 309) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITEVAL)) ; (!*MOVE (QUOTE "MINI-PSL: A Read-Eval-Print Loop, terminate with Q") (REG 1)) ; (MOVE (REG 1) (QUOTE "MINI-PSL: A Read-Eval-Print Loop, terminate with Q")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " !*RAISE has been set T") (REG 1)) ; (MOVE (REG 1) (QUOTE " !*RAISE has been set T")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " Run (TESTSERIES) to check BINDING etc") (REG 1)) ; (MOVE (REG 1) (QUOTE " Run (TESTSERIES) to check BINDING etc")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (!$FLUID DEBUG)) ; (MOVEM (REG 1) (!$FLUID DEBUG)) ; (!*LINK INITREAD EXPR 0) ; (HRRZI (REG LINKREG) 190) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITREAD)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*MOVE (REG 1) (!$FLUID !*RAISE)) ; (MOVEM (REG 1) (!$FLUID !*RAISE)) ; (!*MOVE (WCONST 26) (REG 1)) ; (HRRZI (REG 1) 26) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (!$FLUID !$EOF!$)) ; (MOVEM (REG 1) (!$FLUID !$EOF!$)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE " .... Now Call INITCODE") (REG 1)) ; (MOVE (REG 1) (QUOTE " .... Now Call INITCODE")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK INITCODE EXPR 0) ; (HRRZI (REG LINKREG) 374) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITCODE)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (QUOTE NIL)) ; (CAME (REG NIL) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0004)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " lisp> ") (REG 1)) ; (MOVE (REG 1) (QUOTE " lisp> ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTEQ (LABEL G0011) (REG 1) (QUOTE Q)) ; (CAME (REG 1) (QUOTE Q)) ; (JRST (LABEL G0011)) ; (!*MOVE (QUOTE T) (FRAME 2)) ; (MOVE (REG T1) (FLUID T)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0011)) ; (!*JUMPNOTEQ (LABEL G0012) (REG 1) (!$GLOBAL !$EOF!$)) ; (CAME (REG 1) (!$GLOBAL !$EOF!$)) ; (JRST (LABEL G0012)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " **** Top Level EOF **** ") (REG 1)) ; (MOVE (REG 1) (QUOTE " **** Top Level EOF **** ")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0012)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) L1142: 24 byte(7)32,42,42,42,42,32,84,111,112,32,76,101,118,101,108,32,69,79,70,32,42,42,42,42,32,0 L1143: 6 byte(7)32,108,105,115,112,62,32,0 L1144: 22 byte(7)32,46,46,46,46,32,78,111,119,32,67,97,108,108,32,73,78,73,84,67,79,68,69,0 L1145: 42 byte(7)32,32,32,32,32,32,82,117,110,32,40,84,69,83,84,83,69,82,73,69,83,41,32,116,111,32,99,104,101,99,107,32,66,73,78,68,73,78,71,32,101,116,99,0 L1146: 27 byte(7)32,32,32,32,32,32,33,42,82,65,73,83,69,32,104,97,115,32,98,101,101,110,32,115,101,116,32,84,0 L1147: 49 byte(7)77,73,78,73,45,80,83,76,58,32,65,32,82,101,97,100,45,69,118,97,108,45,80,114,105,110,116,32,76,111,111,112,44,32,116,101,114,109,105,110,97,116,101,32,119,105,116,104,32,81,0 0 ; (!*ENTRY FIRSTCALL EXPR 0) L1148: intern L1148 ADJSP 15,3 MOVEM 0,0(15) MOVEM 0,-1(15) HRRZI 12,351 SETZM 13 PUSHJ 15,SYMFNC+351 HRRZI 12,348 SETZM 13 PUSHJ 15,SYMFNC+348 HRRZI 12,309 SETZM 13 PUSHJ 15,SYMFNC+309 MOVE 1,L1135 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1136 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1137 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,0 MOVEM 1,SYMVAL+195 HRRZI 12,190 SETZM 13 PUSHJ 15,SYMFNC+190 MOVE 1,SYMVAL+84 MOVEM 1,SYMVAL+191 HRRZI 1,26 TLZ 1,253952 TLO 1,245760 MOVEM 1,SYMVAL+375 SETZM -2(15) MOVE 1,L1138 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,374 SETZM 13 PUSHJ 15,SYMFNC+374 L1149: CAME 0,-1(15) JRST L1150 AOS -2(15) MOVE 1,-2(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1139 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,0(15) CAME 1,L1140 JRST L1151 MOVE 6,SYMVAL+84 MOVEM 6,-1(15) JRST L1149 L1151: CAME 1,SYMVAL+375 JRST L1152 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1141 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 JRST L1149 L1152: HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0(15) HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 MOVEM 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 JRST L1149 L1150: HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1141: <4_31>+L1142 L1140: <30_31>+81 L1139: <4_31>+L1143 L1138: <4_31>+L1144 L1137: <4_31>+L1145 L1136: <4_31>+L1146 L1135: <4_31>+L1147 ; (!*ENTRY TESTSERIES EXPR 0) ; (!*ALLOC 0) ; (!*LINK BINDINGTEST EXPR 0) ; (HRRZI (REG LINKREG) 376) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY BINDINGTEST)) ; (!*LINK INTERPTEST EXPR 0) ; (HRRZI (REG LINKREG) 377) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INTERPTEST)) ; (!*LINK COMPBINDTEST EXPR 0) ; (HRRZI (REG LINKREG) 378) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY COMPBINDTEST)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TESTSERIES EXPR 0) L1153: intern L1153 HRRZI 12,376 SETZM 13 PUSHJ 15,SYMFNC+376 HRRZI 12,377 SETZM 13 PUSHJ 15,SYMFNC+377 HRRZI 12,378 SETZM 13 PUSHJ 15,SYMFNC+378 MOVE 1,0 POPJ 15,0 ; (!*ENTRY BINDINGTEST EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Test BINDING Primitives") (REG 1)) ; (MOVE (REG 1) (QUOTE "Test BINDING Primitives")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (WCONST 1) (!$FLUID AA)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID AA)) ; (!*MOVE (QUOTE AA) (REG 1)) ; (MOVE (REG 1) (QUOTE AA)) ; (!*LINK PBIND1 EXPR 1) ; (HRRZI (REG LINKREG) 346) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PBIND1)) ; (!*MOVE (WCONST 3) (REG 2)) ; (HRRZI (REG 2) 3) ; (!*MOVE (QUOTE AA) (REG 1)) ; (MOVE (REG 1) (QUOTE AA)) ; (!*LINK LBIND1 EXPR 2) ; (HRRZI (REG LINKREG) 257) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LBIND1)) ; (!*MOVE (WCONST 3) (REG 3)) ; (HRRZI (REG 3) 3) ; (!*MOVE (!$FLUID AA) (REG 2)) ; (MOVE (REG 2) (!$FLUID AA)) ; (!*MOVE (QUOTE "3rd bound AA") (REG 1)) ; (MOVE (REG 1) (QUOTE "3rd bound AA")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINK UNBINDN EXPR 1) ; (HRRZI (REG LINKREG) 168) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*MOVE (QUOTE NIL) (REG 3)) ; (MOVE (REG 3) (REG NIL)) ; (!*MOVE (!$FLUID AA) (REG 2)) ; (MOVE (REG 2) (!$FLUID AA)) ; (!*MOVE (QUOTE "2rd bound AA") (REG 1)) ; (MOVE (REG 1) (QUOTE "2rd bound AA")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINK UNBINDN EXPR 1) ; (HRRZI (REG LINKREG) 168) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*MOVE (WCONST 1) (REG 3)) ; (HRRZI (REG 3) 1) ; (!*MOVE (!$FLUID AA) (REG 2)) ; (MOVE (REG 2) (!$FLUID AA)) ; (!*MOVE (QUOTE "Original AA") (REG 1)) ; (MOVE (REG 1) (QUOTE "Original AA")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1159: 10 byte(7)79,114,105,103,105,110,97,108,32,65,65,0 L1160: 11 byte(7)50,114,100,32,98,111,117,110,100,32,65,65,0 L1161: 11 byte(7)51,114,100,32,98,111,117,110,100,32,65,65,0 L1162: 22 byte(7)84,101,115,116,32,66,73,78,68,73,78,71,32,80,114,105,109,105,116,105,118,101,115,0 0 ; (!*ENTRY BINDINGTEST EXPR 0) L1163: intern L1163 MOVE 1,L1154 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 HRRZI 6,1 MOVEM 6,SYMVAL+380 MOVE 1,L1155 HRRZI 12,346 HRRZI 13,1 PUSHJ 15,SYMFNC+346 HRRZI 2,3 MOVE 1,L1155 HRRZI 12,257 HRRZI 13,2 PUSHJ 15,SYMFNC+257 HRRZI 3,3 MOVE 2,SYMVAL+380 MOVE 1,L1156 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 HRRZI 1,1 HRRZI 12,168 HRRZI 13,1 PUSHJ 15,SYMFNC+168 MOVE 3,0 MOVE 2,SYMVAL+380 MOVE 1,L1157 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 HRRZI 1,1 HRRZI 12,168 HRRZI 13,1 PUSHJ 15,SYMFNC+168 HRRZI 3,1 MOVE 2,SYMVAL+380 MOVE 1,L1158 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,0 POPJ 15,0 L1158: <4_31>+L1159 L1157: <4_31>+L1160 L1156: <4_31>+L1161 L1155: <30_31>+380 L1154: <4_31>+L1162 ; (!*ENTRY INTERPTEST EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "TEST of Interpreter Primitives for LAMBDA's ") (REG 1)) ; (MOVE (REG 1) (QUOTE "TEST of Interpreter Primitives for LAMBDA's ")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (QUOTE (LAMBDA (X1 X2) (PRINT (LIST (QUOTE LAMBDA1) X1 X2)) (QUOTE L1))) (!$GLOBAL LAMBDA1)) ; (MOVE (REG T1) (QUOTE (LAMBDA (X1 X2) (PRINT (LIST (QUOTE LAMBDA1) X1 X2)) (QUOTE L1)))) ; (MOVEM (REG T1) (!$GLOBAL LAMBDA1)) ; (!*MOVE (QUOTE (LAMBDA (Y1 Y2) (PRINT (LIST (QUOTE LAMBDA2) Y1 Y2)) (QUOTE L2))) (!$GLOBAL LAMBDA2)) ; (MOVE (REG T1) (QUOTE (LAMBDA (Y1 Y2) (PRINT (LIST (QUOTE LAMBDA2) Y1 Y2)) (QUOTE L2)))) ; (MOVEM (REG T1) (!$GLOBAL LAMBDA2)) ; (!*MOVE (QUOTE "LAMBDA1: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "LAMBDA1: ")) ; (!*LINK SPACED EXPR 1) ; (HRRZI (REG LINKREG) 365) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SPACED)) ; (!*MOVE (!$GLOBAL LAMBDA1) (REG 1)) ; (MOVE (REG 1) (!$GLOBAL LAMBDA1)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (QUOTE "FastLambdaApply on Lambda1") (REG 1)) ; (MOVE (REG 1) (QUOTE "FastLambdaApply on Lambda1")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (!$GLOBAL LAMBDA1) (!$GLOBAL CODEFORM!*)) ; (MOVE (REG T1) (!$GLOBAL LAMBDA1)) ; (MOVEM (REG T1) (!$GLOBAL CODEFORM!*)) ; (!*MOVE (WCONST 20) (REG 2)) ; (HRRZI (REG 2) 20) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINK FASTLAMBDAAPPLY EXPR 2) ; (HRRZI (REG LINKREG) 247) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY FASTLAMBDAAPPLY)) ; (!*MOVE (QUOTE L1) (REG 3)) ; (MOVE (REG 3) (QUOTE L1)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE "FastLambdaApply") (REG 1)) ; (MOVE (REG 1) (QUOTE "FastLambdaApply")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE "Now Test FASTAPPLY") (REG 1)) ; (MOVE (REG 1) (QUOTE "Now Test FASTAPPLY")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (QUOTE C1) (REG 3)) ; (MOVE (REG 3) (QUOTE C1)) ; (!*MOVE (QUOTE COMPILED1) (REG 2)) ; (MOVE (REG 2) (QUOTE COMPILED1)) ; (!*MOVE (QUOTE " Compiled ID 1 ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Compiled ID 1 ")) ; (!*LINK TESTAPPLY EXPR 3) ; (HRRZI (REG LINKREG) 381) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TESTAPPLY)) ; (!*MOVE (QUOTE COMPILED2) (REG 1)) ; (MOVE (REG 1) (QUOTE COMPILED2)) ; (!*LINK GETFCODEPOINTER EXPR 1) ; (HRRZI (REG LINKREG) 239) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GETFCODEPOINTER)) ; (!*MOVE (QUOTE C2) (REG 3)) ; (MOVE (REG 3) (QUOTE C2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE " CodePointer 2 ") (REG 1)) ; (MOVE (REG 1) (QUOTE " CodePointer 2 ")) ; (!*LINK TESTAPPLY EXPR 3) ; (HRRZI (REG LINKREG) 381) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TESTAPPLY)) ; (!*MOVE (QUOTE L1) (REG 3)) ; (MOVE (REG 3) (QUOTE L1)) ; (!*MOVE (!$GLOBAL LAMBDA1) (REG 2)) ; (MOVE (REG 2) (!$GLOBAL LAMBDA1)) ; (!*MOVE (QUOTE " Lambda Expression 1 ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Lambda Expression 1 ")) ; (!*LINK TESTAPPLY EXPR 3) ; (HRRZI (REG LINKREG) 381) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TESTAPPLY)) ; (!*MOVE (QUOTE "Test a compiled call on Interpreted code ") (REG 1)) ; (MOVE (REG 1) (QUOTE "Test a compiled call on Interpreted code ")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (QUOTE (LAMBDA (AG1 AG2 AG3) (PRINT (LIST (QUOTE INTERPRETED3) AG1 AG2 AG3)) (QUOTE L3))) (REG 3)) ; (MOVE (REG 3) (QUOTE (LAMBDA (AG1 AG2 AG3) (PRINT (LIST (QUOTE INTERPRETED3) AG1 AG2 AG3)) (QUOTE L3)))) ; (!*MOVE (QUOTE EXPR) (REG 2)) ; (MOVE (REG 2) (QUOTE EXPR)) ; (!*MOVE (QUOTE INTERPRETED3) (REG 1)) ; (MOVE (REG 1) (QUOTE INTERPRETED3)) ; (!*LINK PUTD EXPR 3) ; (HRRZI (REG LINKREG) 291) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY PUTD)) ; (!*MOVE (QUOTE INTERPRETED3) (REG 1)) ; (MOVE (REG 1) (QUOTE INTERPRETED3)) ; (!*LINK FLAMBDALINKP EXPR 1) ; (HRRZI (REG LINKREG) 234) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FLAMBDALINKP)) ; (!*MOVE (QUOTE T) (REG 3)) ; (MOVE (REG 3) (FLUID T)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE " FlambdaLinkP") (REG 1)) ; (MOVE (REG 1) (QUOTE " FlambdaLinkP")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (WCONST 320) (REG 3)) ; (HRRZI (REG 3) 320) ; (!*MOVE (WCONST 310) (REG 2)) ; (HRRZI (REG 2) 310) ; (!*MOVE (WCONST 300) (REG 1)) ; (HRRZI (REG 1) 300) ; (!*LINK INTERPRETED3 EXPR 3) ; (HRRZI (REG LINKREG) 382) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY INTERPRETED3)) ; (!*MOVE (QUOTE L3) (REG 3)) ; (MOVE (REG 3) (QUOTE L3)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE " Interp3") (REG 1)) ; (MOVE (REG 1) (QUOTE " Interp3")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (!$GLOBAL LAMBDA2) (REG 3)) ; (MOVE (REG 3) (!$GLOBAL LAMBDA2)) ; (!*MOVE (QUOTE EXPR) (REG 2)) ; (MOVE (REG 2) (QUOTE EXPR)) ; (!*MOVE (QUOTE INTERPRETED2) (REG 1)) ; (MOVE (REG 1) (QUOTE INTERPRETED2)) ; (!*LINK PUTD EXPR 3) ; (HRRZI (REG LINKREG) 291) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY PUTD)) ; (!*MOVE (QUOTE L2) (REG 3)) ; (MOVE (REG 3) (QUOTE L2)) ; (!*MOVE (QUOTE INTERPRETED2) (REG 2)) ; (MOVE (REG 2) (QUOTE INTERPRETED2)) ; (!*MOVE (QUOTE " Interpreted ID 2 ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Interpreted ID 2 ")) ; (!*LINK TESTAPPLY EXPR 3) ; (HRRZI (REG LINKREG) 381) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TESTAPPLY)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1189: 17 byte(7)32,73,110,116,101,114,112,114,101,116,101,100,32,73,68,32,50,32,0 L1190: 7 byte(7)32,73,110,116,101,114,112,51,0 L1191: 12 byte(7)32,70,108,97,109,98,100,97,76,105,110,107,80,0 L1192: <30_31>+248 <9_31>+L1204 L1193: 40 byte(7)84,101,115,116,32,97,32,99,111,109,112,105,108,101,100,32,99,97,108,108,32,111,110,32,73,110,116,101,114,112,114,101,116,101,100,32,99,111,100,101,32,0 L1194: 20 byte(7)32,76,97,109,98,100,97,32,69,120,112,114,101,115,115,105,111,110,32,49,32,0 L1195: 14 byte(7)32,67,111,100,101,80,111,105,110,116,101,114,32,50,32,0 L1196: 14 byte(7)32,67,111,109,112,105,108,101,100,32,73,68,32,49,32,0 L1197: 17 byte(7)78,111,119,32,84,101,115,116,32,70,65,83,84,65,80,80,76,89,0 L1198: 14 byte(7)70,97,115,116,76,97,109,98,100,97,65,112,112,108,121,0 L1199: 25 byte(7)70,97,115,116,76,97,109,98,100,97,65,112,112,108,121,32,111,110,32,76,97,109,98,100,97,49,0 L1200: 8 byte(7)76,65,77,66,68,65,49,58,32,0 L1201: <30_31>+248 <9_31>+L1205 L1202: <30_31>+248 <9_31>+L1206 L1203: 43 byte(7)84,69,83,84,32,111,102,32,73,110,116,101,114,112,114,101,116,101,114,32,80,114,105,109,105,116,105,118,101,115,32,102,111,114,32,76,65,77,66,68,65,39,115,32,0 L1204: <9_31>+L1207 <9_31>+L1208 L1205: <9_31>+L1209 <9_31>+L1210 L1206: <9_31>+L1211 <9_31>+L1212 L1207: <30_31>+383 <9_31>+L1213 L1208: <9_31>+L1214 <9_31>+L1215 L1209: <30_31>+384 <9_31>+L1216 L1210: <9_31>+L1217 <9_31>+L1218 L1211: <30_31>+385 <9_31>+L1219 L1212: <9_31>+L1220 <9_31>+L1221 L1213: <30_31>+386 <9_31>+L1222 L1214: <30_31>+140 <9_31>+L1223 L1215: <9_31>+L1224 <30_31>+128 L1216: <30_31>+387 <30_31>+128 L1217: <30_31>+140 <9_31>+L1225 L1218: <9_31>+L1226 <30_31>+128 L1219: <30_31>+388 <30_31>+128 L1220: <30_31>+140 <9_31>+L1227 L1221: <9_31>+L1228 <30_31>+128 L1222: <30_31>+389 <30_31>+128 L1223: <9_31>+L1229 <30_31>+128 L1224: <30_31>+223 <9_31>+L1230 L1225: <9_31>+L1231 <30_31>+128 L1226: <30_31>+223 <9_31>+L1232 L1227: <9_31>+L1233 <30_31>+128 L1228: <30_31>+223 <9_31>+L1234 L1229: <30_31>+300 <9_31>+L1235 L1230: <30_31>+390 <30_31>+128 L1231: <30_31>+300 <9_31>+L1236 L1232: <30_31>+391 <30_31>+128 L1233: <30_31>+300 <9_31>+L1237 L1234: <30_31>+392 <30_31>+128 L1235: <9_31>+L1238 <9_31>+L1207 L1236: <9_31>+L1239 <9_31>+L1209 L1237: <9_31>+L1240 <9_31>+L1211 L1238: <30_31>+223 <9_31>+L1241 L1239: <30_31>+223 <9_31>+L1242 L1240: <30_31>+223 <9_31>+L1243 L1241: <30_31>+382 <30_31>+128 L1242: <30_31>+393 <30_31>+128 L1243: <30_31>+394 <30_31>+128 0 ; (!*ENTRY INTERPTEST EXPR 0) L1244: intern L1244 MOVE 1,L1164 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 MOVE 6,L1165 MOVEM 6,SYMVAL+394 MOVE 6,L1166 MOVEM 6,SYMVAL+393 MOVE 1,L1167 HRRZI 12,365 HRRZI 13,1 PUSHJ 15,SYMFNC+365 MOVE 1,SYMVAL+394 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 1,L1168 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 MOVE 6,SYMVAL+394 MOVEM 6,SYMVAL+243 HRRZI 2,20 HRRZI 1,10 HRRZI 12,247 HRRZI 13,2 PUSHJ 15,SYMFNC+247 MOVE 3,L1169 MOVE 2,1 MOVE 1,L1170 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,L1171 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 MOVE 3,L1172 MOVE 2,L1173 MOVE 1,L1174 HRRZI 12,381 HRRZI 13,3 PUSHJ 15,SYMFNC+381 MOVE 1,L1175 HRRZI 12,239 HRRZI 13,1 PUSHJ 15,SYMFNC+239 MOVE 3,L1176 MOVE 2,1 MOVE 1,L1177 HRRZI 12,381 HRRZI 13,3 PUSHJ 15,SYMFNC+381 MOVE 3,L1169 MOVE 2,SYMVAL+394 MOVE 1,L1178 HRRZI 12,381 HRRZI 13,3 PUSHJ 15,SYMFNC+381 MOVE 1,L1179 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 MOVE 3,L1180 MOVE 2,L1181 MOVE 1,L1182 HRRZI 12,291 HRRZI 13,3 PUSHJ 15,SYMFNC+291 MOVE 1,L1182 HRRZI 12,234 HRRZI 13,1 PUSHJ 15,SYMFNC+234 MOVE 3,SYMVAL+84 MOVE 2,1 MOVE 1,L1183 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 HRRZI 3,320 HRRZI 2,310 HRRZI 1,300 HRRZI 12,382 HRRZI 13,3 PUSHJ 15,SYMFNC+382 MOVE 3,L1184 MOVE 2,1 MOVE 1,L1185 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,SYMVAL+393 MOVE 2,L1181 MOVE 1,L1186 HRRZI 12,291 HRRZI 13,3 PUSHJ 15,SYMFNC+291 MOVE 3,L1187 MOVE 2,L1186 MOVE 1,L1188 HRRZI 12,381 HRRZI 13,3 PUSHJ 15,SYMFNC+381 MOVE 1,0 POPJ 15,0 L1188: <4_31>+L1189 L1187: <30_31>+391 L1186: <30_31>+395 L1185: <4_31>+L1190 L1184: <30_31>+390 L1183: <4_31>+L1191 L1182: <30_31>+382 L1181: <30_31>+293 L1180: <9_31>+L1192 L1179: <4_31>+L1193 L1178: <4_31>+L1194 L1177: <4_31>+L1195 L1176: <30_31>+396 L1175: <30_31>+397 L1174: <4_31>+L1196 L1173: <30_31>+398 L1172: <30_31>+399 L1171: <4_31>+L1197 L1170: <4_31>+L1198 L1169: <30_31>+392 L1168: <4_31>+L1199 L1167: <4_31>+L1200 L1166: <9_31>+L1201 L1165: <9_31>+L1202 L1164: <4_31>+L1203 ; (!*ENTRY TESTFASTAPPLY EXPR 0) ; (!*MOVE (FLUID TESTCODE!*) (REG T1)) ; (MOVE (REG T1) (FLUID TESTCODE!*)) ; (!*JCALL FASTAPPLY) ; (JRST (ENTRY FASTAPPLY)) 0 ; (!*ENTRY TESTFASTAPPLY EXPR 0) L1245: intern L1245 MOVE 6,SYMVAL+401 JRST SYMFNC+246 ; (!*ENTRY TESTAPPLY EXPR 3) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE " Testapply case ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Testapply case ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " given ") (REG 1)) ; (MOVE (REG 1) (QUOTE " given ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (FRAME 2) (!$FLUID TESTCODE!*)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (MOVEM (REG T1) (!$FLUID TESTCODE!*)) ; (!*MOVE (QUOTE B) (REG 2)) ; (MOVE (REG 2) (QUOTE B)) ; (!*MOVE (QUOTE A) (REG 1)) ; (MOVE (REG 1) (QUOTE A)) ; (!*LINK TESTFASTAPPLY EXPR 2) ; (HRRZI (REG LINKREG) 400) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY TESTFASTAPPLY)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (QUOTE " answer") (REG 1)) ; (MOVE (REG 1) (QUOTE " answer")) ; (!*LINKE 4 SHOULDBE EXPR 3) ; (ADJSP (REG ST) (MINUS 4)) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY SHOULDBE)) L1251: 7 byte(7)32,32,97,110,115,119,101,114,0 L1252: 6 byte(7)32,103,105,118,101,110,32,0 L1253: 17 byte(7)32,32,32,84,101,115,116,97,112,112,108,121,32,99,97,115,101,32,0 3 ; (!*ENTRY TESTAPPLY EXPR 3) L1254: intern L1254 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,L1246 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1247 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 6,-1(15) MOVEM 6,SYMVAL+401 MOVE 2,L1248 MOVE 1,L1249 HRRZI 12,400 HRRZI 13,2 PUSHJ 15,SYMFNC+400 MOVEM 1,-3(15) MOVE 3,-2(15) MOVE 2,1 MOVE 1,L1250 ADJSP 15,-4 HRRZI 12,368 HRRZI 13,3 JRST SYMFNC+368 L1250: <4_31>+L1251 L1249: <30_31>+65 L1248: <30_31>+66 L1247: <4_31>+L1252 L1246: <4_31>+L1253 ; (!*ENTRY COMPILED1 EXPR 2) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " Compiled1(") (REG 1)) ; (MOVE (REG 1) (QUOTE " Compiled1(")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE ")") (REG 1)) ; (MOVE (REG 1) (QUOTE ")")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE C1) (REG 1)) ; (MOVE (REG 1) (QUOTE C1)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L1259: 0 byte(7)41,0 L1260: 0 byte(7)32,0 L1261: 14 byte(7)32,32,32,32,32,67,111,109,112,105,108,101,100,49,40,0 2 ; (!*ENTRY COMPILED1 EXPR 2) L1262: intern L1262 PUSH 15,2 PUSH 15,1 MOVE 1,L1255 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1256 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1257 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1258 ADJSP 15,-2 POPJ 15,0 L1258: <30_31>+399 L1257: <4_31>+L1259 L1256: <4_31>+L1260 L1255: <4_31>+L1261 ; (!*ENTRY COMPILED2 EXPR 2) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " Compiled2(") (REG 1)) ; (MOVE (REG 1) (QUOTE " Compiled2(")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE ")") (REG 1)) ; (MOVE (REG 1) (QUOTE ")")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE C2) (REG 1)) ; (MOVE (REG 1) (QUOTE C2)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L1267: 0 byte(7)41,0 L1268: 0 byte(7)32,0 L1269: 14 byte(7)32,32,32,32,32,67,111,109,112,105,108,101,100,50,40,0 2 ; (!*ENTRY COMPILED2 EXPR 2) L1270: intern L1270 PUSH 15,2 PUSH 15,1 MOVE 1,L1263 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1264 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1265 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1266 ADJSP 15,-2 POPJ 15,0 L1266: <30_31>+396 L1265: <4_31>+L1267 L1264: <4_31>+L1268 L1263: <4_31>+L1269 ; (!*ENTRY COMPBINDTEST EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Test LAMBIND and PROGBIND in compiled code") (REG 1)) ; (MOVE (REG 1) (QUOTE "Test LAMBIND and PROGBIND in compiled code")) ; (!*LINK DASHED EXPR 1) ; (HRRZI (REG LINKREG) 366) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DASHED)) ; (!*MOVE (QUOTE TOP1) (!$FLUID CFL1)) ; (MOVE (REG T1) (QUOTE TOP1)) ; (MOVEM (REG T1) (!$FLUID CFL1)) ; (!*MOVE (QUOTE TOP2) (!$FLUID CFL2)) ; (MOVE (REG T1) (QUOTE TOP2)) ; (MOVEM (REG T1) (!$FLUID CFL2)) ; (!*MOVE (QUOTE MID2) (REG 3)) ; (MOVE (REG 3) (QUOTE MID2)) ; (!*MOVE (QUOTE MID1) (REG 2)) ; (MOVE (REG 2) (QUOTE MID1)) ; (!*MOVE (QUOTE MID0) (REG 1)) ; (MOVE (REG 1) (QUOTE MID0)) ; (!*LINK CBIND1 EXPR 3) ; (HRRZI (REG LINKREG) 402) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY CBIND1)) ; (!*MOVE (QUOTE TOP1) (REG 3)) ; (MOVE (REG 3) (QUOTE TOP1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE TOP2) (REG 3)) ; (MOVE (REG 3) (QUOTE TOP2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1279: 3 byte(7)67,70,76,50,0 L1280: 3 byte(7)67,70,76,49,0 L1281: 41 byte(7)84,101,115,116,32,76,65,77,66,73,78,68,32,97,110,100,32,80,82,79,71,66,73,78,68,32,105,110,32,99,111,109,112,105,108,101,100,32,99,111,100,101,0 0 ; (!*ENTRY COMPBINDTEST EXPR 0) L1282: intern L1282 MOVE 1,L1271 HRRZI 12,366 HRRZI 13,1 PUSHJ 15,SYMFNC+366 MOVE 6,L1272 MOVEM 6,SYMVAL+403 MOVE 6,L1273 MOVEM 6,SYMVAL+404 MOVE 3,L1274 MOVE 2,L1275 MOVE 1,L1276 HRRZI 12,402 HRRZI 13,3 PUSHJ 15,SYMFNC+402 MOVE 3,L1272 MOVE 2,SYMVAL+403 MOVE 1,L1277 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1273 MOVE 2,SYMVAL+404 MOVE 1,L1278 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,0 POPJ 15,0 L1278: <4_31>+L1279 L1277: <4_31>+L1280 L1276: <30_31>+405 L1275: <30_31>+406 L1274: <30_31>+407 L1273: <30_31>+408 L1272: <30_31>+409 L1271: <4_31>+L1281 ; (!*ENTRY CBIND1 EXPR 3) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LAMBIND (REGISTERS (REG 3) (REG 2)) (NONLOCALVARS (!$FLUID CFL2) (!$FLUID CFL1))) ; (MOVEM (REG 3) (INDIRECT (FLUID LAMBINDARGS!*))) ; (MOVE (REG 3) (FLUID LAMBINDARGS!*)) ; (MOVEM (REG 2) (INDEXED (REG 3) 1)) ; (MOVE (REG 1) (QUOTE [CFL2 CFL1])) ; (PUSHJ (REG ST) (ENTRY LAMBIND)) ; (!*MOVE (QUOTE MID0) (REG 3)) ; (MOVE (REG 3) (QUOTE MID0)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE "x ") (REG 1)) ; (MOVE (REG 1) (QUOTE "x ")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE MID1) (REG 3)) ; (MOVE (REG 3) (QUOTE MID1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE MID2) (REG 3)) ; (MOVE (REG 3) (QUOTE MID2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*LINK CBIND2 EXPR 0) ; (HRRZI (REG LINKREG) 410) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY CBIND2)) ; (!*MOVE (QUOTE BOT1) (REG 3)) ; (MOVE (REG 3) (QUOTE BOT1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE MID2) (REG 3)) ; (MOVE (REG 3) (QUOTE MID2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID CFL2) (!$FLUID CFL1))) ; (HRRZI (REG 1) 2) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) L1291: 3 byte(7)67,70,76,50,0 L1292: 3 byte(7)67,70,76,49,0 L1293: 3 byte(7)120,32,32,32,0 L1294: 1 <30_31>+404 <30_31>+403 3 ; (!*ENTRY CBIND1 EXPR 3) CBIND1: intern CBIND1 PUSH 15,1 MOVEM 3,@SYMVAL+166 MOVE 3,SYMVAL+166 MOVEM 2,1(3) MOVE 1,L1283 PUSHJ 15,SYMFNC+167 MOVE 3,L1284 MOVE 2,0(15) MOVE 1,L1285 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1286 MOVE 2,SYMVAL+403 MOVE 1,L1287 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1288 MOVE 2,SYMVAL+404 MOVE 1,L1289 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 HRRZI 12,410 SETZM 13 PUSHJ 15,SYMFNC+410 MOVE 3,L1290 MOVE 2,SYMVAL+403 MOVE 1,L1287 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1288 MOVE 2,SYMVAL+404 MOVE 1,L1289 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,0 HRRZI 1,2 PUSHJ 15,SYMFNC+168 ADJSP 15,-1 POPJ 15,0 L1290: <30_31>+411 L1289: <4_31>+L1291 L1288: <30_31>+407 L1287: <4_31>+L1292 L1286: <30_31>+406 L1285: <4_31>+L1293 L1284: <30_31>+405 L1283: <8_31>+L1294 ; (!*ENTRY CBIND2 EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE MID1) (REG 3)) ; (MOVE (REG 3) (QUOTE MID1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE MID2) (REG 3)) ; (MOVE (REG 3) (QUOTE MID2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*PROGBIND (NONLOCALVARS (!$FLUID CFL2))) ; (MOVE (REG 1) (QUOTE CFL2)) ; (PUSHJ (REG ST) (ENTRY PBIND1)) ; (!*MOVE (QUOTE BOT1) (!$FLUID CFL1)) ; (MOVE (REG T1) (QUOTE BOT1)) ; (MOVEM (REG T1) (!$FLUID CFL1)) ; (!*MOVE (QUOTE BOT2) (!$FLUID CFL2)) ; (MOVE (REG T1) (QUOTE BOT2)) ; (MOVEM (REG T1) (!$FLUID CFL2)) ; (!*MOVE (QUOTE BOT1) (REG 3)) ; (MOVE (REG 3) (QUOTE BOT1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE BOT2) (REG 3)) ; (MOVE (REG 3) (QUOTE BOT2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID CFL2))) ; (HRRZI (REG 1) 1) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*MOVE (QUOTE BOT1) (REG 3)) ; (MOVE (REG 3) (QUOTE BOT1)) ; (!*MOVE (!$FLUID CFL1) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL1)) ; (!*MOVE (QUOTE "CFL1") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL1")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE MID2) (REG 3)) ; (MOVE (REG 3) (QUOTE MID2)) ; (!*MOVE (!$FLUID CFL2) (REG 2)) ; (MOVE (REG 2) (!$FLUID CFL2)) ; (!*MOVE (QUOTE "CFL2") (REG 1)) ; (MOVE (REG 1) (QUOTE "CFL2")) ; (!*LINK SHOULDBE EXPR 3) ; (HRRZI (REG LINKREG) 368) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SHOULDBE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1302: 3 byte(7)67,70,76,50,0 L1303: 3 byte(7)67,70,76,49,0 0 ; (!*ENTRY CBIND2 EXPR 0) CBIND2: intern CBIND2 MOVE 3,L1295 MOVE 2,SYMVAL+403 MOVE 1,L1296 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1297 MOVE 2,SYMVAL+404 MOVE 1,L1298 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,L1299 PUSHJ 15,SYMFNC+346 MOVE 6,L1300 MOVEM 6,SYMVAL+403 MOVE 6,L1301 MOVEM 6,SYMVAL+404 MOVE 3,L1300 MOVE 2,SYMVAL+403 MOVE 1,L1296 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1301 MOVE 2,SYMVAL+404 MOVE 1,L1298 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 HRRZI 1,1 PUSHJ 15,SYMFNC+168 MOVE 3,L1300 MOVE 2,SYMVAL+403 MOVE 1,L1296 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 3,L1297 MOVE 2,SYMVAL+404 MOVE 1,L1298 HRRZI 12,368 HRRZI 13,3 PUSHJ 15,SYMFNC+368 MOVE 1,0 POPJ 15,0 L1301: <30_31>+412 L1300: <30_31>+411 L1299: <30_31>+404 L1298: <4_31>+L1302 L1297: <30_31>+407 L1296: <4_31>+L1303 L1295: <30_31>+406 0 ; (!*ENTRY INITCODE EXPR 0) L1304: intern L1304 HRRZI 1,15 HRRZI 12,176 HRRZI 13,1 PUSHJ 15,SYMFNC+176 MOVEM 1,SYMVAL+166 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L1305: 0 byte(7)0,0 intern L1305 L1306: 0 byte(7)1,0 intern L1306 L1307: 0 byte(7)2,0 intern L1307 L1308: 0 byte(7)3,0 intern L1308 L1309: 0 byte(7)4,0 intern L1309 L1310: 0 byte(7)5,0 intern L1310 L1311: 0 byte(7)6,0 intern L1311 L1312: 0 byte(7)7,0 intern L1312 L1313: 0 byte(7)8,0 intern L1313 L1314: 0 byte(7)9,0 intern L1314 L1315: 0 byte(7)10,0 intern L1315 L1316: 0 byte(7)11,0 intern L1316 L1317: 0 byte(7)12,0 intern L1317 L1318: 0 byte(7)13,0 intern L1318 L1319: 0 byte(7)14,0 intern L1319 L1320: 0 byte(7)15,0 intern L1320 L1321: 0 byte(7)16,0 intern L1321 L1322: 0 byte(7)17,0 intern L1322 L1323: 0 byte(7)18,0 intern L1323 L1324: 0 byte(7)19,0 intern L1324 L1325: 0 byte(7)20,0 intern L1325 L1326: 0 byte(7)21,0 intern L1326 L1327: 0 byte(7)22,0 intern L1327 L1328: 0 byte(7)23,0 intern L1328 L1329: 0 byte(7)24,0 intern L1329 L1330: 0 byte(7)25,0 intern L1330 L1331: 0 byte(7)26,0 intern L1331 L1332: 0 byte(7)27,0 intern L1332 L1333: 0 byte(7)28,0 intern L1333 L1334: 0 byte(7)29,0 intern L1334 L1335: 0 byte(7)30,0 intern L1335 L1336: 0 byte(7)31,0 intern L1336 L1337: 0 byte(7)32,0 intern L1337 L1338: 0 byte(7)33,0 intern L1338 L1339: 0 byte(7)34,0 intern L1339 L1340: 0 byte(7)35,0 intern L1340 L1341: 0 byte(7)36,0 intern L1341 L1342: 0 byte(7)37,0 intern L1342 L1343: 0 byte(7)38,0 intern L1343 L1344: 0 byte(7)39,0 intern L1344 L1345: 0 byte(7)40,0 intern L1345 L1346: 0 byte(7)41,0 intern L1346 L1347: 0 byte(7)42,0 intern L1347 L1348: 0 byte(7)43,0 intern L1348 L1349: 0 byte(7)44,0 intern L1349 L1350: 0 byte(7)45,0 intern L1350 L1351: 0 byte(7)46,0 intern L1351 L1352: 0 byte(7)47,0 intern L1352 L1353: 0 byte(7)48,0 intern L1353 L1354: 0 byte(7)49,0 intern L1354 L1355: 0 byte(7)50,0 intern L1355 L1356: 0 byte(7)51,0 intern L1356 L1357: 0 byte(7)52,0 intern L1357 L1358: 0 byte(7)53,0 intern L1358 L1359: 0 byte(7)54,0 intern L1359 L1360: 0 byte(7)55,0 intern L1360 L1361: 0 byte(7)56,0 intern L1361 L1362: 0 byte(7)57,0 intern L1362 L1363: 0 byte(7)58,0 intern L1363 L1364: 0 byte(7)59,0 intern L1364 L1365: 0 byte(7)60,0 intern L1365 L1366: 0 byte(7)61,0 intern L1366 L1367: 0 byte(7)62,0 intern L1367 L1368: 0 byte(7)63,0 intern L1368 L1369: 0 byte(7)64,0 intern L1369 L1370: 0 byte(7)65,0 intern L1370 L1371: 0 byte(7)66,0 intern L1371 L1372: 0 byte(7)67,0 intern L1372 L1373: 0 byte(7)68,0 intern L1373 L1374: 0 byte(7)69,0 intern L1374 L1375: 0 byte(7)70,0 intern L1375 L1376: 0 byte(7)71,0 intern L1376 L1377: 0 byte(7)72,0 intern L1377 L1378: 0 byte(7)73,0 intern L1378 L1379: 0 byte(7)74,0 intern L1379 L1380: 0 byte(7)75,0 intern L1380 L1381: 0 byte(7)76,0 intern L1381 L1382: 0 byte(7)77,0 intern L1382 L1383: 0 byte(7)78,0 intern L1383 L1384: 0 byte(7)79,0 intern L1384 L1385: 0 byte(7)80,0 intern L1385 L1386: 0 byte(7)81,0 intern L1386 L1387: 0 byte(7)82,0 intern L1387 L1388: 0 byte(7)83,0 intern L1388 L1389: 0 byte(7)84,0 intern L1389 L1390: 0 byte(7)85,0 intern L1390 L1391: 0 byte(7)86,0 intern L1391 L1392: 0 byte(7)87,0 intern L1392 L1393: 0 byte(7)88,0 intern L1393 L1394: 0 byte(7)89,0 intern L1394 L1395: 0 byte(7)90,0 intern L1395 L1396: 0 byte(7)91,0 intern L1396 L1397: 0 byte(7)92,0 intern L1397 L1398: 0 byte(7)93,0 intern L1398 L1399: 0 byte(7)94,0 intern L1399 L1400: 0 byte(7)95,0 intern L1400 L1401: 0 byte(7)96,0 intern L1401 L1402: 0 byte(7)97,0 intern L1402 L1403: 0 byte(7)98,0 intern L1403 L1404: 0 byte(7)99,0 intern L1404 L1405: 0 byte(7)100,0 intern L1405 L1406: 0 byte(7)101,0 intern L1406 L1407: 0 byte(7)102,0 intern L1407 L1408: 0 byte(7)103,0 intern L1408 L1409: 0 byte(7)104,0 intern L1409 L1410: 0 byte(7)105,0 intern L1410 L1411: 0 byte(7)106,0 intern L1411 L1412: 0 byte(7)107,0 intern L1412 L1413: 0 byte(7)108,0 intern L1413 L1414: 0 byte(7)109,0 intern L1414 L1415: 0 byte(7)110,0 intern L1415 L1416: 0 byte(7)111,0 intern L1416 L1417: 0 byte(7)112,0 intern L1417 L1418: 0 byte(7)113,0 intern L1418 L1419: 0 byte(7)114,0 intern L1419 L1420: 0 byte(7)115,0 intern L1420 L1421: 0 byte(7)116,0 intern L1421 L1422: 0 byte(7)117,0 intern L1422 L1423: 0 byte(7)118,0 intern L1423 L1424: 0 byte(7)119,0 intern L1424 L1425: 0 byte(7)120,0 intern L1425 L1426: 0 byte(7)121,0 intern L1426 L1427: 0 byte(7)122,0 intern L1427 L1428: 0 byte(7)123,0 intern L1428 L1429: 0 byte(7)124,0 intern L1429 L1430: 0 byte(7)125,0 intern L1430 L1431: 0 byte(7)126,0 intern L1431 L1432: 0 byte(7)127,0 intern L1432 L1433: 2 byte(7)78,73,76,0 intern L1433 L1434: 6 byte(7)80,82,73,78,49,73,68,0 intern L1434 L1435: 7 byte(7)80,82,73,78,49,73,78,84,0 intern L1435 L1436: 10 byte(7)80,82,73,78,49,83,84,82,73,78,71,0 intern L1436 L1437: 8 byte(7)80,82,73,78,49,80,65,73,82,0 intern L1437 L1438: 5 byte(7)80,82,84,73,84,77,0 intern L1438 L1439: 4 byte(7)80,82,73,78,49,0 intern L1439 L1440: 6 byte(7)80,82,73,78,50,73,68,0 intern L1440 L1441: 10 byte(7)80,82,73,78,50,83,84,82,73,78,71,0 intern L1441 L1442: 8 byte(7)80,82,73,78,50,80,65,73,82,0 intern L1442 L1443: 4 byte(7)80,82,73,78,50,0 intern L1443 L1444: 5 byte(7)84,69,82,80,82,73,0 intern L1444 L1445: 4 byte(7)80,82,73,78,84,0 intern L1445 L1446: 5 byte(7)80,82,73,78,50,84,0 intern L1446 L1447: 3 byte(7)80,85,84,67,0 intern L1447 L1448: 5 byte(7)80,66,76,65,78,75,0 intern L1448 L1449: 8 byte(7)80,82,73,78,49,73,78,84,88,0 intern L1449 L1450: 6 byte(7)76,79,78,71,68,73,86,0 intern L1450 L1451: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L1451 L1452: 3 byte(7)66,89,84,69,0 intern L1452 L1453: 3 byte(7)81,85,73,84,0 intern L1453 L1454: 4 byte(7)69,82,82,79,82,0 intern L1454 L1455: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L1455 L1456: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L1456 L1457: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L1457 L1458: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L1458 L1459: 3 byte(7)79,85,84,42,0 intern L1459 L1460: 10 byte(7)69,82,82,79,82,72,69,65,68,69,82,0 intern L1460 L1461: 11 byte(7)69,82,82,79,82,84,82,65,73,76,69,82,0 intern L1461 L1462: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L1462 L1463: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L1463 L1464: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L1464 L1465: 5 byte(7)80,82,73,78,49,84,0 intern L1465 L1466: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L1466 L1467: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L1467 L1468: 1 byte(7)70,78,0 intern L1468 L1469: 7 byte(7)79,70,70,69,78,68,69,82,0 intern L1469 L1470: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L1470 L1471: 11 byte(7)76,65,77,66,73,78,68,65,82,71,83,42,0 intern L1471 L1472: 6 byte(7)76,65,77,66,73,78,68,0 intern L1472 L1473: 6 byte(7)85,78,66,73,78,68,78,0 intern L1473 L1474: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1474 L1475: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1475 L1476: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L1476 L1477: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L1477 L1478: 5 byte(7)71,84,72,69,65,80,0 intern L1478 L1479: 4 byte(7)71,84,83,84,82,0 intern L1479 L1480: 5 byte(7)71,84,86,69,67,84,0 intern L1480 L1481: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L1481 L1482: 3 byte(7)71,84,73,68,0 intern L1482 L1483: 7 byte(7)72,65,82,68,67,79,78,83,0 intern L1483 L1484: 3 byte(7)67,79,78,83,0 intern L1484 L1485: 4 byte(7)88,67,79,78,83,0 intern L1485 L1486: 4 byte(7)78,67,79,78,83,0 intern L1486 L1487: 5 byte(7)77,75,86,69,67,84,0 intern L1487 L1488: 4 byte(7)76,73,83,84,50,0 intern L1488 L1489: 4 byte(7)76,73,83,84,51,0 intern L1489 L1490: 4 byte(7)76,73,83,84,52,0 intern L1490 L1491: 4 byte(7)76,73,83,84,53,0 intern L1491 L1492: 6 byte(7)80,85,84,66,89,84,69,0 intern L1492 L1493: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L1493 L1494: 4 byte(7)69,81,83,84,82,0 intern L1494 L1495: 7 byte(7)73,78,73,84,82,69,65,68,0 intern L1495 L1496: 5 byte(7)42,82,65,73,83,69,0 intern L1496 L1497: 2 byte(7)67,72,42,0 intern L1497 L1498: 3 byte(7)84,79,75,42,0 intern L1498 L1499: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L1499 L1500: 4 byte(7)68,69,66,85,71,0 intern L1500 L1501: 7 byte(7)83,69,84,82,65,73,83,69,0 intern L1501 L1502: 9 byte(7)67,76,69,65,82,87,72,73,84,69,0 intern L1502 L1503: 11 byte(7)67,76,69,65,82,67,79,77,77,69,78,84,0 intern L1503 L1504: 6 byte(7)82,69,65,68,83,84,82,0 intern L1504 L1505: 5 byte(7)68,73,71,73,84,80,0 intern L1505 L1506: 6 byte(7)82,69,65,68,73,78,84,0 intern L1506 L1507: 8 byte(7)65,76,80,72,65,69,83,67,80,0 intern L1507 L1508: 5 byte(7)82,69,65,68,73,68,0 intern L1508 L1509: 4 byte(7)82,65,84,79,77,0 intern L1509 L1510: 5 byte(7)87,72,73,84,69,80,0 intern L1510 L1511: 3 byte(7)71,69,84,67,0 intern L1511 L1512: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L1512 L1513: 13 byte(7)66,85,70,70,69,82,84,79,83,84,82,73,78,71,0 intern L1513 L1514: 8 byte(7)82,65,73,83,69,67,72,65,82,0 intern L1514 L1515: 11 byte(7)65,76,80,72,65,78,85,77,69,83,67,80,0 intern L1515 L1516: 5 byte(7)73,78,84,69,82,78,0 intern L1516 L1517: 6 byte(7)69,83,67,65,80,69,80,0 intern L1517 L1518: 5 byte(7)65,76,80,72,65,80,0 intern L1518 L1519: 9 byte(7)76,79,87,69,82,67,65,83,69,80,0 intern L1519 L1520: 7 byte(7)76,79,79,75,85,80,73,68,0 intern L1520 L1521: 8 byte(7)73,78,73,84,78,69,87,73,68,0 intern L1521 L1522: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L1522 L1523: 9 byte(7)85,80,80,69,82,67,65,83,69,80,0 intern L1523 L1524: 8 byte(7)65,76,80,72,65,78,85,77,80,0 intern L1524 L1525: 4 byte(7)82,69,65,68,49,0 intern L1525 L1526: 3 byte(7)82,69,65,68,0 intern L1526 L1527: 7 byte(7)82,69,65,68,76,73,83,84,0 intern L1527 L1528: 4 byte(7)81,85,79,84,69,0 intern L1528 L1529: 6 byte(7)83,65,70,69,67,68,82,0 intern L1529 L1530: 9 byte(7)83,89,77,70,78,67,66,65,83,69,0 intern L1530 L1531: 5 byte(7)87,80,76,85,83,50,0 intern L1531 L1532: 5 byte(7)83,89,77,70,78,67,0 intern L1532 L1533: 6 byte(7)87,84,73,77,69,83,50,0 intern L1533 L1534: 29 byte(7)65,68,68,82,69,83,83,73,78,71,85,78,73,84,83,80,69,82,70,85,78,67,84,73,79,78,67,69,76,76,0 intern L1534 L1535: 16 byte(7)83,72,79,85,76,68,66,69,85,78,68,69,70,73,78,69,68,0 intern L1535 L1536: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L1536 L1537: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L1537 L1538: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L1538 L1539: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L1539 L1540: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L1540 L1541: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L1541 L1542: 5 byte(7)70,67,79,68,69,80,0 intern L1542 L1543: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L1543 L1544: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L1544 L1545: 12 byte(7)67,79,68,69,80,82,73,77,73,84,73,86,69,0 intern L1545 L1546: 7 byte(7)67,79,68,69,80,84,82,42,0 intern L1546 L1547: 12 byte(7)83,65,86,69,82,69,71,73,83,84,69,82,83,0 intern L1547 L1548: 8 byte(7)67,79,68,69,70,79,82,77,42,0 intern L1548 L1549: 8 byte(7)67,79,68,69,78,65,82,71,42,0 intern L1549 L1550: 28 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,0 intern L1550 L1551: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L1551 L1552: 14 byte(7)70,65,83,84,76,65,77,66,68,65,65,80,80,76,89,0 intern L1552 L1553: 5 byte(7)76,65,77,66,68,65,0 intern L1553 L1554: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L1554 L1555: 22 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,65,85,88,0 intern L1555 L1556: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L1556 L1557: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L1557 L1558: 15 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,65,85,88,0 intern L1558 L1559: 3 byte(7)69,86,65,76,0 intern L1559 L1560: 10 byte(7)66,73,78,68,69,86,65,76,65,85,88,0 intern L1560 L1561: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L1561 L1562: 5 byte(7)76,66,73,78,68,49,0 intern L1562 L1563: 2 byte(7)71,69,84,0 intern L1563 L1564: 31 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,65,85,88,0 intern L1564 L1565: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L1565 L1566: 5 byte(7)66,76,68,77,83,71,0 intern L1566 L1567: 6 byte(7)69,86,80,82,79,71,78,0 intern L1567 L1568: 6 byte(7)83,89,83,50,73,78,84,0 intern L1568 L1569: 4 byte(7)80,76,85,83,50,0 intern L1569 L1570: 4 byte(7)77,73,78,85,83,0 intern L1570 L1571: 4 byte(7)87,65,68,68,49,0 intern L1571 L1572: 3 byte(7)69,76,83,69,0 intern L1572 L1573: 3 byte(7)65,68,68,49,0 intern L1573 L1574: 4 byte(7)87,83,85,66,49,0 intern L1574 L1575: 3 byte(7)83,85,66,49,0 intern L1575 L1576: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L1576 L1577: 4 byte(7)76,69,83,83,80,0 intern L1577 L1578: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L1578 L1579: 5 byte(7)84,73,77,69,83,50,0 intern L1579 L1580: 2 byte(7)67,65,82,0 intern L1580 L1581: 2 byte(7)67,68,82,0 intern L1581 L1582: 3 byte(7)67,65,65,82,0 intern L1582 L1583: 3 byte(7)67,65,68,82,0 intern L1583 L1584: 3 byte(7)67,68,65,82,0 intern L1584 L1585: 3 byte(7)67,68,68,82,0 intern L1585 L1586: 3 byte(7)65,84,79,77,0 intern L1586 L1587: 5 byte(7)65,80,80,69,78,68,0 intern L1587 L1588: 3 byte(7)77,69,77,81,0 intern L1588 L1589: 6 byte(7)82,69,86,69,82,83,69,0 intern L1589 L1590: 4 byte(7)69,86,76,73,83,0 intern L1590 L1591: 4 byte(7)80,82,79,71,78,0 intern L1591 L1592: 5 byte(7)69,86,67,79,78,68,0 intern L1592 L1593: 3 byte(7)67,79,78,68,0 intern L1593 L1594: 2 byte(7)83,69,84,0 intern L1594 L1595: 3 byte(7)83,69,84,81,0 intern L1595 L1596: 3 byte(7)80,85,84,68,0 intern L1596 L1597: 1 byte(7)68,69,0 intern L1597 L1598: 3 byte(7)69,88,80,82,0 intern L1598 L1599: 1 byte(7)68,70,0 intern L1599 L1600: 4 byte(7)70,69,88,80,82,0 intern L1600 L1601: 1 byte(7)68,78,0 intern L1601 L1602: 4 byte(7)78,69,88,80,82,0 intern L1602 L1603: 1 byte(7)68,77,0 intern L1603 L1604: 4 byte(7)77,65,67,82,79,0 intern L1604 L1605: 3 byte(7)76,73,83,84,0 intern L1605 L1606: 4 byte(7)65,84,83,79,67,0 intern L1606 L1607: 2 byte(7)71,69,81,0 intern L1607 L1608: 2 byte(7)76,69,81,0 intern L1608 L1609: 4 byte(7)69,81,67,65,82,0 intern L1609 L1610: 3 byte(7)71,69,84,68,0 intern L1610 L1611: 4 byte(7)67,79,80,89,68,0 intern L1611 L1612: 5 byte(7)68,69,76,65,84,81,0 intern L1612 L1613: 2 byte(7)80,85,84,0 intern L1613 L1614: 7 byte(7)73,78,73,84,69,86,65,76,0 intern L1614 L1615: 4 byte(7)87,72,73,76,69,0 intern L1615 L1616: 4 byte(7)70,84,89,80,69,0 intern L1616 L1617: 6 byte(7)76,65,77,66,68,65,80,0 intern L1617 L1618: 8 byte(7)71,69,84,76,65,77,66,68,65,0 intern L1618 L1619: 14 byte(7)76,65,77,66,68,65,69,86,65,76,65,80,80,76,89,0 intern L1619 L1620: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L1620 L1621: 10 byte(7)76,65,77,66,68,65,65,80,80,76,89,0 intern L1621 L1622: 4 byte(7)65,80,80,76,89,0 intern L1622 L1623: 7 byte(7)68,79,76,65,77,66,68,65,0 intern L1623 L1624: 5 byte(7)76,69,78,71,84,72,0 intern L1624 L1625: 4 byte(7)67,79,68,69,80,0 intern L1625 L1626: 4 byte(7)80,65,73,82,80,0 intern L1626 L1627: 2 byte(7)73,68,80,0 intern L1627 L1628: 1 byte(7)69,81,0 intern L1628 L1629: 3 byte(7)78,85,76,76,0 intern L1629 L1630: 2 byte(7)78,79,84,0 intern L1630 L1631: 6 byte(7)76,69,78,71,84,72,49,0 intern L1631 L1632: 5 byte(7)77,65,80,79,66,76,0 intern L1632 L1633: 10 byte(7)80,82,73,78,84,70,69,88,80,82,83,0 intern L1633 L1634: 10 byte(7)80,82,73,78,84,49,70,69,88,80,82,0 intern L1634 L1635: 5 byte(7)70,69,88,80,82,80,0 intern L1635 L1636: 13 byte(7)80,82,73,78,84,70,85,78,67,84,73,79,78,83,0 intern L1636 L1637: 13 byte(7)80,82,73,78,84,49,70,85,78,67,84,73,79,78,0 intern L1637 L1638: 3 byte(7)80,82,79,80,0 intern L1638 L1639: 6 byte(7)82,69,77,80,82,79,80,0 intern L1639 L1640: 7 byte(7)83,89,83,50,70,73,88,78,0 intern L1640 L1641: 13 byte(7)73,78,70,83,84,65,82,84,73,78,71,66,73,84,0 intern L1641 L1642: 11 byte(7)73,78,70,66,73,84,76,69,78,71,84,72,0 intern L1642 L1643: 4 byte(7)82,69,83,69,84,0 intern L1643 L1644: 13 byte(7)66,83,84,65,67,75,79,86,69,82,70,76,79,87,0 intern L1644 L1645: 6 byte(7)69,82,82,79,85,84,42,0 intern L1645 L1646: 14 byte(7)66,83,84,65,67,75,85,78,68,69,82,70,76,79,87,0 intern L1646 L1647: 17 byte(7)67,65,80,84,85,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L1647 L1648: 17 byte(7)82,69,83,84,79,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L1648 L1649: 17 byte(7)37,67,76,69,65,82,45,67,65,84,67,72,45,83,84,65,67,75,0 intern L1649 L1650: 12 byte(7)67,76,69,65,82,66,73,78,68,73,78,71,83,0 intern L1650 L1651: 5 byte(7)80,66,73,78,68,49,0 intern L1651 L1652: 7 byte(7)80,82,79,71,66,73,78,68,0 intern L1652 L1653: 7 byte(7)73,78,73,84,72,69,65,80,0 intern L1653 L1654: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L1654 L1655: 4 byte(7)77,65,73,78,46,0 intern L1655 L1656: 3 byte(7)73,78,73,84,0 intern L1656 L1657: 2 byte(7)73,78,42,0 intern L1657 L1658: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L1658 L1659: 3 byte(7)84,73,77,67,0 intern L1659 L1660: 3 byte(7)68,65,84,69,0 intern L1660 L1661: 10 byte(7)86,69,82,83,73,79,78,78,65,77,69,0 intern L1661 L1662: 5 byte(7)80,85,84,73,78,84,0 intern L1662 L1663: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L1663 L1664: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L1664 L1665: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L1665 L1666: 3 byte(7)70,76,65,71,0 intern L1666 L1667: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L1667 L1668: 7 byte(7)72,69,65,80,73,78,70,79,0 intern L1668 L1669: 6 byte(7)82,69,67,76,65,73,77,0 intern L1669 L1670: 5 byte(7)83,80,65,67,69,68,0 intern L1670 L1671: 5 byte(7)68,65,83,72,69,68,0 intern L1671 L1672: 5 byte(7)68,79,84,84,69,68,0 intern L1672 L1673: 7 byte(7)83,72,79,85,76,68,66,69,0 intern L1673 L1674: 2 byte(7)73,78,70,0 intern L1674 L1675: 2 byte(7)84,65,71,0 intern L1675 L1676: 5 byte(7)77,75,73,84,69,77,0 intern L1676 L1677: 3 byte(7)84,73,77,69,0 intern L1677 L1678: 6 byte(7)70,85,78,67,65,76,76,0 intern L1678 L1679: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L1679 L1680: 4 byte(7)36,69,79,70,36,0 intern L1680 L1681: 10 byte(7)66,73,78,68,73,78,71,84,69,83,84,0 intern L1681 L1682: 9 byte(7)73,78,84,69,82,80,84,69,83,84,0 intern L1682 L1683: 11 byte(7)67,79,77,80,66,73,78,68,84,69,83,84,0 intern L1683 L1684: 9 byte(7)84,69,83,84,83,69,82,73,69,83,0 intern L1684 L1685: 1 byte(7)65,65,0 intern L1685 L1686: 8 byte(7)84,69,83,84,65,80,80,76,89,0 intern L1686 L1687: 11 byte(7)73,78,84,69,82,80,82,69,84,69,68,51,0 intern L1687 L1688: 2 byte(7)65,71,49,0 intern L1688 L1689: 1 byte(7)89,49,0 intern L1689 L1690: 1 byte(7)88,49,0 intern L1690 L1691: 2 byte(7)65,71,50,0 intern L1691 L1692: 1 byte(7)89,50,0 intern L1692 L1693: 1 byte(7)88,50,0 intern L1693 L1694: 2 byte(7)65,71,51,0 intern L1694 L1695: 1 byte(7)76,51,0 intern L1695 L1696: 1 byte(7)76,50,0 intern L1696 L1697: 1 byte(7)76,49,0 intern L1697 L1698: 6 byte(7)76,65,77,66,68,65,50,0 intern L1698 L1699: 6 byte(7)76,65,77,66,68,65,49,0 intern L1699 L1700: 11 byte(7)73,78,84,69,82,80,82,69,84,69,68,50,0 intern L1700 L1701: 1 byte(7)67,50,0 intern L1701 L1702: 8 byte(7)67,79,77,80,73,76,69,68,50,0 intern L1702 L1703: 8 byte(7)67,79,77,80,73,76,69,68,49,0 intern L1703 L1704: 1 byte(7)67,49,0 intern L1704 L1705: 12 byte(7)84,69,83,84,70,65,83,84,65,80,80,76,89,0 intern L1705 L1706: 8 byte(7)84,69,83,84,67,79,68,69,42,0 intern L1706 L1707: 5 byte(7)67,66,73,78,68,49,0 intern L1707 L1708: 3 byte(7)67,70,76,49,0 intern L1708 L1709: 3 byte(7)67,70,76,50,0 intern L1709 L1710: 3 byte(7)77,73,68,48,0 intern L1710 L1711: 3 byte(7)77,73,68,49,0 intern L1711 L1712: 3 byte(7)77,73,68,50,0 intern L1712 L1713: 3 byte(7)84,79,80,50,0 intern L1713 L1714: 3 byte(7)84,79,80,49,0 intern L1714 L1715: 5 byte(7)67,66,73,78,68,50,0 intern L1715 L1716: 3 byte(7)66,79,84,49,0 intern L1716 L1717: 3 byte(7)66,79,84,50,0 intern L1717 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/20-tests/main6.rel version [8d407a171a].
cannot compute difference between binary files
Added psl-1983/20-tests/main6.sym version [f909c4ec41].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR WQUOTIENT !%RECLAIM GTHEAP GTSTR GTVECT GTWARRAY GTID HARDCONS CONS XCONS NCONS MKVECT LIST2 LIST3 LIST4 LIST5 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP LOOKUPID INITNEWID MAKEFUNBOUND UPPERCASEP ALPHANUMP READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED FUNBOUNDP !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK BLDMSG EVPROGN SYS2INT PLUS2 MINUS WADD1 ELSE ADD1 WSUB1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAR CDR CAAR CADR CDAR CDDR ATOM APPEND MEMQ REVERSE EVLIS PROGN EVCOND COND SET SETQ PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO LIST ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE FTYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP PAIRP IDP EQ NULL NOT LENGTH1 MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION PROP REMPROP SYS2FIXN INFSTARTINGBIT INFBITLENGTH RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 PROGBIND))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 348)) (SETQ STRINGGENSYM!* (QUOTE "L1073")) (PUT (QUOTE INFBITLENGTH) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0643")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0237")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0321")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1006")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0325")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0569")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1029")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE FTYPE) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0515")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE WADD1) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0355")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0360")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0230")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0436")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0443") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0183")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0375")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0185")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1018")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0184")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0398")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0299")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0674")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0301")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 243)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0369")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WSUB1) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0370")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE LOOKUPID) (QUOTE ENTRYPOINT) (QUOTE "L0270")) (PUT (QUOTE LOOKUPID) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE RESET) (QUOTE ENTRYPOINT) (QUOTE RESET)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0660")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0425")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0192")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0287")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0263")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1007")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1032")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0634")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0603")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0471")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0647")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0186")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0330")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 244)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0191")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0297")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1015")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0291")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1014")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0665")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0620")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1010")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0646")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0614")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0402")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0679")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0607")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1013")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0222")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0339")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0642")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0604")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0437")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0371")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0483")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0429")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0224")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1019")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0509")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0334")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0241")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0295")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0350")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1005")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0310")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 241)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 198)) |
Added psl-1983/20-tests/main7.cmd version [f6857630df].
> > | 1 2 | main7,dmain7,sub7,Dsub7,sub6,Dsub6,sub5,Dsub5,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/main7.init version [9d3a918936].
> > > > > > | 1 2 3 4 5 6 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (GLOBAL (QUOTE (TESTGLOBALVAR))) |
Added psl-1983/20-tests/main7.mac version [cbf08f09dc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern HEAP extern L0183 extern L0184 extern L0185 extern L0186 extern BPS extern L1185 extern L1186 extern L1187 extern L1188 ; (!*ENTRY INITHEAP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR HEAPLOWERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPLOWERBOUND)) ; (MOVEM (REG T1) (WVAR HEAPLAST)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (MOVEM (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INITHEAP EXPR 0) L1189: intern L1189 MOVE 6,L0183 MOVEM 6,L0185 SETZM 1 MOVEM 1,L0186 POPJ 15,0 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 400) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L1190 MOVE 0,SYMVAL+128 HRRZI 12,400 SETZM 13 JRST SYMFNC+400 L1190: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+385 HRRZI 6,1 MOVEM 6,SYMVAL+154 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 391) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+385 JRST L1191 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L1191: MOVE 1,SYMVAL+385 HRRZI 12,391 HRRZI 13,1 JRST SYMFNC+391 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 152) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+154 CAIE 7,1 JRST L1192 PUSHJ 15,PUTC20 POPJ 15,0 L1192: MOVE 2,1 MOVE 1,SYMVAL+154 HRRZI 12,152 HRRZI 13,2 JRST SYMFNC+152 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY DATE EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "No-Date-Yet") (REG 1)) ; (MOVE (REG 1) (QUOTE "No-Date-Yet")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1194: 10 byte(7)78,111,45,68,97,116,101,45,89,101,116,0 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE MOVE 1,L1193 POPJ 15,0 L1193: <4_31>+L1194 ; (!*ENTRY VERSIONNAME EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "DEC-20 test system") (REG 1)) ; (MOVE (REG 1) (QUOTE "DEC-20 test system")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1196: 17 byte(7)68,69,67,45,50,48,32,116,101,115,116,32,115,121,115,116,101,109,0 0 ; (!*ENTRY VERSIONNAME EXPR 0) L1197: intern L1197 MOVE 1,L1195 POPJ 15,0 L1195: <4_31>+L1196 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*ALLOC 0) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L1198: intern L1198 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L1199: intern L1199 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L1200: intern L1200 MOVEM 12,SYMVAL+408 MOVEM 13,SYMVAL+409 JRST SYMFNC+249 ; (!*ENTRY FLAG EXPR 2) ; (!*ALLOC 0) ; (!*MOVE 2 (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINKE 0 ERR20 EXPR 1) extern ERR20 ; (PUSHJ (REG ST) (INTERNALENTRY ERR20)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 POPJ 15,0 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L1201: intern L1201 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L1202: intern L1202 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 411) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L1203: intern L1203 HRRZI 12,411 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY !%RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE " *** Dummy !%RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE " *** Dummy !%RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 412) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1205: 21 byte(7)32,42,42,42,32,68,117,109,109,121,32,33,37,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY !%RECLAIM EXPR 0) L1206: intern L1206 MOVE 1,L1204 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,412 SETZM 13 JRST SYMFNC+412 L1204: <4_31>+L1205 ; (!*ENTRY RECLAIM EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "*** Dummy RECLAIM: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Dummy RECLAIM: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINKE 0 HEAPINFO EXPR 0) ; (HRRZI (REG LINKREG) 412) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY HEAPINFO)) L1208: 18 byte(7)42,42,42,32,68,117,109,109,121,32,82,69,67,76,65,73,77,58,32,0 0 ; (!*ENTRY RECLAIM EXPR 0) L1209: intern L1209 MOVE 1,L1207 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,412 SETZM 13 JRST SYMFNC+412 L1207: <4_31>+L1208 ; (!*ENTRY HEAPINFO EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPLAST) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPLAST)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLOWERBOUND)) ; (SUB (REG 1) (WVAR HEAPLOWERBOUND)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items used, ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items used, ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPUPPERBOUND) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPUPPERBOUND)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLAST)) ; (SUB (REG 1) (WVAR HEAPLAST)) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " Items left.") (REG 1)) ; (MOVE (REG 1) (QUOTE " Items left.")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1212: 11 byte(7)32,73,116,101,109,115,32,108,101,102,116,46,0 L1213: 12 byte(7)32,73,116,101,109,115,32,117,115,101,100,44,32,0 0 ; (!*ENTRY HEAPINFO EXPR 0) L1214: intern L1214 HRRZI 2,1 MOVE 1,L0185 SUB 1,L0183 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1210 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 2,1 MOVE 1,L0184 SUB 1,L0185 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1211 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 SETZM 1 POPJ 15,0 L1211: <4_31>+L1212 L1210: <4_31>+L1213 ; (!*ENTRY SPACED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1216: 10 byte(7)32,32,32,32,32,32,32,32,32,32,32,0 1 ; (!*ENTRY SPACED EXPR 1) SPACED: intern SPACED PUSH 15,1 MOVE 1,L1215 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1215: <4_31>+L1216 ; (!*ENTRY DASHED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE "---------- ") (REG 1)) ; (MOVE (REG 1) (QUOTE "---------- ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1218: 10 byte(7)45,45,45,45,45,45,45,45,45,45,32,0 1 ; (!*ENTRY DASHED EXPR 1) DASHED: intern DASHED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1217 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1217: <4_31>+L1218 ; (!*ENTRY DOTTED EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " ....... ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1220: 10 byte(7)32,32,32,46,46,46,46,46,46,46,32,0 1 ; (!*ENTRY DOTTED EXPR 1) DOTTED: intern DOTTED PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1219 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1219: <4_31>+L1220 ; (!*ENTRY SHOULDBE EXPR 3) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE " ....... For ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ....... For ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " should be ") (REG 1)) ; (MOVE (REG 1) (QUOTE " should be ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAME (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE " [OK ]") (REG 1)) ; (MOVE (REG 1) (QUOTE " [OK ]")) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE " [BAD] *******") (REG 1)) ; (MOVE (REG 1) (QUOTE " [BAD] *******")) ; (!*LBL (LABEL G0006)) ; (!*LINKE 3 PRIN2T EXPR 1) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2T)) L1226: 15 byte(7)32,32,32,91,66,65,68,93,32,42,42,42,42,42,42,42,0 L1227: 6 byte(7)32,32,91,79,75,32,93,0 L1228: 10 byte(7)32,115,104,111,117,108,100,32,98,101,32,0 L1229: 0 byte(7)32,0 L1230: 14 byte(7)32,32,32,46,46,46,46,46,46,46,32,70,111,114,32,0 3 ; (!*ENTRY SHOULDBE EXPR 3) L1231: intern L1231 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,L1221 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1222 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1223 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 6,-1(15) CAME 6,-2(15) JRST L1232 MOVE 1,L1224 JRST L1233 L1232: MOVE 1,L1225 L1233: ADJSP 15,-3 HRRZI 12,141 HRRZI 13,1 JRST SYMFNC+141 L1225: <4_31>+L1226 L1224: <4_31>+L1227 L1223: <4_31>+L1228 L1222: <4_31>+L1229 L1221: <4_31>+L1230 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (!$FLUID UNDEFNNARG!*) (FRAME 2)) ; (MOVE (REG T1) (!$FLUID UNDEFNNARG!*)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*MOVE (!$FLUID UNDEFNCODE!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID UNDEFNCODE!*)) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE "Undefined Function ") (REG 1)) ; (MOVE (REG 1) (QUOTE "Undefined Function ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " called with ") (REG 1)) ; (MOVE (REG 1) (QUOTE " called with ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " args from compiled code") (REG 1)) ; (MOVE (REG 1) (QUOTE " args from compiled code")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L1237: 23 byte(7)32,97,114,103,115,32,102,114,111,109,32,99,111,109,112,105,108,101,100,32,99,111,100,101,0 L1238: 12 byte(7)32,99,97,108,108,101,100,32,119,105,116,104,32,0 L1239: 18 byte(7)85,110,100,101,102,105,110,101,100,32,70,117,110,99,116,105,111,110,32,0 0 ; (!*ENTRY UNDEFINEDFUNCTIONAUXAUX EXPR 0) L1240: intern L1240 ADJSP 15,2 MOVE 6,SYMVAL+409 MOVEM 6,-1(15) MOVE 1,SYMVAL+408 TLZ 1,253952 TLO 1,245760 MOVEM 1,0(15) MOVE 1,L1234 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1235 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1236 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L1236: <4_31>+L1237 L1235: <4_31>+L1238 L1234: <4_31>+L1239 ; (!*ENTRY INF EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY INF EXPR 1) INF: intern INF HRRZ 1,1 POPJ 15,0 ; (!*ENTRY TAG EXPR 1) ; (!*ALLOC 0) ; (!*FIELD (REG 1) (REG 1) (WCONST 0) (WCONST 5)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY TAG EXPR 1) TAG: intern TAG LDB 1,L1241 POPJ 15,0 L1241: point 5,1,4 ; (!*ENTRY MKITEM EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MKITEM (REG 1) (REG 3)) ; (DPB (REG 3) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 2 ; (!*ENTRY MKITEM EXPR 2) MKITEM: intern MKITEM MOVE 3,1 MOVE 1,2 DPB 3,L1242 POPJ 15,0 L1242: point 5,1,4 ; (!*ENTRY BLDMSG EXPR 7) ; (!*ALLOC 7) ; (ADJSP (REG ST) 7) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 4) (FRAME 4)) ; (MOVEM (REG 4) (INDEXED (REG ST) -3)) ; (!*MOVE (REG 5) (FRAME 5)) ; (MOVEM (REG 5) (INDEXED (REG ST) -4)) ; (!*MOVE (REG 6) (FRAME 6)) ; (HRRZI (REG T1) (IMMEDIATE (EXTRAREG 6))) ; (MOVEM (REG T1) (INDEXED (REG ST) -5)) ; (!*MOVE (REG 7) (FRAME 7)) ; (HRRZI (REG T1) (IMMEDIATE (EXTRAREG 7))) ; (MOVEM (REG T1) (INDEXED (REG ST) -6)) ; (!*MOVE (QUOTE "BldMsg called") (REG 1)) ; (MOVE (REG 1) (QUOTE "BldMsg called")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (FRAME 4) (REG 4)) ; (MOVE (REG 4) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LIST4 EXPR 4) ; (HRRZI (REG LINKREG) 185) ; (HRRZI (REG NARGREG) 4) ; (PUSHJ (REG ST) (ENTRY LIST4)) ; (!*LINKE 7 PRINT EXPR 1) ; (ADJSP (REG ST) (MINUS 7)) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRINT)) L1244: 12 byte(7)66,108,100,77,115,103,32,99,97,108,108,101,100,0 7 ; (!*ENTRY BLDMSG EXPR 7) BLDMSG: intern BLDMSG ADJSP 15,7 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVEM 5,-4(15) HRRZI 6,L0004+0 MOVEM 6,-5(15) HRRZI 6,L0004+1 MOVEM 6,-6(15) MOVE 1,L1243 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 4,-3(15) MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) HRRZI 12,185 HRRZI 13,4 PUSHJ 15,SYMFNC+185 ADJSP 15,-7 HRRZI 12,140 HRRZI 13,1 JRST SYMFNC+140 L1243: <4_31>+L1244 ; (!*ENTRY TIME EXPR 0) ; (!*ALLOC 0) ; (!*LINKE 0 TIMC EXPR 0) ; (HRRZI (REG LINKREG) 403) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY TIMC)) 0 ; (!*ENTRY TIME EXPR 0) TIME: intern TIME HRRZI 12,403 SETZM 13 JRST SYMFNC+403 ; (!*ENTRY FUNCALL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 3)) ; (MOVE (REG 3) (REG 2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*LINKE 0 IDAPPLY1 EXPR 2) ; (HRRZI (REG NARGREG) 1) ; (MOVE (REG LINKREG) (REG 2)) ; (JRST (INDEXED (REG 2) (WARRAY SYMFNC))) 2 ; (!*ENTRY FUNCALL EXPR 2) L1245: intern L1245 MOVE 3,2 MOVE 2,1 MOVE 1,3 HRRZI 13,1 MOVE 12,2 JRST SYMFNC(2) ; (!*ENTRY TESTSETUP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE 1000) (REG 1)) ; (HRRZI (REG 1) 1000) ; (!*LINK PREPARETEST EXPR 1) ; (HRRZI (REG LINKREG) 423) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PREPARETEST)) ; (!*MOVE (REG 1) (!$FLUID TESTLIST)) ; (MOVEM (REG 1) (!$FLUID TESTLIST)) ; (!*MOVE (QUOTE 2000) (REG 1)) ; (HRRZI (REG 1) 2000) ; (!*LINK PREPARETEST EXPR 1) ; (HRRZI (REG LINKREG) 423) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PREPARETEST)) ; (!*MOVE (REG 1) (!$FLUID TESTLIST2)) ; (MOVEM (REG 1) (!$FLUID TESTLIST2)) ; (!*LINK MAKELONGLIST EXPR 0) ; (HRRZI (REG LINKREG) 424) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY MAKELONGLIST)) ; (!*MOVE (QUOTE (SETQ FOO (CADR (QUOTE (1 2 3))))) (REG 1)) ; (MOVE (REG 1) (QUOTE (SETQ FOO (CADR (QUOTE (1 2 3)))))) ; (!*MOVE (REG 1) (!$FLUID EVALFORM)) ; (MOVEM (REG 1) (!$FLUID EVALFORM)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1247: <30_31>+290 <9_31>+L1248 L1248: <30_31>+425 <9_31>+L1249 L1249: <9_31>+L1250 <30_31>+128 L1250: <30_31>+278 <9_31>+L1251 L1251: <9_31>+L1252 <30_31>+128 L1252: <30_31>+223 <9_31>+L1253 L1253: <9_31>+L1254 <30_31>+128 L1254: 1 <9_31>+L1255 L1255: 2 <9_31>+L1256 L1256: 3 <30_31>+128 0 ; (!*ENTRY TESTSETUP EXPR 0) L1257: intern L1257 HRRZI 1,1000 HRRZI 12,423 HRRZI 13,1 PUSHJ 15,SYMFNC+423 MOVEM 1,SYMVAL+427 HRRZI 1,2000 HRRZI 12,423 HRRZI 13,1 PUSHJ 15,SYMFNC+423 MOVEM 1,SYMVAL+428 HRRZI 12,424 SETZM 13 PUSHJ 15,SYMFNC+424 MOVE 1,L1246 MOVEM 1,SYMVAL+429 POPJ 15,0 L1246: <9_31>+L1247 ; (!*ENTRY MAKELONGLIST EXPR 0) ; (!*ALLOC 1) ; (ADJSP (REG ST) 1) ; (!*MOVE (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)) (!$FLUID LONGLIST)) ; (MOVE (REG T1) (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))) ; (MOVEM (REG T1) (!$FLUID LONGLIST)) ; (!*MOVE (QUOTE 0) (FRAME 1)) ; (SETZM (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 1) (QUOTE 5)) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (CAIG (REG T1) 5) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID LONGLIST) (REG 2)) ; (MOVE (REG 2) (!$FLUID LONGLIST)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*LINK APPEND EXPR 2) ; (HRRZI (REG LINKREG) 282) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY APPEND)) ; (!*MOVE (REG 1) (!$FLUID LONGLIST)) ; (MOVEM (REG 1) (!$FLUID LONGLIST)) ; (!*WPLUS2 (FRAME 1) (WCONST 1)) ; (AOS (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) L1259: <30_31>+65 <9_31>+L1260 L1260: <30_31>+66 <9_31>+L1261 L1261: <30_31>+67 <9_31>+L1262 L1262: <30_31>+68 <9_31>+L1263 L1263: <30_31>+69 <9_31>+L1264 L1264: <30_31>+70 <9_31>+L1265 L1265: <30_31>+71 <9_31>+L1266 L1266: <30_31>+72 <9_31>+L1267 L1267: <30_31>+73 <9_31>+L1268 L1268: <30_31>+74 <9_31>+L1269 L1269: <30_31>+75 <9_31>+L1270 L1270: <30_31>+76 <9_31>+L1271 L1271: <30_31>+77 <9_31>+L1272 L1272: <30_31>+78 <9_31>+L1273 L1273: <30_31>+79 <9_31>+L1274 L1274: <30_31>+80 <9_31>+L1275 L1275: <30_31>+81 <9_31>+L1276 L1276: <30_31>+82 <9_31>+L1277 L1277: <30_31>+83 <9_31>+L1278 L1278: <30_31>+84 <9_31>+L1279 L1279: <30_31>+85 <9_31>+L1280 L1280: <30_31>+86 <9_31>+L1281 L1281: <30_31>+87 <9_31>+L1282 L1282: <30_31>+88 <9_31>+L1283 L1283: <30_31>+89 <9_31>+L1284 L1284: <30_31>+90 <30_31>+128 0 ; (!*ENTRY MAKELONGLIST EXPR 0) L1285: intern L1285 ADJSP 15,1 MOVE 6,L1258 MOVEM 6,SYMVAL+430 SETZM 0(15) L1286: MOVE 6,0(15) CAIG 6,5 JRST L1287 MOVE 1,0 JRST L1288 L1287: MOVE 2,SYMVAL+430 MOVE 1,2 HRRZI 12,282 HRRZI 13,2 PUSHJ 15,SYMFNC+282 MOVEM 1,SYMVAL+430 AOS 0(15) JRST L1286 L1288: ADJSP 15,-1 POPJ 15,0 L1258: <9_31>+L1259 ; (!*ENTRY PREPARETEST EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE -1) (FRAME 3)) ; (SETOM (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWGEQ (LABEL G0005) (FRAME 1) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (CAML (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LINK CONS EXPR 2) ; (HRRZI (REG LINKREG) 179) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CONS)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PREPARETEST EXPR 1) L1289: intern L1289 ADJSP 15,3 MOVEM 1,0(15) SETOM -2(15) MOVE 2,0 MOVEM 2,-1(15) L1290: MOVE 6,0(15) CAML 6,-2(15) JRST L1291 MOVE 1,-1(15) JRST L1292 L1291: AOS -2(15) MOVE 2,-1(15) MOVE 1,0 HRRZI 12,179 HRRZI 13,2 PUSHJ 15,SYMFNC+179 MOVEM 1,-1(15) JRST L1290 L1292: ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY CDR1TEST EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 4)) ; (MOVE (REG 4) (REG 1)) ; (!*MOVE (QUOTE -1) (REG 3)) ; (SETOM (REG 3)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 3) (WCONST 1)) ; (AOS (REG 3)) ; (!*MOVE (!$FLUID LONGLIST) (REG 2)) ; (MOVE (REG 2) (!$FLUID LONGLIST)) ; (!*JUMPWLEQ (LABEL G0005) (REG 3) (REG 4)) ; (CAMG (REG 3) (REG 4)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (REG 2)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPTYPE (LABEL G0005) (REG 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY CDR1TEST EXPR 1) L1294: intern L1294 MOVE 4,1 SETOM 3 L1295: AOS 3 MOVE 2,SYMVAL+430 CAMG 3,4 JRST L1296 MOVE 1,0 POPJ 15,0 L1296: MOVE 1,1(2) MOVE 2,1 LDB 11,L1293 CAIN 11,9 JRST L1296 JRST L1295 L1293: point 5,1,4 ; (!*ENTRY CDR2TEST EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 4)) ; (MOVE (REG 4) (REG 1)) ; (!*MOVE (QUOTE -1) (REG 3)) ; (SETOM (REG 3)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 3) (WCONST 1)) ; (AOS (REG 3)) ; (!*MOVE (!$FLUID LONGLIST) (REG 2)) ; (MOVE (REG 2) (!$FLUID LONGLIST)) ; (!*JUMPWLEQ (LABEL G0005) (REG 3) (REG 4)) ; (CAMG (REG 3) (REG 4)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (REG 2)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) 1 ; (!*ENTRY CDR2TEST EXPR 1) L1297: intern L1297 MOVE 4,1 SETOM 3 L1298: AOS 3 MOVE 2,SYMVAL+430 CAMG 3,4 JRST L1299 MOVE 1,0 POPJ 15,0 L1299: MOVE 1,1(2) MOVE 2,1 CAME 1,0 JRST L1299 JRST L1298 ; (!*ENTRY CDDRTEST EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 4)) ; (MOVE (REG 4) (REG 1)) ; (!*MOVE (QUOTE -1) (REG 3)) ; (SETOM (REG 3)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 3) (WCONST 1)) ; (AOS (REG 3)) ; (!*MOVE (!$FLUID LONGLIST) (REG 2)) ; (MOVE (REG 2) (!$FLUID LONGLIST)) ; (!*JUMPWLEQ (LABEL G0005) (REG 3) (REG 4)) ; (CAMG (REG 3) (REG 4)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (CDR (REG 2))) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 2) 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) 1 ; (!*ENTRY CDDRTEST EXPR 1) L1300: intern L1300 MOVE 4,1 SETOM 3 L1301: AOS 3 MOVE 2,SYMVAL+430 CAMG 3,4 JRST L1302 MOVE 1,0 POPJ 15,0 L1302: MOVE 1,1(2) MOVE 1,1(1) MOVE 2,1 CAME 1,0 JRST L1302 JRST L1301 ; (!*ENTRY LISTONLYCDRTEST1 EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (!$FLUID TESTLIST) (REG 4)) ; (MOVE (REG 4) (!$FLUID TESTLIST)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID TESTLIST) (REG 3)) ; (MOVE (REG 3) (!$FLUID TESTLIST)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (REG 3)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*MOVE (CDR (REG 4)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 4) 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 2) (QUOTE NIL)) ; (CAME (REG 2) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY LISTONLYCDRTEST1 EXPR 0) L1303: intern L1303 MOVE 4,SYMVAL+427 L1304: MOVE 3,SYMVAL+427 L1305: MOVE 1,1(3) MOVE 3,1 CAME 1,0 JRST L1305 MOVE 2,1(4) MOVE 4,2 CAME 2,0 JRST L1304 MOVE 1,0 POPJ 15,0 ; (!*ENTRY LISTONLYCDDRTEST1 EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (!$FLUID TESTLIST2) (REG 4)) ; (MOVE (REG 4) (!$FLUID TESTLIST2)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID TESTLIST2) (REG 3)) ; (MOVE (REG 3) (!$FLUID TESTLIST2)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (CDR (REG 3))) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*MOVE (CDR (CDR (REG 4))) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 4) 1)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 2) (QUOTE NIL)) ; (CAME (REG 2) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY LISTONLYCDDRTEST1 EXPR 0) L1306: intern L1306 MOVE 4,SYMVAL+428 L1307: MOVE 3,SYMVAL+428 L1308: MOVE 1,1(3) MOVE 1,1(1) MOVE 3,1 CAME 1,0 JRST L1308 MOVE 2,1(4) MOVE 2,1(2) MOVE 4,2 CAME 2,0 JRST L1307 MOVE 1,0 POPJ 15,0 ; (!*ENTRY LISTONLYCDRTEST2 EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (!$FLUID TESTLIST) (REG 4)) ; (MOVE (REG 4) (!$FLUID TESTLIST)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID TESTLIST) (REG 3)) ; (MOVE (REG 3) (!$FLUID TESTLIST)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (REG 3)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPTYPE (LABEL G0005) (REG 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (CDR (REG 4)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 4) 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*JUMPTYPE (LABEL G0004) (REG 2) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 2) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) ; (FULLWORD (FIELDPOINTER (REG 2) 0 5)) 0 ; (!*ENTRY LISTONLYCDRTEST2 EXPR 0) L1311: intern L1311 MOVE 4,SYMVAL+427 L1312: MOVE 3,SYMVAL+427 L1313: MOVE 1,1(3) MOVE 3,1 LDB 11,L1309 CAIN 11,9 JRST L1313 MOVE 2,1(4) MOVE 4,2 LDB 11,L1310 CAIN 11,9 JRST L1312 MOVE 1,0 POPJ 15,0 L1309: point 5,1,4 L1310: point 5,2,4 ; (!*ENTRY LISTONLYCDDRTEST2 EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (!$FLUID TESTLIST2) (REG 4)) ; (MOVE (REG 4) (!$FLUID TESTLIST2)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID TESTLIST2) (REG 3)) ; (MOVE (REG 3) (!$FLUID TESTLIST2)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (CDR (CDR (REG 3))) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPTYPE (LABEL G0005) (REG 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (CDR (CDR (REG 4))) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 4) 1)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*JUMPTYPE (LABEL G0004) (REG 2) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 2) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) ; (FULLWORD (FIELDPOINTER (REG 2) 0 5)) 0 ; (!*ENTRY LISTONLYCDDRTEST2 EXPR 0) L1316: intern L1316 MOVE 4,SYMVAL+428 L1317: MOVE 3,SYMVAL+428 L1318: MOVE 1,1(3) MOVE 1,1(1) MOVE 3,1 LDB 11,L1314 CAIN 11,9 JRST L1318 MOVE 2,1(4) MOVE 2,1(2) MOVE 4,2 LDB 11,L1315 CAIN 11,9 JRST L1317 MOVE 1,0 POPJ 15,0 L1314: point 5,1,4 L1315: point 5,2,4 ; (!*ENTRY EMPTYTEST EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (QUOTE 0) (REG 2)) ; (SETZM (REG 2)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (REG 2) (REG 3)) ; (CAMG (REG 2) (REG 3)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*WPLUS2 (REG 2) (WCONST 1)) ; (AOS (REG 2)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) 1 ; (!*ENTRY EMPTYTEST EXPR 1) L1319: intern L1319 MOVE 3,1 SETZM 2 L1320: CAMG 2,3 JRST L1321 MOVE 1,0 POPJ 15,0 L1321: AOS 2 JRST L1320 ; (!*ENTRY SLOWEMPTYTEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK GREATERP EXPR 2) ; (HRRZI (REG LINKREG) 271) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GREATERP)) ; (!*JUMPEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK ADD1 EXPR 1) ; (HRRZI (REG LINKREG) 268) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ADD1)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY SLOWEMPTYTEST EXPR 1) L1323: intern L1323 PUSH 15,L1322 PUSH 15,1 L1324: MOVE 2,0(15) MOVE 1,-1(15) HRRZI 12,271 HRRZI 13,2 PUSHJ 15,SYMFNC+271 CAMN 1,0 JRST L1325 MOVE 1,0 JRST L1326 L1325: MOVE 1,-1(15) HRRZI 12,268 HRRZI 13,1 PUSHJ 15,SYMFNC+268 MOVEM 1,-1(15) JRST L1324 L1326: ADJSP 15,-2 POPJ 15,0 L1322: 0 ; (!*ENTRY REVERSETEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID LONGLIST) (REG 1)) ; (MOVE (REG 1) (!$FLUID LONGLIST)) ; (!*LINK REVERSE EXPR 1) ; (HRRZI (REG LINKREG) 284) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY REVERSE)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY REVERSETEST EXPR 1) L1328: intern L1328 PUSH 15,L1327 PUSH 15,1 L1329: MOVE 6,-1(15) CAMG 6,0(15) JRST L1330 MOVE 1,0 JRST L1331 L1330: MOVE 1,SYMVAL+430 HRRZI 12,284 HRRZI 13,1 PUSHJ 15,SYMFNC+284 AOS -1(15) JRST L1329 L1331: ADJSP 15,-2 POPJ 15,0 L1327: 0 ; (!*ENTRY MYREVERSE1TEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID LONGLIST) (REG 1)) ; (MOVE (REG 1) (!$FLUID LONGLIST)) ; (!*LINK MYREVERSE1 EXPR 1) ; (HRRZI (REG LINKREG) 441) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MYREVERSE1)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY MYREVERSE1TEST EXPR 1) L1333: intern L1333 PUSH 15,L1332 PUSH 15,1 L1334: MOVE 6,-1(15) CAMG 6,0(15) JRST L1335 MOVE 1,0 JRST L1336 L1335: MOVE 1,SYMVAL+430 HRRZI 12,441 HRRZI 13,1 PUSHJ 15,SYMFNC+441 AOS -1(15) JRST L1334 L1336: ADJSP 15,-2 POPJ 15,0 L1332: 0 ; (!*ENTRY MYREVERSE1 EXPR 1) ; (!*PUSH (QUOTE NIL)) ; (PUSH (REG ST) (REG NIL)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPTYPE (LABEL G0005) (FRAME 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK CONS EXPR 2) ; (HRRZI (REG LINKREG) 179) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CONS)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (CDR (FRAME 1)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 2) (FRAME 1)) ; (MOVEM (REG 2) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)) 1 ; (!*ENTRY MYREVERSE1 EXPR 1) L1338: intern L1338 PUSH 15,0 PUSH 15,1 L1339: LDB 11,L1337 CAIN 11,9 JRST L1340 MOVE 1,-1(15) JRST L1341 L1340: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,179 HRRZI 13,2 PUSHJ 15,SYMFNC+179 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) JRST L1339 L1341: ADJSP 15,-2 POPJ 15,0 L1337: point 5,0(15),4 ; (!*ENTRY MYREVERSE2TEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID LONGLIST) (REG 1)) ; (MOVE (REG 1) (!$FLUID LONGLIST)) ; (!*LINK MYREVERSE2 EXPR 1) ; (HRRZI (REG LINKREG) 443) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MYREVERSE2)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY MYREVERSE2TEST EXPR 1) L1343: intern L1343 PUSH 15,L1342 PUSH 15,1 L1344: MOVE 6,-1(15) CAMG 6,0(15) JRST L1345 MOVE 1,0 JRST L1346 L1345: MOVE 1,SYMVAL+430 HRRZI 12,443 HRRZI 13,1 PUSHJ 15,SYMFNC+443 AOS -1(15) JRST L1344 L1346: ADJSP 15,-2 POPJ 15,0 L1342: 0 ; (!*ENTRY MYREVERSE2 EXPR 1) ; (!*PUSH (QUOTE NIL)) ; (PUSH (REG ST) (REG NIL)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0005) (FRAME 1) (QUOTE NIL)) ; (CAME (REG NIL) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK CONS EXPR 2) ; (HRRZI (REG LINKREG) 179) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CONS)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (CDR (FRAME 1)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 2) (FRAME 1)) ; (MOVEM (REG 2) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY MYREVERSE2 EXPR 1) L1347: intern L1347 PUSH 15,0 PUSH 15,1 L1348: CAME 0,0(15) JRST L1349 MOVE 1,-1(15) JRST L1350 L1349: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,179 HRRZI 13,2 PUSHJ 15,SYMFNC+179 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) JRST L1348 L1350: ADJSP 15,-2 POPJ 15,0 ; (!*ENTRY LENGTHTEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID LONGLIST) (REG 1)) ; (MOVE (REG 1) (!$FLUID LONGLIST)) ; (!*LINK LENGTH EXPR 1) ; (HRRZI (REG LINKREG) 319) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY LENGTH)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY LENGTHTEST EXPR 1) L1352: intern L1352 PUSH 15,L1351 PUSH 15,1 L1353: MOVE 6,-1(15) CAMG 6,0(15) JRST L1354 MOVE 1,0 JRST L1355 L1354: MOVE 1,SYMVAL+430 HRRZI 12,319 HRRZI 13,1 PUSHJ 15,SYMFNC+319 AOS -1(15) JRST L1353 L1355: ADJSP 15,-2 POPJ 15,0 L1351: 0 ; (!*ENTRY FACT EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPWGEQ (LABEL G0004) (REG 1) (QUOTE 2)) ; (CAIL (REG 1) 2) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 446) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY FACT)) ; (!*WTIMES2 (REG 1) (FRAME 1)) ; (IMUL (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY FACT EXPR 1) FACT: intern FACT PUSH 15,1 CAIL 1,2 JRST L1356 HRRZI 1,1 JRST L1357 L1356: SOS 1 HRRZI 12,446 HRRZI 13,1 PUSHJ 15,FACT IMUL 1,0(15) L1357: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY ARITHMETICTEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (QUOTE 9) (REG 1)) ; (HRRZI (REG 1) 9) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 446) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FACT)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY ARITHMETICTEST EXPR 1) L1359: intern L1359 PUSH 15,L1358 PUSH 15,1 L1360: MOVE 6,-1(15) CAMG 6,0(15) JRST L1361 MOVE 1,0 JRST L1362 L1361: HRRZI 1,9 HRRZI 12,446 HRRZI 13,1 PUSHJ 15,SYMFNC+446 AOS -1(15) JRST L1360 L1362: ADJSP 15,-2 POPJ 15,0 L1358: 0 ; (!*ENTRY EVALTEST EXPR 1) ; (!*PUSH (QUOTE 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (!$FLUID EVALFORM) (REG 1)) ; (MOVE (REG 1) (!$FLUID EVALFORM)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY EVALTEST EXPR 1) L1364: intern L1364 PUSH 15,L1363 PUSH 15,1 L1365: MOVE 6,-1(15) CAMG 6,0(15) JRST L1366 MOVE 1,0 JRST L1367 L1366: MOVE 1,SYMVAL+429 HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 AOS -1(15) JRST L1365 L1367: ADJSP 15,-2 POPJ 15,0 L1363: 0 ; (!*ENTRY TIMEEVAL EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK TIME EXPR 0) ; (HRRZI (REG LINKREG) 421) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIME)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*LINK TIME EXPR 0) ; (HRRZI (REG LINKREG) 421) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIME)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*LINKE 2 DIFFERENCE EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 273) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY DIFFERENCE)) 1 ; (!*ENTRY TIMEEVAL EXPR 1) L1368: intern L1368 ADJSP 15,2 MOVEM 1,0(15) HRRZI 12,421 SETZM 13 PUSHJ 15,SYMFNC+421 MOVEM 1,-1(15) MOVE 1,0(15) HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 HRRZI 12,421 SETZM 13 PUSHJ 15,SYMFNC+421 MOVE 2,-1(15) ADJSP 15,-2 HRRZI 12,273 HRRZI 13,2 JRST SYMFNC+273 ; (!*ENTRY TOPLEVELTAK EXPR 3) ; (!*ALLOC 0) ; (!*LINKE 0 TAK EXPR 3) ; (HRRZI (REG LINKREG) 450) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY TAK)) 3 ; (!*ENTRY TOPLEVELTAK EXPR 3) L1369: intern L1369 HRRZI 12,450 HRRZI 13,3 JRST SYMFNC+450 ; (!*ENTRY TAK EXPR 3) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*JUMPWLESSP (LABEL G0004) (REG 2) (REG 1)) ; (CAMGE (REG 2) (REG 1)) ; (JRST (LABEL G0004)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 450) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 450) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 5)) ; (MOVEM (REG 1) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 450) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 5) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY TAK EXPR 3) TAK: intern TAK ADJSP 15,5 L1370: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) CAMGE 2,1 JRST L1371 MOVE 1,3 JRST L1372 L1371: SOS 1 HRRZI 12,450 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-3(15) MOVE 3,0(15) MOVE 2,-2(15) MOVE 1,-1(15) SOS 1 HRRZI 12,450 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-4(15) MOVE 3,-1(15) MOVE 2,0(15) MOVE 1,-2(15) SOS 1 HRRZI 12,450 HRRZI 13,3 PUSHJ 15,TAK MOVE 3,1 MOVE 2,-4(15) MOVE 1,-3(15) JRST L1370 L1372: ADJSP 15,-5 POPJ 15,0 ; (!*ENTRY TOPLEVELGTAK EXPR 3) ; (!*ALLOC 0) ; (!*LINKE 0 GTAK EXPR 3) ; (HRRZI (REG LINKREG) 452) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY GTAK)) 3 ; (!*ENTRY TOPLEVELGTAK EXPR 3) L1373: intern L1373 HRRZI 12,452 HRRZI 13,3 JRST SYMFNC+452 ; (!*ENTRY GTAK EXPR 3) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK LESSP EXPR 2) ; (HRRZI (REG LINKREG) 272) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LESSP)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK SUB1 EXPR 1) ; (HRRZI (REG LINKREG) 270) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SUB1)) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*LINK GTAK EXPR 3) ; (HRRZI (REG LINKREG) 452) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY GTAK)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK SUB1 EXPR 1) ; (HRRZI (REG LINKREG) 270) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SUB1)) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*LINK GTAK EXPR 3) ; (HRRZI (REG LINKREG) 452) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY GTAK)) ; (!*MOVE (REG 1) (FRAME 5)) ; (MOVEM (REG 1) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK SUB1 EXPR 1) ; (HRRZI (REG LINKREG) 270) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SUB1)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINK GTAK EXPR 3) ; (HRRZI (REG LINKREG) 452) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY GTAK)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 5) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY GTAK EXPR 3) GTAK: intern GTAK ADJSP 15,5 L1374: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 2,1 MOVE 1,-1(15) HRRZI 12,272 HRRZI 13,2 PUSHJ 15,SYMFNC+272 CAME 1,0 JRST L1375 MOVE 1,-2(15) JRST L1376 L1375: MOVE 1,0(15) HRRZI 12,270 HRRZI 13,1 PUSHJ 15,SYMFNC+270 MOVE 3,-2(15) MOVE 2,-1(15) HRRZI 12,452 HRRZI 13,3 PUSHJ 15,GTAK MOVEM 1,-3(15) MOVE 1,-1(15) HRRZI 12,270 HRRZI 13,1 PUSHJ 15,SYMFNC+270 MOVE 3,0(15) MOVE 2,-2(15) HRRZI 12,452 HRRZI 13,3 PUSHJ 15,GTAK MOVEM 1,-4(15) MOVE 1,-2(15) HRRZI 12,270 HRRZI 13,1 PUSHJ 15,SYMFNC+270 MOVE 3,-1(15) MOVE 2,0(15) HRRZI 12,452 HRRZI 13,3 PUSHJ 15,GTAK MOVE 3,1 MOVE 2,-4(15) MOVE 1,-3(15) JRST L1374 L1376: ADJSP 15,-5 POPJ 15,0 ; (!*ENTRY GTSTA EXPR 1) ; (!*PUSH (QUOTE 1)) ; (PUSH (REG ST) (LIT (FULLWORD 1))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (QUOTE 100000)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIG (REG T1) 100000) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 2) (REG T1)) ; (MOVE (REG T1) (REG 2)) ; (!*LINK FASTAPPLY EXPR 1) ; (HRRZI (REG LINKREG) 246) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FASTAPPLY)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 1) 1 ; (!*ENTRY GTSTA EXPR 1) GTSTA: intern GTSTA PUSH 15,L1377 PUSH 15,1 L1378: MOVE 6,-1(15) CAIG 6,100000 JRST L1379 MOVE 1,0 JRST L1380 L1379: MOVE 2,0(15) MOVE 1,-1(15) MOVE 6,2 HRRZI 12,246 HRRZI 13,1 PUSHJ 15,SYMFNC+246 AOS -1(15) JRST L1378 L1380: ADJSP 15,-2 POPJ 15,0 L1377: 1 ; (!*ENTRY GTSTB EXPR 1) ; (!*PUSH (QUOTE 1)) ; (PUSH (REG ST) (LIT (FULLWORD 1))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (QUOTE 100000)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAIG (REG T1) 100000) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 2) (REG T1)) ; (MOVE (REG T1) (REG 2)) ; (!*LINK FASTAPPLY EXPR 1) ; (HRRZI (REG LINKREG) 246) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FASTAPPLY)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 1) 1 ; (!*ENTRY GTSTB EXPR 1) GTSTB: intern GTSTB PUSH 15,L1381 PUSH 15,1 L1382: MOVE 6,-1(15) CAIG 6,100000 JRST L1383 MOVE 1,0 JRST L1384 L1383: MOVE 2,0(15) MOVE 1,-1(15) MOVE 6,2 HRRZI 12,246 HRRZI 13,1 PUSHJ 15,SYMFNC+246 AOS -1(15) JRST L1382 L1384: ADJSP 15,-2 POPJ 15,0 L1381: 1 ; (!*ENTRY G0 EXPR 1) ; (!*ALLOC 0) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY G0 EXPR 1) G0: intern G0 POPJ 15,0 ; (!*ENTRY G1 EXPR 1) ; (!*ALLOC 0) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY G1 EXPR 1) G1: intern G1 AOS 1 POPJ 15,0 ; (!*ENTRY NREVERSE EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*LINKE 0 NRECONC EXPR 2) ; (HRRZI (REG LINKREG) 458) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY NRECONC)) 1 ; (!*ENTRY NREVERSE EXPR 1) L1385: intern L1385 MOVE 2,0 HRRZI 12,458 HRRZI 13,2 JRST SYMFNC+458 ; (!*ENTRY NRECONC EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*MOVE (QUOTE NIL) (REG 3)) ; (MOVE (REG 3) (REG NIL)) ; (!*LBL (LABEL G0004)) ; (!*JUMPTYPE (LABEL G0005) (REG 5) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 5) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (REG 4) (REG 1)) ; (MOVE (REG 1) (REG 4)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*MOVE (REG 5) (REG 3)) ; (MOVE (REG 3) (REG 5)) ; (!*MOVE (CDR (REG 5)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 5) 1)) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*MOVE (REG 3) (REG 2)) ; (MOVE (REG 2) (REG 3)) ; (!*MOVE (REG 4) (CDR (REG 2))) ; (MOVEM (REG 4) (INDEXED (REG 2) 1)) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (FULLWORD (FIELDPOINTER (REG 5) 0 5)) 2 ; (!*ENTRY NRECONC EXPR 2) L1387: intern L1387 MOVE 5,1 MOVE 4,2 MOVE 3,0 L1388: LDB 11,L1386 CAIN 11,9 JRST L1389 MOVE 1,4 POPJ 15,0 L1389: MOVE 3,5 MOVE 1,1(5) MOVE 5,1 MOVE 2,3 MOVEM 4,1(2) MOVE 4,2 JRST L1388 L1386: point 5,5,4 ; (!*ENTRY NNILS EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 3) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LINK CONS EXPR 2) ; (HRRZI (REG LINKREG) 179) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CONS)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY NNILS EXPR 1) NNILS: intern NNILS ADJSP 15,3 MOVEM 1,0(15) MOVEM 0,-1(15) SETZM -2(15) L1390: MOVE 6,-2(15) CAMG 6,0(15) JRST L1391 MOVE 1,-1(15) JRST L1392 L1391: MOVE 2,-1(15) MOVE 1,0 HRRZI 12,179 HRRZI 13,2 PUSHJ 15,SYMFNC+179 MOVEM 1,-1(15) AOS -2(15) JRST L1390 L1392: ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY NILS EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK NNILS EXPR 1) ; (HRRZI (REG LINKREG) 460) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY NNILS)) ; (!*MOVE (REG 1) (!$GLOBAL TESTGLOBALVAR)) ; (MOVEM (REG 1) (!$GLOBAL TESTGLOBALVAR)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY NILS EXPR 1) NILS: intern NILS PUSH 15,1 HRRZI 12,460 HRRZI 13,1 PUSHJ 15,SYMFNC+460 MOVEM 1,SYMVAL+462 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY NR EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (!$GLOBAL TESTGLOBALVAR) (REG 1)) ; (MOVE (REG 1) (!$GLOBAL TESTGLOBALVAR)) ; (!*LINK NREVERSE EXPR 1) ; (HRRZI (REG LINKREG) 459) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY NREVERSE)) ; (!*MOVE (REG 1) (!$GLOBAL TESTGLOBALVAR)) ; (MOVEM (REG 1) (!$GLOBAL TESTGLOBALVAR)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY NR EXPR 0) NR: intern NR MOVE 1,SYMVAL+462 HRRZI 12,459 HRRZI 13,1 PUSHJ 15,SYMFNC+459 MOVEM 1,SYMVAL+462 MOVE 1,0 POPJ 15,0 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (QUOTE NIL) (FRAME 1)) ; (MOVEM (REG NIL) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 402) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*LINK INITHEAP EXPR 0) ; (HRRZI (REG LINKREG) 399) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITHEAP)) ; (!*LINK INITEVAL EXPR 0) ; (HRRZI (REG LINKREG) 309) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITEVAL)) ; (!*MOVE (QUOTE "MINI-PSL with File I/O") (REG 1)) ; (MOVE (REG 1) (QUOTE "MINI-PSL with File I/O")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " Type (IOTEST) to test basic file I/O") (REG 1)) ; (MOVE (REG 1) (QUOTE " Type (IOTEST) to test basic file I/O")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " Future tests will be READ in this way") (REG 1)) ; (MOVE (REG 1) (QUOTE " Future tests will be READ in this way")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE " !*RAISE and !*PVAL set T") (REG 1)) ; (MOVE (REG 1) (QUOTE " !*RAISE and !*PVAL set T")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (!$FLUID DEBUG)) ; (MOVEM (REG 1) (!$FLUID DEBUG)) ; (!*LINK INITREAD EXPR 0) ; (HRRZI (REG LINKREG) 190) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITREAD)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*MOVE (REG 1) (!$FLUID !*RAISE)) ; (MOVEM (REG 1) (!$FLUID !*RAISE)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*MOVE (REG 1) (!$FLUID !*PVAL)) ; (MOVEM (REG 1) (!$FLUID !*PVAL)) ; (!*MOVE (WCONST 26) (REG 1)) ; (HRRZI (REG 1) 26) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (!$FLUID !$EOF!$)) ; (MOVEM (REG 1) (!$FLUID !$EOF!$)) ; (!*MOVE (QUOTE " .... Now we test INITCODE") (REG 1)) ; (MOVE (REG 1) (QUOTE " .... Now we test INITCODE")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK INITCODE EXPR 0) ; (HRRZI (REG LINKREG) 464) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INITCODE)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LINK CLEARIO EXPR 0) ; (HRRZI (REG LINKREG) 396) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY CLEARIO)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTEQ (LABEL G0004) (FRAME 2) (QUOTE NIL)) ; (CAME (REG NIL) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0004)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " lisp> ") (REG 1)) ; (MOVE (REG 1) (QUOTE " lisp> ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTEQ (LABEL G0011) (REG 1) (!$GLOBAL !$EOF!$)) ; (CAME (REG 1) (!$GLOBAL !$EOF!$)) ; (JRST (LABEL G0011)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE " *** Top Level EOF *** ") (REG 1)) ; (MOVE (REG 1) (QUOTE " *** Top Level EOF *** ")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0011)) ; (!*JUMPNOTEQ (LABEL G0012) (REG 1) (QUOTE QUIT)) ; (CAME (REG 1) (QUOTE QUIT)) ; (JRST (LABEL G0012)) ; (!*MOVE (QUOTE T) (FRAME 2)) ; (MOVE (REG T1) (FLUID T)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0012)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPEQ (LABEL G0005) (QUOTE NIL) (!$FLUID !*PVAL)) ; (CAMN (REG NIL) (!$FLUID !*PVAL)) ; (JRST (LABEL G0005)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) L1401: 22 byte(7)32,42,42,42,32,84,111,112,32,76,101,118,101,108,32,69,79,70,32,42,42,42,32,0 L1402: 6 byte(7)32,108,105,115,112,62,32,0 L1403: 25 byte(7)32,46,46,46,46,32,78,111,119,32,119,101,32,116,101,115,116,32,73,78,73,84,67,79,68,69,0 L1404: 26 byte(7)32,32,32,33,42,82,65,73,83,69,32,97,110,100,32,33,42,80,86,65,76,32,115,101,116,32,84,0 L1405: 39 byte(7)32,32,32,70,117,116,117,114,101,32,116,101,115,116,115,32,119,105,108,108,32,98,101,32,82,69,65,68,32,105,110,32,116,104,105,115,32,119,97,121,0 L1406: 38 byte(7)32,32,32,84,121,112,101,32,40,73,79,84,69,83,84,41,32,116,111,32,116,101,115,116,32,98,97,115,105,99,32,102,105,108,101,32,73,47,79,0 L1407: 21 byte(7)77,73,78,73,45,80,83,76,32,119,105,116,104,32,70,105,108,101,32,73,47,79,0 0 ; (!*ENTRY FIRSTCALL EXPR 0) L1408: intern L1408 ADJSP 15,3 MOVEM 0,0(15) MOVEM 0,-1(15) HRRZI 12,402 SETZM 13 PUSHJ 15,SYMFNC+402 HRRZI 12,399 SETZM 13 PUSHJ 15,SYMFNC+399 HRRZI 12,309 SETZM 13 PUSHJ 15,SYMFNC+309 MOVE 1,L1393 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1394 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1395 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,L1396 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,0 MOVEM 1,SYMVAL+195 HRRZI 12,190 SETZM 13 PUSHJ 15,SYMFNC+190 MOVE 1,SYMVAL+84 MOVEM 1,SYMVAL+191 MOVE 1,SYMVAL+84 MOVEM 1,SYMVAL+378 HRRZI 1,26 TLZ 1,253952 TLO 1,245760 MOVEM 1,SYMVAL+377 MOVE 1,L1397 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,464 SETZM 13 PUSHJ 15,SYMFNC+464 SETZM SYMVAL+385 HRRZI 6,1 MOVEM 6,SYMVAL+154 SETZM -2(15) HRRZI 12,396 SETZM 13 PUSHJ 15,SYMFNC+396 L1409: CAME 0,-1(15) JRST L1410 AOS -2(15) MOVE 1,-2(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1398 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,0(15) CAME 1,SYMVAL+377 JRST L1411 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,L1399 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 JRST L1409 L1411: CAME 1,L1400 JRST L1412 MOVE 6,SYMVAL+84 MOVEM 6,-1(15) JRST L1409 L1412: HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0(15) HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 MOVEM 1,0(15) CAMN 0,SYMVAL+378 JRST L1409 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 JRST L1409 L1410: HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1400: <30_31>+148 L1399: <4_31>+L1401 L1398: <4_31>+L1402 L1397: <4_31>+L1403 L1396: <4_31>+L1404 L1395: <4_31>+L1405 L1394: <4_31>+L1406 L1393: <4_31>+L1407 ; (!*ENTRY IOTEST EXPR 0) ; (!*ALLOC 6) ; (ADJSP (REG ST) 6) ; (!*MOVE (QUOTE NIL) (FRAME 1)) ; (MOVEM (REG NIL) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (FRAME 3)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE NIL) (FRAME 4)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -3)) ; (!*MOVE (QUOTE NIL) (FRAME 6)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -5)) ; (!*MOVE (QUOTE "---- Test of File IO") (REG 1)) ; (MOVE (REG 1) (QUOTE "---- Test of File IO")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE 0) (!$GLOBAL IN!*)) ; (SETZM (!$GLOBAL IN!*)) ; (!*MOVE (QUOTE 1) (!$GLOBAL OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$GLOBAL OUT!*)) ; (!*MOVE (QUOTE " Test CLEARIO") (REG 1)) ; (MOVE (REG 1) (QUOTE " Test CLEARIO")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE " Input String for Input File") (REG 1)) ; (MOVE (REG 1) (QUOTE " Input String for Input File")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 5)) ; (MOVEM (REG 1) (INDEXED (REG ST) -4)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*JUMPNOTTYPE (LABEL G0004) (FRAME 5) STR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -4) 0 5)))) ; (CAIE (REG T6) 4) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (QUOTE " Input String for OutPut File") (REG 1)) ; (MOVE (REG 1) (QUOTE " Input String for OutPut File")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 6)) ; (MOVEM (REG 1) (INDEXED (REG ST) -5)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*JUMPNOTTYPE (LABEL G0005) (FRAME 6) STR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -5) 0 5)))) ; (CAIE (REG T6) 4) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE INPUT) (REG 2)) ; (MOVE (REG 2) (QUOTE INPUT)) ; (!*MOVE (FRAME 5) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -4)) ; (!*LINK OPEN EXPR 2) ; (HRRZI (REG LINKREG) 372) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY OPEN)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE " Input File Opened on ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Input File Opened on ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE ", copy to TTY ") (REG 1)) ; (MOVE (REG 1) (QUOTE ", copy to TTY ")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LBL (LABEL G0016)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 391) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY INDEPENDENTREADCHAR)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*JUMPEQ (LABEL G0015) (REG 1) (QUOTE 26)) ; (CAIN (REG 1) 26) ; (JRST (LABEL G0015)) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*JUMP (LABEL G0016)) ; (JRST (LABEL G0016)) ; (!*LBL (LABEL G0015)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK CLOSE EXPR 1) ; (HRRZI (REG LINKREG) 373) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY CLOSE)) ; (!*MOVE (QUOTE " File Closed, Input test done") (REG 1)) ; (MOVE (REG 1) (QUOTE " File Closed, Input test done")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE INPUT) (REG 2)) ; (MOVE (REG 2) (QUOTE INPUT)) ; (!*MOVE (FRAME 5) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -4)) ; (!*LINK OPEN EXPR 2) ; (HRRZI (REG LINKREG) 372) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY OPEN)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE OUTPUT) (REG 2)) ; (MOVE (REG 2) (QUOTE OUTPUT)) ; (!*MOVE (FRAME 6) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -5)) ; (!*LINK OPEN EXPR 2) ; (HRRZI (REG LINKREG) 372) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY OPEN)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE " Input File on ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Input File on ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE ", copy to Output File on") (REG 1)) ; (MOVE (REG 1) (QUOTE ", copy to Output File on")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LBL (LABEL G0024)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 391) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY INDEPENDENTREADCHAR)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*JUMPEQ (LABEL G0023) (REG 1) (QUOTE 26)) ; (CAIN (REG 1) 26) ; (JRST (LABEL G0023)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 152) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY INDEPENDENTWRITECHAR)) ; (!*JUMP (LABEL G0024)) ; (JRST (LABEL G0024)) ; (!*LBL (LABEL G0023)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK CLOSE EXPR 1) ; (HRRZI (REG LINKREG) 373) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY CLOSE)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK CLOSE EXPR 1) ; (HRRZI (REG LINKREG) 373) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY CLOSE)) ; (!*MOVE (QUOTE "Both Files Closed, Inspect File:") (REG 1)) ; (MOVE (REG 1) (QUOTE "Both Files Closed, Inspect File:")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 6) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -5)) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 6) ; (ADJSP (REG ST) (MINUS 6)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -4) 0 5)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -5) 0 5)) L1427: 31 byte(7)66,111,116,104,32,70,105,108,101,115,32,67,108,111,115,101,100,44,32,73,110,115,112,101,99,116,32,70,105,108,101,58,0 L1428: 23 byte(7)44,32,99,111,112,121,32,116,111,32,79,117,116,112,117,116,32,70,105,108,101,32,111,110,0 L1429: 20 byte(7)32,32,32,32,32,32,73,110,112,117,116,32,70,105,108,101,32,32,111,110,32,0 L1430: 32 byte(7)32,32,32,32,32,70,105,108,101,32,67,108,111,115,101,100,44,32,73,110,112,117,116,32,116,101,115,116,32,100,111,110,101,0 L1431: 13 byte(7)44,32,99,111,112,121,32,116,111,32,84,84,89,32,0 L1432: 26 byte(7)32,32,32,32,32,32,73,110,112,117,116,32,70,105,108,101,32,79,112,101,110,101,100,32,111,110,32,0 L1433: 32 byte(7)32,32,32,32,32,73,110,112,117,116,32,83,116,114,105,110,103,32,102,111,114,32,79,117,116,80,117,116,32,70,105,108,101,0 L1434: 31 byte(7)32,32,32,32,32,73,110,112,117,116,32,83,116,114,105,110,103,32,102,111,114,32,73,110,112,117,116,32,70,105,108,101,0 L1435: 16 byte(7)32,32,32,32,32,84,101,115,116,32,67,76,69,65,82,73,79,0 L1436: 19 byte(7)45,45,45,45,32,84,101,115,116,32,111,102,32,70,105,108,101,32,73,79,0 0 ; (!*ENTRY IOTEST EXPR 0) IOTEST: intern IOTEST ADJSP 15,6 MOVEM 0,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-5(15) MOVE 1,L1413 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 SETZM SYMVAL+385 HRRZI 6,1 MOVEM 6,SYMVAL+154 MOVE 1,L1414 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 L1437: MOVE 1,L1415 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,-4(15) HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 LDB 11,L1416 CAIE 11,4 JRST L1437 L1438: MOVE 1,L1417 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,-5(15) HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 LDB 11,L1418 CAIE 11,4 JRST L1438 MOVE 2,L1419 MOVE 1,-4(15) HRRZI 12,372 HRRZI 13,2 PUSHJ 15,SYMFNC+372 MOVEM 1,0(15) MOVE 1,L1420 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1421 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 L1439: MOVE 1,0(15) HRRZI 12,391 HRRZI 13,1 PUSHJ 15,SYMFNC+391 MOVEM 1,-2(15) CAIN 1,26 JRST L1440 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 JRST L1439 L1440: MOVE 1,0(15) HRRZI 12,373 HRRZI 13,1 PUSHJ 15,SYMFNC+373 MOVE 1,L1422 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 2,L1419 MOVE 1,-4(15) HRRZI 12,372 HRRZI 13,2 PUSHJ 15,SYMFNC+372 MOVEM 1,0(15) MOVE 2,L1423 MOVE 1,-5(15) HRRZI 12,372 HRRZI 13,2 PUSHJ 15,SYMFNC+372 MOVEM 1,-1(15) MOVE 1,L1424 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L1425 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 L1441: MOVE 1,0(15) HRRZI 12,391 HRRZI 13,1 PUSHJ 15,SYMFNC+391 MOVEM 1,-2(15) CAIN 1,26 JRST L1442 MOVE 2,1 MOVE 1,-1(15) HRRZI 12,152 HRRZI 13,2 PUSHJ 15,SYMFNC+152 JRST L1441 L1442: MOVE 1,0(15) HRRZI 12,373 HRRZI 13,1 PUSHJ 15,SYMFNC+373 MOVE 1,-1(15) HRRZI 12,373 HRRZI 13,1 PUSHJ 15,SYMFNC+373 MOVE 1,L1426 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-5(15) HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 MOVE 1,0 ADJSP 15,-6 POPJ 15,0 L1416: point 5,-4(15),4 L1418: point 5,-5(15),4 L1426: <4_31>+L1427 L1425: <4_31>+L1428 L1424: <4_31>+L1429 L1423: <30_31>+383 L1422: <4_31>+L1430 L1421: <4_31>+L1431 L1420: <4_31>+L1432 L1419: <30_31>+375 L1417: <4_31>+L1433 L1415: <4_31>+L1434 L1414: <4_31>+L1435 L1413: <4_31>+L1436 0 ; (!*ENTRY INITCODE EXPR 0) L1443: intern L1443 HRRZI 1,15 HRRZI 12,176 HRRZI 13,1 PUSHJ 15,SYMFNC+176 MOVEM 1,SYMVAL+166 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L1444: 0 byte(7)0,0 intern L1444 L1445: 0 byte(7)1,0 intern L1445 L1446: 0 byte(7)2,0 intern L1446 L1447: 0 byte(7)3,0 intern L1447 L1448: 0 byte(7)4,0 intern L1448 L1449: 0 byte(7)5,0 intern L1449 L1450: 0 byte(7)6,0 intern L1450 L1451: 0 byte(7)7,0 intern L1451 L1452: 0 byte(7)8,0 intern L1452 L1453: 0 byte(7)9,0 intern L1453 L1454: 0 byte(7)10,0 intern L1454 L1455: 0 byte(7)11,0 intern L1455 L1456: 0 byte(7)12,0 intern L1456 L1457: 0 byte(7)13,0 intern L1457 L1458: 0 byte(7)14,0 intern L1458 L1459: 0 byte(7)15,0 intern L1459 L1460: 0 byte(7)16,0 intern L1460 L1461: 0 byte(7)17,0 intern L1461 L1462: 0 byte(7)18,0 intern L1462 L1463: 0 byte(7)19,0 intern L1463 L1464: 0 byte(7)20,0 intern L1464 L1465: 0 byte(7)21,0 intern L1465 L1466: 0 byte(7)22,0 intern L1466 L1467: 0 byte(7)23,0 intern L1467 L1468: 0 byte(7)24,0 intern L1468 L1469: 0 byte(7)25,0 intern L1469 L1470: 0 byte(7)26,0 intern L1470 L1471: 0 byte(7)27,0 intern L1471 L1472: 0 byte(7)28,0 intern L1472 L1473: 0 byte(7)29,0 intern L1473 L1474: 0 byte(7)30,0 intern L1474 L1475: 0 byte(7)31,0 intern L1475 L1476: 0 byte(7)32,0 intern L1476 L1477: 0 byte(7)33,0 intern L1477 L1478: 0 byte(7)34,0 intern L1478 L1479: 0 byte(7)35,0 intern L1479 L1480: 0 byte(7)36,0 intern L1480 L1481: 0 byte(7)37,0 intern L1481 L1482: 0 byte(7)38,0 intern L1482 L1483: 0 byte(7)39,0 intern L1483 L1484: 0 byte(7)40,0 intern L1484 L1485: 0 byte(7)41,0 intern L1485 L1486: 0 byte(7)42,0 intern L1486 L1487: 0 byte(7)43,0 intern L1487 L1488: 0 byte(7)44,0 intern L1488 L1489: 0 byte(7)45,0 intern L1489 L1490: 0 byte(7)46,0 intern L1490 L1491: 0 byte(7)47,0 intern L1491 L1492: 0 byte(7)48,0 intern L1492 L1493: 0 byte(7)49,0 intern L1493 L1494: 0 byte(7)50,0 intern L1494 L1495: 0 byte(7)51,0 intern L1495 L1496: 0 byte(7)52,0 intern L1496 L1497: 0 byte(7)53,0 intern L1497 L1498: 0 byte(7)54,0 intern L1498 L1499: 0 byte(7)55,0 intern L1499 L1500: 0 byte(7)56,0 intern L1500 L1501: 0 byte(7)57,0 intern L1501 L1502: 0 byte(7)58,0 intern L1502 L1503: 0 byte(7)59,0 intern L1503 L1504: 0 byte(7)60,0 intern L1504 L1505: 0 byte(7)61,0 intern L1505 L1506: 0 byte(7)62,0 intern L1506 L1507: 0 byte(7)63,0 intern L1507 L1508: 0 byte(7)64,0 intern L1508 L1509: 0 byte(7)65,0 intern L1509 L1510: 0 byte(7)66,0 intern L1510 L1511: 0 byte(7)67,0 intern L1511 L1512: 0 byte(7)68,0 intern L1512 L1513: 0 byte(7)69,0 intern L1513 L1514: 0 byte(7)70,0 intern L1514 L1515: 0 byte(7)71,0 intern L1515 L1516: 0 byte(7)72,0 intern L1516 L1517: 0 byte(7)73,0 intern L1517 L1518: 0 byte(7)74,0 intern L1518 L1519: 0 byte(7)75,0 intern L1519 L1520: 0 byte(7)76,0 intern L1520 L1521: 0 byte(7)77,0 intern L1521 L1522: 0 byte(7)78,0 intern L1522 L1523: 0 byte(7)79,0 intern L1523 L1524: 0 byte(7)80,0 intern L1524 L1525: 0 byte(7)81,0 intern L1525 L1526: 0 byte(7)82,0 intern L1526 L1527: 0 byte(7)83,0 intern L1527 L1528: 0 byte(7)84,0 intern L1528 L1529: 0 byte(7)85,0 intern L1529 L1530: 0 byte(7)86,0 intern L1530 L1531: 0 byte(7)87,0 intern L1531 L1532: 0 byte(7)88,0 intern L1532 L1533: 0 byte(7)89,0 intern L1533 L1534: 0 byte(7)90,0 intern L1534 L1535: 0 byte(7)91,0 intern L1535 L1536: 0 byte(7)92,0 intern L1536 L1537: 0 byte(7)93,0 intern L1537 L1538: 0 byte(7)94,0 intern L1538 L1539: 0 byte(7)95,0 intern L1539 L1540: 0 byte(7)96,0 intern L1540 L1541: 0 byte(7)97,0 intern L1541 L1542: 0 byte(7)98,0 intern L1542 L1543: 0 byte(7)99,0 intern L1543 L1544: 0 byte(7)100,0 intern L1544 L1545: 0 byte(7)101,0 intern L1545 L1546: 0 byte(7)102,0 intern L1546 L1547: 0 byte(7)103,0 intern L1547 L1548: 0 byte(7)104,0 intern L1548 L1549: 0 byte(7)105,0 intern L1549 L1550: 0 byte(7)106,0 intern L1550 L1551: 0 byte(7)107,0 intern L1551 L1552: 0 byte(7)108,0 intern L1552 L1553: 0 byte(7)109,0 intern L1553 L1554: 0 byte(7)110,0 intern L1554 L1555: 0 byte(7)111,0 intern L1555 L1556: 0 byte(7)112,0 intern L1556 L1557: 0 byte(7)113,0 intern L1557 L1558: 0 byte(7)114,0 intern L1558 L1559: 0 byte(7)115,0 intern L1559 L1560: 0 byte(7)116,0 intern L1560 L1561: 0 byte(7)117,0 intern L1561 L1562: 0 byte(7)118,0 intern L1562 L1563: 0 byte(7)119,0 intern L1563 L1564: 0 byte(7)120,0 intern L1564 L1565: 0 byte(7)121,0 intern L1565 L1566: 0 byte(7)122,0 intern L1566 L1567: 0 byte(7)123,0 intern L1567 L1568: 0 byte(7)124,0 intern L1568 L1569: 0 byte(7)125,0 intern L1569 L1570: 0 byte(7)126,0 intern L1570 L1571: 0 byte(7)127,0 intern L1571 L1572: 2 byte(7)78,73,76,0 intern L1572 L1573: 6 byte(7)80,82,73,78,49,73,68,0 intern L1573 L1574: 7 byte(7)80,82,73,78,49,73,78,84,0 intern L1574 L1575: 10 byte(7)80,82,73,78,49,83,84,82,73,78,71,0 intern L1575 L1576: 8 byte(7)80,82,73,78,49,80,65,73,82,0 intern L1576 L1577: 5 byte(7)80,82,84,73,84,77,0 intern L1577 L1578: 4 byte(7)80,82,73,78,49,0 intern L1578 L1579: 6 byte(7)80,82,73,78,50,73,68,0 intern L1579 L1580: 10 byte(7)80,82,73,78,50,83,84,82,73,78,71,0 intern L1580 L1581: 8 byte(7)80,82,73,78,50,80,65,73,82,0 intern L1581 L1582: 4 byte(7)80,82,73,78,50,0 intern L1582 L1583: 5 byte(7)84,69,82,80,82,73,0 intern L1583 L1584: 4 byte(7)80,82,73,78,84,0 intern L1584 L1585: 5 byte(7)80,82,73,78,50,84,0 intern L1585 L1586: 3 byte(7)80,85,84,67,0 intern L1586 L1587: 5 byte(7)80,66,76,65,78,75,0 intern L1587 L1588: 8 byte(7)80,82,73,78,49,73,78,84,88,0 intern L1588 L1589: 6 byte(7)76,79,78,71,68,73,86,0 intern L1589 L1590: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L1590 L1591: 3 byte(7)66,89,84,69,0 intern L1591 L1592: 3 byte(7)81,85,73,84,0 intern L1592 L1593: 4 byte(7)69,82,82,79,82,0 intern L1593 L1594: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L1594 L1595: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L1595 L1596: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L1596 L1597: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L1597 L1598: 3 byte(7)79,85,84,42,0 intern L1598 L1599: 10 byte(7)69,82,82,79,82,72,69,65,68,69,82,0 intern L1599 L1600: 11 byte(7)69,82,82,79,82,84,82,65,73,76,69,82,0 intern L1600 L1601: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L1601 L1602: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L1602 L1603: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L1603 L1604: 5 byte(7)80,82,73,78,49,84,0 intern L1604 L1605: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L1605 L1606: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L1606 L1607: 1 byte(7)70,78,0 intern L1607 L1608: 7 byte(7)79,70,70,69,78,68,69,82,0 intern L1608 L1609: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L1609 L1610: 11 byte(7)76,65,77,66,73,78,68,65,82,71,83,42,0 intern L1610 L1611: 6 byte(7)76,65,77,66,73,78,68,0 intern L1611 L1612: 6 byte(7)85,78,66,73,78,68,78,0 intern L1612 L1613: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1613 L1614: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L1614 L1615: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L1615 L1616: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L1616 L1617: 5 byte(7)71,84,72,69,65,80,0 intern L1617 L1618: 4 byte(7)71,84,83,84,82,0 intern L1618 L1619: 5 byte(7)71,84,86,69,67,84,0 intern L1619 L1620: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L1620 L1621: 3 byte(7)71,84,73,68,0 intern L1621 L1622: 7 byte(7)72,65,82,68,67,79,78,83,0 intern L1622 L1623: 3 byte(7)67,79,78,83,0 intern L1623 L1624: 4 byte(7)88,67,79,78,83,0 intern L1624 L1625: 4 byte(7)78,67,79,78,83,0 intern L1625 L1626: 5 byte(7)77,75,86,69,67,84,0 intern L1626 L1627: 4 byte(7)76,73,83,84,50,0 intern L1627 L1628: 4 byte(7)76,73,83,84,51,0 intern L1628 L1629: 4 byte(7)76,73,83,84,52,0 intern L1629 L1630: 4 byte(7)76,73,83,84,53,0 intern L1630 L1631: 6 byte(7)80,85,84,66,89,84,69,0 intern L1631 L1632: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L1632 L1633: 4 byte(7)69,81,83,84,82,0 intern L1633 L1634: 7 byte(7)73,78,73,84,82,69,65,68,0 intern L1634 L1635: 5 byte(7)42,82,65,73,83,69,0 intern L1635 L1636: 2 byte(7)67,72,42,0 intern L1636 L1637: 3 byte(7)84,79,75,42,0 intern L1637 L1638: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L1638 L1639: 4 byte(7)68,69,66,85,71,0 intern L1639 L1640: 7 byte(7)83,69,84,82,65,73,83,69,0 intern L1640 L1641: 9 byte(7)67,76,69,65,82,87,72,73,84,69,0 intern L1641 L1642: 11 byte(7)67,76,69,65,82,67,79,77,77,69,78,84,0 intern L1642 L1643: 6 byte(7)82,69,65,68,83,84,82,0 intern L1643 L1644: 5 byte(7)68,73,71,73,84,80,0 intern L1644 L1645: 6 byte(7)82,69,65,68,73,78,84,0 intern L1645 L1646: 8 byte(7)65,76,80,72,65,69,83,67,80,0 intern L1646 L1647: 5 byte(7)82,69,65,68,73,68,0 intern L1647 L1648: 4 byte(7)82,65,84,79,77,0 intern L1648 L1649: 5 byte(7)87,72,73,84,69,80,0 intern L1649 L1650: 3 byte(7)71,69,84,67,0 intern L1650 L1651: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L1651 L1652: 13 byte(7)66,85,70,70,69,82,84,79,83,84,82,73,78,71,0 intern L1652 L1653: 8 byte(7)82,65,73,83,69,67,72,65,82,0 intern L1653 L1654: 11 byte(7)65,76,80,72,65,78,85,77,69,83,67,80,0 intern L1654 L1655: 5 byte(7)73,78,84,69,82,78,0 intern L1655 L1656: 6 byte(7)69,83,67,65,80,69,80,0 intern L1656 L1657: 5 byte(7)65,76,80,72,65,80,0 intern L1657 L1658: 9 byte(7)76,79,87,69,82,67,65,83,69,80,0 intern L1658 L1659: 7 byte(7)76,79,79,75,85,80,73,68,0 intern L1659 L1660: 8 byte(7)73,78,73,84,78,69,87,73,68,0 intern L1660 L1661: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L1661 L1662: 9 byte(7)85,80,80,69,82,67,65,83,69,80,0 intern L1662 L1663: 8 byte(7)65,76,80,72,65,78,85,77,80,0 intern L1663 L1664: 4 byte(7)82,69,65,68,49,0 intern L1664 L1665: 3 byte(7)82,69,65,68,0 intern L1665 L1666: 7 byte(7)82,69,65,68,76,73,83,84,0 intern L1666 L1667: 4 byte(7)81,85,79,84,69,0 intern L1667 L1668: 6 byte(7)83,65,70,69,67,68,82,0 intern L1668 L1669: 9 byte(7)83,89,77,70,78,67,66,65,83,69,0 intern L1669 L1670: 5 byte(7)87,80,76,85,83,50,0 intern L1670 L1671: 5 byte(7)83,89,77,70,78,67,0 intern L1671 L1672: 6 byte(7)87,84,73,77,69,83,50,0 intern L1672 L1673: 29 byte(7)65,68,68,82,69,83,83,73,78,71,85,78,73,84,83,80,69,82,70,85,78,67,84,73,79,78,67,69,76,76,0 intern L1673 L1674: 16 byte(7)83,72,79,85,76,68,66,69,85,78,68,69,70,73,78,69,68,0 intern L1674 L1675: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L1675 L1676: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L1676 L1677: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L1677 L1678: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L1678 L1679: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L1679 L1680: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L1680 L1681: 5 byte(7)70,67,79,68,69,80,0 intern L1681 L1682: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L1682 L1683: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L1683 L1684: 12 byte(7)67,79,68,69,80,82,73,77,73,84,73,86,69,0 intern L1684 L1685: 7 byte(7)67,79,68,69,80,84,82,42,0 intern L1685 L1686: 12 byte(7)83,65,86,69,82,69,71,73,83,84,69,82,83,0 intern L1686 L1687: 8 byte(7)67,79,68,69,70,79,82,77,42,0 intern L1687 L1688: 8 byte(7)67,79,68,69,78,65,82,71,42,0 intern L1688 L1689: 28 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,0 intern L1689 L1690: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L1690 L1691: 14 byte(7)70,65,83,84,76,65,77,66,68,65,65,80,80,76,89,0 intern L1691 L1692: 5 byte(7)76,65,77,66,68,65,0 intern L1692 L1693: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L1693 L1694: 22 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,65,85,88,0 intern L1694 L1695: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L1695 L1696: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L1696 L1697: 15 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,65,85,88,0 intern L1697 L1698: 3 byte(7)69,86,65,76,0 intern L1698 L1699: 10 byte(7)66,73,78,68,69,86,65,76,65,85,88,0 intern L1699 L1700: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L1700 L1701: 5 byte(7)76,66,73,78,68,49,0 intern L1701 L1702: 2 byte(7)71,69,84,0 intern L1702 L1703: 31 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,65,85,88,65,85,88,0 intern L1703 L1704: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L1704 L1705: 5 byte(7)66,76,68,77,83,71,0 intern L1705 L1706: 6 byte(7)69,86,80,82,79,71,78,0 intern L1706 L1707: 6 byte(7)83,89,83,50,73,78,84,0 intern L1707 L1708: 4 byte(7)80,76,85,83,50,0 intern L1708 L1709: 4 byte(7)77,73,78,85,83,0 intern L1709 L1710: 4 byte(7)87,65,68,68,49,0 intern L1710 L1711: 3 byte(7)69,76,83,69,0 intern L1711 L1712: 3 byte(7)65,68,68,49,0 intern L1712 L1713: 4 byte(7)87,83,85,66,49,0 intern L1713 L1714: 3 byte(7)83,85,66,49,0 intern L1714 L1715: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L1715 L1716: 4 byte(7)76,69,83,83,80,0 intern L1716 L1717: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L1717 L1718: 5 byte(7)84,73,77,69,83,50,0 intern L1718 L1719: 2 byte(7)67,65,82,0 intern L1719 L1720: 2 byte(7)67,68,82,0 intern L1720 L1721: 3 byte(7)67,65,65,82,0 intern L1721 L1722: 3 byte(7)67,65,68,82,0 intern L1722 L1723: 3 byte(7)67,68,65,82,0 intern L1723 L1724: 3 byte(7)67,68,68,82,0 intern L1724 L1725: 3 byte(7)65,84,79,77,0 intern L1725 L1726: 5 byte(7)65,80,80,69,78,68,0 intern L1726 L1727: 3 byte(7)77,69,77,81,0 intern L1727 L1728: 6 byte(7)82,69,86,69,82,83,69,0 intern L1728 L1729: 4 byte(7)69,86,76,73,83,0 intern L1729 L1730: 4 byte(7)80,82,79,71,78,0 intern L1730 L1731: 5 byte(7)69,86,67,79,78,68,0 intern L1731 L1732: 3 byte(7)67,79,78,68,0 intern L1732 L1733: 2 byte(7)83,69,84,0 intern L1733 L1734: 3 byte(7)83,69,84,81,0 intern L1734 L1735: 3 byte(7)80,85,84,68,0 intern L1735 L1736: 1 byte(7)68,69,0 intern L1736 L1737: 3 byte(7)69,88,80,82,0 intern L1737 L1738: 1 byte(7)68,70,0 intern L1738 L1739: 4 byte(7)70,69,88,80,82,0 intern L1739 L1740: 1 byte(7)68,78,0 intern L1740 L1741: 4 byte(7)78,69,88,80,82,0 intern L1741 L1742: 1 byte(7)68,77,0 intern L1742 L1743: 4 byte(7)77,65,67,82,79,0 intern L1743 L1744: 3 byte(7)76,73,83,84,0 intern L1744 L1745: 4 byte(7)65,84,83,79,67,0 intern L1745 L1746: 2 byte(7)71,69,81,0 intern L1746 L1747: 2 byte(7)76,69,81,0 intern L1747 L1748: 4 byte(7)69,81,67,65,82,0 intern L1748 L1749: 3 byte(7)71,69,84,68,0 intern L1749 L1750: 4 byte(7)67,79,80,89,68,0 intern L1750 L1751: 5 byte(7)68,69,76,65,84,81,0 intern L1751 L1752: 2 byte(7)80,85,84,0 intern L1752 L1753: 7 byte(7)73,78,73,84,69,86,65,76,0 intern L1753 L1754: 4 byte(7)87,72,73,76,69,0 intern L1754 L1755: 4 byte(7)70,84,89,80,69,0 intern L1755 L1756: 6 byte(7)76,65,77,66,68,65,80,0 intern L1756 L1757: 8 byte(7)71,69,84,76,65,77,66,68,65,0 intern L1757 L1758: 14 byte(7)76,65,77,66,68,65,69,86,65,76,65,80,80,76,89,0 intern L1758 L1759: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L1759 L1760: 10 byte(7)76,65,77,66,68,65,65,80,80,76,89,0 intern L1760 L1761: 4 byte(7)65,80,80,76,89,0 intern L1761 L1762: 7 byte(7)68,79,76,65,77,66,68,65,0 intern L1762 L1763: 5 byte(7)76,69,78,71,84,72,0 intern L1763 L1764: 4 byte(7)67,79,68,69,80,0 intern L1764 L1765: 4 byte(7)80,65,73,82,80,0 intern L1765 L1766: 2 byte(7)73,68,80,0 intern L1766 L1767: 1 byte(7)69,81,0 intern L1767 L1768: 3 byte(7)78,85,76,76,0 intern L1768 L1769: 2 byte(7)78,79,84,0 intern L1769 L1770: 6 byte(7)76,69,78,71,84,72,49,0 intern L1770 L1771: 5 byte(7)77,65,80,79,66,76,0 intern L1771 L1772: 10 byte(7)80,82,73,78,84,70,69,88,80,82,83,0 intern L1772 L1773: 10 byte(7)80,82,73,78,84,49,70,69,88,80,82,0 intern L1773 L1774: 5 byte(7)70,69,88,80,82,80,0 intern L1774 L1775: 13 byte(7)80,82,73,78,84,70,85,78,67,84,73,79,78,83,0 intern L1775 L1776: 13 byte(7)80,82,73,78,84,49,70,85,78,67,84,73,79,78,0 intern L1776 L1777: 3 byte(7)80,82,79,80,0 intern L1777 L1778: 6 byte(7)82,69,77,80,82,79,80,0 intern L1778 L1779: 7 byte(7)83,89,83,50,70,73,88,78,0 intern L1779 L1780: 13 byte(7)73,78,70,83,84,65,82,84,73,78,71,66,73,84,0 intern L1780 L1781: 11 byte(7)73,78,70,66,73,84,76,69,78,71,84,72,0 intern L1781 L1782: 4 byte(7)82,69,83,69,84,0 intern L1782 L1783: 13 byte(7)66,83,84,65,67,75,79,86,69,82,70,76,79,87,0 intern L1783 L1784: 6 byte(7)69,82,82,79,85,84,42,0 intern L1784 L1785: 14 byte(7)66,83,84,65,67,75,85,78,68,69,82,70,76,79,87,0 intern L1785 L1786: 17 byte(7)67,65,80,84,85,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L1786 L1787: 17 byte(7)82,69,83,84,79,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L1787 L1788: 17 byte(7)37,67,76,69,65,82,45,67,65,84,67,72,45,83,84,65,67,75,0 intern L1788 L1789: 12 byte(7)67,76,69,65,82,66,73,78,68,73,78,71,83,0 intern L1789 L1790: 5 byte(7)80,66,73,78,68,49,0 intern L1790 L1791: 7 byte(7)80,82,79,71,66,73,78,68,0 intern L1791 L1792: 9 byte(7)83,89,83,67,76,69,65,82,73,79,0 intern L1792 L1793: 8 byte(7)68,69,67,50,48,79,80,69,78,0 intern L1793 L1794: 10 byte(7)83,89,83,79,80,69,78,82,69,65,68,0 intern L1794 L1795: 11 byte(7)83,89,83,79,80,69,78,87,82,73,84,69,0 intern L1795 L1796: 12 byte(7)68,69,67,50,48,82,69,65,68,67,72,65,82,0 intern L1796 L1797: 9 byte(7)83,89,83,82,69,65,68,82,69,67,0 intern L1797 L1798: 6 byte(7)73,79,69,82,82,79,82,0 intern L1798 L1799: 13 byte(7)68,69,67,50,48,87,82,73,84,69,67,72,65,82,0 intern L1799 L1800: 10 byte(7)83,89,83,87,82,73,84,69,82,69,67,0 intern L1800 L1801: 7 byte(7)83,89,83,67,76,79,83,69,0 intern L1801 L1802: 11 byte(7)67,72,65,78,78,69,76,69,82,82,79,82,0 intern L1802 L1803: 11 byte(7)83,89,83,77,65,88,66,85,70,70,69,82,0 intern L1803 L1804: 19 byte(7)84,69,82,77,73,78,65,76,73,78,80,85,84,72,65,78,68,76,69,82,0 intern L1804 L1805: 15 byte(7)87,82,73,84,69,79,78,76,89,67,72,65,78,78,69,76,0 intern L1805 L1806: 15 byte(7)67,79,77,80,82,69,83,83,82,69,65,68,67,72,65,82,0 intern L1806 L1807: 13 byte(7)67,72,65,78,78,69,76,78,79,84,79,80,69,78,0 intern L1807 L1808: 14 byte(7)82,69,65,68,79,78,76,89,67,72,65,78,78,69,76,0 intern L1808 L1809: 16 byte(7)84,79,83,84,82,73,78,71,87,82,73,84,69,67,72,65,82,0 intern L1809 L1810: 15 byte(7)69,88,80,76,79,68,69,87,82,73,84,69,67,72,65,82,0 intern L1810 L1811: 16 byte(7)70,76,65,84,83,73,90,69,87,82,73,84,69,67,72,65,82,0 intern L1811 L1812: 26 byte(7)73,76,76,69,71,65,76,83,84,65,78,68,65,82,68,67,72,65,78,78,69,76,67,76,79,83,69,0 intern L1812 L1813: 4 byte(7)36,69,79,76,36,0 intern L1813 L1814: 2 byte(7)82,68,83,0 intern L1814 L1815: 2 byte(7)87,82,83,0 intern L1815 L1816: 3 byte(7)79,80,69,78,0 intern L1816 L1817: 4 byte(7)67,76,79,83,69,0 intern L1817 L1818: 7 byte(7)84,89,80,69,70,73,76,69,0 intern L1818 L1819: 4 byte(7)73,78,80,85,84,0 intern L1819 L1820: 4 byte(7)68,83,75,73,78,0 intern L1820 L1821: 4 byte(7)36,69,79,70,36,0 intern L1821 L1822: 4 byte(7)42,80,86,65,76,0 intern L1822 L1823: 4 byte(7)42,69,67,72,79,0 intern L1823 L1824: 4 byte(7)76,65,80,73,78,0 intern L1824 L1825: 21 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,73,78,80,85,84,0 intern L1825 L1826: 22 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,79,85,84,80,85,84,0 intern L1826 L1827: 5 byte(7)79,85,84,80,85,84,0 intern L1827 L1828: 22 byte(7)73,78,68,69,80,69,78,68,69,78,84,67,76,79,83,69,67,72,65,78,78,69,76,0 intern L1828 L1829: 2 byte(7)73,78,42,0 intern L1829 L1830: 5 byte(7)83,84,68,73,78,42,0 intern L1830 L1831: 6 byte(7)83,84,68,79,85,84,42,0 intern L1831 L1832: 9 byte(7)80,82,79,77,80,84,79,85,84,42,0 intern L1832 L1833: 14 byte(7)70,73,78,68,70,82,69,69,67,72,65,78,78,69,76,0 intern L1833 L1834: 7 byte(7)73,79,66,85,70,70,69,82,0 intern L1834 L1835: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L1835 L1836: 20 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,83,80,69,67,73,65,76,0 intern L1836 L1837: 15 byte(7)84,69,83,84,76,69,71,65,76,67,72,65,78,78,69,76,0 intern L1837 L1838: 24 byte(7)83,89,83,84,69,77,77,65,82,75,65,83,67,76,79,83,69,68,67,72,65,78,78,69,76,0 intern L1838 L1839: 14 byte(7)67,76,69,65,82,79,78,69,67,72,65,78,78,69,76,0 intern L1839 L1840: 6 byte(7)67,76,69,65,82,73,79,0 intern L1840 L1841: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,84,82,73,78,71,0 intern L1841 L1842: 12 byte(7)80,82,79,77,80,84,83,84,82,73,78,71,42,0 intern L1842 L1843: 7 byte(7)73,78,73,84,72,69,65,80,0 intern L1843 L1844: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L1844 L1845: 4 byte(7)77,65,73,78,46,0 intern L1845 L1846: 3 byte(7)73,78,73,84,0 intern L1846 L1847: 3 byte(7)84,73,77,67,0 intern L1847 L1848: 3 byte(7)68,65,84,69,0 intern L1848 L1849: 10 byte(7)86,69,82,83,73,79,78,78,65,77,69,0 intern L1849 L1850: 5 byte(7)80,85,84,73,78,84,0 intern L1850 L1851: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L1851 L1852: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L1852 L1853: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L1853 L1854: 3 byte(7)70,76,65,71,0 intern L1854 L1855: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L1855 L1856: 7 byte(7)72,69,65,80,73,78,70,79,0 intern L1856 L1857: 6 byte(7)82,69,67,76,65,73,77,0 intern L1857 L1858: 5 byte(7)83,80,65,67,69,68,0 intern L1858 L1859: 5 byte(7)68,65,83,72,69,68,0 intern L1859 L1860: 5 byte(7)68,79,84,84,69,68,0 intern L1860 L1861: 7 byte(7)83,72,79,85,76,68,66,69,0 intern L1861 L1862: 2 byte(7)73,78,70,0 intern L1862 L1863: 2 byte(7)84,65,71,0 intern L1863 L1864: 5 byte(7)77,75,73,84,69,77,0 intern L1864 L1865: 3 byte(7)84,73,77,69,0 intern L1865 L1866: 6 byte(7)70,85,78,67,65,76,76,0 intern L1866 L1867: 10 byte(7)80,82,69,80,65,82,69,84,69,83,84,0 intern L1867 L1868: 11 byte(7)77,65,75,69,76,79,78,71,76,73,83,84,0 intern L1868 L1869: 2 byte(7)70,79,79,0 intern L1869 L1870: 8 byte(7)84,69,83,84,83,69,84,85,80,0 intern L1870 L1871: 7 byte(7)84,69,83,84,76,73,83,84,0 intern L1871 L1872: 8 byte(7)84,69,83,84,76,73,83,84,50,0 intern L1872 L1873: 7 byte(7)69,86,65,76,70,79,82,77,0 intern L1873 L1874: 7 byte(7)76,79,78,71,76,73,83,84,0 intern L1874 L1875: 7 byte(7)67,68,82,49,84,69,83,84,0 intern L1875 L1876: 7 byte(7)67,68,82,50,84,69,83,84,0 intern L1876 L1877: 7 byte(7)67,68,68,82,84,69,83,84,0 intern L1877 L1878: 15 byte(7)76,73,83,84,79,78,76,89,67,68,82,84,69,83,84,49,0 intern L1878 L1879: 16 byte(7)76,73,83,84,79,78,76,89,67,68,68,82,84,69,83,84,49,0 intern L1879 L1880: 15 byte(7)76,73,83,84,79,78,76,89,67,68,82,84,69,83,84,50,0 intern L1880 L1881: 16 byte(7)76,73,83,84,79,78,76,89,67,68,68,82,84,69,83,84,50,0 intern L1881 L1882: 8 byte(7)69,77,80,84,89,84,69,83,84,0 intern L1882 L1883: 12 byte(7)83,76,79,87,69,77,80,84,89,84,69,83,84,0 intern L1883 L1884: 10 byte(7)82,69,86,69,82,83,69,84,69,83,84,0 intern L1884 L1885: 9 byte(7)77,89,82,69,86,69,82,83,69,49,0 intern L1885 L1886: 13 byte(7)77,89,82,69,86,69,82,83,69,49,84,69,83,84,0 intern L1886 L1887: 9 byte(7)77,89,82,69,86,69,82,83,69,50,0 intern L1887 L1888: 13 byte(7)77,89,82,69,86,69,82,83,69,50,84,69,83,84,0 intern L1888 L1889: 9 byte(7)76,69,78,71,84,72,84,69,83,84,0 intern L1889 L1890: 3 byte(7)70,65,67,84,0 intern L1890 L1891: 13 byte(7)65,82,73,84,72,77,69,84,73,67,84,69,83,84,0 intern L1891 L1892: 7 byte(7)69,86,65,76,84,69,83,84,0 intern L1892 L1893: 7 byte(7)84,73,77,69,69,86,65,76,0 intern L1893 L1894: 2 byte(7)84,65,75,0 intern L1894 L1895: 10 byte(7)84,79,80,76,69,86,69,76,84,65,75,0 intern L1895 L1896: 3 byte(7)71,84,65,75,0 intern L1896 L1897: 11 byte(7)84,79,80,76,69,86,69,76,71,84,65,75,0 intern L1897 L1898: 4 byte(7)71,84,83,84,65,0 intern L1898 L1899: 4 byte(7)71,84,83,84,66,0 intern L1899 L1900: 1 byte(7)71,48,0 intern L1900 L1901: 1 byte(7)71,49,0 intern L1901 L1902: 6 byte(7)78,82,69,67,79,78,67,0 intern L1902 L1903: 7 byte(7)78,82,69,86,69,82,83,69,0 intern L1903 L1904: 4 byte(7)78,78,73,76,83,0 intern L1904 L1905: 3 byte(7)78,73,76,83,0 intern L1905 L1906: 12 byte(7)84,69,83,84,71,76,79,66,65,76,86,65,82,0 intern L1906 L1907: 1 byte(7)78,82,0 intern L1907 L1908: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L1908 L1909: 5 byte(7)73,79,84,69,83,84,0 intern L1909 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/20-tests/main7.rel version [d4f4bf4511].
cannot compute difference between binary files
Added psl-1983/20-tests/main7.sym version [4d573d0042].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PUTC PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE QUIT ERROR CHANNELPRIN2 CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* ERRORHEADER ERRORTRAILER FATALERROR STDERROR NONIDERROR PRIN1T TYPEERROR USAGETYPEERROR FN OFFENDER NONNUMBERERROR LAMBINDARGS!* LAMBIND UNBINDN NONINTEGERERROR NONPOSITIVEINTEGERERROR WQUOTIENT !%RECLAIM GTHEAP GTSTR GTVECT GTWARRAY GTID HARDCONS CONS XCONS NCONS MKVECT LIST2 LIST3 LIST4 LIST5 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP LOOKUPID INITNEWID MAKEFUNBOUND UPPERCASEP ALPHANUMP READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED FUNBOUNDP !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK BLDMSG EVPROGN SYS2INT PLUS2 MINUS WADD1 ELSE ADD1 WSUB1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAR CDR CAAR CADR CDAR CDDR ATOM APPEND MEMQ REVERSE EVLIS PROGN EVCOND COND SET SETQ PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO LIST ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE FTYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP PAIRP IDP EQ NULL NOT LENGTH1 MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION PROP REMPROP SYS2FIXN INFSTARTINGBIT INFBITLENGTH RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 PROGBIND SYSCLEARIO DEC20OPEN SYSOPENREAD SYSOPENWRITE DEC20READCHAR SYSREADREC IOERROR DEC20WRITECHAR SYSWRITEREC SYSCLOSE CHANNELERROR SYSMAXBUFFER TERMINALINPUTHANDLER WRITEONLYCHANNEL COMPRESSREADCHAR CHANNELNOTOPEN READONLYCHANNEL TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR ILLEGALSTANDARDCHANNELCLOSE !$EOL!$ RDS WRS OPEN CLOSE TYPEFILE INPUT DSKIN !$EOF!$ !*PVAL !*ECHO LAPIN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT OUTPUT INDEPENDENTCLOSECHANNEL IN!* STDIN!* STDOUT!* PROMPTOUT!* FINDFREECHANNEL IOBUFFER INDEPENDENTREADCHAR SYSTEMOPENFILESPECIAL TESTLEGALCHANNEL SYSTEMMARKASCLOSEDCHANNEL CLEARONECHANNEL CLEARIO CHANNELWRITESTRING PROMPTSTRING!*))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 399)) (SETQ STRINGGENSYM!* (QUOTE "L1509")) (PUT (QUOTE INFBITLENGTH) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0643")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0237")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0321")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1006")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1115")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE MAXBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1111")) (PUT (QUOTE MAXBUFFER) (QUOTE WARRAY) (QUOTE MAXBUFFER)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L1145")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0325")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE SYSOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L1076")) (PUT (QUOTE SYSOPENWRITE) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0025")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0569")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1029")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE FTYPE) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0515")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE WADD1) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1104")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0355")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE PROMPTOUT!*) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE PROMPTOUT!*) (QUOTE INITIALVALUE) (QUOTE 6)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0360")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0230")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0436")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0443") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE SYSCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1100")) (PUT (QUOTE SYSCLOSE) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1157")) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0183")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE SYSREADREC) (QUOTE ENTRYPOINT) (QUOTE "L1080")) (PUT (QUOTE SYSREADREC) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0375")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0185")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1018")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0184")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE PRIN1T) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE SYSWRITEREC) (QUOTE ENTRYPOINT) (QUOTE "L1092")) (PUT (QUOTE SYSWRITEREC) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE IOBUFFER) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0398")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0299")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0674")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0301")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 243)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0369")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 379)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0103")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0098")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 500)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WSUB1) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE !*PVAL) (QUOTE IDNUMBER) (QUOTE 378)) (FLAG (QUOTE (!*PVAL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SYSCLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1074")) (PUT (QUOTE SYSCLEARIO) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0370")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE CHANNELSTATUS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELSTATUS) (QUOTE ASMSYMBOL) (QUOTE "L1110")) (PUT (QUOTE CHANNELSTATUS) (QUOTE WARRAY) (QUOTE CHANNELSTATUS)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE LOOKUPID) (QUOTE ENTRYPOINT) (QUOTE "L0270")) (PUT (QUOTE LOOKUPID) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE RESET) (QUOTE ENTRYPOINT) (QUOTE RESET)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0660")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0425")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1174")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0192")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0093")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE NEXTPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1113")) (PUT (QUOTE NEXTPOSITION) (QUOTE WARRAY) (QUOTE NEXTPOSITION)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0156")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0287")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0263")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0177")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1007")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1032")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1165")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0094")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE SYSOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L1075")) (PUT (QUOTE SYSOPENREAD) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0634")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0182")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0603")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0471")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE CHANNELTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELTABLE) (QUOTE ASMSYMBOL) (QUOTE "L1112")) (PUT (QUOTE CHANNELTABLE) (QUOTE WARRAY) (QUOTE CHANNELTABLE)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0021")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0647")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L1150")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1166")) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L1180")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0186")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1138")) (PUT (QUOTE FINDFREECHANNEL) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1161")) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0034")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0330")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 244)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1105")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE CLEARONECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1168")) (PUT (QUOTE CLEARONECHANNEL) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0191")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1096")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE FN) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0297")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE SYSMAXBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1102")) (PUT (QUOTE SYSMAXBUFFER) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1015")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0172")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE BUFFERLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BUFFERLENGTH) (QUOTE ASMSYMBOL) (QUOTE "L1114")) (PUT (QUOTE BUFFERLENGTH) (QUOTE WARRAY) (QUOTE BUFFERLENGTH)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0291")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1014")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0665")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0620")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1010")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1107")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0646")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0017")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1108")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1103")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0614")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0402")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0679")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0607")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1013")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0222")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE TYPEFILE) (QUOTE ENTRYPOINT) (QUOTE "L1117")) (PUT (QUOTE TYPEFILE) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0339")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1087")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0642")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0604")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0437")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L1109")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0371")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0099")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE OFFENDER) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0483")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0095")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0429")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1106")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0224")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1019")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0509")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0334")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0241")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE INFSTARTINGBIT) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0106")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L1149")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0295")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0350")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1005")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1153")) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0310")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 241)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L1077")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 198)) |
Added psl-1983/20-tests/main8.cmd version [2afa158094].
> > | 1 2 | main8,dmain8,sub8,dsub8,sub7,Dsub7,sub6,Dsub6,sub5,Dsub5,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/20-tests/module.mic version [c6e726a164].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; independant compilation a program for the 20 ; MIC MODULE modulename,symbolmname @define DSK:, DSK:, PT:, P20:, PI: @delete 'A.mac,'A.rel,'A.init @delete D'A.mac,D'A.rel @exp ;avoid obnoixous ^Q halts... @terminal length 0 @get s:TEST-DEC20-cross @st off break; %kill obnoxious break loops off USERMODE ; InputSymFile!* := "'B.sym"$ OutputSymFile!* := "'B.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''NIL; ModName!*:='''A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @reset . @terminal length 24 @get sys:macro.exe @st *'A.rel='A.mac *D'A.rel=D'A.mac @reset . |
Added psl-1983/20-tests/pk-red.dir version [b7f05f280d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SS:<PSL.KERNEL> ALLOCATORS.RED.4 ARITHMETIC.RED.2 AUTOLOAD.RED.3 AUTOLOAD-TRACE.RED.7 BACKTRACE.RED.18 BINDING.RED.2 BREAK.RED.4 CARCDR.RED.1 CATCH-THROW.RED.14 CHAR-IO.RED.2,3 COMP-SUPPORT.RED.1 COMPACTING-GC.RED.9 CONS-MKVECT.RED.2 CONT-ERROR.RED.1 COPIERS.RED.2 COPYING-GC.RED.9 DEFCONST.RED.1 DEFINE-SMACRO.RED.3 DSKIN.RED.3 EASY-NON-SL.RED.5 EASY-SL.RED.3 EQUAL.RED.2 ERROR-ERRORSET.RED.5 ERROR-HANDLERS.RED.4 EVAL-APPLY.RED.5 EVAL-WHEN.RED.1 EXPLODE-COMPRESS.RED.3 FASL-INCLUDE.RED.1 FASLIN.RED.2 FAST-BINDER.RED.1 FLUID-GLOBAL.RED.1 IO-ERRORS.RED.1 IO-EXTENSIONS.RED.1 KNOWN-TO-COMP-SL.RED.1 LISP-MACROS.RED.1 LOAD.RED.12 LOOP-MACROS.RED.1 MINI-EDITOR.RED.3 MINI-TRACE.RED.2 OBLIST.RED.3 OLD-STRING-GENSYM.RED.1 ONOFF.RED.1 OPEN-CLOSE.RED.1,2 OTHER-IO.RED.5 OTHERS-SL.RED.1 P-APPLY-LAP.RED.1 PRINTERS.RED.15 PRINTF.RED.3 PROG-AND-FRIENDS.RED.2 PROPERTY-LIST.RED.1 PUTD-GETD.RED.3 RDS-WRS.RED.1 READ.RED.6 SEQUENCE.RED.2 SETS.RED.1 STRING-GENSYM.RED.2 SYMBOL-VALUES.RED.1 TOKEN-SCANNER.RED.4 TOP-LOOP.RED.12 TYPE-CONVERSIONS.RED.1 TYPE-ERRORS.RED.1,3 VECTORS.RED.2 Total of 140 pages in 65 files |
Added psl-1983/20-tests/program.mic version [ba18a745a9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independent compilation a program for the 20 ;; MAIN module and data_segement, do last ; do PROGRAM modulename ; modulename=symboltablename @define DSK:, DSK:, PT:, P20:, PV:, PI: @delete 'A.mac,'A.rel,'A.init @delete D'A.mac,D'A.rel @exp ;avoid obnoixous ^Q halts... @terminal length 0 @get s:TEST-DEC20-CROSS.EXE @st off break; % avoid obnoxios breaks InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''T; ModName!*:='' 'A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @reset . @terminal length 24 @get sys:macro @st *'A.rel='A.mac *D'A.rel=D'A.mac @reset . |
Added psl-1983/20-tests/rand-psl.times version [34acba8be5].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | RAND-RELAY (VAX 11/750-1Mb) RAND-UNIX (VAX 11/780 4Mb ) *** GC 5: time 1122 ms, EmptyTest 10000 85 0 SlowEmptyTest 10000 1122 663 Cdr1Test 100 2074 1632 Cdr2Test 100 1598 1224 CddrTest 100 1326 1071 ListOnlyCdrTest1 9435 7208 ListOnlyCddrTest1 15283 12410 ListOnlyCdrTest2 12189 9418 ListOnlyCddrTest2 18105 15164 ReverseTest 10 1054 748 *** GC 6: time 1139 ms, 782 ms, MyReverse1Test 10 1156 697 *** GC 7: time 1224 ms, 646ms MyReverse2Test 10 1003 629 *** GC 8: time 1190 ms, 765 ms LengthTest 100 2210 1700 ArithmeticTest 10000 1938 867 EvalTest 10000 8687 5083 tak 18 12 6 1326 765 gtak 18 12 6 7361 4267 gtsta g0 5253 2533 gtsta g1 5355 2465 |
Added psl-1983/20-tests/sub2.init version [a7ffc6f8bf].
Added psl-1983/20-tests/sub2.mac version [615876b770].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY CHANNELWRITECHAR EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 2 ; (!*ENTRY CHANNELWRITECHAR EXPR 2) L0094: intern L0094 MOVE 1,2 HRRZI 12,142 HRRZI 13,1 JRST SYMFNC+142 ; (!*ENTRY WRITECHAR EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$GLOBAL OUT!*) (REG 1)) ; (MOVE (REG 1) (!$GLOBAL OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 152) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY WRITECHAR EXPR 1) L0095: intern L0095 MOVE 2,1 MOVE 1,SYMVAL+154 HRRZI 12,152 HRRZI 13,2 JRST SYMFNC+152 ; (!*ENTRY PRIN1 EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PRIN1ID EXPR 1) ; (HRRZI (REG LINKREG) 129) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1ID)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTINTYPE (LABEL G0005) (REG 1) POSINT) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 31) ; (JRST "L0108") ; (CAILE (REG T6) 0) ; (JRST (LABEL G0005)) ; (!*LINKE 0 PRIN1INT EXPR 1) ; (HRRZI (REG LINKREG) 130) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1INT)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTTYPE (LABEL G0006) (REG 1) STR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 4) ; (JRST (LABEL G0006)) ; (!*LINKE 0 PRIN1STRING EXPR 1) ; (HRRZI (REG LINKREG) 131) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1STRING)) ; (!*LBL (LABEL G0006)) ; (!*JUMPNOTTYPE (LABEL G0007) (REG 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 9) ; (JRST (LABEL G0007)) ; (!*LINKE 0 PRIN1PAIR EXPR 1) ; (HRRZI (REG LINKREG) 132) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1PAIR)) ; (!*LBL (LABEL G0007)) ; (!*LINKE 0 PRTITM EXPR 1) ; (HRRZI (REG LINKREG) 133) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRTITM)) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY PRIN1 EXPR 1) PRIN1: intern PRIN1 LDB 11,L0107 CAIE 11,30 JRST L0109 HRRZI 12,129 HRRZI 13,1 JRST SYMFNC+129 L0109: LDB 11,L0107 CAIN 11,31 JRST L0108 CAILE 11,0 JRST L0110 L0108: HRRZI 12,130 HRRZI 13,1 JRST SYMFNC+130 L0110: LDB 11,L0107 CAIE 11,4 JRST L0111 HRRZI 12,131 HRRZI 13,1 JRST SYMFNC+131 L0111: LDB 11,L0107 CAIE 11,9 JRST L0112 HRRZI 12,132 HRRZI 13,1 JRST SYMFNC+132 L0112: HRRZI 12,133 HRRZI 13,1 JRST SYMFNC+133 L0107: point 5,1,4 ; (!*ENTRY PRIN2 EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PRIN2ID EXPR 1) ; (HRRZI (REG LINKREG) 135) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2ID)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTINTYPE (LABEL G0005) (REG 1) POSINT) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 31) ; (JRST "L0114") ; (CAILE (REG T6) 0) ; (JRST (LABEL G0005)) ; (!*LINKE 0 PRIN1INT EXPR 1) ; (HRRZI (REG LINKREG) 130) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1INT)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTTYPE (LABEL G0006) (REG 1) STR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 4) ; (JRST (LABEL G0006)) ; (!*LINKE 0 PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2STRING)) ; (!*LBL (LABEL G0006)) ; (!*JUMPNOTTYPE (LABEL G0007) (REG 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 9) ; (JRST (LABEL G0007)) ; (!*LINKE 0 PRIN2PAIR EXPR 1) ; (HRRZI (REG LINKREG) 137) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2PAIR)) ; (!*LBL (LABEL G0007)) ; (!*LINKE 0 PRTITM EXPR 1) ; (HRRZI (REG LINKREG) 133) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRTITM)) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) 1 ; (!*ENTRY PRIN2 EXPR 1) PRIN2: intern PRIN2 LDB 11,L0113 CAIE 11,30 JRST L0115 HRRZI 12,135 HRRZI 13,1 JRST SYMFNC+135 L0115: LDB 11,L0113 CAIN 11,31 JRST L0114 CAILE 11,0 JRST L0116 L0114: HRRZI 12,130 HRRZI 13,1 JRST SYMFNC+130 L0116: LDB 11,L0113 CAIE 11,4 JRST L0117 HRRZI 12,136 HRRZI 13,1 JRST SYMFNC+136 L0117: LDB 11,L0113 CAIE 11,9 JRST L0118 HRRZI 12,137 HRRZI 13,1 JRST SYMFNC+137 L0118: HRRZI 12,133 HRRZI 13,1 JRST SYMFNC+133 L0113: point 5,1,4 ; (!*ENTRY PRINT EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRINT EXPR 1) PRINT: intern PRINT PUSH 15,1 HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PRIN2T EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRIN2T EXPR 1) PRIN2T: intern PRIN2T PUSH 15,1 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PBLANK EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 0 ; (!*ENTRY PBLANK EXPR 0) PBLANK: intern PBLANK HRRZI 1,32 HRRZI 12,142 HRRZI 13,1 JRST SYMFNC+142 ; (!*ENTRY PRIN1INT EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (WCONST 0)) ; (JUMPN (REG 1) (LABEL G0004)) ; (!*MOVE (WCONST 48) (REG 1)) ; (HRRZI (REG 1) 48) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWGEQ (LABEL G0005) (REG 1) (WCONST 0)) ; (JUMPGE (REG 1) (LABEL G0005)) ; (!*MOVE (WCONST 45) (REG 1)) ; (HRRZI (REG 1) 45) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*WMINUS (REG 1) (FRAME 1)) ; (MOVN (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1INT EXPR 1) ; (HRRZI (REG LINKREG) 130) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY PRIN1INT)) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0005)) ; (!*LINK PRIN1INTX EXPR 1) ; (HRRZI (REG LINKREG) 144) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1INTX)) ; (!*LBL (LABEL G0003)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRIN1INT EXPR 1) L0017: intern L0017 PUSH 15,1 JUMPN 1,L0119 HRRZI 1,48 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 JRST L0120 L0119: JUMPGE 1,L0121 HRRZI 1,45 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 MOVN 1,0(15) HRRZI 12,130 HRRZI 13,1 PUSHJ 15,L0017 JRST L0120 L0121: HRRZI 12,144 HRRZI 13,1 PUSHJ 15,SYMFNC+144 L0120: MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PRIN1INTX EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (WCONST 0)) ; (JUMPN (REG 1) (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (WCONST 10) (REG 2)) ; (HRRZI (REG 2) 10) ; (!*LINK LONGDIV EXPR 2) ; (HRRZI (REG LINKREG) 145) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LONGDIV)) ; (!*LINK PRIN1INTX EXPR 1) ; (HRRZI (REG LINKREG) 144) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY PRIN1INTX)) ; (!*MOVE (WCONST 10) (REG 2)) ; (HRRZI (REG 2) 10) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LONGREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LONGREMAINDER)) ; (!*WPLUS2 (REG 1) (WCONST 48)) ; (ADDI (REG 1) 48) ; (!*LINKE 1 PUTC EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRIN1INTX EXPR 1) L0021: intern L0021 PUSH 15,1 JUMPN 1,L0122 MOVE 1,0 JRST L0123 L0122: HRRZI 2,10 HRRZI 12,145 HRRZI 13,2 PUSHJ 15,SYMFNC+145 HRRZI 12,144 HRRZI 13,1 PUSHJ 15,L0021 HRRZI 2,10 MOVE 1,0(15) HRRZI 12,146 HRRZI 13,2 PUSHJ 15,SYMFNC+146 ADDI 1,48 ADJSP 15,-1 HRRZI 12,142 HRRZI 13,1 JRST SYMFNC+142 L0123: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PRIN1ID EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*MOVE (MEMORY (REG 1) (WCONST SYMNAM)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE SYMNAM))) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRIN1ID EXPR 1) L0024: intern L0024 PUSH 15,1 HRRZ 1,1 MOVE 1,SYMNAM(1) HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PRIN2ID EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PRIN1ID EXPR 1) ; (HRRZI (REG LINKREG) 129) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN1ID)) 1 ; (!*ENTRY PRIN2ID EXPR 1) L0025: intern L0025 HRRZI 12,129 HRRZI 13,1 JRST SYMFNC+129 ; (!*ENTRY PRIN1STRING EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 34) (REG 1)) ; (HRRZI (REG 1) 34) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*MOVE (WCONST 34) (REG 1)) ; (HRRZI (REG 1) 34) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PRIN1STRING EXPR 1) L0026: intern L0026 PUSH 15,1 HRRZI 1,34 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 MOVE 1,0(15) HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 HRRZI 1,34 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY PRIN2STRING EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*FIELD (REG 2) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 2) (REG 1)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0005)) ; (!*SIGNEDFIELD (REG 1) (MEMORY (FRAME 2) (WCONST 0)) (WCONST 18) (WCONST 18)) ; (HRRE (REG 1) (INDIRECT (INDEXED (REG ST) -1))) ; (!*JUMPWGREATERP (LABEL G0004) (FRAME 3) (REG 1)) ; (CAMGE (REG 1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 1 ; (!*ENTRY PRIN2STRING EXPR 1) L0028: intern L0028 ADJSP 15,3 MOVEM 1,0(15) HRRZ 2,1 MOVEM 2,-1(15) SETZM -2(15) L0125: HRRE 1,@-1(15) CAMGE 1,-2(15) JRST L0126 MOVE 2,-2(15) MOVE 1,-1(15) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L0124 LDB 1,2 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 AOS -2(15) JRST L0125 L0126: MOVE 1,0(15) ADJSP 15,-3 POPJ 15,0 L0124: point 7,0(1),6 ; (!*ENTRY PRIN1PAIR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 40) (REG 1)) ; (HRRZI (REG 1) 40) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (CDR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0004)) ; (!*JUMPTYPE (LABEL G0005) (FRAME 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0005)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (CDR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0003)) ; (!*JUMPEQ (LABEL G0008) (FRAME 1) (QUOTE NIL)) ; (CAMN (REG NIL) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE " . ") (REG 1)) ; (MOVE (REG 1) (QUOTE " . ")) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (WCONST 41) (REG 1)) ; (HRRZI (REG 1) 41) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)) L0129: 2 byte(7)32,46,32,0 1 ; (!*ENTRY PRIN1PAIR EXPR 1) L0034: intern L0034 PUSH 15,1 HRRZI 1,40 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) L0130: LDB 11,L0127 CAIN 11,9 JRST L0131 MOVE 1,0 JRST L0132 L0131: HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0130 L0132: CAMN 0,0(15) JRST L0133 MOVE 1,L0128 HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 L0133: HRRZI 1,41 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L0127: point 5,0(15),4 L0128: <4_31>+L0129 ; (!*ENTRY PRIN2PAIR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (WCONST 40) (REG 1)) ; (HRRZI (REG 1) 40) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (CDR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0004)) ; (!*JUMPTYPE (LABEL G0005) (FRAME 1) PAIR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)))) ; (CAIN (REG T6) 9) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0005)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (CAR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (CDR (FRAME 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0003)) ; (!*JUMPEQ (LABEL G0008) (FRAME 1) (QUOTE NIL)) ; (CAMN (REG NIL) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE " . ") (REG 1)) ; (MOVE (REG 1) (QUOTE " . ")) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (WCONST 41) (REG 1)) ; (HRRZI (REG 1) 41) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK PBLANK EXPR 0) ; (HRRZI (REG LINKREG) 143) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY PBLANK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)) L0136: 2 byte(7)32,46,32,0 1 ; (!*ENTRY PRIN2PAIR EXPR 1) L0042: intern L0042 PUSH 15,1 HRRZI 1,40 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) L0137: LDB 11,L0134 CAIN 11,9 JRST L0138 MOVE 1,0 JRST L0139 L0138: HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) MOVE 1,0(1) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0137 L0139: CAMN 0,0(15) JRST L0140 MOVE 1,L0135 HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 MOVE 1,0(15) HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 L0140: HRRZI 1,41 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZI 12,143 SETZM 13 PUSHJ 15,SYMFNC+143 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L0134: point 5,0(15),4 L0135: <4_31>+L0136 ; (!*ENTRY TERPRI EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 0 ; (!*ENTRY TERPRI EXPR 0) TERPRI: intern TERPRI HRRZI 1,10 HRRZI 12,142 HRRZI 13,1 JRST SYMFNC+142 ; (!*ENTRY PRTITM EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE " <") (REG 1)) ; (MOVE (REG 1) (QUOTE " <")) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 0) (WCONST 5)) ; (LDB (REG 1) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)))) ; (!*LINK PRIN1INT EXPR 1) ; (HRRZI (REG LINKREG) 130) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1INT)) ; (!*MOVE (WCONST 58) (REG 1)) ; (HRRZI (REG 1) 58) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*FIELD (REG 1) (FRAME 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1INT EXPR 1) ; (HRRZI (REG LINKREG) 130) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1INT)) ; (!*MOVE (QUOTE "> ") (REG 1)) ; (MOVE (REG 1) (QUOTE "> ")) ; (!*LINK PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2STRING)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) 0) 0 5)) L0144: 1 byte(7)62,32,0 L0145: 1 byte(7)32,60,0 1 ; (!*ENTRY PRTITM EXPR 1) PRTITM: intern PRTITM PUSH 15,1 MOVE 1,L0141 HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 LDB 1,L0142 HRRZI 12,130 HRRZI 13,1 PUSHJ 15,SYMFNC+130 HRRZI 1,58 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZ 1,0(15) HRRZI 12,130 HRRZI 13,1 PUSHJ 15,SYMFNC+130 MOVE 1,L0143 HRRZI 12,136 HRRZI 13,1 PUSHJ 15,SYMFNC+136 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L0142: point 5,0(15),4 L0143: <4_31>+L0144 L0141: <4_31>+L0145 ; (!*ENTRY CHANNELPRIN2 EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*LINKE 0 PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2)) 2 ; (!*ENTRY CHANNELPRIN2 EXPR 2) L0093: intern L0093 MOVE 1,2 HRRZI 12,138 HRRZI 13,1 JRST SYMFNC+138 ; (!*ENTRY ERRORHEADER EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "*** ERROR *** ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** ERROR *** ")) ; (!*LINKE 0 PRIN2STRING EXPR 1) ; (HRRZI (REG LINKREG) 136) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PRIN2STRING)) L0147: 13 byte(7)42,42,42,32,69,82,82,79,82,32,42,42,42,32,0 0 ; (!*ENTRY ERRORHEADER EXPR 0) L0098: intern L0098 MOVE 1,L0146 HRRZI 12,136 HRRZI 13,1 JRST SYMFNC+136 L0146: <4_31>+L0147 ; (!*ENTRY ERROR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK ERRORHEADER EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY ERRORHEADER)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 ERRORTRAILER EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 156) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ERRORTRAILER)) 1 ; (!*ENTRY ERROR EXPR 1) ERROR: intern ERROR PUSH 15,1 HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,156 HRRZI 13,1 JRST SYMFNC+156 ; (!*ENTRY ERRORTRAILER EXPR 1) ; (!*ALLOC 0) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ERRORTRAILER EXPR 1) L0099: intern L0099 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 POPJ 15,0 ; (!*ENTRY FATALERROR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK ERRORHEADER EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY ERRORHEADER)) ; (!*MOVE (QUOTE " FATAL ") (REG 1)) ; (MOVE (REG 1) (QUOTE " FATAL ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 ERRORTRAILER EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 156) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ERRORTRAILER)) L0149: 6 byte(7)32,70,65,84,65,76,32,0 1 ; (!*ENTRY FATALERROR EXPR 1) L0102: intern L0102 PUSH 15,1 HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 MOVE 1,L0148 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,156 HRRZI 13,1 JRST SYMFNC+156 L0148: <4_31>+L0149 ; (!*ENTRY STDERROR EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 ERROR EXPR 1) ; (HRRZI (REG LINKREG) 149) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ERROR)) 1 ; (!*ENTRY STDERROR EXPR 1) L0103: intern L0103 HRRZI 12,149 HRRZI 13,1 JRST SYMFNC+149 ; (!*ENTRY TYPEERROR EXPR 3) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*LINK ERRORHEADER EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY ERRORHEADER)) ; (!*MOVE (QUOTE "An attempt was made to do") (REG 1)) ; (MOVE (REG 1) (QUOTE "An attempt was made to do")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " on `") (REG 1)) ; (MOVE (REG 1) (QUOTE " on `")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE ", which is not ") (REG 1)) ; (MOVE (REG 1) (QUOTE ", which is not ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN1T EXPR 1) ; (HRRZI (REG LINKREG) 160) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) L0153: 14 byte(7)44,32,119,104,105,99,104,32,105,115,32,110,111,116,32,0 L0154: 4 byte(7)32,111,110,32,96,0 L0155: 24 byte(7)65,110,32,97,116,116,101,109,112,116,32,119,97,115,32,109,97,100,101,32,116,111,32,100,111,0 3 ; (!*ENTRY TYPEERROR EXPR 3) L0156: intern L0156 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 MOVE 1,L0150 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L0151 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L0152 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,160 HRRZI 13,1 PUSHJ 15,SYMFNC+160 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L0152: <4_31>+L0153 L0151: <4_31>+L0154 L0150: <4_31>+L0155 ; (!*ENTRY USAGETYPEERROR EXPR 4) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 4) (FRAME 3)) ; (MOVEM (REG 4) (INDEXED (REG ST) -2)) ; (!*LINK ERRORHEADER EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY ERRORHEADER)) ; (!*MOVE (QUOTE "An attempt was made to use") (REG 1)) ; (MOVE (REG 1) (QUOTE "An attempt was made to use")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " as ") (REG 1)) ; (MOVE (REG 1) (QUOTE " as ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " in `") (REG 1)) ; (MOVE (REG 1) (QUOTE " in `")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (QUOTE " is needed") (REG 1)) ; (MOVE (REG 1) (QUOTE " is needed")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) L0161: 9 byte(7)32,105,115,32,110,101,101,100,101,100,0 L0162: 4 byte(7)32,105,110,32,96,0 L0163: 3 byte(7)32,97,115,32,0 L0164: 25 byte(7)65,110,32,97,116,116,101,109,112,116,32,119,97,115,32,109,97,100,101,32,116,111,32,117,115,101,0 4 ; (!*ENTRY USAGETYPEERROR EXPR 4) L0165: intern L0165 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 4,-2(15) HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 MOVE 1,L0157 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L0158 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L0159 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,0 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L0160 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L0160: <4_31>+L0161 L0159: <4_31>+L0162 L0158: <4_31>+L0163 L0157: <4_31>+L0164 ; (!*ENTRY NONIDERROR EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "an identifier") (REG 3)) ; (MOVE (REG 3) (QUOTE "an identifier")) ; (!*MOVE (!$FLUID FN) (REG 2)) ; (MOVE (REG 2) (!$FLUID FN)) ; (!*MOVE (!$FLUID OFFENDER) (REG 1)) ; (MOVE (REG 1) (!$FLUID OFFENDER)) ; (!*LINKE 0 TYPEERROR EXPR 3) ; (HRRZI (REG LINKREG) 161) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY TYPEERROR)) L0167: 12 byte(7)97,110,32,105,100,101,110,116,105,102,105,101,114,0 2 ; (!*ENTRY NONIDERROR EXPR 2) L0106: intern L0106 MOVE 3,L0166 MOVE 2,SYMVAL+163 MOVE 1,SYMVAL+164 HRRZI 12,161 HRRZI 13,3 JRST SYMFNC+161 L0166: <4_31>+L0167 ; (!*ENTRY NONNUMBERERROR EXPR 2) ; (!*ALLOC 0) ; (!*LAMBIND (REGISTERS (REG 2) (REG 1)) (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (MOVEM (REG 2) (INDIRECT (FLUID LAMBINDARGS!*))) ; (MOVE (REG 2) (FLUID LAMBINDARGS!*)) ; (MOVEM (REG 1) (INDEXED (REG 2) 1)) ; (MOVE (REG 1) (QUOTE [FN OFFENDER])) ; (PUSHJ (REG ST) (ENTRY LAMBIND)) ; (!*MOVE (QUOTE "a number") (REG 3)) ; (MOVE (REG 3) (QUOTE "a number")) ; (!*MOVE (!$FLUID FN) (REG 2)) ; (MOVE (REG 2) (!$FLUID FN)) ; (!*MOVE (!$FLUID OFFENDER) (REG 1)) ; (MOVE (REG 1) (!$FLUID OFFENDER)) ; (!*LINK TYPEERROR EXPR 3) ; (HRRZI (REG LINKREG) 161) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TYPEERROR)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (HRRZI (REG 1) 2) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0170: 7 byte(7)97,32,110,117,109,98,101,114,0 L0171: 1 <30_31>+163 <30_31>+164 2 ; (!*ENTRY NONNUMBERERROR EXPR 2) L0172: intern L0172 MOVEM 2,@SYMVAL+166 MOVE 2,SYMVAL+166 MOVEM 1,1(2) MOVE 1,L0168 PUSHJ 15,SYMFNC+167 MOVE 3,L0169 MOVE 2,SYMVAL+163 MOVE 1,SYMVAL+164 HRRZI 12,161 HRRZI 13,3 PUSHJ 15,SYMFNC+161 HRRZI 1,2 PUSHJ 15,SYMFNC+168 POPJ 15,0 L0169: <4_31>+L0170 L0168: <8_31>+L0171 ; (!*ENTRY NONINTEGERERROR EXPR 2) ; (!*ALLOC 0) ; (!*LAMBIND (REGISTERS (REG 2) (REG 1)) (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (MOVEM (REG 2) (INDIRECT (FLUID LAMBINDARGS!*))) ; (MOVE (REG 2) (FLUID LAMBINDARGS!*)) ; (MOVEM (REG 1) (INDEXED (REG 2) 1)) ; (MOVE (REG 1) (QUOTE [FN OFFENDER])) ; (PUSHJ (REG ST) (ENTRY LAMBIND)) ; (!*MOVE (QUOTE "an integer") (REG 3)) ; (MOVE (REG 3) (QUOTE "an integer")) ; (!*MOVE (!$FLUID FN) (REG 2)) ; (MOVE (REG 2) (!$FLUID FN)) ; (!*MOVE (!$FLUID OFFENDER) (REG 1)) ; (MOVE (REG 1) (!$FLUID OFFENDER)) ; (!*LINK TYPEERROR EXPR 3) ; (HRRZI (REG LINKREG) 161) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TYPEERROR)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (HRRZI (REG 1) 2) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0175: 9 byte(7)97,110,32,105,110,116,101,103,101,114,0 L0176: 1 <30_31>+163 <30_31>+164 2 ; (!*ENTRY NONINTEGERERROR EXPR 2) L0177: intern L0177 MOVEM 2,@SYMVAL+166 MOVE 2,SYMVAL+166 MOVEM 1,1(2) MOVE 1,L0173 PUSHJ 15,SYMFNC+167 MOVE 3,L0174 MOVE 2,SYMVAL+163 MOVE 1,SYMVAL+164 HRRZI 12,161 HRRZI 13,3 PUSHJ 15,SYMFNC+161 HRRZI 1,2 PUSHJ 15,SYMFNC+168 POPJ 15,0 L0174: <4_31>+L0175 L0173: <8_31>+L0176 ; (!*ENTRY NONPOSITIVEINTEGERERROR EXPR 2) ; (!*ALLOC 0) ; (!*LAMBIND (REGISTERS (REG 2) (REG 1)) (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (MOVEM (REG 2) (INDIRECT (FLUID LAMBINDARGS!*))) ; (MOVE (REG 2) (FLUID LAMBINDARGS!*)) ; (MOVEM (REG 1) (INDEXED (REG 2) 1)) ; (MOVE (REG 1) (QUOTE [FN OFFENDER])) ; (PUSHJ (REG ST) (ENTRY LAMBIND)) ; (!*MOVE (QUOTE "a non-negative integer") (REG 3)) ; (MOVE (REG 3) (QUOTE "a non-negative integer")) ; (!*MOVE (!$FLUID FN) (REG 2)) ; (MOVE (REG 2) (!$FLUID FN)) ; (!*MOVE (!$FLUID OFFENDER) (REG 1)) ; (MOVE (REG 1) (!$FLUID OFFENDER)) ; (!*LINK TYPEERROR EXPR 3) ; (HRRZI (REG LINKREG) 161) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TYPEERROR)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID FN) (!$FLUID OFFENDER))) ; (HRRZI (REG 1) 2) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0180: 21 byte(7)97,32,110,111,110,45,110,101,103,97,116,105,118,101,32,105,110,116,101,103,101,114,0 L0181: 1 <30_31>+163 <30_31>+164 2 ; (!*ENTRY NONPOSITIVEINTEGERERROR EXPR 2) L0182: intern L0182 MOVEM 2,@SYMVAL+166 MOVE 2,SYMVAL+166 MOVEM 1,1(2) MOVE 1,L0178 PUSHJ 15,SYMFNC+167 MOVE 3,L0179 MOVE 2,SYMVAL+163 MOVE 1,SYMVAL+164 HRRZI 12,161 HRRZI 13,3 PUSHJ 15,SYMFNC+161 HRRZI 1,2 PUSHJ 15,SYMFNC+168 POPJ 15,0 L0179: <4_31>+L0180 L0178: <8_31>+L0181 end |
Added psl-1983/20-tests/sub2.rel version [583198a233].
cannot compute difference between binary files
Added psl-1983/20-tests/sub20.mac version [c4d31de54c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 JRST INIT20 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SETZM 1 JRST GETC20 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 JRST TIMC20 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC JRST PUTC20 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 JRST QUIT20 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT JRST PUTI20 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 1) L0003: intern L0003 HRRZI 1,1 PUSHJ 15,ERR20 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG HRRZI 1,2 PUSHJ 15,ERR20 ; (!*ENTRY !*WTIMES32 EXPR 2) L0004: intern L0004 IMUL 1,2 POPJ 15,0 end |
Added psl-1983/20-tests/sub3.init version [a7ffc6f8bf].
Added psl-1983/20-tests/sub3.mac version [c7c4d96907].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 extern L0183 extern L0184 extern L0185 extern L0186 ; (!*ENTRY GTHEAP EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 1) (REG 2)) ; (HRRZI (REG 2) 1) ; (!*MOVE (WVAR HEAPUPPERBOUND) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPUPPERBOUND)) ; (!*WDIFFERENCE (REG 1) (WVAR HEAPLAST)) ; (SUB (REG 1) (WVAR HEAPLAST)) ; (!*LINKE 1 WQUOTIENT EXPR 2) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (WVAR HEAPLAST) (WVAR HEAPPREVIOUSLAST)) ; (MOVE (REG T1) (WVAR HEAPLAST)) ; (MOVEM (REG T1) (WVAR HEAPPREVIOUSLAST)) ; (!*WPLUS2 (WVAR HEAPLAST) (REG 1)) ; (ADDM (REG 1) (WVAR HEAPLAST)) ; (!*JUMPWGEQ (LABEL G0006) (WVAR HEAPUPPERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPUPPERBOUND)) ; (CAML (REG T1) (WVAR HEAPLAST)) ; (JRST (LABEL G0006)) ; (!*LINK !%RECLAIM EXPR 0) ; (HRRZI (REG LINKREG) 172) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY !%RECLAIM)) ; (!*MOVE (WVAR HEAPLAST) (WVAR HEAPPREVIOUSLAST)) ; (MOVE (REG T1) (WVAR HEAPLAST)) ; (MOVEM (REG T1) (WVAR HEAPPREVIOUSLAST)) ; (!*WPLUS2 (WVAR HEAPLAST) (FRAME 1)) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (ADDM (REG T2) (WVAR HEAPLAST)) ; (!*JUMPWGEQ (LABEL G0006) (WVAR HEAPUPPERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPUPPERBOUND)) ; (CAML (REG T1) (WVAR HEAPLAST)) ; (JRST (LABEL G0006)) ; (!*MOVE (QUOTE "Heap space exhausted") (REG 1)) ; (MOVE (REG 1) (QUOTE "Heap space exhausted")) ; (!*LINK FATALERROR EXPR 1) ; (HRRZI (REG LINKREG) 157) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FATALERROR)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (WVAR HEAPPREVIOUSLAST) (REG 1)) ; (MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) L0188: 19 byte(7)72,101,97,112,32,115,112,97,99,101,32,101,120,104,97,117,115,116,101,100,0 1 ; (!*ENTRY GTHEAP EXPR 1) GTHEAP: intern GTHEAP PUSH 15,1 CAME 1,0 JRST L0189 HRRZI 2,1 MOVE 1,L0184 SUB 1,L0185 ADJSP 15,-1 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 POPJ 15,0 L0189: MOVE 6,L0185 MOVEM 6,L0186 ADDM 1,L0185 MOVE 6,L0184 CAML 6,L0185 JRST L0190 HRRZI 12,172 SETZM 13 PUSHJ 15,SYMFNC+172 MOVE 6,L0185 MOVEM 6,L0186 MOVE 7,0(15) ADDM 7,L0185 MOVE 6,L0184 CAML 6,L0185 JRST L0190 MOVE 1,L0187 HRRZI 12,157 HRRZI 13,1 PUSHJ 15,SYMFNC+157 L0190: MOVE 1,L0186 ADJSP 15,-1 POPJ 15,0 L0187: <4_31>+L0188 ; (!*ENTRY GTSTR EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (WCONST 5) (REG 2)) ; (HRRZI (REG 2) 5) ; (!*WPLUS2 (REG 1) (WCONST 6)) ; (ADDI (REG 1) 6) ; (!*LINK WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 171) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK GTHEAP EXPR 1) ; (HRRZI (REG LINKREG) 173) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTHEAP)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*MKITEM (REG 1) (WCONST 23)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 23 13)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST 0))) ; (MOVEM (REG 1) (INDIRECT (INDEXED (REG ST) -1))) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 3) (FRAME 2)) ; (ADD (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (MEMORY (REG 3) (WCONST 0))) ; (SETZM (INDEXED (REG 3) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY GTSTR EXPR 1) GTSTR: intern GTSTR ADJSP 15,3 MOVEM 1,0(15) HRRZI 2,5 ADDI 1,6 HRRZI 12,171 HRRZI 13,2 IDIV 1,2 MOVEM 1,-2(15) AOS 1 HRRZI 12,173 HRRZI 13,1 PUSHJ 15,SYMFNC+173 MOVEM 1,-1(15) MOVE 1,0(15) TLZ 1,253952 TLO 1,188416 MOVEM 1,@-1(15) MOVE 3,-2(15) ADD 3,-1(15) SETZM 0(3) MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY GTVECT EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 1) (WCONST 2)) ; (ADDI (REG 1) 2) ; (!*LINK GTHEAP EXPR 1) ; (HRRZI (REG LINKREG) 173) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTHEAP)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*MKITEM (REG 1) (WCONST 26)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 26 13)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST 0))) ; (MOVEM (REG 1) (INDIRECT (INDEXED (REG ST) -1))) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY GTVECT EXPR 1) GTVECT: intern GTVECT ADJSP 15,2 MOVEM 1,0(15) ADDI 1,2 HRRZI 12,173 HRRZI 13,1 PUSHJ 15,SYMFNC+173 MOVEM 1,-1(15) MOVE 1,0(15) TLZ 1,253952 TLO 1,212992 MOVEM 1,@-1(15) MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 ; (!*ENTRY GTWARRAY EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 GTVECT EXPR 1) ; (HRRZI (REG LINKREG) 175) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY GTVECT)) 1 ; (!*ENTRY GTWARRAY EXPR 1) L0191: intern L0191 HRRZI 12,175 HRRZI 13,1 JRST SYMFNC+175 ; (!*ENTRY GTID EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR NEXTSYMBOL) (REG 2)) ; (MOVE (REG 2) (WVAR NEXTSYMBOL)) ; (!*WPLUS2 (WVAR NEXTSYMBOL) (WCONST 1)) ; (AOS (WVAR NEXTSYMBOL)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY GTID EXPR 0) GTID: intern GTID MOVE 2,L0003 AOS L0003 MOVE 1,2 POPJ 15,0 ; (!*ENTRY HARDCONS EXPR 2) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 2) (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINK GTHEAP EXPR 1) ; (HRRZI (REG LINKREG) 173) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTHEAP)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 1) (MEMORY (REG 1) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (MOVEM (REG T1) (INDEXED (REG 1) 0)) ; (!*MOVE (FRAME 2) (MEMORY (REG 1) (WCONST 1))) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (MOVEM (REG T1) (INDEXED (REG 1) 1)) ; (!*MKITEM (REG 1) (WCONST 9)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 9 13)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY HARDCONS EXPR 2) L0192: intern L0192 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) HRRZI 1,2 HRRZI 12,173 HRRZI 13,1 PUSHJ 15,SYMFNC+173 MOVEM 1,-2(15) MOVE 6,0(15) MOVEM 6,0(1) MOVE 6,-1(15) MOVEM 6,1(1) TLZ 1,253952 TLO 1,73728 ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY CONS EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 HARDCONS EXPR 2) ; (HRRZI (REG LINKREG) 178) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY HARDCONS)) 2 ; (!*ENTRY CONS EXPR 2) CONS: intern CONS HRRZI 12,178 HRRZI 13,2 JRST SYMFNC+178 ; (!*ENTRY XCONS EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 3)) ; (MOVE (REG 3) (REG 2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*LINKE 0 HARDCONS EXPR 2) ; (HRRZI (REG LINKREG) 178) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY HARDCONS)) 2 ; (!*ENTRY XCONS EXPR 2) XCONS: intern XCONS MOVE 3,2 MOVE 2,1 MOVE 1,3 HRRZI 12,178 HRRZI 13,2 JRST SYMFNC+178 ; (!*ENTRY NCONS EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*LINKE 0 HARDCONS EXPR 2) ; (HRRZI (REG LINKREG) 178) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY HARDCONS)) 1 ; (!*ENTRY NCONS EXPR 1) NCONS: intern NCONS MOVE 2,0 HRRZI 12,178 HRRZI 13,2 JRST SYMFNC+178 ; (!*ENTRY MKVECT EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTINTYPE (LABEL G0004) (REG 1) POSINT) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 31) ; (JRST "L0193") ; (CAILE (REG T6) 0) ; (JRST (LABEL G0004)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPWGEQ (LABEL G0006) (REG 1) (WCONST -1)) ; (CAML (REG 1) (LIT (FULLWORD -1))) ; (JRST (LABEL G0006)) ; (!*MOVE (QUOTE "A vector with fewer than zero elements cannot be allocated") (REG 1)) ; (MOVE (REG 1) (QUOTE "A vector with fewer than zero elements cannot be allocated")) ; (!*LINKE 3 STDERROR EXPR 1) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY STDERROR)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*LINK GTVECT EXPR 1) ; (HRRZI (REG LINKREG) 175) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTVECT)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (FRAME 3)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -2)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0011)) ; (!*JUMPWGREATERP (LABEL G0010) (FRAME 3) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAMLE (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0010)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 2) (FRAME 2)) ; (ADD (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 1))) ; (MOVEM (REG 1) (INDEXED (REG 2) 1)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0011)) ; (JRST (LABEL G0011)) ; (!*LBL (LABEL G0010)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*MKITEM (REG 1) (WCONST 8)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 8 13)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE MKVECT) (REG 2)) ; (MOVE (REG 2) (QUOTE MKVECT)) ; (!*LINKE 3 NONINTEGERERROR EXPR 2) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 169) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY NONINTEGERERROR)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) ; (FULLWORD -1) L0198: 57 byte(7)65,32,118,101,99,116,111,114,32,119,105,116,104,32,102,101,119,101,114,32,116,104,97,110,32,122,101,114,111,32,101,108,101,109,101,110,116,115,32,99,97,110,110,111,116,32,98,101,32,97,108,108,111,99,97,116,101,100,0 1 ; (!*ENTRY MKVECT EXPR 1) MKVECT: intern MKVECT ADJSP 15,3 MOVEM 1,0(15) LDB 11,L0194 CAIN 11,31 JRST L0193 CAILE 11,0 JRST L0199 L0193: MOVEM 1,0(15) CAML 1,L0195 JRST L0200 MOVE 1,L0196 ADJSP 15,-3 HRRZI 12,158 HRRZI 13,1 JRST SYMFNC+158 L0200: MOVEM 0,-1(15) HRRZI 12,175 HRRZI 13,1 PUSHJ 15,SYMFNC+175 MOVEM 1,-1(15) MOVEM 0,-2(15) SETZM -2(15) L0201: MOVE 6,-2(15) CAMLE 6,0(15) JRST L0202 MOVE 2,-2(15) ADD 2,-1(15) MOVE 1,0 MOVEM 1,1(2) AOS -2(15) JRST L0201 L0202: MOVE 1,-1(15) TLZ 1,253952 TLO 1,65536 JRST L0203 L0199: MOVE 2,L0197 ADJSP 15,-3 HRRZI 12,169 HRRZI 13,2 JRST SYMFNC+169 L0203: ADJSP 15,-3 POPJ 15,0 L0194: point 5,1,4 L0195: -1 L0197: <30_31>+182 L0196: <4_31>+L0198 ; (!*ENTRY LIST2 EXPR 2) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*LINK NCONS EXPR 1) ; (HRRZI (REG LINKREG) 181) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY NCONS)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINKE 1 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) 2 ; (!*ENTRY LIST2 EXPR 2) LIST2: intern LIST2 PUSH 15,1 MOVE 1,2 HRRZI 12,181 HRRZI 13,1 PUSHJ 15,SYMFNC+181 MOVE 2,0(15) ADJSP 15,-1 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 ; (!*ENTRY LIST3 EXPR 3) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (REG 3) (REG 2)) ; (MOVE (REG 2) (REG 3)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK LIST2 EXPR 2) ; (HRRZI (REG LINKREG) 183) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LIST2)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINKE 2 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) 3 ; (!*ENTRY LIST3 EXPR 3) LIST3: intern LIST3 PUSH 15,2 PUSH 15,1 MOVE 2,3 MOVE 1,-1(15) HRRZI 12,183 HRRZI 13,2 PUSHJ 15,SYMFNC+183 MOVE 2,0(15) ADJSP 15,-2 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 ; (!*ENTRY LIST4 EXPR 4) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 4) (REG 3)) ; (MOVE (REG 3) (REG 4)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK LIST3 EXPR 3) ; (HRRZI (REG LINKREG) 184) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY LIST3)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINKE 3 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) 4 ; (!*ENTRY LIST4 EXPR 4) LIST4: intern LIST4 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 3,4 MOVE 2,-2(15) MOVE 1,-1(15) HRRZI 12,184 HRRZI 13,3 PUSHJ 15,SYMFNC+184 MOVE 2,0(15) ADJSP 15,-3 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 ; (!*ENTRY LIST5 EXPR 5) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 4) (FRAME 4)) ; (MOVEM (REG 4) (INDEXED (REG ST) -3)) ; (!*MOVE (REG 5) (REG 4)) ; (MOVE (REG 4) (REG 5)) ; (!*MOVE (FRAME 4) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK LIST4 EXPR 4) ; (HRRZI (REG LINKREG) 185) ; (HRRZI (REG NARGREG) 4) ; (PUSHJ (REG ST) (ENTRY LIST4)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINKE 4 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 4)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) 5 ; (!*ENTRY LIST5 EXPR 5) LIST5: intern LIST5 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVE 4,5 MOVE 3,-3(15) MOVE 2,-2(15) MOVE 1,-1(15) HRRZI 12,185 HRRZI 13,4 PUSHJ 15,SYMFNC+185 MOVE 2,0(15) ADJSP 15,-4 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 ; (!*ENTRY MKSTRING EXPR 2) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (FRAME 3)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE NIL) (FRAME 4)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -3)) ; (!*JUMPNOTINTYPE (LABEL G0005) (REG 1) POSINT) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 31) ; (JRST "L0204") ; (CAILE (REG T6) 0) ; (JRST (LABEL G0005)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (QUOTE MKSTRING) (REG 2)) ; (MOVE (REG 2) (QUOTE MKSTRING)) ; (!*LINKE 5 NONINTEGERERROR EXPR 2) ; (ADJSP (REG ST) (MINUS 5)) ; (HRRZI (REG LINKREG) 169) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY NONINTEGERERROR)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWGEQ (LABEL G0008) (FRAME 3) (WCONST -1)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAML (REG T1) (LIT (FULLWORD -1))) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE MKSTRING) (REG 2)) ; (MOVE (REG 2) (QUOTE MKSTRING)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 5 NONPOSITIVEINTEGERERROR EXPR 2) ; (ADJSP (REG ST) (MINUS 5)) ; (HRRZI (REG LINKREG) 170) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY NONPOSITIVEINTEGERERROR)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK GTSTR EXPR 1) ; (HRRZI (REG LINKREG) 174) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTSTR)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (WCONST 0) (FRAME 5)) ; (SETZM (INDEXED (REG ST) -4)) ; (!*LBL (LABEL G0015)) ; (!*JUMPWGREATERP (LABEL G0014) (FRAME 5) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) -4)) ; (CAMLE (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0014)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 5) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*WPLUS2 (FRAME 5) (WCONST 1)) ; (AOS (INDEXED (REG ST) -4)) ; (!*JUMP (LABEL G0015)) ; (JRST (LABEL G0015)) ; (!*LBL (LABEL G0014)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*MKITEM (REG 1) (WCONST 4)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 4 13)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) ; (FULLWORD -1) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 2 ; (!*ENTRY MKSTRING EXPR 2) L0209: intern L0209 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L0205 CAIN 11,31 JRST L0204 CAILE 11,0 JRST L0210 L0204: MOVEM 1,-2(15) JRST L0211 L0210: MOVE 2,L0206 ADJSP 15,-5 HRRZI 12,169 HRRZI 13,2 JRST SYMFNC+169 L0211: MOVE 6,-2(15) CAML 6,L0207 JRST L0212 MOVE 2,L0206 MOVE 1,0(15) ADJSP 15,-5 HRRZI 12,170 HRRZI 13,2 JRST SYMFNC+170 L0212: MOVE 1,-2(15) HRRZI 12,174 HRRZI 13,1 PUSHJ 15,SYMFNC+174 MOVEM 1,-3(15) SETZM -4(15) L0213: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L0214 MOVE 3,-1(15) MOVE 2,-4(15) MOVE 1,-3(15) AOS 1 HRRZI 12,187 HRRZI 13,3 ADJBP 2,L0208 DPB 3,2 AOS -4(15) JRST L0213 L0214: MOVE 1,-3(15) TLZ 1,253952 TLO 1,32768 ADJSP 15,-5 POPJ 15,0 L0205: point 5,1,4 L0207: -1 L0208: point 7,0(1),6 L0206: <30_31>+188 end |
Added psl-1983/20-tests/sub3.rel version [d8fbd61bb1].
cannot compute difference between binary files
Added psl-1983/20-tests/sub4.init version [a7ffc6f8bf].
Added psl-1983/20-tests/sub4.mac version [8047ba342b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY EQSTR EXPR 2) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*FIELD (REG 2) (REG 2) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 2) (REG 2)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*SIGNEDFIELD (REG 3) (MEMORY (REG 1) (WCONST 0)) (WCONST 18) (WCONST 18)) ; (HRRE (REG 3) (INDEXED (REG 1) 0)) ; (!*MOVE (REG 3) (FRAME 1)) ; (MOVEM (REG 3) (INDEXED (REG ST) 0)) ; (!*SIGNEDFIELD (REG 4) (MEMORY (REG 2) (WCONST 0)) (WCONST 18) (WCONST 18)) ; (HRRE (REG 4) (INDEXED (REG 2) 0)) ; (!*JUMPEQ (LABEL G0004) (REG 3) (REG 4)) ; (CAMN (REG 3) (REG 4)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWGEQ (LABEL G0008) (FRAME 1) (WCONST 0)) ; (SKIPL (INDEXED (REG ST) 0)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*JUMPEQ (LABEL G0011) (REG 5) (REG 1)) ; (CAMN (REG 5) (REG 1)) ; (JRST (LABEL G0011)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0011)) ; (!*WPLUS2 (FRAME 1) (WCONST -1)) ; (SOS (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 2 ; (!*ENTRY EQSTR EXPR 2) EQSTR: intern EQSTR ADJSP 15,3 HRRZ 1,1 MOVEM 1,-2(15) HRRZ 2,2 MOVEM 2,-1(15) HRRE 3,0(1) MOVEM 3,0(15) HRRE 4,0(2) CAMN 3,4 JRST L0216 MOVE 1,0 JRST L0217 L0216: SKIPL 0(15) JRST L0218 MOVE 1,SYMVAL+84 JRST L0217 L0218: MOVE 2,0(15) MOVE 1,-2(15) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L0215 LDB 1,2 MOVE 5,1 MOVE 2,0(15) MOVE 1,-1(15) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L0215 LDB 1,2 CAMN 5,1 JRST L0219 MOVE 1,0 JRST L0217 L0219: SOS 0(15) JRST L0216 L0217: ADJSP 15,-3 POPJ 15,0 L0215: point 7,0(1),6 extern BUFFER ; (!*ENTRY INITREAD EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (!$FLUID !*RAISE)) ; (MOVEM (REG 1) (!$FLUID !*RAISE)) ; (!*MOVE (WCONST 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*MOVE (REG 1) (!$FLUID TOK!*)) ; (MOVEM (REG 1) (!$FLUID TOK!*)) ; (!*MOVE (WCONST 2) (!$FLUID TOKTYPE!*)) ; (HRRZI (REG T1) 2) ; (MOVEM (REG T1) (!$FLUID TOKTYPE!*)) ; (!*JUMPEQ (LABEL G0004) (QUOTE NIL) (!$FLUID DEBUG)) ; (CAMN (REG NIL) (!$FLUID DEBUG)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE "NextSymbol =") (REG 1)) ; (MOVE (REG 1) (QUOTE "NextSymbol =")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (WVAR NEXTSYMBOL) (REG 1)) ; (MOVE (REG 1) (WVAR NEXTSYMBOL)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0221: 11 byte(7)78,101,120,116,83,121,109,98,111,108,32,61,0 0 ; (!*ENTRY INITREAD EXPR 0) L0222: intern L0222 MOVE 1,0 MOVEM 1,SYMVAL+191 HRRZI 1,32 MOVEM 1,SYMVAL+192 MOVE 1,0 MOVEM 1,SYMVAL+193 HRRZI 6,2 MOVEM 6,SYMVAL+194 CAMN 0,SYMVAL+195 JRST L0223 MOVE 1,L0220 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,L0003 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 L0223: MOVE 1,0 POPJ 15,0 L0220: <4_31>+L0221 ; (!*ENTRY SETRAISE EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (!$FLUID !*RAISE)) ; (MOVEM (REG 1) (!$FLUID !*RAISE)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SETRAISE EXPR 1) L0224: intern L0224 MOVEM 1,SYMVAL+191 POPJ 15,0 ; (!*ENTRY RATOM EXPR 0) ; (!*ALLOC 1) ; (ADJSP (REG ST) 1) ; (!*LINK CLEARWHITE EXPR 0) ; (HRRZI (REG LINKREG) 197) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY CLEARWHITE)) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 37) (!$FLUID CH!*)) ; (MOVE (REG T2) (!$FLUID CH!*)) ; (CAIE (REG T2) 37) ; (JRST (LABEL G0004)) ; (!*LINK CLEARCOMMENT EXPR 0) ; (HRRZI (REG LINKREG) 198) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY CLEARCOMMENT)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0007) (WCONST 34) (!$FLUID CH!*)) ; (MOVE (REG T2) (!$FLUID CH!*)) ; (CAIE (REG T2) 34) ; (JRST (LABEL G0007)) ; (!*MOVE (WCONST 0) (!$FLUID TOKTYPE!*)) ; (SETZM (!$FLUID TOKTYPE!*)) ; (!*LINK READSTR EXPR 0) ; (HRRZI (REG LINKREG) 199) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READSTR)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 1) (!$FLUID TOK!*)) ; (MOVEM (REG 1) (!$FLUID TOK!*)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0007)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*LINK DIGITP EXPR 1) ; (HRRZI (REG LINKREG) 200) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DIGITP)) ; (!*JUMPEQ (LABEL G0012) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0012)) ; (!*MOVE (WCONST 1) (!$FLUID TOKTYPE!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID TOKTYPE!*)) ; (!*LINK READINT EXPR 0) ; (HRRZI (REG LINKREG) 201) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READINT)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 1) (!$FLUID TOK!*)) ; (MOVEM (REG 1) (!$FLUID TOK!*)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0012)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*LINK ALPHAESCP EXPR 1) ; (HRRZI (REG LINKREG) 202) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ALPHAESCP)) ; (!*JUMPEQ (LABEL G0018) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0018)) ; (!*MOVE (WCONST 2) (!$FLUID TOKTYPE!*)) ; (HRRZI (REG T1) 2) ; (MOVEM (REG T1) (!$FLUID TOKTYPE!*)) ; (!*LINK READID EXPR 0) ; (HRRZI (REG LINKREG) 203) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READID)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 1) (!$FLUID TOK!*)) ; (MOVEM (REG 1) (!$FLUID TOK!*)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0018)) ; (!*MOVE (WCONST 3) (!$FLUID TOKTYPE!*)) ; (HRRZI (REG T1) 3) ; (MOVEM (REG T1) (!$FLUID TOKTYPE!*)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*MOVE (REG 1) (!$FLUID TOK!*)) ; (MOVEM (REG 1) (!$FLUID TOK!*)) ; (!*MOVE (WCONST 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*MOVE (!$FLUID TOK!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID TOK!*)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY RATOM EXPR 0) RATOM: intern RATOM ADJSP 15,1 HRRZI 12,197 SETZM 13 PUSHJ 15,SYMFNC+197 MOVE 7,SYMVAL+192 CAIE 7,37 JRST L0225 HRRZI 12,198 SETZM 13 PUSHJ 15,SYMFNC+198 L0225: MOVE 7,SYMVAL+192 CAIE 7,34 JRST L0226 SETZM SYMVAL+194 HRRZI 12,199 SETZM 13 PUSHJ 15,SYMFNC+199 MOVEM 1,0(15) MOVEM 1,SYMVAL+193 JRST L0227 L0226: MOVE 1,SYMVAL+192 HRRZI 12,200 HRRZI 13,1 PUSHJ 15,SYMFNC+200 CAMN 1,0 JRST L0228 HRRZI 6,1 MOVEM 6,SYMVAL+194 HRRZI 12,201 SETZM 13 PUSHJ 15,SYMFNC+201 MOVEM 1,0(15) MOVEM 1,SYMVAL+193 JRST L0227 L0228: MOVE 1,SYMVAL+192 HRRZI 12,202 HRRZI 13,1 PUSHJ 15,SYMFNC+202 CAMN 1,0 JRST L0229 HRRZI 6,2 MOVEM 6,SYMVAL+194 HRRZI 12,203 SETZM 13 PUSHJ 15,SYMFNC+203 MOVEM 1,0(15) MOVEM 1,SYMVAL+193 JRST L0227 L0229: HRRZI 6,3 MOVEM 6,SYMVAL+194 MOVE 1,SYMVAL+192 TLZ 1,253952 TLO 1,245760 MOVEM 1,SYMVAL+193 HRRZI 1,32 MOVEM 1,SYMVAL+192 MOVE 1,SYMVAL+193 L0227: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY CLEARWHITE EXPR 0) ; (!*ALLOC 0) ; (!*LBL (LABEL G0002)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*LINK WHITEP EXPR 1) ; (HRRZI (REG LINKREG) 205) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY WHITEP)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0005)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) 0 ; (!*ENTRY CLEARWHITE EXPR 0) L0230: intern L0230 L0231: MOVE 1,SYMVAL+192 HRRZI 12,205 HRRZI 13,1 PUSHJ 15,SYMFNC+205 CAME 1,0 JRST L0232 MOVE 1,0 POPJ 15,0 L0232: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,SYMVAL+192 JRST L0231 ; (!*ENTRY CLEARCOMMENT EXPR 0) ; (!*ALLOC 0) ; (!*LBL (LABEL G0002)) ; (!*JUMPNOTEQ (LABEL G0005) (WCONST 10) (!$FLUID CH!*)) ; (MOVE (REG T2) (!$FLUID CH!*)) ; (CAIE (REG T2) 10) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0005)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0003)) ; (!*LINKE 0 CLEARWHITE EXPR 0) ; (HRRZI (REG LINKREG) 197) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY CLEARWHITE)) 0 ; (!*ENTRY CLEARCOMMENT EXPR 0) L0233: intern L0233 L0234: MOVE 7,SYMVAL+192 CAIE 7,10 JRST L0235 MOVE 1,0 JRST L0236 L0235: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,SYMVAL+192 JRST L0234 L0236: HRRZI 12,197 SETZM 13 JRST SYMFNC+197 ; (!*ENTRY READINT EXPR 0) ; (!*ALLOC 1) ; (ADJSP (REG ST) 1) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*WPLUS2 (REG 1) (WCONST -48)) ; (SUBI (REG 1) (MINUS -48)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0005)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*LINK DIGITP EXPR 1) ; (HRRZI (REG LINKREG) 200) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DIGITP)) ; (!*JUMPEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINK LONGTIMES EXPR 2) ; (HRRZI (REG LINKREG) 207) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LONGTIMES)) ; (!*MOVE (!$FLUID CH!*) (REG 2)) ; (MOVE (REG 2) (!$FLUID CH!*)) ; (!*WPLUS2 (REG 2) (REG 1)) ; (ADDM (REG 1) (REG 2)) ; (!*WPLUS2 (REG 2) (WCONST -48)) ; (SUBI (REG 2) (MINUS -48)) ; (!*MOVE (REG 2) (FRAME 1)) ; (MOVEM (REG 2) (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*MKITEM (REG 1) (WCONST 0)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 0 13)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY READINT EXPR 0) L0237: intern L0237 ADJSP 15,1 MOVE 1,SYMVAL+192 SUBI 1,48 MOVEM 1,0(15) L0238: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,SYMVAL+192 HRRZI 12,200 HRRZI 13,1 PUSHJ 15,SYMFNC+200 CAMN 1,0 JRST L0239 MOVE 2,0(15) HRRZI 1,10 HRRZI 12,207 HRRZI 13,2 PUSHJ 15,SYMFNC+207 MOVE 2,SYMVAL+192 ADDM 1,2 SUBI 2,48 MOVEM 2,0(15) JRST L0238 L0239: MOVE 1,0(15) TLZ 1,253952 TLO 1,0 ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY BUFFERTOSTRING EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK GTSTR EXPR 1) ; (HRRZI (REG LINKREG) 174) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GTSTR)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0006)) ; (!*JUMPWGREATERP (LABEL G0005) (FRAME 3) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAMLE (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (WCONST (PLUS2 1 (WCONST BUFFER))) (REG 1)) ; (HRRZI (REG 1) (IMMEDIATE (PLUS2 1 (WCONST BUFFER)))) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*MKITEM (REG 1) (WCONST 4)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 4 13)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 1 ; (!*ENTRY BUFFERTOSTRING EXPR 1) L0241: intern L0241 ADJSP 15,3 MOVEM 1,0(15) HRRZI 12,174 HRRZI 13,1 PUSHJ 15,SYMFNC+174 MOVEM 1,-1(15) SETZM -2(15) L0242: MOVE 6,-2(15) CAMLE 6,0(15) JRST L0243 MOVE 2,-2(15) HRRZI 1,1+BUFFER HRRZI 12,147 HRRZI 13,2 ADJBP 2,L0240 LDB 1,2 MOVE 3,1 MOVE 2,-2(15) MOVE 1,-1(15) AOS 1 HRRZI 12,187 HRRZI 13,3 ADJBP 2,L0240 DPB 3,2 AOS -2(15) JRST L0242 L0243: MOVE 1,-1(15) TLZ 1,253952 TLO 1,32768 ADJSP 15,-3 POPJ 15,0 L0240: point 7,0(1),6 ; (!*ENTRY READSTR EXPR 0) ; (!*PUSH (WCONST -1)) ; (PUSH (REG ST) (LIT (FULLWORD -1))) ; (!*LBL (LABEL G0005)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*JUMPEQ (LABEL G0004) (REG 1) (WCONST 34)) ; (CAIN (REG 1) 34) ; (JRST (LABEL G0004)) ; (!*WPLUS2 (FRAME 1) (WCONST 1)) ; (AOS (INDEXED (REG ST) 0)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (WCONST (PLUS2 1 (WCONST BUFFER))) (REG 1)) ; (HRRZI (REG 1) (IMMEDIATE (PLUS2 1 (WCONST BUFFER)))) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (WCONST 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 BUFFERTOSTRING EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 208) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY BUFFERTOSTRING)) ; (FULLWORD -1) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 0 ; (!*ENTRY READSTR EXPR 0) L0246: intern L0246 PUSH 15,L0244 L0247: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,SYMVAL+192 CAIN 1,34 JRST L0248 AOS 0(15) MOVE 3,1 MOVE 2,0(15) HRRZI 1,1+BUFFER HRRZI 12,187 HRRZI 13,3 ADJBP 2,L0245 DPB 3,2 JRST L0247 L0248: HRRZI 1,32 MOVEM 1,SYMVAL+192 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,208 HRRZI 13,1 JRST SYMFNC+208 L0244: -1 L0245: point 7,0(1),6 ; (!*ENTRY READID EXPR 0) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (QUOTE NIL) (FRAME 2)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE NIL) (FRAME 3)) ; (MOVEM (REG NIL) (INDEXED (REG ST) -2)) ; (!*MOVE (WCONST 0) (FRAME 1)) ; (SETZM (INDEXED (REG ST) 0)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*LINK RAISECHAR EXPR 1) ; (HRRZI (REG LINKREG) 209) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RAISECHAR)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (WCONST 0) (REG 2)) ; (SETZM (REG 2)) ; (!*MOVE (WCONST (PLUS2 1 (WCONST BUFFER))) (REG 1)) ; (HRRZI (REG 1) (IMMEDIATE (PLUS2 1 (WCONST BUFFER)))) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*LBL (LABEL G0006)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (!$FLUID CH!*)) ; (MOVEM (REG 1) (!$FLUID CH!*)) ; (!*LINK ALPHANUMESCP EXPR 1) ; (HRRZI (REG LINKREG) 210) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ALPHANUMESCP)) ; (!*JUMPEQ (LABEL G0005) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0005)) ; (!*WPLUS2 (FRAME 1) (WCONST 1)) ; (AOS (INDEXED (REG ST) 0)) ; (!*MOVE (!$FLUID CH!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID CH!*)) ; (!*LINK RAISECHAR EXPR 1) ; (HRRZI (REG LINKREG) 209) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RAISECHAR)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (WCONST (PLUS2 1 (WCONST BUFFER))) (REG 1)) ; (HRRZI (REG 1) (IMMEDIATE (PLUS2 1 (WCONST BUFFER)))) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK BUFFERTOSTRING EXPR 1) ; (HRRZI (REG LINKREG) 208) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY BUFFERTOSTRING)) ; (!*LINKE 3 INTERN EXPR 1) ; (ADJSP (REG ST) (MINUS 3)) ; (HRRZI (REG LINKREG) 211) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INTERN)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 0 ; (!*ENTRY READID EXPR 0) READID: intern READID ADJSP 15,3 MOVEM 0,-1(15) MOVEM 0,-2(15) SETZM 0(15) MOVE 1,SYMVAL+192 HRRZI 12,209 HRRZI 13,1 PUSHJ 15,SYMFNC+209 MOVE 3,1 SETZM 2 HRRZI 1,1+BUFFER HRRZI 12,187 HRRZI 13,3 ADJBP 2,L0249 DPB 3,2 L0250: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,SYMVAL+192 HRRZI 12,210 HRRZI 13,1 PUSHJ 15,SYMFNC+210 CAMN 1,0 JRST L0251 AOS 0(15) MOVE 1,SYMVAL+192 HRRZI 12,209 HRRZI 13,1 PUSHJ 15,SYMFNC+209 MOVE 3,1 MOVE 2,0(15) HRRZI 1,1+BUFFER HRRZI 12,187 HRRZI 13,3 ADJBP 2,L0249 DPB 3,2 JRST L0250 L0251: MOVE 1,0(15) HRRZI 12,208 HRRZI 13,1 PUSHJ 15,SYMFNC+208 ADJSP 15,-3 HRRZI 12,211 HRRZI 13,1 JRST SYMFNC+211 L0249: point 7,0(1),6 ; (!*ENTRY RAISECHAR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK ESCAPEP EXPR 1) ; (HRRZI (REG LINKREG) 212) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ESCAPEP)) ; (!*JUMPEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*LINKE 1 GETC EXPR 0) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY GETC)) ; (!*LBL (LABEL G0004)) ; (!*JUMPEQ (LABEL G0009) (QUOTE NIL) (!$FLUID !*RAISE)) ; (CAMN (REG NIL) (!$FLUID !*RAISE)) ; (JRST (LABEL G0009)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK ALPHAP EXPR 1) ; (HRRZI (REG LINKREG) 213) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ALPHAP)) ; (!*JUMPEQ (LABEL G0009) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0009)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LOWERCASEP EXPR 1) ; (HRRZI (REG LINKREG) 214) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY LOWERCASEP)) ; (!*JUMPEQ (LABEL G0009) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0009)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 1) (WCONST -32)) ; (SUBI (REG 1) (MINUS -32)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0009)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY RAISECHAR EXPR 1) L0252: intern L0252 PUSH 15,1 HRRZI 12,212 HRRZI 13,1 PUSHJ 15,SYMFNC+212 CAMN 1,0 JRST L0253 ADJSP 15,-1 HRRZI 12,206 SETZM 13 JRST SYMFNC+206 L0253: CAMN 0,SYMVAL+191 JRST L0254 MOVE 1,0(15) HRRZI 12,213 HRRZI 13,1 PUSHJ 15,SYMFNC+213 CAMN 1,0 JRST L0254 MOVE 1,0(15) HRRZI 12,214 HRRZI 13,1 PUSHJ 15,SYMFNC+214 CAMN 1,0 JRST L0254 MOVE 1,0(15) SUBI 1,32 JRST L0255 L0254: MOVE 1,0(15) L0255: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY INTERN EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIE (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*FIELD (REG 2) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 2) (REG 1)) ; (!*MOVE (MEMORY (REG 2) (WCONST SYMNAM)) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG 2) (IMMEDIATE SYMNAM))) ; (MOVEM (REG T1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LOOKUPID EXPR 1) ; (HRRZI (REG LINKREG) 215) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY LOOKUPID)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*JUMPEQ (LABEL G0007) (REG 2) (QUOTE NIL)) ; (CAMN (REG 2) (REG NIL)) ; (JRST (LABEL G0007)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MKITEM (REG 1) (WCONST 30)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 30 13)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0007)) ; (!*LINK GTID EXPR 0) ; (HRRZI (REG LINKREG) 177) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GTID)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMPEQ (LABEL G0012) (QUOTE NIL) (!$FLUID DEBUG)) ; (CAMN (REG NIL) (!$FLUID DEBUG)) ; (JRST (LABEL G0012)) ; (!*MOVE (QUOTE "New ID# ") (REG 1)) ; (MOVE (REG 1) (QUOTE "New ID# ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*LBL (LABEL G0012)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINKE 2 INITNEWID EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 216) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INITNEWID)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) L0258: 7 byte(7)78,101,119,32,73,68,35,32,0 1 ; (!*ENTRY INTERN EXPR 1) INTERN: intern INTERN ADJSP 15,2 MOVEM 1,0(15) LDB 11,L0256 CAIE 11,30 JRST L0259 HRRZ 2,1 MOVE 6,SYMNAM(2) MOVEM 6,0(15) L0259: MOVE 1,0(15) HRRZI 12,215 HRRZI 13,1 PUSHJ 15,SYMFNC+215 MOVE 2,1 MOVEM 2,-1(15) CAMN 2,0 JRST L0260 MOVE 1,2 TLZ 1,253952 TLO 1,245760 JRST L0261 L0260: HRRZI 12,177 SETZM 13 PUSHJ 15,SYMFNC+177 MOVEM 1,-1(15) CAMN 0,SYMVAL+195 JRST L0262 MOVE 1,L0257 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 L0262: MOVE 2,0(15) MOVE 1,-1(15) ADJSP 15,-2 HRRZI 12,216 HRRZI 13,2 JRST SYMFNC+216 L0261: ADJSP 15,-2 POPJ 15,0 L0256: point 5,1,4 L0257: <4_31>+L0258 ; (!*ENTRY INITNEWID EXPR 2) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (QUOTE NIL) (REG 3)) ; (MOVE (REG 3) (REG NIL)) ; (!*MOVE (REG 3) (MEMORY (REG 1) (WCONST SYMVAL))) ; (MOVEM (REG 3) (INDEXED (REG 1) (IMMEDIATE SYMVAL))) ; (!*MOVE (QUOTE NIL) (REG 4)) ; (MOVE (REG 4) (REG NIL)) ; (!*MOVE (REG 4) (MEMORY (REG 1) (WCONST SYMPRP))) ; (MOVEM (REG 4) (INDEXED (REG 1) (IMMEDIATE SYMPRP))) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MKITEM (REG 1) (WCONST 4)) ; (TLZ (REG 1) 253952) ; (TLO (REG 1) (LSH 4 13)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST SYMNAM))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE SYMNAM))) ; (!*MOVE (FRAME 1) (REG 5)) ; (MOVE (REG 5) (INDEXED (REG ST) 0)) ; (!*MKITEM (REG 5) (WCONST 30)) ; (TLZ (REG 5) 253952) ; (TLO (REG 5) (LSH 30 13)) ; (!*MOVE (REG 5) (FRAME 1)) ; (MOVEM (REG 5) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 5) (REG 1)) ; (MOVE (REG 1) (REG 5)) ; (!*LINK MAKEFUNBOUND EXPR 1) ; (HRRZI (REG LINKREG) 217) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MAKEFUNBOUND)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY INITNEWID EXPR 2) L0263: intern L0263 PUSH 15,2 PUSH 15,1 MOVE 3,0 MOVEM 3,SYMVAL(1) MOVE 4,0 MOVEM 4,SYMPRP(1) MOVE 1,2 TLZ 1,253952 TLO 1,32768 MOVE 7,0(15) MOVEM 1,SYMNAM(7) MOVE 5,0(15) TLZ 5,253952 TLO 5,245760 MOVEM 5,0(15) MOVE 1,5 HRRZI 12,217 HRRZI 13,1 PUSHJ 15,SYMFNC+217 MOVE 1,0(15) ADJSP 15,-2 POPJ 15,0 ; (!*ENTRY LOOKUPID EXPR 1) ; (!*PUSH (WVAR NEXTSYMBOL)) ; (PUSH (REG ST) (WVAR NEXTSYMBOL)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPEQ (LABEL G0004) (QUOTE NIL) (!$FLUID DEBUG)) ; (CAMN (REG NIL) (!$FLUID DEBUG)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE "Lookup string=") (REG 1)) ; (MOVE (REG 1) (QUOTE "Lookup string=")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1STRING EXPR 1) ; (HRRZI (REG LINKREG) 131) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1STRING)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWGREATERP (LABEL G0008) (FRAME 2) (WCONST 0)) ; (SKIPLE (INDEXED (REG ST) -1)) ; (JRST (LABEL G0008)) ; (!*JUMPEQ (LABEL G0010) (QUOTE NIL) (!$FLUID DEBUG)) ; (CAMN (REG NIL) (!$FLUID DEBUG)) ; (JRST (LABEL G0010)) ; (!*MOVE (QUOTE "Not Found in LookupId") (REG 1)) ; (MOVE (REG 1) (QUOTE "Not Found in LookupId")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LBL (LABEL G0010)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0008)) ; (!*WPLUS2 (FRAME 2) (WCONST -1)) ; (SOS (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (MEMORY (FRAME 2) (WCONST SYMNAM)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE SYMNAM))) ; (!*LINK EQSTR EXPR 2) ; (HRRZI (REG LINKREG) 189) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY EQSTR)) ; (!*JUMPEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*JUMPEQ (LABEL G0018) (QUOTE NIL) (!$FLUID DEBUG)) ; (CAMN (REG NIL) (!$FLUID DEBUG)) ; (JRST (LABEL G0018)) ; (!*MOVE (QUOTE "Found In LookUpId=") (REG 1)) ; (MOVE (REG 1) (QUOTE "Found In LookUpId=")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*LBL (LABEL G0018)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) L0267: 17 byte(7)70,111,117,110,100,32,73,110,32,76,111,111,107,85,112,73,100,61,0 L0268: 20 byte(7)78,111,116,32,70,111,117,110,100,32,105,110,32,76,111,111,107,117,112,73,100,0 L0269: 13 byte(7)76,111,111,107,117,112,32,115,116,114,105,110,103,61,0 1 ; (!*ENTRY LOOKUPID EXPR 1) L0270: intern L0270 PUSH 15,L0003 PUSH 15,1 CAMN 0,SYMVAL+195 JRST L0271 MOVE 1,L0264 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,131 HRRZI 13,1 PUSHJ 15,SYMFNC+131 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 L0271: SKIPLE -1(15) JRST L0272 CAMN 0,SYMVAL+195 JRST L0273 MOVE 1,L0265 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 L0273: MOVE 1,0 JRST L0274 L0272: SOS -1(15) MOVE 2,0(15) MOVE 1,-1(15) MOVE 1,SYMNAM(1) HRRZI 12,189 HRRZI 13,2 PUSHJ 15,SYMFNC+189 CAMN 1,0 JRST L0271 CAMN 0,SYMVAL+195 JRST L0275 MOVE 1,L0266 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-1(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 L0275: MOVE 1,-1(15) L0274: ADJSP 15,-2 POPJ 15,0 L0266: <4_31>+L0267 L0265: <4_31>+L0268 L0264: <4_31>+L0269 ; (!*ENTRY WHITEP EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPEQ (LABEL G0004) (REG 1) (WCONST 32)) ; (CAIN (REG 1) 32) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*LBL (LABEL G0005)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPEQ (LABEL G0006) (REG 2) (WCONST 10)) ; (CAIN (REG 2) 10) ; (JRST (LABEL G0006)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0006)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPEQ (LABEL G0007) (REG 2) (WCONST 9)) ; (CAIN (REG 2) 9) ; (JRST (LABEL G0007)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0007)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPEQ (LABEL G0008) (REG 2) (WCONST 10)) ; (CAIN (REG 2) 10) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0008)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPEQ (LABEL G0009) (REG 2) (WCONST 12)) ; (CAIN (REG 2) 12) ; (JRST (LABEL G0009)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0009)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPEQ (LABEL G0001) (REG 2) (WCONST 13)) ; (CAIN (REG 2) 13) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY WHITEP EXPR 1) WHITEP: intern WHITEP MOVE 2,1 CAIN 1,32 JRST L0276 MOVE 1,0 JRST L0277 L0276: MOVE 1,SYMVAL+84 L0277: CAME 1,0 JRST L0278 MOVE 1,SYMVAL+84 CAIN 2,10 JRST L0279 MOVE 1,0 L0279: CAME 1,0 JRST L0278 MOVE 1,SYMVAL+84 CAIN 2,9 JRST L0280 MOVE 1,0 L0280: CAME 1,0 JRST L0278 MOVE 1,SYMVAL+84 CAIN 2,10 JRST L0281 MOVE 1,0 L0281: CAME 1,0 JRST L0278 MOVE 1,SYMVAL+84 CAIN 2,12 JRST L0282 MOVE 1,0 L0282: CAME 1,0 JRST L0278 MOVE 1,SYMVAL+84 CAIN 2,13 JRST L0278 MOVE 1,0 L0278: POPJ 15,0 ; (!*ENTRY DIGITP EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPWLEQ (LABEL G0004) (WCONST 48) (REG 1)) ; (CAIL (REG 1) 48) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*LBL (LABEL G0005)) ; (!*JUMPEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPWLEQ (LABEL G0001) (REG 2) (WCONST 57)) ; (CAIG (REG 2) 57) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY DIGITP EXPR 1) DIGITP: intern DIGITP MOVE 2,1 CAIL 1,48 JRST L0283 MOVE 1,0 JRST L0284 L0283: MOVE 1,SYMVAL+84 L0284: CAMN 1,0 JRST L0285 MOVE 1,SYMVAL+84 CAIG 2,57 JRST L0285 MOVE 1,0 L0285: POPJ 15,0 ; (!*ENTRY ALPHAP EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK UPPERCASEP EXPR 1) ; (HRRZI (REG LINKREG) 218) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY UPPERCASEP)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 LOWERCASEP EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 214) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY LOWERCASEP)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ALPHAP EXPR 1) ALPHAP: intern ALPHAP PUSH 15,1 HRRZI 12,218 HRRZI 13,1 PUSHJ 15,SYMFNC+218 CAME 1,0 JRST L0286 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,214 HRRZI 13,1 JRST SYMFNC+214 L0286: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY UPPERCASEP EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPWLEQ (LABEL G0004) (WCONST 65) (REG 1)) ; (CAIL (REG 1) 65) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*LBL (LABEL G0005)) ; (!*JUMPEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPWLEQ (LABEL G0001) (REG 2) (WCONST 90)) ; (CAIG (REG 2) 90) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY UPPERCASEP EXPR 1) L0287: intern L0287 MOVE 2,1 CAIL 1,65 JRST L0288 MOVE 1,0 JRST L0289 L0288: MOVE 1,SYMVAL+84 L0289: CAMN 1,0 JRST L0290 MOVE 1,SYMVAL+84 CAIG 2,90 JRST L0290 MOVE 1,0 L0290: POPJ 15,0 ; (!*ENTRY LOWERCASEP EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*JUMPWLEQ (LABEL G0004) (WCONST 97) (REG 1)) ; (CAIL (REG 1) 97) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*LBL (LABEL G0005)) ; (!*JUMPEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*JUMPWLEQ (LABEL G0001) (REG 2) (WCONST 122)) ; (CAIG (REG 2) 122) ; (JRST (LABEL G0001)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY LOWERCASEP EXPR 1) L0291: intern L0291 MOVE 2,1 CAIL 1,97 JRST L0292 MOVE 1,0 JRST L0293 L0292: MOVE 1,SYMVAL+84 L0293: CAMN 1,0 JRST L0294 MOVE 1,SYMVAL+84 CAIG 2,122 JRST L0294 MOVE 1,0 L0294: POPJ 15,0 ; (!*ENTRY ESCAPEP EXPR 1) ; (!*ALLOC 0) ; (!*JUMPEQ (LABEL G0003) (REG 1) (WCONST 33)) ; (CAIN (REG 1) 33) ; (JRST (LABEL G0003)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0003)) ; (!*MOVE (QUOTE T) (REG 1)) ; (MOVE (REG 1) (FLUID T)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ESCAPEP EXPR 1) L0295: intern L0295 CAIN 1,33 JRST L0296 MOVE 1,0 POPJ 15,0 L0296: MOVE 1,SYMVAL+84 POPJ 15,0 ; (!*ENTRY ALPHAESCP EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK ESCAPEP EXPR 1) ; (HRRZI (REG LINKREG) 212) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ESCAPEP)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 ALPHAP EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 213) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ALPHAP)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ALPHAESCP EXPR 1) L0297: intern L0297 PUSH 15,1 HRRZI 12,212 HRRZI 13,1 PUSHJ 15,SYMFNC+212 CAME 1,0 JRST L0298 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,213 HRRZI 13,1 JRST SYMFNC+213 L0298: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY ALPHANUMP EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK DIGITP EXPR 1) ; (HRRZI (REG LINKREG) 200) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DIGITP)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 ALPHAP EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 213) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ALPHAP)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ALPHANUMP EXPR 1) L0299: intern L0299 PUSH 15,1 HRRZI 12,200 HRRZI 13,1 PUSHJ 15,SYMFNC+200 CAME 1,0 JRST L0300 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,213 HRRZI 13,1 JRST SYMFNC+213 L0300: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY ALPHANUMESCP EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK ESCAPEP EXPR 1) ; (HRRZI (REG LINKREG) 212) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ESCAPEP)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0001)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 ALPHANUMP EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 219) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY ALPHANUMP)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY ALPHANUMESCP EXPR 1) L0301: intern L0301 PUSH 15,1 HRRZI 12,212 HRRZI 13,1 PUSHJ 15,SYMFNC+212 CAME 1,0 JRST L0302 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,219 HRRZI 13,1 JRST SYMFNC+219 L0302: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY READ EXPR 0) ; (!*ALLOC 0) ; (!*LINK RATOM EXPR 0) ; (HRRZI (REG LINKREG) 204) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY RATOM)) ; (!*LINKE 0 READ1 EXPR 1) ; (HRRZI (REG LINKREG) 220) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY READ1)) 0 ; (!*ENTRY READ EXPR 0) READ: intern READ HRRZI 12,204 SETZM 13 PUSHJ 15,SYMFNC+204 HRRZI 12,220 HRRZI 13,1 JRST SYMFNC+220 ; (!*ENTRY READ1 EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE !()) ; (CAME (REG 1) (QUOTE !()) ; (JRST (LABEL G0004)) ; (!*LINK RATOM EXPR 0) ; (HRRZI (REG LINKREG) 204) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY RATOM)) ; (!*LINKE 0 READLIST EXPR 1) ; (HRRZI (REG LINKREG) 222) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY READLIST)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0001) (REG 1) (QUOTE !')) ; (CAME (REG 1) (QUOTE !')) ; (JRST (LABEL G0001)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*LINK NCONS EXPR 1) ; (HRRZI (REG LINKREG) 181) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY NCONS)) ; (!*MOVE (QUOTE QUOTE) (REG 2)) ; (MOVE (REG 2) (QUOTE QUOTE)) ; (!*LINKE 0 XCONS EXPR 2) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY READ1 EXPR 1) READ1: intern READ1 CAME 1,L0303 JRST L0306 HRRZI 12,204 SETZM 13 PUSHJ 15,SYMFNC+204 HRRZI 12,222 HRRZI 13,1 JRST SYMFNC+222 L0306: CAME 1,L0304 JRST L0307 HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 HRRZI 12,181 HRRZI 13,1 PUSHJ 15,SYMFNC+181 MOVE 2,L0305 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 L0307: POPJ 15,0 L0305: <30_31>+223 L0304: <30_31>+39 L0303: <30_31>+40 ; (!*ENTRY READLIST EXPR 1) ; (!*PUSH (QUOTE NIL)) ; (PUSH (REG ST) (REG NIL)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE !))) ; (CAME (REG 1) (QUOTE !))) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*LINK READ1 EXPR 1) ; (HRRZI (REG LINKREG) 220) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY READ1)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK RATOM EXPR 0) ; (HRRZI (REG LINKREG) 204) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY RATOM)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*JUMPNOTEQ (LABEL G0009) (REG 1) (QUOTE !.)) ; (CAME (REG 1) (QUOTE !.)) ; (JRST (LABEL G0009)) ; (!*LINK RATOM EXPR 0) ; (HRRZI (REG LINKREG) 204) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY RATOM)) ; (!*LINK READLIST EXPR 1) ; (HRRZI (REG LINKREG) 222) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY READLIST)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (CAR (REG 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 0)) ; (!*LINKE 2 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) ; (!*LBL (LABEL G0009)) ; (!*LINK READLIST EXPR 1) ; (HRRZI (REG LINKREG) 222) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY READLIST)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*LINKE 2 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY READLIST EXPR 1) L0310: intern L0310 PUSH 15,0 PUSH 15,1 CAME 1,L0308 JRST L0311 MOVE 1,0 JRST L0312 L0311: HRRZI 12,220 HRRZI 13,1 PUSHJ 15,SYMFNC+220 MOVEM 1,-1(15) HRRZI 12,204 SETZM 13 PUSHJ 15,SYMFNC+204 MOVEM 1,0(15) CAME 1,L0309 JRST L0313 HRRZI 12,204 SETZM 13 PUSHJ 15,SYMFNC+204 HRRZI 12,222 HRRZI 13,1 PUSHJ 15,L0310 MOVE 2,-1(15) MOVE 1,0(1) ADJSP 15,-2 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 L0313: HRRZI 12,222 HRRZI 13,1 PUSHJ 15,L0310 MOVE 2,-1(15) ADJSP 15,-2 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 L0312: ADJSP 15,-2 POPJ 15,0 L0309: <30_31>+46 L0308: <30_31>+41 end |
Added psl-1983/20-tests/sub4.rel version [da237301e7].
cannot compute difference between binary files
Added psl-1983/20-tests/sub5.init version [790aa9c39f].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | (PUT (QUOTE SYMFNCBASE) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE COND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE SETQ) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DF) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DM) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE LIST) (QUOTE TYPE) (QUOTE NEXPR)) (PUT (QUOTE WHILE) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/20-tests/sub5.rel version [b6ef3f5792].
cannot compute difference between binary files
Added psl-1983/20-tests/sub6.init version [a7ffc6f8bf].
Added psl-1983/20-tests/sub6.mac version [4426278191].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 extern BNDSTK extern L1005 extern L1006 extern L1007 ; (!*ENTRY BSTACKOVERFLOW EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "***** Binding stack overflow, restarting...") (REG 2)) ; (MOVE (REG 2) (QUOTE "***** Binding stack overflow, restarting...")) ; (!*MOVE (!$FLUID ERROUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID ERROUT!*)) ; (!*LINK CHANNELPRIN2 EXPR 2) ; (HRRZI (REG LINKREG) 150) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CHANNELPRIN2)) ; (!*MOVE (WCONST 10) (REG 2)) ; (HRRZI (REG 2) 10) ; (!*MOVE (!$FLUID ERROUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID ERROUT!*)) ; (!*LINK CHANNELWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 151) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CHANNELWRITECHAR)) ; (!*LINKE 0 RESET EXPR 0) ; (HRRZI (REG LINKREG) 338) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY RESET)) L1009: 42 byte(7)42,42,42,42,42,32,66,105,110,100,105,110,103,32,115,116,97,99,107,32,111,118,101,114,102,108,111,119,44,32,114,101,115,116,97,114,116,105,110,103,46,46,46,0 0 ; (!*ENTRY BSTACKOVERFLOW EXPR 0) L1010: intern L1010 MOVE 2,L1008 MOVE 1,SYMVAL+340 HRRZI 12,150 HRRZI 13,2 PUSHJ 15,SYMFNC+150 HRRZI 2,10 MOVE 1,SYMVAL+340 HRRZI 12,151 HRRZI 13,2 PUSHJ 15,SYMFNC+151 HRRZI 12,338 SETZM 13 JRST SYMFNC+338 L1008: <4_31>+L1009 ; (!*ENTRY BSTACKUNDERFLOW EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "***** Binding stack underflow, restarting...") (REG 2)) ; (MOVE (REG 2) (QUOTE "***** Binding stack underflow, restarting...")) ; (!*MOVE (!$FLUID ERROUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID ERROUT!*)) ; (!*LINK CHANNELPRIN2 EXPR 2) ; (HRRZI (REG LINKREG) 150) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CHANNELPRIN2)) ; (!*MOVE (WCONST 10) (REG 2)) ; (HRRZI (REG 2) 10) ; (!*MOVE (!$FLUID ERROUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID ERROUT!*)) ; (!*LINK CHANNELWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 151) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CHANNELWRITECHAR)) ; (!*LINKE 0 RESET EXPR 0) ; (HRRZI (REG LINKREG) 338) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY RESET)) L1012: 43 byte(7)42,42,42,42,42,32,66,105,110,100,105,110,103,32,115,116,97,99,107,32,117,110,100,101,114,102,108,111,119,44,32,114,101,115,116,97,114,116,105,110,103,46,46,46,0 0 ; (!*ENTRY BSTACKUNDERFLOW EXPR 0) L1013: intern L1013 MOVE 2,L1011 MOVE 1,SYMVAL+340 HRRZI 12,150 HRRZI 13,2 PUSHJ 15,SYMFNC+150 HRRZI 2,10 MOVE 1,SYMVAL+340 HRRZI 12,151 HRRZI 13,2 PUSHJ 15,SYMFNC+151 HRRZI 12,338 SETZM 13 JRST SYMFNC+338 L1011: <4_31>+L1012 ; (!*ENTRY CAPTUREENVIRONMENT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR BNDSTKPTR) (REG 1)) ; (MOVE (REG 1) (WVAR BNDSTKPTR)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY CAPTUREENVIRONMENT EXPR 0) L1014: intern L1014 MOVE 1,L1007 POPJ 15,0 ; (!*ENTRY RESTOREENVIRONMENT EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*JUMPWGEQ (LABEL G0004) (REG 1) (WVAR BNDSTKLOWERBOUND)) ; (CAML (REG 1) (WVAR BNDSTKLOWERBOUND)) ; (JRST (LABEL G0004)) ; (!*LINKE 0 BSTACKUNDERFLOW EXPR 0) ; (HRRZI (REG LINKREG) 341) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY BSTACKUNDERFLOW)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLESSP (LABEL G0008) (REG 5) (WVAR BNDSTKPTR)) ; (CAMGE (REG 5) (WVAR BNDSTKPTR)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0008)) ; (!*MOVE (MEMORY (WVAR BNDSTKPTR) (WCONST 0)) (REG 1)) ; (MOVE (REG 1) (INDIRECT (WVAR BNDSTKPTR))) ; (!*MOVE (REG 1) (REG 4)) ; (MOVE (REG 4) (REG 1)) ; (!*MOVE (WVAR BNDSTKPTR) (REG 2)) ; (MOVE (REG 2) (WVAR BNDSTKPTR)) ; (!*MOVE (MEMORY (REG 2) (WCONST -1)) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG 2) -1)) ; (!*MOVE (REG 1) (MEMORY (REG 3) (WCONST SYMVAL))) ; (MOVEM (REG 1) (INDEXED (REG 3) (IMMEDIATE SYMVAL))) ; (!*WPLUS2 (WVAR BNDSTKPTR) (WCONST -2)) ; (MOVNI (REG T2) (MINUS -2)) ; (ADDM (REG T2) (WVAR BNDSTKPTR)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) 1 ; (!*ENTRY RESTOREENVIRONMENT EXPR 1) L1015: intern L1015 MOVE 5,1 CAML 1,L1005 JRST L1016 HRRZI 12,341 SETZM 13 JRST SYMFNC+341 L1016: CAMGE 5,L1007 JRST L1017 MOVE 1,0 POPJ 15,0 L1017: MOVE 1,@L1007 MOVE 4,1 MOVE 2,L1007 MOVE 3,-1(2) MOVEM 1,SYMVAL(3) MOVNI 7,2 ADDM 7,L1007 JRST L1016 ; (!*ENTRY CLEARBINDINGS EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR BNDSTKLOWERBOUND) (REG 1)) ; (MOVE (REG 1) (WVAR BNDSTKLOWERBOUND)) ; (!*LINK RESTOREENVIRONMENT EXPR 1) ; (HRRZI (REG LINKREG) 343) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RESTOREENVIRONMENT)) ; (!*LINKE 0 !%CLEAR!-CATCH!-STACK EXPR 0) ; (HRRZI (REG LINKREG) 344) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY !%CLEAR!-CATCH!-STACK)) 0 ; (!*ENTRY CLEARBINDINGS EXPR 0) L1018: intern L1018 MOVE 1,L1005 HRRZI 12,343 HRRZI 13,1 PUSHJ 15,SYMFNC+343 HRRZI 12,344 SETZM 13 JRST SYMFNC+344 ; (!*ENTRY UNBINDN EXPR 1) ; (!*ALLOC 0) ; (!*WMINUS (REG 1) (REG 1)) ; (MOVNS (REG 1)) ; (!*WSHIFT (REG 1) (WCONST 1)) ; (LSH (REG 1) 1) ; (!*WPLUS2 (REG 1) (WVAR BNDSTKPTR)) ; (ADD (REG 1) (WVAR BNDSTKPTR)) ; (!*LINKE 0 RESTOREENVIRONMENT EXPR 1) ; (HRRZI (REG LINKREG) 343) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY RESTOREENVIRONMENT)) 1 ; (!*ENTRY UNBINDN EXPR 1) L1019: intern L1019 MOVNS 1 LSH 1,1 ADD 1,L1007 HRRZI 12,343 HRRZI 13,1 JRST SYMFNC+343 ; (!*ENTRY LBIND1 EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*JUMPTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE "binding") (REG 2)) ; (MOVE (REG 2) (QUOTE "binding")) ; (!*LINKE 0 NONIDERROR EXPR 2) ; (HRRZI (REG LINKREG) 159) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY NONIDERROR)) ; (!*LBL (LABEL G0004)) ; (!*JUMPEQ (LABEL G0006) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0006)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 1) (QUOTE T)) ; (CAME (REG 1) (FLUID T)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (QUOTE "T and NIL cannot be rebound") (REG 1)) ; (MOVE (REG 1) (QUOTE "T and NIL cannot be rebound")) ; (!*LINKE 0 STDERROR EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY STDERROR)) ; (!*LBL (LABEL G0005)) ; (!*WPLUS2 (WVAR BNDSTKPTR) (WCONST 2)) ; (HRRZI (REG T2) 2) ; (ADDM (REG T2) (WVAR BNDSTKPTR)) ; (!*JUMPWGEQ (LABEL G0009) (WVAR BNDSTKUPPERBOUND) (WVAR BNDSTKPTR)) ; (MOVE (REG T1) (WVAR BNDSTKUPPERBOUND)) ; (CAML (REG T1) (WVAR BNDSTKPTR)) ; (JRST (LABEL G0009)) ; (!*LINKE 0 BSTACKOVERFLOW EXPR 0) ; (HRRZI (REG LINKREG) 339) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY BSTACKOVERFLOW)) ; (!*LBL (LABEL G0009)) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*MOVE (REG 1) (REG 5)) ; (MOVE (REG 5) (REG 1)) ; (!*MOVE (WVAR BNDSTKPTR) (REG 4)) ; (MOVE (REG 4) (WVAR BNDSTKPTR)) ; (!*MOVE (REG 1) (MEMORY (REG 4) (WCONST -1))) ; (MOVEM (REG 1) (INDEXED (REG 4) -1)) ; (!*MOVE (MEMORY (REG 1) (WCONST SYMVAL)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE SYMVAL))) ; (!*MOVE (REG 1) (MEMORY (REG 4) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 4) 0)) ; (!*MOVE (REG 2) (MEMORY (REG 5) (WCONST SYMVAL))) ; (MOVEM (REG 2) (INDEXED (REG 5) (IMMEDIATE SYMVAL))) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) L1023: 26 byte(7)84,32,97,110,100,32,78,73,76,32,99,97,110,110,111,116,32,98,101,32,114,101,98,111,117,110,100,0 L1024: 6 byte(7)98,105,110,100,105,110,103,0 2 ; (!*ENTRY LBIND1 EXPR 2) LBIND1: intern LBIND1 MOVE 5,1 LDB 11,L1020 CAIN 11,30 JRST L1025 MOVE 2,L1021 HRRZI 12,159 HRRZI 13,2 JRST SYMFNC+159 L1025: CAMN 1,0 JRST L1026 CAME 1,SYMVAL+84 JRST L1027 L1026: MOVE 1,L1022 HRRZI 12,158 HRRZI 13,1 JRST SYMFNC+158 L1027: HRRZI 7,2 ADDM 7,L1007 MOVE 6,L1006 CAML 6,L1007 JRST L1028 HRRZI 12,339 SETZM 13 JRST SYMFNC+339 L1028: HRRZ 1,1 MOVE 5,1 MOVE 4,L1007 MOVEM 1,-1(4) MOVE 1,SYMVAL(1) MOVEM 1,0(4) MOVEM 2,SYMVAL(5) MOVE 1,2 POPJ 15,0 L1020: point 5,1,4 L1022: <4_31>+L1023 L1021: <4_31>+L1024 ; (!*ENTRY PBIND1 EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*LINKE 0 LBIND1 EXPR 2) ; (HRRZI (REG LINKREG) 257) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY LBIND1)) 1 ; (!*ENTRY PBIND1 EXPR 1) PBIND1: intern PBIND1 MOVE 2,0 HRRZI 12,257 HRRZI 13,2 JRST SYMFNC+257 ; (!*ENTRY LAMBIND EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*SIGNEDFIELD (REG 2) (MEMORY (REG 1) (WCONST 0)) (WCONST 18) (WCONST 18)) ; (HRRE (REG 2) (INDEXED (REG 1) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0005)) ; (!*JUMPWGREATERP (LABEL G0004) (FRAME 3) (FRAME 2)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAMLE (REG T1) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 2) (!$FLUID LAMBINDARGS!*)) ; (ADD (REG 2) (!$FLUID LAMBINDARGS!*)) ; (!*MOVE (MEMORY (REG 2) (WCONST 0)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 2) 0)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (FRAME 1)) ; (ADD (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (MEMORY (REG 1) (WCONST 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*LINK LBIND1 EXPR 2) ; (HRRZI (REG LINKREG) 257) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LBIND1)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY LAMBIND EXPR 1) L1029: intern L1029 ADJSP 15,3 HRRZ 1,1 MOVEM 1,0(15) HRRE 2,0(1) MOVEM 2,-1(15) SETZM -2(15) L1030: MOVE 6,-2(15) CAMLE 6,-1(15) JRST L1031 MOVE 2,-2(15) ADD 2,SYMVAL+166 MOVE 2,0(2) MOVE 1,-2(15) ADD 1,0(15) MOVE 1,1(1) HRRZI 12,257 HRRZI 13,2 PUSHJ 15,SYMFNC+257 AOS -2(15) JRST L1030 L1031: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY PROGBIND EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*FIELD (REG 1) (REG 1) (WCONST 18) (WCONST 18)) ; (HRRZ (REG 1) (REG 1)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*SIGNEDFIELD (REG 2) (MEMORY (REG 1) (WCONST 0)) (WCONST 18) (WCONST 18)) ; (HRRE (REG 2) (INDEXED (REG 1) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0005)) ; (!*JUMPWGREATERP (LABEL G0004) (FRAME 3) (FRAME 2)) ; (MOVE (REG T1) (INDEXED (REG ST) -2)) ; (CAMLE (REG T1) (INDEXED (REG ST) -1)) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (FRAME 1)) ; (ADD (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (MEMORY (REG 1) (WCONST 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 1) 1)) ; (!*LINK PBIND1 EXPR 1) ; (HRRZI (REG LINKREG) 346) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PBIND1)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PROGBIND EXPR 1) L1032: intern L1032 ADJSP 15,3 HRRZ 1,1 MOVEM 1,0(15) HRRE 2,0(1) MOVEM 2,-1(15) SETZM -2(15) L1033: MOVE 6,-2(15) CAMLE 6,-1(15) JRST L1034 MOVE 1,-2(15) ADD 1,0(15) MOVE 1,1(1) HRRZI 12,346 HRRZI 13,1 PUSHJ 15,SYMFNC+346 AOS -2(15) JRST L1033 L1034: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY GETD EXPR 1) ; (!*PUSH (QUOTE NIL)) ; (PUSH (REG ST) (REG NIL)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE "*** Can only GETD off ID's: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Can only GETD off ID's: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*LINK FUNBOUNDP EXPR 1) ; (HRRZI (REG LINKREG) 231) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FUNBOUNDP)) ; (!*JUMPEQ (LABEL G0008) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (QUOTE FTYPE) (REG 2)) ; (MOVE (REG 2) (QUOTE FTYPE)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK GET EXPR 2) ; (HRRZI (REG LINKREG) 258) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GET)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*JUMPNOTEQ (LABEL G0014) (REG 2) (QUOTE NIL)) ; (CAME (REG 2) (REG NIL)) ; (JRST (LABEL G0014)) ; (!*MOVE (QUOTE EXPR) (FRAME 2)) ; (MOVE (REG T1) (QUOTE EXPR)) ; (MOVEM (REG T1) (INDEXED (REG ST) -1)) ; (!*LBL (LABEL G0014)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FCODEP EXPR 1) ; (HRRZI (REG LINKREG) 237) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FCODEP)) ; (!*JUMPEQ (LABEL G0018) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0018)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK GETFCODEPOINTER EXPR 1) ; (HRRZI (REG LINKREG) 239) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY GETFCODEPOINTER)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*LINKE 2 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) ; (!*LBL (LABEL G0018)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FLAMBDALINKP EXPR 1) ; (HRRZI (REG LINKREG) 234) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FLAMBDALINKP)) ; (!*JUMPEQ (LABEL G0024) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0024)) ; (!*MOVE (QUOTE !*LAMBDALINK) (REG 2)) ; (MOVE (REG 2) (QUOTE !*LAMBDALINK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK GET EXPR 2) ; (HRRZI (REG LINKREG) 258) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY GET)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*LINKE 2 XCONS EXPR 2) ; (ADJSP (REG ST) (MINUS 2)) ; (HRRZI (REG LINKREG) 180) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY XCONS)) ; (!*LBL (LABEL G0024)) ; (!*MOVE (QUOTE "*** GETD should find a LAMBDA or CODE") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** GETD should find a LAMBDA or CODE")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) L1041: 36 byte(7)42,42,42,32,71,69,84,68,32,115,104,111,117,108,100,32,102,105,110,100,32,97,32,76,65,77,66,68,65,32,111,114,32,67,79,68,69,0 L1042: 27 byte(7)42,42,42,32,67,97,110,32,111,110,108,121,32,71,69,84,68,32,111,102,102,32,73,68,39,115,58,32,0 1 ; (!*ENTRY GETD EXPR 1) GETD: intern GETD PUSH 15,0 PUSH 15,1 LDB 11,L1035 CAIN 11,30 JRST L1043 MOVE 1,L1036 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 1,0 JRST L1044 L1043: HRRZI 12,231 HRRZI 13,1 PUSHJ 15,SYMFNC+231 CAMN 1,0 JRST L1045 MOVE 1,0 JRST L1044 L1045: MOVE 2,L1037 MOVE 1,0(15) HRRZI 12,258 HRRZI 13,2 PUSHJ 15,SYMFNC+258 MOVE 2,1 MOVEM 2,-1(15) CAME 2,0 JRST L1046 MOVE 6,L1038 MOVEM 6,-1(15) L1046: MOVE 1,0(15) HRRZI 12,237 HRRZI 13,1 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L1047 MOVE 1,0(15) HRRZI 12,239 HRRZI 13,1 PUSHJ 15,SYMFNC+239 MOVE 2,-1(15) ADJSP 15,-2 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 L1047: MOVE 1,0(15) HRRZI 12,234 HRRZI 13,1 PUSHJ 15,SYMFNC+234 CAMN 1,0 JRST L1048 MOVE 2,L1039 MOVE 1,0(15) HRRZI 12,258 HRRZI 13,2 PUSHJ 15,SYMFNC+258 MOVE 2,-1(15) ADJSP 15,-2 HRRZI 12,180 HRRZI 13,2 JRST SYMFNC+180 L1048: MOVE 1,L1040 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 1,0 L1044: ADJSP 15,-2 POPJ 15,0 L1035: point 5,1,4 L1040: <4_31>+L1041 L1039: <30_31>+260 L1038: <30_31>+293 L1037: <30_31>+311 L1036: <4_31>+L1042 ; (!*ENTRY PUTD EXPR 3) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*JUMPTYPE (LABEL G0004) (REG 1) ID) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (REG 1) 0 5)))) ; (CAIN (REG T6) 30) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE "*** Can only define ID's as functions: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Can only define ID's as functions: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*LINK FCODEP EXPR 1) ; (HRRZI (REG LINKREG) 237) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FCODEP)) ; (!*JUMPEQ (LABEL G0009) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0009)) ; (!*MOVE (QUOTE "*** Redefining a COMPILED function: ") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Redefining a COMPILED function: ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*JUMP (LABEL G0008)) ; (JRST (LABEL G0008)) ; (!*LBL (LABEL G0009)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FUNBOUNDP EXPR 1) ; (HRRZI (REG LINKREG) 231) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FUNBOUNDP)) ; (!*JUMPNOTEQ (LABEL G0008) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0008)) ; (!*MOVE (QUOTE " Redefining function ") (REG 1)) ; (MOVE (REG 1) (QUOTE " Redefining function ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (QUOTE !*LAMBDALINK) (REG 2)) ; (MOVE (REG 2) (QUOTE !*LAMBDALINK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK REMPROP EXPR 2) ; (HRRZI (REG LINKREG) 334) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY REMPROP)) ; (!*MOVE (QUOTE FTYPE) (REG 2)) ; (MOVE (REG 2) (QUOTE FTYPE)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK REMPROP EXPR 2) ; (HRRZI (REG LINKREG) 334) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY REMPROP)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK MAKEFUNBOUND EXPR 1) ; (HRRZI (REG LINKREG) 217) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MAKEFUNBOUND)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK LAMBDAP EXPR 1) ; (HRRZI (REG LINKREG) 312) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY LAMBDAP)) ; (!*JUMPEQ (LABEL G0017) (REG 1) (QUOTE NIL)) ; (CAMN (REG 1) (REG NIL)) ; (JRST (LABEL G0017)) ; (!*MOVE (FRAME 3) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (QUOTE !*LAMBDALINK) (REG 2)) ; (MOVE (REG 2) (QUOTE !*LAMBDALINK)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUT EXPR 3) ; (HRRZI (REG LINKREG) 308) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY PUT)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK MAKEFLAMBDALINK EXPR 1) ; (HRRZI (REG LINKREG) 236) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MAKEFLAMBDALINK)) ; (!*JUMP (LABEL G0016)) ; (JRST (LABEL G0016)) ; (!*LBL (LABEL G0017)) ; (!*JUMPNOTTYPE (LABEL G0019) (FRAME 3) CODE) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -2) 0 5)))) ; (CAIE (REG T6) 15) ; (JRST (LABEL G0019)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK MAKEFCODE EXPR 2) ; (HRRZI (REG LINKREG) 238) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY MAKEFCODE)) ; (!*JUMP (LABEL G0016)) ; (JRST (LABEL G0016)) ; (!*LBL (LABEL G0019)) ; (!*MOVE (QUOTE "*** Body must be a LAMBDA or CODE") (REG 1)) ; (MOVE (REG 1) (QUOTE "*** Body must be a LAMBDA or CODE")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN1 EXPR 1) ; (HRRZI (REG LINKREG) 134) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN1)) ; (!*MOVE (QUOTE " ") (REG 1)) ; (MOVE (REG 1) (QUOTE " ")) ; (!*LINK PRIN2 EXPR 1) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0016)) ; (!*JUMPEQ (LABEL G0022) (FRAME 2) (QUOTE EXPR)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMN (REG T1) (QUOTE EXPR)) ; (JRST (LABEL G0022)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (QUOTE FTYPE) (REG 2)) ; (MOVE (REG 2) (QUOTE FTYPE)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUT EXPR 3) ; (HRRZI (REG LINKREG) 308) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY PUT)) ; (!*LBL (LABEL G0022)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (REG 1) 0 5)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG ST) -2) 0 5)) L1059: 0 byte(7)32,0 L1060: 32 byte(7)42,42,42,32,66,111,100,121,32,109,117,115,116,32,98,101,32,97,32,76,65,77,66,68,65,32,111,114,32,67,79,68,69,0 L1061: 20 byte(7)32,82,101,100,101,102,105,110,105,110,103,32,102,117,110,99,116,105,111,110,32,0 L1062: 35 byte(7)42,42,42,32,82,101,100,101,102,105,110,105,110,103,32,97,32,67,79,77,80,73,76,69,68,32,102,117,110,99,116,105,111,110,58,32,0 L1063: 38 byte(7)42,42,42,32,67,97,110,32,111,110,108,121,32,100,101,102,105,110,101,32,73,68,39,115,32,97,115,32,102,117,110,99,116,105,111,110,115,58,32,0 3 ; (!*ENTRY PUTD EXPR 3) PUTD: intern PUTD ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L1049 CAIN 11,30 JRST L1064 MOVE 1,L1050 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 1,0 JRST L1065 L1064: HRRZI 12,237 HRRZI 13,1 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L1066 MOVE 1,L1051 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 JRST L1067 L1066: MOVE 1,0(15) HRRZI 12,231 HRRZI 13,1 PUSHJ 15,SYMFNC+231 CAME 1,0 JRST L1067 MOVE 1,L1052 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 L1067: MOVE 2,L1053 MOVE 1,0(15) HRRZI 12,334 HRRZI 13,2 PUSHJ 15,SYMFNC+334 MOVE 2,L1054 MOVE 1,0(15) HRRZI 12,334 HRRZI 13,2 PUSHJ 15,SYMFNC+334 MOVE 1,0(15) HRRZI 12,217 HRRZI 13,1 PUSHJ 15,SYMFNC+217 MOVE 1,-2(15) HRRZI 12,312 HRRZI 13,1 PUSHJ 15,SYMFNC+312 CAMN 1,0 JRST L1068 MOVE 3,-2(15) MOVE 2,L1053 MOVE 1,0(15) HRRZI 12,308 HRRZI 13,3 PUSHJ 15,SYMFNC+308 MOVE 1,0(15) HRRZI 12,236 HRRZI 13,1 PUSHJ 15,SYMFNC+236 JRST L1069 L1068: LDB 11,L1055 CAIE 11,15 JRST L1070 MOVE 2,-2(15) MOVE 1,0(15) HRRZI 12,238 HRRZI 13,2 PUSHJ 15,SYMFNC+238 JRST L1069 L1070: MOVE 1,L1056 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,0(15) HRRZI 12,134 HRRZI 13,1 PUSHJ 15,SYMFNC+134 MOVE 1,L1057 HRRZI 12,138 HRRZI 13,1 PUSHJ 15,SYMFNC+138 MOVE 1,-2(15) HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 MOVE 1,0 JRST L1065 L1069: MOVE 6,-1(15) CAMN 6,L1058 JRST L1071 MOVE 3,-1(15) MOVE 2,L1054 MOVE 1,0(15) HRRZI 12,308 HRRZI 13,3 PUSHJ 15,SYMFNC+308 L1071: MOVE 1,0(15) L1065: ADJSP 15,-3 POPJ 15,0 L1049: point 5,1,4 L1055: point 5,-2(15),4 L1058: <30_31>+293 L1057: <4_31>+L1059 L1056: <4_31>+L1060 L1054: <30_31>+311 L1053: <30_31>+260 L1052: <4_31>+L1061 L1051: <4_31>+L1062 L1050: <4_31>+L1063 ; (!*ENTRY RESET EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Should RESET here, but will QUIT") (REG 1)) ; (MOVE (REG 1) (QUOTE "Should RESET here, but will QUIT")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 148) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1073: 31 byte(7)83,104,111,117,108,100,32,82,69,83,69,84,32,104,101,114,101,44,32,98,117,116,32,119,105,108,108,32,81,85,73,84,0 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 1,L1072 HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 HRRZI 12,148 SETZM 13 PUSHJ 15,SYMFNC+148 MOVE 1,0 POPJ 15,0 L1072: <4_31>+L1073 end |
Added psl-1983/20-tests/sub6.rel version [eb61c758ae].
cannot compute difference between binary files
Added psl-1983/20-tests/sub7.init version [bf984f29e8].
> > > > > | 1 2 3 4 5 | (GLOBAL (QUOTE (!$EOL!$))) (FLUID (QUOTE (!*ECHO !*PVAL))) (FLUID (QUOTE (IN!* OUT!*))) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!* ERROUT!* PROMPTOUT!* !*ECHO))) |
Added psl-1983/20-tests/sub7.mac version [c9bf2f8e14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern L0001 extern L0002 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0003 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 ; (!*ENTRY SYSCLEARIO EXPR 0) ; (!*MOVE (WCONST 64) (REG 1)) ; (HRRZI (REG 1) 64) ; (RFMOD) ; (TRO 2 63552) ; (SFMOD) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY SYSCLEARIO EXPR 0) L1074: intern L1074 HRRZI 1,64 RFMOD TRO 2,63552 SFMOD POPJ 15,0 ; (!*ENTRY SYSOPENREAD EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*MOVE (WCONST 7516258304) (REG 3)) ; (MOVE (REG 3) 7516258304) ; (!*MOVE (WCONST 8590196736) (REG 2)) ; (MOVE (REG 2) 8590196736) ; (!*MOVE (REG 4) (REG 1)) ; (MOVE (REG 1) (REG 4)) ; (!*LINKE 0 DEC20OPEN EXPR 3) ; (HRRZI (REG LINKREG) 349) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY DEC20OPEN)) 2 ; (!*ENTRY SYSOPENREAD EXPR 2) L1075: intern L1075 MOVE 4,2 MOVE 3,[7516258304] MOVE 2,[8590196736] MOVE 1,4 HRRZI 12,349 HRRZI 13,3 JRST SYMFNC+349 ; (!*ENTRY SYSOPENWRITE EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (REG 2) (REG 4)) ; (MOVE (REG 4) (REG 2)) ; (!*MOVE (WCONST 7516225536) (REG 3)) ; (MOVE (REG 3) 7516225536) ; (!*MOVE (WCONST -17179607040) (REG 2)) ; (MOVE (REG 2) -17179607040) ; (!*MOVE (REG 4) (REG 1)) ; (MOVE (REG 1) (REG 4)) ; (!*LINKE 0 DEC20OPEN EXPR 3) ; (HRRZI (REG LINKREG) 349) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY DEC20OPEN)) 2 ; (!*ENTRY SYSOPENWRITE EXPR 2) L1076: intern L1076 MOVE 4,2 MOVE 3,[7516225536] MOVE 2,[-17179607040] MOVE 1,4 HRRZI 12,349 HRRZI 13,3 JRST SYMFNC+349 ; (!*ENTRY DEC20OPEN EXPR 3) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (HRLI (REG 1) 147904) ; (!*MOVE (REG 1) (REG 4)) ; (MOVE (REG 4) (REG 1)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*MOVE (REG 4) (REG 2)) ; (MOVE (REG 2) (REG 4)) ; (GTJFN) ; (!*JUMP (LABEL CANTOPEN)) ; (JRST (LABEL CANTOPEN)) ; (!*MOVE (REG 3) (REG 2)) ; (MOVE (REG 2) (REG 3)) ; (OPENF) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY DEC20OPEN EXPR 3) L1077: intern L1077 AOS 1 HRLI 1,147904 MOVE 4,1 MOVE 1,2 MOVE 2,4 GTJFN JRST L1078 MOVE 2,3 OPENF L1078: SETZM 1 POPJ 15,0 ; (!*ENTRY SYSREADREC EXPR 2) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (WCONST 0) (FRAME 3)) ; (SETZM (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK DEC20READCHAR EXPR 1) ; (HRRZI (REG LINKREG) 352) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DEC20READCHAR)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*JUMPEQ (LABEL G0008) (REG 3) (WCONST 10)) ; (CAIN (REG 3) 10) ; (JRST (LABEL G0008)) ; (!*JUMPNOTEQ (LABEL G0006) (REG 3) (WCONST 26)) ; (CAIE (REG 3) 26) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0008)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0006)) ; (!*WPLUS2 (FRAME 3) (WCONST 1)) ; (AOS (INDEXED (REG ST) -2)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 4) ; (ADJSP (REG ST) (MINUS 4)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 2 ; (!*ENTRY SYSREADREC EXPR 2) L1080: intern L1080 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) SETZM -2(15) L1081: MOVE 1,0(15) HRRZI 12,352 HRRZI 13,1 PUSHJ 15,SYMFNC+352 MOVEM 1,-3(15) MOVE 3,1 MOVE 2,-2(15) MOVE 1,-1(15) AOS 1 HRRZI 12,187 HRRZI 13,3 ADJBP 2,L1079 DPB 3,2 CAIN 3,10 JRST L1082 CAIE 3,26 JRST L1083 L1082: MOVE 1,-2(15) JRST L1084 L1083: AOS -2(15) JRST L1081 L1084: ADJSP 15,-4 POPJ 15,0 L1079: point 7,0(1),6 ; (!*ENTRY DEC20READCHAR EXPR 1) ; (BIN) ; (ERJMP CHECKEOF) ; (!*JUMPEQ (LABEL LOOP) (REG 2) (WCONST 0)) ; (JUMPE (REG 2) (LABEL LOOP)) ; (!*JUMPEQ (LABEL LOOP) (REG 2) (WCONST 13)) ; (CAIN (REG 2) 13) ; (JRST (LABEL LOOP)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (GTSTS) ; (TLNN (REG 2) 512) ; (!*JUMP (LABEL READERROR)) ; (JRST (LABEL READERROR)) ; (!*MOVE (WCONST 26) (REG 1)) ; (HRRZI (REG 1) 26) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*MOVE (QUOTE "Attempt to read from file failed") (REG 1)) ; (MOVE (REG 1) (QUOTE "Attempt to read from file failed")) ; (!*JCALL IOERROR) ; (JRST (ENTRY IOERROR)) L1086: 31 byte(7)65,116,116,101,109,112,116,32,116,111,32,114,101,97,100,32,102,114,111,109,32,102,105,108,101,32,102,97,105,108,101,100,0 1 ; (!*ENTRY DEC20READCHAR EXPR 1) L1087: intern L1087 L1088: BIN ERJMP L1089 JUMPE 2,L1088 CAIN 2,13 JRST L1088 MOVE 1,2 POPJ 15,0 L1089: GTSTS TLNN 2,512 JRST L1090 HRRZI 1,26 POPJ 15,0 L1090: MOVE 1,L1085 JRST SYMFNC+354 L1085: <4_31>+L1086 ; (!*ENTRY SYSWRITEREC EXPR 3) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*MOVE (WCONST 0) (FRAME 4)) ; (SETZM (INDEXED (REG ST) -3)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 4) (FRAME 3)) ; (MOVE (REG T1) (INDEXED (REG ST) -3)) ; (CAMG (REG T1) (INDEXED (REG ST) -2)) ; (JRST (LABEL G0005)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 4) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK DEC20WRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 355) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY DEC20WRITECHAR)) ; (!*WPLUS2 (FRAME 4) (WCONST 1)) ; (AOS (INDEXED (REG ST) -3)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 4) ; (ADJSP (REG ST) (MINUS 4)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 3 ; (!*ENTRY SYSWRITEREC EXPR 3) L1092: intern L1092 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) SETZM -3(15) L1093: MOVE 6,-3(15) CAMG 6,-2(15) JRST L1094 SETZM 1 JRST L1095 L1094: MOVE 2,-3(15) MOVE 1,-1(15) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L1091 LDB 1,2 MOVE 2,1 MOVE 1,0(15) HRRZI 12,355 HRRZI 13,2 PUSHJ 15,SYMFNC+355 AOS -3(15) JRST L1093 L1095: ADJSP 15,-4 POPJ 15,0 L1091: point 7,0(1),6 ; (!*ENTRY DEC20WRITECHAR EXPR 2) ; (!*JUMPEQ (LABEL CRLF) (REG 2) (WCONST 10)) ; (CAIN (REG 2) 10) ; (JRST (LABEL CRLF)) ; (BOUT) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*MOVE (WCONST 13) (REG 2)) ; (HRRZI (REG 2) 13) ; (BOUT) ; (!*MOVE (WCONST 10) (REG 2)) ; (HRRZI (REG 2) 10) ; (BOUT) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY DEC20WRITECHAR EXPR 2) L1096: intern L1096 CAIN 2,10 JRST L1097 BOUT POPJ 15,0 L1097: HRRZI 2,13 BOUT HRRZI 2,10 BOUT POPJ 15,0 ; (!*ENTRY SYSCLOSE EXPR 1) ; (CLOSF) ; (!*JUMP (LABEL CLOSEERROR)) ; (JRST (LABEL CLOSEERROR)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (!*MOVE (QUOTE "Channel could not be closed") (REG 1)) ; (MOVE (REG 1) (QUOTE "Channel could not be closed")) ; (!*JCALL CHANNELERROR) ; (JRST (ENTRY CHANNELERROR)) L1099: 26 byte(7)67,104,97,110,110,101,108,32,99,111,117,108,100,32,110,111,116,32,98,101,32,99,108,111,115,101,100,0 1 ; (!*ENTRY SYSCLOSE EXPR 1) L1100: intern L1100 CLOSF JRST L1101 POPJ 15,0 L1101: MOVE 1,L1098 JRST SYMFNC+358 L1098: <4_31>+L1099 ; (!*ENTRY SYSMAXBUFFER EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (WCONST 200) (REG 1)) ; (HRRZI (REG 1) 200) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SYSMAXBUFFER EXPR 1) L1102: intern L1102 HRRZI 1,200 POPJ 15,0 extern L1103 extern L1104 extern L1105 extern L1106 extern L1107 extern L1108 extern L1109 extern L1110 extern L1111 extern L1112 extern L1113 extern L1114 ; (!*ENTRY IOERROR EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 139) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK ERRORHEADER EXPR 0) ; (HRRZI (REG LINKREG) 155) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY ERRORHEADER)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 141) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*MOVE (QUOTE 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK RDS EXPR 1) ; (HRRZI (REG LINKREG) 370) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RDS)) ; (!*MOVE (QUOTE 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINK WRS EXPR 1) ; (HRRZI (REG LINKREG) 371) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY WRS)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY IOERROR EXPR 1) L1115: intern L1115 PUSH 15,1 HRRZI 12,139 SETZM 13 PUSHJ 15,SYMFNC+139 HRRZI 12,155 SETZM 13 PUSHJ 15,SYMFNC+155 MOVE 1,0(15) HRRZI 12,141 HRRZI 13,1 PUSHJ 15,SYMFNC+141 SETZM 1 HRRZI 12,370 HRRZI 13,1 PUSHJ 15,SYMFNC+370 HRRZI 1,1 HRRZI 12,371 HRRZI 13,1 PUSHJ 15,SYMFNC+371 MOVE 1,0 ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY TYPEFILE EXPR 1) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE INPUT) (REG 2)) ; (MOVE (REG 2) (QUOTE INPUT)) ; (!*LINK OPEN EXPR 2) ; (HRRZI (REG LINKREG) 372) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY OPEN)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK RDS EXPR 1) ; (HRRZI (REG LINKREG) 370) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RDS)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0007)) ; (!*LINK GETC EXPR 0) ; (HRRZI (REG LINKREG) 206) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY GETC)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMPEQ (LABEL G0006) (REG 1) (QUOTE 26)) ; (CAIN (REG 1) 26) ; (JRST (LABEL G0006)) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*JUMP (LABEL G0007)) ; (JRST (LABEL G0007)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK RDS EXPR 1) ; (HRRZI (REG LINKREG) 370) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RDS)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK CLOSE EXPR 1) ; (HRRZI (REG LINKREG) 373) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY CLOSE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 4) ; (ADJSP (REG ST) (MINUS 4)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY TYPEFILE EXPR 1) L1117: intern L1117 ADJSP 15,4 MOVEM 1,0(15) MOVE 2,L1116 HRRZI 12,372 HRRZI 13,2 PUSHJ 15,SYMFNC+372 MOVEM 1,-1(15) HRRZI 12,370 HRRZI 13,1 PUSHJ 15,SYMFNC+370 MOVEM 1,-2(15) L1118: HRRZI 12,206 SETZM 13 PUSHJ 15,SYMFNC+206 MOVEM 1,-3(15) CAIN 1,26 JRST L1119 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 JRST L1118 L1119: MOVE 1,-2(15) HRRZI 12,370 HRRZI 13,1 PUSHJ 15,SYMFNC+370 MOVE 1,-1(15) HRRZI 12,373 HRRZI 13,1 PUSHJ 15,SYMFNC+373 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L1116: <30_31>+375 ; (!*ENTRY DSKIN EXPR 1) ; (!*ALLOC 4) ; (ADJSP (REG ST) 4) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (QUOTE INPUT) (REG 2)) ; (MOVE (REG 2) (QUOTE INPUT)) ; (!*LINK OPEN EXPR 2) ; (HRRZI (REG LINKREG) 372) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY OPEN)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK RDS EXPR 1) ; (HRRZI (REG LINKREG) 370) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RDS)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*LBL (LABEL G0007)) ; (!*LINK READ EXPR 0) ; (HRRZI (REG LINKREG) 221) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY READ)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMPEQ (LABEL G0006) (REG 1) (!$GLOBAL !$EOF!$)) ; (CAMN (REG 1) (!$GLOBAL !$EOF!$)) ; (JRST (LABEL G0006)) ; (!*LINK EVAL EXPR 1) ; (HRRZI (REG LINKREG) 254) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY EVAL)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMPEQ (LABEL G0007) (QUOTE NIL) (!$FLUID !*PVAL)) ; (CAMN (REG NIL) (!$FLUID !*PVAL)) ; (JRST (LABEL G0007)) ; (!*LINK PRINT EXPR 1) ; (HRRZI (REG LINKREG) 140) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRINT)) ; (!*JUMP (LABEL G0007)) ; (JRST (LABEL G0007)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*LINK RDS EXPR 1) ; (HRRZI (REG LINKREG) 370) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY RDS)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK CLOSE EXPR 1) ; (HRRZI (REG LINKREG) 373) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY CLOSE)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 4) ; (ADJSP (REG ST) (MINUS 4)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY DSKIN EXPR 1) DSKIN: intern DSKIN ADJSP 15,4 MOVEM 1,0(15) MOVE 2,L1120 HRRZI 12,372 HRRZI 13,2 PUSHJ 15,SYMFNC+372 MOVEM 1,-1(15) HRRZI 12,370 HRRZI 13,1 PUSHJ 15,SYMFNC+370 MOVEM 1,-2(15) L1121: HRRZI 12,221 SETZM 13 PUSHJ 15,SYMFNC+221 MOVEM 1,-3(15) CAMN 1,SYMVAL+377 JRST L1122 HRRZI 12,254 HRRZI 13,1 PUSHJ 15,SYMFNC+254 MOVEM 1,-3(15) CAMN 0,SYMVAL+378 JRST L1121 HRRZI 12,140 HRRZI 13,1 PUSHJ 15,SYMFNC+140 JRST L1121 L1122: MOVE 1,-2(15) HRRZI 12,370 HRRZI 13,1 PUSHJ 15,SYMFNC+370 MOVE 1,-1(15) HRRZI 12,373 HRRZI 13,1 PUSHJ 15,SYMFNC+373 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L1120: <30_31>+375 ; (!*ENTRY LAPIN EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*PROGBIND (NONLOCALVARS (!$FLUID !*PVAL) (!$FLUID !*ECHO))) ; (MOVE (REG 1) (QUOTE [!*PVAL !*ECHO])) ; (PUSHJ (REG ST) (ENTRY PROGBIND)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK DSKIN EXPR 1) ; (HRRZI (REG LINKREG) 376) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY DSKIN)) ; (!*FREERSTR (NONLOCALVARS (!$FLUID !*PVAL) (!$FLUID !*ECHO))) ; (HRRZI (REG 1) 2) ; (PUSHJ (REG ST) (ENTRY UNBINDN)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) L1124: 1 <30_31>+378 <30_31>+379 1 ; (!*ENTRY LAPIN EXPR 1) LAPIN: intern LAPIN PUSH 15,1 MOVE 1,L1123 PUSHJ 15,SYMFNC+347 MOVE 1,0(15) HRRZI 12,376 HRRZI 13,1 PUSHJ 15,SYMFNC+376 HRRZI 1,2 PUSHJ 15,SYMFNC+168 ADJSP 15,-1 POPJ 15,0 L1123: <8_31>+L1124 ; (!*ENTRY OPEN EXPR 2) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (REG 2) (QUOTE INPUT)) ; (CAME (REG 2) (QUOTE INPUT)) ; (JRST (LABEL G0004)) ; (!*LINKE 0 SYSTEMOPENFILEFORINPUT EXPR 1) ; (HRRZI (REG LINKREG) 381) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY SYSTEMOPENFILEFORINPUT)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0005) (REG 2) (QUOTE OUTPUT)) ; (CAME (REG 2) (QUOTE OUTPUT)) ; (JRST (LABEL G0005)) ; (!*LINKE 0 SYSTEMOPENFILEFOROUTPUT EXPR 1) ; (HRRZI (REG LINKREG) 382) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY SYSTEMOPENFILEFOROUTPUT)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (QUOTE "Cant Open") (REG 1)) ; (MOVE (REG 1) (QUOTE "Cant Open")) ; (!*LINKE 0 IOERROR EXPR 1) ; (HRRZI (REG LINKREG) 354) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY IOERROR)) L1128: 8 byte(7)67,97,110,116,32,79,112,101,110,0 2 ; (!*ENTRY OPEN EXPR 2) OPEN: intern OPEN CAME 2,L1125 JRST L1129 HRRZI 12,381 HRRZI 13,1 JRST SYMFNC+381 L1129: CAME 2,L1126 JRST L1130 HRRZI 12,382 HRRZI 13,1 JRST SYMFNC+382 L1130: MOVE 1,L1127 HRRZI 12,354 HRRZI 13,1 JRST SYMFNC+354 L1127: <4_31>+L1128 L1126: <30_31>+383 L1125: <30_31>+375 ; (!*ENTRY CLOSE EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 INDEPENDENTCLOSECHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 384) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTCLOSECHANNEL)) 1 ; (!*ENTRY CLOSE EXPR 1) CLOSE: intern CLOSE HRRZI 12,384 HRRZI 13,1 JRST SYMFNC+384 ; (!*ENTRY RDS EXPR 1) ; (!*ALLOC 0) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE 0) (REG 1)) ; (SETZM (REG 1)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*MOVE (!$GLOBAL IN!*) (REG 2)) ; (MOVE (REG 2) (!$GLOBAL IN!*)) ; (!*MOVE (REG 1) (!$GLOBAL IN!*)) ; (MOVEM (REG 1) (!$GLOBAL IN!*)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY RDS EXPR 1) RDS: intern RDS L1131: MOVE 3,1 CAME 1,0 JRST L1132 SETZM 1 JRST L1131 L1132: MOVE 2,0 MOVE 2,SYMVAL+385 MOVEM 1,SYMVAL+385 MOVE 1,2 POPJ 15,0 ; (!*ENTRY WRS EXPR 1) ; (!*ALLOC 0) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE NIL)) ; (CAME (REG 1) (REG NIL)) ; (JRST (LABEL G0004)) ; (!*MOVE (QUOTE 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*MOVE (!$GLOBAL OUT!*) (REG 2)) ; (MOVE (REG 2) (!$GLOBAL OUT!*)) ; (!*MOVE (REG 1) (!$GLOBAL OUT!*)) ; (MOVEM (REG 1) (!$GLOBAL OUT!*)) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY WRS EXPR 1) WRS: intern WRS L1133: MOVE 3,1 CAME 1,0 JRST L1134 HRRZI 1,1 JRST L1133 L1134: MOVE 2,0 MOVE 2,SYMVAL+154 MOVEM 1,SYMVAL+154 MOVE 1,2 POPJ 15,0 ; (!*ENTRY FINDFREECHANNEL EXPR 0) ; (!*PUSH (WCONST 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*LBL (LABEL G0005)) ; (!*JUMPEQ (LABEL G0004) (WCONST 0) (MEMORY (FRAME 1) (WCONST CHANNELSTATUS))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (SKIPN (INDEXED (REG T2) (IMMEDIATE CHANNELSTATUS))) ; (JRST (LABEL G0004)) ; (!*JUMPWLESSP (LABEL G0009) (FRAME 1) (WCONST 31)) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (CAIGE (REG T1) 31) ; (JRST (LABEL G0009)) ; (!*MOVE (QUOTE "No free channels left") (REG 1)) ; (MOVE (REG 1) (QUOTE "No free channels left")) ; (!*LINK IOERROR EXPR 1) ; (HRRZI (REG LINKREG) 354) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY IOERROR)) ; (!*LBL (LABEL G0009)) ; (!*WPLUS2 (FRAME 1) (WCONST 1)) ; (AOS (INDEXED (REG ST) 0)) ; (!*JUMP (LABEL G0005)) ; (JRST (LABEL G0005)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) L1137: 20 byte(7)78,111,32,102,114,101,101,32,99,104,97,110,110,101,108,115,32,108,101,102,116,0 0 ; (!*ENTRY FINDFREECHANNEL EXPR 0) L1138: intern L1138 PUSH 15,L1135 L1139: MOVE 7,0(15) SKIPN L1110(7) JRST L1140 MOVE 6,0(15) CAIGE 6,31 JRST L1141 MOVE 1,L1136 HRRZI 12,354 HRRZI 13,1 PUSHJ 15,SYMFNC+354 L1141: AOS 0(15) JRST L1139 L1140: MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L1135: 0 L1136: <4_31>+L1137 ; (!*ENTRY SYSTEMOPENFILEFORINPUT EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FINDFREECHANNEL EXPR 0) ; (HRRZI (REG LINKREG) 389) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY FINDFREECHANNEL)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINK SYSOPENREAD EXPR 2) ; (HRRZI (REG LINKREG) 350) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY SYSOPENREAD)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST CHANNELTABLE))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE CHANNELTABLE))) ; (!*MOVE (WCONST 1) (MEMORY (FRAME 2) (WCONST CHANNELSTATUS))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (INDEXED (REG T2) (IMMEDIATE CHANNELSTATUS))) ; (!*MOVE (MEMORY (FRAME 2) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINK SYSMAXBUFFER EXPR 1) ; (HRRZI (REG LINKREG) 359) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SYSMAXBUFFER)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST MAXBUFFER))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE MAXBUFFER))) ; (!*MOVE (QUOTE INDEPENDENTREADCHAR) (REG 1)) ; (MOVE (REG 1) (QUOTE INDEPENDENTREADCHAR)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST READFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE READFUNCTION))) ; (!*MOVE (QUOTE READONLYCHANNEL) (REG 1)) ; (MOVE (REG 1) (QUOTE READONLYCHANNEL)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST WRITEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE WRITEFUNCTION))) ; (!*MOVE (QUOTE INDEPENDENTCLOSECHANNEL) (REG 1)) ; (MOVE (REG 1) (QUOTE INDEPENDENTCLOSECHANNEL)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST CLOSEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE CLOSEFUNCTION))) ; (!*MOVE (WCONST 32) (REG 2)) ; (HRRZI (REG 2) 32) ; (!*MOVE (MEMORY (FRAME 2) (WCONST MAXBUFFER)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE MAXBUFFER))) ; (!*LINK MKSTRING EXPR 2) ; (HRRZI (REG LINKREG) 188) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY MKSTRING)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 3) (!$FLUID IOBUFFER)) ; (ADD (REG 3) (!$FLUID IOBUFFER)) ; (!*MOVE (REG 1) (MEMORY (REG 3) (WCONST 1))) ; (MOVEM (REG 1) (INDEXED (REG 3) 1)) ; (!*MOVE (WCONST 0) (MEMORY (FRAME 2) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (SETZM (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (WCONST -1) (MEMORY (FRAME 2) (WCONST BUFFERLENGTH))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (SETOM (INDEXED (REG T2) (IMMEDIATE BUFFERLENGTH))) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SYSTEMOPENFILEFORINPUT EXPR 1) L1145: intern L1145 ADJSP 15,2 MOVEM 1,0(15) HRRZI 12,389 SETZM 13 PUSHJ 15,SYMFNC+389 MOVEM 1,-1(15) MOVE 2,0(15) HRRZI 12,350 HRRZI 13,2 PUSHJ 15,SYMFNC+350 MOVE 7,-1(15) MOVEM 1,L1112(7) MOVE 7,-1(15) HRRZI 6,1 MOVEM 6,L1110(7) MOVE 1,-1(15) MOVE 1,L1112(1) HRRZI 12,359 HRRZI 13,1 PUSHJ 15,SYMFNC+359 MOVE 7,-1(15) MOVEM 1,L1111(7) MOVE 1,L1142 MOVE 7,-1(15) MOVEM 1,L1104(7) MOVE 1,L1143 MOVE 7,-1(15) MOVEM 1,L1105(7) MOVE 1,L1144 MOVE 7,-1(15) MOVEM 1,L1106(7) HRRZI 2,32 MOVE 1,-1(15) MOVE 1,L1111(1) HRRZI 12,188 HRRZI 13,2 PUSHJ 15,SYMFNC+188 MOVE 3,-1(15) ADD 3,SYMVAL+390 MOVEM 1,1(3) MOVE 7,-1(15) SETZM L1113(7) MOVE 7,-1(15) SETOM L1114(7) MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L1144: <30_31>+384 L1143: <30_31>+364 L1142: <30_31>+391 ; (!*ENTRY SYSTEMOPENFILEFOROUTPUT EXPR 1) ; (!*ALLOC 2) ; (ADJSP (REG ST) 2) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK FINDFREECHANNEL EXPR 0) ; (HRRZI (REG LINKREG) 389) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY FINDFREECHANNEL)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*LINK SYSOPENWRITE EXPR 2) ; (HRRZI (REG LINKREG) 351) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY SYSOPENWRITE)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST CHANNELTABLE))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE CHANNELTABLE))) ; (!*MOVE (WCONST 2) (MEMORY (FRAME 2) (WCONST CHANNELSTATUS))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (HRRZI (REG T1) 2) ; (MOVEM (REG T1) (INDEXED (REG T2) (IMMEDIATE CHANNELSTATUS))) ; (!*MOVE (MEMORY (FRAME 2) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINK SYSMAXBUFFER EXPR 1) ; (HRRZI (REG LINKREG) 359) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY SYSMAXBUFFER)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST MAXBUFFER))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE MAXBUFFER))) ; (!*MOVE (QUOTE WRITEONLYCHANNEL) (REG 1)) ; (MOVE (REG 1) (QUOTE WRITEONLYCHANNEL)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST READFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE READFUNCTION))) ; (!*MOVE (QUOTE INDEPENDENTWRITECHAR) (REG 1)) ; (MOVE (REG 1) (QUOTE INDEPENDENTWRITECHAR)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST WRITEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE WRITEFUNCTION))) ; (!*MOVE (QUOTE INDEPENDENTCLOSECHANNEL) (REG 1)) ; (MOVE (REG 1) (QUOTE INDEPENDENTCLOSECHANNEL)) ; (!*MOVE (REG 1) (MEMORY (FRAME 2) (WCONST CLOSEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE CLOSEFUNCTION))) ; (!*MOVE (WCONST 32) (REG 2)) ; (HRRZI (REG 2) 32) ; (!*MOVE (MEMORY (FRAME 2) (WCONST MAXBUFFER)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE MAXBUFFER))) ; (!*LINK MKSTRING EXPR 2) ; (HRRZI (REG LINKREG) 188) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY MKSTRING)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 3) (!$FLUID IOBUFFER)) ; (ADD (REG 3) (!$FLUID IOBUFFER)) ; (!*MOVE (REG 1) (MEMORY (REG 3) (WCONST 1))) ; (MOVEM (REG 1) (INDEXED (REG 3) 1)) ; (!*MOVE (WCONST -1) (MEMORY (FRAME 2) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (SETOM (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (WCONST -1) (MEMORY (FRAME 2) (WCONST BUFFERLENGTH))) ; (MOVE (REG T2) (INDEXED (REG ST) -1)) ; (SETOM (INDEXED (REG T2) (IMMEDIATE BUFFERLENGTH))) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SYSTEMOPENFILEFOROUTPUT EXPR 1) L1149: intern L1149 ADJSP 15,2 MOVEM 1,0(15) HRRZI 12,389 SETZM 13 PUSHJ 15,SYMFNC+389 MOVEM 1,-1(15) MOVE 2,0(15) HRRZI 12,351 HRRZI 13,2 PUSHJ 15,SYMFNC+351 MOVE 7,-1(15) MOVEM 1,L1112(7) MOVE 7,-1(15) HRRZI 6,2 MOVEM 6,L1110(7) MOVE 1,-1(15) MOVE 1,L1112(1) HRRZI 12,359 HRRZI 13,1 PUSHJ 15,SYMFNC+359 MOVE 7,-1(15) MOVEM 1,L1111(7) MOVE 1,L1146 MOVE 7,-1(15) MOVEM 1,L1104(7) MOVE 1,L1147 MOVE 7,-1(15) MOVEM 1,L1105(7) MOVE 1,L1148 MOVE 7,-1(15) MOVEM 1,L1106(7) HRRZI 2,32 MOVE 1,-1(15) MOVE 1,L1111(1) HRRZI 12,188 HRRZI 13,2 PUSHJ 15,SYMFNC+188 MOVE 3,-1(15) ADD 3,SYMVAL+390 MOVEM 1,1(3) MOVE 7,-1(15) SETOM L1113(7) MOVE 7,-1(15) SETOM L1114(7) MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L1148: <30_31>+384 L1147: <30_31>+152 L1146: <30_31>+361 ; (!*ENTRY SYSTEMOPENFILESPECIAL EXPR 1) ; (!*ALLOC 0) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (QUOTE NIL) (REG 2)) ; (MOVE (REG 2) (REG NIL)) ; (!*MOVE (WCONST 3) (MEMORY (REG 2) (WCONST CHANNELSTATUS))) ; (HRRZI (REG T1) 3) ; (MOVEM (REG T1) (INDEXED (REG 2) (IMMEDIATE CHANNELSTATUS))) ; (!*MOVE (REG 2) (REG 1)) ; (MOVE (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SYSTEMOPENFILESPECIAL EXPR 1) L1150: intern L1150 MOVE 3,1 MOVE 2,0 HRRZI 6,3 MOVEM 6,L1110(2) MOVE 1,2 POPJ 15,0 ; (!*ENTRY TESTLEGALCHANNEL EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTTYPE (LABEL G0005) (REG 1) POSINT) ; (TLNE (REG 1) 253952) ; (JRST (LABEL G0005)) ; (!*JUMPWLEQ (LABEL G0004) (REG 1) (WCONST 31)) ; (CAIG (REG 1) 31) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (QUOTE " is not a legal channel ") (REG 2)) ; (MOVE (REG 2) (QUOTE " is not a legal channel ")) ; (!*LINK LIST2 EXPR 2) ; (HRRZI (REG LINKREG) 183) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LIST2)) ; (!*LINKE 0 IOERROR EXPR 1) ; (HRRZI (REG LINKREG) 354) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY IOERROR)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L1152: 23 byte(7)32,105,115,32,110,111,116,32,97,32,108,101,103,97,108,32,99,104,97,110,110,101,108,32,0 1 ; (!*ENTRY TESTLEGALCHANNEL EXPR 1) L1153: intern L1153 TLNE 1,253952 JRST L1154 CAIG 1,31 JRST L1155 L1154: MOVE 2,L1151 HRRZI 12,183 HRRZI 13,2 PUSHJ 15,SYMFNC+183 HRRZI 12,354 HRRZI 13,1 JRST SYMFNC+354 L1155: MOVE 1,0 POPJ 15,0 L1151: <4_31>+L1152 ; (!*ENTRY INDEPENDENTREADCHAR EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK TESTLEGALCHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 393) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY TESTLEGALCHANNEL)) ; (!*JUMPWGEQ (LABEL G0004) (MEMORY (FRAME 1) (WCONST BUFFERLENGTH)) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVE (REG T1) (INDEXED (REG T1) (IMMEDIATE BUFFERLENGTH))) ; (CAML (REG T1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (JRST (LABEL G0004)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 2) (!$FLUID IOBUFFER)) ; (ADD (REG 2) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 2) (WCONST 1)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINK SYSREADREC EXPR 2) ; (HRRZI (REG LINKREG) 353) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY SYSREADREC)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST BUFFERLENGTH))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE BUFFERLENGTH))) ; (!*MOVE (WCONST 0) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (SETZM (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*LBL (LABEL G0004)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (MOVE (REG 2) (INDEXED (REG 2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 3) (!$FLUID IOBUFFER)) ; (ADD (REG 3) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 3) (WCONST 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE NEXTPOSITION))) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*JUMPEQ (LABEL G0009) (QUOTE NIL) (!$FLUID !*ECHO)) ; (CAMN (REG NIL) (!$FLUID !*ECHO)) ; (JRST (LABEL G0009)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK WRITECHAR EXPR 1) ; (HRRZI (REG LINKREG) 153) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY WRITECHAR)) ; (!*LBL (LABEL G0009)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 1 ; (!*ENTRY INDEPENDENTREADCHAR EXPR 1) L1157: intern L1157 ADJSP 15,3 MOVEM 1,0(15) HRRZI 12,393 HRRZI 13,1 PUSHJ 15,SYMFNC+393 MOVE 6,0(15) MOVE 7,0(15) MOVE 6,L1114(6) CAML 6,L1113(7) JRST L1158 MOVE 2,0(15) ADD 2,SYMVAL+390 MOVE 2,1(2) MOVE 1,0(15) MOVE 1,L1112(1) HRRZI 12,353 HRRZI 13,2 PUSHJ 15,SYMFNC+353 MOVEM 1,-2(15) MOVE 7,0(15) MOVEM 1,L1114(7) MOVE 7,0(15) SETZM L1113(7) L1158: MOVE 2,0(15) MOVE 2,L1113(2) MOVE 3,0(15) ADD 3,SYMVAL+390 MOVE 1,1(3) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L1156 LDB 1,2 MOVEM 1,-1(15) MOVE 1,0(15) MOVE 1,L1113(1) AOS 1 MOVE 7,0(15) MOVEM 1,L1113(7) CAMN 0,SYMVAL+379 JRST L1159 MOVE 1,-1(15) HRRZI 12,153 HRRZI 13,1 PUSHJ 15,SYMFNC+153 L1159: MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L1156: point 7,0(1),6 ; (!*ENTRY INDEPENDENTWRITECHAR EXPR 2) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TESTLEGALCHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 393) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY TESTLEGALCHANNEL)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE NEXTPOSITION))) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (MOVE (REG 2) (INDEXED (REG 2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (FRAME 1) (REG 4)) ; (MOVE (REG 4) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 4) (!$FLUID IOBUFFER)) ; (ADD (REG 4) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 4) (WCONST 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 4) 1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK PUTBYTE EXPR 3) ; (HRRZI (REG LINKREG) 187) ; (HRRZI (REG NARGREG) 3) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (DPB (REG 3) (REG 2)) ; (!*JUMPEQ (LABEL G0006) (REG 3) (WCONST 10)) ; (CAIN (REG 3) 10) ; (JRST (LABEL G0006)) ; (!*JUMPWGREATERP (LABEL G0004) (MEMORY (FRAME 1) (WCONST BUFFERLENGTH)) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVE (REG T1) (INDEXED (REG T1) (IMMEDIATE BUFFERLENGTH))) ; (CAMLE (REG T1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0006)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (MOVE (REG 3) (INDEXED (REG 3) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 2) (!$FLUID IOBUFFER)) ; (ADD (REG 2) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 2) (WCONST 1)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINK SYSWRITEREC EXPR 3) ; (HRRZI (REG LINKREG) 356) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY SYSWRITEREC)) ; (!*MOVE (WCONST -1) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (SETOM (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*LBL (LABEL G0004)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) 2 ; (!*ENTRY INDEPENDENTWRITECHAR EXPR 2) L1161: intern L1161 PUSH 15,2 PUSH 15,1 HRRZI 12,393 HRRZI 13,1 PUSHJ 15,SYMFNC+393 MOVE 1,0(15) MOVE 1,L1113(1) AOS 1 MOVE 7,0(15) MOVEM 1,L1113(7) MOVE 3,-1(15) MOVE 2,0(15) MOVE 2,L1113(2) MOVE 4,0(15) ADD 4,SYMVAL+390 MOVE 1,1(4) AOS 1 HRRZI 12,187 HRRZI 13,3 ADJBP 2,L1160 DPB 3,2 CAIN 3,10 JRST L1162 MOVE 6,0(15) MOVE 7,0(15) MOVE 6,L1114(6) CAMLE 6,L1113(7) JRST L1163 L1162: MOVE 3,0(15) MOVE 3,L1113(3) MOVE 2,0(15) ADD 2,SYMVAL+390 MOVE 2,1(2) MOVE 1,0(15) MOVE 1,L1112(1) HRRZI 12,356 HRRZI 13,3 PUSHJ 15,SYMFNC+356 MOVE 7,0(15) SETOM L1113(7) L1163: MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L1160: point 7,0(1),6 ; (!*ENTRY SYSTEMMARKASCLOSEDCHANNEL EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TESTLEGALCHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 393) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY TESTLEGALCHANNEL)) ; (!*MOVE (WCONST 0) (MEMORY (FRAME 1) (WCONST CHANNELSTATUS))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (SETZM (INDEXED (REG T2) (IMMEDIATE CHANNELSTATUS))) ; (!*MOVE (QUOTE CHANNELNOTOPEN) (REG 1)) ; (MOVE (REG 1) (QUOTE CHANNELNOTOPEN)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST CLOSEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE CLOSEFUNCTION))) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST WRITEFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE WRITEFUNCTION))) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST READFUNCTION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE READFUNCTION))) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY SYSTEMMARKASCLOSEDCHANNEL EXPR 1) L1165: intern L1165 PUSH 15,1 HRRZI 12,393 HRRZI 13,1 PUSHJ 15,SYMFNC+393 MOVE 7,0(15) SETZM L1110(7) MOVE 1,L1164 MOVE 7,0(15) MOVEM 1,L1106(7) MOVE 7,0(15) MOVEM 1,L1105(7) MOVE 7,0(15) MOVEM 1,L1104(7) ADJSP 15,-1 POPJ 15,0 L1164: <30_31>+363 ; (!*ENTRY INDEPENDENTCLOSECHANNEL EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LINK TESTLEGALCHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 393) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY TESTLEGALCHANNEL)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINKE 1 SYSCLOSE EXPR 1) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 357) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY SYSCLOSE)) 1 ; (!*ENTRY INDEPENDENTCLOSECHANNEL EXPR 1) L1166: intern L1166 PUSH 15,1 HRRZI 12,393 HRRZI 13,1 PUSHJ 15,SYMFNC+393 MOVE 1,0(15) MOVE 1,L1112(1) ADJSP 15,-1 HRRZI 12,357 HRRZI 13,1 JRST SYMFNC+357 ; (!*ENTRY CLEARONECHANNEL EXPR 3) ; (!*PUSH (REG 2)) ; (PUSH (REG ST) (REG 2)) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*MOVE (REG 2) (MEMORY (REG 1) (WCONST MAXBUFFER))) ; (MOVEM (REG 2) (INDEXED (REG 1) (IMMEDIATE MAXBUFFER))) ; (!*MOVE (WCONST 0) (MEMORY (REG 1) (WCONST NEXTPOSITION))) ; (SETZM (INDEXED (REG 1) (IMMEDIATE NEXTPOSITION))) ; (!*JUMPNOTEQ (LABEL G0004) (REG 3) (QUOTE INPUT)) ; (CAME (REG 3) (QUOTE INPUT)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST -1) (MEMORY (REG 1) (WCONST BUFFERLENGTH))) ; (SETOM (INDEXED (REG 1) (IMMEDIATE BUFFERLENGTH))) ; (!*JUMP (LABEL G0003)) ; (JRST (LABEL G0003)) ; (!*LBL (LABEL G0004)) ; (!*MOVE (WCONST 0) (MEMORY (REG 1) (WCONST BUFFERLENGTH))) ; (SETZM (INDEXED (REG 1) (IMMEDIATE BUFFERLENGTH))) ; (!*LBL (LABEL G0003)) ; (!*MOVE (WCONST 32) (REG 2)) ; (HRRZI (REG 2) 32) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK MKSTRING EXPR 2) ; (HRRZI (REG LINKREG) 188) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY MKSTRING)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 2) (!$FLUID IOBUFFER)) ; (ADD (REG 2) (!$FLUID IOBUFFER)) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 1))) ; (MOVEM (REG 1) (INDEXED (REG 2) 1)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY CLEARONECHANNEL EXPR 3) L1168: intern L1168 PUSH 15,2 PUSH 15,1 MOVEM 2,L1111(1) SETZM L1113(1) CAME 3,L1167 JRST L1169 SETOM L1114(1) JRST L1170 L1169: SETZM L1114(1) L1170: HRRZI 2,32 MOVE 1,-1(15) HRRZI 12,188 HRRZI 13,2 PUSHJ 15,SYMFNC+188 MOVE 2,0(15) ADD 2,SYMVAL+390 MOVEM 1,1(2) ADJSP 15,-2 POPJ 15,0 L1167: <30_31>+375 ; (!*ENTRY CLEARIO EXPR 0) ; (!*ALLOC 0) ; (!*LINK SYSCLEARIO EXPR 0) ; (HRRZI (REG LINKREG) 348) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY SYSCLEARIO)) ; (!*JUMPTYPE (LABEL G0003) (!$FLUID IOBUFFER) VECT) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (!$FLUID IOBUFFER) 0 5)))) ; (CAIN (REG T6) 8) ; (JRST (LABEL G0003)) ; (!*MOVE (WCONST 31) (REG 1)) ; (HRRZI (REG 1) 31) ; (!*LINK MKVECT EXPR 1) ; (HRRZI (REG LINKREG) 182) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY MKVECT)) ; (!*MOVE (REG 1) (!$FLUID IOBUFFER)) ; (MOVEM (REG 1) (!$FLUID IOBUFFER)) ; (!*MOVE (QUOTE INPUT) (REG 3)) ; (MOVE (REG 3) (QUOTE INPUT)) ; (!*MOVE (WCONST 200) (REG 2)) ; (HRRZI (REG 2) 200) ; (!*MOVE (!$FLUID STDIN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID STDIN!*)) ; (!*LINK CLEARONECHANNEL EXPR 3) ; (HRRZI (REG LINKREG) 395) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY CLEARONECHANNEL)) ; (!*MOVE (QUOTE OUTPUT) (REG 3)) ; (MOVE (REG 3) (QUOTE OUTPUT)) ; (!*MOVE (WCONST 200) (REG 2)) ; (HRRZI (REG 2) 200) ; (!*MOVE (!$FLUID STDOUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID STDOUT!*)) ; (!*LINK CLEARONECHANNEL EXPR 3) ; (HRRZI (REG LINKREG) 395) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY CLEARONECHANNEL)) ; (!*MOVE (QUOTE OUTPUT) (REG 3)) ; (MOVE (REG 3) (QUOTE OUTPUT)) ; (!*MOVE (WCONST 200) (REG 2)) ; (HRRZI (REG 2) 200) ; (!*MOVE (!$FLUID ERROUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID ERROUT!*)) ; (!*LINK CLEARONECHANNEL EXPR 3) ; (HRRZI (REG LINKREG) 395) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY CLEARONECHANNEL)) ; (!*MOVE (QUOTE OUTPUT) (REG 3)) ; (MOVE (REG 3) (QUOTE OUTPUT)) ; (!*MOVE (WCONST 200) (REG 2)) ; (HRRZI (REG 2) 200) ; (!*MOVE (!$FLUID PROMPTOUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID PROMPTOUT!*)) ; (!*LINK CLEARONECHANNEL EXPR 3) ; (HRRZI (REG LINKREG) 395) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY CLEARONECHANNEL)) ; (!*LBL (LABEL G0003)) ; (!*MOVE (!$FLUID STDIN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID STDIN!*)) ; (!*MOVE (REG 1) (!$FLUID IN!*)) ; (MOVEM (REG 1) (!$FLUID IN!*)) ; (!*MOVE (!$FLUID STDOUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID STDOUT!*)) ; (!*MOVE (REG 1) (!$FLUID OUT!*)) ; (MOVEM (REG 1) (!$FLUID OUT!*)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (!$FLUID IOBUFFER) 0 5)) 0 ; (!*ENTRY CLEARIO EXPR 0) L1174: intern L1174 HRRZI 12,348 SETZM 13 PUSHJ 15,SYMFNC+348 LDB 11,L1171 CAIN 11,8 JRST L1175 HRRZI 1,31 HRRZI 12,182 HRRZI 13,1 PUSHJ 15,SYMFNC+182 MOVEM 1,SYMVAL+390 MOVE 3,L1172 HRRZI 2,200 MOVE 1,SYMVAL+386 HRRZI 12,395 HRRZI 13,3 PUSHJ 15,SYMFNC+395 MOVE 3,L1173 HRRZI 2,200 MOVE 1,SYMVAL+387 HRRZI 12,395 HRRZI 13,3 PUSHJ 15,SYMFNC+395 MOVE 3,L1173 HRRZI 2,200 MOVE 1,SYMVAL+340 HRRZI 12,395 HRRZI 13,3 PUSHJ 15,SYMFNC+395 MOVE 3,L1173 HRRZI 2,200 MOVE 1,SYMVAL+388 HRRZI 12,395 HRRZI 13,3 PUSHJ 15,SYMFNC+395 L1175: MOVE 1,SYMVAL+386 MOVEM 1,SYMVAL+385 MOVE 1,SYMVAL+387 MOVEM 1,SYMVAL+154 POPJ 15,0 L1171: point 5,<SYMVAL+390>,4 L1173: <30_31>+383 L1172: <30_31>+375 ; (!*ENTRY TERMINALINPUTHANDLER EXPR 1) ; (!*ALLOC 3) ; (ADJSP (REG ST) 3) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK TESTLEGALCHANNEL EXPR 1) ; (HRRZI (REG LINKREG) 393) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY TESTLEGALCHANNEL)) ; (!*JUMPWGEQ (LABEL G0004) (MEMORY (FRAME 1) (WCONST BUFFERLENGTH)) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVE (REG T1) (INDEXED (REG T1) (IMMEDIATE BUFFERLENGTH))) ; (CAML (REG T1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (JRST (LABEL G0004)) ; (!*JUMPNOTTYPE (LABEL G0007) (!$FLUID PROMPTSTRING!*) STR) ; (LDB (REG T6) (LIT (FULLWORD (FIELDPOINTER (!$FLUID PROMPTSTRING!*) 0 5)))) ; (CAIE (REG T6) 4) ; (JRST (LABEL G0007)) ; (!*MOVE (!$FLUID PROMPTSTRING!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID PROMPTSTRING!*)) ; (!*JUMP (LABEL G0006)) ; (JRST (LABEL G0006)) ; (!*LBL (LABEL G0007)) ; (!*MOVE (QUOTE ">") (REG 1)) ; (MOVE (REG 1) (QUOTE ">")) ; (!*LBL (LABEL G0006)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID PROMPTOUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID PROMPTOUT!*)) ; (!*LINK CHANNELWRITESTRING EXPR 2) ; (HRRZI (REG LINKREG) 397) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY CHANNELWRITESTRING)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 2) (!$FLUID IOBUFFER)) ; (ADD (REG 2) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 2) (WCONST 1)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG 2) 1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST CHANNELTABLE)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE CHANNELTABLE))) ; (!*LINK SYSREADREC EXPR 2) ; (HRRZI (REG LINKREG) 353) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY SYSREADREC)) ; (!*MOVE (REG 1) (FRAME 3)) ; (MOVEM (REG 1) (INDEXED (REG ST) -2)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST BUFFERLENGTH))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE BUFFERLENGTH))) ; (!*MOVE (WCONST 0) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (SETZM (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*LBL (LABEL G0004)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (MOVE (REG 2) (INDEXED (REG 2) (IMMEDIATE NEXTPOSITION))) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*WPLUS2 (REG 3) (!$FLUID IOBUFFER)) ; (ADD (REG 3) (!$FLUID IOBUFFER)) ; (!*MOVE (MEMORY (REG 3) (WCONST 1)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG 3) 1)) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*LINK BYTE EXPR 2) ; (HRRZI (REG LINKREG) 147) ; (HRRZI (REG NARGREG) 2) ; (ADJBP (REG 2) (LIT (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)))) ; (LDB (REG 1) (REG 2)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*MOVE (MEMORY (FRAME 1) (WCONST NEXTPOSITION)) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (MOVE (REG 1) (INDEXED (REG 1) (IMMEDIATE NEXTPOSITION))) ; (!*WPLUS2 (REG 1) (WCONST 1)) ; (AOS (REG 1)) ; (!*MOVE (REG 1) (MEMORY (FRAME 1) (WCONST NEXTPOSITION))) ; (MOVE (REG T2) (INDEXED (REG ST) 0)) ; (MOVEM (REG 1) (INDEXED (REG T2) (IMMEDIATE NEXTPOSITION))) ; (!*JUMPEQ (LABEL G0014) (QUOTE NIL) (!$FLUID !*ECHO)) ; (CAMN (REG NIL) (!$FLUID !*ECHO)) ; (JRST (LABEL G0014)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK WRITECHAR EXPR 1) ; (HRRZI (REG LINKREG) 153) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY WRITECHAR)) ; (!*LBL (LABEL G0014)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*EXIT 3) ; (ADJSP (REG ST) (MINUS 3)) ; (POPJ (REG ST) 0) ; (FULLWORD (FIELDPOINTER (!$FLUID PROMPTSTRING!*) 0 5)) ; (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) L1179: 0 byte(7)62,0 1 ; (!*ENTRY TERMINALINPUTHANDLER EXPR 1) L1180: intern L1180 ADJSP 15,3 MOVEM 1,0(15) HRRZI 12,393 HRRZI 13,1 PUSHJ 15,SYMFNC+393 MOVE 6,0(15) MOVE 7,0(15) MOVE 6,L1114(6) CAML 6,L1113(7) JRST L1181 LDB 11,L1176 CAIE 11,4 JRST L1182 MOVE 1,SYMVAL+398 JRST L1183 L1182: MOVE 1,L1177 L1183: MOVE 2,1 MOVE 1,SYMVAL+388 HRRZI 12,397 HRRZI 13,2 PUSHJ 15,SYMFNC+397 MOVE 2,0(15) ADD 2,SYMVAL+390 MOVE 2,1(2) MOVE 1,0(15) MOVE 1,L1112(1) HRRZI 12,353 HRRZI 13,2 PUSHJ 15,SYMFNC+353 MOVEM 1,-2(15) MOVE 7,0(15) MOVEM 1,L1114(7) MOVE 7,0(15) SETZM L1113(7) L1181: MOVE 2,0(15) MOVE 2,L1113(2) MOVE 3,0(15) ADD 3,SYMVAL+390 MOVE 1,1(3) AOS 1 HRRZI 12,147 HRRZI 13,2 ADJBP 2,L1178 LDB 1,2 MOVEM 1,-1(15) MOVE 1,0(15) MOVE 1,L1113(1) AOS 1 MOVE 7,0(15) MOVEM 1,L1113(7) CAMN 0,SYMVAL+379 JRST L1184 MOVE 1,-1(15) HRRZI 12,153 HRRZI 13,1 PUSHJ 15,SYMFNC+153 L1184: MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L1176: point 5,<SYMVAL+398>,4 L1178: point 7,0(1),6 L1177: <4_31>+L1179 end |
Added psl-1983/20-tests/sub7.rel version [f66489d72b].
cannot compute difference between binary files
Added psl-1983/20-tests/test-dec20-cross.mic version [ec23f01556].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | @delete s:test-dec20-cross.exe, exp @get psl:rlisp @st *Options!*:=NIL; % Force reload of ALL *load(zboot, syslisp, if!-system, lap!-to!-asm); *load(dec20!-comp,dec20!-cmac,dec20!-asm); *remflag(''(extrareg),''terminaloperand); *off usermode; *in "P20T:DEC20-PATCHES.sl"$ *Date!* := "PATCHED Dec 20 cross compiler"; *Dumplisp "S:TEST-DEC20-CROSS.EXE"; *Quit; @reset . |
Added psl-1983/20-tests/test-guide.err version [689c76ff59].
> > > > > | 1 2 3 4 5 | @Comment{ErrLog of TEST-GUIDE.MSS.17 by Scribe 3C(1254) on 24 July 1982 at 13:19} Error in MAINN command found while processing the manuscript. TEST-GUIDE.MSS.17 line 287: @@EX @MAINn.CMD The name @MAINN is not defined in document type article. |
Added psl-1983/20-tests/test-guide.otl version [312ccb6cab].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @Comment{OUTLINE of TEST-GUIDE.MSS.17 by Scribe 3C(1254) on 24 July 1982 at 13:19} 1. Introduction 1 TEST-GUIDE.MSS.17 line 51 2. Basic I/O Support 1 TEST-GUIDE.MSS.17 line 64 3. LAP and CMACRO Tests 4 TEST-GUIDE.MSS.17 line 181 4. SysLisp Tests 4 TEST-GUIDE.MSS.17 line 189 5. Mini PSL Tests 7 TEST-GUIDE.MSS.17 line 295 6. Full PSL Tests 7 TEST-GUIDE.MSS.17 line 306 7. References 8 TEST-GUIDE.MSS.17 line 322 I. Sample DEC-20 Output 9 TEST-GUIDE.MSS.17 line 325 Table of Contents 1 <PSL.TESTS.20>-SCRIBE-SCRATCH-.15-3-1.100015 line 3 |
Added psl-1983/20-tests/time-psl.out version [c909ac5773].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Spectral Tests, DEC-20 test system, No-Date-Yet --------------------------------------------------------------- *** Dummy RECLAIM: 9815 Items used, 140185 Items left. EmptyTest 10000 18 SlowEmptyTest 10000 187 Cdr1Test 100 529 Cdr2Test 100 374 CddrTest 100 273 ListOnlyCdrTest1 1776 ListOnlyCddrTest1 3322 ListOnlyCdrTest2 2759 ListOnlyCddrTest2 4144 ReverseTest 10 459 *** Dummy RECLAIM: 46911 Items used, 103089 Items left. MyReverse1Test 10 466 *** Dummy RECLAIM: 83575 Items used, 66425 Items left. MyReverse2Test 10 456 *** Dummy RECLAIM: 120239 Items used, 29761 Items left. LengthTest 100 591 ArithmeticTest 10000 649 EvalTest 10000 2593 tak 18 12 6 489 gtak 18 12 6 1394 gtsta g0 1139 gtsta g1 1211 |
Added psl-1983/20-tests/utah-20-time-psl.out version [48e46123f3].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | PSL Spectral Tests, DEC-20, standard 3.1 PSL, 4-Mar-83 --------------------------------------------------------------- EmptyTest 10000 19 SlowEmptyTest 10000 294 Cdr1Test 100 594 Cdr2Test 100 380 CddrTest 100 276 ListOnlyCdrTest1 1902 ListOnlyCddrTest1 3334 ListOnlyCdrTest2 3119 ListOnlyCddrTest2 4773 ReverseTest 10 407 MyReverse1Test 10 271 MyReverse2Test 10 256 LengthTest 100 603 ArithmeticTest 10000 582 EvalTest 10000 1969 tak 18 12 6 456 gtak 18 12 6 1920 gtsta g0 743 gtsta g1 822 |
Added psl-1983/20-tests/xxx-header.red version [9f61361358].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % XXX-HEADER.RED for DEC20 % Defines Data spaces, MAIN!. for 20 and I/O interface % % Revisions: MLG, 18 Feb 1983 % Move HEAP declarations from PT:SUB3 % and P20T:20-TEST-GLOBAL-DATA.RED % Add dummy DATE and VersionName routines on syslisp; % -----Allocate the stack area Internal WConst StackSize = 5000; Internal WArray Stack[StackSize]; exported WVar StackLowerBound = &Stack[0], StackUpperBound = &Stack[StackSize]; external WVar ST; %--- Allocate HEAP and BPS areas Internal Wconst HeapSize = 150000; % Enough for PSL-TIMER Internal Warray HEAP[HeapSize]; % Could do a Dynamic alloc exported Wvar HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], HeapLast, % next free slot in heap HeapPreviousLast; % save start of new block CommentOutcode << % If Copying GC Internal Warray OtherHeap[HeapSize]; exported WVar OldHeapLast, OldHeapLowerBound = &OtherHeap[0], OldHeapUpperBound = &OtherHeap[HeapSize]; >>; Internal Wconst BPSSize = 500; internal Warray BPS[BPSsize]; % Could do a Dynamic alloc exported WVar FirstBPS=&BPS[0], % Base of BPS, for info NextBPS = &BPS[0], % allocate CODE up LastBPS = &BPS[BPSSize], % allocate Warray down FinalBPS= &BPS[BPSSize]; % For info purposes syslsp procedure InitHeap(); % Set up Heap base etc. <<HeapLast:=HeapLowerBound; HeapPreviousLast := 0>>; % allocate for the "extra" arguments % 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1; exported WArray ArgumentBlock[MaxArgBlock]; % For the ForeignFunction calling protocol exported Wvar Arg1,Arg2,Arg3,ARg4,Arg5,Arg6,Arg7,Arg8, Arg9, Arg10,Arg11,Arg12,Arg13,Arg14,Arg15; %--- End of Data Definitions ---------- %--- Now do 20 Specific MAIN!. and I/O Interface: lap '((!*entry Main!. expr 0) (reset) (move (reg st) (lit (halfword (minus (WConst StackSize)) (difference (WConst Stack) 1)))) (move (reg NIL) (fluid NIL)) (!*LINKE 0 FirstCall Expr 0) % Call the MAINn firstroutine ); % Define "standard" LISP equivalents for the DEC20-MACRO foreign % functions defined in 20IO.MAC FLAG('( Init20 % Initialize I/O, Timer, etc PutC20 % Print Ascii Character, use 10=EOL to get end of line GetC20 % Return Ascii Character Timc20 % Return CPU time (can also print time check) Quit20 % Terminate execution, finalize Err20 % Print error message PutI20 % print an Integer ),'ForeignFunction); Global '(IN!* OUT!*); Procedure Init(); <<Init20 0; LispVar IN!*:=0; LispVar Out!*:=1; >>; % Always need one dummy argument Procedure GetC(); If LispVar IN!* eq 0 then Getc20 0 % Always need one dummy argument else IndependentReadChar LispVar IN!*; Procedure TimC(); TimC20 0; % Always need one dummy argument procedure PutC x; If LispVar Out!* eq 1 then Putc20 x else IndependentWriteChar(LispVar Out!*,x); procedure Quit; Quit20 0; % always need 1 argument procedure Date; '"No-Date-Yet"; Procedure VersionName; '"DEC-20 test system"; procedure PutInt I; PutI20 I; % SYMFNC storage routine: LAP '((!*entry !%Store!-Jcall Expr 2) % CodeAddress, Storage Address (!*alloc 0) (!*WOR (reg 1) 8#254000000000) % Load a JRST in higher-bits (!*MOVE (reg 1) (memory (reg 2) (wconst 0))) (!*EXIT 0)); LAP '((!*entry !%copy!-function!-cell Expr 2) % from to (!*alloc 0) (!*move (memory (reg 1) (Wconst 0)) (memory (reg 2) (wconst 0))) (!*exit 0)); FLUID '(UndefnCode!* UndefnNarg!*); LAP '((!*ENTRY UndefinedFunction expr 0) % For missing Function % No alloc 0 ? and no LINKE because dont want to change LinkReg (!*MOVE (reg LinkReg) (Fluid UndefnCode!*)) (!*Move (reg NargReg) (Fluid UndefnNarg!*)) (!*JCALL UndefinedFunctionAux) ); LAP '((!*ENTRY FLAG expr 2) % Dummy for INIT (!*alloc 0) (!*MOVE 2 (REG 1)) (!*LINKE 0 Err20 Expr 1) ); procedure LongTimes(x,y); x*y; procedure LongDiv(x,y); x/y; procedure LongRemainder(x,y); Remainder(x,y); off syslisp; end; |
Added psl-1983/20-tests/xxx-system-io.red version [700c440789].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %============================================================================== % % PT20:XXX-SYSTEM-IO.RED - 20 specific IO routines for PSL % % Author: Modified by Robert R. Kessler and MLG % From System-io.red for the 20 by Eric Benson % Computer Science Dept. % University of Utah % Date: Modified 16 August 1982 % Original Date 16 September 1981 % % Copyright (c) 1982 University of Utah % %============================================================================== ON Syslisp; % Each individual system must have the following routines defined. % SysClearIo, SysOpenRead, SysOpenWrite, SysReadRec, SysWriteRec, SysClose, % SysMaxBuffer % % The following definitions are used in the routines: % FileDescriptor - A machine dependent word that references a file once % opened. % FileName - A Lisp string of the file name. % % ---------- SysClearIo: % called by Cleario for system dep extras lap '((!*entry SysClearIO expr 0) % % ^C from RDTTY and restart causes trouble, but we don't want a full RESET % (don't want to close files or kill forks), so we'll just do the % part of RESET that we want, for terminal input % (!*MOVE (WConst 8#100) (reg 1)) % .priin (rfmod) (tro 2 2#001111100001000000) % tt%wak + tt%eco + .ttasi, like RESET (sfmod) (!*EXIT 0) ); syslsp procedure SysOpenRead(Channel,FileName); % % Open FileName for input and % % return a file descriptor used % % in later references to the % % file. Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 7*of%bsz of%rd 2#000111000000000000010000000000000000); %/ later... if JFN eq 0 then return ContOpenError(FileName, 'INPUT); syslsp procedure SysOpenWrite(Channel,FileName); Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 7*of%bsz of%wr 2#000111000000000000001000000000000000); %/ if JFN eq 0 then return ContOpenError(FileName, 'OUTPUT); lap '((!*entry Dec20Open expr 3) % % Dec20Open(Filename string, GTJFN bits, OPENF bits) % (!*WPLUS2 (reg 1) (WConst 1)) % increment r1 to point to characters (hrli (reg 1) 8#440700) % turn r1 into a byte pointer (!*MOVE (reg 1) (reg 4)) % save filename string in r4 (!*MOVE (reg 2) (reg 1)) % GTJFN flag bits in r1 (!*MOVE (reg 4) (reg 2)) % string in r2 (gtjfn) (!*JUMP (Label CantOpen)) (!*MOVE (reg 3) (reg 2)) % OPENF bits in r2, JFN in r1 (openf) CantOpen (!*MOVE (WConst 0) (reg 1)) % return 0 on error (!*EXIT 0) % else return the JFN ); syslsp procedure SysReadRec(FileDescriptor,StringBuffer); % % Read from the FileDescriptor, a % % record into the StringBuffer. % % Return the length of the % % string read. Begin scalar N,Ch; N:=0; Loop: Ch:=Dec20ReadChar(FileDescriptor); StrByt(StringBuffer,N):=Ch; If Ch eq Char EOL or Ch eq Char EOF then return N; N:=N+1; % Check buffer size here goto Loop; End; lap '((!*entry Dec20ReadChar expr 1) Loop (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (!*MOVE (reg 2) (reg 1)) % move char to reg 1 %/ (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char %/ (!*PUSH (reg 1)) % yes, save char %/ (!*CALL WriteChar) % and write it %/ (!*POP (reg 1)) % restore it %/ (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) ); syslsp procedure SysWriteRec (FileDescriptor, StringToWrite, StringLength); % % Write StringLength characters % % from StringToWrite from the % % first position. for i:=0:StringLength do Dec20WriteChar(FileDescriptor,strbyt(StringToWrite,i)); lap '((!*entry Dec20WriteChar expr 2) % Jfn,Chr (!*JUMPEQ (Label CRLF) (reg 2) (WConst 8#12)) % if LF, echo CRLF (bout) % no, just echo char (!*EXIT 0) % return CRLF (!*MOVE (WConst 8#15) (reg 2)) % write carriage-return (bout) (!*MOVE (WConst 8#12) (reg 2)) % write linefeed (bout) (!*EXIT 0) % return ); % SysClose (FileDescriptor); % Close FileDescriptor, allowing % % it to be reused. lap '((!*entry SysClose expr 1) (closf) (!*JUMP (Label CloseError)) (!*EXIT 0) CloseError (!*MOVE (QUOTE "Channel could not be closed") (reg 1)) (!*JCALL ChannelError) ); syslsp procedure SysMaxBuffer(FileDesc); 200; End; |
Added psl-1983/20-util/20-interrupt.red version [ec370abe56].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-INTERRUPT.RED -- Crude Interrupt Handler for DEC-20 % Author: M. L. Griss and D. Morrison % Utah Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 May 1981 % Copyright (c) University of Utah % It is assumed that the system dependent portion of an implementation will %supply the following 3 functions: % % InitializeInterrupts % EnableInterrupts % DisableInterrupts % DismissInterrupt % % While these are machine dependent, the interrupt handlers themselves are % are expected to generally be machine independent, simply calling % DismissInterrupt when done. The assignment of terminal-initiated interrupts % to keys is machine dependent. imports '(Addr2ID); % for code-address-to-symbol on Syslisp; %internal WARRAY InterruptLevelTable[2], % InterruptPCStorage[2], % InterruptChannelTable[35]; FLUID '(InterruptLevelTable LoadAverageStore InterruptPCStorage InterruptChannelTable ); compiletime << WCONST !.FHSLF=8#400000;>>; if FUnBoundP 'XJsysError then << syslsp procedure XJsysError(); % autoloading stub << Load JSYS; Apply(function XJsysError, '()) >>; >>; syslsp procedure InitializeInterrupts(); % Initializes interrupt handlers for both machine- and terminal-initiated % interrupts. Most cases should dispatch to machine-independent handlers. % Leaves the interrupt system enabled. % In this Tops-20 (machine-code) version we currently handle: % just playing, for now begin (LispVar InterruptLevelTable):=GtWarray 3; (LispVar InterruptPCStorage):=GtWarray 3; (LispVar InterruptChannelTable):=GtWarray 36; (LispVar LoadAverageStore) := MkString(4, char BLANK); ClearInterrupts(); % set up interrupt tables -- see Monitor Calls Manual for details For i := 0:35 do %/ Some bug, wiped out next one when after (LispVar InterruptChannelTable)[i]:=0; for i := 0:2 do (LispVar InterruptLevelTable)[i]:=(LispVar InterruptPCStorage) + i; % Terminal Interupts (Procedure on channel/level) % Note LEVEL is 1,2,3 PutInterrupt(0,1,'DoControlG); PutInterrupt(1,1,'SaveAndCallControlT); % control T not working yet PutInterrupt(2,1,'SaveAndBreak); % special channels PutInterrupt(6,1,'ArithOverflow); PutInterrupt(7,1,'FloatArithOverflow); PutInterrupt(9,1,'PushDownOverflow); % Now Install tables Xjsys0(!.FHSLF, XWD((LispVar InterruptLevelTable), (LispVar InterruptChannelTable)),0,0,const jsSIR); EnableInterrupts(); ActivateChannel(0); ActivateChannel(1); ActivateChannel(2); ActivateChannel(6); ActivateChannel(7); ActivateChannel(9); PutTerminalInterrupt(7,0); % Char CNTRL-G on 0 PutTerminalInterrupt(4,0); % Char CNTRL-D on 2 PutTerminalInterrupt(20,1); % Char cntrl-t on 1, not working yet PutTerminalInterrupt(0,2); % Char BREAK on 2 PutTerminalInterrupt(2,2); % Char cntrl-B on 2 ClearInterrupts(); end; syslsp procedure SetContinueAddress(Level,Address); begin scalar x; x:=(LispVar InterruptLevelTable)[Level-1]; x[0]:=address; end; % FunctionCellLocation is used by LAP off Syslisp; fluid '(!*WritingFaslFile); lisp procedure SetContinueFunction(Level,FunctionName); begin scalar !*WritingFaslFile; SetContinueAddress(Level, FunctionCellLocation FunctionName); end; lisp procedure PutInterrupt(Channel,Level,ActionId); begin scalar !*WritingFaslFile; WPutV(InterruptChannelTable, Channel, XWD(Level, FunctionCellLocation ActionId)); end; on Syslisp; syslsp procedure XWD(a,b); Lor(Lsh(a,18),b); syslsp procedure PutTerminalInterrupt(CntrlChar,Channel); Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsATI); syslsp procedure RemoveTerminalInterrupt(CntrlChar,Channel); Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsDTI); syslsp procedure ReadTerminalWord; Xjsys1(0,0,0,0,Const jsRTIW); syslsp procedure SetTerminalWordBit(n); <<XJsys0(Lor(ReadTerminalLWord(),Dec20Bit n),0,0,const jsSTIW); ReadTerminalWord()>>; syslsp procedure SetTerminalWord(MSK); <<Xjsys0(Lor(ReadTerminalWord(),MSK),0,0,0,const jsSTIW); ReadTerminalWord()>>; syslsp procedure ClearInterrupts; Xjsys0(0,0,0,0,const jsCIS); % clear any pending interrupts syslsp procedure SignalChannel n; %. Test on channel n Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsIIC); syslsp procedure EnableInterrupts; Xjsys0(!.FHSLF,0,0,0,const jsEIR); syslsp procedure DisableInterrupts; Xjsys0(!.FHSLF,0,0,0,const jsDIR); syslsp procedure ActivateChannel(n); %. Inform OS of channel Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsAIC); syslsp procedure DeActivateChannel(n); %. Inform OS of channel Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsDIC); syslsp procedure Dec20Bit n; %. Bits [0 to 35] Dec20Fld(1,35-n); syslsp procedure Dec20Fld(x,y); LSH(x,y); syslsp procedure DismissInterrupt; % Warning: an interrupt handler should not attempt to resume if may have % caused a garbage collection. Xjsys0(0,0,0,0,const jsDEBRK); % ----- Some default handlers ---------- syslsp procedure DoControlG; << ClearTerminalInputBuffer(); % CFIBF ChannelWriteChar(LispVAR StdOUT!*, Char BELL); ErrorPrintF "*** Restarting"; SetContinueFunction(1,'Reset); DismissInterrupt()>>; syslsp procedure ClearTerminalInputBuffer(); Xjsys0(8#100,0,0,0,const jsCFIBF); syslsp procedure ArithOverflow; <<SetContinueFunction(1,'ArithOverFlowError); DismissInterrupt()>>; syslsp procedure ArithOverFlowError; StdError('"Integer overflow"); syslsp procedure FloatArithOverflow; <<SetContinueFunction(1,'FloatArithOverFlowError); DismissInterrupt()>>; syslsp procedure FloatArithOverFlowError; StdError('"Floating point overflow"); lap '((!*entry PushDownOverflow expr 0) (sub (reg st) (lit (halfword 1000 1000))) % move the stack back (!*MOVE (WConst 1) (REG 1)) (movei 2 ErrorAddress) (!*CALL SetContinueAddress) (!*JCALL DismissInterrupt) ErrorAddress (!*MOVE '"Stack overflow" (reg 1)) (!*JCALL StdError) % normal error ); lap '((!*entry FindLoadAverage expr 0) (move 1 (lit (fullword 8#000014000014))) % 1 min avg, .systa (getab) (!*EXIT 0) (hrrz 2 (fluid LoadAverageStore)) (hrli 2 8#10700) % make a byte pointer (exch 1 2) (move 3 (lit (fullword 8#024037020200))) (flout) (!*EXIT 0) (!*EXIT 0) ); syslsp procedure DoControlT(); begin scalar RunningFunctionID, CameFrom; % ClearTerminalInputBuffer(); FindLoadAverage(); CameFrom := INF ((LispVar InterruptPCStorage)[0]); RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN; ErrorPrintF("^T: in %p at %o, load %w", RunningFunctionID, CameFrom, LispVar LoadAverageStore); end; >>; syslsp procedure DoBreak(); begin scalar RunningFunctionID, CameFrom, CurrentChannel; ClearTerminalInputBuffer(); CameFrom := INF( (LispVar InterruptPCStorage)[0]); RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN; CurrentChannel := WRS NIL; ErrorPrintF("*** Break in %p at %o", RunningFunctionID, CameFrom); ErrorSet(quote Break(), NIL, NIL); WRS CurrentChannel; end; lap '((!*Entry SaveAndCallControlT expr 0) % % Save all regs, call DoControlT and dismiss % (adjsp (reg st) 14) % allocate 14 slots on the stack (hrri (reg nil) (indexed (reg st) -13)) % set up BLT pointer (hrli (reg nil) 1) % move regs 1..14 onto the stack (blt (reg nil) (indexed (reg st) 0)) (move (reg nil) (fluid nil)) % fix reg nil (!*CALL DoControlT) % call the function (hrli (reg nil) (indexed (reg st) -13)) (hrri (reg nil) 1) (blt (reg nil) 14) % move the registers back off the stack (move (reg nil) (fluid nil)) % restore reg nil again (adjsp (reg st) -14) (debrk) ); >>; lap '((!*Entry SaveAndBreak expr 0) % % Save all regs, call DoBreak and dismiss % (adjsp (reg st) 14) % allocate 14 slots on the stack (hrri (reg nil) (indexed (reg st) -13)) % set up BLT pointer (hrli (reg nil) 1) % move regs 1..14 onto the stack (blt (reg nil) (indexed (reg st) 0)) (move (reg nil) (fluid nil)) % fix reg nil (!*CALL DoBreak) % call the function (hrli (reg nil) (indexed (reg st) -13)) (hrri (reg nil) 1) (blt (reg nil) 14) % move the registers back off the stack (move (reg nil) (fluid nil)) % restore reg nil again (adjsp (reg st) -14) (debrk) ); InitializeInterrupts(); off syslisp; END; |
Added psl-1983/20-util/bug.build version [b4a16c2e2c].
> | 1 | in "bug.red"$ |
Added psl-1983/20-util/bug.red version [746603c977].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % BUG.RED - Send bug reports % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 December 1981 % Copyright (c) 1981 University of Utah % IMPORTS '(EXEC); lisp procedure Bug(); << PrintF "*** PSL Bug reporter, ^N to abort%n"; PutRescan BldMsg "MAIL *PSL:USER-BUG-REPORTS.TXT,BENSON,GRISS%n"; MM(); TerPri() >>; END; |
Added psl-1983/20-util/bug.sl version [c51e3f2bcb].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BUG.SL - Send bug reports % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 December 1981 % Copyright (c) 1981 University of Utah % % <PERDUE.PSL>BUG.SL.2, 7-Jan-83 16:52:07, Edit by PERDUE % Changed to LISP syntax, added bug-mail-to variable. % Each site may set bug-mail-to as desired. (imports '(exec)) (fluid '(bug-mail-to)) (cond ((null bug-mail-to) (setq bug-mail-to ""))) (defun bug () (printf "*** PSL Bug reporter, ^N to abort%n") (putrescan (bldmsg "mail %w%n" bug-mail-to)) (mm) (terpri) t) |
Added psl-1983/20-util/dir-stuff.build version [ab90f26ff4].
> | 1 | in "p20:dir-stuff.red"$ |
Added psl-1983/20-util/dir-stuff.red version [19cb5f9ed9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MLG, 6:01am Thursday, 10 June 1982 % Utilities to read and process DIR files % IMPORTS '(EXEC); % -------- Basic File Reader ------------- Fluid '(File); procedure ReadOneLine; % Read a single line, return as string begin scalar c,l; while ((c:=ReadCh()) NEQ !$EOL!$) do If c EQ !$EOF!$ then Throw('Filer,'Done) else l:=c . l; Return list2string reverse l; end; procedure ReadDirFile F; % Read in a file as vector of strings begin scalar oldF,x; OldF:=Rds(F:=Open(F,'input)); File:=NIL; Catch('Filer,'(ReadAllFile1)); Rds OldF; Close F; Return List2vector Reverse File; end; procedure ReadAllFile1; % support for Read Dir File begin scalar l; While (l:=ReadOneLine()) do if Size(l)>=0 then file:= segmentstring(l,char '! ) . file; return List2Vector reverse file; end; %--------------------------------------------------- procedure ReadCleanDir F; % read in a Dir File without dates, and clean up Begin scalar x; x:=ReadDirFile F; % As a vector of strings %/ x:=ExpandNames x; % Handle .xxx case x:=RemoveAllVersionNumbers x; %/ x:=RemoveDuplicates x; % Assume ordered Return x; End; %---- Now take apart the fields Procedure GetFileName(S); % Find part before dot begin scalar N,I; n:=Size S; i:=0; While i<=n and S[i] neq Char '!. do i:=i+1; return Sub(S,0,i-1); end; procedure GetExtension(S); % Find second part, after dot begin scalar N,I; n:=Size S; i:=n; While i>=0 and S[i] neq Char '!. do i:=i-1; return Sub(S,i+1,n-i-1); end; % Dont need to expand names anymore CommentOutCode << procedure ExpandNames(Fvector); % replace .xxxx with yyy.xxx from previous Begin scalar F; for i:=1:Size(Fvector) do <<F:=Fvector[I]; if F[0] EQ char '!. then Fvector[I]:=concat(GetFileName Fvector[I-1],F)>>; return Fvector; end; >>; procedure RemoveVersionNumber F; % replace xxxx.yyyy.nnn with xxxx.yyyy Begin scalar I; i:=Size(F); While i>=0 and F[i] NEQ char '!. do i:=i-1; Return Sub(F,0,i-1); end; procedure RemoveAllVersionNumbers(Fvector); % replace xxxx.yyy.nnn with xxx.yyy Begin For i:=0:Size(Fvector) do Fvector[I]:=RemoveVersionNumber Car Fvector[I]; return Fvector; end; procedure GetDirInFile(Dstring,FileName); Docmds List("Dir ",Dstring,",",crlf, "out ",Filename,crlf, "no heading ",crlf, "separate ",crlf, "no summary ",crlf, crlf,"pop"); procedure GetCleanDir Dstring; Begin Scalar x; GetDirInFile(Dstring,"Junk.Dir"); x:=ReadCleanDir "junk.Dir"; DoCmds List("Del junk.dir,",crlf, "exp ",crlf,crlf,"pop"); return x End; procedure GetDatedDirInFile(Dstring,FileName); Docmds List("Dir ",Dstring,",",crlf, "out ",Filename,crlf, "no heading ",crlf, "separate ",crlf, "no summary ",crlf, "time write ",crlf, crlf,"pop"); procedure GetCleanDatedDir Dstring; Begin Scalar x; GetDatedDirInFile(Dstring,"Junk.Dir"); x:=ReadCleanDatedDir "junk.Dir"; DoCmds List("Del junk.dir,",crlf, "exp ",crlf,crlf,"pop"); return x End; procedure ReadCleanDatedDir F; begin scalar x; x:=ReadDirFile F; %/ x:=ExpandNames x; % Handle .xxx case For i:=0:Size(x) do Rplaca(x[i],RemoveVersionNumber Car x[I]); return x end; % Segment a string into fields: Procedure SegmentString(S,ch); % "parse" string in pieces at CH Begin scalar s0,sN,sN1, Parts, sa,sb; s0:=0; sn:=Size(S); sN1:=sN+1; L1:If s0>sn then goto L2; sa:=NextNonCh(Ch,S,s0,sN); if sa>sN then goto L2; sb:=NextCh(Ch,S,sa+1,sN); if sb>SN1 then goto L2; Parts:=SubSeq(S,sa,sb) . Parts; s0:=sb; goto L1; L2:Return Reverse Parts; End; Procedure NextCh(Ch,S,s1,s2); <<While (S1<=S2) and not(S[S1] eq Ch) do s1:=s1+1; S1>>; Procedure NextNonCh(Ch,S,s1,s2); <<While (S1<=S2) and (S[S1] eq Ch) do s1:=s1+1; S1>>; End; |
Added psl-1983/20-util/directory.sl version [0ece382796].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Directory.SL - File Directory Primitives (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 13 July 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common jsys pathnames file-primitives)) (de find-matching-files (filename include-deleted-files) % Return a list describing all files that match the specified filename. The % filename may specify a directory and/or may contain wildcard characters. % Each element of the returned list corresponds to one matching file. The % format of each list element is: % (file-name full file name string % deleted-flag T or NIL % file-size integer count of pages in file % write-date integer representing date/time of last write % read-date integer representing date/time of last read % ) (setf filename (fixup-directory-name filename)) (let (jfn-word jfn file-name deleted-flag file-size write-date read-date) (cond ((and (stringp filename) (setf jfn-word (attempt-to-get-jfn filename (if include-deleted-files #.(bits 2 8 11 13 17) #.(bits 2 11 13 17) ) ))) (for* (while (>= jfn-word 0)) (do (setf jfn (lowhalfword jfn-word)) (setf file-name (MkString 100 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 (const jsJFNS)) (setf file-name (recopystringtonull file-name)) (setf deleted-flag (jfn-deleted? jfn)) (setf file-size (jfn-page-count jfn)) (setf write-date (jfn-write-date jfn)) (setf read-date (jfn-read-date jfn)) ) (collect (list file-name deleted-flag file-size write-date read-date )) (do (if (FixP (ErrorSet (list 'jsys1 jfn-word 0 0 0 (const jsGNJFN)) NIL NIL)) (setf jfn-word -1))) )) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de fixup-directory-name (pn) % Replace all missing Name, Type, and Version components of the specified % filename with "*". (let ((wild-name (make-pathname 'name 'wild))) (setf pn (pathname pn)) (namestring (merge-pathname-defaults pn wild-name 'wild 'wild)))) |
Added psl-1983/20-util/exec.build version [0e13a711bf].
> > | 1 2 | CompileTime load(Syslisp, Jsys, Monsym); in "exec.red"$ |
Added psl-1983/20-util/exec.red version [35c5686fe3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EXEC.RED - Simple TOPS20 Interfaces, "EXEC Fork", etc % % Author: Martin L. Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 March 1981 % Copyright (c) 1981 University of Utah % % <PSL.UTIL>EXEC.RED.5, 24-May-82 13:01:50, Edit by BENSON % Changed <EDITORS> and <SUBSYS> to SYS: in filenames %/ Changed FILNAM->FileName, due to GLOBAL conflict %/ Changed JSYS calls, so LIST(..) rather than '(..) used %/ Changed for V3:JSYS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Simple JSYS interfaces imports '(JSYS); GLOBAL '(ForkNAMES!* EXECFork EMacsFork MMFork); Lisp procedure GetOLDJfn FileName; %. test If file OLD and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(2,3,17),FileName,0,0,jsGTJfn); % OLD!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Lisp procedure GetNEWJfn FileName; %. test If file NEW and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(0,1,3,17),FileName,0,0,jsGTJfn); % GEN!NEW!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Lisp procedure RELJfn Jfn; %. return Jfn to system JSYS0(Jfn,0,0,0,jsRLJfn); Lisp procedure OPENOLDJfn Jfn; %. OPEN to READ JSYS0(Jfn,Bits( (7 . 5),19),0,0,jsOPENF); Lisp procedure OPENNEWJfn Jfn; %. Open to WRITE JSYS0(Jfn,Bits( (7 . 5),20),0,0,jsOPENF); Lisp procedure GetFork Jfn; %. Create Fork, READ File on Jfn Begin scalar FH; FH := JSYS1(Bits(1),0,0,0,jsCFork); JSYS0(Xword(FH ,Jfn),0,0,0,jsGet); return FH END; Lisp procedure STARTFork FH; %. Start (Restart) a Fork JSYS0(FH, 0,0,0,jsSFRKV); Lisp procedure WAITFork FH; %. Wait for completion JSYS0(FH,0,0,0,jsWFork); Lisp procedure RUNFork FH; %. Normal use, to run a Fork <<STARTFork FH; WAITFork FH>>; Lisp procedure KILLFork FH; %. Kill a Fork JSYS0(FH,0,0,0,jsKFork); Lisp procedure SETPRIMARYJfnS(FH,INJfn,OUTJfn); JSYS0(FH,Xword(INJfn , OUTJfn),0,0,JSSPJfn); %. Change PRIMARY Jfns (BAD?) Lisp procedure OPENFork FileName; %. Get a File into a Fork Begin scalar FH,Jfn; If NULL FileP FileName then StdError CONCAT("Cant find File ",FileName); Jfn := GetOLDJfn FileName; FH := GetFork Jfn; return FH END; Lisp procedure RUN FileName; %. Run A File Begin scalar FH; FH := OPENFork FileName; RUNFork FH; KILLFork FH END; Lisp Procedure ForkP FH; %. test if Valid Fork Handle FixP FH and not Zerop FH; %/Kludge Lisp procedure EXEC; <<If Not ForkP EXECFork then EXECFork := OPENFork "SYSTEM:EXEC.EXE"; RUNFork EXECFork>>; Lisp procedure EMACS; <<If Not ForkP EMacsFork then EMACSFork := OPENFork "SYS:EMACS.EXE"; RUNFork EMACSFork>>; Lisp procedure MM; <<If Not ForkP MMFork then MMFork := OPENFork "SYS:MM.EXE"; RUNFork MMFork>>; Lisp procedure GetUNAME; %. USER name Begin Scalar S; S:=Mkstring 80; JSYS0(s,JSYS1(0,0,0,0,JSGJINF),0,0,JSDIRST); Return RecopyStringToNULL S End; Lisp procedure GetCDIR; %. Connected DIRECTORY Begin scalar s; S:=Mkstring 80; JSYS0(S,JSYS2(0,0,0,0,jsGJINF),0,0,jsDIRST); return RecopyStringToNULL S end; Lisp procedure PSOUT S; %. Print String JSYS0(S,0,0,0,jsPSOUT); Lisp procedure GTJfn L; %. Get a Jfn JSYS1(L,0,0,0,jsGTJFN); Lisp procedure NAMEFROMJfn J; %. name of File on a Jfn Begin scalar S; s:=Mkstring 100; JSYS0(S,J,0,0,JSJfnS); return RecopyStringToNULL S; end; Fexpr Procedure InFile(U); %. INPUT FILE, (prompt for name too?) If StringP U then DskIn EVAL CAR U else Begin scalar Jfn,Fname; PSOUT "Input file:"; Jfn:=Jsys1(BITS(2,3,4,16,17),Xword(8#100,8#101),0,0,jsGTJFN); Fname:= NAMEFROMJFN JFN; RELJFN JFN; PRINTF("reading file %r %n", FNAME); DSKIN Fname; end; %-- Command string processor and take Lisp procedure PutRescan(S); %. Enter String <<JSYS0(S,0,0,0,jsRSCAN); JSYS0(0,0,0,0,jsRSCAN)>>; On SYSLISP; syslsp procedure GetRescan(); %. Return as String Begin scalar N,S; XJSYS1(0,0,0,0,jsRSCAN); % Announce to Get N:=XJSYS1(1,0,0,0,jsRSCAN); % How Many IF N=0 then return 'Nil; S:=GtStr N-1; % To Drop Trailing EOL For I:=0:N-2 do StrByt(S,I):=XJsys1(0,0,0,0,JsPBIN); Return MkSTR S; % Will include Program name end; OFF SYSLISP; Global '(CRLF BL); CRLF :=STRING(8#15,8#12); %. CR-LF BL :=STRING(8#40); %. Blank Lisp procedure CONCATS (L); %. Combine list of strings If PAIRP L then CONCAT(CAR L,CONCATS CDR L) else CRLF; Lisp Fexpr Procedure CMDS (!%L); %. user COMMAND submit DOCMDS EVLIS !%L; Lisp procedure DOCMDS (L); %. Submit via PutRescan <<PutRescan CONCATS L; % Add CR, plant in RSCAN EXEC()>>; % Run 'em %. -------- Sample Commands Lisp procedure VDIR (L); DOCMDS LIST("VDIR ",L,CRLF,"POP"); Lisp procedure HelpDir(); DOCMDS LIST("DIR PH:*.HLP",CRLF,"POP"); Lisp procedure Take (FileName); If FileP FileName then DOCMDS LIST("Take ",FileName,CRLF,"POP"); Lisp procedure SYS (L); DOCMDS LIST("SYS ", L, CRLF, "POP"); Lisp procedure TALK (L); DOCMDS LIST("TALK ",L,CRLF); Lisp procedure TYPE (L); DOCMDS LIST("TYPE ",L,CRLF,"POP"); END; |
Added psl-1983/20-util/file-support.sl version [5845cd5f7d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % File-Support.SL - System-Dependent Support for File Primitives (TOPS-20) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 September 1982 % % This file contains support functions used in the implementation of file % primitives for TOPS-20. The existence of the functions in this file should % be ignored when writing system-independent code. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load jsys common pathnames)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % JFN Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de jfn-truename (jfn) (let ((file-name (make-string 200 #\space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 (const jsJFNS)) (recopystringtonull file-name) )) (de jfn-deleted? (jfn) (if (integerp jfn) (not (= (LAnd (Jsys4 jfn #.(xword 1 1) 4 0 (const jsGTFDB)) (bits 3)) 0)))) (de jfn-write-date (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#14) 4 0 (const jsGTFDB)))) (de jfn-read-date (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#15) 4 0 (const jsGTFDB)))) (de jfn-byte-count (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#12) 4 0 (const jsGTFDB)))) (de jfn-page-count (jfn) (if (integerp jfn) (lowhalfword (Jsys4 jfn #.(xword 1 8#11) 4 0 (const jsGTFDB))))) (de jfn-original-author (jfn) (if (integerp jfn) (let ((str (make-string 100 0))) (Jsys0 (xword 0 jfn) str 0 0 (const jsGFUST)) (recopystringtonull str) ))) (de jfn-author (jfn) (if (integerp jfn) (let ((str (make-string 100 0))) (Jsys0 (xword 1 jfn) str 0 0 (const jsGFUST)) (recopystringtonull str) ))) (de jfn-delete (jfn) (if (integerp jfn) (jsys0 jfn 0 0 0 (const jsDELF)) )) (de jfn-delete-and-expunge (jfn) (if (integerp jfn) (jsys0 (xword 2#010000000000000000 jfn) 0 0 0 (const jsDELF)) )) (de jfn-undelete (jfn) (if (integerp jfn) (jsys0 (xword 1 jfn) #.(bits 3) 0 0 (const jsCHFDB)) )) (de jfn-release (jfn) (if (integerp jfn) (jsys0 jfn 0 0 0 (const jsRLJFN)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % GTJFN Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de attempt-to-get-jfn (file-name the-bits) (setf file-name (namestring file-name)) (let ((jfn (ErrorSet (list 'jsys1 the-bits file-name 0 0 (const jsGTJFN)) nil nil) )) (cond ((listp jfn) (car jfn)) ))) |
Added psl-1983/20-util/get-command-string.sl version [af7c252135].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Get-Command-String.SL (TOPS-20 Version) - Get Program Command String % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common jsys)) (load strings) % The function GET-COMMAND-STRING returns the string argument given % to the program when it was invoked. (de char-blank? (ch) (or (= ch (char space)) (= ch (char tab)))) (fluid '(command-string*)) (de get-command-string () (or command-string* (setq command-string* (dec20-get-command-string)))) (de dec20-get-command-string () % Read the process command string. This function should only be invoked once % in a given fork, and should be invoked as soon as possible. The process % command string is massaged to remove the program name and any trailing % CRLF. (prog (s high i j) (setq s (dec20-read-process-arg)) (setq high (size s)) (if (< high 0) (return "")) (setq i 0) (while (and (<= i high) (char-blank? (igets s i))) (setq i (+ i 1))) (setq j i) (while (and (<= j high) (not (char-blank? (igets s j)))) (setq j (+ j 1))) (if (string-equal (substring s i j) "run") (return "")) (while (and (<= j high) (char-blank? (igets s j))) (setq j (+ j 1))) (while (and (> high j) (not (graphicp (igets s high)))) (setq high (- high 1))) (return (substring s j (+ high 1))) )) (CompileTime (put 'prarg 'OpenCode '((jsys 357) (move (reg 1) (reg 3))))) (CompileTime (put 'rscan 'OpenCode '((jsys 320) (move (reg 1) (reg 1))))) (CompileTime (put 'sin 'OpenCode '((jsys 42) (move (reg 1) (reg 3))))) (de dec20-read-process-arg () % On TOPS-20, the command argument can be passed to an inferior fork in two % ways. The first (and better) way is to pass a string in the process % argument block. The second (and more popular) way is to pass a string in % the RESCAN buffer (what a crock!). We will use the process argument block, % if it is nonempty, otherwise we will read from the RESCAN buffer. (prog (arg-len str) (setq arg-len (prarg #.(int2sys (xword 1 8#400000)) 4 0)) (cond ((> arg-len 0) (setq str (MkString arg-len)) (prarg #.(int2sys (xword 1 8#400000)) (jconv str) arg-len) (return (recopystringtonull str)) )) (setq arg-len (rscan 0)) (if (= arg-len 0) (return "")) % no input string (setq str (MkString arg-len)) (sin 8#777777 (jconv str) (- arg-len)) (return str) )) |
Added psl-1983/20-util/homedir.build version [6e432a143f].
> | 1 | in "homedir.sl"$ |
Added psl-1983/20-util/homedir.sl version [ca89515cdb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HOMEDIR.SL - USER-HOMEDIR-STRING function for Tops-20 % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1982 % Copyright (c) 1982 University of Utah % (compiletime (progn (load monsym syslisp) (put 'get-user-number 'opencode '((gjinf))) (flag '(user-homedir-string-aux get-dir-string) 'internalfunction))) % Returns a string which is the init file for program-name. % Optional HOST is not supported. (de init-file-string (program-name) (concat (user-homedir-string) (concat program-name ".INIT"))) % Returns a string which is the users home directory name. % Optional HOST is not supported. (lap '((*entry user-homedir-string expr 0) (movei (reg 1) (indexed (reg st) 1)) % Pointer into the stack (*alloc 20) % allocate space (*call user-homedir-string-aux) % call the real function (*exit 20))) % deallocate and return (de user-homedir-string-aux (p) (concat "PS:<" (mkstr (get-dir-string p (get-user-number))))) (lap '((*entry get-dir-string expr 2) (*move (reg 1) (reg 5)) % save original addr in ac5 (hrli (reg 1) 8#10700) % make a byte pointer (*move (reg 1) (reg 3)) % save it in ac3 (dirst) (erjmp cant-get-dir) (movei (reg 4) 62) % put a closing > on it (idpb (reg 4) (reg 1)) (setz (reg 4) 0) % put a null char on the end (idpb (reg 4) (reg 1)) (seto (reg 4) 0) % initialize length to -1 string-length-loop (ildb (reg 2) (reg 3)) (jumpe (reg 2) done-computing-length) (aoja (reg 4) string-length-loop) done-computing-length (movem (reg 4) (indexed (reg 5) 0)) % put len in string header (*move (reg 5) (reg 1)) % return original pointer (*exit 0) cant-get-dir (*move (reg 1) '"UNKNOWN>") (*exit 0))) |
Added psl-1983/20-util/input-stream.sl version [7806b22771].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Input-Stream.SL (TOPS-20 Version) - File Input Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.6 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.7 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % % Summary of public functions: % % (setf s (open-input "file name")) % generates error on failure % (setf s (attempt-to-open-input "file name")) % returns NIL on failure % (setf ch (=> s getc)) % read character (map CRLF to LF) % (setf ch (=> s getc-image)) % read character (don't map CRLF to LF) % (setf ch (=> s peekc)) % peek at next character % (setf ch (=> s peekc-image)) % peek at next character (don't map CRLF to LF) % (setf str (=> s getl)) % Read a line; return string without terminating LF. % (=> s empty?) % Are there no more characters? % (=> s close) % Close the file. % (setf fn (=> s file-name)) % Return "true" name of file. % (setf date (=> s read-date)) % Return date that file was last read. % (setf date (=> s write-date)) % Return date that file was last written. % (=> s delete-file) % Delete the associated file. % (=> s undelete-file) % Undelete the associated file. % (=> s delete-and-expunge) % Delete and expunge the associated file. % (setf name (=> s author)) % Return the name of the file's author. % (setf name (=> s original-author)) % Return the original author's name. % (setf count (=> s file-length)) % Return the byte count of the file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Changes: % % 9/29/82 Alan Snyder % Changed GETC to return stray CRs. % Now uses (=> self ...) form (produces same object code). % Added operations PEEKC-IMAGE, GETL, TELL-POSITION, SEEK-POSITION % (written by Nancy Kendzierski). % % 11/22/82 Alan Snyder % Changed SEEK-POSITION to work with large byte pointers (> 256K). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings)) (BothTimes (load objects jsys)) (load directory file-support) (de attempt-to-open-input (file-name) (let ((p (ErrorSet (list 'open-input file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-input (file-name) (let ((s (make-instance 'input-stream))) (=> s open file-name) s)) (DefConst FILE-BUFFER-SIZE #.(* 5 512)) (defflavor input-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next char in buffer count % number of valid chars in buffer eof-flag % T => this bufferfull is the last file-name % full name of actual file buffer % input buffer ) () (gettable-instance-variables file-name) ) % Note: The JSYS function can't be used for the 'SIN' JSYS because the JSYS % function handles errors. The 'SIN' JSYS will report an error on end-of-file % if errors are being handled. We don't want that to happen! (CompileTime (progn (put 'SIN 'OpenCode '((jsys 8#52) (move (reg 1) (reg 3)))) (put 'BIN 'OpenCode '((jsys 8#50) (move (reg 1) (reg 2)))) (put 'CLOSF 'OpenCode '((jsys 8#22) (move (reg 1) (reg 1)))) (put 'RFPTR 'OpenCode '((jsys 8#43) (jfcl) (move (reg 1) (reg 2)))) (put 'SFPTR 'OpenCode '((jsys 8#27) (jfcl) (move (reg 1) (reg 1)))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (input-stream getc) () % Return the next character from the file. Line termination is represented % by a single NEWLINE (LF) character. Returns NIL on end of file. % Implementation note: It was determined by experiment that the PSL % compiler produces much better code if there are no function calls other % than tail-recursive ones. That's why this function is written the way % it is. (if (< ptr count) (let ((ch (prog1 (string-fetch buffer ptr) (setf ptr (+ ptr 1)) ))) % Ignore CR followed by LF (if (= ch #\CR) (=> self &getc-after-CR) ch )) (=> self &fill-buffer-and-getc) )) (defmethod (input-stream &getc-after-CR) () % Internal method. % We have just read a CR from the buffer. If the next character % is a LF, then we should ignore the CR and return the LF. % Otherwise, we should return the CR. (if (= (=> self peekc-image) #\LF) (=> self getc-image) #\CR )) (defmethod (input-stream &fill-buffer-and-getc) () % Internal method. (and (=> self &fill-buffer) (=> self getc))) (defmethod (input-stream getc-image) () % Return the next character from the file. Do not perform any translation. % In particular, return all <CR>s. Returns NIL on end of file. (if (< ptr count) (prog1 (string-fetch buffer ptr) (setf ptr (+ ptr 1)) ) (=> self &fill-buffer-and-getc-image) )) (defmethod (input-stream &fill-buffer-and-getc-image) () % Internal method. (and (=> self &fill-buffer) (=> self getc-image))) (defmethod (input-stream empty?) () (null (=> self peekc-image))) (defmethod (input-stream peekc) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. Maps CRLF to LF. (if (< ptr count) (let ((ch (string-fetch buffer ptr))) % Ignore CR if followed by LF (if (and (= ch #\CR) (= (=> self &peek2) #\LF) ) #\LF ch )) (=> self &fill-buffer-and-peekc) )) (defmethod (input-stream &fill-buffer-and-peekc) () % Internal method. (and (=> self &fill-buffer) (=> self peekc))) (defmethod (input-stream peekc-image) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. (if (< ptr count) (string-fetch buffer ptr) (=> self &fill-buffer-and-peekc-image) )) (defmethod (input-stream &fill-buffer-and-peekc-image) () % Internal method. (and (=> self &fill-buffer) (=> self peekc-image))) (defmethod (input-stream &peek2) () % Internal method. % Return the character after the next character in the file, but don't % advance. Does not map CRLF. Returns Ascii NUL on end of file. Requires % that the buffer contain at least one character. This is a hack required % to implement PEEKC. (let ((next-ptr (+ ptr 1))) (cond ((>= next-ptr count) % The next character has not yet been read into the buffer. (let* ((old-pos (RFPTR jfn)) (ch (BIN jfn)) ) (SFPTR jfn old-pos) ch )) (t (string-fetch buffer next-ptr)) ))) (defmethod (input-stream &fill-buffer) () % Internal method. % Return NIL iff there are no more characters. (if eof-flag NIL (let ((n (SIN jfn (jconv buffer) (- (const FILE-BUFFER-SIZE))))) (if (~= n 0) (setf eof-flag T)) (setf count (+ (const FILE-BUFFER-SIZE) n)) (setf ptr 0) (~= count 0)))) (defmethod (input-stream getl) () % Read and return (the remainder of) the current input line. % Read, but don't return the terminating EOL (if any). % (EOL is interpreted as LF or CRLF) % Return NIL if no characters and end-of-file detected. (if (and (>= ptr count) (not (=> self &fill-buffer))) NIL % Else (let ((start ptr) (save-buffer NIL) (eof? NIL)) (while (and (not eof?) (~= (string-fetch buffer ptr) #\LF)) (setf ptr (+ ptr 1)) (cond ((>= ptr count) (setf save-buffer (concat save-buffer (subseq buffer start ptr))) (setf eof? (not (=> self &fill-buffer))) (setf start ptr) )) ) (if eof? save-buffer % Else (setf ptr (+ ptr 1)) (if (= ptr 1) (if save-buffer (if (= (string-fetch save-buffer (size save-buffer)) #\CR) (subseq save-buffer 0 (size save-buffer)) (sub save-buffer 0 (size save-buffer))) (subseq buffer start ptr)) (if (= (string-fetch buffer (- ptr 2)) #\CR) (concat save-buffer (subseq buffer start (- ptr 2))) (concat save-buffer (subseq buffer start (- ptr 1))) ))) ))) (defmethod (input-stream tell-position) () % Return an integer representing the current "position" of the stream. About % all we can guarantee about this integer is (1) it will be 0 at the % beginning of the file and (2) if you later SEEK-POSITION to this integer, % the stream will be reset to its current position. The reason for this % fuzziness is that the translation of CRLF into LF performed by the "normal" % input operations makes it impossible to predict the relationship between % the apparent file position and the actual file position. (- (RFPTR jfn) (- count ptr)) ) (defmethod (input-stream seek-position) (p) (setf p (int2sys p)) (let* ((buffer-end (RFPTR jfn)) (buffer-start (- buffer-end count))) (if (and (>= p buffer-start) (< p buffer-end)) (setf ptr (- p buffer-start)) % Else (SFPTR jfn p) (setf ptr 0) (setf count 0) (setf eof-flag NIL) ) )) (defmethod (input-stream open) (name-of-file) % Open the specified file for input via SELF. If the file cannot be opened, % a Continuable Error is generated. (if jfn (=> self close)) (setf buffer (MkString (const FILE-BUFFER-SIZE) #\space)) (setf ptr 0) (setf count 0) (setf eof-flag NIL) (setf jfn (Dec20Open name-of-file (int2sys 2#001000000000000001000000000000000000) (int2sys 2#000111000000000000010000000000100000) )) (if (= jfn 0) (setf jfn NIL)) (if (null jfn) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Input." name-of-file) name-of-file)) % Else (setf file-name (jfn-truename jfn)) )) (defmethod (input-stream close) () (when jfn (CLOSF jfn) (setf jfn NIL) (setf buffer NIL) (setf count 0) (setf ptr 0) (setf eof-flag T) )) (defmethod (input-stream read-date) () (jfn-read-date jfn)) (defmethod (input-stream write-date) () (jfn-write-date jfn)) (defmethod (input-stream delete-file) () (jfn-delete jfn)) (defmethod (input-stream undelete-file) () (jfn-undelete jfn)) (defmethod (input-stream delete-and-expunge-file) () (jfn-delete-and-expunge jfn)) (defmethod (input-stream author) () (jfn-author jfn)) (defmethod (input-stream original-author) () (jfn-original-author jfn)) (defmethod (input-stream file-length) () (jfn-byte-count jfn)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CommentOutCode (progn (de test-buffered-input (name-of-file) (setf s (open-input name-of-file)) (while (setf ch (input-stream$getc s)) (WriteChar ch) ) (=> s close) (Prin2 "---EOF---") NIL ) (de time-buffered-input (name-of-file) (setf start-time (time)) (setf s (open-input name-of-file)) (while (setf ch (input-stream$getc s)) ) (=> s close) (- (time) start-time) ) (de time-buffered-input-1 (name-of-file) (setf start-time (time)) (setf s (open-input name-of-file)) (while (setf ch (=> s getc)) ) (=> s close) (- (time) start-time) ) (de time-standard-input (name-of-file) (setf start-time (time)) (setf chan (open name-of-file 'INPUT)) (while (not (= (setf ch (ChannelReadChar chan)) $EOF$)) ) (close chan) (- (time) start-time) ) (de time-input (name-of-file) (list (time-buffered-input name-of-file) (time-buffered-input-1 name-of-file) (time-standard-input name-of-file) )) )) % End CommentOutCode |
Added psl-1983/20-util/interrupt.build version [a61aa846c7].
> > | 1 2 | CompileTime load Syslisp, Monsym, Jsys; in "20-interrupt.red"$ |
Added psl-1983/20-util/jsys.build version [415e3b24fb].
> > | 1 2 | CompileTime load Monsym; in "jsys.red"$ |
Added psl-1983/20-util/jsys.red version [f7e8141161].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % JSYS.RED - Simple XJSYS function % % Author: Martin L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 March 1981 % Copyright (c) 1981 University of Utah % % <PSL.UTIL>JSYS.RED.9, 18-May-82 13:24:36, Edit by BENSON % Made XJSYSn OpenCode'ed %/ Changed FILNAM->FileName, due to GLOBAL conflict %/ Changed JSYS calls, so LIST(..) rather than '(..) used %/ Changed for V3:JSYS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % <PSL.UTIL>JSYS.RED.2, 18-Mar-82 21:49:32, Edit by GRISS % Converted to V3 %. M. Griss 3:32pm Saturday, 7 November 1981 %. MLG: Fixed GetErrorString and BITS macro, 8:57am Friday, 25 December 1981 on syslisp; % Modeled after the IDapply to avoid CONS, register reloads % could easily be done Opencoded % SYSLSP calls, expect W value, return appropriate register %. syslsp procedure XJsys0(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys1(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys2(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys3(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys4(Jr1,Jr2,Jr3,Jr4,Jnum) lap '((!*entry xjsys0 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (wconst 0) (reg 1)) (!*exit 0))$ BothTimes put('xjsys0, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (setzm (reg 1)))); lap '((!*entry xjsys1 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*exit 0))$ BothTimes put('xjsys1, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)))); lap '((!*entry xjsys2 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 2) (reg 1)) (!*exit 0))$ BothTimes put('xjsys2, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 2)))); lap '((!*entry xjsys3 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 3) (reg 1)) (!*exit 0))$ BothTimes put('xjsys3, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 3)))); lap '((!*entry xjsys4 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 4) (reg 1)) (!*exit 0))$ BothTimes put('xjsys4, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 4)))); lap '((!*entry geterrorstring expr 1) (!*move (wconst -1) (reg 2)) % most recent error (hrli (reg 2) 8#400000) % self process (!*move (wconst 0) (reg 3)) % all string (erstr) % get the error string to a1 buffer (jfcl) (jfcl) (!*exit 0))$ syslsp procedure xjsyserror$ %/ should load up errstr begin scalar s; s:=gtstr 200; geterrorstring lor(lsh(8#10700,18), s)$ return stderror recopystringtonull s; end; % --- conversions for lisp level calls syslsp procedure str2int s; sys2int strinf s; syslsp procedure int2str i; mkstr int2sys i; syslsp procedure jconv j; %. handle untagging if fixp j then int2sys j else if stringp j then lor(lsh(8#10700,18),strinf(j)) % Bug in LONG const else stderror list(j,'" not known in jconv"); % lisp calls. untag args, then tag result as integer % user has to convert result from xword, stringbase, etc syslsp procedure jsys0(jr1,jr2,jr3,jr4,jnum); sys2int xjsys0(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys1(jr1,jr2,jr3,jr4,jnum); sys2int xjsys1(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys2(jr1,jr2,jr3,jr4,jnum); sys2int xjsys2(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys3(jr1,jr2,jr3,jr4,jnum); sys2int xjsys3(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys4(jr1,jr2,jr3,jr4,jnum); sys2int xjsys4(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure checknum(x,y); if intp x then intinf x else nonintegererror(x,y); CommentOutCode<< syslsp procedure insertstringsize s; begin scalar l,s1; % this must not be done to a string l:=0; s1:=strinf(s); % in the heap! while not (strbyt(s1,l)= char null) do l:=l+1; @s1:=mkitem(hstr,l-1); return s; end; >>; syslsp procedure recopystringtonull s; begin scalar l,s1,s2,ch; l:=0; s1:=strinf(s); while not (strbyt(s1,l)= char null) do l:=l+1; s2:=gtstr(l-1); l:=0; while not ((ch:=strbyt(s1,l))= char null) do <<strbyt(s2,l):= ch; l:=l+1>>; return mkstr s2; end; % ------------ useful bit, byte and word utilities syslsp procedure swap(x); %. swap half words xword(lowhalfword x,highhalfword x); syslsp procedure lowhalfword n; sys2int land(int2sys n,8#777777); compiletime << syslsp smacro procedure rsh(x,y); lsh(x,-y); >>; syslsp procedure highhalfword n; sys2int land(rsh(int2sys n,18),8#777777); syslsp procedure xword(x,y); %. build word from half-words % sys2int lor(lsh(lowhalfword(int2sys x),18), % lowhalfword int2sys y); %/Compiler error begin scalar Tmp; Tmp := lowhalfword int2sys x; Tmp := lsh(Tmp, 18); Tmp := lor(Tmp, lowhalfword int2sys y); return sys2int Tmp; end; syslsp procedure jbits l; %. convert bit and byte fields % l is list of bitpos or (fieldvalue . rightbitpos) % msb is #0, lsb is #35 on dec-20 begin scalar wd,x,fldpos,fldval; wd:=0; lb: if not pairp l then return sys2int wd; x:=car l; l := cdr l; if pairp x then <<fldpos:=cdr x; fldval:=car x>> else <<fldpos:=x; fldval:=1>>; if not (fixp fldval and fixp fldpos) then goto lb; if fldpos <0 or fldpos > 35 then goto lb; wd := lor(wd,lsh(fldval,35-fldpos)); goto lb; end; macro procedure bits l; list('jbits, 'list . cdr l); %. load jSYS Names procedure MakeJsys(Name, Number); EvDefConst(Name, Number); off syslisp; MakeJsys( 'jsJSYS , 8#0)$ MakeJsys( 'jsLOGIN , 8#1)$ MakeJsys( 'jsCRJOB , 8#2)$ MakeJsys( 'jsLGOUT , 8#3)$ MakeJsys( 'jsCACCT , 8#4)$ MakeJsys( 'jsEFACT , 8#5)$ MakeJsys( 'jsSMON , 8#6)$ MakeJsys( 'jsTMON , 8#7)$ MakeJsys( 'jsGETAB , 8#10)$ MakeJsys( 'jsERSTR , 8#11)$ MakeJsys( 'jsGETER , 8#12)$ MakeJsys( 'jsGJINF , 8#13)$ MakeJsys( 'jsTIME , 8#14)$ MakeJsys( 'jsRUNTM , 8#15)$ MakeJsys( 'jsSYSGT , 8#16)$ MakeJsys( 'jsGNJFN , 8#17)$ MakeJsys( 'jsGTJFN , 8#20)$ MakeJsys( 'jsOPENF , 8#21)$ MakeJsys( 'jsCLOSF , 8#22)$ MakeJsys( 'jsRLJFN , 8#23)$ MakeJsys( 'jsGTSTS , 8#24)$ MakeJsys( 'jsSTSTS , 8#25)$ MakeJsys( 'jsDELF , 8#26)$ MakeJsys( 'jsSFPTR , 8#27)$ MakeJsys( 'jsJFNS , 8#30)$ MakeJsys( 'jsFFFFP , 8#31)$ MakeJsys( 'jsRDDIR , 8#32)$ MakeJsys( 'jsCPRTF , 8#33)$ MakeJsys( 'jsCLZFF , 8#34)$ MakeJsys( 'jsRNAMF , 8#35)$ MakeJsys( 'jsSIZEF , 8#36)$ MakeJsys( 'jsGACTF , 8#37)$ MakeJsys( 'jsSTDIR , 8#40)$ MakeJsys( 'jsDIRST , 8#41)$ MakeJsys( 'jsBKJFN , 8#42)$ MakeJsys( 'jsRFPTR , 8#43)$ MakeJsys( 'jsCNDIR , 8#44)$ MakeJsys( 'jsRFBSZ , 8#45)$ MakeJsys( 'jsSFBSZ , 8#46)$ MakeJsys( 'jsSWJFN , 8#47)$ MakeJsys( 'jsBIN , 8#50)$ MakeJsys( 'jsBOUT , 8#51)$ MakeJsys( 'jsSIN , 8#52)$ MakeJsys( 'jsSOUT , 8#53)$ MakeJsys( 'jsRIN , 8#54)$ MakeJsys( 'jsROUT , 8#55)$ MakeJsys( 'jsPMAP , 8#56)$ MakeJsys( 'jsRPACS , 8#57)$ MakeJsys( 'jsSPACS , 8#60)$ MakeJsys( 'jsRMAP , 8#61)$ MakeJsys( 'jsSACTF , 8#62)$ MakeJsys( 'jsGTFDB , 8#63)$ MakeJsys( 'jsCHFDB , 8#64)$ MakeJsys( 'jsDUMPI , 8#65)$ MakeJsys( 'jsDUMPO , 8#66)$ MakeJsys( 'jsDELDF , 8#67)$ MakeJsys( 'jsASND , 8#70)$ MakeJsys( 'jsRELD , 8#71)$ MakeJsys( 'jsCSYNO , 8#72)$ MakeJsys( 'jsPBIN , 8#73)$ MakeJsys( 'jsPBOUT , 8#74)$ MakeJsys( 'jsPSIN , 8#75)$ MakeJsys( 'jsPSOUT , 8#76)$ MakeJsys( 'jsMTOPR , 8#77)$ MakeJsys( 'jsCFIBF , 8#100)$ MakeJsys( 'jsCFOBF , 8#101)$ MakeJsys( 'jsSIBE , 8#102)$ MakeJsys( 'jsSOBE , 8#103)$ MakeJsys( 'jsDOBE , 8#104)$ MakeJsys( 'jsGTABS , 8#105)$ MakeJsys( 'jsSTABS , 8#106)$ MakeJsys( 'jsRFMOD , 8#107)$ MakeJsys( 'jsSFMOD , 8#110)$ MakeJsys( 'jsRFPOS , 8#111)$ MakeJsys( 'jsRFCOC , 8#112)$ MakeJsys( 'jsSFCOC , 8#113)$ MakeJsys( 'jsSTI , 8#114)$ MakeJsys( 'jsDTACH , 8#115)$ MakeJsys( 'jsATACH , 8#116)$ MakeJsys( 'jsDVCHR , 8#117)$ MakeJsys( 'jsSTDEV , 8#120)$ MakeJsys( 'jsDEVST , 8#121)$ MakeJsys( 'jsMOUNT , 8#122)$ MakeJsys( 'jsDSMNT , 8#123)$ MakeJsys( 'jsINIDR , 8#124)$ MakeJsys( 'jsSIR , 8#125)$ MakeJsys( 'jsEIR , 8#126)$ MakeJsys( 'jsSKPIR , 8#127)$ MakeJsys( 'jsDIR , 8#130)$ MakeJsys( 'jsAIC , 8#131)$ MakeJsys( 'jsIIC , 8#132)$ MakeJsys( 'jsDIC , 8#133)$ MakeJsys( 'jsRCM , 8#134)$ MakeJsys( 'jsRWM , 8#135)$ MakeJsys( 'jsDEBRK , 8#136)$ MakeJsys( 'jsATI , 8#137)$ MakeJsys( 'jsDTI , 8#140)$ MakeJsys( 'jsCIS , 8#141)$ MakeJsys( 'jsSIRCM , 8#142)$ MakeJsys( 'jsRIRCM , 8#143)$ MakeJsys( 'jsRIR , 8#144)$ MakeJsys( 'jsGDSTS , 8#145)$ MakeJsys( 'jsSDSTS , 8#146)$ MakeJsys( 'jsRESET , 8#147)$ MakeJsys( 'jsRPCAP , 8#150)$ MakeJsys( 'jsEPCAP , 8#151)$ MakeJsys( 'jsCFORK , 8#152)$ MakeJsys( 'jsKFORK , 8#153)$ MakeJsys( 'jsFFORK , 8#154)$ MakeJsys( 'jsRFORK , 8#155)$ MakeJsys( 'jsRFSTS , 8#156)$ MakeJsys( 'jsSFORK , 8#157)$ MakeJsys( 'jsSFACS , 8#160)$ MakeJsys( 'jsRFACS , 8#161)$ MakeJsys( 'jsHFORK , 8#162)$ MakeJsys( 'jsWFORK , 8#163)$ MakeJsys( 'jsGFRKH , 8#164)$ MakeJsys( 'jsRFRKH , 8#165)$ MakeJsys( 'jsGFRKS , 8#166)$ MakeJsys( 'jsDISMS , 8#167)$ MakeJsys( 'jsHALTF , 8#170)$ MakeJsys( 'jsGTRPW , 8#171)$ MakeJsys( 'jsGTRPI , 8#172)$ MakeJsys( 'jsRTIW , 8#173)$ MakeJsys( 'jsSTIW , 8#174)$ MakeJsys( 'jsSOBF , 8#175)$ MakeJsys( 'jsRWSET , 8#176)$ MakeJsys( 'jsGETNM , 8#177)$ MakeJsys( 'jsGET , 8#200)$ MakeJsys( 'jsSFRKV , 8#201)$ MakeJsys( 'jsSAVE , 8#202)$ MakeJsys( 'jsSSAVE , 8#203)$ MakeJsys( 'jsSEVEC , 8#204)$ MakeJsys( 'jsGEVEC , 8#205)$ MakeJsys( 'jsGPJFN , 8#206)$ MakeJsys( 'jsSPJFN , 8#207)$ MakeJsys( 'jsSETNM , 8#210)$ MakeJsys( 'jsFFUFP , 8#211)$ MakeJsys( 'jsDIBE , 8#212)$ MakeJsys( 'jsFDFRE , 8#213)$ MakeJsys( 'jsGDSKC , 8#214)$ MakeJsys( 'jsLITES , 8#215)$ MakeJsys( 'jsTLINK , 8#216)$ MakeJsys( 'jsSTPAR , 8#217)$ MakeJsys( 'jsODTIM , 8#220)$ MakeJsys( 'jsIDTIM , 8#221)$ MakeJsys( 'jsODCNV , 8#222)$ MakeJsys( 'jsIDCNV , 8#223)$ MakeJsys( 'jsNOUT , 8#224)$ MakeJsys( 'jsNIN , 8#225)$ MakeJsys( 'jsSTAD , 8#226)$ MakeJsys( 'jsGTAD , 8#227)$ MakeJsys( 'jsODTNC , 8#230)$ MakeJsys( 'jsIDTNC , 8#231)$ MakeJsys( 'jsFLIN , 8#232)$ MakeJsys( 'jsFLOUT , 8#233)$ MakeJsys( 'jsDFIN , 8#234)$ MakeJsys( 'jsDFOUT , 8#235)$ MakeJsys( 'jsCRDIR , 8#240)$ MakeJsys( 'jsGTDIR , 8#241)$ MakeJsys( 'jsDSKOP , 8#242)$ MakeJsys( 'jsSPRIW , 8#243)$ MakeJsys( 'jsDSKAS , 8#244)$ MakeJsys( 'jsSJPRI , 8#245)$ MakeJsys( 'jsSTO , 8#246)$ MakeJsys( 'jsBBNIIT , 8#247)$ MakeJsys( 'jsARCF , 8#247)$ MakeJsys( 'jsASNDP , 8#260)$ MakeJsys( 'jsRELDP , 8#261)$ MakeJsys( 'jsASNDC , 8#262)$ MakeJsys( 'jsRELDC , 8#263)$ MakeJsys( 'jsSTRDP , 8#264)$ MakeJsys( 'jsSTPDP , 8#265)$ MakeJsys( 'jsSTSDP , 8#266)$ MakeJsys( 'jsRDSDP , 8#267)$ MakeJsys( 'jsWATDP , 8#270)$ MakeJsys( 'jsATNVT , 8#274)$ MakeJsys( 'jsCVSKT , 8#275)$ MakeJsys( 'jsCVHST , 8#276)$ MakeJsys( 'jsFLHST , 8#277)$ MakeJsys( 'jsGCVEC , 8#300)$ MakeJsys( 'jsSCVEC , 8#301)$ MakeJsys( 'jsSTTYP , 8#302)$ MakeJsys( 'jsGTTYP , 8#303)$ MakeJsys( 'jsBPT , 8#304)$ MakeJsys( 'jsGTDAL , 8#305)$ MakeJsys( 'jsWAIT , 8#306)$ MakeJsys( 'jsHSYS , 8#307)$ MakeJsys( 'jsUSRIO , 8#310)$ MakeJsys( 'jsPEEK , 8#311)$ MakeJsys( 'jsMSFRK , 8#312)$ MakeJsys( 'jsESOUT , 8#313)$ MakeJsys( 'jsSPLFK , 8#314)$ MakeJsys( 'jsADVIS , 8#315)$ MakeJsys( 'jsJOBTM , 8#316)$ MakeJsys( 'jsDELNF , 8#317)$ MakeJsys( 'jsSWTCH , 8#320)$ MakeJsys( 'jsOPRFN , 8#326)$ MakeJsys( 'jsCGRP , 8#327)$ MakeJsys( 'jsVACCT , 8#330)$ MakeJsys( 'jsGDACC , 8#331)$ MakeJsys( 'jsATGRP , 8#332)$ MakeJsys( 'jsGACTJ , 8#333)$ MakeJsys( 'jsGPSGN , 8#334)$ MakeJsys( 'jsRSCAN , 8#500)$ MakeJsys( 'jsHPTIM , 8#501)$ MakeJsys( 'jsCRLNM , 8#502)$ MakeJsys( 'jsINLNM , 8#503)$ MakeJsys( 'jsLNMST , 8#504)$ MakeJsys( 'jsRDTXT , 8#505)$ MakeJsys( 'jsSETSN , 8#506)$ MakeJsys( 'jsGETJI , 8#507)$ MakeJsys( 'jsMSEND , 8#510)$ MakeJsys( 'jsMRECV , 8#511)$ MakeJsys( 'jsMUTIL , 8#512)$ MakeJsys( 'jsENQ , 8#513)$ MakeJsys( 'jsDEQ , 8#514)$ MakeJsys( 'jsENQC , 8#515)$ MakeJsys( 'jsSNOOP , 8#516)$ MakeJsys( 'jsSPOOL , 8#517)$ MakeJsys( 'jsALLOC , 8#520)$ MakeJsys( 'jsCHKAC , 8#521)$ MakeJsys( 'jsTIMER , 8#522)$ MakeJsys( 'jsRDTTY , 8#523)$ MakeJsys( 'jsTEXTI , 8#524)$ MakeJsys( 'jsUFPGS , 8#525)$ MakeJsys( 'jsSFPOS , 8#526)$ MakeJsys( 'jsSYERR , 8#527)$ MakeJsys( 'jsDIAG , 8#530)$ MakeJsys( 'jsSINR , 8#531)$ MakeJsys( 'jsSOUTR , 8#532)$ MakeJsys( 'jsRFTAD , 8#533)$ MakeJsys( 'jsSFTAD , 8#534)$ MakeJsys( 'jsTBDEL , 8#535)$ MakeJsys( 'jsTBADD , 8#536)$ MakeJsys( 'jsTBLUK , 8#537)$ MakeJsys( 'jsSTCMP , 8#540)$ MakeJsys( 'jsSETJB , 8#541)$ MakeJsys( 'jsGDVEC , 8#542)$ MakeJsys( 'jsSDVEC , 8#543)$ MakeJsys( 'jsCOMND , 8#544)$ MakeJsys( 'jsPRARG , 8#545)$ MakeJsys( 'jsGACCT , 8#546)$ MakeJsys( 'jsLPINI , 8#547)$ MakeJsys( 'jsGFUST , 8#550)$ MakeJsys( 'jsSFUST , 8#551)$ MakeJsys( 'jsACCES , 8#552)$ MakeJsys( 'jsRCDIR , 8#553)$ MakeJsys( 'jsRCUSR , 8#554)$ MakeJsys( 'jsSNDIM , 8#750)$ MakeJsys( 'jsRCVIM , 8#751)$ MakeJsys( 'jsASNSQ , 8#752)$ MakeJsys( 'jsRELSQ , 8#753)$ MakeJsys( 'jsTHIBR , 8#770)$ MakeJsys( 'jsTWAKE , 8#771)$ MakeJsys( 'jsMRPAC , 8#772)$ MakeJsys( 'jsSETPV , 8#773)$ MakeJsys( 'jsMTALN , 8#774)$ MakeJsys( 'jsTTMSG , 8#775)$ End$ |
Added psl-1983/20-util/monsym.build version [6593a960b2].
> | 1 | in "monsym.red"$ |
Added psl-1983/20-util/monsym.red version [d40386e46d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MONSYM.RED - Support for Dec-20 system LAP code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 March 1982 % Copyright (c) 1982 University of Utah % CompileTime << macro procedure DefineJSYSRangeFrom X; begin scalar Start, L; Start := Sub1 second X; L := third X; return ('progn . for each Name in second L collect list('progn, list('put, MkQuote Name,'(quote JSYSValue), Start := Add1 Start), list('put,MkQuote Name, '(quote InstructionDepositFunction), '(quote JSYSDeposit)))); end; >>; lisp procedure JSYSDeposit X; << if !*WritingFaslFile then UpdateBitTable(1, 0); DepositAllFields(8#104, 0, get(car X, 'JSYSValue)) >>; flag('(ERJMP ERCAL), 'MC); lisp procedure ERJMP Address; list list('jump, 8#16, Address); lisp procedure ERCAL Address; list list('jump, 8#17, Address); DefineJSYSRangeFrom(1, '( LOGIN CRJOB LGOUT CACCT EFACT SMON TMON GETAB ERSTR GETER GJINF TIME RUNTM SYSGT GNJFN GTJFN OPENF CLOSF RLJFN GTSTS STSTS DELF SFPTR JFNS FFFFP RDDIR CPRTF CLZFF RNAMF SIZEF GACTF STDIR DIRST BKJFN RFPTR CNDIR RFBSZ SFBSZ SWJFN BIN BOUT SIN SOUT RIN ROUT PMAP RPACS SPACS RMAP SACTF GTFDB CHFDB DUMPI DUMPO DELDF ASND RELD CSYNO PBIN PBOUT PSIN PSOUT MTOPR CFIBF CFOBF SIBE SOBE DOBE GTABS STABS RFMOD SFMOD RFPOS RFCOC SFCOC STI DTACH ATACH DVCHR STDEV DEVST MOUNT DSMNT INIDR SIR EIR SKPIR DIR AIC IIC DIC RCM RWM DEBRK ATI DTI CIS SIRCM RIRCM RIR GDSTS SDSTS RESET RPCAP EPCAP CFORK KFORK FFORK RFORK RFSTS SFORK SFACS RFACS HFORK WFORK GFRKH RFRKH GFRKS DISMS HALTF GTRPW GTRPI RTIW STIW SOBF RWSET GETNM GET SFRKV SAVE SSAVE SEVEC GEVEC GPJFN SPJFN SETNM FFUFP DIBE FDFRE GDSKC LITES TLINK STPAR ODTIM IDTIM ODCNV IDCNV NOUT NIN STAD GTAD ODTNC IDTNC FLIN FLOUT DFIN DFOUT )); DefineJSYSRangeFrom(160, '( CRDIR GTDIR DSKOP SPRIW DSKAS SJPRI STO ARCF )); %define(jsASNDP,8%260) # NOT IMPLEMENTED %define(jsRELDP,8%261) # NOT IMPLEMENTED %define(jsASNDC,8%262) # NOT IMPLEMENTED %define(jsRELDC,8%263) # NOT IMPLEMENTED %define(jsSTRDP,8%264) # NOT IMPLEMENTED %define(jsSTPDP,8%265) # NOT IMPLEMENTED %define(jsSTSDP,8%266) # NOT IMPLEMENTED %define(jsRDSDP,8%267) # NOT IMPLEMENTED %define(jsWATDP,8%270) # NOT IMPLEMENTED DefineJSYSRangeFrom(188, '( ATNVT CVSKT CVHST FLHST GCVEC SCVEC STTYP GTTYP BPT GTDAL WAIT HSYS USRIO PEEK MSFRK ESOUT SPLFK ADVIS JOBTM DELNF SWTCH TFORK RTFRK UTFRK )); DefineJSYSRangeFrom(214, '( OPRFN CGRP VACCT GDACC ATGRP GACTJ GPSGN )); DefineJSYSRangeFrom(320, '( RSCAN HPTIM CRLNM INLNM LNMST RDTXT SETSN GETJI MSEND MRECV MUTIL ENQ DEQ ENQC SNOOP SPOOL ALLOC CHKAC TIMER RDTTY TEXTI UFPGS SFPOS SYERR DIAG SINR SOUTR RFTAD SFTAD TBDEL TBADD TBLUK STCMP SETJB GDVEC SDVEC COMND PRARG GACCT LPINI GFUST SFUST ACCES RCDIR RCUSR )); DefineJSYSRangeFrom(488, '( SNDIM RCVIM ASNSQ RELSQ )); DefineJSYSRangeFrom(504, '( THIBR TWAKE MRPAC SETPV MTALN TTMSG )); END; |
Added psl-1983/20-util/output-stream.sl version [4540cd6db5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Output-Stream.SL (TOPS-20 Version) - File Output Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.7 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.9 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vectors fast-strings)) (BothTimes (load objects jsys)) (de attempt-to-open-output (file-name) (let ((p (ErrorSet (list 'open-output file-name) NIL NIL))) (and (PairP p) (car p)) )) (de attempt-to-open-append (file-name) (let ((p (ErrorSet (list 'open-append file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-output (file-name) (let ((s (make-instance 'output-stream))) (=> s open file-name) s)) (de open-append (file-name) (let ((s (make-instance 'output-stream))) (=> s open-append file-name) s)) (defconst FILE-BUFFER-SIZE #.(* 5 512)) (defflavor output-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next free slot in buffer file-name % full name of actual file buffer % output buffer ) () (gettable-instance-variables file-name) ) (CompileTime (put 'SOUT 'OpenCode '((jsys 43) (move (reg 1) (reg 3))))) (CompileTime (put 'CLOSF 'OpenCode '((jsys 18) (move (reg 1) (reg 1))))) (defmethod (output-stream putc) (ch) % Append the character CH to the file. Line termination is indicated by % writing a single NEWLINE (LF) character. % Implementation note: It was determined by experiment that the PSL % compiler produces much better code if there are no function calls other % than tail-recursive ones. That's why this function is written the way % it is. (if (= ch #\LF) (=> self put-newline) % Otherwise: (string-store buffer ptr ch) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) )) (defmethod (output-stream put-newline) () % Output a line terminator. (string-store buffer ptr #\CR) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) (string-store buffer ptr #\LF) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) ) (defmethod (output-stream putc-image) (ch) % Append the character CH to the file. No translation of LF character. (string-store buffer ptr ch) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) ) (defmethod (output-stream puts) (str) % Write string to output stream (highly optimized!) (let ((i 0) (high (string-upper-bound str)) ) (while (<= i high) (string-store buffer ptr (string-fetch str i)) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) (setf i (+ i 1)) ))) (defmethod (output-stream putl) (str) % Write string followed by line terminator to output stream. (=> self puts str) (=> self put-newline) ) (defmethod (output-stream open) (name-of-file) % Open the specified file for output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (=> self close)) (setf jfn (Dec20Open name-of-file (int2sys 2#100000000000000001000000000000000000) (int2sys 2#000111000000000000001000000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Output" name-of-file) name-of-file)) (=> self &fixup) )) (defmethod (output-stream open-append) (name-of-file) % Open the specified file for append output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (=> self close)) (setf jfn (Dec20Open name-of-file (int2sys 2#000000000000000001000000000000000000) (int2sys 2#000111000000000000000010000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open-append (ContinuableError 0 (BldMsg "Unable to Open '%w' for Append" name-of-file) name-of-file)) (=> self &fixup) )) (defmethod (output-stream attach-to-jfn) (new-jfn) % Attach the output-stream to the specified JFN. (if jfn (=> self close)) (setf jfn new-jfn) (=> self &fixup) ) (defmethod (output-stream &fixup) () % Internal method for initializing instance variables after setting JFN. (setf buffer (make-string (const FILE-BUFFER-SIZE) #\space)) % It is necessary to clear out the low-order bit, lest some programs % think we are writing "line numbers" (what a crock!). (for (from i 0 (- (/ (const FILE-BUFFER-SIZE) 5) 1)) (do (vector-store buffer i 0))) (setf ptr 0) (setf file-name (jfn-truename jfn)) ) (defmethod (output-stream close) () (when jfn (=> self flush) (CLOSF jfn) (setf jfn NIL) (setf buffer NIL) )) (defmethod (output-stream flush) () (when (> ptr 0) (SOUT jfn (jconv buffer) (- ptr)) (setf ptr 0) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (setf time-output-test-string "This is a line of text for testing.")) (CommentOutCode (progn (de time-buffered-output (n-lines) % This is the FAST way to do buffered output. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (output-stream$putc s ch)) ) (output-stream$put-newline s) )) (=> s close) (- (time) start-time) ) (de time-buffered-output-1 (n-lines) % This is the SLOW (but GENERAL) way to do buffered output. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (=> s putc ch)) ) (=> s put-newline) )) (=> s close) (- (time) start-time) ) (de time-standard-output (n-lines) (setf start-time (time)) (setf chan (open "test.output" 'OUTPUT)) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (ChannelWriteChar chan ch)) ) (ChannelWriteChar chan #\LF) )) (close chan) (- (time) start-time) ) (de time-output (n-lines) (list (time-buffered-output-string n-lines) (time-buffered-output n-lines) (time-buffered-output-1 n-lines) (time-standard-output n-lines) )) (de time-buffered-output-string (n-lines) % This is the FAST way to do buffered output from strings. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (output-stream$putl s #.time-output-test-string)) ) (=> s close) (- (time) start-time) ) )) % End CommentOutCode |
Added psl-1983/20-util/pathnames.sl version [fc386fd8c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PathNames.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 9 February 1983 % % DEC-20 implementation of some Common Lisp pathname functions. % % 9-Feb-83 Alan Snyder % Revise conversion to string to omit the dot if there is no type or version. % Revise conversion from string to interpret trailing dot as specifying % an empty type or version. Change home-directory to specify PS: % Fix bug in make-pathname. Convert to using fast-strings stuff. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vector fast-strings)) (BothTimes (load objects)) (when (funboundp 'string2integer) (de string2integer (s) (makestringintolispinteger s 10 1) )) % The following function is an NEXPR: be sure this module is loaded at % compile-time if you use this function in code to be compiled! (dn make-pathname (keyword-arg-list) (let ((pn (make-instance 'pathname))) (while (not (null keyword-arg-list)) (let ((keyword (car keyword-arg-list))) (setf keyword-arg-list (cdr keyword-arg-list)) (cond (keyword-arg-list (let ((value (car keyword-arg-list))) (setf keyword-arg-list (cdr keyword-arg-list)) (selectq keyword (host (=> pn set-host value)) (device (=> pn set-device value)) (directory (=> pn set-directory value)) (name (=> pn set-name value)) (type (=> pn set-type value)) (version (=> pn set-version value)) )))))) pn )) (de pathname-host (pn) (=> (pathname pn) host)) (de pathname-device (pn) (=> (pathname pn) device)) (de pathname-directory (pn) (=> (pathname pn) directory)) (de pathname-name (pn) (=> (pathname pn) name)) (de pathname-type (pn) (=> (pathname pn) type)) (de pathname-version (pn) (=> (pathname pn) version)) (de PathnameP (x) (and (VectorP x) (eq (getv x 0) 'pathname))) (de StreamP (x) (and (VectorP x) (object-get-handler-quietly x 'file-name))) (de truename (x) (pathname x)) (de pathname (x) (cond ((PathnameP x) x) ((StringP x) (string-to-pathname x)) ((IdP x) (string-to-pathname (id2string x))) ((StreamP x) (string-to-pathname (=> x file-name))) (t (TypeError x "PathName" "convertible to a pathname")) )) (de namestring (x) (setf x (pathname x)) (let ((dev (pathname-device x)) (dir (pathname-directory x)) (name (pathname-name x)) (type (pathname-type x)) (vers (pathname-version x)) ) (string-concat (if dev (string-concat (pathname-field-to-string dev) ":") "") (if dir (string-concat "<" (pathname-field-to-string dir) ">") "") (if name (pathname-field-to-string name) "") (if (or (not (pathname-empty-field? type)) (not (pathname-empty-field? vers))) (string-concat "." (pathname-field-to-string type)) "") (if (not (pathname-empty-field? vers)) (string-concat "." (pathname-field-to-string vers)) "") ))) (de file-namestring (x) (setf x (pathname x)) (let ((name (pathname-name x)) (type (pathname-type x)) (vers (pathname-version x)) ) (string-concat (if name (pathname-field-to-string name) "") (if type (string-concat "." (pathname-field-to-string type)) "") (if vers (string-concat "." (pathname-field-to-string vers)) "") ))) (de directory-namestring (x) (setf x (pathname x)) (let ((dir (pathname-directory x)) ) (if dir (string-concat "<" (pathname-field-to-string dir) ">") "") )) (de user-homedir-pathname () (let ((pn (make-instance 'pathname)) (user-number (Jsys1 0 0 0 0 (const jsGJINF))) (dir-name (MkString 100 (char space))) ) (Jsys1 dir-name user-number 0 0 (const jsDIRST)) (setf dir-name (recopystringtonull dir-name)) (=> pn set-device "PS") (=> pn set-directory dir-name) pn )) (de init-file-pathname (program-name) (let ((pn (user-homedir-pathname))) (=> pn set-name program-name) (=> pn set-type "INIT") pn )) (de merge-pathname-defaults (pn defaults-pn default-type default-version) (setf pn (pathname pn)) (setf defaults-pn (pathname defaults-pn)) (setf pn (CopyVector pn)) (if (not (=> pn host)) (=> pn set-host (=> defaults-pn host))) (cond ((not (=> pn device)) (=> pn set-device (=> defaults-pn device)) (if (not (=> pn directory)) (=> pn set-directory (=> defaults-pn directory))) )) (cond ((not (=> pn name)) (=> pn set-name (=> defaults-pn name)) (if (not (=> pn type)) (=> pn set-type (=> defaults-pn type))) (if (not (=> pn version)) (=> pn set-version (=> defaults-pn version))) )) (if (not (=> pn type)) (=> pn set-type default-type)) (if (not (=> pn version)) (=> pn set-version default-version)) pn ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor pathname ((host "LOCAL") (device NIL) (directory NIL) (name NIL) (type NIL) (version NIL) ) () gettable-instance-variables ) (defmethod (pathname set-host) (new-host) (cond ((StringP new-host) (setf host (string-upcase new-host))) ((and (ListP new-host) (not (null new-host)) (StringP (car new-host))) (setf host (string-upcase (car new-host)))) (t (StdError "Invalid host specified for pathname.")) )) (defmethod (pathname set-device) (new-device) (cond ((StringP new-device) (setf device (string-upcase new-device))) ((null new-device) (setf device NIL)) ((and (ListP new-device) (StringP (car new-device))) (setf device (string-upcase (car new-device)))) ((and (IdP new-device) (or (eq new-device 'unspecific) (eq new-device 'wild))) (setf device new-device)) (t (StdError "Invalid device specified for pathname.")) )) (defmethod (pathname set-directory) (new-directory) (cond ((StringP new-directory) (setf directory (string-upcase new-directory))) ((null new-directory) (setf directory NIL)) ((and (ListP new-directory) (StringP (car new-directory))) (setf directory (string-upcase (car new-directory)))) ((and (IdP new-directory) (or (eq new-directory 'unspecific) (eq new-directory 'wild))) (setf directory new-directory)) (t (StdError "Invalid directory specified for pathname.")) )) (defmethod (pathname set-name) (new-name) (cond ((StringP new-name) (setf name (string-upcase new-name))) ((null new-name) (setf name NIL)) ((and (ListP new-name) (StringP (car new-name))) (setf name (string-upcase (car new-name)))) ((and (IdP new-name) (or (eq new-name 'unspecific) (eq new-name 'wild))) (setf name new-name)) (t (StdError "Invalid name specified for pathname.")) )) (defmethod (pathname set-type) (new-type) (cond ((StringP new-type) (setf type (string-upcase new-type))) ((null new-type) (setf type NIL)) ((and (IdP new-type) (or (eq new-type 'unspecific) (eq new-type 'wild))) (setf type new-type)) (t (StdError "Invalid type specified for pathname.")) )) (defmethod (pathname set-version) (new-version) (cond ((and (FixP new-version) (>= new-version 0)) (setf version new-version)) ((null new-version) (setf version NIL)) ((and (IdP new-version) (or (eq new-version 'unspecific) (eq new-version 'wild) (eq new-version 'newest) (eq new-version 'oldest) )) (setf version new-version)) (t (StdError "Invalid version specified for pathname.")) )) (de string-to-pathname (s) (let ((pn (make-instance 'pathname)) (i 0) j ch (len (string-length s)) (name-count 0) field ) (while (< i len) (setf j (pathname-bite s i)) (selectq (string-fetch s (- j 1)) (#\: (=> pn set-device (pathname-field-from-string (substring s i (- j 1))))) (#\> (=> pn set-directory (pathname-field-from-string (substring s (+ i 1) (- j 1))))) (#\. (setf name-count (+ name-count 1)) (setf field (substring s i (- j 1))) (selectq name-count (1 (=> pn set-name (pathname-field-from-string field)) (if (>= j len) (=> pn set-type 'UNSPECIFIC)) ) (2 (=> pn set-type (pathname-field-from-string field)) (if (>= j len) (=> pn set-version 'UNSPECIFIC)) ) (3 (=> pn set-version (pathname-version-from-string field))) )) (t (setf name-count (+ name-count 1)) (setf field (substring s i j)) (selectq name-count (1 (=> pn set-name (pathname-field-from-string field))) (2 (=> pn set-type (pathname-field-from-string field))) (3 (=> pn set-version (pathname-version-from-string field))) ))) (setf i j) ) pn )) (de pathname-bite (pn i) (let* ((len (string-length pn)) (ch (string-fetch pn i)) ) (cond ((= ch #\<) (setf i (+ i 1)) (while (< i len) (setf ch (string-fetch pn i)) (setf i (+ i 1)) (if (= ch #\>) (exit)) ) ) (t (while (< i len) (setf ch (string-fetch pn i)) (setf i (+ i 1)) (if (= ch #\:) (exit)) (if (= ch #\.) (exit)) ))) i )) (de pathname-field-from-string (s) (cond ((StringP s) (cond ((string-empty? s) 'UNSPECIFIC) ((string= s "*") 'WILD) (t s) )) (t s))) (de pathname-version-from-string (s) (cond ((StringP s) (cond ((string-empty? s) NIL) ((string= s "-2") 'OLDEST) ((string= s "0") 'NEWEST) ((string= s "*") 'WILD) ((string-is-integer s) (string2integer s)) (t s) )) (t s))) (de pathname-empty-field? (x) (string-empty? (pathname-field-to-string x)) ) (de pathname-field-to-string (x) (cond ((StringP x) x) ((eq x 'OLDEST) "-2") ((eq x 'NEWEST) "0") ((eq x 'UNSPECIFIC) "") ((eq x 'WILD) "*") ((null x) "") (t (BldMsg "%w" x)))) (de string-is-integer (s) (for (from i 0 (string-upper-bound s)) (always (DigitP (string-fetch s i))) )) |
Added psl-1983/20-util/processor-time.sl version [951a6316cb].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Processor-Time.SL (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (put 'hptim 'OpenCode '((jsys 8#501) (jfcl)))) (de processor-time () % Return accumulated processor time for the current process in microseconds. (WTimes2 (hptim 1) 10) ) |
Added psl-1983/20-util/wait.sl version [72cd54a7f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Wait.SL - Wait Primitive (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (BothTimes (load jsys)) (de wait-timeout (f n-60ths) % Return when either of two conditions are met: (1) The function F (of no % arguments) returns non-NIL; (2) The specified elapsed time (in units of % 1/60th second) has elapsed. Don't waste CPU cycles! Return the last % value returned by F (which is always invoked at least once). (let (result) (while (and (not (setf result (apply f nil))) (> n-60ths 0)) (Jsys0 250 0 0 0 (const jsDISMS)) (setf n-60ths (- n-60ths 15)) ) result )) |
Added psl-1983/20-util/whereis.red version [c5dd0960bf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Scan the *.ins files % for a special Token Loadtime Load DIR!-STUFF$ InsList!*:=Vector2List GetCleanDir "<psl.util.ins>*.ins"$ Procedure ShowAllIns(); Begin scalar R,C,OldC; For each F in InsList!* do <<C:=OPEN(F,'input); OldC:=RDS C; R:=READ(); RDS OldC; Close C; Print F; Print R>>; End; Procedure LoadAllIns(); Begin scalar R,C,OldC; For each F in InsList!* do <<C:=OPEN(F,'input); OldC:=RDS C; R:=READ(); RDS OldC; Close C; For Each x in R do Put(x,'DefinedIn,F); PrintF(" %r loaded %n",F)>> End; Procedure WhereIs X; Begin scalar y; if(y:=get(x,'DefinedIn)) then Return y; if getd x then return "In The Kernel "; return NIL; end; |
Added psl-1983/3-1/clsc-20/common.sl version [713d6d6796].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMMON.SL - Compile- and read-time support for Common Lisp compatibility. % In a few cases, actually LISP Machine Lisp compatibility? % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 31 March 1982 % Copyright (c) 1982 University of Utah % % Edit by Cris Perdue, 7 Mar 1983 1335-PST % Left-expand is now available outside this module. (No longer flagged % as internalfunction.) % Edit by Cris Perdue, 4 Feb 1983 1047-PST % Removed ERRSET (redundant and not COMMON Lisp) and MOD (incorrect). % <PSL.UTIL.NEWVERSIONS>COMMON.SL.2, 13-Dec-82 21:30:58, Edit by GALWAY % Fixed bugs in copylist and copyalist that copied the first element % twice. Also fixed bug in copyalist where it failed to copy first pair % in the list. % Also started commenting the functions defined here. % These are only the Common Lisp definitions that do not conflict with % Standard Lisp or other PSL functions. Currently growing on a daily basis (imports '(useful fast-vector)) (compiletime (defmacro cl-alias (sl-name cl-name) `(defmacro ,cl-name form `(,',sl-name . ,form))) (flag '(expand-funcall* butlast-aux nbutlast-aux left-expand-aux) 'internalfunction) ) (cl-alias de defun) (defmacro defvar (name . other) (if *defn (fluid (list name))) (if (atom other) `(fluid `(,',name)) `(progn (fluid `(,',name)) (setq ,name ,(car other))))) (cl-alias idp symbolp) (cl-alias pairp consp) (defun listp (x) (or (null x) (consp x))) (put 'listp 'cmacro '(lambda (x) ((lambda (y) (or (null y) (consp y))) x))) (cl-alias fixp integerp) (cl-alias fixp characterp) (put 'characterp 'cmacro '(lambda (x) (posintp x))) (cl-alias vectorp arrayp) (cl-alias codep subrp) (defun functionp (x) (or (symbolp x) (codep x) (and (consp x) (eq (car x) 'lambda)))) (cl-alias eqn eql) (cl-alias equal equalp) (cl-alias valuecell symeval) (defmacro fsymeval (symbol) `((lambda (***fsymeval***) (or (cdr (getd ***fsymeval***)) (stderror (bldmsg "%r has no function definition" ***fsymeval***)))) ,symbol)) (defmacro boundp (name) `(not (unboundp ,name))) (defmacro fboundp (name) `(not (funboundp ,name))) (defmacro macro-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'macro)) (cdr y) nil))) (defmacro special-form-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'fexpr)) (cdr y) nil))) (defmacro fset (symbol value) `(putd ,symbol 'expr ,value)) (defmacro makunbound (x) `(let ((y ,x) (makunbound y) y))) (defmacro fmakunbound (x) `(let ((y ,x) (remd y) y))) (defmacro funcall* (fn . args) `(apply ,fn ,(expand-funcall* args))) (defun expand-funcall* (args) (if (null (cdr args)) (car args) `(cons ,(car args) ,(expand-funcall* (cdr args))))) (cl-alias funcall* lexpr-funcall) % only works when calls are compiled right now % need to make a separate special form and compiler macro prop. (defmacro progv (symbols values . body) `(let ((***bindmark*** (captureenvironment))) (do ((symbols ,symbols (cdr symbols)) (values ,values (cdr values))) ((null symbols) nil) (lbind1 (car symbols) (car values))) (prog1 (progn ,@body) (restoreenvironment ***bindmark***)))) (defmacro dolist (bindspec . progbody) `(prog (***do-list*** ,(first bindspec)) (setq ***do-list*** ,(second bindspec)) $loop$ (if (null ***do-list***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (car ***do-list***)) ,@progbody (setq ***do-list*** (cdr ***do-list***)) (go $loop$))) (defmacro dotimes (bindspec . progbody) `(prog (***do-times*** ,(first bindspec)) (setq ,(first bindspec) 0) (setq ***do-times*** ,(second bindspec)) $loop$ (if (= ,(first bindspec) ***do-times***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (+ ,(first bindspec) 1)) ,@progbody (go $loop$))) (cl-alias map mapl) % neither PROG or PROG* supports initialization yet (cl-alias prog prog*) (cl-alias dm macro) % DECLARE, LOCALLY ignored now (defmacro declare forms ()) (defmacro locally forms `(let () ,forms)) % version of THE which does nothing (defmacro the (type form) form) (cl-alias get getpr) (cl-alias put putpr) (cl-alias remprop rempr) (cl-alias prop plist) (cl-alias id2string get-pname) (defun samepnamep (x y) (equal (get-pname x) (get-pname y))) (cl-alias newid make-symbol) (cl-alias internp internedp) (defun plusp (x) (and (not (minusp x)) (not (zerop x)))) (defun oddp (x) (and (integerp x) (equal (remainder x 2) 1))) (defun evenp (x) (and (integerp x) (equal (remainder x 2) 0))) (cl-alias eqn =) (cl-alias lessp <) (cl-alias greaterp >) (cl-alias leq <=) (cl-alias geq >=) (cl-alias neq /=) (cl-alias plus +) (defmacro - args (cond ((null (cdr args)) `(minus ,@args)) ((null (cddr args)) `(difference ,@args)) (t (left-expand args 'difference)))) (cl-alias times *) (defmacro / args (cond ((null (cdr args)) `(recip ,(car args))) ((null (cddr args)) `(quotient ,@args)) (t (left-expand args 'quotient)))) (defun left-expand (arglist op) (left-expand-aux `(,op ,(first arglist) ,(second arglist)) (rest (rest arglist)) op)) (defun left-expand-aux (newform arglist op) (if (null arglist) newform (left-expand-aux `(,op ,newform ,(first arglist)) (rest arglist) op))) (cl-alias add1 !1+) (cl-alias sub1 !1-) (cl-alias incr incf) (cl-alias decr decf) (defmacro logior args (robustexpand args 'lor 0)) (defmacro logxor args (robustexpand args 'lxor 0)) (defmacro logand args (robustexpand args 'land -1)) (cl-alias lnot lognot) (cl-alias lshift ash) (put 'ldb 'assign-op 'dpb) % Not defined, but used in NSTRUCT (put 'rplachar 'cmacro '(lambda (s i x) (iputs s i x))) (put 'char-int 'cmacro '(lambda (x) x)) (put 'int-char 'cmacro '(lambda (x) x)) (put 'char= 'cmacro '(lambda (x y) (eq x y))) (put 'char< 'cmacro '(lambda (x y) (ilessp x y))) (put 'char> 'cmacro '(lambda (x y) (igreaterp x y))) (cl-alias indx elt) (cl-alias setindx setelt) (defun copyseq (seq) (subseq seq 0 (+ (size seq) 1))) (defun endp (x) (cond ((consp x) ()) ((null x) t) (t (stderror (bldmsg "%r is not null at end of list" x))))) (cl-alias length list-length) (cl-alias reversip nreverse) (cl-alias getv vref) (cl-alias putv vset) (put 'string= 'cmacro '(lambda (x y) (eqstr x y))) (put 'string-length 'cmacro '(lambda (x) (iadd1 (isizes x)))) (put 'string-to-list 'cmacro '(lambda (x) (string2list x))) (put 'list-to-string 'cmacro '(lambda (x) (list2string x))) (put 'string-to-vector 'cmacro '(lambda (x) (string2vector x))) (put 'vector-to-string 'cmacro '(lambda (x) (vector2string x))) (put 'substring 'cmacro '(lambda (s low high) (sub s low (idifference high (iadd1 low))))) (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (cl-alias copy copytree) (cl-alias pair pairlis) (put 'make-string 'cmacro '(lambda (i c) (mkstring (isub1 i) c))) (defmacro putprop (symbol value indicator) `(put ,symbol ,indicator ,value)) (defmacro defprop (symbol value indicator) `(putprop `,',symbol `,',value `,',indicator)) (defmacro eval-when (time . forms) (if *defn (progn (when (memq 'compile time) (evprogn forms)) (when (memq 'load time) `(progn ,@forms))) (when (memq 'eval time) `(progn ,@forms)))) % This name is already used by PSL /csp % (defmacro case tail % (cons 'selectq tail) % Selectq is actually a LISP Machine LISP name /csp (defmacro selectq (on . s-forms) (if (atom on) `(cond ,@(expand-select s-forms on)) `((lambda (***selectq-arg***) (cond ,@(expand-select s-forms '***selectq-arg***))) ,on))) (defun expand-select (s-forms formal) (cond ((null s-forms) ()) (t `((,(let ((selector (first (first s-forms)))) (cond ((consp selector) `(memq ,formal `,',selector)) ((memq selector '(otherwise t)) t) (t `(eq ,formal `,',selector)))) ,@(rest (first s-forms))) ,@(expand-select (rest s-forms) formal))))) (defmacro comment form ()) (defmacro special args `(fluid `,',args)) (defmacro unspecial args `(unfluid `,',args)) (cl-alias atsoc assq) (cl-alias lastpair last) (cl-alias flatsize2 flatc) (cl-alias explode2 explodec) % swapf, exchf ...? (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (defun tree-equal (x y) (if (atom x) (eql x y) (and (tree-equal (car x) (car y)) (tree-equal (cdr x) (cdr y))))) % Return a "top level copy" of a list. (defun copylist (x) (if (atom x) x (let* ((x1 (cons (car x) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (car x) ())) (setq x (cdr x)))))) % Return a copy of an a-list (copy down to the pairs but no deeper). (defun copyalist (x) (if (atom x) x (let* ((x1 (cons (cons (caar x) (cdar x)) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (cons (caar x) (cdar x)) ())) (setq x (cdr x)))))) (defun revappend (x y) (if (atom x) y (revappend (cdr x) (cons (car x) y)))) (defun nreconc (x y) (if (atom x) y (let ((z (cdr x))) (rplacd x y) (nreconc z x)))) (defun butlast (x) (if (or (atom x) (atom (cdr x))) x (butlast-aux x ()))) (defun butlast-aux (x y) (let ((z (cons (car x) y))) (if (atom (cddr x)) z (butlast-aux (cdr x) z)))) (defun nbutlast (x) (if (or (atom x) (atom (cdr x))) x (do ((y x (cdr y))) ((atom (cddr y)) (rplacd y ()))) x)) (defun buttail (list sublist) (if (atom list) list (let ((list1 (cons (car list) ()))) (setq list (cdr list)) (do ((list2 list1 (cdr list2))) ((or (atom list) (eq list sublist)) list1) (rplacd list2 (cons (car list) ())) (setq list (cdr list)))))) (cl-alias substip nsubst) (defmacro ouch (char . maybe-channel) (if maybe-channel `(channelwritechar ,(car maybe-channel) ,char) `(writechar ,char))) (defmacro inch maybe-channel (if maybe-channel `(channelreadchar ,(car maybe-channel)) `(readchar))) (defmacro uninch (char . maybe-channel) (if maybe-channel `(channelunreadchar ,(car maybe-channel) ,char) `(unreadchar ,char))) |
Added psl-1983/3-1/clsc-20/extended-input.b version [b4fe030f09].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/extended-input.sl version [8cb4cbdace].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Extended-Input.SL - 9-bit terminal input (for 7 or 8 bit terminals) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 August 1982 % Revised: 11 April 1983 % % 11-Apr-83 Alan Snyder % Change "obsolete" #\BS to #\BackSpace. % 17-Feb-83 Alan Snyder % Added PUSH-BACK-INPUT-CHARACTER function. Revise mapping so that % bit prefix characters are recognized after mapping. % 22-Dec-82 Jeffrey Soreff % Added PUSH-BACK-EXTENDED-CHARACTER function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int fast-vectors)) % Global variables: (fluid '(nmode-meta-bit-prefix-character nmode-control-bit-prefix-character nmode-control-meta-bit-prefix-character)) (setf nmode-meta-bit-prefix-character (x-char C-!\)) (setf nmode-control-bit-prefix-character (x-char C-^)) (setf nmode-control-meta-bit-prefix-character (x-char C-Z)) % Internal static variables: (fluid '(nmode-terminal-map nmode-lookahead-extended-char nmode-lookahead-char)) (setf nmode-lookahead-extended-char nil) (setf nmode-lookahead-char nil) (de nmode-initialize-extended-input () (setf nmode-terminal-map (MkVect 255)) % Most input characters map to themselves. (for (from i 0 255) (do (vector-store nmode-terminal-map i i))) % Some ASCII control character map to Extended Control characters. % Exceptions: BACKSPACE, TAB, RETURN, LINEFEED, ESCAPE (for (from i 0 31) (unless (member i '#.(list #\BackSpace #\Tab #\CR #\LF #\ESC))) (do (let ((mch (X-Set-Control (+ i 64)))) (vector-store nmode-terminal-map i mch) (vector-store nmode-terminal-map (+ i 128) (+ mch 128)) ))) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de input-extended-character () (if nmode-lookahead-extended-char (prog1 nmode-lookahead-extended-char (setf nmode-lookahead-extended-char nil)) (input-direct-extended-character))) (de push-back-extended-character (ch) (setf nmode-lookahead-extended-char ch)) (de input-direct-extended-character () % Read an extended character from the terminal. % Recognize and interpret bit-prefix characters. (let* ((ch (input-terminal-character))) (cond ((= ch nmode-meta-bit-prefix-character) (nmode-append-separated-prompt "M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-unmeta ch))) (x-set-meta ch) ) ((= ch nmode-control-bit-prefix-character) (nmode-append-separated-prompt "C-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-uncontrol ch))) (x-set-control ch) ) ((= ch nmode-control-meta-bit-prefix-character) (nmode-append-separated-prompt "C-M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-base ch))) (x-set-meta (x-set-control ch)) ) (t ch) ))) (de push-back-input-character (ch) (setf nmode-lookahead-char ch) ) (de input-terminal-character () % Read an extended character from the terminal. Perform mapping from 8-bit % to 9-bit characters. Do not interpret bit prefix characters. (if nmode-lookahead-char (prog1 nmode-lookahead-char (setf nmode-lookahead-char nil)) (vector-fetch nmode-terminal-map (input-direct-terminal-character)) )) |
Added psl-1983/3-1/clsc-20/hazeltine-1500.b version [b36120be62].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/hazeltine-1500.sl version [b9bebd65e4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % HAZELTINE-1500.SL - Terminal Interface % % Author: Lon Willett % Date: 6-Jul-83 % % Based on TELERAY.SL by: % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (BothTimes (load jsys)) (compiletime (progn (defconst !.MORLW 8#30 % read page width !.MORLL 8#32 % read page length !.PRIOU 8#101) % primary output jfn, it had better be a TTY (ds get-system-page-height () (jsys3 (const !.priou) (const !.morll) 0 0 (const jsMTOPR)) ) (ds get-system-line-length () (jsys3 (const !.priou) (const !.morlw) 0 0 (const jsMTOPR)) ) )) (BothTimes (Put 'TILDE 'CHARCONST 126)) % This hack redefines !\= as a macro to be replaced by % (INTERN (STRING #\TILDE #\=)). This file shouldn't contain any TILDE's (CompileTime (DM !\= (u) `(#.(INTERN (STRING #\TILDE #/=)) . ,(CDR u)) )) (defflavor hazeltine-1500 ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (auto-wrap 'MAYBE) % does a CRLF when output to last column: YES NO MAYBE (auto-scroll 'YES) % scrolls when output (MAXROW,MAXCOL): YES NO MAYBE (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width auto-wrap auto-scroll maxrow maxcol raw-mode) (initable-instance-variables height width auto-wrap auto-scroll) ) (defmethod (hazeltine-1500 init) (initlis) % Pick up the page length & width from the monitor if it is not % specified by an initialization argument. Use default if we don't like % what the monitor claims. % HEIGHT & MAXROW: (unless (memq 'HEIGHT initlis) (setf height (get-system-page-height))) (when (or (< height 10) (> height 96)) (setf height 24)) (setf maxrow (- height 1)) % WIDTH & MAXCOL: (unless (memq 'WIDTH initlis) (setf width (get-system-line-length))) (when (or (< width 10) (> width 96)) (setf width 80)) (setf maxcol (- width 1)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (deflambda out-move (xxxrow xxxcol) (out-chars TILDE (CONTROL Q)) (PBOUT (IF (>= xxxcol 31) xxxcol (+ xxxcol 8#140))) (PBOUT (+ xxxrow 32)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (hazeltine-1500 get-character) () (& (PBIN) 8#177) ) (defmethod (hazeltine-1500 ring-bell) () (out-char BELL) ) (defmethod (hazeltine-1500 move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (let ((relative-move-number-of-chars (+ %calculate the number of chars for a horizontal move (cond ((= column cursor-column) 0) % no horizontal move required ((= column 0) 1) % using a CR ((< column cursor-column) (- cursor-column column)) % move left takes 1 char (T (- column cursor-column)) ) % move right takes 1 char % and add in the number of chars for a vertical move (cond ((= row cursor-row) 0) % no vertical move required ((< row cursor-row) (* 2 (- cursor-row row))) % move up takes 2 chars (T (- row cursor-row)) )))) % move down takes 1 char (cond ((= relative-move-number-of-chars 0) ) % no move required ((and (= row 0) (= column 0) (<= 2 relative-move-number-of-chars)) (out-chars TILDE (CONTROL R)) ) % cursor home ((<= 4 relative-move-number-of-chars) (out-move row column)) % move absolute (T %Move relative to the current point (cond ((= column cursor-column) ) % no horizontal move needed ((= column 0) (out-char CR)) % move to leftmost column ((< column cursor-column) (FOR (FROM junk cursor-column (+ column 1) -1) (DO (out-char BACKSPACE)) )) % move left (T (FOR (FROM junk cursor-column (- column 1) 1) (DO (out-char (CONTROL P))) ))) % move right (cond ((< row cursor-row) (FOR (FROM junk cursor-row (+ row 1) -1) (DO (out-chars TILDE FF)) )) % move up ((> row cursor-row) (FOR (FROM junk cursor-row (- row 1) 1) (DO (out-char LF)) ))) % move down )) ) (setf cursor-row row) (setf cursor-column column) ) (defmethod (hazeltine-1500 enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (hazeltine-1500 leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (hazeltine-1500 erase) () % This method should be invoked to initialize the screen to a known state. (out-chars TILDE (CONTROL R) TILDE (CONTROL X)) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (hazeltine-1500 clear-line) () (out-chars TILDE (CONTROL O)) ) (defmethod (hazeltine-1500 convert-character) (ch) (setf ch (& ch (display-character-cons % no enhancements (dc-make-enhancement-mask % INVERSE-VIDEO BLINK UNDERLINE INTENSIFY ) % only font number 0 (dc-make-font-mask 0) % only 7 bits in a character 16#7F))) (let ((code (dc-character-code ch))) % replace non-printable chars with a space (when (or (< code 8#40) (>= code 8#176)) (setf ch terminal-blank)) ) ch) (defmethod (hazeltine-1500 normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (hazeltine-1500 highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (hazeltine-1500 supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (hazeltine-1500 update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % this check prevents unchecked index of -1, and also keeps % us from moving the cursor when the line doesn't need to be updated (when (<= first-col last-col) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank ) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (!\= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (when (!\= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self move-cursor row col) (=> self &print-char new-code) (vector-store old-line col new) )) ))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self move-cursor row (+ last-nonblank-column 1)) (=> self clear-line) ) ))) % The following methods are provided for INTERNAL use only! % This method outputs a printable character % (should we check that the character is printable?) (defmethod (hazeltine-1500 &print-char) (ch) (cond ((< cursor-column maxcol) % normal case (PBOUT ch) (setf cursor-column (+ cursor-column 1))) ((< cursor-row maxrow) % last character on a line, but not last line % This horrendous hack assures that we have auto-wrap (PBOUT ch) (setf cursor-row (+ cursor-row 1)) (setf cursor-column 0) (cond ((eq auto-wrap 'NO) (out-chars CR LF)) ((eq auto-wrap 'MAYBE) (out-move cursor-row 0)) % ((eq auto-wrap 'YES) ) )) (T % Bottom right corner % Prevent scrolling (put blank there if we can't print). Move to (0,0). (IF (or (eq auto-scroll 'YES) (eq auto-scroll 'MAYBE)) % THEN (=> self clear-line) % ELSE (eq auto-scroll 'NO) so (PBOUT ch)) (=> self move-cursor 0 0) ) )) (defmethod (hazeltine-1500 &set-terminal-enhancement) (enh) % no enhancements supported (setf terminal-enhancement 0) ) |
Added psl-1983/3-1/clsc-20/make-nmode.ctl version [ccc8820bc5].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ; This file creates a new S:EX-NMODE.EXE, replacing the old one. ; NOTE: the compiler is also loaded, as most users will need it. @delete s:nmode.exe, @exp @ @s:bare-psl random-argument-to-get-a-new-fork *(load nmode) *(load compiler) *(nmode-initialize) *(setf nmode-auto-start T) *(setf prinlevel 2) *(savesystem "Extended 20-PSL 3.1 NMODE" "S:NMODE.EXE" ()) *(quit) @reset . |
Added psl-1983/3-1/clsc-20/make-nmode.mic version [bbb5ed137a].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ! 29-Jun-83 Lon Willett ! Modified MAKE-NMODE.CTL to get this file. Just commented out ! the PRINLEVEL change. ! ! This file creates a new S:NMODE.EXE, replacing the old one. ! NOTE: the compiler is also loaded, as most users will need it. @s:bare-psl random-argument-to-get-a-new-fork *(load nmode) *(load compiler) *(nmode-initialize) *(setf nmode-auto-start T) !(setf prinlevel 2) *(savesystem "Extended 20-PSL 3.1 NMODE" "S:NMODE.EXE" ()) *(quit) @reset . |
Added psl-1983/3-1/clsc-20/mode-defs.b version [83d3bf6090].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/mode-defs.sl version [d9c3c8d2fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MODE-DEFS.SL - NMODE Command Table and Mode Definitions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 15 March 1983 % % 15-Mar-83 Alan Snyder % Add M-X List Browsers, M-X Print Buffer, C-X C-P. Define modes at load % time. Rename write-screen-photo-command to write-screen-command; change to % M-X Write Screen (instead of C-X P). % 18-Feb-83 Alan Snyder % Rename down-list and insert-parens. Add M-) command. % 9-Feb-83 Alan Snyder % Add Esc-_ (Help), temporarily attached to M-X Apropos. % Move some M-X commands into text-command-list. % 2-Feb-83 Alan Snyder % Add Lisp-D. % 26-Jan-83 Alan Snyder % Add Esc-/. % 25-Jan-83 Alan Snyder % Created Window-Command-List to allow scrolling in Recurse mode. % Removed modifying text commands from Recurse mode. % 24-Jan-83 Jeffrey Soreff % Added definition of Recurse-Mode % Defined M-X commands: Delete Matching Lines, Flush Lines, % Delete Non-Matching Lines, Keep Lines, How Many, Count Occurrences, % Set Key, Set Visited Filename, Rename Buffer, Kill Some Buffers, % Insert Date, Revert File % 5-Jan-83 Alan Snyder % Revised definition of input mode, C-S, and C-R. % 3-Dec-82 Alan Snyder % New definitions for ) and ] in Lisp mode. % New definitions for C-M-(, C-M-), C-M-U, C-M-N, and C-M-P. % New definitions for C-M-A, C-M-[, and C-M-R. % Define C-M-\ (Indent Region) in Lisp mode and Text mode. % Define C-? same as M-?, C-( same as C-M-(, C-) same as C-M-). % Lisp Mode establishes Lisp Parser. % Define C-M-C. % Define the text commands: C-=, C-X =, M-A, M-E, M-K, C-X Rubout, M-Z, M-Q, % M-G, M-H, M-], M-[, M-S. % Fix definitions of digits and hyphen: inserting definition goes on % text-command-list (where insertion commands go). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % (CompileTime (load objects)) (CompileTime (load extended-char)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-default-mode nmode-current-buffer nmode-input-special-command-list )) % Mode definitions: (fluid '(Lisp-Interface-Mode Text-Mode Basic-Mode Read-Only-Text-Mode Input-Mode Recurse-Mode )) % Command lists: (fluid '(Input-Command-List Read-Only-Text-Command-List Text-Command-List Rlisp-Command-List Lisp-Command-List Read-Only-Terminal-Command-List Modifying-Terminal-Command-List Window-Command-List Basic-Command-List Essential-Command-List Recurse-Command-List )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Mode Definitions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf Basic-Mode (nmode-define-mode "Basic" '((nmode-define-commands Basic-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) ))) (setf Read-Only-Text-Mode (nmode-define-mode "Read-Only-Text" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-establish-mode Basic-Mode) ))) (setf Text-Mode (nmode-define-mode "Text" '((nmode-define-commands Text-Command-List) (nmode-define-commands Modifying-Terminal-Command-List) (nmode-establish-mode Read-Only-Text-Mode) (nmode-define-normal-self-inserts) ))) (setf Lisp-Interface-Mode (nmode-define-mode "Lisp" '((nmode-define-commands Rlisp-Command-List) (establish-lisp-parser) (nmode-define-commands Lisp-Command-List) (nmode-establish-mode Text-Mode) ))) (setf Input-Mode (nmode-define-mode "Input" '((nmode-define-commands nmode-input-special-command-list) (nmode-define-command (x-char CR) 'nmode-terminate-input) (nmode-define-command (x-char LF) 'nmode-terminate-input) (nmode-define-commands Input-Command-List) (nmode-define-commands Text-Command-List) (nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-normal-self-inserts) ))) (setf Recurse-Mode (nmode-define-mode "Recurse" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-commands Recurse-Command-List) ))) (setf nmode-default-mode Text-Mode) (de nmode-initialize-modes () % Define initial set of file modes. (nmode-declare-file-mode "txt" Text-Mode) (nmode-declare-file-mode "red" Lisp-Interface-Mode) (nmode-declare-file-mode "sl" Lisp-Interface-Mode) (nmode-declare-file-mode "lsp" Lisp-Interface-Mode) (nmode-declare-file-mode "lap" Lisp-Interface-Mode) (nmode-declare-file-mode "build" Lisp-Interface-Mode) ) (de lisp-mode-command () (buffer-set-mode nmode-current-buffer Lisp-Interface-Mode) ) (de text-mode-command () (buffer-set-mode nmode-current-buffer Text-Mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Command Lists: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Rlisp-Command-List - commands related to the LISP interface (setf Rlisp-Command-List (list (cons (x-char C-!]) 'Lisp-prefix) (cons (x-chars C-!] !?) 'lisp-help-command) (cons (x-chars C-!] A) 'lisp-abort-command) (cons (x-chars C-!] B) 'lisp-backtrace-command) (cons (x-chars C-!] C) 'lisp-continue-command) (cons (x-chars C-!] D) 'execute-defun-command) (cons (x-chars C-!] E) 'execute-form-command) (cons (x-chars C-!] L) 'exit-nmode) (cons (x-chars C-!] Q) 'lisp-quit-command) (cons (x-chars C-!] R) 'lisp-retry-command) (cons (x-chars C-!] Y) 'yank-last-output-command) )) % Lisp-Command-List - commands related to editing LISP text (setf Lisp-Command-List (list (cons (x-char !)) 'insert-closing-bracket) (cons (x-char !]) 'insert-closing-bracket) (cons (x-char C-!() 'backward-up-list-command) (cons (x-char C-!)) 'forward-up-list-command) (cons (x-char C-M-!() 'backward-up-list-command) (cons (x-char C-M-!)) 'forward-up-list-command) (cons (x-char C-M-![) 'move-backward-defun-command) (cons (x-char C-M-!]) 'end-of-defun-command) (cons (x-char C-M-!\) 'lisp-indent-region-command) (cons (x-char C-M-@) 'mark-form-command) (cons (x-char C-M-A) 'move-backward-defun-command) (cons (x-char C-M-B) 'move-backward-form-command) (cons (x-char C-M-BACKSPACE) 'mark-defun-command) (cons (x-char C-M-D) 'down-list-command) (cons (x-char C-M-E) 'end-of-defun-command) (cons (x-char C-M-F) 'move-forward-form-command) (cons (x-char C-M-H) 'mark-defun-command) (cons (x-char C-M-I) 'lisp-tab-command) (cons (x-char C-M-K) 'kill-forward-form-command) (cons (x-char C-M-N) 'move-forward-list-command) (cons (x-char C-M-P) 'move-backward-list-command) (cons (x-char C-M-Q) 'lisp-indent-sexpr) (cons (x-char C-M-R) 'reposition-window-command) (cons (x-char C-M-RUBOUT) 'kill-backward-form-command) (cons (x-char C-M-T) 'transpose-forms) (cons (x-char C-M-TAB) 'lisp-tab-command) (cons (x-char C-M-U) 'backward-up-list-command) (cons (x-char M-!;) 'insert-comment-command) (cons (x-char M-BACKSPACE) 'mark-defun-command) (cons (x-char M-!() 'make-parens-command) (cons (x-char M-!)) 'move-over-paren-command) (cons (x-char RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char TAB) 'lisp-tab-command) )) % Essential-Command-List: the most essential commands (setf Essential-Command-List (list (cons (x-char C-X) 'c-x-prefix) (cons (x-char ESC) 'Esc-prefix) (cons (x-char M-X) 'm-x-prefix) (cons (x-char C-M-X) 'm-x-prefix) (cons (x-char C-G) 'nmode-abort-command) (cons (x-char C-L) 'nmode-refresh-command) (cons (x-char C-U) 'universal-argument) (cons (x-char 0) 'argument-digit) (cons (x-char 1) 'argument-digit) (cons (x-char 2) 'argument-digit) (cons (x-char 3) 'argument-digit) (cons (x-char 4) 'argument-digit) (cons (x-char 5) 'argument-digit) (cons (x-char 6) 'argument-digit) (cons (x-char 7) 'argument-digit) (cons (x-char 8) 'argument-digit) (cons (x-char 9) 'argument-digit) (cons (x-char -) 'negative-argument) (cons (x-char C-0) 'argument-digit) (cons (x-char C-1) 'argument-digit) (cons (x-char C-2) 'argument-digit) (cons (x-char C-3) 'argument-digit) (cons (x-char C-4) 'argument-digit) (cons (x-char C-5) 'argument-digit) (cons (x-char C-6) 'argument-digit) (cons (x-char C-7) 'argument-digit) (cons (x-char C-8) 'argument-digit) (cons (x-char C-9) 'argument-digit) (cons (x-char C--) 'negative-argument) (cons (x-char M-0) 'argument-digit) (cons (x-char M-1) 'argument-digit) (cons (x-char M-2) 'argument-digit) (cons (x-char M-3) 'argument-digit) (cons (x-char M-4) 'argument-digit) (cons (x-char M-5) 'argument-digit) (cons (x-char M-6) 'argument-digit) (cons (x-char M-7) 'argument-digit) (cons (x-char M-8) 'argument-digit) (cons (x-char M-9) 'argument-digit) (cons (x-char M--) 'negative-argument) (cons (x-char C-M-0) 'argument-digit) (cons (x-char C-M-1) 'argument-digit) (cons (x-char C-M-2) 'argument-digit) (cons (x-char C-M-3) 'argument-digit) (cons (x-char C-M-4) 'argument-digit) (cons (x-char C-M-5) 'argument-digit) (cons (x-char C-M-6) 'argument-digit) (cons (x-char C-M-7) 'argument-digit) (cons (x-char C-M-8) 'argument-digit) (cons (x-char C-M-9) 'argument-digit) (cons (x-char C-M--) 'negative-argument) (cons (x-chars C-X C-Z) 'nmode-exit-to-superior) (cons (x-chars C-X V) 'nmode-invert-video) (cons (x-chars Esc !/) 'execute-softkey-command) )) % Window-Command-List: commands for scrolling, etc. % These commands do not allow selecting a new window, buffer, mode, etc. (setf Window-Command-List (list (cons (x-char C-M-V) 'scroll-other-window-command) (cons (x-char C-V) 'next-screen-command) (cons (x-char M-R) 'move-to-screen-edge-command) (cons (x-char M-V) 'previous-screen-command) (cons (x-chars C-X <) 'scroll-window-left-command) (cons (x-chars C-X >) 'scroll-window-right-command) (cons (x-chars C-X ^) 'grow-window-command) (cons (m-x "Write Screen") 'write-screen-command) )) % Basic-Command-List: contains commands desirable in almost any mode. (setf Basic-Command-List (list (cons (x-char C-!?) 'help-dispatch) (cons (x-char C-M-L) 'select-previous-buffer-command) (cons (x-char M-!/) 'help-dispatch) (cons (x-char M-!?) 'help-dispatch) (cons (x-char M-!~) 'buffer-not-modified-command) (cons (x-chars C-X !.) 'set-fill-prefix-command) (cons (x-chars C-X 1) 'one-window-command) (cons (x-chars C-X 2) 'two-windows-command) (cons (x-chars C-X 3) 'view-two-windows-command) (cons (x-chars C-X 4) 'visit-in-other-window-command) (cons (x-chars C-X B) 'select-buffer-command) (cons (x-chars C-X C-B) 'buffer-browser-command) (cons (x-chars C-X C-F) 'find-file-command) (cons (x-chars C-X C-P) 'print-buffer-command) (cons (x-chars C-X C-S) 'save-file-command) (cons (x-chars C-X C-W) 'write-file-command) % here??? (cons (x-chars C-X D) 'dired-command) (cons (x-chars C-X E) 'exchange-windows-command) (cons (x-chars C-X F) 'set-fill-column-command) (cons (x-chars C-X K) 'kill-buffer-command) (cons (x-chars C-X O) 'other-window-command) (cons (x-chars Esc _) 'apropos-command) (cons (m-x "Append to File") 'append-to-file-command) (cons (m-x "Apropos") 'apropos-command) (cons (m-x "Auto Fill Mode") 'auto-fill-mode-command) (cons (m-x "Count Occurrences") 'Count-Occurrences-command) (cons (m-x "Delete and Expunge File") 'delete-and-expunge-file-command) (cons (m-x "Delete File") 'delete-file-command) (cons (m-x "DIRED") 'edit-directory-command) (cons (m-x "Edit Directory") 'edit-directory-command) (cons (m-x "Execute Buffer") 'execute-buffer-command) (cons (m-x "Execute File") 'execute-file-command) (cons (m-x "Find File") 'find-file-command) (cons (m-x "How Many") 'Count-Occurrences-command) (cons (m-x "Kill Buffer") 'kill-buffer-command) (cons (m-x "Kill File") 'delete-file-command) (cons (m-x "Kill Some Buffers") 'kill-some-buffers-command) (cons (m-x "List Browsers") 'browser-browser-command) (cons (m-x "List Buffers") 'buffer-browser-command) (cons (m-x "Make Space") 'nmode-gc) (cons (m-x "Prepend to File") 'prepend-to-file-command) (cons (m-x "Print Buffer") 'print-buffer-command) (cons (m-x "Rename Buffer") 'rename-buffer-command) (cons (m-x "Save All Files") 'save-all-files-command) (cons (m-x "Select Buffer") 'select-buffer-command) (cons (m-x "Set Key") 'set-key-command) (cons (m-x "Set Visited Filename") 'set-visited-filename-command) (cons (m-x "Start Scripting") 'start-scripting-command) (cons (m-x "Start Timing NMODE") 'start-timing-command) (cons (m-x "Stop Scripting") 'stop-scripting-command) (cons (m-x "Stop Timing NMODE") 'stop-timing-command) (cons (m-x "Undelete File") 'undelete-file-command) (cons (m-x "Write File") 'write-file-command) % here??? (cons (m-x "Write Region") 'write-region-command) )) % Read-Only-Text-Command-List: Commands for editing text buffers that % do not modify the buffer. (setf Read-Only-Text-Command-List (list % These commands are read-only commands for text mode. (cons (x-char BACKSPACE) 'move-backward-character-command) (cons (x-char C-<) 'mark-beginning-command) (cons (x-char C->) 'mark-end-command) (cons (x-char C-=) 'what-cursor-position-command) (cons (x-char C-@) 'set-mark-command) (cons (x-char C-A) 'move-to-start-of-line-command) (cons (x-char C-B) 'move-backward-character-command) (cons (x-char C-E) 'move-to-end-of-line-command) (cons (x-char C-F) 'move-forward-character-command) (cons (x-char C-M-M) 'back-to-indentation-command) (cons (x-char C-M-RETURN) 'back-to-indentation-command) (cons (x-char C-M-W) 'append-next-kill-command) (cons (x-char C-N) 'move-down-command) (cons (x-char C-P) 'move-up-command) (cons (x-char C-R) 'reverse-search-command) (cons (x-char C-S) 'incremental-search-command) (cons (x-char C-SPACE) 'set-mark-command) (cons (x-char M-<) 'move-to-buffer-start-command) (cons (x-char M->) 'move-to-buffer-end-command) (cons (x-char M-![) 'backward-paragraph-command) (cons (x-char M-!]) 'forward-paragraph-command) (cons (x-char M-@) 'mark-word-command) (cons (x-char M-A) 'backward-sentence-command) (cons (x-char M-B) 'move-backward-word-command) (cons (x-char M-E) 'forward-sentence-command) (cons (x-char M-F) 'move-forward-word-command) (cons (x-char M-H) 'mark-paragraph-command) (cons (x-char M-M) 'back-to-indentation-command) (cons (x-char M-RETURN) 'back-to-indentation-command) (cons (x-char M-W) 'copy-region) (cons (x-chars C-X A) 'append-to-buffer-command) (cons (x-chars C-X C-N) 'set-goal-column-command) (cons (x-chars C-X C-X) 'exchange-point-and-mark) (cons (x-chars C-X H) 'mark-whole-buffer-command) (cons (x-chars C-X =) 'what-cursor-position-command) )) % Text-Command-List: Commands for editing text buffers that might modify % the buffer. Note: put read-only commands on % Read-Only-Text-Command-List (above). (setf Text-Command-List (list (cons (x-char 0) 'argument-or-insert-command) (cons (x-char 1) 'argument-or-insert-command) (cons (x-char 2) 'argument-or-insert-command) (cons (x-char 3) 'argument-or-insert-command) (cons (x-char 4) 'argument-or-insert-command) (cons (x-char 5) 'argument-or-insert-command) (cons (x-char 6) 'argument-or-insert-command) (cons (x-char 7) 'argument-or-insert-command) (cons (x-char 8) 'argument-or-insert-command) (cons (x-char 9) 'argument-or-insert-command) (cons (x-char -) 'argument-or-insert-command) (cons (x-char C-!%) 'replace-string-command) (cons (x-char C-D) 'delete-forward-character-command) (cons (x-char C-K) 'kill-line) (cons (x-char C-M-C) 'insert-self-command) (cons (x-char C-M-O) 'split-line-command) (cons (x-char C-M-!\) 'indent-region-command) (cons (x-char C-N) 'move-down-extending-command) (cons (x-char C-O) 'open-line-command) (cons (x-char C-Q) 'insert-next-character-command) (cons (x-char C-RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char C-T) 'transpose-characters-command) (cons (x-char C-W) 'kill-region) (cons (x-char C-Y) 'insert-kill-buffer) (cons (x-char LF) 'indent-new-line-command) (cons (x-char M-!') 'upcase-digit-command) (cons (x-char M-!%) 'query-replace-command) (cons (x-char M-!\) 'delete-horizontal-space-command) (cons (x-char M-C) 'uppercase-initial-command) (cons (x-char M-D) 'kill-forward-word-command) (cons (x-char M-G) 'fill-region-command) (cons (x-char M-I) 'tab-to-tab-stop-command) (cons (x-char M-K) 'kill-sentence-command) (cons (x-char M-L) 'lowercase-word-command) (cons (x-char M-Q) 'fill-paragraph-command) (cons (x-char M-RUBOUT) 'kill-backward-word-command) (cons (x-char M-S) 'center-line-command) (cons (x-char M-T) 'transpose-words) (cons (x-char M-TAB) 'tab-to-tab-stop-command) (cons (x-char M-U) 'uppercase-word-command) (cons (x-char M-Y) 'unkill-previous) (cons (x-char M-Z) 'fill-comment-command) (cons (x-char M-^) 'delete-indentation-command) (cons (x-char RETURN) 'return-command) (cons (x-char RUBOUT) 'delete-backward-character-command) (cons (x-char TAB) 'tab-to-tab-stop-command) (cons (x-chars C-X C-L) 'lowercase-region-command) (cons (x-chars C-X C-O) 'delete-blank-lines-command) (cons (x-chars C-X C-T) 'transpose-lines) (cons (x-chars C-X C-U) 'uppercase-region-command) (cons (x-chars C-X C-V) 'visit-file-command) (cons (x-chars C-X G) 'get-register-command) (cons (x-chars C-X Rubout) 'backward-kill-sentence-command) (cons (x-chars C-X T) 'transpose-regions) (cons (x-chars C-X X) 'put-register-command) (cons (m-x "Delete Matching Lines") 'delete-matching-lines-command) (cons (m-x "Delete Non-Matching Lines") 'delete-non-matching-lines-command) (cons (m-x "Flush Lines") 'delete-matching-lines-command) (cons (m-x "Insert Buffer") 'insert-buffer-command) (cons (m-x "Insert Date") 'insert-date-command) (cons (m-x "Insert File") 'insert-file-command) (cons (m-x "Keep Lines") 'delete-non-matching-lines-command) (cons (m-x "Lisp Mode") 'lisp-mode-command) (cons (m-x "Replace String") 'replace-string-command) (cons (m-x "Query Replace") 'query-replace-command) (cons (m-x "Revert File") 'revert-file-command) (cons (m-x "Text Mode") 'text-mode-command) (cons (m-x "Visit File") 'visit-file-command) )) (setf Read-Only-Terminal-Command-List (list (cons (x-chars ESC !h) 'move-to-buffer-start-command) (cons (x-chars ESC 4) 'move-backward-word-command) (cons (x-chars ESC 5) 'move-forward-word-command) (cons (x-chars ESC A) 'move-up-command) (cons (x-chars ESC B) 'move-down-command) (cons (x-chars ESC C) 'move-forward-character-command) (cons (x-chars ESC D) 'move-backward-character-command) (cons (x-chars ESC F) 'move-to-buffer-end-command) (cons (x-chars ESC J) 'nmode-full-refresh) (cons (x-chars ESC S) 'scroll-window-up-line-command) (cons (x-chars ESC T) 'scroll-window-down-line-command) (cons (x-chars ESC U) 'scroll-window-up-page-command) (cons (x-chars ESC V) 'scroll-window-down-page-command) )) (setf Modifying-Terminal-Command-List (list (cons (x-chars ESC L) 'open-line-command) (cons (x-chars ESC M) 'kill-line) (cons (x-chars ESC P) 'delete-forward-character-command) )) (setf Input-Command-List (list (cons (x-char C-R) 'nmode-yank-default-input) )) (setf Recurse-Command-List (list (cons (x-char y) 'affirmative-exit) (cons (x-char n) 'negative-exit) )) |
Added psl-1983/3-1/clsc-20/nmode-20.b version [8a4e714be3].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/nmode-ex-20.sl version [b5cf6d08b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-20.SL - DEC-20 NMODE Stuff (intended for DEC-20 Version Only) % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 5 April 1983 % % 15-Jun-83 Robert Kessler % Add ambassador, teleray and VT100 terminal support. % 5-Apr-83 Alan Snyder % Add load-nmode and set-terminal stuff to make it more like other systems. % 15-Mar-83 Alan Snyder % Add nmode-print-device. % 25-Jan-83 Alan Snyder % Add version of actualize-file-name that ensures that transiently-created % file has delete access. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load useful common fast-strings)) % External variables used here: (fluid '(nmode-file-list nmode-source-prefix nmode-binary-prefix *usermode *redefmsg doc-text-file reference-text-file nmode-print-device nmode-terminal )) % Global variables defined here: (fluid '(terminal-type)) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "pn:")) (if (or (unboundp 'nmode-binary-prefix) (null nmode-binary-prefix)) (setf nmode-binary-prefix "pnb:")) (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overridden by the user before NMODE is initialized. (nmode-load-required-modules) (nmode-load-all) (setf nmode-print-device "LPT:") % Set up "pointers" to online documentation. (setf doc-text-file "PS:<PSL.DOC.NMODE>FRAMES.LPT") (setf reference-text-file "PS:<PSL.DOC.NMODE>COSTLY.SL") % Get our version of the prompt line with date/time (load exec) (faslin "pnb:window-label-rewrite.b") (let ((*usermode nil) (*redefmsg nil)) (copyd 'actualize-file-name 'dec20-actualize-file-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-set-terminal () (setf terminal-type (jsys2 65 0 0 0 (const jsgttyp))) (selectq terminal-type (6 % HP264X (ensure-terminal-type 'hp2648a) ) (7 % Teleray (ensure-terminal-type 'teleray) ) (15 % VT52 (ensure-terminal-type 'vt52x) ) (16 % VT100 (ensure-terminal-type 'vt100) ) (19 % ambassador (ensure-terminal-type 'ambassador) ) (21 % HP2621 (ensure-terminal-type 'hp2648a) ) (t (or nmode-terminal (ensure-terminal-type 'hp2648a)) ) )) % These functions defined for compatibility: (de ambassador () (ensure-terminal-type 'ambassador)) (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) (de teleray () (ensure-terminal-type 'teleray)) (de vt100 () (ensure-terminal-type 'vt100)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () % Stolen directly from Nancy Kendzierski % Date/time in appropriate format for the network mail header (let ((date-time (MkString 80))) (jsys1 date-time -1 #.(bits 5 7 10 12 13) 0 (const jsODTIM)) (recopystringtonull date-time))) (de dec20-actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output (string-concat file-name ";P777777") % so we can delete it! )) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load objects) (load common) (load useful) (load strings) (load pathnames) (load pathnamex) (load ring-buffer) (load extended-char) (load directory) (load input-stream) (load output-stream) (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load rawio) (load windows) ) (de nmode-fixup-name (s) s) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-binary-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "browser-browser" "buffer-browser" "dired" "doc" )) |
Added psl-1983/3-1/clsc-20/notes.txt version [f5a7485c48].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 1. Changed references to "PS:<PSL.DOC.NMODE>" to "PNDOC:", in files PN:NMODE-EX-20 => PNB:NMODE-20.B 2. Redo the terminal type selection, in PN:NMODE-EX-20 => PNB:NMODE-20.B 3. Changed TELERAY terminal definitions to do 7 bit input (not 8), in PW:TELERAY.SL => PWB:TELERAY.B 4. Where is the source code for VT100 terminals (and AMBASSADOR)? 5. Changed PRINLEVEL init from 2 to NIL (in PDIST:MAKE-NMODE.CTL) 6. Use ESC as the M-Prefix key, in files PN:EXTENDED-INPUT.SL => PNB:EXTENDED-INPUT.B 7. Define M-ESC (accessed by the sequence ESC ESC) to be the ESC-Prefix, in PN:MODE-DEFS.SL => PNB:MODE-DEFS.B 8. When further terminal types are supported, load the packages from PW:WINDOWS-EX-20.SL => PW:WINDOWS-20.B 9. Note that PSL, not BARE-PSL is used to remake NMODE, so be sure you don't have a PSL.INIT file. Also a few extra packages (HOMEDIR and INIT-FILE) are pre-loaded in the new NMODE. 10. Note that the loading sequence finds the NMODE.LAP in "PL:", not the version in "PN:". 11. Fixed bug in METHOD TELERAY MOVE-CURSOR that used vector index of -1, in PW:TELERAY.SL => PWB:TELERAY.B 12. Why, in 2 window mode, is the top line of the bottom window printed as appended to the mode line of the top window, and therefore not visible? Is the bug something on our 20 or a problem in NMODE in general? |
Added psl-1983/3-1/clsc-20/remake-nmode.mic version [2603ebe33a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @connect scrtch:<psl.3-1.clsc-20> @define s: scrtch:<scratch> @psl:pslcomp *(FASLOUT "VT52NX") (DSKIN "VT52NX.SL") (FASLEND) *(FASLOUT "HAZELTINE-1500") (DSKIN "HAZELTINE-1500.SL") (FASLEND) *(FASLOUT "TELEVIDEO") (DSKIN "TELEVIDEO.SL") (FASLEND) *(FASLOUT "WINDOWS-20") (DSKIN "WINDOWS-EX-20.SL") (FASLEND) *(FASLOUT "EXTENDED-INPUT") (DSKIN "EXTENDED-INPUT.SL") (FASLEND) *(FASLOUT "MODE-DEFS") (DSKIN "MODE-DEFS.SL") (FASLEND) *(FASLOUT "NMODE-20") (DSKIN "NMODE-EX-20.SL") (FASLEND) *(QUIT) @reset . @set file generation-retention-count pwb:windows-20.b.* 0 @set file generation-retention-count pnb:extended-input.b.* 0 @set file generation-retention-count pnb:mode-defs.b.* 0 @set file generation-retention-count pnb:nmode-20.b.* 0 @copy vt52nx.b.0 pwb:vt52nx.b.-1 @copy hazeltine-1500.b.0 pwb:hazeltine-1500.b.-1 @copy televideo.b.0 pwb:televideo.b.-1 @copy windows-20.b.0 pwb:windows-20.b.-1 @copy extended-input.b.0 pnb:extended-input.b.-1 @copy mode-defs.b.0 pnb:mode-defs.b.-1 @copy nmode-20.b.0 pnb:nmode-20.b.-1 @copy psl:psl.exe s:bare-psl.exe @do make-nmode.mic @set file generation-retention-count psl:nmode.exe.* 0 @rename s:nmode.exe.0 psl:nmode.exe.-1 @kmic |
Added psl-1983/3-1/clsc-20/teleray.sl version [4c83f1a64a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TELERAY.SL - Terminal Interface % % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor teleray ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (teleray get-character) () (& (PBIN) 8#377) ) (defmethod (teleray ring-bell) () (out-char BELL) ) (defmethod (teleray move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (teleray enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (teleray leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (teleray erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (teleray clear-line) () (out-chars ESC K) ) (defmethod (teleray convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (teleray normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (teleray update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (if (> new-code 127) (progn (PBOUT 27) (PBOUT 82) (PBOUT (+ 64 (- new-code 128)))) (PBOUT new-code)) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0) )) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (teleray init) () ) (defmethod (teleray &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (teleray &set-terminal-enhancement) (enh) ) |
Added psl-1983/3-1/clsc-20/televideo.b version [c07104b24f].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/televideo.sl version [59854450c2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TELEVIDEO -- Terminal Interface % Lon Willett, 6-Jul-83 % Based on file: % % TELERAY.SL % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (BothTimes (load JSYS)) (compiletime (progn (defconst !.MORLW 8#30 % read page width !.MORLL 8#32 % read page length !.PRIOU 8#101) % primary output jfn, it had better be a TTY % NOTE: since I/O is done with PBIN/PBOUT, using the primary JFN should % be ok. This really ought to be written to use an arbitrary JFN. (ds get-system-page-height () (jsys3 (const !.priou) (const !.morll) 0 0 (const jsMTOPR)) ) (ds get-system-line-length () (jsys3 (const !.priou) (const !.morlw) 0 0 (const jsMTOPR)) ) )) (defflavor televideo ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (auto-wrap 'MAYBE) % does a CRLF when output to last column: YES NO MAYBE (auto-scroll 'YES) % scrolls when output to (MAXROW,MAXCOL): YES NO MAYBE (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width auto-wrap auto-scroll maxrow maxcol raw-mode) (initable-instance-variables height width auto-wrap auto-scroll) ) (defmethod (televideo init) (initlis) % Pick up the page length & width from the monitor if it is not % specified by an initialization argument. Use default if we don't like % what the monitor claims. % HEIGHT & MAXROW: (unless (memq 'HEIGHT initlis) (setf height (get-system-page-height))) (when (or (< height 10) (> height 96)) (setf height 24)) (setf maxrow (- height 1)) % WIDTH & MAXCOL: (unless (memq 'WIDTH initlis) (setf width (get-system-line-length))) (when (or (< width 10) (> width 96)) (setf width 80)) (setf maxcol (- width 1)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC !=) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (televideo get-character) () (& (PBIN) 8#177) ) (defmethod (televideo ring-bell) () (out-char BELL) ) (defmethod (televideo move-cursor) (row column) % (ROW COLUMN) is the point we want to move to (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (let ((relative-move-number-of-chars (+ % vertical move: (cond ((< cursor-row row) (- row cursor-row)) % 1 char to move down ((> cursor-row row) (- cursor-row row)) % 1 to move up (T 0)) % else no vertical move necessary % horizontal move: (cond ((= cursor-column column) 0) % no horizontal move necessary ((= column 0) 1) % move to left column ((> cursor-column column) (- cursor-column column)) % 1 char to move left (T (- column cursor-column)) ) % 1 char to move right ))) (cond ((= relative-move-number-of-chars 0) ) % no move needed ((and (= row 0) (= column 0)) (out-char (CONTROL !^))) % cursor HOME ((>= relative-move-number-of-chars 4) (out-move row column)) % move absolute (T % move relative (cond ((= cursor-column column) ) % no horizontal move needed ((= column 0) (out-char CR)) % move to left-most column ((> cursor-column column) (for (from curcol cursor-column (+ column 1) -1) (do (out-char BACKSPACE)) )) % move left (T (for (from curcol cursor-column (- column 1) 1) (do (out-char FF)) )) ) % move right % now take care of the vertical move (cond ((= cursor-row row) ) % no move needed ((< cursor-row row) (for (from currow cursor-row (- row 1) 1) (do (out-char LF)) )) % move down (T (for (from currow cursor-row (+ row 1) -1) (do (out-char (CONTROL K))) )) ) % move up ))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (televideo enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (televideo leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (televideo erase) () % This method should be invoked to initialize the screen to a known state. (out-chars (CONTROL !^) ESC !*) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (televideo clear-line) () (out-chars ESC (LOWER T)) ) (defmethod (televideo convert-character) (ch) (setf ch (& ch (display-character-cons % no enhancements supporeted (dc-make-enhancement-mask % INVERSE-VIDEO BLINK UNDERLINE INTENSIFY ) % only font number 0 supported (dc-make-font-mask 0) % only 7 bit chars 16#7F))) (let ((code (dc-character-code ch))) % replace non-printable chars with a space (when (or (< code 8#40) (= code (char rubout))) (setf ch terminal-blank))) ch) (defmethod (televideo normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (televideo highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (televideo supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (televideo update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % this check prevents index of -1, and also avoids cursor movement % when the line doesn't need to be changed (when (<= first-col last-col) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (when (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self move-cursor row col) (=> self &print-char new-code) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self move-cursor row (+ last-nonblank-column 1)) (=> self clear-line) ) ))) % The following methods are provided for INTERNAL use only! % This method outputs a printable character % (should we check that the character is printable?) (defmethod (televideo &print-char) (ch) (cond ((< cursor-column maxcol) % normal case (PBOUT ch) (setf cursor-column (+ cursor-column 1))) ((< cursor-row maxrow) % last character on a line, but not last line % This horrendous hack assures that we have auto-wrap (PBOUT ch) (setf cursor-row (+ cursor-row 1)) (setf cursor-column 0) (cond ((eq auto-wrap 'NO) (out-chars CR LF)) ((eq auto-wrap 'MAYBE) (out-move cursor-row 0)) % ((eq auto-wrap 'YES) ) )) (T % Bottom right corner % Prevent scrolling (put blank there if we can't print). Move to (0,0). (IF (or (eq auto-scroll 'YES) (eq auto-scroll 'MAYBE)) % THEN (=> self clear-line) % ELSE (eq auto-scroll 'NO) so (PBOUT ch)) (=> self move-cursor 0 0) ) )) (defmethod (televideo &set-terminal-enhancement) (enh) (setf terminal-enhancement 0) ) |
Added psl-1983/3-1/clsc-20/vt52nx.b version [9f48d50bed].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/vt52nx.sl version [24881d3e52].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % VT52NX -- Non extended VT52 interface % Lon Willett, 6-Jul-83 % Based on file: % % TELERAY.SL % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (BothTimes (load JSYS)) (compiletime (progn (defconst !.MORLW 8#30 % read page width !.MORLL 8#32 % read page length !.PRIOU 8#101) % primary output jfn, it had better be a TTY % NOTE: since I/O is done with PBIN/PBOUT, using the primary JFN should % be ok. This really ought to be written to use an arbitrary JFN. (ds get-system-page-height () (jsys3 (const !.priou) (const !.morll) 0 0 (const jsMTOPR)) ) (ds get-system-line-length () (jsys3 (const !.priou) (const !.morlw) 0 0 (const jsMTOPR)) ) )) (defflavor vt52nx ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (auto-wrap 'MAYBE) % does a CRLF when output to last column: YES NO MAYBE (auto-scroll 'YES) % scrolls when output to (MAXROW,MAXCOL): YES NO MAYBE (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width auto-wrap auto-scroll maxrow maxcol raw-mode) (initable-instance-variables height width auto-wrap auto-scroll) ) (defmethod (vt52nx init) (initlis) % Pick up the page length & width from the monitor if it is not % specified by an initialization argument. Use default if we don't like % what the monitor claims. % HEIGHT & MAXROW: (unless (memq 'HEIGHT initlis) (setf height (get-system-page-height))) (when (or (< height 10) (> height 96)) (setf height 24)) (setf maxrow (- height 1)) % WIDTH & MAXCOL: (unless (memq 'WIDTH initlis) (setf width (get-system-line-length))) (when (or (< width 10) (> width 96)) (setf width 80)) (setf maxcol (- width 1)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (vt52nx get-character) () (& (PBIN) 8#177) ) (defmethod (vt52nx ring-bell) () (out-char BELL) ) (defmethod (vt52nx move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (=> self &move-cursor row column nil nil) ) (defmethod (vt52nx enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (vt52nx leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (vt52nx erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (vt52nx clear-line) () (out-chars ESC K) ) (defmethod (vt52nx convert-character) (ch) (setf ch (& ch (display-character-cons % no enhancements supporeted (dc-make-enhancement-mask % INVERSE-VIDEO BLINK UNDERLINE INTENSIFY ) % only font number 0 supported (dc-make-font-mask 0) % only 7 bit chars 16#7F))) (let ((code (dc-character-code ch))) % replace non-printable chars with a space (when (or (< code 8#40) (= code (char rubout))) (setf ch terminal-blank))) ch) (defmethod (vt52nx normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (vt52nx highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (vt52nx supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (vt52nx update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % this check prevents unchecked index of -1, and also keeps % us from moving the cursor when the line doesn't need to be updated (when (<= first-col last-col) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (when (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor row col row old-line) (=> self &print-char new-code) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor row (+ last-nonblank-column 1) row old-line) (=> self clear-line) ) ))) % The following methods are provided for INTERNAL use only! % This method outputs a printable character % (should we check that the character is printable?) (defmethod (vt52nx &print-char) (ch) (cond ((< cursor-column maxcol) % normal case (PBOUT ch) (setf cursor-column (+ cursor-column 1))) ((< cursor-row maxrow) % last character on a line, but not last line % This horrendous hack assures that we have auto-wrap (PBOUT ch) (setf cursor-row (+ cursor-row 1)) (setf cursor-column 0) (cond ((eq auto-wrap 'NO) (out-chars CR LF)) ((eq auto-wrap 'MAYBE) (out-move cursor-row 0)) % ((eq auto-wrap 'YES) ) )) (T % Bottom right corner % Prevent scrolling (put blank there if we can't print). Move to (0,0). (IF (or (eq auto-scroll 'YES) (eq auto-scroll 'MAYBE)) % THEN (=> self clear-line) % ELSE (eq auto-scroll 'NO) so (PBOUT ch)) (=> self move-cursor 0 0) ) )) (defmethod (vt52nx &move-cursor) (row column known-row-number known-row) % (ROW COLUMN) is the point we want to move to % KNOWN-ROW-NUMBER is the number of a row whose characters are known, or % NIL if we don't have a row. % KNOWN-ROW is a the vector of chars in KNOWN-ROW-NUMBER (let* ((need-to-use-known-line-flag NIL) (relative-move-number-of-chars (+ % vertical move (cond ((< cursor-row row) (- row cursor-row)) % 1 char to move down ((> cursor-row row) (* 2 (- cursor-row row))) % 2 to move up (T 0)) % else no vertical move necessary % horizontal move (cond ((= cursor-column column) 0) % no horizontal move necessary ((= column 0) 1) % move to left column ((> cursor-column column) (- cursor-column column)) % 1 char / move left ((and known-row-number (let (minumumrow maximumrow) (if (< row cursor-row) (setf minumumrow row maximumrow cursor-row) (setf minumumrow cursor-row maximumrow row)) (and (<= known-row-number maximumrow) (>= known-row-number minumumrow)) )) (setf need-to-use-known-line-flag T) (- column cursor-column)) % can reprint chars, 1/move right (T (* 2 (- column cursor-column))) ) % 2 chars/move right ))) (cond ((= relative-move-number-of-chars 0) ) % no move needed ((and (= row 0) (= column 0) (>= relative-move-number-of-chars 2)) (out-chars ESC H)) % cursor HOME ((>= relative-move-number-of-chars 4) (out-move row column)) % move absolute (T % move relative (cond ((= cursor-column column) ) % no horizontal move needed ((= column 0) (out-char CR)) % move to left-most column ((> cursor-column column) (for (from junk cursor-column (+ column 1) -1) (do (out-char BACKSPACE)) )) % move left ((not need-to-use-known-line-flag) (for (from junk cursor-column (- column 1) 1) (do (out-chars ESC C)) )) % move right (T (while (> cursor-row known-row-number) (out-chars ESC A) % move up (setf cursor-row (- cursor-row 1)) ) (while (< cursor-row known-row-number) (out-char LF) % move down (setf cursor-row (+ cursor-row 1)) ) (for (from col cursor-column (- column 1)) (do (PBOUT (vector-fetch known-row col))) )) ) % now take care of the vertical move (cond ((= cursor-row row) ) % no move needed ((< cursor-row row) (for (from junk cursor-row (- row 1) 1) (do (out-char LF)) )) % move down (T (for (from junk cursor-row (+ row 1) -1) (do (out-chars ESC A)) )) ) % move up ))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (vt52nx &set-terminal-enhancement) (enh) (setf terminal-enhancement 0) ) |
Added psl-1983/3-1/clsc-20/windows-20.b version [3d048c687d].
cannot compute difference between binary files
Added psl-1983/3-1/clsc-20/windows-ex-20.sl version [9b56b57b4b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WINDOWS-20.SL - Dec-20 Windows Stuff (intended only for Dec-20 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 April 1983 % % 15-Jun-83 - Robert Kessler % Added faslin of the 3 new device drivers: VT100, Ambassador and Teleray % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int)) (bothtimes (load strings common)) (fluid '(window-file-list window-source-prefix window-binary-prefix)) (if (or (unboundp 'window-source-prefix) (null window-source-prefix)) (setf window-source-prefix "pw:")) (if (or (unboundp 'window-binary-prefix) (null window-binary-prefix)) (setf window-binary-prefix "pwb:")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building WINDOWS: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-fixup-name (s) s) (de window-load-all () (for (in s window-file-list) (do (window-load s)) )) (de window-load (s) (window-faslin window-binary-prefix s) ) (de window-faslin (directory-name module-name) (setf module-name (window-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf window-file-list (list "ambassador" "hp2648a" "physical-screen" "shared-physical-screen" "teleray" "virtual-screen" "vt100" "vt52x" )) |
Added psl-1983/3-1/comp/20/data-machine.red version [65320911d4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DATA-MACHINE.RED - Macros for fast access to data structures % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 April 1982 % Copyright (c) 1982 University of Utah % % 22-May-83 Mark R. Swanson % Added Mid-range tags (for extended addressing-20. % <PSL.COMP>DATA-MACHINE.RED.13, 30-Mar-83 11:03:57, Edit by KENDZIERSKI % Included the text from data-machine.build at the beginning of this file. % The file names w/extensions were getting too large for the VAX to deal with. % <PERDUE.PSL>DATA-MACHINE.RED.3, 28-Feb-83 12:28:57, Edit by PERDUE % Added nasty comments and proposed changes % <PSL.COMP>DATA-MACHINE.RED.10, 10-Jan-83 16:31:31, Edit by PERDUE % Added PutEvecLen for EVectors; this had been omitted % Edit by GRISS, 3Nov: Added missing EVEC operations % Primitives handled by the compiler are BYTE, PUTBYTE, GETMEM, PUTMEM, % MKITEM, FIELD, SIGNEDFIELD, PUTFIELD, HALFWORD, PUYTHALFWORD CompileTime << load if!-system, syslisp; % Assume still there, else load source off UserMode; >>; in "wdeclare.red"$ CompileTime if_system(PDP10, << in "P20C:DEC20-DATA-MACHINE.RED"$ >>)$ CompileTime if_system(Dec20, << in "P20C:DEC20-DATA-MACHINE.RED"$ >>)$ CompileTime if_system(ExtDec20, << in "P20eC:DEC20-DATA-MACHINE.RED"$ >>)$ CompileTime if_system(VAX, << in "vax/vax-data-machine.red"$ >>)$ CompileTime if_system(HP9836, << in "phpc:hp-data-machine.red"$ >>)$ on Syslisp; off R2I; % These definitions are for interpretive testing of Syslisp code. % They may be dangerous in some cases. CommentOutCode << syslsp procedure Byte(WAddr, ByteOffset); Byte(WAddr, ByteOffset); syslsp procedure PutByte(WAddr, ByteOffset, Val); PutByte(WAddr, ByteOffset, Val); syslsp procedure Halfword(WAddr, HalfwordOffset); Halfword(WAddr, HalfwordOffset); syslsp procedure PutHalfword(WAddr, HalfwordOffset, Val); PutHalfword(WAddr, HalfwordOffset, Val); syslsp procedure GetMem Addr; GetMem Addr; syslsp procedure PutMem(Addr, Val); PutMem(Addr, Val); syslsp procedure MkItem(TagPart, InfPart); MkItem(TagPart, InfPart); CommentOutCode << % can't do FIELD w/ non constants syslsp procedure Field(Cell, StartingBit, BitLength); Field(Cell, StartingBit, BitLength); syslsp procedure SignedField(Cell, StartingBit, BitLength); SignedField(Cell, StartingBit, BitLength); syslsp procedure PutField(Cell, StartingBit, BitLength, Val); PutField(Cell, StartingBit, BitLength, Val); >>; syslsp procedure WPlus2(R1, R2); WPlus2(R1, R2); syslsp procedure WDifference(R1, R2); WDifference(R1, R2); syslsp procedure WTimes2(R1, R2); WTimes2(R1, R2); syslsp procedure WQuotient(R1, R2); WQuotient(R1, R2); syslsp procedure WRemainder(R1, R2); WRemainder(R1, R2); syslsp procedure WMinus R1; WMinus R1; syslsp procedure WShift(R1, R2); WShift(R1, R2); syslsp procedure WAnd(R1, R2); WAnd(R1, R2); syslsp procedure WOr(R1, R2); WOr(R1, R2); syslsp procedure WXor(R1, R2); WXor(R1, R2); syslsp procedure WNot R1; WNot R1; syslsp procedure WLessP(R1, R2); WLessP(R1, R2); syslsp procedure WGreaterP(R1, R2); WGreaterP(R1, R2); syslsp procedure WLEQ(R1, R2); WLEQ(R1, R2); syslsp procedure WGEQ(R1, R2); WGEQ(R1, R2); >>; on R2I; off Syslisp; % SysLisp array accessing primitives syslsp macro procedure WGetV U; list('GetMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem)))); syslsp macro procedure WPutV U; list('PutMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem))), cadddr U); % tags CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure MidTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst) - 1) -2, -1); macro procedure HighTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst)) - 1, -1); >>; % JumpInType and friends depend on the ordering and contiguity of % the numeric type tags. Fast arithmetic depends on PosInt = 0, % NegInt = -1. Garbage collectors depend on pointer tags being % between PosInt and Code, non-inclusive. /csp LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair, Evect); put('Code, 'WConst, 15); % Extended addressing treats negative word (one with aits high-order bit % on) as a local address--hence pointer types must have (positive) MidTags MidTags( ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); HighTags(NegInt); % Item constructor macros lisp procedure MakeItemConstructor(TagPart, InfPart); list('MkItem, TagPart, InfPart); syslsp macro procedure MkBTR U; MakeItemConstructor('(wconst BtrTag), cadr U); syslsp macro procedure MkID U; MakeItemConstructor('(wconst ID), cadr U); syslsp macro procedure MkFIXN U; MakeItemConstructor('(wconst FIXN), cadr U); syslsp macro procedure MkFLTN U; MakeItemConstructor('(wconst FLTN), cadr U); syslsp macro procedure MkBIGN U; MakeItemConstructor('(wconst BIGN), cadr U); syslsp macro procedure MkPAIR U; MakeItemConstructor('(wconst PAIR), cadr U); syslsp macro procedure MkVEC U; MakeItemConstructor('(wconst VECT), cadr U); syslsp macro procedure MkEVECT U; MakeItemConstructor('(wconst EVECT), cadr U); syslsp macro procedure MkWRDS U; MakeItemConstructor('(wconst WRDS), cadr U); syslsp macro procedure MkSTR U; MakeItemConstructor('(wconst STR), cadr U); syslsp macro procedure MkBYTES U; MakeItemConstructor('(wconst BYTES), cadr U); syslsp macro procedure MkHalfWords U; MakeItemConstructor('(wconst HalfWords), cadr U); syslsp macro procedure MkCODE U; MakeItemConstructor('(wconst CODE), cadr U); % Access to tag (type indicator) of Lisp item in ordinary code syslsp macro procedure Tag U; list('Field, cadr U, '(wconst TagStartingBit), '(wconst TagBitLength)); % Access to info field of item (pointer or immediate operand) syslsp macro procedure Inf U; list('Field, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength)); syslsp macro procedure PutInf U; list('PutField, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength), caddr U); for each X in '(IDInf StrInf VecInf EvecInf PairInf WrdInf HalfWordInf CodeInf FixInf FltInf BigInf) do PutD(X, 'Macro, cdr getd 'Inf); for each X in '(PutIDInf PutStrInf PutVecInf PutPairInf PutWrdInf PutHalfWordInf PutEvecInf PutFixInf PutFltInf PutBigInf) do PutD(X, 'Macro, cdr getd 'PutInf); % IntInf is no longer needed, will be a macro no-op % for the time being RemProp('IntInf, 'OpenFn); macro procedure IntInf U; cadr U; % Similarly for MkINT macro procedure MkINT U; cadr U; % # of words in a pair syslsp macro procedure PairPack U; 2; % length (in characters, words, etc.) of a string, vector, or whatever, % stored in the first word pointed to syslsp macro procedure GetLen U; list('SignedField, list('GetMem, cadr U), '(WConst InfStartingBit), '(WConst InfBitLength)); syslsp macro procedure StrBase U; % point to chars of string list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); % chars string length --> words string length % Don't add 1 in this! (Put change in at some reasonable time.) % Actually need space for extra null, but magic constant to add % to determine number of words needed is CharsPerWord-1, so all % cancels out. /csp 2-28-83 syslsp macro procedure StrPack U; list('WQuotient, list('WPlus2, cadr U, list('WPlus2, '(WConst CharactersPerWord), 1)), '(WConst CharactersPerWord)); % access to bytes of string; skip first word syslsp macro procedure StrByt U; list('Byte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutStrByt U; list('PutByte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % access to halfword entries; skip first word syslsp macro procedure HalfWordItm U; list('HalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutHalfWordItm U; list('PutHalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % halfword length --> words length % Should add 1 before shift! /csp 2-28-83 syslsp macro procedure HalfWordPack U; list('WPlus2, list('WShift, cadr U, -1), 1); % length (in Item size quantities) of Lisp vectors % size of Lisp vector in words % Adding 1 not needed for GtVect! /csp 2-28-83 syslsp macro procedure VectPack U; list('WPlus2, cadr U, 1); % size of Lisp Evector in words % See comment above! /csp syslsp macro procedure EVectPack U; list('WPlus2, cadr U, 1); % access to elements of Lisp vector syslsp macro procedure VecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % access to elements of Lisp Evector syslsp macro procedure EVecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutEVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % Wrd is like Vect, but not traced by the garbage collector % See comment for VectPack, above! /csp 2-28-83 syslsp macro procedure WrdPack U; list('WPlus2, cadr U, 1); for each X in '(StrLen ByteLen VecLen EVecLen WrdLen HalfWordLen) do PutD(X, 'Macro, cdr getd 'GetLen); PutD('WrdItm, 'Macro, cdr GetD 'VecItm); PutD('PutWrdItm, 'Macro, cdr GetD 'PutVecItm); % So what about FixPack and FloatPack, turkeys? /csp 2-28-83 syslsp macro procedure FixVal U; list('WGetV, cadr U, 1); syslsp macro procedure PutFixVal U; list('WPutV, cadr U, 1, caddr U); syslsp macro procedure FloatBase U; list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); syslsp macro procedure FloatHighOrder U; list('WGetV, cadr U, 1); syslsp macro procedure FloatLowOrder U; list('WGetV, cadr U, 2); % New addition: A code pointer can have the number of arguments it expects % stored in the word just before the entry syslsp macro procedure !%code!-number!-of!-arguments U; list('WGetV, cadr U, -1); % The four basic cells for each symbol: Val, Nam, Fnc, Prp, corresponding to % variable value, symbol name (as string), function cell (jump to compiled % code or lambda linker) and property list (pairs for PUT, GET, atoms for FLAG, % FLAGP). These are currently 4 separate arrays, but this representation may % be changed to a contiguous 4 element record for each symbol or something else % and therefore should not be accessed as arrays. syslsp macro procedure SymVal U; list('WGetV, '(WConst SymVal), cadr U); syslsp macro procedure PutSymVal U; list('WPutV, '(WConst SymVal), cadr U, caddr U); syslsp macro procedure LispVar U; % Access value cell by name list('(WConst SymVal), list('IDLoc, cadr U)); syslsp macro procedure PutLispVar U; list('PutSymVal, list('IDLoc, cadr U), caddr U); syslsp macro procedure SymNam U; list('WGetV, '(WConst SymNam), cadr U); syslsp macro procedure PutSymNam U; list('WPutV, '(WConst SymNam), cadr U, caddr U); % Retrieve the address stored in the function cell % SymFnc and PutSymFnc are not defined portably syslsp macro procedure SymPrp U; list('WGetV, '(WConst SymPrp), cadr U); syslsp macro procedure PutSymPrp U; list('WPutV, '(WConst SymPrp), cadr U, caddr U); % Binding stack primitives syslsp macro procedure BndStkID U; list('WGetV, cadr U, -1); syslsp macro procedure PutBndStkID U; list('WPutV, cadr U, -1, caddr U); syslsp macro procedure BndStkVal U; list('GetMem, cadr U); syslsp macro procedure PutBndStkVal U; list('PutMem, cadr U, caddr U); syslsp macro procedure AdjustBndStkPtr U; list('WPlus2, cadr U, list('WTimes2, caddr U, list('WTimes2, '(WConst AddressingUnitsPerItem), 2))); % ObArray is a linearly allocated hash table containing ID numbers of entries % maintained as a circular buffer. It is referenced only via these macros % because we may decide to change to some other representation. syslsp smacro procedure ObArray I; HalfWord(HashTable, I); syslsp smacro procedure PutObArray(I, X); HalfWord(HashTable, I) := X; put('ObArray, 'Assign!-Op, 'PutObArray); syslsp smacro procedure OccupiedSlot U; ObArray U > 0; DefList('((GetMem PutMem) (Field PutField) (Byte PutByte) (HalfWord PutHalfWord) (Tag PutTag) (Inf PutInf) (IDInf PutIDInf) (StrInf PutStrInf) (VecInf PutVecInf) (EVecInf PutEVecInf) (WrdInf PutWrdInf) (PairInf PutPairInf) (FixInf PutFixInf) (FixVal PutFixVal) (FltInf PutFltInf) (BigInf PutBigInf) (StrLen PutStrLen) (StrByt PutStrByt) (VecLen PutVecLen) (EVecLen PutEvecLen) (VecItm PutVecItm) (EVecItm PutEVecItm) (WrdLen PutWrdLen) (WrdItm PutWrdItm) (SymVal PutSymVal) (LispVar PutLispVar) (SymNam PutSymNam) (SymFnc PutSymFnc) (SymPrp PutSymPrp) (BndStkID PutBndStkID) (BndStkVal PutBndStkVal)), 'Assign!-Op); % This is redefined for the HP 9836 to cure the high-order FF problem macro procedure !%chipmunk!-kludge x; cadr x; END; |
Added psl-1983/3-1/comp/20/dec20-asm.build version [577bae59e5].
> > > > > > | 1 2 3 4 5 6 | CompileTime << load If!-System; load SysLisp; off UserMode; >>; in "DEC20-ASM.RED"$ |
Added psl-1983/3-1/comp/20/dec20-asm.ctl version [9b0b8e2928].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ; Rebuild the ASM module @def dsk: dsk:,p20ec:,p20c:,pc: @def pl: ple: @term page 0 @get psl:ex-rlisp @st *load build; *build "DEC20-ASM"; *quit; @reset . @term page 24 |
Added psl-1983/3-1/comp/20/dec20-asm.red version [8404f9fd09].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 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 % % 21-May-83 Mark R. Swanson % Added changes to support extended addressing. % <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 IndWordFormat!*:= " IFIW %e%n"; % For extended addressing. 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('MkItem2, 'ASMExpressionFormat, "<%e_30>+<%e_18>+%e"); put('MkItem1, 'ASMExpressionFormat, "<%e_30>+%e"); put('MkItem, 'ASMExpressionFunction, 'ASMPseudoMkItem); lisp procedure ASMPseudoMkItem U; % % (MkItem Tag Inf) % if (second U) > 0 and (second U) < 15 % PointerTagP then % use a format that generates a global address PrintExpression List('MkItem2, second U, 1, third U) % force section % # to 1 else PrintExpression List('MkItem1, second U, third U); lisp procedure CodeFileHeader(); CodePrintF " search monsym,macsym%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(); % % "Hardwire" HEAPs into sections 2 & 4; code modifies self to avoid % recreating sections on re-entry. <<DataPrintF(" intern HEAP%n HEAP=2,,0%n"); DataPrintF(" intern HEAP2%n HEAP2=4,,0%n"); CodePrintF " intern MAIN.%nMAIN.:"; CodePrintF " reset%% %n"; CodePrintF " setzm 1%n"; % initially create sections 2,3,4 CodePrintF " move 2,[.fhslf,,2]%n"; CodePrintF " move 3,[140000,,3]%n"; CodePrintF "smap.: smap%%%n"; CodePrintF " move 1,[jfcl]%n"; % make sure it only happens once CodePrintF " movem 1,smap.%n";>>; % by stuffing a NOOP instruction 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",x); procedure !*cerror x; begin scalar i; i:=wrs Nil; printf( "%n *** CERROR: %r %n ",x); wrs i; return list list('cerror,x); end; put('cerror,'asmpseudoop,'printcomment); DefCmacro !*cerror; END; |
Added psl-1983/3-1/comp/20/dec20-cmac.build version [cccca0b271].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | CompileTime << on EolInStringOK; macro procedure !* U; NIL; flag('(TagNumber InumP), 'lose); >>; imports '(dec20-comp); in "p20ec:tags.red"$ in "dec20-cmac.sl"$ |
Added psl-1983/3-1/comp/20/dec20-cmac.ctl version [f20d16e319].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ; Rebuild the CMAC module @term page 0 @def dsk: dsk:,p20ec:,p20c: @def pl: ple: @get psl:ex-rlisp @st *load build; *build "DEC20-CMAC"; *quit; @reset . @term page 24 |
Added psl-1983/3-1/comp/20/dec20-cmac.sl version [3cf19f4047].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-CMAC.SL - Patterns and predicates for Dec-20 PSL cmacro expansion % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 January 1982 % Copyright (c) 1982 University of Utah % % 21-May-83 Mark R. Swanson % Adapted for Extended addressing on -20. Added IdTagP test to *MkItem to % optimize ID cases. % <PSL.20-COMP>20-CMAC.SL.1, 21 October 1982, Griss % Fixed foreign function for CROSS compiler % <PSL.20-COMP>20-CMAC.SL.1, 24-Feb-82 12:08:45, Edit by BENSON % Adapted VAX version for Dec-20 (fluid '(AddressingUnitsPerItem CharactersPerWord StackDirection !*ImmediateQuote AddressingUnitsPerFunctionCell)) (setq AddressingUnitsPerItem 1) (setq CharactersPerWord 5) (setq AddressingUnitsPerFunctionCell 1) (setq StackDirection 1) (setq !*ImmediateQuote NIL) (ds BitMask (Start End) (land (lsh -1 (minus Start)) (lsh -1 (difference 35 End)))) (dm Bit (U) (progn (setq U (cdr U)) (cond ((null U) 0) (t (ExpandBit U))))) (de ExpandBit (U) (cond ((null (cdr U)) (list 'lsh 1 (list 'difference 35 (car U)))) (t (list 'lor (list 'lsh 1 (list 'difference 35 (car U))) (ExpandBit (cdr U)))))) % "InumP tells what numbers can be immediate operands on the target machine." (de InumP (Expression) (and (FixP Expression) (leq Expression 8#777777) (geq Expression (minus 8#1000000)))) (de TagNumber (X) (cond ((IDP X) (get 'ID 'WConst)) ((PairP X) (get 'PAIR 'WConst)) ((StringP X) (get 'STR 'WConst)) ((InumP X) (cond ((MinusP X) 63) (t 0))) ((CodeP X) (get 'CODE 'WConst)) ((FloatP X) (get 'FltN 'WConst)) ((VectorP X) (get 'VECT 'WConst)) ((FixP X) (get 'FixN 'WConst)))) (de IdTagP (X) (and (ImmediateP X) (eq X (get 'ID 'WConst)))) (de ImmediateP (X) (or (EqCar X 'Immediate) (and (FixP X) (leq X 8#777777) (geq X (minus 8#777777))))) (de AddrExpressionP (X) (and (EqCar x 'Immediate) (Null (FixP (cadr x))))) (de MemoryP (X) (not (ImmediateP X))) (de NegativeImmediateP (X) (and (FixP X) (MinusP X) (geq X (minus 8#777777)))) (de SixP (X) (equal X 6)) (de SevenP (X) (equal X 7)) (de TwelveP (X) (equal X 12)) (de EighteenP (X) (equal X 18)) (de TwentyFourP (X) (equal X 24)) (de ThirtyP (X) (equal X 30)) (de NonIndirectP (Expression) (not (EqCar Expression 'Indirect))) (de FakeRegisterNumberP (Expression) (and (IntP Expression) (GreaterP Expression 5))) % "Leave Indexed and Indirect alone in recursive c-macro" (flag '(Indexed Indirect UnImmediate) 'TerminalOperand) (DefAnyreg CAR AnyregCAR ((RegisterP) (Indexed SOURCE 0)) ((move REGISTER SOURCE) (Indexed REGISTER 0))) (DefAnyreg CDR AnyregCDR ((RegisterP) (Indexed SOURCE 1)) ((move REGISTER SOURCE) (Indexed REGISTER 1))) (DefAnyreg QUOTE AnyregQUOTE ((Null) (REG NIL)) ((EqTP) (FLUID T)) ((InumP) SOURCE) ((QUOTE SOURCE))) (DefAnyreg WVAR AnyregWVAR ((RegisterNameP) (REG SOURCE)) ((WVAR SOURCE))) (DefAnyreg MEMORY AnyregMEMORY ((RegisterP AnyP) (Indexed SOURCE ARGTWO)) ((AddressConstantP ZeroP) (UnImmediate SOURCE)) ((!*MOVE SOURCE REGISTER) (Indexed REGISTER ARGTWO))) (DefAnyreg FRAME AnyregFRAME ((Indexed (REG st) SOURCE))) (DefAnyreg REG AnyregREG ((FakeRegisterNumberP) (ExtraReg SOURCE)) ((REG SOURCE))) (DefCMacro !*Call ((InternallyCallableP) (pushj (reg st) (InternalEntry ARGONE))) ((pushj (reg st) (Entry ARGONE)))) (DefCMacro !*JCall ((InternallyCallableP) (jrst (InternalEntry ARGONE))) ((jrst (Entry ARGONE)))) (DefCMacro !*Move (Equal) ((ZeroP AnyP) (setzm ARGTWO)) ((MinusOneP AnyP) (setom ARGTWO)) ((NegativeImmediateP RegisterP) (movni ARGTWO (minus ARGONE))) ((AddrExpressionP RegisterP) (xmovei ARGTWO ARGONE)) ((ImmediateP RegisterP) (hrrzi ARGTWO ARGONE)) ((AnyP RegisterP) (move ARGTWO ARGONE)) ((RegisterP AnyP) (movem ARGONE ARGTWO)) ((!*MOVE ARGONE (reg t1)) (movem (reg t1) ARGTWO))) (DefCMacro !*Alloc ((ZeroP)) ((adjsp (REG st) ARGONE))) (DefCMacro !*DeAlloc ((ZeroP)) ((adjsp (REG st) (minus ARGONE)))) (DefCMacro !*Exit ((!*DeAlloc ARGONE) (popj (reg st) 0))) (DefCMacro !*Jump ((jrst ARGONE))) (DefCMacro !*Lbl (ARGONE)) (DefCMacro !*WPlus2 ((AnyP OneP) (aos ARGONE)) ((AnyP MinusOneP) (sos ARGONE)) ((AnyP RegisterP) (addm ARGTWO ARGONE)) ((RegisterP NegativeImmediateP) (subi ARGONE (minus ARGTWO))) ((RegisterP ImmediateP) (addi ARGONE ARGTWO)) ((RegisterP AnyP) (add ARGONE ARGTWO)) ((!*MOVE ARGTWO (reg t2)) (addm (reg t2) ARGONE))) (DefCMacro !*WDifference ((AnyP OneP) (sos ARGONE)) ((AnyP MinusOneP) (aos ARGONE)) ((RegisterP NegativeImmediateP) (addi ARGONE (minus ARGTWO))) ((RegisterP ImmediateP) (subi ARGONE ARGTWO)) ((RegisterP AnyP) (sub ARGONE ARGTWO)) ((!*WMINUS (reg t2) ARGTWO) (addm (reg t2) ARGONE))) (DefCMacro !*WTimes2 ((AnyP MinusOneP) (!*WMINUS ARGONE ARGONE)) ((RegisterP NegativeImmediateP) (imul ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (imuli ARGONE ARGTWO)) ((RegisterP AnyP) (imul ARGONE ARGTWO)) ((AnyP RegisterP) (imulm ARGTWO ARGONE)) ((!*MOVE ARGTWO (reg t2)) (imulm (reg t2) ARGONE))) (DefCMacro !*WAnd ((RegisterP NegativeImmediateP) (and ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (andi ARGONE ARGTWO)) ((RegisterP AnyP) (and ARGONE ARGTWO)) ((AnyP RegisterP) (andm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (andm (reg t2) ARGONE))) (DefCMacro !*WOr ((RegisterP NegativeImmediateP) (ior ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (iori ARGONE ARGTWO)) ((RegisterP AnyP) (ior ARGONE ARGTWO)) ((AnyP RegisterP) (iorm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (iorm (reg t2) ARGONE))) (DefCMacro !*WXOr ((RegisterP NegativeImmediateP) (xor ARGONE (lit (fullword ARGTWO)))) ((RegisterP ImmediateP) (xori ARGONE ARGTWO)) ((RegisterP AnyP) (xor ARGONE ARGTWO)) ((AnyP RegisterP) (xorm ARGTWO ARGONE)) ((!*MOVE (reg t2) ARGTWO) (xorm (reg t2) ARGONE))) (DefCMacro !*AShift ((RegisterP ImmediateP) (ash ARGONE ARGTWO)) ((RegisterP RegisterP) (ash ARGONE (Indexed ARGTWO 0))) ((RegisterP AnyP) (move (reg t2) ARGTWO) (ash ARGONE (Indexed (reg t2) 0))) ((AnyP ImmediateP) (move (reg t3) ARGONE) (ash (reg t3) ARGTWO) (movem (reg t3) ARGONE)) ((AnyP RegisterP) (move (reg t3) ARGONE) (ash (reg t3) (Indexed ARGTWO 0)) (movem (reg t3) ARGONE)) ((move (reg t2) ARGTWO) (move (reg t3) ARGONE) (ash (reg t3) (Indexed (reg t2) 0)) (movem (reg t3) ARGONE))) (DefCMacro !*WShift ((RegisterP ImmediateP) (lsh ARGONE ARGTWO)) ((RegisterP RegisterP) (lsh ARGONE (Indexed ARGTWO 0))) ((RegisterP AnyP) (move (reg t2) ARGTWO) (lsh ARGONE (Indexed (reg t2) 0))) ((AnyP ImmediateP) (move (reg t3) ARGONE) (lsh (reg t3) ARGTWO) (movem (reg t3) ARGONE)) ((AnyP RegisterP) (move (reg t3) ARGONE) (lsh (reg t3) (Indexed ARGTWO 0)) (movem (reg t3) ARGONE)) ((move (reg t2) ARGTWO) (move (reg t3) ARGONE) (lsh (reg t3) (Indexed (reg t2) 0)) (movem (reg t3) ARGONE))) (DefCMacro !*WNot (Equal (setcmm ARGONE)) ((RegisterP AnyP) (setcm ARGONE ARGTWO)) ((AnyP RegisterP) (setcam ARGTWO ARGONE)) ((move (reg t1) ARGTWO) (setcam (reg t1) ARGONE))) (DefCMacro !*WMinus (Equal (movns ARGONE)) ((RegisterP AnyP) (movn ARGONE ARGTWO)) ((AnyP RegisterP) (movnm ARGTWO ARGONE)) ((move (reg t1) ARGTWO) (movnm (reg t1) ARGONE))) (DefCMacro !*MkItem ((RegisterP IdTagP) % assume ID numbers never slop into left half (hrli ARGONE (lsh ARGTWO 12))) ((RegisterP ImmediateP) (tlz ARGONE 8#770000) (tlo ARGONE (lsh ARGTWO 12))) ((RegisterP RegisterP) (dpb ARGTWO (lit (fullword (FieldPointer ARGONE 0 6))))) ((Registerp Anyp) (!*MOVE ARGTWO (reg t1)) (dpb (reg t1) (lit (fullword (FieldPointer ARGONE 0 6))))) ((AnyP RegisterP) (!*MOVE ARGONE (reg t2)) (dpb ARGTWO (lit (fullword (FieldPointer (reg t2) 0 6)))) (!*MOVE (reg t2) ARGONE)) ((!*MOVE ARGONE (reg t2)) (!*MOVE ARGTWO (reg t1)) (dpb (reg t1) (lit (fullword (FieldPointer (reg t2) 0 6)))) (!*MOVE (reg t2) ARGONE))) (DefCMacro !*JumpType ((RegisterP ZeroP) (tlnn ARGONE 8#770000) (jrst ARGTHREE)) ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 6)))) (!*JUMPEQ ARGTHREE (reg t6) ARGTWO))) (DefCMacro !*JumpNotType ((RegisterP ZeroP) (tlne ARGONE 8#770000) (jrst ARGTHREE)) ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 6)))) (!*JUMPNOTEQ ARGTHREE (reg t6) ARGTWO))) (DefCMacro !*JumpInType ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 6)))) (caig (reg t6) ARGTWO) (jrst ARGTHREE) (cain (reg t6) 63) (jrst ARGTHREE))) % (WConst NegInt) (DefCMacro !*JumpNotInType ((ldb (reg t6) (lit (fullword (FieldPointer ARGONE 0 6)))) (cain (reg t6) 63) % (WConst NegInt) (jrst TEMPLABEL) (caile (reg t6) ARGTWO) (jrst ARGTHREE) TEMPLABEL)) (DefCMacro !*JumpEQ ((RegisterP ZeroP) (jumpe ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpe ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipn ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipn ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camn ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camn ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (cain ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (cain ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camn ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camn ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpNotEQ ((RegisterP ZeroP) (jumpn ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpn ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipe ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipe ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (came ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (came ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caie ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caie ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (came ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (came ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPNOTEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPNOTEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWLessP ((RegisterP ZeroP) (jumpl ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpg ARGTWO ARGTHREE)) ((RegisterP OneP) (jumple ARGONE ARGTHREE)) ((MinusOneP RegisterP) (jumpge ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipge ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skiple ARGTWO) (jrst ARGTHREE)) ((AnyP OneP) (skipg ARGONE) (jrst ARGTHREE)) ((MinusOneP AnyP) (skipl ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camge ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camle ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caige ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caile ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camge ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camle ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWLESSP ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWLESSP ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWGreaterP ((RegisterP ZeroP) (jumpg ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpl ARGTWO ARGTHREE)) ((RegisterP MinusOneP) (jumpge ARGONE ARGTHREE)) ((OneP RegisterP) (jumple ARGTWO ARGTHREE)) ((AnyP ZeroP) (skiple ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipge ARGTWO) (jrst ARGTHREE)) ((AnyP MinusOneP) (skipl ARGONE) (jrst ARGTHREE)) ((OneP AnyP) (skipg ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camle ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camge ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caile ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caige ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camle ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camge ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWGreaterP ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWGreaterP ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWLEQ ((RegisterP ZeroP) (jumple ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumpge ARGTWO ARGTHREE)) ((RegisterP MinusOneP) (jumpl ARGONE ARGTHREE)) ((OneP RegisterP) (jumpg ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipg ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipl ARGTWO) (jrst ARGTHREE)) ((AnyP MinusOneP) (skipge ARGONE) (jrst ARGTHREE)) ((OneP AnyP) (skiple ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (camg ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (caml ARGTWO (lit ARGTHREE)) (jrst ARGTHREE)) ((RegisterP ImmediateP) (caig ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (cail ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (camg ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (caml ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWLEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWLEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*JumpWGEQ ((RegisterP ZeroP) (jumpge ARGONE ARGTHREE)) ((ZeroP RegisterP) (jumple ARGTWO ARGTHREE)) ((RegisterP OneP) (jumpg ARGONE ARGTHREE)) ((MinusOneP RegisterP) (jumpl ARGTWO ARGTHREE)) ((AnyP ZeroP) (skipl ARGONE) (jrst ARGTHREE)) ((ZeroP AnyP) (skipg ARGTWO) (jrst ARGTHREE)) ((AnyP OneP) (skiple ARGONE) (jrst ARGTHREE)) ((MinusOneP AnyP) (skipge ARGTWO) (jrst ARGTHREE)) ((RegisterP NegativeImmediateP) (caml ARGONE (lit (fullword ARGTWO))) (jrst ARGTHREE)) ((NegativeImmediateP RegisterP) (camg ARGTWO (lit (fullword ARGONE))) (jrst ARGTHREE)) ((RegisterP ImmediateP) (cail ARGONE ARGTWO) (jrst ARGTHREE)) ((ImmediateP RegisterP) (caig ARGTWO ARGONE) (jrst ARGTHREE)) ((RegisterP AnyP) (caml ARGONE ARGTWO) (jrst ARGTHREE)) ((AnyP RegisterP) (camg ARGTWO ARGONE) (jrst ARGTHREE)) ((MemoryP AnyP) (move (reg t1) ARGONE) (!*JUMPWGEQ ARGTHREE (reg t1) ARGTWO)) ((move (reg t2) ARGTWO) (!*JUMPWGEQ ARGTHREE ARGONE (reg t2)))) (DefCMacro !*Push ((ImmediateP) (push (reg st) (lit (fullword ARGONE)))) ((push (reg st) ARGONE))) (DefCMacro !*Pop ((ImmediateP) (pop (reg st) (lit (fullword ARGONE)))) ((pop (reg st) ARGONE))) (DefCMacro !*Freerstr ((jsp (reg t5) (Entry FastUnbind)) (fullword ARGONE))) (DefCMacro !*Loc ((RegisterP AnyP) (xmovei ARGONE ARGTWO)) ((xmovei (reg t2) ARGTWO) (movem (reg t2) ARGONE))) (DefCMacro !*Field % ARGONE is Destination, ARGTWO is Source, ARGTHREE is Starting bit % ARGFOUR is Length ((RegisterP AnyP ZeroP EighteenP) (hlrz ARGONE ARGTWO)) ((RegisterP AnyP EighteenP EighteenP) (hrrz ARGONE ARGTWO)) ((AnyP RegisterP ZeroP EighteenP) (hlrzm ARGTWO ARGONE)) ((AnyP RegisterP EighteenP EighteenP) (hrrzm ARGTWO ARGONE)) ((RegisterP AnyP TwelveP TwentyFourP) (!*Move ARGTWO ARGONE) (tlz ARGONE 8#777700)) ((RegisterP AnyP SixP ThirtyP) (!*Move ARGTWO ARGONE) (tlz ARGONE 8#770000)) ((RegisterP) % this might choke with extended addressing? (ldb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR))))) ((ldb (reg t2) (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))) (movem (reg t2) ARGONE))) (DefCMacro !*SignedField ((RegisterP AnyP ZeroP EighteenP) (hlre ARGONE ARGTWO)) ((RegisterP AnyP EighteenP EighteenP) (hrre ARGONE ARGTWO)) ((AnyP RegisterP ZeroP EighteenP) (hlrem ARGTWO ARGONE)) ((AnyP RegisterP EighteenP EighteenP) (hrrem ARGTWO ARGONE)) ((RegisterP MemoryP) % could optimize to use tlne tlo trne tro (!*MOVE ARGTWO (reg t1)) (ldb ARGONE (lit (fullword (FieldPointer (reg t1) ARGTHREE ARGFOUR)))) (tdne ARGONE (lit (fullword (bit ARGTHREE)))) (tdo ARGONE (lit (fullword (bitmask 0 ARGTHREE))))) ((RegisterP) % could optimize to use tlne tlo trne tro (ldb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR)))) (tdne ARGONE (lit (fullword (bit ARGTHREE)))) (tdo ARGONE (lit (fullword (bitmask 0 ARGTHREE))))) ((!*MOVE ARGTWO (reg t1)) (ldb (reg t2) (lit (fullword (FieldPointer (reg t1) ARGTHREE ARGFOUR)))) (tdne (reg t2) (lit (fullword (bit ARGTHREE)))) (tdo (reg t2) (lit (fullword (bitmask 0 ARGTHREE)))) (!*MOVE (reg t2) ARGONE))) (DefCMacro !*PutField ((RegisterP RegisterP) (dpb ARGONE (lit (fullword (FieldPointer ARGTWO ARGTHREE ARGFOUR))))) ((Registerp Anyp ZeroP SixP) % a TAG field in memory (!*LOC (reg t1) ARGTWO) (tlo (reg t1) 8#460000) (dpb ARGONE (reg t1))) ((AnyP Anyp ZeroP SixP) % a TAG field in memory (!*LOC (reg t1) ARGTWO) (tlo (reg t1) 8#460000) (!*MOVE ARGONE (reg t2)) (dpb (reg t2) (reg t1))) ((!*MOVE ARGTWO (reg t2)) (!*MOVE ARGONE (reg t1)) (dpb (reg t1) (lit (fullword (FieldPointer (reg t2) ARGTHREE ARGFOUR)))) (!*MOVE (reg t2) ARGTWO))) (DefCMacro !*ADJSP ((RegisterP ImmediateP) (adjsp ARGONE ARGTWO)) ((RegisterP RegisterP) (adjsp ARGONE (Indexed ARGTWO 0))) ((RegisterP) (move (reg t2) ARGTWO) (adjsp ARGONE (Indexed (reg t2) 0))) ((move (reg t1) ARGONE) (!*ADJSP (reg t1) ARGTWO) (movem (reg t1) ARGONE))) (DefList '((WQuotient ((idiv (reg 1) (reg 2)))) (WRemainder ((idiv (reg 1) (reg 2)) (move (reg 1) (reg 2))))) 'OpenCode) (!&Tworeg '(WQuotient WRemainder)) (loadtime (DefList '((Byte ((tlo (reg 1) 8#620000) (adjbp (reg 2) (reg 1)) (ldb (reg 1) (reg 2)))) (PutByte ((tlo (reg 1) 8#620000) (adjbp (reg 2) (reg 1)) (dpb (reg 3) (reg 2)))) (HalfWord ((tlo (reg 1) 8#740000) (adjbp (reg 2) (reg 1)) (ldb (reg 1) (reg 2)))) (PutHalfWord ((tlo (reg 1) 8#740000) (adjbp (reg 2) (reg 1)) (dpb (reg 3) (reg 2)))) (BitTable ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 2)))) (ldb (reg 1) (reg 2)))) (PutBitTable ((adjbp (reg 2) (lit (fullword (FieldPointer (Indexed (reg 1) 0) 0 2)))) (dpb (reg 3) (reg 2))))) 'OpenCode)) (loadtime (!&TwoReg '(Byte PutByte HalfWord PutHalfWord BitTable PutBitTable))) (DefList '((IDApply0 ((tlz (reg 1) 8#770000) % essentially: clear LH to make (pushj (reg st) % certain address is local (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ((tlz (reg 2) 8#770000) (pushj (reg st) (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ((tlz (reg 3) 8#770000) (pushj (reg st) (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ((tlz (reg 4) 8#770000) (pushj (reg st) (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ((tlz (reg 5) 8#770000) (pushj (reg st) (Indexed (reg 5) (WArray SymFnc)))))) 'OpenCode) (DefList '((IDApply0 ((tlz (reg 1) 8#770000) (jrst (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ((tlz (reg 2) 8#770000) (jrst (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ((tlz (reg 3) 8#770000) (jrst (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ((tlz (reg 4) 8#770000) (jrst (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ((tlz (reg 5) 8#770000) (jrst (Indexed (reg 5) (WArray SymFnc)))))) 'ExitOpenCode) (DefList '((CodeApply0 ((pushj (reg st) (Indexed (reg 1) 0)))) (CodeApply1 ((pushj (reg st) (Indexed (reg 2) 0)))) (CodeApply2 ((pushj (reg st) (Indexed (reg 3) 0)))) (CodeApply3 ((pushj (reg st) (Indexed (reg 4) 0)))) (CodeApply4 ((pushj (reg st) (Indexed (reg 5) 0))))) 'OpenCode) (DefList '((CodeApply0 ((jrst (Indexed (reg 1) 0)))) (CodeApply1 ((jrst (Indexed (reg 2) 0)))) (CodeApply2 ((jrst (Indexed (reg 3) 0)))) (CodeApply3 ((jrst (Indexed (reg 4) 0)))) (CodeApply4 ((jrst (Indexed (reg 5) 0))))) 'ExitOpenCode) (DefList '((AddressApply0 ((pushj (reg st) (Indexed (reg 1) 0)))) (AddressApply1 ((pushj (reg st) (Indexed (reg 2) 0)))) (AddressApply2 ((pushj (reg st) (Indexed (reg 3) 0)))) (AddressApply3 ((pushj (reg st) (Indexed (reg 4) 0)))) (AddressApply4 ((pushj (reg st) (Indexed (reg 5) 0))))) 'OpenCode) (DefList '((AddressApply0 ((jrst (Indexed (reg 1) 0)))) (AddressApply1 ((jrst (Indexed (reg 2) 0)))) (AddressApply2 ((jrst (Indexed (reg 3) 0)))) (AddressApply3 ((jrst (Indexed (reg 4) 0)))) (AddressApply4 ((jrst (Indexed (reg 5) 0))))) 'ExitOpenCode) % "*FEQ, *FGreaterP and !*FLessP can only occur once in a function." (DefList '((!*WFix ((fix (reg 1) (indexed (reg 1) 0)))) (!*WFloat ((fltr (reg 2) (reg 2)) (movem (reg 2) (indexed (reg 1) 0)) (setzm (indexed (reg 1) 1)))) (!*FAssign ((dmove (reg 2) (indexed (reg 2) 0)) (dmovem (reg 2) (indexed (reg 1) 0)))) (!*FEQ ((dmove (reg 3) (indexed (reg 2) 0)) (came (reg 3) (indexed (reg 1) 0)) (jrst !*NotEQ!*) (camn (reg 4) (indexed (reg 1) 1)) !*NotEQ!* (move (reg 1) (reg nil)))) (!*FGreaterP ((dmove (reg 3) (indexed (reg 2) 0)) (camge (reg 3) (indexed (reg 1) 0)) (jrst !*IsGreaterP!*) (camn (reg 3) (indexed (reg 1) 0)) (caml (reg 4) (indexed (reg 1) 1)) (move (reg 1) (reg nil)) !*IsGreaterP!*)) (!*FLessP ((dmove (reg 3) (indexed (reg 2) 0)) (camle (reg 3) (indexed (reg 1) 0)) (jrst !*IsLessP!*) (camn (reg 3) (indexed (reg 1) 0)) (camg (reg 4) (indexed (reg 1) 1)) (move (reg 1) (reg nil)) !*IsLessP!*)) (!*FPlus2 ((dmove (reg 3) (indexed (reg 3) 0)) (dfad (reg 3) (indexed (reg 2) 0)) (dmovem (reg 3) (indexed (reg 1) 0)))) (!*FDifference ((dmove (reg 4) (indexed (reg 2) 0)) (dfsb (reg 4) (indexed (reg 3) 0)) (dmovem (reg 4) (indexed (reg 1) 0)))) (!*FTimes2 ((dmove (reg 3) (indexed (reg 3) 0)) (dfmp (reg 3) (indexed (reg 2) 0)) (dmovem (reg 3) (indexed (reg 1) 0)))) (!*FQuotient ((dmove (reg 4) (indexed (reg 2) 0)) (dfdv (reg 4) (indexed (reg 3) 0)) (dmovem (reg 4) (indexed (reg 1) 0))))) 'OpenCode) % Later, do as FORTRAN call? (DE !*ForeignLink (FunctionName FunctionType NumberOfArguments) (prog NIL (CodeDeclareExternal FunctionName) % To emit Extern (return (LIST (LIST 'Pushj '(REG st) (LIST 'InternalEntry FunctionName)))) )) (DefCMacro !*ForeignLink) |
Added psl-1983/3-1/comp/20/dec20-comp.ctl version [eb01620f62].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ; Rebuild the COMP module @term page 0 @def dsk: dsk:,p20ec:,p20c: @def pl: ple: @get psl:ex-rlisp @st *load build; *build "DEC20-COMP"; *quit; @reset . @term page 24 |
Added psl-1983/3-1/comp/20/dec20-comp.red version [a8ed928006].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-COMP.RED - Compiler patterns for Dec-20 PSL, plus a few cmacro expanders % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 January 1982 % Copyright (c) 1982 University of Utah % % 21-May-83 Mark R. Swanson % Changed *JumpOn to generate Instruction Format Indirect Words for % "case" addresses. % <PSL.COMP-20>DEC20-COMP.RED.4, 2-Mar-83 18:07:16, Edit by PERDUE % Added a USESDEST case to the pattern for SUBPAT % <PSL.20-COMP>20-COMP.RED.1, 25-Feb-82 16:34:42, Edit by BENSON % Converted from VAX version PUT('TVPAT,'PATTERN,'( !®MEM ('!*DESTROY DEST) ((DEST ANY) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((ANY DEST) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((USESDEST ANY) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((ANY USESDEST) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) (ANY ('!*LOAD DEST '(QUOTE T)) (MAC L1 A1 A2) ('!*LOAD DEST '(QUOTE NIL)) ('!*LBL L1)))); PUT('TVPAT1,'PATTERN,'( !®MEM ('!*DESTROY DEST) ((DEST) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) ((USESDEST) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*JUMP L2) ('!*LBL L1) ('!*LOAD DEST '(QUOTE T)) ('!*LBL L2)) (ANY ('!*LOAD DEST '(QUOTE T)) (MAC L1 A1 P2) ('!*LOAD DEST '(QUOTE NIL)) ('!*LBL L1)))); PUT('TSTPAT,'PATTERN,'( NIL !&FIXREGTEST ((REGN ANY) (MAC DEST A1 A2)) (ANY (MAC DEST A2 A1)))); PUT('TSTPATC,'PATTERN,'( NIL !&SETREGS1 ((REGN ANY) (MAC DEST A1 A2)) (ANY (P2 DEST A2 A1)))); PUT('TSTPAT2, 'PATTERN, '( NIL !&SETREGS1 (ANY (MAC DEST A1 P2)))); PUT('SETQPAT,'PATTERN,'( NIL NIL ((NOVAL ANY NOTANYREG) ('!*STORE A2 A1)) ((NOVAL DEST ANY) ('!*STORE A2 DEST)) ((NOVAL USESDEST ANY) ('!*LOAD T1 A2) ('!*STORE T1 A1)) ((NOVAL ANY ANY) ('!*LOAD DEST A2) ('!*STORE DEST A1)) ((ANY DEST) ('!*STORE DEST A1)) ((DEST ANY) ('!*STORE A2 DEST)) ((USESDEST ANY) ('!*STORE A2 A1) ('!*STORE A2 DEST)) (ANY ('!*LOAD DEST A2) ('!*STORE DEST A1)))); PUT('RPLACPAT,'PATTERN,'( NIL NIL ((NOVAL ANY ANY) ('!*STORE A2 (MAC A1))) ((DEST ANY) ('!*STORE A2 (MAC A1))) ((USESDEST ANY) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) ((ANY DEST) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) ((ANY USESDEST) ('!*STORE A2 (MAC A1)) ('!*LOAD DEST A1)) (ANY ('!*LOAD DEST A1) ('!*STORE A2 (MAC DEST))))); PUT('ASSOCPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY DEST) (MAC A2 A1)) ((USESDEST USESDEST) ('!*LOAD T1 A1) ('!*LOAD DEST A2) (MAC DEST T1)) ((ANY USESDEST) ('!*LOAD DEST A2) (MAC DEST A1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('SUBPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY DEST) ('!*WMINUS DEST DEST) ('!*WPLUS2 A2 A1)) ((ANY USESDEST) ('!*LOAD T1 A2) ('!*LOAD DEST A1) (MAC DEST T1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('NONASSOCPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2)) ((DEST ANY) (MAC A1 A2)) ((ANY USESDEST) ('!*LOAD T1 A2) ('!*LOAD DEST A1) (MAC DEST T1)) (ANY ('!*LOAD DEST A1) (MAC DEST A2)))); PUT('FIELDPAT,'PATTERN,'( NIL ('!*SET DEST (FN A1 A2 A3)) (ANY (MAC DEST A1 A2 A3)))); PUT('PUTFIELDPAT,'PATTERN,'( NIL NIL ((NOVAL ANY ANY ANY ANY) (MAC A1 A2 A3 A4)) (ANY (MAC A1 A2 A3 A4) ('!*STORE A1 DEST)))); PUT('UNARYPAT,'PATTERN,'( !&NOANYREG ('!*SET DEST (FN A1)) (ANY (MAC DEST A1)))); PUT('MODMEMPAT,'PATTERN,'( NIL NIL (ANY (MAC A1 A2)))); PUT('MODMEMPAT1,'PATTERN,'( NIL NIL (ANY (MAC A1 A1)))); % Potential trouble spot!!!!!!! (for extend addressing) lisp procedure !*LamBind(Regs, FLst); begin scalar X, Y; FLst := reverse cdr FLst; Regs := reverse cdr Regs; while FLst do << if null Regs then X := 0 else << X := cadr car Regs; Regs := cdr Regs >>; Y := list('halfword, X, list('IDLoc, cadar FLst)) . Y; FLst := cdr FLst >>; return '(jsp (reg t5) (Entry FastBind)) . Y; end; DefCMacro !*Lambind; lisp procedure !*JumpOn(Register, LowerBound, UpperBound, LabelList); begin scalar ExitLbl, BaseLbl, Result; ExitLbl := GenSym(); BaseLbl := GenSym(); Result := NIL . NIL; TConc(Result,if LowerBound < 0 then list('caml, Register, list('lit, LowerBound)) else list('cail, Register, LowerBound)); TConc(Result,if UpperBound < 0 then list('camle, Register, list('lit, UpperBound)) else list('caile, Register, UpperBound)); TConc(Result,list('jrst, ExitLbl)); TConc(Result, list('jrst, list('Indirect, list('Indexed, Register, list('difference, BaseLbl, LowerBound))))); TConc(Result, BaseLbl); for each X in LabelList do TConc(Result, list('indword, cadr X)); TConc(Result, ExitLbl); return car Result; end; DefCMacro !*JumpOn; END; |
Added psl-1983/3-1/comp/20/dec20-cross.mic version [73f2f30c8c].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | @delete s:ex-dec20-cross.exe, exp @get psl:ex-rlisp @st *Options!*:=NIL; % Force reload of ALL *load(zboot, syslisp, if!-system, lap!-to!-asm); *load(dec20!-comp,dec20!-asm); *load(dec20!-cmac); *remflag(''(extrareg),''terminaloperand); *off usermode; *% This patch is until init files can be read *%CopyD(''SaveUncompiledExpression, ''SaveForCompilation); *%in "DEC20-PATCHES.sl"$ *in "pt:new-sym.red"$ *cross!-compiler!-name := "S:EX-DEC20-CROSS.EXE"; *Date!* := "Extended Dec 20 cross compiler"; *writesavefile(); *Quit; @reset . |
Added psl-1983/3-1/comp/20/dec20-data-machine.red version [7822078bdf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-DATA-MACHINE.RED - Lisp item constructors & selectors for Dec-20 Syslisp % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 July 1981 % Copyright (c) 1981 University of Utah % % <PSL.20-COMP>20-DATA-MACHINE.RED.1, 25-Feb-82 17:24:56, Edit by BENSON % Converted from VAX version (which was previously converted from 20 version!) % Primitives handled by the compiler are BYTE, PUTBYTE, GETMEM, PUTMEM, % MKITEM, FIELD, SIGNEDFIELD, PUTFIELD fluid '(system_list!*); system_list!* := '(ExtDec20 Tops20); BothTimes << exported WConst TagStartingBit = 0, TagBitLength = 6, InfStartingBit = 6, InfBitLength = 30, GCStartingBit = 0, GCBitLength = 0, AddressingUnitsPerItem = 1, CharactersPerWord = 5, BitsPerWord = 36, AddressingUnitsPerFunctionCell = 1, StackDirection = 1; >>; syslsp macro procedure GCField U; list('Field, cadr U, '(WConst GCStartingBit), '(WConst GCBitLength)); syslsp macro procedure PutGCField U; list('PutField, cadr U, '(WConst GCStartingBit), '(WConst GCBitLength), caddr U); % Retrieve the address stored in the function cell and strip off 'JRST' part syslsp macro procedure SymFnc U; % list ('Wshift, % list ('WShift, list('WGetV, '(WConst SymFnc), cadr U), 9), % -9); list('Field, list('WGetV, '(WConst SymFnc), cadr U), 12, 24); syslsp macro procedure PutSymFnc U; % put JRST instr. part in table. % list('WPutV, '(WConst SymFnc), cadr U, '(Wor 8#254000000000, caddr U); list('WPutV, '(WConst SymFnc), cadr U, MkCode caddr U); % list('PutField, caddr U,'(Plus2 '(WConst SymFnc), cadr u), 9, 27); % Macros for building stack pointers syslsp macro procedure MakeStackPointerFromAddress U; % when code resides in more than one section, the following will need to be % changed to put the section number rather than a count in the left half list('WOr, list('WShift, list('WDifference, 0, caddr U), 18), list('WDifference, cadr U, 1)); syslsp macro procedure MakeAddressFromStackPointer U; %the next line will be the definition needed when code resides in more than % one section. % list('Field, cadr U, InfStartingBit, InfBitLength); % list('Field, cadr U, 18, 18); list('Wor, list('Field, cadr U, 18, 18), 8#1000000); put('AdjustStackPointer,'OpenFn,'(NonAssocPat !*ADJSP)); lisp procedure !*ADJSP(Arg1, Arg2); Expand2OperandCMacro(Arg1, Arg2, '!*ADJSP); put('EOF, 'CharConst, char cntrl Z); END; |
Added psl-1983/3-1/comp/20/dec20-lap.build version [b29ea39dbf].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | CompileTime << load Syslisp; put('negint,'wconst,63); >>; Compiletime << exported WConst TagStartingBit = 0, TagBitLength = 6, InfStartingBit = 6, InfBitLength = 30, GCStartingBit = 0, GCBitLength = 0, AddressingUnitsPerItem = 1, CharactersPerWord = 5, BitsPerWord = 36, AddressingUnitsPerFunctionCell = 1, StackDirection = 1; >>; in "p20e:system-faslout.red"$ in "dec20-lap.red"$ in "instrs.sl"$ end; |
Added psl-1983/3-1/comp/20/dec20-lap.red version [5f988f9007].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-LAP.RED - Dec-20 PSL assembler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 February 1982 % Copyright (c) 1982 University of Utah % % 27-May-1983 Mark R. Swanson % Added IndWord support for Extended adressing on -20 fluid '(LabelOffsets!* CurrentOffset!* CodeSize!* CodeBase!* Entries!* ForwardInternalReferences!* NewBitTableEntry!* LapReturnValue!* !*WritingFaslFile InitOffset!* !*PGWD !*PWrds); CompileTime << flag('(SaveEntry DefineEntries DepositInstruction OpcodeValue OperandValue DepositWord DepositWordExpression DepositHalfWords LabelValue DepositItem DepositHalfWordIDNumber FindLabels OneLapLength MakeRelocInf MakeRelocWord), 'InternalFunction); smacro procedure LabelP X; atom X; >>; LoadTime << !*PWrds := T; >>; lisp procedure Lap U; begin scalar LapReturnValue!*, LabelOffsets!*, Entries!*; if not !*WritingFaslFile then CurrentOffset!* := 0; U := Pass1Lap U; FindLabels U; if !*PGWD then for each X in U do if atom X then Prin2 X else PrintF(" %p%n", X); if not !*WritingFaslFile then CodeBase!* := GTBPS CodeSize!*; for each X in U do if not LabelP X then if first X = '!*entry then SaveEntry X else DepositInstruction X; DefineEntries(); if not !*WritingFaslFile and !*PWrds then ErrorPrintF("*** %p: base %o, length %d words", for each X in Entries!* collect first car X, CodeBase!*, CodeSize!*); return MkCODE LapReturnValue!*; end; lisp procedure SaveEntry X; if second X = '!*!*!*Code!*!*Pointer!*!*!* then LapReturnValue!* := % Magic token that tells LAP to return (if !*WritingFaslFile then CurrentOffset!* % a code pointer else IPlus2(CodeBase!*, CurrentOffset!*)) else if not !*WritingFaslFile then << Entries!* := (rest X . CurrentOffset!*) . Entries!*; if not LapReturnValue!* then LapReturnValue!* := IPlus2(CodeBase!*, CurrentOffset!*) >> else if second X = '!*!*Fasl!*!*InitCode!*!* then InitOffset!* := CurrentOffset!* else if FlagP(second X, 'InternalFunction) then put(second X, 'InternalEntryOffset, CurrentOffset!*) else << FindIDNumber second X; DFPrintFasl list('PutEntry, MkQuote second X, MkQuote third X, CurrentOffset!*) >>; lisp procedure DefineEntries(); for each X in Entries!* do PutD(first car X, second car X, MkCODE IPlus2(CodeBase!*, cdr X)); lisp procedure DepositInstruction X; % % Legal forms are: % (special_form . any) % (opcode) % (opcode address) % (opcode ac address) % begin scalar Op, Y, A, E; return if (Y := get(first X, 'InstructionDepositFunction)) then Apply(Y, list X) else << NewBitTableEntry!* := 0; Op := OpcodeValue first X; if null(Y := rest X) then A := E := 0 else << E := OperandValue first Y; if null(Y := rest Y) then A := 0 else << A := E; E := OperandValue first Y >> >>; UpdateBitTable(1, NewBitTableEntry!*); DepositAllFields(Op, A, E) >>; end; lisp procedure DepositAllFields(Op, A, E); << @IPlus2(CodeBase!*, CurrentOffset!*) := ILOR(ILSH(Op, 27), ILOR(ILSH(A, 23), E)); CurrentOffset!* := IAdd1 CurrentOffset!* >>; lisp procedure OpcodeValue U; if PosIntP U then U else get(U, 'OpcodeValue) or StdError BldMsg("Unknown opcode %r", U); lisp procedure OperandValue U; % % Legal forms are: % number % other atom (label) % (special . any) fluid, global, etc. % (indexed register address) % (indirect other_op) % begin scalar X; return if PosIntP U then U else if NegIntP U then ILAND(U, 8#777777) else if LabelP U then ILAND(LabelValue U, 8#777777) else if (X := get(first U, 'OperandValueFunction)) then Apply(X, list U) else if (X := WConstEvaluable U) then OperandValue X else StdError BldMsg("Unknown operand %r", U); end; lisp procedure BinaryOperand U; % % (op x x) can occur in expressions % begin scalar X; return if (X := WConstEvaluable U) then X else << X := if GetD first U then first U else get(first U, 'DOFN); U := rest U; if NumberP first U then Apply(X, list(first U, LabelValue second U)) else if NumberP second U then Apply(X, list(LabelValue first U, second U)) else StdError BldMsg("Expression too complicated in LAP %r", U) >>; end; % Add others to this list if they arise put('difference, 'OperandValueFunction, 'BinaryOperand); put('WPlus2, 'OperandValueFunction, 'BinaryOperand); lisp procedure RegisterOperand U; begin scalar V; U := second U; return if PosIntP U then U else if (V := get(U, 'RegisterNumber)) then V else StdError BldMsg("Unknown register %r", U); end; put('REG, 'OperandValueFunction, 'RegisterOperand); DefList('((nil 0) (t1 6) (t2 7) (t3 8) (t4 9) (t5 10) (t6 11) (st 8#17)), 'RegisterNumber); lisp procedure ImmediateOperand U; OperandValue second U; % immediate does nothing on the PDP10 put('immediate, 'OperandValueFunction, 'ImmediateOperand); lisp procedure IndexedOperand U; begin scalar V; V := OperandValue second U; U := OperandValue third U; return ILOR(ILSH(V, 18), U); end; put('indexed, 'OperandValueFunction, 'IndexedOperand); lisp procedure LapValueCell U; ValueCellLocation second U; DefList('((fluid LapValueCell) (!$fluid LapValueCell) (global LapValueCell) (!$global LapValueCell)), 'OperandValueFunction); lisp procedure LapEntry U; FunctionCellLocation second U; put('entry, 'OperandValueFunction, 'LapEntry); lisp procedure LapInternalEntry U; begin scalar X; U := second U; NewBitTableEntry!* := const RELOC_HALFWORD; return if (X := Atsoc(U, LabelOffsets!*)) then << X := cdr X; if !*WritingFaslFile then X else IPlus2(CodeBase!*, X) >> else << if not !*WritingFaslFile then FunctionCellLocation U else if (X := get(U, 'InternalEntryOffset)) then X else << ForwardInternalReferences!* := (CurrentOffset!* . U) . ForwardInternalReferences!*; 0 >> >>; % will be modified later end; put('InternalEntry, 'OperandValueFunction, 'LapInternalEntry); lisp procedure DepositWordBlock X; for each Y in cdr X do DepositWordExpression Y; put('fullword, 'InstructionDepositFunction, 'DepositWordBlock); put('indword, 'InstructionDepositFunction, 'DepositIndWord); lisp procedure DepositIndWord X; begin scalar Infpart; InfPart := cadr X; if not !*WritingFaslFile then DepositWord MkItem(8#40,ILAND(8#777777, LabelValue InfPart)) else << if LabelP InfPart then @IPlus2(CodeBase!*, CurrentOffset!*) := % RELOC_CODE_OFFSET = 0 MkItem(8#40, LabelValue InfPart); CurrentOffset!* := IAdd1 CurrentOffset!*; UpdateBitTable(1, const RELOC_HALFWORD) >>; end; lisp procedure DepositHalfWordBlock X; begin scalar L, R; X := rest X; while not null X do << L := first X; X := rest X; if null X then R := 0 else << R := first X; X := rest X >>; DepositHalfWords(L, R) >>; end; put('halfword, 'InstructionDepositFunction, 'DepositHalfWordBlock); CommentOutCode << lisp procedure DepositByteBlock X; case length X of 0: DepositWord 0; 1: DepositBytes(first X, 0, 0, 0, 0); 2: DepositBytes(first X, second X, 0, 0, 0); 3: DepositBytes(first X, second X, third X, 0, 0); 4: DepositBytes(first X, second X, third X, fourth X, 0); default: << DepositBytes(first X, second X, third X, fourth X, fourth rest X); DepositByteBlock rest rest rest rest rest X >>; end; put('byte, 'InstructionDepositFunction, 'DepositByteBlock); >>; lisp procedure DepositString X; begin scalar Y; X := StrInf second X; Y := StrPack StrLen X; for I := 1 step 1 until Y do DepositWord @IPlus2(X, I); end; put('string, 'InstructionDepositFunction, 'DepositString); lisp procedure DepositFloat X; % this will not work in cross-assembly << X := second X; % don't need to strip tag on PDP10 DepositWord FloatHighOrder X; DepositWord FloatLowOrder X >>; put('float, 'InstructionDepositFunction, 'DepositFloat); lisp procedure DepositWord X; << @IPlus2(CodeBase!*, CurrentOffset!*) := X; UpdateBitTable(1, 0); CurrentOffset!* := IAdd1 CurrentOffset!* >>; lisp procedure DepositWordExpression X; % Only limited expressions now handled begin scalar Y; return if FixP X then DepositWord Int2Sys X else if LabelP X then << @IPlus2(CodeBase!*, CurrentOffset!*) := LabelValue X; UpdateBitTable(1, const RELOC_HALFWORD); CurrentOffset!* := IAdd1 CurrentOffset!* >> else if first X = 'MkItem then DepositItem(second X, third X) else if first X = 'FieldPointer then DepositFieldPointer(second X, third X, fourth X) else if (Y := WConstEvaluable X) then DepositWord Int2Sys Y else StdError BldMsg("Expression too complicated %r", X); end; lisp procedure DepositHalfWords(L, R); begin scalar Y; if not (FixP L or (L := WConstEvaluable L)) then StdError "Left half too complex"; if PairP R and first R = 'IDLoc then DepositHalfWordIDNumber(L, second R) else if (Y := WConstEvaluable R) then DepositWord ILOR(ILSH(L, 18), Y) else StdError BldMsg("Halfword expression too complicated %r", R); end; lisp procedure LabelValue U; begin scalar V; return if CodeP U then Inf U else if (V := Atsoc(U, LabelOffsets!*)) then << V := cdr V; if !*WritingFaslFile then << NewBitTableEntry!* := const RELOC_HALFWORD; V >> else IPlus2(CodeBase!*, V) >> else StdError BldMsg("Unknown label %r in LAP", U); end; lisp procedure DepositItem(TagPart, InfPart); if not !*WritingFaslFile then DepositWord MkItem(TagPart, if LabelP InfPart then LabelValue InfPart else if first InfPart = 'IDLoc then IDInf second InfPart else StdError BldMsg("Unknown inf in MkItem %r", InfPart)) else << if LabelP InfPart then @IPlus2(CodeBase!*, CurrentOffset!*) := % RELOC_CODE_OFFSET = 0 MkItem(TagPart, LabelValue InfPart) else if first InfPart = 'IDLoc then @IPlus2(CodeBase!*, CurrentOffset!*) := MkItem(TagPart, MakeRelocInf(const RELOC_ID_NUMBER, FindIDNumber second InfPart)) else StdError BldMsg("Unknown inf in MkItem %r", InfPart); CurrentOffset!* := IAdd1 CurrentOffset!*; UpdateBitTable(1, const RELOC_INF) >>; lisp procedure DepositHalfWordIDNumber(LHS, X); if not !*WritingFaslFile or ILEQ(IDInf X, 128) then DepositWord ILOR(ILSH(LHS, 18), IDInf X) else << @IPlus2(CodeBase!*, CurrentOffset!*) := ILOR(ILSH(LHS, 18), MakeRelocHalfWord(const RELOC_ID_NUMBER, FindIDNumber X)); CurrentOffset!* := IAdd1 CurrentOffset!*; UpdateBitTable(1, const RELOC_HALFWORD) >>; lisp procedure SystemFaslFixup(); << while not null ForwardInternalReferences!* do << Field(@IPlus2(CodeBase!*, car first ForwardInternalReferences!*), 18, 18) := get(cdr first ForwardInternalReferences!*, 'InternalEntryOffset) or << ErrorPrintF( "***** %r not defined in this module; normal function call being used", cdr first ForwardInternalReferences!*); MakeRelocHalfWord(const RELOC_FUNCTION_CELL, FindIDNumber cdr first ForwardInternalReferences!*) >>; ForwardInternalReferences!* := cdr ForwardInternalReferences!* >>; MapObl function lambda(X); RemProp(X, 'InternalEntryOffset) >>; fluid '(LapCodeList!*); lisp procedure FindLabels LapCodeList!*; << CodeSize!* := 0; for each X in LapCodeList!* do CodeSize!* := IPlus2(CodeSize!*, OneLapLength X) >>; lisp procedure OneLapLength U; begin scalar X; return if atom U then << LabelOffsets!* := (U . IPlus2(CurrentOffset!*, CodeSize!*)) . LabelOffsets!*; 0 >> else if (X := get(car U, 'LapLength)) then if PosIntP X then X else Apply(X, list U) else % minor klugde for long constants << if length U = 3 and FixP(X := third U) and not ImmediateP X then begin scalar Y; RPlaca(rest rest U, Y := StringGensym()); NConc(LapCodeList!*, list(Y, list('fullword, X))); end; 1 >>; end; DefList('((!*entry LapEntryLength) (float 2) (string LapStringLength) (fullword LapWordLength) (halfword LapHalfwordLength) (byte LapByteLength)), 'LapLength); lisp procedure LapEntryLength U; << LabelOffsets!* := (second U . IPlus2(CurrentOffset!*, CodeSize!*)) . LabelOffsets!*; 0 >>; lisp procedure LapStringLength U; StrPack StrLen StrInf second U; lisp procedure LapWordLength U; length rest U; lisp procedure LapHalfwordLength U; ILSH(IAdd1 length rest U, -1); lisp procedure LapByteLength U; StrPack length rest U; on SysLisp; syslsp procedure DepositFieldPointer(Opr, Start, Len); << LispVar NewBitTableEntry!* := 0; Opr := OperandValue Opr; @IPlus2(LispVar CodeBase!*, LispVar CurrentOffset!*) := ILOR(ILSH(36 - (Start + Len), 30), ILOR(ILSH(Len, 24), Opr)); UpdateBitTable(1, LispVar NewBitTableEntry!*); LispVar CurrentOffset!* := IAdd1 LispVar CurrentOffset!* >>; syslsp procedure IndirectOperand U; ILOR(ILSH(1, 22), OperandValue second U); put('Indirect, 'OperandValueFunction, 'IndirectOperand); % ExtraRegLocation is in 20-FASL put('ExtraReg, 'OperandValueFunction, 'ExtraRegLocation); syslsp procedure MakeRelocWord(RelocTag, RelocInf); LSH(RelocTag, 34) + Field(RelocInf, 2, 34); syslsp procedure MakeRelocInf(RelocTag, RelocInf); LSH(RelocTag, 16) + Field(RelocInf, 20, 16); syslsp procedure MakeRelocHalfWord(RelocTag, RelocInf); LSH(RelocTag, 16) + Field(RelocInf, 20, 16); off SysLisp; END; |
Added psl-1983/3-1/comp/20/instrs.sl version [c43e01d726].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (compiletime (dm DEFINEOPCODERANGEFROM (U) (prog (start args) (setq start (sub1 (second U))) (setq args (second (third U))) (return (cons 'progn (foreach X in args collect (list 'put (mkquote X) ''opcodevalue (setq start (add1 start)))))))) ) (DEFINEOPCODERANGEFROM 68 (QUOTE (JSYS ADJSP))) (DEFINEOPCODERANGEFROM 91 (QUOTE (ADJBP))) (DEFINEOPCODERANGEFROM 72 (QUOTE (DFAD DFSB DFMP DFDV))) (DEFINEOPCODERANGEFROM 80 (QUOTE (DMOVE DMOVN FIX))) (DEFINEOPCODERANGEFROM 84 (QUOTE (DMOVEM DMOVNM FIXR FLTR UFA DFN FSC IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ROT LSH JFFO ASHC ROTC LSHC))) (DEFINEOPCODERANGEFROM 168 (QUOTE (EXCH BLT AOBJP AOBJN JRST JFCL XCT MAP PUSHJ PUSH POP POPJ JSR JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM CAML CAME CAMLE CAMA CAMGE CAMN CAMG))) (DEFINEOPCODERANGEFROM 208 (QUOTE (JUMP JUMPL JUMPE JUMPLE JUMPA JUMPGE JUMPN JUMPG SKIP SKIPL SKIPE SKIPLE SKIPA SKIPGE SKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE SOSLE SOSA SOSGE SOSN SOSG))) (DEFINEOPCODERANGEFROM 256 (QUOTE (SETZ SETZI SETZM SETZB AND ANDI ANDM ANDB ANDCA ANDCAI ANDCAM ANDCAB SETM SETMI SETMM SETMB ANDCM ANDCMI ANDCMM ANDCMB))) (DEFINEOPCODERANGEFROM 276 (QUOTE (SETA SETAI SETAM SETAB XOR XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBI ANDCBM ANDCBB EQV EQVI EQVM EQVB SETCA SETCAI SETCAM SETCAB ORCA ORCAI ORCAM ORCAB SETCM SETCMI SETCMM SETCMB ORCM ORCMI ORCMM ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB))) (DEFINEOPCODERANGEFROM 320 (QUOTE (HLL HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE HLREI HLREM HLRES))) (DEFINEOPCODERANGEFROM 384 (QUOTE (TRN TLN TRNE TLNE TRNA TLNA TRNN TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLCE TRCA TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO TSO TDOE TSOE TDOA TSOA TDON TSON))) (DEFINEOPCODERANGEFROM 269 (QUOTE (XMOVEI))) |
Added psl-1983/3-1/comp/20/lap-to-asm.ctl version [ed04dbdfcd].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ; Rebuild the LAP-TO-ASM module @def dsk: dsk:,p20ec:,pc: @def pl: mple:,ple: @term page 0 @get psl:ex-rlisp @st *load build; *build "LAP-TO-ASM"; *quit; @reset . @term page 24 |
Added psl-1983/3-1/comp/20/lap-to-asm.red version [1ca653467c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LAP-TO-ASM.RED - LAP to assembler translator % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 13 August 1981 % Copyright (c) 1981 University of Utah % % 21-May-83 Mark R. Swanson % Added IndWord functions to support extended-20 % 01-Mar-83 Nancy Kendzierski % Changed EVIN to PathIn in ASMOUT to enable search paths to be % used when doing system builds connected to a directory other % than pxx:, where xx=machine (hp, 20, vax, etc.) % Only set InputSymFile!*, OutputSymFile!*, GlobalDataFileName!*, % and InitFileNameFormat!* if they aren't already initialized. % Changed SEMIC!* declaration from global to fluid. % <PSL.COMP>LAP-TO-ASM.RED.5, 30-Apr-82 14:47:52, Edit by BENSON % Removed EVAL and IGNORE processing Imports '(PathIn); fluid '(Semic!* !*Comp !*PLap DfPrint!* CharactersPerWord AddressingUnitsPerItem AddressingUnitsPerFunctionCell InputSymFile!* OutputSymFile!* CodeOut!* DataOut!* InitOut!*; CodeFileNameFormat!* DataFileNameFormat!* InitFileNameFormat!* ModuleName!* UncompiledExpressions!* NextIDNumber!* OrderedIDList!* NilNumber!* !*MainFound !*MAIN !*DeclareBeforeUse MainEntryPointName!* EntryPoints!* LocalLabels!* CodeExternals!* CodeExporteds!* DataExternals!* DataExporteds!* ExternalDeclarationFormat!* ExportedDeclarationFormat!* LabelFormat!* FullWordFormat!* DoubleFloatFormat!* ReserveDataBlockFormat!* ReserveZeroBlockFormat!* UndefinedFunctionCellInstructions!* DefinedFunctionCellFormat!* PrintExpressionForm!* PrintExpressionFormPointer!* CommentFormat!* NumericRegisterNames!* ExpressionCount!* ASMOpenParen!* ASMCloseParen!* ToBeCompiledExpressions!* GlobalDataFileName!* ); % Default values; set up if not already initialized. if null InputSymFile!* then InputSymFile!* := "psl.sym"; if null OutputSymFile!* then OutputSymFile!* := "psl.sym"; if null GlobalDataFileName!* then GlobalDataFileName!* := "global-data.red"; if null InitFileNameFormat!* then InitFileNameFormat!* := "%w.init"; lisp procedure DfPrintASM U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn; if atom U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; IF FLAGP(TY,'COMPILE) THEN << PUT(NAM,'CFNTYPE,LIST TY); U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U) . !&COMPROC(U, NAM); if !*PLAP then for each X in U do Print X; if TY neq 'EXPR then DfPrintASM list('put, MkQuote Nam, '(quote TYPE), MkQuote TY); ASMOUTLAP U >> ELSE % should never happen SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM, MKQUOTE TY, MKQUOTE U); RETURN NIL; DB1: % Simple S-EXPRESSION, maybe EVAL it; IF NOT PAIRP U THEN RETURN NIL; if (Fn := get(car U, 'ASMPreEval)) then return Apply(Fn, list U) else if (Fn := GetD car U) and car Fn = 'MACRO then return DFPRINTASM Apply(cdr Fn, list U); SaveUncompiledExpression U; RETURN NIL; DB2: NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; lisp procedure ASMPreEvalLoadTime U; DFPrintASM cadr U; % remove LOADTIME put('LoadTime, 'ASMPreEval, 'ASMPreEvalLoadTime); lisp procedure ASMPreEvalStartupTime U; SaveForCompilation cadr U; put('StartupTime, 'ASMPreEval, 'ASMPreEvalStartupTime); lisp procedure ASMPreEvalProgN U; for each X in cdr U do DFPrintASM X; put('ProgN, 'ASMPreEval, 'ASMPreEvalProgN); put('WDeclare, 'ASMPreEval, 'Eval); % do it now lisp procedure ASMPreEvalSetQ U; begin scalar X, Val; X := cadr U; Val := caddr U; return if ConstantP Val or Val = T then << FindIDNumber X; put(X, 'InitialValue, Val); NIL >> else if null Val then << FindIDNumber X; RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue); NIL >> else if EqCar(Val, 'QUOTE) then << FindIDNumber X; Val := cadr Val; if null Val then << RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue) >> else put(X, 'InitialValue, Val); NIL >> else if IDP Val and get(Val, 'InitialValue) or FlagP(Val, 'NilInitialValue) then << if (Val := get(Val, 'InitialValue)) then put(X, 'InitialValue, Val) else Flag(list X, 'NilInitialValue) >> else SaveUncompiledExpression U; % just check simple cases, else return end; put('SetQ, 'ASMPreEval, 'ASMPreEvalSetQ); lisp procedure ASMPreEvalPutD U; SaveUncompiledExpression CheckForEasySharedEntryPoints U; lisp procedure CheckForEasySharedEntryPoints U; % % looking for (PUTD (QUOTE name1) xxxx (CDR (GETD (QUOTE name2)))) % begin scalar NU, Nam, Exp; NU := cdr U; Nam := car NU; if car Nam = 'QUOTE then Nam := cadr Nam else return U; NU := cdr NU; Exp := cadr NU; if not (car Exp = 'CDR) then return U; Exp := cadr Exp; if not (car Exp = 'GETD) then return U; Exp := cadr Exp; if not (car Exp = 'QUOTE) then return U; Exp := cadr Exp; FindIDNumber Nam; put(Nam, 'EntryPoint, FindEntryPoint Exp); if not (car NU = '(QUOTE EXPR)) then return list('Put, '(Quote Type), car NU); return NIL; end; put('PutD, 'ASMPreEval, 'ASMPreEvalPutD); lisp procedure ASMPreEvalFluidAndGlobal U; << if EqCar(cadr U, 'QUOTE) then Flag(cadr cadr U, 'NilInitialValue); SaveUncompiledExpression U >>; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); CommentOutCode << fluid '(NewFluids!* NewGlobals!*); lisp procedure ASMPreEvalFluidAndGlobal U; begin scalar L; L := cadr U; return if car L = 'QUOTE then << L := cadr L; if car U = 'FLUID then NewFluids!* := UnionQ(NewFluids!*, L) % take union else NewGlobals!* := UnionQ(NewGlobals!*, L); Flag(L, 'NilInitialValue); NIL >> else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); >>; lisp procedure ASMPreEvalLAP U; if EqCar(cadr U, 'QUOTE) then ASMOutLap cadr cadr U else SaveUncompiledExpression U; put('LAP, 'ASMPreEval, 'ASMPreEvalLAP); CommentOutCode << lisp procedure InitialPut(Nam, Ind, Val); begin scalar L, P; FindIDNumber Nam; if (P := Atsoc(Ind, L := get(Nam, 'InitialPropertyList))) then Rplacd(P, Val) else put(Nam, 'InitialPropertyList, (Ind . Val) . L); end; lisp procedure InitialRemprop(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelAtQIP(Ind, L)); end; lisp procedure InitialFlag1(Nam, Ind); begin scalar L, P; FindIDNumber Nam; if not Ind memq (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, Ind . L); end; lisp procedure InitialRemFlag1(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelQIP(Ind, L)); end; lisp procedure ASMPreEvalPut U; begin scalar Nam, Ind, Val; Nam := second U; Ind := third U; Val := fourth U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) and (ConstantP Val or Val = T or EqCar(Val, 'QUOTE)) then InitialPut(second Nam, second Ind, if EqCar(Val, 'QUOTE) then second Val else Val) else SaveUncompiledExpression U; end; put('put, 'ASMPreEval, 'ASMPreEvalPut); lisp procedure ASMPreEvalRemProp U; begin scalar Nam, Ind; Nam := second U; Ind := third U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) then InitialRemProp(second Nam, second Ind) else SaveUncompiledExpression U; end; put('RemProp, 'ASMPreEval, 'ASMPreEvalRemProp); lisp procedure ASMPreEvalDefList U; begin scalar DList, Ind; DList := second U; Ind := third U; if EqCar(DList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << DList := second DList; Ind := second Ind; for each X in Dlist do InitialPut(first X, Ind, second X) >> else SaveUncompiledExpression U; end; put('DefList, 'ASMPreEval, 'ASMPreEvalDefList); lisp procedure ASMPreEvalFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('flag, 'ASMPreEval, 'ASMPreEvalFlag); lisp procedure ASMPreEvalRemFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialRemFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('RemFlag, 'ASMPreEval, 'ASMPreEvalRemFlag); lisp procedure ASMPreEvalGlobal U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'Global) else SaveUncompiledExpression U; end; put('Global, 'ASMPreEval, 'ASMPreEvalGlobal); lisp procedure ASMPreEvalFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'FLUID) else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluid); lisp procedure ASMPreEvalUnFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialRemProp(X, 'TYPE) else SaveUncompiledExpression U; end; put('UnFluid, 'ASMPreEval, 'ASMPreEvalUnFluid); >>; lisp procedure SaveUncompiledExpression U; if PairP U then begin scalar OldOut; OldOut := WRS InitOut!*; Print U; WRS OldOut; end; ToBeCompiledExpressions!* := NIL . NIL; lisp procedure SaveForCompilation U; if atom U or U member car ToBeCompiledExpressions!* then NIL else if car U = 'progn then for each X in cdr U do SaveForCompilation X else TConc(ToBeCompiledExpressions!*, U); SYMBOLIC PROCEDURE ASMOUT FIL; begin scalar OldOut; ModuleName!* := FIL; Prin2T "ASMOUT: IN files; or type in expressions"; Prin2T "When all done execute ASMEND;"; CodeOut!* := Open(BldMsg(CodeFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS CodeOut!*; LineLength 1000; WRS OldOut; CodeFileHeader(); DataOut!* := Open(BldMsg(DataFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS DataOut!*; LineLength 1000; WRS OldOut; DataFileHeader(); InitOut!* := Open(BldMsg(InitFileNameFormat!*, ModuleName!*), 'OUTPUT); ReadSYMFile(); DFPRINT!* := 'DFPRINTASM; RemD 'OldLap; PutD('OldLap, 'EXPR, cdr RemD 'Lap); PutD('Lap, 'EXPR, cdr GetD 'ASMOutLap); !*DEFN := T; SEMIC!* := '!$ ; % to turn echo off for IN if not ((ModuleName!* = "main") or !*Main) then PathIn GlobalDataFileName!* else !*Main := T; end; lisp procedure ASMEnd; << off SysLisp; if !*MainFound then << CompileUncompiledExpressions(); % WriteInitFile(); InitializeSymbolTable() >> else WriteSymFile(); CodeFileTrailer(); Close CodeOut!*; DataFileTrailer(); Close DataOut!*; Close InitOut!*; RemD 'Lap; PutD('Lap, 'EXPR, cdr GetD 'OldLap); DFPRINT!* := NIL; !*DEFN := NIL >>; FLAG('(ASMEND), 'IGNORE); DEFINEROP('ASMEND,NIL,ESTAT('ASMEND)); lisp procedure CompileUncompiledExpressions(); << CommentOutCode << AddFluidAndGlobalDecls(); >>; DFPRINTASM list('DE, 'INITCODE, '(), 'PROGN . car ToBeCompiledExpressions!*) >>; CommentOutCode << lisp procedure AddFluidAndGlobalDecls(); << SaveUncompiledExpression list('GLOBAL, MkQuote NewGlobals!*); SaveUncompiledExpression list('FLUID, MkQuote NewFluids!*) >>; >>; lisp procedure ReadSymFile(); LapIN InputSymFile!*; lisp procedure WriteSymFile(); begin scalar NewOut, OldOut; OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT)); print list('SaveForCompilation, MkQuote('progn . car ToBeCompiledExpressions!*)); SaveIDList(); SetqPrint 'NextIDNumber!*; SetqPrint 'StringGenSym!*; MapObl function PutPrintEntryAndSym; WRS OldOut; Close NewOut; end; CommentOutCode << lisp procedure WriteInitFile(); begin scalar OldOut, NewOut; NewOut := Open(InitFileName!*, 'OUTPUT); OldOut := WRS NewOut; for each X in car UncompiledExpressions!* do PrintInit X; Close NewOut; WRS OldOut; end; lisp procedure PrintInit X; if EqCar(X, 'progn) then for each Y in cdr X do PrintInit Y else Print X; >>; lisp procedure SaveIDList(); << Print list('setq, 'OrderedIDList!*, MkQuote car OrderedIDList!*); Print quote(OrderedIDList!* := OrderedIDList!* . LastPair OrderedIDList!*) >>; lisp procedure SetqPrint U; print list('SETQ, U, MkQuote Eval U); lisp procedure PutPrint(X, Y, Z); print list('PUT, MkQuote X, MkQuote Y, MkQuote Z); lisp procedure PutPrintEntryAndSym X; begin scalar Y; if (Y := get(X, 'EntryPoint)) then PutPrint(X, 'EntryPoint, Y); if (Y := get(X, 'IDNumber)) then PutPrint(X, 'IDNumber, Y); CommentOutCode << if (Y := get(X, 'InitialPropertyList)) then PutPrint(X, 'InitialPropertyList, Y); >>; if (Y := get(X, 'InitialValue)) then PutPrint(X, 'InitialValue, Y) else if FlagP(X, 'NilInitialValue) then print list('flag, MkQuote list X, '(quote NilInitialValue)); if get(X, 'SCOPE) = 'EXTERNAL then << PutPrint(X, 'SCOPE, 'EXTERNAL); PutPrint(X, 'ASMSymbol, get(X, 'ASMSymbol)); if get(X, 'WVar) then PutPrint(X, 'WVar, X) else if get(X, 'WArray) then PutPrint(X, 'WArray, X) else if get(X, 'WString) then PutPrint(X, 'WString, X) else if (Y := get(X, 'WConst)) then PutPrint(X, 'WConst, Y) >>; end; lisp procedure FindIDNumber U; begin scalar I; return if (I := ID2Int U) <= 128 then I else if (I := get(U, 'IDNumber)) then I else << put(U, 'IDNumber, I := NextIDNumber!*); OrderedIDList!* := TConc(OrderedIDList!*, U); NextIDNumber!* := NextIDNumber!* + 1; I >>; end; OrderedIDList!* := NIL . NIL; NextIDNumber!* := 129; lisp procedure InitializeSymbolTable(); begin scalar MaxSymbol; MaxSymbol := get('MaxSymbols, 'WConst); if MaxSymbol < NextIDNumber!* then << ErrorPrintF("*** MaxSymbols %r is too small; at least %r is needed", MaxSymbol, NextIDNumber!*); MaxSymbol := NextIDNumber!* + 100 >>; Flag('(NIL), 'NilInitialValue); put('T, 'InitialValue, 'T); put('!$EOF!$, 'InitialValue, Int2ID get('EOF, 'CharConst)); put('!$EOL!$, 'InitialValue, '! ); NilNumber!* := CompileConstant NIL; DataAlignFullWord(); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymVal(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); InitializeSymPrp(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymNam MaxSymbol; InitializeSymFnc(); DataReserveFunctionCellBlock((MaxSymbol - NextIDNumber!*) + 1); DataAlignFullWord(); DataPrintGlobalLabel FindGlobalLabel 'NextSymbol; DataPrintFullWord NextIDNumber!*; end; lisp procedure InitializeSymPrp(); << CommentOutCode << InitializeHeap(); >>; % init prop lists DataPrintGlobalLabel FindGlobalLabel 'SymPrp; for I := 0 step 1 until 128 do InitSymPrp1 Int2ID I; for each X in car OrderedIDList!* do InitSymPrp1 X >>; lisp procedure InitSymPrp1 X; << CommentOutCode << DataPrintFullWord(if (X := get(X, 'InitialPropertyList)) then X else NilNumber!*); >>; DataPrintFullWord NilNumber!* >>; CommentOutCode << lisp procedure InitializeHeap(); begin scalar L; DataPrintGlobalLabel FindGlobalLabel 'Heap; for I := 0 step 1 until 128 do PrintPropertyList Int2ID I; for each X in car OrderedIDList!* do PrintPropertyList X; L := get('HeapSize, 'WConst); end; >>; lisp procedure InitializeSymNam MaxSymbol; << DataPrintGlobalLabel FindGlobalLabel 'SymNam; for I := 0 step 1 until 128 do DataPrintFullWord CompileConstant ID2String Int2ID I; for each IDName in car OrderedIDList!* do DataPrintFullWord CompileConstant ID2String IDName; MaxSymbol := MaxSymbol - 1; for I := NextIDNumber!* step 1 until MaxSymbol do DataPrintFullWord(I + 1); DataPrintFullWord 0 >>; lisp procedure InitializeSymVal(); << DataPrintGlobalLabel FindGlobalLabel 'SymVal; for I := 0 step 1 until 128 do InitSymVal1 Int2ID I; for each X in car OrderedIDList!* do InitSymVal1 X >>; lisp procedure InitSymVal1 X; begin scalar Val; return DataPrintFullWord(if (Val := get(X, 'InitialValue)) then CompileConstant Val else if FlagP(X, 'NilInitialValue) then NilNumber!* else list('MkItem, get('Unbound, 'WConst), FindIDNumber X)); end; lisp procedure InitializeSymFnc(); << DataPrintGlobalLabel FindGlobalLabel 'SymFnc; for I := 0 step 1 until 128 do InitSymFnc1 Int2ID I; for each X in car OrderedIDList!* do InitSymFnc1 X >>; lisp procedure InitSymFnc1 X; begin scalar EP; EP := get(X, 'EntryPoint); if null EP then DataPrintUndefinedFunctionCell() else DataPrintDefinedFunctionCell EP; end; lisp procedure ASMOutLap U; begin scalar LocalLabels!*, OldOut; U := Pass1Lap U; % Expand cmacros, quoted expressions CodeBlockHeader(); OldOut := WRS CodeOut!*; for each X in U do ASMOutLap1 X; WRS OldOut; CodeBlockTrailer(); end; lisp procedure ASMOutLap1 X; begin scalar Fn; return if StringP X then PrintLabel X else if atom X then PrintLabel FindLocalLabel X else if (Fn := get(car X, 'ASMPseudoOp)) then Apply(Fn, list X) else % instruction output form is: % "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline" << Prin2 '! ; % Space PrintOpcode car X; X := cdr X; if not null X then << Prin2 '! ; % SPACE PrintOperand car X; for each U in cdr X do << Prin2 '!,; % COMMA PrintOperand U >> >>; Prin2 !$EOL!$ >>; % NEWLINE end; put('!*Entry, 'ASMPseudoOp, 'ASMPrintEntry); lisp procedure ASMPrintEntry X; begin scalar Y; PrintComment X; X := cadr X; Y := FindEntryPoint X; if not FlagP(X, 'InternalFunction) then FindIDNumber X; if X eq MainEntryPointName!* then << !*MainFound := T; SpecialActionForMainEntryPoint() >> else CodeDeclareExportedUse Y; end; Procedure CodeDeclareExportedUse Y; if !*DeclareBeforeUse then << CodeDeclareExported Y; PrintLabel Y >> else << PrintLabel Y; CodeDeclareExported Y >>; lisp procedure FindEntryPoint X; begin scalar E; return if (E := get(X, 'EntryPoint)) then E else if ASMSymbolP X and not get(X, 'ASMSymbol) then << put(X, 'EntryPoint, X); X >> else << E := StringGenSym(); put(X, 'EntryPoint, E); E >>; end; lisp procedure ASMPseudoPrintFloat X; PrintF(DoubleFloatFormat!*, cadr X); put('Float, 'ASMPseudoOp, 'ASMPseudoPrintFloat); lisp procedure ASMPseudoPrintFullWord X; for each Y in cdr X do PrintFullWord Y; put('FullWord, 'ASMPseudoOp, 'ASMPseudoPrintFullWord); lisp procedure ASMPseudoPrintIndWord X; for each Y in cdr X do PrintIndWord Y; put('IndWord, 'ASMPseudoOp, 'ASMPseudoPrintIndWord); lisp procedure ASMPseudoPrintByte X; PrintByteList cdr X; put('Byte, 'ASMPseudoOp, 'ASMPseudoPrintByte); lisp procedure ASMPseudoPrintHalfWord X; PrintHalfWordList cdr X; put('HalfWord, 'ASMPseudoOp, 'ASMPseudoPrintHalfWord); lisp procedure ASMPseudoPrintString X; PrintString cadr X; put('String, 'ASMPseudoOp, 'ASMPseudoPrintString); lisp procedure PrintOperand X; if StringP X then Prin2 X else if NumberP X then PrintNumericOperand X else if IDP X then Prin2 FindLabel X else begin scalar Hd, Fn; Hd := car X; if (Fn := get(Hd, 'OperandPrintFunction)) then Apply(Fn, list X) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintOperand Apply(cdr Fn, list X) else if (Fn := WConstEvaluable X) then PrintOperand Fn else PrintExpression X; end; put('REG, 'OperandPrintFunction, 'PrintRegister); lisp procedure PrintRegister X; begin scalar Nam; X := cadr X; if StringP X then Prin2 X else if NumberP X then Prin2 GetV(NumericRegisterNames!*, X) else if Nam := RegisterNameP X then Prin2 Nam else << ErrorPrintF("***** Unknown register %r", X); Prin2 X >>; end; lisp procedure RegisterNameP X; get(X, 'RegisterName); lisp procedure ASMEntry X; PrintExpression list('plus2, 'SymFnc, list('times2, AddressingUnitsPerFunctionCell, list('IDLoc, cadr X))); put('Entry, 'OperandPrintFunction, 'ASMEntry); lisp procedure ASMInternalEntry X; Prin2 FindEntryPoint cadr X; put('InternalEntry, 'OperandPrintFunction, 'ASMInternalEntry); put('InternalEntry, 'ASMExpressionFunction, 'ASMInternalEntry); macro procedure ExtraReg U; list('plus2, '(WArray ArgumentBlock), (cadr U - (LastActualReg!& + 1)) * AddressingUnitsPerItem); lisp procedure ASMSyslispVarsPrint X; Prin2 FindGlobalLabel cadr X; DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'OperandPrintFunction); DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'ASMExpressionFunction); lisp procedure ASMPrintValueCell X; PrintExpression list('plus2, 'SymVal, list('times, AddressingUnitsPerItem, list('IDLoc, cadr X))); DefList('((fluid ASMPrintValueCell) (!$fluid ASMPrintValueCell) (global ASMPrintValueCell) (!$global ASMPrintValueCell)), 'OperandPrintFunction); % Redefinition of WDeclare for output to assembler file % if either UpperBound or Initializer are NIL, they are considered to be % unspecified. fexpr procedure WDeclare U; for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X); flag('(WDeclare), 'IGNORE); lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer); if Typ = 'WCONST then if Scope = 'EXTERNAL and not get(Name, 'WCONST) then ErrorPrintF("*** A value has not been defined for WConst %r", Name) else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); put(Name, 'WCONST, WConstReform Initializer) >> else << put(Name, Typ, Name); if Scope = 'EXTERNAL then << put(Name, 'SCOPE, 'EXTERNAL); if not RegisterNameP Name then % kludge to avoid declaring << Name := LookupOrAddASMSymbol Name; DataDeclareExternal Name; % registers as variables CodeDeclareExternal Name >> >> else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); Name := LookupOrAddASMSymbol Name; if !*DeclareBeforeUse then DataDeclareExported Name; DataInit(Name, Typ, UpperBound, Initializer); if not !*DeclareBeforeUse then DataDeclareExported Name; CodeDeclareExternal Name >> >>; lisp procedure DataInit(ASMSymbol, Typ, UpperBound, Initializer); << DataAlignFullWord(); if Typ = 'WVAR then << if UpperBound then ErrorPrintF "*** An UpperBound may not be specified for a WVar"; Initializer := if Initializer then WConstReform Initializer else 0; DataPrintVar(ASMSymbol, Initializer) >> else << if UpperBound and Initializer then ErrorPrintF "*** Can't have both UpperBound and initializer" else if not (UpperBound or Initializer) then ErrorPrintF "*** Must have either UpperBound or initializer" else if UpperBound then DataPrintBlock(ASMSymbol, WConstReform UpperBound, Typ) else << Initializer := if StringP Initializer then Initializer else WConstReformLis Initializer; DataPrintList(ASMSymbol, Initializer, Typ) >> >> >>; lisp procedure WConstReform U; begin scalar X; return if FixP U or StringP U then U else if IDP U then if get(U, 'WARRAY) or get(U, 'WSTRING) then U else if get(U,'WVAR) then list('GETMEM,U) else if (X := get(U, 'WCONST)) then X else ErrorPrintF("*** Unknown symbol %r in WConstReform", U) else if PairP U then if (X := get(car U, 'WConstReformPseudo)) then Apply(X, list U) else if (X := get(car U, 'DOFN)) then X . WConstReformLis cdr U else if MacroP car U then WConstReform Apply(cdr GetD car U, list U) else car U . WConstReformLis cdr U else ErrorPrintF("*** Illegal expression %r in WConstReform", U); end; lisp procedure WConstReformIdent U; U; put('InternalEntry, 'WConstReformPseudo, 'WConstReformIdent); lisp procedure WConstReformQuote U; CompileConstant cadr U; put('QUOTE, 'WConstReformPseudo, 'WConstReformQuote); lisp procedure WConstReformLis U; for each X in U collect WConstReform X; lisp procedure WConstReformLoc U; %. To handle &Foo[23] << U := WConstReform cadr U; if car U neq 'GETMEM then ErrorPrintF("*** Illegal constant addressing expression %r", list('LOC, U)) else cadr U >>; put('LOC, 'WConstReformPseudo, 'WConstReformLoc); lisp procedure WConstReformIDLoc U; FindIDNumber cadr U; put('IDLoc, 'WConstReformPseudo, 'WConstReformIDLoc); lisp procedure LookupOrAddASMSymbol U; begin scalar X; if not (X := get(U, 'ASMSymbol)) then X := AddASMSymbol U; return X; end; lisp procedure AddASMSymbol U; begin scalar X; X := if ASMSymbolP U and not get(U, 'EntryPoint) then U else StringGensym(); put(U, 'ASMSymbol, X); return X; end; lisp procedure DataPrintVar(Name, Init); begin scalar OldOut; DataPrintLabel Name; OldOut := WRS DataOut!*; PrintFullWord Init; WRS OldOut; end; lisp procedure DataPrintBlock(Name, Siz, Typ); << if Typ = 'WSTRING then Siz := list('quotient, list('plus2, Siz, CharactersPerWord + 1), CharactersPerWord) else Siz := list('plus2, Siz, 1); DataReserveZeroBlock(Name, Siz) >>; lisp procedure DataPrintList(Nam, Init, Typ); begin scalar OldOut; DataPrintLabel Nam; OldOut := WRS DataOut!*; if Typ = 'WSTRING then if StringP Init then << PrintFullWord Size Init; PrintString Init >> else << PrintFullWord(Length Init - 1); PrintByteList Append(Init, '(0)) >> else if StringP Init then begin scalar S; S := Size Init; for I := 0 step 1 until S do PrintFullWord Indx(Init, I); end else for each X in Init do PrintFullWord X; WRS OldOut; end; lisp procedure DataPrintGlobalLabel X; << if !*DeclareBeforeUse then DataDeclareExported X; DataPrintLabel X; if not !*DeclareBeforeUse then DataDeclareExported X; CodeDeclareExternal X >>; lisp procedure DataDeclareExternal X; if not (X member DataExternals!* or X member DataExporteds!*) then << DataExternals!* := X . DataExternals!*; DataPrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExternal X; if not (X member CodeExternals!* or X member CodeExporteds!*) then << CodeExternals!* := X . CodeExternals!*; CodePrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure DataDeclareExported X; << if X member DataExternals!* or X member DataExporteds!* then ErrorPrintF("***** %r multiply defined", X); DataExporteds!* := X . DataExporteds!*; DataPrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExported X; << if X member CodeExternals!* or X member CodeExporteds!* then ErrorPrintF("***** %r multiply defined", X); CodeExporteds!* := X . CodeExporteds!*; CodePrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure PrintLabel X; PrintF(LabelFormat!*, X,X); lisp procedure DataPrintLabel X; DataPrintF(LabelFormat!*, X,X); lisp procedure CodePrintLabel X; CodePrintF(LabelFormat!*, X,X); lisp procedure PrintComment X; PrintF(CommentFormat!*, X); PrintExpressionForm!* := list('PrintExpression, MkQuote NIL); PrintExpressionFormPointer!* := cdadr PrintExpressionForm!*; % Save some consing % instead of list('PrintExpression, MkQuote X), reuse the same list structure lisp procedure PrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); PrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure PrintIndWord X; << RplacA(PrintExpressionFormPointer!*, X); PrintF(IndWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); DataPrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure CodePrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); CodePrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveZeroBlock(Nam, X); << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveZeroBlockFormat!*, Nam, PrintExpressionForm!*) >>; lisp procedure DataReserveBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveFunctionCellBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerFunctionCell, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintUndefinedFunctionCell(); begin scalar OldOut; OldOut := WRS DataOut!*; for each X in UndefinedFunctionCellInstructions!* do ASMOutLap1 X; WRS OldOut; end; lisp procedure DataPrintDefinedFunctionCell X; <<DataDeclareExternal X; DataPrintF(DefinedFunctionCellFormat!*, X, X)>>; % in case it's needed twice lisp procedure DataPrintByteList X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintByteList X; WRS OldOut; end; lisp procedure DataPrintExpression X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintExpression X; WRS OldOut; end; lisp procedure CodePrintExpression X; begin scalar OldOut; OldOut := WRS CodeOut!*; PrintExpression X; WRS OldOut; end; ExpressionCount!* := -1; lisp procedure PrintExpression X; (lambda(ExpressionCount!*); begin scalar Hd, Tl, Fn; X := ResolveWConstExpression X; if NumberP X or StringP X then Prin2 X else if IDP X then Prin2 FindLabel X else if atom X then << ErrorPrintF("***** Oddity in expression %r", X); Prin2 X >> else << Hd := car X; Tl := cdr X; if (Fn := get(Hd, 'BinaryASMOp)) then << if ExpressionCount!* > 0 then Prin2 ASMOpenParen!*; PrintExpression car Tl; Prin2 Fn; PrintExpression cadr Tl; if ExpressionCount!* > 0 then Prin2 ASMCloseParen!* >> else if (Fn := get(Hd, 'UnaryASMOp)) then << Prin2 Fn; PrintExpression car Tl >> else if (Fn := get(Hd, 'ASMExpressionFormat)) then Apply('PrintF, Fn . for each Y in Tl collect list('PrintExpression, MkQuote Y)) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintExpression Apply(cdr Fn, list X) else if (Fn := get(Hd, 'ASMExpressionFunction)) then Apply(Fn, list X) else << ErrorPrintF("***** Unknown expression %r", X); PrintF("*** Expression error %r ***", X) >> >>; end)(ExpressionCount!* + 1); lisp procedure ASMPrintWConst U; PrintExpression cadr U; put('WConst, 'ASMExpressionFunction, 'ASMPrintWConst); DefList('((Plus2 !+) (WPlus2 !+) (Difference !-) (WDifference !-) (Times2 !*) (WTimes2 !*) (Quotient !/) (WQuotient !/)), 'BinaryASMOp); DefList('((Minus !-) (WMinus !-)), 'UnaryASMOp); lisp procedure CompileConstant X; << X := BuildConstant X; if null cdr X then car X else << If !*DeclareBeforeUse then CodeDeclareExported cadr X; ASMOutLap cdr X; DataDeclareExternal cadr X; If Not !*DeclareBeforeUse then CodeDeclareExported cadr X; car X >> >>; CommentOutCode << lisp procedure CompileHeapData X; begin scalar Y; X := BuildConstant X; return if null cdr X then car X else << Y := WRS DataOut!*; for each Z in cdr X do ASMOutLap1 Z; DataDeclareExported cadr X; WRS Y; car X >>; end; >>; lisp procedure DataPrintString X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintString X; WRS OldOut; end; lisp procedure FindLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else if (Y := get(X, 'ASMSymbol)) then Y else if (Y := get(X, 'WConst)) then Y else FindLocalLabel X; end; lisp procedure FindLocalLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else << LocalLabels!* := (X . (Y := StringGensym())) . LocalLabels!*; Y >>; end; lisp procedure FindGlobalLabel X; get(X, 'ASMSymbol) or ErrorPrintF("***** Undefined symbol %r", X); lisp procedure CodePrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS CodeOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; lisp procedure DataPrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS DataOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; % Kludge of the year, just to avoid having IDLOC defined during compilation CompileTime fluid '(MACRO); MACRO := 'MACRO; PutD('IDLoc, MACRO, function lambda X; FindIDNumber cadr X); END; |
Added psl-1983/3-1/comp/20/tags.red version [9d4ac7fc8a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.COMP.20.EXT>TAGS.RED.7, 1-Jun-83 08:10:26, Edit by KESSLER % Change BothTimes Declarations of wconsts to compiletime. on syslisp; % tags CompileTime << exported WConst TagStartingBit = 0, TagBitLength = 6, InfStartingBit = 6, InfBitLength = 30, GCStartingBit = 0, GCBitLength = 0, AddressingUnitsPerItem = 1, CharactersPerWord = 5, BitsPerWord = 36, AddressingUnitsPerFunctionCell = 1, StackDirection = 1; >>; off syslisp; CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure MidTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst) - 1) - 2, -1); macro procedure HighTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst)) - 1, -1); >>; % JumpInType and friends depend on the ordering and contiguity of % the numeric type tags. Fast arithmetic depends on PosInt = 0, % NegInt = -1. Garbage collectors depend on pointer tags being % between PosInt and Code, non-inclusive. /csp LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair, Evect); put('Code, 'WConst, 15); % Extended addressing treats negative word (one with aits high-order bit % on) as a local address--hence pointer types must have (positive) MidTags MidTags( ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); HighTags(NegInt); |
Added psl-1983/3-1/comp/anyreg-cmacro.sl version [88b7daffcf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% ANYREG-CMACRO.SL - Table-driven Anyreg and C-macro expander % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(ResultingCode!* TempLabel!* TempLabel2!*)) (* "Generated code is collected in reverse order in ResultingCode*") (CompileTime (flag '(SafePair PatternSublA WConstEvaluabLis AnyregPatternMatch1 MatchAll AnyregSubstitute1 TempLabelGen CMacroSubstitute1) 'InternalFunction)) (dm DefAnyreg (Form) (prog (AnyregName FunctionName Pattern) (setq Form (cdr Form)) (setq AnyregName (car Form)) (setq Form (cdr Form)) (setq FunctionName (car Form)) (setq Pattern (cdr Form)) (return (list 'progn (list 'put (MkQuote AnyregName) '(quote AnyregResolutionFunction) (MkQuote FunctionName)) (list 'put (MkQuote AnyregName) '(quote AnyregPatternTable) (MkQuote Pattern)))))) (dm DefCMacro (Form) (prog (CMacroName Pattern) (setq Form (cdr Form)) (setq CMacroName (car Form)) (setq Pattern (cdr Form)) (return (list 'progn (list 'flag (MkQuote (list CMacroName)) '(quote MC)) (list 'put (MkQuote CMacroName) '(quote CMacroPatternTable) (MkQuote Pattern)))))) (de ResolveOperand (Register Source) (prog (ResolveAnyregFunction) (return (cond ((IDP Source) (ResolveWConst Source)) ((atom Source) Source) ((FlagP (car Source) 'TerminalOperand) Source) ((setq ResolveAnyregFunction (get (car Source) 'AnyregResolutionFunction)) (Apply ResolveAnyregFunction (cons Register (cdr Source)))) (t (ResolveWConst Source)))))) (de ResolveWConst (Expression) (prog (ResolvedExpression) (setq ResolvedExpression (ResolveWConstExpression Expression)) (return (cond ((NumberP ResolvedExpression) ResolvedExpression) (t (list 'Immediate Expression)))))) (de ResolveWConstExpression (Expression) (cond ((EqCar Expression 'WConst) (ResolveWConstExpression (cadr Expression))) (t (prog (ResultExpression) (return (cond ((or (NumberP Expression) (StringP Expression)) Expression) ((IDP Expression) (cond ((setq ResultExpression (get Expression 'WConst)) ResultExpression) (t Expression))) (t (progn (cond ((MacroP (car Expression)) (return (ResolveWConstExpression (Apply (car Expression) (list Expression)))))) (setq Expression (cons (car Expression) (MapCar (cdr Expression) (Function ResolveWConstExpression)))) (cond ((setq ResultExpression (WConstEvaluable Expression)) ResultExpression) (t Expression)))))))))) (de WConstEvaluable (Expression) (prog (WC WCLis DoFn) (return (cond ((NumberP Expression) Expression) ((and (IDP Expression) (setq WC (get Expression 'WConst))) WC) ((and (PairP Expression) (IDP (setq WC (car Expression)))) (cond ((MacroP WC) (WConstEvaluable (apply (car Expression) (list Expression)))) ((and (or (and (setq DoFn (get WC 'DoFn)) (setq WC DoFn)) (not (FUnBoundP WC))) (not (eq (setq WCLis (WConstEvaluabLis (cdr Expression))) 'not))) (Eval (cons WC WCLis))) (T NIL))) (T NIL))))) (de WConstEvaluabLis (ExpressionTail) (prog (WC WCLis) (return (cond ((null ExpressionTail) NIL) ((not (setq WC (WConstEvaluable (car ExpressionTail)))) 'not) ((eq (setq WCLis (WConstEvaluabLis (cdr ExpressionTail))) 'not) 'not) (T (cons WC WCLis)))))) (de OneOperandAnyreg (Register Source AnyregName) (ExpandOneArgumentAnyreg Register (ResolveOperand Register Source) AnyregName)) (* "SecondArg must not require a register for evaluation. It is currently used only for (MEMORY reg const).") (de TwoOperandAnyreg (Register Source SecondArg AnyregName) (ExpandTwoArgumentAnyreg Register (ResolveOperand Register Source) (ResolveOperand '(REG Error) SecondArg) AnyregName)) (de ExpandOneArgumentAnyreg (Register Source AnyregName) (AnyregPatternExpand (list Register Source) (get AnyregName 'AnyregPatternTable))) (de ExpandTwoArgumentAnyreg (Register Source SecondArg AnyregName) (AnyregPatternExpand (list Register Source SecondArg) (get AnyregName 'AnyregPatternTable))) (de ExpandThreeArgumentAnyreg (Register Source SecondArg ThirdArg AnyregName) (AnyregPatternExpand (list Register Source SecondArg ThirdArg) (get AnyregName 'AnyregPatternTable))) (de AnyregPatternExpand (ArgumentList PatternTable) (AnyregSubstitute ArgumentList (AnyregPatternMatch (cdr ArgumentList) PatternTable))) (* "The label operand must not require a register to resolve.") (de Expand2OperandAndLabelCMacro (Arg1 Arg2 Label CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2) (ResolveOperand '(REG Error) Label)) (get CMacroName 'CMacroPatternTable))))) (de Expand4OperandCMacro (Arg1 Arg2 Arg3 Arg4 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2) (ResolveOperand '(REG Error) Arg3) (ResolveOperand '(REG Error) Arg4)) (get CMacroName 'CMacroPatternTable))))) (de Expand2OperandCMacro (Arg1 Arg2 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2)) (get CMacroName 'CMacroPatternTable))))) (de Expand1OperandCMacro (Arg1 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1)) (get CMacroName 'CMacroPatternTable))))) (de CMacroPatternExpand (ArgumentList PatternTable) (CMacroSubstitute ArgumentList (AnyregPatternMatch ArgumentList PatternTable))) (de AnyregPatternMatch (ArgumentList PatternTable) (cond ((null (cdr PatternTable)) (car PatternTable)) ((AnyregPatternMatch1 ArgumentList (caar PatternTable)) (cdar PatternTable)) (t (AnyregPatternMatch ArgumentList (cdr PatternTable))))) (de AnyregPatternMatch1 (ArgumentList PredicateOrPredicateList) (cond ((atom PredicateOrPredicateList) (Apply PredicateOrPredicateList ArgumentList)) (t (MatchAll ArgumentList PredicateOrPredicateList)))) (de MatchAll (ArgumentList PredicateList) (or (atom ArgumentList) (atom PredicateList) (and (Apply (car PredicateList) (list (car ArgumentList))) (MatchAll (cdr ArgumentList) (cdr PredicateList))))) (de AnyregSubstitute (ArgumentList CodeAndAddressExpressionList) (AnyregSubstitute1 (SafePair '(Register Source ArgTwo ArgThree) ArgumentList) CodeAndAddressExpressionList)) (de AnyregSubstitute1 (NameExpressionAList CodeAndAddressExpressionList) (cond ((null (cdr CodeAndAddressExpressionList)) (SublA NameExpressionAList (car CodeAndAddressExpressionList))) (t (progn (setq ResultingCode!* (cons (SublA NameExpressionAList (car CodeAndAddressExpressionList)) ResultingCode!*)) (AnyregSubstitute1 NameExpressionAList (cdr CodeAndAddressExpressionList)))))) (de CMacroSubstitute (ArgumentList CodeTemplateList) (prog (TempLabel!* TempLabel2!*) (return (CMacroSubstitute1 (SafePair '(ArgOne ArgTwo ArgThree ArgFour ArgFive) ArgumentList) CodeTemplateList)))) (de CMacroSubstitute1 (NameExpressionAList CodeTemplateList) (cond ((null CodeTemplateList) (ReversIP ResultingCode!*)) (t (progn (setq ResultingCode!* (cons (PatternSublA NameExpressionAList (car CodeTemplateList)) ResultingCode!*)) (CMacroSubstitute1 NameExpressionAList (cdr CodeTemplateList)))))) (de SafePair (CarList CdrList) (cond ((and (PairP CarList) (PairP CdrList)) (cons (cons (car CarList) (car CdrList)) (SafePair (cdr CarList) (cdr CdrList)))) (t NIL))) (de PatternSublA (AList Expression) (prog (X) (return (cond ((null Expression) Expression) ((atom Expression) (cond ((eq Expression 'TempLabel) (TempLabelGen 'TempLabel!*)) ((eq Expression 'TempLabel2) (TempLabelGen 'TempLabel2!*)) ((setq X (atsoc Expression AList)) (cdr X)) (t Expression))) (t (cons (PatternSublA AList (car Expression)) (PatternSublA AList (cdr Expression)))))))) (de TempLabelGen (X) ((lambda (Y) (cond ((StringP Y) Y) (T (set X (StringGensym))))) (Eval X))) |
Added psl-1983/3-1/comp/bare-psl.sym version [14527ad530].
> > > > | 1 2 3 4 | (setq OrderedIDList!* (NCons NIL)) (setq UncompiledExpressions!* (NCons NIL)) (setq ToBeCompiledExpressions!* (NCons NIL)) (setq NextIDNumber!* 129) |
Added psl-1983/3-1/comp/big-faslend.build version [8dcfaa402d].
> | 1 | in "big-faslend.red"$ |
Added psl-1983/3-1/comp/big-faslend.red version [14dcdf4b53].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BIG-FASLEND.RED - Patch to FASLEND for huge files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 7 May 1982 % Copyright (c) 1982 University of Utah % <PSL.COMP>BIG-FASLEND.RED.4, 10-Jun-82 10:39:32, Edit by GRISS % Added InitCodeMax!* for testing % lisp procedure CompileUncompiledExpressions(); <<ErrorPrintF("%n*** Init code length is %w%n", length car UncompiledExpressions!*); CompileInitCode('!*!*Fasl!*!*InitCode!*!*, car UncompiledExpressions!*)>>; FLUID '(InitCodeMax!*); LoadTime <<InitCodeMax!*:=350>>; lisp procedure CompileInitCode(Name, InitCodeList); begin scalar X, Len, LastHalf; return if ILessP(Len := length InitCodeList, InitCodeMax!*) then DfPrintFasl list('de, Name, '(), 'progn . InitCodeList) else << ErrorPrintF( "*** Initcode length %w too large, splitting into smaller pieces", Len); ErrorPrintF("*** Please use smaller files in FASL"); X := PNTH(InitCodeList, IQuotient(Len, 2)); LastHalf := cdr X; Rplacd(X, NIL); % tricky, split the code in 2 X := Intern Concat(ID2String Name, StringGensym()); Flag1(X, 'InternalFunction); % has to be internal to get called! CompileInitCode(X, InitCodeList); CompileInitCode(Name, list X . LastHalf) >>; % call previous end; |
Added psl-1983/3-1/comp/common-cmacros.sl version [f5e3ff0acf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% COMMON-CMACROS.SL - C-macros and Anyregs common to all implementations % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(NAlloc!* AddressingUnitsPerItem StackDirection ResultingCode!*)) (de !*Link (FunctionName FunctionType NumberOfArguments) (list (cond ((FlagP FunctionName 'ForeignFunction) (list '!*ForeignLink FunctionName FunctionType NumberOfArguments)) (t (list '!*Call FunctionName))))) (DefCMacro !*Link) (de !*Call (FunctionName) (prog (ResultingCode!* OpenCodeSequence) (return (cond ((setq OpenCodeSequence (get FunctionName 'OpenCode)) OpenCodeSequence) (t (CMacroPatternExpand (list FunctionName) (get '!*Call 'CMacroPatternTable))))))) (de !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) (cons (list '!*DeAlloc DeAllocCount) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments) '(!*Exit 0))) (t (list (list '!*JCall FunctionName)))))) (DefCMacro !*LinkE) (de !*JCall (FunctionName) (prog (ResultingCode!* OpenCodeSequence) (return (cond ((setq OpenCodeSequence (get FunctionName 'ExitOpenCode)) OpenCodeSequence) ((setq OpenCodeSequence (get FunctionName 'OpenCode)) (Append OpenCodeSequence (list '(!*Exit 0)))) (t (CMacroPatternExpand (list FunctionName) (get '!*JCall 'CMacroPatternTable))))))) (de !*DeAlloc (DeAllocCount) (Expand1OperandCMacro (times DeAllocCount AddressingUnitsPerItem) '!*DeAlloc)) (de !*Alloc (N) (progn (setq NAlloc!* N) (Expand1OperandCMacro (times N AddressingUnitsPerItem) '!*Alloc))) (de !*Exit (N) (Expand1OperandCMacro (times N AddressingUnitsPerItem) '!*Exit)) (de !*JumpWithin (Label LowerBound UpperBound) (prog (ExitLabel) (setq ExitLabel (list 'Label (GenSym))) (return (list (list '!*JumpWLessP ExitLabel '(Reg 1) LowerBound) (list '!*JumpWLeq Label '(Reg 1) UpperBound) (list '!*Lbl ExitLabel))))) (DefCMacro !*JumpWithin) (de !*ProgBind (FluidsList) (!*LamBind '(Registers) FluidsList)) (DefCMacro !*ProgBind) (de !*FreeRstr (FluidsList) (Expand1OperandCMacro (length (cdr FluidsList)) '!*FreeRstr)) (de !*Jump (Arg1) (Expand1OperandCMacro Arg1 '!*Jump)) (de !*Lbl (Arg1) (cdr Arg1)) (de !*Push (Arg1) (Expand1OperandCMacro Arg1 '!*Push)) (de !*Pop (Arg1) (Expand1OperandCMacro Arg1 '!*Pop)) (de !*Move (Source Destination) (prog (ResultingCode!* ResolvedDestination) (setq ResolvedDestination (ResolveOperand '(REG t2) Destination)) (return (CMacroPatternExpand (list (ResolveOperand (cond ((RegisterP ResolvedDestination) ResolvedDestination) (t '(REG t1))) Source) ResolvedDestination) (get '!*Move 'CMacroPatternTable))))) (de !*JumpEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpEQ)) (de !*JumpNotEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpNotEQ)) (de !*JumpWLessP (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWLessP)) (de !*JumpWGreaterP (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWGreaterP)) (de !*JumpWLEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWLEQ)) (de !*JumpWGEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWGEQ)) (de !*JumpType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpType)) (de !*JumpNotType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpNotType)) (de !*JumpInType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpInType)) (de !*JumpNotInType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpNotInType)) (de !*MkItem (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*MkItem)) (de !*WPlus2 (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WPlus2)) (de !*WDifference (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WDifference)) (de !*WTimes2 (Arg1 Arg2) (prog (P) (return (cond ((and (or (EqCar Arg2 'Quote) (EqCar Arg2 'WConst)) (setq P (PowerOf2P (cadr Arg2)))) (!*AShift Arg1 (list (car Arg2) P))) (t (Expand2OperandCMacro Arg1 Arg2 '!*WTimes2)))))) (* "PowerOf2P(X:integer):{integer,NIL} If X is a positive power of 2, log base 2 of X is returned. Otherwise NIL is returned.") (de PowerOf2P (X) (prog (N) (return (cond ((or (not (FixP X)) (MinusP X) (equal X 0)) NIL) (t (progn (setq N 0) (while (not (equal (lor x 1) x)) (progn (setq N (add1 N)) (setq X (lsh X -1)))) (cond ((equal X 1) N) (T NIL)))))))) (de !*AShift (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*AShift)) (de !*WShift (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WShift)) (de !*WAnd (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WAnd)) (de !*WOr (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WOr)) (de !*WXOr (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WXOr)) (de !*WMinus (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WMinus)) (de !*WNot (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WNot)) (de !*Loc (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*Loc)) (de !*Field (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*Field)) (de !*SignedField (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*SignedField)) (de !*PutField (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*PutField)) (de AnyregCAR (Register Source) (OneOperandAnyreg Register Source 'car)) (de AnyregCDR (Register Source) (OneOperandAnyreg Register Source 'cdr)) (de AnyregQUOTE (Register Source) (ExpandOneArgumentAnyreg Register Source 'quote)) (de AnyregWVAR (Register Source) (ExpandOneArgumentAnyreg Register Source 'WVar)) (de AnyregREG (Register Source) (ExpandOneArgumentAnyreg Register Source 'REG)) (de AnyregWCONST (Register Source) (OneOperandAnyreg Register Source 'WConst)) (DefAnyreg WCONST AnyregWCONST (SOURCE)) (de AnyregFRAME (Register Source) (ExpandOneArgumentAnyreg Register (times StackDirection AddressingUnitsPerItem (difference 1 Source)) 'Frame)) (de AnyregFRAMESIZE (Register) (times NAlloc!* AddressingUnitsPerItem)) (DefAnyreg FrameSize AnyregFRAMESIZE) (de AnyregMEMORY (Register Source ArgTwo) (TwoOperandAnyreg Register Source ArgTwo 'MEMORY)) (flag '(FLUID !$FLUID GLOBAL !$GLOBAL ExtraReg Label) 'TerminalOperand) (fluid '(labelgen*)) % a-list of tags and labels % (labelgen tag) and (labelref tag) can be used as either ANYREG or CMACRO. % (labelgen tag) creates and returns a unique label, (labelref tag) returns % the same one. Useful for 'OpenCode lists. (de anyreglabelgen (reg name) ((lambda (lb al) (cond ((null al) (setq labelgen* (cons (cons name lb) labelgen*))) (t (rplacd al lb))) lb) (gensym) (assoc name labelgen*))) (defanyreg labelgen anyreglabelgen) (de labelgen (name) (list (anyreglabelgen nil name))) (defcmacro labelgen) (de anyreglabelref (reg name) (cdr (assoc name labelgen*))) (defanyreg labelref anyreglabelref) (de labelref (name) (list (anyreglabelref nil name))) (defcmacro labelref) |
Added psl-1983/3-1/comp/common-predicates.sl version [e18b5b5696].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% COMMON-PREDICATES.SL - Predicates used for Anyreg and C-macro expansion % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(EntryPoints!* !*FastLinks)) (global '(!*R2I)) (de RegisterP (Expression) (EqCar Expression 'REG)) (de AnyP (Expression) T) (de TaggedLabel (X) (EqCar X 'Label)) (de EqTP (Expression) (equal Expression T)) (de MinusOneP (Expression) (equal Expression -1)) (de InternallyCallableP (X) % only when writing a file (and (or !*WritingFaslFile (not (FUnBoundP 'AsmOut))) (or !*FastLinks (and !*R2I (memq X EntryPoints!*)) (FlagP X 'InternalFunction) (FlagP X 'FastLink)))) (de AddressConstantP (Expression) (or (atom Expression) (equal (car Expression) 'Immediate))) |
Added psl-1983/3-1/comp/comp-decls.build version [df33a3fc05].
> | 1 | in "comp-decls.red"$ |
Added psl-1983/3-1/comp/comp-decls.red version [d852803e8e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMP-DECLS.RED - Machine-independent declaractions used by the compiler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.COMP>COMP-DECLS.RED.16, 3-Sep-82 09:46:43, Edit by BENSON % Added PA1REFORMFN for WNOT % <PSL.COMP>COMP-DECLS.RED.5, 3-Dec-82 18:20:08, Edit by PERDUE % Removed PA1REFORMFN for NE % <PSL.COMP>COMP-DECLS.RED.6, 24-Jan-83 16:04:00, Edit by MLGriss % Changed W to !%!%!%W in the EQCAR to avoid subst W into EQCAR form % Pass 1 functions put('Apply, 'PA1FN, '!&PaApply); PUT('ASSOC, 'PA1FN, '!&PAASSOC); PUT('EQUAL, 'PA1FN, '!&PAEQUAL); PUT('MEMBER, 'PA1FN, '!&PAMEMBER); put('Catch, 'Pa1Fn, '!&PaCatch); PUT('COND, 'PA1FN, '!&PACOND); PUT('DIFFERENCE,'PA1FN, '!&PADIFF); PUT('FUNCTION, 'PA1FN, '!&PAFUNCTION); PUT('GETMEM, 'PA1FN, '!&PAGETMEM); PUT('GO, 'PA1FN, '!&PAIDENT); PUT('CASE, 'PA1FN, '!&PACASE); PUT('INTERN, 'PA1FN, '!&PAINTERN); PUT('LAMBDA, 'PA1FN, '!&PALAMBDA); PUT('LESSP, 'PA1FN, '!&PALESSP); PUT('LIST, 'PA1FN, '!&PALIST); PUT('LOC, 'PA1REFORMFN, '!&REFORMLOC); PUT('MAP, 'PA1FN, '!&PAMAP); PUT('MAPC, 'PA1FN, '!&PAMAPC); PUT('MAPCAN, 'PA1FN, '!&PAMAPCAN); PUT('MAPCAR, 'PA1FN, '!&PAMAPCAR); PUT('MAPCON, 'PA1FN, '!&PAMAPCON); PUT('MAPLIST, 'PA1FN, '!&PAMAPLIST); PUT('MINUS, 'PA1FN, '!&PAMINUS); PUT('NULL, 'PA1REFORMFN, '!&REFORMNULL); % PUT('NE, 'PA1REFORMFN, '!&REFORMNE); % Perdue 12/3/82 put('Nth, 'Pa1Fn, '!&PaNth); put('PNth, 'Pa1Fn, '!&PaPNth); PUT('PLUS2, 'PA1FN, '!&PAPLUS2); PUT('PROG, 'PA1FN, '!&PAPROG); PUT('PUTMEM, 'PA1FN, '!&PAPUTMEM); PUT('PUTLISPVAR,'PA1FN, '!&PAPUTLISPVAR); PUT('LISPVAR, 'PA1FN, '!&PALISPVAR); PUT('QUOTE, 'PA1FN, '!&PAIDENT); PUT('WCONST, 'PA1FN, '!&PAWCONST); PUT('SETQ, 'PA1FN, '!&PASETQ); PUT('WPLUS2, 'PA1FN, '!&GROUP); PUT('WDIFFERENCE,'PA1FN, '!&GROUP); PUT('WMINUS, 'PA1FN, '!&GROUP); PUT('WTIMES2, 'PA1FN, '!&ASSOCOP); PUT('WAND, 'PA1FN, '!&ASSOCOP); PUT('WOR, 'PA1FN, '!&ASSOCOP); PUT('WXOR, 'PA1FN, '!&ASSOCOP); PUT('WPLUS2, 'PA1ALGFN, '!&GROUPV); PUT('WDIFFERENCE,'PA1ALGFN, '!&GROUPV); PUT('WMINUS, 'PA1ALGFN, '!&GROUPV); PUT('WTIMES2, 'PA1ALGFN, '!&ASSOCOPV); PUT('WAND, 'PA1ALGFN, '!&ASSOCOPV); PUT('WOR, 'PA1ALGFN, '!&ASSOCOPV); PUT('WXOR, 'PA1ALGFN, '!&ASSOCOPV); PUT('WSHIFT, 'PA1REFORMFN, '!&DOOP); PUT('WNOT, 'PA1REFORMFN, '!&DOOP); put('WTimes2, 'PA1Reformfn, function !&PaReformWTimes2); % Simplification PUT('WPLUS2, 'DOFN, 'PLUS2); PUT('WDIFFERENCE,'DOFN, 'DIFFERENCE); PUT('WMINUS, 'DOFN, 'MINUS); PUT('WTIMES2, 'DOFN, 'TIMES2); PUT('WQUOTIENT, 'DOFN, 'QUOTIENT); PUT('WREMAINDER,'DOFN, 'REMAINDER); PUT('WAND, 'DOFN, 'LAND); PUT('WOR, 'DOFN, 'LOR); PUT('WXOR, 'DOFN, 'LXOR); PUT('WNOT, 'DOFN, 'LNOT); PUT('WSHIFT, 'DOFN, 'LSHIFT); PUT('WTIMES2, 'ONE, 1); PUT('WTIMES2, 'ZERO, 0); PUT('WPLUS2, 'ONE, 0); PUT('WPLUS2, 'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WMINUS, 'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WDIFFERENCE,'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WAND, 'ZERO, 0); PUT('WOR, 'ONE, 0); PUT('WXOR, 'ONE, 0); % Compile functions PUT('AND, 'COMPFN, '!&COMANDOR); PUT('APPLY, 'COMPFN, '!&COMAPPLY); PUT('COND, 'COMPFN, '!&COMCOND); PUT('CONS, 'COMPFN, '!&COMCONS); PUT('GO, 'COMPFN, '!&COMGO); PUT('CASE, 'COMPFN, '!&COMCASE); PUT('OR, 'COMPFN, '!&COMANDOR); PUT('PROG, 'COMPFN, '!&COMPROG); PUT('PROG2, 'COMPFN, '!&COMPROGN); PUT('PROGN, 'COMPFN, '!&COMPROGN); PUT('RETURN, 'COMPFN, '!&COMRETURN); % Patterns for the tests and SETQ PUT('EQ, 'OPENTST, '(TSTPAT !*JUMPEQ)); PUT('EQ, 'OPENFN, '(TVPAT !*JUMPEQ)); PUT('NE, 'OPENTST, '(TSTPAT !*JUMPNOTEQ)); PUT('NE, 'OPENFN, '(TVPAT !*JUMPNOTEQ)); PUT('AND, 'OPENTST, '!&TSTANDOR); PUT('OR, 'OPENTST, '!&TSTANDOR); PUT('PAIRP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE PAIR)); PUT('ATOM, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE PAIR)); PUT('STRINGP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE STR)); PUT('NOTSTRINGP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE STR)); PUT('VECTORP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE VECT)); PUT('NOTVECTORP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE VECT)); PUT('CODEP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE CODE)); PUT('NOTCODEP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE CODE)); PUT('FLOATP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE FLTN)); PUT('NOTFLOATP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE FLTN)); PUT('INTP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE POSINT)); PUT('NOTINTP, 'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE POSINT)); PUT('FIXP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE BIGN)); PUT('NOTFIXP, 'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE BIGN)); PUT('NUMBERP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE FLTN)); PUT('NOTNUMBERP,'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE FLTN)); PUT('FIXNP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE FIXN)); PUT('NOTFIXNP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE FIXN)); PUT('BIGP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE BIGN)); PUT('NOTBIGP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE BIGN)); PUT('POSINTP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE POSINT)); PUT('NOTPOSINTP,'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE POSINT)); PUT('NEGINTP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE NEGINT)); PUT('NOTNEGINTP,'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE NEGINT)); PUT('IDP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE ID)); PUT('NOTIDP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE ID)); PUT('BYTESP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE BYTES)); PUT('NOTBYTESP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE BYTES)); PUT('WRDSP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE WRDS)); PUT('NOTWRDSP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE WRDS)); PUT('HALFWORDSP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE HALFWORDS)); PUT('NOTHALFWORDSP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE HALFWORDS)); PUT('PAIRP, 'OPENFN, '(TVPAT1 !*JUMPTYPE PAIR)); PUT('ATOM, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE PAIR)); PUT('STRINGP, 'OPENFN, '(TVPAT1 !*JUMPTYPE STR)); PUT('NOTSTRINGP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE STR)); PUT('VECTORP, 'OPENFN, '(TVPAT1 !*JUMPTYPE VECT)); PUT('NOTVECTORP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE VECT)); PUT('CODEP, 'OPENFN, '(TVPAT1 !*JUMPTYPE CODE)); PUT('NOTCODEP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE CODE)); PUT('FLOATP, 'OPENFN, '(TVPAT1 !*JUMPTYPE FLTN)); PUT('NOTFLOATP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE FLTN)); PUT('INTP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE POSINT)); PUT('NOTINTP, 'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE POSINT)); PUT('FIXP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE BIGN)); PUT('NOTFIXP, 'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE BIGN)); PUT('NUMBERP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE FLTN)); PUT('NOTNUMBERP,'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE FLTN)); PUT('FIXNP, 'OPENFN, '(TVPAT1 !*JUMPTYPE FIXN)); PUT('NOTFIXNP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE FIXN)); PUT('BIGP, 'OPENFN, '(TVPAT1 !*JUMPTYPE BIGN)); PUT('NOTBIGP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE BIGN)); PUT('POSINTP, 'OPENFN, '(TVPAT1 !*JUMPTYPE POSINT)); PUT('NOTPOSINTP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE POSINT)); PUT('NEGINTP, 'OPENFN, '(TVPAT1 !*JUMPTYPE NEGINT)); PUT('NOTNEGINTP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE NEGINT)); PUT('IDP, 'OPENFN, '(TVPAT1 !*JUMPTYPE ID)); PUT('NOTIDP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE ID)); PUT('BYTESP, 'OPENFN, '(TVPAT1 !*JUMPTYPE BYTES)); PUT('NOTBYTESP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE BYTES)); PUT('WRDSP, 'OPENFN, '(TVPAT1 !*JUMPTYPE WRDS)); PUT('NOTWRDSP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE WRDS)); PUT('HALFWORDSP, 'OPENFN, '(TVPAT1 !*JUMPTYPE HALFWORDS)); PUT('NOTHALFWORDSP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE HALFWORDS)); PUT('SETQ, 'OPENFN, '(SETQPAT NIL)); PUT('RPLACA, 'OPENFN, '(RPLACPAT CAR)); PUT('RPLACD, 'OPENFN, '(RPLACPAT CDR)); PUT('WPLUS2, 'OPENFN, '(ASSOCPAT !*WPLUS2)); PUT('WDIFFERENCE,'OPENFN, '(SUBPAT !*WDIFFERENCE)); PUT('WTIMES2, 'OPENFN, '(ASSOCPAT !*WTIMES2)); PUT('WMINUS, 'OPENFN, '(UNARYPAT !*WMINUS)); PUT('WAND, 'OPENFN, '(ASSOCPAT !*WAND)); PUT('WOR, 'OPENFN, '(ASSOCPAT !*WOR)); PUT('WXOR, 'OPENFN, '(ASSOCPAT !*WXOR)); PUT('WNOT, 'OPENFN, '(UNARYPAT !*WNOT)); PUT('WSHIFT, 'OPENFN, '(NONASSOCPAT !*WSHIFT)); PUT('MKITEMREV, 'OPENFN, '(NONASSOCPAT !*MKITEM)); PUT('LOC, 'OPENFN, '(UNARYPAT !*LOC)); PUT('!*ADDMEM, 'OPENFN, '(MODMEMPAT !*ADDMEM)); PUT('!*MPYMEM, 'OPENFN, '(MODMEMPAT !*MPYMEM)); PUT('FIELD, 'OPENFN, '(FIELDPAT !*FIELD)); PUT('SIGNEDFIELD,'OPENFN, '(FIELDPAT !*SIGNEDFIELD)); PUT('PUTFIELDREV,'OPENFN, '(PUTFIELDPAT !*PUTFIELD)); PUT('WGREATERP,'OPENTST, '(TSTPATC !*JUMPWGREATERP !*JUMPWLESSP)); PUT('WLEQ, 'OPENTST, '(TSTPATC !*JUMPWLEQ !*JUMPWGEQ)); PUT('WGEQ, 'OPENTST, '(TSTPATC !*JUMPWGEQ !*JUMPWLEQ)); PUT('WLESSP, 'OPENTST, '(TSTPATC !*JUMPWLESSP !*JUMPWGREATERP)); PUT('WGREATERP, 'OPENFN, '(TVPAT !*JUMPWGREATERP)); PUT('WLEQ, 'OPENFN, '(TVPAT !*JUMPWLEQ)); PUT('WGEQ, 'OPENFN, '(TVPAT !*JUMPWGEQ)); PUT('WLESSP, 'OPENFN, '(TVPAT !*JUMPWLESSP)); PUT('EQ,'FLIPTST,'NE); PUT('NE,'FLIPTST,'EQ); PUT('ATOM,'FLIPTST,'PAIRP); PUT('PAIRP,'FLIPTST,'ATOM); PUT('STRINGP,'FLIPTST,'NOTSTRINGP); PUT('NOTSTRINGP,'FLIPTST,'STRINGP); PUT('BytesP,'FLIPTST,'NOTBytesP); PUT('NOTBytesP,'FLIPTST,'BytesP); PUT('WrdsP,'FLIPTST,'NOTWrdsP); PUT('NOTWrdsP,'FLIPTST,'WrdsP); PUT('HalfwordsP,'FLIPTST,'NOTHalfwordsP); PUT('NOTHalfwordsP,'FLIPTST,'HalfwordsP); PUT('CODEP,'FLIPTST,'NOTCODEP); PUT('NOTCODEP, 'FLIPTST,'CODEP); PUT('IDP,'FLIPTST,'NOTIDP); PUT('NOTIDP,'FLIPTST,'IDP); PUT('INTP,'FLIPTST,'NOTINTP); PUT('NOTINTP,'FLIPTST,'INTP); PUT('POSINTP,'FLIPTST,'NOTPOSINTP); PUT('NOTPOSINTP,'FLIPTST,'POSINTP); PUT('NEGINTP,'FLIPTST,'NOTNEGINTP); PUT('NOTNEGINTP,'FLIPTST,'NEGINTP); PUT('FIXP,'FLIPTST,'NOTFIXP); PUT('NOTFIXP,'FLIPTST,'FIXP); PUT('NUMBERP,'FLIPTST,'NOTNUMBERP); PUT('NOTNUMBERP,'FLIPTST,'NUMBERP); PUT('FIXNP,'FLIPTST,'NOTFIXNP); PUT('NOTFIXNP,'FLIPTST,'FIXNP); PUT('FLOATP,'FLIPTST,'NOTFLOATP); PUT('NOTFLOATP,'FLIPTST,'FLOATP); PUT('BIGP,'FLIPTST,'NOTBIGP); PUT('NOTBIGP,'FLIPTST,'BIGP); PUT('VECTORP,'FLIPTST,'NOTVECTORP); PUT('NOTVECTORP,'FLIPTST,'VECTORP); PUT('WLESSP,'FLIPTST,'WGEQ); PUT('WGEQ,'FLIPTST,'WLESSP); PUT('WLEQ,'FLIPTST,'WGREATERP); PUT('WGREATERP,'FLIPTST,'WLEQ); % Match functions PUT('ANY,'MATCHFN,'!&ANY); PUT('VAR,'MATCHFN,'!&VAR); PUT('REG,'MATCHFN,'!®FP); PUT('DEST,'MATCHFN,'!&DEST); PUT('USESDEST,'MATCHFN,'!&USESDEST); PUT('REGN,'MATCHFN,'!®N); PUT('NOTDEST,'MATCHFN,'!&NOTDEST); PUT('NOTANYREG,'MATCHFN,'!&NOTANYREG); PUT('MEM,'MATCHFN,'!&MEM); PUT('ANYREGFN,'MATCHFN,'!&ANYREGFNP); % Tag properties FLAG('(!$LOCAL !$GLOBAL !$FLUID QUOTE WCONST IDLOC WVAR REG LABEL FRAME !*FRAMESIZE IREG), 'TERMINAL); FLAG('(!$LOCAL !$GLOBAL !$FLUID WVAR),'VAR); FLAG('(QUOTE WCONST IDLOC FRAMESIZE),'CONST); FLAG('(REG),'REG); FLAG('(!$FLUID !$GLOBAL),'EXTVAR); FLAG('(CAR CDR !$NAME MEMORY FRAMESIZE), 'ANYREG); FLAG('(!*ADDMEM !*MPYMEM),'MEMMOD); % Optimizing functions PUT('!*LBL, 'OPTFN, '!&LBLOPT); PUT('!*MOVE, 'OPTFN, '!&STOPT); PUT('!*JUMP, 'OPTFN, '!&JUMPOPT); % Things which can be compiled FLAG('(EXPR FEXPR MACRO NEXPR),'COMPILE); % Some compiler macros DEFLIST('((CAAR (LAMBDA (U) (CAR (CAR U)))) (CADR (LAMBDA (U) (CAR (CDR U)))) (CDAR (LAMBDA (U) (CDR (CAR U)))) (CDDR (LAMBDA (U) (CDR (CDR U)))) (CAAAR (LAMBDA (U) (CAR (CAR (CAR U))))) (CAADR (LAMBDA (U) (CAR (CAR (CDR U))))) (CADAR (LAMBDA (U) (CAR (CDR (CAR U))))) (CADDR (LAMBDA (U) (CAR (CDR (CDR U))))) (CDAAR (LAMBDA (U) (CDR (CAR (CAR U))))) (CDADR (LAMBDA (U) (CDR (CAR (CDR U))))) (CDDAR (LAMBDA (U) (CDR (CDR (CAR U))))) (CDDDR (LAMBDA (U) (CDR (CDR (CDR U))))) (EQCAR (LAMBDA (U V) ((LAMBDA (!%!%!%W) (AND (PAIRP !%!%!%W) (EQ (CAR !%!%!%W) V))) U))) (CONSTANTP (LAMBDA (U) ((LAMBDA (V) (NOT (OR (PAIRP V) (IDP V)))) U))) (WEQ (LAMBDA (U V) (EQ U V))) (WNEQ (LAMBDA (U V) (NE U V))) (IPLUS2 (LAMBDA (U V) (WPLUS2 U V))) (IADD1 (LAMBDA (U) (WPLUS2 U 1))) (IDIFFERENCE (LAMBDA (U V) (WDIFFERENCE U V))) (ISUB1 (LAMBDA (U) (WDIFFERENCE U 1))) (ITIMES2 (LAMBDA (U V) (WTIMES2 U V))) (IQUOTIENT (LAMBDA (U V) (WQUOTIENT U V))) (IREMAINDER (LAMBDA (U V) (WREMAINDER U V))) (IGREATERP (LAMBDA (U V) (WGREATERP U V))) (ILESSP (LAMBDA (U V) (WLESSP U V))) (ILEQ (LAMBDA (U V) (WLEQ U V))) (IGEQ (LAMBDA (U V) (WGEQ U V))) (ILOR (LAMBDA (U V) (WOR U V))) (ILSH (LAMBDA (U V) (WSHIFT U V))) (ILAND (LAMBDA (U V) (WAND U V))) (ILXOR (LAMBDA (U V) (WXOR U V))) (IZEROP (LAMBDA (U) (EQ U 0))) (IONEP (LAMBDA (U) (EQ U 1))) (IMINUSP (LAMBDA (U) (WLESSP U 0))) (IMINUS (LAMBDA (U) (WMINUS U))) (PUTFIELD (LAMBDA (U V W X) (PUTFIELDREV X U V W))) (MKITEM (LAMBDA (U V) (MKITEMREV V U))) (NEQ (LAMBDA (U V) (NOT (EQUAL U V)))) (GEQ (LAMBDA (U V) (NOT (LESSP U V)))) (LEQ (LAMBDA (U V) (NOT (GREATERP U V)))) (NOT (LAMBDA (U) (NULL U)))),'CMACRO); % Macro functions PUT('A1,'SUBSTFN,'!&ARG1); PUT('A2,'SUBSTFN,'!&ARG2); PUT('A3,'SUBSTFN,'!&ARG3); PUT('A4,'SUBSTFN,'!&ARG4); PUT('FN,'SUBSTFN,'!&PARAM1); PUT('MAC,'SUBSTFN,'!&PARAM2); PUT('P2,'SUBSTFN,'!&PARAM3); PUT('P3,'SUBSTFN,'!&PARAM4); PUT('T1,'SUBSTFN,'!&GETTEMP); PUT('T2,'SUBSTFN,'!&GETTEMP); PUT('T3,'SUBSTFN,'!&GETTEMP); PUT('T4,'SUBSTFN,'!&GETTEMP); PUT('L1,'SUBSTFN,'!&GETTEMPLBL); PUT('L2,'SUBSTFN,'!&GETTEMPLBL); PUT('L3,'SUBSTFN,'!&GETTEMPLBL); PUT('L4,'SUBSTFN,'!&GETTEMPLBL); % Emit functions PUT('!*LOAD,'EMITFN,'!&EMITLOAD); PUT('!*STORE,'EMITFN,'!&EMITSTORE); PUT('!*JUMP,'EMITFN,'!&EMITJUMP); PUT('!*LBL,'EMITFN,'!&EMITLBL); PUT('!*ADDMEM,'EMITFN,'!&EMITMEMMOD); PUT('!*MPYMEM,'EMITFN,'!&EMITMEMMOD); PUT('!*ADDMEM, 'UNMEMMOD, '!*WPLUS2); PUT('!*MPYMEM, 'UNMEMMOD, '!*WTIMES2); % In memory operations PUT('WPLUS2,'MEMMODFN,'!*ADDMEM); PUT('WTIMES2,'MEMMODFN,'!*MPYMEM); % Flip jump for conditional jump macros PUT('!*JUMPEQ,'NEGJMP,'!*JUMPNOTEQ); PUT('!*JUMPNOTEQ,'NEGJMP,'!*JUMPEQ); PUT('!*JUMPTYPE,'NEGJMP,'!*JUMPNOTTYPE); PUT('!*JUMPNOTTYPE,'NEGJMP,'!*JUMPTYPE); PUT('!*JUMPINTYPE,'NEGJMP,'!*JUMPNOTINTYPE); PUT('!*JUMPNOTINTYPE,'NEGJMP,'!*JUMPINTYPE); PUT('!*JUMPWEQ,'NEGJMP,'!*JUMPWNEQ); PUT('!*JUMPWNEQ,'NEGJMP,'!*JUMPWEQ); PUT('!*JUMPWLESSP,'NEGJMP,'!*JUMPWGEQ); PUT('!*JUMPWGEQ,'NEGJMP,'!*JUMPWLESSP); PUT('!*JUMPWLEQ,'NEGJMP,'!*JUMPWGREATERP); PUT('!*JUMPWGREATERP,'NEGJMP,'!*JUMPWLEQ); % Assorted other flags FLAG('(!*JUMP !*LINKE !*EXIT),'TRANSFER); FLAG('(!*LINK !*LINKE),'UNKNOWNUSE); PUT('!*LINK, 'EXITING, '!*LINKE); % Initialize variables !*MSG := T; % Do print messages !*INSTALLDESTROY := NIL; !*USINGDESTROY := T; !*SHOWDEST := NIL; !*NOFRAMEFLUID := T; !*USEREGFLUID := NIL; !*NOLINKE := NIL; %. Permit LINKE !*ORD := NIL; %. Dont force ORDER !*R2I := T; %. Do convert Rec to Iter GLOBALGENSYM!&:=LIST GENSYM(); % initialize symbol list MAXNARGS!&:=15; LASTACTUALREG!& := 5; END; |
Added psl-1983/3-1/comp/compiler.build version [7c5494f6df].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | CompileTime << load If!-System; >>; if_system(PDP10, << imports '(comp!-decls pass!-1!-lap dec20!-lap dec20!-cmac faslout); if_system(KL10, NIL, imports '(non!-kl!-comp)); >>); if_system(VAX, imports '(comp!-decls pass!-1!-lap vax!-lap vax!-cmac faslout)); if_system(HP9836, imports '(comp!-decls pass!-1!-lap hp!-lap hp!-cmac hp!-comp faslout)); in "compiler.red"$ |
Added psl-1983/3-1/comp/compiler.ctl version [0806832b87].
> > > > > | 1 2 3 4 5 | psl:rlisp loaddirectories!*:='("pl:"); load build; build 'compiler; quit; |
Added psl-1983/3-1/comp/compiler.log version [5609eb7b14].
cannot compute difference between binary files
Added psl-1983/3-1/comp/compiler.red version [afd6baa852].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 | % MLG: 15 Dec % added additional arguments to % Compiler BUG message in &LOCATE to get more info % <PSL.COMP>COMPILER.RED.19, 3-Dec-82 18:21:21, Edit by PERDUE % Removed REFORMNE, which was over-optimizing sometimes % <PSL.COMP>COMPILER.RED.18, 1-Dec-82 15:59:45, Edit by BENSON % Fixed car of atom bug in &PaApply % New extended compiler for PSL % John Peterson 4-5-81 % <PSL.COMP>COMPILER.RED.4, 20-Sep-82 11:40:31, Edit by BENSON % Slight improvement to "FOO not compiled" messages % <PSL.COMP>COMPILER.RED.2, 20-Sep-82 10:32:51, Edit by BENSON % (DE FOO (LIST) (LIST LIST)) does the right thing % <PSL.COMP>COMPILER.RED.10, 10-Sep-82 12:43:27, Edit by BENSON % NONLOCALSYS calls NONLOCALLISP if not WVAR or WARRAY % <PSL.COMP>COMPILER.RED.9, 10-Sep-82 09:53:08, Edit by BENSON % Changed error and warning messages CompileTime flag( '(!&COMPERROR !&COMPWARN !&IREG !&ADDRVALS !&ALLARGS1 !&ALLCONST !&ANYREG !&ANYREGL !&ANYREGP !&ARGLOC !&ASSOCOP1 !&ASSOCOP2 !&ATTACH !&ATTJMP !&ATTLBL !&CALL !&CALL1 !&CALLOPEN !&CFNTYPE !&CLASSMEMBER !&CLRSTR !&COMLIS !&COMLIS1 !&COMOPENTST !&COMPLY !&COMTST !&COMVAL !&COMVAL1 !&CONSTTAG !&DEFEQLBL !&DEFEQLBL1 !&DELARG !&DELCLASS !&DELETEMAC !&DELMAC !&EMITMAC !&EQP !&EQPL !&EQVP !&EXTERNALVARP !&FIXCHAINS !&FIXFRM !&FIXLABS !&FIXLINKS !&FIXREGTEST1 !&FRAME !&FREERSTR !&GENLBL !&GENSYM !&GETFRAMES !&GETFRAMES1 !&GETFRAMES2 !&GETFRM !&GETFVAR !&GETGROUPARGS !&GETGROUPARGS1 !&GETGROUPARGS2 !&GETLBL !&GETNUM !&HIGHEST !&HIGHEST1 !&HIGHEST2 !&INALL !&INSERTMAC !&INSOP !&INSOP1 !&INSTALLDESTROY !&INSTBL !&JUMPNIL !&JUMPT !&LABCLASS !&LBLEQ !&LOADARGS !&LOADOPENEXP !&LOADTEMP1 !&LOADTEMP2 !&LOADTEMPREG !&LOCATE !&LOCATEL !&LREG !&LREG1 !&MACROSUBST !&MACROSUBST1 !&MACROSUBST2 !&MAKEADDRESS !&MAKEXP !&MATCHES !&MEMADDRESS !&MKFRAME !&MKFUNC !&MKNAM !&MKPROGN !&MKREG !&MOVEJUMP &NOANYREG1 !&NOSIDEEFFECTP !&NOSIDEEFFECTPL !&OPENFNP !&OPENP !&OPENPL !&PA1V !&PALISV !&PA1X !&PAASSOC1 !&PAEQUAL1 !&PALIS !&PAMAPCOLLECT !&PAMAPCONC !&PAMAPDO !&PAMEMBER1 !&PANONLOCAL !&PAPROGBOD !&PASS1 !&PASS2 !&PASS3 !&PEEPHOLEOPT !&PROTECT !&RASSOC !&REFERENCES !&REFERENCESL !&REFEXTERNAL !&REFEXTERNALL !&REFMEMORY !&REFMEMORYL !&REFORMMACROS !®P !®VAL !&REMCODE !&REMMREFS !&REMMREFS1 !&REMOPEN !&REMREFS !&REMREFS1 !&REMREGS !&REMREGSL !&REMTAGS !&REMTAGS1 !&REMTAGS2 !&REMTAGS3 !&REMTAGS4 !&REMUNUSEDMAC !&REMVARL !&REMVREFS !&REMVREFS1 !&REPASC !&RMERGE !&RSTVAR !&RSTVARL !&RVAL !&SAVER1 !&STORELOCAL !&STOREVAR !&SUBARG !&SUBARGS !&TEMPREG !&TRANSFERP !&UNPROTECT !&UNUSEDLBLS !&USESDESTL !&VARBIND !&VARP !&WCONSTP !&CONSTP ISAWCONST MKNONLOCAL MKWCONST NONLOCAL NONLOCALLISP NONLOCALSYS PA1ERR WARRAYP WCONSTP WVARP), 'InternalFunction); GLOBAL '(ERFG!* !*NOLINKE !*ORD !*R2I !*UNSAFEBINDER MAXNARGS!& !*NOFRAMEFLUID !*USEREGFLUID !*INSTALLDESTROY !*USINGDESTROY !*SHOWDEST GLOBALGENSYM!&); % list of symbols to be re-used by the compiler FLUID '(ALSTS!& FLAGG!& NAME!& GOLIST!& CODELIST!& CONDTAIL!& LLNGTH!& NARG!& REGS!& EXITT!& LBLIST!& JMPLIST!& SLST!& STOMAP!& LASTACTUALREG!& DFPRINT!* !*PLAP !*SYSLISP SWITCH!& TOPLAB!& FREEBOUND!& STATUS!& REGS1!& PREGS!& DESTREG!& EXITREGS!& DEST!& ENVIRONMENT!& HOLEMAP!& LOCALGENSYM!&); % traveling pointer into GLOBALGENSYM!& %COMMENT ************************************************************** %********************************************************************** % THE STANDARD LISP COMPILER %********************************************************************** % Augmented for SYSLISP %*********************************************************************; % %COMMENT machine dependent parts are in a separate file; % %COMMENT these include the macros described below and, in addition, % an auxiliary function !&MKFUNC which is required to pass % functional arguments (input as FUNCTION <func>) to the % loader. In most cases, !&MKFUNC may be defined as MKQUOTE; % %COMMENT Registers used: %1-MAXNARGS!& used for args of link. result returned in reg 1; % %COMMENT Macros used in this compiler; % %COMMENT The following macros must NOT change REGS!& 1-MAXNARGS!&: %!*ALLOC nw allocate new stack frame of nw words %!*DEALLOC nw deallocate above frame %!*ENTRY name type noargs entry point to function name of type type % with noargs args %!*EXIT EXIT to previously saved return address %!*JUMP adr unconditional jump %!*LBL adr define label %!*LAMBIND regs alst bind free lambda vars in alst currently in regs %!*PROGBIND alst bind free prog vars in alst %!*FREERSTR alst unbind free variables in alst %!*STORE reg floc store contents of reg (or NIL) in floc % %COMMENT the following macro must only change specific register being % loaded: % %!*LOAD reg exp load exp into reg; % %COMMENT the following macros do not protect regs 1-MAXNARGS!&: % %!*LINK fn type nargs link to fn of type type with nargs args %!*LINKE fn type nargs nw link to fn of type type with nargs args % and EXITT!& removing frame of nw words; % % %COMMENT variable types are: % % LOCAL allocated on stack and known only locally % GLOBAL accessed via cell (GLOBAL name) known to % loader at load time % WGLOBAL accessed via cell (WGLOBAL name) known to % loader at load time, SYSLISP % FLUID accessed via cell (FLUID name) % known to loader. This cell is rebound by LAMBIND/ % PROGBIND if variable used in lambda/prog list % and restored by FREERSTR; % %COMMENT global flags used in this compiler: %!*UNSAFEBINDER for Don's BAKER problem...GC may be called in % Binder, so regs cant be preserved %!*MODULE indicates block compilation (a future extension of % this compiler) %!*NOLINKE if ON inhibits use of !*LINKE macro %!*ORD if ON forces left-to-right argument evaluation %!*PLAP if ON causes LAP output to be printed %!*R2I if ON causes recursion removal where possible; % % %COMMENT global variables used: % %DFPRINT!* name of special definition process (or NIL) %ERFG!* used by REDUCE to control error recovery %MAXNARGS!& maximum number of arguments permitted in implementation; % % % %%Standard LISP limit; % %COMMENT fluid variables used: % %ALSTS alist of fluid parameters %FLAGG used in COMTST, and in FIXREST %FREEBOUND indicates that some variables were FLUID %GOLIST storage map for jump labels %PREGS A list of protected registers %CODELIST code being built %CONDTAIL simulated stack of position in the tail of a COND %LLNGTH cell whose CAR is length of frame %NAME NAME!& of function being currently compiled %FNAME!& name of function being currently compiled, set by COMPILE %NARG number of arguments in function %REGS known current contents of registers as an alist with elements % of form (<reg> . <contents>) %EXITT label for *EXIT jump %EXITREGS List or register statuses at return point %LBLIST list of label words %JMPLIST list of locations in CODELIST!& of transfers %SLST association list for stores which have not yet been used %STOMAP storage map for variables %SWITCH boolean expression value flag - keeps track of NULLs; % SYMBOLIC PROCEDURE !&MKFUNC FN; MKQUOTE FN; SYMBOLIC PROCEDURE WARRAYP X; GET(X,'WARRAY) OR GET(X, 'WSTRING); SYMBOLIC PROCEDURE WVARP X; GET(X,'WVAR); SYMBOLIC PROCEDURE WCONSTP X; NUMBERP X OR (IDP X AND GET(X,'WCONST)); SYMBOLIC PROCEDURE !&ANYREGP X; FLAGP(X, 'ANYREG); macro procedure LocalF U; % declare functions internal, ala Franz list('flag, Mkquote cdr U, ''InternalFunction); %************************************************************ % The compiler %************************************************************ % Top level compile entry - X is list of functions to compile SYMBOLIC PROCEDURE COMPILE X; BEGIN SCALAR EXP; FOR EACH FNAME!& IN X DO <<EXP := GETD FNAME!&; IF NULL EXP THEN !&COMPWARN LIST("No definition for", FNAME!&) ELSE IF CODEP CDR EXP THEN !&COMPWARN LIST(FNAME!&, "already compiled") ELSE COMPD(FNAME!&,CAR EXP,CDR EXP)>> END; % COMPD - Single function compiler % Makes sure function type is compilable; sends original definition to % DFPRINT!*, then compiles the function. Shows LAP code when PLAP is on. % Runs LAP and adds COMPFN property if LAP indeed redefines the function. SYMBOLIC PROCEDURE COMPD(NAME!&,TY,EXP); BEGIN IF NOT FLAGP(TY,'COMPILE) THEN <<!&COMPERROR LIST("Uncompilable function type", TY); RETURN NIL>>; IF NOT EQCAR(EXP, 'LAMBDA) THEN << !&COMPERROR LIST("Attempt to compile non-lambda expression", EXP); RETURN NIL >> %/ ELSE IF !*MODULE THEN MODCMP(NAME!&,TY,EXP) % ELSE IF DFPRINT!* % THEN APPLY(DFPRINT!*,LIST IF TY EQ 'EXPR % THEN 'DE . (NAME!& . CDR EXP) % ELSE IF TY EQ 'FEXPR % THEN 'DF . (NAME!& . CDR EXP) % ELSE IF TY EQ 'MACRO %% THEN 'DM . (NAME!& . CDR EXP) % ELSE IF TY EQ 'NEXPR % THEN 'DN . (NAME!& . CDR EXP) % ELSE LIST('PUTD,MKQUOTE NAME!&, % MKQUOTE TY, % MKQUOTE EXP)) ELSE BEGIN SCALAR X; IF TY MEMQ '(EXPR FEXPR) THEN PUT(NAME!&,'CFNTYPE,LIST TY); X := LIST('!*ENTRY,NAME!&,TY,LENGTH CADR EXP) . !&COMPROC(EXP, IF TY MEMQ '(EXPR FEXPR) THEN NAME!&); IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y; % ***Code**Pointer** is a magic token that tells % COMPD to return a code pointer instead of an ID IF NAME!& = '!*!*!*Code!*!*Pointer!*!*!* then NAME!& := LAP X ELSE << LAP X; %this is the hook to the assembler. LAP must %remove old function definition if it exists; IF (X := GET(NAME!&,'CFNTYPE)) AND EQCAR(GETD NAME!&,CAR X) THEN REMPROP(NAME!&,'CFNTYPE) >> END; RETURN NAME!& END; %************************************************************ % Pass 1 routines %************************************************************ SYMBOLIC PROCEDURE !&PASS1 EXP; %. Pass1- reform body of expression for !&PA1(EXP,NIL); % Compilation SYMBOLIC PROCEDURE PA1ERR(X); %. Error messages from PASS1 STDERROR LIST("-- PA1 --", X); lisp procedure !&Pa1(U, Vbls); !&Pa1V(U, Vbls, NIL); % Do the real pass1 and an extra reform SYMBOLIC PROCEDURE !&PA1V(U,VBLS, VAR); BEGIN SCALAR Z,FN; % Z is the pass1 result. Reform if necessary Z:=!&PA1X(U,VBLS, VAR); IF IDP CAR Z AND (FN:=GET(CAR Z,'PA1REFORMFN)) THEN Z := APPLY(FN,LIST Z); RETURN Z; END; SYMBOLIC PROCEDURE !&PA1X(U,VBLS,VAR); %. VBLS are current local vars BEGIN SCALAR X; RETURN IF ATOM U % tag variables and constants THEN IF ISAWCONST U THEN MKWCONST U ELSE IF CONSTANTP U OR U MEMQ '(NIL T) THEN MKQUOTE U ELSE IF NONLOCAL U THEN !&PANONLOCAL(U, VBLS) ELSE IF U MEMQ VBLS THEN LIST('!$LOCAL,U) ELSE <<MKNONLOCAL U; !&PANONLOCAL(U, VBLS) >> ELSE IF NOT IDP CAR U THEN IF EQCAR(CAR U,'LAMBDA) THEN !&PA1V(CAR U,VBLS,VAR) . !&PALISV(CDR U,VBLS,VAR) ELSE % Change to APPLY << !&COMPERROR list("Ill-formed function expression", U); '(QUOTE NIL) >> % Changed semantics of EVAL to conform to Common Lisp. % CAR of a form is NEVER evaluated. % ELSE IF CAR U MEMQ VBLS OR FLUIDP CAR U % OR (GLOBALP CAR U % AND NOT GETD CAR U) THEN % Change to APPLY % << !&COMPWARN list("Functional form converted to APPLY", U); % !&PA1(LIST('APPLY, CAR U, 'LIST . CDR U), VBLS) >> ELSE IF X := GET(CAR U,'PA1ALGFN) % Do const folding, etc. THEN APPLY(X,LIST(U,VBLS,VAR)) ELSE IF X := GET(CAR U,'PA1FN) % Do PA1FN's THEN APPLY(X,LIST(U,VBLS)) ELSE IF X := GET(CAR U,'CMACRO) % CMACRO substitution THEN !&PA1V(SUBLIS(PAIR(CADR X,CDR U),CADDR X),VBLS,VAR) ELSE IF (X := GETD CAR U) % Expand macros AND CAR X EQ 'MACRO AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN !&PA1V(APPLY(CDR X,LIST U),VBLS,VAR) ELSE IF !&CFNTYPE CAR U EQ 'FEXPR % Transform FEXPR calls to AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN LIST(CAR U,MKQUOTE CDR U) % EXPR calls ELSE IF !&CFNTYPE CAR U EQ 'NEXPR % Transform NEXPR calls to AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN LIST(CAR U,!&PA1V('LIST . CDR U,VBLS,VAR)) % EXPR calls ELSE CAR U . !&PALISV(CDR U,VBLS,VAR); END; SYMBOLIC PROCEDURE !&PALIS(U,VBLS); !&PALISV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&PALISV(U,VBLS, VAR); FOR EACH X IN U COLLECT !&PA1V(X,VBLS,VAR); SYMBOLIC PROCEDURE ISAWCONST X; %. Check to see if WCONST, %. in SYSLISP only !*SYSLISP AND WCONSTP X; SYMBOLIC PROCEDURE !&CONSTTAG(); IF !*SYSLISP THEN 'WCONST ELSE 'QUOTE; SYMBOLIC PROCEDURE MKWCONST X; %. Made into WCONST BEGIN SCALAR Y; RETURN LIST('WCONST, IF (Y := GET(X, 'WCONST)) AND NOT GET(X, 'WARRAY) AND NOT GET(X, 'WSTRING) THEN Y ELSE X); END; SYMBOLIC PROCEDURE !&PAWCONST(U, VBLS); MKWCONST CADR U; SYMBOLIC PROCEDURE NONLOCAL X; %. Default NON-LOCAL types IF !*SYSLISP THEN NONLOCALSYS X ELSE NONLOCALLISP X; SYMBOLIC PROCEDURE NONLOCALLISP X; IF FLUIDP X THEN '!$FLUID ELSE IF GLOBALP X THEN '!$GLOBAL ELSE IF WVARP X OR WARRAYP X THEN <<!&COMPWARN LIST(X,"already SYSLISP non-local");NIL>> ELSE NIL; SYMBOLIC PROCEDURE NONLOCALSYS X; IF WARRAYP X THEN 'WARRAY ELSE IF WVARP X THEN 'WVAR ELSE NONLOCALLISP X; SYMBOLIC PROCEDURE !&PANONLOCAL(X, VBLS); %. Reform Non-locals % X will be a declared NONLOCAL BEGIN SCALAR Z; RETURN IF NOT IDP X OR NOT NONLOCAL X THEN PA1ERR LIST("non-local error",X) ELSE IF FLUIDP X THEN LIST('!$FLUID,X) ELSE IF GLOBALP X THEN LIST('!$GLOBAL,X) ELSE IF GET(X,'WVAR) THEN IF X MEMBER VBLS THEN <<!&COMPWARN(LIST('WVAR,X,"used as local")); LIST('!$LOCAL,X)>> ELSE LIST('WVAR,X) ELSE IF WARRAYP X THEN LIST('WCONST, X) ELSE PA1ERR LIST("Unknown in PANONLOCAL",X); END; % Make unknown symbols into FLUID for LISP, WVAR for SYSLISP, with warning % Changed to just declare it fluid, EB, 9:36am Friday, 10 September 1982 SYMBOLIC PROCEDURE MKNONLOCAL U; % IF !*SYSLISP THEN % << !&COMPERROR LIST("Undefined symbol", U, % "in Syslisp, treated as WVAR"); % WDECLARE1(U, 'INTERNAL, 'WVAR, NIL, 0); % LIST('WVAR, U) >> % ELSE <<!&COMPWARN LIST(U,"declared fluid"); FLUID LIST U; LIST('!$FLUID,U)>>; % Utility stuff for the PA1 functions SYMBOLIC PROCEDURE !&MKNAM U; %generates unique name for auxiliary function in U; IMPLODE NCONC(EXPLODE U,EXPLODE !&GENSYM()); % For making implied PROGN's into explicit ones (as in COND) SYMBOLIC PROCEDURE !&MKPROGN U; IF NULL U OR CDR U THEN 'PROGN . U ELSE CAR U; SYMBOLIC PROCEDURE !&EQP U; %!&EQP is true if U is an object for which EQ can replace EQUAL; INUMP U OR IDP U; SYMBOLIC PROCEDURE !&EQVP U; %!&EQVP is true if EVAL U is an object for which EQ can %replace EQUAL; INUMP U OR NULL U OR U EQ 'T OR EQCAR(U,'QUOTE) AND !&EQP CADR U; % !&EQPL U is true if !&EQP of all elements of U SYMBOLIC PROCEDURE !&EQPL U; NULL U OR !&EQP(CAR U) AND !&EQPL(CDR U); SYMBOLIC PROCEDURE !&MAKEADDRESS U; % convert an expression into an addressing expression, (MEMORY var const), % where var is the variable part & const is the constant part (tagged, of % course). It is assumed that U has been through pass 1, which does constant % folding & puts any constant term at the top level. IF EQCAR(U,'LOC) THEN CADR U ELSE % GETMEM LOC x == x 'MEMORY . (IF EQCAR(U,'WPLUS2) AND !&CONSTP CADDR U THEN CDR U ELSE IF EQCAR(U,'WDIFFERENCE) AND !&CONSTP CADR U THEN LIST(LIST('WMINUS,CADDR U),CADR U) ELSE LIST(U,'(WCONST 0))); SYMBOLIC PROCEDURE !&DOOP U; % simplification for random operators - op is doable only when all operands % are constant IF !&ALLCONST CDR U THEN LIST(CAR CADR U, APPLY(GET(CAR U,'DOFN) or car U, FOR EACH X IN CDR U COLLECT CADR X)) ELSE U; SYMBOLIC PROCEDURE !&ALLCONST L; NULL L OR (car L = 'QUOTE or !&WCONSTP CAR L AND NUMBERP CADR CAR L) AND !&ALLCONST CDR L; lisp procedure !&PaReformWTimes2 U; begin scalar X; U := !&Doop U; return if first U = 'WTimes2 then if !&WConstP second U and (X := PowerOf2P second second U) then list('WShift, third U, list(!&ConstTag(), X)) else if !&WConstP third U and (X := PowerOf2P second third U) then list('WShift, second U, list(!&ConstTag(), X)) else U else U; end; SYMBOLIC PROCEDURE !&ASSOCOP(U,VBLS); % For abelian semi-groups & monoids % given an associative, communitive operation (TIMES2, AND, ...) collect all % arguments, seperate constant args, evaluate true constants, check for zero's % and ones (0*X = 0, 1*X = X) !&ASSOCOPV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&ASSOCOPV(U,VBLS,VAR); BEGIN SCALAR ARGS,NUM,CONSTS,VARS; ARGS := !&ASSOCOP1(CAR U,!&PALIS(CDR U,VBLS)); CONSTS := VARS := NUM := NIL; FOR EACH ARG IN ARGS DO IF !&WCONSTP ARG THEN IF NUMBERP CADR ARG THEN IF NUM THEN NUM := APPLY(GET(CAR U,'DOFN),LIST(NUM,CADR ARG)) ELSE NUM := CADR ARG ELSE CONSTS := NCONC(CONSTS,LIST ARG) ELSE VARS := NCONC(VARS,LIST ARG); IF NUM THEN <<IF NUM = GET(CAR U,'ZERO) THEN RETURN LIST(!&CONSTTAG(),NUM); IF NUM NEQ GET(CAR U,'ONE) THEN CONSTS := NUM . CONSTS ELSE IF NULL VARS AND NULL CONSTS THEN RETURN LIST(!&CONSTTAG(), NUM) >>; IF CONSTS THEN VARS := NCONC(VARS,LIST LIST('WCONST,!&INSOP(CAR U,CONSTS))); IF VAR MEMBER VARS THEN <<VARS := DELETIP(VAR,VARS); RETURN !&INSOP(CAR U,REVERSIP(VAR . REVERSIP VARS))>>; RETURN !&INSOP(CAR U,VARS); END; SYMBOLIC PROCEDURE !&ASSOCOP1(OP,ARGS); IF NULL ARGS THEN NIL ELSE NCONC(!&ASSOCOP2(OP,CAR ARGS),!&ASSOCOP1(OP,CDR ARGS)); SYMBOLIC PROCEDURE !&ASSOCOP2(OP,ARG); IF EQCAR(ARG,OP) THEN !&ASSOCOP1(OP,CDR ARG) ELSE LIST ARG; SYMBOLIC PROCEDURE !&INSOP(OP,L); % Insert OP into a list of operands as follows: INSOP(~,'(A B C D)) = % (~ (~ (~ A B) C) D) IF NULL L THEN NIL ELSE if null cdr L then car L else !&INSOP1(list(OP, first L, second L), rest rest L, OP); SYMBOLIC PROCEDURE !&INSOP1(NEW, RL, OP); if null RL then NEW else !&INSOP1(list(OP, NEW, first RL), rest RL, OP); SYMBOLIC PROCEDURE !&GROUP(U,VBLS); % Like ASSOP, except inverses exist. All operands are partitioned into two % lists, non-inverted and inverted. Cancellation is done between these two % lists. The group is defined by three operations, the group operation (+), % inversion (unary -), and subtraction (dyadic -). The GROUPOPS property on % all three of there operators must contain the names of these operators in % the order (add subtract minus) !&GROUPV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&GROUPV(U,VBLS,VAR); BEGIN SCALAR X,ARGS,INVARGS,FNS,CONSTS,INVCONSTS,CON,RES,VFLG,INVFLG,ONE; FNS := GET(CAR U,'GROUPOPS); ONE := LIST(!&CONSTTAG(),GET(CAR FNS,'ONE)); X := !&GETGROUPARGS(FNS,CAR U . !&PALIS(CDR U, VBLS),NIL,'(NIL NIL)); ARGS := CAR X; INVARGS := CADR X; FOR EACH ARG IN ARGS DO IF ARG MEMBER INVARGS THEN <<ARGS := !&DELARG(ARG,ARGS); INVARGS := !&DELARG(ARG,INVARGS)>>; CONSTS := INVCONSTS := CON := NIL; FOR EACH ARG IN ARGS DO IF !&WCONSTP ARG THEN <<ARGS := !&DELARG(ARG,ARGS); IF NUMBERP CADR ARG THEN IF CON THEN CON := APPLY(GET(CAR FNS,'DOFN),LIST(CON,CADR ARG)) ELSE CON := CADR ARG ELSE CONSTS := NCONC(CONSTS,LIST ARG)>>; FOR EACH ARG IN INVARGS DO IF !&WCONSTP ARG THEN <<INVARGS := !&DELARG(ARG,INVARGS); IF NUMBERP CADR ARG THEN IF CON THEN CON := APPLY(GET(CADR FNS,'DOFN),LIST(CON,CADR ARG)) ELSE CON := APPLY(GET(CADDR FNS,'DOFN),LIST CADR ARG) ELSE INVCONSTS := NCONC(INVCONSTS,LIST ARG)>>; IF CON AND CON = GET(CAR FNS,'ZERO) THEN RETURN LIST(!&CONSTTAG(),CON); IF CON AND CON = CADR ONE THEN CON := NIL; IF CON THEN CONSTS := CON . CONSTS; CONSTS := !&MAKEXP(CONSTS,INVCONSTS,FNS); IF CONSTS AND NOT !&WCONSTP CONSTS THEN CONSTS := LIST('WCONST,CONSTS); IF VAR MEMBER ARGS THEN <<ARGS := DELETE(VAR,ARGS); VFLG := T; INVFLG := NIL>>; IF VAR MEMBER INVARGS THEN <<INVARGS := DELETE(VAR,INVARGS); VFLG := T; INVFLG := T>>; ARGS := !&MAKEXP(ARGS,INVARGS,FNS); RES := IF NULL ARGS THEN IF NULL CONSTS THEN ONE ELSE CONSTS ELSE IF NULL CONSTS THEN ARGS ELSE IF EQCAR(ARGS,CADDR FNS) THEN LIST(CADR FNS,CONSTS,CADR ARGS) ELSE LIST(CAR FNS,ARGS,CONSTS); IF VFLG THEN IF RES = ONE THEN IF INVFLG THEN RES := LIST(CADDR FNS,VAR) ELSE RES := VAR ELSE RES := LIST(IF INVFLG THEN CADR FNS ELSE CAR FNS,RES,VAR); RETURN RES; END; SYMBOLIC PROCEDURE !&MAKEXP(ARGS,INVARGS,FNS); IF NULL ARGS THEN IF NULL INVARGS THEN NIL ELSE LIST(CADDR FNS,!&INSOP(CAR FNS,INVARGS)) ELSE IF NULL INVARGS THEN !&INSOP(CAR FNS,ARGS) ELSE !&INSOP(CADR FNS,!&INSOP(CAR FNS,ARGS) . INVARGS); SYMBOLIC PROCEDURE !&GETGROUPARGS(FNS,EXP,INVFLG,RES); IF ATOM EXP OR NOT(CAR EXP MEMBER FNS) THEN !&GETGROUPARGS1(EXP,INVFLG,RES) ELSE IF CAR EXP EQ CAR FNS THEN !&GETGROUPARGS2(FNS,CDR EXP,INVFLG,RES) ELSE IF CAR EXP EQ CADR FNS THEN !&GETGROUPARGS(FNS,CADR EXP,INVFLG, !&GETGROUPARGS(FNS,CADDR EXP,NOT INVFLG,RES)) ELSE IF CAR EXP EQ CADDR FNS THEN !&GETGROUPARGS(FNS,CADR EXP,NOT INVFLG,RES) ELSE !&COMPERROR(LIST("Compiler bug in constant folding",FNS,EXP)); SYMBOLIC PROCEDURE !&GETGROUPARGS1(THING,INVFLG,RES); IF INVFLG THEN LIST(CAR RES,THING . CADR RES) ELSE (THING . CAR RES) . CDR RES; SYMBOLIC PROCEDURE !&GETGROUPARGS2(FNS,ARGS,INVFLG,RES); IF NULL ARGS THEN RES ELSE !&GETGROUPARGS2(FNS,CDR ARGS,INVFLG, !&GETGROUPARGS(FNS,CAR ARGS,INVFLG,RES)); SYMBOLIC PROCEDURE !&DELARG(ARG,ARGS); IF ARG = CAR ARGS THEN CDR ARGS ELSE CAR ARGS . !&DELARG(ARG,CDR ARGS); %************************************************************ % Pass 1 functions %************************************************************ lisp procedure !&PaApply(U, Vars); if EqCar(third U, 'LIST) then % set up for !&COMAPPLY if EqCar(second U, 'function) and !&CfnType second second U = 'EXPR then !&Pa1(second second U . rest third U, Vars) else list('APPLY, !&Pa1(second U, Vars), 'LIST . !&PaLis(rest third U, Vars)) else 'APPLY . !&PaLis(rest U, Vars); % Try to turn ASSOC into ATSOC SYMBOLIC PROCEDURE !&PAASSOC(U,VARS); !&PAASSOC1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAASSOC1(ASSOCVAR,ASSOCLIST); IF !&EQVP ASSOCVAR OR EQCAR(ASSOCLIST,'QUOTE) AND !&EQPL(FOR EACH U IN CADR ASSOCLIST COLLECT CAR U) THEN 'ATSOC ELSE 'ASSOC; SYMBOLIC PROCEDURE !&PACOND(U,VBLS); begin scalar RevU, Result, Temp; if null cdr U then return '(QUOTE NIL); % (COND) == NIL RevU := reverse cdr U; if first first RevU neq T then RevU := '(T NIL) . RevU; for each CondForm in RevU do if null rest CondForm then << if not Temp then << Temp := !&Gensym(); VBLS := Temp . VBLS >>; Result := list(!&PA1(list('SETQ, Temp, first CondForm), VBLS), !&PA1(Temp, VBLS)) . Result >> else Result := list(!&PA1(first CondForm, VBLS), !&PA1(!&MkProgN rest CondForm, VBLS)) . Result; return if Temp then list(list('LAMBDA, list !&PA1(Temp, VBLS), 'COND . Result), '(QUOTE NIL)) else 'COND . Result; end; lisp procedure !&PaCatch(U, Vbls); (lambda(Tag, Forms); << if null cdr Forms and (atom car Forms or car car Forms = 'QUOTE or car car Forms = 'LIST) then !&CompWarn list("Probable obsolete use of CATCH:", U); !&Pa1(list(list('lambda, '(!&!&HiddenVar!&!&), list('cond, list('(null ThrowSignal!*), list('(lambda (xxx) (!%UnCatch !&!&HiddenVar!&!&) xxx), 'progn . Forms)), '(t !&!&HiddenVar!&!&))), list('CatchSetup, Tag)), Vbls)>>)(cadr U, cddr U); % X-1 -> SUB1 X SYMBOLIC PROCEDURE !&PADIFF(U,VARS); IF CADDR U=1 THEN LIST('SUB1,!&PA1(CADR U,VARS)) ELSE 'DIFFERENCE . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAEQUAL(U,VARS); !&PAEQUAL1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAEQUAL1(LEFT,RIGHT); IF !&EQVP LEFT OR !&EQVP RIGHT THEN 'EQ ELSE IF NUMBERP LEFT OR NUMBERP RIGHT THEN 'EQN ELSE 'EQUAL; % FUNCTION will compile a non-atomic arg into a GENSYMed name. % Currently, MKFUNC = MKQUOTE SYMBOLIC PROCEDURE !&PAFUNCTION(U,VBLS); IF ATOM CADR U THEN !&MKFUNC CADR U % COMPD returns a code pointer here ELSE !&MKFUNC COMPD('!*!*!*Code!*!*Pointer!*!*!*, 'EXPR,CADR U); SYMBOLIC PROCEDURE !&PAGETMEM(U,VBLS); !&MAKEADDRESS !&PA1(CADR U,VBLS); SYMBOLIC PROCEDURE !&PAIDENT(U,VBLS); %. return form U; % LAMBDA - pick up new vars, check implicit PROGN SYMBOLIC PROCEDURE !&PACASE(U,VBLS); 'CASE . !&PA1(CADR U,VBLS) . FOR EACH EXP IN CDDR U COLLECT LIST(!&PALIS(CAR EXP,VBLS),!&PA1(CADR EXP,VBLS)); SYMBOLIC PROCEDURE !&PALAMBDA(U,VBLS); <<VBLS := APPEND(CADR U,VBLS); 'LAMBDA . LIST(!&PALIS(CADR U,VBLS),!&PA1(!&MKPROGN CDDR U,VBLS)) >>; % X<0 -> MINUSP(X) SYMBOLIC PROCEDURE !&PALESSP(U,VARS); IF CADDR U=0 THEN LIST('MINUSP,!&PA1(CADR U,VARS)) ELSE 'LESSP . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PALIST(U, VBLS); BEGIN SCALAR L,FN; L := LENGTH CDR U; RETURN IF L = 0 THEN '(QUOTE NIL) ELSE IF FN := ASSOC(L,'((1 . NCONS) (2 . LIST2) (3 . LIST3) (4 . LIST4) (5 . LIST5))) THEN !&PA1(CDR FN . CDR U, VBLS) ELSE !&PA1(LIST('CONS,CADR U, 'LIST . CDDR U), VBLS); END; lisp procedure !&PaNth(U, Vbls); !&PaNths(U, Vbls, '((1 . CAR) (2 . CADR) (3 . CADDR) (4 . CADDDR))); lisp procedure !&PaPNth(U, Vbls); !&PaNths(U, Vbls, '((1 . CR) (2 . CDR) (3 . CDDR) (4 . CDDDR) (5 . CDDDDR))); lisp procedure !&PaNths(U, Vbls, FnTable); begin scalar N, X, Fn; N := !&Pa1(third U, Vbls); X := second U; return if first N memq '(QUOTE WCONST) and FixP second N and (Fn := Assoc(second N, FnTable)) then if cdr Fn = 'CR then !&Pa1(X, Vbls) else !&Pa1(list(cdr Fn, X), Vbls) else list(car U, !&Pa1(X, Vbls), N); end; SYMBOLIC PROCEDURE !&PAMAP(U, VBLS); !&PAMAPDO(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPC(U, VBLS); !&PAMAPDO(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPDO(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP; TMP := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP) (SETQ TMP STARTINGLIST) LOOPLABEL (COND ((ATOM TMP) (RETURN NIL))) FNCALL (SETQ TMP (CDR TMP)) (GO LOOPLABEL))), VBLS); END; SYMBOLIC PROCEDURE !&PAMAPLIST(U, VBLS); !&PAMAPCOLLECT(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPCAR(U, VBLS); !&PAMAPCOLLECT(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPCOLLECT(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP, RESULT, ENDPTR; TMP := !&GENSYM(); RESULT := !&GENSYM(); ENDPTR := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'RESULT . RESULT, 'ENDPTR . ENDPTR, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP RESULT ENDPTR) (SETQ TMP STARTINGLIST) (COND ((ATOM TMP) (RETURN NIL))) (SETQ RESULT (SETQ ENDPTR (NCONS FNCALL))) LOOPLABEL (SETQ TMP (CDR TMP)) (COND ((ATOM TMP) (RETURN RESULT))) (RPLACD ENDPTR (NCONS FNCALL)) (SETQ ENDPTR (CDR ENDPTR)) (GO LOOPLABEL))), VBLS); END; SYMBOLIC PROCEDURE !&PAMAPCON(U, VBLS); !&PAMAPCONC(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPCAN(U, VBLS); !&PAMAPCONC(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPCONC(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP, RESULT, ENDPTR; TMP := !&GENSYM(); RESULT := !&GENSYM(); ENDPTR := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'RESULT . RESULT, 'ENDPTR . ENDPTR, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP RESULT ENDPTR) (SETQ TMP STARTINGLIST) STARTOVER (COND ((ATOM TMP) (RETURN NIL))) (SETQ RESULT FNCALL) (SETQ ENDPTR (LASTPAIR RESULT)) (SETQ TMP (CDR TMP)) (COND ((ATOM ENDPTR) (GO STARTOVER))) LOOPLABEL (COND ((ATOM TMP) (RETURN RESULT))) (RPLACD ENDPTR FNCALL) (SETQ ENDPTR (LASTPAIR ENDPTR)) (SETQ TMP (CDR TMP)) (GO LOOPLABEL))), VBLS); END; % Attempt to change MEMBER to MEMQ SYMBOLIC PROCEDURE !&PAMEMBER(U,VARS); !&PAMEMBER1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAMEMBER1(THING,LST); IF !&EQVP THING OR EQCAR(LST,'QUOTE) AND !&EQPL CADR LST THEN 'MEMQ ELSE 'MEMBER; % (Intern (Compress X)) == (Implode X) % (Intern (Gensym)) == (InternGensym) SYMBOLIC PROCEDURE !&PAINTERN(U, VBLS); << U := !&PA1(CADR U, VBLS); IF EQCAR(U, 'COMPRESS) THEN 'IMPLODE . CDR U ELSE IF EQCAR(U, 'GENSYM) THEN 'INTERNGENSYM . CDR U ELSE LIST('INTERN, U) >>; % Do MINUS on constants. SYMBOLIC PROCEDURE !&PAMINUS(U,VBLS); IF EQCAR(U := !&PA1(CADR U,VBLS),'QUOTE) AND NUMBERP CADR U THEN MKQUOTE ( - CADR U) ELSE IF EQCAR(U ,'WCONST) AND NUMBERP CADR U THEN MKWCONST ( - CADR U) ELSE LIST('MINUS,U); SYMBOLIC PROCEDURE !&REFORMLOC U; IF EQCAR(CADR U, 'MEMORY) THEN LIST('WPLUS2, CADDR CADR U, CADR CADR U) ELSE U; SYMBOLIC PROCEDURE !&REFORMNULL U; BEGIN SCALAR FLIP; RETURN IF PAIRP CADR U AND (FLIP := GET(CAADR U,'FLIPTST)) THEN FLIP . CDADR U ELSE LIST('EQ, CADR U, '(QUOTE NIL)); END; % Perdue 12/3/82 % This optimization causes compiled code to behave differently % from interpreted code. The FLIPTST property on NE and PASS2 % handling of negation in tests (&COMTST) are enough to cause good code % to be generated when NE is used as a test. % SYMBOLIC PROCEDURE !&REFORMNE U; % IF CADR U = '(QUOTE NIL) THEN CADDR U % ELSE IF CADDR U = '(QUOTE NIL) THEN CADR U % ELSE U; % PLUS2(X,1) -> ADD1(X) SYMBOLIC PROCEDURE !&PAPLUS2(U,VARS); IF CADDR U=1 THEN !&PA1(LIST('ADD1, CADR U),VARS) ELSE IF CADR U=1 THEN !&PA1('ADD1 . CDDR U,VARS) ELSE 'PLUS2 . !&PALIS(CDR U,VARS); % Pick up PROG vars, ignore labels. SYMBOLIC PROCEDURE !&PAPROG(U,VBLS); <<VBLS := APPEND(CADR U,VBLS); 'PROG . (!&PALIS(CADR U,VBLS) . !&PAPROGBOD(CDDR U,VBLS)) >>; SYMBOLIC PROCEDURE !&PAPROGBOD(U,VBLS); FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VBLS); SYMBOLIC PROCEDURE !&PAPUTMEM(U,VBLS); !&PA1('SETQ . LIST('GETMEM, CADR U) . CDDR U, VBLS); SYMBOLIC PROCEDURE !&PAPUTLISPVAR(U, VBLS); !&PA1('SETQ . LIST('LISPVAR, CADR U) . CDDR U, VBLS); SYMBOLIC PROCEDURE !&PALISPVAR(U, VBLS); LIST('!$FLUID, CADR U); SYMBOLIC PROCEDURE !&PASETQ(U,VBLS); BEGIN SCALAR VAR,FN,EXP, LN; LN := LENGTH CDR U; IF LN NEQ 2 THEN RETURN << LN := DIVIDE(LN, 2); IF CDR LN NEQ 0 THEN << !&COMPERROR LIST("Odd number of arguments to SETQ", U); U := APPEND(U, LIST NIL); LN := CAR LN + 1 >> ELSE LN := CAR LN; U := CDR U; FOR I := 1 STEP 1 UNTIL LN DO << EXP := LIST('SETQ, CAR U, CADR U) . EXP; U := CDDR U >>; !&PA1('PROGN . REVERSIP EXP, VBLS) >>; VAR := !&PA1(CADR U,VBLS); EXP := !&PA1V(CADDR U, VBLS, VAR); U := IF FLAGP(CAR VAR,'VAR) THEN LIST('!$NAME,VAR) ELSE VAR; IF (NOT (FN := GET(CAR EXP,'MEMMODFN))) OR not (LastCar EXP = VAR) THEN RETURN LIST('SETQ,U,EXP) ELSE RETURN FN . U . REVERSIP CDR REVERSIP CDR EXP; END; SYMBOLIC PROCEDURE !&INSTALLDESTROY(NAME!&); % determine which (if any) registers are unaltered by the function. % Print this information out if !*SHOWDEST, install it on the % property list of the function if !*INSTALLDESTOY BEGIN SCALAR DESTL,R,HRU; HRU := !&HIGHEST(CODELIST!&,NIL,NARG!&,T); % Find the highest register used in the code. Registers above this are % unchanged. Incoming registers have a distinguished value, IREG n, placed % in register n. If this value remains, it has not been destroyed. IF HRU = 'ALL THEN RETURN NIL; DESTL := NIL; FOR I := 1:NARG!& DO <<R := !&MKREG I; IF NOT (!&IREG I MEMBER !®VAL R) THEN DESTL := R . DESTL>>; FOR I := NARG!&+1 : HRU DO DESTL := !&MKREG I . DESTL; IF NULL DESTL THEN DESTL := '((REG 1)); IF !*INSTALLDESTROY THEN PUT(NAME!&,'DESTROYS,DESTL); IF !*SHOWDEST THEN <<PRIN2 NAME!&;PRIN2 " DESTROYS ";PRIN2T DESTL>>; END; % COMPROC does the dirty work - initializes variables and gets the % three passes going. SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME!&); %compiles a function body, returning the generated LAP; BEGIN SCALAR CODELIST!&,FLAGG!&,JMPLIST!&,LBLIST!&, LOCALGENSYM!&, LLNGTH!&,REGS!&,REGS1!&,ALSTS!&, EXITT!&,TOPLAB!&,SLST!&,STOMAP!&, CONDTAIL!&,FREEBOUND!&,HOLEMAP!&,PREGS!&, SWITCH!&,EXITREGS!&,RN; INTEGER NARG!&; LOCALGENSYM!& := GLOBALGENSYM!&; PREGS!& := NIL; REGS!& := NIL; LLNGTH!& := 0; IF NOT EQCAR(EXP, 'LAMBDA) THEN << !&COMPERROR LIST("Attempt to compile a non-lambda expression", EXP); RETURN NIL >>; NARG!& := LENGTH CADR EXP; EXITREGS!& := NIL; EXITT!& := !&GENLBL(); TOPLAB!& := !&GENLBL(); STOMAP!& := NIL; CODELIST!& := LIST '(!*ALLOC (!*FRAMESIZE)); !&ATTLBL TOPLAB!&; EXP := !&PASS1 EXP; IF NARG!& > MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments",NARG!&); ALSTS!& := !&VARBIND(CADR EXP,T); % Generate LAMBIND RN := 1; FOR I := 1:LENGTH CADR EXP DO REGS!& := !&ADDRVALS(!&MKREG I,REGS!&,LIST( !&IREG I)); !&PASS2 CADDR EXP; !&FREERSTR(ALSTS!&,0); %Restores old fluid bindings !&PASS3(); IF !*INSTALLDESTROY OR !*SHOWDEST THEN !&INSTALLDESTROY(NAME!&); !&REFORMMACROS(); % Plugs compile time constants into macros. FIXFRM? !&REMTAGS(); % Kludge RETURN CODELIST!& END; lisp procedure !&IReg N; if N > 0 and N <= 15 then GetV('[() (IREG 1) (IREG 2) (IREG 3) (IREG 4) (IREG 5) (IREG 6) (IREG 7) (IREG 8) (IREG 9) (IREG 10) (IREG 11) (IREG 12) (IREG 13) (IREG 14) (IREG 15)], n) else list('IREG, N); SYMBOLIC PROCEDURE !&WCONSTP X; PairP X and (first X = 'WConst or first X = 'Quote and FixP second X); %************************************************************ % Pass 2 * %************************************************************ % Initialize STATUS!&=0 (Top level) SYMBOLIC PROCEDURE !&PASS2 EXP; !&COMVAL(EXP,0); SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS!&); % Compile EXP. Special cases: if STATUS!&>1 (compiling for side effects), % anyreg functions are ignored since they have no side effects. % Otherwise, top level ANYREG stuff is factored out and done via a LOAD % instead of a LINK. IF !&ANYREG(EXP) THEN IF STATUS!&>1 THEN <<IF NOT (CAR EXP MEMBER '(QUOTE !$LOCAL !$FLUID)) THEN !&COMPWARN(LIST("Value of", EXP, "not used, therefore not compiled")); NIL >> ELSE !&LREG1(EXP) % Just a LOAD ELSE % When not all ANYREG IF !&ANYREGFNP EXP % Is the top level an ANYREG fn? THEN IF STATUS!&>1 THEN <<!&COMVAL(CADR EXP,STATUS!&); !&COMPWARN LIST("Top level", CAR EXP, "in", EXP, "not used, therefore not compiled"); NIL>> ELSE !&LREG1(CAR EXP . !&COMLIS CDR EXP) % Preserve the anyreg fn ELSE !&COMVAL1(EXP,STOMAP!&,STATUS!&); % no anyregs in sight % Generate code which loads the value of EXP into register 1 % Patch to COMVAL1 for better register allocation SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP!&,STATUS!&); BEGIN SCALAR X; IF !&ANYREG EXP OR !&OPENFNP EXP OR !&ANYREGFNP EXP THEN IF STATUS!&<2 AND !&NOSIDEEFFECTP EXP THEN !&COMPWARN(LIST(EXP," not compiled")) ELSE <<!&LOADOPENEXP(IF STATUS!& > 1 THEN !&AllocTemp(Exp) ELSE '(REG 1), CAR EXP . !&COMLIS CDR EXP,STATUS!&,PREGS!&)>> ELSE IF NOT ATOM CAR EXP % Non atomic function? THEN IF CAAR EXP EQ 'LAMBDA THEN !&COMPLY(CAR EXP,CDR EXP,STATUS!&) % LAMBDA compilation ELSE !&COMPERROR LIST(CAR EXP, "Invalid as function") % Should be noticed in pass 1 ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS!&)) % Dispatch built in compiler functions ELSE IF CAR EXP EQ 'LAMBDA THEN !&COMPERROR LIST("Invalid use of LAMBDA in COMVAL1",EXP) ELSE !&CALL(CAR EXP,CDR EXP,STATUS!&); % Call a function RETURN NIL END; % Procedure to allocate temps for OPEN exprs. Used only when STATUS!&<1 to % set up destination. Only special case is SETQ. SETQ tries to put the % value of X:=... into a register containing X (keeps variables in the same % register if possible. Symbolic Procedure !&Alloctemp(Exp); if car Exp = 'Setq then if car caddr exp = 'Setq then % Nested setq - move to actual RHS !&Alloctemp(caddr Exp) else begin Scalar Reg; If (Reg := !&RAssoc(Cadr Cadr Exp,Regs!&)) % LHS variable already in reg? and not (Car Reg member PRegs!&) then % and reg must be available Return Car Reg % Return the reg previously used for the var else Return !&Tempreg() % Just get a temp end else !&TempReg(); % not SETQ - any old temp will do SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS!&); !&CALL1(FN,!&COMLIS1 ARGS,STATUS!&); %Args have been compiled SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS!&); %ARGS is reversed list of compiled arguments of FN; BEGIN INTEGER ARGNO; SCALAR DEST!&; ARGNO := LENGTH ARGS; IF !&ANYREGP FN THEN !&LREG1(FN . ARGS) ELSE <<!&LOADARGS(ARGS,1,PREGS!&); %Emits loads to registers !&ATTACH LIST('!*LINK,FN,!&CFNTYPE FN,ARGNO); !&REMMREFS(); !&REMVREFS(); % Default - all registers destroyed IF !*USINGDESTROY THEN DEST!& := GET(FN,'DESTROYS); IF NULL DEST!& THEN REGS!& := NIL ELSE BEGIN SCALAR TEMP; TEMP := NIL; FOR EACH R IN REGS!& DO IF NOT(CAR R MEMBER DEST!&) THEN TEMP := R . TEMP; REGS!& := TEMP END >> END; % Comlis altered to return unreversed list SYMBOLIC PROCEDURE !&COMLIS EXP; REVERSIP !&COMLIS1 EXP; % COMLIS1 returns reversed list of compiled arguments; SYMBOLIC PROCEDURE !&COMLIS1 EXP; BEGIN SCALAR ACUSED,Y; % Y gathers a set of ANYREG expressions denoting % the params. Code for non ANYREG stuff is emitted by ATTACH. ACUSED is % name of psuedo variable holding results of non anyreg stuff. Y := NIL; WHILE EXP DO <<IF !&CONSTP CAR EXP OR !&OPENP CAR EXP AND (NOT !*ORD OR !&NOSIDEEFFECTPL CDR EXP) THEN Y := CAR EXP . Y % Anyreg stuff is handled later. Anyreg args are not loaded until after % all others. % If !*ORD is true, order is still switched unless no side effects ELSE << %/ Special coding for top level ANYREG IF ACUSED THEN !&SAVER1(); IF (!&ANYREGFNP CAR EXP OR !&OPENFNP CAR EXP) AND (NOT !*ORD OR !&NOSIDEEFFECTPL CDR EXP) THEN <<Y := (CAAR EXP . !&COMLIS CDAR EXP) . Y; ACUSED := T>> % Emit code to place arg in R1, generate a name for the result to put in R1 ELSE <<!&COMVAL1(CAR EXP,STOMAP!&,1); ACUSED := LIST('!$LOCAL,!&GENSYM()); REGS!& := !&ADDRVALS('(REG 1),REGS!&,LIST ACUSED); % REGS!& the new variable name goes on the code list (rest already emitted) Y := ACUSED . Y>>>>; % place arg in memory while doing others EXP := CDR EXP>>; RETURN Y END; % SAVE R1 IF NECESSARY SYMBOLIC PROCEDURE !&SAVER1; %MARKS CONTENTS OF REGISTER 1 FOR STORAGE; BEGIN SCALAR X; X := !®VAL '(REG 1); % Contents of R1 IF NULL X OR NOT !&VARP CAR X THEN RETURN NIL % Dont save constants ELSE IF NOT ASSOC(CAR X,STOMAP!&) THEN !&FRAME CAR X; % For temporaries % as generated in COMLIS !&STORELOCAL(CAR X,'(REG 1)) % Emit a store END; % Compiler for LAMBDA SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS!&); BEGIN SCALAR ALSTS!&,VARS, N, I; %SCALAR OLDSTOMAP,OLDCODE; % OLDSTOMAP := STOMAP!&; % OLDCODE := CODELIST!&; VARS := CADR FN; % Compile args to the lambda ARGS := !&COMLIS1 ARGS; N := LENGTH ARGS; IF N>MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments in LAMBDA form",FN); % Put the args into registers !&LOADARGS(ARGS,1,PREGS!&); % Enter new ENVIRONMENT!& ARGS := !&REMVARL VARS; % The stores that were protected; I := 1; % Put this junk on the frame ALSTS!& := !&VARBIND(VARS,T); %Old fluid values saved; % compile the body !&COMVAL(CADDR FN,STATUS!&); % Restore old fluids !&FREERSTR(ALSTS!&,STATUS!&); % Go back to the old ENVIRONMENT!& !&RSTVARL(VARS,ARGS); %/ !&FIXFRM(OLDSTOMAP,OLDCODE,0) END; % Load a sequence of expressions into the registers SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS!&,PREGS!&); BEGIN INTEGER N; SCALAR FN,DESTREG!&; N := LENGTH ARGS; IF N>MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments",ARGS); WHILE ARGS DO % Generate a load for each arg <<DESTREG!& := !&MKREG N; !&LOADOPENEXP(DESTREG!&,CAR ARGS,STATUS!&,PREGS!&); PREGS!& := DESTREG!& . PREGS!&; N := N - 1; ARGS := CDR ARGS>> END; SYMBOLIC PROCEDURE !&LOADOPENEXP(DESTREG!&,ARG,STATUS!&,PREGS!&); BEGIN SCALAR R; IF !&ANYREG ARG OR !&RASSOC(ARG,REGS!&) THEN !&LREG(DESTREG!&,!&LOCATE ARG) ELSE IF !&ANYREGFNP ARG THEN <<!&LOADOPENEXP(DESTREG!&,CADR ARG,1,PREGS!&); !&LREG(DESTREG!&,!&LOCATE (CAR ARG . DESTREG!& . CDDR ARG)) >> ELSE % Must be an open function IF FLAGP(CAR ARG,'MEMMOD) AND STATUS!& < 2 THEN <<!&LOADOPENEXP(DESTREG!&,ARG,2,PREGS!&); !&LREG(DESTREG!&,IF EQCAR(CADR ARG,'!$NAME) THEN !&LOCATE CADR CADR ARG ELSE !&LOCATE CADR ARG)>> ELSE BEGIN SCALAR OPFN,ADJFN,ANYREGARGS; ANYREGARGS := !&REMOPEN(DESTREG!&,CDR ARG); OPFN := GET(CAR ARG,'OPENFN); IF IDP OPFN THEN APPLY(OPFN,LIST(DESTREG!&,ANYREGARGS,ARG)) ELSE !&CALLOPEN(OPFN,DESTREG!&,ANYREGARGS,CAR ARG) END; END; SYMBOLIC PROCEDURE !&REMOPEN(DESTREG!&,ARGS); FOR EACH ARG IN ARGS COLLECT !&ARGLOC ARG; SYMBOLIC PROCEDURE !&ARGLOC ARG; BEGIN SCALAR LOC; IF EQCAR(ARG,'!$NAME) THEN RETURN ARG; IF !&CONSTP ARG THEN RETURN ARG; IF EQCAR(ARG,'MEMORY) THEN RETURN !&MEMADDRESS ARG; IF LOC := !&RASSOC(ARG,REGS!&) THEN <<PREGS!& := CAR LOC . PREGS!&; RETURN CAR LOC>>; IF !&ANYREG ARG THEN RETURN ARG; IF !&ANYREGFNP ARG THEN RETURN (CAR ARG . !&ARGLOC CADR ARG . CDDR ARG); IF NULL DESTREG!& OR DESTREG!& MEMBER PREGS!& THEN DESTREG!& := !&TEMPREG(); IF FLAGP(CAR ARG,'MEMMOD) THEN <<!&LOADOPENEXP(DESTREG!&,ARG,2,PREGS!&); RETURN CADR CADR ARG>> ELSE !&LOADOPENEXP(DESTREG!&,ARG,1,PREGS!&); PREGS!& := DESTREG!& . PREGS!&; RETURN DESTREG!& END; SYMBOLIC PROCEDURE !&MEMADDRESS ARG; BEGIN SCALAR TEMPDEST; PREGS!& := DESTREG!& . PREGS!&; TEMPDEST := !&TEMPREG(); PREGS!& := CDR PREGS!&; ARG := CAR ARG . !&REMOPEN(TEMPDEST,CDR ARG); IF NOT(CADDR ARG = '(WCONST 0) AND NOT !&ANYREGFNP CADR ARG OR !®FP CADR ARG) THEN <<!&LREG(TEMPDEST,!&LOCATE CADR ARG); ARG := CAR ARG . TEMPDEST . CDDR ARG>>; IF CADR ARG = TEMPDEST THEN PREGS!& := TEMPDEST . PREGS!&; RETURN ARG; END; SYMBOLIC PROCEDURE !&CALLOPEN(OPFN,DEST!&,ARGS,OP); BEGIN SCALAR PATS,PARAMS,ADJFN,REGFN,ENVIRONMENT!&; PATS := CAR OPFN; IF IDP PATS THEN PATS := GET(PATS,'PATTERN); PARAMS := OP . CDR OPFN; ADJFN := CAR PATS; REGFN := CADR PATS; IF ADJFN THEN ARGS := APPLY(ADJFN,LIST ARGS); PATS := CDDR PATS; WHILE NOT NULL PATS AND NOT !&MATCHES(CAAR PATS,ARGS) DO PATS := CDR PATS; IF NULL PATS THEN <<!&COMPERROR(LIST("Compiler bug - no pattern for",OP . ARGS)); RETURN NIL>>; FOR EACH MAC IN CDAR PATS DO !&EMITMAC(!&SUBARGS(MAC,ARGS,PARAMS)); IF REGFN THEN IF IDP REGFN THEN APPLY(REGFN,LIST(OP, ARGS)) ELSE !&EMITMAC(!&SUBARGS(REGFN,ARGS,PARAMS)); RETURN NIL; END; SYMBOLIC PROCEDURE !&MATCHES(PAT,SUBJ); IF EQCAR(PAT,'QUOTE) THEN CADR PAT = SUBJ ELSE IF NULL PAT THEN NULL SUBJ ELSE IF EQCAR(PAT,'NOVAL) THEN STATUS!& > 1 AND !&MATCHES(CDR PAT,SUBJ) ELSE IF ATOM PAT THEN APPLY(GET(PAT,'MATCHFN),LIST SUBJ) ELSE PAIRP SUBJ AND !&MATCHES(CAR PAT,CAR SUBJ) AND !&MATCHES(CDR PAT,CDR SUBJ); SYMBOLIC PROCEDURE !&ANY U;T; SYMBOLIC PROCEDURE !&DEST U;U = DEST!&; % An anyreg which uses DEST!& at any level SYMBOLIC PROCEDURE !&USESDEST U; !&DEST U OR PAIRP U AND !&USESDESTL CDR U; SYMBOLIC PROCEDURE !&USESDESTL U; PAIRP U AND (!&DEST CAR U OR !&USESDEST CAR U OR !&USESDESTL CDR U); SYMBOLIC PROCEDURE !®FP U;!®P U OR EQCAR(U,'!$LOCAL); SYMBOLIC PROCEDURE !®N U; !®P U OR EQCAR(U,'!$LOCAL) OR U = '(QUOTE NIL); SYMBOLIC PROCEDURE !&MEM U; NOT(U = '(QUOTE NIL) OR EQCAR(U,'!$LOCAL)) AND (!&CONSTP U OR !&VARP U OR CAR U = 'MEMORY); SYMBOLIC PROCEDURE !&NOTANYREG U;!&MEM U OR !®FP U; SYMBOLIC PROCEDURE !&SUBARGS(MAC,ARGS,PARAMS); FOR EACH ARG IN MAC COLLECT !&SUBARG(ARG,ARGS,PARAMS); SYMBOLIC PROCEDURE !&SUBARG(ARG,ARGS,PARAMS); BEGIN SCALAR ARGFN; RETURN IF EQCAR(ARG,'QUOTE) THEN CADR ARG ELSE IF PAIRP ARG THEN !&SUBARGS(ARG,ARGS,PARAMS) ELSE IF ARG = 'DEST THEN DEST!& ELSE IF ARGFN := GET(ARG,'SUBSTFN) THEN APPLY(ARGFN,LIST(ARG,ARGS,PARAMS)) ELSE !&COMPERROR(LIST("Compiler bug", ARG,"invalid in macro")) END; SYMBOLIC PROCEDURE !&ARG1(ARG,ARGS,PARAMS); !&LOCATE CAR ARGS; SYMBOLIC PROCEDURE !&ARG2(ARG,ARGS,PARAMS); !&LOCATE CADR ARGS; SYMBOLIC PROCEDURE !&ARG3(ARG,ARGS,PARAMS); !&LOCATE CADDR ARGS; SYMBOLIC PROCEDURE !&ARG4(ARG,ARGS,PARAMS); !&LOCATE CADDDR ARGS; SYMBOLIC PROCEDURE !&PARAM1(ARG,ARGS,PARAMS); CAR PARAMS; SYMBOLIC PROCEDURE !&PARAM2(ARG,ARGS,PARAMS); CADR PARAMS; SYMBOLIC PROCEDURE !&PARAM3(ARG,ARGS,PARAMS); CADDR PARAMS; SYMBOLIC PROCEDURE !&PARAM4(ARG,ARGS,PARAMS); CADDDR PARAMS; SYMBOLIC PROCEDURE !&GETTEMP(TNAME,ARGS,PARAMS); BEGIN SCALAR TN; RETURN IF TN := ASSOC(TNAME,ENVIRONMENT!&) THEN CDR TN ELSE <<TN := !&TEMPREG(); ENVIRONMENT!& := (TNAME . TN) . ENVIRONMENT!&; PREGS!& := TN . PREGS!&; TN>>; END; SYMBOLIC PROCEDURE !&GETTEMPLBL(LNAME,ARGS,PARAMS); BEGIN SCALAR LAB; RETURN IF LAB := ASSOC(LNAME,ENVIRONMENT!&) THEN CDR LAB ELSE <<LAB := !&GENLBL(); ENVIRONMENT!& := (LNAME . LAB) . ENVIRONMENT!&; LAB>> END; SYMBOLIC PROCEDURE !&GENSYM(); % gensym local to compiler, reuses symbols BEGIN SCALAR SYMB; IF NULL CDR LOCALGENSYM!& THEN RPLACD(LOCALGENSYM!&, LIST GENSYM()); SYMB := CAR LOCALGENSYM!&; LOCALGENSYM!& := CDR LOCALGENSYM!&; RETURN SYMB; END; SYMBOLIC PROCEDURE !&COMPERROR U; << ERRORPRINTF("***** in %P: %L", NAME!&, U); ERFG!* := T >>; SYMBOLIC PROCEDURE !&COMPWARN U; !*MSG AND ERRORPRINTF("*** in %P: %L", NAME!&, U); SYMBOLIC PROCEDURE !&EMITMAC MAC; BEGIN SCALAR EMITFN; IF CAR MAC = '!*DO THEN APPLY(CADR MAC,CDDR MAC) ELSE IF CAR MAC = '!*DESTROY THEN FOR EACH REG IN CDR MAC DO REGS!& := DELASC(REG,REGS!&) ELSE IF CAR MAC = '!*SET THEN REGS!& := !&REPASC(CADR MAC,!&REMREGSL CADDR MAC,REGS!&) ELSE IF EMITFN := GET(CAR MAC,'EMITFN) THEN APPLY(EMITFN,LIST MAC) ELSE !&ATTACH MAC END; SYMBOLIC PROCEDURE !&EMITLOAD M; !&LREG(CADR M,CADDR M); SYMBOLIC PROCEDURE !&EMITSTORE M; !&STOREVAR(CADDR M,CADR M); SYMBOLIC PROCEDURE !&EMITJUMP M; !&ATTJMP CADR M; SYMBOLIC PROCEDURE !&EMITLBL M; !&ATTLBL CADR M; SYMBOLIC PROCEDURE !&EMITMEMMOD M; BEGIN SCALAR Y, X; X := CADR M; !&REMREFS X; IF EQCAR(X,'!$LOCAL) THEN WHILE Y := ASSOC(X,SLST!&) DO SLST!& := DELETIP(Y,SLST!&); IF EQCAR(X,'!$LOCAL) THEN M := CAR M . !&GETFRM X . CDDR M; !&ATTACH(GET(CAR M, 'UNMEMMOD) . CDR M); END; % Support to patterns - register adjustment functions SYMBOLIC PROCEDURE !&NOANYREG ARGS; % remove all ANYREG stuff except top level MEMORY IF NULL ARGS THEN NIL ELSE !&NOANYREG1 CAR ARGS . !&NOANYREG CDR ARGS; SYMBOLIC PROCEDURE !&NOANYREG1 ARG; IF !&ANYREGFNP ARG AND NOT EQCAR(ARG,'MEMORY) THEN !&LOADTEMPREG ARG ELSE ARG; SYMBOLIC PROCEDURE !&INREG ARGS; IF NOT !®FP CAR ARGS THEN LIST !&LOADTEMPREG CAR ARGS ELSE ARGS; SYMBOLIC PROCEDURE !®MEM ARGS; <<ARGS := !&NOANYREG ARGS; IF !&MEM CAR ARGS AND !&MEM CADR ARGS THEN !&LOADTEMPREG CAR ARGS . CDR ARGS ELSE ARGS>>; SYMBOLIC PROCEDURE !&DESTMEM ARGS; % A1 in DEST!&, A2 in MEM, rest (if any) not anyreg <<ARGS := CAR ARGS . !&NOANYREG CDR ARGS; IF STATUS!& > 1 THEN IF !®FP CAR ARGS THEN ARGS ELSE !&LOADTEMPREG CAR ARGS . CDR ARGS ELSE IF !&DEST CADR ARGS OR !&USESDEST CADR ARGS THEN !&DESTMEM(CAR ARGS . !&LOADTEMPREG CADR ARGS . CDDR ARGS) ELSE IF CAR ARGS NEQ DEST!& THEN <<!&LREG(DEST!&,!&LOCATE CAR ARGS); DEST!& . CDR ARGS>> ELSE ARGS>>; SYMBOLIC PROCEDURE !&DESTMEMA ARGS; % put either a1or A2 into DEST!&, the other to MEM. IF CAR ARGS = DEST!& THEN % A1 = DEST!&, make A1 mem or reg IF !&NOTANYREG CADR ARGS AND NOT !&USESDEST CADR ARGS THEN ARGS ELSE !&LOADTEMP2 ARGS ELSE IF CADR ARGS = DEST!& THEN % A2 = DEST!&, make A2 mem or reg IF !&NOTANYREG CAR ARGS AND NOT !&USESDEST CAR ARGS THEN ARGS ELSE !&LOADTEMP1 ARGS ELSE IF !&NOTANYREG CADR ARGS OR NOT !&NOTANYREG CAR ARGS THEN % A2 is MEM or A1 is anyreg: make A1 the destination <<IF NOT !&NOTANYREG CADR ARGS OR !&USESDEST CADR ARGS THEN ARGS := !&LOADTEMP2 ARGS; !&LREG(DEST!&,!&LOCATE CAR ARGS); DEST!& . CDR ARGS>> ELSE % Make A2 the DEST!& - only when A2 is anyreg and a1 is mem <<IF NOT !&NOTANYREG CAR ARGS OR !&USESDEST CAR ARGS THEN ARGS := !&LOADTEMP1 ARGS; !&LREG(DEST!&,!&LOCATE CADR ARGS); LIST(CAR ARGS,DEST!&)>>; SYMBOLIC PROCEDURE !&LOADTEMP1 U; % Bring first arg into a temp !&LOADTEMPREG CAR U . CDR U; SYMBOLIC PROCEDURE !&LOADTEMP2 U; % put second arg in a temp CAR U . !&LOADTEMPREG CADR U . CDDR U; SYMBOLIC PROCEDURE !&CONSARGS ARGS; IF NOT !&ANYREGFNP CADR ARGS AND CADR ARGS NEQ DEST!& OR NOT !&ANYREGFNP CAR ARGS AND CAR ARGS NEQ DEST!& THEN ARGS ELSE LIST(CAR ARGS,!&LOADTEMPREG CADR ARGS); SYMBOLIC PROCEDURE !&LOADTEMPREG ARG; % Load ARG into a temporary register. Return the register. BEGIN SCALAR TEMP; TEMP := !&TEMPREG(); PREGS!& := TEMP . PREGS!&; !&LREG(TEMP,!&LOCATE ARG); RETURN TEMP END; SYMBOLIC PROCEDURE !&FIXREGTEST(OP,ARGS); !&FIXREGTEST1(OP, first ARGS, second ARGS); SYMBOLIC PROCEDURE !&FIXREGTEST1(OP, A1, A2); % Fixes up the registers after a conditional jump has been emitted. % For JUMPEQ and JUMPNE, equalities can be assumed in REGS!& or REGS1!& % For other jumps, REGS!& copied onto REGS1!&. <<REGS1!& := REGS!&; IF OP = 'EQ OR OP = 'NE THEN IF NOT !®P A1 THEN << IF !®P A2 THEN !&FIXREGTEST1(OP,A2,A1) >> ELSE <<IF OP = 'EQ THEN REGS1!& := !&ADDRVALS(A1,REGS1!&,!&REMREGS A2) ELSE REGS!& := !&ADDRVALS(A1,REGS!& ,!&REMREGS A2)>>>>; SYMBOLIC PROCEDURE !&SETREGS1(OP, ARGS); REGS1!& := REGS!&; % Find the location of a variable SYMBOLIC PROCEDURE !&LOCATE X; BEGIN SCALAR Y,VTYPE; % Constants are their own location IF ATOM X OR EQCAR(X,'LABEL) OR !&CONSTP X THEN RETURN X; IF EQCAR(X,'!$NAME) THEN RETURN CADR X; IF CAR X = 'MEMORY THEN RETURN(CAR X . !&LOCATE CADR X . CDDR X); IF Y := !&RASSOC(X,REGS!&) THEN RETURN CAR Y; % If in a register, return the register number % Registers are their own location % For ANYREG stuff, locate each constant IF !&ANYREGFNP X THEN RETURN CAR X . !&LOCATEL CDR X; IF NOT EQCAR(X,'!$LOCAL) THEN RETURN X; % Since the value of the variable has been referenced, a previous store was % justified, so it can be removed from SLST!& % Must be in the frame, otherwise make nonlocal (really ought to be an error) % Frame location (<=0) is returned WHILE Y := ASSOC(X,SLST!&) DO SLST!& := DELETIP(Y,SLST!&); IF Y := ASSOC(X,STOMAP!&) THEN RETURN CADR Y; % Nasty compiler bug. Until we fix it, tell the user to simplify expressions !&COMPERROR LIST ("Compiler bug: expression too complicated, please simplify",X); RETURN '(QUOTE 0); % just so it doesn't blow up END; SYMBOLIC PROCEDURE !&LOCATEL U; FOR EACH X IN U COLLECT !&LOCATE X; % Load register REG with value U. V (always NIL except when called from % LOADARGS) is a list of other loads to be done SYMBOLIC PROCEDURE !&LREG(REG,VAL); BEGIN SCALAR ACTUALVAL; ACTUALVAL := !&REMREGS VAL; IF REG = VAL OR ACTUALVAL MEMBER !®VAL REG THEN RETURN NIL; !&ATTACH LIST('!*MOVE,VAL,REG); REGS!& := !&REPASC(REG,ACTUALVAL,REGS!&); END; % Load register 1 with X SYMBOLIC PROCEDURE !&LREG1(X); !&LOADOPENEXP('(REG 1),X,1,PREGS!&); SYMBOLIC PROCEDURE !&JUMPT LAB; !&ATTACH LIST('!*JUMPNOTEQ,LAB,'(REG 1),'(QUOTE NIL)); SYMBOLIC PROCEDURE !&JUMPNIL LAB; !&ATTACH LIST('!*JUMPEQ,LAB,'(REG 1),'(QUOTE NIL)); COMMENT Functions for Handling Non-local Variables; SYMBOLIC PROCEDURE !&VARBIND(VARS,LAMBP); %bind FLUID variables in lambda or prog lists; %LAMBP is true for LAMBDA, false for PROG; BEGIN SCALAR VLOCS,VNAMES,FREGS,Y,REG,TAIL; INTEGER I; I := 1; FOR EACH X IN VARS DO << REG := !&MKREG I; IF EQCAR(X,'!$GLOBAL) THEN % whoops << !&COMPWARN LIST("Illegal to bind global", CADR X, "but binding anyway"); RPLACA(X,'!$FLUID) >>; % cheat a little IF EQCAR(X,'!$FLUID) THEN <<FREEBOUND!& := T; VNAMES := X . VNAMES; IF NOT !*NOFRAMEFLUID THEN VLOCS := !&FRAME X . VLOCS; FREGS := REG . FREGS>> ELSE IF EQCAR(X,'!$LOCAL) THEN <<!&FRAME X; !&STORELOCAL(X,IF LAMBP THEN REG ELSE NIL)>> ELSE !&COMPERROR LIST("Cannot bind non-local variable",X); IF LAMBP THEN IF EQCAR(X,'!$LOCAL) THEN REGS!& := !&REPASC(REG,LIST X,REGS!&) ELSE REGS!& := !&REPASC(REG,NIL,REGS!&); I := I + 1>>; IF NULL VNAMES THEN RETURN NIL; VNAMES := 'NONLOCALVARS . VNAMES; FREGS := 'REGISTERS . FREGS; VLOCS := 'FRAMES . VLOCS; TAIL := IF !*NOFRAMEFLUID THEN LIST VNAMES ELSE LIST(VNAMES,VLOCS); IF LAMBP THEN !&ATTACH('!*LAMBIND . FREGS . TAIL) ELSE !&ATTACH('!*PROGBIND . TAIL); IF !*UNSAFEBINDER THEN REGS!& := NIL; RETURN TAIL; END; SYMBOLIC PROCEDURE !&FREERSTR(ALSTS!&,STATUS!&); %restores FLUID variables; IF ALSTS!& THEN << !&ATTACH('!*FREERSTR . ALSTS!&); IF !*UNSAFEBINDER THEN REGS!& := NIL >>; % ATTACH is used to emit code SYMBOLIC PROCEDURE !&ATTACH U; CODELIST!& := U . CODELIST!&; SYMBOLIC PROCEDURE !&STORELOCAL(U,REG); %marks expression U in register REG for storage; BEGIN SCALAR X; IF NULL REG THEN REG := '(QUOTE NIL); X := LIST('!*MOVE,REG,!&GETFRM U); % Update list of stores done so far !&ATTACH X; % Zap out earlier stores if there were never picked up % ie, if you store to X, then a ref to X will remove this store from % SLST!&. Otherwise, the previous store will be removed by CLRSTR % SLST!& is for variables only (anything else?) !&CLRSTR U; SLST!& := (U . CODELIST!&) . SLST!&; END; SYMBOLIC PROCEDURE !&CLRSTR VAR; %removes unneeded stores; BEGIN SCALAR X; % Inside conditionals, you cant tell if store was on the same path IF CONDTAIL!& THEN RETURN NIL; X := ASSOC(VAR,SLST!&); IF NULL X THEN RETURN NIL; SLST!& := DelQIP(X,SLST!&); !&DELMAC CDR X; END; COMMENT Functions for general tests; SYMBOLIC PROCEDURE !&COMTST(EXP,LABL); %compiles boolean expression EXP. %If EXP has the same value as SWITCH!& then branch to LABL, %otherwise fall through; %REGS are active registers for fall through, %REGS1 for branch; BEGIN SCALAR X,FN,REG; % First factor out NOT's to set up the SWITCH!& WHILE EQCAR(EXP,'EQ) AND CADDR EXP = '(QUOTE NIL) DO <<SWITCH!& := NOT SWITCH!&; EXP := CADR EXP>>; % Dispatch a built in compiling function IF NOT SWITCH!& AND (FN := GET(CAR EXP,'FLIPTST)) THEN EXP := FN . CDR EXP; % SWITCH!& is assumed to be true by fn's with % a flip test IF FN := GET(CAR EXP,'OPENTST) THEN <<IF ATOM FN THEN APPLY(FN,LIST(EXP,LABL)) ELSE !&COMOPENTST(FN,EXP,LABL,PREGS!&)>> % Trivial case of condition is T. FLAGG!& indicates jump cannot take place ELSE <<IF EQCAR(EXP,'QUOTE) THEN IF SWITCH!& AND CADR EXP OR (NOT SWITCH!&) AND (NOT CADR EXP) THEN <<REGS1!& := REGS!&; !&ATTJMP LABL>> ELSE FLAGG!& := T ELSE <<!&COMTST(LIST('NE,EXP,'(QUOTE NIL)),LABL)>>>> END; SYMBOLIC PROCEDURE !&COMOPENTST(PAT,EXP,DESTLAB,PREGS!&); BEGIN SCALAR ANYREGARGS,ADJFN; ANYREGARGS := !&REMOPEN(!&TEMPREG(),!&COMLIS CDR EXP); !&CALLOPEN(PAT,DESTLAB,ANYREGARGS,CAR EXP) END; % Remove variables to avoid name conflicts: Hide variable names which match % new names when entering an inner function. Other names will be available % as global info. VARS is the list of new variable names, the result is a % list of protected stores. SYMBOLIC PROCEDURE !&REMVARL VARS; FOR EACH X IN VARS COLLECT !&PROTECT X; % Delete all references to U from SLST!& % return the protected store SYMBOLIC PROCEDURE !&PROTECT U; BEGIN SCALAR X; IF X := ASSOC(U,SLST!&) THEN SLST!& := DelQIP(X,SLST!&); RETURN X END; % Restore a previous ENVIRONMENT!&. VARS is the list of variables taken out % of the ENVIRONMENT!&; LST is the list of protected stores. One or zero % stores for each variable. SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST); WHILE VARS DO <<!&RSTVAR(CAR VARS,CAR LST); VARS := CDR VARS; LST := CDR LST>>; % Restore a particular variable and STORE SYMBOLIC PROCEDURE !&RSTVAR(VAR,VAL); BEGIN !&REMREFS VAR; !&CLRSTR VAR; % Put back on store list if not NIL !&UNPROTECT VAL END; SYMBOLIC PROCEDURE !&UNPROTECT VAL; %restores VAL to SLST!&; IF VAL THEN SLST!& := VAL . SLST!&; SYMBOLIC PROCEDURE !&STOREVAR(U,V); % The store generated by a SETQ BEGIN SCALAR VTYPE,X; !&REMREFS U; IF CAR U = '!$LOCAL THEN !&STORELOCAL(U,V) ELSE !&ATTACH LIST('!*MOVE,V,U); IF !®P V THEN REGS!& := !&ADDRVALS(V,REGS!&,LIST U) END; COMMENT Support Functions; SYMBOLIC PROCEDURE !&REFERENCES(EXP,VAR); % True if expression EXP (probably ANYREG) references VAR. EXP = VAR OR IF ATOM EXP OR FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE !&REFERENCESL(CDR EXP,VAR); SYMBOLIC PROCEDURE !&REFERENCESL(EXP,VAR); IF NULL EXP THEN NIL ELSE !&REFERENCES(CAR EXP,VAR) OR !&REFERENCESL(CDR EXP,VAR); SYMBOLIC PROCEDURE !&CFNTYPE FN; BEGIN SCALAR X; RETURN IF X := GET(FN,'CFNTYPE) THEN CAR X ELSE IF X := GETD FN THEN CAR X ELSE 'EXPR END; SYMBOLIC PROCEDURE !&GENLBL; BEGIN SCALAR L; L := LIST('LABEL,!&GENSYM()); LBLIST!& := LIST L . LBLIST!&; RETURN L END; SYMBOLIC PROCEDURE !&GETLBL LABL; BEGIN SCALAR X; X := ASSOC(LABL,GOLIST!&); IF NULL X THEN !&COMPERROR LIST("Compiler bug: missing label", LABL); RETURN CDR X END; SYMBOLIC PROCEDURE !&ATTLBL LBL; IF CAAR CODELIST!& EQ '!*LBL THEN !&DEFEQLBL(LBL,CADR CAR CODELIST!&) ELSE !&ATTACH LIST('!*LBL,LBL); SYMBOLIC PROCEDURE !&ATTJMP LBL; BEGIN IF CAAR CODELIST!& EQ '!*LBL THEN <<!&DEFEQLBL(LBL,CADR CAR CODELIST!&); !&DELMAC CODELIST!&>>; IF !&TRANSFERP CODELIST!& THEN RETURN NIL; !&ATTACH LIST('!*JUMP,LBL); END; SYMBOLIC PROCEDURE !&TRANSFERP X; IF CAAR X = '!*NOOP THEN !&TRANSFERP CDR X ELSE FLAGP(IF CAAR X EQ '!*LINK THEN CADAR X ELSE CAAR X,'TRANSFER); SYMBOLIC PROCEDURE !&DEFEQLBL(LAB1,LAB2); LBLIST!& := !&DEFEQLBL1(LBLIST!&,LAB1,LAB2); SYMBOLIC PROCEDURE !&DEFEQLBL1(LABS,LAB1,LAB2); IF LAB1 MEMBER CAR LABS THEN IF LAB2 MEMBER CAR LABS THEN LABS ELSE APPEND(!&LABCLASS LAB2,CAR LABS) . !&DELCLASS(LAB2,CDR LABS) ELSE IF LAB2 MEMBER CAR LABS THEN APPEND(!&LABCLASS LAB1,CAR LABS) . !&DELCLASS(LAB1,CDR LABS) ELSE CAR LABS . !&DEFEQLBL1(CDR LABS,LAB1,LAB2); SYMBOLIC PROCEDURE !&LABCLASS(LAB); BEGIN SCALAR TEMP; TEMP := LBLIST!&; WHILE TEMP AND NOT (LAB MEMBER CAR TEMP) DO TEMP := CDR TEMP; RETURN IF TEMP THEN CAR TEMP ELSE NIL; END; SYMBOLIC PROCEDURE !&DELCLASS(LAB,LABS); IF LAB MEMBER CAR LABS THEN CDR LABS ELSE CAR LABS . !&DELCLASS(LAB,CDR LABS); SYMBOLIC PROCEDURE !&LBLEQ(LAB1,LAB2); LAB1 MEMBER !&LABCLASS LAB2; SYMBOLIC PROCEDURE !&FRAME U; %allocates space for U in frame; BEGIN SCALAR Z,RES; Z := IF NULL STOMAP!& THEN 1 ELSE 1 + CADR CADAR STOMAP!&; RES := !&MKFRAME Z; STOMAP!& := LIST(U,RES) . STOMAP!&; LLNGTH!& := MAX(Z,LLNGTH!&); RETURN RES END; % GETFRM returns the frame location on a variable SYMBOLIC PROCEDURE !&GETFRM U; BEGIN SCALAR X; IF X:=ASSOC(U,STOMAP!&) THEN RETURN CADR X; !&COMPERROR LIST("Compiler bug: lost variable",U) END; %************************************************************************* % The following functions determine classes or properties of expressions * %************************************************************************* SYMBOLIC PROCEDURE !&ANYREG U; % !&ANYREG determines if U is an ANYREG expression % % ANYREG expressions are those expressions which may be loaded into any % register without the use of (visable) temporary registers. It is assumed % that ANYREG expressions have no side effects. % % ANYREG expressions are defined as constants, variables, and ANYREG functions % whose arguments are ANYREG expressions. Note that ANYREG functions are % not necessarily a part of ANYREG expressions; their arguments may not be % ANYREG expressions. !&CONSTP U OR !&VARP U OR !&ANYREGFNP U AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&ANYREGL U; NULL U OR !&ANYREG(CAR U) AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&ANYREGFNP U; % !&ANYREGFNP is true when U is an ANYREG function. The arguments are not % checked !&ANYREGP CAR U; SYMBOLIC PROCEDURE !&OPENP U; !&CONSTP U OR !&VARP U OR (!&ANYREGFNP U OR !&OPENFNP U) AND !&OPENPL CDR U; SYMBOLIC PROCEDURE !&OPENPL U; NULL U OR !&OPENP CAR U AND !&OPENPL CDR U; SYMBOLIC PROCEDURE !&OPENFNP U; GET(CAR U,'OPENFN); SYMBOLIC PROCEDURE !&CONSTP U; % True if U is a constant expression IDP CAR U AND FLAGP(CAR U,'CONST); SYMBOLIC PROCEDURE !&VARP U; % True if U is a variable: (LOCAL x),(FLUID x), ... PAIRP U AND FLAGP(CAR U,'VAR); SYMBOLIC PROCEDURE !®P U; PAIRP U AND FLAGP(CAR U,'REG); SYMBOLIC PROCEDURE !&NOSIDEEFFECTP U; % True if the expression U has no side effects. ANYREG expressions and % functions are assumed to have no side effects; other functions must be % flagged NOSIDEEFFECT. All arguments to a function must also be NOSIDEEFFECT. !&ANYREG U OR (!&ANYREGFNP U OR FLAGP(CAR U,'NOSIDEEFFECT)) AND !&NOSIDEEFFECTPL CDR U; SYMBOLIC PROCEDURE !&NOSIDEEFFECTPL U; NULL U OR !&NOSIDEEFFECTP CAR U AND !&NOSIDEEFFECTPL CDR U; %********************************************************************** % Basic register manipulation utilities %********************************************************************** SYMBOLIC PROCEDURE !&RVAL(R,RGS); % Return the set of values in register R as determined by register list RGS IF NULL RGS THEN NIL ELSE IF CAAR RGS = R THEN CDAR RGS ELSE !&RVAL(R,CDR RGS); SYMBOLIC PROCEDURE !®VAL R; % Normally, register contents are found in register list REGS!&. !&RVAL(R,REGS!&); SYMBOLIC PROCEDURE !&ADDRVALS(REG,RGS,VALS); % Add the values VALS to the contents of REG in register list RGS IF NULL RGS THEN LIST (REG . VALS) ELSE IF CAAR RGS = REG THEN (CAAR RGS . APPEND(VALS,CDAR RGS)) . CDR RGS ELSE CAR RGS . !&ADDRVALS(REG,CDR RGS,VALS); SYMBOLIC PROCEDURE !&MKREG NUM; % Used to generate a tagged register from a register number BEGIN SCALAR AENTRY; RETURN IF AENTRY := ASSOC(NUM, '((1 . (REG 1)) (2 . (REG 2)) (3 . (REG 3)) (4 . (REG 4)) (5 . (REG 5)) (6 . (REG 6)) (7 . (REG 7)) (8 . (REG 8)) (9 . (REG 9)))) THEN CDR AENTRY ELSE LIST('REG,NUM); END; SYMBOLIC PROCEDURE !&MKFRAME NUM; % Used to generate a tagged register from a register number BEGIN SCALAR AENTRY; RETURN IF AENTRY := ASSOC(NUM, '((1 . (FRAME 1)) (2 . (FRAME 2)) (3 . (FRAME 3)) (4 . (FRAME 4)) (5 . (FRAME 5)) (6 . (FRAME 6)) (7 . (FRAME 7)) (8 . (FRAME 8)) (9 . (FRAME 9)))) THEN CDR AENTRY ELSE LIST('FRAME,NUM); END; SYMBOLIC PROCEDURE !&RASSOC(VAL,RGS); % Find a register in register list RGS which contains VAL. NIL is returned if % VAL is not present in RGS IF NULL RGS THEN NIL ELSE IF VAL MEMBER CDAR RGS THEN CAR RGS ELSE !&RASSOC(VAL,CDR RGS); SYMBOLIC PROCEDURE !&REPASC(REG,VAL,REGL); % Replace the contants of REG in list REGL by the value VAL IF NULL REGL THEN LIST (REG . VAL) ELSE IF REG=CAAR REGL THEN (REG . VAL) . CDR REGL ELSE CAR REGL . !&REPASC(REG,VAL,CDR REGL); SYMBOLIC PROCEDURE !&RMERGE U; % RMERGE takes a list of register contents representing the information % present in the registers from a number of different ways to reach the same % place. RMERGE returns whatever information is known to be in the registers % regardless of which path was taken. IF NULL U THEN NIL ELSE BEGIN SCALAR RES,CONTENTS; RES := NIL; FOR EACH RG IN CAR U DO <<CONTENTS := NIL; FOR EACH THING IN CDR RG DO IF !&INALL(THING,CAR RG,CDR U) THEN CONTENTS := THING . CONTENTS; IF CONTENTS THEN RES := (CAR RG . CONTENTS) . RES>>; RETURN RES; END; SYMBOLIC PROCEDURE !&INALL(THING,RG,LST); NULL LST OR (THING MEMBER !&RVAL(RG,CAR LST)) AND !&INALL(THING,RG,CDR LST); SYMBOLIC PROCEDURE !&TEMPREG(); BEGIN SCALAR I,R,EMPTY,UNPROT; EMPTY := UNPROT := NIL; I := 1; WHILE I <= MAXNARGS!& AND NOT EMPTY DO <<R := !&MKREG I; IF NOT(R MEMBER PREGS!&) THEN IF I <= LASTACTUALREG!& AND NULL !®VAL R THEN EMPTY := R ELSE IF NOT UNPROT THEN UNPROT := R; I := I + 1 >>; IF EMPTY THEN RETURN EMPTY; IF UNPROT THEN RETURN UNPROT; !&COMPERROR("Compiler bug: Not enough registers"); RETURN '(REG ERROR); END; SYMBOLIC PROCEDURE !&REMREGS U; IF !®P U THEN !®VAL U ELSE IF EQCAR(U,'FRAME) THEN LIST !&GETFVAR (U,STOMAP!&) ELSE IF !&CONSTP U OR !&VARP U THEN LIST U ELSE !&REMREGSL U; SYMBOLIC PROCEDURE !&GETFVAR (V,SMAP); IF NULL SMAP THEN !&COMPERROR(LIST("Compiler bug:", V,"evaporated?")) ELSE IF CADAR SMAP = V THEN CAAR SMAP ELSE !&GETFVAR (V,CDR SMAP); SYMBOLIC PROCEDURE !&REMREGSL U; FOR EACH ARG IN !&ALLARGS CDR U COLLECT (CAR U . ARG); SYMBOLIC PROCEDURE !&ALLARGS ARGLST; if null Arglst then NIL else IF NULL CDR ARGLST THEN FOR EACH VAL IN !&REMREGS CAR ARGLST COLLECT LIST VAL ELSE !&ALLARGS1(!&REMREGS CAR ARGLST,!&ALLARGS CDR ARGLST); SYMBOLIC PROCEDURE !&ALLARGS1(FIRSTARGS,RESTARGS); BEGIN SCALAR RES; RES := NIL; FOR EACH A1 IN FIRSTARGS DO FOR EACH A2 IN RESTARGS DO RES := (A1 . A2) . RES; RETURN RES; END; SYMBOLIC PROCEDURE !&REMMREFS(); REGS!& := FOR EACH R IN REGS!& COLLECT (CAR R . !&REMMREFS1 CDR R); SYMBOLIC PROCEDURE !&REMMREFS1 L; IF NULL L THEN L ELSE IF !&REFMEMORY CAR L THEN !&REMMREFS1 CDR L ELSE CAR L . !&REMMREFS1 CDR L; SYMBOLIC PROCEDURE !&REFMEMORY EXP; IF ATOM EXP OR FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE CAR EXP MEMBER '(MEMORY CAR CDR) OR !&REFMEMORYL CDR EXP; SYMBOLIC PROCEDURE !&REFMEMORYL L; IF NULL L THEN NIL ELSE !&REFMEMORY CAR L OR !&REFMEMORYL CDR L; SYMBOLIC PROCEDURE !&REMVREFS; BEGIN SCALAR S; REGS!& := FOR EACH R IN REGS!& COLLECT (CAR R . !&REMVREFS1 CDR R); % Slow version: % SLST!& := FOR EACH S IN SLST!& CONC % IF !&EXTERNALVARP CAR S THEN NIL ELSE LIST S; % Faster version: while not null Slst!& and !&ExternalVarP car car Slst!& do Slst!& := cdr Slst!&; S := Slst!&; while not null S and not null cdr S do << if !&ExternalVarP car car cdr S then Rplacd(S, cddr S); S := cdr S >>; END; SYMBOLIC PROCEDURE !&REMVREFS1 L; FOR EACH THING IN L CONC IF !&REFEXTERNAL THING THEN NIL ELSE LIST THING; SYMBOLIC PROCEDURE !&REFEXTERNAL EXP; IF ATOM EXP THEN NIL ELSE IF !&EXTERNALVARP EXP THEN T ELSE IF FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE !&REFEXTERNALL CDR EXP; SYMBOLIC PROCEDURE !&REFEXTERNALL EXPS; IF NULL EXPS THEN NIL ELSE !&EXTERNALVARP CAR EXPS OR !&REFEXTERNALL CDR EXPS; SYMBOLIC PROCEDURE !&EXTERNALVARP U; PAIRP U AND FLAGP(CAR U,'EXTVAR); SYMBOLIC PROCEDURE !&REMREFS V; % Remove all references to V from REGS!& IF CAR V MEMBER '(MEMORY CAR CDR) THEN !&REMMREFS() ELSE REGS!& := FOR EACH R IN REGS!& COLLECT CAR R . !&REMREFS1(V,CDR R); SYMBOLIC PROCEDURE !&REMREFS1(X,LST); % Remove all expressions from LST which reference X IF NULL LST THEN NIL ELSE IF !&REFERENCES(CAR LST,X) THEN !&REMREFS1(X,CDR LST) ELSE CAR LST . !&REMREFS1(X,CDR LST); %************************************************************ % Test functions %************************************************************ SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL); BEGIN SCALAR FLG,FLG1,FN,LAB2,REGSL,REGS1L, TAILP; %FLG is initial SWITCH!& condition; %FN is appropriate AND/OR case; %FLG1 determines appropriate switching state; FLG := SWITCH!&; SWITCH!& := NIL; FN := CAR EXP EQ 'AND; FLG1 := FLG EQ FN; EXP := CDR EXP; LAB2 := !&GENLBL(); WHILE EXP DO <<SWITCH!& := NIL; IF NULL CDR EXP AND FLG1 THEN <<IF FN THEN SWITCH!& := T; !&COMTST(CAR EXP,LABL); REGSL := REGS!& . REGSL; REGS1L := REGS1!& . REGS1L>> ELSE <<IF NOT FN THEN SWITCH!& := T; IF FLG1 THEN <<!&COMTST(CAR EXP,LAB2); REGSL := REGS1!& . REGSL; REGS1L := REGS!& . REGS1L>> ELSE <<!&COMTST(CAR EXP,LABL); REGSL := REGS!& . REGSL; REGS1L := REGS1!& . REGS1L>>>>; IF NULL TAILP THEN <<CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T>>; EXP := CDR EXP>>; !&ATTLBL LAB2; REGS!& := IF NOT FLG1 THEN CAR REGSL ELSE !&RMERGE REGSL; REGS1!& := IF FLG1 THEN CAR REGS1L ELSE !&RMERGE REGS1L; IF TAILP THEN CONDTAIL!& := CDR CONDTAIL!&; SWITCH!& := FLG END; %************************************************************ % Pass2 compile functions %************************************************************ SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS!&); BEGIN SCALAR FN,LABL,REGSL; FN := CAR EXP EQ 'AND; LABL := !&GENLBL(); EXP := CDR EXP; WHILE EXP DO <<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS!&); %to allow for recursion on last entry; REGSL := REGS!& . REGSL; IF CDR EXP THEN IF FN THEN !&JUMPNIL LABL ELSE !&JUMPT LABL; EXP := CDR EXP>>; REGS!& := !&RMERGE REGSL; !&ATTLBL LABL END; SYMBOLIC PROCEDURE !&COMAPPLY(EXP,STATUS); % Look for LIST; BEGIN SCALAR FN,ARGS, N,NN; EXP := CDR EXP; FN := CAR EXP; ARGS := CDR EXP; IF NULL ARGS OR CDR ARGS OR NOT (PAIRP CAR ARGS AND CAAR ARGS MEMBER '(LIST QUOTE NCONS LIST1 LIST2 LIST3 LIST4 LIST5)) OR LENGTH CDAR ARGS>MAXNARGS!& THEN RETURN !&CALL('APPLY,EXP,STATUS); ARGS := IF EQCAR(CAR ARGS,'QUOTE) THEN FOR EACH THING IN CADAR ARGS COLLECT LIST('QUOTE,THING) ELSE CDAR ARGS; NN := LENGTH ARGS; ARGS := REVERSIP (FN . REVERSE ARGS); !&LOADARGS(REVERSIP !&COMLIS ARGS,1,PREGS!&); !&ATTACH LIST('!*MOVE, !&MKREG(NN + 1), '(REG T1)); !&ATTACH LIST('!*LINK,'FASTAPPLY,'EXPR, NN); REGS!& := NIL; !&REMVREFS(); END; %Bug fix to COMCOND - tail has (QUOTE T) not T. Test for tail screwed up anyway SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS!&); %compiles conditional expressions; %registers REGS!& are set for dropping through, %REGS1 are set for a branch; BEGIN SCALAR REGS1!&,FLAGG!&,SWITCH!&,LAB1,LAB2,REGSL, TAILP; EXP := CDR EXP; LAB1 := !&GENLBL(); FOR EACH X ON EXP DO % Changed IN -> ON <<LAB2 := !&GENLBL(); SWITCH!& := NIL; IF CDR X THEN !&COMTST(CAAR X,LAB2) % CAR -> CAAR %update CONDTAIL!&; ELSE IF CAAR X = '(QUOTE T) THEN % CAR -> CAAR, T->(QUOTE T) FLAGG!& := T ELSE <<!&COMVAL(CAAR X,1); % CAR -> CAAR !&JUMPNIL LAB2; REGS1!& := !&ADDRVALS('(REG 1), REGS!&, list '(QUOTE NIL)) >>; IF NULL TAILP THEN <<CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T>>; !&COMVAL(CADR CAR X,STATUS!&); %X -> CAR X % Branch code; %test if need jump to LAB1; IF NOT FLAGG!& THEN % New line <<IF NOT !&TRANSFERP CODELIST!& THEN <<!&ATTJMP LAB1; REGSL := REGS!& . REGSL>>; REGS!& := REGS1!&;>>; %restore register status for next iteration; %we do not need to set REGS1!& to NIL since all COMTSTs %are required to set it; !&ATTLBL LAB2>>; IF NULL FLAGG!& AND STATUS!&<2 THEN <<!&LREG1('(QUOTE NIL)); REGS!& := !&RMERGE(REGS!& . REGSL)>> ELSE IF REGSL THEN REGS!& := !&RMERGE(REGS!& . REGSL); !&ATTLBL LAB1; IF TAILP THEN CONDTAIL!& := CDR CONDTAIL!& END; SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS!&); IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP THEN !&COMPERROR LIST("Wrong number of arguments to CONS",EXP) ELSE IF CADR EXP='(QUOTE NIL) THEN !&CALL('NCONS,LIST CAR EXP,STATUS!&) ELSE IF CADR EXP MEMBER !®VAL '(REG 1) AND !&OPENP CAR EXP THEN !&CALL1('XCONS,!&COMLIS EXP,STATUS!&) ELSE IF !&OPENP CADR EXP THEN !&CALL('CONS,EXP,STATUS!&) ELSE !&CALL1('XCONS,!&COMLIS EXP,STATUS!&); SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS!&); << IF STATUS!&>1 THEN <<!&ATTJMP !&GETLBL CADR EXP; SLST!& := NIL>> ELSE !&COMPERROR LIST(EXP,"invalid go")>>; SYMBOLIC PROCEDURE !&COMCASE(EXP,STATUS!&); BEGIN SCALAR BOTTOMLAB,REGS1!&,JUMPS,EXPS,ELSELAB,HIGH,LOW,SAVEREGS, JMPS,JLIST,RANGES,TABLE,TAILP; BOTTOMLAB := !&GENLBL(); REGS1!& := NIL; !&COMVAL(CADR EXP,1); JUMPS := EXPS := NIL; CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T; FOR EACH THING ON CDDR EXP DO BEGIN SCALAR LAB; LAB := !&GENLBL(); JUMPS := NCONC(JUMPS,LIST LIST(CAAR THING,LAB)); EXPS := NCONC(EXPS,LIST LIST(LAB,CADAR THING)); IF NULL CDR THING THEN IF NOT NULL CAAR THING THEN IF STATUS!& > 1 THEN <<REGS1!& := REGS!& . REGS1!&; ELSELAB := BOTTOMLAB>> ELSE EXPS := NCONC(EXPS,LIST LIST(ELSELAB := !&GENLBL(), '(QUOTE NIL))) ELSE ELSELAB := LAB; END; RANGES := NIL; TABLE := NIL; FOR EACH JMP IN JUMPS DO FOR EACH NUM IN CAR JMP DO IF EQCAR(NUM,'RANGE) THEN BEGIN SCALAR HIGH,LOW; LOW := !&GETNUM CADR NUM; HIGH := !&GETNUM CADDR NUM; IF HIGH >= LOW THEN IF HIGH - LOW < 6 THEN FOR I := LOW:HIGH DO TABLE := !&INSTBL(TABLE,I,CADR JMP) ELSE RANGES := NCONC(RANGES,LIST LIST(LOW,HIGH,CADR JMP)); END ELSE TABLE := !&INSTBL(TABLE,!&GETNUM NUM,CADR JMP); FOR EACH R IN RANGES DO !&ATTACH LIST('!*JUMPWITHIN,CADDR R,CAR R,CADR R); WHILE TABLE DO <<JMPS := LIST CAR TABLE; LOW := HIGH := CAAR TABLE; JLIST := LIST CADAR TABLE; WHILE CDR TABLE AND CAR CADR TABLE < HIGH + 5 DO <<TABLE := CDR TABLE; WHILE HIGH < (CAAR TABLE) - 1 DO <<HIGH := HIGH + 1; JLIST := NCONC(JLIST,LIST ELSELAB)>>; HIGH := HIGH + 1; JLIST := NCONC(JLIST,LIST CADAR TABLE); JMPS := NCONC(JMPS,LIST CAR TABLE)>>; IF LENGTH JMPS < 4 THEN FOR EACH J IN JMPS DO !&ATTACH LIST('!*JUMPEQ,CADR J,'(REG 1),LIST('WCONST,CAR J)) ELSE !&ATTACH('!*JUMPON . '(REG 1) . LOW . HIGH . JLIST); TABLE := CDR TABLE>>; !&ATTJMP ELSELAB; SAVEREGS := REGS!&; FOR EACH THING IN EXPS DO <<!&ATTLBL CAR THING; REGS!& := SAVEREGS; IF CADR THING THEN !&COMVAL(CADR THING,STATUS!&); IF NOT !&TRANSFERP CODELIST!& THEN <<!&ATTJMP BOTTOMLAB; REGS1!& := REGS!& . REGS1!&>> >>; !&ATTLBL BOTTOMLAB; REGS!& := !&RMERGE REGS1!&; CONDTAIL!& := CDR CONDTAIL!& END; SYMBOLIC PROCEDURE !&INSTBL(TBL,I,L); IF NULL TBL THEN LIST LIST(I,L) ELSE IF I < CAAR TBL THEN LIST(I,L) . TBL ELSE IF I = CAAR TBL THEN !&COMPERROR LIST("Ambiguous case",TBL) ELSE CAR TBL . !&INSTBL(CDR TBL,I,L); SYMBOLIC PROCEDURE !&GETNUM X; IF !&WCONSTP X AND NUMBERP CADR X THEN CADR X ELSE !&COMPERROR(LIST("Number expected for CASE label",X)); SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS!&); %compiles program blocks; BEGIN SCALAR ALSTS!&,GOLIST!&,PG,PROGLIS,EXITT!&,EXITREGS!&; INTEGER I; %SCALAR OLDSTOMAP,OLDCODE; % OLDCODE := CODELIST!&; % OLDSTOMAP := STOMAP!&; EXITREGS!& := NIL; PROGLIS := CADR EXP; EXP := CDDR EXP; EXITT!& := !&GENLBL(); PG := !&REMVARL PROGLIS; %protect prog variables; ALSTS!& := !&VARBIND(PROGLIS,NIL); FOR EACH X IN EXP DO IF ATOM X THEN GOLIST!& := (X . !&GENLBL()) . GOLIST!&; WHILE EXP DO <<IF ATOM CAR EXP THEN <<!&ATTLBL !&GETLBL CAR EXP; REGS!& := NIL>> ELSE !&COMVAL(CAR EXP,IF STATUS!&>2 THEN 4 ELSE 3); EXP := CDR EXP>>; IF NOT !&TRANSFERP CODELIST!& AND STATUS!& < 2 THEN !&LREG1('(QUOTE NIL)); !&ATTLBL EXITT!&; REGS!& := !&RMERGE (REGS!& . EXITREGS!&); !&FREERSTR(ALSTS!&,STATUS!&); !&RSTVARL(PROGLIS,PG); %/ !&FIXFRM(OLDSTOMAP,OLDCODE,0); END; SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS!&); BEGIN EXP := CDR EXP; IF NULL EXP THEN RETURN !&COMVAL('(QUOTE NIL), STATUS!&); WHILE CDR EXP DO <<!&COMVAL(CAR EXP,IF STATUS!&<2 THEN 2 ELSE STATUS!&); EXP := CDR EXP>>; !&COMVAL(CAR EXP,STATUS!&) END; SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS!&); << EXP := CDR EXP; IF NULL EXP OR NOT NULL CDR EXP THEN << !&COMPERROR LIST("RETURN must have exactly one argument",EXP); EXP := '((QUOTE NIL)) >>; IF STATUS!&<4 OR NOT !&NOSIDEEFFECTP(CAR EXP) THEN !&LREG1(CAR !&COMLIS1 EXP); SLST!& := NIL; EXITREGS!& := REGS!& . EXITREGS!&; !&ATTJMP EXITT!& >>; SYMBOLIC PROCEDURE !&DELMAC X; % Delete macro CAR X from CODELIST!& RPLACA(X,'(!*NOOP)); %************************************************************* % Pass 3 %************************************************************* COMMENT Post Code Generation Fixups; SYMBOLIC PROCEDURE !&PASS3; % Pass 3 - optimization. % The optimizations currently performed are: % 1. Deletion of stores not yet picked up from SLST!&. % 2. Removal of unreachable macros. % 3. A peep hole optimizer, currently only optmizing LBL macros. % 4. Removal of common code chains % 5. Changing LINK to LINKE where possible % 6. Squeezing out unused frame locations and mapping the stack onto % the registers. % Other functions of PASS3 are to tack exit code on the end and reverse % the code list. << FOR EACH J IN SLST!& DO !&DELMAC CDR J; !&ATTLBL EXITT!&; !&ATTACH '(!*EXIT (!*FRAMESIZE)); !&REMCODE(T); !&FIXLABS(); !&FIXCHAINS(); !&FIXLINKS(); !&REMCODE(NIL); !&FIXFRM(NIL,NIL,NARG!&); !&PEEPHOLEOPT(); !&REMCODE(NIL); CODELIST!& := REVERSIP CODELIST!&; >>; SYMBOLIC PROCEDURE !&INSERTMAC(PLACE,MAC); RPLACW(PLACE,MAC . (CAR PLACE . CDR PLACE)); SYMBOLIC PROCEDURE !&DELETEMAC(PLACE); RPLACW(PLACE,CDR PLACE); SYMBOLIC PROCEDURE !&REMCODE(KEEPTOP); BEGIN SCALAR UNUSEDLBLS; UNUSEDLBLS := !&UNUSEDLBLS(KEEPTOP); !&REMUNUSEDMAC(UNUSEDLBLS); WHILE (UNUSEDLBLS := !&UNUSEDLBLS(KEEPTOP)) DO !&REMUNUSEDMAC(UNUSEDLBLS); END; SYMBOLIC PROCEDURE !&UNUSEDLBLS(KEEPTOP); BEGIN SCALAR USED,UNUSED; USED := NIL; UNUSED := LBLIST!&; IF KEEPTOP THEN <<USED := !&LABCLASS(TOPLAB!&) . USED; UNUSED := !&DELCLASS(TOPLAB!&,UNUSED)>>; FOR EACH MAC IN CODELIST!& DO IF CAR MAC NEQ '!*LBL THEN FOR EACH FLD IN CDR MAC DO IF EQCAR(FLD,'LABEL) AND !&CLASSMEMBER(FLD,UNUSED) THEN <<USED := !&LABCLASS(FLD) . USED; UNUSED := !&DELCLASS(FLD,UNUSED)>>; LBLIST!& := USED; RETURN UNUSED; END; SYMBOLIC PROCEDURE !&CLASSMEMBER(LAB,CLASSES); IF NULL CLASSES THEN NIL ELSE LAB MEMBER CAR CLASSES OR !&CLASSMEMBER(LAB,CDR CLASSES); SYMBOLIC PROCEDURE !&REMUNUSEDMAC(UNUSEDLABS); BEGIN SCALAR P,Q,R; CODELIST!& := P := REVERSIP CODELIST!&; WHILE CDR P DO <<Q := CDR P; IF CAAR Q = '!*NOOP OR !&TRANSFERP P AND CAAR Q NEQ '!*LBL OR CAAR Q = '!*LBL AND !&CLASSMEMBER(CADAR Q,UNUSEDLABS) THEN RPLACD(P,CDR Q) ELSE P := CDR P >>; CODELIST!& := REVERSIP CODELIST!&; END; lisp procedure !&FixLinks(); % % replace LINK by LINKE where appropriate % if not !*NoLinkE and not FreeBound!& then begin scalar Switched; for each Inst on CodeList!& do begin scalar SaveRest; if ExitT!& and first first Inst = '!*JUMP and second first Inst = ExitT!& or first first Inst = '!*EXIT then << if first second Inst = '!*LBL then << if first third Inst = '!*LINK then << Inst := cdr Inst; SaveRest := T >> >>; if first second Inst = '!*LINK then << if second second Inst eq NAME!& and !*R2I then Rplaca(rest Inst, list('!*JUMP, TopLab!&)) else Rplaca(rest Inst, '!*LINKE . '(!*FRAMESIZE) . rest second Inst); if not SaveRest then !&DeleteMac Inst >> >>; end; end; SYMBOLIC PROCEDURE !&PEEPHOLEOPT; %'peep-hole' optimization for various cases; BEGIN SCALAR X,Z; Z := CODELIST!&; WHILE Z DO IF CAAR Z = '!*NOOP THEN !&DELETEMAC Z ELSE IF NOT (X := GET(CAAR Z,'OPTFN)) OR NOT APPLY(X,LIST Z) THEN Z := CDR Z END; COMMENT Peep-hole optimization tables; SYMBOLIC PROCEDURE !&STOPT U; IF CAADR U = '!*ALLOC AND LLNGTH!& = 1 AND CDDAR U = '((FRAME 1)) THEN <<RPLACW(U,LIST('!*PUSH,CADAR U) . CDDR U)>> ELSE IF CAADR U = '!*MOVE AND CAADDR U = '!*ALLOC AND LLNGTH!& = 2 AND CDDAR U = '((FRAME 2)) AND CDDADR U = '((FRAME 1)) THEN <<RPLACW(U,LIST('!*PUSH,CADADR U) . LIST('!*PUSH,CADAR U) . CDDDR U)>>; SYMBOLIC PROCEDURE !&LBLOPT U; BEGIN SCALAR Z; IF CADR U = '!*LBL THEN <<!&DEFEQLBL(CADR U,CADR CDR U); RPLACD(U,CDDR U); RETURN T>>; IF CDADR U AND EQCAR(CADADR U,'LABEL) AND !&LBLEQ(CADAR U,CADADR U) THEN RETURN RPLACW(CDR U,CDDR U) ELSE IF CAADR U = '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP)) AND !&LBLEQ(CADAR U,CADR CADDR U) THEN RETURN <<Z := Z . (CADADR U . CDDR CADDR U); RPLACD(U,(Z . CDDDR U)); T>> ELSE RETURN NIL END; SYMBOLIC PROCEDURE !&JUMPOPT U; IF CADAR U = EXITT!& AND LLNGTH!& = 0 THEN RPLACA(U,'(!*EXIT (!*FRAMESIZE))); SYMBOLIC PROCEDURE !&FIXCHAINS(); BEGIN SCALAR LAB; FOR EACH LABCODE ON CODELIST!& DO IF CAAR LABCODE = '!*LBL % OR CAAR LABCODE = '!*JUMP % croaks on this one THEN <<LAB := CADAR LABCODE; FOR EACH JUMPCODE ON CDR LABCODE DO IF CAAR JUMPCODE = '!*JUMP AND CADAR JUMPCODE = LAB THEN !&MOVEJUMP(LABCODE,JUMPCODE)>> END; SYMBOLIC PROCEDURE !&MOVEJUMP(LABCODE,JUMPCODE); IF CADR LABCODE = CADR JUMPCODE THEN BEGIN SCALAR LAB; REPEAT <<IF CADR LABCODE = CADR JUMPCODE THEN <<JUMPCODE := CDR JUMPCODE; LABCODE := CDR LABCODE>>; WHILE CAADR LABCODE = '!*LBL DO LABCODE := CDR LABCODE; WHILE CAADR JUMPCODE = '!*LBL DO JUMPCODE := CDR JUMPCODE;>> UNTIL NOT(CADR JUMPCODE = CADR LABCODE); IF CAAR LABCODE = '!*LBL THEN RPLACD(JUMPCODE,LIST('!*JUMP,CADR CAR LABCODE) . CDR JUMPCODE) ELSE <<LAB := !&GENLBL(); RPLACD(JUMPCODE,LIST('!*JUMP,LAB) . CDR JUMPCODE); RPLACD(LABCODE,LIST('!*LBL,LAB) . CDR LABCODE)>>; END; SYMBOLIC PROCEDURE !&FIXFRM(OLDSTOMAP,OLDCODE,HIGHREG); % Should change FIXFRM to do sliding squeeze, not reorder; BEGIN SCALAR LST,GAZINTA,N,NF,TOP,FRAMESUSED,R,USED,FR,P,HMAP; HOLEMAP!& := NIL; % No stores were generated - frame size = 0 N := 1; GAZINTA := 1; % Now, loop through every allocated slot in the frame FRAMESUSED := !&GETFRAMES(CODELIST!&,OLDCODE,NIL); WHILE N <= LLNGTH!& DO <<USED := NIL; FR := !&MKFRAME N; FOR EACH VAR IN OLDSTOMAP DO IF CADR VAR = FR THEN USED := T; IF FR MEMBER FRAMESUSED THEN USED := T; % Find out if a frame location was used. N and GAZINTA used for squeeze % HOLEMAP!& is an association list between old and new frame locations. IF USED THEN <<HOLEMAP!& := LIST(FR,!&MKFRAME GAZINTA) . HOLEMAP!&; GAZINTA := GAZINTA + 1 >>; N := N + 1>>; LLNGTH!& := GAZINTA - 1; %now see if we can map stack to registers; TOP := !&HIGHEST(CODELIST!&,OLDCODE,HIGHREG,NIL); IF NOT(TOP = 'ALL OR FREEBOUND!& AND NOT !*USEREGFLUID) THEN <<HMAP := NIL; NF := 0; FOR EACH HOLE IN HOLEMAP!& DO IF TOP < LASTACTUALREG!& THEN << TOP := TOP + 1; LLNGTH!& := LLNGTH!& - 1; R := !&MKREG TOP; REGS!& := DELASC(R,REGS!&); HMAP := LIST(CAR HOLE,R) . HMAP>> ELSE << NF := NF + 1; HMAP := LIST(CAR HOLE, !&MKFRAME NF) . HMAP >>; IF NF NEQ 0 THEN LLNGTH!& := NF; HOLEMAP!& := HMAP; >> ELSE IF N = GAZINTA THEN RETURN NIL; P := CODELIST!&; WHILE NOT (P EQ OLDCODE) DO <<RPLACA(P,!&MACROSUBST(CAR P,HOLEMAP!&)); P := CDR P>>; END; SYMBOLIC PROCEDURE !&GETFRAMES(CODE,OLDCODE,RES); IF CODE EQ OLDCODE THEN RES ELSE !&GETFRAMES(CDR CODE,OLDCODE,!&GETFRAMES1(CDAR CODE,RES)); SYMBOLIC PROCEDURE !&GETFRAMES1(MACARGS,RES); IF NULL MACARGS THEN RES ELSE !&GETFRAMES1(CDR MACARGS, !&GETFRAMES2(CAR MACARGS,RES)); SYMBOLIC PROCEDURE !&GETFRAMES2(MACARG,RES); IF ATOM MACARG OR !&VARP MACARG OR !&CONSTP MACARG OR !®P MACARG THEN RES ELSE IF EQCAR(MACARG,'FRAME) THEN IF MACARG MEMBER RES THEN RES ELSE MACARG . RES ELSE !&GETFRAMES1(CDR MACARG,RES); SYMBOLIC PROCEDURE !&HIGHEST(START,STOP,HIGHREG,EXITFLAG); % Find the highest register used. 'ALL is returned if all are used. IF START EQ STOP THEN HIGHREG ELSE BEGIN SCALAR FN,MAC; MAC := CAR START; RETURN IF CAR MAC = '!*LINK OR CAR MAC = '!*LINKE AND EXITFLAG THEN <<FN := CADR MAC; IF FN = NAME!& THEN IF EXITFLAG THEN !&HIGHEST(CDR START,STOP,HIGHREG,EXITFLAG) ELSE 'ALL ELSE IF (DEST!& := GET(FN,'DESTROYS)) AND !*USINGDESTROY THEN <<FOR EACH R IN DEST!& DO HIGHREG := MAX(HIGHREG,CADR R); !&HIGHEST(CDR START,STOP,HIGHREG,EXITFLAG)>> ELSE 'ALL>> ELSE IF CAR MAC = '!*LINKF OR CAR MAC = '!*LINKEF AND EXITFLAG THEN 'ALL ELSE !&HIGHEST(CDR START,STOP,!&HIGHEST1(HIGHREG,CDR MAC),EXITFLAG); END; SYMBOLIC PROCEDURE !&HIGHEST1(H,ARGS); BEGIN FOR EACH A IN ARGS DO H := MAX(H,!&HIGHEST2(H,A)); RETURN H; END; SYMBOLIC PROCEDURE !&HIGHEST2(H,ARG); IF ATOM ARG THEN H ELSE IF NOT ATOM CAR ARG THEN !&HIGHEST1(H,ARG) ELSE IF !&CONSTP ARG THEN H ELSE IF CAR ARG = 'REG AND NUMBERP CADR ARG THEN MAX(H,CADR ARG) ELSE !&HIGHEST1(H,CDR ARG); SYMBOLIC PROCEDURE !&REFORMMACROS; BEGIN SCALAR FINALTRANSFORM; FINALTRANSFORM := LIST(LIST('(!*FRAMESIZE),LLNGTH!&)); FOR EACH MAC ON CODELIST!& DO RPLACA(MAC,!&MACROSUBST(CAR MAC,FINALTRANSFORM)); END; SYMBOLIC PROCEDURE !&FIXLABS(); BEGIN SCALAR TRANSFORM,U; TRANSFORM := NIL; FOR EACH LAB IN LBLIST!& DO FOR EACH EQLAB IN CDR LAB DO TRANSFORM := LIST(EQLAB,CAR LAB) . TRANSFORM; FOR EACH MAC ON CODELIST!& DO RPLACA(MAC,!&MACROSUBST(CAR MAC,TRANSFORM)); IF U := ASSOC(EXITT!&,TRANSFORM) THEN EXITT!& := CADR U; IF U := ASSOC(TOPLAB!&,TRANSFORM) THEN TOPLAB!& := CADR U; LBLIST!& := FOR EACH LAB IN LBLIST!& COLLECT LIST CAR LAB; END; SYMBOLIC PROCEDURE !&MACROSUBST(MAC,ALIST); CAR MAC . !&MACROSUBST1(CDR MAC,ALIST); SYMBOLIC PROCEDURE !&MACROSUBST1(ARGS,ALIST); FOR EACH ARG IN ARGS COLLECT !&MACROSUBST2(ARG,ALIST); SYMBOLIC PROCEDURE !&MACROSUBST2(ARG,ALIST); BEGIN SCALAR U; U:=ASSOC(ARG,ALIST); RETURN IF U THEN CADR U ELSE IF ATOM ARG OR FLAGP(CAR ARG,'TERMINAL) THEN ARG ELSE (CAR ARG . !&MACROSUBST1(CDR ARG,ALIST)); END; SYMBOLIC PROCEDURE !&REMTAGS(); FOR EACH MAC IN CODELIST!& DO !&REMTAGS1 MAC; SYMBOLIC PROCEDURE !&REMTAGS1 MAC; << IF CAR MAC = '!*JUMPON THEN RPLACD(CDDDR MAC, LIST CDDDDR MAC); FOR EACH MACFIELD IN CDR MAC DO !&REMTAGS2 MACFIELD >>; SYMBOLIC PROCEDURE !&REMTAGS2 U; IF EQCAR(U, 'WCONST) THEN !&REMTAGS3 CADR U; SYMBOLIC PROCEDURE !&REMTAGS3 U; BEGIN SCALAR DOFN; IF ATOM U THEN RETURN NIL; IF DOFN := GET(CAR U, 'DOFN) THEN RPLACA(U, DOFN); !&REMTAGS4 CDR U; END; SYMBOLIC PROCEDURE !&REMTAGS4 U; FOR EACH X IN U DO !&REMTAGS3 X; % Entry points used in setting up the system SYMBOLIC PROCEDURE !&ONEREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1))); SYMBOLIC PROCEDURE !&TWOREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1) (REG 2))); SYMBOLIC PROCEDURE !&THREEREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1) (REG 2) (REG 3))); END; |
Added psl-1983/3-1/comp/data-machine.red version [036a7afc12].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DATA-MACHINE.RED - Macros for fast access to data structures % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP>DATA-MACHINE.RED.13, 30-Mar-83 11:03:57, Edit by KENDZIERSKI % Included the text from data-machine.build at the beginning of this file. % The file names w/extensions were getting too large for the VAX to deal with. % <PERDUE.PSL>DATA-MACHINE.RED.3, 28-Feb-83 12:28:57, Edit by PERDUE % Added nasty comments and proposed changes % <PSL.COMP>DATA-MACHINE.RED.10, 10-Jan-83 16:31:31, Edit by PERDUE % Added PutEvecLen for EVectors; this had been omitted % Edit by GRISS, 3Nov: Added missing EVEC operations % Primitives handled by the compiler are BYTE, PUTBYTE, GETMEM, PUTMEM, % MKITEM, FIELD, SIGNEDFIELD, PUTFIELD, HALFWORD, PUYTHALFWORD CompileTime << load if!-system, syslisp; % Assume still there, else load source off UserMode; >>; in "wdeclare.red"$ CompileTime if_system(PDP10, << in "P20C:DEC20-DATA-MACHINE.RED"$ >>)$ CompileTime if_system(VAX, << in "vax/vax-data-machine.red"$ >>)$ CompileTime if_system(HP9836, << in "phpc:hp-data-machine.red"$ >>)$ on Syslisp; off R2I; % These definitions are for interpretive testing of Syslisp code. % They may be dangerous in some cases. CommentOutCode << syslsp procedure Byte(WAddr, ByteOffset); Byte(WAddr, ByteOffset); syslsp procedure PutByte(WAddr, ByteOffset, Val); PutByte(WAddr, ByteOffset, Val); syslsp procedure Halfword(WAddr, HalfwordOffset); Halfword(WAddr, HalfwordOffset); syslsp procedure PutHalfword(WAddr, HalfwordOffset, Val); PutHalfword(WAddr, HalfwordOffset, Val); syslsp procedure GetMem Addr; GetMem Addr; syslsp procedure PutMem(Addr, Val); PutMem(Addr, Val); syslsp procedure MkItem(TagPart, InfPart); MkItem(TagPart, InfPart); CommentOutCode << % can't do FIELD w/ non constants syslsp procedure Field(Cell, StartingBit, BitLength); Field(Cell, StartingBit, BitLength); syslsp procedure SignedField(Cell, StartingBit, BitLength); SignedField(Cell, StartingBit, BitLength); syslsp procedure PutField(Cell, StartingBit, BitLength, Val); PutField(Cell, StartingBit, BitLength, Val); >>; syslsp procedure WPlus2(R1, R2); WPlus2(R1, R2); syslsp procedure WDifference(R1, R2); WDifference(R1, R2); syslsp procedure WTimes2(R1, R2); WTimes2(R1, R2); syslsp procedure WQuotient(R1, R2); WQuotient(R1, R2); syslsp procedure WRemainder(R1, R2); WRemainder(R1, R2); syslsp procedure WMinus R1; WMinus R1; syslsp procedure WShift(R1, R2); WShift(R1, R2); syslsp procedure WAnd(R1, R2); WAnd(R1, R2); syslsp procedure WOr(R1, R2); WOr(R1, R2); syslsp procedure WXor(R1, R2); WXor(R1, R2); syslsp procedure WNot R1; WNot R1; syslsp procedure WLessP(R1, R2); WLessP(R1, R2); syslsp procedure WGreaterP(R1, R2); WGreaterP(R1, R2); syslsp procedure WLEQ(R1, R2); WLEQ(R1, R2); syslsp procedure WGEQ(R1, R2); WGEQ(R1, R2); >>; on R2I; off Syslisp; % SysLisp array accessing primitives syslsp macro procedure WGetV U; list('GetMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem)))); syslsp macro procedure WPutV U; list('PutMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem))), cadddr U); % tags CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure HighTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst)) - 1, -1); >>; % JumpInType and friends depend on the ordering and contiguity of % the numeric type tags. Fast arithmetic depends on PosInt = 0, % NegInt = -1. Garbage collectors depend on pointer tags being % between PosInt and Code, non-inclusive. /csp LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair, Evect); put('Code, 'WConst, 15); HighTags(NegInt, ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); % Item constructor macros lisp procedure MakeItemConstructor(TagPart, InfPart); list('MkItem, TagPart, InfPart); syslsp macro procedure MkBTR U; MakeItemConstructor('(wconst BtrTag), cadr U); syslsp macro procedure MkID U; MakeItemConstructor('(wconst ID), cadr U); syslsp macro procedure MkFIXN U; MakeItemConstructor('(wconst FIXN), cadr U); syslsp macro procedure MkFLTN U; MakeItemConstructor('(wconst FLTN), cadr U); syslsp macro procedure MkBIGN U; MakeItemConstructor('(wconst BIGN), cadr U); syslsp macro procedure MkPAIR U; MakeItemConstructor('(wconst PAIR), cadr U); syslsp macro procedure MkVEC U; MakeItemConstructor('(wconst VECT), cadr U); syslsp macro procedure MkEVECT U; MakeItemConstructor('(wconst EVECT), cadr U); syslsp macro procedure MkWRDS U; MakeItemConstructor('(wconst WRDS), cadr U); syslsp macro procedure MkSTR U; MakeItemConstructor('(wconst STR), cadr U); syslsp macro procedure MkBYTES U; MakeItemConstructor('(wconst BYTES), cadr U); syslsp macro procedure MkHalfWords U; MakeItemConstructor('(wconst HalfWords), cadr U); syslsp macro procedure MkCODE U; MakeItemConstructor('(wconst CODE), cadr U); % Access to tag (type indicator) of Lisp item in ordinary code syslsp macro procedure Tag U; list('Field, cadr U, '(wconst TagStartingBit), '(wconst TagBitLength)); % Access to info field of item (pointer or immediate operand) syslsp macro procedure Inf U; list('Field, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength)); syslsp macro procedure PutInf U; list('PutField, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength), caddr U); for each X in '(IDInf StrInf VecInf EvecInf PairInf WrdInf HalfWordInf CodeInf FixInf FltInf BigInf) do PutD(X, 'Macro, cdr getd 'Inf); for each X in '(PutIDInf PutStrInf PutVecInf PutPairInf PutWrdInf PutHalfWordInf PutEvecInf PutFixInf PutFltInf PutBigInf) do PutD(X, 'Macro, cdr getd 'PutInf); % IntInf is no longer needed, will be a macro no-op % for the time being RemProp('IntInf, 'OpenFn); macro procedure IntInf U; cadr U; % Similarly for MkINT macro procedure MkINT U; cadr U; % # of words in a pair syslsp macro procedure PairPack U; 2; % length (in characters, words, etc.) of a string, vector, or whatever, % stored in the first word pointed to syslsp macro procedure GetLen U; list('SignedField, list('GetMem, cadr U), '(WConst InfStartingBit), '(WConst InfBitLength)); syslsp macro procedure StrBase U; % point to chars of string list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); % chars string length --> words string length % Don't add 1 in this! (Put change in at some reasonable time.) % Actually need space for extra null, but magic constant to add % to determine number of words needed is CharsPerWord-1, so all % cancels out. /csp 2-28-83 syslsp macro procedure StrPack U; list('WQuotient, list('WPlus2, cadr U, list('WPlus2, '(WConst CharactersPerWord), 1)), '(WConst CharactersPerWord)); % access to bytes of string; skip first word syslsp macro procedure StrByt U; list('Byte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutStrByt U; list('PutByte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % access to halfword entries; skip first word syslsp macro procedure HalfWordItm U; list('HalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutHalfWordItm U; list('PutHalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % halfword length --> words length % Should add 1 before shift! /csp 2-28-83 syslsp macro procedure HalfWordPack U; list('WPlus2, list('WShift, cadr U, -1), 1); % length (in Item size quantities) of Lisp vectors % size of Lisp vector in words % Adding 1 not needed for GtVect! /csp 2-28-83 syslsp macro procedure VectPack U; list('WPlus2, cadr U, 1); % size of Lisp Evector in words % See comment above! /csp syslsp macro procedure EVectPack U; list('WPlus2, cadr U, 1); % access to elements of Lisp vector syslsp macro procedure VecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % access to elements of Lisp Evector syslsp macro procedure EVecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutEVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % Wrd is like Vect, but not traced by the garbage collector % See comment for VectPack, above! /csp 2-28-83 syslsp macro procedure WrdPack U; list('WPlus2, cadr U, 1); for each X in '(StrLen ByteLen VecLen EVecLen WrdLen HalfWordLen) do PutD(X, 'Macro, cdr getd 'GetLen); PutD('WrdItm, 'Macro, cdr GetD 'VecItm); PutD('PutWrdItm, 'Macro, cdr GetD 'PutVecItm); % So what about FixPack and FloatPack, turkeys? /csp 2-28-83 syslsp macro procedure FixVal U; list('WGetV, cadr U, 1); syslsp macro procedure PutFixVal U; list('WPutV, cadr U, 1, caddr U); syslsp macro procedure FloatBase U; list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); syslsp macro procedure FloatHighOrder U; list('WGetV, cadr U, 1); syslsp macro procedure FloatLowOrder U; list('WGetV, cadr U, 2); % New addition: A code pointer can have the number of arguments it expects % stored in the word just before the entry syslsp macro procedure !%code!-number!-of!-arguments U; list('WGetV, cadr U, -1); % The four basic cells for each symbol: Val, Nam, Fnc, Prp, corresponding to % variable value, symbol name (as string), function cell (jump to compiled % code or lambda linker) and property list (pairs for PUT, GET, atoms for FLAG, % FLAGP). These are currently 4 separate arrays, but this representation may % be changed to a contiguous 4 element record for each symbol or something else % and therefore should not be accessed as arrays. syslsp macro procedure SymVal U; list('WGetV, '(WConst SymVal), cadr U); syslsp macro procedure PutSymVal U; list('WPutV, '(WConst SymVal), cadr U, caddr U); syslsp macro procedure LispVar U; % Access value cell by name list('(WConst SymVal), list('IDLoc, cadr U)); syslsp macro procedure PutLispVar U; list('PutSymVal, list('IDLoc, cadr U), caddr U); syslsp macro procedure SymNam U; list('WGetV, '(WConst SymNam), cadr U); syslsp macro procedure PutSymNam U; list('WPutV, '(WConst SymNam), cadr U, caddr U); % Retrieve the address stored in the function cell % SymFnc and PutSymFnc are not defined portably syslsp macro procedure SymPrp U; list('WGetV, '(WConst SymPrp), cadr U); syslsp macro procedure PutSymPrp U; list('WPutV, '(WConst SymPrp), cadr U, caddr U); % Binding stack primitives syslsp macro procedure BndStkID U; list('WGetV, cadr U, -1); syslsp macro procedure PutBndStkID U; list('WPutV, cadr U, -1, caddr U); syslsp macro procedure BndStkVal U; list('GetMem, cadr U); syslsp macro procedure PutBndStkVal U; list('PutMem, cadr U, caddr U); syslsp macro procedure AdjustBndStkPtr U; list('WPlus2, cadr U, list('WTimes2, caddr U, list('WTimes2, '(WConst AddressingUnitsPerItem), 2))); % ObArray is a linearly allocated hash table containing ID numbers of entries % maintained as a circular buffer. It is referenced only via these macros % because we may decide to change to some other representation. syslsp smacro procedure ObArray I; HalfWord(HashTable, I); syslsp smacro procedure PutObArray(I, X); HalfWord(HashTable, I) := X; put('ObArray, 'Assign!-Op, 'PutObArray); syslsp smacro procedure OccupiedSlot U; ObArray U > 0; DefList('((GetMem PutMem) (Field PutField) (Byte PutByte) (HalfWord PutHalfWord) (Tag PutTag) (Inf PutInf) (IDInf PutIDInf) (StrInf PutStrInf) (VecInf PutVecInf) (EVecInf PutEVecInf) (WrdInf PutWrdInf) (PairInf PutPairInf) (FixInf PutFixInf) (FixVal PutFixVal) (FltInf PutFltInf) (BigInf PutBigInf) (StrLen PutStrLen) (StrByt PutStrByt) (VecLen PutVecLen) (EVecLen PutEvecLen) (VecItm PutVecItm) (EVecItm PutEVecItm) (WrdLen PutWrdLen) (WrdItm PutWrdItm) (SymVal PutSymVal) (LispVar PutLispVar) (SymNam PutSymNam) (SymFnc PutSymFnc) (SymPrp PutSymPrp) (BndStkID PutBndStkID) (BndStkVal PutBndStkVal)), 'Assign!-Op); % This is redefined for the HP 9836 to cure the high-order FF problem macro procedure !%chipmunk!-kludge x; cadr x; END; |
Added psl-1983/3-1/comp/faslout.build version [babaa196cb].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | CompileTime load If!-system, Syslisp; CompileTime if_system(PDP10, << load Monsym; in "p20:system-faslout.red"$ >>)$ CompileTime if_system(Unix, << in "../kernel/vax/system-faslout.red"$ >>)$ CompileTime if_system(HP9836, << in "php:system-faslout.red"$ >>)$ in "faslout.red"$ |
Added psl-1983/3-1/comp/faslout.red version [f5720fbad4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FASLOUT.RED - Top level of fasl file writer % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 February 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP>FASLOUT.RED.8, 19-Apr-83 07:54:22, Edit by KESSLER % Flat Faslabort as Ignore, so you need not type compiletime faslabort. % <PSL.COMP>FASLOUT.RED.7, 28-Mar-83 07:49:53, Edit by KESSLER % Added FaslAbort Command to Terminate Faslout Gracefully. % <PSL.COMP>FASLOUT.RED.6, 16-Dec-82 12:49:59, Edit by KESSLER % Take out Semic!* as a fluid. Not used by anyone that I can see % and is already a global in RLISP. % <PSL.COMP>FASLOUT.RED.35, 10-Jun-82 10:41:18, Edit by GRISS % Made CompileUncompiledExpressions regular func % <PSL.COMP>FASLOUT.RED.12, 30-Apr-82 14:45:59, Edit by BENSON % Removed EVAL and IGNORE processing % <PSL.COMP>FASLOUT.RED.8, 29-Apr-82 06:23:18, Edit by GRISS % moved DEFINEROP call to RLISP-PARSER CompileTime << flag('(CodeFileHeader CodeFileTrailer AllocateFaslSpaces), 'InternalFunction); load Fast!-Vector; >>; fluid '(!*WritingFaslFile !*Lower !*quiet_faslout DfPrint!* UncompiledExpressions!* ModuleName!* CodeOut!* InitOffset!* CurrentOffset!* FaslBlockEnd!* MaxFaslOffset!* BitTableOffset!* FaslFilenameFormat!*); FaslFilenameFormat!* := "%w.b"; lisp procedure DfPrintFasl U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn, !*WritingFaslFile; !*WritingFaslFile := T; if atom U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; IF FLAGP(TY,'COMPILE) THEN << PUT(NAM,'CFNTYPE,LIST TY); U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U) . !&COMPROC(U, NAM); LAP U >> ELSE % should never happen SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM, MKQUOTE TY, MKQUOTE U); if IGreaterP(Posn(), 0) then WriteChar char BLANK; Prin1 NAM; RETURN NIL; DB1: % Simple S-EXPRESSION, maybe EVAL it; IF NOT PAIRP U THEN RETURN NIL; if (Fn := get(car U, 'FaslPreEval)) then return Apply(Fn, list U) else if (Fn := GetD car U) and car Fn = 'MACRO then return DFPRINTFasl Apply(cdr Fn, list U); SaveUncompiledExpression U; RETURN NIL; DB2: NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; FLAG ('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL); lisp procedure FaslPreEvalLoadTime U; DFPrintFasl cadr U; % remove LOADTIME put('LoadTime, 'FaslPreEval, 'FaslPreEvalLoadTime); put('BothTimes, 'FaslPreEval, 'FaslPreEvalLoadTime); put('StartupTime, 'FaslPreEval, 'FaslPreEvalLoadTime); % used in kernel % A few things to save space when loading put('Flag, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Flag1, MkQuote X, third U)) else SaveUncompiledExpression U); put('fluid, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Fluid1, MkQuote X)) else SaveUncompiledExpression U); put('global, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Global1, MkQuote X)) else SaveUncompiledExpression U); put('DefList, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('put, MkQuote first X, third U, MkQuote second X)) else SaveUncompiledExpression U); put('ProgN, 'FaslPreEval, function lambda U; for each X in cdr U do DFPrintFasl X); put('LAP, 'FaslPreEval, function lambda U; if EqCar(cadr U, 'QUOTE) then Lap cadr cadr U else SaveUncompiledExpression U); UncompiledExpressions!* := NIL . NIL; lisp procedure SaveUncompiledExpression U; << if atom U then NIL else TConc(UncompiledExpressions!*, U); NIL >>; lisp procedure FaslOut FIL; << ModuleName!* := FIL; if not !*quiet_faslout then << if not FUnBoundP 'Begin1 then << Prin2T "FASLOUT: IN files; or type in expressions"; Prin2T "When all done execute FASLEND;" >> else << Prin2T "FASLOUT: (DSKIN files) or type in expressions"; Prin2T "When all done execute (FASLEND)" >> >>; CodeOut!* := BinaryOpenWrite BldMsg(FaslFilenameFormat!*, ModuleName!*); CodeFileHeader(); DFPRINT!* := 'DFPRINTFasl; !*WritingFaslFile := T; !*DEFN := T >>; lisp procedure FaslEnd; if not !*WritingFaslFile then StdError "FASLEND not within FASLOUT" else << CompileUncompiledExpressions(); UncompiledExpressions!* := NIL . NIL; CodeFileTrailer(); BinaryClose CodeOut!*; DFPRINT!* := NIL; !*WritingFaslFile := NIL; !*DEFN := NIL >>; FLAG('(FaslEND), 'IGNORE); % FaslAbort. Abort the Fasl process cleanly. The code file will be closed % and the various flags will be reset. lisp procedure FaslAbort; if not !*WritingFaslFile then StdError "FASLAbort not within FASLOUT" else << UncompiledExpressions!* := NIL . NIL; BinaryClose CodeOut!*; DFPRINT!* := NIL; !*WritingFaslFile := NIL; !*DEFN := NIL >>; Flag('(FaslAbort), 'Ignore); lisp procedure ComFile Filename; begin scalar !*Defn, !*WritingFaslFile, TestFile, FileBase, FileExt, I, N, DotFound, TestExts, !*quiet_faslout; if IDP Filename then (lambda (!*Lower); Filename := BldMsg("%w", Filename))(T); if not StringP Filename then return NonStringError(Filename, 'ComFile); N := ISizeS Filename; I := 0; while not DotFound and ILEQ(I, N) do << if IGetS(Filename, I) = char '!. then DotFound := T; I := IAdd1 I >>; if DotFound then << if not FileP Filename then return ContError(99, "Couldn't find file", ComFile Filename) else << FileBase := SubSeq(Filename, 0, I); FileExt := SubSeq(Filename, ISub1 I, IAdd1 N) >> >> else << TestExts := '(".build" ".sl" ".red"); while not null TestExts and not FileP(TestFile := Concat(Filename, first TestExts)) do TestExts := rest TestExts; if null TestExts then return ContError(99, "Couldn't find file", ComFile Filename) else << FileExt := first TestExts; FileBase := Filename; Filename := TestFile >> >>; ErrorPrintF("*** Compiling %w", Filename); !*quiet_faslout := T; Faslout FileBase; if FileExt member '(".build" ".red") then EvIn list Filename else DskIn Filename; Faslend; return T; end; lisp procedure CompileUncompiledExpressions(); << ErrorPrintF("*** Init code length is %w", length car UncompiledExpressions!*); DFPRINTFasl list('DE, '!*!*Fasl!*!*InitCode!*!*, '(), 'PROGN . car UncompiledExpressions!*) >>; lisp procedure CodeFileHeader(); << BinaryWrite(CodeOut!*, const FASL_MAGIC_NUMBER); AllocateFaslSpaces() >>; fluid '(CodeBase!* BitTableBase!* OrderedIDList!* NextIDNumber!*); lisp procedure FindIDNumber U; begin scalar I; return if ILEQ(I := IDInf U, 128) then I else if (I := get(U, 'IDNumber)) then I else << put(U, 'IDNumber, I := NextIDNumber!*); OrderedIDList!* := TConc(OrderedIDList!*, U); NextIDNumber!* := IAdd1 NextIDNumber!*; I >>; end; lisp procedure CodeFileTrailer(); begin scalar S; SystemFaslFixup(); BinaryWrite(CodeOut!*, IDifference(ISub1 NextIDNumber!*, 2048)); % Number of local IDs for each X in car OrderedIDList!* do << RemProp(X, 'IDNumber); X := StrInf ID2String X; S := StrLen X; BinaryWriteBlock(CodeOut!*, X, IAdd1 StrPack S) >>; BinaryWrite(CodeOut!*, % S is size in words S := IQuotient(IPlus2(CurrentOffset!*, ISub1 const AddressingUnitsPerItem), const AddressingUnitsPerItem)); BinaryWrite(CodeOut!*, InitOffset!*); BinaryWriteBlock(CodeOut!*, CodeBase!*, S); BinaryWrite(CodeOut!*, S := IQuotient(IPlus2(BitTableOffset!*, ISub1 const BitTableEntriesPerWord), const BitTableEntriesPerWord)); BinaryWriteBlock(CodeOut!*, BitTableBase!*, S); DelWArray(BitTableBase!*, FaslBlockEnd!*); end; lisp procedure UpdateBitTable(NumberOfEntries, FirstEntry); if !*WritingFaslFile then << PutBitTable(BitTableBase!*, BitTableOffset!*, FirstEntry); BitTableOffset!* := IAdd1 BitTableOffset!*; for I := 2 step 1 until NumberOfEntries do << PutBitTable(BitTableBase!*, BitTableOffset!*, 0); BitTableOffset!* := IAdd1 BitTableOffset!* >>; if IGreaterP(BitTableOffset!*, MaxFaslOffset!*) then FatalError "BPS exhausted during FaslOut; output file too large" >>; lisp procedure AllocateFaslSpaces(); begin scalar B; B := GTWarray NIL; % how much is left? B := IDifference(B, IQuotient(B, 3)); FaslBlockEnd!* := GTWArray 0; % pointer to top of space BitTableBase!* := GTWarray B; % take 2/3 of whatever's left CurrentOffset!* := 0; BitTableOffset!* := 0; CodeBase!* := Loc WGetV(BitTableBase!*, % split the space between IQuotient(B, % bit table and code IQuotient(const BitTableEntriesPerWord, const AddressingUnitsPerItem))); MaxFaslOffset!* := IDifference(FaslBlockEnd!*, CodeBase!*); OrderedIDList!* := NIL . NIL; NextIDNumber!* := 2048; % local IDs start at 2048 end; END; |
Added psl-1983/3-1/comp/lap-to-asm.build version [7654a0381f].
> | 1 | in "lap-to-asm.red"$ |
Added psl-1983/3-1/comp/lap-to-asm.red version [f3ec03b882].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LAP-TO-ASM.RED - LAP to assembler translator % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 13 August 1981 % Copyright (c) 1981 University of Utah % % 01-Mar-83 Nancy Kendzierski % Changed EVIN to PathIn in ASMOUT to enable search paths to be % used when doing system builds connected to a directory other % than pxx:, where xx=machine (hp, 20, vax, etc.) % Only set InputSymFile!*, OutputSymFile!*, GlobalDataFileName!*, % and InitFileNameFormat!* if they aren't already initialized. % Changed SEMIC!* declaration from global to fluid. % <PSL.COMP>LAP-TO-ASM.RED.5, 30-Apr-82 14:47:52, Edit by BENSON % Removed EVAL and IGNORE processing Imports '(PathIn); fluid '(Semic!* !*Comp !*PLap DfPrint!* CharactersPerWord AddressingUnitsPerItem AddressingUnitsPerFunctionCell InputSymFile!* OutputSymFile!* CodeOut!* DataOut!* InitOut!*; CodeFileNameFormat!* DataFileNameFormat!* InitFileNameFormat!* ModuleName!* UncompiledExpressions!* NextIDNumber!* OrderedIDList!* NilNumber!* !*MainFound !*MAIN !*DeclareBeforeUse MainEntryPointName!* EntryPoints!* LocalLabels!* CodeExternals!* CodeExporteds!* DataExternals!* DataExporteds!* ExternalDeclarationFormat!* ExportedDeclarationFormat!* LabelFormat!* FullWordFormat!* DoubleFloatFormat!* ReserveDataBlockFormat!* ReserveZeroBlockFormat!* UndefinedFunctionCellInstructions!* DefinedFunctionCellFormat!* PrintExpressionForm!* PrintExpressionFormPointer!* CommentFormat!* NumericRegisterNames!* ExpressionCount!* ASMOpenParen!* ASMCloseParen!* ToBeCompiledExpressions!* GlobalDataFileName!* ); % Default values; set up if not already initialized. if null InputSymFile!* then InputSymFile!* := "psl.sym"; if null OutputSymFile!* then OutputSymFile!* := "psl.sym"; if null GlobalDataFileName!* then GlobalDataFileName!* := "global-data.red"; if null InitFileNameFormat!* then InitFileNameFormat!* := "%w.init"; lisp procedure DfPrintASM U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn; if atom U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; IF FLAGP(TY,'COMPILE) THEN << PUT(NAM,'CFNTYPE,LIST TY); U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U) . !&COMPROC(U, NAM); if !*PLAP then for each X in U do Print X; if TY neq 'EXPR then DfPrintASM list('put, MkQuote Nam, '(quote TYPE), MkQuote TY); ASMOUTLAP U >> ELSE % should never happen SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM, MKQUOTE TY, MKQUOTE U); RETURN NIL; DB1: % Simple S-EXPRESSION, maybe EVAL it; IF NOT PAIRP U THEN RETURN NIL; if (Fn := get(car U, 'ASMPreEval)) then return Apply(Fn, list U) else if (Fn := GetD car U) and car Fn = 'MACRO then return DFPRINTASM Apply(cdr Fn, list U); SaveUncompiledExpression U; RETURN NIL; DB2: NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; lisp procedure ASMPreEvalLoadTime U; DFPrintASM cadr U; % remove LOADTIME put('LoadTime, 'ASMPreEval, 'ASMPreEvalLoadTime); lisp procedure ASMPreEvalStartupTime U; SaveForCompilation cadr U; put('StartupTime, 'ASMPreEval, 'ASMPreEvalStartupTime); lisp procedure ASMPreEvalProgN U; for each X in cdr U do DFPrintASM X; put('ProgN, 'ASMPreEval, 'ASMPreEvalProgN); put('WDeclare, 'ASMPreEval, 'Eval); % do it now lisp procedure ASMPreEvalSetQ U; begin scalar X, Val; X := cadr U; Val := caddr U; return if ConstantP Val or Val = T then << FindIDNumber X; put(X, 'InitialValue, Val); NIL >> else if null Val then << FindIDNumber X; RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue); NIL >> else if EqCar(Val, 'QUOTE) then << FindIDNumber X; Val := cadr Val; if null Val then << RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue) >> else put(X, 'InitialValue, Val); NIL >> else if IDP Val and get(Val, 'InitialValue) or FlagP(Val, 'NilInitialValue) then << if (Val := get(Val, 'InitialValue)) then put(X, 'InitialValue, Val) else Flag(list X, 'NilInitialValue) >> else SaveUncompiledExpression U; % just check simple cases, else return end; put('SetQ, 'ASMPreEval, 'ASMPreEvalSetQ); lisp procedure ASMPreEvalPutD U; SaveUncompiledExpression CheckForEasySharedEntryPoints U; lisp procedure CheckForEasySharedEntryPoints U; % % looking for (PUTD (QUOTE name1) xxxx (CDR (GETD (QUOTE name2)))) % begin scalar NU, Nam, Exp; NU := cdr U; Nam := car NU; if car Nam = 'QUOTE then Nam := cadr Nam else return U; NU := cdr NU; Exp := cadr NU; if not (car Exp = 'CDR) then return U; Exp := cadr Exp; if not (car Exp = 'GETD) then return U; Exp := cadr Exp; if not (car Exp = 'QUOTE) then return U; Exp := cadr Exp; FindIDNumber Nam; put(Nam, 'EntryPoint, FindEntryPoint Exp); if not (car NU = '(QUOTE EXPR)) then return list('Put, '(Quote Type), car NU); return NIL; end; put('PutD, 'ASMPreEval, 'ASMPreEvalPutD); lisp procedure ASMPreEvalFluidAndGlobal U; << if EqCar(cadr U, 'QUOTE) then Flag(cadr cadr U, 'NilInitialValue); SaveUncompiledExpression U >>; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); CommentOutCode << fluid '(NewFluids!* NewGlobals!*); lisp procedure ASMPreEvalFluidAndGlobal U; begin scalar L; L := cadr U; return if car L = 'QUOTE then << L := cadr L; if car U = 'FLUID then NewFluids!* := UnionQ(NewFluids!*, L) % take union else NewGlobals!* := UnionQ(NewGlobals!*, L); Flag(L, 'NilInitialValue); NIL >> else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); >>; lisp procedure ASMPreEvalLAP U; if EqCar(cadr U, 'QUOTE) then ASMOutLap cadr cadr U else SaveUncompiledExpression U; put('LAP, 'ASMPreEval, 'ASMPreEvalLAP); CommentOutCode << lisp procedure InitialPut(Nam, Ind, Val); begin scalar L, P; FindIDNumber Nam; if (P := Atsoc(Ind, L := get(Nam, 'InitialPropertyList))) then Rplacd(P, Val) else put(Nam, 'InitialPropertyList, (Ind . Val) . L); end; lisp procedure InitialRemprop(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelAtQIP(Ind, L)); end; lisp procedure InitialFlag1(Nam, Ind); begin scalar L, P; FindIDNumber Nam; if not Ind memq (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, Ind . L); end; lisp procedure InitialRemFlag1(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelQIP(Ind, L)); end; lisp procedure ASMPreEvalPut U; begin scalar Nam, Ind, Val; Nam := second U; Ind := third U; Val := fourth U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) and (ConstantP Val or Val = T or EqCar(Val, 'QUOTE)) then InitialPut(second Nam, second Ind, if EqCar(Val, 'QUOTE) then second Val else Val) else SaveUncompiledExpression U; end; put('put, 'ASMPreEval, 'ASMPreEvalPut); lisp procedure ASMPreEvalRemProp U; begin scalar Nam, Ind; Nam := second U; Ind := third U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) then InitialRemProp(second Nam, second Ind) else SaveUncompiledExpression U; end; put('RemProp, 'ASMPreEval, 'ASMPreEvalRemProp); lisp procedure ASMPreEvalDefList U; begin scalar DList, Ind; DList := second U; Ind := third U; if EqCar(DList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << DList := second DList; Ind := second Ind; for each X in Dlist do InitialPut(first X, Ind, second X) >> else SaveUncompiledExpression U; end; put('DefList, 'ASMPreEval, 'ASMPreEvalDefList); lisp procedure ASMPreEvalFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('flag, 'ASMPreEval, 'ASMPreEvalFlag); lisp procedure ASMPreEvalRemFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialRemFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('RemFlag, 'ASMPreEval, 'ASMPreEvalRemFlag); lisp procedure ASMPreEvalGlobal U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'Global) else SaveUncompiledExpression U; end; put('Global, 'ASMPreEval, 'ASMPreEvalGlobal); lisp procedure ASMPreEvalFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'FLUID) else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluid); lisp procedure ASMPreEvalUnFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialRemProp(X, 'TYPE) else SaveUncompiledExpression U; end; put('UnFluid, 'ASMPreEval, 'ASMPreEvalUnFluid); >>; lisp procedure SaveUncompiledExpression U; if PairP U then begin scalar OldOut; OldOut := WRS InitOut!*; Print U; WRS OldOut; end; ToBeCompiledExpressions!* := NIL . NIL; lisp procedure SaveForCompilation U; if atom U or U member car ToBeCompiledExpressions!* then NIL else if car U = 'progn then for each X in cdr U do SaveForCompilation X else TConc(ToBeCompiledExpressions!*, U); SYMBOLIC PROCEDURE ASMOUT FIL; begin scalar OldOut; ModuleName!* := FIL; Prin2T "ASMOUT: IN files; or type in expressions"; Prin2T "When all done execute ASMEND;"; CodeOut!* := Open(BldMsg(CodeFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS CodeOut!*; LineLength 1000; WRS OldOut; CodeFileHeader(); DataOut!* := Open(BldMsg(DataFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS DataOut!*; LineLength 1000; WRS OldOut; DataFileHeader(); InitOut!* := Open(BldMsg(InitFileNameFormat!*, ModuleName!*), 'OUTPUT); ReadSYMFile(); DFPRINT!* := 'DFPRINTASM; RemD 'OldLap; PutD('OldLap, 'EXPR, cdr RemD 'Lap); PutD('Lap, 'EXPR, cdr GetD 'ASMOutLap); !*DEFN := T; SEMIC!* := '!$ ; % to turn echo off for IN if not ((ModuleName!* = "main") or !*Main) then PathIn GlobalDataFileName!* else !*Main := T; end; lisp procedure ASMEnd; << off SysLisp; if !*MainFound then << CompileUncompiledExpressions(); % WriteInitFile(); InitializeSymbolTable() >> else WriteSymFile(); CodeFileTrailer(); Close CodeOut!*; DataFileTrailer(); Close DataOut!*; Close InitOut!*; RemD 'Lap; PutD('Lap, 'EXPR, cdr GetD 'OldLap); DFPRINT!* := NIL; !*DEFN := NIL >>; FLAG('(ASMEND), 'IGNORE); DEFINEROP('ASMEND,NIL,ESTAT('ASMEND)); lisp procedure CompileUncompiledExpressions(); << CommentOutCode << AddFluidAndGlobalDecls(); >>; DFPRINTASM list('DE, 'INITCODE, '(), 'PROGN . car ToBeCompiledExpressions!*) >>; CommentOutCode << lisp procedure AddFluidAndGlobalDecls(); << SaveUncompiledExpression list('GLOBAL, MkQuote NewGlobals!*); SaveUncompiledExpression list('FLUID, MkQuote NewFluids!*) >>; >>; lisp procedure ReadSymFile(); LapIN InputSymFile!*; lisp procedure WriteSymFile(); begin scalar NewOut, OldOut; OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT)); print list('SaveForCompilation, MkQuote('progn . car ToBeCompiledExpressions!*)); SaveIDList(); SetqPrint 'NextIDNumber!*; SetqPrint 'StringGenSym!*; MapObl function PutPrintEntryAndSym; WRS OldOut; Close NewOut; end; CommentOutCode << lisp procedure WriteInitFile(); begin scalar OldOut, NewOut; NewOut := Open(InitFileName!*, 'OUTPUT); OldOut := WRS NewOut; for each X in car UncompiledExpressions!* do PrintInit X; Close NewOut; WRS OldOut; end; lisp procedure PrintInit X; if EqCar(X, 'progn) then for each Y in cdr X do PrintInit Y else Print X; >>; lisp procedure SaveIDList(); << Print list('setq, 'OrderedIDList!*, MkQuote car OrderedIDList!*); Print quote(OrderedIDList!* := OrderedIDList!* . LastPair OrderedIDList!*) >>; lisp procedure SetqPrint U; print list('SETQ, U, MkQuote Eval U); lisp procedure PutPrint(X, Y, Z); print list('PUT, MkQuote X, MkQuote Y, MkQuote Z); lisp procedure PutPrintEntryAndSym X; begin scalar Y; if (Y := get(X, 'EntryPoint)) then PutPrint(X, 'EntryPoint, Y); if (Y := get(X, 'IDNumber)) then PutPrint(X, 'IDNumber, Y); CommentOutCode << if (Y := get(X, 'InitialPropertyList)) then PutPrint(X, 'InitialPropertyList, Y); >>; if (Y := get(X, 'InitialValue)) then PutPrint(X, 'InitialValue, Y) else if FlagP(X, 'NilInitialValue) then print list('flag, MkQuote list X, '(quote NilInitialValue)); if get(X, 'SCOPE) = 'EXTERNAL then << PutPrint(X, 'SCOPE, 'EXTERNAL); PutPrint(X, 'ASMSymbol, get(X, 'ASMSymbol)); if get(X, 'WVar) then PutPrint(X, 'WVar, X) else if get(X, 'WArray) then PutPrint(X, 'WArray, X) else if get(X, 'WString) then PutPrint(X, 'WString, X) else if (Y := get(X, 'WConst)) then PutPrint(X, 'WConst, Y) >>; end; lisp procedure FindIDNumber U; begin scalar I; return if (I := ID2Int U) <= 128 then I else if (I := get(U, 'IDNumber)) then I else << put(U, 'IDNumber, I := NextIDNumber!*); OrderedIDList!* := TConc(OrderedIDList!*, U); NextIDNumber!* := NextIDNumber!* + 1; I >>; end; OrderedIDList!* := NIL . NIL; NextIDNumber!* := 129; lisp procedure InitializeSymbolTable(); begin scalar MaxSymbol; MaxSymbol := get('MaxSymbols, 'WConst); if MaxSymbol < NextIDNumber!* then << ErrorPrintF("*** MaxSymbols %r is too small; at least %r is needed", MaxSymbol, NextIDNumber!*); MaxSymbol := NextIDNumber!* + 100 >>; Flag('(NIL), 'NilInitialValue); put('T, 'InitialValue, 'T); put('!$EOF!$, 'InitialValue, Int2ID get('EOF, 'CharConst)); put('!$EOL!$, 'InitialValue, '! ); NilNumber!* := CompileConstant NIL; DataAlignFullWord(); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymVal(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); InitializeSymPrp(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymNam MaxSymbol; InitializeSymFnc(); DataReserveFunctionCellBlock((MaxSymbol - NextIDNumber!*) + 1); DataAlignFullWord(); DataPrintGlobalLabel FindGlobalLabel 'NextSymbol; DataPrintFullWord NextIDNumber!*; end; lisp procedure InitializeSymPrp(); << CommentOutCode << InitializeHeap(); >>; % init prop lists DataPrintGlobalLabel FindGlobalLabel 'SymPrp; for I := 0 step 1 until 128 do InitSymPrp1 Int2ID I; for each X in car OrderedIDList!* do InitSymPrp1 X >>; lisp procedure InitSymPrp1 X; << CommentOutCode << DataPrintFullWord(if (X := get(X, 'InitialPropertyList)) then X else NilNumber!*); >>; DataPrintFullWord NilNumber!* >>; CommentOutCode << lisp procedure InitializeHeap(); begin scalar L; DataPrintGlobalLabel FindGlobalLabel 'Heap; for I := 0 step 1 until 128 do PrintPropertyList Int2ID I; for each X in car OrderedIDList!* do PrintPropertyList X; L := get('HeapSize, 'WConst); end; >>; lisp procedure InitializeSymNam MaxSymbol; << DataPrintGlobalLabel FindGlobalLabel 'SymNam; for I := 0 step 1 until 128 do DataPrintFullWord CompileConstant ID2String Int2ID I; for each IDName in car OrderedIDList!* do DataPrintFullWord CompileConstant ID2String IDName; MaxSymbol := MaxSymbol - 1; for I := NextIDNumber!* step 1 until MaxSymbol do DataPrintFullWord(I + 1); DataPrintFullWord 0 >>; lisp procedure InitializeSymVal(); << DataPrintGlobalLabel FindGlobalLabel 'SymVal; for I := 0 step 1 until 128 do InitSymVal1 Int2ID I; for each X in car OrderedIDList!* do InitSymVal1 X >>; lisp procedure InitSymVal1 X; begin scalar Val; return DataPrintFullWord(if (Val := get(X, 'InitialValue)) then CompileConstant Val else if FlagP(X, 'NilInitialValue) then NilNumber!* else list('MkItem, get('Unbound, 'WConst), FindIDNumber X)); end; lisp procedure InitializeSymFnc(); << DataPrintGlobalLabel FindGlobalLabel 'SymFnc; for I := 0 step 1 until 128 do InitSymFnc1 Int2ID I; for each X in car OrderedIDList!* do InitSymFnc1 X >>; lisp procedure InitSymFnc1 X; begin scalar EP; EP := get(X, 'EntryPoint); if null EP then DataPrintUndefinedFunctionCell() else DataPrintDefinedFunctionCell EP; end; lisp procedure ASMOutLap U; begin scalar LocalLabels!*, OldOut; U := Pass1Lap U; % Expand cmacros, quoted expressions CodeBlockHeader(); OldOut := WRS CodeOut!*; for each X in U do ASMOutLap1 X; WRS OldOut; CodeBlockTrailer(); end; lisp procedure ASMOutLap1 X; begin scalar Fn; return if StringP X then PrintLabel X else if atom X then PrintLabel FindLocalLabel X else if (Fn := get(car X, 'ASMPseudoOp)) then Apply(Fn, list X) else % instruction output form is: % "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline" << Prin2 '! ; % Space PrintOpcode car X; X := cdr X; if not null X then << Prin2 '! ; % SPACE PrintOperand car X; for each U in cdr X do << Prin2 '!,; % COMMA PrintOperand U >> >>; Prin2 !$EOL!$ >>; % NEWLINE end; put('!*Entry, 'ASMPseudoOp, 'ASMPrintEntry); lisp procedure ASMPrintEntry X; begin scalar Y; PrintComment X; X := cadr X; Y := FindEntryPoint X; if not FlagP(X, 'InternalFunction) then FindIDNumber X; if X eq MainEntryPointName!* then << !*MainFound := T; SpecialActionForMainEntryPoint() >> else CodeDeclareExportedUse Y; end; Procedure CodeDeclareExportedUse Y; if !*DeclareBeforeUse then << CodeDeclareExported Y; PrintLabel Y >> else << PrintLabel Y; CodeDeclareExported Y >>; lisp procedure FindEntryPoint X; begin scalar E; return if (E := get(X, 'EntryPoint)) then E else if ASMSymbolP X and not get(X, 'ASMSymbol) then << put(X, 'EntryPoint, X); X >> else << E := StringGenSym(); put(X, 'EntryPoint, E); E >>; end; lisp procedure ASMPseudoPrintFloat X; PrintF(DoubleFloatFormat!*, cadr X); put('Float, 'ASMPseudoOp, 'ASMPseudoPrintFloat); lisp procedure ASMPseudoPrintFullWord X; for each Y in cdr X do PrintFullWord Y; put('FullWord, 'ASMPseudoOp, 'ASMPseudoPrintFullWord); lisp procedure ASMPseudoPrintByte X; PrintByteList cdr X; put('Byte, 'ASMPseudoOp, 'ASMPseudoPrintByte); lisp procedure ASMPseudoPrintHalfWord X; PrintHalfWordList cdr X; put('HalfWord, 'ASMPseudoOp, 'ASMPseudoPrintHalfWord); lisp procedure ASMPseudoPrintString X; PrintString cadr X; put('String, 'ASMPseudoOp, 'ASMPseudoPrintString); lisp procedure PrintOperand X; if StringP X then Prin2 X else if NumberP X then PrintNumericOperand X else if IDP X then Prin2 FindLabel X else begin scalar Hd, Fn; Hd := car X; if (Fn := get(Hd, 'OperandPrintFunction)) then Apply(Fn, list X) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintOperand Apply(cdr Fn, list X) else if (Fn := WConstEvaluable X) then PrintOperand Fn else PrintExpression X; end; put('REG, 'OperandPrintFunction, 'PrintRegister); lisp procedure PrintRegister X; begin scalar Nam; X := cadr X; if StringP X then Prin2 X else if NumberP X then Prin2 GetV(NumericRegisterNames!*, X) else if Nam := RegisterNameP X then Prin2 Nam else << ErrorPrintF("***** Unknown register %r", X); Prin2 X >>; end; lisp procedure RegisterNameP X; get(X, 'RegisterName); lisp procedure ASMEntry X; PrintExpression list('plus2, 'SymFnc, list('times2, AddressingUnitsPerFunctionCell, list('IDLoc, cadr X))); put('Entry, 'OperandPrintFunction, 'ASMEntry); lisp procedure ASMInternalEntry X; Prin2 FindEntryPoint cadr X; put('InternalEntry, 'OperandPrintFunction, 'ASMInternalEntry); put('InternalEntry, 'ASMExpressionFunction, 'ASMInternalEntry); macro procedure ExtraReg U; list('plus2, '(WArray ArgumentBlock), (cadr U - (LastActualReg!& + 1)) * AddressingUnitsPerItem); lisp procedure ASMSyslispVarsPrint X; Prin2 FindGlobalLabel cadr X; DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'OperandPrintFunction); DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'ASMExpressionFunction); lisp procedure ASMPrintValueCell X; PrintExpression list('plus2, 'SymVal, list('times, AddressingUnitsPerItem, list('IDLoc, cadr X))); DefList('((fluid ASMPrintValueCell) (!$fluid ASMPrintValueCell) (global ASMPrintValueCell) (!$global ASMPrintValueCell)), 'OperandPrintFunction); % Redefinition of WDeclare for output to assembler file % if either UpperBound or Initializer are NIL, they are considered to be % unspecified. fexpr procedure WDeclare U; for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X); flag('(WDeclare), 'IGNORE); lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer); if Typ = 'WCONST then if Scope = 'EXTERNAL and not get(Name, 'WCONST) then ErrorPrintF("*** A value has not been defined for WConst %r", Name) else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); put(Name, 'WCONST, WConstReform Initializer) >> else << put(Name, Typ, Name); if Scope = 'EXTERNAL then << put(Name, 'SCOPE, 'EXTERNAL); if not RegisterNameP Name then % kludge to avoid declaring << Name := LookupOrAddASMSymbol Name; DataDeclareExternal Name; % registers as variables CodeDeclareExternal Name >> >> else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); Name := LookupOrAddASMSymbol Name; if !*DeclareBeforeUse then DataDeclareExported Name; DataInit(Name, Typ, UpperBound, Initializer); if not !*DeclareBeforeUse then DataDeclareExported Name; CodeDeclareExternal Name >> >>; lisp procedure DataInit(ASMSymbol, Typ, UpperBound, Initializer); << DataAlignFullWord(); if Typ = 'WVAR then << if UpperBound then ErrorPrintF "*** An UpperBound may not be specified for a WVar"; Initializer := if Initializer then WConstReform Initializer else 0; DataPrintVar(ASMSymbol, Initializer) >> else << if UpperBound and Initializer then ErrorPrintF "*** Can't have both UpperBound and initializer" else if not (UpperBound or Initializer) then ErrorPrintF "*** Must have either UpperBound or initializer" else if UpperBound then DataPrintBlock(ASMSymbol, WConstReform UpperBound, Typ) else << Initializer := if StringP Initializer then Initializer else WConstReformLis Initializer; DataPrintList(ASMSymbol, Initializer, Typ) >> >> >>; lisp procedure WConstReform U; begin scalar X; return if FixP U or StringP U then U else if IDP U then if get(U, 'WARRAY) or get(U, 'WSTRING) then U else if get(U,'WVAR) then list('GETMEM,U) else if (X := get(U, 'WCONST)) then X else ErrorPrintF("*** Unknown symbol %r in WConstReform", U) else if PairP U then if (X := get(car U, 'WConstReformPseudo)) then Apply(X, list U) else if (X := get(car U, 'DOFN)) then X . WConstReformLis cdr U else if MacroP car U then WConstReform Apply(cdr GetD car U, list U) else car U . WConstReformLis cdr U else ErrorPrintF("*** Illegal expression %r in WConstReform", U); end; lisp procedure WConstReformIdent U; U; put('InternalEntry, 'WConstReformPseudo, 'WConstReformIdent); lisp procedure WConstReformQuote U; CompileConstant cadr U; put('QUOTE, 'WConstReformPseudo, 'WConstReformQuote); lisp procedure WConstReformLis U; for each X in U collect WConstReform X; lisp procedure WConstReformLoc U; %. To handle &Foo[23] << U := WConstReform cadr U; if car U neq 'GETMEM then ErrorPrintF("*** Illegal constant addressing expression %r", list('LOC, U)) else cadr U >>; put('LOC, 'WConstReformPseudo, 'WConstReformLoc); lisp procedure WConstReformIDLoc U; FindIDNumber cadr U; put('IDLoc, 'WConstReformPseudo, 'WConstReformIDLoc); lisp procedure LookupOrAddASMSymbol U; begin scalar X; if not (X := get(U, 'ASMSymbol)) then X := AddASMSymbol U; return X; end; lisp procedure AddASMSymbol U; begin scalar X; X := if ASMSymbolP U and not get(U, 'EntryPoint) then U else StringGensym(); put(U, 'ASMSymbol, X); return X; end; lisp procedure DataPrintVar(Name, Init); begin scalar OldOut; DataPrintLabel Name; OldOut := WRS DataOut!*; PrintFullWord Init; WRS OldOut; end; lisp procedure DataPrintBlock(Name, Siz, Typ); << if Typ = 'WSTRING then Siz := list('quotient, list('plus2, Siz, CharactersPerWord + 1), CharactersPerWord) else Siz := list('plus2, Siz, 1); DataReserveZeroBlock(Name, Siz) >>; lisp procedure DataPrintList(Nam, Init, Typ); begin scalar OldOut; DataPrintLabel Nam; OldOut := WRS DataOut!*; if Typ = 'WSTRING then if StringP Init then << PrintFullWord Size Init; PrintString Init >> else << PrintFullWord(Length Init - 1); PrintByteList Append(Init, '(0)) >> else if StringP Init then begin scalar S; S := Size Init; for I := 0 step 1 until S do PrintFullWord Indx(Init, I); end else for each X in Init do PrintFullWord X; WRS OldOut; end; lisp procedure DataPrintGlobalLabel X; << if !*DeclareBeforeUse then DataDeclareExported X; DataPrintLabel X; if not !*DeclareBeforeUse then DataDeclareExported X; CodeDeclareExternal X >>; lisp procedure DataDeclareExternal X; if not (X member DataExternals!* or X member DataExporteds!*) then << DataExternals!* := X . DataExternals!*; DataPrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExternal X; if not (X member CodeExternals!* or X member CodeExporteds!*) then << CodeExternals!* := X . CodeExternals!*; CodePrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure DataDeclareExported X; << if X member DataExternals!* or X member DataExporteds!* then ErrorPrintF("***** %r multiply defined", X); DataExporteds!* := X . DataExporteds!*; DataPrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExported X; << if X member CodeExternals!* or X member CodeExporteds!* then ErrorPrintF("***** %r multiply defined", X); CodeExporteds!* := X . CodeExporteds!*; CodePrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure PrintLabel X; PrintF(LabelFormat!*, X,X); lisp procedure DataPrintLabel X; DataPrintF(LabelFormat!*, X,X); lisp procedure CodePrintLabel X; CodePrintF(LabelFormat!*, X,X); lisp procedure PrintComment X; PrintF(CommentFormat!*, X); PrintExpressionForm!* := list('PrintExpression, MkQuote NIL); PrintExpressionFormPointer!* := cdadr PrintExpressionForm!*; % Save some consing % instead of list('PrintExpression, MkQuote X), reuse the same list structure lisp procedure PrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); PrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); DataPrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure CodePrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); CodePrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveZeroBlock(Nam, X); << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveZeroBlockFormat!*, Nam, PrintExpressionForm!*) >>; lisp procedure DataReserveBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveFunctionCellBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerFunctionCell, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintUndefinedFunctionCell(); begin scalar OldOut; OldOut := WRS DataOut!*; for each X in UndefinedFunctionCellInstructions!* do ASMOutLap1 X; WRS OldOut; end; lisp procedure DataPrintDefinedFunctionCell X; <<DataDeclareExternal X; DataPrintF(DefinedFunctionCellFormat!*, X, X)>>; % in case it's needed twice lisp procedure DataPrintByteList X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintByteList X; WRS OldOut; end; lisp procedure DataPrintExpression X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintExpression X; WRS OldOut; end; lisp procedure CodePrintExpression X; begin scalar OldOut; OldOut := WRS CodeOut!*; PrintExpression X; WRS OldOut; end; ExpressionCount!* := -1; lisp procedure PrintExpression X; (lambda(ExpressionCount!*); begin scalar Hd, Tl, Fn; X := ResolveWConstExpression X; if NumberP X or StringP X then Prin2 X else if IDP X then Prin2 FindLabel X else if atom X then << ErrorPrintF("***** Oddity in expression %r", X); Prin2 X >> else << Hd := car X; Tl := cdr X; if (Fn := get(Hd, 'BinaryASMOp)) then << if ExpressionCount!* > 0 then Prin2 ASMOpenParen!*; PrintExpression car Tl; Prin2 Fn; PrintExpression cadr Tl; if ExpressionCount!* > 0 then Prin2 ASMCloseParen!* >> else if (Fn := get(Hd, 'UnaryASMOp)) then << Prin2 Fn; PrintExpression car Tl >> else if (Fn := get(Hd, 'ASMExpressionFormat)) then Apply('PrintF, Fn . for each Y in Tl collect list('PrintExpression, MkQuote Y)) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintExpression Apply(cdr Fn, list X) else if (Fn := get(Hd, 'ASMExpressionFunction)) then Apply(Fn, list X) else << ErrorPrintF("***** Unknown expression %r", X); PrintF("*** Expression error %r ***", X) >> >>; end)(ExpressionCount!* + 1); lisp procedure ASMPrintWConst U; PrintExpression cadr U; put('WConst, 'ASMExpressionFunction, 'ASMPrintWConst); DefList('((Plus2 !+) (WPlus2 !+) (Difference !-) (WDifference !-) (Times2 !*) (WTimes2 !*) (Quotient !/) (WQuotient !/)), 'BinaryASMOp); DefList('((Minus !-) (WMinus !-)), 'UnaryASMOp); lisp procedure CompileConstant X; << X := BuildConstant X; if null cdr X then car X else << If !*DeclareBeforeUse then CodeDeclareExported cadr X; ASMOutLap cdr X; DataDeclareExternal cadr X; If Not !*DeclareBeforeUse then CodeDeclareExported cadr X; car X >> >>; CommentOutCode << lisp procedure CompileHeapData X; begin scalar Y; X := BuildConstant X; return if null cdr X then car X else << Y := WRS DataOut!*; for each Z in cdr X do ASMOutLap1 Z; DataDeclareExported cadr X; WRS Y; car X >>; end; >>; lisp procedure DataPrintString X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintString X; WRS OldOut; end; lisp procedure FindLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else if (Y := get(X, 'ASMSymbol)) then Y else if (Y := get(X, 'WConst)) then Y else FindLocalLabel X; end; lisp procedure FindLocalLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else << LocalLabels!* := (X . (Y := StringGensym())) . LocalLabels!*; Y >>; end; lisp procedure FindGlobalLabel X; get(X, 'ASMSymbol) or ErrorPrintF("***** Undefined symbol %r", X); lisp procedure CodePrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS CodeOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; lisp procedure DataPrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS DataOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; % Kludge of the year, just to avoid having IDLOC defined during compilation CompileTime fluid '(MACRO); MACRO := 'MACRO; PutD('IDLoc, MACRO, function lambda X; FindIDNumber cadr X); END; |
Added psl-1983/3-1/comp/opencodedfunctions.lst version [8b44d31d19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | These functions where tagged as open coded in the Dec20 PSL. ADDRESSAPPLY0 ADDRESSAPPLY1 ADDRESSAPPLY2 ADDRESSAPPLY3 ADDRESSAPPLY4 CODEAPPLY0 CODEAPPLY1 CODEAPPLY2 CODEAPPLY3 CODEAPPLY4 IDAPPLY0 IDAPPLY1 IDAPPLY2 IDAPPLY3 IDAPPLY4 % These represent the interface tothe users float capability. !*FEQ !*FGREATERP !*WFIX !*WFLOAT !*FDIFFERENCE !*FASSIGN !*FLESSP !*FPLUS2 !*FQUOTIENT !*FTIMES2 %These are for standard division. WREMAINDER WQUOTIENT % These arethe primitives for dealing with the machine words of various sizes. BYTE HALFWORD BITTABLE PUTBYTE PUTHALFWORD PUTBITTABLE |
Added psl-1983/3-1/comp/p-lambind.sl version [dea1bda62b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-LAMBIND.SL - Portable cmacro definitions *LAMBIND, *PROGBIND and *FREERSTR % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % (compiletime (load useful)) (imports '(syslisp)) % requires SYSLISP for AddrUnitsPerItem (de *lambind (regs fluids) (prog (n firstreg) (setq n 0) (setq regs (rest regs)) % remove REGISTERS at the front (setq fluids (rest fluids)) % remove NONLOCALVARS at the front (setq fluids % convert fluids list into vector (list2vector (foreach x in fluids collect (second x)))) (setq firstreg (first regs)) (setq regs (rest regs)) (return (if (null regs) % only one to bind `((*move ,firstreg (reg 2)) (*move `,',(getv fluids 0) (reg 1)) (*call lbind1)) `((*move ,firstreg (memory (fluid LambindArgs*) (wconst 0))) (*move (fluid LambindArgs*) ,firstreg) ,@(foreach x in regs collect (progn (setq n (add1 n)) `(*move ,x (memory ,firstreg (wconst (wtimes2 (wconst AddressingUnitsPerItem) (wconst ,n))))))) (*move `,',fluids (reg 1)) (*call lambind)))))) (defcmacro *lambind) (de *progbind (fluids) (if (null (rest (rest fluids))) `((*move `,',(second (first (rest fluids))) (reg 1)) (*call pbind1)) `((*move `,',(list2vector (foreach x in (rest fluids) collect (second x))) (reg 1)) (*call progbind)))) (defcmacro *progbind) (de *freerstr (fluids) `((*move `,',(length (rest fluids)) (reg 1)) (*call UnBindN))) (defcmacro *freerstr) (setq *unsafebinder t) % has to save registers across calls |
Added psl-1983/3-1/comp/pass-1-lap.build version [66091f31c0].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | CompileTime << on EolInStringOK; macro procedure !* U; NIL; load Syslisp; >>; in "anyreg-cmacro.sl"$ in "pass-1-lap.sl"$ in "common-cmacros.sl"$ in "common-predicates.sl"$ |
Added psl-1983/3-1/comp/pass-1-lap.sl version [7b2f061946].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% PASS-1-LAP.SL - Expand c-macros and allocate quoted expressions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 December 1981 % Copyright (c) 1981 University of Utah % % Added MCprint and InstructionPrint - MLG % <PSL.COMP>PASS-1-LAP.SL.17, 4-Aug-82 00:35:54, Edit by BENSON % Added bignum constants; won't work for cross-compilation, though %") (* "Pass1Lap takes a list of c-macros and instructions, and attempts to simplify them whenever possible. C-macros are expanded by APPLY(CAR X, CDR X), which will return another instruction list to be processed recursively by Pass1Lap. Quoted expressions are allocated at the end of the code, in the following way: In an instruction or c-macro (.... (QUOTE (A B C)) ...) the following is tacked onto the end of the constructed code list: L2 (MKITEM ID A) (MKITEM PAIR L3) L3 (MKITEM ID B) (MKITEM PAIR L4) L4 (MKITEM ID C) (MKITEM ID NIL) If *ImmediateQuote is NIL, the quoted reference becomes: (... L1 ...) ... L1 (fullword (MKITEM PAIR L2)) Otherwise, it becomes: (... (immediate (MKITEM PAIR L2)) ...)") (fluid '(!*ImmediateQuote !*PCMAC !*PrintedOneCMacro Pass1CodeList Pass1ConstantList Pass1ConstantContentsList Pass1AddedCode EntryPoints!* AddressingUnitsPerItem LastActualReg!&)) (CompileTime (flag '(Pass1Code OneLapPass1 AddInstruction ExpandPseudoOps ExpandOnePseudoOp GenerateLabel GenerateCodeLabel AddCodeLabel AddCode ExpandQuote1 ExpandImmediateQuote ExpandItem ExpandNonImmediateQuote SaveConstant SaveContents AppendConstants AppendOneConstant AppendItem AddFullWord AppendContents MakeMkItem) 'InternalFunction)) (CompileTime (load fast-vector)) (de Pass1Lap (InstructionList) (prog (Pass1CodeList Pass1ConstantList Pass1ConstantContentsList EntryPoints!* Pass1AddedCode) (setq Pass1CodeList (cons NIL NIL)) (* "Init a TCONC pointer") (setq Pass1ConstantContentsList (cons NIL NIL)) (Pass1Code InstructionList) (* "Expand macros") (Pass1Code Pass1AddedCode) (AppendConstants) (* "Tack the constants on the end") (return (car Pass1CodeList)))) (* "BuildConstant takes an S-expression and returns the LAP version of it.") (* "The car is the expanded item, cdr is the contents") (de BuildConstant (Expression) (prog (Pass1CodeList Pass1ConstantList Pass1ConstantContentsList ExpandedExpression) (setq Pass1CodeList (cons NIL NIL)) (* "Init a TCONC pointer") (setq Pass1ConstantContentsList (cons NIL NIL)) (setq ExpandedExpression (ExpandItem Expression)) (* "Expand the item") (AppendConstants) (* "Tack the contents on the end") (return (cons ExpandedExpression (car Pass1CodeList))))) (de Pass1Code (InstructionList) (ForEach Instruction in InstructionList do (OneLapPass1 Instruction))) (de OneLapPass1 (Instruction) (cond ((atom Instruction) (AddCodeLabel Instruction)) ((eq (car Instruction) '!*ENTRY) (progn (* "ENTRY directives are passed unchanged") (cond ((and (not (or (FlagP (second Instruction) 'InternalFunction) (equal (second Instruction) '**fasl**initcode**))) (null (car Pass1CodeList))) (* "Header word says how many arguments to expect") (AddCode (list 'FULLWORD (fourth Instruction))))) (setq EntryPoints!* (cons (second Instruction) EntryPoints!*)) (cond (!*PCMAC (MCPrint Instruction))) (AddCode Instruction))) ((FlagP (car Instruction) 'MC) (progn (cond ((and !*PCMAC (not !*PrintedOneCMacro)) (MCPrint Instruction))) ((lambda (!*PrintedOneCMacro) (Pass1Code (Apply (car Instruction) (cdr Instruction)))) T))) (t (progn (cond (!*PCMAC (InstructionPrint Instruction))) (AddInstruction Instruction))))) (de MCPrint(x) (print x)) (de InstructionPrint(x) (PrintF " %p%n" x)) (de AddInstruction (Instruction) (AddCode (ExpandPseudoOps Instruction))) (de ExpandPseudoOps (X) (cond ((atom X) X) (t (cons (ExpandOnePseudoOp (car X)) (ExpandPseudoOps (cdr X)))))) (de ExpandOnePseudoOp (X) (prog (PseudoOpFunction) (return (cond ((atom X) X) ((setq PseudoOpFunction (get (car X) 'Pass1PseudoOp)) (ExpandOnePseudoOp (Apply PseudoOpFunction (list X)))) ((setq PseudoOpFunction (WConstEvaluable X)) PseudoOpFunction) (t (cons (car X) (ExpandPseudoOps (cdr X)))))))) (de PassOneUnImmediate (X) (progn (setq X (cadr X)) (cond ((EqCar X 'Immediate) (cadr X)) (t X)))) (put 'UnImmediate 'Pass1PseudoOp 'PassOneUnImmediate) (de PassOneLabel (U) (cadr U)) (put 'Label 'Pass1PseudoOp 'PassOneLabel) (de PassOneUnDeferred (X) (progn (setq X (cadr X)) (cond ((EqCar X 'Deferred) (cadr X)) (t X)))) (put 'UnDeferred 'Pass1PseudoOp 'PassOneUnDeferred) (* "Removed because ExtraReg has to be processed differently by resident LAP" (de PassOneExtraReg (X) (progn (setq X (cadr X)) (list 'plus2 '(WArray ArgumentBlock) (times (difference (Add1 LastActualReg!&) X) AddressingUnitsPerItem)))) (put 'ExtraReg 'Pass1PseudoOp 'PassOneExtraReg) ) (de GenerateCodeLabel () (prog (NewLabel) (setq NewLabel (GenerateLabel)) (AddCodeLabel NewLabel) (return NewLabel))) (de GenerateLabel () (StringGenSym)) (de AddCodeLabel (Label) (AddCode Label)) (de AddCode (C) (TConc Pass1CodeList C)) (de ExpandLit (U) (prog (L) (cond ((setq L (FindPreviousLit (cdr U))) (return L))) (setq L (GenerateLabel)) (setq Pass1AddedCode (NConc Pass1AddedCode (cons L (ForEach X in (cdr U) collect X)))) (return L))) (de FindPreviousLit (U) (cond ((not (null (rest U))) NIL) (t (prog (L) (setq L Pass1AddedCode) (cond ((null L) (return NIL))) (setq U (first U)) loop (cond ((null (rest L)) (return NIL))) (cond ((equal U (second L)) (return (cond ((atom (first L)) (first L)) (t (prog (B) (setq L (rest L)) (rplacd L (cons (first L) (rest L))) (rplaca L (setq B (GenerateLabel))) (return B))))))) (setq L (rest L)) (go loop))))) (put 'lit 'Pass1PseudoOp 'ExpandLit) (flag '(lit) 'TerminalOperand) (de ExpandQuote (QuotedExpression) (ExpandQuote1 (cadr QuotedExpression))) (put 'Quote 'Pass1PseudoOp 'ExpandQuote) (de ExpandQuote1 (Expression) (cond (!*ImmediateQuote (ExpandImmediateQuote Expression)) (t (ExpandNonImmediateQuote Expression)))) (de ExpandImmediateQuote (Expression) (list 'IMMEDIATE (ExpandItem Expression))) (de ExpandItem (Expression) (prog (LabelOfContents) (return (cond ((InumP Expression) Expression) ((IDP Expression) (MakeMkItem (TagNumber Expression) (list 'IDLoc Expression))) ((CodeP Expression) (MakeMkItem (TagNumber Expression) Expression)) (t (progn (setq LabelOfContents (SaveContents Expression)) (MakeMkItem (TagNumber Expression) LabelOfContents))))))) (de ExpandNonImmediateQuote (Expression) (SaveConstant Expression)) (de SaveConstant (Expression) (prog (TableEntry) (return (cond ((setq TableEntry (Assoc Expression Pass1ConstantList)) (cdr TableEntry)) (t (progn (setq TableEntry (GenerateLabel)) (setq Pass1ConstantList (cons (cons Expression TableEntry) Pass1ConstantList)) TableEntry)))))) (de SaveContents (Expression) (prog (TableEntry) (return (cond ((setq TableEntry (Assoc Expression (car Pass1ConstantContentsList))) (cdr TableEntry)) (t (progn (setq TableEntry (GenerateLabel)) (TConc Pass1ConstantContentsList (cons Expression TableEntry)) TableEntry)))))) (de AppendConstants () (prog (TempCodeList) (cond ((not !*ImmediateQuote) (ForEach TableEntry in Pass1ConstantList do (AppendOneConstant TableEntry)))) (setq TempCodeList Pass1CodeList) (setq Pass1CodeList (cons NIL NIL)) (ForEach TableEntry in (car Pass1ConstantContentsList) do (AppendContents TableEntry)) (* "The contents go on the begininning of the list") (LConc Pass1CodeList (car TempCodeList)))) (de AppendOneConstant (ExpressionLabelPair) (progn (AddCodeLabel (cdr ExpressionLabelPair)) (AppendItem (car ExpressionLabelPair)))) (de AppendItem (Expression) (AddFullWord (ExpandItem Expression))) (de AddFullWord (Expression) (AddCode (list 'FULLWORD Expression))) (de AppendContents (ExpressionLabelPair) (prog (Expression UpperBound I) (AddCodeLabel (cdr ExpressionLabelPair)) (setq Expression (car ExpressionLabelPair)) (cond ((PairP Expression) (progn (AppendItem (car Expression)) (AppendItem (cdr Expression)))) ((StringP Expression) (progn (AddFullWord (Size Expression)) (AddCode (list 'STRING Expression)))) ((VectorP Expression) (progn (setq UpperBound (ISizeV Expression)) (AddFullWord UpperBound) (setq I 0) (while (ILEQ I UpperBound) (progn (AppendItem (IGetV Expression I)) (setq I (IAdd1 I)))))) ((BigP Expression) (progn (setq UpperBound (ISizeV Expression)) (AddFullWord UpperBound) (setq I 0) (while (ILEQ I UpperBound) (progn (AppendItem (IGetV Expression I)) (setq I (IAdd1 I)))))) ((FixP Expression) (progn (AddFullWord 0) (* "Header of full word fixnum") (AddFullWord Expression))) ((FloatP Expression) (progn (AddFullWord 1) (* "Header of float") (AddCode (list 'FLOAT Expression))))))) (de MakeMkItem (TagPart InfPart) (list 'MKITEM TagPart InfPart)) (de InumP (N) (IntP N)) (* "Must be changed for cross-compilation") (de TagNumber (Expression) (MkINT (Tag Expression))) (* "Must be redefined for cross-compilation") |
Added psl-1983/3-1/comp/syslisp-syntax.red version [3acac7e8ee].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSLISP-SYNTAX.RED - SMacros and redefinition of arithmetic operators % and other syslisp syntax % % Author: Eric Benson and M. L. griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 July 1981 % Copyright (c) 1981 University of Utah % % <PSL.COMP>SYSLISP-SYNTAX.RED.2, 30-Mar-83 11:05:36, Edit by KENDZIERSKI % Included the text from syslisp-syntax.build at the beginning of this file. % The file names w/extensions were too large for the VAX to deal with. % <PSL.COMP>SYSLISP-SYNTAX.RED.3, 5-May-82 11:33:48, Edit by BENSON % Wrapped if GetD 'BEGIN1 around parser calls CompileTime << off UserMode; >>; fluid '(!*SYSLISP); % New WDECLARE constructs % Modify ***** [] vector syntax for PREFIX and INFIX forms % At lower prec SYMBOLIC PROCEDURE ParseLVEC(VNAME,VEXPR); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,VNAME,VEXPR)>> ELSE PARERR("Missing ] in index expression "); % Use normal parsing, then CLEAN SYMBOLIC PROCEDURE ParseWDEC0(FN,DMODES,DLIST); BEGIN SCALAR PLIST; IF EQCAR(DLIST,'!*COMMA!*) THEN DLIST:=REVERSE CDR DLIST ELSE DLIST:=LIST DLIST; PLIST:=FOR EACH DEC IN DLIST COLLECT ParseWDEC1(FN,DEC); RETURN ('WDECLARE . DMODES . FN . REVERSE PLIST); END; SYMBOLIC PROCEDURE ParseWDEC1(FN,DEC); % Process each WDEC to check legal modes if EqCar(DEC,'EQUAL) THEN AConc(ParseWDEC2(FN,CADR DEC), ParseWDEC3(FN,CADDR DEC)) ELSE AConc(ParseWDEC2(FN,DEC), NIL); SYMBOLIC PROCEDURE ParseWDEC2(FN,X); % Remove INDXs from LHS of = IF IDP X THEN list(X, NIL) ELSE IF EQCAR(X,'INDX) THEN LIST(CADR X,CADDR X) ELSE PARERR "Only [] allowed on LHS of WDECLARATION"; SYMBOLIC PROCEDURE ParseWDEC3(FN,X); % Remove INDX's from RHS of = IF IDP X THEN X ELSE IF EQCAR(X,'INDX) THEN (IF CADR X EQ '!*PREFIXVECT!* THEN REMCOM(CADDR X) ELSE PARERR("Only [...] is legal INIT in WDECLARE")) ELSE X; if not FUnBoundP 'BEGIN1 then << % kludge #+Rlisp DEFINEBOP('!*LVEC!*,121,5,ParseLVEC); DEFINEROP('!*LVEC!*,5,ParseLVEC('!*PREFIXVECT!*,X)); DEFINEBOP('!*RVEC!*,4,5); DEFINEROP('WCONST,1,ParseWDEC0('WCONST,'DEFAULT,X)); DEFINEROP('WVAR,1,ParseWDEC0('WVAR,'DEFAULT,X)); DEFINEROP('WARRAY,1,ParseWDEC0('WARRAY,'DEFAULT,X)); DEFINEROP('WSTRING,1,ParseWDEC0('WSTRING,'DEFAULT,X)); DEFINEBOP('WCONST,1,1,ParseWDEC0('WCONST,X,Y)); DEFINEBOP('WVAR,1,1,ParseWDEC0('WVAR,X,Y)); DEFINEBOP('WARRAY,1,1,ParseWDEC0('WARRAY,X,Y)); DEFINEBOP('WSTRING,1,1,ParseWDEC0('WSTRING,X,Y)); % Operators @ for GetMem, & for Loc put('!@, 'NewNam, 'GetMem); put('!&, 'NewNam, 'Loc); >>; % SysName hooks for REFORM REMFLAG('(REFORM),'LOSE); SYMBOLIC PROCEDURE REFORM U; IF ATOM U OR CAR U MEMQ '(QUOTE WCONST) THEN U ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U ELSE IF CAR U EQ 'PROG THEN PROGN(RPLCDX(CDR U,REFORMLIS CDDR U),U) ELSE IF CAR U EQ 'LAMBDA THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U) ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U THEN BEGIN SCALAR X; IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO)) THEN RETURN LIST('FUNCTION,X) ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U THEN REDERR "MACRO USED AS FUNCTION" ELSE RETURN U END % ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM)) ELSE IF ATOM CAR U THEN BEGIN SCALAR X,Y,FN; FN := CAR U; IF (Y := GETD FN) AND CAR Y EQ 'MACRO AND EXPANDQ FN THEN RETURN REFORM APPLY(CDR Y,LIST U); X := REFORMLIS CDR U; IF NULL IDP FN THEN RETURN(FN . X); IF !*SYSLISP AND (Y:=GET(FN,'SYSNAME)) THEN <<FN:=Y;U:=FN.CDR U>>; IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'NMACRO)) THEN RETURN APPLY(Y,IF FLAGP(FN,'NOSPREAD) THEN LIST X ELSE X) ELSE IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'SMACRO)) THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y) %we could use an atom SUBLIS here (eg, SUBLA); ELSE RETURN PROGN(RPLCDX(U,X),U) END ELSE REFORM CAR U . REFORMLIS CDR U; RemFlag('(Plus Times), 'NARY)$ DefList('((Plus WPlus2) (Plus2 WPlus2) (Minus WMinus) (Difference WDifference) (Times WTimes2) (Times2 WTimes2) (Quotient WQuotient) (Remainder WRemainder) (Mod WRemainder) (Land WAnd) (Lor WOr) (Lxor WXor) (Lnot WNot) (LShift WShift) (LSH WShift)), 'SysName); DefList('((Neq WNeq) (Equal WEq) (Eqn WEq) (Eq WEq) (Greaterp WGreaterp) (Lessp WLessp) (Geq WGeq) (Leq WLeq) (Getv WGetv) (Indx WGetv) (Putv WPutv) (SetIndx WPutv)), 'SysName); % modification to arithmetic FOR loop for SysLisp LISP PROCEDURE MKSYSFOR U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,LAB2,RESULT,TAIL,VAR,X; VAR := second second U; INCR := cddr second U; if FixP third Incr or WConstEvaluable third Incr then return ConstantIncrementFor U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := LIST('WDIFFERENCE,first INCR,VAR); IF second INCR NEQ 1 THEN X := LIST('WTIMES2,second INCR,X); IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); LAB2 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST('WLESSP,X,0),LIST('GO,LAB2))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,second INCR)) . LIST('GO,LAB1) . LAB2 . TAIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE ConstantIncrementFor U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,RESULT,VAR,X, StepValue, Limit; VAR := second second U; INCR := cddr second U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; StepValue := if FixP second Incr then second Incr else WConstEvaluable second Incr; Limit := first Incr; IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST(if MinusP StepValue then 'WLessP else 'WGreaterP, Var, Limit),'(return 0))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,StepValue)) . LIST('GO,LAB1) . NIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE MKFOR1 U; IF !*SYSLISP THEN MKSYSFOR U ELSE MKLISPFOR U; PUTD('MKLISPFOR,'EXPR,CDR GETD 'FOR); % grab old FOR definition macro procedure For U; MkFor1 U; % redefine FOR END; |
Added psl-1983/3-1/comp/tags.red version [8637527903].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure HighTags U; DeclareTagRange(cdr U, if_system(MC68000, 16#FF, 31), -1); >>; LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair); put('Code, 'WConst, 15); HighTags(NegInt, ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); |
Added psl-1983/3-1/comp/wdeclare.red version [f3b3178e88].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % WDECLARE.RED - Skeleton WDeclare for WConsts % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 March 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP>WDECLARE.RED.2, 17-Nov-82 17:09:39, Edit by PERDUE % Flagged WDeclare IGNORE rather than EVAL, so it takes effect % at compile time rather than load time! fexpr procedure WDeclare U; for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X); flag('(WDeclare), 'IGNORE); lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer); if Typ = 'WCONST then if Scope = 'EXTERNAL and not get(Name, 'WCONST) then ErrorPrintF("*** A value has not been defined for WConst %r", Name) else% EvDefConst(Name, Initializer) put(Name, 'WConst, Initializer) else StdError BldMsg("%r is not currently supported", Typ); |
Added psl-1983/3-1/create-directories.ctl version [86e5e30014].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Please edit this, and replace all <psl with <yourpslname @build <psl> @@perm 6400 ! choose appropriate size @@work 6400 ! nnnn+extra @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 30 @@ ; 5230 pages for following. PSL: needs about 1100. ; Single directory, partial restore needs about 1300 below and 1100 above. @build <psl.comp> @@perm 180 ! choose appropriate size @@work 180 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.comp.20> @@perm 55 ! choose appropriate size @@work 55 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.dist> @@perm 25 ! choose appropriate size @@work 25 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.doc> @@perm 725 ! choose appropriate size @@work 725 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 2 @@ @build <psl.doc.20> @@perm 25 ! choose appropriate size @@work 25 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.doc.nmode> @@perm 590 ! choose appropriate size @@work 590 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.glisp> @@perm 330 ! choose appropriate size @@work 330 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.help> @@perm 100 ! choose appropriate size @@work 100 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.kernel> @@perm 785 ! choose appropriate size @@work 785 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.kernel.20> @@perm 560 ! choose appropriate size @@work 560 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.lap> @@perm 500 ! choose appropriate size @@work 500 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.lpt> @@perm 430 ! choose appropriate size @@work 430 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.nmode> @@perm 510 ! choose appropriate size @@work 510 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.nmode.binary> @@perm 230 ! choose appropriate size @@work 230 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.nonkernel> @@perm 5 ! choose appropriate size @@work 5 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.tests> @@perm 715 ! choose appropriate size @@work 715 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.tests.20> @@perm 500 ! choose appropriate size @@work 500 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.util> @@perm 635 ! choose appropriate size @@work 635 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.util.20> @@perm 60 ! choose appropriate size @@work 60 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.windows> @@perm 105 ! choose appropriate size @@work 105 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.windows.binary> @@perm 30 ! choose appropriate size @@work 30 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ |
Added psl-1983/3-1/dist/20-copy.ctl version [bd62eaecfb].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ! Master PSL Tape Copy ! 12:31 pm Friday, 22 April 1983 @enable ! so operators can read the files @set account small @assign mta0: @assign mta1: @MTU Tape mta0: Copy mta1: rew tape mta1: unload exit @deas mta0: @deas mta1: |
Added psl-1983/3-1/dist/bboard.msg version [4642dcd854].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Version 3.1 PSL Available We have just installed the latest version of Utah's PSL (Portable Standard LISP) system. This system is written almost entirely in itself, and is compiled with an efficient optimizing LISP compiler, with machine oriented extensions (called "SYSLISP"). The LISP itself is based on Utah Standard LISP, with modernizations and extensions derived from FranzLISP, Common-LISP, etc. PSL currently runs on DEC-20 under TOPS-20, VAX under UNIX, and a number of Motorola MC68000 systems. Future implementations for VAX-VMS, CRAY-1, IBM-370 and extended addressing TOPS-20 are envisioned or already underway. In order to run PSL, you must use a set of logical names, defined in <name>MINIMAL-LOGICAL-NAMES.CMD. You should insert a @TAKE of this file in your LOGIN.CMD file. A printed copy of the preliminary PSL manual can be obtained from [........]; there is also a complete online version of this manual, organized as a set of files, one per chapter. These are stored as PLPT:nnnn-chaptername.LPT. PLEASE DO NOT print your own copy. There are a set of short HELP files, on directory PH:. To get started, read PH:PSL-INTRO.HLP. The licence agrrement under which we have recieved this version of PSL restricts it to our internal use. Please do not distribute the code (source or listings), or documentation outside of our group. If there are any problems, please MAIL to [.....]. |
Added psl-1983/3-1/dist/create-directories.ctl version [86e5e30014].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Please edit this, and replace all <psl with <yourpslname @build <psl> @@perm 6400 ! choose appropriate size @@work 6400 ! nnnn+extra @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 30 @@ ; 5230 pages for following. PSL: needs about 1100. ; Single directory, partial restore needs about 1300 below and 1100 above. @build <psl.comp> @@perm 180 ! choose appropriate size @@work 180 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.comp.20> @@perm 55 ! choose appropriate size @@work 55 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.dist> @@perm 25 ! choose appropriate size @@work 25 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.doc> @@perm 725 ! choose appropriate size @@work 725 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 2 @@ @build <psl.doc.20> @@perm 25 ! choose appropriate size @@work 25 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.doc.nmode> @@perm 590 ! choose appropriate size @@work 590 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.glisp> @@perm 330 ! choose appropriate size @@work 330 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.help> @@perm 100 ! choose appropriate size @@work 100 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.kernel> @@perm 785 ! choose appropriate size @@work 785 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.kernel.20> @@perm 560 ! choose appropriate size @@work 560 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.lap> @@perm 500 ! choose appropriate size @@work 500 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.lpt> @@perm 430 ! choose appropriate size @@work 430 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.nmode> @@perm 510 ! choose appropriate size @@work 510 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.nmode.binary> @@perm 230 ! choose appropriate size @@work 230 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.nonkernel> @@perm 5 ! choose appropriate size @@work 5 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.tests> @@perm 715 ! choose appropriate size @@work 715 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.tests.20> @@perm 500 ! choose appropriate size @@work 500 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.util> @@perm 635 ! choose appropriate size @@work 635 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.util.20> @@perm 60 ! choose appropriate size @@work 60 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ @build <psl.windows> @@perm 105 ! choose appropriate size @@work 105 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@max 1 @@ @build <psl.windows.binary> @@perm 30 ! choose appropriate size @@work 30 ! increase this as needed @@files-only ! Cant login @@gen 2 ! Retain 1 previous version @@protection 777700 ! Give group access @@default 777700 ! Give group access @@ |
Added psl-1983/3-1/dist/full-logical-names.cmd version [547a6733f7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Officially recognized logical names for FULL set of ; PSL subdirectories on UTAH-20 for V3 PSL distribution ; EDIT <PSL to your <name define psl: <psl> ! Executable files and miscellaneous define pc: <psl.comp> ! Compiler sources define p20c: <psl.comp.20> ! 20 Specific Compiler sources define pdist: <psl.dist> ! Distribution files define pd: <psl.doc> ! Documentation files define p20d: <psl.doc.20> ! 20 Specific Documentation define pndoc: <psl.doc.nmode> ! NMODE Documentation files ; not distributed anymore define pe: <psl.emode> ! EMODE support and drivers define pg: <psl.glisp> ! Glisp sources define ph: <psl.help> ! Help files define pk: <psl.kernel> ! Kernel Source files define p20k: <psl.kernel.20> ! 20 Specific Kernel Sources define pl: <psl.lap> ! LAP files define plpt: <psl.lpt> ! Printer version of Documentation define pn: <psl.nmode> ! NMODE editor files define pnb: <psl.nmode.binary> ! NMODE editor binaries define pnk: <psl.nonkernel> ! PSL Non Kernel source files define pt: <psl.tests> ! Test files define p20t: <psl.tests.20> ! 20 Specific Test files define pu: <psl.util> ! Utility program sources define p20u: <psl.util.20> ! 20 Specific Utility files define pw: <psl.windows> ! NMODE Window files define pwb: <psl.windows.binary>! NMODE Window binaries take |
Added psl-1983/3-1/dist/full-restore.ctl version [e17259b24c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve ALL ssnames for FULL PSL system ; First edit FULL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories ; then mount TAPE, def X: @TERM PAGE 0 @DUMPER *tape X: *density 1600 *files *account system-default *; --- Skip over the logical names etc to do the restore. *skip 1 *restore dsk*:<*>*.*.* PSL:*.*.* *restore dsk*:<*>*.*.* PC:*.*.* *restore dsk*:<*>*.*.* P20C:*.*.* *restore dsk*:<*>*.*.* PDIST:*.*.* *restore dsk*:<*>*.*.* PD:*.*.* *restore dsk*:<*>*.*.* P20D:*.*.* *restore dsk*:<*>*.*.* PNDOC:*.*.* ; not distributed anymore *restore dsk*:<*>*.*.* PE:*.*.* *restore dsk*:<*>*.*.* PG:*.*.* *restore dsk*:<*>*.*.* ph:*.*.* *restore dsk*:<*>*.*.* pk:*.*.* *restore dsk*:<*>*.*.* p20:*.*.* *restore dsk*:<*>*.*.* pl:*.*.* *restore dsk*:<*>*.*.* plpt:*.*.* *restore dsk*:<*>*.*.* pn:*.*.* *restore dsk*:<*>*.*.* pnb:*.*.* *restore dsk*:<*>*.*.* pnk:*.*.* *restore dsk*:<*>*.*.* pT:*.*.* *restore dsk*:<*>*.*.* p20T:*.*.* *restore dsk*:<*>*.*.* pu:*.*.* *restore dsk*:<*>*.*.* p20u:*.*.* *restore dsk*:<*>*.*.* pw:*.*.* *restore dsk*:<*>*.*.* pwb:*.*.* |
Added psl-1983/3-1/dist/make-bare-psl.ctl version [740838d766].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | @define dsk: dsk:,p20: @S:BPSL.EXE *(lapin "psl.init") *(setq loaddirectories* '("" "pl:")) *(load char-macro)) *(de gc-trap () nil) *(setq heap-warning-level 1000) *(setq options* nil) *(setq bug-mail-to "PSL") *(de versionname() "Extended-20 Bare PSL 3.1") *(savesystem (versionname) "s:bare-psl.exe" ()) *(quit) ;@rename S:BARE-PSL.EXE PSL:BARE-PSL.EXE ;@set file autokeep PSL:BARE-PSL.EXE |
Added psl-1983/3-1/dist/make-hp-psl.ctl version [b1bd447c6d].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | @; This file constructs a new PSL containing many useful things, including: @; @; The NMODE (EMACS-like) editor and Lisp interface. @; The Lisp Machine Defstruct Facility. @; A set of "useful" things described in the manual. @; @; It creates a new executable file S:PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:PSL.EXE. @; @delete s:psl.exe @expunge s: @s:bare-psl random-argument-to-get-a-new-fork *(load useful nstruct debug find nmode init-file) *(nmode-initialize) *(nmode-switch-windows) % Switch to "OUTPUT" window *(set-message *"C-] E executes Lisp form on current line; C-] L gets normal PSL interface") *(savesystem "Extended-20 PSL 3.1" "s:psl.exe" '((read-init-file "psl"))) *(quit) @reset . @set file autokeep s:psl.exe |
Added psl-1983/3-1/dist/make-nmode.ctl version [ccc8820bc5].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ; This file creates a new S:EX-NMODE.EXE, replacing the old one. ; NOTE: the compiler is also loaded, as most users will need it. @delete s:nmode.exe, @exp @ @s:bare-psl random-argument-to-get-a-new-fork *(load nmode) *(load compiler) *(nmode-initialize) *(setf nmode-auto-start T) *(setf prinlevel 2) *(savesystem "Extended 20-PSL 3.1 NMODE" "S:NMODE.EXE" ()) *(quit) @reset . |
Added psl-1983/3-1/dist/make-psl.ctl version [b5771ccd61].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | @; This file constructs a new PSL containing many useful things, including: @; It creates a new executable file S:EX-PSL.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; @s:bare-psl random-argument-to-get-a-new-fork *(load init-file homedir) *(savesystem "Extended 20-PSL 3.1" "s:psl.exe" '((read-init-file "psl"))) *(quit) @reset . |
Added psl-1983/3-1/dist/make-pslcomp.ctl version [babc532650].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | @; This file constructs a new PSLCOMP. @; @; It creates a new executable file S:PSLCOMP.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:PSLCOMP.EXE. @; @delete s:pslcomp.exe, @expunge @ @s:bare-psl random-argument-to-get-a-new-fork * (load pslcomp-main init-file) * % The following things are loaded because their definitions are useful * % when users compile things: * (load objects common strings pathnames fast-vector nstruct) * (savesystem "Extended 20-PSL Compiler 3.1" * "s:pslcomp.exe" * '((read-init-file "pslcomp"))) * (quit) @reset . |
Added psl-1983/3-1/dist/make-rlisp.ctl version [25dbf0f314].
> > > > > > > | 1 2 3 4 5 6 7 | @S:BARE-PSL.EXE random-argument-to-get-a-new-fork *((lambda (loaddirectories!*) (load compiler rlisp init-file)) '("" "pl:")) *(SaveSystem "Extended 20-PSL 3.1 RLisp" "S:RLISP.EXE" '((read-init-file "rlisp"))) *(quit) @reset . |
Added psl-1983/3-1/dist/make-rlispcomp.ctl version [33d0e66190].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | @; This file constructs a new RLISPCOMP. @; @; It creates a new executable file S:RLISPCOMP.EXE, first deleting any previous @; versions and expunging. When approved, this file should be renamed to @; PSL:RLISPCOMP.EXE. @; @delete s:rlispcomp.exe @expunge s: @s:bare-psl random-argument-to-get-a-new-fork * (load rlisp rlispcomp init-file if-system monsym) * % The following things are loaded because their definitions are useful * % when users compile things: * (load objects common strings pathnames fast-vector nstruct) * (savesystem "Extended-20 RLISP Compiler 3.1" * "s:rlispcomp.exe" * '((read-init-file "rlispcomp")(rlispcomp))) * (quit) @reset . |
Added psl-1983/3-1/dist/make-vdir.ctl version [2e9e7860f8].
> > > > > > > > | 1 2 3 4 5 6 7 8 | ; Command file to produce a directory listing for comparison. @vd psl:,pc:,p20c:,phpc:,pvc:,pdist:,p20dist:,phpdist:,pvdist:,pd:,p20d:,phpd:,pndoc:,pvd:,pe:,pg:,ph:,pk:,p20:,php:,pv:,plap:,plpt:,pm:,pnew:,pn:,pnk:,psup:,p20sup:,phpsup:,pvsup:,pt:,p20t:,phpt:pvt:,pu:,p20u:,phpu:,pvu:,pw:, @out s:vdirectory.dir @no times @no user @no protection @date @ |
Added psl-1983/3-1/dist/minimal-logical-names.cmd version [136efe4c63].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Officially recognized logical names for MINIMAL ; PSL system, in single directory ; EDIT <psl> into <name> as appropriate define psl: <psl> ! Executable files and miscellaneous ;define pc: <psl> ! Compiler sources ;define p20c: <psl> ! 20 Specific Compiler sources ;define pdist: <psl> ! Distribution files ;define pd: <psl> ! Documentation files ;define p20d: <psl> ! 20 Specific Documentation files ;define pndoc: <psl> ! NMODE Documentation files ; not distributed define pe: <psl> ! EMODE support and drivers ;define pg: <psl> ! GLISP source define ph: <psl> ! Help files ;define pk: <psl> ! Kernel Source files ;define p20k: <psl> ! 20 Specific Kernel Sources define pl: <psl> ! LAP files ;define plpt: <psl> ! Printer version of Documentation ;define pn: <psl> ! NMODE editor files define pnb: <psl> ! NMODE editor binaries ;define pnk: <psl> ! PSL Non Kernel source files ;define pt: <psl> ! PSL Test files ;define p20t: <psl> ! PSL 20 Specific Test files ;define pu: <psl> ! Utility program sources ;define p20u: <psl> ! 20 specific Utility files ;define pw: <psl> ! NMODE Window files define pwb: <psl> ! NMODE Window binaries take |
Added psl-1983/3-1/dist/minimal-restore.ctl version [d9b9b1fb2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve subset of ssnames for MINIMAL PSL system ; First edit MINIMAL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories or single directory ; then mount TAPE, def X: @DUMPER *tape X: *density 1600 *files *account system-default *; --- Skip over the logical names etc to do the restore. *skip 1 *restore dsk*:<*>*.*.* PSL:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* PC:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* P20C:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PDIST:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PD:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* P20D:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PNDOC:*.*.* *skip 1 ; --- not distributed anymore --- *restore dsk*:<*>*.*.* pe:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pg:*.*.* *skip 1 *restore dsk*:<*>*.*.* ph:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pk:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20:*.*.* *skip 1 *restore dsk*:<*>*.*.* pl:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* plpt:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pn:*.*.* *skip 1 *restore dsk*:<*>*.*.* pnb:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pnk:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pT:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20T:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pu:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20u:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pw:*.*.* *skip 1 *restore dsk*:<*>*.*.* pwb:*.*.* |
Added psl-1983/3-1/dist/rlisp-save.ctl version [4de7021431].
> > > > > > | 1 2 3 4 5 6 | cd S: PSL:PSL.EXE (LOAD RLISP COMPILER) (SaveSystem "PSL 3.0 Rlisp") (quit) rename PSL-SAVE.EXE PSL:RLISP.EXE |
Added psl-1983/3-1/dist/thor-xfer.ctl version [2a7b900e6b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; File of commands to transfer PSL support from HULK to THOR ;;; Cris Perdue 3-2-83 ;;; The user this job runs under must have a CFTP.CMD file that ;;; logs in as guest and gives the guest password when connected to THOR. cftp thor take p20sup:cftp-thor.cmd ; The blank line after each wildcard send tells CFTP that its ; default destination is OK. ; Using "delete" makes this file liable to fail because if the ; deletion can't be done, a "?" message is put out, stopping the ; batch job. There is enough extra space to make it unnecessary ; right now. ; Delete the .EXE files so there is room in the directory. ; delete psl.exe ; delete bare-psl.exe send p20sup:thor-names.cmd logical-names.cmd expunge send plap:*.b expunge send plap:*.lap expunge send ph:help.tbl help.tbl send ph:*.hlp expunge send pnb:*.b expunge send pwb:*.b expunge send psl:psl.exe psl.exe expunge send psl:bare-psl.exe bare-psl.exe expunge exit reset . submit p20sup:thor-xfer.ctl /after:+168:00 /restartable:yes mail perdue, kendzierski THOR file transfer The weekly PSL file transfer to Thor has completed and next week's job has been submitted. |
Added psl-1983/3-1/doc/20/20-dist.err version [bcccd72ed4].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | @Comment{ErrLog of 20-DIST.MSS.9 by Scribe 3C(1265) on 26 April 1983 at 14:37} Error in text found while processing the manuscript. 20-DIST.MSS.9 line 349: Widow line. Error in text. 20-DIST.MSS.9 line 428: Widow line. Error in text. 20-DIST.MSS.9 line 539: Widow line. |
Added psl-1983/3-1/doc/20/20-dist.lpt version [f0cf6df7e9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Utah Symbolic Computation Group June 1983 Operating Note No. xx Release Notes Extended DEC-20 V3.1 PSL System Extended DEC-20 V3.1 PSL System Extended DEC-20 V3.1 PSL System M. L. Griss and R. R. Kessler Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 20 June 1983 ABSTRACT ABSTRACT ABSTRACT This note describes how to install the extended DEC-20 version of PSL. Work supported in part by the National Science Foundation under Grants MCS80-07034 and MCS81-21750, and by development grants from Boeing, Patil Systems, Lucas Film, Wicat and Hewlett Packard. DEC-20 PSL Release Page 2 1. INTRODUCTION 1. INTRODUCTION 1. INTRODUCTION The attached DUMPER format tape contains most of the files needed to use and maintain the DEC-20 PSL system. At UTAH we have a <PSL> main directory, with a number of sub-directories, each containing a separate class of file, such as common interpreter and compiler sources, DEC-20 sources, VAX sources, 68000 sources, help files, etc. This multi-directory structure enables us to manage the sources for all machines in a reasonable way. Most people running PSL on the DEC-20 will not be interested in all of the files, and certainly will not want to have them all on line. We have therefore created the tape to enable either a multi-directory or single directory model; a set of logical device definitions will be TAKEn by the user (usually inserted in the LOGIN.CMD file). Each separate distribution directory is a separate SAVESET on the attached dumper format tape, and so may be individually restored into a common (<PSL> at Utah) directory, or into appropriate sub-directories (<PSL.*> at Utah). 2. DISCLAIMER 2. DISCLAIMER 2. DISCLAIMER Please be aware that this is a PRELIMINARY release, and some of the files and documentation are not quite complete; we may also have forgotten some files, or sent incorrect versions. We are releasing this preliminary version to you at this time to enhance our collaborative research, and we expect the files to continue to change quite rapidly as the system and distribution is tested. For these reasons please: a. Make a note of ANY problems, concerns, suggestions you have, and send this information to us to aid in improving the system and this distribution mechanism. b. Please do not REDISTRIBUTE any of these files, listings or machine readable form to anyone, and try to restrict access to a small group of users. 3. CONTENTS OF THE TAPE 3. CONTENTS OF THE TAPE 3. CONTENTS OF THE TAPE Attached to this note is a copy of the DUMPER run that created the tape, indicating the savesets, the file names, and sizes needed to restore each saveset. DEC-20 PSL Release Page 3 The following lists each of the savesets, their logical names, sizes and whether or not it is included in the saveset: SSname Pages Min <Utah File Name> Logical Name RESTORE-PSL 10 NO ---- ---- Files necessary to restore the PSL system. PSL 1100 YES <psl> psl: The executable files (PSL.EXE and RLISP.EXE), this 20-DIST.DOC file, .CMD files to define appropriate logical names and a sample message to announce PSL availability. Also, included are a number of news files announcing new features and changes, some files associated with the NMODE editor and a version of psl (PSLCOMP.EXE) that will compile the argument on the execution line. COMP 125 NO <psl.comp> pc: Common compiler, LAP, FASL sources. 20COMP 55 NO <psl.comp.20> p20c: DEC-20 specific compiler, LAP and FASL sources. DIST 25 NO <psl.dist> pdist: Files as an aid to the installer. DOC 110 NO <psl.doc> pdoc: Miscellaneous documentation files, including random notes on new features. 20DOC 25 NO <psl.doc.20> p20d: Documentation files that are 20 specific. DOCNMODE 590 NO <psl.doc.nmode> pndoc: NMODE documentation files. GLISP 330 NO <psl.glisp> pg: An object oriented LISP. HELP 100 YES <psl.help> ph: A set of *.HLP files, describing major modules. KERNEL 225 NO <psl.kernel> pk: Machine Independent kernel sources. P20 560 NO <psl.kernel.20> p20: DecSystem 20 dependent kernel sources. LAP 500 YES <psl.lap> pl: Mostly binary FASL (*.B) files, with some LISP DEC-20 PSL Release Page 4 files (*.LAP) for loading multiple .B files of loadable (optional) modules. LPT 430 NO <psl.lpt> plpt: The PSL manual in printable form (has overprinting and underlining), as SCRIBE .LPT files. NMODE 270 NO <psl.nmode> pn: The NMODE text editor sources, which is a newer version of EMODE developed at HP Research Laboratories. NMODEBIN 230 YES <psl.nmode.binary> pnb: The binary files associated with NMODE. NONKERNEL 5 NO <psl.nonkernel> pnk: The sources that are not in the kernel, but are kernel related. PT 215 NO <psl.tests> pt: A set of timing and test files. P20T 500 NO <psl.tests.20> p20t: DecSystem 20 specific test files. UTIL 575 NO <psl.util> pu: Sources for most utilities, useful as examples of PSL and RLISP code, and for customization. P20U 60 NO <psl.util.20> p20u: DecSystem 20 specific utilities. WINDOWS 75 NO <psl.windows> pw: The window support functions used by NMODE. WINBIN 30 YES <psl.windows.binary> pwb: The binaries associated with the window support. 4. INSTALLING PSL 4. INSTALLING PSL 4. INSTALLING PSL When installing the PSL system, you have two options for the directory structure. You may utilize a single directory for all of the file, or you may create a directory tree using subdirectories. The Utah group utilizes a directory tree structure and recommends its use when installing a "full" system (that includes all of the sources and the capability of rebuilding any part of the system). However, if only a minimal system is desired, it can be accomplished using a single directory. DEC-20 PSL Release Page 5 4.1. Retrieve Control Files 4.1. Retrieve Control Files 4.1. Retrieve Control Files Whether building a single directory system or multiple directory system, logical name definition files and file restore control files must be first retrieved. Therefore, first mount the dumper tape, at 1600 BPI (verify that there is no write ring in the tape). Then, define X: as the appropriate tape device, MTAn:, or use MOUNT if running a labeled tape system: @DEFINE X: MTAn: or @MOUNT TAPE X: @ASSIGN X: Restore from the first saveset (PSL) the .cmd and .ctl files @DUMPER *tape X: *density 1600 *files *account system-default *restore <*>*.*.* *.*.* These files will be restored to your connected directory, and should be copied to your main PSL directory after their creation. 4.2. Create a single subdirectory 4.2. Create a single subdirectory 4.2. Create a single subdirectory Create a directory, call it <name> and define a logical device PSL: (a size of about 2400 should be sufficient). Any <name> will do, since the logical device name PSL: will be used. @DEF PSL: <name> Copy the minimal-* restored files to PSL @COPY minimal-*.* PSL:*.* Now edit the file PSL:minimal-logical-names.cmd to reflect the your choice of <name>. DEC-20 PSL Release Page 6 Also put @TAKE <name>minimal-logical-names.cmd in your LOGIN.CMD. Finally, restore the minimal system by DOing the minimal- restore.ctl file: @DO MINIMAL-RESTORE @DEASSIGN X: or @DISMOUNT X: 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM If you plan to do much source modification, or a significant number of rebuilds, or maintain a compatible multiple-machine version of PSL, or attempt retargeting of PSL, a multiple- directory structure such as that at UTAH should be built. The file FULL-LOGICAL-NAMES.CMD, retrieved above should be used as a guide to building the sub-directories. We currently use 18 sub-directories for the Common Sources and DEC-20 specific sources, and have at least an extra three for each new machine. Consult the 20-DIST.LOG file supplied with the PSL tape as a guide for the amount of space required for each sub-directory. The current set of directories for DEC-20 PSL, the logical names that we use, and rough space estimate follows. Build the sub-directories with a somewhat larger working space allocation. Now edit the file PSL:full-logical-names.cmd to reflect the your choice of <name> along with the create-directories.ctl file. Also put @TAKE <name>full-logical-names.cmd in your LOGIN.CMD. 4.4. Build Sub-Directories 4.4. Build Sub-Directories 4.4. Build Sub-Directories Then use the system command, BUILD, to build each sub-directory with the name Pxxx:, as follows. Assistance from the system manager may be required to permit the creation of sub-directories, and the appropriate choice of sub-directory parameters: DEC-20 PSL Release Page 7 @BUILD Pxxx: @@PERM nnnn ! choose appropriate size @@WORK wwww ! nnnn+extra @@FILES-ONLY ! Can't login @@GEN 2 ! Retain 1 previous version @@PROTECTION 777700 ! Give group access @@DEFAULT 777700 @ ! that are permitted access To make this process easier, we have created a control file: CREATE-DIRECTORIES.CTL that will build all of the subdirectories with sizes such that restoration of the files will succeed. Therefore, after editing the full-logical-names.cmd file above to reflect the correct logical names, simply DO the CTL file (some systems use MIC instead of DO, so that may be substituted in the following examples) : @DO CREATE-DIRECTORIES.CTL This will create all of the necessary directories. Finally, restore the full system by DOing the full-restore.ctl file: @DO FULL-RESTORE @DEASSIGN X: or @DISMOUNT X: 4.5. Announce the System 4.5. Announce the System 4.5. Announce the System Send out a Message to all those interested in using PSL. The file BBOARD.MSG is a suggested start. Edit as you see fit, but please REMIND people not to re-distribute the PSL system and sources. You may also want to set the directory protection to 775200 and limit access only to those that you feel should have access at this time. DEC-20 PSL Release Page 8 4.6. Summary of Restoration Process 4.6. Summary of Restoration Process 4.6. Summary of Restoration Process In summary, first retrieve the cmd and ctl files from the first saveset on the DUMPER tape. Then choose a single or multiple directory system and edit the appropriate logical name file to reflect the directory name(s). If creating a multiple directory system use the create-directories.ctl control file to build each directory. Then run the appropriate file retrieval control file. Finally, announce the system to any interested users. 5. REBUILDING LOADABLE MODULES 5. REBUILDING LOADABLE MODULES 5. REBUILDING LOADABLE MODULES Most of the utilities, and many of the more experimental parts of the system are kept as binary FASL files (with extensions .b) on the PL: directory. NMODE is currently the only major sub-system that has its own set of sub-directories. In some cases (usually large sub-systems, or sub-systems that share modules) there are a number of .B files, and a .LAP file that loads each .B file in turn. The PSL LOAD function will look first for a .B file, then a .LAP file first on the user directory, then on PL: (both this "search" path and the order of extensions can be changed). In order to ease the task of rebuilding and modifying the .B files, we have a small utility, BUILD. To use BUILD for a module you call xxxx, prepare a file called xxxx.BUILD, which has RLISP syntax commands for loading the appropriate source files. The file can also have various CompileTime options, including the loading of various .B files to set up the correct compilation environment. Then run PSL:RLISP, LOAD BUILD; and finally enter BUILD 'xxxx; this will do a FASLOUT to "PL:xxxx", input the xxxx.BUILD file, and finally close the FASL file. The target file "PL:xxxx" is constructed using the variable "BuildFileFormat!*", initialized in the file PU:Build.Red . For example, consider the contents of PU:Gsort.Build: CompileTime load Syslisp; in "gsort.red"$ Note that the SYSLISP module is required, since some of the DEC-20 PSL Release Page 9 fast sorting functions in GSORT are written in SYSLISP mode. GSORT is then rebuilt by the sequence: PSL:RLISP LOAD BUILD; BUILD 'GSORT; QUIT; This is such a common sequence that a MIC file (MIC is a parameterized DO facility) PU:BUILD.MIC is provided, and is used by passing the module name to MIC, after connecting to PU: @mic BUILD GSORT is all that is required. 6. REBUILDING THE INTERPRETER 6. REBUILDING THE INTERPRETER 6. REBUILDING THE INTERPRETER A running `rlisp' is required to rebuild the basic interpreter, since the entire system is written in itself. The kernel modules, rather than being compiled to FASL files, are compiled _____ ____ to assembly code (MACRO) and linked using the system loader LINK. ____ _____ _____ ___ The command file P20C:DEC20-cross.CTL is executed to produce the _ _____ _____ cross compiler, S:DEC20-cross (S: should be set to an appropriate scratch directory). The modules in the kernel are represented by ___ _____ __ ______ __ __ the files P20:*.build. There is a program PU:kernel.sl or __ ______ _ PL:kernel.b which generates command files for building the kernel ___ __ ______ ___ __ when parameterized for Tops-20 by P20:20-kernel-gen.sl. The specific modules which are in the kernel are only listed in this ______ file, in the call to the function kernel. This generates a file ____ ___ ____ _____ xxxx.CTL for each xxxx.build. 6.1. Complete Kernel Rebuild 6.1. Complete Kernel Rebuild 6.1. Complete Kernel Rebuild A complete rebuild is accomplished by the following steps. At Utah we use a <scratch> directory for some intermediate files. Define S: to be this directory or some other appropriate location that can be deleted when done. Below we use @SUBMIT xxxx.CTL to run batch jobs; on some systems, @DO xxxx.CTL can be used instead, or on others, @MIC xxxx.CTL may be used. Begin by defining S: as <scratch> or other scratch directory: DEC-20 PSL Release Page 10 @DEFINE S: <scratch> Now connect to <psl.20-comp> and rebuild DEC20-CROSS.EXE: @CONN P20C: @SUBMIT DEC20-CROSS.CTL Copy the <psl.comp>BARE-PSL.SYM to 20.SYM, and regenerate the appropriate .CTL files. This saves the old 20.SYM as PREVIOUS-20.SYM: @CONN P20: @SUBMIT P20:FRESH-KERNEL.CTL Rebuild each module (xxxx) in turn, using its xxxx.CTL. This creates xxxx.MAC and Dxxxx.MAC files, and assembles each to make xxxx.REL and Dxxxx.REL. The entire set is submitted with the file ALL-KERNEL.CTL, which submits each file in turn. (Note that these must be done sequentially, not simultaneously. If you have more than one batch stream, make sure that these are run one at a time): @SUBMIT ALL-KERNEL.CTL Build the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: @SUBMIT P20:MAIN.CTL Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @SUBMIT P20:PSL-LINK.CTL Execute and save as PSL.EXE, reading appropriate xxxx.INIT files (note, each site usually customizes the PSL environment to suit their needs, therefore we recommend that you create your own DEC-20 PSL Release Page 11 version of Make-psl.ctl to perform this task). @SUBMIT PDIST:MAKE-PSL.CTL Finally, run MAKE-RLISP.CTL as needed: @SUBMIT PDIST:MAKE-RLISP.CTL Rlisp.exe and Psl.exe will be saved on the <PSL> directory. You now may want to delete any xxx.log files that where created. You may also remake, RLISPCOMP, PSLCOMP and NMODE, in a similar manner. @DEL P20:*.LOG @DEL P20C:*.LOG 6.2. Partial or Incremental Kernel Rebuild 6.2. Partial or Incremental Kernel Rebuild 6.2. Partial or Incremental Kernel Rebuild Often, only a single kernel file needs to be changed, and a complete rebuild is not needed. The PSL kernel building process permits a (semi-)independent rebuilding of modules, by maintaining the 20.SYM file to record Identifier Numbers, etc. The 20.SYM file from the recent full-rebuild, and xxxx.INIT files are required, as are the "xxxx.REL" and "Dxxxx.REL". The partial rebuild will replace the "mmmm.REL", "Dmmmm.REL" and "mmmm.INIT" files, modify "20.SYM", and then rebuild the MAIN module. Assuming that a recent full rebuild has been done, a partial rebuild of module "mmmm", is accomplished by the following steps. As above, S: is required for "Scratch" space. Define S: as <scratch> or other scratch directory: @DEFINE S: <scratch> Rebuild DEC20-CROSS.EXE, if needed: @SUBMIT P20C:DEC20-CROSS.CTL DEC-20 PSL Release Page 12 Rebuild the module (mmmm), using its mmmm.CTL. This creates mmmm.MAC and Dmmmm.MAC files, and assembled each to make mmmm.REL and Dmmmm.REL. See the file ALL-KERNEL.CTL for current modules. @SUBMIT P20:mmmm.CTL Other modules can be done after this Rebuild the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: (This step can be omitted if 20.SYM has not been changed by the incremental recompilation.) @SUBMIT P20:MAIN.CTL Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @SUBMIT P20:PSL-LINK.CTL Execute and save as PSL.EXE, reading appropriate xxxx.INIT files: @SUBMIT PDIST:MAKE-PSL.CTL Finally, run MAKE-RLISP as needed: @SUBMIT PDIST:MAKE-RLISP.CTL You may also remake, RLISPCOMP, PSLCOMP and NMODE, in a similar manner. Note that 20.SYM may be changed slightly to reflect any new symbols encountered, and certain generated symbols. Occasionally, repeated building of certain modules can cause 20.SYM to grow, and then a full rebuild may be required. DEC-20 PSL Release Page 13 6.3. Rebuilding RLISP.EXE from PSL.EXE 6.3. Rebuilding RLISP.EXE from PSL.EXE 6.3. Rebuilding RLISP.EXE from PSL.EXE The PSL executable file, PSL.EXE, is a fairly bare system, and is usually extended by loading appropriate utilities, and then saving this as a new executable. We have provided RLISP.EXE, which includes the compiler, and the RLISP parser. RLISP.EXE is built from PSL.EXE by the following commands: @TAKE PSL:minimal-logical-names.cmd @PSL:PSL.EXE (LOAD COMPILER RLISP INIT-FILE) % Also LOAD any other modules that % should be in your "standard" system (SAVESYSTEM "PSL 3.1 Rlisp" "PSL:rlisp.exe" '((Read-init-file "rlisp"))) % The string is the Welcome Message, the save file % name and the startup expression to read rlisp.init. (QUIT) We have provided a command file, PDIST:MAKE-RLISP.CTL for this purpose. Edit it to reflect any modules that local usage desires in the basic system (PRLISP, USEFUL, etc. are common choices). In a similar fashion, a customized PSL.EXE could be maintained instead of the "bare" version we provide. In order to avoid destroying PSL entirely, we suggest that you maintain a copy of the supplied PSL.EXE as BARE-PSL.EXE, and customize your PSL.EXE from it. 7. RELATIONSHIP TO PSL 3.0 7. RELATIONSHIP TO PSL 3.0 7. RELATIONSHIP TO PSL 3.0 Even though this is the first version of PSL for the DecSystem-20 that utilizes extended addressing, it is identical to the PSL V3.1 for the non-extended 20. As a new PSL version 3.1, it is a complete release, and totally replaces the previous PSL 3.0 that underwent limited distribution. The files __ ___ ___ ___ __ ____ ___ pd:bug-fix.log and pd:bugs.txt record many of the changes and bug fixes that occurred since version 3.0. 8. FUTURE UPDATES 8. FUTURE UPDATES 8. FUTURE UPDATES It is currently envisioned that future updates will still be complete releases. It is therefore suggested that you DEC-20 PSL Release Page 14 a. Retain this distribution tape in case you may have to compare files. b. Do not make any changes on these distributed directories. If you must make your own bug fixes, it is suggested that you put the changed files on some ____ other directories, such as pnew:. They can then be compared with any new files sent out in subsequent releases. DEC-20 PSL Release Page i Table of Contents Table of Contents Table of Contents 1. INTRODUCTION 2 2. DISCLAIMER 2 3. CONTENTS OF THE TAPE 2 4. INSTALLING PSL 4 4.1. Retrieve Control Files 5 4.2. Create a single subdirectory 5 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 6 4.4. Build Sub-Directories 6 4.5. Announce the System 7 4.6. Summary of Restoration Process 8 5. REBUILDING LOADABLE MODULES 8 6. REBUILDING THE INTERPRETER 9 6.1. Complete Kernel Rebuild 9 6.2. Partial or Incremental Kernel Rebuild 11 6.3. Rebuilding RLISP.EXE from PSL.EXE 13 7. RELATIONSHIP TO PSL 3.0 13 8. FUTURE UPDATES 13 |
Added psl-1983/3-1/doc/20/20-dist.mss version [2955ba4df1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(article) @Case(Draft, 1 <@device(Omnitech)>, else <@device(LPT)> ) @Style(WidowAction=warn) @Style(Hyphenation Off) @comment(on) @Style(DoubleSided no) @comment(yes) @style(Spacing 1) @use(Bibliography "<griss.docs>mtlisp.bib") @modify(enumerate,numbered=<@a. @,@i. >, spread 1) @modify(itemize,spread 1) @pageheading(Left "Utah Symbolic Computation Group", Right "June 1983", Line "Operating Note No. xx" ) @set(page=1) @newpage() @Begin(TitlePAge) @begin(TitleBox) @center[Release Notes @b(Extended DEC-20 V3.1 PSL System) M. L. Griss and R. R. Kessler Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 @value(date)] @end(TitleBox) @begin(abstract) This note describes how to install the extended DEC-20 version of PSL. @end(abstract) @begin(ResearchCredit) Work supported in part by the National Science Foundation under Grants MCS80-07034 and MCS81-21750, and by development grants from Boeing, Patil Systems, Lucas Film, Wicat and Hewlett Packard. @end(ResearchCredit) @end(TitlePage) @pageheading(Left "DEC-20 PSL Release", Right "Page @Value(Page)" ) @newpage() @section(INTRODUCTION) The attached DUMPER format tape contains most of the files needed to use and maintain the DEC-20 PSL system. At UTAH we have a <PSL> main directory, with a number of sub-directories, each containing a separate class of file, such as common interpreter and compiler sources, DEC-20 sources, VAX sources, 68000 sources, help files, etc. This multi-directory structure enables us to manage the sources for all machines in a reasonable way. Most people running PSL on the DEC-20 will not be interested in all of the files, and certainly will not want to have them all on line. We have therefore created the tape to enable either a multi-directory or single directory model; a set of logical device definitions will be TAKEn by the user (usually inserted in the LOGIN.CMD file). Each separate distribution directory is a separate SAVESET on the attached dumper format tape, and so may be individually restored into a common (<PSL> at Utah) directory, or into appropriate sub-directories (<PSL.*> at Utah). @section(DISCLAIMER) Please be aware that this is a PRELIMINARY release, and some of the files and documentation are not quite complete; we may also have forgotten some files, or sent incorrect versions. We are releasing this preliminary version to you at this time to enhance our collaborative research, and we expect the files to continue to change quite rapidly as the system and distribution is tested. For these reasons please: @begin(enumerate) Make a note of ANY problems, concerns, suggestions you have, and send this information to us to aid in improving the system and this distribution mechanism. Please do not REDISTRIBUTE any of these files, listings or machine readable form to anyone, and try to restrict access to a small group of users. @end(enumerate) @section(CONTENTS OF THE TAPE) Attached to this note is a copy of the DUMPER run that created the tape, indicating the savesets, the file names, and sizes needed to restore each saveset. The following lists each of the savesets, their logical names, sizes and whether or not it is included in the saveset: @begin(Description, spread 1) SSname@ @ Pages@ Min@ <Utah@ File@ Name>@ Logical@ Name RESTORE-PSL@ 10@ NO@ @ @ ----@ @ @ @ @ @ @ @ @ @ @ @ ---- @\Files necessary to restore the PSL system. PSL@ @ @ @ @ 1100@ @ YES@ @ <psl>@ @ @ @ @ @ @ @ @ @ @ @ psl: @\The executable files (PSL.EXE and RLISP.EXE), this 20-DIST.DOC file, .CMD files to define appropriate logical names and a sample message to announce PSL availability. Also, included are a number of news files announcing new features and changes, some files associated with the NMODE editor and a version of psl (PSLCOMP.EXE) that will compile the argument on the execution line. COMP@ @ @ @ @ 125@ @ NO@ @ @ <psl.comp>@ @ @ @ @ @ @ pc: @\Common compiler, LAP, FASL sources. 20COMP@ @ @ @ 55@ @ NO@ @ @ <psl.comp.20>@ @ @ @ p20c: @\DEC-20 specific compiler, LAP and FASL sources. DIST@ @ @ @ @ @ 25@ @ NO@ @ @ <psl.dist>@ @ @ @ @ @ @ pdist: @\Files as an aid to the installer. DOC@ @ @ @ @ @ 110@ @ NO@ @ @ <psl.doc>@ @ @ @ @ @ @ @ pdoc: @\Miscellaneous documentation files, including random notes on new features. 20DOC@ @ @ @ @ 25@ @ NO@ @ @ <psl.doc.20>@ @ @ @ @ p20d: @\Documentation files that are 20 specific. DOCNMODE@ 590@ @ NO@ @ @ <psl.doc.nmode>@ @ pndoc: @\NMODE documentation files. GLISP@ @ @ @ 330@ @ NO@ @ @ <psl.glisp>@ @ @ @ @ @ pg: @\An object oriented LISP. HELP@ @ @ @ @ 100@ @ YES@ @ <psl.help>@ @ @ @ @ @ @ ph: @\A set of *.HLP files, describing major modules. KERNEL@ @ @ 225@ @ NO@ @ @ <psl.kernel>@ @ @ @ @ pk: @\Machine Independent kernel sources. P20@ @ @ @ @ @ 560@ @ NO@ @ @ <psl.kernel.20>@ @ p20: @\DecSystem 20 dependent kernel sources. LAP@ @ @ @ @ @ 500@ @ YES@ @ <psl.lap>@ @ @ @ @ @ @ @ pl: @\Mostly binary FASL (*.B) files, with some LISP files (*.LAP) for loading multiple .B files of loadable (optional) modules. LPT@ @ @ @ @ @ 430@ @ NO@ @ @ <psl.lpt>@ @ @ @ @ @ @ @ plpt: @\The PSL manual in printable form (has overprinting and underlining), as SCRIBE .LPT files. NMODE@ @ @ @ 270@ @ NO@ @ @ <psl.nmode>@ @ @ @ @ @ pn: @\The NMODE text editor sources, which is a newer version of EMODE developed at HP Research Laboratories. NMODEBIN@ 230@ @ YES@ @ <psl.nmode.binary>@ pnb: @\The binary files associated with NMODE. NONKERNEL@ @ 5@ @ NO@ @ @ <psl.nonkernel>@ @ pnk: @\The sources that are not in the kernel, but are kernel related. PT@ @ @ @ @ @ @ 215@ @ NO@ @ @ <psl.tests>@ @ @ @ @ @ pt: @\A set of timing and test files. P20T@ @ @ @ @ 500@ @ NO@ @ @ <psl.tests.20>@ @ @ p20t: @\DecSystem 20 specific test files. UTIL@ @ @ @ @ 575@ @ NO@ @ @ <psl.util>@ @ @ @ @ @ @ pu: @\Sources for most utilities, useful as examples of PSL and RLISP code, and for customization. P20U@ @ @ @ @ @ 60@ @ NO@ @ @ <psl.util.20>@ @ @ @ p20u: @\DecSystem 20 specific utilities. WINDOWS@ @ @ 75@ @ NO@ @ @ <psl.windows>@ @ @ @ pw: @\The window support functions used by NMODE. WINBIN@ @ @ @ 30@ @ YES@ @ <psl.windows.binary>@ pwb: @\The binaries associated with the window support. @end(description) @section(INSTALLING PSL) When installing the PSL system, you have two options for the directory structure. You may utilize a single directory for all of the file, or you may create a directory tree using subdirectories. The Utah group utilizes a directory tree structure and recommends its use when installing a "full" system (that includes all of the sources and the capability of rebuilding any part of the system). However, if only a minimal system is desired, it can be accomplished using a single directory. @subsection(Retrieve Control Files) Whether building a single directory system or multiple directory system, logical name definition files and file restore control files must be first retrieved. Therefore, first mount the dumper tape, at 1600 BPI (verify that there is no write ring in the tape). Then, define X: as the appropriate tape device, MTAn:, or use MOUNT if running a labeled tape system: @verbatim[ @@DEFINE X: MTAn: or @@MOUNT TAPE X: @@ASSIGN X: ] Restore from the first saveset (PSL) the .cmd and .ctl files @begin(verbatim) @@DUMPER *tape X: *density 1600 *files *account system-default *restore <*>*.*.* *.*.* @end(verbatim) These files will be restored to your connected directory, and should be copied to your main PSL directory after their creation. @subsection(Create a single subdirectory) Create a directory, call it <name> and define a logical device PSL: (a size of about 2400 should be sufficient). Any <name> will do, since the logical device name PSL: will be used. @begin(verbatim) @@DEF PSL: <name> @end(verbatim) Copy the minimal-* restored files to PSL @begin(verbatim) @@COPY minimal-*.* PSL:*.* @end(verbatim) Now edit the file PSL:minimal-logical-names.cmd to reflect the your choice of <name>. Also put @@TAKE <name>minimal-logical-names.cmd in your LOGIN.CMD. Finally, restore the minimal system by DOing the minimal-restore.ctl file: @begin(verbatim) @@DO MINIMAL-RESTORE @@DEASSIGN X: or @@DISMOUNT X: @end(verbatim) @subsection(A MULTIPLE SUB-DIRECTORY SYSTEM) If you plan to do much source modification, or a significant number of rebuilds, or maintain a compatible multiple-machine version of PSL, or attempt retargeting of PSL, a multiple-directory structure such as that at UTAH should be built. The file FULL-LOGICAL-NAMES.CMD, retrieved above should be used as a guide to building the sub-directories. We currently use 18 sub-directories for the Common Sources and DEC-20 specific sources, and have at least an extra three for each new machine. Consult the 20-DIST.LOG file supplied with the PSL tape as a guide for the amount of space required for each sub-directory. The current set of directories for DEC-20 PSL, the logical names that we use, and rough space estimate follows. Build the sub-directories with a somewhat larger working space allocation. Now edit the file PSL:full-logical-names.cmd to reflect the your choice of <name> along with the create-directories.ctl file. Also put @@TAKE <name>full-logical-names.cmd in your LOGIN.CMD. @subsection(Build Sub-Directories) Then use the system command, BUILD, to build each sub-directory with the name Pxxx:, as follows. Assistance from the system manager may be required to permit the creation of sub-directories, and the appropriate choice of sub-directory parameters: @begin(ProgramExample) @@BUILD Pxxx: @@@@PERM nnnn ! choose appropriate size @@@@WORK wwww ! nnnn+extra @@@@FILES-ONLY ! Can't login @@@@GEN 2 ! Retain 1 previous version @@@@PROTECTION 777700 ! Give group access @@@@DEFAULT 777700 @@ ! that are permitted access @end(ProgramExample) To make this process easier, we have created a control file: CREATE-DIRECTORIES.CTL that will build all of the subdirectories with sizes such that restoration of the files will succeed. Therefore, after editing the full-logical-names.cmd file above to reflect the correct logical names, simply DO the CTL file (some systems use MIC instead of DO, so that may be substituted in the following examples) : @begin(verbatim) @@DO CREATE-DIRECTORIES.CTL @end(verbatim) This will create all of the necessary directories. Finally, restore the full system by DOing the full-restore.ctl file: @begin(verbatim) @@DO FULL-RESTORE @@DEASSIGN X: or @@DISMOUNT X: @end(verbatim) @subsection(Announce the System) Send out a Message to all those interested in using PSL. The file BBOARD.MSG is a suggested start. Edit as you see fit, but please REMIND people not to re-distribute the PSL system and sources. You may also want to set the directory protection to 775200 and limit access only to those that you feel should have access at this time. @subsection(Summary of Restoration Process) In summary, first retrieve the cmd and ctl files from the first saveset on the DUMPER tape. Then choose a single or multiple directory system and edit the appropriate logical name file to reflect the directory name(s). If creating a multiple directory system use the create-directories.ctl control file to build each directory. Then run the appropriate file retrieval control file. Finally, announce the system to any interested users. @section(REBUILDING LOADABLE MODULES) Most of the utilities, and many of the more experimental parts of the system are kept as binary FASL files (with extensions .b) on the PL: directory. NMODE is currently the only major sub-system that has its own set of sub-directories. In some cases (usually large sub-systems, or sub-systems that share modules) there are a number of .B files, and a .LAP file that loads each .B file in turn. The PSL LOAD function will look first for a .B file, then a .LAP file first on the user directory, then on PL: (both this "search" path and the order of extensions can be changed). In order to ease the task of rebuilding and modifying the .B files, we have a small utility, BUILD. To use BUILD for a module you call xxxx, prepare a file called xxxx.BUILD, which has RLISP syntax commands for loading the appropriate source files. The file can also have various CompileTime options, including the loading of various .B files to set up the correct compilation environment. Then run PSL:RLISP, LOAD BUILD; and finally enter BUILD 'xxxx; this will do a FASLOUT to "PL:xxxx", input the xxxx.BUILD file, and finally close the FASL file. The target file "PL:xxxx" is constructed using the variable "BuildFileFormat!*", initialized in the file PU:Build.Red . For example, consider the contents of PU:Gsort.Build: @ProgramExample[ CompileTime load Syslisp; in "gsort.red"$] Note that the SYSLISP module is required, since some of the fast sorting functions in GSORT are written in SYSLISP mode. GSORT is then rebuilt by the sequence: @ProgramExample[ PSL:RLISP LOAD BUILD; BUILD 'GSORT; QUIT;] This is such a common sequence that a MIC file (MIC is a parameterized DO facility) PU:BUILD.MIC is provided, and is used by passing the module name to MIC, after connecting to PU: @ProgramExample[ @@mic BUILD GSORT ] is all that is required. @Section(REBUILDING THE INTERPRETER) A running `rlisp' is required to rebuild the basic interpreter, since the entire system is written in itself. The kernel modules, rather than being compiled to FASL files, are compiled to assembly code (@i(MACRO)) and linked using the system loader @i(LINK). The command file @i{P20C:DEC20-cross.CTL} is executed to produce the cross compiler, @i{S:DEC20-cross} (S: should be set to an appropriate scratch directory). The modules in the kernel are represented by the files @I{P20:*.build}. There is a program @I{PU:kernel.sl or PL:kernel.b} which generates command files for building the kernel when parameterized for Tops-20 by @I{P20:20-kernel-gen.sl}. The specific modules which are in the kernel are only listed in this file, in the call to the function @I{kernel}. This generates a file @I{xxxx.CTL} for each @I{xxxx.build}. @subsection(Complete Kernel Rebuild) A complete rebuild is accomplished by the following steps. At Utah we use a <scratch> directory for some intermediate files. Define S: to be this directory or some other appropriate location that can be deleted when done. Below we use @@SUBMIT xxxx.CTL to run batch jobs; on some systems, @@DO xxxx.CTL can be used instead, or on others, @@MIC xxxx.CTL may be used. Begin by defining S: as <scratch> or other scratch directory: @verbatim[ @@DEFINE S: <scratch>] Now connect to <psl.20-comp> and rebuild DEC20-CROSS.EXE: @verbatim[ @@CONN P20C:] @verbatim[ @@SUBMIT DEC20-CROSS.CTL] Copy the <psl.comp>BARE-PSL.SYM to 20.SYM, and regenerate the appropriate .CTL files. This saves the old 20.SYM as PREVIOUS-20.SYM: @verbatim[ @@CONN P20:] @verbatim[ @@SUBMIT P20:FRESH-KERNEL.CTL] Rebuild each module (xxxx) in turn, using its xxxx.CTL. This creates xxxx.MAC and Dxxxx.MAC files, and assembles each to make xxxx.REL and Dxxxx.REL. The entire set is submitted with the file ALL-KERNEL.CTL, which submits each file in turn. (Note that these must be done sequentially, not simultaneously. If you have more than one batch stream, make sure that these are run one at a time): @verbatim[ @@SUBMIT ALL-KERNEL.CTL] Build the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: @verbatim[ @@SUBMIT P20:MAIN.CTL] Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @verbatim[ @@SUBMIT P20:PSL-LINK.CTL] Execute and save as PSL.EXE, reading appropriate xxxx.INIT files (note, each site usually customizes the PSL environment to suit their needs, therefore we recommend that you create your own version of Make-psl.ctl to perform this task). @verbatim[ @@SUBMIT PDIST:MAKE-PSL.CTL] Finally, run MAKE-RLISP.CTL as needed: @verbatim[ @@SUBMIT PDIST:MAKE-RLISP.CTL] Rlisp.exe and Psl.exe will be saved on the <PSL> directory. You now may want to delete any xxx.log files that where created. You may also remake, RLISPCOMP, PSLCOMP and NMODE, in a similar manner. @Verbatim[ @@DEL P20:*.LOG @@DEL P20C:*.LOG] @subsection(Partial or Incremental Kernel Rebuild) Often, only a single kernel file needs to be changed, and a complete rebuild is not needed. The PSL kernel building process permits a (semi-)independent rebuilding of modules, by maintaining the 20.SYM file to record Identifier Numbers, etc. The 20.SYM file from the recent full-rebuild, and xxxx.INIT files are required, as are the "xxxx.REL" and "Dxxxx.REL". The partial rebuild will replace the "mmmm.REL", "Dmmmm.REL" and "mmmm.INIT" files, modify "20.SYM", and then rebuild the MAIN module. Assuming that a recent full rebuild has been done, a partial rebuild of module "mmmm", is accomplished by the following steps. As above, S: is required for "Scratch" space. Define S: as <scratch> or other scratch directory: @verbatim[ @@DEFINE S: <scratch> ] Rebuild DEC20-CROSS.EXE, if needed: @verbatim[ @@SUBMIT P20C:DEC20-CROSS.CTL] Rebuild the module (mmmm), using its mmmm.CTL. This creates mmmm.MAC and Dmmmm.MAC files, and assembled each to make mmmm.REL and Dmmmm.REL. See the file ALL-KERNEL.CTL for current modules. @verbatim[ @@SUBMIT P20:mmmm.CTL Other modules can be done after this] Rebuild the main module, which converts the accumulated 20.SYM into heap and symbol-table initialization: (This step can be omitted if 20.SYM has not been changed by the incremental recompilation.) @verbatim[ @@SUBMIT P20:MAIN.CTL] Finally LINK the xxxx.REL and Dxxxx.REL files to produce S:BARE-PSL.EXE: @verbatim[ @@SUBMIT P20:PSL-LINK.CTL] Execute and save as PSL.EXE, reading appropriate xxxx.INIT files: @verbatim[ @@SUBMIT PDIST:MAKE-PSL.CTL] Finally, run MAKE-RLISP as needed: @verbatim[ @@SUBMIT PDIST:MAKE-RLISP.CTL] You may also remake, RLISPCOMP, PSLCOMP and NMODE, in a similar manner. Note that 20.SYM may be changed slightly to reflect any new symbols encountered, and certain generated symbols. Occasionally, repeated building of certain modules can cause 20.SYM to grow, and then a full rebuild may be required. @subsection(Rebuilding RLISP.EXE from PSL.EXE) The PSL executable file, PSL.EXE, is a fairly bare system, and is usually extended by loading appropriate utilities, and then saving this as a new executable. We have provided RLISP.EXE, which includes the compiler, and the RLISP parser. RLISP.EXE is built from PSL.EXE by the following commands: @begin(verbatim) @@TAKE PSL:minimal-logical-names.cmd @@PSL:PSL.EXE (LOAD COMPILER RLISP INIT-FILE) % Also LOAD any other modules that % should be in your "standard" system (SAVESYSTEM "PSL 3.1 Rlisp" "PSL:rlisp.exe" '((Read-init-file "rlisp"))) % The string is the Welcome Message, the save file % name and the startup expression to read rlisp.init. (QUIT) @end(verbatim) We have provided a command file, PDIST:MAKE-RLISP.CTL for this purpose. Edit it to reflect any modules that local usage desires in the basic system (PRLISP, USEFUL, etc. are common choices). In a similar fashion, a customized PSL.EXE could be maintained instead of the "bare" version we provide. In order to avoid destroying PSL entirely, we suggest that you maintain a copy of the supplied PSL.EXE as BARE-PSL.EXE, and customize your PSL.EXE from it. @section(RELATIONSHIP TO PSL 3.0) Even though this is the first version of PSL for the DecSystem-20 that utilizes extended addressing, it is identical to the PSL V3.1 for the non-extended 20. As a new PSL version 3.1, it is a complete release, and totally replaces the previous PSL 3.0 that underwent limited distribution. The files @i(pd:bug-fix.log) and @i(pd:bugs.txt) record many of the changes and bug fixes that occurred since version 3.0. @section(FUTURE UPDATES) It is currently envisioned that future updates will still be complete releases. It is therefore suggested that you @begin(enumerate) Retain this distribution tape in case you may have to compare files. Do not make any changes on these distributed directories. If you must make your own bug fixes, it is suggested that you put the changed files on some other directories, such as @i(pnew:). They can then be compared with any new files sent out in subsequent releases. @end |
Added psl-1983/3-1/doc/20/20-dist.otl version [884709d71f].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | @Comment{OUTLINE of 20-DIST.MSS.10 by Scribe 3C(1312) on 20 June 1983 at 13:39} 1. INTRODUCTION 2 20-DIST.MSS.10 line 49 2. DISCLAIMER 2 20-DIST.MSS.10 line 67 3. CONTENTS OF THE TAPE 2 20-DIST.MSS.10 line 86 4. INSTALLING PSL 4 20-DIST.MSS.10 line 178 4.1. Retrieve Control Files 5 20-DIST.MSS.10 line 188 4.2. Create a single subdirectory 5 20-DIST.MSS.10 line 213 4.3. A MULTIPLE SUB-DIRECTORY SYSTEM 6 20-DIST.MSS.10 line 238 4.4. Build Sub-Directories 6 20-DIST.MSS.10 line 258 4.5. Announce the System 7 20-DIST.MSS.10 line 292 4.6. Summary of Restoration Process 8 20-DIST.MSS.10 line 303 5. REBUILDING LOADABLE MODULES 8 20-DIST.MSS.10 line 311 6. REBUILDING THE INTERPRETER 9 20-DIST.MSS.10 line 363 6.1. Complete Kernel Rebuild 9 20-DIST.MSS.10 line 377 6.2. Partial or Incremental Kernel Rebuild 11 20-DIST.MSS.10 line 441 6.3. Rebuilding RLISP.EXE from PSL.EXE 13 20-DIST.MSS.10 line 494 7. RELATIONSHIP TO PSL 3.0 13 20-DIST.MSS.10 line 522 8. FUTURE UPDATES 13 20-DIST.MSS.10 line 530 Table of Contents 1 -SCRIBE-SCRATCH-.28-33-1.100028 line 3 |
Added psl-1983/3-1/doc/examples-for-imp-guide.mss version [d0e21079d0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @section(Examples of various kinds) Recall that when compiling code, variables which are used extended in one procedure, and bound as LAMBDA or PROG variables in another, must be declared fluids. Example: @begin(verbatim) (de foo(X) (PLUS2 X 1)), compiles to: (!*entry foo expr 1) (!*alloc 0) (!*move (quote 1) (reg 2)) (!*linke 0 plus2 expr 2) (de fee(X Y) (Fum (foo X) (foo Y)), compiles to: (!*entry fee expr 2) (!*alloc 2) (!*move (reg 2) (frame 2)) (!*link foo expr 1) (!*move (reg 1) (frame 1)) (!*move (frame 2) (reg 1)) (!*link foo expr 1) (!*move (reg 1) (reg 2)) (!*move (frame 1) (reg 1)) (!*linke 2 fum expr 2) Finally, (de fac (N) (cond ((Lessp N 1) 1) (T (Times2 N (fac SUB 1 N)) compiles to: (!*entry fac expr 1) (!*alloc 1) (!*move (reg 1) (frame 1)) (!*move (quote 1) (reg 2)) (!*link LessP expr 1) (!*jumpeq (label L) (quote nil) (reg 1)) (!*move (quote 1) (reg 1)) (!*exit 1) (!*lbl (label L)) (!*move (frame 1) (reg 1)) (!*link sub1 expr 1) (!*link fac expr 1) (!*move (reg 1) (reg 2)) (!*move (frame 1) (reg 1)) (!*linke 1 times2 expr 2) @end(verbatim) @section(BUILDING the CROSS Compiler) The executable @dq[xxxx-CROSS.EXE] is built as follows: @begin(verbatim) @@psl:rlisp ! an RLISP *mapobl function lambda X; *<< RemProp(X, 'OpenCode); * RemProp(X, 'ExitOpenCode) >>; % Remove old compiler opts * % Load common modules *load(zboot, pass!-one!-lap, if!-system, syslisp, lap!-to!-asm); * % Load XXXX specific modules *load(XXXX!-comp, XXXX!-cmac, XXXX!-asm); *off UserMode; *DumpFileName!* := "filename.exe"; % Establish the executable name *Date!*:=Concat("XXXX Cross Assmbler ", Date()); % Establish greeting *DumpLisp(); % Does a Reclaim and save *Quit; @end(verbatim) @subsection(An example of the process) The following is a complete example, from @syslisp to @CMACRO@xs: @begin(verbatim,leftmargin 0) @@PSL:RLISP PSL 3.0 Rlisp, 9-May-82 syslsp procedure Test1(); % Input RLISP syntax code begin scalar x; x := 5; x := x+7; L := '(A B C D); L1 := (CAR L) . CAR(CDR L); print L1; end; @End(verbatim) @begin(verbatim,leftmargin 0) % This is the output from the Compiler/LAP system. % The lines beginning with "(!* ... " are the Abstract % machine CMACRO's output from the compiler. % The indented lines following them are the VAX @sq[LAP] % assembly code the CMACRO patterns % (in the *-CMAC.SL files) produced by the expansion process. (!*PUSH '5) (@op{PUSHL} 5) (!*WPLUS2 (FRAME 1) (WCONST 7)) % WPLUS2 is actually a % CMACRO (OpenFunct) (@op{ADDL2} 7 (DEFERRED (REG ST))) % Note how the FRAME AnyReg % is converted directly to % a machine specific % addressing mode. (!*MOVE '(A B C D) (!$FLUID L)) (@op{MOVL} '(A B C D) (!$FLUID L)) (!*MOVE (CAR (CDR (!$FLUID L))) (REG 2)) % The AnyReg patterns (@op{EXTZV} 0 27 (!$FLUID L) (REG 2)) % for CAR and CDR are used (@op{EXTZV} 0 27 (DISPLACEMENT (REG 2) 4) (REG 2)) (@op{MOVL} (DEFERRED (REG 2)) (REG 2)) (!*MOVE (CAR (!$FLUID L)) (REG 1)) (@op{EXTZV} 0 27 (!$FLUID L) (REG 1)) (@op{MOVL} (DEFERRED (REG 1)) (REG 1)) (!*LINK CONS EXPR 2) % Standard Function Cell % call. (@op{JSB} (ENTRY CONS)) (!*MOVE (REG 1) (!$FLUID L1)) (@op{MOVL} (REG 1) (!$FLUID L1)) (!*LINK PRINT EXPR 1) (@op{JSB} (ENTRY PRINT)) (!*MOVE 'NIL (REG 1)) (@op{MOVL} (REG NIL) (REG 1)) % Reg NIL evaluates to an (!*EXIT 1) % immediate constant. (@op{ADDL2} 4 (REG ST)) (@op{RSB}) TEST1 @end(verbatim) @subsection(Prologues and Epilogues) An example of Prologues and Epilogues for (@APOLLO version of) the @68000 is given below: @begin(ProgramExample,leftmargin 0) lisp procedure CodeFileHeader(); % Pure Code Segment If !*MAIN then <<CodePrintF(" program %w,m0001%n",ModName!*); CodePrintF " data%n"; DataProcState!*:='data; CodePrintF "* Start of execution of the program%n"; CodeDeclareExternal 'SYMVAL; %/ Issue EXTERN.D early CodeDeclareExternal 'SYMFNC; %/ Issue EXTERN.D early CodePrintF "m0001 EQ *%n"; CodePrintF " move.l db,-(sp) Save caller db%n"; CodePrintF " clr.l -(sp) Push reserved word%n"; CodePrintF " move.l a0,-(sp) Push address of ECB%n"; CodePrintF " move.l SYMVAL+512,d0 Init NIL Reg%n"; CodePrintF " link sb,#0 Balance unlink%n"; CodePrintF " movea.l #0,a6 Setup zeroareg%n"; CodePrintF " lea m0001,db Setup db reg%n"; CodePrintF(" jsr %w Call Main routine%n", MainEntryPointNAme!*); CodePrintF "* now return to OS%n"; CodePrintF " movea.l A_PGM_$EXIT,a6%n"; CodePrintF " jsr (a6)%n"; CodePrintF " unlk sb Reload callers SB%n"; CodePrintF " addq.w #8,sp Pop linkage%n"; CodePrintF " movea.l (sp)+,db Reload callers db%n"; CodePrintF " rts Return%n"; ForeignExternList!*:=NIL; CheckForeignExtern 'PGM!_!$EXIT; >> else <<CodePrintF (" module %w,m0000%n",ModName!*); %/ Kludge, since ModuleName set in ASMOUT CodePrintF " data%n"; DataProcState!*:='data; CodeDeclareExternal 'SYMVAL; %/ Issue EXTERN.D early CodeDeclareExternal 'SYMFNC; %/ Issue EXTERN.D early CodePrintF "* this is an Independent Module %n"; ForeignExternList!*:=NIL; >>; lisp procedure DataFileHeader(); Begin DataPrintF(" module %w_D%n",ModName!*); DataPrintF " data%n"; End; lisp procedure DataFileTrailer(); DataPrintF "end%n"; lisp procedure CodeFileTrailer(); <<Foreach Fn in Reverse ForeignExternList!* do <<CodePrintF(" extern.p %w%n",Fn); CodePrintF("A_%w ac %w%n",Fn,Fn)>>; CodePrintF " end%n">>; @end(ProgramExample) The general use of the headers given above is to declare the module name, tell the assembler that this is a data section@Foot[On the @Apollo all of the code and data were put in a data section since the operating system and assembler had a problem with mixed code and data due to expecting a pure code segment with all data references relative to the data base register.], and in the case of the main routine performing the proper operating system dependent linkage for program entry and exit. Note that CodePrintF and DataPrintF are used to direct output to either the @ei[code] segment or @ei[data] segment. This is to allow seperate segements for those machines that allow for pure code segments (on the @Apollo a pure code segment is directly maped into the address space rather than copied, which results in a large difference in start up speed). This could probably be extended to PureCode, PureData, and ImpureData. procedure WW(X); <<print LIST('WW,x); x+1>>; Now a plain resolve function. That does not argument processing best for register conversion: procedure MYREGFN(R,S); <<Print LIST('MYREG, R,S); List('REG,S+10)>>; PUT('MYREG,'ANYREGRESOLUTIONFUNCTION,'MYREGFN); procedure MYANYFN(R,S); <<Print LIST('MYANY, R,S); S:= ResolveOperand('(REG t3),S); List('Weird,S)>>; FLAG('(WEIRD),'TERMINALOPERAND); PUT('MYANY,'ANYREGRESOLUTIONFUNCTION,'MYANYFN); (!*MOVE (WW 1) (WW 2))); ARgs must be WCONSTEVALUABEL (!*MOVE (WW (WW 1)) (WW 2))); (!*MOVE (WW A) (WW 2))); % First WW shouldnt convert (!*MOVE (MYREG 1) (MYREG 2))); % OK (!*MOVE (MYREG (WW 1)) (WW (MYREG 2)))); % Fails since args not processed (!*MOVE (MYREG (MYREG 1)) (MYREG 2))); (!*MOVE (MYANY 1) (MYANY 2))); % OK (!*MOVE (MYANY (WW 1)) (MYANY (MYREG 2)))); % Args processed (!*MOVE (MYANY (MYANY 1)) (MYANY 2))); @section(Sample ANYREGs and CMACROs from various machines) The following choice pieces from the @VAX750, @DEC20 and @68000 illustrate a range of addressing modes, predicates and style. @subsection(VAX) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % ARGONE -> ARGTWO (Equal) % Don't do anything ((ZeroP AnyP) (@op{clrl} ARGTWO)) % 0 -> ARGTWO ((NegativeImmediateP AnyP) % -n -> ARGTWO (@op{mnegl} (immediate (minus ARGONE)) ARGTWO)) ((@op{movl} ARGONE ARGTWO))) % General case (DefCMacro !*WPlus2 % ARGONE+ARGTWO->ARGONE ((AnyP OneP) (@op{incl} ARGONE)) % add 1 ((AnyP MinusOneP) (@op{decl} ARGONE)) % Subtract 1 ((AnyP MinusP) (@op{subl2} (immediate (minus ARGTWO)) ARGONE)) ((@op{addl2} ARGTWO ARGONE))) The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AnyP@\Just returns T NegativeImmediateP@\Check that a negative, 32 bit constant. @end(Description) @end(verbatim) @subsection(DEC-20) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % Move ArgOne -> ArgTwo (Equal) ((ZeroP AnyP) (@op{setzm} ARGTWO)) ((MinusOneP AnyP) (@op{setom} ARGTWO)) ((RegisterP AnyP) (@op{movem} ARGONE ARGTWO)) ((NegativeImmediateP RegisterP) (@op{movni} ARGTWO (immediate (minus ARGONE)))) ((ImmediateP RegisterP) (@op{hrrzi} ARGTWO ARGONE)) ((AnyP RegisterP) (@op{move} ARGTWO ARGONE)) ((!*MOVE ARGONE (reg t1)) (@op{movem} (reg t1) ARGTWO))) (DefCMacro !*WPlus2 ((AnyP OneP) (@op{aos} ARGONE)) ((AnyP MinusOneP) (@op{sos} ARGONE)) ((AnyP RegisterP) (@op{addm} ARGTWO ARGONE)) ((RegisterP NegativeImmediateP) (@op{subi} ARGTWO (minus ARGONE))) ((RegisterP ImmediateP) (@op{addi} ARGTWO ARGONE)) ((RegisterP AnyP) (@op{add} ARGONE ARGTWO)) ((!*MOVE ARGTWO (reg t2)) (@op{addm} (reg t2) ARGONE))) The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AnyP@\Just returns T MinusOneP@\Check that argument is -1. ImmediateP@\Check that an address or 18 bit constant. Will change for extended addressing. NegativeImmediateP@\Check that a negative 18 bit constant. RegisterP@\Check that is (REG r), a register. @end(Description) @end(verbatim) @subsection(APOLLO) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % (!*Move Source Destination) (Equal) % if source @Value(Eq) dest then do nothing ((ZeroP AregP)(@op{suba!.l} ARGTWO ARGTWO)) ((ZeroP AnyP) (@op{clr!.l} ARGTWO)) % if source @Value(Eq) 0 then dest := 0 ((InumP AregP) (@op{movea!.l} (Iconst ARGONE) ARGTWO)) ((AddressP AregP) (@op{lea} ARGONE ARGTWO)) ((InumP AnyP) (@op{move!.l} (Iconst ARGONE) ARGTWO)) ((AddressP AnyP) (lea ARGONE (reg a0)) (@op{move!.l} (reg a0) ARGTWO)) ((AnyP AregP) (@op{movea!.l} ARGONE ARGTWO)) ((@op{move!.l} ARGONE ARGTWO))) (DefCMacro !*WPlus2 % (!*WPlus2 dest source) ((AnyP QuickIconstP) (@op{addq!.l} (Iconst ARGTWO) ARGONE)) ((AnyP NegativeQuickIconstP) (@op{subq!.l} (Iconst (minus ARGTWO)) ARGONE)) ((AregP MinusP) (@op{suba!.l} (Iconst (Minus ARGTWO)) ARGONE)) ((AnyP MinusP) (@op{subi!.l} (Minus ARGTWO) ARGONE)) ((AregP InumP) (@op{adda!.l} (Iconst ARGTWO) ARGONE)) ((AnyP InumP) (@op{addi!.l} (Iconst ARGTWO) ARGONE)) ((AregP AddressP) (@op{lea} ARGTWO (reg a0)) (@op{adda!.l} (reg a0) ARGONE)) ((AnyP AddressP) (@op{lea} ARGTWO (reg a0)) (@op{add!.l} (reg a0) ARGONE)) ((AregP AnyP)(@op{adda!.l} ARGTWO ARGONE)) ((@op{add!.l} ARGTWO ARGONE))) % really need one a DREG The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AregP@\Check that is one of the A registers (which can not be used for arithmetic), and require modified mnemonics. DregP@\Check that is one of the D registers, used for most arithmetic. InumP@\Check that a small integer. AddressP@\Check that an address, not a constant, since we need to use different instruction for Address's, e.g@. @op{lea} vs @op{movi}. AnyP@\Just returns T. NegativeImmediateP@\Check that a negative, 32 bit constant. QuickIconstP@\Small integer in range 1 ..@. 8 for the xxxxQ instructions on 68000. NegativeQuickIconstP@\Small integer in range -8 ..@. -1 for the xxxxQ instructions on 68000. @end(Description) @end(verbatim) @begin(verbatim,leftmargin 0) For example, on the @VAX750: @begin(Group) (DefAnyreg CAR % First ITEM of pair AnyregCAR % Associated function ((@op{extzv} 0 27 SOURCE REGISTER) % Code to extract 27 bit % address, masking TAG (Deferred REGISTER))) % Finally indexed mode used @hinge (DefAnyreg CDR % Second item AnyregCDR ((@op{extzv} 0 27 SOURCE REGISTER) (Displacement REGISTER 4))) % Displace 4 bytes off Register % Both CAR and CDR use a single instruction, so do not use a % predicate to test SOURCE. @hinge (DefAnyreg QUOTE % Note a set of different choices AnyregQUOTE ((Null) (REG NIL)) ((EqTP) (FLUID T)) ((InumP) SOURCE) ((QUOTE SOURCE))) @hinge (DefCMACRO !*Move % !*MOVE Usually has the most cases (Equal) ((ZeroP AnyP) (@op{clrl} ARGTWO)) ((NegativeImmediateP AnyP) (@op{mnegl} (immediate (minus ARGONE)) ARGTWO)) ((@op{movl} ARGONE ARGTWO))) @hinge (DefCMACRO !*Alloc ((ZeroP)) % No BODY - nothing to allocate ((@op{subl2} ARGONE (REG st)))) @end(group) @end(verbatim) |
Added psl-1983/3-1/doc/fasl.mss version [d156bc18b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(article) @section(How in the hell does faslout work???) This section is a guide to the internal workings of faslout and then faslin. The user begins the faslout procedure by calling the procedure faslout with a string that does not have the extension (because it will add the appropriate binary extension for you). However, when fasling in, the file name requires the binary extension [Change this inconsistency]. Inside the procedure faslout, the file name is assigned to the fluid variable ModuleName!*. Depending upon the setting of the flag !*Quiet_Faslout, the system will either print out a greeting message or not. Next, an output binary file is opened using the argument file name. It will return the channel number to a fluid variable CodeOut!*. CodeFileHeader is called to put in a header in the output file. CodeFileHeader writes out a word consisting of the Fasl Magic Number (currently set to 99). This magic word is used to check consistency between old and current fasl format files (an error is given upon fasling in the file if there is not a 99 as the first word). Therefore, the system must consistently modify that number when a new fasl format is produced. To continue, we need to understand the allocation that takes place within the Binary Program Space (BPS). The BPS is a large, non-collected space that contains compiled code, warrays, the string assocaited with interned ID's, constant data in fasl files, etc. Space is allocated from both ends of the space. Compiled code is allocated from the bottom (using NextBPS as a pointer) and warrays are allocated from the top (using LastBPS as the pointer). When an allocation is attempted, the desired size is checked to see if it will cause LastBPS and NextBPS to cross; if it will, an error message will be printed. The next step is to allocate 2/3 or the remaining BPS from the top. @begin(verbatim) .------------------------------------. | | | WArrays | | | | | Last_BPS>|------------------------------------| <-FaslBlockEnd!* ---. | Code | | | | | | | | | | 2/3 |====================================| <-CodeBase!* | | Bit Table | | |====================================| <-BitTableBase!* ---' | | | | Next_BPS>|------------------------------------| | | | | | | `------------------------------------' Binary Program Space @end(verbatim) The procedure AllocateFaslSpaces will setup the following fluid variables. FaslBlockEnd!* will be the address to the top of the available space for this particular allocation. BitTableBase!* points to the beginning of the BitTable. CurrentOffset!* keeps a pointer into the codespace of this allocation to the next available point to add more code. BitTableOffset!* is a running pointer to the current location in the BitTable where the next entry will go. CodeBase!* is the base pointer to the beginning of the code segment for this allocation. MaxFaslOffset!* is the max size of the codespace allowed for this implementation. OrderedIDList!* keeps record of the ID's as they are added. NextIDNumber!* is a base number used just in fasl files to indicate which IDs are local and which are global. It is assumed that there will never be more than 2048 pre-allocated ID's, currently there are 129. The first 128 preallocated IDs are ASCII codes(0-127) and the last one is NIL(128). Everything is now setup to begin fasling PSL code out to the file. The remainder of the faslout procedure sets up three more fluid variables. !*DEFN is set to T which indicates that you are not going to do normal evaluation from the top loop and from files such as using the functions IN and DSKIN. DFPRINT!* signals that DFPRINT!* is now used as the printing function. The procedure used will be DFPRINTFasl!*. !*WritingFaslFile is set to T to let the system know that fasling out is goping on as opposed to compiling code directly into memory inside the PSL system. @section(What happens to code being fasled out to a file) |
Added psl-1983/3-1/doc/history-of-psl.mss version [77e3b3fc46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @section[A Brief History of @PSL] @begin[Comment] This section NEEDS MORE WORK!! (WFG) Major ideas I think we should cover are: -Influence of REDUCE on the system (e.g. Rlisp syntax). -Work on "Standard Lisp". -Work on portable compiler. The major focus of this chapter should be clarifying why PSL is what it is, and explaining other alternatives that were explored. [But BRIEFLY!] e.g. - Why Rlisp syntax (an outgrowth of REDUCE) - Why syslisp instead of (e.g.) C, (or BIL, or whatever). - Why "DE" instead of "Defun" (perhaps this is getting into too much detail). (Also, perhaps, give more credit to various folks?) @end[Comment] @topic[History of PSL] @Comment{TALK a bit more about REDUCE and Rlisp, mention some of the systems they ran on (e.g. Lisp 1.6 (or 1.5?), IBM dialect (namely?), ...} @Comment{Is my impression correct that REDUCE was once written in LISP syntax, later converted to Rlisp?} @Comment{Then go into this paragraph, but don't need to explain what REDUCE is.} In 1966, a model for a standard @Lisp subset was proposed@cite(Hearn66) as part of a general effort to make @Reduce@cite(Hearn73), a large @Lisp-based algebraic manipulation system, as portable as possible. The goal of this proposal was to define a uniform subset of @lng[Lisp 1.5] and its variants so that programs written in this subset could run on any of those @Lisp systems. @Comment{"intervening"? Between what and what?} In the intervening years, two deficiencies in the original proposal emerged. First, in order to be as general as possible, the specific semantics of several key functions were left undefined. Consequently, programs built on this subset could not be written with any assumptions made about the form of the values of such functions. The second deficiency was in the proposed method of implementation of @lng[Standard Lisp]. The model considered two versions of @Lisp on any given machine, namely @lng[Standard Lisp] and the @Lisp of the host machine, which we shall refer to as @lng[Target Lisp]. @Comment{I CAN'T MAKE SENSE OF THE FOLLOWING (WFG).} This meant that if any definition were stored as interpretive Target @Lisp, it would vary from implementation to implementation; consequently, one could not write programs in Standard @LISP which needed to assume any knowledge about the structure of such forms. This deficiency became apparent during recent work on the development of a portable compiler for @Lisp@cite[Griss81b]. It is clearly easier to write a compiler if we deal with a single dialect (Standard @Lisp) than if we must change it to conform with the various Target @Lisp@xs. As a result of this study, we produced a more aggressive definition of Standard @LISP in the Standard @LISP Report@cite(Marti79). That paper can serve as a standard for a reasonably large subset of @Lisp with as precise as possible a statement about the semantics of each function. Recent work has concentrated on producing a @i(complete) specification and portable implementation of a @lisp based on @lng[Standard LISP]. Experience with a Portable @Lisp Compiler@cite(Griss81b) and with an earlier experimental portable @Lisp implementation@cite(Griss79)) has led to the current @PSL implementation strategy: write most of the system in @Lisp, compiled with the portable compiler. A small non-@Lisp kernel is written in a portable, @Lisp-like systems language, @Syslisp. The previous systems had the problem that the special implementation language (called @lng<BIL>), although oriented to @Lisp implementations, was a distinct language from @Lisp, so that communication between "system" code and "@Lisp" code was difficult. The pattern-driven @lng(BIL) compiler was not very efficient. Consequently, the @lng(BIL) work resulted in a number of experimental @Lisp@xs on a number of machines. These implementations were quite flexible, portable, and useful for @Lisp and @Reduce on machines that did not already have any @Lisp, but somewhat inefficient. We therefore developed the much more powerful, @Lisp-like systems language, @SYSLisp, in which to recode all useful modules. @SYSLisp has been targeted to high-level languages (such as @Fortran, @Pascal, @lng(C) or @Ada), and also to assembly code. We believe this approach will advance our goal of producing a portability strategy which could lead to a system efficient enough for realistic experiments with computer algebra and ultimately to portable, production quality systems. |
Added psl-1983/3-1/doc/hp-psl.lpt version [15b468dceb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Notes on PSL at HP Cris Perdue Alan Snyder 28 September 1982 1. Introduction This memo describes PSL as it exists at HP, as opposed to the standard PSL distribution described in the PSL Users Manual. PSL at HP differs from standard PSL in a number of significant ways. This memo should be read carefully before trying to run PSL at HP. This memo describes the version of PSL installed on Hulk on September 28, 1982. This version does not yet exist on the Vaxen. 2. Before Running PSL on HULK or THOR In order to run PSL on HULK or THOR, you must first perform the EXEC command: @take PSL:LOGICAL-NAMES.CMD This command defines a set of logical device names that are necessary for the proper execution of PSL. If you intend to use PSL more than once, you should include the above command in your LOGIN.CMD file. These logical names are also referred to below and in other PSL documentation; the above command must be performed before you can use any of these logical names. 3. PSL Documentation A printed copy of the preliminary PSL manual can be obtained from Ira Goldstein's secretary. There is also a complete online version of this manual on HULK, organized as a set of files, one per chapter. These are stored in files "PLPT:nnnn-chaptername.LPT". Please do not print your own copies of these files. The manual is currently available on HEWEY in the directory ~psl/dist/lpt. If you have never used PSL at HP before, the memo "DEC-20 PSL New Users' Guide" may be helpful. Copies are available from Ira Goldstein's secretary. On HULK there is a set of short HELP files, on directory "PH:". These help files are generally not very helpful. There is a log of PSL bugs, comments, and inquiries. See the section on "PSL Bugs" below. There is also a file of more substantial PSL news items, (HULK:) PSL:NEWS.TXT. Be sure to read that file as a companion to this document. In addition, there is a file listing most changes made to PSL, (HULK:) PSL:BUG-FIX.LOG. This file is updated whenever a change is made to a PSL system source file; the changes may not actually be installed until some later time. 4. PSL Bugs Send bug reports, inquiries, and comments via computer mail to "PSL". This procedure should work on any DEC-20 or VAX in CRC. The file (HULK:) PSL:BUGS.TXT contains a log of inquiries, comments, and bug reports concerning PSL and its documentation. The file is kept up to date and is edited somewhat. Entries are in chronological order, most recent first, so it is easy to find the latest and most wonderful bugs. The file (HULK:) PSL:BUG-MAIL.TXT contains the unedited accumulation of mail to PSL. 5. Local PSL -- What's in it PSL at HP has some modules preloaded on top of the "bare PSL", which is the minimum set of features now available in a PSL. Some of these modules are described in the PSL manual and are part of the standard PSL distribution; these are preloaded as a convenience for users. Others are local contributions; these are described in greater detail below. The following modules described in the PSL manual are loaded as part of "PSL" at HP. We have chosen these modules as being most useful for most people. useful This module provides a variety of useful features, many or all of them documented in the PSL manual, including the "extended" FOR loop. These functions generally have an obscure annotation in the manual saying that they are available in the USEFUL library. strings This module defines all of the string and character functions defined in section 8.7 of the manual, except for Char and String, whose definitions there conflict with definitions specified elsewhere in PSL. nstruct This module provides a "defstruct" facility said to be the same as the one available on the LISP machines. This is a fancy package that allows the user to define and make use of record or structure-like objects in LISP. See the LISP machine documentation for details, but note that in PSL, colons should not be used to prefix keywords. debug This module provides various debugging features as described in the PSL manual. Most of them are not very high-powered. gsort This module defines some functions for sorting lists and some predicates useful in sorting. common This module defines some functions of "Common LISP". This module is incomplete in many ways: many Common LISP functions are either not provided or are provided in a limited form. This module is intended as a compatibility package rather than an extension to PSL. Common LISP is a relative of MacLISP, and is described in the "Common LISP Reference Manual", copies of which are floating around the Application Technology Department. Many other modules, although mentioned in the PSL manual, are not loaded in "PSL" at HP. Most notable of these are RLISP, the Pascal-like syntax for Standard Lisp, COMPILER, the PSL compiler, and EMODE, a screen editor. See below for information on compiling PSL programs. EMODE has been replaced by NMODE, a locally written editor that is described below. The following are locally-contributed modules that are preloaded in "PSL" at HP. These modules are not described in the PSL Users Manual. Unfortunately, as a result, there is no easy way to prevent your programs from clashing with symbols defined in these modules. Only the most important such modules are listed here. nmode NMODE is an EMACS-like screen editor. It provides a different LISP interface than that described in the PSL manual. See below for more information. objects OBJECTS is a primitive package for supporting object-oriented programming. It is used extensively in NMODE and other HP contributions. It supports a very limited subset of the Lisp Machine flavors package. Notably missing is any support for inheritance. See the file <AS.PSL>OBJECTS.SL on Hulk for further information. input-stream INPUT-STREAM is a class of objects implemented using the OBJECTS package that provide for buffered file input. It is used primarily by NMODE. See the file <AS.PSL>INPUT-STREAM.SL on Hulk for details. output-stream OUTPUT-STREAM is a class of objects implemented using the OBJECTS package that provide for buffered file output. It is used primarily by NMODE. See the file <AS.PSL>OUTPUT-STREAM.SL on Hulk for details. pathnames PATHNAMES is a compatible subset of the Common Lisp pathname package. It provides a system-independent interface for manipulating file names. See the file P20SUP:PATHNAMES.SL for information on the DEC-20 version, and the "Common Lisp Reference Manual". 6. NMODE NMODE is an EMACS-like screen editor. It currently supports only HP terminals, and does not support HP262X terminals well. It supports a useful subset of the EMACS command interface, although many significant features are missing. A list of the NMODE commands is attached as an appendix to this document. Available documentation on NMODE includes the following memos: (1) "NMODE for EMODE Users" - a brief description of NMODE written primarily for those users already familiar with EMODE. (2) "Customizing NMODE" - a description of how to customize NMODE by defining new commands or redefining existing commands. These memos are available on the directory PSL: on Hulk. NMODE provides a display-oriented Lisp interface that is significantly different than the "standard" PSL interface described in the PSL Users Manual. At HP, PSL starts up in NMODE. However, it is possible to get to the "standard" PSL interface simply by executing the command C-] L. (For those not familiar with EMACS, this means to type two characters: "CONTROL-]", followed by "L".) From the PSL interface, you can return to NMODE by invoking the function NMODE (with no arguments), or by RESETing (invoking the function RESET or aborting from a break loop), or reSTARTing (returning to EXEC via ^C and using the "START" command). The proper way to leave NMODE and return to EXEC is to use the command C-X C-Z. While ^C will get you back to EXEC, it may leave your terminal in a funny state. Using C-X C-Z allows NMODE to restore your terminal to the proper state before returning control to the EXEC. NMODE's display-oriented Lisp interface is based on the idea of reading from and writing to NMODE text buffers. The NMODE command "Lisp-E" (which is typed as C-] E) causes PSL to read and evaluate the form starting on the current line of the current buffer. The output resulting from that evaluation is appended to the buffer named "OUTPUT" (which is the current buffer when PSL starts up). If the evaluation of a Lisp form causes an error, a Break Handler will be entered. Terminal input will continue to be directed to NMODE, and NMODE can still be used as an editor while the Break Handler is active. NMODE provides a number of special commands for interacting with an active Break handler: The command "Lisp-Q" (typed as C-] Q) quits out of the innermost break handler. The command "Lisp-A" (typed as C-] A) aborts all the way back to the top level and restarts NMODE. The command "Lisp-R" attempts to retry the failing action that caused the error (which must be a "continuable" error). The command "Lisp-C" is similar, except that rather than reevaluating the "errorform", it uses the result of the last expression evaluated using "Lisp-E". The command "Lisp-B" prints a backtrace. The "Lisp-" commands are available only in LISP mode. To enter Lisp mode, use the command "M-X Lisp Mode". 7. Compiling PSL As mentioned above, the PSL compiler is not normally loaded in PSL. The recommended way to compile PSL programs is to use the program PSLCOMP. PSLCOMP compiles a PSL source file (e.g. "foo.sl") and produces a binary object file (e.g. "foo.b"). PSLCOMP is invoked by the EXEC command @PSLCOMP foo or @PSLCOMP foo.sl PSLCOMP may be given multiple source file names (separated by spaces) and will produce a separate binary file for each source file; however, this practice is dangerous because the "compilation context" created for one source file will remain and may affect the compilation of a later source file. The object file "foo.b" created by PSLCOMP may be loaded into PSL using either LOAD or FASLIN, as follows: (LOAD FOO) (FASLIN "FOO.B") The difference between LOAD and FASLIN is that LOAD will not reload a file that has already been loaded. If you use any non-standard macros, fexprs, or nexprs that are defined in other files, you must cause definitions of those functions to be loaded into PSLCOMP when it compiles your source file. The way to do this is to include a statement of the form (CompileTime (load Module1 Module2 ... )) at the beginning of your source file, where Module1, Module2, ... are LOADable modules that define the macros, etc. that you use. PSLCOMP is preloaded with the following modules: COMMON, USEFUL, STRINGS, OBJECTS, PATHNAMES, NSTRUCT. 8. PSL Directories and Subdirectories -- HULK HULK has a complete set of source files, command files, object files, etc. THOR currently does not, and has only a single directory for PSL. Status of PSL directories and subdirectories on HEWEY is subject to change at any time, so it isn't discussed here. Sources on Hulk reside in SS:<PSL> and its subdirectories. The subdirectories of SS:<PSL> are organized in a logical fashion. The file "PSL:-THIS-.DIRECTORY" contains short descriptions of the files in SS:<PSL> and the subdirectories of SS:<PSL>. To see the complete set of subdirectories of SS:<PSL>, type "DSKUSE SS:<PSL*>" to EXEC. Note that the source code is kept separate from the object code, which is all on PL:. 8.1 TAGS -- Finding the Definitions of PSL System Functions The EMACS editor has a feature that is of great help in finding source code, the TAGS package. To use this package, first load a "tag table", which is a database that records what source file definitions appear in. One tag table can hold definitions that appear in many different source files. We have a very large tag table for all of PSL, which is in the file (HULK:) PSL:PSL.TAGS. To load a tag table file, do "M-X Visit Tag Table" in EMACS and give the file name as an argument. Once a file is loaded, search for a definition using "M-.". You may wish to set the EMACS variable Tags Find File to 1 before searching for definitions. Note also that tag table files may become somewhat out of date. Do not expect perfection. The program TAGS is used to create tag table files. The version that handles PSL (and RLISP) syntax, as well as understanding the file types .SL and .RED is PSL:TAGS.EXE. The system version of TAGS may eventually understand these things. Full information on the EMACS TAGS package is only available in the EMACS manual and through the INFO facility. Do not bother the PSL group with questions and complaints about TAGS until you have read the full documentation. We will not improve the TAGS package itself in any case. |
Added psl-1983/3-1/doc/implementation-guide.mss version [6a857ab8b6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 | @make(article) @Case(Draft, 1 <@device(Omnitech)>, else <@device(LPT)> ) @Comment{ For use with the final versions } @Style(WidowAction=warn) @Style(Hyphenation Off) @comment(on) @Style(DoubleSided no) @comment(yes) @style(Spacing 1, LeftMargin 1.2 Inch) @comment[See G:MSS-junk.MSS] @use(Bibliography "<griss.docs>mtlisp.bib") @comment{ Font related stuff } @Define(OP,FaceCode Y,TabExport)@comment{ used for indicating opcodes in C-macros } @modify(enumerate,numbered=<@a. @,@i. >, spread 1) @modify(itemize,spread 1) @modify(description,leftmargin +2.0 inch,indent -2.0 inch) @LibraryFile(PSLMacrosNames) @LibraryFile(SpecialCharacters) @comment{ The logos and other fancy macros } @PageHeading(Left "Utah Symbolic Computation Group", Right "May 1982", Line "Operating Note No. xx" ) @set(page=1) @newpage() @Begin(TitlePage) @begin(TitleBox) @MajorHeading(@PSL Implementation Guide) @Heading(M. L. Griss, E. Benson, R. Kessler, S. Lowder, G. Q. Maguire, Jr. and J. W. Peterson) Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 Last Update: @value(date) @end(TitleBox) @begin(abstract) This note describes the steps involved in bringing PSL up on a new machine. It combines information from the previous BOOTSTRAP, LAP, CMACRO and TEST guides. @end(abstract) @center[ File: @Value(SourceFile) Printed: @value(date)] @copyrightnotice(Griss, Benson, Lowder, Maguire and Peterson) @begin(ResearchCredit) Work supported in part by the National Science Foundation under Grant No. MCS80-07034, and by Livermore Lawrence Laboratories under Subcontract No. 7752601, IBM and HP. @end(ResearchCredit) @end(TitlePage) @pageheading(Left "Implementation Guide", Center "@value(date)", Right "Page @Value(Page)" ) @comment{@pageheading(Even,Left "Page @Value(Page)", Right "Operating Note No. xx" )} @set(page=1) @newpage() @section(Introduction) This document describes the techniques used to implement PSL on a new machine. This note assumes that the reader has some familiarity with the basic strategy of @PSL implementation (see the 1982 LISP Conference Paper on PSL, UCP-83), and has also read the papers on the @PSL Portable @xlisp compiler (Griss and Hearn, "Software Practice and Experience", and Griss, Hearn and Benson, 1982 Compiler Conference). Also see the compiler chapter (19) of the @PSL manual@cite[Griss81]. Finally, a basic understanding of how to use PSL and LISP is required@cite[Griss81]. In order to explain a new PSL implementation, we will first describe the PSL compilation model, hopefully providing some insight into the various steps involved in the transformation of PSL sources into code executable on the target machine. @comment{May want to add a description of each section to follow} The initial level of transformation takes the RLISP format and translates it into LISP for those source files that are written in RLISP format; those files already in LISP may be directly input into the system (see the figure below). The LISP code is then compiled into instructions for an Abstract Lisp Machine (ALM). The ALM is a general-purpose register machine designed for its ease as a target for compilation@cite(Griss81b) in which temporary variables are allocated in a block of locations on a @ei[stack]. The ALM instructions are expressed in LAP format (LISP Assembly Program) which consists of a list whose first element is the ALM opecode followed by zero or more ALM operands which are ALM addressing modes. The ALM format is (ALMopcode ALMoperand ... ALMoperand). The ALMopcode is a macro referred to as a CMACRO and the addressing modes of the ALMoperands are referred to as ANYRegs. The ALM instructions are macro expanded into instructions for the Target Lisp Machine (TLM). TLM instructions have the same LAP format, except the operators are now TLM operators and the operands are TLM addressing modes. From here, a number of alternate routes are possible for the final code generation. So far the LISP or RLISP has transformed into into a set of TLM instructions that can take one of three paths. @begin(enumerate) Fist, the TLM instructions can be printed out as Target Machine Assembly code (ASM) for assembly on the target machine. This route is followed in the initial phases of the PSL implementation process to produce code for the target machine. Secondly, a file of the target machine code can be produced in a format that can be loaded directly into a running PSL system. This process is called FASLing, producing a FASt Load format file. Finally, the TLM code can be assembled and deposited directly into memopry of the running PSL system. This is basically analogous to the process used to load in a FASL file produced above except the code is not written to or read from a FASL file. @end(enumerate) This process is illustrated below: @begin(verbatim,leftmargin 0,group) .-----------------. Rlisp: Procedure SelectOne x; | RLISP input code| x := car x; `-----------------' v .------. | LISP | Lisp: (de selectone (x) `------' (setq x (car x))) v .----------. | Compiler | `----------' v .------------------------. ALM: (!*entry selectone expr 1) |ALM instructions in LAP | (!*alloc 0) | format | (!*move (car (reg 1)) `------------------------' (reg 1)) v (!*exit 0) .----------. | Pass1Lap | `----------' | v .---------------------. TLM: [68000 code] | TLM instructions in | (Fullword 1) Count of Args | LAP format. | (!*Entry selectone expr 1) `---------------------' (movea!.l (indirect | | (reg 1)) (reg 1)) | v (rts) | .------------. | | TLM to ASM | | | converter | | `------------' | v | .-------------------. ASM: dc.l 1 | | | movea.l (a1),a1 | | Asm code suitable | rts | | for TM assembler | | `-------------------' v .--------------. .-----------------. | LAP resident |----->| Resident binary | | assembler | | `-----------------' +--------------+ | .------------. `-->| FASL files | `------------' @end(verbatim) In summary, here is an overview of the steps necessary to implement PSLon your target machine. More details will be given in the following sections. @begin(enumerate) Prelimaries: @begin(enumerate) Believe in yourself. Choose the host machine. Test file transfer. @end(enumerate) Decide how to map the ALM architecture to the TLM. Implement the TLM to ASM. Implement the ALM to TLM. Build the Cross Compiler and test. Run Cmacro Tests. Build Bare PSL. Implement a resident TLM assembler. Implement FASL. Bootstrap the compiler. @end(enumerate) @section(Overview of the Abstract LISP Machine) The abstract machine is really a class of related machines rather than a single fixed machine (such as PASCAL P-code, or some true @xlisp machines). The exact set of @CMACRO@XS, the number of registers, etc@. are under the control of parameters, flags and compiler code-generator patterns defined for the specific machine. This flexibility permits the match between the compilation model and the target machine to be better set, producing better code. Therefore, the exact set and meaning of @CMACRO@XS are not fixed by this definition; rather, they form an adjustable @dq[convention] between the compilation and @CMACRO/Assembly phase. The compiler itself is defined in PC:COMPILER.RED@Foot[dir: represents a logical directory name, in this PC: stands for <PSL.Comp> under Tops-20 or /psl/comp under UNIX.] and is augmented by machine-specific files, described later. The ABSTRACT LISP MACHINE (ALM) used by our compiler has the following characteristics. @begin(enumerate) There are 15 general purpose registers, 1 ..@. 15; and a stack for call/return addresses. Locals and temporaries variables are allocated on the stack by allocating a frame of temporaries large enough to hold them all, not by the use of push and pop instructions. The function calling mechanism loads N args into 1 ..@. N, and then transfers to the function entry point, pushing the return address onto the stack if necessary. The functions result is returned in register 1. Each procedure is responsible to save any values it needs on stack; small procedures often do not use the stack at all. The following is a brief lisp of all the ALM opcodes (CMACROS). @begin(verbatim) (!*ALLOC nframe:integer) (!*ASHIFT dest:any-alterable source:any) (!*CALL name:id) (!*DEALLOC nframe:integer) (!*EXIT nframe:integer) (!*FIELD operand:any-alterable starting-bit:integer bit-length:integer) (!*FOREIGNLINK name:id type:id number-of-arguments:integer) (!*FREERSTR l:nonlocalvars-list) (!*JCALL name:id) (!*JUMP label:any) (!*JUMPEQ label:any source1:any source2:any) (!*JUMPINTYPE label:any source1:any type-name:id) (!*JUMPNOTEQ label:any source1:any source2:any) (!*JUMPNOTINTYPE label:any source1:any type-name:id) (!*JUMPNOTTYPE label:any source1:any type-name:id) (!*JUMPON source:any lower-bound:integer upper-bound:integer l:label-list) (!*JUMPTYPE label:any source1:any type-name:id) (!*JUMPWGEQ label:any source1:any source2:any) (!*JUMPWGREATERP label:any source1:any source2:any) (!*JUMPWITHIN label:any lower-bound:integer upper-bound:integer) (!*JUMPWLEQ label:any source1:any source2:any) (!*JUMPWLESSP label:any source1:any source2:any) (!*LAMBIND r:registers-list l:nonlocalvars-list) (!*LBL label:tagged-label) (!*LINK name:id type:id number-of-arguments:integer) (!*LINKE nframe:integer name:id type:id number-of-arguments:integer) (!*LOC dest:any-alterable source:any) (!*MKITEM inf:any-alterable tag:any) (!*MOVE source:any dest:any-alterable) (!*POP dest:any-alterable) (!*PROGBIND l:nonlocalvars-list) (!*PUSH source:any) (!*PUTFIELD source:any dest:any-alterable starting-bit:integer bit-length:integer) (!*SIGNEDFIELD operand:any-alterable starting-bit:integer bit-length:integer) (!*WAND dest:any-alterable source:any) (!*WDIFFERENCE dest:any-alterable source:any) (!*WMINUS dest:any-alterable source:any) (!*WNOT dest:any-alterable source:any) (!*WOR dest:any-alterable source:any) (!*WPLUS2 dest:any-alterable source:any) (!*WSHIFT dest:any-alterable source:any) (!*WTIMES2 dest:any-alterable source:any) (!*WXOR dest:any-alterable source:any) (LABELGEN tag:id) (LABELREF tag:id) (!*CERROR message:any) (FULLWORD [exp:wconst-expression]) (HALFWORD [exp:wconst-expression]) (BYTE [exp:wconst-expression]) (STRING s:string) (FLOAT f:float) @end(verbatim) ALM operand forms ("addressing" modes) @begin(verbatim) (FLUID name:id) (!$FLUID name:id) (GLOBAL name:id) (!$GLOBAL name:id) (WVAR name:id) (WARRAY name:id) (WSTRING name:id) (WCONST expr:wconst-expression) (IMMEDIATE wconst-expression:any) (QUOTE s-exp:s-expression) (LABEL l:id) (MEMORY base:any offset:wconst-expression) (CAR base:any) (CDR base:any) (FRAME n:integer) (REG reg-descriptor:{integer,id}) (LIT [any-instruction-or-label:{list,id}]) (LABELGEN tag:id) (LABELREF tag:id) (IDLOC symbol:id) @end(verbatim) @end(enumerate) @Section(System Overview for Bootstrapping) Currently PSL is half bootstrapped from a complete PSL system on a host machine. At the moment only the Decsystem 20 and the VAX 750 can be used as hosts; shortly we expect the Apollo and HP9836 to be also usuable. If you have a choice for your host machine, one important consideration will be the ease in shipping code between the host and target. It is worth taking the time initially to be sure this pathway is as smooth and troublefree as possible. The need for easy file transfers is derived from the half bootstrap method and the iterative nature of developing and debugging the tables used in the ALM to TLM transformation. The size of the transferred files will be in the range of 1 to 70 KBytes. Having a fast network or a tape transfer from host to target is worth considering in the beginning of a PSL implementation. The first major step in the implementation will be to modify the host PSL to become a cross compiler, turning lisp or rlisp into the target machines assembly language. @SubSection(Overview of the Cross Compiler) Three modules are created, compiled and loaded into a host PSL to transform it into a cross compiler. @begin(enumerate) The first module will be xxx-comp.red (we will use XXX to represent the name of the target machine, like DEC20, VAX, etc.); a file containing patterns used by the compiler to control which ALM instructions are emitted for certain instructions. Basically it is used in LISP to ALM transformations and initially will only require you to copy the same file used on your host machine. The second module will be xxx-cmac.sl. This file contains the tables(CMacroPatternTables) used to convert ALM opcodes to TLM opcodes, the tables used to convert ALM addressingmodes into TLM addressingmodes (ANYREGS), and some miscellaneous required opencoded functions. The last module, xxx-asm, consists of two files, xxx-asm.red and xxx-data-machine.red. The first file, xxx-asm.red, specifies the necessary formats, costants, and procedures for converting TLM instructions into the host's actual assembly language. The file, xxx-data-machine.red, provides constants for describing to the compiler some of the specific choices for what registers to use and how the lisp item will be used in the machine words. @end(enumerate) All of these modules are compiled and loaded into a host PSL to turn it into the cross compiler. The next few sections will try to describe to the reader how these three modules are actually designed and built from the bottom up. It will be worth getting a listing of these modules for your host machine and also for a machine most similar to your target machine, if available. @Section(Designing the TLM instruction format). The implementor must decide first the specifics of the TLM instruction format patterned around the form (TLMopcode TLMoperand ... TLMoperand). The TLM to ASM translation occurs in a parallel manner. (TLMopcode TLMoperand TLMoperand) TLM format. | | | ASMopcode ASMoperand ASMoperand Some ASM format. The closer the ASM format approaches the TLM format the better. However in some cases this will not be possible and the reader must devise a scheme. Take a look at the case studies for some ideas of ways to handle some of these issues. TLM opcodes are usually passed through unchanged to the ASM code. However the TLM operands will require extensive changes. [Mention terminal operands!!!]. The TLM operands are of the form (addressingmode value-expression). The addressingmode is a tag which will direct what procedures will be used to convert and print the ASM operands. The reader should pick these addressingmode names to closely match the addressingmodes of the target machine. Some examples of these would be (immediate ...), (indirect ...), (displacement ...), or (indexed ...). Here again the case studies will give you some information for proceeding. [Mention CRAY mismatch of TLM]. @Section(Implementing the TLM to ASM conversion) You can begin by creating the xxx-data-machine.red file and begin to add some definitions. First pick a name for your system, anything representative will do like the name of its operating system or its manufacturers identifier. Some examples are dec20, vax, apollo, or m68000. @begin[verbatim] fluid '(system_list!*); system_list!* := '(MC68000 Chipmunk HP9836); @end[verbatim] The next step is quite important. You must decide how you are going to implement the LISP item on the target machine. The LISP item consists of 2 or three fields; each field having a position and size in the machines item picked by the implementor. All LISP items must have a tag field and an INFormation field and some implementations have a garbage collector field. The tag field must be at least 5 bits long@Foot[Nineteen (19) different tags are presently used.] and the inf field should be large enough to hold a target machine address. Some implementations, such as the Vax, will choose an inf smaller than the largest address possible on the machine and will have to mask tag bits out when using the inf field as an address. This does cause problems and should be avoided if possible. If space allows it the INF field may be larger to allow larger numeric operands to be stored in registers. Currently PSL provides two different garbage collection methods, one of which should be chosen (or a new one developed if needed). One is a two-space copying collector, which requires no extra garbage collection bits, but is very wasteful of space and is best for a virtual memory machine (in fact, there are two copies of the heap). The other is a one space compacting collector, and requires at least one bit for marking, and ideally additional bits for relocation (sometimes, these extra bits can be stored in a separate bit table). Naturally these fields may be larger to make their accessing easier, like aligning on a byte boundary. Once you have decided upon how the LISP item will be implemented on the machine you can begin filling in the constant definitions for the xxx-data-machine.red file. When numbering bits in a machine word, we have settled upon the convention that the most significant bit is zero and counts up to the max-1 bit. The current constants are @begin(verbatim) TagStartingBit TagBitLength InfStartingBit InfBitLength AddressingUnitsPerItem CharactersPerWord BitsPerWord AddressingUnitsPerFunctionCell StackDirection and optionally GCStartingBit GCBitLength @end(verbatim) The following figure illustrates the positions of these constants: @begin(verbatim) .-----------------------------------------. | TAG | [gc] | INF | `-----------------------------------------' FILL IN LATER @end(verbatim) Some other decisions that must be made include: @begin(enumerate) Which and how many registers to dedicate as the compiler-allocated @ei[Registers]; How large an integer will be supported in the @xlisp item; How many tags are to be supported How to implement the recursion stack and check for stack overflow (either using an explicit test, or some machine-interrupt); How to pack and unpack strings; @Comment{PSL must have explicitly tagged items, and the current allocator is a simple linear model, so this is not relevant. Whether to have a heterogeneous heap, multiple heaps, a @ei[page] per type, or whatever;} @Comment{This is also not relevant. Pairs are the same on all machines. How pairs are referenced, i.e. does the pointer to a pair point to the first element, to the second element, are the pairs allocated separately in parallel areas, or is there some type of CDR coding being done.} @end(enumerate) The next step is to implement the tables that accept the ALM form and emits assembly code for the target machine. Most of the program is machine-independent (using PC:LAP-TO-ASM.RED), and an @dq[xxxx-ASM.RED] file is to be written. We have the following already written as a guide: @DEC20 @dq[MACRO], @VAX750 @UNIX @dq[as], @68000 for @apollo and WICAT, and CRAY CTSS CIVIC. The main problem is to emit the correct format, such as: placement of tabs, commas, spaces, parentheses; renaming symbols (certain legal @xlisp IDs are not legal in some assemblers); and determining how and where to place EXTERNAL, ENTRY and GLOBAL declarations, how to declare and reserve blocks of storage, and how to overcome certain problems involved with large files and restrictions on addressing modes and relocation. Finally, the ALM to ASM needs to be tested. This is usually accomplished by Hand-coding some small test routines, and then convert from ALM to machine X assembly code, assemble, and run. This checks the final details of required Prologues and Epilogues@Foot[Prologues and Epilogues contain operating system-specific standard module headers and trailers.], understanding of the instruction set, and so on. Suggested LAP tests are described @ei[generically], but will have to be translated by the implementor into machine-dependent LAP for machine X, and depending on the flavor of assembler and LAP, other tests will have to be devised by the implementor. This is a good time to investigate how Assembly coded routine can call (and be called) by the most common language used on machine X (such as FORTRAN, PASCAL, C, etc.). This "Foreign" language can be used for initial operating system support. @section(Implementing the ALM instructions) The ALM instructions consists of a set of operations and their addressing mode operands. These ALM instructions are commonly referred to as CMACRO's and the addressing modes are ANYREG's. The purpose of this part of the PSL implementation is to implement the functionality of each ALM instruction in terms of other ALM instructions and TLM instructions. The ability to recursively define the ALM instructions in terms of other ALM instructions is a benefit because it greatly decreases the amount of code required to implement a particular instruction. For example, a good technique in designing the ALM instructions is to carefully implement the !*MOVE instruction (to distinguish ALM instructions, they generally have a !* in the front of their name) to efficiently handle transfer between any possible locations (memory to register, stack frame to memory, etc.). Then when implementing another instruction, the code for moving the actual operands to locations necessary for the TLM instruction can be accomplished using a recursive call to the !*MOVE ALM instruction. The important tasks of the implementor are to @begin(enumerate) Carefully examine the instruction set and architecture of the TLM to see which instruction (instructions) correspond to each ALM CMACRO; Decide how to map the ALM registers and addressing modes onto the TLM registers and addressing modes (some will map one-to-one, others will take some thought, and a sequence of actions); Decide on a set of classifications of the TLM modes that distinguish which of a related set of TLM opcodes should be used to implement a particular ALM opcode, and write predicates that examine ALM and TLM modes to decide which class they are in; Write tables to map ALM modes into TLM modes, using these predicates, and then ALM opcodes into a (sequence of) TLM opcodes with the correct TLM modes. @end(enumerate) @subsection(Mechanics of ALM Instruction Definition) Before we get into the description of the ALM instructions, we must first define the table-driven pattern matching approach used to implement them. This approach allows definition of an ALM instruction in terms of a pattern predicate which is used to match the operands of the ALM instruction and a body that may consist of a mixture of ALM instructions (for recursive decomposition) and TLM instructions (for direct code generation). This is exactly analogous to the COND construct in LISP. Just like COND, any number of predicate/body pairs may be included in the expansion of an ALM instruction. Also, the order of the pairs is quite important (since they are compared in order from first to last). Typically, the most specific predicates are described first followed by gradually more and more general ones. The table definition for a specific ALM instruction is compiled into a single procedure. The instruction name must then be flagged with 'MC to indicate that it is a legal ALM instruction. The pattern table itself must then be stored under the indicator 'CMACROPATTERNTABLE on the ALM instruction property list. To simplify this process, the DefCmacro Macro has been defined: @begin(verbatim) (DefCMacro ALMInstructionName (pred1 body1) (pred2 body2) ... lastbody) @end(verbatim) Each ALM instruction is defined with a set number of arguments and the predicates are used to compare the types and/or values of the arguments. A predicate need not test all arguments, with non-tested arguments defaulting to T for a value. For example, one could define the following patterns: @begin(verbatim) Predicate Body (DefCMacro ALMInst ((FOOP) (Body1)) ((FEEP BARP) (Body2)) ((ANYP) (Body3)) (Body4)) @end(verbatim) Note that this looks almost exactly like the LISP operation COND. The one difference lies with the Body4 in the above example, which has no predicate and will always be evaluated if all others fail (Similar to the final 'T case in a Cond without the T). This last predicate/body pair may NOT have a predicate. If it doesn't, it will be evaluted just like the body. [!!Future change - CERROR on the default case, and make the defined use ANYP for his default case] The predicate functions are automatically passed one argument which is the ALM operand in the position of the test. So, in the above example, FOOP is passed the first operand and BARP is passed the second, after failure in the FOOP test. The body can be thought of as an implicit PROGN that contains a set of ALM and TLM instructions. These instructions then reference the various operands as ARGONE, ARGTWO, ARGTHREE, etc. using lexical ordering in the instruction. For example, if an ALM instruction mapped directly to a TLM one, it may be defined as: @begin(verbatim) ((FOOP BARP) (TLMOperator ARGONE ARGTWO)) @end(verbatim) Or, it may map into a number of ALM and TLM instructions: @begin(verbatim) ((FEEP) (ALMOperator ARGONE Something) (TLMOperator Something ARGTWO) (ALMOperator Something ARGONE)) @end(verbatim) Notice that even though the predicates only test the first operand ARGONE, the other operands may be referenced in the body. Also, "Something" can be thought of as a kind of constant operand (like a particular register, an integer constant, a memory location or whatever). In order to facilitate more complicated instructions within the body, we must now introduce a number of other features. First, suppose that you wish to include code generation time constants within the body. This can be accomplished by placing on the property of a variable name, 'WCONST with its value being the desired constant. Then when the variable is encountered in the instruction expansion, it will be replaced by the value on its property list under the 'WCONST indicator. A useful function to perform this operation would be: @begin(verbatim) (DE MakeReferencedConst (ConstName ConstValue) (Put ConstName 'WCONST ConstValue)) @end(verbatim) Therefore, if you perform a (MakeReferencedConst 'TAGPOSITION 10) then the body may reference TAGPOSITION directly: @begin(verbatim) ((FOOP) (ALMOperator ARGONE TAGPOSITION)) @end(verbatim) Now, that we have constants, it is sometimes desirable to have constant expressions. As long as all of the operands are either direct or referenced constants, the expression can be evaluated in an ALM or TLM instruction (the function may also be called if it doesn't have any operands). For example, the following could be imbedded within an instruction body: @begin(verbatim) (Plus2 (Foo 35 TagPosition) WordWidth) @end(verbatim) The system also provides for an alias mechanism, so you can map one name into another. This is accomplished by placing on the property of the alias, the name of the acutal function under the property DOFN. Thus, if you wanted to map FEE into PLUS2, you would simply: (Put 'FEE 'DOFN 'PLUS2). Therefore, another useful function would be: @begin(verbatim) (DE Alias (AliasFunction ActualFunction) (Put AliasFunction 'DOFN ActualFunction)) @end(verbatim) Sometimes in the process of generating the TLM instructions, it is necessary to make use of a temporary label (i.e. to generate a forward branch). This can be accomplished by referencing TEMPLABEL (just like a reference to ARGONE), which will create a label name consistent with a particular body. For example: @begin(verbatim) ((FOOP) (Test ARGONE) (GO (Label TEMPLABEL)) (Operate ARGONE ARGTWO) (Label TEMPLABEL)) @end(verbatim) Notice that even if the label references are separated by recursive ALM instructions, it will still create a unique reference to the label in both places. There is another mechanism to accomplish the same task in a more general fashion, that allows referencing of multiple labels. This mechanism is used with two functions: @begin(description) LabelGen@\This function takes one argument and returns a generated label. The argument and label are stored on an A-List for later reference. The argument may be any atom. LabelRef@\Look up the argument on the label's A-List and return the associated label. @end(description) An example of the use of these two functions is: @begin(verbatim) ((FOOP) (Label (LabelGen 'L1)) (Test ARGONE) (Go (LabelGen 'L2)) (Operator ARGTWO)) (Go (LabelRef 'L1)) (Label (LabelRef 'L2))) @end(verbatim) Finally, if the need arises to be able to call a function within an ALM instruction expansion. This can be accomplished by using the ANYREG mechanism. It is important to know that this technique will not work for a function call within a TLM instruction, only in the recursive expansion of an ALM instruction (there is no method for calling a function within a TLM instruction). (Note: ANYREG's will be explained in detail later, but the mechanism can be used to call a function). The technique is to first define the function that you wish to call, with one extra argument (the first one) that will be ignored. Then define an anyreg function that calls your function. For example, suppose you want a function that returns an associated register based upon a register argument (with the association stored in an A-List). The code would be implemented as follows: @begin(verbatim) (De GetOtherRegFunction (DummyArgument RegName) (Assoc RegName '((A1 S3) (A2 S2) (A3 S1)))) (DefAnyReg GetOtherReg GetOtherRegFunction) @end(verbatim) Then the pattern that may use the function would be: @begin(verbatim) ((FOOP) (ALMOperator (GetOtherReg ARGONE) (GetOtherReg ARGTWO))) @end(Verbatim) [Future Change - Implement a technique so if it is necessary for a random function to be called, all one has to do is define it and flag it as something appropriate - like 'ALMRandomFunction] @subsection(@ANYREG and @CMACRO patterns) Certain of the ALM operands are @ei[tagged] with a very special class of functions thought of as extended addressing modes; these @ANYREG@xs are essentially Pseudo instructions, indicating computations often done by the addressing hardware (such as field extract, indexing, multiple indexing, offset from certain locations, etc.). For example, the @xlisp operations CAR and CDR often are compiled in one instruction, accessing a field of a word or item. Using @ANYREG in this case, CAR and CDR are done as part of some other operations. In most cases, the @ANYREG feature is reserved for operations/addressing modes usable with most instructions. In some cases, the @ANYREG is too complicated to be done in one instruction, so its expansion emits some code to @ei[simplify] the requested addressing operation and returns a simpler addressing mode. The main thing is all desired computations are done using 1 or zero registers, hence the name @dq[@ANYREG]. The @ANYREG@xs have an associated function and possible table, with the name of the function under the property 'ANYREGRESOLUTIONFUNCTION and the pattern under 'ANYREGPATTERNTABLE. Just like the DefCMacro macro has been defined to aid ALM instruction description, the macro DefAnyReg has been provided to help set up these associations: @begin(verbatim) (DEFANYREG anyregname anyregfunction (pred1 body1) (pred2 body2) ... lastbody) @end(verbatim) As you can see, the structure of a DefAnyReg is exactly the same as DefCMacro, except an additional operand AnyRegFunction must be supplied. When an AnyReg is found in the instruction expansion, the function is called with two or more arguments: @begin(enumerate) Temp Register - Since the anyreg must perform its operation using zero or one register, this is the register that it may use to perform its task. (CAVEAT: The current implementation provides either (Reg T1) or (Reg T2) as the temporary register in all cases except one. That is when the anyreg is the source of a move and the destination is a register. In that case, the destination register is passed as the temporary. This can cause a problem if any part of the anyreg requires the destination to first be a source. [Future change - Eliminate this problem used in move and always pass in T1 or T2]). Source - This is the actual body of the anyreg. It may be referenced within the AnyRegPatternTable as SOURCE. ArgTwo - Only one anyreg (Memory) currently has more than two arguments. If they are desired, this third argument may be referenced by ARTTWO. @end(enumerate) A defect in the current system is that the pattern predicates following the anyreg function may not test the Temporary Register. This is quite inconsistent, since the function definition must consider the operand, while the pattern table must ignore it. [Future change - Fix This problem] @subsection(ALM Instruction Expansion) Now that we understand the mechanics of defining ALM instructions and anyreg tables we need to explore the order of expansion of the instructions. The compiler emits ALM instructions, with the operands being legal ALM "addressing" modes. These instructions are collected in a list and passed to the Pass1Lap function. Pass1Lap looks at each instruction and attempts to simplify it. It looks on the property of the opcode and checks to see if it has been flagged with 'MC. If so, it calls the function of the same name with the operands unchanged. Most ALM expansion functions first apply the function @begin(verbatim) ResolveOperand(Reg, Source) @end(verbatim) to each operand, passing a temporary register as the first argument, REG. This resolution process converts ALM operand forms into TLM operand forms i.e, legal addressing modes of the TLM. After each operand has been "resolved", the CMACRO pattern table is used, and the resulting LIST of CMACROS processed recursively. This is what is accomplished in the three functions: @begin(verbatim) EXPAND1OPERANDCMACRO(Arg1,Name) EXPAND2OPERANDCMACRO(Arg1,ARg2,Name) EXPAND4OPERANDCMACRO(Arg1,ARg2,Arg3,Arg4,Name) @end(verbatim) which first resolves the arguments using the available registers and then calls the routine (CMACROPATTERNEXPAND) which finds the pattern table of the Name argument (ALM instruction) stored on the property list under the indicator 'CMACROPATTERNTABLE. For example, (de !*WPlus2 (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WPlus2)) Only the (!*MOVE s d) ALM opcode tries to be smarter about temporary regs: d:=RESOLVEOPERAND('(Reg t2),d) If d is a register, then RESOLVEOPERAND(d,S) else RESOLVEOPERAND('(REG t1),s); [Future change - This should be changed in the future] Recall also that Processing an arugment with RESOLVEOPERAND may require other CMACRO's to be emitted first, to "simplify" the complex addressing mode; each Operand is free to destroy/modify its given register. For example, note how register t1 is reused below to resolve multiple CAR's and CDR's into MOVE's and simpler CAR's and CDR's: (!*MOVE (CAR (CAR x)) d) => (!*MOVE (CAR x) (REG t1)) (!*MOVE (CAR (REG t1)) d) (!*MOVE (CAR (CAR(reg 1))) (CDR (CDR (reg 2)))) => (!*MOVE (CDR (reg 2)) (REG t2)) (!*MOVE (CAR (REG 1)) (REG t1)) (!*MOVE (CAR (reg t1)) (CDR (reg t2))) Therefore, typically the operands are first processed before the ALM instruction table is used. AnyReg processing works the same way as with the ALM instructions. The operands are first resolved by calling the ResolveOperand function and then ExpandOneArgumentAnyReg (or TwoArgument) is called to process the pattern table. This has also been combined into a single function: OneOperandAnyReg and TwoOperandAnyReg. [[WARNING - There is an inconsistency in the naming here. For CMacro expansion the combined functions are called EXPANDxOPERANDCMACRO where for anyregs it is ONEOPERANDANYREG. BE CAREFUL!!!!!!! Another inconsistency is that CMacros are flagged with 'MC, which AnyRegs are not flagged]] @paragraph(ResolveOperand) The ResolveOperand function takes two arguments, a temporary register and the source to resolve. It performs the following resolution, in the order given: @begin(Description) an ID@\cals ResolveWConst on the ID; number or string@\returned unchanged; (OP s)@\If OP is flagged 'TerminalOperand, it is returned as is. (OP s)@\If OP is an @anyreg (has an 'AnyregResolutionFunction), it is applied to (Register s). (OP s)@\Otherwise, it is examined to see if it is a WCONST expression. @end(description) The function ResolveWConst tests its operand to see if it is a constant or constant expression, and returns its value. It performs the following resolution: @begin(description) (WCONST number)@\returns the number ID@\If WCONST indicator is on the ID's property, the associated number is returned otherwise the ID is returned. Expression@\Each operand is tested to determine if it can be resolved as a WCONST and if so, the function is applied to all of the operands (ANY FUNCTION CAN BE CALLED) @end(description) ?????Insert some SUMMARY USING THE FOLLOWING???????? Most ANYREGS use OneOperandAnyReg, ie recursively process arguments inside out (CAR anyreg), (CDR anyreg), etc % (de AnyRegCAR(R S) (OneOperandAnyReg R S 'CAR)) % (defAnyReg CAR AnyRegCar ....) Those that do not permit anyregs as args, use ExpandOneOperandAnyReg eg, (QUOTE s), (WCONST w), (WVAR v), (REG r) or flag name as TERMINALOPERAND to pass direct to ASM so here is a simple WCONST expression. As long as args are WCONSTEVALUABEL themselves, any function can be applied: @section(Predicates) Provided in the common machine independent files are a number of useful predicates. Those include: [[[[List the predicates provided in common-predicates]]]] Each of the following predicates expects one argument; call it X: @begin(Description) RegisterP@\(EqCAR X 'REG) tests for any register AnyP@\ Always T, used as filler EqTP@\ (equal X T) MinusOneP@\(equal X -1) InternallyCallableP@\Check if legal to make a fast internal call. Essentially checks the following: @begin(format) [(or !*FastLinks % all calls Fastlinks? (and !*R2I (memq X EntryPoints!*)) % or specially declared (FlagP X 'InternalFunction) (FlagP X 'FastLink)))] @end(format) AddressConstantP@\(or (NumberP X) (EqCar X 'Immediate))) @end(Description) @section(Standard ANYREGS) The following are the basic @ANYREG functions, which in many cases look for an AnyregTable: @begin(Description) @B[ID]@\@B[Flagged] CAR@\OneOperandAnyreg, 'CAR table@comment{ need to explain all of these tables - particularly the WVar table } CDR@\OneOperandAnyreg, 'CDR table QUOTE@\ExpandOneArgumentAnyreg, 'QUOTE table WVAR@\ExpandOneArgumentAnyreg, 'WVar table REG@\ExpandOneArgumentAnyreg, 'REG table WCONST@\OneOperandAnyreg, 'WConst table, default normally just SOURCE. FRAME@\ExpandOneArgumentAnyreg, computes offset from stack pointer, and passes this (in bytes) to 'FRAME table FRAMESIZE (Register)@\Computes (NAlloc!* @Value(Times) AddressingUnitsPerItem) to give size of frame to any special code needing it. MEMORY (Register Source ArgTwo)@\Used to compute indexed memory access: TwoOperandAnyreg, Look for 'MEMORY table. LABEL@\Flags a label, does no processing. @end(Description) The implementor of @PSL for any particular machine is free to add additional @ANYREG@xs (addressing modes), that are emitted as part of @CMACRO@XS by machine specific compiler patterns or COMPFNs. IMMEDIATE is a tag used to @ei[suggest] address or immediate constant. @subsection(Some AUXILLIARY Operand Modes for the TLM) Each of the following functions expects one argument; call it X: @begin(Description) UnImmediate@\If X @Value(Eq)(Immediate Y), removes tag to get Y. ExtraReg@\Converts argument X into Access to ArgumentBlock[X-LastActualReg] QUOTE@\Compiles X into a constant. If !*ImmediateQuote is T, returns an ITEM for object, else emits ITEM into a memory location, returns its address. @end(Description) Note @CMACRO@XS (flagged 'MC) are first expanded, then the PASS1PSEUDO@xs. This means the @CMACRO@XS are able to insert and manage TAGS that are removed or modified by final PASS1PSEUDO. @section(more junk) @i[Implement the Compiler Patterns and Tables]. This requires selecting certain alternative routes and parameterizations allowed by the compiler, trying to improve the match between the Abstract @PSL machine used by the compiler and the target architecture X. Mostly this phase is reserved for optimization, but the basic tables have to be installed to map @xlisp function names to corresponding @cmacro names and select the Compiler functions (COMPFNs and OPENFNs) to be used for each construct. This file, @dq[xxxx-COMP.RED], is usually copied from one of the existing machines and modified as needed. Most of the modifications relate to the legality of certain addressing combinations. These tables are briefly described in the Compiler chapter of the manual, but currently this task is still somewhat "arcane".@comment{ There needs to be some mention of what the usual modifications are! } @i[Build and Test the CROSS Compiler]. Now compile a series of LAP (mostly @CMACRO tests), @xlisp and @syslisp files to X assembly code, link and run. As the tests proceed, certain small I/O and function calling procedures are written in LAP. A common way to do I/O is to implement a @ei[Foreign Function]-calling protocol, used from @xlisp to call functions according to FORTRAN, PASCAL, C or other useful conventions. Calls in compiled @xlisp/@syslisp code to function names flagged with the 'FOREIGN-FUNCTION flag are called with a non-@xlisp protocol. This permits a standard I/O library to be called and allows simple routines to be written in another language. The purpose of this separate function-calling mechanism is to allow the @xlisp system to use the most efficient calling method possible, compatible with the needs of @syslisp and @xlisp. This method is not necessarily the most flexible, general, or safe method and need not be used by other languages. However, to allow the @xlisp/@syslisp system to call upon existing routines, particularly system-provided services, this additional function-calling mechanism should be provided. Some care needs to be taken to preserve and restore registers appropriately. @chapter(Test Series) In order to accomplish the PSL bootstrap with a minimum of fuss, a carefully graded set of tests is being developed, to help pinpoint each error as rapidly as possible. This section describes the current status of the test files. The first phase requires the coding of an initial machine dependent I/O package and its testing using a familar system language. Then the code-generator macros can be succesively tested, making calls on this I/O package as needed. Following this is a series of graded SYSLISP files, each relying on the correct working of a large set of SYSLISP constructs. At the end of this sequence, a fairly complete "mini-LISP" is obtained. At last the complete PSL interpreter is bootstrapped, and a variety of PSL functional and timing tests are run. @section(Basic I/O Support) The test suite requires a package of I/O routines to read and print characters, and print integers. These support routines are usually written in a "foreign" language (call it "F"), such as PASCAL, C or FORTRAN; they could also be coded in LAP, using CMACROs to call operating system commands, if simple enough. (E.g., JSYS's on DEC-20, Traps on 68000, etc.). These routines typically are limited to using the user's terminal/console for input and output. Later steps in the bootstraping sequence introduce a more complete stream based I/O module, with file-IO. On some systems, it is appropriate to have a main routine written in "F" which initializes various things, and then calls the "LISP" entry point; on others, it is better to have "LISP" as the main routine, and have it call the initialization routines itself. In any event, it is best to first write a MAIN routine in "F", have it call a subroutine (called, say TEST), which then calls the basic I/O routines to test them. The documentation for the operating system should be consulted to determine the subroutine calling conventions. Often, the "F" compiler has an "ASSEMBLY Listing switch", which can be turned on to see how the standard "F" to "F" calling sequence is constructed, and to give some useful guidance to writing correct assembly code. This can also be misleading, if the assembler switch only shows part of the assembly code, thus the user is cautioned to examine both the code and the documentation. On directory PT: (which stands for /psl/tests or <PSL.TESTS>), or its subdirectories, we have a number of sample I/O packages, written in various languages: PASCAL, FORTRAN, C and DEC20 assembly code. Each has been used successfully with some PSL bootstrap. The primitives provided in these files are often named XXX-yyyy, where XXX is the machine name, and yyyy is the primitive, provided that these are legal symbols. Of course, the name XXX-yyyy may have to be changed to conform to "F" and the associated linker symbol conventions. Each name XXX-yyyy will be flagged as a "ForeignFunction", and called by a non-LISP convention. The following is a brief description of each primitive, and its use. For uniformity we assume each "foreign" primitive gets a single integer argument, which it may use, ignore, or change (VAR c:integer in PASCAL). @Comment{Is this assumed to be a WORD size quantity, i.e. on the 68000 a 32 bit quantity or can it be a small integer???} The following routines ("yyyy") in LISP, will be associated with the corresponding "foreign" routine "XXX-yyyy" in an appropriate way: @begin(description) init()@\Called once to set up I/O channels, open devices, print welcome message, initialize timer. Quit()@\Called to terminate execution; may close all open files. PutC(C)@\C is the ASCII equivalent of a character, and is printed out without line termination (I/O buffering may be needed). C=EOL=10 (ASCII LF) @Comment{does this mean that the character should appear right away, or can it wait till the EOL is sent???} will be used to signal end-of-line, C=EOF=26 (ASCII SUB) will be used to signal end of file. GetC()@\Returns the ASCII equivalent of the next input character; C=EOL=10 for end of line, and C=EOF=26 for end of file. Note it is assumed that GetC does not echo the character. TimC()@\Returns the runtime since the start of this program, in milli-seconds, unless micro-seconds is more appropriate. For testing purposes this routine could also print out the time since last called. PutINT(C)@\Print C as an integer, until a SYSLISP based Integer printer that calls XXX-PutC works. This function is used to print integers in the initial tests before the full I/O implementation is ready. @comment{Err(C)@\Called in test code if an error occurs, and prints C as an error number. It should then call Quit() .} @end(description) The following functions will probably need to be defined in LAP, using either the ALM (cmacro level ) or machine specific (TLM) level: @begin(description) !%Store!-Jcall(Code-Address,Storage-Address)@\The Storage-Address is the address of the slot in the SYMFNC table where a jump instruction to the Code-Address must be stored. This implements a compiled call to a compiled function. You may have to insert padding or legal code to make the code match the call to the compiled code. The LAP for the Dec20 is: @begin(verbatim) LAP '((!*entry !%Store!-Jcall Expr 2) % CodeAddress, Storage Address (!*alloc 0) (!*WOR (reg 1) 8#254000000000) % Load a JRST in higher-bits (!*MOVE (reg 1) (memory (reg 2) (wconst 0))) (!*EXIT 0)); @end(verbatim) !%Copy!-Function!-Cell(From-Address,To-Address)@\Copies the SYMFNC cell located at the From-Address to the SYMFNC cell located at the To-Address. If your machine has the SYMFNC cell the same width as that of MEMORY, the following code used on the Dec-20 will work: @begin(verbatim) LAP '((!*entry !%copy!-function!-cell Expr 2) % from to (!*alloc 0) (!*move (memory (reg 1) (Wconst 0)) (memory (reg 2) (wconst 0))) (!*exit 0)); @end(verbatim) UndefinedFunction()@\In general, we think of the storage of the number of arguments in a register (Reg NargReg) and the index of the called function in a register (Reg LinkReg). This function must store the linkage register in the fluid UndefnCode!* and the Narg register in the fluid UndefnNarg!*. Finally, it must !*JCALL to the UndefinedFunctionAux. The following code implements this function in a manner that is portable across all machines that use the LinkReg and NargReg as real register: @begin(verbatim) FLUID '(UndefnCode!* UndefnNarg!*); LAP '((!*ENTRY UndefinedFunction expr 0) % No alloc 0 ? and no LINKE % because we don't want to % change LinkReg. (!*Move (reg LinkReg) (Fluid UndefnCode!*)) (!*Move (reg NargReg) (Fluid UndefnNarg!*)) (!*JCALL UndefinedFunctionAux) ); @end(verbatim) Flag(Dummy1,Dummy2)@\A call to this function is automatically generated by the compiler, but is never used. So, you must implement this function to call your error routine if it is actually called (This function will be redefined in a later test). The code for the Dec-20 is portable except the linkage to the Machine Dependent Error routine Err20: @begin(verbatim) LAP '((!*ENTRY FLAG expr 2) (!*alloc 0) (!*MOVE 2 (REG 1)) (!*LINKE 0 Err20 Expr 1) ); @end(verbatim) @end(description) Finally, the following three functions must be implemented to allow arithmetic operations of sufficient length. @begin(description) LongTimes(Arg1,Arg2)@\Compute the product of Arg1 and Arg2 and return: @begin(verbatim) procedure LongTimes(x,y); x*y; @end(verbatim) LongDiv(Arg1,Arg2)@\Compute the quotient of Arg1 and Arg2 and return the value: @begin(verbatim) procedure LongDiv(x,y); x/y; @end(verbatim) LongRemainder(Arg1,Arg2)@\Compute the Remainder of Arg1 with respect to Arg2: @begin(verbatim) procedure LongRemainder(x,y); Remainder(x,y); @end(verbatim) @end(description) As a simple test of these routines implement in "F" the following. Based on the "MainEntryPointName!*" set in XXX-ASM.RED, and the decision as to whether the Main routine is in "F" or in "LISP", XXX-MAIN() is the main routine or first subroutine called: @begin(verbatim) % MAIN-ROUTINE: CALL XXX-INIT(0); CALL XXX-MAIN(0); CALL XXX-QUIT(0); % XXX-MAIN(DUMMY): INTEGER DUMMY,C; CALL XXX-PUTI(1); % Print a 1 for first test CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(2); % Second test CALL XXX-PUTC(65); % A capital "A" CALL XXX-PUTC(66); % A capital "B" CALL XXX-PUTC(97); % A lowercase "a" CALL XXX-PUTC(98); % A lowercase "b" CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(3); % Third test, type "AB<cr>" CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print A65 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print B66 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTI(C); % should print 10 and EOL CALL XXX-PUTC(C); CALL XXX-PUTI(4); % Last Test CALL XXX-ERR(100); CALL XXX-PUTC(26); % EOF to flush buffer CALL XXX-QUIT(0); % END @end(verbatim) For examples, see PT20:20IO.MAC for DEC-20 version, PHP:HP.TEXT for HP9836 PASCAL version, PCR:shell for CRAY fortran version. @section(LAP-TO-ASM and CMACRO Tests) After the basic XXX-ASM.RED file has been written and the XXX-CROSS.EXE has been built, and seems to be working, an exhastive set of CMACRO tests should be run. The emitted code should be carefully examined, and the XXX-CMAC.SL adjusted as seems necessary. Part of the CMACRO tests are to ensure that !*MOVEs in and out of the registers, and the ForeignFunction calling mechanism work. The goal of this test, and the following few sections is to guide you in getting the first piece of ALM code to translate to TLM form, correctly assemble, and finally execute on the target machine. There are a large number of details to worry about, and one will have to come back and refine decisions a number of times. Some of the decisions you will have to make are based on incomplete information, and are based on an interaction of the ALM model, LISP usage statistics and unknown oddities of the target machine. In many cases, you will have to make the decision just to proceed to get the skeleton together, and then immediately come back to fix the code. The first major milestone will be to set up enough of the basic cross-compiler to be able to translate and assemble the following file, called PT:MAIN0.RED: @begin(verbatim) % MAIN0.RED - A "trivial" file of ALM level LAP to test % basic set of tools: LAP-TO-ASM mostly, % and CMACROs LAP '((!*ENTRY DummyFunctionDefinition Expr 1) (!*ALLOC 0) (!*MOVE (REG 1) (REG 2)) (!*EXIT 0)); END; @end(verbatim) It consists of a single procedure, written in LAP using only 4 CMACROs, each quite simple. Notice the procedure defined has a "long" name, which may have to be mapped to a simpler symbol (for your assembler) by a routine in your xxx-ASM.RED file. The !*ENTRY cmacro is actually handled by LAP itself, so there are 3 CMACROs to be written: @Begin(description) (!*ALLOC n)@\Issues instructions to allocate a frame of n items on the stack. May also have to issue instructions to check stack overflow if the system hardware does not. For some machines, with n=0, no code is emitted, while for others, !*ALLOC is a good place to establish certain registers for the code body. (On the CRAY, the call instruction puts the return address in a register, which get saved on the stack in the !*ALLOC). (!*MOVE source dest)@\Issue code to move the contents of source to the destination. In the MAIN0 example, a register to register move is desired. ALM (REG 1) and (REG 2) are almost always allocated to real TLM registers. An "anyreg" for the REG mapping will have to be written. (!*EXIT n)@\Issues code to clean up the stack, by removing the frame that was allocated by a corresponding (!*ALLOC n), and then returns to the caller, whose address was saved on the stack (usually) by an appropriate TLM instruction. (On CRAY, the return address is restored to the special register). @end(description) Here is an example of the processing of this file on the DEC-20. On the DEC20 we produce 2 files, the CODE-FILE and the DATA-FILE: @begin(verbatim) CODE-FILE, MAIN0.MAC DATA-FILE, DMAIN0.MAC @end(verbatim) In summary, here are the initial steps you will have to follow, with some indication of the decisions you will have to make: @begin(description) Decide on PSL Item layout@\How many bits for the tag; should there be a GC field; will the tag have to be masked out when the INF field is used as an address; should the fields be aligned to byte, word or other boundaries to make TAG and INF access faster; Decide on TLM register use@\Some registers will be used for the ALM registers (rest simulated by memory locations), some used for CMACRO temporaries, some for Target OS interface or addressibility, some for Linkage registers and some for the stack. Stack Implementation@\Should the LISP stack be same as system stack; can we use stack hardware; how about stack overflow; which way should stack grow; ALM needs to access elements inside the stack relative to the stack pointer; the stack pointer needs to be accessible so that the GC and other things can access and examine elements. @end(description) @section(More details on Arcitecture mapping) Need to explain why currently 1 tags used, expect more or less in future. Perhaps explain which tests are MOST important so at least those can be done efficiently, even if others encoded in a funny wya. Mention idea that in future may want to put (say) 3 bits of tag in lower word, force double or quadword alignment, and put rest of tag in object. Mention how some data-types are immediate, others point into memory, and some already have headers. Mention possibel user-defind extension types. Need to clarify how ALM registers are used so can be mapped to TLM or memory. Need to explain Stack registers, CMACRO temporary registers, link registers. Need to explain relative importance of certain CMACROs and order in which they should be written and debugged. Make a CMACRO test file to be examined by hand, to be assembled, and maybe even run. Need to give more detailed steps on how to get MAIN1 running; seems like a BIG step. Perhaps break down into smaller MAIN0, just to get off the ground. (Ie, might not execute, but should assemble). Give a check list of steps. Explain that at first, just get all pieces together, then can fill in details once the skeleton is correct, and flesh out stubs. Explain data-file versus code-file model. @section(SysLisp Tests) This set of tests involve the compilation to target assmbly code, the linking and execution of a series of increasingly more complex tests. The tests are organized as a set of modules, called by a main driver. Two of these files are machine dependent, associating convenient LISP names and calling conventions with the "Foreign" XXX-yyyy function, define basic data-spaces, define external definitions of them for inclusion, and also provide the appropriate MAIN routine, if needed. These files should probably be put on a separte subdirectory of PT: (e.g., PT20:, PT68:, etc.) The machine dependent files are: @begin(description) XXX-HEADER.RED@\Is a machine dependent "main" include file, read into each MAINn.RED file, to define the data-spaces needed, and perhaps define a main routine in LAP, and have the appropriate XXX-MAIN call the "FirstCall" function, used to start the body of the test. Also included are the interface routines to the "F" coded I/O package. providing a set of LISP entry-points to the XXX-yyy functions. This should be copied and edited for the new target machine as needed. Notice that in most cases, it simply defines "procedure yyyy(x); XXX-yyyy(x);", relying on "ForeignFunction" declaration of XXX-yyyy. XXX-TEST-GLOBAL-DATA.RED@\This contains a series of external declarations to correspond to the Global Data definitions in the above header file file. It is automatically included in all but the MAINn module via the "GlobalDataFileName!*" option of XXX-ASM.RED. @end(description) The machine independent test files and drivers are: @begin(description) MAIN1.RED@\Is a very simple driver, that calls Getc and Putc, does a few tests. It does an 'IN "XXX-HEADER.RED";'. The "FirstCall" procedure then calls "init", uses "putc" to print AB on one line. It should then print factorial 10, and some timings for 1000 calls on Factorial 9 and Tak(18,12,6). Build by itself, and run with IO. @Comment{This seems to hide the assumption that 10! can be done in the integer size of the test implementation.??? } SUB2.RED@\Defines a simple print function, to print ID's, Integer's, Strings and Dotted pairs in terms of repeated calls on PutC. Defines PRIN1, PRIN2, PRINT, PRIN2T, TERPRI and a few other auxilliary print functions used in other tests. Tries to print "nice" list notation. MAIN2.RED@\Tests printing and access to strings. It peforms most of the useful string operations, printing messages to verify that they function properly. Uses Prin2String to print a greeting, solicit a sequence of characters to be input, terminated by "#". Watch how end-of-line is handled. Then Print is called, to check that TAG's are correctly recognized, by printing a LISP integer, an ID and 2 dotted pairs. Requires SUB2 and IO modules. Finally, it tests the undefined function calling mechanism to verify that it does print out an error message. Therefore, the UndefinedFunction routine must be defined in xxx-header by this test 2. SUB3.RED@\Defines a mini-allocator, with the functions GtHEAP, GtSTR, GtVECT, GtCONS, Cons, XCons, NCons, MkVect and MkString. Requires primitives in SUB2 module. MAIN3.RED@\First Executes a Casetest, trying a variety of Branches and Defaults in the case staement. There are a number of calls on Ctest with an integer from -1 to 12; Ctest tries to classify its argument using a case statement. ConsTest simply calls the mini-allocator version of CONS to build up a list and then prints it. Requires SUB2, SUB3 and IO modules. SUB4.RED@\Defines a mini-reader, with InitRead, RATOM and READ. It has the facilities to convert case input, using the !*RAISE switch (and the SetRaise function). This mini-READ does not yet read vectors. Requires SUB3, SUB2, and IO modules. MAIN4.RED@\First, this test checks to see that EQSTR works. Then it tests FindId to see if it can find Identifiers known to exist. After that, it tests to see if new Id's can be found and then found in the same place. Then a test loop is created that calls RATOM, printing the internal representation of each token. Type in a series of id's, integer's, string's etc. Watch that the same ID goes to same place. When the user types a Q, it should go into a READ-PRINT loop. You should type in a variety of S-Expressions, checking that they are correctly printed. Once again, you should finally type a Q to exit. Requires SUB3, SUB2 and IO modules. SUB5.RED@\Defines a mini-EVAL. Does not permit user defined functions. Can eval ID's, numbers, and simple forms. No LAMBDA expressions can be applied. FEXPR Functions known are: QUOTE, SETQ, COND, PROGN and WHILE. The Nexpr LIST is also known. Can call any compiled EXPR, with the standard 15 arguments. Requires SUB4, SUB3, SUB2 and I/O. MAIN5.RED@\Starts a mini-READ-EVAL-PRINT loop, to which random simple forms may be input and evaluated. When ready, input (TESTSERIES) to test PUT, GET and REMPROP. Then an undefined function is called to test the UNDEFINED function mechanism. Requires SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are case raised (!*RAISE has been set to T by default) so input can be in in lowercase for built-in functions. Terminates on Q input. SUB6.RED@\Defines a more extensive set of primitives to support the EVAL, including LAMBDA expressions, and user defined EXPR, FEXPR, NEXPR and MACRO functions. This is a complete model of PSL, but has a restriced set of the PSL functions present. Can call any compiled or interpreted function. Requires SUB5, SUB4, SUB3, SUB2 and I/O. MAIN6.RED@\Tests the full PSL BINDING modules (PI:BINDING.RED and PT:P-FAST-BINDER.RED). Call the (TESTSERIES) routine to do a test of Binding, the Interpretive LAMBDA expression evaluator, and binding in compiled functions. Requires SUB6,SUB5, SUB4, SUB3, SUB2 and IO modules. !*RAISE is once again on. Terminates on Q input. SUB7.RED@\A set of routines to define a minimal file-io package, loading the machine independent files: PT:SYSTEM-IO.RED and PT:IO-DATA.RED, and a machine dependent file XXX-SYSTEM-IO.RED. The latter file defines primitives to OPEN and CLOSE files, and read and write RECORDS of some size. The following definitions are used in the routines: @begin(verbatim) FileDescriptor: A machine dependent word to references an open file. FileName: A Lisp string @end(verbatim) @begin(description) SYSCLEARIO()@\Called by Cleario to do any machine specific initialization needed, such as clearing buffers, initialization tables, setting interrupt characters, etc. SysOpenRead(Channel,FileName)@\Open FileName for input and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysOpenWrite(Channel,FileName)@\Open FileName for Output and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysReadRec(FileDescriptor,StringBuffer)@\Read from the FileDescriptor, a record into the StringBuffer. Return the length of the string read. SysWriteRec (FileDescriptor, StringToWrite, StringLength)@\ StringLength characters from StringToWrite from the first position. SysClose (FileDescriptor)@\Close FileDescriptor, allowing it to be reused. SysMaxBuffer(FileDesc)@\Return a number to allocate the file-buffer as a string; this should be maximum for this descriptor. @end(description) RDS, WRS, OPEN, CLOSE, DSKIN and TYPEFILE are defined. MAIN7.RED@\Starts the LISP READ-EVAL-PRINT loop tested before, and now permits the user to test io. Call (IOTEST). Other functions to try are (OPEN "foo" 'OUTPUT), (WRS n), (RDS n) etc. [Now the GETC and PUTC IO routines in XXX-HEADER will finally call the file-oriented IndependentReadChar and IndependentWriteChar]. Also includes the standard PSL-TIMER.RED (described below), which can be invoked by doing (DSKIN "PT:TIME-PSL.SL"). Since the garbage collector not yet present, may run out of space. FIELD.RED@\A a set of extensive tests of the Field and Shift functions. Needs a WCONST BitsPerWord defined in XXX-HEADER.RED. Build by itself, and execute with the IO support. @end(description) Test set "n" is run by using a set of command files to set up a multi-module program. These files are stored on the approriate subdirectory (PT20: for the DEC20). Note that each module usually produces 2-3 files ("code", "data" and "init") @begin(Enumerate) First Connect to the Test subdirectory for XXX: @verbatim[ @@CONN PTxxx:] Then initialize a fresh symbol table for program MAINn, MAINn.SYM: @verbatim[ @@MIC FRESH MAINn] Now successively compile each module, SUB2..SUBn @verbatim[ @@MIC MODULE SUB2,MAINn @@MIC MODULE SUB3,MAINn @@MIC MODULE SUBn,MAINn] Now compile the MAIN program itself @verbatim[ @@MIC PROGRAM MAINn] As appropriate, compile or assemble the output "F" language modules (after shipping to the remote machine, removing tabs, etc..). Then "link" the modules, with the XXX-IO support, and execute. On the DEC-20, the @verbatim[ @@EX @@MAINn.CMD] command files are provided as a guide] Rather than including output from some older test runs, we insist that you run the tests yourself on the HOST machine to be absolutley sure of what output they produce, and what input is expected. Also, if errors occur during testing, the examination of the HOST tests will help. This will also help as additonal tests are added by new implementors. @end(enumerate) @section(Mini PSL Tests) The next step is to start incorporating portions of the PSL kernel into the test series (the "full" Printer, the "full" reader, the "full" Allocator, the "full" Eval, etc.), driving each with more comprehensive tests. Most of these should just "immediately" run. There some peices of Machine specific code that have to be written (in LAP or SYSLISP), to do channel I/O, replacing the simple XXX-IO; to do fast APPLY; Fluid Binding and Arithmetic. This set of tests will help check these peices out before getting involved with large files. @section(Full PSL Tests) Now that PSL seems to be running, a spectrum of functional tests and timing tests should be run to catch any oversights, missing modules or bugs, and as a guide to optimization. The following tests exist: @Description[ PSLTEST.SL@\A fairly comprehensive test of the Standard LISP subset of PSL. Do (DSKIN "pt:psltest.sl"). There are a few tests of the error mechanism that have to be "pushed" through for a full test. MATHLIB.TST@\A series of tests of MATHLIB. First LAOD MATHLIB; into RLISP, then do IN "MATHLIB.TST"; . PSL-TIMER.SL, TIME-PSL.SL@\A standard timimg test covering PSL basics. Compile PSL-TIMER.SL into kernel, or with resident compiler, then (LAPIN "PT:TIME-PSL.TEST"). ] @section(Stabilize Basic PSL) Finally, compile the kernel modules of @PSL, link with the additional machine-dependent modules, and @PSL (hopefully) comes right up@Foot[Presently an unlikely possibility, as the system may still change arbitrarily from under the implementor!]. Additional work is underway to develop a much more comprehensive test set, that will not change while the implementor is proceeding with the bootstrap; unfortunately, @PSL is still undergoing continuous development at Utah, resulting in some "out-of-phase" communication problems. After the basic interpreter is working, additional modules can also be compiled from @xlisp to X and linked with the kernel. The most common of these might be the @RLISP parser and even the @REDUCE@cite[Hearn73] computer algebra system@Comment{???or should this be symbolic algebra system??? }. As more files are compiled to machine X and linked, the task becomes more tedious. At this point, we need to consider the bootstrap of the @ei[Resident] Compiler, LAP and fast-loader (FASL). The most common way to build and maintain large @PSL programs is to build the kernel @PSL with a resident FASLIN for loading fast-load files, and then compile required modules to FASL (xxxx.b) files. A @PSL-based system is built by loading the appropriate FASL files, and then saving the @dq[core] image as an executable file. On some machines this is easy; on others it is quite hard; see the discussions below. These additional steps are: @begin(enumerate) @i[Implement Resident LAP]. Using an existing LAP.RED as a guide, write a table-driven program that does the actual assembly of code written in LAP form for machine X, to the appropriate bit-patterns; the details of this process are discussed at length in @dq[Reading, Writing and Testing LAP]@cite[Griss82h]. @PSL provides many tools to make this task quite easy, but the process is still very machine dependent. Future work may lead to the use of an architectural description language. @i[Test LAP]. The depositing of bit-patterns into BPS@Foot[BPS is Binary Program Space. The name BPS is a remnant of @xlisp 1.6. The desire to have a separate code space is based on the desire to @ei<not> relocate compiled code.] needs to be checked. Check also that procedures can be constructed with LAP, compile LAP into the kernel, and assemble some small files. @i[Implement FASLIN]. FASLIN requires some binary I/O and other small support procedures described in a separate section below. @i[Implement FASLOUT]. Once LAP works, the FASLOUT process seems quite simple, requiring only the Binary I/O etc@. used by FASLIN. It should be possible to get xxxx-FASLOUT working on an existing @PSL, and cross-FASL for machine X. This has not yet been tested. When it works, FASLIN could be made part of the @PSL kernel very early on. @i[Test FASL files]. Check that FASL files can be easily written and read. @Comment{What kind of tests should be done??? This "easily written and read" sounds like apple pie, but it would seem that a piece of SYSLISP could be written that would give the FASL mechanism a good work out, perhaps two pieces with cross references to one another. } @i[Implement and test Core saving]. Determine how to save the image of an executing program, so that it can be restarted. We only require that it be restarted at the beginning, not where it was when it was saved. We usually change the MAIN entry function to call an appropriate TopLoop. See the more extensive discussion below. @foot[Actually, the only part which must be saved is the impure data part; the pure data section, the pure code section and the control stack need not be preserved - however, if only the impure data part is saved, the restart mechanism must map the pure data and code back in. For an example of programs which do selective dumping see EMACS MKDUMP and @interlisp SYSOUT. @Comment{We probably need to think about some way of loading the libraries similar to EMACS, such that it is easy to reload the libraries (particularly if they remain pure).}] @end(enumerate) @chapter(DETAILED REFERENCE MATERIAL) @section(Details on the ALM Operand forms) The following are references to a variety of memory locations: In the current implementation the following 4 reference the same location, the SYMVAL cell of the associated ID. This is the contents of the location SYMVAL+AddressingUnitsPerItem*IDLOC(id): @begin(verbatim) (FLUID name:id) (!$FLUID name:id) (GLOBAL name:id) (!$GLOBAL name:id) @end(verbatim) @begin(description) (WVAR name:id)@\This references the contents of the static location named by the ID. @end(description) The following are all constants, either absolute bit-patterns, or address expressions. @begin(description) (WARRAY name:id)@\Address of the base of a static array (WSTRING name:id)@\Address of the base of a static string (WCONST expr:wconst-expression)@\Any constant expression, either numeric, a declared constant, addresses of thinsg that could also be passed as WARRAY or WSTRING, or other expressions that can be handled by the TLM assembler. (IMMEDIATE wconst-expression:any)@\Really only introduced as a "tag" to make later processing easier; a constant is either an explict constant or (IMMEDIATE expression). This is default TLM mode wrapped when RESOLVEOPERAND is "unsure". We are confused about the differences between WConsts and Immediates in some cases. (QUOTE s-exp:s-expression)@\Is the constant bit-pattern representing a tagged PSL item. (LABEL l:id)@\Reference to a local location (symbol) in the current set of ALM instructions, processed in a single call to LAP, usually a single function. (MEMORY base:any offset:wconst-expression)@\This is the basic ALM "indexing" operation, and represents the contents of the location (base)+offset. (CAR base:any)@\Reference the contents of the ITEM pointed at by INF(base). It is assumed that base is actually a PAIR (not checked). In principle this is sort of like (MEMORY (INF base) (WCONST 0)). (CDR base:any)@\Refernce the contents of the ITEM pointed at by INF(base). It is assumed that base is actually a PAIR (not checked). In principle this is sort of like (MEMORY (INF base) (WCONST AddressingUnitsPerItem)). (FRAME n:integer)@\Contents of the n'th location in the current stack frame. In most versions of the ALM, there is an explicit register, (REG ST), which points at the base of the frame. The stack grows in some direction determined by features on the TLM, so that this could in principle be expressed as (MEMORY (reg ST) (WCONST (times StackDirection -1 AddressingUnitsPerItem (SUB1 n)))) (REG reg-descriptor:{integer,id})@\Reference to an ALM register. (LIT [any-instruction-or-label:{list,id}])@\Plants the instruction sequence elswhere, and leaves a reference to its start. Essetially equivalent to (label g), with g starting a block of the instructions, in "literal" space. (LABELGEN tag:id)@\A mechnism (with LABELREF) to generate and reference a label local to a particular CMACRO pattern. Meant mostly for implementing conditional jumps of various kinds. (LABELREF tag:id)@\Reference a label that was assigned to the Tag. @end(description) The following set of ALM instruction forms are used to define constant data which is intermixed with instructions. @begin(description) (FULLWORD [exp:wconst-expression])@\The expressions are deposited in successive "words" (item-sized units). (HALFWORD [exp:wconst-expression])@)\The expressions are deposited in succesive halfwords (two per item-sized unit). (BYTE [exp:wconst-expression])@\The expressions are deposited in successive "bytes" (character-sized units). (STRING s:string)@\The ASCII values of the characters of the string are deposited in successive bytes, terminated by a zero byte. (FLOAT f:float)@\The 2 word bit pattern for the floating point number is deposited. @end(description) These must be processed by the TLM to ASM translator (and later by the resident assmbler). @subsection(Standard @CMACRO@xs) The following are the basic @CMACRO@XS; additional @CMACRO@XS are of course frequently added either to aid in writing the @CMACRO@XS (a @CMACRO @ei[subroutine]), or to aid some aspect of the machine-specific details. Recall that each @CMACRO returns a list of LAP instructions (which are simpler to generate code for, although it may be a more complex list of operations) representing the appropriate expansion of this @CMACRO (these may also call other @CMACRO@XS). These instructions are then recursively processed by the @CMACRO expander (i.e@. LAP). The !*MOVE @CMACRO is very commonly used for this purpose, to get a @ei[general] operand into a register, so the particular @CMACRO can operate on it. The following @CMACRO@XS deal with function ENTRY, EXIT and function call: @begin(Description) !*Entry((FunctionName FunctionType NumberOfArguments)@\Normally the user does not code this @CMACRO, since it is processed completely by LAP itself. It is used to indicate the start of a function (or entry point within a function). Normally just plants a label corresponding to FunctionName. !*Exit (N)@\Exits (@dq[returns]) from procedure, deallocating N items, as needed. N corresponds to the N items allocated by !*Alloc, see below. !*Link (FunctionName FunctionType NumberOfArguments)@\If FunctionName is flagged 'FOREIGNFUNCTION, emit a call (!*ForeignLink FunctionName FunctionType NumberOfArguments), else emit a (!*Call FunctionName). This is the basic function call macro. It assumes the appropriate number of arguments are in the registers (previously loaded) in the registers, @w[(REG 1) ... (REG n)]. We currently do not check either NumberOfArguments or FunctionType, so a simpler @CMACRO, !*CALL is provided for basic function call. !*Call (FunctionName)@\Basic or @dq[Standard] function call. Checks to see if FunctionName has an 'OPENCODE property, and returns the stored instruction list if any. Otherwise it looks for an appropriate pattern table stored by DEFCMACRO under 'CMACROPATTERNTABLE, as described above. !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments)@\An @dq[exit] call. Emitted when the caller does not need to examine the result, but returns it directly. The !*LinkE @CMACRO does not save the return address, so a return from the called function is not to this caller, but to the previous !*LINK. Essentially deallocates the frame (if any), does either an ordinary !*ForeignCall and then !*Exit(0), or does a !*JCALL which does no return address saving. !*JCall (FunctionName)@\First checks for an EXITOPENCODE table, then for an OPENCODE table (followed by a normal return, !*EXIT(0)) or looks for the general '!*JCALL table. The generated code is supposed to call the function without saving a return address, essentially a JUMP. !*ForeignLink (FunctionName FunctionType NumberOfArguments)@\ This is the basic linkage to a foreign function. It assumes the appropriate number of arguments are in the registers (previously loaded) in the registers, @w[(REG 1) ... (REG n)]. It then pushes the arguments on a stack, or moves them to a global location, as appropriate and transfers to the ForeignFunction in an appropriate manner (REWRITE). Some care must be taken in interfacing to the LISP world, with cleanup on return. @end(description) The following @CMACRO@XS handle the allocation and deallocation of a Frame of temporary items on the stack, used for argument saving, PROG local variables, etc. @Begin(description) !*Alloc (N)@\Allocates a frame of N @Value(Times) AddressingUnitsPerItem units by adjusting the stack (generally increasing it) by using a stack operation that invokes an overflow signal, if any. Otherwise the stack register should be compared against an appropriate UpperBound. It passes N @Value(Times) AddressingUnitsPerItem to the pattern, to be used for indexing or displacement. Note some stacks grow in the @ei[negative] direction, and this is a major source of @CMACRO errors. Currently, there is a major problem, that this MACRO may not be called recursively. FIX in the future. !*DeAlloc (N)@\Decrement stack by N @Value(Times) AddressingUnitsPerItem units, deallocating the temporary FRAME. Passes N*AddressingUnitsPerItem to the pattern. @end(Description) The following @CMACRO@XS deal with the binding and unbinding of FLUID variables used as Lambda or Prog parameters. They are usually quite complex to code. The basic idea is to follow the call on a Lambind or Progbind procedure by a compact table of Fluid addresses or offsets. The call may have to be special, and @ei[internal], so that the support code (usually hand-coded in LAP) can pick up and process each entry in the compact table. @begin(Description) !*LamBind(Registers FluidsList)@\Registers is of the form @w[(REGISTERS (REG a) (REG b) ... (REG c))], and FluidsList is of the form @w[(NONLOCALVARS (FLUID f) ...)]. The intent of this @CMACRO is to save the current value of each Fluid in the list on the Binding Stack, paired with the Fluid name. Then the value in the corresponding register is stored into the Value cell. Later unbinding by !*FreeRstr or the Catch and Throw mechanism, restores the saved value. !*ProgBind (FluidsList)@\Emitted for Fluid variables in Prog parameter lists. Idea is as above, but stores a NIL in the value cell after saving the old contents. Usually implemented as @w[(!*LamBind '(REGISTERS) FluidsList))], but may be able to use a more compact table. !*FreeRstr (FluidsList)@\Restores the old values of the fluids. Since we use a special binding stack with Fluid names stored on it, we really only need the number to unbind. [Perhaps we should use !*UnBind(N) to make this decision explicit.] @end(Description) Data-moving @CMACRO@XS. Most of the work is done by !*MOVE, with some PUSH/POP optimizations if the !*MOVE is close to an !*ALLOC or !*DEALLOC. Other data moving may be done in conjuction some of the operations, such as !*WAND, !*WOR, !*WPLUS2, !*WMINUS, etc. @begin(Description) !*Move (Source Destination)@\The major work horse. Generates code to move SOURCE to DESTINATION. Uses (REG t1) and (REG t2) as temporary registers if needed. First simplifies destination (@ei[Anyreg resolution]), using (REG t1) as a temporary if needed. It then simplifies the SOURCE, using the as temporary either the destination (if a register), or (REG t2). Finally, the !*MOVE table is used. !*Push (Arg1)@\Emitted during peep hole optimization to replace a pair !*ALLOC(1) and !*MOVE(arg1,(FRAME 1)). This is a very common optimization. !*Pop (Arg1)@\Emitted during the peep hole phase to replace the common pair !*MOVE((FRAME 1),Arg1), followed by !*DEALLOC(1). This modifies the argument ARG1. @end(Description) The JUMP @CMACRO@XS are given the label as the first operand, but they pass the label as the third (and last) argument to the pattern (usually as ARGTHREE) after resolving the other arguments. The label is tagged (LABEL Label). @begin(Description) @begin(group) !*Lbl (Label)@\This @CMACRO is emitted when a label is inserted in the generated code. Its body is usually trivial, but can be more complex if some form of short and long jump optimization is attempted. @hinge !*Jump (Label)@\Emit code to jump to Label. Label often involves memory. @hinge !*JumpEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 EQ Arg2. Used for @xlisp EQ and @syslisp WEQ. @hinge !*JumpNotEQ (Label Arg1 Arg2)@\Generate code to JUMP if not(Arg1 EQ Arg2). Used for @xlisp EQ and @syslisp WEQ. @hinge !*JumpWLessP (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(LT) Arg2. Used for @syslisp WLESSP. @hinge !*JumpWGreaterP (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(GT) Arg2. Used for @syslisp WGREATERP. @hinge !*JumpWLEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(LTE) Arg2. Used for @syslisp WLEQ. !*JumpWGEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(GTE) Arg2. Used for @syslisp WGEQ. !*JumpType (Label Arg TypeTag)@\Generate code to JUMP if TAG(Arg) @Value(Eq) TypeTag. The TypeTags are small integers, defined in the xxxx-Data-Machine file. This @CMACRO is emitted for opencoded Type checking, such as IDP(x), etc. It should be implemented very efficiently. Instead of extracting the TAG and comparing with the small integer, it may be easier just to mask the INF portion of Arg, and compare with a shifted version of TypeTag (previously saved, of course). @hinge !*JumpNotType (Label Arg TypeTag)@\Generate code to JUMP if not(TAG(Arg) @Value(Eq) TypeTag). See comments above. @hinge !*JumpInType (Label Arg TypeTag)@\Generate code to JUMP if Tag(Arg) is in the range @w([0 ... TypeTag,NegInt]). This is used to support the numeric Types, which are encoded as 0,...M, and -1 for negative Inums. Thus NumberP, FixP, etc@. have to test a range. Note that NegInt is tested specially. @hinge !*JumpNotInType (Label Arg TypeTag)@\Generate code to JUMP if Tag(Arg) is not in the range @w([0 ... TypeTag, NegInt]). See above comment. @hinge !*JumpOn (Register LowerBound UpperBound LabelList)@\Used to support the CASE statement. This is usually written by hand and no pattern is used. It tests if Register is in range LowerBound @value[Lte] Register @value[Lte] UpperBound; if so, it jumps to the appropriate label in labellist, using (Register @value[MinusSign] LowerBound) as the index. If not in range, it Jumps to a label planted at the end of the label table. In some implementations, the label table has to be a jump table. @hinge !*JumpWithin (Label LowerBound UpperBound)@\This is also used to support the CASE statement, in the situation where the overall label range is large, and there are many sub-ranges. This generates code to JUMP to Label if LowerBound @value(LTE) (REG 1) @value(LTE) UpperBound. A default version uses !*JumpWLessP and !*JumpWLeq tests. [Perhaps should be modified to use ANY reg]. @end(group) @end(Description) The following @CMACRO@XS perform simple computations on their arguments. Binary operations take two arguments, (Dest Source), and leave the result in DEST. @begin(description) !*MkItem (Arg1 Arg2)@\Computes Arg1 @Value(Eq) Item(Arg1,Arg2); construct an Item into Arg1 from the tag in Arg1 and Information part in ARg2. May have to shift and mask both Arg1 and Arg2. Equivalent to !*WOR(!*Wshift(Arg1,24),!*Wand(Arg2,16#FFFFFF)) on the 68000 [This may actually use a stored preshifted version of the tag]. [[[[[Check the ORDER!!!! and use parameters rather than 24 and fffff]]]]]] !*WPlus2 (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1 + Arg2. Look for special cases of 1, -1, 0, etc. Note on the 68000 it checks for a small integer, i.e. -8..8 since these are done with a @dq[QUICK] instruction. [Ignore overflow?] !*WDifference (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1-Arg2. Look for special cases of 1, -1, 0, etc. !*WTimes2 (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1*Arg2. It first looks to see if Arg2 is constant and a power of 2. If so, it emits a corresponding !*Ashift(Arg1,PowerOfTwo Arg2). This check for special cases is in the pattern. !*AShift (Arg1 Arg2)@\Shift Arg1 by Arg2, using Arithmetic shift. Used to support !*WTIMES2. Should do appropriate Sign Extend. !*WShift (Arg1 Arg2)@\Shift Arg1 by Arg2, logically, doing 0 fill. !*WAnd (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 AND Arg2. BitWise AND, each bit of Arg1 is 1 only if BOTH corresponding bits of Arg1 and Arg2 are 1. !*WOr (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 OR Arg2. BitWise OR. !*WXOr (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 Xor Arg2. !*WMinus (Arg1 Arg2)@\Arg1 @Value(Eq) @Value(MinusSign) Arg2. !*WNot (Arg1 Arg2)@\Arg1 @Value(Eq) Logical NOT Arg2. !*Loc (Arg1 Arg2)@\Arg1 @Value(Eq) Address (Arg2). @end(description) The following are important optimizations, that may be initially implemented as procedures: @begin(description) !*Field (Arg1 Arg2 Arg3 Arg4)@\Arg1 @Value(Eq) Extract Field of Arg2 starting at Bit Arg3, of Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. The most significant bit is numbered 0 in our model. There is an assumption that Arg3 Arg4 are constants. !*SignedField (Arg1 Arg2 Arg3 Arg4)@\Arg1 @Value(Eq) Extract Field of Arg2 starting at Bit Arg3, or Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. The field is to be sign extended into Arg1. !*PutField (Arg1 Arg2 Arg3 Arg4)@\Deposit into Arg1 a field of Arg2 starting at Bit Arg3, or Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. @end(Description) @section(Organization of the Compiler and Assembler Source Files) The code is organized as a set of common files kept on the PC: directory, augmented by machine-specific files kept on other directories@Foot[These generally have logical names of the form PxxxC: where xxx is the root name of the directories for a given machine/OS implementation.]. The @dq[skeletal] common files and machine-specific files (mostly kept as compiled FASL files) make up the CROSS compiler and assembler. The machine-specific files customize the compiler for the specific target machine and assembler (currently we compile for @DEC20, @VAX750, @Apollo, @WICAT, and Cray-1). @subsection(Common Files) The machine-independent part of compiler is kept as PL:COMPILER.B@Foot[PL: is <PSL.LAP> or ~psl/lap.], built by PC:COMPILER.CTL. It consists of the files: @begin(description) PC:COMPILER.RED@\The basic compiler PC:COMP-DECLS.RED@\Common declarations configuring the compiler: installing the compiler specific functions, such as PA1FNs, COMPFNs, OPENFNS etc. These are described in the compiler chapter. PC:PASS-1-LAP.SL@\Basic PASS1 of @CMACRO/LAP process. PC:ANYREG-CMACRO.SL@\The @CMACRO and @anyreg pattern matcher and support functions. PC:COMMON-CMACROS.SL@\Standard or default @CMACRO@xs and @anyreg@xs used by most implementations. PC:COMMON-PREDICATES.SL@\Useful predicates to aid in writing the @CMACRO@xs. @end(Description) In addition, the following file is needed: @Begin(Description) PC:LAP-TO-ASM.RED@\Standard functions to convert LAP into machine-dependent assembly code. @end(Description) @subsection(Machine-Specific Files) For machine xxxx, the files: @begin(description) xxxx-COMP.RED@\Machine-Specific Compiler Patterns and Function installations. This file may have some special @CMACRO support in it@Foot{This is the case of extending the abstract machine for a particular implementation.}. xxxx-CMAC.SL@\Machine-Specific @CMACRO@xs and @anyreg@xs. xxxx-ASM.RED@\Definition of FORMATS, and special addressing mode conversion functions, declaration Pseudos, etc. xxxx-DATA-MACHINE.RED@\Smacros and constants to define @syslisp macros needed for the implementation. This file associates @syslisp functions with @CMACRO@xs for special cases. @end(description) Finally, during the compilation of XXXX- user files, the following two files: @begin(description) xxxx:GLOBAL-DATA.Red@\Describes GLOBAL symbols used everywhere. @end(description) @subsection(Building the CROSS Compiler) [For the moment, see the distribution guide for the Host machine]. @section(Design of LAP Format) The argument to the function LAP is a list of lists and atoms. The lists are instructions, pseudo-ops and @cmacro@xs, and the atoms are labels which are used to refer to positions in the code. Note these need not be IDs, but can also be strings, saving on ID space. Instructions should be of the form @w[(@i(opcode) . @i(operands))], where @i(opcode) is a mnemonic for an opcode, and @i(operands) is a list of operands. Each operand should be either an integer, which represents an immediate integer operand, a label, or a list of the form @w[(@i(mode) . @i(suboperands))]. A @i(mode) is an addressing mode, such as INDEXED or INDIRECT on the PDP-10, and DISPLACEMENT, DEFERRED, AUTOINCREMENT, etc@. for the VAX-11. REG must exist on all machines; others will be chosen as appropriate for the system. Remember that these are mainly used for @cmacro expansions rather than for writing code, so choose names for mnemonic value rather than brevity. @i(Suboperands) may also be operands, or they may be specific to the mode, e.g@. register names.@comment(more on @xlisp specific ones, QUOTE and FLUID) See also the READING/WRITING/TESTING of LAP operating note@cite[Griss82h]. @comment[We have a LOT to write here!] @subsection(Addressing Modes) @subsection(Register Designators) @subsection(Labels) @subsection(Storage Pseudos) @section(Implement LAP-TO-ASM) @SubSection(Needed Values) Values must be given for: @begin(description) MainEntryPointName!*@\An ID which is the main procedure name. NumericRegisterNames!*@\A vector of the symbolic names for the compiler registers. @end(description) In addition, each of the registers (as IDs) must be declared, using DefList to provide the string name of the register and flagging the property list of the ID with 'RegisterName. @subsection(Tables) The list ForeignExternList!* is used to remember each of the foreign functions that has been called in the course of a module so that the proper externs can be emitted. @SubSection(Printing routines) A number of routines which are used to print the strings, constants, etc@. are listed as follows: @begin(format) PrintString(S) PrintByte!,(X) TruncateString(S,n) PrintByteList(L) PrintByte(X) PrintHalfWordList(L) PrintHalfWord(X) PrintHalfWords(X) PrintOpcode(X) SpecialActionForMainEntryPoint() PrintNumericOperand(X) @end(format) @subsection(Symbol Mapping) The function ASMSymbolP(X) must be written to check whether a @Xlisp ID is also a legal symbol for the target assembler. @Subsection(Formats) The following formats must be declared to tell the LAP-TO-ASM routines how to print objects and the format of file names to use: CodeFileNameFormat!*, DataFileNameFormat!*, LabelFormat!*, CommentFormat!*, ExportedDeclarationFormat!*, ExternalDeclarationFormat!*, FullWordFormat!*, HalfWordFormat!*, ReserveDataBlockFormat!*, ReserveZeroBlockFormat!*, DefinedFunctionCellFormat!*, UndefinedFunctionCellInstructions!*, and the description for how to construct an item (for MkItem). @section(Independent Compilation) In order to maintain the PSL kernel as a set of reasonable sized modules (about 15) a method to permit (semi-)independent translation from LISP (or RLISP) to TLM assembly format was devised. This method records information about symbols and structures defined in one module and needed in another in a file called the SYM file. When a set of modules is to be assembled into a program, a fresh SYM file is allocated (usually called XXX-PSL.SYM or "Program-name.SYM"). Then as each module, MMM.RED is translated, the SYM file is first read in to initialize various SYMBOL counters. After the translation is complete an updated SYM file is written for the next step. When all modules are tranlated, a last (MAIN) module is translated, and some of the data information gathered in the SYM file is converted into global data declarations in the assembly file. Each module, MMM.RED (perhaps described by a MMM.BUILD file), is converted into 3 files, and updates to the SYM file: @begin(description) Code-File@\Contains the actual instructions for the procedues in the MMM file. May also contain "read-only" data, such as some strings or s-expressions. Typically called something like MMM.asm Data-file@\Contains data-objects that may get changed, typically WVAR and WARRAYs. This file typically called DMMM.asm or MMMd.asm. Init-file@\Contains S-expressions that were not compilable procedures found in the MMM.red file. Typically FLUID declarations, SETQ's and PUT's dominate this sort of code. This file will be read-in by the executing PSL after basic INITCODE is executed. Typically called MMM.INIT. @end(description) The .SYM file data structures are updated. These structures are: @begin(description) Startup-Sexpressions@\Certain s-expressions must be evaluated during INITCODE, before the .INIT files can be read. These are collected into a single procedure, and compiled as INITCODE in the MAIN module. This is the (SAVEFORCOMPILATION (QUOTE ...)) expression in the SYM file. ID list@\New IDs encountered in this file are added to a list of IDs in ID# order. IDs are referred to by ID#; list is called ORDEREDIDLIST!*. NEXTIDNUMBER!*@\The next ID# that will be allocated to the next new ID. STRINGGENSYM!*@\A string representing the last generated symbol-name. Used for internal labels, and external names that are too complex. Individual ID descriptors@\Each ID is now "installed" with a set of PUT's, indicating its ID#, the assembly symbol that is its entry point, if it is a WCONST, WVAR ,WARRAY etc. for example: @begin(Verbatim) (PUT 'INFBITLENGTH 'SCOPE 'EXTERNAL) % An exported WCONST (PUT 'INFBITLENGTH 'ASMSYMBOL 'NIL) % no symbol allocated (PUT 'INFBITLENGTH 'WCONST '18) % Its compile time value (PUT 'STACKUPPERBOUND 'SCOPE 'EXTERNAL) % An exported WVAR (PUT 'STACKUPPERBOUND 'ASMSYMBOL '"L2041") % The Assembly SYMBOL (PUT 'STACKUPPERBOUND 'WVAR 'STACKUPPERBOUND) % Type of VAR (PUT 'TWOARGDISPATCH 'ENTRYPOINT '"L1319") % An internal FUNCTION and its Assembly % SYMBOL (PUT 'RELOAD 'ENTRYPOINT 'RELOAD) % A simple entry point, not renamed (PUT 'RELOAD 'IDNUMBER '552) % Its ID number. SYMFNC(552)-> % JUMP RELOAD (PUT 'CADR 'ENTRYPOINT 'CADR) % Another simple entry point (PUT 'CADR 'IDNUMBER '229) (PUT 'LIST2STRING 'ENTRYPOINT '"L0059") % Entry point, renamed because too long % SYMFNC(147)->JUMP L0059 (PUT 'LIST2STRING 'IDNUMBER '147) (PUT 'SPECIALRDSACTION!* 'IDNUMBER '598) % A Global variable, INITIALLY NIL (FLAG '(SPECIALRDSACTION!*) 'NILINITIALVALUE) (PUT 'GLOBALLOOKUP 'ENTRYPOINT '"L3389") (PUT 'GLOBALLOOKUP 'IDNUMBER '772) (PUT 'CLEARCOMPRESSCHANNEL 'ENTRYPOINT '"L2793") (PUT 'CLEARCOMPRESSCHANNEL 'IDNUMBER '678) @end(Verbatim) @end(description) The contents of SYMFNC are filled in during the translation of the MAIN module, and JUMPs to the entrypoints of symbols that have them are filled in. Other symbols get a JUMP to the UndefinedFunction Entry point. In general, individual modules can be retranslated, since the information they generate is initially taken from the SYM file (ensuring that ID's and SYMBOLS get the same IDNUMBER and ENTRYPOINT as before). The procedure is to translate the desired model (modules) again, replacing the CODE-FILE, DATE-FILE and INIT-FILE previously produced, and also to retranslate the MAIN module, since additonal symbols S-expressions etc may have been produced, and therefor need to be converted into INIOTCODE or HEAP or SYMBOL data. @subsection(Data Pseudos) The following are pseudo operations (from the @68000 version) which must have a procedure to implement them in xxxx-ASM.RED: HalfWord, Deferred, Displacement, Indexed, Immediate, Iconst, AutoIncrement, AutoDecrement, Absolute, and ForeignEntry. @section(Configure the Compiler) This is still somewhat arcane. Basically, the compiler tables that select the COMPFN's and OPENFN's and patterns need to be installed. The most common method of doing this is to start from the xxxx-COMP.RED file most like the target machine X@Foot[It is still the case that you need a compiler wizard to help you with this as the details are still changing and often undocumented, with a lot of "You have to do this, to do that, but ..."]. [Effort is required to describe this more clearly] @Section(Write the Additional LAP Modules) A variety of small LAP routines are required for I/O, system interface, core-saving, efficient function-linkage, variable binding, etc. Some of these are described in the following System Dependent Section. Others are: @subsection(Apply-LAP) These procedures are rather important, and unfortunately tricky to write. They are used to enable compiled-code to call interpreted code and vice versa. When they are used, the registers R1...Rn have the arguments loaded in them, so SYSLISP can't be used. The routines are CodeApply(codePtr,Arglst), CodeEvalApply(CodePtr,Arglst), BindEval(Formals,Args), CompileCallingInterpreted(IdOfFunction), FastApply(), and UndefinedFunction(). These are partially described in SYSLISP, and written in LAP with mostly @CMACRO@XS@Foot[See P20:APPLY-LAP.RED and PV:APPLY-LAP.RED.]. Need to discuss tricks in more detail, devise a set of tests. @subsection(Fast-Bind) This consists of efficient routines written in LAP (using mostly @CMACRO@xs) to BIND and UNBIND fluid variables. The specifics depend on how the !*LAMBIND, !*PROGBIND and !*FREERESTR @CMACRO@xs are implemented. In general, a machine specific "fast-call" is used, rather than the more general recursive LISP call, and a list of ID numbers and values ( NIL or register numbers) are passed in a block. The FASTBIND routine uses the ID number to find the current value of the ID, and saves the ID number and this value on the binding stack. Then NIL (for PROGBIND), or the register value (for LAMBIND) is installed in SYMVAL(ID#). Note that the compiler registers R1...Rn should not be changed, so either they have to be saved, or other "hidden" registers have to be used. Since some hidden registers may be used in the implementation of certain @CMACRO@xs, care has to be exercized. FASTUNBIND is usually simpler, since all it needs is a number of @W[(ID# . Old-value)] pairs to pop off the Binding stack, and restore @Foot[See P20:FAST-BINDER.RED or PV:FAST-BINDER.RED for some ideas.]. @SECTION(System Dependent Primitives) The following set of functions are needed to complete the system-dependent part of @PSL: @subsection(System-dependent input and output) @PSL uses a one-character-at-a-time stream model for I/O. I/O channels are just small integers in a range from 0 to 32 (32 was chosen for no particular reason and could easily be increased if desired). They are used as indices to the WArrays ReadFunction, WriteFunction and CloseFunction, which contain the names (as @xlisp items) of the functions to be called. Thus a stream is an object with a set of operations, buffer(s), and static vaiables associated with it. The current implementation of streams uses parallel vectors for each of the operations that can be associated with a stream. The Channel Number is used as an index into these vectors. For example, the standard input channel is 0@Foot[This corresponds to the @UNIX STDIO channel "stdin".] thus ReadFunction[0] contains 'TerminalInputHandler, which is a function used to get a character from the terminal. The system-dependent file input and output functions are responsible for associating these channels with @ei[file pointers] or @ei[JFNs] or whatever is appropriate to your system. These functions must also perform any buffering required. We have been lucky so far because the @UNIX and Tops-20 systems have single character primitives@Foot[Thus the operating system hides the buffering.]. The reading function is responsible for echoing characters if the flag !*ECHO is T. It may not be appropriate for a read function to echo characters. For example, the "disk" reading function does echoing, while the reader used to implement the @b[Compress] function does not. The read function should return the ASCII code for a line feed (EOL) character to indicate an end of line (or "newline"). This may require that the ASCII code for carriage return be ignored when read, not returned. The VAX UNIX version of SYSTEM-IO.RED (stored on PV:@Foot[PV: is <PSL.VAX-Interp> or ~benson/psl/vax-interp.]) is the simplest, since the UNIX STDIO library is so close to this model. This is a good starting point for a new version. It also uses the file PSLIO.C, which contains the array @w[@Value(UnderScore)FILEPOINTEROFCHANNEL], used for channel allocation. The function @b(ClearIO) is called at system-startup time and when the function RESET is called. It should do all dynamic initialization of the system, but should not close any open files. Static initialization of slots in the function arrays is done in the system-dependent file IO-DATA.RED, and the array used for channel allocation should also have initialized slots for the channels used for terminal input (STDIN!* = 0), terminal output (STDOUT!* = 1) and channels 2 thru 4, used by BLDMSG, COMPRESS/EXPLODE and FLATSIZE. The variable ERROUT!* should have a terminal output channel associated with it. This may be shared with STDOUT!* as in the @Dec20, or be associated with a separate error diagnostic stream, as on the VAX. Channel allocation is handled by the system-dependent part of I/O, so when the @Xlisp function Open calls the function @b(SystemOpenFileSpecial) for a non-file-oriented I/O stream, it should just mark a free channel as being in use and return it. @b(SystemMarkAsClosedChannel) does the opposite, returning a channel to the pool of available ones. @b(SystemOpenFileForInput) and @b(SystemOpenFileForOutput) each takes a string as an argument and should return a channel and set appropriate functions in the corresponding slots in ReadFunction, WriteFunction and CloseFunction. If a file cannot be opened, a continuable error should be generated whose error form is (OPEN @dq[file name] 'TYPE), where TYPE is either INPUT or OUTPUT. Terminal output should be unbuffered if possible. If it must be buffered, it should be flushed when terminal input is done and when EOLs are written. Terminal input should be line buffered, using line editing facilities provided by the operating system if possible. The terminal input routine is responsible for the display of the variable PromptString!*, using a @PSL channel for output if desired, as the VAX version does. The @Dec20 terminal input routine uses a line editing facility that redisplays the prompt and previously typed characters when a Control-R is typed. End of file on input is indicated by returning a character which is CHAR EOF, Control-Z (ASCII 26) on the @Dec20 and Control-D (ASCII 4) on UNIX. This can be changed to any control character. The file SCAN-TABLE.RED will contain the CharConst definition for EOF, and a copy of LispScanTable!* with an 11 (delimiter) in that position. @subsection(Terminate Execution) The function QUIT(); terminates execution. It should probably close open files, perhaps restore system state to "standard" if special I/O capabilities were enabled. On some systems, execution can continue after the QUIT() at the next instruction, using a system command such as START or CONTINUE; on others, the core-image cannot be continued or restarted (see DUMPLISP(), below). On the DEC-20, the HALTF jsys is used, and execution can be continued. On the VAX under UNIX, a Stop signal (18) is sent via the "kill(0,18)" call. This also can be continued under Berkeley 4.1 UNIX. See the file SYSTEM-EXTRAS.RED on PV: and P20: @subsection(Date and Time) The function TIMC(); is supposed to return the run-time in milliseconds. This time should be from the start of this core-image, rather than JOB or SYSTEM time. It is used to time execution of functions. Return it as a full-word, untagged integer in register 1. On the DEC-20, we use the RUNTM jsys, on the VAX the C call on "times" is used, and multipled by 17, to get 1/1020'ths of a second. While not yet required, a TIMR() to get REAL, or WALL, time may be useful@Foot[See TIMC.RED on P20: and PV:.]. The DATE(); function is supposed to return a Tagged @XLISP string containing the current date. No particular format is currently assumed, and the string is used to create welcome messages, etc. Later developments may require a standard for TIMESTAMPS on files, and may also require a CLOCK-time function. The Allocator function GtSTR(nbytes) may be useful to get a fresh string to copy the string returned by a system call into. The string should be 0-terminated. The DEC-20 uses ODTIM, and "writes" to the string in "6-jun-82" format. On the VAX, the "ctime" call is used, and the result "shuffled" into the same format as the DEC-20@Foot[See SYSTEM-EXTRAS.RED on PV: and P20:]. @subsection(ReturnAddressP) The function RETURNADDRESSP(x); supports the backtrace mechanism, and is supposed to check that the instruction before the supposed address X, is in fact a legal CALL instruction. It is used to scan the stack, looking for return addresses@Foot[Very TRICKY, see SYSTEM-EXTRAS.RED on PV: and P20:]. @subsection(Interrupt Handler) Also very crude at present; on the DEC-20, written as a loadable module, P20:20-INTERRUPT.RED, using the JSYS package. This enables CTRL-G, CTRL-T, some stack and arithmetic overflows, binding them to some sort of Throw or Error routine. On the VAX, the file PV:TRAP.RED defines some signal setup, and InitializeInterrupts routine, and is included in the kernel. It associates each trap with a STDERROR call with a given message. Not yet standardized. We really should "bind" all trappable interupts to an appropriate THROW('!$SIGNAL!$,n), and indicate whether to treat as a Fatal Error, a Continuable Error, or not an Error at all. @subsection(Core Image Saving) A way in which @PSL (and most @XLISP@xs) get used involves the ability to load @XLISP and FASL code into an executing @PSL, saving this augmented "core-image" in a named file for subsequent restart later. Some Operating Systems permit a running program to be saved into an executable file, and then restarted from the beginning; others permit the saved program to be continued at the instruction following the call to the SAVE routine. Some operating systems do not normally permit or encourage the saving of a running program into an executable file, and there is a lot of work to be done. The model currently used in @PSL is that a call on DUMPLISP(); does the following (this is based on VAX and DEC-20 experience, and could change as Apollo and CRAY are completed): @begin(enumerate) calls RECLAIM(); to compact the heap, or move the upper heap into the lower heap. @Comment{How is it told that this is a cleanup reclaim that is to put the results in the "lower" heap???} makes some system calls to free unused space, decreasing the executable image; space is returned from HEAP, BPS and STACK. the core-image is saved in a file, whose name is the string in the global variable, DumpFileName!* (this string may have to be passed to the system routine, similar to I/O, using a small peice of LAP as interface, or using the Foreign function protocol); execution continues without leaving the running program; to terminate, the QUIT(); function must be called explicitly [this may not be possible on some systems, and may require a change in the model, or a machine specific restriction]. the saved executable file will restart "from-the-top", i.e. by calling the machine specific "startup" function defined in MAIN-START.RED, which calls initialization functions CLEARBINDINGS(), CLEARIO(), INITIALIZEINTERRUPTS(), etc. Then the Startup function calls MAIN();, which can be redefined by the user before calling DUMPLISP();. MAIN() typically calls StandardLISP() or RLISP(), or some other TopLoop. This startup function also has a @XLISP accesible name, RESET. @end(Enumerate) On some machines, the core-image will automatically start "from-the-top", unless effort is expended to change the "restart-vector" (e.g@. the TOPS-20 SSAVE jsys on the DEC-20); on others, an explicit LINKE CALL (a JUMP) to RESET should be included after the core-save call, to ensure execution of RESET (e.g@. the CTSS DROPFILE call on the CRAY-1). On the VAX under UNIX, a new function UNEXEC was written in C, to convert an executing program back into "a.out" format. See the files MAIN-START.RED and DUMPLISP.RED on P20: and PV:, and the preliminary documentation on the @apollo MAP_CODE.TXT, on PD:. @section(How LAP/TLM assembler works) @Section(How the LAP works) This discription of how the resident assembler (LAP) works is taken from the 68000 implementations. Refer to the diagram below to aid the understanding of this description. ALM instructions are passed into the procedure called LAP. The first thing LAP does is to pass them through the procedure PASS1LAP to transform ALM into TLM. The TLM is handed to OptimizeBranches to check to see if long branches are needed. OptimizeBranches is responsible for computing the offset of each label from the beginning of the function. A list called BranchAndLabelAlist is created which stores the labels and their offsets from the start of the code for this function. Upon the exit from OptimizeBranches the user may turn on the flag "PGWD" and will be able to see the current state of the code. If the code is to be compiled into memory and not fasled to a file then BPS space is allocated. Now the code make take one of three parallel paths. If the code is a label then it is ignored. If the instruction is an instance of !*Entry then the instruction is passed to the procedure SaveEntry to establish the address of the entry point of the code. On all other cases the instruction is passed to the procedure deposit instruction. This is often a good procedure to trace when debugging lap so that one can see what is actually heading off to be depsoited. Once the code has passed through one of the above three paths, the function defineEntries is called which loads the new code pointer into the function cell in the SYMFNC table. Following this the code pointer is tagged as code and returned as the result value of the function LAP. The following details are provideed as a guide to writing your own assembler. Consderation should be give to @begin(enumerate) Regular vs Irregular Machines Templates to Assemble Portions of Instruction Variable Length Instructions Alignment Problems Data Psuedos @xlisp Specific Pseudos @end(enumerate) @section(How do opcodes get defined for the LAP assembly process) There are three procedures used to define the opcodes. The first is DefineOpcode which defines, sets the necessary properties on the opcode's property list, for 680000 opcodes that have no ,byte,word, or long variants. The second function is DefineOpcodes (notice it is simply the plural of the first function) which defines an opcode with variants for byte,word, and long mode. And third is the function DefineCCOpcodes which sets up the properties for all the condition codes. @Section(Description of DefineOpcode) The function DefineOpcode an have three, four, or five arguments. They are defined to be: @begin(enumerate) The opcode name or id. The base 2 value of the opcode, only the constant bits in the opcodes binary value are given initially, the varible fields of an opcode are ORed into the word later. These are all two bytes long. This is tagged on a functions property list as its OpcodeValue. The function to be used to assemble this opcode, referred to on the property list by a functions InstructionDepositFunction. The forth field if present represents the mode to be used with this instruction: either byte, word, or long mode. The default is always word mode. This value is stored on the property list under the tag of Size. The fifth field is the number of bytes that the instruction will take up in the resulting binary code. Generally, only instructions that take no arguments will have this field filled in. This value is stored on the property list under the tag of InstructionLength. @end(enumerate) DefOpcode finally calls the function EvDefopcode which puts all the properties on the property list. @Section(How the Function DefOpcodes works) This function works just like the previous function DefOpcode except that it takes one less field, the size field which tells how the opcode will be used: byte, word, or long. This procedure will define an opcode for each case. For example if an opcode name is move then an id with associated property list will be created for move.b, move.w, and move.l. @Section(How the procedure DefCCOpcodes Works) This function was written just to save typing in all the cases of opcodes that use the condition codes. It does that same thing as DefOpcode above but for each condition code variant of an opcode. @section(Ok so what happens in a functions instruction depositfunction??) The opcode and oprands are selected out of the list and if the operands are not normal then they are passed throught the function effective address which classifies then as to the 68000 convention of register and mode. Purpose: convert an operand from symbolic to numeric form. Returns: Addressing mode in the range 0..7 -------------------------------------------------- M68K addressing modes (from appendix B of the M68K User's Manual) Addressing Mode Mode Reg Valid Modes* Assembler Data MEM Cont Alter Syntax Data Register Direct 000 reg no. X - - X Dn Address Register Direct 001 reg no. - - - X An Addr Reg Indirect 010 reg no. X X X X (An) with PostIncrement 011 reg no. X X - X (An)+ with PreDecrement 100 reg no. X X - X -(An) with Displacement 101 reg no. X X X X d(An) with Index 110 reg no. X X X X d(An,Ri) Absolute Short 111 000 X X X X xxxx Absolute Long 111 001 X X X X xxxxxxxx PC with Displacement 111 010 X X X - d(PC) PC with Index 111 011 X X X - d(PC,Ri) Immediate 111 100 X X - - #xxxxxxxx * = Valid Addressing modes for each type of Addressing Category Data - used to refer to data operands Mem = Memory - used to refer to memory operands Cont = Control - used to refer to memory operands without an associated size Alter = Alterable - used to refer to alterable (writeable) operands -------------------------------------------------- Operand is of the form: case 1: numeric immediate data or (immediate x) case 2: non-numeric atom a local label, which uses PC with displacement case 3: (reg x) x is a number or symbolic register name case 4: (deferred (reg x)) address register indirect in Motorola jargon case 5: (autoincrement (reg x)) address register indirect with postincrement case 6: (autodecrement (reg x)) address register indirect with predecrement case 7: (displacement (reg x) n) if (reg x) is an A reg then if n is 0 then (deferred (reg x)) else address register indirect with displacement else if (reg x) is a D reg then address register indirect with index, using A6 (zero) case 8: (indexed (reg x) (displacement (reg y) n)) address register indirect with index case 9+: various Lisp addressing modes, all of which are absolute long addresses The value returned by this function is the mode field of the instruction for the operand. In addition, the fluid variables OperandRegisterNumber!* and OperandExtension!* will be set. If there are no words to follow, OperandExtension!* will be set to NIL. Otherwise, possible values of OperandExtension!* are: number or (immediate exp) immediate data (number) 16-bit signed displacement non-numeric atom pc relative label (displacement reg disp) index extension word other absolute long, i.e. LISP addressing mode LAP is a complete assembly form and can be used by @xlisp programmers to write any legal assembly code@Foot{There is no real guarantee that the entire set of machine opcodes is supported by the LAP. An implementor may have chosen to implement only those constructs used by the compiler-produced code or explicitly used in hand written LAP. The reason for this partial implementation is that many modern processors have included operations to facilitate @ei[high level language compilation], which often seem to be less than useful.} @section(Binary FAST Loader,FASL) [Explain FASL in general] [Explain essential problem, relocation of machine addresses and LISP ids] [Give big-picture of FASL] [Find MAGUIREs pictures of FASL blocks or regenerate ] This section is a guide to the internal workings of faslout and then faslin. The user begins the faslout procedure by calling the procedure faslout with a string that does not have the extension (because it will add the appropriate binary extension for you). However, when fasling in, the file name requires the binary extension [Change this inconsistency]. Inside the procedure faslout, the file name is assigned to the fluid variable ModuleName!*. Depending upon the setting of the flag !*Quiet_Faslout, the system will either print out a greeting message or not. Next, an output binary file is opened using the argument file name. It will return the channel number to a fluid variable CodeOut!*. CodeFileHeader is called to put in a header in the output file. CodeFileHeader writes out a word consisting of the Fasl Magic Number (currently set to 99). This magic word is used to check consistency between old and current fasl format files (an error is given upon fasling in the file if there is not a 99 as the first word). Therefore, the system must consistently modify that number when a new fasl format is produced. To continue, we need to understand the allocation that takes place within the Binary Program Space (BPS). The BPS is a large, non-collected space that contains compiled code, warrays, the string assocaited with interned ID's, constant data in fasl files, etc. Space is allocated from both ends of the space. Compiled code is allocated from the bottom (using NextBPS as a pointer) and warrays are allocated from the top (using LastBPS as the pointer). When an allocation is attempted, the desired size is checked to see if it will cause LastBPS and NextBPS to cross; if it will, an error message will be printed. The next step is to allocate 2/3 or the remaining BPS from the top. @begin(verbatim,leftmargin 0) .----------------------------. | | | WArrays | | | | | Last_BPS>|----------------------------| <-FaslBlockEnd!* ---. | Code | | | | | | | | | | 2/3 |============================| <-CodeBase!* | | Bit Table | | |============================| <-BitTableBase!* ---' | | | | Next_BPS>|----------------------------| | | | | | | `----------------------------' Binary Program Space @end(verbatim) The procedure AllocateFaslSpaces will setup the following fluid variables. FaslBlockEnd!* will be the address to the top of the available space for this particular allocation. BitTableBase!* points to the beginning of the BitTable. CurrentOffset!* keeps a pointer into the codespace of this allocation to the next available point to add more code. BitTableOffset!* is a running pointer to the current location in the BitTable where the next entry will go. CodeBase!* is the base pointer to the beginning of the code segment for this allocation. MaxFaslOffset!* is the max size of the codespace allowed for this implementation. OrderedIDList!* keeps record of the ID's as they are added. NextIDNumber!* is a base number used just in fasl files to indicate which IDs are local and which are global. It is assumed that there will never be more than 2048 pre-allocated ID's, currently there are 129. The first 128 preallocated IDs are ASCII codes(0-127) and the last one is NIL(128). Everything is now setup to begin fasling PSL code out to the file. The remainder of the faslout procedure sets up three more fluid variables. !*DEFN is set to T which indicates that you are not going to do normal evaluation from the top loop and from files such as using the functions IN and DSKIN. DFPRINT!* signals that DFPRINT!* is now used as the printing function. The procedure used will be DFPRINTFasl!*. !*WritingFaslFile is set to T to let the system know that fasling out is goping on as opposed to compiling code directly into memory inside the PSL system. @subsection(Binary I/O and File Format) @u[Current FASL file format:] Check accuracy, this was PC:fasl-file.Specs @begin(description) Word@\Magic number (currently 99).@comment{ Why the magic number 99??? } Word@\Number of local IDs. Block@\Local ID names, in order, in regular @xlisp format (string size followed by block of chars).@comment{ need to specify that the string size is given as a word, and the character counts is interms of bytes} Word@\Size of code segment in words. Word@\Offset in addressing units of initialization procedure. Block@\Code segment. Word@\Size of bit table in words (redundant, could be eliminated). Block@\Bit table. @end(description) @subsection(Relocation/Bit Table) Describes how to adjust addresses and ID numbers in previous Code Segment. [Should add GENSYM generator option.] This is a block of 2 bit items, one for each \addressing unit/ in the code block.@comment{ Are we committed to two bits forever? } @begin(description) 0@\Don't relocate at this offset. 1@\Relocate the word at this offset in the code segment. 2@\Relocate the (halfword on VAX, right half on 20) at this offset. @comment[Can this be generalized some more????] 3@\Relocate the info field of the @xlisp item at this offset. @end(description) The data referred to by relocation entries in the bit table are split into tag and info fields. The tag field specifies the type of relocation to be done:@comment{ Where is this data stored??? } @begin(description) 0@\Add the code base to the info part. 1@\Replace the local ID number in the info part by its global ID number. 2@\Replace the local ID number in the info part by the location of its value cell. 3@\Replace the local ID number in the info part by the location of its function cell. @end(description) Local ID numbers begin at 2048@comment{why this magic number???}, to allow for statically allocated ID numbers (those which will be the same at compile time and load time). @subsection(Internal Functions) [IS there any special handling of these, or restrictions] @subsection(Foreign Functions, Externs, etc) [Explain why cant do in FASL now. Need to do run-time look up of LOADER symbols, and use in LAP/FASL part of things. Will need to add extra RELOC types to FASL]. @subsection(Init Code) [Explain how executable -sexpressions that are not procedure definitions are gathered into a single LISP procedure, compiled, and given name, sort of !*!*FASL-INIRTCODE!*!*, or some such. Is called as last action of LOAD. Explain current restriction on FASL initcode size, suggest soluitions] @subsection(Annotated FASL file example) @begin(verbatim) *Annotated version of a dump* procedure adder(x); begin scalar y; y:=x; return y+1; end; Dump of "trythis.b" 000000: 0020 0001 E7DF FEDF 0000 0080 0000 00A0 000010: 1800 0000 0000 0000 0000 0000 0000 0000 000020: 0000 0080 0000 0063 16#63 is the magic number which indicates that is a FASL file 0000 0003 Number of local IDs 0000 0004 The first ID, in the form Length of String, String name 000030: 4144 4445 ADDER 5200 0000 0000 0003 Second ID, 3 (+1) characters "ADD1" 4144 4431 ADD1 000040: 0000 0000 0000 0007 Third ID, 7 (+1) characters of "PUTENTRY" 5055 5445 PUTENTRY 4E54 5259 000050: 0000 0000 0000 0003 Fourth ID, 3 (+1) characters "EXPR" 4558 5052 EXPR 0000 0000 000060: 0000 000A CodeSize = 10 words 0000 000A Offset of INIT function -------------------- Code Block 2649 MOVEA.L A1,A3 2449 MOVEA.L A1,A2 4EF9 C000 JMP C000 0801 ^ Relocate Function cell (ID.1 call on "ADD1") 000070: 0801 ---------- The init code 267C 0000 0000 MOVEA.L #0,A3 247A 0010 MOVEA.L 10(pc),A2 227A 0008 MOVEA.L 8(pc),A1 000080: 4EF9 C000 0802 JMP C000 0802 ^ Relocate Function cell (ID.2 = "PUTENTRY") FE40 0800 (ID.0 the procedure ^ Relocate ID number name "ADDER") FE40 0803 (ID.3 the procedure ^ Relocate ID number type "EXPR") 0000 -------------------- Bit Table Section 000090: 0000 0003 Length of Bit table in words -------------------- Bit Table 0004 0000 : 0000 0000 0000 0100 0000 0000 0000 0000 ^ = Relocate Word 0000 040C : 0000 0000 0000 0000 0000 0100 0000 1100 Relocate Word ^ ^ Relocate Inf------------' 0C00 0000 : 0000 1100 0000 0000 0000 0000 0000 0000 ^ Relocate Inf @end(verbatim) [Explain how to use a BDUMP routine to examine this] @subsection(Binary I/O) The following functions are needed for FASLIN and FASLOUT: @i(BinaryOpenRead(Filename:string):system-channel) This should take a filename and open it so that binary input can be done. The value returned is used only by the other functions in this group, and so can be whatever is appropriate on your system. @i(BinaryOpenWrite(Filename:string):system-channel) Similar to BinaryOpenRead, open a file for binary output. @i(BinaryClose(SChn:system-channel):none returned) SChn is the value returned by BinaryOpenRead or BinaryOpenWrite. The file is closed. @i(BinaryRead(SChn:system-channel):word) One word (i.e. Lisp item sized quantity) is read from the binary file. On the Dec-20 this is done using the @i(BIN) jsys with the file opened in 36-bit mode using a 36-bit byte pointer. The VAX Unix implementation uses @i(getw) from the stdio library. @i(BinaryReadBlock(SChn:system-channel, A:word-address, S:integer):none returned) S words are read from the binary file and deposited starting at the word address A. The Dec-20 version uses the @i(SIN) jsys and VAX Unix uses the @i(fread) function. @i(BinaryWrite(SChn:system-channel, W:word):none returned) One word is written to the binary file. On the Dec-20 this is done using the @i(BOUT) jsys with the file opened in 36-bit mode using a 36-bit byte pointer. The VAX Unix implementation uses @i(putw) from the stdio library. @i(BinaryWriteBlock(SChn:system-channel, A:word-address, S:integer):none returned) S words starting at the word address A are written to the binary file. The Dec-20 version uses the @i(SOUT) jsys and VAX Unix uses the @i(fwrite) function. @i(BitTable(A:word-address, B:bit-table-offset):integer) This is similar to @i(Byte) and @i(HalfWord), except that a 2-bit unit is being extracted. A is a word address, the base of a table of 2-bit entries. The one B entries from the beginning is returned. @i(PutBitTable(A:word-address, B:bit-table-offset, I:integer):) Analagous to @i(PutByte) and @i(PutHalfWord), except that a 2-bit unit is being deposited. A is a word address, the base of a table of 2-bit entries. The low-order 2 bits of the integer I are stored at offset B. [Explain how to test Binary I/O, in test N] @subsection(Miscellaneous) To use EMODE/NMODE and PRLISP on some systems, a "raw" I/O mode may be required. See the PBIN, PBOUT, CHARSININPUTBUFFER, ECHOON and ECHOOFF functions in EMOD2:RAWIO.RED and SYSTEM-EXTRAS.RED. Some sort of system-call, fork or similar primitives are useful, clearly system dependent. See the JSYS and EXEC package on P20:, the SYSTEM call in PV:SYSTEM-EXTRAS.RED (written in C as a Foreign Function), or the SYSCALL on the APOLLO. This set is not yet standardized. |
Added psl-1983/3-1/doc/nmode/chart.ibm version [baf2c6684b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>CHART.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 202/9836 NMODE Command Summary 201/11 February 1983 202/Information 201/What Cursor Position C-X = Show Function on Key M-? List Matching Commands <help> 202/Files 201/Find File C-X C-F Write File C-X C-W Save File C-X C-S Save All Files M-X Save All Files Write Region to File M-X Write Region Append Region to File M-X Append to File Prepend Region to File M-X Prepend to File Insert File M-X Insert File Revert File M-X Revert File Set Visited Filename M-X Set Visited Filename 202/Buffers 201/Find File C-X C-F Select Buffer C-X B Select Previous Buffer C-M-L List Buffers C-X C-B Go to Buffer Start M-< (or) <clr-end> Go to Buffer End M-> (or) Shift-<clr-end> Kill Buffer C-X K Kill Some Buffers M-X Kill Some Buffers Append Region to Buffer C-X A Rename Buffer M-X Rename Buffer Insert Buffer M-X Insert Buffer Set Buffer Not-Modified M-~ 202/Regions 201/Kill Region C-W Copy Region M-W Fill Region M-G Upcase Region C-X C-U Downcase Region C-X C-L Append Region to File M-X Append to File Prepend Region to File M-X Prepend to File Append Region to Buffer C-X A 202/The Mark 201/Set/Pop Mark C-@ Exchange Point and Mark C-X C-X Set Mark at Beginning C-< Set Mark at End C-> Mark Word M-@ Mark Paragraph M-H Mark Form C-M-@ Mark Defun M-Backspace Mark Whole Buffer C-X H 202/Characters 201/Move Forward Character C-F (or) <right-arrow> Move Backward Character C-B (or) <left-arrow> Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Transpose Characters C-T Quote Character C-Q 202/Lines 201/Move to Next Line C-N (or) <down-arrow> Move to Previous Line C-P (or) <up-arrow> Goto Start of Line C-A Goto End of Line C-E Kill Line C-K (or) <del-ln> Transpose Lines C-X C-T Center Line M-S Join To Previous Line M-^ Insert Blank Line C-O (or) <ins-ln> Split Line C-M-O Delete Blank Lines C-X C-O Delete Matching Lines M-X Delete Matching Lines Delete Non-Matching Lines M-X Delete Non-Matching Lines 202/Words 201/Move Forward Word M-F (or) Control-<right-arrow> Move Backward Word M-B (or) Control-<left-arrow> Forward Kill Word M-D Backward Kill Word M-Rubout Mark Word M-@ Transpose Words M-T Upcase Word M-U Downcase Word M-L Capitalize Word M-C 202/Sentences 201/Move Forward Sentence M-E Move Backward Sentence M-A Forward Kill Sentence M-K Backward Kill Sentence C-X Rubout 202/Paragraphs 201/Move Forward Paragraph M-] Move Backward Paragraph M-[ Mark Paragraph M-H Fill Paragraph M-Q 202/Killing and Unkilling Text 201/Kill Line C-K (or) <del-ln> Forward Kill Word M-D Backward Kill Word M-Rubout Forward Kill Sentence M-K Backward Kill Sentence C-X Rubout Forward Kill Form C-M-K Backward Kill Form C-M-Rubout Kill Region C-W Copy Region M-W Yank Killed Text C-Y Yank Previous Kill M-Y Append Next Kill C-M-W 202/Deleting Text 201/Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Delete Horizontal Spaces M-\ Delete Blank Lines C-X C-O Delete Matching Lines M-X Delete Matching Lines Delete Non-Matching Lines M-X Delete Non-Matching Lines 202/String Search 201/Foward Search C-S Reverse Search C-R Count Occurrences M-X Count Occurrences 202/String Replacement 201/Query Replace M-% Replace String C-% 202/Indentation 201/Back to Indentation on Line M-M Indent Line Tab Indent New Line Newline Indent Form C-M-Q Indent Region C-M-\ 202/Text Filling and Justification 201/Set Fill Prefix C-X . Set Right Margin C-X F Fill Region M-G Fill Paragraph M-Q Fill Comment M-Z Auto Fill Mode (toggle) M-X Auto Fill Mode 202/Case Conversion 201/Upcase Word M-U Downcase Word M-L Capitalize Word M-C Upcase Region C-X C-U Downcase Region C-X C-L 202/Modes 201/Enter Lisp Mode M-X Lisp Mode Enter Text Mode M-X Text Mode 202/Lisp Forms 201/Move Forward Form C-M-F Move Backward Form C-M-B Forward Kill Form C-M-K Backward Kill Form C-M-Rubout Transpose Forms C-M-T Mark Form C-M-@ Indent Form C-M-Q 202/Lisp Lists 201/Move Backward Up List C-( Move Forward Up List C-) Move Forward Into List C-M-D Insert Parens M-( 202/Lisp Defuns 201/Mark Defun C-M-H Beginning of Defun C-M-A End of Defun C-M-E Execute Defun C-] D 202/Lisp Execution 201/Execute Form C-] E Execute Defun C-] D Quit from Break Loop C-] Q Abort from Break Loop C-] A Backtrace from Break Loop C-] B Continue from Break Loop C-] C Retry from Break Loop C-] R 202/Screen Management 201/Redisplay Screen C-L Reposition Window C-M-R Scroll to Next Screenful C-V (or) <recall> Scroll to Previous Screenful M-V (or) Shift-<recall> Scroll Buffer Up One Line Control-<recall> Scroll Buffer Down One Line Shift-Control-<recall> Invert Video C-X V 202/Windows 201/Two Windows C-X 2 One Window C-X 1 Go to Other Window C-X O Exchange Windows C-X E Scroll Other Window C-M-V Grow Window C-X ^ |
Added psl-1983/3-1/doc/nmode/commands.r version [4346315fc6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @fnc(append-next-kill-command) @cmd(Append Next Kill) @key(C-M-W) @seeglobal(Kill Ring) @acttype(Move Data) @cmddoc Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. @end @fnc(append-to-buffer-command) @cmd(Append To Buffer) @key(C-X A) @topic(Buffers) @seedef(Region) @acttype(Move Data) @cmddoc Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. @end @fnc(append-to-file-command) @cmd(Append To File) @key(M-X Append To File) @topic(Files) @seedef(Region) @acttype(Move Data) @cmddoc Append region to end of specified file. @end @fnc(apropos-command) @cmd(Apropos) @key(M-X Apropos) @key(Esc-_) @acttype(Inform) @cmddoc M-X Apropos lists functions with names containing a string for which the user is prompted. The functions are displayed using a documentation browser, which allows the user to view additional information on each function or further filter the list of displayed functions by matching on addtional strings. @end @fnc(argument-digit) @cmd(Argument Digit) @key(C-0) @key(C-1) @key(C-2) @key(C-3) @key(C-4) @key(C-5) @key(C-6) @key(C-7) @key(C-8) @key(C-9) @key(C-M-0) @key(C-M-1) @key(C-M-2) @key(C-M-3) @key(C-M-4) @key(C-M-5) @key(C-M-6) @key(C-M-7) @key(C-M-8) @key(C-M-9) @key(M-0) @key(M-1) @key(M-2) @key(M-3) @key(M-4) @key(M-5) @key(M-6) @key(M-7) @key(M-8) @key(M-9) @acttype(Subsequent Command Modifier) @cmddoc Specify numeric argument for next command. Several such digits typed in a row all accumulate. @end @fnc(auto-fill-mode-command) @cmd(Auto Fill Mode) @key(M-X Auto Fill Mode) @acttype(Change Mode) @seecmd(Set Fill Column) @cmddoc Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. @end @fnc(back-to-indentation-command) @cmd(Back To Indentation) @key(C-M-M) @key(C-M-RETURN) @key(M-M) @key(M-RETURN) @acttype(Move Point) @cmddoc Move to end of this line's indentation. @end @fnc(backward-kill-sentence-command) @cmd(Backward Kill Sentence) @key(C-X RUBOUT) @seeglobal(Kill Ring) @seedef(Sentence) @acttype(Remove) @cmddoc Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. @end @fnc(backward-paragraph-command) @cmd(Backward Paragraph) @key(M-[) @seedef(Paragraph) @acttype(Move Point) @cmddoc Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. @end @fnc(backward-sentence-command) @cmd(Backward Sentence) @key(M-A) @seedef(Sentence) @acttype(Move Point) @cmddoc Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. @end @fnc(backward-up-list-command) @cmd(Backward Up List) @key[C-(] @key[C-M-(] @mode(Lisp) @key(C-M-U) @acttype(Move Point) @topic(Lisp) @cmddoc Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). @end @fnc(buffer-browser-command) @cmd(Buffer Browser) @key(C-X C-B) @key(M-X List Buffers) @topic(Buffers) @acttype(Inform) @cmddoc Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". @end @fnc(buffer-not-modified-command) @cmd(Buffer Not Modified) @key(M-~) @topic(Buffers) @acttype(Set Global Variable) @cmddoc Pretend that this buffer hasn't been altered. @end @fnc(c-x-prefix) @cmd(C-X Prefix) @key(C-X) @acttype(Subsequent Command Modifier) @cmddoc The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. @end @fnc(center-line-command) @cmd(Center Line) @key(M-S) @topic(Text) @seeglobal(Fill Column) @acttype(Alter Existing Text) @cmddoc Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. @end @fnc(copy-region) @cmd(Copy Region) @key(M-W) @acttype(Preserve) @seeglobal(Kill Ring) @seedef(Region) @cmddoc Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. @end @fnc(count-occurrences-command) @cmd(Count Occurrences) @key(M-X Count Occurrences) @key(M-X How Many) @acttype(Inform) @cmddoc Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. @end @fnc(delete-and-expunge-file-command) @cmd(Delete And Expunge File) @key(M-X Delete And Expunge File) @acttype(Remove) @topic(Files) @cmddoc This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. @end @fnc(delete-backward-character-command) @cmd(Delete Backward Character) @key(BACKSPACE) @key(RUBOUT) @mode(Text) @acttype(Remove) @cmddoc Delete character before point. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. @end @fnc(delete-backward-hacking-tabs-command) @cmd(Delete Backward Hacking Tabs) @key(BACKSPACE) @key(C-RUBOUT) @mode(Lisp) @key(RUBOUT) @acttype(Remove) @cmddoc Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. @end @fnc(delete-blank-lines-command) @cmd(Delete Blank Lines) @key(C-X C-O) @acttype(Remove) @cmddoc Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. @end @fnc(delete-file-command) @cmd(Delete File) @key(M-X Delete File) @key(M-X Kill File) @acttype(Remove) @topic(Files) @cmddoc Delete a file. Prompts for filename. @end @fnc(delete-forward-character-command) @cmd(Delete Forward Character) @key(C-D) @key(ESC-P) @acttype(Remove) @seeglobal(Kill Ring) @cmddoc Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. @end @fnc(delete-horizontal-space-command) @cmd(Delete Horizontal Space) @key(M-\) @acttype(Remove) @cmddoc Delete all spaces and tabs around point. @end @fnc(delete-indentation-command) @cmd(Delete Indentation) @key(M-^) @acttype(Remove) @cmddoc Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). @end @fnc(delete-matching-lines-command) @cmd(Delete Matching Lines) @key(M-X Delete Matching Lines) @key(M-X Flush Lines) @acttype(Select) @acttype(Remove) @cmddoc Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. @end @fnc(delete-non-matching-lines-command) @cmd(Delete Non-Matching Lines) @key(M-X Delete Non-Matching Lines) @key(M-X Keep Lines) @acttype(Select) @acttype(Remove) @cmddoc Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. @end @fnc(dired-command) @cmd(Dired) @key(C-X D) @cmddoc Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. @end @fnc(down-list-command) @cmd(Down List) @key(C-M-D) @acttype(Move Point) @mode(Lisp) @topic(Lisp) @cmddoc Move down one level of list structure, forward. In other words, move forward past the next open bracket, unless there is in an intervening close bracket. With a positive command argument, move forward down that many levels. With a negative command argument, move backward down that many levels. @end @fnc(edit-directory-command) @cmd(Edit Directory) @key(M-X Dired) @key(M-X Edit Directory) @cmddoc DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. @end @fnc(end-of-defun-command) @cmd(End Of Defun) @key(C-M-E) @key(C-M-]) @acttype(Move Point) @mode(Lisp) @topic(Lisp) @seedef(Defun) @cmddoc Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. @end @fnc(esc-prefix) @cmd(Esc Prefix) @key(ESCAPE) @acttype(Subsequent Command Modifier) @cmddoc The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. @end @fnc(exchange-point-and-mark) @cmd(Exchange Point And Mark) @key(C-X C-X) @acttype(Mark) @acttype(Move Point) @cmddoc Exchange positions of point and mark. @end @fnc(exchange-windows-command) @cmd(Exchange Windows) @key(C-X E) @acttype(Alter Display Format) @cmddoc Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. @end @fnc(execute-buffer-command) @cmd(Execute Buffer) @key(M-X Execute Buffer) @topic(Buffers) @cmddoc This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. @end @fnc(execute-defun-command) @cmd(Execute Defun) @key(Lisp-D) @mode(Lisp) @topic(Lisp) @acttype(Mark) @seedef(Defun) @cmddoc Causes the Lisp reader to read and evaluate the current defun. If there is no current defin, the Lisp reader will read a form starting at the current location. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. @end @fnc(execute-file-command) @cmd(Execute File) @key(M-X Execute File) @topic(Files) @cmddoc This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. @end @fnc(execute-form-command) @cmd(Execute Form) @key(Lisp-E) @mode(Lisp) @topic(Lisp) @acttype(Mark) @cmddoc Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. @end @fnc(exit-nmode) @cmd(Exit Nmode) @key(Lisp-L) @mode(Lisp) @topic(Lisp) @acttype(Escape) @cmddoc Leave NMODE, return to normal listen loop. @end @fnc(fill-comment-command) @cmd(Fill Comment) @key(M-Z) @seeglobal(Fill Prefix) @seeglobal(Fill Column) @seedef(Paragraph) @acttype(Alter Existing Text) @cmddoc This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. @end @fnc(fill-paragraph-command) @cmd(Fill Paragraph) @key(M-Q) @seeglobal(Fill Prefix) @seeglobal(Fill Column) @seedef(Paragraph) @topic(Text) @acttype(Alter Existing Text) @cmddoc This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. @end @fnc(fill-region-command) @cmd(Fill Region) @key(M-G) @acttype(Alter Existing Text) @seeglobal(Fill Prefix) @seeglobal(Fill Column) @seedef(Paragraph) @seedef(Sentence) @seecmd(Set Fill Column) @seecmd(Set Fill Prefix) @topic(Text) @cmddoc Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. @end @fnc(find-file-command) @cmd(Find File) @key(C-X C-F) @key(M-X Find File) @acttype(Move Data) @acttype(Move Point) @topic(Files) @topic(Buffers) @cmddoc Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. @end @fnc(forward-paragraph-command) @cmd(Forward Paragraph) @key(M-]) @acttype(Move Point) @seedef(Paragraph) @topic(Text) @cmddoc Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. @end @fnc(forward-sentence-command) @cmd(Forward Sentence) @key(M-E) @topic(Text) @acttype(Move Point) @seedef(Sentence) @cmddoc Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. @end @fnc(forward-up-list-command) @cmd(Forward Up List) @key[C-)] @key[C-M-)] @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). @end @fnc(get-register-command) @cmd(Get Register) @key(C-X G) @acttype(Move Data) @acttype(Mark) @cmddoc Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. @end @fnc(grow-window-command) @cmd(Grow Window) @key(C-X ^) @acttype(Alter Display Format) @cmddoc Make this window use more lines. Argument is number of extra lines (can be negative). @end @fnc(help-dispatch) @cmd(Help Dispatch) @key(C-?) @key(M-/) @key(M-?) @acttype(Inform) @cmddoc Prints the documentation of a command (not a function). The command character is read from the terminal. @end @fnc(incremental-search-command) @cmd(Incremental Search) @key(C-S) @acttype(Move Point) @acttype(Select) @cmddoc Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. @end @fnc(indent-new-line-command) @cmd(Indent New line) @key(NEWLINE) @acttype(Insert Constant) @cmddoc This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. @end @fnc(indent-region-command) @cmd(Indent Region) @key(C-M-\) @mode(Text) @cmddoc Indent all lines between point and mark. With argument, indents each line to exactly that column. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. @end @fnc(insert-buffer-command) @cmd(Insert Buffer) @key(M-X Insert Buffer) @acttype(Move Data) @topic(Buffers) @cmddoc Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. @end @fnc(insert-closing-bracket) @cmd(Insert Closing bracket) @key[)] @key(]) @acttype(Insert Constant) @mode(Lisp) @topic(Lisp) @cmddoc Insert the character typed, which should be a closing bracket, then display the matching opening bracket. @end @fnc(insert-comment-command) @cmd(Insert Comment) @key(M-;) @mode(Lisp) @topic(Lisp) @acttype(Insert Constant) @cmddoc Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. @end @fnc(insert-date-command) @cmd(Insert Date) @key(M-X Insert Date) @acttype(Move Data) @cmddoc Insert the current time and date after point. The mark is put after the inserted text. @end @fnc(insert-file-command) @cmd(Insert File) @key(M-X Insert File) @topic(Files) @acttype(Move Data) @cmddoc Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. @end @fnc(insert-kill-buffer) @cmd(Insert Kill Buffer) @key(C-Y) @seeglobal(Kill Ring) @acttype(Move Data) @acttype(Mark) @cmddoc Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. @end @fnc(insert-next-character-command) @cmd(Insert Next Character) @key(C-Q) @acttype(Move Data) @cmddoc Reads a character and inserts it. @end @fnc(kill-backward-form-command) @cmd(Kill Backward Form) @key(C-M-RUBOUT) @mode(Lisp) @topic(Lisp) @seeglobal(Kill Ring) @acttype(Remove) @cmddoc Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. @end @fnc(kill-backward-word-command) @cmd(Kill Backward Word) @key(M-RUBOUT) @acttype(Remove) @topic(Text) @seeglobal(Kill Ring) @cmddoc Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. @end @fnc(kill-buffer-command) @cmd(Kill Buffer) @key(C-X K) @key(M-X Kill Buffer) @topic(Buffers) @acttype(Remove) @cmddoc Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. @end @fnc(kill-forward-form-command) @cmd(Kill Forward Form) @key(C-M-K) @mode(Lisp) @topic(Lisp) @seeglobal(Kill Ring) @acttype(Remove) @cmddoc Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. @end @fnc(kill-forward-word-command) @cmd(Kill Forward Word) @key(M-D) @seeglobal(Kill Ring) @topic(Text) @acttype(Remove) @cmddoc Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. @end @fnc(kill-line) @cmd(Kill Line) @key(C-K) @key(ESC-M) @seeglobal(Kill Ring) @acttype(Remove) @cmddoc Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. @end @fnc(kill-region) @cmd(Kill Region) @key(C-W) @seeglobal(Kill Ring) @seedef(Region) @acttype(Remove) @cmddoc Kill from point to mark. Use Control-Y and Meta-Y to get it back. @end @fnc(kill-sentence-command) @cmd(Kill Sentence) @key(M-K) @seedef(Sentence) @seeglobal(Kill Ring) @topic(Text) @acttype(Remove) @cmddoc Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. @end @fnc(kill-some-buffers-command) @cmd(Kill Some Buffers) @key(M-X Kill Some Buffers) @acttype(Remove) @topic(Buffers) @cmddoc Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. @end @fnc(lisp-abort-command) @cmd(Lisp Abort) @key(Lisp-A) @mode(Lisp) @topic(Lisp) @acttype(Escape) @cmddoc This command will pop out of an arbitrarily deep break loop. @end @fnc(lisp-backtrace-command) @cmd(Lisp Backtrace) @key(Lisp-B) @mode(Lisp) @topic(Lisp) @acttype(Inform) @cmddoc This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. @end @fnc(lisp-continue-command) @cmd(Lisp Continue) @key(Lisp-C) @mode(Lisp) @topic(Lisp) @acttype(Escape) @cmddoc This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. @end @fnc(lisp-help-command) @cmd(Lisp Help) @key(Lisp-?) @mode(Lisp) @topic(Lisp) @acttype(Inform) @cmddoc If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" @end @fnc(lisp-indent-region-command) @cmd(Lisp Indent Region) @key(C-M-\) @mode(Lisp) @topic(Lisp) @cmddoc Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. @end @fnc(lisp-indent-sexpr) @cmd(Lisp Indent sexpr) @mode(Lisp) @topic(Lisp) @key(C-M-Q) @cmddoc Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. @end @fnc(lisp-mode-command) @cmd(Lisp Mode) @key(M-X Lisp Mode) @acttype(Change Mode) @topic(Lisp) @cmddoc Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. @end @fnc(lisp-prefix) @cmd(Lisp Prefix) @key(C-]) @mode(Lisp) @topic(Lisp) @acttype(Subsequent Command Modifier) @cmddoc The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. @end @fnc(lisp-quit-command) @cmd(Lisp Quit) @key(Lisp-Q) @mode(Lisp) @topic(Lisp) @acttype(Escape) @cmddoc This exits the current break loop. It only pops up one level, unlike abort. @end @fnc(lisp-retry-command) @cmd(Lisp Retry) @key(Lisp-R) @mode(Lisp) @topic(Lisp) @acttype(Escape) @cmddoc This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. @end @fnc(lisp-tab-command) @cmd(Lisp Tab) @key(C-M-I) @key(C-M-TAB) @mode(Lisp) @topic(Lisp) @key(TAB) @seecmd(Tab To Tab Stop) @acttype(Alter Existing Text) @cmddoc Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. @end @fnc(lowercase-region-command) @cmd(Lowercase Region) @key(C-X C-L) @seedef(Region) @acttype(Alter Existing Text) @cmddoc Convert region to lower case. @end @fnc(lowercase-word-command) @cmd(Lowercase Word) @topic(Text) @key(M-L) @acttype(Alter Existing Text) @cmddoc Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. @end @fnc(m-x-prefix) @cmd(M-X Prefix) @key(C-M-X) @key(M-X) @acttype(Subsequent Command Modifier) @cmddoc Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. @end @fnc(make-parens-command) @cmd(Make Parens) @key[M-(] @acttype(Insert Constant) @mode(Lisp) @topic(Lisp) @cmddoc Insert () putting point after the (. Also make a space before the (, if appropriate. With argument, put the ) after the specified number of already existing forms. Thus, with argument 1, puts extra parens around the following form. @end @fnc(mark-beginning-command) @cmd(Mark Beginning) @key(C-<) @acttype(Mark) @cmddoc Set mark at beginning of buffer. @end @fnc(mark-defun-command) @cmd(Mark Defun) @key(C-M-BACKSPACE) @key(C-M-H) @key(M-BACKSPACE) @acttype(Mark) @seedef(Defun) @mode(Lisp) @topic(Lisp) @cmddoc Put point and mark around this defun (or next). @end @fnc(mark-end-command) @cmd(Mark End) @key(C->) @acttype(Mark) @cmddoc Set mark at end of buffer. @end @fnc(mark-form-command) @cmd(Mark Form) @mode(Lisp) @topic(Lisp) @key(C-M-@) @acttype(Mark) @cmddoc Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. @end @fnc(mark-paragraph-command) @cmd(Mark Paragraph) @key(M-H) @acttype(Mark) @topic(Text) @seedef(Paragraph) @acttype(Move Point) @cmddoc Put point and mark around this paragraph. In between paragraphs, puts it around the next one. @end @fnc(mark-whole-buffer-command) @cmd(Mark Whole Buffer) @key(C-X H) @acttype(Mark) @acttype(Move Point) @cmddoc Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. @end @fnc(mark-word-command) @cmd(Mark Word) @key(M-@) @acttype(Mark) @topic(Text) @cmddoc Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. @end @fnc(move-backward-character-command) @cmd(Move Backward Character) @key(C-B) @key(ESC-D) @acttype(Move Point) @cmddoc Move back one character. With argument, move that many characters backward. Negative arguments move forward. @end @fnc(move-backward-defun-command) @cmd(Move Backward Defun) @key(C-M-A) @key(C-M-[) @seedef(Defun) @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. @end @fnc(move-backward-form-command) @cmd(Move Backward Form) @key(C-M-B) @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move back one form. With argument, move that many forms backward. Negative arguments move forward. @end @fnc(move-backward-list-command) @cmd(Move Backward List) @key(C-M-P) @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move back one list. With argument, move that many lists backward. Negative arguments move forward. @end @fnc(move-backward-word-command) @cmd(Move Backward Word) @key(ESC-4) @key(M-B) @topic(Text) @acttype(Move Point) @cmddoc Move back one word. With argument, move that many words backward. Negative arguments move forward. @end @fnc(move-down-command) @cmd(Move Down) @key(ESC-B) @acttype(Move Point) @seeglobal(Goal Column) @cmddoc Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. @end @fnc(move-down-extending-command) @cmd(Move Down Extending) @key(C-N) @acttype(Move Point) @seeglobal(Goal Column) @cmddoc Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. @end @fnc(move-forward-character-command) @cmd(Move Forward Character) @key(C-F) @key(ESC-C) @acttype(Move Point) @cmddoc Move forward one character. With argument, move that many characters forward. Negative args move backward. @end @fnc(move-forward-form-command) @cmd(Move Forward Form) @key(C-M-F) @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move forward one form. With argument, move that many forms forward. Negative args move backward. @end @fnc(move-forward-list-command) @cmd(Move Forward List) @key(C-M-N) @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move forward one list. With argument, move that many lists forward. Negative args move backward. @end @fnc(move-forward-word-command) @cmd(Move Forward Word) @key(ESC-5) @key(M-F) @topic(Text) @acttype(Move Point) @cmddoc Move forward one word. With argument, move that many words forward. Negative args move backward. @end @fnc(move-over-paren-command) @cmd(Move Over Paren) @key[M-)] @mode(Lisp) @topic(Lisp) @acttype(Move Point) @cmddoc Move forward past the next closing bracket. If a positive command argument is given, move forward past that many closing brackets. Delete all indentation before the first closing bracket passed. After the last closing bracket passed, insert an end-of-line and then indent the new line according to Lisp. @end @fnc(move-to-buffer-end-command) @cmd(Move To Buffer End) @key(ESC-F) @key(M->) @acttype(Move Point) @cmddoc Go to end of buffer (leaving mark behind). @end @fnc(move-to-buffer-start-command) @cmd(Move To Buffer Start) @key(ESC-H) @key(M-<) @acttype(Move Point) @cmddoc Go to beginning of buffer (leaving mark behind). @end @fnc(move-to-end-of-line-command) @cmd(Move To End Of Line) @key(C-E) @acttype(Move Point) @cmddoc Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. @end @fnc(move-to-screen-edge-command) @cmd(Move To Screen Edge) @key(M-R) @acttype(Move Point) @cmddoc Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). @end @fnc(move-to-start-of-line-command) @cmd(Move To Start Of Line) @key(C-A) @acttype(Move Point) @cmddoc Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. @end @fnc(move-up-command) @cmd(Move Up) @key(C-P) @key(ESC-A) @seeglobal(Goal Column) @acttype(Move Point) @cmddoc Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. @end @fnc(negative-argument) @cmd(Negative Argument) @key(C--) @key(C-M--) @key(M--) @acttype(Subsequent Command Modifier) @cmddoc Make argument to next command negative. @end @fnc(next-screen-command) @cmd(Next Screen) @key(C-V) @acttype(Move Point) @cmddoc Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. @end @fnc(nmode-abort-command) @cmd(Nmode Abort) @key(C-G) @acttype(Escape) @cmddoc This command provides a way of aborting input requests. @end @fnc(nmode-exit-to-superior) @cmd(Nmode Exit To Superior) @key(C-X C-Z) @acttype(Escape) @cmddoc Go back to EMACS's superior job. @end @fnc(nmode-full-refresh) @cmd(Nmode Full Refresh) @key(ESC-J) @acttype(Alter Display Format) @cmddoc This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. @end @fnc(nmode-gc) @cmd(Nmode Gc) @key(M-X Make Space) @cmddoc Reclaims any internal wasted space. @end @fnc(nmode-invert-video) @cmd(Nmode Invert Video) @key(C-X V) @acttype(Alter Display Format) @cmddoc Toggle between normal and inverse video. @end @fnc(nmode-refresh-command) @cmd(Nmode Refresh) @key(C-L) @acttype(Alter Display Format) @cmddoc Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. @end @fnc(one-window-command) @cmd(One Window) @key(C-X 1) @acttype(Alter Display Format) @cmddoc Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. @end @fnc(open-line-command) @cmd(Open Line) @key(C-O) @key(ESC-L) @acttype(Insert Constant) @cmddoc Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. @end @fnc(other-window-command) @cmd(Other Window) @key(C-X O) @acttype(Alter Display Format) @acttype(Move Point) @cmddoc Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. @end @fnc(prepend-to-file-command) @cmd(Prepend To File) @topic(Files) @key(M-X Prepend To File) @seedef(Region) @acttype(Move Data) @cmddoc Append region to start of specified file. @end @fnc(previous-screen-command) @cmd(Previous Screen) @key(M-V) @acttype(Move Point) @cmddoc Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. @end @fnc(put-register-command) @cmd(Put Register) @key(C-X X) @acttype(Preserve) @cmddoc Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. @end @fnc(query-replace-command) @cmd(Query Replace) @key(M-%) @key(M-X Query Replace) @acttype(Alter Existing Text) @acttype(Select) @cmddoc Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout or Backspace => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. C-L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. Anything else exits and is reread. @end @fnc(rename-buffer-command) @cmd(Rename Buffer) @key(M-X Rename Buffer) @topic(Buffers) @acttype(Set Global Variable) @cmddoc Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. The buffer name is automatically converted to upper case. An error is reported if the user provides the name of another existing buffer. The buffers MAIN and OUTPUT may not be renamed. @end @fnc(replace-string-command) @cmd(Replace String) @key(C-%) @key(M-X Replace String) @acttype(Alter Existing Text) @acttype(Select) @cmddoc Replace string with another from point to buffer end. @end @fnc(reposition-window-command) @cmd(Reposition Window) @key(C-M-R) @mode(Lisp) @topic(Lisp) @acttype(Alter Display Format) @cmddoc Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. @end @fnc(return-command) @cmd(Return) @key(RETURN) @acttype(Insert Constant) @cmddoc Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. @end @fnc(reverse-search-command) @cmd(Reverse Search) @key(C-R) @acttype(Move Point) @acttype(Select) @seecmd(Incremental Search) @cmddoc Incremental Search Backwards. Like Control-S but in reverse. @end @fnc(revert-file-command) @cmd(Revert File) @topic(Files) @key(M-X Revert File) @acttype(Remove) @cmddoc Undo changes to a file. Reads back the file being edited from disk @end @fnc(save-all-files-command) @cmd(Save All Files) @key(M-X Save All Files) @topic(Buffers) @topic(Files) @acttype(Preserve) @cmddoc Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. @end @fnc(save-file-command) @cmd(Save File) @key(C-X C-S) @topic(Files) @acttype(Preserve) @cmddoc Save visited file on disk if modified. @end @fnc(scroll-other-window-command) @cmd(Scroll Other Window) @key(C-M-V) @acttype(Alter Display Format) @cmddoc Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. @end @fnc(scroll-window-down-line-command) @cmd(Scroll Window Down Line) @key(ESC-T) @acttype(Alter Display Format) @cmddoc Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. @end @fnc(scroll-window-down-page-command) @cmd(Scroll Window Down Page) @key(ESC-V) @acttype(Alter Display Format) @cmddoc Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. @end @fnc(scroll-window-left-command) @cmd(Scroll Window Left) @key(C-X <) @acttype(Alter Display Format) @cmddoc Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. @end @fnc(scroll-window-right-command) @cmd(Scroll Window Right) @key(C-X >) @acttype(Alter Display Format) @cmddoc Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. @end @fnc(scroll-window-up-line-command) @cmd(Scroll Window Up Line) @key(ESC-S) @acttype(Alter Display Format) @cmddoc Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. @end @fnc(scroll-window-up-page-command) @cmd(Scroll Window Up Page) @key(ESC-U) @acttype(Alter Display Format) @cmddoc Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. @end @fnc(select-buffer-command) @cmd(Select Buffer) @key(C-X B) @key(M-X Select Buffer) @acttype(Move Point) @topic(Buffers) @cmddoc Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. @end @fnc(select-previous-buffer-command) @cmd(Select Previous Buffer) @key(C-M-L) @topic(Buffers) @acttype(Move Point) @cmddoc Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. @end @fnc(set-fill-column-command) @cmd(Set Fill Column) @seeglobal(Fill Column) @key(C-X F) @acttype(Set Global Variable) @cmddoc Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. @end @fnc(set-fill-prefix-command) @cmd(Set Fill Prefix) @seeglobal(Fill Prefix) @key(C-X .) @acttype(Set Global Variable) @cmddoc Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. @end @fnc(set-goal-column-command) @cmd(Set Goal Column) @key(C-X C-N) @acttype(Set Global Variable) @cmddoc Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. @end @fnc(set-key-command) @cmd(Set Key) @key(M-X Set Key) @acttype(Set Global Variable) @cmddoc Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. @end @fnc(set-mark-command) @cmd(Set Mark) @key(C-@) @key(C-SPACE) @acttype(Mark) @cmddoc Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. @end @fnc(set-visited-filename-command) @cmd(Set Visited Filename) @key(M-X Set Visited Filename) @topic(Files) @acttype(Set Global Variable) @cmddoc Change visited filename, without writing or reading any file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. If possible, the new name will be adjusted to reflect an actual file name, as if the specified file were visited. @end @fnc(split-line-command) @cmd(Split Line) @key(C-M-O) @acttype(Insert Constant) @cmddoc Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. @end @fnc(start-scripting-command) @cmd(Start Scripting) @key(M-X Start Scripting) @acttype(Change Mode) @cmddoc This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. @end @fnc(start-timing-command) @cmd(Start Timing) @key(M-X Start Timing Nmode) @acttype(Change Mode) @cmddoc This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. @end @fnc(stop-scripting-command) @cmd(Stop Scripting) @key(M-X Stop Scripting) @acttype(Change Mode) @cmddoc This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. @end @fnc(stop-timing-command) @cmd(Stop Timing) @key(M-X Stop Timing Nmode) @acttype(Change Mode) @cmddoc This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. @end @fnc(tab-to-tab-stop-command) @cmd(Tab To Tab Stop) @key(M-I) @key(M-TAB) @key(TAB) @seecmd(Lisp Tab) @acttype(Insert Constant) @cmddoc Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. @end @fnc(text-mode-command) @cmd(Text Mode) @key(M-X Text Mode) @topic(Text) @acttype(Change Mode) @cmddoc Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. @end @fnc(transpose-characters-command) @cmd(Transpose Characters) @key(C-T) @acttype(Alter Existing Text) @seecmd(Transpose Words) @cmddoc Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. @end @fnc(transpose-forms) @cmd(Transpose Forms) @key(C-M-T) @mode(Lisp) @topic(Lisp) @seecmd(Transpose Words) @acttype(Alter Existing Text) @cmddoc Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". @end @fnc(transpose-lines) @cmd(Transpose Lines) @key(C-X C-T) @seecmd(Transpose Words) @acttype(Alter Existing Text) @cmddoc Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". @end @fnc(transpose-regions) @cmd(Transpose Regions) @key(C-X T) @seedef(Region) @acttype(Alter Existing Text) @cmddoc Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. @end @fnc(transpose-words) @cmd(Transpose Words) @key(M-T) @topic(Text) @acttype(Alter Existing Text) @cmddoc Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. @end @fnc(two-windows-command) @cmd(Two Windows) @key(C-X 2) @acttype(Alter Display Format) @cmddoc Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. @end @fnc(undelete-file-command) @cmd(Undelete File) @key(M-X Undelete File) @acttype(Move Data) @acttype(Preserve) @topic(Files) @cmddoc This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. @end @fnc(universal-argument) @cmd(Universal Argument) @key(C-U) @acttype(Subsequent Command Modifier) @cmddoc Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. @end @fnc(unkill-previous) @cmd(Unkill Previous) @seedef(Region) @seeglobal(Kill Ring) @key(M-Y) @acttype(Alter Existing Text) @cmddoc Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. @end @fnc(upcase-digit-command) @cmd(Upcase Digit) @key(M-') @acttype(Alter Existing Text) @cmddoc Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. @end @fnc(uppercase-initial-command) @cmd(Uppercase Initial) @key(M-C) @topic(Text) @acttype(Alter Existing Text) @cmddoc Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. @end @fnc(uppercase-region-command) @cmd(Uppercase Region) @key(C-X C-U) @seedef(Region) @acttype(Alter Existing Text) @cmddoc Convert region to upper case. @end @fnc(uppercase-word-command) @cmd(Uppercase Word) @key(M-U) @topic(Text) @acttype(Alter Existing Text) @cmddoc Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. @end @fnc(view-two-windows-command) @cmd(View Two Windows) @key(C-X 3) @acttype(Alter Display Format) @cmddoc Show two windows but stay in first. @end @fnc(visit-file-command) @cmd(Visit File) @key(C-X C-V) @topic(Files) @key(M-X Visit File) @acttype(Move Data) @acttype(Move Point) @cmddoc Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. @end @fnc(visit-in-other-window-command) @cmd(Visit In Other Window) @key(C-X 4) @acttype(Move Point) @acttype(Alter Display Format) @topic(Files) @topic(Buffers) @cmddoc Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. @end @fnc(what-cursor-position-command) @cmd(What Cursor Position) @key(C-=) @key(C-X =) @acttype(Inform) @cmddoc Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. @end @fnc(write-file-command) @cmd(Write File) @key(C-X C-W) @key(M-X Write File) @topic(Files) @acttype(Preserve) @cmddoc Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. @end @fnc(write-region-command) @cmd(Write Region) @key(M-X Write Region) @seedef(Region) @topic(Files) @acttype(Preserve) @cmddoc Write region to file. Prompts for file name. @end @fnc(write-screen-command) @cmd(Write Screen) @key(C-X P) @topic(Files) @acttype(Preserve) @cmddoc Ask for filename, write out the screen to the file. @end @fnc(yank-last-output-command) @cmd(Yank Last Output) @key(Lisp-Y) @mode(Lisp) @topic(Lisp) @acttype(Move Data) @cmddoc Insert "last output" typed in the OUTPUT buffer. @end |
Added psl-1983/3-1/doc/nmode/costly.sl version [d959c0bd7e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SETQ DOC-OBJ-LIST (LIST (SETQ DOC1 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Alter Display Format") (QUOTE TYPE) (QUOTE ACTION) ( QUOTE INDEX) (QUOTE 1) (QUOTE START-LINE) (QUOTE 1) (QUOTE END-LINE) (QUOTE 6) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC2 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Alter Existing Text") (QUOTE TYPE) ( QUOTE ACTION) (QUOTE INDEX) (QUOTE 2) (QUOTE START-LINE) (QUOTE 7) (QUOTE END-LINE) (QUOTE 12) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC3 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Change Mode") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 3) (QUOTE START-LINE) (QUOTE 13) (QUOTE END-LINE) (QUOTE 18) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC4 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Escape") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 4) (QUOTE START-LINE) (QUOTE 19) (QUOTE END-LINE) (QUOTE 23) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC5 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Inform") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 5) (QUOTE START-LINE) (QUOTE 24) (QUOTE END-LINE) (QUOTE 30) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC6 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Constant") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 6) (QUOTE START-LINE) (QUOTE 31) (QUOTE END-LINE) (QUOTE 36) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC7 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark") (QUOTE TYPE) ( QUOTE ACTION) (QUOTE INDEX) (QUOTE 7) (QUOTE START-LINE) (QUOTE 37) (QUOTE END-LINE) (QUOTE 41) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC8 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Data") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 8) (QUOTE START-LINE) (QUOTE 42) (QUOTE END-LINE) (QUOTE 47) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC9 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Point") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 9) (QUOTE START-LINE) (QUOTE 48) (QUOTE END-LINE) (QUOTE 53) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC10 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Preserve") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 10) (QUOTE START-LINE) (QUOTE 54) (QUOTE END-LINE) (QUOTE 58) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC11 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Remove") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 11) (QUOTE START-LINE) (QUOTE 59) (QUOTE END-LINE) (QUOTE 64) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC12 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Select") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 12) (QUOTE START-LINE) (QUOTE 65) (QUOTE END-LINE) (QUOTE 70) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC13 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Global Variable") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 13) (QUOTE START-LINE) ( QUOTE 71) (QUOTE END-LINE) (QUOTE 76) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC14 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Subsequent Command Modifier") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) ( QUOTE 14) (QUOTE START-LINE) (QUOTE 77) (QUOTE END-LINE) (QUOTE 82) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC15 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Defun") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 15) (QUOTE START-LINE) (QUOTE 83) (QUOTE END-LINE) (QUOTE 88) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC16 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Paragraph") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 16) (QUOTE START-LINE) (QUOTE 89) (QUOTE END-LINE) (QUOTE 98) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC17 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Region") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 17) (QUOTE START-LINE) (QUOTE 99) (QUOTE END-LINE) (QUOTE 104) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC18 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Sentence") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 18) (QUOTE START-LINE) (QUOTE 105) (QUOTE END-LINE) (QUOTE 112) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC19 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Fill Column") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 19) (QUOTE START-LINE) (QUOTE 113) (QUOTE END-LINE) (QUOTE 119) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC20 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Fill Prefix") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 20) (QUOTE START-LINE) (QUOTE 120) (QUOTE END-LINE) (QUOTE 128) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC21 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Goal Column") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 21) (QUOTE START-LINE) (QUOTE 129) (QUOTE END-LINE) (QUOTE 133) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC22 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Kill Ring") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 22) (QUOTE START-LINE) (QUOTE 134) (QUOTE END-LINE) (QUOTE 152) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC23 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Append Next Kill") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 23) (QUOTE START-LINE) (QUOTE 153) (QUOTE END-LINE) (QUOTE 164) (QUOTE REF-LIST) (QUOTE (DOC8 DOC22)))) (SETQ DOC24 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Append To Buffer") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 24) (QUOTE START-LINE) (QUOTE 165) ( QUOTE END-LINE) (QUOTE 178) (QUOTE REF-LIST) (QUOTE (DOC8 DOC17 DOC197)))) ( SETQ DOC25 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Append To File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 25) ( QUOTE START-LINE) (QUOTE 179) (QUOTE END-LINE) (QUOTE 189) (QUOTE REF-LIST) ( QUOTE (DOC8 DOC17 DOC196)))) (SETQ DOC26 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Apropos") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 26) (QUOTE START-LINE) (QUOTE 190) (QUOTE END-LINE) ( QUOTE 199) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC27 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Argument Digit") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 27) (QUOTE START-LINE) (QUOTE 200) ( QUOTE END-LINE) (QUOTE 238) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC28 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Auto Fill Mode") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 28) (QUOTE START-LINE) ( QUOTE 239) (QUOTE END-LINE) (QUOTE 252) (QUOTE REF-LIST) (QUOTE (DOC3 DOC159)))) (SETQ DOC29 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Back To Indentation") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 29) (QUOTE START-LINE) (QUOTE 253) (QUOTE END-LINE) (QUOTE 264) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC30 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Backward Kill Sentence") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 30) (QUOTE START-LINE) (QUOTE 265) (QUOTE END-LINE) ( QUOTE 276) (QUOTE REF-LIST) (QUOTE (DOC11 DOC18 DOC22)))) (SETQ DOC31 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 31) (QUOTE START-LINE) ( QUOTE 277) (QUOTE END-LINE) (QUOTE 287) (QUOTE REF-LIST) (QUOTE (DOC9 DOC16)))) (SETQ DOC32 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 32) (QUOTE START-LINE) (QUOTE 288) (QUOTE END-LINE) (QUOTE 298) (QUOTE REF-LIST) (QUOTE (DOC9 DOC18)))) (SETQ DOC33 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Up List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 33) (QUOTE START-LINE) (QUOTE 299) (QUOTE END-LINE) (QUOTE 312) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC34 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Buffer Browser") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 34) ( QUOTE START-LINE) (QUOTE 313) (QUOTE END-LINE) (QUOTE 324) (QUOTE REF-LIST) ( QUOTE (DOC5 DOC197)))) (SETQ DOC35 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Buffer Not Modified") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 35) (QUOTE START-LINE) (QUOTE 325) (QUOTE END-LINE) ( QUOTE 334) (QUOTE REF-LIST) (QUOTE (DOC13 DOC197)))) (SETQ DOC36 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "C-X Prefix") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 36) (QUOTE START-LINE) ( QUOTE 335) (QUOTE END-LINE) (QUOTE 344) (QUOTE REF-LIST) (QUOTE (DOC14)))) ( SETQ DOC37 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Center Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 37) (QUOTE START-LINE) (QUOTE 345) (QUOTE END-LINE) (QUOTE 357) (QUOTE REF-LIST) (QUOTE ( DOC2 DOC19 DOC193)))) (SETQ DOC38 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Copy Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 38) (QUOTE START-LINE) (QUOTE 358) (QUOTE END-LINE) (QUOTE 369) (QUOTE REF-LIST) (QUOTE (DOC10 DOC17 DOC22)))) (SETQ DOC39 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Count Occurrences") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 39) (QUOTE START-LINE) (QUOTE 370) (QUOTE END-LINE) (QUOTE 380) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC40 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete And Expunge File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 40) (QUOTE START-LINE) (QUOTE 381) (QUOTE END-LINE) (QUOTE 393) (QUOTE REF-LIST) (QUOTE (DOC11 DOC196)))) (SETQ DOC41 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Backward Hacking Tabs") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 41) (QUOTE START-LINE) (QUOTE 394) (QUOTE END-LINE) (QUOTE 409) (QUOTE REF-LIST) (QUOTE (DOC11 DOC195)))) ( SETQ DOC42 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Blank Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 42) (QUOTE START-LINE) (QUOTE 410) (QUOTE END-LINE) (QUOTE 421) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC43 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Delete File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 43) (QUOTE START-LINE) (QUOTE 422) (QUOTE END-LINE) (QUOTE 432) (QUOTE REF-LIST) (QUOTE (DOC11 DOC196)))) (SETQ DOC44 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Forward Character") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 44) (QUOTE START-LINE) (QUOTE 433) ( QUOTE END-LINE) (QUOTE 444) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22)))) (SETQ DOC45 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Horizontal Space") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 45) (QUOTE START-LINE) (QUOTE 445) (QUOTE END-LINE) (QUOTE 453) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC46 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Delete Indentation") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 46) (QUOTE START-LINE) (QUOTE 454) (QUOTE END-LINE) (QUOTE 464) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC47 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Matching Lines") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 47) (QUOTE START-LINE) (QUOTE 465) ( QUOTE END-LINE) (QUOTE 476) (QUOTE REF-LIST) (QUOTE (DOC11 DOC12)))) (SETQ DOC48 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Non-Matching Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 48) (QUOTE START-LINE) (QUOTE 477) (QUOTE END-LINE) (QUOTE 488) (QUOTE REF-LIST) (QUOTE (DOC11 DOC12)))) (SETQ DOC49 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Dired") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 49) (QUOTE START-LINE) (QUOTE 489) (QUOTE END-LINE) ( QUOTE 499) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC50 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Down List") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 50) (QUOTE START-LINE) (QUOTE 500) (QUOTE END-LINE) ( QUOTE 511) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC51 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Edit Directory") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 51) (QUOTE START-LINE) ( QUOTE 512) (QUOTE END-LINE) (QUOTE 531) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC52 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "End Of Defun") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 52) (QUOTE START-LINE) ( QUOTE 532) (QUOTE END-LINE) (QUOTE 545) (QUOTE REF-LIST) (QUOTE (DOC9 DOC15 DOC194 DOC195)))) (SETQ DOC53 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Esc Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 53) (QUOTE START-LINE) (QUOTE 546) (QUOTE END-LINE) (QUOTE 556) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC54 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Exchange Point And Mark") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 54) (QUOTE START-LINE) (QUOTE 557) (QUOTE END-LINE) ( QUOTE 566) (QUOTE REF-LIST) (QUOTE (DOC9 DOC7)))) (SETQ DOC55 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Exchange Windows") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 55) (QUOTE START-LINE) (QUOTE 567) ( QUOTE END-LINE) (QUOTE 576) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC56 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Execute Buffer") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 56) (QUOTE START-LINE) ( QUOTE 577) (QUOTE END-LINE) (QUOTE 589) (QUOTE REF-LIST) (QUOTE (DOC197)))) ( SETQ DOC57 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Execute File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 57) (QUOTE START-LINE) (QUOTE 590) (QUOTE END-LINE) (QUOTE 602) (QUOTE REF-LIST) (QUOTE ( DOC196)))) (SETQ DOC58 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Execute Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 58) (QUOTE START-LINE) (QUOTE 603) (QUOTE END-LINE) (QUOTE 616) (QUOTE REF-LIST) (QUOTE (DOC7 DOC194 DOC195)))) (SETQ DOC59 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Exit Nmode") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 59) (QUOTE START-LINE) (QUOTE 617) (QUOTE END-LINE) (QUOTE 627) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC60 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Comment") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 60) (QUOTE START-LINE) ( QUOTE 628) (QUOTE END-LINE) (QUOTE 642) (QUOTE REF-LIST) (QUOTE (DOC2 DOC16 DOC19 DOC20)))) (SETQ DOC61 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Paragraph") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 61) (QUOTE START-LINE) (QUOTE 643) (QUOTE END-LINE) (QUOTE 657) (QUOTE REF-LIST) (QUOTE (DOC2 DOC16 DOC19 DOC20 DOC193)))) (SETQ DOC62 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Region") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 62) (QUOTE START-LINE) ( QUOTE 658) (QUOTE END-LINE) (QUOTE 677) (QUOTE REF-LIST) (QUOTE (DOC2 DOC18 DOC16 DOC19 DOC20 DOC160 DOC159 DOC193)))) (SETQ DOC63 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Find File") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 63) (QUOTE START-LINE) (QUOTE 678) (QUOTE END-LINE) ( QUOTE 691) (QUOTE REF-LIST) (QUOTE (DOC9 DOC8 DOC197 DOC196)))) (SETQ DOC64 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Forward Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 64) (QUOTE START-LINE) ( QUOTE 692) (QUOTE END-LINE) (QUOTE 704) (QUOTE REF-LIST) (QUOTE (DOC9 DOC16 DOC193)))) (SETQ DOC65 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Forward Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 65) (QUOTE START-LINE) (QUOTE 705) (QUOTE END-LINE) (QUOTE 717) (QUOTE REF-LIST) (QUOTE (DOC9 DOC18 DOC193)))) (SETQ DOC66 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Forward Up List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 66) (QUOTE START-LINE) (QUOTE 718) (QUOTE END-LINE) (QUOTE 730) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC67 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Get Register") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 67) (QUOTE START-LINE) ( QUOTE 731) (QUOTE END-LINE) (QUOTE 742) (QUOTE REF-LIST) (QUOTE (DOC7 DOC8)))) ( SETQ DOC68 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Grow Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 68) (QUOTE START-LINE) (QUOTE 743) (QUOTE END-LINE) (QUOTE 752) (QUOTE REF-LIST) (QUOTE ( DOC1)))) (SETQ DOC69 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Help Dispatch") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 69) (QUOTE START-LINE) (QUOTE 753) (QUOTE END-LINE) (QUOTE 764) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC70 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Incremental Search") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 70) (QUOTE START-LINE) (QUOTE 765) (QUOTE END-LINE) (QUOTE 782) (QUOTE REF-LIST) (QUOTE (DOC12 DOC9)))) (SETQ DOC71 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Indent New line") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 71) (QUOTE START-LINE) (QUOTE 783) ( QUOTE END-LINE) (QUOTE 793) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC72 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Buffer") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 72) (QUOTE START-LINE) ( QUOTE 794) (QUOTE END-LINE) (QUOTE 805) (QUOTE REF-LIST) (QUOTE (DOC8 DOC197)))) (SETQ DOC73 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Closing bracket") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 73) (QUOTE START-LINE) (QUOTE 806) (QUOTE END-LINE) (QUOTE 818) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC74 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Comment") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 74) (QUOTE START-LINE) (QUOTE 819) (QUOTE END-LINE) (QUOTE 830) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC75 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Date") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 75) (QUOTE START-LINE) ( QUOTE 831) (QUOTE END-LINE) (QUOTE 840) (QUOTE REF-LIST) (QUOTE (DOC8)))) ( SETQ DOC76 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 76) (QUOTE START-LINE) (QUOTE 841) (QUOTE END-LINE) (QUOTE 851) (QUOTE REF-LIST) (QUOTE ( DOC8 DOC196)))) (SETQ DOC77 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Kill Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 77) (QUOTE START-LINE) (QUOTE 852) (QUOTE END-LINE) (QUOTE 864) (QUOTE REF-LIST) (QUOTE (DOC7 DOC8 DOC22)))) (SETQ DOC78 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Next Character") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 78) (QUOTE START-LINE) (QUOTE 865) ( QUOTE END-LINE) (QUOTE 873) (QUOTE REF-LIST) (QUOTE (DOC8)))) (SETQ DOC79 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Parens") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 79) (QUOTE START-LINE) ( QUOTE 874) (QUOTE END-LINE) (QUOTE 887) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC80 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Kill Backward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 80) (QUOTE START-LINE) (QUOTE 888) (QUOTE END-LINE) (QUOTE 900) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC194 DOC195)))) (SETQ DOC81 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Backward Word") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 81) (QUOTE START-LINE) (QUOTE 901) ( QUOTE END-LINE) (QUOTE 912) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC193)))) ( SETQ DOC82 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 82) (QUOTE START-LINE) (QUOTE 913) (QUOTE END-LINE) (QUOTE 925) (QUOTE REF-LIST) (QUOTE ( DOC11 DOC197)))) (SETQ DOC83 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Forward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 83) (QUOTE START-LINE) (QUOTE 926) (QUOTE END-LINE) (QUOTE 938) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC194 DOC195)))) (SETQ DOC84 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Forward Word") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 84) (QUOTE START-LINE) (QUOTE 939) ( QUOTE END-LINE) (QUOTE 950) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC193)))) ( SETQ DOC85 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 85) (QUOTE START-LINE) (QUOTE 951) (QUOTE END-LINE) (QUOTE 966) (QUOTE REF-LIST) (QUOTE ( DOC11 DOC22)))) (SETQ DOC86 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 86) (QUOTE START-LINE) (QUOTE 967) (QUOTE END-LINE) (QUOTE 977) (QUOTE REF-LIST) (QUOTE (DOC11 DOC17 DOC22)))) (SETQ DOC87 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 87) (QUOTE START-LINE) (QUOTE 978) (QUOTE END-LINE) (QUOTE 991) (QUOTE REF-LIST) (QUOTE (DOC11 DOC18 DOC22 DOC193)))) ( SETQ DOC88 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Some Buffers") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 88) (QUOTE START-LINE) (QUOTE 992) (QUOTE END-LINE) (QUOTE 1002) (QUOTE REF-LIST) (QUOTE (DOC11 DOC197)))) (SETQ DOC89 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Abort") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 89) (QUOTE START-LINE) (QUOTE 1003) (QUOTE END-LINE) (QUOTE 1013) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC90 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Backtrace") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 90) ( QUOTE START-LINE) (QUOTE 1014) (QUOTE END-LINE) (QUOTE 1025) (QUOTE REF-LIST) ( QUOTE (DOC5 DOC194 DOC195)))) (SETQ DOC91 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Continue") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 91) (QUOTE START-LINE) (QUOTE 1026) (QUOTE END-LINE) (QUOTE 1041) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC92 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Help") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 92) (QUOTE START-LINE) ( QUOTE 1042) (QUOTE END-LINE) (QUOTE 1055) (QUOTE REF-LIST) (QUOTE (DOC5 DOC194 DOC195)))) (SETQ DOC93 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Indent Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 93) (QUOTE START-LINE) (QUOTE 1056) (QUOTE END-LINE) (QUOTE 1068) ( QUOTE REF-LIST) (QUOTE (DOC194 DOC195)))) (SETQ DOC94 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Indent sexpr") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 94) (QUOTE START-LINE) (QUOTE 1069) (QUOTE END-LINE) (QUOTE 1079) (QUOTE REF-LIST) (QUOTE (DOC194 DOC195)))) (SETQ DOC95 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Mode") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 95) (QUOTE START-LINE) ( QUOTE 1080) (QUOTE END-LINE) (QUOTE 1091) (QUOTE REF-LIST) (QUOTE (DOC3 DOC194)))) (SETQ DOC96 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Lisp Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 96) (QUOTE START-LINE) (QUOTE 1092) (QUOTE END-LINE) (QUOTE 1103) (QUOTE REF-LIST) (QUOTE (DOC14 DOC194 DOC195)))) (SETQ DOC97 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Quit") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 97) (QUOTE START-LINE) (QUOTE 1104) (QUOTE END-LINE) ( QUOTE 1114) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC98 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Retry") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 98) (QUOTE START-LINE) ( QUOTE 1115) (QUOTE END-LINE) (QUOTE 1127) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC99 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Tab") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 99) (QUOTE START-LINE) (QUOTE 1128) (QUOTE END-LINE) (QUOTE 1145) (QUOTE REF-LIST) (QUOTE (DOC2 DOC170 DOC194 DOC195)))) (SETQ DOC100 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lowercase Region") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 100) (QUOTE START-LINE) (QUOTE 1146) ( QUOTE END-LINE) (QUOTE 1155) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC101 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lowercase Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 101) ( QUOTE START-LINE) (QUOTE 1156) (QUOTE END-LINE) (QUOTE 1166) (QUOTE REF-LIST) ( QUOTE (DOC2 DOC193)))) (SETQ DOC102 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "M-X Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 102) (QUOTE START-LINE) (QUOTE 1167) (QUOTE END-LINE) (QUOTE 1179) ( QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC103 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Beginning") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 103) (QUOTE START-LINE) (QUOTE 1180) (QUOTE END-LINE) (QUOTE 1188) (QUOTE REF-LIST) (QUOTE (DOC7)))) (SETQ DOC104 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Defun") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 104) (QUOTE START-LINE) ( QUOTE 1189) (QUOTE END-LINE) (QUOTE 1202) (QUOTE REF-LIST) (QUOTE (DOC7 DOC15 DOC194 DOC195)))) (SETQ DOC105 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Mark End") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 105) (QUOTE START-LINE) (QUOTE 1203) (QUOTE END-LINE) (QUOTE 1211) ( QUOTE REF-LIST) (QUOTE (DOC7)))) (SETQ DOC106 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Form") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 106) (QUOTE START-LINE) (QUOTE 1212) (QUOTE END-LINE) ( QUOTE 1223) (QUOTE REF-LIST) (QUOTE (DOC7 DOC194 DOC195)))) (SETQ DOC107 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 107) (QUOTE START-LINE) ( QUOTE 1224) (QUOTE END-LINE) (QUOTE 1236) (QUOTE REF-LIST) (QUOTE (DOC9 DOC7 DOC16 DOC193)))) (SETQ DOC108 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Whole Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 108) (QUOTE START-LINE) (QUOTE 1237) (QUOTE END-LINE) (QUOTE 1247) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC7)))) (SETQ DOC109 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Word") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 109) (QUOTE START-LINE) (QUOTE 1248) (QUOTE END-LINE) ( QUOTE 1258) (QUOTE REF-LIST) (QUOTE (DOC7 DOC193)))) (SETQ DOC110 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Character") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 110) (QUOTE START-LINE) (QUOTE 1259) (QUOTE END-LINE) (QUOTE 1269) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC111 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move Backward Defun") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 111) (QUOTE START-LINE) (QUOTE 1270) (QUOTE END-LINE) ( QUOTE 1283) (QUOTE REF-LIST) (QUOTE (DOC9 DOC15 DOC194 DOC195)))) (SETQ DOC112 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 112) (QUOTE START-LINE) (QUOTE 1284) (QUOTE END-LINE) (QUOTE 1295) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC113 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward List") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 113) (QUOTE START-LINE) (QUOTE 1296) ( QUOTE END-LINE) (QUOTE 1307) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) ( SETQ DOC114 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 114) (QUOTE START-LINE) (QUOTE 1308) (QUOTE END-LINE) (QUOTE 1319) (QUOTE REF-LIST) (QUOTE (DOC9 DOC193)))) (SETQ DOC115 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Down") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 115) (QUOTE START-LINE) (QUOTE 1320) (QUOTE END-LINE) ( QUOTE 1330) (QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC116 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Down Extending") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 116) (QUOTE START-LINE) ( QUOTE 1331) (QUOTE END-LINE) (QUOTE 1342) (QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC117 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Move Forward Character") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 117) (QUOTE START-LINE) (QUOTE 1343) (QUOTE END-LINE) (QUOTE 1353) ( QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC118 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 118) (QUOTE START-LINE) (QUOTE 1354) (QUOTE END-LINE) (QUOTE 1365) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC119 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 119) (QUOTE START-LINE) (QUOTE 1366) (QUOTE END-LINE) (QUOTE 1377) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC120 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 120) (QUOTE START-LINE) (QUOTE 1378) (QUOTE END-LINE) (QUOTE 1389) (QUOTE REF-LIST) (QUOTE (DOC9 DOC193)))) (SETQ DOC121 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Buffer End") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 121) (QUOTE START-LINE) ( QUOTE 1390) (QUOTE END-LINE) (QUOTE 1399) (QUOTE REF-LIST) (QUOTE (DOC9)))) ( SETQ DOC122 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Buffer Start") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 122) (QUOTE START-LINE) (QUOTE 1400) (QUOTE END-LINE) (QUOTE 1409) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC123 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move To End Of Line") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 123) (QUOTE START-LINE) (QUOTE 1410) (QUOTE END-LINE) ( QUOTE 1420) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC124 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Screen Edge") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 124) (QUOTE START-LINE) (QUOTE 1421) ( QUOTE END-LINE) (QUOTE 1432) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC125 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Start Of Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 125) (QUOTE START-LINE) (QUOTE 1433) (QUOTE END-LINE) (QUOTE 1444) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC126 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move Up") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 126) (QUOTE START-LINE) (QUOTE 1445) (QUOTE END-LINE) (QUOTE 1456) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC127 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Negative Argument") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 127) (QUOTE START-LINE) (QUOTE 1457) (QUOTE END-LINE) (QUOTE 1467) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC128 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Next Screen") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 128) (QUOTE START-LINE) ( QUOTE 1468) (QUOTE END-LINE) (QUOTE 1478) (QUOTE REF-LIST) (QUOTE (DOC9)))) ( SETQ DOC129 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Abort") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 129) (QUOTE START-LINE) (QUOTE 1479) (QUOTE END-LINE) (QUOTE 1487) (QUOTE REF-LIST) ( QUOTE (DOC4)))) (SETQ DOC130 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Exit To Superior") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 130) (QUOTE START-LINE) (QUOTE 1488) (QUOTE END-LINE) (QUOTE 1496) (QUOTE REF-LIST) (QUOTE (DOC4)))) (SETQ DOC131 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Full Refresh") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 131) (QUOTE START-LINE) (QUOTE 1497) ( QUOTE END-LINE) (QUOTE 1506) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC132 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Gc") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 132) (QUOTE START-LINE) (QUOTE 1507) (QUOTE END-LINE) (QUOTE 1514) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC133 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Invert Video") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 133) (QUOTE START-LINE) (QUOTE 1515) (QUOTE END-LINE) (QUOTE 1523) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC134 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Nmode Refresh") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 134) (QUOTE START-LINE) (QUOTE 1524) (QUOTE END-LINE) (QUOTE 1534) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC135 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "One Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 135) (QUOTE START-LINE) (QUOTE 1535) (QUOTE END-LINE) (QUOTE 1544) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC136 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Open Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 136) (QUOTE START-LINE) (QUOTE 1545) (QUOTE END-LINE) (QUOTE 1556) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC137 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 137) (QUOTE START-LINE) ( QUOTE 1557) (QUOTE END-LINE) (QUOTE 1569) (QUOTE REF-LIST) (QUOTE (DOC9 DOC1)))) (SETQ DOC138 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Prepend To File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 138) ( QUOTE START-LINE) (QUOTE 1570) (QUOTE END-LINE) (QUOTE 1580) (QUOTE REF-LIST) ( QUOTE (DOC8 DOC17 DOC196)))) (SETQ DOC139 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Previous Screen") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 139) (QUOTE START-LINE) (QUOTE 1581) (QUOTE END-LINE) (QUOTE 1591) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC140 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Put Register") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 140) (QUOTE START-LINE) ( QUOTE 1592) (QUOTE END-LINE) (QUOTE 1601) (QUOTE REF-LIST) (QUOTE (DOC10)))) ( SETQ DOC141 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Query Replace") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 141) ( QUOTE START-LINE) (QUOTE 1602) (QUOTE END-LINE) (QUOTE 1620) (QUOTE REF-LIST) ( QUOTE (DOC12 DOC2)))) (SETQ DOC142 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Rename Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 142) (QUOTE START-LINE) (QUOTE 1621) (QUOTE END-LINE) (QUOTE 1632) (QUOTE REF-LIST) (QUOTE (DOC13 DOC197)))) (SETQ DOC143 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Replace String") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 143) (QUOTE START-LINE) (QUOTE 1633) ( QUOTE END-LINE) (QUOTE 1643) (QUOTE REF-LIST) (QUOTE (DOC12 DOC2)))) (SETQ DOC144 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Reposition Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 144) (QUOTE START-LINE) (QUOTE 1644) (QUOTE END-LINE) (QUOTE 1655) (QUOTE REF-LIST) (QUOTE (DOC1 DOC194 DOC195)))) (SETQ DOC145 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Return") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 145) (QUOTE START-LINE) (QUOTE 1656) (QUOTE END-LINE) ( QUOTE 1665) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC146 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Reverse Search") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 146) (QUOTE START-LINE) (QUOTE 1666) ( QUOTE END-LINE) (QUOTE 1676) (QUOTE REF-LIST) (QUOTE (DOC12 DOC9 DOC70)))) ( SETQ DOC147 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Revert File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 147) (QUOTE START-LINE) (QUOTE 1677) (QUOTE END-LINE) (QUOTE 1686) (QUOTE REF-LIST) ( QUOTE (DOC11 DOC196)))) (SETQ DOC148 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Save All Files") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 148) (QUOTE START-LINE) (QUOTE 1687) (QUOTE END-LINE) (QUOTE 1699) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196 DOC197)))) (SETQ DOC149 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Save File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 149) (QUOTE START-LINE) (QUOTE 1700) (QUOTE END-LINE) (QUOTE 1709) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) ( SETQ DOC150 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 150) (QUOTE START-LINE) (QUOTE 1710) (QUOTE END-LINE) (QUOTE 1720) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC151 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Scroll Window Down Line") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 151) (QUOTE START-LINE) (QUOTE 1721) (QUOTE END-LINE) ( QUOTE 1731) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC152 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Down Page") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 152) (QUOTE START-LINE) (QUOTE 1732) (QUOTE END-LINE) (QUOTE 1742) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC153 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Left") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 153) (QUOTE START-LINE) (QUOTE 1743) (QUOTE END-LINE) (QUOTE 1752) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC154 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Scroll Window Right") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 154) (QUOTE START-LINE) (QUOTE 1753) (QUOTE END-LINE) ( QUOTE 1762) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC155 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Up Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 155) (QUOTE START-LINE) (QUOTE 1763) (QUOTE END-LINE) (QUOTE 1773) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC156 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Up Page") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 156) (QUOTE START-LINE) (QUOTE 1774) (QUOTE END-LINE) (QUOTE 1784) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC157 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Select Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 157) (QUOTE START-LINE) (QUOTE 1785) (QUOTE END-LINE) (QUOTE 1796) (QUOTE REF-LIST) (QUOTE (DOC9 DOC197)))) (SETQ DOC158 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Select Previous Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 158) (QUOTE START-LINE) (QUOTE 1797) (QUOTE END-LINE) (QUOTE 1807) (QUOTE REF-LIST) (QUOTE (DOC9 DOC197)))) ( SETQ DOC159 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Fill Column") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 159) ( QUOTE START-LINE) (QUOTE 1808) (QUOTE END-LINE) (QUOTE 1820) (QUOTE REF-LIST) ( QUOTE (DOC13 DOC19)))) (SETQ DOC160 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Set Fill Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 160) (QUOTE START-LINE) (QUOTE 1821) (QUOTE END-LINE) (QUOTE 1834) (QUOTE REF-LIST) (QUOTE (DOC13 DOC20)))) (SETQ DOC161 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Goal Column") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 161) (QUOTE START-LINE) (QUOTE 1835) ( QUOTE END-LINE) (QUOTE 1846) (QUOTE REF-LIST) (QUOTE (DOC13)))) (SETQ DOC162 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Key") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 162) (QUOTE START-LINE) (QUOTE 1847) (QUOTE END-LINE) (QUOTE 1857) (QUOTE REF-LIST) (QUOTE (DOC13)))) (SETQ DOC163 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Mark") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 163) (QUOTE START-LINE) ( QUOTE 1858) (QUOTE END-LINE) (QUOTE 1868) (QUOTE REF-LIST) (QUOTE (DOC7)))) ( SETQ DOC164 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Visited Filename") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 164) (QUOTE START-LINE) (QUOTE 1869) (QUOTE END-LINE) (QUOTE 1881) (QUOTE REF-LIST) (QUOTE (DOC13 DOC196)))) (SETQ DOC165 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Split Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 165) (QUOTE START-LINE) (QUOTE 1882) (QUOTE END-LINE) (QUOTE 1894) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC166 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Start Scripting") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 166) (QUOTE START-LINE) ( QUOTE 1895) (QUOTE END-LINE) (QUOTE 1910) (QUOTE REF-LIST) (QUOTE (DOC3)))) ( SETQ DOC167 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Start Timing") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 167) ( QUOTE START-LINE) (QUOTE 1911) (QUOTE END-LINE) (QUOTE 1923) (QUOTE REF-LIST) ( QUOTE (DOC3)))) (SETQ DOC168 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Stop Scripting") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 168) (QUOTE START-LINE) (QUOTE 1924) (QUOTE END-LINE) (QUOTE 1933) ( QUOTE REF-LIST) (QUOTE (DOC3)))) (SETQ DOC169 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Stop Timing") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 169) (QUOTE START-LINE) (QUOTE 1934) (QUOTE END-LINE) (QUOTE 1946) (QUOTE REF-LIST) (QUOTE (DOC3)))) (SETQ DOC170 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Tab To Tab Stop") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 170) (QUOTE START-LINE) ( QUOTE 1947) (QUOTE END-LINE) (QUOTE 1960) (QUOTE REF-LIST) (QUOTE (DOC6 DOC99)))) (SETQ DOC171 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Text Mode") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 171) ( QUOTE START-LINE) (QUOTE 1961) (QUOTE END-LINE) (QUOTE 1971) (QUOTE REF-LIST) ( QUOTE (DOC3 DOC193)))) (SETQ DOC172 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Transpose Characters") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 172) (QUOTE START-LINE) (QUOTE 1972) (QUOTE END-LINE) ( QUOTE 1983) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176)))) (SETQ DOC173 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Forms") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 173) (QUOTE START-LINE) ( QUOTE 1984) (QUOTE END-LINE) (QUOTE 1996) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176 DOC194 DOC195)))) (SETQ DOC174 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Transpose Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 174) (QUOTE START-LINE) (QUOTE 1997) (QUOTE END-LINE) (QUOTE 2007) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176)))) (SETQ DOC175 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Regions") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 175) (QUOTE START-LINE) (QUOTE 2008) ( QUOTE END-LINE) (QUOTE 2019) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC176 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Words") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 176) ( QUOTE START-LINE) (QUOTE 2020) (QUOTE END-LINE) (QUOTE 2035) (QUOTE REF-LIST) ( QUOTE (DOC2 DOC193)))) (SETQ DOC177 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Two Windows") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 177) (QUOTE START-LINE) (QUOTE 2036) (QUOTE END-LINE) (QUOTE 2045) ( QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC178 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Undelete File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 178) (QUOTE START-LINE) (QUOTE 2046) (QUOTE END-LINE) (QUOTE 2059) (QUOTE REF-LIST) (QUOTE (DOC10 DOC8 DOC196)))) (SETQ DOC179 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Universal Argument") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 179) (QUOTE START-LINE) (QUOTE 2060) (QUOTE END-LINE) (QUOTE 2070) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC180 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Unkill Previous") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 180) (QUOTE START-LINE) (QUOTE 2071) (QUOTE END-LINE) (QUOTE 2086) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17 DOC22)))) (SETQ DOC181 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Upcase Digit") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 181) (QUOTE START-LINE) ( QUOTE 2087) (QUOTE END-LINE) (QUOTE 2098) (QUOTE REF-LIST) (QUOTE (DOC2)))) ( SETQ DOC182 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Initial") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 182) (QUOTE START-LINE) (QUOTE 2099) (QUOTE END-LINE) (QUOTE 2109) (QUOTE REF-LIST) (QUOTE (DOC2 DOC193)))) (SETQ DOC183 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 183) (QUOTE START-LINE) (QUOTE 2110) (QUOTE END-LINE) (QUOTE 2119) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC184 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Word") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 184) (QUOTE START-LINE) ( QUOTE 2120) (QUOTE END-LINE) (QUOTE 2130) (QUOTE REF-LIST) (QUOTE (DOC2 DOC193)))) (SETQ DOC185 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "View Two Windows") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 185) (QUOTE START-LINE) (QUOTE 2131) (QUOTE END-LINE) (QUOTE 2139) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC186 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Visit File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 186) (QUOTE START-LINE) (QUOTE 2140) (QUOTE END-LINE) (QUOTE 2152) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC8 DOC196)))) (SETQ DOC187 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Visit In Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 187) (QUOTE START-LINE) (QUOTE 2153) (QUOTE END-LINE) (QUOTE 2166) (QUOTE REF-LIST) (QUOTE (DOC1 DOC9 DOC197 DOC196)))) (SETQ DOC188 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "What Cursor Position") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 188) (QUOTE START-LINE) (QUOTE 2167) (QUOTE END-LINE) (QUOTE 2180) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC189 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 189) (QUOTE START-LINE) (QUOTE 2181) (QUOTE END-LINE) (QUOTE 2192) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) (SETQ DOC190 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 190) (QUOTE START-LINE) ( QUOTE 2193) (QUOTE END-LINE) (QUOTE 2203) (QUOTE REF-LIST) (QUOTE (DOC10 DOC17 DOC196)))) (SETQ DOC191 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write Screen Photo") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 191) (QUOTE START-LINE) (QUOTE 2204) (QUOTE END-LINE) (QUOTE 2213) ( QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) (SETQ DOC192 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Yank Last Output") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 192) (QUOTE START-LINE) (QUOTE 2214) (QUOTE END-LINE) (QUOTE 2223) (QUOTE REF-LIST) (QUOTE (DOC8 DOC194 DOC195)))) (SETQ DOC193 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "TEXT") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 193) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC194 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "LISP") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 194) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC195 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "LISP") ( QUOTE TYPE) (QUOTE MODE) (QUOTE INDEX) (QUOTE 195) (QUOTE START-LINE) (QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC196 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "FILES") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 196) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC197 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "BUFFERS") (QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 197) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))))) |
Added psl-1983/3-1/doc/nmode/frames.lpt version [b4bcf79222].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ###0 Action Type Explanation: Alter Display Format This type of command alters how text is displayed without altering the contents of existing buffers. ###1 Action Type Explanation: Alter Existing Text This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. ###2 Action Type Explanation: Change Mode This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. ###3 Action Type Explanation: Escape Escape from the current level. ###4 Action Type Explanation: Inform This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). ###5 Action Type Explanation: Insert Constant This type of command inserts a character constant like tab or space or a multiple thereof. ###6 Action Type Explanation: Mark This type of command sets mark. ###7 Action Type Explanation: Move Data This command copies some data (which is not a constant wired into the program) from one place to another. ###8 Action Type Explanation: Move Point This type of command moves point. It may move it within a buffer or from buffer to buffer. ###9 Action Type Explanation: Preserve Make a copy of something current and put it somewhere else (usually disc). ###10 Action Type Explanation: Remove This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. ###11 Action Type Explanation: Select This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. ###12 Action Type Explanation: Set Global Variable This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. ###13 Action Type Explanation: Subsequent Command Modifier This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. ###14 Definition: Defun A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). ###15 Definition: Paragraph Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. ###16 Definition: Region The region is that portion of text between point, the current buffer position, and mark. ###17 Definition: Sentence A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. ###18 Global Explanation: Fill Column The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. ###19 Global Explanation: Fill Prefix The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. ###20 Global Explanation: Goal Column This is not yet correctly implemented ###21 Global Explanation: Kill Ring The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. ###22 Command: Append Next Kill Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. ###23 Command: Append To Buffer Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. ###24 Command: Append To File Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. ###25 Command: Apropos Function: apropos-command Key: M-X Apropos Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. ###26 Command: Argument Digit Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. ###27 Command: Auto Fill Mode Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. ###28 Command: Back To Indentation Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. ###29 Command: Backward Kill Sentence Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. ###30 Command: Backward Paragraph Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. ###31 Command: Backward Sentence Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. ###32 Command: Backward Up List Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). ###33 Command: Buffer Browser Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". ###34 Command: Buffer Not Modified Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. ###35 Command: C-X Prefix Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. ###36 Command: Center Line Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. ###37 Command: Copy Region Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. ###38 Command: Count Occurrences Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. ###39 Command: Delete And Expunge File Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. ###40 Command: Delete Backward Hacking Tabs Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. ###41 Command: Delete Blank Lines Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. ###42 Command: Delete File Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. ###43 Command: Delete Forward Character Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. ###44 Command: Delete Horizontal Space Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. ###45 Command: Delete Indentation Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). ###46 Command: Delete Matching Lines Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. ###47 Command: Delete Non-Matching Lines Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. ###48 Command: Dired Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. ###49 Command: Down List Function: down-list Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. Command argument sensitivity not yet implemented. ###50 Command: Edit Directory Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. ###51 Command: End Of Defun Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. ###52 Command: Esc Prefix Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. ###53 Command: Exchange Point And Mark Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. ###54 Command: Exchange Windows Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. ###55 Command: Execute Buffer Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. ###56 Command: Execute File Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. ###57 Command: Execute Form Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. ###58 Command: Exit Nmode Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. ###59 Command: Fill Comment Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. ###60 Command: Fill Paragraph Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. ###61 Command: Fill Region Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. ###62 Command: Find File Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. ###63 Command: Forward Paragraph Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. ###64 Command: Forward Sentence Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. ###65 Command: Forward Up List Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). ###66 Command: Get Register Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. ###67 Command: Grow Window Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). ###68 Command: Help Dispatch Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. ###69 Command: Incremental Search Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. ###70 Command: Indent New line Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. ###71 Command: Insert Buffer Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. ###72 Command: Insert Closing bracket Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. ###73 Command: Insert Comment Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. ###74 Command: Insert Date Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. ###75 Command: Insert File Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. ###76 Command: Insert Kill Buffer Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. ###77 Command: Insert Next Character Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. ###78 Command: Insert Parens Function: insert-parens Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point between them. Also make a space before them if appropriate. With argument, put the ) after the specified number of already existing s-expressions. Thus, with argument 1, puts extra parens around the following s-expression. ###79 Command: Kill Backward Form Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. ###80 Command: Kill Backward Word Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. ###81 Command: Kill Buffer Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. ###82 Command: Kill Forward Form Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. ###83 Command: Kill Forward Word Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. ###84 Command: Kill Line Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. ###85 Command: Kill Region Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. ###86 Command: Kill Sentence Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. ###87 Command: Kill Some Buffers Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. ###88 Command: Lisp Abort Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. ###89 Command: Lisp Backtrace Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. ###90 Command: Lisp Continue Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. ###91 Command: Lisp Help Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" ###92 Command: Lisp Indent Region Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. ###93 Command: Lisp Indent sexpr Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. ###94 Command: Lisp Mode Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. ###95 Command: Lisp Prefix Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. ###96 Command: Lisp Quit Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. ###97 Command: Lisp Retry Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. ###98 Command: Lisp Tab Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. ###99 Command: Lowercase Region Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. ###100 Command: Lowercase Word Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###101 Command: M-X Prefix Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. ###102 Command: Mark Beginning Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. ###103 Command: Mark Defun Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). ###104 Command: Mark End Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. ###105 Command: Mark Form Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. ###106 Command: Mark Paragraph Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. ###107 Command: Mark Whole Buffer Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. ###108 Command: Mark Word Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. ###109 Command: Move Backward Character Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. ###110 Command: Move Backward Defun Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. ###111 Command: Move Backward Form Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. ###112 Command: Move Backward List Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. ###113 Command: Move Backward Word Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. ###114 Command: Move Down Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. ###115 Command: Move Down Extending Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. ###116 Command: Move Forward Character Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. ###117 Command: Move Forward Form Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. ###118 Command: Move Forward List Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. ###119 Command: Move Forward Word Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. ###120 Command: Move To Buffer End Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). ###121 Command: Move To Buffer Start Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). ###122 Command: Move To End Of Line Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. ###123 Command: Move To Screen Edge Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). ###124 Command: Move To Start Of Line Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. ###125 Command: Move Up Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. ###126 Command: Negative Argument Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. ###127 Command: Next Screen Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. ###128 Command: Nmode Abort Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. ###129 Command: Nmode Exit To Superior Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. ###130 Command: Nmode Full Refresh Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. ###131 Command: Nmode Gc Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. ###132 Command: Nmode Invert Video Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. ###133 Command: Nmode Refresh Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. ###134 Command: One Window Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. ###135 Command: Open Line Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. ###136 Command: Other Window Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. ###137 Command: Prepend To File Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. ###138 Command: Previous Screen Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. ###139 Command: Put Register Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. ###140 Command: Query Replace Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. ^L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. ###141 Command: Rename Buffer Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. ###142 Command: Replace String Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. ###143 Command: Reposition Window Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. ###144 Command: Return Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. ###145 Command: Reverse Search Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. ###146 Command: Revert File Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk ###147 Command: Save All Files Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. ###148 Command: Save File Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. ###149 Command: Scroll Other Window Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. ###150 Command: Scroll Window Down Line Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###151 Command: Scroll Window Down Page Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###152 Command: Scroll Window Left Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. ###153 Command: Scroll Window Right Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. ###154 Command: Scroll Window Up Line Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###155 Command: Scroll Window Up Page Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###156 Command: Select Buffer Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. ###157 Command: Select Previous Buffer Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. ###158 Command: Set Fill Column Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. ###159 Command: Set Fill Prefix Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. ###160 Command: Set Goal Column Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. ###161 Command: Set Key Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. ###162 Command: Set Mark Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. ###163 Command: Set Visited Filename Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. ###164 Command: Split Line Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. ###165 Command: Start Scripting Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. ###166 Command: Start Timing Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. ###167 Command: Stop Scripting Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. ###168 Command: Stop Timing Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. ###169 Command: Tab To Tab Stop Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. ###170 Command: Text Mode Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. ###171 Command: Transpose Characters Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. ###172 Command: Transpose Forms Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". ###173 Command: Transpose Lines Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". ###174 Command: Transpose Regions Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. ###175 Command: Transpose Words Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. ###176 Command: Two Windows Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. ###177 Command: Undelete File Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. ###178 Command: Universal Argument Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. ###179 Command: Unkill Previous Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. ###180 Command: Upcase Digit Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. ###181 Command: Uppercase Initial Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###182 Command: Uppercase Region Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. ###183 Command: Uppercase Word Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###184 Command: View Two Windows Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. ###185 Command: Visit File Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. ###186 Command: Visit In Other Window Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. ###187 Command: What Cursor Position Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. ###188 Command: Write File Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. ###189 Command: Write Region Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. ###190 Command: Write Screen Photo Function: write-screen-photo-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. ###191 Command: Yank Last Output Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. |
Added psl-1983/3-1/doc/nmode/manual.ibm version [ef05167e1b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>MANUAL.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Reference Manual Preliminary Edition 11 February 1983 11:07:16 This document is a preliminary edition of the NMODE Reference Manual. Do not distribute this document! 201/- 2 - NMODE Manual 201/NMODE Manual - 5 - Introduction 202/1. Introduction 201/This document describes the NMODE text editor. NMODE is an interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified appropriately in areas where NMODE and EMACS differ. 201/Introduction - 6 - NMODE Manual 201/NMODE Manual - 7 - Action Types 202/2. Action Types 201/This section defines a number of 203/action types201/, which are used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Display Format 201/This type of command alters how text is displayed without altering the contents of existing buffers. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Existing Text 201/This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Change Mode 201/This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Escape 201/Escape from the current level. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Inform 201/This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Insert Constant 201/This type of command inserts a character constant like tab or space or a multiple thereof. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Mark 201/This type of command sets mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Action Types - 8 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Data 201/This command copies some data (which is not a constant wired into the program) from one place to another. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Point 201/This type of command moves point. It may move it within a buffer or from buffer to buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Preserve 201/Make a copy of something current and put it somewhere else (usually disc). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Remove 201/This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Select 201/This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Set Global Variable 201/This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Subsequent Command Modifier 201/This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 9 - Definitions 202/3. Definitions 201/This section defines a number of terms used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Defun 201/A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Paragraph 201/Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Region 201/The region is that portion of text between point, the current buffer position, and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Sentence 201/A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Definitions - 10 - NMODE Manual 201/NMODE Manual - 11 - Globals 202/4. Globals 201/This section defines a number of conceptual 203/global variables201/, which are referred to in the descriptions of NMODE commands. These 203/globals 201/represent state information that can affect the behavior of various NMODE commands. The value of NMODE globals are set as the result of various NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Column 201/The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Prefix 201/The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Goal Column 201/This is not yet correctly implemented 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Kill Ring 201/The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Globals - 12 - NMODE Manual 201/NMODE Manual - 13 - Command Descriptions 202/5. Command Descriptions 201/This section defines the basic NMODE commands. Each command description includes the following information: 203/command 201/A descriptive name of the command. 203/function 201/The name of the Lisp function that implements the command. 203/key 201/The logical keys on the keyboard that normally have this command attached to them. A 203/logical key 201/includes ordinary keys such as Tab or Rubout, 203/shifted 201/keys using the 202/Control 201/and/or 202/Meta 201/modifiers (e.g., C-F, M-F, and C-M-F), 203/prefixed commands 201/using C-X, C-], or Escape (e.g., C-X C-F, C-] E, and Esc-L), and 203/extended commands 201/using 202/Meta-X 201/(e.g., M-X Delete Matching Lines). 203/action type 201/One of a number of descriptive terms that categorize the behavior of commands. Action types are defined in Chapter 2. 203/mode 201/Some commands are defined only in certain modes. If present, this attribute specifies the mode or modes in which the command is normally defined. 203/topic 201/A keyword that describes the command. Topics are listed in the Topic Index, Chapter 9. 201/Command Descriptions - 14 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append Next Kill 201/Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To Buffer 201/Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To File 201/Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Apropos 201/Function: apropos-command Key: M-X Apropos Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 15 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Argument Digit 201/Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Auto Fill Mode 201/Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 16 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Back To Indentation 201/Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Kill Sentence 201/Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Paragraph 201/Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Sentence 201/Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 17 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Up List 201/Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Browser 201/Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Not Modified 201/Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: C-X Prefix 201/Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 18 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Center Line 201/Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Copy Region 201/Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Count Occurrences 201/Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete And Expunge File 201/Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 19 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Backward Hacking Tabs 201/Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Blank Lines 201/Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete File 201/Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Forward Character 201/Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 20 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Horizontal Space 201/Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Indentation 201/Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Matching Lines 201/Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Non-Matching Lines 201/Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Dired 201/Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 21 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Down List 201/Function: down-list Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. Command argument sensitivity not yet implemented. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Edit Directory 201/Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: End Of Defun 201/Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 22 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Esc Prefix 201/Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Point And Mark 201/Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Windows 201/Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Buffer 201/Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute File 201/Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 23 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Form 201/Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exit Nmode 201/Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Comment 201/Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Paragraph 201/Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 24 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Region 201/Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Find File 201/Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Paragraph 201/Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 25 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Sentence 201/Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Up List 201/Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Get Register 201/Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Grow Window 201/Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 26 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Help Dispatch 201/Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Incremental Search 201/Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Indent New line 201/Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Buffer 201/Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 27 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Closing bracket 201/Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Comment 201/Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Date 201/Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert File 201/Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 28 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Kill Buffer 201/Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Next Character 201/Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Parens 201/Function: insert-parens Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point between them. Also make a space before them if appropriate. With argument, put the ) after the specified number of already existing s-expressions. Thus, with argument 1, puts extra parens around the following s-expression. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Form 201/Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 29 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Word 201/Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Buffer 201/Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Form 201/Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Word 201/Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 30 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Line 201/Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Region 201/Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Sentence 201/Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Some Buffers 201/Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 31 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Abort 201/Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Backtrace 201/Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Continue 201/Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Help 201/Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 32 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent Region 201/Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent sexpr 201/Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Mode 201/Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Prefix 201/Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 33 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Quit 201/Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Retry 201/Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Tab 201/Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Region 201/Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 34 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Word 201/Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: M-X Prefix 201/Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Beginning 201/Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Defun 201/Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 35 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark End 201/Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Form 201/Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Paragraph 201/Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Whole Buffer 201/Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Word 201/Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 36 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Character 201/Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Defun 201/Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Form 201/Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward List 201/Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 37 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Word 201/Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down 201/Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down Extending 201/Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Character 201/Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 38 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Form 201/Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward List 201/Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Word 201/Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer End 201/Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 39 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer Start 201/Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To End Of Line 201/Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Screen Edge 201/Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Start Of Line 201/Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Up 201/Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 40 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Negative Argument 201/Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Next Screen 201/Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Abort 201/Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Exit To Superior 201/Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Full Refresh 201/Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 41 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Gc 201/Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Invert Video 201/Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Refresh 201/Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: One Window 201/Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Open Line 201/Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 42 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Other Window 201/Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Prepend To File 201/Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Previous Screen 201/Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Put Register 201/Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Query Replace 201/Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of 201/NMODE Manual - 43 - Command Descriptions the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. ^L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Rename Buffer 201/Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Replace String 201/Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reposition Window 201/Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Return 201/Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 44 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reverse Search 201/Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Revert File 201/Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save All Files 201/Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save File 201/Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Other Window 201/Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 45 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Line 201/Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Page 201/Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Left 201/Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Right 201/Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Line 201/Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 46 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Page 201/Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Buffer 201/Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Previous Buffer 201/Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Column 201/Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 47 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Prefix 201/Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Goal Column 201/Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Key 201/Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Mark 201/Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 48 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Visited Filename 201/Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Split Line 201/Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Scripting 201/Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Timing 201/Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 49 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Scripting 201/Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Timing 201/Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Tab To Tab Stop 201/Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Text Mode 201/Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 50 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Characters 201/Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Forms 201/Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Lines 201/Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Regions 201/Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 51 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Words 201/Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Two Windows 201/Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Undelete File 201/Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Universal Argument 201/Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 52 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Unkill Previous 201/Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Upcase Digit 201/Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Initial 201/Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Region 201/Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 53 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Word 201/Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: View Two Windows 201/Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit File 201/Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit In Other Window 201/Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 54 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: What Cursor Position 201/Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write File 201/Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Region 201/Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Screen Photo 201/Function: write-screen-photo-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 55 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Yank Last Output 201/Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 56 - NMODE Manual 201/NMODE Manual - 57 - Command Index 202/6. Command Index 201/Append Next Kill . . . . . . . . . . . . . . . . . . . . 14 Append To Buffer . . . . . . . . . . . . . . . . . . . . 14 Append To File . . . . . . . . . . . . . . . . . . . . . 14 Apropos . . . . . . . . . . . . . . . . . . . . . . . . . 14 Argument Digit . . . . . . . . . . . . . . . . . . . . . 15 Auto Fill Mode . . . . . . . . . . . . . . . . . . . . . . 15 Back To Indentation . . . . . . . . . . . . . . . . . . . 16 Backward Kill Sentence . . . . . . . . . . . . . . . . . 16 Backward Paragraph . . . . . . . . . . . . . . . . . . . 16 Backward Sentence . . . . . . . . . . . . . . . . . . . . 16 Backward Up List . . . . . . . . . . . . . . . . . . . . 17 Buffer Browser . . . . . . . . . . . . . . . . . . . . . 17 Buffer Not Modified . . . . . . . . . . . . . . . . . . . 17 C-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 Center Line . . . . . . . . . . . . . . . . . . . . . . . 18 Copy Region . . . . . . . . . . . . . . . . . . . . . . . 18 Count Occurrences . . . . . . . . . . . . . . . . . . . . 18 Delete And Expunge File . . . . . . . . . . . . . . . . . 18 Delete Backward Hacking Tabs . . . . . . . . . . . . . . 19 Delete Blank Lines . . . . . . . . . . . . . . . . . . . . 19 Delete File . . . . . . . . . . . . . . . . . . . . . . . . 19 Delete Forward Character . . . . . . . . . . . . . . . . 19 Delete Horizontal Space . . . . . . . . . . . . . . . . . 20 Delete Indentation . . . . . . . . . . . . . . . . . . . . 20 Delete Matching Lines . . . . . . . . . . . . . . . . . . 20 Delete Non-Matching Lines . . . . . . . . . . . . . . . . 20 Dired . . . . . . . . . . . . . . . . . . . . . . . . . . 20 Down List . . . . . . . . . . . . . . . . . . . . . . . . 21 Edit Directory . . . . . . . . . . . . . . . . . . . . . . 21 End Of Defun . . . . . . . . . . . . . . . . . . . . . . 21 Esc Prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 Exchange Point And Mark . . . . . . . . . . . . . . . . 22 Exchange Windows . . . . . . . . . . . . . . . . . . . . 22 Execute Buffer . . . . . . . . . . . . . . . . . . . . . . 22 Execute File . . . . . . . . . . . . . . . . . . . . . . . 22 Execute Form . . . . . . . . . . . . . . . . . . . . . . 23 Exit Nmode . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Comment . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Paragraph . . . . . . . . . . . . . . . . . . . . . . 23 Fill Region . . . . . . . . . . . . . . . . . . . . . . . . 24 Find File . . . . . . . . . . . . . . . . . . . . . . . . . 24 Forward Paragraph . . . . . . . . . . . . . . . . . . . . 24 Forward Sentence . . . . . . . . . . . . . . . . . . . . 25 Forward Up List . . . . . . . . . . . . . . . . . . . . . 25 201/Command Index - 58 - NMODE Manual Get Register . . . . . . . . . . . . . . . . . . . . . . . 25 Grow Window . . . . . . . . . . . . . . . . . . . . . . . 25 Help Dispatch . . . . . . . . . . . . . . . . . . . . . . 26 Incremental Search . . . . . . . . . . . . . . . . . . . . 26 Indent New line . . . . . . . . . . . . . . . . . . . . . 26 Insert Buffer . . . . . . . . . . . . . . . . . . . . . . 26 Insert Closing bracket . . . . . . . . . . . . . . . . . . 27 Insert Comment . . . . . . . . . . . . . . . . . . . . . 27 Insert Date . . . . . . . . . . . . . . . . . . . . . . . 27 Insert File . . . . . . . . . . . . . . . . . . . . . . . . 27 Insert Kill Buffer . . . . . . . . . . . . . . . . . . . . 28 Insert Next Character . . . . . . . . . . . . . . . . . . 28 Insert Parens . . . . . . . . . . . . . . . . . . . . . . 28 Kill Backward Form . . . . . . . . . . . . . . . . . . . 28 Kill Backward Word . . . . . . . . . . . . . . . . . . . 29 Kill Buffer . . . . . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Form . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Word . . . . . . . . . . . . . . . . . . . . 29 Kill Line . . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Region . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Sentence . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Some Buffers . . . . . . . . . . . . . . . . . . . . 30 Lisp Abort . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Backtrace . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Continue . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Help . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Indent Region . . . . . . . . . . . . . . . . . . . . 32 Lisp Indent sexpr . . . . . . . . . . . . . . . . . . . . 32 Lisp Mode . . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Prefix . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Quit . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Retry . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Tab . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lowercase Region . . . . . . . . . . . . . . . . . . . . 33 Lowercase Word . . . . . . . . . . . . . . . . . . . . . 34 M-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 Mark Beginning . . . . . . . . . . . . . . . . . . . . . 34 Mark Defun . . . . . . . . . . . . . . . . . . . . . . . 34 Mark End . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Form . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Paragraph . . . . . . . . . . . . . . . . . . . . . 35 Mark Whole Buffer . . . . . . . . . . . . . . . . . . . . 35 Mark Word . . . . . . . . . . . . . . . . . . . . . . . . 35 Move Backward Character . . . . . . . . . . . . . . . . 36 Move Backward Defun . . . . . . . . . . . . . . . . . . 36 Move Backward Form . . . . . . . . . . . . . . . . . . . 36 Move Backward List . . . . . . . . . . . . . . . . . . . 36 Move Backward Word . . . . . . . . . . . . . . . . . . . 37 201/NMODE Manual - 59 - Command Index Move Down . . . . . . . . . . . . . . . . . . . . . . . . 37 Move Down Extending . . . . . . . . . . . . . . . . . . 37 Move Forward Character . . . . . . . . . . . . . . . . . 37 Move Forward Form . . . . . . . . . . . . . . . . . . . 38 Move Forward List . . . . . . . . . . . . . . . . . . . . 38 Move Forward Word . . . . . . . . . . . . . . . . . . . 38 Move To Buffer End . . . . . . . . . . . . . . . . . . . 38 Move To Buffer Start . . . . . . . . . . . . . . . . . . 39 Move To End Of Line . . . . . . . . . . . . . . . . . . 39 Move To Screen Edge . . . . . . . . . . . . . . . . . . 39 Move To Start Of Line . . . . . . . . . . . . . . . . . . 39 Move Up . . . . . . . . . . . . . . . . . . . . . . . . . 39 Negative Argument . . . . . . . . . . . . . . . . . . . . 40 Next Screen . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Abort . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Exit To Superior . . . . . . . . . . . . . . . . . 40 Nmode Full Refresh . . . . . . . . . . . . . . . . . . . 40 Nmode Gc . . . . . . . . . . . . . . . . . . . . . . . . 41 Nmode Invert Video . . . . . . . . . . . . . . . . . . . 41 Nmode Refresh . . . . . . . . . . . . . . . . . . . . . . 41 One Window . . . . . . . . . . . . . . . . . . . . . . . 41 Open Line . . . . . . . . . . . . . . . . . . . . . . . . 41 Other Window . . . . . . . . . . . . . . . . . . . . . . 42 Prepend To File . . . . . . . . . . . . . . . . . . . . . 42 Previous Screen . . . . . . . . . . . . . . . . . . . . . 42 Put Register . . . . . . . . . . . . . . . . . . . . . . . 42 Query Replace . . . . . . . . . . . . . . . . . . . . . . 42 Rename Buffer . . . . . . . . . . . . . . . . . . . . . . 43 Replace String . . . . . . . . . . . . . . . . . . . . . . 43 Reposition Window . . . . . . . . . . . . . . . . . . . . 43 Return . . . . . . . . . . . . . . . . . . . . . . . . . . 43 Reverse Search . . . . . . . . . . . . . . . . . . . . . 44 Revert File . . . . . . . . . . . . . . . . . . . . . . . 44 Save All Files . . . . . . . . . . . . . . . . . . . . . . 44 Save File . . . . . . . . . . . . . . . . . . . . . . . . 44 Scroll Other Window . . . . . . . . . . . . . . . . . . . 44 Scroll Window Down Line . . . . . . . . . . . . . . . . . 45 Scroll Window Down Page . . . . . . . . . . . . . . . . . 45 Scroll Window Left . . . . . . . . . . . . . . . . . . . . 45 Scroll Window Right . . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Line . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Page . . . . . . . . . . . . . . . . . . 46 Select Buffer . . . . . . . . . . . . . . . . . . . . . . 46 Select Previous Buffer . . . . . . . . . . . . . . . . . . 46 Set Fill Column . . . . . . . . . . . . . . . . . . . . . 46 Set Fill Prefix . . . . . . . . . . . . . . . . . . . . . . 47 Set Goal Column . . . . . . . . . . . . . . . . . . . . . 47 201/Command Index - 60 - NMODE Manual Set Key . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Mark . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Visited Filename . . . . . . . . . . . . . . . . . . . 48 Split Line . . . . . . . . . . . . . . . . . . . . . . . . 48 Start Scripting . . . . . . . . . . . . . . . . . . . . . . 48 Start Timing . . . . . . . . . . . . . . . . . . . . . . . 48 Stop Scripting . . . . . . . . . . . . . . . . . . . . . . 49 Stop Timing . . . . . . . . . . . . . . . . . . . . . . . 49 Tab To Tab Stop . . . . . . . . . . . . . . . . . . . . 49 Text Mode . . . . . . . . . . . . . . . . . . . . . . . . 49 Transpose Characters . . . . . . . . . . . . . . . . . . 50 Transpose Forms . . . . . . . . . . . . . . . . . . . . . 50 Transpose Lines . . . . . . . . . . . . . . . . . . . . . 50 Transpose Regions . . . . . . . . . . . . . . . . . . . . 50 Transpose Words . . . . . . . . . . . . . . . . . . . . . 51 Two Windows . . . . . . . . . . . . . . . . . . . . . . . 51 Undelete File . . . . . . . . . . . . . . . . . . . . . . . 51 Universal Argument . . . . . . . . . . . . . . . . . . . 51 Unkill Previous . . . . . . . . . . . . . . . . . . . . . 52 Upcase Digit . . . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Initial . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Region . . . . . . . . . . . . . . . . . . . . 52 Uppercase Word . . . . . . . . . . . . . . . . . . . . . 53 View Two Windows . . . . . . . . . . . . . . . . . . . . 53 Visit File . . . . . . . . . . . . . . . . . . . . . . . . 53 Visit In Other Window . . . . . . . . . . . . . . . . . . 53 What Cursor Position . . . . . . . . . . . . . . . . . . . 54 Write File . . . . . . . . . . . . . . . . . . . . . . . . 54 Write Region . . . . . . . . . . . . . . . . . . . . . . . 54 Write Screen Photo . . . . . . . . . . . . . . . . . . . . 54 Yank Last Output . . . . . . . . . . . . . . . . . . . . 55 201/NMODE Manual - 61 - Function Index 202/7. Function Index 201/append-next-kill-command . . . . . . . . . . . . . . . . 14 append-to-buffer-command . . . . . . . . . . . . . . . . 14 append-to-file-command . . . . . . . . . . . . . . . . . 14 apropos-command . . . . . . . . . . . . . . . . . . . . . 14 argument-digit . . . . . . . . . . . . . . . . . . . . . . 15 auto-fill-mode-command . . . . . . . . . . . . . . . . . . 15 back-to-indentation-command . . . . . . . . . . . . . . . 16 backward-kill-sentence-command . . . . . . . . . . . . . 16 backward-paragraph-command . . . . . . . . . . . . . . 16 backward-sentence-command . . . . . . . . . . . . . . . 16 backward-up-list-command . . . . . . . . . . . . . . . . 17 buffer-browser-command . . . . . . . . . . . . . . . . . 17 buffer-not-modified-command . . . . . . . . . . . . . . . 17 c-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 center-line-command . . . . . . . . . . . . . . . . . . . 18 copy-region . . . . . . . . . . . . . . . . . . . . . . . 18 count-occurrences-command . . . . . . . . . . . . . . . 18 delete-and-expunge-file-command . . . . . . . . . . . . . 18 delete-backward-hacking-tabs-command . . . . . . . . . . 19 delete-blank-lines-command . . . . . . . . . . . . . . . . 19 delete-file-command . . . . . . . . . . . . . . . . . . . 19 delete-forward-character-command . . . . . . . . . . . . 19 delete-horizontal-space-command . . . . . . . . . . . . . 20 delete-indentation-command . . . . . . . . . . . . . . . . 20 delete-matching-lines-command . . . . . . . . . . . . . . 20 delete-non-matching-lines-command . . . . . . . . . . . . 20 dired-command . . . . . . . . . . . . . . . . . . . . . . 20 down-list . . . . . . . . . . . . . . . . . . . . . . . . 21 edit-directory-command . . . . . . . . . . . . . . . . . . 21 end-of-defun-command . . . . . . . . . . . . . . . . . . 21 esc-prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 exchange-point-and-mark . . . . . . . . . . . . . . . . . 22 exchange-windows-command . . . . . . . . . . . . . . . 22 execute-buffer-command . . . . . . . . . . . . . . . . . 22 execute-file-command . . . . . . . . . . . . . . . . . . . 22 execute-form-command . . . . . . . . . . . . . . . . . . 23 exit-nmode . . . . . . . . . . . . . . . . . . . . . . . . 23 fill-comment-command . . . . . . . . . . . . . . . . . . . 23 fill-paragraph-command . . . . . . . . . . . . . . . . . . 23 fill-region-command . . . . . . . . . . . . . . . . . . . 24 find-file-command . . . . . . . . . . . . . . . . . . . . 24 forward-paragraph-command . . . . . . . . . . . . . . . 24 forward-sentence-command . . . . . . . . . . . . . . . . 25 forward-up-list-command . . . . . . . . . . . . . . . . . 25 201/Function Index - 62 - NMODE Manual get-register-command . . . . . . . . . . . . . . . . . . 25 grow-window-command . . . . . . . . . . . . . . . . . . 25 help-dispatch . . . . . . . . . . . . . . . . . . . . . . 26 incremental-search-command . . . . . . . . . . . . . . . 26 indent-new-line-command . . . . . . . . . . . . . . . . . 26 insert-buffer-command . . . . . . . . . . . . . . . . . . 26 insert-closing-bracket . . . . . . . . . . . . . . . . . . 27 insert-comment-command . . . . . . . . . . . . . . . . . 27 insert-date-command . . . . . . . . . . . . . . . . . . . 27 insert-file-command . . . . . . . . . . . . . . . . . . . 27 insert-kill-buffer . . . . . . . . . . . . . . . . . . . . . 28 insert-next-character-command . . . . . . . . . . . . . . 28 insert-parens . . . . . . . . . . . . . . . . . . . . . . 28 kill-backward-form-command . . . . . . . . . . . . . . . 28 kill-backward-word-command . . . . . . . . . . . . . . . 29 kill-buffer-command . . . . . . . . . . . . . . . . . . . 29 kill-forward-form-command . . . . . . . . . . . . . . . . 29 kill-forward-word-command . . . . . . . . . . . . . . . . 29 kill-line . . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-region . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-sentence-command . . . . . . . . . . . . . . . . . . 30 kill-some-buffers-command . . . . . . . . . . . . . . . . 30 lisp-abort-command . . . . . . . . . . . . . . . . . . . . 31 lisp-backtrace-command . . . . . . . . . . . . . . . . . 31 lisp-continue-command . . . . . . . . . . . . . . . . . . 31 lisp-help-command . . . . . . . . . . . . . . . . . . . . 31 lisp-indent-region-command . . . . . . . . . . . . . . . . 32 lisp-indent-sexpr . . . . . . . . . . . . . . . . . . . . 32 lisp-mode-command . . . . . . . . . . . . . . . . . . . . 32 lisp-prefix . . . . . . . . . . . . . . . . . . . . . . . . 32 lisp-quit-command . . . . . . . . . . . . . . . . . . . . 33 lisp-retry-command . . . . . . . . . . . . . . . . . . . . 33 lisp-tab-command . . . . . . . . . . . . . . . . . . . . . 33 lowercase-region-command . . . . . . . . . . . . . . . . 33 lowercase-word-command . . . . . . . . . . . . . . . . . 34 m-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 mark-beginning-command . . . . . . . . . . . . . . . . . 34 mark-defun-command . . . . . . . . . . . . . . . . . . . 34 mark-end-command . . . . . . . . . . . . . . . . . . . . 35 mark-form-command . . . . . . . . . . . . . . . . . . . 35 mark-paragraph-command . . . . . . . . . . . . . . . . . 35 mark-whole-buffer-command . . . . . . . . . . . . . . . 35 mark-word-command . . . . . . . . . . . . . . . . . . . 35 move-backward-character-command . . . . . . . . . . . . 36 move-backward-defun-command . . . . . . . . . . . . . . 36 move-backward-form-command . . . . . . . . . . . . . . 36 move-backward-list-command . . . . . . . . . . . . . . . 36 move-backward-word-command . . . . . . . . . . . . . . 37 201/NMODE Manual - 63 - Function Index move-down-command . . . . . . . . . . . . . . . . . . . 37 move-down-extending-command . . . . . . . . . . . . . . 37 move-forward-character-command . . . . . . . . . . . . . 37 move-forward-form-command . . . . . . . . . . . . . . . 38 move-forward-list-command . . . . . . . . . . . . . . . . 38 move-forward-word-command . . . . . . . . . . . . . . . 38 move-to-buffer-end-command . . . . . . . . . . . . . . . 38 move-to-buffer-start-command . . . . . . . . . . . . . . 39 move-to-end-of-line-command . . . . . . . . . . . . . . . 39 move-to-screen-edge-command . . . . . . . . . . . . . . 39 move-to-start-of-line-command . . . . . . . . . . . . . . 39 move-up-command . . . . . . . . . . . . . . . . . . . . 39 negative-argument . . . . . . . . . . . . . . . . . . . . 40 next-screen-command . . . . . . . . . . . . . . . . . . . 40 nmode-abort-command . . . . . . . . . . . . . . . . . . 40 nmode-exit-to-superior . . . . . . . . . . . . . . . . . . 40 nmode-full-refresh . . . . . . . . . . . . . . . . . . . . 40 nmode-gc . . . . . . . . . . . . . . . . . . . . . . . . 41 nmode-invert-video . . . . . . . . . . . . . . . . . . . . 41 nmode-refresh-command . . . . . . . . . . . . . . . . . 41 one-window-command . . . . . . . . . . . . . . . . . . . 41 open-line-command . . . . . . . . . . . . . . . . . . . . 41 other-window-command . . . . . . . . . . . . . . . . . . 42 prepend-to-file-command . . . . . . . . . . . . . . . . . 42 previous-screen-command . . . . . . . . . . . . . . . . . 42 put-register-command . . . . . . . . . . . . . . . . . . 42 query-replace-command . . . . . . . . . . . . . . . . . . 42 rename-buffer-command . . . . . . . . . . . . . . . . . 43 replace-string-command . . . . . . . . . . . . . . . . . 43 reposition-window-command . . . . . . . . . . . . . . . . 43 return-command . . . . . . . . . . . . . . . . . . . . . 43 reverse-search-command . . . . . . . . . . . . . . . . . 44 revert-file-command . . . . . . . . . . . . . . . . . . . 44 save-all-files-command . . . . . . . . . . . . . . . . . . 44 save-file-command . . . . . . . . . . . . . . . . . . . . 44 scroll-other-window-command . . . . . . . . . . . . . . . 44 scroll-window-down-line-command . . . . . . . . . . . . . 45 scroll-window-down-page-command . . . . . . . . . . . . 45 scroll-window-left-command . . . . . . . . . . . . . . . . 45 scroll-window-right-command . . . . . . . . . . . . . . . 45 scroll-window-up-line-command . . . . . . . . . . . . . . 45 scroll-window-up-page-command . . . . . . . . . . . . . 46 select-buffer-command . . . . . . . . . . . . . . . . . . 46 select-previous-buffer-command . . . . . . . . . . . . . 46 set-fill-column-command . . . . . . . . . . . . . . . . . 46 set-fill-prefix-command . . . . . . . . . . . . . . . . . . 47 set-goal-column-command . . . . . . . . . . . . . . . . . 47 201/Function Index - 64 - NMODE Manual set-key-command . . . . . . . . . . . . . . . . . . . . . 47 set-mark-command . . . . . . . . . . . . . . . . . . . . 47 set-visited-filename-command . . . . . . . . . . . . . . . 48 split-line-command . . . . . . . . . . . . . . . . . . . . 48 start-scripting-command . . . . . . . . . . . . . . . . . 48 start-timing-command . . . . . . . . . . . . . . . . . . . 48 stop-scripting-command . . . . . . . . . . . . . . . . . 49 stop-timing-command . . . . . . . . . . . . . . . . . . . 49 tab-to-tab-stop-command . . . . . . . . . . . . . . . . . 49 text-mode-command . . . . . . . . . . . . . . . . . . . . 49 transpose-characters-command . . . . . . . . . . . . . . 50 transpose-forms . . . . . . . . . . . . . . . . . . . . . 50 transpose-lines . . . . . . . . . . . . . . . . . . . . . . 50 transpose-regions . . . . . . . . . . . . . . . . . . . . 50 transpose-words . . . . . . . . . . . . . . . . . . . . . 51 two-windows-command . . . . . . . . . . . . . . . . . . 51 undelete-file-command . . . . . . . . . . . . . . . . . . 51 universal-argument . . . . . . . . . . . . . . . . . . . . 51 unkill-previous . . . . . . . . . . . . . . . . . . . . . . 52 upcase-digit-command . . . . . . . . . . . . . . . . . . 52 uppercase-initial-command . . . . . . . . . . . . . . . . 52 uppercase-region-command . . . . . . . . . . . . . . . . 52 uppercase-word-command . . . . . . . . . . . . . . . . . 53 view-two-windows-command . . . . . . . . . . . . . . . . 53 visit-file-command . . . . . . . . . . . . . . . . . . . . 53 visit-in-other-window-command . . . . . . . . . . . . . . 53 what-cursor-position-command . . . . . . . . . . . . . . 54 write-file-command . . . . . . . . . . . . . . . . . . . . 54 write-region-command . . . . . . . . . . . . . . . . . . 54 write-screen-photo-command . . . . . . . . . . . . . . . 54 yank-last-output-command . . . . . . . . . . . . . . . . 55 201/NMODE Manual - 65 - Key Index 202/8. Key Index 201/) . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 BACKSPACE . . . . . . . . . . . . . . . . . . . . . . . 19 C-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-= . . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-( . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-) . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-M-- . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-M-A . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-B . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-BACKSPACE . . . . . . . . . . . . . . . . . . . . 34 C-M-D . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-M-E . . . . . . . . . . . . . . . . . . . . . . . . . . 21 201/Key Index - 66 - NMODE Manual C-M-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-H . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-I . . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-M-L . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-M-M . . . . . . . . . . . . . . . . . . . . . . . . . . 16 C-M-N . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-O . . . . . . . . . . . . . . . . . . . . . . . . . . 48 C-M-P . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-R . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-M-RETURN . . . . . . . . . . . . . . . . . . . . . . 16 C-M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . 28 C-M-T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-M-TAB . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-U . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-V . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-M-W . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-M-X . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-] . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-N . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-O . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-P . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 19 C-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-SPACE . . . . . . . . . . . . . . . . . . . . . . . . 47 C-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X < . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X 1 . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X 2 . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-X 3 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X 4 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X = . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X > . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X A . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-X B . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X C-B . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X C-F . . . . . . . . . . . . . . . . . . . . . . . . . 24 C-X C-L . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-X C-N . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X C-O . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-X C-S . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-X C-T . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X C-U . . . . . . . . . . . . . . . . . . . . . . . . . 52 C-X C-V . . . . . . . . . . . . . . . . . . . . . . . . . 53 201/NMODE Manual - 67 - Key Index C-X C-W . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X C-X . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X C-Z . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-X D . . . . . . . . . . . . . . . . . . . . . . . . . . 20 C-X E . . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X F . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X G . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-X H . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-X K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-X O . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X P . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X RUBOUT . . . . . . . . . . . . . . . . . . . . . . 16 C-X T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X V . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X X . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X ^ . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 32 ESC-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-A . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-B . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-C . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-D . . . . . . . . . . . . . . . . . . . . . . . . . . 36 ESC-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-H . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-J . . . . . . . . . . . . . . . . . . . . . . . . . . 40 ESC-L . . . . . . . . . . . . . . . . . . . . . . . . . . 41 ESC-M . . . . . . . . . . . . . . . . . . . . . . . . . . 30 ESC-P . . . . . . . . . . . . . . . . . . . . . . . . . . 19 ESC-S . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-T . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-U . . . . . . . . . . . . . . . . . . . . . . . . . . 46 ESC-V . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESCAPE . . . . . . . . . . . . . . . . . . . . . . . . . 22 Lisp-? . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-A . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-B . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-C . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-E . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-L . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-R . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-Y . . . . . . . . . . . . . . . . . . . . . . . . . . 55 M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-' . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 M-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 M-/ . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 201/Key Index - 68 - NMODE Manual M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-; . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 M-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 M-BACKSPACE . . . . . . . . . . . . . . . . . . . . . . 34 M-C . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 M-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 M-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-H . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-I . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 M-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-M . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-RETURN . . . . . . . . . . . . . . . . . . . . . . . . 16 M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 29 M-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 M-TAB . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 53 M-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-X Append To File . . . . . . . . . . . . . . . . . . . 14 M-X Apropos . . . . . . . . . . . . . . . . . . . . . . . 14 M-X Auto Fill Mode . . . . . . . . . . . . . . . . . . . 15 M-X Count Occurrences . . . . . . . . . . . . . . . . . 18 M-X Delete And Expunge File . . . . . . . . . . . . . . 18 M-X Delete File . . . . . . . . . . . . . . . . . . . . . 19 M-X Delete Matching Lines . . . . . . . . . . . . . . . . 20 M-X Delete Non-Matching Lines . . . . . . . . . . . . . . 20 M-X Dired . . . . . . . . . . . . . . . . . . . . . . . . 21 M-X Edit Directory . . . . . . . . . . . . . . . . . . . . 21 M-X Execute Buffer . . . . . . . . . . . . . . . . . . . 22 M-X Execute File . . . . . . . . . . . . . . . . . . . . . 22 M-X Find File . . . . . . . . . . . . . . . . . . . . . . 24 M-X Flush Lines . . . . . . . . . . . . . . . . . . . . . 20 201/NMODE Manual - 69 - Key Index M-X How Many . . . . . . . . . . . . . . . . . . . . . . 18 M-X Insert Buffer . . . . . . . . . . . . . . . . . . . . 26 M-X Insert Date . . . . . . . . . . . . . . . . . . . . . 27 M-X Insert File . . . . . . . . . . . . . . . . . . . . . 27 M-X Keep Lines . . . . . . . . . . . . . . . . . . . . . 20 M-X Kill Buffer . . . . . . . . . . . . . . . . . . . . . 29 M-X Kill File . . . . . . . . . . . . . . . . . . . . . . . 19 M-X Kill Some Buffers . . . . . . . . . . . . . . . . . . 30 M-X Lisp Mode . . . . . . . . . . . . . . . . . . . . . . 32 M-X List Buffers . . . . . . . . . . . . . . . . . . . . . 17 M-X Make Space . . . . . . . . . . . . . . . . . . . . . 41 M-X Prepend To File . . . . . . . . . . . . . . . . . . . 42 M-X Query Replace . . . . . . . . . . . . . . . . . . . 42 M-X Rename Buffer . . . . . . . . . . . . . . . . . . . 43 M-X Replace String . . . . . . . . . . . . . . . . . . . 43 M-X Revert File . . . . . . . . . . . . . . . . . . . . . 44 M-X Save All Files . . . . . . . . . . . . . . . . . . . . 44 M-X Select Buffer . . . . . . . . . . . . . . . . . . . . 46 M-X Set Key . . . . . . . . . . . . . . . . . . . . . . . 47 M-X Set Visited Filename . . . . . . . . . . . . . . . . . 48 M-X Start Scripting . . . . . . . . . . . . . . . . . . . 48 M-X Start Timing Nmode . . . . . . . . . . . . . . . . . 48 M-X Stop Scripting . . . . . . . . . . . . . . . . . . . 49 M-X Stop Timing Nmode . . . . . . . . . . . . . . . . . 49 M-X Text Mode . . . . . . . . . . . . . . . . . . . . . 49 M-X Undelete File . . . . . . . . . . . . . . . . . . . . 51 M-X Visit File . . . . . . . . . . . . . . . . . . . . . . 53 M-X Write File . . . . . . . . . . . . . . . . . . . . . . 54 M-X Write Region . . . . . . . . . . . . . . . . . . . . 54 M-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-Z . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-^ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-~ . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 NEWLINE . . . . . . . . . . . . . . . . . . . . . . . . . 26 RETURN . . . . . . . . . . . . . . . . . . . . . . . . . 43 RUBOUT . . . . . . . . . . . . . . . . . . . . . . . . . 19 TAB . . . . . . . . . . . . . . . . . . . . . . . . . . . 33, 49 ] . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 201/Key Index - 70 - NMODE Manual 201/NMODE Manual - 71 - Topic Index 202/9. Topic Index 201/Alter Display Format . . . . . . . 7, 22, 25, 40, 41, 42, 43, 44, 45, 46, 51, 53 Alter Existing Text . . . . . . . 7, 18, 23, 24, 33, 34, 42, 43, 50, 51, 52, 53 Buffers . . . . . . . . . . . . . 14, 17, 22, 24, 26, 29, 30, 43, 44, 46, 53 Change Mode . . . . . . . . . . . 7, 15, 32, 48, 49 Defun . . . . . . . . . . . . . . 9, 21, 34, 36 Escape . . . . . . . . . . . . . . 7, 23, 31, 33, 40 Files . . . . . . . . . . . . . . . 14, 18, 19, 22, 24, 27, 42, 44, 48, 51, 53, 54 Fill Column . . . . . . . . . . . 11, 18, 23, 24, 46 Fill Prefix . . . . . . . . . . . . 11, 23, 24, 47 Goal Column . . . . . . . . . . . 11, 37, 39 Inform . . . . . . . . . . . . . . 7, 14, 17, 18, 26, 31, 54 Insert Constant . . . . . . . . . 7, 26, 27, 28, 41, 43, 48, 49 Kill Ring . . . . . . . . . . . . . 11, 14, 16, 18, 19, 28, 29, 30, 52 Lisp . . . . . . . . . . . . . . . 17, 21, 23, 25, 27, 28, 29, 31, 32, 33, 34, 35, 36, 38, 43, 50, 55 Mark . . . . . . . . . . . . . . . 7, 22, 23, 25, 28, 34, 35, 47 Move Data . . . . . . . . . . . . 8, 14, 24, 25, 26, 27, 28, 42, 51, 53, 55 Move Point . . . . . . . . . . . . 8, 16, 17, 21, 22, 24, 25, 26, 35, 36, 37, 38, 39, 40, 42, 44, 46, 53 Paragraph . . . . . . . . . . . . 9, 16, 23, 24, 35 Preserve . . . . . . . . . . . . . 8, 18, 42, 44, 51, 54 Region . . . . . . . . . . . . . . 9, 14, 18, 30, 33, 42, 50, 52, 54 Remove . . . . . . . . . . . . . 8, 16, 18, 19, 20, 28, 29, 30, 44 Select . . . . . . . . . . . . . . 8, 20, 26, 42, 43, 44 Sentence . . . . . . . . . . . . . 9, 16, 24, 25, 30 Set Global Variable . . . . . . . . 8, 17, 43, 46, 47, 48 Subsequent Command Modifier . . 8, 15, 17, 22, 32, 34, 40, 51 Text . . . . . . . . . . . . . . . 18, 23, 24, 25, 29, 30, 34, 35, 37, 38, 49, 51, 52, 53 201/Topic Index - 72 - NMODE Manual 201/NMODE Manual - 3 - Table of Contents 202/CONTENTS 1. Introduction ..................................................... 5 2. Action Types .................................................... 7 3. Definitions ....................................................... 9 4. Globals ......................................................... 11 5. Command Descriptions ........................................... 13 6. Command Index ................................................. 57 7. Function Index .................................................. 61 8. Key Index ...................................................... 65 9. Topic Index ..................................................... 71 |
Added psl-1983/3-1/doc/nmode/manual.labels version [1c68f9cd87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .sr label_Introduction 1 .nr label_Introduction 1 .sr label_intro 1 .nr label_intro 1 .sr label_screen 2 .nr label_screen 1 .sr label_modeline 2.1 .nr label_modeline 1 .sr label_characters 3 .nr label_characters 1 .sr label_prefix 3.2 .nr label_prefix 2 .sr label_editing 4 .nr label_editing 1 .sr label_basic 4 .nr label_basic 1 .sr label_arguments 5 .nr label_arguments 1 .sr label_m_x 6 .nr label_m_x 1 .sr label_mmarcana 6.2 .nr label_mmarcana 2 .sr label_subsystems 7.1 .nr label_subsystems 1 .sr label_recursive 7.2 .nr label_recursive 1 .sr label_browsers 8 .nr label_browsers 1 .sr label_help 9 .nr label_help 1 .sr label_mark 10 .nr label_mark 1 .sr label_killing 11 .nr label_killing 1 .sr label_un_killing 11.2 .nr label_un_killing 2 .sr label_copying 11.3 .nr label_copying 4 .sr label_NMODEregisters 11.3.2 .nr label_NMODEregisters 5 .sr label_NMODE_registers 11.3.2 .nr label_NMODE_registers 5 .sr label_search 12 .nr label_search 1 .sr label_text 13 .nr label_text 1 .sr label_words 13.1 .nr label_words 1 .sr label_sentences 13.2 .nr label_sentences 2 .sr label_textindent 13.3 .nr label_textindent 3 .sr label_filling 13.4 .nr label_filling 4 .sr label_case 13.5 .nr label_case 5 .sr label_fixit 14 .nr label_fixit 1 .sr label_files 15 .nr label_files 1 .sr label_visiting 15.1 .nr label_visiting 1 .sr label_revert 15.2 .nr label_revert 2 .sr label_listdir 15.3 .nr label_listdir 2 .sr label_dired 15.4 .nr label_dired 2 .sr label_filadv 15.5 .nr label_filadv 3 .sr label_buffers 16 .nr label_buffers 1 .sr label_display 17 .nr label_display 1 .sr label_windows 18 .nr label_windows 1 .sr label_replace 19 .nr label_replace 1 .sr label_programs 20 .nr label_programs 1 .sr label_majormodes 20.1 .nr label_majormodes 1 .sr label_indenting 20.2 .nr label_indenting 1 .sr label_matching 20.3 .nr label_matching 2 .sr label_comments 20.4 .nr label_comments 3 .sr label_lisp 20.5 .nr label_lisp 3 .sr label_lists 20.5.1 .nr label_lists 3 .sr label_defuns 20.5.2 .nr label_defuns 5 .sr label_grinding 20.6 .nr label_grinding 6 .sr label_NMODECustomization 22 .nr label_NMODECustomization 1 .sr label_customization 22 .nr label_customization 1 .sr label_init 22.1 .nr label_init 1 .sr label_variables 22.2 .nr label_variables 4 .sr label_minormodes 22.3 .nr label_minormodes 4 .sr label_quitting 23.1 .nr label_quitting 1 .sr label_bugs 23.2 .nr label_bugs 1 .sr label_Action_Types 24 .nr label_Action_Types 1 .sr label_Definitions 25 .nr label_Definitions 1 .sr label_Globals 26 .nr label_Globals 1 .sr label_Command 27 .nr label_Command 1 .sr label_Function_Index 28 .nr label_Function_Index 1 .sr label_Key_Index 29 .nr label_Key_Index 1 .sr label_Topic_Index 30 .nr label_Topic_Index 1 |
Added psl-1983/3-1/doc/nmode/manual.lpt version [c6c2ac91fd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 | NMODE Reference Manual Preliminary Edition 11 February 1983 11:07:16 This document is a preliminary edition of the NMODE Reference Manual. Do not distribute this document! - 2 - NMODE Manual NMODE Manual - 5 - Introduction 1. Introduction This document describes the NMODE text editor. NMODE is an interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified appropriately in areas where NMODE and EMACS differ. Introduction - 6 - NMODE Manual NMODE Manual - 7 - Action Types 2. Action Types This section defines a number of action types, which are used in the descriptions of NMODE commands. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Alter Display Format This type of command alters how text is displayed without altering the contents of existing buffers. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Alter Existing Text This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Change Mode This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Escape Escape from the current level. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Inform This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Insert Constant This type of command inserts a character constant like tab or space or a multiple thereof. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Mark This type of command sets mark. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Types - 8 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Move Data This command copies some data (which is not a constant wired into the program) from one place to another. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Move Point This type of command moves point. It may move it within a buffer or from buffer to buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Preserve Make a copy of something current and put it somewhere else (usually disc). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Remove This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Select This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Set Global Variable This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Action Type Explanation: Subsequent Command Modifier This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 9 - Definitions 3. Definitions This section defines a number of terms used in the descriptions of NMODE commands. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Definition: Defun A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Definition: Paragraph Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Definition: Region The region is that portion of text between point, the current buffer position, and mark. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Definition: Sentence A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Definitions - 10 - NMODE Manual NMODE Manual - 11 - Globals 4. Globals This section defines a number of conceptual global variables, which are referred to in the descriptions of NMODE commands. These globals represent state information that can affect the behavior of various NMODE commands. The value of NMODE globals are set as the result of various NMODE commands. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Global Explanation: Fill Column The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Global Explanation: Fill Prefix The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Global Explanation: Goal Column This is not yet correctly implemented $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Global Explanation: Kill Ring The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Globals - 12 - NMODE Manual NMODE Manual - 13 - Command Descriptions 5. Command Descriptions This section defines the basic NMODE commands. Each command description includes the following information: command A descriptive name of the command. function The name of the Lisp function that implements the command. key The logical keys on the keyboard that normally have this command attached to them. A logical key includes ordinary keys such as Tab or Rubout, shifted keys using the Control and/or Meta modifiers (e.g., C-F, M-F, and C-M-F), prefixed commands using C-X, C-], or Escape (e.g., C-X C-F, C-] E, and Esc-L), and extended commands using Meta-X (e.g., M-X Delete Matching Lines). action type One of a number of descriptive terms that categorize the behavior of commands. Action types are defined in Chapter 2. mode Some commands are defined only in certain modes. If present, this attribute specifies the mode or modes in which the command is normally defined. topic A keyword that describes the command. Topics are listed in the Topic Index, Chapter 9. Command Descriptions - 14 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Append Next Kill Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Append To Buffer Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Append To File Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Apropos Function: apropos-command Key: M-X Apropos Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 15 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Argument Digit Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Auto Fill Mode Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 16 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Back To Indentation Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Backward Kill Sentence Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Backward Paragraph Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Backward Sentence Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 17 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Backward Up List Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Buffer Browser Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Buffer Not Modified Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: C-X Prefix Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 18 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Center Line Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Copy Region Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Count Occurrences Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete And Expunge File Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 19 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Backward Hacking Tabs Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Blank Lines Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete File Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Forward Character Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 20 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Horizontal Space Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Indentation Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Matching Lines Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Delete Non-Matching Lines Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Dired Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 21 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Down List Function: down-list Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. Command argument sensitivity not yet implemented. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Edit Directory Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: End Of Defun Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 22 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Esc Prefix Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Exchange Point And Mark Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Exchange Windows Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Execute Buffer Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Execute File Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 23 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Execute Form Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Exit Nmode Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Fill Comment Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Fill Paragraph Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 24 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Fill Region Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Find File Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Forward Paragraph Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 25 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Forward Sentence Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Forward Up List Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Get Register Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Grow Window Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 26 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Help Dispatch Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Incremental Search Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Indent New line Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Buffer Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 27 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Closing bracket Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Comment Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Date Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert File Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 28 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Kill Buffer Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Next Character Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Insert Parens Function: insert-parens Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point between them. Also make a space before them if appropriate. With argument, put the ) after the specified number of already existing s-expressions. Thus, with argument 1, puts extra parens around the following s-expression. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Backward Form Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 29 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Backward Word Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Buffer Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Forward Form Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Forward Word Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 30 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Line Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Region Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Sentence Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Kill Some Buffers Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 31 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Abort Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Backtrace Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Continue Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Help Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 32 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Indent Region Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Indent sexpr Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Mode Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Prefix Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 33 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Quit Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Retry Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lisp Tab Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lowercase Region Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 34 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Lowercase Word Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: M-X Prefix Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Beginning Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Defun Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 35 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark End Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Form Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Paragraph Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Whole Buffer Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Mark Word Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 36 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Backward Character Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Backward Defun Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Backward Form Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Backward List Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 37 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Backward Word Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Down Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Down Extending Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Forward Character Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 38 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Forward Form Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Forward List Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Forward Word Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move To Buffer End Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 39 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move To Buffer Start Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move To End Of Line Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move To Screen Edge Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move To Start Of Line Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Move Up Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 40 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Negative Argument Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Next Screen Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Abort Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Exit To Superior Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Full Refresh Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 41 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Gc Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Invert Video Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Nmode Refresh Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: One Window Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Open Line Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 42 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Other Window Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Prepend To File Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Previous Screen Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Put Register Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Query Replace Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of NMODE Manual - 43 - Command Descriptions the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. ^L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Rename Buffer Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Replace String Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Reposition Window Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Return Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 44 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Reverse Search Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Revert File Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Save All Files Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Save File Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Other Window Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 45 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Down Line Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Down Page Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Left Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Right Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Up Line Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 46 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Scroll Window Up Page Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Select Buffer Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Select Previous Buffer Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Fill Column Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 47 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Fill Prefix Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Goal Column Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Key Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Mark Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 48 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Set Visited Filename Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Split Line Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Start Scripting Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Start Timing Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 49 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Stop Scripting Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Stop Timing Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Tab To Tab Stop Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Text Mode Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 50 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Transpose Characters Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Transpose Forms Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Transpose Lines Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Transpose Regions Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 51 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Transpose Words Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Two Windows Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Undelete File Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Universal Argument Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 52 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Unkill Previous Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Upcase Digit Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Uppercase Initial Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Uppercase Region Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 53 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Uppercase Word Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: View Two Windows Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Visit File Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Visit In Other Window Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 54 - NMODE Manual $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: What Cursor Position Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Write File Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Write Region Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Write Screen Photo Function: write-screen-photo-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NMODE Manual - 55 - Command Descriptions $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command: Yank Last Output Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ Command Descriptions - 56 - NMODE Manual NMODE Manual - 57 - Command Index 6. Command Index Append Next Kill . . . . . . . . . . . . . . . . . . . . 14 Append To Buffer . . . . . . . . . . . . . . . . . . . . 14 Append To File . . . . . . . . . . . . . . . . . . . . . 14 Apropos . . . . . . . . . . . . . . . . . . . . . . . . . 14 Argument Digit . . . . . . . . . . . . . . . . . . . . . 15 Auto Fill Mode . . . . . . . . . . . . . . . . . . . . . . 15 Back To Indentation . . . . . . . . . . . . . . . . . . . 16 Backward Kill Sentence . . . . . . . . . . . . . . . . . 16 Backward Paragraph . . . . . . . . . . . . . . . . . . . 16 Backward Sentence . . . . . . . . . . . . . . . . . . . . 16 Backward Up List . . . . . . . . . . . . . . . . . . . . 17 Buffer Browser . . . . . . . . . . . . . . . . . . . . . 17 Buffer Not Modified . . . . . . . . . . . . . . . . . . . 17 C-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 Center Line . . . . . . . . . . . . . . . . . . . . . . . 18 Copy Region . . . . . . . . . . . . . . . . . . . . . . . 18 Count Occurrences . . . . . . . . . . . . . . . . . . . . 18 Delete And Expunge File . . . . . . . . . . . . . . . . . 18 Delete Backward Hacking Tabs . . . . . . . . . . . . . . 19 Delete Blank Lines . . . . . . . . . . . . . . . . . . . . 19 Delete File . . . . . . . . . . . . . . . . . . . . . . . . 19 Delete Forward Character . . . . . . . . . . . . . . . . 19 Delete Horizontal Space . . . . . . . . . . . . . . . . . 20 Delete Indentation . . . . . . . . . . . . . . . . . . . . 20 Delete Matching Lines . . . . . . . . . . . . . . . . . . 20 Delete Non-Matching Lines . . . . . . . . . . . . . . . . 20 Dired . . . . . . . . . . . . . . . . . . . . . . . . . . 20 Down List . . . . . . . . . . . . . . . . . . . . . . . . 21 Edit Directory . . . . . . . . . . . . . . . . . . . . . . 21 End Of Defun . . . . . . . . . . . . . . . . . . . . . . 21 Esc Prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 Exchange Point And Mark . . . . . . . . . . . . . . . . 22 Exchange Windows . . . . . . . . . . . . . . . . . . . . 22 Execute Buffer . . . . . . . . . . . . . . . . . . . . . . 22 Execute File . . . . . . . . . . . . . . . . . . . . . . . 22 Execute Form . . . . . . . . . . . . . . . . . . . . . . 23 Exit Nmode . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Comment . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Paragraph . . . . . . . . . . . . . . . . . . . . . . 23 Fill Region . . . . . . . . . . . . . . . . . . . . . . . . 24 Find File . . . . . . . . . . . . . . . . . . . . . . . . . 24 Forward Paragraph . . . . . . . . . . . . . . . . . . . . 24 Forward Sentence . . . . . . . . . . . . . . . . . . . . 25 Forward Up List . . . . . . . . . . . . . . . . . . . . . 25 Command Index - 58 - NMODE Manual Get Register . . . . . . . . . . . . . . . . . . . . . . . 25 Grow Window . . . . . . . . . . . . . . . . . . . . . . . 25 Help Dispatch . . . . . . . . . . . . . . . . . . . . . . 26 Incremental Search . . . . . . . . . . . . . . . . . . . . 26 Indent New line . . . . . . . . . . . . . . . . . . . . . 26 Insert Buffer . . . . . . . . . . . . . . . . . . . . . . 26 Insert Closing bracket . . . . . . . . . . . . . . . . . . 27 Insert Comment . . . . . . . . . . . . . . . . . . . . . 27 Insert Date . . . . . . . . . . . . . . . . . . . . . . . 27 Insert File . . . . . . . . . . . . . . . . . . . . . . . . 27 Insert Kill Buffer . . . . . . . . . . . . . . . . . . . . 28 Insert Next Character . . . . . . . . . . . . . . . . . . 28 Insert Parens . . . . . . . . . . . . . . . . . . . . . . 28 Kill Backward Form . . . . . . . . . . . . . . . . . . . 28 Kill Backward Word . . . . . . . . . . . . . . . . . . . 29 Kill Buffer . . . . . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Form . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Word . . . . . . . . . . . . . . . . . . . . 29 Kill Line . . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Region . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Sentence . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Some Buffers . . . . . . . . . . . . . . . . . . . . 30 Lisp Abort . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Backtrace . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Continue . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Help . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Indent Region . . . . . . . . . . . . . . . . . . . . 32 Lisp Indent sexpr . . . . . . . . . . . . . . . . . . . . 32 Lisp Mode . . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Prefix . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Quit . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Retry . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Tab . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lowercase Region . . . . . . . . . . . . . . . . . . . . 33 Lowercase Word . . . . . . . . . . . . . . . . . . . . . 34 M-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 Mark Beginning . . . . . . . . . . . . . . . . . . . . . 34 Mark Defun . . . . . . . . . . . . . . . . . . . . . . . 34 Mark End . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Form . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Paragraph . . . . . . . . . . . . . . . . . . . . . 35 Mark Whole Buffer . . . . . . . . . . . . . . . . . . . . 35 Mark Word . . . . . . . . . . . . . . . . . . . . . . . . 35 Move Backward Character . . . . . . . . . . . . . . . . 36 Move Backward Defun . . . . . . . . . . . . . . . . . . 36 Move Backward Form . . . . . . . . . . . . . . . . . . . 36 Move Backward List . . . . . . . . . . . . . . . . . . . 36 Move Backward Word . . . . . . . . . . . . . . . . . . . 37 NMODE Manual - 59 - Command Index Move Down . . . . . . . . . . . . . . . . . . . . . . . . 37 Move Down Extending . . . . . . . . . . . . . . . . . . 37 Move Forward Character . . . . . . . . . . . . . . . . . 37 Move Forward Form . . . . . . . . . . . . . . . . . . . 38 Move Forward List . . . . . . . . . . . . . . . . . . . . 38 Move Forward Word . . . . . . . . . . . . . . . . . . . 38 Move To Buffer End . . . . . . . . . . . . . . . . . . . 38 Move To Buffer Start . . . . . . . . . . . . . . . . . . 39 Move To End Of Line . . . . . . . . . . . . . . . . . . 39 Move To Screen Edge . . . . . . . . . . . . . . . . . . 39 Move To Start Of Line . . . . . . . . . . . . . . . . . . 39 Move Up . . . . . . . . . . . . . . . . . . . . . . . . . 39 Negative Argument . . . . . . . . . . . . . . . . . . . . 40 Next Screen . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Abort . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Exit To Superior . . . . . . . . . . . . . . . . . 40 Nmode Full Refresh . . . . . . . . . . . . . . . . . . . 40 Nmode Gc . . . . . . . . . . . . . . . . . . . . . . . . 41 Nmode Invert Video . . . . . . . . . . . . . . . . . . . 41 Nmode Refresh . . . . . . . . . . . . . . . . . . . . . . 41 One Window . . . . . . . . . . . . . . . . . . . . . . . 41 Open Line . . . . . . . . . . . . . . . . . . . . . . . . 41 Other Window . . . . . . . . . . . . . . . . . . . . . . 42 Prepend To File . . . . . . . . . . . . . . . . . . . . . 42 Previous Screen . . . . . . . . . . . . . . . . . . . . . 42 Put Register . . . . . . . . . . . . . . . . . . . . . . . 42 Query Replace . . . . . . . . . . . . . . . . . . . . . . 42 Rename Buffer . . . . . . . . . . . . . . . . . . . . . . 43 Replace String . . . . . . . . . . . . . . . . . . . . . . 43 Reposition Window . . . . . . . . . . . . . . . . . . . . 43 Return . . . . . . . . . . . . . . . . . . . . . . . . . . 43 Reverse Search . . . . . . . . . . . . . . . . . . . . . 44 Revert File . . . . . . . . . . . . . . . . . . . . . . . 44 Save All Files . . . . . . . . . . . . . . . . . . . . . . 44 Save File . . . . . . . . . . . . . . . . . . . . . . . . 44 Scroll Other Window . . . . . . . . . . . . . . . . . . . 44 Scroll Window Down Line . . . . . . . . . . . . . . . . . 45 Scroll Window Down Page . . . . . . . . . . . . . . . . . 45 Scroll Window Left . . . . . . . . . . . . . . . . . . . . 45 Scroll Window Right . . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Line . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Page . . . . . . . . . . . . . . . . . . 46 Select Buffer . . . . . . . . . . . . . . . . . . . . . . 46 Select Previous Buffer . . . . . . . . . . . . . . . . . . 46 Set Fill Column . . . . . . . . . . . . . . . . . . . . . 46 Set Fill Prefix . . . . . . . . . . . . . . . . . . . . . . 47 Set Goal Column . . . . . . . . . . . . . . . . . . . . . 47 Command Index - 60 - NMODE Manual Set Key . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Mark . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Visited Filename . . . . . . . . . . . . . . . . . . . 48 Split Line . . . . . . . . . . . . . . . . . . . . . . . . 48 Start Scripting . . . . . . . . . . . . . . . . . . . . . . 48 Start Timing . . . . . . . . . . . . . . . . . . . . . . . 48 Stop Scripting . . . . . . . . . . . . . . . . . . . . . . 49 Stop Timing . . . . . . . . . . . . . . . . . . . . . . . 49 Tab To Tab Stop . . . . . . . . . . . . . . . . . . . . 49 Text Mode . . . . . . . . . . . . . . . . . . . . . . . . 49 Transpose Characters . . . . . . . . . . . . . . . . . . 50 Transpose Forms . . . . . . . . . . . . . . . . . . . . . 50 Transpose Lines . . . . . . . . . . . . . . . . . . . . . 50 Transpose Regions . . . . . . . . . . . . . . . . . . . . 50 Transpose Words . . . . . . . . . . . . . . . . . . . . . 51 Two Windows . . . . . . . . . . . . . . . . . . . . . . . 51 Undelete File . . . . . . . . . . . . . . . . . . . . . . . 51 Universal Argument . . . . . . . . . . . . . . . . . . . 51 Unkill Previous . . . . . . . . . . . . . . . . . . . . . 52 Upcase Digit . . . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Initial . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Region . . . . . . . . . . . . . . . . . . . . 52 Uppercase Word . . . . . . . . . . . . . . . . . . . . . 53 View Two Windows . . . . . . . . . . . . . . . . . . . . 53 Visit File . . . . . . . . . . . . . . . . . . . . . . . . 53 Visit In Other Window . . . . . . . . . . . . . . . . . . 53 What Cursor Position . . . . . . . . . . . . . . . . . . . 54 Write File . . . . . . . . . . . . . . . . . . . . . . . . 54 Write Region . . . . . . . . . . . . . . . . . . . . . . . 54 Write Screen Photo . . . . . . . . . . . . . . . . . . . . 54 Yank Last Output . . . . . . . . . . . . . . . . . . . . 55 NMODE Manual - 61 - Function Index 7. Function Index append-next-kill-command . . . . . . . . . . . . . . . . 14 append-to-buffer-command . . . . . . . . . . . . . . . . 14 append-to-file-command . . . . . . . . . . . . . . . . . 14 apropos-command . . . . . . . . . . . . . . . . . . . . . 14 argument-digit . . . . . . . . . . . . . . . . . . . . . . 15 auto-fill-mode-command . . . . . . . . . . . . . . . . . . 15 back-to-indentation-command . . . . . . . . . . . . . . . 16 backward-kill-sentence-command . . . . . . . . . . . . . 16 backward-paragraph-command . . . . . . . . . . . . . . 16 backward-sentence-command . . . . . . . . . . . . . . . 16 backward-up-list-command . . . . . . . . . . . . . . . . 17 buffer-browser-command . . . . . . . . . . . . . . . . . 17 buffer-not-modified-command . . . . . . . . . . . . . . . 17 c-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 center-line-command . . . . . . . . . . . . . . . . . . . 18 copy-region . . . . . . . . . . . . . . . . . . . . . . . 18 count-occurrences-command . . . . . . . . . . . . . . . 18 delete-and-expunge-file-command . . . . . . . . . . . . . 18 delete-backward-hacking-tabs-command . . . . . . . . . . 19 delete-blank-lines-command . . . . . . . . . . . . . . . . 19 delete-file-command . . . . . . . . . . . . . . . . . . . 19 delete-forward-character-command . . . . . . . . . . . . 19 delete-horizontal-space-command . . . . . . . . . . . . . 20 delete-indentation-command . . . . . . . . . . . . . . . . 20 delete-matching-lines-command . . . . . . . . . . . . . . 20 delete-non-matching-lines-command . . . . . . . . . . . . 20 dired-command . . . . . . . . . . . . . . . . . . . . . . 20 down-list . . . . . . . . . . . . . . . . . . . . . . . . 21 edit-directory-command . . . . . . . . . . . . . . . . . . 21 end-of-defun-command . . . . . . . . . . . . . . . . . . 21 esc-prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 exchange-point-and-mark . . . . . . . . . . . . . . . . . 22 exchange-windows-command . . . . . . . . . . . . . . . 22 execute-buffer-command . . . . . . . . . . . . . . . . . 22 execute-file-command . . . . . . . . . . . . . . . . . . . 22 execute-form-command . . . . . . . . . . . . . . . . . . 23 exit-nmode . . . . . . . . . . . . . . . . . . . . . . . . 23 fill-comment-command . . . . . . . . . . . . . . . . . . . 23 fill-paragraph-command . . . . . . . . . . . . . . . . . . 23 fill-region-command . . . . . . . . . . . . . . . . . . . 24 find-file-command . . . . . . . . . . . . . . . . . . . . 24 forward-paragraph-command . . . . . . . . . . . . . . . 24 forward-sentence-command . . . . . . . . . . . . . . . . 25 forward-up-list-command . . . . . . . . . . . . . . . . . 25 Function Index - 62 - NMODE Manual get-register-command . . . . . . . . . . . . . . . . . . 25 grow-window-command . . . . . . . . . . . . . . . . . . 25 help-dispatch . . . . . . . . . . . . . . . . . . . . . . 26 incremental-search-command . . . . . . . . . . . . . . . 26 indent-new-line-command . . . . . . . . . . . . . . . . . 26 insert-buffer-command . . . . . . . . . . . . . . . . . . 26 insert-closing-bracket . . . . . . . . . . . . . . . . . . 27 insert-comment-command . . . . . . . . . . . . . . . . . 27 insert-date-command . . . . . . . . . . . . . . . . . . . 27 insert-file-command . . . . . . . . . . . . . . . . . . . 27 insert-kill-buffer . . . . . . . . . . . . . . . . . . . . . 28 insert-next-character-command . . . . . . . . . . . . . . 28 insert-parens . . . . . . . . . . . . . . . . . . . . . . 28 kill-backward-form-command . . . . . . . . . . . . . . . 28 kill-backward-word-command . . . . . . . . . . . . . . . 29 kill-buffer-command . . . . . . . . . . . . . . . . . . . 29 kill-forward-form-command . . . . . . . . . . . . . . . . 29 kill-forward-word-command . . . . . . . . . . . . . . . . 29 kill-line . . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-region . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-sentence-command . . . . . . . . . . . . . . . . . . 30 kill-some-buffers-command . . . . . . . . . . . . . . . . 30 lisp-abort-command . . . . . . . . . . . . . . . . . . . . 31 lisp-backtrace-command . . . . . . . . . . . . . . . . . 31 lisp-continue-command . . . . . . . . . . . . . . . . . . 31 lisp-help-command . . . . . . . . . . . . . . . . . . . . 31 lisp-indent-region-command . . . . . . . . . . . . . . . . 32 lisp-indent-sexpr . . . . . . . . . . . . . . . . . . . . 32 lisp-mode-command . . . . . . . . . . . . . . . . . . . . 32 lisp-prefix . . . . . . . . . . . . . . . . . . . . . . . . 32 lisp-quit-command . . . . . . . . . . . . . . . . . . . . 33 lisp-retry-command . . . . . . . . . . . . . . . . . . . . 33 lisp-tab-command . . . . . . . . . . . . . . . . . . . . . 33 lowercase-region-command . . . . . . . . . . . . . . . . 33 lowercase-word-command . . . . . . . . . . . . . . . . . 34 m-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 mark-beginning-command . . . . . . . . . . . . . . . . . 34 mark-defun-command . . . . . . . . . . . . . . . . . . . 34 mark-end-command . . . . . . . . . . . . . . . . . . . . 35 mark-form-command . . . . . . . . . . . . . . . . . . . 35 mark-paragraph-command . . . . . . . . . . . . . . . . . 35 mark-whole-buffer-command . . . . . . . . . . . . . . . 35 mark-word-command . . . . . . . . . . . . . . . . . . . 35 move-backward-character-command . . . . . . . . . . . . 36 move-backward-defun-command . . . . . . . . . . . . . . 36 move-backward-form-command . . . . . . . . . . . . . . 36 move-backward-list-command . . . . . . . . . . . . . . . 36 move-backward-word-command . . . . . . . . . . . . . . 37 NMODE Manual - 63 - Function Index move-down-command . . . . . . . . . . . . . . . . . . . 37 move-down-extending-command . . . . . . . . . . . . . . 37 move-forward-character-command . . . . . . . . . . . . . 37 move-forward-form-command . . . . . . . . . . . . . . . 38 move-forward-list-command . . . . . . . . . . . . . . . . 38 move-forward-word-command . . . . . . . . . . . . . . . 38 move-to-buffer-end-command . . . . . . . . . . . . . . . 38 move-to-buffer-start-command . . . . . . . . . . . . . . 39 move-to-end-of-line-command . . . . . . . . . . . . . . . 39 move-to-screen-edge-command . . . . . . . . . . . . . . 39 move-to-start-of-line-command . . . . . . . . . . . . . . 39 move-up-command . . . . . . . . . . . . . . . . . . . . 39 negative-argument . . . . . . . . . . . . . . . . . . . . 40 next-screen-command . . . . . . . . . . . . . . . . . . . 40 nmode-abort-command . . . . . . . . . . . . . . . . . . 40 nmode-exit-to-superior . . . . . . . . . . . . . . . . . . 40 nmode-full-refresh . . . . . . . . . . . . . . . . . . . . 40 nmode-gc . . . . . . . . . . . . . . . . . . . . . . . . 41 nmode-invert-video . . . . . . . . . . . . . . . . . . . . 41 nmode-refresh-command . . . . . . . . . . . . . . . . . 41 one-window-command . . . . . . . . . . . . . . . . . . . 41 open-line-command . . . . . . . . . . . . . . . . . . . . 41 other-window-command . . . . . . . . . . . . . . . . . . 42 prepend-to-file-command . . . . . . . . . . . . . . . . . 42 previous-screen-command . . . . . . . . . . . . . . . . . 42 put-register-command . . . . . . . . . . . . . . . . . . 42 query-replace-command . . . . . . . . . . . . . . . . . . 42 rename-buffer-command . . . . . . . . . . . . . . . . . 43 replace-string-command . . . . . . . . . . . . . . . . . 43 reposition-window-command . . . . . . . . . . . . . . . . 43 return-command . . . . . . . . . . . . . . . . . . . . . 43 reverse-search-command . . . . . . . . . . . . . . . . . 44 revert-file-command . . . . . . . . . . . . . . . . . . . 44 save-all-files-command . . . . . . . . . . . . . . . . . . 44 save-file-command . . . . . . . . . . . . . . . . . . . . 44 scroll-other-window-command . . . . . . . . . . . . . . . 44 scroll-window-down-line-command . . . . . . . . . . . . . 45 scroll-window-down-page-command . . . . . . . . . . . . 45 scroll-window-left-command . . . . . . . . . . . . . . . . 45 scroll-window-right-command . . . . . . . . . . . . . . . 45 scroll-window-up-line-command . . . . . . . . . . . . . . 45 scroll-window-up-page-command . . . . . . . . . . . . . 46 select-buffer-command . . . . . . . . . . . . . . . . . . 46 select-previous-buffer-command . . . . . . . . . . . . . 46 set-fill-column-command . . . . . . . . . . . . . . . . . 46 set-fill-prefix-command . . . . . . . . . . . . . . . . . . 47 set-goal-column-command . . . . . . . . . . . . . . . . . 47 Function Index - 64 - NMODE Manual set-key-command . . . . . . . . . . . . . . . . . . . . . 47 set-mark-command . . . . . . . . . . . . . . . . . . . . 47 set-visited-filename-command . . . . . . . . . . . . . . . 48 split-line-command . . . . . . . . . . . . . . . . . . . . 48 start-scripting-command . . . . . . . . . . . . . . . . . 48 start-timing-command . . . . . . . . . . . . . . . . . . . 48 stop-scripting-command . . . . . . . . . . . . . . . . . 49 stop-timing-command . . . . . . . . . . . . . . . . . . . 49 tab-to-tab-stop-command . . . . . . . . . . . . . . . . . 49 text-mode-command . . . . . . . . . . . . . . . . . . . . 49 transpose-characters-command . . . . . . . . . . . . . . 50 transpose-forms . . . . . . . . . . . . . . . . . . . . . 50 transpose-lines . . . . . . . . . . . . . . . . . . . . . . 50 transpose-regions . . . . . . . . . . . . . . . . . . . . 50 transpose-words . . . . . . . . . . . . . . . . . . . . . 51 two-windows-command . . . . . . . . . . . . . . . . . . 51 undelete-file-command . . . . . . . . . . . . . . . . . . 51 universal-argument . . . . . . . . . . . . . . . . . . . . 51 unkill-previous . . . . . . . . . . . . . . . . . . . . . . 52 upcase-digit-command . . . . . . . . . . . . . . . . . . 52 uppercase-initial-command . . . . . . . . . . . . . . . . 52 uppercase-region-command . . . . . . . . . . . . . . . . 52 uppercase-word-command . . . . . . . . . . . . . . . . . 53 view-two-windows-command . . . . . . . . . . . . . . . . 53 visit-file-command . . . . . . . . . . . . . . . . . . . . 53 visit-in-other-window-command . . . . . . . . . . . . . . 53 what-cursor-position-command . . . . . . . . . . . . . . 54 write-file-command . . . . . . . . . . . . . . . . . . . . 54 write-region-command . . . . . . . . . . . . . . . . . . 54 write-screen-photo-command . . . . . . . . . . . . . . . 54 yank-last-output-command . . . . . . . . . . . . . . . . 55 NMODE Manual - 65 - Key Index 8. Key Index ) . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 BACKSPACE . . . . . . . . . . . . . . . . . . . . . . . 19 C-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-= . . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-( . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-) . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-M-- . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-M-A . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-B . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-BACKSPACE . . . . . . . . . . . . . . . . . . . . 34 C-M-D . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-M-E . . . . . . . . . . . . . . . . . . . . . . . . . . 21 Key Index - 66 - NMODE Manual C-M-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-H . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-I . . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-M-L . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-M-M . . . . . . . . . . . . . . . . . . . . . . . . . . 16 C-M-N . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-O . . . . . . . . . . . . . . . . . . . . . . . . . . 48 C-M-P . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-R . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-M-RETURN . . . . . . . . . . . . . . . . . . . . . . 16 C-M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . 28 C-M-T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-M-TAB . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-U . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-V . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-M-W . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-M-X . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-] . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-N . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-O . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-P . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 19 C-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-SPACE . . . . . . . . . . . . . . . . . . . . . . . . 47 C-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X < . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X 1 . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X 2 . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-X 3 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X 4 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X = . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X > . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X A . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-X B . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X C-B . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X C-F . . . . . . . . . . . . . . . . . . . . . . . . . 24 C-X C-L . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-X C-N . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X C-O . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-X C-S . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-X C-T . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X C-U . . . . . . . . . . . . . . . . . . . . . . . . . 52 C-X C-V . . . . . . . . . . . . . . . . . . . . . . . . . 53 NMODE Manual - 67 - Key Index C-X C-W . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X C-X . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X C-Z . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-X D . . . . . . . . . . . . . . . . . . . . . . . . . . 20 C-X E . . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X F . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X G . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-X H . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-X K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-X O . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X P . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X RUBOUT . . . . . . . . . . . . . . . . . . . . . . 16 C-X T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X V . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X X . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X ^ . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 32 ESC-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-A . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-B . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-C . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-D . . . . . . . . . . . . . . . . . . . . . . . . . . 36 ESC-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-H . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-J . . . . . . . . . . . . . . . . . . . . . . . . . . 40 ESC-L . . . . . . . . . . . . . . . . . . . . . . . . . . 41 ESC-M . . . . . . . . . . . . . . . . . . . . . . . . . . 30 ESC-P . . . . . . . . . . . . . . . . . . . . . . . . . . 19 ESC-S . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-T . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-U . . . . . . . . . . . . . . . . . . . . . . . . . . 46 ESC-V . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESCAPE . . . . . . . . . . . . . . . . . . . . . . . . . 22 Lisp-? . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-A . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-B . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-C . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-E . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-L . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-R . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-Y . . . . . . . . . . . . . . . . . . . . . . . . . . 55 M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-' . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 M-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 M-/ . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 Key Index - 68 - NMODE Manual M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-; . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 M-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 M-BACKSPACE . . . . . . . . . . . . . . . . . . . . . . 34 M-C . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 M-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 M-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-H . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-I . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 M-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-M . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-RETURN . . . . . . . . . . . . . . . . . . . . . . . . 16 M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 29 M-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 M-TAB . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 53 M-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-X Append To File . . . . . . . . . . . . . . . . . . . 14 M-X Apropos . . . . . . . . . . . . . . . . . . . . . . . 14 M-X Auto Fill Mode . . . . . . . . . . . . . . . . . . . 15 M-X Count Occurrences . . . . . . . . . . . . . . . . . 18 M-X Delete And Expunge File . . . . . . . . . . . . . . 18 M-X Delete File . . . . . . . . . . . . . . . . . . . . . 19 M-X Delete Matching Lines . . . . . . . . . . . . . . . . 20 M-X Delete Non-Matching Lines . . . . . . . . . . . . . . 20 M-X Dired . . . . . . . . . . . . . . . . . . . . . . . . 21 M-X Edit Directory . . . . . . . . . . . . . . . . . . . . 21 M-X Execute Buffer . . . . . . . . . . . . . . . . . . . 22 M-X Execute File . . . . . . . . . . . . . . . . . . . . . 22 M-X Find File . . . . . . . . . . . . . . . . . . . . . . 24 M-X Flush Lines . . . . . . . . . . . . . . . . . . . . . 20 NMODE Manual - 69 - Key Index M-X How Many . . . . . . . . . . . . . . . . . . . . . . 18 M-X Insert Buffer . . . . . . . . . . . . . . . . . . . . 26 M-X Insert Date . . . . . . . . . . . . . . . . . . . . . 27 M-X Insert File . . . . . . . . . . . . . . . . . . . . . 27 M-X Keep Lines . . . . . . . . . . . . . . . . . . . . . 20 M-X Kill Buffer . . . . . . . . . . . . . . . . . . . . . 29 M-X Kill File . . . . . . . . . . . . . . . . . . . . . . . 19 M-X Kill Some Buffers . . . . . . . . . . . . . . . . . . 30 M-X Lisp Mode . . . . . . . . . . . . . . . . . . . . . . 32 M-X List Buffers . . . . . . . . . . . . . . . . . . . . . 17 M-X Make Space . . . . . . . . . . . . . . . . . . . . . 41 M-X Prepend To File . . . . . . . . . . . . . . . . . . . 42 M-X Query Replace . . . . . . . . . . . . . . . . . . . 42 M-X Rename Buffer . . . . . . . . . . . . . . . . . . . 43 M-X Replace String . . . . . . . . . . . . . . . . . . . 43 M-X Revert File . . . . . . . . . . . . . . . . . . . . . 44 M-X Save All Files . . . . . . . . . . . . . . . . . . . . 44 M-X Select Buffer . . . . . . . . . . . . . . . . . . . . 46 M-X Set Key . . . . . . . . . . . . . . . . . . . . . . . 47 M-X Set Visited Filename . . . . . . . . . . . . . . . . . 48 M-X Start Scripting . . . . . . . . . . . . . . . . . . . 48 M-X Start Timing Nmode . . . . . . . . . . . . . . . . . 48 M-X Stop Scripting . . . . . . . . . . . . . . . . . . . 49 M-X Stop Timing Nmode . . . . . . . . . . . . . . . . . 49 M-X Text Mode . . . . . . . . . . . . . . . . . . . . . 49 M-X Undelete File . . . . . . . . . . . . . . . . . . . . 51 M-X Visit File . . . . . . . . . . . . . . . . . . . . . . 53 M-X Write File . . . . . . . . . . . . . . . . . . . . . . 54 M-X Write Region . . . . . . . . . . . . . . . . . . . . 54 M-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-Z . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-^ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-~ . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 NEWLINE . . . . . . . . . . . . . . . . . . . . . . . . . 26 RETURN . . . . . . . . . . . . . . . . . . . . . . . . . 43 RUBOUT . . . . . . . . . . . . . . . . . . . . . . . . . 19 TAB . . . . . . . . . . . . . . . . . . . . . . . . . . . 33, 49 ] . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 Key Index - 70 - NMODE Manual NMODE Manual - 71 - Topic Index 9. Topic Index Alter Display Format . . . . . . . 7, 22, 25, 40, 41, 42, 43, 44, 45, 46, 51, 53 Alter Existing Text . . . . . . . 7, 18, 23, 24, 33, 34, 42, 43, 50, 51, 52, 53 Buffers . . . . . . . . . . . . . 14, 17, 22, 24, 26, 29, 30, 43, 44, 46, 53 Change Mode . . . . . . . . . . . 7, 15, 32, 48, 49 Defun . . . . . . . . . . . . . . 9, 21, 34, 36 Escape . . . . . . . . . . . . . . 7, 23, 31, 33, 40 Files . . . . . . . . . . . . . . . 14, 18, 19, 22, 24, 27, 42, 44, 48, 51, 53, 54 Fill Column . . . . . . . . . . . 11, 18, 23, 24, 46 Fill Prefix . . . . . . . . . . . . 11, 23, 24, 47 Goal Column . . . . . . . . . . . 11, 37, 39 Inform . . . . . . . . . . . . . . 7, 14, 17, 18, 26, 31, 54 Insert Constant . . . . . . . . . 7, 26, 27, 28, 41, 43, 48, 49 Kill Ring . . . . . . . . . . . . . 11, 14, 16, 18, 19, 28, 29, 30, 52 Lisp . . . . . . . . . . . . . . . 17, 21, 23, 25, 27, 28, 29, 31, 32, 33, 34, 35, 36, 38, 43, 50, 55 Mark . . . . . . . . . . . . . . . 7, 22, 23, 25, 28, 34, 35, 47 Move Data . . . . . . . . . . . . 8, 14, 24, 25, 26, 27, 28, 42, 51, 53, 55 Move Point . . . . . . . . . . . . 8, 16, 17, 21, 22, 24, 25, 26, 35, 36, 37, 38, 39, 40, 42, 44, 46, 53 Paragraph . . . . . . . . . . . . 9, 16, 23, 24, 35 Preserve . . . . . . . . . . . . . 8, 18, 42, 44, 51, 54 Region . . . . . . . . . . . . . . 9, 14, 18, 30, 33, 42, 50, 52, 54 Remove . . . . . . . . . . . . . 8, 16, 18, 19, 20, 28, 29, 30, 44 Select . . . . . . . . . . . . . . 8, 20, 26, 42, 43, 44 Sentence . . . . . . . . . . . . . 9, 16, 24, 25, 30 Set Global Variable . . . . . . . . 8, 17, 43, 46, 47, 48 Subsequent Command Modifier . . 8, 15, 17, 22, 32, 34, 40, 51 Text . . . . . . . . . . . . . . . 18, 23, 24, 25, 29, 30, 34, 35, 37, 38, 49, 51, 52, 53 Topic Index - 72 - NMODE Manual NMODE Manual - 3 - Table of Contents CONTENTS 1. Introduction ..................................................... 5 2. Action Types .................................................... 7 3. Definitions ....................................................... 9 4. Globals ......................................................... 11 5. Command Descriptions ........................................... 13 6. Command Index ................................................. 57 7. Function Index .................................................. 61 8. Key Index ...................................................... 65 9. Topic Index ..................................................... 71 |
Added psl-1983/3-1/doc/nmode/manual.r version [37e0336100].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Root file for NMODE Manual. .chp nm-introduction . .chp nm-screen .chp nm-characters .chp nm-editing .chp nm-arguments .chp nm-metax .chp nm-subsystems .chp nm-browsers .chp nm-selfdoc .chp nm-mark .chp nm-killing .chp nm-searching .chp nm-text .chp nm-typos .chp nm-files .chp nm-buffers .chp nm-display .chp nm-windows .chp nm-replacement .chp nm-programs .chp nm-misc .chp nm-customization .chp nm-bugs . .chp nm-actions .chp nm-definitions .chp nm-globals .chp nm-commands .chp nm-fun-index .chp nm-key-index .chp nm-top-index |
Added psl-1983/3-1/doc/nmode/nm-actions.contents version [b812521fc2].
> | 1 | contents_entry(0 24 {Action Types} 24-1) |
Added psl-1983/3-1/doc/nmode/nm-actions.ibm version [1aa54ce981].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-ACTIONS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Action Types) Page 24-1 202/24. Action Types 201/This section defines a number of 203/action types201/, which are used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Display Format 201/This type of command alters how text is displayed without altering the contents of existing buffers. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Existing Text 201/This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Change Mode 201/This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Escape 201/Escape from the current level. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Inform 201/This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Insert Constant 201/This type of command inserts a character constant like tab or space or a multiple thereof. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 24-2 NMODE Manual (Action Types) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Mark 201/This type of command sets mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Data 201/This command copies some data (which is not a constant wired into the program) from one place to another. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Point 201/This type of command moves point. It may move it within a buffer or from buffer to buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Preserve 201/Make a copy of something current and put it somewhere else (usually disc). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Remove 201/This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Select 201/This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Set Global Variable 201/This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Subsequent Command Modifier 201/This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ |
Added psl-1983/3-1/doc/nmode/nm-actions.topic version [c7ce65cc52].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | .silent_index {Alter Display Format} idx 24-1 .silent_index {Alter Existing Text} idx 24-1 .silent_index {Change Mode} idx 24-1 .silent_index {Escape} idx 24-1 .silent_index {Inform} idx 24-1 .silent_index {Insert Constant} idx 24-1 .silent_index {Mark} idx 24-2 .silent_index {Move Data} idx 24-2 .silent_index {Move Point} idx 24-2 .silent_index {Preserve} idx 24-2 .silent_index {Remove} idx 24-2 .silent_index {Select} idx 24-2 .silent_index {Set Global Variable} idx 24-2 .silent_index {Subsequent Command Modifier} idx 24-2 |
Added psl-1983/3-1/doc/nmode/nm-arguments.contents version [399d27b171].
> | 1 | contents_entry(0 5 {Giving Numeric Arguments to NMODE Commands} 5-1) |
Added psl-1983/3-1/doc/nmode/nm-arguments.function version [1153629c7c].
> > > > | 1 2 3 4 | .silent_index {universal-argument} idx 5-1 .silent_index {open-line-command} idx 5-1 .silent_index {argument-digit} idx 5-1 .silent_index {negative-argument} idx 5-1 |
Added psl-1983/3-1/doc/nmode/nm-arguments.ibm version [977df0daea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-ARGUMENTS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Giving Numeric Arguments to NMODE Commands) Page 5-1 202/5. Giving Numeric Arguments to NMODE Commands 201/Any NMODE command can be given a 202/numeric argument201/. Some commands interpret the argument as a repetition count. For example, giving an argument of ten to the C-F command (move forward one character) moves forward ten characters. With these commands, no argument is equivalent to an argument of 1. Some commands care only about whether there is an argument, and not about its value; for example, the command M-Q (203/fill-paragraph-command201/) with no arguments fills text, but with an argument justifies the text as well. Some commands use the value of the argument, but do something peculiar when there is no argument. For example, the C-K (203/kill-line201/) command with an argument <n> kills <n> lines and the line separators that follow them. But C-K with no argument is special; it kills the text up to the next line separator, or, if point is right at the end of the line, it kills the line separator itself. Thus, two C-K commands with no arguments can kill a nonblank line, just like C-K with an argument of one. The fundamental way of specifying an argument is to use the C-U (203/universal-argument201/) command followed by the digits of the argument. Negative arguments are allowed. Often they tell a command to move or act backwards. A negative argument is entered with C-U followed by a minus sign and the digits of the value of the argument. Another option for entering arguments is to use C-digit or strings there of. This runs the function 203/argument-digit 201/each time C-digit is entered. For example, C-U 1 2 3 does the same thing as C-1 C-2 C-3, both apply an argument of 123 to the next command. Negative arguments can also be specified with C-- (C-minus) which runs the function 203/negative-argument201/. C-U followed by a character which is neither a digit nor a minus sign has the special meaning of "multiply by four". It multiplies the argument for the next command by four. Two such C-U's multiply it by sixteen. Thus, C-U C-U C-F moves forward sixteen characters. This is a good way to move forward "fast", since it moves about 1/4 of a line on most terminals. Other useful combinations are C-U C-N, C-U C-U C-N (move down a good fraction of a screen), C-U C-U C-O (make "a lot" of blank lines), and C-U C-K (kill four lines). With commands like M-Q that care whether there is an argument but not what the value is, C-U is a good way of saying "I want an argument". A few commands treat a plain C-U differently from an ordinary argument. A few others may treat an argument of just a minus sign differently from an argument of -1. These unusual cases will be described when they come up; they are always for reasons of convenience of use. |
Added psl-1983/3-1/doc/nmode/nm-arguments.key version [7052b979ec].
> > | 1 2 | .silent_index {C-U} idx 5-1 .silent_index {C-O} idx 5-1 |
Added psl-1983/3-1/doc/nmode/nm-arguments.r version [2c92e1cff3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-ARGUMENTS manual @Chapter[Giving Numeric Arguments to NMODE Commands] @node("arguments") @index{numeric arguments} Any NMODE command can be given a @dfn[numeric argument]. Some commands interpret the argument as a repetition count. For example, giving an argument of ten to the C-F command (move forward one character) moves forward ten characters. With these commands, no argument is equivalent to an argument of 1. Some commands care only about whether there is an argument, and not about its value; for example, the command M-Q (@fnc{fill-paragraph-command}) with no arguments fills text, but with an argument justifies the text as well. Some commands use the value of the argument, but do something peculiar when there is no argument. For example, the C-K (@fnc{kill-line}) command with an argument <n> kills <n> lines and the line separators that follow them. But C-K with no argument is special; it kills the text up to the next line separator, or, if point is right at the end of the line, it kills the line separator itself. Thus, two C-K commands with no arguments can kill a nonblank line, just like C-K with an argument of one. @keyindex{C-U} @fncindex{universal-argument} @keyindex{C-O} @fncindex{open-line-command} @fncindex{argument-digit} @fncindex{negative-argument} The fundamental way of specifying an argument is to use the C-U (@fnc{universal-argument}) command followed by the digits of the argument. Negative arguments are allowed. Often they tell a command to move or act backwards. A negative argument is entered with C-U followed by a minus sign and the digits of the value of the argument. Another option for entering arguments is to use C-digit or strings there of. This runs the function @fnc{argument-digit} each time C-digit is entered. For example, C-U 1 2 3 does the same thing as C-1 C-2 C-3, both apply an argument of 123 to the next command. Negative arguments can also be specified with C-- (C-minus) which runs the function @fnc{negative-argument}. C-U followed by a character which is neither a digit nor a minus sign has the special meaning of "multiply by four". It multiplies the argument for the next command by four. Two such C-U's multiply it by sixteen. Thus, @w[C-U C-U C-F] moves forward sixteen characters. This is a good way to move forward "fast", since it moves about 1/4 of a line on most terminals. Other useful combinations are @w[C-U C-N], @w[C-U C-U C-N] (move down a good fraction of a screen), @w[C-U C-U C-O] (make "a lot" of blank lines), and @w[C-U C-K] (kill four lines). With commands like M-Q that care whether there is an argument but not what the value is, C-U is a good way of saying "I want an argument". A few commands treat a plain C-U differently from an ordinary argument. A few others may treat an argument of just a minus sign differently from an argument of -1. These unusual cases will be described when they come up; they are always for reasons of convenience of use. |
Added psl-1983/3-1/doc/nmode/nm-arguments.topic version [0343a62099].
> | 1 | .silent_index {numeric} idx 5-1 |
Added psl-1983/3-1/doc/nmode/nm-browsers.contents version [ca82f25a25].
> > > > | 1 2 3 4 | contents_entry(0 8 {Browser Subsystems} 8-1) contents_entry(1 8.1 {General Features of NMODE Browsers} 8-1) contents_entry(2 8.1.1 {Commands Common to Browser Subsystems} 8-1) contents_entry(1 8.2 {Invoking Browsers} 8-2) |
Added psl-1983/3-1/doc/nmode/nm-browsers.function version [1a0f9871c5].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | .silent_index {browser-ignore-command} idx 8-1 .silent_index {browser-help-command} idx 8-1 .silent_index {browser-undo-filter-command} idx 8-1 .silent_index {browser-view-command} idx 8-1 .silent_index {browser-edit-command} idx 8-1 .silent_index {apropos-command} idx 8-2 .silent_index {buffer-browser-command} idx 8-2 .silent_index {dired-command} idx 8-2 .silent_index {edit-directory-command} idx 8-2 .silent_index {browser-browser-command} idx 8-2 |
Added psl-1983/3-1/doc/nmode/nm-browsers.ibm version [7366996a68].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (12 April 1983) <PSL.NMODE-DOC>NM-BROWSERS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Browser Subsystems) Page 8-1 202/8. Browser Subsystems 8.1 General Features of NMODE Browsers 201/NMODE has a number of subsytems called browsers. Among NMODE's browsers are a buffer browser, a file browser, a documentation browser, and a browser browser. A browser is a subsystem that displays a list of objects and allows the user to select particular objects from the list for viewing or editing. The user can select objects by placing the cursor on their line. The object pointed to by the cursor is considered the current object. The list of the names of these objects is displayed immediately upon entering the browser in question. Because of NMODE's multiple window features, the list of objects in the browser can often be displayed at the same time as a portion of one of the objects. In the buffer browser, for instance, it is possible to view a buffer's contents in the lower window while still displaying the list of all buffers in the upper window. 202/8.1.1 Commands Common to Browser Subsystems 201/A number of commands are common to all the browser subsystems. For instance, in all the browsers the list of objects displayed can be shortened selectively. The I command (203/browser-ignore-command201/) will remove the current object from the list. The filter command F (which function is invoked depends on the browser) will remove a set of objects, typically those matching a user-supplied string in some way. The options availible in the filter command differ from browser to browser. They can always be displayed by typing ? after entering the filter command with an F. The list of objects can be restored to its former size by using the N command (203/browser-undo-filter-command201/). Other common commands are the E command (203/browser-edit-command201/) and the V command (203/browser-view-command201/). They allow closer examination of the objects listed in the browser. The current object is displayed when the view or edit command is given. In split screen mode, edit will select the bottom window while view does not. Split screen mode can be activated by giving an argument to E or V. In the buffer and file browsers, edit and view can be used to initiate actual alteration of a buffer or file. The buffer and file browsers are often used, in fact, to easily locate and enter buffers and files with long names that the user has forgotten. After editing a file or buffer one can escape back to the browser with C-M-L. Similarly, one can escape back out of any browser with a quit, Q, command (which function is invoked depends on the browser). As can be seen from these examples, browser commands are often single printing characters, which are not self-inserting in browser modes. The browser helps users keep track of commands by displaying an information line at the bottom of the screen. This line shows the commands available in the browser, with the character that invokes the command capitalized. In addition to this cue the browsers provide a line or two of on-line documentation about each command. This information can be displayed by typing ? (203/browser-help-command201/) to the browser's top level. 201/Page 8-2 NMODE Manual (Invoking Browsers) 202/8.2 Invoking Browsers 201/Each browser can be entered with a particular command. The documentation browser can be entered with M-X Apropos (203/apropos-command201/). The buffer browser can be entered with C-X C-B (203/buffer-browser-command201/). The file browser can be entered through either C-X D (203/dired-command201/) or through M-X Edit Directory (203/edit-directory-command201/). The browser-browser can be entered through M-X List Browsers (203/browser-browser-command201/). On the HP9836, several of these commands are availible through soft keys. Another way to enter most of the browsers is to enter the browser-browser and then create or visit a particular browser with the B command (203/browser-browser-browse-command201/). This will visit an existing browser, or create a new browser from a browser template (possibly prompting the user for some input in the process). |
Added psl-1983/3-1/doc/nmode/nm-browsers.key version [8302937ed1].
> > > > > | 1 2 3 4 5 | .silent_index {M-X} idx 8-2 .silent_index {C-X} idx 8-2 .silent_index {C-X} idx 8-2 .silent_index {M-X} idx 8-2 .silent_index {M-X} idx 8-2 |
Added psl-1983/3-1/doc/nmode/nm-browsers.r version [50b0ba252a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-BROWSERS manual @Chapter(Browser Subsystems) @node("browsers") @section[General Features of NMODE Browsers] NMODE has a number of subsytems called browsers. Among NMODE's browsers are a buffer browser, a file browser, a documentation browser, and a browser browser. A browser is a subsystem that displays a list of objects and allows the user to select particular objects from the list for viewing or editing. The user can select objects by placing the cursor on their line. The object pointed to by the cursor is considered the current object. The list of the names of these objects is displayed immediately upon entering the browser in question. Because of NMODE's multiple window features, the list of objects in the browser can often be displayed at the same time as a portion of one of the objects. In the buffer browser, for instance, it is possible to view a buffer's contents in the lower window while still displaying the list of all buffers in the upper window. @subsection[Commands Common to Browser Subsystems] @fncindex{browser-ignore-command} @fncindex{browser-help-command} @fncindex{browser-undo-filter-command} @fncindex{browser-view-command} @fncindex{browser-edit-command} A number of commands are common to all the browser subsystems. For instance, in all the browsers the list of objects displayed can be shortened selectively. The I command (@fnc{browser-ignore-command}) will remove the current object from the list. The filter command F (which function is invoked depends on the browser) will remove a set of objects, typically those matching a user-supplied string in some way. The options availible in the filter command differ from browser to browser. They can always be displayed by typing ? after entering the filter command with an F. The list of objects can be restored to its former size by using the N command (@fnc{browser-undo-filter-command}). Other common commands are the E command (@fnc{browser-edit-command}) and the V command (@fnc{browser-view-command}). They allow closer examination of the objects listed in the browser. The current object is displayed when the view or edit command is given. In split screen mode, edit will select the bottom window while view does not. Split screen mode can be activated by giving an argument to E or V. In the buffer and file browsers, edit and view can be used to initiate actual alteration of a buffer or file. The buffer and file browsers are often used, in fact, to easily locate and enter buffers and files with long names that the user has forgotten. After editing a file or buffer one can escape back to the browser with C-M-L. Similarly, one can escape back out of any browser with a quit, Q, command (which function is invoked depends on the browser). As can be seen from these examples, browser commands are often single printing characters, which are not self-inserting in browser modes. The browser helps users keep track of commands by displaying an information line at the bottom of the screen. This line shows the commands available in the browser, with the character that invokes the command capitalized. In addition to this cue the browsers provide a line or two of on-line documentation about each command. This information can be displayed by typing ? (@fnc{browser-help-command}) to the browser's top level. @section[Invoking Browsers] @keyindex{M-X Apropos} @fncindex{apropos-command} @keyindex{C-X C-B} @fncindex{buffer-browser-command} @keyindex{C-X D} @fncindex{dired-command} @keyindex{M-X Edit Directory} @fncindex{edit-directory-command} @keyindex{M-X List Browsers} @fncindex{browser-browser-command} Each browser can be entered with a particular command. The documentation browser can be entered with M-X Apropos (@fnc{apropos-command}). The buffer browser can be entered with C-X C-B (@fnc{buffer-browser-command}). The file browser can be entered through either C-X D (@fnc{dired-command}) or through M-X Edit Directory (@fnc{edit-directory-command}). The browser-browser can be entered through M-X List Browsers (@fnc{browser-browser-command}). On the HP9836, several of these commands are availible through soft keys. Another way to enter most of the browsers is to enter the browser-browser and then create or visit a particular browser with the B command (@fnc{browser-browser-browse-command}). This will visit an existing browser, or create a new browser from a browser template (possibly prompting the user for some input in the process). |
Added psl-1983/3-1/doc/nmode/nm-buffers.contents version [dd048328ec].
> > > > | 1 2 3 4 | contents_entry(0 16 {Using Multiple Buffers} 16-1) contents_entry(1 16.1 {Creating and Selecting Buffers} 16-1) contents_entry(1 16.2 {Using Existing Buffers} 16-2) contents_entry(1 16.3 {Killing Buffers} 16-2) |
Added psl-1983/3-1/doc/nmode/nm-buffers.function version [db936a9a21].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | .silent_index {select-buffer-command} idx 16-1 .silent_index {select-previous-buffer-command} idx 16-1 .silent_index {find-file-command} idx 16-1 .silent_index {buffer-browser-command} idx 16-2 .silent_index {save-file-command} idx 16-2 .silent_index {save-all-files-command} idx 16-2 .silent_index {rename-buffer-command} idx 16-2 .silent_index {append-to-buffer-command} idx 16-2 .silent_index {insert-buffer-command} idx 16-2 .silent_index {kill-some-buffers-command} idx 16-2 .silent_index {kill-buffer-command} idx 16-2 |
Added psl-1983/3-1/doc/nmode/nm-buffers.ibm version [8b21bcf8c7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-BUFFERS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Using Multiple Buffers) Page 16-1 202/16. Using Multiple Buffers 201/When we speak of "the buffer", which contains the text you are editing, we have given the impression that there is only one. In fact, there may be many of them, each with its own body of text. At any time only one buffer can be 202/selected 201/and available for editing, but it isn't hard to switch to a different one. Each buffer individually remembers which file it is visiting, what modes are in effect, and whether there are any changes that need saving. C-X B Select or create a buffer. C-M-L Select previous buffer. C-X C-F Visit a file in its own buffer. C-X C-B List the existing buffers. C-X K Kill a buffer. Each buffer in NMODE has a single name, which normally doesn't change. A buffer's name can be any length. The name of the currently selected buffer, and the name of the file visited in it, are visible in the mode line when you are at top level. A newly started NMODE has only one buffer, named "Main". 202/16.1 Creating and Selecting Buffers 201/To create a new buffer, you need only think of a name for it (say, "FOO") and then do C-X B FOO<CR>, which is the command C-X B (Select Buffer) followed by the name. This makes a new, empty buffer and selects it for editing. The new buffer is not visiting any file, so if you try to save it you will be asked for the filename to use. Each buffer has its own major mode; the new buffer's major mode is taken from the value of the variable nmode-default-mode. Normally nmode-default-mode is text mode. To return to buffer FOO later after having switched to another, the same command C-X B FOO<CR> is used, since C-X B can tell whether a buffer named FOO exists already or not. It does not matter whether you use upper case or lower case in typing the name of a buffer. C-X B Main<CR> reselects the buffer Main that NMODE started out with. Just C-X B<CR> reselects the previous buffer. One can also return to the previous buffer with C-M-L (203/select-previous-buffer-command201/). This will select the previous buffer, if possible. Otherwise, it will select the MAIN buffer. You can also read a file into its own newly created buffer, all with one command: C-X C-F (203/find-file-command201/), followed by the filename. The name of the file (within its directory) becomes the buffer name. C-F stands for "Find", because if the specified file already resides in a buffer in your NMODE, that buffer is reselected. So you need not remember whether you have brought the file in already or not. A buffer created by C-X C-F can be reselected later with C-X B or C-X C-F, whichever you find more convenient. Nonexistent files can be created with C-X C-F just as they can be with C-X C-V. See Section 15.1 [Visiting], page 1. 201/Page 16-2 NMODE Manual (Using Existing Buffers) 202/16.2 Using Existing Buffers 201/To get a list of all the buffers that exist, do C-X C-B (203/buffer-browser-command201/). Each buffer's name, size, and visited filenames are printed. A star at the beginning of a line indicates a buffer which contains changes that have not been saved. If several buffers have stars, you should save some of them with M-X Save All Files (203/save-all-files-command201/). This finds all the buffers that need saving and asks about each one individually. Saving the buffers this way is much easier and more efficient than selecting each one and typing C-X C-S. M-X Rename Buffer<CR><new name><CR> (203/rename-buffer-command201/) changes the name of the currently selected buffer. If <new name> is the null string, a truncated version of the filename of the visited file is used as the new name of the buffer. The commands C-X A (203/append-to-buffer-command201/) and M-X Insert Buffer (203/insert-buffer-command201/) can be used to copy text from one buffer to another. See Section 11.3 [Copying], page 4. 202/16.3 Killing Buffers 201/After you use an NMODE for a while, it may fill up with buffers which you no longer need. Eventually you can reach a point where trying to create any more results in running out of memory space. So whenever it is convenient you should do M-X Kill Some Buffers, (203/kill-some-buffers-command201/) which asks about each buffer individually. You can say Y or N to kill it or not. Or you can say Control-R to take a look at it first. This gives you a recursive editing level in which you can move around and look at things. When you have seen enough to make up your mind, exit the recursive editing level with a y or n to kill or save the buffer. If you say to kill a buffer that needs saving, you will be asked whether it should be saved. You can kill the buffer FOO by doing C-X K FOO<CR> (203/kill-buffer-command201/). If the buffer being killed has been modified since it was last saved, NMODE will ask you to confirm your command to kill it. You can kill the selected buffer, a common thing to do if you use C-X C-F, by doing C-X K<CR>. If you kill the selected buffer, in any way, NMODE will move you to another buffer. |
Added psl-1983/3-1/doc/nmode/nm-buffers.key version [3ca5983c52].
> > > > > > | 1 2 3 4 5 6 | .silent_index {C-X} idx 16-1 .silent_index {C-M-L} idx 16-1 .silent_index {C-X} idx 16-1 .silent_index {C-X} idx 16-2 .silent_index {C-X} idx 16-2 .silent_index {C-X} idx 16-2 |
Added psl-1983/3-1/doc/nmode/nm-buffers.r version [913a451ef1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-BUFFERS manual @Chapter[Using Multiple Buffers] @Node("buffers") @index{buffers} When we speak of "the buffer", which contains the text you are editing, we have given the impression that there is only one. In fact, there may be many of them, each with its own body of text. At any time only one buffer can be @dfn[selected] and available for editing, but it isn't hard to switch to a different one. Each buffer individually remembers which file it is visiting, what modes are in effect, and whether there are any changes that need saving. @WideCommands{ C-X B Select or create a buffer. C-M-L Select previous buffer. C-X C-F Visit a file in its own buffer. C-X C-B List the existing buffers. C-X K Kill a buffer. } @index{mode line} Each buffer in NMODE has a single name, which normally doesn't change. A buffer's name can be any length. The name of the currently selected buffer, and the name of the file visited in it, are visible in the mode line when you are at top level. A newly started NMODE has only one buffer, named "Main". @Section[Creating and Selecting Buffers] @keyindex{C-X B} @fncindex{select-buffer-command} @index{Select Buffer} @index{nmode-default-mode} @index{Major Modes} To create a new buffer, you need only think of a name for it (say, "FOO") and then do C-X B FOO@return2{}, which is the command C-X B (Select Buffer) followed by the name. This makes a new, empty buffer and selects it for editing. The new buffer is not visiting any file, so if you try to save it you will be asked for the filename to use. Each buffer has its own major mode; the new buffer's major mode is taken from the value of the variable nmode-default-mode. Normally nmode-default-mode is text mode. To return to buffer FOO later after having switched to another, the same command C-X B FOO@return2{} is used, since C-X B can tell whether a buffer named FOO exists already or not. It does not matter whether you use upper case or lower case in typing the name of a buffer. C-X B Main@return2{} reselects the buffer Main that NMODE started out with. Just C-X B@return2{} reselects the previous buffer. @keyindex{C-M-L} @fncindex{select-previous-buffer-command} One can also return to the previous buffer with C-M-L (@fnc{select-previous-buffer-command}). This will select the previous buffer, if possible. Otherwise, it will select the MAIN buffer. @keyindex{C-X C-F} @index{visiting} @index{Find File} @fncindex{find-file-command} You can also read a file into its own newly created buffer, all with one command: C-X C-F (@fnc{find-file-command}), followed by the filename. The name of the file (within its directory) becomes the buffer name. C-F stands for "Find", because if the specified file already resides in a buffer in your NMODE, that buffer is reselected. So you need not remember whether you have brought the file in already or not. A buffer created by C-X C-F can be reselected later with C-X B or C-X C-F, whichever you find more convenient. Nonexistent files can be created with C-X C-F just as they can be with C-X C-V. @Note("Visiting"). @Section[Using Existing Buffers] @keyindex{C-X C-B} @fncindex{buffer-browser-command} @index{List Buffers} To get a list of all the buffers that exist, do C-X C-B (@fnc{buffer-browser-command}). Each buffer's name, size, and visited filenames are printed. A star at the beginning of a line indicates a buffer which contains changes that have not been saved. @index{Save All Files} @keyindex{C-X C-S} @fncindex{save-file-command} @fncindex{save-all-files-command} If several buffers have stars, you should save some of them with M-X Save All Files (@fnc{save-all-files-command}). This finds all the buffers that need saving and asks about each one individually. Saving the buffers this way is much easier and more efficient than selecting each one and typing C-X C-S. @index{Rename Buffer} @fncindex{rename-buffer-command} @fncindex{append-to-buffer-command} @fncindex{insert-buffer-command} M-X Rename Buffer@return1{}<new name>@return2{} (@fnc{rename-buffer-command}) changes the name of the currently selected buffer. If <new name> is the null string, a truncated version of the filename of the visited file is used as the new name of the buffer. The commands C-X A (@fnc{append-to-buffer-command}) and M-X Insert Buffer (@fnc{insert-buffer-command}) can be used to copy text from one buffer to another. @Note("Copying"). @Section[Killing Buffers] @index{Kill Buffer} @index{Kill Some Buffers} @keyindex{C-X K} @index{recursive editing level} @fncindex{kill-some-buffers-command} After you use an NMODE for a while, it may fill up with buffers which you no longer need. Eventually you can reach a point where trying to create any more results in running out of memory space. So whenever it is convenient you should do M-X Kill Some Buffers, (@fnc{kill-some-buffers-command}) which asks about each buffer individually. You can say Y or N to kill it or not. Or you can say Control-R to take a look at it first. This gives you a recursive editing level in which you can move around and look at things. When you have seen enough to make up your mind, exit the recursive editing level with a y or n to kill or save the buffer. If you say to kill a buffer that needs saving, you will be asked whether it should be saved. @fncindex{kill-buffer-command} You can kill the buffer FOO by doing C-X K FOO@return2{} (@fnc{kill-buffer-command}). If the buffer being killed has been modified since it was last saved, NMODE will ask you to confirm your command to kill it. You can kill the selected buffer, a common thing to do if you use C-X C-F, by doing C-X K@return1{}. If you kill the selected buffer, in any way, NMODE will move you to another buffer. |
Added psl-1983/3-1/doc/nmode/nm-buffers.topic version [f9b6cc9a45].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | .silent_index {buffers} idx 16-1 .silent_index {mode} idx 16-1 .silent_index {Select} idx 16-1 .silent_index {nmode-default-mode} idx 16-1 .silent_index {Major} idx 16-1 .silent_index {visiting} idx 16-1 .silent_index {Find} idx 16-1 .silent_index {List} idx 16-2 .silent_index {Save} idx 16-2 .silent_index {Rename} idx 16-2 .silent_index {Kill} idx 16-2 .silent_index {Kill} idx 16-2 .silent_index {recursive} idx 16-2 |
Added psl-1983/3-1/doc/nmode/nm-bugs.contents version [63cf1571ca].
> > > > > > | 1 2 3 4 5 6 | contents_entry(0 23 {Correcting Mistakes and NMODE Problems} 23-1) contents_entry(1 23.1 {Quitting and Aborting} 23-1) contents_entry(2 23.1.1 {Garbage on the Screen} 23-1) contents_entry(1 23.2 {Reporting Bugs} 23-1) contents_entry(2 23.2.1 {When Is There a Bug} 23-1) contents_entry(2 23.2.2 {How to Report a Bug} 23-2) |
Added psl-1983/3-1/doc/nmode/nm-bugs.function version [df798b52bd].
> | 1 | .silent_index {nmode-abort-command} idx 23-1 |
Added psl-1983/3-1/doc/nmode/nm-bugs.ibm version [9c0e304ac0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-BUGS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Correcting Mistakes and NMODE Problems) Page 23-1 202/23. Correcting Mistakes and NMODE Problems 201/If you type an NMODE command you did not intend, the results are often mysterious. This chapter tells what you can do to cancel your mistake or recover from a mysterious situation. NMODE bugs and system crashes are also considered. 202/23.1 Quitting and Aborting 201/C-G Quit. Cancel partially typed command. There are two ways of cancelling commands which are not finished executing: 202/quitting 201/with C-G (203/nmode-abort-command201/), and 202/aborting 201/with C-C on Twenex or STOP on the hp9836. Quitting is cancelling a partially typed command. Aborting is cancelling a command which is already running. Aborting generally doesn't allow a clean re-entry into the old NMODE environment so it is generally not recommended. Quitting with C-G is used for getting rid of a partially typed command, or a numeric argument that you don't want. Quitting an incremental search does special things documented under searching; in general, it may take two successive C-G's to get out of a search. 202/23.1.1 Garbage on the Screen 201/If the data on the screen looks wrong, it could be due to line noise on input or output, a bug in the terminal, a bug in NMODE redisplay, or a bug in an NMODE command. To find out whether there is really anything wrong with your text, the first thing to do is type C-L. This is a command to clear the screen and redisplay it. Often this will display the text you expected. Think of it as getting an opinion from another doctor. 202/23.2 Reporting Bugs 201/Sometimes you will encounter a bug in NMODE. To get it fixed, you must report it. It is your duty to do so; but you must know when to do so and how if it is to be constructive. 202/23.2.1 When Is There a Bug 201/If NMODE executes an illegal instruction, or dies with an operating system error message that indicates a problem in the program (as opposed to "disk full"), then it probably is a bug. We say "probably" because you can also cause these errors yourself if you execute your own code or modify NMODE by redefining its functions or changing its variables. If NMODE updates the display in a way that does not correspond to what is in the buffer, then it is probably a bug. If a command seems to do the wrong thing but the problem is gone if you type C-L, then it is a case of incorrect display updating. 201/Page 23-2 NMODE Manual (When Is There a Bug) Taking forever to complete a command can be a bug, but you must make certain that it was really NMODE's fault. Some commands simply take a long time. If a command you are familiar with causes an NMODE error message in a case where its usual definition ought to be reasonable, it is probably a bug. If a command does the wrong thing, that is a bug. But be sure you know for certain what it ought to have done. If you aren't familiar with the command, or don't know for certain how the command is supposed to work, then it might actually be working right. Rather than jumping to conclusions, show the problem to someone who knows for certain. Finally, a command's intended definition may not be best for editing with. This is a very important sort of problem, but it is also a matter of judgment. Also, it is easy to come to such a conclusion out of ignorance of some of the existing features. It is probably best not to complain about such a problem until you have checked the documentation in the usual ways, feel confident that you understand it, and know for certain that what you want is not available. If you feel confused about the documentation instead, then you don't have grounds for an opinion about whether the command's definition is optimal. Make sure you read it through and check the index or the menus for all references to subjects you don't fully understand. If you have done this diligently and are still confused, or if you finally understand but think you could have said it better, then you have a constructive complaint to make 203/about the documentation201/. It is just as important to report documentation bugs as program bugs. 202/23.2.2 How to Report a Bug 201/When you decide that there is a bug, it is important to report it and to report it in a way which is useful. What is most useful is an exact description of what commands you type, starting with a fresh NMODE just loaded, until the problem happens. Send the bug report to the author (see the preface for the address). The most important principle in reporting a bug is to report 203/facts201/, not hypotheses or conditions. It is always easier to report the facts, but people seem to prefer to strain to think up explanations and report them instead. If the explanations are based on guesses about how NMODE is implemented, they will be useless; we will have to try to figure out what the facts must have been to lead to such speculations. Sometimes this is impossible. But in any case, it is unnecessary work for us. For example, suppose that you type C-X C-V <GLORP>BAZ.UGH<CR>, visiting a file which (you know) happens to be rather large, and NMODE prints out "I feel pretty today". The best way to report the bug is with a sentence like the preceding one, because it gives all the facts and nothing but the facts. Do not assume that the problem is due to the size of the file and say "When I visit a large file, NMODE prints out 'I feel pretty today'". This is what we mean by "guessing explanations". The problem is just as likely to be due to 201/NMODE Manual (How to Report a Bug) Page 23-3 the fact that there is a "Z" in the filename. If this is so, then when we got your report, we would try out the problem with some "big file", probably with no "Z" in its name, and not find anything wrong. There is no way in the world that we could guess that we should try visiting a file with a "Z" in its name. Alternatively, the problem might be due to the fact that the file starts with exactly 25 spaces. For this reason, you should make sure that you don't change the file until we have looked at it. Suppose the problem only occurs when you have typed the C-X C-A command previously? This is why we ask you to give the exact sequence of characters you typed since loading the NMODE. You should not even say "visit the file ..." instead of "C-X C-V" unless you 203/know 201/that it makes no difference which visiting command is used. Similarly, rather than saying "if I have three characters on the line", say "after I type <CR>A B C<CR>C-P", if that is the way you entered the text. In addition, you should say what mode you are in. If the bug occurred in a customized NMODE, it is helpful to try to reproduce the bug in a more standard NMODE. It is best if you can make the problem happen in a completely standard NMODE. If the problem does 203/not 201/occur in a standard NMODE, it is very important to report that fact, because otherwise we will try to debug it in a standard NMODE, not find the problem, and give up. If the problem does depend on an init file, then you should make sure it is not a bug in the init file by complaining to the person who wrote the file, first. He should check over his code, and verify the definitions of the PSL commands he is using. Then if he verifies that the bug is in NMODE he should report it. We cannot be responsible for maintaining users' init files; we might not even be able to tell what they are supposed to do. If you can tell us a way to cause the problem without reading in any files, please do so. This makes it much easier to debug. If you do need files, make sure you arrange for us to see their exact contents. For example, it can often matter whether there are spaces at the ends of lines, or a line separator after the last line in the buffer (nothing ought to care whether the last line is terminated, but tell that to the bugs). |
Added psl-1983/3-1/doc/nmode/nm-bugs.key version [e624d068f7].
> > | 1 2 | .silent_index {C-G} idx 23-1 .silent_index {C-G} idx 23-1 |
Added psl-1983/3-1/doc/nmode/nm-bugs.r version [ce1a7c9b08].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-BUGS manual @Chapter[Correcting Mistakes and NMODE Problems] If you type an NMODE command you did not intend, the results are often mysterious. This chapter tells what you can do to cancel your mistake or recover from a mysterious situation. NMODE bugs and system crashes are also considered. @Section[Quitting and Aborting] @node("quitting") @fncindex{nmode-abort-command} @keyindex{C-G} @Commands{ C-G Quit. Cancel partially typed command. } There are two ways of cancelling commands which are not finished executing: @dfn[quitting] with C-G (@fnc{nmode-abort-command}), and @dfn[aborting] with C-C on Twenex or STOP on the hp9836. Quitting is cancelling a partially typed command. Aborting is cancelling a command which is already running. Aborting generally doesn't allow a clean re-entry into the old NMODE environment so it is generally not recommended. @index{quitting}@keyindex{C-G} Quitting with C-G is used for getting rid of a partially typed command, or a numeric argument that you don't want. Quitting an incremental search does special things documented under searching; in general, it may take two successive C-G's to get out of a search. @SubSection[Garbage on the Screen] If the data on the screen looks wrong, it could be due to line noise on input or output, a bug in the terminal, a bug in NMODE redisplay, or a bug in an NMODE command. To find out whether there is really anything wrong with your text, the first thing to do is type C-L. This is a command to clear the screen and redisplay it. Often this will display the text you expected. Think of it as getting an opinion from another doctor. @SubSection[Garbage Displayed Persistently] @index{terminal type} @Twenex{@Index[Set Terminal Type]} @ITS{@index[TCTYP]} If NMODE persistently displays garbage on the screen, or if it outputs the right things but scattered around all the wrong places on the screen, it may be that NMODE has the wrong idea of your terminal type. The first thing to do in this case is to exit from NMODE and restart it. Each time NMODE is restarted it asks the system what terminal type you are using. Whenever you detach and move to a terminal of a different type you should restart NMODE as a matter of course. If you stopped NMODE with the exit command, or by interrupting it when it was awaiting a command, then this is sure to be safe. The system itself may not know what type of terminal you have. You should try telling the system with the @ITS{:TCTYP command.}@Twenex{TERMINAL TYPE command in EXEC. If your terminal is compatible with one of the standard types but has a different size screen, you must tell the system the size with the TERMINAL LENGTH and TERMINAL WIDTH commands, because NMODE uses whatever size the system says it knows. Alternatively, you can use Set Terminal Type. @Note("Term Types" "Terminal Types"), for more information.} @SubSection[URK Error (Address Space Exhausted)] @label[NMODEURK] @Index{Make Space}@INDEX{URK}@Index{Kill Ring}@Index{Undo} @Index{Kill Libraries}@Index{Kill Some Buffers} If attempting to visit a file or load a library causes an "URK" error, it means you have filled up the address space; there is no room inside NMODE for any more files or libraries. In this situation NMODE will try to run the function Make Space for you. If NMODE is unable to do it for you, you may still be able to do M-X Make Space yourself. This command compacts the data inside NMODE to free up some space. It also offers to discard data that may be occupying a lot of space, such as the kill ring (@Note("Killing").), the undo memory (@Note("Undo").), and buffers created by @ITS(RMAIL,) TAGS and INFO. Another way of freeing space is to kill buffers with M-X Kill Some Buffers (@Note("Buffers")@.) or unload libraries with M-X Kill Libraries (@Note("Libraries").). @index{What Available Space} Use the command M-X What Available Space to find out how close you are to running out of space. It tells you how many K of space you have available for additional files or libraries. @Section[Reporting Bugs] @node("bugs") @index{Bugs} Sometimes you will encounter a bug in NMODE. To get it fixed, you must report it. It is your duty to do so; but you must know when to do so and how if it is to be constructive. @Subsection[When Is There a Bug] If NMODE executes an illegal instruction, or dies with an operating system error message that indicates a problem in the program (as opposed to "disk full"), then it probably is a bug. We say "probably" because you can also cause these errors yourself if you execute your own code or modify NMODE by redefining its functions or changing its variables. If NMODE updates the display in a way that does not correspond to what is in the buffer, then it is probably a bug. If a command seems to do the wrong thing but the problem is gone if you type C-L, then it is a case of incorrect display updating. Taking forever to complete a command can be a bug, but you must make certain that it was really NMODE's fault. Some commands simply take a long time. If a command you are familiar with causes an NMODE error message in a case where its usual definition ought to be reasonable, it is probably a bug. If a command does the wrong thing, that is a bug. But be sure you know for certain what it ought to have done. If you aren't familiar with the command, or don't know for certain how the command is supposed to work, then it might actually be working right. Rather than jumping to conclusions, show the problem to someone who knows for certain. Finally, a command's intended definition may not be best for editing with. This is a very important sort of problem, but it is also a matter of judgment. Also, it is easy to come to such a conclusion out of ignorance of some of the existing features. It is probably best not to complain about such a problem until you have checked the documentation in the usual ways, feel confident that you understand it, and know for certain that what you want is not available. If you feel confused about the documentation instead, then you don't have grounds for an opinion about whether the command's definition is optimal. Make sure you read it through and check the index or the menus for all references to subjects you don't fully understand. If you have done this diligently and are still confused, or if you finally understand but think you could have said it better, then you have a constructive complaint to make @xxi(about the documentation). It is just as important to report documentation bugs as program bugs. @Subsection[How to Report a Bug] When you decide that there is a bug, it is important to report it and to report it in a way which is useful. What is most useful is an exact description of what commands you type, starting with a fresh NMODE just loaded, until the problem happens. Send the bug report to the author (see the preface for the address). The most important principle in reporting a bug is to report @xxii[facts], not hypotheses or conditions. It is always easier to report the facts, but people seem to prefer to strain to think up explanations and report them instead. If the explanations are based on guesses about how NMODE is implemented, they will be useless; we will have to try to figure out what the facts must have been to lead to such speculations. Sometimes this is impossible. But in any case, it is unnecessary work for us. For example, suppose that you type C-X C-V <GLORP>BAZ.UGH@return1{}, visiting a file which (you know) happens to be rather large, and NMODE prints out "I feel pretty today". The best way to report the bug is with a sentence like the preceding one, because it gives all the facts and nothing but the facts. Do not assume that the problem is due to the size of the file and say "When I visit a large file, NMODE prints out 'I feel pretty today'". This is what we mean by "guessing explanations". The problem is just as likely to be due to the fact that there is a "Z" in the filename. If this is so, then when we got your report, we would try out the problem with some "big file", probably with no "Z" in its name, and not find anything wrong. There is no way in the world that we could guess that we should try visiting a file with a "Z" in its name. Alternatively, the problem might be due to the fact that the file starts with exactly 25 spaces. For this reason, you should make sure that you don't change the file until we have looked at it. Suppose the problem only occurs when you have typed the C-X C-A command previously? This is why we ask you to give the exact sequence of characters you typed since loading the NMODE. You should not even say "visit the file ..." instead of "C-X C-V" unless you @xxi[know] that it makes no difference which visiting command is used. Similarly, rather than saying "if I have three characters on the line", say "after I type @return1{}A B C@return1{}C-P", if that is the way you entered the text. In addition, you should say what mode you are in. @index{FS Flags}@index{minibuffer} Be sure to say what version of NMODE and TECO are running. If you don't know, type Meta-Altmode QNMODE Version= FS Version= and NMODE will print them out. (This is a use of the minibuffer. @Note("Minibuffer").) If the bug occurred in a customized NMODE, it is helpful to try to reproduce the bug in a more standard NMODE. It is best if you can make the problem happen in a completely standard NMODE. If the problem does @xxii[not] occur in a standard NMODE, it is very important to report that fact, because otherwise we will try to debug it in a standard NMODE, not find the problem, and give up. If the problem does depend on an init file, then you should make sure it is not a bug in the init file by complaining to the person who wrote the file, first. He should check over his code, and verify the definitions of the PSL commands he is using. Then if he verifies that the bug is in NMODE he should report it. We cannot be responsible for maintaining users' init files; we might not even be able to tell what they are supposed to do. If you can tell us a way to cause the problem without reading in any files, please do so. This makes it much easier to debug. If you do need files, make sure you arrange for us to see their exact contents. For example, it can often matter whether there are spaces at the ends of lines, or a line separator after the last line in the buffer (nothing ought to care whether the last line is terminated, but tell that to the bugs). If NMODE gets an operating system error message, such as for an illegal instruction, then you can probably recover by restarting it. But before doing so, you should make a dump file. If you restart or continue the NMODE before making the dump, the trail will be covered and it will probably be too late to find out what happened. @Twenex{Use the SAVE command to do this; however, this does not record the contents of the accumulators. To do that, use the EXEC commands EXAMINE 0, EXAMINE 1, etc., through EXAMINE 17. Include the numbers printed by these commands as part of your bug report.}@ITS{Use the DDT command @;@example[ :PDUMP CRASH;NMODE <yourname> @;] (or use any other suitable filename) to do this. Your bug report should contain the filename you used for the dump, and the error message printed when the NMODE stopped, as well as the events leading up to the bug. The first number in the error message is the PC, which is not recorded by :PDUMP, so it must be copied precisely. Also type .JPC/ and include DDT's response in your report.} A dump is also useful if NMODE gets into a wedged state in which commands that usually work do strange things. @manual{@include(wordab.mss)@String(Filename="NMODE")} |
Added psl-1983/3-1/doc/nmode/nm-bugs.topic version [8ba056e473].
> > | 1 2 | .silent_index {quitting} idx 23-1 .silent_index {Bugs} idx 23-1 |
Added psl-1983/3-1/doc/nmode/nm-characters.contents version [89ad5480d7].
> > > > > | 1 2 3 4 5 | contents_entry(0 3 {Character Sets and Command Input Conventions} 3-1) contents_entry(1 3.1 {The 9-bit Command Character Set} 3-1) contents_entry(1 3.2 {Prefix Characters} 3-2) contents_entry(1 3.3 {Commands, Functions, and Variables} 3-2) contents_entry(1 3.4 {Notational Conventions for ASCII Characters} 3-3) |
Added psl-1983/3-1/doc/nmode/nm-characters.function version [253a9fcded].
> > > > | 1 2 3 4 | .silent_index {c-x-prefix} idx 3-2 .silent_index {m-x-prefix} idx 3-2 .silent_index {lisp-prefix} idx 3-2 .silent_index {esc-prefix} idx 3-2 |
Added psl-1983/3-1/doc/nmode/nm-characters.ibm version [7a4c0c01f7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-CHARACTERS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Character Sets and Command Input Conventions) Page 3-1 202/3. Character Sets and Command Input Conventions 201/In this chapter we introduce the terminology and concepts used to talk about NMODE commands. NMODE is designed to be used with a kind of keyboard with two special shift keys which can type 512 different characters, instead of the 128 different characters which ordinary ASCII keyboards can send. The terminology of NMODE commands is formulated in terms of these shift keys. So that NMODE can be used on ASCII terminals, we provide two-character ASCII circumlocutions for the command characters which are not ASCII. 202/3.1 The 9-bit Command Character Set 201/NMODE is designed ideally to be used with terminals whose keyboards have a pair of shift keys, labeled "Control" and "Meta", either or both of which can be combined with any character that you can type. These shift keys produce 202/Control 201/characters and 202/Meta 201/characters, which are the editing commands of NMODE. We name each of these characters by prefixing "Control-" (or "C-"), "Meta-" (or "M-") or both to the basic character: thus, Meta-F or M-F is the character which is F typed with the Meta key held down. C-M-; is the Semicolon character with both the Control and Meta keys. Control in the NMODE command character set is not precisely the same as Control in the ASCII character set, but the general purpose is the same. There are 128 basic characters. Multiplied by the four possibilities of the Control and Meta keys, this makes 512 characters in the NMODE command character set. So it is called the 512-character set, to distinguish it from ASCII, which has only 128 characters. It is also called the 202/9-bit 201/character set because 9 bits are required to express a number from 0 to 511. Note that the 512-character set is used only for keyboard commands. Characters in files being edited with NMODE are ASCII characters. Sadly, most terminals do not have ideal NMODE keyboards. In fact, the only ideal keyboards are at MIT. On nonideal keyboards, the Control key is somewhat limited (it can only be combined with some characters, not with all), and the Meta key may not exist at all. We make it possible to use NMODE on a nonideal terminal by providing two-character circumlocutions, made up of ASCII characters that you can type, for the characters that you can't type. These circumlocutions start with a 202/bit prefix 201/character; see below. For example, to use the Meta-A command, you could type C-A. On the hp9836, the key labelled tab sends C-and acts as a meta prefix. Both the NMODE 9-bit character set and ASCII have Control characters, but the 9-bit character set has more different ones. In ASCII, only letters and a few punctuation marks can be made into Control characters; in the 9-bit character set every character has a Control version. For example, we have Control-Space, Control-1, and Control-=. We also have two different characters Control-A and Control-a! But they always do the same thing in NMODE, so you can ignore the distinction between them, unless you are doing customization. In practice, you can forget all about the distinction between ASCII Control and NMODE Control, except to realize that NMODE uses some "Control" characters which ASCII keyboards cannot type. 201/Page 3-2 NMODE Manual (The 9-bit Command Character Set) We have given some command characters special names which we always capitalize. "<CR>" or "Return" stands for the carriage return character, code 015 (all character codes are in octal). Note that C-R means the character Control-R, never <CR>. "Rubout" is the character with code 177, labeled "Delete" on some keyboards. "Altmode" is the character with code 033, sometimes labeled "Escape". Other command characters with special names are Tab (code 011), Backspace (code 010), Linefeed (code 012), Space (code 040), Excl ("!", code 041), Comma (code 054), and Period (code 056). Control is represented in the numeric code for a character by 400, and Meta by 200; thus, Meta-Period is code 256 in the 9-bit character set. 202/3.2 Prefix Characters 201/A non-ideal keyboard can only send certain Control characters, and may completely lack the ability to send Meta characters. To use these commands on such keyboards, you need to use two-character circumlocutions starting with a 202/bit prefix 201/character which turns on the Control or Meta bit in the second character. The C-character turns on the Meta bit, so C-X can be used to type a Meta-X, and C-Control-O can be used to type a C-M-O. C-is known as the 202/Metizer201/. Other bit prefix characters are C-^ for Control, and C-Z for Control and Meta together. Thus, C-^ < is a way of typing a Control-<, and C-Z < can be used to type C-M-<. Because C-^ is awkward to type on most keyboards, we have tried to minimize the number of commands for which you will need it. There are two other prefix characters, Control-X and Meta-X which are used as the beginning of a large set of multi-character commands known as 202/C-X commands 201/and 202/M-X commands201/. C-X is not a bit prefix character; C-X A is not a circumlocution for any single character, and it must be typed as two characters on any terminal. C-X actually runs the function 203/c-x-prefix201/, while M-X runs 203/m-x-prefix201/. Two prefixes which are also used are ESC (203/esc-prefix201/) and C-] (203/lisp-prefix201/) (also called Lisp-). Each of these is used with a small set of single character suffixes. You can create new prefix characters when you customize. 202/3.3 Commands, Functions, and Variables 201/Most of the NMODE commands documented herein are members of this 9-bit character set. Others are pairs of characters from that set. However, NMODE doesn't really implement commands directly. Instead, NMODE is composed of 202/functions201/, which have long names such as 203/move-down-extending-command 201/and which are programs that perform the editing operations. 202/Commands 201/such as C-N are connected to functions through the 202/command dispatch table201/. When we say that C-N moves the cursor down a line, we are glossing over a distinction which is unimportant for ordinary use, but essential for customization: it is the function 203/move-down-extending-command 201/which knows how to move down a line, and C-N moves down a line 203/because 201/it is connected to that function. We usually ignore this subtlety to keep things simple. To give the extension-writer the information he needs, we state the name of the function which really does the work in parentheses after mentioning the command name. For example: "C-N (203/move-down-extending-command201/) moves the cursor down a line". In the NMODE wall chart, the function names are used as a form of very brief 201/NMODE Manual (Commands, Functions, and Variables) Page 3-3 documentation for the command characters. See Section 6.2 [Functions], page 2. While we are on the subject of customization information which you should not be frightened of, it's a good time to tell you about 202/variables201/. Often the description of a command will say "to change this, set the variable Mumble Foo". A variable is a name used to remember a value. NMODE contains many variables which are there so that you can change them if you want to customize. The variable's value is examined by some command, and changing the value makes the command behave differently. Until you are interested in customizing, you can ignore this information. When you are ready to be interested, read the basic information on variables, and then the information on individual variables will make sense. See Section 22.2 [Variables], page 4. 202/3.4 Notational Conventions for ASCII Characters 201/Control characters in files, your NMODE buffer, or PSL programs, are ordinary ASCII characters. The special 9-bit character set applies only to typing NMODE commands. ASCII contains the printing characters, rubout, and some control characters. Most ASCII control characters are represented in this manual as uparrow or caret followed by the corresponding non-control character: control-E is represented as ^E. Some ASCII characters have special names. These include tab (011), backspace (010), linefeed (012), Return (015), altmode (033), space (040), and rubout (177). To make it clear whether we are talking about a 9-bit character or an ASCII character, we capitalize names of 9-bit characters and leave names of ASCII characters in lower case. Note that the 9-bit characters Tab and Control-I are different, but the ASCII characters tab and control-I are the same. On the Dec-20 lines in files are separated by a sequence of two ASCII control characters, carriage return followed by linefeed. This sequence is called 202/CRLF201/. On the hp9836 lines in files are separated by other means. Normally, NMODE treats this two-character sequence as if it were a single character, a 202/line separator201/, linefeed. A Return which is not part of a CRLF is called 202/stray201/. NMODE usually treats them as part of the text of a line and displays them as ^Ms. Most control characters when present in the NMODE buffer are displayed with a caret; thus, ^A for ASCII ^A. Rubout is displayed as ^?, because by stretching the meaning of "control" it can be interpreted as ASCII control-?. A backspace is usually displayed as ^H since it is ASCII control-H, because most displays cannot do overprinting. |
Added psl-1983/3-1/doc/nmode/nm-characters.key version [19e1992056].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | .silent_index {C-} idx 3-1 .silent_index {M-} idx 3-1 .silent_index {Altmode} idx 3-2 .silent_index {Rubout} idx 3-2 .silent_index {Space} idx 3-2 .silent_index {Tab} idx 3-2 .silent_index {C-^} idx 3-2 .silent_index {C-X} idx 3-2 .silent_index {M-X} idx 3-2 .silent_index {C-]} idx 3-2 .silent_index {ESC} idx 3-2 .silent_index {tab} idx 3-3 .silent_index {backspace} idx 3-3 .silent_index {linefeed} idx 3-3 .silent_index {altmode} idx 3-3 .silent_index {space} idx 3-3 .silent_index {rubout} idx 3-3 |
Added psl-1983/3-1/doc/nmode/nm-characters.r version [d16d075fec].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-CHARACTERS manual @Chapter[Character Sets and Command Input Conventions] @node("characters") In this chapter we introduce the terminology and concepts used to talk about NMODE commands. NMODE is designed to be used with a kind of keyboard with two special shift keys which can type 512 different characters, instead of the 128 different characters which ordinary ASCII keyboards can send. The terminology of NMODE commands is formulated in terms of these shift keys. So that NMODE can be used on ASCII terminals, we provide two-character ASCII circumlocutions for the command characters which are not ASCII. @Section[The 9-bit Command Character Set] @index{control} @index{meta} @index{character set} @keyindex{C-} @keyindex{M-} @index{ASCII} NMODE is designed ideally to be used with terminals whose keyboards have a pair of shift keys, labeled "Control" and "Meta", either or both of which can be combined with any character that you can type. These shift keys produce @dfn[Control] characters and @dfn[Meta] characters, which are the editing commands of NMODE. We name each of these characters by prefixing "Control-" (or "C-"), "Meta-" (or "M-") or both to the basic character: thus, Meta-F or M-F is the character which is F typed with the Meta key held down. C-M-; is the Semicolon character with both the Control and Meta keys. Control in the NMODE command character set is not precisely the same as Control in the ASCII character set, but the general purpose is the same. There are 128 basic characters. Multiplied by the four possibilities of the Control and Meta keys, this makes 512 characters in the NMODE command character set. So it is called the 512-character set, to distinguish it from ASCII, which has only 128 characters. It is also called the @dfn[9-bit] character set because 9 bits are required to express a number from 0 to 511. Note that the 512-character set is used only for keyboard commands. Characters in files being edited with NMODE are ASCII characters. Sadly, most terminals do not have ideal NMODE keyboards. In fact, the only ideal keyboards are at MIT. On nonideal keyboards, the Control key is somewhat limited (it can only be combined with some characters, not with all), and the Meta key may not exist at all. We make it possible to use NMODE on a nonideal terminal by providing two-character circumlocutions, made up of ASCII characters that you can type, for the characters that you can't type. These circumlocutions start with a @dfn[bit prefix] character; see below. For example, to use the Meta-A command, you could type C-\ A. On the hp9836, the key labelled tab sends C-\ and acts as a meta prefix. Both the NMODE 9-bit character set and ASCII have Control characters, but the 9-bit character set has more different ones. In ASCII, only letters and a few punctuation marks can be made into Control characters; in the 9-bit character set every character has a Control version. For example, we have Control-Space, Control-1, and Control-=. We also have two different characters Control-A and Control-a! But they always do the same thing in NMODE, so you can ignore the distinction between them, unless you are doing customization. In practice, you can forget all about the distinction between ASCII Control and NMODE Control, except to realize that NMODE uses some "Control" characters which ASCII keyboards cannot type. @keyindex{Altmode} @keyindex{Rubout} @keyindex{Space} @index{@return1{}} We have given some command characters special names which we always capitalize. "@Return1{}" or "@return3{}" stands for the carriage return character, code 015 (all character codes are in octal). Note that C-R means the character Control-R, never @Return1{}. "Rubout" is the character with code 177, labeled "Delete" on some keyboards. "Altmode" is the character with code 033, sometimes labeled "Escape". Other command characters with special names are Tab (code 011), Backspace (code 010), Linefeed (code 012), Space (code 040), Excl ("!", code 041), Comma (code 054), and Period (code 056). Control is represented in the numeric code for a character by 400, and Meta by 200; thus, Meta-Period is code 256 in the 9-bit character set. @section[Prefix Characters] @node("prefix") @index{prefix characters} @keyIndex{Tab} @Keyindex{C-^} @Twenex{@index[C-Z]} @index{Metizer} A non-ideal keyboard can only send certain Control characters, and may completely lack the ability to send Meta characters. To use these commands on such keyboards, you need to use two-character circumlocutions starting with a @dfn[bit prefix] character which turns on the Control or Meta bit in the second character. The C-\ character turns on the Meta bit, so C-\ X can be used to type a Meta-X, and C-\ Control-O can be used to type a C-M-O. C-\ is known as the @dfn[Metizer]. Other bit prefix characters are C-^ for Control, and @CC[] for Control and Meta together. Thus, C-^ < is a way of typing a Control-<, and @CC[] < can be used to type C-M-<. Because C-^ is awkward to type on most keyboards, we have tried to minimize the number of commands for which you will need it. @fncindex{c-x-prefix} @keyindex{C-X} @fncindex{m-x-prefix} @keyindex{M-X} There are two other prefix characters, Control-X and Meta-X which are used as the beginning of a large set of multi-character commands known as @dfn[C-X commands] and @dfn[M-X commands]. C-X is not a bit prefix character; C-X A is not a circumlocution for any single character, and it must be typed as two characters on any terminal. C-X actually runs the function @fnc{c-x-prefix}, while M-X runs @fnc{m-x-prefix}. @keyindex{C-]} @fncindex{lisp-prefix} @keyindex{ESC} @fncindex{esc-prefix} Two prefixes which are also used are ESC (@fnc{esc-prefix}) and C-] (@fnc{lisp-prefix}) (also called Lisp-). Each of these is used with a small set of single character suffixes. You can create new prefix characters when you customize. @section[Commands, Functions, and Variables] @index{Functions} @index{Connected} @index{Customization} Most of the NMODE commands documented herein are members of this 9-bit character set. Others are pairs of characters from that set. However, NMODE doesn't really implement commands directly. Instead, NMODE is composed of @dfn[functions], which have long names such as @fnc{move-down-extending-command} and which are programs that perform the editing operations. @dfn[Commands] such as C-N are connected to functions through the @dfn[command dispatch table]. When we say that C-N moves the cursor down a line, we are glossing over a distinction which is unimportant for ordinary use, but essential for customization: it is the function @fnc{move-down-extending-command} which knows how to move down a line, and C-N moves down a line @xxi[because] it is connected to that function. We usually ignore this subtlety to keep things simple. To give the extension-writer the information he needs, we state the name of the function which really does the work in parentheses after mentioning the command name. For example: "C-N (@fnc{move-down-extending-command}) moves the cursor down a line". In the NMODE wall chart, the function names are used as a form of very brief documentation for the command characters. @Note("MMArcana" "Functions"). @index{Variables} While we are on the subject of customization information which you should not be frightened of, it's a good time to tell you about @dfn[variables]. Often the description of a command will say "to change this, set the variable Mumble Foo". A variable is a name used to remember a value. NMODE contains many variables which are there so that you can change them if you want to customize. The variable's value is examined by some command, and changing the value makes the command behave differently. Until you are interested in customizing, you can ignore this information. When you are ready to be interested, read the basic information on variables, and then the information on individual variables will make sense. @Note("Variables"). @section[Notational Conventions for ASCII Characters] @index{ASCII} @index{control} @index{uparrow} @index{caret} @index{^} Control characters in files, your NMODE buffer, or PSL programs, are ordinary ASCII characters. The special 9-bit character set applies only to typing NMODE commands. ASCII contains the printing characters, rubout, and some control characters. Most ASCII control characters are represented in this manual as uparrow or caret followed by the corresponding non-control character: control-E is represented as @CTL[E]. @keyindex{tab} @keyindex{backspace} @keyindex{linefeed} @index{@return1{}} @keyindex{altmode} @keyindex{space} @keyindex{rubout} Some ASCII characters have special names. These include tab (011), backspace (010), linefeed (012), @return3{} (015), altmode (033), space (040), and rubout (177). To make it clear whether we are talking about a 9-bit character or an ASCII character, we capitalize names of 9-bit characters and leave names of ASCII characters in lower case. Note that the 9-bit characters Tab and Control-I are different, but the ASCII characters tab and control-I are the same. @index{CRLF} @index{@Return1{}, stray} @index{Linefeed, stray} @index{line separator} On the Dec-20 lines in files are separated by a sequence of two ASCII control characters, carriage return followed by linefeed. This sequence is called @dfn[CRLF]. On the hp9836 lines in files are separated by other means. Normally, NMODE treats this two-character sequence as if it were a single character, a @dfn[line separator], linefeed. A @return3{} which is not part of a CRLF is called @dfn[stray]. NMODE usually treats them as part of the text of a line and displays them as ^Ms. @index{Backspace} @index{Control characters, display of} Most control characters when present in the NMODE buffer are displayed with a caret; thus, ^A for ASCII @CTL[A]. Rubout is displayed as ^?, because by stretching the meaning of "control" it can be interpreted as ASCII control-?. A backspace is usually displayed as ^H since it is ASCII control-H, because most displays cannot do overprinting. |
Added psl-1983/3-1/doc/nmode/nm-characters.topic version [a3d0836729].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | .silent_index {control} idx 3-1 .silent_index {meta} idx 3-1 .silent_index {character} idx 3-1 .silent_index {ASCII} idx 3-1 .silent_index {return1{}} idx 3-2 .silent_index {prefix} idx 3-2 .silent_index {C-Z} idx 3-2 .silent_index {Metizer} idx 3-2 .silent_index {Functions} idx 3-2 .silent_index {Connected} idx 3-2 .silent_index {Customization} idx 3-2 .silent_index {Variables} idx 3-3 .silent_index {ASCII} idx 3-3 .silent_index {control} idx 3-3 .silent_index {uparrow} idx 3-3 .silent_index {caret} idx 3-3 .silent_index {^} idx 3-3 .silent_index {return1{}} idx 3-3 .silent_index {CRLF} idx 3-3 .silent_index {Return1{},} idx 3-3 .silent_index {Linefeed,} idx 3-3 .silent_index {line} idx 3-3 .silent_index {Backspace} idx 3-3 .silent_index {Control} idx 3-3 |
Added psl-1983/3-1/doc/nmode/nm-cmd-index.contents version [7f1ae84b97].
> | 1 | contents_entry(0 26 {Command Index} 26-1) |
Added psl-1983/3-1/doc/nmode/nm-cmd-index.ibm version [0560f2a0c4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (21 March 1983) <PSL.NMODE-DOC>NM-CMD-INDEX.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Command Index) Page 26-1 202/26. Command Index 201/Append Next Kill . . . . . . . . . . . . . . . . . . . . 25-2 Append To Buffer . . . . . . . . . . . . . . . . . . . . 25-2 Append To File . . . . . . . . . . . . . . . . . . . . . 25-2 Apropos . . . . . . . . . . . . . . . . . . . . . . . . . 25-2 Argument Digit . . . . . . . . . . . . . . . . . . . . . 25-3 Auto Fill Mode . . . . . . . . . . . . . . . . . . . . . . 25-3 Back To Indentation . . . . . . . . . . . . . . . . . . . 25-4 Backward Kill Sentence . . . . . . . . . . . . . . . . . 25-4 Backward Paragraph . . . . . . . . . . . . . . . . . . . 25-4 Backward Sentence . . . . . . . . . . . . . . . . . . . . 25-4 Backward Up List . . . . . . . . . . . . . . . . . . . . 25-5 Buffer Browser . . . . . . . . . . . . . . . . . . . . . 25-5 Buffer Not Modified . . . . . . . . . . . . . . . . . . . 25-5 C-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 25-5 Center Line . . . . . . . . . . . . . . . . . . . . . . . 25-6 Copy Region . . . . . . . . . . . . . . . . . . . . . . . 25-6 Count Occurrences . . . . . . . . . . . . . . . . . . . . 25-6 Delete And Expunge File . . . . . . . . . . . . . . . . . 25-6 Delete Backward Hacking Tabs . . . . . . . . . . . . . . 25-7 Delete Blank Lines . . . . . . . . . . . . . . . . . . . . 25-7 Delete File . . . . . . . . . . . . . . . . . . . . . . . . 25-7 Delete Forward Character . . . . . . . . . . . . . . . . 25-7 Delete Horizontal Space . . . . . . . . . . . . . . . . . 25-8 Delete Indentation . . . . . . . . . . . . . . . . . . . . 25-8 Delete Matching Lines . . . . . . . . . . . . . . . . . . 25-8 Delete Non-Matching Lines . . . . . . . . . . . . . . . . 25-8 Dired . . . . . . . . . . . . . . . . . . . . . . . . . . 25-8 Down List . . . . . . . . . . . . . . . . . . . . . . . . 25-9 Edit Directory . . . . . . . . . . . . . . . . . . . . . . 25-9 End Of Defun . . . . . . . . . . . . . . . . . . . . . . 25-9 Esc Prefix . . . . . . . . . . . . . . . . . . . . . . . . 25-10 Exchange Point And Mark . . . . . . . . . . . . . . . . 25-10 Exchange Windows . . . . . . . . . . . . . . . . . . . . 25-10 Execute Buffer . . . . . . . . . . . . . . . . . . . . . . 25-10 Execute Defun . . . . . . . . . . . . . . . . . . . . . . 25-10 Execute File . . . . . . . . . . . . . . . . . . . . . . . 25-11 Execute Form . . . . . . . . . . . . . . . . . . . . . . 25-11 Exit Nmode . . . . . . . . . . . . . . . . . . . . . . . 25-11 Fill Comment . . . . . . . . . . . . . . . . . . . . . . . 25-11 Fill Paragraph . . . . . . . . . . . . . . . . . . . . . . 25-12 Fill Region . . . . . . . . . . . . . . . . . . . . . . . . 25-12 Find File . . . . . . . . . . . . . . . . . . . . . . . . . 25-12 Forward Paragraph . . . . . . . . . . . . . . . . . . . . 25-13 Forward Sentence . . . . . . . . . . . . . . . . . . . . 25-13 Forward Up List . . . . . . . . . . . . . . . . . . . . . 25-13 201/Page 26-2 NMODE Manual (Command Index) Get Register . . . . . . . . . . . . . . . . . . . . . . . 25-13 Grow Window . . . . . . . . . . . . . . . . . . . . . . . 25-14 Help Dispatch . . . . . . . . . . . . . . . . . . . . . . 25-14 Incremental Search . . . . . . . . . . . . . . . . . . . . 25-14 Indent New line . . . . . . . . . . . . . . . . . . . . . 25-14 Insert Buffer . . . . . . . . . . . . . . . . . . . . . . 25-15 Insert Closing bracket . . . . . . . . . . . . . . . . . . 25-15 Insert Comment . . . . . . . . . . . . . . . . . . . . . 25-15 Insert Date . . . . . . . . . . . . . . . . . . . . . . . 25-15 Insert File . . . . . . . . . . . . . . . . . . . . . . . . 25-16 Insert Kill Buffer . . . . . . . . . . . . . . . . . . . . 25-16 Insert Next Character . . . . . . . . . . . . . . . . . . 25-16 Kill Backward Form . . . . . . . . . . . . . . . . . . . 25-16 Kill Backward Word . . . . . . . . . . . . . . . . . . . 25-17 Kill Buffer . . . . . . . . . . . . . . . . . . . . . . . . 25-17 Kill Forward Form . . . . . . . . . . . . . . . . . . . . 25-17 Kill Forward Word . . . . . . . . . . . . . . . . . . . . 25-17 Kill Line . . . . . . . . . . . . . . . . . . . . . . . . . 25-18 Kill Region . . . . . . . . . . . . . . . . . . . . . . . . 25-18 Kill Sentence . . . . . . . . . . . . . . . . . . . . . . . 25-18 Kill Some Buffers . . . . . . . . . . . . . . . . . . . . 25-18 Lisp Abort . . . . . . . . . . . . . . . . . . . . . . . . 25-19 Lisp Backtrace . . . . . . . . . . . . . . . . . . . . . . 25-19 Lisp Continue . . . . . . . . . . . . . . . . . . . . . . 25-19 Lisp Help . . . . . . . . . . . . . . . . . . . . . . . . 25-19 Lisp Indent Region . . . . . . . . . . . . . . . . . . . . 25-20 Lisp Indent sexpr . . . . . . . . . . . . . . . . . . . . 25-20 Lisp Mode . . . . . . . . . . . . . . . . . . . . . . . . 25-20 Lisp Prefix . . . . . . . . . . . . . . . . . . . . . . . 25-20 Lisp Quit . . . . . . . . . . . . . . . . . . . . . . . . 25-21 Lisp Retry . . . . . . . . . . . . . . . . . . . . . . . . 25-21 Lisp Tab . . . . . . . . . . . . . . . . . . . . . . . . . 25-21 Lowercase Region . . . . . . . . . . . . . . . . . . . . 25-21 Lowercase Word . . . . . . . . . . . . . . . . . . . . . 25-22 M-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 25-22 Make Parens . . . . . . . . . . . . . . . . . . . . . . . 25-22 Mark Beginning . . . . . . . . . . . . . . . . . . . . . 25-22 Mark Defun . . . . . . . . . . . . . . . . . . . . . . . 25-23 Mark End . . . . . . . . . . . . . . . . . . . . . . . . 25-23 Mark Form . . . . . . . . . . . . . . . . . . . . . . . . 25-23 Mark Paragraph . . . . . . . . . . . . . . . . . . . . . 25-23 Mark Whole Buffer . . . . . . . . . . . . . . . . . . . . 25-24 Mark Word . . . . . . . . . . . . . . . . . . . . . . . . 25-24 Move Backward Character . . . . . . . . . . . . . . . . 25-24 Move Backward Defun . . . . . . . . . . . . . . . . . . 25-24 Move Backward Form . . . . . . . . . . . . . . . . . . . 25-25 Move Backward List . . . . . . . . . . . . . . . . . . . 25-25 Move Backward Word . . . . . . . . . . . . . . . . . . . 25-25 201/NMODE Manual (Command Index) Page 26-3 Move Down . . . . . . . . . . . . . . . . . . . . . . . . 25-25 Move Down Extending . . . . . . . . . . . . . . . . . . 25-26 Move Forward Character . . . . . . . . . . . . . . . . . 25-26 Move Forward Form . . . . . . . . . . . . . . . . . . . 25-26 Move Forward List . . . . . . . . . . . . . . . . . . . . 25-26 Move Forward Word . . . . . . . . . . . . . . . . . . . 25-27 Move Over Paren . . . . . . . . . . . . . . . . . . . . . 25-27 Move To Buffer End . . . . . . . . . . . . . . . . . . . 25-27 Move To Buffer Start . . . . . . . . . . . . . . . . . . 25-27 Move To End Of Line . . . . . . . . . . . . . . . . . . 25-28 Move To Screen Edge . . . . . . . . . . . . . . . . . . 25-28 Move To Start Of Line . . . . . . . . . . . . . . . . . . 25-28 Move Up . . . . . . . . . . . . . . . . . . . . . . . . . 25-28 Negative Argument . . . . . . . . . . . . . . . . . . . . 25-29 Next Screen . . . . . . . . . . . . . . . . . . . . . . . 25-29 Nmode Abort . . . . . . . . . . . . . . . . . . . . . . . 25-29 Nmode Exit To Superior . . . . . . . . . . . . . . . . . 25-29 Nmode Full Refresh . . . . . . . . . . . . . . . . . . . 25-29 Nmode Gc . . . . . . . . . . . . . . . . . . . . . . . . 25-30 Nmode Invert Video . . . . . . . . . . . . . . . . . . . 25-30 Nmode Refresh . . . . . . . . . . . . . . . . . . . . . . 25-30 One Window . . . . . . . . . . . . . . . . . . . . . . . 25-30 Open Line . . . . . . . . . . . . . . . . . . . . . . . . 25-30 Other Window . . . . . . . . . . . . . . . . . . . . . . 25-31 Prepend To File . . . . . . . . . . . . . . . . . . . . . 25-31 Previous Screen . . . . . . . . . . . . . . . . . . . . . 25-31 Put Register . . . . . . . . . . . . . . . . . . . . . . . 25-31 Query Replace . . . . . . . . . . . . . . . . . . . . . . 25-31 Rename Buffer . . . . . . . . . . . . . . . . . . . . . . 25-32 Replace String . . . . . . . . . . . . . . . . . . . . . . 25-32 Reposition Window . . . . . . . . . . . . . . . . . . . . 25-32 Return . . . . . . . . . . . . . . . . . . . . . . . . . . 25-33 Reverse Search . . . . . . . . . . . . . . . . . . . . . 25-33 Revert File . . . . . . . . . . . . . . . . . . . . . . . 25-33 Save All Files . . . . . . . . . . . . . . . . . . . . . . 25-33 Save File . . . . . . . . . . . . . . . . . . . . . . . . 25-33 Scroll Other Window . . . . . . . . . . . . . . . . . . . 25-34 Scroll Window Down Line . . . . . . . . . . . . . . . . . 25-34 Scroll Window Down Page . . . . . . . . . . . . . . . . . 25-34 Scroll Window Left . . . . . . . . . . . . . . . . . . . . 25-34 Scroll Window Right . . . . . . . . . . . . . . . . . . . 25-34 Scroll Window Up Line . . . . . . . . . . . . . . . . . . 25-35 Scroll Window Up Page . . . . . . . . . . . . . . . . . . 25-35 Select Buffer . . . . . . . . . . . . . . . . . . . . . . 25-35 Select Previous Buffer . . . . . . . . . . . . . . . . . . 25-35 Set Fill Column . . . . . . . . . . . . . . . . . . . . . 25-36 Set Fill Prefix . . . . . . . . . . . . . . . . . . . . . . 25-36 201/Page 26-4 NMODE Manual (Command Index) Set Goal Column . . . . . . . . . . . . . . . . . . . . . 25-36 Set Key . . . . . . . . . . . . . . . . . . . . . . . . . 25-36 Set Mark . . . . . . . . . . . . . . . . . . . . . . . . . 25-37 Set Visited Filename . . . . . . . . . . . . . . . . . . . 25-37 Split Line . . . . . . . . . . . . . . . . . . . . . . . . 25-37 Start Scripting . . . . . . . . . . . . . . . . . . . . . . 25-37 Start Timing . . . . . . . . . . . . . . . . . . . . . . . 25-38 Stop Scripting . . . . . . . . . . . . . . . . . . . . . . 25-38 Stop Timing . . . . . . . . . . . . . . . . . . . . . . . 25-38 Tab To Tab Stop . . . . . . . . . . . . . . . . . . . . 25-38 Text Mode . . . . . . . . . . . . . . . . . . . . . . . . 25-39 Transpose Characters . . . . . . . . . . . . . . . . . . 25-39 Transpose Forms . . . . . . . . . . . . . . . . . . . . . 25-39 Transpose Lines . . . . . . . . . . . . . . . . . . . . . 25-39 Transpose Regions . . . . . . . . . . . . . . . . . . . . 25-40 Transpose Words . . . . . . . . . . . . . . . . . . . . . 25-40 Two Windows . . . . . . . . . . . . . . . . . . . . . . . 25-40 Undelete File . . . . . . . . . . . . . . . . . . . . . . . 25-40 Universal Argument . . . . . . . . . . . . . . . . . . . 25-41 Unkill Previous . . . . . . . . . . . . . . . . . . . . . 25-41 Upcase Digit . . . . . . . . . . . . . . . . . . . . . . . 25-41 Uppercase Initial . . . . . . . . . . . . . . . . . . . . . 25-41 Uppercase Region . . . . . . . . . . . . . . . . . . . . 25-42 Uppercase Word . . . . . . . . . . . . . . . . . . . . . 25-42 View Two Windows . . . . . . . . . . . . . . . . . . . . 25-42 Visit File . . . . . . . . . . . . . . . . . . . . . . . . 25-42 Visit In Other Window . . . . . . . . . . . . . . . . . . 25-42 What Cursor Position . . . . . . . . . . . . . . . . . . . 25-43 Write File . . . . . . . . . . . . . . . . . . . . . . . . 25-43 Write Region . . . . . . . . . . . . . . . . . . . . . . . 25-43 Write Screen Photo . . . . . . . . . . . . . . . . . . . . 25-43 Yank Last Output . . . . . . . . . . . . . . . . . . . . 25-44 |
Added psl-1983/3-1/doc/nmode/nm-commands.command version [484ccffe43].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Append Next Kill} idx 27-2 .silent_index {Append To Buffer} idx 27-2 .silent_index {Append To File} idx 27-2 .silent_index {Apropos} idx 27-2 .silent_index {Argument Digit} idx 27-3 .silent_index {Auto Fill Mode} idx 27-3 .silent_index {Back To Indentation} idx 27-4 .silent_index {Backward Kill Sentence} idx 27-4 .silent_index {Backward Paragraph} idx 27-4 .silent_index {Backward Sentence} idx 27-4 .silent_index {Backward Up List} idx 27-5 .silent_index {Buffer Browser} idx 27-5 .silent_index {Buffer Not Modified} idx 27-5 .silent_index {C-X Prefix} idx 27-5 .silent_index {Center Line} idx 27-6 .silent_index {Copy Region} idx 27-6 .silent_index {Count Occurrences} idx 27-6 .silent_index {Delete And Expunge File} idx 27-6 .silent_index {Delete Backward Character} idx 27-7 .silent_index {Delete Backward Hacking Tabs} idx 27-7 .silent_index {Delete Blank Lines} idx 27-7 .silent_index {Delete File} idx 27-7 .silent_index {Delete Forward Character} idx 27-8 .silent_index {Delete Horizontal Space} idx 27-8 .silent_index {Delete Indentation} idx 27-8 .silent_index {Delete Matching Lines} idx 27-8 .silent_index {Delete Non-Matching Lines} idx 27-8 .silent_index {Dired} idx 27-9 .silent_index {Down List} idx 27-9 .silent_index {Edit Directory} idx 27-9 .silent_index {End Of Defun} idx 27-10 .silent_index {Esc Prefix} idx 27-10 .silent_index {Exchange Point And Mark} idx 27-10 .silent_index {Exchange Windows} idx 27-10 .silent_index {Execute Buffer} idx 27-10 .silent_index {Execute Defun} idx 27-11 .silent_index {Execute File} idx 27-11 .silent_index {Execute Form} idx 27-11 .silent_index {Exit Nmode} idx 27-11 .silent_index {Fill Comment} idx 27-12 .silent_index {Fill Paragraph} idx 27-12 .silent_index {Fill Region} idx 27-12 .silent_index {Find File} idx 27-13 .silent_index {Forward Paragraph} idx 27-13 .silent_index {Forward Sentence} idx 27-13 .silent_index {Forward Up List} idx 27-13 .silent_index {Get Register} idx 27-14 .silent_index {Grow Window} idx 27-14 .silent_index {Help Dispatch} idx 27-14 .silent_index {Incremental Search} idx 27-14 .silent_index {Indent New line} idx 27-15 .silent_index {Indent Region} idx 27-15 .silent_index {Insert Buffer} idx 27-15 .silent_index {Insert Closing bracket} idx 27-15 .silent_index {Insert Comment} idx 27-16 .silent_index {Insert Date} idx 27-16 .silent_index {Insert File} idx 27-16 .silent_index {Insert Kill Buffer} idx 27-16 .silent_index {Insert Next Character} idx 27-17 .silent_index {Kill Backward Form} idx 27-17 .silent_index {Kill Backward Word} idx 27-17 .silent_index {Kill Buffer} idx 27-17 .silent_index {Kill Forward Form} idx 27-18 .silent_index {Kill Forward Word} idx 27-18 .silent_index {Kill Line} idx 27-18 .silent_index {Kill Region} idx 27-18 .silent_index {Kill Sentence} idx 27-19 .silent_index {Kill Some Buffers} idx 27-19 .silent_index {Lisp Abort} idx 27-19 .silent_index {Lisp Backtrace} idx 27-19 .silent_index {Lisp Continue} idx 27-20 .silent_index {Lisp Help} idx 27-20 .silent_index {Lisp Indent Region} idx 27-20 .silent_index {Lisp Indent sexpr} idx 27-20 .silent_index {Lisp Mode} idx 27-21 .silent_index {Lisp Prefix} idx 27-21 .silent_index {Lisp Quit} idx 27-21 .silent_index {Lisp Retry} idx 27-21 .silent_index {Lisp Tab} idx 27-22 .silent_index {Lowercase Region} idx 27-22 .silent_index {Lowercase Word} idx 27-22 .silent_index {M-X Prefix} idx 27-22 .silent_index {Make Parens} idx 27-23 .silent_index {Mark Beginning} idx 27-23 .silent_index {Mark Defun} idx 27-23 .silent_index {Mark End} idx 27-23 .silent_index {Mark Form} idx 27-24 .silent_index {Mark Paragraph} idx 27-24 .silent_index {Mark Whole Buffer} idx 27-24 .silent_index {Mark Word} idx 27-24 .silent_index {Move Backward Character} idx 27-25 .silent_index {Move Backward Defun} idx 27-25 .silent_index {Move Backward Form} idx 27-25 .silent_index {Move Backward List} idx 27-25 .silent_index {Move Backward Word} idx 27-26 .silent_index {Move Down} idx 27-26 .silent_index {Move Down Extending} idx 27-26 .silent_index {Move Forward Character} idx 27-26 .silent_index {Move Forward Form} idx 27-27 .silent_index {Move Forward List} idx 27-27 .silent_index {Move Forward Word} idx 27-27 .silent_index {Move Over Paren} idx 27-27 .silent_index {Move To Buffer End} idx 27-28 .silent_index {Move To Buffer Start} idx 27-28 .silent_index {Move To End Of Line} idx 27-28 .silent_index {Move To Screen Edge} idx 27-28 .silent_index {Move To Start Of Line} idx 27-28 .silent_index {Move Up} idx 27-29 .silent_index {Negative Argument} idx 27-29 .silent_index {Next Screen} idx 27-29 .silent_index {Nmode Abort} idx 27-29 .silent_index {Nmode Exit To Superior} idx 27-29 .silent_index {Nmode Full Refresh} idx 27-30 .silent_index {Nmode Gc} idx 27-30 .silent_index {Nmode Invert Video} idx 27-30 .silent_index {Nmode Refresh} idx 27-30 .silent_index {One Window} idx 27-30 .silent_index {Open Line} idx 27-31 .silent_index {Other Window} idx 27-31 .silent_index {Prepend To File} idx 27-31 .silent_index {Previous Screen} idx 27-31 .silent_index {Put Register} idx 27-32 .silent_index {Query Replace} idx 27-32 .silent_index {Rename Buffer} idx 27-32 .silent_index {Replace String} idx 27-33 .silent_index {Reposition Window} idx 27-33 .silent_index {Return} idx 27-33 .silent_index {Reverse Search} idx 27-33 .silent_index {Revert File} idx 27-33 .silent_index {Save All Files} idx 27-34 .silent_index {Save File} idx 27-34 .silent_index {Scroll Other Window} idx 27-34 .silent_index {Scroll Window Down Line} idx 27-34 .silent_index {Scroll Window Down Page} idx 27-34 .silent_index {Scroll Window Left} idx 27-35 .silent_index {Scroll Window Right} idx 27-35 .silent_index {Scroll Window Up Line} idx 27-35 .silent_index {Scroll Window Up Page} idx 27-35 .silent_index {Select Buffer} idx 27-35 .silent_index {Select Previous Buffer} idx 27-36 .silent_index {Set Fill Column} idx 27-36 .silent_index {Set Fill Prefix} idx 27-36 .silent_index {Set Goal Column} idx 27-36 .silent_index {Set Key} idx 27-37 .silent_index {Set Mark} idx 27-37 .silent_index {Set Visited Filename} idx 27-37 .silent_index {Split Line} idx 27-37 .silent_index {Start Scripting} idx 27-38 .silent_index {Start Timing} idx 27-38 .silent_index {Stop Scripting} idx 27-38 .silent_index {Stop Timing} idx 27-38 .silent_index {Tab To Tab Stop} idx 27-39 .silent_index {Text Mode} idx 27-39 .silent_index {Transpose Characters} idx 27-39 .silent_index {Transpose Forms} idx 27-39 .silent_index {Transpose Lines} idx 27-40 .silent_index {Transpose Regions} idx 27-40 .silent_index {Transpose Words} idx 27-40 .silent_index {Two Windows} idx 27-40 .silent_index {Undelete File} idx 27-41 .silent_index {Universal Argument} idx 27-41 .silent_index {Unkill Previous} idx 27-41 .silent_index {Upcase Digit} idx 27-41 .silent_index {Uppercase Initial} idx 27-42 .silent_index {Uppercase Region} idx 27-42 .silent_index {Uppercase Word} idx 27-42 .silent_index {View Two Windows} idx 27-42 .silent_index {Visit File} idx 27-42 .silent_index {Visit In Other Window} idx 27-43 .silent_index {What Cursor Position} idx 27-43 .silent_index {Write File} idx 27-43 .silent_index {Write Region} idx 27-43 .silent_index {Write Screen} idx 27-44 .silent_index {Yank Last Output} idx 27-44 |
Added psl-1983/3-1/doc/nmode/nm-commands.contents version [772a387c37].
> | 1 | contents_entry(0 27 {Command Descriptions} 27-1) |
Added psl-1983/3-1/doc/nmode/nm-commands.function version [7249adb733].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {append-next-kill-command} idx 27-2 .silent_index {append-to-buffer-command} idx 27-2 .silent_index {append-to-file-command} idx 27-2 .silent_index {apropos-command} idx 27-2 .silent_index {argument-digit} idx 27-3 .silent_index {auto-fill-mode-command} idx 27-3 .silent_index {back-to-indentation-command} idx 27-4 .silent_index {backward-kill-sentence-command} idx 27-4 .silent_index {backward-paragraph-command} idx 27-4 .silent_index {backward-sentence-command} idx 27-4 .silent_index {backward-up-list-command} idx 27-5 .silent_index {buffer-browser-command} idx 27-5 .silent_index {buffer-not-modified-command} idx 27-5 .silent_index {c-x-prefix} idx 27-5 .silent_index {center-line-command} idx 27-6 .silent_index {copy-region} idx 27-6 .silent_index {count-occurrences-command} idx 27-6 .silent_index {delete-and-expunge-file-command} idx 27-6 .silent_index {delete-backward-character-command} idx 27-7 .silent_index {delete-backward-hacking-tabs-command} idx 27-7 .silent_index {delete-blank-lines-command} idx 27-7 .silent_index {delete-file-command} idx 27-7 .silent_index {delete-forward-character-command} idx 27-8 .silent_index {delete-horizontal-space-command} idx 27-8 .silent_index {delete-indentation-command} idx 27-8 .silent_index {delete-matching-lines-command} idx 27-8 .silent_index {delete-non-matching-lines-command} idx 27-8 .silent_index {dired-command} idx 27-9 .silent_index {down-list-command} idx 27-9 .silent_index {edit-directory-command} idx 27-9 .silent_index {end-of-defun-command} idx 27-10 .silent_index {esc-prefix} idx 27-10 .silent_index {exchange-point-and-mark} idx 27-10 .silent_index {exchange-windows-command} idx 27-10 .silent_index {execute-buffer-command} idx 27-10 .silent_index {execute-defun-command} idx 27-11 .silent_index {execute-file-command} idx 27-11 .silent_index {execute-form-command} idx 27-11 .silent_index {exit-nmode} idx 27-11 .silent_index {fill-comment-command} idx 27-12 .silent_index {fill-paragraph-command} idx 27-12 .silent_index {fill-region-command} idx 27-12 .silent_index {find-file-command} idx 27-13 .silent_index {forward-paragraph-command} idx 27-13 .silent_index {forward-sentence-command} idx 27-13 .silent_index {forward-up-list-command} idx 27-13 .silent_index {get-register-command} idx 27-14 .silent_index {grow-window-command} idx 27-14 .silent_index {help-dispatch} idx 27-14 .silent_index {incremental-search-command} idx 27-14 .silent_index {indent-new-line-command} idx 27-15 .silent_index {indent-region-command} idx 27-15 .silent_index {insert-buffer-command} idx 27-15 .silent_index {insert-closing-bracket} idx 27-15 .silent_index {insert-comment-command} idx 27-16 .silent_index {insert-date-command} idx 27-16 .silent_index {insert-file-command} idx 27-16 .silent_index {insert-kill-buffer} idx 27-16 .silent_index {insert-next-character-command} idx 27-17 .silent_index {kill-backward-form-command} idx 27-17 .silent_index {kill-backward-word-command} idx 27-17 .silent_index {kill-buffer-command} idx 27-17 .silent_index {kill-forward-form-command} idx 27-18 .silent_index {kill-forward-word-command} idx 27-18 .silent_index {kill-line} idx 27-18 .silent_index {kill-region} idx 27-18 .silent_index {kill-sentence-command} idx 27-19 .silent_index {kill-some-buffers-command} idx 27-19 .silent_index {lisp-abort-command} idx 27-19 .silent_index {lisp-backtrace-command} idx 27-19 .silent_index {lisp-continue-command} idx 27-20 .silent_index {lisp-help-command} idx 27-20 .silent_index {lisp-indent-region-command} idx 27-20 .silent_index {lisp-indent-sexpr} idx 27-20 .silent_index {lisp-mode-command} idx 27-21 .silent_index {lisp-prefix} idx 27-21 .silent_index {lisp-quit-command} idx 27-21 .silent_index {lisp-retry-command} idx 27-21 .silent_index {lisp-tab-command} idx 27-22 .silent_index {lowercase-region-command} idx 27-22 .silent_index {lowercase-word-command} idx 27-22 .silent_index {m-x-prefix} idx 27-22 .silent_index {make-parens-command} idx 27-23 .silent_index {mark-beginning-command} idx 27-23 .silent_index {mark-defun-command} idx 27-23 .silent_index {mark-end-command} idx 27-23 .silent_index {mark-form-command} idx 27-24 .silent_index {mark-paragraph-command} idx 27-24 .silent_index {mark-whole-buffer-command} idx 27-24 .silent_index {mark-word-command} idx 27-24 .silent_index {move-backward-character-command} idx 27-25 .silent_index {move-backward-defun-command} idx 27-25 .silent_index {move-backward-form-command} idx 27-25 .silent_index {move-backward-list-command} idx 27-25 .silent_index {move-backward-word-command} idx 27-26 .silent_index {move-down-command} idx 27-26 .silent_index {move-down-extending-command} idx 27-26 .silent_index {move-forward-character-command} idx 27-26 .silent_index {move-forward-form-command} idx 27-27 .silent_index {move-forward-list-command} idx 27-27 .silent_index {move-forward-word-command} idx 27-27 .silent_index {move-over-paren-command} idx 27-27 .silent_index {move-to-buffer-end-command} idx 27-28 .silent_index {move-to-buffer-start-command} idx 27-28 .silent_index {move-to-end-of-line-command} idx 27-28 .silent_index {move-to-screen-edge-command} idx 27-28 .silent_index {move-to-start-of-line-command} idx 27-28 .silent_index {move-up-command} idx 27-29 .silent_index {negative-argument} idx 27-29 .silent_index {next-screen-command} idx 27-29 .silent_index {nmode-abort-command} idx 27-29 .silent_index {nmode-exit-to-superior} idx 27-29 .silent_index {nmode-full-refresh} idx 27-30 .silent_index {nmode-gc} idx 27-30 .silent_index {nmode-invert-video} idx 27-30 .silent_index {nmode-refresh-command} idx 27-30 .silent_index {one-window-command} idx 27-30 .silent_index {open-line-command} idx 27-31 .silent_index {other-window-command} idx 27-31 .silent_index {prepend-to-file-command} idx 27-31 .silent_index {previous-screen-command} idx 27-31 .silent_index {put-register-command} idx 27-32 .silent_index {query-replace-command} idx 27-32 .silent_index {rename-buffer-command} idx 27-32 .silent_index {replace-string-command} idx 27-33 .silent_index {reposition-window-command} idx 27-33 .silent_index {return-command} idx 27-33 .silent_index {reverse-search-command} idx 27-33 .silent_index {revert-file-command} idx 27-33 .silent_index {save-all-files-command} idx 27-34 .silent_index {save-file-command} idx 27-34 .silent_index {scroll-other-window-command} idx 27-34 .silent_index {scroll-window-down-line-command} idx 27-34 .silent_index {scroll-window-down-page-command} idx 27-34 .silent_index {scroll-window-left-command} idx 27-35 .silent_index {scroll-window-right-command} idx 27-35 .silent_index {scroll-window-up-line-command} idx 27-35 .silent_index {scroll-window-up-page-command} idx 27-35 .silent_index {select-buffer-command} idx 27-35 .silent_index {select-previous-buffer-command} idx 27-36 .silent_index {set-fill-column-command} idx 27-36 .silent_index {set-fill-prefix-command} idx 27-36 .silent_index {set-goal-column-command} idx 27-36 .silent_index {set-key-command} idx 27-37 .silent_index {set-mark-command} idx 27-37 .silent_index {set-visited-filename-command} idx 27-37 .silent_index {split-line-command} idx 27-37 .silent_index {start-scripting-command} idx 27-38 .silent_index {start-timing-command} idx 27-38 .silent_index {stop-scripting-command} idx 27-38 .silent_index {stop-timing-command} idx 27-38 .silent_index {tab-to-tab-stop-command} idx 27-39 .silent_index {text-mode-command} idx 27-39 .silent_index {transpose-characters-command} idx 27-39 .silent_index {transpose-forms} idx 27-39 .silent_index {transpose-lines} idx 27-40 .silent_index {transpose-regions} idx 27-40 .silent_index {transpose-words} idx 27-40 .silent_index {two-windows-command} idx 27-40 .silent_index {undelete-file-command} idx 27-41 .silent_index {universal-argument} idx 27-41 .silent_index {unkill-previous} idx 27-41 .silent_index {upcase-digit-command} idx 27-41 .silent_index {uppercase-initial-command} idx 27-42 .silent_index {uppercase-region-command} idx 27-42 .silent_index {uppercase-word-command} idx 27-42 .silent_index {view-two-windows-command} idx 27-42 .silent_index {visit-file-command} idx 27-42 .silent_index {visit-in-other-window-command} idx 27-43 .silent_index {what-cursor-position-command} idx 27-43 .silent_index {write-file-command} idx 27-43 .silent_index {write-region-command} idx 27-43 .silent_index {write-screen-command} idx 27-44 .silent_index {yank-last-output-command} idx 27-44 |
Added psl-1983/3-1/doc/nmode/nm-commands.ibm version [3cf478df63].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-COMMANDS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Command Descriptions) Page 27-1 202/27. Command Descriptions 201/This section defines the basic NMODE commands. Each command description includes the following information: 203/command 201/A descriptive name of the command. 203/function 201/The name of the Lisp function that implements the command. 203/key 201/The logical keys on the keyboard that normally have this command attached to them. A 203/logical key 201/includes ordinary keys such as Tab or Rubout, 203/shifted 201/keys using the 202/Control 201/and/or 202/Meta 201/modifiers (e.g., C-F, M-F, and C-M-F), 203/prefixed commands 201/using C-X, C-], or Escape (e.g., C-X C-F, C-] E, and Esc-L), and 203/extended commands 201/using 202/Meta-X 201/(e.g., M-X Delete Matching Lines). 203/action type 201/One of a number of descriptive terms that categorize the behavior of commands. Action types are defined in Chapter 24. 203/mode 201/Some commands are defined only in certain modes. If present, this attribute specifies the mode or modes in which the command is normally defined. 203/topic 201/A keyword that describes the command. Topics are listed in the Topic Index, Chapter 30. 201/Page 27-2 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append Next Kill 201/Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To Buffer 201/Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To File 201/Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Apropos 201/Function: apropos-command Key: M-X Apropos Key: Esc-_ Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. The functions are displayed using a documentation browser, which allows the user to view additional information on each function or further filter the list of displayed functions by matching on addtional strings. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-3 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Argument Digit 201/Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Auto Fill Mode 201/Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-4 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Back To Indentation 201/Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Kill Sentence 201/Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Paragraph 201/Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Sentence 201/Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-5 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Up List 201/Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Browser 201/Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Not Modified 201/Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: C-X Prefix 201/Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-6 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Center Line 201/Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Copy Region 201/Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Count Occurrences 201/Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete And Expunge File 201/Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-7 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Backward Character 201/Function: delete-backward-character-command Key: BACKSPACE Key: RUBOUT Mode: Text Action Type: Remove Delete character before point. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Backward Hacking Tabs 201/Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Blank Lines 201/Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete File 201/Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-8 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Forward Character 201/Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Horizontal Space 201/Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Indentation 201/Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Matching Lines 201/Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Non-Matching Lines 201/Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-9 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Dired 201/Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Down List 201/Function: down-list-command Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. In other words, move forward past the next open bracket, unless there is in an intervening close bracket. With a positive command argument, move forward down that many levels. With a negative command argument, move backward down that many levels. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Edit Directory 201/Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-10 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: End Of Defun 201/Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Esc Prefix 201/Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Point And Mark 201/Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Windows 201/Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Buffer 201/Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 201/NMODE Manual (Command Descriptions) Page 27-11 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Defun 201/Function: execute-defun-command Key: Lisp-D Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Causes the Lisp reader to read and evaluate the current defun. If there is no current defin, the Lisp reader will read a form starting at the current location. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute File 201/Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Form 201/Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exit Nmode 201/Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-12 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Comment 201/Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Paragraph 201/Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Region 201/Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-13 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Find File 201/Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Paragraph 201/Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Sentence 201/Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Up List 201/Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-14 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Get Register 201/Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Grow Window 201/Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Help Dispatch 201/Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Incremental Search 201/Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-15 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Indent New line 201/Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Indent Region 201/Function: indent-region-command Key: C-M-\ Mode: Text Indent all lines between point and mark. With argument, indents each line to exactly that column. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Buffer 201/Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Closing bracket 201/Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-16 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Comment 201/Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Date 201/Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert File 201/Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Kill Buffer 201/Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-17 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Next Character 201/Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Form 201/Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Word 201/Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Buffer 201/Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-18 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Form 201/Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Word 201/Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Line 201/Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Region 201/Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-19 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Sentence 201/Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Some Buffers 201/Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Abort 201/Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Backtrace 201/Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-20 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Continue 201/Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Help 201/Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent Region 201/Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent sexpr 201/Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-21 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Mode 201/Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Prefix 201/Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Quit 201/Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Retry 201/Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-22 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Tab 201/Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Region 201/Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Word 201/Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: M-X Prefix 201/Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-23 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Make Parens 201/Function: make-parens-command Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point after the (. Also make a space before the (, if appropriate. With argument, put the ) after the specified number of already existing forms. Thus, with argument 1, puts extra parens around the following form. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Beginning 201/Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Defun 201/Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark End 201/Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-24 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Form 201/Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Paragraph 201/Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Whole Buffer 201/Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Word 201/Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-25 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Character 201/Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Defun 201/Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Form 201/Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward List 201/Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-26 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Word 201/Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down 201/Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down Extending 201/Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Character 201/Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-27 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Form 201/Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward List 201/Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Word 201/Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Over Paren 201/Function: move-over-paren-command Key: M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move forward past the next closing bracket. If a positive command argument is given, move forward past that many closing brackets. Delete all indentation before the first closing bracket passed. After the last closing bracket passed, insert an end-of-line and then indent the new line according to Lisp. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-28 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer End 201/Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer Start 201/Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To End Of Line 201/Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Screen Edge 201/Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Start Of Line 201/Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-29 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Up 201/Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Negative Argument 201/Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Next Screen 201/Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Abort 201/Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Exit To Superior 201/Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-30 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Full Refresh 201/Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Gc 201/Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Invert Video 201/Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Refresh 201/Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: One Window 201/Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-31 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Open Line 201/Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Other Window 201/Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Prepend To File 201/Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Previous Screen 201/Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-32 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Put Register 201/Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Query Replace 201/Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout or Backspace => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. C-L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. Anything else exits and is reread. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Rename Buffer 201/Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. The buffer name is automatically converted to upper case. An error is reported if the user provides the name of another existing buffer. The buffers MAIN and OUTPUT may not be renamed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-33 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Replace String 201/Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reposition Window 201/Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Return 201/Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reverse Search 201/Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Revert File 201/Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-34 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save All Files 201/Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save File 201/Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Other Window 201/Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Line 201/Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Page 201/Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-35 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Left 201/Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Right 201/Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Line 201/Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Page 201/Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Buffer 201/Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-36 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Previous Buffer 201/Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Column 201/Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Prefix 201/Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Goal Column 201/Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-37 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Key 201/Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Mark 201/Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Visited Filename 201/Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing or reading any file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. If possible, the new name will be adjusted to reflect an actual file name, as if the specified file were visited. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Split Line 201/Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-38 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Scripting 201/Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Timing 201/Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Scripting 201/Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Timing 201/Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-39 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Tab To Tab Stop 201/Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Text Mode 201/Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Characters 201/Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Forms 201/Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-40 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Lines 201/Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Regions 201/Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Words 201/Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Two Windows 201/Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-41 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Undelete File 201/Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Universal Argument 201/Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Unkill Previous 201/Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Upcase Digit 201/Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-42 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Initial 201/Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Region 201/Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Word 201/Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: View Two Windows 201/Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit File 201/Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual (Command Descriptions) Page 27-43 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit In Other Window 201/Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: What Cursor Position 201/Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write File 201/Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Region 201/Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 27-44 NMODE Manual (Command Descriptions) 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Screen 201/Function: write-screen-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Yank Last Output 201/Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ |
Added psl-1983/3-1/doc/nmode/nm-commands.key version [c69ddace35].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {C-M-W} idx 27-2 .silent_index {C-X A} idx 27-2 .silent_index {M-X Append To File} idx 27-2 .silent_index {M-X Apropos} idx 27-2 .silent_index {Esc-_} idx 27-2 .silent_index {C-0} idx 27-3 .silent_index {C-1} idx 27-3 .silent_index {C-2} idx 27-3 .silent_index {C-3} idx 27-3 .silent_index {C-4} idx 27-3 .silent_index {C-5} idx 27-3 .silent_index {C-6} idx 27-3 .silent_index {C-7} idx 27-3 .silent_index {C-8} idx 27-3 .silent_index {C-9} idx 27-3 .silent_index {C-M-0} idx 27-3 .silent_index {C-M-1} idx 27-3 .silent_index {C-M-2} idx 27-3 .silent_index {C-M-3} idx 27-3 .silent_index {C-M-4} idx 27-3 .silent_index {C-M-5} idx 27-3 .silent_index {C-M-6} idx 27-3 .silent_index {C-M-7} idx 27-3 .silent_index {C-M-8} idx 27-3 .silent_index {C-M-9} idx 27-3 .silent_index {M-0} idx 27-3 .silent_index {M-1} idx 27-3 .silent_index {M-2} idx 27-3 .silent_index {M-3} idx 27-3 .silent_index {M-4} idx 27-3 .silent_index {M-5} idx 27-3 .silent_index {M-6} idx 27-3 .silent_index {M-7} idx 27-3 .silent_index {M-8} idx 27-3 .silent_index {M-9} idx 27-3 .silent_index {M-X Auto Fill Mode} idx 27-3 .silent_index {C-M-M} idx 27-4 .silent_index {C-M-RETURN} idx 27-4 .silent_index {M-M} idx 27-4 .silent_index {M-RETURN} idx 27-4 .silent_index {C-X RUBOUT} idx 27-4 .silent_index {M-[} idx 27-4 .silent_index {M-A} idx 27-4 .silent_index {C-(} idx 27-5 .silent_index {C-M-(} idx 27-5 .silent_index {C-M-U} idx 27-5 .silent_index {C-X C-B} idx 27-5 .silent_index {M-X List Buffers} idx 27-5 .silent_index {M-~} idx 27-5 .silent_index {C-X} idx 27-5 .silent_index {M-S} idx 27-6 .silent_index {M-W} idx 27-6 .silent_index {M-X Count Occurrences} idx 27-6 .silent_index {M-X How Many} idx 27-6 .silent_index {M-X Delete And Expunge File} idx 27-6 .silent_index {BACKSPACE} idx 27-7 .silent_index {RUBOUT} idx 27-7 .silent_index {BACKSPACE} idx 27-7 .silent_index {C-RUBOUT} idx 27-7 .silent_index {RUBOUT} idx 27-7 .silent_index {C-X C-O} idx 27-7 .silent_index {M-X Delete File} idx 27-7 .silent_index {M-X Kill File} idx 27-7 .silent_index {C-D} idx 27-8 .silent_index {ESC-P} idx 27-8 .silent_index {M-\} idx 27-8 .silent_index {M-^} idx 27-8 .silent_index {M-X Delete Matching Lines} idx 27-8 .silent_index {M-X Flush Lines} idx 27-8 .silent_index {M-X Delete Non-Matching Lines} idx 27-8 .silent_index {M-X Keep Lines} idx 27-8 .silent_index {C-X D} idx 27-9 .silent_index {C-M-D} idx 27-9 .silent_index {M-X Dired} idx 27-9 .silent_index {M-X Edit Directory} idx 27-9 .silent_index {C-M-E} idx 27-10 .silent_index {C-M-]} idx 27-10 .silent_index {ESCAPE} idx 27-10 .silent_index {C-X C-X} idx 27-10 .silent_index {C-X E} idx 27-10 .silent_index {M-X Execute Buffer} idx 27-10 .silent_index {Lisp-D} idx 27-11 .silent_index {M-X Execute File} idx 27-11 .silent_index {Lisp-E} idx 27-11 .silent_index {Lisp-L} idx 27-11 .silent_index {M-Z} idx 27-12 .silent_index {M-Q} idx 27-12 .silent_index {M-G} idx 27-12 .silent_index {C-X C-F} idx 27-13 .silent_index {M-X Find File} idx 27-13 .silent_index {M-]} idx 27-13 .silent_index {M-E} idx 27-13 .silent_index {C-)} idx 27-13 .silent_index {C-M-)} idx 27-13 .silent_index {C-X G} idx 27-14 .silent_index {C-X ^} idx 27-14 .silent_index {C-?} idx 27-14 .silent_index {M-/} idx 27-14 .silent_index {M-?} idx 27-14 .silent_index {C-S} idx 27-14 .silent_index {NEWLINE} idx 27-15 .silent_index {C-M-\} idx 27-15 .silent_index {M-X Insert Buffer} idx 27-15 .silent_index {)} idx 27-15 .silent_index {]} idx 27-15 .silent_index {M-;} idx 27-16 .silent_index {M-X Insert Date} idx 27-16 .silent_index {M-X Insert File} idx 27-16 .silent_index {C-Y} idx 27-16 .silent_index {C-Q} idx 27-17 .silent_index {C-M-RUBOUT} idx 27-17 .silent_index {M-RUBOUT} idx 27-17 .silent_index {C-X K} idx 27-17 .silent_index {M-X Kill Buffer} idx 27-17 .silent_index {C-M-K} idx 27-18 .silent_index {M-D} idx 27-18 .silent_index {C-K} idx 27-18 .silent_index {ESC-M} idx 27-18 .silent_index {C-W} idx 27-18 .silent_index {M-K} idx 27-19 .silent_index {M-X Kill Some Buffers} idx 27-19 .silent_index {Lisp-A} idx 27-19 .silent_index {Lisp-B} idx 27-19 .silent_index {Lisp-C} idx 27-20 .silent_index {Lisp-?} idx 27-20 .silent_index {C-M-\} idx 27-20 .silent_index {C-M-Q} idx 27-20 .silent_index {M-X Lisp Mode} idx 27-21 .silent_index {C-]} idx 27-21 .silent_index {Lisp-Q} idx 27-21 .silent_index {Lisp-R} idx 27-21 .silent_index {C-M-I} idx 27-22 .silent_index {C-M-TAB} idx 27-22 .silent_index {TAB} idx 27-22 .silent_index {C-X C-L} idx 27-22 .silent_index {M-L} idx 27-22 .silent_index {C-M-X} idx 27-22 .silent_index {M-X} idx 27-22 .silent_index {M-(} idx 27-23 .silent_index {C-<} idx 27-23 .silent_index {C-M-BACKSPACE} idx 27-23 .silent_index {C-M-H} idx 27-23 .silent_index {M-BACKSPACE} idx 27-23 .silent_index {C->} idx 27-23 .silent_index {C-M-@} idx 27-24 .silent_index {M-H} idx 27-24 .silent_index {C-X H} idx 27-24 .silent_index {M-@} idx 27-24 .silent_index {C-B} idx 27-25 .silent_index {ESC-D} idx 27-25 .silent_index {C-M-A} idx 27-25 .silent_index {C-M-[} idx 27-25 .silent_index {C-M-B} idx 27-25 .silent_index {C-M-P} idx 27-25 .silent_index {ESC-4} idx 27-26 .silent_index {M-B} idx 27-26 .silent_index {ESC-B} idx 27-26 .silent_index {C-N} idx 27-26 .silent_index {C-F} idx 27-26 .silent_index {ESC-C} idx 27-26 .silent_index {C-M-F} idx 27-27 .silent_index {C-M-N} idx 27-27 .silent_index {ESC-5} idx 27-27 .silent_index {M-F} idx 27-27 .silent_index {M-)} idx 27-27 .silent_index {ESC-F} idx 27-28 .silent_index {M->} idx 27-28 .silent_index {ESC-H} idx 27-28 .silent_index {M-<} idx 27-28 .silent_index {C-E} idx 27-28 .silent_index {M-R} idx 27-28 .silent_index {C-A} idx 27-28 .silent_index {C-P} idx 27-29 .silent_index {ESC-A} idx 27-29 .silent_index {C--} idx 27-29 .silent_index {C-M--} idx 27-29 .silent_index {M--} idx 27-29 .silent_index {C-V} idx 27-29 .silent_index {C-G} idx 27-29 .silent_index {C-X C-Z} idx 27-29 .silent_index {ESC-J} idx 27-30 .silent_index {M-X Make Space} idx 27-30 .silent_index {C-X V} idx 27-30 .silent_index {C-L} idx 27-30 .silent_index {C-X 1} idx 27-30 .silent_index {C-O} idx 27-31 .silent_index {ESC-L} idx 27-31 .silent_index {C-X O} idx 27-31 .silent_index {M-X Prepend To File} idx 27-31 .silent_index {M-V} idx 27-31 .silent_index {C-X X} idx 27-32 .silent_index {M-%} idx 27-32 .silent_index {M-X Query Replace} idx 27-32 .silent_index {M-X Rename Buffer} idx 27-32 .silent_index {C-%} idx 27-33 .silent_index {M-X Replace String} idx 27-33 .silent_index {C-M-R} idx 27-33 .silent_index {RETURN} idx 27-33 .silent_index {C-R} idx 27-33 .silent_index {M-X Revert File} idx 27-33 .silent_index {M-X Save All Files} idx 27-34 .silent_index {C-X C-S} idx 27-34 .silent_index {C-M-V} idx 27-34 .silent_index {ESC-T} idx 27-34 .silent_index {ESC-V} idx 27-34 .silent_index {C-X <} idx 27-35 .silent_index {C-X >} idx 27-35 .silent_index {ESC-S} idx 27-35 .silent_index {ESC-U} idx 27-35 .silent_index {C-X B} idx 27-35 .silent_index {M-X Select Buffer} idx 27-35 .silent_index {C-M-L} idx 27-36 .silent_index {C-X F} idx 27-36 .silent_index {C-X .} idx 27-36 .silent_index {C-X C-N} idx 27-36 .silent_index {M-X Set Key} idx 27-37 .silent_index {C-@} idx 27-37 .silent_index {C-SPACE} idx 27-37 .silent_index {M-X Set Visited Filename} idx 27-37 .silent_index {C-M-O} idx 27-37 .silent_index {M-X Start Scripting} idx 27-38 .silent_index {M-X Start Timing Nmode} idx 27-38 .silent_index {M-X Stop Scripting} idx 27-38 .silent_index {M-X Stop Timing Nmode} idx 27-38 .silent_index {M-I} idx 27-39 .silent_index {M-TAB} idx 27-39 .silent_index {TAB} idx 27-39 .silent_index {M-X Text Mode} idx 27-39 .silent_index {C-T} idx 27-39 .silent_index {C-M-T} idx 27-39 .silent_index {C-X C-T} idx 27-40 .silent_index {C-X T} idx 27-40 .silent_index {M-T} idx 27-40 .silent_index {C-X 2} idx 27-40 .silent_index {M-X Undelete File} idx 27-41 .silent_index {C-U} idx 27-41 .silent_index {M-Y} idx 27-41 .silent_index {M-'} idx 27-41 .silent_index {M-C} idx 27-42 .silent_index {C-X C-U} idx 27-42 .silent_index {M-U} idx 27-42 .silent_index {C-X 3} idx 27-42 .silent_index {C-X C-V} idx 27-42 .silent_index {M-X Visit File} idx 27-42 .silent_index {C-X 4} idx 27-43 .silent_index {C-=} idx 27-43 .silent_index {C-X =} idx 27-43 .silent_index {C-X C-W} idx 27-43 .silent_index {M-X Write File} idx 27-43 .silent_index {M-X Write Region} idx 27-43 .silent_index {C-X P} idx 27-44 .silent_index {Lisp-Y} idx 27-44 |
Added psl-1983/3-1/doc/nmode/nm-commands.topic version [7bc7f0b5a6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Kill Ring} idx 27-2 .silent_index {Move Data} idx 27-2 .silent_index {Buffers} idx 27-2 .silent_index {Region} idx 27-2 .silent_index {Move Data} idx 27-2 .silent_index {Files} idx 27-2 .silent_index {Region} idx 27-2 .silent_index {Move Data} idx 27-2 .silent_index {Inform} idx 27-2 .silent_index {Subsequent Command Modifier} idx 27-3 .silent_index {Change Mode} idx 27-3 .silent_index {Move Point} idx 27-4 .silent_index {Kill Ring} idx 27-4 .silent_index {Sentence} idx 27-4 .silent_index {Remove} idx 27-4 .silent_index {Paragraph} idx 27-4 .silent_index {Move Point} idx 27-4 .silent_index {Sentence} idx 27-4 .silent_index {Move Point} idx 27-4 .silent_index {Lisp} idx 27-5 .silent_index {Move Point} idx 27-5 .silent_index {Buffers} idx 27-5 .silent_index {Inform} idx 27-5 .silent_index {Buffers} idx 27-5 .silent_index {Set Global Variable} idx 27-5 .silent_index {Subsequent Command Modifier} idx 27-5 .silent_index {Text} idx 27-6 .silent_index {Fill Column} idx 27-6 .silent_index {Alter Existing Text} idx 27-6 .silent_index {Kill Ring} idx 27-6 .silent_index {Region} idx 27-6 .silent_index {Preserve} idx 27-6 .silent_index {Inform} idx 27-6 .silent_index {Files} idx 27-6 .silent_index {Remove} idx 27-6 .silent_index {Remove} idx 27-7 .silent_index {Remove} idx 27-7 .silent_index {Remove} idx 27-7 .silent_index {Files} idx 27-7 .silent_index {Remove} idx 27-7 .silent_index {Kill Ring} idx 27-8 .silent_index {Remove} idx 27-8 .silent_index {Remove} idx 27-8 .silent_index {Remove} idx 27-8 .silent_index {Select} idx 27-8 .silent_index {Remove} idx 27-8 .silent_index {Select} idx 27-8 .silent_index {Remove} idx 27-8 .silent_index {Lisp} idx 27-9 .silent_index {Move Point} idx 27-9 .silent_index {Lisp} idx 27-10 .silent_index {Defun} idx 27-10 .silent_index {Move Point} idx 27-10 .silent_index {Subsequent Command Modifier} idx 27-10 .silent_index {Mark} idx 27-10 .silent_index {Move Point} idx 27-10 .silent_index {Alter Display Format} idx 27-10 .silent_index {Buffers} idx 27-10 .silent_index {Lisp} idx 27-11 .silent_index {Defun} idx 27-11 .silent_index {Mark} idx 27-11 .silent_index {Files} idx 27-11 .silent_index {Lisp} idx 27-11 .silent_index {Mark} idx 27-11 .silent_index {Lisp} idx 27-11 .silent_index {Escape} idx 27-11 .silent_index {Fill Prefix} idx 27-12 .silent_index {Fill Column} idx 27-12 .silent_index {Paragraph} idx 27-12 .silent_index {Alter Existing Text} idx 27-12 .silent_index {Text} idx 27-12 .silent_index {Fill Prefix} idx 27-12 .silent_index {Fill Column} idx 27-12 .silent_index {Paragraph} idx 27-12 .silent_index {Alter Existing Text} idx 27-12 .silent_index {Text} idx 27-12 .silent_index {Fill Prefix} idx 27-12 .silent_index {Fill Column} idx 27-12 .silent_index {Paragraph} idx 27-12 .silent_index {Sentence} idx 27-12 .silent_index {Alter Existing Text} idx 27-12 .silent_index {Files} idx 27-13 .silent_index {Buffers} idx 27-13 .silent_index {Move Data} idx 27-13 .silent_index {Move Point} idx 27-13 .silent_index {Text} idx 27-13 .silent_index {Paragraph} idx 27-13 .silent_index {Move Point} idx 27-13 .silent_index {Text} idx 27-13 .silent_index {Sentence} idx 27-13 .silent_index {Move Point} idx 27-13 .silent_index {Lisp} idx 27-13 .silent_index {Move Point} idx 27-13 .silent_index {Move Data} idx 27-14 .silent_index {Mark} idx 27-14 .silent_index {Alter Display Format} idx 27-14 .silent_index {Inform} idx 27-14 .silent_index {Move Point} idx 27-14 .silent_index {Select} idx 27-14 .silent_index {Insert Constant} idx 27-15 .silent_index {Buffers} idx 27-15 .silent_index {Move Data} idx 27-15 .silent_index {Lisp} idx 27-15 .silent_index {Insert Constant} idx 27-15 .silent_index {Lisp} idx 27-16 .silent_index {Insert Constant} idx 27-16 .silent_index {Move Data} idx 27-16 .silent_index {Files} idx 27-16 .silent_index {Move Data} idx 27-16 .silent_index {Kill Ring} idx 27-16 .silent_index {Move Data} idx 27-16 .silent_index {Mark} idx 27-16 .silent_index {Move Data} idx 27-17 .silent_index {Lisp} idx 27-17 .silent_index {Kill Ring} idx 27-17 .silent_index {Remove} idx 27-17 .silent_index {Text} idx 27-17 .silent_index {Kill Ring} idx 27-17 .silent_index {Remove} idx 27-17 .silent_index {Buffers} idx 27-17 .silent_index {Remove} idx 27-17 .silent_index {Lisp} idx 27-18 .silent_index {Kill Ring} idx 27-18 .silent_index {Remove} idx 27-18 .silent_index {Text} idx 27-18 .silent_index {Kill Ring} idx 27-18 .silent_index {Remove} idx 27-18 .silent_index {Kill Ring} idx 27-18 .silent_index {Remove} idx 27-18 .silent_index {Kill Ring} idx 27-18 .silent_index {Region} idx 27-18 .silent_index {Remove} idx 27-18 .silent_index {Text} idx 27-19 .silent_index {Kill Ring} idx 27-19 .silent_index {Sentence} idx 27-19 .silent_index {Remove} idx 27-19 .silent_index {Buffers} idx 27-19 .silent_index {Remove} idx 27-19 .silent_index {Lisp} idx 27-19 .silent_index {Escape} idx 27-19 .silent_index {Lisp} idx 27-19 .silent_index {Inform} idx 27-19 .silent_index {Lisp} idx 27-20 .silent_index {Escape} idx 27-20 .silent_index {Lisp} idx 27-20 .silent_index {Inform} idx 27-20 .silent_index {Lisp} idx 27-20 .silent_index {Lisp} idx 27-20 .silent_index {Lisp} idx 27-21 .silent_index {Change Mode} idx 27-21 .silent_index {Lisp} idx 27-21 .silent_index {Subsequent Command Modifier} idx 27-21 .silent_index {Lisp} idx 27-21 .silent_index {Escape} idx 27-21 .silent_index {Lisp} idx 27-21 .silent_index {Escape} idx 27-21 .silent_index {Lisp} idx 27-22 .silent_index {Alter Existing Text} idx 27-22 .silent_index {Region} idx 27-22 .silent_index {Alter Existing Text} idx 27-22 .silent_index {Text} idx 27-22 .silent_index {Alter Existing Text} idx 27-22 .silent_index {Subsequent Command Modifier} idx 27-22 .silent_index {Lisp} idx 27-23 .silent_index {Insert Constant} idx 27-23 .silent_index {Mark} idx 27-23 .silent_index {Lisp} idx 27-23 .silent_index {Defun} idx 27-23 .silent_index {Mark} idx 27-23 .silent_index {Mark} idx 27-23 .silent_index {Lisp} idx 27-24 .silent_index {Mark} idx 27-24 .silent_index {Text} idx 27-24 .silent_index {Paragraph} idx 27-24 .silent_index {Mark} idx 27-24 .silent_index {Move Point} idx 27-24 .silent_index {Mark} idx 27-24 .silent_index {Move Point} idx 27-24 .silent_index {Text} idx 27-24 .silent_index {Mark} idx 27-24 .silent_index {Move Point} idx 27-25 .silent_index {Lisp} idx 27-25 .silent_index {Defun} idx 27-25 .silent_index {Move Point} idx 27-25 .silent_index {Lisp} idx 27-25 .silent_index {Move Point} idx 27-25 .silent_index {Lisp} idx 27-25 .silent_index {Move Point} idx 27-25 .silent_index {Text} idx 27-26 .silent_index {Move Point} idx 27-26 .silent_index {Goal Column} idx 27-26 .silent_index {Move Point} idx 27-26 .silent_index {Goal Column} idx 27-26 .silent_index {Move Point} idx 27-26 .silent_index {Move Point} idx 27-26 .silent_index {Lisp} idx 27-27 .silent_index {Move Point} idx 27-27 .silent_index {Lisp} idx 27-27 .silent_index {Move Point} idx 27-27 .silent_index {Text} idx 27-27 .silent_index {Move Point} idx 27-27 .silent_index {Lisp} idx 27-27 .silent_index {Move Point} idx 27-27 .silent_index {Move Point} idx 27-28 .silent_index {Move Point} idx 27-28 .silent_index {Move Point} idx 27-28 .silent_index {Move Point} idx 27-28 .silent_index {Move Point} idx 27-28 .silent_index {Goal Column} idx 27-29 .silent_index {Move Point} idx 27-29 .silent_index {Subsequent Command Modifier} idx 27-29 .silent_index {Move Point} idx 27-29 .silent_index {Escape} idx 27-29 .silent_index {Escape} idx 27-29 .silent_index {Alter Display Format} idx 27-30 .silent_index {Alter Display Format} idx 27-30 .silent_index {Alter Display Format} idx 27-30 .silent_index {Alter Display Format} idx 27-30 .silent_index {Insert Constant} idx 27-31 .silent_index {Alter Display Format} idx 27-31 .silent_index {Move Point} idx 27-31 .silent_index {Files} idx 27-31 .silent_index {Region} idx 27-31 .silent_index {Move Data} idx 27-31 .silent_index {Move Point} idx 27-31 .silent_index {Preserve} idx 27-32 .silent_index {Alter Existing Text} idx 27-32 .silent_index {Select} idx 27-32 .silent_index {Buffers} idx 27-32 .silent_index {Set Global Variable} idx 27-32 .silent_index {Alter Existing Text} idx 27-33 .silent_index {Select} idx 27-33 .silent_index {Lisp} idx 27-33 .silent_index {Alter Display Format} idx 27-33 .silent_index {Insert Constant} idx 27-33 .silent_index {Move Point} idx 27-33 .silent_index {Select} idx 27-33 .silent_index {Files} idx 27-33 .silent_index {Remove} idx 27-33 .silent_index {Buffers} idx 27-34 .silent_index {Files} idx 27-34 .silent_index {Preserve} idx 27-34 .silent_index {Files} idx 27-34 .silent_index {Preserve} idx 27-34 .silent_index {Alter Display Format} idx 27-34 .silent_index {Alter Display Format} idx 27-34 .silent_index {Alter Display Format} idx 27-34 .silent_index {Alter Display Format} idx 27-35 .silent_index {Alter Display Format} idx 27-35 .silent_index {Alter Display Format} idx 27-35 .silent_index {Alter Display Format} idx 27-35 .silent_index {Buffers} idx 27-35 .silent_index {Move Point} idx 27-35 .silent_index {Buffers} idx 27-36 .silent_index {Move Point} idx 27-36 .silent_index {Fill Column} idx 27-36 .silent_index {Set Global Variable} idx 27-36 .silent_index {Fill Prefix} idx 27-36 .silent_index {Set Global Variable} idx 27-36 .silent_index {Set Global Variable} idx 27-36 .silent_index {Set Global Variable} idx 27-37 .silent_index {Mark} idx 27-37 .silent_index {Files} idx 27-37 .silent_index {Set Global Variable} idx 27-37 .silent_index {Insert Constant} idx 27-37 .silent_index {Change Mode} idx 27-38 .silent_index {Change Mode} idx 27-38 .silent_index {Change Mode} idx 27-38 .silent_index {Change Mode} idx 27-38 .silent_index {Insert Constant} idx 27-39 .silent_index {Text} idx 27-39 .silent_index {Change Mode} idx 27-39 .silent_index {Alter Existing Text} idx 27-39 .silent_index {Lisp} idx 27-39 .silent_index {Alter Existing Text} idx 27-39 .silent_index {Alter Existing Text} idx 27-40 .silent_index {Region} idx 27-40 .silent_index {Alter Existing Text} idx 27-40 .silent_index {Text} idx 27-40 .silent_index {Alter Existing Text} idx 27-40 .silent_index {Alter Display Format} idx 27-40 .silent_index {Files} idx 27-41 .silent_index {Move Data} idx 27-41 .silent_index {Preserve} idx 27-41 .silent_index {Subsequent Command Modifier} idx 27-41 .silent_index {Kill Ring} idx 27-41 .silent_index {Region} idx 27-41 .silent_index {Alter Existing Text} idx 27-41 .silent_index {Alter Existing Text} idx 27-41 .silent_index {Text} idx 27-42 .silent_index {Alter Existing Text} idx 27-42 .silent_index {Region} idx 27-42 .silent_index {Alter Existing Text} idx 27-42 .silent_index {Text} idx 27-42 .silent_index {Alter Existing Text} idx 27-42 .silent_index {Alter Display Format} idx 27-42 .silent_index {Files} idx 27-42 .silent_index {Move Data} idx 27-42 .silent_index {Move Point} idx 27-42 .silent_index {Files} idx 27-43 .silent_index {Buffers} idx 27-43 .silent_index {Move Point} idx 27-43 .silent_index {Alter Display Format} idx 27-43 .silent_index {Inform} idx 27-43 .silent_index {Files} idx 27-43 .silent_index {Preserve} idx 27-43 .silent_index {Files} idx 27-43 .silent_index {Region} idx 27-43 .silent_index {Preserve} idx 27-43 .silent_index {Files} idx 27-44 .silent_index {Preserve} idx 27-44 .silent_index {Lisp} idx 27-44 .silent_index {Move Data} idx 27-44 |
Added psl-1983/3-1/doc/nmode/nm-contents.ibm version [aea92ab38c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (1 March 1983) <PSL.NMODE-DOC>NM-CONTENTS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/Contents NMODE Manual Page i Chapter 1. Introduction Chapter 4. Basic Editing Commands 4.1. Inserting Text 4-1 4.2. Moving The Cursor 4-1 4.3. Erasing Text 4-2 4.4. Files 4-2 4.5. Help 4-3 4.6. Using Blank Lines Can Make Editing Faster 4-4 Chapter 21. Action Types Chapter 22. Definitions Chapter 23. Globals Chapter 24. Command Descriptions Chapter 25. Command Index Chapter 26. Function Index Chapter 27. Key Index Chapter 28. Topic Index |
Added psl-1983/3-1/doc/nmode/nm-customization.contents version [53432295cf].
> > > > | 1 2 3 4 | contents_entry(0 22 {Simple Customization} 22-1) contents_entry(1 22.1 {Init Files} 22-1) contents_entry(1 22.2 {Variables} 22-4) contents_entry(1 22.3 {Minor Modes} 22-4) |
Added psl-1983/3-1/doc/nmode/nm-customization.function version [500172bd87].
> | 1 | .silent_index {set-fill-column-command} idx 22-5 |
Added psl-1983/3-1/doc/nmode/nm-customization.ibm version [d9919926ac].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-CUSTOMIZATION.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Simple Customization) Page 22-1 202/22. Simple Customization 201/In this chapter we describe simple ways of customizing NMODE. NMODE is designed to be customizable; each user can rearrange things to suit his taste. Simple customizations are primarily of two types: moving functions from one character to another, and setting variables which functions refer to so as to direct their actions. Beyond this, extensions can involve redefining existing functions, or writing entirely new functions and creating sharable libraries of them. 202/22.1 Init Files 201/This section explains how to customize NMODE by redefining the effect of input keystrokes. NMODE is customized by executing Lisp forms. These forms may be executed directly within NMODE (using Lisp-E), or may be stored in an INIT file, which is read by NMODE when it first starts up. The name of the INIT file read by NMODE is "NMODE.INIT" in the user's home directory. There are three concepts that must be understood to customize NMODE: Commands, Functions, and Modes. 1) Commands. The effect of given keystroke or sequence of keystrokes in NMODE is based on a mapping between "commands" and "functions". A "command" may be either a single "extended character" or a sequence of characters. An extended character is a 9-bit character with distinct "Control" and "Meta" bits. Thus "C-M-A" is a single "extended character", even though on many terminals you have to use two keystrokes to enter it. Extended characters are specified using the macro X-CHAR, for example: (x-char A) the letter "A" (upper case) (x-char C-F) Control-F (x-char C-M-Z) Control-Meta-Z (x-char CR) Carriage-Return (x-char TAB) Tab (x-char BACKSPACE) Backspace (x-char NEWLINE) Newline (x-char RUBOUT) Rubout (x-char C-M-RUBOUT) Control-Meta-Rubout (The macros described in this section are defined in the load module EXTENDED-CHAR.) It is important to note that on most terminals, some Ascii control characters are mapped to extended "Control" characters and some aren't. Those that aren't are: Backspace, CR, Newline, Tab, and Escape. Even if you type "CTRL-I" on the keyboard, you will get "Tab" and not "Control-I". The remaining Ascii control characters are mapped to extended "Control" characters, thus typing "CTRL-A" on the keyboard gives "Control-A". As mentioned above, a command can be a sequence of characters. There are two forms: Prefix commands and Extended commands. 201/Page 22-2 NMODE Manual (Init Files) Prefix commands: A prefix command consists of two characters, the first of which is a defined "prefix character". In NMODE, there are 3 predefined prefix characters: C-X, ESC, and C-]. Prefix commands are specified using the X-CHARS macro, for example: (x-chars C-X C-F) (x-chars ESC A) (x-chars C-] E) Extended commands: An extended command consists of the character M-X and a string. Extended commands are defined using the M-X macro, for example: (M-X "Lisp Mode") (M-X "Revert File") The case of the letters in the string is irrelevant, except to specify how the command name will be displayed when "completion" is used by the user. By convention, the first letter of each word in an extended command name is capitalized. 2) Functions. NMODE commands are implemented by PSL functions. By convention, most (but not all) PSL functions that implement NMODE commands have names ending with "-COMMAND", for example, 203/move-forward-character-command201/. An NMODE command function should take no arguments. The function can perform its task using a large number of existing support functions; see PN:BUFFER.SL and PN:MOVE-COMMANDS.SL for examples. A command function can determine the command argument (given by C-U) by inspecting global variables: nmode-command-argument: the numeric value (default: 1) nmode-command-argument-given: T if the user specified an argument nmode-command-number-given: T if the user typed digits in the argument See the files PN:MOVE-COMMANDS.SL, PN:LISP-COMMANDS.SL, and PN:COMMANDS.SL for many examples of NMODE command functions. 3) Modes. The mapping between commands and functions is dependent on the current "mode". Examples of existing modes are "Text Mode", which is the basic mode for text editing, "Lisp Mode", which is an extension of "Text Mode" for editing and executing Lisp code, and "Dired Mode", which is a specialized mode for the Directory Editor Subsystem. A mode is defined by a list of Lisp forms which are evaluated to determine the state of a Dispatch Table. The Dispatch Table is what is actually used to map from commands to functions. Every time the user selects a new buffer, the Dispatch Table is cleared and the Lisp forms defining the mode for the new buffer are evaluated to fill the Dispatch Table. The forms are evaluated in reverse order, so that the first form is evaluated last. Thus, any command definitions made by one form supersede those made by forms appearing after it in the list. 201/NMODE Manual (Init Files) Page 22-3 Two functions are commonly invoked by mode-defining forms: 203/nmode-establish-mode 201/and 203/nmode-define-commands201/. 203/nmode-establish-mode 201/takes one argument, a list of mode defining forms, and evaluates those forms. Thus, 203/nmode-establish-mode 201/can be used to define one mode in terms of (as an extension of or a modification to) another mode. 203/nmode-define-commands 201/takes one argument, a list of pairs, where each pair consists of a COMMAND and a FUNCTION. This form of list is called a "command list". Command lists are not used directly to map from commands to functions. Instead, 203/nmode-define-commands 201/reads the command list it is given and for each COMMAND-FUNCTION pair in the command list (in order), it alters the Dispatch Table to map the specified COMMAND to the corresponding FUNCTION. Note that as a convenience, whenever you define an "upper case" command, the corresponding "lower case" command is also defined to map to the same function. Thus, if you define C-M-A, you automatically define C-M-a to map to the same function. If you want the lower case command to map to a different function, you must define the lower case command "after" defining the upper case command. The usual technique for modifying one or more existing modes is to modify one of the command lists given to 203/nmode-define-commands201/. The file PN:MODE-DEFS.SL contains the definition of most predefined NMODE command lists, as well as the definition of most predefined modes. To modify a mode or modes, you must alter one or more command lists by adding (or perhaps removing) entries. Command lists are manipulated using two functions: (add-to-command-list list-name command func) (remove-from-command-list list-name command) Here are some examples: (add-to-command-list 'read-only-text-command-list (x-char M-@) 'set-mark-command) [The above form makes M-@ set the mark.] (add-to-command-list 'read-only-terminal-command-list (x-chars ESC Y) 'print-buffer-names-command) [The above form makes Esc-Y print a list of all buffer names. Esc-Y is sent by HP264X terminals when the "Display Functions" key is hit.] Note that these functions change only the command lists, not the Dispatch Table which is actually used to map from commands to functions. To cause the Dispatch Table to be updated to reflect any changes in the command lists, you must invoke the function 203/nmode-establish-current-mode201/. 201/Page 22-4 NMODE Manual (Variables) 202/22.2 Variables 201/Since the init file consists of a series of PSL forms, it can contain simple assignment statements which set up global variables in NMODE. A variable is a name which is associated with a value. NMODE uses many variables internally, and has others whose purpose is to be set by the user for customization. If you want to set a variable a particular way each time you use NMODE, you can use your init file to do so. Global variables may also be set automatically by major modes. Two examples of global variables are *outwindow and nmode-default-mode. Nmode-default-mode is the mode used for most newly created buffers. It is normally set to text-mode, but might be set to lisp-interface-mode by a user who expects to be editing programs most of the time. The other variable controls the automatic pop up of the output window. If *outwindow is T, the output buffer will automatically appear if it is not already displayed when output (i.e. from a lisp calculation) occurs. Another example of such a variable is the Fill Column variable, which specifies the position of the right margin (in characters from the left margin) to be used by the fill and justify commands. To set a variable, include in the init file a line containing (setq <variable_name> <variable_value>). This is just an assignment statement in PSL. To adjust the fill column to 60, for instance, include a line: (setq fill-column 60). 202/22.3 Minor Modes 201/Since init files can execute arbitrary PSL forms, they can run the same functions that one can call from the terminal by appropriate commands. In particular they can turn major or minor modes on or off. Minor modes are options which you can use or not. For example, Auto Fill mode is a minor mode in which Spaces break lines between words as you type. All the minor modes are independent of each other and of the selected major mode. Most minor modes say in the mode line when they are on; for example, "Fill" in the mode line means that Auto Fill mode is on. Minor modes are controlled by a global variable: nmode-minor-modes. This is a list of currently active minor modes. Rather than directly setting this list, it is generally preferable to use some existing functions to turn the modes on and off, since they correctly handle some side effects. Minor modes can be added to this list with 203/activate-minor-mode 201/and removed from it with 203/deactivate-minor-mode201/. For example, auto fill mode can be turned on when NMODE is started by including (activate-minor-mode auto-fill-mode) 201/NMODE Manual (Minor Modes) Page 22-5 in the init file. Each minor mode is associated with a function that can be used to turn it on or off. The function turns the mode on if it was off and off if it was on. This is known as 202/toggling201/. All the minor mode functions are suitable for connecting to single or double character commands if you want to enter and exit a minor mode frequently. Auto Fill mode allows you to type text endlessly without worrying about the width of your screen. Line separators are be inserted where needed to prevent lines from becoming too long. A variable called fill-column sets the maximum number of columns allowed in a line. See Section 13.4 [Filling], page 4. |
Added psl-1983/3-1/doc/nmode/nm-customization.key version [5671a6a911].
> > > | 1 2 3 | .silent_index {C-X} idx 22-2 .silent_index {M-X} idx 22-2 .silent_index {C-X} idx 22-5 |
Added psl-1983/3-1/doc/nmode/nm-customization.r version [d61f6298fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-CUSTOMIZATION manual @Chapter[Simple Customization] @label[NMODECustomization] @node("customization") In this chapter we describe simple ways of customizing NMODE. NMODE is designed to be customizable; each user can rearrange things to suit his taste. Simple customizations are primarily of two types: moving functions from one character to another, and setting variables which functions refer to so as to direct their actions. Beyond this, extensions can involve redefining existing functions, or writing entirely new functions and creating sharable libraries of them. @index{redefining commands} @Section[Init Files] @node("init") @index{init files} @index{customization} This section explains how to customize NMODE by redefining the effect of input keystrokes. NMODE is customized by executing Lisp forms. These forms may be executed directly within NMODE (using Lisp-E), or may be stored in an INIT file, which is read by NMODE when it first starts up. The name of the INIT file read by NMODE is "NMODE.INIT" in the user's home directory. There are three concepts that must be understood to customize NMODE: Commands, Functions, and Modes. @index{control} @index{meta} @index{character set} 1) Commands. The effect of given keystroke or sequence of keystrokes in NMODE is based on a mapping between "commands" and "functions". A "command" may be either a single "extended character" or a sequence of characters. An extended character is a 9-bit character with distinct "Control" and "Meta" bits. Thus "C-M-A" is a single "extended character", even though on many terminals you have to use two keystrokes to enter it. Extended characters are specified using the macro X-CHAR, for example: @verbatim{ (x-char A) the letter "A" (upper case) (x-char C-F) Control-F (x-char C-M-Z) Control-Meta-Z (x-char CR) Carriage-Return (x-char TAB) Tab (x-char BACKSPACE) Backspace (x-char NEWLINE) Newline (x-char RUBOUT) Rubout (x-char C-M-RUBOUT) Control-Meta-Rubout } (The macros described in this section are defined in the load module EXTENDED-CHAR.) It is important to note that on most terminals, some Ascii control characters are mapped to extended "Control" characters and some aren't. Those that aren't are: Backspace, CR, Newline, Tab, and Escape. Even if you type "CTRL-I" on the keyboard, you will get "Tab" and not "Control-I". The remaining Ascii control characters are mapped to extended "Control" characters, thus typing "CTRL-A" on the keyboard gives "Control-A". As mentioned above, a command can be a sequence of characters. There are two forms: Prefix commands and Extended commands. @keyindex{C-X} @index{prefix characters} Prefix commands: A prefix command consists of two characters, the first of which is a defined "prefix character". In NMODE, there are 3 predefined prefix characters: C-X, ESC, and C-]. Prefix commands are specified using the X-CHARS macro, for example: @verbatim{ (x-chars C-X C-F) (x-chars ESC A) (x-chars C-] E) } @index{extended commands} @keyindex{M-X} @index{functions} @index{commands} Extended commands: An extended command consists of the character M-X and a string. Extended commands are defined using the M-X macro, for example: @verbatim{ (M-X "Lisp Mode") (M-X "Revert File") } The case of the letters in the string is irrelevant, except to specify how the command name will be displayed when "completion" is used by the user. By convention, the first letter of each word in an extended command name is capitalized. 2) Functions. NMODE commands are implemented by PSL functions. By convention, most (but not all) PSL functions that implement NMODE commands have names ending with "-COMMAND", for example, @fnc{move-forward-character-command}. An NMODE command function should take no arguments. The function can perform its task using a large number of existing support functions; see PN:BUFFER.SL and PN:MOVE-COMMANDS.SL for examples. A command function can determine the command argument (given by C-U) by inspecting global variables: @verbatim{ nmode-command-argument: the numeric value (default: 1) nmode-command-argument-given: T if the user specified an argument nmode-command-number-given: T if the user typed digits in the argument } See the files PN:MOVE-COMMANDS.SL, PN:LISP-COMMANDS.SL, and PN:COMMANDS.SL for many examples of NMODE command functions. 3) Modes. The mapping between commands and functions is dependent on the current "mode". Examples of existing modes are "Text Mode", which is the basic mode for text editing, "Lisp Mode", which is an extension of "Text Mode" for editing and executing Lisp code, and "Dired Mode", which is a specialized mode for the Directory Editor Subsystem. A mode is defined by a list of Lisp forms which are evaluated to determine the state of a Dispatch Table. The Dispatch Table is what is actually used to map from commands to functions. Every time the user selects a new buffer, the Dispatch Table is cleared and the Lisp forms defining the mode for the new buffer are evaluated to fill the Dispatch Table. The forms are evaluated in reverse order, so that the first form is evaluated last. Thus, any command definitions made by one form supersede those made by forms appearing after it in the list. Two functions are commonly invoked by mode-defining forms: @fnc{nmode-establish-mode} and @fnc{nmode-define-commands}. @fnc{nmode-establish-mode} takes one argument, a list of mode defining forms, and evaluates those forms. Thus, @fnc{nmode-establish-mode} can be used to define one mode in terms of (as an extension of or a modification to) another mode. @fnc{nmode-define-commands} takes one argument, a list of pairs, where each pair consists of a COMMAND and a FUNCTION. This form of list is called a "command list". Command lists are not used directly to map from commands to functions. Instead, @fnc{nmode-define-commands} reads the command list it is given and for each COMMAND-FUNCTION pair in the command list (in order), it alters the Dispatch Table to map the specified COMMAND to the corresponding FUNCTION. Note that as a convenience, whenever you define an "upper case" command, the corresponding "lower case" command is also defined to map to the same function. Thus, if you define C-M-A, you automatically define C-M-a to map to the same function. If you want the lower case command to map to a different function, you must define the lower case command "after" defining the upper case command. The usual technique for modifying one or more existing modes is to modify one of the command lists given to @fnc{nmode-define-commands}. The file PN:MODE-DEFS.SL contains the definition of most predefined NMODE command lists, as well as the definition of most predefined modes. To modify a mode or modes, you must alter one or more command lists by adding (or perhaps removing) entries. Command lists are manipulated using two functions: @verbatim{ (add-to-command-list list-name command func) (remove-from-command-list list-name command) } Here are some examples: @verbatim{ (add-to-command-list 'read-only-text-command-list (x-char M-@) 'set-mark-command) [The above form makes M-@ set the mark.] (add-to-command-list 'read-only-terminal-command-list (x-chars ESC Y) 'print-buffer-names-command) [The above form makes Esc-Y print a list of all buffer names. Esc-Y is sent by HP264X terminals when the "Display Functions" key is hit.] } Note that these functions change only the command lists, not the Dispatch Table which is actually used to map from commands to functions. To cause the Dispatch Table to be updated to reflect any changes in the command lists, you must invoke the function @fnc{nmode-establish-current-mode}. @Section[Variables] @node("variables") @index{variables} @index{options} @index{Fill Column} Since the init file consists of a series of PSL forms, it can contain simple assignment statements which set up global variables in NMODE. A variable is a name which is associated with a value. NMODE uses many variables internally, and has others whose purpose is to be set by the user for customization. If you want to set a variable a particular way each time you use NMODE, you can use your init file to do so. Global variables may also be set automatically by major modes. Two examples of global variables are *outwindow and nmode-default-mode. Nmode-default-mode is the mode used for most newly created buffers. It is normally set to text-mode, but might be set to lisp-interface-mode by a user who expects to be editing programs most of the time. The other variable controls the automatic pop up of the output window. If *outwindow is T, the output buffer will automatically appear if it is not already displayed when output (i.e. from a lisp calculation) occurs. Another example of such a variable is the Fill Column variable, which specifies the position of the right margin (in characters from the left margin) to be used by the fill and justify commands. @Index{NMODE.VARS} @index{variables} To set a variable, include in the init file a line containing @verbatim{ (setq <variable_name> <variable_value>). } This is just an assignment statement in PSL. To adjust the fill column to 60, for instance, include a line: @verbatim{ (setq fill-column 60). } @Section[Minor Modes] @node("minormodes") @index{minor modes} @index{numeric arguments} @index{mode line} @index{toggling} Since init files can execute arbitrary PSL forms, they can run the same functions that one can call from the terminal by appropriate commands. In particular they can turn major or minor modes on or off. Minor modes are options which you can use or not. For example, Auto Fill mode is a minor mode in which Spaces break lines between words as you type. All the minor modes are independent of each other and of the selected major mode. Most minor modes say in the mode line when they are on; for example, "Fill" in the mode line means that Auto Fill mode is on. Minor modes are controlled by a global variable: nmode-minor-modes. This is a list of currently active minor modes. Rather than directly setting this list, it is generally preferable to use some existing functions to turn the modes on and off, since they correctly handle some side effects. Minor modes can be added to this list with @fnc{activate-minor-mode} and removed from it with @fnc{deactivate-minor-mode}. For example, auto fill mode can be turned on when NMODE is started by including @verbatim{ (activate-minor-mode auto-fill-mode) } in the init file. Each minor mode is associated with a function that can be used to turn it on or off. The function turns the mode on if it was off and off if it was on. This is known as @dfn[toggling]. All the minor mode functions are suitable for connecting to single or double character commands if you want to enter and exit a minor mode frequently. @index{Auto Fill mode} @keyindex{C-X F} @index{Fill Column} @fncindex{set-fill-column-command} Auto Fill mode allows you to type text endlessly without worrying about the width of your screen. Line separators are be inserted where needed to prevent lines from becoming too long. A variable called fill-column sets the maximum number of columns allowed in a line. @Note("Filling"). @node("kbdmac") @Section[Keyboard Macros] @WideCommands[ C-X ( Start defining a keyboard macro. C-X ) End the definition of a keyboard macro. C-X E Execute the most recent keyboard macro. C-U C-X ( Re-execute last keyboard macro and append to its definition. C-X Q Ask for confirmation when the keyboard macro is executed. C-U C-X Q Allow the user to edit for a while, each time the keyboard macro is executed. M-X Name Kbd Macro Make the most recent keyboard macro into the permanent definition of a command. M-X Write Kbd Macro Save a keyboard macro in a file. ] @index{keyboard macros} A @dfn[keyboard macro] is a command defined by the user to abbreviate a sequence of other commands. If you discover that you are about to type C-N C-D forty times, you can define a keyboard macro to do C-N C-D and call it with a repeat count of forty. @index{TECO} Keyboard macros differ from ordinary NMODE commands, in that they are written in the NMODE command language rather than in TECO. This makes it easier for the novice to write them, and makes them more convenient as temporary hacks. However, the NMODE command language is not powerful enough as a programming language to be useful for writing anything intelligent or general. For such things, TECO must be used. NMODE functions were formerly known as macros (which is part of the explanation of the name NMODE), because they were macros within the context of TECO as an editor. We decided to change the terminology because, when thinking of NMODE, we consider TECO a programming language rather than an editor. The only "macros" in NMODE now are keyboard macros. You define a keyboard macro while executing the commands which are the definition. Put differently, as you are defining a keyboard macro, the definition is being executed for the first time. This way, you can see what the effects of your commands are, so that you don't have to figure them out in your head. When you are finished, the keyboard macro is defined and also has been, in effect, executed once. You can then do the whole thing over again by invoking the macro. @SubSection[Basic Use] @index{C-X (}@index{C-X )}@index{C-X E}@fncindex{start kbd macro-command}@fncindex{end kbd macro-command} @fncindex{execute kbd macro-command} To start defining a keyboard macro, type the @w[C-X (] command (@fnc{start kbd macro-command}). From then on, your commands continue to be executed, but also become part of the definition of the macro. "Def" appears in the mode line to remind you of what is going on. When you are finished, the @w[C-X )] command (@fnc{end kbd macro-command}) terminates the definition (without becoming part of it!). The macro thus defined can be invoked again with the C-X E command (@fnc{execute kbd macro-command}), which may be given a repeat count as a numeric argument to execute the macro many times. @w[C-X )] can also be given a repeat count as an argument, in which case it repeats the macro that many times right after defining it, but defining the macro counts as the first repetition (since it is executed as you define it). So, giving @w[C-X )] an argument of 2 executes the macro immediately one additional time. An argument of zero to @w[C-X E] or @w[C-X )] means repeat the macro indefinitely (until it gets an error). If you want to perform an operation on each line, then either you should start by positioning point on the line above the first one to be processed and then begin the macro definition with a C-N, or you should start on the proper line and end with a C-N. Either way, repeating the macro will operate on successive lines. After you have terminated the definition of a keyboard macro, you can add to the end of its definition by typing C-U @w[C-X (]. This is equivalent to plain @w[C-X (] followed by retyping the whole definition so far. As a consequence it re-executes the macro as previously defined. @index{Name Kbd Macro} If you wish to save a keyboard macro for longer than until you define the next one, you must give it a name. If you do M-X Name Kbd MacroFOO@return2{}, the last keyboard macro defined (the one which C-X E would invoke) is turned into a function and given the name FOO. M-X FOO will from then on invoke that particular macro. Name Kbd Macro also reads a character from the keyboard and redefines that character command to invoke the macro. You can use a bit prefix character in specifying the command; you can also type a C-X command to be redefined. When you have finished typing the command characters, Name Kbd Macro asks you whether it should go ahead and redefine the character. @index{Write Kbd Macro} To save a keyboard macro permanently, do M-X Write Kbd Macro. Supply the function name of the keyboard macro as a string argument, or else it will ask you to type the character which invokes the keyboard macro. The keyboard macro is saved as a library which, when loaded, automatically redefines the keyboard macro. The filename is read from the terminal. Its second name should be :EJ, like other libraries; that is the default. @index{View Kbd Macro} To examine the definition of a keyboard macro, use the function View Kbd Macro. Either supply the name of the function which runs the macro, as a string argument, or type the command which invokes the macro when View Kbd Macro asks for it. @SubSection[Executing Macros with Variations] @index{C-X Q}@fncindex{kbd macro query-command} If you want to be allowed to do arbitrary editing at a certain point each time around the macro (different each time, and not remembered as part of the macro), you can use the C-U C-X Q command (@fnc{kbd macro query-command}). When you are defining the macro, this lets you do some editing, which does @xxii[not] become part of the macro. When you are done, exit with @CMC[] to return to defining the macro. When you execute the macro, at that same point, you will again be allowed to do some editing. When you exit this time with @CMC[], the execution of the macro will resume. If you abort the recursive editing level with C-], you will abort the macro definition or execution. @index{Query Replace}@index{Space}@index{Rubout}@index{C-L}@index{C-R}@index{Altmode} You can get the effect of Query Replace, where the macro asks you each time around whether to make a change, by using the command C-X Q with no argument in your keyboard macro. When you are defining the macro, the C-X Q does nothing, but when the macro is invoked the C-X Q reads a character from the terminal to decide whether to continue. The special answers are Space, Rubout, Altmode, C-L, C-R. A Space means to continue. A Rubout means to skip the remainder of this repetition of the macro, starting again from the beginning in the next repetition. An Altmode ends all repetitions of the macro, but only the innermost macro (in case it was called from another macro). C-L clears the screen and asks you again for a character to say what to do. C-R enters a recursive editing level; when you exit, you are asked again (if you type a Space, the macro will continue from wherever you left things when you exited the C-R). Anything else exits all levels of keyboard macros and is reread as a command. |
Added psl-1983/3-1/doc/nmode/nm-customization.topic version [89b71b7be9].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | .silent_index {redefining} idx 22-1 .silent_index {init} idx 22-1 .silent_index {customization} idx 22-1 .silent_index {control} idx 22-1 .silent_index {meta} idx 22-1 .silent_index {character} idx 22-1 .silent_index {prefix} idx 22-2 .silent_index {extended} idx 22-2 .silent_index {functions} idx 22-2 .silent_index {commands} idx 22-2 .silent_index {variables} idx 22-4 .silent_index {options} idx 22-4 .silent_index {Fill} idx 22-4 .silent_index {NMODE.VARS} idx 22-4 .silent_index {variables} idx 22-4 .silent_index {minor} idx 22-4 .silent_index {numeric} idx 22-4 .silent_index {mode} idx 22-4 .silent_index {toggling} idx 22-4 .silent_index {Auto} idx 22-5 .silent_index {Fill} idx 22-5 |
Added psl-1983/3-1/doc/nmode/nm-definitions.contents version [9e459575be].
> | 1 | contents_entry(0 25 {Definitions} 25-1) |
Added psl-1983/3-1/doc/nmode/nm-definitions.ibm version [41d6d8c3f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-DEFINITIONS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Definitions) Page 25-1 202/25. Definitions 201/This section defines a number of terms used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Defun 201/A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Paragraph 201/Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Region 201/The region is that portion of text between point, the current buffer position, and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Sentence 201/A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ |
Added psl-1983/3-1/doc/nmode/nm-definitions.topic version [25c09e723f].
> > > > | 1 2 3 4 | .silent_index {Defun} idx 25-1 .silent_index {Paragraph} idx 25-1 .silent_index {Region} idx 25-1 .silent_index {Sentence} idx 25-1 |
Added psl-1983/3-1/doc/nmode/nm-display.contents version [899dc2c883].
> | 1 | contents_entry(0 17 {Controlling the Display} 17-1) |
Added psl-1983/3-1/doc/nmode/nm-display.function version [c8839a0506].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | .silent_index {nmode-refresh-command} idx 17-1 .silent_index {nmode-full-refresh} idx 17-1 .silent_index {next-screen-command} idx 17-2 .silent_index {previous-screen-command} idx 17-2 .silent_index {scroll-window-up-line-command} idx 17-2 .silent_index {scroll-window-down-line-command} idx 17-2 .silent_index {scroll-window-up-page-command} idx 17-2 .silent_index {scroll-window-down-page-command} idx 17-2 .silent_index {reposition-window-command} idx 17-2 .silent_index {scroll-window-left-command} idx 17-2 .silent_index {scroll-window-right-command} idx 17-2 .silent_index {move-to-screen-edge-command} idx 17-2 |
Added psl-1983/3-1/doc/nmode/nm-display.ibm version [388cd68bdd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-DISPLAY.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Controlling the Display) Page 17-1 202/17. Controlling the Display 201/Since only part of a large file fits on the screen, NMODE tries to show the part that is likely to be interesting. The display control commands allow you to ask to see a different part of the file. C-L Clear and redisplay screen, putting point at a specified vertical position. ESC-J Clear and rewrite display, but without moving text or point. C-V Scroll forwards (a screen or a few lines). M-V Scroll backwards. M-R Move point to the text at a given vertical position. C-M-R Shift the function point is in onto the screen. ESC-S scroll window up line ESC-T scroll window down line ESC-U scroll window up page ESC-V scroll window down page C-X < scroll window left C-X > scroll window right The terminal screen is rarely large enough to display all of your file. If the whole buffer doesn't fit on the screen, NMODE shows a contiguous portion of it, containing point. It continues to show approximately the same portion until point moves outside of it; then NMODE chooses a new portion centered around the new point. This is NMODE's guess as to what you are most interested in seeing. But if the guess is wrong, you can use the display control commands to see a different portion. The finite area of screen through which you can see part of the buffer is called 202/the window201/, and the choice of where in the buffer to start displaying is also called 202/the window201/. The basic display control command is C-L (203/nmode-refresh-command201/). In its simplest form, with no argument, it clears the screen and tells NMODE to choose a new window position. If enough of the buffer is above point, NMODE will pick the window's position in the file so that point is about two-thirds of the way down the screen. If there is not enough of the buffer above point to fill up two-thirds of the screen, NMODE will pick the window position so that point is one-third of the way down the screen. If there isn't even enough of the buffer above point to fill a third of the screen, NMODE will put the top of the buffer at the top of the screen and let point fall where it may. Another command that can be used to help clear up the screen is ESC-J (203/nmode-full-refresh201/). This clears and rewrites the display, but without changing the portion of the buffer displayed on the screen. C-L with a positive argument chooses a new window so as to put point that many lines from the top. An argument of zero puts point on the very top line. Point does not move with respect to the text; rather, the text and point move rigidly on the screen. C-L with a negative argument puts point that many lines from the bottom of the window. For example, C-U -1 C-L puts point on the bottom line, and C-U -5 C-L puts it five lines from the bottom. C-L with an argument does not clear the screen, so that it can move the text on the screen instead of printing it again if the terminal allows that. 201/Page 17-2 NMODE Manual (Controlling the Display) The 202/scrolling 201/commands C-V and M-V let you move the whole display up or down a few lines. C-V (203/next-screen-command201/) with an argument shows you that many more lines at the bottom of the screen, moving the text and point up together as C-L might. C-V with a negative argument shows you more lines at the top of the screen, as does Meta-V (203/previous-screen-command201/) with a positive argument. There are two other commands that let you move the whole display up or down by a few lines. These are ESC-S (203/scroll-window-up-line-command201/) and ESC-T (203/scroll-window-down-line-command201/). These move text and point together up and down respectively relative to the screen. To read the buffer a screenful at a time, use the C-V command with no argument. Each C-V shows the "next screenful" of text. Point is put at the same point on the screen as on the previous screen. To move backward, use M-V without an argument, which moves a whole screenful backwards. To move by multiple screenfuls in the buffer, ESC-U (203/scroll-window-up-page-command201/) and ESC-V (203/scroll-window-down-page-command201/) can be used. These functions accept command arguments and then move the text in the screen up or down by command-argument pages. They will reverse direction if given negative arguments. In Lisp mode, one can use the C-M-R command (203/reposition-window-command201/) to scroll the buffer so that the current function (defun) is positioned conveniently on the screen. This command tries to get as much as possible of the current function, preferring the beginning to the end, but not moving point off the screen. There are also commands to scroll the window horizontally. C-X < (203/scroll-window-left-command201/) and C-X > (203/scroll-window-right-command201/). These scroll the portion of the buffer viewed by the screen to the left or right respectively. These commands have the opposite movement conventions from the other scrolling commands. In all the other commands, one gets the correct direction of movement by imagining that it is the characters visible on the CRT that are moving. For these commands one should think of the screen as a movable hole looking at the buffer, and it is the movement of the hole that is named by the commands. C-L in all its forms changes the position of point on the screen, carrying the text with it. Another command moves point the same way but leaves the text fixed. It is called Meta-R (203/move-to-screen-edge-command201/). With no argument, it puts point in the line at the center of the screen, at the current vertical column. An argument is used to specify the line to put it on, counting from the top if the argument is positive, or from the bottom if it is negative. Thus, Meta-R with an argument of 0 puts point on the top line of the screen. Meta-R never causes any text to move on the screen; it causes point to move with respect to the screen and the text. |
Added psl-1983/3-1/doc/nmode/nm-display.key version [6856d52dfc].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | .silent_index {C-L} idx 17-1 .silent_index {ESC-J} idx 17-1 .silent_index {C-V} idx 17-2 .silent_index {M-V} idx 17-2 .silent_index {ESC-S} idx 17-2 .silent_index {ESC-T} idx 17-2 .silent_index {ESC-U} idx 17-2 .silent_index {ESC-V} idx 17-2 .silent_index {C-M-R} idx 17-2 .silent_index {C-X} idx 17-2 .silent_index {C-X} idx 17-2 .silent_index {M-R} idx 17-2 |
Added psl-1983/3-1/doc/nmode/nm-display.r version [751dd29383].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-DISPLAY manual @Chapter[Controlling the Display] @node("display") @index{scrolling} @index{screen} Since only part of a large file fits on the screen, NMODE tries to show the part that is likely to be interesting. The display control commands allow you to ask to see a different part of the file. @Commands[ C-L Clear and redisplay screen, putting point at a specified vertical position. ESC-J Clear and rewrite display, but without moving text or point. C-V Scroll forwards (a screen or a few lines). M-V Scroll backwards. M-R Move point to the text at a given vertical position. C-M-R Shift the function point is in onto the screen. ESC-S scroll window up line ESC-T scroll window down line ESC-U scroll window up page ESC-V scroll window down page C-X < scroll window left C-X > scroll window right ] The terminal screen is rarely large enough to display all of your file. If the whole buffer doesn't fit on the screen, NMODE shows a contiguous portion of it, containing point. It continues to show approximately the same portion until point moves outside of it; then NMODE chooses a new portion centered around the new point. This is NMODE's guess as to what you are most interested in seeing. But if the guess is wrong, you can use the display control commands to see a different portion. The finite area of screen through which you can see part of the buffer is called @dfn[the window], and the choice of where in the buffer to start displaying is also called @dfn[the window]. @keyindex{C-L} @index{clear screen} @fncindex{nmode-refresh-command} The basic display control command is C-L (@fnc{nmode-refresh-command}). In its simplest form, with no argument, it clears the screen and tells NMODE to choose a new window position. If enough of the buffer is above point, NMODE will pick the window's position in the file so that point is about two-thirds of the way down the screen. If there is not enough of the buffer above point to fill up two-thirds of the screen, NMODE will pick the window position so that point is one-third of the way down the screen. If there isn't even enough of the buffer above point to fill a third of the screen, NMODE will put the top of the buffer at the top of the screen and let point fall where it may. @keyindex{ESC-J} @fncindex{nmode-full-refresh} Another command that can be used to help clear up the screen is ESC-J (@fnc{nmode-full-refresh}). This clears and rewrites the display, but without changing the portion of the buffer displayed on the screen. @index{numeric arguments} C-L with a positive argument chooses a new window so as to put point that many lines from the top. An argument of zero puts point on the very top line. Point does not move with respect to the text; rather, the text and point move rigidly on the screen. C-L with a negative argument puts point that many lines from the bottom of the window. For example, @w[C-U -1] C-L puts point on the bottom line, and @w[C-U -5] C-L puts it five lines from the bottom. C-L with an argument does not clear the screen, so that it can move the text on the screen instead of printing it again if the terminal allows that. @keyindex{C-V} @keyindex{M-V} @fncindex{next-screen-command} @fncindex{previous-screen-command} @index{Scrolling} The @dfn[scrolling] commands C-V and M-V let you move the whole display up or down a few lines. C-V (@fnc{next-screen-command}) with an argument shows you that many more lines at the bottom of the screen, moving the text and point up together as C-L might. C-V with a negative argument shows you more lines at the top of the screen, as does Meta-V (@fnc{previous-screen-command}) with a positive argument. @keyindex{ESC-S} @fncindex{scroll-window-up-line-command} @keyindex{ESC-T} @fncindex{scroll-window-down-line-command} There are two other commands that let you move the whole display up or down by a few lines. These are ESC-S (@fnc{scroll-window-up-line-command}) and ESC-T (@fnc{scroll-window-down-line-command}). These move text and point together up and down respectively relative to the screen. To read the buffer a screenful at a time, use the C-V command with no argument. Each C-V shows the "next screenful" of text. Point is put at the same point on the screen as on the previous screen. To move backward, use M-V without an argument, which moves a whole screenful backwards. @keyindex{ESC-U} @fncindex{scroll-window-up-page-command} @keyindex{ESC-V} @fncindex{scroll-window-down-page-command} To move by multiple screenfuls in the buffer, ESC-U (@fnc{scroll-window-up-page-command}) and ESC-V (@fnc{scroll-window-down-page-command}) can be used. These functions accept command arguments and then move the text in the screen up or down by command-argument pages. They will reverse direction if given negative arguments. @keyindex{C-M-R} @fncindex{reposition-window-command} In Lisp mode, one can use the C-M-R command (@fnc{reposition-window-command}) to scroll the buffer so that the current function (defun) is positioned conveniently on the screen. This command tries to get as much as possible of the current function, preferring the beginning to the end, but not moving point off the screen. @keyindex{C-X <} @fncindex{scroll-window-left-command} @keyindex{C-X >} @fncindex{scroll-window-right-command} There are also commands to scroll the window horizontally. C-X < (@fnc{scroll-window-left-command}) and C-X > (@fnc{scroll-window-right-command}). These scroll the portion of the buffer viewed by the screen to the left or right respectively. These commands have the opposite movement conventions from the other scrolling commands. In all the other commands, one gets the correct direction of movement by imagining that it is the characters visible on the CRT that are moving. For these commands one should think of the screen as a movable hole looking at the buffer, and it is the movement of the hole that is named by the commands. @keyindex{M-R} @fncindex{move-to-screen-edge-command} C-L in all its forms changes the position of point on the screen, carrying the text with it. Another command moves point the same way but leaves the text fixed. It is called Meta-R (@fnc{move-to-screen-edge-command}). With no argument, it puts point in the line at the center of the screen, at the current vertical column. An argument is used to specify the line to put it on, counting from the top if the argument is positive, or from the bottom if it is negative. Thus, Meta-R with an argument of 0 puts point on the top line of the screen. Meta-R never causes any text to move on the screen; it causes point to move with respect to the screen and the text. |
Added psl-1983/3-1/doc/nmode/nm-display.topic version [b14633b15c].
> > > > > | 1 2 3 4 5 | .silent_index {scrolling} idx 17-1 .silent_index {screen} idx 17-1 .silent_index {clear} idx 17-1 .silent_index {numeric} idx 17-1 .silent_index {Scrolling} idx 17-2 |
Added psl-1983/3-1/doc/nmode/nm-editing.contents version [86349a3b14].
> > > > > > | 1 2 3 4 5 6 | contents_entry(0 4 {Basic Editing Commands} 4-1) contents_entry(1 4.1 {Inserting Text} 4-1) contents_entry(1 4.2 {Moving The Cursor} 4-1) contents_entry(1 4.3 {Erasing Text} 4-2) contents_entry(1 4.4 {Files} 4-3) contents_entry(1 4.5 {Using Blank Lines Can Make Editing Faster} 4-3) |
Added psl-1983/3-1/doc/nmode/nm-editing.function version [097575bec9].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | .silent_index {delete-backward-character-command} idx 4-1 .silent_index {return-command} idx 4-1 .silent_index {insert-next-character-command} idx 4-1 .silent_index {move-down-command} idx 4-1 .silent_index {move-to-start-of-line-command} idx 4-1 .silent_index {move-to-end-of-line-command} idx 4-1 .silent_index {move-forward-character-command} idx 4-1 .silent_index {move-backward-character-command} idx 4-1 .silent_index {move-down-extending-command} idx 4-1 .silent_index {move-up-command} idx 4-1 .silent_index {nmode-refresh-command} idx 4-1 .silent_index {transpose-characters-command} idx 4-1 .silent_index {move-to-buffer-start-command} idx 4-1 .silent_index {move-to-buffer-end-command} idx 4-1 .silent_index {set-goal-column-command} idx 4-2 .silent_index {what-cursor-position-command} idx 4-2 .silent_index {visit-file-command} idx 4-3 .silent_index {save-file-command} idx 4-3 .silent_index {open-line-command} idx 4-3 .silent_index {delete-blank-lines-command} idx 4-3 |
Added psl-1983/3-1/doc/nmode/nm-editing.ibm version [1a6a8caa96].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-EDITING.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Basic Editing Commands) Page 4-1 202/4. Basic Editing Commands 201/We now give the basics of how to enter text, make corrections, and save the text in a file. If this material is new to you, you might learn it more easily by running the NTEACH program. 202/4.1 Inserting Text 201/To insert printing characters into the text you are editing, just type them. When the selected buffer is an editing buffer, all printing characters you type are inserted into the text at the cursor (that is, at 202/point201/), and the cursor moves forward. Any characters after the cursor move forward too. If the text in the buffer is FOOBAR, with the cursor before the B, then if you type XX, you get FOOXXBAR, with the cursor still before the B. To correct text you have just inserted, you can use Backspace. Backspace deletes the character 203/before 201/the cursor (not the one that the cursor is on top of or under; that is the character 203/after 201/the cursor). The cursor and all characters after it move backwards. Therefore, if you type a printing character and then type Backspace, they cancel out. To end a line and start typing a new one, type Return (Customizers, note: this runs the function 203/return-command201/). Return operates by inserting a line separator, so if you type Return in the middle of a line, you break the line in two. If you add too many characters to one line, without breaking it with a Return, the line will display a "!" at the extreme right margin. This does not stop you from adding further characters, but those characters will not be visible until the line is somehow broken, or until you scroll the window horizontally using C-X >. Direct insertion works for printing characters and space, but other characters act as editing commands and do not insert themselves. If you need to insert a control character, Altmode, Tab, Backspace or Rubout, you must 202/quote 201/it by typing the Control-Q (203/insert-next-character-command201/) command first. See Section 3 [Control], page 1. 202/4.2 Moving The Cursor 201/To do more than insert characters, you have to know how to move the cursor. Here are a few of the commands for doing that. C-A Move to the beginning of the line. C-E Move to the end of the line. C-F Move forward over one character. ESC-C Same as C-F. Many terminals have an arrow key pointing right which sends this escape sequence. 201/Page 4-2 NMODE Manual (Moving The Cursor) C-B Move backward over one character. ESC-D Same as C-B. Many terminals have an arrow key pointing left which sends this escape sequence. C-N Move down one line, vertically. If you start in the middle of one line, you end in the middle of the next. From the last line of text, it creates a new line. ESC-B Same as C-N except that it will not create a new line. Many terminals have an arrow key pointing down which sends this escape sequence. C-P Move up one line, vertically. ESC-A Same as C-P. Many terminals have an arrow key pointing up which sends this escape sequence. C-L Clear the screen and reprints everything. C-U C-L reprints just the line that the cursor is on. C-T Transpose two characters (the ones before and after the cursor). M-< Move to the top of your text. M-> Move to the end of your text. There is a special command: C-X C-N (203/set-goal-column-command201/), which affects how C-P, ESC-A, C-N, and ESC-B act. Without an argument, C-X C-N will store the current column so that the vertical movement commands will try to move into it when they move point up or down, regardless of the column that point is in prior to the vertical movement. To remove the goal column, give the C-X C-N command with an argument. There is a command, C-X = (203/what-cursor-position-command201/), which is normally used to obtain information about where one is in a buffer. If given an argument, however, it will treat the argument as a line-number and it will jump to the corresponding line. 202/4.3 Erasing Text 201/Backspace Delete the character before the cursor. C-D Delete the character after the cursor. C-K Kill to the end of the line. You already know about the Backspace command which deletes the character before the cursor. Another command, Control-D, deletes the character after the cursor, causing the rest of the text on the line to shift left. If Control-D is typed at the end of a line, that line and the next line are joined together. To erase a larger amount of text, use the Control-K command, which kills a line at a time. If Control-K is done at the beginning or middle of a line, it kills all the text up to the end of the line. If Control-K is done at the end of a line, it joins that line and the next line. See Section 11 [Killing], page 1, for more flexible ways of killing text. 201/NMODE Manual (Files) Page 4-3 202/4.4 Files 201/The commands above are sufficient for creating text in the NMODE buffer. The more advanced NMODE commands just make things easier. But to keep any text permanently you must put it in a 202/file201/. Files are the objects which the operating system uses for storing data for communication between different programs or to hold onto for a length of time. To tell NMODE to edit text in a file, choose a 202/filename201/, such as FOO, and type C-X C-V FOO<CR>. This 202/visits 201/the file FOO so that its contents appear on the screen for editing. You can make changes, and then 202/save 201/the file by typing C-X C-S. This makes the changes permanent and actually changes the file FOO. Until then, the changes are only inside your NMODE, and the file FOO is not really changed. If the file FOO doesn't exist, and you want to create it, visit it as if it did exist. When you save your text with C-X C-S the file will be created. Of course, there is a lot more to learn about using files. See Section 15 [Files], page 1. 202/4.5 Using Blank Lines Can Make Editing Faster 201/C-O Insert one or more blank lines after the cursor. C-X C-O Delete all but one of many consecutive blank lines. It is much more efficient to insert text at the end of a line than in the middle. So if you want to stick a new line before an existing one, the best way is to make a blank line there first and then type the text into it, rather than inserting the new text at the beginning of the existing line and finally inserting a line separator. Making the blank line first also makes the meaning of the text clearer while you are typing it in. To make a blank line, you can type Return and then C-B. But there is a single character for this: C-O (Customizers: this is the function 203/open-line-command201/) So, FOO<CR> is equivalent to C-O FOO C-F. If you want to insert many lines, you can type many C-O's at the beginning (or you can give C-O an argument to tell it how many blank lines to make. See Section 5 [Arguments], page 1, for how). As you then insert lines of text, you will notice that Return behaves strangely: it "uses up" the blank lines instead of pushing them down. If you don't use up all the blank lines, you can type C-X C-O (the function 203/delete-blank-lines-command201/) to get rid of all but one. When point is on a blank line, C-X C-O replaces all the blank lines around that one with a single blank line. When point is on a nonblank line, C-X C-O deletes any blank lines following that nonblank line. |
Added psl-1983/3-1/doc/nmode/nm-editing.key version [53f0d748e4].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | .silent_index {C-Q} idx 4-1 .silent_index {C-A} idx 4-1 .silent_index {C-E} idx 4-1 .silent_index {C-F} idx 4-1 .silent_index {ESC-C} idx 4-1 .silent_index {C-B} idx 4-1 .silent_index {ESC-D} idx 4-1 .silent_index {C-N} idx 4-1 .silent_index {ESC-B} idx 4-1 .silent_index {C-P} idx 4-1 .silent_index {ESC-A} idx 4-1 .silent_index {C-L} idx 4-1 .silent_index {C-T} idx 4-1 .silent_index {M->} idx 4-1 .silent_index {M-<} idx 4-1 .silent_index {C-X} idx 4-2 .silent_index {C-X} idx 4-2 .silent_index {C-D} idx 4-2 .silent_index {C-K} idx 4-2 .silent_index {C-X} idx 4-3 .silent_index {C-X} idx 4-3 .silent_index {C-O} idx 4-3 .silent_index {C-X} idx 4-3 |
Added psl-1983/3-1/doc/nmode/nm-editing.r version [09db99db40].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-EDITING manual @Chapter[Basic Editing Commands] @node("editing") @node("basic") We now give the basics of how to enter text, make corrections, and save the text in a file. If this material is new to you, you might learn it more easily by running the NTEACH program. @Section[Inserting Text] @index{insertion} @index{point} @index{cursor} @index{printing characters} To insert printing characters into the text you are editing, just type them. When the selected buffer is an editing buffer, When NMODE is in either Text or Lisp mode, all printing characters you type are inserted into the text at the cursor (that is, at @dfn[point]), and the cursor moves forward. Any characters after the cursor move forward too. If the text in the buffer is FOOBAR, with the cursor before the B, then if you type XX, you get FOOXXBAR, with the cursor still before the B. @index{Backspace} @index{deletion} @fncindex{delete-backward-character-command} To correct text you have just inserted, you can use Backspace. Backspace deletes the character @xxii[before] the cursor (not the one that the cursor is on top of or under; that is the character @xxii[after] the cursor). The cursor and all characters after it move backwards. Therefore, if you type a printing character and then type Backspace, they cancel out. @index{@Return1{}} @index{CRLF} @fncindex{return-command} @index{line separator} To end a line and start typing a new one, type @Return3{} (Customizers, note: this runs the function @fnc{return-command}). @Return3{} operates by inserting a line separator, so if you type @Return3{} in the middle of a line, you break the line in two. @index{!} If you add too many characters to one line, without breaking it with a @Return3{}, the line will display a "!" at the extreme right margin. This does not stop you from adding further characters, but those characters will not be visible until the line is somehow broken, or until you scroll the window horizontally using C-X >. @index{Quoting} @index{Control characters, inserting} @keyindex{C-Q} @fncindex{insert-next-character-command} Direct insertion works for printing characters and space, but other characters act as editing commands and do not insert themselves. If you need to insert a control character, Altmode, Tab, Backspace or Rubout, you must @dfn[quote] it by typing the Control-Q (@fnc{insert-next-character-command}) command first. @Note("Characters" "Control"). @Section[Moving The Cursor] To do more than insert characters, you have to know how to move the cursor. Here are a few of the commands for doing that. @keyindex{C-A} @keyindex{C-E} @keyindex{C-F} @keyindex{ESC-C} @keyindex{C-B} @keyindex{ESC-D} @keyindex{C-N} @keyindex{ESC-B} @keyindex{C-P} @keyindex{ESC-A} @keyindex{C-L} @keyindex{C-T} @keyindex{M->} @keyindex{M-<} @fncindex{move-down-command} @fncindex{move-to-start-of-line-command} @fncindex{move-to-end-of-line-command} @fncindex{move-forward-character-command} @fncindex{move-backward-character-command} @fncindex{move-down-extending-command} @fncindex{move-up-command} @fncindex{nmode-refresh-command} @fncindex{transpose-characters-command} @fncindex{move-to-buffer-start-command} @fncindex{move-to-buffer-end-command} @Commands[ C-A Move to the beginning of the line. C-E Move to the end of the line. C-F Move forward over one character. ESC-C Same as C-F. Many terminals have an arrow key pointing right which sends this escape sequence. C-B Move backward over one character. ESC-D Same as C-B. Many terminals have an arrow key pointing left which sends this escape sequence. C-N Move down one line, vertically. If you start in the middle of one line, you end in the middle of the next. From the last line of text, it creates a new line. ESC-B Same as C-N except that it will not create a new line. Many terminals have an arrow key pointing down which sends this escape sequence. C-P Move up one line, vertically. ESC-A Same as C-P. Many terminals have an arrow key pointing up which sends this escape sequence. C-L Clear the screen and reprints everything. @w[C-U C-L] reprints just the line that the cursor is on. C-T Transpose two characters (the ones before and after the cursor). M-< Move to the top of your text. M-> Move to the end of your text. ] @keyindex{C-X C-N} @fncindex{set-goal-column-command} There is a special command: C-X C-N (@fnc{set-goal-column-command}), which affects how C-P, ESC-A, C-N, and ESC-B act. Without an argument, C-X C-N will store the current column so that the vertical movement commands will try to move into it when they move point up or down, regardless of the column that point is in prior to the vertical movement. To remove the goal column, give the C-X C-N command with an argument. @keyindex{C-X =} @fncindex{what-cursor-position-command} There is a command, C-X = (@fnc{what-cursor-position-command}), which is normally used to obtain information about where one is in a buffer. If given an argument, however, it will treat the argument as a line-number and it will jump to the corresponding line. @Section[Erasing Text] @Commands[ Backspace Delete the character before the cursor. C-D Delete the character after the cursor. C-K Kill to the end of the line. ] @Index{Backspace} @Keyindex{C-D} @Keyindex{C-K} You already know about the Backspace command which deletes the character before the cursor. Another command, Control-D, deletes the character after the cursor, causing the rest of the text on the line to shift left. If Control-D is typed at the end of a line, that line and the next line are joined together. To erase a larger amount of text, use the Control-K command, which kills a line at a time. If Control-K is done at the beginning or middle of a line, it kills all the text up to the end of the line. If Control-K is done at the end of a line, it joins that line and the next line. @Note("Killing"), for more flexible ways of killing text. @Section[Files] @index{files} @keyindex{C-X C-V} @index{visiting} @keyindex{C-X C-S} @fncindex{visit-file-command} @fncindex{save-file-command} The commands above are sufficient for creating text in the NMODE buffer. The more advanced NMODE commands just make things easier. But to keep any text permanently you must put it in a @dfn[file]. Files are the objects which the operating system uses for storing data for communication between different programs or to hold onto for a length of time. To tell NMODE to edit text in a file, choose a @dfn[filename], such as FOO, and type C-X C-V FOO@return2{}. This @dfn[visits] the file FOO so that its contents appear on the screen for editing. You can make changes, and then @dfn[save] the file by typing C-X C-S. This makes the changes permanent and actually changes the file FOO. Until then, the changes are only inside your NMODE, and the file FOO is not really changed. If the file FOO doesn't exist, and you want to create it, visit it as if it did exist. When you save your text with C-X C-S the file will be created. Of course, there is a lot more to learn about using files. @Note("Files"). @Section[Using Blank Lines Can Make Editing Faster] @WideCommands[ C-O Insert one or more blank lines after the cursor. C-X C-O Delete all but one of many consecutive blank lines. ] @keyindex{C-O} @keyindex{C-X C-O} @index{blank lines} @fncindex{open-line-command} @fncindex{delete-blank-lines-command} It is much more efficient to insert text at the end of a line than in the middle. So if you want to stick a new line before an existing one, the best way is to make a blank line there first and then type the text into it, rather than inserting the new text at the beginning of the existing line and finally inserting a line separator. Making the blank line first also makes the meaning of the text clearer while you are typing it in. To make a blank line, you can type @Return3{} and then C-B. But there is a single character for this: C-O (Customizers: this is the function @fnc{open-line-command}) So, FOO@Return2{} is equivalent to C-O FOO C-F. If you want to insert many lines, you can type many C-O's at the beginning (or you can give C-O an argument to tell it how many blank lines to make. @Note("Arguments"), for how). As you then insert lines of text, you will notice that @Return3{} behaves strangely: it "uses up" the blank lines instead of pushing them down. If you don't use up all the blank lines, you can type C-X C-O (the function @fnc{delete-blank-lines-command}) to get rid of all but one. When point is on a blank line, C-X C-O replaces all the blank lines around that one with a single blank line. When point is on a nonblank line, C-X C-O deletes any blank lines following that nonblank line. |
Added psl-1983/3-1/doc/nmode/nm-editing.topic version [cb1bc6379e].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | .silent_index {insertion} idx 4-1 .silent_index {point} idx 4-1 .silent_index {cursor} idx 4-1 .silent_index {printing} idx 4-1 .silent_index {Backspace} idx 4-1 .silent_index {deletion} idx 4-1 .silent_index {Return1{}} idx 4-1 .silent_index {CRLF} idx 4-1 .silent_index {line} idx 4-1 .silent_index {!} idx 4-1 .silent_index {Quoting} idx 4-1 .silent_index {Control} idx 4-1 .silent_index {Backspace} idx 4-2 .silent_index {files} idx 4-3 .silent_index {visiting} idx 4-3 .silent_index {blank} idx 4-3 |
Added psl-1983/3-1/doc/nmode/nm-files.contents version [192f14a4d0].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | contents_entry(0 15 {File Handling} 15-1) contents_entry(1 15.1 {Visiting Files} 15-1) contents_entry(1 15.2 {How to Undo Drastic Changes to a File} 15-2) contents_entry(1 15.3 {Listing a File Directory} 15-2) contents_entry(1 15.4 {DIRED, the Directory Editor Subsystem} 15-2) contents_entry(2 15.4.1 {Basic DIRED Commands} 15-2) contents_entry(2 15.4.2 {Other DIRED Commands} 15-3) contents_entry(2 15.4.3 {Invoking DIRED} 15-3) contents_entry(1 15.5 {Miscellaneous File Operations} 15-3) |
Added psl-1983/3-1/doc/nmode/nm-files.function version [abbc8b9e75].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | .silent_index {visit-file-command} idx 15-1 .silent_index {save-file-command} idx 15-1 .silent_index {buffer-not-modified-command} idx 15-2 .silent_index {revert-file-command} idx 15-2 .silent_index {dired-command} idx 15-2 .silent_index {edit-directory-command} idx 15-2 .silent_index {dired-command} idx 15-3 .silent_index {write-file-command} idx 15-3 .silent_index {insert-file-command} idx 15-4 .silent_index {write-region-command} idx 15-4 .silent_index {append-to-file-command} idx 15-4 .silent_index {prepend-to-file-command} idx 15-4 .silent_index {set-visited-filename-command} idx 15-4 .silent_index {delete-file-command} idx 15-4 .silent_index {delete-and-expunge-file-command} idx 15-4 .silent_index {undelete-file-command} idx 15-4 |
Added psl-1983/3-1/doc/nmode/nm-files.ibm version [1b4369e0ec].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-FILES.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (File Handling) Page 15-1 202/15. File Handling 201/The basic unit of stored data is the file. Each program, each paper, lives usually in its own file. To edit a program or paper, the editor must be told the name of the file that contains it. This is called 202/visiting 201/the file. To make your changes to the file permanent on disk, you must 202/save 201/the file. NMODE also has facilities for deleting files conveniently, and for listing your file directory. 202/15.1 Visiting Files 201/C-X C-V Visit a file. C-X C-S Save the visited file. Meta-~ Tell NMODE to forget that the buffer has been changed. 202/Visiting 201/a file means copying its contents into NMODE where you can edit them. NMODE remembers the name of the file you visited. Unless you use the multiple buffer or window features of NMODE, you can only be visiting one file at a time. The name of the file you are visiting in the currently selected buffer is visible in the mode line. The changes you make with NMODE are made in a copy inside NMODE. The file itself is not changed. The changed text is not permanent until you 202/save 201/it in a file. The first time you change the text, a star appears at the end of the mode line; this indicates that the text contains fresh changes which will be lost unless you save them. To visit a file, use the command C-X C-V (203/visit-file-command201/). Follow the command with the name of the file you wish to visit, terminated by a Return. After C-X C-V is entered, 203/visit-file-command 201/will display a prompt. This prompt may contain a default filename, if so then any component of the filename which you don't specify is taken from it. You can abort the command by typing C-G, or edit the filename with normal NMODE editing commands. If you do type a Return to finish the command, the new file's text appears on the screen, and its name appears in the mode line. When you wish to save the file and make your changes permanent, type C-X C-S (203/save-file-command201/). After the save is finished, C-X C-S prints "Written: <filename>" in the echo area at the bottom of the screen. If there are no changes to save (no star at the end of the mode line), the file is not saved; it would be redundant to save a duplicate of the previous version. What if you want to create a file? Just visit it. NMODE prints "(New File)" but aside from that behaves as if you had visited an existing empty file. If you make any changes and save them, the file is created. If you visit a nonexistent file unintentionally (because you typed the wrong file name), go ahead and visit the file you meant. If you don't save the unwanted file, it is not created. If you alter one file and then visit another in the same buffer, NMODE offers to save the old one. If you answer YES, the old file is saved; if you answer NO, all the changes you have made to it since the last save are lost. 201/Page 15-2 NMODE Manual (Visiting Files) Sometimes you will change a buffer by accident. Even if you undo the change by hand, NMODE still knows that "the buffer has been changed". You can tell NMODE to believe that there have been no changes with the Meta-~ (203/buffer-not-modified-command201/) command. This command simply clears the "modified" flag which says that the buffer contains changes which need to be saved. Even if the buffer really 203/is 201/changed NMODE will still act as if it were not. If we take "~" to mean "not", then Meta-~ is "not", metafied. 202/15.2 How to Undo Drastic Changes to a File 201/If you have made extensive changes to a file and then change your mind about them, you can get rid of them by reading in the previous version of the file. To do this, use M-X Revert File (203/revert-file-command201/). M-X Revert File does not change point, so that if the file was only edited slightly, you will be at approximately the same piece of text after the Revert as before. If you have made drastic changes, the same value of point in the old file may address a totally different piece of text. 202/15.3 Listing a File Directory 201/To look at a file directory, use the C-X D command (203/dired-command201/). With no argument, it shows you the directory of the file you are visiting. C-U C-X D reads a directory specification from the keyboard and shows you the files related to that directory specification. M-X DIRED (203/edit-directory-command201/) differs in that it prompts for a directory specification even without an argument. 202/15.4 DIRED, the Directory Editor Subsystem 201/DIRED makes it easy to delete many of the files in a single directory at once. It presents a copy of a listing of the directory, which you can move around in, marking files for deletion. When you are satisfied, you can tell DIRED to go ahead and delete the marked files. Invoke DIRED with C-X D or M-X DIRED<CR><CR> to edit the current default directory, or M-X DIRED<CR><dir><CR> to edit directory <dir>. You are then given a listing of the directory which you can move around in with all the normal NMODE motion commands. Some NMODE commands are made undefined and others do special things, but it's still a recursive editing level which you can exit normally with Q. 202/15.4.1 Basic DIRED Commands 201/You can mark a file for deletion by moving to the line describing the file and typing D. The deletion mark is visible as a D at the beginning of the line. Point is moved to the beginning of the next line, so that several D's delete several files. Alternatively, if you give D an argument it marks that many consecutive files. Given a negative argument, it marks the preceding file (or several files) and puts point at the first (in the buffer) line marked. Most of the DIRED commands (D, U, E, Space) repeat this way with numeric arguments. 201/NMODE Manual (Basic DIRED Commands) Page 15-3 If you wish to remove a deletion mark, use the U (for Undelete) command, which is invoked like D: it removes the deletion mark from the current line (or next few lines, if given an argument). The Rubout command removes the deletion mark from the previous line, moving up to that line. Thus, a Rubout after a D precisely cancels the D. For extra convenience, Space is made a command similar to C-N. Moving down a line is done so often in DIRED that it deserves to be easy to type. Rubout is often useful simply for moving up. If you are not sure whether you want to delete a file, you can examine it by typing E. This enters a recursive editing mode on the file, which you can exit with C-M-L. This also allows you to modify files. When you exit the recursive editing level, you return to DIRED. When you have marked the files you wish to mark, you can exit DIRED with Q. If any files were marked for deletion, DIRED lists them in a concise format, several per line. You can type "YES" (Just "Y" won't do) to go ahead and delete them, "N" to return to editing the directory so you can change the marks, or "X" to give up and delete nothing. No Return character is needed. No other inputs are accepted at this point. 202/15.4.2 Other DIRED Commands 201/S sorts the files into a different order. It reads another character to say which order: F for filename (the default), S for size, R for read date, or W for write date. R does the same sorting as S, but uses the reverse order (small files, older files or end of alphabet first). ? displays documentation on DIRED. 202/15.4.3 Invoking DIRED 201/There are some other ways to invoke DIRED. The command C-X D (203/dired-command201/) puts you in DIRED on the directory containing the file you are currently editing. With a numeric argument of 1 (C-U 1 C-X D), only the current file is displayed instead of the whole directory. This is present for historical reasons. On file systems which contain multiple versions of files, such as twenex, this allows one to see how much space old versions of a file are consuming. With a numeric argument of 4 (C-U C-X D), it asks you for the directory name. Type a directory name and/or a file name. If you explicitly specify a file name only versions of that file are displayed, otherwise the whole directory is displayed. 202/15.5 Miscellaneous File Operations 201/NMODE has extended commands for performing many other operations on files. M-X Write File<CR><file><CR> (203/write-file-command201/) writes the contents of the buffer into the file <file>, and then visits that file. It can be thought of 201/Page 15-4 NMODE Manual (Miscellaneous File Operations) as a way of "changing the name" of the file you are visiting. Unlike C-X C-S, Write File saves even if the buffer has not been changed. C-X C-W is another way of getting at this command. M-X Insert File<CR><file><CR> (203/insert-file-command201/) inserts the contents of <file> into the buffer at point, leaving point unchanged before the contents and mark after them. M-X Write Region<CR><file><CR> (203/write-region-command201/) writes the region (the text between point and mark) to the specified file. It does not set the visited filename. The buffer is not changed. M-X Append to File<CR><file><CR> (203/append-to-file-command201/) appends the region to <file>. The text is added to the end of <file>. M-X Prepend to File<CR><file><CR> (203/prepend-to-file-command201/) adds the text to the beginning of <file> instead of the end. M-X Set Visited Filename<CR><file><CR> (203/set-visited-filename-command201/) changes the name of the file being visited without reading or writing the data in the buffer. M-X Write File is approximately equivalent to this command followed by a C-X C-S. M-X Delete File<CR><file><CR> (203/delete-file-command201/) deletes the file. In twenex this has the effect of putting the file in the directory of deleted files, from which it can be retrieved until the next expunge. On the hp9836, this has the effect of irretrievably removing the file. M-X Delete and Expunge File<CR><file><CR> (203/delete-and-expunge-file-command201/) will, if possible, irretrievably delete a file. If the operation fails, a bell will sound. M-X Undelete File<CR><file><CR> (203/undelete-file-command201/) will attempt to retrieve a deleted file. This only works on Twenex. |
Added psl-1983/3-1/doc/nmode/nm-files.key version [bb25e2acad].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | .silent_index {C-X} idx 15-1 .silent_index {C-G} idx 15-1 .silent_index {C-X} idx 15-1 .silent_index {M-~} idx 15-2 .silent_index {C-X} idx 15-2 .silent_index {M-X} idx 15-2 .silent_index {C-X} idx 15-3 .silent_index {M-X} idx 15-3 .silent_index {C-X} idx 15-3 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 .silent_index {M-X} idx 15-4 |
Added psl-1983/3-1/doc/nmode/nm-files.r version [379f9c5327].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-FILES manual @Chapter[File Handling] @node("files") The basic unit of stored data is the file. Each program, each paper, lives usually in its own file. To edit a program or paper, the editor must be told the name of the file that contains it. This is called @dfn[visiting] the file. To make your changes to the file permanent on disk, you must @dfn[save] the file. NMODE also has facilities for deleting files conveniently, and for listing your file directory. @Section[Visiting Files] @node("visiting") @WideCommands{ C-X C-V Visit a file. C-X C-S Save the visited file. Meta-~ Tell NMODE to forget that the buffer has been changed. } @index{files} @index{visiting} @index{saving} @dfn[Visiting] a file means copying its contents into NMODE where you can edit them. NMODE remembers the name of the file you visited. Unless you use the multiple buffer or window features of NMODE, you can only be visiting one file at a time. The name of the file you are visiting in the currently selected buffer is visible in the mode line. The changes you make with NMODE are made in a copy inside NMODE. The file itself is not changed. The changed text is not permanent until you @dfn[save] it in a file. The first time you change the text, a star appears at the end of the mode line; this indicates that the text contains fresh changes which will be lost unless you save them. @keyindex{C-X C-V} @keyindex{C-G} @fncindex{visit-file-command} To visit a file, use the command C-X C-V (@fnc{visit-file-command}). Follow the command with the name of the file you wish to visit, terminated by a @Return3{}. After C-X C-V is entered, @fnc{visit-file-command} will display a prompt. This prompt may contain a default filename, if so then any component of the filename which you don't specify is taken from it. You can abort the command by typing C-G, or edit the filename with normal NMODE editing commands. If you do type a @Return3{} to finish the command, the new file's text appears on the screen, and its name appears in the mode line. @keyindex{C-X C-S} @fncindex{save-file-command} When you wish to save the file and make your changes permanent, type C-X C-S (@fnc{save-file-command}). After the save is finished, C-X C-S prints "Written: <filename>" in the echo area at the bottom of the screen. If there are no changes to save (no star at the end of the mode line), the file is not saved; it would be redundant to save a duplicate of the previous version. @Index{Create File} What if you want to create a file? Just visit it. NMODE prints @w["(New File)"] but aside from that behaves as if you had visited an existing empty file. If you make any changes and save them, the file is created. If you visit a nonexistent file unintentionally (because you typed the wrong file name), go ahead and visit the file you meant. If you don't save the unwanted file, it is not created. @ITS{ @index{Set Visited Filename} When you read a file which is a link, you get the contents of the target file, but if you save under the name of the link, you break the link and a new file is created. The target does not change. If you would prefer to alter the target file, use Set Visited Filename to change the visited name to the target file's name. @Note("Filadv" "Set Visited Filename"). } @index{Visit File Save Old} If you alter one file and then visit another in the same buffer, NMODE offers to save the old one. If you answer YES, the old file is saved; if you answer NO, all the changes you have made to it since the last save are lost. @fncindex{buffer-not-modified-command} @keyindex{M-~} Sometimes you will change a buffer by accident. Even if you undo the change by hand, NMODE still knows that "the buffer has been changed". You can tell NMODE to believe that there have been no changes with the Meta-~ (@fnc{buffer-not-modified-command}) command. This command simply clears the "modified" flag which says that the buffer contains changes which need to be saved. Even if the buffer really @xxi(is) changed NMODE will still act as if it were not. If we take "~" to mean "not", then Meta-~ is "not", metafied. @Section[How to Undo Drastic Changes to a File] @node("revert") @fncindex{revert-file-command} @index{files} @index{Drastic Changes} If you have made extensive changes to a file and then change your mind about them, you can get rid of them by reading in the previous version of the file. To do this, use M-X Revert File (@fnc{revert-file-command}). M-X Revert File does not change point, so that if the file was only edited slightly, you will be at approximately the same piece of text after the Revert as before. If you have made drastic changes, the same value of point in the old file may address a totally different piece of text. @Section[Listing a File Directory] @node("listdir") @index{file directory} @keyindex{C-X D} @fncindex{dired-command} @keyindex{M-X DIRED} @fncindex{edit-directory-command} To look at a file directory, use the C-X D command (@fnc{dired-command}). With no argument, it shows you the directory of the file you are visiting. @w[C-U C-X D] reads a directory specification from the keyboard and shows you the files related to that directory specification. M-X DIRED (@fnc{edit-directory-command}) differs in that it prompts for a directory specification even without an argument. @Section[DIRED, the Directory Editor Subsystem] @node("dired") @index{DIRED} @index{file deletion} DIRED makes it easy to delete many of the files in a single directory at once. It presents a copy of a listing of the directory, which you can move around in, marking files for deletion. When you are satisfied, you can tell DIRED to go ahead and delete the marked files. @index{recursive editing level} Invoke DIRED with C-X D or M-X DIRED@Return1{}@Return2{} to edit the current default directory, or M-X DIRED@Return1{}<dir>@Return2{} to edit directory <dir>. You are then given a listing of the directory which you can move around in with all the normal NMODE motion commands. Some NMODE commands are made undefined and others do special things, but it's still a recursive editing level which you can exit normally with Q. @SubSection[Basic DIRED Commands] You can mark a file for deletion by moving to the line describing the file and typing D. The deletion mark is visible as a D at the beginning of the line. Point is moved to the beginning of the next line, so that several D's delete several files. Alternatively, if you give D an argument it marks that many consecutive files. Given a negative argument, it marks the preceding file (or several files) and puts point at the first (in the buffer) line marked. Most of the DIRED commands (D, U, E, Space) repeat this way with numeric arguments. If you wish to remove a deletion mark, use the U (for Undelete) command, which is invoked like D: it removes the deletion mark from the current line (or next few lines, if given an argument). The Rubout command removes the deletion mark from the previous line, moving up to that line. Thus, a Rubout after a D precisely cancels the D. For extra convenience, Space is made a command similar to C-N. Moving down a line is done so often in DIRED that it deserves to be easy to type. Rubout is often useful simply for moving up. If you are not sure whether you want to delete a file, you can examine it by typing E. This enters a recursive editing mode on the file, which you can exit with C-M-L. This also allows you to modify files. When you exit the recursive editing level, you return to DIRED. @index{confirmation} When you have marked the files you wish to mark, you can exit DIRED with Q. If any files were marked for deletion, DIRED lists them in a concise format, several per line. You can type "YES" (Just "Y" won't do) to go ahead and delete them, "N" to return to editing the directory so you can change the marks, or "X" to give up and delete nothing. No @Return3{} character is needed. No other inputs are accepted at this point. @SubSection[Other DIRED Commands] S sorts the files into a different order. It reads another character to say which order: F for filename (the default), S for size, R for read date, or W for write date. R does the same sorting as S, but uses the reverse order (small files, older files or end of alphabet first). ? displays documentation on DIRED. @SubSection[Invoking DIRED] @keyindex{C-X D} @index{directory} @fncindex{dired-command} There are some other ways to invoke DIRED. The command C-X D (@fnc{dired-command}) puts you in DIRED on the directory containing the file you are currently editing. With a numeric argument of 1 (@w[C-U 1] C-X D), only the current file is displayed instead of the whole directory. This is present for historical reasons. On file systems which contain multiple versions of files, such as twenex, this allows one to see how much space old versions of a file are consuming. With a numeric argument of 4 (C-U C-X D), it asks you for the directory name. Type a directory name and/or a file name. If you explicitly specify a file name only versions of that file are displayed, otherwise the whole directory is displayed. @Section[Miscellaneous File Operations] @node("filadv") @index{insertion} @index{files} NMODE has extended commands for performing many other operations on files. @fncindex{write-file-command} @keyindex{M-X Write File} @keyindex{C-X C-W} M-X Write File@return1{}<file>@return2{} (@fnc{write-file-command}) writes the contents of the buffer into the file <file>, and then visits that file. It can be thought of as a way of "changing the name" of the file you are visiting. Unlike C-X C-S, Write File saves even if the buffer has not been changed. C-X C-W is another way of getting at this command. @fncindex{insert-file-command} @keyindex{M-X Insert File} M-X Insert File@return1{}<file>@return2{} (@fnc{insert-file-command}) inserts the contents of <file> into the buffer at point, leaving point unchanged before the contents and mark after them. @index{mark} @index{Region} @fncindex{write-region-command} @keyindex{M-X Write Region} M-X Write Region@return1{}<file>@return2{} (@fnc{write-region-command}) writes the region (the text between point and mark) to the specified file. It does not set the visited filename. The buffer is not changed. @fncindex{append-to-file-command} @keyindex{M-X Append to File} M-X Append to File@return1{}<file>@return2{} (@fnc{append-to-file-command}) appends the region to <file>. The text is added to the end of <file>. @fncindex{prepend-to-file-command} @keyindex{M-X Prepend to File} M-X Prepend to File@return1{}<file>@return2{} (@fnc{prepend-to-file-command}) adds the text to the beginning of <file> instead of the end. @index{Set Visited Filename} @fncindex{set-visited-filename-command} M-X Set Visited Filename@return1{}<file>@return2{} (@fnc{set-visited-filename-command}) changes the name of the file being visited without reading or writing the data in the buffer. M-X Write File is approximately equivalent to this command followed by a C-X C-S. @fncindex{delete-file-command} @index{Delete File} @keyindex{M-X Delete File} M-X Delete File@return1{}<file>@return2{} (@fnc{delete-file-command}) deletes the file. In twenex this has the effect of putting the file in the directory of deleted files, from which it can be retrieved until the next expunge. On the hp9836, this has the effect of irretrievably removing the file. @fncindex{delete-and-expunge-file-command} @index{Delete File} @keyindex{M-X Delete and Expunge File} M-X Delete and Expunge File@return1{}<file>@return2{} (@fnc{delete-and-expunge-file-command}) will, if possible, irretrievably delete a file. If the operation fails, a bell will sound. @fncindex{undelete-file-command} @keyindex{M-X Undelete File} M-X Undelete File@return1{}<file>@return2{} (@fnc{undelete-file-command}) will attempt to retrieve a deleted file. This only works on Twenex. |
Added psl-1983/3-1/doc/nmode/nm-files.topic version [c3e3bd4594].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | .silent_index {files} idx 15-1 .silent_index {visiting} idx 15-1 .silent_index {saving} idx 15-1 .silent_index {Create} idx 15-1 .silent_index {Set} idx 15-1 .silent_index {Visit} idx 15-1 .silent_index {files} idx 15-2 .silent_index {Drastic} idx 15-2 .silent_index {file} idx 15-2 .silent_index {DIRED} idx 15-2 .silent_index {file} idx 15-2 .silent_index {recursive} idx 15-2 .silent_index {confirmation} idx 15-3 .silent_index {directory} idx 15-3 .silent_index {insertion} idx 15-3 .silent_index {files} idx 15-3 .silent_index {mark} idx 15-4 .silent_index {Region} idx 15-4 .silent_index {Set} idx 15-4 .silent_index {Delete} idx 15-4 .silent_index {Delete} idx 15-4 |
Added psl-1983/3-1/doc/nmode/nm-fun-index.contents version [6516417481].
> | 1 | contents_entry(0 28 {Function Index} 28-1) |
Added psl-1983/3-1/doc/nmode/nm-fun-index.ibm version [100fd33f94].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-FUN-INDEX.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Function Index) Page 28-1 202/28. Function Index 201/append-next-kill-command . . . . . . . . . . . . . . . . 11-3, 27-2 append-to-buffer-command . . . . . . . . . . . . . . . . 11-4, 16-2, 27-2 append-to-file-command . . . . . . . . . . . . . . . . . 11-4, 15-4, 27-2 apropos-command . . . . . . . . . . . . . . . . . . . . . 8-1, 9-1, 27-2 argument-digit . . . . . . . . . . . . . . . . . . . . . . 5-1, 27-3 auto-fill-mode-command . . . . . . . . . . . . . . . . . . 6-1, 13-4, 27-3 back-to-indentation-command . . . . . . . . . . . . . . . 13-4, 27-4 backward-kill-sentence-command . . . . . . . . . . . . . 11-1, 13-2, 14-1, 27-4 backward-paragraph-command . . . . . . . . . . . . . . 13-3, 27-4 backward-sentence-command . . . . . . . . . . . . . . . 13-2, 27-4 backward-up-list-command . . . . . . . . . . . . . . . . 20-4, 27-5 browser-browser-command . . . . . . . . . . . . . . . . 8-1 buffer-browser-command . . . . . . . . . . . . . . . . . 8-1, 16-2, 27-5 buffer-not-modified-command . . . . . . . . . . . . . . . 15-2, 27-5 c-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 27-5 center-line-command . . . . . . . . . . . . . . . . . . . 13-5, 27-6 copy-region . . . . . . . . . . . . . . . . . . . . . . . 11-3, 27-6 count-occurrences-command . . . . . . . . . . . . . . . 19-1, 27-6 delete-and-expunge-file-command . . . . . . . . . . . . . 15-4, 27-6 delete-backward-character-command . . . . . . . . . . . 4-1, 14-1, 27-7 delete-backward-hacking-tabs-command . . . . . . . . . . 11-1, 20-3, 27-7 delete-blank-lines-command . . . . . . . . . . . . . . . . 4-3, 11-1, 27-7 delete-file-command . . . . . . . . . . . . . . . . . . . 15-4, 27-7 delete-forward-character-command . . . . . . . . . . . . 11-1, 27-8 delete-horizontal-space-command . . . . . . . . . . . . . 11-1, 13-3, 20-2, 27-8 delete-indentation-command . . . . . . . . . . . . . . . . 11-1, 13-3, 20-2, 20-6, 27-8 delete-matching-lines-command . . . . . . . . . . . . . . 19-1, 27-8 delete-non-matching-lines-command . . . . . . . . . . . . 19-1, 27-8 dired-command . . . . . . . . . . . . . . . . . . . . . . 8-1, 15-2, 15-3, 27-9 down-list-command . . . . . . . . . . . . . . . . . . . . 20-4, 27-9 edit-directory-command . . . . . . . . . . . . . . . . . . 8-1, 15-2, 27-9 end-of-defun-command . . . . . . . . . . . . . . . . . . 20-5, 27-10 esc-prefix . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 27-10 exchange-point-and-mark . . . . . . . . . . . . . . . . . 10-1, 27-10 exchange-windows-command . . . . . . . . . . . . . . . 18-1, 27-10 execute-buffer-command . . . . . . . . . . . . . . . . . 27-10 execute-defun-command . . . . . . . . . . . . . . . . . 20-7, 27-11 execute-file-command . . . . . . . . . . . . . . . . . . . 27-11 execute-form-command . . . . . . . . . . . . . . . . . . 20-7, 27-11 exit-nmode . . . . . . . . . . . . . . . . . . . . . . . . 7-2, 27-11 201/Page 28-2 NMODE Manual (Function Index) fill-comment-command . . . . . . . . . . . . . . . . . . . 20-3, 27-12 fill-paragraph-command . . . . . . . . . . . . . . . . . . 13-4, 27-12 fill-region-command . . . . . . . . . . . . . . . . . . . 13-4, 27-12 find-file-command . . . . . . . . . . . . . . . . . . . . 16-1, 27-13 forward-paragraph-command . . . . . . . . . . . . . . . 13-3, 27-13 forward-sentence-command . . . . . . . . . . . . . . . . 13-2, 27-13 forward-up-list-command . . . . . . . . . . . . . . . . . 20-4, 27-13 get-register-command . . . . . . . . . . . . . . . . . . 11-5, 27-14 grow-window-command . . . . . . . . . . . . . . . . . . 18-2, 27-14 help-dispatch . . . . . . . . . . . . . . . . . . . . . . 9-1, 27-14 incremental-search-command . . . . . . . . . . . . . . . 12-1, 27-14 indent-new-line-command . . . . . . . . . . . . . . . . . 20-1, 20-2, 20-6, 27-15 indent-region-command . . . . . . . . . . . . . . . . . . 13-3, 27-15 insert-buffer-command . . . . . . . . . . . . . . . . . . 11-4, 16-2, 27-15 insert-closing-bracket . . . . . . . . . . . . . . . . . . 20-2, 27-15 insert-comment-command . . . . . . . . . . . . . . . . . 20-3, 27-16 insert-date-command . . . . . . . . . . . . . . . . . . . 21-1, 27-16 insert-file-command . . . . . . . . . . . . . . . . . . . 15-4, 27-16 insert-kill-buffer . . . . . . . . . . . . . . . . . . . . . 11-2, 27-16 insert-next-character-command . . . . . . . . . . . . . . 4-1, 27-17 kill-backward-form-command . . . . . . . . . . . . . . . 11-1, 20-4, 27-17 kill-backward-word-command . . . . . . . . . . . . . . . 11-1, 13-1, 14-1, 27-17 kill-buffer-command . . . . . . . . . . . . . . . . . . . 16-2, 27-17 kill-forward-form-command . . . . . . . . . . . . . . . . 11-1, 20-4, 27-18 kill-forward-word-command . . . . . . . . . . . . . . . . 11-1, 13-1, 27-18 kill-line . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 27-18 kill-region . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 11-2, 27-18 kill-sentence-command . . . . . . . . . . . . . . . . . . 11-1, 13-2, 27-19 kill-some-buffers-command . . . . . . . . . . . . . . . . 16-2, 27-19 lisp-abort-command . . . . . . . . . . . . . . . . . . . . 20-8, 27-19 lisp-backtrace-command . . . . . . . . . . . . . . . . . 20-8, 27-19 lisp-continue-command . . . . . . . . . . . . . . . . . . 20-8, 27-20 lisp-help-command . . . . . . . . . . . . . . . . . . . . 20-8, 27-20 lisp-indent-region-command . . . . . . . . . . . . . . . . 20-7, 27-20 lisp-indent-sexpr . . . . . . . . . . . . . . . . . . . . 20-6, 27-20 lisp-mode-command . . . . . . . . . . . . . . . . . . . . 20-1, 27-21 lisp-prefix . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 27-21 lisp-quit-command . . . . . . . . . . . . . . . . . . . . 20-8, 27-21 lisp-retry-command . . . . . . . . . . . . . . . . . . . . 20-8, 27-21 lisp-tab-command . . . . . . . . . . . . . . . . . . . . . 20-3, 20-6, 27-22 lowercase-region-command . . . . . . . . . . . . . . . . 13-6, 27-22 lowercase-word-command . . . . . . . . . . . . . . . . . 13-5, 14-2, 27-22 201/NMODE Manual (Function Index) Page 28-3 m-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 6-1, 27-22 make-parens-command . . . . . . . . . . . . . . . . . . 20-5, 27-23 mark-beginning-command . . . . . . . . . . . . . . . . . 10-2, 27-23 mark-defun-command . . . . . . . . . . . . . . . . . . . 10-2, 20-5, 27-23 mark-end-command . . . . . . . . . . . . . . . . . . . . 10-2, 27-23 mark-form-command . . . . . . . . . . . . . . . . . . . 10-2, 20-5, 27-24 mark-paragraph-command . . . . . . . . . . . . . . . . . 10-2, 13-3, 27-24 mark-whole-buffer-command . . . . . . . . . . . . . . . 10-2, 27-24 mark-word-command . . . . . . . . . . . . . . . . . . . 10-2, 13-2, 27-24 move-backward-character-command . . . . . . . . . . . . 4-1, 27-25 move-backward-defun-command . . . . . . . . . . . . . . 20-5, 27-25 move-backward-form-command . . . . . . . . . . . . . . 20-4, 27-25 move-backward-list-command . . . . . . . . . . . . . . . 20-4, 27-25 move-backward-word-command . . . . . . . . . . . . . . 13-1, 27-26 move-down-command . . . . . . . . . . . . . . . . . . . 4-1, 27-26 move-down-extending-command . . . . . . . . . . . . . . 4-1, 27-26 move-forward-character-command . . . . . . . . . . . . . 4-1, 27-26 move-forward-form-command . . . . . . . . . . . . . . . 20-4, 27-27 move-forward-list-command . . . . . . . . . . . . . . . . 20-4, 27-27 move-forward-word-command . . . . . . . . . . . . . . . 13-1, 27-27 move-over-paren-command . . . . . . . . . . . . . . . . 20-5, 27-27 move-to-buffer-end-command . . . . . . . . . . . . . . . 4-1, 27-28 move-to-buffer-start-command . . . . . . . . . . . . . . 4-1, 27-28 move-to-end-of-line-command . . . . . . . . . . . . . . . 4-1, 27-28 move-to-screen-edge-command . . . . . . . . . . . . . . 17-2, 27-28 move-to-start-of-line-command . . . . . . . . . . . . . . 4-1, 27-28 move-up-command . . . . . . . . . . . . . . . . . . . . 4-1, 27-29 negative-argument . . . . . . . . . . . . . . . . . . . . 5-1, 27-29 next-screen-command . . . . . . . . . . . . . . . . . . . 17-2, 27-29 nmode-abort-command . . . . . . . . . . . . . . . . . . 23-1, 27-29 nmode-exit-to-superior . . . . . . . . . . . . . . . . . . 7-2, 27-29 nmode-full-refresh . . . . . . . . . . . . . . . . . . . . 17-1, 27-30 nmode-gc . . . . . . . . . . . . . . . . . . . . . . . . 21-1, 27-30 nmode-invert-video . . . . . . . . . . . . . . . . . . . . 2-1, 27-30 nmode-refresh-command . . . . . . . . . . . . . . . . . 4-1, 17-1, 27-30 one-window-command . . . . . . . . . . . . . . . . . . . 18-1, 27-30 open-line-command . . . . . . . . . . . . . . . . . . . . 4-3, 5-1, 27-31 other-window-command . . . . . . . . . . . . . . . . . . 18-1, 27-31 prepend-to-file-command . . . . . . . . . . . . . . . . . 11-4, 15-4, 27-31 previous-screen-command . . . . . . . . . . . . . . . . . 17-2, 27-31 put-register-command . . . . . . . . . . . . . . . . . . 11-5, 27-32 query-replace-command . . . . . . . . . . . . . . . . . . 19-1, 27-32 rename-buffer-command . . . . . . . . . . . . . . . . . 16-2, 27-32 replace-string-command . . . . . . . . . . . . . . . . . 19-1, 27-33 reposition-window-command . . . . . . . . . . . . . . . . 17-2, 27-33 return-command . . . . . . . . . . . . . . . . . . . . . 4-1, 27-33 reverse-search-command . . . . . . . . . . . . . . . . . 12-1, 27-33 revert-file-command . . . . . . . . . . . . . . . . . . . 15-2, 27-33 201/Page 28-4 NMODE Manual (Function Index) save-all-files-command . . . . . . . . . . . . . . . . . . 16-2, 27-34 save-file-command . . . . . . . . . . . . . . . . . . . . 4-3, 15-1, 16-2, 27-34 scroll-other-window-command . . . . . . . . . . . . . . . 18-2, 27-34 scroll-window-down-line-command . . . . . . . . . . . . . 17-2, 27-34 scroll-window-down-page-command . . . . . . . . . . . . 17-2, 27-34 scroll-window-left-command . . . . . . . . . . . . . . . . 17-2, 27-35 scroll-window-right-command . . . . . . . . . . . . . . . 17-2, 27-35 scroll-window-up-line-command . . . . . . . . . . . . . . 17-2, 27-35 scroll-window-up-page-command . . . . . . . . . . . . . 17-2, 27-35 select-buffer-command . . . . . . . . . . . . . . . . . . 16-1, 27-35 select-previous-buffer-command . . . . . . . . . . . . . 16-1, 27-36 set-fill-column-command . . . . . . . . . . . . . . . . . 13-5, 22-5, 27-36 set-fill-prefix-command . . . . . . . . . . . . . . . . . . 13-5, 27-36 set-goal-column-command . . . . . . . . . . . . . . . . . 4-2, 27-36 set-key-command . . . . . . . . . . . . . . . . . . . . . 6-2, 27-37 set-mark-command . . . . . . . . . . . . . . . . . . . . 10-1, 27-37 set-visited-filename-command . . . . . . . . . . . . . . . 15-4, 27-37 split-line-command . . . . . . . . . . . . . . . . . . . . 20-2, 27-37 start-scripting-command . . . . . . . . . . . . . . . . . 27-38 start-timing-command . . . . . . . . . . . . . . . . . . . 27-38 stop-scripting-command . . . . . . . . . . . . . . . . . 27-38 stop-timing-command . . . . . . . . . . . . . . . . . . . 27-38 tab-to-tab-stop-command . . . . . . . . . . . . . . . . . 13-1, 13-3, 27-39 text-mode-command . . . . . . . . . . . . . . . . . . . . 13-1, 20-1, 27-39 transpose-characters-command . . . . . . . . . . . . . . 4-1, 14-1, 27-39 transpose-forms . . . . . . . . . . . . . . . . . . . . . 20-5, 27-39 transpose-lines . . . . . . . . . . . . . . . . . . . . . . 14-2, 27-40 transpose-regions . . . . . . . . . . . . . . . . . . . . 14-2, 27-40 transpose-words . . . . . . . . . . . . . . . . . . . . . 13-1, 27-40 two-windows-command . . . . . . . . . . . . . . . . . . 18-1, 27-40 undelete-file-command . . . . . . . . . . . . . . . . . . 15-4, 27-41 universal-argument . . . . . . . . . . . . . . . . . . . . 5-1, 27-41 unkill-previous . . . . . . . . . . . . . . . . . . . . . . 11-3, 27-41 upcase-digit-command . . . . . . . . . . . . . . . . . . 14-2, 27-41 uppercase-initial-command . . . . . . . . . . . . . . . . 13-5, 14-2, 27-42 uppercase-region-command . . . . . . . . . . . . . . . . 10-1, 13-6, 27-42 uppercase-word-command . . . . . . . . . . . . . . . . . 13-5, 14-2, 27-42 view-two-windows-command . . . . . . . . . . . . . . . . 18-2, 27-42 visit-file-command . . . . . . . . . . . . . . . . . . . . 4-3, 15-1, 27-42 visit-in-other-window-command . . . . . . . . . . . . . . 18-3, 27-43 what-cursor-position-command . . . . . . . . . . . . . . 4-2, 13-5, 27-43 write-file-command . . . . . . . . . . . . . . . . . . . . 15-3, 27-43 write-region-command . . . . . . . . . . . . . . . . . . 15-4, 27-43 write-screen-command . . . . . . . . . . . . . . . . . . 21-1, 27-44 201/NMODE Manual (Function Index) Page 28-5 yank-last-output-command . . . . . . . . . . . . . . . . 20-7, 27-44 |
Added psl-1983/3-1/doc/nmode/nm-globals.contents version [ffa84626cc].
> | 1 | contents_entry(0 26 {Globals} 26-1) |
Added psl-1983/3-1/doc/nmode/nm-globals.ibm version [cd23924cbf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-GLOBALS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Globals) Page 26-1 202/26. Globals 201/This section defines a number of conceptual 203/global variables201/, which are referred to in the descriptions of NMODE commands. These 203/globals 201/represent state information that can affect the behavior of various NMODE commands. The value of NMODE globals are set as the result of various NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Column 201/The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Prefix 201/The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Goal Column 201/The goal column is set or unset using the C-X C-N command. When the goal column is defined, the commands C-N and C-P will always leave the cursor at the specified column position, if the current line is sufficiently long. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Kill Ring 201/The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have 201/Page 26-2 NMODE Manual (Globals) taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ |
Added psl-1983/3-1/doc/nmode/nm-globals.topic version [6a9252fc75].
> > > > | 1 2 3 4 | .silent_index {Fill Column} idx 26-1 .silent_index {Fill Prefix} idx 26-1 .silent_index {Goal Column} idx 26-1 .silent_index {Kill Ring} idx 26-1 |
Added psl-1983/3-1/doc/nmode/nm-introduction.contents version [476f555248].
> > | 1 2 | contents_entry(0 1 {Introduction} 1-1) contents_entry(1 1.1 {Preface} 1-2) |
Added psl-1983/3-1/doc/nmode/nm-introduction.ibm version [af53a94453].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-INTRODUCTION.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Introduction) Page 1-1 202/1. Introduction 201/This document describes the NMODE text editor. NMODE is an advanced, self-documenting, customizable, extensible, interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified (by Jeff Soreff) appropriately in areas where NMODE and EMACS differ. The EMACS documentation was written by Richard M. Stallman. We say that NMODE is a screen-oriented editor because normally the text being edited is visible on the screen and is updated automatically as you type your commands. See Section 2 [Display], page 1. We call it an interactive editor because the display is updated very frequently, usually after each character or pair of characters you type. This minimizes the amount of information you must keep in your head as you edit. We call NMODE advanced because it provides facilities that go beyond simple insertion and deletion: filling of text; automatic indentation of programs; viewing two files at once; and dealing in terms of characters, words, lines, sentences, and paragraphs, as well as LISP constructs. It is much easier to type one command meaning "go to the end of the paragraph" than to find the desired spot with repetition of simpler commands. Self-documenting means that there are on-line functions to find out the function of any command and to view documentation about that command. See Section 9 [Help], page 1. Customizable means that you can change the definitions of NMODE commands in little ways. For example, you can rearrange the command set. If you prefer the four basic cursor motion commands (up, down, left and right) on keys in a diamond pattern on the keyboard, you can have it. See Section 22 [Customization], page 1. Extensible means that you can go beyond simple customization and write entirely new commands, programs in the language PSL. NMODE is an "on-line extensible" system, which means that it is divided into many functions that call each other, any of which can be redefined in the middle of an editing session. Any part of NMODE can be replaced without making a separate copy 201/Page 1-2 NMODE Manual (Introduction) of all of NMODE. 202/1.1 Preface 201/This manual documents the use and simple customization of the display editor NMODE with the hp9836 operating system. The reader is 203/not 201/expected to be a programmer. Even simple customizations do not require programming skill, but the user who is not interested in customizing can ignore the scattered customization hints. This is primarily a reference manual, but can also be used as a primer. However, I recommend that the newcomer first use the on-line, learn-by-doing tutorial NTEACH. With it, you learn NMODE by using NMODE on a specially designed file which describes commands, tells you when to try them, and then explains the results you see. This gives a more vivid introduction than a printed manual. On first reading, you need not make any attempt to memorize chapters 2 and 3, which describe the notational conventions of the manual and the general appearance of the NMODE display screen. It is enough to be aware of what questions are answered in these chapters, so you can refer back when you later become interested in the answers. After reading the Basic Editing chapter you should practice the commands there. The next few chapters describe fundamental techniques and concepts that are referred to again and again. It is best to understand them thoroughly, experimenting with them if necessary. To find the documentation on a particular command, look in the index if you know what the command is. Both command characters and function names are indexed. If you know vaguely what the command does, look in the topic index. |
Added psl-1983/3-1/doc/nmode/nm-introduction.r version [27e88c332d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part nm-introduction manual .chapter Introduction .label Introduction . @node("intro") This document describes the NMODE text editor. NMODE is an advanced, self-documenting, customizable, extensible, interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified (by Jeff Soreff) appropriately in areas where NMODE and EMACS differ. The EMACS documentation was written by Richard M. Stallman. We say that NMODE is a screen-oriented editor because normally the text being edited is visible on the screen and is updated automatically as you type your commands. @Note("Screen" "Display"). We call it an interactive editor because the display is updated very frequently, usually after each character or pair of characters you type. This minimizes the amount of information you must keep in your head as you edit. We call NMODE advanced because it provides facilities that go beyond simple insertion and deletion: filling of text; automatic indentation of programs; viewing two files at once; and dealing in terms of characters, words, lines, sentences, and paragraphs, as well as LISP constructs. It is much easier to type one command meaning "go to the end of the paragraph" than to find the desired spot with repetition of simpler commands. Self-documenting means that there are on-line functions to find out the function of any command and to view documentation about that command. @Note("Help"). Customizable means that you can change the definitions of NMODE commands in little ways. For example, you can rearrange the command set. If you prefer the four basic cursor motion commands (up, down, left and right) on keys in a diamond pattern on the keyboard, you can have it. @Manual{@Note("Customization")}. Extensible means that you can go beyond simple customization and write entirely new commands, programs in the language PSL. NMODE is an "on-line extensible" system, which means that it is divided into many functions that call each other, any of which can be redefined in the middle of an editing session. Any part of NMODE can be replaced without making a separate copy of all of NMODE. @Section(Preface) This manual documents the use and simple customization of the display editor NMODE with the hp9836 operating system. The reader is @i(not) expected to be a programmer. Even simple customizations do not require programming skill, but the user who is not interested in customizing can ignore the scattered customization hints. This is primarily a reference manual, but can also be used as a primer. However, I recommend that the newcomer first use the on-line, learn-by-doing tutorial NTEACH. With it, you learn NMODE by using NMODE on a specially designed file which describes commands, tells you when to try them, and then explains the results you see. This gives a more vivid introduction than a printed manual. On first reading, you need not make any attempt to memorize chapters 2 and 3, which describe the notational conventions of the manual and the general appearance of the NMODE display screen. It is enough to be aware of what questions are answered in these chapters, so you can refer back when you later become interested in the answers. After reading the Basic Editing chapter you should practice the commands there. The next few chapters describe fundamental techniques and concepts that are referred to again and again. It is best to understand them thoroughly, experimenting with them if necessary. To find the documentation on a particular command, look in the index if you know what the command is. Both command characters and function names are indexed. If you know vaguely what the command does, look in the topic index. |
Added psl-1983/3-1/doc/nmode/nm-key-index.contents version [59e6192d42].
> | 1 | contents_entry(0 29 {Key Index} 29-1) |
Added psl-1983/3-1/doc/nmode/nm-key-index.ibm version [739b4d0c0e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-KEY-INDEX.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Key Index) Page 29-1 202/29. Key Index 201/) . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-15 Altmode . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 altmode . . . . . . . . . . . . . . . . . . . . . . . . . 3-3 backspace . . . . . . . . . . . . . . . . . . . . . . . . 3-3, 20-1 BACKSPACE . . . . . . . . . . . . . . . . . . . . . . . 27-7 C- . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-1 C-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 C-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-33 C-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-5 C-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-13 C-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-29 C-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 27-23 C-= . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-43 C-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 27-23 C-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-14 C-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 10-1, 27-37 C-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 13-2, 20-2, 27-28 C-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-25 C-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-2, 6-1, 11-1, 27-8 C-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 13-2, 20-2, 27-28 C-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-26 C-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 6-1, 12-2, 15-1, 23-1, 27-29 C-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-2, 11-1, 13-2, 27-18 C-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 17-1, 27-30 C-M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . 13-3, 20-7, 27-15, 27-20 C-M-( . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4 C-M-) . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4 C-M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5 C-M-] . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5 C-M-( . . . . . . . . . . . . . . . . . . . . . . . . . . 27-5 C-M-) . . . . . . . . . . . . . . . . . . . . . . . . . . 27-13 C-M-- . . . . . . . . . . . . . . . . . . . . . . . . . . 27-29 201/Page 29-2 NMODE Manual (Key Index) C-M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 C-M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 20-5, 27-24 C-M-A . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5, 27-25 C-M-B . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-25 C-M-BACKSPACE . . . . . . . . . . . . . . . . . . . . 27-23 C-M-D . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-9 C-M-E . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5, 27-10 C-M-F . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-27 C-M-H . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 20-5, 27-23 C-M-I . . . . . . . . . . . . . . . . . . . . . . . . . . 27-22 C-M-K . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 20-4, 27-18 C-M-L . . . . . . . . . . . . . . . . . . . . . . . . . . 16-1, 27-36 C-M-M . . . . . . . . . . . . . . . . . . . . . . . . . . 13-4, 20-2, 27-4 C-M-N . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-27 C-M-O . . . . . . . . . . . . . . . . . . . . . . . . . . 20-2, 27-37 C-M-P . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-25 C-M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 20-6, 27-20 C-M-R . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-33 C-M-RETURN . . . . . . . . . . . . . . . . . . . . . . 27-4 C-M-Rubout . . . . . . . . . . . . . . . . . . . . . . . 11-1, 20-4 C-M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . 27-17 C-M-T . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5, 27-39 C-M-Tab . . . . . . . . . . . . . . . . . . . . . . . . . 20-6 C-M-TAB . . . . . . . . . . . . . . . . . . . . . . . . 27-22 C-M-U . . . . . . . . . . . . . . . . . . . . . . . . . . 20-4, 27-5 C-M-V . . . . . . . . . . . . . . . . . . . . . . . . . . 18-2, 27-34 C-M-W . . . . . . . . . . . . . . . . . . . . . . . . . . 11-3, 27-2 C-M-X . . . . . . . . . . . . . . . . . . . . . . . . . . 27-22 C-M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . 27-25 C-M-] . . . . . . . . . . . . . . . . . . . . . . . . . . 27-10 C-M-^ . . . . . . . . . . . . . . . . . . . . . . . . . . 20-6 C-N . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-26 C-O . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-3, 5-1, 20-2, 27-31 C-P . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-29 C-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 13-3, 27-17 C-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 12-1, 27-33 C-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 27-7 C-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 12-1, 27-14 C-Space . . . . . . . . . . . . . . . . . . . . . . . . . 10-1 C-SPACE . . . . . . . . . . . . . . . . . . . . . . . . 27-37 C-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 14-1, 27-39 C-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 5-1, 10-2, 13-3, 27-41 201/NMODE Manual (Key Index) Page 29-3 C-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-29 C-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-3, 27-18 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 4-2, 4-3, 8-1, 10-1, 10-2, 11-1, 11-4, 11-5, 13-2, 13-5, 13-6, 14-1, 14-2, 15-1, 15-2, 15-3, 16-1, 16-2, 17-2, 18-1, 18-2, 18-3, 22-2, 22-5, 27-5 C-X < . . . . . . . . . . . . . . . . . . . . . . . . . . 27-35 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-36 C-X 1 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-30 C-X 2 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-40 C-X 3 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-42 C-X 4 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-43 C-X = . . . . . . . . . . . . . . . . . . . . . . . . . . 27-43 C-X > . . . . . . . . . . . . . . . . . . . . . . . . . . 27-35 C-X A . . . . . . . . . . . . . . . . . . . . . . . . . . 27-2 C-X B . . . . . . . . . . . . . . . . . . . . . . . . . . 27-35 C-X C-B . . . . . . . . . . . . . . . . . . . . . . . . . 27-5 C-X C-F . . . . . . . . . . . . . . . . . . . . . . . . . 27-13 C-X C-L . . . . . . . . . . . . . . . . . . . . . . . . . 27-22 C-X C-N . . . . . . . . . . . . . . . . . . . . . . . . . 27-36 C-X C-O . . . . . . . . . . . . . . . . . . . . . . . . . 27-7 C-X C-S . . . . . . . . . . . . . . . . . . . . . . . . . 27-34 C-X C-T . . . . . . . . . . . . . . . . . . . . . . . . . 27-40 C-X C-U . . . . . . . . . . . . . . . . . . . . . . . . . 27-42 C-X C-V . . . . . . . . . . . . . . . . . . . . . . . . . 27-42 C-X C-W . . . . . . . . . . . . . . . . . . . . . . . . . 27-43 C-X C-X . . . . . . . . . . . . . . . . . . . . . . . . . 27-10 C-X C-Z . . . . . . . . . . . . . . . . . . . . . . . . . 27-29 C-X D . . . . . . . . . . . . . . . . . . . . . . . . . . 27-9 C-X E . . . . . . . . . . . . . . . . . . . . . . . . . . 27-10 C-X F . . . . . . . . . . . . . . . . . . . . . . . . . . 27-36 C-X G . . . . . . . . . . . . . . . . . . . . . . . . . . 27-14 C-X H . . . . . . . . . . . . . . . . . . . . . . . . . . 27-24 C-X K . . . . . . . . . . . . . . . . . . . . . . . . . . 27-17 C-X O . . . . . . . . . . . . . . . . . . . . . . . . . . 27-31 C-X P . . . . . . . . . . . . . . . . . . . . . . . . . . 27-44 C-X RUBOUT . . . . . . . . . . . . . . . . . . . . . . 27-4 C-X T . . . . . . . . . . . . . . . . . . . . . . . . . . 27-40 C-X V . . . . . . . . . . . . . . . . . . . . . . . . . . 27-30 C-X X . . . . . . . . . . . . . . . . . . . . . . . . . . 27-32 C-X ^ . . . . . . . . . . . . . . . . . . . . . . . . . . 27-14 C-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-2, 27-16 C-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-21 C-^ . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 201/Page 29-4 NMODE Manual (Key Index) ESC . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 ESC-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-26 ESC-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 27-27 ESC-A . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-29 ESC-B . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-26 ESC-C . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-26 ESC-D . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-25 ESC-F . . . . . . . . . . . . . . . . . . . . . . . . . . 27-28 ESC-H . . . . . . . . . . . . . . . . . . . . . . . . . . 27-28 ESC-J . . . . . . . . . . . . . . . . . . . . . . . . . . 17-1, 27-30 ESC-L . . . . . . . . . . . . . . . . . . . . . . . . . . 27-31 ESC-M . . . . . . . . . . . . . . . . . . . . . . . . . . 27-18 ESC-P . . . . . . . . . . . . . . . . . . . . . . . . . . 27-8 ESC-S . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-35 ESC-T . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-34 ESC-U . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-35 ESC-V . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-34 Esc-_ . . . . . . . . . . . . . . . . . . . . . . . . . . 27-2 ESCape . . . . . . . . . . . . . . . . . . . . . . . . . 19-1 ESCAPE . . . . . . . . . . . . . . . . . . . . . . . . . 27-10 linefeed . . . . . . . . . . . . . . . . . . . . . . . . . 3-3 Linefeed . . . . . . . . . . . . . . . . . . . . . . . . . 20-1 lisp-? . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-? . . . . . . . . . . . . . . . . . . . . . . . . . . 27-20 lisp-A . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-A . . . . . . . . . . . . . . . . . . . . . . . . . . 27-19 lisp-B . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-B . . . . . . . . . . . . . . . . . . . . . . . . . . 27-19 lisp-C . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-C . . . . . . . . . . . . . . . . . . . . . . . . . . 27-20 Lisp-D . . . . . . . . . . . . . . . . . . . . . . . . . . 27-11 Lisp-E . . . . . . . . . . . . . . . . . . . . . . . . . . 27-11 Lisp-L . . . . . . . . . . . . . . . . . . . . . . . . . . 27-11 lisp-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 27-21 lisp-R . . . . . . . . . . . . . . . . . . . . . . . . . . 20-8 Lisp-R . . . . . . . . . . . . . . . . . . . . . . . . . . 27-21 Lisp-Y . . . . . . . . . . . . . . . . . . . . . . . . . . 27-44 M- . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-1 M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-3, 20-2, 27-8 M-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5 M-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 20-5 M-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-32 M-' . . . . . . . . . . . . . . . . . . . . . . . . . . . 14-2, 27-41 M-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-23 M-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-27 M-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 14-2, 27-29 M-/ . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-14 M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 201/NMODE Manual (Key Index) Page 29-5 M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-3 M-; . . . . . . . . . . . . . . . . . . . . . . . . . . . 20-3, 27-16 M-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-28 M-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 4-1, 27-28 M-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-14 M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 13-2, 27-24 M-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-2, 27-4 M-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-1, 27-26 M-Backspace . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-1, 14-1 M-BACKSPACE . . . . . . . . . . . . . . . . . . . . . . 27-23 M-C . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-5, 14-2, 27-42 M-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-1, 27-18 M-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-2, 27-13 M-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-1, 27-27 M-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-4, 27-12 M-H . . . . . . . . . . . . . . . . . . . . . . . . . . . 10-2, 13-3, 13-4, 27-24 M-I . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-39 M-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-2, 27-19 M-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-5, 14-2, 27-22 M-M . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-4, 20-2, 27-4 M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-4, 27-12 M-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-28 M-RETURN . . . . . . . . . . . . . . . . . . . . . . . . 27-4 M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 27-17 M-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-5, 27-6 M-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-1, 27-40 M-Tab . . . . . . . . . . . . . . . . . . . . . . . . . . 13-3 M-TAB . . . . . . . . . . . . . . . . . . . . . . . . . . 27-39 M-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-5, 14-2, 27-42 M-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 17-2, 27-31 M-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-3, 27-6 M-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2, 6-1, 6-2, 8-1, 15-2, 15-3, 15-4, 21-1, 22-2, 27-22 M-X Append To File . . . . . . . . . . . . . . . . . . . 27-2 M-X Apropos . . . . . . . . . . . . . . . . . . . . . . . 27-2 M-X Auto Fill Mode . . . . . . . . . . . . . . . . . . . 27-3 M-X Count Occurrences . . . . . . . . . . . . . . . . . 27-6 M-X Delete And Expunge File . . . . . . . . . . . . . . 27-6 M-X Delete File . . . . . . . . . . . . . . . . . . . . . 27-7 M-X Delete Matching Lines . . . . . . . . . . . . . . . . 27-8 M-X Delete Non-Matching Lines . . . . . . . . . . . . . . 27-8 M-X Dired . . . . . . . . . . . . . . . . . . . . . . . . 27-9 M-X Edit Directory . . . . . . . . . . . . . . . . . . . . 27-9 201/Page 29-6 NMODE Manual (Key Index) M-X Execute Buffer . . . . . . . . . . . . . . . . . . . 27-10 M-X Execute File . . . . . . . . . . . . . . . . . . . . . 27-11 M-X Find File . . . . . . . . . . . . . . . . . . . . . . 27-13 M-X Flush Lines . . . . . . . . . . . . . . . . . . . . . 27-8 M-X How Many . . . . . . . . . . . . . . . . . . . . . . 27-6 M-X Insert Buffer . . . . . . . . . . . . . . . . . . . . 27-15 M-X Insert Date . . . . . . . . . . . . . . . . . . . . . 27-16 M-X Insert File . . . . . . . . . . . . . . . . . . . . . 27-16 M-X Keep Lines . . . . . . . . . . . . . . . . . . . . . 27-8 M-X Kill Buffer . . . . . . . . . . . . . . . . . . . . . 27-17 M-X Kill File . . . . . . . . . . . . . . . . . . . . . . . 27-7 M-X Kill Some Buffers . . . . . . . . . . . . . . . . . . 27-19 M-X Lisp Mode . . . . . . . . . . . . . . . . . . . . . . 27-21 M-X List Buffers . . . . . . . . . . . . . . . . . . . . . 27-5 M-X Make Space . . . . . . . . . . . . . . . . . . . . . 27-30 M-X Prepend To File . . . . . . . . . . . . . . . . . . . 27-31 M-X Query Replace . . . . . . . . . . . . . . . . . . . 27-32 M-X Rename Buffer . . . . . . . . . . . . . . . . . . . 27-32 M-X Replace String . . . . . . . . . . . . . . . . . . . 27-33 M-X Revert File . . . . . . . . . . . . . . . . . . . . . 27-33 M-X Save All Files . . . . . . . . . . . . . . . . . . . . 27-34 M-X Select Buffer . . . . . . . . . . . . . . . . . . . . 27-35 M-X Set Key . . . . . . . . . . . . . . . . . . . . . . . 27-37 M-X Set Visited Filename . . . . . . . . . . . . . . . . . 27-37 M-X Start Scripting . . . . . . . . . . . . . . . . . . . 27-38 M-X Start Timing Nmode . . . . . . . . . . . . . . . . . 27-38 M-X Stop Scripting . . . . . . . . . . . . . . . . . . . 27-38 M-X Stop Timing Nmode . . . . . . . . . . . . . . . . . 27-38 M-X Text Mode . . . . . . . . . . . . . . . . . . . . . 27-39 M-X Undelete File . . . . . . . . . . . . . . . . . . . . 27-41 M-X Visit File . . . . . . . . . . . . . . . . . . . . . . 27-42 M-X Write File . . . . . . . . . . . . . . . . . . . . . . 27-43 M-X Write Region . . . . . . . . . . . . . . . . . . . . 27-43 M-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-3, 27-41 M-Z . . . . . . . . . . . . . . . . . . . . . . . . . . . 20-3, 27-12 M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-3, 27-4 M-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-3, 27-13 M-^ . . . . . . . . . . . . . . . . . . . . . . . . . . . 11-1, 13-3, 20-2, 20-6, 27-8 M-~ . . . . . . . . . . . . . . . . . . . . . . . . . . . 15-2, 27-5 NEWLINE . . . . . . . . . . . . . . . . . . . . . . . . . 27-15 RETURN . . . . . . . . . . . . . . . . . . . . . . . . . 27-33 Rubout . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 rubout . . . . . . . . . . . . . . . . . . . . . . . . . . 3-3 Rubout . . . . . . . . . . . . . . . . . . . . . . . . . 20-1 RUBOUT . . . . . . . . . . . . . . . . . . . . . . . . . 27-7 201/NMODE Manual (Key Index) Page 29-7 Space . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 space . . . . . . . . . . . . . . . . . . . . . . . . . . 3-3 Space . . . . . . . . . . . . . . . . . . . . . . . . . . 13-4 Tab . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-2 tab . . . . . . . . . . . . . . . . . . . . . . . . . . . 3-3 Tab . . . . . . . . . . . . . . . . . . . . . . . . . . . 13-1, 13-3, 20-1, 20-3, 20-6 TAB . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-22, 27-39 ] . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27-15 |
Added psl-1983/3-1/doc/nmode/nm-killing.contents version [29a36db822].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | contents_entry(0 11 {Killing and Moving Text} 11-1) contents_entry(1 11.1 {Deletion and Killing} 11-1) contents_entry(2 11.1.1 {Deletion} 11-1) contents_entry(2 11.1.2 {Killing by Lines} 11-2) contents_entry(2 11.1.3 {Other Kill Commands} 11-2) contents_entry(1 11.2 {Un-Killing} 11-2) contents_entry(2 11.2.1 {Appending Kills} 11-3) contents_entry(2 11.2.2 {Un-killing Earlier Kills} 11-3) contents_entry(1 11.3 {Other Ways of Copying Text} 11-4) contents_entry(2 11.3.1 {Accumulating Text} 11-4) contents_entry(2 11.3.2 {Copying Text Many Times} 11-5) |
Added psl-1983/3-1/doc/nmode/nm-killing.function version [aa37f2ac4d].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | .silent_index {kill-forward-word-command} idx 11-1 .silent_index {kill-backward-word-command} idx 11-1 .silent_index {kill-forward-form-command} idx 11-1 .silent_index {kill-backward-form-command} idx 11-1 .silent_index {backward-kill-sentence-command} idx 11-1 .silent_index {kill-sentence-command} idx 11-1 .silent_index {delete-forward-character-command} idx 11-1 .silent_index {delete-backward-hacking-tabs-command} idx 11-1 .silent_index {kill-line} idx 11-1 .silent_index {kill-region} idx 11-1 .silent_index {delete-horizontal-space-command} idx 11-1 .silent_index {delete-blank-lines-command} idx 11-1 .silent_index {delete-indentation-command} idx 11-1 .silent_index {kill-region} idx 11-2 .silent_index {insert-kill-buffer} idx 11-2 .silent_index {copy-region} idx 11-3 .silent_index {append-next-kill-command} idx 11-3 .silent_index {unkill-previous} idx 11-3 .silent_index {append-to-buffer-command} idx 11-4 .silent_index {insert-buffer-command} idx 11-4 .silent_index {append-to-file-command} idx 11-4 .silent_index {prepend-to-file-command} idx 11-4 .silent_index {put-register-command} idx 11-5 .silent_index {get-register-command} idx 11-5 |
Added psl-1983/3-1/doc/nmode/nm-killing.ibm version [8470ae0bbd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-KILLING.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Killing and Moving Text) Page 11-1 202/11. Killing and Moving Text 201/The commonest way of moving or copying text with NMODE is to kill it, and get it back again in one or more places. This is very safe because the last several pieces of killed text are all remembered, and it is versatile, because the many commands for killing syntactic units can also be used for moving those units. There are also other ways of moving text for special purposes. 202/11.1 Deletion and Killing 201/Most commands which erase text from the buffer save it so that you can get it back if you change your mind, or move or copy it to other parts of the buffer. These commands are known as 202/kill 201/commands. The rest of the commands that erase text do not save it; they are known as 202/delete 201/commands. The delete commands include C-D and Backspace, which delete only one character at a time, and those commands that delete only spaces or line separators. Commands that can destroy significant amounts of nontrivial data generally kill. The commands' names and individual descriptions use the words "kill" and "delete" to say which they do. C-D Delete next character. Backspace Delete previous character. M-\ Delete spaces and tabs around point. C-X C-O Delete blank lines around the current line. M-^ Join two lines by deleting the line separator and any indentation. C-K Kill rest of line or one or more lines. C-W Kill region (from point to the mark). M-D Kill word. M-Backspace Kill word backwards. C-X Rubout Kill back to beginning of sentence. M-K Kill to end of sentence. C-M-K Kill Lisp form. C-M-Rubout Kill Lisp form backwards. 202/11.1.1 Deletion 201/The most basic delete commands are C-D and Backspace. C-D deletes the character after the cursor, the one the cursor is "on top of" or "underneath". The cursor doesn't move. Backspace deletes the character before the cursor, and moves the cursor back. Line separators act like single characters when deleted. Actually, C-D and Backspace aren't always delete commands; if you give an argument, they kill instead. This prevents you from losing a great deal of text by typing a large argument to a C-D or Backspace. The other delete commands are those which delete only formatting characters: spaces, tabs and line separators. M-\ (203/delete-horizontal-space-command201/) deletes all the spaces and tab characters before and after point. C-X C-O (203/delete-blank-lines-command201/) deletes all blank lines after the current line, and if the current line is blank deletes all blank lines preceding the current line as well (leaving one blank line, the 201/Page 11-2 NMODE Manual (Deletion) current line). M-^ (203/delete-indentation-command201/) joins the current line and the previous line, or the current line and the next line if given an argument. See Section 13.3 [Indentation], page 3. 202/11.1.2 Killing by Lines 201/The simplest kill command is the C-K command (203/kill-line201/). If given at the beginning of a line, it kills all the text on the line, leaving it blank. If given on a blank line, the blank line disappears. As a consequence, if you go to the front of a non-blank line and type two C-K's, the line disappears completely. More generally, C-K kills from point up to the end of the line, unless it is at the end of a line. In that case it kills the line separator following the line, thus merging the next line into the current one. Invisible spaces and tabs at the end of the line are ignored when deciding which case applies, so if point appears to be at the end of the line, you can be sure the line separator will be killed. If C-K is given a positive argument, it kills that many lines, and the separators that follow them (however, text on the current line before point is spared). With a negative argument, it kills back to a number of line beginnings. An argument of -2 means kill back to the second line beginning. If point is at the beginning of a line, that line beginning doesn't count, so C-U - 2 C-K with point at the front of a line kills the two previous lines. C-K with an argument of zero kills all the text before point on the current line. 202/11.1.3 Other Kill Commands 201/A kill command which is very general is C-W (203/kill-region201/), which kills everything between point and the mark. With this command, you can kill any contiguous characters, if you first set the mark at one end of them and go to the other end. Other syntactic units can be killed: words, with M-Backspace and M-D (See Section 13.1 [Words], page 1.); forms, with C-M-Rubout and C-M-K (See Section 20.5.1 [Forms], page 3.); sentences, with C-X Rubout and M-K (See Section 13.2 [Sentences], page 2.). 202/11.2 Un-Killing 201/Un-killing is getting back text which was killed. The usual way to move or copy text is to kill it and then un-kill it one or more times. C-Y Yank (re-insert) last killed text. M-Y Replace re-inserted killed text with the previously killed text. M-W Save region as last killed text without killing. C-M-W Append next kill to last batch of killed text. Killed text is pushed onto a 202/ring buffer 201/called the 202/kill ring 201/that remembers the last 16 blocks of text that were killed. (Why it is called a ring buffer 201/NMODE Manual (Un-Killing) Page 11-3 will be explained below). The command C-Y (203/insert-kill-buffer201/) reinserts the text of the most recent kill. It leaves the cursor at the end of the text, and puts the mark at the beginning. Thus, a single C-W undoes the C-Y. C-U C-Y leaves the cursor in front of the text, and the mark after. This is only if the argument is specified with just a C-U, precisely. Any other sort of argument, including C-U and digits, has an effect described below. If you wish to copy a block of text, you might want to use M-W (203/copy-region201/), which copies the region into the kill ring without removing it from the buffer. This is approximately equivalent to C-W followed by C-Y, except that M-W does not mark the buffer as "changed" and does not temporarily change the screen. There is only one kill ring, and switching buffers or files has no effect on it. After visiting a new file, whatever was last killed in the previous file is still on top of the kill ring. This is important for moving text between files. 202/11.2.1 Appending Kills 201/Normally, each kill command pushes a new block onto the kill ring. However, two or more kill commands in a row combine their text into a single entry on the ring, so that a single C-Y command gets it all back as it was before it was killed. This means that you don't have to kill all the text in one command; you can keep killing line after line, or word after word, until you have killed it all, and you can still get it all back at once. (Thus we join television in leading people to kill thoughtlessly). Commands that kill forward from point add onto the end of the previous killed text. Commands that kill backward from point add onto the beginning. This way, any sequence of mixed forward and backward kill commands puts all the killed text into one entry without rearrangement. If a kill command is separated from the last kill command by other commands, it starts a new entry on the kill ring, unless you tell it not to by saying C-M-W (203/append-next-kill-command201/) in front of it. The C-M-W tells the following command, if it is a kill command, to append the text it kills to the last killed text, instead of starting a new entry. With C-M-W, you can kill several separated pieces of text and accumulate them to be yanked back in one place. 202/11.2.2 Un-killing Earlier Kills 201/To recover killed text that is no longer the most recent kill, you need the Meta-Y (203/unkill-previous201/) command. The M-Y command should be used only after a C-Y command or another M-Y. It takes the un-killed text inserted by the C-Y and replaces it with the text from an earlier kill. So, to recover the text of the next-to-the-last kill, you first use C-Y to recover the last kill, and then use M-Y to move back to the previous kill. You can think of all the last few kills as living in a ring. After a C-Y command, the text at the front of the ring is also present in the buffer. M-Y "rotates" the ring, bringing the previous string of text to the front, and this text replaces the other text in the buffer as well. Enough M-Y 201/Page 11-4 NMODE Manual (Un-killing Earlier Kills) commands can rotate any part of the ring to the front, so you can get at any killed text as long as it is recent enough to be still in the ring. Eventually the ring rotates all the way around and the most recent killed text comes to the front (and into the buffer) again. M-Y with a negative argument rotates the ring backwards. If the region doesn't match the text at the front of the ring, M-Y is not allowed. In any case, when the text you are looking for is brought into the buffer, you can stop doing M-Y's and it will stay there. It's really just a copy of what's at the front of the ring, so editing it does not change what's in the ring. And the ring, once rotated, stays rotated, so that doing another C-Y gets another copy of what you rotated to the front with M-Y. If you change your mind about un-killing, a C-W gets rid of the un-killed text at any point, after any number of M-Y's. C-W pushes the text onto the ring again. If you know how many M-Y's it would take to find the text you want, then there is an alternative. C-Y with an argument greater than one restores the text the specified number of entries down on the ring. Thus, C-U 2 C-Y gets the next to the last block of killed text. It differs from C-Y M-Y in that C-U 2 C-Y does not permanently rotate the ring. 202/11.3 Other Ways of Copying Text 201/Usually we copy or move text by killing it and un-killing it, but there are other ways that are useful for copying one block of text in many places, or for copying many scattered blocks of text into one place. 202/11.3.1 Accumulating Text 201/You can accumulate blocks of text from scattered locations either into a buffer or into a file if you like. To append them into a buffer, use the command C-X A (203/append-to-buffer-command201/), which inserts a copy of the region into the specified buffer at the location of point in that buffer. This command will prompt for the name of a buffer, which should be terminated with Return. If there is no buffer with the name you specify, one is created. If you append text into a buffer which has been used for editing, the copied text goes into the middle of the text of the buffer, wherever point happens to be in it. Point in that buffer is left at the end of the copied text, so successive uses of C-X A accumulate the text in the specified buffer in the same order as they were copied. If C-X A is given an argument, point in the other buffer is left before the copied text, so successive uses of C-X A add text in reverse order. You can retrieve the accumulated text from that buffer with M-X Insert Buffer (203/insert-buffer-command201/). This inserts a copy of the text in that buffer into the selected buffer. It prompts for the buffer name needed. You can also select the other buffer for editing. See Section 16 [Buffers], page 201/NMODE Manual (Accumulating Text) Page 11-5 1, for background information on buffers. Strictly speaking, C-X A does not always append to the text already in the buffer. But if it is used on a buffer which starts out empty, it does keep appending to the end. Instead of accumulating text within NMODE, in a buffer, you can append text directly into a disk file with the command M-X Append to File (203/append-to-file-command201/). It adds the text of the region to the end of the specified file. M-X Prepend to File (203/prepend-to-file-command201/) adds the text to the beginning of the file instead. Both commands prompt for the file name. The file is changed immediately on disk. These commands are normally used with files that are 203/not 201/being visited in NMODE. They have the advantage of working even on files too large to fit into the NMODE address space. 202/11.3.2 Copying Text Many Times 201/When you want to insert a copy of the same piece of text frequently, the kill ring becomes impractical, since the text moves down on the ring as you edit, and will be in an unpredictable place on the ring when you need it again. For this case, you can use the commands C-X X (203/put-register-command201/) and C-X G (203/get-register-command201/) to move the text. C-X X stores a copy of the text of the region in a place called a register. With an argument, C-X X deletes the text as well. C-X G inserts the text from a register into the buffer. Both these commands prompt for the register name, which must be a single letter or digit. This gives 36 places in which you can store a piece of text. Normally C-X G leaves point before the text and places the mark after, but with a numeric argument it puts point after the text and the mark before. |
Added psl-1983/3-1/doc/nmode/nm-killing.key version [7e0e0c9c44].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | .silent_index {M-D} idx 11-1 .silent_index {M-Backspace} idx 11-1 .silent_index {C-M-K} idx 11-1 .silent_index {C-M-Rubout} idx 11-1 .silent_index {C-X} idx 11-1 .silent_index {M-K} idx 11-1 .silent_index {C-D} idx 11-1 .silent_index {C-K} idx 11-1 .silent_index {C-W} idx 11-1 .silent_index {C-D} idx 11-1 .silent_index {C-K} idx 11-1 .silent_index {C-W} idx 11-1 .silent_index {M-\} idx 11-1 .silent_index {C-X} idx 11-1 .silent_index {M-^} idx 11-1 .silent_index {C-Y} idx 11-2 .silent_index {M-W} idx 11-3 .silent_index {C-M-W} idx 11-3 .silent_index {M-Y} idx 11-3 .silent_index {C-X} idx 11-4 .silent_index {C-X} idx 11-5 .silent_index {C-X} idx 11-5 |
Added psl-1983/3-1/doc/nmode/nm-killing.r version [46cbc81833].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-KILLING manual @chapter(Killing and Moving Text) The commonest way of moving or copying text with NMODE is to kill it, and get it back again in one or more places. This is very safe because the last several pieces of killed text are all remembered, and it is versatile, because the many commands for killing syntactic units can also be used for moving those units. There are also other ways of moving text for special purposes. @node("killing") @section(Deletion and Killing) @keyindex{M-D} @fncindex{kill-forward-word-command} @keyindex{M-Backspace} @fncindex{kill-backward-word-command} @keyindex{C-M-K} @fncindex{kill-forward-form-command} @keyindex{C-M-Rubout} @fncindex{kill-backward-form-command} @keyindex{C-X Rubout} @fncindex{backward-kill-sentence-command} @keyindex{M-K} @fncindex{kill-sentence-command} @keyindex{C-D} @fncindex{delete-forward-character-command} @index{Backspace} @fncindex{delete-backward-hacking-tabs-command} @keyindex{C-K} @fncindex{kill-line} @keyindex{C-W} @fncindex{kill-region} @index{killing} @index{deletion} @keyindex{C-D} @index{Backspace} @keyindex{C-K} @keyindex{C-W} @index{lines} Most commands which erase text from the buffer save it so that you can get it back if you change your mind, or move or copy it to other parts of the buffer. These commands are known as @dfn[kill] commands. The rest of the commands that erase text do not save it; they are known as @dfn[delete] commands. The delete commands include C-D and Backspace, which delete only one character at a time, and those commands that delete only spaces or line separators. Commands that can destroy significant amounts of nontrivial data generally kill. The commands' names and individual descriptions use the words "kill" and "delete" to say which they do. @DoubleWideCommands[ C-D Delete next character. Backspace Delete previous character. M-\ Delete spaces and tabs around point. C-X C-O Delete blank lines around the current line. M-^ Join two lines by deleting the line separator and any indentation. C-K Kill rest of line or one or more lines. C-W Kill region (from point to the mark). M-D Kill word. M-Backspace Kill word backwards. C-X Rubout Kill back to beginning of sentence. M-K Kill to end of sentence. C-M-K Kill Lisp form. C-M-Rubout Kill Lisp form backwards. ] @Subsection[Deletion] The most basic delete commands are C-D and Backspace. C-D deletes the character after the cursor, the one the cursor is "on top of" or "underneath". The cursor doesn't move. Backspace deletes the character before the cursor, and moves the cursor back. Line separators act like single characters when deleted. Actually, C-D and Backspace aren't always delete commands; if you give an argument, they kill instead. This prevents you from losing a great deal of text by typing a large argument to a C-D or Backspace. @keyindex{M-\} @fncindex{delete-horizontal-space-command} @Keyindex{C-X C-O} @fncindex{delete-blank-lines-command} @keyindex{M-^} @fncindex{delete-indentation-command} The other delete commands are those which delete only formatting characters: spaces, tabs and line separators. M-\ (@fnc{delete-horizontal-space-command}) deletes all the spaces and tab characters before and after point. C-X C-O (@fnc{delete-blank-lines-command}) deletes all blank lines after the current line, and if the current line is blank deletes all blank lines preceding the current line as well (leaving one blank line, the current line). M-^ (@fnc{delete-indentation-command}) joins the current line and the previous line, or the current line and the next line if given an argument. @Note("TextIndent" "Indentation"). @Subsection[Killing by Lines] @index{blank lines} The simplest kill command is the C-K command (@fnc{kill-line}). If given at the beginning of a line, it kills all the text on the line, leaving it blank. If given on a blank line, the blank line disappears. As a consequence, if you go to the front of a non-blank line and type two C-K's, the line disappears completely. More generally, C-K kills from point up to the end of the line, unless it is at the end of a line. In that case it kills the line separator following the line, thus merging the next line into the current one. Invisible spaces and tabs at the end of the line are ignored when deciding which case applies, so if point appears to be at the end of the line, you can be sure the line separator will be killed. @index{numeric arguments} If C-K is given a positive argument, it kills that many lines, and the separators that follow them (however, text on the current line before point is spared). With a negative argument, it kills back to a number of line beginnings. An argument of -2 means kill back to the second line beginning. If point is at the beginning of a line, that line beginning doesn't count, so @w[C-U - 2 C-K] with point at the front of a line kills the two previous lines. C-K with an argument of zero kills all the text before point on the current line. @Subsection[Other Kill Commands] @index{mark} @index{Region} @fncindex{kill-region} A kill command which is very general is C-W (@fnc{kill-region}), which kills everything between point and the mark. With this command, you can kill any contiguous characters, if you first set the mark at one end of them and go to the other end. Other syntactic units can be killed: words, with M-Backspace and M-D (@Note("Words").); forms, with C-M-Rubout and C-M-K (@Note("Lists" "Forms").); sentences, with C-X Rubout and M-K (@Note("Sentences").). @Section[Un-Killing] @node("un-killing") @index{killing} @index{moving text} @index{kill ring} Un-killing is getting back text which was killed. The usual way to move or copy text is to kill it and then un-kill it one or more times. @Commands[ C-Y Yank (re-insert) last killed text. M-Y Replace re-inserted killed text with the previously killed text. M-W Save region as last killed text without killing. C-M-W Append next kill to last batch of killed text. ] @keyindex{C-Y} @fncindex{insert-kill-buffer} Killed text is pushed onto a @dfn[ring buffer] called the @dfn[kill ring] that remembers the last 16 blocks of text that were killed. (Why it is called a ring buffer will be explained below). The command C-Y (@fnc{insert-kill-buffer}) reinserts the text of the most recent kill. It leaves the cursor at the end of the text, and puts the mark at the beginning. Thus, a single C-W undoes the C-Y. @w[C-U C-Y] leaves the cursor in front of the text, and the mark after. This is only if the argument is specified with just a C-U, precisely. Any other sort of argument, including C-U and digits, has an effect described below. @index{mark} @index{Region} @keyindex{M-W} @fncindex{copy-region} If you wish to copy a block of text, you might want to use M-W (@fnc{copy-region}), which copies the region into the kill ring without removing it from the buffer. This is approximately equivalent to C-W followed by C-Y, except that M-W does not mark the buffer as "changed" and does not temporarily change the screen. There is only one kill ring, and switching buffers or files has no effect on it. After visiting a new file, whatever was last killed in the previous file is still on top of the kill ring. This is important for moving text between files. @Subsection[Appending Kills] @keyindex{C-M-W} @fncindex{append-next-kill-command} Normally, each kill command pushes a new block onto the kill ring. However, two or more kill commands in a row combine their text into a single entry on the ring, so that a single C-Y command gets it all back as it was before it was killed. This means that you don't have to kill all the text in one command; you can keep killing line after line, or word after word, until you have killed it all, and you can still get it all back at once. (Thus we join television in leading people to kill thoughtlessly). Commands that kill forward from point add onto the end of the previous killed text. Commands that kill backward from point add onto the beginning. This way, any sequence of mixed forward and backward kill commands puts all the killed text into one entry without rearrangement. If a kill command is separated from the last kill command by other commands, it starts a new entry on the kill ring, unless you tell it not to by saying C-M-W (@fnc{append-next-kill-command}) in front of it. The C-M-W tells the following command, if it is a kill command, to append the text it kills to the last killed text, instead of starting a new entry. With C-M-W, you can kill several separated pieces of text and accumulate them to be yanked back in one place. @Subsection[Un-killing Earlier Kills] @keyindex{M-Y} @fncindex{unkill-previous} To recover killed text that is no longer the most recent kill, you need the Meta-Y (@fnc{unkill-previous}) command. The M-Y command should be used only after a C-Y command or another M-Y. It takes the un-killed text inserted by the C-Y and replaces it with the text from an earlier kill. So, to recover the text of the next-to-the-last kill, you first use C-Y to recover the last kill, and then use M-Y to move back to the previous kill. You can think of all the last few kills as living in a ring. After a C-Y command, the text at the front of the ring is also present in the buffer. M-Y "rotates" the ring, bringing the previous string of text to the front, and this text replaces the other text in the buffer as well. Enough M-Y commands can rotate any part of the ring to the front, so you can get at any killed text as long as it is recent enough to be still in the ring. Eventually the ring rotates all the way around and the most recent killed text comes to the front (and into the buffer) again. M-Y with a negative argument rotates the ring backwards. If the region doesn't match the text at the front of the ring, M-Y is not allowed. In any case, when the text you are looking for is brought into the buffer, you can stop doing M-Y's and it will stay there. It's really just a copy of what's at the front of the ring, so editing it does not change what's in the ring. And the ring, once rotated, stays rotated, so that doing another C-Y gets another copy of what you rotated to the front with M-Y. If you change your mind about un-killing, a C-W gets rid of the un-killed text at any point, after any number of M-Y's. C-W pushes the text onto the ring again. @index{numeric arguments} If you know how many M-Y's it would take to find the text you want, then there is an alternative. C-Y with an argument greater than one restores the text the specified number of entries down on the ring. Thus, @w[C-U 2 C-Y] gets the next to the last block of killed text. It differs from C-Y M-Y in that @w[C-U 2 C-Y] does not permanently rotate the ring. @Section[Other Ways of Copying Text] @node("copying") Usually we copy or move text by killing it and un-killing it, but there are other ways that are useful for copying one block of text in many places, or for copying many scattered blocks of text into one place. @Subsection[Accumulating Text] @keyindex{C-X A} @fncindex{append-to-buffer-command} @fncindex{insert-buffer-command} @fncindex{append-to-file-command} @fncindex{prepend-to-file-command} You can accumulate blocks of text from scattered locations either into a buffer or into a file if you like. To append them into a buffer, use the command C-X A (@fnc{append-to-buffer-command}), which inserts a copy of the region into the specified buffer at the location of point in that buffer. This command will prompt for the name of a buffer, which should be terminated with @Return3{}. If there is no buffer with the name you specify, one is created. If you append text into a buffer which has been used for editing, the copied text goes into the middle of the text of the buffer, wherever point happens to be in it. Point in that buffer is left at the end of the copied text, so successive uses of C-X A accumulate the text in the specified buffer in the same order as they were copied. If C-X A is given an argument, point in the other buffer is left before the copied text, so successive uses of C-X A add text in reverse order. You can retrieve the accumulated text from that buffer with M-X Insert Buffer (@fnc{insert-buffer-command}). This inserts a copy of the text in that buffer into the selected buffer. It prompts for the buffer name needed. You can also select the other buffer for editing. @Note("Buffers"), for background information on buffers. Strictly speaking, C-X A does not always append to the text already in the buffer. But if it is used on a buffer which starts out empty, it does keep appending to the end. Instead of accumulating text within NMODE, in a buffer, you can append text directly into a disk file with the command M-X Append to File (@fnc{append-to-file-command}). It adds the text of the region to the end of the specified file. M-X Prepend to File (@fnc{prepend-to-file-command}) adds the text to the beginning of the file instead. Both commands prompt for the file name. The file is changed immediately on disk. These commands are normally used with files that are @xxi(not) being visited in NMODE. They have the advantage of working even on files too large to fit into the NMODE address space. @Subsection[Copying Text Many Times] @keyindex{C-X X} @keyindex{C-X G} @fncindex{put-register-command} @fncindex{get-register-command} @index{registers} @label{NMODEregisters} @label{NMODE-registers} When you want to insert a copy of the same piece of text frequently, the kill ring becomes impractical, since the text moves down on the ring as you edit, and will be in an unpredictable place on the ring when you need it again. For this case, you can use the commands C-X X (@fnc{put-register-command}) and C-X G (@fnc{get-register-command}) to move the text. C-X X stores a copy of the text of the region in a place called a register. With an argument, C-X X deletes the text as well. C-X G inserts the text from a register into the buffer. Both these commands prompt for the register name, which must be a single letter or digit. This gives 36 places in which you can store a piece of text. Normally C-X G leaves point before the text and places the mark after, but with a numeric argument it puts point after the text and the mark before. |
Added psl-1983/3-1/doc/nmode/nm-killing.topic version [788bfdd4be].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | .silent_index {Backspace} idx 11-1 .silent_index {killing} idx 11-1 .silent_index {deletion} idx 11-1 .silent_index {Backspace} idx 11-1 .silent_index {lines} idx 11-1 .silent_index {blank} idx 11-2 .silent_index {numeric} idx 11-2 .silent_index {mark} idx 11-2 .silent_index {Region} idx 11-2 .silent_index {killing} idx 11-2 .silent_index {moving} idx 11-2 .silent_index {kill} idx 11-2 .silent_index {mark} idx 11-3 .silent_index {Region} idx 11-3 .silent_index {numeric} idx 11-4 .silent_index {registers} idx 11-5 |
Added psl-1983/3-1/doc/nmode/nm-mark.contents version [f2f75e6698].
> > > | 1 2 3 | contents_entry(0 10 {The Mark and the Region} 10-1) contents_entry(1 10.1 {Commands to Mark Textual Objects} 10-2) contents_entry(1 10.2 {The Ring of Marks} 10-2) |
Added psl-1983/3-1/doc/nmode/nm-mark.function version [b9cb3220be].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | .silent_index {uppercase-region-command} idx 10-1 .silent_index {set-mark-command} idx 10-1 .silent_index {exchange-point-and-mark} idx 10-1 .silent_index {mark-word-command} idx 10-2 .silent_index {mark-form-command} idx 10-2 .silent_index {mark-beginning-command} idx 10-2 .silent_index {mark-end-command} idx 10-2 .silent_index {mark-paragraph-command} idx 10-2 .silent_index {mark-defun-command} idx 10-2 .silent_index {mark-whole-buffer-command} idx 10-2 |
Added psl-1983/3-1/doc/nmode/nm-mark.ibm version [694f06dc6d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-MARK.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (The Mark and the Region) Page 10-1 202/10. The Mark and the Region 201/In general, a command which processes an arbitrary part of the buffer must know where to start and where to stop. In NMODE, such commands usually operate on the text between point and 202/the mark201/. This range of text is called 202/the region201/. To specify a region, you set point to one end of it and mark at the other. It doesn't matter which one is set first chronologically, or which one comes earlier in the text. Here are some commands for setting the mark: C-@ Set the mark where point is. C-Space The same. C-X C-X Interchange mark and point. M-@ Set mark after end of next word. This command and the following three do not move point. C-M-@ Set mark after end of next Lisp form. C-< Set mark at beginning of buffer. C-> Set mark at end of buffer. M-H Put region around current paragraph. C-M-H Put region around current Lisp defun. C-X H Put region around entire buffer. For example, if you wish to convert part of the buffer to all upper-case, you can use the C-X C-U command, which operates on the text in the region. You can first go to the beginning of the text to be capitalized, put the mark there, move to the end, and then type C-X C-U. Or, you can set the mark at the end of the text, move to the beginning, and then type C-X C-U. C-X C-U runs the function 203/uppercase-region-command201/, whose name signifies that the region, or everything between point and the mark, is to be capitalized. The most common way to set the mark is with the C-@ command or the C-Space command (203/set-mark-command201/). They set the mark where point is. Then you can move point away, leaving the mark behind. It isn't actually possible to type C-Space on non-Meta keyboards. Yet on many terminals the command appears to work anyway! This is because trying to type a Control-Space on those terminals actually sends the character C-@, which means the same thing as C-Space. A few keyboards just send a Space. If you have one of them, you type C-@, or customize your NMODE. Since terminals have only one cursor, there is no way for NMODE to show you where the mark is located. You have to remember. The usual solution to this problem is to set the mark and then use it soon, before you forget where it is. But you can see where the mark is with the command C-X C-X (203/exchange-point-and-mark201/) which puts the mark where point was and point where the mark was. The extent of the region is unchanged, but the cursor and point are now at the previous location of the mark. C-X C-X is also useful when you are satisfied with the location of point but want to move the mark; do C-X C-X to put point there and then you can move it. A second use of C-X C-X, if necessary, puts the mark at the new location with point back at its original location. If you insert or delete before the mark, the mark may drift through the 201/Page 10-2 NMODE Manual (The Mark and the Region) text. If the buffer contains "FOO BAR" and the mark is before the "B", then if you delete the "F" the mark will be before the "A". This is an unfortunate result of the simple way the mark is implemented. It is best not to delete or insert at places above the mark until you are finished using it and don't care where it drifts to. 202/10.1 Commands to Mark Textual Objects 201/There are commands for placing the mark on the other side of a certain object such as a word or a list, without having to move there first. M-@ (203/mark-word-command201/) puts the mark at the end of the next word, while C-M-@ (203/mark-form-command201/) puts it at the end of the next s-expression. C-> (203/mark-end-command201/) puts the mark at the end of the buffer, while C-< (203/mark-beginning-command201/) puts it at the beginning. These characters allow you to save a little typing or redisplay, sometimes. Other commands set both point and mark, to delimit an object in the buffer. M-H (203/mark-paragraph-command201/) puts point at the beginning of the paragraph it was inside of (or before), and puts the mark at the end. M-H does all that's necessary if you wish to case-convert or kill a whole paragraph. C-M-H (203/mark-defun-command201/) similarly puts point before and the mark after the current or next defun. Finally, C-X H (203/mark-whole-buffer-command201/) makes the region the entire buffer by putting point at the beginning and the mark at the end. 202/10.2 The Ring of Marks 201/Aside from delimiting the region, the mark is also useful for remembering a spot that you may want to go back to. To make this feature more useful, NMODE remembers 16 previous locations of the mark for each buffer. Most commands that set the mark push the old mark onto this stack. To return to a marked location, use C-U C-@ (or C-U C-Space). This moves point to where the mark was, and restores the mark from the stack of former marks. So repeated use of this command moves point to all of the old marks on the stack, one by one. Since the stack is actually a ring, enough uses of C-U C-@ bring point back to where it was originally. Insertion and deletion can cause the saved marks to drift, but they will still be good for this purpose because they are unlikely to drift very far. Some commands whose primary purpose is to move point a great distance take advantage of the stack of marks to give you a way to undo the command. The best example is M-<, which moves to the beginning of the buffer. It sets the mark first, so that you can use C-U C-@ or C-X C-X to go back to where you were. |
Added psl-1983/3-1/doc/nmode/nm-mark.key version [f7fb3d3c1d].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | .silent_index {C-X} idx 10-1 .silent_index {C-@} idx 10-1 .silent_index {C-Space} idx 10-1 .silent_index {C-X} idx 10-1 .silent_index {M-@} idx 10-2 .silent_index {C-M-@} idx 10-2 .silent_index {C->} idx 10-2 .silent_index {C-<} idx 10-2 .silent_index {M-H} idx 10-2 .silent_index {C-M-H} idx 10-2 .silent_index {C-X} idx 10-2 .silent_index {C-U} idx 10-2 .silent_index {C-U} idx 10-2 |
Added psl-1983/3-1/doc/nmode/nm-mark.r version [c7e8225531].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-MARK manual @Chapter[The Mark and the Region] @node("mark") @index{mark} @index{Region} @keyindex{C-X C-U} @fncindex{uppercase-region-command} In general, a command which processes an arbitrary part of the buffer must know where to start and where to stop. In NMODE, such commands usually operate on the text between point and @dfn[the mark]. This range of text is called @dfn[the region]. To specify a region, you set point to one end of it and mark at the other. It doesn't matter which one is set first chronologically, or which one comes earlier in the text. Here are some commands for setting the mark: @WideCommands[ C-@ Set the mark where point is. C-Space The same. C-X C-X Interchange mark and point. M-@ Set mark after end of next word. This command and the following three do not move point. C-M-@ Set mark after end of next Lisp form. C-< Set mark at beginning of buffer. C-> Set mark at end of buffer. M-H Put region around current paragraph. C-M-H Put region around current Lisp defun. C-X H Put region around entire buffer. ] For example, if you wish to convert part of the buffer to all upper-case, you can use the C-X C-U command, which operates on the text in the region. You can first go to the beginning of the text to be capitalized, put the mark there, move to the end, and then type C-X C-U. Or, you can set the mark at the end of the text, move to the beginning, and then type C-X C-U. C-X C-U runs the function @fnc{uppercase-region-command}, whose name signifies that the region, or everything between point and the mark, is to be capitalized. @keyindex{C-@} @keyindex{C-Space} @fncindex{set-mark-command} The most common way to set the mark is with the C-@ command or the C-Space command (@fnc{set-mark-command}). They set the mark where point is. Then you can move point away, leaving the mark behind. It isn't actually possible to type C-Space on non-Meta keyboards. Yet on many terminals the command appears to work anyway! This is because trying to type a Control-Space on those terminals actually sends the character C-@, which means the same thing as C-Space. A few keyboards just send a Space. If you have one of them, you type C-@, or customize your NMODE. @keyindex{C-X C-X} @fncindex{exchange-point-and-mark} Since terminals have only one cursor, there is no way for NMODE to show you where the mark is located. You have to remember. The usual solution to this problem is to set the mark and then use it soon, before you forget where it is. But you can see where the mark is with the command C-X C-X (@fnc{exchange-point-and-mark}) which puts the mark where point was and point where the mark was. The extent of the region is unchanged, but the cursor and point are now at the previous location of the mark. C-X C-X is also useful when you are satisfied with the location of point but want to move the mark; do C-X C-X to put point there and then you can move it. A second use of C-X C-X, if necessary, puts the mark at the new location with point back at its original location. If you insert or delete before the mark, the mark may drift through the text. If the buffer contains "FOO BAR" and the mark is before the "B", then if you delete the "F" the mark will be before the "A". This is an unfortunate result of the simple way the mark is implemented. It is best not to delete or insert at places above the mark until you are finished using it and don't care where it drifts to. @Section[Commands to Mark Textual Objects] @keyindex{M-@} @keyindex{C-M-@} @index{words} @index{lists} @keyindex{C->} @keyindex{C-<} @fncindex{mark-word-command} @fncindex{mark-form-command} @fncindex{mark-beginning-command} @fncindex{mark-end-command} There are commands for placing the mark on the other side of a certain object such as a word or a list, without having to move there first. M-@ (@fnc{mark-word-command}) puts the mark at the end of the next word, while C-M-@ (@fnc{mark-form-command}) puts it at the end of the next s-expression. C-> (@fnc{mark-end-command}) puts the mark at the end of the buffer, while C-< (@fnc{mark-beginning-command}) puts it at the beginning. These characters allow you to save a little typing or redisplay, sometimes. @index{paragraphs} @index{Defuns} @index{pages} @keyindex{M-H} @keyindex{C-M-H} @keyindex{C-X H} @fncindex{mark-paragraph-command} @fncindex{mark-defun-command} @fncindex{mark-whole-buffer-command} Other commands set both point and mark, to delimit an object in the buffer. M-H (@fnc{mark-paragraph-command}) puts point at the beginning of the paragraph it was inside of (or before), and puts the mark at the end. M-H does all that's necessary if you wish to case-convert or kill a whole paragraph. C-M-H (@fnc{mark-defun-command}) similarly puts point before and the mark after the current or next defun. Finally, C-X H (@fnc{mark-whole-buffer-command}) makes the region the entire buffer by putting point at the beginning and the mark at the end. @Section[The Ring of Marks] @keyindex{C-U C-@} @keyindex{C-U C-Space} Aside from delimiting the region, the mark is also useful for remembering a spot that you may want to go back to. To make this feature more useful, NMODE remembers 16 previous locations of the mark for each buffer. Most commands that set the mark push the old mark onto this stack. To return to a marked location, use @w[C-U C-@] (or @w[C-U C-Space]). This moves point to where the mark was, and restores the mark from the stack of former marks. So repeated use of this command moves point to all of the old marks on the stack, one by one. Since the stack is actually a ring, enough uses of @w[C-U C-@] bring point back to where it was originally. Insertion and deletion can cause the saved marks to drift, but they will still be good for this purpose because they are unlikely to drift very far. Some commands whose primary purpose is to move point a great distance take advantage of the stack of marks to give you a way to undo the command. The best example is M-<, which moves to the beginning of the buffer. It sets the mark first, so that you can use @w[C-U C-@] or @w[C-X C-X] to go back to where you were. |
Added psl-1983/3-1/doc/nmode/nm-mark.topic version [247b8c335f].
> > > > > > > | 1 2 3 4 5 6 7 | .silent_index {mark} idx 10-1 .silent_index {Region} idx 10-1 .silent_index {words} idx 10-2 .silent_index {lists} idx 10-2 .silent_index {paragraphs} idx 10-2 .silent_index {Defuns} idx 10-2 .silent_index {pages} idx 10-2 |
Added psl-1983/3-1/doc/nmode/nm-metax.contents version [0f55cd653d].
> > > > > | 1 2 3 4 5 | contents_entry(0 6 {Extended (Meta-X) Commands and Functions} 6-1) contents_entry(1 6.1 {Issuing Extended Commands} 6-1) contents_entry(2 6.1.1 {Typing The Command Name} 6-1) contents_entry(2 6.1.2 {Completion} 6-1) contents_entry(1 6.2 {Arcane Information about M-X Commands} 6-2) |
Added psl-1983/3-1/doc/nmode/nm-metax.function version [b295d8bf01].
> > > | 1 2 3 | .silent_index {m-x-prefix} idx 6-1 .silent_index {auto-fill-mode-command} idx 6-1 .silent_index {set-key-command} idx 6-2 |
Added psl-1983/3-1/doc/nmode/nm-metax.ibm version [85f2cad20a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-METAX.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Extended (Meta-X) Commands and Functions) Page 6-1 202/6. Extended (Meta-X) Commands and Functions 201/Not all NMODE commands are of the one or two character variety you have seen so far. Most commands have long invocations composed of English words. This is for two reasons: the long invocations are easier to remember and more suggestive, and there are not enough two-character combinations for every command to have one. The commands with long names are known as 202/extended commands 201/because they extend the set of two-character commands. 202/6.1 Issuing Extended Commands 201/M-X Begin an extended command. Follow by the command invocation only; the command will ask for any arguments. C-M-X Same as M-X. Extended commands are also called 202/M-X commands201/, because they all start with the character Meta-X (203/m-x-prefix201/). The M-X is followed by the command's long, suggestive invocation. The invocation is terminated with a Return. For example, Meta-X Auto Fill Mode<CR> invokes 203/auto-fill-mode-command201/. This function when executed turns Auto Fill mode on or off. There are a great many functions in NMODE for you to call. They will be described elsewhere in the manual, according to what they do. Here we are concerned only with extended commands in general. 202/6.1.1 Typing The Command Name 201/When you type M-X, the cursor moves down to the echo area at the bottom of the screen. "Extended Command:" is printed there, and when you type the command name it echoes there. This is known as 202/reading a line in the echo area201/. You can use any moving or deleting command (C-A, C-E, C-F, C-B , C-D, Backspace, etc.) to help construct the M-X command. A C-G cancels the whole M-X. These editing characters apply any time NMODE reads a line in the echo area, not just within M-X. The string "Extended Command:" which appears in the echo area is called a 202/prompt201/. The prompt always tells you what sort of argument is required and what it is going to be used for; "Extended Command:" means that you are inside of the command M-X, and should type the invocation of a function to be called. 202/6.1.2 Completion 201/You can abbreviate the name of the command, typing only the beginning of the name, as much as is needed to identify the command unambiguously. You can also use completion on the function name. This means that you type part of the command name, and NMODE visibly fills in the rest, or as much as can be determined from the part you have typed. 201/Page 6-2 NMODE Manual (Completion) You request completion by typing Return. For example, if you type M-X Au<CR>, the "Au" expands to "Auto Fill Mode" because "Auto Fill Mode" is the only command invocation that starts with "Au". If you ask for completion when there are several alternatives for the next character, the bell rings and nothing else happens. Space is another way to request completion, but it completes only one word. Successive Spaces complete one word each, until either there are multiple possibilities or the end of the name is reached. If the first word of a command is Edit, List, Kill, View or What, it is sufficient to type just the first letter and complete it with a Space. (This does not follow from the usual definition of completion, since the single letter is ambiguous; it is a special feature added because these words are so common). 202/6.2 Arcane Information about M-X Commands 201/You can skip this section if you are not interested in customization, unless you want to know what is going on behind the scenes. Actually, 203/every 201/command in NMODE simply runs a function. For example, when you type the command C-N, it runs the function "203/move-down-extending-command201/". C-N can be thought of as a sort of abbreviation. We say that the command C-N has been 202/connected 201/to the function 203/move-down-extending-command201/. The name is looked up once when the command and function are connected, so that it does not have to be looked up again each time the command is used. The documentation for individual NMODE commands usually gives the name of the function which really implements the command in parentheses after the command itself. Just as any function can be called directly with M-X, so almost any function can be connected to a command. You can use the command M-X Set Key (203/set-key-command201/) to do this. M-X Set Key reads the name of the function from the keyboard, then reads the character command (including metizers or other prefix characters) directly from the terminal. To define C-N, you could type M-X Set Key<CR>move-down-extending-command<CR> and then type C-N. If, for instance, you use the function 203/{auto-fill-mode-command} 201/often, you could connect it to the command C-X Z (not normally defined). You could even connect it to the command C-M-V, replacing that command's normal definition. Set Key is good for redefining commands in the middle of editing. An init file can do it each time you run NMODE. See Section 22.1 [Init], page 1. |
Added psl-1983/3-1/doc/nmode/nm-metax.key version [965fab0102].
> > > > | 1 2 3 4 | .silent_index {M-X} idx 6-1 .silent_index {C-D} idx 6-1 .silent_index {C-G} idx 6-1 .silent_index {M-X} idx 6-2 |
Added psl-1983/3-1/doc/nmode/nm-metax.lpt version [510d0f8266].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Node("M-X") Chapter[Extended (Meta-X) Commands and Functions] Not all NMODE commands are of the one or two character variety you have seen so far. Most commands have long invocations composed of English words. This is for two reasons: the long invocations are easier to remember and more suggestive, and there are not enough two-character combinations for every command to have one. The commands with long names are known as dfn[extended commands] because they extend the set of two-character commands. Section[Issuing Extended Commands] DoubleWideCommands[ M-X Begin an extended command. Follow by the command invocation only; the command will ask for any arguments. C-M-X Begin an extended command. Follow by the command invocation only; the command will ask for any arguments. ] index{extended commands} index{M-X} index{functions} index{commands} Extended commands are also called dfn[M-X commands], because they all start with the character Meta-X (fnc{m-x-prefix}). The M-X is followed by the command's long, suggestive invocation. Terminate the invocation with a Return3{}. For example, Meta-X Auto Fill Mode return2{} invokes the function auto-fill-mode-command. This function when executed turns Auto Fill mode on or off. There are a great many functions in NMODE for you to call. They will be described elsewhere in the manual, according to what they do. Here we are concerned only with extended commands in general. SubSection[Typing The Command Name] index{Backspace} index{C-D} index{C-U} index{C-G} index{echo area} When you type M-X, the cursor moves down to the echo area at the bottom of the screen. "M-X" is printed there, and when you type the command name it echoes there. This is known as dfn[reading a line in the echo area]. You can use any moving or deleting command (C-A, C-E, C-F, C-B , C-D, Backspace, etc.) to help construct the M-X command. A C-G cancels the whole M-X. These editing characters apply any time NMODE reads a line in the echo area, not just within M-X. - 2 - index{prompting} index{TECO} index{Read Command Prompt} The string "M-X" which appears in the echo area is called a dfn[prompt]. The prompt always tells you what sort of argument is required and what it is going to be used for; "M-X" means that you are inside of the command M-X, and should type the invocation of a function to be called. SubSection[Completion] index{command completion} index{Altmode} index{Space} You can abbreviate the name of the command, typing only the beginning of the name, as much as is needed to identify the command unambiguously. You can also use completion on the function name. This means that you type part of the command name, and NMODE visibly fills in the rest, or as much as can be determined from the part you have typed. You request completion by typing Return3{}. For example, if you type W[M-X Au Return2{}, the "Au" expands to W["Auto Fill Mode"] because "Auto Fill Mode" is the only command invocation that starts with "Au". If you ask for completion when there are several alternatives for the next character, the bell rings and nothing else happens. Space is another way to request completion, but it completes only one word. Successive Spaces complete one word each, until either there are multiple possibilities or the end of the name is reached. If the first word of a command is Edit, List, Kill, View or What, it is sufficient to type just the first letter and complete it with a Space. (This does not follow from the usual definition of completion, since the single letter is ambiguous; it is a special feature added because these words are so common). INFO{ Note("MMArcana" "MM"), for more information on this and other topics related to how extended commands work, how they are really the foundation of everything in NMODE, and how they relate to customization.} Node("MMArcana") Section[Arcane Information about M-X Commands] index{M-X} You can skip this section if you are not interested in customization, unless you want to know what is going on behind the scenes. index{customization} index{Connected} index{Functions} Actually, xxi[every] command in NMODE simply runs a function. For example, when you type the command C-N, it runs the function " fnc{move-down-extending-command}" C-N can be thought of as a sort of abbreviation. We say that the command C-N has been - 3 - dfn[connected] to the function fnc{move-down-extending-command}. The name is looked up once when the command and function are connected, so that it does not have to be looked up again each time the command is used. The documentation for individual NMODE commands usually gives the name of the function which really implements the command in parentheses after the command itself. index{Set Key} Just as any function can be called directly with M-X, so almost any function can be connected to a command. You can use the function Set Key to do this. Set Key takes the name of the function as a string argument, then reads the character command (including metizers or other prefix characters) directly from the terminal. To define C-N, you could type example[ M-X Set Key Return1{}move-down-extending-command Return1{} ] and then type C-N. If you use the function View File often, you could connect it to the command C-X Z (not normally defined). You could even connect it to the command C-M-V, replacing that command's normal definition. Set Key is good for redefining commands in the middle of editing. An init file or EVARS() file can do it each time you run NMODE. Note("Init"). Subsection[Subroutines] index{subroutines} index{command completion} NMODE is composed of a large number of functions, each with a name. Some of these functions are connected to commands; some are there for you to call with M-X; some are called by other functions. The last group are called subroutines. |
Added psl-1983/3-1/doc/nmode/nm-metax.r version [9347384a12].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-METAX manual @Chapter[Extended (Meta-X) Commands and Functions] @node("m-x") Not all NMODE commands are of the one or two character variety you have seen so far. Most commands have long invocations composed of English words. This is for two reasons: the long invocations are easier to remember and more suggestive, and there are not enough two-character combinations for every command to have one. The commands with long names are known as @dfn[extended commands] because they extend the set of two-character commands. @Section[Issuing Extended Commands] @DoubleWideCommands[ M-X Begin an extended command. Follow by the command invocation only; the command will ask for any arguments. C-M-X Same as M-X. ] @index{extended commands} @keyindex{M-X} @fncindex{m-x-prefix} @index{functions} @index{commands} @fncindex{auto-fill-mode-command} Extended commands are also called @dfn[M-X commands], because they all start with the character Meta-X (@fnc{m-x-prefix}). The M-X is followed by the command's long, suggestive invocation. The invocation is terminated with a @Return3{}. For example, Meta-X Auto Fill Mode@return2{} invokes @fnc{auto-fill-mode-command}. This function when executed turns Auto Fill mode on or off. There are a great many functions in NMODE for you to call. They will be described elsewhere in the manual, according to what they do. Here we are concerned only with extended commands in general. @SubSection[Typing The Command Name] @index{Backspace} @keyindex{C-D} @keyindex{C-G} @index{echo area} When you type M-X, the cursor moves down to the echo area at the bottom of the screen. "Extended Command:" is printed there, and when you type the command name it echoes there. This is known as @dfn[reading a line in the echo area]. You can use any moving or deleting command (C-A, C-E, C-F, C-B , C-D, Backspace, etc.) to help construct the M-X command. A C-G cancels the whole M-X. These editing characters apply any time NMODE reads a line in the echo area, not just within M-X. @index{prompting} @index{Read Command Prompt} The string "Extended Command:" which appears in the echo area is called a @dfn[prompt]. The prompt always tells you what sort of argument is required and what it is going to be used for; "Extended Command:" means that you are inside of the command M-X, and should type the invocation of a function to be called. @SubSection[Completion] @index{command completion} @index{return3{}} @index{Space} You can abbreviate the name of the command, typing only the beginning of the name, as much as is needed to identify the command unambiguously. You can also use completion on the function name. This means that you type part of the command name, and NMODE visibly fills in the rest, or as much as can be determined from the part you have typed. You request completion by typing @Return3{}. For example, if you type @W[M-X Au@Return2{}], the "Au" expands to @W["Auto Fill Mode"] because "Auto Fill Mode" is the only command invocation that starts with "Au". If you ask for completion when there are several alternatives for the next character, the bell rings and nothing else happens. Space is another way to request completion, but it completes only one word. Successive Spaces complete one word each, until either there are multiple possibilities or the end of the name is reached. If the first word of a command is Edit, List, Kill, View or What, it is sufficient to type just the first letter and complete it with a Space. (This does not follow from the usual definition of completion, since the single letter is ambiguous; it is a special feature added because these words are so common). @INFO{ @Note("MMArcana" "MM"), for more information on this and other topics related to how extended commands work, how they are really the foundation of everything in NMODE, and how they relate to customization.} @Section[Arcane Information about M-X Commands] @node("mmarcana") @keyindex{M-X} You can skip this section if you are not interested in customization, unless you want to know what is going on behind the scenes. @index{customization} @index{Connected} @index{Functions} Actually, @xxi[every] command in NMODE simply runs a function. For example, when you type the command C-N, it runs the function "@fnc{move-down-extending-command}". C-N can be thought of as a sort of abbreviation. We say that the command C-N has been @dfn[connected] to the function @fnc{move-down-extending-command}. The name is looked up once when the command and function are connected, so that it does not have to be looked up again each time the command is used. The documentation for individual NMODE commands usually gives the name of the function which really implements the command in parentheses after the command itself. @fncindex{set-key-command} Just as any function can be called directly with M-X, so almost any function can be connected to a command. You can use the command M-X Set Key (@fnc{set-key-command}) to do this. M-X Set Key reads the name of the function from the keyboard, then reads the character command (including metizers or other prefix characters) directly from the terminal. To define C-N, you could type @example[ M-X Set Key@Return1{}move-down-extending-command@Return1{} ] and then type C-N. If, for instance, you use the function @fnc({auto-fill-mode-command}) often, you could connect it to the command C-X Z (not normally defined). You could even connect it to the command C-M-V, replacing that command's normal definition. Set Key is good for redefining commands in the middle of editing. An init file can do it each time you run NMODE. @Note("Init"). |
Added psl-1983/3-1/doc/nmode/nm-metax.topic version [39251f551a].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | .silent_index {extended} idx 6-1 .silent_index {functions} idx 6-1 .silent_index {commands} idx 6-1 .silent_index {Backspace} idx 6-1 .silent_index {echo} idx 6-1 .silent_index {prompting} idx 6-1 .silent_index {Read} idx 6-1 .silent_index {command} idx 6-1 .silent_index {return3{}} idx 6-1 .silent_index {Space} idx 6-1 .silent_index {customization} idx 6-2 .silent_index {Connected} idx 6-2 .silent_index {Functions} idx 6-2 |
Added psl-1983/3-1/doc/nmode/nm-misc.contents version [f46ac36bda].
> | 1 | contents_entry(0 21 {Miscellaneous Commands} 21-1) |
Added psl-1983/3-1/doc/nmode/nm-misc.function version [a9c90dac41].
> > > | 1 2 3 | .silent_index {insert-date-command} idx 21-1 .silent_index {nmode-gc} idx 21-1 .silent_index {write-screen-command} idx 21-1 |
Added psl-1983/3-1/doc/nmode/nm-misc.ibm version [fc3b7e9847].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-MISC.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Miscellaneous Commands) Page 21-1 202/21. Miscellaneous Commands 201/This chapter covers some miscellaneous commands which don't fit naturally into earlier chapters. M-X Insert Date (203/insert-date-command201/) inserts the current date into the text in the current buffer. The mark is put after the inserted date and point is left unchanged. M-X Make Space (203/nmode-gc201/) reclaims any wasted internal space. It also indicates the remaining amount of free space. M-X Write Screen (203/write-screen-command201/) writes a copy of the current screen to a file. |
Added psl-1983/3-1/doc/nmode/nm-misc.key version [78ad683aa1].
> > > | 1 2 3 | .silent_index {M-X} idx 21-1 .silent_index {M-X} idx 21-1 .silent_index {M-X} idx 21-1 |
Added psl-1983/3-1/doc/nmode/nm-misc.r version [cc8d10672d].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | .so pndoc:nman .part NM-MISC manual @Chapter[Miscellaneous Commands] This chapter covers some miscellaneous commands which don't fit naturally into earlier chapters. @keyindex{M-X Insert Date} @fncindex{insert-date-command} M-X Insert Date (@fnc{insert-date-command}) inserts the current date into the text in the current buffer. The mark is put after the inserted date and point is left unchanged. @keyindex{M-X Make Space} @fncindex{nmode-gc} M-X Make Space (@fnc{nmode-gc}) reclaims any wasted internal space. It also indicates the remaining amount of free space. @keyindex{M-X Write Screen} @fncindex{write-screen-command} M-X Write Screen (@fnc{write-screen-command}) writes a copy of the current screen to a file. |
Added psl-1983/3-1/doc/nmode/nm-misc.topic version [df75c73349].
> > > | 1 2 3 | .silent_index {M-X} idx 20-1 .silent_index {M-X} idx 20-1 .silent_index {M-X} idx 20-1 |
Added psl-1983/3-1/doc/nmode/nm-programs.contents version [feda7b2e00].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | contents_entry(0 20 {Editing Programs} 20-1) contents_entry(1 20.1 {Major Modes} 20-1) contents_entry(1 20.2 {Indentation Commands for Code} 20-1) contents_entry(1 20.3 {Automatic Display Of Matching Parentheses} 20-2) contents_entry(1 20.4 {Manipulating Comments} 20-3) contents_entry(1 20.5 {Lisp Mode} 20-3) contents_entry(2 20.5.1 {Moving Over and Killing Lists and forms} 20-3) contents_entry(2 20.5.2 {Commands for Manipulating Defuns} 20-5) contents_entry(1 20.6 {Lisp Grinding} 20-6) contents_entry(1 20.7 {Lisp Language Interface} 20-7) contents_entry(2 20.7.1 {Evaluation} 20-7) contents_entry(2 20.7.2 {Debugging} 20-7) |
Added psl-1983/3-1/doc/nmode/nm-programs.function version [d087d4806c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {indent-new-line-command} idx 20-1 .silent_index {text-mode-command} idx 20-1 .silent_index {lisp-mode-command} idx 20-1 .silent_index {indent-new-line-command} idx 20-2 .silent_index {delete-indentation-command} idx 20-2 .silent_index {delete-horizontal-space-command} idx 20-2 .silent_index {split-line-command} idx 20-2 .silent_index {insert-closing-bracket} idx 20-2 .silent_index {insert-comment-command} idx 20-3 .silent_index {fill-comment-command} idx 20-3 .silent_index {lisp-tab-command} idx 20-3 .silent_index {delete-backward-hacking-tabs-command} idx 20-3 .silent_index {move-forward-form-command} idx 20-4 .silent_index {move-backward-form-command} idx 20-4 .silent_index {move-forward-list-command} idx 20-4 .silent_index {move-backward-list-command} idx 20-4 .silent_index {kill-backward-form-command} idx 20-4 .silent_index {kill-forward-form-command} idx 20-4 .silent_index {backward-up-list-command} idx 20-4 .silent_index {forward-up-list-command} idx 20-4 .silent_index {down-list-command} idx 20-4 .silent_index {transpose-forms} idx 20-5 .silent_index {mark-form-command} idx 20-5 .silent_index {make-parens-command} idx 20-5 .silent_index {move-over-paren-command} idx 20-5 .silent_index {move-backward-defun-command} idx 20-5 .silent_index {end-of-defun-command} idx 20-5 .silent_index {mark-defun-command} idx 20-5 .silent_index {lisp-tab-command} idx 20-6 .silent_index {indent-new-line-command} idx 20-6 .silent_index {delete-indentation-command} idx 20-6 .silent_index {lisp-indent-sexpr} idx 20-6 .silent_index {lisp-indent-region-command} idx 20-7 .silent_index {execute-defun-command} idx 20-7 .silent_index {execute-form-command} idx 20-7 .silent_index {yank-last-output-command} idx 20-7 .silent_index {lisp-abort-command} idx 20-8 .silent_index {lisp-quit-command} idx 20-8 .silent_index {lisp-backtrace-command} idx 20-8 .silent_index {lisp-continue-command} idx 20-8 .silent_index {lisp-retry-command} idx 20-8 .silent_index {lisp-help-command} idx 20-8 |
Added psl-1983/3-1/doc/nmode/nm-programs.ibm version [302d780ee2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-PROGRAMS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Editing Programs) Page 20-1 202/20. Editing Programs 201/Special features for editing lisp programs include automatic indentation, parenthesis matching, and the ability to move over and kill balanced expressions. Lisp mode defines paragraphs to be separated only by blank lines and page boundaries. This makes the paragraph commands useful for editing programs. See Section 13.2 [Paragraphs], page 2. Moving over words is useful for editing programs as well as text. See Section 13.1 [Words], page 1. 202/20.1 Major Modes 201/NMODE has many different 202/major modes201/. Two such modes are Text mode and Lisp mode. Each of these customizes NMODE, one for text, the other for Lisp programs. The major modes are mutually exclusive, and one major mode is current at any time. When at top level, NMODE always says in the mode line which major mode you are in. These modes tell NMODE to change the meanings of a few commands to become more specifically adapted to the language being edited. Most commands remain unchanged; the ones which usually change are Tab, Backspace, and Linefeed. In addition, a few special move and mark commands are turned on in Lisp mode which are not available in text mode. Selecting a new major mode can be done with a M-X command. For example M-X Text Mode (203/text-mode-command201/) enters text mode and M-X Lisp Mode (203/lisp-mode-command201/) enters lisp mode. As can be seen from these examples, some major mode's names are the same as the invocations of the functions to select those modes. Often NMODE enters the correct major mode for a file simply based on the file's extension, and you do not have to worry about selecting a mode. Lisp mode specifies that only blank lines separate paragraphs. This is so that the paragraph commands remain useful. 202/20.2 Indentation Commands for Code 201/Tab Indents current line. Linefeed Equivalent to Return followed by Tab. M-^ Joins two lines, leaving one space between if appropriate. C-M-O Split the current line. M-\ Deletes all spaces and tabs around point. M-M Moves to the first nonblank character on the line. Most programming languages have some indentation convention. For Lisp code, lines are indented according to their nesting in parentheses. Whatever the language, to indent a line, use the Tab command. Each major mode defines this command to perform the sort of indentation appropriate for the particular language. In Lisp mode, Tab aligns the line according to its 201/Page 20-2 NMODE Manual (Indentation Commands for Code) depth in parentheses. No matter where in the line you are when you type Tab, it aligns the line as a whole. The command Linefeed (203/indent-new-line-command201/) does a Return and then does a Tab on the next line. Thus, Linefeed at the end of the line makes a following blank line and supplies it with the usual amount of indentation. Linefeed in the middle of a line breaks the line and supplies the usual indentation in front of the new line. The inverse of Linefeed is Meta-^ or C-M-^ (203/delete-indentation-command201/). This command deletes the indentation at the front of the current line, and the line separator as well. They are replaced by a single space, or by no space if before a ")" or after a "(", or at the beginning of a line. With an argument, M-^ joins the current line and the 203/next 201/line, removing indentation at the front of the next line beforehand. To delete just the indentation of a line, go to the beginning of the line and use Meta-\ (203/delete-horizontal-space-command201/), which deletes all spaces and tabs around the cursor. Another command which affects indentation is C-M-O (203/split-line-command201/). It moves the rest of the current line, after point, down vertically. It indents the new line so that the rest of the line winds up in the same column that it was in before the split. If this command is given a positive argument, it adds enough empty lines between the old line and the new line that the total number of lines added equals the argument. The command leaves point unchanged. To insert an indented line before the current one, do C-A, C-O, and then Tab. To make an indented line after the current one, use C-E Linefeed. To move over the indentation on a line, use Meta-M or C-M-M (203/back-to-indentation-command201/). These commands move the cursor forward or back to the first nonblank character on the line. 202/20.3 Automatic Display Of Matching Parentheses 201/The NMODE parenthesis-matching feature is designed to show automatically how parentheses balance in text as it is typed in. When this feature is enabled, after a close parenthesis or other close bracket character is inserted (using 203/insert-closing-bracket201/) the cursor automatically moves for an instant to the open bracket which balances the newly inserted character. The cursor stays at the open parenthesis for a second before returning home, unless you type another command before the second is up. It is worth emphasizing that the location of point, the place where your type-in will be inserted, is not affected by the parenthesis matching feature. It stays after the close parenthesis, where it ought to be. Only the cursor on the screen moves away and back. You can type ahead freely as if the parenthesis display feature did not exist. In fact, if you type fast enough, you won't see the cursor move. You must pause after typing a close parenthesis to let the cursor move to the open parenthesis. 201/NMODE Manual (Automatic Display Of Matching Parentheses) Page 20-3 An additional function is whether NMODE should warn you by ringing the bell if you type an unmatched close parenthesis. NMODE will warn you if you are editing a language in which parentheses are paramount, such as Lisp, but will not do so for languages in which parentheses are not so crucial. 202/20.4 Manipulating Comments 201/M-; Insert comment. M-Z Fill a block of comments. There are two NMODE commands which affect comments. First there is M-; (203/insert-comment-command201/), which jumps to the end of the current line and inserts a percent sign and a space, thus starting a comment. Second, there is M-Z (203/fill-comment-command201/), which allows filling of blocks of comments. It fills a paragraph using whatever text is adjacent to the current line and begins with the same sequence of blank characters, nonalphanumeric characters, and more blank characters as the current line. As a result, it will fill all lines starting with " % ", for instance. Notice that it will NOT do any filling if the current line differs in indentation from the rest of the paragraph of comments (i.e. if it is an indented first line). 202/20.5 Lisp Mode 201/Lisp's simple syntax makes it much easier for an editor to understand; as a result, NMODE can do more for Lisp, and with less work, than for any other language. Lisp programs should be edited in Lisp mode. In this mode, Tab is defined to indent the current line according to the conventions of Lisp programming style. It does not matter where in the line Tab is used; the effect on the line is the same. The function which does the work is called 203/lisp-tab-command201/. Linefeed, as usual, does a Return and a Tab, so it moves to the next line and indents it. As in most modes where indentation is likely to vary from line to line, Backspace (203/delete-backward-hacking-tabs-command 201/in Lisp mode) is redefined to treat a tab as if it were the equivalent number of spaces. This makes it possible to rub out indentation one position at a time without worrying whether it is made up of spaces or tabs. Paragraphs are defined to start only with blank lines so that the paragraph commands can be useful. Auto Fill indents the new lines which it creates. Comments start with "%". 202/20.5.1 Moving Over and Killing Lists and forms 201/C-M-F Move Forward over form. C-M-B Move Backward over form. C-M-K Kill form forward. C-M-Rubout Kill form backward. 201/Page 20-4 NMODE Manual (Moving Over and Killing Lists and forms) C-M-U Move Up and backward in list structure. C-M-( Same as C-M-U. C-( Same as C-M-U. C-M-) Move up and forward in list structure. C-) Same as C-M-). C-M-D Move Down and forward in list structure. C-M-N Move forward over a list. C-M-P Move backward over a list. C-M-T Transpose forms. C-M-@ Put mark after form. M-( Put parentheses around next form(s). M-) Move past next close parenthesis and re-indent. By convention, NMODE commands that deal with balanced parentheses are usually Control-Meta- characters. They tend to be analogous in function to their Control- and Meta- equivalents. These commands are usually thought of as pertaining to Lisp, but can be useful with any language in which some sort of parentheses exist (including English). They are, however, only defined in Lisp mode. To move forward over a form, use C-M-F (203/move-forward-form-command201/). If the first significant character after point is an "(", C-M-F moves past the matching ")". If the first character is a ")", C-M-F just moves past it. If the character begins an atom, C-M-F moves to the end of the atom. C-M-F with an argument repeats that operation the specified number of times; with a negative argument, it moves backward instead. The command C-M-B (203/move-backward-form-command201/) moves backward over a form; it is like C-M-F with the argument's sign reversed. If there are "'"-like characters in front of the form moved over, they are moved over as well. Thus, with point after " 'FOO ", C-M-B leaves point before the "'", not before the "F". These two commands (and the commands in this section) know how to handle comments, string literals, and all other token syntax in (unaltered) PSL. NMODE makes one restriction: it will not handle string literals that extend over multiple lines. Two other commands move over lists instead of forms are often useful. They are C-M-N (203/move-forward-list-command201/) and C-M-P (203/move-backward-list-command201/). They act like C-M-F and C-M-B except that they don't stop on atoms; after moving over an atom, they move over the next expression, stopping after moving over a list. With these commands, you can avoid stopping after all of the atomic arguments to a function. Killing a form at a time can be done with C-M-K (203/kill-forward-form-command201/) and C-M-Rubout (203/kill-backward-form-command201/) commands. C-M-K kills the characters that C-M-F would move over, and C-M-Rubout kills what C-M-B would move over. C-M-F and C-M-B stay at the same level in parentheses, when that's possible. To move 203/up 201/one (or n) levels, use C-M-( or C-M-) (203/backward-up-list 201/and 203/forward-up-list-command201/). C-M-( moves backward up 201/NMODE Manual (Moving Over and Killing Lists and forms) Page 20-5 past one containing "(". C-M-) moves forward up past one containing ")". Given a positive argument, these commands move up the specified number of levels of parentheses. C-M-U is another name for C-M-(, which is easier to type, especially on non-Meta keyboards. If you use that name, it is useful to know that a negative argument makes the command move up forwards, like C-M-). C-M-( and C-M-) are also availible as C-( and C-), respectively, which are easier to type on the hp9836 keyboard. To move 203/down 201/in list structure, use C-M-D (203/down-list-command201/). It is nearly the same as searching for a "(". A somewhat random-sounding command which is nevertheless easy to use is C-M-T (203/transpose-forms201/), which drags the previous form across the next one. An argument serves as a repeat count, and a negative argument drags backwards (thus canceling out the effect of C-M-T with a positive argument). An argument of zero, rather than doing nothing, transposes the forms at the point and the mark. To make the region be the next form in the buffer, use C-M-@ (203/mark-form-command201/) which sets mark at the same place that C-M-F would move to. C-M-@ takes arguments like C-M-F. In particular, a negative argument is useful for putting the mark at the beginning of the previous form. The commands M-( (203/make-parens-command201/) and M-) (203/move-over-paren-command201/) are designed for a style of editing which keeps parentheses balanced at all times. M-( inserts a pair of parentheses, either together as in "()", or, if given an argument, around the next several forms, and leaves point after the open parenthesis. Instead of typing "(FOO)", you can type M-( FOO, which has the same effect except for leaving the cursor before the close parenthesis. Then you type M-), which moves past the close parenthesis, deleting any indentation preceding it (in this example there is none), and indenting with Linefeed after it. 202/20.5.2 Commands for Manipulating Defuns 201/C-M-[, C-M-A Move to beginning of defun. C-M-], C-M-E Move to end of defun. C-M-H Put region around whole defun. For historical reasons, an expression at the top level in the buffer is called a 202/defun201/, regardless of what function is actually called by the expression. One might imagine that NMODE finds defuns by moving upward a level of parentheses until there were no more levels to go up. This would require scanning all the way back to the beginning of the file. To speed up the operation, NMODE assumes that any "(" in column 0 is the start of a defun. This heuristic is nearly always right and avoids the costly scan. The commands to move to the beginning and end of the current defun are C-M-[ (203/move-backward-defun-command201/) and C-M-] (203/end-of-defun-command201/). Alternate names for these two commands are C-M-A for C-M-[ and C-M-E for C-M-]. The alternate names are easier to type on many non-Meta keyboards. 201/Page 20-6 NMODE Manual (Commands for Manipulating Defuns) If you wish to operate on the current defun, use C-M-H (203/mark-defun-command201/) which puts point at the beginning and mark at the end of the current or next defun. 202/20.6 Lisp Grinding 201/The best way to keep Lisp code properly indented ("ground") is to use NMODE to re-indent it when it is changed. NMODE has commands to indent properly either a single line, a specified number of lines, or all of the lines inside a single form. Tab In Lisp mode, re-indents line according to parenthesis depth. Linefeed Equivalent to Return followed by Tab. M-^ Join two lines, leaving one space between them if appropriate. C-M-Q Re-indent all the lines within one list. The basic indentation function is 203/lisp-tab-command201/, which gives the current line the correct indentation as determined from the previous lines' indentation and parenthesis structure. This function is placed on Tab in Lisp mode (Use Meta-Tab or C-Q Tab to insert a tab). If executed at the beginning of a line, it leaves point after the indentation; when given inside the text on the line, it leaves point fixed with respect to the characters around it. When entering a large amount of new code, use Linefeed (203/indent-new-line-command201/), which is equivalent to a Return followed by a Tab. In Lisp mode, a Linefeed creates or moves down onto a blank line, and then gives it the appropriate indentation. To join two lines together, use the Meta-^ or Control-Meta-^ command (203/delete-indentation-command201/), which is approximately the opposite of Linefeed. It deletes any spaces and tabs at the front of the current line, and then deletes the line separator before the line. A single space is then inserted, if NMODE thinks that one is needed there. Spaces are not needed before a close parenthesis, or after an open parenthesis. If you are dissatisfied about where Tab indents the second and later lines of an form, you can override it. If you alter the indentation of one of the lines yourself, then Tab will indent successive lines of the same list to be underneath it. This is the right thing for functions which Tab indents unaesthetically. When you wish to re-indent code which has been altered or moved to a different level in the list structure, you have several commands available. You can re-indent a specific number of lines by giving the ordinary indent command (Tab, in Lisp mode) an argument. This indents as many lines as you say and moves to the line following them. Thus, if you underestimate, you can repeat the process later. You can re-indent the contents of a single form by positioning point before the beginning of it and typing Control-Meta-Q (203/lisp-indent-sexpr201/). The line the form starts on is not re-indented; thus, only the relative indentation 201/NMODE Manual (Lisp Grinding) Page 20-7 with in the form, and not its position, is changed. To correct the position as well, type a Tab before the C-M-Q. Another way to specify the range to be re-indented is with point and mark. The command C-M-\ (203/lisp-indent-region-command201/) applies Tab to every line whose first character is between point and mark. In Lisp mode, this does a Lisp indent. The standard pattern of indentation is as follows: the second line of the expression is indented under the first argument, if that is on the same line as the beginning of the expression; otherwise, the second line is indented two spaces more than the entire expression. Each following line is indented under the previous line whose nesting depth is the same. 202/20.7 Lisp Language Interface 201/The following section contains many commands starting with "Lisp-". This prefix is equivalent to C-], but can sometimes be typed using a soft key. 202/20.7.1 Evaluation 201/NMODE contains a number of facilities to allow the user to use the underlying LISP language. In addition to editing and pretty-printing LISP expressions with the commands in the preceding sections, the user can execute the LISP expressions in the buffer. Lisp-D Execute the current Defun. Lisp-E Execute the form starting on this line. Lisp-Y Yanks the last output into current buffer. Lisp-D (203/execute-defun-command201/) causes the Lisp reader to read and evaluate the current defun. If there is no current defun, the Lisp reader will read a form starting at the current location. We arrange for output to be appended to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. Lisp-E (203/execute-form-command201/) causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to be appended to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. Lisp-Y (203/yank-last-output-command201/) copies the last piece of output from the output buffer back into the current buffer, allowing it to be added to some code or text within the current buffer. 202/20.7.2 Debugging 201/The commands of the last subsection allow one to use the underlying LISP, provided that no errors occur in the evaluation of expressions. The commands of this subsection allow recovery from errors in evaluations. When an error occurs, one enters a "break loop". This is indicated by the presence of more than one angle bracket on the lisp prompt at the right hand 201/Page 20-8 NMODE Manual (Debugging) side of the mode line under the output buffer. When one is in a break loop, one can still evaluate lisp expressions. Additional errors at this point will wrap additional break loops around the current one. Commands available in break loops include: Lisp-A Abort break loops. Lisp-Q Quit current break loop. Lisp-B Backtrace function calls. Lisp-C Continue execution. Lisp-R Retry expression. Lisp-? Help command Lisp-A (203/lisp-abort-command201/) will pop out of an arbitrarily deep break loop. Lisp-Q (203/lisp-quit-command201/) exits the current break loop. It only pops up one level, unlike abort. Lisp-B (203/lisp-backtrace-command201/) lists all the function calls on the stack. The most recently invoked function is listed first. It is a good way to see how the offending expression got generated. Unfortunately, many internal functions of Lisp and NMODE are shown, so the list may get somewhat cluttered. Lisp-C (203/lisp-continue-command201/) causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. Lisp-R (203/lisp-retry-command201/) tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. Lisp-? (203/lisp-help-command201/) lists the lisp commands available. When in a break loop it prints: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" Otherwise it prints: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" |
Added psl-1983/3-1/doc/nmode/nm-programs.key version [6f9c57d68e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Tab} idx 20-1 .silent_index {Rubout} idx 20-1 .silent_index {Linefeed} idx 20-1 .silent_index {backspace} idx 20-1 .silent_index {Tab} idx 20-1 .silent_index {M-^} idx 20-2 .silent_index {M-\} idx 20-2 .silent_index {C-M-O} idx 20-2 .silent_index {C-A} idx 20-2 .silent_index {C-O} idx 20-2 .silent_index {C-E} idx 20-2 .silent_index {M-M} idx 20-2 .silent_index {C-M-M} idx 20-2 .silent_index {M-;} idx 20-3 .silent_index {M-Z} idx 20-3 .silent_index {Tab} idx 20-3 .silent_index {C-M-F} idx 20-4 .silent_index {C-M-B} idx 20-4 .silent_index {C-M-N} idx 20-4 .silent_index {C-M-P} idx 20-4 .silent_index {C-M-Rubout} idx 20-4 .silent_index {C-M-K} idx 20-4 .silent_index {C-M-U} idx 20-4 .silent_index {C-M-(} idx 20-4 .silent_index {C-M-)} idx 20-4 .silent_index {C-M-D} idx 20-4 .silent_index {C-M-T} idx 20-5 .silent_index {C-M-@} idx 20-5 .silent_index {M-(} idx 20-5 .silent_index {M-)} idx 20-5 .silent_index {C-M-A} idx 20-5 .silent_index {C-M-E} idx 20-5 .silent_index {C-M-H} idx 20-5 .silent_index {C-M-[} idx 20-5 .silent_index {C-M-]} idx 20-5 .silent_index {Tab} idx 20-6 .silent_index {C-M-Tab} idx 20-6 .silent_index {C-M-Tab} idx 20-6 .silent_index {C-M-^} idx 20-6 .silent_index {M-^} idx 20-6 .silent_index {C-M-Q} idx 20-6 .silent_index {C-M-\} idx 20-7 .silent_index {lisp-A} idx 20-8 .silent_index {lisp-Q} idx 20-8 .silent_index {lisp-B} idx 20-8 .silent_index {lisp-C} idx 20-8 .silent_index {lisp-R} idx 20-8 .silent_index {lisp-?} idx 20-8 |
Added psl-1983/3-1/doc/nmode/nm-programs.r version [fd06f87dce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-PROGRAMS manual @Chapter(Editing Programs) @node("programs") Special features for editing lisp programs include automatic indentation, parenthesis matching, and the ability to move over and kill balanced expressions. Lisp mode defines paragraphs to be separated only by blank lines and page boundaries. This makes the paragraph commands useful for editing programs. @Note("Sentences" "Paragraphs"). Moving over words is useful for editing programs as well as text. @Note("Words"). @Section[Major Modes] @node("majormodes") @index{major modes} @keyindex{Tab} @keyindex{Rubout} @keyindex{Linefeed} @keyindex{backspace} @index{comments} @fncindex{indent-new-line-command} NMODE has many different @dfn[major modes]. Two such modes are Text mode and Lisp mode. Each of these customizes NMODE, one for text, the other for Lisp programs. The major modes are mutually exclusive, and one major mode is current at any time. When at top level, NMODE always says in the mode line which major mode you are in. These modes tell NMODE to change the meanings of a few commands to become more specifically adapted to the language being edited. Most commands remain unchanged; the ones which usually change are Tab, Backspace, and Linefeed. In addition, a few special move and mark commands are turned on in Lisp mode which are not available in text mode. @fncindex{text-mode-command} @fncindex{lisp-mode-command} Selecting a new major mode can be done with a M-X command. For example M-X Text Mode (@fnc{text-mode-command}) enters text mode and M-X Lisp Mode (@fnc{lisp-mode-command}) enters lisp mode. As can be seen from these examples, some major mode's names are the same as the invocations of the functions to select those modes. Often NMODE enters the correct major mode for a file simply based on the file's extension, and you do not have to worry about selecting a mode. Lisp mode specifies that only blank lines separate paragraphs. This is so that the paragraph commands remain useful. They also cause Auto Fill mode to use the definition of Tab to indent the new lines it creates. This is because most lines in a program are usually indented. @Section[Indentation Commands for Code] @node("indenting") @WideCommands[ Tab Indents current line. Linefeed Equivalent to @Return3{} followed by Tab. M-^ Joins two lines, leaving one space between if appropriate. C-M-O Split the current line. M-\ Deletes all spaces and tabs around point. M-M Moves to the first nonblank character on the line. ] @keyindex{Tab} @index{indentation} @index{Lisp} Most programming languages have some indentation convention. For Lisp code, lines are indented according to their nesting in parentheses. Whatever the language, to indent a line, use the Tab command. Each major mode defines this command to perform the sort of indentation appropriate for the particular language. In Lisp mode, Tab aligns the line according to its depth in parentheses. No matter where in the line you are when you type Tab, it aligns the line as a whole. @index{Linefeed} @fncindex{indent-new-line-command} The command Linefeed (@fnc{indent-new-line-command}) does a @Return3{} and then does a Tab on the next line. Thus, Linefeed at the end of the line makes a following blank line and supplies it with the usual amount of indentation. Linefeed in the middle of a line breaks the line and supplies the usual indentation in front of the new line. @keyindex{M-^} @fncindex{delete-indentation-command} @keyindex{M-\} @fncindex{delete-horizontal-space-command} The inverse of Linefeed is Meta-^ or C-M-^ (@fnc{delete-indentation-command}). This command deletes the indentation at the front of the current line, and the line separator as well. They are replaced by a single space, or by no space if before a ")" or after a "(", or at the beginning of a line. With an argument, M-^ joins the current line and the @xxi[next] line, removing indentation at the front of the next line beforehand. To delete just the indentation of a line, go to the beginning of the line and use Meta-\ (@fnc{delete-horizontal-space-command}), which deletes all spaces and tabs around the cursor. @keyindex{C-M-O} @fncindex{split-line-command} Another command which affects indentation is C-M-O (@fnc{split-line-command}). It moves the rest of the current line, after point, down vertically. It indents the new line so that the rest of the line winds up in the same column that it was in before the split. If this command is given a positive argument, it adds enough empty lines between the old line and the new line that the total number of lines added equals the argument. The command leaves point unchanged. @keyindex{C-A} @keyindex{C-O} @keyindex{C-E} To insert an indented line before the current one, do C-A, C-O, and then Tab. To make an indented line after the current one, use C-E Linefeed. @keyindex{M-M} @keyindex{C-M-M} To move over the indentation on a line, use Meta-M or C-M-M (@fnc{back-to-indentation-command}). These commands move the cursor forward or back to the first nonblank character on the line. @Section[Automatic Display Of Matching Parentheses] @index{matching} @index{parentheses} @node("matching") @fncindex{insert-closing-bracket} The NMODE parenthesis-matching feature is designed to show automatically how parentheses balance in text as it is typed in. When this feature is enabled, after a close parenthesis or other close bracket character is inserted (using @fnc{insert-closing-bracket}) the cursor automatically moves for an instant to the open bracket which balances the newly inserted character. The cursor stays at the open parenthesis for a second before returning home, unless you type another command before the second is up. It is worth emphasizing that the location of point, the place where your type-in will be inserted, is not affected by the parenthesis matching feature. It stays after the close parenthesis, where it ought to be. Only the cursor on the screen moves away and back. You can type ahead freely as if the parenthesis display feature did not exist. In fact, if you type fast enough, you won't see the cursor move. You must pause after typing a close parenthesis to let the cursor move to the open parenthesis. An additional function is whether NMODE should warn you by ringing the bell if you type an unmatched close parenthesis. NMODE will warn you if you are editing a language in which parentheses are paramount, such as Lisp, but will not do so for languages in which parentheses are not so crucial. @Section[Manipulating Comments] @index{comments} @node("comments") @keyindex{M-;} @keyindex{M-Z} @fncindex{insert-comment-command} @fncindex{fill-comment-command} @WideCommands[ M-; Insert comment. M-Z Fill a block of comments. ] There are two NMODE commands which affect comments. First there is M-; (@fnc{insert-comment-command}), which jumps to the end of the current line and inserts a percent sign and a space, thus starting a comment. Second, there is M-Z (@fnc{fill-comment-command}), which allows filling of blocks of comments. It fills a paragraph using whatever text is adjacent to the current line and begins with the same sequence of blank characters, nonalphanumeric characters, and more blank characters as the current line. As a result, it will fill all lines starting with " % ", for instance. Notice that it will NOT do any filling if the current line differs in indentation from the rest of the paragraph of comments (i.e. if it is an indented first line). @Section[Lisp Mode] @node("lisp") Lisp's simple syntax makes it much easier for an editor to understand; as a result, NMODE can do more for Lisp, and with less work, than for any other language. @fncindex{lisp-tab-command} @keyindex{Tab} @index{Lisp mode} Lisp programs should be edited in Lisp mode. In this mode, Tab is defined to indent the current line according to the conventions of Lisp programming style. It does not matter where in the line Tab is used; the effect on the line is the same. The function which does the work is called @fnc{lisp-tab-command}. Linefeed, as usual, does a @Return3{} and a Tab, so it moves to the next line and indents it. @index{Backspace} @fncindex{delete-backward-hacking-tabs-command} As in most modes where indentation is likely to vary from line to line, Backspace (@fnc{delete-backward-hacking-tabs-command} in Lisp mode) is redefined to treat a tab as if it were the equivalent number of spaces. This makes it possible to rub out indentation one position at a time without worrying whether it is made up of spaces or tabs. @index{Paragraphs} @index{syntax table} @index{comments} @index{Auto Fill} @index{blank lines} Paragraphs are defined to start only with blank lines so that the paragraph commands can be useful. Auto Fill indents the new lines which it creates. Comments start with "%". @SubSection[Moving Over and Killing Lists and forms] @index{Lists} @index{forms} @node("lists") @DoubleWideCommands[ C-M-F Move Forward over form. C-M-B Move Backward over form. C-M-K Kill form forward. C-M-Rubout Kill form backward. C-M-U Move Up and backward in list structure. C-M-( Same as C-M-U. C-( Same as C-M-U. C-M-) Move up and forward in list structure. C-) Same as C-M-). C-M-D Move Down and forward in list structure. C-M-N Move forward over a list. C-M-P Move backward over a list. C-M-T Transpose forms. C-M-@ Put mark after form. M-( Put parentheses around next form(s). M-) Move past next close parenthesis and re-indent. ] @index{Control-Meta} By convention, NMODE commands that deal with balanced parentheses are usually Control-Meta- characters. They tend to be analogous in function to their Control- and Meta- equivalents. These commands are usually thought of as pertaining to Lisp, but can be useful with any language in which some sort of parentheses exist (including English). They are, however, only defined in Lisp mode. @index{motion} @keyindex{C-M-F} @keyindex{C-M-B} @fncindex{move-forward-form-command} @fncindex{move-backward-form-command} To move forward over a form, use C-M-F (@fnc{move-forward-form-command}). If the first significant character after point is an "(", C-M-F moves past the matching ")". If the first character is a ")", C-M-F just moves past it. If the character begins an atom, C-M-F moves to the end of the atom. C-M-F with an argument repeats that operation the specified number of times; with a negative argument, it moves backward instead. The command C-M-B (@fnc{move-backward-form-command}) moves backward over a form; it is like C-M-F with the argument's sign reversed. If there are "'"-like characters in front of the form moved over, they are moved over as well. Thus, with point after @w[" 'FOO "], C-M-B leaves point before the "'", not before the "F". @index{comments} These two commands (and the commands in this section) know how to handle comments, string literals, and all other token syntax in (unaltered) PSL. NMODE makes one restriction: it will not handle string literals that extend over multiple lines. @keyindex{C-M-N} @keyindex{C-M-P} @fncindex{move-forward-list-command} @fncindex{move-backward-list-command} Two other commands move over lists instead of forms are often useful. They are C-M-N (@fnc{move-forward-list-command}) and C-M-P (@fnc{move-backward-list-command}). They act like C-M-F and C-M-B except that they don't stop on atoms; after moving over an atom, they move over the next expression, stopping after moving over a list. With these commands, you can avoid stopping after all of the atomic arguments to a function. @index{killing} @keyindex{C-M-Rubout} @keyindex{C-M-K} @fncindex{kill-backward-form-command} @fncindex{kill-forward-form-command} Killing a form at a time can be done with C-M-K (@fnc{kill-forward-form-command}) and C-M-Rubout (@fnc{kill-backward-form-command}) commands. C-M-K kills the characters that C-M-F would move over, and C-M-Rubout kills what C-M-B would move over. @keyindex{C-M-U} @keyindex{C-M-(} @keyindex{C-M-)} @keyindex{C-M-D} @fncindex{backward-up-list-command} @fncindex{forward-up-list-command} @fncindex{down-list-command} C-M-F and C-M-B stay at the same level in parentheses, when that's possible. To move @xxii[up] one (or n) levels, use C-M-( or C-M-) (@fnc{backward-up-list} and @fnc{forward-up-list-command}). C-M-( moves backward up past one containing "(". C-M-) moves forward up past one containing ")". Given a positive argument, these commands move up the specified number of levels of parentheses. C-M-U is another name for C-M-(, which is easier to type, especially on non-Meta keyboards. If you use that name, it is useful to know that a negative argument makes the command move up forwards, like C-M-). C-M-( and C-M-) are also availible as C-( and C-), respectively, which are easier to type on the hp9836 keyboard. To move @xxii[down] in list structure, use C-M-D (@fnc{down-list-command}). It is nearly the same as searching for a "(". @index{transposition} @keyindex{C-M-T} @fncindex{transpose-forms} A somewhat random-sounding command which is nevertheless easy to use is C-M-T (@fnc{transpose-forms}), which drags the previous form across the next one. An argument serves as a repeat count, and a negative argument drags backwards (thus canceling out the effect of C-M-T with a positive argument). An argument of zero, rather than doing nothing, transposes the forms at the point and the mark. @index{mark} @keyindex{C-M-@} @fncindex{mark-form-command} To make the region be the next form in the buffer, use C-M-@ (@fnc{mark-form-command}) which sets mark at the same place that C-M-F would move to. C-M-@ takes arguments like C-M-F. In particular, a negative argument is useful for putting the mark at the beginning of the previous form. @keyindex{M-(} @keyindex{M-)} @fncindex{make-parens-command} @fncindex{move-over-paren-command} The commands M-( (@fnc{make-parens-command}) and M-) (@fnc{move-over-paren-command}) are designed for a style of editing which keeps parentheses balanced at all times. M-( inserts a pair of parentheses, either together as in "()", or, if given an argument, around the next several forms, and leaves point after the open parenthesis. Instead of typing "(FOO)", you can type M-( FOO, which has the same effect except for leaving the cursor before the close parenthesis. Then you type M-), which moves past the close parenthesis, deleting any indentation preceding it (in this example there is none), and indenting with Linefeed after it. @SubSection[Commands for Manipulating Defuns] @index{Defuns} @node("defuns") @DoubleWideCommands( C-M-[, C-M-A Move to beginning of defun. C-M-], C-M-E Move to end of defun. C-M-H Put region around whole defun. ) @keyindex{C-M-A} @fncindex{move-backward-defun-command} @keyindex{C-M-E} @fncindex{end-of-defun-command} @keyindex{C-M-H} @fncindex{mark-defun-command} @index{mark} @index{Region} @index{motion} @keyindex{C-M-[} @keyindex{C-M-]} For historical reasons, an expression at the top level in the buffer is called a @dfn[defun], regardless of what function is actually called by the expression. One might imagine that NMODE finds defuns by moving upward a level of parentheses until there were no more levels to go up. This would require scanning all the way back to the beginning of the file. To speed up the operation, NMODE assumes that any "(" in column 0 is the start of a defun. This heuristic is nearly always right and avoids the costly scan. The commands to move to the beginning and end of the current defun are C-M-[ (@fnc{move-backward-defun-command}) and C-M-] (@fnc{end-of-defun-command}). Alternate names for these two commands are C-M-A for C-M-[ and C-M-E for C-M-]. The alternate names are easier to type on many non-Meta keyboards. If you wish to operate on the current defun, use C-M-H (@fnc{mark-defun-command}) which puts point at the beginning and mark at the end of the current or next defun. @Section[Lisp Grinding] @node("grinding") @index{indentation} @index{formatting} @index{grinding} @keyindex{Tab} @keyindex{C-M-Tab} The best way to keep Lisp code properly indented ("ground") is to use NMODE to re-indent it when it is changed. NMODE has commands to indent properly either a single line, a specified number of lines, or all of the lines inside a single form. @WideCommands[ Tab In Lisp mode, re-indents line according to parenthesis depth. Linefeed Equivalent to @Return3{} followed by Tab. M-^ Join two lines, leaving one space between them if appropriate. C-M-Q Re-indent all the lines within one list. ] @fncindex{lisp-tab-command} @keyindex{C-M-Tab} The basic indentation function is @fnc{lisp-tab-command}, which gives the current line the correct indentation as determined from the previous lines' indentation and parenthesis structure. This function is placed on Tab in Lisp mode (Use Meta-Tab or C-Q Tab to insert a tab). If executed at the beginning of a line, it leaves point after the indentation; when given inside the text on the line, it leaves point fixed with respect to the characters around it. @index{Linefeed} @fncindex{indent-new-line-command} When entering a large amount of new code, use Linefeed (@fnc{indent-new-line-command}), which is equivalent to a @Return3{} followed by a Tab. In Lisp mode, a Linefeed creates or moves down onto a blank line, and then gives it the appropriate indentation. @keyindex{C-M-^} @keyindex{M-^} @fncindex{delete-indentation-command} To join two lines together, use the Meta-^ or Control-Meta-^ command (@fnc{delete-indentation-command}), which is approximately the opposite of Linefeed. It deletes any spaces and tabs at the front of the current line, and then deletes the line separator before the line. A single space is then inserted, if NMODE thinks that one is needed there. Spaces are not needed before a close parenthesis, or after an open parenthesis. If you are dissatisfied about where Tab indents the second and later lines of an form, you can override it. If you alter the indentation of one of the lines yourself, then Tab will indent successive lines of the same list to be underneath it. This is the right thing for functions which Tab indents unaesthetically. @index{numeric arguments} When you wish to re-indent code which has been altered or moved to a different level in the list structure, you have several commands available. You can re-indent a specific number of lines by giving the ordinary indent command (Tab, in Lisp mode) an argument. This indents as many lines as you say and moves to the line following them. Thus, if you underestimate, you can repeat the process later. @keyindex{C-M-Q} @fncindex{lisp-indent-sexpr} You can re-indent the contents of a single form by positioning point before the beginning of it and typing Control-Meta-Q (@fnc{lisp-indent-sexpr}). The line the form starts on is not re-indented; thus, only the relative indentation with in the form, and not its position, is changed. To correct the position as well, type a Tab before the C-M-Q. @keyindex{C-M-\} @index{Region} @fncindex{lisp-indent-region-command} Another way to specify the range to be re-indented is with point and mark. The command C-M-\ (@fnc{lisp-indent-region-command}) applies Tab to every line whose first character is between point and mark. In Lisp mode, this does a Lisp indent. The standard pattern of indentation is as follows: the second line of the expression is indented under the first argument, if that is on the same line as the beginning of the expression; otherwise, the second line is indented two spaces more than the entire expression. Each following line is indented under the previous line whose nesting depth is the same. @section[Lisp Language Interface] The following section contains many commands starting with "Lisp-". This prefix is equivalent to C-], but can sometimes be typed using a soft key. @subsection[Evaluation] NMODE contains a number of facilities to allow the user to use the underlying LISP language. In addition to editing and pretty-printing LISP expressions with the commands in the preceding sections, the user can execute the LISP expressions in the buffer. @doublewidecommands( Lisp-D Execute the current Defun. Lisp-E Execute the form starting on this line. Lisp-Y Yanks the last output into current buffer.) @fncindex{execute-defun-command} Lisp-D (@fnc{execute-defun-command}) causes the Lisp reader to read and evaluate the current defun. If there is no current defun, the Lisp reader will read a form starting at the current location. We arrange for output to be appended to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. @fncindex{execute-form-command} Lisp-E (@fnc{execute-form-command}) causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to be appended to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. @fncindex{yank-last-output-command} Lisp-Y (@fnc{yank-last-output-command}) copies the last piece of output from the output buffer back into the current buffer, allowing it to be added to some code or text within the current buffer. @subsection[Debugging] The commands of the last subsection allow one to use the underlying LISP, provided that no errors occur in the evaluation of expressions. The commands of this subsection allow recovery from errors in evaluations. When an error occurs, one enters a "break loop". This is indicated by the presence of more than one angle bracket on the lisp prompt at the right hand side of the mode line under the output buffer. When one is in a break loop, one can still evaluate lisp expressions. Additional errors at this point will wrap additional break loops around the current one. Commands available in break loops include: @doublewidecommands( Lisp-A Abort break loops. Lisp-Q Quit current break loop. Lisp-B Backtrace function calls. Lisp-C Continue execution. Lisp-R Retry expression. Lisp-? Help command) @fncindex{lisp-abort-command} @keyindex{lisp-A} Lisp-A (@fnc{lisp-abort-command}) will pop out of an arbitrarily deep break loop. @fncindex{lisp-quit-command} @keyindex{lisp-Q} Lisp-Q (@fnc{lisp-quit-command}) exits the current break loop. It only pops up one level, unlike abort. @fncindex{lisp-backtrace-command} @keyindex{lisp-B} Lisp-B (@fnc{lisp-backtrace-command}) lists all the function calls on the stack. The most recently invoked function is listed first. It is a good way to see how the offending expression got generated. Unfortunately, many internal functions of Lisp and NMODE are shown, so the list may get somewhat cluttered. @fncindex{lisp-continue-command} @keyindex{lisp-C} Lisp-C (@fnc{lisp-continue-command}) causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. @fncindex{lisp-retry-command} @keyindex{lisp-R} Lisp-R (@fnc{lisp-retry-command}) tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. @fncindex{lisp-help-command} @keyindex{lisp-?} Lisp-? (@fnc{lisp-help-command}) lists the lisp commands available. When in a break loop it prints: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" Otherwise it prints: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" |
Added psl-1983/3-1/doc/nmode/nm-programs.topic version [7c32979327].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {major} idx 20-1 .silent_index {comments} idx 20-1 .silent_index {indentation} idx 20-1 .silent_index {Lisp} idx 20-1 .silent_index {Linefeed} idx 20-2 .silent_index {matching} idx 20-2 .silent_index {parentheses} idx 20-2 .silent_index {comments} idx 20-3 .silent_index {Lisp} idx 20-3 .silent_index {Backspace} idx 20-3 .silent_index {Paragraphs} idx 20-3 .silent_index {syntax} idx 20-3 .silent_index {comments} idx 20-3 .silent_index {Auto} idx 20-3 .silent_index {blank} idx 20-3 .silent_index {Lists} idx 20-3 .silent_index {forms} idx 20-3 .silent_index {Control-Meta} idx 20-4 .silent_index {motion} idx 20-4 .silent_index {comments} idx 20-4 .silent_index {killing} idx 20-4 .silent_index {transposition} idx 20-5 .silent_index {mark} idx 20-5 .silent_index {Defuns} idx 20-5 .silent_index {mark} idx 20-5 .silent_index {Region} idx 20-5 .silent_index {motion} idx 20-5 .silent_index {indentation} idx 20-6 .silent_index {formatting} idx 20-6 .silent_index {grinding} idx 20-6 .silent_index {Linefeed} idx 20-6 .silent_index {numeric} idx 20-6 .silent_index {Region} idx 20-7 |
Added psl-1983/3-1/doc/nmode/nm-replacement.contents version [39305394f3].
> > > | 1 2 3 | contents_entry(0 19 {Replacement Commands} 19-1) contents_entry(1 19.1 {Query Replace} 19-1) contents_entry(1 19.2 {Other Search-and-loop Functions} 19-1) |
Added psl-1983/3-1/doc/nmode/nm-replacement.function version [b4c6d7057c].
> > > > > | 1 2 3 4 5 | .silent_index {replace-string-command} idx 19-1 .silent_index {query-replace-command} idx 19-1 .silent_index {count-occurrences-command} idx 19-1 .silent_index {delete-non-matching-lines-command} idx 19-1 .silent_index {delete-matching-lines-command} idx 19-1 |
Added psl-1983/3-1/doc/nmode/nm-replacement.ibm version [f649c74a5d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-REPLACEMENT.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Replacement Commands) Page 19-1 202/19. Replacement Commands 201/Global search-and-replace operations are not needed as often in NMODE as they are in other editors, but they are available. In addition to the simple Replace operation which is like that found in most editors, there is a Query Replace operation which asks you, for each occurrence of the pattern, whether to replace it. To replace every instance of FOO after point with BAR, you can do M-X Replace<CR>FOO<CR>BAR<CR> This invokes 203/replace-string-command201/. Replacement occurs only after point, so if you want to cover the whole buffer you must go to the beginning first. Replacement continues to the end of the buffer. 202/19.1 Query Replace 201/If you want to change only some of the occurrences of FOO, not all, then you cannot use an ordinary Replace. Instead, use M-X Query Replace<CR>FOO<CR>BAR<CR> (203/query-replace-command201/). This displays each occurrence of FOO and waits for you to say whether to replace it with a BAR. The things you can type when you are shown an occurrence of FOO are: Space to replace the FOO Rubout to skip to the next FOO without replacing this one. Comma to replace this FOO and display the result. You are then asked for another input character, except that since the replacement has already been made, Rubout and Space are equivalent. Escape to exit without doing any more replacements. Period to replace this FOO and then exit. ! to replace all remaining FOO's without asking. ^ to go back to the previous FOO (or, where it was), in case you have made a mistake. If you type any other character, the Query Replace is exited, and the character executed as a command. 202/19.2 Other Search-and-loop Functions 201/Here are some other functions related to replacement. Their arguments are strings. M-X How Many<CR>FOO<CR> invoke 203/count-occurrences-command 201/and print the number of occurrences of FOO after point. M-X Count Occurrences<CR>FOO<CR> Same as M-X How Many. 201/Page 19-2 NMODE Manual (Other Search-and-loop Functions) M-X Keep Lines<CR>FOO<CR> invoke 203/delete-non-matching-lines-command 201/and kill all lines after point that don't contain FOO. M-X Delete Non-Matching Lines<CR>FOO<CR> Same as M-X Keep Lines. M-X Flush Lines<CR>FOO<CR> invoke 203/delete-matching-lines-command 201/and kill all lines after point that contain FOO. M-X Delete Matching Lines<CR>FOO<CR> Same as M-X Flush Lines. |
Added psl-1983/3-1/doc/nmode/nm-replacement.key version [6582868ce6].
> | 1 | .silent_index {ESCape} idx 19-1 |
Added psl-1983/3-1/doc/nmode/nm-replacement.r version [345e0b3066].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-REPLACEMENT manual @Chapter[Replacement Commands] @node("replace") @index{searching} @index{replacement} @index{Replace String} Global search-and-replace operations are not needed as often in NMODE as they are in other editors, but they are available. In addition to the simple Replace operation which is like that found in most editors, there is a Query Replace operation which asks you, for each occurrence of the pattern, whether to replace it. @fncindex{replace-string-command} To replace every instance of FOO after point with BAR, you can do @example[ M-X Replace@return1{}FOO@return1{}BAR@return1{} ] This invokes @fnc{replace-string-command}. Replacement occurs only after point, so if you want to cover the whole buffer you must go to the beginning first. Replacement continues to the end of the buffer. @Section[Query Replace] @index{Query Replace} @fncindex{query-replace-command} If you want to change only some of the occurrences of FOO, not all, then you cannot use an ordinary Replace. Instead, use M-X Query Replace@return1{}FOO@return1{}BAR@return2{} (@fnc{query-replace-command}). This displays each occurrence of FOO and waits for you to say whether to replace it with a BAR. The things you can type when you are shown an occurrence of FOO are: @index{Space} @index{Rubout} @index{Comma} @keyindex{ESCape (Execute)} @index{.} @index{!} @index{^} @WideCommands{ Space to replace the FOO Rubout to skip to the next FOO without replacing this one. Comma to replace this FOO and display the result. You are then asked for another input character, except that since the replacement has already been made, Rubout and Space are equivalent. Escape to exit without doing any more replacements. Period to replace this FOO and then exit. ! to replace all remaining FOO's without asking. ^ to go back to the previous FOO (or, where it was), in case you have made a mistake. } If you type any other character, the Query Replace is exited, and the character executed as a command. @Section[Other Search-and-loop Functions] Here are some other functions related to replacement. Their arguments are strings. @fncindex{count-occurrences-command} @fncindex{delete-non-matching-lines-command} @fncindex{delete-matching-lines-command} @index{deletion}@index{replacement} @GrossCommands[ M-X How Many@return1{}FOO@return1{} invoke @fnc{count-occurrences-command} and print the number of occurrences of FOO after point. M-X Count Occurrences@return1{}FOO@return1{} Same as M-X How Many. M-X Keep Lines@return1{}FOO@return1{} invoke @fnc{delete-non-matching-lines-command} and kill all lines after point that don't contain FOO. M-X Delete Non-Matching Lines@return1{}FOO@return1{} Same as M-X Keep Lines. M-X Flush Lines@return1{}FOO@return1{} invoke @fnc{delete-matching-lines-command} and kill all lines after point that contain FOO. M-X Delete Matching Lines@return1{}FOO@return1{} Same as M-X Flush Lines. ] |
Added psl-1983/3-1/doc/nmode/nm-replacement.topic version [33804df20d].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | .silent_index {searching} idx 19-1 .silent_index {replacement} idx 19-1 .silent_index {Replace} idx 19-1 .silent_index {Query} idx 19-1 .silent_index {Space} idx 19-1 .silent_index {Rubout} idx 19-1 .silent_index {Comma} idx 19-1 .silent_index {.} idx 19-1 .silent_index {!} idx 19-1 .silent_index {^} idx 19-1 .silent_index {deletion} idx 19-1 .silent_index {replacement} idx 19-1 |
Added psl-1983/3-1/doc/nmode/nm-screen.contents version [287faa2d32].
> > | 1 2 | contents_entry(0 2 {The Organization of the Screen} 2-1) contents_entry(1 2.1 {The Mode Line} 2-1) |
Added psl-1983/3-1/doc/nmode/nm-screen.function version [0513b18c5d].
> | 1 | .silent_index {nmode-invert-video} idx 2-1 |
Added psl-1983/3-1/doc/nmode/nm-screen.ibm version [4eb47f0701].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-SCREEN.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (The Organization of the Screen) Page 2-1 202/2. The Organization of the Screen 201/NMODE divides the screen into several areas, each of which contains its own sorts of information. The biggest area, of course, is the one in which you usually see the text you are editing. The terminal's cursor usually appears in the middle of the text, showing the position of 202/point201/, the location at which editing takes place. While the cursor appears to point 203/at 201/a character, point should be thought of as 203/between 201/two characters; it points 203/before 201/the character that the cursor appears on top of. Terminals have only one cursor, and when output is in progress it must appear where the typing is being done. This does not mean that point is moving. It is only that NMODE has no way to show you the location of point except when the terminal is idle. One terminal function which 203/is 201/flexible is the choice of normal or inverse video for displaying text. Nmode lets you toggle this feature with the C-X V (203/nmode-invert-video201/) command. A few lines at the bottom of the screen compose what is called the 202/echo area201/. 202/Echoing 201/means printing out the commands that you type. NMODE commands are usually not echoed at all, but if you pause for more than a second in the middle of a multi-character command then all the characters typed so far are echoed. This is intended to 202/prompt 201/you for the rest of the command. The rest of the command is echoed, too, as you type it. This behavior is designed to give confident users optimum response, while giving hesitant users maximum feedback. NMODE also uses the echo area for reading and displaying the arguments for some commands, such as searches, and for printing brief information in response to certain commands. 202/2.1 The Mode Line 201/The line above the echo area is known as the 202/mode line201/. It is the line that usually starts with "NMODE something". Its purpose is to tell you anything that may affect the meaning of your commands aside from the text itself. NMODE major (minor) [bfr] file --pos-- * 202/major 201/is always the name of the 202/major mode 201/you are in. At any time, NMODE is in one and only one of its possible major modes. The major modes available include Text mode, Lisp mode (which NMODE starts out in), Recurse mode, Browser modes, and others. See Section 20.1 [Major Modes], page 1, for details of how the modes differ and how to select one. 202/minor 201/is a list of some of the 202/minor modes 201/that are turned on at the moment. "Fill" means that Auto Fill mode is on. 202/bfr 201/is the name of the currently selected 202/buffer201/. Each buffer has its own name and holds a file being edited; this is how NMODE can hold several files at once. But at any time you are editing only one of them, the 202/selected 201/buffer. When we speak of what some command does to "the buffer", we are talking about the currently selected buffer. Multiple buffers make it easy to 201/Page 2-2 NMODE Manual (The Mode Line) switch around between several files, and then it is very useful that the mode line tells you which one you are editing at any time. However, before you learn how to use multiple buffers, you will always be in the buffer called "Main", which is one that exists when NMODE starts up. If the name of the buffer is the same as the name of the file you are visiting, then the buffer name is left out of the mode line. See Section 16 [Buffers], page 1, for how to use more than one buffer in one NMODE. 202/file 201/is the name of the file that you are editing. It is the last file that was visited in the buffer you are in. The star at the end of the mode line means that there are changes in the buffer that have not been saved in the file. If the file has not been changed since it was read in or saved, there is no star. 202/pos 201/tells you whether there is additional text above the top of the screen, or below the bottom. If your file is small and it is all on the screen, --pos-- is omitted. Otherwise, it is --TOP-- if you are looking at the beginning of the file, --BOT-- if you are looking at the end of the file, or --nn%-- where nn is the percentage of the file above the top of the screen. If you are accustomed to other display editors, you may be surprised that NMODE does not always display the page number and line number of point in the mode line. This is because the text is stored in a way that makes it difficult to compute this information. Displaying them all the time would be too slow to be borne. However, once you are adjusted to NMODE, you will rarely have any reason to be concerned with page numbers or line numbers. |
Added psl-1983/3-1/doc/nmode/nm-screen.r version [4f4abe97e5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-SCREEN manual @Chapter[The Organization of the Screen] @node("screen") @index{cursor} @index{screen} @index{Point} NMODE divides the screen into several areas, each of which contains its own sorts of information. The biggest area, of course, is the one in which you usually see the text you are editing. The terminal's cursor usually appears in the middle of the text, showing the position of @dfn[point], the location at which editing takes place. While the cursor appears to point @xxii[at] a character, point should be thought of as @xxii[between] two characters; it points @xxii[before] the character that the cursor appears on top of. Terminals have only one cursor, and when output is in progress it must appear where the typing is being done. This does not mean that point is moving. It is only that NMODE has no way to show you the location of point except when the terminal is idle. @fncindex{nmode-invert-video} One terminal function which @xxii[is] flexible is the choice of normal or inverse video for displaying text. Nmode lets you toggle this feature with the C-X V (@fnc{nmode-invert-video}) command. @index{echo area} @index{prompting} A few lines at the bottom of the screen compose what is called the @dfn[echo area]. @dfn[Echoing] means printing out the commands that you type. NMODE commands are usually not echoed at all, but if you pause for more than a second in the middle of a multi-character command then all the characters typed so far are echoed. This is intended to @dfn[prompt] you for the rest of the command. The rest of the command is echoed, too, as you type it. This behavior is designed to give confident users optimum response, while giving hesitant users maximum feedback. NMODE also uses the echo area for reading and displaying the arguments for some commands, such as searches, and for printing brief information in response to certain commands. @INFO{ The line above the echo area is known as the @dfn[mode line]. It is the line that usually starts with "NMODE something". Its purpose is to tell what is going on in the NMODE, and to show any reasons why commands may not be interpreted in the standard way. The mode line is very important, and if you are surprised by how NMODE reacts to your commands you should look there for enlightenment.} @Section[The Mode Line] @index{mode line} @node("modeline") The line above the echo area is known as the @dfn[mode line]. It is the line that usually starts with "NMODE something". Its purpose is to tell you anything that may affect the meaning of your commands aside from the text itself. @Example[ NMODE major (minor) [bfr] file --pos-- * ] @index{major modes}@index{submode} @dfn[major] is always the name of the @dfn[major mode] you are in. At any time, NMODE is in one and only one of its possible major modes. The major modes available include Text mode, Lisp mode (which NMODE starts out in), Recurse mode, Browser modes, and others. @Note("MajorModes" "Major Modes"), for details of how the modes differ and how to select one. @index{minor modes} @index{Auto Fill mode} @dfn[minor] is a list of some of the @dfn[minor modes] that are turned on at the moment. "Fill" means that Auto Fill mode is on. @index{buffers} @dfn[bfr] is the name of the currently selected @dfn[buffer]. Each buffer has its own name and holds a file being edited; this is how NMODE can hold several files at once. But at any time you are editing only one of them, the @dfn[selected] buffer. When we speak of what some command does to "the buffer", we are talking about the currently selected buffer. Multiple buffers make it easy to switch around between several files, and then it is very useful that the mode line tells you which one you are editing at any time. However, before you learn how to use multiple buffers, you will always be in the buffer called "Main", which is one that exists when NMODE starts up. If the name of the buffer is the same as the name of the file you are visiting, then the buffer name is left out of the mode line. @Note("Buffers"), for how to use more than one buffer in one NMODE. @index{files} @dfn[file] is the name of the file that you are editing. It is the last file that was visited in the buffer you are in. The star at the end of the mode line means that there are changes in the buffer that have not been saved in the file. If the file has not been changed since it was read in or saved, there is no star. @dfn[pos] tells you whether there is additional text above the top of the screen, or below the bottom. If your file is small and it is all on the screen, --pos-- is omitted. Otherwise, it is --TOP-- if you are looking at the beginning of the file, --BOT-- if you are looking at the end of the file, or --nn%-- where nn is the percentage of the file above the top of the screen. If you are accustomed to other display editors, you may be surprised that NMODE does not always display the page number and line number of point in the mode line. This is because the text is stored in a way that makes it difficult to compute this information. Displaying them all the time would be too slow to be borne. However, once you are adjusted to NMODE, you will rarely have any reason to be concerned with page numbers or line numbers. |
Added psl-1983/3-1/doc/nmode/nm-screen.topic version [4686b544c8].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | .silent_index {cursor} idx 2-1 .silent_index {screen} idx 2-1 .silent_index {Point} idx 2-1 .silent_index {echo} idx 2-1 .silent_index {prompting} idx 2-1 .silent_index {mode} idx 2-1 .silent_index {major} idx 2-1 .silent_index {submode} idx 2-1 .silent_index {minor} idx 2-1 .silent_index {Auto} idx 2-1 .silent_index {buffers} idx 2-1 .silent_index {files} idx 2-2 |
Added psl-1983/3-1/doc/nmode/nm-searching.contents version [4da83480b1].
> | 1 | contents_entry(0 12 {Searching} 12-1) |
Added psl-1983/3-1/doc/nmode/nm-searching.function version [104645410b].
> > | 1 2 | .silent_index {incremental-search-command} idx 12-1 .silent_index {reverse-search-command} idx 12-1 |
Added psl-1983/3-1/doc/nmode/nm-searching.ibm version [a1fc13b41f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-SEARCHING.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Searching) Page 12-1 202/12. Searching 201/Like other editors, NMODE has commands for searching for an occurrence of a string. The search command is unusual in that it is 202/incremental201/; it begins to search before you have finished typing the search string. As you type in the search string, NMODE shows you where it would be found. When you have typed enough characters to identify the place you want, you can stop. Depending on what you will do next, you may or may not need to terminate the search explicitly with an Escape (Execute on the hp9836) first. C-S Search forward. C-R Search backward. The command to search is C-S (203/incremental-search-command201/). C-S reads in characters and positions the cursor at the first occurrence of the characters that you have typed. If you type C-S and then F, the cursor moves right after the first "F". Type an "O", and see the cursor move to after the first "FO". After another "O", the cursor is after the first "FOO" after the place where you started the search. At the same time, the "FOO" has echoed at the bottom of the screen. If you type a mistaken character, you can delete it. After the FOO, typing a Backspace makes the "O" disappear from the bottom of the screen, leaving only "FO". The cursor moves back to the "FO". Deleting the "O" and "F" moves the cursor back to where you started the search. When you are satisfied with the place you have reached, you can type an Escape, which stops searching, leaving the cursor where the search brought it. Also, any command not specially meaningful in searches stops the searching and is then executed. 204/1 201/Thus, typing C-A would exit the search and then move to the beginning of the line. escape is necessary only if the next command you want to type is a printing character, Rubout, Backspace, Escape, C-Q, or another search command, since those are the characters that have special meanings inside the search. Sometimes you search for "FOO" and find it, but not the one you expected to find. There was a second FOO that you forgot about, before the one you were looking for. Then type another C-S and the cursor will find the next FOO. This can be done any number of times. If you overshoot, you can delete the C-S's. After you exit a search, you can search for the same string again by typing just C-S C-S: one C-S command to start the search and then another C-S to mean "search again". ______________________________ 201/ 1. A few other commands are not executed after a search. Most special function keys send commands which begin with Escape. This escape is taken as terminating the search, and the rest of the command is then executed. ESC-A, for instance, will terminate the search and insert A, instead of terminating the search and jumping up a line. 201/Page 12-2 NMODE Manual (Searching) If your string is not found at all, the echo area says "Failing I-Search". The cursor is after the place where NMODE found as much of your string as it could. Thus, if you search for FOOT, and there is no FOOT, you might see the cursor after the FOO in FOOL. At this point there are several things you can do. If your string was mistyped, you can rub some of it out and correct it. If you like the place you have found, you can type Escape or some other NMODE command to "accept what the search offered". Or you can type C-G, which throws away the characters that could not be found (the "T" in "FOOT"), leaving those that were found (the "FOO" in "FOOT"). A second C-G at that point undoes the search entirely. The C-G "quit" command does special things during searches; just what, depends on the status of the search. If the search has found what you specified and is waiting for input, C-G cancels the entire search. The cursor moves back to where you started the search. If C-G is typed while the search is actually searching for something or updating the display, or after search failed to find some of your input (having searched all the way to the end of the file), then only the characters which have not been found are discarded. Having discarded them, the search is now successful and waiting for more input, so a second C-G will cancel the entire search. Make sure you wait for the first C-G to ring the bell before typing the second one; if typed too soon, the second C-G may be confused with the first and effectively lost. You can also type C-R at any time to start searching backwards. If a search fails because the place you started was too late in the file, you should do this. Repeated C-R's keep looking for more occurrences backwards. A C-S starts going forwards again. C-R's can be rubbed out just like anything else. If you know that you want to search backwards, you can use C-R instead of C-S to start the search, because C-R is also a command (203/reverse-search-command201/) to search backward. All sorts of searches in NMODE normally ignore the case of the text they are searching through; if you specify searching for FOO, then Foo and foo are also considered a match. |
Added psl-1983/3-1/doc/nmode/nm-searching.key version [e9ebeef108].
> > > | 1 2 3 | .silent_index {C-S} idx 12-1 .silent_index {C-R} idx 12-1 .silent_index {C-G} idx 12-2 |
Added psl-1983/3-1/doc/nmode/nm-searching.r version [136cf004c3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-SEARCHING manual @Chapter[Searching] @node("search") Like other editors, NMODE has commands for searching for an occurrence of a string. The search command is unusual in that it is @dfn[incremental]; it begins to search before you have finished typing the search string. As you type in the search string, NMODE shows you where it would be found. When you have typed enough characters to identify the place you want, you can stop. Depending on what you will do next, you may or may not need to terminate the search explicitly with an Escape (Execute on the hp9836) first. @WideCommands[ C-S Search forward. C-R Search backward. ] @index{searching} @keyindex{C-S} @keyindex{C-R} @fncindex{incremental-search-command} @fncindex{reverse-search-command} The command to search is C-S (@fnc{incremental-search-command}). C-S reads in characters and positions the cursor at the first occurrence of the characters that you have typed. If you type C-S and then F, the cursor moves right after the first "F". Type an "O", and see the cursor move to after the first "FO". After another "O", the cursor is after the first "FOO" after the place where you started the search. At the same time, the "FOO" has echoed at the bottom of the screen. If you type a mistaken character, you can delete it. After the FOO, typing a Backspace makes the "O" disappear from the bottom of the screen, leaving only "FO". The cursor moves back to the "FO". Deleting the "O" and "F" moves the cursor back to where you started the search. When you are satisfied with the place you have reached, you can type an Escape, which stops searching, leaving the cursor where the search brought it. Also, any command not specially meaningful in searches stops the searching and is then executed. @foot{A few other commands are not executed after a search. Most special function keys send commands which begin with Escape. This escape is taken as terminating the search, and the rest of the command is then executed. ESC-A, for instance, will terminate the search and insert A, instead of terminating the search and jumping up a line.} Thus, typing C-A would exit the search and then move to the beginning of the line. escape is necessary only if the next command you want to type is a printing character, Rubout, Backspace, Escape, C-Q, or another search command, since those are the characters that have special meanings inside the search. Sometimes you search for "FOO" and find it, but not the one you expected to find. There was a second FOO that you forgot about, before the one you were looking for. Then type another C-S and the cursor will find the next FOO. This can be done any number of times. If you overshoot, you can delete the C-S's. After you exit a search, you can search for the same string again by typing just C-S C-S: one C-S command to start the search and then another C-S to mean "search again". If your string is not found at all, the echo area says "Failing I-Search". The cursor is after the place where NMODE found as much of your string as it could. Thus, if you search for FOOT, and there is no FOOT, you might see the cursor after the FOO in FOOL. At this point there are several things you can do. If your string was mistyped, you can rub some of it out and correct it. If you like the place you have found, you can type Escape or some other NMODE command to "accept what the search offered". Or you can type C-G, which throws away the characters that could not be found (the "T" in "FOOT"), leaving those that were found (the "FOO" in "FOOT"). A second C-G at that point undoes the search entirely. @index{quitting} @keyindex{C-G} The C-G "quit" command does special things during searches; just what, depends on the status of the search. If the search has found what you specified and is waiting for input, C-G cancels the entire search. The cursor moves back to where you started the search. If C-G is typed while the search is actually searching for something or updating the display, or after search failed to find some of your input (having searched all the way to the end of the file), then only the characters which have not been found are discarded. Having discarded them, the search is now successful and waiting for more input, so a second C-G will cancel the entire search. Make sure you wait for the first C-G to ring the bell before typing the second one; if typed too soon, the second C-G may be confused with the first and effectively lost. You can also type C-R at any time to start searching backwards. If a search fails because the place you started was too late in the file, you should do this. Repeated C-R's keep looking for more occurrences backwards. A C-S starts going forwards again. C-R's can be rubbed out just like anything else. If you know that you want to search backwards, you can use C-R instead of C-S to start the search, because C-R is also a command (@fnc{reverse-search-command}) to search backward. @Index{Case Search} All sorts of searches in NMODE normally ignore the case of the text they are searching through; if you specify searching for FOO, then Foo and foo are also considered a match. |
Added psl-1983/3-1/doc/nmode/nm-searching.topic version [664556e8dc].
> > > | 1 2 3 | .silent_index {searching} idx 12-1 .silent_index {quitting} idx 12-2 .silent_index {Case} idx 12-2 |
Added psl-1983/3-1/doc/nmode/nm-selfdoc.contents version [58caee8cf9].
> | 1 | contents_entry(0 9 {Help} 9-1) |
Added psl-1983/3-1/doc/nmode/nm-selfdoc.function version [a79bd08a97].
> > | 1 2 | .silent_index {apropos-command} idx 9-1 .silent_index {help-dispatch} idx 9-1 |
Added psl-1983/3-1/doc/nmode/nm-selfdoc.ibm version [f815eca19f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-SELFDOC.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Help) Page 9-1 202/9. Help 201/NMODE has a great deal of internal documentation. There are two basic commands, the Apropos command and the Help Dispatch command. The Apropos command can be started by typing a "+" on the key pad at the far right hand side of the hp9836 keyboard or by typing M-X Apropos. The Help Dispatch command can be started by typing C-?, M-/, or M-?. The Help Dispatch command tells you what function is connected to a given key or key combination. The function names are often descriptive, so you can sometimes find out which key does what with the Help Dispatch command. To find out the function of a key or key combination, type M-?, then type the keys exactly as if you wanted NMODE to act on them. The Apropos command basically looks up command names containing a given word or phrase, or relating to a given topic. When you have started it, it will ask you for the word or phrase you are looking for in a command name (like "Move" or "Text" or "Remove", for instance). It will then temporarily cover up your text and show you a list of commands that match the phrase you typed in. At this point you can move up and down the list with the normal NMODE move commands, or you can look at the documentation for a particular command by typing V (for view). This temporarily covers up the list of commands while showing documentation for the command that you choose. Among other things this documentation tells you what key calls the command. You can get back to the list of commands by typing "Q" (for quit) or C-M-L. You can then get a more specific list of commands by typing "F" (for filter) and another phrase relevant to the command(s) you want to find. You can get back from the list of commands to your original text by typing "Q" (for quit). Here is a set of Apropos strings that covers many classes of NMODE commands, since there are strong conventions for naming the standard NMODE commands. By giving you a feel for the naming conventions, this set should also serve to aid you in developing a technique for picking Apropos strings. character, line, word, sentence, paragraph, region, page, buffer, screen, window, bounds, file, dir, beginning, end, case, mode, forward, backward, next, previous, up, down, search, kill, delete, mark, fill, indent, change. There is also a convention for how command names start for certain common kinds of operations: many commands start with one of the words "Edit", "View", "Insert", "List", or "What" "Move" "Mark". Note that the ability to apply filters allows you to search for commands which contain a set of strings, even if you don't know the order of the strings in the command name. If you find the list of commands containing or otherwise tied to "word", you can then filter the list to find the sublist that is also tied to "kill" and to "back" (in two filter operations), without knowing that the operation being searched for is kill-backward-word-command, rather than backward-kill-word-command or some other permutation. Because topics and action types and modes are also searched for, it is 201/Page 9-2 NMODE Manual (Help) possible to find broader classes of commands than would be possible from names alone. "Remove", for instance, is given as an action type for both kill commands and delete commands, so one can search for both at once by searching for "remove" and other specifying words. |
Added psl-1983/3-1/doc/nmode/nm-selfdoc.r version [6393351e11].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-SELFDOC manual @chapter[Help] @node("help") @fncindex{apropos-command} @fncindex{help-dispatch} NMODE has a great deal of internal documentation. There are two basic commands, the Apropos command and the Help Dispatch command. The Apropos command can be started by typing a "+" on the key pad at the far right hand side of the hp9836 keyboard or by typing M-X Apropos. The Help Dispatch command can be started by typing C-?, M-/, or M-?. The Help Dispatch command tells you what function is connected to a given key or key combination. The function names are often descriptive, so you can sometimes find out which key does what with the Help Dispatch command. To find out the function of a key or key combination, type M-?, then type the keys exactly as if you wanted NMODE to act on them. The Apropos command basically looks up command names containing a given word or phrase, or relating to a given topic. When you have started it, it will ask you for the word or phrase you are looking for in a command name (like "Move" or "Text" or "Remove", for instance). It will then temporarily cover up your text and show you a list of commands that match the phrase you typed in. At this point you can move up and down the list with the normal NMODE move commands, or you can look at the documentation for a particular command by typing V (for view). This temporarily covers up the list of commands while showing documentation for the command that you choose. Among other things this documentation tells you what key calls the command. You can get back to the list of commands by typing "Q" (for quit) or C-M-L. You can then get a more specific list of commands by typing "F" (for filter) and another phrase relevant to the command(s) you want to find. You can get back from the list of commands to your original text by typing "Q" (for quit). Here is a set of Apropos strings that covers many classes of NMODE commands, since there are strong conventions for naming the standard NMODE commands. By giving you a feel for the naming conventions, this set should also serve to aid you in developing a technique for picking Apropos strings. @begin[quotation] character, line, word, sentence, paragraph, region, page, buffer, screen, window, bounds, file, dir, beginning, end, case, mode, forward, backward, next, previous, up, down, search, kill, delete, mark, fill, indent, change. @end[quotation] There is also a convention for how command names start for certain common kinds of operations: many commands start with one of the words "Edit", "View", "Insert", "List", or "What" "Move" "Mark". Note that the ability to apply filters allows you to search for commands which contain a set of strings, even if you don't know the order of the strings in the command name. If you find the list of commands containing or otherwise tied to "word", you can then filter the list to find the sublist that is also tied to "kill" and to "back" (in two filter operations), without knowing that the operation being searched for is kill-backward-word-command, rather than backward-kill-word-command or some other permutation. Because topics and action types and modes are also searched for, it is possible to find broader classes of commands than would be possible from names alone. "Remove", for instance, is given as an action type for both kill commands and delete commands, so one can search for both at once by searching for "remove" and other specifying words. |
Added psl-1983/3-1/doc/nmode/nm-subsystems.contents version [8a161d4abf].
> > > > | 1 2 3 4 | contents_entry(0 7 {Moving Up And Down Levels} 7-1) contents_entry(1 7.1 {Subsystems} 7-1) contents_entry(1 7.2 {Recursive Editing Levels} 7-1) contents_entry(1 7.3 {Exiting Levels; Exiting NMODE} 7-2) |
Added psl-1983/3-1/doc/nmode/nm-subsystems.function version [2f2c4d822f].
> > | 1 2 | .silent_index {exit-nmode} idx 7-2 .silent_index {nmode-exit-to-superior} idx 7-2 |
Added psl-1983/3-1/doc/nmode/nm-subsystems.ibm version [ac2cd63392].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-SUBSYSTEMS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Moving Up And Down Levels) Page 7-1 202/7. Moving Up And Down Levels 201/Subsystems and recursive editing levels are two states in which you are temporarily doing something other than editing the visited file as usual. For example, you might be editing the arguments prompted for by a M-X command, or using a browser. 202/7.1 Subsystems 201/A 202/subsystem 201/is an NMODE function which is an interactive program in its own right: it reads commands in a language of its own, and displays the results. You enter a subsystem by typing an NMODE command which invokes it. Once entered, the subsystem usually runs until a specific command to exit the subsystem is typed. An example of an NMODE subsystem is the buffer-browser, invoked by typing C-X C-B. The commands understood by a subsystem are usually not like NMODE commands, because their purpose is something other than editing text. In the buffer-browser, for instance, the commands are tailored to moving up and down a list of the existing buffers, reordering this list in various ways, and to deleting buffers. In NMODE, most commands are Control or Meta characters because printing characters insert themselves. In most subsystems, there is no insertion of text, so non-Control non-Meta characters can be the commands. While you are inside a subsystem, the mode line identifies the subsystem by identifying the mode of the current buffer. The special properties of the subsystem are due to the kinds of commands that are available in this mode, and to the keys that the mode associates with them. Because each buffer has its own associated mode at any given time, if a user moves out of the buffer associated with the subsystem into an ordinary text buffer, he/she will have left the subsystem, even though he/she will not have used the normal command for doing so. Because each subsystem implements its own commands, we cannot guarantee anything about them. However, there are conventions for what certain commands ought to do: Space Moves downwards, like C-N in NMODE. Q Exits normally. Help or ? Prints documentation on the subsystem's commands. Not all of these necessarily exist in every subsystem, however. 202/7.2 Recursive Editing Levels 201/A 202/recursive editing level 201/is a state in which part of the execution of one command involves doing some editing. You may be editing the file you are working on, or you may be editing completely something totally different from what you were working on at top level. Currently, the completion of extended commands, the preparation of prompted input strings, and the examination of buffers in the kill-some-buffers-command function all involve 201/Page 7-2 NMODE Manual (Recursive Editing Levels) recursive editing levels within which the full power of NMODE is available. 202/7.3 Exiting Levels; Exiting NMODE 201/L] On the hp9836, <STOP> will exit from NMODE to the hp9836 workstation top level command interpreter. C-X C-Z will exit from NMODE into the PSL interpreter, as will C-] L (Lisp-L) in Lisp mode. |
Added psl-1983/3-1/doc/nmode/nm-subsystems.r version [4c209d5419].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-SUBSYSTEMS manual @Chapter[Moving Up And Down Levels] Subsystems and recursive editing levels are two states in which you are temporarily doing something other than editing the visited file as usual. For example, you might be editing the arguments prompted for by a M-X command, or using a browser. @Section[Subsystems] @node("subsystems") A @dfn[subsystem] is an NMODE function which is an interactive program in its own right: it reads commands in a language of its own, and displays the results. You enter a subsystem by typing an NMODE command which invokes it. Once entered, the subsystem usually runs until a specific command to exit the subsystem is typed. An example of an NMODE subsystem is the buffer-browser, invoked by typing C-X C-B. The commands understood by a subsystem are usually not like NMODE commands, because their purpose is something other than editing text. In the buffer-browser, for instance, the commands are tailored to moving up and down a list of the existing buffers, reordering this list in various ways, and to deleting buffers. In NMODE, most commands are Control or Meta characters because printing characters insert themselves. In most subsystems, there is no insertion of text, so non-Control non-Meta characters can be the commands. While you are inside a subsystem, the mode line identifies the subsystem by identifying the mode of the current buffer. The special properties of the subsystem are due to the kinds of commands that are available in this mode, and to the keys that the mode associates with them. Because each buffer has its own associated mode at any given time, if a user moves out of the buffer associated with the subsystem into an ordinary text buffer, he/she will have left the subsystem, even though he/she will not have used the normal command for doing so. Because each subsystem implements its own commands, we cannot guarantee anything about them. However, there are conventions for what certain commands ought to do: @DoubleWideCommands{ Space Moves downwards, like C-N in NMODE. Q Exits normally. Help or ? Prints documentation on the subsystem's commands. } Not all of these necessarily exist in every subsystem, however. @Section[Recursive Editing Levels] @node("recursive") @Index{Recursive Editing Level} @Index{Mode Line} A @dfn[recursive editing level] is a state in which part of the execution of one command involves doing some editing. You may be editing the file you are working on, or you may be editing completely something totally different from what you were working on at top level. Currently, the completion of extended commands, the preparation of prompted input strings, and the examination of buffers in the kill-some-buffers-command function all involve recursive editing levels within which the full power of NMODE is available. @Section[Exiting Levels; Exiting NMODE] @index[stop] @index[C-X C-Z] @index[C-] L] @fncindex{exit-nmode} @fncindex{nmode-exit-to-superior} @index{exiting} On the hp9836, <STOP> will exit from NMODE to the hp9836 workstation top level command interpreter. C-X C-Z will exit from NMODE into the PSL interpreter, as will C-] L (Lisp-L) in Lisp mode. |
Added psl-1983/3-1/doc/nmode/nm-subsystems.topic version [9048589c0c].
> > > > > > | 1 2 3 4 5 6 | .silent_index {Recursive} idx 7-1 .silent_index {Mode} idx 7-1 .silent_index {stop} idx 7-2 .silent_index {C-X} idx 7-2 .silent_index {C-} idx 7-2 .silent_index {exiting} idx 7-2 |
Added psl-1983/3-1/doc/nmode/nm-text.contents version [15fe236894].
> > > > > > > > | 1 2 3 4 5 6 7 8 | contents_entry(0 13 {Commands for English Text} 13-1) contents_entry(1 13.1 {Word Commands} 13-1) contents_entry(1 13.2 {Sentence and Paragraph Commands} 13-2) contents_entry(2 13.2.1 {Sentences} 13-2) contents_entry(2 13.2.2 {Paragraphs} 13-3) contents_entry(1 13.3 {Indentation Commands for Text} 13-3) contents_entry(1 13.4 {Text Filling} 13-4) contents_entry(1 13.5 {Case Conversion Commands} 13-5) |
Added psl-1983/3-1/doc/nmode/nm-text.function version [5b843f6f40].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {tab-to-tab-stop-command} idx 13-1 .silent_index {text-mode-command} idx 13-1 .silent_index {move-forward-word-command} idx 13-1 .silent_index {move-backward-word-command} idx 13-1 .silent_index {kill-forward-word-command} idx 13-1 .silent_index {kill-backward-word-command} idx 13-1 .silent_index {transpose-words} idx 13-1 .silent_index {mark-word-command} idx 13-2 .silent_index {backward-sentence-command} idx 13-2 .silent_index {forward-sentence-command} idx 13-2 .silent_index {kill-sentence-command} idx 13-2 .silent_index {backward-kill-sentence-command} idx 13-2 .silent_index {backward-paragraph-command} idx 13-3 .silent_index {forward-paragraph-command} idx 13-3 .silent_index {mark-paragraph-command} idx 13-3 .silent_index {tab-to-tab-stop-command} idx 13-3 .silent_index {indent-region-command} idx 13-3 .silent_index {delete-horizontal-space-command} idx 13-3 .silent_index {delete-indentation-command} idx 13-3 .silent_index {back-to-indentation-command} idx 13-4 .silent_index {auto-fill-mode-command} idx 13-4 .silent_index {fill-region-command} idx 13-4 .silent_index {fill-paragraph-command} idx 13-4 .silent_index {center-line-command} idx 13-5 .silent_index {set-fill-column-command} idx 13-5 .silent_index {set-fill-prefix-command} idx 13-5 .silent_index {what-cursor-position-command} idx 13-5 .silent_index {lowercase-word-command} idx 13-5 .silent_index {uppercase-word-command} idx 13-5 .silent_index {uppercase-initial-command} idx 13-5 .silent_index {lowercase-region-command} idx 13-6 .silent_index {uppercase-region-command} idx 13-6 |
Added psl-1983/3-1/doc/nmode/nm-text.ibm version [5814241543].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-TEXT.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Commands for English Text) Page 13-1 202/13. Commands for English Text 201/NMODE enables you to manipulate words, sentences, or paragraphs of text. In addition, there are commands to fill text, and convert case. Editing files of text in a human language ought to be done using Text mode. Invoke M-X Text Mode to enter Text mode. See Section 20.1 [Major Modes], page 1. M-X Text Mode (203/text-mode-command201/) causes Tab to run the function 203/tab-to-tab-stop-command201/. Automatic display of parenthesis matching is turned off, which is what most people want. 202/13.1 Word Commands 201/NMODE has commands for moving over or operating on words. By convention, they are all Meta- characters. M-F Move Forward over a word. M-B Move Backward over a word. M-D Kill up to the end of a word. M-Backspace Kill back to the beginning of a word. M-@ Mark the end of the next word. M-T Transpose two words; drag a word forward or backward across other words. Notice how these commands form a group that parallels the character based commands C-F, C-B, C-D, C-T and Backspace. M-@ is related to C-@. The commands Meta-F (203/move-forward-word-command201/) and Meta-B (203/move-backward-word-command201/) move forward and backward over words. They are thus analogous to Control-F and Control-B, which move over single characters. Like their Control- equivalents, Meta-F and Meta-B move several words if given an argument. Meta-F with a negative argument moves backward like Meta-B, and Meta-B with a negative argument moves forward. Forward motion stops right after the last letter of the word, while backward motion stops right before the first letter. It is easy to kill a word at a time. Meta-D (203/kill-forward-word-command201/) kills the word after point. To be precise, it kills everything from point to the place Meta-F would move to. Thus, if point is in the middle of a word, only the part after point is killed. If some punctuation occurs between point and the end of the next word it will be killed. If you wish to kill only the next word but not the punctuation, simply do Meta-F to get the end, and kill the word backwards with Meta-Backspace. Meta-D takes arguments just like Meta-F. Meta-Backspace (203/kill-backward-word-command201/) kills the word before point. It kills everything from point back to where Meta-B would move to. If point is after the space in "FOO, BAR", then "FOO, " is killed. If you wish to kill just "FOO", then do a Meta-B and a Meta-D instead of a Meta-Backspace. Meta-T (203/transpose-words201/) moves the cursor forward over a word, dragging the word preceding or containing the cursor forward as well. A numeric argument serves as a repeat count. Meta-T with a negative argument undoes the effect of Meta-T with a positive argument; it drags the word behind the 201/Page 13-2 NMODE Manual (Word Commands) cursor backward over a word. An argument of zero, instead of doing nothing, transposes the word at point (surrounding or adjacent to it) with the word at mark. In any case, the delimiter characters between the words do not move. For example, "FOO, BAR" transposes into "BAR, FOO" rather than "BAR FOO,". To operate on the next n words with an operation which applies between point and mark, you can either set the mark at point and then move over the words, or you can use the command Meta-@ (203/mark-word-command201/) which does not move point, but sets the mark where Meta-F would move to. It can be given arguments just like Meta-F. 202/13.2 Sentence and Paragraph Commands 201/The NMODE commands for manipulating sentences and paragraphs are mostly Meta- commands, so as to resemble the word-handling commands. M-A Move back to the beginning of the sentence. M-E Move forward to the end of the sentence. M-K Kill forward to the end of the sentence. M-[ Move back to previous paragraph beginning. M-] Move forward to next paragraph end. M-H Put point and mark around this paragraph (around the following one, if between paragraphs). C-X Rubout Kill back to the beginning of the sentence. 202/13.2.1 Sentences 201/The commands Meta-A and Meta-E (203/backward-sentence-command 201/and 203/forward-sentence-command201/) move to the beginning and end of the current sentence, respectively. They were chosen to resemble Control-A and Control-E, which move to the beginning and end of a line. Unlike them, Meta-A and Meta-E if repeated or given numeric arguments move over successive sentences. NMODE considers a sentence to end wherever there is a ".", "?" or "!" followed by the end of a line or two spaces, with any number of ")"'s, "]"'s, "'"'s, or '"' 's allowed in between. Neither M-A nor M-E moves past the line separator or spaces which delimit the sentence. Just as C-A and C-E have a kill command, C-K, to go with them, so M-A and M-E have a corresponding kill command M-K (203/kill-sentence-command201/) which kills from point to the end of the sentence. With minus one as an argument it kills back to the beginning of the sentence. Larger arguments serve as a repeat count. There is a special command, C-X Rubout (203/backward-kill-sentence-command201/) for killing back to the beginning of a sentence, because this is useful when you change your mind in the middle of composing text. It also accepts arguments, acting as C-U (minus argument given) M-K would. 201/NMODE Manual (Paragraphs) Page 13-3 202/13.2.2 Paragraphs 201/Meta-[ (203/backward-paragraph-command201/) moves to the beginning of the current or previous paragraph, while Meta-] (203/forward-paragraph-command201/) moves to the end of the current or next paragraph. Blank lines and text justifier command lines (text mode only for these!) separate paragraphs and are not part of any paragraph. Also, an indented line starts a new paragraph. (text mode only!) A text justifier command line is part of no paragraph in text mode. A text justifier command line is any line that begins with a period. In major modes for programs (as opposed to Text mode), paragraphs are determined only by blank lines. This makes the paragraph commands continue to be useful even though there are no paragraphs per se. When there is a fill prefix, then paragraphs are delimited by all lines which don't start with the fill prefix. See Section 13.4 [Filling], page 4. When you wish to operate on a paragraph, you can use the command Meta-H (203/mark-paragraph-command201/) to set the region around it. This command puts point at the beginning and mark at the end of the paragraph point was in. Before setting the new mark at the end, a mark is set at the old location of point; this allows you to undo a mistaken Meta-H with two C-U C-@'s. If point is between paragraphs (in a run of blank lines, or at a boundary), the paragraph following point is surrounded by point and mark. Thus, for example, Meta-H C-W kills the paragraph around or after point. 202/13.3 Indentation Commands for Text 201/Tab Indents "appropriately" in a mode-dependent fashion. M-Tab Inserts a tab character. Linefeed Is the same as Return followed by Tab. M-^ Undoes a Linefeed. Merges two lines. M-M Moves to the line's first nonblank character. M-I Indent to tab stop. In Text mode, Tab does this also. C-M-\ Indent several lines to same column. The way to request indentation is with the Tab command. Its precise effect depends on the major mode. In Text mode, it runs 203/tab-to-tab-stop-command201/, which inserts a Tab character. If you are not in Text mode, this function can be found on M-I anyway. You can also do this with M-Tab or C-Q Tab. One also indent a group of lines to a known column by using C-M-\ (203/indent-region-command201/). This must be given a command argument. It will then indent all the lines in the current region to the argument-the column. For English text, usually only the first line of a paragraph should be indented. So, in Text mode, new lines created by Auto Fill mode are not indented. But sometimes you want to have an indented paragraph. This can be done by setting fill prefix to the desired indentation. To undo a line-break, whether done manually or by Auto Fill, use Meta-^ 201/Page 13-4 NMODE Manual (Indentation Commands for Text) (203/delete-indentation-command201/) to delete the indentation at the front of the current line, and the line boundary as well. They are replaced by a single space, or by no space if before a ")" or after a "(", or at the beginning of a line. To delete just the indentation of a line, go to the beginning of the line and use Meta-\ (203/delete-horizontal-space-command201/), which deletes all spaces and tabs around the cursor. To insert an indented line before the current line, do C-A, C-O, and then Tab. To make an indented line after the current line, use C-E Linefeed. To move over the indentation on a line, do Meta-M or C-M-M (203/back-to-indentation-command201/). These commands, given anywhere on a line, position the cursor at the first nonblank character on the line. 202/13.4 Text Filling 201/Space in Auto Fill mode, breaks lines when appropriate. M-Q Fill paragraph. M-G Fill region (G is for Grind, by analogy with Lisp). M-S Center a line. C-X = Show current cursor position. Auto Fill mode lets you type in text that is 202/filled 201/(broken up into lines that fit in a specified width) as you go. If you alter existing text and thus cause it to cease to be properly filled, NMODE can fill it again if you ask. Entering Auto Fill mode is done with M-X Auto Fill (203/auto-fill-mode-command201/). From then on, lines are broken automatically at spaces when they get longer than the desired width. To leave Auto Fill mode, execute M-X Auto Fill again. When Auto Fill mode is in effect, the word "Fill" appears in the mode line. When you finish a paragraph, you can type Space with an argument of zero. This doesn't insert any spaces, but it does move the last word of the paragraph to a new line if it doesn't fit in the old line. Return also moves the last word, but it may create another blank line. If you edit the middle of a paragraph, it may no longer be correctly filled. To refill a paragraph, use the command Meta-Q (203/fill-paragraph-command201/). It causes the paragraph that point is inside, or the one after point if point is between paragraphs, to be refilled. All the line-breaks are removed, and then new ones are inserted where necessary. If you are not happy with Meta-Q's idea of where paragraphs start and end (the same as Meta-H's. See Section 13.2 [Paragraphs], page 2.), you can use Meta-G (203/fill-region-command201/) which refills everything between point and mark. Sometimes, it is ok to fill a region of several paragraphs at once. Meta-G recognizes a blank line or (in text mode) an indented line as starting a paragraph and does not fill it in with the preceding line. The purpose of M-G is to allow you to override NMODE's usual criteria for paragraph boundaries. Giving an argument to M-G or M-Q causes the text to be 202/justified 201/as well as 201/NMODE Manual (Text Filling) Page 13-5 filled. This means that extra spaces are inserted between the words so as to make the right margin come out exactly even. I do not recommend doing this. If someone else has uglified some text by justifying it, you can unjustify it (remove the spaces) with M-G or M-Q without an argument. The command Meta-S (203/center-line-command201/) centers a line within the current line width. With an argument, it centers several lines individually and moves past them. With a negative argument it centers lines above the current one. The maximum line width for filling is in the variable Fill-Column. Both M-Q and Auto Fill make sure that no line exceeds this width. The easiest way to set the variable is to use the command C-X F (203/set-fill-column-command201/), which places the margin at the column point is on, or at the column specified by a numeric argument. The fill column is initially column 70. To fill a paragraph in which each line starts with a special marker (which might be a few spaces, giving an indented paragraph), use the 202/fill prefix 201/feature. Move point to a spot right after the special marker and give the command C-X Period (203/set-fill-prefix-command201/). Then, filling the paragraph will remove the marker from each line beforehand, perform the filling, and put the marker back in on each line afterward. Auto Fill when there is a fill prefix inserts the fill prefix at the front of each new line. Also, any line which does not start with the fill prefix is considered to delimit a paragraph. To turn off the fill prefix, do C-X Period with point at the front of a line. The fill prefix is kept in the variable Fill-Prefix. The command C-X = (203/what-cursor-position-command201/) can be used to find out the column that the cursor is in, and other miscellaneous information about point which is quick to compute. It prints a line in the echo area that looks like this: X=2 Y=19 CH=10 line=428 (74 percent of 574 lines) In this line, the X value is the column the cursor is in (zero at the left), the Y value is the screen line that the cursor is in (zero at the top), the CH value is the ascii value of the character after point and the other values show how large the buffer is and where the current line is in it. 202/13.5 Case Conversion Commands 201/NMODE has commands for converting either a single word or any arbitrary range of text to upper case or to lower case. M-L Convert following word to lower case. M-U Convert following word to upper case. M-C Capitalize the following word. C-X C-L Convert region to lower case. C-X C-U Convert region to upper case. The word conversion commands are the most useful. Meta-L (203/lowercase-word-command201/) converts the word after point to lower case, moving past it. Thus, successive Meta-L's convert successive words. 201/Page 13-6 NMODE Manual (Case Conversion Commands) Meta-U (203/uppercase-word-command201/) converts to all capitals instead, while Meta-C (203/uppercase-initial-command201/) puts the first letter of the word into upper case and the rest into lower case. All these commands convert several words at once if given an argument. They are especially convenient for converting a large amount of text from all upper case to mixed case, because you can move through the text using M-L, M-U or M-C on each word as appropriate. When given a negative argument, the word case conversion commands apply to the appropriate number of words before point, but do not move point. This is convenient when you have just typed a word in the wrong case. You can give the case conversion command and continue typing. If a word case conversion command is given in the middle of a word, it applies only to the part of the word which follows the cursor, treating it as a whole word. The other case conversion commands are C-X C-U (203/uppercase-region-command201/) and C-X C-L (203/lowercase-region-command201/), which convert everything between point and mark to the specified case. Point and mark do not move. |
Added psl-1983/3-1/doc/nmode/nm-text.key version [59c600040b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Tab} idx 13-1 .silent_index {M-F} idx 13-1 .silent_index {M-B} idx 13-1 .silent_index {M-Backspace} idx 13-1 .silent_index {M-D} idx 13-1 .silent_index {M-T} idx 13-1 .silent_index {M-@} idx 13-2 .silent_index {M-A} idx 13-2 .silent_index {M-E} idx 13-2 .silent_index {C-A} idx 13-2 .silent_index {C-E} idx 13-2 .silent_index {C-K} idx 13-2 .silent_index {M-K} idx 13-2 .silent_index {C-X} idx 13-2 .silent_index {M-[} idx 13-3 .silent_index {M-]} idx 13-3 .silent_index {C-W} idx 13-3 .silent_index {C-U} idx 13-3 .silent_index {M-H} idx 13-3 .silent_index {Tab} idx 13-3 .silent_index {M-Tab} idx 13-3 .silent_index {C-Q} idx 13-3 .silent_index {C-M-\} idx 13-3 .silent_index {M-\} idx 13-3 .silent_index {M-^} idx 13-3 .silent_index {M-M} idx 13-4 .silent_index {C-M-M} idx 13-4 .silent_index {Space} idx 13-4 .silent_index {M-Q} idx 13-4 .silent_index {M-G} idx 13-4 .silent_index {M-H} idx 13-4 .silent_index {M-S} idx 13-5 .silent_index {C-X} idx 13-5 .silent_index {C-X} idx 13-5 .silent_index {C-X} idx 13-5 .silent_index {M-L} idx 13-5 .silent_index {M-U} idx 13-5 .silent_index {M-C} idx 13-5 .silent_index {C-X} idx 13-6 .silent_index {C-X} idx 13-6 |
Added psl-1983/3-1/doc/nmode/nm-text.r version [44b7e40560].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-TEXT manual @Chapter[Commands for English Text] @node("text") @manual{NMODE enables you to manipulate words, sentences, or paragraphs of text. In addition, there are commands to fill text, and convert case. } @fncindex{tab-to-tab-stop-command} @index{Text mode} @keyindex{Tab} @fncindex{text-mode-command} @index{parentheses} Editing files of text in a human language ought to be done using Text mode. Invoke M-X Text Mode to enter Text mode. @Note("MajorModes" "Major Modes"). M-X Text Mode (@fnc{text-mode-command}) causes Tab to run the function @fnc{tab-to-tab-stop-command}. Automatic display of parenthesis matching is turned off, which is what most people want. @Section[Word Commands] @node("words") @index{words} @index{Meta} NMODE has commands for moving over or operating on words. By convention, they are all Meta- characters. @WideCommands[ M-F Move Forward over a word. M-B Move Backward over a word. M-D Kill up to the end of a word. M-Backspace Kill back to the beginning of a word. M-@ Mark the end of the next word. M-T Transpose two words; drag a word forward or backward across other words. ] Notice how these commands form a group that parallels the character based commands C-F, C-B, C-D, C-T and Backspace. M-@ is related to C-@. @index{motion} @keyindex{M-F} @keyindex{M-B} @fncindex{move-forward-word-command} @fncindex{move-backward-word-command} The commands Meta-F (@fnc{move-forward-word-command}) and Meta-B (@fnc{move-backward-word-command}) move forward and backward over words. They are thus analogous to Control-F and Control-B, which move over single characters. Like their Control- equivalents, Meta-F and Meta-B move several words if given an argument. Meta-F with a negative argument moves backward like Meta-B, and Meta-B with a negative argument moves forward. Forward motion stops right after the last letter of the word, while backward motion stops right before the first letter. @index{killing} @keyindex{M-Backspace} @keyindex{M-D} @fncindex{kill-forward-word-command} @fncindex{kill-backward-word-command} It is easy to kill a word at a time. Meta-D (@fnc{kill-forward-word-command}) kills the word after point. To be precise, it kills everything from point to the place Meta-F would move to. Thus, if point is in the middle of a word, only the part after point is killed. If some punctuation occurs between point and the end of the next word it will be killed. If you wish to kill only the next word but not the punctuation, simply do Meta-F to get the end, and kill the word backwards with Meta-Backspace. Meta-D takes arguments just like Meta-F. Meta-Backspace (@fnc{kill-backward-word-command}) kills the word before point. It kills everything from point back to where Meta-B would move to. If point is after the space in @w["FOO, BAR"], then @w["FOO, "] is killed. If you wish to kill just "FOO", then do a Meta-B and a Meta-D instead of a Meta-Backspace. @index{transposition} @index{numeric arguments} @keyindex{M-T} @fncindex{transpose-words} Meta-T (@fnc{transpose-words}) moves the cursor forward over a word, dragging the word preceding or containing the cursor forward as well. A numeric argument serves as a repeat count. Meta-T with a negative argument undoes the effect of Meta-T with a positive argument; it drags the word behind the cursor backward over a word. An argument of zero, instead of doing nothing, transposes the word at point (surrounding or adjacent to it) with the word at mark. In any case, the delimiter characters between the words do not move. For example, @w["FOO, BAR"] transposes into @w["BAR, FOO"] rather than @w["BAR FOO,"]. @index{mark} @keyindex{M-@} @fncindex{mark-word-command} To operate on the next n words with an operation which applies between point and mark, you can either set the mark at point and then move over the words, or you can use the command Meta-@ (@fnc{mark-word-command}) which does not move point, but sets the mark where Meta-F would move to. It can be given arguments just like Meta-F. @Section[Sentence and Paragraph Commands] @node("sentences") @index{sentences} @index{paragraphs} The NMODE commands for manipulating sentences and paragraphs are mostly Meta- commands, so as to resemble the word-handling commands. @Commands{ M-A Move back to the beginning of the sentence. M-E Move forward to the end of the sentence. M-K Kill forward to the end of the sentence. M-[ Move back to previous paragraph beginning. M-] Move forward to next paragraph end. M-H Put point and mark around this paragraph (around the following one, if between paragraphs). C-X Rubout Kill back to the beginning of the sentence. } @SubSection[Sentences] @index{motion} @keyindex{M-A} @keyindex{M-E} @fncindex{backward-sentence-command} @fncindex{forward-sentence-command} The commands Meta-A and Meta-E (@fnc{backward-sentence-command} and @fnc{forward-sentence-command}) move to the beginning and end of the current sentence, respectively. They were chosen to resemble Control-A and Control-E, which move to the beginning and end of a line. Unlike them, Meta-A and Meta-E if repeated or given numeric arguments move over successive sentences. NMODE considers a sentence to end wherever there is a ".", "?" or "!" followed by the end of a line or two spaces, with any number of ")"'s, "]"'s, "'"'s, or '"' 's allowed in between. Neither M-A nor M-E moves past the line separator or spaces which delimit the sentence. @keyindex{C-A} @keyindex{C-E} @keyindex{C-K} @index{killing} @keyindex{M-K} @keyindex{C-X Rubout} @fncindex{kill-sentence-command} @fncindex{backward-kill-sentence-command} Just as C-A and C-E have a kill command, C-K, to go with them, so M-A and M-E have a corresponding kill command M-K (@fnc{kill-sentence-command}) which kills from point to the end of the sentence. With minus one as an argument it kills back to the beginning of the sentence. Larger arguments serve as a repeat count. There is a special command, C-X Rubout (@fnc{backward-kill-sentence-command}) for killing back to the beginning of a sentence, because this is useful when you change your mind in the middle of composing text. It also accepts arguments, acting as C-U (minus argument given) M-K would. @SubSection[Paragraphs] @keyindex{M-[} @keyindex{M-]} @fncindex{backward-paragraph-command} @fncindex{forward-paragraph-command} Meta-[ (@fnc{backward-paragraph-command}) moves to the beginning of the current or previous paragraph, while Meta-] (@fnc{forward-paragraph-command}) moves to the end of the current or next paragraph. Blank lines and text justifier command lines (text mode only for these!) separate paragraphs and are not part of any paragraph. Also, an indented line starts a new paragraph. (text mode only!) @index{Paragraph Delimiter} A text justifier command line is part of no paragraph in text mode. A text justifier command line is any line that begins with a period. @index{blank lines} In major modes for programs (as opposed to Text mode), paragraphs are determined only by blank lines. This makes the paragraph commands continue to be useful even though there are no paragraphs per se. @index{fill-prefix} When there is a fill prefix, then paragraphs are delimited by all lines which don't start with the fill prefix. @Note("Filling"). @index{Region} @index{mark} @keyindex{C-W} @keyindex{C-U C-@} @keyindex{M-H} @fncindex{mark-paragraph-command} When you wish to operate on a paragraph, you can use the command Meta-H (@fnc{mark-paragraph-command}) to set the region around it. This command puts point at the beginning and mark at the end of the paragraph point was in. Before setting the new mark at the end, a mark is set at the old location of point; this allows you to undo a mistaken Meta-H with two C-U C-@'s. If point is between paragraphs (in a run of blank lines, or at a boundary), the paragraph following point is surrounded by point and mark. Thus, for example, Meta-H C-W kills the paragraph around or after point. @Section[Indentation Commands for Text] @node("textindent") @index{indentation} @index{formatting} @WideCommands[ Tab Indents "appropriately" in a mode-dependent fashion. M-Tab Inserts a tab character. Linefeed Is the same as @Return3{} followed by Tab. M-^ Undoes a Linefeed. Merges two lines. M-M Moves to the line's first nonblank character. M-I Indent to tab stop. In Text mode, Tab does this also. C-M-\ Indent several lines to same column. C-X Tab Shift block of lines rigidly right or left. ] @keyindex{Tab} @index{Linefeed} @fncindex{tab-to-tab-stop-command} @keyindex{M-Tab} @keyindex{C-Q} The way to request indentation is with the Tab command. Its precise effect depends on the major mode. In Text mode, it runs @fnc{tab-to-tab-stop-command}, which inserts a Tab character. If you are not in Text mode, this function can be found on M-I anyway. You can also do this with M-Tab or C-Q Tab. @keyindex{C-M-\} @fncindex{indent-region-command} One also indent a group of lines to a known column by using C-M-\ (@fnc{indent-region-command}). This must be given a command argument. It will then indent all the lines in the current region to the argument-the column. @index{Auto Fill Mode} For English text, usually only the first line of a paragraph should be indented. So, in Text mode, new lines created by Auto Fill mode are not indented. But sometimes you want to have an indented paragraph. This can be done by setting fill prefix to the desired indentation. @keyindex{M-\} @keyindex{M-^} @fncindex{delete-horizontal-space-command} @fncindex{delete-indentation-command} To undo a line-break, whether done manually or by Auto Fill, use Meta-^ (@fnc{delete-indentation-command}) to delete the indentation at the front of the current line, and the line boundary as well. They are replaced by a single space, or by no space if before a ")" or after a "(", or at the beginning of a line. To delete just the indentation of a line, go to the beginning of the line and use Meta-\ (@fnc{delete-horizontal-space-command}), which deletes all spaces and tabs around the cursor. To insert an indented line before the current line, do C-A, C-O, and then Tab. To make an indented line after the current line, use C-E Linefeed. @keyindex{M-M} @keyindex{C-M-M} @fncindex{back-to-indentation-command} To move over the indentation on a line, do Meta-M or C-M-M (@fnc{back-to-indentation-command}). These commands, given anywhere on a line, position the cursor at the first nonblank character on the line. @index{numeric arguments} @index{C-M-\} @index{C-X Tab} @fncindex{indent region} @fncindex{indent rigidly} There are also commands for changing the indentation of several lines at once. Control-Meta-\ (@fnc{indent region}) gives each line which begins in the region the "usual" indentation by invoking Tab at the beginning of the line. A numeric argument specifies the indentation, and each line is shifted left or right so that it has exactly that much. C-X Tab (@fnc{indent rigidly}) moves all of the lines in the region right by its argument (left, for negative arguments). The whole group of lines move rigidly sideways, which is how the command gets its name. @Index{Tabify} @Index{Untabify} To convert all tabs in a file to spaces, you can use M-X Untabify. M-X Tabify performs the opposite transformation, replacing spaces with tabs whenever possible, but only if there are at least three of them so as not to obscure ends of sentences. A numeric argument to Tabify or Untabify specifies the interval between tab stops to use for computing how to change the file. By default, they use the same interval being used for display. The visual appearance of the text should never be changed by Tabify or Untabify without a numeric argument. @Section[Text Filling] @node("filling") @index{filling} @Commands[ Space in Auto Fill mode, breaks lines when appropriate. M-Q Fill paragraph. M-G Fill region (G is for Grind, by analogy with Lisp). M-S Center a line. C-X = Show current cursor position. ] @index{Auto Fill Mode} @keyindex{Space} Auto Fill mode lets you type in text that is @dfn[filled] (broken up into lines that fit in a specified width) as you go. If you alter existing text and thus cause it to cease to be properly filled, NMODE can fill it again if you ask. @fncindex{auto-fill-mode-command} Entering Auto Fill mode is done with M-X Auto Fill (@fnc{auto-fill-mode-command}). From then on, lines are broken automatically at spaces when they get longer than the desired width. To leave Auto Fill mode, execute M-X Auto Fill again. When Auto Fill mode is in effect, the word "Fill" appears in the mode line. @index{numeric arguments} When you finish a paragraph, you can type Space with an argument of zero. This doesn't insert any spaces, but it does move the last word of the paragraph to a new line if it doesn't fit in the old line. @Return3{} also moves the last word, but it may create another blank line. @keyindex{M-Q} @index{paragraphs} @keyindex{M-G} @fncindex{fill-region-command} @fncindex{fill-paragraph-command} If you edit the middle of a paragraph, it may no longer be correctly filled. To refill a paragraph, use the command Meta-Q (@fnc{fill-paragraph-command}). It causes the paragraph that point is inside, or the one after point if point is between paragraphs, to be refilled. All the line-breaks are removed, and then new ones are inserted where necessary. @keyindex{M-H} If you are not happy with Meta-Q's idea of where paragraphs start and end (the same as Meta-H's. @note("Sentences" "Paragraphs").), you can use Meta-G (@fnc{fill-region-command}) which refills everything between point and mark. Sometimes, it is ok to fill a region of several paragraphs at once. Meta-G recognizes a blank line or (in text mode) an indented line as starting a paragraph and does not fill it in with the preceding line. The purpose of M-G is to allow you to override NMODE's usual criteria for paragraph boundaries. @index{justification} Giving an argument to M-G or M-Q causes the text to be @dfn[justified] as well as filled. This means that extra spaces are inserted between the words so as to make the right margin come out exactly even. I do not recommend doing this. If someone else has uglified some text by justifying it, you can unjustify it (remove the spaces) with M-G or M-Q without an argument. @keyindex{M-S} @index{centering} @fncindex{center-line-command} The command Meta-S (@fnc{center-line-command}) centers a line within the current line width. With an argument, it centers several lines individually and moves past them. With a negative argument it centers lines above the current one. @index{Fill Column} @keyindex{C-X F} @fncindex{set-fill-column-command} The maximum line width for filling is in the variable Fill-Column. Both M-Q and Auto Fill make sure that no line exceeds this width. The easiest way to set the variable is to use the command C-X F (@fnc{set-fill-column-command}), which places the margin at the column point is on, or at the column specified by a numeric argument. The fill column is initially column 70. @index{Fill Prefix} @keyindex{C-X .} @fncindex{set-fill-prefix-command} To fill a paragraph in which each line starts with a special marker (which might be a few spaces, giving an indented paragraph), use the @dfn[fill prefix] feature. Move point to a spot right after the special marker and give the command @w[C-X Period] (@fnc{set-fill-prefix-command}). Then, filling the paragraph will remove the marker from each line beforehand, perform the filling, and put the marker back in on each line afterward. Auto Fill when there is a fill prefix inserts the fill prefix at the front of each new line. Also, any line which does not start with the fill prefix is considered to delimit a paragraph. To turn off the fill prefix, do C-X Period with point at the front of a line. The fill prefix is kept in the variable Fill-Prefix. @keyindex{C-X =} @index{echo area} @fncindex{what-cursor-position-command} The command @w[C-X =] (@fnc{what-cursor-position-command}) can be used to find out the column that the cursor is in, and other miscellaneous information about point which is quick to compute. It prints a line in the echo area that looks like this: @example[ X=2 Y=19 CH=10 line=428 (74 percent of 574 lines) ] In this line, the X value is the column the cursor is in (zero at the left), the Y value is the screen line that the cursor is in (zero at the top), the CH value is the ascii value of the character after point and the other values show how large the buffer is and where the current line is in it. @Section[Case Conversion Commands] @node("case") @index{case conversion} NMODE has commands for converting either a single word or any arbitrary range of text to upper case or to lower case. @WideCommands[ M-L Convert following word to lower case. M-U Convert following word to upper case. M-C Capitalize the following word. C-X C-L Convert region to lower case. C-X C-U Convert region to upper case. ] @keyindex{M-L} @keyindex{M-U} @keyindex{M-C} @index{words} @fncindex{lowercase-word-command} @fncindex{uppercase-word-command} @fncindex{uppercase-initial-command} The word conversion commands are the most useful. Meta-L (@fnc{lowercase-word-command}) converts the word after point to lower case, moving past it. Thus, successive Meta-L's convert successive words. Meta-U (@fnc{uppercase-word-command}) converts to all capitals instead, while Meta-C (@fnc{uppercase-initial-command}) puts the first letter of the word into upper case and the rest into lower case. All these commands convert several words at once if given an argument. They are especially convenient for converting a large amount of text from all upper case to mixed case, because you can move through the text using M-L, M-U or M-C on each word as appropriate. @index{numeric arguments} When given a negative argument, the word case conversion commands apply to the appropriate number of words before point, but do not move point. This is convenient when you have just typed a word in the wrong case. You can give the case conversion command and continue typing. If a word case conversion command is given in the middle of a word, it applies only to the part of the word which follows the cursor, treating it as a whole word. @keyindex{C-X C-L} @keyindex{C-X C-U} @index{Region} @fncindex{lowercase-region-command} @fncindex{uppercase-region-command} The other case conversion commands are C-X C-U (@fnc{uppercase-region-command}) and C-X C-L (@fnc{lowercase-region-command}), which convert everything between point and mark to the specified case. Point and mark do not move. |
Added psl-1983/3-1/doc/nmode/nm-text.topic version [a74ef7194a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Text} idx 13-1 .silent_index {parentheses} idx 13-1 .silent_index {words} idx 13-1 .silent_index {Meta} idx 13-1 .silent_index {motion} idx 13-1 .silent_index {killing} idx 13-1 .silent_index {transposition} idx 13-1 .silent_index {numeric} idx 13-1 .silent_index {mark} idx 13-2 .silent_index {sentences} idx 13-2 .silent_index {paragraphs} idx 13-2 .silent_index {motion} idx 13-2 .silent_index {killing} idx 13-2 .silent_index {Paragraph} idx 13-3 .silent_index {blank} idx 13-3 .silent_index {fill-prefix} idx 13-3 .silent_index {Region} idx 13-3 .silent_index {mark} idx 13-3 .silent_index {indentation} idx 13-3 .silent_index {formatting} idx 13-3 .silent_index {Linefeed} idx 13-3 .silent_index {Auto} idx 13-3 .silent_index {filling} idx 13-4 .silent_index {Auto} idx 13-4 .silent_index {numeric} idx 13-4 .silent_index {paragraphs} idx 13-4 .silent_index {justification} idx 13-4 .silent_index {centering} idx 13-5 .silent_index {Fill} idx 13-5 .silent_index {Fill} idx 13-5 .silent_index {echo} idx 13-5 .silent_index {case} idx 13-5 .silent_index {words} idx 13-5 .silent_index {numeric} idx 13-6 .silent_index {Region} idx 13-6 |
Added psl-1983/3-1/doc/nmode/nm-top-index.contents version [65e1189ad3].
> | 1 | contents_entry(0 30 {Topic Index} 30-1) |
Added psl-1983/3-1/doc/nmode/nm-top-index.ibm version [d584e83487].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-TOP-INDEX.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Topic Index) Page 30-1 202/30. Topic Index 201/<CR> . . . . . . . . . . . . . . 3-2, 3-3 <CR> . . . . . . . . . . . . . . 4-1 <CR>, . . . . . . . . . . . . . . 3-3 ! . . . . . . . . . . . . . . . . 4-1, 19-1 . . . . . . . . . . . . . . . . . 19-1 Alter Display Format . . . . . . . 24-1, 27-10, 27-14, 27-30, 27-31, 27-33, 27-34, 27-35, 27-40, 27-42, 27-43 Alter Existing Text . . . . . . . 24-1, 27-6, 27-12, 27-22, 27-32, 27-33, 27-39, 27-40, 27-41, 27-42 ASCII . . . . . . . . . . . . . . 3-1, 3-3 Auto . . . . . . . . . . . . . . . 2-1, 13-3, 13-4, 20-3, 22-5 Backspace . . . . . . . . . . . . 3-3, 4-1, 4-2, 6-1, 11-1, 14-1, 20-3 blank . . . . . . . . . . . . . . 4-3, 11-2, 13-3, 20-3 buffers . . . . . . . . . . . . . 2-1, 16-1, 18-2, 18-3 Buffers . . . . . . . . . . . . . 27-2, 27-5, 27-10, 27-13, 27-15, 27-17, 27-19, 27-32, 27-34, 27-35, 27-36, 27-43 Bugs . . . . . . . . . . . . . . 23-1 C- . . . . . . . . . . . . . . . . 7-2 C-X . . . . . . . . . . . . . . . 7-2 C-Z . . . . . . . . . . . . . . . 3-2 caret . . . . . . . . . . . . . . 3-3 Case . . . . . . . . . . . . . . . 12-2 case . . . . . . . . . . . . . . . 13-5, 14-2 centering . . . . . . . . . . . . 13-5 Change Mode . . . . . . . . . . . 24-1, 27-3, 27-21, 27-38, 27-39 character . . . . . . . . . . . . 3-1, 22-1 clear . . . . . . . . . . . . . . . 17-1 Comma . . . . . . . . . . . . . . 19-1 command . . . . . . . . . . . . . 6-1 commands . . . . . . . . . . . . 6-1, 22-2 comments . . . . . . . . . . . . 20-1, 20-3, 20-4 confirmation . . . . . . . . . . . 15-3 Connected . . . . . . . . . . . . 3-2, 6-2 control . . . . . . . . . . . . . . 3-1, 3-3 Control . . . . . . . . . . . . . 3-3, 4-1 control . . . . . . . . . . . . . . 22-1 Control-Meta . . . . . . . . . . . 20-4 Create . . . . . . . . . . . . . . 15-1 CRLF . . . . . . . . . . . . . . 3-3, 4-1 cursor . . . . . . . . . . . . . . 2-1, 4-1 Customization . . . . . . . . . . 3-2 customization . . . . . . . . . . . 6-2, 22-1 201/Page 30-2 NMODE Manual (Topic Index) Defun . . . . . . . . . . . . . . 25-1, 27-10, 27-11, 27-23, 27-25 Defuns . . . . . . . . . . . . . . 10-2, 20-5 Delete . . . . . . . . . . . . . . 15-4 deletion . . . . . . . . . . . . . 4-1, 11-1, 14-1, 19-1 directory . . . . . . . . . . . . 15-3 DIRED . . . . . . . . . . . . . . 15-2 Drastic . . . . . . . . . . . . . 15-2 echo . . . . . . . . . . . . . . . 2-1, 6-1, 13-5 Escape . . . . . . . . . . . . . . 24-1, 27-11, 27-19, 27-20, 27-21, 27-29 exiting . . . . . . . . . . . . . . 7-2 extended . . . . . . . . . . . . . 6-1, 22-2 file . . . . . . . . . . . . . . . 15-2 files . . . . . . . . . . . . . . . 2-2, 4-3, 15-1, 15-2, 15-3, 18-3 Files . . . . . . . . . . . . . . . 27-2, 27-6, 27-7, 27-11, 27-13, 27-16, 27-31, 27-33, 27-34, 27-37, 27-41, 27-42, 27-43, 27-44 Fill . . . . . . . . . . . . . . . 13-5, 22-4, 22-5 Fill Column . . . . . . . . . . . 26-1, 27-6, 27-12, 27-36 Fill Prefix . . . . . . . . . . . . 26-1, 27-12, 27-36 fill-prefix . . . . . . . . . . . . 13-3 filling . . . . . . . . . . . . . . 13-4 Find . . . . . . . . . . . . . . . 16-1 formatting . . . . . . . . . . . . 13-3, 20-6 forms . . . . . . . . . . . . . . 20-3 Functions . . . . . . . . . . . . 3-2 functions . . . . . . . . . . . . 6-1 Functions . . . . . . . . . . . . 6-2 functions . . . . . . . . . . . . 22-2 Goal Column . . . . . . . . . . . 26-1, 27-26, 27-29 grinding . . . . . . . . . . . . . 20-6 indentation . . . . . . . . . . . . 13-3, 20-1, 20-6 Inform . . . . . . . . . . . . . . 24-1, 27-2, 27-5, 27-6, 27-14, 27-19, 27-20, 27-43 init . . . . . . . . . . . . . . . 22-1 Insert Constant . . . . . . . . . 24-1, 27-15, 27-16, 27-23, 27-31, 27-33, 27-37, 27-39 insertion . . . . . . . . . . . . . 4-1, 15-3 justification . . . . . . . . . . . 13-4 kill . . . . . . . . . . . . . . . 11-2 Kill . . . . . . . . . . . . . . . 16-2 Kill Ring . . . . . . . . . . . . . 26-1, 27-2, 27-4, 27-6, 27-8, 27-16, 27-17, 27-18, 27-19, 27-41 killing . . . . . . . . . . . . . . 11-1, 11-2, 13-1, 13-2, 14-1, 20-4 201/NMODE Manual (Topic Index) Page 30-3 line . . . . . . . . . . . . . . . 3-3, 4-1 Linefeed . . . . . . . . . . . . . 13-3, 20-2, 20-6 Linefeed, . . . . . . . . . . . . 3-3 lines . . . . . . . . . . . . . . . 11-1 Lisp . . . . . . . . . . . . . . . 20-1, 20-3, 27-5, 27-9, 27-10, 27-11, 27-13, 27-15, 27-16, 27-17, 27-18, 27-19, 27-20, 27-21, 27-22, 27-23, 27-24, 27-25, 27-27, 27-33, 27-39, 27-44 List . . . . . . . . . . . . . . . 16-2 lists . . . . . . . . . . . . . . . 10-2 Lists . . . . . . . . . . . . . . . 20-3 M-X . . . . . . . . . . . . . . . 20-1 major . . . . . . . . . . . . . . 2-1 Major . . . . . . . . . . . . . . 16-1 major . . . . . . . . . . . . . . 20-1 mark . . . . . . . . . . . . . . . 10-1, 11-2, 11-3, 13-2, 13-3, 15-4, 20-5 Mark . . . . . . . . . . . . . . . 24-2, 27-10, 27-11, 27-14, 27-16, 27-23, 27-24, 27-37 matching . . . . . . . . . . . . . 20-2 meta . . . . . . . . . . . . . . . 3-1 Meta . . . . . . . . . . . . . . . 13-1 meta . . . . . . . . . . . . . . . 22-1 Metizer . . . . . . . . . . . . . 3-2 minor . . . . . . . . . . . . . . 2-1, 22-4 mode . . . . . . . . . . . . . . . 2-1 Mode . . . . . . . . . . . . . . . 7-1 mode . . . . . . . . . . . . . . . 16-1, 22-4 motion . . . . . . . . . . . . . . 13-1, 13-2, 20-4, 20-5 Move Data . . . . . . . . . . . . 24-2, 27-2, 27-13, 27-14, 27-15, 27-16, 27-17, 27-31, 27-41, 27-42, 27-44 Move Point . . . . . . . . . . . . 24-2, 27-4, 27-5, 27-9, 27-10, 27-13, 27-14, 27-24, 27-25, 27-26, 27-27, 27-28, 27-29, 27-31, 27-33, 27-35, 27-36, 27-42, 27-43 moving . . . . . . . . . . . . . . 11-2 nmode-default-mode . . . . . . . 16-1 NMODE.VARS . . . . . . . . . . 22-4 numeric . . . . . . . . . . . . . 5-1, 11-2, 11-4, 13-1, 13-4, 13-6, 17-1, 18-2, 20-6, 22-4 options . . . . . . . . . . . . . 22-4 OUTPUT . . . . . . . . . . . . . 18-1 pages . . . . . . . . . . . . . . 10-2 Paragraph . . . . . . . . . . . . 13-3, 25-1, 27-4, 27-12, 27-13, 27-24 paragraphs . . . . . . . . . . . 10-2, 13-2, 13-4 Paragraphs . . . . . . . . . . . 20-3 parentheses . . . . . . . . . . . 13-1, 20-2 Point . . . . . . . . . . . . . . 2-1 point . . . . . . . . . . . . . . 4-1 prefix . . . . . . . . . . . . . . 3-2, 22-2 201/Page 30-4 NMODE Manual (Topic Index) Preserve . . . . . . . . . . . . . 24-2, 27-6, 27-32, 27-34, 27-41, 27-43, 27-44 printing . . . . . . . . . . . . . 4-1 prompting . . . . . . . . . . . . 2-1, 6-1 Query . . . . . . . . . . . . . . 19-1 quitting . . . . . . . . . . . . . 12-2, 23-1 Quoting . . . . . . . . . . . . . 4-1 Read . . . . . . . . . . . . . . . 6-1 Recursive . . . . . . . . . . . . 7-1 recursive . . . . . . . . . . . . 15-2, 16-2 redefining . . . . . . . . . . . . 22-1 Region . . . . . . . . . . . . . . 10-1, 11-2, 11-3, 13-3, 13-6, 15-4, 20-5, 20-7, 25-1, 27-2, 27-6, 27-18, 27-22, 27-31, 27-40, 27-41, 27-42, 27-43 registers . . . . . . . . . . . . . 11-5 Remove . . . . . . . . . . . . . 24-2, 27-4, 27-6, 27-7, 27-8, 27-17, 27-18, 27-19, 27-33 Rename . . . . . . . . . . . . . 16-2 Replace . . . . . . . . . . . . . 19-1 replacement . . . . . . . . . . . 19-1 return3{} . . . . . . . . . . . . 6-1 Rubout . . . . . . . . . . . . . 19-1 Save . . . . . . . . . . . . . . . 16-2 saving . . . . . . . . . . . . . . 15-1 screen . . . . . . . . . . . . . . 2-1, 17-1 scrolling . . . . . . . . . . . . . 17-1 Scrolling . . . . . . . . . . . . . 17-2 scrolling . . . . . . . . . . . . . 18-2 searching . . . . . . . . . . . . 12-1, 19-1 Select . . . . . . . . . . . . . . 16-1, 24-2, 27-8, 27-14, 27-32, 27-33 Sentence . . . . . . . . . . . . . 25-1, 27-4, 27-12, 27-13, 27-19 sentences . . . . . . . . . . . . 13-2, 14-1 Set . . . . . . . . . . . . . . . 15-1, 15-4 Set Global Variable . . . . . . . . 24-2, 27-5, 27-32, 27-36, 27-37 shifted-digits-association-list . . . 14-2 Space . . . . . . . . . . . . . . 6-1, 19-1 stop . . . . . . . . . . . . . . . 7-2 submode . . . . . . . . . . . . . 2-1 Subsequent Command Modifier . . 24-2, 27-3, 27-5, 27-10, 27-21, 27-22, 27-29, 27-41 syntax . . . . . . . . . . . . . . 20-3 Text . . . . . . . . . . . . . . . 13-1, 27-6, 27-12, 27-13, 27-17, 27-18, 27-19, 27-22, 27-24, 27-26, 27-27, 27-39, 27-40, 27-42 toggling . . . . . . . . . . . . . 22-4 transposition . . . . . . . . . . . 13-1, 14-1, 20-5 two . . . . . . . . . . . . . . . 18-1 typos . . . . . . . . . . . . . . 14-1, 14-2 201/NMODE Manual (Topic Index) Page 30-5 uparrow . . . . . . . . . . . . . 3-3 Variables . . . . . . . . . . . . 3-3 variables . . . . . . . . . . . . . 22-4 Visit . . . . . . . . . . . . . . . 15-1 visiting . . . . . . . . . . . . . 4-3, 15-1, 16-1, 18-3 windows . . . . . . . . . . . . . 18-1 words . . . . . . . . . . . . . . 10-2, 13-1, 13-5, 14-1, 14-2 ^ . . . . . . . . . . . . . . . . 3-3, 19-1 |
Added psl-1983/3-1/doc/nmode/nm-typos.contents version [d281515a9a].
> > > > | 1 2 3 4 | contents_entry(0 14 {Commands for Fixing Typos} 14-1) contents_entry(1 14.1 {Killing Your Mistakes} 14-1) contents_entry(1 14.2 {Transposition} 14-1) contents_entry(1 14.3 {Case Conversion} 14-2) |
Added psl-1983/3-1/doc/nmode/nm-typos.function version [7e2c78db5b].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | .silent_index {delete-backward-character-command} idx 14-1 .silent_index {kill-backward-word-command} idx 14-1 .silent_index {backward-kill-sentence-command} idx 14-1 .silent_index {transpose-characters-command} idx 14-1 .silent_index {transpose-lines} idx 14-2 .silent_index {transpose-regions} idx 14-2 .silent_index {lowercase-word-command} idx 14-2 .silent_index {uppercase-word-command} idx 14-2 .silent_index {uppercase-initial-command} idx 14-2 .silent_index {upcase-digit-command} idx 14-2 |
Added psl-1983/3-1/doc/nmode/nm-typos.ibm version [cd21342b79].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-TYPOS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Commands for Fixing Typos) Page 14-1 202/14. Commands for Fixing Typos 201/In this section we describe the commands that are especially useful for the times when you catch a mistake in your text just after you have made it, or change your mind while composing text on line. Backspace Delete last character. M-Backspace Kill last word. C-X Rubout Kill to beginning of sentence. C-T Transpose two characters. C-X C-T Transpose two lines. C-X T Transpose two arbitrary regions. The next three commands are just M-L, M-U and M-C with arguments of -1. The argument could be entered with M-Minus, C-Minus, or C-U -1. M-Minus M-L Convert last word to lower case. M-Minus M-U Convert last word to all upper case. M-Minus M-C Convert last word to lower case with capital initial. M-' Fix up omitted shift key on digit. 202/14.1 Killing Your Mistakes 201/The Backspace command is the most important correction command. When used among printing (self-inserting) characters, it can be thought of as canceling the last character typed. When your mistake is longer than a couple of characters, it might be more convenient to use M-Backspace (203/kill-backward-word-command201/) or C-X Rubout (203/backward-kill-sentence-command201/). M-Backspace kills back to the start of the last word, and C-X Rubout kills back to the start of the last sentence. C-X Rubout is particularly useful when you are thinking of what to write as you type it, in case you change your mind about phrasing. M-Backspace and C-X Rubout save the killed text for C-Y and M-Y to retrieve (See Section 11.2 [Un-killing], page 2.). M-Rubout is often useful even when you have typed only a few characters wrong, if you know you are confused in your typing and aren't sure exactly what you typed. At such a time, you cannot correct with Rubout except by looking at the screen to see what you did. It requires less thought to kill the whole word and start over again. 202/14.2 Transposition 201/The common error of transposing two characters can be fixed, when they are adjacent, with the C-T command (203/transpose-characters-command201/). Normally, C-T transposes the two characters on either side of the cursor. When given at the end of a line, rather than transposing the last character of the line with the line separator, which would be useless, C-T transposes the last two characters on the line. So, if you catch your transposition error right away, you can fix it with just a C-T. If you don't catch it so fast, you must move the cursor back to between the two transposed characters. If 201/Page 14-2 NMODE Manual (Transposition) you transposed a space with the last character of the word before it, the word motion commands are a good way of getting there. Otherwise, a reverse search (C-R) is often the best way. See Section 12 [Search], page 1. To transpose two lines, use the C-X C-T command (203/transpose-lines201/). M-T transposes words and C-M-T transposes Lisp forms (in Lisp mode). A more general transpose command is C-X T (203/transpose-regions201/). This transposes two arbitrary blocks of text, which need not even be next to each other. To use it, set the mark at one end of one of the blocks, then at the other end of this block; then go to the other block and set the mark at one end, and put point at the other. In other words, point and the last three marks should be at the four locations which are the ends of the two blocks. It does not matter which of the four locations point is at, or which order the others were marked. C-X T transposes the two blocks of text thus identified. 202/14.3 Case Conversion 201/A very common error is to type words in the wrong case. Because of this, the word case-conversion commands M-L, M-U and M-C have a special feature when used with a negative argument: they do not move the cursor. As soon as you see you have mistyped the last word, you can simply case-convert it and go on typing. See Section 13.5 [Case], page 5. Another common error is to type a special character and miss the shift key, producing a digit instead. There is a special command for fixing this: M-' (203/upcase-digit-command201/), which fixes the last digit before point in this way (but only if that digit appears on the current line or the previous line. Otherwise, to minimize random effects of accidental use, M-' does nothing). Once again, the cursor does not move, so you can use M-' when you notice the error and immediately continue typing. Because M-' needs to know the arrangement of your keyboard, the first time you use it you must supply the information by typing the row of digits 1, 2, ... , 9, 0 but 203/holding down the shift key201/. This tells M-' the correspondence between digits and special characters, which is remembered for the duration of the NMODE in the variable shifted-digits-association-list. This command is called M-' because its main use is to replace "7" with a single-quote. |
Added psl-1983/3-1/doc/nmode/nm-typos.key version [17bbfaf280].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | .silent_index {M-Backspace} idx 14-1 .silent_index {C-X} idx 14-1 .silent_index {C-T} idx 14-1 .silent_index {C-X} idx 14-2 .silent_index {C-X} idx 14-2 .silent_index {M--} idx 14-2 .silent_index {M--} idx 14-2 .silent_index {M--} idx 14-2 .silent_index {M-L} idx 14-2 .silent_index {M-U} idx 14-2 .silent_index {M-C} idx 14-2 .silent_index {M-'} idx 14-2 |
Added psl-1983/3-1/doc/nmode/nm-typos.r version [89db18fc3c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-TYPOS manual @Chapter[Commands for Fixing Typos] @node("fixit") @index{typos} In this section we describe the commands that are especially useful for the times when you catch a mistake in your text just after you have made it, or change your mind while composing text on line. @DoubleWideCommands[ Backspace Delete last character. M-Backspace Kill last word. C-X Rubout Kill to beginning of sentence. C-T Transpose two characters. C-X C-T Transpose two lines. C-X T Transpose two arbitrary regions. ] The next three commands are just M-L, M-U and M-C with arguments of -1. The argument could be entered with M-Minus, C-Minus, or C-U -1. @DoubleWideCommands[ M-Minus M-L Convert last word to lower case. M-Minus M-U Convert last word to all upper case. M-Minus M-C Convert last word to lower case with capital initial. M-' Fix up omitted shift key on digit. ] @Section[Killing Your Mistakes] @index{Backspace} @index{deletion} @fncindex{delete-backward-character-command} The Backspace command is the most important correction command. When used among printing (self-inserting) characters, it can be thought of as canceling the last character typed. @keyindex{M-Backspace} @keyindex{C-X Rubout} @index{words} @index{sentences} @index{killing} @fncindex{kill-backward-word-command} @fncindex{backward-kill-sentence-command} When your mistake is longer than a couple of characters, it might be more convenient to use M-Backspace (@fnc{kill-backward-word-command}) or C-X Rubout (@fnc{backward-kill-sentence-command}). M-Backspace kills back to the start of the last word, and C-X Rubout kills back to the start of the last sentence. C-X Rubout is particularly useful when you are thinking of what to write as you type it, in case you change your mind about phrasing. M-Backspace and C-X Rubout save the killed text for C-Y and M-Y to retrieve (@Note("Un-killing").). M-Rubout is often useful even when you have typed only a few characters wrong, if you know you are confused in your typing and aren't sure exactly what you typed. At such a time, you cannot correct with Rubout except by looking at the screen to see what you did. It requires less thought to kill the whole word and start over again. @Section[Transposition] @index{transposition} @keyindex{C-T} @fncindex{transpose-characters-command} The common error of transposing two characters can be fixed, when they are adjacent, with the C-T command (@fnc{transpose-characters-command}). Normally, C-T transposes the two characters on either side of the cursor. When given at the end of a line, rather than transposing the last character of the line with the line separator, which would be useless, C-T transposes the last two characters on the line. So, if you catch your transposition error right away, you can fix it with just a C-T. If you don't catch it so fast, you must move the cursor back to between the two transposed characters. If you transposed a space with the last character of the word before it, the word motion commands are a good way of getting there. Otherwise, a reverse search (C-R) is often the best way. @Note("Search"). @keyindex{C-X C-T} @fncindex{transpose-lines} To transpose two lines, use the C-X C-T command (@fnc{transpose-lines}). M-T transposes words and C-M-T transposes Lisp forms (in Lisp mode). @Keyindex{C-X T} @fncindex{transpose-regions} A more general transpose command is C-X T (@fnc{transpose-regions}). This transposes two arbitrary blocks of text, which need not even be next to each other. To use it, set the mark at one end of one of the blocks, then at the other end of this block; then go to the other block and set the mark at one end, and put point at the other. In other words, point and the last three marks should be at the four locations which are the ends of the two blocks. It does not matter which of the four locations point is at, or which order the others were marked. C-X T transposes the two blocks of text thus identified. , and relocates point and the three marks without changing their order. @Section[Case Conversion] @fncindex{lowercase-word-command} @fncindex{uppercase-word-command} @fncindex{uppercase-initial-command} @keyindex{M-- M-L} @keyindex{M-- M-U} @keyindex{M-- M-C} @keyindex{M-L} @keyindex{M-U} @keyindex{M-C} @index{case conversion} @index{words} A very common error is to type words in the wrong case. Because of this, the word case-conversion commands M-L, M-U and M-C have a special feature when used with a negative argument: they do not move the cursor. As soon as you see you have mistyped the last word, you can simply case-convert it and go on typing. @Note("Case"). @keyindex{M-'} @index{typos} @fncindex{upcase-digit-command} @index{shifted-digits-association-list} Another common error is to type a special character and miss the shift key, producing a digit instead. There is a special command for fixing this: M-' (@fnc{upcase-digit-command}), which fixes the last digit before point in this way (but only if that digit appears on the current line or the previous line. Otherwise, to minimize random effects of accidental use, M-' does nothing). Once again, the cursor does not move, so you can use M-' when you notice the error and immediately continue typing. Because M-' needs to know the arrangement of your keyboard, the first time you use it you must supply the information by typing the row of digits 1, 2, ... , 9, 0 but @xxii[holding down the shift key]. This tells M-' the correspondence between digits and special characters, which is remembered for the duration of the NMODE in the variable shifted-digits-association-list. This command is called M-' because its main use is to replace "7" with a single-quote. |
Added psl-1983/3-1/doc/nmode/nm-typos.topic version [0170b0b2fd].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | .silent_index {typos} idx 14-1 .silent_index {Backspace} idx 14-1 .silent_index {deletion} idx 14-1 .silent_index {words} idx 14-1 .silent_index {sentences} idx 14-1 .silent_index {killing} idx 14-1 .silent_index {transposition} idx 14-1 .silent_index {case} idx 14-2 .silent_index {words} idx 14-2 .silent_index {typos} idx 14-2 .silent_index {shifted-digits-association-list} idx 14-2 |
Added psl-1983/3-1/doc/nmode/nm-windows.contents version [e89b199ecb].
> > | 1 2 | contents_entry(0 18 {Two Window Mode} 18-1) contents_entry(1 18.1 {Multiple Windows and Multiple Buffers} 18-2) |
Added psl-1983/3-1/doc/nmode/nm-windows.function version [33bdd9c1d0].
> > > > > > > > | 1 2 3 4 5 6 7 8 | .silent_index {two-windows-command} idx 18-1 .silent_index {one-window-command} idx 18-1 .silent_index {other-window-command} idx 18-1 .silent_index {exchange-windows-command} idx 18-1 .silent_index {scroll-other-window-command} idx 18-2 .silent_index {view-two-windows-command} idx 18-2 .silent_index {grow-window-command} idx 18-2 .silent_index {visit-in-other-window-command} idx 18-3 |
Added psl-1983/3-1/doc/nmode/nm-windows.ibm version [189a72faaa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 April 1983) <PSL.NMODE-DOC>NM-WINDOWS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Two Window Mode) Page 18-1 202/18. Two Window Mode 201/NMODE allows you to split the screen into two 202/windows 201/and use them to display parts of two files, or two parts of the same file. C-X 2 Start showing two windows. C-X 3 Show two windows but stay "in" the top one. C-X 1 Show only one window again. C-X O Switch to the Other window C-X E Exchange Windows C-X 4 Find buffer or file in other window. C-X ^ Make this window bigger. C-M-V Scroll the other window. In 202/two window 201/mode, the text display portion of the screen is divided into two parts called 202/windows201/, which display different pieces of text. The two windows can display two different files, or two parts of the same file. Only one of the windows is selected; that is the window which the cursor is in. Editing normally takes place in that window alone. To edit in the other window, you would give a special command to move the cursor to the other window, and then edit there. The command C-X 2 (203/two-windows-command201/) enters two-window mode. A second mode line appears across the middle of the screen, dividing the text display area into two halves. Window one, containing the same text as previously occupied the whole screen, fills the top half, while window two fills the bottom half. The cursor moves to window two. If this is your first entry to two-window mode, window two contains the output buffer OUTPUT. Otherwise, it contains the same text it held the last time you looked at it. If given an argument, the same buffer that previously occupied the whole screen will appear in the lower window as well. To return to viewing only one window, use the command C-X 1 (203/one-window-command201/). Window one expands to fill the whole screen, and window two disappears until the next C-X 2. C-U C-X 1 gets rid of window one and makes window two use the whole screen. Neither of these depends on which window the cursor is in when the command is given. While you are in two window mode you can use C-X O (203/other-window-command201/) to switch between the windows. After doing C-X 2, the cursor is in window two. Doing C-X O moves the cursor back to window one, to exactly where it was before the C-X 2. The difference between this and doing C-X 1 is that C-X O leaves window two visible on the screen. A second C-X O moves the cursor back into window two, to where it was before the first C-X O. And so on... While you are in two window mode you can also call C-X E (203/exchange-windows-command201/) , which exchanges the physical positions of the two windows. This leaves the cursor in the current window, and leaves the division of the screen unchanged, but it swaps the buffers displayed in the two portions of the screen. As a result it can change the portion of each buffer that is displayed. 201/Page 18-2 NMODE Manual (Two Window Mode) Often you will be editing one window while using the other just for reference. Then, the command C-M-V (203/scroll-other-window-command201/) is very useful. It scrolls the other window without switching to it and switching back. It scrolls the same way C-V does: with no argument, a whole screen up; with an argument, that many lines up (or down, for a negative argument). With just a minus sign (no digits) as an argument, C-M-V scrolls a whole screenful backwards (what M-V does). The C-X 3 (203/view-two-windows-command201/) command is like C-X 2 but leaves the cursor in window one. That is, it makes window two appear at the bottom of the screen but leaves the cursor where it was. C-X 2 is equivalent to C-X 3 C-X O. C-X 3 is equivalent to C-X 2 C-X O, but C-X 3 is much faster. Normally, the screen is divided evenly between the two windows. You can also redistribute screen space between the windows with the C-X ^ (203/grow-window-command201/) command. It makes the currently selected window get one line bigger, or as many lines as is specified with a numeric argument. With a negative argument, it makes the selected window smaller. Neither window can be squeezed to less than one line of visible text by C-X ^. Overly large arguments squeeze one window to a line of text, then stop. The allocation of space to the windows is remembered while you are in one window mode and the same allocation is used when you return to two window mode. The allocation changes only when you give a C-X ^ command. After leaving two-window mode, you can still use C-X O, but its meaning is different. Window two does not appear, but whatever was being shown in it appears, in window one (the whole screen). Whatever buffer used to be in window one is stuck, invisibly, into window two. Another C-X O reverses the effect of the first. For example, if window one shows buffer B and window two shows buffer OUTPUT (the usual case), and only window one is visible, then after a C-X O window one shows buffer OUTPUT and window two shows buffer B. 202/18.1 Multiple Windows and Multiple Buffers 201/Buffers can be selected independently in each window. The C-X B command selects a new buffer in whichever window the cursor is in. The other window's buffer does not change. Window two's buffer is remembered while you are in one window mode, and when you return to two window mode that same buffer reappears in window two. See Section 16 [Buffers], page 1. You can view one buffer in both windows. Give C-X 2 an argument as in C-U C-X 2 to go into two window mode, with both windows showing the buffer which used to be in window one alone. Although the same buffer appears in both windows, they have different values of point, so you can move around in window two while window one continues to show the same text. Then, having found in window two the place you wish to refer to, you can go back to window one with C-X O to make your changes. Finally you can do C-X 1 to make window two leave the screen. If you are already in two window mode, C-U C-X O switches windows carrying the buffer from the old window to the new one so that both windows show that buffer. 201/NMODE Manual (Multiple Windows and Multiple Buffers) Page 18-3 If you have the same buffer in both windows, you must beware of trying to visit a different file in one of the windows with C-X C-V, because if you bring a new file into this buffer, it will replace the old file in 203/both 201/windows. To view different files in the two windows again, you must switch buffers in one of the windows first (with C-X B or C-X C-F, perhaps). A convenient "combination" command for viewing something in the other window is C-X 4 (203/visit-in-other-window-command201/). With this command you can ask to see any specified buffer or file in the other window. Follow the C-X 4 with either B and a buffer name, F or C-F and a file name. This switches to the other window and finds there what you specified. If you were previously in one-window mode, two-window mode is entered. C-X 4 B is similar to to C-X 2 C-X B. C-X 4 F is similar to C-X 2 C-X C-F. The difference is one of efficiency, and also that C-X 4 works equally well if you are already using two windows. |
Added psl-1983/3-1/doc/nmode/nm-windows.key version [3d5eb6f1f0].
> > > > > > > > | 1 2 3 4 5 6 7 8 | .silent_index {C-X} idx 18-1 .silent_index {C-X} idx 18-1 .silent_index {C-X} idx 18-1 .silent_index {C-X} idx 18-1 .silent_index {C-M-V} idx 18-2 .silent_index {C-X} idx 18-2 .silent_index {C-X} idx 18-2 .silent_index {C-X} idx 18-3 |
Added psl-1983/3-1/doc/nmode/nm-windows.r version [024dccedda].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .so pndoc:nman .part NM-WINDOWS manual @Chapter[Two Window Mode] @node("windows") NMODE allows you to split the screen into two @dfn[windows] and use them to display parts of two files, or two parts of the same file. @WideCommands[ C-X 2 Start showing two windows. C-X 3 Show two windows but stay "in" the top one. C-X 1 Show only one window again. C-X O Switch to the Other window C-X E Exchange Windows C-X 4 Find buffer or file in other window. C-X ^ Make this window bigger. C-M-V Scroll the other window. ] @index{windows} @index{two window mode} In @dfn[two window] mode, the text display portion of the screen is divided into two parts called @dfn[windows], which display different pieces of text. The two windows can display two different files, or two parts of the same file. Only one of the windows is selected; that is the window which the cursor is in. Editing normally takes place in that window alone. To edit in the other window, you would give a special command to move the cursor to the other window, and then edit there. @index{OUTPUT} @keyindex{C-X 2} @fncindex{two-windows-command} The command C-X 2 (@fnc{two-windows-command}) enters two-window mode. A second mode line appears across the middle of the screen, dividing the text display area into two halves. Window one, containing the same text as previously occupied the whole screen, fills the top half, while window two fills the bottom half. The cursor moves to window two. If this is your first entry to two-window mode, window two contains the output buffer OUTPUT. Otherwise, it contains the same text it held the last time you looked at it. If given an argument, the same buffer that previously occupied the whole screen will appear in the lower window as well. @keyindex{C-X 1} @fncindex{one-window-command} To return to viewing only one window, use the command @w[C-X 1] (@fnc{one-window-command}). Window one expands to fill the whole screen, and window two disappears until the next @w[C-X 2]. @w[C-U C-X 1] gets rid of window one and makes window two use the whole screen. Neither of these depends on which window the cursor is in when the command is given. @keyindex{C-X O} @fncindex{other-window-command} While you are in two window mode you can use C-X O (@fnc{other-window-command}) to switch between the windows. After doing C-X 2, the cursor is in window two. Doing C-X O moves the cursor back to window one, to exactly where it was before the @w[C-X 2]. The difference between this and doing C-X 1 is that C-X O leaves window two visible on the screen. A second C-X O moves the cursor back into window two, to where it was before the first @w[C-X O]. And so on... @keyindex{C-X E} @fncindex{exchange-windows-command} While you are in two window mode you can also call C-X E (@fnc{exchange-windows-command}) , which exchanges the physical positions of the two windows. This leaves the cursor in the current window, and leaves the division of the screen unchanged, but it swaps the buffers displayed in the two portions of the screen. As a result it can change the portion of each buffer that is displayed. @index{scrolling} @index{numeric arguments} @keyindex{C-M-V} @fncindex{scroll-other-window-command} Often you will be editing one window while using the other just for reference. Then, the command C-M-V (@fnc{scroll-other-window-command}) is very useful. It scrolls the other window without switching to it and switching back. It scrolls the same way C-V does: with no argument, a whole screen up; with an argument, that many lines up (or down, for a negative argument). With just a minus sign (no digits) as an argument, C-M-V scrolls a whole screenful backwards (what M-V does). @keyindex{C-X 3} @fncindex{view-two-windows-command} The C-X 3 (@fnc{view-two-windows-command}) command is like C-X 2 but leaves the cursor in window one. That is, it makes window two appear at the bottom of the screen but leaves the cursor where it was. C-X 2 is equivalent to C-X 3 @w[C-X O]. C-X 3 is equivalent to C-X 2 C-X O, but C-X 3 is much faster. @keyindex{C-X ^} @fncindex{grow-window-command} Normally, the screen is divided evenly between the two windows. You can also redistribute screen space between the windows with the @w[C-X ^] (@fnc{grow-window-command}) command. It makes the currently selected window get one line bigger, or as many lines as is specified with a numeric argument. With a negative argument, it makes the selected window smaller. Neither window can be squeezed to less than one line of visible text by C-X ^. Overly large arguments squeeze one window to a line of text, then stop. The allocation of space to the windows is remembered while you are in one window mode and the same allocation is used when you return to two window mode. The allocation changes only when you give a @w[C-X ^] command. After leaving two-window mode, you can still use C-X O, but its meaning is different. Window two does not appear, but whatever was being shown in it appears, in window one (the whole screen). Whatever buffer used to be in window one is stuck, invisibly, into window two. Another C-X O reverses the effect of the first. For example, if window one shows buffer B and window two shows buffer OUTPUT (the usual case), and only window one is visible, then after a C-X O window one shows buffer OUTPUT and window two shows buffer B. @Section[Multiple Windows and Multiple Buffers] @index{buffers} Buffers can be selected independently in each window. The C-X B command selects a new buffer in whichever window the cursor is in. The other window's buffer does not change. Window two's buffer is remembered while you are in one window mode, and when you return to two window mode that same buffer reappears in window two. @Note("Buffers"). @index{numeric arguments} You can view one buffer in both windows. Give C-X 2 an argument as in C-U C-X 2 to go into two window mode, with both windows showing the buffer which used to be in window one alone. Although the same buffer appears in both windows, they have different values of point, so you can move around in window two while window one continues to show the same text. Then, having found in window two the place you wish to refer to, you can go back to window one with C-X O to make your changes. Finally you can do C-X 1 to make window two leave the screen. If you are already in two window mode, C-U C-X O switches windows carrying the buffer from the old window to the new one so that both windows show that buffer. If you have the same buffer in both windows, you must beware of trying to visit a different file in one of the windows with C-X C-V, because if you bring a new file into this buffer, it will replace the old file in @xxii[both] windows. To view different files in the two windows again, you must switch buffers in one of the windows first (with C-X B or C-X C-F, perhaps). @keyindex{C-X 4} @index{visiting} @index{buffers} @index{files} @fncindex{visit-in-other-window-command} A convenient "combination" command for viewing something in the other window is C-X 4 (@fnc{visit-in-other-window-command}). With this command you can ask to see any specified buffer or file in the other window. Follow the C-X 4 with either B and a buffer name, F or C-F and a file name. This switches to the other window and finds there what you specified. If you were previously in one-window mode, two-window mode is entered. C-X 4 B is similar to to C-X 2 C-X B. C-X 4 F is similar to C-X 2 C-X C-F. The difference is one of efficiency, and also that C-X 4 works equally well if you are already using two windows. |
Added psl-1983/3-1/doc/nmode/nm-windows.topic version [2f9416ef1c].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | .silent_index {windows} idx 18-1 .silent_index {two} idx 18-1 .silent_index {OUTPUT} idx 18-1 .silent_index {scrolling} idx 18-2 .silent_index {numeric} idx 18-2 .silent_index {buffers} idx 18-2 .silent_index {numeric} idx 18-2 .silent_index {visiting} idx 18-3 .silent_index {buffers} idx 18-3 .silent_index {files} idx 18-3 |
Added psl-1983/3-1/doc/nmode/nman.rmac version [e69c6ce2f4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Master macro file for NMODE Manual. .dv ibm .so no-overprint . .nr both_sides 1 .sr left_heading \section_title .sr left_heading NMODE Manual (\section_title) .sr center_heading .sr right_heading Page \page_number .nr top_margin_size 600 .nr bottom_margin_size 1400 .nr heading_pos 400 .sd file_date_string fdate .nr macro_arg_limit 20 .sr list_left_margin 0 .sr list_right_margin 0 . .so multipart .so std .so send .so xref .so environments . .so <user-utilities>index .nr index_tab 3000 . .de letter_break .sp 1 .ne 4 .in index_tab!m .ta index_tab!m .em . .de before_index_entry .br .ti 0 .em . .sr term_page_separator . .sr page_page_separator , .sr subentry_separator |||| . .de odd_page .top_of_page .if page%2==0 .rs .bp .en .em . .so pndoc:nmode-macros |
Added psl-1983/3-1/doc/nmode/nmode-macros.rmac version [def3c6724a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .nd frames 0 . .tr @ @ .cc x @ .ec t \ tab .ec a @ text at-sign .ec s text space . ------------------------------------------------------------------------------ Sending Macros ------------------------------------------------------------------------------ . .de send_topic .if ~frames .setup_file topic .wl .silent_index {\0} idx \page_number .we .en .em . .de send_fnc .if ~frames .setup_file function .wl .silent_index {\0} idx \page_number .we .en .em . .de send_name .if ~frames .setup_file command .wl .silent_index {\0} idx \page_number .we .en .em . .de send_key .if ~frames .setup_file key .wl .silent_index {\0} idx \page_number .we .en .em . . ------------------------------------------------------------------------------ Environment Definitions ------------------------------------------------------------------------------ . Environments that don't change Filling .define_environment group sp -1 0 0 {ne 3i} noop .define_environment fnc sp -1 0 0 {nv font 2} noop .define_environment hp9836 sp -1 0 0 noop noop Filled Environments: .define_environment cmd_doc sp 1 1 1 begdoc enddoc .define_environment multiple sp 1 0 0 noop noop List Environments: .define_environment description next 1 0 0 desc end_list .define_environment enumerate next 1 0 0 enum end_list .define_environment commands next 1 0 0 cmds end_list .define_environment widecommands next 1 0 0 wcmds end_list .define_environment doublewidecommands next 1 0 0 dwcmds end_list .define_environment grosscommands next 1 0 0 dwcmds end_list NoFill Environments: .define_environment quotation sp 0 1 1 quot noop .define_environment verbatim sp 0 1 1 noop noop .define_environment format sp 0 1 1 noop noop .define_environment example sp 0 1 1 noop noop .define_environment equation sp 0 1 1 noop noop .define_environment programexample sp 0 1 1 noop noop .define_environment funenv sp 0 1 1 noop noop .define_environment code sp 0 1 1 noop noop .define_environment lispexample sp 0 1 1 noop noop .define_environment center sp 0 0 0 centst noop Ignored Environments: .define_environment comment noop 0 0 0 ignore end_ignore .define_environment info noop 0 0 0 ignore end_ignore .define_environment twenex noop 0 0 0 ignore end_ignore .define_environment its noop 0 0 0 ignore end_ignore . .de funstt .hv indent 5 .hv rindent 5 .em . .de centst .nr adjust 2 .em . .de quot .hv indent 5 .ti indent!m .em . .de desc .sv list_start .ilist 14 .em . .de enum .sv list_start \\,list_count.\s\t .ilist 5 .em . .de itmz .sv list_start \\list_count.\s\t .ilist 5 .em . .de cmds .sv list_left_margin 8 .ilist 8 0 .em . .de wcmds .sv list_left_margin 8 .ilist 12 0 .em . .de dwcmds .sv list_left_margin 8 .ilist 16 0 .em . .de begdoc .if frames .nr adjust 0 .en .em . .de enddoc .if ~frames .dashes .en .ns .em . .de psep .sp .ns .em . . ------------------------------------------------------------------------------ Cross-Reference Stuff ------------------------------------------------------------------------------ . .de node .label {\0} .em . .de note .lbegin .sv node \0 .sv name \1 .if nargs<2 .sr name \0 .en See Section ref(\node) [\name], page pageref(\node) .en .em . ------------------------------------------------------------------------------ Sectioning Macros ------------------------------------------------------------------------------ . .eq old_chapter chapter .eq old_section section .eq old_subsection subsection . .de chapter .nr indent 0 .nr rindent 0 .old_chapter {\:*} .em . .de section .ti 0 .in 0 .ir 0 .old_section {\:*} .em . .de subsection .ti 0 .in 0 .ir 0 .old_subsection {\:*} .em . ------------------------------------------------------------------------------ Footnotes ------------------------------------------------------------------------------ . .de foot {text} \fn .sfoot \* .efoot .em . ------------------------------------------------------------------------------ Indexes ------------------------------------------------------------------------------ . .de fncindex .send_fnc \* .em . .de keyindex .send_key \* .em . .de index .send_topic \* .em . . ------------------------------------------------------------------------------ Bibliography ------------------------------------------------------------------------------ . .de cite [\*] .em . . ------------------------------------------------------------------------------ Miscellaneous Macros ------------------------------------------------------------------------------ . .de traceon .nr trace 1 .em . .de traceoff .nr trace 0 .em . .de tabdivide n .if .nv n \0 .nv w ll/n .ta w!m 2*w!m 3*w!m 4*w!m 5*w!m 6*w!m 7*w!m 8*w!m 9*w!m 10*w!m .en .em . .de include foo.mss .if .sv the_filename \0 .nv i 0 .sv period . .si i period the_filename .if i>0 .sb the_filename the_filename 1 i-1 .en .so \the_filename.r .en .em . .de newpage .bp .em . .de comment .em . .de blankspace .sp \0 .em . .de manual \* .em . .de w \* .em . .de ctl ^\0 .em . .de return1 <CR> .em . .de return2 <CR> .em . .de return3 Return .em . .de cz C-C .em . .de cc C-Z .em . ------------------------------------------------------------------------------ Font Specifications ------------------------------------------------------------------------------ . .de i italic 2\** .em . .de r roman 0\** .em . .de b bold 1\** .em . .de up superscript \* .em . .de down subscript \* .em . .eq c r small capitals .eq k b capitals? .eq ei i .eq u b underline .eq dq b .eq xxi i .eq xxii i .eq xxu b .eq xxuu b . .de u_if_we_could underline .if .nv ul 1 .nv ul_space 0 \* .en .em . .eq fnc i .eq dfn b . .nr dashes_page -1 .nr dashes_vpos -1 . .de dashes .if page~=dashes_page|vpos>dashes_vpos+100 . br . if ibm 4$* . ef - . en . br . nr dashes_page page . nr dashes_vpos vpos . en .em |
Added psl-1983/3-1/doc/nmode/r.contents version [476f555248].
> > | 1 2 | contents_entry(0 1 {Introduction} 1-1) contents_entry(1 1.1 {Preface} 1-2) |
Added psl-1983/3-1/doc/nmode/r.out version [b3d7483012].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (23 March 1983) R.OUT PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Manual (Introduction) Page 1-1 202/1. Introduction 201/This document describes the NMODE text editor. NMODE is an advanced, self-documenting, customizable, extensible, interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified appropriately in areas where NMODE and EMACS differ. The original author of the EMACS documentation was Richard M. Stallman. We say that NMODE is a screen-oriented editor because normally the text being edited is visible on the screen and is updated automatically as you type your commands. See Section 2 [Display], page 1. We call it an interactive editor because the display is updated very frequently, usually after each character or pair of characters you type. This minimizes the amount of information you must keep in your head as you edit. We call NMODE advanced because it provides facilities that go beyond simple insertion and deletion: filling of text; automatic indentation of programs; viewing two files at once; and dealing in terms of characters, words, lines, sentences, paragraphs, and pages, as well as expressions and comments in several different programming languages. It is much easier to type one command meaning "go to the end of the paragraph" than to find the desired spot with repetition of simpler commands. Self-documenting means that there are on-line functions to find out the function of any command and to view documentation about that command. See Section 8 [Help], page 1. Customizable means that you can change the definitions of NMODE commands in little ways. For example, you can rearrange the command set. If you prefer the four basic cursor motion commands (up, down, left and right) on keys in a diamond pattern on the keyboard, you can have it. See Section 21 [Customization], page 1. Extensible means that you can go beyond simple customization and write entirely new commands, programs in the language PSL. NMODE is an "on-line extensible" system, which means that it is divided into many functions that call each other, any of which can be redefined in the middle of an editing 201/Page 1-2 NMODE Manual (Introduction) session. Any part of NMODE can be replaced without making a separate copy of all of NMODE. 202/1.1 Preface 201/This manual documents the use and simple customization of the display editor NMODE with the 9836 operating system. The reader is 203/not 201/expected to be a programmer. Even simple customizations do not require programming skill, but the user who is not interested in customizing can ignore the scattered customization hints. This is primarily a reference manual, but can also be used as a primer. However, I recommend that the newcomer first use the on-line, learn-by-doing tutorial NTEACH. With it, you learn NMODE by using NMODE on a specially designed file which describes commands, tells you when to try them, and then explains the results you see. This gives a more vivid introduction than a printed manual. On first reading, you need not make any attempt to memorize chapters 2 and 3, which describe the notational conventions of the manual and the general appearance of the NMODE display screen. It is enough to be aware of what questions are answered in these chapters, so you can refer back when you later become interested in the answers. After reading the Basic Editing chapter you should practice the commands there. The next few chapters describe fundamental techniques and concepts that are referred to again and again. It is best to understand them thoroughly, experimenting with them if necessary. To find the documentation on a particular command, look in the index if you know what the command is. Both command characters and function names are indexed. If you know vaguely what the command does, look in the command summary. The command summary contains a line or two about each command, and a cross reference to the section of the manual that describes the command in more detail; related commands are grouped together. |
Added psl-1983/3-1/doc/nmode/simple-chart.ibm version [15c7e20a19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>SIMPLE-CHART.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 202/Simplified 9836 NMODE Command Summary 201/10 February 1983 202/Information 201/Show Function on Key M-? List Matching Commands <help> 202/Files 201/Find File C-X C-F Save File C-X C-S 202/Buffers 201/Select Buffer C-X B List Buffers C-X C-B Go to Buffer Start M-< (or) <clr-end> Go to Buffer End M-> (or) Shift-<clr-end> Kill Buffer C-X K 202/Characters 201/Move Forward Character C-F (or) <right-arrow> Move Backward Character C-B (or) <left-arrow> Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Quote Character C-Q 202/Lines 201/Move to Next Line C-N (or) <down-arrow> Move to Previous Line C-P (or) <up-arrow> Goto Start of Line C-A Goto End of Line C-E Kill Line C-K (or) <del-ln> Insert Blank Line C-O (or) <ins-ln> 202/Killing and Unkilling Text 201/Kill Line C-K (or) <del-ln> Yank Killed Text C-Y Yank Previous Kill M-Y 202/String Search 201/Foward Search C-S Reverse Search C-R 202/String Replacement 201/Query Replace M-% Replace String C-% 202/Indentation 201/Indent Line Tab Indent New Line Newline 202/Text Filling and Justification 201/Fill Paragraph M-Q Fill Comment M-Z Auto Fill Mode (toggle) M-X Auto Fill Mode 202/Modes 201/Enter Lisp Mode M-X Lisp Mode Enter Text Mode M-X Text Mode 202/Lisp Execution 201/Execute Form C-] E Execute Defun C-] D Quit from Break Loop C-] Q Backtrace from Break Loop C-] B Retry from Break Loop C-] R 202/Screen Management 201/Redisplay Screen C-L Scroll to Next Screenful C-V (or) <recall> Scroll to Previous Screenful M-V (or) Shift-<recall> 202/Windows 201/Two Windows C-X 2 One Window C-X 1 Go to Other Window C-X O |
Added psl-1983/3-1/doc/psl-vm.doc version [7569b87d41].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NOTES ON THE PSL VIRTUAL MACHINE Cris Perdue 3-8-83 ------------------------------------- NOTES ON THE SYSLISP DATATYPES ------------------------------ Most of the PSL low-level operators deal with values that are of a standard size for a given machine. Tagged LISP "items" are of this size, as are "machine-integers" and "machine-pointers" (see below for details on these datatypes). A machine-integer is a value to which operations such as WPLUS2, WOR and WSHIFT apply. These are listed in the documentation for SYSLISP. The arithmetic operators are all signed arithmetic. A machine-pointer is a machine-integer which may be an argument to byte, memory, putmem, wgetv, etc.. It is legitimate to use address arithmetic, but the difference between the addresses of two adjacent items may be an integer greater than one. The difference between the addresses of two adjacent items (words) is the value of the WCONST AddressingUnitsPerItem. PROBLEMS WITH THE USE OF MACHINE-INTEGERS AND MACHINE-POINTERS In the current implementation of PSL a machine-integer serves as the representation for every LISP integer of less than a certain size. Within this range of values, no conversion is required and machine integers can neither confuse the garbage collector nor be trashed by the garbage collector. If a machine integer outside this range resides where the garbage collector expects an item, for example in the stack, it is liable to be taken as a tagged pointer. If it appears to have a legal tag, the garbage collector is likely to try to examine the word pointed to and this may cause an odd address error or memory bus error. Also the integer may well be "relocated", i.e. altered to "point" to the new location of the data after the garbage collection -- the garbage collectors move heap objects. Even if none of these catastrophic events occurs, the garbage collector may be prevented from collecting some garbage because the integer gave the appearance of pointing to it. Machine-pointers suffer from some similar problems. If a garbage collection should occur during the active lifetime of a machine-pointer that points into the heap, that pointer will cease to point to the intended object. A NOTE ON PREDICATES All of the predicates described in this document return LISP boolean values, i.e. NIL or not-NIL. When used to affect flow of control, they compile just as the corresponding tests would in C or PASCAL, without reference to any LISPy values. ARITHMETIC AND LOGICAL OPERATIONS --------------------------------- WPLUS2, WDIFFERENCE, WTIMES2, WQUOTIENT, WREMAINDER Signed arithmetic with word-sized arguments and result. (WSHIFT value amount) Logical shift left or right. Positive shift amounts mean shifting to the left. The absolute value of the shift amount should be less than the number of bits per item. WMINUS Unary negation. WAND, WOR, WXOR Binary bitwise logical operators. WNOT Unary logical complement (logical negation). WEQ, WNEQ Equality of item-sized values. Serves for both logical and arithmetic equality. The result is a LISP boolean value (NIL or not NIL), which is not necessarily materialized. WGREATERP, WLESSP, WGEQ, WLEQ Signed arithmetic booleans. The result is a LISP boolean value (NIL or not NIL) which is not necessarily materialized. (FIELD value startingbit length), (SIGNEDFIELD value startingbit length) These operators extract fields from item-sized quantities. The extracted field is right-justified. FIELD pads the result with zeroes, and SIGNEDFIELD pads the result with ones if the most significant bit of the field is a one. Bits are numbered with the most significant bit as bit zero. The startingbit and length arguments must be compile-time constants. MEMORY-ORIENTED OPERATIONS -------------------------- (GETMEM pointer) Given a machine pointer, returns the word pointed to. (PUTMEM pointer value) Given a machine pointer and a word-sized value, stores the value into the word pointed to. (PUTFIELD pointer startingbit length value) Given a machine pointer, compile-time constants startingbit and length, and a word-sized value, the low-order bits of the value are stored into the specified field of the word referred to by pointer. Is a value returned? (WGETV pointer offset), (WPUTV pointer offset value) These provide access to words at addresses that are offset from some address. (WGETV pointer 0) is equivalent to (GETMEM pointer). Does WPUTV return a value? (BYTE pointer index), (PUTBYTE pointer index value) These provide access to vectors of byte-sized quantities. The pointer is a machine-pointer to the first word in which the bytes may be stored. The index must be zero or greater. BYTE extracts a byte and pads with zeroes. PUTBYTE stores the low-order bits of the value into a byte in memory. Does PUTBYTE return a value? (HALFWORD pointer index), (PUTHALFWORD pointer index value) These provide access to vectors of quantities packable 2 per word. They are analagous to BYTE and PUTBYTE, and the value of HALFWORD is zero-padded. LOC Use with variable names including WVARs and WARRAYs? Also with WGETV expressions? WCONST WCONSTs can be used in any LISP code by writing a compile-time constant expression: (WCONST <expression>). The expression may use WCONSTs by name. If WDECLARE is loaded (as in SYSLISP), named WCONSTs (and only WCONSTs) may be declared using the WDECLARE function. CROSS-COMPILER ONLY -- WVAR, WARRAY, WSTRING For WVARs, declare them first then use by name. <<So why say LISPVAR at all in SysLisp?>> Use WCONSTs as (WCONST expression) or alternatively (I think) declare first and use by name. Use of WARRAY or WSTRING by name means address of zeroth element, rather like a WCONST.(?) DECLARING WVARS, WARRAYS, WSTRINGS, AND WCONSTS (WDeclare scope type (name bound init) (name [bound init]) . . . ) Scope is EXPORTED, EXTERNAL, or DEFAULT. (Meaning of DEFAULT?) Type is WVAR, WARRAY, WSTRING, or WCONST. Bound and Init are optional and mutually exclusive. Bound can only apply to a WARRAY or WSTRING, and gives the upper bound of the array or string. Init is a compile-time constant expression in the case of a WVAR, or a list (of constant expressions?) in the case of a WARRAY, or a string in the case of a WSTRING. I think the list form is legal for a string, in which case the members are taken as ASCII codes for characters. (This information is not guaranteed!) CONVERSION BETWEEN LISP- AND MACHINE-VALUES ------------------------------------------- INUMs need no conversion. For machine-integers in general, the functions SYS2INT and INT2SYS convert to and from LISP numeric values. ON "ITEMS" ---------- All PSL "pointers" are "items", also known as "tagged items". An item consists of a tag part and an information part. In current implementations the parts occupy fixed fields of a fixed-size quantity, but this has not been so in every implementation. In what follows note that BYTES are only partially implemented and that from the user's point of view, HALFWORDS are an experiment. Use them with the understanding that a redesign of the system datatypes might cause them to be eliminated. TAGGED ITEM CONSTRUCTORS ------------------------ (MkBTR MkID MkFIXN MkFLTN MkBIGN MkPAIR MkVEC MkEVECT MkWRDS MkSTR MkBYTES MkHalfWords MkCODE) Given a machine-integer data part, these return a tagged item of the type suggested by the name of the constructor, with data part same as the argument. TAGGED ITEM COMPONENTS ---------------------- (IDInf StrInf VecInf EvecInf PairInf WrdInf HalfWordInf CodeInf FixInf FltInf BigInf) (PutIDInf PutStrInf PutVecInf PutPairInf PutWrdInf PutHalfWordInf PutEvecInf PutFixInf PutFltInf PutBigInf) Given a machine pointer to an item, these fetch or store the data part of the item pointed to. The value returned by the accessors is in machine format. Note: ByteInf and PutByteInf are missing. (Tag U) Gets the tag part of an item. Clear enough what this does now, but what are its specifications? PREDICATES ON TAGS ------------------ Each of these predicates takes a LISP item as its argument and returns a LISP boolean if used for its value. NOTE: By clever ordering of the values of the type tags, ALL of these tests are comparable in speed. In fact, on the 9836 they may soon all be just about the same speed, so don't hesitate to use the most appropriate one! PAIRP, STRINGP, VECTORP, CODEP, IDP, BYTESP, WRDSP, HALFWORDSP These are all independent predicates on the type of an item. FIXNP, FLOATP, BIGP These are checks for specific sorts of numbers. Testing for FLOATP is probably the most legitimate for use in user code, though see the function FLOAT also. INTP, FIXP, NUMBERP These are related type tests. FIXP and NUMBERP are quite legitimate to use in general user-level programs. INTP tests whether a number is in the "INUM range", that is, is represented directly by an item rather than using space in the heap. If a number is INTP, at present it has the same representation as a machine-integer of the same value. POSINTP, NEGINTP POSINTP checks for a positive INUM (or zero), and NEGINTP checks for a negative INUM. These happen at present to be separate type tags. There are actually even more obscure tags, but these are of very limited use in the author's view. ALLOCATORS AND DEALLOCATORS --------------------------- (GtStr N) Space for a string of upper bound N. Returns a machine pointer. Header is initialized, last byte cleared. (GtConstStr N) Like GtStr, but gets space in BPS (using GtBPS). Used for print name storage of INTERNed IDs. (GtHalfWords N) (GtVect N) (GtEvect N) (GtWrds N) Gets enough heap space for an object of upper bound N and initializes the header. (GtBPS N) Gets N items of BPS (from the bottom). Returns a machine pointer. (DelBPS Bottom Top) Returns the space from bottom up to (not including) top, provided that it is the last space allocated but not deallocated (stack-like). (GtWarray N) Gets N words of BPS, but from the opposite end to GtBPS. (DelWarray Bottom Top) Returns WArray space like DelBPS does BPS. UPPER BOUNDS OF COMPOUND TYPES ------------------------------ (StrLen ByteLen VecLen EVecLen WrdLen HalfWordLen) Given a machine pointer to an object of the suggested type, returns the upper bound on indexes permitted for the object. ELEMENT RETRIEVAL ----------------- (StrByte U N) U is a machine pointer to a string. Retrieves the Nth byte. (VecItm U N) (EVecItm U N) (WrdItm U N) (HalfWordItem U N) Returns the Nth element given a machine pointer U. WHAT? ----- (StrBase U) Pointer to string translated to pointer to beginning of data part which can be accessed via Byte. So what about VectBase, etc.? FIXNUMS AND FLOATNUMS --------------------- (FixVal U) Gets the data part of a fixnum. DO WE REALLY BELIEVE THIS STUFF ABOUT FLOATNUMS? (FloatBase U) Pointer to first word of data part of floatnum. (FloatHighOrder U) Gets high order part of floatnum representation. (FloatLowOrder U) Gets low order part of floatnum representation. (%code-number-of-arguments U) Gets the number of arguments information given a code pointer to a routine. ULTRAPRIMITIVES --------------- The following functions appear in some system code, but are usually not needed even by system-level programmers because other slightly higher-level functions exist to serve most needs. One would use them if writing a new garbage collector, for example. (GtHeap N) Ultraprimitive. Gets N items from the heap. Returns a machine pointer. If an appropriate header is not installed in those words immediately the heap could be left in an inconsistent state and the garbage collector might break. (PairPack dum) Number of items in the representation of a pair. (StrPack N) (VectPack N) (EVectPack N) (WrdPack N) (HalfWordPack N) Number of items required to be allocated for data part of object of N+1 elements (upper bound of N). Many of these suffer from "off by one" errors in the conservative direction. Note: BytePack is missing. |
Added psl-1983/3-1/doc/pslmac.lib version [7059627ea4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Marker(Library,PSLMacrosNames) @comment{ <GRISS>PSLMAC.LIB.2, by Griss, from} @comment{ <MAGUIRE>LOCALM.LIB.2, 13-May-82 05:46:06, Edit by MAGUIRE} @comment{ Started by G. Q. Maguire Jr. on 13.5.82 } @comment{ Various assorted commonly used macros for Local languages and papers, so they look consistent. } @comment{ Commonly used and abused words} @Commandstring(Dec20="DECSystem-20") @Commandstring(VAX750="VAX 11/750") @Commandstring(Apollo="Apollo DOMAIN") @Commandstring(68000="Motorola MC68000") @Commandstring(Wicat="Wicat System 100") @Commandstring(PSL="@r[PSL]") @comment{ The Short version of the names } @Commandstring(sDec20="DEC-20") @Commandstring(sVAX750="VAX 11/750") @Commandstring(sApollo="Apollo") @Commandstring(s68000="MC68000") @Commandstring(sWicat="Wicat") @comment[to be set spacially] @Commandstring(cmacro="c-macro") @Commandstring(anyreg="anyreg") @TextForm(TM="@+[TM]@Foot[Trademark of @parm(text)]") @comment{ Favorite Abbreviations and macros } @Commandstring(xs = "s") @Comment{Plural for abbrevs} @Commandstring(xlisp = "@r[L@c[isp]]") @Commandstring(xlisps = "@xlisp systems") @Commandstring(Franzlisp = "@r[F@c[ranz]]@xlisp") @Commandstring(CommonLisp = "@r[C@c[ommon ]]@xlisp") @Commandstring(lmlisp = "@r[Lisp Machine @xlisp]") @Commandstring(newlisp = "@r[N@c[il]]") @Commandstring(slisp = "@r[S@c[pice]] @xlisp") @Commandstring(maclisp = "@r[M@c[ac]]@xlisp") @Commandstring(interlisp = "@r[I@c[nter]]@xlisp") @Commandstring(rlisp = "@r[R]@xlisp") @Commandstring(picturerlisp = "@r[P@c[icture]]@rlisp") @Commandstring(emode = "@r[E@c[mode]]") @Commandstring(syslisp = "@r[S@c[ys]]@xlisp") @Commandstring(stdlisp = "@r[S@c[tandard]] @xlisp") @Commandstring(macsyma = "@r[MACSYMA]") @Commandstring(reduce = "@r[REDUCE]") @Commandstring(fortran = "@r[FORTRAN]") @Comment[ Set Alpha_1 logo properly on the Omnitech ] @Case(GenericDevice, Omnitech < @Define(FSS,Script -0.2 lines,Size 14) @CommandString(Alpha1="A@c(LPHA)@FSS(-)1") @commandstring(LTS="@value(LT)") @commandstring(EQS="@value(EQ)") @commandstring(PLS="@value(PLUSSIGN)") >, Else < @CommandString(Alpha1="Alpha_1") @commandString(PLS="+") @commandstring(EQS="=") @commandstring(LTS="<") >) @comment{ Do the Ada, UNIX, etc. TradeMark stuff } @Case(GenericDevice, Omnitech < @Define(Marks,Script +.5 lines, Size -5) @CommandString(TMS="@Marks(TM)") >, Else < @CommandString(TMS="@+(TM)") >) @CommandString(ADA="Ada@TMS") @CommandString(UNIX="UNIX@TMS") @Case(GenericDevice, Omnitech {@TextForm<EI=[@i(@Parm(text))]>}, else {@TextForm<EI=[@DQ(@Parm(Text))]>} ) |
Added psl-1983/3-1/full-logical-names.cmd version [547a6733f7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Officially recognized logical names for FULL set of ; PSL subdirectories on UTAH-20 for V3 PSL distribution ; EDIT <PSL to your <name define psl: <psl> ! Executable files and miscellaneous define pc: <psl.comp> ! Compiler sources define p20c: <psl.comp.20> ! 20 Specific Compiler sources define pdist: <psl.dist> ! Distribution files define pd: <psl.doc> ! Documentation files define p20d: <psl.doc.20> ! 20 Specific Documentation define pndoc: <psl.doc.nmode> ! NMODE Documentation files ; not distributed anymore define pe: <psl.emode> ! EMODE support and drivers define pg: <psl.glisp> ! Glisp sources define ph: <psl.help> ! Help files define pk: <psl.kernel> ! Kernel Source files define p20k: <psl.kernel.20> ! 20 Specific Kernel Sources define pl: <psl.lap> ! LAP files define plpt: <psl.lpt> ! Printer version of Documentation define pn: <psl.nmode> ! NMODE editor files define pnb: <psl.nmode.binary> ! NMODE editor binaries define pnk: <psl.nonkernel> ! PSL Non Kernel source files define pt: <psl.tests> ! Test files define p20t: <psl.tests.20> ! 20 Specific Test files define pu: <psl.util> ! Utility program sources define p20u: <psl.util.20> ! 20 Specific Utility files define pw: <psl.windows> ! NMODE Window files define pwb: <psl.windows.binary>! NMODE Window binaries take |
Added psl-1983/3-1/full-restore.ctl version [e17259b24c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve ALL ssnames for FULL PSL system ; First edit FULL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories ; then mount TAPE, def X: @TERM PAGE 0 @DUMPER *tape X: *density 1600 *files *account system-default *; --- Skip over the logical names etc to do the restore. *skip 1 *restore dsk*:<*>*.*.* PSL:*.*.* *restore dsk*:<*>*.*.* PC:*.*.* *restore dsk*:<*>*.*.* P20C:*.*.* *restore dsk*:<*>*.*.* PDIST:*.*.* *restore dsk*:<*>*.*.* PD:*.*.* *restore dsk*:<*>*.*.* P20D:*.*.* *restore dsk*:<*>*.*.* PNDOC:*.*.* ; not distributed anymore *restore dsk*:<*>*.*.* PE:*.*.* *restore dsk*:<*>*.*.* PG:*.*.* *restore dsk*:<*>*.*.* ph:*.*.* *restore dsk*:<*>*.*.* pk:*.*.* *restore dsk*:<*>*.*.* p20:*.*.* *restore dsk*:<*>*.*.* pl:*.*.* *restore dsk*:<*>*.*.* plpt:*.*.* *restore dsk*:<*>*.*.* pn:*.*.* *restore dsk*:<*>*.*.* pnb:*.*.* *restore dsk*:<*>*.*.* pnk:*.*.* *restore dsk*:<*>*.*.* pT:*.*.* *restore dsk*:<*>*.*.* p20T:*.*.* *restore dsk*:<*>*.*.* pu:*.*.* *restore dsk*:<*>*.*.* p20u:*.*.* *restore dsk*:<*>*.*.* pw:*.*.* *restore dsk*:<*>*.*.* pwb:*.*.* |
Added psl-1983/3-1/glisp/circle.sl version [9105140291].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % CIRCLE.SL.3 31 Jan. 83 % Test program to draw a circle on a graphics screen. % G. Novak (DG CIRCLE (XSTART:integer YSTART:integer RADIUS:INTEGER) % (* edited: "19-MAR-82 16:31") % (* Draw a circle incrementally.) (PROG (X Y YLAST DELTA NP2) (X_RADIUS) (Y_0) (DELTA_0) (WHILE Y<X DO (YLAST_Y) (DELTA _+ X + X - 1) (WHILE DELTA>0 DO (DELTA _- Y+Y+1) (Y_+1)) (NP2 _(Y - YLAST + 1)/2) (WHILE NP2>0 DO (NP2_-1) (DRAWCIRCLEPOINT X YLAST XSTART YSTART) (YLAST_+1)) (X_-1) (WHILE YLAST<Y DO (DRAWCIRCLEPOINT X YLAST XSTART YSTART) (YLAST_+1))))) % for testing: (de drawcirclepoint (x y xstart ystart) (prin1 x)(prin2 '! )(print y)) (dg oldDRAWCIRCLEPOINT (X:integer Y:integer XSTART:integer YSTART:INTEGER) % (* edited: "19-MAR-82 15:40") (BITMAPBIT XSTART+X YSTART+Y 1) (BITMAPBIT (XSTART - X) YSTART+Y 1) (BITMAPBIT (XSTART - X) (YSTART - Y) 1) (BITMAPBIT XSTART+X (YSTART - Y) 1) (BITMAPBIT XSTART+Y YSTART+X 1) (BITMAPBIT XSTART+Y (YSTART - X) 1) (BITMAPBIT (XSTART - Y) YSTART+X 1) (BITMAPBIT (XSTART - Y) (YSTART - X) 1)) |
Added psl-1983/3-1/glisp/crt.sl version [81c18a8d23].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % CRT.SL.14 07 April 83 % derived from <NOVAK>H19.PSL.1 20-Mar-83 12:40:06 % Written by Gordon Novak Jr. % Copyright (c) 1983 Hewlett-Packard (GLOBAL '(TERMINAL)) (GLISPOBJECTS (TERMINAL ATOM MSG ((MOVETOXY TERMINAL-MOVETOXY) (PRINTCHAR TERMINAL-PRINTCHAR OPEN T) (PRINTSTRING TERMINAL-PRINTSTRING) (INVERTVIDEO (nil)) (NORMALVIDEO (nil)) (GRAPHICSMODE (nil)) (NORMALMODE (nil)) (ERASEEOL ((PBOUT (CHAR ESC)) (PBOUT (char K)))))) ) (GLISPGLOBALS (TERMINAL TERMINAL) ) (GLISPCONSTANTS (BLANKCHAR 32 integer) (HORIZONTALLINECHAR 45 integer) (HORIZONTALBARCHAR 95 integer) (LVERTICALBARCHAR 124 integer) (RVERTICALBARCHAR 124 integer) (escapechar 27 INTEGER) ) % edited: 14-Mar-83 22:48 % Move cursor to a specified X Y position. (DG TERMINAL-MOVETOXY (TERM:TERMINAL X:INTEGER Y:INTEGER) (IF X<0 THEN X_0 ELSEIF X>79 X_79)(IF Y<0 THEN Y_0 ELSEIF Y>23 THEN Y_23)(SEND TERMINAL PRINTCHAR (CHAR ESC))(SEND TERMINAL PRINTCHAR (char Y))(SEND TERMINAL PRINTCHAR (55 - Y))(SEND TERMINAL PRINTCHAR (32 + X))) % edited: 19-Mar-83 20:29 (DG TERMINAL-PRINTCHAR (TERM:TERMINAL S:STRING) (PBOUT S)) % edited: 19-Mar-83 20:29 (DG TERMINAL-PRINTSTRING (TERM:TERMINAL S:STRING) (prog (i n) (if s is not a string then (S _ (gevstringify s))) (n _ s:length) (i _ 0) (while (i<n) do (pbout (indx s i)) (i _+ 1)) )) (SETQ TERMINAL 'VT52) |
Added psl-1983/3-1/glisp/gev.hlp version [08084b4e7c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | GEV Inspector/Editor for Lisp Data GEV (for GLISP Edit Value) is a display-based program which displays Lisp data in a window according to its GLISP datatype description. The user can "zoom in" on data of interest, display computed properties of objects by menu selection, send messages to objects, and write looping programs interactively using menu selection. GEV is available for Interlisp-D and for Interlisp-10 using a Heath-19 terminal. A demonstration file for GEV is available. From Interlisp, enter LOAD(<GLISP>GEVLOAD.LSP); then try (GEV C 'CIRCLE) and (GEV HPP 'PROJECT). The commands which can be entered at the "GEV:" prompt are as follows: Q Quit. POP Pop up to the earlier GEV edit window. E Edit the current item using the Lisp editor. PR Write a looping program using menu selection. P Display a menu of computed PROPerties for selection. A Display a menu of ADJectives for selection. I Display a menu of ISA adjectives for selection. M Display a menu of Messages to the object for selection. R Redraw the current window. T n Print the data type of item n. n Push down to "zoom in" on data item n. When a menu option is selected, a separate menu is displayed and a "Menu:" prompt is given. Menu selections are made by entering the number of the desired menu item (followed by a carriage return). "Q" may be entered instead of a number to leave the menu mode without making any selection. The data used for the demonstration is contained in the file GEVDEMO.LSP. Documentation on GEV is contained in HPP Memo HPP-82-34, copies of which may be obtained in MJH 225. While designed for use with GLISP, GEV may be used for any Lisp data which is described by a GLISP structure description. |
Added psl-1983/3-1/glisp/gev.old version [89d05b5777].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GEV.PSL;2 25-MAR-83 11:36:28 (FLUID '(GLNATOM RESULT Y)) (GLOBAL '(GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)) % GEV Structure Inspector % The following files are required: VECTOR GEVAUX WINDOW (GLISPGLOBALS (GEVACTIVEFLG BOOLEAN) (GEVEDITCHAIN EDITCHAIN) (GEVEDITFLG BOOLEAN) (GEVLASTITEMNUMBER INTEGER) (GEVMENUWINDOW WINDOW) (GEVMENUWINDOWHEIGHT INTEGER) (GEVMOUSEAREA MOUSESTATE) (GEVSHORTCHARS INTEGER) (GEVWINDOW WINDOW) (GEVWINDOWY INTEGER) ) (GLISPCONSTANTS (GEVMOUSEBUTTON 4 INTEGER) (GEVNAMECHARS 11 INTEGER) (GEVVALUECHARS 27 INTEGER) (GEVNAMEPOS (GEVNUMBERPOS + (IF GEVNUMBERCHARS > 0 THEN (GEVNUMBERCHARS + 1) *WINDOWCHARWIDTH ELSE 0)) INTEGER) (GEVTILDEPOS (GEVNAMEPOS + (GEVNAMECHARS+1) *WINDOWCHARWIDTH) INTEGER) (GEVVALUEPOS (GEVTILDEPOS + 2*WINDOWCHARWIDTH) INTEGER) ) (GLISPOBJECTS (EDITCHAIN (LISTOF EDITFRAME) PROP ((TOPFRAME ((CAR self))) (TOPITEM ((CAR TOPFRAME:PREVS))))) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) (SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM)))) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) (SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP ((NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))))) (MOUSESTATE (LIST (AREA REGION) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER))) ) % GSN 9-FEB-83 11:40 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DF GEV (ARGS) (GEVA (CAR ARGS) (EVAL (CAR ARGS)) (AND (CDR ARGS) (COND ((OR (NOT (ATOM (CADR ARGS))) (NOT (UNBOUNDP (CADR ARGS)))) (EVAL (CADR ARGS))) (T (CADR ARGS)))))) % edited: 15-MAR-83 10:40 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DG GEVA (VAR VAL STR) (PROG (GLNATOM TMP HEADER) (GEVENTER) (COND ((OR (NOT (NOT (UNBOUNDP 'GEVWINDOW))) (NULL GEVWINDOW)) (GEVINITEDITWINDOW))) (IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW OPEN)) (SEND GEVWINDOW OPEN) (GEVACTIVEFLG_T) (GEVEDITFLG_NIL) (GLNATOM_0) (GEVSHORTCHARS_GEVVALUECHARS) (IF VAR IS A LIST AND (CAR VAR) ='QUOTE THEN VAR_ (CONCAT "'" (GEVSTRINGIFY (CADR VAR)))) (IF ~STR THEN (IF VAL IS ATOMIC AND (GET VAL 'GLSTRUCTURE) THEN STR_'GLTYPE ELSEIF (GEVGLISPP) THEN STR_ (GLCLASS VAL))) (HEADER_ (A GSEITEM WITH NAME = VAR VALUE = VAL TYPE = STR)) (GEVEDITCHAIN_ (LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) (GEVMOUSELOOP) (GEVEXIT))) % GSN 2-MAR-83 14:06 (DG GEVCOMMANDFN (COMMANDWORD:ATOM) (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASE COMMANDWORD OF (EDIT (GEVEDIT)) (QUIT (IF GEVMOUSEAREA THEN (SEND GEVWINDOW INVERTAREA GEVMOUSEAREA:AREA) (GEVMOUSEAREA_NIL) ELSE (GEVQUIT))) (POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) ELSE (ERROR 0 NIL)))) % GSN 25-MAR-83 10:14 (DG GEVCOMMANDPROP (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) (PROG (VAL PROPNAMES FLG) (IF PROPNAME THEN FLG_T) (IF ITEM:TYPE IS ATOMIC THEN (PROPNAMES_ (GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME))) (IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP THEN (IF COMMANDWORD='PROP THEN (IF (CDR PROPNAMES) THEN PROPNAMES+_'All) PROPNAMES+_'self) (IF ~PROPNAMES (RETURN NIL)) (IF ~PROPNAME (PROPNAME _ (SEND (A MENU WITH ITEMS = PROPNAMES) SELECT))) (IF ~PROPNAME (RETURN NIL) ELSEIF PROPNAME='self THEN (PRIN1 PROPNAME) (PRINC " = ") (PRINT ITEM:VALUE) ELSEIF COMMANDWORD='PROP AND PROPNAME='All THEN (FOR X IN (OR (CDDR PROPNAMES) (CDR PROPNAMES)) DO (GEVDOPROP ITEM X COMMANDWORD FLG)) ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG)) (IF COMMANDWORD='MSG THEN (GEVREFILLWINDOW) (GEVEDITFLG_T))))) % edited: 22-DEC-82 11:09 % Get all property names of properties of type PROPTYPE for OBJ. % Properties are filtered to remove system properties and those % which are already displayed. (DG GEVCOMMANDPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN ~ (PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME = (CAR P))) AND ~ (PROPTYPE='PROP AND (MEMQ (CAR P) '(SHORTVALUE DISPLAYPROPS) )) AND ~ (PROPTYPE='MSG AND (CADR P) IS ATOMIC AND (~ (GETDDD (CADR P)) OR (LENGTH (CADR (GETDDD (CADR P)))) >1)) COLLECT P:NAME)) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME)))) (RETURN RESULT))) % GSN 2-MAR-83 10:42 % Compile a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVCOMPPROP (STR:GLTYPE PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (RETURN 'GEVERROR)) % If the property is implemented by a named function, return the % function name. (IF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC THEN (RETURN (CADR PROPENT))) % Compile code for this property and save it. First be sure the GLISP % compiler is loaded. (RETURN (COND ((GEVGLISPP) (GLCOMPPROP STR PROPNAME PROPTYPE) OR 'GEVERROR) (T (ERROR 0 (LIST "GLISP compiler must be loaded for PROPs which" "are not specified with function name equivalents." STR PROPTYPE PROPNAME))))))) % edited: 4-NOV-82 16:08 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (RESULT) (GEVDATANAMESB OBJ:STRDES FILTER) (RETURN (REVERSIP RESULT)))) % GSN 4-FEB-83 17:39 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMESB (STR:ANYTHING FILTER:ATOM) (GLOBAL RESULT)(PROG (TMP) (IF STR IS ATOMIC THEN (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER))) (RECORD (FOR X IN (CDDR STR) DO (GEVDATANAMESB X FILTER))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) (LISTOF (RETURN NIL)) ELSE (IF (GEVFILTER (CADR STR) FILTER) THEN (RESULT +_ (LIST (CAR STR) (CADR STR)))) (GEVDATANAMESB (CADR STR) FILTER))))) % GSN 25-MAR-83 09:48 % Display a newly added property in the window. (DG GEVDISPLAYNEWPROP NIL (PROG (Y NEWONE:GSEITEM) (Y_GEVWINDOWY) (NEWONE_ (CAR (LASTPAIR GEVEDITCHAIN:TOPFRAME:PROPS))) (GEVPPS NEWONE 0 GEVWINDOW) (GEVWINDOWY_Y))) % GSN 4-FEB-83 16:58 % Add the property PROPNAME of type COMMANDWORD to the display for % ITEM. (DG GEVDOPROP (ITEM:GSEITEM PROPNAME:ATOM COMMANDWORD:ATOM FLG:BOOLEAN) (PROG (VAL) (VAL_ (GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL)) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = PROPNAME TYPE = (GEVPROPTYPE ITEM:TYPE PROPNAME COMMANDWORD) VALUE = VAL NODETYPE = COMMANDWORD)) (IF ~FLG THEN (GEVDISPLAYNEWPROP)))) % GSN 25-MAR-83 09:48 % Edit the currently displayed item. (DG GEVEDIT NIL (PROG (CHANGEDFLG GEVTOPITEM) (GEVTOPITEM_GEVEDITCHAIN:TOPITEM) (IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE 'EDIT 'MSG NIL) ~='GEVERROR THEN CHANGEDFLG_T ELSEIF GEVTOPITEM:VALUE IS A LIST THEN (EDITV GEVTOPITEM:VALUE) (CHANGEDFLG_T) ELSE (RETURN NIL)) (IF CHANGEDFLG THEN (SEND GEVWINDOW OPEN) (GEVREFILLWINDOW)) (GEVEDITFLG_CHANGEDFLG))) % GSN 25-MAR-83 09:49 % Execute a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE on the object OBJ whose type is % STR. (DG GEVEXPROP (OBJ STR PROPNAME:ATOM PROPTYPE:ATOM ARGS) (PROG (FN) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) OR (ARGS AND PROPTYPE~='MSG) (RETURN 'GEVERROR)) (IF (FN_ (GEVCOMPPROP STR PROPNAME PROPTYPE)) ='GEVERROR THEN (RETURN FN) ELSE (RETURN (GEVAPPLY FN (CONS OBJ ARGS)))))) % edited: 15-MAR-83 12:40 % Fill the GEV editor window with the item which is at the top of % GEVEDITCHAIN. (DG GEVFILLWINDOW NIL (PROG (Y TOP) (SEND GEVWINDOW CLEAR) % Compute an initial Y value for printing titles in the window. (Y_GEVWINDOW:HEIGHT - WINDOWLINEYSPACING) % Print the titles from the edit chain first. (GEVLASTITEMNUMBER _ 0) (TOP_GEVEDITCHAIN:TOPFRAME) (FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:SUBITEMS DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:PROPS DO (GEVPPS X 0 GEVWINDOW)) (GEVWINDOWY_Y))) % GSN 21-JAN-83 10:24 % Filter types according to a specified FILTER. (DG GEVFILTER (TYPE FILTER) (TYPE_ (GEVXTRTYPE TYPE))(CASE FILTER OF (NUMBER ~ (MEMQ TYPE '(ATOM STRING BOOLEAN ANYTHING)) AND ~ ((PAIRP TYPE) AND (CAR TYPE) ='LISTOF)) (LIST (PAIRP TYPE) AND (CAR TYPE) ='LISTOF) ELSE T)) % edited: 14-OCT-82 11:32 (DG GEVFINDITEMPOS (POS:VECTOR ITEM:GSEITEM N:INTEGER) (RESULT MOUSESTATE) % Test whether ITEM contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N) (GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N) ((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF) AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N)))) % edited: 13-OCT-82 12:03 (DG GEVFINDLISTPOS (POS:VECTOR ITEMS: (LISTOF GSEITEM) N) (RESULT MOUSESTATE) % Find some ITEM corresponding to the mouse position POS. (IF ITEMS THEN (GEVFINDITEMPOS POS (CAR ITEMS) N) OR (GEVFINDLISTPOS POS (CDR ITEMS) N))) % edited: 13-OCT-82 12:06 (DG GEVFINDPOS (POS:VECTOR FRAME:EDITFRAME) (RESULT MOUSESTATE) % Find the sub-item of FRAME corresponding to the mouse position POS. % The result is NIL if not found, else a list of the sub-item and a % flag which is NIL if the NAME part is identified, T if the VALUE % part is identified. (PROG (TMP N ITEMS: (LISTOF gseitem)) (N_0) (WHILE FRAME AND ~TMP DO (N_+1) ITEMS-_FRAME (TMP_ (GEVFINDLISTPOS POS ITEMS N))) (RETURN TMP))) % edited: 22-DEC-82 14:53 % Get all names of properties and stored data from a GLISP object % type. (DG GEVGETNAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES (GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ 'PROP FILTER)) (RETURN (NCONC DATANAMES PROPNAMES)))) % GSN 4-FEB-83 16:59 % Retrieve a GLISP property whose name is PROPNAME and whose property % type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVGETPROP (STR PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (ERROR 0 NIL)) (RETURN (AND (PL_ (GET STR 'GLSTRUCTURE)) (SUBPL_ (LISTGET (CDR PL) PROPTYPE)) (PROPENT_ (ASSOC PROPNAME SUBPL)))))) % edited: 11-NOV-82 15:53 (DE GEVGLISPP NIL (NOT (UNBOUNDP 'GLBASICTYPES))) % edited: 14-MAR-83 16:41 (DG GEVHORIZLINE (W:WINDOW) (GLOBAL Y:INTEGER) % Draw a horizontal line across window W at Y and decrease Y. (SEND W DRAWLINE (A VECTOR WITH X = W:LEFTMARGIN Y = Y+WINDOWLINEYSPACING/2) (A VECTOR WITH X = W:RIGHTMARGIN Y = Y+WINDOWLINEYSPACING/2))( Y_-WINDOWLINEYSPACING)) % edited: 11-MAR-83 16:03 (DE GEVINIT NIL (SETQ GLNATOM 0)(COND ((NOT (NOT (UNBOUNDP 'GLLISPDIALECT))) (SETQ GLLISPDIALECT 'INTERLISP)))(SETQ GEVWINDOW NIL)) % GSN 25-MAR-83 10:14 % Respond to an event which selects an item. GROUP gives the group in % which the item occurs. 1 = edit path. FLAG is T if the type of the % item is selected, NIL if the value is selected. (DG GEVITEMEVENTFN (ITEM:GSEITEM GROUP:INTEGER FLAG:BOOLEAN) (PROG (TMP TOP N) (IF FLAG THEN (IF GROUP=1 THEN (TMP_GEVEDITCHAIN:TOPFRAME:PREVS) (N_0) (WHILE TMP AND (TOP-_TMP) <>ITEM DO N_+1) (GEVPOP NIL N) ELSE (GEVPUSH ITEM)) ELSE (PRIN1 ITEM:NAME) (PRINC " is ") (PRIN1 ITEM:TYPE) (TERPRI)))) % GSN 2-MAR-83 16:14 % Bound the length of VAL to NCHARS. (DG GEVLENGTHBOUND (VAL NCHARS) (COND ((GREATERP (FlatSize2 VAL) NCHARS) ((SUBSTRING VAL 1 (SUB1 NCHARS)) + "-")) (T VAL))) % GSN 2-MAR-83 16:33 % Make a function to perform OPERATION on set SETNAME from INPUTTYPE % following PATH to get to the data. (DG GEVMAKENEWFN (OPERATION:ATOM INPUTTYPE:ATOM SET: (LIST (NAME ATOM) (TYPE GLTYPE)) PATH: (LISTOF (LIST (NAME ATOM) (TYPE GLTYPE)))) (PROG (LASTPATH) (SETQ LASTPATH (CAR (LASTPAIR PATH))) (RETURN (LIST (LIST 'GLAMBDA (LIST (MKATOM (CONCAT "GEVNEWFNTOP:" INPUTTYPE:PNAME))) (LIST 'PROG (CONS 'GEVNEWFNVALUE (CASE OPERATION OF (COLLECT '(GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (TOTAL '((GEVNEWFNSUM 0))) (AVERAGE '((GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0))) ELSE (ERROR 0 NIL))) (NCONC (LIST 'FOR 'GEVNEWFNLOOPVAR 'IN (MKATOM (CONCAT "GEVNEWFNTOP:" SET:NAME:PNAME)) 'DO (LIST 'GEVNEWFNVALUE '_ (REVERSIP (CONS 'GEVNEWFNLOOPVAR (MAPCAN PATH (FUNCTION (LAMBDA (X) (LIST 'OF (CAR X) 'THE)))))))) (COPY (CASE OPERATION OF (COLLECT '((GEVNEWFNRESULT +_ GEVNEWFNVALUE))) (MAXIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR)))) (MINIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR)))) (AVERAGE '((GEVNEWFNSUM _+ GEVNEWFNVALUE) (GEVNEWFNCOUNT _+ 1))) (TOTAL '((GEVNEWFNSUM _+ GEVNEWFNVALUE)))))) (LIST 'RETURN (CASE OPERATION OF (COLLECT '(DREVERSE GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (AVERAGE '(QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT))) (TOTAL 'GEVNEWFNSUM))))) (CASE OPERATION OF (COLLECT (LIST 'LISTOF (CADR LASTPATH))) ((MAXIMUM MINIMUM) (LIST 'LIST (COPY LASTPATH) (LIST 'WINNER (CADR SET:TYPE)))) (AVERAGE 'REAL) (TOTAL (CADR LASTPATH))))))) % edited: 8-OCT-82 10:43 (DG GEVMATCH (STR VAL FLG) (RESULT (LISTOF GSEITEM)) % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) (RETURN (REVERSIP RESULT)))) % edited: 8-OCT-82 10:01 % Make a single item which matches structure STR and value VAL. (DG GEVMATCHA (STR VAL FLG) (PROG (RES) (RES_ (GEVMATCH STR VAL FLG)) (IF ~ (CDR RES) THEN (RETURN (CAR RES)) ELSE (RETURN (A GSEITEM WITH VALUE = VAL TYPE = STR SUBVALUES = RES NODETYPE = 'SUBTREE))))) % edited: 7-OCT-82 16:38 % Match an ATOM structure to a given value. (DG GEVMATCHATOM (STR VAL NAME) (PROG (L STRB TMP) (IF VAL IS NOT ATOMIC OR VAL IS NULL THEN (RETURN NIL)) (STRB_ (CADR STR)) (IF (CAR STRB) ~='PROPLIST THEN (RETURN NIL)) (L_ (CDR STRB)) (FOR X IN L DO (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 7-OCT-82 16:57 % Match an ALIST structure to a given value. (DG GEVMATCHALIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (ASSOC (CAR X) VAL) THEN (GEVMATCHB X (CDR TMP) NIL NIL))))) % edited: 22-DEC-82 15:26 % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. If % FLG is set, the match will descend inside an atomic type name. % Results are added to the free variable RESULT. (DG GEVMATCHB (STR: (LISTOF ANYTHING) VAL NAME:ATOM FLG:BOOLEAN) (GLOBAL RESULT)(PROG (X Y STRB XSTR TOP TMP) (XSTR_ (GEVXTRTYPE STR)) (IF STR IS ATOMIC THEN (IF FLG AND (STRB _ (CAR (GET STR 'GLSTRUCTURE))) THEN (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = (GEVMATCH STRB VAL NIL) TYPE = STR NODETYPE = 'STRUCTURE)) ELSE (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB (CADDR STR) (CDR VAL) NIL NIL)) (LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL) NIL NIL) (VAL_ (CDR VAL))))) (ATOM (GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST (GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) (RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) (GEVMATCHOBJECT STR VAL NAME)) ELSE (IF NAME THEN (TMP _ (GEVMATCH STR VAL NIL)) (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN ( TOP:NAME_NAME) TOP ELSE (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = TMP TYPE = XSTR NODETYPE = 'SUBTREE))) ELSEIF (STRB _ (GEVXTRTYPE (CADR STR))) IS ATOMIC THEN (GEVMATCHB STRB VAL (CAR STR) NIL) ELSEIF (TMP_ (GEVMATCH (CADR STR) VAL NIL)) THEN (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN (TOP:NAME_ (CAR STR)) TOP ELSE (A GSEITEM WITH NAME = (CAR STR) VALUE = VAL SUBVALUES = TMP TYPE = (CADR STR) NODETYPE = 'SUBTREE))) ELSE (PRINT "GEVMATCHB Failed")))))) % edited: 8-OCT-82 10:15 % Match a LISTOF structure. (DG GEVMATCHLISTOF (STR VAL NAME) (GLOBAL RESULT)(RESULT+_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) % edited: 22-DEC-82 10:04 % Match the OBJECT structures. (DG GEVMATCHOBJECT (STR VAL NAME) (GLOBAL RESULT)(PROG (OBJECTTYPE TMP) (SETQ OBJECTTYPE (CAR STR)) (RESULT _+ (A GSEITEM WITH NAME = 'CLASS VALUE = (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (TMP-_VAL)) (ATOMOBJECT (GET VAL 'CLASS))) TYPE = 'GLTYPE)) (FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (IF VAL (GEVMATCHB X (TMP-_VAL) NIL NIL))) (ATOMOBJECT (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))))) % edited: 24-NOV-82 16:31 % Match an PROPLIST structure to a given value. (DG GEVMATCHPROPLIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (LISTGET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 11-MAR-83 16:31 % Match a RECORD structure. (DG GEVMATCHRECORD (STR VAL NAME) (PROG (STRNAME FIELDS N) (IF (CADR STR) IS ATOMIC THEN STRNAME_ (CADR STR) FIELDS_ (CDDR STR) ELSE FIELDS_ (CDR STR)) (N_0) (FOR X IN FIELDS DO (N_+1) (GEVMATCHB X (GetV VAL N) (CAR X) NIL)))) % GSN 2-MAR-83 17:33 % Pop up from the current item to the previous one. If FLG is set, % popping continues through extended LISTOF elements. (DG GEVPOP (FLG:BOOLEAN N:INTEGER) (PROG (TMP TOP:GSEITEM TMPITEM) (IF N<1 (RETURN NIL)) LP (TMP-_GEVEDITCHAIN) (IF ~GEVEDITCHAIN THEN (RETURN (GEVQUIT))) (TOP_ (CAAAR GEVEDITCHAIN)) % Test for repeated LISTOF elements. (TMPITEM_ (CAR TMP:PREVS)) (IF FLG AND TMPITEM:NODETYPE='FORWARD THEN (GO LP)) (IF (N_-1) >0 THEN (GO LP)) (IF TOP:TYPE IS A LIST AND (CAR TOP:TYPE) ='LISTOF AND ~ (CDR TOP:VALUE) THEN (GO LP)) (IF GEVEDITFLG AND ~ (MEMBER TMPITEM:SHORTVALUE '("(...)" "---")) THEN (GEVREFILLWINDOW) ELSE GEVEDITFLG_NIL (GEVFILLWINDOW)))) % edited: 11-MAR-83 15:06 (DG GEVPOSTEST (POS:VECTOR TPOS:VECTOR NAME:STRING ITEM:GSEITEM FLG N:INTEGER) (RESULT MOUSESTATE) % Test whether TPOS contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+WINDOWLINEYSPACING AND POS:X>=TPOS:X AND POS:X<TPOS:X+GEVNAMECHARS*WINDOWCHARWIDTH THEN (A MOUSESTATE WITH AREA = (A REGION WITH START = (A VECTOR WITH X = TPOS:X Y = TPOS:Y - 1) SIZE = (A VECTOR WITH X = WINDOWCHARWIDTH*NAME:LENGTH Y = WINDOWLINEYSPACING)) ITEM = ITEM FLAG = FLG GROUP = N))) % edited: 15-MAR-83 12:38 (DG GEVPPS (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) (GLOBAL Y:INTEGER) % Pretty-print a structure defined by ITEM in the window WINDOW, % beginning ar horizontal column COL and vertical position Y. The % positions in ITEM are modified to match the positions in the % window. (PROG (NAMEX TOP) % Make sure there is room in window. (IF Y<0 THEN (RETURN NIL)) (IF GEVNUMBERCHARS>0 THEN (GEVLASTITEMNUMBER _+ 1) (SEND WINDOW PRINTAT (GEVSTRINGIFY GEVLASTITEMNUMBER) (A VECTOR WITH X = GEVNUMBERPOS Y = Y))) % Position in window for slot name. (NAMEX _ GEVNAMEPOS + COL*WINDOWCHARWIDTH) (ITEM:NAMEPOS:X_NAMEX) (ITEM:NAMEPOS:Y_Y) (IF ITEM:NODETYPE='FULLVALUE THEN (SEND WINDOW PRINTAT "(expanded)" (A VECTOR WITH X = NAMEX Y = Y)) ELSEIF ITEM:NAME THEN (IF ITEM:NAME IS NUMERIC THEN (SEND WINDOW PRINTAT "#" (A VECTOR WITH X = NAMEX Y = Y)) (NAMEX_+WINDOWCHARWIDTH)) (SEND WINDOW PRINTAT (GEVLENGTHBOUND ITEM:NAME GEVNAMECHARS) (A VECTOR WITH X = NAMEX Y = Y))) % See if there is a value to print for this name. (IF ~ITEM:NODETYPE OR (MEMQ ITEM:NODETYPE '(FORWARD BACKUP PROP ADJ MSG ISA)) THEN (ITEM:VALUEPOS:X_GEVVALUEPOS) (ITEM:VALUEPOS:Y_Y) (SEND WINDOW PRINTAT (ITEM:SHORTVALUE OR (ITEM:SHORTVALUE _ (GEVSHORTVALUE ITEM:VALUE ITEM:TYPE (GEVSHORTCHARS - COL)))) (A VECTOR WITH X = GEVVALUEPOS Y = Y)) (IF ~ (EQ ITEM:SHORTVALUE ITEM:VALUE) THEN (SEND WINDOW PRINTAT "~" (A VECTOR WITH X = GEVTILDEPOS Y = Y))) (Y_-WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='FULLVALUE THEN (Y_-WINDOWLINEYSPACING) (SEND WINDOW PRETTYPRINTAT ITEM:VALUE (A VECTOR WITH X = WINDOWCHARWIDTH Y = Y)) (Y_WINDOW:YPOSITION - WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='DISPLAY THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE 'GEVDISPLAY 'MSG (LIST WINDOW Y)) ELSE % This is a subtree (Y_-WINDOWLINEYSPACING) (FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW))))) % GSN 25-MAR-83 10:15 % Write an interactive program involving the current item. (DG GEVPROGRAM NIL (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF (COMMAND_ (SEND (A MENU WITH ITEMS = '(Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM)) SELECT)) ='Quit OR ~ COMMAND THEN (RETURN NIL)) (IF (SET_ (GEVPROPMENU TOPITEM:TYPE 'LIST NIL)) ='Quit OR SET='Pop OR ~SET THEN (RETURN NIL)) (PATH_ (LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE))) (NEXT_SET) (TYPE_ (CADADR SET)) (WHILE ~DONE AND ~ABORTFLG DO (NEXT_ (GEVPROPMENU TYPE (COMMAND~='COLLECT AND 'NUMBER) COMMAND='COLLECT)) (CASE NEXT OF ((NIL Quit) (ABORTFLG_T)) (Pop (IF ~ (CDDR PATH) THEN (ABORTFLG_T) ELSE (NEXT-_PATH) (NEXT_ (CAR PATH)) (TYPE_ (CADR NEXT)) (IF TYPE IS A LIST THEN TYPE_ (CADR TYPE)) (LAST_ (CAR NEXT)))) (Done (DONE_T)) ELSE (PROGN (PATH+_NEXT) (TYPE_ (CADR NEXT)) (LAST_ (CAR NEXT)))) (IF (MEMQ TYPE '(ATOM INTEGER STRING REAL BOOLEAN NIL)) DONE_T)) (IF ABORTFLG (RETURN NIL)) (PATH_ (REVERSIP PATH)) (NEWFN_ (GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH))) (GEVPUTD 'GEVNEWFN (CAR NEWFN)) (RESULT_ (GEVNEWFN TOPITEM:VALUE)) % Print result as well as displaying it. (PRIN1 COMMAND) (SPACES 1) (FOR X IN (CDDR PATH) DO (PRIN1 (CAR X)) (SPACES 1)) (PRINC "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) (PRINC " = ") (PRINT RESULT) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = (CONCAT (GEVSTRINGIFY COMMAND) (CONCAT " " (GEVSTRINGIFY LAST))) TYPE = (CADR NEWFN) VALUE = RESULT NODETYPE = 'MSG)) (GEVDISPLAYNEWPROP))) % GSN 21-JAN-83 10:32 % Make a menu to get properties of object OBJ with filter FILTER. FLG % is T if it is okay to stop before reaching a basic type. (DG GEVPROPMENU (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) (PROG (PROPS SEL PNAMES MENU) (PROPS_ (GEVGETNAMES OBJ FILTER)) (IF ~PROPS THEN (RETURN NIL) ELSE (PNAMES_ (MAPCAR PROPS (FUNCTION CAR))) (SEL_ (SEND (A MENU WITH ITEMS = (CONS 'Quit (CONS 'Pop (IF FLG THEN (CONS 'Done PNAMES) ELSE PNAMES)))) SELECT)) (RETURN (CASE SEL OF ((Quit Pop Done NIL) SEL) ELSE (ASSOC SEL PROPS)))))) % GSN 4-FEB-83 17:01 % Get all property names and types of properties of type PROPTYPE for % OBJ when they satisfy FILTER. (DG GEVPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN (TYPE_ (GEVPROPTYPES OBJ P:NAME 'PROP)) AND (GEVFILTER TYPE FILTER) COLLECT (LIST P:NAME TYPE))) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER)))) (RETURN RESULT))) % GSN 4-FEB-83 17:02 % Find the type of a computed property. (DG GEVPROPTYPE (STR:ATOM PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT TMP) (IF STR IS NOT ATOMIC THEN (RETURN NIL) ELSEIF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (TMP_ (LISTGET (CDDR PROPENT) 'RESULT)) THEN (RETURN TMP) ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP_ (GET (CADR PROPENT) 'GLRESULTTYPE)) THEN (RETURN TMP) ELSEIF (AND (PL_ (GET STR 'GLPROPFNS)) (SUBPL_ (ASSOC PROPTYPE PL)) (PROPENT_ (ASSOC PROPNAME (CDR SUBPL))) (TMP_ (CADDR PROPENT))) THEN (RETURN TMP) ELSEIF PROPTYPE='ADJ THEN (RETURN 'BOOLEAN)))) % edited: 4-NOV-82 15:39 (DE GEVPROPTYPES (OBJ NAME TYPE) (OR (GEVPROPTYPE OBJ NAME TYPE) (AND (GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE)))) % GSN 2-MAR-83 17:32 % Push down to look at an item referenced from the current item. (DG GEVPUSH (ITEM:GSEITEM) (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (IF ITEM:NODETYPE='BACKUP THEN (GEVPOP NIL 1) (RETURN NIL)) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF ITEM:NODETYPE='FORWARD THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM T)) ELSEIF ITEM:TYPE IS ATOMIC AND ~ (GET ITEM:TYPE 'GLSTRUCTURE) THEN (CASE ITEM:TYPE OF ((ATOM NUMBER REAL INTEGER STRING ANYTHING) (IF ITEM:VALUE=ITEM:SHORTVALUE THEN (RETURN NIL) ELSE (NEWITEMS_ (LIST (A GSEITEM WITH NAME = ITEM:NAME VALUE = ITEM:VALUE SHORTVALUE = ITEM:SHORTVALUE TYPE = ITEM:TYPE NODETYPE = 'FULLVALUE))))) ELSE (RETURN NIL)) ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM NIL))) (GEVEDITCHAIN+_ (AN EDITFRAME WITH PREVS = (CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS) SUBITEMS = NEWITEMS)) % Do another PUSH automatically for a list of only one item. (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF AND ~ (CDR ITEM:VALUE) THEN (LSTITEM_ (CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN NIL)))) % edited: 11-MAR-83 15:08 % Push into a datum of type LISTOF, expanding it into the individual % elements. If FLG is set, ITEM is a FORWARD item to be continued. (DG GEVPUSHLISTOF (ITEM:GSEITEM FLG:BOOLEAN) (PROG (ITEMTYPE TOPFRAME N:INTEGER NROOM LST VALS: (LISTOF anything) TMP) % Compute the vertical room available in the window. (IF ~ITEM:VALUE (RETURN NIL)) (TOPFRAME_GEVEDITCHAIN:TOPFRAME) (NROOM _ GEVWINDOW:HEIGHT/WINDOWLINEYSPACING - 4 - (LENGTH TOPFRAME:PREVS)) % If there was a previous display of this list, insert an ellipsis % header. (IF FLG THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "(..." NODETYPE = 'BACKUP)) (N_ITEM:NAME) (ITEMTYPE_ITEM:TYPE) (NROOM_-1) (VALS_ITEM:SUBVALUES) ELSE (N_1) (ITEMTYPE_ (CADR ITEM:TYPE)) (VALS_ITEM:VALUE)) % Now make entries for each value on the list. (WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~ (CDR VALS))) DO (LST+_ (A GSEITEM WITH VALUE = (TMP-_VALS) TYPE = ITEMTYPE NAME = N)) (NROOM_-1) (N_+1)) (IF VALS THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "...)" NODETYPE = 'FORWARD TYPE = ITEMTYPE NAME = N SUBVALUES = VALS))) (RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = ITEMTYPE NODETYPE = 'LISTOF SUBVALUES = (REVERSIP LST)))))) % edited: 14-MAR-83 16:46 (DG GEVQUIT NIL (SETQ GEVACTIVEFLG NIL)(SEND GEVWINDOW CLOSE)(IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW CLOSE))) % edited: 19-OCT-82 10:23 % Recompute property values for the item. (DG GEVREDOPROPS (TOP:EDITFRAME) (PROG (ITEM L) (ITEM_ (CAR TOP:PREVS)) (IF ~TOP:PROPS AND (L_ (GEVEXPROP ITEM:VALUE ITEM:TYPE 'DISPLAYPROPS 'PROP NIL)) ~='GEVERROR THEN (IF L IS ATOMIC THEN (GEVCOMMANDPROP ITEM 'PROP 'All) ELSEIF L IS A LIST THEN (FOR X IN L (GEVCOMMANDPROP ITEM 'PROP X))) ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG DO (X:VALUE _ (GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL)) (X:SHORTVALUE _ NIL))))) % edited: 14-OCT-82 12:46 % Re-expand the top item of GEVEDITCHAIN, which may have been changed % due to editing. (DG GEVREFILLWINDOW NIL (PROG (TOP TOPITEM SUBS TOPSUB) (TOP_GEVEDITCHAIN:TOPFRAME) (TOPITEM_GEVEDITCHAIN:TOPITEM) (TOPSUB_ (CAR TOP:SUBITEMS)) (IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF) THEN (IF (GEVGETPROP TOPITEM:TYPE 'GEVDISPLAY 'MSG) THEN (TOP:SUBITEMS_ (LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE TYPE = TOPITEM:TYPE NODETYPE = 'DISPLAY))) ELSE (SUBS_ (GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T)) (TOPSUB_ (CAR SUBS)) (TOP:SUBITEMS_ (IF ~ (CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE AND TOPSUB:VALUE=TOPITEM:VALUE AND TOPSUB:TYPE=TOPITEM:TYPE THEN TOPSUB:SUBVALUES ELSE SUBS)))) (GEVREDOPROPS TOP) (GEVFILLWINDOW))) % edited: 8-OCT-82 15:41 (DE GEVSHORTATOMVAL (ATM NCHARS) (COND ((NUMBERP ATM) (COND ((GREATERP (FlatSize2 ATM) NCHARS) (GEVSHORTSTRINGVAL (MKSTRING ATM) NCHARS)) (T ATM))) ((GREATERP (FlatSize2 ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM))) % GSN 25-MAR-83 10:02 % Compute a short value for printing a CONS of two items. (DG GEVSHORTCONSVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP NC) (RES +_ "(") (NLEFT _ NCHARS - 5) (TMP_ (GEVSHORTVALUE (CAR VAL) (CADR STR) NLEFT - 3)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT - 3 THEN TMP_ "---" NC_3) (RES+_ (GEVSTRINGIFY TMP)) (RES +_ " . ") (NLEFT_-NC) (TMP_ (GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT THEN TMP_ "---" NC_3) (RES+_ (GEVSTRINGIFY TMP)) (RES+_ ")") (RETURN (GEVCONCAT (REVERSIP RES))))) % GSN 25-MAR-83 10:03 % Compute a short value for printing a list of items. (DG GEVSHORTLISTVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (RES +_ "(") (REST_4) (NLEFT _ NCHARS - 2) (RSTR_ (CDR STR)) (WHILE VAL AND ~QUIT AND (NCI_ (IF (CDR VAL) THEN NLEFT - REST ELSE NLEFT)) >2 DO (TMP_ (GEVSHORTVALUE (CAR VAL) (IF (CAR STR) ='LISTOF THEN (CADR STR) ELSEIF (CAR STR) ='LIST THEN (CAR RSTR)) NCI)) (QUIT _ (MEMBER TMP '(GEVERROR "(...)" "---" "???"))) (NC_ (FlatSize2 TMP)) (IF NC>NCI AND (CDR RES) THEN QUIT_T ELSE (IF NC>NCI THEN TMP_ "---" NC_3 QUIT_T) (RES+_ (GEVSTRINGIFY TMP)) (NLEFT_-NC) (VAL_ (CDR VAL)) (RSTR_ (CDR RSTR)) (IF VAL THEN (RES+_ " ") (NLEFT_-1)))) (IF VAL THEN (RES+_ "...")) (RES+_ ")") (RETURN (GEVCONCAT (REVERSIP RES))))) % edited: 12-OCT-82 12:14 % Compute the short value of a string VAL. The result is a string % which can be printed within NCHARS. (DE GEVSHORTSTRINGVAL (VAL NCHARS) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"))) % edited: 11-MAR-83 15:34 % Compute the short value of a given value VAL whose type is STR. The % result is an atom, string, or list structure which can be printed % within NCHARS. (DE GEVSHORTVALUE (VAL STR NCHARS) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) (RETURN (COND ((AND (ATOM STR) (MEMQ STR '(ATOM INTEGER REAL))) (GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR 'STRING) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NE (SETQ TMP (GEVEXPROP VAL STR 'SHORTVALUE 'PROP NIL)) 'GEVERROR)) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) (GEVSHORTSTRINGVAL VAL NCHARS)) ((PAIRP STR) (CASEQ (CAR STR) ((LISTOF LIST) (COND ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND ((PAIRP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) (T "---"))) ((PAIRP VAL) (GEVSHORTLISTVAL VAL '(LISTOF ANYTHING) NCHARS)) (T "---"))))) % edited: 21-OCT-82 11:17 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GEVXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (MEMQ (CAR TYPE) '(A AN a an An TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (NOT (UNBOUNDP GLUSERSTRNAMES)) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR 0 (LIST 'GEVXTRTYPE (LIST TYPE "is an illegal type specification."))) NIL))) (SETQ GEVTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) |
Added psl-1983/3-1/glisp/gev.sl version [522526e5b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GEV.PSL;3 6-APR-83 16:26:08 (FLUID '(GLNATOM RESULT Y)) (GLOBAL '(GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)) % GEV Structure Inspector % The following files are required: VECTOR GEVAUX WINDOW (GLISPGLOBALS (GEVACTIVEFLG BOOLEAN) (GEVEDITCHAIN EDITCHAIN) (GEVEDITFLG BOOLEAN) (GEVLASTITEMNUMBER INTEGER) (GEVMENUWINDOW WINDOW) (GEVMENUWINDOWHEIGHT INTEGER) (GEVMOUSEAREA MOUSESTATE) (GEVSHORTCHARS INTEGER) (GEVWINDOW WINDOW) (GEVWINDOWY INTEGER) ) (GLISPCONSTANTS (GEVMOUSEBUTTON 4 INTEGER) (GEVNAMECHARS 11 INTEGER) (GEVVALUECHARS 27 INTEGER) (GEVNAMEPOS (GEVNUMBERPOS + (IF GEVNUMBERCHARS > 0 THEN (GEVNUMBERCHARS + 1) *WINDOWCHARWIDTH ELSE 0)) INTEGER) (GEVTILDEPOS (GEVNAMEPOS + (GEVNAMECHARS+1) *WINDOWCHARWIDTH) INTEGER) (GEVVALUEPOS (GEVTILDEPOS + 2*WINDOWCHARWIDTH) INTEGER) ) (GLISPOBJECTS (EDITCHAIN (LISTOF EDITFRAME) PROP ((TOPFRAME ((CAR self))) (TOPITEM ((CAR TOPFRAME:PREVS))))) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) (SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM)))) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) (SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP ((NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))))) (MOUSESTATE (LIST (AREA REGION) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER))) ) % GSN 9-FEB-83 11:40 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DF GEV (ARGS) (GEVA (CAR ARGS) (EVAL (CAR ARGS)) (AND (CDR ARGS) (COND ((OR (NOT (ATOM (CADR ARGS))) (NOT (UNBOUNDP (CADR ARGS)))) (EVAL (CADR ARGS))) (T (CADR ARGS)))))) % edited: 15-MAR-83 10:40 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DG GEVA (VAR VAL STR) (PROG (GLNATOM TMP HEADER) (GEVENTER) (COND ((OR (NOT (NOT (UNBOUNDP 'GEVWINDOW))) (NULL GEVWINDOW)) (GEVINITEDITWINDOW))) (IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW OPEN)) (SEND GEVWINDOW OPEN) (GEVACTIVEFLG_T) (GEVEDITFLG_NIL) (GLNATOM_0) (GEVSHORTCHARS_GEVVALUECHARS) (IF VAR IS A LIST AND (CAR VAR) ='QUOTE THEN VAR_ (CONCAT "'" (GEVSTRINGIFY (CADR VAR)))) (IF ~STR THEN (IF VAL IS ATOMIC AND (GET VAL 'GLSTRUCTURE) THEN STR_'GLTYPE ELSEIF (GEVGLISPP) THEN STR_ (GLCLASS VAL))) (HEADER_ (A GSEITEM WITH NAME = VAR VALUE = VAL TYPE = STR)) (GEVEDITCHAIN_ (LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) (GEVMOUSELOOP) (GEVEXIT))) % GSN 2-MAR-83 14:06 (DG GEVCOMMANDFN (COMMANDWORD:ATOM) (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASE COMMANDWORD OF (EDIT (GEVEDIT)) (QUIT (IF GEVMOUSEAREA THEN (SEND GEVWINDOW INVERTAREA GEVMOUSEAREA:AREA) (GEVMOUSEAREA_NIL) ELSE (GEVQUIT))) (POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) ELSE (ERROR 0 NIL)))) % GSN 25-MAR-83 10:14 (DG GEVCOMMANDPROP (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) (PROG (VAL PROPNAMES FLG) (IF PROPNAME THEN FLG_T) (IF ITEM:TYPE IS ATOMIC THEN (PROPNAMES_ (GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME))) (IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP THEN (IF COMMANDWORD='PROP THEN (IF (CDR PROPNAMES) THEN PROPNAMES+_'All) PROPNAMES+_'self) (IF ~PROPNAMES (RETURN NIL)) (IF ~PROPNAME (PROPNAME _ (SEND (A MENU WITH ITEMS = PROPNAMES) SELECT))) (IF ~PROPNAME (RETURN NIL) ELSEIF PROPNAME='self THEN (PRIN1 PROPNAME) (PRINC " = ") (PRINT ITEM:VALUE) ELSEIF COMMANDWORD='PROP AND PROPNAME='All THEN (FOR X IN (OR (CDDR PROPNAMES) (CDR PROPNAMES)) DO (GEVDOPROP ITEM X COMMANDWORD FLG)) ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG)) (IF COMMANDWORD='MSG THEN (GEVREFILLWINDOW) (GEVEDITFLG_T))))) % edited: 22-DEC-82 11:09 % Get all property names of properties of type PROPTYPE for OBJ. % Properties are filtered to remove system properties and those % which are already displayed. (DG GEVCOMMANDPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN ~ (PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME = (CAR P))) AND ~ (PROPTYPE='PROP AND (MEMQ (CAR P) '(SHORTVALUE DISPLAYPROPS) )) AND ~ (PROPTYPE='MSG AND (CADR P) IS ATOMIC AND (~ (GETDDD (CADR P)) OR (LENGTH (CADR (GETDDD (CADR P)))) >1)) COLLECT P:NAME)) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME)))) (RETURN RESULT))) % GSN 2-MAR-83 10:42 % Compile a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVCOMPPROP (STR:GLTYPE PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (RETURN 'GEVERROR)) % If the property is implemented by a named function, return the % function name. (IF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC THEN (RETURN (CADR PROPENT))) % Compile code for this property and save it. First be sure the GLISP % compiler is loaded. (RETURN (COND ((GEVGLISPP) (GLCOMPPROP STR PROPNAME PROPTYPE) OR 'GEVERROR) (T (ERROR 0 (LIST "GLISP compiler must be loaded for PROPs which" "are not specified with function name equivalents." STR PROPTYPE PROPNAME))))))) % edited: 4-NOV-82 16:08 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (RESULT) (GEVDATANAMESB OBJ:STRDES FILTER) (RETURN (REVERSIP RESULT)))) % GSN 4-FEB-83 17:39 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMESB (STR:ANYTHING FILTER:ATOM) (GLOBAL RESULT)(PROG (TMP) (IF STR IS ATOMIC THEN (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER))) (RECORD (FOR X IN (CDDR STR) DO (GEVDATANAMESB X FILTER))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) (LISTOF (RETURN NIL)) ELSE (IF (GEVFILTER (CADR STR) FILTER) THEN (RESULT +_ (LIST (CAR STR) (CADR STR)))) (GEVDATANAMESB (CADR STR) FILTER))))) % GSN 25-MAR-83 09:48 % Display a newly added property in the window. (DG GEVDISPLAYNEWPROP NIL (PROG (Y NEWONE:GSEITEM) (Y_GEVWINDOWY) (NEWONE_ (CAR (LASTPAIR GEVEDITCHAIN:TOPFRAME:PROPS))) (GEVPPS NEWONE 0 GEVWINDOW) (GEVWINDOWY_Y))) % GSN 4-FEB-83 16:58 % Add the property PROPNAME of type COMMANDWORD to the display for % ITEM. (DG GEVDOPROP (ITEM:GSEITEM PROPNAME:ATOM COMMANDWORD:ATOM FLG:BOOLEAN) (PROG (VAL) (VAL_ (GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL)) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = PROPNAME TYPE = (GEVPROPTYPE ITEM:TYPE PROPNAME COMMANDWORD) VALUE = VAL NODETYPE = COMMANDWORD)) (IF ~FLG THEN (GEVDISPLAYNEWPROP)))) % GSN 25-MAR-83 09:48 % Edit the currently displayed item. (DG GEVEDIT NIL (PROG (CHANGEDFLG GEVTOPITEM) (GEVTOPITEM_GEVEDITCHAIN:TOPITEM) (IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE 'EDIT 'MSG NIL) ~='GEVERROR THEN CHANGEDFLG_T ELSEIF GEVTOPITEM:VALUE IS A LIST THEN (EDITV GEVTOPITEM:VALUE) (CHANGEDFLG_T) ELSE (RETURN NIL)) (IF CHANGEDFLG THEN (SEND GEVWINDOW OPEN) (GEVREFILLWINDOW)) (GEVEDITFLG_CHANGEDFLG))) % GSN 25-MAR-83 09:49 % Execute a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE on the object OBJ whose type is % STR. (DG GEVEXPROP (OBJ STR PROPNAME:ATOM PROPTYPE:ATOM ARGS) (PROG (FN) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) OR (ARGS AND PROPTYPE~='MSG) (RETURN 'GEVERROR)) (IF (FN_ (GEVCOMPPROP STR PROPNAME PROPTYPE)) ='GEVERROR THEN (RETURN FN) ELSE (RETURN (GEVAPPLY FN (CONS OBJ ARGS)))))) % edited: 15-MAR-83 12:40 % Fill the GEV editor window with the item which is at the top of % GEVEDITCHAIN. (DG GEVFILLWINDOW NIL (PROG (Y TOP) (SEND GEVWINDOW CLEAR) % Compute an initial Y value for printing titles in the window. (Y_GEVWINDOW:HEIGHT - WINDOWLINEYSPACING) % Print the titles from the edit chain first. (GEVLASTITEMNUMBER _ 0) (TOP_GEVEDITCHAIN:TOPFRAME) (FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:SUBITEMS DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:PROPS DO (GEVPPS X 0 GEVWINDOW)) (GEVWINDOWY_Y))) % GSN 21-JAN-83 10:24 % Filter types according to a specified FILTER. (DG GEVFILTER (TYPE FILTER) (TYPE_ (GEVXTRTYPE TYPE))(CASE FILTER OF (NUMBER ~ (MEMQ TYPE '(ATOM STRING BOOLEAN ANYTHING)) AND ~ ((PAIRP TYPE) AND (CAR TYPE) ='LISTOF)) (LIST (PAIRP TYPE) AND (CAR TYPE) ='LISTOF) ELSE T)) % edited: 14-OCT-82 11:32 (DG GEVFINDITEMPOS (POS:VECTOR ITEM:GSEITEM N:INTEGER) (RESULT MOUSESTATE) % Test whether ITEM contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N) (GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N) ((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF) AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N)))) % edited: 13-OCT-82 12:03 (DG GEVFINDLISTPOS (POS:VECTOR ITEMS: (LISTOF GSEITEM) N) (RESULT MOUSESTATE) % Find some ITEM corresponding to the mouse position POS. (IF ITEMS THEN (GEVFINDITEMPOS POS (CAR ITEMS) N) OR (GEVFINDLISTPOS POS (CDR ITEMS) N))) % edited: 13-OCT-82 12:06 (DG GEVFINDPOS (POS:VECTOR FRAME:EDITFRAME) (RESULT MOUSESTATE) % Find the sub-item of FRAME corresponding to the mouse position POS. % The result is NIL if not found, else a list of the sub-item and a % flag which is NIL if the NAME part is identified, T if the VALUE % part is identified. (PROG (TMP N ITEMS: (LISTOF GSEITEM)) (N_0) (WHILE FRAME AND ~TMP DO (N_+1) ITEMS-_FRAME (TMP_ (GEVFINDLISTPOS POS ITEMS N))) (RETURN TMP))) % edited: 22-DEC-82 14:53 % Get all names of properties and stored data from a GLISP object % type. (DG GEVGETNAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES (GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ 'PROP FILTER)) (RETURN (NCONC DATANAMES PROPNAMES)))) % GSN 4-FEB-83 16:59 % Retrieve a GLISP property whose name is PROPNAME and whose property % type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVGETPROP (STR PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (ERROR 0 NIL)) (RETURN (AND (PL_ (GET STR 'GLSTRUCTURE)) (SUBPL_ (LISTGET (CDR PL) PROPTYPE)) (PROPENT_ (ASSOC PROPNAME SUBPL)))))) % edited: 11-NOV-82 15:53 (DE GEVGLISPP NIL (NOT (UNBOUNDP 'GLBASICTYPES))) % edited: 6-APR-83 15:54 (DG GEVHORIZLINE (W:WINDOW) (GLOBAL Y:INTEGER) % Draw a horizontal line across window W at Y and decrease Y. (SEND W DRAWLINE (A VECTOR WITH X = W:LEFTMARGIN Y = Y+WINDOWLINEYSPACING / 2) (A VECTOR WITH X = W:RIGHTMARGIN Y = Y+WINDOWLINEYSPACING / 2))( Y_-WINDOWLINEYSPACING)) % edited: 11-MAR-83 16:03 (DE GEVINIT NIL (SETQ GLNATOM 0)(COND ((NOT (NOT (UNBOUNDP 'GLLISPDIALECT))) (SETQ GLLISPDIALECT 'INTERLISP)))(SETQ GEVWINDOW NIL)) % GSN 25-MAR-83 10:14 % Respond to an event which selects an item. GROUP gives the group in % which the item occurs. 1 = edit path. FLAG is T if the type of the % item is selected, NIL if the value is selected. (DG GEVITEMEVENTFN (ITEM:GSEITEM GROUP:INTEGER FLAG:BOOLEAN) (PROG (TMP TOP N) (IF FLAG THEN (IF GROUP=1 THEN (TMP_GEVEDITCHAIN:TOPFRAME:PREVS) (N_0) (WHILE TMP AND (TOP-_TMP) <>ITEM DO N_+1) (GEVPOP NIL N) ELSE (GEVPUSH ITEM)) ELSE (PRIN1 ITEM:NAME) (PRINC " is ") (PRIN1 ITEM:TYPE) (TERPRI)))) % GSN 2-MAR-83 16:14 % Bound the length of VAL to NCHARS. (DG GEVLENGTHBOUND (VAL NCHARS) (COND ((GREATERP (FlatSize2 VAL) NCHARS) ((SUBSTRING VAL 1 (SUB1 NCHARS)) + "-")) (T VAL))) % edited: 6-APR-83 16:01 % Make a function to perform OPERATION on set SETNAME from INPUTTYPE % following PATH to get to the data. (DG GEVMAKENEWFN (OPERATION:ATOM INPUTTYPE:ATOM SET: (LIST (NAME ATOM) (TYPE GLTYPE)) PATH: (LISTOF (LIST (NAME ATOM) (TYPE GLTYPE)))) (PROG (LASTPATH VIEWSPEC) (SETQ LASTPATH (CAR (LASTPAIR PATH))) (RETURN (LIST (LIST 'GLAMBDA (LIST (MKATOM (CONCAT "GEVNEWFNTOP:" INPUTTYPE:PNAME))) (LIST 'PROG (CONS 'GEVNEWFNVALUE (CASE OPERATION OF (COLLECT '(GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (TOTAL '((GEVNEWFNSUM 0))) (AVERAGE '((GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0))) ELSE (ERROR 0 NIL))) (NCONC (LIST 'FOR 'GEVNEWFNLOOPVAR 'IN (MKATOM (CONCAT "GEVNEWFNTOP:" SET:NAME:PNAME)) 'DO (LIST 'GEVNEWFNVALUE '_ (PROGN (VIEWSPEC _ (LIST 'GEVNEWFNLOOPVAR) ) (FOR X IN PATH DO (VIEWSPEC +_ 'OF) (VIEWSPEC +_ X:NAME) (VIEWSPEC +_ 'THE)) VIEWSPEC))) (COPY (CASE OPERATION OF (COLLECT '((GEVNEWFNRESULT +_ GEVNEWFNVALUE))) (MAXIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR))) ) (MINIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR))) ) (AVERAGE '((GEVNEWFNSUM _+ GEVNEWFNVALUE) (GEVNEWFNCOUNT _+ 1))) (TOTAL '((GEVNEWFNSUM _+ GEVNEWFNVALUE)))))) (LIST 'RETURN (CASE OPERATION OF (COLLECT '(DREVERSE GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (AVERAGE '(QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT))) (TOTAL 'GEVNEWFNSUM))))) (CASE OPERATION OF (COLLECT (LIST 'LISTOF (CADR LASTPATH))) ((MAXIMUM MINIMUM) (LIST 'LIST (COPY LASTPATH) (LIST 'WINNER (CADR SET:TYPE)))) (AVERAGE 'REAL) (TOTAL (CADR LASTPATH))))))) % edited: 8-OCT-82 10:43 (DG GEVMATCH (STR VAL FLG) (RESULT (LISTOF GSEITEM)) % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) (RETURN (REVERSIP RESULT)))) % edited: 8-OCT-82 10:01 % Make a single item which matches structure STR and value VAL. (DG GEVMATCHA (STR VAL FLG) (PROG (RES) (RES_ (GEVMATCH STR VAL FLG)) (IF ~ (CDR RES) THEN (RETURN (CAR RES)) ELSE (RETURN (A GSEITEM WITH VALUE = VAL TYPE = STR SUBVALUES = RES NODETYPE = 'SUBTREE))))) % edited: 7-OCT-82 16:38 % Match an ATOM structure to a given value. (DG GEVMATCHATOM (STR VAL NAME) (PROG (L STRB TMP) (IF VAL IS NOT ATOMIC OR VAL IS NULL THEN (RETURN NIL)) (STRB_ (CADR STR)) (IF (CAR STRB) ~='PROPLIST THEN (RETURN NIL)) (L_ (CDR STRB)) (FOR X IN L DO (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 7-OCT-82 16:57 % Match an ALIST structure to a given value. (DG GEVMATCHALIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (ASSOC (CAR X) VAL) THEN (GEVMATCHB X (CDR TMP) NIL NIL))))) % edited: 22-DEC-82 15:26 % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. If % FLG is set, the match will descend inside an atomic type name. % Results are added to the free variable RESULT. (DG GEVMATCHB (STR: (LISTOF ANYTHING) VAL NAME:ATOM FLG:BOOLEAN) (GLOBAL RESULT)(PROG (X Y STRB XSTR TOP TMP) (XSTR_ (GEVXTRTYPE STR)) (IF STR IS ATOMIC THEN (IF FLG AND (STRB _ (CAR (GET STR 'GLSTRUCTURE))) THEN (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = (GEVMATCH STRB VAL NIL) TYPE = STR NODETYPE = 'STRUCTURE)) ELSE (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB (CADDR STR) (CDR VAL) NIL NIL)) (LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL) NIL NIL) (VAL_ (CDR VAL))))) (ATOM (GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST (GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) (RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) (GEVMATCHOBJECT STR VAL NAME)) ELSE (IF NAME THEN (TMP _ (GEVMATCH STR VAL NIL)) (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN ( TOP:NAME_NAME) TOP ELSE (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = TMP TYPE = XSTR NODETYPE = 'SUBTREE))) ELSEIF (STRB _ (GEVXTRTYPE (CADR STR))) IS ATOMIC THEN (GEVMATCHB STRB VAL (CAR STR) NIL) ELSEIF (TMP_ (GEVMATCH (CADR STR) VAL NIL)) THEN (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN (TOP:NAME_ (CAR STR)) TOP ELSE (A GSEITEM WITH NAME = (CAR STR) VALUE = VAL SUBVALUES = TMP TYPE = (CADR STR) NODETYPE = 'SUBTREE))) ELSE (PRINT "GEVMATCHB Failed")))))) % edited: 8-OCT-82 10:15 % Match a LISTOF structure. (DG GEVMATCHLISTOF (STR VAL NAME) (GLOBAL RESULT)(RESULT+_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) % edited: 22-DEC-82 10:04 % Match the OBJECT structures. (DG GEVMATCHOBJECT (STR VAL NAME) (GLOBAL RESULT)(PROG (OBJECTTYPE TMP) (SETQ OBJECTTYPE (CAR STR)) (RESULT _+ (A GSEITEM WITH NAME = 'CLASS VALUE = (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (TMP-_VAL)) (ATOMOBJECT (GET VAL 'CLASS))) TYPE = 'GLTYPE)) (FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (IF VAL (GEVMATCHB X (TMP-_VAL) NIL NIL))) (ATOMOBJECT (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))))) % edited: 24-NOV-82 16:31 % Match an PROPLIST structure to a given value. (DG GEVMATCHPROPLIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (LISTGET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 11-MAR-83 16:31 % Match a RECORD structure. (DG GEVMATCHRECORD (STR VAL NAME) (PROG (STRNAME FIELDS N) (IF (CADR STR) IS ATOMIC THEN STRNAME_ (CADR STR) FIELDS_ (CDDR STR) ELSE FIELDS_ (CDR STR)) (N_0) (FOR X IN FIELDS DO (N_+1) (GEVMATCHB X (GetV VAL N) (CAR X) NIL)))) % GSN 2-MAR-83 17:33 % Pop up from the current item to the previous one. If FLG is set, % popping continues through extended LISTOF elements. (DG GEVPOP (FLG:BOOLEAN N:INTEGER) (PROG (TMP TOP:GSEITEM TMPITEM) (IF N<1 (RETURN NIL)) LP (TMP-_GEVEDITCHAIN) (IF ~GEVEDITCHAIN THEN (RETURN (GEVQUIT))) (TOP_ (CAAAR GEVEDITCHAIN)) % Test for repeated LISTOF elements. (TMPITEM_ (CAR TMP:PREVS)) (IF FLG AND TMPITEM:NODETYPE='FORWARD THEN (GO LP)) (IF (N_-1) >0 THEN (GO LP)) (IF TOP:TYPE IS A LIST AND (CAR TOP:TYPE) ='LISTOF AND ~ (CDR TOP:VALUE) THEN (GO LP)) (IF GEVEDITFLG AND ~ (MEMBER TMPITEM:SHORTVALUE '("(...)" "---")) THEN (GEVREFILLWINDOW) ELSE GEVEDITFLG_NIL (GEVFILLWINDOW)))) % edited: 11-MAR-83 15:06 (DG GEVPOSTEST (POS:VECTOR TPOS:VECTOR NAME:STRING ITEM:GSEITEM FLG N:INTEGER) (RESULT MOUSESTATE) % Test whether TPOS contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+WINDOWLINEYSPACING AND POS:X>=TPOS:X AND POS:X<TPOS:X+GEVNAMECHARS*WINDOWCHARWIDTH THEN (A MOUSESTATE WITH AREA = (A REGION WITH START = (A VECTOR WITH X = TPOS:X Y = TPOS:Y - 1) SIZE = (A VECTOR WITH X = WINDOWCHARWIDTH*NAME:LENGTH Y = WINDOWLINEYSPACING)) ITEM = ITEM FLAG = FLG GROUP = N))) % edited: 15-MAR-83 12:38 (DG GEVPPS (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) (GLOBAL Y:INTEGER) % Pretty-print a structure defined by ITEM in the window WINDOW, % beginning ar horizontal column COL and vertical position Y. The % positions in ITEM are modified to match the positions in the % window. (PROG (NAMEX TOP) % Make sure there is room in window. (IF Y<0 THEN (RETURN NIL)) (IF GEVNUMBERCHARS>0 THEN (GEVLASTITEMNUMBER _+ 1) (SEND WINDOW PRINTAT (GEVSTRINGIFY GEVLASTITEMNUMBER) (A VECTOR WITH X = GEVNUMBERPOS Y = Y))) % Position in window for slot name. (NAMEX _ GEVNAMEPOS + COL*WINDOWCHARWIDTH) (ITEM:NAMEPOS:X_NAMEX) (ITEM:NAMEPOS:Y_Y) (IF ITEM:NODETYPE='FULLVALUE THEN (SEND WINDOW PRINTAT "(expanded)" (A VECTOR WITH X = NAMEX Y = Y)) ELSEIF ITEM:NAME THEN (IF ITEM:NAME IS NUMERIC THEN (SEND WINDOW PRINTAT "#" (A VECTOR WITH X = NAMEX Y = Y)) (NAMEX_+WINDOWCHARWIDTH)) (SEND WINDOW PRINTAT (GEVLENGTHBOUND ITEM:NAME GEVNAMECHARS) (A VECTOR WITH X = NAMEX Y = Y))) % See if there is a value to print for this name. (IF ~ITEM:NODETYPE OR (MEMQ ITEM:NODETYPE '(FORWARD BACKUP PROP ADJ MSG ISA)) THEN (ITEM:VALUEPOS:X_GEVVALUEPOS) (ITEM:VALUEPOS:Y_Y) (SEND WINDOW PRINTAT (ITEM:SHORTVALUE OR (ITEM:SHORTVALUE _ (GEVSHORTVALUE ITEM:VALUE ITEM:TYPE (GEVSHORTCHARS - COL)))) (A VECTOR WITH X = GEVVALUEPOS Y = Y)) (IF ~ (EQ ITEM:SHORTVALUE ITEM:VALUE) THEN (SEND WINDOW PRINTAT "~" (A VECTOR WITH X = GEVTILDEPOS Y = Y))) (Y_-WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='FULLVALUE THEN (Y_-WINDOWLINEYSPACING) (SEND WINDOW PRETTYPRINTAT ITEM:VALUE (A VECTOR WITH X = WINDOWCHARWIDTH Y = Y)) (Y_WINDOW:YPOSITION - WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='DISPLAY THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE 'GEVDISPLAY 'MSG (LIST WINDOW Y)) ELSE % This is a subtree (Y_-WINDOWLINEYSPACING) (FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW))))) % edited: 6-APR-83 16:03 % Write an interactive program involving the current item. (DG GEVPROGRAM NIL (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF (COMMAND_ (SEND (A MENU WITH ITEMS = '(Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM)) SELECT)) ='Quit OR ~ COMMAND THEN (RETURN NIL)) (IF (SET_ (GEVPROPMENU TOPITEM:TYPE 'LIST NIL)) ='Quit OR SET='Pop OR ~SET THEN (RETURN NIL)) (PATH_ (LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE))) (NEXT_SET) (TYPE_ (CADADR SET)) (WHILE ~DONE AND ~ABORTFLG DO (NEXT_ (GEVPROPMENU TYPE (COMMAND~='COLLECT AND 'NUMBER) COMMAND='COLLECT)) (IF NEXT IS ATOMIC THEN (CASE NEXT OF ((NIL Quit) (ABORTFLG_T)) (Pop (IF ~ (CDDR PATH) THEN (ABORTFLG_T) ELSE (NEXT-_PATH) (NEXT_ (CAR PATH)) (TYPE_ (CADR NEXT)) (IF TYPE IS A LIST THEN TYPE_ (CADR TYPE)) (LAST_ (CAR NEXT)))) (Done (DONE_T))) ELSE (PATH+_NEXT) (TYPE_ (CADR NEXT)) (LAST_ (CAR NEXT))) (IF (MEMQ TYPE '(ATOM INTEGER STRING REAL BOOLEAN NIL)) DONE_T)) (IF ABORTFLG (RETURN NIL)) (PATH_ (REVERSIP PATH)) (NEWFN_ (GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH))) (GEVPUTD 'GEVNEWFN (CAR NEWFN)) (RESULT_ (GEVNEWFN TOPITEM:VALUE)) % Print result as well as displaying it. (PRIN1 COMMAND) (SPACES 1) (FOR X IN (CDDR PATH) DO (PRIN1 (CAR X)) (SPACES 1)) (PRINC "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) (PRINC " = ") (PRINT RESULT) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = (CONCAT (GEVSTRINGIFY COMMAND) (CONCAT " " (GEVSTRINGIFY LAST))) TYPE = (CADR NEWFN) VALUE = RESULT NODETYPE = 'MSG)) (GEVDISPLAYNEWPROP))) % GSN 21-JAN-83 10:32 % Make a menu to get properties of object OBJ with filter FILTER. FLG % is T if it is okay to stop before reaching a basic type. (DG GEVPROPMENU (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) (PROG (PROPS SEL PNAMES MENU) (PROPS_ (GEVGETNAMES OBJ FILTER)) (IF ~PROPS THEN (RETURN NIL) ELSE (PNAMES_ (MAPCAR PROPS (FUNCTION CAR))) (SEL_ (SEND (A MENU WITH ITEMS = (CONS 'Quit (CONS 'Pop (IF FLG THEN (CONS 'Done PNAMES) ELSE PNAMES)))) SELECT)) (RETURN (CASE SEL OF ((Quit Pop Done NIL) SEL) ELSE (ASSOC SEL PROPS)))))) % GSN 4-FEB-83 17:01 % Get all property names and types of properties of type PROPTYPE for % OBJ when they satisfy FILTER. (DG GEVPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN (TYPE_ (GEVPROPTYPES OBJ P:NAME 'PROP)) AND (GEVFILTER TYPE FILTER) COLLECT (LIST P:NAME TYPE))) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER)))) (RETURN RESULT))) % GSN 4-FEB-83 17:02 % Find the type of a computed property. (DG GEVPROPTYPE (STR:ATOM PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT TMP) (IF STR IS NOT ATOMIC THEN (RETURN NIL) ELSEIF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (TMP_ (LISTGET (CDDR PROPENT) 'RESULT)) THEN (RETURN TMP) ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP_ (GET (CADR PROPENT) 'GLRESULTTYPE)) THEN (RETURN TMP) ELSEIF (AND (PL_ (GET STR 'GLPROPFNS)) (SUBPL_ (ASSOC PROPTYPE PL)) (PROPENT_ (ASSOC PROPNAME (CDR SUBPL))) (TMP_ (CADDR PROPENT))) THEN (RETURN TMP) ELSEIF PROPTYPE='ADJ THEN (RETURN 'BOOLEAN)))) % edited: 4-NOV-82 15:39 (DE GEVPROPTYPES (OBJ NAME TYPE) (OR (GEVPROPTYPE OBJ NAME TYPE) (AND (GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE)))) % GSN 2-MAR-83 17:32 % Push down to look at an item referenced from the current item. (DG GEVPUSH (ITEM:GSEITEM) (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (IF ITEM:NODETYPE='BACKUP THEN (GEVPOP NIL 1) (RETURN NIL)) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF ITEM:NODETYPE='FORWARD THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM T)) ELSEIF ITEM:TYPE IS ATOMIC AND ~ (GET ITEM:TYPE 'GLSTRUCTURE) THEN (CASE ITEM:TYPE OF ((ATOM NUMBER REAL INTEGER STRING ANYTHING) (IF ITEM:VALUE=ITEM:SHORTVALUE THEN (RETURN NIL) ELSE (NEWITEMS_ (LIST (A GSEITEM WITH NAME = ITEM:NAME VALUE = ITEM:VALUE SHORTVALUE = ITEM:SHORTVALUE TYPE = ITEM:TYPE NODETYPE = 'FULLVALUE))))) ELSE (RETURN NIL)) ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM NIL))) (GEVEDITCHAIN+_ (AN EDITFRAME WITH PREVS = (CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS) SUBITEMS = NEWITEMS)) % Do another PUSH automatically for a list of only one item. (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF AND ~ (CDR ITEM:VALUE) THEN (LSTITEM_ (CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN NIL)))) % edited: 6-APR-83 16:04 % Push into a datum of type LISTOF, expanding it into the individual % elements. If FLG is set, ITEM is a FORWARD item to be continued. (DG GEVPUSHLISTOF (ITEM:GSEITEM FLG:BOOLEAN) (PROG (ITEMTYPE TOPFRAME N:INTEGER NROOM LST VALS: (LISTOF ANYTHING) TMP) % Compute the vertical room available in the window. (IF ~ITEM:VALUE (RETURN NIL)) (TOPFRAME_GEVEDITCHAIN:TOPFRAME) (NROOM _ GEVWINDOW:HEIGHT / WINDOWLINEYSPACING - 4 - (LENGTH TOPFRAME:PREVS)) % If there was a previous display of this list, insert an ellipsis % header. (IF FLG THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "(..." NODETYPE = 'BACKUP)) (N_ITEM:NAME) (ITEMTYPE_ITEM:TYPE) (NROOM_-1) (VALS_ITEM:SUBVALUES) ELSE (N_1) (ITEMTYPE_ (CADR ITEM:TYPE)) (VALS_ITEM:VALUE)) % Now make entries for each value on the list. (WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~ (CDR VALS))) DO (LST+_ (A GSEITEM WITH VALUE = (TMP-_VALS) TYPE = ITEMTYPE NAME = N)) (NROOM_-1) (N_+1)) (IF VALS THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "...)" NODETYPE = 'FORWARD TYPE = ITEMTYPE NAME = N SUBVALUES = VALS))) (RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = ITEMTYPE NODETYPE = 'LISTOF SUBVALUES = (REVERSIP LST)))))) % edited: 14-MAR-83 16:46 (DG GEVQUIT NIL (SETQ GEVACTIVEFLG NIL)(SEND GEVWINDOW CLOSE)(IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW CLOSE))) % edited: 19-OCT-82 10:23 % Recompute property values for the item. (DG GEVREDOPROPS (TOP:EDITFRAME) (PROG (ITEM L) (ITEM_ (CAR TOP:PREVS)) (IF ~TOP:PROPS AND (L_ (GEVEXPROP ITEM:VALUE ITEM:TYPE 'DISPLAYPROPS 'PROP NIL)) ~='GEVERROR THEN (IF L IS ATOMIC THEN (GEVCOMMANDPROP ITEM 'PROP 'All) ELSEIF L IS A LIST THEN (FOR X IN L (GEVCOMMANDPROP ITEM 'PROP X))) ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG DO (X:VALUE _ (GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL)) (X:SHORTVALUE _ NIL))))) % edited: 14-OCT-82 12:46 % Re-expand the top item of GEVEDITCHAIN, which may have been changed % due to editing. (DG GEVREFILLWINDOW NIL (PROG (TOP TOPITEM SUBS TOPSUB) (TOP_GEVEDITCHAIN:TOPFRAME) (TOPITEM_GEVEDITCHAIN:TOPITEM) (TOPSUB_ (CAR TOP:SUBITEMS)) (IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF) THEN (IF (GEVGETPROP TOPITEM:TYPE 'GEVDISPLAY 'MSG) THEN (TOP:SUBITEMS_ (LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE TYPE = TOPITEM:TYPE NODETYPE = 'DISPLAY))) ELSE (SUBS_ (GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T)) (TOPSUB_ (CAR SUBS)) (TOP:SUBITEMS_ (IF ~ (CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE AND TOPSUB:VALUE=TOPITEM:VALUE AND TOPSUB:TYPE=TOPITEM:TYPE THEN TOPSUB:SUBVALUES ELSE SUBS)))) (GEVREDOPROPS TOP) (GEVFILLWINDOW))) % edited: 6-APR-83 16:05 (DE GEVSHORTATOMVAL (ATM NCHARS) (COND ((NUMBERP ATM) (COND ((GREATERP (FlatSize2 ATM) NCHARS) (GEVSHORTSTRINGVAL (GEVSTRINGIFY ATM) NCHARS)) (T ATM))) ((GREATERP (FlatSize2 ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM))) % GSN 4-APR-83 16:23 % Compute a short value for printing a CONS of two items. (DG GEVSHORTCONSVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP NC) (RES +_ "(") (NLEFT _ NCHARS - 5) (TMP_ (GEVSHORTVALUE (CAR VAL) (CADR STR) NLEFT - 3)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT - 3 THEN TMP_ "---" NC_3) (RES+_ (GEVSTRINGIFY TMP)) (RES +_ " . ") (NLEFT_-NC) (TMP_ (GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT THEN TMP_ "---" NC_3) (RES+_ (GEVSTRINGIFY TMP)) (RES+_ ")") (RETURN (GEVCONCAT (REVERSIP RES))))) % GSN 4-APR-83 16:24 % Compute a short value for printing a list of items. (DG GEVSHORTLISTVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (RES +_ "(") (REST_4) (NLEFT _ NCHARS - 2) (RSTR_ (CDR STR)) (WHILE VAL AND ~QUIT AND (NCI_ (IF (CDR VAL) THEN NLEFT - REST ELSE NLEFT)) >2 DO (TMP_ (GEVSHORTVALUE (CAR VAL) (IF (CAR STR) ='LISTOF THEN (CADR STR) ELSEIF (CAR STR) ='LIST THEN (CAR RSTR)) NCI)) (QUIT _ (MEMBER TMP '(GEVERROR "(...)" "---" "???"))) (NC_ (FlatSize2 TMP)) (IF NC>NCI AND (CDR RES) THEN QUIT_T ELSE (IF NC>NCI THEN TMP_ "---" NC_3 QUIT_T) (RES+_ (GEVSTRINGIFY TMP)) (NLEFT_-NC) (VAL_ (CDR VAL)) (RSTR_ (CDR RSTR)) (IF VAL THEN (RES+_ " ") (NLEFT_-1)))) (IF VAL THEN (RES+_ "...")) (RES+_ ")") (RETURN (GEVCONCAT (REVERSIP RES))))) % edited: 12-OCT-82 12:14 % Compute the short value of a string VAL. The result is a string % which can be printed within NCHARS. (DE GEVSHORTSTRINGVAL (VAL NCHARS) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"))) % edited: 11-MAR-83 15:34 % Compute the short value of a given value VAL whose type is STR. The % result is an atom, string, or list structure which can be printed % within NCHARS. (DE GEVSHORTVALUE (VAL STR NCHARS) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) (RETURN (COND ((AND (ATOM STR) (MEMQ STR '(ATOM INTEGER REAL))) (GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR 'STRING) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NE (SETQ TMP (GEVEXPROP VAL STR 'SHORTVALUE 'PROP NIL)) 'GEVERROR)) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) (GEVSHORTSTRINGVAL VAL NCHARS)) ((PAIRP STR) (CASEQ (CAR STR) ((LISTOF LIST) (COND ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND ((PAIRP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) (T "---"))) ((PAIRP VAL) (GEVSHORTLISTVAL VAL '(LISTOF ANYTHING) NCHARS)) (T "---"))))) % edited: 21-OCT-82 11:17 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GEVXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (MEMQ (CAR TYPE) '(A AN a an An TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (NOT (UNBOUNDP GLUSERSTRNAMES)) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR 0 (LIST 'GEVXTRTYPE (LIST TYPE "is an illegal type specification."))) NIL))) (SETQ GEVTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) |
Added psl-1983/3-1/glisp/gevaux.sl version [44253841ae].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVAUX.SL.14 07 April 83 % Auxiliary functions for PSL version of GEV. % GSN 07 March 83 % Interlisp Substring function. (de substring (string first last) (cond ((not (stringp string)) (setq string (gevstringify string)))) (cond ((minusp first) (setq first (add1 (plus (add1 (size string)) first))))) (cond ((minusp last) (setq last (add1 (plus (add1 (size string)) last))))) (subseq string (sub1 first) last) ) % Make a string out of anything (de gevstringify (x) (cond ((stringp x) x) (t (bldmsg "%p" x)))) % Concatenate an arbitrary number of items (de concatn (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (car l))) (t (concat (gevstringify (car l)) (concatn (cdr l)))))) (de concatln (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (eval (car l)))) (t (concat (gevstringify (eval (car l))) (concatln (cdr l)))))) (df concatl (concatlarg) (concatln concatlarg)) (de gevconcat (l) (concatn l)) (de dreverse (l) (reversip l)) (de mkatom (s) (intern s)) (de gevputd (fn form) (put fn 'gloriginalexpr (cons 'lambda (cdr form))) (put fn 'glcompiled nil) (remd fn) (putd fn 'macro '(lambda (gldgform) (glhook gldgform)))) % Apply a function to arguments, Glisp-compiling first if needed. (de gevapply (fn args) (cond ((and (atom fn) (or (null (get fn 'glcompiled)) (not (eq (getddd fn) (get fn 'glcompiled))))) (glcc fn) (apply fn args)) (t (apply fn args)))) |
Added psl-1983/3-1/glisp/gevaux20.old version [daf5a78e91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVAUX20.SL.21 % Auxiliary functions for PSL version of GEV. % GSN 07 March 83 % Interlisp Substring function. (de substring (string first last) (cond ((not (stringp string)) (setq string (gevstringify string)))) (cond ((minusp first) (setq first (add1 (plus (add1 (size string)) first))))) (cond ((minusp last) (setq last (add1 (plus (add1 (size string)) last))))) (subseq string (sub1 first) last) ) % Make a string out of anything (de gevstringify (x) (cond ((stringp x) x) (t (bldmsg "%p" x)))) % Concatenate an arbitrary number of items (de concatn (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (car l))) (t (concat (gevstringify (car l)) (concatn (cdr l)))))) (de concatln (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (eval (car l)))) (t (concat (gevstringify (eval (car l))) (concatln (cdr l)))))) (df concatl (concatlarg) (concatln concatlarg)) (de gevconcat (l) (concatn l)) (de dreverse (l) (reversip l)) (de mkatom (s) (intern s)) (de gevputd (fn form) (put fn 'gloriginalexpr (cons 'lambda (cdr form))) (put fn 'glcompiled nil) (remd fn) (putd fn 'macro '(lambda (gldgform) (glhook gldgform)))) % Apply a function to arguments, Glisp-compiling first if needed. (de gevapply (fn args) (cond ((and (atom fn) (or (null (get fn 'glcompiled)) (not (eq (getddd fn) (get fn 'glcompiled))))) (glcc fn) (apply fn args)) (t (apply fn args)))) |
Added psl-1983/3-1/glisp/gevaux20.sl version [daf5a78e91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVAUX20.SL.21 % Auxiliary functions for PSL version of GEV. % GSN 07 March 83 % Interlisp Substring function. (de substring (string first last) (cond ((not (stringp string)) (setq string (gevstringify string)))) (cond ((minusp first) (setq first (add1 (plus (add1 (size string)) first))))) (cond ((minusp last) (setq last (add1 (plus (add1 (size string)) last))))) (subseq string (sub1 first) last) ) % Make a string out of anything (de gevstringify (x) (cond ((stringp x) x) (t (bldmsg "%p" x)))) % Concatenate an arbitrary number of items (de concatn (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (car l))) (t (concat (gevstringify (car l)) (concatn (cdr l)))))) (de concatln (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (eval (car l)))) (t (concat (gevstringify (eval (car l))) (concatln (cdr l)))))) (df concatl (concatlarg) (concatln concatlarg)) (de gevconcat (l) (concatn l)) (de dreverse (l) (reversip l)) (de mkatom (s) (intern s)) (de gevputd (fn form) (put fn 'gloriginalexpr (cons 'lambda (cdr form))) (put fn 'glcompiled nil) (remd fn) (putd fn 'macro '(lambda (gldgform) (glhook gldgform)))) % Apply a function to arguments, Glisp-compiling first if needed. (de gevapply (fn args) (cond ((and (atom fn) (or (null (get fn 'glcompiled)) (not (eq (getddd fn) (get fn 'glcompiled))))) (glcc fn) (apply fn args)) (t (apply fn args)))) |
Added psl-1983/3-1/glisp/gevauxold.sl version [13d1b2b2c8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVAUX.SL.21 28 March 83 % Auxiliary functions for PSL version of GEV, HP 9836 version. % GSN 07 March 83 % Interlisp Substring function. (de substring (string first last) (cond ((not (stringp string)) (setq string (gevstringify string)))) (cond ((minusp first) (setq first (add1 (plus (add1 (size string)) first))))) (cond ((minusp last) (setq last (add1 (plus (add1 (size string)) last))))) (subseq string (sub1 first) last) ) % Make a string out of anything (de gevstringify (x) (cond ((stringp x) x) (t (bldmsg "%p" x)))) % Concatenate an arbitrary number of items (de concatn (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (car l))) (t (concat (gevstringify (car l)) (concatn (cdr l)))))) (de concatln (l) (cond ((null l) "") ((null (cdr l)) (gevstringify (eval (car l)))) (t (concat (gevstringify (eval (car l))) (concatln (cdr l)))))) (df concatl (concatlarg) (concatln concatlarg)) (de gevconcat (l) (concatn l)) (de dreverse (l) (reversip l)) (de mkatom (s) (intern s)) (de gevputd (fn form) (put fn 'gloriginalexpr (cons 'lambda (cdr form))) (put fn 'glcompiled nil) (remd fn) (putd fn 'macro '(lambda (gldgform) (glhook gldgform)))) % Apply a function to arguments, Glisp-compiling first if needed. (de gevapply (fn args) (cond ((and (atom fn) (or (null (get fn 'glcompiled)) (not (eq (getddd fn) (get fn 'glcompiled))))) (glcc fn) (apply fn args)) (t (apply fn args)))) % TTY input replacement for mouse operations. % GSN 07 March 83 (dg gevmouseloop () (prog (input n tmp) lp (prin2 "GEV: ") (input _ (read)) (if input='t and (n _ (read)) is numeric then (gevnselect n nil) (go lp) elseif input is numeric then (gevnselect input t) (go lp) elseif (tmp _ (assoc input '((q quit)(pop pop)(e edit)(pr program) (p prop)(a adj)(i isa)(m msg)))) then (gevcommandfn (cadr tmp)) (if (cadr tmp)='quit or ~gevactiveflg then (return nil) else (go lp))) err (prin2 "? Quit POP Edit PRogram Prop Adj Isa Msg") (terpri) (go lp) )) % GEVCRT.SL.4 28 March 83 % derived from <NOVAK>GEVCRT.PSL.1 20-Mar-83 12:41:24 (GLOBAL '(GEVMENUWINDOW GEVSAVEESC GEVSAVEGLQUIET GEVSAVEGCGAG GEVMOUSEAREA)) (DE GEVENTER NIL (setq gevsavegcgag !*GC) (setq !*GC nil) (SETQ GEVSAVEGLQUIET GLQUIETFLG) (SETQ GLQUIETFLG T) (window-init nil)) (DE GEVEXIT NIL (setq !*GC gevsavegcgag) (SETQ GLQUIETFLG GEVSAVEGLQUIET) (window-term nil)) % edited: 19-Mar-83 22:41 (DG GEVINITEDITWINDOW NIL (PROG NIL (GEVWINDOW _ (A WINDOW WITH START = (A VECTOR WITH X = 0 Y = 0) SIZE = (A VECTOR WITH X = 300 Y = 500) TITLE = "GEV Structure Inspector")) (RETURN GEVWINDOW))) % edited: 19-Mar-83 21:42 % Select the Nth item in the display and push down to zoom in on it. (DG GEVNSELECT (N:INTEGER FLAG:BOOLEAN) (PROG (L TOP SUBLIST GROUP ITEM) (GROUP _ 0) (TOP _ GEVEDITCHAIN:TOPFRAME) LP (IF ~TOP THEN (RETURN NIL)) (SUBLIST -_ TOP) (GROUP _+ 1) (IF GROUP=1 AND (L _ (LENGTH SUBLIST)) >=N THEN (ITEM _ (CAR (PNth SUBLIST (L + 1 - N)))) ELSEIF ~ (ITEM _ (GEVNTHITEM SUBLIST)) THEN (GO LP)) (IF ITEM:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) THEN (RETURN NIL) ELSE (RETURN (GEVITEMEVENTFN ITEM GROUP FLAG))))) % edited: 19-Mar-83 22:15 % Find the Nth item in a tree structure of items. (DG GEVNTHITEM (L: (LISTOF GSEITEM)) (GLOBAL N:INTEGER)(PROG (TMP RES) (IF N<=0 THEN (ERROR 0 NIL) ELSEIF ~L THEN (RETURN NIL) ELSEIF N=1 THEN (RETURN (CAR L)) ELSE (N _- 1) (TMP -_ L) (IF TMP:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) AND (RES _ (GEVNTHITEM TMP:SUBVALUES)) THEN (RETURN RES) ELSE (RETURN (GEVNTHITEM L)))))) (GLISPCONSTANTS (GEVNUMBERCHARS 2 INTEGER) (GEVNUMBERPOS 1 INTEGER) ) (SETQ GEVMENUWINDOW NIL) (SETQ GEVMOUSEAREA NIL) |
Added psl-1983/3-1/glisp/gevcrt.sl version [d541892fd7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVCRT.SL.9 07 April 83 % derived from <NOVAK>GEVCRT.PSL.1 20-Mar-83 12:41:24 % Written by Gordon Novak Jr. % Copyright (c) Hewlett-Packard 1983 (fluid '(n p)) (GLOBAL '(GEVMENUWINDOW GEVSAVEESC GEVSAVEGLQUIET GEVSAVEGCGAG GEVMOUSEAREA glquietflg gllispdialect gevtypenames gluserstrnames mouse terminal )) (DE GEVENTER NIL (setq gevsavegcgag !*GC) (setq !*GC nil) (SETQ GEVSAVEGLQUIET GLQUIETFLG) (SETQ GLQUIETFLG T) (echooff)) (DE GEVEXIT NIL (setq !*GC gevsavegcgag) (SETQ GLQUIETFLG GEVSAVEGLQUIET) (echoon)) % edited: 19-Mar-83 22:41 (DG GEVINITEDITWINDOW NIL (PROG NIL (GEVWINDOW _ (A WINDOW WITH START = (A VECTOR WITH X = 0 Y = 3) SIZE = (A VECTOR WITH X = 46 Y = 20) TITLE = "GEV Structure Inspector")) (RETURN GEVWINDOW))) % edited: 19-Mar-83 21:12 % Wait in a loop for mouse actions within the edit window. (DG GEVMOUSELOOP NIL (PROG (INP N TMP) LP (SEND GEVWINDOW MOVETOXY 0 -1) (SEND TERMINAL ERASEEOL) (SEND GEVWINDOW MOVETOXY 0 -1) (SEND TERMINAL PRINTSTRING "GEV: ") (echoon) (INP _ (READ)) (echooff) (SEND TERMINAL ERASEEOL) (IF INP=T AND (N _ (READ)) IS NUMERIC THEN (GEVNSELECT N NIL) (GO LP) ELSEIF INP IS NUMERIC THEN (GEVNSELECT INP T) (GO LP) ELSEIF (TMP _ (ASSOC INP '((Q QUIT) (POP POP) (E EDIT) (PR PROGRAM) (P PROP) (A ADJ) (I ISA) (M MSG)))) THEN (GEVCOMMANDFN (CADR TMP)) (IF (CADR TMP) ='QUIT OR ~GEVACTIVEFLG THEN (SEND GEVWINDOW MOVETOXY 0 -1) (SEND TERMINAL ERASEEOL) (RETURN NIL) ELSE (GO LP)) ELSEIF INP = 'R THEN (SEND GEVWINDOW OPEN) (GEVFILLWINDOW) (GO LP) ELSE (PRIN1 "? Quit POP Edit PRogram Prop Adj Isa Msg Redraw") (TERPRI) (GO LP)))) % edited: 19-Mar-83 21:42 % Select the Nth item in the display and push down to zoom in on it. (DG GEVNSELECT (N:INTEGER FLAG:BOOLEAN) (PROG (L TOP SUBLIST GROUP ITEM) (GROUP _ 0) (TOP _ GEVEDITCHAIN:TOPFRAME) LP (IF ~TOP THEN (RETURN NIL)) (SUBLIST -_ TOP) (GROUP _+ 1) (IF GROUP=1 AND (L _ (LENGTH SUBLIST)) >=N THEN (ITEM _ (CAR (PNth SUBLIST (L + 1 - N)))) ELSEIF ~ (ITEM _ (GEVNTHITEM SUBLIST)) THEN (GO LP)) (IF ITEM:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) THEN (RETURN NIL) ELSE (RETURN (GEVITEMEVENTFN ITEM GROUP FLAG))))) % edited: 19-Mar-83 22:15 % Find the Nth item in a tree structure of items. (DG GEVNTHITEM (L: (LISTOF GSEITEM)) (GLOBAL N:INTEGER)(PROG (TMP RES) (IF N<=0 THEN (ERROR 0 NIL) ELSEIF ~L THEN (RETURN NIL) ELSEIF N=1 THEN (RETURN (CAR L)) ELSE (N _- 1) (TMP -_ L) (IF TMP:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) AND (RES _ (GEVNTHITEM TMP:SUBVALUES)) THEN (RETURN RES) ELSE (RETURN (GEVNTHITEM L)))))) (GLISPCONSTANTS (GEVNUMBERCHARS 2 INTEGER) (GEVNUMBERPOS 1 INTEGER) ) (SETQ GEVMENUWINDOW NIL) (SETQ GEVMOUSEAREA NIL) |
Added psl-1983/3-1/glisp/gevdemo.old version [8e0c17e0ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED " 8-NOV-82 09:44:50" {DSK}GEVDEMO.LSP;22 10081 changes to: (FNS GEVDEMO-INIT) (VARS GEVDEMOCOMS) previous date: "26-OCT-82 16:10:02" {DSK}GEVDEMO.LSP;20) (PRETTYCOMPRINT GEVDEMOCOMS) (RPAQQ GEVDEMOCOMS ((GLISPOBJECTS PROJECT CONTRACT AGENCY PERSON BUDGET ADDRESS PHONE-NUMBER DATE PICTURE CAMPUS-ADDRESS BUILDING CIRCLE VECTOR RADIANS DEGREES RVECTOR) (FNS GEVDEMO-INIT TODAYS-DATE TOTAL-BUDGET) (PROP GLRESULTTYPE TODAYS-DATE) (P (GEVDEMO-INIT)))) [GLISPOBJECTS (PROJECT [ATOM (PROPLIST (TITLE STRING) (ABBREVIATION ATOM) (ADMINISTRATOR PERSON) (CONTRACTS (LISTOF CONTRACT)) (EXECUTIVES (LISTOF PERSON] PROP ((SHORTVALUE (ABBREVIATION)) (DISPLAYPROPS (T)) (BUDGET TOTAL-BUDGET)) ) (CONTRACT (ATOM (PROPLIST (TITLE STRING) (LEADER PERSON) (SPONSOR AGENCY) (BUDGET BUDGET))) PROP ((SHORTVALUE (TITLE))) ) (AGENCY (ATOM (PROPLIST (NAME STRING) (ABBREVIATION ATOM) (ADDRESS ADDRESS) (PHONE PHONE-NUMBER))) PROP ((SHORTVALUE (ABBREVIATION))) ) (PERSON (ATOM (PROPLIST (NAME STRING) (INITIALS ATOM) (TITLE ATOM) (PROJECT PROJECT) (SALARY REAL) (SSNO INTEGER) (BIRTHDATE DATE) (PHONE PHONE-NUMBER) (OFFICE CAMPUS-ADDRESS) (HOME-ADDRESS ADDRESS) (HOME-PHONE PHONE-NUMBER) (PICTURE PICTURE))) PROP ((SHORTVALUE (INITIALS)) (CONTRACTS ((THOSE CONTRACTS OF PROJECT WITH LEADER=self))) (AGE ((THE YEAR OF (TODAYS-DATE)) - BIRTHDATE:YEAR)) (MONTHLY-SALARY (SALARY/12)) (DISPLAYPROPS (T))) ADJ [(FACULTY ((MEMB TITLE (QUOTE (PROF ASSOC-PROF ASST-PROF] ) (BUDGET (LIST (LABOR REAL) (COMPUTER REAL)) PROP ((OVERHEAD (LABOR*0.59)) (TOTAL (LABOR+OVERHEAD+COMPUTER)) (SHORTVALUE (TOTAL)) (DISPLAYPROPS (T))) ) (ADDRESS (LIST (STREET STRING) (CITY STRING) (STATE ATOM) (ZIP INTEGER)) PROP [(SHORTVALUE ((CONCAT CITY ", " STATE] ) (PHONE-NUMBER (LIST (AREA INTEGER) (NUMBER INTEGER)) PROP [(SHORTVALUE ((CONCAT "(" AREA ") " (SUBSTRING NUMBER 1 3) "-" (SUBSTRING NUMBER 4 7] ADJ ((LOCAL (AREA=415 OR AREA=408))) ) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (SHORTYEAR INTEGER)) PROP [[MONTHNAME ((CAR (NTH (QUOTE (January February March April May June July August September October November December)) MONTH] (YEAR (SHORTYEAR + 1900)) (SHORTVALUE ((CONCAT MONTHNAME " " DAY ", " YEAR] ) (PICTURE ANYTHING MSG ((EDIT PAINTW) (GEVDISPLAY PICTURE-GEVDISPLAY)) ) (CAMPUS-ADDRESS (LIST (BUILDING BUILDING) (ROOM ATOM)) PROP [(SHORTVALUE ((CONCAT BUILDING:ABBREVIATION " " ROOM] ) (BUILDING (ATOM (PROPLIST (ABBREVIATION ATOM) (NAME STRING) (NUMBER INTEGER))) PROP ((SHORTVALUE (NAME))) ) (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP [(PI (3.141593)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) (SQUARESIDE ((SQRT AREA))) (DISPLAYPROPS ((QUOTE (DIAMETER CIRCUMFERENCE AREA] MSG ((GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) (STANDARD (AREA_100.0))) ADJ ((BIG (AREA>100)) (SMALL (AREA<80))) ) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP [(MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE , Y = Y/MAGNITUDE] ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG [(PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI] ) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T))) ) (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T))) ) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR) ) ] (DEFINEQ (GEVDEMO-INIT [GLAMBDA NIL (* edited: " 6-NOV-82 14:41") (* Initialize data structures for GEV demo.) (PROG NIL (HPP _(A PROJECT WITH TITLE = "Heuristic Programming Project" , ABBREVIATION =(QUOTE HPP))) (MJH _(A BUILDING WITH ABBREVIATION =(QUOTE MJH) , NAME = "Margaret Jacks Hall" , NUMBER = 460)) (ARPA _(AN AGENCY WITH NAME = "Defense Advanced Research Projects Agency" , ABBREVIATION =(QUOTE ARPA) , ADDRESS =(AN ADDRESS WITH STREET = "1400 Wilson Blvd." , CITY = "Arlington" , STATE =(QUOTE VA) , ZIP = 22209) , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER = 6944349))) (NSF _(AN AGENCY WITH NAME = "National Science Foundation" , ABBREVIATION =(QUOTE NSF) , ADDRESS =(AN ADDRESS WITH STREET = "1800 G STREET N.W." , CITY = "Washington" , STATE =(QUOTE DC) , ZIP = 20550) , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER = 6327346))) (NIH _(AN AGENCY WITH NAME = "National Institutes of Health" , ABBREVIATION =(QUOTE NIH) , ADDRESS =(AN ADDRESS WITH STREET = "9000 Rockville Pike" , CITY = "Bethesda" , STATE =(QUOTE MD) , ZIP = 20001) , PHONE =(A PHONE-NUMBER WITH AREA = 301 , NUMBER = 4964000))) (GSN _(A PERSON WITH NAME = "Gordon S. Novak Jr." , INITIALS =(QUOTE GSN) , TITLE =(QUOTE VISITOR) , PROJECT = HPP , SALARY = 30000.0 , SSNO = 455827977 , BIRTHDATE =(A DATE WITH DAY = 21 , MONTH = 7 , SHORTYEAR = 47) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4974532) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 244) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4935807) , HOME-ADDRESS =(AN ADDRESS WITH STREET = "3857 Ross Road" , CITY = "Palo Alto" , STATE =(QUOTE CA) , ZIP = 94303))) (TCR _(A PERSON WITH NAME = "Tom C. Rindfleisch" , INITIALS =(QUOTE TCR) , TITLE =(QUOTE ADMINISTRATOR) , PROJECT = HPP , SALARY = 30000.0 , SSNO = 452123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 47) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4972780) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4324321) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 236) , HOME-ADDRESS =(AN ADDRESS))) (EAF _(A PERSON WITH NAME = "Edward A. Feigenbaum" , INITIALS =(QUOTE EAF) , TITLE =(QUOTE PROF) , PROJECT = HPP , SALARY = 99999.0 , SSNO = 123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 37) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4974878) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 226) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4931234) , HOME-ADDRESS =(AN ADDRESS WITH STREET = " " , CITY = "Stanford" , STATE =( QUOTE CA) , ZIP = 94305))) (MRG _(A PERSON WITH NAME = "Michael R. Genesereth" , INITIALS =(QUOTE MRG) , TITLE =(QUOTE ASST-PROF) , PROJECT = HPP , SALARY = 31234.0 , SSNO = 123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 50) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4970324) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 234) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4324321) , HOME-ADDRESS =(AN ADDRESS))) (J5 _(A CONTRACT WITH TITLE = "Advanced A.I. Architectures" , LEADER = EAF , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 50000.0 , COMPUTER = 10000.0))) (IA _(A CONTRACT WITH TITLE = "Intelligent Agents" , LEADER = MRG , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 70000.0 , COMPUTER = 50000.0))) (DART _(A CONTRACT WITH TITLE = "Diagnosis and Repair Techniques" , LEADER = MRG , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 100000.0 , COMPUTER = 150000.0))) (GLISP _(A CONTRACT WITH TITLE = "GLISP" , LEADER = GSN , SPONSOR = ARPA , BUDGET =( A BUDGET WITH LABOR = 50000.0 , COMPUTER = 20000.0))) (CMPICTURE _(CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 100 HEIGHT _ 100))) (CM _(A PERSON WITH NAME = "Cookie Monster" , INITIALS =(QUOTE CM) , TITLE =(QUOTE MONSTER) , PROJECT = HPP , SALARY = 1.0 , SSNO = 123456789 , BIRTHDATE =(A DATE WITH MONTH = 4 , DAY = 1 , SHORTYEAR = 65) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4971234) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 252) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4561234) , HOME-ADDRESS =(AN ADDRESS WITH STREET = "123 Sesame Street" , CITY = "Palo Alto" , STATE =(QUOTE CA) , ZIP = 94303) , PICTURE = CMPICTURE)) (CARBM _(A CONTRACT WITH TITLE = "Carbohydrate Metabolism in Atypical Hominids" , LEADER = CM , SPONSOR = NIH , BUDGET =(A BUDGET WITH LABOR = 1.39 , COMPUTER = 5.0))) (HPP:ADMINISTRATOR _ TCR) (HPP:CONTRACTS _(LIST J5 IA DART GLISP CARBM)) (HPP:EXECUTIVES _(LIST EAF MRG GSN TCR)) (C _(A CIRCLE WITH START =(A VECTOR WITH X = 1 , Y = 1) , RADIUS = 5.0]) (TODAYS-DATE (GLAMBDA NIL (* edited: "22-OCT-82 16:54") (A DATE WITH MONTH = 10 , DAY = 15 , SHORTYEAR = 82))) (TOTAL-BUDGET (GLAMBDA (P:PROJECT) (* edited: "22-OCT-82 17:13") (PROG (SUM) (SUM_0.0) (FOR EACH CONTRACT SUM_+BUDGET:TOTAL) (RETURN SUM)))) ) (PUTPROPS TODAYS-DATE GLRESULTTYPE DATE) (GEVDEMO-INIT) (DECLARE: DONTCOPY (FILEMAP (NIL (4061 9998 (GEVDEMO-INIT 4071 . 9592) (TODAYS-DATE 9594 . 9764) (TOTAL-BUDGET 9766 . 9996))))) STOP |
Added psl-1983/3-1/glisp/gevdemo.sl version [3616208b43].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GEVDEMO.PSL;1 5-FEB-83 15:41:04 (GLISPOBJECTS (PROJECT (ATOM (PROPLIST (TITLE STRING) (ABBREVIATION ATOM) (ADMINISTRATOR PERSON) (CONTRACTS (LISTOF CONTRACT)) (EXECUTIVES (LISTOF PERSON)))) PROP ((SHORTVALUE (ABBREVIATION)) (DISPLAYPROPS (T)) (BUDGET TOTAL-BUDGET))) (CONTRACT (ATOM (PROPLIST (TITLE STRING) (LEADER PERSON) (SPONSOR AGENCY) (BUDGET BUDGET))) PROP ((SHORTVALUE (TITLE)))) (AGENCY (ATOM (PROPLIST (NAME STRING) (ABBREVIATION ATOM) (ADDRESS ADDRESS) (PHONE PHONE-NUMBER))) PROP ((SHORTVALUE (ABBREVIATION)))) (PERSON (ATOM (PROPLIST (NAME STRING) (INITIALS ATOM) (TITLE ATOM) (PROJECT PROJECT) (SALARY REAL) (SSNO INTEGER) (BIRTHDATE DATE) (PHONE PHONE-NUMBER) (OFFICE CAMPUS-ADDRESS) (HOME-ADDRESS ADDRESS) (HOME-PHONE PHONE-NUMBER) (PICTURE PICTURE))) PROP ((SHORTVALUE (INITIALS)) (CONTRACTS ((THOSE CONTRACTS OF PROJECT WITH LEADER=self))) (AGE ((THE YEAR OF (TODAYS-DATE)) - BIRTHDATE:YEAR)) (MONTHLY-SALARY (SALARY/12)) (DISPLAYPROPS (T))) ADJ ((FACULTY ((MEMQ TITLE '(PROF ASSOC-PROF ASST-PROF)))))) (BUDGET (LIST (LABOR REAL) (COMPUTER REAL)) PROP ((OVERHEAD (LABOR * 0.59)) (TOTAL (LABOR+OVERHEAD+COMPUTER)) (SHORTVALUE (TOTAL)) (DISPLAYPROPS (T)))) (ADDRESS (LIST (STREET STRING) (CITY STRING) (STATE ATOM) (ZIP INTEGER)) PROP ((SHORTVALUE ((CONCATL CITY ", " STATE))))) (PHONE-NUMBER (LIST (AREA INTEGER) (NUMBER INTEGER)) PROP ((SHORTVALUE ((CONCATL "(" AREA ") " (SUBSTRING NUMBER 1 3) "-" (SUBSTRING NUMBER 4 7))))) ADJ ((LOCAL (AREA=415 OR AREA=408)))) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (SHORTYEAR INTEGER)) PROP ((MONTHNAME ((NTH '(January February March April May June July August September October November December) MONTH))) (YEAR (SHORTYEAR + 1900)) (SHORTVALUE ((CONCATL MONTHNAME " " DAY ", " YEAR))))) (PICTURE ANYTHING MSG ((EDIT PAINTW) (GEVDISPLAY PICTURE-GEVDISPLAY))) (CAMPUS-ADDRESS (LIST (BUILDING BUILDING) (ROOM ATOM)) PROP ((SHORTVALUE ((CONCATL BUILDING:ABBREVIATION " " ROOM))))) (BUILDING (ATOM (PROPLIST (ABBREVIATION ATOM) (NAME STRING) (NUMBER INTEGER))) PROP ((SHORTVALUE (NAME)))) (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.141593)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) (SQUARESIDE ((SQRT AREA))) (DISPLAYPROPS ('(DIAMETER CIRCUMFERENCE AREA)))) MSG ((GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) (STANDARD (AREA_100.0))) ADJ ((BIG (AREA>100)) (SMALL (AREA<80)))) ) % edited: 6-NOV-82 14:41 % Initialize data structures for GEV demo. (DG GEVDEMO-INIT NIL (PROG NIL (HPP _ (A PROJECT WITH TITLE = "Heuristic Programming Project" ABBREVIATION = 'HPP)) (MJH _ (A BUILDING WITH ABBREVIATION = 'MJH NAME = "Margaret Jacks Hall" NUMBER = 460)) (ARPA _ (AN AGENCY WITH NAME = "Defense Advanced Research Projects Agency" ABBREVIATION = 'ARPA ADDRESS = (AN ADDRESS WITH STREET = "1400 Wilson Blvd." CITY = "Arlington" STATE = 'VA ZIP = 22209) PHONE = (A PHONE-NUMBER WITH AREA = 202 NUMBER = 6944349))) (NSF _ (AN AGENCY WITH NAME = "National Science Foundation" ABBREVIATION = 'NSF ADDRESS = (AN ADDRESS WITH STREET = "1800 G STREET N.W." CITY = "Washington" STATE = 'DC ZIP = 20550) PHONE = (A PHONE-NUMBER WITH AREA = 202 NUMBER = 6327346))) (NIH _ (AN AGENCY WITH NAME = "National Institutes of Health" ABBREVIATION = 'NIH ADDRESS = (AN ADDRESS WITH STREET = "9000 Rockville Pike" CITY = "Bethesda" STATE = 'MD ZIP = 20001) PHONE = (A PHONE-NUMBER WITH AREA = 301 NUMBER = 4964000))) (GSN _ (A PERSON WITH NAME = "Gordon S. Novak Jr." INITIALS = 'GSN TITLE = 'VISITOR PROJECT = HPP SALARY = 30000.0 SSNO = 455827977 BIRTHDATE = (A DATE WITH DAY = 21 MONTH = 7 SHORTYEAR = 47) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4974532) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 244) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4935807) HOME-ADDRESS = (AN ADDRESS WITH STREET = "3857 Ross Road" CITY = "Palo Alto" STATE = 'CA ZIP = 94303))) (TCR _ (A PERSON WITH NAME = "Tom C. Rindfleisch" INITIALS = 'TCR TITLE = 'ADMINISTRATOR PROJECT = HPP SALARY = 30000.0 SSNO = 452123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 47) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4972780) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4324321) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 236) HOME-ADDRESS = (AN ADDRESS))) (EAF _ (A PERSON WITH NAME = "Edward A. Feigenbaum" INITIALS = 'EAF TITLE = 'PROF PROJECT = HPP SALARY = 99999.0 SSNO = 123123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 37) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4974878) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 226) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4931234) HOME-ADDRESS = (AN ADDRESS WITH STREET = " " CITY = "Stanford" STATE = 'CA ZIP = 94305))) (MRG _ (A PERSON WITH NAME = "Michael R. Genesereth" INITIALS = 'MRG TITLE = 'ASST-PROF PROJECT = HPP SALARY = 31234.0 SSNO = 123123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 50) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4970324) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 234) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4324321) HOME-ADDRESS = (AN ADDRESS))) (J5 _ (A CONTRACT WITH TITLE = "Advanced A.I. Architectures" LEADER = EAF SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 50000.0 COMPUTER = 10000.0))) (IA _ (A CONTRACT WITH TITLE = "Intelligent Agents" LEADER = MRG SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 70000.0 COMPUTER = 50000.0))) (DART _ (A CONTRACT WITH TITLE = "Diagnosis and Repair Techniques" LEADER = MRG SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 100000.0 COMPUTER = 150000.0))) (GLISP _ (A CONTRACT WITH TITLE = "GLISP" LEADER = GSN SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 50000.0 COMPUTER = 20000.0))) (CM _ (A PERSON WITH NAME = "Cookie Monster" INITIALS = 'CM TITLE = 'MONSTER PROJECT = HPP SALARY = 1.0 SSNO = 123456789 BIRTHDATE = (A DATE WITH MONTH = 4 DAY = 1 SHORTYEAR = 65) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4971234) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 252) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4561234) HOME-ADDRESS = (AN ADDRESS WITH STREET = "123 Sesame Street" CITY = "Palo Alto" STATE = 'CA ZIP = 94303) )) (CARBM _ (A CONTRACT WITH TITLE = "Carbohydrate Metabolism in Atypical Hominids" LEADER = CM SPONSOR = NIH BUDGET = (A BUDGET WITH LABOR = 1.39 COMPUTER = 5.0))) (HPP:ADMINISTRATOR _ TCR) (HPP:CONTRACTS _ (LIST J5 IA DART GLISP CARBM)) (HPP:EXECUTIVES _ (LIST EAF MRG GSN TCR)) (C _ (A CIRCLE WITH START = (A VECTOR WITH X = 1 Y = 1) RADIUS = 5.0)))) % edited: 22-OCT-82 16:54 (DG TODAYS-DATE NIL (A DATE WITH MONTH = 10 DAY = 15 SHORTYEAR = 82)) % edited: 22-OCT-82 17:13 (DG TOTAL-BUDGET (P:PROJECT) (PROG (SUM) (SUM_0.0) (FOR EACH CONTRACT SUM _+ BUDGET:TOTAL) (RETURN SUM))) (PUT 'TODAYS-DATE 'GLRESULTTYPE 'DATE) % Now initialize te data structures for the demo. (gevdemo-init) |
Added psl-1983/3-1/glisp/gevhrd.sl version [1a89ccc3b9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEVHRD.SL.4 07 April 83 % derived from <NOVAK>GEVCRT.PSL.1 20-Mar-83 12:41:24 (fluid '(n)) (GLOBAL '(GEVMENUWINDOW GEVSAVEESC GEVSAVEGLQUIET GEVSAVEGCGAG GEVMOUSEAREA glquietflg gllispdialect gevtypenames gluserstrnames mouse terminal )) % TTY input replacement for mouse operations. % GSN 07 March 83 (dg gevmouseloop () (prog (input n tmp) lp (prin2 "GEV: ") (input _ (read)) (if input='t and (n _ (read)) is numeric then (gevnselect n nil) (go lp) elseif input is numeric then (gevnselect input t) (go lp) elseif (tmp _ (assoc input '((q quit)(pop pop)(e edit)(pr program) (p prop)(a adj)(i isa)(m msg)))) then (gevcommandfn (cadr tmp)) (if (cadr tmp)='quit or ~gevactiveflg then (return nil) else (go lp))) err (prin2 "? Quit POP Edit PRogram Prop Adj Isa Msg") (terpri) (go lp) )) (DE GEVENTER NIL (setq gevsavegcgag !*GC) (setq !*GC nil) (SETQ GEVSAVEGLQUIET GLQUIETFLG) (SETQ GLQUIETFLG T)) (DE GEVEXIT NIL (setq !*GC gevsavegcgag) (SETQ GLQUIETFLG GEVSAVEGLQUIET)) % edited: 19-Mar-83 22:41 (DG GEVINITEDITWINDOW NIL (PROG NIL (GEVWINDOW _ (A WINDOW WITH START = (A VECTOR WITH X = 0 Y = 0) SIZE = (A VECTOR WITH X = 400 Y = 500) TITLE = "GEV Structure Inspector")) (RETURN GEVWINDOW))) % edited: 19-Mar-83 21:42 % Select the Nth item in the display and push down to zoom in on it. (DG GEVNSELECT (N:INTEGER FLAG:BOOLEAN) (PROG (L TOP SUBLIST GROUP ITEM) (GROUP _ 0) (TOP _ GEVEDITCHAIN:TOPFRAME) LP (IF ~TOP THEN (RETURN NIL)) (SUBLIST -_ TOP) (GROUP _+ 1) (IF GROUP=1 AND (L _ (LENGTH SUBLIST)) >=N THEN (ITEM _ (CAR (PNth SUBLIST (L + 1 - N)))) ELSEIF ~ (ITEM _ (GEVNTHITEM SUBLIST)) THEN (GO LP)) (IF ITEM:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) THEN (RETURN NIL) ELSE (RETURN (GEVITEMEVENTFN ITEM GROUP FLAG))))) % edited: 19-Mar-83 22:15 % Find the Nth item in a tree structure of items. (DG GEVNTHITEM (L: (LISTOF GSEITEM)) (GLOBAL N:INTEGER)(PROG (TMP RES) (IF N<=0 THEN (ERROR 0 NIL) ELSEIF ~L THEN (RETURN NIL) ELSEIF N=1 THEN (RETURN (CAR L)) ELSE (N _- 1) (TMP -_ L) (IF TMP:NODETYPE <= '(STRUCTURE SUBTREE LISTOF) AND (RES _ (GEVNTHITEM TMP:SUBVALUES)) THEN (RETURN RES) ELSE (RETURN (GEVNTHITEM L)))))) (GLISPCONSTANTS (GEVNUMBERCHARS 2 INTEGER) (GEVNUMBERPOS 1 INTEGER) ) (SETQ GEVMENUWINDOW NIL) (SETQ GEVMOUSEAREA NIL) |
Added psl-1983/3-1/glisp/gevnew.sl version [9148fb21f3].
> | 1 | (de gevdonewfn (x) (gevnewfn x)) |
Added psl-1983/3-1/glisp/gevt.b version [fa9bb2b5e5].
cannot compute difference between binary files
Added psl-1983/3-1/glisp/gevt.sl version [545799931f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (fluid '(p)) (DE SUBSTRING (STRING FIRST LAST) (COND ((NOT (STRINGP STRING)) (SETQ STRING ( GEVSTRINGIFY STRING)))) (COND ((MINUSP FIRST) (SETQ FIRST (ADD1 (PLUS (ADD1 ( SIZE STRING)) FIRST))))) (COND ((MINUSP LAST) (SETQ LAST (ADD1 (PLUS (ADD1 ( SIZE STRING)) LAST))))) (SUBSEQ STRING (SUB1 FIRST) LAST)) (DE GEVSTRINGIFY (X) (COND ((STRINGP X) X) (T (BLDMSG "%p" X)))) (DE CONCATN (L) (COND ((NULL L) "") ((NULL (CDR L)) (GEVSTRINGIFY (CAR L))) ( T (CONCAT (GEVSTRINGIFY (CAR L)) (CONCATN (CDR L)))))) (DE CONCATLN (L) (COND ((NULL L) "") ((NULL (CDR L)) (GEVSTRINGIFY (EVAL ( CAR L)))) (T (CONCAT (GEVSTRINGIFY (EVAL (CAR L))) (CONCATLN (CDR L)))))) (DF CONCATL (CONCATLARG) (CONCATLN CONCATLARG)) (DE GEVCONCAT (L) (CONCATN L)) (DE DREVERSE (L) (REVERSIP L)) (DE MKATOM (S) (INTERN S)) (DE GEVPUTD (FN FORM) (PUT FN (QUOTE GLORIGINALEXPR) (CONS (QUOTE LAMBDA) ( CDR FORM))) (PUT FN (QUOTE GLCOMPILED) NIL) (REMD FN) (PUTD FN (QUOTE MACRO) ( QUOTE (LAMBDA (GLDGFORM) (GLHOOK GLDGFORM))))) (DE GEVAPPLY (FN ARGS) (COND ((AND (ATOM FN) (OR (NULL (GET FN (QUOTE GLCOMPILED))) (NOT (EQ (GETDDD FN) (GET FN (QUOTE GLCOMPILED)))))) (GLCC FN) ( APPLY FN ARGS)) (T (APPLY FN ARGS)))) (GLOBAL (QUOTE (TERMINAL))) (GLISPOBJECTS (TERMINAL ATOM MSG ((MOVETOXY TERMINAL-MOVETOXY) (PRINTCHAR TERMINAL-PRINTCHAR OPEN T) (PRINTSTRING TERMINAL-PRINTSTRING) (INVERTVIDEO ( NIL)) (NORMALVIDEO (NIL)) (GRAPHICSMODE (NIL)) (NORMALMODE (NIL)) (ERASEEOL (( PBOUT (CHAR ESC)) (PBOUT (CHAR K))))))) (GLISPGLOBALS (TERMINAL TERMINAL)) (GLISPCONSTANTS (BLANKCHAR 32 INTEGER) (HORIZONTALLINECHAR 45 INTEGER) ( HORIZONTALBARCHAR 95 INTEGER) (LVERTICALBARCHAR 124 INTEGER) ( RVERTICALBARCHAR 124 INTEGER) (ESCAPECHAR 27 INTEGER)) (DE TERMINAL-MOVETOXY (TERM X Y) (COND ((LESSP X 0) (SETQ X 0)) ((GREATERP X 79) (SETQ X 79))) (COND ((LESSP Y 0) (SETQ Y 0)) ((GREATERP Y 23) (SETQ Y 23))) (PROG (S) (SETQ S (CHAR ESC)) (PBOUT S)) (PROG (S) (SETQ S (CHAR Y)) ( PBOUT S)) (PROG (S) (SETQ S (DIFFERENCE 55 Y)) (PBOUT S)) (PROG (S) (SETQ S ( PLUS 32 X)) (RETURN (PBOUT S)))) (DE TERMINAL-PRINTCHAR (TERM S) (PBOUT S)) (DE TERMINAL-PRINTSTRING (TERM S) (PROG (I N) (COND ((NOT (STRINGP S)) (SETQ S (GEVSTRINGIFY S)))) (SETQ N (ADD1 (SIZE S))) (SETQ I 0) (PROG NIL GLLABEL1 ( COND ((LESSP I N) (PBOUT (INDX S I)) (SETQ I (ADD1 I)) (GO GLLABEL1)))))) (SETQ TERMINAL (QUOTE VT52)) (GLOBAL (QUOTE (MENUSTART))) (GLISPOBJECTS (MENU (LISTOBJECT (ITEMS (LISTOF ATOM)) (WINDOW WINDOW)) MSG (( SELECT MENU-SELECT RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (LISTOBJECT ( START VECTOR) (SIZE VECTOR) (TITLE STRING) (LASTFILLEDLINE INTEGER)) PROP (( YPOSITION (LASTFILLEDLINE)) (LEFTMARGIN (1)) (RIGHTMARGIN (WIDTH !- 2))) MSG (( CLEAR WINDOW-CLEAR) (OPEN WINDOW-OPEN) (CLOSE WINDOW-CLOSE) (INVERTAREA WINDOW-INVERTAREA OPEN T) (MOVETOXY WINDOW-MOVETOXY OPEN T) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (CENTEROFFSET WINDOW-CENTEROFFSET OPEN T)) SUPERS (REGION))) (GLISPGLOBALS (MOUSE MOUSE)) (GLISPCONSTANTS (WINDOWCHARWIDTH 1 INTEGER) (WINDOWLINEYSPACING 1 INTEGER)) (SETQ MOUSE (QUOTE MOUSE)) (SETQ GEVMENUWINDOW NIL) (SETQ MENUSTART (A VECTOR WITH X = 50 Y = 3)) (DE MENU-SELECT (M) (PROG (MAXW I N SAVEESC SAVEGLQ SAVEGCG RESULT) (COND (( NOT GEVACTIVEFLG) (GEVENTER))) (SETQ SAVEGLQ GLQUIETFLG) (SETQ GLQUIETFLG T) ( SETQ MAXW 0) (MAPC (CADR M) (FUNCTION (LAMBDA (X) (SETQ MAXW (MAX MAXW (PROG ( SELF) (SETQ SELF (ID2STRING X)) (RETURN (ADD1 (SIZE SELF))))))))) (COND (( GREATERP MAXW 20) (SETQ MAXW 20))) (RPLACA (CDDR M) (LIST (QUOTE WINDOW) MENUSTART (LIST (TIMES (PLUS MAXW 5) 1) (TIMES (MIN (ADD1 (LENGTH (CADR M))) 19) 1)) "Menu" 0)) (WINDOW-OPEN (CADDR M)) (SETQ I 0) (MAPC (CADR M) ( FUNCTION (LAMBDA (X) (SETQ I (ADD1 I)) (PROG (W S POS) (SETQ W (CADDR M)) ( SETQ S (CONCAT (GEVSTRINGIFY I) (CONCAT (COND ((LESSP I 10) " ") (T " ")) ( GEVSTRINGIFY X)))) (SETQ POS (LIST 1 (DIFFERENCE (PROG (SELF) (SETQ SELF ( CADDR M)) (RETURN (CADR (CADDR SELF)))) I))) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH W 5))) (RPLACA ( PNTH W 5) (CADR POS)))))))))) (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) (PBOUT ( CHAR ESC)) (PBOUT (CHAR K)) LP (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) ( TERMINAL-PRINTSTRING TERMINAL "Menu: ") (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( ECHOON) (SETQ N (READ)) (ECHOOFF) (COND ((AND (FIXP N) (GREATERP N 0) (NOT ( GREATERP N (LENGTH (CADR M))))) (SETQ RESULT (CAR (PNTH (CADR M) N))) (GO OUT)) ((EQ N (QUOTE Q)) (SETQ RESULT NIL) (GO OUT)) (T (PRIN1 N) (SPACES 1) (TERMINAL-PRINTSTRING TERMINAL "?") (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( GO LP))) OUT (WINDOW-CLOSE (CADDR M)) (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) (TERPRI) ( PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (SETQ GLQUIETFLG SAVEGLQ) (COND ((NOT GEVACTIVEFLG) (GEVEXIT))) (RETURN RESULT))) (DE PRINTNC (N C) (PROG NIL GLLABEL1 (COND ((GREATERP N 0) (SETQ N (SUB1 N)) ( PBOUT C) (GO GLLABEL1))))) (DE WINDOW-CLEAR (W) (PROG (TTL NBL Y NLINES) (SETQ NLINES 0) NIL (SETQ Y ( SUB1 (CADR (CADDR W)))) (PROG NIL GLLABEL1 (COND ((NOT (LESSP Y (CAR (PNTH W 5)))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS Y (CADADR W))) ( PBOUT 124) (COND ((LESSP Y (PLUS (CADADR W) (CADR (CADDR W)))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)))) (PROG (X) (SETQ X (SUB1 (CAADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (COND ((GREATERP (SETQ NLINES (ADD1 NLINES)) 3) (TERPRI) (SETQ NLINES 0))) (SETQ Y (SUB1 Y)) (GO GLLABEL1)))) NIL (TERMINAL-MOVETOXY TERMINAL ( PLUS 0 (CAADR W)) (PLUS -1 (CADADR W))) (TERPRI) (RPLACA (PNTH W 5) (CADR ( CADDR W))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) ) (DE WINDOW-CLOSE (W) (PROG (Y NLINES) (SETQ Y (CADR (CADDR W))) (SETQ NLINES 0) (PROG NIL GLLABEL1 (COND ((NOT (LESSP Y 0)) (TERMINAL-MOVETOXY TERMINAL ( PLUS 0 (CAADR W)) (PLUS Y (CADADR W))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( COND ((GREATERP (SETQ NLINES (ADD1 NLINES)) 8) (TERPRI) (SETQ NLINES 0))) ( SETQ Y (SUB1 Y)) (GO GLLABEL1)))) (TERPRI))) (DE WINDOW-DRAWLINE (W FROM TO) (COND ((EQN (CADR FROM) (CADR TO)) (PROG (X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) (TERMINAL-MOVETOXY TERMINAL ( PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (DIFFERENCE (CAR TO) ( CAR FROM))) 45) (COND ((LESSP (CADR FROM) (CAR (PNTH W 5))) (CAR (RPLACA ( PNTH W 5) (CADR FROM)))))))) (DE WINDOW-INVERTAREA (W AREA) NIL) (DE WINDOW-MOVETO (W POS) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( RETURN (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))))) (DE WINDOW-MOVETOXY (W X Y) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) ( PLUS Y (CADADR W)))) (DE WINDOW-OPEN (W) (PROG (TTL NBL L) (PROG (Y) (SETQ Y (CADR (CADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS 1 (CAADR W)) (PLUS Y (CADADR W)))) (SETQ TTL (OR (CADDDR W) " ")) (SETQ L (ADD1 (SIZE TTL))) NIL (COND ((GREATERP ( ADD1 (SIZE TTL)) (DIFFERENCE (CAADDR W) 2)) (SETQ TTL (SUBSTRING TTL 1 ( DIFFERENCE (CAADDR W) 2))))) (SETQ NBL (SUB1 (QUOTIENT (DIFFERENCE (CAADDR W) ( ADD1 (SIZE TTL))) 2))) (PRINTNC NBL 32) (TERMINAL-PRINTSTRING TERMINAL TTL) ( PRINTNC (DIFFERENCE (DIFFERENCE (DIFFERENCE (CAADDR W) (ADD1 (SIZE TTL))) NBL) 2) 32) NIL (TERPRI) NIL (RPLACA (PNTH W 5) 1) (PROG (Y) (SETQ Y (CADR ( CADDR W))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (PROG (X Y) (SETQ X (SUB1 (CAADDR W))) (SETQ Y (CADR (CADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS 0 (CADADR W))) ( PBOUT 124) (PRINTNC (DIFFERENCE (CAADDR W) 2) 95) (PBOUT 124) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) NIL (TERPRI) (WINDOW-CLEAR W) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W))))) (DE WINDOW-PRETTYPRINTAT (W VALUE POSITION) (PROG (X Y) (SETQ X (CAR POSITION)) (SETQ Y (CADR POSITION)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (RESETLST (RESETSAVE SYSPRETTYFLG T) ( RESETSAVE TTYLINELENGTH (SUB1 (DIFFERENCE (CAADDR W) (CAR POSITION)))) ( SHOWPRINT VALUE) (CAR (RPLACA (PNTH W 5) 1)))) (DE WINDOW-PRINTAT (W S POS) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) ( COND ((LESSP (CADR POS) (CAR (PNTH W 5))) (CAR (RPLACA (PNTH W 5) (CADR POS))))) ))) (DE WINDOW-UNDRAWLINE (W FROM TO) (COND ((EQN (CADR FROM) (CADR TO)) (PROG ( X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) (TERMINAL-MOVETOXY TERMINAL ( PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (DIFFERENCE (CAR TO) ( CAR FROM))) 32)))) (DE WINDOW-UNPRINTAT (W S POS) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (SIZE S)) 32)))) (FLUID (QUOTE (N))) (GLOBAL (QUOTE (GEVMENUWINDOW GEVSAVEESC GEVSAVEGLQUIET GEVSAVEGCGAG GEVMOUSEAREA GLQUIETFLG GLLISPDIALECT GEVTYPENAMES GLUSERSTRNAMES MOUSE TERMINAL))) (DE GEVENTER NIL (SETQ GEVSAVEGCGAG *GC) (SETQ *GC NIL) (SETQ GEVSAVEGLQUIET GLQUIETFLG) (SETQ GLQUIETFLG T) (ECHOOFF)) (DE GEVEXIT NIL (SETQ *GC GEVSAVEGCGAG) (SETQ GLQUIETFLG GEVSAVEGLQUIET) ( ECHOON)) (DE GEVINITEDITWINDOW NIL (PROG NIL (SETQ GEVWINDOW (LIST (QUOTE WINDOW) ( APPEND (QUOTE (0 3)) NIL) (APPEND (QUOTE (46 20)) NIL) "GEV Structure Inspector" 0)) (RETURN GEVWINDOW))) (DE GEVMOUSELOOP NIL (PROG (INP N TMP) LP (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 (CADADR GEVWINDOW))) (PBOUT (CHAR ESC)) (PBOUT ( CHAR K)) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 ( CADADR GEVWINDOW))) (TERMINAL-PRINTSTRING TERMINAL "GEV: ") (ECHOON) (SETQ INP (READ)) (ECHOOFF) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (COND ((AND (EQUAL INP T) (NUMBERP (SETQ N (READ)))) (GEVNSELECT N NIL) (GO LP)) ((NUMBERP INP) ( GEVNSELECT INP T) (GO LP)) ((SETQ TMP (ASSOC INP (QUOTE ((Q QUIT) (POP POP) ( E EDIT) (PR PROGRAM) (P PROP) (A ADJ) (I ISA) (M MSG))))) (GEVCOMMANDFN ( CADR TMP)) (COND ((OR (EQ (CADR TMP) (QUOTE QUIT)) (NOT GEVACTIVEFLG)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 (CADADR GEVWINDOW))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (RETURN NIL)) (T (GO LP)))) (( EQ INP (QUOTE R)) (WINDOW-OPEN GEVWINDOW) (GEVFILLWINDOW) (GO LP)) (T (PRIN1 "? Quit POP Edit PRogram Prop Adj Isa Msg Redraw") (TERPRI) (GO LP))))) (DE GEVNSELECT (N FLAG) (PROG (L TOP SUBLIST GROUP ITEM) (SETQ GROUP 0) ( SETQ TOP (CAR GEVEDITCHAIN)) LP (COND ((NOT TOP) (RETURN NIL))) (SETQ SUBLIST (CAR TOP)) (SETQ TOP (CDR TOP)) (SETQ GROUP (ADD1 GROUP)) (COND (( AND (EQN GROUP 1) (NOT (LESSP (SETQ L (LENGTH SUBLIST)) N))) (SETQ ITEM (CAR ( PNTH SUBLIST (DIFFERENCE (ADD1 L) N))))) ((NOT (SETQ ITEM (GEVNTHITEM SUBLIST))) (GO LP))) (COND ((MEMQ (CAR (PNTH ITEM 5)) (QUOTE (STRUCTURE SUBTREE LISTOF))) (RETURN NIL)) (T (RETURN (GEVITEMEVENTFN ITEM GROUP FLAG)))))) (DE GEVNTHITEM (L) (PROG (TMP RES) (COND ((NOT (GREATERP N 0)) (ERROR 0 NIL)) (( NOT L) (RETURN NIL)) ((EQN N 1) (RETURN (CAR L))) (T (SETQ N (SUB1 N)) (SETQ TMP (CAR L)) (SETQ L (CDR L)) (COND ((AND (MEMQ (CAR (PNTH TMP 5)) (QUOTE ( STRUCTURE SUBTREE LISTOF))) (SETQ RES (GEVNTHITEM (CAR (PNTH TMP 6))))) ( RETURN RES)) (T (RETURN (GEVNTHITEM L)))))))) (GLISPCONSTANTS (GEVNUMBERCHARS 2 INTEGER) (GEVNUMBERPOS 1 INTEGER)) (SETQ GEVMENUWINDOW NIL) (SETQ GEVMOUSEAREA NIL) (FLUID (QUOTE (GLNATOM RESULT Y))) (GLOBAL (QUOTE (GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY))) (GLISPGLOBALS (GEVACTIVEFLG BOOLEAN) (GEVEDITCHAIN EDITCHAIN) (GEVEDITFLG BOOLEAN) (GEVLASTITEMNUMBER INTEGER) (GEVMENUWINDOW WINDOW) ( GEVMENUWINDOWHEIGHT INTEGER) (GEVMOUSEAREA MOUSESTATE) (GEVSHORTCHARS INTEGER) (GEVWINDOW WINDOW) (GEVWINDOWY INTEGER)) (GLISPCONSTANTS (GEVMOUSEBUTTON 4 INTEGER) (GEVNAMECHARS 11 INTEGER) ( GEVVALUECHARS 27 INTEGER) (GEVNAMEPOS (GEVNUMBERPOS !+ (IF GEVNUMBERCHARS > 0 THEN (GEVNUMBERCHARS !+ 1) *WINDOWCHARWIDTH ELSE 0)) INTEGER) (GEVTILDEPOS ( GEVNAMEPOS !+ (GEVNAMECHARS+1) *WINDOWCHARWIDTH) INTEGER) (GEVVALUEPOS ( GEVTILDEPOS !+ !2*WINDOWCHARWIDTH) INTEGER)) (GLISPOBJECTS (EDITCHAIN (LISTOF EDITFRAME) PROP ((TOPFRAME ((CAR SELF))) ( TOPITEM ((CAR TOPFRAME:PREVS))))) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) ( SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM)))) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) ( SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP (( NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = WINDOWCHARWIDTH* ( NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))))) (MOUSESTATE (LIST (AREA REGION) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER)))) (DF GEV (ARGS) (GEVA (CAR ARGS) (EVAL (CAR ARGS)) (AND (CDR ARGS) (COND ((OR ( NOT (ATOM (CADR ARGS))) (NOT (UNBOUNDP (CADR ARGS)))) (EVAL (CADR ARGS))) (T ( CADR ARGS)))))) (DE GEVA (VAR VAL STR) (PROG (GLNATOM TMP HEADER) (GEVENTER) (COND ((OR (NOT ( NOT (UNBOUNDP (QUOTE GEVWINDOW)))) (NULL GEVWINDOW)) (GEVINITEDITWINDOW))) ( COND (GEVMENUWINDOW (WINDOW-OPEN GEVMENUWINDOW))) (WINDOW-OPEN GEVWINDOW) ( SETQ GEVACTIVEFLG T) (SETQ GEVEDITFLG NIL) (SETQ GLNATOM 0) (SETQ GEVSHORTCHARS 27) (COND ((AND (PAIRP VAR) (EQ (CAR VAR) (QUOTE QUOTE))) ( SETQ VAR (CONCAT "'" (GEVSTRINGIFY (CADR VAR)))))) (COND ((NOT STR) (COND (( AND (ATOM VAL) (GET VAL (QUOTE GLSTRUCTURE))) (SETQ STR (QUOTE GLTYPE))) (( GEVGLISPP) (SETQ STR (GLCLASS VAL)))))) (SETQ HEADER (LIST VAR VAL STR NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))) (SETQ GEVEDITCHAIN (LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) ( GEVMOUSELOOP) (GEVEXIT))) (DE GEVCOMMANDFN (COMMANDWORD) (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASEQ COMMANDWORD (EDIT (GEVEDIT)) (QUIT (COND (GEVMOUSEAREA (PROG ( AREA) (SETQ AREA (CAR GEVMOUSEAREA))) (SETQ GEVMOUSEAREA NIL)) (T (GEVQUIT)))) ( POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (SETQ TOPITEM ( CAAAR GEVEDITCHAIN)) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) (T (ERROR 0 NIL))))) (DE GEVCOMMANDPROP (ITEM COMMANDWORD PROPNAME) (PROG (VAL PROPNAMES FLG) ( COND (PROPNAME (SETQ FLG T))) (COND ((ATOM (CADDR ITEM)) (SETQ PROPNAMES ( GEVCOMMANDPROPNAMES (CADDR ITEM) COMMANDWORD (CAR GEVEDITCHAIN))))) (COND (( OR (ATOM (CADDR ITEM)) (EQ COMMANDWORD (QUOTE PROP))) (COND ((EQ COMMANDWORD ( QUOTE PROP)) (COND ((CDR PROPNAMES) (SETQ PROPNAMES (CONS (QUOTE ALL) PROPNAMES)))) (SETQ PROPNAMES (CONS (QUOTE SELF) PROPNAMES)))) (COND ((NOT PROPNAMES) (RETURN NIL))) (COND ((NOT PROPNAME) (SETQ PROPNAME (MENU-SELECT ( LIST (QUOTE MENU) PROPNAMES (COPY (QUOTE (WINDOW (0 0) (0 0) NIL 0)))))))) ( COND ((NOT PROPNAME) (RETURN NIL)) ((EQ PROPNAME (QUOTE SELF)) (PRIN1 PROPNAME) (PRINC " = ") (PRINT (CADR ITEM))) ((AND (EQ COMMANDWORD (QUOTE PROP)) (EQ PROPNAME (QUOTE ALL))) (MAPC (OR (CDDR PROPNAMES) (CDR PROPNAMES)) ( FUNCTION (LAMBDA (X) (GEVDOPROP ITEM X COMMANDWORD FLG))))) (T (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG))) (COND ((EQ COMMANDWORD (QUOTE MSG)) ( GEVREFILLWINDOW) (SETQ GEVEDITFLG T))))))) (DE GEVCOMMANDPROPNAMES (OBJ PROPTYPE TOPFRAME) (PROG (RESULT TYPE) (SETQ RESULT (MAPCAN (CASEQ PROPTYPE (PROP (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE PROP))) (ADJ (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ADJ))) (ISA (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ISA))) ( MSG (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE MSG)))) (FUNCTION ( LAMBDA (P) (AND (NOT (AND (NE PROPTYPE (QUOTE MSG)) (CAR (SOME (CADDR TOPFRAME) (FUNCTION (LAMBDA (GLVAR1) (EQ (CAR GLVAR1) (CAR P)))))))) (NOT ( AND (EQ PROPTYPE (QUOTE PROP)) (MEMQ (CAR P) (QUOTE (SHORTVALUE DISPLAYPROPS)))) ) (NOT (AND (EQ PROPTYPE (QUOTE MSG)) (ATOM (CADR P)) (OR (NOT (GETDDD (CADR P))) (GREATERP (LENGTH (CADR (GETDDD (CADR P)))) 1)))) (CONS (CAR P) NIL)))))) ( MAPC (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE SUPERS)) (FUNCTION ( LAMBDA (S) (SETQ RESULT (NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME)))))) (RETURN RESULT))) (DE GEVCOMPPROP (STR PROPNAME PROPTYPE) (PROG (PROPENT) (COND ((NOT (MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (RETURN (QUOTE GEVERROR)))) (COND (( AND (SETQ PROPENT (GEVGETPROP STR PROPNAME PROPTYPE)) (ATOM (CADR PROPENT))) ( RETURN (CADR PROPENT)))) (RETURN (COND ((GEVGLISPP) (OR (GLCOMPPROP STR PROPNAME PROPTYPE) (QUOTE GEVERROR))) (T (ERROR 0 (LIST "GLISP compiler must be loaded for PROPs which" "are not specified with function name equivalents." STR PROPTYPE PROPNAME))))))) (DE GEVDATANAMES (OBJ FILTER) (PROG (RESULT) (GEVDATANAMESB (CAR (GET OBJ ( QUOTE GLSTRUCTURE))) FILTER) (RETURN (REVERSIP RESULT)))) (DE GEVDATANAMESB (STR FILTER) (PROG (TMP) (COND ((ATOM STR) (RETURN NIL)) ( T (CASEQ (CAR STR) (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB ( CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (MAPC (CDR STR) (FUNCTION (LAMBDA ( X) (GEVDATANAMESB X FILTER))))) (RECORD (MAPC (CDDR STR) (FUNCTION (LAMBDA ( X) (GEVDATANAMESB X FILTER))))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) ( GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) ( LISTOF (RETURN NIL)) (T (COND ((GEVFILTER (CADR STR) FILTER) (SETQ RESULT ( CONS (LIST (CAR STR) (CADR STR)) RESULT)))) (GEVDATANAMESB (CADR STR) FILTER)))) ))) (DE GEVDISPLAYNEWPROP NIL (PROG (Y NEWONE) (SETQ Y GEVWINDOWY) (SETQ NEWONE ( CAR (LASTPAIR (CADDAR GEVEDITCHAIN)))) (GEVPPS NEWONE 0 GEVWINDOW) (SETQ GEVWINDOWY Y))) (DE GEVDOPROP (ITEM PROPNAME COMMANDWORD FLG) (PROG (VAL) (SETQ VAL ( GEVEXPROP (CADR ITEM) (CADDR ITEM) PROPNAME COMMANDWORD NIL)) (RPLACA (CDDAR GEVEDITCHAIN) (ACONC (CADDAR GEVEDITCHAIN) (LIST PROPNAME VAL (GEVPROPTYPE ( CADDR ITEM) PROPNAME COMMANDWORD) NIL COMMANDWORD NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) (COND ((NOT FLG) (GEVDISPLAYNEWPROP))))) (DE GEVEDIT NIL (PROG (CHANGEDFLG GEVTOPITEM) (SETQ GEVTOPITEM (CAAAR GEVEDITCHAIN)) (COND ((AND (ATOM (CADDR GEVTOPITEM)) (NE (GEVEXPROP (CADR GEVTOPITEM) (CADDR GEVTOPITEM) (QUOTE EDIT) (QUOTE MSG) NIL) (QUOTE GEVERROR))) (SETQ CHANGEDFLG T)) ((PAIRP (CADR GEVTOPITEM)) (EDITV (CADR GEVTOPITEM)) ( SETQ CHANGEDFLG T)) (T (RETURN NIL))) (COND (CHANGEDFLG (WINDOW-OPEN GEVWINDOW) (GEVREFILLWINDOW))) (SETQ GEVEDITFLG CHANGEDFLG))) (DE GEVEXPROP (OBJ STR PROPNAME PROPTYPE ARGS) (PROG (FN) (COND ((OR (NOT ( MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (AND ARGS (NE PROPTYPE (QUOTE MSG)))) (RETURN (QUOTE GEVERROR)))) (COND ((EQ (SETQ FN (GEVCOMPPROP STR PROPNAME PROPTYPE)) (QUOTE GEVERROR)) (RETURN FN)) (T (RETURN (GEVAPPLY FN (CONS OBJ ARGS))))))) (DE GEVFILLWINDOW NIL (PROG (Y TOP) (WINDOW-CLEAR GEVWINDOW) (SETQ Y (SUB1 ( CADR (CADDR GEVWINDOW)))) (SETQ GEVLASTITEMNUMBER 0) (SETQ TOP (CAR GEVEDITCHAIN)) (MAPC (REVERSE (CAR TOP)) (FUNCTION (LAMBDA (X) (GEVPPS X 0 GEVWINDOW)))) (GEVHORIZLINE GEVWINDOW) (MAPC (CADR TOP) (FUNCTION (LAMBDA ( X) (GEVPPS X 0 GEVWINDOW)))) (GEVHORIZLINE GEVWINDOW) (MAPC (CADDR TOP) ( FUNCTION (LAMBDA (X) (GEVPPS X 0 GEVWINDOW)))) (SETQ GEVWINDOWY Y))) (DE GEVFILTER (TYPE FILTER) (SETQ TYPE (GEVXTRTYPE TYPE)) (CASEQ FILTER ( NUMBER (AND (NOT (MEMQ TYPE (QUOTE (ATOM STRING BOOLEAN ANYTHING)))) (NOT ( AND (PAIRP TYPE) (EQ (CAR TYPE) (QUOTE LISTOF)))))) (LIST (AND (PAIRP TYPE) ( EQ (CAR TYPE) (QUOTE LISTOF)))) (T T))) (DE GEVFINDITEMPOS (POS ITEM N) (OR (GEVPOSTEST POS (CAR (PNTH ITEM 7)) (CAR ITEM) ITEM NIL N) (GEVPOSTEST POS (CAR (PNTH ITEM 8)) (CADDDR ITEM) ITEM T N) ( AND (OR (EQ (CAR (PNTH ITEM 5)) (QUOTE STRUCTURE)) (EQ (CAR (PNTH ITEM 5)) (QUOTE SUBTREE)) (EQ (CAR (PNTH ITEM 5)) (QUOTE LISTOF))) ( GEVFINDLISTPOS POS (CAR (PNTH ITEM 6)) N)))) (DE GEVFINDLISTPOS (POS ITEMS N) (COND (ITEMS (OR (GEVFINDITEMPOS POS (CAR ITEMS) N) (GEVFINDLISTPOS POS (CDR ITEMS) N))))) (DE GEVFINDPOS (POS FRAME) (PROG (TMP N ITEMS) (SETQ N 0) (PROG NIL GLLABEL1 ( COND ((AND FRAME (NOT TMP)) (SETQ N (ADD1 N)) (SETQ ITEMS (CAR FRAME)) (SETQ FRAME (CDR FRAME)) (SETQ TMP (GEVFINDLISTPOS POS ITEMS N)) (GO GLLABEL1)))) ( RETURN TMP))) (DE GEVGETNAMES (OBJ FILTER) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES ( GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ (QUOTE PROP) FILTER)) (RETURN (NCONC DATANAMES PROPNAMES)))) (DE GEVGETPROP (STR PROPNAME PROPTYPE) (PROG (PL SUBPL PROPENT) (COND ((NOT ( MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (ERROR 0 NIL))) (RETURN (AND ( SETQ PL (GET STR (QUOTE GLSTRUCTURE))) (SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (SETQ PROPENT (ASSOC PROPNAME SUBPL)))))) (DE GEVGLISPP NIL (NOT (UNBOUNDP (QUOTE GLBASICTYPES)))) (DE GEVHORIZLINE (W) (PROG (FROM TO) (SETQ FROM (LIST 1 (PLUS Y 0))) (SETQ TO (LIST (DIFFERENCE (CAADDR W) 2) (PLUS Y 0))) (COND ((EQN (CADR FROM) ( CADR TO)) (PROG (X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC ( ADD1 (DIFFERENCE (CAR TO) (CAR FROM))) 45) (COND ((LESSP (CADR FROM) (CAR ( PNTH W 5))) (RPLACA (PNTH W 5) (CADR FROM))))))) (SETQ Y (SUB1 Y))) (DE GEVINIT NIL (SETQ GLNATOM 0) (COND ((NOT (NOT (UNBOUNDP (QUOTE GLLISPDIALECT)))) (SETQ GLLISPDIALECT (QUOTE INTERLISP)))) (SETQ GEVWINDOW NIL)) (DE GEVITEMEVENTFN (ITEM GROUP FLAG) (PROG (TMP TOP N) (COND (FLAG (COND (( EQN GROUP 1) (SETQ TMP (CAAR GEVEDITCHAIN)) (SETQ N 0) (PROG NIL GLLABEL1 ( COND ((AND TMP (NOT (EQUAL (PROG1 (SETQ TOP (CAR TMP)) (SETQ TMP (CDR TMP))) ITEM))) (SETQ N (ADD1 N)) (GO GLLABEL1)))) (GEVPOP NIL N)) (T (GEVPUSH ITEM)))) (T (PRIN1 (CAR ITEM)) (PRINC " is ") (PRIN1 (CADDR ITEM)) (TERPRI))))) (DE GEVLENGTHBOUND (VAL NCHARS) (COND ((GREATERP (FLATSIZE2 VAL) NCHARS) ( CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS)) "-")) (T VAL))) (DE GEVMAKENEWFN (OPERATION INPUTTYPE SET PATH) (PROG (LASTPATH VIEWSPEC) ( SETQ LASTPATH (CAR (LASTPAIR PATH))) (RETURN (LIST (LIST (QUOTE GLAMBDA) ( LIST (MKATOM (CONCAT "GEVNEWFNTOP:" (ID2STRING INPUTTYPE)))) (LIST (QUOTE PROG) (CONS (QUOTE GEVNEWFNVALUE) (CASEQ OPERATION (COLLECT (QUOTE ( GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) (TOTAL (QUOTE ((GEVNEWFNSUM 0)))) (AVERAGE (QUOTE (( GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0)))) (T (ERROR 0 NIL)))) (NCONC (LIST ( QUOTE FOR) (QUOTE GEVNEWFNLOOPVAR) (QUOTE IN) (MKATOM (CONCAT "GEVNEWFNTOP:" ( ID2STRING (CAR SET)))) (QUOTE DO) (LIST (QUOTE GEVNEWFNVALUE) (QUOTE _) ( PROGN (SETQ VIEWSPEC (LIST (QUOTE GEVNEWFNLOOPVAR))) (MAPC PATH (FUNCTION ( LAMBDA (X) (SETQ VIEWSPEC (CONS (QUOTE OF) VIEWSPEC)) (SETQ VIEWSPEC (CONS ( CAR X) VIEWSPEC)) (SETQ VIEWSPEC (CONS (QUOTE THE) VIEWSPEC))))) VIEWSPEC))) ( COPY (CASEQ OPERATION (COLLECT (QUOTE ((GEVNEWFNRESULT !+_ GEVNEWFNVALUE)))) ( MAXIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR))))) (MINIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR))))) (AVERAGE (QUOTE ((GEVNEWFNSUM _+ GEVNEWFNVALUE) (GEVNEWFNCOUNT _+ 1)))) ( TOTAL (QUOTE ((GEVNEWFNSUM _+ GEVNEWFNVALUE))))))) (LIST (QUOTE RETURN) ( CASEQ OPERATION (COLLECT (QUOTE (DREVERSE GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) (AVERAGE (QUOTE ( QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT)))) (TOTAL (QUOTE GEVNEWFNSUM)))))) ( CASEQ OPERATION (COLLECT (LIST (QUOTE LISTOF) (CADR LASTPATH))) ((MAXIMUM MINIMUM) (LIST (QUOTE LIST) (COPY LASTPATH) (LIST (QUOTE WINNER) (CADADR SET)))) (AVERAGE (QUOTE REAL)) (TOTAL (CADR LASTPATH))))))) (DE GEVMATCH (STR VAL FLG) (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) ( RETURN (REVERSIP RESULT)))) (DE GEVMATCHA (STR VAL FLG) (PROG (RES) (SETQ RES (GEVMATCH STR VAL FLG)) ( COND ((NOT (CDR RES)) (RETURN (CAR RES))) (T (RETURN (LIST NIL VAL STR NIL ( QUOTE SUBTREE) RES (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))))))) (DE GEVMATCHATOM (STR VAL NAME) (PROG (L STRB TMP) (COND ((OR (NOT (ATOM VAL)) ( NULL VAL)) (RETURN NIL))) (SETQ STRB (CADR STR)) (COND ((NE (CAR STRB) ( QUOTE PROPLIST)) (RETURN NIL))) (SETQ L (CDR STRB)) (MAPC L (FUNCTION ( LAMBDA (X) (COND ((SETQ TMP (GET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))) (DE GEVMATCHALIST (STR VAL NAME) (PROG (L TMP) (SETQ L (CDR STR)) (MAPC L ( FUNCTION (LAMBDA (X) (COND ((SETQ TMP (ASSOC (CAR X) VAL)) (GEVMATCHB X (CDR TMP) NIL NIL)))))))) (DE GEVMATCHB (STR VAL NAME FLG) (PROG (X Y STRB XSTR TOP TMP) (SETQ XSTR ( GEVXTRTYPE STR)) (COND ((ATOM STR) (COND ((AND FLG (SETQ STRB (CAR (GET STR ( QUOTE GLSTRUCTURE))))) (SETQ RESULT (CONS (LIST NAME VAL STR NIL (QUOTE STRUCTURE) (GEVMATCH STRB VAL NIL) (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE ( 0 0)) NIL)) RESULT))) (T (SETQ RESULT (CONS (LIST NAME VAL STR NIL NIL NIL ( APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) RESULT)))) (RETURN NIL)) ( T (CASEQ (CAR STR) (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB ( CADDR STR) (CDR VAL) NIL NIL)) (LIST (MAPC (CDR STR) (FUNCTION (LAMBDA (X) ( COND (VAL (GEVMATCHB X (CAR VAL) NIL NIL) (SETQ VAL (CDR VAL)))))))) (ATOM ( GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST ( GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) ( RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) ( GEVMATCHOBJECT STR VAL NAME)) (T (COND (NAME (SETQ TMP (GEVMATCH STR VAL NIL)) ( SETQ TOP (CAR TMP)) (SETQ RESULT (CONS (COND ((AND (NOT (CDR TMP)) (NOT (CAR TOP))) (RPLACA TOP NAME) TOP) (T (LIST NAME VAL XSTR NIL (QUOTE SUBTREE) TMP ( APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) RESULT))) ((ATOM ( SETQ STRB (GEVXTRTYPE (CADR STR)))) (GEVMATCHB STRB VAL (CAR STR) NIL)) (( SETQ TMP (GEVMATCH (CADR STR) VAL NIL)) (SETQ TOP (CAR TMP)) (SETQ RESULT ( CONS (COND ((AND (NOT (CDR TMP)) (NOT (CAR TOP))) (RPLACA TOP (CAR STR)) TOP) ( T (LIST (CAR STR) VAL (CADR STR) NIL (QUOTE SUBTREE) TMP (APPEND (QUOTE ( 0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) RESULT))) (T (PRINT "GEVMATCHB Failed") )))))))) (DE GEVMATCHLISTOF (STR VAL NAME) (SETQ RESULT (CONS (LIST NAME VAL STR NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) RESULT))) (DE GEVMATCHOBJECT (STR VAL NAME) (PROG (OBJECTTYPE TMP) (SETQ OBJECTTYPE ( CAR STR)) (SETQ RESULT (ACONC RESULT (LIST (QUOTE CLASS) (CASEQ OBJECTTYPE (( OBJECT LISTOBJECT) (PROG1 (SETQ TMP (CAR VAL)) (SETQ VAL (CDR VAL)))) ( ATOMOBJECT (GET VAL (QUOTE CLASS)))) (QUOTE GLTYPE) NIL NIL NIL (APPEND ( QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) (MAPC (CDR STR) (FUNCTION ( LAMBDA (X) (CASEQ OBJECTTYPE ((OBJECT LISTOBJECT) (COND (VAL (GEVMATCHB X ( PROG1 (SETQ TMP (CAR VAL)) (SETQ VAL (CDR VAL))) NIL NIL)))) (ATOMOBJECT ( COND ((SETQ TMP (GET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))))) (DE GEVMATCHPROPLIST (STR VAL NAME) (PROG (L TMP) (SETQ L (CDR STR)) (MAPC L ( FUNCTION (LAMBDA (X) (COND ((SETQ TMP (LISTGET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))) (DE GEVMATCHRECORD (STR VAL NAME) (PROG (STRNAME FIELDS N) (COND ((ATOM ( CADR STR)) (SETQ STRNAME (CADR STR)) (SETQ FIELDS (CDDR STR))) (T (SETQ FIELDS (CDR STR)))) (SETQ N 0) (MAPC FIELDS (FUNCTION (LAMBDA (X) (SETQ N ( ADD1 N)) (GEVMATCHB X (GETV VAL N) (CAR X) NIL)))))) (DE GEVPOP (FLG N) (PROG (TMP TOP TMPITEM) (COND ((LESSP N 1) (RETURN NIL))) LP (SETQ TMP (CAR GEVEDITCHAIN)) (SETQ GEVEDITCHAIN (CDR GEVEDITCHAIN)) ( COND ((NOT GEVEDITCHAIN) (RETURN (GEVQUIT)))) (SETQ TOP (CAAAR GEVEDITCHAIN)) ( SETQ TMPITEM (CAAR TMP)) (COND ((AND FLG (EQ (CAR (PNTH TMPITEM 5)) (QUOTE FORWARD))) (GO LP))) (COND ((GREATERP (SETQ N (SUB1 N)) 0) (GO LP))) (COND (( AND (PAIRP (CADDR TOP)) (EQ (CAADDR TOP) (QUOTE LISTOF)) (NOT (CDADR TOP))) ( GO LP))) (COND ((AND GEVEDITFLG (NOT (MEMBER (CADDDR TMPITEM) (QUOTE ("(...)" "---"))))) (GEVREFILLWINDOW)) (T (SETQ GEVEDITFLG NIL) (GEVFILLWINDOW))))) (DE GEVPOSTEST (POS TPOS NAME ITEM FLG N) (COND ((AND (NOT (LESSP (CADR POS) ( CADR TPOS))) (NOT (GREATERP (CADR POS) (ADD1 (CADR TPOS)))) (NOT (LESSP (CAR POS) (CAR TPOS))) (LESSP (CAR POS) (PLUS (CAR TPOS) 11))) (LIST (LIST (LIST ( CAR TPOS) (SUB1 (CADR TPOS))) (LIST (TIMES 1 (ADD1 (SIZE NAME))) 1)) ITEM FLG N)))) (DE GEVPPS (ITEM COL WINDOW) (PROG (NAMEX TOP) (COND ((LESSP Y 0) (RETURN NIL))) (SETQ GEVLASTITEMNUMBER (ADD1 GEVLASTITEMNUMBER)) (PROG (S POS) (SETQ S (GEVSTRINGIFY GEVLASTITEMNUMBER)) (SETQ POS (LIST 1 Y)) (COND ((GREATERP ( CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR ( PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (SETQ NAMEX (PLUS 4 (TIMES COL 1))) (RPLACA (CAR (PNTH ITEM 7)) NAMEX) (RPLACA (CDAR (PNTH ITEM 7)) Y) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE FULLVALUE)) (PROG (POS) ( SETQ POS (LIST NAMEX Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X ( CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "(expanded)") (TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS)))))))) ((CAR ITEM) (COND ((NUMBERP (CAR ITEM)) (PROG ( POS) (SETQ POS (LIST NAMEX Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "#") ( TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (SETQ NAMEX (ADD1 NAMEX)))) (PROG (S POS) (SETQ S ( GEVLENGTHBOUND (CAR ITEM) 11)) (SETQ POS (LIST NAMEX Y)) (COND ((GREATERP ( CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR ( PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))))) (COND ((OR (NOT ( CAR (PNTH ITEM 5))) (MEMQ (CAR (PNTH ITEM 5)) (QUOTE (FORWARD BACKUP PROP ADJ MSG ISA)))) (RPLACA (CAR (PNTH ITEM 8)) 18) (RPLACA (CDAR (PNTH ITEM 8)) Y) (PROG (S POS) (SETQ S (OR (CADDDR ITEM) (CAR (RPLACA (CDDDR ITEM) ( GEVSHORTVALUE (CADR ITEM) (CADDR ITEM) (DIFFERENCE GEVSHORTCHARS COL)))))) ( SETQ POS (LIST 18 Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X ( CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL S) ( TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (COND ((NE (CADDDR ITEM) (CADR ITEM)) (PROG (POS) (SETQ POS (LIST 16 Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) ( SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "~") (TERPRI) (COND (( LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) )) (SETQ Y (SUB1 Y))) ((EQ (CAR (PNTH ITEM 5)) (QUOTE FULLVALUE)) (SETQ Y ( SUB1 Y)) (PROG (VALUE POSITION) (SETQ VALUE (CADR ITEM)) (SETQ POSITION ( LIST 1 Y)) (PROG (X Y) (SETQ X (CAR POSITION)) (SETQ Y (CADR POSITION)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( RESETLST (RESETSAVE SYSPRETTYFLG T) (RESETSAVE TTYLINELENGTH (SUB1 ( DIFFERENCE (CAADDR WINDOW) (CAR POSITION)))) (SHOWPRINT VALUE) (CAR (RPLACA ( PNTH WINDOW 5) 1)))) (SETQ Y (SUB1 (CAR (PNTH WINDOW 5))))) ((EQ (CAR (PNTH ITEM 5)) (QUOTE DISPLAY)) (GEVEXPROP (CADR ITEM) (CADDR ITEM) (QUOTE GEVDISPLAY) (QUOTE MSG) (LIST WINDOW Y))) (T (SETQ Y (SUB1 Y)) (MAPC (CAR ( PNTH ITEM 6)) (FUNCTION (LAMBDA (VSUB) (GEVPPS VSUB (PLUS COL 2) WINDOW)))))))) (DE GEVPROGRAM NIL (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (COND ((OR (EQ ( SETQ COMMAND (MENU-SELECT (COPY (QUOTE (MENU (QUIT COLLECT TOTAL AVERAGE MAXIMUM MINIMUM) (WINDOW (0 0) (0 0) NIL 0)))))) (QUOTE QUIT)) (NOT COMMAND)) ( RETURN NIL))) (COND ((OR (EQ (SETQ SET (GEVPROPMENU (CADDR TOPITEM) (QUOTE LIST) NIL)) (QUOTE QUIT)) (EQ SET (QUOTE POP)) (NOT SET)) (RETURN NIL))) ( SETQ PATH (LIST SET (LIST (CAR TOPITEM) (CADDR TOPITEM)))) (SETQ NEXT SET) ( SETQ TYPE (CADADR SET)) (PROG NIL GLLABEL1 (COND ((AND (NOT DONE) (NOT ABORTFLG)) (SETQ NEXT (GEVPROPMENU TYPE (AND (NE COMMAND (QUOTE COLLECT)) ( QUOTE NUMBER)) (EQ COMMAND (QUOTE COLLECT)))) (COND ((ATOM NEXT) (CASEQ NEXT (( NIL QUIT) (SETQ ABORTFLG T)) (POP (COND ((NOT (CDDR PATH)) (SETQ ABORTFLG T)) ( T (SETQ NEXT (CAR PATH)) (SETQ PATH (CDR PATH)) (SETQ NEXT (CAR PATH)) (SETQ TYPE (CADR NEXT)) (COND ((PAIRP TYPE) (SETQ TYPE (CADR TYPE)))) (SETQ LAST ( CAR NEXT))))) (DONE (SETQ DONE T)))) (T (SETQ PATH (CONS NEXT PATH)) (SETQ TYPE (CADR NEXT)) (SETQ LAST (CAR NEXT)))) (COND ((MEMQ TYPE (QUOTE (ATOM INTEGER STRING REAL BOOLEAN NIL))) (SETQ DONE T))) (GO GLLABEL1)))) (COND ( ABORTFLG (RETURN NIL))) (SETQ PATH (REVERSIP PATH)) (SETQ NEWFN ( GEVMAKENEWFN COMMAND (CADDR TOPITEM) SET (CDDR PATH))) (GEVPUTD (QUOTE GEVNEWFN) (CAR NEWFN)) (SETQ RESULT (GEVdoNEWFN (CADR TOPITEM))) (PRIN1 COMMAND) (SPACES 1) (MAPC (CDDR PATH) (FUNCTION (LAMBDA (X) (PRIN1 (CAR X)) ( SPACES 1)))) (PRINC "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) ( PRINC " = ") (PRINT RESULT) (RPLACA (CDDAR GEVEDITCHAIN) (ACONC (CADDAR GEVEDITCHAIN) (LIST (CONCAT (GEVSTRINGIFY COMMAND) (CONCAT " " (GEVSTRINGIFY LAST))) RESULT (CADR NEWFN) NIL (QUOTE MSG) NIL (APPEND (QUOTE (0 0)) NIL) ( APPEND (QUOTE (0 0)) NIL)))) (GEVDISPLAYNEWPROP))) (DE GEVPROPMENU (OBJ FILTER FLG) (PROG (PROPS SEL PNAMES MENU) (SETQ PROPS ( GEVGETNAMES OBJ FILTER)) (COND ((NOT PROPS) (RETURN NIL)) (T (SETQ PNAMES ( MAPCAR PROPS (FUNCTION CAR))) (SETQ SEL (MENU-SELECT (LIST (QUOTE MENU) ( CONS (QUOTE QUIT) (CONS (QUOTE POP) (COND (FLG (CONS (QUOTE DONE) PNAMES)) ( T PNAMES)))) (COPY (QUOTE (WINDOW (0 0) (0 0) NIL 0)))))) (RETURN (CASEQ SEL (( QUIT POP DONE NIL) SEL) (T (ASSOC SEL PROPS)))))))) (DE GEVPROPNAMES (OBJ PROPTYPE FILTER) (PROG (RESULT TYPE) (SETQ RESULT ( MAPCAN (CASEQ PROPTYPE (PROP (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) ( QUOTE PROP))) (ADJ (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ADJ))) ( ISA (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ISA))) (MSG (LISTGET ( CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE MSG)))) (FUNCTION (LAMBDA (P) (AND ( SETQ TYPE (GEVPROPTYPES OBJ (CAR P) (QUOTE PROP))) (GEVFILTER TYPE FILTER) ( CONS (LIST (CAR P) TYPE) NIL)))))) (MAPC (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE SUPERS)) (FUNCTION (LAMBDA (S) (SETQ RESULT (NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER)))))) (RETURN RESULT))) (DE GEVPROPTYPE (STR PROPNAME PROPTYPE) (PROG (PL SUBPL PROPENT TMP) (COND (( NOT (ATOM STR)) (RETURN NIL)) ((AND (SETQ PROPENT (GEVGETPROP STR PROPNAME PROPTYPE)) (SETQ TMP (LISTGET (CDDR PROPENT) (QUOTE RESULT)))) (RETURN TMP)) (( AND PROPENT (ATOM (CADR PROPENT)) (SETQ TMP (GET (CADR PROPENT) (QUOTE GLRESULTTYPE)))) (RETURN TMP)) ((AND (SETQ PL (GET STR (QUOTE GLPROPFNS))) ( SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL))) ( SETQ TMP (CADDR PROPENT))) (RETURN TMP)) ((EQ PROPTYPE (QUOTE ADJ)) (RETURN ( QUOTE BOOLEAN)))))) (DE GEVPROPTYPES (OBJ NAME TYPE) (OR (GEVPROPTYPE OBJ NAME TYPE) (AND ( GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE)))) (DE GEVPUSH (ITEM) (PROG (NEWITEMS TOPITEM LSTITEM) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE BACKUP)) (GEVPOP NIL 1) (RETURN NIL))) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE FORWARD)) (SETQ NEWITEMS (GEVPUSHLISTOF ITEM T))) ((AND (ATOM (CADDR ITEM)) (NOT (GET (CADDR ITEM) (QUOTE GLSTRUCTURE)))) (CASEQ (CADDR ITEM) ((ATOM NUMBER REAL INTEGER STRING ANYTHING) (COND ((EQ (CADR ITEM) (CADDDR ITEM)) (RETURN NIL)) (T ( SETQ NEWITEMS (LIST (LIST (CAR ITEM) (CADR ITEM) (CADDR ITEM) (CADDDR ITEM) ( QUOTE FULLVALUE) NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))))))) (T (RETURN NIL)))) ((AND (PAIRP (CADDR ITEM)) (EQ (CAADDR ITEM) (QUOTE LISTOF))) (SETQ NEWITEMS (GEVPUSHLISTOF ITEM NIL)))) (SETQ GEVEDITCHAIN ( CONS (LIST (CONS ITEM (CAAR GEVEDITCHAIN)) NEWITEMS NIL) GEVEDITCHAIN)) ( GEVREFILLWINDOW) (COND ((AND (PAIRP (CADDR ITEM)) (EQ (CAADDR ITEM) (QUOTE LISTOF)) (NOT (CDADR ITEM))) (SETQ LSTITEM (CAADAR GEVEDITCHAIN)) (GEVPUSH ( CAAR (PNTH LSTITEM 6))) (RETURN NIL))))) (DE GEVPUSHLISTOF (ITEM FLG) (PROG (ITEMTYPE TOPFRAME N NROOM LST VALS TMP) ( COND ((NOT (CADR ITEM)) (RETURN NIL))) (SETQ TOPFRAME (CAR GEVEDITCHAIN)) ( SETQ NROOM (DIFFERENCE (DIFFERENCE (QUOTIENT (CADR (CADDR GEVWINDOW)) 1) 4) (LENGTH (CAR TOPFRAME)))) (COND (FLG (SETQ LST (CONS (LIST NIL NIL NIL "(..." (QUOTE BACKUP) NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)) (SETQ N (CAR ITEM)) (SETQ ITEMTYPE (CADDR ITEM)) (SETQ NROOM ( SUB1 NROOM)) (SETQ VALS (CAR (PNTH ITEM 6)))) (T (SETQ N 1) (SETQ ITEMTYPE ( CADR (CADDR ITEM))) (SETQ VALS (CADR ITEM)))) (PROG NIL GLLABEL1 (COND ((AND VALS (OR (GREATERP NROOM 1) (AND (EQN NROOM 1) (NOT (CDR VALS))))) (SETQ LST ( CONS (LIST N (PROG1 (SETQ TMP (CAR VALS)) (SETQ VALS (CDR VALS))) ITEMTYPE NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)) ( SETQ NROOM (SUB1 NROOM)) (SETQ N (ADD1 N)) (GO GLLABEL1)))) (COND (VALS ( SETQ LST (CONS (LIST N NIL ITEMTYPE "...)" (QUOTE FORWARD) VALS (APPEND ( QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)))) (RETURN (LIST (LIST "expanded" NIL ITEMTYPE NIL (QUOTE LISTOF) (REVERSIP LST) (APPEND (QUOTE ( 0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))))) (DE GEVQUIT NIL (SETQ GEVACTIVEFLG NIL) (WINDOW-CLOSE GEVWINDOW) (COND ( GEVMENUWINDOW (WINDOW-CLOSE GEVMENUWINDOW)))) (DE GEVREDOPROPS (TOP) (PROG (ITEM L) (SETQ ITEM (CAAR TOP)) (COND ((AND ( NOT (CADDR TOP)) (NE (SETQ L (GEVEXPROP (CADR ITEM) (CADDR ITEM) (QUOTE DISPLAYPROPS) (QUOTE PROP) NIL)) (QUOTE GEVERROR))) (COND ((ATOM L) ( GEVCOMMANDPROP ITEM (QUOTE PROP) (QUOTE ALL))) ((PAIRP L) (MAPC L (FUNCTION ( LAMBDA (X) (GEVCOMMANDPROP ITEM (QUOTE PROP) X))))))) (T (MAPC (CADDR TOP) ( FUNCTION (LAMBDA (X) (COND ((NE (CAR (PNTH X 5)) (QUOTE MSG)) (RPLACA (CDR X) ( GEVEXPROP (CADR ITEM) (CADDR ITEM) (CAR X) (CAR (PNTH X 5)) NIL)) (RPLACA ( CDDDR X) NIL)))))))))) (DE GEVREFILLWINDOW NIL (PROG (TOP TOPITEM SUBS TOPSUB) (SETQ TOP (CAR GEVEDITCHAIN)) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (SETQ TOPSUB (CAADR TOP)) ( COND ((OR (NOT TOPSUB) (AND (NE (CAR (PNTH TOPSUB 5)) (QUOTE FULLVALUE)) (NE ( CAR (PNTH TOPSUB 5)) (QUOTE LISTOF)))) (COND ((GEVGETPROP (CADDR TOPITEM) ( QUOTE GEVDISPLAY) (QUOTE MSG)) (RPLACA (CDR TOP) (LIST (LIST NIL (CADR TOPITEM) (CADDR TOPITEM) NIL (QUOTE DISPLAY) NIL (APPEND (QUOTE (0 0)) NIL) ( APPEND (QUOTE (0 0)) NIL))))) (T (SETQ SUBS (GEVMATCH (CADDR TOPITEM) (CADR TOPITEM) T)) (SETQ TOPSUB (CAR SUBS)) (RPLACA (CDR TOP) (COND ((AND (NOT ( CDR SUBS)) (EQ (CAR (PNTH TOPSUB 5)) (QUOTE STRUCTURE)) (EQUAL (CADR TOPSUB) ( CADR TOPITEM)) (EQUAL (CADDR TOPSUB) (CADDR TOPITEM))) (CAR (PNTH TOPSUB 6))) (T SUBS))))))) (GEVREDOPROPS TOP) (GEVFILLWINDOW))) (DE GEVSHORTATOMVAL (ATM NCHARS) (COND ((NUMBERP ATM) (COND ((GREATERP ( FLATSIZE2 ATM) NCHARS) (GEVSHORTSTRINGVAL (GEVSTRINGIFY ATM) NCHARS)) (T ATM))) ((GREATERP (FLATSIZE2 ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM))) (DE GEVSHORTCONSVAL (VAL STR NCHARS) (PROG (NLEFT RES TMP NC) (SETQ RES ( CONS "(" RES)) (SETQ NLEFT (DIFFERENCE NCHARS 5)) (SETQ TMP (GEVSHORTVALUE ( CAR VAL) (CADR STR) (DIFFERENCE NLEFT 3))) (SETQ NC (FLATSIZE2 TMP)) (COND (( GREATERP NC (DIFFERENCE NLEFT 3)) (SETQ TMP "---") (SETQ NC 3))) (SETQ RES ( CONS (GEVSTRINGIFY TMP) RES)) (SETQ RES (CONS " . " RES)) (SETQ NLEFT ( DIFFERENCE NLEFT NC)) (SETQ TMP (GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) ( SETQ NC (FLATSIZE2 TMP)) (COND ((GREATERP NC NLEFT) (SETQ TMP "---") (SETQ NC 3))) (SETQ RES (CONS (GEVSTRINGIFY TMP) RES)) (SETQ RES (CONS ")" RES)) ( RETURN (GEVCONCAT (REVERSIP RES))))) (DE GEVSHORTLISTVAL (VAL STR NCHARS) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (SETQ RES (CONS "(" RES)) (SETQ REST 4) (SETQ NLEFT (DIFFERENCE NCHARS 2)) (SETQ RSTR (CDR STR)) (PROG NIL GLLABEL1 (COND ((AND VAL (NOT QUIT) ( GREATERP (SETQ NCI (COND ((CDR VAL) (DIFFERENCE NLEFT REST)) (T NLEFT))) 2)) (SETQ TMP (GEVSHORTVALUE (CAR VAL) (COND ((EQ (CAR STR) (QUOTE LISTOF)) ( CADR STR)) ((EQ (CAR STR) (QUOTE LIST)) (CAR RSTR))) NCI)) (SETQ QUIT ( MEMBER TMP (QUOTE (GEVERROR "(...)" "---" "???")))) (SETQ NC (FLATSIZE2 TMP)) ( COND ((AND (GREATERP NC NCI) (CDR RES)) (SETQ QUIT T)) (T (COND ((GREATERP NC NCI) (SETQ TMP "---") (SETQ NC 3) (SETQ QUIT T))) (SETQ RES (CONS ( GEVSTRINGIFY TMP) RES)) (SETQ NLEFT (DIFFERENCE NLEFT NC)) (SETQ VAL (CDR VAL)) (SETQ RSTR (CDR RSTR)) (COND (VAL (SETQ RES (CONS " " RES)) (SETQ NLEFT (SUB1 NLEFT)))))) (GO GLLABEL1)))) (COND (VAL (SETQ RES (CONS "..." RES)))) (SETQ RES (CONS ")" RES)) (RETURN (GEVCONCAT (REVERSIP RES))))) (DE GEVSHORTSTRINGVAL (VAL NCHARS) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"))) (DE GEVSHORTVALUE (VAL STR NCHARS) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) ( RETURN (COND ((AND (ATOM STR) (MEMQ STR (QUOTE (ATOM INTEGER REAL)))) ( GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR (QUOTE STRING)) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NE (SETQ TMP (GEVEXPROP VAL STR (QUOTE SHORTVALUE) ( QUOTE PROP) NIL)) (QUOTE GEVERROR))) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) ( GEVSHORTSTRINGVAL VAL NCHARS)) ((PAIRP STR) (CASEQ (CAR STR) ((LISTOF LIST) ( COND ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND (( PAIRP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) (T "---"))) ((PAIRP VAL) (GEVSHORTLISTVAL VAL (QUOTE (LISTOF ANYTHING)) NCHARS)) (T "---"))))) (DE GEVXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) (( AND (MEMQ (CAR TYPE) (QUOTE (A AN A AN AN TRANSPARENT))) (CDR TYPE) (ATOM ( CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (NOT ( UNBOUNDP GLUSERSTRNAMES)) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND ( ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR 0 (LIST ( QUOTE GEVXTRTYPE) (LIST TYPE "is an illegal type specification."))) NIL))) (SETQ GEVTYPENAMES (QUOTE (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT))) |
Added psl-1983/3-1/glisp/glcase.sl version [1906d5b717].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GSN 10-FEB-83 12:56 % Compile code for Case statement. (DE GLDOCASE (EXPR) (PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB) (SETQ TYPEOK T) (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (CAR TMP)) (SETQ SELECTORTYPE (CADR TMP)) (SETQ EXPR (CDDR EXPR)) % Get rid of of if present (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ EXPR (CDR EXPR)))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS 'SELECTQ (CONS SELECTOR (ACONC RESULT ELSECLAUSE)))) RESULTTYPE))) ((MEMQ (CAR EXPR) '(ELSE Else else)) (SETQ TMP (GLPROGN (CDR EXPR) CONTEXT)) (SETQ ELSECLAUSE (COND ((CDAR TMP) (CONS 'PROGN (CAR TMP))) (T (CAAR TMP)))) (SETQ EXPR NIL)) (T (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (SETQ RESULT (ACONC RESULT (CONS (COND ((ATOM (CAAR EXPR)) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES (CAAR EXPR) NIL)) (CADR TMPB)) (CAAR EXPR))) (T (MAPCAR (CAAR EXPR) (FUNCTION (LAMBDA (X) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES X NIL)) (CADR TMPB)) X)))))) (CAR TMP)))))) % If all the result types are the same, then we know the result of the % Case statement. (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (cond (expr (SETQ EXPR (CDR EXPR)) )) (GO A))) |
Added psl-1983/3-1/glisp/glhead.psl version [d93d89617a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLHEAD.PSL.13 16 FEB. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES GLTYPESUSED)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST TYPE GLNRECURSIONS GLFNSUBS GLEVALSUBS)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) |
Added psl-1983/3-1/glisp/glhead.sl version [0cf7875034].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLHEAD.PSL.9 14 Jan. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) |
Added psl-1983/3-1/glisp/glisp.b version [31329c7202].
cannot compute difference between binary files
Added psl-1983/3-1/glisp/glisp.sl version [fd9609b887].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 | % % GLHEAD.PSL.13 16 FEB. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES GLTYPESUSED)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST TYPE GLNRECURSIONS GLFNSUBS GLEVALSUBS)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) % % GLTAIL.PSL.4 18 Feb. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (COND ((PAIRP (GETD X)) (CDR (GETD X))) (T NIL))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NOT (PAIRP L)) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (glputhook (car x)) ) % Put the hook macro onto a function to cause auto compilation. (de glputhook (x) (put x 'glcompiled nil) (putd x 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % {DSK}GLISP.PSL;1 16-MAR-83 12:28:51 % GSN 7-MAR-83 16:41 % Transform an expression X for Portable Standard Lisp dialect. (DE GLPSLTRANSFM (X) (PROG (TMP NOTFLG) % First do argument reversals. (COND ((NOT (PAIRP X)) (RETURN X)) ((MEMQ (CAR X) '(push PUSH)) (SETQ X (LIST (CAR X) (CADDR X) (CADR X)))) ((MEMQ (CAR X) NIL) (SETQ X (LIST (CAR X) (CADR X) (CADDDR X) (CADDR X)))) ((EQ (CAR X) 'APPLY*) (SETQ X (LIST 'APPLY (CADR X) (CONS 'LIST (CDDR X)))))) % Now see if the result will be negated. (SETQ NOTFLG (MEMQ (CAR X) '(NLISTP BOUNDP GEQ LEQ IGEQ ILEQ))) (COND ((SETQ TMP (ASSOC (CAR X) '((MEMB MEMQ) (FMEMB MEMQ) (FASSOC ASSOC) (LITATOM IDP) (GETPROP GET) (GETPROPLIST PROP) (PUTPROP PUT) (LISTP PAIRP) (NLISTP PAIRP) (NEQ NE) (IGREATERP GREATERP) (IGEQ LESSP) (GEQ LESSP) (ILESSP LESSP) (ILEQ GREATERP) (LEQ GREATERP) (IPLUS PLUS) (IDIFFERENCE DIFFERENCE) (ITIMES TIMES) (IQUOTIENT QUOTIENT) (* CommentOutCode) (MAPCONC MAPCAN) (DECLARE CommentOutCode) (NCHARS FlatSize2) (NTHCHAR GLNTHCHAR) (DREVERSE REVERSIP) (STREQUAL String!=) (ALPHORDER String!<!=) (GLSTRGREATERP String!>) (GLSTRGEP String!>!=) (GLSTRLESSP String!<) (EQP EQN) (LAST LASTPAIR) (NTH PNth) (NCONC1 ACONC) (U-CASE GLUCASE) (DSUBST SUBSTIP) (BOUNDP UNBOUNDP) (UNPACK EXPLODE) (PACK IMPLODE) (DREMOVE DELETIP) (GETD GETDDD) (PUTD PUTDDD)))) (SETQ X (CONS (CADR TMP) (CDR X)))) ((AND (EQ (CAR X) 'RETURN) (NULL (CDR X))) (SETQ X (LIST (CAR X) NIL))) ((AND (EQ (CAR X) 'APPEND) (NULL (CDDR X))) (SETQ X (LIST (CAR X) (CADR X) NIL))) ((EQ (CAR X) 'ERROR) (SETQ X (LIST (CAR X) 0 (COND ((NULL (CDR X)) NIL) ((NULL (CDDR X)) (CADR X)) (T (CONS 'LIST (CDR X))))))) ((EQ (CAR X) 'SELECTQ) (RPLACA X 'CASEQ) (SETQ TMP (NLEFT X 2)) (COND ((NULL (CADR TMP)) (RPLACD TMP NIL)) (T (RPLACD TMP (LIST (LIST T (CADR TMP)))))))) (RETURN (COND (NOTFLG (LIST 'NOT X)) (T X))))) % edited: 18-NOV-82 11:47 (DF A (L) (GLAINTERPRETER L)) % edited: 18-NOV-82 11:47 (DF AN (L) (GLAINTERPRETER L)) % edited: 29-OCT-81 14:25 (DE GL-A-AN? (X) (MEMQ X '(A AN a an An))) % GSN 17-FEB-83 11:31 % Test whether FNNAME is an abstract function. (DE GLABSTRACTFN? (FNNAME) (PROG (DEFN) (RETURN (AND (SETQ DEFN (GLGETD FNNAME)) (PAIRP DEFN) (EQ (CAR DEFN) 'MLAMBDA))))) % GSN 16-FEB-83 12:39 % Add a PROPerty entry of type PROPTYPE to structure STRNAME. (DE GLADDPROP (STRNAME PROPTYPE LST) (PROG (PL SUBPL) (COND ((NOT (AND (ATOM STRNAME) (SETQ PL (GET STRNAME 'GLSTRUCTURE)))) (ERROR 0 (LIST STRNAME " has no structure definition."))) ((SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (NCONC SUBPL (LIST LST))) (T (NCONC PL (LIST PROPTYPE (LIST LST))))))) % edited: 25-Jan-81 18:17 % Add the type SDES to RESULTTYPE in GLCOMP (DE GLADDRESULTTYPE (SDES) (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE SDES)) ((AND (PAIRP RESULTTYPE) (EQ (CAR RESULTTYPE) 'OR)) (COND ((NOT (MEMBER SDES (CDR RESULTTYPE))) (ACONC RESULTTYPE SDES)))) ((NOT (EQUAL SDES RESULTTYPE)) (SETQ RESULTTYPE (LIST 'OR RESULTTYPE SDES))))) % edited: 2-Jan-81 13:37 % Add an entry to the current context for a variable ATM, whose NAME % in context is given, and which has structure STR. The entry is % pushed onto the front of the list at the head of the context. (DE GLADDSTR (ATM NAME STR CONTEXT) (RPLACA CONTEXT (CONS (LIST ATM NAME STR) (CAR CONTEXT)))) % GSN 10-FEB-83 12:56 % edited: 17-Sep-81 13:58 % Compile code to test if SOURCE is PROPERTY. (DE GLADJ (SOURCE PROPERTY ADJWD) (PROG (ADJL TRANS TMP FETCHCODE) (COND ((EQ ADJWD 'ISASELF) (COND ((SETQ ADJL (GLSTRPROP PROPERTY 'ISA 'self NIL)) (GO A)) (T (RETURN NIL)))) ((SETQ ADJL (GLSTRPROP (CADR SOURCE) ADJWD PROPERTY NIL)) (GO A))) % See if the adjective can be found in a TRANSPARENT substructure. (SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE))) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLADJ (LIST '*GL* (GLXTRTYPE (CAR TRANS))) PROPERTY ADJWD)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR SOURCE) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR SOURCE)) (RETURN TMP)) (T (SETQ TRANS (CDR TRANS)) (GO B))) A (COND ((AND (PAIRP (CADR ADJL)) (MEMQ (CAADR ADJL) '(NOT Not not)) (ATOM (CADADR ADJL)) (NULL (CDDADR ADJL)) (SETQ TMP (GLSTRPROP (CADR SOURCE) ADJWD (CADADR ADJL) NIL))) (SETQ ADJL TMP) (SETQ NOTFLG (NOT NOTFLG)) (GO A))) (RETURN (GLCOMPMSGL SOURCE ADJWD ADJL NIL CONTEXT)))) % GSN 10-FEB-83 15:08 (DE GLAINTERPRETER (L) (PROG (CODE GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLNRECURSIONS) (SETQ GLNATOM 0) (SETQ GLNRECURSIONS 0) (SETQ FAULTFN 'GLAINTERPRETER) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (SETQ CODE (GLDOA (CONS 'A L))) (RETURN (EVAL (CAR CODE))))) % edited: 26-DEC-82 15:40 % AND operator (DE GLANDFN (LHS RHS) (COND ((NULL LHS) RHS) ((NULL RHS) LHS) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND) (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (APPEND (CAR LHS) (CDAR RHS)) (CADR LHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND)) (LIST (APPEND (CAR LHS) (LIST (CAR RHS))) (CADR LHS))) ((AND (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (CONS 'AND (CONS (CAR LHS) (CDAR RHS))) (CADR LHS))) ((AND (PAIRP (CADR RHS)) (EQ (CAADR RHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'INTERSECTION (CAR LHS) (CAR RHS)) (CADR RHS))) ((GLDOMSG LHS 'AND (LIST RHS))) ((GLUSERSTROP LHS 'AND RHS)) (T (LIST (LIST 'AND (CAR LHS) (CAR RHS)) (CADR RHS))))) % edited: 19-MAY-82 13:54 % Test if ATM is the name of any CAR/CDR combination. If so, the value % is a list of the intervening letters in reverse order. (DE GLANYCARCDR? (ATM) (PROG (RES N NMAX TMP) (OR (AND (EQ (GLNTHCHAR ATM 1) 'C) (EQ (GLNTHCHAR ATM -1) 'R)) (RETURN NIL)) (SETQ NMAX (SUB1 (FlatSize2 ATM))) (SETQ N 2) A (COND ((GREATERP N NMAX) (RETURN RES)) ((OR (EQ (SETQ TMP (GLNTHCHAR ATM N)) 'D) (EQ TMP 'A)) (SETQ RES (CONS TMP RES)) (SETQ N (ADD1 N)) (GO A)) (T (RETURN NIL))))) % edited: 26-OCT-82 15:26 % Try to get indicator IND from an ATOM structure. (DE GLATOMSTRFN (IND DES DESLIST) (PROG (TMP) (RETURN (OR (AND (SETQ TMP (ASSOC 'PROPLIST (CDR DES))) (GLPROPSTRFN IND TMP DESLIST T)) (AND (SETQ TMP (ASSOC 'BINDING (CDR DES))) (GLSTRVALB IND (CADR TMP) '(EVAL *GL*))))))) % GSN 1-FEB-83 16:35 % edited: 14-Sep-81 12:45 % Test whether STR is a legal ATOM structure. (DE GLATMSTR? (STR) (PROG (TMP) (COND ((OR (AND (CDR STR) (OR (NOT (PAIRP (CADR STR))) (AND (CDDR STR) (OR (NOT (PAIRP (CADDR STR))) (CDDDR STR)))))) (RETURN NIL))) (COND ((SETQ TMP (ASSOC 'BINDING (CDR STR))) (COND ((OR (CDDR TMP) (NULL (GLOKSTR? (CADR TMP)))) (RETURN NIL))))) (COND ((SETQ TMP (ASSOC 'PROPLIST (CDR STR))) (RETURN (EVERY (CDR TMP) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X))))))))) (RETURN T))) % edited: 23-DEC-82 10:43 % Test whether TYPE is implemented as an ATOM structure. (DE GLATOMTYPEP (TYPE) (PROG (TYPEB) (RETURN (OR (EQ TYPE 'ATOM) (AND (PAIRP TYPE) (MEMQ (CAR TYPE) '(ATOM ATOMOBJECT))) (AND (NE (SETQ TYPEB (GLXTRTYPEB TYPE)) TYPE) (GLATOMTYPEP TYPEB)))))) % edited: 24-AUG-82 17:21 (DE GLBUILDALIST (ALIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL ALIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop ALIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (ACONC LIS (GLBUILDCONS (KWOTE (CAR TMP1)) TMP2 T))))) (GO A))) % edited: 9-DEC-82 17:14 % Generate code to build a CONS structure. OPTFLG is true iff the % structure does not need to be a newly created one. (DE GLBUILDCONS (X Y OPTFLG) (COND ((NULL Y) (GLBUILDLIST (LIST X) OPTFLG)) ((AND (PAIRP Y) (EQ (CAR Y) 'LIST)) (GLBUILDLIST (CONS X (CDR Y)) OPTFLG)) ((AND OPTFLG (GLCONST? X) (GLCONST? Y)) (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y)))) ((AND (GLCONSTSTR? X) (GLCONSTSTR? Y)) (LIST 'COPY (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y))))) (T (LIST 'CONS X Y)))) % edited: 9-DEC-82 17:13 % Build a LIST structure, possibly doing compile-time constant % folding. OPTFLG is true iff the structure does not need to be a % newly created copy. (DE GLBUILDLIST (LST OPTFLG) (COND ((EVERY LST (FUNCTION GLCONST?)) (COND (OPTFLG (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))) (T (GLGENCODE (LIST 'APPEND (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))))) ((EVERY LST (FUNCTION GLCONSTSTR?)) (GLGENCODE (LIST 'COPY (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))) (T (CONS 'LIST LST)))) % edited: 19-OCT-82 15:05 % Build code to do (NOT CODE) , doing compile-time folding if % possible. (DE GLBUILDNOT (CODE) (PROG (TMP) (COND ((GLCONST? CODE) (RETURN (NOT (GLCONSTVAL CODE)))) ((NOT (PAIRP CODE)) (RETURN (LIST 'NOT CODE))) ((EQ (CAR CODE) 'NOT) (RETURN (CADR CODE))) ((NOT (ATOM (CAR CODE))) (RETURN NIL)) ((SETQ TMP (ASSOC (CAR CODE) '((EQ NE) (NE EQ) (LEQ GREATERP) (GEQ LESSP)))) (RETURN (CONS (CADR TMP) (CDR CODE)))) (T (RETURN (LIST 'NOT CODE)))))) % edited: 26-OCT-82 16:02 (DE GLBUILDPROPLIST (PLIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL PLIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop PLIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (NCONC LIS (LIST (KWOTE (CAR TMP1)) TMP2))))) (GO A))) % edited: 12-NOV-82 11:26 % Build a RECORD structure. (DE GLBUILDRECORD (STR PAIRLIST PREVLST) (PROG (TEMP ITEMS RECORDNAME) (COND ((ATOM (CADR STR)) (SETQ RECORDNAME (CADR STR)) (SETQ ITEMS (CDDR STR))) (T (SETQ ITEMS (CDR STR)))) (COND ((EQ (CAR STR) 'OBJECT) (SETQ ITEMS (CONS '(CLASS ATOM) ITEMS)))) (RETURN (CONS 'Vector (MAPCAR ITEMS (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))) ))))) % GSN 7-MAR-83 17:01 % edited: 13-Aug-81 14:06 % Generate code to build a structure according to the structure % description STR. PAIRLIST is a list of elements of the form % (SLOTNAME CODE TYPE) for each named slot to be filled in in the % structure. (DE GLBUILDSTR (STR PAIRLIST PREVLST) (PROG (PROPLIS TEMP PROGG TMPCODE ATMSTR) (SETQ ATMSTR '((ATOM) (INTEGER . 0) (REAL . 0.0) (NUMBER . 0) (BOOLEAN) (NIL) (ANYTHING))) (COND ((NULL STR) (RETURN NIL)) ((ATOM STR) (COND ((SETQ TEMP (ASSOC STR ATMSTR)) (RETURN (CDR TEMP))) ((MEMQ STR PREVLST) (RETURN NIL)) ((SETQ TEMP (GLGETSTR STR)) (RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST)))) (T (RETURN NIL)))) ((NOT (PAIRP STR)) (GLERROR 'GLBUILDSTR (LIST "Illegal structure type encountered:" STR)) (RETURN NIL))) (RETURN (CASEQ (CAR STR) (CONS (GLBUILDCONS (GLBUILDSTR (CADR STR) PAIRLIST PREVLST) (GLBUILDSTR (CADDR STR) PAIRLIST PREVLST) NIL)) (LIST (GLBUILDLIST (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST)))) NIL)) (LISTOBJECT (GLBUILDLIST (CONS (KWOTE (CAR PREVLST)) (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))))) NIL)) (ALIST (GLBUILDALIST (CDR STR) PREVLST)) (PROPLIST (GLBUILDPROPLIST (CDR STR) PREVLST)) (ATOM (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (KWOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (COND ((SETQ TEMP (ASSOC 'BINDING (CDR STR))) (SETQ TMPCODE (GLBUILDSTR (CADR TEMP) PAIRLIST PREVLST)) (ACONC PROGG (LIST 'SET 'ATOMNAME TMPCODE)))) (COND ((SETQ TEMP (ASSOC 'PROPLIST (CDR STR))) (SETQ PROPLIS (CDR TEMP)) (GLPUTPROPS PROPLIS PREVLST))) (ACONC PROGG (COPY '(RETURN ATOMNAME))) PROGG) (ATOMOBJECT (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (KWOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (LIST 'QUOTE 'CLASS) (KWOTE (CAR PREVLST))))) (GLPUTPROPS (CDR STR) PREVLST) (ACONC PROGG (COPY '(RETURN ATOMNAME)))) (TRANSPARENT (AND (NOT (MEMQ (CADR STR) PREVLST)) (SETQ TEMP (GLGETSTR (CADR STR))) (GLBUILDSTR TEMP PAIRLIST (CONS (CADR STR) PREVLST)))) (LISTOF NIL) (RECORD (GLBUILDRECORD STR PAIRLIST PREVLST)) (OBJECT (GLBUILDRECORD STR (CONS (LIST 'CLASS (KWOTE (CAR PREVLST)) 'ATOM) PAIRLIST) PREVLST)) (T (COND ((ATOM (CAR STR)) (COND ((SETQ TEMP (ASSOC (CAR STR) PAIRLIST)) (CADR TEMP)) ((AND (ATOM (CADR STR)) (NOT (ASSOC (CADR STR) ATMSTR))) (GLBUILDSTR (CADR STR) NIL PREVLST)) (T (GLBUILDSTR (CADR STR) PAIRLIST PREVLST)))) (T NIL))))))) % edited: 14-MAR-83 16:59 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPE (LST STR) (COND ((NULL LST) STR) ((NULL STR) NIL) ((MEMQ STR GLBASICTYPES) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST (GLGETSTR STR))) ((NOT (PAIRP STR)) (ERROR 0 NIL)) (T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR))))) % edited: 19-MAY-82 14:41 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPEB (LST STR) (COND ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST STR)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((AND (ATOM (CAR STR)) (NOT (MEMQ (CAR STR) GLTYPENAMES)) (CDR STR) (NULL (CDDR STR))) (GLCARCDRRESULTTYPE LST (CADR STR))) ((EQ (CAR LST) 'A) (COND ((OR (EQ (CAR STR) 'LISTOF) (EQ (CAR STR) 'CONS) (EQ (CAR STR) 'LIST)) (GLCARCDRRESULTTYPE (CDR LST) (CADR STR))) (T NIL))) ((EQ (CAR LST) 'D) (COND ((EQ (CAR STR) 'CONS) (GLCARCDRRESULTTYPE (CDR LST) (CADDR STR))) ((EQ (CAR STR) 'LIST) (COND ((CDDR STR) (GLCARCDRRESULTTYPE (CDR LST) (CONS 'LIST (CDDR STR)))) (T NIL))) ((EQ (CAR STR) 'LISTOF) (GLCARCDRRESULTTYPE (CDR LST) STR)))) (T (ERROR 0 NIL)))) % edited: 13-JAN-82 13:45 % Test if X is a CAR or CDR combination up to 3 long. (DE GLCARCDR? (X) (MEMQ X '(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR))) % edited: 5-OCT-82 15:24 (DE GLCC (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN)))) % GSN 18-JAN-83 15:04 % Get the Class of object OBJ. (DE GLCLASS (OBJ) (PROG (CLASS) (RETURN (AND (SETQ CLASS (COND ((VectorP OBJ) (GetV OBJ 0)) ((ATOM OBJ) (GET OBJ 'CLASS)) ((PAIRP OBJ) (CAR OBJ)) (T NIL))) (GLCLASSP CLASS) CLASS)))) % edited: 11-NOV-82 11:23 % Test whether the object OBJ is a member of class CLASS. (DE GLCLASSMEMP (OBJ CLASS) (GLDESCENDANTP (GLCLASS OBJ) CLASS)) % edited: 11-NOV-82 11:45 % See if CLASS is a Class name. (DE GLCLASSP (CLASS) (PROG (TMP) (RETURN (AND (ATOM CLASS) (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (MEMQ (CAR (GLXTRTYPE (CAR TMP))) '(OBJECT ATOMOBJECT LISTOBJECT)))))) % GSN 9-FEB-83 16:58 % Execute a message to CLASS with selector SELECTOR and arguments % ARGS. PROPNAME is one of MSG, ADJ, ISA, PROP. (DE GLCLASSSEND (CLASS SELECTOR ARGS PROPNAME) (PROG (FNCODE) (COND ((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME)) (RETURN (COND ((ATOM FNCODE) (EVAL (CONS FNCODE (MAPCAR ARGS (FUNCTION KWOTE))))) (T (APPLY FNCODE ARGS)))))) (RETURN 'GLSENDFAILURE))) % GSN 10-FEB-83 15:09 % GLISP compiler function. GLAMBDAFN is the atom whose function % definition is being compiled; GLEXPR is the GLAMBDA expression to % be compiled. The compiled function is saved on the property list % of GLAMBDAFN under the indicator GLCOMPILED. The property % GLRESULTTYPE is the RESULT declaration, if specified; GLGLOBALS is % a list of global variables referenced and their types. (DE GLCOMP (GLAMBDAFN GLEXPR GLTYPESUBS GLFNSUBS ARGTYPES) (PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX RESULTTYPE GLGLOBALVARS RESULT GLSEPATOM GLSEPPTR VALBUSY EXPRSTACK GLTU GLNRECURSIONS) (SETQ GLSEPPTR 0) (SETQ GLNRECURSIONS 0) (COND ((NOT GLQUIETFLG) (PRINT (LIST 'GLCOMP GLAMBDAFN)))) (SETQ EXPRSTACK (LIST GLEXPR)) (SETQ GLNATOM 0) (SETQ GLTOPCTX (LIST NIL)) (SETQ GLTU GLTYPESUSED) (SETQ GLTYPESUSED NIL) % Process the argument list of the GLAMBDA. (SETQ NEWARGS (GLDECL (CADR GLEXPR) '(T NIL) GLTOPCTX GLAMBDAFN ARGTYPES)) % See if there is a RESULT declaration. (SETQ GLEXPR (CDDR GLEXPR)) (GLSKIPCOMMENTS) (GLRESGLOBAL) (GLSKIPCOMMENTS) (GLRESGLOBAL) (SETQ VALBUSY (NULL (CDR GLEXPR))) (SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX))) (PUT GLAMBDAFN 'GLRESULTTYPE (OR RESULTTYPE (CADR NEWEXPR))) (PUT GLAMBDAFN 'GLTYPESUSED GLTYPESUSED) (GLSAVEFNTYPES GLAMBDAFN GLTYPESUSED) (SETQ RESULT (GLUNWRAP (CONS 'LAMBDA (CONS NEWARGS (CAR NEWEXPR))) T)) (SETQ GLTYPESUSED GLTU) (RETURN RESULT))) % GSN 2-FEB-83 14:52 % Compile an abstract function into an instance function given the % specified set of type substitutions and function substitutions. (DE GLCOMPABSTRACT (FN INSTFN TYPESUBS FNSUBS ARGTYPES) (PROG (TMP) (COND (INSTFN) ((SETQ TMP (ASSOC FN FNSUBS)) (SETQ INSTFN (CDR TMP))) (T (SETQ INSTFN (GLINSTANCEFNNAME FN)))) (SETQ FNSUBS (CONS (CONS FN INSTFN) FNSUBS)) % Now compile the abstract function with the specified type % substitutions. (PUTDDD INSTFN (GLCOMP INSTFN (GLGETD FN) TYPESUBS FNSUBS ARGTYPES)) (RETURN INSTFN))) % GSN 10-FEB-83 15:09 % Compile a GLISP expression. CODE is a GLISP expression. VARLST is a % list of lists (VAR TYPE) . The result is a list (OBJCODE TYPE) % where OBJCODE is the Lisp code corresponding to CODE and TYPE is % the type returned by OBJCODE. (DE GLCOMPEXPR (CODE VARLST) (PROG (OBJCODE GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPEXPR) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (MAPC VARLST (FUNCTION (LAMBDA (X) (GLADDSTR (CAR X) NIL (CADR X) CONTEXT)))) (COND ((SETQ OBJCODE (GLPUSHEXPR CODE T CONTEXT T)) (RETURN (LIST (GLUNWRAP (CAR OBJCODE) T) (CADR OBJCODE))))))) % edited: 27-MAY-82 12:58 % Compile the function definition stored for the atom FAULTFN using % the GLISP compiler. (DE GLCOMPILE (FAULTFN) (GLAMBDATRAN (GLGETD FAULTFN))FAULTFN) % edited: 4-MAY-82 11:13 % Compile FN if not already compiled. (DE GLCOMPILE? (FN) (OR (GET FN 'GLCOMPILED) (GLCOMPILE FN))) % GSN 10-FEB-83 15:33 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSG (OBJECT MSGLST ARGLIST CONTEXT) (PROG (RESULT) (COND ((GREATERP (SETQ GLNRECURSIONS (ADD1 GLNRECURSIONS)) 9) (RETURN (GLERROR 'GLCOMPMSG (LIST "Infinite loop detected in compiling" (CAR MSGLST) "for object of type" (CADR OBJECT)))))) (SETQ RESULT (GLCOMPMSGB OBJECT MSGLST ARGLIST CONTEXT)) (SETQ GLNRECURSIONS (SUB1 GLNRECURSIONS)) (RETURN RESULT))) % GSN 10-FEB-83 15:13 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSGB (OBJECT MSGLST ARGLIST CONTEXT) (PROG (GLPROGLST RESULTTYPE METHOD RESULT VTYPE) (SETQ RESULTTYPE (LISTGET (CDDR MSGLST) 'RESULT)) (SETQ METHOD (CADR MSGLST)) (COND ((ATOM METHOD) % Function name is specified. (COND ((LISTGET (CDDR MSGLST) 'OPEN) (RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST) (CONS (CADR OBJECT) (LISTGET (CDDR MSGLST) 'ARGTYPES)) RESULTTYPE (LISTGET (CDDR MSGLST) 'SPECVARS)))) (T (RETURN (LIST (CONS METHOD (CONS (CAR OBJECT) (MAPCAR ARGLIST (FUNCTION CAR)))) (OR (GLRESULTTYPE METHOD (CONS (CADR OBJECT) (MAPCAR ARGLIST (FUNCTION CADR)))) (LISTGET (CDDR MSGLST) 'RESULT))))))) ((NOT (PAIRP METHOD)) (RETURN (GLERROR 'GLCOMPMSG (LIST "The form of Response is illegal for message" (CAR MSGLST))))) ((AND (PAIRP (CAR METHOD)) (MEMQ (CAAR METHOD) '(virtual Virtual VIRTUAL))) (OR (SETQ VTYPE (LISTGET (CDDR MSGLST) 'VTYPE)) (PROGN (SETQ VTYPE (GLMAKEVTYPE (CADR OBJECT) (CAR METHOD))) (NCONC MSGLST (LIST 'VTYPE VTYPE)))) (RETURN (LIST (CAR OBJECT) VTYPE)))) % The Method is a list of stuff to be compiled open. (SETQ CONTEXT (LIST NIL)) (COND ((ATOM (CAR OBJECT)) (GLADDSTR (LIST 'PROG1 (CAR OBJECT)) 'self (CADR OBJECT) CONTEXT)) ((AND (PAIRP (CAR OBJECT)) (EQ (CAAR OBJECT) 'PROG1) (ATOM (CADAR OBJECT)) (NULL (CDDAR OBJECT))) (GLADDSTR (CAR OBJECT) 'self (CADR OBJECT) CONTEXT)) (T (SETQ GLPROGLST (CONS (LIST 'self (CAR OBJECT)) GLPROGLST)) (GLADDSTR 'self NIL (CADR OBJECT) CONTEXT))) (SETQ RESULT (GLPROGN METHOD CONTEXT)) % If more than one expression resulted, embed in a PROGN. (RPLACA RESULT (COND ((CDAR RESULT) (CONS 'PROGN (CAR RESULT))) (T (CAAR RESULT)))) (RETURN (LIST (COND (GLPROGLST (GLGENCODE (LIST 'PROG GLPROGLST (LIST 'RETURN (CAR RESULT))))) (T (CAR RESULT))) (OR RESULTTYPE (CADR RESULT)))))) % GSN 16-FEB-83 17:37 % Attempt to compile code for a message list for an object. OBJECT is % the destination, in the form (<code> <type>) , PROPTYPE is the % property type (ADJ etc.) , MSGLST is the message list, and ARGS is % a list of arguments of the form (<code> <type>) . The result is of % the form (<code> <type>) , or NIL if failure. (DE GLCOMPMSGL (OBJECT PROPTYPE MSGLST ARGS CONTEXT) (PROG (TYPE SELECTOR NEWFN NEWMSGLST) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (SETQ SELECTOR (CAR MSGLST)) (RETURN (COND ((LISTGET (CDDR MSGLST) 'MESSAGE) (SETQ CONTEXT (LIST NIL)) (GLADDSTR (CAR OBJECT) 'self TYPE CONTEXT) (LIST (COND ((EQ PROPTYPE 'MSG) (CONS 'SEND (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (T (CONS 'SENDPROP (CONS (CAR OBJECT) (CONS SELECTOR (CONS PROPTYPE (MAPCAR ARGS (FUNCTION CAR)))))))) (GLEVALSTR (LISTGET (CDDR MSGLST) 'RESULT) CONTEXT))) ((LISTGET (CDDR MSGLST) 'SPECIALIZE) (SETQ NEWFN (GLINSTANCEFNNAME (CADR MSGLST))) (SETQ NEWMSGLST (LIST (CAR MSGLST) NEWFN 'SPECIALIZATION T)) (GLADDPROP (CADR OBJECT) PROPTYPE NEWMSGLST) (GLCOMPABSTRACT (CADR MSGLST) NEWFN NIL NIL (CONS (CADR OBJECT) (MAPCAR ARGS (FUNCTION CADR)))) (PUT NEWFN 'GLSPECIALIZATION (CONS (LIST (CADR MSGLST) (CADR OBJECT) PROPTYPE SELECTOR) (GET NEWFN 'GLSPECIALIZATION))) (NCONC NEWMSGLST (LIST 'RESULT (GET NEWFN 'GLRESULTTYPE))) (GLCOMPMSG OBJECT NEWMSGLST ARGS CONTEXT)) (T (GLCOMPMSG OBJECT MSGLST ARGS CONTEXT)))))) % GSN 4-MAR-83 14:17 % Compile the function FN Open, given as arguments ARGS with argument % types ARGTYPES. Types may be defined in the definition of function % FN (which may be either a GLAMBDA or LAMBDA function) or by % ARGTYPES; ARGTYPES takes precedence. (DE GLCOMPOPEN (FN ARGS ARGTYPES RESULTTYPE SPCVARS) (PROG (PTR FNDEF GLPROGLST NEWEXPR CONTEXT NEWARGS) % Put a new level on top of CONTEXT. (SETQ CONTEXT (LIST NIL)) (SETQ FNDEF (GLGETD FN)) % Get the parameter declarations and add to CONTEXT. (GLDECL (CADR FNDEF) '(T NIL) CONTEXT NIL NIL) % Make the function parameters into names and put in the values, % hiding any which are simple variables. (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (COND ((EQ ARGS T) (GLADDSTR (CAAR PTR) NIL (OR (CAR ARGTYPES) (CADDAR PTR)) CONTEXT) (SETQ NEWARGS (CONS (CAAR PTR) NEWARGS))) ((AND (ATOM (CAAR ARGS)) (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS))) % Wrap the atom in a PROG1 so it won't match as a name; the PROG1 will % generally be stripped later. (GLADDSTR (LIST 'PROG1 (CAAR ARGS)) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) ((AND (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS)) (PAIRP (CAAR ARGS)) (EQ (CAAAR ARGS) 'PROG1) (ATOM (CADAAR ARGS)) (NULL (CDDAAR ARGS))) (GLADDSTR (CAAR ARGS) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) (T % Since the actual argument is not atomic, make a PROG variable for % it. (SETQ GLPROGLST (CONS (LIST (CAAR PTR) (CAAR ARGS)) GLPROGLST)) (GLADDSTR (CAAR PTR) (CADAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT))) (SETQ PTR (CDR PTR)) (COND ((PAIRP ARGS) (SETQ ARGS (CDR ARGS)))) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ FNDEF (CDDR FNDEF)) % Get rid of comments at start of function. C (COND ((AND FNDEF (PAIRP (CAR FNDEF)) (MEMQ (CAAR FNDEF) '(RESULT * GLOBAL))) (SETQ FNDEF (CDR FNDEF)) (GO C))) (SETQ NEWEXPR (GLPROGN FNDEF CONTEXT)) % Get rid of atomic result if it isnt busy outside. (COND ((AND (NOT VALBUSY) (CDAR EXPR) (OR (ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR) 2)))) (AND (PAIRP (CADR PTR)) (EQ (CAADR PTR) 'PROG1) (ATOM (CADADR PTR)) (NULL (CDDADR PTR))))) (RPLACD PTR NIL))) (SETQ RESULT (LIST (COND (GLPROGLST (SETQ PTR (LASTPAIR (CAR NEWEXPR))) (RPLACA PTR (LIST 'RETURN (CAR PTR))) (GLGENCODE (CONS 'PROG (CONS (REVERSIP GLPROGLST) (CAR NEWEXPR))))) ((CDAR NEWEXPR) (CONS 'PROGN (CAR NEWEXPR))) (T (CAAR NEWEXPR))) (OR RESULTTYPE (GLRESULTTYPE FN NIL) (CADR NEWEXPR)))) (COND ((EQ ARGS T) (RPLACA RESULT (LIST 'LAMBDA (REVERSIP NEWARGS) (CAR RESULT))))) (RETURN RESULT))) % GSN 1-FEB-83 16:18 % Compile a LAMBDA expression to compute the property PROPNAME of type % PROPTYPE for structure STR. The property type STR is allowed for % structure access. (DE GLCOMPPROP (STR PROPNAME PROPTYPE) (PROG (CODE PL SUBPL PROPENT) % See if the property has already been compiled. (COND ((AND (SETQ PL (GET STR 'GLPROPFNS)) (SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL)))) (RETURN (CADR PROPENT)))) % Compile code for this property and save it. (COND ((NOT (MEMQ PROPTYPE '(STR ADJ ISA PROP MSG))) (ERROR 0 NIL))) (OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE)) (RETURN NIL)) (COND ((NOT PL) (PUT STR 'GLPROPFNS (SETQ PL (COPY '((STR) (PROP) (ADJ) (ISA) (MSG))))) (SETQ SUBPL (ASSOC PROPTYPE PL)))) (RPLACD SUBPL (CONS (CONS PROPNAME CODE) (CDR SUBPL))) (RETURN (CAR CODE)))) % GSN 16-FEB-83 11:25 % Compile a message as a closed form, i.e., function name or LAMBDA % form. (DE GLCOMPPROPL (STR PROPNAME PROPTYPE) (PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPPROPL) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (COND ((EQ PROPTYPE 'STR) (COND ((SETQ CODE (GLSTRFN PROPNAME STR NIL)) (RETURN (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (SUBSTIP 'self '*GL* (CAR CODE)) T)) (CADR CODE)))) (T (RETURN NIL)))) ((SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME NIL)) (COND ((ATOM (CADR MSGL)) (COND ((LISTGET (CDDR MSGL) 'OPEN) (SETQ CODE (GLCOMPOPEN (CADR MSGL) T (LIST STR) NIL NIL))) (T (SETQ CODE (LIST (CADR MSGL) (GLRESULTTYPE (CADR MSGL) NIL)))))) ((SETQ CODE (GLADJ (LIST 'self STR) PROPNAME PROPTYPE)) (SETQ CODE (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (CAR CODE) T)) (CADR CODE)))))) ((SETQ TRANS (GLTRANSPARENTTYPES STR)) (GO B)) (T (RETURN NIL))) (RETURN (LIST (GLUNWRAP (CAR CODE) T) (OR (CADR CODE) (LISTGET (CDDR MSGL) 'RESULT)))) % Look for the message in a contained TRANSPARENT type. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS)) PROPNAME PROPTYPE)) (COND ((ATOM (CAR TMP)) (GLERROR 'GLCOMPPROPL (LIST "GLISP cannot currently" "handle inheritance of the property" PROPNAME "which is specified as a function name" "in a TRANSPARENT subtype. Sorry.")) (RETURN NIL))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) STR NIL)) (SETQ NEWVAR (GLMKVAR)) (GLSTRVAL FETCHCODE NEWVAR) (RETURN (LIST (GLUNWRAP (LIST 'LAMBDA (CONS NEWVAR (CDADAR TMP)) (LIST 'PROG (LIST (LIST (CAADAR TMP) (CAR FETCHCODE))) (LIST 'RETURN (CADDAR TMP)))) T) (CADR TMP)))) (T (SETQ TRANS (CDR TRANS)) (GO B))))) % edited: 14-MAR-83 17:07 % Attempt to infer the type of a constant expression. (DE GLCONSTANTTYPE (EXPR) (PROG (TMP TYPES) (COND ((SETQ TMP (COND ((FIXP EXPR) 'INTEGER) ((NUMBERP EXPR) 'NUMBER) ((ATOM EXPR) 'ATOM) ((STRINGP EXPR) 'STRING) ((NOT (PAIRP EXPR)) 'ANYTHING) ((NOT (OR (NULL (CDR EXPR)) (PAIRP (CDR EXPR)))) 'ANYTHING) ((EVERY EXPR (FUNCTION FIXP)) '(LISTOF INTEGER)) ((EVERY EXPR (FUNCTION NUMBERP)) '(LISTOF NUMBER)) ((EVERY EXPR (FUNCTION ATOM)) '(LISTOF ATOM)) ((EVERY EXPR (FUNCTION STRINGP)) '(LISTOF STRING)))) (RETURN TMP))) (SETQ TYPES (MAPCAR EXPR (FUNCTION GLCONSTANTTYPE))) (COND ((EVERY (CDR TYPES) (FUNCTION (LAMBDA (Y) (EQUAL Y (CAR TYPES))))) (RETURN (LIST 'LISTOF (CAR TYPES)))) (T (RETURN (CONS 'LIST TYPES)))))) % edited: 31-AUG-82 15:38 % Test X to see if it represents a compile-time constant value. (DE GLCONST? (X) (OR (NULL X) (EQ X T) (NUMBERP X) (AND (PAIRP X) (EQ (CAR X) 'QUOTE) (ATOM (CADR X))) (AND (ATOM X) (GET X 'GLISPCONSTANTFLG)))) % edited: 9-DEC-82 17:02 % Test to see if X is a constant structure. (DE GLCONSTSTR? (X) (OR (GLCONST? X) (AND (PAIRP X) (OR (EQ (CAR X) 'QUOTE) (AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NE (CAR X) 'APPEND) (NULL (CDDR X)) (NULL (CADDR X)))) (AND (EQ (CAR X) 'LIST) (EVERY (CDR X) (FUNCTION GLCONSTSTR?))) (AND (EQ (CAR X) 'CONS) (GLCONSTSTR? (CADR X)) (GLCONSTSTR? (CADDR X))))))) % edited: 9-DEC-82 17:07 % Get the value of a compile-time constant (DE GLCONSTVAL (X) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) ((AND (PAIRP X) (EQ (CAR X) 'QUOTE)) (CADR X)) ((PAIRP X) (COND ((AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NULL (CDDR X)) (NULL (CADDR X)))) (CADADR X)) ((EQ (CAR X) 'LIST) (MAPCAR (CDR X) (FUNCTION GLCONSTVAL))) ((EQ (CAR X) 'CONS) (CONS (GLCONSTVAL (CADR X)) (GLCONSTVAL (CADDR X)))) (T (ERROR 0 NIL)))) ((AND (ATOM X) (GET X 'GLISPCONSTANTFLG)) (GET X 'GLISPCONSTANTVAL)) (T (ERROR 0 NIL)))) % edited: 5-OCT-82 15:23 (DE GLCP (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN) (GLP FN)))) % GSN 28-JAN-83 09:29 % edited: 1-Jun-81 16:02 % Process a declaration list from a GLAMBDA expression. Each element % of the list is of the form <var>, <var>:<str-descr>, :<str-descr>, % or <var>: (A <str-descr>) or (A <str-descr>) . Forms without a % variable are accepted only if NOVAROK is true. If VALOK is true, a % PROG form (variable value) is allowed. The result is a list of % variable names. (DE GLDECL (LST FLGS GLTOPCTX FN ARGTYPES) (PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR NOVAROK VALOK) (SETQ NOVAROK (CAR FLGS)) (SETQ VALOK (CADR FLGS)) (COND ((NULL GLTOPCTX) (ERROR 0 NIL))) A % Get the next variable/description from LST (COND ((NULL LST) (SETQ ARGTYPES NIL) (SETQ CONTEXT GLTOPCTX) (MAPC (CAR GLTOPCTX) (FUNCTION (LAMBDA (S) (SETQ ARGTYPES (CONS (GLEVALSTR (CADDR S) GLTOPCTX) ARGTYPES)) (RPLACA (CDDR S) (CAR ARGTYPES))))) (SETQ RESULT (REVERSIP RESULT)) (COND (FN (PUT FN 'GLARGUMENTTYPES ARGTYPES))) (RETURN RESULT))) (SETQ TOP (pop LST)) (COND ((NOT (ATOM TOP)) (GO B))) (SETQ VARS NIL) (SETQ STR NIL) (GLSEPINIT TOP) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (COND ((EQ FIRST ':) (COND ((NULL SECOND) (COND ((AND NOVAROK LST (GLOKSTR? (CAR LST))) (GLDECLDS (GLMKVAR) (pop LST)) (GO A)) (T (GO E)))) ((AND NOVAROK (GLOKSTR? SECOND) (NULL (GLSEPNXT))) (GLDECLDS (GLMKVAR) SECOND) (GO A)) (T (GO E))))) D % At least one variable name has been found. Collect other variable % names until a <type> is found. (SETQ VARS (ACONC VARS FIRST)) (COND ((NULL SECOND) (GO C)) ((EQ SECOND ':) (COND ((AND (SETQ THIRD (GLSEPNXT)) (GLOKSTR? THIRD) (NULL (GLSEPNXT))) (SETQ STR THIRD) (GO C)) ((AND (NULL THIRD) (GLOKSTR? (CAR LST))) (SETQ STR (pop LST)) (GO C)) (T (GO E)))) ((EQ SECOND '!,) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)) ((ATOM (CAR LST)) (GLSEPINIT (pop LST)) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)))) (T (GO E))) C % Define the <type> for each variable on VARS. (MAPC VARS (FUNCTION (LAMBDA (X) (GLDECLDS X STR)))) (GO A) B % The top of LST is non-atomic. Must be either (A <type>) or % (<var> <value>) . (COND ((AND (GL-A-AN? (CAR TOP)) NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) ((AND VALOK (NOT (GL-A-AN? (CAR TOP))) (ATOM (CAR TOP)) (CDR TOP)) (SETQ EXPR (CDR TOP)) (SETQ TMP (GLDOEXPR NIL GLTOPCTX T)) (COND (EXPR (GO E))) (GLADDSTR (CAR TOP) NIL (CADR TMP) GLTOPCTX) (SETQ RESULT (CONS (LIST (CAR TOP) (CAR TMP)) RESULT))) ((AND NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) (T (GO E))) (GO A) E (GLERROR 'GLDECL (LIST "Bad argument structure" LST)) (RETURN NIL))) % GSN 26-JAN-83 13:17 % edited: 2-Jan-81 13:39 % Add ATM to the RESULT list of GLDECL, and declare its structure. (DE GLDECLDS (ATM STR) (PROG NIL % If a substitution exists for this type, use it. (COND (ARGTYPES (SETQ STR (pop ARGTYPES))) (GLTYPESUBS (SETQ STR (GLSUBSTTYPE STR GLTYPESUBS)))) (SETQ RESULT (CONS ATM RESULT)) (GLADDSTR ATM NIL STR GLTOPCTX))) % GSN 26-JAN-83 10:28 % Declare variables and types in top of CONTEXT. (DE GLDECLS (VARS TYPES CONTEXT) (PROG NIL A (COND ((NULL VARS) (RETURN NIL))) (GLADDSTR (CAR VARS) NIL (CAR TYPES) CONTEXT) (SETQ VARS (CDR VARS)) (SETQ TYPES (CDR TYPES)) (GO A))) % edited: 19-MAY-82 13:33 % Define the result types for a list of functions. The format of the % argument is a list of dotted pairs, (FN . TYPE) (DE GLDEFFNRESULTTYPES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (PUT Y 'GLRESULTTYPE (CAR X))))))))) % edited: 19-MAY-82 13:05 % Define the result type functions for a list of functions. The format % of the argument is a list of dotted pairs, (FN . TYPEFN) (DE GLDEFFNRESULTTYPEFNS (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PUT (CAR X) 'GLRESULTTYPEFN (CDR X)))))) % GSN 2-MAR-83 10:14 % Define properties for an object type. Each property is of the form % (<propname> (<definition>) <properties>) (DE GLDEFPROP (OBJECT PROP LST) (PROG (LSTP) (MAPC LST (FUNCTION (LAMBDA (X) (COND ((NOT (OR (EQ PROP 'DOC) (AND (EQ PROP 'SUPERS) (ATOM X)) (AND (PAIRP X) (ATOM (CAR X)) (CDR X)))) (PRIN1 "GLDEFPROP: For object ") (PRIN1 OBJECT) (PRIN1 " the ") (PRIN1 PROP) (PRIN1 " property ") (PRIN1 X) (PRIN1 " has bad form.") (TERPRI) (PRIN1 "This property was ignored.") (TERPRI)) (T (SETQ LSTP (CONS X LSTP))))))) (NCONC (GET OBJECT 'GLSTRUCTURE) (LIST PROP (REVERSIP LSTP))))) % GSN 10-FEB-83 12:31 % edited: 17-Sep-81 12:21 % Process a Structure Description. The format of the argument is the % name of the structure followed by its structure description, % followed by other optional arguments. (DE GLDEFSTR (LST SYSTEMFLG) (PROG (STRNAME STR OLDSTR) (SETQ STRNAME (pop LST)) (COND ((AND (NOT SYSTEMFLG) (MEMQ STRNAME GLBASICTYPES)) (PRIN1 "The GLISP type ") (PRIN1 STRNAME) (PRIN1 " may not be redefined by the user.") (TERPRI) (RETURN NIL)) ((SETQ OLDSTR (GET STRNAME 'GLSTRUCTURE)) (COND ((EQUAL OLDSTR LST) (RETURN NIL)) ((NOT GLQUIETFLG) (PRIN1 STRNAME) (PRIN1 " structure redefined.") (TERPRI))) (GLSTRCHANGED STRNAME)) ((NOT SYSTEMFLG) NIL)) (SETQ STR (pop LST)) (PUT STRNAME 'GLSTRUCTURE (LIST STR)) (COND ((NOT (GLOKSTR? STR)) (PRIN1 STRNAME) (PRIN1 " has faulty structure specification.") (TERPRI))) (COND ((NOT (MEMQ STRNAME GLOBJECTNAMES)) (SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES)))) % Process the remaining specifications, if any. Each additional % specification is a list beginning with a keyword. LP (COND ((NULL LST) (RETURN NIL))) (CASEQ (CAR LST) ((ADJ Adj adj) (GLDEFPROP STRNAME 'ADJ (CADR LST))) ((PROP Prop prop) (GLDEFPROP STRNAME 'PROP (CADR LST))) ((ISA Isa IsA isA isa) (GLDEFPROP STRNAME 'ISA (CADR LST))) ((MSG Msg msg) (GLDEFPROP STRNAME 'MSG (CADR LST))) (T (GLDEFPROP STRNAME (CAR LST) (CADR LST)))) (SETQ LST (CDDR LST)) (GO LP))) % edited: 27-APR-82 11:01 (DF GLDEFSTRNAMES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PROG (TMP) (COND ((SETQ TMP (ASSOC (CAR X) GLUSERSTRNAMES)) (RPLACD TMP (CDR X))) (T (SETQ GLUSERSTRNAMES (ACONC GLUSERSTRNAMES X)) ))))))) % GSN 10-FEB-83 11:50 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % GSN 10-FEB-83 12:13 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSYSSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG T))))) % edited: 27-MAY-82 13:00 % This function is called by the user to define a unit package to the % GLISP system. The argument, a unit record, is a list consisting of % the name of a function to test an entity to see if it is a unit of % the units package, the name of the unit package's runtime GET % function, and an ALIST of operations on units and the functions to % perform those operations. Operations include GET, PUT, ISA, ISADJ, % NCONC, REMOVE, PUSH, and POP. (DE GLDEFUNITPKG (UNITREC) (PROG (LST) (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (SETQ GLUNITPKGS (ACONC GLUNITPKGS UNITREC)) (RETURN NIL)) ((EQ (CAAR LST) (CAR UNITREC)) (RPLACA LST UNITREC))) (SETQ LST (CDR LST)) (GO A))) % GSN 23-JAN-83 15:39 % Remove the GLISP structure definition for NAME. (DE GLDELDEF (NAME TYPE) (PUT NAME 'GLSTRUCTURE NIL)) % edited: 28-NOV-82 15:18 (DE GLDESCENDANTP (SUBCLASS CLASS) (PROG (SUPERS) (COND ((EQ SUBCLASS CLASS) (RETURN T))) (SETQ SUPERS (GLGETSUPERS SUBCLASS)) LP (COND ((NULL SUPERS) (RETURN NIL)) ((GLDESCENDANTP (CAR SUPERS) CLASS) (RETURN T))) (SETQ SUPERS (CDR SUPERS)) (GO LP))) % GSN 25-FEB-83 16:41 % edited: 25-Jun-81 15:26 % Function to compile an expression of the form (A <type> ...) (DE GLDOA (EXPR) (PROG (TYPE UNITREC TMP) (SETQ TYPE (CADR EXPR)) (COND ((AND (PAIRP TYPE) (EQ (CAR TYPE) 'TYPEOF)) (SETQ TYPE (GLGETTYPEOF TYPE)) (GLNOTICETYPE TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((GLGETSTR TYPE) (GLNOTICETYPE TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'A (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST EXPR)))) (T (GLERROR 'GLDOA (LIST "The type" TYPE "is not defined.")))))) % GSN 7-MAR-83 16:54 % Compile code for Case statement. (DE GLDOCASE (EXPR) (PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB) (SETQ TYPEOK T) (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (CAR TMP)) (SETQ SELECTORTYPE (CADR TMP)) (SETQ EXPR (CDDR EXPR)) % Get rid of of if present (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ EXPR (CDR EXPR)))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS 'SELECTQ (CONS SELECTOR (ACONC RESULT ELSECLAUSE)))) RESULTTYPE))) ((MEMQ (CAR EXPR) '(ELSE Else else)) (SETQ TMP (GLPROGN (CDR EXPR) CONTEXT)) (SETQ ELSECLAUSE (COND ((CDAR TMP) (CONS 'PROGN (CAR TMP))) (T (CAAR TMP)))) (SETQ EXPR NIL)) (T (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (SETQ RESULT (ACONC RESULT (CONS (COND ((ATOM (CAAR EXPR)) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES (CAAR EXPR) NIL)) (CADR TMPB)) (CAAR EXPR))) (T (MAPCAR (CAAR EXPR) (FUNCTION (LAMBDA (X) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES X NIL)) (CADR TMPB)) X)))))) (CAR TMP)))))) % If all the result types are the same, then we know the result of the % Case statement. (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (COND (EXPR (SETQ EXPR (CDR EXPR)))) (GO A))) % edited: 23-APR-82 14:38 % Compile a COND expression. (DE GLDOCOND (CONDEXPR) (PROG (RESULT TMP TYPEOK RESULTTYPE) (SETQ TYPEOK T) A (COND ((NULL (SETQ CONDEXPR (CDR CONDEXPR))) (GO B))) (SETQ TMP (GLPROGN (CAR CONDEXPR) CONTEXT)) (COND ((NE (CAAR TMP) NIL) (SETQ RESULT (ACONC RESULT (CAR TMP))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ RESULTTYPE NIL) (SETQ TYPEOK NIL))))))) (COND ((NE (CAAR TMP) T) (GO A))) B (RETURN (LIST (COND ((AND (NULL (CDR RESULT)) (EQ (CAAR RESULT) T)) (CONS 'PROGN (CDAR RESULT))) (T (CONS 'COND RESULT))) (AND TYPEOK RESULTTYPE))))) % GSN 4-MAR-83 14:06 % edited: 23-Sep-81 17:08 % Compile a single expression. START is set if EXPR is the start of a % new expression, i.e., if EXPR might be a function call. The global % variable EXPR is the expression, CONTEXT the context in which it % is compiled. VALBUSY is T if the value of the expression is needed % outside the expression. The value is a list of the new expression % and its value-description. (DE GLDOEXPR (START CONTEXT VALBUSY) (PROG (FIRST TMP RESULT) (SETQ EXPRSTACK (CONS EXPR EXPRSTACK)) (COND ((NOT (PAIRP EXPR)) (GLERROR 'GLDOEXPR (LIST "Expression is not a list.")) (GO OUT)) ((AND (NOT START) (STRINGP (CAR EXPR))) (GO A)) ((OR (NOT (IDP (CAR EXPR))) (NOT START)) (GO A))) % Test the initial atom to see if it is a function name. It is assumed % to be a function name if it doesnt contain any GLISP operators and % the following atom doesnt start with a GLISP binary operator. (COND ((AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAR EXPR) '*)) (SETQ RESULT (LIST EXPR NIL)) (GO OUT)) ((MEMQ (CAR EXPR) ''Quote) (SETQ FIRST (CAR EXPR)) (GO B))) (GLSEPINIT (CAR EXPR)) % See if the initial atom contains an expression operator. (COND ((NE (SETQ FIRST (GLSEPNXT)) (CAR EXPR)) (COND ((OR (MEMQ (CAR EXPR) '(APPLY* BLKAPPLY* PACK* PP*)) (GETDDD (CAR EXPR)) (GET (CAR EXPR) 'MACRO) (AND (NE FIRST '~) (GLOPERATOR? FIRST))) (GLSEPCLR) (SETQ FIRST (CAR EXPR)) (GO B)) (T (GLSEPCLR) (GO A)))) ((OR (EQ FIRST '~) (EQ FIRST '-)) (GLSEPCLR) (GO A)) ((OR (NOT (PAIRP (CDR EXPR))) (NOT (IDP (CADR EXPR)))) (GO B))) % See if the initial atom is followed by an expression operator. (GLSEPINIT (CADR EXPR)) (SETQ TMP (GLSEPNXT)) (GLSEPCLR) (COND ((GLOPERATOR? TMP) (GO A))) % The EXPR is a function reference. Test for system functions. B (SETQ RESULT (CASEQ FIRST ('Quote (LIST EXPR (GLCONSTANTTYPE (CADR EXPR)))) ((GO Go go) (LIST EXPR NIL)) ((PROG Prog prog) (GLDOPROG EXPR CONTEXT)) ((FUNCTION Function function) (GLDOFUNCTION EXPR NIL CONTEXT T)) ((SETQ Setq setq) (GLDOSETQ EXPR)) ((COND Cond cond) (GLDOCOND EXPR)) ((RETURN Return return) (GLDORETURN EXPR)) ((FOR For for) (GLDOFOR EXPR)) ((THE The the) (GLDOTHE EXPR)) ((THOSE Those those) (GLDOTHOSE EXPR)) ((IF If if) (GLDOIF EXPR CONTEXT)) ((A a AN An an) (GLDOA EXPR)) ((_ SEND Send send) (GLDOSEND EXPR)) ((PROGN PROG2) (GLDOPROGN EXPR)) (PROG1 (GLDOPROG1 EXPR CONTEXT)) ((SELECTQ CASEQ) (GLDOSELECTQ EXPR CONTEXT)) ((WHILE While while) (GLDOWHILE EXPR CONTEXT)) ((REPEAT Repeat repeat) (GLDOREPEAT EXPR)) ((CASE Case case) (GLDOCASE EXPR)) ((MAP MAPLIST MAPCON MAPC MAPCAR MAPCONC MAPCAN) (GLDOMAP EXPR)) (T (GLUSERFN EXPR)))) (GO OUT) A % The current EXPR is possibly a GLISP expression. Parse the next % subexpression using GLPARSEXPR. (SETQ RESULT (GLPARSEXPR)) OUT (SETQ EXPRSTACK (CDR EXPRSTACK)) (RETURN RESULT))) % GSN 2-MAR-83 17:03 % edited: 21-Apr-81 11:25 % Compile code for a FOR loop. (DE GLDOFOR (EXPR) (PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT LOOPCONTENTS SINGFLAG LOOPCOND COLLECTCODE) (SETQ ORIGEXPR EXPR) (pop EXPR) % Parse the forms (FOR EACH <set> ...) and (FOR <var> IN <set> ...) (COND ((MEMQ (CAR EXPR) '(EACH Each each)) (SETQ SINGFLAG T) (pop EXPR)) ((AND (ATOM (CAR EXPR)) (MEMQ (CADR EXPR) '(IN In in))) (SETQ LOOPVAR (pop EXPR)) (pop EXPR)) (T (GO X))) % Now get the <set> (COND ((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG))) (GO X))) (SETQ DTYPE (GLXTRTYPE (CADR DOMAIN))) (COND ((OR (NULL DTYPE) (EQ DTYPE 'ANYTHING)) (SETQ DTYPE '(LISTOF ANYTHING))) ((OR (NOT (PAIRP DTYPE)) (NE (CAR DTYPE) 'LISTOF)) (COND ((OR (AND (PAIRP (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (EQ (CAR DTYPE) 'LISTOF)) (NULL DTYPE))) (T (GLERROR 'GLDOFOR (LIST "Warning: The domain of a FOR loop is of type" DTYPE "which is not a LISTOF type.")) (SETQ DTYPE '(LISTOF ANYTHING)))))) % Add a level onto the context for the inside of the loop. (SETQ NEWCONTEXT (CONS NIL CONTEXT)) % If a loop variable wasnt specified, make one. (OR LOOPVAR (SETQ LOOPVAR (GLMKVAR))) (GLADDSTR LOOPVAR (AND SINGFLAG DOMAINNAME) (CADR DTYPE) NEWCONTEXT) % See if a condition is specified. If so, add it to LOOPCOND. (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT NIL NIL))) ((MEMQ (CAR EXPR) '(WHICH Which which WHO Who who THAT That that)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT T T)))) (COND ((AND EXPR (MEMQ (CAR EXPR) '(when When WHEN))) (pop EXPR) (SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT T))))) (COND ((MEMQ (CAR EXPR) '(collect Collect COLLECT)) (pop EXPR) (SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T))) (T (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) (SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT))))) (RETURN (GLMAKEFORLOOP LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)) X (RETURN (GLUSERFN ORIGEXPR)))) % GSN 26-JAN-83 10:14 % Compile a functional expression. TYPES is a list of argument types % which is sent in from outside, e.g. when a mapping function is % compiled. (DE GLDOFUNCTION (EXPR ARGTYPES CONTEXT VALBUSY) (PROG (NEWCODE RESULTTYPE PTR ARGS) (COND ((NOT (AND (PAIRP EXPR) (MEMQ (CAR EXPR) ''FUNCTION))) (RETURN (GLPUSHEXPR EXPR T CONTEXT T))) ((ATOM (CADR EXPR)) (RETURN (LIST EXPR (GLRESULTTYPE (CADR EXPR) ARGTYPES)))) ((NOT (MEMQ (CAADR EXPR) '(GLAMBDA LAMBDA))) (GLERROR 'GLDOFUNCTION (LIST "Bad functional form.")))) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ ARGS (GLDECL (CADADR EXPR) '(T NIL) CONTEXT NIL NIL)) (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (GLADDSTR (CAAR PTR) NIL (OR (CADDAR PTR) (CAR ARGTYPES)) CONTEXT) (SETQ PTR (CDR PTR)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ NEWCODE (GLPROGN (CDDADR EXPR) CONTEXT)) (RETURN (LIST (LIST 'FUNCTION (CONS 'LAMBDA (CONS ARGS (CAR NEWCODE)))) (CADR NEWCODE))))) % edited: 4-MAY-82 10:46 % Process an IF ... THEN expression. (DE GLDOIF (EXPR CONTEXT) (PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT) (SETQ OLDCONTEXT CONTEXT) (pop EXPR) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'COND CONDLIST) TYPE)))) (SETQ CONTEXT (CONS NIL OLDCONTEXT)) (SETQ PRED (GLPREDICATE NIL CONTEXT NIL T)) (COND ((MEMQ (CAR EXPR) '(THEN Then then)) (pop EXPR))) (SETQ ACTIONS (CONS (CAR PRED) NIL)) (SETQ TYPE (CADR PRED)) C (SETQ CONDLIST (ACONC CONDLIST ACTIONS)) B (COND ((NULL EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSEIF ElseIf Elseif elseIf elseif)) (pop EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSE Else else)) (pop EXPR) (SETQ ACTIONS (CONS T NIL)) (SETQ TYPE 'BOOLEAN) (GO C)) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (ACONC ACTIONS (CAR TMP)) (SETQ TYPE (CADR TMP)) (GO B)) (T (GLERROR 'GLDOIF (LIST "IF statement contains bad code.")))))) % edited: 16-DEC-81 15:47 % Compile a LAMBDA expression for which the ARGTYPES are given. (DE GLDOLAMBDA (EXPR ARGTYPES CONTEXT) (PROG (ARGS NEWEXPR VALBUSY) (SETQ ARGS (CADR EXPR)) (SETQ CONTEXT (CONS NIL CONTEXT)) LP (COND (ARGS (GLADDSTR (CAR ARGS) NIL (CAR ARGTYPES) CONTEXT) (SETQ ARGS (CDR ARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP))) (SETQ VALBUSY T) (SETQ NEWEXPR (GLPROGN (CDDR EXPR) CONTEXT)) (RETURN (LIST (CONS 'LAMBDA (CONS (CADR EXPR) (CAR NEWEXPR))) (CADR NEWEXPR))))) % edited: 30-MAY-82 16:12 % Get a domain specification from the EXPR. If SINGFLAG is set and the % top of EXPR is a simple atom, the atom is made plural and used as % a variable or field name. (DE GLDOMAIN (SINGFLAG) (PROG (NAME FIRST) (COND ((MEMQ (CAR EXPR) '(THE The the)) (SETQ FIRST (CAR EXPR)) (RETURN (GLPARSFLD NIL))) ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (SETQ NAME (GLSEPNXT)) (CAR EXPR)) (pop EXPR) (SETQ DOMAINNAME NAME) (RETURN (COND (SINGFLAG (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ FIRST 'THE) (SETQ EXPR (CONS (GLPLURAL NAME) EXPR)) (GLPARSFLD NIL)) (T (GLIDNAME (GLPLURAL NAME) NIL)))) (T (GLIDNAME NAME NIL))))) (T (GLSEPCLR) (RETURN (GLDOEXPR NIL CONTEXT T))))) (T (RETURN (GLDOEXPR NIL CONTEXT T)))))) % edited: 29-DEC-82 14:50 % Compile code for MAP functions. MAPs are treated specially so that % types can be propagated. (DE GLDOMAP (EXPR) (PROG (MAPFN MAPSET SETTYPE MAPCODE NEWCODE RESULTTYPE ITEMTYPE) (SETQ MAPFN (CAR EXPR)) (SETQ EXPR (CDR EXPR)) (PROGN (SETQ MAPSET (GLDOEXPR NIL CONTEXT T)) (COND ((OR (NULL EXPR) (CDR EXPR)) (GLERROR 'GLDOMAP (LIST "Bad form of mapping function."))) (T (SETQ MAPCODE (CAR EXPR))))) (SETQ SETTYPE (GLXTRTYPEB (CADR MAPSET))) (COND ((AND (PAIRP SETTYPE) (EQ (CAR SETTYPE) 'LISTOF)) (SETQ ITEMTYPE (CASEQ MAPFN ((MAP MAPLIST MAPCON) SETTYPE) ((MAPC MAPCAR MAPCONC MAPCAN) (CADR SETTYPE)) (T (ERROR 0 NIL)))))) (SETQ NEWCODE (GLDOFUNCTION MAPCODE (LIST ITEMTYPE) CONTEXT (MEMQ MAPFN '(MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) ))) (SETQ RESULTTYPE (CASEQ MAPFN ((MAP MAPC) NIL) ((MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) (LIST 'LISTOF (CADR NEWCODE))) (T (ERROR 0 NIL)))) (RETURN (LIST (GLGENCODE (LIST MAPFN (CAR MAPSET) (CAR NEWCODE))) RESULTTYPE)))) % GSN 10-FEB-83 12:56 % Attempt to compile code for the sending of a message to an object. % OBJECT is the destination, in the form (<code> <type>) , SELECTOR % is the message selector, and ARGS is a list of arguments of the % form (<code> <type>) . The result is of this form, or NIL if % failure. (DE GLDOMSG (OBJECT SELECTOR ARGS) (PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (COND ((SETQ METHOD (GLSTRPROP TYPE 'MSG SELECTOR ARGS)) (RETURN (GLCOMPMSGL OBJECT 'MSG METHOD ARGS CONTEXT))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'MSG (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST OBJECT SELECTOR ARGS)))) ((SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT)))) ((AND (MEMQ TYPE '(NUMBER REAL INTEGER)) (MEMQ SELECTOR '(+ - * / ^ > < >= <=)) ARGS (NULL (CDR ARGS)) (MEMQ (GLXTRTYPE (CADAR ARGS)) '(NUMBER REAL INTEGER))) (RETURN (GLREDUCEARITH SELECTOR OBJECT (CAR ARGS)))) (T (RETURN NIL))) % See if the message can be handled by a TRANSPARENT subobject. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLDOMSG (LIST '*GL* (GLXTRTYPE (CAR TRANS))) SELECTOR ARGS)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR OBJECT) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR OBJECT)) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % GSN 26-JAN-83 10:14 % edited: 17-Sep-81 14:01 % Compile a PROG expression. (DE GLDOPROG (EXPR CONTEXT) (PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE) (pop EXPR) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ PROGLST (GLDECL (pop EXPR) '(NIL T) CONTEXT NIL NIL)) (SETQ CONTEXT (CONS NIL CONTEXT)) % Compile the contents of the PROG onto NEWEXPR % Compile the next expression in a PROG. L (COND ((NULL EXPR) (GO X))) (SETQ NEXTEXPR (pop EXPR)) (COND ((ATOM NEXTEXPR) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) % ***** % Set up the context for the label we just found. (GO L)) ((NOT (PAIRP NEXTEXPR)) (GLERROR 'GLDOPROG (LIST "PROG contains bad stuff:" NEXTEXPR)) (GO L)) ((EQ (CAR NEXTEXPR) '*) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) (GO L))) (COND ((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL)) (SETQ NEWEXPR (CONS (CAR TMP) NEWEXPR)))) (GO L) X (SETQ RESULT (CONS 'PROG (CONS PROGLST (REVERSIP NEWEXPR)))) (RETURN (LIST RESULT RESULTTYPE)))) % edited: 5-NOV-81 14:31 % Compile a PROGN in the source program. (DE GLDOPROGN (EXPR) (PROG (RES) (SETQ RES (GLPROGN (CDR EXPR) CONTEXT)) (RETURN (LIST (CONS (CAR EXPR) (CAR RES)) (CADR RES))))) % edited: 25-JAN-82 17:34 % Compile a PROG1, whose result is the value of its first argument. (DE GLDOPROG1 (EXPR CONTEXT) (PROG (RESULT TMP TYPE TYPEFLG) (SETQ EXPR (CDR EXPR)) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'PROG1 (REVERSIP RESULT)) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG))) (SETQ RESULT (CONS (CAR TMP) RESULT)) % Get the result type from the first item of the PROG1. (COND ((NOT TYPEFLG) (SETQ TYPE (CADR TMP)) (SETQ TYPEFLG T))) (GO A)) (T (GLERROR 'GLDOPROG1 (LIST "PROG1 contains bad subexpression.")) (pop EXPR) (GO A))))) % edited: 26-MAY-82 15:12 (DE GLDOREPEAT (EXPR) (PROG (ACTIONS TMP LABEL) (pop EXPR) A (COND ((MEMQ (CAR EXPR) '(UNTIL Until until)) (pop EXPR)) ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (RETURN (GLERROR 'GLDOREPEAT (LIST "REPEAT contains bad subexpression."))))) (COND ((OR (NULL EXPR) (NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL))) EXPR) (GLERROR 'GLDOREPEAT (LIST "REPEAT contains no UNTIL or bad UNTIL clause")) (SETQ TMP (LIST T 'BOOLEAN)))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (CONS 'PROG (CONS NIL (CONS LABEL (ACONC ACTIONS (LIST 'COND (LIST (GLBUILDNOT (CAR TMP)) (LIST 'GO LABEL))))))) NIL)))) % edited: 7-Apr-81 11:49 % Compile a RETURN, capturing the type of the result as a type of the % function result. (DE GLDORETURN (EXPR) (PROG (TMP) (pop EXPR) (COND ((NULL EXPR) (GLADDRESULTTYPE NIL) (RETURN '((RETURN) NIL))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (GLADDRESULTTYPE (CADR TMP)) (RETURN (LIST (LIST 'RETURN (CAR TMP)) (CADR TMP))))))) % edited: 26-AUG-82 09:30 % Compile a SELECTQ. Special treatment is necessary in order to quote % the selectors implicitly. (DE GLDOSELECTQ (EXPR CONTEXT) (PROG (RESULT RESULTTYPE TYPEOK KEY TMP TMPB FN) (SETQ FN (CAR EXPR)) (SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)))) (SETQ TYPEOK T) (SETQ EXPR (CDDR EXPR)) % If the selection criterion is constant, do it directly. (COND ((OR (SETQ KEY (NUMBERP (CAR RESULT))) (AND (PAIRP (CAR RESULT)) (EQ (CAAR RESULT) 'QUOTE) (SETQ KEY (CADAR RESULT)))) (SETQ TMP (SOME EXPR (FUNCTION (LAMBDA (X) (COND ((ATOM (CAR X)) (EQUAL KEY (CAR X))) ((PAIRP (CAR X)) (MEMBER KEY (CAR X))) (T NIL)))))) (COND ((OR (NULL TMP) (NULL (CDR TMP))) (SETQ TMPB (GLPROGN (LASTPAIR EXPR) CONTEXT))) (T (SETQ TMPB (GLPROGN (CDAR TMP) CONTEXT)))) (RETURN (LIST (CONS 'PROGN (CAR TMPB)) (CADR TMPB))))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS FN RESULT)) RESULTTYPE)))) (SETQ RESULT (ACONC RESULT (COND ((OR (CDR EXPR) (EQ FN 'CASEQ)) (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (CONS (CAAR EXPR) (CAR TMP))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (CAR TMP))))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 4-JUN-82 15:35 % Compile code for the sending of a message to an object. The syntax % of the message expression is % (_ <object> <selector> <arg1>...<argn>) , where the _ may % optionally be SEND, Send, or send. (DE GLDOSEND (EXPRR) (PROG (EXPR OBJECT SELECTOR ARGS TMP FNNAME) (SETQ FNNAME (CAR EXPRR)) (SETQ EXPR (CDR EXPRR)) (SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (pop EXPR)) (COND ((OR (NULL SELECTOR) (NOT (IDP SELECTOR))) (RETURN (GLERROR 'GLDOSEND (LIST SELECTOR "is an illegal message Selector."))))) % Collect arguments of the message, if any. A (COND ((NULL EXPR) (COND ((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS)) (RETURN TMP)) (T % No message was defined, so just pass it through and hope one will be % defined by runtime. (RETURN (LIST (GLGENCODE (CONS FNNAME (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (CADR OBJECT)))))) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (SETQ ARGS (ACONC ARGS TMP)) (GO A)) (T (GLERROR 'GLDOSEND (LIST "A message argument is bad.")))))) % edited: 7-Apr-81 11:52 % Compile a SETQ expression (DE GLDOSETQ (EXPR) (PROG (VAR) (pop EXPR) (SETQ VAR (pop EXPR)) (RETURN (GLDOVARSETQ VAR (GLDOEXPR NIL CONTEXT T))))) % edited: 20-MAY-82 15:13 % Process a THE expression in a list. (DE GLDOTHE (EXPR) (PROG (RESULT) (SETQ RESULT (GLTHE NIL)) (COND (EXPR (GLERROR 'GLDOTHE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 20-MAY-82 15:16 % Process a THE expression in a list. (DE GLDOTHOSE (EXPR) (PROG (RESULT) (SETQ EXPR (CDR EXPR)) (SETQ RESULT (GLTHE T)) (COND (EXPR (GLERROR 'GLDOTHOSE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 5-MAY-82 15:51 % Compile code to do a SETQ of VAR to the RHS. If the type of VAR is % unknown, it is set to the type of RHS. (DE GLDOVARSETQ (VAR RHS) (PROG NIL (GLUPDATEVARTYPE VAR (CADR RHS)) (RETURN (LIST (LIST 'SETQ VAR (CAR RHS)) (CADR RHS))))) % edited: 4-MAY-82 10:46 (DE GLDOWHILE (EXPR CONTEXT) (PROG (ACTIONS TMP LABEL) (SETQ CONTEXT (CONS NIL CONTEXT)) (pop EXPR) (SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T)))) (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) A (COND ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (GLERROR 'GLDOWHILE (LIST "Bad stuff in While statement:" EXPR)) (pop EXPR) (GO A))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (LIST 'PROG NIL LABEL (LIST 'COND (ACONC ACTIONS (LIST 'GO LABEL)))) NIL)))) % edited: 23-DEC-82 10:47 % Produce code to test the two sides for equality. (DE GLEQUALFN (LHS RHS) (PROG (TMP LHSTP RHSTP) (RETURN (COND ((SETQ TMP (GLDOMSG LHS '= (LIST RHS))) TMP) ((SETQ TMP (GLUSERSTROP LHS '= RHS)) TMP) (T (SETQ LHSTP (CADR LHS)) (SETQ RHSTP (CADR RHS)) (LIST (COND ((NULL (CAR RHS)) (LIST 'NULL (CAR LHS))) ((NULL (CAR LHS)) (LIST 'NULL (CAR RHS))) (T (GLGENCODE (LIST (COND ((OR (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER)) 'EQP) ((OR (GLATOMTYPEP LHSTP) (GLATOMTYPEP RHSTP)) 'EQ) ((AND (EQ LHSTP 'STRING) (EQ RHSTP 'STRING)) 'STREQUAL) (T 'EQUAL)) (CAR LHS) (CAR RHS))))) 'BOOLEAN)))))) % edited: 23-SEP-82 11:52 (DF GLERR (ERREXP) (PRIN1 "Execution of GLISP error expression: ")(PRINT ERREXP)(ERROR 0 NIL)) % GSN 26-JAN-83 13:42 % Look through a structure to see if it involves evaluating other % structures to produce a concrete type. (DE GLEVALSTR (STR CONTEXT) (PROG (GLEVALSUBS) (GLEVALSTRB STR) (RETURN (COND (GLEVALSUBS (GLSUBLIS GLEVALSUBS STR)) (T STR))))) % GSN 30-JAN-83 15:34 % Find places where substructures need to be evaluated and collect % substitutions for them. (DE GLEVALSTRB (STR) (PROG (TMP EXPR) (COND ((ATOM STR) (RETURN NIL)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((EQ (CAR STR) 'TYPEOF) (SETQ EXPR (CDR STR)) (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (COND ((CADR TMP) (SETQ GLEVALSUBS (CONS (CONS STR (CADR TMP)) GLEVALSUBS))) (T (GLERROR 'GLEVALSTRB (LIST "The evaluated type" STR "was not found.") ))) (RETURN NIL)) (T (MAPC (CDR STR) (FUNCTION GLEVALSTRB)))))) % GSN 27-JAN-83 13:56 % If a PROGN occurs within a PROGN, expand it by splicing its contents % into the top-level list. (DE GLEXPANDPROGN (LST BUSY PROGFLG) (PROG (X Y) (SETQ Y LST) LP (SETQ X (CDR Y)) (COND ((NULL X) (RETURN LST)) ((NOT (PAIRP (CAR X))) % Eliminate non-busy atomic items. (COND ((AND (NOT PROGFLG) (OR (CDR X) (NOT BUSY))) (RPLACD Y (CDR X)) (GO LP)))) ((MEMQ (CAAR X) '(PROGN PROG2)) % Expand contained PROGNs in-line. (COND ((CDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDAR X)))) (RPLACA X (CADAR X))) ((AND (EQ (CAAR X) 'PROG) (NULL (CADAR X)) (EVERY (CDDAR X) (FUNCTION (LAMBDA (Y) (NOT (ATOM Y))))) (NOT (GLOCCURS 'RETURN (CDDAR X)))) % Expand contained simple PROGs. (COND ((CDDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDDAR X)))) (RPLACA X (CADDAR X)))) (SETQ Y (CDR Y)) (GO LP))) % edited: 9-JUN-82 12:55 % Test if EXPR is expensive to compute. (DE GLEXPENSIVE? (EXPR) (COND ((ATOM EXPR) NIL) ((NOT (PAIRP EXPR)) (ERROR 0 NIL)) ((MEMQ (CAR EXPR) '(CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR CADDDR)) (GLEXPENSIVE? (CADR EXPR))) ((AND (EQ (CAR EXPR) 'PROG1) (NULL (CDDR EXPR))) (GLEXPENSIVE? (CADR EXPR))) (T T))) % edited: 2-Jan-81 14:26 % Find the first entry for variable VAR in the CONTEXT structure. (DE GLFINDVARINCTX (VAR CONTEXT) (AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT)) (GLFINDVARINCTX VAR (CDR CONTEXT))))) % edited: 19-OCT-82 15:19 % Generate code of the form X. The code generated by the compiler is % transformed, if necessary, for the output dialect. (DE GLGENCODE (X) (GLPSLTRANSFM X)) % edited: 20-Mar-81 15:52 % Get the value for the entry KEY from the a-list ALST. GETASSOC is % used so that the corresponding PUTASSOC can be generated by % GLPUTFN. (DE GLGETASSOC (KEY ALST) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC KEY ALST)) (CDR TMP))))) % edited: 30-AUG-82 10:25 (DE GLGETCONSTDEF (ATM) (COND ((GET ATM 'GLISPCONSTANTFLG) (LIST (KWOTE (GET ATM 'GLISPCONSTANTVAL)) (GET ATM 'GLISPCONSTANTTYPE))) (T NIL))) % edited: 30-OCT-81 12:20 % Get the GLISP object description for NAME for the file package. (DE GLGETDEF (NAME TYPE) (LIST 'GLDEFSTRQ (CONS NAME (GET NAME 'GLSTRUCTURE)))) % edited: 5-OCT-82 15:06 % Find a way to retrieve the FIELD from the structure pointed to by % SOURCE (which may be a variable name, NIL, or a list (CODE DESCR)) % relative to CONTEXT. The result is a list of code to get the field % and the structure description of the resulting field. (DE GLGETFIELD (SOURCE FIELD CONTEXT) (PROG (TMP CTXENTRY CTXLIST) (COND ((NULL SOURCE) (GO B)) ((ATOM SOURCE) (COND ((SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT)) (COND ((SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY) NIL)) (RETURN TMP)) (T (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for" SOURCE "whose type is" (CADDR CTXENTRY)))))) ((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT)) (SETQ SOURCE TMP)) ((SETQ TMP (GLGETGLOBALDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) ((SETQ TMP (GLGETCONSTDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The name" SOURCE "cannot be found."))))))) (COND ((PAIRP SOURCE) (COND ((SETQ TMP (GLVALUE (CAR SOURCE) FIELD (CADR SOURCE) NIL)) (RETURN TMP)) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for type" (CADR SOURCE) "in" (CAR SOURCE)))))))) B % No source is specified. Look for a source in the context. (COND ((NULL CONTEXT) (RETURN NIL))) (SETQ CTXLIST (pop CONTEXT)) C (COND ((NULL CTXLIST) (GO B))) (SETQ CTXENTRY (pop CTXLIST)) (COND ((EQ FIELD (CADR CTXENTRY)) (RETURN (LIST (CAR CTXENTRY) (CADDR CTXENTRY)))) ((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY) FIELD (CADDR CTXENTRY) NIL))) (GO C))) (RETURN TMP))) % edited: 27-MAY-82 13:01 % Call the appropriate function to compile code to get the indicator % (QUOTE IND') from the item whose description is DES, where DES % describes a unit in a unit package whose record is UNITREC. (DE GLGETFROMUNIT (UNITREC IND DES) (PROG (TMP) (COND ((SETQ TMP (ASSOC 'GET (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST IND DES)))) (T (RETURN NIL))))) % edited: 23-APR-82 16:58 (DE GLGETGLOBALDEF (ATM) (COND ((GET ATM 'GLISPGLOBALVAR) (LIST ATM (GET ATM 'GLISPGLOBALVARTYPE))) (T NIL))) % edited: 4-JUN-82 15:36 % Get pairs of <field> = <value>, where the = and , are optional. (DE GLGETPAIRS (EXPR) (PROG (PROP VAL PAIRLIST) A (COND ((NULL EXPR) (RETURN PAIRLIST)) ((NOT (ATOM (SETQ PROP (pop EXPR)))) (GLERROR 'GLGETPAIRS (LIST PROP "is not a legal property name."))) ((EQ PROP '!,) (GO A))) (COND ((MEMQ (CAR EXPR) '(= _ :=)) (pop EXPR))) (SETQ VAL (GLDOEXPR NIL CONTEXT T)) (SETQ PAIRLIST (ACONC PAIRLIST (CONS PROP VAL))) (GO A))) % edited: 23-DEC-81 12:52 (DE GLGETSTR (DES) (PROG (TYPE TMP) (RETURN (AND (SETQ TYPE (GLXTRTYPE DES)) (ATOM TYPE) (SETQ TMP (GET TYPE 'GLSTRUCTURE)) (CAR TMP))))) % edited: 28-NOV-82 15:10 % Get the superclasses of CLASS. (DE GLGETSUPERS (CLASS) (LISTGET (CDR (GET CLASS 'GLSTRUCTURE)) 'SUPERS)) % GSN 9-FEB-83 15:28 % Get the type of an expression. (DE GLGETTYPEOF (TYPE) (PROG (TMP) (COND ((SETQ TMP (GLPUSHEXPR (CDR TYPE) NIL CONTEXT T)) (RETURN (CADR TMP)))))) % edited: 21-MAY-82 17:01 % Identify a given name as either a known variable name of as an % implicit field reference. (DE GLIDNAME (NAME DEFAULTFLG) (PROG (TMP) (RETURN (COND ((ATOM NAME) (COND ((NULL NAME) (LIST NIL NIL)) ((IDP NAME) (COND ((EQ NAME T) (LIST NAME 'BOOLEAN)) ((SETQ TMP (GLVARTYPE NAME CONTEXT)) (LIST NAME (COND ((EQ TMP '*NIL*) NIL) (T TMP)))) ((GLGETFIELD NIL NAME CONTEXT)) ((SETQ TMP (GLIDTYPE NAME CONTEXT)) (LIST (CAR TMP) (CADDR TMP))) ((GLGETCONSTDEF NAME)) ((GLGETGLOBALDEF NAME)) (T (COND ((OR (NOT DEFAULTFLG) GLCAUTIOUSFLG) (GLERROR 'GLIDNAME (LIST "The name" NAME "cannot be found in this context.")))) (LIST NAME NIL)))) ((FIXP NAME) (LIST NAME 'INTEGER)) ((FLOATP NAME) (LIST NAME 'REAL)) (T (GLERROR 'GLIDNAME (LIST NAME "is an illegal name."))))) (T NAME))))) % edited: 27-MAY-82 13:02 % Try to identify a name by either its referenced name or its type. (DE GLIDTYPE (NAME CONTEXT) (PROG (CTXLEVELS CTXLEVEL CTXENTRY) (SETQ CTXLEVELS CONTEXT) LPA (COND ((NULL CTXLEVELS) (RETURN NIL))) (SETQ CTXLEVEL (pop CTXLEVELS)) LPB (COND ((NULL CTXLEVEL) (GO LPA))) (SETQ CTXENTRY (CAR CTXLEVEL)) (SETQ CTXLEVEL (CDR CTXLEVEL)) (COND ((OR (EQ (CADR CTXENTRY) NAME) (EQ (CADDR CTXENTRY) NAME) (AND (PAIRP (CADDR CTXENTRY)) (GL-A-AN? (CAADDR CTXENTRY)) (EQ NAME (CADR (CADDR CTXENTRY))))) (RETURN CTXENTRY))) (GO LPB))) % GSN 4-MAR-83 11:57 % Initialize things for GLISP (DE GLINIT NIL (PROG NIL (SETQ GLSEPBITTBL (MAKEBITTABLE '(: _ + - !' = ~ < > * / !, ^))) (SETQ GLUNITPKGS NIL) (SETQ GLSEPMINUS NIL) (SETQ GLQUIETFLG NIL) (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0) (SETQ GLBREAKONERROR NIL) (SETQ GLUSERSTRNAMES NIL) (SETQ GLTYPESUSED NIL) (SETQ GLLASTFNCOMPILED NIL) (SETQ GLLASTSTREDITED NIL) (SETQ GLCAUTIOUSFLG NIL) (MAPC '(EQ NE EQUAL AND OR NOT MEMQ ADD1 SUB1 EQN ASSOC PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ CAR CDR CAAR CADR) (FUNCTION (LAMBDA (X) (PUT X 'GLEVALWHENCONST T)))) (MAPC '(ADD1 SUB1 EQN PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ) (FUNCTION (LAMBDA (X) (PUT X 'GLARGSNUMBERP T)))) (GLDEFFNRESULTTYPES '((NUMBER (PLUS MINUS DIFFERENCE TIMES EXPT QUOTIENT REMAINDER MIN MAX ABS)) (INTEGER (LENGTH FIX ADD1 SUB1)) (REAL (SQRT LOG EXP SIN COS ATAN ARCSIN ARCCOS ARCTAN ARCTAN2 FLOAT)) (BOOLEAN (ATOM NULL EQUAL MINUSP ZEROP GREATERP LESSP NUMBERP FIXP FLOATP STRINGP ARRAYP EQ NOT NULL BOUNDP)))) (GLDEFFNRESULTTYPES '((INTEGER (FLATSIZE FLATSIZE2)) (BOOLEAN (EQN NE PAIRP IDP UNBOUNDP)) (STRING (SUBSTRING CONCAT)))) (GLDEFFNRESULTTYPEFNS (APPEND '((CONS . GLLISTRESULTTYPEFN) (LIST . GLLISTRESULTTYPEFN) (NCONC . GLLISTRESULTTYPEFN)) '((PNTH . GLNTHRESULTTYPEFN)))) (GLDEFSYSSTRQ (STRING STRING PROP ((LENGTH ((ADD1 (SIZE self))) RESULT INTEGER)) MSG ((+ CONCAT RESULT STRING))) (INTEGER INTEGER SUPERS (NUMBER)) (ATOM ATOM PROP ((PNAME ID2STRING RESULT STRING))) (REAL REAL SUPERS (NUMBER))))) % edited: 26-JUL-82 17:07 % Look up an instance function of an abstract function name which % takes arguments of the specified types. (DE GLINSTANCEFN (FNNAME ARGTYPES) (PROG (INSTANCES IARGS TMP) (OR (SETQ INSTANCES (GET FNNAME 'GLINSTANCEFNS)) (RETURN NIL)) % Get ultimate data types for arguments. LP (COND ((NULL INSTANCES) (RETURN NIL))) (SETQ IARGS (GET (CAAR INSTANCES) 'GLARGUMENTTYPES)) (SETQ TMP ARGTYPES) % Match the ultimate types of each argument. LPB (COND ((NULL IARGS) (RETURN (CAR INSTANCES))) ((EQUAL (GLXTRTYPEB (CAR IARGS)) (GLXTRTYPEB (CAR TMP))) (SETQ IARGS (CDR IARGS)) (SETQ TMP (CDR TMP)) (GO LPB))) (SETQ INSTANCES (CDR INSTANCES)) (GO LP))) % GSN 3-FEB-83 14:13 % Make a new name for an instance of a generic function. (DE GLINSTANCEFNNAME (FN) (PROG (INSTFN N) (SETQ N (ADD1 (OR (GET FN 'GLINSTANCEFNNO) 0))) (PUT FN 'GLINSTANCEFNNO N) (SETQ INSTFN (IMPLODE (NCONC (EXPLODE FN) (CONS '- (EXPLODE N))))) (PUT FN 'GLINSTANCEFNS (CONS INSTFN (GET FN 'GLINSTANCEFNS))) (RETURN INSTFN))) % edited: 30-AUG-82 10:28 % Define compile-time constants. (DF GLISPCONSTANTS (ARGS) (PROG (TMP EXPR EXPRSTACK FAULTFN) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPCONSTANTFLG T) (PUT (CAR ARG) 'GLISPORIGCONSTVAL (CADR ARG)) (PUT (CAR ARG) 'GLISPCONSTANTVAL (PROGN (SETQ EXPR (LIST (CADR ARG))) (SETQ TMP (GLDOEXPR NIL NIL T)) (SET (CAR ARG) (EVAL (CAR TMP))))) (PUT (CAR ARG) 'GLISPCONSTANTTYPE (OR (CADDR ARG) (CADR TMP)))))))) % edited: 26-MAY-82 15:30 % Define compile-time constants. (DF GLISPGLOBALS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPGLOBALVAR T) (PUT (CAR ARG) 'GLISPGLOBALVARTYPE (CADR ARG)))))) % GSN 10-FEB-83 11:51 % edited: 7-Jan-81 10:48 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLISPOBJECTS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % GSN 4-MAR-83 13:53 % Test the word ADJ to see if it is a LISP adjective. If so, return % the CONS of the name of the function to test it and the type of % the result. (DE GLLISPADJ (ADJ) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ADJ) '((ATOMIC ATOM ATOM) (NULL NULL NIL) (NIL NULL NIL) (INTEGER FIXP INTEGER) (REAL FLOATP REAL) (BOUND BOUNDP ATOM) (ZERO ZEROP NUMBER) (NUMERIC NUMBERP NUMBER) (NEGATIVE MINUSP NUMBER) (MINUS MINUSP NUMBER)))) (CDR TMP))))) % GSN 4-MAR-83 13:54 % Test to see if ISAWORD is a LISP ISA word. If so, return the CONS of % the name of the function to test for it and the type of the result % if true. (DE GLLISPISA (ISAWORD) (PROG (TMP) (COND ((SETQ TMP (ASSOC (GLUCASE ISAWORD) '((ATOM ATOM ATOM) (LIST LISTP (LISTOF ANYTHING)) (NUMBER NUMBERP NUMBER) (INTEGER FIXP INTEGER) (SYMBOL LITATOM ATOM) (ARRAY ARRAYP ARRAY) (STRING STRINGP STRING) (BIGNUM BIGP BIGNUM) (LITATOM LITATOM ATOM)))) (RETURN (CDR TMP)))))) % edited: 12-NOV-82 10:53 % Compute result types for Lisp functions. (DE GLLISTRESULTTYPEFN (FN ARGTYPES) (PROG (ARG1 ARG2) (SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES))) (COND ((CDR ARGTYPES) (SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES))))) (RETURN (CASEQ FN (CONS (OR (AND (PAIRP ARG2) (COND ((EQ (CAR ARG2) 'LIST) (CONS 'LIST (CONS ARG1 (CDR ARG2)))) ((AND (EQ (CAR ARG2) 'LISTOF) (EQUAL ARG1 (CADR ARG2))) ARG2))) (LIST FN ARGTYPES))) (NCONC (COND ((EQUAL ARG1 ARG2) ARG1) ((AND (PAIRP ARG1) (PAIRP ARG2) (EQ (CAR ARG1) 'LISTOF) (EQ (CAR ARG2) 'LIST) (NULL (CDDR ARG2)) (EQUAL (CADR ARG1) (CADR ARG2))) ARG1) (T (OR ARG1 ARG2)))) (LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE)))) (T (ERROR 0 NIL)))))) % GSN 11-JAN-83 14:05 % Create a function call to retrieve the field IND from a LIST % structure. (DE GLLISTSTRFN (IND DES DESLIST) (PROG (TMP N FNLST) (SETQ N 1) (SETQ FNLST '((CAR *GL*) (CADR *GL*) (CADDR *GL*) (CADDDR *GL*))) (COND ((EQ (CAR DES) 'LISTOBJECT) (SETQ N (ADD1 N)) (SETQ FNLST (CDR FNLST)))) C (pop DES) (COND ((NULL DES) (RETURN NIL)) ((NOT (PAIRP (CAR DES)))) ((SETQ TMP (GLSTRFN IND (CAR DES) DESLIST)) (RETURN (GLSTRVAL TMP (COND (FNLST (COPY (CAR FNLST))) (T (LIST 'CAR (GLGENCODE (LIST 'NTH '*GL* N))))))))) (SETQ N (ADD1 N)) (AND FNLST (SETQ FNLST (CDR FNLST))) (GO C))) % edited: 24-AUG-82 17:36 % Compile code for a FOR loop. (DE GLMAKEFORLOOP (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE) (COND ((NULL COLLECTCODE) (LIST (GLGENCODE (LIST 'MAPC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (COND (LOOPCOND (LIST 'COND (CONS (CAR LOOPCOND) LOOPCONTENTS))) ((NULL (CDR LOOPCONTENTS)) (CAR LOOPCONTENTS)) (T (CONS 'PROGN LOOPCONTENTS))))))) NIL)) (T (LIST (COND (LOOPCOND (GLGENCODE (LIST 'MAPCONC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (LIST 'AND (CAR LOOPCOND) (LIST 'CONS (CAR COLLECTCODE) NIL))))))) ((AND (PAIRP (CAR COLLECTCODE)) (ATOM (CAAR COLLECTCODE)) (CDAR COLLECTCODE) (EQ (CADAR COLLECTCODE) LOOPVAR) (NULL (CDDAR COLLECTCODE))) (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (CAAR COLLECTCODE))))) (T (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR COLLECTCODE))))))) (LIST 'LISTOF (CADR COLLECTCODE)))))) % GSN 1-MAR-83 11:36 % Compile code to create a structure in response to a statement % (A <structure> WITH <field> = <value> ...) (DE GLMAKESTR (TYPE EXPR) (PROG (PAIRLIST STRDES) (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR))) (COND ((NULL (SETQ STRDES (GLGETSTR TYPE))) (GLERROR 'GLMAKESTR (LIST "The type name" TYPE "is not defined.")))) (COND ((EQ (CAR STRDES) 'LISTOF) (RETURN (LIST (CONS 'LIST (MAPCAR EXPR (FUNCTION (LAMBDA (EXPR) (GLDOEXPR NIL CONTEXT T))) )) TYPE)))) (SETQ PAIRLIST (GLGETPAIRS EXPR)) (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE)) TYPE)))) % GSN 3-FEB-83 12:12 % Make a virtual type for a view of the original type. (DE GLMAKEVTYPE (ORIGTYPE VLIST) (PROG (SUPER PL PNAME TMP VTYPE) (SETQ SUPER (CADR VLIST)) (SETQ VLIST (CDDR VLIST)) (COND ((MEMQ (CAR VLIST) '(with With WITH)) (SETQ VLIST (CDR VLIST)))) LP (COND ((NULL VLIST) (GO OUT))) (SETQ PNAME (CAR VLIST)) (SETQ VLIST (CDR VLIST)) (COND ((EQ (CAR VLIST) '=) (SETQ VLIST (CDR VLIST)))) (SETQ TMP NIL) LPB (COND ((OR (NULL VLIST) (EQ (CAR VLIST) '!,) (AND (ATOM (CAR VLIST)) (CDR VLIST) (EQ (CADR VLIST) '=))) (SETQ PL (CONS (LIST PNAME (REVERSIP TMP)) PL)) (COND ((AND VLIST (EQ (CAR VLIST) '!,)) (SETQ VLIST (CDR VLIST)))) (GO LP))) (SETQ TMP (CONS (CAR VLIST) TMP)) (SETQ VLIST (CDR VLIST)) (GO LPB) OUT (SETQ VTYPE (GLMKVTYPE)) (PUT VTYPE 'GLSTRUCTURE (LIST (LIST 'TRANSPARENT ORIGTYPE) 'PROP PL 'SUPERS (LIST SUPER))) (RETURN VTYPE))) % GSN 25-FEB-83 16:08 % Test whether an item of type TNEW could be stored into a slot of % type TINTO. (DE GLMATCH (TNEW TINTO) (PROG (TMP RES) (RETURN (COND ((OR (EQ TNEW TINTO) (NULL TINTO) (EQ TINTO 'ANYTHING) (AND (MEMQ TNEW '(INTEGER REAL NUMBER)) (MEMQ TINTO '(NUMBER ATOM))) (AND (EQ TNEW 'ATOM) (PAIRP TINTO) (EQ (CAR TINTO) 'ATOM))) TNEW) ((AND (SETQ TMP (GLXTRTYPEC TNEW)) (SETQ RES (GLMATCH TMP TINTO))) RES) ((AND (SETQ TMP (GLXTRTYPEC TINTO)) (SETQ RES (GLMATCH TNEW TMP))) RES) (T NIL))))) % GSN 25-FEB-83 16:03 % Test whether two types match as an element type and a list type. The % result is the resulting element type. (DE GLMATCHL (TELEM TLIST) (PROG (TMP RES) (RETURN (COND ((AND (PAIRP TLIST) (EQ (CAR TLIST) 'LISTOF) (GLMATCH TELEM (CADR TLIST))) TELEM) ((AND (SETQ TMP (GLXTRTYPEC TLIST)) (SETQ RES (GLMATCHL TELEM TMP)))) (T NIL))))) % edited: 26-MAY-82 15:33 % Construct the NOT of the argument LHS. (DE GLMINUSFN (LHS) (OR (GLDOMSG LHS 'MINUS NIL) (GLUSERSTROP LHS 'MINUS NIL) (LIST (GLGENCODE (COND ((NUMBERP (CAR LHS)) (MINUS (CAR LHS))) ((EQ (GLXTRTYPE (CADR LHS)) 'INTEGER) (LIST 'IMINUS (CAR LHS))) (T (LIST 'MINUS (CAR LHS))))) (CADR LHS)))) % edited: 11-NOV-82 11:54 % Make a variable name for GLCOMP functions. (DE GLMKATOM (NAME) (PROG (N NEWATOM) LP (PUT NAME 'GLISPATOMNUMBER (SETQ N (ADD1 (OR (GET NAME 'GLISPATOMNUMBER) 0)))) (SETQ NEWATOM (IMPLODE (APPEND (EXPLODE NAME) (EXPLODE N)))) % If an atom with this name has something on its proplist, try again. (COND ((PROP NEWATOM) (GO LP)) (T (RETURN NEWATOM))))) % edited: 27-MAY-82 11:02 % Make a variable name for GLCOMP functions. (DE GLMKLABEL NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L L A B E L) (EXPLODE GLNATOM)))))) % edited: 27-MAY-82 11:04 % Make a variable name for GLCOMP functions. (DE GLMKVAR NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L V A R) (EXPLODE GLNATOM)))))) % edited: 18-NOV-82 11:58 % Make a virtual type name for GLCOMP functions. (DE GLMKVTYPE NIL (GLMKATOM 'GLVIRTUALTYPE)) % GSN 25-JAN-83 16:47 % edited: 2-Jun-81 14:18 % Produce a function to implement the _+ operator. Code is produced to % append the right-hand side to the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLNCONCFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS))) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF) (NOT (EQUAL LHSDES (CADR RHS)))) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'NCONC)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_+ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLNCONCFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_+ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ LHS RHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 23-DEC-82 10:49 % Produce code to test the two sides for inequality. (DE GLNEQUALFN (LHS RHS) (PROG (TMP) (COND ((SETQ TMP (GLDOMSG LHS '~= (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '~= RHS)) (RETURN TMP)) ((OR (GLATOMTYPEP (CADR LHS)) (GLATOMTYPEP (CADR RHS))) (RETURN (LIST (GLGENCODE (LIST 'NEQ (CAR LHS) (CAR RHS))) 'BOOLEAN))) (T (RETURN (LIST (GLGENCODE (LIST 'NOT (CAR (GLEQUALFN LHS RHS)))) 'BOOLEAN)))))) % GSN 7-MAR-83 16:55 % If SOURCE represents a variable name, add the TYPE of SOURCE to the % CONTEXT. (DE GLNOTESOURCETYPE (SOURCE TYPE ADDISATYPE) (PROG (TMP) (RETURN (COND (ADDISATYPE (COND ((ATOM (CAR SOURCE)) (GLADDSTR (CAR SOURCE) NIL TYPE CONTEXT)) ((AND (PAIRP (CAR SOURCE)) (MEMQ (CAAR SOURCE) '(SETQ PROG1)) (ATOM (CADAR SOURCE))) (GLADDSTR (CADAR SOURCE) (COND ((SETQ TMP (GLFINDVARINCTX (CAR SOURCE) CONTEXT)) (CADR TMP))) TYPE CONTEXT)))))))) % edited: 3-MAY-82 14:35 % Construct the NOT of the argument LHS. (DE GLNOTFN (LHS) (OR (GLDOMSG LHS '~ NIL) (GLUSERSTROP LHS '~ NIL) (LIST (GLBUILDNOT (CAR LHS)) 'BOOLEAN))) % GSN 28-JAN-83 09:39 % Add TYPE to the global variable GLTYPESUSED if not already there. (DE GLNOTICETYPE (TYPE) (COND ((NOT (MEMQ TYPE GLTYPESUSED)) (SETQ GLTYPESUSED (CONS TYPE GLTYPESUSED))))) % edited: 23-JUN-82 14:31 % Compute the result type for the function NTH. (DE GLNTHRESULTTYPEFN (FN ARGTYPES) (PROG (TMP) (RETURN (COND ((AND (PAIRP (SETQ TMP (GLXTRTYPE (CAR ARGTYPES)))) (EQ (CAR TMP) 'LISTOF)) (CAR ARGTYPES)) (T NIL))))) % edited: 3-JUN-82 11:02 % See if X occurs in STR, using EQ. (DE GLOCCURS (X STR) (COND ((EQ X STR) T) ((NOT (PAIRP STR)) NIL) (T (OR (GLOCCURS X (CAR STR)) (GLOCCURS X (CDR STR)))))) % GSN 30-JAN-83 15:35 % Check a structure description for legality. (DE GLOKSTR? (STR) (COND ((NULL STR) NIL) ((ATOM STR) T) ((AND (PAIRP STR) (ATOM (CAR STR))) (CASEQ (CAR STR) ((A AN a an An) (COND ((CDDR STR) NIL) ((OR (GLGETSTR (CADR STR)) (GLUNIT? (CADR STR)) (COND (GLCAUTIOUSFLG (PRIN1 "The structure ") (PRIN1 (CADR STR)) (PRIN1 " is not currently defined. Accepted.") (TERPRI) T) (T T)))))) (CONS (AND (CDR STR) (CDDR STR) (NULL (CDDDR STR)) (GLOKSTR? (CADR STR)) (GLOKSTR? (CADDR STR)))) ((LIST OBJECT ATOMOBJECT LISTOBJECT) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION GLOKSTR?)))) (RECORD (COND ((AND (CDR STR) (ATOM (CADR STR))) (pop STR))) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (LISTOF (AND (CDR STR) (NULL (CDDR STR)) (GLOKSTR? (CADR STR)))) ((ALIST PROPLIST) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (ATOM (GLATMSTR? STR)) (TYPEOF T) (T (COND ((AND (CDR STR) (NULL (CDDR STR))) (GLOKSTR? (CADR STR))) ((ASSOC (CAR STR) GLUSERSTRNAMES)) (T NIL))))) (T NIL))) % edited: 30-DEC-81 16:41 % Get the next operand from the input list, EXPR (global) . The % operand may be an atom (possibly containing operators) or a list. (DE GLOPERAND NIL (PROG NIL (COND ((SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) ((NULL EXPR) (RETURN NIL)) ((STRINGP (CAR EXPR)) (RETURN (LIST (pop EXPR) 'STRING))) ((ATOM (CAR EXPR)) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) (T (RETURN (GLPUSHEXPR (pop EXPR) T CONTEXT T)))))) % GSN 4-MAR-83 14:26 % Test if an atom is a GLISP operator (DE GLOPERATOR? (ATM) (MEMQ ATM '(_ := __ + - * / > < >= <= ^ _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __- _+_))) % edited: 26-DEC-82 15:48 % OR operator (DE GLORFN (LHS RHS) (COND ((AND (PAIRP (CADR LHS)) (EQ (CAADR LHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'UNION (CAR LHS) (CAR RHS)) (CADR LHS))) ((GLDOMSG LHS 'OR (LIST RHS))) ((GLUSERSTROP LHS 'OR RHS)) (T (LIST (LIST 'OR (CAR LHS) (CAR RHS)) (COND ((EQUAL (GLXTRTYPE (CADR LHS)) (GLXTRTYPE (CADR RHS))) (CADR LHS)) (T NIL)))))) % GSN 10-FEB-83 16:13 % Remove unwanted system properties from LST for making an output % file. (DE GLOUTPUTFILTER (PROPTYPE LST) (COND ((MEMQ PROPTYPE '(PROP ADJ ISA MSG)) (MAPCAN LST (FUNCTION (LAMBDA (L) (COND ((LISTGET (CDDR L) 'SPECIALIZATION) NIL) (T (LIST (CONS (CAR L) (CONS (CADR L) (MAPCON (CDDR L) (FUNCTION (LAMBDA (PAIR) (COND ((MEMQ (CAR PAIR) '(VTYPE)) NIL) (T (LIST (CAR PAIR) (CADR PAIR)))))) (FUNCTION CDDR))))))))))) (T LST))) % edited: 22-SEP-82 17:16 % Subroutine of GLDOEXPR to parse a GLISP expression containing field % specifications and/or operators. The global variable EXPR is used, % and is modified to reflect the amount of the expression which has % been parsed. (DE GLPARSEXPR NIL (PROG (OPNDS OPERS FIRST LHSP RHSP) % Get the initial part of the expression, i.e., variable or field % specification. L (SETQ OPNDS (CONS (GLOPERAND) OPNDS)) M (COND ((NULL FIRST) (COND ((OR (NULL EXPR) (NOT (ATOM (CAR EXPR)))) (GO B))) (GLSEPINIT (CAR EXPR)) (COND ((GLOPERATOR? (SETQ FIRST (GLSEPNXT))) (pop EXPR) (GO A)) ((MEMQ FIRST '(IS Is is HAS Has has)) (COND ((AND OPERS (GREATERP (GLPREC (CAR OPERS)) 5)) (GLREDUCE) (SETQ FIRST NIL) (GO M)) (T (SETQ OPNDS (CONS (GLPREDICATE (pop OPNDS) CONTEXT T (AND (NOT (UNBOUNDP 'ADDISATYPE)) ADDISATYPE)) OPNDS)) (SETQ FIRST NIL) (GO M)))) (T (GLSEPCLR) (GO B)))) ((GLOPERATOR? FIRST) (GO A)) (T (GLERROR 'GLPARSEXPR (LIST FIRST "appears illegally or cannot be interpreted.")))) % FIRST now contains an operator A % While top operator < top of stack in precedence, reduce. (COND ((NOT (OR (NULL OPERS) (LESSP (SETQ LHSP (GLPREC (CAR OPERS))) (SETQ RHSP (GLPREC FIRST))) (AND (EQN LHSP RHSP) (MEMQ FIRST '(_ ^ :=))))) (GLREDUCE) (GO A))) % Push new operator onto the operator stack. (SETQ OPERS (CONS FIRST OPERS)) (GO L) B (COND (OPERS (GLREDUCE) (GO B))) (RETURN (CAR OPNDS)))) % edited: 30-DEC-82 10:55 % Parse a field specification of the form var:field:field... Var may % be missing, and there may be zero or more fields. The variable % FIRST is used globally; it contains the first atom of the group on % entry, and the next atom on exit. (DE GLPARSFLD (PREV) (PROG (FIELD TMP) (COND ((NULL PREV) (COND ((EQ FIRST '!') (COND ((SETQ TMP (GLSEPNXT)) (SETQ FIRST (GLSEPNXT)) (RETURN (LIST (KWOTE TMP) 'ATOM))) (EXPR (SETQ FIRST NIL) (SETQ TMP (pop EXPR)) (RETURN (LIST (KWOTE TMP) (GLCONSTANTTYPE TMP)))) (T (RETURN NIL)))) ((MEMQ FIRST '(THE The the)) (SETQ TMP (GLTHE NIL)) (SETQ FIRST NIL) (RETURN TMP)) ((NE FIRST ':) (SETQ PREV FIRST) (SETQ FIRST (GLSEPNXT)))))) A (COND ((EQ FIRST ':) (COND ((SETQ FIELD (GLSEPNXT)) (SETQ PREV (GLGETFIELD PREV FIELD CONTEXT)) (SETQ FIRST (GLSEPNXT)) (GO A)))) (T (RETURN (COND ((EQ PREV '*NIL*) (LIST NIL NIL)) (T (GLIDNAME PREV T)))))))) % edited: 20-MAY-82 11:30 % Parse a field specification which may be preceded by a ~. (DE GLPARSNFLD NIL (PROG (TMP UOP) (COND ((OR (EQ FIRST '~) (EQ FIRST '-)) (SETQ UOP FIRST) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (ATOM (CAR EXPR))) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (PAIRP (CAR EXPR))) (SETQ TMP (GLPUSHEXPR (pop EXPR) T CONTEXT T))) (T (RETURN (LIST UOP NIL)))) (RETURN (COND ((EQ UOP '~) (GLNOTFN TMP)) (T (GLMINUSFN TMP))))) (T (RETURN (GLPARSFLD NIL)))))) % edited: 27-MAY-82 10:42 % Form the plural of a given word. (DE GLPLURAL (WORD) (PROG (TMP LST UCASE ENDING) (COND ((SETQ TMP (GET WORD 'PLURAL)) (RETURN TMP))) (SETQ LST (REVERSIP (EXPLODE WORD))) (SETQ UCASE (U-CASEP (CAR LST))) (COND ((AND (MEMQ (CAR LST) '(Y y)) (NOT (MEMQ (CADR LST) '(A a E e O o U u)))) (SETQ LST (CDR LST)) (SETQ ENDING (OR (AND UCASE '(S E I)) '(s e i)))) ((MEMQ (CAR LST) '(S s X x)) (SETQ ENDING (OR (AND UCASE '(S E)) '(s e)))) (T (SETQ ENDING (OR (AND UCASE '(S)) '(s))))) (RETURN (IMPLODE (REVERSIP (APPEND ENDING LST)))))) % edited: 29-DEC-82 12:40 % Produce a function to implement the -_ (pop) operator. Code is % produced to remove one element from the right-hand side and assign % it to the left-hand side. (DE GLPOPFN (LHS RHS) (PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR) (SETQ RHSCODE (CAR RHS)) (SETQ RHSDES (GLXTRTYPE (CADR RHS))) (COND ((AND (PAIRP RHSDES) (EQ (CAR RHSDES) 'LISTOF)) (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL))) ((EQ RHSDES 'BOOLEAN) (SETQ POPCODE (GLPUTFN RHS '(NIL NIL) NIL)) (SETQ GETCODE (GLPUTFN LHS RHS NIL))) ((SETQ TMP (GLDOMSG RHS '-_ (LIST LHS))) (RETURN TMP)) ((AND (SETQ STR (GLGETSTR RHSDES)) (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS) STR)))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP RHS '-_ LHS)) (RETURN TMP)) ((OR (GLATOMTYPEP RHSDES) (AND (NE RHSDES 'ANYTHING) (MEMQ (GLXTRTYPEB RHSDES) GLBASICTYPES))) (RETURN NIL)) (T % If all else fails, assume a list. (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL)))) (RETURN (LIST (LIST 'PROG1 (CAR GETCODE) (CAR POPCODE)) (CADR GETCODE))))) % edited: 30-OCT-82 14:36 % Precedence numbers for operators (DE GLPREC (OP) (PROG (TMP) (COND ((SETQ TMP (ASSOC OP '((_ . 1) (:= . 1) (__ . 1) (_+ . 2) (__+ . 2) (+_ . 2) (_+_ . 2) (_- . 2) (__- . 2) (-_ . 2) (= . 5) (~= . 5) (<> . 5) (AND . 4) (And . 4) (and . 4) (OR . 3) (Or . 3) (or . 3) (/ . 7) (+ . 6) (- . 6) (> . 5) (< . 5) (>= . 5) (<= . 5) (^ . 8)))) (RETURN (CDR TMP))) ((EQ OP '*) (RETURN 7)) (T (RETURN 10))))) % GSN 7-MAR-83 17:13 % Get a predicate specification from the EXPR (referenced globally) % and return code to test the SOURCE for that predicate. VERBFLG is % true if a verb is expected as the top of EXPR. (DE GLPREDICATE (SOURCE CONTEXT VERBFLG ADDISATYPE) (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG) (COND ((NULL VERBFLG) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((NULL SOURCE) (GLERROR 'GLPREDICATE (LIST "The object to be tested was not found. EXPR =" EXPR))) ((MEMQ (CAR EXPR) '(HAS Has has)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NO No no)) (SETQ NOTFLG T) (pop EXPR))) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((MEMQ (CAR EXPR) '(IS Is is ARE Are are)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NOT Not not)) (SETQ NOTFLG T) (pop EXPR))) (COND ((GL-A-AN? (CAR EXPR)) (pop EXPR) (SETQ SETNAME (pop EXPR)) % The condition is to test whether SOURCE IS A SETNAME. (COND ((SETQ NEWPRED (GLADJ SOURCE SETNAME 'ISA))) ((SETQ NEWPRED (GLADJ (LIST (CAR SOURCE) SETNAME) SETNAME 'ISASELF)) (GLNOTESOURCETYPE SOURCE SETNAME ADDISATYPE)) ((GLCLASSP SETNAME) (SETQ NEWPRED (LIST (LIST 'GLCLASSMEMP (CAR SOURCE) (KWOTE SETNAME)) 'BOOLEAN))) ((SETQ TMP (GLLISPISA SETNAME)) (SETQ NEWPRED (LIST (GLGENCODE (LIST (CAR TMP) (CAR SOURCE))) 'BOOLEAN)) (GLNOTESOURCETYPE SOURCE (CADR TMP) ADDISATYPE)) (T (GLERROR 'GLPREDICATE (LIST "IS A adjective" SETNAME "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS 'A SETNAME) 'BOOLEAN))))) (T (SETQ PROPERTY (CAR EXPR)) % The condition to test is whether SOURCE is PROPERTY. (COND ((SETQ NEWPRED (GLADJ SOURCE PROPERTY 'ADJ)) (pop EXPR)) ((SETQ TMP (GLLISPADJ PROPERTY)) (pop EXPR) (SETQ NEWPRED (LIST (GLGENCODE (LIST (CAR TMP) (CAR SOURCE))) 'BOOLEAN)) (GLNOTESOURCETYPE SOURCE (CADR TMP) ADDISATYPE)) (T (GLERROR 'GLPREDICATE (LIST "The adjective" PROPERTY "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (pop EXPR) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS PROPERTY) 'BOOLEAN)))))))) (RETURN (COND (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED)) 'BOOLEAN)) (T NEWPRED))))) % edited: 25-MAY-82 16:09 % Compile an implicit PROGN, that is, a list of items. (DE GLPROGN (EXPR CONTEXT) (PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) A (COND ((NULL EXPR) (RETURN (LIST (REVERSIP RESULT) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY)) (SETQ RESULT (CONS (CAR TMP) RESULT)) (SETQ TYPE (CADR TMP)) (GO A)) (T (GLERROR 'GLPROGN (LIST "Illegal item appears in implicit PROGN. EXPR =" EXPR)))))) % edited: 14-MAR-83 17:12 % Create a function call to retrieve the field IND from a % property-list type structure. FLG is true if a PROPLIST is inside % an ATOM structure. (DE GLPROPSTRFN (IND DES DESLIST FLG) (PROG (DESIND TMP RECNAME N) % Handle a PROPLIST by looking inside each property for IND. (COND ((AND (EQ (SETQ DESIND (pop DES)) 'RECORD) (ATOM (CAR DES))) (SETQ RECNAME (pop DES)))) (SETQ N 0) P (COND ((NULL DES) (RETURN NIL)) ((AND (PAIRP (CAR DES)) (ATOM (CAAR DES)) (CDAR DES) (SETQ TMP (GLSTRFN IND (CAR DES) DESLIST))) (SETQ TMP (GLSTRVAL TMP (CASEQ DESIND (ALIST (LIST 'GLGETASSOC (KWOTE (CAAR DES)) '*GL*)) ((RECORD OBJECT) (COND ((EQ DESIND 'OBJECT) (SETQ N (ADD1 N)))) (LIST 'GetV '*GL* N)) ((PROPLIST ATOMOBJECT) (GLGENCODE (LIST (COND ((OR FLG (EQ DESIND 'ATOMOBJECT)) 'GETPROP) (T 'LISTGET)) '*GL* (KWOTE (CAAR DES)))))))) (RETURN TMP)) (T (pop DES) (SETQ N (ADD1 N)) (GO P))))) % edited: 4-JUN-82 13:37 % Test if the function X is a pure computation, i.e., can be % eliminated if the result is not used. (DE GLPURE (X) (MEMQ X '(CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR CADDDR))) % edited: 25-MAY-82 16:10 % This function serves to call GLDOEXPR with a new expression, % rebinding the global variable EXPR. (DE GLPUSHEXPR (EXPR START CONTEXT VALBUSY) (PROG (GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) (RETURN (GLDOEXPR START CONTEXT VALBUSY)))) % GSN 25-JAN-83 16:48 % edited: 2-Jun-81 14:19 % Produce a function to implement the +_ operator. Code is produced to % push the right-hand side onto the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLPUSHFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE)) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (MEMQ (CAR LHSDES) '(LIST CONS LISTOF))) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'PUSH)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLPUSHFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '+_ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ RHS LHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 22-JAN-83 14:44 % Process a store into a value which is computed by an arithmetic % expression. (DE GLPUTARITH (LHS RHS) (PROG (LHSC OP TMP NEWLHS NEWRHS) (SETQ LHSC (CAR LHS)) (SETQ OP (CAR LHSC)) (COND ((NOT (SETQ TMP (ASSOC OP '((PLUS DIFFERENCE) (MINUS MINUS) (DIFFERENCE PLUS) (TIMES QUOTIENT) (QUOTIENT TIMES) (IPLUS IDIFFERENCE) (IMINUS IMINUS) (IDIFFERENCE IPLUS) (ITIMES IQUOTIENT) (IQUOTIENT ITIMES) (ADD1 SUB1) (SUB1 ADD1) (EXPT SQRT) (SQRT EXPT))))) (RETURN NIL))) (SETQ NEWLHS (CADR LHSC)) (CASEQ OP ((ADD1 SUB1 MINUS IMINUS) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))) ((PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE ITIMES IQUOTIENT) (COND ((NUMBERP (CADDR LHSC)) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADDR LHSC)))) ((NUMBERP (CADR LHSC)) (SETQ NEWLHS (CADDR LHSC)) (CASEQ OP ((DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT) (SETQ NEWRHS (LIST OP (CADR LHSC) (CAR RHS)))) (T (PROGN (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADR LHSC))))))))) (EXPT (COND ((EQUAL (CADDR LHSC) 2) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))))) (SQRT (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) 2)))) (RETURN (AND NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS)) (LIST NEWRHS (CADR RHS)) NIL))))) % GSN 22-JAN-83 14:37 % edited: 2-Jun-81 14:16 % Create code to put the right-hand side datum RHS into the left-hand % side, whose access function and type are given by LHS. (DE GLPUTFN (LHS RHS OPTFLG) (PROG (LHSD LNAME TMP RESULT TMPVAR) (SETQ LHSD (CAR LHS)) (COND ((ATOM LHSD) (RETURN (OR (GLDOMSG LHS '_ (LIST RHS)) (GLUSERSTROP LHS '_ RHS) (AND (NULL (CADR LHS)) (CADR RHS) (GLUSERSTROP (LIST (CAR LHS) (CADR RHS)) '_ RHS)) (GLDOVARSETQ LHSD RHS))))) (SETQ LNAME (CAR LHSD)) (COND ((EQ LNAME 'CAR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (CADR LHSD) (CAR RHS))))))) ((EQ LNAME 'CDR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CDR (LIST 'RPLACD TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CDR (LIST 'RPLACD (CADR LHSD) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((CADR . CDR) (CADDR . CDDR) (CADDDR . CDDDR)))) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (LIST (CDR TMP) (CADR LHSD)))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST (LIST 'CAR TMPVAR) LHSD (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (LIST (CDR TMP) (CADR LHSD)) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((GetV . PutV) (IGetV . IPutV) (GET . PUTPROP) (GETPROP . PUTPROP) (LISTGET . LISTPUT)))) (SETQ RESULT (LIST (CDR TMP) (CADR LHSD) (CADDR LHSD) (CAR RHS)))) ((EQ LNAME 'CXR) (SETQ RESULT (LIST 'CXR (CADR LHSD) (LIST 'RPLACX (CADR LHSD) (CADDR LHSD) (CAR RHS))))) ((EQ LNAME 'GLGETASSOC) (SETQ RESULT (LIST 'PUTASSOC (CADR LHSD) (CAR RHS) (CADDR LHSD)))) ((EQ LNAME 'EVAL) (SETQ RESULT (LIST 'SET (CADR LHSD) (CAR RHS)))) ((EQ LNAME 'fetch) (SETQ RESULT (LIST 'replace (CADR LHSD) 'of (CADDDR LHSD) 'with (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'PUT)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_ RHS)) (RETURN TMP)) ((SETQ TMP (GLPUTARITH LHS RHS)) (RETURN TMP)) (T (RETURN (GLERROR 'GLPUTFN (LIST "Illegal assignment. LHS =" LHS "RHS =" RHS))))) X (RETURN (LIST (GLGENCODE RESULT) (OR (CADR LHS) (CADR RHS)))))) % edited: 27-MAY-82 13:07 % This function appends PUTPROP calls to the list PROGG (global) so % that ATOMNAME has its property list built. (DE GLPUTPROPS (PROPLIS PREVLST) (PROG (TMP TMPCODE) A (COND ((NULL PROPLIS) (RETURN NIL))) (SETQ TMP (pop PROPLIS)) (COND ((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST)) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (KWOTE (CAR TMP)) TMPCODE))))) (GO A))) % edited: 26-JAN-82 10:29 % This function implements the __ operator, which is interpreted as % assignment to the source of a variable (usually self) outside an % open-compiled function. Any other use of __ is illegal. (DE GLPUTUPFN (OP LHS RHS) (PROG (TMP TMPOP) (OR (SETQ TMPOP (ASSOC OP '((__ . _) (__+ . _+) (__- . _-) (_+_ . +_)))) (ERROR 0 (LIST (LIST 'GLPUTUPFN OP) " Illegal operator."))) (COND ((AND (ATOM (CAR LHS)) (NOT (UNBOUNDP 'GLPROGLST)) (SETQ TMP (ASSOC (CAR LHS) GLPROGLST))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADR TMP) (CADR LHS)) RHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'PROG1) (ATOM (CADAR LHS))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADAR LHS) (CADR LHS)) RHS))) (T (RETURN (GLERROR 'GLPUTUPFN (LIST "A self-assignment __ operator is used improperly. LHS =" LHS))))))) % edited: 30-OCT-82 14:38 % Reduce the operator on OPERS and the operands on OPNDS % (in GLPARSEXPR) and put the result back on OPNDS (DE GLREDUCE NIL (PROG (RHS OPER) (SETQ RHS (pop OPNDS)) (SETQ OPNDS (CONS (COND ((MEMQ (SETQ OPER (pop OPERS)) '(_ := _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __ _+_ __-)) (GLREDUCEOP OPER (pop OPNDS) RHS)) ((MEMQ OPER '(+ - * / > < >= <= ^)) (GLREDUCEARITH OPER (pop OPNDS) RHS)) ((EQ OPER 'MINUS) (GLMINUSFN RHS)) ((EQ OPER '~) (GLNOTFN RHS)) (T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS)) (CAR RHS))) NIL))) OPNDS)))) % GSN 25-FEB-83 16:32 % edited: 14-Aug-81 12:38 % Reduce an arithmetic operator in an expression. (DE GLREDUCEARITH (OP LHS RHS) (PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP) (SETQ OPLIST '((+ . PLUS) (- . DIFFERENCE) (* . TIMES) (/ . QUOTIENT) (> . GREATERP) (< . LESSP) (>= . GEQ) (<= . LEQ) (^ . EXPT))) (SETQ IOPLIST '((+ . IPLUS) (- . IDIFFERENCE) (* . ITIMES) (/ . IQUOTIENT) (> . IGREATERP) (< . ILESSP) (>= . IGEQ) (<= . ILEQ))) (SETQ PREDLIST '(GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)) (SETQ NUMBERTYPES '(INTEGER REAL NUMBER)) (SETQ LHSTP (GLXTRTYPE (CADR LHS))) (SETQ RHSTP (GLXTRTYPE (CADR RHS))) (COND ((OR (AND (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER) (SETQ TMP (ASSOC OP IOPLIST))) (AND (MEMQ LHSTP NUMBERTYPES) (MEMQ RHSTP NUMBERTYPES) (SETQ TMP (ASSOC OP OPLIST)))) (RETURN (LIST (COND ((AND (NUMBERP (CAR LHS)) (NUMBERP (CAR RHS))) (EVAL (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))))) (T (GLGENCODE (COND ((AND (EQ (CDR TMP) 'IPLUS) (EQN (CAR RHS) 1)) (LIST 'ADD1 (CAR LHS))) ((AND (EQ (CDR TMP) 'IDIFFERENCE) (EQN (CAR RHS) 1)) (LIST 'SUB1 (CAR LHS))) (T (LIST (CDR TMP) (CAR LHS) (CAR RHS))))))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T LHSTP)))))) (COND ((EQ LHSTP 'STRING) (COND ((NE RHSTP 'STRING) (RETURN (GLERROR 'GLREDUCEARITH (LIST "operation on string and non-string")))) ((SETQ TMP (ASSOC OP '((+ CONCAT STRING) (> GLSTRGREATERP BOOLEAN) (>= GLSTRGEP BOOLEAN) (< GLSTRLESSP BOOLEAN) (<= ALPHORDER BOOLEAN)))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADDR TMP)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for strings."))))) ) ((EQ LHSTP 'BOOLEAN) (COND ((NE RHSTP 'BOOLEAN) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operation on Boolean and non-Boolean")))) ((MEMQ OP '(+ * -)) (RETURN (LIST (GLGENCODE (CASEQ OP (+ (LIST 'OR (CAR LHS) (CAR RHS))) (* (LIST 'AND (CAR LHS) (CAR RHS))) (- (LIST 'AND (CAR LHS) (LIST 'NOT (CAR RHS)))))) 'BOOLEAN))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for Booleans."))))) ) ((AND (PAIRP LHSTP) (EQ (CAR LHSTP) 'LISTOF)) (COND ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF)) (COND ((NOT (EQUAL (CADR LHSTP) (CADR RHSTP))) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operations on lists of different types" (CADR LHSTP) (CADR RHSTP)))))) (COND ((SETQ TMP (ASSOC OP '((+ UNION) (- LDIFFERENCE) (* INTERSECTION) ))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation" OP "on lists.")))))) ((AND (GLMATCH RHSTP (CADR LHSTP)) (MEMQ OP '(+ - >=))) (RETURN (LIST (GLGENCODE (LIST (COND ((EQ OP '+) 'CONS) ((EQ OP '-) 'REMOVE) ((EQ OP '>=) (COND ((GLATOMTYPEP RHSTP) 'MEMB) (T 'MEMBER)))) (CAR RHS) (CAR LHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation on list.")))))) ((AND (MEMQ OP '(+ <=)) (GLMATCHL LHSTP RHSTP)) (RETURN (COND ((EQ OP '+) (LIST (GLGENCODE (LIST 'CONS (CAR LHS) (CAR RHS))) (CADR RHS))) ((EQ OP '<=) (LIST (GLGENCODE (LIST (COND ((GLATOMTYPEP LHSTP) 'MEMB) (T 'MEMBER)) (CAR LHS) (CAR RHS))) 'BOOLEAN))))) ((AND (MEMQ OP '(+ - >=)) (SETQ TMP (GLMATCHL LHSTP RHSTP))) (RETURN (GLREDUCEARITH (LIST (CAR LHS) (LIST 'LISTOF TMP)) OP (LIST (CAR RHS) TMP)))) ((SETQ TMP (GLDOMSG LHS OP (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS OP RHS)) (RETURN TMP)) ((SETQ TMP (GLXTRTYPEC LHSTP)) (SETQ TMP (GLREDUCEARITH OP (LIST (CAR LHS) TMP) (LIST (CAR RHS) (OR (GLXTRTYPEC RHSTP) RHSTP)))) (RETURN (LIST (CAR TMP) LHSTP))) ((SETQ TMP (ASSOC OP OPLIST)) (AND LHSTP RHSTP (GLERROR 'GLREDUCEARITH (LIST "Warning: Arithmetic operation on non-numeric arguments of types:" LHSTP RHSTP))) (RETURN (LIST (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T 'NUMBER))))) (T (ERROR 0 (LIST 'GLREDUCEARITH OP LHS RHS)))))) % edited: 29-DEC-82 12:20 % Reduce the operator OP with operands LHS and RHS. (DE GLREDUCEOP (OP LHS RHS) (PROG (TMP RESULT) (COND ((MEMQ OP '(_ :=)) (RETURN (GLPUTFN LHS RHS NIL))) ((SETQ TMP (ASSOC OP '((_+ . GLNCONCFN) (+_ . GLPUSHFN) (_- . GLREMOVEFN) (-_ . GLPOPFN) (= . GLEQUALFN) (~= . GLNEQUALFN) (<> . GLNEQUALFN) (AND . GLANDFN) (And . GLANDFN) (and . GLANDFN) (OR . GLORFN) (Or . GLORFN) (or . GLORFN)))) (COND ((SETQ RESULT (APPLY (CDR TMP) (LIST LHS RHS))) (RETURN RESULT)) (T (GLERROR 'GLREDUCEOP (LIST "The operator" OP "could not be interpreted for arguments" LHS "and" RHS))))) ((MEMQ OP '(__ __+ __- _+_)) (RETURN (GLPUTUPFN OP LHS RHS))) (T (ERROR 0 (LIST 'GLREDUCEOP OP LHS RHS)))))) % GSN 25-JAN-83 16:50 % edited: 2-Jun-81 14:20 % Produce a function to implement the _- operator. Code is produced to % remove the right-hand side from the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLREMOVEFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'SUB1 LHSCODE))) (T (SETQ NCCODE (LIST 'IDIFFERENCE LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'DIFFERENCE LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'AND LHSCODE (LIST 'NOT (CAR RHS))))) ((OR (NULL LHSDES) (AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF))) (SETQ NCCODE (LIST 'REMOVE (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'REMOVE)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_- (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '- (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLREMOVEFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_- RHS)) (RETURN TMP)) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 26-JAN-83 13:41 % Get GLOBAL and RESULT declarations for the GLISP compiler. The % property GLRESULTTYPE is the RESULT declaration, if specified; % GLGLOBALS is a list of global variables referenced and their % types. (DE GLRESGLOBAL NIL (COND ((PAIRP (CAR GLEXPR)) (COND ((MEMQ (CAAR GLEXPR) '(RESULT Result result)) (COND ((AND (GLOKSTR? (CADAR GLEXPR)) (NULL (CDDAR GLEXPR))) (PUT GLAMBDAFN 'GLRESULTTYPE (SETQ RESULTTYPE (GLSUBSTTYPE (GLEVALSTR (CADAR GLEXPR) GLTOPCTX) GLTYPESUBS))) (pop GLEXPR)) (T (GLERROR 'GLCOMP (LIST "Bad RESULT structure declaration:" (CAR GLEXPR))) (pop GLEXPR)))) ((MEMQ (CAAR GLEXPR) '(GLOBAL Global global)) (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR) '(NIL NIL) GLTOPCTX NIL NIL)) (PUT GLAMBDAFN 'GLGLOBALS GLGLOBALVARS) (pop GLEXPR)))))) % edited: 26-MAY-82 16:14 % Get the result type for a function which has a GLAMBDA definition. % ATM is the function name. (DE GLRESULTTYPE (ATM ARGTYPES) (PROG (TYPE FNDEF STR TMP) % See if this function has a known result type. (COND ((SETQ TYPE (GET ATM 'GLRESULTTYPE)) (RETURN TYPE))) % If there exists a function to compute the result type, let it do so. (COND ((SETQ TMP (GET ATM 'GLRESULTTYPEFN)) (RETURN (APPLY TMP (LIST ATM ARGTYPES)))) ((SETQ TMP (GLANYCARCDR? ATM)) (RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES))))) (SETQ FNDEF (GLGETDB ATM)) (COND ((OR (NOT (PAIRP FNDEF)) (NOT (MEMQ (CAR FNDEF) '(LAMBDA GLAMBDA)))) (RETURN NIL))) (SETQ FNDEF (CDDR FNDEF)) A (COND ((OR (NULL FNDEF) (NOT (PAIRP (CAR FNDEF)))) (RETURN NIL)) ((OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR FNDEF) '*)) (MEMQ (CAAR FNDEF) '(GLOBAL Global global))) (pop FNDEF) (GO A)) ((AND (MEMQ (CAAR FNDEF) '(RESULT Result result)) (GLOKSTR? (SETQ STR (CADAR FNDEF)))) (RETURN STR)) (T (RETURN NIL))))) % GSN 28-JAN-83 09:55 (DE GLSAVEFNTYPES (GLAMBDAFN TYPELST) (PROG (Y) (MAPC TYPELST (FUNCTION (LAMBDA (X) (COND ((NOT (MEMQ GLAMBDAFN (SETQ Y (GET X 'GLFNSUSEDIN)))) (PUT X 'GLFNSUSEDIN (CONS GLAMBDAFN Y))))))))) % GSN 16-FEB-83 11:30 % Send a runtime message to OBJ. (DE GLSENDB (OBJ CLASS SELECTOR PROPTYPE ARGS) (PROG (RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL) (COND (CLASS) ((SETQ CLASS (GLCLASS OBJ))) (T (ERROR 0 (LIST "Object" OBJ "has no Class.")))) (SETQ ARGLIST (CONS OBJ ARGS)) (COND ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST PROPTYPE)) 'GLSENDFAILURE) (RETURN RESULT)) ((AND (EQ SELECTOR 'CLASS) (MEMQ PROPTYPE '(PROP MSG))) (RETURN CLASS)) ((NE PROPTYPE 'MSG) (GO ERR)) ((AND ARGS (NULL (CDR ARGS)) (EQ (GLNTHCHAR SELECTOR -1) ':) (SETQ SEL (SUBATOM SELECTOR 1 -2)) (SETQ FNCODE (OR (GLCOMPPROP CLASS SEL 'STR) (GLCOMPPROP CLASS SEL 'PROP))) (SETQ PUTCODE (GLPUTFN (LIST (SUBST '*GL* (CAADR FNCODE) (CADDR FNCODE)) NIL) (LIST '*GLVAL* NIL) NIL))) (SETQ *GLVAL* (CAR ARGS)) (SETQ *GL* OBJ) (RETURN (EVAL (CAR PUTCODE)))) (ARGS (GO ERR)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'STR)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'PROP)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ADJ)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ISA)) 'GLSENDFAILURE) (RETURN RESULT))) ERR (ERROR 0 (LIST "Message" SELECTOR "to object" OBJ "of class" CLASS "not understood.")))) % edited: 30-DEC-81 16:34 (DE GLSEPCLR NIL (SETQ GLSEPPTR 0)) % GSN 9-FEB-83 17:24 % edited: 30-Dec-80 10:05 % Initialize the scanning function which breaks apart atoms containing % embedded operators. (DE GLSEPINIT (ATM) (COND ((AND (ATOM ATM) (NOT (STRINGP ATM))) (SETQ GLSEPATOM ATM) (SETQ GLSEPPTR 1)) (T (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0)))) % edited: 30-OCT-82 14:40 % Get the next sub-atom from the atom which was previously given to % GLSEPINIT. Sub-atoms are defined by splitting the given atom at % the occurrence of operators. Operators which are defined are : _ % _+ __ +_ _- -_ ' = ~= <> > < (DE GLSEPNXT NIL (PROG (END TMP) (COND ((ZEROP GLSEPPTR) (RETURN NIL)) ((NULL GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN '*NIL*)) ((NUMBERP GLSEPATOM) (SETQ TMP GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN TMP))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR)) A (COND ((NULL END) (RETURN (PROG1 (COND ((EQN GLSEPPTR 1) GLSEPATOM) ((GREATERP GLSEPPTR (FlatSize2 GLSEPATOM)) NIL) (T (GLSUBATOM GLSEPATOM GLSEPPTR (FlatSize2 GLSEPATOM)))) (SETQ GLSEPPTR 0)))) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (PLUS GLSEPPTR 2))) '(__+ __- _+_)) (SETQ GLSEPPTR (PLUS GLSEPPTR 3)) (RETURN TMP)) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (ADD1 GLSEPPTR))) '(:= __ _+ +_ _- -_ ~= <> >= <=)) (SETQ GLSEPPTR (PLUS GLSEPPTR 2)) (RETURN TMP)) ((AND (NOT GLSEPMINUS) (EQ (GLNTHCHAR GLSEPATOM END) '-) (NOT (EQ (GLNTHCHAR GLSEPATOM (ADD1 END)) '_))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END))) (GO A)) ((GREATERP END GLSEPPTR) (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR (SUB1 END)) (SETQ GLSEPPTR END)))) (T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR) (SETQ GLSEPPTR (ADD1 GLSEPPTR)))))))) % edited: 26-MAY-82 16:17 % Skip comments in GLEXPR. (DE GLSKIPCOMMENTS NIL (PROG NIL A (COND ((AND (PAIRP GLEXPR) (PAIRP (CAR GLEXPR)) (OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR GLEXPR) '*)) (EQ (CAAR GLEXPR) 'COMMENT))) (pop GLEXPR) (GO A))))) % GSN 17-FEB-83 12:36 % This function is called when the structure STR has been changed. It % uncompiles code which depends on STR. (DE GLSTRCHANGED (STR) (PROG (FNS) (COND ((NOT (GET STR 'GLSTRUCTURE)) (RETURN NIL)) ((GET STR 'GLPROPFNS) (PUT STR 'GLPROPFNS NIL))) (SETQ FNS (GET STR 'GLFNSUSEDIN)) (PUT STR 'GLFNSUSEDIN NIL) (MAPC FNS (FUNCTION GLUNCOMPILE)))) % GSN 28-JAN-83 10:19 % Create a function call to retrieve the field IND from a structure % described by the structure description DES. The value is NIL if % failure, (NIL DESCR) if DES equals IND, or (FNSTR DESCR) if IND % can be gotten from within DES. In the latter case, FNSTR is a % function to get the IND from the atom *GL*. GLSTRFN only does % retrieval from a structure, and does not get properties of an % object unless they are part of a TRANSPARENT substructure. DESLIST % is a list of structure descriptions which have been tried already; % this prevents a compiler loop in case the user specifies circular % TRANSPARENT structures. (DE GLSTRFN (IND DES DESLIST) (PROG (DESIND TMP STR UNITREC) % If this structure has already been tried, quit to avoid a loop. (COND ((MEMQ DES DESLIST) (RETURN NIL))) (SETQ DESLIST (CONS DES DESLIST)) (COND ((OR (NULL DES) (NULL IND)) (RETURN NIL)) ((OR (ATOM DES) (AND (PAIRP DES) (ATOM (CADR DES)) (GL-A-AN? (CAR DES)) (SETQ DES (CADR DES)))) (RETURN (COND ((SETQ STR (GLGETSTR DES)) (GLNOTICETYPE DES) (GLSTRFN IND STR DESLIST)) ((SETQ UNITREC (GLUNIT? DES)) (GLGETFROMUNIT UNITREC IND DES)) ((EQ IND DES) (LIST NIL (CADR DES))) (T NIL)))) ((NOT (PAIRP DES)) (GLERROR 'GLSTRFN (LIST "Bad structure specification" DES)))) (SETQ DESIND (CAR DES)) (COND ((OR (EQ IND DES) (EQ DESIND IND)) (RETURN (LIST NIL (CADR DES))))) (RETURN (CASEQ DESIND (CONS (OR (GLSTRVALB IND (CADR DES) '(CAR *GL*)) (GLSTRVALB IND (CADDR DES) '(CDR *GL*)))) ((LIST LISTOBJECT) (GLLISTSTRFN IND DES DESLIST)) ((PROPLIST ALIST RECORD ATOMOBJECT OBJECT) (GLPROPSTRFN IND DES DESLIST NIL)) (ATOM (GLATOMSTRFN IND DES DESLIST)) (TRANSPARENT (GLSTRFN IND (CADR DES) DESLIST)) (T (COND ((AND (SETQ TMP (ASSOC DESIND GLUSERSTRNAMES)) (CADR TMP)) (APPLY (CADR TMP) (LIST IND DES DESLIST))) ((OR (NULL (CDR DES)) (ATOM (CADR DES)) (AND (PAIRP (CADR DES)) (GL-A-AN? (CAADR DES)))) NIL) (T (GLSTRFN IND (CADR DES) DESLIST)))))))) % GSN 16-MAR-83 10:49 % If STR is a structured object, i.e., either a declared GLISP % structure or a Class of Units, get the property PROP from the % GLISP class of properties GLPROP. (DE GLSTRPROP (STR GLPROP PROP ARGS) (PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS) (OR (ATOM (SETQ STRB (GLXTRTYPE STR))) (RETURN NIL)) (COND ((SETQ GLPROPS (GET STRB 'GLSTRUCTURE)) (GLNOTICETYPE STRB) (COND ((AND (SETQ PROPL (LISTGET (CDR GLPROPS) GLPROP)) (SETQ TMP (GLSTRPROPB PROP PROPL ARGS))) (RETURN TMP))))) (SETQ SUPERS (AND GLPROPS (LISTGET (CDR GLPROPS) 'SUPERS))) LP (COND (SUPERS (COND ((SETQ TMP (GLSTRPROP (CAR SUPERS) GLPROP PROP ARGS)) (RETURN TMP)) (T (SETQ SUPERS (CDR SUPERS)) (GO LP)))) ((AND (SETQ UNITREC (GLUNIT? STRB)) (SETQ TMP (APPLY (CADDDR UNITREC) (LIST STRB GLPROP PROP)))) (RETURN TMP))))) % GSN 10-FEB-83 13:14 % See if the property PROP can be found within the list of properties % PROPL. If ARGS is specified and ARGTYPES are specified for a % property entry, ARGS are required to match ARGTYPES. (DE GLSTRPROPB (PROP PROPL ARGS) (PROG (PROPENT ARGTYPES LARGS) LP (COND ((NULL PROPL) (RETURN NIL))) (SETQ PROPENT (CAR PROPL)) (SETQ PROPL (CDR PROPL)) (COND ((NE (CAR PROPENT) PROP) (GO LP))) (OR (AND ARGS (SETQ ARGTYPES (LISTGET (CDDR PROPENT) 'ARGTYPES))) (RETURN PROPENT)) (SETQ LARGS ARGS) LPB (COND ((AND (NULL LARGS) (NULL ARGTYPES)) (RETURN PROPENT)) ((OR (NULL LARGS) (NULL ARGTYPES)) (GO LP)) ((GLTYPEMATCH (CADAR LARGS) (CAR ARGTYPES)) (SETQ LARGS (CDR LARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LPB)) (T (GO LP))))) % edited: 11-JAN-82 14:58 % GLSTRVAL is a subroutine of GLSTRFN. Given an old partial retrieval % function, in which the item from which the retrieval is made is % specified by *GL*, and a new function to compute *GL*, a composite % function is made. (DE GLSTRVAL (OLDFN NEW) (PROG NIL (COND ((CAR OLDFN) (RPLACA OLDFN (SUBST NEW '*GL* (CAR OLDFN)))) (T (RPLACA OLDFN NEW))) (RETURN OLDFN))) % edited: 13-Aug-81 16:13 % If the indicator IND can be found within the description DES, make a % composite retrieval function using a copy of the function pattern % NEW. (DE GLSTRVALB (IND DES NEW) (PROG (TMP) (COND ((SETQ TMP (GLSTRFN IND DES DESLIST)) (RETURN (GLSTRVAL TMP (COPY NEW)))) (T (RETURN NIL))))) % edited: 30-DEC-81 16:35 (DE GLSUBATOM (X Y Z) (OR (SUBATOM X Y Z) '*NIL*)) % GSN 22-JAN-83 16:27 % Same as SUBLIS, but allows first elements in PAIRS to be non-atomic. (DE GLSUBLIS (PAIRS EXPR) (PROG (TMP) (RETURN (COND ((SETQ TMP (ASSOC EXPR PAIRS)) (CDR TMP)) ((NOT (PAIRP EXPR)) EXPR) (T (CONS (GLSUBLIS PAIRS (CAR EXPR)) (GLSUBLIS PAIRS (CDR EXPR)))))))) % edited: 30-AUG-82 10:29 % Make subtype substitutions within TYPE according to GLTYPESUBS. (DE GLSUBSTTYPE (TYPE SUBS) (SUBLIS SUBS TYPE)) % edited: 11-NOV-82 14:02 % Get the list of superclasses for CLASS. (DE GLSUPERS (CLASS) (PROG (TMP) (RETURN (AND (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (LISTGET (CDR TMP) 'SUPERS))))) % GSN 16-FEB-83 11:56 % edited: 17-Apr-81 14:23 % EXPR begins with THE. Parse the expression and return code. (DE GLTHE (PLURALFLG) (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND TMP) % Now trace the path specification. (GLTHESPECS) (SETQ QUALFLG (AND EXPR (MEMQ (CAR EXPR) '(with With WITH who Who WHO which Which WHICH that That THAT))) ) B (COND ((NULL SPECS) (COND ((MEMQ (CAR EXPR) '(IS Is is HAS Has has ARE Are are)) (RETURN (GLPREDICATE SOURCE CONTEXT T NIL))) (QUALFLG (GO C)) (T (RETURN SOURCE)))) ((AND QUALFLG (NOT PLURALFLG) (NULL (CDR SPECS))) % If this is a definite reference to a qualified entity, make the name % of the entity plural. (SETQ NAME (CAR SPECS)) (RPLACA SPECS (GLPLURAL (CAR SPECS))))) % Try to find the next name on the list of SPECS from SOURCE. (COND ((NULL SOURCE) (OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS)) NIL)) (RETURN (GLERROR 'GLTHE (LIST "The definite reference to" NAME "could not be found."))))) (SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS) CONTEXT)))) (GO B) C (COND ((ATOM (SETQ DTYPE (GLXTRTYPE (CADR SOURCE)))) (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE))))) (COND ((OR (NOT (PAIRP DTYPE)) (NE (CAR DTYPE) 'LISTOF)) (GLERROR 'GLTHE (LIST "The group name" NAME "has type" DTYPE "which is not a legal group type.")))) (SETQ NEWCONTEXT (CONS NIL CONTEXT)) (GLADDSTR (SETQ LOOPVAR (GLMKVAR)) NAME (CADR DTYPE) NEWCONTEXT) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT (MEMQ (pop EXPR) '(who Who WHO which Which WHICH that That THAT)) NIL)) (SETQ TMP (GLGENCODE (LIST (COND (PLURALFLG 'SUBSET) (T 'SOME)) (CAR SOURCE) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR LOOPCOND)))))) (RETURN (COND (PLURALFLG (LIST TMP (CADR SOURCE))) (T (LIST (LIST 'CAR TMP) (CADR DTYPE))))))) % edited: 20-MAY-82 17:19 % EXPR begins with THE. Parse the expression and return code in SOURCE % and path names in SPECS. (DE GLTHESPECS NIL (PROG NIL A (COND ((NULL EXPR) (RETURN NIL)) ((MEMQ (CAR EXPR) '(THE The the)) (pop EXPR) (COND ((NULL EXPR) (RETURN (GLERROR 'GLTHE (LIST "Nothing following THE"))))))) (COND ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (GLSEPNXT) (CAR EXPR)) (SETQ SPECS (CONS (pop EXPR) SPECS))) (T (GLSEPCLR) (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL)))) (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL))) % SPECS contains a path specification. See if there is any more. (COND ((MEMQ (CAR EXPR) '(OF Of of)) (pop EXPR) (GO A))))) % edited: 14-DEC-81 10:51 % Return a list of all transparent types defined for STR (DE GLTRANSPARENTTYPES (STR) (PROG (TTLIST) (COND ((ATOM STR) (SETQ STR (GLGETSTR STR)))) (GLTRANSPB STR) (RETURN (REVERSIP TTLIST)))) % edited: 13-NOV-81 15:37 % Look for TRANSPARENT substructures for GLTRANSPARENTTYPES. (DE GLTRANSPB (STR) (COND ((NOT (PAIRP STR))) ((EQ (CAR STR) 'TRANSPARENT) (SETQ TTLIST (CONS STR TTLIST))) ((MEMQ (CAR STR) '(LISTOF ALIST PROPLIST))) (T (MAPC (CDR STR) (FUNCTION GLTRANSPB))))) % edited: 4-JUN-82 11:18 % Translate places where a PROG variable is initialized to a value as % allowed by Interlisp. This is done by adding a SETQ to set the % value of each PROG variable which is initialized. In some cases, a % change of variable name is required to preserve the same % semantics. (DE GLTRANSPROG (X) (PROG (TMP ARGVALS SETVARS) (MAP (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP (CAR Y)) % If possible, use the same variable; otherwise, make a new one. (SETQ TMP (COND ((OR (SOME (CADR X) (FUNCTION (LAMBDA (Z) (AND (PAIRP Z) (GLOCCURS (CAR Z) (CADAR Y)))))) (SOME ARGVALS (FUNCTION (LAMBDA (Z) (GLOCCURS (CAAR Y) Z))))) (GLMKVAR)) (T (CAAR Y)))) (SETQ SETVARS (ACONC SETVARS (LIST 'SETQ TMP (CADAR Y)))) (SUBSTIP TMP (CAAR Y) (CDDR X)) (SETQ ARGVALS (CONS (CADAR Y) ARGVALS)) (RPLACA Y TMP)))))) (COND (SETVARS (RPLACD (CDR X) (NCONC SETVARS (CDDR X))))) (RETURN X))) % GSN 10-FEB-83 13:31 % See if the type SUBTYPE matches the type TYPE, either directly or % because TYPE is a SUPER of SUBTYPE. (DE GLTYPEMATCH (SUBTYPE TYPE) (PROG NIL (SETQ SUBTYPE (GLXTRTYPE SUBTYPE)) (RETURN (OR (NULL SUBTYPE) (NULL TYPE) (EQ TYPE 'ANYTHING) (EQUAL SUBTYPE TYPE) (SOME (GLSUPERS SUBTYPE) (FUNCTION (LAMBDA (Y) (GLTYPEMATCH Y TYPE)))))))) % GSN 3-FEB-83 14:41 % Remove the GLISP-compiled definition and properties of GLAMBDAFN (DE GLUNCOMPILE (GLAMBDAFN) (PROG (SPECS SPECLST STR LST TMP) (OR (GET GLAMBDAFN 'GLCOMPILED) (SETQ SPECS (GET GLAMBDAFN 'GLSPECIALIZATION)) (RETURN NIL)) (COND ((NOT GLQUIETFLG) (PRIN1 "uncompiling ") (PRIN1 GLAMBDAFN) (TERPRI))) (PUT GLAMBDAFN 'GLCOMPILED NIL) (PUT GLAMBDAFN 'GLRESULTTYPE NIL) (GLUNSAVEDEF GLAMBDAFN) (MAPC (GET GLAMBDAFN 'GLTYPESUSED) (FUNCTION (LAMBDA (Y) (PUT Y 'GLFNSUSEDIN (DELETIP GLAMBDAFN (GET Y 'GLFNSUSEDIN)))))) (PUT GLAMBDAFN 'GLTYPESUSED NIL) (OR SPECS (RETURN NIL)) % Uncompile a specialization of a generic function. % Remove the function definition so it will be garbage collected. (PUTDDD GLAMBDAFN NIL) A (COND ((NULL SPECS) (RETURN NIL))) (SETQ SPECLST (pop SPECS)) (PUT (CAR SPECLST) 'GLINSTANCEFNS (DELETIP GLAMBDAFN (GET (CAR SPECLST) 'GLINSTANCEFNS))) % Remove the specialization entry in the datatype where it was % created. (OR (SETQ STR (GET (CADR SPECLST) 'GLSTRUCTURE)) (GO A)) (SETQ LST (CDR STR)) LP (COND ((NULL LST) (GO A)) ((EQ (CAR LST) (CADDR SPECLST)) (COND ((AND (SETQ TMP (ASSOC (CADDDR SPECLST) (CADR LST))) (EQ (CADR TMP) GLAMBDAFN)) (RPLACA (CDR LST) (DELETIP TMP (CADR LST))))) (GO A)) (T (SETQ LST (CDDR LST)) (GO LP))))) % edited: 27-MAY-82 13:08 % GLUNITOP calls a function to generate code for an operation on a % unit in a units package. UNITREC is the unit record for the units % package, LHS and RHS the code for the left-hand side and % right-hand side of the operation % (in general, the (QUOTE GET') code for each side) , and OP is the % operation to be performed. (DE GLUNITOP (LHS RHS OP) (PROG (TMP LST UNITREC) % (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (RETURN NIL)) ((NOT (MEMQ (CAAR LHS) (CADAR LST))) (SETQ LST (CDR LST)) (GO A))) (SETQ UNITREC (CAR LST)) (COND ((SETQ TMP (ASSOC OP (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST LHS RHS))))) (RETURN NIL))) % edited: 27-MAY-82 13:08 % GLUNIT? tests a given structure to see if it is a unit of one of the % unit packages on GLUNITPKGS. If so, the value is the unit package % record for the unit package which matched. (DE GLUNIT? (STR) (PROG (UPS) (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (RETURN NIL)) ((APPLY (CAAR UPS) (LIST STR)) (RETURN (CAR UPS)))) (SETQ UPS (CDR UPS)) (GO LP))) % GSN 28-JAN-83 11:15 % Remove the GLISP-compiled definition of GLAMBDAFN (DE GLUNSAVEDEF (GLAMBDAFN) (GLPUTHOOK GLAMBDAFN)) % GSN 27-JAN-83 13:58 % Unwrap an expression X by removing extra stuff inserted during % compilation. (DE GLUNWRAP (X BUSY) (COND ((NOT (PAIRP X)) X) ((NOT (ATOM (CAR X))) (ERROR 0 (LIST 'GLUNWRAP X))) ((CASEQ (CAR X) ('GO X) ((PROG2 PROGN) (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN X BUSY NIL) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (PROG1 (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (EQ Y (CDR X)))))))) (COND (BUSY (GLEXPANDPROGN (CDR X) BUSY NIL)) (T (RPLACA X 'PROGN) (GLEXPANDPROGN X BUSY NIL))) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (FUNCTION (RPLACA (CDR X) (GLUNWRAP (CADR X) BUSY)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) X) ((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY) (GLUNWRAPMAP X BUSY)) (LAMBDA (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CDR X) BUSY NIL) X) (PROG (GLUNWRAPPROG X BUSY)) (COND (GLUNWRAPCOND X BUSY)) ((SELECTQ CASEQ) (GLUNWRAPSELECTQ X BUSY)) ((UNION INTERSECTION LDIFFERENCE) (GLUNWRAPINTERSECT X)) (T (COND ((AND (EQ (CAR X) '*) (EQ GLLISPDIALECT 'INTERLISP)) X) ((AND (NOT BUSY) (CDR X) (NULL (CDDR X)) (GLPURE (CAR X))) (GLUNWRAP (CADR X) NIL)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (COND ((AND (CDR X) (NULL (CDDR X)) (PAIRP (CADR X)) (GLCARCDR? (CAR X)) (GLCARCDR? (CAADR X)) (LESSP (PLUS (FlatSize2 (CAR X)) (FlatSize2 (CAADR X))) 9)) (RPLACA X (IMPLODE (CONS 'C (REVERSIP (CONS 'R (NCONC (GLANYCARCDR? (CAADR X)) (GLANYCARCDR? (CAR X)))))))) (RPLACA (CDR X) (CADADR X)) (GLUNWRAP X BUSY)) ((AND (GET (CAR X) 'GLEVALWHENCONST) (EVERY (CDR X) (FUNCTION GLCONST?)) (OR (NOT (GET (CAR X) 'GLARGSNUMBERP)) (EVERY (CDR X) (FUNCTION NUMBERP)))) (EVAL X)) ((MEMQ (CAR X) '(AND OR)) (GLUNWRAPLOG X)) (T X))))))))) % GSN 27-JAN-83 13:57 % Unwrap a COND expression. (DE GLUNWRAPCOND (X BUSY) (PROG (RESULT) (SETQ RESULT X) A (COND ((NULL (CDR RESULT)) (GO B))) (RPLACA (CADR RESULT) (GLUNWRAP (CAADR RESULT) T)) (COND ((EQ (CAADR RESULT) NIL) (RPLACD RESULT (CDDR RESULT)) (GO A)) (T (MAP (CDADR RESULT) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CADR RESULT) BUSY NIL))) (COND ((EQ (CAADR RESULT) T) (RPLACD (CDR RESULT) NIL))) (SETQ RESULT (CDR RESULT)) (GO A) B (COND ((AND (NULL (CDDR X)) (EQ (CAADR X) T)) (RETURN (CONS 'PROGN (CDADR X)))) (T (RETURN X))))) % GSN 17-FEB-83 13:40 % Optimize intersections and unions of subsets of the same set: % (INTERSECT (SUBSET S P) (SUBSET S Q)) -> (SUBSET S (AND P Q)) (DE GLUNWRAPINTERSECT (CODE) (PROG (LHS RHS P Q QQ SA SB) (SETQ LHS (GLUNWRAP (CADR CODE) T)) (SETQ RHS (GLUNWRAP (CADDR CODE) T)) (OR (AND (PAIRP LHS) (PAIRP RHS) (EQ (CAR LHS) 'SUBSET) (EQ (CAR RHS) 'SUBSET)) (GO OUT)) (PROGN (SETQ SA (GLUNWRAP (CADR LHS) T)) (SETQ SB (GLUNWRAP (CADR RHS) T))) % Make sure the sets are the same. (OR (EQUAL SA SB) (GO OUT)) (PROGN (SETQ P (GLXTRFN (CADDR LHS))) (SETQ Q (GLXTRFN (CADDR RHS)))) (SETQ QQ (SUBST (CAR P) (CAR Q) (CADR Q))) (RETURN (GLGENCODE (LIST 'SUBSET SA (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR P)) (GLUNWRAP (CASEQ (CAR CODE) (INTERSECTION (LIST 'AND (CADR P) QQ)) (UNION (LIST 'OR (CADR P) QQ)) (LDIFFERENCE (LIST 'AND (CADR P) (LIST 'NOT QQ))) (T (ERROR 0 NIL))) T)))))) OUT (MAP (CDR CODE) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (RETURN CODE))) % GSN 16-MAR-83 10:50 % Unwrap a logical expression by performing constant transformations % and splicing in sublists of the same type, e.g., (AND X (AND Y Z)) % -> (AND X Y Z) . (DE GLUNWRAPLOG (X) (PROG (Y LAST) (SETQ Y (CDR X)) (SETQ LAST X) LP (COND ((NULL Y) (GO OUT)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'AND)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'OR))) (RPLACD Y NIL)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'OR)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'AND))) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((AND (PAIRP (CAR Y)) (EQ (CAAR Y) (CAR X))) (RPLACD (LASTPAIR (CAR Y)) (CDR Y)) (RPLACD Y (CDDAR Y)) (RPLACA Y (CADAR Y)))) (SETQ Y (CDR Y)) (SETQ LAST (CDR LAST)) (GO LP) OUT (COND ((NULL (CDR X)) (RETURN (EQ (CAR X) 'AND))) ((NULL (CDDR X)) (RETURN (CADR X)))) (RETURN X))) % edited: 19-OCT-82 16:03 % Unwrap and optimize mapping-type functions. (DE GLUNWRAPMAP (X BUSY) (PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST) (PROGN (SETQ LST (GLUNWRAP (CADR X) T)) (SETQ FN (GLUNWRAP (CADDR X) (NOT (MEMQ (CAR X) '(MAPC MAP)))))) (COND ((OR (NOT (MEMQ (SETQ OUTFN (CAR X)) '(SUBSET MAPCAR MAPC MAPCONC))) (NOT (AND (PAIRP LST) (MEMQ (SETQ INFN (CAR LST)) '(SUBSET MAPCAR))))) (GO OUT))) % Optimize compositions of mapping functions to avoid construction of % lists of intermediate results. % These optimizations are not correct if the mapping functions have % interdependent side-effects. However, these are likely to be very % rare, so we do it anyway. (SETQ OUTSIDE (GLXTRFN FN)) (SETQ INSIDE (GLXTRFN (PROGN (SETQ NEWLST (CADR LST)) (CADDR LST)))) (CASEQ INFN (SUBSET (CASEQ OUTFN ((SUBSET MAPCONC) (SETQ NEWMAP OUTFN) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE))))) (MAPCAR (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (LIST 'CONS (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) NIL)))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) ))) (T (ERROR 0 NIL)))) (MAPCAR (SETQ NEWFN (LIST 'PROG (LIST (SETQ TMPVAR (GLMKVAR))) (LIST 'SETQ TMPVAR (CADR INSIDE)) (LIST 'RETURN '*GLCODE*))) (CASEQ OUTFN (SUBSET (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (SUBST (LIST 'AND (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) (LIST 'CONS TMPVAR NIL)) '*GLCODE* NEWFN))) (MAPCAR (SETQ NEWMAP 'MAPCAR) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (T (ERROR 0 NIL)))) (T (ERROR 0 NIL))) (RETURN (GLUNWRAP (GLGENCODE (LIST NEWMAP NEWLST (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR INSIDE)) NEWFN)))) BUSY)) OUT (RETURN (GLGENCODE (LIST OUTFN LST FN))))) % GSN 27-JAN-83 13:57 % Unwrap a PROG expression. (DE GLUNWRAPPROG (X BUSY) (PROG (LAST) (COND ((NE GLLISPDIALECT 'INTERLISP) (GLTRANSPROG X))) % First see if the PROG is not busy and ends with a RETURN. (COND ((AND (NOT BUSY) (SETQ LAST (LASTPAIR X)) (PAIRP (CAR LAST)) (EQ (CAAR LAST) 'RETURN)) % Remove the RETURN. If atomic, remove the atom also. (COND ((ATOM (CADAR LAST)) (RPLACD (NLEFT X 2) NIL)) (T (RPLACA LAST (CADAR LAST)))))) % Do any initializations of PROG variables. (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP Y) (RPLACA (CDR Y) (GLUNWRAP (CADR Y) T))))))) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) NIL))))) (GLEXPANDPROGN (CDR X) BUSY T) (RETURN X))) % GSN 27-JAN-83 13:57 % Unwrap a SELECTQ or CASEQ expression. (DE GLUNWRAPSELECTQ (X BUSY) (PROG (L SELECTOR) % First unwrap the component expressions. (RPLACA (CDR X) (GLUNWRAP (CADR X) T)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (COND ((OR (CDR Y) (EQ (CAR X) 'CASEQ)) (MAP (CDAR Y) (FUNCTION (LAMBDA (Z) (RPLACA Z (GLUNWRAP (CAR Z) (AND BUSY (NULL (CDR Z)))))))) (GLEXPANDPROGN (CAR Y) BUSY NIL)) (T (RPLACA Y (GLUNWRAP (CAR Y) BUSY))))))) % Test if the selector is a compile-time constant. (COND ((NOT (GLCONST? (CADR X))) (RETURN X))) % Evaluate the selection at compile time. (SETQ SELECTOR (GLCONSTVAL (CADR X))) (SETQ L (CDDR X)) LP (COND ((NULL L) (RETURN NIL)) ((AND (NULL (CDR L)) (EQ (CAR X) 'SELECTQ)) (RETURN (CAR L))) ((AND (EQ (CAR X) 'CASEQ) (EQ (CAAR L) T)) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY))) ((OR (EQ SELECTOR (CAAR L)) (AND (PAIRP (CAAR L)) (MEMQ SELECTOR (CAAR L)))) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY)))) (SETQ L (CDR L)) (GO LP))) % edited: 5-MAY-82 15:49 % Update the type of VAR to be TYPE. (DE GLUPDATEVARTYPE (VAR TYPE) (PROG (CTXENT) (COND ((NULL TYPE)) ((SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT)) (COND ((NULL (CADDR CTXENT)) (RPLACA (CDDR CTXENT) TYPE)))) (T (GLADDSTR VAR NIL TYPE CONTEXT))))) % GSN 23-JAN-83 15:31 % edited: 7-Apr-81 10:44 % Process a user-function, i.e., any function which is not specially % compiled by GLISP. The function is tested to see if it is one % which a unit package wants to compile specially; if not, the % function is compiled by GLUSERFNB. (DE GLUSERFN (EXPR) (PROG (FNNAME TMP UPS) (SETQ FNNAME (CAR EXPR)) % First see if a user structure-name package wants to intercept this % function call. (SETQ UPS GLUSERSTRNAMES) LPA (COND ((NULL UPS) (GO B)) ((SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LPA) B % Test the function name to see if it is a function which some unit % package would like to intercept and compile specially. (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (GO C)) ((AND (MEMQ FNNAME (CAR (CDDDDR (CAR UPS)))) (SETQ TMP (ASSOC 'UNITFN (CADDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LP) C (COND ((AND (NOT (UNBOUNDP 'GLFNSUBS)) (SETQ TMP (ASSOC FNNAME GLFNSUBS))) (RETURN (GLUSERFNB (CONS (CDR TMP) (CDR EXPR))))) (T (RETURN (GLUSERFNB EXPR)))))) % GSN 23-JAN-83 15:54 % edited: 7-Apr-81 10:44 % Parse an arbitrary function by getting the function name and then % calling GLDOEXPR to get the arguments. (DE GLUSERFNB (EXPR) (PROG (ARGS ARGTYPES FNNAME TMP) (SETQ FNNAME (pop EXPR)) A (COND ((NULL EXPR) (SETQ ARGS (REVERSIP ARGS)) (SETQ ARGTYPES (REVERSIP ARGTYPES)) (RETURN (COND ((AND (GET FNNAME 'GLEVALWHENCONST) (EVERY ARGS (FUNCTION GLCONST?))) (LIST (EVAL (CONS FNNAME ARGS)) (GLRESULTTYPE FNNAME ARGTYPES))) (T (LIST (CONS FNNAME ARGS) (GLRESULTTYPE FNNAME ARGTYPES)))))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS (CAR TMP) ARGS)) (SETQ ARGTYPES (CONS (CADR TMP) ARGTYPES)) (GO A))))) % edited: 24-AUG-82 17:40 % Get the arguments to an function call for use by a user compilation % function. (DE GLUSERGETARGS (EXPR CONTEXT) (PROG (ARGS TMP) (pop EXPR) A (COND ((NULL EXPR) (RETURN (REVERSIP ARGS))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS TMP ARGS)) (GO A))))) % GSN 10-FEB-83 16:01 % Try to perform an operation on a user-defined structure, which is % LHS. The type of LHS is looked up on GLUSERSTRNAMES, and if found, % the appropriate user function is called. (DE GLUSERSTROP (LHS OP RHS) (PROG (TMP DES TMPB) (SETQ DES (CADR LHS)) (COND ((NULL DES) (RETURN NIL)) ((ATOM DES) (COND ((NE (SETQ TMP (GLGETSTR DES)) DES) (RETURN (GLUSERSTROP (LIST (CAR LHS) TMP) OP RHS))) (T (RETURN NIL)))) ((NOT (PAIRP DES)) (RETURN NIL)) ((AND (SETQ TMP (ASSOC (CAR DES) GLUSERSTRNAMES)) (SETQ TMPB (ASSOC OP (CADDDR TMP)))) (RETURN (APPLY (CDR TMPB) (LIST LHS RHS)))) (T (RETURN NIL))))) % GSN 10-FEB-83 12:57 % Get the value of the property PROP from SOURCE, whose type is given % by TYPE. The property may be a field in the structure, or may be a % PROP virtual field. % DESLIST is a list of object types which have previously been tried, % so that a compiler loop can be prevented. (DE GLVALUE (SOURCE PROP TYPE DESLIST) (PROG (TMP PROPL TRANS FETCHCODE) (COND ((MEMQ TYPE DESLIST) (RETURN NIL)) ((SETQ TMP (GLSTRFN PROP TYPE DESLIST)) (RETURN (GLSTRVAL TMP SOURCE))) ((SETQ PROPL (GLSTRPROP TYPE 'PROP PROP NIL)) (SETQ TMP (GLCOMPMSGL (LIST SOURCE TYPE) 'PROP PROPL NIL CONTEXT)) (RETURN TMP))) % See if the value can be found in a TRANSPARENT subobject. (SETQ TRANS (GLTRANSPARENTTYPES TYPE)) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLVALUE '*GL* PROP (GLXTRTYPE (CAR TRANS)) (CONS (CAR TRANS) DESLIST))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) TYPE NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP SOURCE) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % edited: 16-DEC-81 12:00 % Get the structure-description for a variable in the specified % context. (DE GLVARTYPE (VAR CONTEXT) (PROG (TMP) (RETURN (COND ((SETQ TMP (GLFINDVARINCTX VAR CONTEXT)) (OR (CADDR TMP) '*NIL*)) (T NIL))))) % edited: 3-DEC-82 10:24 % Extract the code and variable from a FUNCTION list. If there is no % variable, a new one is created. The result is a list of the % variable and code. (DE GLXTRFN (FNLST) (PROG (TMP) % If only the function name is specified, make a LAMBDA form. (COND ((ATOM (CADR FNLST)) (RPLACA (CDR FNLST) (LIST 'LAMBDA (LIST (SETQ TMP (GLMKVAR))) (LIST (CADR FNLST) TMP))))) (COND ((CDDDR (CADR FNLST)) (RPLACD (CDADR FNLST) (LIST (CONS 'PROGN (CDDADR FNLST)))))) (RETURN (LIST (CAADR (CADR FNLST)) (CADDR (CADR FNLST)))))) % edited: 26-JUL-82 14:03 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GLXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (OR (GL-A-AN? (CAR TYPE)) (EQ (CAR TYPE) 'TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPE (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 26-JUL-82 14:02 % Extract a -real- type from a type spec. (DE GLXTRTYPEB (TYPE) (COND ((NULL TYPE) NIL) ((ATOM TYPE) (COND ((MEMQ TYPE GLBASICTYPES) TYPE) (T (GLXTRTYPEB (GLGETSTR TYPE))))) ((NOT (PAIRP TYPE)) NIL) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPEB (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 1-NOV-82 16:38 % Extract a -real- type from a type spec. (DE GLXTRTYPEC (TYPE) (AND (ATOM TYPE) (NOT (MEMQ TYPE GLBASICTYPES)) (GLXTRTYPE (GLGETSTR TYPE)))) % GSN 9-FEB-83 16:46 (DF SEND (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) NIL (CADR GLISPSENDARGS) 'MSG (MAPCAR (CDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDC (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) (CADR GLISPSENDARGS) (CADDR GLISPSENDARGS) 'MSG (MAPCAR (CDDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:46 (DF SENDPROP (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) NIL (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (MAPCAR (CDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDPROPC (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (CADDDR GLISPSENDPROPARGS) (MAPCAR (CDDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) (SETQ GLOBJECTNAMES NIL) (GLISPOBJECTS (GLTYPE (ATOM (PROPLIST (GLSTRUCTURE (CONS (STRDES ANYTHING) (PROPLIST (PROP (LISTOF GLPROPENTRY) ) (ADJ (LISTOF GLPROPENTRY)) (ISA (LISTOF GLPROPENTRY)) (MSG (LISTOF GLPROPENTRY)) (DOC ANYTHING) (SUPERS (LISTOF GLTYPE)))) ) (GLISPATOMNUMBER INTEGER) (GLPROPFNS (ALIST (STR (LISTOF GLPROPFNENTRY)) (PROP (LISTOF GLPROPFNENTRY)) (ADJ (LISTOF GLPROPFNENTRY)) (ISA (LISTOF GLPROPFNENTRY)) (MSG (LISTOF GLPROPFNENTRY)))) (GLFNSUSEDIN (LISTOF GLFUNCTION)))) PROP ((PROPS (PROP)) (ADJS (ADJ)) (ISAS (ISA)) (MSGS (MSG)))) (GLPROPENTRY (CONS (NAME ATOM) (CONS (CODE ANYTHING) (PROPLIST (RESULT GLTYPE) (OPEN BOOLEAN)))) PROP ((SHORTVALUE (NAME)))) (GLPROPFNENTRY (LIST (NAME ATOM) (CODE ANYTHING) (RESULT GLTYPE))) (GLFUNCTION (ATOM (PROPLIST (GLORIGINALEXPR ANYTHING) (GLCOMPILED ANYTHING) (GLRESULTTYPE ANYTHING) (GLARGUMENTTYPES (LISTOF ANYTHING)) (GLTYPESUSED (LISTOF GLTYPE))))) ) (SETQ GLLISPDIALECT 'PSL) (GLINIT) |
Added psl-1983/3-1/glisp/glprop.sl version [08b009e713].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GSN 11-JAN-83 09:59 % Create a function call to retrieve the field IND from a % property-list type structure. FLG is true if a PROPLIST is inside % an ATOM structure. (DE GLPROPSTRFN (IND DES DESLIST FLG) (PROG (DESIND TMP RECNAME N) % Handle a PROPLIST by looking inside each property for IND. (COND ((AND (EQ (SETQ DESIND (pop DES)) 'RECORD) (ATOM (CAR DES))) (SETQ RECNAME (pop DES)))) (SETQ N 0) P (COND ((NULL DES) (RETURN NIL)) ((AND (PAIRP (CAR DES)) (ATOM (CAAR DES)) (CDAR DES) (SETQ TMP (GLSTRFN IND (CAR DES) DESLIST))) (SETQ TMP (GLSTRVAL TMP (glgencode (CASEQ DESIND (ALIST (LIST 'GLGETASSOC (KWOTE (CAAR DES)) '*GL*)) ((RECORD OBJECT) (COND ((EQ DESIND 'OBJECT) (SETQ N (ADD1 N)))) (LIST 'GetV '*GL* N)) ((PROPLIST ATOMOBJECT) (LIST (COND ((OR FLG (EQ DESIND 'ATOMOBJECT)) 'GETPROP) (T 'LISTGET)) '*GL* (KWOTE (CAAR DES)))))))) (RETURN TMP)) (T (pop DES) (SETQ N (ADD1 N)) (GO P))))) |
Added psl-1983/3-1/glisp/glscan.sl version [12dda21ad9].
> > > > > > > > | 1 2 3 4 5 6 7 8 | (setq GLispScanTable!* ' [17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 GLispDipthong]) |
Added psl-1983/3-1/glisp/gltail.psl version [bda1458bda].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLTAIL.PSL.4 18 Feb. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (COND ((PAIRP (GETD X)) (CDR (GETD X))) (T NIL))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NOT (PAIRP L)) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (glputhook (car x)) ) % Put the hook macro onto a function to cause auto compilation. (df glputhook (x) (put x 'glcompiled nil) (putd x 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (setq globjectnames nil) (GLINIT) |
Added psl-1983/3-1/glisp/gltail.sl version [9172196497].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLTAIL.PSL.10 14 Jan. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (CDR (GETD X))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NULL L) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST) (COND ((GREATERP M (FLATSIZE2 ATM))(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (put (car x) 'glcompiled nil) (putd (car x) 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (GLINIT) |
Added psl-1983/3-1/glisp/gltest version [0822a2efe8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.PSL.2 22 OCTOBER 82 % GLISP TEST FUNCTIONS, PSL VERSION. GSN 22 OCTOBER 82 (DE GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DE CURRENTDATE () (A DATE WITH YEAR = 1981 !, MONTH = 11 !, DAY = 30)) (PUTPROP 'CURRENTDATE 'GLRESULTTYPE 'DATE) (GLISPOBJECTS (EMPLOYEE (LIST (NAME STRING) (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH ' (JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) (PUTPROP 'COMPANY1 'PRESIDENT '("OSCAR THE GROUCH" (3 15 1907) 88.0 PRESIDENT NIL) ) (PUTPROP 'COMPANY1 'EMPLOYEES '(("COOKIE MONSTER" (7 21 1947) 12.5 ELECTRICIAN NIL) ("BETTY LOU" (5 14 1980) 9.0 ELECTRICIAN NIL) ("GROVER" (6 13 1978) 3.0 ELECTRICIAN T)) ) (GLISPOBJECTS (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T) (/ VECTORQUOTIENT OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ SELF PRIN1) (TERPRI))) ) ) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE PAINT))))) (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) (VELOCITY VECTOR)) MSG ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((_ SELF MOVE VELOCITY)))) ) ) (DE VECTORPLUS (V1!,V2:VECTOR) (A VECTOR WITH X = V1:X + V2:X !, Y = V1:Y + V2:Y)) (DE VECTORDIFF (V1!,V2:VECTOR) (A VECTOR WITH X = V1:X - V2:X !, Y = V1:Y - V2:Y)) (DE VECTORTIMES (V:VECTOR N:NUMBER) (A VECTOR WITH X = X*N !, Y = Y*N)) (DE VECTORQUOTIENT (V:VECTOR N:NUMBER) (A VECTOR WITH X = X/N !, Y = Y/N)) (DE VECTORMOVE (V!,DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y)) (DE GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (_ SELF ERASE) (START _+ DELTA) (_ SELF DRAW)) (DE MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) (DE TESTFN1 () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE =(QUOTE RECTANGLE) !, SIZE =(A VECTOR WITH X = 4 !, Y = 3) !, VELOCITY =(A VECTOR WITH X = 3 !, Y = 4))) (N _ 0) (WHILE (N_+1) <100 (_ MGO STEP)) (_(THE START OF MGO) PRINT))) (DE TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA )) (DE DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS)))) ) (GLISPOBJECTS (LISPTREE (CONS (CAR LISPTREE) (CDR LISPTREE)) PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) (DE TP (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (_ PSR NEXT)))) (GLISPOBJECTS (ARITHMETICOPERATOR (SELF ATOM) PROP ((PRECEDENCE OPERATORPRECEDENCEFN RESULT INTEGER) (PRINTFORM ((GET SELF (QUOTE PRINTFORM)) OR SELF))) MSG ((PRIN1 ((PRIN1 THE PRINTFORM)))) ) (INTEGERMOD7 (SELF INTEGER) PROP ((MODULUS (7)) (INVERSE ((IF SELF IS ZERO THEN 0 ELSE (MODULUS - SELF))))) ADJ ((EVEN ((ZEROP (LOGAND SELF 1)))) (ODD (NOT EVEN))) ISA ((PRIME PRIMETESTFN)) MSG ((+ IMOD7PLUS OPEN T RESULT INTEGERMOD7) (_ IMOD7STORE OPEN T RESULT INTEGERMOD7)) ) ) (DE IMOD7STORE (LHS:INTEGERMOD7 RHS:INTEGER) (LHS:SELF __(IREMAINDER RHS MODULUS))) (DE IMOD7PLUS (X!,Y:INTEGERMOD7) (IREMAINDER (X:SELF + Y:SELF) X:MODULUS)) (DE SA (:ARITHMETICOPERATOR) (IF PRECEDENCE>5 (_ (THE ARITHMETICOPERATOR) PRIN1))) (DE SB (X:INTEGERMOD7) (PROG (Y) (LIST MODULUS INVERSE) (IF X IS ODD OR X IS EVEN OR X IS A PRIME THEN (Y _ 5) (X _ 12) (X _+5)))) (GLISPOBJECTS (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) ) )) % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DE GROWCIRCLE (C:CIRCLE) (C:AREA_+100) (PRINT RADIUS) ) (SETQ MYCIRCLE '((0 0) 0.0)) % EXAMPLE OF ELIMINATION OF COMPILE-TIME CONSTANTS (DE SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF 6<2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) |
Added psl-1983/3-1/glisp/gltest.sl version [a4c3c38e87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.SL.2 18 February 1983 % GLISP TEST FUNCTIONS, PSL VERSION. % Object descriptions for a Company database. (GLISPOBJECTS (EMPLOYEE % Name of the object type (LIST (NAME STRING) % Actual storage structure (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) % Computed properties - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) % Computed adjectives ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) % Message definitions (Date (List (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH '(JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) % Some test data for the above functions. (setq company1 (a company with President = (An Employee with Name = "Oscar the Grouch" Salary = 88.0 Jobtitle = 'President Date-Hired = (A Date with Month = 3 Day = 15 Year = 1907)) Employees = (list (An Employee with Name = "Cookie Monster" Salary = 12.50 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 7 Day = 21 Year = 1947)) (An Employee with Name = "Betty Lou" Salary = 9.00 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 5 Day = 15 Year = 1980)) (An Employee with Name = "Grover" Salary = 3.00 Jobtitle = 'Electrician Trainee = T Date-Hired = (A Date with Month = 6 Day = 13 Year = 1978)) ))) % Program to give raises to the electricians. (DG GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DG CURRENTDATE () (Result DATE) (A DATE WITH YEAR = 1981 MONTH = 11 DAY = 30)) % The following object descriptions are used in a graphics object test % program (derived from one written by D.G. Bobrow as a LOOPS example). % The test program MGO-TEST runs on a Xerox D-machine, but won't run on % other machines. (GLISPOBJECTS % The actual stored structure for a Vector is simple, but it is overloaded % with many properties. (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (DIRECTION ((IF X IS ZERO THEN (IF Y IS NEGATIVE THEN -90.0 ELSE 90.0) ELSE (ATAN2D Y X))) RESULT DEGREES) ) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) % Defining operators as messages % causes the compiler to automatically % overload the operators. (- VECTORDIFF OPEN T) (* VECTORTIMESSCALAR ARGTYPES (NUMBER) OPEN T) (* VECTORDOTPRODUCT ARGTYPES (VECTOR) OPEN T) (/ VECTORQUOTIENTSCALAR OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((SEND SELF PRIN1) % PRINT is defined in terms of the (TERPRI))) ) ) % PRIN1 message of this object. (DEGREES REAL % Stored value is just a real number. PROP ((RADIANS (self*(3.1415926 / 180.0)) RESULT RADIANS))) (RADIANS REAL PROP ((DEGREES (self*(180.0 / 3.1415926)) RESULT DEGREES))) % A FVECTOR is a very different kind of VECTOR: it has a different % storage structure and different element types. However, it can % still inherit some vector properties, e.g., addition. (FVECTOR (CONS (Y STRING) (X BOOLEAN)) SUPERS (VECTOR)) % The definition of GraphicsObject builds on that of Vector. (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) % A property defined in terms of a % property of a substructure (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) % Vector arithmetic (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) % A way to get runtime message (List SELF % behavior without using the (QUOTE PAINT))))) % message mechanism. (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) % Includes properties of a (VELOCITY VECTOR)) % GraphicsObject due to the % TRANSPARENT declaration. Msg ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((SEND SELF MOVE VELOCITY)))) ) ) % The following functions define arithmetic operations on Vectors. % These functions are generally called OPEN (macro-expanded) rather % than being called directly. (DG VECTORPLUS (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) (DG VECTORDIFF (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) (DG VECTORTIMESSCALAR (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X*N Y = Y*N)) (DG VECTORDOTPRODUCT (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X * V2:X Y = V1:Y * V2:Y)) (DG VECTORQUOTIENTSCALAR (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X/N Y = Y/N)) % VectorMove, which defines the _+ operator for vectors, does a destructive % addition to the vector which is its first argument. Thus, the expression % U_+V will destructively change U, while U_U+V will make a new vector with % the value U+V and assign its value to U. (DG VECTORMOVE (V:vector DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y) V) % An object is moved by erasing it, changing its starting point, and % then redrawing it. (DG GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (SEND SELF ERASE) % Erase the object (START _+ DELTA) % Destructively move start point by delta (SEND SELF DRAW)) % Redraw the object in new location (DG MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) % Now we define some test functions which use the above definitions. % First there are some simple functions which test vector operations. (DG TVPLUS (U:VECTOR V:VECTOR) U+V) (DG TVMOVE (U:VECTOR V:VECTOR) U_+V) (DG TVTIMESV (U:VECTOR V:VECTOR) U*V) (DG TVTIMESN (U:VECTOR V:NUMBER) U*V) (DG TFVPLUS (U:FVECTOR V:FVECTOR) U+V) % This test function creates a MovingGraphicsObject and then moves it % across the screen by sending it MOVE messages. Everything in this % example is compiled open; the STEP message involves a great deal of % message inheritance. (DG MGO-TEST () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE = (QUOTE RECTANGLE) SIZE = (A VECTOR WITH X = 4 Y = 3) VELOCITY = (A VECTOR WITH X = 3 Y = 4))) (N _ 0) (WHILE (N_+1)<100 (SEND MGO STEP)) (SEND (THE START OF MGO) PRINT))) % This function tests the properties of a GraphicsObject. (DG TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA)) % Function to draw a rectangle. Computed properties of the rectangle are % used within calls to the graphics functions, making the code easy to % write and understand. (DG DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS) )) % The LispTree and PreorderSearchRecord objects illustrate how generators % can be written. (GLISPOBJECTS % In defining a LispTree, which can actually be of multiple types (atom or % dotted pair), we define it as the more complex dotted-pair type and take % care of the simpler case in the PROPerty definitions. (LISPTREE (CONS (CAR LISPTREE) % Defines a LispTree structure as the CONS (CDR LISPTREE)) % of two fields named CAR and CDR. PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) % PreorderSearchRecord is defined to be a generator. Its data structure holds % the current node and a stack of previous nodes, and its NEXT message is % defined as code to step through the preorder search. (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) % PRINTLEAVES prints the leaves of the tree, using a PreorderSearchRecord % as the generator for searching the tree. (DG PRINTLEAVES (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (SEND PSR NEXT)))) % The Circle objects illustrate the definition of a number of mathematical % properties of an object in terms of stored data and other properties. (Glispobjects (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) % A PROPerty can be a constant. (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) % Defined in terms of other prop. (AREA (PI*RADIUS^2)) ) ADJ ((BIG (AREA>120)) % BIG defined in terms of AREA (MEDIUM (AREA >= 60 AND AREA <= 120)) (SMALL (AREA<60))) MSG ((STANDARD (AREA_100)) % "Storing into" computed property (GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) ) ) % A DCIRCLE is implemented differently from a circle. % The data structure is different, and DIAMETER is stored instead of RADIUS. % By defining RADIUS as a PROPerty, all of the CIRCLE properties defined % in terms of radius can be inherited. (DCIRCLE (LISTOBJECT (START VECTOR) (DIAMETER REAL)) PROP ((RADIUS (DIAMETER/2))) SUPERS (CIRCLE) ) ) % Make a DCIRCLE for testing (setq dc (a dcircle with diameter = 10.0)) % Since DCIRCLE is an Object type, it can be used with interpreted messages, % e.g., (send dc area) to get the area property, % (send dc standard) to set the area to the standard value, % (send dc diameter) to get the stored diameter value. % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DG GROWCIRCLE (C:CIRCLE) (C:AREA_+100) C ) (SETQ MYCIRCLE (A CIRCLE)) % Since SQRT is not defined in the bare-PSL system, we redefine it here. (DG SQRT (X) (PROG (S) (S_X) (IF X < 0 THEN (ERROR) ELSE (WHILE (ABS S*S - X) > 0.000001 DO (S _ (S+X/S) * 0.5))) (RETURN S))) % Function SQUASH illustrates elimination of compile-time constants. % Of course, nobody would write such a function directly. However, such forms % can arise when inherited properties are compiled. Conditional compilation % occurs automatically when appropriate variables are defined to the GLISP % compiler as compile-time constants because the post-optimization phase of % the compiler makes the unwanted code disappear. (DG SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF (SQRT 7.2) < 2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) % The following object definitions describe a student records database. (glispobjects (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winning (average>=95)) (losing (average<60))) isa ((winner (self is winning)))) (student-group (listof student) prop ((n-students length) % This property is implemented by % the Lisp function LENGTH. (Average Student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male))) (women ((those students who are female))) (winners ((those students who are winning))) (losers ((those students who are losing))) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)) (for s in sg do sum_+s:average) (return sum/sg:n-students) )) % Print name and grade average for each student (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (print s:grade-average))) % Another version of the above function (dg test1b (:class) (for each student (prin1 name) (prin2 '! ) (print grade-average))) % Print name and average of the winners in the class (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % The average of all the male students' grades (dg test3 (c:class) c:men:average) % The name and average of the winning women (dg test4 (c:class) (for s in c:women when s is winning (prin1 s:name) (prin2 '! ) (print s:average))) % Another version of the above function. The * operator in this case % denotes the intersection of the sets of women and winners. The % GLISP compiler optimizes the code so that these intermediate sets are % not actually constructed. (dg test4b (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % Make a list of the easy professors. (dg easy-profs (classes:(listof class)) (for each class with class-average > 90.0 collect (the instructor))) % A more Pascal-like version of easy-profs: (dg easy-profs-b (classes:(listof class)) (for c in classes when c:class-average > 90.0 collect c:instructor)) % Some test data for testing the above functions. (setq class1 (a class with instructor = "A. Prof" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) % The following object definitions illustrate inheritance of properties % from multiple parent classes. The three "bottom" classes Planet, Brick, % and Bowling-Ball all inherit the same definition of the property Density, % although they are represented in very different ways. (glispobjects (physical-object anything prop ((density (mass/volume)))) (ordinary-object anything prop ((mass (weight / 9.88))) % Compute mass as weight/gravity supers (physical-object)) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (parallelepiped anything prop ((volume (length*width*height)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) % A planet is a physical-object % and a sphere. (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) % Three test functions to demonstrate inheritance of the Density property. (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) % Some objects to test the functions on. (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.10 height = 0.05 length = 0.20)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) % Since the object types Planet, Brick, and Bowling-Ball are defined as % Object types (i.e., they contain the Class name as part of their stored % data), messages can be sent to them directly from the keyboard for % interactive examination of the objects. For example, the following % messages could be used: % (send earth density) % (send brick1 weight: 25.0) % (send brick1 mass: 2.0) % (send bb1 radius) % (send bb1 type: 'child) |
Added psl-1983/3-1/glisp/gltestb.psl version [bf458d1abf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (glispobjects (circle (list (start vector) (radius real) (color atom)) prop ((pi (3.14159265)) (diameter (2*radius)) (circumference (pi*diameter)) (area (pi*radius^2))) adj ((big (area>100)) (small (area<80))) msg ((grow (area_+100)) (shrink (area_area/2)) (standard (area_100))) ) (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winner (average>=95)) (loser (average<60))) isa ((winner (self is winner)))) (student-group (listof student) prop ((n-students length) (average student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male)) result student-group) (women ((those students who are female)) result student-group) (winners ((those students who are winner)) result student-group) (losers ((those students who are loser)) result student-group) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)(n 0.0)) (for s in sg do sum_+s:average n _+ 1.0) (return sum/n) )) (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (prin1 s:grade-average) (terpri))) (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (dg test3 (c:class) c:men:average) (dg test4 (c:class) (for s in c:women when s is winner (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (dg test5 (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (setq class1 (a class with instructor = "G. Novak" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) (glispobjects (physical-object anything prop ((density (mass/volume)))) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) (ordinary-object anything prop ((mass (weight / 9.88))) supers (physical-object)) (parallelepiped anything prop ((volume (length*width*height)))) (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.06 height = 0.04 length = 0.16)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) |
Added psl-1983/3-1/glisp/gltrans.sl version [e169a20d55].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTRANS.SL.1 12 April 1983 % % Translate files from GLISP form to PSL. % G. Novak 12 April 83 (global '(gltransfile)) % Open a file for output (de gltransopen (filename) (setq gltransfile (open filename 'output))) % Close the output file (de gltransclose () (close gltransfile)) % Read a file, translate it, and append to the output file. (de gltransread (filename) (prog (infile expr) (setq infile (open filename 'input)) lp (setq expr (channelread infile)) (cond ((eq expr !$EOF!$) (return t)) ((pairp expr) (eval expr) (channelterpri gltransfile) (cond ((eq (car expr) 'dg) (glcc (cadr expr)) (channelprin1 gltransfile (cons 'de (cons (cadr expr) (cdr (get (cadr expr) 'glcompiled)))))) (t (channelprin1 gltransfile expr))) (channelterpri gltransfile))) (go lp))) |
Added psl-1983/3-1/glisp/gltype.sl version [071eed503d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Define the GLISP types. GSN 07 march 83 (glispobjects (gltype (atom (proplist (glstructure (cons (strdes anything) (proplist (prop (listof glpropentry)) (adj (listof glpropentry)) (isa (listof glpropentry)) (msg (listof glpropentry)) (supers (listof gltype))))) (glispatomnumber integer) (glpropfns (alist (str (listof glpropfnentry)) (prop (listof glpropfnentry)) (adj (listof glpropfnentry)) (isa (listof glpropfnentry)) (msg (listof glpropfnentry)))))) prop ((props (prop)) (adjs (adj)) (isas (isa)) (msgs (msg)))) (glpropentry (cons (name atom) (cons (code anything) (proplist (result gltype) (open boolean))))) (glpropfnentry (list (name atom) (code anything) (result gltype))) ) (put 'atom 'glstructure '(atom prop ((pname id2string result string)))) |
Added psl-1983/3-1/glisp/gluser.mss version [074026df66].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Make(Manual) @Define(PE,FaceCode U) @Begin(TitlePage) @Begin(TitleBox) @MajorHeading[GLISP User's Manual] @BlankSpace(2) @Center( Gordon S. Novak Jr. Computer Science Department Stanford University Stanford, California 94305) @BlankSpace(3) @BlankSpace(2) @Center[@B<Revised:> @Value(Date)] @End(TitleBox) @Begin(ResearchCredit) This research was supported in part by NSF grant SED-7912803 in the Joint National Science Foundation - National Institute of Education Program of Research on Cognitive Processes and the Structure of Knowledge in Science and Mathematics, and in part by the Defense Advanced Research Projects Agency under contract MDA-903-80-c-007. @End(ResearchCredit) @End(TitlePage) @Chapter(Introduction) @Section(Overview of GLISP) GLISP is a LISP-based language which provides high-level language features not found in ordinary LISP. The GLISP language is implemented by means of a compiler which accepts GLISP as input and produces ordinary LISP as output; this output can be further compiled to machine code by the LISP compiler. GLISP is available for several LISP dialects, including Interlisp, Maclisp, UCI Lisp, ELISP, Franz Lisp, and Portable Standard Lisp. The goal of GLISP is to allow structured objects to be referenced in a convenient, succinct language, and to allow the structures of objects to be changed without changing the code which references the objects. GLISP provides both PASCAL-like and English-like syntaxes; much of the power and brevity of GLISP derive from the compiler features necessary to support the relatively informal, English-like language constructs. The following example function illustrates how GLISP permits definite reference to structured objects. @Begin(ProgramExample) (HourlySalaries (GLAMBDA ( (a DEPARTMENT) ) (for each EMPLOYEE who is HOURLY (PRIN1 NAME) (SPACES 3) (PRINT SALARY) ) )) @End(ProgramExample) The features provided by GLISP include the following: @Begin(Enumerate) GLISP maintains knowledge of the "context" of the computation as the program is executed. Features of objects which are in context may be referenced directly; the compiler will determine how to reference the objects given the current context, and will add the newly referenced objects to the context. In the above example, the function's argument, an object whose class is DEPARTMENT, establishes an initial context relative to which EMPLOYEEs can be found. In the context of an EMPLOYEE, NAME and SALARY can be found. GLISP supports flexible object definition and reference with a powerful abstract datatype facility. Object classes are easily declared to the system. An object declaration includes a definition of the storage structure of the object and declarations of properties of the object; these may be declared in such a way that they compile open, resulting in efficient object code. GLISP supports object-centered programming, in which processes are invoked by means of "messages" sent to objects. Object structures may be LISP structures (for which code is automatically compiled) or Units in the user's favorite representation language (for which the user can supply compilation functions). Loop constructs, such as @ (FOR EACH <item> WITH <property> DO ...)@ , are compiled into loops of the appropriate form. Compilation of infix expressions is provided for the arithmetic operators and for additional operators which facilitate list manipulation. Operators are interpreted appropriately for Lisp datatypes as well as for numbers; operator overloading for user-defined objects is provided using the message facility. The GLISP compiler infers the types of objects when possible, and uses this knowledge to generate efficient object code. By performing @I[ compilation relative to a knowledge base ], GLISP is able to perform certain computations (e.g., inheritance of an attached procedure from a parent class of an object in a knowledge base) at compile time rather than at runtime, resulting in much faster execution. By separating object definitions from the code which references objects, GLISP permits radical changes to object structures with no changes to code. @End(Enumerate) @Section(Implementation) GLISP is implemented by means of a compiler, which produces a normal Lisp EXPR from the GLISP code; the GLISP code is saved on the function's property list, and the compiled definition replaces the GLISP definition. Use of GLISP entails the cost of a single compilation, but otherwise is about as efficient as normal LISP. The LISP code produced by GLISP can be further compiled to machine code by the LISP compiler. GLISP functions are indicated by the use of GLAMBDA instead of LAMBDA in the function definition. When the Lisp interpreter sees the GLAMBDA, it calls the GLISP compiler to incrementally compile the GLISP function. The compiled version replaces the GLISP version (which is saved on the function name's property list), and is used thereafter. This automatic compilation feature is currently implemented in Interlisp and in Franz Lisp. In other dialects, it is necessary for the user to explicitly invoke compilation of GLISP functions by calling the compiler function @PE[GLCC] for each one. To use GLISP, it is first necessary to load the compiler file into Lisp. Users' files containing structure descriptions and GLISP code are then loaded. Compilation of a GLISP function is requested by: @Tabset(1.7 inch) @Begin(Format) @PE[(GLCC 'FN)]@\Compile @PE[FN]. @PE[(GLCP 'FN)]@\Compile @PE[FN] and prettyprint the result. @PE[(GLP 'FN)]@\Print the compiled version of @PE[FN]. @End(Format) In Interlisp, all the GLISP functions (beginning with GLAMBDA) in a file can be compiled by invoking @PE[(GLCOMPCOMS@ <file>COMS)], where @PE[<file>COMS] is the list of file package commands for the file. Properties of compiled functions are stored on the property list of the function name: @Begin(Format) @PE[GLORIGINALEXPR]@\Original (GLISP) version of the function.@FOOT[The original definition is saved as EXPR in Interlisp.] @PE[GLCOMPILED]@\GLISP-compiled version of the function. @PE[GLRESULTTYPE]@\Type of the result of the function. @PE[GLARGUMENTTYPES]@\Types of the arguments of the function. @End(format) Properties of GLISP functions can be examined with the function @PE[(GLED '<name>)], which calls the Lisp editor on the property list of @PE[<name>]. @PE[(GLEDF '<name>)] calls the Lisp editor on the original (GLISP) definition of @PE[<name>]. @Section(Error Messages) GLISP provides detailed error messages when compilation errors are detected; many careless errors such as misspellings will be caught by the compiler. When the source program contains errors, the compiled code generates runtime errors upon execution of the erroneous expressions. @Section(Interactive Features of GLISP) Several features of GLISP are available interactively, as well as in compiled functions: @Enumerate{ The @PE[A] function, which creates structured objects from a readable property/value list, is available as an interactive function. Messages to objects can be executed interactively. A display editor/inspector, GEV, is available for use with bitmap graphics terminals.@Foot[GEV is currently implemented only for Xerox Lisp machines.] GEV interprets objects according to their GLISP structure descriptions; it allows the user to inspect objects, edit them, interactively construct programs which operate on them, display computed properties, send messages to objects, and "push down" to inspect data values.} @Chapter(Object Descriptions) @Section(Declaration of Object Descriptions) An @I(Object Description) in GLISP is a description of the structure of an object in terms of named substructures, together with definitions of ways of referencing the object. The latter may include @I( properties ) (i.e., data whose values are not stored, but are computed from the values of stored data), adjectival predicates, and @I(messages) which the object can receive; the messages can be used to implement operator overloading and other compilation features. Object Descriptions are obtained by GLISP in several ways: @Begin(Enumerate) The descriptions of basic datatypes (e.g., INTEGER) are automatically known to the compiler. Structure descriptions (but not full object descriptions) may be used directly as @I(types) in function definitions. The user may declare object descriptions to the system using the function GLISPOBJECTS; the names of the object types may then be used as @I[ types ] in function definitions and definitions of other structures. Object descriptions may be included as part of a knowledge representation language, and are then furnished to GLISP by the interface package written for that representation language. @End(Enumerate) LISP data structures are declared using the function GLISPOBJECTS@Foot{ Once declared, object descriptions may be included in INTERLISP program files by including in the <file>COMS a statement of the form: @PE[(GLISPOBJECTS@ <object-name@-(1)>@ ...@ <object-name@-(n)>)]}, which takes one or more object descriptions as arguments (assuming the descriptions to be quoted). Since GLISP compilation is performed relative to the knowledge base of object descriptions, the object descriptions must be declared prior to GLISP compilation of functions using those descriptions. The format of each description is as follows: @Begin(ProgramExample) (<object name> <structure description> PROP <property descriptions> ADJ <adjective descriptions> ISA <predicate descriptions> MSG <message descriptions> SUPERS <list of superclasses> VALUES <list of values> ) @End(ProgramExample) The <object name> and <structure description> are required; the other property/value pairs are optional, and may appear in any order. The following example illustrates some of the declarations which might be made to describe the object type @PE(VECTOR). @Begin(ProgramExample) (GLISPOBJECTS (VECTOR (CONS (X NUMBER) (Y NUMBER)) PROP ( (MAGNITUDE ((SQRT X*X + Y*Y))) ) ADJ ( (ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0)) ) MSG ( (+ VECTORPLUS OPEN T) (- VECTORDIFFERENCE) ) )) @End(ProgramExample) @Subsection(Property Descriptions) Each @PE[<description>] specified with PROP, ADJ, ISA, or MSG has the following format: @Begin(ProgramExample) (<name> <response> <prop@-[1]> <value@-[1]> ... <prop@-[n]> <value@-[n]>) @END(ProgramExample) where @PE[<name>] is the (atomic) name of the property, @PE[<response>] is a function name or a list of GLISP code to be compiled in place of the property, and the @PE[<prop>@ <value>] pairs are optional properties which affect compilation. All four kinds of properties are compiled in a similar fashion, as described in the section "Compilation of Messages". @Subsection(Supers Description) The SUPERS list specifies a list of @I[ superclasses ], i.e., the names of other object descriptions from which the object may inherit PROP, ADJ, ISA, and MSG properties. Inheritance from superclasses can be recursive, as described under "Compilation of Messages". @Subsection(Values Description) The VALUES list is a list of pairs, @PE[ (<name> <value>) ], which is used to associate symbolic names with constant values for an object type. If VALUES are defined for the type of the @I[ selector ] of a CASE statement, the corresponding symbolic names may be used as the selection values for the clauses of the CASE statement. @Section(Structure Descriptions) Much of the power of GLISP is derived from its use of Structure Descriptions. A Structure Description (abbreviated "<sd>") is a means of describing a LISP data structure and giving names to parts of the structure; it is similar in concept to a Record declaration in PASCAL. Structure descriptions are used by the GLISP compiler to generate code to retrieve and store parts of structures. @Subsection(Syntax of Structure Descriptions) The syntax of structure descriptions is recursively defined in terms of basic types and composite types which are built up from basic types. The syntax of structure descriptions is as follows: @Foot[The names of the basic types and the structuring operators must be all upper-case or lower-case, depending on the case which is usual for the underlying Lisp system. In general, other GLISP keywords and user program names may be in upper-case, lower-case, or mixed-case, if mixed cases are permitted by the Lisp system.] @Begin(Enumerate) The following basic types are known to the compiler: @Begin(Format) @Tabdivide(3) @B(ATOM) @B(INTEGER) @B(REAL) @B(NUMBER)@\(either INTEGER or REAL) @B(STRING) @B(BOOLEAN)@\(either T or NIL) @B(ANYTHING)@\(an arbitrary structure) @End(Format) An object type which is known to the compiler, either from a GLISPOBJECTS declaration or because it is a Class of units in the user's knowledge representation language, is a valid type for use in a structure description. The <name>@ of such an object type may be specified directly as <name> or, for readability, as @ @B[(A]@ <name>@B[)]@ or @ @B[(AN]@ <name>@B[)]. @Foot[Whenever the form @B<(A ...)> is allowed in GLISP, the form @B<(AN ...)> is also allowed.]@ Any substructure can be named by enclosing it in a list prefixed by the name: @ @B[(]<name>@ @ <sd>@B[)]@ . This allows the same substructure to have multiple names. "A", "AN", and the names used in forming composite types (given below) are treated as reserved words, and may not be used as names. Composite Structures:@ Structured data types composed of other structures are described using the following structuring operators: @Begin(Enumerate) (@B[CONS]@ @ <sd@-[1]>@ @ <sd@-[2]>) @* The CONS of two structures whose descriptions are <sd@-[1]> and <sd@-[2]>. (@B[LIST]@ @ <sd@-[1]>@ @ <sd@-[2]>@ @ ...@ @ <sd@-[n]>) @* A list of exactly the elements whose descriptions are <sd@-[1]>@ <sd@-[2]>@ ...@ <sd@-[n]>. (@B[LISTOF]@ @ <sd>) @* A list of zero or more elements, each of which has the description <sd>. (@B[ALIST]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @* An association list in which the atom <name@-[i]>, if present, is associated with a structure whose description is <sd@-[i]>. (@B[PROPLIST]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @* An association list in "property-list format" (alternating names and values) in which the atom <name@-[i]>, if present, is associated with a structure whose description is <sd@-[i]>. (@B[ATOM]@ @ @ (@B[BINDING]@ @ <sd>) @ @ @ @ (@B[PROPLIST]@ @ (<pname@-[1]>@ <sd@-[1]>)@ ...@ @~ (<pname@-[n]>@ <sd@-[n]>)@ )) @* This describes an atom with its binding and/or its property list; either the BINDING or the PROPLIST group may be omitted. Each property name <pname@-[i]> is treated as a property list indicator as well as the name of the substructure. When creation of such a structure is specified, GLISP will compile code to create a GENSYM atom. (@B[RECORD]@ @ <recordname>@ @ (<name@-[1]>@ <sd@-[1]>)@ @ ...@ @ (<name@-[n]>@ <sd@-[n]>)) @* RECORD specifies the use of contiguous records for data storage. <recordname> is the name of the record type; it is optional, and is not used in some Lisp dialects.@Foot[RECORDs are implemented using RECORDs in Interlisp, HUNKs in Maclisp and Franz Lisp, VECTORs in Portable Standard Lisp, and lists in UCI Lisp and ELISP. In Interlisp, appropriate RECORD declarations must be made to the system by the user in addition to the GLISP declarations.] (@B[TRANSPARENT]@ @ <type>) @* An object of type <type> is incorporated into the structure being defined in @I[transparent mode], which means that all fields and properties of the object of type <type> can be directly referenced as if they were properties of the object being defined. A substructure which is a named @I[ type ] and which is not declared to be TRANSPARENT is assumed to be opaque, i.e., its internal structure cannot be seen unless an access path explicitly names the subrecord.@Foot{For example, a PROFESSOR record might contain some fields which are unique to professors, plus a pointer to an EMPLOYEE record. If the declaration in the PROFESSOR record were @PE[(EMPREC@ (TRANSPARENT@ EMPLOYEE))], then a field of the employee record, say SALARY, could be referenced directly from a variable P which points to a PROFESSOR record as @PE[ P:SALARY ]; if the declaration were @PE[(EMPREC@ EMPLOYEE)], it would be necessary to say @PE[P:EMPREC:SALARY].} The object of type <type> may also contain TRANSPARENT objects; the graph of TRANSPARENT object references must of course be acyclic. (@B[OBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*(@B[ATOMOBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*(@B[LISTOBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*These declarations describe @I[ Objects ], data structures which can receive messages at runtime. The three types of objects are implemented as records, atoms, or lists, respectively. In each case, the system adds to the object a @PE[CLASS] datum which points to the name of the type of the object. An object declaration may only appear as the top-level declaration of a named object type. @End(Enumerate) @End(Enumerate) @Subsection(Examples of Structure Descriptions) The following examples illustrate the use of Structure Descriptions. @Begin(ProgramExample) (GLISPOBJECTS (CAT (LIST (NAME ATOM) (PROPERTIES (LIST (CONS (SEX ATOM) (WEIGHT INTEGER)) (AGE INTEGER) (COLOR ATOM))) (LIKESCATNIP BOOLEAN))) (PERSON (ATOM (PROPLIST (CHILDREN (LISTOF (A PERSON))) (AGE INTEGER) (PETS (LIST (CATS (LISTOF CAT)) (DOGS (LISTOF (A DOG))) )) ))) ) @End(ProgramExample) The first structure, CAT, is entirely composed of list structure. An CAT structure might look like: @Begin(ProgramExample) (PUFF ((MALE . 10) 5 CALICO) T) @End(ProgramExample) Given a CAT object X, we could ask for its WEIGHT [equivalent to (CDAADR X)] or for a subrecord such as PROPERTIES [equivalent to (CADR X)]. Having set a variable Y to the PROPERTIES, we could also ask for the WEIGHT from Y [equivalent to (CDAR Y)]. In general, whenever a subrecord is accessed, the structure description of the subrecord is associated with it by the compiler, enabling further accesses to parts of the subrecord. Thus, the meaning of a subrecord name depends on the type of record from which the subrecord is retrieved. The subrecord AGE has two different meanings when applied to PERSONs and CATs. The second structure, PERSON, illustrates a description of an object which is a Lisp atom with properties stored on its property list. Whereas no structure names appear in an actual CAT structure, the substructures of a PROPLIST operator must be named, and the names appear in the actual structures. For example, if X is a PERSON structure, retrieval of the AGE of X is equivalent to @PE[(GETPROP@ X@ 'AGE)]. A subrecord of a PROPLIST record can be referenced directly; e.g., one can ask for the DOGS of a PERSON directly, without cognizance of the fact that DOGS is part of the PETS property. @Section(Editing of Object Descriptions) An object description can be edited by calling @PE[ (GLEDS TYPE) ], where @PE[ TYPE ] is the name of the object type. This will cause the Lisp editor to be called on the object description of @PE[ TYPE ]. @Section(Interactive Editing of Objects) An interactive structure inspector/editor, GEV, is available for the Xerox 1100-series lisp machines. GEV allows the user to inspect and edit any structures which are described by GLISP object descriptions, to "zoom in" on substructures of interest, and to display the values of computed properties automatically or on demand. GEV is described in a separate document. @Section(Global Variables) The types of free variables can be declared within the functions which reference them. Alternatively, the types of global variables can be declared to the compiler using the form:@Foot[@PE{(GLISPGLOBALS@ <name@-(1)>@ ...@ <name@-(n)>)} is defined as a file package command for Interlisp.] @Begin(ProgramExample) (GLISPGLOBALS (<name> <type>) ... ) @End(ProgramExample) Following such a declaration, the compiler will assume a free variable <name> is of the corresponding <type>. A GLOBAL object does not have to actually exist as a storage structure; for example, one could define a global object "MOUSE" or "SYSTEM" whose properties are actually implemented by calls to the operating system. @Section(Compile-Time Constants and Conditional Compilation) The values and types of compile-time constants can be declared to the compiler using the form:@Foot[@PE{(GLISPCONSTANTS@ <name@-(1)>@ ...@ <name@-(n)>)} is defined as a file package command for Interlisp.] @Programexample[ (GLISPCONSTANTS (<name> <value-expression> <type>) ... ) ] The <name> and <type> fields are assumed to be quoted. The @PE[ <value-expression> ] field is a GLISP expression which is parsed and evaluated; this allows constants to be defined by expressions involving previously defined constants. The GLISP compiler will perform many kinds of computations on constants at compile time, reducing the size of the compiled code and improving execution speed.@Foot[Ordinary Lisp functions are evaluated on constant arguments if the property @PE(GLEVALWHENCONST) is set to T on the property list of the function name. This property is set by the compiler for the basic arithmetic functions.] In particular, arithmetic, comparison, logical, conditional, and CASE function calls are optimized, with elimination of dead code. This permits conditional compilation in a clean form. Code can be written which tests the values of flags in the usual way; if the flag values are then declared to be compile-time constants using GLISPCONSTANTS, the tests will be performed at compile time, and the unneeded code will vanish. @Chapter(Reference To Objects) @Section(Accessing Objects) The problem of reference is the problem of determining what object, or feature of a structured object, is referred to by some part of a statement in a language. Most programming languages solve the problem of reference by unique naming: each distinct object in a program unit has a unique name, and is referenced by that name. Reference to a part of a structured object is done by giving the name of the variable denoting that object and a path specification which tells how to get to the desired part from the whole. GLISP permits reference by unique naming and path specification, but in addition permits @I[definite reference relative to context.] A @I[definite reference] is a reference to an object which has not been explicitly named before, but which can be understood relative to the current context of computation. If, for example, an object of type VECTOR (as defined earlier) is in context, the program statement @Begin(ProgramExample) (IF X IS NEGATIVE ... @End(ProgramExample) contains a definite reference to "X", which may be interpreted as the X substructure of the VECTOR which is in context. The definition of the computational context and the way in which definite references are resolved are covered in a later section of this manual. In the following section, which describes the syntaxes of reference to objects in GLISP, the following notation is used. "<var>" refers to a variable name in the usual LISP sense, i.e., a LAMBDA variable, PROG variable, or GLOBAL variable; the variable is assumed to point to (be bound to) an object. "<type>" refers to the type of object pointed to by a variable. "<property>" refers to a property or subrecord of an object. Two syntaxes are available for reference to objects: an English-like syntax, and a PASCAL-like syntax. The two are equivalent, and may be intermixed freely within a GLISP function. The allowable forms of references in the two syntaxes are shown in the table below. @Begin(Format) @TabDivide(3) @U("PASCAL" Syntax)@\@U("English" Syntax)@\@U(Meaning) <var>@\<var>@\The object denoted @\@\by <var> @B[:]<type>@\@B[The] <type>@\The object whose type @\@\is <type> @B[:]<property>@\@B[The] <property>@\The <property> of @I[or] <property>@\@\some object <var>@B[:]<property>@\@B[The] <property> @B[of] <var>@\The <property> of the @\@\object denoted by <var> @End(Format) These forms can be extended to specify longer paths in the obvious way, as in "The AGE of the SPOUSE of the HEAD of the DEPARTMENT" or "DEPARTMENT:HEAD:SPOUSE:AGE". Note that there is no distinction between reference to substructures and reference to properties as far as the syntax of the referencing code is concerned; this facilitates hiding the internal structures of objects. @Section(Creation of Objects) GLISP allows the creation of structures to be specified by expressions of the form: @BlankSpace(1) @B[(A] <type> @P[with] <property@-[1]> @P[=] <value@-[1]> @P[,] ... @P[,] @~ <property@-[n]> @P[=] <value@-[n]>@B[)] @BlankSpace(1) In this expression, the "@I[with]", "=", and "," are allowed for readability, but may be omitted if desired@Foot[Some Lisp dialects, e.g. Maclisp, will interpret commas as "backquote" commands and generate error messages. In such dialects, the commas must be omitted or be "slashified".]; if present, they must all be delimited on both sides by blanks. In response to such an expression, GLISP will generate code to create a new instance of the specified structure. The <property> names may be specified in any order. Unspecified properties are defaulted according to the following rules: @Begin(Enumerate) Basic types are defaulted to 0 for INTEGER and NUMBER, 0.0 for REAL, and NIL for other types. Composite structures are created from the defaults of their components, except that missing PROPLIST and ALIST items which would default to NIL are omitted. @End(Enumerate) Except for missing PROPLIST and ALIST elements, as noted above, a newly created LISP structure will contain all of the fields specified in its structure description. @Section(Interpretive Creation of Objects) The "A" function is defined for interpretive use as well as for use within GLISP functions. @Section(Predicates on Objects) Adjectives defined for structures using the @PE[ADJ] and @PE[ISA] specifications may be used in predicate expressions on objects in @B[If] and @B[For] statements. The syntax of basic predicate expressions is: @Begin(ProgramExample) <object> @b[is] <adjective> <object> @B[is a] <isa-adjective> @End(ProgramExample) Basic predicate expressions may be combined using AND, OR, NOT or ~, and grouping parentheses. The compiler automatically recognizes the LISP adjectives ATOMIC, NULL, NIL, INTEGER, REAL, ZERO, NUMERIC, NEGATIVE, MINUS, and BOUND, and the ISA-adjectives ATOM, LIST, NUMBER, INTEGER, SYMBOL, STRING, ARRAY, and BIGNUM@Foot[where applicable.]; user definitions have precedence over these pre-defined adjectives. @Subsection(Self-Recognition Adjectives) If the ISA-adjective @PE[ self ] is defined for an object type, the type name may be used as an ISA-adjective to test whether a given object is a member of that type. Given a predicate phrase of the form "@PE[@ X@ is@ a@ Y@ ]", the compiler first looks at the definition of the object type of @PE[ X ] to see if @PE[ Y ] is defined as an ISA-adjective for such objects. If no such ISA-adjective is found, and @PE[ Y ] is a type name, the compiler looks to see if @PE[ self ] is defined as an ISA-adjective for @PE[ Y ], and if so, compiles it. If a @PE[ self ] ISA-adjective predicate is compiled as the test of an @B[If], @B[While], or @B[For] statement, and the tested object is a simple variable, the variable will be known to be of that type within the scope of the test. For example, in the statement @Begin(ProgramExample) (If X is a FOO then (_ X Print) ... @End(ProgramExample) the compiler will know that X is a FOO if the test succeeds, and will compile the Print message appropriate for a FOO, even if the type of X was declared as something other than FOO earlier. This feature is useful in implementing disjunctive types, as discussed in a later section. @Subsection(Testing Object Classes) For those data types which are defined using one of the OBJECT structuring operators, the Class name is automatically defined as an ISA-adjective. The ISA test is implemented by runtime examination of the CLASS datum of the object. @Chapter(GLISP Program Syntax) @Section(Function Syntax) GLISP function syntax is essentially the same as that of LISP with the addition of type information and RESULT and GLOBAL declarations. The basic function syntax is: @Foot[The PROG is not required. In Lisp dialects other than Interlisp, LAMBDA may be used instead of GLAMBDA.] @Begin(ProgramExample) (<function-name> (@B[GLAMBDA] (<arguments>) @P[(RESULT] <result-description>@P[)] @P[(GLOBAL] <global-variable-descriptions>@P[)] (PROG (<prog-variables>) <code> ))) @End(ProgramExample) The RESULT declaration is optional; in many cases, the compiler will infer the result type automatically. The main use of the RESULT declaration is to allow the compiler to determine the result type without compiling the function, which may be useful when compiling another function which calls it. The <result-description> is a standard structure description or <type>. The GLOBAL declaration is used to inform the compiler of the types of free variables. The function GLISPGLOBALS can be used to declare the types of global variables, making GLOBAL declarations within individual functions unnecessary. The major difference between a GLISP function definition and a standard LISP definition is the presence of type declarations for variables, which are in PASCAL-like syntax of the following forms: @Begin(ProgramExample) <variable>@B[:]<type> <variable>@B[:(A] <type>@B[)] <variable>@B[,]<variable>@B[,]...@B[:]<type> <variable>@B[,]<variable>@B[,]...@B[:(A] <type>@B[)] @B[:]<type> @B[(A] <type>@B[)] @End(ProgramExample) In addition to declared <type>s, a Structure Description may be used directly as a <type> in a variable declaration. Type declarations are required only for variables whose subrecords or properties will be referenced. In general, if the value of a variable is computed in such a way that the type of the value can be inferred, the variable will receive the appropriate type automatically; in such cases, no type declaration is necessary. Since GLISP maintains a @I[context] of the computation, it is often unnecessary to name a variable which is an argument of a function; in such cases, it is only necessary to specify the <type> of the argument, as shown in the latter two syntax forms above. PROG and GLOBAL declarations must always specify variable names (with optional types); the ability to directly reference features of objects reduces the number of PROG variables needed in many cases. Initial values for PROG variables may be specified, as in Interlisp, by enclosing the variable and its initial value in a list@Foot[This feature is available in all Lisp dialects.]: @ProgramExample{ (PROG (X (N 0) Y) ...) } However, the syntax of variable declarations does not permit the type of a variable and its initial value to both be specified. @Section(Expressions) GLISP provides translation of infix expressions of the kind usually found in programming languages. In addition, it provides additional operators which facilitate list manipulation and other operations. Overloading of operators for user-defined types is provided by means of the @I[message] facility. Expressions may be written directly in-line within function references, as in @PE[ (SQRT X*X + Y*Y) ], or they may be written within parentheses; parentheses may be used for grouping in the usual way. Operators may be written with or without delimiting spaces, @I[except for the "-" operator, which @P(must) be delimited by spaces]. @Foot[The "-" operator is required to be delimited by spaces since "-" is often used as a hyphen within variable names. The "-" operator will be recognized within "atom" names if the flag GLSEPMINUS is set to T.] Expression parsing is done by an operator precedence parser, using the same precedence ordering as in FORTRAN. @Foot[The precedence of compound operators is higher than assignment but lower than that of all other operators. The operators @PE[^ _ _+ +_ _- -_] are right-associative; all others are left-associative.] The operators which are recognized are as follows:@Foot<In Maclisp, the operator @PE[/] must be written @PE[//].> @Begin(Format) @TabDivide(3) Assignment@\@PE(_) @I[ or ] @PE[:=] Arithmetic@\@PE[+ - * / ^] Comparison@\@PE[= @R<~>= <> < <= > >=] Logical@\@PE[AND OR NOT @R<~>] Compound@\@PE(_+ _- +_ -_) @End(Format) @Subsection(Interpretation of Operators) In addition to the usual interpretation of operators when used with numeric arguments, some of the operators are interpreted appropriately for other Lisp types. @Paragraph(Operations on Strings) For operands of type STRING, the operator @PE[ + ] performs concatenation. All of the comparison operators are defined for STRINGs. @Paragraph(Operations on Lists) Several operators are defined in such a way that they perform set operations on lists of the form @PE[ (LISTOF@ <type>) ], where @PE[ <type> ] is considered to be the element type. The following table shows the interpretations of the operators: @Begin(Format) @Tabdivide(3) @PE[<list> + <list>]@\Set Union @PE[<list> - <list>]@\Set Difference @PE[<list> * <list>]@\Set Intersection @PE[<list> + <element>]@\CONS @PE[<element> + <list>]@\CONS @PE[<list> - <element>]@\REMOVE @PE[<element> <= <list>]@\MEMBER or MEMB @PE[<list> >= <element>]@\MEMBER or MEMB @End(Format) @Paragraph(Compound Operators) Each compound operator performs an operation involving the arguments of the operator and assigns a value to the left-hand argument; compound operators are therefore thought of as "destructive change" operators. The meaning of a compound operator depends on the type of its left-hand argument, as shown in the following table: @Begin(Group) @Begin(Format) @TabDivide(5) @U(Operator)@\@U(Mnemonic)@\@U(NUMBER)@\@U(LISTOF)@\@U(BOOLEAN) @B[@PE(_+)]@\@I(Accumulate)@\PLUS@\NCONC1@\OR @B[@PE(_-)]@\@I(Remove)@\DIFFERENCE@\REMOVE@\AND NOT @B[@PE(+_)]@\@I(Push)@\PLUS@\PUSH@\OR @B[@PE(-_)]@\@I(Pop)@\@\POP@Foot[For the Pop operator, the arguments are in the reverse of the usual order, i.e., (TOP@ @PE(-_)@ STACK) will pop the top element off STACK and assign the element removed to TOP.] @End(Format) @End(Group) As an aid in remembering the list operators, the arrow may be thought of as representing the list, with the head of the arrow being the front of the list and the operation (+ or -) appearing where the operation occurs on the list. Thus, for example, @PE(_+) adds an element at the end of the list, while @PE(+_) adds an element at the front of the list. Each of the compound operators performs an assignment to its left-hand side; the above table shows an abbreviation of the operation which is performed prior to the assignment. The following examples show the effects of the operator "@PE(_+)" on local variables of different types: @Begin(Format) @TabDivide(3) @U(Type)@\@U(Source Code)@\@U(Compiled Code) INTEGER@\@PE(I _+ 5)@\@PE[(SETQ I (IPLUS I 5))] BOOLEAN@\@PE(P _+ Q)@\@PE[(SETQ P (OR P Q))] LISTOF@\@PE(L _+ ITEM)@\@PE[(SETQ L (NCONC1 L ITEM))] @END(Format) When the compound operators are not specifically defined for a type, they are interpreted as specifying the operation (@PE[+] or @PE[-]) on the two operands, followed by assignment of the result to the left-hand operand. @Paragraph(Assignment) Assignment of a value to the left-hand argument of an assignment operator is relatively flexible in GLISP. The following kinds of operands are allowed on the left-hand side of an assignment operator: @Begin(Enumerate) Variables. Stored substructures of a structured type. PROPerties of a structured type, whenever the interpretation of the PROPerty would be a legal left-hand side. Algebraic expressions involving numeric types, @I[ provided ] that the expression ultimately involves only one occurrence of a variable or stored value.@Foot{For example, @PE[(X^2 _ 2.0)] is acceptable, but @PE[(X*X@ _@ 2.0)] is not because the variable @PE[X] occurs twice.} @End(Enumerate) For example, consider the following Object Description for a CIRCLE: @ProgramExample{ (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2))) ) } Given this description, and a CIRCLE @PE[ C ], the following are legal assignments: @Programexample{ (C:RADIUS _ 5.0) (C:AREA _ 100.0) (C:AREA _ C:AREA*2) (C:AREA _+ 100.0) } @Paragraph(Self-Assignment Operators @Foot[This section may be skipped by the casual user of GLISP.]) There are some cases where it would be desirable to let an object perform an assignment of its own value. For example, the user might want to define @I[PropertyList] as an abstract datatype, with messages such as GETPROP and PUTPROP, and use PropertyLists as substructures of other datatypes. However, a message such as PUTPROP may cause the PropertyList object to modify its own structure, perhaps even changing its structure from NIL to a non-NIL value. If the function which implements PUTPROP performs a normal assignment to its "self" variable, the assignment will affect only the local variable, and will not modify the PropertyList component of the containing structure. The purpose of the Self-Assignment Operators is to allow such modification of the value within the containing structure. The Self-Assignment Operators are @PE[__], @PE[__+], @PE[_+_], and @PE[__-], corresponding to the operators @PE[_], @PE[_+], @PE[+_], and @PE[_-], respectively. The meaning of these operators is that the assignment is performed to the object on the left-hand side of the operator, @I[as seen from the structure containing the object]. The use of these operators is highly restricted; any use of a Self-Assignment Operator must meet all of the following conditions: @Begin(Enumerate) A Self-Assignment Operator can only be used within a Message function which is compiled OPEN. The left-hand side of the assignment must be a simple variable which is an argument of the function. The left-hand-side variable must be given a unique (unusual) name to prevent accidental aliasing with a user variable name. @End(Enumerate) As an example, the PUTPROP message for a PropertyList datatype could be implemented as follows: @Begin(ProgramExample) (PropertyList.PUTPROP (GLAMBDA (PropertyListPUTPROPself prop val) (PropertyListPUTPROPself __ (LISTPUT PropertyListPUTPROPself prop val)) )) @End(ProgramExample) @Section(Control Statements) GLISP provides several PASCAL-like control statements. @Subsection(IF Statement) The syntax of the IF statement is as follows: @Begin(ProgramExample) (@B[IF] <condition@-[1]> @P[THEN] <action@-[11]>@ ...@ <action@-[1i]> @P[ELSEIF] <condition@-[2]> @P[THEN] <action@-[21]>@ ...@ <action@-[2j]> ... @P[ELSE] <action@-[m1]>@ ...@ <action@-[mk]>) @End(ProgramExample) Such a statement is translated to a COND of the obvious form. The "THEN" keyword is optional, as are the "ELSEIF" and "ELSE" clauses. @Subsection(CASE Statement) The CASE statement selects a set of actions based on an atomic selector value; its syntax is: @Begin(ProgramExample) (@B[CASE] <selector> @B[OF] (<case@-[1]> <action@-[11]>@ ...@ <action@-[1i]>) (<case@-[2]> <action@-[21]>@ ...@ <action@-[2j]>) ... @P[ELSE] <action@-[m1]>@ ...@ <action@-[mk]>) @End(ProgramExample) The @PE[<selector>] is evaluated, and is compared with the given @PE[<case>] specifications. Each @PE[<case>] specification is either a single, atomic specification, or a list of atomic specifications. All @PE[<case>] specifications are assumed to be quoted. The "ELSE" clause is optional; the "ELSE" actions are executed if @PE[<selector>] does not match any @PE[<case>]. If the @I[ type ] of the @PE[<selector>] has a VALUES specification, @PE[<case>] specifications which match the VALUES for that type will be translated into the corresponding values. @Subsection(FOR Statement) The FOR statement generates a loop through a set of elements (typically a list). Two syntaxes of the FOR statement are provided: @Begin(ProgramExample) (@B[FOR EACH] <set> @P[DO] <action@-[1]>@ ...@ <action@-[n]>) (@B[FOR] <variable> @B[IN] <set> @P[DO] <action@-[1]>@ ...@ <action@-[n]>) @End(ProgramExample) The keyword "DO" is optional. In the first form of the FOR statement, the singular form of the <set> is specified; GLISP will convert the given set name to the plural form. @Foot[For names with irregular plurals, the plural form should be put on the property list of the singular form under the property name PLURAL, e.g., @PE<(PUTPROP 'MAN 'PLURAL 'MEN)>.] The <set> may be qualified by an adjective or predicate phrase in the first form; the allowable syntaxes for such qualifying phrases are shown below: @Begin(ProgramExample) <set> @B[WITH] <predicate> <set> @B[WHICH IS] <adjective> <set> @B[WHO IS] <adjective> <set> @B[THAT IS] <adjective> @End(ProgramExample) The <predicate> and <adjective> phrases may be combined with AND, OR, NOT, and grouping parentheses. These phrases may be followed by a qualifying phrase of the form: @Begin(ProgramExample) @B[WHEN] <expression> @End(ProgramExample) The "WHEN" expression is ANDed with the other qualifying expressions to determine when the loop body will be executed. Within the FOR loop, the current member of the <set> which is being examined is automatically put into @I[context] at the highest level of priority. For example, suppose that the current context contains a substructure whose description is: @Begin(ProgramExample) (PLUMBERS (LISTOF EMPLOYEE)) @END(ProgramExample) Assuming that EMPLOYEE contains the appropriate definitions, the following FOR loop could be written: @Begin(ProgramExample) (FOR EACH PLUMBER WHO IS NOT A TRAINEE DO SALARY _+ 1.50) @End(ProgramExample) To simplify the collection of features of a group of objects, the <action>s in the FOR loop may be replaced by the CLISP-like construct: @Begin(ProgramExample) ... @B[COLLECT] <form>) @End(ProgramExample) @Subsection(WHILE Statement) The format of the WHILE statement is as follows: @Begin(ProgramExample) (@B[WHILE] <condition> @B[DO] <action@-[1]> ... <action@-[n]>) @End(ProgramExample) The actions @PE(<action@-[1]>) through @PE(<action@-[n]>) are executed repeatedly as long as @PE(<condition>) is true. The keyword @B[DO] may be omitted. The value of the expression is NIL. @Subsection(REPEAT Statement) The format of the REPEAT statement is as follows: @Begin(ProgramExample) (@B[REPEAT] <action@-[1]> ... <action@-[n]> @B[UNTIL] <condition>) @End(ProgramExample) The actions @PE(<action@-[1]>) through @PE(<action@-[n]>) are repeated (always at least once) until @PE[<condition>] is true. The value of the expression is NIL. The keyword @B[UNTIL] is required. @Section(Definite Reference to Particular Objects) In order to simplify reference to particular member(s) of a group, definite reference may be used. Such an expression is written using the word @B[THE] followed by the singular form of the group, or @B[THOSE] followed by the plural form of the group, and qualifying phrases (as described for the @B[FOR] statement). The following examples illustrate these expressions. @Begin(ProgramExample) (THE SLOT WITH SLOTNAME = NAME) (THOSE EMPLOYEES WITH JOBTITLE = 'ELECTRICIAN) @End(ProgramExample) The value of @B[THE] is a single object (or NIL if no object satisfies the specified conditions); @B[THOSE] produces a list of all objects satisfying the conditions.@Foot[In general, nested loops are optimized so that intermediate lists are not actually constructed. Therefore, use of nested THE or THOSE statements is not inefficient.] @Chapter(Messages) GLISP supports the @I[Message] metaphor, which has its roots in the languages SIMULA and SMALLTALK. These languages provide @I[Object-Centered Programming], in which objects are thought of as being active entities which communicate by sending each other @I[Messages]. The internal structures of objects are hidden; a program which wishes to access "variables" of an object does so by sending messages to the object requesting the access desired. Each object contains @Foot[typically by inheritance from some parent in a Class hierarchy] a list of @I[Selectors], which identify the messages to which the object can respond. A @I[Message] specifies the destination object, the selector, and any arguments associated with the message. When a message is executed at runtime, the selector is looked up for the destination object; associated with the selector is a procedure, which is executed with the destination object and message arguments as its arguments. GLISP treats reference to properties, adjectives, and predicates associated with an object similarly to the way it treats messages. The compiler is able to perform much of the lookup of @I[selectors] at compile time, resulting in efficient code while maintaining the flexibility of the message metaphor. Messages can be defined in such a way that they compile open, compile as function calls to the function which is associated with the selector, or compile as messages to be interpreted at runtime. Sending of a @I[message] in GLISP is specified using the following syntax: @Begin(ProgramExample) @B[(SEND] <object> <selector> <arg@-[1]>@ ...@ <arg@-[n]>@B[)] @End(ProgramExample) The keyword "SEND" may be replaced by "@B[@PE(_)]". The @PE[<selector>] is assumed to be quoted. Zero or more arguments may be specified; the arguments other than @PE[<selector>] are evaluated. @PE[<object>] is evaluated; if @PE[<object>] is a non-atomic expression, it must be enclosed in at least one set of parantheses, so that the @PE[<selector>] will always be the third element of the list. @SECTION(Compilation of Messages) When GLISP encounters a message statement, it looks up the <selector> in the MSG definition of the type of the object to which the message is sent, or in one of the SUPERS of the type. @Foot[If an appropriate representation language is provided, the <selector> and its associated <response> may be inherited from a parent class in the class hierarchy of the representation language.] Each <selector> is paired with the appropriate <response> to the message. Code is compiled depending on the form of the <response> associated with the <selector>, as follows: @Foot[If the type of the destination object is unknown, or if the <selector> cannot be found, GLISP compiles the (SEND@ ...) statement as if it is a normal function call.] @Begin(Enumerate) If the <response> is an atom, that atom is taken as the name of a function which is to be called in response to the message. The code which is compiled is a direct call to this function, @Begin(ProgramExample) (<response> <object> <arg@-[1]> ... <arg@-[n]>) @End(ProgramExample) If the <response> is a list, the contents of the list are recursively compiled in-line as GLISP code, with the name "@PE[self]" artificially "bound" to the <object> to which the message was sent. Because the compilation is recursive, a message may be defined in terms of other messages, substructures, or properties, which may themselves be defined as messages. @Foot[Such recursive definitions must of course be acyclic.] The outer pair of parentheses of the <response> serves only to bound its contents; thus, if the <response> is a function call, the function call must be enclosed in an additional set of parentheses. @End(Enumerate) The following examples illustrate the various ways of defining message responses. @Begin(ProgramExample) (EDIT EDITV) (SUCCESSOR (self + 1)) (MAGNITUDE ((SQRT X*X + Y*Y))) @End(ProgramExample) In the first example, a message with <selector> EDIT is compiled as a direct call to the function EDITV. In the second example, the SUCCESSOR message is compiled as the sum of the object receiving the message (represented by "@PE[self]") and the constant 1; if the object receiving the message is the value of the variable J and has the type INTEGER, the code generated for the SUCCESSOR would be @PE[(ADD1 J)]. The third example illustrates a call to a function, SQRT, with arguments containing definite references to X and Y (which presumably are defined as part of the object whose MAGNITUDE is sought). Note that since MAGNITUDE is defined by a function call, an "extra" pair of parentheses is required around the function call to distinguish it from in-line code. The user can determine whether a message is to be compiled open, compiled as a function call, or compiled as a message which is to be executed at runtime. When a GLISP expression is specified as a <response>, the <response> is always compiled open; open compilation can be requested by using the OPEN property when the <response> is a function name. Open compilation operates like macro expansion; since the "macro" is a GLISP expression, it is easy to define messages and properties in terms of other messages and properties. The combined capabilities of open compilation, message inheritance, conditional compilation, and flexible assignment provide a great deal of power. The ability to use definite reference in GLISP makes the definition and use of the "macros" simple and natural. @Section(Compilation of Properties and Adjectives) Properties, Adjectives, and ISA-adjectives are compiled in the same way as Messages. Since the syntax of use of properties and adjectives does not permit specification of any arguments, the only argument available to code or a function which implements the @PE[<response>] for a property or adjective is the @PE[ self ] argument, which denotes the object to which the property or adjective applies. A @PE[<response>] which is written directly as GLISP code may use the name @PE[ self ] directly @Foot[The name @PE< self > is "declared" by the compiler, and does not have to be specified in the Structure Description.], as in the SUCCESSOR example above; a function which is specified as the @PE[<response>] will be called with the @PE[self] object as its single argument. @Section(Declarations for Message Compilation) Declarations which affect compilation of Messages, Adjectives, or Properties may be specified following the <response> for a given message; such declarations are in (Interlisp) property-list format, @PE[<prop@-[1]><value@-[1]>@ ...@ <prop@-[n]><value@-[n]>]. The following declarations may be specified: @Begin(Enumerate) @B[RESULT]@PE[ <type>] @* This declaration specifies the @I[type] of the result of the message or other property. Specification of result types helps the compiler to perform type inference, thus reducing the number of type declarations needed in user programs. The RESULT type for simple GLISP expressions will be inferred by the compiler; the RESULT declaration should be used if the @PE[<response>] is a complex GLISP expression or a function name. @Foot[Alternatively, the result of a function may be specified by the RESULT declaration within the function itself.]@ @B[OPEN@ @ T] @* This declaration specifies that the function which is specified as the <response> is to be compiled open at each reference. A <response> which is a list of GLISP code is always compiled open; however, such a <response> can have only the @PE[self] argument. If it is desired to compile open a Message <response> which has arguments besides @PE[self], the <response> must be coded as a function (in order to bind the arguments) and the OPEN declaration must be used. Functions which are compiled open may not be recursive via any chain of open-compiled functions. @B[MESSAGE@ @ T] @* This declaration specifies that a runtime message should be generated for messages with this <selector> sent to objects of this Class. Typically, such a declaration would be used in a higher-level Class whose subclasses have different responses to the same message <selector>. @End(Enumerate) @Section(Operator Overloading) GLISP provides operator overloading for user-defined objects using the Message facility. If an arithmetic operator is defined as the @I[selector] of a message for a user datatype, an arithmetic subexpression using that operator will be compiled as if it were a message call with two arguments. For example, the type VECTOR might have the declaration and function definitions below: @Begin(ProgramExample) (GLISPOBJECTS (VECTOR (CONS (X INTEGER) (Y INTEGER)) MSG ((+ VECTORPLUS OPEN T) (_+ VECTORINCR OPEN T)) ) ) (DEFINEQ (VECTORPLUS (GLAMBDA (U,V:VECTOR) (A VECTOR WITH X = U:X + V:X , Y = U:Y + V:Y) )) (VECTORINCR (GLAMBDA (U,V:VECTOR) (U:X _+ V:X) (U:Y _+ V:Y) )) ) @End(ProgramExample) With these definitions, an expression involving the operators @PE[+] or @PE[_+] will be compiled by open compilation of the respective functions. The compound operators (@PE[_+ +_ _- -_]) are conventionally thought of as "destructive replacement" operators; thus, the expression @PE[(U@ _@ U@ +@ V)] will create a new VECTOR structure and assign the new structure to U, while the expression @PE[(U@ _+@ V)] will smash the existing structure U, given the definitions above. The convention of letting the compound operators specify "destructive replacement" allows the user to specify both the destructive and non-destructive cases. However, if the compound operators are not overloaded but the arithmetic operators @PE[+] and @PE[-] are overloaded, the compound operators are compiled using the definitions of @PE[+] for @PE[_+] and @PE[+_], and @PE[-] for @PE[_-] and @PE[-_]. Thus, if only the @PE[+] operator were overloaded for VECTOR, the expression @PE[(U@ _+@ V)] would be compiled as if it were @PE[(U@ _@ U@ +@ V)]. @Section(Runtime Interpretation of Messages) In some cases, the type of the object which will receive a given message is not known at compile time; in such cases, the message must be executed interpretively, at runtime. Interpretive execution is provided for all types of GLISP messages. An interpretive message call (i.e., a call to the function @PE[SEND]) is generated by the GLISP compiler in response to a message call in a GLISP program when the specified message selector cannot be found for the declared type of the object receiving the message, or when the MESSAGE flag is set for that selector. Alternatively, a call to SEND may be entered interactively by the user or may be contained in a function which has not been compiled by GLISP. Messages can be interpreted only for those objects which are represented as one of the OBJECT types, since it is necessary that the object contain a pointer to its CLASS. The <selector> of the message is looked up in the MSG declarations of the CLASS; if it is not found there, the SUPERS of the CLASS are examined (depth-first) until the selector is found. The <response> associated with the <selector> is then examined. If the <response> is a function name, that function is simply called with the specified arguments.@Foot{The object to which the message is sent is always inserted as the first argument, followed by the other arguments specified in the message call.} If the <response> is a GLISP expression, the expression is compiled as a LAMBDA form and cached for future use. Interpretive execution is available for other property types (PROP, ADJ, and ISA) using the call: @Programexample[ (SENDPROP <object> <selector> <proptype>) ] where @PE[<proptype>] is PROP, ADJ, or ISA. @PE[<proptype>] is not evaluated. @Chapter(Context Rules and Reference) The ability to use definite reference to features of objects which are in @I[Context] is the key to much of GLISP's power. At the same time, definite reference introduces the possibility of ambiguity, i.e., there could be more than one object in Context which has a feature with a specified name. In this chapter, guidelines are presented for use of definite reference to allow the user to avoid ambiguity. @Section(Organization of Context) The Context maintained by the compiler is organized in levels, each of which may have multiple entries; the sequence of levels is a stack. Searching of the Context proceeds from the top (nearest) level of the stack to the bottom (farthest) level. The bottom level of the stack is composed of the LAMBDA variables of the function being compiled. New levels are added to the Context in the following cases: @Begin(Enumerate) When a PROG is compiled. The PROG variables are added to the new level. When a @B[For] loop is compiled. The "loop index" variable (which may be either a user variable or a compiler variable) is added to the new level, so that it is in context during the loop. When a @B[While] loop is compiled. When a new clause of an @B[If] statement is compiled. @End(Enumerate) When a Message, Property, or Adjective is compiled, that compilation takes place in a @I[ new ] context consisting only of the @PE[ self ] argument and other message arguments. @Section(Rules for Using Definite Reference) The possibility of referential ambiguity is easily controlled in practice. First, it should be noted that the traditional methods of unique naming and complete path specification ("PASCAL style") are available, and should be used whenever there is any possibility of ambiguity. Second, there are several cases which are guaranteed to be unambiguous: @Begin(Enumerate) In compiling GLISP code which implements a Message, Property, or Adjective, only the @PE[@ self@ ] argument is in context initially; definite reference to any substructure or property of the object is therefore unambiguous. @Foot[Unless there are duplicated names in the object definition. However, if the same name is used as both a Property and an Adjective, for example, it is not considered a duplicate since Properties and Adjectives are specified by different source language constructs.]@ Within a @B[For] loop, the loop variable is the closest thing in context. In many cases, a function will only have a single structured argument; in such cases, definite reference is unambiguous. @End(Enumerate) If "PASCAL" syntax (or the equivalent English-like form) is used for references other than the above cases, no ambiguities will occur. @Section(Type Inference) In order to interpret definite references to features of objects, the compiler must know the @I[ types ] of the objects. However, explicit type specification can be burdensome, and makes it difficult to change types without rewriting existing type declarations. The GLISP compiler performs type inference in many cases, relieving the programmer of the burden of specifying types explicitly. The following rules enable the programmer to know when types will be inferred by the compiler. @Begin(Enumerate) Whenever a variable is set to a value whose type is known, the type of the variable is inferred to be the type of the value to which it was set. If a variable whose initial type was NIL (e.g., an untyped PROG variable) appears on the left-hand side of the @PE[@ _+@ ] operator, its type is inferred to be @PE[(LISTOF@ <type>)], where @PE[@ <type>@ ] is the type of the right-hand side of the @PE[@ _+@ ] expression. Whenever a substructure of a structured object is retrieved, the type of the substructure is retrieved also. Types of infix expressions are inferred. Types of Properties, Adjectives, and Messages are inferred if: @Begin(Enumerate) The @PE[ <response> ] is GLISP code whose type can be inferred. The @PE[ <response> ] has a RESULT declaration associated with it. The @PE[ <response> ] is a function whose definition includes a RESULT declaration, or whose property list contains a GLRESULTTYPE declaration. @End(Enumerate) The type of the "loop variable" in a @B[For] loop is inferred and is added to a new level of Context by the compiler. If an @B[If] statement tests the type of a variable using a @PE[@ self@ ] adjective, the variable is inferred to be of that type if the test is satisfied. Similar type inference is performed if the test of the type of the variable is the condition of a @B[While] statement. When possible, GLISP infers the type of the function it is compiling and adds the type of the result to the property list of the function name under the indicator GLRESULTTYPE. The types returned by many standard Lisp functions are known by the compiler. @End(Enumerate) @Chapter(GLISP and Knowledge Representation Languages) GLISP provides a convenient @I[Access Language] which allows uniform specification of access to objects, without regard to the way in which the objects are actually stored; in addition, GLISP provides a basic @I[Representation Language], in which the structures and properties of objects can be declared. The field of Artificial Intelligence has spawned a number of powerful Representation Languages, which provide power in describing large numbers of object classes by allowing hierarchies of @I[Class] descriptions, in which instances of Classes can inherit properties and procedures from parent Classes. The @I[Access Languages] provided for these Representation Languages, however, have typically been rudimentary, often being no more than variations of LISP's GETPROP and PUTPROP. In addition, by performing inheritance of procedures and data values at runtime, these Representation Languages have often been computationally costly. Facilities are provided for interfacing GLISP with representation languages of the user's choice. When this is done, GLISP provides a convenient and uniform language for accessing both objects in the Representation Language and LISP objects. In addition, GLISP can greatly improve the efficiency of programs which access the representations by performing lookup of procedures and data in the Class hierarchy @I[at compile time]. Finally, a LISP structure can be specified @I[as the way of implementing] instances of a Class in the Representation Language, so that while the objects in such a class appear the same as other objects in the Representation Language and are accessed in the same way, they are actually implemented as LISP objects which are efficient in both time and storage. A clean @Foot[Cleanliness is in the eye of the beholder and, being next to Godliness, difficult to attain. However, it's @I(relatively) clean.] interface between GLISP and a Representation Language is provided. With such an interface, each @I[Class] in the Representation Language is acceptable as a GLISP @I[type]. When the program which is being compiled specifies an access to an object which is known to be a member of some Class, the interface module for the Representation Language is called to generate code to perform the access. The interface module can perform inheritance within the Class hierarchy, and can call GLISP compiler functions to compile code for subexpressions. Properties, Adjectives, and Messages in GLISP format can be added to Class definitions, and can be inherited by subclasses at compile time. In an Object-Centered representation language or other representation language which relies heavily on procedural inheritance, substantial improvements in execution speed can be achieved by performing the inheritance lookup at compile time and compiling direct procedure calls to inherited procedures when the procedures are static and the type of the object which inherits the procedure is known at compile time. Specifications for an interface module for GLISP are contained in a separate document@Foot[to be written.]. To date, GLISP has been interfaced to our own GIRL representation language, and to LOOPS. @Foot[LOOPS, a LISP Object Oriented Programming System, is being developed at Xerox Palo Alto Research Center by Dan Bobrow and yMark Stefik.] @Chapter(Obtaining and Using GLISP) GLISP and its documentation are available free of charge over the ARPANET. The host computers involved will accept the login "ANONYMOUS GUEST" for transferring files with FTP. @Section(Documentation) This user's manual, in line-printer format, is contained in @PE([UTEXAS-20]<CS.NOVAK>GLUSER.LPT) . The SCRIBE source file is @PE([SU-SCORE]<CSD.NOVAK>GLUSER.MSS) . Printed copies of this manual can be ordered from Publications Coordinator, Computer Science Department, Stanford University, Stanford, CA 94305, as technical report STAN-CS-82-895 ($3.15 prepaid); the printed version may not be as up-to-date as the on-line version. @Section(Compiler Files) There are two files, GLISP (the compiler itself) and GLTEST (a file of examples). The files for the different Lisp dialects are: @Tabset(1.4 inch) @Begin(Format) Interlisp:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.LSP) and @PE(GLTEST.LSP) Maclisp:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.MAC) and @PE(GLTEST.MAC) UCI Lisp:@\@PE([UTEXAS-20]<CS.NOVAK>GLISP.UCI) and @PE(GLTEST.UCI) ELISP:@\the UCI version plus @PE([UTEXAS-20]<CS.NOVAK>ELISP.FIX) Franz Lisp:@\@PE([SUMEX-AIM]<NOVAK>GLISP.FRANZ) and @PE(GLTEST.FRANZ) PSL:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.PSL) and @PE(GLTEST.PSL) @End(Format) @Section(Getting Started) Useful functions for invoking GLISP are: @Begin(Format) @PE[(GLCC 'FN)]@\Compile FN. @PE[(GLCP 'FN)]@\Compile FN and prettyprint result. @PE[(GLP 'FN)]@\Prettyprint GLISP-compiled version of FN. @PE[(GLED 'NAME)]@\Edit the property list of NAME. @PE[(GLEDF 'FN)]@\Edit the original (GLISP) definition of FN. @\(The original definition is saved under the property @\"GLORIGINALEXPR" when the function is compiled, and @\the compiled version replaces the function @\definition.) @PE[(GLEDS 'STR)]@\Edit the structure declarations of STR. @End(Format) The editing functions call the "BBN/Interlisp" structure editor. To try out GLISP, load the GLTEST file and use GLCP to compile the functions CURRENTDATE, GIVE-RAISE, TESTFN1, TESTFN2, DRAWRECT, TP, GROWCIRCLE, and SQUASH. To run compiled functions on test data, do: @Begin(ProgramExample) (GIVE-RAISE 'COMPANY1) (TP '(((A (B (C D (E (G H (I J (K)))))))))) (GROWCIRCLE MYCIRCLE) @END(ProgramExample) @Section(Reserved Words and Characters) GLISP contains ordinary lisp as a sublanguage. However, in order to avoid having code which was intended as "ordinary lisp" interpreted as GLISP code, it is necessary to follow certain conventions when writing "ordinary lisp" code. @Subsection(Reserved Characters) The colon and the characters which represent the arithmetic operators should not be used within atom names, since GLISP splits apart "atoms" which contain operators. The set of characters to be avoided within atom names is: @Programexample{ + * / ^ _ ~ = < > : ' , } The character "minus" (@PE[ - ]) is permitted within atom names unless the flag @PE[GLSEPMINUS] is set. Some GLISP constructs permit (but do not require) use of the character "comma" (@PE[ , ]); since the comma is used as a "backquote" character in some Lisp dialects, the user may wish to avoid its use. When used in Lisp dialects which use comma as a backquote character, all commas must be "escaped" or "slashified"; this makes porting of GLISP code containing commas more difficult. @Subsection(Reserved Function Names) Most GLISP function, variable, and property names begin with "@PE[GL]" to avoid conflict with user names. Those "function" names which are used in GLISP constructs or in interpretive functions should be avoided. This set includes the following names: @Programexample{ A AN CASE FOR IF REPEAT SEND SENDPROP THE WHILE } @SUBSECTION(Other Reserved Names) Words which are used within GLISP constructs should be avoided as variable names. This set of names includes: @ProgramExample{ A AN DO ELSE ELSEIF IS OF THE THEN UNTIL } @SECTION(Lisp Dialect Idiosyncrasies) GLISP code passes through the Lisp reader before it is seen by GLISP. For this reason, operators in expressions may need to be set off from operands by blanks; the operator "@PE[-]" should always be surrounded by blanks, and the operator "@PE[+]" should be separated from numbers by blanks. @Subsection(Interlisp) GLISP compilation happens automatically, and usually does not need to be invoked explicitly. GLISP declarations are integrated with the file package. @Subsection(UCI Lisp) The following command is needed before loading to make room for GLISP: @ProgramExample[(REALLOC 3000 1000 1000 1000 35000)] The compiler file modifies the syntax of the character @B[~] to be "alphabetic" so it can be used as a GLISP operator. The character "@PE[/]" must be "slashified" to "@PE[//]". @Subsection(ELISP) For ELISP, the UCI Lisp version of the compiler is used, together with a small compatibility file. The above comments about UCI lisp do not apply to ELISP. The characters "@PE[/]" and "@PE[,]" must be "slashified" to "@PE[//]" and "@PE[/,]". @Subsection(Maclisp) The characters "@PE[/]" and "@PE[,]" must be "slashified" to "@PE[//]" and "@PE[/,]". @Subsection(Franz Lisp) Automatic compilation is implemented for Franz Lisp. The character "@PE[,]" and the operators "@PE[+_]" and "@PE[-_]" must be "slashified" to "@PE[\,]", "@PE[+\_]", and "@PE[-\_]", respectively. Before loading GLISP, edit something to cause the editor files to be loaded@Foot[Some versions of the "CMU editor" contain function definitions which may conflict with those of GLISP; if the editor is loaded first, the GLISP versions override.]. The Franz Lisp version of GLISP has been tested on Opus 38 Franz Lisp; users with earlier versions of Franz might encounter difficulties. @Section(Bug Reports and Mailing List) To get on the GLISP mailing list or to report bugs, send mail to CSD.NOVAK@@SU-SCORE. @Chapter(GLISP Hacks) This chapter discusses some ways of doing things in GLISP which might not be entirely obvious at first glance. @Section(Overloading Basic Types) GLISP provides the ability to define properties of structures described in the Structure Description language; since the elementary LISP types are structures in this language, objects whose storage representation is an elementary type can be "overloaded" by specifying properties and operators for them. The following examples illustrate how this can be done. @Begin(ProgramExample) (GLDEFSTRQ (ArithmeticOperator (self ATOM) PROP ((Precedence OperatorPrecedenceFn RESULT INTEGER) (PrintForm ((GETPROP self 'PRINTFORM) or self)) ) MSG ((PRIN1 ((PRIN1 the PrintForm)))) ) (IntegerMod7 (self INTEGER) PROP ((Modulus (7)) (Inverse ((If self is ZERO then 0 else (Modulus - self))) )) ADJ ((Even ((ZEROP (LOGAND self 1)))) (Odd (NOT Even))) ISA ((Prime PrimeTestFn)) MSG ((+ IMod7Plus OPEN T RESULT IntegerMod7) (_ IMod7Store OPEN T RESULT IntegerMod7)) ) ) (DEFINEQ (IMod7Store (GLAMBDA (LHS:IntegerMod7 RHS:INTEGER) (LHS:self __ (IREMAINDER RHS Modulus)) )) (IMod7Plus (GLAMBDA (X,Y:IntegerMod7) (IREMAINDER (X:self + Y:self) X:Modulus) )) ) @End(ProgramExample) A few subtleties of the function IMod7Store are worth noting. First, the left-hand-side expression used in storing the result is LHS:self rather than simply LHS. LHS and LHS:self of course refer to the same actual structure; however, the @I[type] of LHS is IntegerMod7, while the type of LHS:self is INTEGER. If LHS were used on the left-hand side, since the @PE[ _ ] operator is overloaded for IntegerMod7, the function IMod7Store would be invoked again to perform its own function; since the function is compiled OPEN, this would be an infinite loop. A second subtlety is that the assignment to LHS:self must use the self-assignment operator, @PE[@ __@ ], since it is desired to perform assignment as seen "outside" the function IMod7Store, i.e., in the environment in which the original assignment operation was specified. @Section(Disjunctive Types) LISP programming often involves objects which may in fact be of different types, but which are for some purposes treated alike. For example, LISP data structures are typically constructed of CONS cells whose fields may point to other CONS cells or to ATOMs. The GLISP Structure Description language does not permit the user to specify that a certain field of a structure is a CONS cell @P[or] an ATOM. However, it is possible to create a GLISP datatype which encompasses both. Typically, this is done by declaring the structure of the object to be the complex structure, and testing for the simpler structure explicitly. This is illustrated for the case of the LISP tree below. @Begin(ProgramExample) (LISPTREE (CONS (CAR LISPTREE) (CDR LISPTREE)) ADJ ((EMPTY (@R<~>self))) PROP ((LEFTSON ((If self is ATOMIC then NIL else CAR))) (RIGHTSON ((If self is ATOMIC then NIL else CDR))))) @End(ProgramExample) @Section(Generators) Often, one would like to define such properties of an object as the way of enumerating its parts in some order. Such things cannot be specified directly as properties of the object because they depend on the previous state of the enumeration. However, it is possible to define an object, associated with the original datatype, which contains the state of the enumeration and responds to Messages. This is illustrated below by an object which searches a tree in Preorder. @Begin(ProgramExample) (PreorderSearchRecord (CONS (Node LISPTREE) (PreviousNodes (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (If TMP_Node:LEFTSON then (If Node:RIGHTSON then PreviousNodes+_Node) Node_TMP else TMP-_PreviousNodes Node_TMP:RIGHTSON) )))) (TP (GLAMBDA ((A LISPTREE)) (PROG (PSR) (PSR _ (A PreorderSearchRecord with Node = (the LISPTREE))) (While Node (If Node is ATOMIC (PRINT Node)) (_ PSR NEXT)) ))) @End(ProgramExample) The object class PreorderSearchRecord serves two purposes: it holds the state of the enumeration, and it responds to messages to step through the enumeration. With these definitions, it is easy to write a program involving enumeration of a LISPTREE, as illustrated by the example function TP above. By being open-compiled, messages to an object can be as efficient as in-line hand coding; yet, the code for the messages only has to be written once, and can easily be changed without changing the programs which use the messages. @Chapter(Program Examples) In this chapter, examples of GLISP object declarations and programs are presented. Each example is discussed as a section of this chapter; the code for the examples and the code produced by the compiler are shown for each example at the end of the chapter. @Section(GLTST1 File) The GLTST1 file illustrates the use of several types of LISP structures, and the use of fairly complex Property definitions for objects. SENIORITY of an EMPLOYEE, for example, is defined in terms of the YEAR of DATE-HIRED, which is a substructure of EMPLOYEE, and the YEAR of the function (CURRENTDATE). @Foot[The @I<type> of (CURRENTDATE) must be known to the compiler, either by compiling it first, or by including a RESULT declaration in the function definition of CURRENTDATE, or by specifying the GLRESULTTYPE property for the function name.] @Section(GLTST2 File) The GLTST2 file illustrates the use of Messages for ordinary LISP objects. By defining the arithmetic operators as Message selectors for the object VECTOR, use of vectors in arithmetic expressions is enabled; OPEN compilation is specified for these messages. The definition of GRAPHICSOBJECT uses VECTORs as components. While the actual structure of a GRAPHICSOBJECT is simple, numerous properties are defined for user convenience. The definition of CENTER is easily stated as a VECTOR expression. The Messages of GRAPHICSOBJECT illustrate how different responses to a message for different types of objects can be achieved, even though for GLISP compilation of messages to LISP objects the code for a message must be resolved at compile time. @Foot[For objects in a Representation Language, messages may be compiled directly as LISP code or as messages to be interpreted at runtime, depending on how much is known about the object to which the message is sent and the compilation declarations in effect.] The DRAW and ERASE messages get the function to be used from the property list of the SHAPE name of the GRAPHICSOBJECT and APPLY it to draw the desired object. MOVINGGRAPHICSOBJECT contains a GRAPHICSOBJECT as a TRANSPARENT component, so that it inherits the properties of a GRAPHICSOBJECT; a MOVINGGRAPHICSOBJECT is a GRAPHICSOBJECT which has a VELOCITY, and will move itself by the amount of its velocity upon the message command STEP.@Foot[This example is adapted from the MovingPoint example written by Dan Bobrow for LOOPS.] The compilation of the message @PE[(_@ MGO@ STEP)] in the function TESTFN1 is of particular interest. This message is expanded into the sending of the message @PE[(_@ self@ MOVE@ VELOCITY)] to the MOVINGGRAPHICSOBJECT. The MOVINGGRAPHICSOBJECT cannot respond to such a message; however, since it contains a GRAPHICSOBJECT as a TRANSPARENT component, its GRAPHICSOBJECT responds to the message. @Foot[TRANSPARENT substructures thus permit procedural inheritance by LISP objects.] A GRAPHICSOBJECT responds to a MOVE message by erasing itself, increasing its START point by the (vector) distance to be moved, and then redrawing itself. All of the messages are specified as being compiled open, so that the short original message actually generates a large amount of code. A rectangle is drawn by the function DRAWRECT. Note how the use of the properties defined for a GRAPHICSOBJECT allows an easy interface to the system functions MOVETO and DRAWTO in terms of the properties LEFT, RIGHT, TOP, and BOTTOM. |
Added psl-1983/3-1/glisp/grtree.old version [4f81573f01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED "15-JAN-83 16:03:58" {DSK}GRTREE.LSP;11 7426 changes to: (FNS STRINGDATA-DRAW TREEELEMENT-DRAWIN BOXTYPE-DRAW BOXTYPE-ERASE DRAWRECTANGLE GRAPHICSBOX-DRAWIN GRAPHICSBOX-ERASEIN MATCHTREE RECTANGLESIZE BOXTYPE-SETSIZE GRAPHICSTREE-BOXTYPE GRAPHICSTREE-WIDTH) (VARS GRTREECOMS GRAPHICSBOXTYPES) (PROPS (RECTANGLE SIZEPROGRAM) (RECTANGLE DRAWPROGRAM)) previous date: "13-JAN-83 10:32:08" {DSK}GRTREE.LSP;1) (PRETTYCOMPRINT GRTREECOMS) (RPAQQ GRTREECOMS [(GLISPOBJECTS BOXTYPE GRAPHICSBOX GRAPHICSTREE LISPGRAPHICSTREE LISPNODEDISPLAY TREEELEMENT) (FNS BOXTYPE-DRAW BOXTYPE-ERASE BOXTYPE-SETSIZE DRAWRECTANGLE GRAPHICSBOX-DRAWIN GRAPHICSBOX-ERASEIN MATCHTREE RECTANGLESIZE STRINGDATA-DRAW TREEELEMENT-DRAWIN) (GLISPGLOBALS GRAPHICSBOXTYPES) (PROP DRAWPROGRAM RECTANGLE) (PROP SIZEPROGRAM RECTANGLE) (VARS GRAPHICSBOXTYPES) (GLOBALVARS GRAPHICSBOXTYPES) (P (LOAD? (QUOTE VECTOR.LSP]) [GLISPOBJECTS (BOXTYPE (ATOM (PROPLIST (DRAWPROGRAM ATOM) (SIZEPROGRAM ATOM))) MSG ((DRAW BOXTYPE-DRAW OPEN T) (ERASE BOXTYPE-ERASE OPEN T) (SETSIZE BOXTYPE-SETSIZE OPEN T)) ) (GRAPHICSBOX (LISTOBJECT (BOXTYPE BOXTYPE) (START VECTOR) (SIZE VECTOR) (CONTENTSOFFSET VECTOR) (DISPLAYCONTENTS ANYTHING) (CONTENTSSIZE VECTOR)) MSG [(DRAWIN GRAPHICSBOX-DRAWIN OPEN T) (ERASEIN GRAPHICSBOX-ERASEIN OPEN T) (SETSIZE ((SEND BOXTYPE SETSIZE self] SUPERS (REGION) ) (GRAPHICSTREE ANYTHING PROP ((BOXTYPE (BOXTYPENAME) RESULT BOXTYPE)) MSG ((MAKEGRAPHICSTREE MATCHTREE) (DRAW GRAPHICSTREE-DRAW) (TERMINAL? (self IS TERMINAL))) ) (LISPGRAPHICSTREE (LISTOBJECT (EXPR ANYTHING)) PROP ((BOXTYPENAME ((QUOTE RECTANGLE))) [BOXCONTENTS ((IF EXPR IS ATOMIC THEN EXPR ELSE (CAR EXPR] (BOXDISPLAYCONTENTS ((A LISPNODEDISPLAY WITH CONTENTS = BOXCONTENTS))) (SUCCESSORS [(IF EXPR IS ATOMIC THEN NIL ELSE (FOR X IN (CDR EXPR) COLLECT (A LISPGRAPHICSTREE WITH EXPR = X] RESULT (LISTOF LISPGRAPHICSTREE))) ADJ ((TERMINAL (EXPR IS ATOMIC))) SUPERS (GRAPHICSTREE) ) (LISPNODEDISPLAY (LISTOBJECT (CONTENTS ANYTHING)) PROP [(DISPLAYSIZE ((A VECTOR WITH X = (NCHARS CONTENTS) *8 Y = 12] MSG ((DRAW STRINGDATA-DRAW)) ) (TREEELEMENT (LISTOBJECT (BOX GRAPHICSBOX) (ORIGINALNODE ANYTHING) (SUCCESSORS (LISTOF TREEELEMENT)) (DISPLAYSIZE VECTOR)) PROP ((DISPLAYWIDTH (DISPLAYSIZE:X)) (DISPLAYHEIGHT (DISPLAYSIZE:Y))) MSG ((DRAWIN TREEELEMENT-DRAWIN)) ) ] (DEFINEQ (BOXTYPE-DRAW (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:58") (APPLY* BOXTYPE:DRAWPROGRAM BOX (QUOTE PAINT) W))) (BOXTYPE-ERASE (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:58") (APPLY* BOXTYPE:DRAWPROGRAM BOX (QUOTE ERASE) W))) (BOXTYPE-SETSIZE (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX) (* GSN "14-JAN-83 09:52") (BOX:CONTENTSSIZE _(SEND BOX:DISPLAYCONTENTS DISPLAYSIZE)) (APPLY* BOXTYPE:SIZEPROGRAM BOX))) (DRAWRECTANGLE (GLAMBDA (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (* GSN "14-JAN-83 13:01") (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (MOVETO BOX:LEFT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:TOP) (DRAWTO BOX:RIGHT BOX:TOP) (DRAWTO BOX:RIGHT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:BOTTOM) (CURRENTDISPLAYSTREAM OLDDS)))) (GRAPHICSBOX-DRAWIN (GLAMBDA (BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:55") (SEND BOX:BOXTYPE DRAW BOX W))) (GRAPHICSBOX-ERASEIN (GLAMBDA (BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:55") (SEND BOX:BOXTYPE ERASE BOX W))) (MATCHTREE (GLAMBDA (TR) (* GSN "14-JAN-83 10:46") (* Build a TREEELEMENT structure to match the given tree TR.) (RESULT TREEELEMENT) (PROG (TE SUM) [TE _(A TREEELEMENT WITH ORIGINALNODE = TR BOX =(A GRAPHICSBOX WITH BOXTYPE =(SEND TR BOXTYPE) DISPLAYCONTENTS =(SEND TR BOXDISPLAYCONTENTS)) SUCCESSORS =(FOR X IN (SEND TR SUCCESSORS) COLLECT (SEND X MAKEGRAPHICSTREE] (SEND TE:BOX SETSIZE) (TE:DISPLAYWIDTH _(IF (SEND TR TERMINAL?) THEN TE:BOX:WIDTH + 10 ELSE (SUM_0) (FOR X IN TE:SUCCESSORS DO SUM_+X:DISPLAYWIDTH) (MAX (TE:BOX:WIDTH + 10) SUM))) [TE:DISPLAYHEIGHT _(IF (SEND TR TERMINAL?) THEN TE:BOX:HEIGHT ELSE TE:BOX:HEIGHT + 20 +(APPLY (FUNCTION MAX) (FOR X IN TE:SUCCESSORS COLLECT X:BOX:HEIGHT] (RETURN TE)))) (RECTANGLESIZE (GLAMBDA (BOX:GRAPHICSBOX) (* GSN "14-JAN-83 10:28") (BOX:SIZE _ BOX:CONTENTSSIZE +(A VECTOR WITH X = 10 Y = 10)) (BOX:CONTENTSOFFSET _(A VECTOR WITH X = 5 Y = 5)))) (STRINGDATA-DRAW (GLAMBDA (self:LISPNODEDISPLAY POS:VECTOR W:WINDOW) (* GSN "14-JAN-83 14:35") (SEND W PRINTAT self:CONTENTS POS))) (TREEELEMENT-DRAWIN [GLAMBDA (TREE:TREEELEMENT AREA:REGION W:WINDOW) (* GSN "14-JAN-83 14:42") (* Draw the subtree beginning with TREE inside area AREA in window W.) (PROG (NEWX NEWY SUM FSPN (TB TREE:BOX)) (IF TREE:DISPLAYSIZE>AREA:SIZE THEN (ERROR "Area is too small for tree.")) (TB:START _(A VECTOR WITH X =(AREA:LEFT + AREA:RIGHT - TB:SIZE:X)/2 Y = AREA:TOP - TB:SIZE:Y)) (SEND TB DRAWIN W) (SEND TB:DISPLAYCONTENTS DRAW TB:START+TB:CONTENTSOFFSET W) (* Now compute positions for successors of top node.) (IF TREE:SUCCESSORS THEN (NEWY _ AREA:TOP - TB:SIZE:Y - 20) (SUM_0) (FOR S IN TREE:SUCCESSORS DO SUM_+S:DISPLAYSIZE:X) (* Calculate free space for each box.) (FSPN _(AREA:SIZE:X - SUM)/(LENGTH SUCCESSORS)) (NEWX _ AREA:START:X + FSPN/2) (* Draw each subtree.) (FOR S IN TREE:SUCCESSORS DO (* Draw arc to new subtree.) (SEND W DRAWLINE TB:BOTTOMCENTER (A VECTOR WITH X = NEWX+S:DISPLAYSIZE:X/2 Y = NEWY)) (SEND S DRAWIN (AN AREA WITH START =(A VECTOR WITH X = NEWX Y = AREA:START:Y) SIZE =(A VECTOR WITH X = S:DISPLAYSIZE:X Y = NEWY - AREA:START:Y)) W) (NEWX_+S:DISPLAYSIZE:X+FSPN]) ) [GLISPGLOBALS (GRAPHICSBOXTYPES (LISTOF BOXTYPE) ) ] (PUTPROPS RECTANGLE DRAWPROGRAM DRAWRECTANGLE) (PUTPROPS RECTANGLE SIZEPROGRAM RECTANGLESIZE) (RPAQQ GRAPHICSBOXTYPES (RECTANGLE)) (DECLARE: DOEVAL@COMPILE DONTCOPY (ADDTOVAR GLOBALVARS GRAPHICSBOXTYPES) ) (LOAD? (QUOTE VECTOR.LSP)) (DECLARE: DONTCOPY (FILEMAP (NIL (2714 7091 (BOXTYPE-DRAW 2724 . 2892) (BOXTYPE-ERASE 2894 . 3063) (BOXTYPE-SETSIZE 3065 . 3278) (DRAWRECTANGLE 3280 . 3715) (GRAPHICSBOX-DRAWIN 3717 . 3867) (GRAPHICSBOX-ERASEIN 3869 . 4021 ) (MATCHTREE 4023 . 5126) (RECTANGLESIZE 5128 . 5358) (STRINGDATA-DRAW 5360 . 5512) ( TREEELEMENT-DRAWIN 5514 . 7089))))) STOP |
Added psl-1983/3-1/glisp/grtree.sl version [53fa5c06f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GRTREE.PSL;11 4-FEB-83 16:48:01 (GLOBAL '(GRAPHICSBOXTYPES)) % Tree Drawing Package. To test, do (DLT TX WW) where WW is a window. (GLISPOBJECTS (BOXTYPE (ATOM (PROPLIST (DRAWPROGRAM ATOM) (SIZEPROGRAM ATOM))) MSG ((DRAW BOXTYPE-DRAW OPEN T) (ERASE BOXTYPE-ERASE OPEN T) (SETSIZE BOXTYPE-SETSIZE OPEN T))) (GRAPHICSBOX (LISTOBJECT (BOXTYPE BOXTYPE) (START VECTOR) (SIZE VECTOR) (CONTENTSOFFSET VECTOR) (DISPLAYCONTENTS ANYTHING) (CONTENTSSIZE VECTOR)) MSG ((DRAWIN GRAPHICSBOX-DRAWIN OPEN T) (ERASEIN GRAPHICSBOX-ERASEIN OPEN T) (SETSIZE ((SEND BOXTYPE SETSIZE self)))) SUPERS (REGION)) (GRAPHICSTREE (LISTOBJECT (TOPNODE TREE) (GRTREE TREEELEMENT) (BOXTYPE BOXTYPE) (LINESTYPE LINESTYPE) (SPACING VECTOR)) MSG ((CREATE CREATETREE SPECIALIZE T) (MATCH MATCHTREE SPECIALIZE T) (SELECTNODE GRAPHICSTREE-SELECTNODE OPEN T))) (LISPGRAPHICSTREE (LISTOBJECT (TOPNODE LISPTREE) (GRTREE TREEELEMENT)) PROP ((BOXTYPE ('RECTANGLE) RESULT BOXTYPE) (LINESTYPE ('STRAIGHT) RESULT LINESTYPE) (SPACING ('(10 20)) RESULT VECTOR)) SUPERS (GRAPHICSTREE)) (LISPNODEDISPLAY (LISTOBJECT (CONTENTS ANYTHING)) PROP ((DISPLAYSIZE ((A VECTOR WITH X = (NCHARS CONTENTS) *7 Y = 10)))) MSG ((DRAW STRINGDATA-DRAW))) (LISPTREE (EXPR ANYTHING) PROP ((CONTENTS ((A LISPNODEDISPLAY WITH CONTENTS = (IF EXPR IS ATOMIC THEN EXPR ELSE (CAR EXPR))))) (SUCCESSORS ((IF EXPR IS ATOMIC THEN NIL ELSE (CDR EXPR))) RESULT (LISTOF LISPTREE))) ADJ ((TERMINAL (EXPR IS ATOMIC)))) (TREEELEMENT (LISTOBJECT (BOX GRAPHICSBOX) (ORIGINALNODE ANYTHING) (SUCCESSORS (LISTOF TREEELEMENT)) (DISPLAYSIZE VECTOR)) PROP ((DISPLAYWIDTH (DISPLAYSIZE:X)) (DISPLAYHEIGHT (DISPLAYSIZE:Y)) (TOTALAREA ((VIRTUAL REGION WITH START = TOTALSTART SIZE = DISPLAYSIZE))) (TOTALSTART ((VIRTUAL VECTOR WITH X = BOX:START:X + (BOX:SIZE:X - DISPLAYSIZE:X) / 2 Y = BOX:START:Y + BOX:SIZE:Y - DISPLAYSIZE:Y)))) MSG ((DRAWIN TREEELEMENT-DRAWIN) (SELECTNODE TREEELEMENT-SELECTNODE))) ) % GSN 14-JAN-83 12:58 (DG BOXTYPE-DRAW (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'PAINT W))) % GSN 14-JAN-83 12:58 (DG BOXTYPE-ERASE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'ERASE W))) % GSN 14-JAN-83 09:52 (DG BOXTYPE-SETSIZE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX) (BOX:CONTENTSSIZE _ (SEND BOX:DISPLAYCONTENTS DISPLAYSIZE))(APPLY BOXTYPE:SIZEPROGRAM (LIST BOX))) % GSN 2-FEB-83 12:58 (DG CIRCLESIZE (BOX:GRAPHICSBOX) (PROG (DIAM) (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10) (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = DIAM)) (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X) /2 Y = (DIAM - BOX:CONTENTSSIZE:Y) /2)))) % GSN 2-FEB-83 11:23 (DG CREATETREE (TR:GRAPHICSTREE) (SEND TR MATCH TOPNODE)) % GSN 2-FEB-83 14:04 % Draw a Lisp tree. (DG DLT (EXPR WW:WINDOW) (PROG (TREE) (SEND WW CLEAR) (TREE _ (SEND (A LISPGRAPHICSTREE WITH TOPNODE = EXPR) CREATE)) (IF TREE:DISPLAYSIZE > WW:SIZE THEN (ERROR 0 "Window is too small") ELSE (SEND TREE DRAWIN (AN AREA WITH SIZE = TREE:DISPLAYSIZE START = (SEND WW CENTEROFFSET TREE:DISPLAYSIZE)) WW)))) % GSN 2-FEB-83 12:16 (DG DRAWGRCIRCLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (DRAWCIRCLE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:X/2 NIL W) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 2-FEB-83 13:12 (DG DRAWGRELLIPSE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (DRAWELLIPSE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:Y/2 BOX:SIZE:X/2 0 NIL NIL W) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 14-JAN-83 13:01 (DG DRAWRECTANGLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (MOVETO BOX:LEFT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:TOP) (DRAWTO BOX:RIGHT BOX:TOP) (DRAWTO BOX:RIGHT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:BOTTOM) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 2-FEB-83 13:12 (DG ELLIPSESIZE (BOX:GRAPHICSBOX) (PROG (DIAM) (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10) (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = BOX:CONTENTSSIZE:Y + 10)) (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X) /2 + 1 Y = 6)))) % GSN 14-JAN-83 12:55 (DG GRAPHICSBOX-DRAWIN (BOX:GRAPHICSBOX W:WINDOW) (SEND BOX:BOXTYPE DRAW BOX W)) % GSN 14-JAN-83 12:55 (DG GRAPHICSBOX-ERASEIN (BOX:GRAPHICSBOX W:WINDOW) (SEND BOX:BOXTYPE ERASE BOX W)) % GSN 2-FEB-83 16:14 (DG GRAPHICSTREE-SELECTNODE (GT:GRAPHICSTREE V:VECTOR) (SEND GT:GRTREE SELECTNODE V)) % GSN 3-FEB-83 13:29 % Build a TREEELEMENT structure to match the given tree TR. (DG MATCHTREE (TR:GRAPHICSTREE NODE:TREE) (RESULT TREEELEMENT)(PROG (TE SUM MAXH) (TE _ (A TREEELEMENT WITH ORIGINALNODE = NODE BOX = (A GRAPHICSBOX WITH BOXTYPE = TR:BOXTYPE DISPLAYCONTENTS = NODE:CONTENTS) SUCCESSORS = (FOR X IN NODE:SUCCESSORS COLLECT (SEND TR MATCH X)))) (SEND TE:BOX SETSIZE) (TE:DISPLAYWIDTH _ (IF NODE IS TERMINAL THEN TE:BOX:WIDTH + TR:SPACING:X ELSE (SUM_0) (FOR X IN TE:SUCCESSORS DO SUM_+X:DISPLAYWIDTH) (MAX (TE:BOX:WIDTH + TR:SPACING:X) SUM))) (TE:DISPLAYHEIGHT _ (IF NODE IS TERMINAL THEN TE:BOX:HEIGHT ELSE (MAXH_0) (FOR X IN TE:SUCCESSORS DO (MAXH_ (MAX MAXH X:DISPLAYHEIGHT))) (TE:BOX:HEIGHT + TR:SPACING:Y + MAXH))) (RETURN TE))) % GSN 2-FEB-83 12:02 (DG RECTANGLESIZE (BOX:GRAPHICSBOX) (BOX:SIZE _ BOX:CONTENTSSIZE + (A VECTOR WITH X = 10 Y = 10))( BOX:CONTENTSOFFSET _ (A VECTOR WITH X = 6 Y = 6))) % GSN 14-JAN-83 14:35 (DG STRINGDATA-DRAW (self:LISPNODEDISPLAY POS:VECTOR W:WINDOW) (SEND W PRINTAT self:CONTENTS POS)) % GSN 14-JAN-83 14:42 % Draw the subtree beginning with TREE inside area AREA in window W. (DG TREEELEMENT-DRAWIN (TREE:TREEELEMENT AREA:REGION W:WINDOW) (PROG (NEWX NEWY SUM FSPN TB) (IF TREE:DISPLAYSIZE>AREA:SIZE THEN (ERROR 0 "Area is too small for tree.")) (TB:START _ (A VECTOR WITH X = (AREA:LEFT + AREA:RIGHT - TB:SIZE:X) /2 Y = AREA:TOP - TB:SIZE:Y)) (SEND TB DRAWIN W) (SEND TB:DISPLAYCONTENTS DRAW TB:START+TB:CONTENTSOFFSET W) % Now compute positions for successors of top node. (IF TREE:SUCCESSORS THEN (NEWY _ AREA:TOP - TB:SIZE:Y - 20) (SUM_0) (FOR S IN TREE:SUCCESSORS DO SUM_+S:DISPLAYSIZE:X) % Calculate free space for each box. (FSPN _ (AREA:SIZE:X - SUM) / (LENGTH SUCCESSORS)) (NEWX _ AREA:START:X + FSPN/2) % Draw each subtree. (FOR S IN TREE:SUCCESSORS DO % Draw arc to new subtree. (SEND W DRAWLINE TB:BOTTOMCENTER (A VECTOR WITH X = NEWX+S:DISPLAYSIZE:X/2 Y = NEWY)) (SEND S DRAWIN (AN AREA WITH START = (A VECTOR WITH X = NEWX Y = AREA:START:Y) SIZE = (A VECTOR WITH X = S:DISPLAYSIZE:X Y = NEWY - AREA:START:Y)) W) (NEWX_+S:DISPLAYSIZE:X+FSPN))))) % GSN 2-FEB-83 17:37 (DG TREEELEMENT-SELECTNODE (TE:TREEELEMENT V:VECTOR) (PROG (RESULT LST TMP) (IF (SEND TE:BOX CONTAINS? V) THEN (RETURN TE) ELSEIF (SEND TE:TOTALAREA CONTAINS? V) THEN (LST_TE:SUCCESSORS) (WHILE ~RESULT AND (TMP-_LST) DO (RESULT _ (SEND TMP SELECTNODE V))) (RETURN RESULT)))) (GLISPGLOBALS (GRAPHICSBOXTYPES (LISTOF BOXTYPE)) ) (PUT 'RECTANGLE 'DRAWPROGRAM 'DRAWRECTANGLE) (PUT 'CIRCLE 'DRAWPROGRAM 'DRAWGRCIRCLE) (PUT 'ELLIPSE 'DRAWPROGRAM 'DRAWGRELLIPSE) (PUT 'RECTANGLE 'SIZEPROGRAM 'RECTANGLESIZE) (PUT 'CIRCLE 'SIZEPROGRAM 'CIRCLESIZE) (PUT 'ELLIPSE 'SIZEPROGRAM 'ELLIPSESIZE) (SETQ GRAPHICSBOXTYPES '(RECTANGLE)) (SETQ TX '(/(+(- B) (SQRT (-(^ B 2) (* 4 (* A C)) ))) (* 2 A) )) |
Added psl-1983/3-1/glisp/h19.sl version [4b6e0591ea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <NOVAK>H19.PSL.1 20-Mar-83 12:40:06 (GLISPOBJECTS (TERMINAL ATOM MSG ((MOVETOXY TERMINAL-MOVETOXY) (PRINTCHAR TERMINAL-PRINTCHAR OPEN T) (PRINTSTRING TERMINAL-PRINTSTRING OPEN T) (INVERTVIDEO ((PRIN1 ESCAPECHAR) (PRIN1 "p"))) (NORMALVIDEO ((PRIN1 ESCAPECHAR) (PRIN1 "q"))) (GRAPHICSMODE ((PRIN1 ESCAPECHAR) (PRIN1 "F"))) (NORMALMODE ((PRIN1 ESCAPECHAR) (PRIN1 "G"))) (ERASEEOL ((PRIN1 ESCAPECHAR) (PRIN1 "K"))))) ) (GLISPGLOBALS (TERMINAL TERMINAL) ) (GLISPCONSTANTS (BLANKCHAR " " STRING) (HORIZONTALLINECHAR "-" STRING) (HORIZONTALBARCHAR "{" STRING) (LVERTICALBARCHAR "}" STRING) (RVERTICALBARCHAR "|" STRING) (ESCAPECHAR (CHARACTER 27) STRING) ) % edited: 14-Mar-83 22:48 % Move cursor to a specified X Y position. (DG TERMINAL-MOVETOXY (TERM:TERMINAL X:INTEGER Y:INTEGER) (IF X<0 THEN X_0 ELSEIF X>79 X_79)(IF Y<0 THEN Y_0 ELSEIF Y>23 THEN Y_23)(SEND TERMINAL PRINTCHAR ESCAPECHAR)(SEND TERMINAL PRINTCHAR "Y")(SEND TERMINAL PRINTCHAR (CHARACTER 55 - Y))(SEND TERMINAL PRINTCHAR (CHARACTER 32 + X))) % edited: 19-Mar-83 20:29 (DG TERMINAL-PRINTCHAR (TERM:TERMINAL S:STRING) (PRIN1 S)) % edited: 19-Mar-83 20:29 (DG TERMINAL-PRINTSTRING (TERM:TERMINAL S:STRING) (PRIN1 S)) (SETQ TERMINAL 'H19) |
Added psl-1983/3-1/glisp/hrd.sl version [8f47198c95].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % HRD.SL.2 07 April 83 % Programs to interface to Methius high-resolution display on HP 9836. % G. Novak 07 April 83 (DE M-MOVEP1 (X Y) (M_MOVEP1 X (DIFFERENCE 551 Y))) (DE M-CHAR (ASCIIN) (M_CHAR ASCIIN)) (DE M-ERASE (X1 Y1 X2 Y2) (M_ERASE X1 (DIFFERENCE 551 Y1) X2 (DIFFERENCE 551 Y2))) (DE M-RECT-OUTLINE (X1 Y1 X2 Y2) (M_RECT_OUTLINE X1 (DIFFERENCE 551 Y1) X2 (DIFFERENCE 551 Y2))) (DE M-VECTOR (X1 Y1 X2 Y2) (M_VECTOR X1 (DIFFERENCE 551 Y1) X2 (DIFFERENCE 551 Y2))) |
Added psl-1983/3-1/glisp/irewrite.b version [a79ed30a56].
cannot compute difference between binary files
Added psl-1983/3-1/glisp/irewrite.sl version [aa5dc9b72b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}IREWRITE.PSL;2 6-JAN-83 10:08:06 (DE ADD-LEMMA (TERM) (COND ((AND (NOT (ATOM TERM)) (EQ (CAR TERM) 'EQUAL) (NOT (ATOM (CADR TERM)))) (PUT (CAR (CADR TERM)) 'LEMMAS (CONS TERM (GET (CAR (CADR TERM)) 'LEMMAS)))) (T (ERROR 0 (LIST 'ADD-LEMMA-DID-NOT-LIKE-TERM TERM))))) (DE ADD-LEMMA-LST (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST))))) % lmm 7-JUN-81 10:07 (DE APPLY-SUBST (ALIST TERM) (COND ((NOT (PAIRP TERM)) ((LAMBDA (TEM) (COND (TEM (CDR TEM)) (T TERM))) (ASSOC TERM ALIST))) (T (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION (LAMBDA (X) (APPLY-SUBST ALIST X)))))))) (DE APPLY-SUBST-LST (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST)))))) (DE FALSEP (X LST) (OR (EQUAL X '(F)) (MEMBER X LST))) (DE ONE-WAY-UNIFY (TERM1 TERM2) (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2))) % lmm 7-JUN-81 09:47 (DE ONE-WAY-UNIFY1 (TERM1 TERM2) (COND ((NOT (PAIRP TERM2)) ((LAMBDA (TEM) (COND (TEM (EQUAL TERM1 (CDR TEM))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) (ASSOC TERM2 UNIFY-SUBST))) ((NOT (PAIRP TERM1)) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL))) (DE ONE-WAY-UNIFY1-LST (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL))) (DE PTIME NIL (PROG (GCTM) (SETQ GCTM 0) (RETURN (CONS (time) GCTM)))) % lmm 7-JUN-81 10:04 (DE REWRITE (TERM) (COND ((NOT (PAIRP TERM)) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION REWRITE))) (GET (CAR TERM) 'LEMMAS))))) (DE REWRITE-WITH-LEMMAS (TERM LST) (COND ((NULL LST) TERM) ((ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST))))) (T (REWRITE-WITH-LEMMAS TERM (CDR LST))))) (DE SETUP NIL (ADD-LEMMA-LST '((EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL)))) (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) (EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F)))) (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) (EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (SUB1 X)))) (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) (EQUAL (PRIME X) (AND (NOT (ZEROP X)) (NOT (EQUAL X (ADD1 (ZERO)))) (PRIME1 X (SUB1 X)))) (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) (EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X)))) (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) (EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y)))) (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUS J K)) (TIMES (EXP I J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) (EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE)))) (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) (EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1))))) (EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y)))) (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) (EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A))))) (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) (EQUAL (TIMES X (DIFFERENCE C W)) (DIFFERENCE (TIMES C X) (TIMES W X))) (EQUAL (REMAINDER (TIMES X Z) Z) (ZERO)) (EQUAL (DIFFERENCE (PLUS B (PLUS A C)) A) (PLUS B C)) (EQUAL (DIFFERENCE (ADD1 (PLUS Y Z)) Z) (ADD1 Y)) (EQUAL (LESSP (PLUS X Y) (PLUS X Z)) (LESSP Y Z)) (EQUAL (LESSP (TIMES X Z) (TIMES Y Z)) (AND (NOT (ZEROP Z)) (LESSP X Y))) (EQUAL (LESSP Y (PLUS X Y)) (NOT (ZEROP X))) (EQUAL (GCD (TIMES X Z) (TIMES Y Z)) (TIMES Z (GCD X Y))) (EQUAL (VALUE (NORMALIZE X) A) (VALUE X A)) (EQUAL (EQUAL (FLATTEN X) (CONS Y (NIL))) (AND (NLISTP X) (EQUAL X Y))) (EQUAL (LISTP (GOPHER X)) (LISTP X)) (EQUAL (SAMEFRINGE X Y) (EQUAL (FLATTEN X) (FLATTEN Y))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) (ZERO)) (AND (OR (ZEROP Y) (EQUAL Y 1)) (EQUAL X (ZERO)))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) 1) (EQUAL X 1)) (EQUAL (NUMBERP (GREATEST-FACTOR X Y)) (NOT (AND (OR (ZEROP Y) (EQUAL Y 1)) (NOT (NUMBERP X))))) (EQUAL (TIMES-LIST (APPEND X Y)) (TIMES (TIMES-LIST X) (TIMES-LIST Y))) (EQUAL (PRIME-LIST (APPEND X Y)) (AND (PRIME-LIST X) (PRIME-LIST Y))) (EQUAL (EQUAL Z (TIMES W Z)) (AND (NUMBERP Z) (OR (EQUAL Z (ZERO)) (EQUAL W 1)))) (EQUAL (GREATEREQPR X Y) (NOT (LESSP X Y))) (EQUAL (EQUAL X (TIMES X Y)) (OR (EQUAL X (ZERO)) (AND (NUMBERP X) (EQUAL Y 1)))) (EQUAL (REMAINDER (TIMES Y X) Y) (ZERO)) (EQUAL (EQUAL (TIMES A B) 1) (AND (NOT (EQUAL A (ZERO))) (NOT (EQUAL B (ZERO))) (NUMBERP A) (NUMBERP B) (EQUAL (SUB1 A) (ZERO)) (EQUAL (SUB1 B) (ZERO)))) (EQUAL (LESSP (LENGTH (DELETE X L)) (LENGTH L)) (MEMBER X L)) (EQUAL (SORT2 (DELETE X L)) (DELETE X (SORT2 L))) (EQUAL (DSORT X) (SORT2 X)) (EQUAL (LENGTH (CONS X1 (CONS X2 (CONS X3 (CONS X4 (CONS X5 (CONS X6 X7))))))) (PLUS 6 (LENGTH X7))) (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)) (EQUAL (QUOTIENT (PLUS X (PLUS X Y)) 2) (PLUS X (QUOTIENT Y 2))) (EQUAL (SIGMA (ZERO) I) (QUOTIENT (TIMES I (ADD1 I)) 2)) (EQUAL (PLUS X (ADD1 Y)) (IF (NUMBERP Y) (ADD1 (PLUS X Y)) (ADD1 X))) (EQUAL (EQUAL (DIFFERENCE X Y) (DIFFERENCE Z Y)) (IF (LESSP X Y) (NOT (LESSP Y Z)) (IF (LESSP Z Y) (NOT (LESSP Y X)) (EQUAL (FIX X) (FIX Z))))) (EQUAL (MEANING (PLUS-TREE (DELETE X Y)) A) (IF (MEMBER X Y) (DIFFERENCE (MEANING (PLUS-TREE Y) A) (MEANING X A)) (MEANING (PLUS-TREE Y) A))) (EQUAL (TIMES X (ADD1 Y)) (IF (NUMBERP Y) (PLUS X (TIMES X Y)) (FIX X))) (EQUAL (NTH (NIL) I) (IF (ZEROP I) (NIL) (ZERO))) (EQUAL (LAST (APPEND A B)) (IF (LISTP B) (LAST B) (IF (LISTP A) (CONS (CAR (LAST A)) B) B))) (EQUAL (EQUAL (LESSP X Y) Z) (IF (LESSP X Y) (EQUAL T Z) (EQUAL F Z))) (EQUAL (ASSIGNMENT X (APPEND A B)) (IF (ASSIGNEDP X A) (ASSIGNMENT X A) (ASSIGNMENT X B))) (EQUAL (CAR (GOPHER X)) (IF (LISTP X) (CAR (FLATTEN X)) (ZERO))) (EQUAL (FLATTEN (CDR (GOPHER X))) (IF (LISTP X) (CDR (FLATTEN X)) (CONS (ZERO) (NIL)))) (EQUAL (QUOTIENT (TIMES Y X) Y) (IF (ZEROP Y) (ZERO) (FIX X))) (EQUAL (GET J (SET I VAL MEM)) (IF (EQP J I) VAL (GET J MEM)))))) % lmm 7-JUN-81 09:44 (DE TAUTOLOGYP (X TRUE-LST FALSE-LST) (COND ((TRUEP X TRUE-LST) T) ((FALSEP X FALSE-LST) NIL) ((NOT (PAIRP X)) NIL) ((EQ (CAR X) 'IF) (COND ((TRUEP (CADR X) TRUE-LST) (TAUTOLOGYP (CADDR X) TRUE-LST FALSE-LST)) ((FALSEP (CADR X) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST FALSE-LST)) (T (AND (TAUTOLOGYP (CADDR X) (CONS (CADR X) TRUE-LST) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST (CONS (CADR X) FALSE-LST)))))) (T NIL))) (DE TAUTP (X) (TAUTOLOGYP (REWRITE X) NIL NIL)) (DE TEST NIL (PROG (TM1 TM2 ANS TERM) (SETQ TM1 (PTIME)) (SETQ TERM (APPLY-SUBST '((X F (PLUS (PLUS A B) (PLUS C (ZERO)))) (Y F (TIMES (TIMES A B) (PLUS C D))) (Z F (REVERSE (APPEND (APPEND A B) (NIL)))) (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B)))) '(IMPLIES (AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W)))) (IMPLIES X W)))) (SETQ ANS (TAUTP TERM)) (SETQ TM2 (PTIME)) (RETURN (LIST ANS (DIFFERENCE (CAR TM2) (CAR TM1)) (DIFFERENCE (CDR TM2) (CDR TM1)))))) (DE TRANS-OF-IMPLIES (N) (LIST 'IMPLIES (TRANS-OF-IMPLIES1 N) (LIST 'IMPLIES 0 N))) (DE TRANS-OF-IMPLIES1 (N) (COND ((EQUAL N 1) (LIST 'IMPLIES 0 1)) (T (LIST 'AND (LIST 'IMPLIES (SUB1 N) N) (TRANS-OF-IMPLIES1 (SUB1 N)))))) (DE TRUEP (X LST) (OR (EQUAL X '(T)) (MEMBER X LST))) |
Added psl-1983/3-1/glisp/menu.sl version [051df54de0].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % MENU.SL.1 % Abstract datatype for Menu operations. % G. Novak 31 Jan. 83 (glispobjects (menu (listobject (items (listof atom))) msg ((create menu-create) (select menu-select))) ) % Initialize a menu which has been newly created. (dg menu-create (m:menu)) % Ask the user for a selection from a menu. (dg menu-select (m:menu) ) |
Added psl-1983/3-1/glisp/newdg.sl version [31086f116d].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % Fexpr for defining GLISP functions. (dm dg (x) (prog (result) (put (cadr x) 'gloriginalexpr (cons 'lambda (cddr x))) (return (cond (glcompiledefflg (glcc (cadr x)) (setq result (cons 'df (cons (cadr x) (cdr (get (cadr x) 'glcompiled))))) (put (cadr x) 'glcompiled nil) result) (t (glputhook (cadr x)) (list 'quote (cadr x)) )) ))) |
Added psl-1983/3-1/glisp/oldgltest.sl version [f21dbae4af].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.SL.8 17 January 1983 % GLISP TEST FUNCTIONS, PSL VERSION. % Object descriptions for a Company database. (GLISPOBJECTS (EMPLOYEE % Name of the object type (LIST (NAME STRING) % Actual storage structure (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) % Computed properties - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) % Computed adjectives ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) % Message definitions (Date (List (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH '(JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) % Some test data for the above functions. (setq company1 (a company with President = (An Employee with Name = "Oscar the Grouch" Salary = 88.0 Jobtitle = 'President Date-Hired = (A Date with Month = 3 Day = 15 Year = 1907)) Employees = (list (An Employee with Name = "Cookie Monster" Salary = 12.50 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 7 Day = 21 Year = 1947)) (An Employee with Name = "Betty Lou" Salary = 9.00 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 5 Day = 15 Year = 1980)) (An Employee with Name = "Grover" Salary = 3.00 Jobtitle = 'Electrician Trainee = T Date-Hired = (A Date with Month = 6 Day = 13 Year = 1978)) ))) % Program to give raises to the electricians. (DG GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DG CURRENTDATE () (Result DATE) (A DATE WITH YEAR = 1981 MONTH = 11 DAY = 30)) % The following object descriptions are used in a graphics object test % program (derived from one written by D.G. Bobrow as a LOOPS example). % The test program MGO-TEST runs on a Xerox D-machine, but won't run on % other machines. (GLISPOBJECTS % The actual stored structure for a Vector is simple, but it is overloaded % with many properties. (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (DIRECTION ((IF X IS ZERO THEN (IF Y IS NEGATIVE THEN -90.0 ELSE 90.0) ELSE (ATAN2D Y X))) RESULT DEGREES) ) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) % Defining operators as messages % causes the compiler to automatically % overload the operators. (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T ARGTYPES (NUMBER)) (* vectordotproduct open t argtypes (vector)) (/ VECTORQUOTIENT OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((SEND SELF PRIN1) % PRINT is defined in terms of the (TERPRI))) ) ) % PRIN1 message of this object. (DEGREES REAL % Stored value is just a real number. PROP ((RADIANS (self*(3.1415926 / 180.0)) RESULT RADIANS))) (RADIANS REAL PROP ((DEGREES (self*(180.0 / 3.1415926)) RESULT DEGREES))) % The definition of GraphicsObject builds on that of Vector. (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) % A property defined in terms of a % property of a substructure (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) % Vector addition. (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) % Vector arithmetic (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) % A way to get runtime message (List SELF % behavior without using the (QUOTE PAINT))))) % message mechanism. (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) % Includes properties of a (VELOCITY VECTOR)) % GraphicsObject due to the % TRANSPARENT declaration. Msg ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((SEND SELF MOVE VELOCITY)))) ) ) % The following functions define arithmetic operations on Vectors. % These functions are generally called OPEN (macro-expanded) rather % than being called directly. (DG VECTORPLUS (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) (DG VECTORDIFF (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) (DG VECTORTIMES (V:VECTOR N:NUMBER) (A (typeof v) WITH X = X*N Y = Y*N)) (DG VECTORDOTPRODUCT (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X * V2:X Y = V1:Y * V2:Y)) (DG VECTORQUOTIENT (V:VECTOR N:NUMBER) (A (typeof v) WITH X = X/N Y = Y/N)) % VectorMove, which defines the _+ operator for vectors, does a destructive % addition to the vector which is its first argument. Thus, the expression % U_+V will destructively change U, while U_U+V will make a new vector with % the value U+V and assign its value to U. (DG VECTORMOVE (V:vector DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y) V) % An object is moved by erasing it, changing its starting point, and % then redrawing it. (DG GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (SEND SELF ERASE) % Erase the object (START _+ DELTA) % Destructively move start point by delta (SEND SELF DRAW)) % Redraw the object in new location (DG MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) % Now we define some test functions which use the above definitions. % First there are some simple functions which test vector operations. (DG TVPLUS (U:VECTOR V:VECTOR) U+V) (DG TVMOVE (U:VECTOR V:VECTOR) U_+V) (DG TVTIMESN (U:VECTOR N:NUMBER) U*N) (DG TVTIMESV (U:VECTOR V:VECTOR) U*V) % This test function creates a MovingGraphicsObject and then moves it % across the screen by sending it MOVE messages. Everything in this % example is compiled open; the STEP message involves a great deal of % message inheritance. (DG MGO-TEST () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE = (QUOTE RECTANGLE) SIZE = (A VECTOR WITH X = 4 Y = 3) VELOCITY = (A VECTOR WITH X = 3 Y = 4))) (N _ 0) (WHILE (N_+1)<100 (SEND MGO STEP)) (SEND (THE START OF MGO) PRINT))) % This function tests the properties of a GraphicsObject. (DG TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA)) % Function to draw a rectangle. Computed properties of the rectangle are % used within calls to the graphics functions, making the code easy to % write and understand. (DG DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS) )) % The LispTree and PreorderSearchRecord objects illustrate how generators % can be written. (GLISPOBJECTS % In defining a LispTree, which can actually be of multiple types (atom or % dotted pair), we define it as the more complex dotted-pair type and take % care of the simpler case in the PROPerty definitions. (LISPTREE (CONS (CAR LISPTREE) % Defines a LispTree structure as the CONS (CDR LISPTREE)) % of two fields named CAR and CDR. PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) % PreorderSearchRecord is defined to be a generator. Its data structure holds % the current node and a stack of previous nodes, and its NEXT message is % defined as code to step through the preorder search. (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) % PRINTLEAVES prints the leaves of the tree, using a PreorderSearchRecord % as the generator for searching the tree. (DG PRINTLEAVES (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (SEND PSR NEXT)))) % The Circle objects illustrate the definition of a number of mathematical % properties of an object in terms of stored data and other properties. (Glispobjects (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) % A PROPerty can be a constant. (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) % Defined in terms of other prop. (AREA (PI*RADIUS^2)) ) ADJ ((BIG (AREA>120)) % BIG defined in terms of AREA (MEDIUM (AREA >= 60 AND AREA <= 120)) (SMALL (AREA<60))) MSG ((STANDARD (AREA_100)) % "Storing into" computed property (GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) ) ) % A DCIRCLE is implemented differently from a circle. % The data structure is different, and DIAMETER is stored instead of RADIUS. % By defining RADIUS as a PROPerty, all of the CIRCLE properties defined % in terms of radius can be inherited. (DCIRCLE (LISTOBJECT (START VECTOR) (DIAMETER REAL)) PROP ((RADIUS (DIAMETER/2))) SUPERS (CIRCLE) ) ) % Make a DCIRCLE for testing (setq dc (a dcircle with diameter = 10.0)) % Since DCIRCLE is an Object type, it can be used with interpreted messages, % e.g., (send dc area) to get the area property, % (send dc standard) to set the area to the standard value, % (send dc diameter) to get the stored diameter value. % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DG GROWCIRCLE (C:CIRCLE) (C:AREA_+100) (PRINT RADIUS) ) (SETQ MYCIRCLE (A CIRCLE)) % Since SQRT is not defined in the bare-PSL system, we redefine it here. (DG SQRT (X) (PROG (S) (S_X) (IF X < 0 THEN (ERROR) ELSE (WHILE (ABS S*S - X) > 0.000001 DO (S _ (S+X/S) * 0.5))) (RETURN S))) % Function SQUASH illustrates elimination of compile-time constants. % Of course, nobody would write such a function directly. However, such forms % can arise when inherited properties are compiled. Conditional compilation % occurs automatically when appropriate variables are defined to the GLISP % compiler as compile-time constants because the post-optimization phase of % the compiler makes the unwanted code disappear. (DG SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF 6<2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) % The following object definitions describe a student records database. (glispobjects (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winning (average>=95)) (losing (average<60))) isa ((winner (self is winning)))) (student-group (listof student) prop ((n-students length) % This property is implemented by % the Lisp function LENGTH. (Average Student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male))) (women ((those students who are female))) (winners ((those students who are winning))) (losers ((those students who are losing))) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)) (for s in sg do sum_+s:average) (return sum/sg:n-students) )) % Print name and grade average for each student (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (print s:grade-average))) % Another version of the above function (dg test1b (:class) (for each student (prin1 name) (prin2 '! ) (print grade-average))) % Print name and average of the winners in the class (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % The average of all the male students' grades (dg test3 (c:class) c:men:average) % The name and average of the winning women (dg test4 (c:class) (for s in c:women when s is winning (prin1 s:name) (prin2 '! ) (print s:average))) % Another version of the above function. The * operator in this case % denotes the intersection of the sets of women and winners. The % GLISP compiler optimizes the code so that these intermediate sets are % not actually constructed. (dg test5 (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % Make a list of the easy professors. (dg easy-profs (classes:(listof class)) (for each class with class-average > 90.0 collect (the instructor))) % A more Pascal-like version of easy-profs: (dg easy-profs-b (classes:(listof class)) (for c in classes when c:class-average > 90.0 collect c:instructor)) % Some test data for testing the above functions. (setq class1 (a class with instructor = "G. Novak" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) % The following object definitions illustrate inheritance of properties % from multiple parent classes. The three "bottom" classes Planet, Brick, % and Bowling-Ball all inherit the same definition of the property Density, % although they are represented in very different ways. (glispobjects (physical-object anything prop ((density (mass/volume)))) (ordinary-object anything prop ((mass (weight / 9.88))) % Compute mass as weight/gravity supers (physical-object)) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (parallelepiped anything prop ((volume (length*width*height)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) % A planet is a physical-object % and a sphere. (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) % Three test functions to demonstrate inheritance of the Density property. (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) % Some objects to test the functions on. (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.10 height = 0.05 length = 0.20)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) % Since the object types Planet, Brick, and Bowling-Ball are defined as % Object types (i.e., they contain the Class name as part of their stored % data), messages can be sent to them directly from the keyboard for % interactive examination of the objects. For example, the following % messages could be used: % (send earth density) % (send brick1 weight: 25.0) % (send brick1 mass: 2.0) % (send bb1 radius) % (send bb1 type: 'child) |
Added psl-1983/3-1/glisp/permute.old version [24a628abab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED " 2-JAN-83 14:20:01" {DSK}PERMUTE.LSP;4 9267 changes to: (FNS HISTO-CREATE HISTO-PEAKS HISTO-ADD) (VARS PERMUTECOMS) previous date: "28-DEC-82 11:32:40" {DSK}PERMUTE.LSP;1) (PRETTYCOMPRINT PERMUTECOMS) (RPAQQ PERMUTECOMS ((GLISPOBJECTS HISTOGRAM PERMUTATION) (VARS PERM3S FOLD3S PERM4S FOLD4S) (FNS ALLPERMS BINLIST BITSHUFFLE COMPOSEBITSHUFFLES DOBITSHUFFLE GENPERMS HISTO-ADD HISTO-CREATE HISTO-PEAKS IDPERM LISTOFC LOG2 NEGINPPERM OUTPERMS PERM-INVERSE) (PROP GLRESULTTYPE BITSHUFFLE DOBITSHUFFLE))) [GLISPOBJECTS (HISTOGRAM (LISTOBJECT (MIN INTEGER) (MAX INTEGER) (TOTAL INTEGER) (COUNTS (LISTOF INTEGER))) PROP ((PEAKS HISTO-PEAKS)) MSG ((CREATE HISTO-CREATE) (+ HISTO-ADD)) ) (PERMUTATION (LISTOF INTEGER) PROP ((LENGTH LENGTH) (INVERSE PERM-INVERSE RESULT PERMUTATION)) MSG ((* COMPOSEBITSHUFFLES RESULT PERMUTATION)) ) ] (RPAQQ PERM3S ((7 3 5 1 6 2 4 0) (7 5 3 1 6 4 2 0) (7 3 6 2 5 1 4 0) (7 5 6 4 3 1 2 0) (7 6 3 2 5 4 1 0))) (RPAQQ FOLD3S ((3 2 1 0 7 6 5 4) (5 4 7 6 1 0 3 2) (6 7 4 5 2 3 0 1))) (RPAQQ PERM4S ((15 7 11 3 13 5 9 1 14 6 10 2 12 4 8 0) (15 11 7 3 13 9 5 1 14 10 6 2 12 8 4 0) (15 7 13 5 11 3 9 1 14 6 12 4 10 2 8 0) (15 11 13 9 7 3 5 1 14 10 12 8 6 2 4 0) (15 13 7 5 11 9 3 1 14 12 6 4 10 8 2 0) (15 13 11 9 7 5 3 1 14 12 10 8 6 4 2 0) (15 7 11 3 14 6 10 2 13 5 9 1 12 4 8 0) (15 11 7 3 14 10 6 2 13 9 5 1 12 8 4 0) (15 7 13 5 14 6 12 4 11 3 9 1 10 2 8 0) (15 11 13 9 14 10 12 8 7 3 5 1 6 2 4 0) (15 13 7 5 14 12 6 4 11 9 3 1 10 8 2 0) (15 13 11 9 14 12 10 8 7 5 3 1 6 4 2 0) (15 7 14 6 11 3 10 2 13 5 12 4 9 1 8 0) (15 11 14 10 7 3 6 2 13 9 12 8 5 1 4 0) (15 7 14 6 13 5 12 4 11 3 10 2 9 1 8 0) (15 11 14 10 13 9 12 8 7 3 6 2 5 1 4 0) (15 13 14 12 7 5 6 4 11 9 10 8 3 1 2 0) (15 13 14 12 11 9 10 8 7 5 6 4 3 1 2 0) (15 14 7 6 11 10 3 2 13 12 5 4 9 8 1 0) (15 14 11 10 7 6 3 2 13 12 9 8 5 4 1 0) (15 14 7 6 13 12 5 4 11 10 3 2 9 8 1 0) (15 14 11 10 13 12 9 8 7 6 3 2 5 4 1 0) (15 14 13 12 7 6 5 4 11 10 9 8 3 2 1 0))) (RPAQQ FOLD4S ((7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) (11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) (13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) (14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1))) (DEFINEQ (ALLPERMS (GLAMBDA (N:INTEGER) (* edited: "27-DEC-82 15:36") (* Generate a list of all permutations of length N. The identity permutation is always the first member of the list.) (RESULT (LISTOF PERMUTATION)) (DECLARE (SPECVARS LST)) (PROG (LST) (IF N>5 (ERROR "TOO MANY PERMUTATIONS!")) (GENPERMS NIL (IDPERM N)) (RETURN LST)))) (BINLIST (GLAMBDA (N,NBITS:INTEGER) (* edited: "28-DEC-82 11:26") (* Convert N to a list of bit values.) (RESULT (LISTOF INTEGER)) (PROG (L I BIT) (I_0) (BIT_1) (WHILE I<NBITS DO (L+_(IF (LOGAND N BIT)=0 THEN 0 ELSE 1)) (I_+1) (BIT_+BIT)) (RETURN L)))) (BITSHUFFLE [LAMBDA (INPUT LST) (* edited: " 6-MAY-82 16:33") (* Compute a bit-shuffle of the input according to the specification list LST. LST gives, for each output bit in order, the input bit from which it comes.) (PROG (RES) (SETQ RES 0) [MAPC LST (FUNCTION (LAMBDA (X) (SETQ RES (IPLUS (IPLUS RES RES) (COND ((NULL X) 0) ((NOT (NUMBERP X)) 1) ((ZEROP (LOGAND INPUT (BITPICK X))) 0) (T 1] (RETURN RES]) (COMPOSEBITSHUFFLES [LAMBDA (FIRST SECOND) (* edited: "23-JUN-82 15:17") (* Compose two bitshuffles to produce a single bitshuffle which is equivalent.) (PROG (L) (COND ((NOT (EQUAL (SETQ L (LENGTH FIRST)) (LENGTH SECOND))) (ERROR))) (RETURN (MAPCAR SECOND (FUNCTION (LAMBDA (X) (COND [(FIXP X) (CAR (NTH FIRST (IDIFFERENCE L X] (T X]) (DOBITSHUFFLE [LAMBDA (INT PERM) (* edited: "27-DEC-82 15:44") (BITSHUFFLE INT PERM]) (GENPERMS [GLAMBDA (PREV,L:(LISTOF INTEGER)) (* edited: "27-DEC-82 15:38") (* Generate all permutations consisting of the list PREV followed by all permutations of the list L. The permutations which are generated are added to the global LST. Called by ALLPERMS.) (GLOBAL LST:(LISTOF PERMUTATION)) (PROG (I TMP N) (IF ~L THEN LST+_PREV (RETURN)) (N_(LENGTH L)) (I_0) (WHILE (I_+1) <=N DO (TMP_(CAR (NTH L I))) (GENPERMS (PREV+TMP) (L - TMP]) (HISTO-ADD (GLAMBDA (H:HISTOGRAM N:INTEGER) (* edited: "30-DEC-82 13:26") (IF N>MAX OR N<MIN THEN (ERROR) ELSE TOTAL_+1 (CAR (NTH COUNTS (N - MIN + 1)))_+1) H)) (HISTO-CREATE (GLAMBDA (H:HISTOGRAM) (* edited: " 2-JAN-83 14:14") (RESULT HISTOGRAM) (* Initialize a histogram.) (TOTAL_0) (COUNTS_(LISTOFC 0 (MAX - MIN + 1))) H)) (HISTO-PEAKS [GLAMBDA (H:HISTOGRAM) (* edited: " 2-JAN-83 14:10") (PROG (THRESH L MX N) (MX_0) (FOR X IN COUNTS (IF X>MX MX_X)) (THRESH_MX/2) (N_MIN) (FOR X IN COUNTS DO (IF X>=THRESH L+_N) N_+1) (RETURN (DREVERSE L]) (IDPERM (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:23") (* Produce an identity permutation of length N.) (RESULT PERMUTATION) (PROG (L (I 0)) (WHILE I<N L+_I I_+1) (RETURN L)))) (LISTOFC (GLAMBDA (C N:INTEGER) (* edited: "28-DEC-82 11:23") (* Make a list of N copies of the constant C.) (RESULT (LISTOF ATOM)) (PROG (I L) (I_0) (WHILE (I_+1) <=N DO L+_C) (RETURN L)))) (LOG2 (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:07") (* Log to the base 2 of an integer, rounded up.) (RESULT INTEGER) (PROG ((I 0) (M 1)) (WHILE M<N DO I_+1 M_+M) (RETURN I)))) (NEGINPPERM (GLAMBDA (N,M:INTEGER) (* edited: "28-DEC-82 11:03") (* Compute the permutation to be applied to the output of a boolean function of N inputs to account for negating the Mth input.) (RESULT PERMUTATION) (PROG (TWON TWOM (I 0) L) (TWON_2^N) (TWOM_2^M) (WHILE I<TWON L+_(IF (LOGAND I TWOM) ~=0 THEN I - TWOM ELSE I+TWOM) I_+1) (RETURN L)))) (OUTPERMS (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:02") (* Create the set of permutations of the set of 2^N outputs corresponding to isomorphisms, i.e., renamings of the N inputs of a boolean function. The identity isomorphism is omitted.) (RESULT (LISTOF PERMUTATION)) (PROG (I TMP RES TWON) (TWON_2^N) (FOR X IN (CDR (ALLPERMS N)) DO (I_0) (TMP_NIL) (WHILE I<TWON DO (TMP+_(DOBITSHUFFLE I X)) (I_+1)) (RES+_TMP)) (RETURN RES)))) (PERM-INVERSE (GLAMBDA (P:PERMUTATION) (* edited: " 2-SEP-82 10:47") (RESULT PERMUTATION) (* edited: " 2-SEP-82 10:44") (* Compute the inverse of a permutation.) (PROG (LST N M (I 0) J PP TMP) (N_P:LENGTH) (WHILE I<N DO (J _ N - 1) (PP_P) [WHILE PP DO (IF (CAR PP)=I THEN LST+_J PP_NIL ELSE TMP-_PP J_-1 (IF ~PP (ERROR] (I_+1)) (RETURN LST)))) ) (PUTPROPS BITSHUFFLE GLRESULTTYPE INTEGER) (PUTPROPS DOBITSHUFFLE GLRESULTTYPE INTEGER) (DECLARE: DONTCOPY (FILEMAP (NIL (2528 9147 (ALLPERMS 2538 . 3071) (BINLIST 3073 . 3528) (BITSHUFFLE 3530 . 4122) ( COMPOSEBITSHUFFLES 4124 . 4654) (DOBITSHUFFLE 4656 . 4799) (GENPERMS 4801 . 5395) (HISTO-ADD 5397 . 5635) (HISTO-CREATE 5637 . 5902) (HISTO-PEAKS 5904 . 6268) (IDPERM 6270 . 6598) (LISTOFC 6600 . 6950) (LOG2 6952 . 7296) (NEGINPPERM 7298 . 7897) (OUTPERMS 7899 . 8504) (PERM-INVERSE 8506 . 9145))))) STOP |
Added psl-1983/3-1/glisp/permute.sl version [d2e84a5a6b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}PERMUTE.PSL;1 5-FEB-83 15:53:01 (GLISPOBJECTS (HISTOGRAM (LISTOBJECT (MIN INTEGER) (MAX INTEGER) (TOTAL INTEGER) (COUNTS (LISTOF INTEGER))) PROP ((PEAKS HISTO-PEAKS)) MSG ((CREATE HISTO-CREATE) (+ HISTO-ADD))) (PERMUTATION (LISTOF INTEGER) PROP ((LENGTH LENGTH) (INVERSE PERM-INVERSE RESULT PERMUTATION)) MSG ((* COMPOSEBITSHUFFLES RESULT PERMUTATION))) ) (SETQ PERM3S '((7 3 5 1 6 2 4 0) (7 5 3 1 6 4 2 0) (7 3 6 2 5 1 4 0) (7 5 6 4 3 1 2 0) (7 6 3 2 5 4 1 0))) (SETQ FOLD3S '((3 2 1 0 7 6 5 4) (5 4 7 6 1 0 3 2) (6 7 4 5 2 3 0 1))) (SETQ PERM4S '((15 7 11 3 13 5 9 1 14 6 10 2 12 4 8 0) (15 11 7 3 13 9 5 1 14 10 6 2 12 8 4 0) (15 7 13 5 11 3 9 1 14 6 12 4 10 2 8 0) (15 11 13 9 7 3 5 1 14 10 12 8 6 2 4 0) (15 13 7 5 11 9 3 1 14 12 6 4 10 8 2 0) (15 13 11 9 7 5 3 1 14 12 10 8 6 4 2 0) (15 7 11 3 14 6 10 2 13 5 9 1 12 4 8 0) (15 11 7 3 14 10 6 2 13 9 5 1 12 8 4 0) (15 7 13 5 14 6 12 4 11 3 9 1 10 2 8 0) (15 11 13 9 14 10 12 8 7 3 5 1 6 2 4 0) (15 13 7 5 14 12 6 4 11 9 3 1 10 8 2 0) (15 13 11 9 14 12 10 8 7 5 3 1 6 4 2 0) (15 7 14 6 11 3 10 2 13 5 12 4 9 1 8 0) (15 11 14 10 7 3 6 2 13 9 12 8 5 1 4 0) (15 7 14 6 13 5 12 4 11 3 10 2 9 1 8 0) (15 11 14 10 13 9 12 8 7 3 6 2 5 1 4 0) (15 13 14 12 7 5 6 4 11 9 10 8 3 1 2 0) (15 13 14 12 11 9 10 8 7 5 6 4 3 1 2 0) (15 14 7 6 11 10 3 2 13 12 5 4 9 8 1 0) (15 14 11 10 7 6 3 2 13 12 9 8 5 4 1 0) (15 14 7 6 13 12 5 4 11 10 3 2 9 8 1 0) (15 14 11 10 13 12 9 8 7 6 3 2 5 4 1 0) (15 14 13 12 7 6 5 4 11 10 9 8 3 2 1 0))) (SETQ FOLD4S '((7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) (11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) (13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) (14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1))) % edited: 27-DEC-82 15:36 % Generate a list of all permutations of length N. The identity % permutation is always the first member of the list. (DG ALLPERMS (N:INTEGER) (RESULT (LISTOF PERMUTATION)) % (SPECVARS LST) (PROG (LST) (IF N>5 (ERROR 0 "TOO MANY PERMUTATIONS!")) (GENPERMS NIL (IDPERM N)) (RETURN LST))) % edited: 28-DEC-82 11:26 % Convert N to a list of bit values. (DG BINLIST (N,NBITS:INTEGER) (RESULT (LISTOF INTEGER))(PROG (L I BIT) (I_0) (BIT_1) (WHILE I<NBITS DO (L+_ (IF (LOGAND N BIT) =0 THEN 0 ELSE 1)) (I_+1) (BIT_+BIT)) (RETURN L))) % edited: 6-MAY-82 16:33 % Compute a bit-shuffle of the input according to the specification % list LST. LST gives, for each output bit in order, the input bit % from which it comes. (DE BITSHUFFLE (INPUT LST) (PROG (RES) (SETQ RES 0) (MAPC LST (FUNCTION (LAMBDA (X) (SETQ RES (PLUS (PLUS RES RES) (COND ((NULL X) 0) ((NOT (NUMBERP X)) 1) ((ZEROP (LOGAND INPUT (BITPICK X))) 0) (T 1))))))) (RETURN RES))) % edited: 23-JUN-82 15:17 % Compose two bitshuffles to produce a single bitshuffle which is % equivalent. (DE COMPOSEBITSHUFFLES (FIRST SECOND) (PROG (L) (COND ((NOT (EQUAL (SETQ L (LENGTH FIRST)) (LENGTH SECOND))) (ERROR 0 NIL))) (RETURN (MAPCAR SECOND (FUNCTION (LAMBDA (X) (COND ((FIXP X) (CAR (PNth FIRST (DIFFERENCE L X)))) (T X)))))))) % edited: 27-DEC-82 15:44 (DE DOBITSHUFFLE (INT PERM) (BITSHUFFLE INT PERM)) % edited: 27-DEC-82 15:38 % Generate all permutations consisting of the list PREV followed by % all permutations of the list L. The permutations which are % generated are added to the global LST. Called by ALLPERMS. (DG GENPERMS (PREV,L: (LISTOF INTEGER)) (GLOBAL LST: (LISTOF PERMUTATION))(PROG (I TMP N) (IF ~L THEN LST+_PREV (RETURN NIL)) (N_ (LENGTH L)) (I_0) (WHILE (I_+1) <=N DO (TMP_ (CAR (PNth L I))) (GENPERMS (PREV+TMP) (L - TMP))))) % edited: 30-DEC-82 13:26 (DG HISTO-ADD (H:HISTOGRAM N:INTEGER) (IF N>MAX OR N<MIN THEN (ERROR 0 NIL) ELSE TOTAL_+1 (CAR (PNth COUNTS (N - MIN + 1))) _+1)H) % edited: 2-JAN-83 14:14 (DG HISTO-CREATE (H:HISTOGRAM) (RESULT HISTOGRAM)% Initialize a histogram. (TOTAL_0)(COUNTS_ (LISTOFC 0 (MAX - MIN + 1)))H) % edited: 2-JAN-83 14:10 (DG HISTO-PEAKS (H:HISTOGRAM) (PROG (THRESH L MX N) (MX_0) (FOR X IN COUNTS (IF X>MX MX_X)) (THRESH_MX/2) (N_MIN) (FOR X IN COUNTS DO (IF X>=THRESH L+_N) N_+1) (RETURN (REVERSIP L)))) % edited: 28-DEC-82 11:23 % Produce an identity permutation of length N. (DG IDPERM (N:INTEGER) (RESULT PERMUTATION)(PROG (L I) (SETQ I 0) (WHILE I<N L+_I I_+1) (RETURN L))) % edited: 28-DEC-82 11:23 % Make a list of N copies of the constant C. (DG LISTOFC (C N:INTEGER) (RESULT (LISTOF ATOM))(PROG (I L) (I_0) (WHILE (I_+1) <=N DO L+_C) (RETURN L))) % edited: 28-DEC-82 11:07 % Log to the base 2 of an integer, rounded up. (DG LOG2 (N:INTEGER) (RESULT INTEGER)(PROG (I M) (SETQ I 0) (SETQ M 1) (WHILE M<N DO I_+1 M_+M) (RETURN I))) % edited: 28-DEC-82 11:03 % Compute the permutation to be applied to the output of a boolean % function of N inputs to account for negating the Mth input. (DG NEGINPPERM (N,M:INTEGER) (RESULT PERMUTATION)(PROG (TWON TWOM I L) (SETQ I 0) (TWON_2^N) (TWOM_2^M) (WHILE I<TWON L+_ (IF (LOGAND I TWOM) ~=0 THEN I - TWOM ELSE I+TWOM) I_+1) (RETURN L))) % edited: 28-DEC-82 11:02 % Create the set of permutations of the set of 2^N outputs % corresponding to isomorphisms, i.e., renamings of the N inputs of % a boolean function. The identity isomorphism is omitted. (DG OUTPERMS (N:INTEGER) (RESULT (LISTOF PERMUTATION))(PROG (I TMP RES TWON) (TWON_2^N) (FOR X IN (CDR (ALLPERMS N)) DO (I_0) (TMP_NIL) (WHILE I<TWON DO (TMP+_ (DOBITSHUFFLE I X)) (I_+1)) (RES+_TMP)) (RETURN RES))) % edited: 2-SEP-82 10:47 (DG PERM-INVERSE (P:PERMUTATION) (RESULT PERMUTATION)% edited: 2-SEP-82 10:44 % Compute the inverse of a permutation. (PROG (LST N M I J PP TMP) (SETQ I 0) (N_P:LENGTH) (WHILE I<N DO (J _ N - 1) (PP_P) (WHILE PP DO (IF (CAR PP) =I THEN LST+_J PP_NIL ELSE TMP-_PP J_-1 (IF ~PP (ERROR 0 NIL)))) (I_+1)) (RETURN LST))) (PUT 'BITSHUFFLE 'GLRESULTTYPE 'INTEGER) (PUT 'DOBITSHUFFLE 'GLRESULTTYPE 'INTEGER) |
Added psl-1983/3-1/glisp/rawio.red version [45a78adf61].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % RAWIO.RED - Support routines for PSL Emode % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981, 1982 University of Utah % Modified and maintained by William F. Galway. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DEC-20 version FLUID '(!*rawio); % T if terminal is using "raw" i.o. CompileTime << load if!-system; load syslisp$ off UserMode; % csp 8/20/82 if_system(Dec20, << load monsym$ load jsys$ >>) >>; BothTimes if_system(Dec20, % CompileTime probably suffices. << FLUID '( % Global? OldCCOCWords OldTIW OldJFNModeWord ); lisp procedure BITS1 U; if not NumberP U then Error(99, "Non-numeric argument to BITS") else lsh(1, 35 - U); macro procedure BITS U; begin scalar V; V := 0; for each X in cdr U do V := lor(V, BITS1 X); return V; end; >>); LoadTime if_system(Dec20, << OldJfnModeWord := NIL; % Flag "modes not saved yet" lap '((!*entry PBIN expr 0) % Read a single character from the TTY as a Lisp integer (pbin) % Issue PBIN (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry PBOUT expr 1) % write a single charcter to the TTY, works for integers and single char IDs % Don't bother with Int2Sys? (pbout) (!*exit 0) ); lap '((!*entry CharsInInputBuffer expr 0) % Returns the number of characters in the terminal input buffer. (!*MOVE (WConst 8#101) (reg 1)) % The input file (the terminal, = % 8#101) (sibe) % skip if input buffer empty (skipa (reg 1) (reg 2)) % otherwise # chars in r2 (setz (reg 1) 0) % if skipped, then zero (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry RFMOD expr 1) % returns the JFN mode word as Lisp integer (hrrzs (reg 1)) (rfmod) (!*MOVE (reg 2) (reg 1)) % Get mode word from R2 (!*CALL Sys2Int) (!*exit 0) ); lap '((!*entry RFCOC expr 1) % returns the 2 CCOC words for JFN as dotted pair of Lisp integers (hrrzs (reg 1)) (rfcoc) (!*PUSH (reg 2)) % save the first word (!*MOVE (reg 3) (reg 1)) (!*CALL Sys2Int) % make second into number (exch (reg 1) (indexed (reg st) 0)) % grab first word, save % tagged 2nd word. (!*CALL Sys2Int) % make first into number (!*POP (reg 2)) (!*JCALL Cons) % and cons them together ); lap '((!*entry RTIW expr 1) % Returns terminal interrupt word for specified process, or -5 for entire job, % as Lisp integer (hrrzs (reg 1)) % strip tag (rtiw) (!*MOVE (reg 2) (reg 1)) % result in r2, return in r1 (!*JCALL Sys2Int) % return as Lisp integer ); lisp procedure SaveInitialTerminalModes(); % Save the terminal modes, if not already saved. if null OldJfnModeWord then << OldJFNModeWord := RFMOD(8#101); OldCCOCWords := RFCOC(8#101); OldTIW := RTIW(-5); >>; lap '((!*entry SFMOD expr 2) % SFMOD(JFN, ModeWord); % set program related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (sfmod) (!*exit 0) ); lap '((!*entry STPAR expr 2) % STPAR(JFN, ModeWord); % set device related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stpar) (!*exit 0) ); lap '((!*entry SFCOC expr 3) % SFCOC(JFN, CCOCWord1, CCOCWord2); % set control character output control for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*PUSH (reg 3)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (exch (reg 1) (indexed (reg st) 0)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (sfcoc) (!*exit 0) ); lap '((!*entry STIW expr 2) % STIW(JFN, ModeWord); % set terminal interrupt word for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stiw) (!*exit 0) ); lisp procedure EchoOff(); % A bit of a misnomer, perhaps "on_rawio" would be better. % Off echo, On formfeed, send all control characters % Allow input of 8-bit characters (meta key) if not !*rawio then % Avoid doing anything if already "raw mode" << SaveInitialTerminalModes(); % Note that 8#101, means "the terminal". % Clear bit 24 to turn echo off, % bits 28,29 turn off "translation" SFMOD(8#101, LAND(OldJFNModeWord, LNOT BITS(24, 28, 29))); % Set bit 0 to indicate "has mechanical tab" (so cntrl-L gets % through?). % Clear bit 34 to turn off cntrl-S/cntrl-Q STPAR(8#101, LAND(lor(OldJFNModeWord, BITS 1), LNOT BITS(34))); % More nonsense to turn off processing of control characters? SFCOC(8#101, LNOT(8#252525252525), LNOT(8#252525252525)); % Turn off terminal interrupts for entire job (-5), for everything % except cntrl-C (the bit number three that's one). STIW(-5,8#040000000000); !*rawio := T; % Turn on flag >>; lisp procedure EchoOn(); % Restore initial terminal echoing modes << % Avoid doing anything if OldJFNModeWord is NIL, means terminal mode % already "restored". if OldJFNModeWord then << SFMOD(8#101,OldJFNModeWord); STPAR(8#101,OldJFNModeWord); SFCOC(8#101,car OldCCOCWords,cdr OldCCOCWords); STIW(-5,OldTIW); >>; % Set to NIL so that things get saved again by % SaveInitialTerminalModes. (The terminal status may have been changed % between times.) OldJFNModeWord := NIL; !*rawio := NIL; % Indicate "cooked" i/o. >>; % Flush output buffer for stdoutput. (On theory that we're using buffered % I/O to speed things up.) Symbolic Procedure FlushStdOutputBuffer(); NIL; % Just a dummy routine for the 20. >> ); % END OF DEC-20 version. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % VAX Unix version LoadTime if_system(Unix, << % EchoOn, EchoOff, and CharsInInputBuffer are part of "kernel". Symbolic Procedure PBIN(); % Read a "raw character". NOTE--assumption that 0 gives terminal input. VaxReadChar(0); % Just call this with "raw mode" on. Symbolic Procedure PBOUT(chr); % NOTE ASSUMPTION that 1 gives terminal output. VaxWriteChar(1,chr); >>); % END OF Unix version. fluid '(!*EMODE); LoadTime << !*EMODE := NIL; Symbolic Procedure rawio_break(); % Redefined break handler to turn echoes back on after a break, unless % EMODE is running. << if !*rawio and not !*EMODE then EchoOn(); pre_rawio_break(); % May want to be paranoid and use a "catch(nil, % '(pre_rawio_break)" here. >>; % Carefully redefine the break handler. if null getd('pre_rawio_break) then << CopyD('pre_rawio_break, 'Break); CopyD('break, 'rawio_break); >>; >>; |
Added psl-1983/3-1/glisp/tlg.sl version [fb43fae755].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % TLG.SL.3 31 Jan. 83 G. Novak % Program to test speed of line graphics by filling a square with lines. (de TLG (WINDOW) (PROG (XMIN XMAX DELTA XA XB) (SETQ XMIN 100) (SETQ XMAX 500) (SETQ XA XMIN) (SETQ XB XMAX) (SETQ DELTA 4) LP (COND ((IGREATERP XA XMAX) (RETURN))) (DRAWLINE XA XMIN XB XMAX 1 (QUOTE PAINT) WINDOW) (DRAWLINE XMIN XA XMAX XB 1 (QUOTE PAINT) WINDOW) (SETQ XA (IPLUS XA DELTA)) (SETQ XB (IDIFFERENCE XB DELTA)) (GO LP))) |
Added psl-1983/3-1/glisp/vector.old version [847db88517].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % VECTOR.SL.3 28 Feb 83 % {DSK}VECTOR.PSL;1 5-FEB-83 15:48:43 (GLISPOBJECTS (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T)))) (DOLPHINREGION (LIST (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER)) PROP ((START (self) RESULT VECTOR) (SIZE ((CDDR self)) RESULT VECTOR)) SUPERS (REGION)) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'PAINT))) (ERASE ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'ERASE))) (MOVE GRAPHICSOBJECTMOVE OPEN T))) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T)))) (REGION (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (TOPCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = TOP))) (BOTTOMCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = BOTTOM))) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T) (SETPOSITION REGION-SETPOSITION OPEN T) (CENTEROFFSET REGION-CENTEROFFSET OPEN T))) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR)) (SYMMETRY INTEGER PROP ((SWAPXY ((LOGAND self 4) <>0)) (INVERTY ((LOGAND self 2) <>0)) (INVERTX ((LOGAND self 1) <>0)))) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (IMAGNITUDE ((FIX MAGNITUDE + .9999))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y= Y/MAGNITUDE)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T) (/ VECTORQUOTIENT OPEN T) (> VECTORGREATERP OPEN T) (<= VECTORLEQP OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI))))) ) % edited: 11-JAN-82 12:40 (DG DRAWRECT ((A GRAPHICSOBJECT) DSPOP:ATOM) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS))) % edited: 11-JAN-82 16:07 (DG GRAPHICSOBJECTMOVE (self:GRAPHICSOBJECT DELTA:VECTOR) (_ self ERASE)(START _+ DELTA)(_ self DRAW)) % GSN 30-JAN-83 15:44 % Transform the starting point of an object as appropriate for the % specified symmetry transform. (DG NEWSTART (START:VECTOR SIZE:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_SIZE:X) (H_SIZE:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H_0) (IF ~SYM:INVERTX THEN W_0) (RETURN (A (TYPEOF START) WITH X = START:X+W Y = START:Y+H)))) % GSN 30-JAN-83 15:44 % Transform a given relative POINT for specified symmetry transform. (DG NEWPOINT (START:VECTOR POINT:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_POINT:X) (H_POINT:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H _ - H) (IF ~SYM:INVERTX THEN W _ - W) (RETURN (A (TYPEOF POINT) WITH X = START:X+W Y = START:Y+H)))) % GSN 2-FEB-83 14:00 (DG REGION-CENTEROFFSET (R:REGION V:VECTOR) (A (TYPEOF V) WITH X = (R:WIDTH - V:X) /2 Y = (R:HEIGHT - V:Y) /2)) % edited: 26-OCT-82 11:45 % Test whether an area contains a point P. (DG REGION-CONTAINS (AREA P) (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)) % GSN 30-JAN-83 15:45 (DG REGION-INTERSECT (P:AREA Q:AREA) (RESULT (TYPEOF P)) % Produce an AREA which is the intersection of two given AREAs. (PROG (NEWBOTTOM NEWLEFT NEWAREA XSIZE YSIZE) (NEWBOTTOM _ (IMAX P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMIN P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMAX P:LEFT Q:LEFT)) (XSIZE _ (IMIN P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (IF XSIZE>0 AND YSIZE>0 THEN NEWAREA:LEFT_NEWLEFT NEWAREA:BOTTOM_NEWBOTTOM NEWAREA:WIDTH_XSIZE NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 14-JAN-83 11:52 % Change the START point of AREA so that the position APOS relative to % the area will have the position NEWPOS. (DG REGION-SETPOSITION (AREA APOS:VECTOR NEWPOS:VECTOR) (AREA:START _+ NEWPOS - APOS)) % GSN 30-JAN-83 15:46 (DG REGION-UNION (P:AREA Q:AREA) (RESULT (TYPEOF P))% Produce an AREA which is the union of two given AREAs. (PROG (NEWBOTTOM NEWLEFT XSIZE YSIZE NEWAREA) (NEWBOTTOM _ (IMIN P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMAX P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMIN P:LEFT Q:LEFT)) (XSIZE _ (IMAX P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (NEWAREA:LEFT_NEWLEFT) (NEWAREA:BOTTOM_NEWBOTTOM) (NEWAREA:WIDTH_XSIZE) (NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 30-JAN-83 15:36 (DG VECTORPLUS (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) % GSN 30-JAN-83 15:47 (DG VECTORDIFF (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) % GSN 14-JAN-83 12:33 % This version of > tests whether one box will fit inside the other. (DG VECTORGREATERP (U:VECTOR V:VECTOR) (U:X>V:X OR U:Y>V:Y)) % GSN 14-JAN-83 12:31 (DG VECTORLEQP (U:VECTOR V:VECTOR) (U:X<=V:X AND U:Y<=V:Y)) % GSN 30-JAN-83 15:47 (DG VECTORTIMES (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X*N Y = Y*N)) % GSN 30-JAN-83 15:47 (DG VECTORQUOTIENT (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X/N Y = Y/N)) % GSN 23-JAN-83 16:28 (DG VECTORMOVE (V:VECTOR DELTA:VECTOR) (V:X _+ DELTA:X)(V:Y _+ DELTA:Y)V) (PUT 'RECTANGLE 'DRAWFN 'DRAWRECT) |
Added psl-1983/3-1/glisp/vector.sl version [c908cd681b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}VECTOR.PSL;1 4-MAR-83 16:25:56 (GLISPOBJECTS (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T)))) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'PAINT))) (ERASE ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'ERASE))) (MOVE GRAPHICSOBJECTMOVE OPEN T))) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T)))) (REGION (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (TOPCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = TOP))) (BOTTOMCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = BOTTOM))) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T) (SETPOSITION REGION-SETPOSITION OPEN T) (CENTEROFFSET REGION-CENTEROFFSET OPEN T))) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR)) (SYMMETRY INTEGER PROP ((SWAPXY ((LOGAND self 4) <>0)) (INVERTY ((LOGAND self 2) <>0)) (INVERTX ((LOGAND self 1) <>0)))) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (IMAGNITUDE ((FIX MAGNITUDE + .9999))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y = Y/MAGNITUDE)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T ARGTYPES (VECTOR)) (- VECTORDIFF OPEN T ARGTYPES (VECTOR)) (* VECTORTIMES OPEN T ARGTYPES (NUMBER)) (* VECTORDOTPRODUCT OPEN T ARGTYPES (VECTOR)) (/ VECTORQUOTIENT OPEN T ARGTYPES (NUMBER)) (> VECTORGREATERP OPEN T ARGTYPES (VECTOR)) (<= VECTORLEQP OPEN T ARGTYPES (VECTOR)) (_+ VECTORMOVE OPEN T ARGTYPES (VECTOR)) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI))))) ) % edited: 11-JAN-82 12:40 (DG DRAWRECT ((A GRAPHICSOBJECT) DSPOP:ATOM) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS))) % edited: 11-JAN-82 16:07 (DG GRAPHICSOBJECTMOVE (self:GRAPHICSOBJECT DELTA:VECTOR) (_ self ERASE)(START _+ DELTA)(_ self DRAW)) % GSN 30-JAN-83 15:44 % Transform the starting point of an object as appropriate for the % specified symmetry transform. (DG NEWSTART (START:VECTOR SIZE:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_SIZE:X) (H_SIZE:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H_0) (IF ~SYM:INVERTX THEN W_0) (RETURN (A (TYPEOF START) WITH X = START:X+W Y = START:Y+H)))) % GSN 30-JAN-83 15:44 % Transform a given relative POINT for specified symmetry transform. (DG NEWPOINT (START:VECTOR POINT:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_POINT:X) (H_POINT:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H _ - H) (IF ~SYM:INVERTX THEN W _ - W) (RETURN (A (TYPEOF POINT) WITH X = START:X+W Y = START:Y+H)))) % GSN 2-FEB-83 14:00 (DG REGION-CENTEROFFSET (R:REGION V:VECTOR) (A (TYPEOF V) WITH X = (R:WIDTH - V:X) /2 Y = (R:HEIGHT - V:Y) /2)) % edited: 26-OCT-82 11:45 % Test whether an area contains a point P. (DG REGION-CONTAINS (AREA P) (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)) % GSN 28-FEB-83 16:03 (DG REGION-INTERSECT (P:AREA Q:AREA) (RESULT (TYPEOF P)) % Produce an AREA which is the intersection of two given AREAs. (PROG (NEWBOTTOM NEWLEFT NEWAREA XSIZE YSIZE) (NEWBOTTOM _ (IMAX P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMIN P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMAX P:LEFT Q:LEFT)) (XSIZE _ (IMIN P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (IF XSIZE>0 AND YSIZE>0 THEN NEWAREA:LEFT_NEWLEFT NEWAREA:BOTTOM_NEWBOTTOM NEWAREA:WIDTH_XSIZE NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 14-JAN-83 11:52 % Change the START point of AREA so that the position APOS relative to % the area will have the position NEWPOS. (DG REGION-SETPOSITION (AREA APOS:VECTOR NEWPOS:VECTOR) (AREA:START _+ NEWPOS - APOS)) % GSN 28-FEB-83 16:04 (DG REGION-UNION (P:AREA Q:AREA) (RESULT (TYPEOF P)) % Produce an AREA which is the union of two given AREAs. (PROG (NEWBOTTOM NEWLEFT XSIZE YSIZE NEWAREA) (NEWBOTTOM _ (IMIN P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMAX P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMIN P:LEFT Q:LEFT)) (XSIZE _ (IMAX P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (NEWAREA:LEFT_NEWLEFT) (NEWAREA:BOTTOM_NEWBOTTOM) (NEWAREA:WIDTH_XSIZE) (NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 10-FEB-83 13:41 (DG VECTORPLUS (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) % GSN 10-FEB-83 13:41 (DG VECTORDIFF (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) % GSN 10-FEB-83 13:42 (DG VECTORDOTPRODUCT (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X * V2:X Y = V1:Y * V2:Y)) % GSN 14-JAN-83 12:33 % This version of > tests whether one box will fit inside the other. (DG VECTORGREATERP (U:VECTOR V:VECTOR) (U:X>V:X OR U:Y>V:Y)) % GSN 14-JAN-83 12:31 (DG VECTORLEQP (U:VECTOR V:VECTOR) (U:X<=V:X AND U:Y<=V:Y)) % GSN 10-FEB-83 13:41 (DG VECTORTIMES (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X*N Y = Y*N)) % GSN 10-FEB-83 13:42 (DG VECTORQUOTIENT (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X/N Y = Y/N)) % GSN 10-FEB-83 13:43 (DG VECTORMOVE (V:VECTOR DELTA:VECTOR) (V:X _+ DELTA:X)(V:Y _+ DELTA:Y)V) (PUT 'RECTANGLE 'DRAWFN 'DRAWRECT) |
Added psl-1983/3-1/glisp/window.old version [19941b3743].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WINDOW.SL 28 Feb 83 % {DSK}WINDOW.PSL;1 5-FEB-83 15:51:00 % GSN 2-FEB-83 13:57 (DG WINDOW-CENTEROFFSET (W:WINDOW V:VECTOR) (SEND W:REGION CENTEROFFSET V)) % GSN 13-JAN-83 16:28 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 'PAINT W)) % GSN 13-JAN-83 15:29 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (MOVETO POS:X POS:Y W)) % GSN 13-JAN-83 16:25 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION 'PAINT W)) (PRIN1 S W) (DSPOPERATION LASTWOP W))) % GSN 13-JAN-83 16:28 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 'ERASE W)) % GSN 13-JAN-83 16:24 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION 'ERASE W)) (PRIN1 S W) (DSPOPERATION LASTWOP W))) (GLISPOBJECTS (WINDOW ANYTHING PROP ((REGION ((DSPCLIPPINGREGION NIL self)) RESULT DOLPHINREGION) (XPOSITION ((DSPXPOSITION NIL self)) RESULT INTEGER) (YPOSITION ((DSPYPOSITION NIL self)) RESULT INTEGER) (HEIGHT (REGION:HEIGHT)) (WIDTH (REGION:WIDTH)) (LEFT ((DSPXOFFSET NIL self)) RESULT INTEGER) (BOTTOM ((DSPYOFFSET NIL self)) RESULT INTEGER) (START (REGION:START)) (SIZE (REGION:SIZE))) MSG ((CLEAR CLEARW) (OPEN OPENW) (CLOSE CLOSEW))) ) |
Added psl-1983/3-1/glisp/window.sl version [3541800032].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WINDOW.SL.10 28 March 83 % derived from {DSK}WINDOW.PSL;1 4-MAR-83 16:25:00 (glispconstants (screenxoffset -255 integer) (screenyoffset -255 integer) (screenxscale 256.0 real) (screenyscale 256.0 real) ) (GLISPOBJECTS (MENU (listobject (ITEMS (LISTOF ATOM)) (window window)) MSG ((SELECT MENU-select RESULT ATOM))) (MOUSE ANYTHING) (grpos integer prop ((screenvalue ((self + screenxoffset) / screenxscale )))) (grvector (list (x grpos) (y grpos)) supers (vector)) (WINDOW (listobject (start grvector) (size grvector) (title string) (lastfilledline integer) (lastposition grvector)) PROP ((leftmargin (left + 1)) (rightmargin (right - 2))) MSG ((CLEAR window-clear) (OPEN window-open) (CLOSE window-close) (movetoxy window-movetoxy OPEN T) (INVERTAREA WINDOW-INVERTAREA) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (printatxy window-printatxy) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (unprintatxy window-unprintatxy) (DRAWLINE WINDOW-DRAWLINE OPEN T) (drawlinexy window-drawlinexy OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (undrawlinexy window-undrawlinexy OPEN T) (CENTEROFFSET WINDOW-CENTEROFFSET)) supers (region) ) ) (GLISPGLOBALS (MOUSE MOUSE) ) (glispconstants (windowcharwidth 8 integer) (windowlineyspacing 20 integer) ) (setq mouse 'mouse) (setq gevmenuwindow nil) (setq menustart (a vector with x = 320 y = 0)) % Initialize graphics routines. (dg window-init (w:window) (prog () (graphics-init) (color-display) (set-color white) (set-line-style solid) (set-char-size (quotient 7.0 screenxscale) (quotient 16.0 screenyscale)) )) % Done with graphics (dg window-term (w:window) (prog () (graphics-term))) % Alias graphics function names without underline characters (de graphics-init () (graphics_init)) (de graphics-term () (graphics_term)) (de display-init (unit mode) (display_init unit mode)) (de set-color (x) (set_color x)) (de set-line-style (x) (set_line_style x)) (de clear-display () (clear_display)) (de set-char-size (w h) (set_char_size w h)) (de set-text-rot (x y) (set_text_rot x y)) (de set-display-lim (x0 x1 y0 y1) (set_display_lim x0 x1 y0 y1)) (de set-viewport (x0 x1 y0 y1) (set_viewport x0 x1 y0 y1)) (de init-9111 () (init_9111)) (de sample-locator () (sample_locator)) (de await-locator () (await_locator)) (de color-display () (color_display)) % Clear a graphics window. (dg window-clear (w:window) ) % Open a graphics window. (dg window-open (w:window) (send w drawlinexy w:left w:bottom w:left w:top) (send w drawlinexy w:left w:top w:right w:top) (send w drawlinexy w:right w:top w:right w:bottom) (send w drawlinexy w:right w:bottom w:left w:bottom) ) % Open a graphics window. (dg window-close (w:window) (send w undrawlinexy w:left w:bottom w:left w:top) (send w undrawlinexy w:left w:top w:right w:top) (send w undrawlinexy w:right w:top w:right w:bottom) (send w undrawlinexy w:right w:bottom w:left w:bottom) ) % GSN 2-MAR-83 16:19 (DG MOUSE-POSITIONIN (M:MOUSE W:WINDOW) (GETMOUSESTATE)(A VECTOR WITH X = (LASTMOUSEX W) Y = (LASTMOUSEY W))) % GSN 2-MAR-83 16:19 (DG MOUSE-TESTBUTTON (M:MOUSE BUTTON:INTEGER) (GETMOUSESTATE)(NOT (ZEROP (LOGAND LASTMOUSEBUTTONS BUTTON)))) % GSN 2-FEB-83 13:57 (DG WINDOW-CENTEROFFSET (W:WINDOW V:VECTOR) (SEND W:REGION CENTEROFFSET V)) % GSN 28-FEB-83 16:10 (DG WINDOW-DRAWLINE (W:WINDOW FROM:grVECTOR TO:grVECTOR) (send w drawlinexy from:x from:y to:x to:y)) (DG WINDOW-DRAWLINExy (W:WINDOW fromx:grpos fromy:grpos tox:grpos toy:grpos) (gdraw white solid fromx:screenvalue fromy:screenvalue tox:screenvalue toy:screenvalue)) % GSN 28-FEB-83 16:58 (DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION) nil) % GSN 13-JAN-83 15:29 (DG WINDOW-MOVETO (W:WINDOW POS:grVECTOR) (send w movetoxy pos:x pos:y)) % Move to position specified as separate x and y coordinates. (dg window-movetoxy (w:window x:grpos y:grpos) (gmove x:screenvalue y:screenvalue)) % GSN 2-MAR-83 13:58 (DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:grVECTOR) (set-color white) (send w moveto pos) (w:lastposition _ position) (gtext value)) % GSN 13-JAN-83 16:25 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:grVECTOR) (set-color white) (send w moveto pos) (gtext s)) (DG WINDOW-PRINTATxy (W:WINDOW S:STRING x:grpos y:grpos) (set-color white) (send w movetoxy x y) (gtext s)) % GSN 28-FEB-83 16:11 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:grVECTOR) (send w undrawlinexy from:x from:y to:x to:y)) (DG WINDOW-unDRAWLINExy (W:WINDOW fromx:grpos fromy:grpos tox:grpos toy:grpos) (gdraw background solid fromx:screenvalue fromy:screenvalue tox:screenvalue toy:screenvalue)) % GSN 13-JAN-83 16:24 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:grVECTOR) (set-color background) (send w moveto pos) (gtext s)) (DG WINDOW-UNPRINTATxy (W:WINDOW S:STRING x:grpos y:grpos) (set-color background) (send w movetoxy x y) (gtext s)) % Present a pop-up menu and select an item from it. GSN 14 March 83 (dg menu-select (m:menu) (prog (maxw i n saveglq result) (if ~gevactiveflg then (geventer)) (saveglq _ glquietflg) (glquiteflg _ t) (maxw _ 0) (for x in m:items do (maxw _ (max maxw x:pname:length))) (maxw _ (min maxw 20)) (m:window _ (a window with start = menustart size = (a vector with x = (maxw + 5)* windowcharwidth y = (min (length m:items) 19) * windowlineyspacing) title = "Menu")) (send m:window open) (I _ 0) (for x in m:items do (i _+ 1) (send m:window printatxy (concat (gevstringify i) (concat (if i<10 then " " else " ") (gevstringify x))) 1 (m:window:height - i * windowlineyspacing) )) lp (prin2 "Menu:") (n _ (read)) (if n is integer and n > 0 and n <= (length m:items) then (result _ (car (PNth m:items n))) (go out) elseif n = 'q then (result _ nil) (go out) else (prin1 n) (prin2 " ?") (terpri) (go lp) ) out (setq glquietflg saveglq) (if ~gevactiveflg then (gevexit)) (return result) )) |
Added psl-1983/3-1/glisp/window20.sl version [577a99be45].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}WINDOW.PSL;1 4-MAR-83 16:25:00 (GLISPOBJECTS (MENU (listobject (ITEMS (LISTOF ATOM)) (window window)) MSG ((SELECT MENU-select RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (listobject (start vector) (size vector) (title string) (lastfilledline integer)) PROP ((leftmargin (left + 1)) (rightmargin (right - 2))) MSG ((CLEAR window-clear) (OPEN window-open) (CLOSE window-close) (movetoxy window-movetoxy) (invertvideo ((pbout escapechar)(pbout (char !p)))) (normalvideo ((pbout escapechar)(pbout (char !q)))) (graphicsmode (nil)) (normalmode (nil)) (eraseeol ((pbout escapechar)(pbout (char K)))) (INVERTAREA WINDOW-INVERTAREA) (MOVETO WINDOW-MOVETO) (PRINTAT WINDOW-PRINTAT) (printatxy window-printatxy) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT) (UNPRINTAT WINDOW-UNPRINTAT) (unprintatxy window-unprintatxy) (DRAWLINE WINDOW-DRAWLINE) (drawlinexy window-drawlinexy) (UNDRAWLINE WINDOW-UNDRAWLINE) (undrawlinexy window-undrawlinexy) (CENTEROFFSET WINDOW-CENTEROFFSET)) supers (region) ) ) (GLISPGLOBALS (MOUSE MOUSE) ) (glispconstants (windowcharwidth 8 integer) (windowlineyspacing 12 integer) (verticalbarchar 73 integer) (horizontalbarchar 33 integer) (escapechar 27 integer) (blankchar 32 integer) ) % Initialize graphics routines. (dg window-init (w:window) ) % Done with graphics (dg window-term (w:window) ) % Open a graphics window. (dg window-open (w:window) (prog (ttl nbl) (send w movetoxy w:left + 1 w:top) (ttl _ w:title or " ") (l _ ttl:length) (send w invertvideo) (if ttl:length > w:width - 2 then (ttl _ (substring ttl 1 w:width - 2))) (nbl _ (w:width - ttl:length)/2 - 1) (printnc nbl blankchar) (prin2 ttl) (printnc (w:width - ttl:length - nbl - 2) blankchar) (send w normalvideo) (terpri) (w:lastfilledline _ w:bottom + 1) (send w movetoxy w:left w:top) (pbout verticalbarchar) (send w movetoxy w:right - 1 w:top) (pbout verticalbarchar) (send w movetoxy w:left w:bottom) (pbout verticalbarchar) (printnc w:width - 2 horizontalbarchar) (pbout verticalbarchar) (terpri) (send w clear) (send w movetoxy 0 2)) ) % Close a graphics window. (dg window-close (w:window) ) % GSN 2-FEB-83 13:57 (DG WINDOW-CENTEROFFSET (W:WINDOW V:VECTOR) (SEND W:REGION CENTEROFFSET V)) % GSN 28-FEB-83 16:10 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (if from:y=to:y then (send w moveto from) (printnc (to:x - from:x + 1) horizontalbarchar))) % GSN 28-FEB-83 16:58 (DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION) nil) % GSN 13-JAN-83 15:29 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (send w movetoxy pos:x pos:y)) % Move to position specified as separate x and y coordinates. (dg window-movetoxy (w:window x:integer y:integer) (if x < 0 then (x _ 0) elseif x > 79 then (x _ 79)) (if y < 0 then (y _ 0) elseif Y > 23 then (y _ 23)) (pbout escapechar) (pbout (char Y)) (pbout (55 - y)) (pbout (32 + x))) % GSN 2-MAR-83 13:58 (DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:VECTOR) (send w printat value position)) % GSN 13-JAN-83 16:25 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (send w moveto pos) (prin2 s)) % GSN 28-FEB-83 16:10 (DG WINDOW-unDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (if from:y=to:y then (send w moveto from) (printnc (to:x - from:x + 1) blankchar))) % GSN 13-JAN-83 16:24 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (send w moveto pos) (printnc s:length " ")) % Present a pop-up menu and select an item from it. GSN 14 March 83 (dg menu-select (m:menu) (prog (maxw i n) (maxw _ 0) (for x in m:items do (maxw _ (max maxw x:pname:length))) (maxw _ (min maxw 20)) (m:window _ (a window with start = menustart size = (a vector with x = (maxw + 5)* windowcharwidth y = (min (length n:items) 19) * windowlineyspacing) title = "Menu")) (send m:window open) (I _ 0) (for x in m:items do (i _+ 1) (send m:window printatxy (concat (gevstringify i) (if i<10 then " " else " ") (gevstringify x)))) (send m:window movetoxy 0 2) (send m:window eraseeol) lp (send m:window movetoxy 0 2) (prin2 "Menu:") (n _ (read)) (if n is integer and n > 0 and n <= (length m:items) then (return (nth m:items n)) else (prin1 n) (prin2 " ?") (send m:window eraseeol) (go lp) ))) % Print the same character n times. (dg printnc (n:integer c:integer) (while n > 0 do (n _- 1) (prin2 c))) (dg window-clear (w:window) (prog (y) (y _ w:top - 1) (while y >= w:lastfilledline do (send w movetoxy w:left y) (prin2 verticalbarchar) (send w eraseeol) (send w movetoxy w:right - 1 y) (prin2 verticalbarchar) (y _- 1)) )) |
Added psl-1983/3-1/glisp/windowcrt.sl version [cd953a2d41].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WINDOWCRT.SL.11 07 April 83 % derived from <NOVAK>WINDOWCRT.PSL.1 20-Mar-83 12:40:45 % Written by Gordon Novak Jr. % Copyright (c) 1983 Hewlett-Packard (GLOBAL '(MENUSTART)) (GLISPOBJECTS (MENU (LISTOBJECT (ITEMS (LISTOF ATOM)) (WINDOW WINDOW)) MSG ((SELECT MENU-SELECT RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (LISTOBJECT (START VECTOR) (SIZE VECTOR) (TITLE STRING) (LASTFILLEDLINE INTEGER)) PROP ((YPOSITION (LASTFILLEDLINE)) (LEFTMARGIN (1)) (RIGHTMARGIN (WIDTH - 2))) MSG ((CLEAR WINDOW-CLEAR) (OPEN WINDOW-OPEN) (CLOSE WINDOW-CLOSE) (INVERTAREA WINDOW-INVERTAREA OPEN T) (MOVETOXY WINDOW-MOVETOXY OPEN T) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (CENTEROFFSET WINDOW-CENTEROFFSET OPEN T)) SUPERS (REGION)) ) (GLISPGLOBALS (MOUSE MOUSE) ) (GLISPCONSTANTS (WINDOWCHARWIDTH 1 INTEGER) (WINDOWLINEYSPACING 1 INTEGER) ) (SETQ MOUSE 'MOUSE) (SETQ GEVMENUWINDOW NIL) (SETQ MENUSTART (A VECTOR WITH X = 50 Y = 3)) % edited: 16-Mar-83 15:04 % Select an item from a pop-up menu. (DG MENU-SELECT (M:MENU) (PROG (MAXW I N SAVEESC SAVEGLQ SAVEGCG RESULT) (if ~gevactiveflg then (geventer)) (SAVEGLQ _ GLQUIETFLG) (GLQUIETFLG _ T) (MAXW_0) (FOR X IN M:ITEMS DO (MAXW_ (MAX MAXW X:PNAME:LENGTH))) (IF MAXW > 20 THEN (MAXW _ 20)) (M:WINDOW _ (A WINDOW WITH START = MENUSTART SIZE = (A VECTOR WITH X = (MAXW + 5) *WINDOWCHARWIDTH Y = (MIN (LENGTH M:ITEMS) + 1 19) *WINDOWLINEYSPACING) TITLE = "Menu")) (SEND M:WINDOW OPEN) (I_0) (FOR X IN M:ITEMS DO (I _+ 1) (SEND M:WINDOW PRINTAT (CONCAT (GEVSTRINGIFY I) (concat (IF I<10 THEN " " ELSE " ") (gevstringify X))) (A VECTOR WITH X = 1 Y = M:WINDOW:HEIGHT - I))) (SEND M:WINDOW MOVETOXY 0 -1) (SEND TERMINAL ERASEEOL) LP (SEND M:WINDOW MOVETOXY 0 -1) (SEND TERMINAL PRINTSTRING "Menu: ") (SEND TERMINAL ERASEEOL) (echoon) (N _ (READ)) (echooff) (IF N IS INTEGER AND N>0 AND N<= (LENGTH M:ITEMS) THEN (RESULT _ (CAR (PNth M:ITEMS N))) (GO OUT) ELSEIF N = 'Q THEN (RESULT _ NIL) (GO OUT) ELSE (PRIN1 N) (SPACES 1) (SEND TERMINAL PRINTSTRING "?") (SEND TERMINAL ERASEEOL) (GO LP)) OUT (SEND M:WINDOW CLOSE) (SEND M:WINDOW MOVETOXY 0 -1) (TERPRI) (SEND TERMINAL ERASEEOL) (SETQ GLQUIETFLG SAVEGLQ) (if ~gevactiveflg then (gevexit)) (RETURN RESULT))) % edited: 11-Mar-83 22:42 % Print a character N times. (DG PRINTNC (N:INTEGER C:STRING) (WHILE N > 0 DO (N _- 1) (SEND TERMINAL PRINTCHAR C))) % edited: 16-Mar-83 14:02 % Open a window in a H-19 terminal. (DG WINDOW-CLEAR (W:WINDOW) (PROG (TTL NBL Y NLINES) (NLINES_0) (SEND TERMINAL GRAPHICSMODE) (Y _ W:HEIGHT - 1) (WHILE Y >= W:LASTFILLEDLINE DO (SEND W MOVETOXY 0 Y) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (IF Y<W:TOP THEN (SEND TERMINAL ERASEEOL)) (SEND W MOVETOXY W:WIDTH - 1 Y) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (IF (NLINES _+ 1) >3 THEN (TERPRI) (NLINES_0)) (Y_-1)) (SEND TERMINAL NORMALMODE) (SEND W MOVETOXY 0 -1) (TERPRI) (W:LASTFILLEDLINE _ W:HEIGHT) (SEND W MOVETOXY 0 -1))) (DG WINDOW-CLOSE (W:WINDOW) (PROG (Y NLINES) (Y _ W:HEIGHT) (NLINES _ 0) (WHILE Y >= 0 DO (SEND W MOVETOXY 0 Y) (SEND TERMINAL ERASEEOL) (IF (NLINES _+ 1) > 8 THEN (TERPRI) (NLINES _ 0)) (Y _- 1)) (TERPRI))) % edited: 12-Mar-83 15:22 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (IF FROM:Y=TO:Y THEN (SEND W MOVETO FROM) (PRINTNC (TO:X - FROM:X + 1) HORIZONTALLINECHAR) (IF FROM:Y < W:LASTFILLEDLINE THEN (W:LASTFILLEDLINE _ FROM:Y)))) % edited: 12-Mar-83 15:17 (DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION) NIL) % edited: 12-Mar-83 15:18 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (SEND W MOVETOXY POS:X POS:Y)) % edited: 19-Mar-83 20:25 % Move cursor to X-Y position relative to window. (DG WINDOW-MOVETOXY (W:WINDOW X:INTEGER Y:INTEGER) (SEND TERMINAL MOVETOXY X+W:LEFT Y+W:BOTTOM)) % edited: 19-Mar-83 20:39 % Open a window on a H-19 terminal. (DG WINDOW-OPEN (W:WINDOW) (PROG (TTL NBL L) (SEND W MOVETOXY 1 W:HEIGHT) (TTL _ W:TITLE OR " ") (L_TTL:LENGTH) (SEND TERMINAL INVERTVIDEO) (IF TTL:LENGTH > W:WIDTH - 2 THEN (TTL _ (SUBSTRING TTL 1 W:WIDTH - 2))) (NBL _ (W:WIDTH - TTL:LENGTH) /2 - 1) (PRINTNC NBL BLANKCHAR) (SEND TERMINAL PRINTSTRING TTL) (PRINTNC (W:WIDTH - TTL:LENGTH - NBL - 2) BLANKCHAR) (SEND TERMINAL NORMALVIDEO) (TERPRI) (SEND TERMINAL GRAPHICSMODE) (W:LASTFILLEDLINE _ 1) (SEND W MOVETOXY 0 W:HEIGHT) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (SEND W MOVETOXY W:WIDTH - 1 W:HEIGHT) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (SEND W MOVETOXY 0 0) (SEND TERMINAL PRINTCHAR LVERTICALBARCHAR) (PRINTNC W:WIDTH - 2 HORIZONTALBARCHAR) (SEND TERMINAL PRINTCHAR RVERTICALBARCHAR) (send terminal eraseeol) (SEND TERMINAL NORMALMODE) (TERPRI) (SEND W CLEAR) (SEND W MOVETOXY 0 -1))) % edited: 12-Mar-83 17:03 (DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:VECTOR) (SEND W MOVETO POSITION)(RESETLST (RESETSAVE SYSPRETTYFLG T) (RESETSAVE TTYLINELENGTH (W:WIDTH - POSITION:X - 1)) (SHOWPRINT VALUE) (W:LASTFILLEDLINE _ 1))) % edited: 16-Mar-83 14:18 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (SEND TERMINAL PRINTSTRING S) (TERPRI) (IF POS:Y < W:LASTFILLEDLINE THEN (W:LASTFILLEDLINE _ POS:Y)))) % edited: 12-Mar-83 15:23 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (IF FROM:Y=TO:Y THEN (SEND W MOVETO FROM) (PRINTNC (TO:X - FROM:X + 1) BLANKCHAR))) % edited: 16-Mar-83 14:19 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (PRINTNC S:LENGTH BLANKCHAR))) |
Added psl-1983/3-1/glisp/windowhrd.sl version [fa68ce3b42].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WINDOWHRD.SL.7 07 April 83 % Window package for Methius display on HP 9836 % derived from <NOVAK>WINDOWCRT.PSL.1 20-Mar-83 12:40:45 (GLOBAL '(MENUSTART)) (GLISPOBJECTS (MENU (LISTOBJECT (ITEMS (LISTOF ATOM)) (WINDOW WINDOW)) MSG ((SELECT MENU-SELECT RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (LISTOBJECT (START VECTOR) (SIZE VECTOR) (TITLE STRING) (LASTFILLEDLINE INTEGER)) PROP ((YPOSITION (LASTFILLEDLINE)) (LEFTMARGIN (1)) (RIGHTMARGIN (WIDTH - 2))) MSG ((CLEAR WINDOW-CLEAR) (OPEN WINDOW-OPEN) (CLOSE WINDOW-CLOSE) (INVERTAREA WINDOW-INVERTAREA OPEN T) (MOVETOXY WINDOW-MOVETOXY OPEN T) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (PRINTCHAR WINDOW-PRINTCHAR OPEN T) (PRINTSTRING WINDOW-PRINTSTRING) (PRINTNC WINDOW-PRINTNC) (CENTEROFFSET WINDOW-CENTEROFFSET OPEN T)) SUPERS (REGION)) ) (GLISPGLOBALS (MOUSE MOUSE) ) (GLISPCONSTANTS (WINDOWCHARWIDTH 8 INTEGER) (WINDOWLINEYSPACING 16 INTEGER) ) (SETQ MOUSE 'MOUSE) (SETQ GEVMENUWINDOW NIL) (SETQ MENUSTART (A VECTOR WITH X = 500 Y = 1)) % edited: 16-Mar-83 15:04 % Select an item from a pop-up menu. (DG MENU-SELECT (M:MENU) (PROG (MAXW I N SAVEESC SAVEGLQ SAVEGCG RESULT) (if ~gevactiveflg then (geventer)) (SAVEGLQ _ GLQUIETFLG) (GLQUIETFLG _ T) (MAXW_0) (FOR X IN M:ITEMS DO (MAXW_ (MAX MAXW X:PNAME:LENGTH))) (IF MAXW > 20 THEN (MAXW _ 20)) (M:WINDOW _ (A WINDOW WITH START = MENUSTART SIZE = (A VECTOR WITH X = (MAXW + 5) *WINDOWCHARWIDTH Y = (MIN (LENGTH M:ITEMS) + 1 19) *WINDOWLINEYSPACING) TITLE = "Menu")) (SEND M:WINDOW OPEN) (I_0) (FOR X IN M:ITEMS DO (I _+ 1) (SEND M:WINDOW PRINTAT (CONCAT (GEVSTRINGIFY I) (concat (IF I<10 THEN " " ELSE " ") (gevstringify X))) (A VECTOR WITH X = 1 Y = M:WINDOW:HEIGHT - I * windowlineyspacing))) LP (PRIN1 "Menu: ") (N _ (READ)) (IF N IS INTEGER AND N>0 AND N<= (LENGTH M:ITEMS) THEN (RESULT _ (CAR (PNth M:ITEMS N))) (GO OUT) ELSEIF N = 'Q THEN (RESULT _ NIL) (GO OUT) ELSE (PRIN1 N) (SPACES 1) (PRINC "?") (terpri) (GO LP)) OUT (SEND M:WINDOW CLOSE) (TERPRI) (SETQ GLQUIETFLG SAVEGLQ) (if ~gevactiveflg then (gevexit)) (RETURN RESULT))) % edited: 16-Mar-83 14:02 % Open a window in a H-19 terminal. (DG WINDOW-CLEAR (W:WINDOW) (PROG () (M-ERASE W:LEFT W:BOTTOM W:RIGHT W:TOP) (M-RECT-OUTLINE W:LEFT W:BOTTOM W:RIGHT W:TOP) )) (DG WINDOW-CLOSE (W:WINDOW) (M-ERASE W:LEFT W:BOTTOM W:RIGHT W:TOP) ) % edited: 12-Mar-83 15:22 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (M-VECTOR FROM:X FROM:Y TO:X TO:Y)) % edited: 12-Mar-83 15:17 (DG WINDOW-INVERTAREA (W:WINDOW AREA:REGION) NIL) % edited: 12-Mar-83 15:18 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (SEND W MOVETOXY POS:X POS:Y)) % edited: 19-Mar-83 20:25 % Move cursor to X-Y position relative to window. (DG WINDOW-MOVETOXY (W:WINDOW X:INTEGER Y:INTEGER) (M-MOVEP1 X+W:LEFT Y+W:BOTTOM)) % edited: 19-Mar-83 20:39 % Open a window on a terminal. (DG WINDOW-OPEN (W:WINDOW) (SEND W CLEAR)) % edited: 12-Mar-83 17:03 (DG WINDOW-PRETTYPRINTAT (W:WINDOW VALUE POSITION:VECTOR) (SEND W PRINTAT VALUE POSITION)) % edited: 16-Mar-83 14:18 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (SEND W PRINTSTRING S) (IF POS:Y < W:LASTFILLEDLINE THEN (W:LASTFILLEDLINE _ POS:Y)))) % edited: 12-Mar-83 15:23 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) NIL) % edited: 16-Mar-83 14:19 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (IF POS:Y > 0 THEN (SEND W MOVETO POS) (SEND W PRINTNC S:LENGTH " "))) % edited: 11-Mar-83 22:42 % Print a character N times. (DG WINDOW-PRINTNC (W:WINDOW N:INTEGER C:STRING) (WHILE N > 0 DO (N _- 1) (SEND W PRINTCHAR C))) % Print a character on the display (DG WINDOW-PRINTCHAR (W:WINDOW S:STRING) (M-CHAR (INDX S 0))) % Print a string on the display. (DG WINDOW-PRINTSTRING (W:WINDOW S:STRING) (PROG (L:INTEGER I) (S _ (GEVSTRINGIFY S)) (L _ (SIZE S)) (I _ 0) (WHILE I <= L DO (M-CHAR (INDX S I)) (I _+ 1)) )) |
Added psl-1983/3-1/help/-notes.txt version [9c63924d85].
> > | 1 2 | See PU:-FILES-NOTES.TXT for synopses of some of the packages not documented in the reference manual. |
Added psl-1983/3-1/help/big.doc version [50a96777ac].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Beryl Morrison, 4 June 1982 BigNum Structure and "Constants" The current PSL bignum package was written using vectors of "Big Digits" or "Bigits". The first element of each vector is either BIGPOS or BIGNEG, depending whether the number is positive or negative. A bignum of the form [BIGPOS a b c d] has a value of a + b * bbase!* + c * bbase!* ** 2 + d * bbase!* ** 3 BBase!* is a fluid variable which varies from one machine to another. For the VAX and the DEC-20, it is calculated as follows: bbits!* := (n-1)/2; bbase!* := 2 ** bbits!*; "n" is the total number of bits per word on the given machine. On the DEC-20, n is 36, so bbits!* is 17 and bbase!* is 131072. On the VAX, n is 32, so bbits!* is 15 and bbase!* is 32768. There are some other constants used in the system as well. The sources are in pu:bigbig.red on the DEC-20, /u/benson/psl-dist/util/bigbig.red on the VAX. Starting BigNums "Load Big;" will bring in the bignum package. A file called big.lap loads arith.b which provides an interface via tags for when inum functions and when bignum functions should be used; (sources are in test-arith.red) vector-fix.b which provides a means of truncating vectors without copying them; bigbig.b which provides the bignum versions of functions as required by arith.b; bigface.b which provides the final interface between bigbig.b and arith.b. The order of loading the files must remain as shown; arith and vector-fix may be swapped, but otherwise function definitions must be presented in the order given. Building the BigNum Package Each of the individual files may be rebuilt (to form a new *.b file) separately. A file XXX.red may be rebuilt as follows: [1] faslout "YYY"; [2] in "XXX.red"$ 2 [3] faslout; On the DEC-20, the resulting YYY.b file is put on the directory pl:; on the VAX, it is put on the connected directory. They should be on pl: on the DEC-20 for public access, and on /usr/local/lib/psl on the VAX. The Functions in BigBig The functions defined by BigBig for bignums are as follows: BLOr Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, PosIfZero. BLXOr Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, TrimBigNum1. BLAnd Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, TrimBigNum1. BLNot Takes one BigNum argument, returning a bignum. Calls BMinus, BSmallAdd. BLShift Takes two BigNum arguments, returning a bignum. Calls BMinusP, BQuotient, BTwoPower, BMinus, BTimes2. BMinus Takes one BigNum argument, returning a bignum. Calls BZeroP, BSize, BMinusP, GtPos, GtNeg. BMinusP Takes one BigNum argument, returning a bignum or NIL. BPlus2 Takes two BigNum arguments, returning a bignum. Calls BMinusP, BDifference2, BMinus, BPlusA2. BDifference BZeroP, BMinus, BMinusP, BPlusA2, BDifference2. BTimes2 Takes two BigNum arguments, returning a bignum. Calls BSize, BMinusP, GtPos, GtNeg, BDigitTimes2, PosIfZero, TrimBigNum1. BDivide Takes two BigNum arguments, returning a pair of bignums. Calls BSize, GtPos, BSimpleDivide, BHardDivide. BGreaterP Takes two BigNum arguments, returning a bignum or NIL. Calls BMinusP, BDifference. BLessP Takes two BigNum arguments, returning a bignum or NIL. Calls BMinusP, BDifference. BAdd1 Takes a BigNum argument, returning a bignum. Calls BSmallAdd. BSub1 Takes a BigNum argument, returning a bignum. Calls BigSmallDiff. 3 FloatFromBigNum Takes a bignum, returning a float. Calls BZeroP, BGreaterP, BLessP, BSize, BMinusP. BChannelPrin2 Calls BigNumP, NonBigNumError, BSimpleDivide, BSize, BZeroP. BRead Calls GtPos, BReadAdd, BMinus. BigFromFloat Takes a float and converts to a bignum. Calls BNum, BPlus2, BTimes2, BTwoPower, FloatFromBigNum, BMinus, PosIfZero. The following functions are support functions for those given above. SetBits Takes as an argument the total number of bits per word on a given machine; sets some fluid variables accordingly. NOTE: FloatHi!* must be changed separately from this procedure by hand when moving to a new machine both in bigbig.red and in bigface.red. Calls TwoPower, BNum, BMinus, BSub1, BTwoPower, BAdd1. BigNumP Checks if the argument is a bignum. Calls no special functions. NonBigNumError Calls no special functions. BSize Gives size of a bignum, i.e. total number of bigits (the tag "BIGPOS" or "BIGNEG" is number 0). Calls BigNumP. PosIfZero Takes a bignum; if it is a negative zero, it is converted to a positive zero. Calls BPosOrNegZeroP, BMinusP. BPosOrNegZeroP Takes a BigNum; checks if magnitude is zero. Calls BSize. GtPos Takes an inum/fixnum. Returns a vector of size of the argument; first (i.e.0th) element is BIGPOS, others are NIL. GtNeg Takes an inum/fixnum. Returns a vector of size of the argument; first (i.e.0th) element is BIGNEG, others are NIL. TrimBigNum Takes a BigNum as an argument; truncates any trailing "NIL"s. Calls BigNumP, NonBigNumError, TrimBigNum1, BSize. TrimBigNum1 Does dirty work for TrimBigNum, with second argument the size of the BigNum. Big2Sys Calls BLessP, BGreaterP, BSize, BMinusP. TwoPower Takes and returns a fix/inum. 2**n. BTwoPower Takes a fix/inum or bignum, returns a bignum of value 2**n. Calls BigNumP, Big2Sys, GtPos, TwoPower, TrimBigNum1. BZeroP Checks size of BigNum (0) and sign. Calls BSize, BMinusP. 4 BOneP Calls BMinusP, BSize. BAbs Calls BMinusP, BMinus. BGeq Calls BLessP. BLeq Calls BGreaterP. BMax Calls BGeq. BMin Calls BLeq. BExpt Takes a BigNum and a fix/inum. Calls Int2B, BTimes2, BQuotient. AddCarry Support for trapping the carry in addition. BPlusA2 Does the dirty work of addition of two BigNums with signs pre-checked and identical. Calls BSize, GtNeg, GtPos, AddCarry, PosIfZero, TrimBigNum1. SubCarry Mechanism to get carry in subtractions. BDifference2 Does the dirty work of subtraction with signs pre-checked and identical. Calls BSize, GtNeg, GtPos, SubCarry, PosIfZero, TrimBigNum1. BDigitTimes2 Multiplies the first argument (BigNum) by a single Bigit of the second BigNum argument. Returns the partially completed result. Calls no special functions. BSmallTimes2 Takes a BigNum argument and a fixnum argument, returning a bignum. Calls GtPos, BMinusP, GtNeg, PosIfZero, TrimBigNum1. BQuotient Takes two BigNum arguments, returning a bignum. Calls BDivide. BRemainder Takes two BigNum arguments, returning a bignum. Calls BDivide. BSimpleQuotient Calls BSimpleDivide. BSimpleRemainder Calls BSimpleDivide. BSimpleDivide Used to divide a BigNum by an inum. Returns a dotted pair of quotient and remainder, both being bignums. Calls BMinusP, GtPos, GtNeg, PosIfZero, TrimBigNum1. BHardDivide Used to divide two "true" BigNums. Returns a pair of bignums. Algorithm taken from Knuth. Calls BMinusP, GtPos, GtNeg, BAbs, BSmallTimes2, BSize, BDifference, BPlus2, TrimBigNum1, BSimpleQuotient, PosIfZero. 5 BReadAdd Calls BSmallTimes2, BSmallAdd. BSmallAdd Adds an inum to a BigNum, returning a bignum. Calls BZeroP, BMinusP, BMinus, BSmallDiff, BSize, GtPos, AddCarry, PosIfZero, TrimBigNum1. BNum Takes an inum and returns a BigNum of one bigit; test that the inum is less than bbase!* is assumed done. Calls GtPos, GtNeg. BSmallDiff Calls BZeroP, BMinusP, BMinus, BSmallAdd, GtPos, SubCarry, PosIfZero, TrimBigNum1. int2b Takes a fix/inum and converts to a BigNum. Calls BNum, BRead. Problems - Should the "vectors" be changed to hwords? - Should there be primitives so that each bigit uses almost the whole word instead of almost half the word? This would involve writing "overflow" functions, checking and trapping overflow in operations such as multiplication. This would allow integers to be returned as inums or fixnums if they are geq the current bbase!* and lessp 2 ** (n-1). Currently, anything bbase!* or larger is kept as a bignum once the bignum package is loaded. - Make the constants real constants instead of fluids: bbase!*, bbits!*, floathi!*, floatlow!*, logicalbits!*, wordhi!*, wordlow!*, syshi!*, syslo!*, digit2letter!*. Carry!* should be a fluid. - Try to make the whole package loaded as one *.b file. - Change arith.b so that divide is used for the interface instead of quotient and remainder. As it stands, doing a "Divide" when bignums are loaded would mean doing the quotient and then the remainder separately, although Knuth's algorithm computes them together. - Get rid of superfluous functions. - Put in more calls to NonBigNumError for greater safety? |
Added psl-1983/3-1/help/break.hlp version [414d8e8bf3].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, except that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet A Abort to top level, i.e. restart PSL C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. |
Added psl-1983/3-1/help/exec.doc version [aa6d880fc4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | EXEC0.RED: A Simple TOPS20 Interface 26 April 1982 ------------------------------------ This is a loadable option but currently is non-functional. Top Level Functions of Interest: RUN FileName; Run A File in sub-fork EXEC(); Run Exec EMACS(); Run EMACS MM(); Run MM FileP FileName; Test If File exists CMDS (!%L); Submit List of commands (FEXPR) DoCmds (L); Submit List of commands (EXPR) Use CRLF or BL in string VDIR (L); DoCmds LIST("VDIR ",L,CRLF,"POP"); HelpDir(); DoCmds LIST("DIR PH:*.HLP",CRLF,"POP"); Take (FileName); DoCmds LIST("Take ",FileName,CRLF,"POP"); SYS (L); DoCmds LIST("SYS ", L, CRLF, "POP"); TALK (L); DoCmds LIST("TALK ",L,CRLF); TYPE (L); DoCmds LIST("TYPE ",L,CRLF,"POP"); Fork manipulation: [return forkhandle, FH, an integer returned by system] OPENFork FileName; Get a File into a Fork RUNFork FH; Normal use, to run a Fork KILLFork FH; Kill a Fork GetFork Jfn; Create Fork, READ File on Jfn STARTFork FH; Start (Restart) a Fork WAITFork FH; Wait for completion File manipulation functions: [Mostly return JFN, as small integer] GetOLDJfn FileName; test If file OLD and return Jfn GetNEWJfn FileName; test If file NEW and return Jfn RELJfn Jfn; return Jfn to system OPENOLDJfn Jfn; OPEN to READ OPENNEWJfn Jfn; Open to WRITE GTJfn FileName; Get a Jfn NAMEFROMJfn Jfn; name of File on a Jfn Miscellaneous Functions: GetUNAME(); Get USER name GetCDIR(); Get Connected DIRECTORY |
Added psl-1983/3-1/help/find.doc version [7ba26e222b].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | FIND.RED - Recognition and search OBLIST functions ------------------------------------------------- This is a loadable option [Load Find; in RLISP, (Load Find) in LISP]. These functions take a string or id, and map the Symbol Table to collect a list of ids with Prefix or Suffix as given: FindPrefix(Key:{Id, String}):id-list Scan Symbol Table for prefix FindSuffix(Key:{Id, String}):id-list Scan Symbol Table for suffix Find(Pattern:{Id,String}):id-list Scan Symbol Table for matching string Thus X:=FindPrefix '!*; Finds all ids starting with * The 'GSORT' package is used to sort the list. The Pattern is a string, with special characters, prefixed by %, like the format string in PrintF; StringMatch(pattern,subject) is called: %% Match a % in subject string %? Match any one character %* Match any series of characters (0..n) Thus Find "*%*"; is equivalent to FindPrefix "*"; Find "%**"; is equivalent to FindSuffix "*"; Find "A%*B"; matches any string starting with A and ending with B. |
Added psl-1983/3-1/help/hcons.doc version [32b11cfabc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | HCONS - Hashing (unique) CONS and associated utilities. The Hcons function creates unique dotted pairs. In other words, Hcons(A,B) eq Hcons(C,D) if and only if A eq C and B eq D. This allows very rapid tests for equality between structures, at the cost of expending more time in creating the structures. The use of Hcons may also save space in cases where lists share a large amount of common substructure, since only one copy of the substructure is stored. The system works by keeping a hash table of all pairs that have been created by Hcons. (So the space advantage of sharing substructure may be offset by the space consumed by table entries.) This hash table allows the system to store property lists for pairs--in the same way that Lisp has property lists for identifiers. Pairs created by Hcons SHOULD NOT be modified with RPLACA and RPLACD. Doing so will make the pair hash table inconsistent, as well as being very likely to modify structure shared with something that you don't wish to change. Also note that large numbers may be equal without being eq, so the Hcons of two large numbers may not be eq to the Hcons of two other numbers that appear to be the same. (Similar warnings hold for strings and vectors.) The following "user" functions are provided by HCONS: Hcons([U:any]): pair macro - --- ---- ----- The Hcons macro takes one or more arguments and returns their "hashed cons" (right associatively). Two arguments corresponds to a call of Cons. Hlist([U:any]): list nexpr - --- ---- ----- Hlist is the "Hcons version" of the List function. Hcopy(U:any): any macro - --- --- ----- Hcopy is the Hcons version of the copy function. Note that Hcopy serves a very different purpose than copy--which is usually used to copy a structure so that destructive changes can be made to the copy without changing the original. Hcopy, on the other hand, will only actually copy those parts of the structure which haven't already been "consed together" by Hcons. Happend (U:list, V:list): list expr - ---- - ---- ---- ---- Hcons version of append. Hreverse (U:list): list expr - ---- ---- ---- Hcons version of reverse. The following two functions can be used to "get" and "put" properties for pairs or identifiers. The pairs for these functions must be created by Hcons. These functions are known to the Setf macro. extended-put (U:id-or-pair, IND:id, PROP:any): any expr - ---------- --- -- ---- --- --- ---- extended-get (U:id-or-pair, IND:any): any expr - ---------- --- --- --- ---- |
Added psl-1983/3-1/help/help.hlp version [90293db87b].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | HELP([ARGS:id-list]):NIL mlg, 31 dec 1981 ------------------------ Type: NOEVAL, NOSPREAD If no arguments are given, this file is printed. Otherwise, each of the id arguments is checked to see if any help information is available. If it has a value under the property list indicator HelpFunction, that function is called. If it has a value under the indicator HelpString, the value is printed. If it has a value under the indicator HelpFile, the file is displayed on the terminal. (SHOWSTATE U:id-list) Show information about Switches and Globals on list U, or ALL known switches and globals if U is NIL (SHOWGLOBALS U:id-list) Globals only (SHOWSWITCHES U:id-list) Switches only |
Added psl-1983/3-1/help/help.tbl version [b01ce0d2b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Edit by Cris Perdue, 4 Apr 1983 0950-PST % Switchs --> Switches (put 'Help 'HelpFunction 'HelpHelp) (put '!? 'HelpFunction 'HelpHelp) (put 'Br 'HelpFile 'mini!-trace) (put 'Break 'HelpFunction 'HelpBreak) (put 'Edit 'HelpFile 'Editor) (put 'EditF 'HelpFile 'ZPEdit) (put 'Switches 'HelpFunction 'ShowSwitches) (put 'Globals 'HelpFunction 'ShowGlobals) (put 'LapIn 'HelpFile 'Load) (put 'Load 'HelpFile 'Load) (put 'MiniEditor 'HelpFile 'Mini!-Editor) (put 'MiniTrace 'HelpFile 'Mini!-Trace) (put 'TopLoop 'HelpFunction 'HelpTopLoop) (put 'Tr 'HelpFile 'mini!-trace) (put 'UnBr 'HelpFile 'mini!-trace) (put 'UnTr 'HelpFile 'mini!-trace) (DefineSwitch 'Echo "Echo input characters if T") (DefineSwitch 'Time "Print TimeCheck in TopLoop") (DefineSwitch 'Defn "Output Parsed Expression, bypass EVAL") (defineGlobal 'OutputBase!* "Output base for numbers") (defineGlobal 'PromptString!* "Current input prompt") %(defineGlobal 'Module!* "Module name for help system") (defineGlobal 'TopLoopName!* "Name of current top loop") (defineGlobal 'TopLoopRead!* "Current reader in top loop") (defineGlobal 'TopLoopEval!* "Current evaluator in top loop") (defineGlobal 'TopLoopPrint!* "Current printer in top loop") |
Added psl-1983/3-1/help/history.doc version [3647b40ca4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | How to use the history mechanism implemented in PSL/FRL: PSL/FRL allows you to take any previous input or output and substitute it in place of what you typed. Thus you can either print or redo any input you have previously done. You can also print or execute any result you have previously received. The system will work identify commands by either their history number, or by a subword in the input command. PSL/FRL also allows you to take any previously expression and do global substitutions on subwords inside words or numbers inside expressions(Thus allowing spelling corrections, and other word changes easily.) PSL/FRL is a set of read macros that insert the previous history text asked for inplace of them selves. Thus they can be put inside any lisp expression typed by the user. The system will evaluate the resulting expression the same as if the user had retyped everything in himself. ^^ : means insert last input command inplace of ^^. As an input command by itself, ^^ by itself means redo last command. ^n : where n is a number replaces itself with the result of (inp n). ^n by itself means (redo n). ^+n : same as ^n. ^-n : is replaced by the nth back command. replaced with the result of (inp (- current-history-number n)). by itself means (redo (- current-history-number n)) ^word : where word starts with 'a'-'z' or 'A'-'Z', means take the last input command that has word as a subword or pattern of what was typed (after readmacros were executed.), and replace that ^word with that entire input command. If you want a word that doesn't begin with 'a'-'z', or 'A'-'Z', use ^?word where word can be any lisp atom. (say 23, *, |"ab|, word). ex.: 1 lisp> (plus 2 3) 5 2 lisp> (* 4 5) 20 3 lisp> ^us (PLUS 2 3) 5 4 lisp> (* 3 ^lu) (PLUS 2 3) 15 Case is ignored in word. Word is read by the command read, And thus should be a normal lisp atom. Use the escape character as needed. If the first ^ in any of the above commands is replaced with ^@, then instead of (inp n) , the read macro is replaced with (ans n). Words are still matched against the input, not the answer. (Probably something should be added to allow matching of subwords against the answer also.) Thus:(if typed as commands by themselves): ^@^ = (eval (ans (last-command))) ^@3 = (eval (ans 3)) ^@plus = (eval (ans (last-command which has plus as a subword in its input))). Once the ^ readmacro is replaced with its history expression, you are allowed to do some editing of the command. The way to do this is to type a colon immediately after the ^ command as described above before any space or other delimiting character. ex.: ^plus:p ^2:s/ab/cd/ ^^:p ^@^:p Currently there are two types of editing commands allowed. :p means print only, do not insert in expression, whole read macro returns only nil. :s/word1/word2/ means take each atom in the expression found, and if word1 is a subword of that atom, replace the subword word1 with word2. Read is used to read word1 and word2, thus the system expects an atom and will ignore anything after what read sees before the /. Use escape characters as necessary. :n where n is a positive unsigned number, means take the nth element of the command(must be a list) and return it. ^string1^string2^ is equivalent to :s/string1/string2/. ex.: ^plus^plus^times^ is equivalent to ^plus:s/plus/times/ . After a :s, ^ or :<n> command you may have another :s command, ^ or a :p command. :p command may not be followed by any other command. The expression as modified by the :s commands is what is returned in place of the ^ readmacro. You need a closing / as seen in the :s command above. After the command you should type a delimiting character if you wish the next expression to begin with a :, since a : will be interpreted as another editing command. On substitution, case is ignored when matching the subword, and the replacement subword is capitalized(unless you use an escape character before typing a lowercase letter). Examples: 1 lisp> (plus 23 34) 57 2 lisp> ^^:s/plus/times/ (TIMES 23 34) 782 3 lisp> ^plus:s/3/5/ (PLUS 25 54) 79 4 lisp> |
Added psl-1983/3-1/help/inspect.doc version [d8239ae92f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | INSPECT M.L. Griss, Monday, 31 May 1982 ------- This is a simple utility to scan the contents of a source file to tell what functions are defined in it. It will be embellished slightly to permit the on-line querying of certain attributes of files. INSPECT reads one or more files, printing and collecting information on defined functions. Usage: LOAD INSPECT; INSPECT "file-name"; % Scans the file, and prints proc names. % It also builds the lists ProcedureList!* % FileList!* and ProcFileList!* % File-Name can IN other files On the Fly printing is controlled by !*PrintInspect, default is T. Other lists built include FileList!* and ProcFileList!*, which is a list of (procedure . filename) for multi-file processing. For more complete process, do: LOAD Inspect; Off PrintInspect; InspectOut(); % Later will get a file Name IN ....; IN ...; InspectEnd; Now use Gsort etc. to process the lists |
Added psl-1983/3-1/help/loop.doc version [97e85cee8a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;Loop macro blathering. ; ; This doc is totally wrong. Complete documentation (nice looking ; hardcopy) is available from GSB, or from ML:LSBDOC;LPDOC (which ; needs to be run through BOLIO). ; ;This is intended to be a cleaned-up version of PSZ's FOR package ;which is a cleaned-up version of the Interlisp CLisp FOR package. ;Note that unlike those crocks, the order of evaluation is the ;same as the textual order of the code, always. ; ;The form is introduced by the word LOOP followed by a series of clauses, ;each of which is introduced by a keyword which however need not be ;in any particular package. Certain keywords may be made "major" ;which means they are global and macros themselves, so you could put ;them at the front of the form and omit the initial "LOOP". ; ;Each clause can generate: ; ; Variables local to the loop. ; ; Prologue Code. ; ; Main Code. ; ; Epilogue Code. ; ;Within each of the three code sections, code is always executed strictly ;in the order that the clauses were written by the user. For parallel assignments ;and such there are special syntaxes within a clause. The prologue is executed ;once to set up. The main code is executed several times as the loop. The epilogue ;is executed once after the loop terminates. ; ;The term expression means any Lisp form. The term expression(s) means any number ;of Lisp forms, where only the first may be atomic. It stops at the first atom ;after the first form. ; ;The following clauses exist: ; ;Prologue: ; INITIALLY expression(s) ; This explicitly inserts code into the prologue. More commonly ; code comes from variable initializations. ; ;Epilogue: ; FINALLY expression(s) ; This is the only way to explicitly insert code into the epilogue. ; ;Side effects: ; DO expression(s) ; The expressions are evaluated. This is how you make a "body". ; DOING is synonymous with DO. ; ;Return values: ; RETURN expression(s) ; The last expression is returned immediately as the value of the form. ; This is equivalent to DO (RETURN expression) which you will ; need to use if you want to return multiple values. ; COLLECT expression(s) ; The return value of the form will be a list (unless over-ridden ; with a RETURN). The list is formed out of the values of the ; last expression. ; COLLECTING is synonymous with COLLECT. ; APPEND (or APPENDING) and NCONC (or NCONCING) can be used ; in place of COLLECT, forming the list in the appropriate ways. ; COUNT expression(s) ; The return value of the form will be the number of times the ; value of the last expression was non-NIL. ; SUM expression(s) ; The return value of the form will be the arithmetic sum of ; the values of the last expression. ; The following are a bit wierd syntactically, but Interlisp has them ; so they must be good. ; ALWAYS expression(s) ; The return value will be T if the last expression is true on ; every iteration, NIL otherwise. ; NEVER expressions(s) ; The return value will be T if the last expression is false on ; every iteration, NIL otherwise. ; THEREIS expression(s) ; This is wierd, I'm not sure what it really does. ; You probably want WHEN (NUMBERP X) RETURN X ; or maybe WHEN expression RETURN IT ; ;Conditionals: (these all affect only the main code) ; ; WHILE expression ; The loop terminates at this point if expression is false. ; UNTIL expression ; The loop terminates at this point if expression is true. ; WHEN expression clause ; Clause is performed only if expression is true. ; This affects only the main-code portion of a clause ; such as COLLECT. Use with FOR is a little unclear. ; IF is synonymous with WHEN. ; WHEN expression RETURN IT (also COLLECT IT, COUNT IT, SUM IT) ; This is a special case, the value of expression is returned if non-NIL. ; This works by generating a temporary variable to hold ; the value of the expression. ; UNLESS expression clause ; Clause is performed only if expression is false. ; ;Variables and iterations: (this is the hairy part) ; ; WITH variable = expression {AND variable = expression}... ; The variable is set to the expression in the prologue. ; If several variables are chained together with AND ; the setq's happen in parallel. Note that all variables ; are bound before any expressions are evaluated (unlike DO). ; ; FOR variable = expression {AND variable = expression}... ; At this point in the main code the variable is set to the expression. ; Equivalent to DO (PSETQ variable expression variable expression...) ; except that the variables are bound local to the loop. ; ; FOR variable FROM expression TO expression {BY expression} ; Numeric iteration. BY defaults to 1. ; BY and TO may be in either order. ; If you say DOWNTO instead of TO, BY defaults to -1 and ; the end-test is reversed. ; If you say BELOW instead of TO or ABOVE instead of DOWNTO ; the iteration stops before the end-value instead of after. ; The expressions are evaluated in the prologue then the ; variable takes on its next value at this point in the loop; ; hair is required to win the first time around if this FOR is ; not the first thing in the main code. ; FOR variable IN expression ; Iteration down members of a list. ; FOR variable ON expression ; Iteration down tails of a list. ; FOR variable IN/ON expression BY expression ; This is an Interlisp crock which looks useful. ; FOR var ON list BY expression[var] ; is the same as FOR var = list THEN expression[var] ; FOR var IN list BY expression[var] ; is similar except that var gets tails of the list ; and, kludgiferously, the internal tail-variable ; is substituted for var in expression. ; FOR variable = expression THEN expression ; General DO-type iteration. ; Note that all the different types of FOR clauses can be tied together ; with AND to achieve parallel assignment. Is this worthwhile? ; [It's only implemented for = mode.] ; AS is synonymous with FOR. ; ; FOR variable BEING expression(s) AND ITS pathname ; FOR variable BEING expression(s) AND ITS a-r ; FOR variable BEING {EACH} pathname {OF expression(s)} ; FOR variable BEING {EACH} a-r {OF expression(s)} ; Programmable iteration facility. Each pathname has a ; function associated with it, on LOOP-PATH-KEYWORD-ALIST; the ; alist has entries of the form (pathname function prep-list). ; prep-list is a list of allowed prepositions; after either of ; the above formats is parsed, then pairs of (preposition expression) ; are collected, while preposition is in prep-list. The expression ; may be a progn if there are multiple prepositions before the next ; keyword. The function is then called with arguments of: ; pathnname variable prep-phrases inclusive? prep-list ; Prep-phrases is the list of pairs collected, in order. Inclusive? ; is T for the first format, NIL otherwise; it says that the init ; value of the form takes on expression. For the first format, the ; list (OF expression) is pushed onto the fromt of the prep-phrases. ; In the above examples, a-r is a form to be evaluated to get an ; attachment-relationship. In this case, the pathname is taken as ; being ATTACHMENTS, and a-r is passed in by being treated as if it ; had been used with the preposition IN. The function should return ; a list of the form (bindings init-form step-form end-test); bindings ; are stuffed onto loop-variables, init-form is initialization code, ; step-form is step-code, and end-test tells whether or not to exit. ; ;Declarations? Not needed by Lisp machine. For Maclisp these will be done ;by a reserved word in front of the variable name as in PSZ's macro. ; ;The implementation is as a PROG. No initial values are given for the ;PROG-variables. PROG1 is used for parallel assignment. ; ;The iterating forms of FOR present a special problem. The problem is that ;you must do everything in the order that it was written by the user, but the ;FOR-variable gets its value in a different way in the first iteration than ;in the subsequent iterations. Note that the end-tests created by FOR have ;to be done in the appropriate order, since otherwise the next clause might get ;an error. ; ;The most general way is to introduce a flag, !FIRST-TIME, and compile the ;clause "FOR var = first TO last" as "INITIALLY (SETQ var first) ;WHEN (NOT !FIRST-TIME) DO (SETQ var (1+ var)) WHILE (<= var last)". ;However we try to optimize this by recognizing a special case: ;The special case is recognized where all FOR clauses are at the front of ;the main code; in this case if there is only one its stepping and ;endtest are moved to the end, and a jump to the endtest put at the ;front. If there are more than one their stepping and endtests are moved ;to the end, with duplicate endtests at the front except for the last ;which doesn't need a duplicate endtest. If FORs are embedded in the ;main code it can only be implemented by either a first-time flag or ;starting the iteration variable at a special value (initial minus step ;in the numeric iteration case). This could probably just be regarded as ;an error. The important thing is that it never does anything out of ;order. |
Added psl-1983/3-1/help/objects.doc version [c991a39bb1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The OBJECTS Module Cris Perdue Alan Snyder 11/22/82 ----------------------------- INTRODUCTION ------------ The OBJECTS module provides simple support for object-oriented programming in PSL. It is based on the "flavors" facility of the LISP machine, which is the source of its terminology. The LISP Machine Manual contains a much longer introduction to the idea of object oriented programming, generic operations, and the flavors facility in particular. This discussion goes over the basics of using flavored objects once briefly to give you an idea of what is involved, then goes into details. A datatype is known as a flavor (don't ask). The definition of a flavor can be thought of in two parts: the DEFFLAVOR form ("flavor definition"), plus a set of DEFMETHOD forms ("method definitions") for operating on objects of that flavor. With the objects package the programmer completely controls what operations are to be done on objects of each flavor, so this is a true object-oriented programming facility. Also, all operations on flavored objects are automatically "generic" operations. This means that any programs you write that USE flavored objects have an extra degree of built-in generality. What does it mean to say that operations on flavored objects are generic? This means that the operations can be done on an object of any flavor, just so long as the operations are defined for that flavor of object. The same operation can be defined for many flavors, and whenever the operation is invoked, what is actually done will depend on the flavor of the object it is being done to. We may wish to write a scanner that reads a sequence of characters out of some object and processes them. It does not need to assume that the characters are coming from a file, or even from an I/O channel. Suppose the scanner gets a character by invoking the GET-CHARACTER operation. In this case any object of a flavor with a GET-CHARACTER operation can be passed to the scanner, and the GET-CHARACTER operation defined for that object's flavor will be done to fetch the character. This means that the scanner can get characters from a string, or from a text editor's buffer, or from any object at all that provides a GET-CHARACTER operation. The scanner is automatically general. DEFFLAVOR A flavor definition looks like: (defflavor flavor-name (var1 var2 ...) () option1 option2 ...) Example: (defflavor complex-number (real-part (imaginary-part 0.0)) () gettable-instance-variables initable-instance-variables ) A flavor definition specifies the fields, components, or in our terminology, the "instance variables" that each object of that flavor is to have. The mention of the instance variable imaginary-part indicated that by default the imaginary part of a complex number will be initialized to 0.0. There is no default initialization for the real-part. Instance variables may be strictly part of the implementation of a flavor, totally invisible to users. Typically though, some of the instance variables are directly visible in some way to the user of the object. The flavor definition may specify "initable-instance-variables", "gettable-instance-variables", and "settable-instance-variables". None, some of, or all of the instance variables may be specified in each option. CREATING OBJECTS The function MAKE-INSTANCE provides a convenient way to create objects of any flavor. The flavor of the object to be created and the initializations to be done are given as parameters in a way that is fully independent of the internal representation of the object. METHODS The function "=>", whose name is intended to suggest the sending of a message to an object, is usually used to invoke a method. Examples: (=> my-object zap) (=> thing1 set-location 2.0 3.4) The first "argument" to => is the object being operated on: my-object and thing1 in the examples. The second "argument" is the name of the method to be invoked: zap and set-location. The method name IS NOT EVALUATED. Any further arguments become arguments to the method. (There is a function SEND which is just like => except that the method name argument is evaluated just like everything else.) Once an object is created, all operations on it are performed by "methods" defined for objects of its flavor. The flavor definition itself also defines some methods. For each "gettable" instance variable, a method of the same name is defined which returns the current value of that instance variable. For "settable" instance variables a method named "set-<variable name>" is defined. Given a new value for the instance variable, the method sets the instance variable to have that value. SANCTITY OF OBJECTS Most LISPs and PSL in particular leave open the possibility for the user to perform illicit operations on LISP objects. Objects defined by the objects package are represented as ordinary LISP objects (vectors at present), so in a sense it is quite easy to do illicit operations on them: just operate directly on its representation (do vector operations). On the other hand, there are major practical pitfalls in doing this. The representation of a flavor of objects is generated automatically, and there is no guarantee that a particular flavor definition will result in a particular representation of the objects. There is also no guarantee that the representation of a flavor will remain the same over time. It is likely that at some point vectors will no longer even be used as the representation. In addition, using the objects package is quite convenient, so the temptation to operate on the underlying representation is reduced. For debugging, one can even define a couple of extra methods "on the fly" if need be. REFERENCE INFORMATION --------------------- LOADING THE MODULE NOTE: THIS FILE DEFINES BOTH MACROS AND ORDINARY LISP FUNCTIONS. IT MUST BE LOADED BEFORE ANY OF THESE FUNCTIONS ARE USED. The recommended way of doing this is to put the expression: (BothTimes (load objects)) at the beginning of your source file. This will cause the package to be loaded at both compile and load time. DEFFLAVOR - Define a new flavor of Object The form is: (defflavor <name> <instance-variables> <mixin-flavors> <options>) Examples: (defflavor complex-number (real-part imaginary-part) () gettable-instance-variables initable-instance-variables ) (defflavor complex-number ((real-part 0.0) (imaginary-part 0.0) ) () gettable-instance-variables (settable-instance-variables real-part) ) The <instance-variables> form a list. Each member of the list is either a symbol (id) or a list of 2 elements. The 2-element list form consists of a symbol and a default initialization form. Note: Do not use names like "IF" or "WHILE" for instance variables: they are translated freely within method bodies (see DEFMETHOD). The translation process is not very smart about which occurrences of the symbol for an instance variable are actually uses of the variable, though it does understand the nature of QUOTE. The <mixin-flavors> list must be empty. In the LISP machine flavors facility, this may be a list of names of other flavors. Recognized options are: (GETTABLE-INSTANCE-VARIABLES var1 var2 ...) (SETTABLE-INSTANCE-VARIABLES var1 var2 ...) (INITABLE-INSTANCE-VARIABLES var1 var2 ...) GETTABLE-INSTANCE-VARIABLES [make all instance variables GETTABLE] SETTABLE-INSTANCE-VARIABLES [make all instance variables SETTABLE] INITABLE-INSTANCE-VARIABLES [make all instance variables INITABLE] An empty list of variables is taken as meaning all variables rather than none, so (GETTABLE-INSTANCE-VARIABLES) is equivalent to GETTABLE-INSTANCE-VARIABLES. For each gettable instance variable a method of the same name is generated to access the instance variable. If instance variable LOCATION is gettable, one can invoke (=> <object> LOCATION). For each settable instance variable a method with the name SET-<name> is generated. If instance variable LOCATION is settable, one can invoke (=> <object> SET-LOCATION <expression>). Settable instance variables are always also gettable and initable by implication. If this feature is not desired, define a method such as SET-LOCATION directly rather than declaring the instance variable to be settable. Initable instance variables may be initialized via options to MAKE-INSTANCE or INSTANTIATE-FLAVOR. See below. DEFMETHOD - Define a method on an existing flavor. The form is: (defmethod (<flavor-name> <method-name>) (<arg> <arg> . . . ) <expression> <expression> . . . ) The <flavor-name>, the <method-name>, and each <arg> are all identifiers. There may be zero or more <arg>s. Examples: (defmethod (complex-number real-part) () real-part) (defmethod (complex-number set-real-part) (new-real-part) (setf real-part new-real-part)) The body of a method can refer to any instance variable of the flavor by using the name just like an ordinary variable. They can set them using SETF. All occurrences of instance variables (except within vectors or quoted lists) are translated to an invocation of the form (IGETV SELF n). The body of a method can also freely use SELF much as though it were another instance variable. SELF is bound to the object that the method applies to. SELF may not be setq'ed or setf'ed. Example using SELF: (defmethod (toaster plug-into) (socket) (setf plugged-into socket) (=> socket assert-as-plugged-in self)) MAKE-INSTANCE - Create a new instance of a flavor. Examples: (make-instance 'complex-number) (make-instance 'complex-number 'real-part 0.0 'imaginary-part 1.0) MAKE-INSTANCE takes as arguments a flavor name and an optional sequence of initializations, consisting of alternating pairs of instance variable names and corresponding initial values. Note that all the arguments are evaluated. Initialization of a newly made object happens as follows: Each instance variable with initialization specified in the call to make-instance is initialized to the value given. Any instance variables not initialized in this way, but having default initializations specified in the flavor definition are initialized by the default initialization specified there. All other instance variables are initialized to the symbol *UNBOUND*. If a method named INIT is defined for this flavor of object, that method is invoked automatically after the initializations just discussed. The INIT method is passed as its one argument a list of alternating variable names and initial values. This list is the result of evaluating the initializations given to MAKE-INSTANCE. For example, if we call: (make-instance 'complex-number 'real-part (sin 30) 'imaginary-part (cos 30)) then the argument to the INIT method (if any) would be (real-part .5 imaginary-part .866). The INIT method may do anything desired to set up the desired initial state of the object. At present, this value passed to the INIT method is of virtually no use to the INIT method since the values have been stored into the instance variables already. In the future, though, the objects package may be extended to permit keywords other than names of instance variables to be in the initialization part of calls to make-instance. If this is done, INIT methods will be able to use the information by scanning the argument. INSTANTIATE-FLAVOR This is the same as MAKE-INSTANCE, except that the initialization list is provided as a single (required) argument. Example: (instantiate-flavor 'complex-number (list 'real-part (sin 30) 'imaginary-part (cos 30))) OPERATING ON OBJECTS -------------------- Operations on an object are done by the methods of the flavor of the object. We say that a method is invoked, or we may say that a message is sent to the object. The notation suggests the sending of messages. In this metaphor, the name of the method to use is part of the message sent to the object, and the arguments of the method are the rest of the message. There are several approaches to invoking a method: => - Convenient form for sending a message Examples: (=> r real-part) (=> r set-real-part 1.0) The message name is not quoted. Arguments to the method are supplied as arguments to =>. In these examples, r is the object, real-part and set-real-part are the methods, and 1.0 is the argument to the set-real-part method. SEND - Send a Message (Evaluated Message Name) Examples: (send r 'real-part) (send r 'set-real-part 1.0) The meanings of these two examples are the same as the meanings of the previous two. Only the syntax is different: the message name is quoted. FANCY FORMS OF SEND SEND-IF-HANDLES - Conditionally Send a Message (Evaluated Message Name) Examples: (send-if-handles r 'real-part) (send-if-handles r 'set-real-part 1.0) SEND-IF-HANDLES is like SEND, except that if the object defines no method to handle the message, no error is reported and NIL is returned. LEXPR-SEND - Send a Message (Explicit "Rest" Argument List) Examples: (lexpr-send foo 'bar a b c list) The last argument to LEXPR-SEND is a list of the remaining arguments. LEXPR-SEND-IF-HANDLES This is the same as LEXPR-SEND, except that no error is reported if the object fails to handle the message. LEXPR-SEND-1 - Send a Message (Explicit Argument List) Examples: (lexpr-send-1 r 'real-part nil) (lexpr-send-1 r 'set-real-part (list 1.0)) Note that the message name is quoted and that the argument list is passed as a single argument to LEXPR-SEND-1. LEXPR-SEND-1-IF-HANDLES This is the same as LEXPR-SEND-1, except that no error is reported if the object fails to handle the message. USEFUL FUNCTION(s) ON OBJECTS ----------------------------- OBJECT-TYPE The OBJECT-TYPE function returns the type (an ID) of the specified object, or NIL, if the argument is not an object. At present this function cannot be guaranteed to distinguish between objects created by the OBJECTS package and other LISP entities, but the only possible confusion is with vectors. DEBUGGING INFORMATION --------------------- Any object may be displayed symbolically by invoking the method DESCRIBE, e.g. (=> x describe). This method prints the name of each instance variable and its value, using the ordinary LISP printing routines. Flavored objects are liable to be complex and nested deeply or even circular. This makes it often a good idea to set PRINLEVEL to a small integer before printing structures containing objects to control the amount of output. When printed by the standard LISP printing routines, "flavored objects" appear as vectors whose zeroth element is the name of the flavor. For each method defined, there is a corresponding LISP function named <flavor-name>$<method-name>. Such function names show up in backtrace printouts. It is permissible to define new methods on the fly for debugging purposes. DECLARE and UNDECLARE --------------------- *** Read these warnings carefully! *** This facility can reduce the overhead of invoking methods on particular variables, but it should be used sparingly. It is not well integrated with the rest of the language. At some point a proper declaration facility is expected and then it will be possible to make declarations about objects, integers, vectors, etc., all in a uniform and clean way. The DECLARE macro allows you to declare that a specific symbol is bound to an object of a specific flavor. This allows the flavors implementation to eliminate the run-time method lookup normally associated with sending a message to that variable, which can result in an appreciable improvement in execution speed. This feature is motivated solely by efficiency considerations and should be used ONLY where the performance improvement is critical. Details: if you declare the variable X to be bound to an object of flavor FOO, then WITHIN THE CONTEXT OF THE DECLARATION (see below), expressions of the form (=> X GORP ...) or (SEND X 'GORP ...) will be replaced by function invocations of the form (FOO$GORP X ...). Note that there is no check made that the flavor FOO actually contains a method GORP. If it does not, then a run-time error "Invocation of undefined function FOO$GORP" will be reported. WARNING: The DECLARE feature is not presently well integrated with the compiler. Currently, the DECLARE macro may be used only as a top-level form, like the PSL FLUID declaration. It takes effect for all code evaluated or compiled henceforth. Thus, if you should later compile a different file in the same compiler, the declaration will still be in effect! THIS IS A DANGEROUS CROCK, SO BE CAREFUL! To avoid problems, I recommend that DECLARE be used only for uniquely-named variables. The effect of a DECLARE can be undone by an UNDECLARE, which also may be used only as a top-level form. Therefore, it is good practice to bracket your code in the source file with a DECLARE and a corresponding UNDECLARE. Here are the syntactic details: (DECLARE FLAVOR-NAME VAR1 VAR2 ...) (UNDECLARE VAR1 VAR2 ...) *** Did you read the above warnings??? *** REPRESENTATION INFORMATION -------------------------- (You don't need to know any of this to use this stuff.) A flavor-name is an ID. It has the following properties: VARIABLE-NAMES A list of the instance variables of the flavor, in order of their location in the instance vector. This property exists at compile time, dskin time, and load time. INITABLE-VARIABLES A list of the instance variables that have been declared to be INITABLE. This property exists at dskin time and at load time. METHOD-TABLE An association list mapping each method name (ID) defined for the flavor to the corresponding function name (ID) that implements the method. This property exists at dskin time and at load time. INSTANCE-VECTOR-SIZE An integer that specifies the number of elements in the vector that represents an instance of this flavor. This property exists at dskin time and at load time. It is used by MAKE-INSTANCE. The function that implements a method has a name of the form FLAVOR$METHOD. Each such function ID has the following properties: SOURCE-CODE A list of the form (LAMBDA (SELF ...) ...) which is the untransformed source code for the method. This property exists at compile time and dskin time. Implementation Note: A tricky aspect of the code that implements the objects package is making sure that the right things happen at the right time. When a source file is read and evaluated (using DSKIN), then everything must happen at once. However, when a source file is compiled to produce a FASL file, then some actions must be performed at compile-time, whereas other actions are supposed to occur when the FASL file is loaded. Actions to occur at compile time are performed by macros; actions to occur at load time are performed by the forms returned by macros. Another goal of the implementation is to avoid consing whenever possible during method invocation. The current scheme prefers to compile into (APPLY HANDLER (LIST args...)), for which the PSL compiler will produce code that performs no consing. |
Added psl-1983/3-1/help/pcheck.doc version [f37df54fbf].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | PCHECK.RED MLG, 10 June 1982 ---------- PCHECK will READ a .SL file, printing some of the top-level of each S-expression. It is meant to survey the file, and if the file has unbalanced parensthesis, will show where things get confused. To use: LOAD PCHECK; PCHECK "foo.sl"; |
Added psl-1983/3-1/help/poly.doc version [9040194d95].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | POLY.RED MLG July 82 -------- POLY is a simple (pedagogic) Rational Function Evaluator. After loading POLY.RED, run function ALGG(); or RAT(); These accept a sequence of expressions: <exp> ; | QUIT; (Semicolon terminator) <exp> ::= <term> [+ <exp> | - <exp>] <term> ::= <primary> [* <term> | / <term>] <primary> ::= <primary0> [^ <primary0> | ' <primary0> ] ^ is exponentiation, ' is derivative <primary0> ::= <number> | <variable> | ( <exp> ) It includes a simple parser (RPARSE), 2 evaluators (RSIMP x) and (PRESIMP), and 2 prettyprinters, (RATPRINT) and (PREPRINT) 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) |
Added psl-1983/3-1/help/prlisp.hlp version [7adc83bf30].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 3D version of PictureRLISP MLG 4 Jan 1983 ------------------------------------------------------ This is a brief guide to the 3D version of Picture RLISP. This is much slower than the PRLISP2D subset, which is better if only planar displays are required. PRLISP can now be run under PSL as well, though of course with no syntax. RLISP Use: LOAD PRLISP; % Load 3D version of PictureRLISP HP!.INIT(); % Select Driver, this is most common HP2648a version Line := {0,0} _ {10,10}; % Line from center towards upper-right Show Line; % Draw it Show Line | ZROT(25); % Draw rotated by 25 degrees Erase(); % Clear screen Show Line & (Line | scale 3 | zrot 20 ) | xmove 10; For more examples, see PU:PR-DEMO.RED, use IN "PU:PR-DEMO.RED"$ PRLISP can also be loaded and run from PSL, but no syntax is available: (LOAD PRLISP) (HP!.INIT) (setq LINE (POINTSET (ONEPOINT 0 0) (ONEPOINT 10 10))) (SHOW LINE) (SHOW (TRANSFORM LINE (ZROT 25))) (ERASE) (SHOW (GROUP LINE (TRANSFORM (TRANSFORM (TRANSFORM Line (SCALE 3)) (ZROT 20)) (XMOVE 10)))) For more examples, see PU:PR-DEMO.SL, run with (LAPIN "PU:PR-DEMO.SL") |
Added psl-1983/3-1/help/prlisp.mss version [c0a8ac753a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Device(lpt) @style(justification yes) @style(linewidth 80, spacing 1,indent 5) @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 "September 1981", Line "Operating Note 59" ) @set(page=1) @newpage() @begin(titlepage) @begin(titlebox) @b(PictureRLISP) @center[A LISP-Based Graphics Language System with Flexible Syntax and Hierarchical Data Structure by Fuh-Meei Chen, Paul R. Stay and Martin L. Griss Computer Science Department University of Utah Salt Lake City, Utah 84112 Last Revision: @value(date)] @end(titlebox) @begin(abstract) This report is a description and a users manual for PictureRLISP, a LISP based interactive graphics language. PictureRLISP has an ALGOL-like syntax, with primitives to create, manipulate and apply 3D transformations to hierachical data structures called "Models". PictureRLISP is entirely written in RLISP which is a high-level interface to Standard LISP. @end(Abstract) @begin(Researchcredit) Work supported in part by the National Science Foundation under Grant No. MCS80-07034. @end(Researchcredit) @end(titlepage) @pageheading(Left "PictureRLISP",Center "@value(date)", Right "@value(Page)" ) @set(page=1) @newpage @section<Introduction> PictureRLISP is a graphic specification language in an interactive RLISP environment. PictureRLISP usage typically consists of creating, modifying, and requesting the display of graphical objects, called "Models". A model is a three dimensional representation of the spatial, topological and graphical features of an object. Models can contain any number of primitives, which can generally be in any order. The hierarchical structure and implementation of the PictureRLISP system are designed to support both the beginning and the expert user as well. The sophisticated PictureRLISP user can utilize low level primitive operations to support customized modeling, syntax or device environments; yet the beginner need not know how to use these features. PictureRLISP is a re-implementation of an earlier system, PICTUREBALM@cite[Goates80], with a number of additions. The major improvement is that the entire system is now written in RLISP, including the low-level clipping and transformation routines. RLISP is an ALGOL-like interface to LISP, found more convenient to use by many people. The extensible, table-driven RLISP parser itself is written in LISP, permitting rapid syntactice customization. The version of RLISP used for PictureRLISP is built upon PSL@cite[Griss81,Griss82b], an efficient, portable and interactive LISP system. PSL provides rich data structures, dynamic storage management, and an efficient LISP to machine code compiler@cite[Griss79b], which makes PSL-based PictureRLISP much more efficient than the previous PictureBALM system. A complete PSL currently runs on DECSystem-20, VAX-11/750 under UNIX. A preliminary PSL now runs on an Apollo DOMAIN (a Motorola MC68000-based personal machine with high-resolution graphics). PictureRLISP is capable of driving a number of different graphic output devices, and is fairly easy to extend to others. The current devices that built-in PictureRLISP drivers support include: Tektronix 4010 (and 'clones, such as ADM3a with retrographics board, Apollo Tektronix emulator,etc.); Hewlett-Packard HP2648a; Evans and Sutherland MPS-1; AED-512 color terminal; and "checkout" graphics on low-resolution devices such as 60 x 80 Ann-Arbor Ambassador, or 24 x 80 Teleray-1061 or VT100. PictureRLISP has also been extended to run under EMODE@cite[Galway82], an interactive LISP-based, full-screen editor which is similar to EMACS. EMODE runs within the PSL environment, and permits the editing of PictureRLISP commands and procedures, and then immediate execution from within the editing window. One can also define graphics windows to display the models presented. @section(Basic concepts) @subsection(Models) PictureRLISP usage typically consists of creating, modifying, and requesting the display of graphical objects, called "Models". A Model is a three dimensional representation of the spatial, topological and graphical features of an object. Models can contain any number of primitives, which can generally be in any order. PictureRLISP Model primitives include: Point Sets, which might be interpreted as polygons, connected line segments, curve control points, etc.; transformations of objects or coordinate systems in three dimensional space; color or appearance attributes; Repeat Specifications, which cause sub-sections of the Model to be replicated; named references to other Models to be displayed as if they were part of the current Model; and procedure calls. Allowing Models to contain references to other Models facilitates dynamic displays and allows the user to structure his data in Clusters in a meaningful manner. Sub-Models may be shared among a number of Models. Allowing procedure calls to be imbedded within Models provides the user with a mechanism which can easily effect arbitrary displays, transformations, parameterized models or other functions that may be required by a specific application; in some cases, it is essential to represent objects by algorithms or procedural models. @subsection<Coordinate systems, Viewport> [ *** This section needs more work ****] Currently, each device supported by has its own "screen" coordinates, and the user has to think of his model sizes in a device specific fashion. This is a defect, and we are planning to change the basic system so that each device driver will normalize coordiates so that a square of side N world-coordinates (or M inches?) will map onto the physical screen, with a square aspect ratio. Clipping of objects outside this square (cube) and exact placement of the square will be controlled by default settings of the View Port and a Global transformation matrix. Since both view port and global transformation (for perspective and scaling) are adjustable, the idea will be to provide a more natural default. Perhaps two or three sets of defualts are desirable, selectable by the user: A device independant WORLD view, a semi-device independant PHYSICAL size and a very device specific SCREEN view. @subsection<Example of PictureRLISP> As a small example of the flavor of PictureRLISP, the following commands will display a set of BOX's of different sizes, after suitable device initialization: @begin(verbatim) BOX := {0,0}_{0,10}_{10,10}_{10,0}_{0,0}; % Assigns to BOX a set of connected points for 10*10 box SHOW BOX & BOX | ZROT(45) & BOX | SCALE(2); % Display 3 boxes, the original, a rotated box, and % a 20 * 20 box. The & collects a set of unconnected models % and | attaches a transformation (matrix) @end(verbatim) @section(Specification of the PictureRLISP Language) PictureRLISP supports the creation and manipulation of Models both by means of built-in procedures for the various primitives (points, pointsets, and groups) and by means of syntactic extensions, i.e. operators which construct Models out of primitives. PictureRLISP contains five operators designed to make graphics programs easy to read and write. They are denoted by the following special characters: {, }, _, & and |, and map to an appropriate set of Lisp procedures. The following is the set of legal Model primitives: @begin(enumerate) @u(Point.) Points are constructed by using curly brackets, or by the function POINT(x,y,z,w), e.g. {x,y} [denotes the point (x, y, 0) in three dimensional space]. Points can be described by any one of four ways. A single value on the x axis, a two dimensional point, a three dimensional point or in homogeneous coordinate space. @u(Pointset.) The function POINTSET(p,q,..s) or the infix "_" operator is used to make Point Sets; e.g. it can be used to make polygons out of Points. For example, the usual graphical interpretation of the sequence A@ _@ B@ _@ C, where A, B, and C are Points, moves the display beam to the point represented by A, draws to B, and then draws to C. @u(Group) A Group is a set of Point Sets or Points and is formed by the infix operator & or the function GROUP(ps1,ps2,...psN). Thus models may be grouped together and formed into larger models for reference. @u(Point Set Modifiers.) Point Set Modifiers alter the interpretation of any Point Sets within their scope. The curved Point Set Modifier BEZIER() causes the points to be interpreted as the specification points for a BEZIER curve. The BEZIER curve has as its end points the endpoints of the control polygon. BSPLINE() does the same for a closed Bspline curve. If a control polygon is not closed then then algorithm will create a closed polygon by assuming there is a line segment between the endpoints. In order to get these curves a pointset acting as control points need to be given. Even though the control points may not be closed for a BSPLINE curve the system will close the polygon to form a closed BSPLINE curve. Another modifier is that of COLOR() where on color drawing systems different color values can be given to the model. @u(Transforms.) Transforms are the Model primitives which correspond to transformations of objects or coordinate systems in three dimensional space. PictureRLISP supports rotation, translation, scaling, perspective transformation and clipping. The Transform primitives are: @begin<enumerate> Translation: Move the specified amount along the specified axis. @*XMOVE (deltaX) ; YMOVE (deltaY) ; ZMOVE (deltaZ) @*MOVE (deltaX, deltaY, deltaZ) @blankspace(1 line) These Transforms are implemented as procedures which return a transformation matrix as their value. Scale : Scale the Model SCALE (factor) @*XSCALE (factor) ; YSCALE (factor) ; ZSCALE (factor) @*SCALE1 (x.scale.factor, y.scale.factor, z.scale.factor) @*SCALE <Scale factor>. Scale along all axes. @blankspace(1 line) These Transforms are implemented as a transformation matrix which will scale Models by the specified factors, either uniformly or along only one dimension. Rotation: Rotate the Model @*ROT (degrees) ; ROT (degrees, point.specifying.axis) @*XROT (degrees) ; YROT (degrees) ; ZROT (degrees) @blankspace(1 line) These procedures return a matrix which will rotate Models about the axis specified. Currently rotation are limited to being about the three coordinate axes, though one would like to be able to specify an arbitrary rotation axis. WINDOW (z.eye,z.screen): The WINDOW primitive assumes that the viewer is located along the z axis looking in the positive z direction, and that the viewing window is to be centered on both the x and y axis. The window function is used to show perspective for models and the default window at initialization of the device is set with the eye at -300 and with the screen at 60. If one wish to use a right handed coordinate system then the eye is in the positive direction. VWPORT(leftclip,rightclip,topclip,bottomclip): The VWPORT, which specifies the region of the screen which is used for display. This is set to a convenient default at the time a device is initialized by the device drivers. @end<enumerate> @u(Repeat Specifications.) This primitive provides the user with a means of replicating a section of a Model any number of times as modified by an arbitrary Transform, e.g. in different positions. The primitive is called REPEATED (number.of.times, my.transform), where number.of.times is an integer. The section of the Model which is contained within the scope of the Repeat Specification is replicated. Note that REPEATED is intended to duplicate a sub-image in several different places on the screen; it was not designed for animation. @u(Identifiers of other Models.) When an identifier is encountered, the Model referenced is displayed as if it were part of the current Model. Allowing Models to contain identifiers of other Models greatly facilitates dynamic displays. @u(Calls to PictureRLISP Procedures.) This Model primitive allows procedure calls to be imbedded within Models. When the Model interpreter reaches the procedure identifier it calls it, passing it the portion of the Model below the procedure as an argument. The current transformation matrix and the current pen position are available to such procedures as the values of the global identifiers GLOBAL!.TRANSFORM and HEREPOINT. This primitive provides the user with a mechanism which can be used to easily effect arbitrary displays, transformations, functions or models required by a specific application. The value of the procedure upon its return is assumed to be a legal Model and is SHOW'n; PictureRLISP uses syntax to distinguish between calling a procedure at Model-building time and imbedding the procedure in the Model to be called at SHOW time; if normal procedure call syntax, i.e. proc.name@ (parameters), is used then the procedure is called at Model-building time, but if only the procedure's identifier is used then the procedure is imbedded in the Model. @u(Global Variables) There are a number of important global variables in PictureRLISP whose meaning should be aware of, and which should be avoided by the user, unless understood: @begin<description> @u<Globals>@\@u<Meaning> HEREPOINT@\Current cursor position as a 4-vector. HERE@\Current cursor position as a '(POINT x y z) ORIGIN@\The vector [0,0,0,1]. GLOBAL!.TRANSFORM@\A global transform specified by the user, which is applied to everything as the "last" transformation. A default is set in the Device initializtion, but can be changed by user as convenient. MAT!*1@\Unit 4 x 4 transformation matrix. MAT!*0@\Zero 4 x 4 transformation matrix. DEV!.@\Name of the current device, for device dependent code. CURRENT!.TRANSFORM@\The current (cumulative) transformation matrix. All points are transformed by this before a move or draw. Initialized to GLOBAL!.TRANSFORM before each Display. CURRENT!.LINE@\The current Pointset modifier, can be 'BEZIER, 'BSPLINE or the default straight line modifier 'LINE. !*EMODE@\Tells the system and or user if PictureRlisp is in EMODE status. @end(description) @end(enumerate) @newpage The following is a BNF-like description of the set of legal Models. The meta-symbols used are ::= for "is a" and | for "or". Capitalized tokens are non-terminal symbols of the grammar of Models, a usage that is adhered to in the text of this report. Upper case tokens are PictureRLISP reserved words, which have been defined as RLISP procedures, operators and/or macros. Lower case tokens can be either numbers or identifiers, but not quoted number identifiers, except for "string" which denotes either a RLISP item of type string or a string identifier. @begin(verbatim) <Model> ::= NIL | <Simple Model> | <Model> & <Model> <Simple Model> | <Model Object> | ( <Model> ) | <Model> | <Model Modifier> | <Model Identifier> | '<Model Identifier> <Model Object> ::= NIL | <Point Set> | <Model Object Identifier> | '<Model Object Identifier> <Model Modifier> ::= NIL | <Transform> | <Point Set Modifier> <Transform> ::= XROT (degrees) | YROT (degrees) | ZROT (degrees) | XMOVE (deltaX) | YMOVE (deltaY) | ZMOVE (deltaZ) | MOVE (xdelta, ydelta, zdelta) | SCALE (factor) | XSCALE (factor) | YSCALE (factor)| ZSCALE(factor) | SCALE (x.factor, y.factor, z.factor) | WINDOW (z.eye,z.screen) | <Transform Identifier> | ' <Transform Identifier> Repeat Specification ::= REPEATED (number!.of!.times, Transform) <Point Set Modifier> ::= | BEZIER() | BSPLINE() | CIRCLE(r) | COLOR(value) <Point Set> ::= <Point> | <Point> _ <Point Set> | <Point Set Identifier> | '<Point Set Identifier> <Point> ::= {x} | {x, y} | {x, y, z} | {x,y,z,w} | Point Identifier | ' Point Identifier @end(verbatim) @section<Basic PictureRLISP Procedures> It should be emphasized that the typical user of the PictureRLISP language need never use some of these primitives directly, nor need he even know of their existence. They are called by the procedures which are written in RLISP which implement the standard PictureRLISP user functions. Nevertheless, they are available for the sophisticated user who can utilize them to implement a customized language environment. Also, they might serve as an example of the primitives that a PictureRLISP implementor would want to add to support other devices. @subsection(Common Functions) @begin<description> @b<ERASE()>@\Clears the screen and leaves the cursor at the origin. @b<SHOW (pict)>@\Takes a picture and display it on the screen @b<ESHOW (pict)>@\Erases the whole screen and display "pict" @b<HP!.INIT()>@\Initializes the operating system's (TOPS-20) view of the characteristics of HP2648A terminal. @b<TEK!.INIT()>@\Initializes the operating system's (TOPS-20) view of the characteristics of TEKTRONIX 4006-1 terminal and also ADM-3A with Retrographics board. @b<TEL!.INIT()>@\Initializes the operating system's (TOPS-20) view of the graphics characteristics of the Teleray 1061 terminal. This is rather crude graphics, on a 24*80 grid, using the character X. Nevertheless, it provides a reasonable preview. @b<MPS!.INIT()>@\Initializes the operating system's (UNIX) on the vax to handle the MPS commands. (currently on the VAX). @b<ST!.INIT()>@\Initializes the operating system's view of the characteristics of the Apollo workstation (a 68000 based system hooked up to the DEC 20 or Vax), emulating a TekTronix 4006 and VT-52 simultaneously in multiple windows. @b<AED!.INIT()>@\Initializes the operating system's view of the graphics color device AED-512 a 4006 tektronix color system. @end(Description) @subsection(Low Level Driver Functions) Most of these are "generic" names for the device specific procedures to do basic drawing, moving, erasing etc. The initialization routine for device XX, called XX!.INIT() above, copies the routines, usually called XX!.YYYY into the generic names YYYYY. @begin(description) @b<ERASES()>@\Erase the Graphics Screen @B<GRAPHON()>@\Called by SHOW, ESHOW and ERASE() to put the device into graphics mode. May have to turn off normal terminal ECHO, using ECHOOFF(), unless running under EMODE. @b<GRAPHOFF()>@\Called by SHOW, ESHOW and ERASE() to put the device back into text mode. May have to turn normal terminal ECHO back on, using ECHOON(), unless running under EMODE. @b<MOVES (x, y)>@\Moves the graphics cursor to the point (x, y) where x and y are specified in coordinates. These coordinates will be converted to absolute location on the screen allowing different devices to display the same models whether they have the same coordinate systems internaly or not. @b<DRAWS (x, y)>@\Draws a line from the current cursor position to the point specified in screen space. @end(description) @subsection(Low Level Matrix Operations) @begin(description) @b<MAT!*MAT (new!.transform, current!.transform)>@\This procedure is passed two transformation matrices. Each matrix is represented by a 16 element vector of floating point or interger numbers. They are concatenated via matrix multiplication and returned as the new value of current transform. @b<PNT!*PNT(point!.1,point!.2)>@\This procedure is passed two 4-vector matrices, a value is returned. @b<PNT!*MAT(point,transformation)>@\This is passed 4-vector and a 4 by 4 matrix, and returns a new (transformed) point. @end<description> @section<Internal Representations of PictureRLISP Graphical Objects> In the LISP-like internal form, Points and Transforms are represented by 4 vectors (homogeneous coordinates, also assuming the model has been placed on w=1.0 plane) and 16 element vectors respectively. Other Model primitives are represented as operators in LISP S-expressions of the form "(operator arg1 arg2... argN)". Points and matrices can also be represented as S-expression operators, if this is desirable for increased flexibility. It will be helpful for the PictureRLISP user to know what the meaning of the interpreted form is in terms of the PictureRLISP parsed form. The operator is some meaningful token, such as POINT, TRANSFORM, POINTSET or GROUP; e.g. GROUP is the representation of the user level operator "&". The operator is used as a software interpreter label, which makes this implementation of a PictureRLISP interpreter easy to extend. Here is the table to show the external and corresponding internal forms for some basic PictureRLISP operators. @begin <verbatim> @u[Internal Form] @u[External Form] @u[Result on Draw] (POINT x y z ) {x,y,z} [x,y,z,w] (POINTSET a b c d) a_b_c_d move to a, then connect b, c, and d. (GROUP (pointset a b a_b_c_d & e do each pointset in c d) e) turn. (TRANSFORM f g) f | g apply the transform g to the picture f. (TRANSFORM point point | draws a circle with (CIRCLE radius)) CIRCLE(radius) radius specified about the center "point". (TRANSFORM pict pict | draws Bezier curve for (BEZIER) BEZIER() "pict". (TRANSFORM pict pict | same as (pict |BEZIER()) (BSPLINE) BSPLINE() but drawing Bspline curve. (TRANSFORM pict pict | REPEATED the "pict" is replicated (REPEATED (count,trans) "count" times as modified count trans )) by the specified transform "trans". For example, the Model @end<verbatim> @begin(display) (A _ B _ C & {1,2} _ B) | XROT (30) | 'TRAN ; maps to the LISP form: (TRANSFORM (TRANSFORM (GROUP (POINTSET A B C) (POINTSET (POINT 1 2) B)) (XROT 30)) (QUOTE TRAN)) @end(display) These structures give a natural hierachical structure as well as scope rules to PictureRLISP. @section<How to run PictureRLISP> Models can be built using any number of primitives and transformations and assigned to model ID's. Once a model is defined and the device has been choosen then the object can be drawn on the graphics device by using the commands Show and Eshow, both of which will display the model or object on the graphics device and the difference being that Eshow will first erase the screen. To erase the screen one can issue the command Erase() and all models and object will be erased from the screen. Unfortunately one cannot erase individual objects from the display device. The following section will give an idea on other aspects of running PictureRLISP by example. @section<Examples of PictureRLISP Commands> In the following examples, anything following a % on the same line is a comment. Rlisp expressions (or commands) are terminated with a semicolon. It is suggested that you execute these examples while executing PictureRLISP at one of the terminals to see the correct response one would get. Most of these are located in the file <stay.pict>exp.red on the DecSystem 20 at Utah and is supplied with the release of PictureRLISP. @begin(verbatim) % % PictureRLISP Commands to SHOW lots of Cubes % % Outline is a Point Set defining the 20 by 20 % square which will be part of the Cubeface % Outline := { 10, 10} _ {-10, 10} _ {-10,-10} _ { 10,-10} _ {10, 10}; % Cubeface will also have an Arrow on it % Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}; % We are ready for the Cubeface Cubeface := (Outline & Arrow) | 'Tranz; % Note the use of static clustering to keep objects % meaningful as well as the quoted Cluster % to the as yet undefined transformation Tranz, % which will result in its evaluation being % deferred until SHOW time % and now define the Cube Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90); % In order to have a more pleasant look at % the picture shown on the screen we magnify % cube by 5 times. BigCube := Cube | SCALE 5; % Set up initial Z Transform for each cube face % Tranz := ZMOVE (10); % 10 units out % Now draw cube % SHOW BigCube; @blankspace(4 inches) % Draw it again rotated and moved left % SHOW (BigCube | XROT 20 | YROT 30 | ZROT 10); @blankspace(4 inches) % Dynamically expand the faces out % Tranz := ZMOVE 12; % SHOW (BigCube | YROT 30 | ZROT 10); @blankspace(4inches) % Now show 5 cubes, each moved further right by 80 % Tranz := ZMOVE 10; % SHOW (Cube | SCALE 2.5 | XMOVE (-240) | REPEATED(5, XMOVE 80)); @blankspace(4 inches) % % Now try pointset modifier. % Given a pointset (polygon) as control points either a BEZIER or a % BSPLINE curve can be drawn. % Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ % % Now draw Bezier curve % Show the polygon and the Bezier curve % SHOW (Cpts & Cpts | BEZIER()); @blankspace(4 inches) % Now draw Bspline curve % Show the polygon and the Bspline curve % SHOW (Cpts & Cpts | BSPLINE()); @blankspace(4inches) % Now work on the Circle % Given a center position and a radius a circle will be drawn % SHOW ( {10,10} | CIRCLE(50)); @blankspace(3inches) % Define a procedure which returns a model of % a Cube when passed the face to be used % Symbolic Procedure Buildcube; List 'Buildcube; % put the name onto the property list Put('buildcube, 'pbintrp, 'Dobuildcube); Symbolic Procedure Dobuildcube Face$ Face & Face | XROT(180) & Face | YROT(90) & Face | YROT(-90) & Face | XROT(90) & Face | XROT(-90) ; % just return the value of the one statement % Use this procedure to display 2 cubes, with and % without the Arrow - first do it by calling % Buildcube at time the Model is built % P := Cubeface | Buildcube() | XMOVE(-15) & (Outline | 'Tranz) | Buildcube() | XMOVE 15; % SHOW (P | SCALE 5); @blankspace(4inches) % Now define a procedure which returns a Model of % a cube when passed the half size parameter Symbolic Procedure CubeModel; List 'CubeModel; %put the name onto the property list Put('CubeModel,'Pbintrp, 'DoCubeModel); Symbolic Procedure DoCubeModel HSize; << if idp HSize then HSize := eval HSize$ { HSize, HSize, HSize} _ {-HSize, HSize, HSize} _ {-HSize, -HSize, HSize} _ { HSize, -HSize, HSize} _ { HSize, HSize, HSize} _ { HSize, HSize, -HSize} _ {-HSize, HSize, -HSize} _ {-HSize, -HSize, -HSize} _ { HSize, -HSize, -HSize} _ { HSize, HSize, -HSize} & {-HSize, HSize, -HSize} _ {-HSize, HSize, HSize} & {-HSize, -HSize, -HSize} _ {-HSize, -HSize, HSize} & { HSize, -HSize, -HSize} _ { HSize, -HSize, HSize} >>; % Imbed the parameterized cube in some Models % His!.cube := 'His!.size | CubeModel(); Her!.cube := 'Her!.size | CubeModel(); R := His!.cube | XMOVE (60) & Her!.cube | XMOVE (-60) ; % Set up some sizes and SHOW them His!.size := 50; Her!.size := 30; % SHOW R ; @blankspace(4inches) % % Set up some different sizes and SHOW them again % His!.size := 35; Her!.size := 60; % SHOW R; @blankspace(4inches) @end<verbatim> @section<How to run PictureRLISP on the various devices> The current version of PictureRLISP runs on a number of devices at the University of Utah. PictureRLISP source is in PU:PRLISP.RED, and the device driver library is in the file PU:PRLISP-DRIVERS.RED. These files, compiled into the binary LOAD form are PRLISP-1.B and PRLISP-2.B. Both are automatically loaded if the user invokes LOAD PRLISP; from PSL:RLISP (see PSL documentation for implementation and usage of the loader). The following contains information concerning the generic form of a device driver, and the execution of PictureRLISP under PSL. PictureRLISP is such that device drivers can be written for what ever device you are using for a graphics display device. @subsection<Generic Device Driver> The following is an example of an xxx device driver and its associated routines. The main routines of the driver may be divided into three areas: low level I/O, basic graphics primitives (eg. move, draw, viewport etc.), and the setup routine. @begin(verbatim) %*************************** % setup functions for * % terminal devices * %*************************** % FNCOPY(NewName,OldName) is used to copy equivalent a % device specific function (e.g. xxx-Draws) into the generic % procedure name % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % xxx specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % device low level routines to drive the escape sequences for % a graphics device. These output procedures will send the various % codes to the device to perform the desired generic function Procedure xxx!.OutChar x; %. RawTerminal I/o Pbout x; Procedure xxx!.EraseS(); %. EraseS screen, Returns terminal <<xxx!.OutChar Char ESC; %. to Alpha mode and places cursor. xxx!.OutChar Char FF>>; % The following procedures are used to simulate the tektronix % interface for picturerlisp and are considered the graphics % primitives to emulate the system. Procedure xxx!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << xxx!.OutChar HIGHERY NormY YDEST$ %. information to the xxx!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte xxx!.OutChar HIGHERX NormX XDEST$ %. sequences containing the xxx!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure xxx!.MoveS(XDEST,YDEST)$ <<xxx!.OutChar 29 $ %. GS: sets terminal to Graphic mode. xxx!.4BYTES (XDEST,YDEST)$ xxx!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure xxx!.DrawS (XDEST,YDEST)$ %. Same as xxx!.MoveS but << xxx!.OutChar 29$ %. draw the line. xxx!.4BYTES (CAR2 HERE, CAR3 HERE)$ xxx!.4BYTES (XDEST, YDEST)$ xxx!.OutChar 31>> $ Procedure xxx!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure xxx!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure xxx!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. the display device X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure xxx!.Delay(); %. some devices may need a NIL; %. delay to flush the buffer output Procedure xxx!.GRAPHON(); %. set the device in graph mode If not !*emode then echooff(); Procedure xxx!.GRAPHOFF(); %. Take the device out of graphics mode If not !*emode then echoon(); Procedure xxx!.INIT$ %. Initialization of device specIfic Begin %. Procedures equivalent. PRINT "XXX IS DEVICE"$ DEV!. := ' XXX; FNCOPY( 'EraseS, 'xxx!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'xxx!.NormX)$ % initialization when using FNCOPY( 'NormY, 'xxx!.NormY)$ % xxx as the device FNCOPY( 'MoveS, 'xxx!.MoveS)$ FNCOPY( 'DrawS, 'xxx!.DrawS)$ FNCOPY( 'VWPORT, 'xxx!.VWPORT)$ FNCOPY( 'Delay, 'xxx!.Delay)$ FNCOPY( 'GraphOn, 'xxx!.GraphOn)$ FNCOPY( 'GraphOff, 'xxx!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ @end(verbatim) The following is a sample session of PSL:Rlisp initializing the device xxx. @begin(verbatim) @@psl:rlisp *PSL 3.0 Rlisp, 9-May-1982 *[1] load prlisp; % The system types the [1] prompt *[2] xxx.init(); @end(verbatim) The system is now ready for pictureRlisp use, and one could then load in any other routines for their application. It should be noted that a number of devices can be loaded into the system but presently only one is the current display device at any given time. The following are specifics on each of the devices currently being used in PictureRlisp. The coordinate systems mentioned are device coordianates and should be transparent to the user. @subsection<Hp terminal 2648A> The screen of the HP terminal is 720 units long in the X direction, and 360 units high in the Y direction. The coordinate system used in HP terminal places the origin in approximately the center of the screen, and uses a domain of -360 to 360 and a range of -180 to 180. The procedure HP!.INIT() will load in the functions used for the HP terminal. @subsection<Tektronix terminal> Similarly, the screen of the TEKTRONIX 4006 and 4010 terminala are 1024 units long in the X direction, and 780 units high in the Y direction. The same origin is used but the domain is -512 to 512 in the X direction and the range is -390 to 390 in the Y direction. TEK!.INIT() will initialize the tektronix device for displayable graphics. @subsection<Apollo work station> Currently the APOLLO DOMAIN can work station is being used as a terminal to the Decsystem 20, using the ST program on the Apollo. The screen is split into 2 windows, on of 24*80 lines, emulating a Teleray 1061, and the other a 400 * 700 tektronix likes graphics terminal. ST!.INIT() is used for initializing the commands for the apollo. @subsection<Teleray Terminal> The teleray terminal can only display characters on the screen. It can be used as a "rapid-checkout" device, by drawing all lines as a sequence of x's. To initialize the teleray the command TEL!.INIT() will setup the graphics device to be the teleray terminal. This gives a 24 * 80 resolution. @subsection<Ann Arbaor Ambassador Terminal> The teleray terminal can only display characters on the screen. It can be used as a "rapid-checkout" device, by drawing all lines as a sequence of x's. To initialize the teleray the command TEL!.INIT() will setup the graphics device to be the teleray terminal. This gives a 60 * 80 resolution. @subsection<Evans and Sutherland Multi Picture System> Currently, the MPS can be driven on the gr-vax at the University of Utah and is an example of a high level graphics device being driven by PictureRLISP. Thus it may be interesting to look at the device driver for the mps to get the feel for how PictureRLISP drives high level graphics devices. The initialization is done by calling the procedure MPS!.INIT(). [???? add the other devices such as the AED, ADM3a+Retro ???] @section<Future Work> PictureRLISP currently uses a large number of vectors, regenerating points at the very lowest level. Since all Clipping and transformation is done in LISP, using vectors. This results in very frequent garbage collection, a time-consuming and expensive process. On the DEC-20, a grabage takes about 2.5 secs. On the VAX, GC is only 1 second, and happens much less frequently. It is planned to optimize this lower level. Perhaps this could be fixed by using a number of fluid point vectors as the only points which exist as vectors. Since all devices currently defined in PRLISP-DRIVERS.RED use a standard tektronix interface it becomes impossible under the current version to use some features that the devices have defined in hardware. For instance the MPS system has bult in clipping, viewport and windowing functions all defined in hardeware as well as 3-d display. At this point it is impossible for one to use the full features offered by the mps and it seems that it would be nice if one could use some of these features. @section(References) @bibliography() |
Added psl-1983/3-1/help/prlisp2d.hlp version [1077186b83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 2D version of PictureRLISP MLG 4 Jan 1983 ------------------------------------------------------ This is a brief guide to the 2D version of Picture RLISP. This is much faster than the full 3D version if only planar displays are required. It is the X-Y plane subset of PRLISP. PRLISP can now be run under PSL as well, though of course with no syntax. RLISP Use: LOAD PRLISP2D; % Load 2D version of PictureRLISP HP!.INIT(); % Select Driver, this is most common HP2648a version Line := {0,0} _ {10,10}; % Line from center towards upper-right Show Line; % Draw it Show Line | ZROT(25); % Draw rotated by 25 degrees Erase(); % Clear screen Show Line & (Line | scale 3 | zrot 20 ) | xmove 10; For more examples, see PU:PR2D-DEMO.RED, use IN "PU:PR2D-DEMO.RED"$ PRLISP2D can also be loaded and run from PSL, but no syntax is available: (LOAD PRLISP2D) (HP!.INIT) (setq LINE (POINTSET (ONEPOINT 0 0) (ONEPOINT 10 10))) (SHOW LINE) (SHOW (TRANSFORM LINE (ZROT 25))) (ERASE) (SHOW (GROUP LINE (TRANSFORM (TRANSFORM (TRANSFORM Line (SCALE 3)) (ZROT 20)) (XMOVE 10)))) For more examples, see PU:PR2D-DEMO.SL, run with (LAPIN "PU:PR2D-DEMO.SL") |
Added psl-1983/3-1/help/showflags.doc version [a56a17e63c].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | The Names and State of important Flags and Globals can be displayed by executing: ShowFlags(Flag-name-list) or ShowGlobals(Global-Name-List) If the List is NIL, some default set of Flags or Globals will be displayed. Each Flag or Global will have a short descriptive string associated with it, under the indicator 'FlagInfo or 'GlobalInfo. These are stored with DefineFlag(Id,Info-String) % Note that ID does NOT include the !* and DefineGlobal(Global,Info-string) |
Added psl-1983/3-1/help/step.hlp version [ffc659f1d4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | STEP(Form:any):any EXPR -------------------------------------------------------------------------- Step is a loadable option (Load Step). Evaluates form, single-stepping. Form is printed, preceded by -> on entry, <-> for macro expansions. After evaluation, Form is printed preceded by <- and followed by the result of evaluation. A single character is read at each step to determine the action to be taken: Control-N (Next) Step to the Next thing. The stepper continues until the next thing to print out, and it accepts another command. Space Go to the next thing at this level. In other words, continue to evaluate at this level, but don't step anything at lower levels. This is a good way to skip over parts of the evaluation that don't interest you. Control-U (Up) Continue evaluating until we go up one level. This is like the space command, only more so; it skips over anything on the current level as well as lower levels. Control-X (eXit) Exit; finish evaluating without any more stepping. Control-G, Control-P (Grind) Grind (i.e. prettyprint) the current form. Control-R Grind the form in Rlisp syntax. Control-E (Editor) Invoke the structure editor on the current form. Control-B (Break) Enter a break loop from which you can examine the values of variables and other aspects of the current environment. Control-L Redisplay the last 10 pending forms. ? Display this help file. |
Added psl-1983/3-1/help/tag-bits.doc version [0ade98f368].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL TAG BITS TAG TAG*2 Meaning (octal) ------------------------------------- 0 00 01 Positive Integer 1 02 03 Fixnum 2 04 05 Bignum 3 06 07 Float 4 10 11 String 5 12 13 Byte-Vector 6 14 15 Halfword-Vector 7 16 17 Word-Vector 8 20 21 Vector 9 22 23 Pair 15 36 37 Code 23 56 57 (Header) Bytes 24 60 61 (Header) Halfwords 25 62 63 (Header) Words 26 64 65 (Header) Vector 27 66 67 Forward 28 70 71 BTR 29 72 73 Unbound 30 74 75 ID 31 76 77 Negative Integer ------------------------------------- |
Added psl-1983/3-1/help/time-fnc.doc version [d1e97c542b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Time-fnc.sl : code to time function calls. Usage: do (timef function-name-1 function-name-2 ...) Timef is a fexpr. It will redefine the functions named so that timing information is kept on these functions. This information is kept on the property list of the function name. The properties used are `time' and `number-of-calls'. (get function-name 'time) gives you the total time in the function. (not counting gc time). Note, this is the time from entrance to exit. The timef function redefines the function with an unwind-protect, so calls that are interrupted by *throws are counted. (get function-name 'number-of-calls) gives you the number of times the function is called. To stop timing do : (untimef function-name1 ..) or do (untimef) for all functions. (untimef) is a fexpr. To print timing information do (print-time-info function-name-1 function-name-2 ..) or do (print-time-info) for timing information on all function names. special variables used: *timed-functions* : list of all functions currently being timed. *all-timed-functions* : list of all functions ever timed in the current session. Comment: if tr is called on a called on a function that is already being timed, and then untimef is called on the function, the function will no longer be traced. |
Added psl-1983/3-1/help/useful.doc version [a4f741270a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | A number of useful options can be defined by Loading Useful. Descriptions follow. BACKQUOTE and friends ------------------ (Note that the special symbols decribed here will only work in LISP syntax, not RLISP. In RLISP you may simply use the functions BACKQUOTE, UNQUOTE, UNQUOTEL, and UNQUOTED) The backquote symbol "`" is a read macro which introduces a quoted expression which may contain the unquote symbols comma "," and comma-atsign ",@". Any appropriate form consisting of the unquoted expression, calls to the function cons, and quoted expressions are produced so that the resulting expression looks like the quoted one except that the values of the unquote expressions are substitued in the appropriate place. ",@" splices in the value of the subsequent expression (i.e. strips off the outer layer of parentheses). Thus `(a (b ,x) c d ,@x e f) is equivalent to (cons 'a (cons (list 'b x) (append '(c d) (append x '(e f))))) In particular, if x is bound to (1 2 3) this will evaluate to (a (b (1 2 3)) c d 1 2 3 e f) ",." is like ",@", except it may use destructive operations on its argument. DESETQ ------ DESETQ is a destructuring setq. That is, the first argument is a piece of list structure whose atoms are all ids. Each is setq'd to the corresponding part of the second argument. For instance (desetq (a (b) . c) '((1) (2) (3) 4)) setq's a to (1), b to 2, and c to ((3) 4). DEFMACRO -------- DEFMACRO is a useful tool for defining macros. A DEFMACRO form looks like (defmacro <name> <pattern> <s1> <s2> ... <sN>) The <pattern> is an S-expression made of pairs and ids. It is matched against the arguments of the macro much like the first argument to desetq. All of the non-nil ids in <pattern> are local variables which may be used freely in the body (the <si>). When the macro is called the <si> are evaluated as in a progn with the local variables in <pattern> appropriately bound, and the value of <sN> is returned. DEFMACRO is often used with backquote. DEFLAMBDA --------- Another macro defining macro similar to DEFMACRO is DEFLAMBDA. The arguments to DEFLAMBDA are identical to those for DE. The resulting macro is simply application of a lambda expression. Thus a function defined with DEFLAMBDA will have semantics identical to that of a function defined with DE, modulo the ability to dynamically redefine the function. This is a convenient way to cause functions to be open compiled. For example, if (NEW-FOO X Y) should return (LIST X Y (LIST X Y)) we do not want it to be a simple substitution style macro, in case one of the actual arguments has side effects, or is expensive to compute. If we define it by (DEFLAMBDA NEW-FOO (X Y) (LIST X Y (LIST X Y))) then we will have the desired behaviour. In particular, (NEW-FOO (BAR) (SETQ BAZ (BOOZE))) will expand to ((LAMBDA (X Y) (LIST X Y (LIST X Y)) ) (BAR) (SETQ BAZ (BOOZE)) ) PROG1 ----- PROG1 evaluates its arguments in order, like PROGN, but returns the value of the first. LET and LET* ------------ LET is a macro giving a more perspicuous form for writing lambda expressions. The basic form is (let ((v1 i1) (v2 i2) ...(vN iN)) s1 s2 ... sN) The i's are evaluated (in an unspecified order), and then the v's are bound to these values, the s's evaluated, and the value of the last is returned. Note that the i's are evaluated in the outer environment before the v's are bound. LET!* is just like LET, except that it makes the assignments sequentially. That is, the first binding is made before the value for the second one is computed. MACROEXPAND ----------- MACROEXPAND is a useful tool for debugging macro definitions. If given one argument, MACROEXPAND will all expand all the macros in that form. Often we wish more control over this process. For example, if a macro expands into a let, we may not wish to see the LET itself expanded to a lambda expression. Therefor additional arguments may be given to MACROEXPAND. If these are supplied, only they should be macros, and only those specified will be expanded. PUSH and POP ------------ These are convenient macros for adding and deleting things from the head of a list. (push item stack) is equivalent to (setq stack (cons item stack)), and (pop stack) does (setq stack (cdr stack)) and returns the item popped off stack. An additional argument may be supplied to pop, in which case it is a variable which is setq'd to the popped value. INCR and DECR ------------- These are convenient macros for incrementing and decrementing numeric variables. (incr i) is equivalent to (setq i (add1 i)) and (decr i) to (setq i (sub1 i)). Additional arguments may be supplied, which are summed and used as the amounts by to increment or decrement. DO, DO*, DO-LOOP, and DO-LOOP* ------------------------------ The DO macro is a general iteration construct similar to that of LISPM and friends. However, it does differ in some details; in particular it is not compatible with the "old style DO" of MACLISP (which is a crock anyway), nor does it support the "no end test means once only" convention (which was just an ugly kludge to get an initialized prog). DO has the form (do (i1 i2 ... iN) (test r1 r2 ... rK) s1 s2 ... sM) where there may be zero or more i's, r's, and s's. In general the i's will have the form (var init step) On entry to the DO form, all the inits are evaluated, then the variables are bound to their respective inits. The test is evaluated, and if non-nil the form evaluates the r's and returns the value of the last one. If none are supplied it returns nil. If the test evaluates to nil the s's are evaluated, the variables are assigned the values of their respective steps in parallel, and the test evaluated again. This iteration continues until test evaluates to a non-nil value. Note that the inits are evaluated in the surrounding environment, while the steps are evaluated in the new environment. The body of the DO (the s's) is a prog, and may contain labels and GO's, though use of this is discouraged. It may be changed at a later date. RETURN used within a DO will return immediately without evaluating the test or exit forms (r's). There are alternative forms for the i's: If the step is omitted, the variable's value is left unchanged. If both the init and step are omitted or if the i is an id it is initialized to nil, and left unchanged. This is particularly useful for introducing dummy variables which will be setq'd inside the body. DO* is like DO, expcept the variable bindings and updatings are done sequentially instead of in parallel. DO-LOOP is like Do, except that it takes an additional argument, a prologue. The general form is (do-loop (i1 i2 ... iN) (p1 p2 ... pJ) (test r1 r2 ... rK) s1 s2 ... sM) This is executed just like the corresponding DO, except that after the bindings are established and initial values assigned, but before the test is first executed the pi's are evaluated, in order. Note that the pi's are all evaluated exactly once (assuming that none of the pi's err out, or otherwise throw to a surrounding context). DO-LOOP* does the variable bindings and undates sequentially instead of in parallel. IF, WHEN, and UNLESS for If and Only If Statements -------------------------------------------------- IF is a macro to simplify the writing of a common form of COND where there are only two clauses and the antecedent of the second is t. (if <test> <then-clause> <else1>...<elseN>) The <then-clause> is evaluated if and only if the test is non-nil, otherwise the elses are evaluated, and the last returned. There may be zero elses. Related macros for common COND forms are WHEN and UNLESS. (when <test> s1 s2 ... sN) evaluates the si and returns the value of sN if and only if <test> is non-nil. Otherwise WHEN returns nil. (unless <test> s1 s2 ... sN) <=> (when (not <test>) s1 s2 ... sN). PSETQ and PSETF --------------- (psetq var1 val1 var2 val2 ... varN valN) setq's the vars to the corresponding vals. The vals are all evaluated before any assignments are made. That is, this is a parallel setq. PSETF is to SETF as PSETQ is to SETQ. SETF ---- USEFUL contains an expanded version of the standard SETF macro. The principal difference from the default is that it always returns the the thing assigned (i.e. the right hand side). For example, (setf (cdr foo) '(x y z)) returns '(x y z). In the default SETF the return value is indeterminate. USEFUL also makes several more functions known to SETF. All the c...r functions are included. LIST and CONS are also include, and are similar to desetq. For example, (setf (list (cons a b) c (car d)) '((1 2) 3 4 5)) sets a to 1, b to (2), c to 3, and rplaca's the car of d to 4. It returns ((1 2) 3 4 5). SHARP-SIGN MACROS ------------------ USEFUL defines several MACLISP style sharp sign read macros. Note that these only work with the LISP reader, not RLISP. Those currently included are #' : this is like the quote mark ' but is for FUNCTION instead of QUOTE. #/ : this returns the numeric form of the following character read without raising it. For example #/a is 97 while #/A is 65. #\ : This is a read macro for the CHAR macro, described in the PSL manual. Not that the argument is raised, if *RAISE it non-nil. For example, #\a = #\A = 65, while #\!a = #\(lower a) = 97. Char has been redefined in USEFUL to be slightly more table driven -- users can now add new "prefixes" such as META or CONTROL: just hang the appropriate function (from integers to integers) off the char-prefix-function property of the "prefix". A LARGE number of additional alias for various characters have been added, including all the "standard" ASCII names like NAK and DC1. #. : this causes the following expression to be evaluated at read time. For example, `(1 2 #.(plus 1 2) 4) reads as (1 2 3 4) #+ : this reads two expressions, and passes them to the if_system macro. That is, the first should be a system name, and if that is the current system the second argument is returned by the reader. If not, nil is returned. #- is similar, but causes the second arg to be returned only if it is NOT the current system. Note that this does NOT use splice macros, since PSL doesn't have them (I don't really know why not -- at the very least there ought to be a way to tell the reader "ignore this", even if splice macros are thought to be a kludge). FOR --- FOR is a general iteration construct similar in many ways to the Lisp Machine LOOP construct, and the earlier InterLISP CLISP iteration construct. FOR, however, is considerably simpler, far more "lispy", and somewhat less powerful. FOR will only work in LISP syntax. In fact, loading FOR will, for the time being, "break" RLISP, as it redefines the FOR macro. It is hoped that eventually the RLISP parser will be modified to emit calls on this new FOR macro instead of the old one. The arguments to FOR are clauses; each clause is itself a list of a keyword and one or more arguments. The clauses may introduce local variables, specify return values, have side-effects, when the iteration should cease, and so on. Before going further, it is probably best to give an example. The following function will zip together three lists into a list of three element lists. (de zip3 (x y z) (for (in u x) (in v y) (in w z) (collect (list u v w)))) The three IN clauses specify that their first argument should take successive elements of the respective lists, and the COLLECT clause specifies that the answer should be a list built out of its argument. For example, (zip3 '(1 2 3 4) '(a b c d) '(w x y z)) is ((1 a w)(2 b x)(3 c y)(4 d z)). Following are described all the possible clauses. The first few introduce iteration variables. Most of these also give some means of indicating when iteration should cease. For example, when a list being mapped over by an IN clause is exhausted, iteration must cease. If several such clauses are given in FOR expression, iteration will cease whenever on of the clauses indicates it should, whether or not the other clauses indicate that it should cease. (in v1 v2) assigns the variable v1 successive elements of the list v2. This may take an additional, optional argument: a function to be applied to the extracted element or sublist before it is assigned to the variable. The following returns the sum of the lengths of all the elements of L. [rather a kludge -- not sure why this is here. Perhaps it should come out again.] (de SumLengths (L) (for (in N L length) (sum N))) For example, (SumLengths '((1 2 3 4 5)(a b c)(x y))) is 10. (on v1 v2) assigns the varaible v1 successive cdrs of the list v2. (from var init final step) is a numeric clause. The variable is first assigned init, and then incremented by step until it is larger than final. Init, final, and step are optional. Init and step both default to 1, and if final is omitted the iteration will continue until stopped by some other means. To specify a step with init or final omitted, or a final with init omitted place nil (the constant -- it cannot be an expression) in the appropriate slot to be omitted. Final and step are only evaluated once. (for var init next) assigns the variable init first, and subsequently the value of the expression next. Init and next may be omitted. Note that this is identical to the behaviour of iterators in a DO. (with v1 v2 ... vN) introduces N locals, initialized to nil. In addition, each vi may also be of the form (var init), in which case it will be initialized to init. There are two clauses which allow arbitrary code to be executed before the first iteration, and after the last. (initially s1 s2 ... sN) will cause the si's to be evaluated in the new environment (i.e. with the iteration variables bound to their initial values) before the first iteration. (finally s1 s2 ... sN) causes the si's to be evaluated just before the function returns. (do s1 s2 ... sN) causes the si's to be evaluated at each iteration. The next few clauses build up return types. Except for the RETURNS/RETURNING clause, they may each take an additional argument which specifies that instead of returning the appropriate value, it is accumulated in the specified variable. For example, an unzipper might be defined as (de unzip3 (L) (for (in u L) (with X Y Z) (collect (car U) X) (collect (cadr U) Y) (collect (caddr U) Z) (returns (list X Y Z)))) This is essentially the opposite of zip3. Given a list of three element lists, it unzips them into three lists, and returns a list of those three lists. For example, (unzip '((1 a w)(2 b x)(3 c y)(4 d z))) is ((1 2 3 4)(a b c d)(w x y z)). (returns exp) causes the given expression to be the value of the FOR. Returning is synonymous with returns. It may be given additional arguments, in which case they are evaluated in order and the value of the last is returned (implicit PROGN). (collect exp) causes the succesive values of the expression to be collected into a list. (adjoin exp) is similar, but only adds an element to the list if it is not equal to anything already there. (adjoinq exp) is like adjoin, but uses eq instead of equal. (conc exp) causes the succesive values to be nconc'd together. (join exp) causes them to be appended. (union exp) forms the union of all the exp (unionq exp), (intersection exp), (intersectionq exp) are similar, but use the specified function instead of union. (count exp) returns the number of times exp was non-nil. (sum exp), (product exp), (maximize exp), and (minimize exp) do the obvious. Synonyms are summing, maximizing, and minimizing. (always exp) will return t if exp is non-nil on each iteration. If exp is ever nil, the loop will terminate immediately, no epilogue code, such as that introduced by finally will be run, and nil will be returned. (never exp) is equivlent to (always (not exp)). Explicit tests for the end of the loop may be given using (while exp). The loop will terminate if exp becomes nil at the beginning of an iteration. (until exp) is equivalent to (while (not exp)). Both while and until may be given additional arguments; (while e1 e2 ... eN) is equivalent to (while (and e1 e2 ... eN)) and (until e1 e2 ... eN) is equivalent to (until (or e1 e2 ... eN)). (when exp) will cause a jump to the next iteration if exp is nil. (unless exp) is equivalent to (when (not exp)). Unlike MACLISP and clones' LOOP, FOR does all variable binding/updating in parallel. There is a similar macro, FOR*, which does it sequentially. All variable binding/updating still preceeds any tests or other code. Also note that all WHEN or UNLESS clauses apply to all action clauses, not just subsequent ones. This fixed order of evaluation makes FOR less powerful than LOOP, but also keeps it considerably simpler. The basic order of evaluation is 1) bind variables to initial values (computed in the outer environment) 2) execute prologue (i.e. INITIALLY clauses) 3) while none of the termination conditions are satisfied: 4) check conditionalization clauses (WHEN and UNLESS), and start next iteration if all are not satisfied. 5) perform body, collecting into variables as necessary 6) next iteration 7) (after a termination condition is satisfied) execute the epilogue (i. e. FINALLY clauses) DEFSWITCH --------- Defswitch provides a convenient machanism for declaring variables whose values need to be set in a disciplined manner. It is quite similar to T's DEFINE-SWITCH. The form of a defswitch expression is (defswitch <name> <var> [<read-action> {<set-action>}]) This declares <name> to be a function of no arguments for deterimining the value of the variable <var>. <var> is declared fluid. SETF will set the value of <var> when given a call on <name> as its first argument. When <name> is called <read-action> will be evaluated (after the value of the variable is looked up). When it is set the <set-action>s will be evaluated (before the value is set). <name> may be used as a "free" variable in the <read-action> and <set-action>s, in which case it will hold the current value and new value, respectively. If <var> is nil an uninterned id will be used for the variable. Suppose we wish to keep a list in a variable, FOO, but also want to always have it's length available in FOOLENGTH. We can do this by always accessing FOO by a function as follows: (defswitch FOO nil nil (setq FOOLENGTH (length FOO))) |
Added psl-1983/3-1/help/zbasic.doc version [1e77be0cb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZBASIC contains 6 packages -- (1) YLSTS -- useful functions for lists. (2) YNUMS -- useful functions for numbers. (3) YSTRS -- useful functions for strings. (4) YIO -- useful functions for user io. (5) YCNTRL -- useful functions for program control. (6) YRARE -- functions we use now, but may eliminate. YLSTS -- BASIC LIST UTILITIES CCAR ( X:any ):any CCDR ( X:any ):any LAST ( X:list ):any NTH-CDR ( L:list N:number ):list NTH-ELT ( L:list N:number ):elt of list NTH-TAIL( L:list N:number ):list TAIL-P ( X:list Y:list ):extra-boolean NCONS ( X:any ): (CONS X NIL) KWOTE ( X:any ): '<eval of #X> MKQUOTE ( X:any ): '<eval of #X> RPLACW ( X:list Y:list ):list DREMOVE ( X:any L:list ):list REMOVE ( X:any L:list ):list DSUBST ( X:any Y:any Z:list ):list LSUBST ( NEW:list OLD:list X:any ):list COPY ( X:list ):list TCONC ( P:list X:any ): tconc-ptr LCONC ( P:list X:list ):list CVSET ( X:list ):set ENTER ( ELT:element SET:list ):set ABSTRACT( FN:function L:list ):list EACH ( L:list FN:function ):extra-boolean SOME ( L:list FN:function ):extra-boolean INTERSECTION ( SET1:list SET2:list ):extra-boolean SETDIFFERENCE ( SET1:list SET2:list ):extra-boolean SUBSET ( SET1:any SET2:list ):extra boolean UNION ( X:list Y:list ):list SEQUAL ( X:list Y:list ):extra boolean MAP2C ( X:list Y:list FN:function ):NIL MAP2 ( X:list Y:list FN:function ):NIL ATSOC ( ALST:list, KEY:atom ):any CCAR( X:any ):any ---- Careful Car. Returns car of x if x is a list, else NIL. CCDR( X:any ):any ---- Careful Cdr. Returns cdr of x if x is a list, else NIL. LAST( X:list ):any ---- Returns the last cell in X. E.g. (LAST '(A B C)) = (C), (LAST '(A B . C)) = C. NTH-CDR( L:list N:number ):list ------- Returns the nth cdr of list--0 is the list, 1 the cdr ... NTH-ELT( L:list N:number ):list ------- Returns the nth elt of list--1 is the car, 2 the cadr ... NTH-TAIL( L:list N:number ):list ------- Returns the nth tail of list--1 is the list, 2 the cdr ... TAIL-P( X:list Y:list ):extra-boolean ------ If X is a non-nil tail of Y (X eq cdr Y or cddr Y or...), return X. Renamed to avoid a conflict with TAILP in compiler NCONS( X:any ): (CONS X NIL) ----- Returns (CONS X NIL) KWOTE( X:any ): '<eval of #X> MKQUOTE( X:any ): '<eval of #X> ------- Returns the quoted value of its argument. RPLACW( X:list Y:list ):list ------ Destructively replace the Whole list X by Y. DREMOVE( X:any L:list ):list ------- Remove destructively all equal occurrances of X from L. REMOVE( X:any L:list ):list ------ Return copy of L with all equal occurrences of X removed. COPY( X:list ):list ---- Make a copy of X--EQUAL but not EQ (except for atoms). DSUBST( X:any Y:any Z:list ):list ------ Destructively substitute copies(??) of X for Y in Z. LSUBST( NEW:list OLD:list X:any ):list ------ Substitute elts of NEW (splicing) for the element old in X TCONC( P:list X:any ): tconc-ptr ----- Pointer consists of (CONS LIST (LAST LIST)). Returns (and alters) pointer consisting of (CONS LIST1 (LAST LIST1)), where LIST1 = (NCONC1 LIST X). Avoids searching down the list as nconc1 does, by pointing at last elt of list for nconc1. To use, setq ptr to (NCONS NIL), tconc elts, return car of ptr. LCONC( P:list X:list ):list ----- Same as TCONC, but NCONCs instead of NCONC1s. CVSET( X:list ):list -------------------- Converts list to set, i.e., removes redundant elements. ENTER( ELT:element SET:list ):list ----- Returns (ELT . SET) if ELT is not member of SET, else SET. ABSTRACT( FN:function L:list ):list -------- Returns list of elts of list satisfying FN. EACH( L:list FN:function ):extra boolean ---- Returns L if each elt satisfies FN, else NIL. SOME( L:list FN:function ):extra boolean ---- Returns the first tail of the list whose CAR satisfies function. INTERSECTION( #SET1:list #SET2:list ):extra boolean ------------ Returns list of elts in SET1 which are also members of SET2 SETDIFFERENCE( #SET1:list #SET2:list ):extra boolean ------------- Returns all elts of SET1 not members of SET2. SUBSET( #SET1:any #SET2:list ):extra boolean ------ Returns SET1 if each element of SET1 is a member of SET2. UNION( X:list Y:list ):list ----- Returns the union of lists X, Y SEQUAL( X:list Y:list ):extra boolean ------ Returns X if X and Y are set-equal: same length and X subset of Y. MAP2( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired tails of X and Y. MAP2C( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired elts of X and Y. ATSOC( ALST:list, KEY:atom ):any ----- Like ASSOC, except uses an EQ check. Returns first element of ALST whose CAR is KEY. YNUMS -- BASIC NUMBER UTILITIES ADD1 ( number ):number EXPR SUB1 ( number ):number EXPR ZEROP ( any ):boolean EXPR MINUSP ( number ):boolean EXPR PLUSP ( number ):boolean EXPR POSITIVE( X:any ):extra-boolean EXPR NEGATIVE( X:any ):extra-boolean EXPR NUMERAL ( X:number/digit/any ):boolean EXPR GREAT1 ( X:number Y:number ):extra-boolean EXPR LESS1 ( X:number Y:number ):extra-boolean EXPR GEQ ( X:number Y:number ):extra-boolean EXPR LEQ ( X:number Y:number ):extra-boolean EXPR ODD ( X:integer ):boolean EXPR SIGMA ( L:list FN:function ):integer EXPR RAND16 ( ):integer EXPR IRAND ( N:integer ):integer EXPR The DEC compiler may optimize calls to PLUS2, DIFFERENCE, EQUAL, LESSP, etc. by converting them to calls to ADD1, SUB1, ZEROP, MINUSP, etc. This will create circular defintions in the conditional defintions, about which the compiler will complain. Such complaints can be ignored. ADD1( number ):number EXPR ---- Note: DEC compiler optimizes (PLUS2 N 1) into (ADD1 N). SUB1( number ):number EXPR ---- Note: DEC compiler optimizes (DIFFERENCE N 1) into (SUB1 N). ZEROP( X:any ):boolean EXPR ----- Returns non-nil iff X equals 0. MINUSP( N:number ):boolean EXPR ------ Returns non-nil iff N is less than 0. PLUSP( N:number ):boolean EXPR ----- Returns non-nil iff N is greater than 0. ODD( X:integer ):boolean EXPR --- Returns T if x is odd, else NIL. WARNING: EVENP is used by REDUCE to test if a list has even length. ODD and EVENP are thus highly distinct. POSITIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a positive number. NEGATIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a negative number. NUMERAL( X:any ): boolean EXPR ------- Returns true for both numbers and digits. Some dialects had been treating the digits as numbers, and this fn is included as a replacement for NUMBERP where NUMBERP might really be checking for digits. N.B.: Digits are characters and thus ID's GREAT1( X:number Y:number ):extra-boolean EXPR ------ Returns X if it is strictly greater than Y, else NIL. GREATERP is simpler if only T/NIL is needed. LESS1( X:number Y:number ):extra-boolean EXPR ----- Returns X if it is strictly less than Y, else NIL LESSP is simpler if only T/NIL is needed. GEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is greater than or equal to Y, else NIL. LEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is less than or equal to Y, else NIL. SIGMA( L:list, FN:function ):integer EXPR ----- Returns sum of results of applying FN to each elt of LST. RAND16( ):integer EXPR IRAND ( N:integer ):integer EXPR ------ Linear-congruential random-number generator. To avoid dependence upon the big number package, we are forced to use 16-bit numbers, which means the generator will cycle after only 2^16. The randomness obtained should be sufficient for selecting choices in VOCAL, but not for monte-carlo experiments and other sensitive stuff. decimal 14933 = octal 35125, decimal 21749 = octal 52365 Returns a new 16-bit unsigned random integer. Leftmost bits are most random so you shouldn't use REMAINDER to scale this to range Scale new random number to range 0 to N-1 with approximately equal probability. Uses times/quotient instead of remainder to make best use of high-order bits which are most random YSTRS -- BASIC STRING UTILITIES EXPLODEC ( X:any ):char-list EXPR EXPLODE2 ( X:any ):char-list EXPR FLATSIZE ( X:str ):integer EXPR FLATSIZE2( X:str ):integer EXPR NTHCHAR ( X:str N:number ):char-id EXPR ICOMPRESS( LST:lst ):<interned id> EXPR SUBSTR ( STR:str START:num LENGTH:num ):string EXPR CAT-DE ( L: list of strings ):string EXPR CAT-ID-DE( L: list of strings ):<uninterned id> EXPR SSEXPR ( S: string ):<interned id> EXPR EXPLODE2( X:any ):char-list EXPR EXPLODEC( X:any ):char-list EXPR -------- List of characters which would appear in PRIN2 of X. If either is built into the interpreter, we will use that defintion for both. Otherwise, the definition below should work, but inefficiently. Note that this definition does not support vectors and lists. (The DEC and IBM interpreters support EXPLODE and EXPLODE2 by using the same internal algorithm that is used for PRIN1 (PRIN2), but put the chars generated into a list instead of printing them. Thus, they work on arbitrary s-expressions.) If either EXPLODEC or EXPLODE2 is defined, the CDE does nothing. Note: According to the STANDARD LISP REPORT, EXPLODE and EXPLODE2 are only defined for atoms. If your interpreter does not support extended EXPLODE and EXPLODE2, then change the second CDE's below for FLATSIZE and FLATSIZE2 to get recursive versions of them. FLATSIZE( X:any ):integer EXPR -------- Number of chars in a PRIN1 of X. Also equals length of list created by EXPLODE of X, assuming that EXPLODE extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN1, but count chars instead of printing them. If your EXPLODE only works for atoms, comment out the above CDE and turn the CDE below into DE. FLATSIZE2( X:any ):integer EXPR --------- Number of chars in a PRIN2 of X. Also equals length of list created by EXPLODE2 of X, assuming that EXPLODE2 extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN2, but count chars instead of printing them. FLATSIZE will often suffice for FLATSIZE2 If your EXPLODE2 only works for atoms, comment out the CDE above and turn the CDE below into DE. NTHCHAR( X:any, N:number ):character-id EXPR ------- Returns nth character of EXPLODE2 of X. ICOMPRESS( LST:list ):interned atom EXPR --------- Returns INTERN'ed atom made by COMPRESS. SUBSTR( STR:string START:number LENGTH:number ):string EXPR ------ Returns a substring of the given LENGTH beginning with the character at location START in the string. NB: The first location of the string is 0. If START or LENGTH is negative, 0 is assumed. If the length given would exceed the end of the string, the subtring returned quietly goes to end of string, no error. CAT-DE( L: list of expressions ):string EXPR ------- Returns a string made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT macro. CAT-ID-DE( L: list of any ):uninterned id EXPR ------- Returns an id made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT-ID macro. SSEXPR( S: string ): id EXPR ------ Returns ID `read' from string. Not very robust. YIO -- simple I/O utilities. All EXPR's. CONFIRM (#QUEST: string ):boolean EATEOL ():NIL TTY-DE (#L: list ):NIL TTY-TX-DE (#L: list ):NIL TTY-XT-DE (#L: list ):NIL TTY-TT-DE (#L: list ):NIL TTY-ELT (#X: elt ):NIL PRINA (#X: any ):NIL PRIN1SQ (#X: any ):NIL PRIN2SQ (#X: any ):NIL PRINCS (#X: single-char-id ):NIL --queue-code-- SEND ():NIL SEND-1 (#EE) ENQUEUE (#FN #ARG) Q-PRIN1 (#E: any ):NIL Q-PRINT (#E: any ):NIL Q-PRIN2 (#E: any ):NIL Q-TERPRI () ONEARG-TERPRI (#E: any ):NIL Q-TYO (#N: ascii-code ):NIL Q-PRINC (#C: single-char-id ):NIL * Q-TTY-DE (#CMDS: list ):NIL * Q-TTY-XT-DE (#CMDS: list ):NIL * Q-TTY-TX-DE (#CMDS: list ):NIL * Q-TTY-TT-DE (#CMDS: list ):NIL DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) ( SETQ !#ANS (CAR (EXPLODEC (READ)))) (COND ((EQ !#ANS (QUOTE Y)) (PROGN ( EATEOL) (RETURN T))) ((EQ !#ANS (QUOTE N)) (PROGN (EATEOL) (RETURN NIL))) (( EQ !#ANS (QUOTE !?)) (GO LP0)) (T (TTY!-XT Please type Y, N or ?.)) (GO LP1))) Eat (discard) text until $EOL$ or <ESC> seen. <ESC> meaningful only on PDP-10 systems. $EOL$ meaningful only on correctly-implemented Standard-LISP systems. An idea whose time has not yet come... DE TTY!-DE (EOLS!#BEFORE !#L EOLS!#AFTER) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) LP1 (COND ((ONEP EOLS!#BEFORE) (TTY!-ELT !$EOL!$)) (( ZEROP EOLS!#BEFORE) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#BEFORE ( SUB1 EOLS!#BEFORE)) (GO LP1)))) (MAPC !#L (FUNCTION TTY!-ELT)) LP1 (COND (( ONEP EOLS!#AFTER) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#AFTER) NIL) (T (PROGN ( TTY!-ELT !$EOL!$) (SETQ EOLS!#AFTER (SUB1 EOLS!#AFTER)) (GO LP2)))) (WRS OLD!#CHAN))) So, for now at least, ... PRINA( X:any ): any ----- Prin2s expression, after TERPRIing if it is too big for line, or spacing if it is not at the beginning of a line. Returns the value of X. Except for the space, this is just PRIN2 in the IBM interpreter. CHRCT (): <number> ----- CHaRacter CounT left in line. Also a CDE in YPP.LSP -- built into IMSSS DEC interpreter. BINARY (#X: boolean): old-value ------ Stub for non-IMSSS interpreters. In IMSSS interpreter, will put terminal into binary mode or take it out, according to argument, and return old value. PRIN1SQ (#X: any) ------- PRIN1, Safe, use apostrophe for Quoted expressions. This is essentially a PRIN1 which tries not to exceed the right margin. It exceeds it only in those cases where the pname of a single atom exceeds the entire linelength. In such cases, <big> is printed at the terminal as a warning. (QUOTE xxx) structures are printed in 'xxx form to save space. Again, this is a little superfluous for the IBM interpreter. PRIN2SQ (#X: any) ------- PRIN2, Safe, use apostrophe for Quoted expressions. Just like PRIN1SQ, but uses PRIN2 as a basis. PRINCS (#X: single-character-atom) ------- PRINC Safe. Does a PRINC, but first worries about right margin. 1980 Jul 24 -- New Queued-I/O routines. To interface other code to this new I/O method, the following changes must be made in other code: PRIN2 --> TTY TERPRI --> $EOL$ inside a TTY, which causes Q-TERPRI to be called TYO --> Q-TYO PRIN1, PRINT -- These are used only for debugging. Do a (SEND) just before starting to print things in realtime, or use Q-PRIN1 etc. TTY -- Ok, expands into TTY-DE which calls Q-PRIN2 and Q-TERPRI. SAY -- I don't know what to do with this crock. It seems to be a poor substitute for TTY. If so it can be changed to TTY with the arguments fixed to be correct. <!GRAM>LPARSE.LSP When *BATCHOUT is NIL, output is done in realtime and *BATCHQUEUE remains NIL. When *BATCHOUT is true, output is queued and SEND executes&dequeues it later. Initialize *BATCHQUEUE for TCONC operations. Initialize *BATCHMAX and *BATCHCNT These call PRIN2, so they would cause double-enqueuing. DE Q!-TTY!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-DE) !#CMDS)) ( 1 (TTY!-DE !#CMDS)))) DE Q!-TTY!-XT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-XT!-DE) !#CMDS)) (1 (TTY!-XT!-DE !#CMDS)))) DE Q!-TTY!-TX!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TX!-DE) !#CMDS)) (1 (TTY!-TX!-DE !#CMDS)))) DE Q!-TTY!-TT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TT!-DE) !#CMDS)) (1 (TTY!-TT!-DE !#CMDS)))) YCNTRL -- ROUTINES INVOLVED WITH PROGRAM CONTROL STRUCTURES CATCH ( EXP:s-expression LABELS:id or idlist ):any EXPR THROW ( VALU:any LABEL:id ): error label EXPR ERRSET-DE ( #EXP #LBL ):any EXPR APPLY# ( ARG1: function ARG2: argument:list ):any EXPR BOUND ( X:any ):boolean EXPR MKPROG ( VARS:id-lst BODY:exp ):prog EXPR BUG-STOP (): any EXPR CATCH( EXP:s-expression LABELS:id or idlist ): any EXPR ----- For use with throw. If no THROW occurs in expression, then returns value of expression. If thrown label is MEMQ or EQ to labels, then returns thrown value. OW, thrown label is passed up higher. Expression should be quoted, as in ERRORSET. THROW( VALU:any LABEL:id ): error label EXPR ----- Throws value with label up to enclosing CATCH having label. If there is no such CATCH, causes error. ERRSET-DE ( EXP LBL ):any EXPR Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. Usually called via ERRSET macro. APPLY#(ARG1: function ARG2: argument:list): any EXPR ------ Like APPLY, but can use fexpr and macro functions. BOUND( X:any ): boolean EXPR ----- Returns T if X is a bound id. MKPROG( VARS:id-lst BODY:exp ) EXPR ------ Makes a prog around the body, binding the vars. BUGSTOP ():NIL EXPR ------- Enter a read/eval/print loop, exit when OK is seen. YRARE -- ROUTINES WHICH ARE USED, BUT OF DUBIOUS USEFULNESS ?? DELETE THESE ?? LOADV ( V:vector FN:function ):vector EXPR AMONG ( ALST KEY ITEM ) EXPR INSERT ( ITEM ALST KEY ) EXPR DCONS ( X:any Y:list ):list EXPR SUBLIST ( X:list P1:integer P2:integer ):list EXPR SUBLIST1( Y ) EXPR LDIFF ( X:list Y:list ):list EXPR used in editor/copy in ZEDIT MAPCAR# ( L:list FN:function ):any EXPR MAP# ( L:list FN:function ):any EXPR INITIALP( X:list Y:list ):boolean EXPR SUBLISTP( X:list Y:list ):list EXPR INITQ ( X:any Y:list R:fn ):boolean EXPR LOADV( V:vector FN:function ):vector EXPR ----- Loads vector with values. Function should be 1-place numerical. V[I] _ FN( I ). If value of function is 'novalue, then doesn't change value. ?? AMONG(ALST:association-list KEY:atom ITEM:atom):boolean EXPR ----- Tests if item is found under key in association list. Uses EQUAL tests. INSERT (ITEM:item ALST:association:list KEY:any):association list ------ EXPR (destructive operation on ALST) Inserts item in association list under key or if key not present adds (KEY ITEM) to the ALST. DCONS( X:any Y:list ):list EXPR ----- Destructively cons x to list. SUBLIST( X:list P1:integer P2:integer ):list EXPR ------- Returns sublist from p1 to p2 positions, negatives counting from end. I.e., (SUBLIST '(A B C D E) 2 -2) = (B C D) LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X. MAPCAR#( L:list FN:function ):any EXPR ------- Extends mapcar to work on general s-expressions as well as lists. The return is of same form, i.e. (MAPCAR# 'ATOM '(A B C . D)) = (T T T . T) Also, if for any member of list the variable SPLICE is set to true by function, then for that member the return from the function is spliced into the return. MAP#( L:list FN:function ):any EXPR ---- Extends map to work on general s-expressions as well as lists. INITIALP( X:list Y:list ):boolean EXPR -------- Returns T if X is EQUAL to some ldiff of Y. SUBLISTP( X:list Y:list ):list EXPR -------- Returns a tail of Y (or T) if X is a sublist of Y. INITQ( X:any Y:list R:fn ):boolean EXPR ----- Returns T if x is an initial portion of Y under the relation R. |
Added psl-1983/3-1/help/zfiles.doc version [914c6dc12a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZFILES contains 2 packages -- (1) YFILES -- useful functions for accessing files. (2) YTOPCOM -- useful functions for compiling files. %%%% YFILES -- BASIC FILE ACCESSING UTILITIES File descriptor is a canonical FILE name, gets converted to file string: FILE or (FILE) -> "FILE.LSP" (FILE.EXT) -> "File.Ext" (DIR FILE) -> "<Dir>File.LSP" (DIR FILE EXT) -> "<dir>File.Ext" "xxx" -> "xxx" --------------------------------------------------------------- FORM-FILE ( FILE:DSCR ): filename EXPR GRABBER ( SELECTION FILE:DSCR ): NIL EXPR DUMPER ( FILE:DSCR ): NIL EXPR DUMPFNS-DE ( SELECTION FILE:DSCR ): NIL EXPR DUMP-REMAINING ( SELECTION:list DUMPED:list ): NIL EXPR FCOPY ( IN:DSCR OUT:DSCR filedscrs ):boolean EXPR REFPRINT-FOR-GRAB-CTL( #X: any ):NIL EXPR G:CREFON Switched on by cross reference program CREF:FILE G:JUST:FNS Save only fn names in variable whose name is the first field of filename if T, O/W save all exprs in that variable G:FILES List of files read into LISP G:SHOW:TRACE Turns backtrace in ERRORSET on if T G:SHOW:ERRORS Prints ERRORSET error messages if T GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. See ZMACROS. GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER IDS <file-dscr>) Like GRAB, but only reads in specified ids. See ZMACROS. FORM-FILE( FILE:DSCR ): filename EXPR --------- Takes a file dscr, possibly NIL, and returns a file name corresponding to that dscr and suitable as an argument to OPEN. F:OLD:FILE is set to this file name for future reference. Meanwhile, F:FILE:ID is set to a lisp identifier, and the file name is put on the OPEN:FILE:NAME property of that identifier. The identifier can be used to hold info about the file. E.g. its value may be a list of objects read from the file. NB: FORM-FILE is at the lowest level of machine-independant code. MAKE-OPEN-FILE-NAME is a system dependant routine that creates file names specifically tailored to the version of SLISP in use. GRABBER( SELECTION:id-list FILE:DSCR ):T EXPR ------- Opens the specified file, applies GRAB-EVAL-CTL to each expression on it, and then closes it. Returns T. See GRAB-EVAL-CTL for important side effects. GRAB-EVAL-CTL( #SELECTION EXPR#READ FILE#ID ) EXPR ------------- Examines each expression read from file, and determines whether to EVAL that expression. Also decides whether to append the expression, or an id taken from it, or nothing at all, to the value of the file id poined at by FILE#ID. The file id is stored for use as an argument to DUMP or COMPILE, for example. Note: G:JUSTFNS suppresses the storage of comments from the file. When reading LAP files, no list of fns is made. DUMPER( FILE:DSCR : file-dscr ): NIL EXPR ------ Dumps file onto disk. Filename as in GRABBER. Prettyprints the defined functions, set variables, and evaluated expressions which are members of the value of the variable filename. (For DEC versions: If IBASE neq 10, puts (SETQ IBASE current:base) at head of file.) DUMPFNS-DE( FNS FILE:DSCR ): NIL EXPR ---------- Like DUMPER. Copies old file, putting new definitions for specified functions/variables. E.g.: (DUMPFNS-DE '(A B) '(FOO)) will first copy verbatim all the expressions on FOO.LSP which do not define A or B. Then the core definitions of A and B are dumped onto the file. DUMP-REMAINING( SELECTION:list DUMPED:list ) EXPR -------------- Taken out of DUMPFNS for ease of reading. Dumps those properties of items in selection which have not already been dumped. FCOPY( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the prettyprinter. Useful for removing angle brackets or for tightening up function format. Returns T on normal exit, NIL if error reading file. FCOPY-SQ ( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the compacting printer. Letterizes and reports via '<big>' message long strings. Returns T on normal exit, NIL if error reading file. YTOPCOM -- Compiler Control functions (DF COMPILE-FILE (FILE:NAME) (DF COMPILE-IN-CORE (FILE:NAME) Commonly used globals. Declared in this file so each individual file doesn't have to declare them. "Other globals/fluids "This flag is checked by COMPILE-FILE. PPLAP( MODE CODE ) EXPR ----- Prints the lap code in some appropriate format. Currently uses PRIN1SQ (PRIN1, Safe, use apostrophe to Quote non-numeric expressions). COMPILE-FILE( FILE:DSCR ) FEXPR ------------ Reads the given file, and creates a corresponding LAP file. Each expression on the original file is mapped into an expression on the LAP file. Comments map into NIL. Function definitions map into the corresponding LAP code. These definitions are compiled, but NOT evaluated -- hence the functions will not be loaded into this core image by this routine. All other expressions are evaluated in an errorset then copied verbatim. EXCEPTION: UNFLUID is evalutated, but converted into a comment when printed, to avoid confusing loader. COMPILE-IN-CORE( FILE:DSCR ):NIL FEXPR --------------- Compiles all EXPRS and FEXPRS on a file and loads compiled code into core. Creates a file FILE:NAME.cpl which is a compilation log consisting of the names of functions compiled and the space used in their loading. GCMSG( X:boolean ):any EXPR ----- Pre-defined in both SLISP and new IBM intpreter, so this cde shouln't do anything. GCMSG turns the garbage collection msgs on or off. |
Added psl-1983/3-1/help/zmacro.doc version [e89fb61125].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZMACRO contains two macro packages -- (1) YMACS -- basically useful macros and fexprs. (2) YSAIMACS -- macros used to simulate many SAIL constructs. YMACS -- USEFUL MACROS AND FEXPRS (see also YSAIMAC) * ( X:any ): NIL MACRO ** ( X:list ) MACRO NEQ ( X:any Y:any ):boolean MACRO NEQN ( X:any Y:any ):boolean MACRO NEQUAL ( X:any Y:any ):boolean MACRO MAKE ( variable template ) MACRO SETQQ ( variable value ) MACRO EXTEND ( function series ) MACRO DREVERSE( list ):list MACRO APPENDL ( lists ) MACRO NCONCL ( lists ) MACRO NCONC1 ( lst exp1 ... expn ): any MACRO SELECTQ ( exp cases last-resort ) MACRO WHILE ( test body ) MACRO REPEAT ( body test ) MACRO FOREACH ( var in/of lst do/collect exp ) MACRO SAY ( test expressions ) MACRO DIVERT ( channel expressions ) MACRO CAT ( list of any ):string MACRO CAT-ID ( list of any ):<uninterned id> MACRO TTY ( L:list ):NIL MACRO TTY-TX ( L:list ):NIL MACRO TTY-XT ( L:list ):NIL MACRO TTY-TT ( L:list ):NIL MACRO ERRSET ( expression label ) MACRO GRAB ( file ) MACRO GRABFNS ( ids file-dscr ) MACRO DUMP ( file-dscr ) MACRO DUMPFNS ( ids file-dscr ) MACRO used to expand macros: XP#SELECTQ (#L#) EXPR XP#WHILE (#BOOL #BODY) EXPR XP#FOREACH (#VAR #MOD #LST #ACTION #BODY) EXPR XP#SAY1 ( expression ) EXPR *( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules. **( X:list ) MACRO ===> (PROGN <lists>) For comments--all atoms are ignored, lists evaluated as in PROGN. NEQ( X:any Y:any ):boolean MACRO ===> (NOT (EQ X Y)) Changed to CDM because NEQ in PSL means NOT EQUAL. We hope to change that situation, however. NEQN( X:any Y:any ):boolean MACRO ===> (NOT (EQN X Y)) NEQUAL( X:any Y:any ):boolean MACRO ===> (NOT (EQUAL X Y)) MAKE( variable template ) MACRO ===> (SETQ <var> <some form using var>) To change the value of a variable depending upon template. Uses similar format for template as editor MBD. There are 3 cases. 1) template is numerical: (MAKE VARIABLE 3) = (SETQ VARIABLE (PLUS VARIABLE 3)) 2) Template is a series, whose first element is an atom: (MAKE VARIABLE ASSOC ITEM) = (SETQ VARIABLE (ASSOC ITEM VARIABLE)) 3) Otherwise, variable is substituted for occurrences of * in template. (MAKE VARIABLE (ASSOC (CADR *) (CDDR *)) = (SETQ VARIABLE (ASSOC (CADR VARIABLE) (CDDR VARIABLE)) SETQQ( variable value ) MACRO ===> (SETQ VARIABLE 'VALUE) EXTEND( function series ) MACRO ===> (FN ELT1 (FN ELT2 ... (FN ELTn-1 ELTn))) Applies 2-place function to series, similarly to PLUS. E.g.: (EXTEND SETQ A B C D 5) = (SETQ A (SETQ B (SETQ C (SETQ D 5)))) DREVERSE( L: list ):list MACRO ===> (REVERSIP L) Synonym for REVERSIP. APPENDL( lists ) MACRO ===> (APPEND LIST1 (APPEND LIST2 ....)) EXPAND's APPEND to a list of arguments instead of just 2. NCONCL( lists ) MACRO ===> (NCONC LST1 (NCONC LST2 ....)) EXPAND's NCONC to a list of arguments instead of just 2. NCONC1( lst exp1 ... expn ): any MACRO ===> (NCONC LST (LIST EXP1 ... EXPn)) Destructively add exp1 ... exp-n to the end of lst. SELECTQ( exp cases last-resort ) MACRO ===> (COND ...) Exp is a lisp expression to be evaluated. Each case-i is of the form (key-i exp1 exp2...expm). Last-resort is a lisp expression to be evaluated. Generates a COND statement: If key-i is an atom, case-i becomes the cond-pair: ((EQUAL exp key-i) (PROGN exp1 exp2 ... expm)) If key-i is a list, case-i becomes the cond-pair: ((MEMBER exp key-i) (PROGN exp1 exp2 ... expm)) Last-resort becomes the final cond-pair: (T last-resort) If exp is non-atomic, it should not be re-evaluated in each clause, so a dummy variable (#SELECTQ) is set to the value of exp in the first test and that dummy variable is used in all successive tests. Note: (1) A FEXPR version of SELECTQ would forbid use of RETURN and GO. (2) The form created must NOT have a prog or lambda wrapped around the cond expression, as this would also forbid RETURN and GO. Since #SELECTQ can't be lambda-bound by any means whatsoever and remain consistent with the standard-lisp report (if GO or RETURN appears inside a consequent), there is no way we can make SELECTQ re-entrant. If you go into a break with ^B or ^H and execute another SELECTQ you will clobber the one and only incarnation of #SELECTQ, and if it happened to be in the middle of deciding which consequent to execute, then when you continue the computation it won't work correctly. Update -- IMSSS break pkg now tries to protect #SELECTQ. Update -- uses XP#SELECTQ which can be compiled to speed up macro expansion. WHILE( test body ) MACRO ===> (PROG ...) <while loop> While test is true do body. REPEAT( body test ) MACRO ===> (PROG ...) <repeat loop> Repeat body until test is true. Jim found that this fn as we had it was causing compiler errors. The BODY was (CDDR U) and the BOOL was (CADR U). Question: Does the fact that Utah was unable to reproduce our compiler errors lie in this fact. Does function until test becomes non-NIL. FOREACH( var in/of lst do/collect exp ) MACRO ===> (MAPxx LST (FUNCTION (LAMBDA (VAR) EXP))) Undocumented FOREACH supplied by Utah. Required by compiler. Update: modified to call xp#foreach which can be compiled to speed up macro expansion. SAY( test expressions ) MACRO ===> (COND (<test> (PROGN (PRIN2 ...) (PRIN2 ...) ...))) If test is true then evaluate and prin2 all expressions. Exceptions: the value of printing functions, those flaged with SAY:PRINT (including: PRINT PRIN1 PRIN2 PRINC TYO PPRINT TERPRI POSN DOHOME DORIGH DOLEFT DOUP DODOWN DPYNCH DPYCHR SETCUR MOVECUR) are just evaluated. E.g.: (In the example @ is used for quotes) (SAY T @this @ (PRIN1 '!!AND!!) @ that@) appears as: this !!AND!! that DIVERT( channel expressions ) MACRO ===> (PROG (ochan) <select given chan> <eval exps> <select ochan>) Yields PROG that selects channel for output, evaluates each expression, and then reselects prior channel. CAT( list of any ):string MACRO ===> (CAT-DE (LIST <list>)) Evaluates all arguments given and forms a string from the concatenation of their prin2 names. CAT-ID( list of any ):<uninterned id> MACRO ===> (CAT-ID-DE (LIST <list>)) Evaluates all arguments given and forms an id from the concatenation of their prin2 names. TTY ( L:list ):NIL MACRO TTY-TX( L:list ):NIL MACRO TTY-XT( L:list ):NIL MACRO TTY-TT( L:list ):NIL MACRO ===> (TTY-xx-DE (LIST <list>)) TTY is selected for output, then each elt of list is evaluated and PRIN2'ed, except for $EOL$'s, which cause a TERPRI. Then prior output channel is reselected. TTY-TX adds leading TERPRI. TTY-XT adds trailing TERPRI. TTY-TT adds leading and trailing TERPRI's. CDMs were making all of the following unloadable into existing QDRIVER.SAV core image. I flushed the 'C' July 27 TTY-DE now takes two extra arguments, for the number of TERPRIs to preceed and follow the other printed material. ERRSET (expression label) MACRO ===> (ERRSET-DE 'exp 'label) Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER FNS <file-dscr>) Like grab, but only reads in specified fns/vars. DUMP( <file description> ) MACRO ===> (DUMPER '<file-dscr>) Dumps file onto disk. Filename as in GRAB. Prettyprints. DUMPFNS( <ids> . <file dscr> ) MACRO ===> (DUMPFNS-DE <fns> '<file-dscr>) Like DUMP, but copies old file, inserting new defs for specified fns/vars We are currently defining these to be macros everywhere, but might want them to be exprs while interpreted, in which case use the following to get compile-time macros. PUT (QUOTE NEQ) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQ !#X !#Y)))) ) PUT (QUOTE NEQN) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQN !#X !#Y))))) PUT (QUOTE NEQUAL) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQUAL !#X !#Y))))) YSAIMAC -- MACROS used to simulate SAIL constructs. macros: DO-UNTIL SAI-IF SAI2-IF SAI-DONE SAI-CONTINUE SAI-WHILE SAI-FOREACH SAI-FOR SAI-BEGIN PBEGIN PRETURN SAI-ASSIGN MSETQ SAI-COLLECT IFC OUTSTR SAI-SAY SAI-& SAI-LENGTH CVSEST CVSEN CVS SUBSTRING-FOR SUBSTRING-TO PUSHES PUSHVARS SLIST SAI-MAPC SAI-EQU auxiliary exprs used to expand macros: XP#SAY-IF XP#SAI-WHILE XP#SAI-FOREACH XP#SAI-FOR XP#SUBSTRING-TO SAI-IF ( sailish if-expression ) MACRO (IF test1 THEN exp1 [ ELSEIF testi THEN expi ] [ELSE expn]) ===> (COND (test1 exp1) ... (testi expi) ... (T expn)) Embedded expressions do not cause embedded COND's, (unlike ALGOL!). Examples: (IF (ATOM Y) THEN (CAR X)) (IF (ATOM Y) THEN (CAR X) ELSE (CADR X)) (IF (ATOM Y) THEN (CAR X) ELSEIF (ATOM Z) THEN (CADR X)) SAI-WHILE ( sailish while-expression ) MACRO (WHILE b DO e1 e2 ... en) does e1,..., en as long as b is non-nil. ===> (PROG NIL CONTINUE: (COND ((NULL b) (RETURN NIL))) e1 ... en (GO CONTINUE:)) N.B. (WHILE b DO ... (RETURN e)) has the RETURN relative to the PROG in the expansion. As in SAIL, (CONTINUE) and DONE work as statements. (They are also macros.) REM is planning on cleaning this up so it works in all cases... The form that (SUBSTRING-TO stringexpr low high) should expand into is ((LAMBDA (#STRING) (SUBSTR #STRING low high)) stringexpr) except that low and high have been modified to replace INF by explicit calls to (FLATSIZE2 #STRING). Thus things like (SUBSTRING-TO (READ) 2 (SUB1 INF)) should work without requiring the user to type the same string twice. Probably that inner (SUBSTR ...) should simply be ((LAMBDA (INF) (SUBSTR #STRING low high)) (FLATSIZE2 #STRING)) where we don't have to internally modify low or high at all! |
Added psl-1983/3-1/help/zpedit.doc version [14007678b1].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/20-kernel-gen.ctl version [279ccffc74].
> > > > | 1 2 3 4 | @psl:psl *(lapin "p20:20-kernel-gen.sl") *(quit) |
Added psl-1983/3-1/kernel/20/20-kernel-gen.sl version [561534c75b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-KERNEL-GEN.SL - Generate scripts for building Dec-20 PSL kernel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 May 1982 % Copyright (c) 1982 University of Utah % % 21-May-83 Modified to produce Extended-20 version. % Took out delete of .MAC files, as some hand patching is (unfortunately) % still necessary. % 01-Mar-83 Nancy Kendzierski % Changed script files to use PathIn, instead of In and DSK:. % Changed link file to explicitly use .REL files on P20:. % <PSL.20-INTERP>20-KERNEL-GEN.SL.15, 7-Jun-82 12:48:19, Edit by BENSON % Converted kernel-file-name* to all-kernel-script... % <PSL.20-INTERP>20-KERNEL-GEN.SL.14, 6-Jun-82 05:29:21, Edit by GRISS % Add kernel-file-name* (compiletime (load kernel)) (compiletime (setq *EOLInStringOK T)) (loadtime (imports '(kernel))) (setq command-file-name* "%w.ctl") (setq command-file-format* ";Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20,pk: S:DEC20-CROSS.EXE ASMOut ""%w""; PathIn ""%w.build""; ASMEnd; quit; compile %w.mac, d%w.mac ") (setq init-file-name* "psl.init") (setq init-file-format* "(lapin ""%w.init"") ") (setq all-kernel-script-name* "all-kernel.ctl") (setq all-kernel-script-format* "submit %w.ctl ") (setq code-object-file-name* "%w.rel") (setq data-object-file-name* "d%w.rel") (setq link-script-name* "psl-link.ctl") (setq link-script-format* ";Modifications to this file may disappear, as this file is generated ;automatically using information in P20E:20-KERNEL-GEN.SL. cd S: LINK /map p20:nil.rel /set:.low.:202 p20:%e /save s:pbpsl.exe /go @get s:pbpsl.exe/u 1 @save s:bpsl.exe ") (setq script-file-name-separator* " p20:") (kernel '(types randm alloc arith debg error eval extra fasl io macro prop symbl sysio tloop main heap)) |
Added psl-1983/3-1/kernel/20/20.sym version [14d336ae2b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !') ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADQUOTEDEXPRESSION)) (PUT (QUOTE !() ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADLISTORDOTTEDPAIR)) (PUT (QUOTE !)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADRIGHTPAREN)) (PUT (QUOTE ![) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADVECTOR)) (PUT (MKID (CHAR EOF)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADEOF))))) (SETQ ORDEREDIDLIST!* (QUOTE (ID2INT NONIDERROR INT2ID TYPEERROR NONINTEGERERROR INT2SYS LISP2CHAR NONCHARACTERERROR INT2CODE SYS2INT GTFIXN ID2STRING STRING2VECTOR GTVECT NONSTRINGERROR VECTOR2STRING GTSTR NONVECTORERROR LIST2STRING LENGTH NONPAIRERROR STRING2LIST CONS LIST2VECTOR VECTOR2LIST GETV BLDMSG STDERROR INDEXERROR PUTV UPBV EVECTORP EGETV EPUTV EUPBV INDX RANGEERROR NONSEQUENCEERROR SETINDX SUB SUBSEQ GTWRDS GTHALFWORDS NCONS TCONC SETSUB SETSUBSEQ CONCAT APPEND SIZE CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP CAR CDR RPLACA RPLACD FIXP DIGIT LITER EQN LISPEQUAL STRINGEQUAL EQSTR EQUAL CAAAAR CAAAR CAAADR CAADAR CAADR CAADDR CADAAR CADAR CADADR CADDAR CADDR CADDDR CDAAAR CDAAR CDAADR CDADAR CDADR CDADDR CDDAAR CDDAR CDDADR CDDDAR CDDDR CDDDDR CAAR CADR CDAR CDDR SAFECAR SAFECDR ATOM CONSTANTP NULL NUMBERP EXPT MKQUOTE LIST3 CONTINUABLEERROR GREATERP DIFFERENCE MINUSP TIMES2 ADD1 QUOTIENT PLUS2 LIST EVLIS QUOTE EXPR DE LIST2 LIST4 PUTD FUNCTION LAMBDA FEXPR DF MACRO DM NEXPR DN SETQ EVAL SET PROG2 PROGN EVPROGN AND EVAND OR EVOR COND EVCOND NOT ABS MINUS DIVIDE ZEROP REMAINDER XCONS MAX ROBUSTEXPAND MAX2 LESSP MIN MIN2 PLUS TIMES MAP FASTAPPLY MAPC MAPCAN NCONC MAPCON MAPCAR MAPLIST ASSOC SASSOC PAIR SUBLIS DEFLIST PUT DELETE MEMBER MEMQ REVERSE SUBST EXPAND CHANNELPRINT CHANNELPRIN1 CHANNELTERPRI PRINT OUT!* NEQ NE GEQ LEQ EQCAR EXPRP GETD MACROP FEXPRP NEXPRP COPYD RECIP FIRST SECOND THIRD FOURTH REST REVERSIP SUBSTIP DELETIP DELQ DEL DELQIP ATSOC ASS MEM RASSOC DELASC DELASCIP DELATQ DELATQIP SUBLA RPLACW LASTCAR LASTPAIR COPY NTH SUB1 PNTH ACONC LCONC MAP2 MAPC2 CHANNELPRIN2T CHANNELPRIN2 PRIN2T CHANNELSPACES CHANNELWRITECHAR SPACES CHANNELTAB CHANNELPOSN TAB FILEP PUTC SPACES2 CHANNELSPACES2 LIST2SET LIST2SETQ ADJOIN ADJOINQ UNION UNIONQ XN XNQ INTERSECTION INTERSECTIONQ KNOWN!-FREE!-SPACE GTHEAP FATALERROR !%RECLAIM GC!-TRAP!-LEVEL SET!-GC!-TRAP!-LEVEL DELHEAP GTCONSTSTR GTBPS GTEVECT GTFLTN GTID RECLAIM DELBPS GTWARRAY DELWARRAY COPYSTRINGTOFROM COPYSTRING COPYWARRAY COPYVECTORTOFROM COPYVECTOR COPYWRDSTOFROM COPYWRDS TOTALCOPY MKVECT MKEVECTOR MKEVECT MKSTRING NONPOSITIVEINTEGERERROR MAKE!-BYTES MAKE!-HALFWORDS MAKE!-WORDS MAKE!-VECTOR STRING VECTOR LIST5 GCKNT!* GCTIME!* !*GC HEAP!-WARN!-LEVEL ERRORPRINTF TIMC UNMAP!-SPACE RETURNNIL RETURNFIRSTARG LAND LOR LXOR LSHIFT LSH LNOT FIX FLOAT ONEP DEBUG TR EVLOAD TRST QEDITFNS !*EXPERT !*VERBOSE EDITF EDIT YESP PROMPTSTRING!* FASTBIND TERPRI EDITORREADER!* EDITORPRINTER!* FASTUNBIND READ CL HELP BREAK EHELP PL UP OK DISPLAYHELPFILE EDITOR IGNOREDINBACKTRACE!* INTERPRETERFUNCTIONS!* INTERPBACKTRACE PRINTF BACKTRACE RETURNADDRESSP ADDR2ID VERBOSEBACKTRACE OPTIONS!* WRITECHAR CHANNELWRITEUNKNOWNITEM CODE!-ADDRESS!-TO!-SYMBOL PRIN1 QUIT ERROR NO YES RDS ERROUT!* WRS ERRORSET CURSYM!* !*SEMICOL!* ERRORFORM!* !*CONTINUABLEERROR EMSG!* !*BREAK !*EMSGP MAXBREAKLEVEL!* BREAKLEVEL!* FLATSIZE USAGETYPEERROR NONNUMBERERROR NONWORDS NONIOCHANNELERROR !*BACKTRACE !*INNER!*BACKTRACE THROW !$ERROR!$ ERRSET CATCH CATCHSETUP THROWSIGNAL!* !%UNCATCH CHANNELNOTOPEN CHANNELERROR WRITEONLYCHANNEL READONLYCHANNEL ILLEGALSTANDARDCHANNELCLOSE IOERROR CODEAPPLY CODEEVALAPPLY BINDEVAL LBIND1 COMPILEDCALLINGINTERPRETED BSTACKOVERFLOW RESTOREENVIRONMENT !*LAMBDALINK UNDEFINEDFUNCTION UNBINDN APPLY FUNBOUNDP FCODEP GETFCODEPOINTER GET VALUECELL GETFNTYPE !&!&VALUE!&!& THROWTAG!* CATCH!-ALL UNWIND!-ALL !&!&THROWN!&!& !$UNWIND!-PROTECT!$ !&!&TAG!&!& !%THROW UNWIND!-PROTECT !*CATCH !*THROW RESET CAPTUREENVIRONMENT !%CLEAR!-CATCH!-STACK PROGBODY!* PROGJUMPTABLE!* PROG PBIND1 !$PROG!$ GO RETURN SYSTEM_LIST!* DATE DUMPLISP BINARYOPENREAD DEC20OPEN BINARYOPENWRITE VALUECELLLOCATION !*WRITINGFASLFILE NEWBITTABLEENTRY!* FINDIDNUMBER MAKERELOCHALFWORD EXTRAREGLOCATION FUNCTIONCELLLOCATION FASLIN INTERN PUTENTRY LOADDIRECTORIES!* LOADEXTENSIONS!* !*VERBOSELOAD !*PRINTLOADNAMES LOAD LOAD1 RELOAD EVRELOAD !*USERMODE !*REDEFMSG !*INSIDELOAD !*LOWER PENDINGLOADS!* IMPORTS PP PRETTYPRINT DEFSTRUCT STEP MINI EMODE INVOKE RCREF CREFON COMPILER COMPD FASLOUT BUG EXEC MM TERMINALINPUTHANDLER COMPRESSREADCHAR DEC20WRITECHAR TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR !$EOL!$ CHANNELREADCHAR READCHAR IN!* CHANNELUNREADCHAR UNREADCHAR OPEN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT SYSTEMOPENFILESPECIAL SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!* SPECIAL OUTPUT INPUT CLOSE SYSTEMMARKASCLOSEDCHANNEL SPECIALRDSACTION!* STDIN!* SPECIALWRSACTION!* STDOUT!* CHANNELEJECT EJECT CHANNELLINELENGTH LINELENGTH POSN CHANNELLPOSN LPOSN CHANNELREADCH !*RAISE READCH PRINC CHANNELPRINC CURRENTREADMACROINDICATOR!* CHANNELREADTOKENWITHHOOKS CHANNELREADTOKEN TOKTYPE!* CURRENTSCANTABLE!* CHANNELREAD LISPSCANTABLE!* LISPREADMACRO MAKEINPUTAVAILABLE !*INSIDESTRUCTUREREAD CHANNELREADEOF !$EOF!$ CHANNELREADQUOTEDEXPRESSION CHANNELREADLISTORDOTTEDPAIR CHANNELREADRIGHTPAREN CHANNELREADVECTOR !*COMPRESSING !*EOLINSTRINGOK NEWID MAKESTRINGINTOLISPINTEGER DIGITTONUMBER PACKAGE CURRENTPACKAGE!* GLOBAL RATOM READLINE CHANNELREADLINE OUTPUTBASE!* IDESCAPECHAR!* CHANNELWRITESTRING WRITESTRING CHANNELWRITESYSINTEGER CHANNELWRITEBITSTRAUX WRITESYSINTEGER CHANNELWRITEFIXNUM CHANNELWRITEINTEGER CHANNELWRITESYSFLOAT WRITEFLOAT CHANNELWRITEFLOAT CHANNELPRINTSTRING CHANNELWRITEID CHANNELWRITEUNBOUND CHANNELPRINTID CHANNELPRINTUNBOUND CHANNELWRITECODEPOINTER CHANNELWRITEBLANKOREOL CHANNELWRITEPAIR PRINLEVEL PRINLENGTH RECURSIVECHANNELPRIN2 CHANNELPRINTPAIR RECURSIVECHANNELPRIN1 CHANNELWRITEVECTOR CHANNELPRINTVECTOR CHANNELWRITEEVECTOR OBJECT!-GET!-HANDLER!-QUIETLY CHANNELPRIN CHANNELPRINTEVECTOR CHANNELWRITEWORDS CHANNELWRITEHALFWORDS CHANNELWRITEBYTES PRIN2 FORMATFORPRINTF!* PRIN2L ERRPRIN CHANNELPRINTF EXPLODEENDPOINTER!* EXPLODE EXPLODE2 FLATSIZE2 COMPRESSERROR COMPRESSLIST!* CLEARCOMPRESSCHANNEL COMPRESS IMPLODE CHANNELTYI CHANNELTYO TYI TYO COMMENTOUTCODE COMPILETIME BOTHTIMES LOADTIME STARTUPTIME CONTERROR OTHERWISE DEFAULT CASE RANGE SETF EXPANDSETF SETF!-EXPAND ASSIGN!-OP ONOFF!* MKFLAGVAR SIMPFG ON OFF !#ARG DS DEFCONST EVDEFCONST CONST STRINGGENSYM STRINGGENSYM!* FOREACH COLLECT JOIN CONC IN DO EXIT !$LOOP!$ NEXT WHILE REPEAT FOR GENSYM MK!*SQ SIMP BIN))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 752)) (SETQ STRINGGENSYM!* (QUOTE "L3141")) (PUT (QUOTE TWOARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1341")) (PUT (QUOTE RELOAD) (QUOTE ENTRYPOINT) (QUOTE RELOAD)) (PUT (QUOTE RELOAD) (QUOTE IDNUMBER) (QUOTE 568)) (PUT (QUOTE TWOARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1358")) (PUT (QUOTE COPYITEM1) (QUOTE ENTRYPOINT) (QUOTE "L1302")) (PUT (QUOTE INTLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1488")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NEQ) (QUOTE ENTRYPOINT) (QUOTE NEQ)) (PUT (QUOTE NEQ) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE LIST2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0061")) (PUT (QUOTE LIST2STRING) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE SPECIALRDSACTION!*) (QUOTE IDNUMBER) (QUOTE 615)) (FLAG (QUOTE (SPECIALRDSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L2914")) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE IDNUMBER) (QUOTE 703)) (PUT (QUOTE DEFSTRUCT) (QUOTE ENTRYPOINT) (QUOTE "L2218")) (PUT (QUOTE DEFSTRUCT) (QUOTE IDNUMBER) (QUOTE 578)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE MAKERELOCHALFWORD) (QUOTE IDNUMBER) (QUOTE 556)) (PUT (QUOTE BACKTRACE1) (QUOTE ENTRYPOINT) (QUOTE "L1677")) (PUT (QUOTE DO) (QUOTE IDNUMBER) (QUOTE 741)) (PUT (QUOTE THROWSIGNAL!*) (QUOTE IDNUMBER) (QUOTE 500)) (FLAG (QUOTE (THROWSIGNAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE PRINLEVEL) (QUOTE IDNUMBER) (QUOTE 678)) (FLAG (QUOTE (PRINLEVEL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EJECT) (QUOTE ENTRYPOINT) (QUOTE EJECT)) (PUT (QUOTE EJECT) (QUOTE IDNUMBER) (QUOTE 620)) (PUT (QUOTE LISPREADMACRO) (QUOTE IDNUMBER) (QUOTE 638)) (PUT (QUOTE STRING2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0072")) (PUT (QUOTE STRING2LIST) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE EXIT) (QUOTE ENTRYPOINT) (QUOTE EXIT)) (PUT (QUOTE EXIT) (QUOTE IDNUMBER) (QUOTE 742)) (PUT (QUOTE ONEARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1370")) (PUT (QUOTE STRING2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0042")) (PUT (QUOTE STRING2VECTOR) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1825")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE BACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1672")) (PUT (QUOTE BACKTRACE) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1821")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 507)) (PUT (QUOTE RETURNNIL) (QUOTE ENTRYPOINT) (QUOTE "L1395")) (PUT (QUOTE RETURNNIL) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2564")) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 662)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1103")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE GENSYM) (QUOTE IDNUMBER) (QUOTE 748)) (PUT (QUOTE ONEARGPREDICATEDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1383")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1690")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 604)) (PUT (QUOTE !*EMSGP) (QUOTE IDNUMBER) (QUOTE 485)) (PUT (QUOTE !*EMSGP) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE TYI) (QUOTE ENTRYPOINT) (QUOTE TYI)) (PUT (QUOTE TYI) (QUOTE IDNUMBER) (QUOTE 708)) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 519)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L1706")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 745)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE SECOND) (QUOTE ENTRYPOINT) (QUOTE SECOND)) (PUT (QUOTE SECOND) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 694)) (PUT (QUOTE CURSYM!*) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE CHANNELTYI) (QUOTE ENTRYPOINT) (QUOTE "L2920")) (PUT (QUOTE CHANNELTYI) (QUOTE IDNUMBER) (QUOTE 706)) (PUT (QUOTE FLOATREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1444")) (PUT (QUOTE SASSOC) (QUOTE ENTRYPOINT) (QUOTE SASSOC)) (PUT (QUOTE SASSOC) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE OLDHEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE OLDHEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1087")) (PUT (QUOTE OLDHEAPTRAPBOUND) (QUOTE WVAR) (QUOTE OLDHEAPTRAPBOUND)) (PUT (QUOTE ADDR2ID) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE ROBUSTEXPAND) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE ROBUSTEXPAND) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE INTREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1443")) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 8209)) (PUT (QUOTE TWOARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1342")) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE CURRENTPACKAGE!*) (QUOTE IDNUMBER) (QUOTE 653)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE ENTRYPOINT) (QUOTE "L2022")) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 538)) (PUT (QUOTE SETSUBSEQ) (QUOTE ENTRYPOINT) (QUOTE "L0262")) (PUT (QUOTE SETSUBSEQ) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE PNTH) (QUOTE ENTRYPOINT) (QUOTE PNTH)) (PUT (QUOTE PNTH) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE PACKAGE) (QUOTE ENTRYPOINT) (QUOTE "L2551")) (PUT (QUOTE PACKAGE) (QUOTE IDNUMBER) (QUOTE 652)) (PUT (QUOTE MAKEDS) (QUOTE ENTRYPOINT) (QUOTE MAKEDS)) (PUT (QUOTE !*USERMODE) (QUOTE IDNUMBER) (QUOTE 570)) (FLAG (QUOTE (!*USERMODE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*REDEFMSG) (QUOTE IDNUMBER) (QUOTE 571)) (FLAG (QUOTE (!*REDEFMSG)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SAVE!-INTO!-FILE) (QUOTE ENTRYPOINT) (QUOTE "L2087")) (PUT (QUOTE CHANNELPRINTID) (QUOTE ENTRYPOINT) (QUOTE "L2601")) (PUT (QUOTE CHANNELPRINTID) (QUOTE IDNUMBER) (QUOTE 673)) (PUT (QUOTE BUG) (QUOTE ENTRYPOINT) (QUOTE BUG)) (PUT (QUOTE BUG) (QUOTE IDNUMBER) (QUOTE 588)) (PUT (QUOTE LPOSN) (QUOTE ENTRYPOINT) (QUOTE LPOSN)) (PUT (QUOTE LPOSN) (QUOTE IDNUMBER) (QUOTE 625)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE INITIALVALUE) (QUOTE (EVAL APPLY FASTAPPLY CODEAPPLY CODEEVALAPPLY CATCH ERRORSET EVPROGN TOPLOOP BREAKEVAL BINDEVAL BREAK MAIN))) (PUT (QUOTE DEFAULT) (QUOTE IDNUMBER) (QUOTE 717)) (PUT (QUOTE DOPNTH) (QUOTE ENTRYPOINT) (QUOTE DOPNTH)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE STRINGGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3053")) (PUT (QUOTE STRINGGENSYM) (QUOTE IDNUMBER) (QUOTE 734)) (PUT (QUOTE FLOATSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1504")) (PUT (QUOTE TAB) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE TAB) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1152")) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE MEMBER) (QUOTE ENTRYPOINT) (QUOTE MEMBER)) (PUT (QUOTE MEMBER) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE EXPRP) (QUOTE ENTRYPOINT) (QUOTE EXPRP)) (PUT (QUOTE EXPRP) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LNOT) (QUOTE ENTRYPOINT) (QUOTE LNOT)) (PUT (QUOTE LNOT) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE ONEARGPREDICATEDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1382")) (PUT (QUOTE ACONC) (QUOTE ENTRYPOINT) (QUOTE ACONC)) (PUT (QUOTE ACONC) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE PRETTYPRINT) (QUOTE ENTRYPOINT) (QUOTE "L2211")) (PUT (QUOTE PRETTYPRINT) (QUOTE IDNUMBER) (QUOTE 577)) (PUT (QUOTE !$PROG!$) (QUOTE IDNUMBER) (QUOTE 543)) (PUT (QUOTE ERRSET) (QUOTE ENTRYPOINT) (QUOTE ERRSET)) (PUT (QUOTE ERRSET) (QUOTE IDNUMBER) (QUOTE 497)) (PUT (QUOTE DIVIDE) (QUOTE ENTRYPOINT) (QUOTE DIVIDE)) (PUT (QUOTE DIVIDE) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE DELETE) (QUOTE ENTRYPOINT) (QUOTE DELETE)) (PUT (QUOTE DELETE) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE NONINTEGER2ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1364")) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0372")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 612)) (PUT (QUOTE PRINLENGTH) (QUOTE IDNUMBER) (QUOTE 679)) (FLAG (QUOTE (PRINLENGTH)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE XNQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE XNQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE TYO) (QUOTE ENTRYPOINT) (QUOTE TYO)) (PUT (QUOTE TYO) (QUOTE IDNUMBER) (QUOTE 709)) (PUT (QUOTE !*THROW) (QUOTE ENTRYPOINT) (QUOTE "L2010")) (PUT (QUOTE !*THROW) (QUOTE IDNUMBER) (QUOTE 535)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0676")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE ERRORFORM!*) (QUOTE IDNUMBER) (QUOTE 481)) (FLAG (QUOTE (ERRORFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*INSIDELOAD) (QUOTE IDNUMBER) (QUOTE 572)) (FLAG (QUOTE (!*INSIDELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1540")) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 511)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE MAP) (QUOTE ENTRYPOINT) (QUOTE MAP)) (PUT (QUOTE MAP) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE FOURTH) (QUOTE ENTRYPOINT) (QUOTE FOURTH)) (PUT (QUOTE FOURTH) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE LXOR) (QUOTE ENTRYPOINT) (QUOTE LXOR)) (PUT (QUOTE LXOR) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE COMPD) (QUOTE ENTRYPOINT) (QUOTE COMPD)) (PUT (QUOTE COMPD) (QUOTE IDNUMBER) (QUOTE 586)) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2701")) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE IDNUMBER) (QUOTE 684)) (PUT (QUOTE BOTHTIMES) (QUOTE ENTRYPOINT) (QUOTE "L2924")) (PUT (QUOTE BOTHTIMES) (QUOTE IDNUMBER) (QUOTE 712)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2253")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 521)) (PUT (QUOTE VALUECELL) (QUOTE IDNUMBER) (QUOTE 523)) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2662")) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE IDNUMBER) (QUOTE 681)) (PUT (QUOTE WRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2574")) (PUT (QUOTE WRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 664)) (PUT (QUOTE BACKTRACERANGE) (QUOTE ENTRYPOINT) (QUOTE "L1669")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L1089")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE DIGIT) (QUOTE ENTRYPOINT) (QUOTE DIGIT)) (PUT (QUOTE DIGIT) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE FASLIN) (QUOTE ENTRYPOINT) (QUOTE FASLIN)) (PUT (QUOTE FASLIN) (QUOTE IDNUMBER) (QUOTE 559)) (PUT (QUOTE LIST2SETQ) (QUOTE ENTRYPOINT) (QUOTE "L1050")) (PUT (QUOTE LIST2SETQ) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2576")) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE IDNUMBER) (QUOTE 666)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE PUTC) (QUOTE ENTRYPOINT) (QUOTE PUTC)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE DELASC) (QUOTE ENTRYPOINT) (QUOTE DELASC)) (PUT (QUOTE DELASC) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE FOREACH) (QUOTE ENTRYPOINT) (QUOTE "L3073")) (PUT (QUOTE FOREACH) (QUOTE IDNUMBER) (QUOTE 736)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L1855")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 512)) (PUT (QUOTE MM) (QUOTE ENTRYPOINT) (QUOTE MM)) (PUT (QUOTE MM) (QUOTE IDNUMBER) (QUOTE 590)) (PUT (QUOTE FLOATINTARG) (QUOTE ENTRYPOINT) (QUOTE "L1538")) (PUT (QUOTE MKEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1198")) (PUT (QUOTE MKEVECTOR) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE MAKEBUFINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2393")) (PUT (QUOTE DELASCIP) (QUOTE ENTRYPOINT) (QUOTE "L0947")) (PUT (QUOTE DELASCIP) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE ZEROP) (QUOTE ENTRYPOINT) (QUOTE ZEROP)) (PUT (QUOTE ZEROP) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE FLOATGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1484")) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2368")) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE IDNUMBER) (QUOTE 646)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE DELASCIP1) (QUOTE ENTRYPOINT) (QUOTE "L0940")) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 600)) (FLAG (QUOTE (IN!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INTLSHIFT) (QUOTE ENTRYPOINT) (QUOTE "L1475")) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE MAPC2) (QUOTE ENTRYPOINT) (QUOTE MAPC2)) (PUT (QUOTE MAPC2) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE EDITORPRINTER!*) (QUOTE IDNUMBER) (QUOTE 446)) (FLAG (QUOTE (EDITORPRINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1081")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE ENTRYPOINT) (QUOTE "L2778")) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE IDNUMBER) (QUOTE 691)) (PUT (QUOTE EXPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2903")) (PUT (QUOTE EXPLODE) (QUOTE IDNUMBER) (QUOTE 698)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SPECIAL) (QUOTE IDNUMBER) (QUOTE 610)) (PUT (QUOTE RCREF) (QUOTE IDNUMBER) (QUOTE 583)) (PUT (QUOTE EVRELOAD) (QUOTE ENTRYPOINT) (QUOTE "L2172")) (PUT (QUOTE EVRELOAD) (QUOTE IDNUMBER) (QUOTE 569)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE INITIALVALUE) (QUOTE (COND PROG AND OR PROGN SETQ))) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 634)) (FLAG (QUOTE (TOKTYPE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1273")) (PUT (QUOTE INTSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1503")) (PUT (QUOTE MIN) (QUOTE ENTRYPOINT) (QUOTE MIN)) (PUT (QUOTE MIN) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2714")) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE IDNUMBER) (QUOTE 685)) (PUT (QUOTE CHANNELPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2330")) (PUT (QUOTE CHANNELPOSN) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1829")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 508)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE COPYFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1287")) (PUT (QUOTE REMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1442")) (PUT (QUOTE REMAINDER) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE !*VERBOSELOAD) (QUOTE IDNUMBER) (QUOTE 564)) (FLAG (QUOTE (!*VERBOSELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1127")) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE ID2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0035")) (PUT (QUOTE ID2STRING) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L2893")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 695)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L1080")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1110")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2884")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE !*VERBOSE) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*VERBOSE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EUPBV) (QUOTE ENTRYPOINT) (QUOTE EUPBV)) (PUT (QUOTE EUPBV) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1082")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE NEWBITTABLEENTRY!*) (QUOTE IDNUMBER) (QUOTE 554)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2558")) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 660)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0597")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE GETV) (QUOTE ENTRYPOINT) (QUOTE GETV)) (PUT (QUOTE GETV) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE !*INSIDESTRUCTUREREAD) (QUOTE IDNUMBER) (QUOTE 640)) (FLAG (QUOTE (!*INSIDESTRUCTUREREAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1489")) (PUT (QUOTE CL) (QUOTE IDNUMBER) (QUOTE 449)) (FLAG (QUOTE (CL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MACROP) (QUOTE ENTRYPOINT) (QUOTE MACROP)) (PUT (QUOTE MACROP) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE CONTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2932")) (PUT (QUOTE CONTERROR) (QUOTE IDNUMBER) (QUOTE 715)) (PUT (QUOTE FLOATONEP) (QUOTE ENTRYPOINT) (QUOTE "L1549")) (PUT (QUOTE ONEP) (QUOTE ENTRYPOINT) (QUOTE ONEP)) (PUT (QUOTE ONEP) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE LOAD) (QUOTE ENTRYPOINT) (QUOTE LOAD)) (PUT (QUOTE LOAD) (QUOTE IDNUMBER) (QUOTE 566)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE VECTOR) (QUOTE ENTRYPOINT) (QUOTE VECTOR)) (PUT (QUOTE VECTOR) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE GTHEAP1) (QUOTE ENTRYPOINT) (QUOTE "L1091")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1098")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1836")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 509)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE IDNUMBER) (QUOTE 562)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE INITIALVALUE) (QUOTE ("" "pl:"))) (PUT (QUOTE WRITENUMBER1) (QUOTE ENTRYPOINT) (QUOTE "L2568")) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE THIRD) (QUOTE ENTRYPOINT) (QUOTE THIRD)) (PUT (QUOTE THIRD) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE SETF) (QUOTE ENTRYPOINT) (QUOTE SETF)) (PUT (QUOTE SETF) (QUOTE IDNUMBER) (QUOTE 720)) (PUT (QUOTE QEDNTH) (QUOTE ENTRYPOINT) (QUOTE QEDNTH)) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2106")) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE IDNUMBER) (QUOTE 557)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 692)) (PUT (QUOTE LASTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L0990")) (PUT (QUOTE LASTPAIR) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE ERRORSET) (QUOTE ENTRYPOINT) (QUOTE "L1805")) (PUT (QUOTE ERRORSET) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE COMPILER) (QUOTE IDNUMBER) (QUOTE 585)) (PUT (QUOTE VECTOR2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0090")) (PUT (QUOTE VECTOR2LIST) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PUTV) (QUOTE ENTRYPOINT) (QUOTE PUTV)) (PUT (QUOTE PUTV) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE YESP) (QUOTE ENTRYPOINT) (QUOTE YESP)) (PUT (QUOTE YESP) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE NCONC) (QUOTE ENTRYPOINT) (QUOTE NCONC)) (PUT (QUOTE NCONC) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RETURNADDRESSP) (QUOTE ENTRYPOINT) (QUOTE "L2072")) (PUT (QUOTE RETURNADDRESSP) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L1105")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE HELP) (QUOTE ENTRYPOINT) (QUOTE HELP)) (PUT (QUOTE HELP) (QUOTE IDNUMBER) (QUOTE 450)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE IDNUMBER) (QUOTE 658)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE INITIALVALUE) (QUOTE 10)) (PUT (QUOTE LOADTIME) (QUOTE ENTRYPOINT) (QUOTE "L2925")) (PUT (QUOTE LOADTIME) (QUOTE IDNUMBER) (QUOTE 713)) (PUT (QUOTE ID2INT) (QUOTE ENTRYPOINT) (QUOTE ID2INT)) (PUT (QUOTE ID2INT) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE ENTRYPOINT) (QUOTE "L2426")) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE IDNUMBER) (QUOTE 633)) (PUT (QUOTE THROWAUX) (QUOTE ENTRYPOINT) (QUOTE "L2026")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1086")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE !%THROW) (QUOTE ENTRYPOINT) (QUOTE !%THROW)) (PUT (QUOTE !%THROW) (QUOTE IDNUMBER) (QUOTE 532)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0030")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 655)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 627)) (PUT (QUOTE !*RAISE) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE NEXPRP) (QUOTE ENTRYPOINT) (QUOTE NEXPRP)) (PUT (QUOTE NEXPRP) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE MKFLAGVAR) (QUOTE ENTRYPOINT) (QUOTE "L2988")) (PUT (QUOTE MKFLAGVAR) (QUOTE IDNUMBER) (QUOTE 725)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 442)) (FLAG (QUOTE (PROMPTSTRING!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE STRINGEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0469")) (PUT (QUOTE STRINGEQUAL) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NE) (QUOTE ENTRYPOINT) (QUOTE NE)) (PUT (QUOTE NE) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2891")) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 594)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 613)) (PUT (QUOTE FINDIDNUMBER) (QUOTE IDNUMBER) (QUOTE 555)) (PUT (QUOTE TIMES) (QUOTE ENTRYPOINT) (QUOTE TIMES)) (PUT (QUOTE TIMES) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE ENTRYPOINT) (QUOTE "L2361")) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE IDNUMBER) (QUOTE 645)) (PUT (QUOTE FLOATMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1521")) (PUT (QUOTE EXEC) (QUOTE ENTRYPOINT) (QUOTE EXEC)) (PUT (QUOTE EXEC) (QUOTE IDNUMBER) (QUOTE 589)) (PUT (QUOTE DELQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0903")) (PUT (QUOTE EMODE) (QUOTE ENTRYPOINT) (QUOTE EMODE)) (PUT (QUOTE EMODE) (QUOTE IDNUMBER) (QUOTE 581)) (PUT (QUOTE READLINE) (QUOTE ENTRYPOINT) (QUOTE "L2544")) (PUT (QUOTE READLINE) (QUOTE IDNUMBER) (QUOTE 656)) (PUT (QUOTE INTMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1106")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2683")) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE IDNUMBER) (QUOTE 683)) (PUT (QUOTE EVECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0127")) (PUT (QUOTE EVECTORP) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 597)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE OBJECT!-GET!-HANDLER!-QUIETLY) (QUOTE IDNUMBER) (QUOTE 686)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2638")) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE IDNUMBER) (QUOTE 677)) (PUT (QUOTE !*LOWER) (QUOTE IDNUMBER) (QUOTE 573)) (FLAG (QUOTE (!*LOWER)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DUMPLISP) (QUOTE ENTRYPOINT) (QUOTE "L2085")) (PUT (QUOTE DUMPLISP) (QUOTE IDNUMBER) (QUOTE 548)) (PUT (QUOTE EVAND) (QUOTE ENTRYPOINT) (QUOTE EVAND)) (PUT (QUOTE EVAND) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE ASSIGN!-OP) (QUOTE IDNUMBER) (QUOTE 723)) (PUT (QUOTE PLUS) (QUOTE ENTRYPOINT) (QUOTE PLUS)) (PUT (QUOTE PLUS) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE !$UNWIND!-PROTECT!$) (QUOTE IDNUMBER) (QUOTE 530)) (PUT (QUOTE COMPRESS) (QUOTE ENTRYPOINT) (QUOTE "L2918")) (PUT (QUOTE COMPRESS) (QUOTE IDNUMBER) (QUOTE 704)) (PUT (QUOTE MAPCON) (QUOTE ENTRYPOINT) (QUOTE MAPCON)) (PUT (QUOTE MAPCON) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE MAPCAR) (QUOTE ENTRYPOINT) (QUOTE MAPCAR)) (PUT (QUOTE MAPCAR) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1711")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE SUBLIS) (QUOTE ENTRYPOINT) (QUOTE SUBLIS)) (PUT (QUOTE SUBLIS) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE MAKEBUFINTOID) (QUOTE ENTRYPOINT) (QUOTE "L2387")) (PUT (QUOTE PROG) (QUOTE ENTRYPOINT) (QUOTE PROG)) (PUT (QUOTE PROG) (QUOTE IDNUMBER) (QUOTE 541)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE IDNUMBER) (QUOTE 631)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE INITIALVALUE) (QUOTE LISPREADMACRO)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE CHANNELWRITEID) (QUOTE ENTRYPOINT) (QUOTE "L2590")) (PUT (QUOTE CHANNELWRITEID) (QUOTE IDNUMBER) (QUOTE 671)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE ASMSYMBOL) (QUOTE "L2260")) (PUT (QUOTE JFNOFCHANNEL) (QUOTE WARRAY) (QUOTE JFNOFCHANNEL)) (PUT (QUOTE CHANNELLPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2331")) (PUT (QUOTE CHANNELLPOSN) (QUOTE IDNUMBER) (QUOTE 624)) (PUT (QUOTE STRINGGENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3054")) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE FLOAT) (QUOTE ENTRYPOINT) (QUOTE FLOAT)) (PUT (QUOTE FLOAT) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 8000)) (PUT (QUOTE FLOATZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1440")) (PUT (QUOTE INDX) (QUOTE ENTRYPOINT) (QUOTE INDX)) (PUT (QUOTE INDX) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 515)) (PUT (QUOTE INTZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1544")) (PUT (QUOTE FLOATADD1) (QUOTE ENTRYPOINT) (QUOTE "L1494")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1772")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L2575")) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE IDNUMBER) (QUOTE 665)) (PUT (QUOTE EPUTV) (QUOTE ENTRYPOINT) (QUOTE EPUTV)) (PUT (QUOTE EPUTV) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 637)) (FLAG (QUOTE (LISPSCANTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2281")) (PUT (QUOTE UNREADCHAR) (QUOTE IDNUMBER) (QUOTE 602)) (PUT (QUOTE MAKE!-WORDS) (QUOTE ENTRYPOINT) (QUOTE "L1238")) (PUT (QUOTE MAKE!-WORDS) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2108")) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE IDNUMBER) (QUOTE 558)) (PUT (QUOTE SIMPFG) (QUOTE IDNUMBER) (QUOTE 726)) (PUT (QUOTE SPECIALREADFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 607)) (FLAG (QUOTE (SPECIALREADFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CHANNELPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2901")) (PUT (QUOTE CHANNELPRINTF) (QUOTE IDNUMBER) (QUOTE 696)) (PUT (QUOTE OR) (QUOTE ENTRYPOINT) (QUOTE OR)) (PUT (QUOTE OR) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE MKQUOTE) (QUOTE ENTRYPOINT) (QUOTE "L0861")) (PUT (QUOTE MKQUOTE) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE !*PRINTLOADNAMES) (QUOTE IDNUMBER) (QUOTE 565)) (FLAG (QUOTE (!*PRINTLOADNAMES)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 472)) (PUT (QUOTE EDITORREADER!*) (QUOTE IDNUMBER) (QUOTE 445)) (FLAG (QUOTE (EDITORREADER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETF!-EXPAND) (QUOTE IDNUMBER) (QUOTE 722)) (PUT (QUOTE SETSUB) (QUOTE ENTRYPOINT) (QUOTE SETSUB)) (PUT (QUOTE SETSUB) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE SIZE) (QUOTE ENTRYPOINT) (QUOTE SIZE)) (PUT (QUOTE SIZE) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 536)) (PUT (QUOTE CHANNELREAD) (QUOTE ENTRYPOINT) (QUOTE "L2339")) (PUT (QUOTE CHANNELREAD) (QUOTE IDNUMBER) (QUOTE 636)) (PUT (QUOTE !&!&VALUE!&!&) (QUOTE IDNUMBER) (QUOTE 525)) (PUT (QUOTE CHANNELSPACES) (QUOTE ENTRYPOINT) (QUOTE "L1036")) (PUT (QUOTE CHANNELSPACES) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE PRINTF2) (QUOTE ENTRYPOINT) (QUOTE "L2853")) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L1844")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 510)) (PUT (QUOTE LISPEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0429")) (PUT (QUOTE LISPEQUAL) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE UNION) (QUOTE ENTRYPOINT) (QUOTE UNION)) (PUT (QUOTE UNION) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE DELQIP) (QUOTE ENTRYPOINT) (QUOTE DELQIP)) (PUT (QUOTE DELQIP) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE CHANNELTAB) (QUOTE ENTRYPOINT) (QUOTE "L1040")) (PUT (QUOTE CHANNELTAB) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE BIGFLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1394")) (PUT (QUOTE INTLNOT) (QUOTE ENTRYPOINT) (QUOTE "L1513")) (PUT (QUOTE MAX) (QUOTE ENTRYPOINT) (QUOTE MAX)) (PUT (QUOTE MAX) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE INSTANTIATEINFORM) (QUOTE ENTRYPOINT) (QUOTE "L2994")) (PUT (QUOTE COPYWRDS) (QUOTE ENTRYPOINT) (QUOTE "L1158")) (PUT (QUOTE COPYWRDS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L1177")) (PUT (QUOTE CHANNELPRINT) (QUOTE ENTRYPOINT) (QUOTE "L0812")) (PUT (QUOTE CHANNELPRINT) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE IDNUMBER) (QUOTE 563)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE INITIALVALUE) (QUOTE ((".b" . FASLIN) ( ".lap" . LAPIN)))) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE FEXPRP) (QUOTE ENTRYPOINT) (QUOTE FEXPRP)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2335")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE THROW) (QUOTE ENTRYPOINT) (QUOTE THROW)) (PUT (QUOTE THROW) (QUOTE IDNUMBER) (QUOTE 495)) (PUT (QUOTE FIX) (QUOTE ENTRYPOINT) (QUOTE FIX)) (PUT (QUOTE FIX) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0375")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE INITIALVALUE) (QUOTE 1000)) (PUT (QUOTE TCONC) (QUOTE ENTRYPOINT) (QUOTE TCONC)) (PUT (QUOTE TCONC) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1122")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE EGETV) (QUOTE ENTRYPOINT) (QUOTE EGETV)) (PUT (QUOTE EGETV) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE CONST) (QUOTE ENTRYPOINT) (QUOTE CONST)) (PUT (QUOTE CONST) (QUOTE IDNUMBER) (QUOTE 733)) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L1869")) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE IDNUMBER) (QUOTE 516)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE DS) (QUOTE ENTRYPOINT) (QUOTE DS)) (PUT (QUOTE DS) (QUOTE IDNUMBER) (QUOTE 730)) (PUT (QUOTE OLDHEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE OLDHEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L1083")) (PUT (QUOTE OLDHEAPLAST) (QUOTE WVAR) (QUOTE OLDHEAPLAST)) (PUT (QUOTE WORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0426")) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1818")) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 506)) (PUT (QUOTE COMPRESSLIST!*) (QUOTE IDNUMBER) (QUOTE 702)) (FLAG (QUOTE (COMPRESSLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1142")) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2902")) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 595)) (PUT (QUOTE SPECIALWRSACTION!*) (QUOTE IDNUMBER) (QUOTE 617)) (FLAG (QUOTE (SPECIALWRSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODE!-ADDRESS!-TO!-SYMBOL) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE MAPLIST) (QUOTE ENTRYPOINT) (QUOTE "L0737")) (PUT (QUOTE MAPLIST) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1746")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE !*EXPERT) (QUOTE IDNUMBER) (QUOTE 437)) (FLAG (QUOTE (!*EXPERT)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CONC) (QUOTE IDNUMBER) (QUOTE 739)) (PUT (QUOTE CHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2814")) (PUT (QUOTE CHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE PRINTF1) (QUOTE ENTRYPOINT) (QUOTE "L2852")) (PUT (QUOTE ABS) (QUOTE ENTRYPOINT) (QUOTE ABS)) (PUT (QUOTE ABS) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1781")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 491)) (PUT (QUOTE OTHERWISE) (QUOTE IDNUMBER) (QUOTE 716)) (PUT (QUOTE FASLOUT) (QUOTE ENTRYPOINT) (QUOTE "L2243")) (PUT (QUOTE FASLOUT) (QUOTE IDNUMBER) (QUOTE 587)) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2760")) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE IDNUMBER) (QUOTE 690)) (PUT (QUOTE SUBSEQ) (QUOTE ENTRYPOINT) (QUOTE SUBSEQ)) (PUT (QUOTE SUBSEQ) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE LSHIFT) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSHIFT) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L1754")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE XCHANGE) (QUOTE ENTRYPOINT) (QUOTE "L1610")) (PUT (QUOTE COMPRESSERROR) (QUOTE ENTRYPOINT) (QUOTE "L2917")) (PUT (QUOTE COMPRESSERROR) (QUOTE IDNUMBER) (QUOTE 701)) (PUT (QUOTE READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2268")) (PUT (QUOTE READCHAR) (QUOTE IDNUMBER) (QUOTE 599)) (PUT (QUOTE FLOATDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1409")) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 635)) (FLAG (QUOTE (CURRENTSCANTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE CHANNELREADCH) (QUOTE ENTRYPOINT) (QUOTE "L2332")) (PUT (QUOTE CHANNELREADCH) (QUOTE IDNUMBER) (QUOTE 626)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE COPYVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1148")) (PUT (QUOTE COPYVECTOR) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 642)) (FLAG (QUOTE (!$EOF!$)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DELQ) (QUOTE ENTRYPOINT) (QUOTE DELQ)) (PUT (QUOTE DELQ) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1766")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1256")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE CREFON) (QUOTE ENTRYPOINT) (QUOTE CREFON)) (PUT (QUOTE CREFON) (QUOTE IDNUMBER) (QUOTE 584)) (PUT (QUOTE FOR) (QUOTE ENTRYPOINT) (QUOTE FOR)) (PUT (QUOTE FOR) (QUOTE IDNUMBER) (QUOTE 747)) (PUT (QUOTE BIN) (QUOTE IDNUMBER) (QUOTE 751)) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE ENTRYPOINT) (QUOTE "L2336")) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE IDNUMBER) (QUOTE 632)) (PUT (QUOTE INT2CODE) (QUOTE ENTRYPOINT) (QUOTE "L0026")) (PUT (QUOTE INT2CODE) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE BREAK) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1865")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 614)) (PUT (QUOTE INTADD1) (QUOTE ENTRYPOINT) (QUOTE "L1493")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2272")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 470)) (PUT (QUOTE IN) (QUOTE IDNUMBER) (QUOTE 740)) (PUT (QUOTE HEAPTRAPPED) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPPED) (QUOTE ASMSYMBOL) (QUOTE "L1088")) (PUT (QUOTE HEAPTRAPPED) (QUOTE WVAR) (QUOTE HEAPTRAPPED)) (PUT (QUOTE !*EOLINSTRINGOK) (QUOTE IDNUMBER) (QUOTE 648)) (FLAG (QUOTE (!*EOLINSTRINGOK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE MIN2) (QUOTE ENTRYPOINT) (QUOTE MIN2)) (PUT (QUOTE MIN2) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE ASS) (QUOTE ENTRYPOINT) (QUOTE ASS)) (PUT (QUOTE ASS) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2280")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE IDNUMBER) (QUOTE 601)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE ENTRYPOINT) (QUOTE "L2620")) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE EVDEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3048")) (PUT (QUOTE EVDEFCONST) (QUOTE IDNUMBER) (QUOTE 732)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE CASE) (QUOTE ENTRYPOINT) (QUOTE CASE)) (PUT (QUOTE CASE) (QUOTE IDNUMBER) (QUOTE 718)) (PUT (QUOTE SCANNERERROR) (QUOTE ENTRYPOINT) (QUOTE "L2455")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE ENTRYPOINT) (QUOTE "L1396")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE COPYITEM) (QUOTE ENTRYPOINT) (QUOTE "L1290")) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0407")) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1228")) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE STRINGGENSYM!*) (QUOTE IDNUMBER) (QUOTE 735)) (FLAG (QUOTE (STRINGGENSYM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNMAP!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L2088")) (PUT (QUOTE UNMAP!-SPACE) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE !*CATCH) (QUOTE ENTRYPOINT) (QUOTE "L2009")) (PUT (QUOTE !*CATCH) (QUOTE IDNUMBER) (QUOTE 534)) (PUT (QUOTE MINUSP) (QUOTE ENTRYPOINT) (QUOTE MINUSP)) (PUT (QUOTE MINUSP) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE BPSSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPSSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BPSSIZE) (QUOTE WCONST) (QUOTE 170000)) (PUT (QUOTE IMPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2919")) (PUT (QUOTE IMPLODE) (QUOTE IDNUMBER) (QUOTE 705)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1769")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE FASTBIND) (QUOTE IDNUMBER) (QUOTE 443)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1892")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2579")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 669)) (PUT (QUOTE CHECKLINEFIT) (QUOTE ENTRYPOINT) (QUOTE "L2553")) (PUT (QUOTE !%UNCATCH) (QUOTE ENTRYPOINT) (QUOTE "L2021")) (PUT (QUOTE !%UNCATCH) (QUOTE IDNUMBER) (QUOTE 501)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L1778")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE WCONST) (QUOTE 8)) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2613")) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE IDNUMBER) (QUOTE 674)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1482")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE MAPC) (QUOTE ENTRYPOINT) (QUOTE MAPC)) (PUT (QUOTE MAPC) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1812")) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 504)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE IDNUMBER) (QUOTE 546)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE INITIALVALUE) (QUOTE (DEC20 PDP10 TOPS20 KL10))) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE MAKESTRINGINTOBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2518")) (PUT (QUOTE UPBV) (QUOTE ENTRYPOINT) (QUOTE UPBV)) (PUT (QUOTE UPBV) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE LCONC) (QUOTE ENTRYPOINT) (QUOTE LCONC)) (PUT (QUOTE LCONC) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE EDCOPY) (QUOTE ENTRYPOINT) (QUOTE EDCOPY)) (PUT (QUOTE FLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1530")) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1749")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 489)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 542)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE DEL) (QUOTE ENTRYPOINT) (QUOTE DEL)) (PUT (QUOTE DEL) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE MAKE!-BYTES) (QUOTE ENTRYPOINT) (QUOTE "L1218")) (PUT (QUOTE MAKE!-BYTES) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE FIRST) (QUOTE ENTRYPOINT) (QUOTE FIRST)) (PUT (QUOTE FIRST) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE DATE) (QUOTE ENTRYPOINT) (QUOTE DATE)) (PUT (QUOTE DATE) (QUOTE IDNUMBER) (QUOTE 547)) (PUT (QUOTE DOTCONTEXTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2351")) (PUT (QUOTE SYSPOWEROF2P) (QUOTE ENTRYPOINT) (QUOTE "L2516")) (PUT (QUOTE LOAD1) (QUOTE ENTRYPOINT) (QUOTE LOAD1)) (PUT (QUOTE LOAD1) (QUOTE IDNUMBER) (QUOTE 567)) (PUT (QUOTE LISP2CHAR) (QUOTE ENTRYPOINT) (QUOTE "L0022")) (PUT (QUOTE LISP2CHAR) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE MEM) (QUOTE ENTRYPOINT) (QUOTE MEM)) (PUT (QUOTE MEM) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE EHELP) (QUOTE ENTRYPOINT) (QUOTE EHELP)) (PUT (QUOTE EHELP) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE EDIT0) (QUOTE ENTRYPOINT) (QUOTE EDIT0)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE MAKEBUFINTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2390")) (PUT (QUOTE INTMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1539")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 606)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1775")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE INTERPBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1668")) (PUT (QUOTE INTERPBACKTRACE) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE !$ERROR!$) (QUOTE IDNUMBER) (QUOTE 496)) (PUT (QUOTE INTGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1483")) (PUT (QUOTE UNMAP!-PAGES) (QUOTE ENTRYPOINT) (QUOTE "L2090")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2326")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE IDNUMBER) (QUOTE 621)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE SCANPOSSIBLEDIPHTHONG) (QUOTE ENTRYPOINT) (QUOTE "L2449")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 591)) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE ENTRYPOINT) (QUOTE "L2345")) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE IDNUMBER) (QUOTE 643)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 311)) (FLAG (QUOTE (OUT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EXPANDSETF) (QUOTE ENTRYPOINT) (QUOTE "L2968")) (PUT (QUOTE EXPANDSETF) (QUOTE IDNUMBER) (QUOTE 721)) (PUT (QUOTE GO) (QUOTE ENTRYPOINT) (QUOTE GO)) (PUT (QUOTE GO) (QUOTE IDNUMBER) (QUOTE 544)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 618)) (FLAG (QUOTE (STDOUT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE REST) (QUOTE ENTRYPOINT) (QUOTE REST)) (PUT (QUOTE REST) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE SIMP) (QUOTE IDNUMBER) (QUOTE 750)) (PUT (QUOTE INVOKE) (QUOTE ENTRYPOINT) (QUOTE INVOKE)) (PUT (QUOTE INVOKE) (QUOTE IDNUMBER) (QUOTE 582)) (PUT (QUOTE !*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 493)) (FLAG (QUOTE (!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !&!&TAG!&!&) (QUOTE IDNUMBER) (QUOTE 531)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE TR) (QUOTE ENTRYPOINT) (QUOTE TR)) (PUT (QUOTE TR) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE UP) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE EMSG!*) (QUOTE IDNUMBER) (QUOTE 483)) (FLAG (QUOTE (EMSG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKE!-VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1248")) (PUT (QUOTE MAKE!-VECTOR) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE FLATSIZE) (QUOTE ENTRYPOINT) (QUOTE "L2907")) (PUT (QUOTE FLATSIZE) (QUOTE IDNUMBER) (QUOTE 488)) (PUT (QUOTE PROGBODY!*) (QUOTE IDNUMBER) (QUOTE 539)) (FLAG (QUOTE (PROGBODY!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SPECIALWRITEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 608)) (FLAG (QUOTE (SPECIALWRITEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE READINBUF) (QUOTE ENTRYPOINT) (QUOTE "L2384")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE ENTRYPOINT) (QUOTE "L2006")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE IDNUMBER) (QUOTE 533)) (PUT (QUOTE SUBSTIP1) (QUOTE ENTRYPOINT) (QUOTE "L0873")) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0602")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE INTLXOR) (QUOTE ENTRYPOINT) (QUOTE "L1468")) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE UNIONQ) (QUOTE ENTRYPOINT) (QUOTE UNIONQ)) (PUT (QUOTE UNIONQ) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE MAKESTRINGINTOSYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2392")) (PUT (QUOTE NTH) (QUOTE ENTRYPOINT) (QUOTE NTH)) (PUT (QUOTE NTH) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE PL) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE JOIN) (QUOTE IDNUMBER) (QUOTE 738)) (PUT (QUOTE SUBSTIP) (QUOTE ENTRYPOINT) (QUOTE "L0878")) (PUT (QUOTE SUBSTIP) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE SPECIALCLOSEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 609)) (FLAG (QUOTE (SPECIALCLOSEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE STARTUPTIME) (QUOTE ENTRYPOINT) (QUOTE "L2925")) (PUT (QUOTE STARTUPTIME) (QUOTE IDNUMBER) (QUOTE 714)) (PUT (QUOTE INTERSECTIONQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE INTERSECTIONQ) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE EDITOR) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE FLOATQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1426")) (PUT (QUOTE BREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 487)) (FLAG (QUOTE (BREAKLEVEL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1737")) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE MAKEBUFINTOSYSNUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2391")) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L2616")) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE IDNUMBER) (QUOTE 675)) (PUT (QUOTE BINARYOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L2097")) (PUT (QUOTE BINARYOPENREAD) (QUOTE IDNUMBER) (QUOTE 549)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2254")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE INT2SYS) (QUOTE ENTRYPOINT) (QUOTE "L0016")) (PUT (QUOTE INT2SYS) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE ON) (QUOTE ENTRYPOINT) (QUOTE ON)) (PUT (QUOTE ON) (QUOTE IDNUMBER) (QUOTE 727)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1119")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE INTPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1399")) (PUT (QUOTE TIMC) (QUOTE ENTRYPOINT) (QUOTE TIMC)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 593)) (PUT (QUOTE INTQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1425")) (PUT (QUOTE PROG2) (QUOTE ENTRYPOINT) (QUOTE PROG2)) (PUT (QUOTE PROG2) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE MK!*SQ) (QUOTE IDNUMBER) (QUOTE 749)) (PUT (QUOTE LIST2SET) (QUOTE ENTRYPOINT) (QUOTE "L1044")) (PUT (QUOTE LIST2SET) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE YES) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 514)) (PUT (QUOTE !*WRITINGFASLFILE) (QUOTE IDNUMBER) (QUOTE 553)) (PUT (QUOTE DELETIP1) (QUOTE ENTRYPOINT) (QUOTE "L0884")) (PUT (QUOTE OLDHEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE OLDHEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1085")) (PUT (QUOTE OLDHEAPUPPERBOUND) (QUOTE WVAR) (QUOTE OLDHEAPUPPERBOUND)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 518)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1763")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 490)) (PUT (QUOTE OFF) (QUOTE ENTRYPOINT) (QUOTE OFF)) (PUT (QUOTE OFF) (QUOTE IDNUMBER) (QUOTE 728)) (PUT (QUOTE QEDITFNS) (QUOTE IDNUMBER) (QUOTE 436)) (FLAG (QUOTE (QEDITFNS)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CHANNELPRIN2T) (QUOTE ENTRYPOINT) (QUOTE "L1035")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE COLLECT) (QUOTE IDNUMBER) (QUOTE 737)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE ENTRYPOINT) (QUOTE "L2621")) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE IDNUMBER) (QUOTE 676)) (PUT (QUOTE !*INNER!*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 494)) (FLAG (QUOTE (!*INNER!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRING) (QUOTE ENTRYPOINT) (QUOTE "L1134")) (PUT (QUOTE COPYSTRING) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 537)) (PUT (QUOTE TOTALCOPY) (QUOTE ENTRYPOINT) (QUOTE "L1163")) (PUT (QUOTE TOTALCOPY) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE OPTIONS!*) (QUOTE IDNUMBER) (QUOTE 466)) (FLAG (QUOTE (OPTIONS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 524)) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1101")) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE LINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2329")) (PUT (QUOTE LINELENGTH) (QUOTE IDNUMBER) (QUOTE 622)) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE ENTRYPOINT) (QUOTE "L2572")) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE IDNUMBER) (QUOTE 663)) (PUT (QUOTE RANGE) (QUOTE IDNUMBER) (QUOTE 719)) (PUT (QUOTE PUTENTRY) (QUOTE ENTRYPOINT) (QUOTE "L2164")) (PUT (QUOTE PUTENTRY) (QUOTE IDNUMBER) (QUOTE 561)) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2583")) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE IDNUMBER) (QUOTE 670)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2906")) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 596)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE INT2ID) (QUOTE ENTRYPOINT) (QUOTE INT2ID)) (PUT (QUOTE INT2ID) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE INTDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1408")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 513)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE MAX2) (QUOTE ENTRYPOINT) (QUOTE MAX2)) (PUT (QUOTE MAX2) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE VALUECELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2104")) (PUT (QUOTE VALUECELLLOCATION) (QUOTE IDNUMBER) (QUOTE 552)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE PRINC) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRINC) (QUOTE IDNUMBER) (QUOTE 629)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2256")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE MINI) (QUOTE ENTRYPOINT) (QUOTE MINI)) (PUT (QUOTE MINI) (QUOTE IDNUMBER) (QUOTE 580)) (PUT (QUOTE EXPLODE2) (QUOTE ENTRYPOINT) (QUOTE "L2904")) (PUT (QUOTE EXPLODE2) (QUOTE IDNUMBER) (QUOTE 699)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2257")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE PAIR) (QUOTE ENTRYPOINT) (QUOTE PAIR)) (PUT (QUOTE PAIR) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE REVERSIP) (QUOTE ENTRYPOINT) (QUOTE "L0868")) (PUT (QUOTE REVERSIP) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2597")) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE IDNUMBER) (QUOTE 672)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2110")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 560)) (PUT (QUOTE RANGEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1710")) (PUT (QUOTE RANGEERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PENDINGLOADS!*) (QUOTE IDNUMBER) (QUOTE 574)) (FLAG (QUOTE (PENDINGLOADS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE QUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1424")) (PUT (QUOTE QUOTIENT) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE SPACES) (QUOTE ENTRYPOINT) (QUOTE SPACES)) (PUT (QUOTE SPACES) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0032")) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2725")) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE IDNUMBER) (QUOTE 688)) (PUT (QUOTE CATCH) (QUOTE ENTRYPOINT) (QUOTE CATCH)) (PUT (QUOTE CATCH) (QUOTE IDNUMBER) (QUOTE 498)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE IDNUMBER) (QUOTE 659)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE INITIALVALUE) (QUOTE 33)) (PUT (QUOTE CHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1824")) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 503)) (PUT (QUOTE WRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2561")) (PUT (QUOTE WRITESTRING) (QUOTE IDNUMBER) (QUOTE 661)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1265")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE CHANNELREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2263")) (PUT (QUOTE CHANNELREADCHAR) (QUOTE IDNUMBER) (QUOTE 598)) (PUT (QUOTE DELATQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0962")) (PUT (QUOTE SPACES2) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE SPACES2) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE ASSOC) (QUOTE ENTRYPOINT) (QUOTE ASSOC)) (PUT (QUOTE ASSOC) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE IMPORTS) (QUOTE ENTRYPOINT) (QUOTE "L2202")) (PUT (QUOTE IMPORTS) (QUOTE IDNUMBER) (QUOTE 575)) (PUT (QUOTE EQN) (QUOTE ENTRYPOINT) (QUOTE EQN)) (PUT (QUOTE EQN) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE DELETIP) (QUOTE ENTRYPOINT) (QUOTE "L0890")) (PUT (QUOTE DELETIP) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE FLOATTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1417")) (PUT (QUOTE REPEAT) (QUOTE ENTRYPOINT) (QUOTE REPEAT)) (PUT (QUOTE REPEAT) (QUOTE IDNUMBER) (QUOTE 746)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE AND) (QUOTE ENTRYPOINT) (QUOTE AND)) (PUT (QUOTE AND) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE EXPLODEENDPOINTER!*) (QUOTE IDNUMBER) (QUOTE 697)) (FLAG (QUOTE (EXPLODEENDPOINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE HEAPSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE HEAPSIZE) (QUOTE WCONST) (QUOTE 262000)) (PUT (QUOTE !&!&THROWN!&!&) (QUOTE IDNUMBER) (QUOTE 529)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2911")) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 592)) (PUT (QUOTE RECIP) (QUOTE ENTRYPOINT) (QUOTE RECIP)) (PUT (QUOTE RECIP) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 486)) (FLAG (QUOTE (MAXBREAKLEVEL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE DELATQIP) (QUOTE ENTRYPOINT) (QUOTE "L0968")) (PUT (QUOTE DELATQIP) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE READCH) (QUOTE ENTRYPOINT) (QUOTE READCH)) (PUT (QUOTE READCH) (QUOTE IDNUMBER) (QUOTE 628)) (PUT (QUOTE LITER) (QUOTE ENTRYPOINT) (QUOTE LITER)) (PUT (QUOTE LITER) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE NEXT) (QUOTE ENTRYPOINT) (QUOTE NEXT)) (PUT (QUOTE NEXT) (QUOTE IDNUMBER) (QUOTE 744)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1254")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE UNWIND!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1982")) (PUT (QUOTE UNWIND!-ALL) (QUOTE IDNUMBER) (QUOTE 528)) (PUT (QUOTE XINS) (QUOTE ENTRYPOINT) (QUOTE XINS)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1787")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 492)) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2742")) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE IDNUMBER) (QUOTE 689)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE STACKSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE STACKSIZE) (QUOTE WCONST) (QUOTE 10000)) (PUT (QUOTE DEFLIST) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE DEFLIST) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CHANNELTYO) (QUOTE ENTRYPOINT) (QUOTE "L2921")) (PUT (QUOTE CHANNELTYO) (QUOTE IDNUMBER) (QUOTE 707)) (PUT (QUOTE CHANNELREADLINE) (QUOTE ENTRYPOINT) (QUOTE "L2547")) (PUT (QUOTE CHANNELREADLINE) (QUOTE IDNUMBER) (QUOTE 657)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1877")) (PUT (QUOTE SUB) (QUOTE ENTRYPOINT) (QUOTE SUB)) (PUT (QUOTE SUB) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1858")) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CHANNELSPACES2) (QUOTE ENTRYPOINT) (QUOTE "L1040")) (PUT (QUOTE CHANNELSPACES2) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE OLDHEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE OLDHEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1084")) (PUT (QUOTE OLDHEAPLOWERBOUND) (QUOTE WVAR) (QUOTE OLDHEAPLOWERBOUND)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L2259")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE VECTOR2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0052")) (PUT (QUOTE VECTOR2STRING) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE CHANNELREADEOF) (QUOTE ENTRYPOINT) (QUOTE "L2342")) (PUT (QUOTE CHANNELREADEOF) (QUOTE IDNUMBER) (QUOTE 641)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1111")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE FIXP) (QUOTE ENTRYPOINT) (QUOTE FIXP)) (PUT (QUOTE FIXP) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ADJOIN) (QUOTE ENTRYPOINT) (QUOTE ADJOIN)) (PUT (QUOTE ADJOIN) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2348")) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE IDNUMBER) (QUOTE 644)) (PUT (QUOTE EXPAND) (QUOTE ENTRYPOINT) (QUOTE EXPAND)) (PUT (QUOTE EXPAND) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE HALFWORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0458")) (PUT (QUOTE HEAP2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAP2) (QUOTE ASMSYMBOL) (QUOTE HEAP2)) (PUT (QUOTE HEAP2) (QUOTE WARRAY) (QUOTE HEAP2)) (PUT (QUOTE MAKEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L1391")) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L1208")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE CHANNELTERPRI) (QUOTE ENTRYPOINT) (QUOTE "L2334")) (PUT (QUOTE CHANNELTERPRI) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE LASTCAR) (QUOTE ENTRYPOINT) (QUOTE "L0986")) (PUT (QUOTE LASTCAR) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE !*BREAK) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE !*BREAK) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE THROWTAG!*) (QUOTE IDNUMBER) (QUOTE 526)) (FLAG (QUOTE (THROWTAG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EXPT) (QUOTE ENTRYPOINT) (QUOTE EXPT)) (PUT (QUOTE EXPT) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE EVOR) (QUOTE ENTRYPOINT) (QUOTE EVOR)) (PUT (QUOTE EVOR) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE MAPCAN) (QUOTE ENTRYPOINT) (QUOTE MAPCAN)) (PUT (QUOTE MAPCAN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE LAND) (QUOTE ENTRYPOINT) (QUOTE LAND)) (PUT (QUOTE LAND) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE LSH) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSH) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE COMPILETIME) (QUOTE ENTRYPOINT) (QUOTE "L2923")) (PUT (QUOTE COMPILETIME) (QUOTE IDNUMBER) (QUOTE 711)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE STEP) (QUOTE ENTRYPOINT) (QUOTE STEP)) (PUT (QUOTE STEP) (QUOTE IDNUMBER) (QUOTE 579)) (PUT (QUOTE PAGEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE PAGEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2258")) (PUT (QUOTE PAGEPOSITION) (QUOTE WARRAY) (QUOTE PAGEPOSITION)) (PUT (QUOTE DEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3044")) (PUT (QUOTE DEFCONST) (QUOTE IDNUMBER) (QUOTE 731)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 522)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 654)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1407")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE BPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPS) (QUOTE ASMSYMBOL) (QUOTE BPS)) (PUT (QUOTE BPS) (QUOTE WARRAY) (QUOTE BPS)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2279")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 467)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1784")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE EQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0429")) (PUT (QUOTE EQUAL) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 649)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2255")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE ENTRYPOINT) (QUOTE "L2027")) (PUT (QUOTE NO) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INTLAND) (QUOTE ENTRYPOINT) (QUOTE "L1455")) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE RPLACEALL) (QUOTE ENTRYPOINT) (QUOTE "L1611")) (PUT (QUOTE READONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1815")) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 505)) (PUT (QUOTE CATCHSETUPAUX) (QUOTE ENTRYPOINT) (QUOTE "L2014")) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE INTHISCASE) (QUOTE ENTRYPOINT) (QUOTE "L2951")) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE COMMENTOUTCODE) (QUOTE ENTRYPOINT) (QUOTE "L2922")) (PUT (QUOTE COMMENTOUTCODE) (QUOTE IDNUMBER) (QUOTE 710)) (PUT (QUOTE HEAP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAP) (QUOTE ASMSYMBOL) (QUOTE HEAP)) (PUT (QUOTE HEAP) (QUOTE WARRAY) (QUOTE HEAP)) (PUT (QUOTE COPYWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1135")) (PUT (QUOTE COPYWARRAY) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE INTTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1416")) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE LIST2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE LIST2VECTOR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE SUBST) (QUOTE ENTRYPOINT) (QUOTE SUBST)) (PUT (QUOTE SUBST) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 517)) (PUT (QUOTE !*COMPRESSING) (QUOTE IDNUMBER) (QUOTE 647)) (FLAG (QUOTE (!*COMPRESSING)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE XN) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE XN) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE LOR) (QUOTE ENTRYPOINT) (QUOTE LOR)) (PUT (QUOTE LOR) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L1757")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0794")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE WRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2848")) (PUT (QUOTE WRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 668)) (PUT (QUOTE ONOFF!*) (QUOTE ENTRYPOINT) (QUOTE "L2979")) (PUT (QUOTE ONOFF!*) (QUOTE IDNUMBER) (QUOTE 724)) (PUT (QUOTE FLATSIZE2) (QUOTE ENTRYPOINT) (QUOTE "L2908")) (PUT (QUOTE FLATSIZE2) (QUOTE IDNUMBER) (QUOTE 700)) (PUT (QUOTE PROGJUMPTABLE!*) (QUOTE IDNUMBER) (QUOTE 540)) (FLAG (QUOTE (PROGJUMPTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE NONINTEGER1ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1367")) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1260")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0811")) (PUT (QUOTE FUNCTION) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE NUMBERP) (QUOTE ENTRYPOINT) (QUOTE "L0632")) (PUT (QUOTE NUMBERP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE PP) (QUOTE ENTRYPOINT) (QUOTE PP)) (PUT (QUOTE PP) (QUOTE IDNUMBER) (QUOTE 576)) (PUT (QUOTE CONCAT) (QUOTE ENTRYPOINT) (QUOTE CONCAT)) (PUT (QUOTE CONCAT) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE SETMACROREFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L3006")) (PUT (QUOTE !*SEMICOL!*) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE INTONEP) (QUOTE ENTRYPOINT) (QUOTE "L1548")) (PUT (QUOTE COPY) (QUOTE ENTRYPOINT) (QUOTE COPY)) (PUT (QUOTE COPY) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE EDITF) (QUOTE ENTRYPOINT) (QUOTE EDITF)) (PUT (QUOTE EDITF) (QUOTE IDNUMBER) (QUOTE 439)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1760")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE CHANNELEJECT) (QUOTE ENTRYPOINT) (QUOTE "L2321")) (PUT (QUOTE CHANNELEJECT) (QUOTE IDNUMBER) (QUOTE 619)) (PUT (QUOTE SUBLA) (QUOTE ENTRYPOINT) (QUOTE SUBLA)) (PUT (QUOTE SUBLA) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 616)) (FLAG (QUOTE (STDIN!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FASTUNBIND) (QUOTE IDNUMBER) (QUOTE 447)) (PUT (QUOTE RASSOC) (QUOTE ENTRYPOINT) (QUOTE RASSOC)) (PUT (QUOTE RASSOC) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE STATICINTFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L1359")) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 611)) (PUT (QUOTE EVLOAD) (QUOTE ENTRYPOINT) (QUOTE EVLOAD)) (PUT (QUOTE EVLOAD) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE CATCH!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1970")) (PUT (QUOTE CATCH!-ALL) (QUOTE IDNUMBER) (QUOTE 527)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE ENTRYPOINT) (QUOTE "L1809")) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 502)) (PUT (QUOTE SETINDX) (QUOTE ENTRYPOINT) (QUOTE "L0186")) (PUT (QUOTE SETINDX) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 605)) (PUT (QUOTE ADJOINQ) (QUOTE ENTRYPOINT) (QUOTE "L1056")) (PUT (QUOTE ADJOINQ) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE MAKEBUFINTOFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2398")) (PUT (QUOTE CATCHSETUP) (QUOTE ENTRYPOINT) (QUOTE "L2013")) (PUT (QUOTE CATCHSETUP) (QUOTE IDNUMBER) (QUOTE 499)) (PUT (QUOTE FORMATFORPRINTF!*) (QUOTE IDNUMBER) (QUOTE 693)) (FLAG (QUOTE (FORMATFORPRINTF!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DIGITTONUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2510")) (PUT (QUOTE DIGITTONUMBER) (QUOTE IDNUMBER) (QUOTE 651)) (PUT (QUOTE MARKANDCOPYFROMID) (QUOTE ENTRYPOINT) (QUOTE "L1272")) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 520)) (PUT (QUOTE CHANNELPRIN) (QUOTE IDNUMBER) (QUOTE 687)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE DISPLAYHELPFILE) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE !$LOOP!$) (QUOTE IDNUMBER) (QUOTE 743)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1255")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2512")) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE IDNUMBER) (QUOTE 650)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L2081")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 603)) (PUT (QUOTE RETURN) (QUOTE ENTRYPOINT) (QUOTE RETURN)) (PUT (QUOTE RETURN) (QUOTE IDNUMBER) (QUOTE 545)) (PUT (QUOTE BINARYOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L2102")) (PUT (QUOTE BINARYOPENWRITE) (QUOTE IDNUMBER) (QUOTE 551)) (PUT (QUOTE ONEARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1369")) (PUT (QUOTE INTLOR) (QUOTE ENTRYPOINT) (QUOTE INTLOR)) (PUT (QUOTE COPYFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1267")) (PUT (QUOTE ONEARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1378")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1268")) (PUT (QUOTE CHANNELPRINC) (QUOTE ENTRYPOINT) (QUOTE "L2335")) (PUT (QUOTE CHANNELPRINC) (QUOTE IDNUMBER) (QUOTE 630)) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2827")) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 682)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE !*CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 482)) (FLAG (QUOTE (!*CONTINUABLEERROR)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE VECTOREQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0446")) (PUT (QUOTE INTERSECTION) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE INTERSECTION) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE ENTRYPOINT) (QUOTE "L2552")) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE IDNUMBER) (QUOTE 639)) (PUT (QUOTE EVAND1) (QUOTE ENTRYPOINT) (QUOTE EVAND1)) (PUT (QUOTE RPLACW) (QUOTE ENTRYPOINT) (QUOTE RPLACW)) (PUT (QUOTE RPLACW) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE FINDFIRST) (QUOTE ENTRYPOINT) (QUOTE "L1613")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 550)) (PUT (QUOTE MKEVECT) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE CHANNELWRITEBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2566")) (PUT (QUOTE QUIT) (QUOTE ENTRYPOINT) (QUOTE QUIT)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 471)) (PUT (QUOTE TRST) (QUOTE ENTRYPOINT) (QUOTE TRST)) (PUT (QUOTE TRST) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE FILEP) (QUOTE ENTRYPOINT) (QUOTE FILEP)) (PUT (QUOTE FILEP) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE GCSTATS) (QUOTE ENTRYPOINT) (QUOTE "L1270")) (PUT (QUOTE FLOATPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1400")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2578")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE IDNUMBER) (QUOTE 667)) (PUT (QUOTE !#ARG) (QUOTE IDNUMBER) (QUOTE 729)) (PUT (QUOTE MAP2) (QUOTE ENTRYPOINT) (QUOTE MAP2)) (PUT (QUOTE MAP2) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE EDIT) (QUOTE ENTRYPOINT) (QUOTE EDIT)) (PUT (QUOTE EDIT) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE STRING) (QUOTE ENTRYPOINT) (QUOTE STRING)) (PUT (QUOTE STRING) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2796")) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 680)) (PUT (QUOTE OK) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE POSN) (QUOTE ENTRYPOINT) (QUOTE POSN)) (PUT (QUOTE POSN) (QUOTE IDNUMBER) (QUOTE 623)) |
Added psl-1983/3-1/kernel/20/all-kernel.ctl version [2150df11e6].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | submit types.ctl submit randm.ctl submit alloc.ctl submit arith.ctl submit debg.ctl submit error.ctl submit eval.ctl submit extra.ctl submit fasl.ctl submit io.ctl submit macro.ctl submit prop.ctl submit symbl.ctl submit sysio.ctl submit tloop.ctl submit heap.ctl |
Added psl-1983/3-1/kernel/20/alloc.ctl version [a73a1a4c77].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "alloc"; PathIn "alloc.build"; ASMEnd; quit; compile alloc.mac, dalloc.mac |
Added psl-1983/3-1/kernel/20/alloc.init version [d17791cc3a].
> > > | 1 2 3 | (PUT (QUOTE STRING) (QUOTE TYPE) (QUOTE NEXPR)) (PUT (QUOTE VECTOR) (QUOTE TYPE) (QUOTE NEXPR)) (FLUID (QUOTE (!*GC GCKNT!* GCTIME!* HEAP!-WARN!-LEVEL))) |
Added psl-1983/3-1/kernel/20/alloc.log version [2cca670481].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:32:07 BATCON Version 104(4133) GLXLIB Version 1(527) Job ALLOC Req #476 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1733 Input from => PS:<PSL.KERNEL.20.EXT>ALLOC.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>ALLOC.LOG 9:32:08 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:32:08 MONTR @SET TIME-LIMIT 600 9:32:08 MONTR @@LOGIN KESSLER SMALL 9:32:11 MONTR Job 12 on TTY224 8-Jun-83 09:32:11 9:32:11 MONTR Previous login at 8-Jun-83 09:29:18 9:32:11 MONTR There is 1 other job logged in as user KESSLER 9:32:21 MONTR @ 9:32:21 MONTR [PS Mounted] 9:32:21 MONTR 9:32:21 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:32:21 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:32:22 MONTR @S:EX-DEC20-CROSS.EXE 9:32:27 USER [17] ASMOut "alloc"; 9:32:28 USER ASMOUT: IN files; or type in expressions 9:32:28 USER When all done execute ASMEND; 9:32:33 USER [18] PathIn "alloc.build"; 9:32:33 USER % 9:32:33 USER % ALLOC.BUILD - Files dealing with allocation of memory blocks 9:32:33 USER % 9:32:33 USER % Author: Eric Benson 9:32:33 USER % Symbolic Computation Group 9:32:33 USER % Computer Science Dept. 9:32:33 USER % University of Utah 9:32:34 USER % Date: 19 May 1982 9:32:34 USER % Copyright (c) 1982 University of Utah 9:32:35 USER % 9:32:35 USER 9:32:35 USER PathIn "allocators.red"$ % heap, symbol and code space alloc 9:32:58 USER PathIn "copiers.red"$ % copying functions 9:33:05 USER PathIn "cons-mkvect.red"$ % SL constructor functions 9:33:15 USER PathIn "comp-support.red"$ % optimized CONS and LIST compilation 9:33:16 USER PathIn "system-gc.red"$ % system-specific GC routines 9:33:17 USER PathIn "gc.red"$ % the garbage collector 9:33:42 USER [19] ASMEnd; 9:33:44 USER *** Garbage collection starting 9:33:49 USER *** GC 8: time 1768 ms, 205573 recovered, 244793 free 9:34:00 USER 0 9:34:00 USER [20] quit; 9:34:00 MONTR @compile alloc.mac, dalloc.mac 9:34:03 USER MACRO: .MAIN 9:34:11 USER MACRO: .MAIN 9:34:11 USER 9:34:11 USER EXIT 9:34:12 MONTR @ 9:34:13 MONTR Killed by OPERATOR, TTY 221 9:34:13 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:34:13 MONTR at 8-Jun-83 09:34:13, Used 0:00:49 in 0:02:01 |
Added psl-1983/3-1/kernel/20/alloc.mac version [f3f5a4c0ab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern BPS extern HEAP extern HEAP2 extern L1080 extern L1081 extern L1082 extern L1083 extern L1084 extern L1085 extern L1086 extern L1087 extern L1088 0 ; (!*ENTRY KNOWN!-FREE!-SPACE EXPR 0) L1089: intern L1089 HRRZI 2,1 MOVE 1,L1082 SUB 1,L1080 IDIV 1,2 POPJ 15,0 1 ; (!*ENTRY GTHEAP EXPR 1) GTHEAP: intern GTHEAP CAME 1,0 JRST L1090 JRST SYMFNC+378 L1090: MOVE 2,0 JRST L1091 L1093: 19 byte(7)72,101,97,112,32,115,112,97,99,101,32,101,120,104,97,117,115,116,101,100,0 ; (!*ENTRY GTHEAP1 EXPR 2) L1091: intern L1091 ADJSP 15,3 L1094: MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 6,L1080 MOVEM 6,-2(15) ADDM 1,L1080 MOVE 6,L1086 CAML 6,L1080 JRST L1095 MOVE 6,L1082 CAML 6,L1080 JRST L1096 MOVE 6,-2(15) MOVEM 6,L1080 CAMN 2,0 JRST L1097 MOVE 1,L1092 PUSHJ 15,SYMFNC+380 JRST L1095 L1097: PUSHJ 15,SYMFNC+381 MOVE 2,SYMVAL+84 MOVE 1,0(15) JRST L1094 L1096: CAME 0,L1088 JRST L1095 MOVE 6,SYMVAL+84 MOVEM 6,L1088 PUSHJ 15,SYMFNC+382 L1095: MOVE 1,-2(15) ADJSP 15,-3 POPJ 15,0 L1092: <4_30>+<1_18>+L1093 0 ; (!*ENTRY GC!-TRAP!-LEVEL EXPR 0) L1098: intern L1098 HRRZI 2,1 MOVE 1,L1082 SUB 1,L1086 IDIV 1,2 POPJ 15,0 1 ; (!*ENTRY SET!-GC!-TRAP!-LEVEL EXPR 1) L1101: intern L1101 PUSH 15,1 LDB 11,L1099 CAIG 11,0 JRST L1102 CAIN 11,63 JRST L1102 MOVE 2,L1100 PUSHJ 15,SYMFNC+133 L1102: MOVE 1,L1082 SUB 1,0(15) MOVEM 1,L1086 MOVE 1,SYMVAL+84 ADJSP 15,-1 POPJ 15,0 L1099: point 6,1,5 L1100: <30_30>+383 2 ; (!*ENTRY DELHEAP EXPR 2) L1103: intern L1103 CAME 2,L1080 JRST L1104 MOVEM 1,L1080 POPJ 15,0 L1104: MOVE 1,0 POPJ 15,0 1 ; (!*ENTRY GTSTR EXPR 1) GTSTR: intern GTSTR ADJSP 15,3 MOVEM 1,0(15) HRRZI 2,5 ADDI 1,6 IDIV 1,2 MOVEM 1,-2(15) AOS 1 PUSHJ 15,SYMFNC+379 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 TLO 2,94208 MOVEM 2,0(1) MOVE 4,-2(15) ADDM 1,4 SETZM 0(4) ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY GTCONSTSTR EXPR 1) L1105: intern L1105 ADJSP 15,3 MOVEM 1,0(15) HRRZI 2,5 ADDI 1,6 IDIV 1,2 MOVEM 1,-2(15) AOS 1 PUSHJ 15,SYMFNC+386 MOVEM 1,-1(15) MOVE 6,0(15) MOVEM 6,0(1) MOVE 3,-2(15) ADDM 1,3 SETZM 0(3) ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY GTHALFWORDS EXPR 1) L1106: intern L1106 ADJSP 15,3 MOVEM 1,0(15) LSH 1,-1 AOS 1 MOVEM 1,-2(15) AOS 1 PUSHJ 15,SYMFNC+379 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 TLO 2,98304 MOVEM 2,0(1) ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY GTVECT EXPR 1) GTVECT: intern GTVECT ADJSP 15,2 MOVEM 1,0(15) ADDI 1,2 PUSHJ 15,SYMFNC+379 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 TLO 2,106496 MOVEM 2,0(1) ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY GTWRDS EXPR 1) GTWRDS: intern GTWRDS ADJSP 15,2 MOVEM 1,0(15) ADDI 1,2 PUSHJ 15,SYMFNC+379 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 TLO 2,102400 MOVEM 2,0(1) ADJSP 15,-2 POPJ 15,0 0 ; (!*ENTRY GTFIXN EXPR 0) GTFIXN: intern GTFIXN ADJSP 15,1 HRRZI 1,2 PUSHJ 15,SYMFNC+379 MOVEM 1,0(15) SETZM 2 TLZ 2,258048 TLO 2,102400 MOVEM 2,0(1) ADJSP 15,-1 POPJ 15,0 0 ; (!*ENTRY GTFLTN EXPR 0) GTFLTN: intern GTFLTN ADJSP 15,1 HRRZI 1,3 PUSHJ 15,SYMFNC+379 MOVEM 1,0(15) HRRZI 2,1 TLZ 2,258048 TLO 2,102400 MOVEM 2,0(1) ADJSP 15,-1 POPJ 15,0 L1108: 18 byte(7)82,97,110,32,111,117,116,32,111,102,32,73,68,32,115,112,97,99,101,0 0 ; (!*ENTRY GTID EXPR 0) GTID: intern GTID PUSH 15,0 SKIPE L0001 JRST L1109 PUSHJ 15,SYMFNC+390 SKIPE L0001 JRST L1109 MOVE 1,L1107 ADJSP 15,-1 JRST SYMFNC+380 L1109: MOVE 6,L0001 MOVEM 6,0(15) MOVE 6,0(15) MOVE 6,SYMNAM(6) MOVEM 6,L0001 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L1107: <4_30>+<1_18>+L1108 extern L1110 extern L1111 L1113: 30 byte(7)82,97,110,32,111,117,116,32,111,102,32,98,105,110,97,114,121,32,112,114,111,103,114,97,109,32,115,112,97,99,101,0 1 ; (!*ENTRY GTBPS EXPR 1) GTBPS: intern GTBPS MOVE 4,1 MOVE 3,0 CAME 1,0 JRST L1114 HRRZI 2,1 MOVE 1,L1111 SUB 1,L1110 IDIV 1,2 POPJ 15,0 L1114: MOVE 3,L1110 ADDM 1,L1110 MOVE 6,L1111 CAML 6,L1110 JRST L1115 MOVE 1,L1112 JRST SYMFNC+156 L1115: MOVE 1,3 POPJ 15,0 L1112: <4_30>+<1_18>+L1113 2 ; (!*ENTRY DELBPS EXPR 2) DELBPS: intern DELBPS CAME 2,L1110 JRST L1116 MOVEM 1,L1110 POPJ 15,0 L1116: MOVE 1,0 POPJ 15,0 L1118: 22 byte(7)82,97,110,32,111,117,116,32,111,102,32,87,65,114,114,97,121,32,115,112,97,99,101,0 1 ; (!*ENTRY GTWARRAY EXPR 1) L1119: intern L1119 MOVE 4,1 MOVE 3,0 CAME 1,0 JRST L1120 HRRZI 2,1 MOVE 1,L1111 SUB 1,L1110 IDIV 1,2 POPJ 15,0 L1120: MOVE 2,L1111 SUB 2,1 MOVE 3,2 CAML 2,L1110 JRST L1121 MOVE 1,L1117 JRST SYMFNC+156 L1121: MOVE 1,2 MOVEM 1,L1111 POPJ 15,0 L1117: <4_30>+<1_18>+L1118 2 ; (!*ENTRY DELWARRAY EXPR 2) L1122: intern L1122 CAME 1,L1111 JRST L1123 MOVE 1,2 MOVEM 1,L1111 POPJ 15,0 L1123: MOVE 1,0 POPJ 15,0 2 ; (!*ENTRY COPYSTRINGTOFROM EXPR 2) L1127: intern L1127 ADJSP 15,6 MOVEM 1,-5(15) MOVEM 2,-4(15) MOVE 3,1 TLZ 3,258048 MOVEM 3,-2(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-1(15) MOVE 6,0(4) LDB 5,L1124 TDNE 5,L1125 TDO 5,L1126 MOVEM 5,-3(15) MOVE 6,0(3) LDB 1,L1124 TDNE 1,L1125 TDO 1,L1126 CAML 1,5 JRST L1128 MOVEM 1,-3(15) L1128: HRRZI 2,5 HRRZI 1,6 ADD 1,-3(15) IDIV 1,2 MOVEM 1,-3(15) SETZM 0(15) L1129: MOVE 6,0(15) CAMLE 6,-3(15) JRST L1130 MOVE 2,0(15) ADD 2,-2(15) MOVE 3,0(15) ADD 3,-1(15) MOVE 6,1(3) MOVEM 6,1(2) AOS 0(15) JRST L1129 L1130: MOVE 1,-5(15) ADJSP 15,-6 POPJ 15,0 L1124: point 30,6,35 L1125: 536870912 L1126: -536870912 1 ; (!*ENTRY COPYSTRING EXPR 1) L1134: intern L1134 ADJSP 15,2 MOVEM 1,0(15) MOVE 2,1 TLZ 2,258048 MOVE 6,0(2) LDB 1,L1131 TDNE 1,L1132 TDO 1,L1133 PUSHJ 15,SYMFNC+145 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC+394 MOVE 1,-1(15) TLZ 1,258048 TLO 1,16384 ADJSP 15,-2 POPJ 15,0 L1131: point 30,6,35 L1132: 536870912 L1133: -536870912 3 ; (!*ENTRY COPYWARRAY EXPR 3) L1135: intern L1135 ADJSP 15,2 MOVEM 1,-1(15) MOVEM 2,0(15) MOVE 5,3 SETZM 4 L1136: CAMG 4,5 JRST L1137 SETZM 1 JRST L1138 L1137: MOVE 2,4 ADD 2,-1(15) MOVE 3,4 ADD 3,0(15) MOVE 6,0(3) MOVEM 6,0(2) AOS 4 JRST L1136 L1138: MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 2 ; (!*ENTRY COPYVECTORTOFROM EXPR 2) L1142: intern L1142 ADJSP 15,6 MOVEM 1,-5(15) MOVEM 2,-4(15) MOVE 3,1 TLZ 3,258048 MOVEM 3,-2(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-1(15) MOVE 6,0(4) LDB 5,L1139 TDNE 5,L1140 TDO 5,L1141 MOVEM 5,-3(15) SETZM 0(15) L1143: MOVE 6,0(15) CAMLE 6,-3(15) JRST L1144 MOVE 2,0(15) ADD 2,-2(15) MOVE 3,0(15) ADD 3,-1(15) MOVE 6,1(3) MOVEM 6,1(2) AOS 0(15) JRST L1143 L1144: MOVE 1,-5(15) ADJSP 15,-6 POPJ 15,0 L1139: point 30,6,35 L1140: 536870912 L1141: -536870912 1 ; (!*ENTRY COPYVECTOR EXPR 1) L1148: intern L1148 ADJSP 15,2 MOVEM 1,0(15) MOVE 2,1 TLZ 2,258048 MOVE 6,0(2) LDB 1,L1145 TDNE 1,L1146 TDO 1,L1147 PUSHJ 15,SYMFNC+142 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC+397 MOVE 1,-1(15) TLZ 1,258048 TLO 1,32768 ADJSP 15,-2 POPJ 15,0 L1145: point 30,6,35 L1146: 536870912 L1147: -536870912 2 ; (!*ENTRY COPYWRDSTOFROM EXPR 2) L1152: intern L1152 ADJSP 15,6 MOVEM 1,-5(15) MOVEM 2,-4(15) MOVE 3,1 TLZ 3,258048 MOVEM 3,-2(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-1(15) MOVE 6,0(4) LDB 5,L1149 TDNE 5,L1150 TDO 5,L1151 MOVEM 5,-3(15) SETZM 0(15) L1153: MOVE 6,0(15) CAMLE 6,-3(15) JRST L1154 MOVE 2,0(15) ADD 2,-2(15) MOVE 3,0(15) ADD 3,-1(15) MOVE 6,1(3) MOVEM 6,1(2) AOS 0(15) JRST L1153 L1154: MOVE 1,-5(15) ADJSP 15,-6 POPJ 15,0 L1149: point 30,6,35 L1150: 536870912 L1151: -536870912 1 ; (!*ENTRY COPYWRDS EXPR 1) L1158: intern L1158 ADJSP 15,2 MOVEM 1,0(15) MOVE 2,1 TLZ 2,258048 MOVE 6,0(2) LDB 1,L1155 TDNE 1,L1156 TDO 1,L1157 PUSHJ 15,SYMFNC+170 MOVEM 1,-1(15) MOVE 2,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC+399 MOVE 1,-1(15) TLZ 1,258048 TLO 1,28672 ADJSP 15,-2 POPJ 15,0 L1155: point 30,6,35 L1156: 536870912 L1157: -536870912 1 ; (!*ENTRY TOTALCOPY EXPR 1) L1163: intern L1163 ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 1,L1159 CAIL 1,1 CAILE 1,9 JRST L1164 JRST @L1165-1(1) L1165: IFIW L1166 IFIW L1167 IFIW L1168 IFIW L1169 IFIW L1167 IFIW L1167 IFIW L1170 IFIW L1171 IFIW L1172 L1164: JRST L1167 L1172: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,L1163 MOVEM 1,-4(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,L1163 MOVE 2,-4(15) ADJSP 15,-5 JRST SYMFNC+278 L1169: MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+395 L1171: MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-3(15) MOVE 6,0(2) LDB 3,L1160 TDNE 3,L1161 TDO 3,L1162 MOVEM 3,-1(15) MOVE 1,3 PUSHJ 15,SYMFNC+142 MOVE 4,1 TLZ 4,258048 TLO 4,32768 MOVEM 4,-2(15) MOVEM 0,-4(15) SETZM -4(15) L1173: MOVE 6,-4(15) CAMG 6,-1(15) JRST L1174 SETZM 1 JRST L1175 L1174: MOVE 1,0(15) TLZ 1,258048 ADD 1,-4(15) MOVE 1,1(1) PUSHJ 15,L1163 MOVE 2,-2(15) TLZ 2,258048 ADD 2,-4(15) MOVEM 1,1(2) AOS -4(15) JRST L1173 L1175: MOVE 1,-2(15) JRST L1176 L1170: MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+400 L1166: MOVE 1,0(15) PUSHJ 15,SYMFNC+400 TLZ 1,258048 TLZ 1,258048 TLO 1,4096 JRST L1176 L1168: MOVE 1,0(15) PUSHJ 15,SYMFNC+400 TLZ 1,258048 TLZ 1,258048 TLO 1,12288 JRST L1176 L1167: MOVE 1,0(15) L1176: ADJSP 15,-5 POPJ 15,0 L1159: point 6,1,5 L1160: point 30,6,35 L1161: 536870912 L1162: -536870912 ; (!*ENTRY HARDCONS EXPR 2) L1177: intern L1177 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVNI 7,2 ADDM 7,L1080 HRRZI 1,2 PUSHJ 15,SYMFNC+379 MOVEM 1,-2(15) MOVE 6,0(15) MOVEM 6,0(1) MOVE 6,-1(15) MOVEM 6,1(1) TLZ 1,258048 TLO 1,36864 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY CONS EXPR 2) CONS: intern CONS MOVE 5,1 MOVE 4,2 MOVE 3,L1080 HRRZI 7,2 ADDM 7,L1080 MOVE 6,L1086 CAML 6,L1080 JRST L1178 JRST L1177 L1178: MOVEM 1,0(3) MOVEM 2,1(3) MOVE 1,3 TLZ 1,258048 TLO 1,36864 POPJ 15,0 2 ; (!*ENTRY XCONS EXPR 2) XCONS: intern XCONS MOVE 5,1 MOVE 4,2 MOVE 3,L1080 HRRZI 7,2 ADDM 7,L1080 MOVE 6,L1086 CAML 6,L1080 JRST L1179 MOVE 2,1 MOVE 1,4 JRST L1177 L1179: MOVEM 2,0(3) MOVEM 1,1(3) MOVE 1,3 TLZ 1,258048 TLO 1,36864 POPJ 15,0 1 ; (!*ENTRY NCONS EXPR 1) NCONS: intern NCONS MOVE 4,1 MOVE 3,L1080 HRRZI 7,2 ADDM 7,L1080 MOVE 6,L1086 CAML 6,L1080 JRST L1180 MOVE 2,0 JRST L1177 L1180: MOVEM 1,0(3) MOVE 2,0 MOVEM 2,1(3) MOVE 1,3 TLZ 1,258048 TLO 1,36864 POPJ 15,0 L1186: 57 byte(7)65,32,118,101,99,116,111,114,32,119,105,116,104,32,102,101,119,101,114,32,116,104,97,110,32,122,101,114,111,32,101,108,101,109,101,110,116,115,32,99,97,110,110,111,116,32,98,101,32,97,108,108,111,99,97,116,101,100,0 1 ; (!*ENTRY MKVECT EXPR 1) MKVECT: intern MKVECT ADJSP 15,3 MOVEM 1,0(15) LDB 11,L1182 CAIN 11,63 JRST L1181 CAILE 11,0 JRST L1187 L1181: MOVEM 1,0(15) CAML 1,L1183 JRST L1188 MOVE 1,L1184 ADJSP 15,-3 JRST SYMFNC+156 L1188: MOVEM 0,-1(15) PUSHJ 15,SYMFNC+142 MOVEM 1,-1(15) MOVEM 0,-2(15) SETZM -2(15) L1189: MOVE 6,-2(15) CAMLE 6,0(15) JRST L1190 MOVE 2,-2(15) ADD 2,-1(15) MOVE 1,0 MOVEM 1,1(2) AOS -2(15) JRST L1189 L1190: MOVE 1,-1(15) TLZ 1,258048 TLO 1,32768 JRST L1191 L1187: MOVE 2,L1185 ADJSP 15,-3 JRST SYMFNC+133 L1191: ADJSP 15,-3 POPJ 15,0 L1182: point 6,1,5 L1183: -1 L1185: <30_30>+402 L1184: <4_30>+<1_18>+L1186 L1197: 58 byte(7)65,110,32,32,69,118,101,99,116,32,119,105,116,104,32,102,101,119,101,114,32,116,104,97,110,32,122,101,114,111,32,101,108,101,109,101,110,116,115,32,99,97,110,110,111,116,32,98,101,32,97,108,108,111,99,97,116,101,100,0 2 ; (!*ENTRY MKEVECTOR EXPR 2) L1198: intern L1198 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1193 CAIN 11,63 JRST L1192 CAILE 11,0 JRST L1199 L1192: MOVEM 1,0(15) CAML 1,L1194 JRST L1200 MOVE 1,L1195 ADJSP 15,-4 JRST SYMFNC+156 L1200: MOVEM 0,-2(15) PUSHJ 15,SYMFNC+387 MOVEM 1,-2(15) MOVE 6,-1(15) MOVEM 6,1(1) MOVEM 0,-3(15) HRRZI 6,1 MOVEM 6,-3(15) L1201: MOVE 6,-3(15) CAMLE 6,0(15) JRST L1202 MOVE 2,-3(15) ADD 2,-2(15) MOVE 1,0 MOVEM 1,1(2) AOS -3(15) JRST L1201 L1202: MOVE 1,-2(15) TLZ 1,258048 TLO 1,40960 JRST L1203 L1199: MOVE 2,L1196 ADJSP 15,-4 JRST SYMFNC+133 L1203: ADJSP 15,-4 POPJ 15,0 L1193: point 6,1,5 L1194: -1 L1196: <30_30>+404 L1195: <4_30>+<1_18>+L1197 2 ; (!*ENTRY MKSTRING EXPR 2) L1208: intern L1208 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L1205 CAIN 11,63 JRST L1204 CAILE 11,0 JRST L1209 L1204: MOVEM 1,-2(15) JRST L1210 L1209: MOVE 2,L1206 ADJSP 15,-5 JRST SYMFNC+133 L1210: MOVE 6,-2(15) CAML 6,L1207 JRST L1211 MOVE 2,L1206 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+406 L1211: MOVE 1,-2(15) PUSHJ 15,SYMFNC+145 MOVEM 1,-3(15) SETZM -4(15) L1212: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L1213 MOVE 3,-1(15) MOVE 2,-4(15) MOVE 1,-3(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -4(15) JRST L1212 L1213: MOVE 1,-3(15) TLZ 1,258048 TLO 1,16384 ADJSP 15,-5 POPJ 15,0 L1205: point 6,1,5 L1207: -1 L1206: <30_30>+405 2 ; (!*ENTRY MAKE!-BYTES EXPR 2) L1218: intern L1218 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L1215 CAIN 11,63 JRST L1214 CAILE 11,0 JRST L1219 L1214: MOVEM 1,-2(15) JRST L1220 L1219: MOVE 2,L1216 ADJSP 15,-5 JRST SYMFNC+133 L1220: MOVE 6,-2(15) CAML 6,L1217 JRST L1221 MOVE 2,L1216 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+406 L1221: MOVE 1,-2(15) PUSHJ 15,SYMFNC+145 MOVEM 1,-3(15) SETZM -4(15) L1222: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L1223 MOVE 3,-1(15) MOVE 2,-4(15) MOVE 1,-3(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -4(15) JRST L1222 L1223: MOVE 1,-3(15) TLZ 1,258048 TLO 1,20480 ADJSP 15,-5 POPJ 15,0 L1215: point 6,1,5 L1217: -1 L1216: <30_30>+407 2 ; (!*ENTRY MAKE!-HALFWORDS EXPR 2) L1228: intern L1228 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L1225 CAIN 11,63 JRST L1224 CAILE 11,0 JRST L1229 L1224: MOVEM 1,-2(15) JRST L1230 L1229: MOVE 2,L1226 ADJSP 15,-5 JRST SYMFNC+133 L1230: MOVE 6,-2(15) CAML 6,L1227 JRST L1231 MOVE 2,L1226 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+406 L1231: MOVE 1,-2(15) PUSHJ 15,SYMFNC+171 MOVEM 1,-3(15) SETZM -4(15) L1232: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L1233 MOVE 3,-1(15) MOVE 2,-4(15) MOVE 1,-3(15) AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -4(15) JRST L1232 L1233: MOVE 1,-3(15) TLZ 1,258048 TLO 1,24576 ADJSP 15,-5 POPJ 15,0 L1225: point 6,1,5 L1227: -1 L1226: <30_30>+408 2 ; (!*ENTRY MAKE!-WORDS EXPR 2) L1238: intern L1238 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L1235 CAIN 11,63 JRST L1234 CAILE 11,0 JRST L1239 L1234: MOVEM 1,-2(15) JRST L1240 L1239: MOVE 2,L1236 ADJSP 15,-5 JRST SYMFNC+133 L1240: MOVE 6,-2(15) CAML 6,L1237 JRST L1241 MOVE 2,L1236 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+406 L1241: MOVE 1,-2(15) PUSHJ 15,SYMFNC+170 MOVEM 1,-3(15) SETZM -4(15) L1242: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L1243 MOVE 2,-4(15) ADD 2,-3(15) MOVE 6,-1(15) MOVEM 6,1(2) AOS -4(15) JRST L1242 L1243: MOVE 1,-3(15) TLZ 1,258048 TLO 1,28672 ADJSP 15,-5 POPJ 15,0 L1235: point 6,1,5 L1237: -1 L1236: <30_30>+409 2 ; (!*ENTRY MAKE!-VECTOR EXPR 2) L1248: intern L1248 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L1245 CAIN 11,63 JRST L1244 CAILE 11,0 JRST L1249 L1244: MOVEM 1,-2(15) JRST L1250 L1249: MOVE 2,L1246 ADJSP 15,-5 JRST SYMFNC+133 L1250: MOVE 6,-2(15) CAML 6,L1247 JRST L1251 MOVE 2,L1246 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+406 L1251: MOVE 1,-2(15) PUSHJ 15,SYMFNC+142 MOVEM 1,-3(15) SETZM -4(15) L1252: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L1253 MOVE 2,-4(15) ADD 2,-3(15) MOVE 6,-1(15) MOVEM 6,1(2) AOS -4(15) JRST L1252 L1253: MOVE 1,-3(15) TLZ 1,258048 TLO 1,32768 ADJSP 15,-5 POPJ 15,0 L1245: point 6,1,5 L1247: -1 L1246: <30_30>+410 1 ; (!*ENTRY STRING NEXPR 1) STRING: intern STRING JRST SYMFNC+147 1 ; (!*ENTRY VECTOR NEXPR 1) VECTOR: intern VECTOR JRST SYMFNC+152 5 ; (!*ENTRY LIST5 EXPR 5) LIST5: intern LIST5 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVE 4,5 MOVE 3,-3(15) MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+250 MOVE 2,0(15) ADJSP 15,-4 JRST SYMFNC+278 4 ; (!*ENTRY LIST4 EXPR 4) LIST4: intern LIST4 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 3,4 MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+235 MOVE 2,0(15) ADJSP 15,-3 JRST SYMFNC+278 3 ; (!*ENTRY LIST3 EXPR 3) LIST3: intern LIST3 PUSH 15,2 PUSH 15,1 MOVE 2,3 MOVE 1,-1(15) PUSHJ 15,SYMFNC+249 MOVE 2,0(15) ADJSP 15,-2 JRST SYMFNC+278 2 ; (!*ENTRY LIST2 EXPR 2) LIST2: intern LIST2 PUSH 15,1 MOVE 1,2 PUSHJ 15,SYMFNC+172 MOVE 2,0(15) ADJSP 15,-1 JRST SYMFNC+278 extern L1254 extern L1255 extern L1256 extern L1257 extern L1258 extern L1259 0 ; (!*ENTRY RECLAIM EXPR 0) L1260: intern L1260 JRST SYMFNC+381 L1263: 13 byte(7)72,101,97,112,32,115,112,97,99,101,32,108,111,119,0 L1264: 30 byte(7)42,42,42,32,71,97,114,98,97,103,101,32,99,111,108,108,101,99,116,105,111,110,32,115,116,97,114,116,105,110,103,0 0 ; (!*ENTRY !%RECLAIM EXPR 0) L1265: intern L1265 ADJSP 15,2 CAMN 0,SYMVAL+416 JRST L1266 MOVE 1,L1261 PUSHJ 15,SYMFNC+418 L1266: HRRZI 1,2 MOVNS 1 MOVE 2,1 MOVE 1,15 ADJSP 1,0(2) HRRZ 1,1 IOR 1,[262144] MOVEM 1,L1257 PUSHJ 15,SYMFNC+419 MOVEM 1,L1258 MOVE 2,L1080 SUB 2,L1081 MOVEM 2,L1259 AOS SYMVAL+414 MOVE 6,L1080 MOVEM 6,L1083 MOVE 6,L1084 MOVEM 6,L1080 MOVE 6,L1081 MOVEM 6,0(15) MOVE 6,L1082 MOVEM 6,-1(15) MOVE 6,L1084 MOVEM 6,L1081 MOVE 6,L1085 MOVEM 6,L1082 MOVE 6,0(15) MOVEM 6,L1084 MOVE 6,-1(15) MOVEM 6,L1085 MOVE 6,L1086 MOVEM 6,0(15) MOVE 6,L1087 MOVEM 6,L1086 MOVE 6,0(15) MOVEM 6,L1087 PUSHJ 15,L1267 PUSHJ 15,L1268 MOVE 2,L1083 ADDI 2,1023 MOVE 1,L1084 AOS 1 PUSHJ 15,SYMFNC+420 PUSHJ 15,SYMFNC+419 SUB 1,L1258 MOVEM 1,L1258 ADDM 1,SYMVAL+415 CAMN 0,SYMVAL+416 JRST L1269 PUSHJ 15,L1270 L1269: MOVE 1,0 MOVEM 1,L1088 PUSHJ 15,SYMFNC+378 CAML 1,SYMVAL+417 JRST L1271 MOVE 3,0 MOVE 2,L1262 HRRZI 1,99 PUSHJ 15,SYMFNC+236 L1271: MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L1262: <4_30>+<1_18>+L1263 L1261: <4_30>+<1_18>+L1264 ; (!*ENTRY MARKANDCOPYFROMID EXPR 1) L1272: intern L1272 PUSH 15,1 ADDI 1,SYMNAM PUSHJ 15,L1273 MOVE 7,0(15) XMOVEI 6,SYMNAM(7) TLO 6,155648 HRRZI 7,27 DPB 7,6 XMOVEI 1,SYMPRP ADD 1,0(15) PUSHJ 15,L1273 XMOVEI 1,SYMVAL ADD 1,0(15) ADJSP 15,-1 JRST L1273 ; (!*ENTRY COPYFROMALLBASES EXPR 0) L1267: intern L1267 ADJSP 15,3 MOVEM 0,0(15) MOVEM 0,-1(15) HRRZI 1,128 PUSHJ 15,L1272 SETZM -2(15) L1276: MOVE 6,-2(15) CAILE 6,127 JRST L1277 MOVE 7,-2(15) LDB 1,L1274 CAIN 1,27 JRST L1278 MOVE 1,-2(15) PUSHJ 15,L1272 L1278: AOS -2(15) JRST L1276 L1277: SETZM -2(15) L1279: MOVE 6,-2(15) CAILE 6,8209 JRST L1280 MOVE 2,-2(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVEM 1,-1(15) JUMPLE 1,L1281 LDB 2,L1275 CAIN 2,27 JRST L1281 PUSHJ 15,L1272 L1281: AOS -2(15) JRST L1279 L1280: MOVE 6,L1255 MOVEM 6,-1(15) L1282: HRRZI 7,2 ADDM 7,-1(15) MOVE 1,SYMVAL+84 MOVE 6,-1(15) CAMG 6,L1256 JRST L1283 MOVE 1,0 L1283: CAMN 1,0 JRST L1284 MOVE 1,-1(15) PUSHJ 15,L1273 JRST L1282 L1284: MOVE 6,L1254 MOVEM 6,-2(15) L1285: MOVE 6,-2(15) CAMLE 6,L1257 JRST L1286 MOVE 1,-2(15) PUSHJ 15,L1273 AOS -2(15) JRST L1285 L1286: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1274: point 6,SYMNAM(7),5 L1275: point 6,SYMNAM(1),5 ; (!*ENTRY COPYFROMRANGE EXPR 2) L1287: intern L1287 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 1,-2(15) SETZM -3(15) L1288: MOVE 6,-2(15) CAMLE 6,-1(15) JRST L1289 MOVE 1,-2(15) PUSHJ 15,L1273 AOS -3(15) MOVE 1,-3(15) ADD 1,0(15) ADDI 1,0 MOVEM 1,-2(15) JRST L1288 L1289: MOVE 1,0 ADJSP 15,-4 POPJ 15,0 ; (!*ENTRY COPYFROMBASE EXPR 1) L1273: intern L1273 JRST L1290 ; (!*ENTRY COPYITEM EXPR 1) L1290: intern L1290 ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 6,0(1) MOVEM 6,-4(15) LDB 2,L1291 MOVEM 2,-1(15) JUMPLE 2,L1295 CAIGE 2,15 JRST L1296 L1295: CAIE 2,30 JRST L1297 CAMN 0,-4(15) JRST L1297 MOVE 3,-4(15) TLZ 3,258048 MOVEM 3,-2(15) LDB 4,L1292 CAIN 4,27 JRST L1297 MOVE 1,3 PUSHJ 15,L1272 L1297: MOVE 1,-4(15) MOVE 7,0(15) MOVEM 1,0(7) JRST L1298 L1296: MOVE 3,-4(15) TLZ 3,258048 MOVEM 3,-2(15) CAMGE 3,L1084 JRST L1299 CAMG 3,L1083 JRST L1300 L1299: MOVE 1,-4(15) JRST L1298 L1300: MOVE 6,0(3) MOVEM 6,-3(15) LDB 4,L1293 CAIE 4,27 JRST L1301 MOVE 5,-3(15) TLZ 5,258048 DPB 2,L1294 MOVEM 5,0(1) MOVE 1,5 JRST L1298 L1301: ADJSP 15,-5 JRST L1302 L1298: ADJSP 15,-5 POPJ 15,0 L1291: point 6,-4(15),5 L1292: point 6,SYMNAM(3),5 L1293: point 6,-3(15),5 L1294: point 6,5,5 L1309: 54 byte(7)85,110,101,120,112,101,99,116,101,100,32,116,97,103,32,37,119,32,102,111,117,110,100,32,97,116,32,37,119,32,100,117,114,105,110,103,32,103,97,114,98,97,103,101,32,99,111,108,108,101,99,116,105,111,110,0 ; (!*ENTRY COPYITEM1 EXPR 1) L1302: intern L1302 ADJSP 15,7 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 6,0(1) MOVEM 6,-5(15) LDB 1,L1303 CAIL 1,1 CAILE 1,10 JRST L1310 JRST @L1311-1(1) L1311: IFIW L1312 IFIW L1312 IFIW L1312 IFIW L1313 IFIW L1314 IFIW L1314 IFIW L1312 IFIW L1315 IFIW L1316 IFIW L1317 L1310: JRST L1314 L1316: MOVE 2,-5(15) MOVE 2,0(2) MOVEM 2,-3(15) HRRZI 1,2 PUSHJ 15,SYMFNC+379 MOVE 3,1 MOVEM 3,-1(15) TLZ 3,258048 TLO 3,110592 MOVE 7,-5(15) MOVEM 3,0(7) MOVE 2,-1(15) TLZ 2,258048 TLO 2,36864 MOVE 7,0(15) MOVEM 2,0(7) MOVE 7,-1(15) MOVE 6,-3(15) MOVEM 6,0(7) MOVE 4,-5(15) MOVE 4,1(4) MOVE 7,-1(15) MOVEM 4,1(7) SETZM 1 ADD 1,-1(15) PUSHJ 15,L1290 HRRZI 1,1 ADD 1,-1(15) ADJSP 15,-7 JRST L1290 L1313: MOVE 1,-5(15) PUSHJ 15,SYMFNC+395 MOVE 3,-5(15) TLZ 3,258048 MOVE 2,1 MOVEM 2,-1(15) TLZ 2,258048 TLO 2,110592 MOVEM 2,0(3) MOVE 1,-1(15) MOVE 7,0(15) MOVEM 1,0(7) JRST L1318 L1315: MOVE 2,-5(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 6,0(2) LDB 3,L1304 TDNE 3,L1305 TDO 3,L1306 MOVEM 3,-2(15) MOVE 1,3 PUSHJ 15,SYMFNC+142 MOVE 2,1 MOVEM 2,-3(15) TLZ 2,258048 TLO 2,110592 MOVE 7,-4(15) MOVEM 2,0(7) MOVEM 0,-6(15) SETZM -6(15) L1319: MOVE 6,-6(15) CAMG 6,-2(15) JRST L1320 SETZM 1 JRST L1321 L1320: MOVE 2,-6(15) ADD 2,-3(15) MOVE 3,-6(15) ADD 3,-4(15) MOVE 6,1(3) MOVEM 6,1(2) HRRZI 1,1 ADDM 2,1 PUSHJ 15,L1290 AOS -6(15) JRST L1319 L1321: MOVE 1,-3(15) TLZ 1,258048 TLO 1,32768 MOVE 7,0(15) MOVEM 1,0(7) JRST L1318 L1317: MOVE 2,-5(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 6,0(2) LDB 3,L1304 TDNE 3,L1305 TDO 3,L1306 MOVEM 3,-2(15) MOVE 1,3 PUSHJ 15,SYMFNC+142 MOVE 2,1 MOVEM 2,-3(15) TLZ 2,258048 TLO 2,110592 MOVE 7,-4(15) MOVEM 2,0(7) MOVEM 0,-6(15) SETZM -6(15) L1322: MOVE 6,-6(15) CAMG 6,-2(15) JRST L1323 SETZM 1 JRST L1324 L1323: MOVE 2,-6(15) ADD 2,-3(15) MOVE 3,-6(15) ADD 3,-4(15) MOVE 6,1(3) MOVEM 6,1(2) HRRZI 1,1 ADDM 2,1 PUSHJ 15,L1290 AOS -6(15) JRST L1322 L1324: MOVE 1,-3(15) TLZ 1,258048 TLO 1,40960 MOVE 7,0(15) MOVEM 1,0(7) JRST L1318 L1312: MOVEM 1,-3(15) MOVE 1,-5(15) PUSHJ 15,SYMFNC+400 MOVE 3,-5(15) TLZ 3,258048 MOVE 2,1 MOVEM 2,-1(15) TLZ 2,258048 TLO 2,110592 MOVEM 2,0(3) MOVE 1,-1(15) MOVE 6,-3(15) DPB 6,L1307 MOVE 7,0(15) MOVEM 1,0(7) JRST L1318 L1314: MOVE 3,-5(15) TLZ 3,258048 MOVE 2,1 MOVE 1,L1308 PUSHJ 15,SYMFNC+155 ADJSP 15,-7 JRST SYMFNC+380 L1318: ADJSP 15,-7 POPJ 15,0 L1303: point 6,-5(15),5 L1304: point 30,6,35 L1305: 536870912 L1306: -536870912 L1307: point 6,1,5 L1308: <4_30>+<1_18>+L1309 ; (!*ENTRY MAKEIDFREELIST EXPR 0) L1268: intern L1268 MOVE 3,0 SETZM 2 L1327: CAILE 2,128 JRST L1328 XMOVEI 6,SYMNAM(2) TLO 6,155648 HRRZI 7,4 DPB 7,6 AOS 2 JRST L1327 L1328: HRRZI 3,129 L1329: LDB 1,L1325 CAIE 1,27 JRST L1330 CAILE 3,8000 JRST L1330 XMOVEI 6,SYMNAM(3) TLO 6,155648 HRRZI 7,4 DPB 7,6 AOS 3 JRST L1329 L1330: CAIGE 3,8000 JRST L1331 SETZM L0001 JRST L1332 L1331: MOVEM 3,L0001 L1332: MOVE 1,3 AOS 1 MOVE 2,1 L1333: CAILE 2,8000 JRST L1334 LDB 1,L1326 CAIE 1,27 JRST L1335 XMOVEI 6,SYMNAM(2) TLO 6,155648 HRRZI 7,4 DPB 7,6 JRST L1336 L1335: MOVEM 2,SYMNAM(3) MOVE 3,2 L1336: AOS 2 JRST L1333 L1334: SETZM SYMNAM(3) MOVE 1,0 POPJ 15,0 L1325: point 6,SYMNAM(3),5 L1326: point 6,SYMNAM(2),5 L1338: 43 byte(7)42,42,42,32,71,67,32,37,119,58,32,116,105,109,101,32,37,100,32,109,115,44,32,37,100,32,114,101,99,111,118,101,114,101,100,44,32,37,100,32,102,114,101,101,0 ; (!*ENTRY GCSTATS EXPR 0) L1270: intern L1270 ADJSP 15,1 HRRZI 2,1 MOVE 1,L1259 ADD 1,L1081 SUB 1,L1080 IDIV 1,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+378 MOVE 5,1 MOVE 4,0(15) MOVE 3,L1258 MOVE 2,SYMVAL+414 MOVE 1,L1337 ADJSP 15,-1 JRST SYMFNC+418 L1337: <4_30>+<1_18>+L1338 end |
Added psl-1983/3-1/kernel/20/alloc.rel version [2cf5b09f08].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/allocators.red version [e356fa2f72].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ALLOCATORS.RED - Low level storage management % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <SWANSON.TEST>ALLOCATORS.UPD.2, 3-Apr-83 09:57:03, Edit by SWANSON % Added changes required to fit Ext-20 model % <PSL.KERNEL>ALLOCATORS.RED.7, 23-Mar-83 11:35:37, Edit by KESSLER % Added OldHeapTrapBound to exported WVars, so we can update the heap trap % bound upon switch. % Edit by Cris Perdue, 16 Feb 1983 1834-PST % Pre-GC trap, known-free-space fns % <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE % Added GtEVect on SysLisp; external WArray BPS, Heap, Heap2; CommentOutCode << % For the compacting GC exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], HeapTrapBound = &Heap[HeapSize]; % Value of HeapLast for trap >>; exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], % end of active heap OldHeapLast, OldHeapLowerBound = &Heap2[0], OldHeapUpperBound = &Heap2[HeapSize], HeapTrapBound = &Heap[HeapSize], % Value of HeapLast for trap OldHeapTrapBound = &Heap2[HeapSize]; >>); exported WVar HeapTrapped = NIL; % Boolean: trap since last GC? compiletime flag('(GtHeap1), 'InternalFunction); syslsp procedure Known!-Free!-Space; MkInt((HeapUpperBound - HeapLast)/AddressingUnitsPerItem); syslsp procedure GtHEAP N; %. get heap block of N words if null N then known!-free!-space() else GtHeap1(N, NIL); syslsp procedure GtHeap1(N, LastTryP); begin scalar PrevLast; PrevLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapTrapBound then if HeapLast > HeapUpperBound then << HeapLast := PrevLast; if LastTryP then FatalError "Heap space exhausted" else << !%Reclaim(); return GtHeap1(N, T) >> >> else %% From one GC to the next there can be at most 1 GC trap, %% done the first time space gets "low". %Reclaim resets %% HeapTrapped to NIL. if HeapTrapped = NIL then << HeapTrapped := T; GC!-Trap!-Level() >>; return PrevLast end; syslsp procedure GC!-Trap!-Level; MkInt (HeapUpperBound - HeapTrapBound)/AddressingUnitsPerItem; syslsp procedure Set!-GC!-Trap!-Level N; << if not IntP(N) then NonIntegerError(N, 'Set!-GC!-Trap!-Level); N := IntInf N; HeapTrapBound := HeapUpperBound - N*AddressingUnitsPerItem; T >>; syslsp procedure DelHeap(LowPointer, HighPointer); if HighPointer eq HeapLast then HeapLast := LowPointer; syslsp procedure GtSTR N; %. Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtConstSTR N; %. allocate un-collected string for print name begin scalar S, NW; % same as GtSTR, but uses BPS, not heap S := GtBPS((NW := STRPack N) + 1); @S := N; S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtHalfWords N; %. Allocate space for N halfwords begin scalar S, NW; S := GtHEAP((NW := HalfWordPack N) + 1); @S := MkItem(HHalfWords, N); return S; end; syslsp procedure GtVECT N; %. Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; Putd('GtEvect,'expr,cdr getd 'GtVect); syslsp procedure GtWRDS N; %. Allocate space for N untraced words begin scalar W; W := GtHEAP(WRDPack N + 1); @W := MkItem(HWRDS, N); return W; end; syslsp procedure GtFIXN(); %. allocate space for a fixnum begin scalar W; W := GtHEAP(WRDPack 0 + 1); @W := MkItem(HWRDS, 0); return W; end; syslsp procedure GtFLTN(); %. allocate space for a float begin scalar W; W := GtHEAP(WRDPack 1 + 1); @W := MkItem(HWRDS, 1); return W; end; % NextSymbol and SymbolTableSize are globally declared syslsp procedure GtID(); %. Allocate a new ID % % IDs are allocated as a linked free list through the SymNam cell, % with a 0 to indicate the end of the list. % begin scalar U; if NextSymbol = 0 then << Reclaim(); if NextSymbol = 0 then return FatalError "Ran out of ID space" >>; U := NextSymbol; NextSymbol := SymNam U; return U; end; external WVar NextBPS, LastBPS; syslsp procedure GtBPS N; %. Allocate N words for binary code begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GTBPS NIL returns # left B := NextBPS; NextBPS := NextBPS + N*AddressingUnitsPerItem; return if NextBPS > LastBPS then StdError '"Ran out of binary program space" else B; end; syslsp procedure DelBPS(Bottom, Top); %. Return space to BPS if NextBPS eq Top then NextBPS := Bottom; syslsp procedure GtWArray N; %. Allocate N words for WVar/WArray/WString begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GtWArray NIL returns # left B := LastBPS - N*AddressingUnitsPerItem; return if NextBPS > B then StdError '"Ran out of WArray space" else LastBPS := B; end; syslsp procedure DelWArray(Bottom, Top); %. Return space for WArray if LastBPS eq Bottom then LastBPS := Top; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/apply-lap.red version [242bc780b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % APPLY-LAP.RED - LAP support for EVAL and APPLY % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % 25-May-1983 Mark R. Swanson % Changes to support extended addressing; mostly clearing instruction field % of entries from SYMFNC table % <PSL.NEW>APPLY-LAP.RED.2, 9-Dec-82 18:13:02, Edit by PERDUE % Modified UndefinedFunction to make it continuable CompileTime flag('(FastLambdaApply), 'InternalFunction); on SysLisp; external WVar BndStkPtr, BndStkUpperBound; % TAG( CodeApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeApply expr 2) %. CodeApply(CodePointer, ArgList) % % r1 is code pointer, r2 is list of arguments % (!*field (reg t1) (reg 1) 12 24) % make it a local address (!*MOVE (reg 2) (reg t2)) (!*MOVE (WConst 1) (reg t3)) Loop (!*JUMPNOTTYPE (MEMORY (REG T1) (WConst 0)) (reg t2) PAIR) % jump to code if list is exhauseted (!*MOVE (CAR (reg t2)) (reg t4)) (!*MOVE (reg t4) (MEMORY (reg t3) 0)) % load argument register (!*MOVE (CDR (reg t2)) (reg t2)) (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % skip if neq MaxRegs+1 (!*MOVE (WConst ArgumentBlock) (reg t3)) % else switch to extra args (!*JUMPWLEQ (Label Loop) (reg t3) (WConst (plus2 9 (WConst ArgumentBlock)))) (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( CodeEvalApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeEvalApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := Eval car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeEvalApply expr 2) %. CodeApply(CodePointer, EvLis Args) % % r1 is code pointer, r2 is list of arguments to be evaled % (!*PUSH (reg 1)) % code pointer goes on the bottom (!*PUSH (WConst 0)) % then arg count Loop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label Done) (reg 2) PAIR) (!*JUMPWLESSP (Label ArgOverflow) (frame 1) (WConst -15)) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 2)) % save the cdr (!*CALL Eval) % eval the car (!*POP (reg 2)) % grab the list in r2 again (!*POP (reg 3)) % get count in r3 (!*WDIFFERENCE (reg 3) (WConst 1)) % decrement count (!*PUSH (reg 1)) % push the evaled arg (!*PUSH (reg 3)) % and the decremented count (!*JUMP (Label Loop)) Done (!*POP (reg 3)) % count in r3, == -no. of args to pop (!*JUMP (MEMORY (reg 3) (Label ZeroArgs))) % indexed jump (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 9)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 8)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 7)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 6)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 5)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 4)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 3)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 2)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 1)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 0)) (WConst 0))) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) ZeroArgs (!*POP (reg t1)) % code pointer in (reg t1) (!*field (reg t1) (reg t1) 12 24) % isolate just local addr bits (!*JUMP (MEMORY (reg t1) (WConst 0))) % jump to address ArgOverflow (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( BindEval ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure BindEval(Formals, Args); % begin scalar N; % N := 0; % while PairP Args and PairP Formals do % << N := N + 1; % Push Eval car ArgList; % Push car Formals; % ArgList := cdr ArgList >>; % if PairP Args or PairP Formals then return -1; % for I := 1 step 1 until N do % LBind1(Pop(), Pop()); % return N; % end; lap '((!*entry BindEval expr 2) %. BindEval(FormalsList, ArgsToBeEvaledList); % % r1 is list of formals, r2 is list of arguments to be evaled % (!*PUSH (WConst 0)) % count on the bottom (!*MOVE (WConst 0) (reg 4)) (!*MOVE (reg 1) (reg 3)) % shift arg1 to r3 EvalLoop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label DoneEval) (reg 2) PAIR) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 3)) % save the formals (!*PUSH (reg 2)) % save the rest of args (!*CALL Eval) % eval the car (!*POP (reg 2)) % save then rest of arglist (!*POP (reg 3)) % and the rest of formals (!*POP (reg 4)) % and the count (!*JUMPNOTTYPE (Label ReturnError) (reg 3) PAIR) % if it's not a pair, then error (!*WPLUS2 (reg 4) (WConst 1)) % increment the count (!*MOVE (CAR (reg 3)) (reg 5)) (!*MOVE (CDR (reg 3)) (reg 3)) (!*PUSH (reg 1)) % push the evaluated argument (!*PUSH (reg 5)) % and next formal (!*PUSH (reg 4)) % and new count (!*JUMP (Label EvalLoop)) ReturnError (!*WSHIFT (reg 4) (WConst 1)) % multiply count by 2 (hrl (reg 4) (reg 4)) % in both halves (sub (reg st) (reg 4)) % move the stack ptr back (!*MOVE (WConst -1) (reg 1)) % return -1 as error indicator (!*EXIT 0) DoneEval (!*DEALLOC 1) % removed saved values at top of stack (!*JUMPTYPE (Label ReturnError) (reg 3) PAIR) % if more formals, error (!*MOVE (reg 4) (reg 3)) % r3 gets decremented, r4 saved for return BindLoop (!*JUMPEQ (Label NormalReturn) (reg 3) (WConst 0)) % if count is zero, then return (!*POP (reg 1)) % pop ID to bind (!*POP (reg 2)) % and value (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*CALL LBind1) (!*POP (reg 4)) (!*POP (reg 3)) (soja (reg 3) BindLoop) NormalReturn (!*MOVE (reg 4) (reg 1)) % return count (!*EXIT 0) ); % TAG( CompiledCallingInterpreted ) % This is pretty gross, but it is essentially the same as LambdaApply, taking % values from the argument registers instead of a list. % if this could be written in Syslisp, it would look something like this: % syslsp procedure CompiledCallingInterpreted IDOfFunction; % begin scalar LForm, LArgs, N, Result; % LForm := get(IDOfFunction, '!*LambdaLink); % LArgs := cadr LForm; % LForm := cddr LForm; % N := 1; % while PairP LArgs do % << LBind1(car LArgs, ArgumentRegister[N]; % LArgs := cdr LArgs; % N := N + 1 >>; % Result := EvProgN LForm; % UnBindN(N - 1); % return Result; % end; lap '((!*entry CompiledCallingInterpreted expr 0) %. link for lambda % % called by JSP T5, from function cell % (!*MOVE (reg t5) (reg t1)) (!*WDIFFERENCE (reg t1) (WConst (plus2 (WConst SymFnc) 1))) (!*MKITEM (reg t1) (WConst BtrTag)) (!*PUSH (reg t1)) % make stack mark for btrace (hrrz (reg t1)(reg t1)) % discard extraneous left half (!*MOVE (MEMORY (reg t1) (WConst SymPrp)) (reg t1)) % load prop list LoopFindProp (!*JUMPNOTTYPE (Label PropNotFound) (reg t1) PAIR) (!*MOVE (CAR (reg t1)) (reg t2)) % get car of prop list (!*MOVE (CDR (reg t1)) (reg t1)) % cdr down (!*JUMPNOTTYPE (Label LoopFindProp) (reg t2) PAIR) (!*MOVE (CAR (reg t2)) (reg t3)) % its a pair, look at car (!*JUMPNOTEQ (Label LoopFindProp) (reg t3) '!*LambdaLink) (!*MOVE (CDR (reg t2)) (reg t2)) % yes, get lambda form (!*entry FastLambdaApply expr 0) % called from FastApply (!*MOVE (CDR (reg t2)) (reg t2)) % get cdr of lambda form (!*MOVE (CDR (reg t2)) (reg t1)) % save cddr in (reg t1) (!*MOVE (CAR (reg t2)) (reg t2)) % cadr of lambda == arg list (!*MOVE (WConst 1) (reg t3)) % pointer to arg register in t3 (!*MOVE (WVar BndStkPtr) (reg t4)) % binding stack pointer in t4 (!*PUSH (reg t4)) % save it on the stack LoopBindingFormals (!*JUMPNOTTYPE (Label DoneBindingFormals) (reg t2) PAIR) (!*WPLUS2 (reg t4) (WConst 2)) % adjust binding stack pointer up 2 (caml (reg t4) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (!*MOVE (CAR (reg t2)) (reg t5)) % get formal in t5 (hrrzm (reg t5) (Indexed (reg t4) -1)) % store ID number in BndStk (!*MOVE (MEMORY (reg t5) (WArray SymVal)) (reg t6)) % get old value (!*MOVE (reg t6) (MEMORY (reg t4) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t6)) % get reg value in t6 (!*MOVE (reg t6) (MEMORY (reg t5) (WConst SymVal))) % put in value cell (!*MOVE (CDR (reg t2)) (reg t2)) % cdr down argument list (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % Go to extra args? (movei (reg t3) (WArray ArgumentBlock)) % Yes (!*JUMP (Label LoopBindingFormals)) % No DoneBindingFormals (!*MOVE (reg t4) (WVar BndStkPtr)) % store binding stack (!*MOVE (reg t1) (reg 1)) % get cddr of lambda form to eval (!*CALL EvProgN) % implicit progn (exch (reg 1) (Indexed (reg st) 0)) % save result, get old bind stk ptr (!*CALL RestoreEnvironment) (!*POP (reg 1)) % restore old bindings and pickup value (!*EXIT 1) % throw away backtrace mark and return PropNotFound (!*MOVE (QUOTE "Internal error in function calling mechanism; consult a wizard") (reg 1)) (!*JCALL StdError) ); % TAG( FastApply ) lap '((!*entry FastApply expr 0) %. Apply with arguments loaded % % Called with arguments in the registers and functional form in (reg t1) % (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*FIELD (reg t1) (reg t1) 12 24) % make it a local address (!*JUMPEQ (MEMORY (reg t1) (WConst SymFnc)) (reg t2) (WConst ID)) (!*JUMPEQ (MEMORY (reg t1) (WConst 0)) (reg t2) (WConst CODE)) (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR)) (!*MOVE (CAR (reg t1)) (reg t2)) (!*JUMPNOTEQ IllegalFunctionalForm (reg t2) (QUOTE LAMBDA)) (!*MOVE (reg t1) (reg t2)) % put lambda form in (reg t2) (!*PUSH '()) % align stack (!*JCALL FastLambdaApply) IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form %r in Apply") (reg 1)) (!*MOVE (reg t1) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); % TAG( UndefinedFunction ) lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code % % also called by JSP T5, % (!*WDIFFERENCE (reg t5) (wconst 1)) % T5 now points to the function entry slot of the atom that % is undefined as a function. % We will push the entry address onto the stack and transfer % to it by a POPJ at the end of this routine. (!*PUSH (reg t5)) (!*PUSH (reg 1)) % Save all the regs (including fakes) (args) (!*PUSH (reg 2)) (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*WDIFFERENCE (reg t5) (WConst SymFnc)) (!*MKITEM (reg t5) (WConst ID)) (!*MOVE (reg t5) (reg 2)) (!*MOVE (QUOTE "Undefined function %r called from compiled code") (reg 1)) (!*CALL BldMsg) (!*MOVE (reg 1) (reg 2)) (!*MOVE (WConst 0) (reg 1)) (!*MOVE (reg NIL) (reg 3)) (!*CALL ContinuableError) (!*POP (reg 15)) % Restore all those possible arguments (!*POP (reg 14)) (!*POP (reg 13)) (!*POP (reg 12)) (!*POP (reg 11)) (!*POP (reg 10)) (!*POP (reg 9)) (!*POP (reg 8)) (!*POP (reg 7)) (!*POP (reg 6)) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (!*EXIT 0) ); off SysLisp; END; |
Added psl-1983/3-1/kernel/20/arith.ctl version [8ab4b224c0].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "arith"; PathIn "arith.build"; ASMEnd; quit; compile arith.mac, darith.mac |
Added psl-1983/3-1/kernel/20/arith.init version [a7ffc6f8bf].
Added psl-1983/3-1/kernel/20/arith.log version [37387adee5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:34:15 BATCON Version 104(4133) GLXLIB Version 1(527) Job ARITH Req #477 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1734 Input from => PS:<PSL.KERNEL.20.EXT>ARITH.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>ARITH.LOG 9:34:16 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:34:16 MONTR @SET TIME-LIMIT 600 9:34:16 MONTR @LOGIN KESSLER SMALL 9:34:19 MONTR Job 12 on TTY224 8-Jun-83 09:34:19 9:34:19 MONTR Previous login at 8-Jun-83 09:32:11 9:34:20 MONTR There is 1 other job logged in as user KESSLER 9:34:29 MONTR @ 9:34:29 MONTR [PS Mounted] 9:34:29 MONTR 9:34:29 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:34:29 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:34:30 MONTR @S:EX-DEC20-CROSS.EXE 9:34:32 USER [20] ASMOut "arith"; 9:34:34 USER ASMOUT: IN files; or type in expressions 9:34:34 USER When all done execute ASMEND; 9:34:36 USER [21] PathIn "arith.build"; 9:34:37 USER % 9:34:37 USER % ARITH.BUILD - Files dealing with arithmetic 9:34:37 USER % 9:34:37 USER % Author: Eric Benson 9:34:37 USER % Symbolic Computation Group 9:34:37 USER % Computer Science Dept. 9:34:37 USER % University of Utah 9:34:38 USER % Date: 19 May 1982 9:34:38 USER % Copyright (c) 1982 University of Utah 9:34:38 USER % 9:34:38 USER 9:34:38 USER PathIn "arithmetic.red"$ % Lisp arithmetic functions 9:35:10 USER [22] ASMEnd; 9:35:10 USER *** Garbage collection starting 9:35:12 USER *** GC 9: time 1574 ms, 106103 recovered, 243208 free 9:35:20 USER 0 9:35:20 USER [23] quit; 9:35:20 MONTR @compile arith.mac, darith.mac 9:35:23 USER MACRO: .MAIN 9:35:28 USER MACRO: .MAIN 9:35:29 USER 9:35:29 USER EXIT 9:35:29 MONTR @ 9:35:30 MONTR Killed by OPERATOR, TTY 221 9:35:30 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:35:30 MONTR at 8-Jun-83 09:35:30, Used 0:00:34 in 0:01:10 |
Added psl-1983/3-1/kernel/20/arith.mac version [bcfdd1a9f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 ; (!*ENTRY TWOARGDISPATCH EXPR 2) L1341: intern L1341 LDB 4,L1339 LDB 3,L1340 JRST L1342 L1339: point 6,2,5 L1340: point 6,1,5 ; (!*ENTRY TWOARGDISPATCH1 EXPR 4) L1342: intern L1342 CAIE 3,63 JRST L1343 SETZM 3 L1343: CAIE 4,63 JRST L1344 SETZM 4 L1344: CAILE 3,3 JRST L1345 CAILE 4,3 JRST L1345 LSH 3,2 ADDM 3,4 POP 15,3 CAIL 4,0 CAILE 4,15 JRST L1346 JRST @L1347-0(4) L1347: IFIW L1348 IFIW L1349 IFIW L1350 IFIW L1351 IFIW L1352 IFIW L1353 IFIW L1350 IFIW L1354 IFIW L1350 IFIW L1350 IFIW L1350 IFIW L1350 IFIW L1355 IFIW L1356 IFIW L1350 IFIW L1357 L1346:L1350: JRST L1358 L1352: TLZ 1,258048 MOVE 1,1(1) MOVE 6,0(3) JRST 0(6) L1353: TLZ 1,258048 MOVE 1,1(1) L1349: TLZ 2,258048 MOVE 2,1(2) L1348: MOVE 6,0(3) JRST 0(6) L1354: TLZ 1,258048 MOVE 1,1(1) L1351: PUSH 15,3 PUSH 15,2 PUSHJ 15,L1359 POP 15,2 POP 15,3 MOVE 6,1(3) JRST 0(6) L1356: TLZ 2,258048 MOVE 2,1(2) L1355: PUSH 15,3 PUSH 15,1 MOVE 1,2 PUSHJ 15,L1359 MOVE 2,1 POP 15,1 POP 15,3 MOVE 6,1(3) JRST 0(6) L1357: MOVE 6,1(3) JRST 0(6) L1345: POP 15,3 JRST L1358 L1361: 33 byte(7)78,111,110,45,110,117,109,101,114,105,99,32,97,114,103,117,109,101,110,116,32,105,110,32,97,114,105,116,104,109,101,116,105,99,0 ; (!*ENTRY TWOARGERROR EXPR 3) L1358: intern L1358 PUSH 15,3 MOVE 3,2 MOVE 2,1 MOVE 1,0(15) MOVE 1,2(1) PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1360 HRRZI 1,99 ADJSP 15,-1 JRST SYMFNC+236 L1360: <4_30>+<1_18>+L1361 L1363: 33 byte(7)78,111,110,45,105,110,116,101,103,101,114,32,97,114,103,117,109,101,110,116,32,105,110,32,97,114,105,116,104,109,101,116,105,99,0 ; (!*ENTRY NONINTEGER2ERROR EXPR 3) L1364: intern L1364 PUSH 15,3 MOVE 3,2 MOVE 2,1 MOVE 1,0(15) MOVE 1,2(1) PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1362 HRRZI 1,99 ADJSP 15,-1 JRST SYMFNC+236 L1362: <4_30>+<1_18>+L1363 L1366: 33 byte(7)78,111,110,45,105,110,116,101,103,101,114,32,97,114,103,117,109,101,110,116,32,105,110,32,97,114,105,116,104,109,101,116,105,99,0 ; (!*ENTRY NONINTEGER1ERROR EXPR 2) L1367: intern L1367 PUSH 15,2 MOVE 2,1 MOVE 1,0(15) MOVE 1,2(1) PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L1365 HRRZI 1,99 ADJSP 15,-1 JRST SYMFNC+236 L1365: <4_30>+<1_18>+L1366 ; (!*ENTRY ONEARGDISPATCH EXPR 1) L1369: intern L1369 LDB 2,L1368 JRST L1370 L1368: point 6,1,5 ; (!*ENTRY ONEARGDISPATCH1 EXPR 2) L1370: intern L1370 CAIE 2,63 JRST L1371 SETZM 2 L1371: POP 15,3 CAIL 2,0 CAILE 2,3 JRST L1372 JRST @L1373-0(2) L1373: IFIW L1374 IFIW L1375 IFIW L1376 IFIW L1377 L1372:L1376: JRST L1378 L1375: TLZ 1,258048 MOVE 1,1(1) L1374: MOVE 6,0(3) JRST 0(6) L1377: MOVE 6,1(3) JRST 0(6) L1380: 33 byte(7)78,111,110,45,110,117,109,101,114,105,99,32,97,114,103,117,109,101,110,116,32,105,110,32,97,114,105,116,104,109,101,116,105,99,0 ; (!*ENTRY ONEARGERROR EXPR 3) L1378: intern L1378 MOVE 2,1 MOVE 1,2(3) PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L1379 HRRZI 1,99 JRST SYMFNC+236 L1379: <4_30>+<1_18>+L1380 ; (!*ENTRY ONEARGPREDICATEDISPATCH EXPR 1) L1382: intern L1382 LDB 2,L1381 JRST L1383 L1381: point 6,1,5 ; (!*ENTRY ONEARGPREDICATEDISPATCH1 EXPR 2) L1383: intern L1383 CAIE 2,63 JRST L1384 SETZM 2 L1384: POP 15,3 CAIL 2,0 CAILE 2,3 JRST L1385 JRST @L1386-0(2) L1386: IFIW L1387 IFIW L1388 IFIW L1389 IFIW L1390 L1385:L1389: MOVE 1,0 POPJ 15,0 L1388: TLZ 1,258048 MOVE 1,1(1) L1387: MOVE 6,0(3) JRST 0(6) L1390: MOVE 6,1(3) JRST 0(6) ; (!*ENTRY MAKEFIXNUM EXPR 1) L1391: intern L1391 ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+139 MOVEM 1,-1(15) MOVE 6,0(15) MOVEM 6,1(1) TLZ 1,258048 TLO 1,4096 ADJSP 15,-2 POPJ 15,0 L1393: 24 byte(7)66,105,103,110,117,109,115,32,110,111,116,32,121,101,116,32,115,117,112,112,111,114,116,101,100,0 ; (!*ENTRY BIGFLOATFIX EXPR 1) L1394: intern L1394 MOVE 1,L1392 JRST SYMFNC+156 L1392: <4_30>+<1_18>+L1393 0 ; (!*ENTRY RETURNNIL EXPR 0) L1395: intern L1395 MOVE 1,0 POPJ 15,0 1 ; (!*ENTRY RETURNFIRSTARG EXPR 1) L1396: intern L1396 POPJ 15,0 extern L1397 extern L1398 ; (!*ENTRY STATICINTFLOAT EXPR 1) L1359: intern L1359 MOVE 2,1 SETZM 1 ADDI 1,1+L1397 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) MOVE 1,L1398 POPJ 15,0 2 ; (!*ENTRY PLUS2 EXPR 2) PLUS2: intern PLUS2 PUSHJ 15,L1341 L1399 L1400 <30_30>+243 ; (!*ENTRY INTPLUS2 EXPR 2) L1399: intern L1399 MOVE 4,1 ADDM 2,4 MOVE 1,4 MOVE 3,1 MOVE 6,1 LDB 1,L1401 TDNE 1,L1402 TDO 1,L1403 CAMN 1,3 JRST L1404 MOVE 1,0 JRST L1405 L1404: MOVE 1,SYMVAL+84 L1405: CAMN 1,0 JRST L1406 MOVE 1,4 POPJ 15,0 L1406: MOVE 1,4 JRST L1391 L1401: point 31,6,35 L1402: 1073741824 L1403: -1073741824 ; (!*ENTRY FLOATPLUS2 EXPR 2) L1400: intern L1400 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 AOS 1 DMOVE 3,0(3) DFAD 3,0(2) DMOVEM 3,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY DIFFERENCE EXPR 2) L1407: intern L1407 PUSHJ 15,L1341 L1408 L1409 <30_30>+238 ; (!*ENTRY INTDIFFERENCE EXPR 2) L1408: intern L1408 MOVE 4,1 MOVN 1,2 ADDM 1,4 MOVE 1,4 MOVE 3,1 MOVE 6,1 LDB 1,L1410 TDNE 1,L1411 TDO 1,L1412 CAMN 1,3 JRST L1413 MOVE 1,0 JRST L1414 L1413: MOVE 1,SYMVAL+84 L1414: CAMN 1,0 JRST L1415 MOVE 1,4 POPJ 15,0 L1415: MOVE 1,4 JRST L1391 L1410: point 31,6,35 L1411: 1073741824 L1412: -1073741824 ; (!*ENTRY FLOATDIFFERENCE EXPR 2) L1409: intern L1409 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 AOS 1 DMOVE 4,0(2) DFSB 4,0(3) DMOVEM 4,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY TIMES2 EXPR 2) TIMES2: intern TIMES2 PUSHJ 15,L1341 L1416 L1417 <30_30>+240 ; (!*ENTRY INTTIMES2 EXPR 2) L1416: intern L1416 ADJSP 15,2 MOVEM 1,-1(15) MOVEM 2,0(15) MOVE 3,1 IMUL 3,2 MOVE 5,3 MOVE 1,3 MOVE 4,1 MOVE 6,1 LDB 1,L1418 TDNE 1,L1419 TDO 1,L1420 CAMN 1,4 JRST L1421 MOVE 1,0 JRST L1422 L1421: MOVE 1,SYMVAL+84 L1422: CAME 1,0 JRST L1423 MOVE 1,3 ADJSP 15,-2 JRST L1391 L1423: MOVE 1,3 ADJSP 15,-2 POPJ 15,0 L1418: point 31,6,35 L1419: 1073741824 L1420: -1073741824 ; (!*ENTRY FLOATTIMES2 EXPR 2) L1417: intern L1417 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 AOS 1 DMOVE 3,0(3) DFMP 3,0(2) DMOVEM 3,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY QUOTIENT EXPR 2) L1424: intern L1424 PUSHJ 15,L1341 L1425 L1426 <30_30>+242 L1432: 36 byte(7)65,116,116,101,109,112,116,32,116,111,32,100,105,118,105,100,101,32,98,121,32,122,101,114,111,32,105,110,32,81,117,111,116,105,101,110,116,0 ; (!*ENTRY INTQUOTIENT EXPR 2) L1425: intern L1425 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) JUMPN 2,L1433 PUSHJ 15,SYMFNC+234 MOVEM 1,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L1427 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1428 HRRZI 1,99 ADJSP 15,-4 JRST SYMFNC+236 L1433: IDIV 1,2 MOVEM 1,-2(15) MOVEM 1,-3(15) MOVE 6,1 LDB 1,L1429 TDNE 1,L1430 TDO 1,L1431 CAMN 1,-3(15) JRST L1434 MOVE 1,0 JRST L1435 L1434: MOVE 1,SYMVAL+84 L1435: CAME 1,0 JRST L1436 MOVE 1,-2(15) ADJSP 15,-4 JRST L1391 L1436: MOVE 1,-2(15) ADJSP 15,-4 POPJ 15,0 L1429: point 31,6,35 L1430: 1073741824 L1431: -1073741824 L1428: <4_30>+<1_18>+L1432 L1427: <30_30>+242 L1439: 36 byte(7)65,116,116,101,109,112,116,32,116,111,32,100,105,118,105,100,101,32,98,121,32,122,101,114,111,32,105,110,32,81,117,111,116,105,101,110,116,0 ; (!*ENTRY FLOATQUOTIENT EXPR 2) L1426: intern L1426 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVE 1,2 PUSHJ 15,L1440 CAMN 1,0 JRST L1441 MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L1437 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1438 HRRZI 1,99 ADJSP 15,-4 JRST SYMFNC+236 L1441: PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 AOS 1 DMOVE 4,0(2) DFDV 4,0(3) DMOVEM 4,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-4 POPJ 15,0 L1438: <4_30>+<1_18>+L1439 L1437: <30_30>+242 2 ; (!*ENTRY REMAINDER EXPR 2) L1442: intern L1442 PUSHJ 15,L1341 L1443 L1444 <30_30>+277 L1450: 37 byte(7)65,116,116,101,109,112,116,32,116,111,32,100,105,118,105,100,101,32,98,121,32,122,101,114,111,32,105,110,32,82,101,109,97,105,110,100,101,114,0 ; (!*ENTRY INTREMAINDER EXPR 2) L1443: intern L1443 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) JUMPN 2,L1451 PUSHJ 15,SYMFNC+234 MOVEM 1,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L1445 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1446 HRRZI 1,99 ADJSP 15,-4 JRST SYMFNC+236 L1451: IDIV 1,2 MOVE 1,2 MOVEM 1,-2(15) MOVEM 1,-3(15) MOVE 6,1 LDB 1,L1447 TDNE 1,L1448 TDO 1,L1449 CAMN 1,-3(15) JRST L1452 MOVE 1,0 JRST L1453 L1452: MOVE 1,SYMVAL+84 L1453: CAME 1,0 JRST L1454 MOVE 1,-2(15) ADJSP 15,-4 JRST L1391 L1454: MOVE 1,-2(15) ADJSP 15,-4 POPJ 15,0 L1447: point 31,6,35 L1448: 1073741824 L1449: -1073741824 L1446: <4_30>+<1_18>+L1450 L1445: <30_30>+277 ; (!*ENTRY FLOATREMAINDER EXPR 2) L1444: intern L1444 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 AOS 1 DMOVE 4,0(2) DFDV 4,0(3) DMOVEM 4,0(1) MOVE 3,-1(15) TLZ 3,258048 AOS 3 MOVE 2,-2(15) AOS 2 MOVE 1,2 DMOVE 3,0(3) DFMP 3,0(2) DMOVEM 3,0(1) MOVE 3,-2(15) AOS 3 MOVE 2,0(15) TLZ 2,258048 AOS 2 MOVE 1,3 DMOVE 4,0(2) DFSB 4,0(3) DMOVEM 4,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY LAND EXPR 2) LAND: intern LAND PUSHJ 15,L1341 L1455 L1364 <30_30>+423 ; (!*ENTRY INTLAND EXPR 2) L1455: intern L1455 AND 1,2 MOVE 4,1 MOVE 3,1 MOVE 6,1 LDB 1,L1456 TDNE 1,L1457 TDO 1,L1458 CAMN 1,3 JRST L1459 MOVE 1,0 JRST L1460 L1459: MOVE 1,SYMVAL+84 L1460: CAMN 1,0 JRST L1461 MOVE 1,4 POPJ 15,0 L1461: MOVE 1,4 JRST L1391 L1456: point 31,6,35 L1457: 1073741824 L1458: -1073741824 2 ; (!*ENTRY LOR EXPR 2) LOR: intern LOR PUSHJ 15,L1341 INTLOR L1364 <30_30>+424 ; (!*ENTRY INTLOR EXPR 2) INTLOR: intern INTLOR IOR 1,2 MOVE 4,1 MOVE 3,1 MOVE 6,1 LDB 1,L1462 TDNE 1,L1463 TDO 1,L1464 CAMN 1,3 JRST L1465 MOVE 1,0 JRST L1466 L1465: MOVE 1,SYMVAL+84 L1466: CAMN 1,0 JRST L1467 MOVE 1,4 POPJ 15,0 L1467: MOVE 1,4 JRST L1391 L1462: point 31,6,35 L1463: 1073741824 L1464: -1073741824 2 ; (!*ENTRY LXOR EXPR 2) LXOR: intern LXOR PUSHJ 15,L1341 L1468 L1364 <30_30>+425 ; (!*ENTRY INTLXOR EXPR 2) L1468: intern L1468 XOR 1,2 MOVE 4,1 MOVE 3,1 MOVE 6,1 LDB 1,L1469 TDNE 1,L1470 TDO 1,L1471 CAMN 1,3 JRST L1472 MOVE 1,0 JRST L1473 L1472: MOVE 1,SYMVAL+84 L1473: CAMN 1,0 JRST L1474 MOVE 1,4 POPJ 15,0 L1474: MOVE 1,4 JRST L1391 L1469: point 31,6,35 L1470: 1073741824 L1471: -1073741824 2 ; (!*ENTRY LSHIFT EXPR 2) LSHIFT: intern LSHIFT PUSHJ 15,L1341 L1475 L1364 <30_30>+426 ; (!*ENTRY INTLSHIFT EXPR 2) L1475: intern L1475 ADJSP 15,2 MOVEM 1,-1(15) MOVEM 2,0(15) MOVE 3,1 LSH 3,0(2) MOVE 5,3 MOVE 1,3 MOVE 4,1 MOVE 6,1 LDB 1,L1476 TDNE 1,L1477 TDO 1,L1478 CAMN 1,4 JRST L1479 MOVE 1,0 JRST L1480 L1479: MOVE 1,SYMVAL+84 L1480: CAME 1,0 JRST L1481 MOVE 1,3 ADJSP 15,-2 JRST L1391 L1481: MOVE 1,3 ADJSP 15,-2 POPJ 15,0 L1476: point 31,6,35 L1477: 1073741824 L1478: -1073741824 2 ; (!*ENTRY GREATERP EXPR 2) L1482: intern L1482 PUSHJ 15,L1341 L1483 L1484 <30_30>+237 ; (!*ENTRY INTGREATERP EXPR 2) L1483: intern L1483 CAMLE 1,2 JRST L1485 MOVE 1,0 POPJ 15,0 L1485: MOVE 1,SYMVAL+84 POPJ 15,0 ; (!*ENTRY FLOATGREATERP EXPR 2) L1484: intern L1484 TLZ 2,258048 AOS 2 TLZ 1,258048 AOS 1 DMOVE 3,0(2) CAMGE 3,0(1) JRST L1486 CAMN 3,0(1) CAML 4,1(1) MOVE 1,0 L1486: CAMN 1,0 JRST L1487 MOVE 1,SYMVAL+84 L1487: POPJ 15,0 2 ; (!*ENTRY LESSP EXPR 2) LESSP: intern LESSP PUSHJ 15,L1341 L1488 L1489 <30_30>+282 ; (!*ENTRY INTLESSP EXPR 2) L1488: intern L1488 CAMGE 1,2 JRST L1490 MOVE 1,0 POPJ 15,0 L1490: MOVE 1,SYMVAL+84 POPJ 15,0 ; (!*ENTRY FLOATLESSP EXPR 2) L1489: intern L1489 TLZ 2,258048 AOS 2 TLZ 1,258048 AOS 1 DMOVE 3,0(2) CAMLE 3,0(1) JRST L1491 CAMN 3,0(1) CAMG 4,1(1) MOVE 1,0 L1491: CAMN 1,0 JRST L1492 MOVE 1,SYMVAL+84 L1492: POPJ 15,0 1 ; (!*ENTRY ADD1 EXPR 1) ADD1: intern ADD1 PUSHJ 15,L1369 L1493 L1494 <30_30>+241 ; (!*ENTRY INTADD1 EXPR 1) L1493: intern L1493 MOVE 3,1 AOS 3 MOVE 1,3 MOVE 2,1 MOVE 6,1 LDB 1,L1495 TDNE 1,L1496 TDO 1,L1497 CAMN 1,2 JRST L1498 MOVE 1,0 JRST L1499 L1498: MOVE 1,SYMVAL+84 L1499: CAMN 1,0 JRST L1500 MOVE 1,3 POPJ 15,0 L1500: MOVE 1,3 JRST L1391 L1495: point 31,6,35 L1496: 1073741824 L1497: -1073741824 L1502: 1 1.0 0 ; (!*ENTRY FLOATADD1 EXPR 1) L1494: intern L1494 MOVE 2,L1501 JRST L1400 L1501: <3_30>+<1_18>+L1502 1 ; (!*ENTRY SUB1 EXPR 1) SUB1: intern SUB1 PUSHJ 15,L1369 L1503 L1504 <30_30>+349 ; (!*ENTRY INTSUB1 EXPR 1) L1503: intern L1503 MOVE 3,1 SOS 3 MOVE 1,3 MOVE 2,1 MOVE 6,1 LDB 1,L1505 TDNE 1,L1506 TDO 1,L1507 CAMN 1,2 JRST L1508 MOVE 1,0 JRST L1509 L1508: MOVE 1,SYMVAL+84 L1509: CAMN 1,0 JRST L1510 MOVE 1,3 POPJ 15,0 L1510: MOVE 1,3 JRST L1391 L1505: point 31,6,35 L1506: 1073741824 L1507: -1073741824 L1512: 1 1.0 0 ; (!*ENTRY FLOATSUB1 EXPR 1) L1504: intern L1504 MOVE 2,L1511 JRST L1409 L1511: <3_30>+<1_18>+L1512 1 ; (!*ENTRY LNOT EXPR 1) LNOT: intern LNOT PUSHJ 15,L1369 L1513 L1367 <30_30>+428 ; (!*ENTRY INTLNOT EXPR 1) L1513: intern L1513 SETCMM 1 MOVE 3,1 MOVE 2,1 MOVE 6,1 LDB 1,L1514 TDNE 1,L1515 TDO 1,L1516 CAMN 1,2 JRST L1517 MOVE 1,0 JRST L1518 L1517: MOVE 1,SYMVAL+84 L1518: CAMN 1,0 JRST L1519 MOVE 1,3 POPJ 15,0 L1519: MOVE 1,3 JRST L1391 L1514: point 31,6,35 L1515: 1073741824 L1516: -1073741824 1 ; (!*ENTRY MINUS EXPR 1) MINUS: intern MINUS PUSHJ 15,L1369 L1520 L1521 <30_30>+274 ; (!*ENTRY INTMINUS EXPR 1) L1520: intern L1520 MOVNS 1 MOVE 3,1 MOVE 2,1 MOVE 6,1 LDB 1,L1522 TDNE 1,L1523 TDO 1,L1524 CAMN 1,2 JRST L1525 MOVE 1,0 JRST L1526 L1525: MOVE 1,SYMVAL+84 L1526: CAMN 1,0 JRST L1527 MOVE 1,3 POPJ 15,0 L1527: MOVE 1,3 JRST L1391 L1522: point 31,6,35 L1523: 1073741824 L1524: -1073741824 L1529: 1 0.0 0 ; (!*ENTRY FLOATMINUS EXPR 1) L1521: intern L1521 MOVE 2,1 MOVE 1,L1528 JRST L1409 L1528: <3_30>+<1_18>+L1529 1 ; (!*ENTRY FIX EXPR 1) FIX: intern FIX PUSHJ 15,L1369 L1396 L1530 <30_30>+429 ; (!*ENTRY FLOATFIX EXPR 1) L1530: intern L1530 ADJSP 15,3 MOVEM 1,0(15) TLZ 1,258048 AOS 1 FIX 1,0(1) MOVEM 1,-1(15) MOVEM 1,-2(15) MOVE 6,1 LDB 1,L1531 TDNE 1,L1532 TDO 1,L1533 CAMN 1,-2(15) JRST L1534 MOVE 1,0 JRST L1535 L1534: MOVE 1,SYMVAL+84 L1535: CAMN 1,0 JRST L1536 MOVE 1,-1(15) JRST L1537 L1536: MOVE 1,-1(15) ADJSP 15,-3 JRST L1391 L1537: ADJSP 15,-3 POPJ 15,0 L1531: point 31,6,35 L1532: 1073741824 L1533: -1073741824 1 ; (!*ENTRY FLOAT EXPR 1) FLOAT: intern FLOAT PUSHJ 15,L1369 L1538 L1396 <30_30>+430 ; (!*ENTRY FLOATINTARG EXPR 1) L1538: intern L1538 ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+388 MOVEM 1,-1(15) MOVE 2,0(15) AOS 1 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) MOVE 1,-1(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY MINUSP EXPR 1) MINUSP: intern MINUSP PUSHJ 15,L1382 L1539 L1540 <30_30>+239 ; (!*ENTRY INTMINUSP EXPR 1) L1539: intern L1539 JUMPL 1,L1541 MOVE 1,0 POPJ 15,0 L1541: MOVE 1,SYMVAL+84 POPJ 15,0 L1543: 1 0.0 0 ; (!*ENTRY FLOATMINUSP EXPR 1) L1540: intern L1540 MOVE 2,L1542 JRST L1489 L1542: <3_30>+<1_18>+L1543 1 ; (!*ENTRY ZEROP EXPR 1) ZEROP: intern ZEROP PUSHJ 15,L1382 L1544 L1440 <30_30>+276 ; (!*ENTRY INTZEROP EXPR 1) L1544: intern L1544 JUMPE 1,L1545 MOVE 1,0 POPJ 15,0 L1545: MOVE 1,SYMVAL+84 POPJ 15,0 L1547: 1 0.0 0 ; (!*ENTRY FLOATZEROP EXPR 1) L1440: intern L1440 MOVE 2,L1546 JRST SYMFNC+194 L1546: <3_30>+<1_18>+L1547 1 ; (!*ENTRY ONEP EXPR 1) ONEP: intern ONEP PUSHJ 15,L1382 L1548 L1549 <30_30>+431 ; (!*ENTRY INTONEP EXPR 1) L1548: intern L1548 CAIN 1,1 JRST L1550 MOVE 1,0 POPJ 15,0 L1550: MOVE 1,SYMVAL+84 POPJ 15,0 L1552: 1 1.0 0 ; (!*ENTRY FLOATONEP EXPR 1) L1549: intern L1549 MOVE 2,L1551 JRST SYMFNC+194 L1551: <3_30>+<1_18>+L1552 end |
Added psl-1983/3-1/kernel/20/arith.rel version [c9a3d760ff].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/bare-psl.sym version [14527ad530].
> > > > | 1 2 3 4 | (setq OrderedIDList!* (NCons NIL)) (setq UncompiledExpressions!* (NCons NIL)) (setq ToBeCompiledExpressions!* (NCons NIL)) (setq NextIDNumber!* 129) |
Added psl-1983/3-1/kernel/20/copiers.red version [ac826fe467].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % COPIERS.RED - Functions for copying various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % 6-May-83 Mark Swanson % Changed CopyStringToFrom to copy strings as words, not bytes, taking % advantage of fact that they are always allocated in word multiples % and starting on word boundaries; definite efficiency winner. % <PSL.KERNEL>COPIERS.RED.2, 28-Sep-82 10:21:15, Edit by PERDUE % Made CopyStringToFrom safe and to not bother clearing the % terminating byte. on SysLisp; syslsp procedure CopyStringToFrom(New, Old); %. Copy all chars in Old to New begin scalar SLen, StripNew, StripOld; StripNew := StrInf New; StripOld := StrInf Old; SLen := StrLen StripOld; if StrLen StripNew < SLen then SLen := StrLen StripNew; SLen := StrPack SLen; for I := 0 step 1 until SLen do VecItm(StripNew, I) := VecItm(StripOld, I); return New; end; syslsp procedure CopyString S; %. copy to new heap string begin scalar S1; S1 := GtSTR StrLen StrInf S; CopyStringToFrom(S1, StrInf S); return MkSTR S1; end; syslsp procedure CopyWArray(New, Old, UpLim); %. copy UpLim + 1 words << for I := 0 step 1 until UpLim do New[I] := Old[I]; New >>; syslsp procedure CopyVectorToFrom(New, Old); %. Move elements, don't recurse begin scalar SLen, StripNew, StripOld; StripNew := VecInf New; StripOld := VecInf Old; SLen := VecLen StripOld; % assumes VecLen New has been set for I := 0 step 1 until SLen do VecItm(StripNew, I) := VecItm(StripOld, I); return New; end; syslsp procedure CopyVector S; %. Copy to new vector in heap begin scalar S1; S1 := GtVECT VecLen VecInf S; CopyVectorToFrom(S1, VecInf S); return MkVEC S1; end; syslsp procedure CopyWRDSToFrom(New, Old); %. Like CopyWArray in heap begin scalar SLen, StripNew, StripOld; StripNew := WrdInf New; StripOld := WrdInf Old; SLen := WrdLen StripOld; % assumes WrdLen New has been set for I := 0 step 1 until SLen do WrdItm(StripNew, I) := WrdItm(StripOld, I); return New; end; syslsp procedure CopyWRDS S; %. Allocate new WRDS array in heap begin scalar S1; S1 := GtWRDS WrdLen WrdInf S; CopyWRDSToFrom(S1, WrdInf S); return MkWRDS S1; end; % CopyPairToFrom is RplacW, found in EASY-NON-SL.RED % CopyPair is: car S . cdr S; % Usual Lisp definition of Copy only copies pairs, is found in EASY-NON-SL.RED syslsp procedure TotalCopy S; %. Unique copy of entire structure begin scalar Len, Ptr, StripS; % blows up on circular structures return case Tag S of PAIR: TotalCopy car S . TotalCopy cdr S; STR: CopyString S; VECT: << StripS := VecInf S; Len := VecLen StripS; Ptr := MkVEC GtVECT Len; for I := 0 step 1 until Len do VecItm(VecInf Ptr, I) := TotalCopy VecItm(VecInf S, I); Ptr >>; WRDS: CopyWRDS S; FIXN: MkFIXN Inf CopyWRDS S; FLTN: MkFLTN Inf CopyWRDS S; default: S end; end; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/dalloc.mac version [fede352792].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern BPS extern HEAP extern HEAP2 L1080: HEAP+0 intern L1080 L1081: HEAP+0 intern L1081 L1082: HEAP+262000 intern L1082 L1083: 0 intern L1083 L1084: HEAP2+0 intern L1084 L1085: HEAP2+262000 intern L1085 L1086: HEAP+262000 intern L1086 L1087: HEAP2+262000 intern L1087 L1088: 0 intern L1088 extern L1110 extern L1111 extern L1254 extern L1255 extern L1256 L1257: 0 intern L1257 L1258: 0 intern L1258 L1259: 0 intern L1259 end |
Added psl-1983/3-1/kernel/20/dalloc.rel version [f81490db03].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/darith.mac version [771a5b75e3].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L1397: 1 0 0 intern L1397 L1398: <3_30>+<1_18>+L1397 intern L1398 end |
Added psl-1983/3-1/kernel/20/darith.rel version [d32e8ecc80].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/ddebg.mac version [a143753710].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L1254 extern L1082 end |
Added psl-1983/3-1/kernel/20/ddebg.rel version [0aefe5de23].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/debg.ctl version [a86bf93b3b].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "debg"; PathIn "debg.build"; ASMEnd; quit; compile debg.mac, ddebg.mac |
Added psl-1983/3-1/kernel/20/debg.init version [b3fc2d6e9f].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (PUT (QUOTE TR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE TRST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (QEDITFNS !*EXPERT !*VERBOSE PROMPTSTRING!* EDITORREADER!* EDITORPRINTER!* CL))) (UNFLUID (QUOTE (CL))) (PUT (QUOTE EDIT) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITF) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITOR) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (FLUID (QUOTE (IGNOREDINBACKTRACE!* OPTIONS!* INTERPRETERFUNCTIONS!*))) |
Added psl-1983/3-1/kernel/20/debg.log version [075b6cb597].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/debg.mac version [5c984974dc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L1555: <30_30>+432 <30_30>+128 1 ; (!*ENTRY TR MACRO 1) TR: intern TR PUSH 15,1 MOVE 1,L1553 PUSHJ 15,SYMFNC+434 MOVE 2,L1554 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L1554: <30_30>+433 L1553: <9_30>+<1_18>+L1555 L1558: <30_30>+432 <30_30>+128 1 ; (!*ENTRY TRST MACRO 1) TRST: intern TRST PUSH 15,1 MOVE 1,L1556 PUSHJ 15,SYMFNC+434 MOVE 2,L1557 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L1557: <30_30>+435 L1556: <9_30>+<1_18>+L1558 L1563: 17 byte(7)67,104,97,110,103,101,32,68,101,102,105,110,105,116,105,111,110,63,0 L1564: 29 byte(7)37,114,32,105,115,32,110,111,116,32,97,110,32,101,100,105,116,97,98,108,101,32,102,117,110,99,116,105,111,110,0 1 ; (!*ENTRY EDITF EXPR 1) EDITF: intern EDITF ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-4(15) PUSHJ 15,SYMFNC+318 MOVEM 1,-2(15) LDB 11,L1559 CAIE 11,9 JRST L1565 LDB 11,L1560 CAIE 11,15 JRST L1566 L1565: MOVE 2,0(15) MOVE 1,L1561 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 L1566: MOVE 1,-2(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+347 MOVEM 1,-3(15) MOVE 1,-2(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+440 MOVE 1,L1562 PUSHJ 15,SYMFNC+441 CAME 1,0 JRST L1567 MOVE 2,-3(15) MOVE 1,-2(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+344 MOVE 1,0 JRST L1568 L1567: MOVE 2,SYMVAL+436 MOVE 1,0(15) PUSHJ 15,SYMFNC+302 CAME 1,0 JRST L1569 MOVE 2,SYMVAL+436 MOVE 1,0(15) PUSHJ 15,SYMFNC+151 MOVEM 1,SYMVAL+436 L1569: MOVE 1,0(15) L1568: ADJSP 15,-5 POPJ 15,0 L1559: point 6,1,5 L1560: point 6,1(1),5 L1562: <4_30>+<1_18>+L1563 L1561: <4_30>+<1_18>+L1564 L1574: 36 byte(7)84,121,112,101,32,72,69,76,80,60,67,82,62,32,102,111,114,32,97,32,108,105,115,116,32,111,102,32,99,111,109,109,97,110,100,115,46,0 L1575: 5 byte(7)101,100,105,116,62,32,0 1 ; (!*ENTRY EDIT EXPR 1) EDIT: intern EDIT ADJSP 15,2 MOVEM 1,0(15) JSP 10,SYMFNC+443 byte(18)0,442 MOVE 6,L1570 MOVEM 6,SYMVAL+442 PUSHJ 15,SYMFNC+444 CAME 0,SYMVAL+437 JRST L1576 MOVE 1,L1571 PUSHJ 15,SYMFNC+357 L1576: MOVE 1,SYMVAL+445 CAME 1,0 JRST L1577 MOVE 1,L1572 L1577: MOVEM 1,-1(15) MOVE 1,SYMVAL+446 CAME 1,0 JRST L1578 MOVE 1,L1573 L1578: MOVE 3,1 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,EDIT0 JSP 10,SYMFNC+447 1 ADJSP 15,-2 POPJ 15,0 L1573: <30_30>+310 L1572: <30_30>+448 L1571: <4_30>+<1_18>+L1574 L1570: <4_30>+<1_18>+L1575 L1597: 14 byte(7)73,108,108,101,103,97,108,32,99,111,109,109,97,110,100,0 L1598: 9 byte(7)76,105,115,116,32,101,109,112,116,121,0 L1599: 31 byte(7)89,111,117,32,97,114,101,32,97,108,114,101,97,100,121,32,97,116,32,116,104,101,32,116,111,112,32,108,101,118,101,108,0 L1600: <30_30>+450 <9_30>+<1_18>+L1602 L1601: 8 byte(7)78,79,84,32,70,79,85,78,68,0 L1602: <30_30>+63 <30_30>+128 ; (!*ENTRY EDIT0 EXPR 3) EDIT0: intern EDIT0 ADJSP 15,10 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-7(15) MOVEM 0,-9(15) JSP 10,SYMFNC+443 byte(18)0,449 PUSHJ 15,SYMFNC+172 MOVEM 1,-6(15) HRRZI 6,3 MOVEM 6,-5(15) L1603: MOVE 6,-6(15) MOVEM 6,-4(15) MOVE 1,-4(15) PUSHJ 15,SYMFNC+172 MOVEM 1,-3(15) MOVE 2,-6(15) MOVE 2,0(2) MOVEM 2,SYMVAL+449 L1604: CAMN 0,SYMVAL+438 JRST L1605 MOVE 2,-5(15) MOVE 1,SYMVAL+449 PUSHJ 15,EDCOPY MOVE 2,-2(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 L1605: MOVE 1,-1(15) MOVE 6,1 PUSHJ 15,SYMFNC+288 MOVEM 1,-8(15) LDB 11,L1579 CAIE 11,9 JRST L1606 LDB 11,L1581 CAIN 11,63 JRST L1580 CAILE 11,3 JRST L1607 L1580: SKIPN 0(1) JRST L1608 SETZM 2 MOVE 1,0(1) PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L1609 MOVE 1,-8(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+349 MOVE 2,SYMVAL+449 PUSHJ 15,QEDNTH MOVE 4,-8(15) MOVE 4,0(4) MOVE 3,-8(15) MOVE 3,1(3) MOVE 2,-4(15) PUSHJ 15,L1610 JRST L1604 L1609: MOVE 1,-8(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+241 PUSHJ 15,SYMFNC+274 MOVE 2,SYMVAL+449 PUSHJ 15,QEDNTH MOVE 4,-8(15) MOVE 4,0(4) MOVE 3,-8(15) MOVE 3,1(3) MOVE 2,-4(15) PUSHJ 15,XINS JRST L1604 L1607: MOVE 6,L1582 CAME 6,0(1) JRST L1608 MOVE 3,SYMVAL+449 MOVE 2,1(1) MOVE 2,1(2) MOVE 2,0(2) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,L1611 JRST L1604 L1612: MOVE 1,-1(15) MOVE 6,1 PUSHJ 15,SYMFNC+288 MOVE 3,-3(15) MOVE 2,SYMVAL+449 PUSHJ 15,L1613 MOVEM 1,-7(15) CAME 1,0 JRST L1614 MOVE 1,L1583 PUSHJ 15,SYMFNC+357 JRST L1604 L1614: MOVE 2,0(1) MOVEM 2,SYMVAL+449 MOVE 3,1(1) MOVEM 3,-3(15) MOVE 4,0(3) MOVEM 4,-4(15) JRST L1604 L1606: LDB 11,L1585 CAIN 11,63 JRST L1584 CAILE 11,3 JRST L1615 L1584: SKIPE -8(15) JRST L1616 MOVE 1,-4(15) MOVE 1,0(1) MOVEM 1,SYMVAL+449 JRST L1604 L1615: MOVE 6,-8(15) CAME 6,L1586 JRST L1617 MOVE 1,SYMVAL+438 CAME 1,0 JRST L1604 MOVE 2,-5(15) MOVE 1,SYMVAL+449 PUSHJ 15,EDCOPY MOVE 2,-2(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 JRST L1604 L1617: MOVE 6,-8(15) CAME 6,L1587 JRST L1618 MOVE 1,-6(15) MOVE 1,0(1) JRST L1619 L1618: MOVE 6,-8(15) CAMN 6,L1588 JRST L1620 MOVE 6,-8(15) CAME 6,L1589 JRST L1621 PUSHJ 15,SYMFNC+451 JRST L1604 L1621: MOVE 6,-8(15) CAMN 6,L1590 JRST L1612 MOVE 6,-8(15) CAME 6,L1591 JRST L1622 MOVE 1,-1(15) MOVE 6,1 PUSHJ 15,SYMFNC+288 MOVEM 1,-5(15) JRST L1604 L1622: MOVE 2,L1592 MOVE 1,-8(15) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L1623 PUSHJ 15,SYMFNC+452 JRST L1604 L1623: MOVE 6,-8(15) CAME 6,L1593 JRST L1624 MOVE 1,-1(15) MOVE 6,1 PUSHJ 15,SYMFNC+288 PUSHJ 15,SYMFNC+261 MOVE 2,-2(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 JRST L1604 L1624: MOVE 6,-8(15) CAME 6,SYMVAL+84 JRST L1608 JRST L1603 L1620: MOVE 7,-3(15) CAME 0,1(7) JRST L1625 MOVE 1,L1594 PUSHJ 15,SYMFNC+357 JRST L1604 L1625: MOVE 1,-3(15) MOVE 1,1(1) MOVEM 1,-3(15) MOVE 2,0(1) MOVEM 2,-4(15) MOVE 3,0(2) MOVEM 3,SYMVAL+449 JRST L1604 L1616: MOVE 6,-8(15) MOVEM 6,-9(15) MOVE 1,-8(15) PUSHJ 15,SYMFNC+273 MOVE 2,SYMVAL+449 PUSHJ 15,QEDNTH MOVEM 1,-8(15) CAME 1,0 JRST L1626 MOVE 1,L1595 PUSHJ 15,SYMFNC+357 JRST L1604 L1626: SETZM 2 MOVE 1,-9(15) PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L1627 MOVE 2,-8(15) MOVE 2,0(2) MOVEM 2,SYMVAL+449 L1627: MOVE 6,-8(15) MOVEM 6,-4(15) MOVE 2,-3(15) MOVE 1,-4(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-3(15) JRST L1604 L1608: MOVE 1,L1596 PUSHJ 15,SYMFNC+357 JRST L1604 L1619: JSP 10,SYMFNC+447 1 ADJSP 15,-10 POPJ 15,0 L1579: point 6,1,5 L1581: point 6,0(1),5 L1585: point 6,-8(15),5 L1596: <4_30>+<1_18>+L1597 L1595: <4_30>+<1_18>+L1598 L1594: <4_30>+<1_18>+L1599 L1593: <30_30>+69 L1592: <9_30>+<1_18>+L1600 L1591: <30_30>+453 L1590: <30_30>+70 L1589: <30_30>+66 L1588: <30_30>+454 L1587: <30_30>+455 L1586: <30_30>+80 L1583: <4_30>+<1_18>+L1601 L1582: <30_30>+82 ; (!*ENTRY QEDNTH EXPR 2) QEDNTH: intern QEDNTH ADJSP 15,2 L1629: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1628 CAIN 11,9 JRST L1630 MOVE 1,0 JRST L1631 L1630: HRRZI 2,1 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L1632 MOVE 1,0(15) PUSHJ 15,SYMFNC+349 MOVE 2,-1(15) MOVE 2,1(2) JRST L1629 L1632: MOVE 1,-1(15) L1631: ADJSP 15,-2 POPJ 15,0 L1628: point 6,2,5 L1635: 2 byte(7)42,42,42,0 ; (!*ENTRY EDCOPY EXPR 2) EDCOPY: intern EDCOPY ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1633 CAIE 11,9 JRST L1636 MOVE 1,2 PUSHJ 15,SYMFNC+239 CAMN 1,0 JRST L1637 MOVE 1,L1634 JRST L1636 L1637: MOVE 1,-1(15) PUSHJ 15,SYMFNC+349 MOVE 2,1 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,EDCOPY MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,EDCOPY MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L1636: ADJSP 15,-3 POPJ 15,0 L1633: point 6,1,5 L1634: <4_30>+<1_18>+L1635 ; (!*ENTRY RPLACEALL EXPR 3) L1611: intern L1611 ADJSP 15,3 L1639: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L1638 CAIN 11,9 JRST L1640 MOVE 1,0 JRST L1641 L1640: MOVE 2,1 MOVE 1,0(3) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L1642 MOVE 3,-2(15) MOVE 6,-1(15) MOVEM 6,0(3) MOVE 3,1(3) JRST L1643 L1642: MOVE 3,-2(15) MOVE 3,0(3) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,L1611 MOVE 3,-2(15) MOVE 3,1(3) L1643: MOVE 2,-1(15) MOVE 1,0(15) JRST L1639 L1641: ADJSP 15,-3 POPJ 15,0 L1638: point 6,3,5 ; (!*ENTRY FINDFIRST EXPR 3) L1613: intern L1613 ADJSP 15,4 L1645: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) LDB 11,L1644 CAIN 11,9 JRST L1646 MOVE 1,0 JRST L1647 L1646: PUSHJ 15,SYMFNC+302 CAMN 1,0 JRST L1648 MOVE 2,-2(15) MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+151 L1648: MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+151 MOVE 3,1 MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,L1613 CAME 1,0 JRST L1647 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L1645 L1647: ADJSP 15,-4 POPJ 15,0 L1644: point 6,2,5 L1651: 9 byte(7)76,105,115,116,32,101,109,112,116,121,0 ; (!*ENTRY XCHANGE EXPR 4) L1610: intern L1610 PUSH 15,2 PUSH 15,1 LDB 11,L1649 CAIN 11,9 JRST L1652 MOVE 1,L1650 PUSHJ 15,SYMFNC+357 MOVE 1,0 JRST L1653 L1652: CAIE 4,1 JRST L1654 MOVE 2,1(1) MOVE 1,3 PUSHJ 15,SYMFNC+291 MOVE 7,-1(15) MOVEM 1,0(7) MOVE 1,-1(15) MOVE 1,0(1) MOVEM 1,SYMVAL+449 JRST L1653 L1654: MOVE 7,1(1) CAMN 0,1(7) JRST L1655 MOVE 1,1(1) MOVE 1,1(1) JRST L1656 L1655: MOVE 1,0 L1656: MOVE 2,1 MOVE 1,3 PUSHJ 15,SYMFNC+291 MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) L1653: ADJSP 15,-2 POPJ 15,0 L1649: point 6,1,5 L1650: <4_30>+<1_18>+L1651 L1659: 9 byte(7)76,105,115,116,32,101,109,112,116,121,0 ; (!*ENTRY XINS EXPR 4) XINS: intern XINS PUSH 15,2 PUSH 15,1 LDB 11,L1657 CAIN 11,9 JRST L1660 MOVE 1,L1658 PUSHJ 15,SYMFNC+357 MOVE 1,0 JRST L1661 L1660: CAIE 4,1 JRST L1662 MOVE 2,1 MOVE 1,3 PUSHJ 15,SYMFNC+291 MOVE 7,-1(15) MOVEM 1,0(7) MOVE 1,-1(15) MOVE 1,0(1) MOVEM 1,SYMVAL+449 JRST L1661 L1662: MOVE 2,1(1) MOVE 1,3 PUSHJ 15,SYMFNC+291 MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) L1661: ADJSP 15,-2 POPJ 15,0 L1657: point 6,1,5 L1658: <4_30>+<1_18>+L1659 L1665: <30_30>+450 <30_30>+128 0 ; (!*ENTRY EHELP EXPR 0) EHELP: intern EHELP MOVE 1,L1663 PUSHJ 15,SYMFNC+434 MOVE 1,L1664 JRST SYMFNC+456 L1664: <30_30>+457 L1663: <9_30>+<1_18>+L1665 extern L1254 extern L1082 L1667: 63 byte(7)66,97,99,107,116,114,97,99,101,44,32,105,110,99,108,117,100,105,110,103,32,105,110,116,101,114,112,114,101,116,101,114,32,102,117,110,99,116,105,111,110,115,44,32,102,114,111,109,32,116,111,112,32,111,102,32,115,116,97,99,107,58,37,110,0 0 ; (!*ENTRY INTERPBACKTRACE EXPR 0) L1668: intern L1668 PUSH 15,0 XMOVEI 1,0(15) MOVEM 1,0(15) MOVE 1,L1666 PUSHJ 15,SYMFNC+461 HRRZI 3,1 MOVE 2,L1254 MOVE 1,0(15) ADJSP 15,-1 JRST L1669 L1666: <4_30>+<1_18>+L1667 L1671: 29 byte(7)66,97,99,107,116,114,97,99,101,32,102,114,111,109,32,116,111,112,32,111,102,32,115,116,97,99,107,58,37,110,0 0 ; (!*ENTRY BACKTRACE EXPR 0) L1672: intern L1672 PUSH 15,0 PUSH 15,0 XMOVEI 1,0(15) MOVEM 1,0(15) MOVE 1,L1670 PUSHJ 15,SYMFNC+461 SETZM 3 MOVE 2,L1254 MOVE 1,0(15) ADJSP 15,-2 JRST L1669 L1670: <4_30>+<1_18>+L1671 ; (!*ENTRY BACKTRACERANGE EXPR 3) L1669: intern L1669 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 1,-4(15) L1674: MOVE 6,-4(15) CAMGE 6,-1(15) JRST L1675 MOVE 7,-4(15) LDB 1,L1673 CAIE 1,28 JRST L1676 MOVE 2,-2(15) MOVE 7,-4(15) MOVE 1,0(7) TLZ 1,258048 HRLI 1,122880 PUSHJ 15,L1677 JRST L1678 L1676: MOVE 1,-4(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+463 MOVE 2,1 MOVEM 2,-3(15) CAMN 2,0 JRST L1678 MOVE 2,-2(15) MOVE 1,-3(15) PUSHJ 15,L1677 L1678: SOS -4(15) JRST L1674 L1675: ADJSP 15,-5 JRST SYMFNC+444 L1673: point 6,0(7),5 L1686: 4 byte(7)9,37,112,37,110,0 L1687: 10 byte(7)37,112,32,45,62,32,37,112,58,37,110,0 L1688: 4 byte(7)9,37,114,37,110,0 L1689: <30_30>+464 <30_30>+128 0 ; (!*ENTRY VERBOSEBACKTRACE EXPR 0) L1690: intern L1690 ADJSP 15,3 MOVEM 0,0(15) MOVEM 0,-1(15) MOVE 2,SYMVAL+466 MOVE 1,L1679 PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L1691 MOVE 1,L1680 PUSHJ 15,SYMFNC+434 L1691: XMOVEI 1,0(15) MOVEM 1,0(15) MOVEM 1,-2(15) L1692: MOVE 6,-2(15) CAMGE 6,L1254 JRST L1693 MOVE 6,-2(15) LDB 11,L1681 CAIE 11,15 JRST L1694 MOVE 7,-2(15) MOVE 1,0(7) TLZ 1,258048 CAMG 1,L1082 JRST L1694 HRRZI 1,9 PUSHJ 15,SYMFNC+467 MOVE 2,-2(15) MOVE 2,0(2) MOVE 1,SYMVAL+311 PUSHJ 15,SYMFNC+468 PUSHJ 15,SYMFNC+444 JRST L1695 L1694: MOVE 7,-2(15) LDB 1,L1682 CAIE 1,28 JRST L1696 MOVE 7,-2(15) MOVE 2,0(7) TLZ 2,258048 HRLI 2,122880 MOVE 1,L1683 JRST L1697 L1696: MOVE 1,-2(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+463 MOVE 2,1 MOVEM 2,-1(15) CAMN 2,0 JRST L1698 MOVE 7,-2(15) MOVE 1,0(7) TLZ 1,258048 PUSHJ 15,SYMFNC+469 MOVE 3,-1(15) MOVE 2,1 MOVE 1,L1684 PUSHJ 15,SYMFNC+461 JRST L1695 L1698: MOVE 2,-2(15) MOVE 2,0(2) MOVE 1,L1685 L1697: PUSHJ 15,SYMFNC+461 L1695: SOS -2(15) JRST L1692 L1693: ADJSP 15,-3 JRST SYMFNC+444 L1681: point 6,0(6),5 L1682: point 6,0(7),5 L1685: <4_30>+<1_18>+L1686 L1684: <4_30>+<1_18>+L1687 L1683: <4_30>+<1_18>+L1688 L1680: <9_30>+<1_18>+L1689 L1679: <30_30>+464 ; (!*ENTRY BACKTRACE1 EXPR 2) L1677: intern L1677 PUSH 15,2 PUSH 15,1 MOVE 2,SYMVAL+458 PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L1699 SKIPE -1(15) JRST L1700 MOVE 2,SYMVAL+459 MOVE 1,0(15) PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L1701 L1700: MOVE 1,0(15) PUSHJ 15,SYMFNC+470 HRRZI 1,32 PUSHJ 15,SYMFNC+467 JRST L1702 L1701: MOVE 1,0 L1702: JRST L1703 L1699: MOVE 1,0 L1703: ADJSP 15,-2 POPJ 15,0 end |
Added psl-1983/3-1/kernel/20/debg.rel version [3cd92dd9fd].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/derror.mac version [a3b6816309].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 end |
Added psl-1983/3-1/kernel/20/derror.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/deval.mac version [82a40766df].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L1256 extern L1825 L2011: block 1601 intern L2011 L2012: L2011+0 intern L2012 end |
Added psl-1983/3-1/kernel/20/deval.rel version [a22cf27473].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dextra.mac version [e76c9ddf3b].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L1080 extern L1082 extern L1110 extern L1111 extern L2081 end |
Added psl-1983/3-1/kernel/20/dextra.rel version [36600e1b6b].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dfasl.mac version [dae18a3089].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L2110 L2111: 0 intern L2111 end |
Added psl-1983/3-1/kernel/20/dfasl.rel version [e972bb2b4f].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dheap.mac version [6399a0afef].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 BPS: block 170001 intern BPS L1110: <BPS+0>+262144 intern L1110 L1111: <BPS+170000>+262144 intern L1111 end |
Added psl-1983/3-1/kernel/20/dheap.rel version [8a9769886b].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dio.mac version [6ab10c829a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L2110: block 1001 intern L2110 L2253: <30_30>+591 <30_30>+504 <30_30>+504 <30_30>+592 <30_30>+504 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 intern L2253 L2254: <30_30>+505 <30_30>+593 <30_30>+594 <30_30>+595 <30_30>+596 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 intern L2254 L2255: <30_30>+506 <30_30>+506 <30_30>+506 <30_30>+506 <30_30>+506 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 <30_30>+502 intern L2255 L2256: 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L2256 L2257: 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L2257 L2258: block 32 intern L2258 L2259: 0 80 80 10000 10000 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L2259 L2260: 64 65 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 intern L2260 TOKCH: 0 intern TOKCH L2373: 0 intern L2373 L2374: 0 intern L2374 L2375: 0 intern L2375 L2376: 0 intern L2376 L2377: 0 intern L2377 L2378: 0 intern L2378 L2379: 0 intern L2379 L2380: 0 intern L2380 L2381: 0 intern L2381 L2394: block 2 intern L2394 L2395: block 2 intern L2395 L2396: block 2 intern L2396 L2397: block 2 intern L2397 L2562: 35 byte(7)48,49,50,51,52,53,54,55,56,57,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,0 intern L2562 L2563: block 9 intern L2563 L2905: 0 intern L2905 L2909: 0 intern L2909 end |
Added psl-1983/3-1/kernel/20/dio.rel version [b91349f6f7].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dmacro.mac version [a3b6816309].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 end |
Added psl-1983/3-1/kernel/20/dmacro.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dmain.mac version [dd7ea837ef].
more than 10,000 changes
Added psl-1983/3-1/kernel/20/dmain.rel version [5374d382d2].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dprop.mac version [8c4b03d593].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 UNDEFN: <24377294848+<SYMFNC+0>>+516 intern UNDEFN LAMLNK: <24377294848+<SYMFNC+0>>+512 intern LAMLNK end |
Added psl-1983/3-1/kernel/20/dprop.rel version [721a1005de].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/drandm.mac version [a3b6816309].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 end |
Added psl-1983/3-1/kernel/20/drandm.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dsymbl.mac version [7556dd1966].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 BNDSTK: block 2001 intern BNDSTK L1255: BNDSTK+0 intern L1255 L1825: BNDSTK+1999 intern L1825 L1256: BNDSTK+0 intern L1256 L3465: 4 byte(7)71,48,48,48,48,0 intern L3465 L3479: 0 intern L3479 end |
Added psl-1983/3-1/kernel/20/dsymbl.rel version [60b9b90494].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dsysio.mac version [5d3e8c107b].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L2260 extern L2253 extern L2254 extern L2255 L3504: 1 intern L3504 L3505: block 41 intern L3505 end |
Added psl-1983/3-1/kernel/20/dsysio.rel version [565f38bba5].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dtloop.mac version [a3b6816309].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 end |
Added psl-1983/3-1/kernel/20/dtloop.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dtypes.mac version [a3b6816309].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 end |
Added psl-1983/3-1/kernel/20/dtypes.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/dumplisp.red version [93f5fbca07].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DUMPLISP.RED - Dump running Lisp into a file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 April 1982 % Copyright (c) 1982 University of Utah % % 27-May-83 Mark R. Swanson % Changes for extended addressing % <PSL.KERNEL-20>DUMPLISP.RED.2, 5-Oct-82 10:57:34, Edit by BENSON % Removed DumpFileName!* added filename arg to Dumplisp % <PSL.20-INTERP>DUMPLISP.RED.7, 3-Sep-82 10:22:46, Edit by BENSON % Fixed page boundary bug when unmapping stack CompileTime << flag('(unmap!-pages save!-into!-file), 'InternalFunction); >>; on Syslisp; external WVar ST, HeapLast, HeapUpperBound, NextBPS, LastBPS, StackUpperBound; syslsp procedure DumpLisp Filename; << if not StringP Filename then StdError "Dumplisp requires a filename argument"; Reclaim; unmap!-space(HeapLast, HeapUpperBound); unmap!-space(NextBPS, LastBPS); %% Add some slack to the end of the stack fo the call to unmap-space! unmap!-space(MakeAddressFromStackPointer ST + 10, StackUpperBound); save!-into!-file Filename >>; syslsp procedure unmap!-space(Lo, Hi); begin scalar LoPage, HiPage; LoPage := LSH(Lo + 8#777, -9); HiPage := LSH(Hi - 8#1000, -9); return if not (LoPage >= HiPage) then unmap!-pages(LoPage, HiPage - LoPage); end; lap '((!*entry unmap!-pages expr 2) (hrlzi 3 2#100000000000000000) % pm%cnt in AC3 (hrr 3 2) % page count in rh AC3 (hrlzi 2 8#400000) % .fhslf in lh AC2 (hrr 2 1) % starting page in rh AC2 (!*MOVE (WConst -1) (REG 1)) % -1 in AC1 (pmap) % do it (!*EXIT 0) ); lap '((!*entry save!-into!-file expr 1) (!*MOVE (reg 1) (reg 5)) % save in 5 (move 2 1) % file name in 2 (!*MkItem (reg 2) 8#66) % make a byte pointer (hrlzi 1 2#100000000000000001) % gj%fou + gj%sht (gtjfn) (jrst CouldntOpen) (hrli 1 8#400000) % .fhslf (hrrzi 2 2#101011000000000000) % ss%cpy, ss%rd, ss%exe, ss%e??,all pages % (hrli 2 -8#1000) % for Release 4 and before, 1000 pages %/ Change previous line to following line for extended addressing (tlo 2 8#400000) % large negative number (!*MOVE (WConst 8#1000) (REG 3)) (ssave) (!*MOVE (WConst 0) (REG 1)) (!*EXIT 0) CouldntOpen (!*MOVE '"Couldn't GTJFN `%w' for Dumplisp" (reg 1)) (!*MOVE (reg 5) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); off Syslisp; END; |
Added psl-1983/3-1/kernel/20/easy-non-sl.red version [ceb5a9ed09].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EASY-NON-SL.RED - Commonly used Non-Standard Lisp functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EASY-NON-SL.RED.2, 17-Sep-82 16:10:18, Edit by BENSON % Added ChannelPrin2T, ChannelSpaces, ChannelTab, ChannelSpaces2 % <PSL.INTERP>EASY-NON-SL.RED.7, 9-Jul-82 12:46:43, Edit by BENSON % Changed NTH to improve error reporting, using DoPNTH % <PSL.INTERP>EASY-NON-SL.RED.2, 19-Apr-82 23:05:35, Edit by BENSON % Changed order of tests in PNTH % <PSL.INTERP>EASY-NON-SL.RED.20, 23-Feb-82 21:36:36, Edit by BENSON % Added NE (not eq) % <PSL.INTERP>EASY-NON-SL.RED.19, 16-Feb-82 22:30:33, Edit by BENSON % made NEQ GEQ and LEQ back into EXPRs % <PSL.INTERP>EASY-NON-SL.RED.16, 15-Feb-82 18:01:14, Edit by BENSON % Made NEQ GEQ and LEQ into macros % <PSL.INTERP>EASY-NON-SL.RED.12, 18-Jan-82 12:28:13, Edit by BENSON % Added NexprP CompileTime flag('(DelqIP1 DeletIP1 SubstIP1 DelAscIP1 DelAtQIP1 DoPNTH), 'InternalFunction); % predicates expr procedure NEQ(U, V); %. not EQUAL (should be changed to not EQ) not(U = V); expr procedure NE(U, V); %. not EQ not(U eq V); expr procedure GEQ(U, V); %. greater than or equal to not(U < V); expr procedure LEQ(U, V); %. less than or equal to not(U > V); lisp procedure EqCar(U, V); %. car U eq V PairP U and car U eq V; lisp procedure ExprP U; %. Is U an EXPR? EqCar(U, 'LAMBDA) or CodeP U or EqCar(GetD U, 'EXPR); lisp procedure MacroP U; %. Is U a MACRO? EqCar(GetD U, 'MACRO); lisp procedure FexprP U; %. Is U an FEXPR? EqCar(GetD U, 'FEXPR); lisp procedure NexprP U; %. Is U an NEXPR? EqCar(GetD U, 'NEXPR); % Function definition lisp procedure CopyD(New, Old); %. FunDef New := FunDef Old; % % CopyD(New:id, Old:id):id % ----------------------- % Type: EVAL, SPREAD % The function body and type for New become the same as Old. If no % definition exists for Old, the error % % ***** `Old' has no definition in CopyD % % occurs. New is returned. % begin scalar OldDef; OldDef := GetD Old; if PairP OldDef then PutD(New, car OldDef, cdr OldDef) else StdError BldMsg("%r has no definition in CopyD", Old); return New; end; % Numerical functions lisp procedure Recip N; %. Floating point reciprocal 1.0 / N; % Commonly used constructors lisp procedure MkQuote U; %. Eval MkQuote U eq U list('QUOTE, U); % Nicer names to access parts of a list macro procedure First U; %. First element of a list 'CAR . cdr U; macro procedure Second U; %. Second element of a list 'CADR . cdr U; macro procedure Third U; %. Third element of a list 'CADDR . cdr U; macro procedure Fourth U; %. Fourth element of a list 'CADDDR . cdr U; macro procedure Rest U; %. Tail of a list 'CDR . cdr U; % Destructive and EQ versions of Standard Lisp functions lisp procedure ReversIP U; %. Destructive REVERSE (REVERSe In Place) begin scalar X,Y; while PairP U do << X := cdr U; Y := RplacD(U, Y); U := X >>; return Y end; lisp procedure SubstIP1(A, X, L); % Auxiliary function for SubstIP << if X = car L then RplacA(L, A) else if PairP car L then SubstIP(A, X, car L); if PairP cdr L then SubstIP(A, X, cdr L) >>; lisp procedure SubstIP(A, X, L); %. Destructive version of Subst if null L then NIL else if X = L then A else if not PairP L then L else << SubstIP1(A, X, L); L >>; lisp procedure DeletIP1(U, V); % Auxiliary function for DeletIP if PairP cdr V then if U = cadr V then RplacD(V, cddr V) else DeletIP1(U, cdr V); lisp procedure DeletIP(U, V); %. Destructive DELETE if not PairP V then V else if U = car V then cdr V else << DeletIP1(U, V); V >>; lisp procedure DelQ(U, V); %. EQ version of DELETE if not PairP V then V else if car V eq U then cdr V else car V . DelQ(U, cdr V); lisp procedure Del(F, U, V); %. Generalized Delete, F is comparison function if not PairP V then V else if Apply(F, list(car V, U)) then cdr V else car V . Del(F, U, cdr V); lisp procedure DelqIP1(U, V); % Auxiliary function for DelqIP if PairP cdr V then if U eq cadr V then RplacD(V, cddr V) else DelqIP1(U, cdr V); lisp procedure DelqIP(U, V); %. Destructive DELQ if not PairP V then V else if U eq car V then cdr V else << DelqIP1(U, V); V >>; lisp procedure Atsoc(U, V); %. EQ version of ASSOC if not PairP V then NIL else if PairP car V and U eq caar V then car V else Atsoc(U, cdr V); lisp procedure Ass(F, U, V); %. Generalized Assoc, F is comparison function % % Not to be confused with Elbow % if not PairP V then NIL else if PairP car V and Apply(F, list(U, caar V)) then car V else Ass(F, U, cdr V); lisp procedure Mem(F, U, V); %. Generalized Member, F is comparison function if not PairP V then NIL else if Apply(F, list(U, car V)) then V else Mem(F, U, cdr V); lisp procedure RAssoc(U, V); %. Reverse Assoc, compare with cdr of entry if not PairP V then NIL else if PairP car V and U = cdar V then car V else RAssoc(U, cdr V); lisp procedure DelAsc(U, V); %. Remove first (U . xxx) from V if not PairP V then NIL else if PairP car V and U = caar V then cdr V else car V . DelAsc(U, cdr V); lisp procedure DelAscIP1(U, V); % Auxiliary function for DelAscIP if PairP cdr V then if PairP cadr V and U = caadr V then RplacD(V, cddr V) else DelAscIP1(U, cdr V); lisp procedure DelAscIP(U, V); %. Destructive DelAsc if not PairP V then NIL else if PairP car V and U = caar V then cdr V else << DelAscIP1(U, V); V >>; lisp procedure DelAtQ(U, V); %. EQ version of DELASC if not PairP V then NIL else if EqCar(car V, U) then cdr V else car V . DelAtQ(U, cdr V); lisp procedure DelAtQIP1(U, V); % Auxiliary function for DelAtQIP if PairP cdr V then if PairP cadr V and U eq caadr V then RplacD(V, cddr V) else DelAtQIP1(U, cdr V); lisp procedure DelAtQIP(U, V); %. Destructive DelAtQ if not PairP V then NIL else if PairP car V and U eq caar V then cdr V else << DelAtQIP1(U, V); V >>; lisp procedure SublA(U,V); %. EQ version of SubLis, replaces atoms only begin scalar X; return if not PairP U or null V then V else if atom V then if (X := Atsoc(V, U)) then cdr X else V else SublA(U, car V) . SublA(U, cdr V) end; lisp procedure RplacW(A, B); %. RePLACe Whole pair if PairP A then if PairP B then RplacA(RplacD(A, cdr B), car B) else NonPairError(B, 'RplacW) else NonPairError(A, 'RPlacW); lisp procedure LastCar X; %. last element of list if atom X then X else car LastPair X; lisp procedure LastPair X; %. last pair of list if atom X or atom cdr X then X else LastPair cdr X; lisp procedure Copy U; %. copy all pairs in S-Expr % % See also TotalCopy in COPIERS.RED % if PairP U then Copy car U . Copy cdr U else U; % blows up if circular lisp procedure NTH(U, N); %. N-th element of list (lambda(X); if PairP X then car X else RangeError(U, N, 'NTH))(DoPNTH(U, N)); lisp procedure DoPNTH(U, N); if N = 1 or not PairP U then U else DoPNTH(cdr U, N - 1); lisp procedure PNTH(U, N); %. Pointer to N-th element of list if N = 1 then U else if not PairP U then RangeError(U, N, 'PNTH) else PNTH(cdr U, N - 1); lisp procedure AConc(U, V); %. destructively add element V to the tail of U NConc(U, list V); lisp procedure TConc(Ptr, Elem); %. AConc maintaining pointer to end % % ACONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to (NIL . NIL) before calling the first time % << Elem := list Elem; if not PairP Ptr then % if PTR not initialized, return starting ptr Elem . Elem else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, Elem), Elem) else << RplacD(cdr Ptr, Elem); RplacD(Ptr, Elem) >> >>; lisp procedure LConc(Ptr, Lst); %. NConc maintaining pointer to end % % NCONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to NIL . NIL before calling the first time % if null Lst then Ptr else if atom Ptr then % if PTR not initialized, return starting ptr Lst . LastPair Lst else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, LastPair Lst), Lst) else << RplacD(cdr Ptr, Lst); RplacD(Ptr, LastPair Lst) >>; % MAP functions of 2 arguments lisp procedure Map2(L, M, Fn); %. for each X, Y on L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(L, M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAP2" else NIL >>; lisp procedure MapC2(L, M, Fn); %. for each X, Y in L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(car L, car M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAPC2" else NIL >>; % Printing functions lisp procedure ChannelPrin2T(C, U); %. Prin2 and TerPri << ChannelPrin2(C, U); ChannelTerPri C; U >>; lisp procedure Prin2T U; %. Prin2 and TerPri ChannelPrin2T(OUT!*, U); lisp procedure ChannelSpaces(C, N); %. Prin2 N spaces for I := 1 step 1 until N do ChannelWriteChar(C, char BLANK); lisp procedure Spaces N; %. Prin2 N spaces ChannelSpaces(OUT!*, N); lisp procedure ChannelTAB(Chn, N); %. Spaces to column N begin scalar M; M := ChannelPosn Chn; if N < M then << ChannelTerPri Chn; M := 0 >>; ChannelSpaces(Chn, N - M); end; lisp procedure TAB N; %. Spaces to column N ChannelTAB(OUT!*, N); if_system(Dec20, << lap '((!*entry FileP expr 1) (!*MOVE (REG 1) (REG 2)) (!*MkItem (reg 2) 8#66) % make a byte pointer (hrlzi 1 2#001000000000000001) % gj%old + gj%sht (gtjfn) (jrst NotFile) (rljfn) % release it (jfcl) (!*MOVE (QUOTE T) (REG 1)) (!*EXIT 0) NotFile (!*MOVE (QUOTE NIL) (REG 1)) (!*EXIT 0) ); >>, << lisp procedure FileP F; %. is F an existing file? % % This could be done more efficiently in a much more system-dependent way, % but efficiency probably doesn't matter too much here. % if PairP(F := ErrorSet(list('OPEN, MkQuote F, '(QUOTE INPUT)), NIL, NIL)) then << Close car F; T >> else NIL; >>); % This doesn't belong anywhere and will be eliminated soon lisp procedure PutC(Name, Ind, Exp); %. Used by RLISP to define SMACROs << put(Name, Ind, Exp); Name >>; LoadTime << PutD('Spaces2, 'EXPR, cdr GetD 'TAB); % For compatibility PutD('ChannelSpaces2, 'EXPR, cdr GetD 'ChannelTAB); >>; END; |
Added psl-1983/3-1/kernel/20/error.ctl version [84bd23dafb].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:EX-DEC20-CROSS.EXE ASMOut "error"; PathIn "error.build"; ASMEnd; quit; compile error.mac, derror.mac |
Added psl-1983/3-1/kernel/20/error.init version [83b8b0a3d6].
> > > > > > > | 1 2 3 4 5 6 7 | (FLUID (QUOTE (!*CONTINUABLEERROR ERRORFORM!* BREAKLEVEL!* MAXBREAKLEVEL!* !*EMSGP))) (GLOBAL (QUOTE (EMSG!*))) (GLOBAL (QUOTE (EMSG!*))) (FLUID (QUOTE (!*BACKTRACE !*INNER!*BACKTRACE !*EMSGP !*BREAK BREAKLEVEL!* MAXBREAKLEVEL!* !*CONTINUABLEERROR))) (PUT (QUOTE ERRSET) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/3-1/kernel/20/error.log version [2093e99fbb].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/error.mac version [6b44fe4a12].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L1705: 20 byte(7)42,42,42,42,42,32,70,97,116,97,108,32,101,114,114,111,114,58,32,37,115,0 1 ; (!*ENTRY FATALERROR EXPR 1) L1706: intern L1706 PUSH 15,1 MOVE 2,1 MOVE 1,L1704 PUSHJ 15,SYMFNC+418 L1707: PUSHJ 15,SYMFNC+471 JRST L1707 L1704: <4_30>+<1_18>+L1705 L1709: 33 byte(7)73,110,100,101,120,32,37,114,32,111,117,116,32,111,102,32,114,97,110,103,101,32,102,111,114,32,37,112,32,105,110,32,37,112,0 3 ; (!*ENTRY RANGEERROR EXPR 3) L1710: intern L1710 MOVE 4,3 MOVE 3,1 MOVE 1,L1708 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L1708: <4_30>+<1_18>+L1709 1 ; (!*ENTRY STDERROR EXPR 1) L1711: intern L1711 MOVE 2,1 HRRZI 1,99 JRST SYMFNC+472 L1718: <30_30>+451 <30_30>+128 L1719: <30_30>+78 <9_30>+<1_18>+L1722 L1720: <30_30>+89 <9_30>+<1_18>+L1723 L1721: 12 byte(7)63,37,108,32,40,89,32,111,114,32,78,41,32,0 L1722: <30_30>+473 <30_30>+128 L1723: <30_30>+474 <30_30>+128 1 ; (!*ENTRY YESP EXPR 1) YESP: intern YESP ADJSP 15,6 MOVEM 1,0(15) MOVEM 0,-1(15) JSP 10,SYMFNC+443 byte(18)0,442 MOVE 1,0 PUSHJ 15,SYMFNC+475 MOVEM 1,-5(15) MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+477 MOVEM 1,-4(15) MOVE 2,0(15) MOVE 1,L1712 PUSHJ 15,SYMFNC+155 MOVEM 1,SYMVAL+442 L1724: PUSHJ 15,SYMFNC+448 MOVEM 1,-2(15) MOVE 2,L1713 PUSHJ 15,SYMFNC+303 MOVE 2,1 MOVEM 2,-3(15) CAME 2,0 JRST L1725 MOVE 2,L1714 MOVE 1,-2(15) PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L1725 MOVE 6,-2(15) CAME 6,L1715 JRST L1726 MOVE 3,0 MOVE 2,0 MOVE 1,L1716 PUSHJ 15,SYMFNC+478 L1726: MOVE 6,SYMVAL+84 MOVEM 6,-1(15) JRST L1724 L1725: MOVE 1,-4(15) PUSHJ 15,SYMFNC+477 MOVE 1,-5(15) PUSHJ 15,SYMFNC+475 MOVE 6,L1717 MOVEM 6,SYMVAL+479 MOVE 1,-3(15) JSP 10,SYMFNC+447 1 ADJSP 15,-6 POPJ 15,0 L1717: <30_30>+480 L1716: <9_30>+<1_18>+L1718 L1715: <30_30>+66 L1714: <9_30>+<1_18>+L1719 L1713: <9_30>+<1_18>+L1720 L1712: <4_30>+<1_18>+L1721 L1732: 1 byte(7)37,112,0 L1733: 38 byte(7)42,42,42,42,42,32,67,111,110,116,105,110,117,97,98,108,101,32,101,114,114,111,114,44,32,114,101,116,114,121,32,102,111,114,109,32,105,115,58,0 L1734: 40 byte(7)42,42,42,42,42,32,67,111,110,116,105,110,117,97,98,108,101,32,101,114,114,111,114,58,32,114,101,116,114,121,32,102,111,114,109,32,105,115,32,37,114,0 L1735: 23 byte(7)42,42,42,42,42,32,67,111,110,116,105,110,117,97,98,108,101,32,101,114,114,111,114,46,0 L1736: 7 byte(7)42,42,42,42,42,32,37,108,0 3 ; (!*ENTRY CONTINUABLEERROR EXPR 3) L1737: intern L1737 PUSH 15,2 PUSH 15,1 JSP 10,SYMFNC+443 byte(18)3,481 JSP 10,SYMFNC+443 byte(18)0,482 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+482 MOVEM 2,SYMVAL+483 CAMN 0,SYMVAL+484 JRST L1738 CAMN 0,SYMVAL+485 JRST L1738 MOVE 2,SYMVAL+486 MOVE 1,SYMVAL+487 PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L1738 MOVE 2,-1(15) MOVE 1,L1727 PUSHJ 15,SYMFNC+418 CAME 0,SYMVAL+481 JRST L1739 MOVE 1,L1728 PUSHJ 15,SYMFNC+418 JRST L1740 L1739: MOVE 1,SYMVAL+481 PUSHJ 15,SYMFNC+488 HRRZI 2,40 PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L1741 MOVE 2,SYMVAL+481 MOVE 1,L1729 JRST L1742 L1741: MOVE 1,L1730 PUSHJ 15,SYMFNC+418 MOVE 2,SYMVAL+481 MOVE 1,L1731 L1742: PUSHJ 15,SYMFNC+418 L1740: PUSHJ 15,SYMFNC+451 JRST L1743 L1738: MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+472 L1743: JSP 10,SYMFNC+447 1 JSP 10,SYMFNC+447 1 ADJSP 15,-2 POPJ 15,0 L1731: <4_30>+<1_18>+L1732 L1730: <4_30>+<1_18>+L1733 L1729: <4_30>+<1_18>+L1734 L1728: <4_30>+<1_18>+L1735 L1727: <4_30>+<1_18>+L1736 L1745: 50 byte(7)65,110,32,97,116,116,101,109,112,116,32,119,97,115,32,109,97,100,101,32,116,111,32,100,111,32,37,112,32,111,110,32,37,114,44,32,119,104,105,99,104,32,105,115,32,110,111,116,32,37,119,0 3 ; (!*ENTRY TYPEERROR EXPR 3) L1746: intern L1746 MOVE 4,3 MOVE 3,1 MOVE 1,L1744 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L1744: <4_30>+<1_18>+L1745 L1748: 60 byte(7)65,110,32,97,116,116,101,109,112,116,32,119,97,115,32,109,97,100,101,32,116,111,32,117,115,101,32,37,114,32,97,115,32,37,119,32,105,110,32,37,112,44,32,119,104,101,114,101,32,37,119,32,105,115,32,110,101,101,100,101,100,0 4 ; (!*ENTRY USAGETYPEERROR EXPR 4) L1749: intern L1749 PUSH 15,4 MOVE 5,3 MOVE 4,2 MOVE 3,0(15) MOVE 2,1 MOVE 1,L1747 PUSHJ 15,SYMFNC+155 ADJSP 15,-1 JRST SYMFNC+156 L1747: <4_30>+<1_18>+L1748 L1752: 9 byte(7)97,110,32,105,110,116,101,103,101,114,0 L1753: 7 byte(7)97,110,32,105,110,100,101,120,0 2 ; (!*ENTRY INDEXERROR EXPR 2) L1754: intern L1754 MOVE 4,L1750 MOVE 3,L1751 JRST SYMFNC+489 L1751: <4_30>+<1_18>+L1752 L1750: <4_30>+<1_18>+L1753 L1756: 5 byte(7)97,32,112,97,105,114,0 2 ; (!*ENTRY NONPAIRERROR EXPR 2) L1757: intern L1757 MOVE 3,L1755 JRST SYMFNC+132 L1755: <4_30>+<1_18>+L1756 L1759: 12 byte(7)97,110,32,105,100,101,110,116,105,102,105,101,114,0 2 ; (!*ENTRY NONIDERROR EXPR 2) L1760: intern L1760 MOVE 3,L1758 JRST SYMFNC+132 L1758: <4_30>+<1_18>+L1759 L1762: 7 byte(7)97,32,110,117,109,98,101,114,0 2 ; (!*ENTRY NONNUMBERERROR EXPR 2) L1763: intern L1763 MOVE 3,L1761 JRST SYMFNC+132 L1761: <4_30>+<1_18>+L1762 L1765: 9 byte(7)97,110,32,105,110,116,101,103,101,114,0 2 ; (!*ENTRY NONINTEGERERROR EXPR 2) L1766: intern L1766 MOVE 3,L1764 JRST SYMFNC+132 L1764: <4_30>+<1_18>+L1765 L1768: 21 byte(7)97,32,110,111,110,45,110,101,103,97,116,105,118,101,32,105,110,116,101,103,101,114,0 2 ; (!*ENTRY NONPOSITIVEINTEGERERROR EXPR 2) L1769: intern L1769 MOVE 3,L1767 JRST SYMFNC+132 L1767: <4_30>+<1_18>+L1768 L1771: 10 byte(7)97,32,99,104,97,114,97,99,116,101,114,0 2 ; (!*ENTRY NONCHARACTERERROR EXPR 2) L1772: intern L1772 MOVE 3,L1770 JRST SYMFNC+132 L1770: <4_30>+<1_18>+L1771 L1774: 7 byte(7)97,32,115,116,114,105,110,103,0 2 ; (!*ENTRY NONSTRINGERROR EXPR 2) L1775: intern L1775 MOVE 3,L1773 JRST SYMFNC+132 L1773: <4_30>+<1_18>+L1774 L1777: 7 byte(7)97,32,118,101,99,116,111,114,0 2 ; (!*ENTRY NONVECTORERROR EXPR 2) L1778: intern L1778 MOVE 3,L1776 JRST SYMFNC+132 L1776: <4_30>+<1_18>+L1777 L1780: 13 byte(7)97,32,119,111,114,100,115,32,118,101,99,116,111,114,0 2 ; (!*ENTRY NONWORDS EXPR 2) L1781: intern L1781 MOVE 3,L1779 JRST SYMFNC+132 L1779: <4_30>+<1_18>+L1780 L1783: 9 byte(7)97,32,115,101,113,117,101,110,99,101,0 2 ; (!*ENTRY NONSEQUENCEERROR EXPR 2) L1784: intern L1784 MOVE 3,L1782 JRST SYMFNC+132 L1782: <4_30>+<1_18>+L1783 L1786: 18 byte(7)97,32,108,101,103,97,108,32,73,47,79,32,99,104,97,110,110,101,108,0 2 ; (!*ENTRY NONIOCHANNELERROR EXPR 2) L1787: intern L1787 MOVE 3,L1785 JRST SYMFNC+132 L1785: <4_30>+<1_18>+L1786 L1790: 7 byte(7)42,42,42,42,42,32,37,108,0 2 ; (!*ENTRY ERROR EXPR 2) ERROR: intern ERROR PUSH 15,2 PUSH 15,1 JSP 10,SYMFNC+443 byte(18)0,482 MOVEM 2,SYMVAL+483 CAMN 0,SYMVAL+485 JRST L1791 MOVE 1,L1788 PUSHJ 15,SYMFNC+418 CAMN 0,SYMVAL+484 JRST L1791 MOVE 2,SYMVAL+486 MOVE 1,SYMVAL+487 PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L1791 PUSHJ 15,SYMFNC+451 JRST L1792 L1791: CAMN 0,SYMVAL+494 JRST L1793 PUSHJ 15,SYMFNC+462 L1793: MOVE 2,0(15) MOVE 1,L1789 PUSHJ 15,SYMFNC+495 L1792: JSP 10,SYMFNC+447 1 ADJSP 15,-2 POPJ 15,0 L1789: <30_30>+496 L1788: <4_30>+<1_18>+L1790 L1799: <30_30>+485 <30_30>+128 L1800: <30_30>+246 <9_30>+<1_18>+L1801 L1801: <30_30>+496 <30_30>+128 1 ; (!*ENTRY ERRSET MACRO 1) ERRSET: intern ERRSET ADJSP 15,2 MOVEM 1,0(15) MOVE 7,1(1) CAME 0,1(7) JRST L1802 MOVE 1,SYMVAL+84 JRST L1803 L1802: MOVE 1,1(1) MOVE 1,1(1) MOVE 1,0(1) L1803: MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) MOVE 1,0(1) MOVEM 2,-1(15) MOVE 2,1 MOVE 1,L1794 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L1795 MOVE 1,L1796 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1797 MOVE 1,L1798 PUSHJ 15,SYMFNC+235 MOVE 2,-1(15) ADJSP 15,-2 JRST SYMFNC+249 L1798: <30_30>+253 L1797: <9_30>+<1_18>+L1799 L1796: <30_30>+498 L1795: <9_30>+<1_18>+L1800 L1794: <30_30>+172 3 ; (!*ENTRY ERRORSET EXPR 3) L1805: intern L1805 ADJSP 15,3 MOVEM 1,0(15) JSP 10,SYMFNC+443 byte(18)3,494 byte(18)2,485 MOVE 1,L1804 PUSHJ 15,SYMFNC+499 MOVEM 1,-1(15) CAME 0,SYMVAL+500 JRST L1806 MOVE 1,0(15) PUSHJ 15,SYMFNC+261 PUSHJ 15,SYMFNC+172 MOVEM 1,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+501 MOVE 1,-2(15) L1806: JSP 10,SYMFNC+447 2 ADJSP 15,-3 POPJ 15,0 L1804: <30_30>+496 L1808: 15 byte(7)67,104,97,110,110,101,108,32,110,111,116,32,111,112,101,110,0 2 ; (!*ENTRY CHANNELNOTOPEN EXPR 2) L1809: intern L1809 MOVE 2,L1807 JRST SYMFNC+503 L1807: <4_30>+<1_18>+L1808 L1811: 26 byte(7)67,104,97,110,110,101,108,32,111,112,101,110,32,102,111,114,32,119,114,105,116,101,32,111,110,108,121,0 1 ; (!*ENTRY WRITEONLYCHANNEL EXPR 1) L1812: intern L1812 MOVE 2,L1810 JRST SYMFNC+503 L1810: <4_30>+<1_18>+L1811 L1814: 25 byte(7)67,104,97,110,110,101,108,32,111,112,101,110,32,102,111,114,32,114,101,97,100,32,111,110,108,121,0 2 ; (!*ENTRY READONLYCHANNEL EXPR 2) L1815: intern L1815 MOVE 2,L1813 JRST SYMFNC+503 L1813: <4_30>+<1_18>+L1814 L1817: 32 byte(7)73,108,108,101,103,97,108,32,116,111,32,99,108,111,115,101,32,115,116,97,110,100,97,114,100,32,99,104,97,110,110,101,108,0 1 ; (!*ENTRY ILLEGALSTANDARDCHANNELCLOSE EXPR 1) L1818: intern L1818 MOVE 2,L1816 JRST SYMFNC+503 L1816: <4_30>+<1_18>+L1817 L1820: 12 byte(7)73,47,79,32,69,114,114,111,114,58,32,37,115,0 1 ; (!*ENTRY IOERROR EXPR 1) L1821: intern L1821 MOVE 2,1 MOVE 1,L1819 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L1819: <4_30>+<1_18>+L1820 L1823: 26 byte(7)73,47,79,32,69,114,114,111,114,32,111,110,32,99,104,97,110,110,101,108,32,37,100,58,32,37,115,0 2 ; (!*ENTRY CHANNELERROR EXPR 2) L1824: intern L1824 MOVE 3,2 MOVE 2,1 MOVE 1,L1822 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L1822: <4_30>+<1_18>+L1823 end |
Added psl-1983/3-1/kernel/20/error.rel version [988ca13bc1].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/eval.ctl version [21bb0928c8].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "eval"; PathIn "eval.build"; ASMEnd; quit; compile eval.mac, deval.mac |
Added psl-1983/3-1/kernel/20/eval.init version [d64fcdb267].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (FLUID (QUOTE (THROWSIGNAL!* THROWTAG!*))) (GLOBAL (QUOTE (EMSG!*))) (PUT (QUOTE CATCH!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CATCH) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !*CATCH) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (PROGJUMPTABLE!* PROGBODY!*))) (PUT (QUOTE PROG) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE GO) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/3-1/kernel/20/eval.log version [b93fcbd29d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:37:41 BATCON Version 104(4133) GLXLIB Version 1(527) Job EVAL Req #480 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1737 Input from => PS:<PSL.KERNEL.20.EXT>EVAL.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>EVAL.LOG 9:37:41 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:37:41 MONTR @SET TIME-LIMIT 600 9:37:41 MONTR @LOGIN KESSLER SMALL 9:37:44 MONTR Job 12 on TTY224 8-Jun-83 09:37:44 9:37:44 MONTR Previous login at 8-Jun-83 09:36:52 9:37:44 MONTR There is 1 other job logged in as user KESSLER 9:37:52 MONTR @ 9:37:52 MONTR [PS Mounted] 9:37:52 MONTR 9:37:52 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:37:52 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:37:53 MONTR @S:EX-DEC20-CROSS.EXE 9:37:55 USER [29] ASMOut "eval"; 9:37:56 USER ASMOUT: IN files; or type in expressions 9:37:56 USER When all done execute ASMEND; 9:37:58 USER [30] PathIn "eval.build"; 9:37:59 USER % 9:37:59 USER % EVAL.BUILD - Files with Eval and Apply in the interpreter 9:37:59 USER % 9:37:59 USER % Author: Eric Benson 9:37:59 USER % Symbolic Computation Group 9:37:59 USER % Computer Science Dept. 9:37:59 USER % University of Utah 9:37:59 USER % Date: 19 May 1982 9:37:59 USER % Copyright (c) 1982 University of Utah 9:37:59 USER % 9:37:59 USER 9:37:59 USER PathIn "apply-lap.red"$ % low-level function linkage, in LAP 9:38:08 USER PathIn "eval-apply.red"$ % interpreter functions 9:38:20 USER PathIn "catch-throw.red"$ 9:38:20 USER *** Function `CATCH!-ALL' has been redefined 9:38:21 USER *** Function `UNWIND!-ALL' has been redefined 9:38:22 USER *** Function `UNWIND!-PROTECT' has been redefined 9:38:23 USER *** Function `!*CATCH' has been redefined 9:38:28 USER % non-local GOTO mechanism 9:38:28 USER PathIn "prog-and-friends.red"$ % Prog, Go and Return 9:38:32 USER [31] ASMEnd; 9:38:33 USER *** Garbage collection starting 9:38:36 USER *** GC 12: time 1916 ms, 146295 recovered, 239467 free 9:38:43 USER 0 9:38:43 USER [32] quit; 9:38:43 MONTR @compile eval.mac, deval.mac 9:38:46 USER MACRO: .MAIN 9:38:53 USER MACRO: .MAIN 9:38:54 USER 9:38:54 USER EXIT 9:38:54 MONTR @ 9:38:55 MONTR Killed by OPERATOR, TTY 221 9:38:55 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:38:56 MONTR at 8-Jun-83 09:38:55, Used 0:00:41 in 0:01:11 |
Added psl-1983/3-1/kernel/20/eval.mac version [fa40098f52].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L1256 extern L1825 L1828: 29 byte(7)84,111,111,32,109,97,110,121,32,97,114,103,117,109,101,110,116,115,32,116,111,32,102,117,110,99,116,105,111,110,0 2 ; (!*ENTRY CODEAPPLY EXPR 2) L1829: intern L1829 MOVE 6,1 TLZ 6,262080 MOVE 7,2 HRRZI 8,1 L1830: LDB 11,L1826 CAIE 11,9 JRST 0(6) MOVE 9,0(7) MOVEM 9,0(8) MOVE 7,1(7) AOS 8 CAIN 8,6 XMOVEI 8,L0002 CAIG 8,9+L0002 JRST L1830 MOVE 1,L1827 JRST SYMFNC+156 L1826: point 6,7,5 L1827: <4_30>+<1_18>+L1828 L1835: 29 byte(7)84,111,111,32,109,97,110,121,32,97,114,103,117,109,101,110,116,115,32,116,111,32,102,117,110,99,116,105,111,110,0 2 ; (!*ENTRY CODEEVALAPPLY EXPR 2) L1836: intern L1836 PUSH 15,1 PUSH 15,L1831 L1837: LDB 11,L1832 CAIE 11,9 JRST L1838 MOVE 6,0(15) CAMGE 6,L1833 JRST L1839 MOVE 1,0(2) MOVE 2,1(2) PUSH 15,2 PUSHJ 15,SYMFNC+261 POP 15,2 POP 15,3 SOS 3 PUSH 15,1 PUSH 15,3 JRST L1837 L1838: POP 15,3 JRST L1840(3) POP 15,L0002+9 POP 15,L0002+8 POP 15,L0002+7 POP 15,L0002+6 POP 15,L0002+5 POP 15,L0002+4 POP 15,L0002+3 POP 15,L0002+2 POP 15,L0002+1 POP 15,L0002+0 POP 15,5 POP 15,4 POP 15,3 POP 15,2 POP 15,1 L1840: POP 15,6 TLZ 6,262080 JRST 0(6) L1839: MOVE 1,L1834 JRST SYMFNC+156 L1831: 0 L1832: point 6,2,5 L1833: -15 L1834: <4_30>+<1_18>+L1835 2 ; (!*ENTRY BINDEVAL EXPR 2) L1844: intern L1844 PUSH 15,L1841 SETZM 4 MOVE 3,1 L1845: LDB 11,L1842 CAIE 11,9 JRST L1846 MOVE 1,0(2) MOVE 2,1(2) PUSH 15,3 PUSH 15,2 PUSHJ 15,SYMFNC+261 POP 15,2 POP 15,3 POP 15,4 LDB 11,L1843 CAIE 11,9 JRST L1847 AOS 4 MOVE 5,0(3) MOVE 3,1(3) PUSH 15,1 PUSH 15,5 PUSH 15,4 JRST L1845 L1847: LSH 4,1 HRL 4,4 SUB 15,4 SETOM 1 POPJ 15,0 L1846: ADJSP 15,-1 LDB 11,L1843 CAIN 11,9 JRST L1847 MOVE 3,4 L1848: JUMPE 3,L1849 POP 15,1 POP 15,2 PUSH 15,3 PUSH 15,4 PUSHJ 15,SYMFNC+511 POP 15,4 POP 15,3 SOJA 3,L1848 L1849: MOVE 1,4 POPJ 15,0 L1841: 0 L1842: point 6,2,5 L1843: point 6,3,5 L1854: 61 byte(7)73,110,116,101,114,110,97,108,32,101,114,114,111,114,32,105,110,32,102,117,110,99,116,105,111,110,32,99,97,108,108,105,110,103,32,109,101,99,104,97,110,105,115,109,59,32,99,111,110,115,117,108,116,32,97,32,119,105,122,97,114,100,0 0 ; (!*ENTRY COMPILEDCALLINGINTERPRETED EXPR 0) L1855: intern L1855 MOVE 6,10 SUBI 6,SYMFNC+1 TLZ 6,258048 TLO 6,114688 PUSH 15,6 HRRZ 6,6 MOVE 6,SYMPRP(6) L1856: LDB 11,L1850 CAIE 11,9 JRST L1857 MOVE 7,0(6) MOVE 6,1(6) LDB 11,L1851 CAIE 11,9 JRST L1856 MOVE 8,0(7) CAME 8,L1852 JRST L1856 MOVE 7,1(7) ; (!*ENTRY FASTLAMBDAAPPLY EXPR 0) L1858: intern L1858 MOVE 7,1(7) MOVE 6,1(7) MOVE 7,0(7) HRRZI 8,1 MOVE 9,L1256 PUSH 15,9 L1859: LDB 11,L1851 CAIE 11,9 JRST L1860 ADDI 9,2 CAML 9,L1825 JRST SYMFNC+513 MOVE 10,0(7) HRRZM 10,-1(9) MOVE 11,SYMVAL(10) MOVEM 11,0(9) MOVE 11,0(8) MOVEM 11,SYMVAL(10) MOVE 7,1(7) AOS 8 CAIN 8,6 MOVEI 8,L0002 JRST L1859 L1860: MOVEM 9,L1256 MOVE 1,6 PUSHJ 15,SYMFNC+265 EXCH 1,0(15) PUSHJ 15,SYMFNC+514 POP 15,1 ADJSP 15,-1 POPJ 15,0 L1857: MOVE 1,L1853 JRST SYMFNC+156 L1850: point 6,6,5 L1851: point 6,7,5 L1853: <4_30>+<1_18>+L1854 L1852: <30_30>+515 L1864: 34 byte(7)73,108,108,101,103,97,108,32,102,117,110,99,116,105,111,110,97,108,32,102,111,114,109,32,37,114,32,105,110,32,65,112,112,108,121,0 0 ; (!*ENTRY FASTAPPLY EXPR 0) L1865: intern L1865 LDB 7,L1861 TLZ 6,262080 CAIN 7,30 JRST SYMFNC(6) CAIN 7,15 JRST 0(6) CAIE 7,9 JRST L1866 MOVE 7,0(6) CAME 7,L1862 JRST L1866 MOVE 7,6 PUSH 15,0 JRST L1858 L1866: MOVE 1,L1863 MOVE 2,6 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L1861: point 6,6,5 L1863: <4_30>+<1_18>+L1864 L1862: <30_30>+253 L1868: 46 byte(7)85,110,100,101,102,105,110,101,100,32,102,117,110,99,116,105,111,110,32,37,114,32,99,97,108,108,101,100,32,102,114,111,109,32,99,111,109,112,105,108,101,100,32,99,111,100,101,0 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L1869: intern L1869 SOS 10 PUSH 15,10 PUSH 15,1 PUSH 15,2 PUSH 15,3 PUSH 15,4 PUSH 15,5 PUSH 15,L0002+0 PUSH 15,L0002+1 PUSH 15,L0002+2 PUSH 15,L0002+3 PUSH 15,L0002+4 PUSH 15,L0002+5 PUSH 15,L0002+6 PUSH 15,L0002+7 PUSH 15,L0002+8 PUSH 15,L0002+9 SUBI 10,SYMFNC HRLI 10,122880 MOVE 2,10 MOVE 1,L1867 PUSHJ 15,SYMFNC+155 MOVE 2,1 SETZM 1 MOVE 3,0 PUSHJ 15,SYMFNC+236 POP 15,L0002+9 POP 15,L0002+8 POP 15,L0002+7 POP 15,L0002+6 POP 15,L0002+5 POP 15,L0002+4 POP 15,L0002+3 POP 15,L0002+2 POP 15,L0002+1 POP 15,L0002+0 POP 15,5 POP 15,4 POP 15,3 POP 15,2 POP 15,1 POPJ 15,0 L1867: <4_30>+<1_18>+L1868 L1875: 23 byte(7)65,114,103,117,109,101,110,116,32,110,117,109,98,101,114,32,109,105,115,109,97,116,99,104,0 L1876: 29 byte(7)73,108,108,45,102,111,114,109,101,100,32,102,117,110,99,116,105,111,110,32,101,120,112,114,101,115,115,105,111,110,0 ; (!*ENTRY LAMBDAEVALAPPLY EXPR 2) L1877: intern L1877 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1870 CAIE 11,9 JRST L1878 MOVE 6,L1871 CAMN 6,0(1) JRST L1879 L1878: PUSHJ 15,SYMFNC+151 MOVE 3,1 MOVE 2,L1872 HRRZI 1,1103 ADJSP 15,-4 JRST SYMFNC+236 L1879: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+510 MOVEM 1,-2(15) CAME 1,L1873 JRST L1880 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+151 MOVE 3,1 MOVE 2,L1874 HRRZI 1,1203 ADJSP 15,-4 JRST SYMFNC+236 L1880: MOVE 1,0(15) MOVE 1,1(1) MOVE 1,1(1) PUSHJ 15,SYMFNC+265 MOVEM 1,-3(15) SKIPN -2(15) JRST L1881 MOVE 1,-2(15) PUSHJ 15,SYMFNC+517 L1881: MOVE 1,-3(15) ADJSP 15,-4 POPJ 15,0 L1870: point 6,1,5 L1873: -1 L1874: <4_30>+<1_18>+L1875 L1872: <4_30>+<1_18>+L1876 L1871: <30_30>+253 L1890: 23 byte(7)65,114,103,117,109,101,110,116,32,110,117,109,98,101,114,32,109,105,115,109,97,116,99,104,0 L1891: 29 byte(7)73,108,108,45,102,111,114,109,101,100,32,102,117,110,99,116,105,111,110,32,101,120,112,114,101,115,115,105,111,110,0 ; (!*ENTRY LAMBDAAPPLY EXPR 2) L1892: intern L1892 ADJSP 15,9 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1882 CAIE 11,9 JRST L1893 MOVE 6,L1883 CAMN 6,0(1) JRST L1894 L1893: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 2,-2(15) LDB 11,L1884 CAIN 11,9 JRST L1895 MOVE 1,0 JRST L1896 L1895: MOVE 1,0(2) MOVEM 1,-5(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-4(15) MOVEM 3,-3(15) L1897: MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) LDB 11,L1882 CAIN 11,9 JRST L1898 MOVE 1,-3(15) JRST L1896 L1898: MOVE 1,0(1) MOVEM 1,-5(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 7,-4(15) MOVEM 1,1(7) MOVE 2,-4(15) MOVE 2,1(2) MOVEM 2,-4(15) JRST L1897 L1896: MOVE 2,0(15) PUSHJ 15,SYMFNC+278 MOVE 3,1 MOVE 2,L1885 HRRZI 1,1104 ADJSP 15,-9 JRST SYMFNC+236 L1894: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 3,1(1) MOVE 3,0(3) MOVEM 3,-2(15) SETZM -3(15) L1899: LDB 11,L1886 CAIE 11,9 JRST L1900 LDB 11,L1887 CAIE 11,9 JRST L1900 MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,-2(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+511 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 2,1(2) MOVEM 2,-1(15) AOS -3(15) JRST L1899 L1900: LDB 11,L1886 CAIN 11,9 JRST L1901 LDB 11,L1887 CAIE 11,9 JRST L1902 L1901: MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) MOVE 6,-1(15) MOVEM 6,-5(15) LDB 11,L1888 CAIN 11,9 JRST L1903 MOVE 1,0 JRST L1904 L1903: MOVE 1,-5(15) MOVE 1,0(1) MOVEM 1,-8(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVEM 1,-7(15) MOVEM 1,-6(15) L1905: MOVE 1,-5(15) MOVE 1,1(1) MOVEM 1,-5(15) LDB 11,L1882 CAIN 11,9 JRST L1906 MOVE 1,-6(15) JRST L1904 L1906: MOVE 1,0(1) MOVEM 1,-8(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 7,-7(15) MOVEM 1,1(7) MOVE 2,-7(15) MOVE 2,1(2) MOVEM 2,-7(15) JRST L1905 L1904: MOVE 2,0(15) PUSHJ 15,SYMFNC+278 MOVE 3,1 MOVE 2,L1889 HRRZI 1,1204 ADJSP 15,-9 JRST SYMFNC+236 L1902: MOVE 1,0(15) MOVE 1,1(1) MOVE 1,1(1) PUSHJ 15,SYMFNC+265 MOVEM 1,-4(15) SKIPN -3(15) JRST L1907 MOVE 1,-3(15) PUSHJ 15,SYMFNC+517 L1907: MOVE 1,-4(15) ADJSP 15,-9 POPJ 15,0 L1882: point 6,1,5 L1884: point 6,2,5 L1886: point 6,-2(15),5 L1887: point 6,-1(15),5 L1888: point 6,-5(15),5 L1889: <4_30>+<1_18>+L1890 L1885: <4_30>+<1_18>+L1891 L1883: <30_30>+253 L1915: 29 byte(7)73,108,108,45,102,111,114,109,101,100,32,102,117,110,99,116,105,111,110,32,101,120,112,114,101,115,115,105,111,110,0 L1916: 26 byte(7)37,114,32,105,115,32,97,110,32,117,110,100,101,102,105,110,101,100,32,102,117,110,99,116,105,111,110,0 2 ; (!*ENTRY APPLY EXPR 2) APPLY: intern APPLY ADJSP 15,9 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1908 CAIE 11,30 JRST L1917 MOVEM 0,-2(15) MOVEM 0,-3(15) PUSHJ 15,SYMFNC+519 CAMN 1,0 JRST L1918 MOVE 2,0(15) MOVE 1,L1909 PUSHJ 15,SYMFNC+155 MOVEM 1,-4(15) MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) MOVE 6,-1(15) MOVEM 6,-5(15) LDB 11,L1910 CAIN 11,9 JRST L1919 MOVE 1,0 JRST L1920 L1919: MOVE 1,-5(15) MOVE 1,0(1) MOVEM 1,-8(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,-7(15) MOVEM 2,-6(15) L1921: MOVE 1,-5(15) MOVE 1,1(1) MOVEM 1,-5(15) LDB 11,L1908 CAIN 11,9 JRST L1922 MOVE 1,-6(15) JRST L1920 L1922: MOVE 1,0(1) MOVEM 1,-8(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 7,-7(15) MOVEM 1,1(7) MOVE 2,-7(15) MOVE 2,1(2) MOVEM 2,-7(15) JRST L1921 L1920: MOVE 2,0(15) PUSHJ 15,SYMFNC+278 MOVE 3,1 MOVE 2,-4(15) HRRZI 1,1002 JRST L1923 L1918: MOVE 2,0(15) TLZ 2,258048 TLZ 2,258048 TLO 2,114688 MOVEM 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+520 CAMN 1,0 JRST L1924 MOVE 1,0(15) PUSHJ 15,SYMFNC+521 MOVE 2,-1(15) PUSHJ 15,SYMFNC+508 JRST L1925 L1924: MOVE 2,L1911 MOVE 1,0(15) PUSHJ 15,SYMFNC+522 MOVE 2,-1(15) PUSHJ 15,L1892 L1925: MOVEM 1,-3(15) JRST L1926 L1917: LDB 11,L1908 CAIE 11,15 JRST L1927 ADJSP 15,-9 JRST SYMFNC+508 L1927: LDB 11,L1908 CAIE 11,9 JRST L1928 MOVE 6,L1912 CAME 6,0(1) JRST L1928 ADJSP 15,-9 JRST L1892 L1928: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 2,-2(15) LDB 11,L1913 CAIN 11,9 JRST L1929 MOVE 1,0 JRST L1930 L1929: MOVE 1,0(2) MOVEM 1,-5(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-4(15) MOVEM 3,-3(15) L1931: MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) LDB 11,L1908 CAIN 11,9 JRST L1932 MOVE 1,-3(15) JRST L1930 L1932: MOVE 1,0(1) MOVEM 1,-5(15) PUSHJ 15,SYMFNC+234 PUSHJ 15,SYMFNC+172 MOVE 7,-4(15) MOVEM 1,1(7) MOVE 2,-4(15) MOVE 2,1(2) MOVEM 2,-4(15) JRST L1931 L1930: MOVE 2,0(15) PUSHJ 15,SYMFNC+278 MOVE 3,1 MOVE 2,L1914 HRRZI 1,1102 L1923: ADJSP 15,-9 JRST SYMFNC+236 L1926: ADJSP 15,-9 POPJ 15,0 L1908: point 6,1,5 L1910: point 6,-5(15),5 L1913: point 6,2,5 L1914: <4_30>+<1_18>+L1915 L1912: <30_30>+253 L1911: <30_30>+515 L1909: <4_30>+<1_18>+L1916 L1943: 31 byte(7)73,108,108,45,102,111,114,109,101,100,32,101,120,112,114,101,115,115,105,111,110,32,105,110,32,69,118,97,108,32,37,114,0 L1944: 23 byte(7)85,110,107,110,111,119,110,32,102,117,110,99,116,105,111,110,32,116,121,112,101,32,37,114,0 L1945: 26 byte(7)37,114,32,105,115,32,97,110,32,117,110,100,101,102,105,110,101,100,32,102,117,110,99,116,105,111,110,0 1 ; (!*ENTRY EVAL EXPR 1) EVAL: intern EVAL ADJSP 15,5 MOVEM 1,0(15) LDB 11,L1933 CAIN 11,9 JRST L1946 LDB 11,L1933 CAIE 11,30 JRST L1947 ADJSP 15,-5 JRST SYMFNC+523 L1946: MOVEM 0,-1(15) MOVE 2,0(1) MOVEM 2,-1(15) LDB 11,L1934 CAIE 11,30 JRST L1948 MOVE 1,2 PUSHJ 15,SYMFNC+519 CAMN 1,0 JRST L1949 MOVE 2,-1(15) MOVE 1,L1935 PUSHJ 15,SYMFNC+155 MOVE 3,0(15) MOVE 2,1 HRRZI 1,1300 ADJSP 15,-5 JRST SYMFNC+236 L1949: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+524 MOVEM 1,-2(15) MOVE 2,-1(15) TLZ 2,258048 TLZ 2,258048 TLO 2,114688 MOVEM 2,-3(15) CAME 1,0 JRST L1950 MOVE 1,-1(15) PUSHJ 15,SYMFNC+520 CAMN 1,0 JRST L1951 MOVE 1,-1(15) PUSHJ 15,SYMFNC+521 MOVE 2,0(15) MOVE 2,1(2) PUSHJ 15,SYMFNC+509 JRST L1952 L1951: MOVE 2,L1936 MOVE 1,-1(15) PUSHJ 15,SYMFNC+522 MOVE 2,0(15) MOVE 2,1(2) PUSHJ 15,L1877 JRST L1952 L1950: CAME 1,L1937 JRST L1953 MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) TLZ 2,258048 PUSHJ 15,SYMFNC(2) JRST L1952 L1953: CAME 1,L1938 JRST L1954 MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+245 MOVE 2,-1(15) TLZ 2,258048 PUSHJ 15,SYMFNC(2) JRST L1952 L1954: CAME 1,L1939 JRST L1955 MOVE 2,-1(15) MOVE 1,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC(2) PUSHJ 15,EVAL JRST L1952 L1955: MOVE 2,1 MOVE 1,L1940 PUSHJ 15,SYMFNC+155 MOVE 3,0(15) MOVE 2,1 HRRZI 1,1301 PUSHJ 15,SYMFNC+236 L1952: MOVEM 1,-4(15) JRST L1947 L1948: LDB 11,L1934 CAIE 11,15 JRST L1956 MOVE 2,1(1) MOVE 1,-1(15) ADJSP 15,-5 JRST SYMFNC+509 L1956: LDB 11,L1934 CAIE 11,9 JRST L1957 MOVE 6,L1941 CAME 6,0(2) JRST L1957 MOVE 2,1(1) MOVE 1,-1(15) ADJSP 15,-5 JRST L1877 L1957: MOVE 2,1 MOVE 1,L1942 PUSHJ 15,SYMFNC+155 MOVE 3,0(15) MOVE 2,1 HRRZI 1,1302 ADJSP 15,-5 JRST SYMFNC+236 L1947: ADJSP 15,-5 POPJ 15,0 L1933: point 6,1,5 L1934: point 6,2,5 L1942: <4_30>+<1_18>+L1943 L1941: <30_30>+253 L1940: <4_30>+<1_18>+L1944 L1939: <30_30>+256 L1938: <30_30>+258 L1937: <30_30>+254 L1936: <30_30>+515 L1935: <4_30>+<1_18>+L1945 L1966: <30_30>+525 <30_30>+128 L1967: <30_30>+84 <9_30>+<1_18>+L1966 L1968: <30_30>+244 <9_30>+<1_18>+L1969 L1969: <30_30>+526 <9_30>+<1_18>+L1966 1 ; (!*ENTRY CATCH!-ALL MACRO 1) L1970: intern L1970 ADJSP 15,2 MOVE 2,1(1) MOVE 2,1(2) MOVE 1,1(1) MOVE 1,0(1) MOVEM 2,0(15) MOVE 3,L1958 MOVE 2,1 MOVE 1,L1959 PUSHJ 15,SYMFNC+235 MOVE 2,1 MOVE 1,L1960 PUSHJ 15,SYMFNC+249 MOVE 3,L1961 MOVE 2,1 MOVE 1,L1962 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1963 MOVE 1,L1964 PUSHJ 15,SYMFNC+235 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 1,0 PUSHJ 15,SYMFNC+151 MOVE 2,L1965 PUSHJ 15,SYMFNC+278 MOVE 2,1 MOVE 1,-1(15) ADJSP 15,-2 JRST SYMFNC+249 L1965: <30_30>+498 L1964: <30_30>+253 L1963: <9_30>+<1_18>+L1966 L1962: <30_30>+270 L1961: <9_30>+<1_18>+L1967 L1960: <30_30>+500 L1959: <30_30>+518 L1958: <9_30>+<1_18>+L1968 L1976: <30_30>+525 <30_30>+128 L1977: <30_30>+244 <9_30>+<1_18>+L1978 L1978: <9_30>+<1_18>+L1979 <9_30>+<1_18>+L1976 L1979: <30_30>+266 <9_30>+<1_18>+L1980 L1980: <30_30>+500 <9_30>+<1_18>+L1981 L1981: <30_30>+526 <30_30>+128 1 ; (!*ENTRY UNWIND!-ALL MACRO 1) L1982: intern L1982 ADJSP 15,2 MOVE 2,1(1) MOVE 2,1(2) MOVE 1,1(1) MOVE 1,0(1) MOVEM 2,0(15) MOVE 3,L1971 MOVE 2,1 MOVE 1,L1972 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L1973 MOVE 1,L1974 PUSHJ 15,SYMFNC+235 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 1,0 PUSHJ 15,SYMFNC+151 MOVE 2,L1975 PUSHJ 15,SYMFNC+278 MOVE 2,1 MOVE 1,-1(15) ADJSP 15,-2 JRST SYMFNC+249 L1975: <30_30>+498 L1974: <30_30>+253 L1973: <9_30>+<1_18>+L1976 L1972: <30_30>+518 L1971: <9_30>+<1_18>+L1977 L1991: <30_30>+246 <9_30>+<1_18>+L1996 L1992: <30_30>+525 <30_30>+128 L1993: <30_30>+500 <9_30>+<1_18>+L1997 L1994: <30_30>+529 <9_30>+<1_18>+L1998 L1995: <30_30>+270 <9_30>+<1_18>+L1999 L1996: <30_30>+530 <30_30>+128 L1997: <30_30>+526 <30_30>+128 L1998: <30_30>+531 <30_30>+128 L1999: <9_30>+<1_18>+L2000 <9_30>+<1_18>+L2001 L2000: <30_30>+529 <9_30>+<1_18>+L2002 L2001: <9_30>+<1_18>+L2003 <30_30>+128 L2002: <9_30>+<1_18>+L2004 <30_30>+128 L2003: <30_30>+84 <9_30>+<1_18>+L1992 L2004: <30_30>+532 <9_30>+<1_18>+L2005 L2005: <30_30>+531 <9_30>+<1_18>+L1992 1 ; (!*ENTRY UNWIND!-PROTECT MACRO 1) L2006: intern L2006 ADJSP 15,2 MOVE 2,1(1) MOVE 2,1(2) MOVE 1,1(1) MOVE 1,0(1) MOVEM 1,0(15) MOVE 1,L1983 PUSHJ 15,SYMFNC+151 MOVE 4,L1984 MOVE 3,1 MOVE 2,L1985 MOVE 1,L1986 PUSHJ 15,SYMFNC+250 MOVE 2,L1987 PUSHJ 15,SYMFNC+151 MOVE 3,1 MOVE 2,L1988 MOVE 1,L1986 PUSHJ 15,SYMFNC+235 MOVEM 1,-1(15) MOVE 3,0(15) MOVE 2,L1989 MOVE 1,L1990 PUSHJ 15,SYMFNC+235 MOVE 2,1 MOVE 1,-1(15) ADJSP 15,-2 JRST SYMFNC+249 L1990: <30_30>+498 L1989: <9_30>+<1_18>+L1991 L1988: <9_30>+<1_18>+L1992 L1987: <9_30>+<1_18>+L1993 L1986: <30_30>+253 L1985: <9_30>+<1_18>+L1994 L1984: <9_30>+<1_18>+L1995 L1983: <30_30>+264 1 ; (!*ENTRY CATCH FEXPR 1) CATCH: intern CATCH ADJSP 15,3 MOVE 2,1(1) MOVE 1,0(1) MOVEM 2,0(15) PUSHJ 15,SYMFNC+261 PUSHJ 15,SYMFNC+499 MOVEM 1,-1(15) CAME 0,SYMVAL+500 JRST L2007 MOVE 1,0(15) PUSHJ 15,SYMFNC+265 MOVEM 1,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+501 MOVE 1,-2(15) L2007: ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY !*CATCH MACRO 1) L2009: intern L2009 MOVE 2,1(1) MOVE 1,L2008 JRST SYMFNC+151 L2008: <30_30>+498 2 ; (!*ENTRY !*THROW EXPR 2) L2010: intern L2010 JRST SYMFNC+495 extern L2011 extern L2012 1 ; (!*ENTRY CATCHSETUP EXPR 1) L2013: intern L2013 MOVE 2,0(15) MOVE 3,15 JRST L2014 L2017: 19 byte(7)67,97,116,99,104,32,115,116,97,99,107,32,111,118,101,114,102,108,111,119,0 L2018: 35 byte(7)67,97,116,99,104,45,116,104,114,111,119,32,115,116,97,99,107,32,111,118,101,114,102,108,111,119,32,40,119,97,114,110,105,110,103,41,0 ; (!*ENTRY CATCHSETUPAUX EXPR 3) L2014: intern L2014 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 6,L2012 MOVEM 6,-3(15) HRRZI 7,4 ADDM 7,L2012 SETZM 4 ADDI 4,1580+L2011 CAMLE 4,L2012 JRST L2019 CAME 4,L2012 JRST L2020 MOVE 3,0 MOVE 2,L2015 HRRZI 1,99 PUSHJ 15,SYMFNC+236 L2020: SETZM 1 ADDI 1,1600+L2011 CAMLE 1,L2012 JRST L2019 MOVE 6,L2016 MOVEM 6,SYMVAL+483 PUSHJ 15,SYMFNC+536 L2019: MOVE 7,L2012 MOVE 6,0(15) MOVEM 6,0(7) MOVE 2,L2012 MOVE 6,-1(15) MOVEM 6,1(2) MOVE 6,-2(15) MOVEM 6,2(2) PUSHJ 15,SYMFNC+537 MOVE 3,L2012 MOVEM 1,3(3) MOVE 2,0 MOVEM 2,SYMVAL+500 MOVE 1,-3(15) ADJSP 15,-4 POPJ 15,0 L2016: <4_30>+<1_18>+L2017 L2015: <4_30>+<1_18>+L2018 1 ; (!*ENTRY !%UNCATCH EXPR 1) L2021: intern L2021 MOVEM 1,L2012 MOVE 1,0 MOVEM 1,SYMVAL+500 POPJ 15,0 0 ; (!*ENTRY !%CLEAR!-CATCH!-STACK EXPR 0) L2022: intern L2022 SETZM 1 ADDI 1,L2011 MOVEM 1,L2012 POPJ 15,0 2 ; (!*ENTRY !%THROW EXPR 2) %THROW: intern %THROW ADJSP 15,5 L2024: MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 6,L2012 MOVE 6,0(6) MOVEM 6,-2(15) CAMN 0,-2(15) JRST L2025 MOVE 6,-2(15) CAMN 6,L2023 JRST L2025 CAMN 1,-2(15) JRST L2025 MOVNI 7,4 ADDM 7,L2012 JRST L2024 L2025: MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 4,L2012 MOVE 6,1(4) MOVEM 6,-3(15) MOVE 6,2(4) MOVEM 6,-4(15) MOVE 1,3(4) PUSHJ 15,SYMFNC+514 MOVNI 7,4 ADDM 7,L2012 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+500 MOVE 6,0(15) MOVEM 6,SYMVAL+526 MOVE 3,-4(15) MOVE 2,-3(15) MOVE 1,-1(15) ADJSP 15,-5 JRST L2026 L2023: <30_30>+530 ; (!*ENTRY THROWAUX EXPR 3) L2026: intern L2026 MOVE 15,3 MOVEM 2,0(15) POPJ 15,0 2 ; (!*ENTRY THROW EXPR 2) THROW: intern THROW MOVE 3,L2012 JRST L2027 L2032: 24 byte(7)69,114,114,111,114,32,110,111,116,32,119,105,116,104,105,110,32,69,114,114,111,114,83,101,116,0 L2033: 30 byte(7)67,97,116,99,104,32,116,97,103,32,37,114,32,110,111,116,32,102,111,117,110,100,32,105,110,32,84,104,114,111,119,0 ; (!*ENTRY FINDCATCHMARKANDTHROW EXPR 3) L2027: intern L2027 ADJSP 15,4 L2034: MOVEM 1,0(15) MOVEM 2,-1(15) SETZM 4 ADDI 4,L2011 CAME 3,4 JRST L2035 CAMN 1,L2028 JRST L2036 MOVE 2,1 MOVE 1,L2029 PUSHJ 15,SYMFNC+155 MOVEM 1,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L2030 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,-2(15) HRRZI 1,99 ADJSP 15,-4 JRST SYMFNC+236 L2036: MOVE 1,L2031 ADJSP 15,-4 JRST SYMFNC+380 L2035: CAMN 0,0(3) JRST L2037 CAME 1,0(3) JRST L2038 L2037: ADJSP 15,-4 JRST SYMFNC+532 L2038: SUBI 3,4 JRST L2034 L2031: <4_30>+<1_18>+L2032 L2030: <30_30>+495 L2029: <4_30>+<1_18>+L2033 L2028: <30_30>+496 1 ; (!*ENTRY PROG FEXPR 1) PROG: intern PROG ADJSP 15,4 JSP 10,SYMFNC+443 byte(18)1,539 MOVEM 0,0(15) MOVEM 0,-1(15) JSP 10,SYMFNC+443 byte(18)0,540 LDB 11,L2039 CAIN 11,9 JRST L2044 MOVE 1,0 JRST L2045 L2044: SETZM 0(15) MOVE 2,SYMVAL+539 MOVE 2,0(2) MOVEM 2,-2(15) L2046: LDB 11,L2040 CAIE 11,9 JRST L2047 MOVE 1,-2(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+542 MOVE 1,0(15) PUSHJ 15,SYMFNC+241 MOVEM 1,0(15) MOVE 2,-2(15) MOVE 2,1(2) MOVEM 2,-2(15) JRST L2046 L2047: MOVE 1,SYMVAL+539 MOVE 1,1(1) MOVEM 1,SYMVAL+539 MOVEM 1,-2(15) L2048: LDB 11,L2040 CAIE 11,9 JRST L2049 MOVE 1,-2(15) LDB 11,L2041 CAIE 11,30 JRST L2050 MOVE 2,SYMVAL+540 PUSHJ 15,SYMFNC+151 MOVEM 1,SYMVAL+540 L2050: MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) JRST L2048 L2049: LDB 11,L2039 CAIE 11,9 JRST L2051 MOVE 6,SYMVAL+539 LDB 11,L2042 CAIN 11,30 JRST L2052 L2051: MOVE 1,0 JRST L2053 L2052: MOVE 1,SYMVAL+539 MOVE 1,1(1) MOVEM 1,SYMVAL+539 JRST L2049 L2053: MOVE 1,SYMVAL+84 LDB 11,L2039 CAIN 11,9 JRST L2054 MOVE 1,0 L2054: CAMN 1,0 JRST L2055 MOVE 1,L2043 PUSHJ 15,SYMFNC+499 MOVEM 1,-2(15) CAME 0,SYMVAL+500 JRST L2056 MOVE 1,SYMVAL+539 MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVEM 1,-3(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+501 MOVE 1,-3(15) L2056: MOVEM 1,-1(15) CAME 0,SYMVAL+500 JRST L2049 MOVE 1,0 MOVEM 1,-1(15) MOVE 2,SYMVAL+539 MOVE 2,1(2) MOVEM 2,SYMVAL+539 JRST L2049 L2055: MOVE 1,0(15) PUSHJ 15,SYMFNC+517 MOVE 1,-1(15) L2045: JSP 10,SYMFNC+447 1 JSP 10,SYMFNC+447 1 ADJSP 15,-4 POPJ 15,0 L2039: point 6,<SYMVAL+539>,5 L2040: point 6,-2(15),5 L2041: point 6,0(1),5 L2042: point 6,0(6),5 L2043: <30_30>+543 L2061: 39 byte(7)71,79,32,97,116,116,101,109,112,116,101,100,32,111,117,116,115,105,100,101,32,116,104,101,32,115,99,111,112,101,32,111,102,32,97,32,80,82,79,71,0 L2062: 41 byte(7)37,114,32,105,115,32,110,111,116,32,97,32,108,97,98,101,108,32,119,105,116,104,105,110,32,116,104,101,32,99,117,114,114,101,110,116,32,115,99,111,112,101,0 1 ; (!*ENTRY GO FEXPR 1) GO: intern GO ADJSP 15,3 MOVEM 1,0(15) MOVEM 0,-1(15) CAMN 0,SYMVAL+539 JRST L2063 MOVE 2,SYMVAL+540 MOVE 1,0(1) PUSHJ 15,SYMFNC+335 MOVEM 1,-1(15) CAME 1,0 JRST L2064 MOVE 2,0(15) MOVE 2,0(2) MOVE 1,L2057 PUSHJ 15,SYMFNC+155 MOVEM 1,-2(15) MOVE 2,0(15) MOVE 1,L2058 PUSHJ 15,SYMFNC+151 MOVE 3,1 MOVE 2,-2(15) HRRZI 1,3001 ADJSP 15,-3 JRST SYMFNC+236 L2064: MOVEM 1,SYMVAL+539 MOVE 2,0 MOVE 1,L2059 ADJSP 15,-3 JRST SYMFNC+535 L2063: MOVE 2,L2058 PUSHJ 15,SYMFNC+278 MOVE 3,1 MOVE 2,L2060 HRRZI 1,3101 ADJSP 15,-3 JRST SYMFNC+236 L2060: <4_30>+<1_18>+L2061 L2059: <30_30>+543 L2058: <30_30>+544 L2057: <4_30>+<1_18>+L2062 L2068: 43 byte(7)82,69,84,85,82,78,32,97,116,116,101,109,112,116,101,100,32,111,117,116,115,105,100,101,32,116,104,101,32,115,99,111,112,101,32,111,102,32,97,32,80,82,79,71,0 1 ; (!*ENTRY RETURN EXPR 1) RETURN: intern RETURN CAMN 0,SYMVAL+539 JRST L2069 MOVE 2,0 MOVEM 2,SYMVAL+539 MOVE 2,1 MOVE 1,L2065 JRST SYMFNC+535 L2069: PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2066 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L2067 HRRZI 1,3102 JRST SYMFNC+236 L2067: <4_30>+<1_18>+L2068 L2066: <30_30>+545 L2065: <30_30>+543 end |
Added psl-1983/3-1/kernel/20/eval.rel version [1d558525dd].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/extra.ctl version [0f5918030f].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "extra"; PathIn "extra.build"; ASMEnd; quit; compile extra.mac, dextra.mac |
Added psl-1983/3-1/kernel/20/extra.init version [f580ab836a].
> > | 1 2 | (FLUID (QUOTE (SYSTEM_LIST!*))) (COPYD (QUOTE EXITLISP) (QUOTE QUIT)) |
Added psl-1983/3-1/kernel/20/extra.log version [9065039881].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:38:56 BATCON Version 104(4133) GLXLIB Version 1(527) Job EXTRA Req #481 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1738 Input from => PS:<PSL.KERNEL.20.EXT>EXTRA.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>EXTRA.LOG 9:38:57 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:38:57 MONTR @SET TIME-LIMIT 600 9:38:57 MONTR @LOGIN KESSLER SMALL 9:39:00 MONTR Job 12 on TTY224 8-Jun-83 09:39:00 9:39:00 MONTR Previous login at 8-Jun-83 09:37:44 9:39:00 MONTR There is 1 other job logged in as user KESSLER 9:39:07 MONTR @ 9:39:07 MONTR [PS Mounted] 9:39:07 MONTR 9:39:07 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:39:07 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:39:08 MONTR @S:EX-DEC20-CROSS.EXE 9:39:10 USER [32] ASMOut "extra"; 9:39:11 USER ASMOUT: IN files; or type in expressions 9:39:11 USER When all done execute ASMEND; 9:39:15 USER [33] PathIn "extra.build"; 9:39:15 USER % 9:39:15 USER % EXTRA.BUILD - System-dependent extras 9:39:15 USER % 9:39:15 USER % Author: Eric Benson 9:39:15 USER % Symbolic Computation Group 9:39:15 USER % Computer Science Dept. 9:39:15 USER % University of Utah 9:39:15 USER % Date: 19 May 1982 9:39:17 USER % Copyright (c) 1982 University of Utah 9:39:17 USER % 9:39:17 USER 9:39:17 USER PathIn "timc.red"$ % System time routine 9:39:19 USER PathIn "system-extras.red"$ % Random system-specific routines 9:39:22 USER PathIn "trap.red"$ % Interrupt handler 9:39:22 USER PathIn "dumplisp.red"$ % Core saver 9:39:25 USER [34] ASMEnd; 9:39:25 USER *** Garbage collection starting 9:39:29 USER *** GC 13: time 2196 ms, 16480 recovered, 239324 free 9:39:34 USER 0 9:39:34 USER [35] quit; 9:39:35 MONTR @compile extra.mac, dextra.mac 9:39:37 USER MACRO: .MAIN 9:39:42 USER MACRO: .MAIN 9:39:43 USER 9:39:43 USER EXIT 9:39:43 MONTR @ 9:39:44 MONTR Killed by OPERATOR, TTY 221 9:39:44 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:39:44 MONTR at 8-Jun-83 09:39:44, Used 0:00:19 in 0:00:43 |
Added psl-1983/3-1/kernel/20/extra.mac version [7ac1960ca2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC MOVNI 1,5 RUNTM POPJ 15,0 L2071: 8 byte(7)67,111,110,116,105,110,117,101,100,0 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT HALTF MOVE 1,L2070 POPJ 15,0 L2070: <4_30>+<1_18>+L2071 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE HRRZI 1,8 PUSHJ 15,SYMFNC+145 MOVE 4,1 AOS 1 TLO 1,200704 SETOM 2 HRLZI 3,1 ODTIM MOVE 1,4 TLZ 1,258048 TLO 1,16384 POPJ 15,0 1 ; (!*ENTRY RETURNADDRESSP EXPR 1) L2072: intern L2072 MOVE 5,1 XMOVEI 2,SYMFNC HRRZ 2,2 MOVE 3,2 HLRZ 1,1 CAIN 1,102400 JRST L2073 MOVE 1,0 JRST L2074 L2073: MOVE 1,SYMVAL+84 L2074: CAMN 1,0 JRST L2075 HLRZ 1,-1(5) CAIN 1,90592 JRST L2076 MOVE 1,0 JRST L2077 L2076: MOVE 1,SYMVAL+84 L2077: CAMN 1,0 JRST L2075 HRRZ 1,-1(5) SUB 1,2 MOVE 4,1 JUMPG 1,L2078 MOVE 1,0 JRST L2079 L2078: MOVE 1,SYMVAL+84 L2079: CAMN 1,0 JRST L2075 MOVE 1,SYMVAL+84 CAIGE 4,8000 JRST L2080 MOVE 1,0 L2080: CAMN 1,0 JRST L2075 MOVE 1,4 HRLI 1,122880 L2075: POPJ 15,0 extern L1080 extern L1082 extern L1110 extern L1111 extern L2081 L2084: 36 byte(7)68,117,109,112,108,105,115,112,32,114,101,113,117,105,114,101,115,32,97,32,102,105,108,101,110,97,109,101,32,97,114,103,117,109,101,110,116,0 1 ; (!*ENTRY DUMPLISP EXPR 1) L2085: intern L2085 PUSH 15,1 LDB 11,L2082 CAIN 11,4 JRST L2086 MOVE 1,L2083 PUSHJ 15,SYMFNC+156 L2086: PUSHJ 15,SYMFNC+390 MOVE 2,L1082 MOVE 1,L1080 PUSHJ 15,SYMFNC+420 MOVE 2,L1111 MOVE 1,L1110 PUSHJ 15,SYMFNC+420 MOVE 2,L2081 HRRZ 1,15 IOR 1,[262144] ADDI 1,10 PUSHJ 15,SYMFNC+420 MOVE 1,0(15) ADJSP 15,-1 JRST L2087 L2082: point 6,1,5 L2083: <4_30>+<1_18>+L2084 2 ; (!*ENTRY UNMAP!-SPACE EXPR 2) L2088: intern L2088 ADJSP 15,3 MOVEM 1,-2(15) MOVEM 2,-1(15) MOVE 3,1 ADDI 3,511 LSH 3,-9 MOVEM 3,0(15) MOVE 4,2 SUBI 4,512 LSH 4,-9 MOVE 5,4 CAML 3,4 JRST L2089 MOVE 2,4 SUB 2,3 MOVE 1,3 ADJSP 15,-3 JRST L2090 L2089: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY UNMAP!-PAGES EXPR 2) L2090: intern L2090 HRLZI 3,131072 HRR 3,2 HRLZI 2,131072 HRR 2,1 SETOM 1 PMAP POPJ 15,0 L2092: 31 byte(7)67,111,117,108,100,110,39,116,32,71,84,74,70,78,32,96,37,119,39,32,102,111,114,32,68,117,109,112,108,105,115,112,0 ; (!*ENTRY SAVE!-INTO!-FILE EXPR 1) L2087: intern L2087 MOVE 5,1 MOVE 2,1 TLZ 2,258048 TLO 2,221184 HRLZI 1,131073 GTJFN JRST L2093 HRLI 1,131072 HRRZI 2,176128 TLO 2,131072 HRRZI 3,512 SSAVE SETZM 1 POPJ 15,0 L2093: MOVE 1,L2091 MOVE 2,5 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L2091: <4_30>+<1_18>+L2092 end |
Added psl-1983/3-1/kernel/20/extra.rel version [bd0d2b38e4].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/fasl.ctl version [2c19871727].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "fasl"; PathIn "fasl.build"; ASMEnd; quit; compile fasl.mac, dfasl.mac |
Added psl-1983/3-1/kernel/20/fasl.init version [5c9de73b1d].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (FLUID (QUOTE (LOADDIRECTORIES!* LOADEXTENSIONS!* PENDINGLOADS!* !*LOWER !*REDEFMSG !*USERMODE !*INSIDELOAD !*VERBOSELOAD !*PRINTLOADNAMES OPTIONS!*))) (PUT (QUOTE LOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE RELOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE PP) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DEFSTRUCT) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE HELP) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE CREF) (QUOTE SIMPFG) (QUOTE ((T (CREFON)) (NIL (CREFOFF))))) (PUT (QUOTE SYSLISP) (QUOTE SIMPFG) (QUOTE ((T (LOAD SYSLISP))))) |
Added psl-1983/3-1/kernel/20/fasl.log version [d38337b520].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/fasl.mac version [cb7f55ab9c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L2096: 34 byte(7)67,111,117,108,100,110,39,116,32,111,112,101,110,32,98,105,110,97,114,121,32,102,105,108,101,32,102,111,114,32,105,110,112,117,116,0 1 ; (!*ENTRY BINARYOPENREAD EXPR 1) L2097: intern L2097 ADJSP 15,2 MOVEM 1,0(15) MOVE 3,[-30064705536] MOVE 2,[8590196736] PUSHJ 15,SYMFNC+550 MOVEM 1,-1(15) JUMPN 1,L2098 MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2094 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L2095 HRRZI 1,99 ADJSP 15,-2 JRST SYMFNC+236 L2098: ADJSP 15,-2 POPJ 15,0 L2095: <4_30>+<1_18>+L2096 L2094: <30_30>+549 L2101: 35 byte(7)67,111,117,108,100,110,39,116,32,111,112,101,110,32,98,105,110,97,114,121,32,102,105,108,101,32,102,111,114,32,111,117,116,112,117,116,0 1 ; (!*ENTRY BINARYOPENWRITE EXPR 1) L2102: intern L2102 ADJSP 15,2 MOVEM 1,0(15) MOVE 3,[-30064738304] MOVE 2,[-17179607040] PUSHJ 15,SYMFNC+550 MOVEM 1,-1(15) JUMPN 1,L2103 MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2099 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,L2100 HRRZI 1,99 ADJSP 15,-2 JRST SYMFNC+236 L2103: ADJSP 15,-2 POPJ 15,0 L2100: <4_30>+<1_18>+L2101 L2099: <30_30>+551 1 ; (!*ENTRY VALUECELLLOCATION EXPR 1) L2104: intern L2104 CAME 0,SYMVAL+553 JRST L2105 TLZ 1,258048 ADDI 1,SYMVAL POPJ 15,0 L2105: HRRZI 6,2 MOVEM 6,SYMVAL+554 PUSHJ 15,SYMFNC+555 MOVE 2,1 HRRZI 1,2 JRST SYMFNC+556 1 ; (!*ENTRY EXTRAREGLOCATION EXPR 1) L2106: intern L2106 MOVE 1,1(1) MOVE 1,0(1) CAME 0,SYMVAL+553 JRST L2107 ADDI 1,-6+L0002 POPJ 15,0 L2107: HRRZI 6,2 MOVEM 6,SYMVAL+554 MOVE 2,1 ADDI 2,8150 HRRZI 1,2 JRST SYMFNC+556 1 ; (!*ENTRY FUNCTIONCELLLOCATION EXPR 1) L2108: intern L2108 CAME 0,SYMVAL+553 JRST L2109 TLZ 1,258048 ADDI 1,SYMFNC POPJ 15,0 L2109: HRRZI 6,2 MOVEM 6,SYMVAL+554 PUSHJ 15,SYMFNC+555 MOVE 2,1 HRRZI 1,3 JRST SYMFNC+556 extern L2110 extern L2111 L2121: 27 byte(7)37,114,32,105,115,32,110,111,116,32,97,32,102,97,115,108,32,102,111,114,109,97,116,32,102,105,108,101,0 1 ; (!*ENTRY FASLIN EXPR 1) FASLIN: intern FASLIN ADJSP 15,16 MOVEM 1,0(15) MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) MOVEM 0,-8(15) MOVEM 0,-9(15) MOVEM 0,-10(15) MOVEM 0,-11(15) MOVEM 0,-12(15) MOVEM 0,-14(15) PUSHJ 15,SYMFNC+549 MOVEM 1,-1(15) BIN MOVE 1,2 MOVEM 1,-2(15) CAIN 1,2099 JRST L2122 MOVE 2,0(15) MOVE 1,L2112 PUSHJ 15,SYMFNC+155 MOVEM 1,-15(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2113 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,-15(15) HRRZI 1,99 PUSHJ 15,SYMFNC+236 L2122: MOVE 1,-1(15) BIN MOVE 1,2 MOVEM 1,-3(15) SETZM 1 PUSHJ 15,SYMFNC+392 MOVEM 1,-13(15) MOVE 1,-3(15) AOS 1 PUSHJ 15,SYMFNC+392 MOVEM 1,-4(15) SETZM -15(15) L2123: MOVE 6,-15(15) CAMLE 6,-3(15) JRST L2124 MOVE 1,-1(15) BIN MOVE 1,2 MOVEM 1,L2110 HRRZI 2,5 MOVE 1,L2110 ADDI 1,6 IDIV 1,2 MOVE 3,1 SETZM 2 ADDI 2,1+L2110 MOVE 1,-1(15) HRLI 2,149760 MOVNS 3 SIN XMOVEI 1,L2110 TLZ 1,258048 TLO 1,16384 PUSHJ 15,SYMFNC+560 MOVE 2,-15(15) ADD 2,-4(15) TLZ 1,258048 MOVEM 1,0(2) AOS -15(15) JRST L2123 L2124: MOVE 1,-1(15) BIN MOVE 1,2 MOVEM 1,-5(15) MOVE 6,L2111 MOVEM 6,-6(15) PUSHJ 15,SYMFNC+386 MOVEM 1,L2111 SETZM 1 PUSHJ 15,SYMFNC+386 MOVEM 1,-14(15) MOVE 1,-1(15) BIN MOVE 1,2 MOVE 2,1 ADD 2,L2111 MOVEM 2,-7(15) MOVE 3,-5(15) MOVE 2,L2111 MOVE 1,-1(15) HRLI 2,149760 MOVNS 3 SIN MOVE 1,-1(15) BIN MOVE 1,2 MOVEM 1,-2(15) PUSHJ 15,SYMFNC+392 MOVEM 1,-8(15) MOVE 3,-2(15) MOVE 2,1 MOVE 1,-1(15) HRLI 2,149760 MOVNS 3 SIN MOVE 1,-1(15) CLOSF JFCL SOS -5(15) SETZM -15(15) L2125: MOVE 6,-15(15) CAMLE 6,-5(15) JRST L2126 MOVE 2,-15(15) MOVE 1,-8(15) ADJBP 2,L2114 LDB 1,2 MOVEM 1,-9(15) MOVE 2,-15(15) ADD 2,L2111 MOVEM 2,-12(15) CAIN 1,1 JRST L2127 CAIN 1,2 JRST L2128 CAIN 1,3 JRST L2129 JRST L2130 L2127: LDB 3,L2115 MOVEM 3,-10(15) LDB 4,L2116 MOVEM 4,-11(15) MOVE 1,3 CAIL 1,0 CAILE 1,3 JRST L2131 JRST @L2132-0(1) L2132: IFIW L2133 IFIW L2134 IFIW L2135 IFIW L2136 L2131: JRST L2130 L2133: MOVE 5,4 ADD 5,L2111 MOVEM 5,0(2) JRST L2130 L2135: CAIGE 4,8150 JRST L2137 XMOVEI 7,-8156+L0002 ADDM 7,-11(15) JRST L2138 L2137: CAIGE 4,2048 JRST L2139 MOVE 5,4 ADD 5,-4(15) XMOVEI 4,SYMVAL ADD 4,-2048(5) MOVEM 4,-11(15) JRST L2138 L2139: XMOVEI 7,SYMVAL ADDM 7,-11(15) L2138: MOVE 6,-11(15) MOVEM 6,0(2) JRST L2130 L2136: CAIGE 4,2048 JRST L2140 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2140: MOVE 5,-11(15) ADDI 5,SYMFNC MOVEM 5,0(2) JRST L2130 L2134: CAIGE 4,2048 JRST L2141 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2141: MOVE 6,-11(15) MOVEM 6,0(2) JRST L2130 L2128: LDB 3,L2117 MOVEM 3,-10(15) LDB 4,L2118 MOVEM 4,-11(15) MOVE 1,3 CAIL 1,0 CAILE 1,3 JRST L2142 JRST @L2143-0(1) L2143: IFIW L2144 IFIW L2145 IFIW L2146 IFIW L2147 L2142: JRST L2130 L2144: MOVE 5,4 ADD 5,L2111 MOVE 7,0(2) MOVE 6,5 DPB 6,L2119 MOVEM 7,0(2) JRST L2130 L2146: CAIGE 4,8150 JRST L2148 XMOVEI 7,-8156+L0002 ADDM 7,-11(15) JRST L2149 L2148: CAIGE 4,2048 JRST L2150 MOVE 5,4 ADD 5,-4(15) XMOVEI 4,SYMVAL ADD 4,-2048(5) MOVEM 4,-11(15) JRST L2149 L2150: XMOVEI 7,SYMVAL ADDM 7,-11(15) L2149: MOVE 7,0(2) MOVE 6,-11(15) DPB 6,L2119 MOVEM 7,0(2) JRST L2130 L2147: CAIGE 4,2048 JRST L2151 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2151: MOVE 5,-11(15) ADDI 5,SYMFNC MOVE 7,0(2) MOVE 6,5 DPB 6,L2119 MOVEM 7,0(2) JRST L2130 L2145: CAIGE 4,2048 JRST L2152 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2152: MOVE 7,0(2) MOVE 6,-11(15) DPB 6,L2119 MOVEM 7,0(2) JRST L2130 L2129: LDB 3,L2117 MOVEM 3,-10(15) LDB 4,L2118 MOVEM 4,-11(15) MOVE 1,3 CAIL 1,0 CAILE 1,3 JRST L2153 JRST @L2154-0(1) L2154: IFIW L2155 IFIW L2156 IFIW L2157 IFIW L2158 L2153: JRST L2130 L2155: MOVE 5,4 ADD 5,L2111 MOVE 7,0(2) MOVE 6,5 DPB 6,L2120 MOVEM 7,0(2) JRST L2130 L2157: CAIGE 4,8150 JRST L2159 XMOVEI 7,-8156+L0002 ADDM 7,-11(15) JRST L2160 L2159: CAIGE 4,2048 JRST L2161 MOVE 5,4 ADD 5,-4(15) XMOVEI 4,SYMVAL ADD 4,-2048(5) MOVEM 4,-11(15) JRST L2160 L2161: XMOVEI 7,SYMVAL ADDM 7,-11(15) L2160: MOVE 7,0(2) MOVE 6,-11(15) DPB 6,L2120 MOVEM 7,0(2) JRST L2130 L2158: CAIGE 4,2048 JRST L2162 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2162: MOVE 5,-11(15) ADDI 5,SYMFNC MOVE 7,0(2) MOVE 6,5 DPB 6,L2120 MOVEM 7,0(2) JRST L2130 L2156: CAIGE 4,2048 JRST L2163 MOVE 5,4 ADD 5,-4(15) MOVE 6,-2048(5) MOVEM 6,-11(15) L2163: MOVE 7,0(2) MOVE 6,-11(15) DPB 6,L2120 MOVEM 7,0(2) L2130: AOS -15(15) JRST L2125 L2126: MOVE 2,-13(15) MOVE 1,-8(15) PUSHJ 15,SYMFNC+393 MOVE 1,-7(15) PUSHJ 15,0(1) MOVE 6,-6(15) MOVEM 6,L2111 MOVE 2,-14(15) MOVE 1,-7(15) PUSHJ 15,SYMFNC+391 MOVE 1,0 ADJSP 15,-16 POPJ 15,0 L2114: point 2,0(1),1 L2115: point 2,0(2),1 L2116: point 34,0(2),35 L2117: point 2,0(2),19 L2118: point 16,0(2),35 L2119: point 18,7,35 L2120: point 30,7,35 L2113: <30_30>+559 L2112: <4_30>+<1_18>+L2121 3 ; (!*ENTRY PUTENTRY EXPR 3) L2164: intern L2164 ADD 3,L2111 TLZ 3,258048 TLO 3,61440 JRST SYMFNC+251 1 ; (!*ENTRY LOAD MACRO 1) LOAD: intern LOAD MOVE 1,1(1) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2165 JRST SYMFNC+249 L2165: <30_30>+434 1 ; (!*ENTRY EVLOAD EXPR 1) EVLOAD: intern EVLOAD PUSH 15,1 PUSH 15,1 L2167: LDB 11,L2166 CAIN 11,9 JRST L2168 MOVE 1,0 JRST L2169 L2168: MOVE 1,-1(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+567 MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L2167 L2169: ADJSP 15,-2 POPJ 15,0 L2166: point 6,-1(15),5 1 ; (!*ENTRY RELOAD MACRO 1) RELOAD: intern RELOAD MOVE 1,1(1) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L2170 JRST SYMFNC+249 L2170: <30_30>+569 1 ; (!*ENTRY EVRELOAD EXPR 1) L2172: intern L2172 PUSH 15,1 PUSH 15,1 L2173: LDB 11,L2171 CAIN 11,9 JRST L2174 MOVE 1,0 JRST L2175 L2174: MOVE 1,-1(15) MOVE 1,0(1) MOVE 2,SYMVAL+466 PUSHJ 15,SYMFNC+301 MOVEM 1,SYMVAL+466 MOVE 2,-1(15) MOVE 2,1(2) MOVEM 2,-1(15) JRST L2173 L2175: MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+434 L2171: point 6,-1(15),5 L2180: 15 byte(7)42,42,42,32,108,111,97,100,105,110,103,32,37,119,37,110,0 L2181: 23 byte(7)37,114,32,108,111,97,100,32,109,111,100,117,108,101,32,110,111,116,32,102,111,117,110,100,0 L2182: 5 byte(7)37,119,37,119,37,119,0 L2183: 20 byte(7)42,42,42,32,37,119,32,97,108,114,101,97,100,121,32,108,111,97,100,101,100,0 1 ; (!*ENTRY LOAD1 EXPR 1) LOAD1: intern LOAD1 ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) JSP 10,SYMFNC+443 byte(18)0,570 byte(18)0,571 CAMN 0,SYMVAL+564 JRST L2184 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+571 L2184: MOVE 2,SYMVAL+466 PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L2185 CAMN 0,SYMVAL+564 JRST L2186 MOVE 2,0(15) MOVE 1,L2176 PUSHJ 15,SYMFNC+418 JRST L2187 L2186: MOVE 1,0 JRST L2187 L2185: MOVE 1,SYMVAL+84 JSP 10,SYMFNC+443 byte(18)1,572 MOVE 6,SYMVAL+562 MOVEM 6,-1(15) MOVE 1,SYMVAL+84 JSP 10,SYMFNC+443 byte(18)1,573 L2188: CAMN 0,-1(15) JRST L2189 CAMN 0,-4(15) JRST L2190 L2189: MOVE 1,0 JRST L2191 L2190: MOVE 6,SYMVAL+563 MOVEM 6,-2(15) L2192: CAMN 0,-2(15) JRST L2193 CAME 0,-4(15) JRST L2193 MOVE 4,-2(15) MOVE 4,0(4) MOVE 4,0(4) MOVE 3,0(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,L2177 PUSHJ 15,SYMFNC+155 MOVEM 1,-3(15) PUSHJ 15,SYMFNC+364 CAMN 1,0 JRST L2194 MOVE 2,-2(15) MOVE 2,0(2) MOVE 2,1(2) MOVEM 2,-4(15) L2194: MOVE 2,-2(15) MOVE 2,1(2) MOVEM 2,-2(15) JRST L2192 L2193: MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L2188 L2191: JSP 10,SYMFNC+447 1 CAME 0,-4(15) JRST L2195 MOVE 2,0(15) MOVE 1,L2178 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 JRST L2196 L2195: MOVE 2,SYMVAL+466 MOVE 1,0(15) PUSHJ 15,SYMFNC+151 MOVEM 1,SYMVAL+466 CAME 0,SYMVAL+564 JRST L2197 CAMN 0,SYMVAL+565 JRST L2198 L2197: MOVE 2,-3(15) MOVE 1,L2179 PUSHJ 15,SYMFNC+418 L2198: MOVE 2,-4(15) MOVE 1,-3(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 L2199: CAME 0,SYMVAL+574 JRST L2200 MOVE 1,0 JRST L2196 L2200: MOVE 1,SYMVAL+574 MOVE 1,0(1) MOVEM 1,-4(15) MOVE 2,SYMVAL+574 MOVE 2,1(2) MOVEM 2,SYMVAL+574 PUSHJ 15,LOAD1 JRST L2199 L2196: JSP 10,SYMFNC+447 1 L2187: JSP 10,SYMFNC+447 2 ADJSP 15,-5 POPJ 15,0 L2179: <4_30>+<1_18>+L2180 L2178: <4_30>+<1_18>+L2181 L2177: <4_30>+<1_18>+L2182 L2176: <4_30>+<1_18>+L2183 1 ; (!*ENTRY IMPORTS EXPR 1) L2202: intern L2202 ADJSP 15,3 MOVEM 1,0(15) CAMN 0,SYMVAL+572 JRST L2203 MOVEM 0,-1(15) MOVEM 1,-1(15) L2204: LDB 11,L2201 CAIN 11,9 JRST L2205 MOVE 1,0 JRST L2206 L2205: MOVE 1,-1(15) MOVE 1,0(1) MOVEM 1,-2(15) MOVE 2,SYMVAL+466 PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L2207 MOVE 2,SYMVAL+574 MOVE 1,-2(15) PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L2207 MOVE 1,-2(15) PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVE 1,SYMVAL+574 PUSHJ 15,SYMFNC+177 MOVEM 1,SYMVAL+574 L2207: MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L2204 L2203: ADJSP 15,-3 JRST SYMFNC+434 L2206: ADJSP 15,-3 POPJ 15,0 L2201: point 6,-1(15),5 L2210: <30_30>+576 <30_30>+128 1 ; (!*ENTRY PRETTYPRINT EXPR 1) L2211: intern L2211 PUSH 15,1 MOVE 1,L2208 PUSHJ 15,SYMFNC+434 MOVE 2,L2209 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2209: <30_30>+577 L2208: <9_30>+<1_18>+L2210 L2214: <30_30>+576 <30_30>+128 1 ; (!*ENTRY PP FEXPR 1) PP: intern PP PUSH 15,1 MOVE 1,L2212 PUSHJ 15,SYMFNC+434 MOVE 2,L2213 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2213: <30_30>+576 L2212: <9_30>+<1_18>+L2214 L2217: <30_30>+578 <30_30>+128 1 ; (!*ENTRY DEFSTRUCT FEXPR 1) L2218: intern L2218 PUSH 15,1 MOVE 1,L2215 PUSHJ 15,SYMFNC+434 MOVE 2,L2216 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2216: <30_30>+578 L2215: <9_30>+<1_18>+L2217 L2221: <30_30>+579 <30_30>+128 1 ; (!*ENTRY STEP EXPR 1) STEP: intern STEP PUSH 15,1 MOVE 1,L2219 PUSHJ 15,SYMFNC+434 MOVE 2,L2220 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2220: <30_30>+579 L2219: <9_30>+<1_18>+L2221 L2224: <30_30>+580 <30_30>+128 1 ; (!*ENTRY MINI EXPR 1) MINI: intern MINI PUSH 15,1 MOVE 1,L2222 PUSHJ 15,SYMFNC+434 MOVE 2,L2223 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2223: <30_30>+580 L2222: <9_30>+<1_18>+L2224 L2227: <30_30>+450 <30_30>+128 1 ; (!*ENTRY HELP FEXPR 1) HELP: intern HELP PUSH 15,1 MOVE 1,L2225 PUSHJ 15,SYMFNC+434 MOVE 2,L2226 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2226: <30_30>+450 L2225: <9_30>+<1_18>+L2227 L2230: <30_30>+581 <30_30>+128 0 ; (!*ENTRY EMODE EXPR 0) EMODE: intern EMODE MOVE 1,L2228 PUSHJ 15,SYMFNC+434 MOVE 1,L2229 MOVE 6,1 JRST SYMFNC+288 L2229: <30_30>+581 L2228: <9_30>+<1_18>+L2230 L2233: <30_30>+580 <30_30>+128 1 ; (!*ENTRY INVOKE EXPR 1) INVOKE: intern INVOKE PUSH 15,1 MOVE 1,L2231 PUSHJ 15,SYMFNC+434 MOVE 2,L2232 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2232: <30_30>+582 L2231: <9_30>+<1_18>+L2233 L2236: <30_30>+583 <30_30>+128 0 ; (!*ENTRY CREFON EXPR 0) CREFON: intern CREFON MOVE 1,L2234 PUSHJ 15,SYMFNC+434 MOVE 1,L2235 MOVE 6,1 JRST SYMFNC+288 L2235: <30_30>+584 L2234: <9_30>+<1_18>+L2236 L2239: <30_30>+585 <30_30>+128 3 ; (!*ENTRY COMPD EXPR 3) COMPD: intern COMPD ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 1,L2237 PUSHJ 15,SYMFNC+434 MOVE 4,L2238 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 6,4 ADJSP 15,-3 JRST SYMFNC+288 L2238: <30_30>+586 L2237: <9_30>+<1_18>+L2239 L2242: <30_30>+585 <30_30>+128 1 ; (!*ENTRY FASLOUT EXPR 1) L2243: intern L2243 PUSH 15,1 MOVE 1,L2240 PUSHJ 15,SYMFNC+434 MOVE 2,L2241 MOVE 1,0(15) MOVE 6,2 ADJSP 15,-1 JRST SYMFNC+288 L2241: <30_30>+587 L2240: <9_30>+<1_18>+L2242 L2246: <30_30>+588 <30_30>+128 0 ; (!*ENTRY BUG EXPR 0) BUG: intern BUG MOVE 1,L2244 PUSHJ 15,SYMFNC+434 MOVE 1,L2245 MOVE 6,1 JRST SYMFNC+288 L2245: <30_30>+588 L2244: <9_30>+<1_18>+L2246 L2249: <30_30>+589 <30_30>+128 0 ; (!*ENTRY MM EXPR 0) MM: intern MM MOVE 1,L2247 PUSHJ 15,SYMFNC+434 MOVE 1,L2248 MOVE 6,1 JRST SYMFNC+288 L2248: <30_30>+590 L2247: <9_30>+<1_18>+L2249 L2252: <30_30>+589 <30_30>+128 0 ; (!*ENTRY EXEC EXPR 0) EXEC: intern EXEC MOVE 1,L2250 PUSHJ 15,SYMFNC+434 MOVE 1,L2251 MOVE 6,1 JRST SYMFNC+288 L2251: <30_30>+589 L2250: <9_30>+<1_18>+L2252 end |
Added psl-1983/3-1/kernel/20/fasl.rel version [71a253be4a].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/faslin.red version [25d42018d8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 25-May-1983 Mark R. Swanson % Changed magic number to differentiate extended-20 fasl files from old ones on SysLisp; external WString TokenBuffer; external WArray ArgumentBlock; internal WConst CODE_OFFSET = 0, RELOC_ID_NUMBER = 1, RELOC_VALUE_CELL = 2, RELOC_FUNCTION_CELL = 3; internal WConst RELOC_WORD = 1, RELOC_RIGHT_HALF = 2, RELOC_INF = 3; internal WConst FASLMAGIC = 2099; CompileTime << smacro procedure LocalIDNumberP U; U >= 2048; smacro procedure LocalToGlobalID U; IDTable[U - 2048]; smacro procedure ExtraArgumentP U; U >= 8150; % Something enough less than 8192 smacro procedure MakeExtraArgument U; U - (8150 + (MaxRealRegs + 1)); >>; internal WVar CodeBase; syslsp procedure FaslIN File; begin scalar F, N, M, IDTable, CodeSize, OldCodeBase, E, BT, R, RT, RI, BI, Top, BTop; F := BinaryOpenRead File; N := BinaryRead F; % First word is magic number if N neq FASLMAGIC then ContError(99, "%r is not a fasl format file", File, FaslIN File); M := BinaryRead F; % Number of local IDs Top := GtWArray 0; % pointer to top of space IDTable := GtWArray(M + 1); % Allocate space for table for I := 0 step 1 until M do << TokenBuffer[0] := BinaryRead F; % word is length of ID name BinaryReadBlock(F, &TokenBuffer[1], StrPack TokenBuffer[0]); IDTable[I] := IDInf Intern MkSTR TokenBuffer >>; CodeSize := BinaryRead F; % Size of code segment in words OldCodeBase := CodeBase; % So FASLIN is reentrant CodeBase := GtBPS CodeSize; % Allocate space in BPS BTop := GTBPS 0; % pointer to top E := CodeBase + BinaryRead F; % Next word is offset of init function % Will be called after code is read BinaryReadBlock(F, CodeBase, CodeSize); % Put the next N words there N := BinaryRead F; % Next word is size of bit table in words BT := GtWArray N; % Allocate space for bit table BinaryReadBlock(F, BT, N); % read bit table BinaryClose F; % close the file CodeSize := CodeSize*AddressingUnitsPerItem - 1; for I := 0 step 1 until CodeSize do << R := BitTable(BT, I); BI := CodeBase + I; case R of RELOC_WORD: << RT := RelocWordTag @BI; RI := RelocWordInf @BI; case RT of CODE_OFFSET: @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := RI >>; end >>; RELOC_RIGHT_HALF: << RT := RelocRightHalfTag @BI; RI := RelocRightHalfInf @BI; case RT of CODE_OFFSET: RightHalf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; RightHalf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := RI >>; end >>; RELOC_INF: << RT := RelocInfTag @BI; RI := RelocInfInf @BI; case RT of CODE_OFFSET: Inf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; Inf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := RI >>; end >>; end >>; DelWArray(BT, Top); % return the space used by tables AddressApply0 E; % Call the init routine CodeBase := OldCodeBase; % restore previous value for CodeBase DelBPS(E, BTop); % deallocate space of init routine end; syslsp procedure PutEntry(Name, Type, Offset); PutD(Name, Type, MkCODE(CodeBase + Offset)); off Syslisp; END; |
Added psl-1983/3-1/kernel/20/fast-binder.red version [868f78fd0c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FAST-BINDER.RED - Fast binding and unbinding routines in LAP for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 July 1981 % Copyright (c) 1981 University of Utah % % 25-May-1983 Mark R. Swanson % Changed FastBind to zero out left half of a symbol table index (for extended % addressing 20). on SysLisp; external WVar BndStkPtr, % The binding stack pointer BndStkLowerBound, % Bottom of the binding stack BndStkUpperBound; % Top of the binding stack % TAG( FastBind ) lap '((!*Entry FastBind expr 0) % Bind IDs to values in registers % % FastBind is called with JSP T5, followed by % regnum,,idnum % ... % (!*MOVE (WVar BndStkPtr) (reg t2)) % load binding stack pointer Loop (!*MOVE (Indexed (reg t5) (WConst 0)) (reg t1)) % get next entry (tlnn (reg t1) 8#777000) % if it's not an instruction (!*JUMP (Label MoreLeft)) % keep binding (!*MOVE (reg t2) (WVar BndStkPtr)) % Otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 0))) % and return MoreLeft (!*WPLUS2 (reg t2) (WConst 2)) % add 2 to binding stack pointer (caml (reg t2) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (hlrz (reg t3) (reg t1)) % stick register number in t3 (caile (reg t3) (WConst MaxRealRegs)) % is it a real register? (!*WPLUS2 (reg t3) % no, move to arg block (WConst (difference (WArray ArgumentBlock) (plus (WConst MaxRealRegs) 1)))) (hrrzm (reg t1) (Indexed (reg t2) (WConst -1))) % store ID number in BndStk (hrrz (reg t1) (reg t1)) % zero out left half of reg t1 for % extended memory (!*MOVE (MEMORY (reg t1) (WConst SymVal)) (reg t4)) % get old value for ID in t4 (!*MOVE (reg t4) (MEMORY (reg t2) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t3)) % get reg value in t3 (!*MOVE (reg t3) (MEMORY (reg t1) (WConst SymVal))) % store in ID value cell (aoja (reg t5) Loop) % try again ); % TAG( FastUnBind ) lap '((!*Entry FastUnBind expr 0) % Unbind last N entries in bind stack % % FastUnBind is called with JSP T5, followed by word containing count to % unbind. % (!*MOVE (WVar BndStkPtr) (reg t1)) % get binding stack pointer in t1 (!*MOVE (MEMORY (reg t5) (WConst 0)) (reg t2)) % count in t2 Loop (!*JUMPWGREATERP (Label MoreLeft) (reg t2) (WConst 0)) % continue if count is > zero (!*MOVE (reg t1) (WVar BndStkPtr)) % otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 1))) % and return MoreLeft (camge (reg t1) (WVar BndStkLowerBound)) % check for underflow (!*JCALL BStackUnderflow) (dmove (reg t3) (Indexed (reg t1) -1)) % get ID # in t3, value in t4 (!*MOVE (reg t4) (MEMORY (reg t3) (WConst SymVal))) % restore to value cell (!*WDIFFERENCE (reg t1) (WConst 2)) % adjust binding stack pointer -2 (soja (reg t2) Loop) % and count down by 1, then try again ); off SysLisp; END; |
Added psl-1983/3-1/kernel/20/fresh-kernel.ctl version [c603c0893f].
> > > > > | 1 2 3 4 5 | rename 20.SYM PREVIOUS-20.SYM copy PC:BARE-PSL.SYM 20.SYM ; To regenerate the .CTL files: ; PSL:PSL ; (dskin "20-kernel-gen.sl") |
Added psl-1983/3-1/kernel/20/function-primitives.red version [e061d7b5c2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FUNCTION-PRIMITIVES.RED - primitives used by PUTD/GETD and EVAL/APPLY % P20: version % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 August 1981 % Copyright (c) 1981 University of Utah % % 22-May-83 Mark R. Swanson % Changes to support extended addressing on -20: essentially making % references to SYMFNC explicit array refences. % Every ID has a "function cell". It does not necessarily contain a legal % Lisp item, and therefore should not be accessed directly by Lisp functions. % In this implementation the function cell contains an instruction to be % executed. There are 3 possibilites for this instruction, for which the % following predicates and updating functions exist: % % FUnBoundP(ID) -- the function is not defined % FLambdaLinkP(ID) -- the function is interpreted % FCodeP(ID) -- the function is compiled % % MakeFUnBound(ID) -- undefine the function % MakeFLambdaLink(ID) -- specify that the function is interpreted % MakeFCode(ID, CodePtr) -- specify that the function is compiled, % and that the code resides at the address % associated with CodePtr % % GetFCodePointer(ID) -- returns the contents of the function cell as a % code pointer % These functions currently check that they have proper arguments, but this may % change since they are only used by functions that have checked them already. % Note that MakeFCode is necessarily machine-dependent -- this file currently % contains the PDP-10 version. This function should be moved to a file of % system-dependent routines. Of course, other things in this file will % probably have to change for a different machine as well. on SysLisp; internal WConst SymfncJsp = 8#265500000000 + &SymFnc[0]; internal WVar UnDefn = SymFncJsp + IDLoc UndefinedFunction; internal WVar LamLnk = SymFncJsp + IDLoc CompiledCallingInterpreted; % currently the WVars UnDefn and LamLnk contain the instructions which will % be found in the function cells of undefined and interpreted functions. syslsp procedure FUnBoundP U; %. does U not have a function defn? if IDP U then SymFnc[Inf U] eq Undefn else NonIDError(U, 'FUnBoundP); syslsp procedure FLambdaLinkP U; %. is U an interpreted function? if IDP U then SymFnc [Inf U] eq LamLnk else NonIDError(U, 'FLambdaLinkP); syslsp procedure FCodeP U; %. is U a compiled function? if IDP U then SymFnc[Inf U] neq UnDefn and SymFnc[Inf U] neq LamLnk else NonIDError(U, 'FCodeP); syslsp procedure MakeFUnBound U; %. Make U an undefined function if IDP U then << SymFnc[Inf U] := UnDefn; NIL >> else NonIDError(U, 'MakeFUnBound); syslsp procedure MakeFLambdaLink U; %. Make U an interpreted function if IDP U then << SymFnc[Inf U] := LamLnk; NIL >> else NonIDError(U, 'MakeFLambdaLink); syslsp procedure MakeFCode(U, CodePtr); %. Make U a compiled function if IDP U then if CodeP CodePtr then << SymFnc[Inf U] := Field(CodePtr, 18, 18) + 8#254000000000; % PutField(SymFnc U, 0, 9, 8#254); % JRST NIL >> else NonIDError(U, 'MakeFCode); syslsp procedure GetFCodePointer U; %. Get code pointer for U if IDP U then MkCODE Field(SymFnc[Inf U], 12, 24) else NonIDError(U, 'GetFCodePointer); off SysLisp; END; |
Added psl-1983/3-1/kernel/20/gc.red version [dcbcebdde6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GC.RED - Copying 2-space garbage collector for PSL % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 30 November 1981 % Copyright (c) 1981 Eric Benson % % Edit by Mark Swanson, 3 April 1983 0949-MST % Made COPYITEM1 tail-recursive so that long lists can be copied without % stack overflow -- both COPYITEM and COPYITEM1 are now called exclusively % for their side effects--return values should be ignored. % Edit by Cris Perdue, 25 Mar 1983 1711-PST % Occurrence of heap-warn-level in initialization no longer flagged % with "LispVar". Didn't work. % <PSL.KERNEL>COPYING-GC.RED.2, 23-Mar-83 11:35:37, Edit by KESSLER % Add HeadTrapBound Guys, so we can update the heap trap bound upon switch % Edit by Cris Perdue, 15 Mar 1983 0937-PST % Added missing comma as noted by Kessler. % Edit by Cris Perdue, 16 Feb 1983 1409-PST % Removed external declaration of HeapPreviousLast (the only occurrence) % Now using "known-free-space" function and heap-warn-level % Sets HeapTrapped to NIL now. % Added check of Heap!-Warn!-Level after %Reclaim. % <PSL.KERNEL>COPYING-GC.RED.6, 4-Oct-82 17:56:49, Edit by BENSON % Added GCTime!* fluid '(!*GC GCKnt!* GCTime!* Heap!-Warn!-Level); LoadTime << GCKnt!* := 0; GCTime!* := 0; !*GC := T; Heap!-Warn!-Level := 1000 >>; on SysLisp; CompileTime << syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinOldHeapPointer X; X >= !%chipmunk!-kludge OldHeapLowerBound and X <= !%chipmunk!-kludge OldHeapLast; syslsp smacro procedure Mark X; MkItem(Forward, X); syslsp smacro procedure Marked X; Tag X eq Forward; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; flag('(CopyFromAllBases CopyFromRange CopyFromBase CopyItem CopyItem1 MarkAndCopyFromID MakeIDFreeList GCStats), 'InternalFunction); >>; external WVar ST, StackLowerBound, BndStkLowerBound, BndStkPtr, HeapLast, HeapLowerBound, HeapUpperBound, OldHeapLast, OldHeapLowerBound, OldHeapUpperBound, HeapTrapBound, OldHeapTrapBound, HeapTrapped; internal WVar StackLast, OldTime, OldSize; syslsp procedure Reclaim(); !%Reclaim(); syslsp procedure !%Reclaim(); begin scalar Tmp1, Tmp2; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; BeforeGCSystemHook(); StackLast := MakeAddressFromStackPointer AdjustStackPointer(ST, -FrameSize()); OldTime := TimC(); OldSize := HeapLast - HeapLowerBound; LispVar GCKnt!* := LispVar GCKnt!* + 1; OldHeapLast := HeapLast; HeapLast := OldHeapLowerBound; Tmp1 := HeapLowerBound; Tmp2 := HeapUpperBound; HeapLowerBound := OldHeapLowerBound; HeapUpperBound := OldHeapUpperBound; OldHeapLowerBound := Tmp1; OldHeapUpperBound := Tmp2; Tmp1 := HeapTrapBound; HeapTrapBound := OldHeapTrapBound; OldHeapTrapBound := Tmp1; CopyFromAllBases(); MakeIDFreeList(); AfterGCSystemHook(); OldTime := TimC() - OldTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, OldTime); if LispVar !*GC then GCStats(); HeapTrapped := NIL; if IntInf Known!-Free!-Space() < IntInf (LispVar Heap!-Warn!-Level) then ContinuableError(99, "Heap space low", NIL) >>; syslsp procedure MarkAndCopyFromID X; % SymNam has to be copied before marking, since the mark destroys the tag % No problem since it's only a string, can't reference itself. << CopyFromBase &SymNam X; MarkID X; CopyFromBase &SymPrp X; CopyFromBase &SymVal X >>; syslsp procedure CopyFromAllBases(); begin scalar LastSymbol, B; MarkAndCopyFromID 128; % Mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkAndCopyFromID I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkAndCopyFromID B >>; B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do CopyFromBase B; for I := StackLowerBound step StackDirection*AddressingUnitsPerItem until StackLast do CopyFromBase I; end; syslsp procedure CopyFromRange(Lo, Hi); begin scalar X, I; X := Lo; I := 0; while X <= Hi do << CopyFromBase X; I := I + 1; X := &Lo[I] >>; end; syslsp procedure CopyFromBase P; % P is an "address" CopyItem P; syslsp procedure CopyItem P; % COPYITEM is executed for SIDE-EFFECT--its return value is not likely to % be meaningful and should be ignored! begin scalar Typ, Info, Hdr, X; X := @P; Typ := Tag X; if not PointerTagP Typ then return @P := << if Typ = ID and not null X then % don't follow NIL, for speed << Info := IDInf X; if not MarkedID Info then MarkAndCopyFromID Info >>; X >>; % else it is a PointerType Info := Inf X; if not WithinOldHeapPointer Info then return X; Hdr := @Info; if Marked Hdr then return @P := MkItem(Typ, Inf Hdr); return CopyItem1 P; end; syslsp procedure CopyItem1 P; % Copier for GC % COPYITEM1 is executed for SIDE-EFFECT--its return value is not likely to % be meaningful and should be ignored! begin scalar NewS, Len, Ptr, StripS, S; S := @P; return case Tag S of PAIR: << Ptr := car S; % Save car which is about to be % replaced by MARK and new address Rplaca(S, Mark(NewS := GtHeap PairPack())); @P := MkPAIR NewS; NewS[0] := Ptr; NewS[1] := cdr S; CopyItem &NewS[0]; return CopyItem &NewS[1] >>; STR: << @StrInf S := Mark(NewS := CopyString S); return @P := NewS >>; VECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do << VecItm(Ptr, I) := VecItm(StripS, I); CopyItem &VecItm(Ptr, I) >>; return @P := MkVEC Ptr >>; EVECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do << VecItm(Ptr, I) := VecItm(StripS, I); CopyItem &VecItm(Ptr, I) >>; return @P := MkItem(EVECT, Ptr) >>; WRDS, FIXN, FLTN, BIGN: << Ptr := Tag S; @Inf S := Mark(NewS := CopyWRDS S); return @P := MkItem(Ptr, NewS) >>; default: FatalError BldMsg("Unexpected tag %w found at %w during garbage collection", MkInt Tag S,MkInt Inf S); end; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure GCStats(); << ErrorPrintF("*** GC %w: time %d ms, %d recovered, %d free", LispVar GCKnt!*, OldTime, (OldSize - (HeapLast - HeapLowerBound))/AddressingUnitsPerItem, Known!-Free!-Space() ) >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/global-data.red version [b6d2bc6f26].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLOBAL-DATA.RED - Data used by everyone % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 September 1981 % Copyright (c) 1981 University of Utah % on SysLisp; exported WConst MaxSymbols = 8000, HeapSize = 262000, MaxObArray = 8209, % first prime above 8192 StackSize = 10000, BPSSize = 170000; exported WConst CompressedBinaryRadix = 8; external WArray SymNam, SymVal, SymFnc, SymPrp; external WVar NextSymbol; exported WConst MaxRealRegs = 5, MaxArgs = 15; external WArray ArgumentBlock; external WArray HashTable; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/heap.build version [28df2775c8].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % % HEAP.BUILD - Declaration of the heap and BPS % % Author: Mark Swanson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 4 March 1983 % Copyright (c) 1983 University of Utah % on Syslisp; internal WArray BPS[BPSSize]; exported WVar NextBPS = &BPS[0] + 8#1000000, LastBPS = &BPS[BPSSize] + 8#1000000; exported WConst Heap = 8#2000000; off Syslisp; END; |
Added psl-1983/3-1/kernel/20/heap.ctl version [41de4a7a9b].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "heap"; PathIn "heap.build"; ASMEnd; quit; compile heap.mac, dheap.mac |
Added psl-1983/3-1/kernel/20/heap.init version [a7ffc6f8bf].
Added psl-1983/3-1/kernel/20/heap.log version [1782431fc9].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/heap.mac version [41e35d5f34].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern BPS extern L1110 extern L1111 end |
Added psl-1983/3-1/kernel/20/heap.rel version [987be51576].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/io-data.red version [34da76080b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-DATA.RED - Data structures used by input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1981 % Copyright (c) 1981 University of Utah % % 01-Mar-83 Nancy Kendzierski % Added initialization of UnReadBuffer and LinePosition. % <PSL.KERNEL-20>IO-DATA.RED.2, 29-Dec-82 12:19:36, Edit by PERDUE % Added PagePosition array to support LPOSN on SysLisp; internal WConst MaxTokenSize = 5000; exported WString TokenBuffer[MaxTokenSize]; exported WConst MaxChannels = 31; % All need (MaxChannels + 1) initial values. exported WArray ReadFunction = ['TerminalInputHandler, 'WriteOnlyChannel, 'WriteOnlyChannel, 'CompressReadChar, 'WriteOnlyChannel, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], WriteFunction = ['ReadOnlyChannel, 'Dec20WriteChar, 'ToStringWriteChar, 'ExplodeWriteChar, 'FlatSizeWriteChar, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], CloseFunction = ['IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], UnReadBuffer = [0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0], LinePosition = [0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0], PagePosition[MaxChannels], MaxLine = [0,80,80,10000,10000, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0], JFNOfChannel = [8#100,8#101,-1,-1,-1, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0,0,0,0, 0,0]; off SysLisp; global '(!$EOL!$); LoadTime(!$EOL!$ := '! ); END; |
Added psl-1983/3-1/kernel/20/io.ctl version [45aa5b521a].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "io"; PathIn "io.build"; ASMEnd; quit; compile io.mac, dio.mac |
Added psl-1983/3-1/kernel/20/io.init version [5ddad09b2f].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | (GLOBAL (QUOTE (!$EOL!$))) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!*))) (GLOBAL (QUOTE (SPECIALRDSACTION!* SPECIALWRSACTION!* IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!*))) (GLOBAL (QUOTE (OUT!*))) (FLUID (QUOTE (!*RAISE))) (FLUID (QUOTE (CURRENTREADMACROINDICATOR!* CURRENTSCANTABLE!* LISPSCANTABLE!* !*INSIDESTRUCTUREREAD))) (GLOBAL (QUOTE (TOKTYPE!* IN!* !$EOF!$))) (FLUID (QUOTE (CURRENTSCANTABLE!* !*RAISE !*COMPRESSING !*EOLINSTRINGOK))) (FLUID (QUOTE (OUTPUTBASE!* PRINLENGTH PRINLEVEL CURRENTSCANTABLE!* LISPSCANTABLE!* IDESCAPECHAR!* !*LOWER))) (FLUID (QUOTE (FORMATFORPRINTF!*))) (FLUID (QUOTE (EXPLODEENDPOINTER!* COMPRESSLIST!* !*COMPRESSING))) (GLOBAL (QUOTE (IN!* OUT!*))) |
Added psl-1983/3-1/kernel/20/io.log version [97ae5715f8].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/io.mac version [6fbe085c71].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L2110 extern L2253 extern L2254 extern L2255 extern L2256 extern L2257 extern L2258 extern L2259 extern L2260 L2262: 14 byte(7)67,104,97,110,110,101,108,82,101,97,100,67,104,97,114,0 1 ; (!*ENTRY CHANNELREADCHAR EXPR 1) L2263: intern L2263 ADJSP 15,3 MOVEM 1,0(15) MOVEM 1,-2(15) JUMPL 1,L2264 CAIG 1,31 JRST L2265 L2264: MOVE 2,L2261 PUSHJ 15,SYMFNC+492 L2265: MOVE 1,-2(15) MOVE 1,L2256(1) MOVEM 1,-1(15) JUMPE 1,L2266 MOVE 7,-2(15) SETZM L2256(7) JRST L2267 L2266: MOVE 2,-2(15) MOVE 2,L2253(2) MOVE 1,-2(15) ADJSP 15,-3 TLZ 2,258048 JRST SYMFNC(2) L2267: ADJSP 15,-3 POPJ 15,0 L2261: <4_30>+<1_18>+L2262 0 ; (!*ENTRY READCHAR EXPR 0) L2268: intern L2268 MOVE 1,SYMVAL+600 JRST SYMFNC+598 L2271: 15 byte(7)67,104,97,110,110,101,108,87,114,105,116,101,67,104,97,114,0 2 ; (!*ENTRY CHANNELWRITECHAR EXPR 2) L2272: intern L2272 PUSH 15,1 PUSH 15,2 JUMPL 1,L2273 CAIG 1,31 JRST L2274 L2273: MOVE 2,L2269 PUSHJ 15,SYMFNC+492 L2274: MOVE 6,0(15) CAIE 6,10 JRST L2275 MOVE 7,-1(15) SETZM L2257(7) MOVE 6,-1(15) AOS L2258(6) JRST L2276 L2275: MOVE 6,0(15) CAIE 6,9 JRST L2277 MOVE 1,-1(15) MOVE 1,L2257(1) ADDI 1,8 AND 1,L2270 MOVE 7,-1(15) MOVEM 1,L2257(7) JRST L2276 L2277: MOVE 6,0(15) CAIE 6,12 JRST L2278 MOVE 7,-1(15) SETZM L2258(7) MOVE 7,-1(15) SETZM L2257(7) JRST L2276 L2278: MOVE 6,-1(15) AOS L2257(6) L2276: MOVE 3,-1(15) MOVE 3,L2254(3) MOVE 2,0(15) MOVE 1,-1(15) TLZ 3,258048 PUSHJ 15,SYMFNC(3) MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L2270: -8 L2269: <4_30>+<1_18>+L2271 1 ; (!*ENTRY WRITECHAR EXPR 1) L2279: intern L2279 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+359 2 ; (!*ENTRY CHANNELUNREADCHAR EXPR 2) L2280: intern L2280 MOVEM 2,L2256(1) MOVE 1,2 POPJ 15,0 1 ; (!*ENTRY UNREADCHAR EXPR 1) L2281: intern L2281 MOVE 2,1 MOVE 1,SYMVAL+600 JRST SYMFNC+601 L2292: 18 byte(7)85,110,107,110,111,119,110,32,97,99,99,101,115,115,32,116,121,112,101,0 L2293: 37 byte(7)73,109,112,114,111,112,101,114,108,121,32,115,101,116,45,117,112,32,115,112,101,99,105,97,108,32,73,79,32,111,112,101,110,32,99,97,108,108,0 2 ; (!*ENTRY OPEN EXPR 2) OPEN: intern OPEN ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) CAME 2,L2282 JRST L2294 PUSHJ 15,SYMFNC+604 MOVEM 1,-2(15) SETZM L2256(1) MOVE 6,L2283 MOVEM 6,L2254(1) JRST L2295 L2294: CAME 2,L2284 JRST L2296 PUSHJ 15,SYMFNC+605 MOVEM 1,-2(15) SETZM L2257(1) HRRZI 6,80 MOVEM 6,L2259(1) MOVE 6,L2285 MOVEM 6,L2253(1) JRST L2295 L2296: CAME 2,L2286 JRST L2297 LDB 11,L2287 CAIE 11,30 JRST L2298 LDB 11,L2288 CAIE 11,30 JRST L2298 LDB 11,L2289 CAIE 11,30 JRST L2298 PUSHJ 15,SYMFNC+606 MOVEM 1,-2(15) SETZM L2257(1) HRRZI 6,80 MOVEM 6,L2259(1) SETZM L2256(1) MOVE 2,SYMVAL+607 TLZ 2,258048 MOVEM 2,L2253(1) MOVE 3,SYMVAL+608 TLZ 3,258048 MOVEM 3,L2254(1) MOVE 4,SYMVAL+609 TLZ 4,258048 MOVEM 4,L2255(1) JRST L2295 L2298: MOVE 1,L2290 JRST L2299 L2297: MOVE 1,L2291 L2299: PUSHJ 15,SYMFNC+507 L2295: MOVE 1,-2(15) ADJSP 15,-3 POPJ 15,0 L2287: point 6,<SYMVAL+607>,5 L2288: point 6,<SYMVAL+608>,5 L2289: point 6,<SYMVAL+609>,5 L2291: <4_30>+<1_18>+L2292 L2290: <4_30>+<1_18>+L2293 L2286: <30_30>+610 L2285: <30_30>+504 L2284: <30_30>+611 L2283: <30_30>+505 L2282: <30_30>+612 L2302: 4 byte(7)67,108,111,115,101,0 1 ; (!*ENTRY CLOSE EXPR 1) CLOSE: intern CLOSE PUSH 15,1 PUSH 15,1 JUMPL 1,L2303 CAIG 1,31 JRST L2304 L2303: MOVE 2,L2300 PUSHJ 15,SYMFNC+492 L2304: MOVE 2,-1(15) MOVE 2,L2255(2) MOVE 1,-1(15) TLZ 2,258048 PUSHJ 15,SYMFNC(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+614 MOVE 7,-1(15) MOVE 6,L2301 MOVEM 6,L2253(7) MOVE 7,-1(15) MOVE 6,L2301 MOVEM 6,L2254(7) MOVE 7,-1(15) MOVE 6,L2301 MOVEM 6,L2255(7) MOVE 1,0(15) ADJSP 15,-2 POPJ 15,0 L2301: <30_30>+502 L2300: <4_30>+<1_18>+L2302 L2308: 32 byte(7)67,104,97,110,110,101,108,32,110,111,116,32,111,112,101,110,32,102,111,114,32,105,110,112,117,116,32,105,110,32,82,68,83,0 1 ; (!*ENTRY RDS EXPR 1) RDS: intern RDS ADJSP 15,3 MOVEM 1,0(15) CAMN 0,SYMVAL+615 JRST L2309 MOVE 3,SYMVAL+615 MOVE 2,1 MOVE 1,SYMVAL+600 MOVE 6,3 PUSHJ 15,SYMFNC+288 L2309: MOVE 6,SYMVAL+600 MOVEM 6,-1(15) CAME 0,0(15) JRST L2310 MOVE 6,SYMVAL+616 MOVEM 6,0(15) L2310: MOVE 6,0(15) MOVE 6,L2253(6) MOVEM 6,-2(15) MOVE 6,-2(15) CAMN 6,L2305 JRST L2311 MOVE 6,-2(15) CAME 6,L2306 JRST L2312 L2311: MOVE 2,L2307 MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+503 L2312: MOVE 6,0(15) MOVEM 6,SYMVAL+600 MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L2307: <4_30>+<1_18>+L2308 L2306: <30_30>+504 L2305: <30_30>+502 L2316: 33 byte(7)67,104,97,110,110,101,108,32,110,111,116,32,111,112,101,110,32,102,111,114,32,111,117,116,112,117,116,32,105,110,32,87,82,83,0 1 ; (!*ENTRY WRS EXPR 1) WRS: intern WRS ADJSP 15,3 MOVEM 1,0(15) CAMN 0,SYMVAL+617 JRST L2317 MOVE 3,SYMVAL+617 MOVE 2,1 MOVE 1,SYMVAL+311 MOVE 6,3 PUSHJ 15,SYMFNC+288 L2317: MOVE 6,SYMVAL+311 MOVEM 6,-1(15) CAME 0,0(15) JRST L2318 MOVE 6,SYMVAL+618 MOVEM 6,0(15) L2318: MOVE 6,0(15) MOVE 6,L2254(6) MOVEM 6,-2(15) MOVE 6,-2(15) CAMN 6,L2313 JRST L2319 MOVE 6,-2(15) CAME 6,L2314 JRST L2320 L2319: MOVE 2,L2315 MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+503 L2320: MOVE 6,0(15) MOVEM 6,SYMVAL+311 MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L2315: <4_30>+<1_18>+L2316 L2314: <30_30>+505 L2313: <30_30>+502 1 ; (!*ENTRY CHANNELEJECT EXPR 1) L2321: intern L2321 HRRZI 2,12 PUSHJ 15,SYMFNC+359 MOVE 1,0 POPJ 15,0 0 ; (!*ENTRY EJECT EXPR 0) EJECT: intern EJECT MOVE 1,SYMVAL+311 JRST SYMFNC+619 L2325: 27 byte(7)37,114,32,105,115,32,97,110,32,105,110,118,97,108,105,100,32,108,105,110,101,32,108,101,110,103,116,104,0 2 ; (!*ENTRY CHANNELLINELENGTH EXPR 2) L2326: intern L2326 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVE 6,L2259(1) MOVEM 6,-2(15) CAMN 2,0 JRST L2327 LDB 11,L2323 CAIN 11,63 JRST L2322 CAILE 11,0 JRST L2328 L2322: JUMPL 2,L2328 MOVEM 2,L2259(1) JRST L2327 L2328: MOVE 1,L2324 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 L2327: MOVE 1,-2(15) ADJSP 15,-4 POPJ 15,0 L2323: point 6,2,5 L2324: <4_30>+<1_18>+L2325 1 ; (!*ENTRY LINELENGTH EXPR 1) L2329: intern L2329 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+621 1 ; (!*ENTRY CHANNELPOSN EXPR 1) L2330: intern L2330 MOVE 1,L2257(1) POPJ 15,0 0 ; (!*ENTRY POSN EXPR 0) POSN: intern POSN MOVE 1,SYMVAL+311 JRST SYMFNC+362 1 ; (!*ENTRY CHANNELLPOSN EXPR 1) L2331: intern L2331 MOVE 1,L2258(1) POPJ 15,0 0 ; (!*ENTRY LPOSN EXPR 0) LPOSN: intern LPOSN MOVE 1,SYMVAL+311 JRST SYMFNC+624 1 ; (!*ENTRY CHANNELREADCH EXPR 1) L2332: intern L2332 ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+598 MOVEM 1,-1(15) CAMN 0,SYMVAL+627 JRST L2333 CAIGE 1,97 JRST L2333 CAILE 1,122 JRST L2333 MOVNI 7,32 ADDM 7,-1(15) L2333: MOVE 1,-1(15) HRLI 1,122880 ADJSP 15,-2 POPJ 15,0 0 ; (!*ENTRY READCH EXPR 0) READCH: intern READCH MOVE 1,SYMVAL+600 JRST SYMFNC+626 1 ; (!*ENTRY CHANNELTERPRI EXPR 1) L2334: intern L2334 HRRZI 2,10 PUSHJ 15,SYMFNC+359 MOVE 1,0 POPJ 15,0 0 ; (!*ENTRY TERPRI EXPR 0) TERPRI: intern TERPRI MOVE 1,SYMVAL+311 JRST SYMFNC+309 1 ; (!*ENTRY CHANNELREADTOKENWITHHOOKS EXPR 1) L2336: intern L2336 ADJSP 15,3 MOVEM 1,0(15) MOVEM 0,-2(15) PUSHJ 15,SYMFNC+633 MOVEM 1,-1(15) MOVE 7,SYMVAL+634 CAIE 7,3 JRST L2337 MOVE 2,SYMVAL+631 PUSHJ 15,SYMFNC+522 MOVE 2,1 MOVEM 2,-2(15) CAMN 2,0 JRST L2337 MOVE 3,2 MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-3 TLZ 3,258048 JRST SYMFNC(3) L2337: MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY CHANNELREAD EXPR 1) L2339: intern L2339 PUSH 15,1 JSP 10,SYMFNC+443 byte(18)0,631 byte(18)0,635 MOVE 6,SYMVAL+637 MOVEM 6,SYMVAL+635 MOVE 6,L2338 MOVEM 6,SYMVAL+631 PUSHJ 15,SYMFNC+632 JSP 10,SYMFNC+447 2 ADJSP 15,-1 POPJ 15,0 L2338: <30_30>+638 0 ; (!*ENTRY READ EXPR 0) READ: intern READ PUSHJ 15,SYMFNC+639 MOVE 1,SYMVAL+600 JRST SYMFNC+636 L2341: 41 byte(7)85,110,101,120,112,101,99,116,101,100,32,69,79,70,32,119,104,105,108,101,32,114,101,97,100,105,110,103,32,111,110,32,99,104,97,110,110,101,108,32,37,114,0 2 ; (!*ENTRY CHANNELREADEOF EXPR 2) L2342: intern L2342 PUSH 15,2 PUSH 15,1 CAMN 0,SYMVAL+640 JRST L2343 JSP 10,SYMFNC+443 byte(18)0,640 MOVE 2,1 MOVE 1,L2340 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 JSP 10,SYMFNC+447 1 JRST L2344 L2343: MOVE 1,SYMVAL+642 L2344: ADJSP 15,-2 POPJ 15,0 L2340: <4_30>+<1_18>+L2341 2 ; (!*ENTRY CHANNELREADQUOTEDEXPRESSION EXPR 2) L2345: intern L2345 PUSHJ 15,SYMFNC+632 JRST SYMFNC+234 2 ; (!*ENTRY CHANNELREADLISTORDOTTEDPAIR EXPR 2) L2348: intern L2348 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVEM 0,-4(15) JSP 10,SYMFNC+443 byte(18)0,640 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+640 PUSHJ 15,SYMFNC+632 MOVEM 1,-2(15) MOVE 7,SYMVAL+634 CAIE 7,3 JRST L2349 CAME 1,L2346 JRST L2350 PUSHJ 15,L2351 JRST L2352 L2350: CAME 1,L2347 JRST L2349 MOVE 1,0 JRST L2352 L2349: PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,-4(15) MOVEM 2,-3(15) L2353: MOVE 1,0(15) PUSHJ 15,SYMFNC+632 MOVEM 1,-2(15) MOVE 7,SYMVAL+634 CAIE 7,3 JRST L2354 CAME 1,L2347 JRST L2355 MOVE 1,-3(15) JRST L2352 L2355: CAME 1,L2346 JRST L2354 MOVE 1,0(15) PUSHJ 15,SYMFNC+632 MOVEM 1,-2(15) MOVE 7,SYMVAL+634 CAIE 7,3 JRST L2356 CAMN 1,L2347 JRST L2357 CAME 1,L2346 JRST L2356 L2357: PUSHJ 15,L2351 JRST L2352 L2356: MOVE 7,-4(15) MOVEM 1,1(7) MOVE 1,0(15) PUSHJ 15,SYMFNC+632 MOVEM 1,-2(15) MOVE 7,SYMVAL+634 CAIE 7,3 JRST L2358 CAME 1,L2347 JRST L2358 MOVE 1,-3(15) JRST L2352 L2358: PUSHJ 15,L2351 JRST L2352 L2354: MOVE 1,-2(15) PUSHJ 15,SYMFNC+172 MOVE 7,-4(15) MOVEM 1,1(7) MOVE 2,-4(15) MOVE 2,1(2) MOVEM 2,-4(15) JRST L2353 L2352: JSP 10,SYMFNC+447 1 ADJSP 15,-5 POPJ 15,0 L2347: <30_30>+41 L2346: <30_30>+46 L2360: 30 byte(7)42,42,42,32,85,110,109,97,116,99,104,101,100,32,114,105,103,104,116,32,112,97,114,101,110,116,104,101,115,105,115,0 2 ; (!*ENTRY CHANNELREADRIGHTPAREN EXPR 2) L2361: intern L2361 PUSH 15,1 CAMN 0,SYMVAL+640 JRST L2362 MOVE 1,2 JRST L2363 L2362: CAMN 1,SYMVAL+616 JRST L2364 MOVE 1,L2359 PUSHJ 15,SYMFNC+418 L2364: MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+632 L2363: ADJSP 15,-1 POPJ 15,0 L2359: <4_30>+<1_18>+L2360 L2366: 16 byte(7)68,111,116,32,99,111,110,116,101,120,116,32,101,114,114,111,114,0 ; (!*ENTRY DOTCONTEXTERROR EXPR 0) L2351: intern L2351 MOVE 1,L2365 JRST SYMFNC+507 L2365: <4_30>+<1_18>+L2366 1 ; (!*ENTRY CHANNELREADVECTOR EXPR 1) L2368: intern L2368 ADJSP 15,4 MOVEM 1,0(15) JSP 10,SYMFNC+443 byte(18)0,640 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+640 MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,-3(15) MOVEM 2,-2(15) L2369: MOVE 1,0(15) PUSHJ 15,SYMFNC+632 MOVEM 1,-1(15) MOVE 2,SYMVAL+634 MOVE 1,SYMVAL+84 CAIE 2,3 JRST L2370 MOVE 1,0 L2370: CAME 1,0 JRST L2371 MOVE 1,SYMVAL+84 MOVE 6,-1(15) CAME 6,L2367 JRST L2371 MOVE 1,0 L2371: CAMN 1,0 JRST L2372 MOVE 1,-1(15) PUSHJ 15,SYMFNC+172 MOVE 7,-3(15) MOVEM 1,1(7) MOVE 2,-3(15) MOVE 2,1(2) MOVEM 2,-3(15) JRST L2369 L2372: MOVE 1,-2(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+152 JSP 10,SYMFNC+447 1 ADJSP 15,-4 POPJ 15,0 L2367: <30_30>+93 extern TOKCH extern L2373 extern L2374 extern L2375 extern L2376 extern L2377 extern L2378 extern L2379 extern L2380 extern L2381 L2383: 37 byte(7)42,42,42,42,42,32,82,69,65,68,32,66,117,102,102,101,114,32,111,118,101,114,102,108,111,119,44,32,84,114,117,110,99,97,116,105,110,103,0 ; (!*ENTRY READINBUF EXPR 0) L2384: intern L2384 MOVE 1,L2373 PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH MOVE 3,1 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 2,SYMVAL+635 TLZ 2,258048 ADDM 3,2 MOVE 6,1(2) MOVEM 6,L2374 MOVE 7,L2375 CAIL 7,5000 JRST L2385 AOS L2375 MOVE 1,L2375 POPJ 15,0 L2385: MOVE 7,L2375 CAIE 7,5000 JRST L2386 MOVE 1,L2382 PUSHJ 15,SYMFNC+418 L2386: HRRZI 1,5001 MOVEM 1,L2375 POPJ 15,0 L2382: <4_30>+<1_18>+L2383 ; (!*ENTRY MAKEBUFINTOID EXPR 0) L2387: intern L2387 SETZM SYMVAL+634 MOVE 7,L2375 CAIE 7,1 JRST L2388 SETZM 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 LDB 1,2 HRLI 1,122880 POPJ 15,0 L2388: SETZM 3 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,L2375 SOS 1 MOVEM 1,L2110 CAMN 0,SYMVAL+647 JRST L2389 XMOVEI 1,L2110 PUSHJ 15,SYMFNC+395 JRST SYMFNC+649 L2389: XMOVEI 1,L2110 TLZ 1,258048 TLO 1,16384 JRST SYMFNC+560 ; (!*ENTRY MAKEBUFINTOSTRING EXPR 0) L2390: intern L2390 HRRZI 6,1 MOVEM 6,SYMVAL+634 SETZM 3 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,L2375 SOS 1 MOVEM 1,L2110 XMOVEI 1,L2110 JRST SYMFNC+395 ; (!*ENTRY MAKEBUFINTOSYSNUMBER EXPR 2) L2391: intern L2391 MOVE 5,1 MOVE 4,2 SETZM 3 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,L2375 SOS 1 MOVEM 1,L2110 MOVE 3,4 MOVE 2,5 XMOVEI 1,L2110 JRST L2392 ; (!*ENTRY MAKEBUFINTOLISPINTEGER EXPR 2) L2393: intern L2393 MOVE 5,1 MOVE 4,2 HRRZI 6,2 MOVEM 6,SYMVAL+634 SETZM 3 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,L2375 SOS 1 MOVEM 1,L2110 MOVE 3,4 MOVE 2,5 XMOVEI 1,L2110 TLZ 1,258048 TLO 1,16384 JRST SYMFNC+650 extern L2394 extern L2395 extern L2396 extern L2397 ; (!*ENTRY MAKEBUFINTOFLOAT EXPR 2) L2398: intern L2398 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) HRRZI 2,10 XMOVEI 1,L2396 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) SETZM 2 XMOVEI 1,L2394 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) SETZM 2 XMOVEI 1,L2397 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) MOVE 1,L2375 SOS 1 MOVEM 1,-3(15) SETZM -4(15) L2399: MOVE 6,-4(15) CAMLE 6,-3(15) JRST L2400 MOVE 2,-4(15) XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 LDB 1,2 PUSHJ 15,SYMFNC+651 MOVE 2,1 XMOVEI 1,L2395 FLTR 2,2 MOVEM 2,0(1) SETZM 1(1) XMOVEI 3,L2396 XMOVEI 2,L2394 XMOVEI 1,L2394 DMOVE 3,0(3) DFMP 3,0(2) DMOVEM 3,0(1) XMOVEI 3,L2395 XMOVEI 2,L2394 XMOVEI 1,L2394 DMOVE 3,0(3) DFAD 3,0(2) DMOVEM 3,0(1) AOS -4(15) JRST L2399 L2400: SKIPG 0(15) JRST L2401 MOVEM 0,-4(15) HRRZI 6,1 MOVEM 6,-4(15) L2402: MOVE 6,-4(15) CAMLE 6,0(15) JRST L2403 XMOVEI 3,L2396 XMOVEI 2,L2394 XMOVEI 1,L2394 DMOVE 3,0(3) DFMP 3,0(2) DMOVEM 3,0(1) AOS -4(15) JRST L2402 L2401: SKIPL 0(15) JRST L2403 MOVN 1,0(15) MOVEM 1,0(15) MOVEM 0,-4(15) HRRZI 6,1 MOVEM 6,-4(15) L2404: MOVE 6,-4(15) CAMLE 6,0(15) JRST L2403 XMOVEI 3,L2396 XMOVEI 2,L2394 XMOVEI 1,L2394 DMOVE 4,0(2) DFDV 4,0(3) DMOVEM 4,0(1) AOS -4(15) JRST L2404 L2403: CAMN 0,-1(15) JRST L2405 XMOVEI 3,L2394 XMOVEI 2,L2397 XMOVEI 1,L2394 DMOVE 4,0(2) DFSB 4,0(3) DMOVEM 4,0(1) L2405: HRRZI 6,2 MOVEM 6,SYMVAL+634 PUSHJ 15,SYMFNC+388 MOVEM 1,-2(15) XMOVEI 2,L2394 AOS 1 DMOVE 2,0(2) DMOVEM 2,0(1) MOVE 1,-2(15) TLZ 1,258048 TLO 1,12288 ADJSP 15,-5 POPJ 15,0 L2417: 24 byte(7)77,105,115,115,105,110,103,32,101,120,112,111,110,101,110,116,32,105,110,32,102,108,111,97,116,0 L2418: 17 byte(7)68,105,103,105,116,32,111,117,116,32,111,102,32,114,97,110,103,101,0 L2419: 17 byte(7)82,97,100,105,120,32,111,117,116,32,111,102,32,114,97,110,103,101,0 L2420: 27 byte(7)69,79,70,32,101,110,99,111,117,110,116,101,114,101,100,32,105,110,115,105,100,101,32,97,110,32,73,68,0 L2421: 30 byte(7)69,79,70,32,101,110,99,111,117,110,116,101,114,101,100,32,105,110,115,105,100,101,32,97,32,115,116,114,105,110,103,0 L2422: 36 byte(7)42,42,42,32,83,116,114,105,110,103,32,99,111,110,116,105,110,117,101,100,32,111,118,101,114,32,101,110,100,45,111,102,45,108,105,110,101,0 L2423: 46 byte(7)73,108,108,101,103,97,108,32,116,111,32,102,111,108,108,111,119,32,112,97,99,107,97,103,101,32,105,110,100,105,99,97,116,111,114,32,119,105,116,104,32,110,111,110,32,73,68,0 L2424: 17 byte(7)85,110,107,110,111,119,110,32,116,111,107,101,110,32,116,121,112,101,0 L2425: 32 byte(7)73,110,116,101,114,110,97,108,32,101,114,114,111,114,32,45,32,99,111,110,115,117,108,116,32,97,32,119,105,122,97,114,100,0 1 ; (!*ENTRY CHANNELREADTOKEN EXPR 1) L2426: intern L2426 PUSH 15,1 MOVEM 1,L2373 SETZM L2376 SETZM L2375 L2427: MOVE 1,0(15) PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,L2374 MOVE 7,L2374 CAIN 7,17 JRST L2427 MOVE 3,1 MOVE 2,L2375 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS L2375 MOVE 1,L2374 JUMPL 1,L2428 CAIG 1,9 JRST L2429 L2428: CAIL 1,10 CAILE 1,21 JRST L2430 JRST @L2431-10(1) L2431: IFIW L2432 IFIW L2433 IFIW L2434 IFIW L2435 IFIW L2436 IFIW L2437 IFIW L2438 IFIW L2439 IFIW L2440 IFIW L2441 IFIW L2442 IFIW L2443 L2430: JRST L2444 L2429: HRRZI 6,1 MOVEM 6,L2378 JRST L2445 L2432: CAMN 0,SYMVAL+627 JRST L2446 CAIGE 3,97 JRST L2447 CAILE 3,122 JRST L2447 SUBI 3,32 MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2447 L2433: HRRZI 6,3 MOVEM 6,SYMVAL+634 MOVE 1,3 HRLI 1,122880 JRST L2448 L2435: MOVE 2,3 HRLI 2,122880 MOVE 1,L2373 ADJSP 15,-1 JRST L2449 L2436: CAME 0,SYMVAL+627 JRST L2450 JRST L2451 L2437: SOS L2375 JRST L2452 L2438: SETZM L2375 HRRZI 6,1 MOVEM 6,L2376 MOVE 1,L2406 PUSHJ 15,SYMFNC+652 CAME 0,SYMVAL+627 JRST L2453 JRST L2454 L2439: MOVE 1,L2407 PUSHJ 15,L2455 JRST L2451 L2440: SETOM L2378 JRST L2456 L2441: HRRZI 6,1 MOVEM 6,L2378 JRST L2456 L2442: SETZM L2375 PUSHJ 15,L2384 MOVE 7,L2374 CAIGE 7,10 JRST L2457 MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 MOVE 2,L2408 MOVE 1,L2373 ADJSP 15,-1 JRST L2449 L2457: HRRZI 6,1 MOVEM 6,L2378 JRST L2458 L2443: SOS L2375 JRST L2459 L2444: MOVE 1,L2409 ADJSP 15,-1 JRST L2455 L2451: SOS L2375 PUSHJ 15,L2384 L2446: PUSHJ 15,L2384 MOVE 7,L2374 CAIG 7,10 JRST L2446 MOVE 7,L2374 CAIN 7,19 JRST L2446 MOVE 7,L2374 CAIN 7,18 JRST L2446 MOVE 7,L2374 CAIN 7,14 JRST L2451 MOVE 7,L2374 CAIE 7,16 JRST L2460 SOS L2375 HRRZI 6,1 MOVEM 6,L2376 PUSHJ 15,L2387 PUSHJ 15,SYMFNC+652 SETZM L2375 JRST L2454 L2460: MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 SKIPN L2376 JRST L2461 MOVE 1,SYMVAL+653 PUSHJ 15,SYMFNC+652 L2461: ADJSP 15,-1 JRST L2387 L2454: PUSHJ 15,L2384 MOVE 7,L2374 CAIN 7,10 JRST L2446 MOVE 7,L2374 CAIN 7,14 JRST L2451 MOVE 1,L2410 PUSHJ 15,L2455 L2450: SOS L2375 PUSHJ 15,L2384 L2447: PUSHJ 15,L2384 MOVE 7,L2374 CAIGE 7,10 JRST L2447 MOVE 7,L2374 CAIN 7,19 JRST L2447 MOVE 7,L2374 CAIN 7,18 JRST L2447 MOVE 7,L2374 CAIE 7,10 JRST L2462 MOVE 7,TOKCH CAIGE 7,97 JRST L2447 MOVE 7,TOKCH CAILE 7,122 JRST L2447 MOVE 3,TOKCH SUBI 3,32 MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2447 L2462: MOVE 7,L2374 CAIN 7,14 JRST L2450 MOVE 7,L2374 CAIE 7,16 JRST L2463 SOS L2375 HRRZI 6,1 MOVEM 6,L2376 PUSHJ 15,L2387 PUSHJ 15,SYMFNC+652 SETZM L2375 JRST L2453 L2463: MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 SKIPN L2376 JRST L2464 MOVE 1,SYMVAL+653 PUSHJ 15,SYMFNC+652 L2464: ADJSP 15,-1 JRST L2387 L2453: PUSHJ 15,L2384 MOVE 7,L2374 CAIE 7,10 JRST L2465 MOVE 7,TOKCH CAIGE 7,97 JRST L2447 MOVE 7,TOKCH CAILE 7,122 JRST L2447 MOVE 3,TOKCH SUBI 3,32 MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2447 L2465: MOVE 7,L2374 CAIN 7,14 JRST L2450 MOVE 1,L2410 PUSHJ 15,L2455 L2452: PUSHJ 15,L2384 MOVE 7,L2374 CAIE 7,15 JRST L2466 SOS L2375 PUSHJ 15,L2384 MOVE 7,L2374 CAIN 7,15 JRST L2452 MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 ADJSP 15,-1 JRST L2390 L2466: MOVE 7,TOKCH CAIE 7,10 JRST L2467 CAME 0,SYMVAL+648 JRST L2467 MOVE 1,L2411 PUSHJ 15,SYMFNC+418 JRST L2452 L2467: MOVE 7,TOKCH CAIE 7,26 JRST L2452 MOVE 1,L2412 PUSHJ 15,L2455 JRST L2452 L2459: PUSHJ 15,L2384 MOVE 7,L2374 CAIE 7,21 JRST L2468 SOS L2375 ADJSP 15,-1 JRST L2387 L2468: MOVE 7,L2374 CAIE 7,14 JRST L2469 SOS L2375 PUSHJ 15,L2384 JRST L2459 L2469: MOVE 7,TOKCH CAIE 7,26 JRST L2459 MOVE 1,L2413 PUSHJ 15,L2455 JRST L2459 L2456: SETZM L2375 PUSHJ 15,L2384 MOVE 7,TOKCH CAIE 7,46 JRST L2470 HRRZI 3,48 SETZM 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 HRRZI 6,2 MOVEM 6,L2375 JRST L2471 L2470: MOVE 7,L2374 CAIN 7,10 JRST L2472 MOVE 7,L2374 CAIN 7,18 JRST L2472 MOVE 7,L2374 CAIE 7,19 JRST L2473 L2472: SETZM L2375 SKIPL L2378 JRST L2474 HRRZI 1,45 JRST L2475 L2474: HRRZI 1,43 L2475: MOVE 3,1 SETZM 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 3,TOKCH HRRZI 2,1 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 HRRZI 6,2 MOVEM 6,L2375 CAMN 0,SYMVAL+627 JRST L2446 CAIGE 3,97 JRST L2447 CAILE 3,122 JRST L2447 SUBI 3,32 MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2447 L2473: MOVE 7,L2374 CAIE 7,14 JRST L2476 SETZM L2375 SKIPL L2378 JRST L2477 HRRZI 1,45 JRST L2478 L2477: HRRZI 1,43 L2478: MOVE 3,1 SETZM 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 HRRZI 6,1 MOVEM 6,L2375 CAMN 0,SYMVAL+627 JRST L2451 JRST L2450 L2476: MOVE 7,L2374 CAIG 7,9 JRST L2445 MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SKIPL L2378 JRST L2479 HRRZI 1,45 JRST L2480 L2479: HRRZI 1,43 L2480: MOVE 2,1 HRLI 2,122880 MOVE 1,0(15) ADJSP 15,-1 JRST L2449 L2445: PUSHJ 15,L2384 MOVE 7,L2374 CAIGE 7,10 JRST L2445 MOVE 7,TOKCH CAIE 7,35 JRST L2481 SOS L2375 HRRZI 2,1 HRRZI 1,10 PUSHJ 15,L2391 MOVEM 1,L2377 SETZM L2375 CAIGE 1,2 JRST L2482 CAIG 1,36 JRST L2483 L2482: MOVE 1,L2414 ADJSP 15,-1 JRST L2455 L2483: CAILE 1,10 JRST L2484 JRST L2485 L2481: MOVE 7,TOKCH CAIN 7,46 JRST L2471 MOVE 7,TOKCH CAIN 7,66 JRST L2486 MOVE 7,TOKCH CAIE 7,98 JRST L2487 L2486: SOS L2375 MOVE 2,L2378 HRRZI 1,8 ADJSP 15,-1 JRST L2393 L2487: MOVE 7,TOKCH CAIN 7,69 JRST L2488 MOVE 7,TOKCH CAIE 7,101 JRST L2489 L2488: SETZM L2379 JRST L2490 L2489: MOVE 7,L2374 CAIN 7,10 JRST L2491 MOVE 7,L2374 CAIN 7,18 JRST L2491 MOVE 7,L2374 CAIE 7,19 JRST L2492 L2491: CAMN 0,SYMVAL+627 JRST L2446 MOVE 7,TOKCH CAIGE 7,97 JRST L2447 MOVE 7,TOKCH CAILE 7,122 JRST L2447 MOVE 3,TOKCH SUBI 3,32 MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2447 L2492: MOVE 7,L2374 CAIE 7,14 JRST L2493 CAMN 0,SYMVAL+627 JRST L2451 JRST L2450 L2493: MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 MOVE 2,L2378 HRRZI 1,10 ADJSP 15,-1 JRST L2393 L2485: PUSHJ 15,L2384 MOVE 6,L2377 CAMLE 6,L2374 JRST L2485 MOVE 7,L2374 CAIL 7,10 JRST L2494 MOVE 1,L2415 ADJSP 15,-1 JRST L2455 L2494: MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 MOVE 2,L2378 MOVE 1,L2377 ADJSP 15,-1 JRST L2393 L2484: PUSHJ 15,L2384 MOVE 7,L2374 CAIGE 7,10 JRST L2484 MOVE 7,L2374 CAILE 7,10 JRST L2494 MOVE 7,TOKCH CAIGE 7,97 JRST L2495 MOVE 7,TOKCH CAILE 7,122 JRST L2495 MOVNI 7,32 ADDM 7,TOKCH MOVE 3,TOKCH MOVE 2,L2375 SOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 L2495: MOVE 1,L2377 ADDI 1,55 CAMLE 1,TOKCH JRST L2484 JRST L2494 L2471: SOS L2375 PUSHJ 15,L2384 MOVE 7,TOKCH CAIN 7,69 JRST L2496 MOVE 7,TOKCH CAIE 7,101 JRST L2497 L2496: SETZM L2379 JRST L2490 L2497: MOVE 7,L2374 CAIGE 7,10 JRST L2458 MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 MOVE 1,L2378 MOVE 2,SYMVAL+84 JUMPL 1,L2498 MOVE 2,0 L2498: SETZM 1 ADJSP 15,-1 JRST L2398 L2458: HRRZI 6,1 MOVEM 6,L2379 L2499: PUSHJ 15,L2384 MOVE 7,L2374 CAIL 7,10 JRST L2500 MOVE 7,L2379 CAIL 7,9 JRST L2501 AOS L2379 JRST L2499 L2501: SOS L2375 JRST L2499 L2500: MOVE 7,TOKCH CAIN 7,69 JRST L2490 MOVE 7,TOKCH CAIN 7,101 JRST L2490 MOVE 2,TOKCH MOVE 1,0(15) PUSHJ 15,SYMFNC+601 SOS L2375 MOVE 1,L2378 MOVE 2,SYMVAL+84 JUMPL 1,L2502 MOVE 2,0 L2502: MOVN 1,L2379 ADJSP 15,-1 JRST L2398 L2490: SOS L2375 HRRZI 6,1 MOVEM 6,L2380 SETZM L2381 MOVE 1,L2373 PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,L2374 MOVE 7,L2374 CAIGE 7,10 JRST L2503 CAIE 1,45 JRST L2504 SETOM L2380 JRST L2505 L2504: CAIN 1,43 JRST L2505 MOVE 1,L2416 ADJSP 15,-1 JRST L2455 L2505: MOVE 1,L2373 PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,L2374 MOVE 7,L2374 CAIGE 7,10 JRST L2503 MOVE 1,L2416 ADJSP 15,-1 JRST L2455 L2503: MOVE 6,L2374 MOVEM 6,L2381 L2506: MOVE 1,L2373 PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,L2374 MOVE 7,L2374 CAIL 7,10 JRST L2507 MOVE 2,L2381 IMULI 2,10 ADD 2,L2374 MOVEM 2,L2381 JRST L2506 L2507: MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+601 MOVE 1,L2378 MOVE 2,SYMVAL+84 JUMPL 1,L2508 MOVE 2,0 L2508: MOVE 1,L2380 IMUL 1,L2381 SUB 1,L2379 ADJSP 15,-1 JRST L2398 L2434: MOVE 1,0(15) PUSHJ 15,SYMFNC+598 MOVEM 1,TOKCH CAIE 1,10 JRST L2509 SETZM L2375 JRST L2427 L2509: CAIE 1,26 JRST L2434 MOVE 1,SYMVAL+642 L2448: ADJSP 15,-1 POPJ 15,0 L2416: <4_30>+<1_18>+L2417 L2415: <4_30>+<1_18>+L2418 L2414: <4_30>+<1_18>+L2419 L2413: <4_30>+<1_18>+L2420 L2412: <4_30>+<1_18>+L2421 L2411: <4_30>+<1_18>+L2422 L2410: <4_30>+<1_18>+L2423 L2409: <4_30>+<1_18>+L2424 L2408: <30_30>+46 L2407: <4_30>+<1_18>+L2425 L2406: <30_30>+654 0 ; (!*ENTRY RATOM EXPR 0) RATOM: intern RATOM MOVE 1,SYMVAL+600 JRST SYMFNC+633 1 ; (!*ENTRY DIGITTONUMBER EXPR 1) L2510: intern L2510 CAIGE 1,48 JRST L2511 CAILE 1,57 JRST L2511 SUBI 1,48 POPJ 15,0 L2511: SUBI 1,55 POPJ 15,0 3 ; (!*ENTRY MAKESTRINGINTOLISPINTEGER EXPR 3) L2512: intern L2512 PUSHJ 15,L2392 JRST SYMFNC+138 ; (!*ENTRY MAKESTRINGINTOSYSINTEGER EXPR 3) L2392: intern L2392 ADJSP 15,7 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 1,2 PUSHJ 15,L2516 MOVE 4,1 MOVEM 4,-5(15) CAMN 4,0 JRST L2517 MOVE 4,-2(15) MOVE 3,-5(15) MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-7 JRST L2518 L2517: MOVE 2,0(15) TLZ 2,258048 MOVEM 2,0(15) MOVE 6,0(2) LDB 3,L2513 TDNE 3,L2514 TDO 3,L2515 MOVEM 3,-3(15) SETZM -4(15) SETZM -6(15) L2519: MOVE 6,-6(15) CAMLE 6,-3(15) JRST L2520 MOVE 2,-6(15) MOVE 1,0(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 PUSHJ 15,SYMFNC+651 MOVE 2,-4(15) IMUL 2,-1(15) ADDM 2,1 MOVEM 1,-4(15) AOS -6(15) JRST L2519 L2520: SKIPL -2(15) JRST L2521 MOVN 1,-4(15) JRST L2522 L2521: MOVE 1,-4(15) L2522: ADJSP 15,-7 POPJ 15,0 L2513: point 30,6,35 L2514: 536870912 L2515: -536870912 ; (!*ENTRY MAKESTRINGINTOBITSTRING EXPR 4) L2518: intern L2518 ADJSP 15,7 MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) TLZ 1,258048 MOVEM 1,0(15) MOVE 6,0(1) LDB 5,L2523 TDNE 5,L2524 TDO 5,L2525 MOVEM 5,-4(15) SETZM -5(15) SETZM -6(15) L2526: MOVE 6,-6(15) CAMLE 6,-4(15) JRST L2527 MOVE 1,-5(15) MOVE 7,-2(15) LSH 1,0(7) MOVEM 1,-5(15) MOVE 2,-6(15) MOVE 1,0(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 PUSHJ 15,SYMFNC+651 IOR 1,-5(15) MOVEM 1,-5(15) AOS -6(15) JRST L2526 L2527: SKIPL -3(15) JRST L2528 MOVN 1,-5(15) JRST L2529 L2528: MOVE 1,-5(15) L2529: ADJSP 15,-7 POPJ 15,0 L2523: point 30,6,35 L2524: 536870912 L2525: -536870912 ; (!*ENTRY SYSPOWEROF2P EXPR 1) L2516: intern L2516 CAIL 1,1 CAILE 1,8 JRST L2530 JRST @L2531-1(1) L2531: IFIW L2532 IFIW L2533 IFIW L2534 IFIW L2535 IFIW L2534 IFIW L2534 IFIW L2534 IFIW L2536 L2530: CAIN 1,16 JRST L2537 CAIN 1,32 JRST L2538 JRST L2534 L2532: SETZM 1 POPJ 15,0 L2533: HRRZI 1,1 POPJ 15,0 L2535: HRRZI 1,2 POPJ 15,0 L2536: HRRZI 1,3 POPJ 15,0 L2537: HRRZI 1,4 POPJ 15,0 L2538: HRRZI 1,5 POPJ 15,0 L2534: MOVE 1,0 POPJ 15,0 L2540: 31 byte(7)42,42,42,42,42,32,69,114,114,111,114,32,105,110,32,116,111,107,101,110,32,115,99,97,110,110,101,114,58,32,37,115,0 ; (!*ENTRY SCANNERERROR EXPR 1) L2455: intern L2455 MOVE 2,1 MOVE 1,L2539 PUSHJ 15,SYMFNC+155 JRST SYMFNC+156 L2539: <4_30>+<1_18>+L2540 ; (!*ENTRY SCANPOSSIBLEDIPHTHONG EXPR 2) L2449: intern L2449 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVEM 0,-4(15) HRRZI 6,3 MOVEM 6,SYMVAL+634 MOVE 2,SYMVAL+635 TLZ 2,258048 MOVE 2,129(2) MOVE 1,-1(15) PUSHJ 15,SYMFNC+522 MOVE 3,1 MOVEM 3,-2(15) CAME 3,0 JRST L2541 MOVE 1,-1(15) JRST L2542 L2541: MOVE 1,0(15) PUSHJ 15,SYMFNC+598 MOVE 2,-2(15) HRLI 1,122880 MOVEM 1,-4(15) PUSHJ 15,SYMFNC+335 MOVE 2,1 MOVEM 2,-3(15) CAME 2,0 JRST L2543 MOVE 2,-4(15) TLZ 2,258048 MOVE 1,0(15) PUSHJ 15,SYMFNC+601 MOVE 1,-1(15) JRST L2542 L2543: MOVE 1,1(2) L2542: ADJSP 15,-5 POPJ 15,0 0 ; (!*ENTRY READLINE EXPR 0) L2544: intern L2544 PUSHJ 15,SYMFNC+639 MOVE 1,SYMVAL+600 JRST SYMFNC+657 L2546: -1 byte(7)0 1 ; (!*ENTRY CHANNELREADLINE EXPR 1) L2547: intern L2547 ADJSP 15,2 MOVEM 1,0(15) SETOM L2110 L2548: MOVE 1,0(15) PUSHJ 15,SYMFNC+598 MOVEM 1,-1(15) CAIN 1,10 JRST L2549 CAIN 1,26 JRST L2549 AOS L2110 MOVE 3,1 MOVE 2,L2110 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 JRST L2548 L2549: SKIPGE L2110 JRST L2550 SETZM 3 MOVE 2,L2110 AOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 XMOVEI 1,L2110 TLZ 1,258048 TLO 1,16384 ADJSP 15,-2 JRST SYMFNC+395 L2550: MOVE 1,L2545 ADJSP 15,-2 POPJ 15,0 L2545: <4_30>+<1_18>+L2546 1 ; (!*ENTRY PACKAGE EXPR 1) L2551: intern L2551 MOVE 1,0 POPJ 15,0 0 ; (!*ENTRY MAKEINPUTAVAILABLE EXPR 0) L2552: intern L2552 MOVE 1,0 POPJ 15,0 ; (!*ENTRY CHECKLINEFIT EXPR 4) L2553: intern L2553 ADJSP 15,3 MOVEM 2,0(15) MOVEM 3,-1(15) MOVEM 4,-2(15) MOVE 5,1 ADD 5,L2257(2) CAMG 5,L2259(2) JRST L2554 SKIPG L2259(2) JRST L2554 HRRZI 2,10 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2554: MOVE 3,-1(15) MOVE 2,-2(15) MOVE 1,0(15) ADJSP 15,-3 TLZ 3,258048 JRST SYMFNC(3) 2 ; (!*ENTRY CHANNELWRITESTRING EXPR 2) L2558: intern L2558 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 4,2 TLZ 4,258048 MOVE 6,0(4) LDB 3,L2555 TDNE 3,L2556 TDO 3,L2557 MOVEM 3,-2(15) SETZM -3(15) L2559: MOVE 6,-3(15) CAMLE 6,-2(15) JRST L2560 MOVE 2,-3(15) MOVE 1,-1(15) TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 AOS -3(15) JRST L2559 L2560: MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2555: point 30,6,35 L2556: 536870912 L2557: -536870912 1 ; (!*ENTRY WRITESTRING EXPR 1) L2561: intern L2561 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+660 extern L2562 extern L2563 3 ; (!*ENTRY CHANNELWRITESYSINTEGER EXPR 3) L2564: intern L2564 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-4(15) MOVE 1,3 PUSHJ 15,L2516 MOVE 4,1 MOVEM 4,-3(15) CAMN 4,0 JRST L2565 MOVE 3,-2(15) SOS 3 MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-5 JRST L2566 L2565: SKIPL -1(15) JRST L2567 HRRZI 2,45 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVE 2,-2(15) MOVE 1,-1(15) IDIV 1,2 MOVE 3,-2(15) MOVN 2,1 MOVE 1,0(15) PUSHJ 15,L2568 MOVE 2,-2(15) MOVE 1,-1(15) IDIV 1,2 MOVE 1,2 MOVN 2,1 XMOVEI 1,1+L2562 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+359 L2567: SKIPE -1(15) JRST L2569 HRRZI 2,48 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+359 L2569: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-5 JRST L2568 ; (!*ENTRY WRITENUMBER1 EXPR 3) L2568: intern L2568 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) JUMPE 2,L2570 MOVE 2,3 MOVE 1,-1(15) IDIV 1,2 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,L2568 MOVE 2,-2(15) MOVE 1,-1(15) IDIV 1,2 MOVE 1,2 MOVE 2,1 XMOVEI 1,1+L2562 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+359 L2570: ADJSP 15,-3 POPJ 15,0 ; (!*ENTRY CHANNELWRITEBITSTRING EXPR 4) L2566: intern L2566 JUMPN 2,L2571 HRRZI 2,48 JRST SYMFNC+359 L2571: JRST SYMFNC+663 4 ; (!*ENTRY CHANNELWRITEBITSTRAUX EXPR 4) L2572: intern L2572 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) JUMPE 2,L2573 MOVN 5,4 LSH 2,0(5) PUSHJ 15,L2572 MOVE 2,-1(15) AND 2,-2(15) XMOVEI 1,1+L2562 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+359 L2573: ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY WRITESYSINTEGER EXPR 2) L2574: intern L2574 MOVE 3,2 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+662 2 ; (!*ENTRY CHANNELWRITEFIXNUM EXPR 2) L2575: intern L2575 TLZ 2,258048 MOVE 2,1(2) JRST SYMFNC+666 2 ; (!*ENTRY CHANNELWRITEINTEGER EXPR 2) L2576: intern L2576 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 3,SYMVAL+658 MOVEM 3,-2(15) CAIN 3,10 JRST L2577 HRRZI 3,10 MOVE 2,-2(15) PUSHJ 15,SYMFNC+662 HRRZI 2,35 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2577: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+662 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY CHANNELWRITESYSFLOAT EXPR 2) L2578: intern L2578 PUSH 15,1 XMOVEI 1,L2563 PUSHJ 15,SYMFNC+668 XMOVEI 2,L2563 MOVE 1,0(15) PUSHJ 15,SYMFNC+660 MOVE 1,0 ADJSP 15,-1 POPJ 15,0 2 ; (!*ENTRY CHANNELWRITEFLOAT EXPR 2) L2579: intern L2579 TLZ 2,258048 AOS 2 JRST SYMFNC+667 2 ; (!*ENTRY CHANNELPRINTSTRING EXPR 2) L2583: intern L2583 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) HRRZI 2,34 PUSHJ 15,SYMFNC+359 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2580 TDNE 1,L2581 TDO 1,L2582 MOVEM 1,-2(15) SETZM -4(15) L2584: MOVE 6,-4(15) CAMLE 6,-2(15) JRST L2585 MOVE 2,-4(15) MOVE 1,-1(15) TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) CAIE 1,34 JRST L2586 HRRZI 2,34 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2586: MOVE 2,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 AOS -4(15) JRST L2584 L2585: HRRZI 2,34 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2580: point 30,6,35 L2581: 536870912 L2582: -536870912 2 ; (!*ENTRY CHANNELWRITEID EXPR 2) L2590: intern L2590 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) CAME 0,SYMVAL+573 JRST L2591 TLZ 2,258048 MOVE 2,SYMNAM(2) ADJSP 15,-5 JRST SYMFNC+660 L2591: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 3,2 TLZ 3,258048 MOVE 2,SYMNAM(3) TLZ 2,258048 MOVEM 2,-1(15) MOVE 6,0(2) LDB 4,L2587 TDNE 4,L2588 TDO 4,L2589 MOVEM 4,-3(15) MOVEM 0,-4(15) SETZM -4(15) L2592: MOVE 6,-4(15) CAMLE 6,-3(15) JRST L2593 MOVE 2,-4(15) MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-2(15) CAIGE 1,65 JRST L2594 CAILE 1,90 JRST L2594 HRRZI 7,32 ADDM 7,-2(15) L2594: MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 AOS -4(15) JRST L2592 L2593: MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2587: point 30,6,35 L2588: 536870912 L2589: -536870912 L2596: 9 byte(7)35,60,85,110,98,111,117,110,100,58,0 2 ; (!*ENTRY CHANNELWRITEUNBOUND EXPR 2) L2597: intern L2597 PUSH 15,2 PUSH 15,1 MOVE 2,L2595 PUSHJ 15,SYMFNC+660 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+671 HRRZI 2,62 MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+359 L2595: <4_30>+<1_18>+L2596 2 ; (!*ENTRY CHANNELPRINTID EXPR 2) L2601: intern L2601 ADJSP 15,6 MOVEM 1,0(15) MOVEM 0,-4(15) MOVE 3,2 TLZ 3,258048 MOVE 2,SYMNAM(3) TLZ 2,258048 MOVEM 2,-1(15) MOVE 6,0(2) LDB 4,L2598 TDNE 4,L2599 TDO 4,L2600 MOVEM 4,-2(15) SETZM 2 MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) MOVE 5,SYMVAL+635 TLZ 5,258048 ADDM 1,5 MOVE 7,1(5) CAIN 7,10 JRST L2602 MOVE 2,SYMVAL+659 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2602: CAME 0,SYMVAL+573 JRST L2603 MOVE 2,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVEM 0,-5(15) HRRZI 6,1 MOVEM 6,-5(15) L2604: MOVE 6,-5(15) CAMLE 6,-2(15) JRST L2605 MOVE 2,-5(15) MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,-4(15) MOVE 6,-4(15) CAIG 6,10 JRST L2606 MOVE 6,-4(15) CAIN 6,19 JRST L2606 MOVE 6,-4(15) CAIN 6,18 JRST L2606 MOVE 2,SYMVAL+659 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2606: MOVE 2,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 AOS -5(15) JRST L2604 L2603: MOVE 6,-3(15) CAIGE 6,65 JRST L2607 MOVE 6,-3(15) CAILE 6,90 JRST L2607 HRRZI 7,32 ADDM 7,-3(15) L2607: MOVE 2,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVEM 0,-5(15) HRRZI 6,1 MOVEM 6,-5(15) L2608: MOVE 6,-5(15) CAMLE 6,-2(15) JRST L2605 MOVE 2,-5(15) MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) MOVE 3,SYMVAL+635 TLZ 3,258048 ADDM 1,3 MOVE 6,1(3) MOVEM 6,-4(15) MOVE 6,-4(15) CAIG 6,10 JRST L2609 MOVE 6,-4(15) CAIN 6,19 JRST L2609 MOVE 6,-4(15) CAIN 6,18 JRST L2609 MOVE 2,SYMVAL+659 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2609: MOVE 6,-3(15) CAIGE 6,65 JRST L2610 MOVE 6,-3(15) CAILE 6,90 JRST L2610 HRRZI 7,32 ADDM 7,-3(15) L2610: MOVE 2,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+359 AOS -5(15) JRST L2608 L2605: MOVE 1,0 ADJSP 15,-6 POPJ 15,0 L2598: point 30,6,35 L2599: 536870912 L2600: -536870912 L2612: 9 byte(7)35,60,85,110,98,111,117,110,100,32,0 2 ; (!*ENTRY CHANNELPRINTUNBOUND EXPR 2) L2613: intern L2613 PUSH 15,2 PUSH 15,1 MOVE 2,L2611 PUSHJ 15,SYMFNC+660 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+673 HRRZI 2,62 MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+359 L2611: <4_30>+<1_18>+L2612 L2615: 6 byte(7)35,60,67,111,100,101,32,0 2 ; (!*ENTRY CHANNELWRITECODEPOINTER EXPR 2) L2616: intern L2616 ADJSP 15,3 MOVEM 1,0(15) TLZ 2,258048 MOVEM 2,-1(15) MOVE 2,L2614 PUSHJ 15,SYMFNC+660 MOVE 6,-1(15) MOVE 6,-1(6) MOVEM 6,-2(15) SKIPGE -2(15) JRST L2617 MOVE 6,-2(15) CAILE 6,15 JRST L2617 HRRZI 3,10 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+662 HRRZI 2,32 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 L2617: HRRZI 3,8 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+662 HRRZI 2,62 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L2614: <4_30>+<1_18>+L2615 L2619: 9 byte(7)35,60,85,110,107,110,111,119,110,32,0 2 ; (!*ENTRY CHANNELWRITEUNKNOWNITEM EXPR 2) L2620: intern L2620 PUSH 15,2 PUSH 15,1 MOVE 2,L2618 PUSHJ 15,SYMFNC+660 HRRZI 3,8 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+662 HRRZI 2,62 MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+359 L2618: <4_30>+<1_18>+L2619 1 ; (!*ENTRY CHANNELWRITEBLANKOREOL EXPR 1) L2621: intern L2621 MOVE 2,L2257(1) AOS 2 CAMGE 2,L2259(1) JRST L2622 SKIPG L2259(1) JRST L2622 HRRZI 2,10 JRST L2623 L2622: HRRZI 2,32 L2623: JRST SYMFNC+359 L2635: 2 byte(7)46,46,46,0 L2636: 2 byte(7)32,46,32,0 L2637: 3 byte(7)32,46,46,46,0 3 ; (!*ENTRY CHANNELWRITEPAIR EXPR 3) L2638: intern L2638 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2625 CAIN 11,63 JRST L2624 CAILE 11,0 JRST L2639 L2624: CAMGE 3,SYMVAL+678 JRST L2639 HRRZI 2,35 ADJSP 15,-4 JRST SYMFNC+359 L2639: MOVEM 0,-3(15) AOS -2(15) HRRZI 4,40 MOVE 3,L2626 MOVE 2,1 HRRZI 1,1 PUSHJ 15,L2553 LDB 11,L2628 CAIN 11,63 JRST L2627 CAILE 11,0 JRST L2640 L2627: SKIPG SYMVAL+679 JRST L2641 L2640: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+680 HRRZI 6,2 MOVEM 6,-3(15) MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) L2642: LDB 11,L2629 CAIE 11,9 JRST L2643 LDB 11,L2628 CAIN 11,63 JRST L2630 CAILE 11,0 JRST L2644 L2630: MOVE 6,-3(15) CAMLE 6,SYMVAL+679 JRST L2643 L2644: MOVE 1,0(15) PUSHJ 15,SYMFNC+676 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+680 AOS -3(15) MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L2642 L2643: LDB 11,L2629 CAIE 11,9 JRST L2645 MOVE 4,L2631 JRST L2646 L2645: CAMN 0,-1(15) JRST L2647 MOVE 4,L2632 MOVE 3,L2633 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+680 JRST L2647 L2641: MOVE 4,L2634 L2646: MOVE 3,L2633 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2647: HRRZI 4,41 MOVE 3,L2626 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2625: point 6,<SYMVAL+678>,5 L2628: point 6,<SYMVAL+679>,5 L2629: point 6,-1(15),5 L2634: <4_30>+<1_18>+L2635 L2633: <30_30>+660 L2632: <4_30>+<1_18>+L2636 L2631: <4_30>+<1_18>+L2637 L2626: <30_30>+359 L2659: 2 byte(7)46,46,46,0 L2660: 2 byte(7)32,46,32,0 L2661: 3 byte(7)32,46,46,46,0 3 ; (!*ENTRY CHANNELPRINTPAIR EXPR 3) L2662: intern L2662 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2649 CAIN 11,63 JRST L2648 CAILE 11,0 JRST L2663 L2648: CAMGE 3,SYMVAL+678 JRST L2663 HRRZI 2,35 ADJSP 15,-4 JRST SYMFNC+359 L2663: MOVEM 0,-3(15) AOS -2(15) HRRZI 4,40 MOVE 3,L2650 MOVE 2,1 HRRZI 1,1 PUSHJ 15,L2553 LDB 11,L2652 CAIN 11,63 JRST L2651 CAILE 11,0 JRST L2664 L2651: SKIPG SYMVAL+679 JRST L2665 L2664: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+682 HRRZI 6,2 MOVEM 6,-3(15) MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) L2666: LDB 11,L2653 CAIE 11,9 JRST L2667 LDB 11,L2652 CAIN 11,63 JRST L2654 CAILE 11,0 JRST L2668 L2654: MOVE 6,-3(15) CAMLE 6,SYMVAL+679 JRST L2667 L2668: MOVE 1,0(15) PUSHJ 15,SYMFNC+676 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+682 AOS -3(15) MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L2666 L2667: LDB 11,L2653 CAIE 11,9 JRST L2669 MOVE 4,L2655 JRST L2670 L2669: CAMN 0,-1(15) JRST L2671 MOVE 4,L2656 MOVE 3,L2657 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+682 JRST L2671 L2665: MOVE 4,L2658 L2670: MOVE 3,L2657 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2671: HRRZI 4,41 MOVE 3,L2650 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2649: point 6,<SYMVAL+678>,5 L2652: point 6,<SYMVAL+679>,5 L2653: point 6,-1(15),5 L2658: <4_30>+<1_18>+L2659 L2657: <30_30>+660 L2656: <4_30>+<1_18>+L2660 L2655: <4_30>+<1_18>+L2661 L2650: <30_30>+359 L2682: 2 byte(7)46,46,46,0 3 ; (!*ENTRY CHANNELWRITEVECTOR EXPR 3) L2683: intern L2683 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2673 CAIN 11,63 JRST L2672 CAILE 11,0 JRST L2684 L2672: CAMGE 3,SYMVAL+678 JRST L2684 HRRZI 2,35 ADJSP 15,-5 JRST SYMFNC+359 L2684: MOVEM 0,-3(15) MOVEM 0,-4(15) AOS -2(15) HRRZI 4,91 MOVE 3,L2674 MOVE 2,1 HRRZI 1,1 PUSHJ 15,L2553 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2675 TDNE 1,L2676 TDO 1,L2677 MOVEM 1,-3(15) JUMPGE 1,L2685 HRRZI 4,93 MOVE 3,L2674 MOVE 2,0(15) HRRZI 1,1 ADJSP 15,-5 JRST L2553 L2685: SETZM -4(15) L2686: LDB 11,L2679 CAIN 11,63 JRST L2678 CAILE 11,0 JRST L2687 L2678: MOVE 6,-4(15) CAML 6,SYMVAL+679 JRST L2688 L2687: MOVE 3,-2(15) MOVE 2,-1(15) TLZ 2,258048 ADD 2,-4(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+680 AOS -4(15) MOVE 6,-4(15) CAMLE 6,-3(15) JRST L2689 MOVE 1,0(15) PUSHJ 15,SYMFNC+676 JRST L2686 L2688: MOVE 4,L2680 MOVE 3,L2681 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2689: HRRZI 4,93 MOVE 3,L2674 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2673: point 6,<SYMVAL+678>,5 L2675: point 30,6,35 L2676: 536870912 L2677: -536870912 L2679: point 6,<SYMVAL+679>,5 L2681: <30_30>+660 L2680: <4_30>+<1_18>+L2682 L2674: <30_30>+359 L2700: 2 byte(7)46,46,46,0 3 ; (!*ENTRY CHANNELPRINTVECTOR EXPR 3) L2701: intern L2701 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2691 CAIN 11,63 JRST L2690 CAILE 11,0 JRST L2702 L2690: CAMGE 3,SYMVAL+678 JRST L2702 HRRZI 2,35 ADJSP 15,-5 JRST SYMFNC+359 L2702: MOVEM 0,-3(15) MOVEM 0,-4(15) AOS -2(15) HRRZI 4,91 MOVE 3,L2692 MOVE 2,1 HRRZI 1,1 PUSHJ 15,L2553 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2693 TDNE 1,L2694 TDO 1,L2695 MOVEM 1,-3(15) JUMPGE 1,L2703 HRRZI 4,93 MOVE 3,L2692 MOVE 2,0(15) HRRZI 1,1 ADJSP 15,-5 JRST L2553 L2703: SETZM -4(15) L2704: LDB 11,L2697 CAIN 11,63 JRST L2696 CAILE 11,0 JRST L2705 L2696: MOVE 6,-4(15) CAML 6,SYMVAL+679 JRST L2706 L2705: MOVE 3,-2(15) MOVE 2,-1(15) TLZ 2,258048 ADD 2,-4(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+682 AOS -4(15) MOVE 6,-4(15) CAMLE 6,-3(15) JRST L2707 MOVE 1,0(15) PUSHJ 15,SYMFNC+676 JRST L2704 L2706: MOVE 4,L2698 MOVE 3,L2699 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2707: HRRZI 4,93 MOVE 3,L2692 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2691: point 6,<SYMVAL+678>,5 L2693: point 30,6,35 L2694: 536870912 L2695: -536870912 L2697: point 6,<SYMVAL+679>,5 L2699: <30_30>+660 L2698: <4_30>+<1_18>+L2700 L2692: <30_30>+359 L2713: 9 byte(7)35,60,69,86,101,99,116,111,114,32,0 3 ; (!*ENTRY CHANNELWRITEEVECTOR EXPR 3) L2714: intern L2714 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2709 CAIN 11,63 JRST L2708 CAILE 11,0 JRST L2715 L2708: CAMGE 3,SYMVAL+678 JRST L2715 HRRZI 2,35 JRST L2716 L2715: MOVE 1,L2710 PUSHJ 15,SYMFNC+318 CAMN 1,0 JRST L2717 MOVE 2,L2711 MOVE 1,-1(15) PUSHJ 15,SYMFNC+686 MOVE 2,1 CAMN 2,0 JRST L2717 MOVE 5,2 MOVE 4,0 MOVE 3,-2(15) MOVE 2,0(15) MOVE 1,-1(15) MOVE 6,5 PUSHJ 15,SYMFNC+288 JRST L2718 L2717: MOVE 2,L2712 MOVE 1,0(15) PUSHJ 15,SYMFNC+660 HRRZI 3,8 MOVE 2,-1(15) TLZ 2,258048 MOVE 1,0(15) PUSHJ 15,SYMFNC+662 HRRZI 2,62 MOVE 1,0(15) L2716: PUSHJ 15,SYMFNC+359 L2718: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L2709: point 6,<SYMVAL+678>,5 L2712: <4_30>+<1_18>+L2713 L2711: <30_30>+687 L2710: <30_30>+686 L2724: 9 byte(7)35,60,69,86,101,99,116,111,114,32,0 3 ; (!*ENTRY CHANNELPRINTEVECTOR EXPR 3) L2725: intern L2725 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L2720 CAIN 11,63 JRST L2719 CAILE 11,0 JRST L2726 L2719: CAMGE 3,SYMVAL+678 JRST L2726 HRRZI 2,35 JRST L2727 L2726: MOVE 1,L2721 PUSHJ 15,SYMFNC+318 CAMN 1,0 JRST L2728 MOVE 2,L2722 MOVE 1,-1(15) PUSHJ 15,SYMFNC+686 MOVE 2,1 CAMN 2,0 JRST L2728 MOVE 5,2 MOVE 4,SYMVAL+84 MOVE 3,-2(15) MOVE 2,0(15) MOVE 1,-1(15) MOVE 6,5 PUSHJ 15,SYMFNC+288 JRST L2729 L2728: MOVE 2,L2723 MOVE 1,0(15) PUSHJ 15,SYMFNC+660 HRRZI 3,8 MOVE 2,-1(15) TLZ 2,258048 MOVE 1,0(15) PUSHJ 15,SYMFNC+662 HRRZI 2,62 MOVE 1,0(15) L2727: PUSHJ 15,SYMFNC+359 L2729: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L2720: point 6,<SYMVAL+678>,5 L2723: <4_30>+<1_18>+L2724 L2722: <30_30>+687 L2721: <30_30>+686 L2740: 2 byte(7)46,46,46,0 L2741: 7 byte(7)35,60,87,111,114,100,115,58,0 2 ; (!*ENTRY CHANNELWRITEWORDS EXPR 2) L2742: intern L2742 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVE 2,L2730 PUSHJ 15,SYMFNC+660 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2731 TDNE 1,L2732 TDO 1,L2733 MOVEM 1,-2(15) JUMPGE 1,L2743 HRRZI 4,62 MOVE 3,L2734 MOVE 2,0(15) HRRZI 1,1 ADJSP 15,-4 JRST L2553 L2743: SETZM -3(15) L2744: LDB 11,L2736 CAIN 11,63 JRST L2735 CAILE 11,0 JRST L2745 L2735: MOVE 6,-3(15) CAML 6,SYMVAL+679 JRST L2746 L2745: MOVE 4,-1(15) TLZ 4,258048 ADD 4,-3(15) MOVE 4,1(4) MOVE 3,L2737 MOVE 2,0(15) HRRZI 1,10 PUSHJ 15,L2553 AOS -3(15) MOVE 6,-3(15) CAMLE 6,-2(15) JRST L2747 MOVE 1,0(15) PUSHJ 15,SYMFNC+676 JRST L2744 L2746: MOVE 4,L2738 MOVE 3,L2739 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2747: HRRZI 4,62 MOVE 3,L2734 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2731: point 30,6,35 L2732: 536870912 L2733: -536870912 L2736: point 6,<SYMVAL+679>,5 L2739: <30_30>+660 L2738: <4_30>+<1_18>+L2740 L2737: <30_30>+666 L2734: <30_30>+359 L2730: <4_30>+<1_18>+L2741 L2758: 2 byte(7)46,46,46,0 L2759: 11 byte(7)35,60,72,97,108,102,119,111,114,100,115,58,0 2 ; (!*ENTRY CHANNELWRITEHALFWORDS EXPR 2) L2760: intern L2760 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVE 2,L2748 PUSHJ 15,SYMFNC+660 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2749 TDNE 1,L2750 TDO 1,L2751 MOVEM 1,-2(15) JUMPGE 1,L2761 HRRZI 4,62 MOVE 3,L2752 MOVE 2,0(15) HRRZI 1,1 ADJSP 15,-4 JRST L2553 L2761: SETZM -3(15) L2762: LDB 11,L2754 CAIN 11,63 JRST L2753 CAILE 11,0 JRST L2763 L2753: MOVE 6,-3(15) CAML 6,SYMVAL+679 JRST L2764 L2763: MOVE 2,-3(15) MOVE 1,-1(15) TLZ 1,258048 AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 4,1 MOVE 3,L2755 MOVE 2,0(15) HRRZI 1,10 PUSHJ 15,L2553 AOS -3(15) MOVE 6,-3(15) CAMLE 6,-2(15) JRST L2765 MOVE 1,0(15) PUSHJ 15,SYMFNC+676 JRST L2762 L2764: MOVE 4,L2756 MOVE 3,L2757 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2765: HRRZI 4,62 MOVE 3,L2752 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2749: point 30,6,35 L2750: 536870912 L2751: -536870912 L2754: point 6,<SYMVAL+679>,5 L2757: <30_30>+660 L2756: <4_30>+<1_18>+L2758 L2755: <30_30>+666 L2752: <30_30>+359 L2748: <4_30>+<1_18>+L2759 L2776: 2 byte(7)46,46,46,0 L2777: 7 byte(7)35,60,66,121,116,101,115,58,0 2 ; (!*ENTRY CHANNELWRITEBYTES EXPR 2) L2778: intern L2778 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-3(15) MOVE 2,L2766 PUSHJ 15,SYMFNC+660 MOVE 2,-1(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L2767 TDNE 1,L2768 TDO 1,L2769 MOVEM 1,-2(15) JUMPGE 1,L2779 HRRZI 4,62 MOVE 3,L2770 MOVE 2,0(15) HRRZI 1,1 ADJSP 15,-4 JRST L2553 L2779: SETZM -3(15) L2780: LDB 11,L2772 CAIN 11,63 JRST L2771 CAILE 11,0 JRST L2781 L2771: MOVE 6,-3(15) CAML 6,SYMVAL+679 JRST L2782 L2781: MOVE 2,-3(15) MOVE 1,-1(15) TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 4,1 MOVE 3,L2773 MOVE 2,0(15) HRRZI 1,10 PUSHJ 15,L2553 AOS -3(15) MOVE 6,-3(15) CAMLE 6,-2(15) JRST L2783 MOVE 1,0(15) PUSHJ 15,SYMFNC+676 JRST L2780 L2782: MOVE 4,L2774 MOVE 3,L2775 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,L2553 L2783: HRRZI 4,62 MOVE 3,L2770 MOVE 2,0(15) HRRZI 1,1 PUSHJ 15,L2553 MOVE 1,0 ADJSP 15,-4 POPJ 15,0 L2767: point 30,6,35 L2768: 536870912 L2769: -536870912 L2772: point 6,<SYMVAL+679>,5 L2775: <30_30>+660 L2774: <4_30>+<1_18>+L2776 L2773: <30_30>+666 L2770: <30_30>+359 L2766: <4_30>+<1_18>+L2777 2 ; (!*ENTRY CHANNELPRIN2 EXPR 2) L2335: intern L2335 SETZM 3 JRST SYMFNC+680 3 ; (!*ENTRY RECURSIVECHANNELPRIN2 EXPR 3) L2796: intern L2796 PUSH 15,2 PUSH 15,1 LDB 1,L2784 CAIL 1,0 CAILE 1,10 JRST L2797 JRST @L2798-0(1) L2798: IFIW L2799 IFIW L2800 IFIW L2801 IFIW L2802 IFIW L2803 IFIW L2804 IFIW L2805 IFIW L2806 IFIW L2807 IFIW L2808 IFIW L2809 L2797: CAIN 1,15 JRST L2810 CAIN 1,29 JRST L2811 CAIN 1,30 JRST L2812 CAIE 1,63 JRST L2801 L2799: MOVE 4,2 MOVE 3,L2785 MOVE 2,0(15) HRRZI 1,10 PUSHJ 15,L2553 JRST L2813 L2812: MOVE 4,2 MOVE 3,L2786 MOVE 2,0(15) MOVE 1,4 TLZ 1,258048 MOVE 5,SYMNAM(1) TLZ 5,258048 MOVE 6,0(5) LDB 1,L2787 TDNE 1,L2788 TDO 1,L2789 AOS 1 PUSHJ 15,L2553 JRST L2813 L2811: MOVE 4,2 MOVE 3,L2790 MOVE 2,0(15) MOVE 1,4 TLZ 1,258048 MOVE 5,SYMNAM(1) TLZ 5,258048 MOVE 6,0(5) LDB 1,L2787 TDNE 1,L2788 TDO 1,L2789 ADDI 1,12 PUSHJ 15,L2553 JRST L2813 L2803: MOVE 4,2 MOVE 3,L2791 MOVE 2,0(15) MOVE 5,4 TLZ 5,258048 MOVE 6,0(5) LDB 1,L2787 TDNE 1,L2788 TDO 1,L2789 AOS 1 PUSHJ 15,L2553 JRST L2813 L2810: MOVE 4,2 MOVE 3,L2792 MOVE 2,0(15) HRRZI 1,14 PUSHJ 15,L2553 JRST L2813 L2800: MOVE 4,2 MOVE 3,L2793 MOVE 2,0(15) HRRZI 1,20 PUSHJ 15,L2553 JRST L2813 L2802: MOVE 4,2 MOVE 3,L2794 MOVE 2,0(15) HRRZI 1,30 PUSHJ 15,L2553 JRST L2813 L2806: MOVE 1,0(15) PUSHJ 15,SYMFNC+689 JRST L2813 L2805: MOVE 1,0(15) PUSHJ 15,SYMFNC+690 JRST L2813 L2804: MOVE 1,0(15) PUSHJ 15,SYMFNC+691 JRST L2813 L2808: MOVE 1,0(15) PUSHJ 15,SYMFNC+677 JRST L2813 L2807: MOVE 1,0(15) PUSHJ 15,SYMFNC+683 JRST L2813 L2809: MOVE 1,0(15) PUSHJ 15,SYMFNC+685 JRST L2813 L2801: MOVE 4,2 MOVE 3,L2795 MOVE 2,0(15) HRRZI 1,20 PUSHJ 15,L2553 L2813: MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L2784: point 6,2,5 L2787: point 30,6,35 L2788: 536870912 L2789: -536870912 L2795: <30_30>+468 L2794: <30_30>+669 L2793: <30_30>+665 L2792: <30_30>+675 L2791: <30_30>+660 L2790: <30_30>+672 L2786: <30_30>+671 L2785: <30_30>+666 1 ; (!*ENTRY PRIN2 EXPR 1) PRIN2: intern PRIN2 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+356 2 ; (!*ENTRY CHANNELPRIN1 EXPR 2) L2814: intern L2814 SETZM 3 JRST SYMFNC+682 3 ; (!*ENTRY RECURSIVECHANNELPRIN1 EXPR 3) L2827: intern L2827 PUSH 15,2 PUSH 15,1 LDB 1,L2815 CAIL 1,0 CAILE 1,10 JRST L2828 JRST @L2829-0(1) L2829: IFIW L2830 IFIW L2831 IFIW L2832 IFIW L2833 IFIW L2834 IFIW L2835 IFIW L2836 IFIW L2837 IFIW L2838 IFIW L2839 IFIW L2840 L2828: CAIN 1,15 JRST L2841 CAIN 1,29 JRST L2842 CAIN 1,30 JRST L2843 CAIE 1,63 JRST L2832 L2830: MOVE 4,2 MOVE 3,L2816 MOVE 2,0(15) HRRZI 1,10 PUSHJ 15,L2553 JRST L2844 L2843: MOVE 4,2 MOVE 3,L2817 MOVE 2,0(15) MOVE 1,4 TLZ 1,258048 MOVE 5,SYMNAM(1) TLZ 5,258048 MOVE 6,0(5) LDB 1,L2818 TDNE 1,L2819 TDO 1,L2820 ADDI 1,5 PUSHJ 15,L2553 JRST L2844 L2842: MOVE 4,2 MOVE 3,L2821 MOVE 2,0(15) MOVE 1,4 TLZ 1,258048 MOVE 5,SYMNAM(1) TLZ 5,258048 MOVE 6,0(5) LDB 1,L2818 TDNE 1,L2819 TDO 1,L2820 ADDI 1,16 PUSHJ 15,L2553 JRST L2844 L2834: MOVE 4,2 MOVE 3,L2822 MOVE 2,0(15) MOVE 5,4 TLZ 5,258048 MOVE 6,0(5) LDB 1,L2818 TDNE 1,L2819 TDO 1,L2820 ADDI 1,4 PUSHJ 15,L2553 JRST L2844 L2841: MOVE 4,2 MOVE 3,L2823 MOVE 2,0(15) HRRZI 1,14 PUSHJ 15,L2553 JRST L2844 L2831: MOVE 4,2 MOVE 3,L2824 MOVE 2,0(15) HRRZI 1,20 PUSHJ 15,L2553 JRST L2844 L2833: MOVE 4,2 MOVE 3,L2825 MOVE 2,0(15) HRRZI 1,20 PUSHJ 15,L2553 JRST L2844 L2837: MOVE 1,0(15) PUSHJ 15,SYMFNC+689 JRST L2844 L2836: MOVE 1,0(15) PUSHJ 15,SYMFNC+690 JRST L2844 L2835: MOVE 1,0(15) PUSHJ 15,SYMFNC+691 JRST L2844 L2839: MOVE 1,0(15) PUSHJ 15,SYMFNC+681 JRST L2844 L2838: MOVE 1,0(15) PUSHJ 15,SYMFNC+684 JRST L2844 L2840: MOVE 1,0(15) PUSHJ 15,SYMFNC+688 JRST L2844 L2832: MOVE 4,2 MOVE 3,L2826 MOVE 2,0(15) HRRZI 1,20 PUSHJ 15,L2553 L2844: MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L2815: point 6,2,5 L2818: point 30,6,35 L2819: 536870912 L2820: -536870912 L2826: <30_30>+468 L2825: <30_30>+669 L2824: <30_30>+665 L2823: <30_30>+675 L2822: <30_30>+670 L2821: <30_30>+674 L2817: <30_30>+673 L2816: <30_30>+666 1 ; (!*ENTRY PRIN1 EXPR 1) PRIN1: intern PRIN1 MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+308 L2847: 19 byte(7)67,111,117,108,100,110,39,116,32,112,114,105,110,116,32,102,108,111,97,116,0 2 ; (!*ENTRY WRITEFLOAT EXPR 2) L2848: intern L2848 MOVE 6,1 AOS 1 HRLI 1,147904 MOVE 7,1 MOVE 3,1(2) MOVE 2,0(2) MOVE 4,L2845 DFOUT JRST L2849 SETOM 4 L2850: CAMN 1,7 JRST L2851 IBP 7 AOJA 4,L2850 L2851: MOVEM 4,0(6) SETZM 2 IDPB 4,1 POPJ 15,0 L2849: MOVE 1,L2846 JRST SYMFNC+507 L2845: 2686452736 L2846: <4_30>+<1_18>+L2847 15 ; (!*ENTRY PRINTF EXPR 15) PRINTF: intern PRINTF JSP 10,SYMFNC+443 byte(18)1,693 MOVE 1,SYMVAL+693 PUSHJ 15,L2852 JSP 10,SYMFNC+447 1 POPJ 15,0 ; (!*ENTRY PRINTF1 EXPR 15) L2852: intern L2852 PUSH 15,2 XMOVEI 1,0(15) PUSH 15,3 PUSH 15,4 PUSH 15,5 PUSH 15,L0002+0 PUSH 15,L0002+1 PUSH 15,L0002+2 PUSH 15,L0002+3 PUSH 15,L0002+4 PUSH 15,L0002+5 PUSH 15,L0002+6 PUSH 15,L0002+7 PUSH 15,L0002+8 PUSH 15,L0002+9 PUSHJ 15,L2853 ADJSP 15,-14 POPJ 15,0 L2858: 36 byte(7)85,110,107,110,111,119,110,32,99,104,97,114,97,99,116,101,114,32,99,111,100,101,32,102,111,114,32,80,114,105,110,116,70,58,32,37,114,0 ; (!*ENTRY PRINTF2 EXPR 1) L2853: intern L2853 ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 3,SYMVAL+693 TLZ 3,258048 MOVE 6,0(3) LDB 2,L2854 TDNE 2,L2855 TDO 2,L2856 MOVEM 2,-1(15) SETZM -2(15) L2859: MOVE 6,-2(15) CAMLE 6,-1(15) JRST L2860 MOVE 2,-2(15) MOVE 1,SYMVAL+693 TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) CAIN 1,37 JRST L2861 PUSHJ 15,SYMFNC+467 JRST L2862 L2861: AOS -2(15) MOVE 2,-2(15) MOVE 1,SYMVAL+693 TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-3(15) CAIGE 1,97 JRST L2863 CAILE 1,122 JRST L2863 SUBI 1,32 L2863: MOVEM 1,-4(15) CAIN 1,37 JRST L2864 CAIL 1,66 CAILE 1,70 JRST L2865 JRST @L2866-66(1) L2866: IFIW L2867 IFIW L2868 IFIW L2869 IFIW L2870 IFIW L2871 L2865: CAIL 1,76 CAILE 1,88 JRST L2872 JRST @L2873-76(1) L2873: IFIW L2874 IFIW L2875 IFIW L2876 IFIW L2877 IFIW L2878 IFIW L2875 IFIW L2879 IFIW L2880 IFIW L2881 IFIW L2875 IFIW L2875 IFIW L2882 IFIW L2883 L2872: JRST L2875 L2867: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+360 AOS 0(15) JRST L2862 L2868: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+467 AOS 0(15) JRST L2862 L2869: HRRZI 2,10 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+664 AOS 0(15) JRST L2862 L2870: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 AOS 0(15) JRST L2862 L2871: PUSHJ 15,SYMFNC+623 JUMPLE 1,L2862 HRRZI 1,10 PUSHJ 15,SYMFNC+467 JRST L2862 L2874: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+694 AOS 0(15) JRST L2862 L2876: HRRZI 1,10 PUSHJ 15,SYMFNC+467 JRST L2862 L2877: HRRZI 2,8 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+664 AOS 0(15) JRST L2862 L2883: HRRZI 2,16 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+664 AOS 0(15) JRST L2862 L2878: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+470 AOS 0(15) JRST L2862 L2879: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+695 AOS 0(15) JRST L2862 L2880: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+661 AOS 0(15) JRST L2862 L2881: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+363 AOS 0(15) JRST L2862 L2882: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+692 AOS 0(15) JRST L2862 L2864: HRRZI 1,37 PUSHJ 15,SYMFNC+467 JRST L2862 L2875: MOVE 2,-3(15) HRLI 2,122880 MOVE 1,L2857 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 L2862: AOS -2(15) JRST L2859 L2860: MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2854: point 30,6,35 L2855: 536870912 L2856: -536870912 L2857: <4_30>+<1_18>+L2858 5 ; (!*ENTRY ERRORPRINTF EXPR 5) L2884: intern L2884 ADJSP 15,6 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVEM 5,-4(15) MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+477 MOVEM 1,-5(15) MOVE 3,SYMVAL+476 SKIPG L2257(3) JRST L2885 PUSHJ 15,SYMFNC+444 L2885: MOVE 5,-4(15) MOVE 4,-3(15) MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+461 MOVE 2,SYMVAL+476 SKIPG L2257(2) JRST L2886 PUSHJ 15,SYMFNC+444 L2886: MOVE 1,-5(15) PUSHJ 15,SYMFNC+477 MOVE 1,0 ADJSP 15,-6 POPJ 15,0 L2889: 48 byte(7)66,117,102,102,101,114,32,111,118,101,114,102,108,111,119,32,119,104,105,108,101,32,99,111,110,115,116,114,117,99,116,105,110,103,32,101,114,114,111,114,32,109,101,115,115,97,103,101,58,0 L2890: 24 byte(7)84,104,101,32,116,114,117,110,99,97,116,101,100,32,114,101,115,117,108,116,32,119,97,115,58,0 2 ; (!*ENTRY TOSTRINGWRITECHAR EXPR 2) L2891: intern L2891 MOVE 7,L2110 CAIGE 7,4999 JRST L2892 HRRZI 6,80 MOVEM 6,L2110 SETZM 3 HRRZI 2,80 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 XMOVEI 1,L2110 TLZ 1,258048 TLO 1,16384 PUSHJ 15,SYMFNC+395 MOVE 4,1 MOVE 3,L2887 MOVE 2,SYMVAL+693 MOVE 1,L2888 PUSHJ 15,SYMFNC+250 JRST SYMFNC+156 L2892: AOS L2110 MOVE 3,2 MOVE 2,L2110 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 POPJ 15,0 L2888: <4_30>+<1_18>+L2889 L2887: <4_30>+<1_18>+L2890 5 ; (!*ENTRY BLDMSG EXPR 5) BLDMSG: intern BLDMSG ADJSP 15,6 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVEM 5,-4(15) SETZM 2+L2257 SETOM L2110 MOVE 6,SYMVAL+311 MOVEM 6,-5(15) HRRZI 6,2 MOVEM 6,SYMVAL+311 PUSHJ 15,SYMFNC+461 SETZM 3 MOVE 2,L2110 AOS 2 XMOVEI 1,1+L2110 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 6,-5(15) MOVEM 6,SYMVAL+311 XMOVEI 1,L2110 ADJSP 15,-6 JRST SYMFNC+395 1 ; (!*ENTRY ERRPRIN EXPR 1) L2893: intern L2893 PUSH 15,1 HRRZI 1,96 PUSHJ 15,SYMFNC+467 MOVE 1,0(15) PUSHJ 15,SYMFNC+470 HRRZI 1,39 ADJSP 15,-1 JRST SYMFNC+467 1 ; (!*ENTRY PRIN2L EXPR 1) PRIN2L: intern PRIN2L PUSH 15,1 CAMN 1,0 JRST L2895 LDB 11,L2894 CAIN 11,9 JRST L2896 ADJSP 15,-1 JRST SYMFNC+692 L2896: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+692 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) LDB 11,L2894 CAIN 11,9 JRST L2897 MOVE 1,0 JRST L2898 L2897: MOVE 1,SYMVAL+84 L2898: CAME 1,0 JRST L2899 MOVE 1,0 JRST L2900 L2899: MOVE 1,SYMVAL+311 PUSHJ 15,SYMFNC+676 JRST L2896 L2900: CAMN 0,0(15) JRST L2895 MOVE 1,SYMVAL+311 PUSHJ 15,SYMFNC+676 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+692 L2895: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L2894: point 6,1,5 15 ; (!*ENTRY CHANNELPRINTF EXPR 15) L2901: intern L2901 ADJSP 15,13 MOVEM 2,0(15) MOVEM 3,-1(15) MOVEM 4,-2(15) MOVEM 5,-3(15) XMOVEI 6,L0002+0 MOVEM 6,-4(15) XMOVEI 6,L0002+1 MOVEM 6,-5(15) XMOVEI 6,L0002+2 MOVEM 6,-6(15) XMOVEI 6,L0002+3 MOVEM 6,-7(15) XMOVEI 6,L0002+4 MOVEM 6,-8(15) XMOVEI 6,L0002+5 MOVEM 6,-9(15) XMOVEI 6,L0002+6 MOVEM 6,-10(15) XMOVEI 6,L0002+7 MOVEM 6,-11(15) XMOVEI 6,L0002+8 MOVEM 6,-12(15) JSP 10,SYMFNC+443 byte(18)1,311 XMOVEI 6,L0002+9 MOVEM 6,L0002+8 MOVE 6,-12(15) MOVEM 6,L0002+7 MOVE 6,-11(15) MOVEM 6,L0002+6 MOVE 6,-10(15) MOVEM 6,L0002+5 MOVE 6,-9(15) MOVEM 6,L0002+4 MOVE 6,-8(15) MOVEM 6,L0002+3 MOVE 6,-7(15) MOVEM 6,L0002+2 MOVE 6,-6(15) MOVEM 6,L0002+1 MOVE 6,-5(15) MOVEM 6,L0002+0 MOVE 5,-4(15) MOVE 4,-3(15) MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+461 JSP 10,SYMFNC+447 1 ADJSP 15,-13 POPJ 15,0 2 ; (!*ENTRY EXPLODEWRITECHAR EXPR 2) L2902: intern L2902 MOVE 1,2 HRLI 1,122880 PUSHJ 15,SYMFNC+172 MOVE 7,SYMVAL+697 MOVEM 1,1(7) MOVEM 1,SYMVAL+697 POPJ 15,0 1 ; (!*ENTRY EXPLODE EXPR 1) L2903: intern L2903 ADJSP 15,2 MOVEM 1,0(15) MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,SYMVAL+697 MOVEM 2,-1(15) SETZM 3+L2257 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,SYMFNC+308 MOVE 1,-1(15) MOVE 1,1(1) ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY EXPLODE2 EXPR 1) L2904: intern L2904 ADJSP 15,2 MOVEM 1,0(15) MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,SYMVAL+697 MOVEM 2,-1(15) SETZM 3+L2257 MOVE 2,0(15) HRRZI 1,3 PUSHJ 15,SYMFNC+356 MOVE 1,-1(15) MOVE 1,1(1) ADJSP 15,-2 POPJ 15,0 extern L2905 2 ; (!*ENTRY FLATSIZEWRITECHAR EXPR 2) L2906: intern L2906 AOS L2905 MOVE 1,L2905 POPJ 15,0 1 ; (!*ENTRY FLATSIZE EXPR 1) L2907: intern L2907 SETZM L2905 SETZM 4+L2257 MOVE 2,1 HRRZI 1,4 PUSHJ 15,SYMFNC+308 MOVE 1,L2905 POPJ 15,0 1 ; (!*ENTRY FLATSIZE2 EXPR 1) L2908: intern L2908 SETZM L2905 SETZM 4+L2257 MOVE 2,1 HRRZI 1,4 PUSHJ 15,SYMFNC+356 MOVE 1,L2905 POPJ 15,0 extern L2909 1 ; (!*ENTRY COMPRESSREADCHAR EXPR 1) L2911: intern L2911 MOVE 5,1 MOVE 4,0 CAMN 0,L2909 JRST L2912 JRST SYMFNC+701 L2912: LDB 11,L2910 CAIN 11,9 JRST L2913 MOVE 6,SYMVAL+84 MOVEM 6,L2909 HRRZI 1,32 POPJ 15,0 L2913: MOVE 2,SYMVAL+702 MOVE 2,0(2) MOVE 4,2 MOVE 3,SYMVAL+702 MOVE 3,1(3) MOVEM 3,SYMVAL+702 MOVE 1,2 JRST SYMFNC+135 L2910: point 6,<SYMVAL+702>,5 0 ; (!*ENTRY CLEARCOMPRESSCHANNEL EXPR 0) L2914: intern L2914 SETZM 3+L2256 MOVE 1,0 MOVEM 1,L2909 POPJ 15,0 L2916: 37 byte(7)80,111,111,114,108,121,32,102,111,114,109,101,100,32,83,45,101,120,112,114,101,115,115,105,111,110,32,105,110,32,67,79,77,80,82,69,83,83,0 0 ; (!*ENTRY COMPRESSERROR EXPR 0) L2917: intern L2917 MOVE 1,L2915 JRST SYMFNC+156 L2915: <4_30>+<1_18>+L2916 1 ; (!*ENTRY COMPRESS EXPR 1) L2918: intern L2918 JSP 10,SYMFNC+443 byte(18)1,702 JSP 10,SYMFNC+443 byte(18)0,647 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+647 PUSHJ 15,SYMFNC+703 HRRZI 1,3 PUSHJ 15,SYMFNC+636 JSP 10,SYMFNC+447 1 JSP 10,SYMFNC+447 1 POPJ 15,0 1 ; (!*ENTRY IMPLODE EXPR 1) L2919: intern L2919 JSP 10,SYMFNC+443 byte(18)1,702 PUSHJ 15,SYMFNC+703 HRRZI 1,3 PUSHJ 15,SYMFNC+636 JSP 10,SYMFNC+447 1 POPJ 15,0 1 ; (!*ENTRY CHANNELTYI EXPR 1) L2920: intern L2920 JRST SYMFNC+598 2 ; (!*ENTRY CHANNELTYO EXPR 2) L2921: intern L2921 PUSH 15,1 MOVE 1,2 PUSHJ 15,SYMFNC+135 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+359 0 ; (!*ENTRY TYI EXPR 0) TYI: intern TYI MOVE 1,SYMVAL+600 JRST SYMFNC+706 1 ; (!*ENTRY TYO EXPR 1) TYO: intern TYO MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+707 end |
Added psl-1983/3-1/kernel/20/io.rel version [7696d45e6a].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/macro.ctl version [483f29a031].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. @def dsk: dsk:,p20:,pk: @S:DEC20-CROSS.EXE *!*symwrite := T; *!*symsave := nil; *ASMOut "macro"; *PathIn "macro.build"; *ASMEnd; *quit; @reset . @S:DEC20-CROSS.EXE *!*symread := T; *readsymfile(); *!*symread := nil; *writesavefile(); *quit; @compile macro.mac, dmacro.mac |
Added psl-1983/3-1/kernel/20/macro.init version [86d5c6a27d].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (PUT (QUOTE COMMENTOUTCODE) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (COMMENTOUTCODE COMPILETIME)) (QUOTE IGNORE)) (FLAG (QUOTE (BOTHTIMES)) (QUOTE EVAL)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE IGNORE)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE EVAL)) (PUT (QUOTE CONTERROR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CASE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE SETF) (QUOTE TYPE) (QUOTE MACRO)) (DEFLIST (QUOTE ((GETV PUTV) (CAR RPLACA) (CDR RPLACD) (INDX SETINDX) (SUB SETSUB) (NTH (LAMBDA (L I X) (RPLACA (PNTH L I) X) X)) (EVAL SET) (VALUE SET))) (QUOTE ASSIGN!-OP)) (PUT (QUOTE ON) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE OFF) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (ON OFF)) (QUOTE IGNORE)) (PUT (QUOTE DS) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DEFCONST) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (DEFCONST)) (QUOTE EVAL)) (PUT (QUOTE CONST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (STRINGGENSYM!*))) (SETQ STRINGGENSYM!* (COPYSTRING "L0000")) (PUT (QUOTE FOREACH) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE EXIT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE NEXT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE WHILE) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE REPEAT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE FOR) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/3-1/kernel/20/macro.log version [49b4eee837].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/macro.mac version [62b09637a5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 1 ; (!*ENTRY COMMENTOUTCODE MACRO 1) L2922: intern L2922 MOVE 1,0 POPJ 15,0 1 ; (!*ENTRY COMPILETIME EXPR 1) L2923: intern L2923 POPJ 15,0 1 ; (!*ENTRY BOTHTIMES EXPR 1) L2924: intern L2924 POPJ 15,0 1 ; (!*ENTRY LOADTIME EXPR 1) L2925: intern L2925 POPJ 15,0 1 ; (!*ENTRY CONTERROR MACRO 1) L2932: intern L2932 ADJSP 15,9 MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 1,1(1) MOVE 2,0(1) MOVEM 2,-1(15) MOVE 1,1(1) MOVEM 1,0(15) MOVE 7,1(1) CAME 0,1(7) JRST L2933 MOVE 3,0(1) MOVEM 3,-2(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L2934 L2933: MOVE 7,0(15) CAMN 0,1(7) JRST L2935 MOVE 2,0(15) MOVE 2,0(2) MOVE 1,-2(15) PUSHJ 15,SYMFNC+351 MOVEM 1,-2(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) JRST L2933 L2935: MOVE 2,-2(15) MOVE 1,L2926 PUSHJ 15,SYMFNC+151 MOVEM 1,-2(15) L2934: MOVE 1,0(15) MOVE 1,0(1) MOVEM 1,-3(15) LDB 11,L2927 CAIN 11,9 JRST L2936 MOVE 2,1 MOVE 1,L2928 PUSHJ 15,SYMFNC+249 JRST L2937 L2936: MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-4(15) MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) MOVE 2,-3(15) MOVE 2,1(2) MOVEM 2,-5(15) LDB 11,L2929 CAIN 11,9 JRST L2938 MOVE 1,0 JRST L2939 L2938: MOVE 1,0(2) MOVEM 1,-8(15) MOVE 2,1 MOVE 1,L2928 PUSHJ 15,SYMFNC+249 PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-7(15) MOVEM 3,-6(15) L2940: MOVE 1,-5(15) MOVE 1,1(1) MOVEM 1,-5(15) LDB 11,L2927 CAIN 11,9 JRST L2941 MOVE 1,-6(15) JRST L2939 L2941: MOVE 1,0(1) MOVEM 1,-8(15) MOVE 2,1 MOVE 1,L2928 PUSHJ 15,SYMFNC+249 PUSHJ 15,SYMFNC+172 MOVE 7,-7(15) MOVEM 1,1(7) MOVE 2,-7(15) MOVE 2,1(2) MOVEM 2,-7(15) JRST L2940 L2939: MOVE 2,-4(15) PUSHJ 15,SYMFNC+278 MOVE 2,L2930 PUSHJ 15,SYMFNC+278 L2937: MOVEM 1,-3(15) MOVE 4,1 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,L2931 ADJSP 15,-9 JRST SYMFNC+250 L2927: point 6,1,5 L2929: point 6,2,5 L2931: <30_30>+236 L2930: <30_30>+244 L2928: <30_30>+234 L2926: <30_30>+155 L2945: <30_30>+716 <9_30>+<1_18>+L2946 L2946: <30_30>+717 <30_30>+128 1 ; (!*ENTRY CASE FEXPR 1) CASE: intern CASE ADJSP 15,5 MOVEM 1,0(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVEM 1,-1(15) L2947: MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) LDB 11,L2942 CAIN 11,9 JRST L2948 MOVE 1,-2(15) ADJSP 15,-5 JRST SYMFNC+261 L2948: MOVE 2,0(1) MOVE 2,0(2) MOVEM 2,-3(15) MOVE 3,0(1) MOVE 3,1(3) MOVE 3,0(3) MOVEM 3,-4(15) LDB 11,L2943 CAIE 11,9 JRST L2949 MOVE 2,L2944 MOVE 1,-3(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L2950 L2949: MOVE 6,-4(15) MOVEM 6,-2(15) JRST L2947 L2950: MOVE 2,-3(15) MOVE 1,-1(15) PUSHJ 15,L2951 CAMN 1,0 JRST L2947 MOVE 1,-4(15) ADJSP 15,-5 JRST SYMFNC+261 L2942: point 6,1,5 L2943: point 6,2,5 L2944: <9_30>+<1_18>+L2945 ; (!*ENTRY INTHISCASE EXPR 2) L2951: intern L2951 ADJSP 15,2 L2955: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L2952 CAIN 11,9 JRST L2956 MOVE 1,0 JRST L2957 L2956: LDB 11,L2953 CAIE 11,9 JRST L2958 MOVE 7,0(2) MOVE 6,L2954 CAME 6,0(7) JRST L2958 MOVE 2,0(2) MOVE 2,1(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+282 CAME 1,0 JRST L2958 MOVE 1,-1(15) PUSHJ 15,SYMFNC+208 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+237 CAME 1,0 JRST L2958 MOVE 1,SYMVAL+84 JRST L2957 L2958: MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L2959 MOVE 1,SYMVAL+84 JRST L2957 L2959: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L2955 L2957: ADJSP 15,-2 POPJ 15,0 L2952: point 6,2,5 L2953: point 6,0(2),5 L2954: <30_30>+719 1 ; (!*ENTRY SETF MACRO 1) SETF: intern SETF MOVE 2,1(1) MOVE 2,1(2) MOVE 2,0(2) MOVE 1,1(1) MOVE 1,0(1) JRST SYMFNC+721 L2967: 36 byte(7)37,114,32,105,115,32,110,111,116,32,97,32,107,110,111,119,110,32,102,111,114,109,32,102,111,114,32,97,115,115,105,103,110,109,101,110,116,0 2 ; (!*ENTRY EXPANDSETF EXPR 2) L2968: intern L2968 ADJSP 15,3 L2969: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) LDB 11,L2960 CAIN 11,9 JRST L2970 MOVE 3,2 MOVE 2,1 MOVE 1,L2961 ADJSP 15,-3 JRST SYMFNC+235 L2970: MOVE 2,L2962 MOVE 1,0(1) PUSHJ 15,SYMFNC+522 MOVE 3,1 MOVEM 3,-2(15) CAMN 3,0 JRST L2971 MOVE 1,-1(15) PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+177 MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L2971: MOVE 2,L2963 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+522 MOVE 2,1 MOVEM 2,-2(15) CAMN 2,0 JRST L2972 MOVE 3,2 MOVE 2,-1(15) MOVE 1,0(15) MOVE 6,3 ADJSP 15,-3 JRST SYMFNC+288 L2972: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+318 MOVE 3,1 MOVEM 3,-2(15) CAMN 3,0 JRST L2973 MOVE 6,L2964 CAME 6,0(3) JRST L2973 MOVE 2,1(3) MOVE 1,0(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVE 2,-1(15) JRST L2969 L2973: MOVE 3,-1(15) MOVE 2,0(15) MOVE 1,L2965 PUSHJ 15,SYMFNC+235 MOVE 2,1 MOVE 1,L2966 PUSHJ 15,SYMFNC+155 ADJSP 15,-3 JRST SYMFNC+156 L2960: point 6,1,5 L2966: <4_30>+<1_18>+L2967 L2965: <30_30>+720 L2964: <30_30>+256 L2963: <30_30>+722 L2962: <30_30>+723 L2961: <30_30>+260 2 ; (!*ENTRY ONOFF!* EXPR 2) L2979: intern L2979 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 1,-3(15) L2980: LDB 11,L2974 CAIE 11,9 JRST L2981 MOVE 1,-3(15) MOVE 1,0(1) MOVEM 1,-4(15) LDB 11,L2975 CAIN 11,30 JRST L2982 CAME 0,-1(15) JRST L2983 MOVE 1,L2976 JRST L2984 L2983: MOVE 1,L2977 L2984: MOVE 2,1 MOVE 1,-4(15) PUSHJ 15,SYMFNC+130 JRST L2985 L2982: PUSHJ 15,SYMFNC+725 MOVE 2,-1(15) PUSHJ 15,SYMFNC+262 MOVE 2,L2978 MOVE 1,-4(15) PUSHJ 15,SYMFNC+522 MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+335 MOVEM 1,-2(15) CAMN 1,0 JRST L2985 MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 L2985: MOVE 1,-3(15) MOVE 1,1(1) MOVEM 1,-3(15) JRST L2980 L2981: MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L2974: point 6,-3(15),5 L2975: point 6,1,5 L2978: <30_30>+726 L2977: <30_30>+727 L2976: <30_30>+728 L2987: 0 byte(7)42,0 1 ; (!*ENTRY MKFLAGVAR EXPR 1) L2988: intern L2988 PUSHJ 15,SYMFNC+140 MOVE 2,1 MOVE 1,L2986 PUSHJ 15,SYMFNC+176 JRST SYMFNC+560 L2986: <4_30>+<1_18>+L2987 1 ; (!*ENTRY ON MACRO 1) ON: intern ON MOVE 1,1(1) PUSHJ 15,SYMFNC+234 MOVE 3,SYMVAL+84 MOVE 2,1 MOVE 1,L2989 JRST SYMFNC+235 L2989: <30_30>+724 1 ; (!*ENTRY OFF MACRO 1) OFF: intern OFF MOVE 1,1(1) PUSHJ 15,SYMFNC+234 MOVE 3,0 MOVE 2,1 MOVE 1,L2990 JRST SYMFNC+235 L2990: <30_30>+724 ; (!*ENTRY INSTANTIATEINFORM EXPR 2) L2994: intern L2994 ADJSP 15,6 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L2991 CAIN 11,9 JRST L2995 MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L2996 MOVE 1,-1(15) JRST L2997 L2996: MOVE 1,-1(15) ADJSP 15,-6 JRST SYMFNC+234 L2995: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 2,-2(15) LDB 11,L2991 CAIN 11,9 JRST L2998 MOVE 1,0 JRST L2999 L2998: MOVE 1,0(2) MOVEM 1,-5(15) MOVE 2,1 MOVE 1,0(15) PUSHJ 15,L2994 PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-4(15) MOVEM 3,-3(15) L3000: MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) LDB 11,L2992 CAIN 11,9 JRST L3001 MOVE 1,-3(15) JRST L2999 L3001: MOVE 1,0(1) MOVEM 1,-5(15) MOVE 2,1 MOVE 1,0(15) PUSHJ 15,L2994 PUSHJ 15,SYMFNC+172 MOVE 7,-4(15) MOVEM 1,1(7) MOVE 2,-4(15) MOVE 2,1(2) MOVEM 2,-4(15) JRST L3000 L2999: MOVE 2,L2993 ADJSP 15,-6 JRST SYMFNC+278 L2997: ADJSP 15,-6 POPJ 15,0 L2991: point 6,2,5 L2992: point 6,1,5 L2993: <30_30>+244 L3004: <30_30>+187 <9_30>+<1_18>+L3005 L3005: <30_30>+729 <30_30>+128 ; (!*ENTRY SETMACROREFERENCE EXPR 1) L3006: intern L3006 MOVE 3,L3002 MOVE 2,1 MOVE 1,L3003 JRST SYMFNC+235 L3003: <30_30>+260 L3002: <9_30>+<1_18>+L3004 1 ; (!*ENTRY DS MACRO 1) DS: intern DS MOVE 3,1(1) MOVE 3,1(3) MOVE 3,1(3) MOVE 2,1(1) MOVE 2,1(2) MOVE 2,0(2) MOVE 1,1(1) MOVE 1,0(1) JRST MAKEDS L3017: <30_30>+729 <30_30>+128 L3018: <30_30>+246 <9_30>+<1_18>+L3021 L3019: <30_30>+270 <9_30>+<1_18>+L3022 L3020: <30_30>+260 <9_30>+<1_18>+L3023 L3021: <30_30>+264 <30_30>+128 L3022: <9_30>+<1_18>+L3024 <30_30>+128 L3023: <30_30>+729 <9_30>+<1_18>+L3025 L3024: <9_30>+<1_18>+L3026 <9_30>+<1_18>+L3027 L3025: <9_30>+<1_18>+L3028 <30_30>+128 L3026: <30_30>+184 <9_30>+<1_18>+L3029 L3027: <9_30>+<1_18>+L3030 <30_30>+128 L3028: <30_30>+228 <9_30>+<1_18>+L3017 L3029: <9_30>+<1_18>+L3031 <30_30>+128 L3030: <30_30>+156 <9_30>+<1_18>+L3032 L3031: <30_30>+188 <9_30>+<1_18>+L3017 L3032: <4_30>+<1_18>+L3033 <30_30>+128 L3033: 36 byte(7)65,114,103,117,109,101,110,116,32,109,105,115,109,97,116,99,104,32,105,110,32,83,77,97,99,114,111,32,101,120,112,97,110,115,105,111,110,0 ; (!*ENTRY MAKEDS EXPR 3) MAKEDS: intern MAKEDS ADJSP 15,9 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-4(15) MOVE 1,L3007 PUSHJ 15,SYMFNC+172 MOVE 2,-1(15) PUSHJ 15,SYMFNC+278 MOVEM 1,-3(15) MOVE 6,-1(15) MOVEM 6,-5(15) L3034: LDB 11,L3008 CAIE 11,9 JRST L3035 MOVE 1,-5(15) MOVE 1,0(1) MOVEM 1,-6(15) MOVE 2,-3(15) MOVE 1,L3009 PUSHJ 15,SYMFNC+151 MOVEM 1,-3(15) MOVE 1,-6(15) PUSHJ 15,L3006 MOVE 2,-3(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-3(15) MOVE 2,-5(15) MOVE 2,1(2) MOVEM 2,-5(15) JRST L3034 L3035: MOVE 2,-3(15) MOVE 1,L3010 PUSHJ 15,SYMFNC+151 MOVEM 1,-3(15) MOVE 7,-2(15) CAME 0,1(7) JRST L3036 MOVE 2,-2(15) MOVE 2,0(2) MOVE 1,-1(15) PUSHJ 15,L2994 JRST L3037 L3036: MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) MOVE 6,-2(15) MOVEM 6,-5(15) LDB 11,L3008 CAIN 11,9 JRST L3038 MOVE 1,0 JRST L3039 L3038: MOVE 1,-5(15) MOVE 1,0(1) MOVEM 1,-8(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,L2994 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVEM 2,-7(15) MOVEM 2,-6(15) L3040: MOVE 1,-5(15) MOVE 1,1(1) MOVEM 1,-5(15) LDB 11,L3011 CAIN 11,9 JRST L3041 MOVE 1,-6(15) JRST L3039 L3041: MOVE 1,0(1) MOVEM 1,-8(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,L2994 PUSHJ 15,SYMFNC+172 MOVE 7,-7(15) MOVEM 1,1(7) MOVE 2,-7(15) MOVE 2,1(2) MOVEM 2,-7(15) JRST L3040 L3039: MOVE 2,L3012 PUSHJ 15,SYMFNC+278 MOVE 2,L3013 PUSHJ 15,SYMFNC+278 L3037: MOVE 2,1 MOVE 1,L3014 PUSHJ 15,SYMFNC+249 MOVE 2,-3(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-3(15) PUSHJ 15,SYMFNC+329 PUSHJ 15,SYMFNC+172 MOVE 2,L3015 PUSHJ 15,SYMFNC+278 MOVE 2,0(15) PUSHJ 15,SYMFNC+278 MOVE 2,L3016 ADJSP 15,-9 JRST SYMFNC+278 L3008: point 6,-5(15),5 L3011: point 6,1,5 L3016: <30_30>+257 L3015: <9_30>+<1_18>+L3017 L3014: <30_30>+545 L3013: <30_30>+244 L3012: <9_30>+<1_18>+L3018 L3010: <9_30>+<1_18>+L3019 L3009: <9_30>+<1_18>+L3020 L3007: <30_30>+541 1 ; (!*ENTRY DEFCONST MACRO 1) L3044: intern L3044 ADJSP 15,3 MOVEM 1,0(15) MOVE 1,L3042 PUSHJ 15,SYMFNC+172 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) L3045: CAMN 0,0(15) JRST L3046 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-2(15) MOVE 1,0(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-2(15) MOVE 1,L3043 PUSHJ 15,SYMFNC+235 MOVE 2,-1(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVE 2,1(2) MOVEM 2,0(15) JRST L3045 L3046: MOVE 1,-1(15) ADJSP 15,-3 JRST SYMFNC+329 L3043: <30_30>+732 L3042: <30_30>+264 2 ; (!*ENTRY EVDEFCONST EXPR 2) L3048: intern L3048 MOVE 3,2 MOVE 2,L3047 JRST SYMFNC+300 L3047: <30_30>+733 L3051: 20 byte(7)85,110,107,110,111,119,110,32,99,111,110,115,116,32,102,111,114,109,32,37,114,0 1 ; (!*ENTRY CONST MACRO 1) CONST: intern CONST PUSH 15,1 MOVE 2,L3049 MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+522 CAME 1,0 JRST L3052 MOVE 2,0(15) MOVE 1,L3050 PUSHJ 15,SYMFNC+155 ADJSP 15,-1 JRST SYMFNC+156 L3052: ADJSP 15,-1 POPJ 15,0 L3050: <4_30>+<1_18>+L3051 L3049: <30_30>+733 0 ; (!*ENTRY STRINGGENSYM EXPR 0) L3053: intern L3053 HRRZI 1,4 JRST L3054 ; (!*ENTRY STRINGGENSYM1 EXPR 1) L3054: intern L3054 ADJSP 15,2 L3055: MOVEM 1,0(15) MOVEM 0,-1(15) SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3056 MOVE 2,0(15) MOVE 1,SYMVAL+735 PUSHJ 15,SYMFNC+164 HRRZI 2,57 MOVEM 1,-1(15) PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L3057 MOVE 1,-1(15) PUSHJ 15,SYMFNC+241 MOVE 3,1 MOVE 2,0(15) MOVE 1,SYMVAL+735 PUSHJ 15,SYMFNC+167 MOVE 1,SYMVAL+735 ADJSP 15,-2 JRST SYMFNC+401 L3057: HRRZI 3,48 MOVE 2,0(15) MOVE 1,SYMVAL+735 PUSHJ 15,SYMFNC+167 MOVE 1,0(15) PUSHJ 15,SYMFNC+349 JRST L3055 L3056: SETZM 2 MOVE 1,SYMVAL+735 PUSHJ 15,SYMFNC+164 PUSHJ 15,SYMFNC+241 MOVE 3,1 SETZM 2 MOVE 1,SYMVAL+735 PUSHJ 15,SYMFNC+167 ADJSP 15,-2 JRST SYMFNC+734 L3072: 33 byte(7)37,114,32,105,115,32,97,110,32,105,108,108,101,103,97,108,32,97,99,116,105,111,110,32,105,110,32,70,111,114,69,97,99,104,0 1 ; (!*ENTRY FOREACH MACRO 1) L3073: intern L3073 ADJSP 15,7 MOVE 2,1(1) MOVE 2,0(2) MOVEM 2,-6(15) MOVE 1,1(1) MOVE 1,1(1) MOVE 3,0(1) MOVEM 3,-5(15) MOVE 1,1(1) MOVE 4,0(1) MOVEM 4,-4(15) MOVE 1,1(1) MOVEM 1,0(15) MOVE 5,0(1) MOVEM 5,-1(15) MOVE 1,1(1) MOVEM 1,-2(15) CAME 5,L3058 JRST L3074 CAME 3,L3059 JRST L3075 MOVE 1,L3060 JRST L3076 L3075: MOVE 1,L3061 JRST L3076 L3074: CAMN 5,L3062 JRST L3077 CAME 5,L3063 JRST L3078 L3077: CAME 3,L3059 JRST L3079 MOVE 1,L3064 JRST L3076 L3079: MOVE 1,L3065 JRST L3076 L3078: CAME 5,L3066 JRST L3080 CAME 3,L3059 JRST L3081 MOVE 1,L3067 JRST L3076 L3081: MOVE 1,L3068 JRST L3076 L3080: MOVE 2,5 MOVE 1,L3069 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 L3076: MOVEM 1,-3(15) MOVE 1,-6(15) PUSHJ 15,SYMFNC+172 MOVE 2,-2(15) PUSHJ 15,SYMFNC+151 MOVE 2,L3070 PUSHJ 15,SYMFNC+278 MOVE 2,1 MOVE 1,L3071 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,-4(15) MOVE 1,-3(15) ADJSP 15,-7 JRST SYMFNC+235 L3071: <30_30>+252 L3070: <30_30>+253 L3069: <4_30>+<1_18>+L3072 L3068: <30_30>+294 L3067: <30_30>+293 L3066: <30_30>+737 L3065: <30_30>+292 L3064: <30_30>+290 L3063: <30_30>+738 L3062: <30_30>+739 L3061: <30_30>+287 L3060: <30_30>+289 L3059: <30_30>+740 L3058: <30_30>+741 L3085: <30_30>+545 <9_30>+<1_18>+L3086 L3086: <30_30>+128 <30_30>+128 1 ; (!*ENTRY EXIT MACRO 1) EXIT: intern EXIT CAME 0,1(1) JRST L3087 MOVE 1,L3082 POPJ 15,0 L3087: MOVE 7,1(1) CAMN 0,1(7) JRST L3088 MOVE 2,1(1) MOVE 1,L3083 PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,L3084 JRST SYMFNC+249 L3088: MOVE 2,1(1) MOVE 1,L3084 JRST SYMFNC+151 L3084: <30_30>+545 L3083: <30_30>+264 L3082: <9_30>+<1_18>+L3085 L3090: <30_30>+544 <9_30>+<1_18>+L3091 L3091: <30_30>+743 <30_30>+128 1 ; (!*ENTRY NEXT MACRO 1) NEXT: intern NEXT MOVE 1,L3089 POPJ 15,0 L3089: <9_30>+<1_18>+L3090 L3098: <9_30>+<1_18>+L3100 <30_30>+128 L3099: <30_30>+545 <9_30>+<1_18>+L3101 L3100: <30_30>+544 <9_30>+<1_18>+L3102 L3101: <30_30>+128 <30_30>+128 L3102: <30_30>+743 <30_30>+128 1 ; (!*ENTRY WHILE MACRO 1) WHILE: intern WHILE ADJSP 15,2 MOVEM 1,0(15) MOVE 2,1(1) MOVE 2,0(2) MOVE 1,L3092 PUSHJ 15,SYMFNC+249 MOVE 2,L3093 PUSHJ 15,SYMFNC+249 MOVE 2,1 MOVE 1,L3094 PUSHJ 15,SYMFNC+249 MOVEM 1,-1(15) MOVE 2,L3095 MOVE 1,0(15) MOVE 1,1(1) MOVE 1,1(1) PUSHJ 15,SYMFNC+177 MOVE 2,-1(15) PUSHJ 15,SYMFNC+278 MOVE 2,L3096 PUSHJ 15,SYMFNC+278 MOVE 2,0 PUSHJ 15,SYMFNC+278 MOVE 2,L3097 ADJSP 15,-2 JRST SYMFNC+278 L3097: <30_30>+541 L3096: <30_30>+743 L3095: <9_30>+<1_18>+L3098 L3094: <30_30>+270 L3093: <9_30>+<1_18>+L3099 L3092: <30_30>+272 L3110: <30_30>+544 <9_30>+<1_18>+L3111 L3111: <30_30>+743 <30_30>+128 1 ; (!*ENTRY REPEAT MACRO 1) REPEAT: intern REPEAT ADJSP 15,4 MOVEM 1,0(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 2,1(1) MOVEM 2,-1(15) LDB 11,L3103 CAIN 11,9 JRST L3112 MOVE 1,0 JRST L3113 L3112: MOVE 1,2 CAME 0,1(1) JRST L3114 MOVE 2,0(1) MOVE 1,L3104 PUSHJ 15,SYMFNC+249 MOVE 2,L3105 PUSHJ 15,SYMFNC+249 MOVE 2,1 MOVE 1,L3106 PUSHJ 15,SYMFNC+249 JRST L3115 L3114: MOVE 1,0(1) L3115: PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-3(15) MOVEM 3,-2(15) L3116: MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) LDB 11,L3107 CAIN 11,9 JRST L3117 MOVE 1,-2(15) JRST L3113 L3117: CAME 0,1(1) JRST L3118 MOVE 2,0(1) MOVE 1,L3104 PUSHJ 15,SYMFNC+249 MOVE 2,L3105 PUSHJ 15,SYMFNC+249 MOVE 2,1 MOVE 1,L3106 PUSHJ 15,SYMFNC+249 JRST L3119 L3118: MOVE 1,0(1) L3119: PUSHJ 15,SYMFNC+172 MOVE 7,-3(15) MOVEM 1,1(7) MOVE 2,-3(15) MOVE 2,1(2) MOVEM 2,-3(15) JRST L3116 L3113: MOVE 2,L3108 PUSHJ 15,SYMFNC+278 MOVE 2,0 PUSHJ 15,SYMFNC+278 MOVE 2,L3109 ADJSP 15,-4 JRST SYMFNC+278 L3103: point 6,2,5 L3107: point 6,1,5 L3109: <30_30>+541 L3108: <30_30>+743 L3106: <30_30>+270 L3105: <9_30>+<1_18>+L3110 L3104: <30_30>+272 L3135: <9_30>+<1_18>+L3137 <30_30>+128 L3136: <30_30>+545 <9_30>+<1_18>+L3138 L3137: <30_30>+544 <9_30>+<1_18>+L3139 L3138: <30_30>+128 <30_30>+128 L3139: <30_30>+743 <30_30>+128 1 ; (!*ENTRY FOR MACRO 1) FOR: intern FOR ADJSP 15,11 MOVEM 1,0(15) MOVEM 0,-3(15) MOVE 2,1(1) MOVE 2,0(2) MOVE 2,1(2) MOVE 2,0(2) MOVEM 2,-7(15) MOVE 3,1(1) MOVE 3,0(3) MOVE 3,1(3) MOVE 3,1(3) MOVEM 3,-4(15) MOVE 4,1(1) MOVE 4,1(4) MOVE 4,0(4) MOVE 4,0(4) MOVEM 4,-1(15) MOVE 5,1(1) MOVE 5,1(5) MOVE 5,0(5) MOVE 5,1(5) MOVE 5,0(5) MOVEM 5,-2(15) MOVE 3,0(3) MOVE 1,L3120 PUSHJ 15,SYMFNC+235 PUSHJ 15,SYMFNC+172 MOVEM 1,-5(15) MOVE 2,-4(15) MOVE 2,1(2) MOVEM 2,-4(15) MOVE 3,-7(15) MOVE 2,0(2) MOVE 1,L3121 PUSHJ 15,SYMFNC+235 MOVEM 1,-8(15) MOVE 7,-4(15) MOVE 7,1(7) MOVE 7,0(7) CAIN 7,1 JRST L3140 MOVE 3,1 MOVE 2,-4(15) MOVE 2,1(2) MOVE 2,0(2) MOVE 1,L3122 PUSHJ 15,SYMFNC+235 MOVEM 1,-8(15) L3140: MOVE 6,L3123 MOVEM 6,-6(15) MOVE 6,-1(15) CAMN 6,L3124 JRST L3141 MOVE 2,L3125 MOVE 1,-1(15) PUSHJ 15,SYMFNC+522 MOVEM 1,-1(15) PUSHJ 15,SYMFNC+748 MOVEM 1,-3(15) MOVE 2,-2(15) MOVE 1,L3126 PUSHJ 15,SYMFNC+249 MOVE 3,-3(15) MOVE 2,1 MOVE 1,-1(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L3120 PUSHJ 15,SYMFNC+235 MOVEM 1,-2(15) MOVE 1,-1(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L3120 PUSHJ 15,SYMFNC+235 MOVE 2,-5(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-5(15) MOVE 2,-3(15) MOVE 1,L3127 PUSHJ 15,SYMFNC+249 MOVE 2,1 MOVE 1,L3128 PUSHJ 15,SYMFNC+249 MOVEM 1,-6(15) MOVE 1,-3(15) PUSHJ 15,SYMFNC+172 MOVEM 1,-3(15) L3141: MOVE 2,-3(15) MOVE 1,-7(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-9(15) MOVE 2,-8(15) MOVE 1,L3129 PUSHJ 15,SYMFNC+249 MOVE 2,-6(15) PUSHJ 15,SYMFNC+249 MOVE 2,1 MOVE 1,L3130 PUSHJ 15,SYMFNC+249 MOVEM 1,-10(15) MOVE 3,-4(15) MOVE 3,1(3) MOVE 3,0(3) MOVE 2,-7(15) MOVE 1,L3131 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,-7(15) MOVE 1,L3120 PUSHJ 15,SYMFNC+235 MOVE 2,L3132 PUSHJ 15,SYMFNC+151 MOVE 2,-2(15) PUSHJ 15,SYMFNC+278 MOVE 2,-10(15) PUSHJ 15,SYMFNC+278 MOVE 2,L3133 PUSHJ 15,SYMFNC+278 MOVE 2,1 MOVE 1,-5(15) PUSHJ 15,SYMFNC+291 MOVE 2,-9(15) PUSHJ 15,SYMFNC+278 MOVE 2,L3134 ADJSP 15,-11 JRST SYMFNC+278 L3134: <30_30>+541 L3133: <30_30>+743 L3132: <9_30>+<1_18>+L3135 L3131: <30_30>+243 L3130: <30_30>+270 L3129: <30_30>+239 L3128: <30_30>+545 L3127: <30_30>+749 L3126: <30_30>+750 L3125: <30_30>+751 L3124: <30_30>+741 L3123: <9_30>+<1_18>+L3136 L3122: <30_30>+286 L3121: <30_30>+238 L3120: <30_30>+260 end |
Added psl-1983/3-1/kernel/20/macro.rel version [26fd28be85].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/main-start.red version [eedec49f29].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MAIN-START.RED - First routine called on startup % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 September 1981 % Copyright (c) 1981 University of Utah % % 26-May-1983 Mark R. Swanson % Cahnges to support extended addressing % <PSL.KERNEL-20>MAIN-START.RED.4, 5-Oct-82 10:42:14, Edit by BENSON % Added call to EvalInitForms in MAIN!. on SysLisp; internal WConst StackSize = 4000; internal WArray Stack[StackSize]; exported WVar StackLowerBound = &Stack[0] + 8#1000000, StackUpperBound = &Stack[StackSize] + 8#1000000; external WVar ST; internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1; % 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs exported WArray ArgumentBlock[MaxArgBlock]; exported WArray HashTable[MaxObArray/2]; lap '((!*entry Main!. expr 0) Forever (move (reg st) (lit (halfword (minus (WConst StackSize)) (difference (WConst Stack) 1)))) (move (reg nil) (fluid nil)) (!*CALL pre!-main) (jrst Forever) ); syslsp procedure Reset(); Throw('Reset, 'Reset); syslsp procedure pre!-main(); << ClearBindings(); ClearIO(); EvalInitForms(); if Catch('Reset, Main()) = 'Reset then pre!-main() >>; syslsp procedure Main(); %. initialization function % % A new system can be created by redefining this function to call whatever % top loop is desired. % << InitCode(); % special code accumulated in compiler SymFnc[IDLoc Main] := SymFnc[IDLoc StandardLisp]; % don't do it again StandardLisp() >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/main.ctl version [70af8d0536].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. @def dsk: dsk:,p20:,pk: @S:DEC20-CROSS.EXE *!*main:=T; *ASMOut "main"; *PathIn "main.build"; *ASMEnd; *quit; @compile main.mac, dmain.mac |
Added psl-1983/3-1/kernel/20/main.init version [a7ffc6f8bf].
Added psl-1983/3-1/kernel/20/main.log version [b035439503].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/main.mac version [ca674ca794].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 | search monsym,macsym radix 10 extern STACK extern L1254 extern L2081 extern L0002 extern L0003 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: reset% setzm 1 move 2,[.fhslf,,2] move 3,[140000,,3] smap.: smap% move 1,[jfcl] movem 1,smap. L3699: MOVE 15,L3698 MOVE 0,SYMVAL+128 PUSHJ 15,SYMFNC+843 JRST L3699 L3698: byte(18)-4000,STACK-1 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 2,L3700 MOVE 1,L3700 JRST SYMFNC+495 L3700: <30_30>+536 0 ; (!*ENTRY PRE!-MAIN EXPR 0) L3702: intern L3702 ADJSP 15,2 L3703: PUSHJ 15,SYMFNC+781 PUSHJ 15,SYMFNC+794 PUSHJ 15,SYMFNC+838 MOVE 1,L3701 PUSHJ 15,SYMFNC+499 MOVEM 1,0(15) CAME 0,SYMVAL+500 JRST L3704 PUSHJ 15,SYMFNC+844 MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+501 MOVE 1,-1(15) L3704: CAMN 1,L3701 JRST L3703 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L3701: <30_30>+536 0 ; (!*ENTRY MAIN EXPR 0) MAIN: intern MAIN PUSHJ 15,SYMFNC+845 MOVE 6,834+SYMFNC MOVEM 6,844+SYMFNC JRST SYMFNC+834 0 ; (!*ENTRY INITCODE EXPR 0) L3721: intern L3721 MOVE 3,L3705 MOVE 2,L3706 MOVE 1,L3707 PUSHJ 15,SYMFNC+300 MOVE 3,L3705 MOVE 2,L3706 MOVE 1,L3708 PUSHJ 15,SYMFNC+300 MOVE 3,L3709 MOVE 2,L3710 MOVE 1,L3711 PUSHJ 15,SYMFNC+300 MOVE 3,L3712 MOVE 2,L3710 MOVE 1,L3713 PUSHJ 15,SYMFNC+300 MOVE 3,L3714 MOVE 2,L3710 MOVE 1,L3715 PUSHJ 15,SYMFNC+300 MOVE 3,L3716 MOVE 2,L3710 MOVE 1,L3717 PUSHJ 15,SYMFNC+300 MOVE 3,L3718 MOVE 2,L3710 HRRZI 1,26 HRLI 1,122880 PUSHJ 15,SYMFNC+300 PUSHJ 15,SYMFNC+791 HRRZI 3,26 MOVE 2,L3719 MOVE 1,L3720 JRST SYMFNC+300 L3720: <30_30>+846 L3719: <30_30>+847 L3718: <30_30>+641 L3717: <30_30>+91 L3716: <30_30>+646 L3715: <30_30>+41 L3714: <30_30>+645 L3713: <30_30>+40 L3712: <30_30>+644 L3711: <30_30>+39 L3710: <30_30>+638 L3709: <30_30>+643 L3708: <30_30>+246 L3707: <30_30>+264 L3706: <30_30>+759 L3705: <30_30>+254 extern SYMVAL L3722: <30_30>+261 <9_30>+<1_18>+L3723 L3723: <30_30>+518 <9_30>+<1_18>+L3724 L3724: <30_30>+288 <9_30>+<1_18>+L3725 L3725: <30_30>+508 <9_30>+<1_18>+L3726 L3726: <30_30>+509 <9_30>+<1_18>+L3727 L3727: <30_30>+498 <9_30>+<1_18>+L3728 L3728: <30_30>+478 <9_30>+<1_18>+L3729 L3729: <30_30>+265 <9_30>+<1_18>+L3730 L3730: <30_30>+807 <9_30>+<1_18>+L3731 L3731: <30_30>+809 <9_30>+<1_18>+L3732 L3732: <30_30>+510 <9_30>+<1_18>+L3733 L3733: <30_30>+451 <9_30>+<1_18>+L3734 L3734: <30_30>+844 <30_30>+128 intern L3722 L3735: <30_30>+270 <9_30>+<1_18>+L3736 L3736: <30_30>+541 <9_30>+<1_18>+L3737 L3737: <30_30>+266 <9_30>+<1_18>+L3738 L3738: <30_30>+268 <9_30>+<1_18>+L3739 L3739: <30_30>+264 <9_30>+<1_18>+L3740 L3740: <30_30>+260 <30_30>+128 intern L3735 L3741: <30_30>+848 <9_30>+<1_18>+L3742 L3742: <30_30>+849 <9_30>+<1_18>+L3743 L3743: <30_30>+850 <9_30>+<1_18>+L3744 L3744: <30_30>+851 <30_30>+128 intern L3741 L3745: <4_30>+<1_18>+L3746 <9_30>+<1_18>+L3747 L3746: -1 byte(7)0 L3747: <4_30>+<1_18>+L3748 <30_30>+128 L3748: 2 byte(7)112,108,58,0 intern L3745 L3749: <9_30>+<1_18>+L3750 <9_30>+<1_18>+L3751 L3750: <4_30>+<1_18>+L3752 <30_30>+559 L3751: <9_30>+<1_18>+L3753 <30_30>+128 L3752: 1 byte(7)46,98,0 L3753: <4_30>+<1_18>+L3754 <30_30>+841 L3754: 3 byte(7)46,108,97,112,0 intern L3749 L3755: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_30>+852 intern L3755 L3756: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_30>+852 intern L3756 L3757: 21 byte(7)80,111,114,116,97,98,108,101,32,83,116,97,110,100,97,114,100,32,76,73,83,80,0 intern L3757 extern SYMPRP extern SYMNAM L3758: 0 byte(7)0,0 intern L3758 L3759: 0 byte(7)1,0 intern L3759 L3760: 0 byte(7)2,0 intern L3760 L3761: 0 byte(7)3,0 intern L3761 L3762: 0 byte(7)4,0 intern L3762 L3763: 0 byte(7)5,0 intern L3763 L3764: 0 byte(7)6,0 intern L3764 L3765: 0 byte(7)7,0 intern L3765 L3766: 0 byte(7)8,0 intern L3766 L3767: 0 byte(7)9,0 intern L3767 L3768: 0 byte(7)10,0 intern L3768 L3769: 0 byte(7)11,0 intern L3769 L3770: 0 byte(7)12,0 intern L3770 L3771: 0 byte(7)13,0 intern L3771 L3772: 0 byte(7)14,0 intern L3772 L3773: 0 byte(7)15,0 intern L3773 L3774: 0 byte(7)16,0 intern L3774 L3775: 0 byte(7)17,0 intern L3775 L3776: 0 byte(7)18,0 intern L3776 L3777: 0 byte(7)19,0 intern L3777 L3778: 0 byte(7)20,0 intern L3778 L3779: 0 byte(7)21,0 intern L3779 L3780: 0 byte(7)22,0 intern L3780 L3781: 0 byte(7)23,0 intern L3781 L3782: 0 byte(7)24,0 intern L3782 L3783: 0 byte(7)25,0 intern L3783 L3784: 0 byte(7)26,0 intern L3784 L3785: 0 byte(7)27,0 intern L3785 L3786: 0 byte(7)28,0 intern L3786 L3787: 0 byte(7)29,0 intern L3787 L3788: 0 byte(7)30,0 intern L3788 L3789: 0 byte(7)31,0 intern L3789 L3790: 0 byte(7)32,0 intern L3790 L3791: 0 byte(7)33,0 intern L3791 L3792: 0 byte(7)34,0 intern L3792 L3793: 0 byte(7)35,0 intern L3793 L3794: 0 byte(7)36,0 intern L3794 L3795: 0 byte(7)37,0 intern L3795 L3796: 0 byte(7)38,0 intern L3796 L3797: 0 byte(7)39,0 intern L3797 L3798: 0 byte(7)40,0 intern L3798 L3799: 0 byte(7)41,0 intern L3799 L3800: 0 byte(7)42,0 intern L3800 L3801: 0 byte(7)43,0 intern L3801 L3802: 0 byte(7)44,0 intern L3802 L3803: 0 byte(7)45,0 intern L3803 L3804: 0 byte(7)46,0 intern L3804 L3805: 0 byte(7)47,0 intern L3805 L3806: 0 byte(7)48,0 intern L3806 L3807: 0 byte(7)49,0 intern L3807 L3808: 0 byte(7)50,0 intern L3808 L3809: 0 byte(7)51,0 intern L3809 L3810: 0 byte(7)52,0 intern L3810 L3811: 0 byte(7)53,0 intern L3811 L3812: 0 byte(7)54,0 intern L3812 L3813: 0 byte(7)55,0 intern L3813 L3814: 0 byte(7)56,0 intern L3814 L3815: 0 byte(7)57,0 intern L3815 L3816: 0 byte(7)58,0 intern L3816 L3817: 0 byte(7)59,0 intern L3817 L3818: 0 byte(7)60,0 intern L3818 L3819: 0 byte(7)61,0 intern L3819 L3820: 0 byte(7)62,0 intern L3820 L3821: 0 byte(7)63,0 intern L3821 L3822: 0 byte(7)64,0 intern L3822 L3823: 0 byte(7)65,0 intern L3823 L3824: 0 byte(7)66,0 intern L3824 L3825: 0 byte(7)67,0 intern L3825 L3826: 0 byte(7)68,0 intern L3826 L3827: 0 byte(7)69,0 intern L3827 L3828: 0 byte(7)70,0 intern L3828 L3829: 0 byte(7)71,0 intern L3829 L3830: 0 byte(7)72,0 intern L3830 L3831: 0 byte(7)73,0 intern L3831 L3832: 0 byte(7)74,0 intern L3832 L3833: 0 byte(7)75,0 intern L3833 L3834: 0 byte(7)76,0 intern L3834 L3835: 0 byte(7)77,0 intern L3835 L3836: 0 byte(7)78,0 intern L3836 L3837: 0 byte(7)79,0 intern L3837 L3838: 0 byte(7)80,0 intern L3838 L3839: 0 byte(7)81,0 intern L3839 L3840: 0 byte(7)82,0 intern L3840 L3841: 0 byte(7)83,0 intern L3841 L3842: 0 byte(7)84,0 intern L3842 L3843: 0 byte(7)85,0 intern L3843 L3844: 0 byte(7)86,0 intern L3844 L3845: 0 byte(7)87,0 intern L3845 L3846: 0 byte(7)88,0 intern L3846 L3847: 0 byte(7)89,0 intern L3847 L3848: 0 byte(7)90,0 intern L3848 L3849: 0 byte(7)91,0 intern L3849 L3850: 0 byte(7)92,0 intern L3850 L3851: 0 byte(7)93,0 intern L3851 L3852: 0 byte(7)94,0 intern L3852 L3853: 0 byte(7)95,0 intern L3853 L3854: 0 byte(7)96,0 intern L3854 L3855: 0 byte(7)97,0 intern L3855 L3856: 0 byte(7)98,0 intern L3856 L3857: 0 byte(7)99,0 intern L3857 L3858: 0 byte(7)100,0 intern L3858 L3859: 0 byte(7)101,0 intern L3859 L3860: 0 byte(7)102,0 intern L3860 L3861: 0 byte(7)103,0 intern L3861 L3862: 0 byte(7)104,0 intern L3862 L3863: 0 byte(7)105,0 intern L3863 L3864: 0 byte(7)106,0 intern L3864 L3865: 0 byte(7)107,0 intern L3865 L3866: 0 byte(7)108,0 intern L3866 L3867: 0 byte(7)109,0 intern L3867 L3868: 0 byte(7)110,0 intern L3868 L3869: 0 byte(7)111,0 intern L3869 L3870: 0 byte(7)112,0 intern L3870 L3871: 0 byte(7)113,0 intern L3871 L3872: 0 byte(7)114,0 intern L3872 L3873: 0 byte(7)115,0 intern L3873 L3874: 0 byte(7)116,0 intern L3874 L3875: 0 byte(7)117,0 intern L3875 L3876: 0 byte(7)118,0 intern L3876 L3877: 0 byte(7)119,0 intern L3877 L3878: 0 byte(7)120,0 intern L3878 L3879: 0 byte(7)121,0 intern L3879 L3880: 0 byte(7)122,0 intern L3880 L3881: 0 byte(7)123,0 intern L3881 L3882: 0 byte(7)124,0 intern L3882 L3883: 0 byte(7)125,0 intern L3883 L3884: 0 byte(7)126,0 intern L3884 L3885: 0 byte(7)127,0 intern L3885 L3886: 2 byte(7)78,73,76,0 intern L3886 L3887: 5 byte(7)73,68,50,73,78,84,0 intern L3887 L3888: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L3888 L3889: 5 byte(7)73,78,84,50,73,68,0 intern L3889 L3890: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L3890 L3891: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L3891 L3892: 6 byte(7)73,78,84,50,83,89,83,0 intern L3892 L3893: 8 byte(7)76,73,83,80,50,67,72,65,82,0 intern L3893 L3894: 16 byte(7)78,79,78,67,72,65,82,65,67,84,69,82,69,82,82,79,82,0 intern L3894 L3895: 7 byte(7)73,78,84,50,67,79,68,69,0 intern L3895 L3896: 6 byte(7)83,89,83,50,73,78,84,0 intern L3896 L3897: 5 byte(7)71,84,70,73,88,78,0 intern L3897 L3898: 8 byte(7)73,68,50,83,84,82,73,78,71,0 intern L3898 L3899: 12 byte(7)83,84,82,73,78,71,50,86,69,67,84,79,82,0 intern L3899 L3900: 5 byte(7)71,84,86,69,67,84,0 intern L3900 L3901: 13 byte(7)78,79,78,83,84,82,73,78,71,69,82,82,79,82,0 intern L3901 L3902: 12 byte(7)86,69,67,84,79,82,50,83,84,82,73,78,71,0 intern L3902 L3903: 4 byte(7)71,84,83,84,82,0 intern L3903 L3904: 13 byte(7)78,79,78,86,69,67,84,79,82,69,82,82,79,82,0 intern L3904 L3905: 10 byte(7)76,73,83,84,50,83,84,82,73,78,71,0 intern L3905 L3906: 5 byte(7)76,69,78,71,84,72,0 intern L3906 L3907: 11 byte(7)78,79,78,80,65,73,82,69,82,82,79,82,0 intern L3907 L3908: 10 byte(7)83,84,82,73,78,71,50,76,73,83,84,0 intern L3908 L3909: 3 byte(7)67,79,78,83,0 intern L3909 L3910: 10 byte(7)76,73,83,84,50,86,69,67,84,79,82,0 intern L3910 L3911: 10 byte(7)86,69,67,84,79,82,50,76,73,83,84,0 intern L3911 L3912: 3 byte(7)71,69,84,86,0 intern L3912 L3913: 5 byte(7)66,76,68,77,83,71,0 intern L3913 L3914: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L3914 L3915: 9 byte(7)73,78,68,69,88,69,82,82,79,82,0 intern L3915 L3916: 3 byte(7)80,85,84,86,0 intern L3916 L3917: 3 byte(7)85,80,66,86,0 intern L3917 L3918: 7 byte(7)69,86,69,67,84,79,82,80,0 intern L3918 L3919: 4 byte(7)69,71,69,84,86,0 intern L3919 L3920: 4 byte(7)69,80,85,84,86,0 intern L3920 L3921: 4 byte(7)69,85,80,66,86,0 intern L3921 L3922: 3 byte(7)73,78,68,88,0 intern L3922 L3923: 9 byte(7)82,65,78,71,69,69,82,82,79,82,0 intern L3923 L3924: 15 byte(7)78,79,78,83,69,81,85,69,78,67,69,69,82,82,79,82,0 intern L3924 L3925: 6 byte(7)83,69,84,73,78,68,88,0 intern L3925 L3926: 2 byte(7)83,85,66,0 intern L3926 L3927: 5 byte(7)83,85,66,83,69,81,0 intern L3927 L3928: 5 byte(7)71,84,87,82,68,83,0 intern L3928 L3929: 10 byte(7)71,84,72,65,76,70,87,79,82,68,83,0 intern L3929 L3930: 4 byte(7)78,67,79,78,83,0 intern L3930 L3931: 4 byte(7)84,67,79,78,67,0 intern L3931 L3932: 5 byte(7)83,69,84,83,85,66,0 intern L3932 L3933: 8 byte(7)83,69,84,83,85,66,83,69,81,0 intern L3933 L3934: 5 byte(7)67,79,78,67,65,84,0 intern L3934 L3935: 5 byte(7)65,80,80,69,78,68,0 intern L3935 L3936: 3 byte(7)83,73,90,69,0 intern L3936 L3937: 4 byte(7)67,79,68,69,80,0 intern L3937 L3938: 1 byte(7)69,81,0 intern L3938 L3939: 5 byte(7)70,76,79,65,84,80,0 intern L3939 L3940: 3 byte(7)66,73,71,80,0 intern L3940 L3941: 2 byte(7)73,68,80,0 intern L3941 L3942: 4 byte(7)80,65,73,82,80,0 intern L3942 L3943: 6 byte(7)83,84,82,73,78,71,80,0 intern L3943 L3944: 6 byte(7)86,69,67,84,79,82,80,0 intern L3944 L3945: 2 byte(7)67,65,82,0 intern L3945 L3946: 2 byte(7)67,68,82,0 intern L3946 L3947: 5 byte(7)82,80,76,65,67,65,0 intern L3947 L3948: 5 byte(7)82,80,76,65,67,68,0 intern L3948 L3949: 3 byte(7)70,73,88,80,0 intern L3949 L3950: 4 byte(7)68,73,71,73,84,0 intern L3950 L3951: 4 byte(7)76,73,84,69,82,0 intern L3951 L3952: 2 byte(7)69,81,78,0 intern L3952 L3953: 8 byte(7)76,73,83,80,69,81,85,65,76,0 intern L3953 L3954: 10 byte(7)83,84,82,73,78,71,69,81,85,65,76,0 intern L3954 L3955: 4 byte(7)69,81,83,84,82,0 intern L3955 L3956: 4 byte(7)69,81,85,65,76,0 intern L3956 L3957: 5 byte(7)67,65,65,65,65,82,0 intern L3957 L3958: 4 byte(7)67,65,65,65,82,0 intern L3958 L3959: 5 byte(7)67,65,65,65,68,82,0 intern L3959 L3960: 5 byte(7)67,65,65,68,65,82,0 intern L3960 L3961: 4 byte(7)67,65,65,68,82,0 intern L3961 L3962: 5 byte(7)67,65,65,68,68,82,0 intern L3962 L3963: 5 byte(7)67,65,68,65,65,82,0 intern L3963 L3964: 4 byte(7)67,65,68,65,82,0 intern L3964 L3965: 5 byte(7)67,65,68,65,68,82,0 intern L3965 L3966: 5 byte(7)67,65,68,68,65,82,0 intern L3966 L3967: 4 byte(7)67,65,68,68,82,0 intern L3967 L3968: 5 byte(7)67,65,68,68,68,82,0 intern L3968 L3969: 5 byte(7)67,68,65,65,65,82,0 intern L3969 L3970: 4 byte(7)67,68,65,65,82,0 intern L3970 L3971: 5 byte(7)67,68,65,65,68,82,0 intern L3971 L3972: 5 byte(7)67,68,65,68,65,82,0 intern L3972 L3973: 4 byte(7)67,68,65,68,82,0 intern L3973 L3974: 5 byte(7)67,68,65,68,68,82,0 intern L3974 L3975: 5 byte(7)67,68,68,65,65,82,0 intern L3975 L3976: 4 byte(7)67,68,68,65,82,0 intern L3976 L3977: 5 byte(7)67,68,68,65,68,82,0 intern L3977 L3978: 5 byte(7)67,68,68,68,65,82,0 intern L3978 L3979: 4 byte(7)67,68,68,68,82,0 intern L3979 L3980: 5 byte(7)67,68,68,68,68,82,0 intern L3980 L3981: 3 byte(7)67,65,65,82,0 intern L3981 L3982: 3 byte(7)67,65,68,82,0 intern L3982 L3983: 3 byte(7)67,68,65,82,0 intern L3983 L3984: 3 byte(7)67,68,68,82,0 intern L3984 L3985: 6 byte(7)83,65,70,69,67,65,82,0 intern L3985 L3986: 6 byte(7)83,65,70,69,67,68,82,0 intern L3986 L3987: 3 byte(7)65,84,79,77,0 intern L3987 L3988: 8 byte(7)67,79,78,83,84,65,78,84,80,0 intern L3988 L3989: 3 byte(7)78,85,76,76,0 intern L3989 L3990: 6 byte(7)78,85,77,66,69,82,80,0 intern L3990 L3991: 3 byte(7)69,88,80,84,0 intern L3991 L3992: 6 byte(7)77,75,81,85,79,84,69,0 intern L3992 L3993: 4 byte(7)76,73,83,84,51,0 intern L3993 L3994: 15 byte(7)67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L3994 L3995: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L3995 L3996: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L3996 L3997: 5 byte(7)77,73,78,85,83,80,0 intern L3997 L3998: 5 byte(7)84,73,77,69,83,50,0 intern L3998 L3999: 3 byte(7)65,68,68,49,0 intern L3999 L4000: 7 byte(7)81,85,79,84,73,69,78,84,0 intern L4000 L4001: 4 byte(7)80,76,85,83,50,0 intern L4001 L4002: 3 byte(7)76,73,83,84,0 intern L4002 L4003: 4 byte(7)69,86,76,73,83,0 intern L4003 L4004: 4 byte(7)81,85,79,84,69,0 intern L4004 L4005: 3 byte(7)69,88,80,82,0 intern L4005 L4006: 1 byte(7)68,69,0 intern L4006 L4007: 4 byte(7)76,73,83,84,50,0 intern L4007 L4008: 4 byte(7)76,73,83,84,52,0 intern L4008 L4009: 3 byte(7)80,85,84,68,0 intern L4009 L4010: 7 byte(7)70,85,78,67,84,73,79,78,0 intern L4010 L4011: 5 byte(7)76,65,77,66,68,65,0 intern L4011 L4012: 4 byte(7)70,69,88,80,82,0 intern L4012 L4013: 1 byte(7)68,70,0 intern L4013 L4014: 4 byte(7)77,65,67,82,79,0 intern L4014 L4015: 1 byte(7)68,77,0 intern L4015 L4016: 4 byte(7)78,69,88,80,82,0 intern L4016 L4017: 1 byte(7)68,78,0 intern L4017 L4018: 3 byte(7)83,69,84,81,0 intern L4018 L4019: 3 byte(7)69,86,65,76,0 intern L4019 L4020: 2 byte(7)83,69,84,0 intern L4020 L4021: 4 byte(7)80,82,79,71,50,0 intern L4021 L4022: 4 byte(7)80,82,79,71,78,0 intern L4022 L4023: 6 byte(7)69,86,80,82,79,71,78,0 intern L4023 L4024: 2 byte(7)65,78,68,0 intern L4024 L4025: 4 byte(7)69,86,65,78,68,0 intern L4025 L4026: 1 byte(7)79,82,0 intern L4026 L4027: 3 byte(7)69,86,79,82,0 intern L4027 L4028: 3 byte(7)67,79,78,68,0 intern L4028 L4029: 5 byte(7)69,86,67,79,78,68,0 intern L4029 L4030: 2 byte(7)78,79,84,0 intern L4030 L4031: 2 byte(7)65,66,83,0 intern L4031 L4032: 4 byte(7)77,73,78,85,83,0 intern L4032 L4033: 5 byte(7)68,73,86,73,68,69,0 intern L4033 L4034: 4 byte(7)90,69,82,79,80,0 intern L4034 L4035: 8 byte(7)82,69,77,65,73,78,68,69,82,0 intern L4035 L4036: 4 byte(7)88,67,79,78,83,0 intern L4036 L4037: 2 byte(7)77,65,88,0 intern L4037 L4038: 11 byte(7)82,79,66,85,83,84,69,88,80,65,78,68,0 intern L4038 L4039: 3 byte(7)77,65,88,50,0 intern L4039 L4040: 4 byte(7)76,69,83,83,80,0 intern L4040 L4041: 2 byte(7)77,73,78,0 intern L4041 L4042: 3 byte(7)77,73,78,50,0 intern L4042 L4043: 3 byte(7)80,76,85,83,0 intern L4043 L4044: 4 byte(7)84,73,77,69,83,0 intern L4044 L4045: 2 byte(7)77,65,80,0 intern L4045 L4046: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L4046 L4047: 3 byte(7)77,65,80,67,0 intern L4047 L4048: 5 byte(7)77,65,80,67,65,78,0 intern L4048 L4049: 4 byte(7)78,67,79,78,67,0 intern L4049 L4050: 5 byte(7)77,65,80,67,79,78,0 intern L4050 L4051: 5 byte(7)77,65,80,67,65,82,0 intern L4051 L4052: 6 byte(7)77,65,80,76,73,83,84,0 intern L4052 L4053: 4 byte(7)65,83,83,79,67,0 intern L4053 L4054: 5 byte(7)83,65,83,83,79,67,0 intern L4054 L4055: 3 byte(7)80,65,73,82,0 intern L4055 L4056: 5 byte(7)83,85,66,76,73,83,0 intern L4056 L4057: 6 byte(7)68,69,70,76,73,83,84,0 intern L4057 L4058: 2 byte(7)80,85,84,0 intern L4058 L4059: 5 byte(7)68,69,76,69,84,69,0 intern L4059 L4060: 5 byte(7)77,69,77,66,69,82,0 intern L4060 L4061: 3 byte(7)77,69,77,81,0 intern L4061 L4062: 6 byte(7)82,69,86,69,82,83,69,0 intern L4062 L4063: 4 byte(7)83,85,66,83,84,0 intern L4063 L4064: 5 byte(7)69,88,80,65,78,68,0 intern L4064 L4065: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,0 intern L4065 L4066: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4066 L4067: 12 byte(7)67,72,65,78,78,69,76,84,69,82,80,82,73,0 intern L4067 L4068: 4 byte(7)80,82,73,78,84,0 intern L4068 L4069: 3 byte(7)79,85,84,42,0 intern L4069 L4070: 2 byte(7)78,69,81,0 intern L4070 L4071: 1 byte(7)78,69,0 intern L4071 L4072: 2 byte(7)71,69,81,0 intern L4072 L4073: 2 byte(7)76,69,81,0 intern L4073 L4074: 4 byte(7)69,81,67,65,82,0 intern L4074 L4075: 4 byte(7)69,88,80,82,80,0 intern L4075 L4076: 3 byte(7)71,69,84,68,0 intern L4076 L4077: 5 byte(7)77,65,67,82,79,80,0 intern L4077 L4078: 5 byte(7)70,69,88,80,82,80,0 intern L4078 L4079: 5 byte(7)78,69,88,80,82,80,0 intern L4079 L4080: 4 byte(7)67,79,80,89,68,0 intern L4080 L4081: 4 byte(7)82,69,67,73,80,0 intern L4081 L4082: 4 byte(7)70,73,82,83,84,0 intern L4082 L4083: 5 byte(7)83,69,67,79,78,68,0 intern L4083 L4084: 4 byte(7)84,72,73,82,68,0 intern L4084 L4085: 5 byte(7)70,79,85,82,84,72,0 intern L4085 L4086: 3 byte(7)82,69,83,84,0 intern L4086 L4087: 7 byte(7)82,69,86,69,82,83,73,80,0 intern L4087 L4088: 6 byte(7)83,85,66,83,84,73,80,0 intern L4088 L4089: 6 byte(7)68,69,76,69,84,73,80,0 intern L4089 L4090: 3 byte(7)68,69,76,81,0 intern L4090 L4091: 2 byte(7)68,69,76,0 intern L4091 L4092: 5 byte(7)68,69,76,81,73,80,0 intern L4092 L4093: 4 byte(7)65,84,83,79,67,0 intern L4093 L4094: 2 byte(7)65,83,83,0 intern L4094 L4095: 2 byte(7)77,69,77,0 intern L4095 L4096: 5 byte(7)82,65,83,83,79,67,0 intern L4096 L4097: 5 byte(7)68,69,76,65,83,67,0 intern L4097 L4098: 7 byte(7)68,69,76,65,83,67,73,80,0 intern L4098 L4099: 5 byte(7)68,69,76,65,84,81,0 intern L4099 L4100: 7 byte(7)68,69,76,65,84,81,73,80,0 intern L4100 L4101: 4 byte(7)83,85,66,76,65,0 intern L4101 L4102: 5 byte(7)82,80,76,65,67,87,0 intern L4102 L4103: 6 byte(7)76,65,83,84,67,65,82,0 intern L4103 L4104: 7 byte(7)76,65,83,84,80,65,73,82,0 intern L4104 L4105: 3 byte(7)67,79,80,89,0 intern L4105 L4106: 2 byte(7)78,84,72,0 intern L4106 L4107: 3 byte(7)83,85,66,49,0 intern L4107 L4108: 3 byte(7)80,78,84,72,0 intern L4108 L4109: 4 byte(7)65,67,79,78,67,0 intern L4109 L4110: 4 byte(7)76,67,79,78,67,0 intern L4110 L4111: 3 byte(7)77,65,80,50,0 intern L4111 L4112: 4 byte(7)77,65,80,67,50,0 intern L4112 L4113: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,84,0 intern L4113 L4114: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4114 L4115: 5 byte(7)80,82,73,78,50,84,0 intern L4115 L4116: 12 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,0 intern L4116 L4117: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L4117 L4118: 5 byte(7)83,80,65,67,69,83,0 intern L4118 L4119: 9 byte(7)67,72,65,78,78,69,76,84,65,66,0 intern L4119 L4120: 10 byte(7)67,72,65,78,78,69,76,80,79,83,78,0 intern L4120 L4121: 2 byte(7)84,65,66,0 intern L4121 L4122: 4 byte(7)70,73,76,69,80,0 intern L4122 L4123: 3 byte(7)80,85,84,67,0 intern L4123 L4124: 6 byte(7)83,80,65,67,69,83,50,0 intern L4124 L4125: 13 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,50,0 intern L4125 L4126: 7 byte(7)76,73,83,84,50,83,69,84,0 intern L4126 L4127: 8 byte(7)76,73,83,84,50,83,69,84,81,0 intern L4127 L4128: 5 byte(7)65,68,74,79,73,78,0 intern L4128 L4129: 6 byte(7)65,68,74,79,73,78,81,0 intern L4129 L4130: 4 byte(7)85,78,73,79,78,0 intern L4130 L4131: 5 byte(7)85,78,73,79,78,81,0 intern L4131 L4132: 1 byte(7)88,78,0 intern L4132 L4133: 2 byte(7)88,78,81,0 intern L4133 L4134: 11 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,0 intern L4134 L4135: 12 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,81,0 intern L4135 L4136: 15 byte(7)75,78,79,87,78,45,70,82,69,69,45,83,80,65,67,69,0 intern L4136 L4137: 5 byte(7)71,84,72,69,65,80,0 intern L4137 L4138: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L4138 L4139: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L4139 L4140: 12 byte(7)71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4140 L4141: 16 byte(7)83,69,84,45,71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4141 L4142: 6 byte(7)68,69,76,72,69,65,80,0 intern L4142 L4143: 9 byte(7)71,84,67,79,78,83,84,83,84,82,0 intern L4143 L4144: 4 byte(7)71,84,66,80,83,0 intern L4144 L4145: 6 byte(7)71,84,69,86,69,67,84,0 intern L4145 L4146: 5 byte(7)71,84,70,76,84,78,0 intern L4146 L4147: 3 byte(7)71,84,73,68,0 intern L4147 L4148: 6 byte(7)82,69,67,76,65,73,77,0 intern L4148 L4149: 5 byte(7)68,69,76,66,80,83,0 intern L4149 L4150: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L4150 L4151: 8 byte(7)68,69,76,87,65,82,82,65,89,0 intern L4151 L4152: 15 byte(7)67,79,80,89,83,84,82,73,78,71,84,79,70,82,79,77,0 intern L4152 L4153: 9 byte(7)67,79,80,89,83,84,82,73,78,71,0 intern L4153 L4154: 9 byte(7)67,79,80,89,87,65,82,82,65,89,0 intern L4154 L4155: 15 byte(7)67,79,80,89,86,69,67,84,79,82,84,79,70,82,79,77,0 intern L4155 L4156: 9 byte(7)67,79,80,89,86,69,67,84,79,82,0 intern L4156 L4157: 13 byte(7)67,79,80,89,87,82,68,83,84,79,70,82,79,77,0 intern L4157 L4158: 7 byte(7)67,79,80,89,87,82,68,83,0 intern L4158 L4159: 8 byte(7)84,79,84,65,76,67,79,80,89,0 intern L4159 L4160: 5 byte(7)77,75,86,69,67,84,0 intern L4160 L4161: 8 byte(7)77,75,69,86,69,67,84,79,82,0 intern L4161 L4162: 6 byte(7)77,75,69,86,69,67,84,0 intern L4162 L4163: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L4163 L4164: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L4164 L4165: 9 byte(7)77,65,75,69,45,66,89,84,69,83,0 intern L4165 L4166: 13 byte(7)77,65,75,69,45,72,65,76,70,87,79,82,68,83,0 intern L4166 L4167: 9 byte(7)77,65,75,69,45,87,79,82,68,83,0 intern L4167 L4168: 10 byte(7)77,65,75,69,45,86,69,67,84,79,82,0 intern L4168 L4169: 5 byte(7)83,84,82,73,78,71,0 intern L4169 L4170: 5 byte(7)86,69,67,84,79,82,0 intern L4170 L4171: 4 byte(7)76,73,83,84,53,0 intern L4171 L4172: 5 byte(7)71,67,75,78,84,42,0 intern L4172 L4173: 6 byte(7)71,67,84,73,77,69,42,0 intern L4173 L4174: 2 byte(7)42,71,67,0 intern L4174 L4175: 14 byte(7)72,69,65,80,45,87,65,82,78,45,76,69,86,69,76,0 intern L4175 L4176: 10 byte(7)69,82,82,79,82,80,82,73,78,84,70,0 intern L4176 L4177: 3 byte(7)84,73,77,67,0 intern L4177 L4178: 10 byte(7)85,78,77,65,80,45,83,80,65,67,69,0 intern L4178 L4179: 8 byte(7)82,69,84,85,82,78,78,73,76,0 intern L4179 L4180: 13 byte(7)82,69,84,85,82,78,70,73,82,83,84,65,82,71,0 intern L4180 L4181: 3 byte(7)76,65,78,68,0 intern L4181 L4182: 2 byte(7)76,79,82,0 intern L4182 L4183: 3 byte(7)76,88,79,82,0 intern L4183 L4184: 5 byte(7)76,83,72,73,70,84,0 intern L4184 L4185: 2 byte(7)76,83,72,0 intern L4185 L4186: 3 byte(7)76,78,79,84,0 intern L4186 L4187: 2 byte(7)70,73,88,0 intern L4187 L4188: 4 byte(7)70,76,79,65,84,0 intern L4188 L4189: 3 byte(7)79,78,69,80,0 intern L4189 L4190: 4 byte(7)68,69,66,85,71,0 intern L4190 L4191: 1 byte(7)84,82,0 intern L4191 L4192: 5 byte(7)69,86,76,79,65,68,0 intern L4192 L4193: 3 byte(7)84,82,83,84,0 intern L4193 L4194: 7 byte(7)81,69,68,73,84,70,78,83,0 intern L4194 L4195: 6 byte(7)42,69,88,80,69,82,84,0 intern L4195 L4196: 7 byte(7)42,86,69,82,66,79,83,69,0 intern L4196 L4197: 4 byte(7)69,68,73,84,70,0 intern L4197 L4198: 3 byte(7)69,68,73,84,0 intern L4198 L4199: 3 byte(7)89,69,83,80,0 intern L4199 L4200: 12 byte(7)80,82,79,77,80,84,83,84,82,73,78,71,42,0 intern L4200 L4201: 7 byte(7)70,65,83,84,66,73,78,68,0 intern L4201 L4202: 5 byte(7)84,69,82,80,82,73,0 intern L4202 L4203: 12 byte(7)69,68,73,84,79,82,82,69,65,68,69,82,42,0 intern L4203 L4204: 13 byte(7)69,68,73,84,79,82,80,82,73,78,84,69,82,42,0 intern L4204 L4205: 9 byte(7)70,65,83,84,85,78,66,73,78,68,0 intern L4205 L4206: 3 byte(7)82,69,65,68,0 intern L4206 L4207: 1 byte(7)67,76,0 intern L4207 L4208: 3 byte(7)72,69,76,80,0 intern L4208 L4209: 4 byte(7)66,82,69,65,75,0 intern L4209 L4210: 4 byte(7)69,72,69,76,80,0 intern L4210 L4211: 1 byte(7)80,76,0 intern L4211 L4212: 1 byte(7)85,80,0 intern L4212 L4213: 1 byte(7)79,75,0 intern L4213 L4214: 14 byte(7)68,73,83,80,76,65,89,72,69,76,80,70,73,76,69,0 intern L4214 L4215: 5 byte(7)69,68,73,84,79,82,0 intern L4215 L4216: 18 byte(7)73,71,78,79,82,69,68,73,78,66,65,67,75,84,82,65,67,69,42,0 intern L4216 L4217: 20 byte(7)73,78,84,69,82,80,82,69,84,69,82,70,85,78,67,84,73,79,78,83,42,0 intern L4217 L4218: 14 byte(7)73,78,84,69,82,80,66,65,67,75,84,82,65,67,69,0 intern L4218 L4219: 5 byte(7)80,82,73,78,84,70,0 intern L4219 L4220: 8 byte(7)66,65,67,75,84,82,65,67,69,0 intern L4220 L4221: 13 byte(7)82,69,84,85,82,78,65,68,68,82,69,83,83,80,0 intern L4221 L4222: 6 byte(7)65,68,68,82,50,73,68,0 intern L4222 L4223: 15 byte(7)86,69,82,66,79,83,69,66,65,67,75,84,82,65,67,69,0 intern L4223 L4224: 7 byte(7)79,80,84,73,79,78,83,42,0 intern L4224 L4225: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L4225 L4226: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,75,78,79,87,78,73,84,69,77,0 intern L4226 L4227: 21 byte(7)67,79,68,69,45,65,68,68,82,69,83,83,45,84,79,45,83,89,77,66,79,76,0 intern L4227 L4228: 4 byte(7)80,82,73,78,49,0 intern L4228 L4229: 3 byte(7)81,85,73,84,0 intern L4229 L4230: 4 byte(7)69,82,82,79,82,0 intern L4230 L4231: 1 byte(7)78,79,0 intern L4231 L4232: 2 byte(7)89,69,83,0 intern L4232 L4233: 2 byte(7)82,68,83,0 intern L4233 L4234: 6 byte(7)69,82,82,79,85,84,42,0 intern L4234 L4235: 2 byte(7)87,82,83,0 intern L4235 L4236: 7 byte(7)69,82,82,79,82,83,69,84,0 intern L4236 L4237: 6 byte(7)67,85,82,83,89,77,42,0 intern L4237 L4238: 8 byte(7)42,83,69,77,73,67,79,76,42,0 intern L4238 L4239: 9 byte(7)69,82,82,79,82,70,79,82,77,42,0 intern L4239 L4240: 16 byte(7)42,67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L4240 L4241: 4 byte(7)69,77,83,71,42,0 intern L4241 L4242: 5 byte(7)42,66,82,69,65,75,0 intern L4242 L4243: 5 byte(7)42,69,77,83,71,80,0 intern L4243 L4244: 13 byte(7)77,65,88,66,82,69,65,75,76,69,86,69,76,42,0 intern L4244 L4245: 10 byte(7)66,82,69,65,75,76,69,86,69,76,42,0 intern L4245 L4246: 7 byte(7)70,76,65,84,83,73,90,69,0 intern L4246 L4247: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L4247 L4248: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L4248 L4249: 7 byte(7)78,79,78,87,79,82,68,83,0 intern L4249 L4250: 16 byte(7)78,79,78,73,79,67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4250 L4251: 9 byte(7)42,66,65,67,75,84,82,65,67,69,0 intern L4251 L4252: 15 byte(7)42,73,78,78,69,82,42,66,65,67,75,84,82,65,67,69,0 intern L4252 L4253: 4 byte(7)84,72,82,79,87,0 intern L4253 L4254: 6 byte(7)36,69,82,82,79,82,36,0 intern L4254 L4255: 5 byte(7)69,82,82,83,69,84,0 intern L4255 L4256: 4 byte(7)67,65,84,67,72,0 intern L4256 L4257: 9 byte(7)67,65,84,67,72,83,69,84,85,80,0 intern L4257 L4258: 11 byte(7)84,72,82,79,87,83,73,71,78,65,76,42,0 intern L4258 L4259: 7 byte(7)37,85,78,67,65,84,67,72,0 intern L4259 L4260: 13 byte(7)67,72,65,78,78,69,76,78,79,84,79,80,69,78,0 intern L4260 L4261: 11 byte(7)67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4261 L4262: 15 byte(7)87,82,73,84,69,79,78,76,89,67,72,65,78,78,69,76,0 intern L4262 L4263: 14 byte(7)82,69,65,68,79,78,76,89,67,72,65,78,78,69,76,0 intern L4263 L4264: 26 byte(7)73,76,76,69,71,65,76,83,84,65,78,68,65,82,68,67,72,65,78,78,69,76,67,76,79,83,69,0 intern L4264 L4265: 6 byte(7)73,79,69,82,82,79,82,0 intern L4265 L4266: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L4266 L4267: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L4267 L4268: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L4268 L4269: 5 byte(7)76,66,73,78,68,49,0 intern L4269 L4270: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L4270 L4271: 13 byte(7)66,83,84,65,67,75,79,86,69,82,70,76,79,87,0 intern L4271 L4272: 17 byte(7)82,69,83,84,79,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4272 L4273: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L4273 L4274: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L4274 L4275: 6 byte(7)85,78,66,73,78,68,78,0 intern L4275 L4276: 4 byte(7)65,80,80,76,89,0 intern L4276 L4277: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L4277 L4278: 5 byte(7)70,67,79,68,69,80,0 intern L4278 L4279: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L4279 L4280: 2 byte(7)71,69,84,0 intern L4280 L4281: 8 byte(7)86,65,76,85,69,67,69,76,76,0 intern L4281 L4282: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L4282 L4283: 8 byte(7)38,38,86,65,76,85,69,38,38,0 intern L4283 L4284: 8 byte(7)84,72,82,79,87,84,65,71,42,0 intern L4284 L4285: 8 byte(7)67,65,84,67,72,45,65,76,76,0 intern L4285 L4286: 9 byte(7)85,78,87,73,78,68,45,65,76,76,0 intern L4286 L4287: 9 byte(7)38,38,84,72,82,79,87,78,38,38,0 intern L4287 L4288: 15 byte(7)36,85,78,87,73,78,68,45,80,82,79,84,69,67,84,36,0 intern L4288 L4289: 6 byte(7)38,38,84,65,71,38,38,0 intern L4289 L4290: 5 byte(7)37,84,72,82,79,87,0 intern L4290 L4291: 13 byte(7)85,78,87,73,78,68,45,80,82,79,84,69,67,84,0 intern L4291 L4292: 5 byte(7)42,67,65,84,67,72,0 intern L4292 L4293: 5 byte(7)42,84,72,82,79,87,0 intern L4293 L4294: 4 byte(7)82,69,83,69,84,0 intern L4294 L4295: 17 byte(7)67,65,80,84,85,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4295 L4296: 17 byte(7)37,67,76,69,65,82,45,67,65,84,67,72,45,83,84,65,67,75,0 intern L4296 L4297: 8 byte(7)80,82,79,71,66,79,68,89,42,0 intern L4297 L4298: 13 byte(7)80,82,79,71,74,85,77,80,84,65,66,76,69,42,0 intern L4298 L4299: 3 byte(7)80,82,79,71,0 intern L4299 L4300: 5 byte(7)80,66,73,78,68,49,0 intern L4300 L4301: 5 byte(7)36,80,82,79,71,36,0 intern L4301 L4302: 1 byte(7)71,79,0 intern L4302 L4303: 5 byte(7)82,69,84,85,82,78,0 intern L4303 L4304: 11 byte(7)83,89,83,84,69,77,95,76,73,83,84,42,0 intern L4304 L4305: 3 byte(7)68,65,84,69,0 intern L4305 L4306: 7 byte(7)68,85,77,80,76,73,83,80,0 intern L4306 L4307: 13 byte(7)66,73,78,65,82,89,79,80,69,78,82,69,65,68,0 intern L4307 L4308: 8 byte(7)68,69,67,50,48,79,80,69,78,0 intern L4308 L4309: 14 byte(7)66,73,78,65,82,89,79,80,69,78,87,82,73,84,69,0 intern L4309 L4310: 16 byte(7)86,65,76,85,69,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4310 L4311: 15 byte(7)42,87,82,73,84,73,78,71,70,65,83,76,70,73,76,69,0 intern L4311 L4312: 16 byte(7)78,69,87,66,73,84,84,65,66,76,69,69,78,84,82,89,42,0 intern L4312 L4313: 11 byte(7)70,73,78,68,73,68,78,85,77,66,69,82,0 intern L4313 L4314: 16 byte(7)77,65,75,69,82,69,76,79,67,72,65,76,70,87,79,82,68,0 intern L4314 L4315: 15 byte(7)69,88,84,82,65,82,69,71,76,79,67,65,84,73,79,78,0 intern L4315 L4316: 19 byte(7)70,85,78,67,84,73,79,78,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4316 L4317: 5 byte(7)70,65,83,76,73,78,0 intern L4317 L4318: 5 byte(7)73,78,84,69,82,78,0 intern L4318 L4319: 7 byte(7)80,85,84,69,78,84,82,89,0 intern L4319 L4320: 15 byte(7)76,79,65,68,68,73,82,69,67,84,79,82,73,69,83,42,0 intern L4320 L4321: 14 byte(7)76,79,65,68,69,88,84,69,78,83,73,79,78,83,42,0 intern L4321 L4322: 11 byte(7)42,86,69,82,66,79,83,69,76,79,65,68,0 intern L4322 L4323: 14 byte(7)42,80,82,73,78,84,76,79,65,68,78,65,77,69,83,0 intern L4323 L4324: 3 byte(7)76,79,65,68,0 intern L4324 L4325: 4 byte(7)76,79,65,68,49,0 intern L4325 L4326: 5 byte(7)82,69,76,79,65,68,0 intern L4326 L4327: 7 byte(7)69,86,82,69,76,79,65,68,0 intern L4327 L4328: 8 byte(7)42,85,83,69,82,77,79,68,69,0 intern L4328 L4329: 8 byte(7)42,82,69,68,69,70,77,83,71,0 intern L4329 L4330: 10 byte(7)42,73,78,83,73,68,69,76,79,65,68,0 intern L4330 L4331: 5 byte(7)42,76,79,87,69,82,0 intern L4331 L4332: 12 byte(7)80,69,78,68,73,78,71,76,79,65,68,83,42,0 intern L4332 L4333: 6 byte(7)73,77,80,79,82,84,83,0 intern L4333 L4334: 1 byte(7)80,80,0 intern L4334 L4335: 10 byte(7)80,82,69,84,84,89,80,82,73,78,84,0 intern L4335 L4336: 8 byte(7)68,69,70,83,84,82,85,67,84,0 intern L4336 L4337: 3 byte(7)83,84,69,80,0 intern L4337 L4338: 3 byte(7)77,73,78,73,0 intern L4338 L4339: 4 byte(7)69,77,79,68,69,0 intern L4339 L4340: 5 byte(7)73,78,86,79,75,69,0 intern L4340 L4341: 4 byte(7)82,67,82,69,70,0 intern L4341 L4342: 5 byte(7)67,82,69,70,79,78,0 intern L4342 L4343: 7 byte(7)67,79,77,80,73,76,69,82,0 intern L4343 L4344: 4 byte(7)67,79,77,80,68,0 intern L4344 L4345: 6 byte(7)70,65,83,76,79,85,84,0 intern L4345 L4346: 2 byte(7)66,85,71,0 intern L4346 L4347: 3 byte(7)69,88,69,67,0 intern L4347 L4348: 1 byte(7)77,77,0 intern L4348 L4349: 19 byte(7)84,69,82,77,73,78,65,76,73,78,80,85,84,72,65,78,68,76,69,82,0 intern L4349 L4350: 15 byte(7)67,79,77,80,82,69,83,83,82,69,65,68,67,72,65,82,0 intern L4350 L4351: 13 byte(7)68,69,67,50,48,87,82,73,84,69,67,72,65,82,0 intern L4351 L4352: 16 byte(7)84,79,83,84,82,73,78,71,87,82,73,84,69,67,72,65,82,0 intern L4352 L4353: 15 byte(7)69,88,80,76,79,68,69,87,82,73,84,69,67,72,65,82,0 intern L4353 L4354: 16 byte(7)70,76,65,84,83,73,90,69,87,82,73,84,69,67,72,65,82,0 intern L4354 L4355: 4 byte(7)36,69,79,76,36,0 intern L4355 L4356: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,65,82,0 intern L4356 L4357: 7 byte(7)82,69,65,68,67,72,65,82,0 intern L4357 L4358: 2 byte(7)73,78,42,0 intern L4358 L4359: 16 byte(7)67,72,65,78,78,69,76,85,78,82,69,65,68,67,72,65,82,0 intern L4359 L4360: 9 byte(7)85,78,82,69,65,68,67,72,65,82,0 intern L4360 L4361: 3 byte(7)79,80,69,78,0 intern L4361 L4362: 21 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,73,78,80,85,84,0 intern L4362 L4363: 22 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,79,85,84,80,85,84,0 intern L4363 L4364: 20 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,83,80,69,67,73,65,76,0 intern L4364 L4365: 19 byte(7)83,80,69,67,73,65,76,82,69,65,68,70,85,78,67,84,73,79,78,42,0 intern L4365 L4366: 20 byte(7)83,80,69,67,73,65,76,87,82,73,84,69,70,85,78,67,84,73,79,78,42,0 intern L4366 L4367: 20 byte(7)83,80,69,67,73,65,76,67,76,79,83,69,70,85,78,67,84,73,79,78,42,0 intern L4367 L4368: 6 byte(7)83,80,69,67,73,65,76,0 intern L4368 L4369: 5 byte(7)79,85,84,80,85,84,0 intern L4369 L4370: 4 byte(7)73,78,80,85,84,0 intern L4370 L4371: 4 byte(7)67,76,79,83,69,0 intern L4371 L4372: 24 byte(7)83,89,83,84,69,77,77,65,82,75,65,83,67,76,79,83,69,68,67,72,65,78,78,69,76,0 intern L4372 L4373: 16 byte(7)83,80,69,67,73,65,76,82,68,83,65,67,84,73,79,78,42,0 intern L4373 L4374: 5 byte(7)83,84,68,73,78,42,0 intern L4374 L4375: 16 byte(7)83,80,69,67,73,65,76,87,82,83,65,67,84,73,79,78,42,0 intern L4375 L4376: 6 byte(7)83,84,68,79,85,84,42,0 intern L4376 L4377: 11 byte(7)67,72,65,78,78,69,76,69,74,69,67,84,0 intern L4377 L4378: 4 byte(7)69,74,69,67,84,0 intern L4378 L4379: 16 byte(7)67,72,65,78,78,69,76,76,73,78,69,76,69,78,71,84,72,0 intern L4379 L4380: 9 byte(7)76,73,78,69,76,69,78,71,84,72,0 intern L4380 L4381: 3 byte(7)80,79,83,78,0 intern L4381 L4382: 11 byte(7)67,72,65,78,78,69,76,76,80,79,83,78,0 intern L4382 L4383: 4 byte(7)76,80,79,83,78,0 intern L4383 L4384: 12 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,0 intern L4384 L4385: 5 byte(7)42,82,65,73,83,69,0 intern L4385 L4386: 5 byte(7)82,69,65,68,67,72,0 intern L4386 L4387: 4 byte(7)80,82,73,78,67,0 intern L4387 L4388: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,67,0 intern L4388 L4389: 25 byte(7)67,85,82,82,69,78,84,82,69,65,68,77,65,67,82,79,73,78,68,73,67,65,84,79,82,42,0 intern L4389 L4390: 24 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,87,73,84,72,72,79,79,75,83,0 intern L4390 L4391: 15 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,0 intern L4391 L4392: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L4392 L4393: 16 byte(7)67,85,82,82,69,78,84,83,67,65,78,84,65,66,76,69,42,0 intern L4393 L4394: 10 byte(7)67,72,65,78,78,69,76,82,69,65,68,0 intern L4394 L4395: 13 byte(7)76,73,83,80,83,67,65,78,84,65,66,76,69,42,0 intern L4395 L4396: 12 byte(7)76,73,83,80,82,69,65,68,77,65,67,82,79,0 intern L4396 L4397: 17 byte(7)77,65,75,69,73,78,80,85,84,65,86,65,73,76,65,66,76,69,0 intern L4397 L4398: 19 byte(7)42,73,78,83,73,68,69,83,84,82,85,67,84,85,82,69,82,69,65,68,0 intern L4398 L4399: 13 byte(7)67,72,65,78,78,69,76,82,69,65,68,69,79,70,0 intern L4399 L4400: 4 byte(7)36,69,79,70,36,0 intern L4400 L4401: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,81,85,79,84,69,68,69,88,80,82,69,83,83,73,79,78,0 intern L4401 L4402: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,83,84,79,82,68,79,84,84,69,68,80,65,73,82,0 intern L4402 L4403: 20 byte(7)67,72,65,78,78,69,76,82,69,65,68,82,73,71,72,84,80,65,82,69,78,0 intern L4403 L4404: 16 byte(7)67,72,65,78,78,69,76,82,69,65,68,86,69,67,84,79,82,0 intern L4404 L4405: 11 byte(7)42,67,79,77,80,82,69,83,83,73,78,71,0 intern L4405 L4406: 13 byte(7)42,69,79,76,73,78,83,84,82,73,78,71,79,75,0 intern L4406 L4407: 4 byte(7)78,69,87,73,68,0 intern L4407 L4408: 24 byte(7)77,65,75,69,83,84,82,73,78,71,73,78,84,79,76,73,83,80,73,78,84,69,71,69,82,0 intern L4408 L4409: 12 byte(7)68,73,71,73,84,84,79,78,85,77,66,69,82,0 intern L4409 L4410: 6 byte(7)80,65,67,75,65,71,69,0 intern L4410 L4411: 14 byte(7)67,85,82,82,69,78,84,80,65,67,75,65,71,69,42,0 intern L4411 L4412: 5 byte(7)71,76,79,66,65,76,0 intern L4412 L4413: 4 byte(7)82,65,84,79,77,0 intern L4413 L4414: 7 byte(7)82,69,65,68,76,73,78,69,0 intern L4414 L4415: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,78,69,0 intern L4415 L4416: 10 byte(7)79,85,84,80,85,84,66,65,83,69,42,0 intern L4416 L4417: 12 byte(7)73,68,69,83,67,65,80,69,67,72,65,82,42,0 intern L4417 L4418: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,84,82,73,78,71,0 intern L4418 L4419: 10 byte(7)87,82,73,84,69,83,84,82,73,78,71,0 intern L4419 L4420: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4420 L4421: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,73,84,83,84,82,65,85,88,0 intern L4421 L4422: 14 byte(7)87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4422 L4423: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,73,88,78,85,77,0 intern L4423 L4424: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,78,84,69,71,69,82,0 intern L4424 L4425: 19 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,70,76,79,65,84,0 intern L4425 L4426: 9 byte(7)87,82,73,84,69,70,76,79,65,84,0 intern L4426 L4427: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,76,79,65,84,0 intern L4427 L4428: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,83,84,82,73,78,71,0 intern L4428 L4429: 13 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,68,0 intern L4429 L4430: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,66,79,85,78,68,0 intern L4430 L4431: 13 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,73,68,0 intern L4431 L4432: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,85,78,66,79,85,78,68,0 intern L4432 L4433: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,79,68,69,80,79,73,78,84,69,82,0 intern L4433 L4434: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,76,65,78,75,79,82,69,79,76,0 intern L4434 L4435: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,80,65,73,82,0 intern L4435 L4436: 8 byte(7)80,82,73,78,76,69,86,69,76,0 intern L4436 L4437: 9 byte(7)80,82,73,78,76,69,78,71,84,72,0 intern L4437 L4438: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4438 L4439: 15 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,80,65,73,82,0 intern L4439 L4440: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4440 L4441: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,86,69,67,84,79,82,0 intern L4441 L4442: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,86,69,67,84,79,82,0 intern L4442 L4443: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,69,86,69,67,84,79,82,0 intern L4443 L4444: 25 byte(7)79,66,74,69,67,84,45,71,69,84,45,72,65,78,68,76,69,82,45,81,85,73,69,84,76,89,0 intern L4444 L4445: 10 byte(7)67,72,65,78,78,69,76,80,82,73,78,0 intern L4445 L4446: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,69,86,69,67,84,79,82,0 intern L4446 L4447: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,87,79,82,68,83,0 intern L4447 L4448: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,72,65,76,70,87,79,82,68,83,0 intern L4448 L4449: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,89,84,69,83,0 intern L4449 L4450: 4 byte(7)80,82,73,78,50,0 intern L4450 L4451: 15 byte(7)70,79,82,77,65,84,70,79,82,80,82,73,78,84,70,42,0 intern L4451 L4452: 5 byte(7)80,82,73,78,50,76,0 intern L4452 L4453: 6 byte(7)69,82,82,80,82,73,78,0 intern L4453 L4454: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,70,0 intern L4454 L4455: 17 byte(7)69,88,80,76,79,68,69,69,78,68,80,79,73,78,84,69,82,42,0 intern L4455 L4456: 6 byte(7)69,88,80,76,79,68,69,0 intern L4456 L4457: 7 byte(7)69,88,80,76,79,68,69,50,0 intern L4457 L4458: 8 byte(7)70,76,65,84,83,73,90,69,50,0 intern L4458 L4459: 12 byte(7)67,79,77,80,82,69,83,83,69,82,82,79,82,0 intern L4459 L4460: 12 byte(7)67,79,77,80,82,69,83,83,76,73,83,84,42,0 intern L4460 L4461: 19 byte(7)67,76,69,65,82,67,79,77,80,82,69,83,83,67,72,65,78,78,69,76,0 intern L4461 L4462: 7 byte(7)67,79,77,80,82,69,83,83,0 intern L4462 L4463: 6 byte(7)73,77,80,76,79,68,69,0 intern L4463 L4464: 9 byte(7)67,72,65,78,78,69,76,84,89,73,0 intern L4464 L4465: 9 byte(7)67,72,65,78,78,69,76,84,89,79,0 intern L4465 L4466: 2 byte(7)84,89,73,0 intern L4466 L4467: 2 byte(7)84,89,79,0 intern L4467 L4468: 13 byte(7)67,79,77,77,69,78,84,79,85,84,67,79,68,69,0 intern L4468 L4469: 10 byte(7)67,79,77,80,73,76,69,84,73,77,69,0 intern L4469 L4470: 8 byte(7)66,79,84,72,84,73,77,69,83,0 intern L4470 L4471: 7 byte(7)76,79,65,68,84,73,77,69,0 intern L4471 L4472: 10 byte(7)83,84,65,82,84,85,80,84,73,77,69,0 intern L4472 L4473: 8 byte(7)67,79,78,84,69,82,82,79,82,0 intern L4473 L4474: 8 byte(7)79,84,72,69,82,87,73,83,69,0 intern L4474 L4475: 6 byte(7)68,69,70,65,85,76,84,0 intern L4475 L4476: 3 byte(7)67,65,83,69,0 intern L4476 L4477: 4 byte(7)82,65,78,71,69,0 intern L4477 L4478: 3 byte(7)83,69,84,70,0 intern L4478 L4479: 9 byte(7)69,88,80,65,78,68,83,69,84,70,0 intern L4479 L4480: 10 byte(7)83,69,84,70,45,69,88,80,65,78,68,0 intern L4480 L4481: 8 byte(7)65,83,83,73,71,78,45,79,80,0 intern L4481 L4482: 5 byte(7)79,78,79,70,70,42,0 intern L4482 L4483: 8 byte(7)77,75,70,76,65,71,86,65,82,0 intern L4483 L4484: 5 byte(7)83,73,77,80,70,71,0 intern L4484 L4485: 1 byte(7)79,78,0 intern L4485 L4486: 2 byte(7)79,70,70,0 intern L4486 L4487: 3 byte(7)35,65,82,71,0 intern L4487 L4488: 1 byte(7)68,83,0 intern L4488 L4489: 7 byte(7)68,69,70,67,79,78,83,84,0 intern L4489 L4490: 9 byte(7)69,86,68,69,70,67,79,78,83,84,0 intern L4490 L4491: 4 byte(7)67,79,78,83,84,0 intern L4491 L4492: 11 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,0 intern L4492 L4493: 12 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,42,0 intern L4493 L4494: 6 byte(7)70,79,82,69,65,67,72,0 intern L4494 L4495: 6 byte(7)67,79,76,76,69,67,84,0 intern L4495 L4496: 3 byte(7)74,79,73,78,0 intern L4496 L4497: 3 byte(7)67,79,78,67,0 intern L4497 L4498: 1 byte(7)73,78,0 intern L4498 L4499: 1 byte(7)68,79,0 intern L4499 L4500: 3 byte(7)69,88,73,84,0 intern L4500 L4501: 5 byte(7)36,76,79,79,80,36,0 intern L4501 L4502: 3 byte(7)78,69,88,84,0 intern L4502 L4503: 4 byte(7)87,72,73,76,69,0 intern L4503 L4504: 5 byte(7)82,69,80,69,65,84,0 intern L4504 L4505: 2 byte(7)70,79,82,0 intern L4505 L4506: 5 byte(7)71,69,78,83,89,77,0 intern L4506 L4507: 4 byte(7)77,75,42,83,81,0 intern L4507 L4508: 3 byte(7)83,73,77,80,0 intern L4508 L4509: 2 byte(7)66,73,78,0 intern L4509 L4510: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L4510 L4511: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L4511 L4512: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L4512 L4513: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L4513 L4514: 3 byte(7)80,82,79,80,0 intern L4514 L4515: 6 byte(7)83,69,84,80,82,79,80,0 intern L4515 L4516: 4 byte(7)70,76,65,71,80,0 intern L4516 L4517: 3 byte(7)84,89,80,69,0 intern L4517 L4518: 3 byte(7)70,76,65,71,0 intern L4518 L4519: 4 byte(7)70,76,65,71,49,0 intern L4519 L4520: 6 byte(7)82,69,77,70,76,65,71,0 intern L4520 L4521: 7 byte(7)82,69,77,70,76,65,71,49,0 intern L4521 L4522: 6 byte(7)82,69,77,80,82,79,80,0 intern L4522 L4523: 7 byte(7)82,69,77,80,82,79,80,76,0 intern L4523 L4524: 7 byte(7)85,78,66,79,85,78,68,80,0 intern L4524 L4525: 6 byte(7)86,65,82,84,89,80,69,0 intern L4525 L4526: 4 byte(7)70,76,85,73,68,0 intern L4526 L4527: 5 byte(7)70,76,85,73,68,49,0 intern L4527 L4528: 5 byte(7)70,76,85,73,68,80,0 intern L4528 L4529: 6 byte(7)71,76,79,66,65,76,49,0 intern L4529 L4530: 6 byte(7)71,76,79,66,65,76,80,0 intern L4530 L4531: 6 byte(7)85,78,70,76,85,73,68,0 intern L4531 L4532: 7 byte(7)85,78,70,76,85,73,68,49,0 intern L4532 L4533: 3 byte(7)82,69,77,68,0 intern L4533 L4534: 4 byte(7)42,67,79,77,80,0 intern L4534 L4535: 3 byte(7)85,83,69,82,0 intern L4535 L4536: 3 byte(7)76,79,83,69,0 intern L4536 L4537: 23 byte(7)67,79,68,69,45,78,85,77,66,69,82,45,79,70,45,65,82,71,85,77,69,78,84,83,0 intern L4537 L4538: 14 byte(7)66,83,84,65,67,75,85,78,68,69,82,70,76,79,87,0 intern L4538 L4539: 12 byte(7)67,76,69,65,82,66,73,78,68,73,78,71,83,0 intern L4539 L4540: 10 byte(7)77,65,75,69,85,78,66,79,85,78,68,0 intern L4540 L4541: 11 byte(7)72,65,83,72,70,85,78,67,84,73,79,78,0 intern L4541 L4542: 4 byte(7)82,69,77,79,66,0 intern L4542 L4543: 6 byte(7)73,78,84,69,82,78,80,0 intern L4543 L4544: 11 byte(7)73,78,84,69,82,78,71,69,78,83,89,77,0 intern L4544 L4545: 5 byte(7)77,65,80,79,66,76,0 intern L4545 L4546: 11 byte(7)71,76,79,66,65,76,76,79,79,75,85,80,0 intern L4546 L4547: 12 byte(7)71,76,79,66,65,76,73,78,83,84,65,76,76,0 intern L4547 L4548: 11 byte(7)71,76,79,66,65,76,82,69,77,79,86,69,0 intern L4548 L4549: 9 byte(7)73,78,73,84,79,66,76,73,83,84,0 intern L4549 L4550: 12 byte(7)68,69,67,50,48,82,69,65,68,67,72,65,82,0 intern L4550 L4551: 4 byte(7)42,69,67,72,79,0 intern L4551 L4552: 6 byte(7)67,76,69,65,82,73,79,0 intern L4552 L4553: 16 byte(7)68,69,67,50,48,67,76,79,83,69,67,72,65,78,78,69,76,0 intern L4553 L4554: 4 byte(7)42,68,69,70,78,0 intern L4554 L4555: 10 byte(7)66,82,69,65,75,86,65,76,85,69,42,0 intern L4555 L4556: 9 byte(7)42,81,85,73,84,66,82,69,65,75,0 intern L4556 L4557: 7 byte(7)66,82,69,65,75,73,78,42,0 intern L4557 L4558: 8 byte(7)66,82,69,65,75,79,85,84,42,0 intern L4558 L4559: 11 byte(7)84,79,80,76,79,79,80,78,65,77,69,42,0 intern L4559 L4560: 11 byte(7)84,79,80,76,79,79,80,69,86,65,76,42,0 intern L4560 L4561: 9 byte(7)66,82,69,65,75,69,86,65,76,42,0 intern L4561 L4562: 9 byte(7)66,82,69,65,75,78,65,77,69,42,0 intern L4562 L4563: 12 byte(7)84,79,80,76,79,79,80,80,82,73,78,84,42,0 intern L4563 L4564: 11 byte(7)84,79,80,76,79,79,80,82,69,65,68,42,0 intern L4564 L4565: 6 byte(7)84,79,80,76,79,79,80,0 intern L4565 L4566: 6 byte(7)36,66,82,69,65,75,36,0 intern L4566 L4567: 8 byte(7)66,82,69,65,75,69,86,65,76,0 intern L4567 L4568: 12 byte(7)66,82,69,65,75,70,85,78,67,84,73,79,78,0 intern L4568 L4569: 8 byte(7)66,82,69,65,75,81,85,73,84,0 intern L4569 L4570: 12 byte(7)66,82,69,65,75,67,79,78,84,73,78,85,69,0 intern L4570 L4571: 9 byte(7)66,82,69,65,75,82,69,84,82,89,0 intern L4571 L4572: 8 byte(7)72,69,76,80,66,82,69,65,75,0 intern L4572 L4573: 10 byte(7)66,82,69,65,75,69,82,82,77,83,71,0 intern L4573 L4574: 8 byte(7)66,82,69,65,75,69,68,73,84,0 intern L4574 L4575: 12 byte(7)84,79,80,76,79,79,80,76,69,86,69,76,42,0 intern L4575 L4576: 12 byte(7)72,73,83,84,79,82,89,67,79,85,78,84,42,0 intern L4576 L4577: 10 byte(7)76,73,83,80,66,65,78,78,69,82,42,0 intern L4577 L4578: 6 byte(7)42,79,85,84,80,85,84,0 intern L4578 L4579: 5 byte(7)83,69,77,73,67,42,0 intern L4579 L4580: 11 byte(7)72,73,83,84,79,82,89,76,73,83,84,42,0 intern L4580 L4581: 4 byte(7)42,84,73,77,69,0 intern L4581 L4582: 3 byte(7)84,73,77,69,0 intern L4582 L4583: 5 byte(7)42,78,79,78,73,76,0 intern L4583 L4584: 12 byte(7)36,69,88,73,84,84,79,80,76,79,79,80,36,0 intern L4584 L4585: 7 byte(7)68,70,80,82,73,78,84,42,0 intern L4585 L4586: 5 byte(7)73,71,78,79,82,69,0 intern L4586 L4587: 2 byte(7)73,78,80,0 intern L4587 L4588: 3 byte(7)82,69,68,79,0 intern L4588 L4589: 2 byte(7)65,78,83,0 intern L4589 L4590: 3 byte(7)72,73,83,84,0 intern L4590 L4591: 4 byte(7)67,76,69,65,82,0 intern L4591 L4592: 11 byte(7)83,84,65,78,68,65,82,68,76,73,83,80,0 intern L4592 L4593: 17 byte(7)80,82,73,78,84,87,73,84,72,70,82,69,83,72,76,73,78,69,0 intern L4593 L4594: 9 byte(7)83,65,86,69,83,89,83,84,69,77,0 intern L4594 L4595: 9 byte(7)73,78,73,84,70,79,82,77,83,42,0 intern L4595 L4596: 12 byte(7)69,86,65,76,73,78,73,84,70,79,82,77,83,0 intern L4596 L4597: 4 byte(7)68,83,75,73,78,0 intern L4597 L4598: 8 byte(7)68,83,75,73,78,69,86,65,76,0 intern L4598 L4599: 4 byte(7)76,65,80,73,78,0 intern L4599 L4600: 4 byte(7)77,65,73,78,46,0 intern L4600 L4601: 7 byte(7)80,82,69,45,77,65,73,78,0 intern L4601 L4602: 3 byte(7)77,65,73,78,0 intern L4602 L4603: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L4603 L4604: 2 byte(7)69,79,70,0 intern L4604 L4605: 8 byte(7)67,72,65,82,67,79,78,83,84,0 intern L4605 L4606: 4 byte(7)68,69,67,50,48,0 intern L4606 L4607: 4 byte(7)80,68,80,49,48,0 intern L4607 L4608: 5 byte(7)84,79,80,83,50,48,0 intern L4608 L4609: 3 byte(7)75,76,49,48,0 intern L4609 L4610: 12 byte(7)76,73,83,80,68,73,80,72,84,72,79,78,71,0 intern L4610 extern SYMFNC extern L0001 end MAIN. |
Added psl-1983/3-1/kernel/20/main.rel version [1e845eeea1].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/mini-trace.red version [3cc15c79a2].
> > | 1 2 | PathIn "autoload-trace.red"$ END; |
Added psl-1983/3-1/kernel/20/nil.mac version [f8ac16eccd].
> > > > > | 1 2 3 4 5 | radix 10 loc 128 <30_30>+128 <30_30>+128 end |
Added psl-1983/3-1/kernel/20/nil.rel version [38c887dfd8].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/prop.ctl version [13d6332521].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "prop"; PathIn "prop.build"; ASMEnd; quit; compile prop.mac, dprop.mac |
Added psl-1983/3-1/kernel/20/prop.init version [8caa9913cb].
> > | 1 2 | (FLUID (QUOTE (!*REDEFMSG !*USERMODE))) (FLUID (QUOTE (!*COMP PROMPTSTRING!*))) |
Added psl-1983/3-1/kernel/20/prop.log version [87cf62066b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:47:15 BATCON Version 104(4133) GLXLIB Version 1(527) Job PROP Req #485 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1742 Input from => PS:<PSL.KERNEL.20.EXT>PROP.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>PROP.LOG 9:47:16 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:47:16 MONTR @SET TIME-LIMIT 600 9:47:16 MONTR @LOGIN KESSLER SMALL 9:47:19 MONTR Job 12 on TTY224 8-Jun-83 09:47:19 9:47:19 MONTR Previous login at 8-Jun-83 09:44:40 9:47:20 MONTR There is 1 other job logged in as user KESSLER 9:47:27 MONTR @ 9:47:27 MONTR [PS Mounted] 9:47:27 MONTR 9:47:27 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:47:27 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:47:28 MONTR @S:EX-DEC20-CROSS.EXE 9:47:30 USER [45] ASMOut "prop"; 9:47:31 USER ASMOUT: IN files; or type in expressions 9:47:31 USER When all done execute ASMEND; 9:47:34 USER [46] PathIn "prop.build"; 9:47:34 USER % 9:47:34 USER % PROP.BUILD - Files with functions for property lists and function definition 9:47:34 USER % 9:47:34 USER % Author: Eric Benson 9:47:34 USER % Symbolic Computation Group 9:47:34 USER % Computer Science Dept. 9:47:34 USER % University of Utah 9:47:34 USER % Date: 19 May 1982 9:47:34 USER % Copyright (c) 1982 University of Utah 9:47:35 USER % 9:47:35 USER 9:47:35 USER PathIn "function-primitives.red"$ % used by PutD, GetD and Eval 9:47:41 USER PathIn "property-list.red"$ % PUT and FLAG and friends 9:47:51 USER PathIn "fluid-global.red"$ % variable declarations 9:47:54 USER PathIn "putd-getd.red"$ % function defining functions 9:48:05 USER [47] ASMEnd; 9:48:06 USER *** Garbage collection starting 9:48:11 USER *** GC 19: time 2795 ms, 118806 recovered, 230743 free 9:48:21 USER 0 9:48:21 USER [48] quit; 9:48:21 MONTR @compile prop.mac, dprop.mac 9:48:24 USER MACRO: .MAIN 9:48:31 USER MACRO: .MAIN 9:48:32 USER 9:48:32 USER EXIT 9:48:32 MONTR @ 9:48:33 MONTR Killed by OPERATOR, TTY 221 9:48:33 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:48:33 MONTR at 8-Jun-83 09:48:33, Used 0:00:37 in 0:01:13 |
Added psl-1983/3-1/kernel/20/prop.mac version [492be3e70a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern UNDEFN extern LAMLNK 1 ; (!*ENTRY FUNBOUNDP EXPR 1) L3144: intern L3144 LDB 11,L3142 CAIE 11,30 JRST L3145 MOVE 2,1 TLZ 2,258048 MOVE 3,SYMFNC(2) MOVE 1,SYMVAL+84 CAMN 3,UNDEFN JRST L3146 MOVE 1,0 POPJ 15,0 L3145: MOVE 2,L3143 JRST SYMFNC+130 L3146: POPJ 15,0 L3142: point 6,1,5 L3143: <30_30>+519 1 ; (!*ENTRY FLAMBDALINKP EXPR 1) L3149: intern L3149 LDB 11,L3147 CAIE 11,30 JRST L3150 MOVE 2,1 TLZ 2,258048 MOVE 3,SYMFNC(2) MOVE 1,SYMVAL+84 CAMN 3,LAMLNK JRST L3151 MOVE 1,0 POPJ 15,0 L3150: MOVE 2,L3148 JRST SYMFNC+130 L3151: POPJ 15,0 L3147: point 6,1,5 L3148: <30_30>+752 1 ; (!*ENTRY FCODEP EXPR 1) FCODEP: intern FCODEP LDB 11,L3152 CAIE 11,30 JRST L3154 MOVE 2,1 TLZ 2,258048 MOVE 3,SYMFNC(2) MOVE 1,SYMVAL+84 CAME 3,UNDEFN JRST L3155 MOVE 1,0 L3155: CAMN 1,0 JRST L3156 MOVE 1,SYMFNC(2) CAME 1,LAMLNK JRST L3157 MOVE 1,0 POPJ 15,0 L3157: MOVE 1,SYMVAL+84 POPJ 15,0 L3154: MOVE 2,L3153 JRST SYMFNC+130 L3156: POPJ 15,0 L3152: point 6,1,5 L3153: <30_30>+520 1 ; (!*ENTRY MAKEFUNBOUND EXPR 1) L3160: intern L3160 LDB 11,L3158 CAIE 11,30 JRST L3161 MOVE 3,1 TLZ 3,258048 MOVE 6,UNDEFN MOVEM 6,SYMFNC(3) MOVE 1,0 POPJ 15,0 L3161: MOVE 2,L3159 JRST SYMFNC+130 L3158: point 6,1,5 L3159: <30_30>+753 1 ; (!*ENTRY MAKEFLAMBDALINK EXPR 1) L3164: intern L3164 LDB 11,L3162 CAIE 11,30 JRST L3165 MOVE 3,1 TLZ 3,258048 MOVE 6,LAMLNK MOVEM 6,SYMFNC(3) MOVE 1,0 POPJ 15,0 L3165: MOVE 2,L3163 JRST SYMFNC+130 L3162: point 6,1,5 L3163: <30_30>+754 2 ; (!*ENTRY MAKEFCODE EXPR 2) L3169: intern L3169 LDB 11,L3166 CAIE 11,30 JRST L3170 LDB 11,L3167 CAIE 11,15 JRST L3171 MOVE 4,1 TLZ 4,258048 HRRZ 3,2 ADD 3,[23085449216] MOVEM 3,SYMFNC(4) JRST L3170 L3171: MOVE 2,L3168 JRST SYMFNC+130 L3170: MOVE 1,0 POPJ 15,0 L3166: point 6,1,5 L3167: point 6,2,5 L3168: <30_30>+755 1 ; (!*ENTRY GETFCODEPOINTER EXPR 1) L3174: intern L3174 LDB 11,L3172 CAIE 11,30 JRST L3175 MOVE 2,1 TLZ 2,258048 MOVE 1,SYMFNC(2) TLZ 1,262080 TLZ 1,258048 TLO 1,61440 POPJ 15,0 L3175: MOVE 2,L3173 JRST SYMFNC+130 L3172: point 6,1,5 L3173: <30_30>+521 1 ; (!*ENTRY PROP EXPR 1) PROP: intern PROP LDB 11,L3176 CAIE 11,30 JRST L3178 TLZ 1,258048 MOVE 1,SYMPRP(1) POPJ 15,0 L3178: MOVE 2,L3177 JRST SYMFNC+130 L3176: point 6,1,5 L3177: <30_30>+756 2 ; (!*ENTRY SETPROP EXPR 2) L3181: intern L3181 LDB 11,L3179 CAIE 11,30 JRST L3182 MOVE 3,1 TLZ 3,258048 MOVE 1,2 MOVEM 1,SYMPRP(3) POPJ 15,0 L3182: MOVE 2,L3180 JRST SYMFNC+130 L3179: point 6,1,5 L3180: <30_30>+757 2 ; (!*ENTRY FLAGP EXPR 2) FLAGP: intern FLAGP ADJSP 15,3 MOVEM 1,-2(15) MOVEM 2,-1(15) LDB 11,L3183 CAIE 11,30 JRST L3185 LDB 11,L3184 CAIN 11,30 JRST L3186 L3185: MOVE 1,0 JRST L3187 L3186: MOVEM 0,0(15) MOVE 5,0 MOVE 4,1 TLZ 4,258048 MOVE 6,SYMPRP(4) MOVEM 6,0(15) CAME 0,0(15) JRST L3188 MOVE 1,0 JRST L3187 L3188: MOVE 7,0(15) CAME 2,0(7) JRST L3189 MOVE 1,SYMVAL+84 JRST L3187 L3189: MOVE 5,0(15) MOVE 3,0(15) MOVE 3,1(3) MOVEM 3,0(15) L3190: CAME 0,0(15) JRST L3191 MOVE 1,0 JRST L3187 L3191: MOVE 7,0(15) MOVE 6,-1(15) CAME 6,0(7) JRST L3192 MOVE 7,0(15) MOVE 6,0(5) MOVEM 6,0(7) MOVE 6,-1(15) MOVEM 6,0(5) MOVE 1,SYMVAL+84 JRST L3187 L3192: MOVE 5,0(15) MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L3190 L3187: ADJSP 15,-3 POPJ 15,0 L3183: point 6,1,5 L3184: point 6,2,5 1 ; (!*ENTRY GETFNTYPE EXPR 1) L3194: intern L3194 MOVE 2,L3193 JRST GET L3193: <30_30>+759 2 ; (!*ENTRY GET EXPR 2) GET: intern GET ADJSP 15,5 MOVEM 1,-4(15) MOVEM 2,-3(15) LDB 11,L3195 CAIE 11,30 JRST L3198 LDB 11,L3196 CAIN 11,30 JRST L3199 L3198: MOVE 1,0 JRST L3200 L3199: MOVEM 0,-2(15) MOVEM 0,-1(15) MOVEM 0,0(15) MOVE 4,1 TLZ 4,258048 MOVE 6,SYMPRP(4) MOVEM 6,-2(15) CAME 0,-2(15) JRST L3201 MOVE 1,0 JRST L3200 L3201: MOVE 3,-2(15) MOVE 3,0(3) MOVEM 3,-1(15) LDB 11,L3197 CAIE 11,9 JRST L3202 CAME 2,0(3) JRST L3202 MOVE 1,1(3) JRST L3200 L3202: MOVE 6,-2(15) MOVEM 6,0(15) MOVE 5,-2(15) MOVE 5,1(5) MOVEM 5,-2(15) L3203: CAME 0,-2(15) JRST L3204 MOVE 1,0 JRST L3200 L3204: MOVE 1,-2(15) MOVE 1,0(1) MOVEM 1,-1(15) LDB 11,L3195 CAIE 11,9 JRST L3205 MOVE 6,-3(15) CAME 6,0(1) JRST L3205 MOVE 7,-2(15) MOVE 6,0(15) MOVE 6,0(6) MOVEM 6,0(7) MOVE 7,0(15) MOVEM 1,0(7) MOVE 1,1(1) JRST L3200 L3205: MOVE 6,-2(15) MOVEM 6,0(15) MOVE 2,-2(15) MOVE 2,1(2) MOVEM 2,-2(15) JRST L3203 L3200: ADJSP 15,-5 POPJ 15,0 L3195: point 6,1,5 L3196: point 6,2,5 L3197: point 6,3,5 2 ; (!*ENTRY FLAG EXPR 2) FLAG: intern FLAG ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L3206 CAIN 11,30 JRST L3209 MOVE 2,L3207 MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+130 L3209: MOVEM 0,-2(15) MOVEM 1,-2(15) L3210: LDB 11,L3208 CAIN 11,9 JRST L3211 MOVE 1,0 JRST L3212 L3211: MOVE 1,-2(15) MOVE 1,0(1) MOVEM 1,-3(15) MOVE 2,-1(15) PUSHJ 15,SYMFNC+761 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) JRST L3210 L3212: ADJSP 15,-4 POPJ 15,0 L3206: point 6,2,5 L3208: point 6,-2(15),5 L3207: <30_30>+760 2 ; (!*ENTRY FLAG1 EXPR 2) FLAG1: intern FLAG1 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L3213 CAIN 11,30 JRST L3215 MOVE 2,L3214 ADJSP 15,-3 JRST SYMFNC+130 L3215: MOVEM 0,-2(15) PUSHJ 15,SYMFNC+756 MOVEM 1,-2(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L3216 MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+757 L3216: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L3213: point 6,1,5 L3214: <30_30>+760 2 ; (!*ENTRY REMFLAG EXPR 2) L3220: intern L3220 ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L3217 CAIN 11,30 JRST L3221 MOVE 2,L3218 MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+130 L3221: MOVEM 0,-2(15) MOVEM 1,-2(15) L3222: LDB 11,L3219 CAIN 11,9 JRST L3223 MOVE 1,0 JRST L3224 L3223: MOVE 1,-2(15) MOVE 1,0(1) MOVEM 1,-3(15) MOVE 2,-1(15) PUSHJ 15,SYMFNC+763 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) JRST L3222 L3224: ADJSP 15,-4 POPJ 15,0 L3217: point 6,2,5 L3219: point 6,-2(15),5 L3218: <30_30>+762 2 ; (!*ENTRY REMFLAG1 EXPR 2) L3227: intern L3227 PUSH 15,2 PUSH 15,1 LDB 11,L3225 CAIN 11,30 JRST L3228 MOVE 2,L3226 ADJSP 15,-2 JRST SYMFNC+130 L3228: PUSHJ 15,SYMFNC+756 MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+334 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+757 L3225: point 6,1,5 L3226: <30_30>+762 3 ; (!*ENTRY PUT EXPR 3) PUT: intern PUT ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L3229 CAIN 11,30 JRST L3232 MOVE 2,L3230 ADJSP 15,-5 JRST SYMFNC+130 L3232: LDB 11,L3231 CAIN 11,30 JRST L3233 MOVE 2,L3230 MOVE 1,-1(15) ADJSP 15,-5 JRST SYMFNC+130 L3233: MOVEM 0,-3(15) MOVEM 0,-4(15) PUSHJ 15,SYMFNC+756 MOVEM 1,-3(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+335 MOVE 2,1 MOVEM 2,-4(15) CAME 2,0 JRST L3234 MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+151 MOVE 2,-3(15) PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+757 JRST L3235 L3234: MOVE 6,-2(15) MOVEM 6,1(2) L3235: MOVE 1,-2(15) ADJSP 15,-5 POPJ 15,0 L3229: point 6,1,5 L3231: point 6,2,5 L3230: <30_30>+300 2 ; (!*ENTRY REMPROP EXPR 2) L3238: intern L3238 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L3236 CAIE 11,30 JRST L3239 LDB 11,L3237 CAIN 11,30 JRST L3240 L3239: MOVE 1,0 JRST L3241 L3240: MOVEM 0,-2(15) PUSHJ 15,SYMFNC+522 MOVE 3,1 MOVEM 3,-2(15) CAMN 3,0 JRST L3242 MOVE 1,0(15) PUSHJ 15,SYMFNC+756 MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+342 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+757 L3242: MOVE 1,-2(15) L3241: ADJSP 15,-3 POPJ 15,0 L3236: point 6,1,5 L3237: point 6,2,5 2 ; (!*ENTRY REMPROPL EXPR 2) L3244: intern L3244 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 1,-2(15) L3245: LDB 11,L3243 CAIN 11,9 JRST L3246 MOVE 1,0 JRST L3247 L3246: MOVE 1,-2(15) MOVE 1,0(1) MOVE 2,-1(15) PUSHJ 15,SYMFNC+764 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) JRST L3245 L3247: ADJSP 15,-3 POPJ 15,0 L3243: point 6,-2(15),5 ; (!*ENTRY DECLAREFLUIDORGLOBAL EXPR 2) L3249: intern L3249 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 1,-2(15) L3250: LDB 11,L3248 CAIN 11,9 JRST L3251 MOVE 1,0 JRST L3252 L3251: MOVE 1,-2(15) MOVE 1,0(1) MOVE 2,-1(15) PUSHJ 15,L3253 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,-2(15) JRST L3250 L3252: ADJSP 15,-3 POPJ 15,0 L3248: point 6,-2(15),5 L3257: 25 byte(7)42,42,42,32,37,112,32,37,114,32,99,97,110,110,111,116,32,98,101,99,111,109,101,32,37,112,0 ; (!*ENTRY DECLAREFLUIDORGLOBAL1 EXPR 2) L3253: intern L3253 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L3254 CAIN 11,30 JRST L3258 MOVE 1,0 JRST L3259 L3258: MOVEM 0,-2(15) MOVE 2,L3255 PUSHJ 15,SYMFNC+522 MOVEM 1,-2(15) CAME 1,0 JRST L3260 MOVE 3,-1(15) MOVE 2,L3255 MOVE 1,0(15) PUSHJ 15,SYMFNC+300 MOVE 1,0(15) PUSHJ 15,SYMFNC+766 CAMN 1,0 JRST L3261 MOVE 2,0 MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+262 L3261: MOVE 1,0 JRST L3259 L3260: CAME 1,-1(15) JRST L3262 MOVE 1,0 JRST L3259 L3262: MOVE 4,-1(15) MOVE 3,0(15) MOVE 2,1 MOVE 1,L3256 ADJSP 15,-3 JRST SYMFNC+418 L3259: ADJSP 15,-3 POPJ 15,0 L3254: point 6,1,5 L3256: <4_30>+<1_18>+L3257 L3255: <30_30>+767 1 ; (!*ENTRY FLUID EXPR 1) FLUID: intern FLUID MOVE 2,L3263 JRST L3249 L3263: <30_30>+768 1 ; (!*ENTRY FLUID1 EXPR 1) FLUID1: intern FLUID1 MOVE 2,L3264 JRST L3253 L3264: <30_30>+768 1 ; (!*ENTRY FLUIDP EXPR 1) FLUIDP: intern FLUIDP MOVE 2,L3265 PUSHJ 15,SYMFNC+522 CAMN 1,L3266 JRST L3267 MOVE 1,0 POPJ 15,0 L3267: MOVE 1,SYMVAL+84 POPJ 15,0 L3266: <30_30>+768 L3265: <30_30>+767 1 ; (!*ENTRY GLOBAL EXPR 1) GLOBAL: intern GLOBAL MOVE 2,L3268 JRST L3249 L3268: <30_30>+654 1 ; (!*ENTRY GLOBAL1 EXPR 1) L3270: intern L3270 MOVE 2,L3269 JRST L3253 L3269: <30_30>+654 1 ; (!*ENTRY GLOBALP EXPR 1) L3273: intern L3273 MOVE 2,L3271 PUSHJ 15,SYMFNC+522 CAMN 1,L3272 JRST L3274 MOVE 1,0 POPJ 15,0 L3274: MOVE 1,SYMVAL+84 POPJ 15,0 L3272: <30_30>+654 L3271: <30_30>+767 1 ; (!*ENTRY UNFLUID EXPR 1) L3276: intern L3276 PUSH 15,1 PUSH 15,1 L3277: LDB 11,L3275 CAIN 11,9 JRST L3278 MOVE 1,0 JRST L3279 L3278: MOVE 1,-1(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+774 MOVE 1,-1(15) MOVE 1,1(1) MOVEM 1,-1(15) JRST L3277 L3279: ADJSP 15,-2 POPJ 15,0 L3275: point 6,-1(15),5 1 ; (!*ENTRY UNFLUID1 EXPR 1) L3281: intern L3281 PUSH 15,1 PUSHJ 15,SYMFNC+770 CAMN 1,0 JRST L3282 MOVE 2,L3280 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+764 L3282: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L3280: <30_30>+767 1 ; (!*ENTRY GETD EXPR 1) GETD: intern GETD ADJSP 15,2 MOVEM 1,0(15) LDB 11,L3283 CAIN 11,30 JRST L3287 MOVE 1,0 JRST L3288 L3287: MOVE 1,SYMVAL+84 L3288: CAMN 1,0 JRST L3289 MOVE 1,0(15) PUSHJ 15,SYMFNC+519 CAMN 1,0 JRST L3290 MOVE 1,0 JRST L3291 L3290: MOVE 1,SYMVAL+84 L3291: CAMN 1,0 JRST L3289 MOVE 2,L3284 MOVE 1,0(15) PUSHJ 15,SYMFNC+522 CAME 1,0 JRST L3292 MOVE 1,L3285 L3292: MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+752 CAMN 1,0 JRST L3293 MOVE 2,L3286 MOVE 1,0(15) PUSHJ 15,SYMFNC+522 JRST L3294 L3293: MOVE 1,0(15) PUSHJ 15,SYMFNC+521 L3294: MOVE 2,-1(15) ADJSP 15,-2 JRST SYMFNC+278 L3289: ADJSP 15,-2 POPJ 15,0 L3283: point 6,1,5 L3286: <30_30>+515 L3285: <30_30>+247 L3284: <30_30>+759 1 ; (!*ENTRY REMD EXPR 1) REMD: intern REMD ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+318 MOVE 2,1 MOVEM 2,-1(15) CAMN 2,0 JRST L3297 MOVE 1,0(15) PUSHJ 15,SYMFNC+753 MOVE 2,L3295 MOVE 1,0(15) PUSHJ 15,SYMFNC+764 MOVE 2,L3296 MOVE 1,0(15) PUSHJ 15,SYMFNC+764 L3297: MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L3296: <30_30>+515 L3295: <30_30>+759 L3313: 33 byte(7)42,42,42,32,70,117,110,99,116,105,111,110,32,37,114,32,104,97,115,32,98,101,101,110,32,114,101,100,101,102,105,110,101,100,0 L3314: 37 byte(7)73,108,108,45,102,111,114,109,101,100,32,102,117,110,99,116,105,111,110,32,101,120,112,114,101,115,115,105,111,110,32,105,110,32,80,117,116,68,0 L3315: 53 byte(7)68,111,32,121,111,117,32,114,101,97,108,108,121,32,119,97,110,116,32,116,111,32,114,101,100,101,102,105,110,101,32,116,104,101,32,115,121,115,116,101,109,32,102,117,110,99,116,105,111,110,32,37,114,63,0 L3316: 54 byte(7)42,42,42,32,37,114,32,104,97,115,32,110,111,116,32,98,101,101,110,32,100,101,102,105,110,101,100,44,32,98,101,99,97,117,115,101,32,105,116,32,105,115,32,102,108,97,103,103,101,100,32,76,79,83,69,0 L3317: 30 byte(7)37,114,32,105,115,32,110,111,116,32,97,32,108,101,103,97,108,32,102,117,110,99,116,105,111,110,32,116,121,112,101,0 L3318: <30_30>+247 <9_30>+<1_18>+L3319 L3319: <30_30>+254 <9_30>+<1_18>+L3320 L3320: <30_30>+256 <9_30>+<1_18>+L3321 L3321: <30_30>+258 <30_30>+128 3 ; (!*ENTRY PUTD EXPR 3) PUTD: intern PUTD ADJSP 15,9 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L3298 CAIN 11,30 JRST L3322 MOVE 2,L3299 PUSHJ 15,SYMFNC+130 JRST L3323 L3322: MOVE 2,L3300 MOVE 1,-1(15) PUSHJ 15,SYMFNC+303 CAME 1,0 JRST L3324 MOVE 2,-1(15) MOVE 1,L3301 PUSHJ 15,SYMFNC+155 MOVEM 1,-3(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-4(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-5(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+234 MOVE 4,1 MOVE 3,-5(15) MOVE 2,-4(15) MOVE 1,L3299 PUSHJ 15,SYMFNC+250 MOVE 3,1 MOVE 2,-3(15) HRRZI 1,1305 PUSHJ 15,SYMFNC+236 JRST L3323 L3324: MOVE 2,L3302 MOVE 1,0(15) PUSHJ 15,SYMFNC+758 CAMN 1,0 JRST L3325 MOVE 2,0(15) MOVE 1,L3303 PUSHJ 15,SYMFNC+418 MOVE 1,0 JRST L3323 L3325: MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 0,-5(15) MOVEM 0,-6(15) JSP 10,SYMFNC+443 byte(18)0,442 MOVE 1,0(15) PUSHJ 15,SYMFNC+519 CAME 1,0 JRST L3326 CAMN 0,SYMVAL+571 JRST L3327 MOVE 6,SYMVAL+84 MOVEM 6,-4(15) L3327: CAMN 0,SYMVAL+570 JRST L3326 MOVE 2,L3304 MOVE 1,0(15) PUSHJ 15,SYMFNC+758 CAME 1,0 JRST L3326 MOVE 2,0(15) MOVE 1,L3305 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+441 CAME 1,0 JRST L3328 MOVE 1,0 JRST L3329 L3328: MOVE 2,L3304 MOVE 1,0(15) PUSHJ 15,SYMFNC+761 L3326: LDB 11,L3306 CAIE 11,15 JRST L3330 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+755 MOVE 2,L3307 MOVE 1,0(15) PUSHJ 15,SYMFNC+764 JRST L3331 L3330: LDB 11,L3306 CAIE 11,30 JRST L3332 MOVE 1,-2(15) PUSHJ 15,SYMFNC+519 CAME 1,0 JRST L3332 MOVE 1,-2(15) PUSHJ 15,SYMFNC+318 MOVE 3,1(1) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,PUTD JRST L3329 L3332: CAMN 0,SYMVAL+776 JRST L3333 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+586 JRST L3329 L3333: MOVE 1,-2(15) MOVEM 1,-7(15) LDB 11,L3298 CAIN 11,9 JRST L3334 MOVE 1,0 JRST L3335 L3334: MOVE 1,SYMVAL+84 L3335: CAMN 1,0 JRST L3336 MOVE 1,-7(15) MOVE 1,0(1) CAMN 1,L3308 JRST L3337 MOVE 1,0 JRST L3336 L3337: MOVE 1,SYMVAL+84 L3336: CAMN 1,0 JRST L3338 MOVE 3,-2(15) MOVE 2,L3307 MOVE 1,0(15) PUSHJ 15,SYMFNC+300 MOVE 1,0(15) PUSHJ 15,SYMFNC+754 JRST L3331 L3338: MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-7(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-8(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+234 MOVE 4,1 MOVE 3,-8(15) MOVE 2,-7(15) MOVE 1,L3299 PUSHJ 15,SYMFNC+250 MOVE 3,1 MOVE 2,L3309 HRRZI 1,1105 PUSHJ 15,SYMFNC+236 JRST L3329 L3331: MOVE 6,-1(15) CAMN 6,L3310 JRST L3339 MOVE 3,-1(15) MOVE 2,L3311 MOVE 1,0(15) PUSHJ 15,SYMFNC+300 JRST L3340 L3339: MOVE 2,L3311 MOVE 1,0(15) PUSHJ 15,SYMFNC+764 L3340: CAMN 0,SYMVAL+570 JRST L3341 MOVE 2,L3304 MOVE 1,0(15) PUSHJ 15,SYMFNC+761 JRST L3342 L3341: MOVE 2,L3304 MOVE 1,0(15) PUSHJ 15,SYMFNC+763 L3342: CAMN 0,-4(15) JRST L3343 MOVE 2,0(15) MOVE 1,L3312 PUSHJ 15,SYMFNC+418 L3343: MOVE 1,0(15) L3329: JSP 10,SYMFNC+447 1 L3323: ADJSP 15,-9 POPJ 15,0 L3298: point 6,1,5 L3306: point 6,-2(15),5 L3312: <4_30>+<1_18>+L3313 L3311: <30_30>+759 L3310: <30_30>+247 L3309: <4_30>+<1_18>+L3314 L3308: <30_30>+253 L3307: <30_30>+515 L3305: <4_30>+<1_18>+L3315 L3304: <30_30>+777 L3303: <4_30>+<1_18>+L3316 L3302: <30_30>+778 L3301: <4_30>+<1_18>+L3317 L3300: <9_30>+<1_18>+L3318 L3299: <30_30>+251 1 ; (!*ENTRY CODE!-NUMBER!-OF!-ARGUMENTS EXPR 1) L3345: intern L3345 MOVE 5,1 MOVE 4,0 LDB 11,L3344 CAIE 11,15 JRST L3346 MOVE 3,1 TLZ 3,258048 MOVE 4,-1(3) JUMPL 4,L3347 CAILE 4,15 JRST L3347 MOVE 1,4 POPJ 15,0 L3347: MOVE 1,0 POPJ 15,0 L3346: MOVE 1,0 POPJ 15,0 L3344: point 6,1,5 end |
Added psl-1983/3-1/kernel/20/prop.rel version [711524abca].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/psl-link.ctl version [7d532bcb9f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in p2e:20-KERNEL-GEN.SL. def p2e: p20e:,dmp: cd S: LINK /map p2e:nil.rel /set:.low.:202 p2e:types.rel p2e:randm.rel p2e:alloc.rel p2e:arith.rel p2e:debg.rel p2e:error.rel p2e:eval.rel p2e:extra.rel p2e:fasl.rel p2e:io.rel p2e:macro.rel p2e:prop.rel p2e:symbl.rel p2e:sysio.rel p2e:tloop.rel p2e:main.rel p2e:heap.rel p2e:dtypes.rel p2e:drandm.rel p2e:dalloc.rel p2e:darith.rel p2e:ddebg.rel p2e:derror.rel p2e:deval.rel p2e:dextra.rel p2e:dfasl.rel p2e:dio.rel p2e:dmacro.rel p2e:dprop.rel p2e:dsymbl.rel p2e:dsysio.rel p2e:dtloop.rel p2e:dmain.rel p2e:dheap.rel /save s:pbpsl.exe /go @get s:pbpsl.exe/u 1 @save s:bpsl.exe |
Added psl-1983/3-1/kernel/20/psl-link.log version [2efe59a9bd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20.EXT>PSL-LINK.CTL.9 started at 15-Jun-83 13:01:38] TOPS-20 Command processor 5(712)-1 @;Modifications to this file may disappear, as this file is generated ;automatically using information in p2e:20-KERNEL-GEN.SL. def p2e: p20e:,dmp: @cd S: @LINK */map *p2e:nil.rel */set:.low.:202 *p2e:types.rel *p2e:randm.rel *p2e:alloc.rel *p2e:arith.rel *p2e:debg.rel *p2e:error.rel *p2e:eval.rel *p2e:extra.rel *p2e:fasl.rel *p2e:io.rel *p2e:macro.rel *p2e:prop.rel %LNKMDS Multiply-defined global symbol GET Detected in module .MAIN from file P2E:PROP.REL Defined value = 41052, this value = 104000000200 *p2e:symbl.rel *p2e:sysio.rel *p2e:tloop.rel *p2e:main.rel *p2e:heap.rel *p2e:dtypes.rel *p2e:drandm.rel *p2e:dalloc.rel *p2e:darith.rel *p2e:ddebg.rel *p2e:derror.rel *p2e:deval.rel *p2e:dextra.rel *p2e:dfasl.rel *p2e:dio.rel *p2e:dmacro.rel *p2e:dprop.rel *p2e:dsymbl.rel *p2e:dsysio.rel *p2e:dtloop.rel *p2e:dmain.rel *p2e:dheap.rel */save s:prebpsl.exe */go @get s:prebpsl.exe/u 1 ?File not found - "s:prebpsl.exe" @ [DO: End of control file while searching for %ERR::] [DO: Execution aborted at 15-Jun-83 13:03:43] |
Added psl-1983/3-1/kernel/20/psl.init version [d06c73fc9e].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | (lapin "types.init") (lapin "randm.init") (lapin "alloc.init") (lapin "arith.init") (lapin "debg.init") (lapin "error.init") (lapin "eval.init") (lapin "extra.init") (lapin "fasl.init") (lapin "io.init") (lapin "macro.init") (lapin "prop.init") (lapin "symbl.init") (lapin "sysio.init") (lapin "tloop.init") (lapin "main.init") (lapin "heap.init") |
Added psl-1983/3-1/kernel/20/randm.ctl version [b42df8498c].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "randm"; PathIn "randm.build"; ASMEnd; quit; compile randm.mac, drandm.mac |
Added psl-1983/3-1/kernel/20/randm.init version [d73c12c5d1].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | (PUT (QUOTE LIST) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DE) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DF) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DM) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DN) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE SETQ) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE AND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE OR) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE COND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE MAX) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE MIN) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE PLUS) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE TIMES) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE FUNCTION) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE FIRST) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE SECOND) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE THIRD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE FOURTH) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE REST) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/3-1/kernel/20/randm.log version [0dfb404f5a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 8-Jun-83 9:29:14 BATCON Version 104(4133) GLXLIB Version 1(527) Job RANDM Req #475 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:10:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 1732 Input from => PS:<PSL.KERNEL.20.EXT>RANDM.CTL.3 Output to => PS:<PSL.KERNEL.20.EXT>RANDM.LOG 9:29:14 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 9:29:14 MONTR @SET TIME-LIMIT 600 9:29:14 MONTR @LOGIN KESSLER SMALL 9:29:18 MONTR Job 12 on TTY224 8-Jun-83 09:29:18 9:29:18 MONTR Previous login at 8-Jun-83 09:27:22 9:29:18 MONTR There is 1 other job logged in as user KESSLER 9:29:25 MONTR @ 9:29:25 MONTR [PS Mounted] 9:29:25 MONTR 9:29:25 MONTR [CONNECTED TO PS:<PSL.KERNEL.20.EXT>] ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. 9:29:25 MONTR def dsk: dsk:,p20e:,pk:,p20: 9:29:27 MONTR @S:EX-DEC20-CROSS.EXE 9:29:28 USER [14] ASMOut "randm"; 9:29:29 USER ASMOUT: IN files; or type in expressions 9:29:29 USER When all done execute ASMEND; 9:29:32 USER [15] PathIn "randm.build"; 9:29:32 USER % 9:29:32 USER % RANDM.BUILD - Miscellaneous interpreter files 9:29:32 USER % 9:29:32 USER % Author: Eric Benson 9:29:32 USER % Symbolic Computation Group 9:29:32 USER % Computer Science Dept. 9:29:32 USER % University of Utah 9:29:32 USER % Date: 19 May 1982 9:29:32 USER % Copyright (c) 1982 University of Utah 9:29:32 USER % 9:29:32 USER 9:29:32 USER PathIn "known-to-comp-sl.red"$ % SL functions performed inline in code 9:29:37 USER PathIn "others-sl.red"$ % DIGIT, LITER and LENGTH 9:29:46 USER PathIn "equal.red"$ % equality predicates 9:30:00 USER PathIn "carcdr.red"$ % CDDDDR, etc. 9:30:13 USER PathIn "easy-sl.red"$ 9:30:17 USER *** Function `DE' has been redefined 9:30:18 USER *** Function `DF' has been redefined 9:30:18 USER *** Function `DM' has been redefined 9:30:19 USER *** Function `DN' has been redefined 9:30:24 USER *** Function `MAX' has been redefined 9:30:24 USER *** Function `MIN' has been redefined 9:30:25 USER *** Function `PLUS' has been redefined 9:30:25 USER *** Function `TIMES' has been redefined 9:30:34 USER *** Garbage collection starting 9:30:37 USER *** GC 6: time 1395 ms, 248337 recovered, 248337 free 9:30:40 USER % highly portable SL function defns 9:30:41 USER PathIn "easy-non-sl.red"$ 9:30:45 USER *** Function `FIRST' has been redefined 9:30:45 USER *** Function `SECOND' has been redefined 9:30:46 USER *** Function `THIRD' has been redefined 9:30:46 USER *** Function `FOURTH' has been redefined 9:30:46 USER *** Function `REST' has been redefined 9:31:04 USER % simple, ubiquitous SL extensions 9:31:04 USER PathIn "sets.red"$ % Set manipulation functions 9:31:08 USER [16] ASMEnd; 9:31:09 USER *** Garbage collection starting 9:31:18 USER *** GC 7: time 1626 ms, 171323 recovered, 247010 free 9:31:38 USER 0 9:31:38 USER [17] quit; 9:31:39 MONTR @compile randm.mac, drandm.mac 9:31:43 USER MACRO: .MAIN 9:32:04 USER MACRO: .MAIN 9:32:04 USER 9:32:04 USER EXIT 9:32:04 MONTR @ 9:32:06 MONTR Killed by OPERATOR, TTY 221 9:32:06 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 224, 9:32:06 MONTR at 8-Jun-83 09:32:06, Used 0:01:23 in 0:02:48 |
Added psl-1983/3-1/kernel/20/randm.mac version [cfef41b09b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 1 ; (!*ENTRY CODEP EXPR 1) CODEP: intern CODEP LDB 11,L0360 CAIN 11,15 JRST L0361 MOVE 1,0 POPJ 15,0 L0361: MOVE 1,SYMVAL+84 POPJ 15,0 L0360: point 6,1,5 2 ; (!*ENTRY EQ EXPR 2) EQ: intern EQ CAMN 1,2 JRST L0362 MOVE 1,0 POPJ 15,0 L0362: MOVE 1,SYMVAL+84 POPJ 15,0 1 ; (!*ENTRY FLOATP EXPR 1) FLOATP: intern FLOATP LDB 11,L0363 CAIN 11,3 JRST L0364 MOVE 1,0 POPJ 15,0 L0364: MOVE 1,SYMVAL+84 POPJ 15,0 L0363: point 6,1,5 1 ; (!*ENTRY BIGP EXPR 1) BIGP: intern BIGP LDB 11,L0365 CAIN 11,2 JRST L0366 MOVE 1,0 POPJ 15,0 L0366: MOVE 1,SYMVAL+84 POPJ 15,0 L0365: point 6,1,5 1 ; (!*ENTRY IDP EXPR 1) IDP: intern IDP LDB 11,L0367 CAIN 11,30 JRST L0368 MOVE 1,0 POPJ 15,0 L0368: MOVE 1,SYMVAL+84 POPJ 15,0 L0367: point 6,1,5 1 ; (!*ENTRY PAIRP EXPR 1) PAIRP: intern PAIRP LDB 11,L0369 CAIN 11,9 JRST L0370 MOVE 1,0 POPJ 15,0 L0370: MOVE 1,SYMVAL+84 POPJ 15,0 L0369: point 6,1,5 1 ; (!*ENTRY STRINGP EXPR 1) L0372: intern L0372 LDB 11,L0371 CAIN 11,4 JRST L0373 MOVE 1,0 POPJ 15,0 L0373: MOVE 1,SYMVAL+84 POPJ 15,0 L0371: point 6,1,5 1 ; (!*ENTRY VECTORP EXPR 1) L0375: intern L0375 LDB 11,L0374 CAIN 11,8 JRST L0376 MOVE 1,0 POPJ 15,0 L0376: MOVE 1,SYMVAL+84 POPJ 15,0 L0374: point 6,1,5 1 ; (!*ENTRY CAR EXPR 1) CAR: intern CAR CAME 1,0 JRST L0379 MOVE 1,0 POPJ 15,0 L0379: LDB 11,L0377 CAIE 11,9 JRST L0380 MOVE 1,0(1) POPJ 15,0 L0380: MOVE 2,L0378 JRST SYMFNC+149 L0377: point 6,1,5 L0378: <30_30>+187 1 ; (!*ENTRY CDR EXPR 1) CDR: intern CDR CAME 1,0 JRST L0383 MOVE 1,0 POPJ 15,0 L0383: LDB 11,L0381 CAIE 11,9 JRST L0384 MOVE 1,1(1) POPJ 15,0 L0384: MOVE 2,L0382 JRST SYMFNC+149 L0381: point 6,1,5 L0382: <30_30>+188 2 ; (!*ENTRY RPLACA EXPR 2) RPLACA: intern RPLACA LDB 11,L0385 CAIE 11,9 JRST L0387 MOVEM 2,0(1) POPJ 15,0 L0387: MOVE 2,L0386 JRST SYMFNC+149 L0385: point 6,1,5 L0386: <30_30>+189 2 ; (!*ENTRY RPLACD EXPR 2) RPLACD: intern RPLACD LDB 11,L0388 CAIE 11,9 JRST L0390 MOVEM 2,1(1) POPJ 15,0 L0390: MOVE 2,L0389 JRST SYMFNC+149 L0388: point 6,1,5 L0389: <30_30>+190 1 ; (!*ENTRY FIXP EXPR 1) FIXP: intern FIXP LDB 11,L0391 CAIG 11,2 JRST L0392 CAIN 11,63 JRST L0392 MOVE 1,0 POPJ 15,0 L0392: MOVE 1,SYMVAL+84 POPJ 15,0 L0391: point 6,1,5 1 ; (!*ENTRY DIGIT EXPR 1) DIGIT: intern DIGIT MOVE 2,1 LDB 11,L0393 CAIN 11,30 JRST L0394 MOVE 1,0 JRST L0395 L0394: MOVE 1,SYMVAL+84 L0395: CAMN 1,0 JRST L0396 MOVE 1,2 TLZ 1,258048 MOVE 2,1 CAIL 1,48 JRST L0397 MOVE 1,0 JRST L0398 L0397: MOVE 1,SYMVAL+84 L0398: CAMN 1,0 JRST L0396 MOVE 1,SYMVAL+84 CAIG 2,57 JRST L0396 MOVE 1,0 L0396: POPJ 15,0 L0393: point 6,1,5 1 ; (!*ENTRY LITER EXPR 1) LITER: intern LITER MOVE 2,1 LDB 11,L0399 CAIN 11,30 JRST L0400 MOVE 1,0 JRST L0401 L0400: MOVE 1,SYMVAL+84 L0401: CAMN 1,0 JRST L0402 MOVE 1,2 TLZ 1,258048 MOVE 2,1 CAIL 1,65 JRST L0403 MOVE 1,0 JRST L0404 L0403: MOVE 1,SYMVAL+84 L0404: CAMN 1,0 JRST L0405 MOVE 1,SYMVAL+84 CAIG 2,90 JRST L0405 MOVE 1,0 L0405: CAME 1,0 JRST L0402 MOVE 1,SYMVAL+84 CAIL 2,97 JRST L0406 MOVE 1,0 L0406: CAMN 1,0 JRST L0402 MOVE 1,SYMVAL+84 CAIG 2,122 JRST L0402 MOVE 1,0 L0402: POPJ 15,0 L0399: point 6,1,5 1 ; (!*ENTRY LENGTH EXPR 1) LENGTH: intern LENGTH SETZM 2 JRST L0407 ; (!*ENTRY LENGTH1 EXPR 2) L0407: intern L0407 L0409: LDB 11,L0408 CAIE 11,9 JRST L0410 AOS 2 MOVE 1,1(1) JRST L0409 L0410: MOVE 1,2 POPJ 15,0 L0408: point 6,1,5 2 ; (!*ENTRY EQN EXPR 2) EQN: intern EQN MOVE 5,1 CAMN 1,2 JRST L0413 MOVE 1,0 JRST L0414 L0413: MOVE 1,SYMVAL+84 L0414: CAME 1,0 JRST L0415 LDB 1,L0411 CAIN 1,1 JRST L0416 CAIN 1,2 JRST L0417 CAIE 1,3 JRST L0418 MOVE 1,SYMVAL+84 LDB 11,L0412 CAIN 11,3 JRST L0419 MOVE 1,0 L0419: CAMN 1,0 JRST L0415 MOVE 3,5 TLZ 3,258048 MOVE 4,2 TLZ 4,258048 MOVE 1,1(3) CAMN 1,1(4) JRST L0420 MOVE 1,0 JRST L0421 L0420: MOVE 1,SYMVAL+84 L0421: CAMN 1,0 JRST L0415 MOVE 1,2(3) CAMN 1,2(4) JRST L0422 MOVE 1,0 POPJ 15,0 L0422: MOVE 1,SYMVAL+84 POPJ 15,0 L0416: MOVE 1,SYMVAL+84 LDB 11,L0412 CAIN 11,1 JRST L0423 MOVE 1,0 L0423: CAMN 1,0 JRST L0415 MOVE 3,5 TLZ 3,258048 MOVE 4,2 TLZ 4,258048 MOVE 1,1(3) CAMN 1,1(4) JRST L0424 MOVE 1,0 POPJ 15,0 L0424: MOVE 1,SYMVAL+84 POPJ 15,0 L0417: MOVE 1,SYMVAL+84 LDB 11,L0412 CAIN 11,2 JRST L0425 MOVE 1,0 L0425: CAMN 1,0 JRST L0415 MOVE 1,5 JRST L0426 L0418: MOVE 1,0 L0415: POPJ 15,0 L0411: point 6,5,5 L0412: point 6,2,5 2 ; (!*ENTRY LISPEQUAL EXPR 2) L0429: intern L0429 ADJSP 15,2 L0430: MOVEM 1,0(15) MOVEM 2,-1(15) CAMN 1,2 JRST L0431 MOVE 1,0 JRST L0432 L0431: MOVE 1,SYMVAL+84 L0432: CAME 1,0 JRST L0433 LDB 1,L0427 CAIL 1,1 CAILE 1,9 JRST L0434 JRST @L0435-1(1) L0435: IFIW L0436 IFIW L0437 IFIW L0438 IFIW L0439 IFIW L0439 IFIW L0440 IFIW L0441 IFIW L0442 IFIW L0443 L0434: JRST L0444 L0442: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,8 JRST L0445 MOVE 1,0 L0445: CAMN 1,0 JRST L0433 MOVE 1,0(15) ADJSP 15,-2 JRST L0446 L0439: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,4 JRST L0447 MOVE 1,0 L0447: CAMN 1,0 JRST L0433 MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+196 L0443: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,9 JRST L0448 MOVE 1,0 L0448: CAMN 1,0 JRST L0433 MOVE 2,0(2) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,L0429 CAMN 1,0 JRST L0433 MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) MOVE 1,1(1) JRST L0430 L0438: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,3 JRST L0449 MOVE 1,0 L0449: CAMN 1,0 JRST L0433 MOVE 3,0(15) TLZ 3,258048 MOVE 4,2 TLZ 4,258048 MOVE 1,1(3) CAMN 1,1(4) JRST L0450 MOVE 1,0 JRST L0451 L0450: MOVE 1,SYMVAL+84 L0451: CAMN 1,0 JRST L0433 MOVE 1,2(3) CAMN 1,2(4) JRST L0452 MOVE 1,0 JRST L0433 L0452: MOVE 1,SYMVAL+84 JRST L0433 L0436: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,1 JRST L0453 MOVE 1,0 L0453: CAMN 1,0 JRST L0433 MOVE 3,0(15) TLZ 3,258048 MOVE 4,2 TLZ 4,258048 MOVE 1,1(3) CAMN 1,1(4) JRST L0454 MOVE 1,0 JRST L0433 L0454: MOVE 1,SYMVAL+84 JRST L0433 L0437: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,2 JRST L0455 MOVE 1,0 L0455: CAMN 1,0 JRST L0433 MOVE 1,0(15) ADJSP 15,-2 JRST L0426 L0441: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,7 JRST L0456 MOVE 1,0 L0456: CAMN 1,0 JRST L0433 MOVE 1,0(15) ADJSP 15,-2 JRST L0426 L0440: MOVE 1,SYMVAL+84 LDB 11,L0428 CAIN 11,6 JRST L0457 MOVE 1,0 L0457: CAMN 1,0 JRST L0433 MOVE 1,0(15) ADJSP 15,-2 JRST L0458 L0444: MOVE 1,0 L0433: ADJSP 15,-2 POPJ 15,0 L0427: point 6,0(15),5 L0428: point 6,2,5 2 ; (!*ENTRY EQSTR EXPR 2) EQSTR: intern EQSTR MOVE 3,1 CAMN 1,2 JRST L0461 MOVE 1,0 JRST L0462 L0461: MOVE 1,SYMVAL+84 L0462: CAME 1,0 JRST L0463 MOVE 1,SYMVAL+84 LDB 11,L0459 CAIN 11,4 JRST L0464 MOVE 1,0 L0464: CAMN 1,0 JRST L0463 MOVE 1,SYMVAL+84 LDB 11,L0460 CAIN 11,4 JRST L0465 MOVE 1,0 L0465: CAMN 1,0 JRST L0463 MOVE 1,3 JRST SYMFNC+196 L0463: POPJ 15,0 L0459: point 6,3,5 L0460: point 6,2,5 2 ; (!*ENTRY STRINGEQUAL EXPR 2) L0469: intern L0469 ADJSP 15,4 MOVEM 0,0(15) TLZ 1,258048 MOVEM 1,-3(15) TLZ 2,258048 MOVEM 2,-2(15) MOVE 6,0(1) LDB 3,L0466 TDNE 3,L0467 TDO 3,L0468 MOVEM 3,-1(15) MOVE 6,0(2) LDB 4,L0466 TDNE 4,L0467 TDO 4,L0468 CAMN 3,4 JRST L0470 MOVE 1,0 JRST L0471 L0470: SETZM 0(15) L0472: MOVE 6,0(15) CAMG 6,-1(15) JRST L0473 MOVE 1,SYMVAL+84 JRST L0471 L0473: MOVE 2,0(15) MOVE 1,-3(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 5,1 MOVE 2,0(15) MOVE 1,-2(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 CAMN 5,1 JRST L0474 MOVE 1,0 JRST L0471 L0474: AOS 0(15) JRST L0472 L0471: ADJSP 15,-4 POPJ 15,0 L0466: point 30,6,35 L0467: 536870912 L0468: -536870912 ; (!*ENTRY WORDSEQUAL EXPR 2) L0426: intern L0426 ADJSP 15,3 MOVE 5,0 TLZ 1,258048 MOVEM 1,-2(15) TLZ 2,258048 MOVEM 2,-1(15) MOVE 6,0(1) LDB 3,L0475 TDNE 3,L0476 TDO 3,L0477 MOVEM 3,0(15) MOVE 6,0(2) LDB 4,L0475 TDNE 4,L0476 TDO 4,L0477 CAMN 3,4 JRST L0478 MOVE 1,0 JRST L0479 L0478: SETZM 5 L0480: CAME 5,0(15) JRST L0481 MOVE 1,SYMVAL+84 JRST L0479 L0481: MOVE 2,5 ADD 2,-2(15) MOVE 3,5 ADD 3,-1(15) MOVE 6,1(3) CAMN 6,1(2) JRST L0482 MOVE 1,0 JRST L0479 L0482: AOS 5 JRST L0480 L0479: ADJSP 15,-3 POPJ 15,0 L0475: point 30,6,35 L0476: 536870912 L0477: -536870912 ; (!*ENTRY HALFWORDSEQUAL EXPR 2) L0458: intern L0458 ADJSP 15,4 MOVEM 0,0(15) TLZ 1,258048 MOVEM 1,-3(15) TLZ 2,258048 MOVEM 2,-2(15) MOVE 6,0(1) LDB 3,L0483 TDNE 3,L0484 TDO 3,L0485 MOVEM 3,-1(15) MOVE 6,0(2) LDB 4,L0483 TDNE 4,L0484 TDO 4,L0485 CAMN 3,4 JRST L0486 MOVE 1,0 JRST L0487 L0486: SETZM 0(15) L0488: MOVE 6,0(15) CAME 6,-1(15) JRST L0489 MOVE 1,SYMVAL+84 JRST L0487 L0489: MOVE 2,0(15) MOVE 1,-3(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 5,1 MOVE 2,0(15) MOVE 1,-2(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 CAMN 5,1 JRST L0490 MOVE 1,0 JRST L0487 L0490: AOS 0(15) JRST L0488 L0487: ADJSP 15,-4 POPJ 15,0 L0483: point 30,6,35 L0484: 536870912 L0485: -536870912 ; (!*ENTRY VECTOREQUAL EXPR 2) L0446: intern L0446 ADJSP 15,4 MOVEM 0,-3(15) TLZ 1,258048 MOVEM 1,0(15) TLZ 2,258048 MOVEM 2,-1(15) MOVE 6,0(1) LDB 3,L0491 TDNE 3,L0492 TDO 3,L0493 MOVEM 3,-2(15) MOVE 6,0(2) LDB 4,L0491 TDNE 4,L0492 TDO 4,L0493 CAMN 3,4 JRST L0494 MOVE 1,0 JRST L0495 L0494: SETZM -3(15) L0496: MOVE 6,-3(15) CAMG 6,-2(15) JRST L0497 MOVE 1,SYMVAL+84 JRST L0495 L0497: MOVE 2,-3(15) ADD 2,-1(15) MOVE 2,1(2) MOVE 1,-3(15) ADD 1,0(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+195 CAME 1,0 JRST L0498 MOVE 1,0 JRST L0495 L0498: AOS -3(15) JRST L0496 L0495: ADJSP 15,-4 POPJ 15,0 L0491: point 30,6,35 L0492: 536870912 L0493: -536870912 1 ; (!*ENTRY CAAAAR EXPR 1) CAAAAR: intern CAAAAR CAME 1,0 JRST L0501 MOVE 1,0 POPJ 15,0 L0501: LDB 11,L0499 CAIE 11,9 JRST L0502 MOVE 1,0(1) JRST SYMFNC+200 L0502: MOVE 2,L0500 JRST SYMFNC+149 L0499: point 6,1,5 L0500: <30_30>+199 1 ; (!*ENTRY CAAADR EXPR 1) CAAADR: intern CAAADR CAME 1,0 JRST L0505 MOVE 1,0 POPJ 15,0 L0505: LDB 11,L0503 CAIE 11,9 JRST L0506 MOVE 1,1(1) JRST SYMFNC+200 L0506: MOVE 2,L0504 JRST SYMFNC+149 L0503: point 6,1,5 L0504: <30_30>+201 1 ; (!*ENTRY CAADAR EXPR 1) CAADAR: intern CAADAR CAME 1,0 JRST L0509 MOVE 1,0 POPJ 15,0 L0509: LDB 11,L0507 CAIE 11,9 JRST L0510 MOVE 1,0(1) JRST SYMFNC+203 L0510: MOVE 2,L0508 JRST SYMFNC+149 L0507: point 6,1,5 L0508: <30_30>+202 1 ; (!*ENTRY CAADDR EXPR 1) CAADDR: intern CAADDR CAME 1,0 JRST L0513 MOVE 1,0 POPJ 15,0 L0513: LDB 11,L0511 CAIE 11,9 JRST L0514 MOVE 1,1(1) JRST SYMFNC+203 L0514: MOVE 2,L0512 JRST SYMFNC+149 L0511: point 6,1,5 L0512: <30_30>+204 1 ; (!*ENTRY CADAAR EXPR 1) CADAAR: intern CADAAR CAME 1,0 JRST L0517 MOVE 1,0 POPJ 15,0 L0517: LDB 11,L0515 CAIE 11,9 JRST L0518 MOVE 1,0(1) JRST SYMFNC+206 L0518: MOVE 2,L0516 JRST SYMFNC+149 L0515: point 6,1,5 L0516: <30_30>+205 1 ; (!*ENTRY CADADR EXPR 1) CADADR: intern CADADR CAME 1,0 JRST L0521 MOVE 1,0 POPJ 15,0 L0521: LDB 11,L0519 CAIE 11,9 JRST L0522 MOVE 1,1(1) JRST SYMFNC+206 L0522: MOVE 2,L0520 JRST SYMFNC+149 L0519: point 6,1,5 L0520: <30_30>+207 1 ; (!*ENTRY CADDAR EXPR 1) CADDAR: intern CADDAR CAME 1,0 JRST L0525 MOVE 1,0 POPJ 15,0 L0525: LDB 11,L0523 CAIE 11,9 JRST L0526 MOVE 1,0(1) JRST SYMFNC+209 L0526: MOVE 2,L0524 JRST SYMFNC+149 L0523: point 6,1,5 L0524: <30_30>+208 1 ; (!*ENTRY CADDDR EXPR 1) CADDDR: intern CADDDR CAME 1,0 JRST L0529 MOVE 1,0 POPJ 15,0 L0529: LDB 11,L0527 CAIE 11,9 JRST L0530 MOVE 1,1(1) JRST SYMFNC+209 L0530: MOVE 2,L0528 JRST SYMFNC+149 L0527: point 6,1,5 L0528: <30_30>+210 1 ; (!*ENTRY CDAAAR EXPR 1) CDAAAR: intern CDAAAR CAME 1,0 JRST L0533 MOVE 1,0 POPJ 15,0 L0533: LDB 11,L0531 CAIE 11,9 JRST L0534 MOVE 1,0(1) JRST SYMFNC+212 L0534: MOVE 2,L0532 JRST SYMFNC+149 L0531: point 6,1,5 L0532: <30_30>+211 1 ; (!*ENTRY CDAADR EXPR 1) CDAADR: intern CDAADR CAME 1,0 JRST L0537 MOVE 1,0 POPJ 15,0 L0537: LDB 11,L0535 CAIE 11,9 JRST L0538 MOVE 1,1(1) JRST SYMFNC+212 L0538: MOVE 2,L0536 JRST SYMFNC+149 L0535: point 6,1,5 L0536: <30_30>+213 1 ; (!*ENTRY CDADAR EXPR 1) CDADAR: intern CDADAR CAME 1,0 JRST L0541 MOVE 1,0 POPJ 15,0 L0541: LDB 11,L0539 CAIE 11,9 JRST L0542 MOVE 1,0(1) JRST SYMFNC+215 L0542: MOVE 2,L0540 JRST SYMFNC+149 L0539: point 6,1,5 L0540: <30_30>+214 1 ; (!*ENTRY CDADDR EXPR 1) CDADDR: intern CDADDR CAME 1,0 JRST L0545 MOVE 1,0 POPJ 15,0 L0545: LDB 11,L0543 CAIE 11,9 JRST L0546 MOVE 1,1(1) JRST SYMFNC+215 L0546: MOVE 2,L0544 JRST SYMFNC+149 L0543: point 6,1,5 L0544: <30_30>+216 1 ; (!*ENTRY CDDAAR EXPR 1) CDDAAR: intern CDDAAR CAME 1,0 JRST L0549 MOVE 1,0 POPJ 15,0 L0549: LDB 11,L0547 CAIE 11,9 JRST L0550 MOVE 1,0(1) JRST SYMFNC+218 L0550: MOVE 2,L0548 JRST SYMFNC+149 L0547: point 6,1,5 L0548: <30_30>+217 1 ; (!*ENTRY CDDADR EXPR 1) CDDADR: intern CDDADR CAME 1,0 JRST L0553 MOVE 1,0 POPJ 15,0 L0553: LDB 11,L0551 CAIE 11,9 JRST L0554 MOVE 1,1(1) JRST SYMFNC+218 L0554: MOVE 2,L0552 JRST SYMFNC+149 L0551: point 6,1,5 L0552: <30_30>+219 1 ; (!*ENTRY CDDDAR EXPR 1) CDDDAR: intern CDDDAR CAME 1,0 JRST L0557 MOVE 1,0 POPJ 15,0 L0557: LDB 11,L0555 CAIE 11,9 JRST L0558 MOVE 1,0(1) JRST SYMFNC+221 L0558: MOVE 2,L0556 JRST SYMFNC+149 L0555: point 6,1,5 L0556: <30_30>+220 1 ; (!*ENTRY CDDDDR EXPR 1) CDDDDR: intern CDDDDR CAME 1,0 JRST L0561 MOVE 1,0 POPJ 15,0 L0561: LDB 11,L0559 CAIE 11,9 JRST L0562 MOVE 1,1(1) JRST SYMFNC+221 L0562: MOVE 2,L0560 JRST SYMFNC+149 L0559: point 6,1,5 L0560: <30_30>+222 1 ; (!*ENTRY CAAAR EXPR 1) CAAAR: intern CAAAR CAME 1,0 JRST L0565 MOVE 1,0 POPJ 15,0 L0565: LDB 11,L0563 CAIE 11,9 JRST L0566 MOVE 1,0(1) JRST SYMFNC+223 L0566: MOVE 2,L0564 JRST SYMFNC+149 L0563: point 6,1,5 L0564: <30_30>+200 1 ; (!*ENTRY CAADR EXPR 1) CAADR: intern CAADR CAME 1,0 JRST L0569 MOVE 1,0 POPJ 15,0 L0569: LDB 11,L0567 CAIE 11,9 JRST L0570 MOVE 1,1(1) JRST SYMFNC+223 L0570: MOVE 2,L0568 JRST SYMFNC+149 L0567: point 6,1,5 L0568: <30_30>+203 1 ; (!*ENTRY CADAR EXPR 1) CADAR: intern CADAR CAME 1,0 JRST L0573 MOVE 1,0 POPJ 15,0 L0573: LDB 11,L0571 CAIE 11,9 JRST L0574 MOVE 1,0(1) JRST SYMFNC+224 L0574: MOVE 2,L0572 JRST SYMFNC+149 L0571: point 6,1,5 L0572: <30_30>+206 1 ; (!*ENTRY CADDR EXPR 1) CADDR: intern CADDR CAME 1,0 JRST L0577 MOVE 1,0 POPJ 15,0 L0577: LDB 11,L0575 CAIE 11,9 JRST L0578 MOVE 1,1(1) JRST SYMFNC+224 L0578: MOVE 2,L0576 JRST SYMFNC+149 L0575: point 6,1,5 L0576: <30_30>+209 1 ; (!*ENTRY CDAAR EXPR 1) CDAAR: intern CDAAR CAME 1,0 JRST L0581 MOVE 1,0 POPJ 15,0 L0581: LDB 11,L0579 CAIE 11,9 JRST L0582 MOVE 1,0(1) JRST SYMFNC+225 L0582: MOVE 2,L0580 JRST SYMFNC+149 L0579: point 6,1,5 L0580: <30_30>+212 1 ; (!*ENTRY CDADR EXPR 1) CDADR: intern CDADR CAME 1,0 JRST L0585 MOVE 1,0 POPJ 15,0 L0585: LDB 11,L0583 CAIE 11,9 JRST L0586 MOVE 1,1(1) JRST SYMFNC+225 L0586: MOVE 2,L0584 JRST SYMFNC+149 L0583: point 6,1,5 L0584: <30_30>+215 1 ; (!*ENTRY CDDAR EXPR 1) CDDAR: intern CDDAR CAME 1,0 JRST L0589 MOVE 1,0 POPJ 15,0 L0589: LDB 11,L0587 CAIE 11,9 JRST L0590 MOVE 1,0(1) JRST SYMFNC+226 L0590: MOVE 2,L0588 JRST SYMFNC+149 L0587: point 6,1,5 L0588: <30_30>+218 1 ; (!*ENTRY CDDDR EXPR 1) CDDDR: intern CDDDR CAME 1,0 JRST L0593 MOVE 1,0 POPJ 15,0 L0593: LDB 11,L0591 CAIE 11,9 JRST L0594 MOVE 1,1(1) JRST SYMFNC+226 L0594: MOVE 2,L0592 JRST SYMFNC+149 L0591: point 6,1,5 L0592: <30_30>+221 1 ; (!*ENTRY SAFECAR EXPR 1) L0597: intern L0597 CAME 1,0 JRST L0598 MOVE 1,0 POPJ 15,0 L0598: LDB 11,L0595 CAIE 11,9 JRST L0599 MOVE 1,0(1) POPJ 15,0 L0599: MOVE 2,L0596 JRST SYMFNC+149 L0595: point 6,1,5 L0596: <30_30>+187 1 ; (!*ENTRY SAFECDR EXPR 1) L0602: intern L0602 CAME 1,0 JRST L0603 MOVE 1,0 POPJ 15,0 L0603: LDB 11,L0600 CAIE 11,9 JRST L0604 MOVE 1,1(1) POPJ 15,0 L0604: MOVE 2,L0601 JRST SYMFNC+149 L0600: point 6,1,5 L0601: <30_30>+188 1 ; (!*ENTRY CAAR EXPR 1) CAAR: intern CAAR CAME 1,0 JRST L0607 MOVE 1,0 POPJ 15,0 L0607: LDB 11,L0605 CAIE 11,9 JRST L0608 MOVE 1,0(1) JRST SYMFNC+227 L0608: MOVE 2,L0606 JRST SYMFNC+149 L0605: point 6,1,5 L0606: <30_30>+223 1 ; (!*ENTRY CADR EXPR 1) CADR: intern CADR CAME 1,0 JRST L0611 MOVE 1,0 POPJ 15,0 L0611: LDB 11,L0609 CAIE 11,9 JRST L0612 MOVE 1,1(1) JRST SYMFNC+227 L0612: MOVE 2,L0610 JRST SYMFNC+149 L0609: point 6,1,5 L0610: <30_30>+224 1 ; (!*ENTRY CDAR EXPR 1) CDAR: intern CDAR CAME 1,0 JRST L0615 MOVE 1,0 POPJ 15,0 L0615: LDB 11,L0613 CAIE 11,9 JRST L0616 MOVE 1,0(1) JRST SYMFNC+228 L0616: MOVE 2,L0614 JRST SYMFNC+149 L0613: point 6,1,5 L0614: <30_30>+225 1 ; (!*ENTRY CDDR EXPR 1) CDDR: intern CDDR CAME 1,0 JRST L0619 MOVE 1,0 POPJ 15,0 L0619: LDB 11,L0617 CAIE 11,9 JRST L0620 MOVE 1,1(1) JRST SYMFNC+228 L0620: MOVE 2,L0618 JRST SYMFNC+149 L0617: point 6,1,5 L0618: <30_30>+226 1 ; (!*ENTRY ATOM EXPR 1) ATOM: intern ATOM LDB 11,L0621 CAIE 11,9 JRST L0622 MOVE 1,0 POPJ 15,0 L0622: MOVE 1,SYMVAL+84 POPJ 15,0 L0621: point 6,1,5 1 ; (!*ENTRY CONSTANTP EXPR 1) L0625: intern L0625 MOVE 2,1 LDB 11,L0623 CAIE 11,9 JRST L0626 MOVE 1,0 JRST L0627 L0626: MOVE 1,SYMVAL+84 L0627: CAMN 1,0 JRST L0628 MOVE 1,SYMVAL+84 LDB 11,L0624 CAIE 11,30 JRST L0628 MOVE 1,0 L0628: POPJ 15,0 L0623: point 6,1,5 L0624: point 6,2,5 1 ; (!*ENTRY NULL EXPR 1) NULL: intern NULL CAMN 1,0 JRST L0629 MOVE 1,0 POPJ 15,0 L0629: MOVE 1,SYMVAL+84 POPJ 15,0 1 ; (!*ENTRY NUMBERP EXPR 1) L0632: intern L0632 MOVE 2,1 LDB 11,L0630 CAIG 11,2 JRST L0633 CAIN 11,63 JRST L0633 MOVE 1,0 JRST L0634 L0633: MOVE 1,SYMVAL+84 L0634: CAME 1,0 JRST L0635 MOVE 1,SYMVAL+84 LDB 11,L0631 CAIN 11,3 JRST L0635 MOVE 1,0 L0635: POPJ 15,0 L0630: point 6,1,5 L0631: point 6,2,5 L0641: 24 byte(7)73,108,108,101,103,97,108,32,97,114,103,117,109,101,110,116,115,32,116,111,32,69,120,112,116,0 2 ; (!*ENTRY EXPT EXPR 2) EXPT: intern EXPT ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) LDB 11,L0637 CAIN 11,63 JRST L0636 CAILE 11,0 JRST L0642 L0636: LDB 11,L0638 CAIG 11,3 JRST L0643 CAIN 11,63 JRST L0643 L0642: PUSHJ 15,SYMFNC+234 MOVEM 1,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-3(15) MOVE 1,L0639 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L0640 HRRZI 1,99 ADJSP 15,-4 JRST SYMFNC+236 L0643: HRRZI 6,1 MOVEM 6,-2(15) SETZM 2 MOVE 1,-1(15) PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L0644 MOVEM 0,-3(15) HRRZI 6,1 MOVEM 6,-3(15) L0645: MOVE 2,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+238 PUSHJ 15,SYMFNC+239 CAME 1,0 JRST L0646 MOVE 2,0(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+240 MOVEM 1,-2(15) MOVE 1,-3(15) PUSHJ 15,SYMFNC+241 MOVEM 1,-3(15) JRST L0645 L0644: MOVE 1,-1(15) PUSHJ 15,SYMFNC+239 CAMN 1,0 JRST L0646 MOVEM 0,-3(15) SETOM -3(15) L0647: MOVE 2,-3(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+238 MOVE 2,1 SETOM 1 PUSHJ 15,SYMFNC+240 PUSHJ 15,SYMFNC+239 CAME 1,0 JRST L0646 MOVE 2,0(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+242 MOVEM 1,-2(15) SETOM 2 MOVE 1,-3(15) PUSHJ 15,SYMFNC+243 MOVEM 1,-3(15) JRST L0647 L0646: MOVE 1,-2(15) ADJSP 15,-4 POPJ 15,0 L0637: point 6,2,5 L0638: point 6,1,5 L0640: <4_30>+<1_18>+L0641 L0639: <30_30>+233 1 ; (!*ENTRY LIST FEXPR 1) LIST: intern LIST JRST SYMFNC+245 L0652: <30_30>+246 <9_30>+<1_18>+L0653 L0653: <30_30>+247 <30_30>+128 1 ; (!*ENTRY DE MACRO 1) DE: intern DE ADJSP 15,2 MOVEM 1,0(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVE 2,1(2) MOVE 1,L0648 PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,L0649 PUSHJ 15,SYMFNC+249 MOVE 4,1 MOVE 3,L0650 MOVE 2,-1(15) MOVE 1,L0651 ADJSP 15,-2 JRST SYMFNC+250 L0651: <30_30>+251 L0650: <9_30>+<1_18>+L0652 L0649: <30_30>+252 L0648: <30_30>+253 L0658: <30_30>+246 <9_30>+<1_18>+L0659 L0659: <30_30>+254 <30_30>+128 1 ; (!*ENTRY DF MACRO 1) DF: intern DF ADJSP 15,2 MOVEM 1,0(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVE 2,1(2) MOVE 1,L0654 PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,L0655 PUSHJ 15,SYMFNC+249 MOVE 4,1 MOVE 3,L0656 MOVE 2,-1(15) MOVE 1,L0657 ADJSP 15,-2 JRST SYMFNC+250 L0657: <30_30>+251 L0656: <9_30>+<1_18>+L0658 L0655: <30_30>+252 L0654: <30_30>+253 L0664: <30_30>+246 <9_30>+<1_18>+L0665 L0665: <30_30>+256 <30_30>+128 1 ; (!*ENTRY DM MACRO 1) DM: intern DM ADJSP 15,2 MOVEM 1,0(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVE 2,1(2) MOVE 1,L0660 PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,L0661 PUSHJ 15,SYMFNC+249 MOVE 4,1 MOVE 3,L0662 MOVE 2,-1(15) MOVE 1,L0663 ADJSP 15,-2 JRST SYMFNC+250 L0663: <30_30>+251 L0662: <9_30>+<1_18>+L0664 L0661: <30_30>+252 L0660: <30_30>+253 L0670: <30_30>+246 <9_30>+<1_18>+L0671 L0671: <30_30>+258 <30_30>+128 1 ; (!*ENTRY DN MACRO 1) DN: intern DN ADJSP 15,2 MOVEM 1,0(15) MOVE 1,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVE 2,1(2) MOVE 1,L0666 PUSHJ 15,SYMFNC+151 MOVE 2,1 MOVE 1,L0667 PUSHJ 15,SYMFNC+249 MOVE 4,1 MOVE 3,L0668 MOVE 2,-1(15) MOVE 1,L0669 ADJSP 15,-2 JRST SYMFNC+250 L0669: <30_30>+251 L0668: <9_30>+<1_18>+L0670 L0667: <30_30>+252 L0666: <30_30>+253 1 ; (!*ENTRY SETQ FEXPR 1) SETQ: intern SETQ ADJSP 15,3 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) L0672: CAMN 0,0(15) JRST L0673 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,-2(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVE 2,1 MOVEM 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+262 MOVE 1,-2(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0672 L0673: MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 2 ; (!*ENTRY PROG2 EXPR 2) PROG2: intern PROG2 MOVE 1,2 POPJ 15,0 1 ; (!*ENTRY PROGN FEXPR 1) PROGN: intern PROGN JRST SYMFNC+265 1 ; (!*ENTRY EVPROGN EXPR 1) L0676: intern L0676 PUSH 15,1 LDB 11,L0674 CAIE 11,9 JRST L0677 L0678: MOVE 6,0(15) LDB 11,L0675 CAIN 11,9 JRST L0679 MOVE 1,0 JRST L0680 L0679: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0678 L0680: MOVE 1,0(15) MOVE 1,0(1) ADJSP 15,-1 JRST SYMFNC+261 L0677: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L0674: point 6,1,5 L0675: point 6,1(6),5 1 ; (!*ENTRY AND FEXPR 1) AND: intern AND JRST SYMFNC+267 1 ; (!*ENTRY EVAND EXPR 1) EVAND: intern EVAND LDB 11,L0681 CAIN 11,9 JRST L0682 MOVE 1,SYMVAL+84 POPJ 15,0 L0682: JRST EVAND1 L0681: point 6,1,5 ; (!*ENTRY EVAND1 EXPR 1) EVAND1: intern EVAND1 ADJSP 15,1 L0684: MOVEM 1,0(15) LDB 11,L0683 CAIN 11,9 JRST L0685 MOVE 1,0(1) ADJSP 15,-1 JRST SYMFNC+261 L0685: MOVE 1,0(1) PUSHJ 15,SYMFNC+261 CAME 1,0 JRST L0686 MOVE 1,0 JRST L0687 L0686: MOVE 1,0(15) MOVE 1,1(1) JRST L0684 L0687: ADJSP 15,-1 POPJ 15,0 L0683: point 6,1(1),5 1 ; (!*ENTRY OR FEXPR 1) OR: intern OR JRST SYMFNC+269 1 ; (!*ENTRY EVOR EXPR 1) EVOR: intern EVOR ADJSP 15,1 L0689: MOVEM 1,0(15) LDB 11,L0688 CAIN 11,9 JRST L0690 MOVE 1,0 JRST L0691 L0690: MOVE 1,SYMVAL+84 L0691: CAMN 1,0 JRST L0692 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 CAME 1,0 JRST L0692 MOVE 1,0(15) MOVE 1,1(1) JRST L0689 L0692: ADJSP 15,-1 POPJ 15,0 L0688: point 6,1,5 1 ; (!*ENTRY COND FEXPR 1) COND: intern COND JRST SYMFNC+271 1 ; (!*ENTRY EVCOND EXPR 1) EVCOND: intern EVCOND ADJSP 15,4 L0697: MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L0693 CAIN 11,9 JRST L0698 MOVE 1,0 JRST L0699 L0698: MOVE 2,0(1) MOVEM 2,-1(15) MOVE 1,1(1) MOVEM 1,0(15) LDB 11,L0694 CAIE 11,9 JRST L0700 MOVE 1,0(2) JRST L0701 L0700: MOVE 1,2 L0701: MOVEM 1,-2(15) PUSHJ 15,SYMFNC+261 MOVE 3,1 MOVEM 3,-3(15) CAME 3,0 JRST L0702 MOVE 1,0(15) JRST L0697 L0702: LDB 11,L0695 CAIE 11,9 JRST L0703 MOVE 6,-1(15) LDB 11,L0696 CAIN 11,9 JRST L0704 L0703: MOVE 1,3 JRST L0699 L0704: MOVE 1,-1(15) MOVE 1,1(1) ADJSP 15,-4 JRST SYMFNC+265 L0699: ADJSP 15,-4 POPJ 15,0 L0693: point 6,1,5 L0694: point 6,2,5 L0695: point 6,-1(15),5 L0696: point 6,1(6),5 1 ; (!*ENTRY NOT EXPR 1) NOT: intern NOT CAMN 1,0 JRST L0705 MOVE 1,0 POPJ 15,0 L0705: MOVE 1,SYMVAL+84 POPJ 15,0 1 ; (!*ENTRY ABS EXPR 1) ABS: intern ABS PUSH 15,1 PUSHJ 15,SYMFNC+239 CAMN 1,0 JRST L0706 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+274 L0706: MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L0709: 31 byte(7)65,116,116,101,109,112,116,32,116,111,32,100,105,118,105,100,101,32,98,121,32,48,32,105,110,32,68,73,86,73,68,69,0 2 ; (!*ENTRY DIVIDE EXPR 2) DIVIDE: intern DIVIDE ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 1,2 PUSHJ 15,SYMFNC+276 CAMN 1,0 JRST L0710 MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVEM 1,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-2(15) MOVE 1,L0707 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,L0708 HRRZI 1,99 ADJSP 15,-3 JRST SYMFNC+236 L0710: MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+242 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+277 MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L0708: <4_30>+<1_18>+L0709 L0707: <30_30>+275 1 ; (!*ENTRY MAX MACRO 1) MAX: intern MAX SETZM 3 MOVE 2,L0711 MOVE 1,1(1) JRST SYMFNC+280 L0711: <30_30>+281 2 ; (!*ENTRY MAX2 EXPR 2) MAX2: intern MAX2 PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L0712 MOVE 1,-1(15) JRST L0713 L0712: MOVE 1,0(15) L0713: ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY MIN MACRO 1) MIN: intern MIN SETZM 3 MOVE 2,L0714 MOVE 1,1(1) JRST SYMFNC+280 L0714: <30_30>+284 2 ; (!*ENTRY MIN2 EXPR 2) MIN2: intern MIN2 PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L0715 MOVE 1,-1(15) JRST L0716 L0715: MOVE 1,0(15) L0716: ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY PLUS MACRO 1) PLUS: intern PLUS SETZM 3 MOVE 2,L0717 MOVE 1,1(1) JRST SYMFNC+280 L0717: <30_30>+243 1 ; (!*ENTRY TIMES MACRO 1) TIMES: intern TIMES HRRZI 3,1 MOVE 2,L0718 MOVE 1,1(1) JRST SYMFNC+280 L0718: <30_30>+240 2 ; (!*ENTRY MAP EXPR 2) MAP: intern MAP PUSH 15,2 PUSH 15,1 L0720: LDB 11,L0719 CAIN 11,9 JRST L0721 MOVE 1,0 JRST L0722 L0721: MOVE 2,-1(15) MOVE 1,0(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0720 L0722: ADJSP 15,-2 POPJ 15,0 L0719: point 6,0(15),5 2 ; (!*ENTRY MAPC EXPR 2) MAPC: intern MAPC PUSH 15,2 PUSH 15,1 L0724: LDB 11,L0723 CAIN 11,9 JRST L0725 MOVE 1,0 JRST L0726 L0725: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0724 L0726: ADJSP 15,-2 POPJ 15,0 L0723: point 6,0(15),5 2 ; (!*ENTRY MAPCAN EXPR 2) MAPCAN: intern MAPCAN ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0727 CAIN 11,9 JRST L0728 MOVE 1,0 JRST L0729 L0728: MOVE 1,0(1) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,MAPCAN MOVE 2,1 MOVE 1,-2(15) ADJSP 15,-3 JRST SYMFNC+291 L0729: ADJSP 15,-3 POPJ 15,0 L0727: point 6,1,5 2 ; (!*ENTRY MAPCON EXPR 2) MAPCON: intern MAPCON ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0730 CAIN 11,9 JRST L0731 MOVE 1,0 JRST L0732 L0731: MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,MAPCON MOVE 2,1 MOVE 1,-2(15) ADJSP 15,-3 JRST SYMFNC+291 L0732: ADJSP 15,-3 POPJ 15,0 L0730: point 6,1,5 2 ; (!*ENTRY MAPCAR EXPR 2) MAPCAR: intern MAPCAR ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0733 CAIN 11,9 JRST L0734 MOVE 1,0 JRST L0735 L0734: MOVE 1,0(1) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,MAPCAR MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L0735: ADJSP 15,-3 POPJ 15,0 L0733: point 6,1,5 2 ; (!*ENTRY MAPLIST EXPR 2) L0737: intern L0737 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0736 CAIN 11,9 JRST L0738 MOVE 1,0 JRST L0739 L0738: MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,L0737 MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L0739: ADJSP 15,-3 POPJ 15,0 L0736: point 6,1,5 2 ; (!*ENTRY APPEND EXPR 2) APPEND: intern APPEND ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0740 CAIN 11,9 JRST L0742 MOVE 1,2 JRST L0743 L0742: MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+172 MOVE 3,1 MOVEM 3,-3(15) MOVEM 3,-2(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) L0744: LDB 11,L0741 CAIE 11,9 JRST L0745 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+172 MOVE 7,-3(15) MOVEM 1,1(7) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) MOVE 3,-3(15) MOVE 3,1(3) MOVEM 3,-3(15) JRST L0744 L0745: MOVE 7,-3(15) MOVE 6,-1(15) MOVEM 6,1(7) MOVE 1,-2(15) L0743: ADJSP 15,-4 POPJ 15,0 L0740: point 6,1,5 L0741: point 6,0(15),5 2 ; (!*ENTRY ASSOC EXPR 2) ASSOC: intern ASSOC ADJSP 15,2 L0748: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0746 CAIN 11,9 JRST L0749 MOVE 1,0 JRST L0750 L0749: LDB 11,L0747 CAIE 11,9 JRST L0751 MOVE 2,0(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0751 MOVE 1,-1(15) MOVE 1,0(1) JRST L0750 L0751: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0748 L0750: ADJSP 15,-2 POPJ 15,0 L0746: point 6,2,5 L0747: point 6,0(2),5 3 ; (!*ENTRY SASSOC EXPR 3) SASSOC: intern SASSOC ADJSP 15,3 L0754: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L0752 CAIN 11,9 JRST L0755 MOVE 1,3 MOVE 6,1 ADJSP 15,-3 JRST SYMFNC+288 L0755: LDB 11,L0753 CAIE 11,9 JRST L0756 MOVE 2,0(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0756 MOVE 1,-1(15) MOVE 1,0(1) JRST L0757 L0756: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0754 L0757: ADJSP 15,-3 POPJ 15,0 L0752: point 6,2,5 L0753: point 6,0(2),5 L0761: 29 byte(7)68,105,102,102,101,114,101,110,116,32,108,101,110,103,116,104,32,108,105,115,116,115,32,105,110,32,80,65,73,82,0 2 ; (!*ENTRY PAIR EXPR 2) PAIR: intern PAIR ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0758 CAIE 11,9 JRST L0762 LDB 11,L0759 CAIE 11,9 JRST L0762 MOVE 2,0(2) MOVE 1,0(1) PUSHJ 15,SYMFNC+151 MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,PAIR MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L0762: LDB 11,L0758 CAIN 11,9 JRST L0763 LDB 11,L0759 CAIE 11,9 JRST L0764 L0763: MOVE 1,L0760 ADJSP 15,-3 JRST SYMFNC+156 L0764: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L0758: point 6,1,5 L0759: point 6,2,5 L0760: <4_30>+<1_18>+L0761 2 ; (!*ENTRY SUBLIS EXPR 2) SUBLIS: intern SUBLIS ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0765 CAIN 11,9 JRST L0767 MOVE 1,2 JRST L0768 L0767: MOVEM 0,-2(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+295 MOVEM 1,-2(15) LDB 11,L0765 CAIE 11,9 JRST L0769 MOVE 1,1(1) JRST L0768 L0769: LDB 11,L0766 CAIN 11,9 JRST L0770 MOVE 1,-1(15) JRST L0768 L0770: MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) PUSHJ 15,SUBLIS MOVEM 1,-3(15) MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,SUBLIS MOVE 2,-3(15) ADJSP 15,-4 JRST SYMFNC+278 L0768: ADJSP 15,-4 POPJ 15,0 L0765: point 6,1,5 L0766: point 6,-1(15),5 2 ; (!*ENTRY DEFLIST EXPR 2) L0772: intern L0772 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0771 CAIN 11,9 JRST L0773 MOVE 1,0 JRST L0774 L0773: MOVE 3,0(1) MOVE 3,1(3) MOVE 3,0(3) MOVE 1,0(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+300 MOVE 1,0(15) MOVE 1,0(1) MOVE 1,0(1) MOVEM 1,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,L0772 MOVE 2,-2(15) ADJSP 15,-3 JRST SYMFNC+278 L0774: ADJSP 15,-3 POPJ 15,0 L0771: point 6,1,5 2 ; (!*ENTRY DELETE EXPR 2) DELETE: intern DELETE PUSH 15,2 PUSH 15,1 LDB 11,L0775 CAIN 11,9 JRST L0776 MOVE 1,2 JRST L0777 L0776: MOVE 2,1 MOVE 1,-1(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0778 MOVE 1,-1(15) MOVE 1,1(1) JRST L0777 L0778: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,DELETE MOVE 2,-1(15) MOVE 2,0(2) ADJSP 15,-2 JRST SYMFNC+278 L0777: ADJSP 15,-2 POPJ 15,0 L0775: point 6,2,5 2 ; (!*ENTRY MEMBER EXPR 2) MEMBER: intern MEMBER ADJSP 15,2 L0780: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0779 CAIN 11,9 JRST L0781 MOVE 1,0 JRST L0782 L0781: MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0783 MOVE 1,-1(15) JRST L0782 L0783: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0780 L0782: ADJSP 15,-2 POPJ 15,0 L0779: point 6,2,5 2 ; (!*ENTRY MEMQ EXPR 2) MEMQ: intern MEMQ L0785: LDB 11,L0784 CAIN 11,9 JRST L0786 MOVE 1,0 POPJ 15,0 L0786: CAME 1,0(2) JRST L0787 MOVE 1,2 POPJ 15,0 L0787: MOVE 2,1(2) JRST L0785 L0784: point 6,2,5 2 ; (!*ENTRY NCONC EXPR 2) NCONC: intern NCONC MOVE 5,1 MOVE 4,2 MOVE 3,0 LDB 11,L0788 CAIN 11,9 JRST L0790 MOVE 1,2 POPJ 15,0 L0790: MOVE 3,1 L0791: LDB 11,L0789 CAIE 11,9 JRST L0792 MOVE 1,1(3) MOVE 3,1 JRST L0791 L0792: MOVEM 4,1(3) MOVE 1,5 POPJ 15,0 L0788: point 6,1,5 L0789: point 6,1(3),5 1 ; (!*ENTRY REVERSE EXPR 1) L0794: intern L0794 PUSH 15,0 PUSH 15,1 L0795: LDB 11,L0793 CAIE 11,9 JRST L0796 MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+151 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) JRST L0795 L0796: MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 L0793: point 6,0(15),5 3 ; (!*ENTRY SUBST EXPR 3) SUBST: intern SUBST ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) CAME 3,0 JRST L0798 MOVE 1,0 JRST L0799 L0798: MOVE 2,3 MOVE 1,-1(15) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0800 MOVE 1,0(15) JRST L0799 L0800: LDB 11,L0797 CAIN 11,9 JRST L0801 MOVE 1,-2(15) JRST L0799 L0801: MOVE 3,-2(15) MOVE 3,0(3) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SUBST MOVEM 1,-3(15) MOVE 3,-2(15) MOVE 3,1(3) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SUBST MOVE 2,-3(15) ADJSP 15,-4 JRST SYMFNC+278 L0799: ADJSP 15,-4 POPJ 15,0 L0797: point 6,-2(15),5 1 ; (!*ENTRY EVLIS EXPR 1) EVLIS: intern EVLIS ADJSP 15,2 MOVEM 1,0(15) LDB 11,L0802 CAIN 11,9 JRST L0803 MOVE 1,0 JRST L0804 L0803: MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVEM 1,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,EVLIS MOVE 2,-1(15) ADJSP 15,-2 JRST SYMFNC+278 L0804: ADJSP 15,-2 POPJ 15,0 L0802: point 6,1,5 3 ; (!*ENTRY ROBUSTEXPAND EXPR 3) L0805: intern L0805 CAME 1,0 JRST L0806 MOVE 1,3 POPJ 15,0 L0806: JRST SYMFNC+306 2 ; (!*ENTRY EXPAND EXPR 2) EXPAND: intern EXPAND PUSH 15,2 PUSH 15,1 LDB 11,L0807 CAIE 11,9 JRST L0809 LDB 11,L0808 CAIN 11,9 JRST L0810 MOVE 1,0(1) JRST L0809 L0810: MOVE 1,1(1) PUSHJ 15,EXPAND MOVE 3,1 MOVE 2,0(15) MOVE 2,0(2) MOVE 1,-1(15) ADJSP 15,-2 JRST SYMFNC+235 L0809: ADJSP 15,-2 POPJ 15,0 L0807: point 6,1,5 L0808: point 6,1(1),5 1 ; (!*ENTRY QUOTE FEXPR 1) QUOTE: intern QUOTE MOVE 1,0(1) POPJ 15,0 1 ; (!*ENTRY FUNCTION FEXPR 1) L0811: intern L0811 MOVE 1,0(1) POPJ 15,0 2 ; (!*ENTRY CHANNELPRINT EXPR 2) L0812: intern L0812 PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+308 MOVE 1,0(15) PUSHJ 15,SYMFNC+309 MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY PRINT EXPR 1) PRINT: intern PRINT MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+307 2 ; (!*ENTRY NEQ EXPR 2) NEQ: intern NEQ PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0813 MOVE 1,0 POPJ 15,0 L0813: MOVE 1,SYMVAL+84 POPJ 15,0 2 ; (!*ENTRY NE EXPR 2) NE: intern NE CAME 1,2 JRST L0814 MOVE 1,0 POPJ 15,0 L0814: MOVE 1,SYMVAL+84 POPJ 15,0 2 ; (!*ENTRY GEQ EXPR 2) GEQ: intern GEQ PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L0815 MOVE 1,0 POPJ 15,0 L0815: MOVE 1,SYMVAL+84 POPJ 15,0 2 ; (!*ENTRY LEQ EXPR 2) LEQ: intern LEQ PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L0816 MOVE 1,0 POPJ 15,0 L0816: MOVE 1,SYMVAL+84 POPJ 15,0 2 ; (!*ENTRY EQCAR EXPR 2) EQCAR: intern EQCAR MOVE 3,1 LDB 11,L0817 CAIN 11,9 JRST L0818 MOVE 1,0 JRST L0819 L0818: MOVE 1,SYMVAL+84 L0819: CAMN 1,0 JRST L0820 MOVE 1,0(3) CAMN 1,2 JRST L0821 MOVE 1,0 POPJ 15,0 L0821: MOVE 1,SYMVAL+84 L0820: POPJ 15,0 L0817: point 6,1,5 1 ; (!*ENTRY EXPRP EXPR 1) EXPRP: intern EXPRP PUSH 15,1 PUSH 15,1 LDB 11,L0822 CAIN 11,9 JRST L0826 MOVE 1,0 JRST L0827 L0826: MOVE 1,SYMVAL+84 L0827: CAMN 1,0 JRST L0828 MOVE 1,-1(15) MOVE 1,0(1) CAMN 1,L0823 JRST L0829 MOVE 1,0 JRST L0828 L0829: MOVE 1,SYMVAL+84 L0828: CAME 1,0 JRST L0830 MOVE 1,SYMVAL+84 LDB 11,L0824 CAIN 11,15 JRST L0831 MOVE 1,0 L0831: CAME 1,0 JRST L0830 MOVE 1,0(15) PUSHJ 15,SYMFNC+318 MOVEM 1,-1(15) LDB 11,L0822 CAIN 11,9 JRST L0832 MOVE 1,0 JRST L0833 L0832: MOVE 1,SYMVAL+84 L0833: CAMN 1,0 JRST L0830 MOVE 1,-1(15) MOVE 1,0(1) CAMN 1,L0825 JRST L0834 MOVE 1,0 JRST L0830 L0834: MOVE 1,SYMVAL+84 L0830: ADJSP 15,-2 POPJ 15,0 L0822: point 6,1,5 L0824: point 6,0(15),5 L0825: <30_30>+247 L0823: <30_30>+253 1 ; (!*ENTRY MACROP EXPR 1) MACROP: intern MACROP ADJSP 15,1 PUSHJ 15,SYMFNC+318 MOVEM 1,0(15) LDB 11,L0835 CAIN 11,9 JRST L0837 MOVE 1,0 JRST L0838 L0837: MOVE 1,SYMVAL+84 L0838: CAMN 1,0 JRST L0839 MOVE 1,0(15) MOVE 1,0(1) CAMN 1,L0836 JRST L0840 MOVE 1,0 JRST L0839 L0840: MOVE 1,SYMVAL+84 L0839: ADJSP 15,-1 POPJ 15,0 L0835: point 6,1,5 L0836: <30_30>+256 1 ; (!*ENTRY FEXPRP EXPR 1) FEXPRP: intern FEXPRP ADJSP 15,1 PUSHJ 15,SYMFNC+318 MOVEM 1,0(15) LDB 11,L0841 CAIN 11,9 JRST L0843 MOVE 1,0 JRST L0844 L0843: MOVE 1,SYMVAL+84 L0844: CAMN 1,0 JRST L0845 MOVE 1,0(15) MOVE 1,0(1) CAMN 1,L0842 JRST L0846 MOVE 1,0 JRST L0845 L0846: MOVE 1,SYMVAL+84 L0845: ADJSP 15,-1 POPJ 15,0 L0841: point 6,1,5 L0842: <30_30>+254 1 ; (!*ENTRY NEXPRP EXPR 1) NEXPRP: intern NEXPRP ADJSP 15,1 PUSHJ 15,SYMFNC+318 MOVEM 1,0(15) LDB 11,L0847 CAIN 11,9 JRST L0849 MOVE 1,0 JRST L0850 L0849: MOVE 1,SYMVAL+84 L0850: CAMN 1,0 JRST L0851 MOVE 1,0(15) MOVE 1,0(1) CAMN 1,L0848 JRST L0852 MOVE 1,0 JRST L0851 L0852: MOVE 1,SYMVAL+84 L0851: ADJSP 15,-1 POPJ 15,0 L0847: point 6,1,5 L0848: <30_30>+258 L0855: 28 byte(7)37,114,32,104,97,115,32,110,111,32,100,101,102,105,110,105,116,105,111,110,32,105,110,32,67,111,112,121,68,0 2 ; (!*ENTRY COPYD EXPR 2) COPYD: intern COPYD ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 1,2 PUSHJ 15,SYMFNC+318 MOVEM 1,-2(15) LDB 11,L0853 CAIE 11,9 JRST L0856 MOVE 3,1(1) MOVE 2,0(1) MOVE 1,0(15) PUSHJ 15,SYMFNC+251 JRST L0857 L0856: MOVE 2,-1(15) MOVE 1,L0854 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 L0857: MOVE 1,0(15) ADJSP 15,-3 POPJ 15,0 L0853: point 6,1,5 L0854: <4_30>+<1_18>+L0855 L0859: 1 1.0 0 1 ; (!*ENTRY RECIP EXPR 1) RECIP: intern RECIP MOVE 2,1 MOVE 1,L0858 JRST SYMFNC+242 L0858: <3_30>+<1_18>+L0859 1 ; (!*ENTRY MKQUOTE EXPR 1) L0861: intern L0861 MOVE 2,1 MOVE 1,L0860 JRST SYMFNC+249 L0860: <30_30>+246 1 ; (!*ENTRY FIRST MACRO 1) FIRST: intern FIRST MOVE 2,1(1) MOVE 1,L0862 JRST SYMFNC+151 L0862: <30_30>+187 1 ; (!*ENTRY SECOND MACRO 1) SECOND: intern SECOND MOVE 2,1(1) MOVE 1,L0863 JRST SYMFNC+151 L0863: <30_30>+224 1 ; (!*ENTRY THIRD MACRO 1) THIRD: intern THIRD MOVE 2,1(1) MOVE 1,L0864 JRST SYMFNC+151 L0864: <30_30>+209 1 ; (!*ENTRY FOURTH MACRO 1) FOURTH: intern FOURTH MOVE 2,1(1) MOVE 1,L0865 JRST SYMFNC+151 L0865: <30_30>+210 1 ; (!*ENTRY REST MACRO 1) REST: intern REST MOVE 2,1(1) MOVE 1,L0866 JRST SYMFNC+151 L0866: <30_30>+188 1 ; (!*ENTRY REVERSIP EXPR 1) L0868: intern L0868 MOVE 5,1 MOVE 4,0 MOVE 3,0 L0869: LDB 11,L0867 CAIE 11,9 JRST L0870 MOVE 1,1(5) MOVE 4,1 MOVE 2,5 MOVEM 3,1(2) MOVE 3,2 MOVE 5,1 JRST L0869 L0870: MOVE 1,3 POPJ 15,0 L0867: point 6,5,5 ; (!*ENTRY SUBSTIP1 EXPR 3) L0873: intern L0873 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 2,0(3) MOVE 1,-1(15) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0874 MOVE 7,-2(15) MOVE 6,0(15) MOVEM 6,0(7) JRST L0875 L0874: MOVE 6,-2(15) LDB 11,L0871 CAIE 11,9 JRST L0875 MOVE 3,-2(15) MOVE 3,0(3) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+330 L0875: MOVE 6,-2(15) LDB 11,L0872 CAIE 11,9 JRST L0876 MOVE 3,-2(15) MOVE 3,1(3) MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-3 JRST SYMFNC+330 L0876: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L0871: point 6,0(6),5 L0872: point 6,1(6),5 3 ; (!*ENTRY SUBSTIP EXPR 3) L0878: intern L0878 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) CAME 3,0 JRST L0879 MOVE 1,0 JRST L0880 L0879: MOVE 2,3 MOVE 1,-1(15) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0881 MOVE 1,0(15) JRST L0880 L0881: LDB 11,L0877 CAIE 11,9 JRST L0882 MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,L0873 L0882: MOVE 1,-2(15) L0880: ADJSP 15,-3 POPJ 15,0 L0877: point 6,-2(15),5 ; (!*ENTRY DELETIP1 EXPR 2) L0884: intern L0884 ADJSP 15,2 L0885: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0883 CAIE 11,9 JRST L0886 MOVE 2,1(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0887 MOVE 1,-1(15) MOVE 6,1(1) MOVE 6,1(6) MOVEM 6,1(1) JRST L0888 L0887: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0885 L0886: MOVE 1,0 L0888: ADJSP 15,-2 POPJ 15,0 L0883: point 6,1(2),5 2 ; (!*ENTRY DELETIP EXPR 2) L0890: intern L0890 PUSH 15,2 PUSH 15,1 LDB 11,L0889 CAIN 11,9 JRST L0891 MOVE 1,2 JRST L0892 L0891: MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0893 MOVE 1,-1(15) MOVE 1,1(1) JRST L0892 L0893: MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,L0884 MOVE 1,-1(15) L0892: ADJSP 15,-2 POPJ 15,0 L0889: point 6,2,5 2 ; (!*ENTRY DELQ EXPR 2) DELQ: intern DELQ PUSH 15,2 LDB 11,L0894 CAIN 11,9 JRST L0895 MOVE 1,2 JRST L0896 L0895: CAME 1,0(2) JRST L0897 MOVE 1,1(2) JRST L0896 L0897: MOVE 2,1(2) PUSHJ 15,DELQ MOVE 2,0(15) MOVE 2,0(2) ADJSP 15,-1 JRST SYMFNC+278 L0896: ADJSP 15,-1 POPJ 15,0 L0894: point 6,2,5 3 ; (!*ENTRY DEL EXPR 3) DEL: intern DEL ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L0898 CAIN 11,9 JRST L0899 MOVE 1,3 JRST L0900 L0899: MOVE 3,1 MOVE 1,-2(15) MOVE 1,0(1) MOVE 6,3 PUSHJ 15,SYMFNC+288 CAMN 1,0 JRST L0901 MOVE 1,-2(15) MOVE 1,1(1) JRST L0900 L0901: MOVE 3,-2(15) MOVE 3,1(3) MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,DEL MOVE 2,-2(15) MOVE 2,0(2) ADJSP 15,-3 JRST SYMFNC+278 L0900: ADJSP 15,-3 POPJ 15,0 L0898: point 6,3,5 ; (!*ENTRY DELQIP1 EXPR 2) L0903: intern L0903 L0904: LDB 11,L0902 CAIE 11,9 JRST L0905 MOVE 7,1(2) CAME 1,0(7) JRST L0906 MOVE 1,2 MOVE 6,1(1) MOVE 6,1(6) MOVEM 6,1(1) POPJ 15,0 L0906: MOVE 2,1(2) JRST L0904 L0905: MOVE 1,0 POPJ 15,0 L0902: point 6,1(2),5 2 ; (!*ENTRY DELQIP EXPR 2) DELQIP: intern DELQIP PUSH 15,2 LDB 11,L0907 CAIN 11,9 JRST L0908 MOVE 1,2 JRST L0909 L0908: CAME 1,0(2) JRST L0910 MOVE 1,1(2) JRST L0909 L0910: PUSHJ 15,L0903 MOVE 1,0(15) L0909: ADJSP 15,-1 POPJ 15,0 L0907: point 6,2,5 2 ; (!*ENTRY ATSOC EXPR 2) ATSOC: intern ATSOC L0913: LDB 11,L0911 CAIN 11,9 JRST L0914 MOVE 1,0 POPJ 15,0 L0914: LDB 11,L0912 CAIE 11,9 JRST L0915 MOVE 7,0(2) CAME 1,0(7) JRST L0915 MOVE 1,0(2) POPJ 15,0 L0915: MOVE 2,1(2) JRST L0913 L0911: point 6,2,5 L0912: point 6,0(2),5 3 ; (!*ENTRY ASS EXPR 3) ASS: intern ASS ADJSP 15,3 L0918: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L0916 CAIN 11,9 JRST L0919 MOVE 1,0 JRST L0920 L0919: LDB 11,L0917 CAIE 11,9 JRST L0921 MOVE 3,1 MOVE 2,-2(15) MOVE 2,0(2) MOVE 2,0(2) MOVE 1,-1(15) MOVE 6,3 PUSHJ 15,SYMFNC+288 CAMN 1,0 JRST L0921 MOVE 1,-2(15) MOVE 1,0(1) JRST L0920 L0921: MOVE 3,-2(15) MOVE 3,1(3) MOVE 2,-1(15) MOVE 1,0(15) JRST L0918 L0920: ADJSP 15,-3 POPJ 15,0 L0916: point 6,3,5 L0917: point 6,0(3),5 3 ; (!*ENTRY MEM EXPR 3) MEM: intern MEM ADJSP 15,3 L0923: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) LDB 11,L0922 CAIN 11,9 JRST L0924 MOVE 1,0 JRST L0925 L0924: MOVE 3,1 MOVE 2,-2(15) MOVE 2,0(2) MOVE 1,-1(15) MOVE 6,3 PUSHJ 15,SYMFNC+288 CAMN 1,0 JRST L0926 MOVE 1,-2(15) JRST L0925 L0926: MOVE 3,-2(15) MOVE 3,1(3) MOVE 2,-1(15) MOVE 1,0(15) JRST L0923 L0925: ADJSP 15,-3 POPJ 15,0 L0922: point 6,3,5 2 ; (!*ENTRY RASSOC EXPR 2) RASSOC: intern RASSOC ADJSP 15,2 L0929: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0927 CAIN 11,9 JRST L0930 MOVE 1,0 JRST L0931 L0930: LDB 11,L0928 CAIE 11,9 JRST L0932 MOVE 2,0(2) MOVE 2,1(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0932 MOVE 1,-1(15) MOVE 1,0(1) JRST L0931 L0932: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0929 L0931: ADJSP 15,-2 POPJ 15,0 L0927: point 6,2,5 L0928: point 6,0(2),5 2 ; (!*ENTRY DELASC EXPR 2) DELASC: intern DELASC PUSH 15,2 PUSH 15,1 LDB 11,L0933 CAIN 11,9 JRST L0935 MOVE 1,0 JRST L0936 L0935: LDB 11,L0934 CAIE 11,9 JRST L0937 MOVE 2,0(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0937 MOVE 1,-1(15) MOVE 1,1(1) JRST L0936 L0937: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,DELASC MOVE 2,-1(15) MOVE 2,0(2) ADJSP 15,-2 JRST SYMFNC+278 L0936: ADJSP 15,-2 POPJ 15,0 L0933: point 6,2,5 L0934: point 6,0(2),5 ; (!*ENTRY DELASCIP1 EXPR 2) L0940: intern L0940 ADJSP 15,2 L0941: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0938 CAIE 11,9 JRST L0942 MOVE 6,1(2) LDB 11,L0939 CAIE 11,9 JRST L0943 MOVE 2,1(2) MOVE 2,0(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0943 MOVE 1,-1(15) MOVE 6,1(1) MOVE 6,1(6) MOVEM 6,1(1) JRST L0944 L0943: MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) JRST L0941 L0942: MOVE 1,0 L0944: ADJSP 15,-2 POPJ 15,0 L0938: point 6,1(2),5 L0939: point 6,0(6),5 2 ; (!*ENTRY DELASCIP EXPR 2) L0947: intern L0947 PUSH 15,2 PUSH 15,1 LDB 11,L0945 CAIN 11,9 JRST L0948 MOVE 1,0 JRST L0949 L0948: LDB 11,L0946 CAIE 11,9 JRST L0950 MOVE 2,0(2) MOVE 2,0(2) PUSHJ 15,SYMFNC+198 CAMN 1,0 JRST L0950 MOVE 1,-1(15) MOVE 1,1(1) JRST L0949 L0950: MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,L0940 MOVE 1,-1(15) L0949: ADJSP 15,-2 POPJ 15,0 L0945: point 6,2,5 L0946: point 6,0(2),5 2 ; (!*ENTRY DELATQ EXPR 2) DELATQ: intern DELATQ ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L0951 CAIN 11,9 JRST L0953 MOVE 1,0 JRST L0954 L0953: MOVE 1,0(2) MOVEM 1,-2(15) LDB 11,L0952 CAIN 11,9 JRST L0955 MOVE 1,0 JRST L0956 L0955: MOVE 1,SYMVAL+84 L0956: CAMN 1,0 JRST L0957 MOVE 1,-2(15) MOVE 1,0(1) CAMN 1,0(15) JRST L0958 MOVE 1,0 JRST L0957 L0958: MOVE 1,SYMVAL+84 L0957: CAMN 1,0 JRST L0959 MOVE 1,1(2) JRST L0954 L0959: MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,DELATQ MOVE 2,-1(15) MOVE 2,0(2) ADJSP 15,-3 JRST SYMFNC+278 L0954: ADJSP 15,-3 POPJ 15,0 L0951: point 6,2,5 L0952: point 6,1,5 ; (!*ENTRY DELATQIP1 EXPR 2) L0962: intern L0962 L0963: LDB 11,L0960 CAIE 11,9 JRST L0964 MOVE 6,1(2) LDB 11,L0961 CAIE 11,9 JRST L0965 MOVE 7,1(2) MOVE 7,0(7) CAME 1,0(7) JRST L0965 MOVE 1,2 MOVE 6,1(1) MOVE 6,1(6) MOVEM 6,1(1) POPJ 15,0 L0965: MOVE 2,1(2) JRST L0963 L0964: MOVE 1,0 POPJ 15,0 L0960: point 6,1(2),5 L0961: point 6,0(6),5 2 ; (!*ENTRY DELATQIP EXPR 2) L0968: intern L0968 PUSH 15,2 LDB 11,L0966 CAIN 11,9 JRST L0969 MOVE 1,0 JRST L0970 L0969: LDB 11,L0967 CAIE 11,9 JRST L0971 MOVE 7,0(2) CAME 1,0(7) JRST L0971 MOVE 1,1(2) JRST L0970 L0971: PUSHJ 15,L0962 MOVE 1,0(15) L0970: ADJSP 15,-1 POPJ 15,0 L0966: point 6,2,5 L0967: point 6,0(2),5 2 ; (!*ENTRY SUBLA EXPR 2) SUBLA: intern SUBLA ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) LDB 11,L0972 CAIE 11,9 JRST L0974 CAME 2,0 JRST L0975 L0974: MOVE 1,2 JRST L0976 L0975: LDB 11,L0973 CAIN 11,9 JRST L0977 MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+335 MOVE 3,1 MOVEM 3,-2(15) CAMN 3,0 JRST L0978 MOVE 1,1(3) JRST L0976 L0978: MOVE 1,-1(15) JRST L0976 L0977: MOVE 2,0(2) PUSHJ 15,SUBLA MOVEM 1,-3(15) MOVE 2,-1(15) MOVE 2,1(2) MOVE 1,0(15) PUSHJ 15,SUBLA MOVE 2,-3(15) ADJSP 15,-4 JRST SYMFNC+278 L0976: ADJSP 15,-4 POPJ 15,0 L0972: point 6,1,5 L0973: point 6,2,5 2 ; (!*ENTRY RPLACW EXPR 2) RPLACW: intern RPLACW MOVE 3,2 LDB 11,L0979 CAIE 11,9 JRST L0982 LDB 11,L0980 CAIE 11,9 JRST L0983 MOVE 6,1(2) MOVEM 6,1(1) MOVE 6,0(2) MOVEM 6,0(1) POPJ 15,0 L0983: MOVE 2,L0981 MOVE 1,3 JRST L0984 L0982: MOVE 2,L0981 L0984: JRST SYMFNC+149 L0979: point 6,1,5 L0980: point 6,2,5 L0981: <30_30>+344 1 ; (!*ENTRY LASTCAR EXPR 1) L0986: intern L0986 LDB 11,L0985 CAIE 11,9 JRST L0987 PUSHJ 15,SYMFNC+346 MOVE 1,0(1) L0987: POPJ 15,0 L0985: point 6,1,5 1 ; (!*ENTRY LASTPAIR EXPR 1) L0990: intern L0990 L0991: LDB 11,L0988 CAIE 11,9 JRST L0992 LDB 11,L0989 CAIE 11,9 JRST L0992 MOVE 1,1(1) JRST L0991 L0992: POPJ 15,0 L0988: point 6,1,5 L0989: point 6,1(1),5 1 ; (!*ENTRY COPY EXPR 1) COPY: intern COPY ADJSP 15,2 MOVEM 1,0(15) LDB 11,L0993 CAIE 11,9 JRST L0994 MOVE 1,0(1) PUSHJ 15,COPY MOVEM 1,-1(15) MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,COPY MOVE 2,-1(15) ADJSP 15,-2 JRST SYMFNC+278 L0994: ADJSP 15,-2 POPJ 15,0 L0993: point 6,1,5 2 ; (!*ENTRY NTH EXPR 2) NTH: intern NTH PUSH 15,2 PUSH 15,1 PUSHJ 15,DOPNTH LDB 11,L0995 CAIE 11,9 JRST L0997 MOVE 1,0(1) JRST L0998 L0997: MOVE 3,L0996 MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+165 L0998: ADJSP 15,-2 POPJ 15,0 L0995: point 6,1,5 L0996: <30_30>+348 ; (!*ENTRY DOPNTH EXPR 2) DOPNTH: intern DOPNTH ADJSP 15,1 L1000: MOVEM 1,0(15) CAIN 2,1 JRST L1001 LDB 11,L0999 CAIE 11,9 JRST L1001 MOVE 1,2 PUSHJ 15,SYMFNC+349 MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) JRST L1000 L1001: ADJSP 15,-1 POPJ 15,0 L0999: point 6,1,5 2 ; (!*ENTRY PNTH EXPR 2) PNTH: intern PNTH ADJSP 15,1 L1004: MOVEM 1,0(15) CAIN 2,1 JRST L1005 LDB 11,L1002 CAIN 11,9 JRST L1006 MOVE 3,L1003 ADJSP 15,-1 JRST SYMFNC+165 L1006: MOVE 1,2 PUSHJ 15,SYMFNC+349 MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) JRST L1004 L1005: ADJSP 15,-1 POPJ 15,0 L1002: point 6,1,5 L1003: <30_30>+350 2 ; (!*ENTRY ACONC EXPR 2) ACONC: intern ACONC PUSH 15,1 MOVE 1,2 PUSHJ 15,SYMFNC+172 MOVE 2,1 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+291 2 ; (!*ENTRY TCONC EXPR 2) TCONC: intern TCONC ADJSP 15,2 MOVEM 1,0(15) MOVE 1,2 PUSHJ 15,SYMFNC+172 MOVEM 1,-1(15) LDB 11,L1007 CAIN 11,9 JRST L1008 MOVE 2,1 ADJSP 15,-2 JRST SYMFNC+278 L1008: MOVE 7,0(15) CAME 0,1(7) JRST L1009 MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) MOVE 6,-1(15) MOVEM 6,0(1) JRST L1010 L1009: MOVE 7,0(15) MOVE 7,1(7) MOVEM 1,1(7) MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) L1010: ADJSP 15,-2 POPJ 15,0 L1007: point 6,0(15),5 2 ; (!*ENTRY LCONC EXPR 2) LCONC: intern LCONC PUSH 15,2 PUSH 15,1 CAMN 2,0 JRST L1012 LDB 11,L1011 CAIN 11,9 JRST L1013 MOVE 1,2 PUSHJ 15,SYMFNC+346 MOVE 2,-1(15) ADJSP 15,-2 JRST SYMFNC+278 L1013: CAME 0,1(1) JRST L1014 MOVE 1,2 PUSHJ 15,SYMFNC+346 MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) MOVE 6,-1(15) MOVEM 6,0(1) JRST L1012 L1014: MOVE 7,1(1) MOVEM 2,1(7) MOVE 1,2 PUSHJ 15,SYMFNC+346 MOVE 7,0(15) MOVEM 1,1(7) MOVE 1,0(15) L1012: ADJSP 15,-2 POPJ 15,0 L1011: point 6,1,5 L1018: 29 byte(7)68,105,102,102,101,114,101,110,116,32,108,101,110,103,116,104,32,108,105,115,116,115,32,105,110,32,77,65,80,50,0 3 ; (!*ENTRY MAP2 EXPR 3) MAP2: intern MAP2 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) L1019: LDB 11,L1015 CAIE 11,9 JRST L1020 LDB 11,L1016 CAIN 11,9 JRST L1021 L1020: MOVE 1,0 JRST L1022 L1021: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 1,0(15) MOVE 6,3 PUSHJ 15,SYMFNC+288 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) MOVE 2,-1(15) MOVE 2,1(2) MOVEM 2,-1(15) JRST L1019 L1022: LDB 11,L1015 CAIN 11,9 JRST L1023 LDB 11,L1016 CAIE 11,9 JRST L1024 L1023: MOVE 1,L1017 ADJSP 15,-3 JRST SYMFNC+156 L1024: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1015: point 6,0(15),5 L1016: point 6,-1(15),5 L1017: <4_30>+<1_18>+L1018 L1028: 30 byte(7)68,105,102,102,101,114,101,110,116,32,108,101,110,103,116,104,32,108,105,115,116,115,32,105,110,32,77,65,80,67,50,0 3 ; (!*ENTRY MAPC2 EXPR 3) MAPC2: intern MAPC2 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) L1029: LDB 11,L1025 CAIE 11,9 JRST L1030 LDB 11,L1026 CAIN 11,9 JRST L1031 L1030: MOVE 1,0 JRST L1032 L1031: MOVE 3,-2(15) MOVE 2,-1(15) MOVE 2,0(2) MOVE 1,0(15) MOVE 1,0(1) MOVE 6,3 PUSHJ 15,SYMFNC+288 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) MOVE 2,-1(15) MOVE 2,1(2) MOVEM 2,-1(15) JRST L1029 L1032: LDB 11,L1025 CAIN 11,9 JRST L1033 LDB 11,L1026 CAIE 11,9 JRST L1034 L1033: MOVE 1,L1027 ADJSP 15,-3 JRST SYMFNC+156 L1034: MOVE 1,0 ADJSP 15,-3 POPJ 15,0 L1025: point 6,0(15),5 L1026: point 6,-1(15),5 L1027: <4_30>+<1_18>+L1028 2 ; (!*ENTRY CHANNELPRIN2T EXPR 2) L1035: intern L1035 PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+356 MOVE 1,0(15) PUSHJ 15,SYMFNC+309 MOVE 1,-1(15) ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY PRIN2T EXPR 1) PRIN2T: intern PRIN2T MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+355 2 ; (!*ENTRY CHANNELSPACES EXPR 2) L1036: intern L1036 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) HRRZI 6,1 MOVEM 6,-2(15) L1037: MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+238 PUSHJ 15,SYMFNC+239 CAMN 1,0 JRST L1038 MOVE 1,0 JRST L1039 L1038: HRRZI 2,32 MOVE 1,0(15) PUSHJ 15,SYMFNC+359 MOVE 1,-2(15) PUSHJ 15,SYMFNC+241 MOVEM 1,-2(15) JRST L1037 L1039: ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY SPACES EXPR 1) SPACES: intern SPACES MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+358 2 ; (!*ENTRY CHANNELTAB EXPR 2) L1040: intern L1040 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) PUSHJ 15,SYMFNC+362 MOVEM 1,-2(15) MOVE 2,1 MOVE 1,-1(15) PUSHJ 15,SYMFNC+282 CAMN 1,0 JRST L1041 MOVE 1,0(15) PUSHJ 15,SYMFNC+309 SETZM -2(15) L1041: MOVE 2,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+238 MOVE 2,1 MOVE 1,0(15) PUSHJ 15,SYMFNC+358 MOVE 1,0 ADJSP 15,-3 POPJ 15,0 1 ; (!*ENTRY TAB EXPR 1) TAB: intern TAB MOVE 2,1 MOVE 1,SYMVAL+311 JRST SYMFNC+361 1 ; (!*ENTRY FILEP EXPR 1) FILEP: intern FILEP MOVE 2,1 TLZ 2,258048 TLO 2,221184 HRLZI 1,32769 GTJFN JRST L1042 RLJFN JFCL MOVE 1,SYMVAL+84 POPJ 15,0 L1042: MOVE 1,0 POPJ 15,0 3 ; (!*ENTRY PUTC EXPR 3) PUTC: intern PUTC PUSH 15,1 PUSHJ 15,SYMFNC+300 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 1 ; (!*ENTRY LIST2SET EXPR 1) L1044: intern L1044 ADJSP 15,1 L1045: MOVEM 1,0(15) LDB 11,L1043 CAIN 11,9 JRST L1046 MOVE 1,0 JRST L1047 L1046: MOVE 2,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+302 CAMN 1,0 JRST L1048 MOVE 1,0(15) MOVE 1,1(1) JRST L1045 L1048: MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,L1044 MOVE 2,0(15) MOVE 2,0(2) ADJSP 15,-1 JRST SYMFNC+278 L1047: ADJSP 15,-1 POPJ 15,0 L1043: point 6,1,5 1 ; (!*ENTRY LIST2SETQ EXPR 1) L1050: intern L1050 PUSH 15,1 LDB 11,L1049 CAIN 11,9 JRST L1051 MOVE 1,0 JRST L1052 L1051: MOVE 2,1(1) MOVE 1,0(1) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L1053 MOVE 1,0(15) MOVE 1,1(1) ADJSP 15,-1 JRST SYMFNC+368 L1053: MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+368 MOVE 2,0(15) MOVE 2,0(2) ADJSP 15,-1 JRST SYMFNC+278 L1052: ADJSP 15,-1 POPJ 15,0 L1049: point 6,1,5 2 ; (!*ENTRY ADJOIN EXPR 2) ADJOIN: intern ADJOIN PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+302 CAMN 1,0 JRST L1054 MOVE 1,-1(15) JRST L1055 L1054: MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+151 L1055: ADJSP 15,-2 POPJ 15,0 2 ; (!*ENTRY ADJOINQ EXPR 2) L1056: intern L1056 PUSH 15,2 PUSH 15,1 PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L1057 MOVE 1,-1(15) JRST L1058 L1057: MOVE 2,-1(15) MOVE 1,0(15) ADJSP 15,-2 JRST SYMFNC+151 L1058: ADJSP 15,-2 POPJ 15,0 2 ; (!*ENTRY UNION EXPR 2) UNION: intern UNION ADJSP 15,2 L1060: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1059 CAIN 11,9 JRST L1061 MOVE 1,2 JRST L1062 L1061: MOVE 1,0(1) PUSHJ 15,SYMFNC+302 CAMN 1,0 JRST L1063 MOVE 1,-1(15) JRST L1064 L1063: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+151 L1064: MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) JRST L1060 L1062: ADJSP 15,-2 POPJ 15,0 L1059: point 6,1,5 2 ; (!*ENTRY UNIONQ EXPR 2) UNIONQ: intern UNIONQ ADJSP 15,2 L1066: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1065 CAIN 11,9 JRST L1067 MOVE 1,2 JRST L1068 L1067: MOVE 1,0(1) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L1069 MOVE 1,-1(15) JRST L1070 L1069: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+151 L1070: MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) JRST L1066 L1068: ADJSP 15,-2 POPJ 15,0 L1065: point 6,1,5 2 ; (!*ENTRY XN EXPR 2) XN: intern XN ADJSP 15,2 L1072: MOVEM 1,0(15) MOVEM 2,-1(15) LDB 11,L1071 CAIN 11,9 JRST L1073 MOVE 1,0 JRST L1074 L1073: MOVE 1,0(1) PUSHJ 15,SYMFNC+302 CAMN 1,0 JRST L1075 MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+301 MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,XN MOVE 2,0(15) MOVE 2,0(2) ADJSP 15,-2 JRST SYMFNC+278 L1075: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) JRST L1072 L1074: ADJSP 15,-2 POPJ 15,0 L1071: point 6,1,5 2 ; (!*ENTRY XNQ EXPR 2) XNQ: intern XNQ PUSH 15,2 PUSH 15,1 LDB 11,L1076 CAIN 11,9 JRST L1077 MOVE 1,0 JRST L1078 L1077: MOVE 1,0(1) PUSHJ 15,SYMFNC+303 CAMN 1,0 JRST L1079 MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+332 MOVE 2,1 MOVE 1,0(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+374 MOVE 2,0(15) MOVE 2,0(2) ADJSP 15,-2 JRST SYMFNC+278 L1079: MOVE 2,-1(15) MOVE 1,0(15) MOVE 1,1(1) ADJSP 15,-2 JRST SYMFNC+374 L1078: ADJSP 15,-2 POPJ 15,0 L1076: point 6,1,5 end |
Added psl-1983/3-1/kernel/20/randm.rel version [3d0df7eb37].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/scan-table.red version [ae5195dc73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SCAN-TABLE.RED - Lisp character table for DEC-20 % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 November 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>SCAN-TABLE.RED.6, 10-Feb-83 16:12:38, Edit by PERDUE % Changed the "put EOF" to be a STARTUPTIME form % Edit by Cris Perdue, 28 Jan 1983 2039-PST % LispDipthong -> LispDiphthong fluid '(LispScanTable!* CurrentScanTable!*); LispScanTable!* := ' [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LispDiphthong]; CurrentScanTable!* := LispScanTable!*; % Done as "startuptime" because "char" is available at compile % time but not necessarily init time /csp startuptime put('EOF, 'CharConst, char cntrl Z); END; |
Added psl-1983/3-1/kernel/20/symbl.ctl version [d75e60b60b].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "symbl"; PathIn "symbl.build"; ASMEnd; quit; compile symbl.mac, dsymbl.mac |
Added psl-1983/3-1/kernel/20/symbl.init version [a7ffc6f8bf].
Added psl-1983/3-1/kernel/20/symbl.log version [fa51bd88a3].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/symbl.mac version [d9094494c5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern BNDSTK extern L1255 extern L1825 extern L1256 L3349: 42 byte(7)42,42,42,42,42,32,66,105,110,100,105,110,103,32,115,116,97,99,107,32,111,118,101,114,102,108,111,119,44,32,114,101,115,116,97,114,116,105,110,103,46,46,46,0 0 ; (!*ENTRY BSTACKOVERFLOW EXPR 0) L3350: intern L3350 MOVE 2,L3348 MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+356 HRRZI 2,10 MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+359 JRST SYMFNC+536 L3348: <4_30>+<1_18>+L3349 L3352: 43 byte(7)42,42,42,42,42,32,66,105,110,100,105,110,103,32,115,116,97,99,107,32,117,110,100,101,114,102,108,111,119,44,32,114,101,115,116,97,114,116,105,110,103,46,46,46,0 0 ; (!*ENTRY BSTACKUNDERFLOW EXPR 0) L3353: intern L3353 MOVE 2,L3351 MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+356 HRRZI 2,10 MOVE 1,SYMVAL+476 PUSHJ 15,SYMFNC+359 JRST SYMFNC+536 L3351: <4_30>+<1_18>+L3352 0 ; (!*ENTRY CAPTUREENVIRONMENT EXPR 0) L3354: intern L3354 MOVE 1,L1256 POPJ 15,0 1 ; (!*ENTRY RESTOREENVIRONMENT EXPR 1) L3355: intern L3355 MOVE 3,1 CAML 1,L1255 JRST L3356 JRST SYMFNC+780 L3356: CAMGE 3,L1256 JRST L3357 MOVE 1,0 POPJ 15,0 L3357: MOVE 1,L1256 MOVE 2,-1(1) MOVE 6,0(1) MOVEM 6,SYMVAL(2) MOVNI 7,2 ADDM 7,L1256 JRST L3356 0 ; (!*ENTRY CLEARBINDINGS EXPR 0) L3358: intern L3358 MOVE 1,L1255 PUSHJ 15,SYMFNC+514 JRST SYMFNC+538 1 ; (!*ENTRY UNBINDN EXPR 1) L3359: intern L3359 MOVNS 1 LSH 1,1 ADD 1,L1256 JRST SYMFNC+514 L3363: 26 byte(7)84,32,97,110,100,32,78,73,76,32,99,97,110,110,111,116,32,98,101,32,114,101,98,111,117,110,100,0 L3364: 6 byte(7)98,105,110,100,105,110,103,0 2 ; (!*ENTRY LBIND1 EXPR 2) LBIND1: intern LBIND1 LDB 11,L3360 CAIN 11,30 JRST L3365 MOVE 2,L3361 JRST SYMFNC+130 L3365: CAMN 1,0 JRST L3366 CAME 1,SYMVAL+84 JRST L3367 L3366: MOVE 1,L3362 JRST SYMFNC+156 L3367: HRRZI 7,2 ADDM 7,L1256 MOVE 6,L1825 CAML 6,L1256 JRST L3368 JRST SYMFNC+513 L3368: TLZ 1,258048 MOVE 4,L1256 MOVEM 1,-1(4) MOVE 6,SYMVAL(1) MOVEM 6,0(4) MOVEM 2,SYMVAL(1) MOVE 1,2 POPJ 15,0 L3360: point 6,1,5 L3362: <4_30>+<1_18>+L3363 L3361: <4_30>+<1_18>+L3364 1 ; (!*ENTRY PBIND1 EXPR 1) PBIND1: intern PBIND1 MOVE 2,0 JRST SYMFNC+511 0 ; (!*ENTRY FASTBIND EXPR 0) L3369: intern L3369 MOVE 7,L1256 L3370: MOVE 6,0(10) TLNN 6,261632 JRST L3371 MOVEM 7,L1256 JRST 0(10) L3371: ADDI 7,2 CAML 7,L1825 JRST SYMFNC+513 HLRZ 8,6 CAILE 8,5 ADDI 8,L0002-6 HRRZM 6,-1(7) HRRZ 6,6 MOVE 9,SYMVAL(6) MOVEM 9,0(7) MOVE 8,0(8) MOVEM 8,SYMVAL(6) AOJA 10,L3370 0 ; (!*ENTRY FASTUNBIND EXPR 0) L3372: intern L3372 MOVE 6,L1256 MOVE 7,0(10) L3373: JUMPG 7,L3374 MOVEM 6,L1256 JRST 1(10) L3374: CAMGE 6,L1255 JRST SYMFNC+780 DMOVE 8,-1(6) MOVEM 9,SYMVAL(8) SUBI 6,2 SOJA 7,L3373 1 ; (!*ENTRY UNBOUNDP EXPR 1) L3378: intern L3378 LDB 11,L3375 CAIE 11,30 JRST L3379 MOVE 3,1 TLZ 3,258048 LDB 2,L3376 CAIE 2,29 JRST L3380 MOVE 1,SYMVAL+84 POPJ 15,0 L3380: MOVE 1,0 POPJ 15,0 L3379: MOVE 2,L3377 JRST SYMFNC+130 L3375: point 6,1,5 L3376: point 6,SYMVAL(3),5 L3377: <30_30>+766 1 ; (!*ENTRY MAKEUNBOUND EXPR 1) L3383: intern L3383 LDB 11,L3381 CAIE 11,30 JRST L3384 MOVE 2,1 TLZ 2,258048 MOVE 1,2 TLZ 1,258048 TLO 1,118784 MOVEM 1,SYMVAL(2) POPJ 15,0 L3384: MOVE 2,L3382 JRST SYMFNC+130 L3381: point 6,1,5 L3382: <30_30>+782 L3389: 18 byte(7)37,114,32,105,115,32,97,110,32,117,110,98,111,117,110,100,32,73,68,0 1 ; (!*ENTRY VALUECELL EXPR 1) L3390: intern L3390 PUSH 15,0 PUSH 15,1 LDB 11,L3385 CAIE 11,30 JRST L3391 MOVE 3,1 TLZ 3,258048 MOVE 6,SYMVAL(3) MOVEM 6,-1(15) LDB 2,L3386 CAIE 2,29 JRST L3392 MOVE 2,1 MOVE 1,L3387 PUSHJ 15,SYMFNC+155 MOVE 3,0(15) MOVE 2,1 HRRZI 1,99 ADJSP 15,-2 JRST SYMFNC+236 L3392: MOVE 1,-1(15) JRST L3393 L3391: MOVE 2,L3388 ADJSP 15,-2 JRST SYMFNC+130 L3393: ADJSP 15,-2 POPJ 15,0 L3385: point 6,1,5 L3386: point 6,-1(15),5 L3388: <30_30>+523 L3387: <4_30>+<1_18>+L3389 L3397: 22 byte(7)84,32,97,110,100,32,78,73,76,32,99,97,110,110,111,116,32,98,101,32,83,69,84,0 2 ; (!*ENTRY SET EXPR 2) SET: intern SET LDB 11,L3394 CAIE 11,30 JRST L3398 CAMN 1,0 JRST L3399 CAMN 1,SYMVAL+84 JRST L3399 MOVE 4,1 TLZ 4,258048 MOVEM 2,SYMVAL(4) MOVE 1,2 POPJ 15,0 L3399: MOVE 1,L3395 JRST SYMFNC+156 L3398: MOVE 2,L3396 JRST SYMFNC+130 L3394: point 6,1,5 L3396: <30_30>+262 L3395: <4_30>+<1_18>+L3397 L3404: 33 byte(7)84,104,101,32,110,117,108,108,32,115,116,114,105,110,103,32,99,97,110,110,111,116,32,98,101,32,105,110,116,101,114,110,101,100,0 ; (!*ENTRY ADDTOOBLIST EXPR 1) L3405: intern L3405 ADJSP 15,5 MOVEM 0,-1(15) MOVEM 0,-3(15) MOVE 2,1 TLZ 2,258048 MOVEM 2,-2(15) MOVE 1,SYMNAM(2) TLZ 1,258048 MOVEM 1,0(15) MOVE 6,0(1) LDB 3,L3400 TDNE 3,L3401 TDO 3,L3402 MOVEM 3,-4(15) JUMPGE 3,L3406 MOVE 1,L3403 ADJSP 15,-5 JRST SYMFNC+156 L3406: JUMPN 3,L3407 SETZM 2 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 HRLI 1,122880 JRST L3408 L3407: PUSHJ 15,L3409 MOVE 2,1 MOVEM 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3410 MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 HRLI 1,122880 JRST L3408 L3410: MOVE 3,-2(15) MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 MOVE 1,-4(15) PUSHJ 15,SYMFNC+385 MOVEM 1,-3(15) MOVE 2,0(15) PUSHJ 15,SYMFNC+394 MOVE 1,-3(15) TLZ 1,258048 TLO 1,16384 MOVE 7,-2(15) MOVEM 1,SYMNAM(7) MOVE 1,-2(15) HRLI 1,122880 L3408: ADJSP 15,-5 POPJ 15,0 L3400: point 30,6,35 L3401: 536870912 L3402: -536870912 L3403: <4_30>+<1_18>+L3404 L3415: 33 byte(7)84,104,101,32,110,117,108,108,32,115,116,114,105,110,103,32,99,97,110,110,111,116,32,98,101,32,105,110,116,101,114,110,101,100,0 ; (!*ENTRY LOOKUPORADDTOOBLIST EXPR 1) L3416: intern L3416 ADJSP 15,5 MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) TLZ 1,258048 MOVEM 1,0(15) MOVE 6,0(1) LDB 2,L3411 TDNE 2,L3412 TDO 2,L3413 MOVEM 2,-4(15) JUMPGE 2,L3417 MOVE 1,L3414 ADJSP 15,-5 JRST SYMFNC+156 L3417: JUMPN 2,L3418 SETZM 2 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 HRLI 1,122880 JRST L3419 L3418: PUSHJ 15,L3409 MOVE 2,1 MOVEM 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3420 MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 HRLI 1,122880 JRST L3419 L3420: PUSHJ 15,SYMFNC+389 MOVEM 1,-2(15) MOVE 3,1 MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 MOVE 1,-4(15) PUSHJ 15,SYMFNC+385 MOVEM 1,-3(15) MOVE 2,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC+394 MOVE 2,-3(15) TLZ 2,258048 TLO 2,16384 MOVE 1,-2(15) ADJSP 15,-5 JRST L3421 L3419: ADJSP 15,-5 POPJ 15,0 L3411: point 30,6,35 L3412: 536870912 L3413: -536870912 L3414: <4_30>+<1_18>+L3415 1 ; (!*ENTRY NEWID EXPR 1) NEWID: intern NEWID PUSH 15,1 PUSHJ 15,SYMFNC+389 MOVE 2,0(15) ADJSP 15,-1 JRST L3421 ; (!*ENTRY INITNEWID EXPR 2) L3421: intern L3421 ADJSP 15,1 MOVEM 2,SYMNAM(1) HRLI 1,122880 MOVEM 1,0(15) PUSHJ 15,SYMFNC+782 MOVE 2,0 MOVE 1,0(15) PUSHJ 15,SYMFNC+757 MOVE 1,0(15) PUSHJ 15,SYMFNC+753 MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 1 ; (!*ENTRY HASHFUNCTION EXPR 1) L3425: intern L3425 ADJSP 15,1 TLZ 1,258048 MOVEM 1,0(15) SETZM 4 MOVE 6,0(1) LDB 2,L3422 TDNE 2,L3423 TDO 2,L3424 MOVE 5,2 CAIG 2,28 JRST L3426 HRRZI 5,28 L3426: SETZM 3 L3427: CAMLE 3,5 JRST L3428 MOVE 2,3 MOVE 1,0(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 HRRZI 2,28 SUB 2,3 LSH 1,0(2) XOR 1,4 MOVE 4,1 AOS 3 JRST L3427 L3428: HRRZI 2,8209 MOVE 1,4 ADJSP 15,-1 IDIV 1,2 MOVE 1,2 POPJ 15,0 L3422: point 30,6,35 L3423: 536870912 L3424: -536870912 L3431: 14 byte(7)79,98,108,105,115,116,32,111,118,101,114,102,108,111,119,0 ; (!*ENTRY INOBLIST EXPR 1) L3409: intern L3409 ADJSP 15,4 MOVEM 1,0(15) PUSHJ 15,SYMFNC+783 MOVEM 1,-1(15) MOVEM 1,-3(15) SETOM -2(15) L3432: MOVE 2,-3(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 JUMPN 1,L3433 MOVE 6,-2(15) CAMN 6,L3429 JRST L3434 MOVE 1,-2(15) JRST L3435 L3434: MOVE 1,-3(15) JRST L3435 L3433: MOVE 2,-3(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 CAME 1,L3429 JRST L3436 MOVE 6,-2(15) CAME 6,L3429 JRST L3436 MOVE 6,-3(15) MOVEM 6,-2(15) JRST L3437 L3436: MOVE 2,-3(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 2,0(15) MOVE 1,SYMNAM(1) PUSHJ 15,SYMFNC+196 CAMN 1,0 JRST L3437 MOVE 1,-3(15) JRST L3435 L3437: MOVE 6,-3(15) CAIE 6,8209 JRST L3438 SETZM 1 JRST L3439 L3438: MOVE 1,-3(15) AOS 1 L3439: MOVEM 1,-3(15) CAME 1,-1(15) JRST L3432 MOVE 1,L3430 PUSHJ 15,SYMFNC+380 JRST L3432 L3435: ADJSP 15,-4 POPJ 15,0 L3429: -1 L3430: <4_30>+<1_18>+L3431 L3443: 11 byte(7)73,68,32,111,114,32,115,116,114,105,110,103,0 1 ; (!*ENTRY INTERN EXPR 1) INTERN: intern INTERN LDB 11,L3440 CAIE 11,30 JRST L3444 JRST L3405 L3444: LDB 11,L3440 CAIE 11,4 JRST L3445 JRST L3416 L3445: MOVE 3,L3441 MOVE 2,L3442 JRST SYMFNC+132 L3440: point 6,1,5 L3442: <30_30>+560 L3441: <4_30>+<1_18>+L3443 L3449: 7 byte(7)110,111,110,45,99,104,97,114,0 1 ; (!*ENTRY REMOB EXPR 1) REMOB: intern REMOB PUSH 15,0 PUSH 15,1 LDB 11,L3446 CAIN 11,30 JRST L3450 MOVE 2,L3447 ADJSP 15,-2 JRST SYMFNC+130 L3450: MOVE 2,1 TLZ 2,258048 MOVEM 2,-1(15) CAIL 2,128 JRST L3451 MOVE 3,L3448 MOVE 2,L3447 ADJSP 15,-2 JRST SYMFNC+132 L3451: MOVE 6,SYMNAM(2) MOVEM 6,-1(15) MOVE 1,-1(15) PUSHJ 15,L3409 MOVE 2,1 MOVEM 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3452 SETOM 3 MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 L3452: MOVE 1,0(15) ADJSP 15,-2 POPJ 15,0 L3446: point 6,1,5 L3448: <4_30>+<1_18>+L3449 L3447: <30_30>+784 1 ; (!*ENTRY INTERNP EXPR 1) L3457: intern L3457 PUSH 15,1 LDB 11,L3453 CAIE 11,30 JRST L3458 TLZ 1,258048 MOVEM 1,0(15) CAIGE 1,128 JRST L3459 MOVE 1,0 JRST L3460 L3459: MOVE 1,SYMVAL+84 L3460: CAME 1,0 JRST L3461 MOVE 1,0(15) MOVE 1,SYMNAM(1) PUSHJ 15,L3409 MOVE 2,1 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 CAME 1,0(15) JRST L3462 MOVE 1,SYMVAL+84 JRST L3461 L3458: LDB 11,L3453 CAIE 11,4 JRST L3462 MOVE 2,1 TLZ 2,258048 MOVE 6,0(2) LDB 1,L3454 TDNE 1,L3455 TDO 1,L3456 JUMPE 1,L3463 MOVE 1,0 JRST L3464 L3463: MOVE 1,SYMVAL+84 L3464: CAME 1,0 JRST L3461 MOVE 1,0(15) PUSHJ 15,L3409 MOVE 2,1 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 ADJSP 15,-1 JRST SYMFNC+237 L3462: MOVE 1,0 L3461: ADJSP 15,-1 POPJ 15,0 L3453: point 6,1,5 L3454: point 30,6,35 L3455: 536870912 L3456: -536870912 extern L3465 0 ; (!*ENTRY GENSYM EXPR 0) GENSYM: intern GENSYM HRRZI 1,4 PUSHJ 15,L3466 XMOVEI 1,L3465 PUSHJ 15,SYMFNC+395 JRST SYMFNC+649 ; (!*ENTRY GENSYM1 EXPR 1) L3466: intern L3466 L3467: MOVE 5,1 MOVE 4,0 JUMPLE 1,L3468 MOVE 2,1 XMOVEI 1,1+L3465 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,1 MOVE 4,2 CAIL 2,57 JRST L3469 MOVE 3,2 AOS 3 MOVE 2,5 XMOVEI 1,1+L3465 TLO 1,204800 ADJBP 2,1 DPB 3,2 POPJ 15,0 L3469: HRRZI 3,48 MOVE 2,5 XMOVEI 1,1+L3465 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,5 SOS 1 JRST L3467 L3468: SETZM 2 XMOVEI 1,1+L3465 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 3,1 AOS 3 SETZM 2 XMOVEI 1,1+L3465 TLO 1,204800 ADJBP 2,1 DPB 3,2 HRRZI 1,4 JRST L3467 0 ; (!*ENTRY INTERNGENSYM EXPR 0) L3470: intern L3470 HRRZI 1,4 PUSHJ 15,L3466 XMOVEI 1,L3465 TLZ 1,258048 TLO 1,16384 JRST SYMFNC+560 1 ; (!*ENTRY MAPOBL EXPR 1) MAPOBL: intern MAPOBL PUSH 15,L3471 PUSH 15,1 L3472: MOVE 6,-1(15) CAIG 6,127 JRST L3473 SETZM 1 JRST L3474 L3473: MOVE 2,0(15) MOVE 1,-1(15) HRLI 1,122880 MOVE 6,2 PUSHJ 15,SYMFNC+288 AOS -1(15) JRST L3472 L3474: SETZM -1(15) L3475: MOVE 6,-1(15) CAIG 6,8209 JRST L3476 SETZM 1 JRST L3477 L3476: MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3478 MOVE 2,-1(15) XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 2,0(15) HRLI 1,122880 MOVE 6,2 PUSHJ 15,SYMFNC+288 L3478: AOS -1(15) JRST L3475 L3477: ADJSP 15,-2 POPJ 15,0 L3471: 0 extern L3479 1 ; (!*ENTRY GLOBALLOOKUP EXPR 1) L3482: intern L3482 LDB 11,L3480 CAIN 11,4 JRST L3483 MOVE 2,L3481 JRST SYMFNC+143 L3483: PUSHJ 15,L3409 MOVE 2,1 MOVEM 2,L3479 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 SETZM 2 PUSHJ 15,SYMFNC+237 CAMN 1,0 JRST L3484 MOVE 2,L3479 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 HRLI 1,122880 POPJ 15,0 L3484: SETZM 1 POPJ 15,0 L3480: point 6,1,5 L3481: <30_30>+788 1 ; (!*ENTRY GLOBALINSTALL EXPR 1) L3488: intern L3488 ADJSP 15,3 MOVEM 1,0(15) MOVEM 0,-2(15) PUSHJ 15,SYMFNC+788 MOVEM 1,-1(15) JUMPN 1,L3489 PUSHJ 15,SYMFNC+389 MOVEM 1,-1(15) MOVE 3,1 MOVE 2,L3479 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L3485 TDNE 1,L3486 TDO 1,L3487 PUSHJ 15,SYMFNC+385 MOVEM 1,-2(15) MOVE 2,0(15) TLZ 2,258048 PUSHJ 15,SYMFNC+394 MOVE 2,-2(15) TLZ 2,258048 TLO 2,16384 MOVE 1,-1(15) ADJSP 15,-3 JRST L3421 L3489: ADJSP 15,-3 POPJ 15,0 L3485: point 30,6,35 L3486: 536870912 L3487: -536870912 1 ; (!*ENTRY GLOBALREMOVE EXPR 1) L3490: intern L3490 ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+788 MOVEM 1,-1(15) JUMPN 1,L3491 SETZM 1 JRST L3492 L3491: MOVE 2,L3479 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVEM 1,-1(15) SETOM 3 MOVE 2,L3479 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 MOVE 1,-1(15) HRLI 1,122880 L3492: ADJSP 15,-2 POPJ 15,0 0 ; (!*ENTRY INITOBLIST EXPR 0) L3493: intern L3493 ADJSP 15,2 MOVE 1,L0001 SOS 1 MOVEM 1,0(15) HRRZI 6,128 MOVEM 6,-1(15) L3494: MOVE 6,-1(15) CAMLE 6,0(15) JRST L3495 MOVE 1,-1(15) MOVE 1,SYMNAM(1) PUSHJ 15,L3409 MOVE 3,-1(15) MOVE 2,1 XMOVEI 1,L0003 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -1(15) JRST L3494 L3495: MOVE 1,0 ADJSP 15,-2 POPJ 15,0 end |
Added psl-1983/3-1/kernel/20/symbl.rel version [d79daa7c9c].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/sys-io.red version [e2031dcf87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-IO.RED - System dependent IO routines for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 September 1981 % Copyright (c) 1981 University of Utah % % 21-May-1983 Mark R. Swanson % Replace local byte pointers with one-word global byte pointers global '(IN!* OUT!*); LoadTime << IN!* := 0; OUT!* := 1; >>; fluid '(StdIN!* StdOUT!* ErrOUT!* !*Echo); LoadTime << StdIN!* := 0; StdOUT!* := 1; ErrOUT!* := 1; >>; CompileTime flag('(RDTTY FindFreeChannel Dec20Open ContOpenError ClearIO1), 'InternalFunction); on SysLisp; external WArray JFNOfChannel, ReadFunction, WriteFunction, CLoseFunction; Internal WString Chn1Buf[100]; Internal WString Chn2Buf[100]; Internal WString Chn3Buf[100]; Internal WString Chn4Buf[100]; Internal WString Chn5Buf[100]; Internal WString Chn6Buf[100]; Internal WString Chn7Buf[100]; Internal WString Chn8Buf[100]; Internal WString Chn9Buf[100]; Internal WString Chn10Buf[100]; Internal Warray buffer-pointer[MaxChannels], in-buffer = [Chn1Buf, Chn2Buf, Chn3Buf, Chn4Buf, Chn5Buf, Chn6Buf, Chn7Buf, Chn8Buf, Chn9Buf, Chn10Buf]; if_system(Tops20, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); if_system(Tenex, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (cain (reg 2) (WConst 8#37)) % TENEX EOL (!*MOVE (WConst 8#12) (reg 2)) % replace it with a linefeed (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); lap '((!*entry Dec20WriteChar expr 2) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) % get JFN for channel (!*JUMPEQ (Label CRLF) (reg 2) (WConst 8#12)) % if LF, echo CRLF (bout) % no, just echo char (!*EXIT 0) % return CRLF (!*MOVE (WConst 8#15) (reg 2)) % write carriage-return (bout) (!*MOVE (WConst 8#12) (reg 2)) % write linefeed (bout) (!*EXIT 0) % return ); internal WConst MaxTerminalBuffer = 200; internal WVar NextTerminalChar = 1; internal WString TerminalInputBuffer[MaxTerminalBuffer]; lap '((!*entry ClearIO1 expr 0) % % ^C from RDTTY and restart causes trouble, but we don't want a full RESET % (don't want to close files or kill forks), so we'll just do the % part of RESET that we want, for terminal input % (!*MOVE (WConst 8#100) (reg 1)) % .priin (rfmod) (tro 2 2#001111100001000000) % tt%wak + tt%eco + .ttasi, like RESET (sfmod) (!*EXIT 0) ); syslsp procedure ClearIO(); << ClearIO1(); TerminalInputBuffer[0] := -1; NextTerminalChar := 0; LispVar IN!* := LispVar STDIN!*; LispVar OUT!* := LispVar STDOUT!* >>; if_system(Tops20, lap '((!*entry RDTTY expr 3) (dmove (reg t1) (reg 1)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (dmove (reg 1) (reg t1)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (!*MkItem (reg 1) 8#61) % (globalize it) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (!*MkItem (reg 3) 8#61) % (globalize it) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf (jsys 8#523) % RDTTY (!*JUMP (Label CantRDTTY)) (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) CantRDTTY (!*MOVE (QUOTE "Can't read from terminal") (reg 1)) (!*JCALL IOError) )); if_system(Tenex, lap '((!*entry RDTTY expr 3) (move (reg t1) (reg 1)) (move (reg t2) (reg 2)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (move (reg 1) (reg t1)) (move (reg 2) (reg t2)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (hrli (reg 1) 8#440700) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (hrli (reg 3) 8#440700) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) % (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf % (jsys 8#523) % RDTTY % (!*JUMP (Label CantRDTTY)) (!*MOVE (WConst MaxTerminalBuffer) (reg 2)) % # of chars (setz 3 0) % clear 3 (jsys 8#611) % PSTIN, IMSSS JSYS (!*MOVE (WConst 8#12) (reg 3)) % put linefeed at end of buffer (dpb (reg 3) (reg 1)) % 1 points to end of what's been read (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) )); syslsp procedure TerminalInputHandler Chn; begin scalar Ch; while NextTerminalChar >= StrLen TerminalInputBuffer do << NextTerminalChar := 0; TerminalInputBuffer[0] := RDTTY(TerminalInputBuffer, MaxTerminalBuffer, if StringP LispVar PromptString!* then LispVar PromptString!* else ">") >>; Ch := StrByt(TerminalInputBuffer, NextTerminalChar); NextTerminalChar := NextTerminalChar + 1; return Ch; end; syslsp procedure FindFreeChannel(); begin scalar Chn; Chn := 0; while JfnOfChannel[Chn] neq 0 do << if Chn >= MaxChannels then IOError("No free channels left"); Chn := Chn + 1 >>; return Chn; end; syslsp procedure SystemMarkAsClosedChannel FileDes; JFNOfChannel[IntInf FileDes] := 0; lap '((!*entry Dec20CloseChannel expr 1) (!*MOVE (reg 1) (reg 2)) % save in case of error (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) (closf) (!*JUMP (Label CloseError)) (!*EXIT 0) CloseError (!*MOVE (QUOTE "Channel could not be closed") (reg 1)) (!*JCALL ChannelError) ); syslsp procedure SystemOpenFileSpecial FileName; << JFNOfChannel[FileName := FindFreeChannel()] := -1; FileName >>; syslsp procedure SystemOpenFileForInput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 7*of%bsz of%rd 2#000111000000000000010000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'INPUT); JFNOfChannel[Chn] := JFN; ReadFunction[Chn] := 'Dec20ReadChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; syslsp procedure SystemOpenFileForOutput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 7*of%bsz of%wr 2#000111000000000000001000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'OUTPUT); JFNOfChannel[Chn] := JFN; WriteFunction[Chn] := 'Dec20WriteChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; lap '((!*entry Dec20Open expr 3) % % Dec20Open(Filename string, GTJFN bits, OPENF bits) % (!*WPLUS2 (reg 1) (WConst 1)) % increment r1 to point to characters (!*MkItem (reg 1) 8#61) % (globalize it) (!*MOVE (reg 1) (reg 4)) % save filename string in r4 (!*MOVE (reg 2) (reg 1)) % GTJFN flag bits in r1 (!*MOVE (reg 4) (reg 2)) % string in r2 (gtjfn) (!*JUMP (Label CantOpen)) (!*MOVE (reg 3) (reg 2)) % OPENF bits in r2, JFN in r1 (openf) CantOpen (!*MOVE (WConst 0) (reg 1)) % return 0 on error (!*EXIT 0) % else return the JFN ); off SysLisp; lisp procedure ContOpenError(FileName, AccessMode); ContinuableError(99, BldMsg("`%s' cannot be open for %w", FileName, AccessMode), list('OPEN, MkSTR FileName, MkQuote AccessMode)); END; |
Added psl-1983/3-1/kernel/20/sysio.ctl version [d6060cc024].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "sysio"; PathIn "sysio.build"; ASMEnd; quit; compile sysio.mac, dsysio.mac |
Added psl-1983/3-1/kernel/20/sysio.init version [8719f1db79].
> > > | 1 2 3 | (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!* ERROUT!* !*ECHO))) (FLUID (QUOTE (LISPSCANTABLE!* CURRENTSCANTABLE!*))) |
Added psl-1983/3-1/kernel/20/sysio.log version [c4e384fe59].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/sysio.mac version [a275b39284].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern L2260 extern L2253 extern L2254 extern L2255 L3497: 31 byte(7)65,116,116,101,109,112,116,32,116,111,32,114,101,97,100,32,102,114,111,109,32,102,105,108,101,32,102,97,105,108,101,100,0 1 ; (!*ENTRY DEC20READCHAR EXPR 1) L3498: intern L3498 MOVE 1,L2260(1) L3499: BIN ERJMP L3500 JUMPE 2,L3499 CAIN 2,13 JRST L3499 MOVE 1,2 CAMN 0,SYMVAL+793 POPJ 15,0 PUSH 15,1 PUSHJ 15,SYMFNC+467 POP 15,1 POPJ 15,0 L3500: GTSTS TLNN 2,512 JRST L3501 HRRZI 1,26 POPJ 15,0 L3501: MOVE 1,L3496 JRST SYMFNC+507 L3496: <4_30>+<1_18>+L3497 2 ; (!*ENTRY DEC20WRITECHAR EXPR 2) L3502: intern L3502 MOVE 1,L2260(1) CAIN 2,10 JRST L3503 BOUT POPJ 15,0 L3503: HRRZI 2,13 BOUT HRRZI 2,10 BOUT POPJ 15,0 extern L3504 extern L3505 ; (!*ENTRY CLEARIO1 EXPR 0) L3506: intern L3506 HRRZI 1,64 RFMOD TRO 2,63552 SFMOD POPJ 15,0 0 ; (!*ENTRY CLEARIO EXPR 0) L3507: intern L3507 PUSHJ 15,L3506 SETOM L3505 SETZM L3504 MOVE 6,SYMVAL+616 MOVEM 6,SYMVAL+600 MOVE 1,SYMVAL+618 MOVEM 1,SYMVAL+311 POPJ 15,0 L3509: 23 byte(7)67,97,110,39,116,32,114,101,97,100,32,102,114,111,109,32,116,101,114,109,105,110,97,108,0 ; (!*ENTRY RDTTY EXPR 3) RDTTY: intern RDTTY DMOVE 6,1 HRRZI 1,65 RFMOD TLZE 2,131072 SFMOD DMOVE 1,6 MOVE 4,2 AOS 1 TLZ 1,258048 TLO 1,200704 AOS 3 TLZ 3,258048 TLO 3,200704 MOVE 5,1 MOVE 1,3 PSOUT MOVE 1,5 HRLI 2,24576 JSYS 339 JRST L3510 MOVE 1,4 HRRZS 2 SUB 1,2 POPJ 15,0 L3510: MOVE 1,L3508 JRST SYMFNC+507 L3508: <4_30>+<1_18>+L3509 L3516: 0 byte(7)62,0 1 ; (!*ENTRY TERMINALINPUTHANDLER EXPR 1) L3517: intern L3517 PUSH 15,0 PUSH 15,1 L3518: MOVE 6,L3505 LDB 1,L3511 TDNE 1,L3512 TDO 1,L3513 CAMLE 1,L3504 JRST L3519 SETZM L3504 LDB 11,L3514 CAIE 11,4 JRST L3520 MOVE 1,SYMVAL+442 JRST L3521 L3520: MOVE 1,L3515 L3521: MOVE 3,1 HRRZI 2,200 XMOVEI 1,L3505 PUSHJ 15,RDTTY MOVEM 1,L3505 JRST L3518 L3519: MOVE 2,L3504 XMOVEI 1,1+L3505 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVEM 1,-1(15) AOS L3504 ADJSP 15,-2 POPJ 15,0 L3511: point 30,6,35 L3512: 536870912 L3513: -536870912 L3514: point 6,<SYMVAL+442>,5 L3515: <4_30>+<1_18>+L3516 L3524: 20 byte(7)78,111,32,102,114,101,101,32,99,104,97,110,110,101,108,115,32,108,101,102,116,0 ; (!*ENTRY FINDFREECHANNEL EXPR 0) L3525: intern L3525 PUSH 15,L3522 L3526: MOVE 7,0(15) SKIPN L2260(7) JRST L3527 MOVE 6,0(15) CAIGE 6,31 JRST L3528 MOVE 1,L3523 PUSHJ 15,SYMFNC+507 L3528: AOS 0(15) JRST L3526 L3527: MOVE 1,0(15) ADJSP 15,-1 POPJ 15,0 L3522: 0 L3523: <4_30>+<1_18>+L3524 1 ; (!*ENTRY SYSTEMMARKASCLOSEDCHANNEL EXPR 1) L3529: intern L3529 SETZM L2260(1) SETZM 1 POPJ 15,0 L3531: 26 byte(7)67,104,97,110,110,101,108,32,99,111,117,108,100,32,110,111,116,32,98,101,32,99,108,111,115,101,100,0 1 ; (!*ENTRY DEC20CLOSECHANNEL EXPR 1) L3532: intern L3532 MOVE 2,1 MOVE 1,L2260(1) CLOSF JRST L3533 POPJ 15,0 L3533: MOVE 1,L3530 JRST SYMFNC+503 L3530: <4_30>+<1_18>+L3531 1 ; (!*ENTRY SYSTEMOPENFILESPECIAL EXPR 1) L3534: intern L3534 PUSHJ 15,L3525 MOVE 3,1 SETOM L2260(3) MOVE 1,3 POPJ 15,0 1 ; (!*ENTRY SYSTEMOPENFILEFORINPUT EXPR 1) L3538: intern L3538 ADJSP 15,3 MOVEM 1,0(15) PUSHJ 15,L3525 MOVEM 1,-1(15) MOVE 3,[7516258304] MOVE 2,[8590196736] MOVE 1,0(15) PUSHJ 15,L3539 MOVEM 1,-2(15) JUMPN 1,L3540 MOVE 2,L3535 MOVE 1,0(15) ADJSP 15,-3 JRST L3541 L3540: MOVE 7,-1(15) MOVEM 1,L2260(7) MOVE 7,-1(15) MOVE 6,L3536 MOVEM 6,L2253(7) MOVE 7,-1(15) MOVE 6,L3537 MOVEM 6,L2255(7) MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L3537: <30_30>+795 L3536: <30_30>+792 L3535: <30_30>+612 1 ; (!*ENTRY SYSTEMOPENFILEFOROUTPUT EXPR 1) L3545: intern L3545 ADJSP 15,3 MOVEM 1,0(15) PUSHJ 15,L3525 MOVEM 1,-1(15) MOVE 3,[7516225536] MOVE 2,[-17179607040] MOVE 1,0(15) PUSHJ 15,L3539 MOVEM 1,-2(15) JUMPN 1,L3546 MOVE 2,L3542 MOVE 1,0(15) ADJSP 15,-3 JRST L3541 L3546: MOVE 7,-1(15) MOVEM 1,L2260(7) MOVE 7,-1(15) MOVE 6,L3543 MOVEM 6,L2254(7) MOVE 7,-1(15) MOVE 6,L3544 MOVEM 6,L2255(7) MOVE 1,-1(15) ADJSP 15,-3 POPJ 15,0 L3544: <30_30>+795 L3543: <30_30>+593 L3542: <30_30>+611 ; (!*ENTRY DEC20OPEN EXPR 3) L3539: intern L3539 AOS 1 TLZ 1,258048 TLO 1,200704 MOVE 4,1 MOVE 1,2 MOVE 2,4 GTJFN JRST L3547 MOVE 2,3 OPENF L3547: SETZM 1 POPJ 15,0 L3550: 25 byte(7)96,37,115,39,32,99,97,110,110,111,116,32,98,101,32,111,112,101,110,32,102,111,114,32,37,119,0 ; (!*ENTRY CONTOPENERROR EXPR 2) L3541: intern L3541 ADJSP 15,3 MOVEM 1,0(15) MOVEM 2,-1(15) MOVE 3,2 MOVE 2,1 MOVE 1,L3548 PUSHJ 15,SYMFNC+155 MOVEM 1,-2(15) MOVE 1,-1(15) PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,0(15) TLZ 2,258048 TLO 2,16384 MOVE 1,L3549 PUSHJ 15,SYMFNC+235 MOVE 3,1 MOVE 2,-2(15) HRRZI 1,99 ADJSP 15,-3 JRST SYMFNC+236 L3549: <30_30>+603 L3548: <4_30>+<1_18>+L3550 end |
Added psl-1983/3-1/kernel/20/sysio.rel version [e3a42f1e0d].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/system-extras.red version [5611c0d343].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-EXTRAS.RED - System-specific functions for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 4 March 1982 % Copyright (c) 1982 University of Utah % % 21-May-83 Mark R. Swanson % Made local byte pointer into global byte pointer in DATE; changed % ReturnAddressP to use only low halfword of value in SYMFNC table. % <PSL.KERNEL-20>SYSTEM-EXTRAS.RED.3, 5-Jan-83 16:46:34, Edit by PERDUE % Added ExitLISP, for the DEC-20 a synonym of QUIT fluid '(system_list!*); if_system(Tenex, if_system(KL10, system_list!* := '(Dec20 PDP10 Tenex KL10), system_list!* := '(Dec20 PDP10 Tenex)), system_list!* := '(Dec20 PDP10 Tops20 KL10)); lap '((!*entry Quit expr 0) (haltf) (!*MOVE '"Continued" (reg 1)) (!*EXIT 0) ); CopyD('ExitLISP, 'Quit); lap '((!*entry Date expr 0) (!*MOVE (WConst 8) (reg 1)) % allocate a 9 character string (!*CALL GtStr) (!*MOVE (reg 1) (reg 4)) % save it in 4 (!*WPLUS2 (reg 1) (WConst 1)) (tlo 1 8#610000) % create a byte pointer to it (!*MOVE (WConst -1) (reg 2)) % current date (hrlzi (reg 3) 2#0000000001) % ot%ntm, don't output time (odtim) (!*MOVE (reg 4) (reg 1)) (!*MKITEM (reg 1) (WConst STR)) % tag it as a string (!*EXIT 0) ); if_system(KL10, NIL, lap '((!*Entry StackOverflow expr 0) (sub (reg ST) (lit (halfword 1000 1000))) % back up stack (!*MOVE '"Stack overflow" (reg 1)) (!*JCALL StdError) )); on SysLisp; syslsp procedure ReturnAddressP X; begin scalar Y, Z; Z := Field(&SymFnc, 18, 18); % don't want any opcode bits in Z % may someday want to use 23 bits, though. return Field(X, 0, 18) = 2#011001000000000000 % PC flags and Field(@(X - 1), 0, 18) = 8#260740 % pushj 17, and (Y := Field(@(X - 1), 18, 18) - Z) > 0 and Y < MaxSymbols and MkID Y; end; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/system-faslin.red version [a8d335b096].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-FASLIN.RED - Functions needed by faslin % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 April 1982 % Copyright (c) 1982 University of Utah % % 21-May-83 Mark R. Swanson % Changed reference to &SYMFNC in FunctionCellLocation to be an explicit % array reference. % <PSL.KERNEL-20>SYSTEM-FASLIN.RED.4, 7-Oct-82 13:37:56, Edit by BENSON % Changed 0 byte size to 36 byte size, for Tenex compatibility on Syslisp; syslsp procedure BinaryOpenRead FileName; begin scalar F; F := Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 36*of%bsz of%rd 2#100100000000000000010000000000000000); return if F eq 0 then ContError(99, "Couldn't open binary file for input", BinaryOpenRead FileName) else F; end; syslsp procedure BinaryOpenWrite FileName; begin scalar F; F := Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 36*of%bsz of%wr 2#100100000000000000001000000000000000); return if F eq 0 then ContError(99, "Couldn't open binary file for output", BinaryOpenWrite FileName) else F; end; syslsp procedure ValueCellLocation X; if not LispVar !*WritingFaslFile then &SymVal IDInf X else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_VALUE_CELL, FindIDNumber X) >>; syslsp procedure ExtraRegLocation X; << X := second X; if not LispVar !*WritingFaslFile then &ArgumentBlock[X - (MaxRealRegs + 1)] else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_VALUE_CELL, X + 8150) >> >>; syslsp procedure FunctionCellLocation X; if not LispVar !*WritingFaslFile then &SymFnc[IDInf X] % different from VALUECELLLOCATION because of % strange interaction with SymFnc as a function? else << LispVar NewBitTableEntry!* := const RELOC_HALFWORD; MakeRelocHalfWord(const RELOC_FUNCTION_CELL, FindIDNumber X) >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/20/system-faslout.red version [d4f1887ed7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-FASLOUT.RED - 20-specific stuff for FASL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 February 1982 % Copyright (c) 1982 University of Utah % % 21-May-1983 Mark R. Swanson % Changed FASL_MAGIC_NUMBER to 2099 to differentiate Extended-20 fasl % files from one-section fasl files. CompileTime DefConst(AddressingUnitsPerItem, 1, BitTableEntriesPerWord, 18, FASL_MAGIC_NUMBER, 2099, RELOC_ID_NUMBER, 1, RELOC_VALUE_CELL, 2, RELOC_FUNCTION_CELL, 3, RELOC_WORD, 1, RELOC_HALFWORD, 2, RELOC_INF, 3); on SysLisp; CompileTime << smacro procedure RelocRightHalfTag X; Field(X, 18, 2); smacro procedure RelocRightHalfInf X; Field(X, 20, 16); smacro procedure RelocInfTag X; Field(X, 18, 2); smacro procedure RelocInfInf X; Field(X, 20, 16); smacro procedure RelocWordTag X; Field(X, 0, 2); smacro procedure RelocWordInf X; Field(X, 2, 34); smacro procedure PutRightHalf(Where, What); PutField(Where, 18, 18, What); put('RightHalf, 'Assign!-Op, 'PutRightHalf); >>; CompileTime DefList('((BinaryWrite ((bout))) (BinaryRead ((bin) (move (reg 1) (reg 2)))) (BinaryClose ((closf) (jfcl))) (BinaryWriteBlock % ((hrli (reg 2) 8#740000) % point 18, % (movns (reg 3)) % (lsh 3,1) % times 2 % for extended addressing, the following code should only work if it and % the input buffer are in the same section, otherwise, something like the % above must be implemented, i.e., a global byte pointer would be needed. % ((hrli (reg 2) 8#444400) % point 36, (movns (reg 3)) (sout))) (BinaryReadBlock ((hrli (reg 2) 8#444400) % point 36, (movns (reg 3)) (sin)))), 'OpenCode); off Syslisp; END; |
Added psl-1983/3-1/kernel/20/system-gc.red version [07c4c09533].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-GC.RED - System dependent before and after GC hooks % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 March 1982 % Copyright (c) 1982 University of Utah % % 21-May-1983 Mark R. Swanson % Unmap old heap space after copying GC has been called, so we don't % occupy as much swapping space. on Syslisp; CompileTime << external WVar OldHeapLast, OldHeapLowerBound, OldHeapUpperBound; syslsp smacro procedure BeforeGCSystemHook(); NIL; syslsp smacro procedure AfterGCSystemHook(); % Unmap all of old heap except first page, which is assumed to be the first % page in a section; else after a savesystem, sections with no pages will % not exist (and we don't want to re-create them). unmap!-space( OldHeapLowerBound + 1,OldHeapLast+8#1777); >>; off Syslisp; END; |
Added psl-1983/3-1/kernel/20/system-io.red version [eb1368d14d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-IO.RED - System dependent IO routines for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 September 1981 % Copyright (c) 1981 University of Utah % % 21-May-1983 Mark R. Swanson % Replace local byte pointers with one-word global byte pointers global '(IN!* OUT!*); LoadTime << IN!* := 0; OUT!* := 1; >>; fluid '(StdIN!* StdOUT!* ErrOUT!* !*Echo); LoadTime << StdIN!* := 0; StdOUT!* := 1; ErrOUT!* := 1; >>; CompileTime flag('(RDTTY FindFreeChannel Dec20Open ContOpenError ClearIO1), 'InternalFunction); on SysLisp; external WArray JFNOfChannel, ReadFunction, WriteFunction, CLoseFunction; if_system(Tops20, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); if_system(Tenex, lap '((!*entry Dec20ReadChar expr 1) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) Loop % get JFN for channel (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (cain (reg 2) (WConst 8#37)) % TENEX EOL (!*MOVE (WConst 8#12) (reg 2)) % replace it with a linefeed (!*MOVE (reg 2) (reg 1)) % move char to reg 1 (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char (!*PUSH (reg 1)) % yes, save char (!*CALL WriteChar) % and write it (!*POP (reg 1)) % restore it (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) )); lap '((!*entry Dec20WriteChar expr 2) (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) % get JFN for channel (!*JUMPEQ (Label CRLF) (reg 2) (WConst 8#12)) % if LF, echo CRLF (bout) % no, just echo char (!*EXIT 0) % return CRLF (!*MOVE (WConst 8#15) (reg 2)) % write carriage-return (bout) (!*MOVE (WConst 8#12) (reg 2)) % write linefeed (bout) (!*EXIT 0) % return ); internal WConst MaxTerminalBuffer = 200; internal WVar NextTerminalChar = 1; internal WString TerminalInputBuffer[MaxTerminalBuffer]; lap '((!*entry ClearIO1 expr 0) % % ^C from RDTTY and restart causes trouble, but we don't want a full RESET % (don't want to close files or kill forks), so we'll just do the % part of RESET that we want, for terminal input % (!*MOVE (WConst 8#100) (reg 1)) % .priin (rfmod) (tro 2 2#001111100001000000) % tt%wak + tt%eco + .ttasi, like RESET (sfmod) (!*EXIT 0) ); syslsp procedure ClearIO(); << ClearIO1(); TerminalInputBuffer[0] := -1; NextTerminalChar := 0; LispVar IN!* := LispVar STDIN!*; LispVar OUT!* := LispVar STDOUT!* >>; if_system(Tops20, lap '((!*entry RDTTY expr 3) (dmove (reg t1) (reg 1)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (dmove (reg 1) (reg t1)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (!*MkItem (reg 1) 8#61) % (globalize it) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (!*MkItem (reg 3) 8#61) % (globalize it) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf (jsys 8#523) % RDTTY (!*JUMP (Label CantRDTTY)) (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) CantRDTTY (!*MOVE (QUOTE "Can't read from terminal") (reg 1)) (!*JCALL IOError) )); if_system(Tenex, lap '((!*entry RDTTY expr 3) (move (reg t1) (reg 1)) (move (reg t2) (reg 2)) (!*MOVE (WConst 8#101) (reg 1)) % .priou (rfmod) % read mode word (tlze (reg 2) 2#100000000000000000) % if tt%osp is 0, then skip (sfmod) % otherwise turn on output (move (reg 1) (reg t1)) (move (reg 2) (reg t2)) (!*MOVE (reg 2) (reg 4)) % save original count in r4 (!*WPLUS2 (reg 1) (WConst 1)) % make input buffer into byte pointer (hrli (reg 1) 8#440700) (!*WPLUS2 (reg 3) (WConst 1)) % make prompt string into byte pointer (hrli (reg 3) 8#440700) (!*MOVE (reg 1) (reg 5)) % print it once (!*MOVE (reg 3) (reg 1)) (psout) (!*MOVE (reg 5) (reg 1)) % (hrli (reg 2) 2#000110000000000000) % rd%bel + rd%crf % (jsys 8#523) % RDTTY % (!*JUMP (Label CantRDTTY)) (!*MOVE (WConst MaxTerminalBuffer) (reg 2)) % # of chars (setz 3 0) % clear 3 (jsys 8#611) % PSTIN, IMSSS JSYS (!*MOVE (WConst 8#12) (reg 3)) % put linefeed at end of buffer (dpb (reg 3) (reg 1)) % 1 points to end of what's been read (!*MOVE (reg 4) (reg 1)) % move original count to r1 (hrrzs (reg 2)) % clear flag bits in r2 (!*WDIFFERENCE (reg 1) (reg 2)) % return # chars read, not # available (!*EXIT 0) )); syslsp procedure TerminalInputHandler Chn; begin scalar Ch; while NextTerminalChar >= StrLen TerminalInputBuffer do << NextTerminalChar := 0; TerminalInputBuffer[0] := RDTTY(TerminalInputBuffer, MaxTerminalBuffer, if StringP LispVar PromptString!* then LispVar PromptString!* else ">") >>; Ch := StrByt(TerminalInputBuffer, NextTerminalChar); NextTerminalChar := NextTerminalChar + 1; return Ch; end; syslsp procedure FindFreeChannel(); begin scalar Chn; Chn := 0; while JfnOfChannel[Chn] neq 0 do << if Chn >= MaxChannels then IOError("No free channels left"); Chn := Chn + 1 >>; return Chn; end; syslsp procedure SystemMarkAsClosedChannel FileDes; JFNOfChannel[IntInf FileDes] := 0; lap '((!*entry Dec20CloseChannel expr 1) (!*MOVE (reg 1) (reg 2)) % save in case of error (!*MOVE (MEMORY (reg 1) (WConst JFNOfChannel)) (reg 1)) (closf) (!*JUMP (Label CloseError)) (!*EXIT 0) CloseError (!*MOVE (QUOTE "Channel could not be closed") (reg 1)) (!*JCALL ChannelError) ); syslsp procedure SystemOpenFileSpecial FileName; << JFNOfChannel[FileName := FindFreeChannel()] := -1; FileName >>; syslsp procedure SystemOpenFileForInput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 7*of%bsz of%rd 2#000111000000000000010000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'INPUT); JFNOfChannel[Chn] := JFN; ReadFunction[Chn] := 'Dec20ReadChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; syslsp procedure SystemOpenFileForOutput FileName; begin scalar Chn, JFN; Chn := FindFreeChannel(); JFN := Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 7*of%bsz of%wr 2#000111000000000000001000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'OUTPUT); JFNOfChannel[Chn] := JFN; WriteFunction[Chn] := 'Dec20WriteChar; CloseFunction[Chn] := 'Dec20CloseChannel; return Chn; end; lap '((!*entry Dec20Open expr 3) % % Dec20Open(Filename string, GTJFN bits, OPENF bits) % (!*WPLUS2 (reg 1) (WConst 1)) % increment r1 to point to characters (!*MkItem (reg 1) 8#61) % (globalize it) (!*MOVE (reg 1) (reg 4)) % save filename string in r4 (!*MOVE (reg 2) (reg 1)) % GTJFN flag bits in r1 (!*MOVE (reg 4) (reg 2)) % string in r2 (gtjfn) (!*JUMP (Label CantOpen)) (!*MOVE (reg 3) (reg 2)) % OPENF bits in r2, JFN in r1 (openf) CantOpen (!*MOVE (WConst 0) (reg 1)) % return 0 on error (!*EXIT 0) % else return the JFN ); off SysLisp; lisp procedure ContOpenError(FileName, AccessMode); ContinuableError(99, BldMsg("`%s' cannot be open for %w", FileName, AccessMode), list('OPEN, MkSTR FileName, MkQuote AccessMode)); END; |
Added psl-1983/3-1/kernel/20/test-psl-link.ctl version [c2cd7e98c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | cd S: define DSK:, DSK:, P20: LINK /nosymbol nil.rel /set:.low.:202 types.rel randm.rel alloc.rel arith.rel debg.rel error.rel eval.rel extra.rel fasl.rel io.rel macro.rel prop.rel symbl.rel sysio.rel tloop.rel main.rel heap.rel dtypes.rel drandm.rel dalloc.rel darith.rel ddebg.rel derror.rel deval.rel dextra.rel dfasl.rel dio.rel dmacro.rel dprop.rel dsymbl.rel dsysio.rel dtloop.rel dmain.rel dheap.rel /save s:bpsl.exe /go |
Added psl-1983/3-1/kernel/20/timc.red version [19f9edfc8f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % % TIMC.RED - get run time in milliseconds % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 October 1981 % Copyright (c) 1981 University of Utah % lap '((!*entry TimC expr 0) (!*MOVE (WConst -5) (reg 1)) (runtm) (!*EXIT 0) ); end; |
Added psl-1983/3-1/kernel/20/tloop.ctl version [696dcb9164].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "tloop"; PathIn "tloop.build"; ASMEnd; quit; compile tloop.mac, dtloop.mac |
Added psl-1983/3-1/kernel/20/tloop.init version [c202deaa9e].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | (FLUID (QUOTE (!*BREAK !*QUITBREAK BREAKEVAL!* BREAKNAME!* BREAKVALUE!* ERRORFORM!* BREAKLEVEL!* MAXBREAKLEVEL!* TOPLOOPNAME!* TOPLOOPEVAL!* TOPLOOPREAD!* TOPLOOPPRINT!* !*DEFN BREAKIN!* BREAKOUT!*))) (DEFLIST (QUOTE ((Q BREAKQUIT) (!? HELPBREAK) (A RESET) (M BREAKERRMSG) (E BREAKEDIT) (C BREAKCONTINUE) (R BREAKRETRY) (I INTERPBACKTRACE) (V VERBOSEBACKTRACE) (T BACKTRACE))) (QUOTE BREAKFUNCTION)) (FLUID (QUOTE (TOPLOOPREAD!* TOPLOOPPRINT!* TOPLOOPEVAL!* TOPLOOPNAME!* TOPLOOPLEVEL!* HISTORYCOUNT!* HISTORYLIST!* PROMPTSTRING!* LISPBANNER!* !*EMSGP !*BACKTRACE !*TIME GCTIME!* !*DEFN DFPRINT!* !*OUTPUT SEMIC!* !*NONIL INITFORMS!* LISPSCANTABLE!*))) (FLUID (QUOTE (!*BREAK))) (PUT (QUOTE HIST) (QUOTE TYPE) (QUOTE NEXPR)) (FLAG (QUOTE (DSKIN)) (QUOTE IGNORE)) (FLUID (QUOTE (!*REDEFMSG !*ECHO))) |
Added psl-1983/3-1/kernel/20/tloop.log version [32ffa3db43].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/tloop.mac version [ecee529e80].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 L3560: 15 byte(7)69,120,105,116,32,116,111,32,69,114,114,111,114,83,101,116,0 L3561: 9 byte(7)108,105,115,112,32,98,114,101,97,107,0 L3562: 9 byte(7)66,114,101,97,107,32,108,111,111,112,0 L3563: 5 byte(7)32,98,114,101,97,107,0 0 ; (!*ENTRY BREAK EXPR 0) BREAK: intern BREAK ADJSP 15,4 MOVE 1,SYMVAL+487 PUSHJ 15,SYMFNC+241 JSP 10,SYMFNC+443 byte(18)1,487 JSP 10,SYMFNC+443 byte(18)0,796 byte(18)0,797 byte(18)0,798 MOVE 1,SYMVAL+799 PUSHJ 15,SYMFNC+475 MOVEM 1,0(15) MOVE 1,SYMVAL+800 PUSHJ 15,SYMFNC+477 MOVEM 1,-1(15) MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+798 CAMN 0,SYMVAL+801 JRST L3564 MOVE 6,L3551 CAMN 6,SYMVAL+802 JRST L3565 MOVE 6,SYMVAL+802 MOVEM 6,SYMVAL+803 MOVE 2,L3552 MOVE 1,SYMVAL+801 PUSHJ 15,SYMFNC+176 MOVEM 1,SYMVAL+804 L3565: MOVE 1,L3553 PUSHJ 15,SYMFNC+499 MOVEM 1,-2(15) CAME 0,SYMVAL+500 JRST L3566 MOVE 5,L3554 MOVE 4,SYMVAL+804 MOVE 3,L3551 MOVE 2,SYMVAL+805 MOVE 1,SYMVAL+806 PUSHJ 15,SYMFNC+807 MOVEM 1,-3(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+501 JRST L3566 L3564: MOVE 6,L3555 MOVEM 6,SYMVAL+803 MOVE 6,L3556 MOVEM 6,SYMVAL+804 MOVE 1,L3553 PUSHJ 15,SYMFNC+499 MOVEM 1,-2(15) CAME 0,SYMVAL+500 JRST L3566 MOVE 5,L3554 MOVE 4,SYMVAL+804 MOVE 3,L3551 MOVE 2,L3557 MOVE 1,L3558 PUSHJ 15,SYMFNC+807 MOVEM 1,-3(15) MOVE 1,-2(15) PUSHJ 15,SYMFNC+501 L3566: MOVE 1,0(15) PUSHJ 15,SYMFNC+475 MOVE 1,-1(15) PUSHJ 15,SYMFNC+477 CAMN 0,SYMVAL+798 JRST L3567 JSP 10,SYMFNC+443 byte(18)0,485 byte(18)0,484 MOVE 1,L3559 PUSHJ 15,SYMFNC+156 JSP 10,SYMFNC+447 2 JRST L3568 L3567: MOVE 1,SYMVAL+481 PUSHJ 15,SYMFNC+261 L3568: JSP 10,SYMFNC+447 3 JSP 10,SYMFNC+447 1 ADJSP 15,-4 POPJ 15,0 L3559: <4_30>+<1_18>+L3560 L3558: <30_30>+448 L3557: <30_30>+310 L3556: <4_30>+<1_18>+L3561 L3555: <30_30>+261 L3554: <4_30>+<1_18>+L3562 L3553: <30_30>+808 L3552: <4_30>+<1_18>+L3563 L3551: <30_30>+809 1 ; (!*ENTRY BREAKEVAL EXPR 1) L3571: intern L3571 PUSH 15,0 PUSH 15,1 LDB 11,L3569 CAIE 11,30 JRST L3572 MOVE 2,L3570 PUSHJ 15,SYMFNC+522 MOVE 2,1 MOVEM 2,-1(15) CAMN 2,0 JRST L3572 MOVE 1,2 MOVE 6,1 ADJSP 15,-2 JRST SYMFNC+288 L3572: MOVE 2,SYMVAL+803 MOVE 1,0(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 MOVEM 1,SYMVAL+797 ADJSP 15,-2 POPJ 15,0 L3569: point 6,1,5 L3570: <30_30>+810 0 ; (!*ENTRY BREAKQUIT EXPR 0) L3574: intern L3574 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+798 MOVE 2,0 MOVE 1,L3573 JRST SYMFNC+495 L3573: <30_30>+808 0 ; (!*ENTRY BREAKCONTINUE EXPR 0) L3575: intern L3575 MOVE 1,SYMVAL+797 PUSHJ 15,SYMFNC+234 MOVEM 1,SYMVAL+481 JRST SYMFNC+813 L3578: 68 byte(7)67,97,110,32,111,110,108,121,32,99,111,110,116,105,110,117,101,32,102,114,111,109,32,97,32,99,111,110,116,105,110,117,97,98,108,101,32,101,114,114,111,114,59,32,117,115,101,32,81,32,40,66,114,101,97,107,81,117,105,116,41,32,116,111,32,113,117,105,116,0 0 ; (!*ENTRY BREAKRETRY EXPR 0) L3579: intern L3579 CAMN 0,SYMVAL+482 JRST L3580 MOVE 1,0 MOVEM 1,SYMVAL+798 MOVE 2,0 MOVE 1,L3576 JRST SYMFNC+495 L3580: MOVE 1,L3577 PUSHJ 15,SYMFNC+357 JRST SYMFNC+444 L3577: <4_30>+<1_18>+L3578 L3576: <30_30>+808 L3583: <30_30>+450 <30_30>+128 0 ; (!*ENTRY HELPBREAK EXPR 0) L3584: intern L3584 MOVE 1,L3581 PUSHJ 15,SYMFNC+434 MOVE 1,L3582 JRST SYMFNC+456 L3582: <30_30>+451 L3581: <9_30>+<1_18>+L3583 L3586: 18 byte(7)69,114,114,111,114,70,111,114,109,33,42,32,58,32,37,114,32,37,110,0 0 ; (!*ENTRY BREAKERRMSG EXPR 0) L3587: intern L3587 MOVE 2,SYMVAL+481 MOVE 1,L3585 JRST SYMFNC+461 L3585: <4_30>+<1_18>+L3586 L3590: 20 byte(7)42,42,42,32,69,100,105,116,111,114,32,110,111,116,32,108,111,97,100,101,100,0 0 ; (!*ENTRY BREAKEDIT EXPR 0) L3591: intern L3591 MOVE 1,L3588 PUSHJ 15,SYMFNC+318 CAMN 1,0 JRST L3592 MOVE 1,SYMVAL+481 PUSHJ 15,SYMFNC+440 MOVEM 1,SYMVAL+481 POPJ 15,0 L3592: MOVE 1,L3589 JRST SYMFNC+418 L3589: <4_30>+<1_18>+L3590 L3588: <30_30>+440 L3602: 11 byte(7)69,120,105,116,105,110,103,32,37,119,37,110,0 L3603: 32 byte(7)67,112,117,32,116,105,109,101,58,32,37,119,32,109,115,44,32,71,67,32,116,105,109,101,58,32,37,119,32,109,115,37,110,0 L3604: 16 byte(7)67,112,117,32,116,105,109,101,58,32,37,119,32,109,115,37,110,0 L3605: <30_30>+518 <9_30>+<1_18>+L3607 L3606: 7 byte(7)37,119,32,37,119,37,119,32,0 L3607: <30_30>+806 <9_30>+<1_18>+L3608 L3608: <30_30>+128 <30_30>+128 5 ; (!*ENTRY TOPLOOP EXPR 5) L3609: intern L3609 ADJSP 15,7 MOVEM 5,0(15) JSP 10,SYMFNC+443 byte(18)4,801 byte(18)3,802 byte(18)2,805 byte(18)1,806 MOVEM 0,-4(15) JSP 10,SYMFNC+443 byte(18)0,821 byte(18)0,442 MOVE 6,L3593 MOVEM 6,SYMVAL+821 MOVE 1,SYMVAL+817 AOS 1 JSP 10,SYMFNC+443 byte(18)1,817 SETZM -5(15) MOVE 6,SYMVAL+415 MOVEM 6,-2(15) HRRZI 2,62 MOVE 1,SYMVAL+817 PUSHJ 15,SYMFNC+405 MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+357 L3610: AOS SYMVAL+818 MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVE 2,SYMVAL+822 PUSHJ 15,SYMFNC+151 MOVEM 1,SYMVAL+822 MOVE 4,-1(15) MOVE 3,SYMVAL+801 MOVE 2,SYMVAL+818 MOVE 1,L3594 PUSHJ 15,SYMFNC+155 MOVEM 1,SYMVAL+442 MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 MOVE 1,L3595 PUSHJ 15,SYMFNC+478 MOVEM 1,-3(15) CAMN 1,L3596 JRST L3611 LDB 11,L3597 CAIE 11,9 JRST L3610 MOVE 1,0(1) MOVEM 1,-3(15) CAMN 1,L3596 JRST L3611 CAMN 1,SYMVAL+642 JRST L3611 MOVE 7,SYMVAL+822 MOVE 7,0(7) MOVEM 1,0(7) CAMN 0,SYMVAL+823 JRST L3612 PUSHJ 15,SYMFNC+824 MOVEM 1,-5(15) MOVE 6,SYMVAL+415 MOVEM 6,-2(15) L3612: CAMN 0,SYMVAL+796 JRST L3613 MOVE 1,-3(15) PUSHJ 15,L3614 JRST L3615 L3613: MOVE 1,SYMVAL+802 PUSHJ 15,SYMFNC+234 MOVEM 1,-6(15) MOVE 1,-3(15) PUSHJ 15,SYMFNC+172 PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-6(15) MOVE 1,L3598 PUSHJ 15,SYMFNC+235 MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 PUSHJ 15,SYMFNC+478 L3615: MOVEM 1,-4(15) LDB 11,L3597 CAIE 11,9 JRST L3610 MOVE 1,0(1) MOVEM 1,-4(15) CAMN 0,SYMVAL+823 JRST L3616 PUSHJ 15,SYMFNC+824 MOVE 2,-5(15) PUSHJ 15,SYMFNC+238 MOVEM 1,-5(15) MOVE 2,-2(15) MOVE 1,SYMVAL+415 PUSHJ 15,SYMFNC+238 MOVEM 1,-2(15) L3616: MOVE 7,SYMVAL+822 MOVE 7,0(7) MOVE 6,-4(15) MOVEM 6,1(7) CAMN 0,SYMVAL+820 JRST L3617 MOVE 6,L3593 CAME 6,SYMVAL+821 JRST L3617 CAMN 0,SYMVAL+825 JRST L3618 CAMN 0,-4(15) JRST L3617 L3618: MOVE 1,SYMVAL+805 PUSHJ 15,SYMFNC+234 MOVEM 1,-6(15) MOVE 1,-4(15) PUSHJ 15,SYMFNC+172 PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-6(15) MOVE 1,L3598 PUSHJ 15,SYMFNC+235 MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 PUSHJ 15,SYMFNC+478 L3617: CAMN 0,SYMVAL+823 JRST L3610 SKIPE -2(15) JRST L3619 MOVE 2,-5(15) MOVE 1,L3599 PUSHJ 15,SYMFNC+461 JRST L3610 L3619: MOVE 2,-2(15) MOVE 1,-5(15) PUSHJ 15,SYMFNC+238 MOVE 3,-2(15) MOVE 2,1 MOVE 1,L3600 PUSHJ 15,SYMFNC+461 JRST L3610 L3611: MOVE 2,SYMVAL+801 MOVE 1,L3601 PUSHJ 15,SYMFNC+461 JSP 10,SYMFNC+447 1 MOVE 1,0 JSP 10,SYMFNC+447 2 JSP 10,SYMFNC+447 4 ADJSP 15,-7 POPJ 15,0 L3597: point 6,1,5 L3601: <4_30>+<1_18>+L3602 L3600: <4_30>+<1_18>+L3603 L3599: <4_30>+<1_18>+L3604 L3598: <30_30>+518 L3596: <30_30>+826 L3595: <9_30>+<1_18>+L3605 L3594: <4_30>+<1_18>+L3606 L3593: <30_30>+59 ; (!*ENTRY DEFNPRINT EXPR 1) L3614: intern L3614 PUSH 15,1 LDB 11,L3620 CAIE 11,9 JRST L3624 MOVE 2,L3621 MOVE 1,0(1) PUSHJ 15,SYMFNC+758 CAMN 1,0 JRST L3624 MOVE 1,0(15) ADJSP 15,-1 JRST L3625 L3624: CAMN 0,SYMVAL+827 JRST L3626 MOVE 2,SYMVAL+827 MOVE 1,0(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 JRST L3627 L3626: MOVE 1,0(15) PUSHJ 15,SYMFNC+577 L3627: LDB 11,L3622 CAIE 11,9 JRST L3628 MOVE 2,L3623 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+758 CAMN 1,0 JRST L3628 MOVE 1,0(15) ADJSP 15,-1 JRST L3625 L3628: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L3620: point 6,1,5 L3622: point 6,0(15),5 L3623: <30_30>+261 L3621: <30_30>+828 ; (!*ENTRY DEFNPRINT1 EXPR 1) L3625: intern L3625 ADJSP 15,2 MOVEM 1,0(15) MOVE 1,SYMVAL+802 PUSHJ 15,SYMFNC+234 MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+172 PUSHJ 15,SYMFNC+234 MOVE 3,1 MOVE 2,-1(15) MOVE 1,L3629 PUSHJ 15,SYMFNC+235 MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 ADJSP 15,-2 JRST SYMFNC+478 L3629: <30_30>+518 L3631: 18 byte(7)78,111,32,104,105,115,116,111,114,121,32,101,110,116,114,121,32,37,114,0 ; (!*ENTRY NTHENTRY EXPR 1) L3632: intern L3632 PUSH 15,1 JSP 10,SYMFNC+443 byte(18)0,484 CAMGE 1,SYMVAL+818 JRST L3633 MOVE 2,1 MOVE 1,L3630 PUSHJ 15,SYMFNC+155 PUSHJ 15,SYMFNC+156 JRST L3634 L3633: MOVE 2,SYMVAL+818 SUB 2,1 MOVE 1,SYMVAL+822 MOVE 1,1(1) PUSHJ 15,SYMFNC+350 MOVE 1,0(1) L3634: JSP 10,SYMFNC+447 1 ADJSP 15,-1 POPJ 15,0 L3630: <4_30>+<1_18>+L3631 1 ; (!*ENTRY INP EXPR 1) INP: intern INP PUSHJ 15,L3632 MOVE 1,0(1) POPJ 15,0 1 ; (!*ENTRY REDO EXPR 1) REDO: intern REDO PUSHJ 15,L3632 MOVE 2,SYMVAL+802 MOVE 1,0(1) MOVE 6,2 JRST SYMFNC+288 1 ; (!*ENTRY ANS EXPR 1) ANS: intern ANS PUSHJ 15,L3632 MOVE 1,1(1) POPJ 15,0 1 ; (!*ENTRY HIST NEXPR 1) HIST: intern HIST ADJSP 15,4 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 7,SYMVAL+818 CAIL 7,2 JRST L3638 MOVE 1,0 JRST L3639 L3638: HRRZI 6,1 MOVEM 6,-1(15) MOVE 2,SYMVAL+818 SOS 2 MOVEM 2,-2(15) LDB 11,L3635 CAIE 11,9 JRST L3640 MOVE 6,L3636 CAME 6,0(1) JRST L3641 HRRZI 6,1 MOVEM 6,SYMVAL+818 MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVEM 1,SYMVAL+822 MOVE 1,0 JRST L3639 L3641: SKIPL 0(1) JRST L3642 MOVE 3,0(1) MOVNS 3 MOVE 1,SYMVAL+822 MOVE 1,1(1) ADJSP 15,-4 JRST L3643 L3642: MOVE 2,0(1) MOVE 1,-1(15) PUSHJ 15,SYMFNC+281 MOVEM 1,-1(15) MOVE 2,0(15) MOVE 2,1(2) MOVEM 2,0(15) L3640: LDB 11,L3637 CAIE 11,9 JRST L3644 MOVE 2,0(15) MOVE 2,0(2) MOVE 1,-2(15) PUSHJ 15,SYMFNC+284 MOVEM 1,-2(15) L3644: MOVE 2,SYMVAL+818 SUB 2,-2(15) MOVE 1,SYMVAL+822 MOVE 1,1(1) PUSHJ 15,SYMFNC+350 MOVE 3,-2(15) SUB 3,-1(15) AOS 3 MOVE 2,-2(15) ADJSP 15,-4 JRST L3643 L3639: ADJSP 15,-4 POPJ 15,0 L3635: point 6,1,5 L3637: point 6,0(15),5 L3636: <30_30>+833 L3646: 21 byte(7)37,119,9,73,110,112,58,32,37,112,37,110,9,65,110,115,58,32,37,112,37,110,0 ; (!*ENTRY HISTPRINT EXPR 3) L3643: intern L3643 PUSH 15,2 PUSH 15,1 JUMPN 3,L3647 MOVE 1,0 JRST L3648 L3647: SOS 3 SOS 2 MOVE 1,1(1) PUSHJ 15,L3643 MOVE 4,0(15) MOVE 4,0(4) MOVE 4,1(4) MOVE 3,0(15) MOVE 3,0(3) MOVE 3,0(3) MOVE 2,-1(15) MOVE 1,L3645 ADJSP 15,-2 JRST SYMFNC+461 L3648: ADJSP 15,-2 POPJ 15,0 L3645: <4_30>+<1_18>+L3646 0 ; (!*ENTRY TIME EXPR 0) TIME: intern TIME PUSHJ 15,SYMFNC+419 JRST SYMFNC+138 L3654: 3 byte(7)108,105,115,112,0 0 ; (!*ENTRY STANDARDLISP EXPR 0) L3655: intern L3655 MOVE 2,SYMVAL+637 MOVE 1,L3649 JSP 10,SYMFNC+443 byte(18)2,635 byte(18)1,631 MOVE 5,SYMVAL+819 MOVE 4,L3650 MOVE 3,L3651 MOVE 2,L3652 MOVE 1,L3653 PUSHJ 15,SYMFNC+807 JSP 10,SYMFNC+447 2 POPJ 15,0 L3653: <30_30>+448 L3652: <30_30>+835 L3651: <30_30>+261 L3650: <4_30>+<1_18>+L3654 L3649: <30_30>+638 L3657: 5 byte(7)37,102,37,112,37,110,0 1 ; (!*ENTRY PRINTWITHFRESHLINE EXPR 1) L3658: intern L3658 MOVE 2,1 MOVE 1,L3656 JRST SYMFNC+461 L3656: <4_30>+<1_18>+L3657 L3660: 5 byte(7)37,119,44,32,37,119,0 3 ; (!*ENTRY SAVESYSTEM EXPR 3) L3661: intern L3661 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVE 6,SYMVAL+818 MOVEM 6,-4(15) MOVE 6,SYMVAL+822 MOVEM 6,-3(15) MOVE 4,0 MOVEM 4,SYMVAL+822 SETZM SYMVAL+818 PUSHJ 15,SYMFNC+547 MOVE 3,1 MOVE 2,0(15) MOVE 1,L3659 PUSHJ 15,SYMFNC+155 MOVEM 1,SYMVAL+819 MOVE 6,SYMVAL+84 MOVEM 6,SYMVAL+570 MOVE 6,-2(15) MOVEM 6,SYMVAL+837 MOVE 1,-1(15) PUSHJ 15,SYMFNC+548 MOVE 1,0 MOVEM 1,SYMVAL+837 MOVE 6,-4(15) MOVEM 6,SYMVAL+818 MOVE 6,-3(15) MOVEM 6,SYMVAL+822 MOVE 1,0 ADJSP 15,-5 POPJ 15,0 L3659: <4_30>+<1_18>+L3660 0 ; (!*ENTRY EVALINITFORMS EXPR 0) L3663: intern L3663 PUSH 15,SYMVAL+837 L3664: LDB 11,L3662 CAIN 11,9 JRST L3665 MOVE 1,0 JRST L3666 L3665: MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+261 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L3664 L3666: MOVE 1,0 MOVEM 1,SYMVAL+837 ADJSP 15,-1 POPJ 15,0 L3662: point 6,0(15),5 L3676: 5 byte(7)37,102,37,112,37,110,0 L3677: <30_30>+448 <30_30>+128 L3678: 22 byte(7)67,111,117,108,100,110,39,116,32,111,112,101,110,32,102,105,108,101,32,96,37,119,39,0 L3679: <30_30>+246 <9_30>+<1_18>+L3680 L3680: <30_30>+612 <30_30>+128 1 ; (!*ENTRY DSKIN EXPR 1) DSKIN: intern DSKIN ADJSP 15,6 MOVEM 1,0(15) MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-4(15) MOVE 3,L3667 MOVE 2,1 MOVE 1,L3668 PUSHJ 15,SYMFNC+235 MOVE 3,0 MOVE 2,0 PUSHJ 15,SYMFNC+478 MOVEM 1,-3(15) LDB 11,L3669 CAIN 11,9 JRST L3681 MOVE 2,0(15) MOVE 1,L3670 PUSHJ 15,SYMFNC+155 MOVEM 1,-5(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L3671 PUSHJ 15,SYMFNC+249 MOVE 3,1 MOVE 2,-5(15) HRRZI 1,99 ADJSP 15,-6 JRST SYMFNC+236 L3681: MOVE 2,0(1) MOVEM 2,-2(15) MOVE 1,2 PUSHJ 15,SYMFNC+475 MOVEM 1,-1(15) L3682: MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 MOVE 1,L3672 PUSHJ 15,SYMFNC+478 MOVEM 1,-4(15) LDB 11,L3669 CAIE 11,9 JRST L3683 MOVE 6,SYMVAL+642 CAMN 6,0(1) JRST L3683 MOVE 1,0(1) PUSHJ 15,SYMFNC+234 MOVE 2,1 MOVE 1,L3673 PUSHJ 15,SYMFNC+249 MOVE 3,SYMVAL+493 MOVE 2,SYMVAL+84 PUSHJ 15,SYMFNC+478 MOVE 2,1 MOVEM 2,-4(15) LDB 11,L3674 CAIE 11,9 JRST L3683 CAME 0,SYMVAL+796 JRST L3682 MOVE 2,0(2) MOVE 1,L3675 PUSHJ 15,SYMFNC+461 JRST L3682 L3683: MOVE 1,-1(15) PUSHJ 15,SYMFNC+475 MOVE 1,-2(15) PUSHJ 15,SYMFNC+613 MOVE 1,0 ADJSP 15,-6 POPJ 15,0 L3669: point 6,1,5 L3674: point 6,2,5 L3675: <4_30>+<1_18>+L3676 L3673: <30_30>+840 L3672: <9_30>+<1_18>+L3677 L3671: <30_30>+839 L3670: <4_30>+<1_18>+L3678 L3668: <30_30>+603 L3667: <9_30>+<1_18>+L3679 1 ; (!*ENTRY DSKINEVAL EXPR 1) L3684: intern L3684 CAME 0,SYMVAL+796 JRST L3685 JRST SYMFNC+261 L3685: JRST L3686 ; (!*ENTRY DSKINDEFNPRINT EXPR 1) L3686: intern L3686 PUSH 15,1 LDB 11,L3687 CAIE 11,9 JRST L3691 MOVE 2,L3688 MOVE 1,0(1) PUSHJ 15,SYMFNC+758 CAMN 1,0 JRST L3691 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+261 L3691: CAMN 0,SYMVAL+827 JRST L3692 MOVE 2,SYMVAL+827 MOVE 1,0(15) MOVE 6,2 PUSHJ 15,SYMFNC+288 JRST L3693 L3692: MOVE 1,0(15) PUSHJ 15,SYMFNC+577 L3693: LDB 11,L3689 CAIE 11,9 JRST L3694 MOVE 2,L3690 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+758 CAMN 1,0 JRST L3694 MOVE 1,0(15) ADJSP 15,-1 JRST SYMFNC+261 L3694: MOVE 1,0 ADJSP 15,-1 POPJ 15,0 L3687: point 6,1,5 L3689: point 6,0(15),5 L3690: <30_30>+261 L3688: <30_30>+828 1 ; (!*ENTRY LAPIN EXPR 1) LAPIN: intern LAPIN ADJSP 15,3 MOVEM 1,0(15) JSP 10,SYMFNC+443 byte(18)0,793 byte(18)0,571 MOVE 2,L3695 PUSHJ 15,SYMFNC+603 PUSHJ 15,SYMFNC+475 MOVEM 1,-1(15) L3696: PUSHJ 15,SYMFNC+448 MOVE 2,SYMVAL+642 MOVEM 1,-2(15) PUSHJ 15,SYMFNC+198 CAME 1,0 JRST L3697 MOVE 1,-2(15) PUSHJ 15,SYMFNC+261 JRST L3696 L3697: MOVE 1,-1(15) PUSHJ 15,SYMFNC+475 PUSHJ 15,SYMFNC+613 MOVE 1,0 JSP 10,SYMFNC+447 2 ADJSP 15,-3 POPJ 15,0 L3695: <30_30>+612 end |
Added psl-1983/3-1/kernel/20/tloop.rel version [761852663f].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/trap.red version [4991d33e65].
> | 1 | end; |
Added psl-1983/3-1/kernel/20/types.ctl version [f80b3b8edb].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | ;Modifications to this file may disappear, as this file is generated ;automatically using information in P20:20-KERNEL-GEN.SL. def dsk: dsk:,p20:,pk: S:DEC20-CROSS.EXE ASMOut "types"; PathIn "types.build"; ASMEnd; quit; compile types.mac, dtypes.mac |
Added psl-1983/3-1/kernel/20/types.init version [a7ffc6f8bf].
Added psl-1983/3-1/kernel/20/types.log version [7bfcafb6b0].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/types.mac version [a088fe70f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym,macsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 1 ; (!*ENTRY ID2INT EXPR 1) ID2INT: intern ID2INT LDB 11,L0004 CAIE 11,30 JRST L0006 TLZ 1,258048 POPJ 15,0 L0006: MOVE 2,L0005 JRST SYMFNC+130 L0004: point 6,1,5 L0005: <30_30>+129 L0011: 15 byte(7)112,111,115,105,116,105,118,101,32,105,110,116,101,103,101,114,0 1 ; (!*ENTRY INT2ID EXPR 1) INT2ID: intern INT2ID MOVE 5,1 MOVE 4,0 LDB 11,L0008 CAIN 11,63 JRST L0007 CAILE 11,0 JRST L0012 L0007: MOVE 4,1 JUMPL 1,L0013 HRLI 1,122880 POPJ 15,0 L0013: MOVE 3,L0009 MOVE 2,L0010 JRST SYMFNC+132 L0012: MOVE 2,L0010 JRST SYMFNC+133 L0008: point 6,1,5 L0010: <30_30>+131 L0009: <4_30>+<1_18>+L0011 1 ; (!*ENTRY INT2SYS EXPR 1) L0016: intern L0016 LDB 11,L0014 CAIG 11,0 JRST L0017 CAIN 11,63 JRST L0017 LDB 11,L0014 CAIE 11,1 JRST L0018 TLZ 1,258048 MOVE 1,1(1) POPJ 15,0 L0018: MOVE 2,L0015 JRST SYMFNC+133 L0017: POPJ 15,0 L0014: point 6,1,5 L0015: <30_30>+134 1 ; (!*ENTRY LISP2CHAR EXPR 1) L0022: intern L0022 MOVE 5,1 MOVE 4,0 LDB 11,L0020 CAIN 11,63 JRST L0019 CAILE 11,0 JRST L0023 L0019: MOVE 2,1 MOVE 4,2 JUMPL 2,L0023 CAILE 2,127 JRST L0023 MOVE 1,2 POPJ 15,0 L0023: LDB 11,L0020 CAIE 11,30 JRST L0024 SETZM 2 MOVE 3,1 TLZ 3,258048 MOVE 1,SYMNAM(3) TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 POPJ 15,0 L0024: LDB 11,L0020 CAIE 11,4 JRST L0025 SETZM 2 TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 POPJ 15,0 L0025: MOVE 2,L0021 JRST SYMFNC+136 L0020: point 6,1,5 L0021: <30_30>+135 1 ; (!*ENTRY INT2CODE EXPR 1) L0026: intern L0026 TLZ 1,258048 TLO 1,61440 POPJ 15,0 1 ; (!*ENTRY SYS2INT EXPR 1) L0030: intern L0030 MOVE 6,1 LDB 2,L0027 TDNE 2,L0028 TDO 2,L0029 CAMN 2,1 JRST L0031 JRST L0032 L0031: POPJ 15,0 L0027: point 31,6,35 L0028: 1073741824 L0029: -1073741824 ; (!*ENTRY SYS2FIXN EXPR 1) L0032: intern L0032 ADJSP 15,2 MOVEM 1,0(15) PUSHJ 15,SYMFNC+139 MOVEM 1,-1(15) MOVE 6,0(15) MOVEM 6,1(1) TLZ 1,258048 TLO 1,4096 ADJSP 15,-2 POPJ 15,0 1 ; (!*ENTRY ID2STRING EXPR 1) L0035: intern L0035 LDB 11,L0033 CAIE 11,30 JRST L0036 TLZ 1,258048 MOVE 1,SYMNAM(1) POPJ 15,0 L0036: MOVE 2,L0034 JRST SYMFNC+130 L0033: point 6,1,5 L0034: <30_30>+140 1 ; (!*ENTRY STRING2VECTOR EXPR 1) L0042: intern L0042 ADJSP 15,5 MOVEM 1,0(15) LDB 11,L0037 CAIE 11,4 JRST L0043 MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVE 3,1 TLZ 3,258048 MOVE 6,0(3) LDB 2,L0038 TDNE 2,L0039 TDO 2,L0040 MOVEM 2,-3(15) MOVE 1,2 PUSHJ 15,SYMFNC+142 MOVEM 1,-2(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-1(15) MOVEM 0,-4(15) SETZM -4(15) L0044: MOVE 6,-4(15) CAMLE 6,-3(15) JRST L0045 MOVE 2,-4(15) MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,-4(15) ADD 2,-2(15) MOVEM 1,1(2) AOS -4(15) JRST L0044 L0045: MOVE 1,-2(15) TLZ 1,258048 TLO 1,32768 JRST L0046 L0043: MOVE 2,L0041 ADJSP 15,-5 JRST SYMFNC+143 L0046: ADJSP 15,-5 POPJ 15,0 L0037: point 6,1,5 L0038: point 30,6,35 L0039: 536870912 L0040: -536870912 L0041: <30_30>+141 1 ; (!*ENTRY VECTOR2STRING EXPR 1) L0052: intern L0052 ADJSP 15,6 MOVEM 1,0(15) LDB 11,L0047 CAIE 11,8 JRST L0053 MOVEM 0,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVE 3,1 TLZ 3,258048 MOVE 6,0(3) LDB 2,L0048 TDNE 2,L0049 TDO 2,L0050 MOVEM 2,-3(15) MOVE 1,2 PUSHJ 15,SYMFNC+145 MOVEM 1,-2(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-1(15) MOVEM 0,-5(15) SETZM -5(15) L0054: MOVE 6,-5(15) CAMLE 6,-3(15) JRST L0055 MOVE 1,-5(15) ADD 1,-1(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+135 MOVE 3,1 MOVE 2,-5(15) MOVE 1,-2(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -5(15) JRST L0054 L0055: MOVE 1,-2(15) TLZ 1,258048 TLO 1,16384 JRST L0056 L0053: MOVE 2,L0051 ADJSP 15,-6 JRST SYMFNC+146 L0056: ADJSP 15,-6 POPJ 15,0 L0047: point 6,1,5 L0048: point 30,6,35 L0049: 536870912 L0050: -536870912 L0051: <30_30>+144 L0060: -1 byte(7)0 1 ; (!*ENTRY LIST2STRING EXPR 1) L0061: intern L0061 ADJSP 15,4 MOVEM 1,0(15) CAME 1,0 JRST L0062 MOVE 1,L0057 JRST L0063 L0062: LDB 11,L0058 CAIE 11,9 JRST L0064 MOVEM 0,-1(15) MOVEM 0,-2(15) PUSHJ 15,SYMFNC+148 MOVE 2,1 SOS 2 MOVEM 2,-2(15) MOVE 1,2 PUSHJ 15,SYMFNC+145 MOVEM 1,-1(15) MOVEM 0,-3(15) SETZM -3(15) L0065: MOVE 6,-3(15) CAMLE 6,-2(15) JRST L0066 MOVE 1,0(15) MOVE 1,0(1) PUSHJ 15,SYMFNC+135 MOVE 3,1 MOVE 2,-3(15) MOVE 1,-1(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) AOS -3(15) JRST L0065 L0066: MOVE 1,-1(15) TLZ 1,258048 TLO 1,16384 JRST L0063 L0064: MOVE 2,L0059 ADJSP 15,-4 JRST SYMFNC+149 L0063: ADJSP 15,-4 POPJ 15,0 L0058: point 6,1,5 L0059: <30_30>+147 L0057: <4_30>+<1_18>+L0060 1 ; (!*ENTRY STRING2LIST EXPR 1) L0072: intern L0072 ADJSP 15,4 MOVEM 1,0(15) LDB 11,L0067 CAIE 11,4 JRST L0073 MOVEM 0,-1(15) MOVEM 0,-2(15) MOVE 2,0 MOVEM 2,-1(15) MOVE 4,1 TLZ 4,258048 MOVE 6,0(4) LDB 3,L0068 TDNE 3,L0069 TDO 3,L0070 MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 3,-3(15) L0074: SKIPGE -3(15) JRST L0075 MOVE 2,-3(15) MOVE 1,0(15) TLZ 1,258048 AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 2,-1(15) PUSHJ 15,SYMFNC+151 MOVEM 1,-1(15) SOS -3(15) JRST L0074 L0075: MOVE 1,-1(15) JRST L0076 L0073: MOVE 2,L0071 ADJSP 15,-4 JRST SYMFNC+143 L0076: ADJSP 15,-4 POPJ 15,0 L0067: point 6,1,5 L0068: point 30,6,35 L0069: 536870912 L0070: -536870912 L0071: <30_30>+150 1 ; (!*ENTRY LIST2VECTOR EXPR 1) L0079: intern L0079 ADJSP 15,4 MOVEM 1,0(15) LDB 11,L0077 CAIN 11,9 JRST L0080 CAME 1,0 JRST L0081 L0080: MOVEM 0,-1(15) MOVEM 0,-2(15) PUSHJ 15,SYMFNC+148 MOVE 2,1 SOS 2 MOVEM 2,-2(15) MOVE 1,2 PUSHJ 15,SYMFNC+142 MOVEM 1,-1(15) MOVEM 0,-3(15) SETZM -3(15) L0082: MOVE 6,-3(15) CAMLE 6,-2(15) JRST L0083 MOVE 2,-3(15) ADD 2,-1(15) MOVE 1,0(15) MOVE 1,0(1) MOVEM 1,1(2) MOVE 3,0(15) MOVE 3,1(3) MOVEM 3,0(15) AOS -3(15) JRST L0082 L0083: MOVE 1,-1(15) TLZ 1,258048 TLO 1,32768 JRST L0084 L0081: MOVE 2,L0078 ADJSP 15,-4 JRST SYMFNC+149 L0084: ADJSP 15,-4 POPJ 15,0 L0077: point 6,1,5 L0078: <30_30>+152 1 ; (!*ENTRY VECTOR2LIST EXPR 1) L0090: intern L0090 ADJSP 15,4 MOVEM 1,0(15) LDB 11,L0085 CAIE 11,8 JRST L0091 MOVEM 0,-1(15) MOVEM 0,-2(15) MOVE 2,0 MOVEM 2,-1(15) MOVE 4,1 TLZ 4,258048 MOVE 6,0(4) LDB 3,L0086 TDNE 3,L0087 TDO 3,L0088 MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 3,-3(15) L0092: SKIPGE -3(15) JRST L0093 MOVE 2,-1(15) MOVE 1,0(15) TLZ 1,258048 ADD 1,-3(15) MOVE 1,1(1) PUSHJ 15,SYMFNC+151 MOVEM 1,-1(15) SOS -3(15) JRST L0092 L0093: MOVE 1,-1(15) JRST L0094 L0091: MOVE 2,L0089 ADJSP 15,-4 JRST SYMFNC+146 L0094: ADJSP 15,-4 POPJ 15,0 L0085: point 6,1,5 L0086: point 30,6,35 L0087: 536870912 L0088: -536870912 L0089: <30_30>+153 L0103: 35 byte(7)83,117,98,115,99,114,105,112,116,32,37,114,32,105,110,32,71,101,116,86,32,105,115,32,111,117,116,32,111,102,32,114,97,110,103,101,0 2 ; (!*ENTRY GETV EXPR 2) GETV: intern GETV ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) LDB 11,L0095 CAIE 11,8 JRST L0104 LDB 11,L0097 CAIN 11,63 JRST L0096 CAILE 11,0 JRST L0105 L0096: MOVE 3,1 TLZ 3,258048 MOVEM 3,-2(15) MOVEM 2,-3(15) JUMPL 2,L0106 MOVE 6,0(3) LDB 4,L0098 TDNE 4,L0099 TDO 4,L0100 CAMLE 2,4 JRST L0106 MOVE 1,2 ADDM 3,1 MOVE 1,1(1) JRST L0107 L0106: MOVE 1,L0101 PUSHJ 15,SYMFNC+155 ADJSP 15,-4 JRST SYMFNC+156 L0105: MOVE 2,L0102 MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+157 L0104: MOVE 2,L0102 ADJSP 15,-4 JRST SYMFNC+146 L0107: ADJSP 15,-4 POPJ 15,0 L0095: point 6,1,5 L0097: point 6,2,5 L0098: point 30,6,35 L0099: 536870912 L0100: -536870912 L0102: <30_30>+154 L0101: <4_30>+<1_18>+L0103 L0116: 35 byte(7)83,117,98,115,99,114,105,112,116,32,37,114,32,105,110,32,80,117,116,86,32,105,115,32,111,117,116,32,111,102,32,114,97,110,103,101,0 3 ; (!*ENTRY PUTV EXPR 3) PUTV: intern PUTV ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) LDB 11,L0108 CAIE 11,8 JRST L0117 LDB 11,L0110 CAIN 11,63 JRST L0109 CAILE 11,0 JRST L0118 L0109: MOVE 4,1 TLZ 4,258048 MOVEM 4,-3(15) MOVEM 2,-4(15) JUMPL 2,L0119 MOVE 6,0(4) LDB 5,L0111 TDNE 5,L0112 TDO 5,L0113 CAMLE 2,5 JRST L0119 ADDM 4,2 MOVE 1,3 MOVEM 1,1(2) JRST L0120 L0119: MOVE 1,L0114 PUSHJ 15,SYMFNC+155 ADJSP 15,-5 JRST SYMFNC+156 L0118: MOVE 2,L0115 MOVE 1,-1(15) ADJSP 15,-5 JRST SYMFNC+157 L0117: MOVE 2,L0115 ADJSP 15,-5 JRST SYMFNC+146 L0120: ADJSP 15,-5 POPJ 15,0 L0108: point 6,1,5 L0110: point 6,2,5 L0111: point 30,6,35 L0112: 536870912 L0113: -536870912 L0115: <30_30>+158 L0114: <4_30>+<1_18>+L0116 1 ; (!*ENTRY UPBV EXPR 1) UPBV: intern UPBV LDB 11,L0121 CAIE 11,8 JRST L0125 MOVE 2,1 TLZ 2,258048 MOVE 6,0(2) LDB 1,L0122 TDNE 1,L0123 TDO 1,L0124 POPJ 15,0 L0125: MOVE 1,0 POPJ 15,0 L0121: point 6,1,5 L0122: point 30,6,35 L0123: 536870912 L0124: -536870912 1 ; (!*ENTRY EVECTORP EXPR 1) L0127: intern L0127 LDB 1,L0126 CAIN 1,10 JRST L0128 MOVE 1,0 POPJ 15,0 L0128: MOVE 1,SYMVAL+84 POPJ 15,0 L0126: point 6,1,5 L0136: 36 byte(7)83,117,98,115,99,114,105,112,116,32,37,114,32,105,110,32,69,71,69,84,86,32,105,115,32,111,117,116,32,111,102,32,114,97,110,103,101,0 2 ; (!*ENTRY EGETV EXPR 2) EGETV: intern EGETV ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) PUSHJ 15,SYMFNC+160 CAMN 1,0 JRST L0137 LDB 11,L0130 CAIN 11,63 JRST L0129 CAILE 11,0 JRST L0138 L0129: MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-2(15) MOVE 6,-1(15) MOVEM 6,-3(15) SKIPGE -3(15) JRST L0139 MOVE 6,0(2) LDB 3,L0131 TDNE 3,L0132 TDO 3,L0133 CAMGE 3,-3(15) JRST L0139 MOVE 1,-3(15) ADDM 2,1 MOVE 1,1(1) JRST L0140 L0139: MOVE 2,-1(15) MOVE 1,L0134 PUSHJ 15,SYMFNC+155 ADJSP 15,-4 JRST SYMFNC+156 L0138: MOVE 2,L0135 MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+157 L0137: MOVE 2,L0135 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+146 L0140: ADJSP 15,-4 POPJ 15,0 L0130: point 6,-1(15),5 L0131: point 30,6,35 L0132: 536870912 L0133: -536870912 L0135: <30_30>+161 L0134: <4_30>+<1_18>+L0136 L0148: 36 byte(7)83,117,98,115,99,114,105,112,116,32,37,114,32,105,110,32,69,112,117,116,118,32,105,115,32,111,117,116,32,111,102,32,114,97,110,103,101,0 3 ; (!*ENTRY EPUTV EXPR 3) EPUTV: intern EPUTV ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) PUSHJ 15,SYMFNC+160 CAMN 1,0 JRST L0149 LDB 11,L0142 CAIN 11,63 JRST L0141 CAILE 11,0 JRST L0150 L0141: MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-3(15) MOVE 6,-1(15) MOVEM 6,-4(15) SKIPGE -4(15) JRST L0151 MOVE 6,0(2) LDB 3,L0143 TDNE 3,L0144 TDO 3,L0145 CAMGE 3,-4(15) JRST L0151 MOVE 4,-4(15) ADDM 2,4 MOVE 1,-2(15) MOVEM 1,1(4) JRST L0152 L0151: MOVE 2,-1(15) MOVE 1,L0146 PUSHJ 15,SYMFNC+155 ADJSP 15,-5 JRST SYMFNC+156 L0150: MOVE 2,L0147 MOVE 1,-1(15) ADJSP 15,-5 JRST SYMFNC+157 L0149: MOVE 2,L0147 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+146 L0152: ADJSP 15,-5 POPJ 15,0 L0142: point 6,-1(15),5 L0143: point 30,6,35 L0144: 536870912 L0145: -536870912 L0147: <30_30>+162 L0146: <4_30>+<1_18>+L0148 1 ; (!*ENTRY EUPBV EXPR 1) EUPBV: intern EUPBV PUSH 15,1 PUSHJ 15,SYMFNC+160 CAMN 1,0 JRST L0156 MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L0153 TDNE 1,L0154 TDO 1,L0155 JRST L0157 L0156: MOVE 1,0 L0157: ADJSP 15,-1 POPJ 15,0 L0153: point 30,6,35 L0154: 536870912 L0155: -536870912 2 ; (!*ENTRY INDX EXPR 2) INDX: intern INDX ADJSP 15,4 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) TLNN 2,258048 JRST L0163 MOVE 2,L0158 MOVE 1,-1(15) ADJSP 15,-4 JRST SYMFNC+157 L0163: MOVE 3,1 TLZ 3,258048 MOVEM 3,-2(15) LDB 4,L0159 MOVEM 4,-3(15) MOVE 1,4 CAIL 1,4 CAILE 1,9 JRST L0164 JRST @L0165-4(1) L0165: IFIW L0166 IFIW L0166 IFIW L0167 IFIW L0168 IFIW L0169 IFIW L0170 L0164: JRST L0171 L0166: MOVE 6,0(3) LDB 5,L0160 TDNE 5,L0161 TDO 5,L0162 CAMG 2,5 JRST L0172 MOVE 3,L0158 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+165 L0172: MOVE 1,3 AOS 1 ADJSP 15,-4 TLO 1,204800 ADJBP 2,1 LDB 1,2 POPJ 15,0 L0169: MOVE 6,0(3) LDB 5,L0160 TDNE 5,L0161 TDO 5,L0162 CAMG 2,5 JRST L0173 MOVE 3,L0158 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+165 L0173: MOVE 1,2 ADDM 3,1 MOVE 1,1(1) JRST L0174 L0168: MOVE 6,0(3) LDB 5,L0160 TDNE 5,L0161 TDO 5,L0162 CAMG 2,5 JRST L0175 MOVE 3,L0158 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+165 L0175: MOVE 1,2 ADDM 3,1 MOVE 1,1(1) JRST L0174 L0167: MOVE 6,0(3) LDB 5,L0160 TDNE 5,L0161 TDO 5,L0162 CAMG 2,5 JRST L0176 MOVE 3,L0158 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+165 L0176: MOVE 1,3 AOS 1 ADJSP 15,-4 TLO 1,245760 ADJBP 2,1 LDB 1,2 POPJ 15,0 L0170: MOVEM 2,-3(15) L0177: SKIPLE -3(15) JRST L0178 MOVE 1,0 JRST L0179 L0178: MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) LDB 11,L0159 CAIN 11,9 JRST L0180 MOVE 3,L0158 MOVE 2,-1(15) PUSHJ 15,SYMFNC+165 L0180: SOS -3(15) JRST L0177 L0179: MOVE 1,0(15) MOVE 1,0(1) JRST L0174 L0171: MOVE 2,L0158 MOVE 1,0(15) ADJSP 15,-4 JRST SYMFNC+166 L0174: ADJSP 15,-4 POPJ 15,0 L0159: point 6,1,5 L0160: point 30,6,35 L0161: 536870912 L0162: -536870912 L0158: <30_30>+164 3 ; (!*ENTRY SETINDX EXPR 3) L0186: intern L0186 ADJSP 15,5 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) TLNN 2,258048 JRST L0187 MOVE 2,L0181 MOVE 1,-1(15) ADJSP 15,-5 JRST SYMFNC+157 L0187: MOVE 4,1 TLZ 4,258048 MOVEM 4,-3(15) LDB 5,L0182 MOVEM 5,-4(15) MOVE 1,5 CAIL 1,4 CAILE 1,9 JRST L0188 JRST @L0189-4(1) L0189: IFIW L0190 IFIW L0190 IFIW L0191 IFIW L0192 IFIW L0193 IFIW L0194 L0188: JRST L0195 L0190: MOVE 6,0(4) LDB 1,L0183 TDNE 1,L0184 TDO 1,L0185 CAMG 2,1 JRST L0196 MOVE 3,L0181 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+165 L0196: MOVE 1,4 AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 MOVE 1,3 JRST L0197 L0193: MOVE 6,0(4) LDB 1,L0183 TDNE 1,L0184 TDO 1,L0185 CAMG 2,1 JRST L0198 MOVE 3,L0181 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+165 L0198: ADDM 4,2 MOVEM 3,1(2) MOVE 1,3 JRST L0197 L0192: MOVE 6,0(4) LDB 1,L0183 TDNE 1,L0184 TDO 1,L0185 CAMG 2,1 JRST L0199 MOVE 3,L0181 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+165 L0199: ADDM 4,2 MOVEM 3,1(2) MOVE 1,3 JRST L0197 L0191: MOVE 6,0(4) LDB 1,L0183 TDNE 1,L0184 TDO 1,L0185 CAMG 2,1 JRST L0200 MOVE 3,L0181 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+165 L0200: MOVE 1,4 AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 MOVE 1,3 JRST L0197 L0194: MOVEM 2,-4(15) L0201: SKIPLE -4(15) JRST L0202 MOVE 1,0 JRST L0203 L0202: MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) LDB 11,L0182 CAIN 11,9 JRST L0204 MOVE 3,L0181 MOVE 2,-1(15) PUSHJ 15,SYMFNC+165 L0204: SOS -4(15) JRST L0201 L0203: MOVE 7,0(15) MOVE 6,-2(15) MOVEM 6,0(7) MOVE 1,-2(15) JRST L0197 L0195: MOVE 2,L0181 MOVE 1,0(15) ADJSP 15,-5 JRST SYMFNC+166 L0197: ADJSP 15,-5 POPJ 15,0 L0182: point 6,1,5 L0183: point 30,6,35 L0184: 536870912 L0185: -536870912 L0181: <30_30>+167 3 ; (!*ENTRY SUB EXPR 3) SUB: intern SUB ADDM 2,3 AOS 3 JRST SYMFNC+169 3 ; (!*ENTRY SUBSEQ EXPR 3) SUBSEQ: intern SUBSEQ ADJSP 15,7 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 0,-5(15) TLNN 2,258048 JRST L0212 MOVE 2,L0205 MOVE 1,-1(15) ADJSP 15,-7 JRST SYMFNC+157 L0212: TLNN 3,258048 JRST L0213 MOVE 2,L0205 MOVE 1,3 ADJSP 15,-7 JRST SYMFNC+157 L0213: MOVE 4,3 SUB 4,2 SOS 4 MOVEM 4,-3(15) CAML 4,L0206 JRST L0214 MOVE 3,L0205 MOVE 2,-2(15) ADJSP 15,-7 JRST SYMFNC+165 L0214: LDB 1,L0207 CAIL 1,4 CAILE 1,9 JRST L0215 JRST @L0216-4(1) L0216: IFIW L0217 IFIW L0217 IFIW L0218 IFIW L0219 IFIW L0220 IFIW L0221 L0215: JRST L0222 L0217: MOVE 1,0(15) TLZ 1,258048 MOVE 6,0(1) LDB 5,L0208 TDNE 5,L0209 TDO 5,L0210 MOVEM 5,-4(15) MOVE 1,3 SOS 1 CAMG 1,5 JRST L0223 MOVE 3,L0205 MOVE 2,-2(15) MOVE 1,0(15) ADJSP 15,-7 JRST SYMFNC+165 L0223: MOVE 1,4 PUSHJ 15,SYMFNC+145 MOVEM 1,-5(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-2(15) MOVEM 0,-6(15) SETZM -6(15) L0224: MOVE 6,-6(15) CAMG 6,-3(15) JRST L0225 SETZM 1 JRST L0226 L0225: MOVE 2,-6(15) ADD 2,-1(15) MOVE 1,-2(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-6(15) MOVE 1,-5(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -6(15) JRST L0224 L0226: LDB 1,L0211 CAIN 1,4 JRST L0227 CAIN 1,5 JRST L0228 JRST L0229 L0227: MOVE 1,-5(15) TLZ 1,258048 TLO 1,16384 JRST L0230 L0228: MOVE 1,-5(15) TLZ 1,258048 TLO 1,20480 JRST L0230 L0229: MOVE 1,0 JRST L0230 L0220: MOVE 1,0(15) TLZ 1,258048 MOVE 6,0(1) LDB 5,L0208 TDNE 5,L0209 TDO 5,L0210 MOVEM 5,-4(15) MOVE 1,3 SOS 1 CAMG 1,5 JRST L0231 MOVE 3,L0205 MOVE 2,-2(15) MOVE 1,0(15) ADJSP 15,-7 JRST SYMFNC+165 L0231: MOVE 1,4 PUSHJ 15,SYMFNC+142 MOVEM 1,-5(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-2(15) MOVEM 0,-6(15) SETZM -6(15) L0232: MOVE 6,-6(15) CAMG 6,-3(15) JRST L0233 SETZM 1 JRST L0234 L0233: MOVE 2,-6(15) ADD 2,-5(15) MOVE 3,-6(15) ADD 3,-1(15) ADD 3,-2(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -6(15) JRST L0232 L0234: MOVE 1,-5(15) TLZ 1,258048 TLO 1,32768 JRST L0230 L0219: MOVE 1,0(15) TLZ 1,258048 MOVE 6,0(1) LDB 5,L0208 TDNE 5,L0209 TDO 5,L0210 MOVEM 5,-4(15) MOVE 1,3 SOS 1 CAMG 1,5 JRST L0235 MOVE 3,L0205 MOVE 2,-2(15) MOVE 1,0(15) ADJSP 15,-7 JRST SYMFNC+165 L0235: MOVE 1,4 PUSHJ 15,SYMFNC+170 MOVEM 1,-5(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-2(15) MOVEM 0,-6(15) SETZM -6(15) L0236: MOVE 6,-6(15) CAMG 6,-3(15) JRST L0237 SETZM 1 JRST L0238 L0237: MOVE 2,-6(15) ADD 2,-5(15) MOVE 3,-6(15) ADD 3,-1(15) ADD 3,-2(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -6(15) JRST L0236 L0238: MOVE 1,-5(15) TLZ 1,258048 TLO 1,28672 JRST L0230 L0218: MOVE 1,0(15) TLZ 1,258048 MOVE 6,0(1) LDB 5,L0208 TDNE 5,L0209 TDO 5,L0210 MOVEM 5,-4(15) MOVE 1,3 SOS 1 CAMG 1,5 JRST L0239 MOVE 3,L0205 MOVE 2,-2(15) MOVE 1,0(15) ADJSP 15,-7 JRST SYMFNC+165 L0239: MOVE 1,4 PUSHJ 15,SYMFNC+171 MOVEM 1,-5(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-2(15) MOVEM 0,-6(15) SETZM -6(15) L0240: MOVE 6,-6(15) CAMG 6,-3(15) JRST L0241 SETZM 1 JRST L0242 L0241: MOVE 2,-6(15) ADD 2,-1(15) MOVE 1,-2(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-6(15) MOVE 1,-5(15) AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -6(15) JRST L0240 L0242: MOVE 1,-5(15) TLZ 1,258048 TLO 1,24576 JRST L0230 L0221: MOVEM 0,-6(15) HRRZI 6,1 MOVEM 6,-6(15) L0243: MOVE 6,-6(15) CAMG 6,-1(15) JRST L0244 SETZM 1 JRST L0245 L0244: LDB 11,L0211 CAIE 11,9 JRST L0246 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0247 L0246: MOVE 3,L0205 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 L0247: AOS -6(15) JRST L0243 L0245: MOVE 1,0 PUSHJ 15,SYMFNC+172 MOVEM 1,-5(15) MOVEM 0,-6(15) SETZM -6(15) L0248: MOVE 6,-6(15) CAMG 6,-3(15) JRST L0249 SETZM 1 JRST L0250 L0249: LDB 11,L0211 CAIE 11,9 JRST L0251 MOVE 2,0(15) MOVE 2,0(2) MOVE 1,-5(15) PUSHJ 15,SYMFNC+173 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0252 L0251: MOVE 3,L0205 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 L0252: AOS -6(15) JRST L0248 L0250: MOVE 1,-5(15) MOVE 1,0(1) JRST L0230 L0222: MOVE 2,L0205 MOVE 1,0(15) ADJSP 15,-7 JRST SYMFNC+166 L0230: ADJSP 15,-7 POPJ 15,0 L0206: -1 L0207: point 6,1,5 L0208: point 30,6,35 L0209: 536870912 L0210: -536870912 L0211: point 6,0(15),5 L0205: <30_30>+169 4 ; (!*ENTRY SETSUB EXPR 4) SETSUB: intern SETSUB ADDM 2,3 AOS 3 JRST SYMFNC+175 4 ; (!*ENTRY SETSUBSEQ EXPR 4) L0262: intern L0262 ADJSP 15,9 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) MOVEM 4,-3(15) MOVEM 0,-4(15) MOVEM 0,-5(15) MOVEM 0,-6(15) MOVEM 0,-7(15) TLNN 2,258048 JRST L0263 MOVE 2,L0253 MOVE 1,-1(15) ADJSP 15,-9 JRST SYMFNC+157 L0263: TLNN 3,258048 JRST L0264 MOVE 2,L0253 MOVE 1,3 ADJSP 15,-9 JRST SYMFNC+157 L0264: MOVE 5,3 SUB 5,2 SOS 5 MOVEM 5,-4(15) CAML 5,L0254 JRST L0265 MOVE 3,L0253 MOVE 2,-2(15) ADJSP 15,-9 JRST SYMFNC+165 L0265: LDB 1,L0255 CAIL 1,4 CAILE 1,9 JRST L0266 JRST @L0267-4(1) L0267: IFIW L0268 IFIW L0268 IFIW L0269 IFIW L0270 IFIW L0271 IFIW L0272 L0266: JRST L0273 L0268: LDB 11,L0256 CAIN 11,4 JRST L0274 LDB 11,L0256 CAIN 11,5 JRST L0274 MOVE 2,L0253 MOVE 1,4 ADJSP 15,-9 JRST SYMFNC+143 L0274: MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-5(15) MOVE 1,4 TLZ 1,258048 MOVEM 1,-7(15) MOVE 6,0(1) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-6(15) MOVE 1,3 SOS 1 CAMG 1,-5(15) JRST L0275 MOVE 3,L0253 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 JRST L0276 L0275: CAMN 5,-6(15) JRST L0277 MOVE 3,L0253 MOVE 2,5 MOVE 1,4 PUSHJ 15,SYMFNC+165 JRST L0276 L0277: MOVEM 2,-2(15) MOVEM 0,-8(15) SETZM -8(15) L0278: MOVE 6,-8(15) CAMLE 6,-4(15) JRST L0276 MOVE 2,-8(15) MOVE 1,-7(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-8(15) ADD 2,-1(15) MOVE 1,-2(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -8(15) JRST L0278 L0271: LDB 11,L0256 CAIN 11,8 JRST L0279 MOVE 2,L0253 MOVE 1,4 ADJSP 15,-9 JRST SYMFNC+146 L0279: MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-5(15) MOVE 1,4 TLZ 1,258048 MOVEM 1,-7(15) MOVE 6,0(1) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-6(15) MOVE 1,3 SOS 1 CAMG 1,-5(15) JRST L0280 MOVE 3,L0253 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 JRST L0276 L0280: CAMN 5,-6(15) JRST L0281 MOVE 3,L0253 MOVE 2,5 MOVE 1,4 PUSHJ 15,SYMFNC+165 JRST L0276 L0281: MOVEM 2,-2(15) MOVEM 0,-8(15) SETZM -8(15) L0282: MOVE 6,-8(15) CAMLE 6,-4(15) JRST L0276 MOVE 2,-8(15) ADD 2,-1(15) ADD 2,-2(15) MOVE 3,-8(15) ADD 3,-7(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -8(15) JRST L0282 L0270: LDB 11,L0256 CAIN 11,7 JRST L0283 MOVE 2,L0253 MOVE 1,4 ADJSP 15,-9 JRST SYMFNC+146 L0283: MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-5(15) MOVE 1,4 TLZ 1,258048 MOVEM 1,-7(15) MOVE 6,0(1) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-6(15) MOVE 1,3 SOS 1 CAMG 1,-5(15) JRST L0284 MOVE 3,L0253 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 JRST L0276 L0284: CAMN 5,-6(15) JRST L0285 MOVE 3,L0253 MOVE 2,5 MOVE 1,4 PUSHJ 15,SYMFNC+165 JRST L0276 L0285: MOVEM 2,-2(15) MOVEM 0,-8(15) SETZM -8(15) L0286: MOVE 6,-8(15) CAMLE 6,-4(15) JRST L0276 MOVE 2,-8(15) ADD 2,-1(15) ADD 2,-2(15) MOVE 3,-8(15) ADD 3,-7(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -8(15) JRST L0286 L0269: LDB 11,L0256 CAIN 11,6 JRST L0287 MOVE 2,L0253 MOVE 1,4 ADJSP 15,-9 JRST SYMFNC+146 L0287: MOVE 2,0(15) TLZ 2,258048 MOVE 6,0(2) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-5(15) MOVE 1,4 TLZ 1,258048 MOVEM 1,-7(15) MOVE 6,0(1) LDB 1,L0257 TDNE 1,L0258 TDO 1,L0259 MOVEM 1,-6(15) MOVE 1,3 SOS 1 CAMG 1,-5(15) JRST L0288 MOVE 3,L0253 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 JRST L0276 L0288: CAMN 5,-6(15) JRST L0289 MOVE 3,L0253 MOVE 2,5 MOVE 1,4 PUSHJ 15,SYMFNC+165 JRST L0276 L0289: MOVEM 2,-2(15) MOVEM 0,-8(15) SETZM -8(15) L0290: MOVE 6,-8(15) CAMLE 6,-4(15) JRST L0276 MOVE 2,-8(15) MOVE 1,-7(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-8(15) ADD 2,-1(15) MOVE 1,-2(15) AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -8(15) JRST L0290 L0272: LDB 11,L0256 CAIN 11,9 JRST L0291 CAMN 4,0 JRST L0291 MOVE 2,L0253 MOVE 1,4 ADJSP 15,-9 JRST SYMFNC+149 L0291: MOVEM 0,-8(15) HRRZI 6,1 MOVEM 6,-8(15) L0292: MOVE 6,-8(15) CAMLE 6,-1(15) JRST L0293 LDB 11,L0260 CAIE 11,9 JRST L0294 MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) JRST L0295 L0294: MOVE 3,L0253 MOVE 2,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 L0295: AOS -8(15) JRST L0292 L0293: MOVE 6,-3(15) MOVEM 6,-7(15) MOVEM 0,-8(15) SETZM -8(15) L0296: MOVE 6,-8(15) CAMLE 6,-4(15) JRST L0276 LDB 11,L0260 CAIE 11,9 JRST L0297 LDB 11,L0261 CAIE 11,9 JRST L0297 MOVE 7,0(15) MOVE 6,-7(15) MOVE 6,0(6) MOVEM 6,0(7) MOVE 1,0(15) MOVE 1,1(1) MOVEM 1,0(15) MOVE 2,-7(15) MOVE 2,1(2) MOVEM 2,-7(15) JRST L0298 L0297: MOVE 3,L0253 MOVE 2,-2(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+165 L0298: AOS -8(15) JRST L0296 L0273: MOVE 2,L0253 MOVE 1,0(15) PUSHJ 15,SYMFNC+166 L0276: MOVE 1,-3(15) ADJSP 15,-9 POPJ 15,0 L0254: -1 L0255: point 6,1,5 L0256: point 6,4,5 L0257: point 30,6,35 L0258: 536870912 L0259: -536870912 L0260: point 6,0(15),5 L0261: point 6,-7(15),5 L0253: <30_30>+175 2 ; (!*ENTRY CONCAT EXPR 2) CONCAT: intern CONCAT ADJSP 15,8 MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 0,-2(15) MOVEM 0,-3(15) MOVEM 0,-4(15) MOVEM 0,-5(15) MOVEM 0,-6(15) LDB 1,L0299 CAIL 1,4 CAILE 1,9 JRST L0306 JRST @L0307-4(1) L0307: IFIW L0308 IFIW L0308 IFIW L0309 IFIW L0310 IFIW L0311 IFIW L0312 L0306: CAIN 1,30 JRST L0312 JRST L0313 L0308: LDB 11,L0300 CAIN 11,4 JRST L0314 LDB 11,L0300 CAIN 11,5 JRST L0314 MOVE 2,L0301 MOVE 1,-1(15) ADJSP 15,-8 JRST SYMFNC+143 L0314: MOVE 3,0(15) TLZ 3,258048 MOVEM 3,-4(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-5(15) MOVE 6,0(3) LDB 5,L0302 TDNE 5,L0303 TDO 5,L0304 MOVEM 5,-2(15) MOVE 6,0(4) LDB 1,L0302 TDNE 1,L0303 TDO 1,L0304 MOVEM 1,-3(15) ADDM 5,1 AOS 1 PUSHJ 15,SYMFNC+145 MOVEM 1,-6(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 3,-1(15) TLZ 3,258048 MOVEM 3,-5(15) MOVEM 0,-7(15) SETZM -7(15) L0315: MOVE 6,-7(15) CAMG 6,-2(15) JRST L0316 SETZM 1 JRST L0317 L0316: MOVE 2,-7(15) MOVE 1,-4(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-7(15) MOVE 1,-6(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -7(15) JRST L0315 L0317: MOVEM 0,-7(15) SETZM -7(15) L0318: MOVE 6,-7(15) CAMG 6,-3(15) JRST L0319 SETZM 1 JRST L0320 L0319: MOVE 2,-7(15) MOVE 1,-5(15) AOS 1 TLO 1,204800 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-7(15) ADD 2,-2(15) AOS 2 MOVE 1,-6(15) AOS 1 TLO 1,204800 ADJBP 2,1 DPB 3,2 AOS -7(15) JRST L0318 L0320: LDB 11,L0305 CAIE 11,4 JRST L0321 MOVE 1,-6(15) TLZ 1,258048 TLO 1,16384 JRST L0322 L0321: MOVE 1,-6(15) TLZ 1,258048 TLO 1,20480 JRST L0322 L0311: LDB 11,L0300 CAIN 11,8 JRST L0323 MOVE 2,L0301 MOVE 1,-1(15) ADJSP 15,-8 JRST SYMFNC+146 L0323: MOVE 3,0(15) TLZ 3,258048 MOVEM 3,-4(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-5(15) MOVE 6,0(3) LDB 5,L0302 TDNE 5,L0303 TDO 5,L0304 MOVEM 5,-2(15) MOVE 6,0(4) LDB 1,L0302 TDNE 1,L0303 TDO 1,L0304 MOVEM 1,-3(15) ADDM 5,1 AOS 1 PUSHJ 15,SYMFNC+142 MOVEM 1,-6(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 3,-1(15) TLZ 3,258048 MOVEM 3,-5(15) MOVEM 0,-7(15) SETZM -7(15) L0324: MOVE 6,-7(15) CAMG 6,-2(15) JRST L0325 SETZM 1 JRST L0326 L0325: MOVE 2,-7(15) ADD 2,-6(15) MOVE 3,-7(15) ADD 3,-4(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -7(15) JRST L0324 L0326: MOVEM 0,-7(15) SETZM -7(15) L0327: MOVE 6,-7(15) CAMG 6,-3(15) JRST L0328 SETZM 1 JRST L0329 L0328: MOVE 2,-7(15) ADD 2,-2(15) ADD 2,-6(15) MOVE 3,-7(15) ADD 3,-5(15) MOVE 6,1(3) MOVEM 6,2(2) AOS -7(15) JRST L0327 L0329: MOVE 1,-6(15) TLZ 1,258048 TLO 1,32768 JRST L0322 L0310: LDB 11,L0300 CAIN 11,7 JRST L0330 MOVE 2,L0301 MOVE 1,-1(15) ADJSP 15,-8 JRST SYMFNC+146 L0330: MOVE 3,0(15) TLZ 3,258048 MOVEM 3,-4(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-5(15) MOVE 6,0(3) LDB 5,L0302 TDNE 5,L0303 TDO 5,L0304 MOVEM 5,-2(15) MOVE 6,0(4) LDB 1,L0302 TDNE 1,L0303 TDO 1,L0304 MOVEM 1,-3(15) ADDM 5,1 AOS 1 PUSHJ 15,SYMFNC+170 MOVEM 1,-6(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 3,-1(15) TLZ 3,258048 MOVEM 3,-5(15) MOVEM 0,-7(15) SETZM -7(15) L0331: MOVE 6,-7(15) CAMG 6,-2(15) JRST L0332 SETZM 1 JRST L0333 L0332: MOVE 2,-7(15) ADD 2,-6(15) MOVE 3,-7(15) ADD 3,-4(15) MOVE 6,1(3) MOVEM 6,1(2) AOS -7(15) JRST L0331 L0333: MOVEM 0,-7(15) SETZM -7(15) L0334: MOVE 6,-7(15) CAMG 6,-3(15) JRST L0335 SETZM 1 JRST L0336 L0335: MOVE 2,-7(15) ADD 2,-2(15) ADD 2,-6(15) MOVE 3,-7(15) ADD 3,-5(15) MOVE 6,1(3) MOVEM 6,2(2) AOS -7(15) JRST L0334 L0336: MOVE 1,-6(15) TLZ 1,258048 TLO 1,28672 JRST L0322 L0309: LDB 11,L0300 CAIN 11,6 JRST L0337 MOVE 2,L0301 MOVE 1,-1(15) ADJSP 15,-8 JRST SYMFNC+146 L0337: MOVE 3,0(15) TLZ 3,258048 MOVEM 3,-4(15) MOVE 4,2 TLZ 4,258048 MOVEM 4,-5(15) MOVE 6,0(3) LDB 5,L0302 TDNE 5,L0303 TDO 5,L0304 MOVEM 5,-2(15) MOVE 6,0(4) LDB 1,L0302 TDNE 1,L0303 TDO 1,L0304 MOVEM 1,-3(15) ADDM 5,1 AOS 1 PUSHJ 15,SYMFNC+171 MOVEM 1,-6(15) MOVE 2,0(15) TLZ 2,258048 MOVEM 2,-4(15) MOVE 3,-1(15) TLZ 3,258048 MOVEM 3,-5(15) MOVEM 0,-7(15) SETZM -7(15) L0338: MOVE 6,-7(15) CAMG 6,-2(15) JRST L0339 SETZM 1 JRST L0340 L0339: MOVE 2,-7(15) MOVE 1,-4(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-7(15) MOVE 1,-6(15) AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -7(15) JRST L0338 L0340: MOVEM 0,-7(15) SETZM -7(15) L0341: MOVE 6,-7(15) CAMG 6,-3(15) JRST L0342 SETZM 1 JRST L0343 L0342: MOVE 2,-7(15) MOVE 1,-5(15) AOS 1 TLO 1,245760 ADJBP 2,1 LDB 1,2 MOVE 3,1 MOVE 2,-7(15) ADD 2,-2(15) AOS 2 MOVE 1,-6(15) AOS 1 TLO 1,245760 ADJBP 2,1 DPB 3,2 AOS -7(15) JRST L0341 L0343: MOVE 1,-6(15) TLZ 1,258048 TLO 1,24576 JRST L0322 L0312: CAMN 0,0(15) JRST L0344 LDB 11,L0305 CAIE 11,9 JRST L0345 L0344: MOVE 1,0(15) ADJSP 15,-8 JRST SYMFNC+177 L0345: MOVE 1,0 JRST L0322 L0313: MOVE 2,L0301 MOVE 1,0(15) ADJSP 15,-8 JRST SYMFNC+166 L0322: ADJSP 15,-8 POPJ 15,0 L0299: point 6,1,5 L0300: point 6,2,5 L0302: point 30,6,35 L0303: 536870912 L0304: -536870912 L0305: point 6,0(15),5 L0301: <30_30>+176 1 ; (!*ENTRY SIZE EXPR 1) SIZE: intern SIZE MOVE 4,1 LDB 1,L0346 CAIL 1,4 CAILE 1,9 JRST L0352 JRST @L0353-4(1) L0353: IFIW L0354 IFIW L0354 IFIW L0354 IFIW L0354 IFIW L0354 IFIW L0355 L0352: CAIN 1,30 JRST L0356 JRST L0357 L0354: MOVE 2,4 TLZ 2,258048 MOVE 6,0(2) LDB 1,L0347 TDNE 1,L0348 TDO 1,L0349 POPJ 15,0 L0356: SETOM 1 POPJ 15,0 L0355: MOVE 3,0 SETOM 3 L0358: LDB 11,L0350 CAIE 11,9 JRST L0359 AOS 3 MOVE 1,1(4) MOVE 4,1 JRST L0358 L0359: MOVE 1,3 POPJ 15,0 L0357: MOVE 2,L0351 MOVE 1,4 JRST SYMFNC+166 L0346: point 6,1,5 L0347: point 30,6,35 L0348: 536870912 L0349: -536870912 L0350: point 6,4,5 L0351: <30_30>+178 end |
Added psl-1983/3-1/kernel/20/types.rel version [1574940615].
cannot compute difference between binary files
Added psl-1983/3-1/kernel/20/write-float.red version [5f6b3377e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % WRITE-FLOAT.RED - format a floating point number into a string % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 November 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>WRITE-FLOAT.RED.3, 28-Sep-82 15:44:53, Edit by BENSON % Changed DMOVE to 2 moves, so this will run on a KI10 Tenex lap '((!*entry WriteFloat expr 2) % convert float to string % % r1 is string pointer, r2 is pointer to 2 word float % puts characters in string buffer with terminating null char and count % (!*MOVE (reg 1) (reg t1)) % save pointer to string count (!*WPLUS2 (reg 1) (WConst 1)) % move to chars (hrli (reg 1) 8#440700) % make r1 a byte pointer (!*MOVE (reg 1) (reg t2)) % save starting byte pointer (move (reg 3) (Indexed (reg 2) 1)) % load r2 and r3 with the number (move (reg 2) (Indexed (reg 2) 0)) (move (reg 4) (lit (fullword 2#000010100000001000000000010000000000))) % fl%one + fl%pnt + 16 fl%rnd (dfout) (!*JUMP (Label Error)) (!*MOVE (WConst -1) (reg 4)) % count := -1 Count (!*JUMPEQ (Label DoneCounting) (reg 1) (reg t2)) % byte pointers equal? (ibp (reg t2)) (aoja (reg 4) Count) % Count := Count + 1 DoneCounting (!*MOVE (reg 4) (MEMORY (reg t1) (WConst 0))) % deposit count (!*MOVE (WConst 0) (reg 2)) (idpb (reg 4) (reg 1)) % deposit null byte (!*EXIT 0) Error (!*MOVE (QUOTE "Couldn't print float") (reg 1)) (!*JCALL IOError) ); END; |
Added psl-1983/3-1/kernel/alloc.build version [dbcb4e1e79].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | % % ALLOC.BUILD - Files dealing with allocation of memory blocks % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "allocators.red"$ % heap, symbol and code space alloc PathIn "copiers.red"$ % copying functions PathIn "cons-mkvect.red"$ % SL constructor functions PathIn "comp-support.red"$ % optimized CONS and LIST compilation PathIn "system-gc.red"$ % system-specific GC routines PathIn "gc.red"$ % the garbage collector |
Added psl-1983/3-1/kernel/allocators.red version [798c1d69b2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ALLOCATORS.RED - Low level storage management % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>ALLOCATORS.RED.7, 23-Mar-83 11:35:37, Edit by KESSLER % Added OldHeapTrapBound to exported WVars, so we can update the heap trap % bound upon switch. % Edit by Cris Perdue, 16 Feb 1983 1834-PST % Pre-GC trap, known-free-space fns % <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE % Added GtEVect on SysLisp; external WArray BPS, Heap; if_system(PDP10, << % For the compacting GC exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], HeapTrapBound = &Heap[HeapSize]; % Value of HeapLast for trap >>, << exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize/2], % end of active heap OldHeapLast, OldHeapLowerBound = &Heap[HeapSize/2 + 1], OldHeapUpperBound = &Heap[HeapSize], HeapTrapBound = &Heap[HeapSize/2], % Value of HeapLast for trap OldHeapTrapBound = &Heap[HeapSize]; >>); exported WVar HeapTrapped = NIL; % Boolean: trap since last GC? compiletime flag('(GtHeap1), 'InternalFunction); syslsp procedure Known!-Free!-Space; MkInt((HeapUpperBound - HeapLast)/AddressingUnitsPerItem); syslsp procedure GtHEAP N; %. get heap block of N words if null N then known!-free!-space() else GtHeap1(N, NIL); syslsp procedure GtHeap1(N, LastTryP); begin scalar PrevLast; PrevLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapTrapBound then if HeapLast > HeapUpperBound then << HeapLast := PrevLast; if LastTryP then FatalError "Heap space exhausted" else << !%Reclaim(); return GtHeap1(N, T) >> >> else %% From one GC to the next there can be at most 1 GC trap, %% done the first time space gets "low". %Reclaim resets %% HeapTrapped to NIL. if HeapTrapped = NIL then << HeapTrapped := T; GC!-Trap() >>; return PrevLast end; syslsp procedure GC!-Trap!-Level; MkInt (HeapUpperBound - HeapTrapBound)/AddressingUnitsPerItem; syslsp procedure Set!-GC!-Trap!-Level N; << if not IntP(N) then NonIntegerError(N, 'Set!-GC!-Trap!-Level); N := IntInf N; HeapTrapBound := HeapUpperBound - N*AddressingUnitsPerItem; T >>; syslsp procedure DelHeap(LowPointer, HighPointer); if HighPointer eq HeapLast then HeapLast := LowPointer; syslsp procedure GtSTR N; %. Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtConstSTR N; %. allocate un-collected string for print name begin scalar S, NW; % same as GtSTR, but uses BPS, not heap S := GtBPS((NW := STRPack N) + 1); @S := N; S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtHalfWords N; %. Allocate space for N halfwords begin scalar S, NW; S := GtHEAP((NW := HalfWordPack N) + 1); @S := MkItem(HHalfWords, N); return S; end; syslsp procedure GtVECT N; %. Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; Putd('GtEvect,'expr,cdr getd 'GtVect); syslsp procedure GtWRDS N; %. Allocate space for N untraced words begin scalar W; W := GtHEAP(WRDPack N + 1); @W := MkItem(HWRDS, N); return W; end; syslsp procedure GtFIXN(); %. allocate space for a fixnum begin scalar W; W := GtHEAP(WRDPack 0 + 1); @W := MkItem(HWRDS, 0); return W; end; syslsp procedure GtFLTN(); %. allocate space for a float begin scalar W; W := GtHEAP(WRDPack 1 + 1); @W := MkItem(HWRDS, 1); return W; end; % NextSymbol and SymbolTableSize are globally declared syslsp procedure GtID(); %. Allocate a new ID % % IDs are allocated as a linked free list through the SymNam cell, % with a 0 to indicate the end of the list. % begin scalar U; if NextSymbol = 0 then << Reclaim(); if NextSymbol = 0 then return FatalError "Ran out of ID space" >>; U := NextSymbol; NextSymbol := SymNam U; return U; end; exported WVar NextBPS = &BPS[0], LastBPS = &BPS[BPSSize]; syslsp procedure GtBPS N; %. Allocate N words for binary code begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GTBPS NIL returns # left B := NextBPS; NextBPS := NextBPS + N*AddressingUnitsPerItem; return if NextBPS > LastBPS then StdError '"Ran out of binary program space" else B; end; syslsp procedure DelBPS(Bottom, Top); %. Return space to BPS if NextBPS eq Top then NextBPS := Bottom; syslsp procedure GtWArray N; %. Allocate N words for WVar/WArray/WString begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GtWArray NIL returns # left B := LastBPS - N*AddressingUnitsPerItem; return if NextBPS > B then StdError '"Ran out of WArray space" else LastBPS := B; end; syslsp procedure DelWArray(Bottom, Top); %. Return space for WArray if LastBPS eq Bottom then LastBPS := Top; off SysLisp; END; |
Added psl-1983/3-1/kernel/arith.build version [48c248f65c].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % % ARITH.BUILD - Files dealing with arithmetic % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "arithmetic.red"$ % Lisp arithmetic functions |
Added psl-1983/3-1/kernel/arithmetic.red version [23d2898843].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 January 1982 % Copyright (c) 1982 University of Utah % CompileTime flag('(TwoArgDispatch TwoArgDispatch1 TwoArgError OneArgDispatch OneArgDispatch1 OneArgPredicateDispatch OneArgPredicateDispatch1 OneArgError IntAdd1 IntSub1 IntPlus2 IntTimes2 IntDifference IntQuotient IntRemainder IntLShift IntLAnd IntLOr IntLXOr IntGreaterP IntLessP IntMinus IntMinusP IntZeroP IntOneP IntLNot FloatIntArg FloatAdd1 FloatSub1 FloatPlus2 FloatTimes2 FloatQuotient FloatRemainder FloatDifference FloatGreaterP FloatLessP FloatMinus FloatMinusP FloatZeroP FloatOneP StaticIntFloat FloatFix NonInteger1Error NonInteger2Error MakeFixnum BigFloatFix), 'InternalFunction); on SysLisp; CompileTime << syslsp macro procedure IsInum U; list('(lambda (X) (eq (SignedField X (ISub1 (WConst InfStartingBit)) (IAdd1 (WConst InfBitLength))) X)), second U); >>; internal WConst IntFunctionEntry = 0, FloatFunctionEntry = 1, FunctionNameEntry = 2; syslsp procedure TwoArgDispatch(FirstArg, SecondArg); TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg); lap '((!*entry TwoArgDispatch1 expr 4) (!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 3)) NotNeg1 (!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 4)) NotNeg2 (!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN)) (!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN)) (!*WSHIFT (reg 3) (WConst 2)) (!*WPLUS2 (reg 4) (reg 3)) (!*POP (reg 3)) (!*JUMPON (reg 4) 0 15 ((Label IntInt) (Label IntFix) (Label TemporaryNonEntry) (Label IntFloat) (Label FixInt) (Label FixFix) (Label TemporaryNonEntry) (Label FixFloat) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label FloatInt) (Label FloatFix) (Label TemporaryNonEntry) (Label FloatFloat))) TemporaryNonEntry (!*JCALL TwoArgError) FixInt (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) FixFix (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) IntInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) FixFloat (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) FloatFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) FloatInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) FloatFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) NonNumeric (!*POP (reg 3)) (!*JCALL TwoArgError) ); syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger1Error(Arg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], Arg)); syslsp procedure OneArgDispatch FirstArg; OneArgDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label TemporaryNonEntry) (Label OneFloat))) TemporaryNonEntry (!*JCALL OneArgError) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) OneFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) ); syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg)); syslsp procedure OneArgPredicateDispatch FirstArg; OneArgPredicateDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgPredicateDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label TemporaryNonEntry) (Label OneFloat))) TemporaryNonEntry (!*MOVE (QUOTE NIL) (reg 1)) (!*EXIT 0) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) OneFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) ); syslsp procedure MakeFixnum N; begin scalar F; F := GtFIXN(); FixVal F := N; return MkFIXN F; end; syslsp procedure BigFloatFix N; StdError '"Bignums not yet supported"; syslsp procedure ReturnNIL(); NIL; syslsp procedure ReturnFirstArg Arg; Arg; internal WArray StaticFloatBuffer = [1, 0, 0]; internal WVar StaticFloatItem = MkItem(FLTN, StaticFloatBuffer); syslsp procedure StaticIntFloat Arg; << !*WFloat(&StaticFloatBuffer[1], Arg); StaticFloatItem >>; off SysLisp; CompileTime << macro procedure DefArith2Entry U; DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U); macro procedure DefArith1Entry U; DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U); macro procedure DefArith1PredicateEntry U; DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U); lisp procedure StupidParserFix X; % Goddamn Rlisp parser won't let me just give "Difference" as the parameter % to a macro if null X then X else RemQuote car X . StupidParserFix cdr X; lisp procedure RemQuote X; if EqCar(X, 'QUOTE) then cadr X else X; lisp procedure DefArithEntry L; SublA(Pair('(NumberOfArguments DispatchRoutine NameOfFunction IntFunction BigFunction FloatFunction), L), quote(lap '((!*entry NameOfFunction expr NumberOfArguments) (!*Call DispatchRoutine) (fullword (InternalEntry IntFunction)) % (fullword (InternalEntry BigFunction)) (fullword (InternalEntry FloatFunction)) (fullword (MkItem (WConst ID) (IDLoc NameOfFunction)))))); >>; DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2); syslsp procedure IntPlus2(FirstArg, SecondArg); if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatPlus2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FPlus2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference); syslsp procedure IntDifference(FirstArg, SecondArg); if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatDifference(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2); % What about overflow? syslsp procedure IntTimes2(FirstArg, SecondArg); begin scalar Result; Result := WTimes2(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatTimes2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FTimes2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient); syslsp procedure IntQuotient(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); Result := WQuotient(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatQuotient(FirstArg, SecondArg); begin scalar F; if FloatZeroP SecondArg then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); F := GtFLTN(); !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder); syslsp procedure IntRemainder(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Remainder", Remainder(FirstArg, SecondArg)); Result := WRemainder(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatRemainder(FirstArg, SecondArg); begin scalar F; % This is pretty silly F := GtFLTN(); % might be better to signal an error !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); !*FTimes2(FloatBase F, FloatBase F, FloatBase FltInf SecondArg); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase F); return MkFLTN F; end; DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error); syslsp procedure IntLAnd(FirstArg, SecondArg); if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error); syslsp procedure IntLOr(FirstArg, SecondArg); if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error); syslsp procedure IntLXOr(FirstArg, SecondArg); if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error); PutD('LSH, 'EXPR, cdr GetD 'LShift); syslsp procedure IntLShift(FirstArg, SecondArg); begin scalar Result; Result := WShift(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP); syslsp procedure IntGreaterP(FirstArg, SecondArg); WGreaterP(FirstArg, SecondArg); syslsp procedure FloatGreaterP(FirstArg, SecondArg); !*FGreaterP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP); syslsp procedure IntLessP(FirstArg, SecondArg); WLessP(FirstArg, SecondArg); syslsp procedure FloatLessP(FirstArg, SecondArg); !*FLessP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1); syslsp procedure IntAdd1 FirstArg; if IsInum(FirstArg := WPlus2(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatAdd1 FirstArg; FloatPlus2(FirstArg, 1.0); DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1); lisp procedure IntSub1 FirstArg; if IsInum(FirstArg := WDifference(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatSub1 FirstArg; FloatDifference(FirstArg, 1.0); DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error); lisp procedure IntLNot X; if IsInum(X := WNot X) then X else MakeFixnum X; DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus); lisp procedure IntMinus FirstArg; if IsInum(FirstArg := WMinus FirstArg) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatMinus FirstArg; FloatDifference(0.0, FirstArg); DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix); syslsp procedure FloatFix Arg; begin scalar R; return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R else MakeFixnum R; end; DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg); syslsp procedure FloatIntArg Arg; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, Arg); return MkFLTN F; end; DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP); syslsp procedure IntMinusP FirstArg; WLessP(FirstArg, 0); lisp procedure FloatMinusP FirstArg; FloatLessP(FirstArg, 0.0); DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP); lisp procedure IntZeroP FirstArg; FirstArg = 0; lisp procedure FloatZeroP FirstArg; EQN(FirstArg, 0.0); DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP); lisp procedure IntOneP FirstArg; FirstArg = 1; lisp procedure FloatOneP FirstArg; EQN(FirstArg, 1.0); END; |
Added psl-1983/3-1/kernel/autoload-trace.red version [ee4aab36d8].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % % AUTOLOAD-TRACE.RED - Autoloading stubs for DEBUG % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1982 % Copyright (c) 1982 University of Utah % % This file is used instead of MINI-TRACE.RED for those systems which % can load files lisp macro procedure TR U; << load Debug; Apply('TR, list U) >>; lisp macro procedure TRST U; << load Debug; Apply('TRST, list U) >>; END; |
Added psl-1983/3-1/kernel/autoload.red version [e698ab5fff].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % AUTOLOAD.RED - Autoloading entry stubs % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 March 1982 % Copyright (c) 1982 University of Utah % % 07-Mar-83 Nancy Kendzierski % Changed PrettyPrint to use PP, not PrettyPrint. % Added PP as an autoloaded function. % <PSL.KERNEL>AUTOLOAD.RED.3, 17-Sep-82 16:35:02, Edit by BENSON % Changed PrettyPrint to use PrettyPrint, not Pretty CompileTime << macro procedure DefAutoload U; % % (DefAutoload name), (DefAutoload name loadname), % (DefAutoload name loadname fntype), or % (DefAutoload name loadname fntype numargs) % % Default is 1 Arg EXPR in module of same name % begin scalar Name, NumArgs, LoadName, FnType; U := rest U; Name := first U; U := rest U; if not null U then << LoadName := first U; U :=rest U >> else LoadName := Name; if EqCar(Name, 'QUOTE) then Name := second Name; if EqCar(LoadName, 'QUOTE) then LoadName := second LoadName; if not null U then << FnType := first U; U := rest U >> else FnType := 'EXPR; if not null U then NumArgs := first U else NumArgs := 1; NumArgs := MakeArgList NumArgs; return list('PutD, MkQuote Name, MkQuote FnType, list('function, list('lambda, NumArgs, list('load, LoadName), list('Apply, MkQuote Name, 'list . NumArgs)))); end; lisp procedure MakeArgList N; GetV('[() (X1) (X1 X2) (X1 X2 X3) (X1 X2 X3 X4) (X1 X2 X3 X4 X5)], N); >>; DefAutoload(PrettyPrint, PP); DefAutoload(PP, PP, FEXPR); DefAutoload(DefStruct, DefStruct, FEXPR); DefAutoload(Step); DefAutoload Mini; DefAutoload('Help, 'Help, FEXPR); DefAutoload(Emode, Emode, EXPR, 0); DefAutoload(Invoke, Mini); PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); DefAutoload(CrefOn, RCref, EXPR, 0); put('Syslisp, 'SimpFg, '((T (load Syslisp)))); DefAutoload(CompD, Compiler, EXPR, 3); DefAutoload(FaslOUT, Compiler); if_system(Tops20, << DefAutoload(Bug, Bug, EXPR, 0); DefAutoload(MM, Exec, EXPR, 0); DefAutoload(Exec, Exec, EXPR, 0); >>); END; |
Added psl-1983/3-1/kernel/backtrace.red version [970f71f38a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.KERNEL>BACKTRACE.RED.3, 20-Sep-82 10:21:41, Edit by BENSON % Attempt to make output easier to read CompileTime flag('(Backtrace1 BacktraceRange), 'InternalFunction); fluid '(IgnoredInBacktrace!* Options!* InterpreterFunctions!*); IgnoredInBacktrace!* := '(Eval Apply FastApply CodeApply CodeEvalApply Catch ErrorSet EvProgN TopLoop BreakEval BindEval Break Main); InterpreterFunctions!* := '(Cond Prog And Or ProgN SetQ); on SysLisp; external WVar StackLowerBound, HeapUpperBound; syslsp procedure InterpBacktrace(); begin scalar Here; Here := &Here; PrintF "Backtrace, including interpreter functions, from top of stack:%n"; return BacktraceRange(Here, StackLowerBound, 1); end; syslsp procedure Backtrace(); begin scalar Here, X; Here := &Here; PrintF "Backtrace from top of stack:%n"; return BacktraceRange(Here, StackLowerBound, 0); end; syslsp procedure BacktraceRange(Starting, Ending, InterpFlag); begin scalar X; for I := Starting step -(AddressingUnitsPerItem*StackDirection) until Ending do if Tag @I eq BtrTag then Backtrace1(MkID Inf @I, InterpFlag) else if (X := ReturnAddressP @I) then Backtrace1(X, InterpFlag); return TerPri(); end; syslsp procedure VerboseBacktrace(); begin scalar Here, X; if not 'addr2id member options!* then load addr2id; Here := &Here; % start a little before here for I := Here step -(AddressingUnitsPerItem*StackDirection) until StackLowerBound do if CodeP @I and Inf @I > HeapUpperBound then << WriteChar char TAB; ChannelWriteUnknownItem(LispVar OUT!*, @I); TerPri() >> else if Tag @I eq BtrTag then PrintF(" %r%n", MkID Inf @I) else if (X := ReturnAddressP @I) then PrintF("%p -> %p:%n", code!-address!-to!-symbol Inf @I, X) else PrintF(" %p%n", @I); return TerPri(); end; off SysLisp; lisp procedure Backtrace1(Item, Code); % % Code is 1 if Interpreter functions should be printed, 0 if not. % if not (Item memq IgnoredInBacktrace!*) then if not (Code = 0 and Item memq InterpreterFunctions!*) then << Prin1 Item; WriteChar char BLANK >>; END; |
Added psl-1983/3-1/kernel/binding.red version [b1ac91bb47].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BINDING.RED - Primitives to support Lambda binding % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>BINDING.RED.2, 21-Dec-82 15:57:06, Edit by BENSON % Added call to %clear-catch-stack in ClearBindings % Support for binding in compiled code is in FAST-BINDER.RED on SysLisp; internal WConst BndStkSize = 2000; internal WArray BndStk[BndStkSize]; % Only these WVars, which contain addresses rather than indexes, will be % used to access the binding stack exported WVar BndStkLowerBound = &BndStk[0], BndStkUpperBound = &BndStk[BndStkSize-1], BndStkPtr = &BndStk[0]; % Only the macros BndStkID, BndStkVal and AdjustBndStkPtr will be used % to access or modify the binding stack and pointer. syslsp procedure BStackOverflow(); << ChannelPrin2(LispVar ErrOUT!*, "***** Binding stack overflow, restarting..."); ChannelWriteChar(LispVar ErrOUT!*, char EOL); Reset() >>; syslsp procedure BStackUnderflow(); << ChannelPrin2(LispVar ErrOUT!*, "***** Binding stack underflow, restarting..."); ChannelWriteChar(LispVar ErrOUT!*, char EOL); Reset() >>; syslsp procedure CaptureEnvironment(); %. Save bindings to be restored BndStkPtr; syslsp procedure RestoreEnvironment Ptr; %. Restore old bindings << if Ptr < BndStkLowerBound then BStackUnderflow() else while BndStkPtr > Ptr do << SymVal BndStkID BndStkPtr := BndStkVal BndStkPtr; BndStkPtr := AdjustBndStkPtr(BndStkPtr, -1) >> >>; syslsp procedure ClearBindings(); %. Restore bindings to top level << RestoreEnvironment BndStkLowerBound; !%clear!-catch!-stack() >>; syslsp procedure UnBindN N; %. Support for Lambda and Prog interp RestoreEnvironment AdjustBndStkPtr(BndStkPtr, -IntInf N); syslsp procedure LBind1(IDName, ValueToBind); %. Support for Lambda if not IDP IDName then NonIDError(IDName, "binding") else if null IDName or IDName eq 'T then StdError '"T and NIL cannot be rebound" else << BndStkPtr := AdjustBndStkPtr(BndStkPtr, 1); if BndStkPtr > BndStkUpperBound then BStackOverflow() else << IDName := IDInf IDName; BndStkID BndStkPtr := IDName; BndStkVal BndStkPtr := SymVal IDName; SymVal IDName := ValueToBind >> >>; syslsp procedure PBind1 IDName; %. Support for PROG LBind1(IDName, NIL); off SysLisp; END; |
Added psl-1983/3-1/kernel/break.red version [c93d6df10c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BREAK.RED - Break using new top loop % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>BREAK.RED.2, 11-Oct-82 17:52:13, Edit by BENSON % Changed CATCH/THROW to new definition % <PSL.INTERP>BREAK.RED.6, 28-Jul-82 14:29:59, Edit by BENSON % Added A for abort-to-top-level % <PSL.INTERP>BREAK.RED.3, 30-Apr-82 14:34:33, Edit by BENSON % Added binding of !*DEFN to NIL fluid '(!*Break !*QuitBreak BreakEval!* BreakName!* BreakValue!* ErrorForm!* BreakLevel!* MaxBreakLevel!* TopLoopName!* TopLoopEval!* TopLoopRead!* TopLoopPrint!* !*DEFN % break binds !*DEFN to NIL BreakIn!* BreakOut!*); LoadTime << BreakLevel!* := 0; MaxBreakLevel!* := 5; >>; lisp procedure Break(); %. Enter top loop within evaluation (lambda(BreakLevel!*); begin scalar OldIn, OldOut, !*QuitBreak,BreakValue!*, !*Defn; OldIn := RDS BreakIn!*; OldOut := WRS BreakOut!*; !*QuitBreak := T; if TopLoopName!* then << if TopLoopEval!* neq 'BreakEval then << BreakEval!* := TopLoopEval!*; BreakName!* := ConCat(TopLoopName!*, " break") >>; Catch('!$Break!$, TopLoop(TopLoopRead!*, TopLoopPrint!*, 'BreakEval, BreakName!*, "Break loop")) >> else << BreakEval!* := 'Eval; BreakName!* := "lisp break"; Catch('!$Break!$, TopLoop('Read, 'Print, 'BreakEval, BreakName!*, "Break loop")) >>; RDS OldIn; WRS OldOut; return if !*QuitBreak then begin scalar !*Break, !*EmsgP; return StdError "Exit to ErrorSet"; end else Eval ErrorForm!*; end)(BreakLevel!* + 1); lisp procedure BreakEval U; begin scalar F; return if IDP U and (F := get(U, 'BreakFunction)) then Apply(F, NIL) else BreakValue!*:=Apply(BreakEval!*, list U); end; lisp procedure BreakQuit(); << !*QuitBreak := T; Throw('!$Break!$, NIL) >>; lisp procedure BreakContinue(); << ErrorForm!* := MkQuote BreakValue!*; BreakRetry() >>; lisp procedure BreakRetry(); if !*ContinuableError then << !*QuitBreak := NIL; Throw('!$Break!$, NIL) >> else << Prin2T "Can only continue from a continuable error; use Q (BreakQuit) to quit"; TerPri() >>; lisp procedure HelpBreak(); << EvLoad '(HELP); DisplayHelpFile 'Break >>; lisp procedure BreakErrMsg(); PrintF("ErrorForm!* : %r %n", ErrorForm!*); lisp procedure BreakEdit(); if GetD 'Edit then ErrorForm!* := Edit ErrorForm!* else ErrorPrintF("*** Editor not loaded"); LoadTime DefList('((Q BreakQuit) (!? HelpBreak) (A Reset) % Abort to top level (M BreakErrMsg) (E BreakEdit) (C BreakContinue) (R BreakRetry) (I InterpBackTrace) (V VerboseBackTrace) (T BackTrace)), 'BreakFunction); END; |
Added psl-1983/3-1/kernel/carcdr.red version [93d290a6f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CARCDR.RED - Composites of CAR and CDR, up to 4 levels % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>CARCDR.RED.3, 4-Jul-82 13:29:21, Edit by BENSON % CAR and CDR of NIL are legal == NIL CompileTime for each X in '( % remove all compiler optimizations CAAAAR CAAAR CAAR % for CAR and CDR composites CAAADR CAADR CADR CAADAR CADAR CDAR CAADDR CADDR CDDR CADAAR CDAAR CADADR CDADR CADDAR CDDAR CADDDR CDDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR ) do Put(X, 'SaveCMACRO, RemProp(X, 'CMACRO)); lisp procedure CAAAAR U; %. if null U then NIL else if PairP U then CAAAR CAR U else NonPairError(U, 'CAAAAR); lisp procedure CAAADR U; %. if null U then NIL else if PairP U then CAAAR CDR U else NonPairError(U, 'CAAADR); lisp procedure CAADAR U; %. if null U then NIL else if PairP U then CAADR CAR U else NonPairError(U, 'CAADAR); lisp procedure CAADDR U; %. if null U then NIL else if PairP U then CAADR CDR U else NonPairError(U, 'CAADDR); lisp procedure CADAAR U; %. if null U then NIL else if PairP U then CADAR CAR U else NonPairError(U, 'CADAAR); lisp procedure CADADR U; %. if null U then NIL else if PairP U then CADAR CDR U else NonPairError(U, 'CADADR); lisp procedure CADDAR U; %. if null U then NIL else if PairP U then CADDR CAR U else NonPairError(U, 'CADDAR); lisp procedure CADDDR U; %. if null U then NIL else if PairP U then CADDR CDR U else NonPairError(U, 'CADDDR); lisp procedure CDAAAR U; %. if null U then NIL else if PairP U then CDAAR CAR U else NonPairError(U, 'CDAAAR); lisp procedure CDAADR U; %. if null U then NIL else if PairP U then CDAAR CDR U else NonPairError(U, 'CDAADR); lisp procedure CDADAR U; %. if null U then NIL else if PairP U then CDADR CAR U else NonPairError(U, 'CDADAR); lisp procedure CDADDR U; %. if null U then NIL else if PairP U then CDADR CDR U else NonPairError(U, 'CDADDR); lisp procedure CDDAAR U; %. if null U then NIL else if PairP U then CDDAR CAR U else NonPairError(U, 'CDDAAR); lisp procedure CDDADR U; %. if null U then NIL else if PairP U then CDDAR CDR U else NonPairError(U, 'CDDADR); lisp procedure CDDDAR U; %. if null U then NIL else if PairP U then CDDDR CAR U else NonPairError(U, 'CDDDAR); lisp procedure CDDDDR U; %. if null U then NIL else if PairP U then CDDDR CDR U else NonPairError(U, 'CDDDDR); lisp procedure CAAAR U; %. if null U then NIL else if PairP U then CAAR CAR U else NonPairError(U, 'CAAAR); lisp procedure CAADR U; %. if null U then NIL else if PairP U then CAAR CDR U else NonPairError(U, 'CAADR); lisp procedure CADAR U; %. if null U then NIL else if PairP U then CADR CAR U else NonPairError(U, 'CADAR); lisp procedure CADDR U; %. if null U then NIL else if PairP U then CADR CDR U else NonPairError(U, 'CADDR); lisp procedure CDAAR U; %. if null U then NIL else if PairP U then CDAR CAR U else NonPairError(U, 'CDAAR); lisp procedure CDADR U; %. if null U then NIL else if PairP U then CDAR CDR U else NonPairError(U, 'CDADR); lisp procedure CDDAR U; %. if null U then NIL else if PairP U then CDDR CAR U else NonPairError(U, 'CDDAR); lisp procedure CDDDR U; %. if null U then NIL else if PairP U then CDDR CDR U else NonPairError(U, 'CDDDR); lisp procedure SafeCAR U; if null U then NIL else if PairP U then CAR U else NonPairError(U, 'CAR); lisp procedure SafeCDR U; if null U then NIL else if PairP U then CDR U else NonPairError(U, 'CDR); lisp procedure CAAR U; %. if null U then NIL else if PairP U then SafeCAR CAR U else NonPairError(U, 'CAAR); lisp procedure CADR U; %. if null U then NIL else if PairP U then SafeCAR CDR U else NonPairError(U, 'CADR); lisp procedure CDAR U; %. if null U then NIL else if PairP U then SafeCDR CAR U else NonPairError(U, 'CDAR); lisp procedure CDDR U; %. if null U then NIL else if PairP U then SafeCDR CDR U else NonPairError(U, 'CDDR); CompileTime for each X in '( % restore compiler optimizations CAAAAR CAAAR CAAR % for CAR and CDR composites CAAADR CAADR CADR CAADAR CADAR CDAR CAADDR CADDR CDDR CADAAR CDAAR CADADR CDADR CADDAR CDDAR CADDDR CDDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR ) do Put(X, 'CMACRO, RemProp(X, 'SaveCMACRO)); END; |
Added psl-1983/3-1/kernel/catch-throw.red version [779e937baa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CATCH-THROW.RED - Common Lisp dynamic non-local exits % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 October 1982 % Copyright (c) 1982 University of Utah % % 03-Mar-83 Nancy Kendzierski % Changed declaration of EMSG!* from fluid to global. % Edit by Cris Perdue, 23 Feb 1983 1624-PST % Modified the stack overflow warning message % Edit by Cris Perdue, 16 Feb 1983 1032-PST % Changed catch stack overflow checking to give a continuable error % when stack gets low, Reset when all out. % Edit by Cris Perdue, 4 Feb 1983 1209-PST % Moved ERRSET to ERROR-ERRORSET from here. % Edit by Cris Perdue, 3 Feb 1983 1520-PST % Changed catch stack overflow to talk about the CATCH stack. (!) % Deleted definition of "errset". % <PSL.KERNEL>CATCH-THROW.RED.13, 21-Dec-82 15:55:26, Edit by BENSON % Added %clear-catch-stack % <PSL.KERNEL>CATCH-THROW.RED.13, 16-Dec-82 09:58:59, Edit by BENSON % Error not within ErrorSet now causes fatal error, not infinite loop fluid '(ThrowSignal!* ThrowTag!*); global '(EMSG!*); macro procedure catch!-all u; (lambda(fn, forms); list(list('lambda, '(!&!&Value!&!&), list('cond, list('ThrowSignal!*, list('Apply, fn, '(list ThrowTag!* !&!&Value!&!&))), '(t !&!&Value!&!&))), 'catch . nil . forms))(cadr U, cddr U); macro procedure unwind!-all u; (lambda(fn, forms); list(list('lambda, '(!&!&Value!&!&), list('Apply, fn, '(list (and ThrowSignal!* ThrowTag!*) !&!&Value!&!&))), 'catch . nil . forms))(cadr U, cddr U); macro procedure unwind!-protect u; (lambda(protected_form, cleanup_forms); list(list('lambda, '(!&!&Value!&!&), list('lambda, '(!&!&Thrown!&!& !&!&Tag!&!&), 'progn . cleanup_forms, '(cond (!&!&Thrown!&!& (!%Throw !&!&Tag!&!& !&!&Value!&!&)) (t !&!&Value!&!&))) . '(ThrowSignal!* ThrowTag!*)), list('catch, ''!$unwind!-protect!$, protected_form)))(cadr U,cddr U); off R2I; % This funny definition is due to a PA1FN for CATCH fexpr procedure Catch U; (lambda(Tag, Forms); Catch(Eval Tag, EvProgN Forms))(car U, cdr U); on R2I; % Temporary compatibility package. macro procedure !*Catch U; 'Catch . cdr U; expr procedure !*Throw(x,y); throw(x,y); on Syslisp; % Size is in terms of number of frames internal WConst CatchStackSize = 400; internal WArray CatchStack[CatchStackSize*4]; internal WVar CatchStackPtr = &CatchStack[0]; CompileTime << smacro procedure CatchPop(); CatchStackPtr := &CatchStackPtr[-4]; smacro procedure CatchStackDecrement X; &X[-4]; % Rather large for a smacro, used only from CatchSetupAux /csp % Tests structured for fast usual execution /csp % Random constant 5 for "reserve" catch stack frames /csp smacro procedure CatchPush(Tag, PC, SP, Env); << CatchStackPtr := &CatchStackPtr[4]; if CatchStackPtr >= &CatchStack[(CatchStackSize-5)*4] then << if CatchStackPtr = &CatchStack[(CatchStackSize-5)*4] then ContinuableError(99,"Catch-throw stack overflow (warning)", NIL); if CatchStackPtr >= &CatchStack[CatchStackSize*4] then << (LispVar EMSG!*) := "Catch stack overflow"; reset() >> >>; CatchStackPtr[0] := Tag; CatchStackPtr[1] := PC; CatchStackPtr[2] := SP; CatchStackPtr[3] := Env >>; smacro procedure CatchTopTag(); CatchStackPtr[0]; smacro procedure CatchTagAt X; X[0]; smacro procedure CatchTopPC(); CatchStackPtr[1]; smacro procedure CatchTopSP(); CatchStackPtr[2]; smacro procedure CatchTopEnv(); CatchStackPtr[3]; flag('(CatchSetupAux ThrowAux FindCatchMarkAndThrow), 'InternalFunction); >>; % CatchSetup puts the return address in reg 2, the stack pointer in reg 3 % and calls CatchSetupAux lap '((!*entry CatchSetup expr 1) %. CatchSetup(Tag) (!*MOVE (MEMORY (reg st) (WConst 0)) (reg 2)) (!*MOVE (reg st) (reg 3)) (!*JCALL CatchSetupAux) ); syslsp procedure CatchSetupAux(Tag, PC, SP); begin scalar Previous; Previous := CatchStackPtr; CatchPush(Tag, PC, SP, CaptureEnvironment()); LispVar ThrowSignal!* := NIL; return Previous; end; syslsp procedure !%UnCatch Previous; << CatchStackPtr := Previous; LispVar ThrowSignal!* := NIL >>; syslsp procedure !%clear!-catch!-stack(); CatchStackPtr := &CatchStack[0]; syslsp procedure !%Throw(Tag, Value); begin scalar TopTag; TopTag := CatchTopTag(); return if not (null TopTag or TopTag eq '!$unwind!-protect!$ or Tag eq TopTag) then << CatchPop(); !%Throw(Tag, Value) >> else begin scalar PC, SP; PC := CatchTopPC(); SP := CatchTopSP(); RestoreEnvironment CatchTopEnv(); CatchPop(); LispVar ThrowSignal!* := T; LispVar ThrowTag!* := Tag; return ThrowAux(Value, PC, SP); end; end; lap '((!*entry ThrowAux expr 3) (!*MOVE (reg 3) (reg st)) (!*MOVE (reg 2) (MEMORY (reg st) (WConst 0))) (!*EXIT 0) ); syslsp procedure Throw(Tag, Value); FindCatchMarkAndThrow(Tag, Value, CatchStackPtr); % Throw to $Error$ that doesn't have a catch can't cause a normal error % else an infinite loop will result. Changed to use FatalError instead. syslsp procedure FindCatchMarkAndThrow(Tag, Value, P); if P = &CatchStack[0] then if not (Tag eq '!$Error!$) then ContError(99, "Catch tag %r not found in Throw", Tag, Throw(Tag, Value)) else FatalError "Error not within ErrorSet" else if null CatchTagAt P or Tag eq CatchTagAt P then !%Throw(Tag, Value) else FindCatchMarkAndThrow(Tag, Value, CatchStackDecrement P); off Syslisp; END; |
Added psl-1983/3-1/kernel/char-io.red version [037549e210].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR-IO.RED - Bottom level character IO primitives % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1652-PST % ChannelReadChar and ChannelWriteChar now check the FileDes argument % <PERDUE.PSL>CHAR-IO.RED.2, 29-Dec-82 12:21:51, Edit by PERDUE % Added code to ChannelWriteChar to maintain PagePosition for LPOSN global '(IN!* % The current input channel OUT!*); % The current output channel on SysLisp; external WArray ReadFunction, % Indexed by channel # to read char WriteFunction, % Indexed by channel # to write char UnReadBuffer, % For input backup LinePosition, % For Posn() PagePosition; % For LPosn() syslsp procedure ChannelReadChar FileDes; %. Read one char from channel % % All channel input must pass through this function. When a channel is % open, its read function must be set up. % begin scalar Ch, FD; FD := IntInf FileDes; %/ Heuristic: don't do Int type test if not (0 <= FD and FD <= MaxChannels) then NonIOChannelError(FileDes, "ChannelReadChar"); return if (Ch := UnReadBuffer[FD]) neq char NULL then << UnReadBuffer[FD] := char NULL; Ch >> else IDApply1(FD, ReadFunction[FD]); end; syslsp procedure ReadChar(); %. Read single char from current input ChannelReadChar LispVar IN!*; syslsp procedure ChannelWriteChar(FileDes, Ch); %. Write one char to channel % % All channel output must pass through this function. When a channel is % open, its write function must be set up, and line position set to zero. % begin scalar FD; FD := IntInf FileDes; if not (0 <= FD and FD <= MaxChannels) then NonIOChannelError(FileDes, "ChannelWriteChar"); if Ch eq char EOL then << LinePosition[FD] := 0; PagePosition[FD] := PagePosition[FD] + 1 >> else if Ch eq char TAB then % LPos := (LPos + 8) - ((LPos + 8) MOD 8) LinePosition[FD] := LAND(LinePosition[FD] + 8, LNOT 7) else if Ch eq char FF then << PagePosition[FD] := 0; LinePosition[FD] := 0 >> else LinePosition[FD] := LinePosition[FD] + 1; IDApply2(FD, Ch, WriteFunction[FD]); end; syslsp procedure WriteChar Ch; %. Write single char to current output ChannelWriteChar(LispVar OUT!*, Ch); syslsp procedure ChannelUnReadChar(Channel, Ch); %. Input backup function % % Any channel input backup must pass through this function. The following % restrictions are made on input backup: % 1. Backing up without first doing input should cause an error, but % will probably cause unpredictable results. % 2. Only one character backup is supported. % UnReadBuffer[IntInf Channel] := Ch; syslsp procedure UnReadChar Ch; %. Backup on current input channel ChannelUnReadChar(LispVar IN!*, Ch); off SysLisp; END; |
Added psl-1983/3-1/kernel/char-macro.sl version [419cbb3834].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR-MACRO.SL - Character constant macro % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 1 Feb 1983 1355-PST % pk:char.red merged with the version in USEFUL. Some symbolic names % for characters removed (not needed, I hope). (dm Char (U) %. Character constant macro (DoChar (cadr U))) % Table driven char macro expander (de DoChar (u) (cond ((idp u) (or (get u 'CharConst) ((lambda (n) (cond ((lessp n 128) n))) (id2int u)) (CharError u))) ((pairp u) % Here's the real change -- let users add "functions" ((lambda (fn) (cond (fn (apply fn (list (dochar (cadr u))))) (t (CharError u)))) (cond ((idp (car u)) (get (car u) 'char-prefix-function))))) ((and (fixp u) (geq u 0) (leq u 9)) (plus u (char 0))) (t (CharError u)))) (deflist (list (list 'lower (function (lambda(x) (lor x 2#100000)))) (list 'quote (function (lambda(x) x))) (list 'control (function (lambda(x) (land x 2#11111)))) (list 'cntrl (function (lambda(x) (land x 2#11111)))) (list 'meta (function (lambda(x) (lor x 2#10000000))))) 'char-prefix-function) (de CharError (u) (ErrorPrintF "*** Unknown character constant: %r" u) 0) (DefList '((NULL 0) (BELL 7) (BACKSPACE 8) (TAB 8#11) (LF 8#12) % (RETURN 8#12) % RETURN is LF: it's end-of-line. Out! /csp (EOL 8#12) (FF 8#14) (CR 8#15) (ESC 27) (ESCAPE 27) (BLANK 32) (SPACE 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177) ) 'CharConst) |
Added psl-1983/3-1/kernel/comp-support.red version [20da01e823].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMP-SUPPORT.RED - Run-time support for optimized Cons and List compilation % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 September 1981 % Copyright (c) 1981 University of Utah % CommentOutCode << % defined in CONS-MKVECT.RED CompileTime(SavedCompFn := RemProp('Cons, 'CompFn)); % else can't compile lisp procedure NCons U; %. U . NIL, or 1-argument EXPR for LIST U . NIL; lisp procedure XCons(U, V); %. V . U V . U; CompileTime put('Cons, 'CompFn, SavedCompFn); >>; lisp procedure List5(U, V, W, X, Y); %. 5-argument EXPR for LIST U . List4(V, W, X, Y); lisp procedure List4(U, V, W, X); %. 4-argument EXPR for LIST U . List3(V, W, X); lisp procedure List3(U, V, W); %. 3-argument EXPR for LIST U . List2(V, W); lisp procedure List2(U, V); %. 2-argument EXPR for LIST U . NCons V; END; |
Added psl-1983/3-1/kernel/compacting-gc.red version [d363a9a9cf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GC.RED - Compacting garbage collector for PSL % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % WARNING! This file has not been parameterized using % AddressingUnitsPerItem. It will not work on machines that % address bytes. /csp 3-1-83 % All data types have either explicit header tag in first item, % or are assumed to be 1st element of pair. % Revision History: % Edit by Cris Perdue, 16 Feb 1983 1407-PST % Fixed GtHeap and collector(s) to use only HeapLast, not HeapPreviousLast % Sets HeapTrapped to NIL now. % Using known-free-space function % Added check of Heap-Warn-Level after %Reclaim % Defined and used known-free-space function % <PSL.KERNEL>COMPACTING-GC.RED.9, 4-Oct-82 17:59:55, Edit by BENSON % Added GCTime!* % <PSL.KERNEL>COMPACTING-GC.RED.3, 21-Sep-82 10:43:21, Edit by BENSON % Flagged most functions internal % (M.L. Griss, March, 1977). % (Update to speed up, July 1978) % Converted to Syslisp July 1980 % En-STRUCT-ed, Eric Benson April 1981 % Added EVECT tag, M. Griss, 3 July 1982 fluid '(!*GC % Controls printing of statistics GCTime!* % Total amount of time spent in GC GCKnt!* % count of # of GC's since system build heap!-warn!-level); % Continuable error if this much not % free after %Reclaim. LoadTime << !*GC := T; % Do print GC messages (SL Rep says no) GCTime!* := 0; GCKnt!* := 0; % Initialize to zero Heap!-Warn!-Level := 1000; >>; on Syslisp; % Predicates for whether to follow pointers external WVar HeapLowerBound, % Bottom of heap HeapUpperBound, % Top of heap HeapLast, % Last item allocated HeapTrapped; % Boolean: has trap occurred since GC? CompileTime << flag('(MarkFromAllBases BuildRelocationFields UpdateAllBases CompactHeap MarkFromOneSymbol MakeIDFreeList GCMessage MarkFromSymbols MarkFromRange MarkFromBase MarkFromVector GCError UpdateSymbols UpdateRegion UpdateItem UpdateHeap), 'InternalFunction); syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinHeapPointer X; X >= HeapLowerBound and X <= HeapLast; >>; % Marking primitives internal WConst GCMarkValue = 8#777, HSkip = Forward; CompileTime << syslsp smacro procedure Mark X; % Get GC mark bits in item X points to GCField @X; syslsp smacro procedure SetMark X; % Set GC mark bits in item X points to GCField @X := GCMarkValue; syslsp smacro procedure ClearMark X; % Clear GC mark bits in item X points to GCField @X := if NegIntP @X then -1 else 0; syslsp smacro procedure Marked X; % Is item pointed to by X marked? Mark X eq GCMarkValue; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; % Relocation primitives syslsp smacro procedure SkipLength X; % Stored in heap header Inf @X; syslsp smacro procedure PutSkipLength(X, L); % Store in heap header Inf @X := L; put('SkipLength, 'Assign!-Op, 'PutSkipLength); >>; internal WConst BitsInSegment = 13, SegmentLength = LShift(1, BitsInSegment), SegmentMask = SegmentLength - 1; internal WConst GCArraySize = LShift(HeapSize, -BitsInSegment) + 1; internal WArray GCArray[GCArraySize]; CompileTime << syslsp smacro procedure SegmentNumber X; % Get segment part of pointer LShift(X - HeapLowerBound, -BitsInSegment); syslsp smacro procedure OffsetInSegment X; % Get offset part of pointer LAnd(X - HeapLowerBound, SegmentMask); syslsp smacro procedure MovementWithinSegment X; % Reloc field in item GCField @X; syslsp smacro procedure PutMovementWithinSegment(X, M); % Store reloc field GCField @X := M; syslsp smacro procedure ClearMovementWithinSegment X; % Clear reloc field GCField @X := if NegIntP @X then -1 else 0; put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment); syslsp smacro procedure SegmentMovement X; % Segment table GCArray[X]; syslsp smacro procedure PutSegmentMovement(X, M); % Store in seg table GCArray[X] := M; put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement); syslsp smacro procedure Reloc X; % Compute pointer adjustment X - (SegmentMovement SegmentNumber X + MovementWithinSegment X); >>; external WVar ST, % stack pointer StackLowerBound; % bottom of stack % Base registers marked from by collector % SymNam, SymPrp and SymVal are declared for all external WVar NextSymbol; % next ID number to be allocated external WVar BndStkLowerBound, % Bottom of binding stack BndStkPtr; % Binding stack pointer internal WVar StackEnd, % Holds address of bottom of stack StackStart, % Holds address of top of stack MarkTag, % Used by MarkFromBase only Hole, % First location moved in heap HeapShrink, % Total amount reclaimed StartingRealTime; syslsp procedure Reclaim(); %. User call to garbage collector << !%Reclaim(); NIL >>; syslsp procedure !%Reclaim(); % Garbage collector << StackEnd := MakeAddressFromStackPointer ST - FrameSize(); StackStart := StackLowerBound; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; StartingRealTime := TimC(); LispVar GCKnt!* := LispVar GCKnt!* + 1; % must be INUM > 0, so needn't chk MarkFromAllBases(); MakeIDFreeList(); BuildRelocationFields(); UpdateAllBases(); CompactHeap(); HeapLast := HeapLast - HeapShrink; StartingRealTime := TimC() - StartingRealTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, StartingRealTime); if LispVar !*GC then GCMessage(); HeapTrapped := NIL; if IntInf known!-free!-space() < IntInf (LispVar Heap!-Warn!-Level) then ContinuableError(99, "Heap space low", NIL); >>; syslsp procedure MarkFromAllBases(); begin scalar B; MarkFromSymbols(); MarkFromRange(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do MarkFromBase @B; end; syslsp procedure MarkFromSymbols(); begin scalar B; MarkFromOneSymbol 128; % mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkFromOneSymbol I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkFromOneSymbol B >>; end; syslsp procedure MarkFromOneSymbol X; % SymNam has to be marked from before marking ID, since the mark uses its tag % No problem since it's only a string, can't reference itself. << MarkFromBase SymNam X; MarkID X; MarkFromBase SymPrp X; MarkFromBase SymVal X >>; syslsp procedure MarkFromRange(Low, High); for Ptr := Low step 1 until High do MarkFromBase @Ptr; syslsp procedure MarkFromBase Base; begin scalar MarkInfo; MarkTag := Tag Base; if not PointerTagP MarkTag then return << if MarkTag = ID and not null Base then << MarkInfo := IDInf Base; if not MarkedID MarkInfo then MarkFromOneSymbol MarkInfo >> >>; MarkInfo := Inf Base; if not WithinHeapPointer MarkInfo or Marked MarkInfo then return; SetMark MarkInfo; CommentOutCode CheckAndSetMark MarkInfo; return if MarkTag eq VECT or MarkTag eq EVECT then MarkFromVector MarkInfo else if MarkTag eq PAIR then << MarkFromBase car Base; MarkFromBase cdr Base >>; end; CommentOutCode << syslsp procedure CheckAndSetMark P; begin scalar HeadAtP; HeadAtP := Tag @P; case MarkTag of STR: if HeadAtP eq HBYTES then SetMark P; FIXN, FLTN, BIGN, WRDS: if HeadAtP eq HWRDS then SetMark P; VECT, EVECT: if HeadAtP eq HVECT then SetMark P; PAIR: SetMark P; default: GCError("Internal error in marking phase, at %o", P) end; end; >>; syslsp procedure MarkFromVector Info; begin scalar Uplim; CommentOutCode if Tag @Info neq HVECT then return; Uplim := &VecItm(Info, VecLen Info); for Ptr := &VecItm(Info, 0) step 1 until Uplim do MarkFromBase @Ptr; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure BuildRelocationFields(); % % Pass 2 - Turn off GC marks and Build SEGKNTs % begin scalar CurrentItem, SGCurrent, IGCurrent, TmpIG, DCount, SegLen; SGCurrent := IGCurrent := 0; SegmentMovement SGCurrent := 0; % Dummy Hole := HeapLowerBound - 1; % will be first hole DCount := HeapShrink := 0; % holes in current segment, total holes CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin scalar Incr; SegLen := case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: 2; % must be first of pair HBYTES: 1 + StrPack StrLen CurrentItem; HHalfwords: 1 + HalfWordPack StrLen CurrentItem; HWRDS: 1 + WrdPack WrdLen CurrentItem; HVECT: 1 + VectPack VecLen CurrentItem; HSKIP: SkipLength CurrentItem; default: GCError("Illegal item in heap at %o", CurrentItem) end; % case if Marked CurrentItem then % a hole if HeapShrink = 0 then ClearMark CurrentItem else % segment also clears mark << MovementWithinSegment CurrentItem := DCount; % incremental shift Incr := 0 >> % no shift else << @CurrentItem := MkItem(HSKIP, SegLen); % a skip mark Incr := 1; % more shift if Hole < HeapLowerBound then Hole := CurrentItem >>; TmpIG := IGCurrent + SegLen; % set SEG size CurrentItem := CurrentItem + SegLen; while TmpIG >= SegmentLength do begin scalar Tmp; Tmp := SegmentLength - IGCurrent; % Expand to next SEGMENT SegLen := SegLen - Tmp; if Incr eq 1 then HeapShrink := HeapShrink + Tmp; DCount := IGCurrent := 0; SGCurrent := SGCurrent + 1; SegmentMovement SGCurrent := HeapShrink; % Store Next Base TmpIG := TmpIG - SegmentLength; end; IGCurrent := TmpIG; if Incr eq 1 then << HeapShrink := HeapShrink + SegLen; DCount := DCount + SegLen >>; % Add in Hole Size end; SegmentMovement(SGCurrent + 1) := HeapShrink; end; syslsp procedure UpdateAllBases(); begin scalar B; UpdateSymbols(); UpdateRegion(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do UpdateItem B; UpdateHeap() >>; syslsp procedure UpdateSymbols(); for I := 0 step 1 until MaxSymbols do begin scalar NameLoc; NameLoc := &SymNam I; if StringP @NameLoc then << UpdateItem NameLoc; UpdateItem &SymVal I; UpdateItem &SymPrp I >>; end; syslsp procedure UpdateRegion(Low, High); for Ptr := Low step 1 until High do UpdateItem Ptr; syslsp procedure UpdateHeap(); begin scalar CurrentItem; CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND: CurrentItem := CurrentItem + 1; STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: << if Inf @CurrentItem >= Hole and Inf @CurrentItem <= HeapLast then Inf @CurrentItem := Reloc Inf @CurrentItem; CurrentItem := CurrentItem + 1 >>; HBYTES: CurrentItem := CurrentItem + 1 + StrPack StrLen CurrentItem; HHalfwords: CurrentItem := CurrentItem + 1 + HalfwordPack StrLen CurrentItem; HWRDS: CurrentItem := CurrentItem + 1 + WrdPack WrdLen CurrentItem; HVECT: begin scalar Tmp; Tmp := VecLen CurrentItem; CurrentItem := CurrentItem + 1; % Move over header for I := 0 step 1 until Tmp do % VecLen + 1 items begin scalar Tmp2, Tmp3; Tmp2 := @CurrentItem; Tmp3 := Tag Tmp2; if PointerTagP Tmp3 and Inf Tmp2 >= Hole and Inf Tmp2 <= HeapLast then Inf @CurrentItem := Reloc Inf Tmp2; CurrentItem := CurrentItem + 1; end; end; HSKIP: CurrentItem := CurrentItem + SkipLength CurrentItem; default: GCError("Internal error in updating phase at %o", CurrentItem) end; % case end end; syslsp procedure UpdateItem Ptr; begin scalar Tg, Info; Tg := Tag @Ptr; if not PointerTagP Tg then return; Info := INF @Ptr; if Info < Hole or Info > HeapLast then return; Inf @Ptr := Reloc Info; end; syslsp procedure CompactHeap(); begin scalar OldItemPtr, NewItemPtr, SegLen; if Hole < HeapLowerBound then return; NewItemPtr := OldItemPtr := Hole; while OldItemPtr < HeapLast do begin; case Tag @OldItemPtr of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: SegLen := PairPack OldItemPtr; HBYTES: SegLen := 1 + StrPack StrLen OldItemPtr; HHalfwords: SegLen := 1 + HalfWordPack HalfwordLen OldItemPtr; HWRDS: SegLen := 1 + WrdPack WrdLen OldItemPtr; HVECT: SegLen := 1 + VectPack VecLen OldItemPtr; HSKIP: << OldItemPtr := OldItemPtr + SkipLength OldItemPtr; goto WhileNext >>; default: GCError("Internal error in compaction at %o", OldItemPtr) end; % case ClearMovementWithinSegment OldItemPtr; for I := 1 step 1 until SegLen do << @NewItemPtr := @OldItemPtr; NewItemPtr := NewItemPtr + 1; OldItemPtr := OldItemPtr + 1 >>; WhileNext: end; end; syslsp procedure GCError(Message, P); << ErrorPrintF("***** Fatal error during garbage collection"); ErrorPrintF(Message, P); while T do Quit; >>; syslsp procedure GCMessage(); << ErrorPrintF("*** GC %w: time %d ms", LispVar GCKnt!*, StartingRealTime); ErrorPrintF("*** %d recovered, %d stable, %d active, %d free", HeapShrink, Hole - HeapLowerBound, HeapLast - Hole, intinf known!-free!-space() ) >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/cons-mkvect.red version [827e9e3c6e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CONS-MKVECT.RED - Standard Lisp constructor functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>CONS-MKVECT.RED.4, 28-Feb-83 11:41:46, Edit by PERDUE % Moved Make-Words, Make-Halfwords, etc. here from SEQUENCE.RED % Also moved STRING and VECTOR here from there. % Edit by Cris Perdue, 23 Feb 1983 1045-PST % Changed occurrences of HeapUpperbound to HeapTrapBound in optimized % allocators to supported pre-GC traps. % <PSL.KERNEL>CONS-MKVECT.RED.2, 10-Jan-83 15:50:08, Edit by PERDUE % Added MkEVect % Edit by GRISS: (?) % Optimized CONS, XCONS and NCONS % <PSL.INTERP>CONS-MKVECT.RED.5, 9-Feb-82 06:25:51, Edit by GRISS % Added HardCons CompileTime flag('(HardCons), 'InternalFunction); on SysLisp; external WVar HeapLast, HeapTrapBound; syslsp procedure HardCons(U, V); % Basic CONS with car U and cdr V begin scalar P; HeapLast := HeapLast - AddressingUnitsPerItem*PairPack(); P := GtHeap PairPack(); P[0] := U; P[1] := V; return MkPAIR P; end; syslsp procedure Cons(U, V); %. Construct pair with car U and cdr V begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(U, V) else << HP[0] := U; HP[1] := V; MkPAIR HP >> >>; end; syslsp procedure XCons(U, V); %. eXchanged Cons begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(V, U) else << HP[0] := V; HP[1] := U; MkPAIR HP >> >>; end; syslsp procedure NCons U; %. U . NIL begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(U, NIL) else << HP[0] := U; HP[1] := NIL; MkPAIR HP >> >>; end; syslsp procedure MkVect N; %. Allocate vector, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"A vector with fewer than zero elements cannot be allocated" else begin scalar V; V := GtVect N; for I := 0 step 1 until N do VecItm(V, I) := NIL; return MkVEC V; % Tag it end >> else NonIntegerError(N, 'MkVect); syslsp procedure MkEVECTOR(N,ETAG); %. Allocate Evect, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"An Evect with fewer than zero elements cannot be allocated" else begin scalar V; V := GtEVect N; EVecItm(V,0):=ETAG; for I := 1 step 1 until N do VecItm(V, I) := NIL; return MkEVECT V; % Tag it end >> else NonIntegerError(N, 'MkEVECT); syslsp procedure MkString(L, C); %. Make str with upb L, all chars C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'MkString); if L1 < -1 then return NonPositiveIntegerError(L, 'MkString); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkSTR S; end; syslsp procedure Make!-Bytes(L, C); %. Make byte vector with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Bytes); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Bytes); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkBytes S; end; syslsp procedure Make!-HalfWords(L, C); %. Make h vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-HalfWords); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-HalfWords); S := GtHalfWords L1; for I := 0 step 1 until L1 do HalfWordItm(S, I) := C; return MkHalfWords S; end; syslsp procedure Make!-Words(L, C); %. Make w vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Words); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Words); S := GtWrds L1; for I := 0 step 1 until L1 do WrdItm(S, I) := C; return MkWrds S; end; syslsp procedure Make!-Vector(L, C); %. Make vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Vector); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Vector); S := GtVECT L1; for I := 0 step 1 until L1 do VecItm(S, I) := C; return MkVEC S; end; % Maybe we want to support efficient compilation of these, as with LIST, % by functions String2, String3, Vector2, Vector3, etc. nexpr procedure String U; %. Analogous to LIST, string constructor List2String U; nexpr procedure Vector U; %. Analogous to LIST, vector constructor List2Vector U; off SysLisp; END; |
Added psl-1983/3-1/kernel/cont-error.red version [caba0b1554].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CONT-ERROR.RED - Nice macro to set up arguments for ContinuableError % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>CONT-ERROR.RED.3, 2-Sep-82 09:10:04, Edit by BENSON % Made handling of ReEvalForm more robust % format is: % ContError(ErrorNumber, FormatString, {arguments to PrintF}, ReEvalForm) % ReEvalForm is something like % Foo(X, Y) % which becomes % list('Foo, MkQuote X, MkQuote Y) macro procedure ContError U; %. Set up for ContinuableError begin scalar ErrorNumber, Message, ReEvalForm; U := cdr U; ErrorNumber := car U; U := cdr U; if null cddr U then % if it's just a string, don't << Message := car U; % generate call to BldMsg U := cdr U >> else << while cdr U do << Message := AConc(Message, car U); U := cdr U >>; Message := 'BldMsg . Message >>; ReEvalForm := car U; ReEvalForm := if not PairP ReEvalForm then list('MkQuote, ReEvalForm) else 'list . MkQuote car ReEvalForm . for each X in cdr ReEvalForm collect list('MkQuote, X); return list('ContinuableError, ErrorNumber, Message, ReEvalForm); end; END; |
Added psl-1983/3-1/kernel/copiers.red version [fb1c324373].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % COPIERS.RED - Functions for copying various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>COPIERS.RED.2, 28-Sep-82 10:21:15, Edit by PERDUE % Made CopyStringToFrom safe and to not bother clearing the % terminating byte. on SysLisp; syslsp procedure CopyStringToFrom(New, Old); %. Copy all chars in Old to New begin scalar SLen, StripNew, StripOld; StripNew := StrInf New; StripOld := StrInf Old; SLen := StrLen StripOld; if StrLen StripNew < SLen then SLen := StrLen StripNew; for I := 0 step 1 until SLen do StrByt(StripNew, I) := StrByt(StripOld, I); return New; end; syslsp procedure CopyString S; %. copy to new heap string begin scalar S1; S1 := GtSTR StrLen StrInf S; CopyStringToFrom(S1, StrInf S); return MkSTR S1; end; syslsp procedure CopyWArray(New, Old, UpLim); %. copy UpLim + 1 words << for I := 0 step 1 until UpLim do New[I] := Old[I]; New >>; syslsp procedure CopyVectorToFrom(New, Old); %. Move elements, don't recurse begin scalar SLen, StripNew, StripOld; StripNew := VecInf New; StripOld := VecInf Old; SLen := VecLen StripOld; % assumes VecLen New has been set for I := 0 step 1 until SLen do VecItm(StripNew, I) := VecItm(StripOld, I); return New; end; syslsp procedure CopyVector S; %. Copy to new vector in heap begin scalar S1; S1 := GtVECT VecLen VecInf S; CopyVectorToFrom(S1, VecInf S); return MkVEC S1; end; syslsp procedure CopyWRDSToFrom(New, Old); %. Like CopyWArray in heap begin scalar SLen, StripNew, StripOld; StripNew := WrdInf New; StripOld := WrdInf Old; SLen := WrdLen StripOld; % assumes WrdLen New has been set for I := 0 step 1 until SLen do WrdItm(StripNew, I) := WrdItm(StripOld, I); return New; end; syslsp procedure CopyWRDS S; %. Allocate new WRDS array in heap begin scalar S1; S1 := GtWRDS WrdLen WrdInf S; CopyWRDSToFrom(S1, WrdInf S); return MkWRDS S1; end; % CopyPairToFrom is RplacW, found in EASY-NON-SL.RED % CopyPair is: car S . cdr S; % Usual Lisp definition of Copy only copies pairs, is found in EASY-NON-SL.RED syslsp procedure TotalCopy S; %. Unique copy of entire structure begin scalar Len, Ptr, StripS; % blows up on circular structures return case Tag S of PAIR: TotalCopy car S . TotalCopy cdr S; STR: CopyString S; VECT: << StripS := VecInf S; Len := VecLen StripS; Ptr := MkVEC GtVECT Len; for I := 0 step 1 until Len do VecItm(VecInf Ptr, I) := TotalCopy VecItm(VecInf S, I); Ptr >>; WRDS: CopyWRDS S; FIXN: MkFIXN Inf CopyWRDS S; FLTN: MkFLTN Inf CopyWRDS S; default: S end; end; off SysLisp; END; |
Added psl-1983/3-1/kernel/copying-gc.red version [6e45f5944d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GC.RED - Copying 2-space garbage collector for PSL % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 30 November 1981 % Copyright (c) 1981 Eric Benson % % <PSL.KERNEL>COPYING-GC.RED.2, 23-Mar-83 11:35:37, Edit by KESSLER % Add HeadTrapBound Guys, so we can update the heap trap bound upon switch % Edit by Cris Perdue, 15 Mar 1983 0937-PST % Added missing comma as noted by Kessler. % Edit by Cris Perdue, 16 Feb 1983 1409-PST % Removed external declaration of HeapPreviousLast (the only occurrence) % Now using "known-free-space" function and heap-warn-level % Sets HeapTrapped to NIL now. % Added check of Heap!-Warn!-Level after %Reclaim. % <PSL.KERNEL>COPYING-GC.RED.6, 4-Oct-82 17:56:49, Edit by BENSON % Added GCTime!* fluid '(!*GC GCKnt!* GCTime!* Heap!-Warn!-Level); LoadTime << GCKnt!* := 0; GCTime!* := 0; !*GC := T; LispVar Heap!-Warn!-Level := 1000 >>; on SysLisp; CompileTime << syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinOldHeapPointer X; X >= !%chipmunk!-kludge OldHeapLowerBound and X <= !%chipmunk!-kludge OldHeapLast; syslsp smacro procedure Mark X; MkItem(Forward, X); syslsp smacro procedure Marked X; Tag X eq Forward; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; flag('(CopyFromAllBases CopyFromRange CopyFromBase CopyItem CopyItem1 MarkAndCopyFromID MakeIDFreeList GCStats), 'InternalFunction); >>; external WVar ST, StackLowerBound, BndStkLowerBound, BndStkPtr, HeapLast, HeapLowerBound, HeapUpperBound, OldHeapLast, OldHeapLowerBound, OldHeapUpperBound, HeapTrapBound, OldHeapTrapBound, HeapTrapped; internal WVar StackLast, OldTime, OldSize; syslsp procedure Reclaim(); !%Reclaim(); syslsp procedure !%Reclaim(); begin scalar Tmp1, Tmp2; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; BeforeGCSystemHook(); StackLast := MakeAddressFromStackPointer AdjustStackPointer(ST, -FrameSize()); OldTime := TimC(); OldSize := HeapLast - HeapLowerBound; LispVar GCKnt!* := LispVar GCKnt!* + 1; OldHeapLast := HeapLast; HeapLast := OldHeapLowerBound; Tmp1 := HeapLowerBound; Tmp2 := HeapUpperBound; HeapLowerBound := OldHeapLowerBound; HeapUpperBound := OldHeapUpperBound; OldHeapLowerBound := Tmp1; OldHeapUpperBound := Tmp2; Tmp1 := HeapTrapBound; HeapTrapBound := OldHeapTrapBound; OldHeapTrapBound := Tmp1; CopyFromAllBases(); MakeIDFreeList(); AfterGCSystemHook(); OldTime := TimC() - OldTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, OldTime); if LispVar !*GC then GCStats(); HeapTrapped := NIL; if IntInf Known!-Free!-Space() < IntInf (LispVar Heap!-Warning!-Level) then ContinuableError(99, "Heap space low", NIL) >>; syslsp procedure MarkAndCopyFromID X; % SymNam has to be copied before marking, since the mark destroys the tag % No problem since it's only a string, can't reference itself. << CopyFromBase &SymNam X; MarkID X; CopyFromBase &SymPrp X; CopyFromBase &SymVal X >>; syslsp procedure CopyFromAllBases(); begin scalar LastSymbol, B; MarkAndCopyFromID 128; % Mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkAndCopyFromID I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkAndCopyFromID B >>; B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do CopyFromBase B; for I := StackLowerBound step StackDirection*AddressingUnitsPerItem until StackLast do CopyFromBase I; end; syslsp procedure CopyFromRange(Lo, Hi); begin scalar X, I; X := Lo; I := 0; while X <= Hi do << CopyFromBase X; I := I + 1; X := &Lo[I] >>; end; syslsp procedure CopyFromBase P; @P := CopyItem @P; syslsp procedure CopyItem X; begin scalar Typ, Info, Hdr; Typ := Tag X; if not PointerTagP Typ then return << if Typ = ID and not null X then % don't follow NIL, for speed << Info := IDInf X; if not MarkedID Info then MarkAndCopyFromID Info >>; X >>; Info := Inf X; if not WithinOldHeapPointer Info then return X; Hdr := @Info; if Marked Hdr then return MkItem(Typ, Inf Hdr); return CopyItem1 X; end; syslsp procedure CopyItem1 S; % Copier for GC begin scalar NewS, Len, Ptr, StripS; return case Tag S of PAIR: << Ptr := car S; Rplaca(S, Mark(NewS := GtHeap PairPack())); NewS[1] := CopyItem cdr S; NewS[0] := CopyItem Ptr; MkPAIR NewS >>; STR: << @StrInf S := Mark(NewS := CopyString S); NewS >>; VECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := CopyItem VecItm(StripS, I); MkVEC Ptr >>; EVECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := CopyItem VecItm(StripS, I); MkItem(EVECT, Ptr) >>; WRDS, FIXN, FLTN, BIGN: << Ptr := Tag S; @Inf S := Mark(NewS := CopyWRDS S); MkItem(Ptr, NewS) >>; default: FatalError "Unexpected tag found during garbage collection"; end; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure GCStats(); << ErrorPrintF("*** GC %w: time %d ms, %d recovered, %d free", LispVar GCKnt!*, OldTime, (OldSize - (HeapLast - HeapLowerBound))/AddressingUnitsPerItem, Known!-Free!-Space() ) >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/debg.build version [4cd902bb16].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % DEBG.BUILD - Minor debugging tools in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "mini-trace.red"$ % simple function tracing PathIn "mini-editor.red"$ PathIn "backtrace.red"$ % Stack backtrace |
Added psl-1983/3-1/kernel/defconst.red version [734ec979d0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFCONST.RED - Definition and use of symbolic constants % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 January 1982 % Copyright (c) 1982 University of Utah % % DefConst is used to define a value for a name, to be used in const(Name) macro procedure DefConst Form; %. DefConst(Name, Value, ...); begin scalar ResultForm; ResultForm := list 'ProgN; Form := cdr Form; while not null Form do << ResultForm := list('EvDefConst, MkQuote car Form, MkQuote cadr Form) . ResultForm; Form := cddr Form >>; return ReversIP ResultForm; end; flag('(DefConst), 'Eval); lisp procedure EvDefConst(ConstName, ConstValue); put(ConstName, 'Const, ConstValue); macro procedure Const Form; get(cadr Form, 'Const) or StdError BldMsg("Unknown const form %r", Form); END; |
Added psl-1983/3-1/kernel/define-smacro.red version [a27a0b7bdc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFINE-SMACRO.RED - Convert SMacros to Lisp macros % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>DEFINE-SMACRO.RED.3, 21-Sep-82 10:48:10, Edit by BENSON % Flagged internal functions % The functions SafeCDR and StdError are required for run-time support % of the code generated by DS CompileTime flag('(InstantiateInForm MakeDS SetMacroReference), 'InternalFunction); lisp procedure InstantiateInForm(Formals, Form); if Atom Form then if Form memq Formals then Form else MkQuote Form else 'List . for each X in Form collect InstantiateInForm(Formals, X); lisp procedure SetMacroReference U; list('SetQ, U, '(car !#Arg)); macro procedure DS Form; %. Define Smacro % % DS(FNAME:id, PARAMS:id-list, FN:any):id % --------------------------------------- % Type: MACRO % A convenient syntax for a simple macro definition, known as an SMACRO. % The syntax of DS is similar to DE, except that a MACRO is defined instead % of an EXPR, e.g. % (DS FOO (A B) (BAR A B)) % is equivalent to: % (DM FOO (U) (LIST 'BAR (CADR U) (CADDR U))). % The "implicit ProgN" is allowed when using Lisp syntax. DS is invoked % with Rlisp syntax as the procedure type SMACRO, e.g. % SMACRO PROCEDURE FOO(A, B); BAR(A, B); % produces the above Lisp form. % MakeDS(cadr Form, caddr Form, cdddr Form); lisp procedure MakeDS(MacroName, Formals, Form); begin scalar NewForm, I; NewForm := list 'PROG; NewForm := Formals . NewForm; for each X in Formals do << NewForm := '(SetQ !#Arg (SafeCDR !#Arg)) . NewForm; NewForm := SetMacroReference X . NewForm >>; NewForm := '(cond ((PairP (cdr !#Arg)) (StdError "Argument mismatch in SMacro expansion"))) . NewForm; NewForm := list('Return, if null cdr Form then InstantiateInForm(Formals, car Form) else 'list . '(quote ProgN) . for each X in Form collect InstantiateInForm(Formals, X)) . NewForm; return 'dm . MacroName . '(!#Arg) . list ReversIP NewForm; end; %lisp procedure PutC(Name, Type, Body); % if Type eq 'SMACRO then Eval MakeDS(Name, cadr Body, cddr Body) % else % << put(Name, Type, Body); % Name >>; END; |
Added psl-1983/3-1/kernel/dskin.red version [2c7d1c7fc8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DSKIN.RED - Read/Eval/Print from files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>DSKIN.RED.2, 5-Oct-82 11:32:28, Edit by BENSON % Changed DSKIN from FEXPR to 1 argument EXPR % <PSL.INTERP>DSKIN.RED.11, 7-May-82 06:14:27, Edit by GRISS % Added XPRINT in loop to handle levels of output % <PSL.INTERP>DSKIN.RED.6, 30-Apr-82 12:49:59, Edit by BENSON % Made !*DEFN call DfPrint instead of own processing % <PSL.INTERP>DSKIN.RED.3, 29-Apr-82 04:23:49, Edit by GRISS % Added !*DEFN flag, cf TOPLOOP CompileTime << flag('(DskInDefnPrint), 'InternalFunction); >>; expr procedure DskIN F; %. Read a file (dskin "file") % % This is reasonably standard Standard Lisp, except for file name format % knowledge. % begin scalar OldIN, NewIN, TestOpen, Exp; TestOpen := ErrorSet(list('OPEN, F, '(QUOTE INPUT)), NIL, NIL); if not PairP TestOpen then return ContError(99, "Couldn't open file `%w'", F, DskIN F); NewIN := car TestOpen; OldIN := RDS NewIN; while PairP(Exp := ErrorSet(quote Read(), T, !*Backtrace)) and not (car Exp eq !$EOF!$) and PairP(Exp := ErrorSet(list('DskInEval, MkQuote car Exp), T, !*Backtrace)) do if not !*Defn then PrintF("%f%p%n", car Exp); %/ no error protection for printing, maybe should be RDS OldIN; Close NewIN; end; lisp procedure DskInEval U; if not !*DEFN then Eval U else DskInDefnPrint U; lisp procedure DskInDefnPrint U; % handle case of !*Defn:=T % % Looks for special action on a form, otherwise prettyprints it; % Adapted from DFPRINT % if PairP U and FlagP(car U,'Ignore) then Eval U else % So 'IGNORE is EVALED, not output << if DfPrint!* then Apply(DfPrint!*, list U) else PrettyPrint U; % So 'EVAL gets EVALED and Output if PairP U and FlagP(Car U,'EVAL) then Eval U >>; flag('(DskIn), 'IGNORE); fluid '(!*RedefMSG !*Echo); SYMBOLIC PROCEDURE LAPIN FIL; BEGIN SCALAR OLDIN, EXP, !*REDEFMSG, !*ECHO; OLDIN := RDS OPEN(FIL,'INPUT); WHILE (EXP := READ()) NEQ !$EOF!$ DO EVAL EXP; CLOSE RDS OLDIN; END; END; |
Added psl-1983/3-1/kernel/easy-non-sl.red version [2dab558d2c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EASY-NON-SL.RED - Commonly used Non-Standard Lisp functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EASY-NON-SL.RED.2, 17-Sep-82 16:10:18, Edit by BENSON % Added ChannelPrin2T, ChannelSpaces, ChannelTab, ChannelSpaces2 % <PSL.INTERP>EASY-NON-SL.RED.7, 9-Jul-82 12:46:43, Edit by BENSON % Changed NTH to improve error reporting, using DoPNTH % <PSL.INTERP>EASY-NON-SL.RED.2, 19-Apr-82 23:05:35, Edit by BENSON % Changed order of tests in PNTH % <PSL.INTERP>EASY-NON-SL.RED.20, 23-Feb-82 21:36:36, Edit by BENSON % Added NE (not eq) % <PSL.INTERP>EASY-NON-SL.RED.19, 16-Feb-82 22:30:33, Edit by BENSON % made NEQ GEQ and LEQ back into EXPRs % <PSL.INTERP>EASY-NON-SL.RED.16, 15-Feb-82 18:01:14, Edit by BENSON % Made NEQ GEQ and LEQ into macros % <PSL.INTERP>EASY-NON-SL.RED.12, 18-Jan-82 12:28:13, Edit by BENSON % Added NexprP CompileTime flag('(DelqIP1 DeletIP1 SubstIP1 DelAscIP1 DelAtQIP1 DoPNTH), 'InternalFunction); % predicates expr procedure NEQ(U, V); %. not EQUAL (should be changed to not EQ) not(U = V); expr procedure NE(U, V); %. not EQ not(U eq V); expr procedure GEQ(U, V); %. greater than or equal to not(U < V); expr procedure LEQ(U, V); %. less than or equal to not(U > V); lisp procedure EqCar(U, V); %. car U eq V PairP U and car U eq V; lisp procedure ExprP U; %. Is U an EXPR? EqCar(U, 'LAMBDA) or CodeP U or EqCar(GetD U, 'EXPR); lisp procedure MacroP U; %. Is U a MACRO? EqCar(GetD U, 'MACRO); lisp procedure FexprP U; %. Is U an FEXPR? EqCar(GetD U, 'FEXPR); lisp procedure NexprP U; %. Is U an NEXPR? EqCar(GetD U, 'NEXPR); % Function definition lisp procedure CopyD(New, Old); %. FunDef New := FunDef Old; % % CopyD(New:id, Old:id):id % ----------------------- % Type: EVAL, SPREAD % The function body and type for New become the same as Old. If no % definition exists for Old, the error % % ***** `Old' has no definition in CopyD % % occurs. New is returned. % begin scalar OldDef; OldDef := GetD Old; if PairP OldDef then PutD(New, car OldDef, cdr OldDef) else StdError BldMsg("%r has no definition in CopyD", Old); return New; end; % Numerical functions lisp procedure Recip N; %. Floating point reciprocal 1.0 / N; % Commonly used constructors lisp procedure MkQuote U; %. Eval MkQuote U eq U list('QUOTE, U); % Nicer names to access parts of a list macro procedure First U; %. First element of a list 'CAR . cdr U; macro procedure Second U; %. Second element of a list 'CADR . cdr U; macro procedure Third U; %. Third element of a list 'CADDR . cdr U; macro procedure Fourth U; %. Fourth element of a list 'CADDDR . cdr U; macro procedure Rest U; %. Tail of a list 'CDR . cdr U; % Destructive and EQ versions of Standard Lisp functions lisp procedure ReversIP U; %. Destructive REVERSE (REVERSe In Place) begin scalar X,Y; while PairP U do << X := cdr U; Y := RplacD(U, Y); U := X >>; return Y end; lisp procedure SubstIP1(A, X, L); % Auxiliary function for SubstIP << if X = car L then RplacA(L, A) else if PairP car L then SubstIP(A, X, car L); if PairP cdr L then SubstIP(A, X, cdr L) >>; lisp procedure SubstIP(A, X, L); %. Destructive version of Subst if null L then NIL else if X = L then A else if not PairP L then L else << SubstIP1(A, X, L); L >>; lisp procedure DeletIP1(U, V); % Auxiliary function for DeletIP if PairP cdr V then if U = cadr V then RplacD(V, cddr V) else DeletIP1(U, cdr V); lisp procedure DeletIP(U, V); %. Destructive DELETE if not PairP V then V else if U = car V then cdr V else << DeletIP1(U, V); V >>; lisp procedure DelQ(U, V); %. EQ version of DELETE if not PairP V then V else if car V eq U then cdr V else car V . DelQ(U, cdr V); lisp procedure Del(F, U, V); %. Generalized Delete, F is comparison function if not PairP V then V else if Apply(F, list(car V, U)) then cdr V else car V . Del(F, U, cdr V); lisp procedure DelqIP1(U, V); % Auxiliary function for DelqIP if PairP cdr V then if U eq cadr V then RplacD(V, cddr V) else DelqIP1(U, cdr V); lisp procedure DelqIP(U, V); %. Destructive DELQ if not PairP V then V else if U eq car V then cdr V else << DelqIP1(U, V); V >>; lisp procedure Atsoc(U, V); %. EQ version of ASSOC if not PairP V then NIL else if PairP car V and U eq caar V then car V else Atsoc(U, cdr V); lisp procedure Ass(F, U, V); %. Generalized Assoc, F is comparison function % % Not to be confused with Elbow % if not PairP V then NIL else if PairP car V and Apply(F, list(U, caar V)) then car V else Ass(F, U, cdr V); lisp procedure Mem(F, U, V); %. Generalized Member, F is comparison function if not PairP V then NIL else if Apply(F, list(U, car V)) then V else Mem(F, U, cdr V); lisp procedure RAssoc(U, V); %. Reverse Assoc, compare with cdr of entry if not PairP V then NIL else if PairP car V and U = cdar V then car V else RAssoc(U, cdr V); lisp procedure DelAsc(U, V); %. Remove first (U . xxx) from V if not PairP V then NIL else if PairP car V and U = caar V then cdr V else car V . DelAsc(U, cdr V); lisp procedure DelAscIP1(U, V); % Auxiliary function for DelAscIP if PairP cdr V then if PairP cadr V and U = caadr V then RplacD(V, cddr V) else DelAscIP1(U, cdr V); lisp procedure DelAscIP(U, V); %. Destructive DelAsc if not PairP V then NIL else if PairP car V and U = caar V then cdr V else << DelAscIP1(U, V); V >>; lisp procedure DelAtQ(U, V); %. EQ version of DELASC if not PairP V then NIL else if EqCar(car V, U) then cdr V else car V . DelAtQ(U, cdr V); lisp procedure DelAtQIP1(U, V); % Auxiliary function for DelAtQIP if PairP cdr V then if PairP cadr V and U eq caadr V then RplacD(V, cddr V) else DelAtQIP1(U, cdr V); lisp procedure DelAtQIP(U, V); %. Destructive DelAtQ if not PairP V then NIL else if PairP car V and U eq caar V then cdr V else << DelAtQIP1(U, V); V >>; lisp procedure SublA(U,V); %. EQ version of SubLis, replaces atoms only begin scalar X; return if not PairP U or null V then V else if atom V then if (X := Atsoc(V, U)) then cdr X else V else SublA(U, car V) . SublA(U, cdr V) end; lisp procedure RplacW(A, B); %. RePLACe Whole pair if PairP A then if PairP B then RplacA(RplacD(A, cdr B), car B) else NonPairError(B, 'RplacW) else NonPairError(A, 'RPlacW); lisp procedure LastCar X; %. last element of list if atom X then X else car LastPair X; lisp procedure LastPair X; %. last pair of list if atom X or atom cdr X then X else LastPair cdr X; lisp procedure Copy U; %. copy all pairs in S-Expr % % See also TotalCopy in COPIERS.RED % if PairP U then Copy car U . Copy cdr U else U; % blows up if circular lisp procedure NTH(U, N); %. N-th element of list (lambda(X); if PairP X then car X else RangeError(U, N, 'NTH))(DoPNTH(U, N)); lisp procedure DoPNTH(U, N); if N = 1 or not PairP U then U else DoPNTH(cdr U, N - 1); lisp procedure PNTH(U, N); %. Pointer to N-th element of list if N = 1 then U else if not PairP U then RangeError(U, N, 'PNTH) else PNTH(cdr U, N - 1); lisp procedure AConc(U, V); %. destructively add element V to the tail of U NConc(U, list V); lisp procedure TConc(Ptr, Elem); %. AConc maintaining pointer to end % % ACONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to (NIL . NIL) before calling the first time % << Elem := list Elem; if not PairP Ptr then % if PTR not initialized, return starting ptr Elem . Elem else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, Elem), Elem) else << RplacD(cdr Ptr, Elem); RplacD(Ptr, Elem) >> >>; lisp procedure LConc(Ptr, Lst); %. NConc maintaining pointer to end % % NCONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to NIL . NIL before calling the first time % if null Lst then Ptr else if atom Ptr then % if PTR not initialized, return starting ptr Lst . LastPair Lst else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, LastPair Lst), Lst) else << RplacD(cdr Ptr, Lst); RplacD(Ptr, LastPair Lst) >>; % MAP functions of 2 arguments lisp procedure Map2(L, M, Fn); %. for each X, Y on L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(L, M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAP2" else NIL >>; lisp procedure MapC2(L, M, Fn); %. for each X, Y in L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(car L, car M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAPC2" else NIL >>; % Printing functions lisp procedure ChannelPrin2T(C, U); %. Prin2 and TerPri << ChannelPrin2(C, U); ChannelTerPri C; U >>; lisp procedure Prin2T U; %. Prin2 and TerPri ChannelPrin2T(OUT!*, U); lisp procedure ChannelSpaces(C, N); %. Prin2 N spaces for I := 1 step 1 until N do ChannelWriteChar(C, char BLANK); lisp procedure Spaces N; %. Prin2 N spaces ChannelSpaces(OUT!*, N); lisp procedure ChannelTAB(Chn, N); %. Spaces to column N begin scalar M; M := ChannelPosn Chn; if N < M then << ChannelTerPri Chn; M := 0 >>; ChannelSpaces(Chn, N - M); end; lisp procedure TAB N; %. Spaces to column N ChannelTAB(OUT!*, N); if_system(Dec20, << lap '((!*entry FileP expr 1) (!*MOVE (REG 1) (REG 2)) (hrli 2 8#010700) % make a byte pointer (hrlzi 1 2#001000000000000001) % gj%old + gj%sht (gtjfn) (jrst NotFile) (rljfn) % release it (jfcl) (!*MOVE (QUOTE T) (REG 1)) (!*EXIT 0) NotFile (!*MOVE (QUOTE NIL) (REG 1)) (!*EXIT 0) ); >>, << lisp procedure FileP F; %. is F an existing file? % % This could be done more efficiently in a much more system-dependent way, % but efficiency probably doesn't matter too much here. % if PairP(F := ErrorSet(list('OPEN, MkQuote F, '(QUOTE INPUT)), NIL, NIL)) then << Close car F; T >> else NIL; >>); % This doesn't belong anywhere and will be eliminated soon lisp procedure PutC(Name, Ind, Exp); %. Used by RLISP to define SMACROs << put(Name, Ind, Exp); Name >>; LoadTime << PutD('Spaces2, 'EXPR, cdr GetD 'TAB); % For compatibility PutD('ChannelSpaces2, 'EXPR, cdr GetD 'ChannelTAB); >>; END; |
Added psl-1983/3-1/kernel/easy-sl.red version [642f7c1834].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EASY-SL.RED - Standard Lisp functions with easy Standard Lisp definitions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EASY-SL.RED.3, 17-Sep-82 16:16:58, Edit by BENSON % Added ChannelPrint % <PSL.INTERP>EASY-SL.RED.4, 13-Aug-82 14:14:49, Edit by BENSON % Changed nice recursive Append to ugly iterative definition % <PSL.INTERP>EASY-SL.RED.13, 8-Feb-82 17:43:07, Edit by BENSON % Made SetQ take multiple arguments % <PSL.INTERP>EASY-SL.RED.7, 18-Jan-82 17:30:14, Edit by BENSON % Added Max2 and Min2 % <PSL.INTERP>EASY-SL.RED.6, 15-Jan-82 14:54:36, Edit by BENSON % Changed DE, DF, DM, DN from Fexprs to Macros % This file contains only functions found in the Standard Lisp report which % can be easily and efficiently defined in terms of other Standard Lisp % functions. It does not include primitive functions which are handled % specially by the compiler, such as EQ. % Many NULL tests in these functions have been replaced with not PairP tests, % so that they will be safer. CompileTime flag('(EvAnd1), 'InternalFunction); % Section 3.1 -- Elementary predicates lisp procedure Atom U; %. is U a non pair? not PairP U; lisp procedure ConstantP U; %. is Eval U eq U by definition? not PairP U and not IDP U; lisp procedure Null U; %. is U eq NIL? U eq NIL; lisp procedure NumberP U; %. is U a number of any kind? FixP U or FloatP U; lisp procedure Expt(X, N); begin scalar Result; if not IntP N or not NumberP X then return ContError(99, "Illegal arguments to Expt", X ** N); Result := 1; if N > 0 then for I := 1 step 1 until N do Result := Result * X else if N < 0 then for I := -1 step -1 until N do Result := Result / X; return Result; end; % MinusP, OneP and ZeroP are in ARITHMETIC.RED % FixP is defined in OTHERS-SL.RED % Section 3.2 -- Functions on Dotted-Pairs % composites of CAR and CDR are found in CARCDR.RED fexpr procedure List U; %. construct list of arguments EvLis U; % section 3.5 -- Function definition macro procedure DE U; %. Terse syntax for PutD call for EXPR list('PutD, MkQuote cadr U, '(QUOTE EXPR), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DF U; %. Terse syntax for PutD call for FEXPR list('PutD, MkQuote cadr U, '(QUOTE FEXPR), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DM U; %. Terse syntax for PutD call for MACRO list('PutD, MkQuote cadr U, '(QUOTE MACRO), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DN U; %. Terse syntax for PutD call for NEXPR list('PutD, MkQuote cadr U, '(QUOTE NEXPR), list('FUNCTION, ('LAMBDA . cddr U))); % Section 3.6 -- Variables and bindings fexpr procedure SetQ U; %. Standard named variable assignment % % Extended from SL Report to be Common Lisp compatible % (setq foo 1 bar 2 ...) is permitted % begin scalar V, W; while U do << W := cdr U; Set(car U, V := Eval car W); U := cdr W >>; return V; end; % Section 3.7 -- Program feature functions lisp procedure Prog2(U, V); %. Return second argument V; fexpr procedure ProgN U; %. Sequential evaluation, return last EvProgN U; StartupTime put('PROGN, 'TYPE, 'FEXPR); lisp procedure EvProgN U; %. EXPR support for ProgN, Eval, Cond if PairP U then << while PairP cdr U do << Eval car U; U := cdr U >>; Eval car U >> else NIL; % Section 3.10 -- Boolean functions and conditionals fexpr procedure And U; %. Sequentially evaluate until NIL EvAnd U; lisp procedure EvAnd U; %. EXPR support for And if not PairP U then T else EvAnd1 U; lisp procedure EvAnd1 U; % Auxiliary function for EvAnd if not PairP cdr U then Eval car U else if not Eval car U then NIL else EvAnd1 cdr U; fexpr procedure OR U; %. sequentially evaluate until non-NIL EvOr U; lisp procedure EvOr U; %. EXPR support for Or PairP U and (Eval car U or EvOr cdr U); fexpr procedure Cond U; %. Conditional evaluation construct EvCond U; lisp procedure EvCond U; %. EXPR support for Cond % % Extended from Standard Lisp definition to allow no consequent (antecedent is % returned), or multiple consequent (implicit progn). % begin scalar CondForm, Antecedent, Result; return if not PairP U then NIL else << CondForm := car U; U := cdr U; Antecedent := if PairP CondForm then car CondForm else CondForm; if not (Result := Eval Antecedent) then EvCond U else if not PairP CondForm or not PairP cdr CondForm then Result else EvProgN cdr CondForm >>; end; lisp procedure Not U; %. Equivalent to NULL null U; % Section 3.11 -- Arithmetic functions lisp procedure Abs U; %. Absolute value of number if MinusP U then -U else U; lisp procedure Divide(U, V); %. dotted pair remainder and quotient if ZeroP V then ContError(99, "Attempt to divide by 0 in DIVIDE", Divide(U, V)) else Quotient(U, V) . Remainder(U, V); macro procedure Max U; %. numeric maximum of several arguments RobustExpand(cdr U, 'Max2, 0); % should probably be -infinity lisp procedure Max2(U, V); %. maximum of 2 arguments if U < V then V else U; macro procedure Min U; %. numeric minimum of several arguments RobustExpand(cdr U, 'Min2, 0); % should probably be +infinity lisp procedure Min2(U, V); %. minimum of 2 arguments if U > V then V else U; macro procedure Plus U; %. addition of several arguments RobustExpand(cdr U, 'Plus2, 0); macro procedure Times U; %. multiplication of several arguments RobustExpand(cdr U, 'Times2, 1); % Section 3.12 -- MAP Composite functions lisp procedure Map(L, Fn); %. for each X on L do Fn(X); while PairP L do << Apply(Fn, list L); L := cdr L >>; lisp procedure MapC(L, Fn); %. for each X in L do Fn(X); while PairP L do << Apply(Fn, list car L); L := cdr L >>; lisp procedure MapCan(L, Fn); %. for each X in L conc Fn(X); if not PairP L then NIL else NConc(Apply(Fn, list car L), MapCan(cdr L, Fn)); lisp procedure MapCon(L, Fn); %. for each X on L conc Fn(X); if not PairP L then NIL else NConc(Apply(Fn, list L), MapCon(cdr L, Fn)); lisp procedure MapCar(L, Fn); %. for each X in L collect Fn(X); if not PairP L then NIL else Apply(Fn, list car L) . MapCar(cdr L, Fn); lisp procedure MapList(L, Fn); %. for each X on L collect Fn(X); if not PairP L then NIL else Apply(Fn, list L) . MapList(cdr L, Fn); % Section 3.13 -- Composite functions lisp procedure Append(U, V); %. Combine 2 lists if not PairP U then V else begin scalar U1, U2; U1 := U2 := car U . NIL; U := cdr U; while PairP U do << RplacD(U2, car U . NIL); U := cdr U; U2 := cdr U2 >>; RplacD(U2, V); return U1; end; % % These A-list functions differ from the Standard Lisp Report in that % poorly formed A-lists (non-pair entries) are not signalled as an error, % rather the entries are ignored. This is because some data structures % (such as property lists) use atom entries for other purposes. % lisp procedure Assoc(U, V); %. Return first (U . xxx) in V, or NIL if not PairP V then NIL else if PairP car V and U = caar V then car V else Assoc(U, cdr V); lisp procedure Sassoc(U, V, Fn); %. Return first (U . xxx) in V, or Fn() if not PairP V then Apply(Fn, NIL) else if PairP car V and U = caar V then car V else Sassoc(U, cdr V, Fn); lisp procedure Pair(U, V); %. For each X,Y in U,V collect (X . Y) if PairP U and PairP V then (car U . car V) . Pair(cdr U, cdr V) else if PairP U or PairP V then StdError "Different length lists in PAIR" else NIL; lisp procedure SubLis(X, Y); %. Substitution in Y by A-list X if not PairP X then Y else begin scalar U; U := Assoc(Y, X); return if PairP U then cdr U else if not PairP Y then Y else SubLis(X, car Y) . SubLis(X, cdr Y); end; lisp procedure DefList(DList, Indicator); %. PUT many IDs, same indicator if not PairP DList then NIL else << put(caar DList, Indicator, cadar DList); caar DList >> . DefList(cdr DList, Indicator); lisp procedure Delete(U, V); %. Remove first top-level U in V if not PairP V then V else if car V = U then cdr V else car V . Delete(U, cdr V); % DIGIT, LENGTH and LITER are optimized, don't use SL Report version lisp procedure Member(U, V); %. Find U in V if not PairP V then NIL else if U = car V then V else U Member cdr V; lisp procedure MemQ(U, V); % EQ version of Member if not PairP V then NIL else if U eq car V then V else U MemQ cdr V; lisp procedure NConc(U, V); %. Destructive version of Append begin scalar W; if not PairP U then return V; W := U; while PairP cdr W do W := cdr W; RplacD(W, V); return U; end; lisp procedure Reverse U; %. Top-level reverse of list begin scalar V; while PairP U do << V := car U . V; U := cdr U >>; return V; end; lisp procedure Subst(A, X, L); %. Replace every X in L with A if null L then NIL else if X = L then A else if null PairP L then L else Subst(A, X, car L) . Subst(A, X, cdr L); lisp procedure EvLis U; %. For each X in U collect Eval X if not PairP U then NIL else Eval car U . EvLis cdr U; lisp procedure RobustExpand(L, Fn, EmptyCase); %. Expand + arg for empty list if null L then EmptyCase else Expand(L, Fn); lisp procedure Expand(L, Fn); %. L = (a b c) --> (Fn a (Fn b c)) if not PairP L then L else if not PairP cdr L then car L else list(Fn, car L, Expand(cdr L, Fn)); fexpr procedure Quote U; %. Return unevaluated argument car U; StartupTime put('QUOTE, 'TYPE, 'FEXPR); % needed to run from scratch fexpr procedure Function U; %. Same as Quote in this version car U; % Section 3.15 -- Input and Output lisp procedure ChannelPrint(C, U); %. Display U and terminate line << ChannelPrin1(C, U); ChannelTerPri C; U >>; lisp procedure Print U; %. Display U and terminate line ChannelPrint(OUT!*, U); End; |
Added psl-1983/3-1/kernel/equal.red version [a38fa729ea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EQUAL.RED - EQUAL, EQN and friends % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EQUAL.RED.2, 21-Sep-82 10:38:28, Edit by BENSON % Made HalfWordsEqual, etc. internal % EQ is handled by the compiler and is in KNOWN-TO-COMP-SL.RED CompileTime flag('(HalfWordsEqual VectorEqual WordsEqual), 'InternalFunction); on SysLisp; syslsp procedure Eqn(U, V); %. Eq or numeric equality U eq V or case Tag U of % add bignums later FLTN: FloatP V and FloatHighOrder FltInf U eq FloatHighOrder FltInf V and FloatLowOrder FltInf U eq FloatLowOrder FltInf V; FIXN: FixNP V and FixVal FixInf U eq FixVal FixInf V; BIGN: BigP V and WordsEqual(U, V); default: NIL end; % Called LispEqual instead of Equal, to avoid name change due to Syslisp parser syslsp procedure LispEqual(U, V); %. Structural equality U eq V or case Tag U of VECT: VectorP V and VectorEqual(U, V); STR, BYTES: StringP V and StringEqual(U, V); PAIR: PairP V and LispEqual(car U, car V) and LispEqual(cdr U, cdr V); FLTN: FloatP V and FloatHighOrder FltInf U eq FloatHighOrder FltInf V and FloatLowOrder FltInf U eq FloatLowOrder FltInf V; FIXN: FixNP V and FixVal FixInf U eq FixVal FixInf V; BIGN: BigP V and WordsEqual(U, V); WRDS: WrdsP V and WordsEqual(U, V); HalfWords: HalfWordsP V and HalfWordsEqual(U, V); default: NIL end; syslsp procedure EqStr(U, V); %. Eq or string equality U eq V or StringP U and StringP V and StringEqual(U, V); syslsp procedure StringEqual(U, V); % EqStr without typechecking or eq begin scalar Len, I; U := StrInf U; V := StrInf V; Len := StrLen U; if Len neq StrLen V then return NIL; I := 0; Loop: if I > Len then return T; if StrByt(U, I) neq StrByt(V, I) then return NIL; I := I + 1; goto Loop; end; syslsp procedure WordsEqual(U, V); begin scalar S1, I; U := WrdInf U; V := WrdInf V; if not ((S1 := WrdLen U) eq WrdLen V) then return NIL; I := 0; Loop: if I eq S1 then return T; if not (WrdItm(U, I) eq WrdItm(V, I)) then return NIL; I := I + 1; goto Loop; end; syslsp procedure HalfWordsEqual(U, V); begin scalar S1, I; U := HalfWordInf U; V := HalfWordInf V; if not ((S1 := HalfWordLen U) eq HalfWordLen V) then return NIL; I := 0; Loop: if I eq S1 then return T; if not (HalfWordItm(U, I) eq HalfWordItm(V, I)) then return NIL; I := I + 1; goto Loop; end; syslsp procedure VectorEqual(U, V); % Vector equality without type check begin scalar Len, I; U := VecInf U; V := VecInf V; Len := VecLen U; if Len neq VecLen V then return NIL; I := 0; Loop: if I > Len then return T; if not LispEqual(VecItm(U, I), VecItm(V, I)) then return NIL; I := I + 1; goto Loop; end; off SysLisp; LoadTime PutD('Equal, 'EXPR, cdr GetD 'LispEqual); END; |
Added psl-1983/3-1/kernel/error-errorset.red version [ae8f44d36a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ERROR-ERRORSET.RED - The most basic ERROR and ERRORSET % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 4 Feb 1983 1208-PST % Moved ERRSET here from CATCH-THROW.RED. % Edit by Cris Perdue, 3 Feb 1983 1526-PST % Tidied up definition of ERRORSET. % <PSL.KERNEL>ERROR-ERRORSET.RED.3, 11-Oct-82 17:57:30, Edit by BENSON % Changed CATCH/THROW to new definition % <PSL.KERNEL>ERROR-ERRORSET.RED.2, 20-Sep-82 11:31:23, Edit by BENSON % Removed printing of error number in ERROR % <PSL.INTERP>ERROR-ERRORSET.RED.7, 26-Feb-82 23:44:01, Edit by BENSON % Added BreakLevel!* check % <PSL.INTERP>ERROR-ERRORSET.RED.5, 28-Dec-81 17:07:18, Edit by BENSON % Changed 3rd formal in ErrorSet to !*Inner!*Backtrace global '(EMsg!*); % gets current error message fluid '(!*BackTrace % controls backtrace printing (actual) !*Inner!*Backtrace % controls backtrace printing (formal) !*EMsgP % controls message printing !*Break % controls breaking BreakLevel!* % nesting level of breaks MaxBreakLevel!* % maximum permitted ... !*ContinuableError); % if T, inside a continuable error LoadTime << !*EmsgP := T; !*BackTrace := NIL; !*Break := T >>; lisp procedure Error(Number, Message); %. Throw to ErrorSet begin scalar !*ContinuableError; EMsg!* := Message; if !*EMsgP then << ErrorPrintF("***** %l", Message); % Error number is not printed if !*Break and BreakLevel!* < MaxBreakLevel!* then return Break() >>; return << if !*Inner!*BackTrace then BackTrace(); Throw('!$Error!$, Number) >>; end; % More useful version of ERRORSET macro procedure errset u; (lambda(form, flag); list(list('lambda, '(!*Emsgp), list('catch, ''!$error!$, list('ncons, form))), flag))(cadr u, if null cddr u then t else caddr u); lisp procedure ErrorSet(Form, !*EMsgP, !*Inner!*BackTrace); %. Protected Eval Catch('!$Error!$, list(Eval Form)); % eval form END; |
Added psl-1983/3-1/kernel/error-handlers.red version [0da90a6bfa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ERROR-HANDLERS.RED - Low level error handlers % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PERDUE.PSL>ERROR-HANDLERS.RED.2, 9-Dec-82 18:16:42, Edit by PERDUE % Changed continuable error message; also allows for no (NIL) retry form % <PSL.KERNEL>ERROR-HANDLERS.RED.2, 20-Sep-82 14:55:56, Edit by BENSON % Error number isn't printed % <PSL.INTERP>ERROR-HANDLERS.RED.11, 26-Feb-82 23:43:16, Edit by BENSON % Added BreakLevel!* check % <PSL.INTERP>ERROR-HANDLERS.RED.8, 28-Dec-81 17:02:43, Edit by BENSON % Compressed output in ContinuableError % MLG 7:18am Tuesday, 24 November 1981 - To print ErrorForm!* on ErrorOut!* fluid '(!*ContinuableError % if true, inside continuable error ErrorForm!* BreakLevel!* % nesting level of break loops MaxBreakLevel!* % maximum permitted ... !*EMsgP); % value of 2nd arg to previous errorset global '(EMsg!*); % gets message from most recent error on SysLisp; syslsp procedure FatalError S; << ErrorPrintF("***** Fatal error: %s", S); while T do Quit; >>; off SysLisp; lisp procedure RangeError(Object, Index, Fn); StdError BldMsg("Index %r out of range for %p in %p", Index, Object, Fn); lisp procedure StdError Message; %. Error without number Error(99, Message); SYMBOLIC PROCEDURE YESP U; BEGIN SCALAR BOOL,X,Y, OLDOUT, OLDIN, PROMPTSTRING!*; OLDIN := RDS NIL; OLDOUT := WRS ERROUT!*; % TERPRI(); % PRIN2L U; % TERPRI(); % TERPRI(); if_system(Tops20, % ? in col 1, so batch jobs get killed PROMPTSTRING!* := BldMsg("?%l (Y or N) ", U), PROMPTSTRING!* := BldMsg("%l (Y or N) ", U)); A: X := READ(); IF (Y := (X MEMQ '(Y YES))) OR X MEMQ '(N NO) THEN GO TO B; % IF NULL BOOL THEN PRIN2T "TYPE Y OR N"; if X = 'B then ErrorSet('(Break), NIL, NIL); if_system(Unix, % If read EOF, croak so shell scripts terminate if X eq !$EOF!$ then return (lambda(!*Break); StdError "End-of-file read in YesP")(NIL)); BOOL := T; GO TO A; B: WRS OLDOUT; RDS OLDIN; CURSYM!* := '!*SEMICOL!*; RETURN Y END; lisp procedure ContinuableError(ErrNum, Message, ErrorForm!*); %. maybe fix begin scalar !*ContinuableError; !*ContinuableError := T; EMsg!* := Message; return if !*Break and !*EMsgP and BreakLevel!* < MaxBreakLevel!* then << ErrorPrintF("***** %l", Message); % Don't print number if null ErrorForm!* then ErrorPrintF("***** Continuable error.") else if FlatSize ErrorForm!* < 40 then ErrorPrintF("***** Continuable error: retry form is %r", ErrorForm!*) else << ErrorPrintF("***** Continuable error, retry form is:"); ErrorPrintF("%p", ErrorForm!*) >>; Break() >> else Error(ErrNum, Message); end; END; |
Added psl-1983/3-1/kernel/error.build version [216c0738f0].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % ERROR.BUILD - Files with error handling functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "error-handlers.red"$ % low level error handlers PathIn "type-errors.red"$ % type mismatch error calls PathIn "error-errorset.red"$ % most basic error handling PathIn "io-errors.red"$ % I/O error handlers |
Added psl-1983/3-1/kernel/eval-apply.red version [bf84031003].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EVAL-APPLY.RED - Function calling mechanism % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EVAL-APPLY.RED.2, 20-Sep-82 10:36:28, Edit by BENSON % CAR of a form is never evaluated % <PSL.INTERP>EVAL-APPLY.RED.5, 6-Jan-82 19:22:46, Edit by GRISS % Add NEXPR % FUnBoundP and other function cell primitives found in FUNCTION-PRIMITIVES % Eval and Apply could have been defined using only GetD rather than these % primitves. They are used instead to avoid the CONS in GETD. % ValueCell is found in SYMBOL-VALUES.RED % IDApply, CodeApply, IDEvalApply and CodeEvalApply are written in LAP % due to register usage and to make them faster. They are found in % APPLY-LAP.RED. IDApply1 is handled by the compiler % uses EvProgN, found in EASY-SL.RED, expr for PROGN % Error numbers: % 1000 - undefined function % 1100 - ill-formed function expression % 1200 - argument number mismatch % 1300 - unknown function type % +3 in LambdaEvalApply % +4 in LambdaApply % +2 in Apply % +1 in Eval CompileTime flag('(LambdaEvalApply LambdaApply), 'InternalFunction); on SysLisp; % the only reason these 2 are in Syslisp is to speed up arithmetic (N := N + 1) syslsp procedure LambdaEvalApply(Fn, Args); %. Fn is Lambda, Args to be Evaled if not (PairP Fn and car Fn = 'LAMBDA) then ContinuableError('1103, '"Ill-formed function expression", Fn . Args) else begin scalar N, Result; N := BindEval(cadr Fn, Args); % hand-coded, bind formals to evlis args if N = -1 then return ContinuableError('1203, '"Argument number mismatch", Fn . Args); Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; syslsp procedure LambdaApply(Fn, Args); %. Fn is Lambda, unevaled Args if not (PairP Fn and car Fn = 'LAMBDA) then ContinuableError('1104, '"Ill-formed function expression", Fn . for each X in Args collect MkQuote X) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals and PairP Args do << LBind1(car Formals, car Args); Formals := cdr Formals; Args := cdr Args; N := N + 1 >>; if PairP Formals or PairP Args then return ContinuableError('1204, '"Argument number mismatch", Fn . for each X in Args collect MkQuote X); Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off SysLisp; % Apply differs from the Standard Lisp Report in that functions other % than EXPRs are allowed to be applied, the effect being the same as % Apply(cdr GetD Fn, Args) lisp procedure Apply(Fn, Args); %. Indirect function call if IDP Fn then begin scalar StackMarkForBacktrace, Result; if FUnBoundP Fn then return ContinuableError(1002, BldMsg("%r is an undefined function", Fn), Fn . for each X in Args collect MkQuote X); StackMarkForBacktrace := MkBTR Inf Fn; Result := if FCodeP Fn then CodeApply(GetFCodePointer Fn, Args) else LambdaApply(get(Fn, '!*LambdaLink), Args); return Result; end else if CodeP Fn then CodeApply(Fn, Args) else if PairP Fn and car Fn = 'LAMBDA then LambdaApply(Fn, Args) else ContinuableError(1102, "Ill-formed function expression", Fn . for each X in Args collect MkQuote X); lisp procedure Eval U; %. Interpret S-Expression as program if not PairP U then if not IDP U then U else ValueCell U else begin scalar Fn; Fn := car U; return if IDP Fn then if FUnBoundP Fn then ContinuableError(1300, BldMsg("%r is an undefined function", Fn), U) else begin scalar FnType, StackMarkForBacktrace, Result; FnType := GetFnType Fn; StackMarkForBacktrace := MkBTR Inf Fn; Result := if null FnType then % must be an EXPR if FCodeP Fn then CodeEvalApply(GetFCodePointer Fn, cdr U) else LambdaEvalApply(get(Fn, '!*LambdaLink), cdr U) else if FnType = 'FEXPR then IDApply1(cdr U, Fn) else if FnType = 'NEXPR then IDApply1(EvLis cdr U, Fn) else if FnType = 'MACRO then Eval IDApply1(U, Fn) else ContinuableError(1301, BldMsg("Unknown function type %r", FnType), U); return Result; end else if CodeP Fn then CodeEvalApply(Fn, cdr U) else if PairP Fn and car Fn = 'LAMBDA then LambdaEvalApply(Fn, cdr U) else ContinuableError(1302, BldMsg("Ill-formed expression in Eval %r", U), U); end; END; |
Added psl-1983/3-1/kernel/eval-when.red version [836d273222].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EVAL-WHEN.RED - Funny business to make things happen at different times % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 30 August 1981 % Copyright (c) 1981 University of Utah % % Functions flagged IGNORE are evaluated immediately when invoked at the top % level while compiling to a file. Those flagged EVAL are evaled immediately % and also passed to the file. These functions are defined to make those % actions more visible and mnemonic. macro procedure CommentOutCode U; %. Comment out a single expression NIL; lisp procedure CompileTime U; %. Evaluate at compile time only U; % just return the already evaluated argument flag('(CommentOutCode CompileTime), 'IGNORE); % The functions above need only be present at compile time. Those below must % be present at both compile and load time to be effective. lisp procedure BothTimes U; %. Evaluate at compile and load time U; flag('(BothTimes), 'EVAL); lisp procedure LoadTime U; %. Evaluate at load time only U; PutD('StartupTime, 'EXPR, cdr GetD 'LoadTime); % StartupTime is kernel hack RemFlag('(LoadTime), 'IGNORE); % just to be sure it doesn't RemFlag('(LoadTime), 'EVAL); % happen until load time END; |
Added psl-1983/3-1/kernel/eval.build version [dd7f0a6f01].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % EVAL.BUILD - Files with Eval and Apply in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "apply-lap.red"$ % low-level function linkage, in LAP PathIn "eval-apply.red"$ % interpreter functions PathIn "catch-throw.red"$ % non-local GOTO mechanism PathIn "prog-and-friends.red"$ % Prog, Go and Return |
Added psl-1983/3-1/kernel/explode-compress.red version [bea6641f89].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EXPLODE-COMPRESS.RED - Write to/read from a list; includes FlatSize % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EXPLODE-COMPRESS.RED.3, 12-Oct-82 16:49:54, Edit by BENSON % Changed CompressReadChar to use Lisp2Char, so ASCII characters are OK, % but digits 0..9 as !0..!9 are not. fluid '(ExplodeEndPointer!* % pointer used to RplacD new chars onto CompressList!* % list being compressed !*Compressing); % if T, don't intern IDs when read external WArray LinePosition,UnReadBuffer; on SysLisp; syslsp procedure ExplodeWriteChar(Channel, Ch); << RplacD(LispVar ExplodeEndPointer!*, list MkID Ch); LispVar ExplodeEndPointer!* := cdr LispVar ExplodeEndPointer!* >>; syslsp procedure Explode U; %. S-expr --> char-list begin scalar Result; Result := LispVar ExplodeEndPointer!* := NIL . NIL; LinePosition[3] := 0; ChannelPrin1('3, U); return cdr Result; end; syslsp procedure Explode2 U; %. Prin2 version of Explode begin scalar Result; Result := LispVar ExplodeEndPointer!* := NIL . NIL; LinePosition[3] := 0; ChannelPrin2('3, U); return cdr Result; end; internal WVar FlatSizeAccumulator; syslsp procedure FlatSizeWriteChar(Channel, Ch); FlatSizeAccumulator := FlatSizeAccumulator + 1; syslsp procedure FlatSize U; %. character length of S-expression << FlatSizeAccumulator := 0; LinePosition[4] := 0; ChannelPrin1('4, U); MkINT FlatSizeAccumulator >>; lisp procedure FlatSize2 U; %. Prin2 version of FlatSize << FlatSizeAccumulator := 0; LinePosition[4] := 0; ChannelPrin2('4, U); MkINT FlatSizeAccumulator >>; internal WVar AtEndOfList; syslsp procedure CompressReadChar Channel; begin scalar NextEntry; if AtEndOfList then return CompressError(); if not PairP LispVar CompressList!* then << AtEndOfList := 'T; return char BLANK >>; NextEntry := car LispVar CompressList!*; LispVar CompressList!* := cdr LispVar CompressList!*; return Lisp2Char NextEntry; end; syslsp procedure ClearCompressChannel(); << UnReadBuffer[3] := char NULL; AtEndOfList := 'NIL >>; off SysLisp; lisp procedure CompressError(); StdError "Poorly formed S-expression in COMPRESS"; lisp procedure Compress CompressList!*; %. Char-list --> S-expr begin scalar !*Compressing; !*Compressing := T; ClearCompressChannel(); return ChannelRead 3; end; lisp procedure Implode CompressList!*; %. Compress with IDs interned << ClearCompressChannel(); ChannelRead 3 >>; END; |
Added psl-1983/3-1/kernel/extra.build version [1df7654350].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % EXTRA.BUILD - System-dependent extras % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "timc.red"$ % System time routine PathIn "system-extras.red"$ % Random system-specific routines PathIn "trap.red"$ % Interrupt handler PathIn "dumplisp.red"$ % Core saver |
Added psl-1983/3-1/kernel/fasl-include.red version [f5273fcef2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FASL-INCLUDE.RED - data declarations for FASL at compile time % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 20 February 1982 % Copyright (c) 1982 Eric Benson % on SysLisp; CompileTime << DefConst(FASL_MAGIC_NUMBER, 99); DefConst(RELOC_ID_NUMBER, 1, RELOC_VALUE_CELL, 2, RELOC_FUNCTION_CELL, 3); DefConst(RELOC_WORD, 1, RELOC_HALFWORD, 2, RELOC_INF, 3); smacro procedure RelocRightHalfTag X; Field(X, BitsPerWord/2, 2); smacro procedure RelocRightHalfInf X; Field(X, BitsPerWord/2+2, BitsPerWord/2-2); smacro procedure RelocInfTag X; Field(X, InfStartingBit, 2); smacro procedure RelocInfInf X; Field(X, InfStartingBit+2, InfBitLength-2); smacro procedure RelocWordTag X; Field(X, 0, 2); smacro procedure RelocWordInf X; Field(X, 2, BitsPerWord-2); >>; off Syslisp; END; |
Added psl-1983/3-1/kernel/fasl.build version [ebbe4f0040].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % % FASL.BUILD - Files used for Fasl in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "system-faslout.red"$ PathIn "system-faslin.red"$ PathIn "faslin.red"$ PathIn "load.red"$ % Standard module FASL loader PathIn "autoload.red"$ % stubs to load modules |
Added psl-1983/3-1/kernel/faslin.red version [f74410220d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | on SysLisp; external WString TokenBuffer; external WArray ArgumentBlock; internal WConst CODE_OFFSET = 0, RELOC_ID_NUMBER = 1, RELOC_VALUE_CELL = 2, RELOC_FUNCTION_CELL = 3; internal WConst RELOC_WORD = 1, RELOC_RIGHT_HALF = 2, RELOC_INF = 3; internal WConst FASLMAGIC = 99; CompileTime << smacro procedure LocalIDNumberP U; U >= 2048; smacro procedure LocalToGlobalID U; IDTable[U - 2048]; smacro procedure ExtraArgumentP U; U >= 8150; % Something enough less than 8192 smacro procedure MakeExtraArgument U; U - (8150 + (MaxRealRegs + 1)); >>; internal WVar CodeBase; syslsp procedure FaslIN File; begin scalar F, N, M, IDTable, CodeSize, OldCodeBase, E, BT, R, RT, RI, BI, Top, BTop; F := BinaryOpenRead File; N := BinaryRead F; % First word is magic number if N neq FASLMAGIC then ContError(99, "%r is not a fasl format file", File, FaslIN File); M := BinaryRead F; % Number of local IDs Top := GtWArray 0; % pointer to top of space IDTable := GtWArray(M + 1); % Allocate space for table for I := 0 step 1 until M do << TokenBuffer[0] := BinaryRead F; % word is length of ID name BinaryReadBlock(F, &TokenBuffer[1], StrPack TokenBuffer[0]); IDTable[I] := IDInf Intern MkSTR TokenBuffer >>; CodeSize := BinaryRead F; % Size of code segment in words OldCodeBase := CodeBase; % So FASLIN is reentrant CodeBase := GtBPS CodeSize; % Allocate space in BPS BTop := GTBPS 0; % pointer to top E := CodeBase + BinaryRead F; % Next word is offset of init function % Will be called after code is read BinaryReadBlock(F, CodeBase, CodeSize); % Put the next N words there N := BinaryRead F; % Next word is size of bit table in words BT := GtWArray N; % Allocate space for bit table BinaryReadBlock(F, BT, N); % read bit table BinaryClose F; % close the file CodeSize := CodeSize*AddressingUnitsPerItem - 1; for I := 0 step 1 until CodeSize do << R := BitTable(BT, I); BI := CodeBase + I; case R of RELOC_WORD: << RT := RelocWordTag @BI; RI := RelocWordInf @BI; case RT of CODE_OFFSET: @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := RI >>; end >>; RELOC_RIGHT_HALF: << RT := RelocRightHalfTag @BI; RI := RelocRightHalfInf @BI; case RT of CODE_OFFSET: RightHalf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; RightHalf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := RI >>; end >>; RELOC_INF: << RT := RelocInfTag @BI; RI := RelocInfInf @BI; case RT of CODE_OFFSET: Inf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; Inf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := RI >>; end >>; end >>; DelWArray(BT, Top); % return the space used by tables AddressApply0 E; % Call the init routine CodeBase := OldCodeBase; % restore previous value for CodeBase DelBPS(E, BTop); % deallocate space of init routine end; syslsp procedure PutEntry(Name, Type, Offset); PutD(Name, Type, MkCODE(CodeBase + Offset)); off Syslisp; END; |
Added psl-1983/3-1/kernel/fast-binder.red version [76bcb81d58].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-FAST-BINDER.RED - Portable version of binding from compiled code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % % This file is for use with *LAMBIND and *PROGBIND in P-LAMBIND StartupTime << LambindArgs!* := GtWArray 15; >>; on Syslisp; syslsp procedure LamBind V; % V is vector of IDs begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do LBind1(VecItm(V, I), (LispVar LambindArgs!*)[I]); end; syslsp procedure ProgBind V; begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do PBind1 VecItm(V, I); end; off Syslisp; END; |
Added psl-1983/3-1/kernel/fluid-global.red version [c2e4a95a7d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FLUID-GLOBAL.RED - Fluid and Global declarations % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>FLUID-GLOBAL.RED.3, 10-Sep-82 09:18:04, Edit by BENSON % Uses indicator VARTYPE instead of TYPE % <PSL.INTERP>FLUID-GLOBAL.RED.3, 22-Jan-82 12:35:25, Edit by BENSON % GlobalP now only checks for variables, not functions % The functions dealing with FLUID and GLOBAL declarations use the property % list indicator TYPE, which is also used by PUTD and GETD. % Not true anymore! % Non-Standard Lisp functions used: % ErrorPrintF -- in IO.RED CompileTime flag('(DeclareFluidOrGlobal DeclareFluidOrGlobal1), 'InternalFunction); lisp procedure DeclareFluidOrGlobal(IDList, FG); for each U in IDList do DeclareFluidOrGlobal1(U, FG); lisp procedure DeclareFluidOrGlobal1(U, FG); if not IDP U then NIL else begin scalar X; X := get(U, 'VARTYPE); return if null X then << put(U, 'VARTYPE, FG); if UnBoundP U then Set(U, NIL) >> else if X eq FG then NIL else ErrorPrintF("*** %p %r cannot become %p", X, U, FG); end; lisp procedure Fluid IDList; %. Declare all in IDList as fluid vars DeclareFluidOrGlobal(IDList, 'FLUID); lisp procedure Fluid1 U; %. Declare U fluid DeclareFluidOrGlobal1(U, 'FLUID); lisp procedure FluidP U; %. Is U a fluid variable? get(U, 'VARTYPE) = 'FLUID; lisp procedure Global IDList; %. Declare all in IDList as global vars DeclareFluidOrGlobal(IDList, 'GLOBAL); lisp procedure Global1 U; %. Declare U global DeclareFluidOrGlobal1(U, 'GLOBAL); lisp procedure GlobalP U; %. Is U a global variable get(U, 'VARTYPE) = 'GLOBAL; lisp procedure UnFluid IDList; %. Undeclare all in IDList as fluid for each U in IDList do UnFluid1 U; lisp procedure UnFluid1 U; if FluidP U then RemProp(U, 'VARTYPE); END; |
Added psl-1983/3-1/kernel/io-errors.red version [40d73b7baf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-ERRORS.RED - Error handlers for input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % on SysLisp; syslsp procedure ChannelNotOpen(Chn, Ch); ChannelError(Chn, "Channel not open"); syslsp procedure WriteOnlyChannel Chn; ChannelError(Chn, "Channel open for write only"); syslsp procedure ReadOnlyChannel(Chn, Ch); ChannelError(Chn, "Channel open for read only"); syslsp procedure IllegalStandardChannelClose Chn; ChannelError(Chn, "Illegal to close standard channel"); syslsp procedure IOError(Message); StdError BldMsg("I/O Error: %s", Message); syslsp procedure ChannelError(Channel, Message); StdError BldMsg("I/O Error on channel %d: %s", IntInf Channel, Message); off SysLisp; END; |
Added psl-1983/3-1/kernel/io-extensions.red version [2f94bbdcd2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-EXTENSIONS.RED - Random, possibly useful functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 22 October 1981 % Copyright (c) 1981 University of Utah % on SysLisp; syslsp procedure ChannelTYI Chn; %. Read one char ASCII value MkINT ChannelReadChar Chn; syslsp procedure ChannelTYO(Chn, Ch); %. Write one char ASCII value ChannelWriteChar(Chn, Lisp2Char Ch); off SysLisp; global '(IN!* OUT!*); lisp procedure TYI(); %. Read ASCII value from curent input ChannelTYI IN!*; lisp procedure TYO Ch; %. Write ASCII value to current output ChannelTYO(OUT!*, Ch); END; |
Added psl-1983/3-1/kernel/io.build version [39acda9d26].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % % IO.BUILD - System-independent input and output files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "io-data.red"$ % Data structures used by IO PathIn "char-io.red"$ % bottom level IO primitives PathIn "open-close.red"$ % file primitives PathIn "rds-wrs.red"$ % IO channel switching functions PathIn "other-io.red"$ % random SL IO functions PathIn "read.red"$ % S-expression parser PathIn "token-scanner.red"$ % table-driven token scanner PathIn "printers.red"$ % Printing functions PathIn "write-float.red"$ % Floating point printer PathIn "printf.red"$ % formatted print routines PathIn "explode-compress.red"$ % Access to characters of atoms PathIn "io-extensions.red"$ % Random non-SL IO functions |
Added psl-1983/3-1/kernel/known-to-comp-sl.red version [ac3508bfb9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % KNOWN-TO-COMPILER.RED - Standard Lisp functions which are handled entirely % by the compiler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>KNOWN-TO-COMP-SL.RED.4, 4-Jul-82 13:30:59, Edit by BENSON % CAR and CDR of NIL are legal == NIL off R2I; % can't do recursion removal, will get infinte recursion % Section 3.1 -- Elementary predicates lisp procedure CodeP U; %. Is U a code pointer? CodeP U; lisp procedure Eq(U, V); %. Are U and V identical? U eq V; lisp procedure FloatP U; %. Is U a floating point number? FloatP U; lisp procedure BigP U; %. Is U a bignum? BigP U; lisp procedure IDP U; %. Is U an ID? IDP U; lisp procedure PairP U; %. Is U a pair? PairP U; lisp procedure StringP U; %. Is U a string? StringP U; lisp procedure VectorP U; %. Is U a vector? VectorP U; % Section 3.2 -- Functions on Dotted-Pairs % NonPairError found in TYPE-ERRORS.RED lisp procedure Car U; %. left subtree of pair if null U then NIL else if PairP U then car U else NonPairError(U, 'CAR); lisp procedure Cdr U; %. right subtree of pair if null U then NIL else if PairP U then cdr U else NonPairError(U, 'CDR); lisp procedure RplacA(U, V); %. RePLAce CAr of pair if PairP U then RplacA(U, V) else NonPairError(U, 'RPLACA); lisp procedure RplacD(U, V); %. RePLACe CDr of pair if PairP U then RplacD(U, V) else NonPairError(U, 'RPLACD); on R2I; % Turn recursion removal back on END; |
Added psl-1983/3-1/kernel/lisp-macros.red version [e9e3eff7a0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LISP-MACROS.RED - Various macros to make pure Lisp more tolerable % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>LISP-MACROS.RED.4, 22-Jul-82 10:51:11, Edit by BENSON % Added CASE, removed IF % still to come: Do, Let % <PSL.INTERP>LISP-MACROS.RED.5, 28-Dec-81 14:43:39, Edit by BENSON % Added SetF CompileTime flag('(InThisCase), 'InternalFunction); % Not a macro, but it belongs with these SYMBOLIC FEXPR PROCEDURE CASE U; %U is of form (CASE <integer exp> (<case-1> <exp-1>) . . .(<case-n> <exp-n>)). % If <case-i> is NIL it is default, % else is list of INT or (RANGE int int) BEGIN SCALAR CaseExpr,DEF,CaseLst,BOD; CaseExpr:=EVAL CAR U; L: IF NOT PAIRP(U:=CDR U) THEN RETURN EVAL DEF; CaseLst:=CAAR U; BOD:=CADAR U; IF NOT PAIRP CaseLst OR CAR CaseLst MEMQ '(OTHERWISE DEFAULT) THEN <<DEF:=BOD; GOTO L>>; IF InThisCase(CaseExpr,CaseLst) THEN RETURN EVAL BOD; GOTO L END; SYMBOLIC PROCEDURE InThisCase(CaseExpr,Cases); IF NOT PAIRP Cases Then NIL ELSE IF PAIRP Car Cases and Caar Cases EQ 'RANGE and CaseExpr>=Cadar Cases and CaseExpr<=Caddar Cases then T ELSE IF CaseExpr = Car Cases then T ELSE InThisCase(CaseExpr,Cdr Cases); macro procedure SetF U; %. General assignment macro ExpandSetF(cadr U, caddr U); lisp procedure ExpandSetF(LHS, RHS); begin scalar LHSOp; return if atom LHS then list('setq, LHS, RHS) else if (LHSOp := get(car LHS, 'Assign!-Op)) then LHSOp . Append(cdr LHS, list RHS) % simple substitution case else if (LHSOp := get(car LHS, 'SetF!-Expand)) then Apply(LHSOp, list(LHS, RHS)) % more complex transformation else if (LHSOp := GetD car LHS) and car LHSOp = 'MACRO then ExpandSetF(Apply(cdr LHSOp, list LHS), RHS) else StdError BldMsg("%r is not a known form for assignment", list('SetF, LHS, RHS)); end; LoadTime DefList('((GetV PutV) (car RplacA) (cdr RplacD) (Indx SetIndx) (Sub SetSub) (Nth (lambda (L I X) (rplaca (PNTH L I) X) X)) (Eval Set) (Value Set)), 'Assign!-Op); END; |
Added psl-1983/3-1/kernel/load.red version [3639951ea3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LOAD.RED - New version of LOAD function, with search path % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 2 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL>LOAD.RED.17, 23-Mar-83 11:44:39, Edit by KESSLER % Change Apollo Load directory % Edit by Cris Perdue, 21 Mar 1983 1440-PST % Put "" back in loaddirectories*. Fun, huh? % Edit by Cris Perdue, 7 Mar 1983 1527-PST % Removed ".sl" from loadextensions* and "" from loaddirectories*. % Edit by MLG, 6 March 1983. % Corrected bug in fix to Imports -- "else" was matched with incorrect "then". % Edit by Cris Perdue, 17 Feb 1983 1201-PST % Corrected use of *verboseload in top of load1 % MLG, 15 Feb 1983 % Added !*VERBOSELOAD and !*PRINTLOADNAMES % M. Griss, 9 Feb 1983 % Changed LoadDirectories!* for the VAX to refer to "$pl/" % <PSL.NEW>-SOURCE-CHANGES.LOG.15, 15-Dec-82 15:45:55, Edit by PERDUE % LOAD will now handle ".sl" extension % <PSL.KERNEL>LOAD.RED.7, 1-Dec-82 16:07:38, Edit by BENSON % Added if_system(HP9836, ...) % EDIT by GRISS 28 Oct 1982: Added EvLoad to Imports % <PSL.KERNEL>LOAD.RED.4, 4-Oct-82 09:46:54, Edit by BENSON % Moved addition of U to Options!* to avoid double load % <PSL.KERNEL>LOAD.RED.3, 30-Sep-82 11:57:03, Edit by BENSON % Removed "FOO already loaded" message % <PSL.KERNEL>LOAD.RED.2, 22-Sep-82 15:38:48, Edit by BENSON % Added ReLoad, changed VAX search path fluid '(LoadDirectories!* % list of strings to append to front LoadExtensions!* % a-list of (str . fn) to append to end % and apply PendingLoads!* % created by Imports, aux loads !*Lower % print IDs in lowercase, for building % filename for Unix !*RedefMSG % controls printing of redefined % function message !*UserMode % Controls query of user for redefining % system functions !*InsideLoad % Controls "already loaded" message !*VerboseLoad % Print REDEFs and LOAD file names !*PrintLoadNames % Print Names of files loading Options!*); % list of modules already loaded if_system(Apollo, LoadDirectories!* := '("" "~p/l/")); if_system(Tops20, LoadDirectories!* := '("" "pl:")); if_system(Unix, LoadDirectories!* := '("" "$pll/" "$pl/")); if_system(HP9836, LoadDirectories!* := '("" "pl:")); if_system(Wicat, LoadDirectories!* := '("" "PSL.LAP/")); LoadExtensions!* := '((".b" . FaslIN) (".lap" . LapIN)); !*VerboseLoad :=NIL; !*PrintLoadNames := NIL; macro procedure Load U; list('EvLoad, MkQuote cdr U); lisp procedure EvLoad U; for each X in U do Load1 X; macro procedure ReLoad U; list('EvReLoad, MkQuote cdr U); lisp procedure EvReLoad U; << for each X in U do Options!* := Delete(X, Options!*); EvLoad U >>; lisp procedure Load1 U; begin scalar !*RedefMSG, !*UserMode, LD, LE, F, Found; If !*VerBoseLoad then !*RedefMSG := T; return if U memq Options!* then if !*VerboseLoad then ErrorPrintF("*** %w already loaded", U) else NIL else (lambda(!*InsideLoad); << LD := LoadDirectories!*; (lambda (!*Lower); while not null LD and not Found do << LE := LoadExtensions!*; while not null LE and not Found do << if FileP(F := BldMsg("%w%w%w", first LD, U, car first LE)) then Found := cdr first LE; % Found is function to apply LE := rest LE >>; LD := rest LD >>)(T); if not Found then StdError BldMsg("%r load module not found", U) else << Options!* := U . Options!*; If !*VerboseLoad or !*PrintLoadNames then ErrorPrintf("*** loading %w%n",F); Apply(Found, list F); while not null PendingLoads!* do << Found := car PendingLoads!*; PendingLoads!* := cdr PendingLoads!*; Load1 Found >> >> >>)(T); end; lisp procedure Imports L; if !*InsideLoad then <<for each X in L do if not (X memq Options!* or X memq PendingLoads!*) then PendingLoads!* := Append(PendingLoads!*, list X)>> else EvLoad L; END; |
Added psl-1983/3-1/kernel/loop-macros.red version [a174933a90].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LOOP-MACROS.RED - Various macros to make pure Lisp more tolerable % % Author: Eric Benson and M. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 October 1981 % Copyright (c) 1981 University of Utah % % Edit by MLG,9:35am Tuesday, 29 December 1981 % Add EXIT, NEXT, REPEAT, add 'Join, improve FOR macro procedure ForEach U; %. Macro for MAP functions % % From RLISP % % Possible forms are: % (foreach x in u do (foo x)) --> (mapc u (function (lambda (x) (foo x)))) % (foreach x in u collect (foo x)) --> (mapcar u ...) % (foreach x in u conc (foo x)) --> (mapcan u ...) % (foreach x in u join (foo x)) --> (mapcan u ...) % (foreach x on u do (foo x)) --> (map u ...) % (foreach x on u collect (foo u)) --> (maplist u ...) % (foreach x on u conc (foo x)) --> (mapcon u ...) % (foreach x on u join (foo x)) --> (mapcon u ...) % begin scalar Action, Body, Fn, Lst, Mod, Var; Var := cadr U; U := cddr U; Mod := car U; U := cdr U; Lst := car U; U := cdr U; Action := car U; Body := cdr U; Fn := if Action eq 'DO then if Mod eq 'IN then 'MAPC else 'MAP else if Action eq 'CONC or Action eq 'JOIN then if Mod eq 'IN then 'MAPCAN else 'MAPCON else if Action eq 'COLLECT then if Mod eq 'IN then 'MAPCAR else 'MAPLIST else StdError BldMsg("%r is an illegal action in ForEach", Action); return list(Fn, Lst, list('FUNCTION, 'LAMBDA . list Var . Body)) end; macro procedure Exit U; %. To leave current Iteration if null cdr U then '(return NIL) else if cddr U then list('return, 'progn . cdr U) else 'return . cdr U; macro procedure Next U; %. Continue Loop '(go !$Loop!$); % no named DO's yet (no DO at all) macro procedure While U; %. Iteration macro % % From RLISP % % Form is (while bool exp1 ... expN) % 'prog . '() . '!$Loop!$ . list('Cond, list(list('not, cadr U), '(return NIL))) . Append(cddr U, '((go !$Loop!$))); macro procedure Repeat U; % % From RLISP % Form is (repeat exp1 ... expN bool) % Repeat until bool is true, similar to Pascal, etc. % 'prog . '() . '!$Loop!$. for each X on cdr U collect if null cdr X then list('Cond, list(list('not, car X),'(go !$Loop!$))) else car X; MACRO PROCEDURE FOR U; % % From RLISP % % Form is (FOR (FROM var init final step) (key form)) %/ Limited right now to key=DO BEGIN SCALAR ACTION,BODY,EXP,INCR,RESULT,TAIL,VAR,X; VAR := second second U; INCR := cddr second U; %(init final step) ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := LIST('DIFFERENCE,first INCR,VAR); IF second INCR NEQ 1 THEN X := LIST('TIMES,second INCR,X); TAIL :='(RETURN NIL); IF NOT ACTION EQ 'DO THEN <<ACTION := GET(ACTION,'BIN); EXP := GENSYM(); BODY := LIST('SETQ,EXP, LIST(CAR ACTION,LIST('SIMP,BODY),EXP)); RESULT := LIST('SETQ,EXP,MKQUOTE CDR ACTION) . RESULT; TAIL := LIST('RETURN, LIST('MK!*SQ,EXP)); EXP := LIST EXP>>; RETURN ('PROG . (VAR . EXP) . NCONC(RESULT, '!$LOOP!$ . LIST('COND,LIST(LIST('MINUSP,X), TAIL)) . BODY . LIST('SETQ,VAR,LIST('PLUS2,VAR,second INCR)) . '((GO !$LOOP!$)) )); END; END; |
Added psl-1983/3-1/kernel/macro.build version [a6ff3d1184].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | % % MACRO.BUILD - Files of macros defined in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL>MACRO.BUILD.2, 2-Feb-83 15:36:40, Edit by PERDUE % Removed char.red. It is now pnk:char-macro.red PathIn "eval-when.red"$ % control evaluation time PathIn "cont-error.red"$ % macro for ContinuableError PathIn "lisp-macros.red"$ % Various macros for readability PathIn "onoff.red"$ % (on xxx yyy) and (off xxx yyy) PathIn "define-smacro.red"$ PathIn "defconst.red"$ PathIn "string-gensym.red"$ PathIn "loop-macros.red"$ % Various macros for readability |
Added psl-1983/3-1/kernel/main.build version [8bc80a2dee].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % % MAIN.BUILD - Definition of entry point routine and symbol table init % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 May 1982 % Copyright (c) 1982 University of Utah % PathIn "main-start.red"$ |
Added psl-1983/3-1/kernel/mini-editor.red version [7fe2597350].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.KERNEL>MINI-EDITOR.RED.3, 21-Sep-82 11:14:10, Edit by BENSON % Flagged internal functions %. PSL Structure Editor Module; %. Adapted By D. Morrison for PSL V1. %. Based on Nordstroms trimmed InterLISP editor %. Cleaned Up and commented by M. L. Griss, %. 8:57pm Monday, 2 November 1981 %. See PH:Editor.Hlp for guide CompileTime flag('(EDIT0 QEDNTH EDCOPY RPLACEALL FINDFIRST XCHANGE XINS), 'InternalFunction); FLUID '(QEDITFNS %. Keep track of which changed !*EXPERT %. Do not print "help" if NIL !*VERBOSE %. Dont do implicit "P" if NIL PROMPTSTRING!* %. For "nicer" interface EditorReader!* %. Use RLISP etc Syntax, ala Break EditorPrinter!* CL ); QEDITFNS:=NIL; !*Expert := NIL; !*Verbose := NIL; lisp procedure EDITF(FN); %. Edit a Copy of Function Body Begin scalar BRFL,X,SAVE,TRFL; %/ Capture !*BREAK, reset to NIL? X := GETD FN; If ATOM X OR CODEP CDR X then StdError BldMsg("%r is not an editable function", Fn); SAVE:=COPY CDR X; EDIT CDR X; If YESP "Change Definition?" then GO TO YES; RPLACW(CDR X,SAVE); %/ Why not Just PUTD again? RETURN NIL; YES: If NULL (FN MEMBER QEDITFNS) then QEDITFNS:=FN.QEDITFNS; RETURN FN; END; lisp procedure EDIT S; %. Edit a Structure, S begin scalar PROMPTSTRING!*; PROMPTSTRING!* := "edit> "; TERPRI(); If NOT !*EXPERT then PRIN2T "Type HELP<CR> for a list of commands."; %/ Savea copy for UNDO? RETURN EDIT0(S,EDITORREADER!* OR 'READ,EDITORPRINTER!* OR 'PRINT) END; lisp procedure EDIT0(S,READER,PRINTER); Begin scalar CL,CTLS,CTL,PLEVEL,TOP,TEMP,X,NNN; TOP:=LIST S; PLEVEL:=3; B: CTL:=TOP; CTLS:=LIST CTL; CL:=CAR TOP; NEXT: If !*VERBOSE then APPLY(PRINTER,LIST EDCOPY(CL,PLEVEL)); X:=APPLY(READER,NIL); If ATOM X then GO TO ATOMX else If NUMBERP CAR X then If CAR X = 0 then GO TO ILLG else If CAR X > 0 then XCHANGE(QEDNTH(CAR X - 1,CL),CTL,CDR X,CAR X) else XINS(QEDNTH(-(CAR X + 1),CL),CTL,CDR X,CAR X) else If CAR X = 'R then RPLACEALL(CADR X,CADDR X,CL) else GO TO ILLG; GO TO NEXT; F: TEMP:=FINDFIRST(APPLY(READER,NIL),CL,CTLS); If NULL TEMP then <<PRIN2T "NOT FOUND"; GO TO NEXT>>; CL:=CAR TEMP; CTLS:=CDR TEMP; CTL:=CAR CTLS; GO TO NEXT; ATOMX: If NUMBERP X then If X = 0 then CL:=CAR CTL else GO TO NUMBX else If X = 'P then !*VERBOSE OR APPLY(PRINTER,LIST EDCOPY(CL,PLEVEL)) else If X = 'OK then RETURN CAR TOP else If X = 'UP then GO TO UP else If X = 'B then BREAK() else If X = 'F then GO TO F else If X = 'PL then PLEVEL:=APPLY(READER,NIL) else If X MEMQ '(HELP !?) then EHELP() else If X EQ 'E then Apply(PRINTER,LIST EVAL Apply(READER,NIL)) else If X = 'T then GO TO B else GO TO ILLG; GO TO NEXT; UP: If CDR CTLS then GO TO UP1; PRIN2T "You are already at the top level"; GO TO NEXT; UP1: CTLS:=CDR CTLS; CTL:=CAR CTLS; CL:=CAR CTL; GO TO NEXT; NUMBX: NNN := X; X:=QEDNTH(ABS(X),CL); If NULL X then << PRIN2T "List empty"; GO TO NEXT >>; If NNN > 0 then CL:=CAR X; CTL:=X; CTLS:=CTL.CTLS; GO TO NEXT; ILLG: PRIN2T "Illegal command"; GO TO NEXT END; lisp procedure QEDNTH(N,L); If ATOM L then NIL else If N > 1 then QEDNTH(N-1,CDR L) else L; lisp procedure EDCOPY(L,N); If ATOM L then L else If N < 0 then "***" else EDCOPY(CAR L,N-1).EDCOPY(CDR L,N); lisp procedure RPLACEALL(A,NEW,S); If ATOM S then NIL else If CAR S = A then RPLACEALL(A,NEW,CDR RPLACA(S,NEW)) else <<RPLACEALL(A,NEW,CAR S); RPLACEALL(A,NEW,CDR S)>>; lisp procedure FINDFIRST(A,S,TRC); %. FIND Occurance of A in S Begin scalar RES; If ATOM S then RETURN NIL; If A MEMBER S then RETURN S. TRC; RETURN(FINDFIRST(A,CAR S,S.TRC) or FINDFIRST(A,CDR S,TRC)); %/ Add a PMAT here END; lisp procedure XCHANGE(S,CTL,NEW,N); If ATOM S then <<PRIN2T "List empty"; NIL>> else If N = 1 then <<RPLACA(CTL,NCONC(NEW,CDR S)); CL:=CAR CTL>> else RPLACD(S,NCONC(NEW,If CDDR S then CDDR S else NIL)); lisp procedure XINS(S,CTL,NEW,N); If ATOM S then <<PRIN2T "List empty"; NIL>> else If N = 1 then <<RPLACA(CTL,NCONC(NEW,S)); CL:=CAR CTL>> else RPLACD(S,NCONC(NEW,CDR S)); UNFLUID '(CL); lisp procedure EHELP; << EvLoad '(Help); DisplayHelpFile 'Editor >>; PUT('EDIT, 'HelpFunction, 'EHELP); PUT('EDITF, 'HelpFunction, 'EHELP); PUT('EDITOR, 'HelpFunction, 'EHELP); END; |
Added psl-1983/3-1/kernel/mini-trace.red version [354ceb5232].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MINI-TRACE.RED - Simple trace and BreakFn package % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>MINI-TRACE.RED.4, 3-May-82 11:26:12, Edit by BENSON % Bug fix in BR.PRC, changed VV to MkQuote VV % Non-Standard Lisp functions used: % PrintF, ErrorPrintF, BldMsg, EqCar, Atsoc, MkQuote, SubSeq % -------- Simple TRACE package ----------- fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure Tr!.Prc(PN, B, A); % Called in place of Traced code % % Called by TRACE for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); VV := Apply(B, A); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, VV); TrSpace!* := TrSpace!* - 1; return VV end; fluid '(!*Comp !*RedefMSG PromptString!*); lisp procedure Tr!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp, !*RedefMSG; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be traced", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Tr!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'TraceCode, cdr GetD Nam); end; lisp procedure UnTr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'TraceCode)) then << ErrorPrintF("*** %r cannot be untraced", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure TR L; %. Trace functions in L list('EvTR, MkQuote cdr L); expr procedure EvTR L; for each X in L do Tr!.1 X; macro procedure UnTr L; %. Untrace Function in L list('EvUnTr, MkQuote cdr L); expr procedure EvUnTr L; for each X in L do UnTr!.1 X; lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); lisp procedure TrClr(); %. Called to setup or fix trace << TrSpace!* := 0; !*NoTrArgs := NIL >>; LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, ErrorForm!*); TrSpace!* := TrSpace!* - 1; return ErrorForm!* end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; for each X in L do Br!.1 X; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; END; |
Added psl-1983/3-1/kernel/nonrec-gc.red version [f4adde00d2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % NONREC-GC.RED - Non-recursive copying 2-space garbage collector for PSL % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 30 November 1981 % Copyright (c) 1981 Eric Benson % % Edit by Cris Perdue, 29 Mar 1983 1256-PST % Removed "LispVar" from initialization of heap-warn-level, % added code in !%Reclaim to swap old and new trap bounds. % Edit by Cris Perdue, 1 Mar 1983 % Removed external declaration of HeapPreviousLast (the only occurrence) % Now using "known-free-space" function and heap-warn-level % Sets HeapTrapped to NIL now. (Value is T iff pre-GC trap has % occurred since last GC.) % <PSL.KERNEL>COPYING-GC.RED.6, 4-Oct-82 17:56:49, Edit by BENSON % Added GCTime!* fluid '(!*GC GCKnt!* GCTime!* Heap!-Warn!-Level % Error if not this many items free after GC ); LoadTime << GCKnt!* := 0; GCTime!* := 0; !*GC := T; Heap!-Warn!-Level := 1000 >>; on SysLisp; CompileTime << syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinOldHeapPointer X; X >= !%chipmunk!-kludge OldHeapLowerBound and X <= !%chipmunk!-kludge OldHeapLast; syslsp smacro procedure Mark X; MkItem(Forward, X); syslsp smacro procedure Marked X; Tag X eq Forward; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; flag('(CopyFromAllBases CopyFromRange CopyFromBase CopyItem CopyItem1 CopyFromNewHeap MarkAndCopyFromID MakeIDFreeList GCStats), 'InternalFunction); >>; external WVar ST, StackLowerBound, BndStkLowerBound, BndStkPtr, HeapLast, HeapLowerBound, HeapUpperBound, OldHeapLast, OldHeapLowerBound, OldHeapUpperBound, HeapTrapBound, OldHeapTrapBound, HeapTrapped; internal WVar StackLast, OldTime, OldSize; syslsp procedure Reclaim(); !%Reclaim(); syslsp procedure !%Reclaim(); begin scalar Tmp1, Tmp2; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; BeforeGCSystemHook(); StackLast := MakeAddressFromStackPointer AdjustStackPointer(ST, -FrameSize()); OldTime := TimC(); OldSize := HeapLast - HeapLowerBound; LispVar GCKnt!* := LispVar GCKnt!* + 1; OldHeapLast := HeapLast; HeapLast := OldHeapLowerBound; Tmp1 := HeapLowerBound; Tmp2 := HeapUpperBound; HeapLowerBound := OldHeapLowerBound; HeapUpperBound := OldHeapUpperBound; OldHeapLowerBound := Tmp1; OldHeapUpperBound := Tmp2; Tmp1 := HeapTrapBound; HeapTrapBound := OldHeapTrapBound; OldHeapTrapBound := Tmp1; CopyFromAllBases(); MakeIDFreeList(); AfterGCSystemHook(); OldTime := TimC() - OldTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, OldTime); if LispVar !*GC then GCStats(); HeapTrapped := NIL; if IntInf Known!-Free!-Space() < IntInf (LispVar Heap!-Warning!-Level) then ContinuableError(99, "Heap space low", NIL) >>; syslsp procedure MarkAndCopyFromID X; % SymNam has to be copied before marking, since the mark destroys the tag % No problem since it's only a string, can't reference itself. << CopyFromBase &SymNam X; MarkID X; CopyFromBase &SymPrp X; CopyFromBase &SymVal X >>; syslsp procedure CopyFromAllBases(); begin scalar LastSymbol, B; MarkAndCopyFromID 128;% Mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkAndCopyFromID I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkAndCopyFromID B >>; B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do CopyFromBase B; for I := StackLowerBound step StackDirection*AddressingUnitsPerItem until StackLast do CopyFromBase I; CopyFromNewHeap(); end; syslsp procedure CopyFromNewHeap(); begin scalar P, Q; P := HeapLowerBound; while P < HeapLast do << Q := @P; case Tag Q of HBYTES: P := &P[StrPack StrLen P]; HHalfWords: P := &P[HalfWordPack HalfWordLen P]; HWRDS: P := &P[WrdPack WrdLen P]; HVECT: NIL; default: @P := CopyItem Q; end; P := &P[1] >>; end; syslsp procedure CopyFromRange(Lo, Hi); begin scalar X, I; X := Lo; I := 0; while X <= Hi do << CopyFromBase X; I := I + 1; X := &Lo[I] >>; end; syslsp procedure CopyFromBase P; @P := CopyItem @P; syslsp procedure CopyItem X; begin scalar Typ, Info, Hdr; Typ := Tag X; if not PointerTagP Typ then return << if Typ = ID and not null X then% don't follow NIL, for speed << Info := IDInf X; if not MarkedID Info then MarkAndCopyFromID Info >>; X >>; Info := Inf X; if not WithinOldHeapPointer Info then return X; Hdr := @Info; if Marked Hdr then return MkItem(Typ, Inf Hdr); return CopyItem1 X; end; syslsp procedure CopyItem1 S;% Copier for GC begin scalar NewS, Len, Ptr, StripS; return case Tag S of PAIR: << Ptr := car S; Rplaca(S, Mark(NewS := GtHeap PairPack())); NewS[1] := cdr S; NewS[0] := Ptr; MkPAIR NewS >>; STR: << @StrInf S := Mark(NewS := CopyString S); NewS >>; VECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := VecItm(StripS, I); MkVEC Ptr >>; EVECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := VecItm(StripS, I); MkItem(EVECT, Ptr) >>; WRDS, FIXN, FLTN, BIGN: << Ptr := Tag S; @Inf S := Mark(NewS := CopyWRDS S); MkItem(Ptr, NewS) >>; default: FatalError "Unexpected tag found during garbage collection"; end; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous;% free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0;% end of free list end; syslsp procedure GCStats(); << ErrorPrintF("*** GC %w: time %d ms, %d recovered, %d free", LispVar GCKnt!*, OldTime, (OldSize - (HeapLast - HeapLowerBound))/AddressingUnitsPerItem, (HeapUpperBound - HeapLast)/AddressingUnitsPerItem) >>; off SysLisp; END; |
Added psl-1983/3-1/kernel/oblist.red version [55ca349791].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OBLIST.RED - Intern, RemOb and friends % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>OBLIST.RED.9, 15-Sep-82 09:35:25, Edit by BENSON % InternP accepts a string as well as a symbol % CopyString and CopyStringToFrom are found in COPIERS.RED CompileTime flag('(AddToObList LookupOrAddToObList InObList InitNewID GenSym1), 'InternalFunction); on SysLisp; internal WConst DeletedSlotValue = -1, EmptySlotValue = 0; CompileTime << syslsp smacro procedure DeletedSlot U; ObArray U eq DeletedSlotValue; syslsp smacro procedure EmptySlot U; ObArray U eq EmptySlotValue; syslsp smacro procedure NextSlot H; if H eq MaxObArray then 0 else H + 1; % StringEqual found in EQUAL.RED syslsp smacro procedure EqualObArrayEntry(ObArrayIndex, S); StringEqual(SymNam ObArray ObArrayIndex, S); >>; syslsp procedure AddToObList U; % % U is an ID, which is added to the oblist if an ID with the same % print name is not already there. The interned ID is returned. % begin scalar V, W, X, Y; W := IDInf U; U := StrInf SymNam W; Y := StrLen U; if Y < 0 then return StdError '"The null string cannot be interned"; if Y eq 0 then return MkID StrByt(U, 0); return if OccupiedSlot(V := InObList U) then MkID ObArray V else << ObArray V := W; X := GtConstSTR Y; CopyStringToFrom(X, U); SymNam W := MkSTR X; MkID W >>; end; syslsp procedure LookupOrAddToObList U; % % U is a String, which IS copied if it is not found on the ObList % The interned ID with U as print name is returned % begin scalar V, W, X, Y; U := StrInf U; Y := StrLen U; if Y < 0 then return StdError '"The null string cannot be interned"; if Y eq 0 then return MkID StrByt(U, 0); return if OccupiedSlot(V := InObList U) then MkID ObArray V else << W := GtID(); % allocate a new ID ObArray V := W; % plant it in the Oblist X := GtConstSTR Y; % allocate a string from uncollected CopyStringToFrom(X, StrInf U); % space InitNewID(W, MkSTR X) >>; end; syslsp procedure NewID S; %. Allocate un-interned ID with print name S InitNewID(GtID(), S); % Doesn't copy S syslsp procedure InitNewID(U, V); % Initialize cells of an ID to defaults << SymNam U := V; U := MkID U; MakeUnBound U; SetProp(U, NIL); MakeFUnBound U; U >>; syslsp procedure HashFunction S; % Compute hash function of string begin scalar Len, HashVal; % Fold together a bunch of bits S := StrInf S; HashVal := 0; % from the first BitsPerWord - 8 Len := StrLen S; % chars of the string if Len > BitsPerWord - 8 then Len := BitsPerWord - 8; for I := 0 step 1 until Len do HashVal := LXOR(HashVal, LSH(StrByt(S, I), (BitsPerWord - 8) - I)); return MOD(HashVal, MaxObArray); end; syslsp procedure InObList U; % U is a string. Returns an ObArray pointer begin scalar H, DSlot, WalkObArray; H := HashFunction U; WalkObArray := H; DSlot := -1; Loop: if EmptySlot WalkObArray then return if DSlot neq -1 then DSlot else WalkObArray else if DeletedSlot WalkObArray and DSlot eq -1 then DSlot := WalkObArray else if EqualObArrayEntry(WalkObArray, U) then return WalkObArray; WalkObArray := NextSlot WalkObArray; if WalkObArray eq H then FatalError "Oblist overflow"; goto Loop; end; syslsp procedure Intern U; %. Add U to ObList % % U is a string or uninterned ID % if IDP U then AddToObList U else if StringP U then LookupOrAddToObList U else TypeError(U, 'Intern, '"ID or string"); syslsp procedure RemOb U; %. REMove id from OBlist begin scalar V; if not IDP U then return NonIDError(U, 'RemOb); V := IDInf U; if V < 128 then return TypeError(U, 'RemOb, '"non-char"); V := SymNam V; return << if OccupiedSlot(V := InObList V) then ObArray V := DeletedSlotValue; U >> end; % Changed to allow a string as well as a symbol, EB, 15 September 1982 syslsp procedure InternP U; %. Is U an interned ID? if IDP U then << U := IDInf U; U < 128 or U eq ObArray InObList SymNam U >> else if StringP U then StrLen StrInf U eq 0 or OccupiedSlot InObList U else NIL; internal WString GenSymPName = "G0000"; syslsp procedure GenSym(); %. GENerate unique, uninterned SYMbol << GenSym1 4; NewID CopyString GenSymPName >>; syslsp procedure GenSym1 N; % Auxiliary function for GenSym begin scalar Ch; return if N > 0 then if (Ch := StrByt(GenSymPName, N)) < char !9 then StrByt(GenSymPName, N) := Ch + 1 else << StrByt(GenSymPName, N) := char !0; GenSym1(N - 1) >> else % start over << StrByt(GenSymPName, 0) := StrByt(GenSymPName, 0) + 1; GenSym1 4 >>; end; syslsp procedure InternGenSym(); %. GENerate unique, interned SYMbol << GenSym1 4; Intern MkSTR GenSymPName >>; syslsp procedure MapObl F; %. Apply F to every interned ID << for I := 0 step 1 until 127 do Apply(F, list MkID I); for I := 0 step 1 until MaxObArray do if OccupiedSlot I then Apply(F, list MkID ObArray I) >>; % These functions provide support for multiple oblists % Cf PACKAGE.RED for their use internal WVar LastObArrayPtr; syslsp procedure GlobalLookup S; % Lookup string S in global oblist if not StringP S then NonStringError(S, 'GlobalLookup) else if OccupiedSlot(LastObArrayPtr := InObList S) then MkID ObArray LastObArrayPtr else '0; syslsp procedure GlobalInstall S; % Add new ID with PName S to oblist begin scalar Ind, PN; Ind := GlobalLookup S; return if Ind neq '0 then Ind else << Ind := GtID(); ObArray LastObArrayPtr := Ind; PN := GtConstSTR StrLen StrInf S; % allocate a string from uncollected CopyStringToFrom(PN, StrInf S); % space InitNewID(Ind, MkSTR PN) >>; end; syslsp procedure GlobalRemove S; % Remove ID with PName S from oblist begin scalar Ind; Ind := GlobalLookup S; return if Ind eq '0 then '0 else << Ind := ObArray LastObArrayPtr; ObArray LastObArrayPtr := DeletedSlotValue; MkID Ind >>; end; syslsp procedure InitObList(); begin scalar Tmp; if_system(MC68000, << % 68000 systems don't clear memory statically for I := 0 step 1 until MaxObArray do ObArray I := EmptySlotValue >>); Tmp := NextSymbol - 1; for I := 128 step 1 until Tmp do ObArray InObList SymNam I := I; end; off SysLisp; StartupTime InitObList(); END; |
Added psl-1983/3-1/kernel/onoff.red version [fd2ab58daf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ONOFF.RED - Macros for setting/resetting flags, with SIMPFG hook % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 July 1982 % Copyright (c) 1982 University of Utah % % ONOFF.RED - ON and OFF for Bare PSL % MLG, from PU:RLISP-PARSER.RED lisp procedure OnOff!*(IdList, U); % % IdList is list of variables without !* prefix, U is T or NIL % begin scalar Y; for each X in IdList do if not IDP X then NonIDError(X, if null U then 'OFF else 'ON) else << Set(MkFlagVar X, U); if (Y := Atsoc(U, get(X, 'SIMPFG))) then Eval second Y >>; end; lisp procedure MkFlagVar U; % Should be redefined in PACKAGE.RED Intern Concat("*", ID2String U); % to lambda-bind current pkg to GLOBAL macro procedure ON U; list('OnOff!*, MkQuote cdr U, T); macro procedure OFF U; list('OnOff!*, MkQuote cdr U, NIL); flag('(ON OFF), 'IGNORE); END; |
Added psl-1983/3-1/kernel/open-close.red version [0662cc734a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OPEN-CLOSE.RED - File primitives % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1700-PST % Close now checks for a legitimate FileDes argument fluid '(SpecialReadFunction!* % These must be set up for special SpecialWriteFunction!* % Open call SpecialCloseFunction!*); on SysLisp; external WArray ReadFunction, % indexed by channel to read a char WriteFunction, % indexed by channel to write a char CloseFunction, % indexed by channel to close channel UnReadBuffer, % indexed by channel for input backup LinePosition, % indexed by channel for Posn() MaxLine; % when to force an end-of-line syslsp procedure Open(FileName, AccessType); %. Get access to file begin scalar FileDes; if AccessType eq 'INPUT then << FileDes := SystemOpenFileForInput FileName; UnReadBuffer[FileDes] := char NULL; WriteFunction[FileDes] := 'ReadOnlyChannel >> else if AccessType eq 'OUTPUT then << FileDes := SystemOpenFileForOutput FileName; LinePosition[FileDes] := 0; MaxLine[FileDes] := 80; ReadFunction[FileDes] := 'WriteOnlyChannel >> else if AccessType eq 'SPECIAL then if IDP LispVar SpecialReadFunction!* and IDP LispVar SpecialWriteFunction!* and IDP LispVar SpecialCloseFunction!* then << FileDes := SystemOpenFileSpecial FileName; LinePosition[FileDes] := 0; MaxLine[FileDes] := 80; UnReadBuffer[FileDes] := char NULL; ReadFunction[FileDes] := IdInf LispVar SpecialReadFunction!*; WriteFunction[FileDes] := IdInf LispVar SpecialWriteFunction!*; CloseFunction[FileDes] := IdInf LispVar SpecialCloseFunction!* >> else IOError "Improperly set-up special IO open call" else IOError "Unknown access type"; return MkINT FileDes; end; syslsp procedure Close FileDes; %. End access to file begin scalar BareFileDes; BareFileDes := IntInf FileDes; if not (0 <= BareFileDes and BareFileDes <= MaxChannels) then NonIOChannelError(FileDes, "Close"); IDApply1(BareFileDes, CloseFunction[BareFileDes]); SystemMarkAsClosedChannel FileDes; ReadFunction[BareFileDes] := 'ChannelNotOpen; WriteFunction[BareFileDes] := 'ChannelNotOpen; CloseFunction[BareFileDes] := 'ChannelNotOpen; return FileDes; end; off SysLisp; END; |
Added psl-1983/3-1/kernel/other-io.red version [87c68be2b7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OTHER-IO.RED - Miscellaneous input and output functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1428-PST % put in Kessler's change so ChannelLineLength allows Len=0 to mean that % EOL is not to be automatically written. % <PSL.KERNEL>OTHER-IO.RED.3, 29-Dec-82 12:23:52, Edit by PERDUE % added LPosn and ChannelLPosn % <PSL.KERNEL>OTHER-IO.RED.2, 17-Sep-82 15:46:38, Edit by BENSON % Added ChannelLinelength, ChannelPosn, ChannelEject, ChannelTerPri % ChannelReadCH, ChannelPrinC % <PSL.INTERP>OTHER-IO.RED.3, 21-Jul-82 00:48:35, Edit by BENSON % Made ReadCh do case conversion for *Raise % Most of the uninteresting I/O functions from the Standard Lisp report global '(OUT!*); % Current output channel fluid '(!*Raise); % controls case conversion of IDs on SysLisp; external WArray LinePosition, % Array indexed by channel MaxLine; % ditto syslsp procedure ChannelEject C; %. Skip to top of next output page << ChannelWriteChar(C, char FF); % write a formfeed NIL >>; syslsp procedure Eject(); %. Skip to top of next output page ChannelEject LispVar OUT!*; syslsp procedure ChannelLineLength(Chn, Len); %. Set maximum line length begin scalar OldLen, StripLen; OldLen := MaxLine[Chn]; if Len then if IntP Len and Len >= 0 then MaxLine[Chn] := Len else StdError BldMsg('"%r is an invalid line length", Len); return OldLen; % if Len is NIL, just return current end; syslsp procedure LineLength Len; %. Set maximum line length ChannelLineLength(LispVar OUT!*, Len); syslsp procedure ChannelPosn Chn; %. Number of characters since last EOL LinePosition[Chn]; syslsp procedure Posn(); %. Number of characters since last EOL ChannelPosn LispVar OUT!*; syslsp procedure ChannelLPosn Chn; %. Number of EOLs since last FF PagePosition[Chn]; syslsp procedure LPosn(); %. Number of EOLs since last FF ChannelLPosn LispVar OUT!*; syslsp procedure ChannelReadCH Chn; %. Read a single character ID begin scalar X; % for Standard Lisp compatibility X := ChannelReadChar Chn; % converts lower to upper when *RAISE if LispVar !*Raise and X >= char lower a and X <= char lower z then X := char A + (X - char lower a); return MkID X; end; syslsp procedure ReadCH(); %. Read a single character ID ChannelReadCH LispVar IN!*; syslsp procedure ChannelTerPri Chn; %. Terminate current output line << ChannelWriteChar(Chn, char EOL); NIL >>; syslsp procedure TerPri(); %. Terminate current output line ChannelTerPri LispVar OUT!*; off SysLisp; LoadTime PutD('PrinC, 'EXPR, cdr GetD 'Prin2); % same definition as Prin2 LoadTime PutD('ChannelPrinC, 'EXPR, cdr GetD 'ChannelPrin2); % same definition as ChannelPrin2 END; |
Added psl-1983/3-1/kernel/others-sl.red version [9f1bef2026].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OTHERS-SL.RED - Random Standard Lisp functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % These are functions that didn't have a logical home % Most could have been defined portably, but were not for efficiency reasons on SysLisp; off R2I; syslsp procedure FixP U; %. Is U an integer? FixP U; on R2I; syslsp procedure Digit U; %. Is U an ID whose print name is a digit? IDP U and (U := IDInf U) >= char !0 and U <= char !9; syslsp procedure Liter U; %. Is U a single character alphabetic ID? IDP U and ((U := IDInf U) >= char A and U <= char Z or U >= char !a and U <= char !z); off SysLisp; CompileTime flag('(Length1), 'InternalFunction); lisp procedure Length U; %. Length of list U Length1(U, 0); lisp procedure Length1(U, N); if PairP U then Length1(cdr U, IAdd1 N) else N; END; |
Added psl-1983/3-1/kernel/p-apply-lap.red version [e5ef19329a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-APPLY-LAP.RED - Inefficient, portable version of APPLY-LAP % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 29 July 1982 % Copyright (c) 1982 University of Utah % % Functions which must be written non-portably: % CodePrimitive % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without distubing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. % CompiledCallingInterpreted % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the ID % in the fluid variable CodeForm!* without disturbing the argument % registers, then finish with % (!*JCALL CompiledCallingInterpretedAux) % (CompiledCallingInterpretedAux may be flagged 'InternalFunction). % FastApply % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). % UndefinedFunction % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. CompileTime << flag('(CompiledCallingInterpretedAuxAux BindEvalAux SaveRegisters), 'InternalFunction); fluid '(CodePtr!* % gets code pointer used by CodePrimitive CodeForm!* % gets fn to be called from code ); >>; on Syslisp; internal WArray CodeArgs[15]; syslsp procedure CodeApply(CodePtr, ArgList); begin scalar I; I := 0; LispVar CodePtr!* := CodePtr; while PairP ArgList and ILessP(I, 15) do << WPutV(CodeArgs , I, first ArgList); I := IAdd1 I; ArgList := rest ArgList >>; if IGEQ(I, 15) then return StdError "Too many arguments to function"; return case I of 0: CodePrimitive(); 1: CodePrimitive WGetV(CodeArgs, 0); 2: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1)); 3: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2)); 4: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3)); 5: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4)); 6: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5)); 7: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6)); 8: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7)); 9: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8)); 10: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9)); 11: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10)); 12: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11)); 13: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12)); 14: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13)); 15: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13), WGetV(CodeArgs, 14)); end; end; %lisp procedure CodeEvalApply(CodePtr, ArgList); % CodeApply(CodePtr, EvLis ArgList); lap '((!*entry CodeEvalApply expr 2) (!*ALLOC 15) (!*LOC (reg 3) (frame 15)) (!*CALL CodeEvalApplyAux) (!*EXIT 15) ); syslsp procedure CodeEvalApplyAux(CodePtr, ArgList, P); begin scalar N; N := 0; while PairP ArgList and ILessP(N, 15) do << WPutV(P, ITimes2(StackDirection, N), Eval first ArgList); ArgList := rest ArgList; N := IAdd1 N >>; if IGEQ(N, 15) then return StdError "Too many arguments to function"; LispVar CodePtr!* := CodePtr; return case N of 0: CodePrimitive(); 1: CodePrimitive WGetV(P, ITimes2(StackDirection, 0)); 2: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1))); 3: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2))); 4: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3))); 5: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4))); 6: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5))); 7: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6))); 8: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7))); 9: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8))); 10: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9))); 11: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10))); 12: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11))); 13: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12))); 14: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13))); 15: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13)), WGetV(P, ITimes2(StackDirection, 14))); end; end; off Syslisp; syslsp procedure BindEval(Formals, Args); BindEvalAux(Formals, Args, 0); syslsp procedure BindEvalAux(Formals, Args, N); begin scalar F, A; return if PairP Formals then if PairP Args then << F := first Formals; A := Eval first Args; N := BindEvalAux(rest Formals, rest Args, IAdd1 N); if N = -1 then -1 else << LBind1(F, A); N >> >> else -1 else if PairP Args then -1 else N; end; syslsp procedure SaveRegisters(A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14, A15); << CodeArgs[14] := A15; CodeArgs[13] := A14; CodeArgs[12] := A13; CodeArgs[11] := A12; CodeArgs[10] := A11; CodeArgs[9] := A10; CodeArgs[8] := A9; CodeArgs[7] := A8; CodeArgs[6] := A7; CodeArgs[5] := A6; CodeArgs[4] := A5; CodeArgs[3] := A4; CodeArgs[2] := A3; CodeArgs[1] := A2; CodeArgs[0] := A1 >>; syslsp procedure CompiledCallingInterpretedAux(); << SaveRegisters(); CompiledCallingInterpretedAuxAux get(LispVar CodeForm!*, '!*LambdaLink) >>; syslsp procedure FastLambdaApply(); << SaveRegisters(); CompiledCallingInterpretedAuxAux LispVar CodeForm!* >>; syslsp procedure CompiledCallingInterpretedAuxAux Fn; if not (PairP Fn and car Fn = 'LAMBDA) then StdError BldMsg("Ill-formed functional expression %r for %r", Fn, LispVar CodeForm!*) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals do << LBind1(car Formals, WGetV(CodeArgs, N)); Formals := cdr Formals; N := IAdd1 N >>; Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off Syslisp; END; |
Added psl-1983/3-1/kernel/printers.red version [79d2e55a7b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PRINTERS.RED - Printing functions for various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PRINTERS.RED.17, 7-Mar-83 11:53:59, Edit by KESSLER % Change Channelwriteblankoreol to check linelength = 0 also. % 03-Mar-83 Nancy Kendzierski % Changed declaration of LispScanTable!* from global to fluid. % Edit by MLGriss, 11:31am Saturday, 5 February 1983 % Fix ChannelWriteBitstring to put out a single 0 if needed % Fixed to handle largest NEGATIVE number correctly % Used to get ------, since -(largest neg) NOT=largestPOS % <PSL.KERNEL>PRINTERS.RED.14, 31-Jan-83 15:45:30, Edit by PERDUE % Fix to printing of EVECTORs % Edit by Cris Perdue, 29 Jan 1983 1620-PST % Removed definition of EVecInf (both compile- and load-time) % Edit by Cris Perdue, 27 Jan 1983 1436-PST % Put in Kessler's change so CheckLineFit won't write EOL if LineLength = 0 % <PSL.KERNEL>PRINTERS.RED.11, 10-Jan-83 13:58:14, Edit by PERDUE % Added some code to handle EVectors, especially to represent OBJECTs % <PSL.KERNEL>PRINTERS.RED.10, 21-Dec-82 15:24:18, Edit by BENSON % Changed order of tests in WriteInteger so that -ive hex #s are done right % <PSL.KERNEL>PRINTERS.RED.9, 4-Oct-82 10:04:34, Edit by BENSON % Added PrinLength and PrinLevel % <PSL.KERNEL>PRINTERS.RED.3, 23-Sep-82 13:16:20, Edit by BENSON % Look for # of args in code pointer, changed : to space in #<...> stuff % <PSL.INTERP>PRINTERS.RED.12, 2-Sep-82 09:01:31, Edit by BENSON % (QUOTE x y) prints correctly, not as 'x % <PSL.INTERP>PRINTERS.RED.11, 4-May-82 20:31:32, Edit by BENSON % Printers keep tags on, for Emode GC % <PSL.VAX-INTERP>PRINTERS.RED.6, 18-Feb-82 16:30:12, Edit by BENSON % Added printer for unbound, changed code to #<Code:xx> % <PSL.VAX-INTERP>PRINTERS.RED.2, 20-Jan-82 02:11:16, Edit by GRISS % fixed prining of zero length vectors % <PSL.VAX-INTERP>PRINTERS.RED.1, 15-Jan-82 14:27:13, Edit by BENSON % Changed for new integer tags % <PSL.INTERP>PRINTERS.RED.13, 7-Jan-82 22:47:40, Edit by BENSON % Made (QUOTE xxx) print as 'xxx % <PSL.INTERP>PRINTERS.RED.12, 5-Jan-82 21:37:41, Edit by BENSON % Changed OBase to OutputBase!* fluid '(OutputBase!* % current output base PrinLength % length of structures to print PrinLevel % level of recursion to print CurrentScanTable!* LispScanTable!* IDEscapeChar!* !*Lower); % print IDs with uppercase chars lowered LoadTime << OutputBase!* := 10; IDEscapeChar!* := 33; % (char !!) CurrentScanTable!* := LispScanTable!* >>; % so TokenTypeOfChar works right on SysLisp; CompileTime << syslsp smacro procedure UpperCaseP Ch; Ch >= char A and Ch <= char Z; syslsp smacro procedure LowerCaseP Ch; Ch >= char !a and Ch <= char !z; syslsp smacro procedure RaiseChar Ch; (Ch - char !a) + char A; syslsp smacro procedure LowerChar Ch; (Ch - char A) + char !a; >>; CompileTime flag('(CheckLineFit WriteNumber1 ChannelWriteBitString), 'InternalFunction); %. Writes EOL first if given Len causes max line length to be exceeded syslsp procedure CheckLineFit(Len, Chn, Fn, Itm); << if (LinePosition[Chn] + Len > MaxLine[Chn]) and (MaxLine[Chn] > 0) then ChannelWriteChar(Chn, char EOL); IDApply2(Chn, Itm, Fn) >>; syslsp procedure ChannelWriteString(Channel, Strng); % % Strng may be tagged or not, but it must have a length field accesible % by StrLen. % begin scalar UpLim; UpLim := StrLen StrInf Strng; for I := 0 step 1 until UpLim do ChannelWriteChar(Channel, StrByt(StrInf Strng, I)); end; syslsp procedure WriteString S; ChannelWriteString(LispVar OUT!*, S); internal WString DigitString = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; internal WString WriteNumberBuffer[40]; syslsp procedure ChannelWriteSysInteger(Channel, Number, Radix); begin scalar Exponent,N1; return if (Exponent := SysPowerOf2P Radix) then ChannelWriteBitString(Channel, Number, Radix - 1, Exponent) else if Number < 0 then << ChannelWriteChar(Channel, char '!-); WriteNumber1(Channel,-(Number/Radix),Radix); % To catch largest NEG ChannelWriteChar(Channel, StrByt(DigitString, - MOD(Number, Radix))) >> else if Number = 0 then ChannelWriteChar(Channel, char !0) else WriteNumber1(Channel, Number, Radix); end; syslsp procedure WriteNumber1(Channel, Number, Radix); if Number = 0 then Channel else << WriteNumber1(Channel, Number / Radix, Radix); ChannelWriteChar(Channel, StrByt(DigitString, MOD(Number, Radix))) >>; syslsp procedure ChannelWriteBitString(Channel, Number, DigitMask, Exponent); if Number = 0 then ChannelWriteChar(Channel,char !0) else ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); syslsp procedure ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); if Number = 0 then Channel % Channel means nothing here else % just trying to fool the compiler << ChannelWriteBitStrAux(Channel, LSH(Number, -Exponent), DigitMask, Exponent); ChannelWriteChar(Channel, StrByt(DigitString, LAND(Number, DigitMask))) >>; syslsp procedure WriteSysInteger(Number, Radix); ChannelWriteSysInteger(LispVar OUT!*, Number, Radix); syslsp procedure ChannelWriteFixnum(Channel, Num); ChannelWriteInteger(Channel, FixVal FixInf Num); syslsp procedure ChannelWriteInteger(Channel, Num); begin scalar CurrentBase; if (CurrentBase := LispVar OutputBase!*) neq 10 then << ChannelWriteSysInteger(Channel, CurrentBase, 10); ChannelWriteChar(Channel, char !#) >>; ChannelWriteSysInteger(Channel, Num, CurrentBase); end; syslsp procedure ChannelWriteSysFloat(Channel, FloatPtr); begin scalar Ch, ChIndex; WriteFloat(WriteNumberBuffer, FloatPtr); ChannelWriteString(Channel, WriteNumberBuffer); end; syslsp procedure ChannelWriteFloat(Channel, LispFloatPtr); ChannelWriteSysFloat(Channel, FloatBase FltInf LispFloatPtr); syslsp procedure ChannelPrintString(Channel, Strng); begin scalar Len, Ch; ChannelWriteChar(Channel, char !"); Len := StrLen StrInf Strng; for I := 0 step 1 until Len do << Ch := StrByt(StrInf Strng, I); if Ch eq char !" then ChannelWriteChar(Channel, char !"); ChannelWriteChar(Channel, Ch) >>; ChannelWriteChar(Channel, char !"); end; syslsp procedure ChannelWriteID(Channel, Itm); if not LispVar !*Lower then ChannelWriteString(Channel, SymNam IDInf Itm) else begin scalar Ch, Len; Itm := StrInf SymNam IDInf Itm; Len := StrLen Itm; for I := 0 step 1 until Len do << Ch := StrByt(Itm, I); if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch) >>; end; syslsp procedure ChannelWriteUnbound(Channel, Itm); << ChannelWriteString(Channel, "#<Unbound:"); ChannelWriteID(Channel, Itm); ChannelWriteChar(Channel, char '!>) >>; syslsp procedure ChannelPrintID(Channel, Itm); begin scalar Len, Ch, TokenType; Itm := StrInf SymNam IDInf Itm; Len := StrLen Itm; Ch := StrByt(Itm, 0); if TokenTypeOfChar Ch neq 10 then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); if not LispVar !*Lower then << ChannelWriteChar(Channel, Ch); for I := 1 step 1 until Len do << Ch := StrByt(Itm, I); TokenType := TokenTypeOfChar Ch; if not (TokenType <= 10 or TokenType eq PLUSSIGN or TokenType eq MINUSSIGN) then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); ChannelWriteChar(Channel, Ch) >> >> else << if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch); for I := 1 step 1 until Len do << Ch := StrByt(Itm, I); TokenType := TokenTypeOfChar Ch; if not (TokenType <= 10 or TokenType eq PLUSSIGN or TokenType eq MINUSSIGN) then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch) >> >> end; syslsp procedure ChannelPrintUnbound(Channel, Itm); << ChannelWriteString(Channel, "#<Unbound "); ChannelPrintID(Channel, Itm); ChannelWriteChar(Channel, char '!>) >>; syslsp procedure ChannelWriteCodePointer(Channel, CP); begin scalar N; CP := CodeInf CP; ChannelWriteString(Channel, "#<Code "); N := !%code!-number!-of!-arguments CP; if N >= 0 and N <= MaxArgs then << ChannelWriteSysInteger(Channel, N, 10); ChannelWriteChar(Channel, char BLANK) >>: ChannelWriteSysInteger(Channel, CP, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); end; syslsp procedure ChannelWriteUnknownItem(Channel, Itm); << ChannelWriteString(Channel, "#<Unknown "); ChannelWriteSysInteger(Channel, Itm, CompressedBinaryRadix); ChannelWriteChar(Channel, char !>) >>; syslsp procedure ChannelWriteBlankOrEOL Channel; << if (LinePosition[Channel] + 1 >= MaxLine[Channel]) and (MaxLine[Channel] > 0) then ChannelWriteChar(Channel, char EOL) else ChannelWriteChar(Channel, char ! ) >>; syslsp procedure ChannelWritePair(Channel, Itm, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar N; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char !( ); if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then << RecursiveChannelPrin2(Channel, car Itm, Level); N := 2; Itm := cdr Itm; while PairP Itm and (not IntP LispVar PrinLength or N <= LispVar PrinLength) do << ChannelWriteBlankOrEOL Channel; RecursiveChannelPrin2(Channel, car Itm, Level); N := N + 1; Itm := cdr Itm >>; if PairP Itm then CheckLineFit(3, Channel, 'ChannelWriteString, " ...") else if Itm then << CheckLineFit(3, Channel, 'ChannelWriteString, " . "); RecursiveChannelPrin2(Channel, Itm, Level) >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char !) ); end; syslsp procedure ChannelPrintPair(Channel, Itm, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar N; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char !( ); if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then << RecursiveChannelPrin1(Channel, car Itm, Level); N := 2; Itm := cdr Itm; while PairP Itm and (not IntP LispVar PrinLength or N <= LispVar PrinLength) do << ChannelWriteBlankOrEOL Channel; RecursiveChannelPrin1(Channel, car Itm, Level); N := N + 1; Itm := cdr Itm >>; if PairP Itm then CheckLineFit(3, Channel, 'ChannelWriteString, " ...") else if Itm then << CheckLineFit(3, Channel, 'ChannelWriteString, " . "); RecursiveChannelPrin1(Channel, Itm, Level) >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char !) ); end; syslsp procedure ChannelWriteVector(Channel, Vec, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar Len, I; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ ); Len := VecLen VecInf Vec; If Len<0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << RecursiveChannelPrin2(Channel, VecItm(VecInf Vec, I), Level); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); end; syslsp procedure ChannelPrintVector(Channel, Vec, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar Len, I; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ ); Len := VecLen VecInf Vec; If Len<0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << RecursiveChannelPrin1(Channel, VecItm(VecInf Vec, I), Level); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); end; syslsp procedure ChannelWriteEVector(Channel, EVec, Level); begin scalar handler; if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else if getd('object!-get!-handler!-quietly) and (handler := object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then apply(handler, list(EVec, Channel, Level, NIL)) else << ChannelWriteString(Channel, "#<EVector "); ChannelWriteSysInteger(Channel, EVecInf EVec, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); >>; end; syslsp procedure ChannelPrintEVector(Channel, EVec, Level); begin scalar handler; if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else if getd('object!-get!-handler!-quietly) and (handler := object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then apply(handler, list(EVec, Channel, Level, T)) else << ChannelWriteString(Channel, "#<EVector "); ChannelWriteSysInteger(Channel, EVecInf EVec, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); >>; end; syslsp procedure ChannelWriteWords(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Words:"); Len := WrdLen WrdInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, WrdItm(WrdInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelWriteHalfWords(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Halfwords:"); Len := HalfWordLen HalfWordInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, HalfWordItm(HalfWordInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelWriteBytes(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Bytes:"); Len := StrLen StrInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, StrByt(StrInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelPrin2(Channel, Itm); %. Display Itm on Channel RecursiveChannelPrin2(Channel, Itm, 0); syslsp procedure RecursiveChannelPrin2(Channel, Itm, Level); << case Tag Itm of PosInt, NegInt: CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm); ID: CheckLineFit(StrLen StrInf SymNam IDInf Itm + 1, Channel, 'ChannelWriteID, Itm); UNBOUND: CheckLineFit(StrLen StrInf SymNam IDInf Itm + 12, Channel, 'ChannelWriteUnbound, Itm); STR: CheckLineFit(StrLen StrInf Itm + 1, Channel, 'ChannelWriteString, Itm); CODE: CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm); FIXN: CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm); FLTN: CheckLineFit(30, Channel, 'ChannelWriteFloat, Itm); WRDS: ChannelWriteWords(Channel, Itm); Halfwords: ChannelWriteHalfWords(Channel, Itm); Bytes: ChannelWriteBytes(Channel, Itm); PAIR: ChannelWritePair(Channel, Itm, Level); VECT: ChannelWriteVector(Channel, Itm, Level); EVECT: ChannelWriteEVector(Channel, Itm, Level); default: CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm) end; Itm >>; syslsp procedure Prin2 Itm; %. ChannelPrin2 to current channel ChannelPrin2(LispVar OUT!*, Itm); syslsp procedure ChannelPrin1(Channel, Itm); %. Display Itm in READable form RecursiveChannelPrin1(Channel, Itm, 0); syslsp procedure RecursiveChannelPrin1(Channel, Itm, Level); << case Tag Itm of PosInt, NegInt: CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm); ID: % leave room for possible escape chars CheckLineFit(StrLen StrInf SymNam IDInf Itm + 5, Channel, 'ChannelPrintID, Itm); UNBOUND: % leave room for possible escape chars CheckLineFit(StrLen StrInf SymNam IDInf Itm + 16, Channel, 'ChannelPrintUnbound, Itm); STR: CheckLineFit(StrLen StrInf Itm + 4, Channel, 'ChannelPrintString, Itm); CODE: CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm); FIXN: CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm); FLTN: CheckLineFit(20, Channel, 'ChannelWriteFloat, Itm); WRDS: ChannelWriteWords(Channel, Itm); Halfwords: ChannelWriteHalfWords(Channel, Itm); Bytes: ChannelWriteBytes(Channel, Itm); PAIR: ChannelPrintPair(Channel, Itm, Level); VECT: ChannelPrintVector(Channel, Itm, Level); EVECT: ChannelPrintEVector(Channel, Itm, Level); default: CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm) end; Itm >>; syslsp procedure Prin1 Itm; %. ChannelPrin1 to current output ChannelPrin1(LispVar OUT!*, Itm); off SysLisp; END; |
Added psl-1983/3-1/kernel/printf.red version [6cabfaa7cf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PRINTF.RED - Formatted print routine % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PRINTF.RED.2, 17-Sep-82 16:01:01, Edit by BENSON % Added ChannelPrintF % <PSL.INTERP>PRINTF.RED.6, 3-May-82 10:45:11, Edit by BENSON % %L prints nothing for NIL % <PSL.INTERP>PRINTF.RED.9, 23-Feb-82 21:40:31, Edit by BENSON % Added %x for hex % <PSL.INTERP>PRINTF.RED.7, 1-Dec-81 16:11:11, Edit by BENSON % Changed to cause error for unknown character CompileTime flag('(PrintF1 PrintF2), 'InternalFunction); fluid '(FormatForPrintF!*); % First, lambda-bind FormatForPrintF!* lisp procedure PrintF(FormatForPrintF!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14); PrintF1(FormatForPrintF!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14); % Then, push all the registers on the stack and set up a pointer to them lap '((!*entry PrintF1 expr 15) (!*PUSH (reg 2)) (!*LOC (reg 1) (frame 1)) (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*CALL PrintF2) (!*EXIT 14) ); on SysLisp; % Finally, actual printf, with 1 argument, pointer to array of parameters syslsp procedure PrintF2 PrintFArgs; %. Formatted print % % Format is a string, either in the heap or not, whose characters will be % written on the currently selected output channel. The exception to this is % that when a % is encountered, the following character is interpreted as a % format character, to decide how to print one of the other arguments. The % following format characters are currently supported: % %b - blanks; take the next argument as integer and print that many % blanks % %c - print the next argument as a single character % %d - print the next argument as a decimal integer % %e - EVALs the next argument for side-effect -- most useful if the % thing EVALed does some printing % %f - fresh-line, print end-of-line char if not at beginning of line % %l - same as %w, except lists are printed without top level parens % %n - print end-of-line character % %o - print the next argument as an octal integer % %p - print the next argument as a Lisp item, using Prin1 % %r - print the next argument as a Lisp item, using ErrPrin (`FOO') % %s - print the next argument as a string % %t - tab; take the next argument as an integer and % print spaces to that column % %w - print the next argument as a Lisp item, using Prin2 % %x - print the next argument as a hexidecimal integer % %% - print a % % % If the character is not one of these (either upper or lower case), then an % error occurs. % begin scalar UpLim, I, Ch, UpCh; UpLim := StrLen StrInf LispVar FormatForPrintF!*; I := 0; while I <= UpLim do << Ch := StrByt(StrInf LispVar FormatForPrintF!*, I); if Ch neq char !% then WriteChar Ch else begin I := I + 1; Ch := StrByt(StrInf LispVar FormatForPrintF!*, I); UpCh := if LowerCaseChar Ch then RaiseChar Ch else Ch; case UpCh of char B: << Spaces @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char C: << WriteChar @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char D: << WriteSysInteger(@PrintFArgs, 10); PrintFArgs := &PrintFArgs[StackDirection] >>; char E: << Eval @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char F: if Posn() > 0 then WriteChar char EOL; char L: << Prin2L @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char N: WriteChar char EOL; char O: << WriteSysInteger(@PrintFArgs, 8); PrintFArgs := &PrintFArgs[StackDirection] >>; char X: << WriteSysInteger(@PrintFArgs, 16); PrintFArgs := &PrintFArgs[StackDirection] >>; char P: << Prin1 @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char R: << ErrPrin @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char S: << WriteString @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char T: << Tab @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char W: << Prin2 @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char !%: WriteChar char !%; default: StdError BldMsg('"Unknown character code for PrintF: %r", MkID Ch); end; end; I := I + 1 >>; end; syslsp procedure ErrorPrintF(Format, A1, A2, A3, A4); % also A5..A14 begin scalar SaveChannel; SaveChannel := WRS LispVar ErrOut!*; if LinePosition[IntInf LispVar ErrOut!*] > 0 then TerPri(); PrintF(Format, A1, A2, A3, A4); if LinePosition[IntInf LispVar ErrOut!*] > 0 then TerPri(); WRS SaveChannel; end; syslsp procedure ToStringWriteChar(Channel, Ch); % shares TokenBuffer << if TokenBuffer[0] >= MaxTokenSize - 1 then << TokenBuffer[0] := 80; % truncate to 80 chars StrByt(TokenBuffer, 80) := char NULL; StdError list('"Buffer overflow while constructing error message:", LispVar FormatForPrintF!*, '"The truncated result was:", CopyString MkSTR TokenBuffer) >> else << TokenBuffer[0] := TokenBuffer[0] + 1; StrByt(TokenBuffer, TokenBuffer[0]) := Ch >> >>; syslsp procedure BldMsg(Format, Args1, Args2, Args3, Args4); %. Print to string begin scalar TempChannel; % takes up to 14 args LinePosition[2] := 0; TokenBuffer[0] := -1; TempChannel := LispVar OUT!*; LispVar OUT!* := '2; PrintF(Format, Args1, Args2, Args3, Args4); StrByt(TokenBuffer, TokenBuffer[0] + 1) := char NULL; LispVar OUT!* := TempChannel; return CopyString TokenBuffer; end; syslsp procedure ErrPrin U; %. `Prin1 with quotes' << WriteChar char !`; Prin1 U; WriteChar char !' >>; off SysLisp; lisp procedure Prin2L Itm; %. Prin2 without top-level parens if null Itm then NIL % NIL is (), print nothing else if not PairP Itm then Prin2 Itm else << while << Prin2 car Itm; Itm := cdr Itm; PairP Itm >> do ChannelWriteBlankOrEOL OUT!*; if Itm then << ChannelWriteBlankOrEOL OUT!*; Prin2 Itm >> >>; syslsp procedure ChannelPrintF(OUT!*, Format, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); PrintF(Format, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); END; |
Added psl-1983/3-1/kernel/prog-and-friends.red version [df6c762d15].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROG-AND-FRIENDS.RED - PROG, GO, and RETURN % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PROG-AND-FRIENDS.RED.2, 11-Oct-82 17:55:57, Edit by BENSON % Changed CATCH/THROW to *CATCH/*THROW % Error numbers: % 3000 - Unknown label % 3100 - outside the scope of a PROG % +1 in GO % +2 in RETURN fluid '(ProgJumpTable!* % A-List of labels and expressions ProgBody!*); % Tail of the current PROG fexpr procedure Prog ProgBody!*; %. Program feature function begin scalar ProgJumpTable!*, N, Result; if not PairP ProgBody!* then return NIL; N := 0; for each X in car ProgBody!* do << PBind1 X; N := N + 1 >>; ProgBody!* := cdr ProgBody!*; for each X on ProgBody!* do if IDP car X then ProgJumpTable!* := X . ProgJumpTable!*; while << while PairP ProgBody!* and IDP car ProgBody!* do ProgBody!* := cdr ProgBody!*; % skip over labels PairP ProgBody!* >> do % eval the expression << Result := !*Catch('!$Prog!$, Eval car ProgBody!*); if not ThrowSignal!* then << Result := NIL; ProgBody!* := cdr ProgBody!* >> >>; UnBindN N; return Result; end; lisp fexpr procedure GO U; %. Goto label within PROG begin scalar NewProgBody; return if ProgBody!* then << NewProgBody := Atsoc(car U, ProgJumpTable!*); if null NewProgBody then ContinuableError(3001, BldMsg( "%r is not a label within the current scope", car U), 'GO . U) else << ProgBody!* := NewProgBody; !*Throw('!$Prog!$, NIL) >> >> else ContinuableError(3101, "GO attempted outside the scope of a PROG", 'GO . U); end; lisp procedure Return U; %. Return value from PROG if ProgBody!* then << ProgBody!* := NIL; !*Throw('!$Prog!$, U) >> else ContError(3102, "RETURN attempted outside the scope of a PROG", Return U); END; |
Added psl-1983/3-1/kernel/prop.build version [a60f14ce3d].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % PROP.BUILD - Files with functions for property lists and function definition % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "function-primitives.red"$ % used by PutD, GetD and Eval PathIn "property-list.red"$ % PUT and FLAG and friends PathIn "fluid-global.red"$ % variable declarations PathIn "putd-getd.red"$ % function defining functions |
Added psl-1983/3-1/kernel/property-list.red version [7e5b9b2d7c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROPERTY-LIST.RED - Functions dealing with property lists % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>PROPERTY-LIST.RED.11, 1-Mar-82 14:09:20, Edit by BENSON % Changed "move-to-front" to "exchange-with-previous" % <PSL.INTERP>PROPERTY-LIST.RED.7, 27-Feb-82 12:43:27, Edit by BENSON % Optimized GET and FLAGP, rearranges property list % Every ID in the system has a property list. It is obtained by the function % PROP(ID) and updated with the function SETPROP(ID, PLIST). These functions % are not in the Standard Lisp report, and are not intended for use in user % programs. A property list (whose format should also not be known to % user programs) is a list of IDs and dotted pairs (A-List entries). The % pairs are used by PUT and GET, and the IDs are used by FLAG and FLAGP. % Non-Standard Lisp functions used: % DELQIP -- EQ, destructive version of Delete (in EASY-NON-SL.RED) % ATSOC -- EQ version of ASSOC (in EASY-NON-SL.RED) % DELATQIP -- EQ, destructive version of DELASC (in EASY-NON-SL.RED) % EQCAR(A,B) -- PairP A and car A eq B (in EASY-NON-SL.RED) % NonIDError -- in TYPE-ERRORS.RED on SysLisp; syslsp procedure Prop U; %. Access property list of U if IDP U then SymPrp IDInf U else NonIDError(U, 'Prop); syslsp procedure SetProp(U, L); %. Store L as property list of U if IDP U then SymPrp IDInf U := L else NonIDError(U, 'SetProp); syslsp procedure FlagP(U, Indicator); %. Is U marked with Indicator? if not IDP U or not IDP Indicator then NIL else begin scalar PL, PreviousPointer; PL := SymPrp IDInf U; if null PL then return NIL; if car PL eq Indicator then return T; PreviousPointer := PL; PL := cdr PL; Loop: if null PL then return NIL; if car PL eq Indicator then return << Rplaca(PL, car PreviousPointer); Rplaca(PreviousPointer, Indicator); T >>; PreviousPointer := PL; PL := cdr PL; goto Loop; end; on FastLinks; syslsp procedure GetFnType U; get(U, 'TYPE); off FastLinks; syslsp procedure Get(U, Indicator); %. Retrieve value stored for U with Ind if not IDP U or not IDP Indicator then NIL else begin scalar PL, X, PreviousPointer; PL := SymPrp IDInf U; if null PL then return NIL; X := car PL; if PairP X and car X eq Indicator then return cdr X; PreviousPointer := PL; PL := cdr PL; Loop: if null PL then return NIL; X := car PL; if PairP X and car X eq Indicator then return << Rplaca(PL, car PreviousPointer); Rplaca(PreviousPointer, X); cdr X >>; PreviousPointer := PL; PL := cdr PL; goto Loop; end; off SysLisp; lisp procedure Flag(IDList, Indicator); %. Mark all in IDList with Indicator if not IDP Indicator then NonIDError(Indicator, 'Flag) else for each U in IDList do Flag1(U, Indicator); lisp procedure Flag1(U, Indicator); if not IDP U then NonIDError(U, 'Flag) else begin scalar PL; PL := Prop U; if not (Indicator memq PL) then SetProp(U, Indicator . PL); end; lisp procedure RemFlag(IDList, Indicator); %. Remove marking of all in IDList if not IDP Indicator then NonIDError(Indicator, 'RemFlag) else for each U in IDList do RemFlag1(U, Indicator); lisp procedure RemFlag1(U, Indicator); if not IDP U then NonIDError(U, 'RemFlag) else SetProp(U, DelQIP(Indicator, Prop U)); lisp procedure Put(U, Indicator, Val); %. Store Val in U with Indicator if not IDP U then NonIDError(U, 'Put) else if not IDP Indicator then NonIDError(Indicator, 'Put) else begin scalar PL, V; PL := Prop U; if not (V := Atsoc(Indicator, PL)) then SetProp(U, (Indicator . Val) . PL) else RPlacD(V, Val); return Val; end; lisp procedure RemProp(U, Indicator); %. Remove value of U with Indicator if not IDP U or not IDP Indicator then NIL else begin scalar V; if (V := get(U, Indicator)) then SetProp(U, DelAtQIP(Indicator, Prop U)); return V; end; lisp procedure RemPropL(L, Indicator); %. RemProp for all IDs in L for each X in L do RemProp(X, Indicator); END; |
Added psl-1983/3-1/kernel/putd-getd.red version [f6a032b80f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PUTD-GETD.RED - Standard Lisp function defining functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PUTD-GETD.RED.3, 13-Jan-83 19:09:47, Edit by PERDUE % Removed obsolete code from PUTD in response to Bobbie Othmer's bug report % <PSL.KERNEL>PUTD-GETD.RED.2, 24-Sep-82 15:01:38, Edit by BENSON % Added CODE-NUMBER-OF-ARGUMENTS % <PSL.INTERP>PUTD-GETD.RED.3, 19-Apr-82 13:10:57, Edit by BENSON % Function in PutD may be an ID % <PSL.INTERP>PUTD-GETD.RED.4, 6-Jan-82 19:18:47, Edit by GRISS % Add NEXPR % DE, DF and DM are defined in EASY-SL.RED % If the function is interpreted, the lambda form will be found by % GET(ID, '!*LambdaLink). % If the type of a function is other than EXPR (i.e. FEXPR or MACRO or NEXPR), % this will be indicated by GET(ID, 'TYPE) = 'FEXPR or 'MACRO or 'NEXPR % PutD makes use of the fact that FLUID and GLOBAL declarations use the % property list indicator TYPE % Non-Standard Lisp functions used: % function cell primitives FUnBoundP, etc. found in FUNCTION-PRIMITVES.RED % CompD -- in COMPILER.RED % ErrorPrintF, VerboseTypeError, BldMsg % Error numbers: % 1100 - ill-formed function expression % 1300 - unknown function type % +5 in GetD lisp procedure GetD U; %. Lookup function definition of U IDP U and not FUnBoundP U and ((get(U, 'TYPE) or 'EXPR) . (if FLambdaLinkP U then get(U, '!*LambdaLink) else GetFCodePointer U)); lisp procedure RemD U; %. Remove function definition of U begin scalar OldGetD; if (OldGetD := GetD U) then << MakeFUnBound U; RemProp(U, 'TYPE); RemProp(U, '!*LambdaLink) >>; return OldGetD; end; fluid '(!*RedefMSG % controls printing of redefined !*UserMode); % controls query for redefinition LoadTime << !*UserMode := NIL; % start in system mode !*RedefMSG := T >>; % message in PutD fluid '(!*Comp % controls automatic compilation PromptString!*); lisp procedure PutD(FnName, FnType, FnExp); %. Install function definition % % this differs from the SL Report in 2 ways: % - function names flagged LOSE are not defined. % - " " which are already fluid or global are defined anyway, % with a warning. % if not IDP FnName then NonIDError(FnName, 'PutD) else if not (FnType memq '(EXPR FEXPR MACRO NEXPR)) then ContError(1305, "%r is not a legal function type", FnType, PutD(FnName, FnType, FnExp)) else if FlagP(FnName, 'LOSE) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", FnName); NIL >> else begin scalar VarType, PrintRedefinedMessage, OldIN, PromptString!*, QueryResponse; if not FUnBoundP FnName then << if !*RedefMSG then PrintRedefinedMessage := T; if !*UserMode and not FlagP(FnName, 'USER) then if not YesP BldMsg( "Do you really want to redefine the system function %r?", FnName) then return NIL else Flag1(FnName, 'USER) >>; if CodeP FnExp then << MakeFCode(FnName, FnExp); RemProp(FnName, '!*LambdaLink) >> else if IDP FnExp and not FUnBoundP FnExp then return PutD(FnName, FnType, cdr GetD FnExp) else if !*Comp then return CompD(FnName, FnType, FnExp) else if EqCar(FnExp, 'LAMBDA) then << put(FnName, '!*LambdaLink, FnExp); MakeFLambdaLink FnName >> else return ContError(1105, "Ill-formed function expression in PutD", PutD(FnName, FnType, FnExp)); if FnType neq 'EXPR then put(FnName, 'TYPE, FnType) else RemProp(FnName, 'TYPE); if !*UserMode then Flag1(FnName, 'USER) else RemFlag1(FnName, 'USER); if PrintRedefinedMessage then ErrorPrintF("*** Function %r has been redefined", FnName); return FnName; end; on Syslisp; syslsp procedure code!-number!-of!-arguments cp; begin scalar n; return if codep cp then << n := !%code!-number!-of!-arguments CodeInf cp; if n >= 0 and n <= MaxArgs then n >>; end; END; |
Added psl-1983/3-1/kernel/randm.build version [2886244a8f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % % RANDM.BUILD - Miscellaneous interpreter files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "known-to-comp-sl.red"$ % SL functions performed inline in code PathIn "others-sl.red"$ % DIGIT, LITER and LENGTH PathIn "equal.red"$ % equality predicates PathIn "carcdr.red"$ % CDDDDR, etc. PathIn "easy-sl.red"$ % highly portable SL function defns PathIn "easy-non-sl.red"$ % simple, ubiquitous SL extensions PathIn "sets.red"$ % Set manipulation functions |
Added psl-1983/3-1/kernel/rds-wrs.red version [840f5c074c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RDS-WRS.RED - Switch the current input or output channel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % global '(SpecialRDSAction!* % possibly apply to old and new channel SpecialWRSAction!* % ditto IN!* % Current input channel OUT!*); % Current output channel fluid '(StdIN!* % Standard input - may be rebound StdOUT!*); % Standard output - may be rebound on SysLisp; syslsp procedure RDS Channel; %. Switch input channels, return old begin scalar OldIN, ReadFn; if LispVar SpecialRDSAction!* then Apply(LispVar SpecialRDSAction!*, list(LispVar IN!*, Channel)); OldIN := LispVar IN!*; if null Channel then Channel := LispVar StdIN!*; ReadFn := ReadFunction[IntInf Channel]; if ReadFn eq 'ChannelNotOpen or ReadFn eq 'WriteOnlyChannel then return ChannelError(Channel, "Channel not open for input in RDS"); LispVar IN!* := Channel; return OldIN; end; syslsp procedure WRS Channel; %. Switch output channels, return old begin scalar OldOUT, WriteFn; if LispVar SpecialWRSAction!* then Apply(LispVar SpecialWRSAction!*, list(LispVar OUT!*, Channel)); OldOUT := LispVar OUT!*; if null Channel then Channel := LispVar StdOUT!*; WriteFn := WriteFunction[IntInf Channel]; if WriteFn eq 'ChannelNotOpen or WriteFn eq 'ReadOnlyChannel then return ChannelError(Channel, "Channel not open for output in WRS"); LispVar OUT!* := Channel; return OldOUT; end; off SysLisp; END; |
Added psl-1983/3-1/kernel/read.red version [8e1377de6c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % READ.RED - S-expression parser % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % 03-Mar-83 Nancy Kendzierski % Changed declaration of LispScanTable!* from global to fluid. % <PSL.KERNEL>READ.RED.6, 20-Oct-82 11:07:28, Edit by BENSON % Extra right paren in file only prints warning, not error % <PSL.KERNEL>READ.RED.5, 6-Oct-82 11:37:33, Edit by BENSON % Took away CATCH in READ, EOF error binds *InsideStructureRead to NIL % <PSL.KERNEL>READ.RED.2, 20-Sep-82 11:24:32, Edit by BENSON % Right parens at top level cause an error in a file % <PSL.INTERP>READ.RED.6, 2-Sep-82 14:07:37, Edit by BENSON % Right parens are ignored at the top level fluid '(CurrentReadMacroIndicator!* % Get to find read macro function CurrentScanTable!* % vector of character types LispScanTable!* % CurrentScanTable!* when READing !*InsideStructureRead); % indicates within compound read global '(TokType!* % Set by token scanner, type of token IN!* % Current input channel !$EOF!$); % has value returned when EOF is read CurrentReadMacroIndicator!* := 'LispReadMacro; CompileTime flag('(DotContextError), 'InternalFunction); lisp procedure ChannelReadTokenWithHooks Channel; % Scan token w/read macros % % This is ReadToken with hooks for read macros % begin scalar Tkn, Fn; Tkn := ChannelReadToken Channel; if TokType!* eq 3 and (Fn := get(Tkn, CurrentReadMacroIndicator!*)) then return IDApply2(Channel, Tkn, Fn); return Tkn; end; lisp procedure ChannelRead Channel; %. Parse S-expression from channel begin scalar CurrentScanTable!*, CurrentReadMacroIndicator!*; CurrentScanTable!* := LispScanTable!*; CurrentReadMacroIndicator!* := 'LispReadMacro; return ChannelReadTokenWithHooks Channel; end; lisp procedure Read(); %. Parse S-expr from current input << MakeInputAvailable(); ChannelRead IN!* >>; lisp procedure ChannelReadEof(Channel, Ef); % Handle end-of-file in Read if !*InsideStructureRead then return begin scalar !*InsideStructureRead; return StdError BldMsg("Unexpected EOF while reading on channel %r", Channel); end else !$EOF!$; lisp procedure ChannelReadQuotedExpression(Channel, Qt); % read macro ' MkQuote ChannelReadTokenWithHooks Channel; lisp procedure ChannelReadListOrDottedPair(Channel, Pa); % read macro ( % % Read list or dotted pair. Collect items until closing right paren. % Check for dot context errors. % begin scalar Elem, StartPointer, EndPointer, !*InsideStructureRead; !*InsideStructureRead := T; Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 then if Elem eq '!. then return DotContextError() else if Elem eq '!) then return NIL; StartPointer := EndPointer := list Elem; LoopBegin: Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 then if Elem eq '!) then return StartPointer else if Elem eq '!. then << Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 and (Elem eq '!) or Elem eq '!.) then return DotContextError() else << RplacD(EndPointer, Elem); Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 and Elem eq '!) then return StartPointer else return DotContextError() >> >>; % If we had splice macros, I think they would be checked here RplacD(EndPointer, list Elem); EndPointer := cdr EndPointer; goto LoopBegin; end; lisp procedure ChannelReadRightParen(Channel, Tok); % Ignore right parens at the top if !*InsideStructureRead then Tok else << if not (Channel eq StdIN!*) then % if not reading from the terminal ErrorPrintF "*** Unmatched right parenthesis"; ChannelReadTokenWithHooks Channel >>; lisp procedure DotContextError(); % Parsing error IOError "Dot context error"; % List2Vector is found in TYPE-CONVERSIONS.RED lisp procedure ChannelReadVector Channel; % read macro [ begin scalar Elem, StartPointer, EndPointer, !*InsideStructureRead; !*InsideStructureRead := T; StartPointer := EndPointer := (NIL . NIL); while << Elem := ChannelReadTokenWithHooks Channel; TokType!* neq 3 or Elem neq '!] >> do << RplacD(EndPointer, list Elem); EndPointer := cdr EndPointer >>; return List2Vector cdr StartPointer; end; StartupTime << put('!', 'LispReadMacro, function ChannelReadQuotedExpression); put('!( , 'LispReadMacro, function ChannelReadListOrDottedPair); put('!) , 'LispReadMacro, function ChannelReadRightParen); put('![, 'LispReadMacro, function ChannelReadVector); put(MkID char EOF, 'LispReadMacro, function ChannelReadEOF); >>; END; |
Added psl-1983/3-1/kernel/sequence.red version [7bdb8b0d0a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SEQUENCE.RED - Useful functions on strings, vectors and lists % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>SEQUENCE.RED.2, 25-Jan-83 16:11:28, Edit by PERDUE % Removed Make-String, etc., moved to cons-mkvect.red % STRINGS pkg defines Make-String (differently and Common LISP compatibly) % <PSL.INTERP>SEQUENCE.RED.2, 27-Feb-82 00:46:03, Edit by BENSON % Started adding more vector types % <PSL.INTERP>STRING-OPS.RED.11, 6-Jan-82 20:41:16, Edit by BENSON % Changed String and Vector into Nexprs on SysLisp; % Indexing operations syslsp procedure Indx(R1, R2); %. Element of sequence begin scalar Tmp1, Tmp2; if not PosIntP R2 then return IndexError(R2, 'Indx); % Subscript Tmp1 := Inf R1; Tmp2 := Tag R1; return case Tmp2 of Str, Bytes: if R2 > StrLen Tmp1 then RangeError(R1, R2, 'Indx) else StrByt(Tmp1, R2); Vect: if R2 > VecLen Tmp1 then RangeError(R1, R2, 'Indx) else VecItm(Tmp1, R2); Wrds: if R2 > WrdLen Tmp1 then RangeError(R1, R2, 'Indx) else WrdItm(Tmp1, R2); HalfWords: if R2 > HalfWordLen Tmp1 then RangeError(R1, R2, 'Indx) else HalfWordItm(Tmp1, R2); Pair: << Tmp2 := R2; while Tmp2 > 0 do << R1 := cdr R1; if atom R1 then RangeError(R1, R2, 'Indx); Tmp2 := Tmp2 - 1 >>; car R1 >>; default: NonSequenceError(R1, 'Indx); end; end; syslsp procedure SetIndx(R1, R2, R3); %. Store at index of sequence begin scalar Tmp1, Tmp2; if not PosIntP R2 then return IndexError(R2, 'SetIndx); % Subscript Tmp1 := Inf R1; Tmp2 := Tag R1; return case Tmp2 of Str, Bytes: if R2 > StrLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << StrByt(Tmp1, R2) := R3; R3 >>; Vect: if R2 > VecLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << VecItm(Tmp1, R2) := R3; R3 >>; Wrds: if R2 > WrdLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << WrdItm(Tmp1, R2) := R3; R3 >>; HalfWords: if R2 > HalfWordLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << HalfWordItm(Tmp1, R2) := R3; R3 >>; Pair: << Tmp2 := R2; while Tmp2 > 0 do << R1 := cdr R1; if atom R1 then RangeError(R1, R2, 'SetIndx); Tmp2 := Tmp2 - 1 >>; Rplaca(R1, R3); R3 >>; default: NonSequenceError(R1, 'SetIndx); end; end; % String and vector sub-part operations. syslsp procedure Sub(R1, R2, R3); %. Obsolete subsequence function SubSeq(R1, R2, R2 + R3 + 1); syslsp procedure SubSeq(R1, R2, R3); % R2 is lower bound, R3 upper begin scalar NewSize, OldSize, NewItem; if not PosIntP R2 then return IndexError(R2, 'SubSeq); if not PosIntP R3 then return IndexError(R3, 'SubSeq); NewSize := R3 - R2 - 1; if NewSize < -1 then return RangeError(R1, R3, 'SubSeq); return case Tag R1 of Str, Bytes: << OldSize := StrLen StrInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtSTR NewSize; R3 := StrInf R1; for I := 0 step 1 until NewSize do StrByt(NewItem, I) := StrByt(R3, R2 + I); case Tag R1 of Str: MkSTR NewItem; Bytes: MkBYTES NewItem; end >> >>; Vect: << OldSize := VecLen VecInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtVECT NewSize; R3 := VecInf R1; for I := 0 step 1 until NewSize do VecItm(NewItem, I) := VecItm(R3, R2 + I); MkVEC NewItem >> >>; Wrds: << OldSize := WrdLen WrdInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtWRDS NewSize; R3 := WrdInf R1; for I := 0 step 1 until NewSize do WrdItm(NewItem, I) := WrdItm(R3, R2 + I); MkWRDS NewItem >> >>; HalfWords: << OldSize := HalfWordLen HalfWordInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtHalfWords NewSize; R3 := HalfWordInf R1; for I := 0 step 1 until NewSize do HalfWordItm(NewItem, I) := HalfWordItm(R3, R2 + I); MkHalfWords NewItem >> >>; Pair: << for I := 1 step 1 until R2 do if PairP R1 then R1 := rest R1 else RangeError(R1, R2, 'SubSeq); NewItem := NIL . NIL; for I := 0 step 1 until NewSize do if PairP R1 then << TConc(NewItem, first R1); R1 := rest R1 >> else RangeError(R1, R3, 'SubSeq); car NewItem >>; default: NonSequenceError(R1, 'SubSeq); end; end; syslsp procedure SetSub(R1, R2, R3, R4); %. Obsolete subsequence function SetSubSeq(R1, R2, R2 + R3 + 1, R4); syslsp procedure SetSubSeq(R1, R2, R3, R4); % R2 is lower bound, R3 upper begin scalar NewSize, OldSize, SubSize, NewItem; if not PosIntP R2 then return IndexError(R2, 'SetSubSeq); if not PosIntP R3 then return IndexError(R3, 'SetSubSeq); NewSize := R3 - R2 - 1; if NewSize < -1 then return RangeError(R1, R3, 'SetSubSeq); case Tag R1 of Str, Bytes: << if not StringP R4 and not BytesP R4 then return NonStringError(R4, 'SetSubSeq); OldSize := StrLen StrInf R1; NewItem := StrInf R4; SubSize := StrLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := StrInf R1; for I := 0 step 1 until NewSize do StrByt(R3, R2 + I) := StrByt(NewItem, I) >> >>; Vect: << if not VectorP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := VecLen VecInf R1; NewItem := VecInf R4; SubSize := VecLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := VecInf R1; for I := 0 step 1 until NewSize do VecItm(R3, R2 + I) := VecItm(NewItem, I) >> >>; Wrds: << if not WrdsP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := WrdLen WrdInf R1; NewItem := WrdInf R4; SubSize := WrdLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := WrdInf R1; for I := 0 step 1 until NewSize do WrdItm(R3, R2 + I) := WrdItm(NewItem, I) >> >>; HalfWords: << if not HalfWordsP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := HalfWordLen HalfWordInf R1; NewItem := HalfWordInf R4; SubSize := HalfWordLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := HalfWordInf R1; for I := 0 step 1 until NewSize do HalfWordItm(R3, R2 + I) := HalfWordItm(NewItem, I) >> >>; Pair: << if not PairP R4 and not null R4 then return NonPairError(R4, 'SetSubSeq); for I := 1 step 1 until R2 do if PairP R1 then R1 := rest R1 else RangeError(R1, R2, 'SetSubSeq); NewItem := R4; for I := 0 step 1 until NewSize do if PairP R1 and PairP NewItem then << RPlaca(R1, first NewItem); R1 := rest R1; NewItem := rest NewItem >> else RangeError(R1, R3, 'SetSubSeq) >>; default: NonSequenceError(R1, 'SetSubSeq); end; return R4; end; syslsp procedure Concat(R1, R2); %. Concatenate 2 sequences begin scalar I1, I2, Tmp1, Tmp2, Tmp3; return case Tag R1 of STR, BYTES: << if not (StringP R2 or BytesP R2) then return NonStringError(R2, 'Concat); Tmp1 := StrInf R1; Tmp2 := StrInf R2; I1 := StrLen Tmp1; I2 := StrLen Tmp2; Tmp3 := GtSTR(I1 + I2 + 1); % R1 and R2 can move Tmp1 := StrInf R1; Tmp2 := StrInf R2; for I := 0 step 1 until I1 do StrByt(Tmp3, I) := StrByt(Tmp1, I); for I := 0 step 1 until I2 do StrByt(Tmp3, I1 + I + 1) := StrByt(Tmp2, I); if StringP R1 then MkSTR Tmp3 else MkBYTES Tmp3 >>; VECT: << if not VectorP R2 then return NonVectorError(R2, 'Concat); Tmp1 := VecInf R1; Tmp2 := VecInf R2; I1 := VecLen Tmp1; I2 := VecLen Tmp2; Tmp3 := GtVECT(I1 + I2 + 1); % R1 and R2 can move Tmp1 := VecInf R1; Tmp2 := VecInf R2; for I := 0 step 1 until I1 do VecItm(Tmp3, I) := VecItm(Tmp1, I); for I := 0 step 1 until I2 do VecItm(Tmp3, I1 + I + 1) := VecItm(Tmp2, I); MkVEC Tmp3 >>; WRDS: << if not WrdsP R2 then return NonVectorError(R2, 'Concat); Tmp1 := WrdInf R1; Tmp2 := WrdInf R2; I1 := WrdLen Tmp1; I2 := WrdLen Tmp2; Tmp3 := GtWrds(I1 + I2 + 1); % R1 and R2 can move Tmp1 := WrdInf R1; Tmp2 := WrdInf R2; for I := 0 step 1 until I1 do WrdItm(Tmp3, I) := WrdItm(Tmp1, I); for I := 0 step 1 until I2 do WrdItm(Tmp3, I1 + I + 1) := WrdItm(Tmp2, I); MkWRDS Tmp3 >>; HALFWORDS: << if not HalfWordsP R2 then return NonVectorError(R2, 'Concat); Tmp1 := HalfWordInf R1; Tmp2 := HalfWordInf R2; I1 := HalfWordLen Tmp1; I2 := HalfWordLen Tmp2; Tmp3 := GtHalfWords(I1 + I2 + 1); % R1 and R2 can move Tmp1 := HalfWordInf R1; Tmp2 := HalfWordInf R2; for I := 0 step 1 until I1 do HalfWordItm(Tmp3, I) := HalfWordItm(Tmp1, I); for I := 0 step 1 until I2 do HalfWordItm(Tmp3, I1 + I + 1) := HalfWordItm(Tmp2, I); MkHalfWords Tmp3 >>; PAIR, ID: if null R1 or PairP R1 then Append(R1, R2); default: NonSequenceError(R1, 'Concat); end; end; syslsp procedure Size S; %. Upper bound of sequence case Tag S of STR, BYTES, WRDS, VECT, HALFWORDS: GetLen Inf S; ID: -1; PAIR: begin scalar I; I := -1; while PairP S do << I := I + 1; S := cdr S >>; return I; end; default: NonSequenceError(S, 'Size); end; off SysLisp; END; |
Added psl-1983/3-1/kernel/sets.red version [d2e2ad5749].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SETS.RED - Functions acting on lists as sets % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 December 1981 % Copyright (c) 1981 University of Utah % lisp procedure List2Set L; %. Remove redundant elements from L if not PairP L then NIL else if car L member cdr L then List2Set cdr L else car L . List2Set cdr L; lisp procedure List2SetQ L; %. EQ version of List2Set if not PairP L then NIL % Don't confuse it with SetQ! else if car L memq cdr L then List2Set cdr L else car L . List2Set cdr L; lisp procedure Adjoin(Element, ASet); %. Add Element to Set if Element member ASet then ASet else Element . ASet; lisp procedure AdjoinQ(Element, ASet); %. EQ version of Adjoin if Element memq ASet then ASet else Element . ASet; lisp procedure Union(X, Y); %. Set union if not PairP X then Y else Union(cdr X, if car X Member Y then Y else car X . Y); lisp procedure UnionQ(X, Y); %. EQ version of UNION if not PairP X then Y else UnionQ(cdr X, if car X memq Y then Y else car X . Y); lisp procedure XN(U, V); %. Set intersection if not PairP U then NIL else if car U Member V then car U . XN(cdr U, Delete(car U, V)) else XN(cdr U, V); lisp procedure XNQ(U, V); %. EQ version of XN if null PairP U then NIL else if car U memq V then car U . XN(cdr U, DelQ(car U, V)) else XN(cdr U, V); LoadTime << PutD('Intersection, 'EXPR, cdr GetD 'XN); % for those who like to type PutD('IntersectionQ, 'EXPR, cdr GetD 'XNQ) >>; END; |
Added psl-1983/3-1/kernel/string-gensym.red version [cf2affaf91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % STRING-GENSYM.RED - Complement to GenSym, makes a string instead of ID % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 January 1982 % Copyright (c) 1982 University of Utah % % Edit by Cris Perdue, 9 Feb 1983 1620-PST % Modified to avoid using the CHAR macro in a top level form fluid '(StringGenSym!*); StringGenSym!* := copystring("L0000"); % Copy to force into heap /csp CompileTime flag('(StringGenSym1), 'InternalFunction); lisp procedure StringGenSym(); %. Generate unique string StringGenSym1 4; lisp procedure StringGenSym1 N; %. Auxiliary function for StringGenSym begin scalar Ch; return if N > 0 then if (Ch := Indx(StringGenSym!*, N)) < char !9 then << SetIndx(StringGenSym!*, N, Ch + 1); TotalCopy StringGenSym!* >> else << SetIndx(StringGenSym!*, N, char !0); StringGenSym1(N - 1) >> else % Increment starting letter << SetIndx(StringGenSym!*, 0, Indx(StringGenSym!*, 0) + 1); StringGenSym() >>; end; END; |
Added psl-1983/3-1/kernel/symbl.build version [b480556330].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % SYMBL.BUILD - Files dealing with symbols in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "binding.red"$ % binding from the interpreter PathIn "fast-binder.red"$ % for binding in compiled code, in LAP PathIn "symbol-values.red"$ % SET, and support for Eval PathIn "oblist.red"$ % Intern, RemOb and GenSym |
Added psl-1983/3-1/kernel/symbol-values.red version [b6fd3cd69e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYMBOL-VALUES.RED - ValueCell, UnboundP, MakeUnbound and Set % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 Eric Benson % on SysLisp; syslsp procedure UnboundP U; %. Does U not have a value? if IDP U then if Tag SymVal IDInf U eq Unbound then T else NIL else NonIDError(U, 'UnboundP); syslsp procedure MakeUnbound U; %. Make U an unbound ID if IDP U then SymVal IDInf U := MkItem(Unbound, IDInf U) else NonIDError(U, 'MakeUnbound); syslsp procedure ValueCell U; %. Safe access to SymVal entry begin scalar V; % This guy is called from Eval return if IDP U then << V := SymVal IDInf U; if Tag V eq Unbound then ContinuableError('99, BldMsg('"%r is an unbound ID", U), U) else V >> else NonIDError(U, 'ValueCell); end; % This version of SET differs from the Standard Lisp report in that Exp is % not declared fluid, in order to maintain compatibility between compiled % and interpreted code. syslsp procedure Set(Exp, Val); %. Assign Val to ID Exp if IDP Exp then if not (null Exp or Exp eq 'T) then << SymVal IDInf Exp := Val; Val >> else StdError '"T and NIL cannot be SET" else NonIDError(Exp, 'Set); off SysLisp; END; |
Added psl-1983/3-1/kernel/sysio.build version [36b02e6690].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % % SYSIO.BUILD - Files for system-dependent input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "system-io.red"$ % system dependent IO functions PathIn "scan-table.red"$ % change scan table for system |
Added psl-1983/3-1/kernel/tloop.build version [6b7b2f001d].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % TLOOP.BUILD - Files with top loop and related functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "break.red"$ % break package (uses top loop) PathIn "top-loop.red"$ % generalized top loop function PathIn "dskin.red"$ % Read/Eval/Print from files |
Added psl-1983/3-1/kernel/token-scanner.red version [3d8b5a0e75].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TOKEN-SCANNER.RED - Table-driven token scanner % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.NEW>TOKEN-SCANNER.RED.2, 7-Apr-83 12:29:58, Edit by KESSLER % Changed MakeBufIntoFloat so it uses FloatZero, instead of '0.0. % Edit by Cris Perdue, 11 Mar 1983 % Added argument to MakeBufIntoFloat to specify sign of number % Edit by Cris Perdue, 29 Jan 1983 1338-PST % Occurrences of "dipthong" changed to "diphthong" % <PSL.KERNEL>TOKEN-SCANNER.RED.2, 16-Dec-82 14:55:55, Edit by BENSON % MakeBufIntoFloat uses floating point arithmetic on each digit % <PSL.INTERP>TOKEN-SCANNER.RED.6, 15-Sep-82 10:49:54, Edit by BENSON % Can now scan 1+ and 1- % <PSL.INTERP>TOKEN-SCANNER.RED.12, 10-Jan-82 21:53:28, Edit by BENSON % Fixed bug in floating point parsing % <PSL.INTERP>TOKEN-SCANNER.RED.9, 8-Jan-82 07:06:23, Edit by GRISS % MakeBufIntoLispInteger becomes procedure for BigNums % <PSL.INTERP>TOKEN-SCANNER.RED.7, 28-Dec-81 22:09:14, Edit by BENSON % Made dipthong indicator last element of scan table fluid '(CurrentScanTable!* !*Raise !*Compressing !*EOLInStringOK); LoadTime << !*Raise := T; !*Compressing := NIL; !*EOLInStringOK := NIL; >>; CompileTime flag('(ReadInBuf MakeBufIntoID MakeBufIntoString MakeBufIntoLispInteger MakeBufIntoSysNumber MakeBufIntoFloat MakeStringIntoSysInteger MakeStringIntoBitString ScannerError SysPowerOf2P ScanPossibleDiphthong), 'InternalFunction); on SysLisp; % DIGITS are 0..9 internal WConst LETTER = 10, DELIMITER = 11, COMMENTCHAR = 12, DIPHTHONGSTART = 13, IDESCAPECHAR = 14, STRINGQUOTE = 15, PACKAGEINDICATOR = 16, IGNORE = 17, MINUSSIGN = 18, PLUSSIGN = 19, DECIMALPOINT = 20, IDSURROUND = 21; internal WVar TokCh, TokChannel, ChTokenType, CurrentChar, ChangedPackages, TokRadix, TokSign, TokFloatFractionLength, TokFloatExponentSign, TokFloatExponent; CompileTime << syslsp smacro procedure TokenTypeOfChar Ch; IntInf VecItm(VecInf LispVar CurrentScanTable!*, Ch); syslsp smacro procedure CurrentDiphthongIndicator(); VecItm(VecInf LispVar CurrentScanTable!*, 128); syslsp smacro procedure ResetBuf(); CurrentChar := 0; syslsp smacro procedure BackupBuf(); CurrentChar := CurrentChar - 1; >>; syslsp procedure ReadInBuf(); << TokCh := ChannelReadChar TokChannel; StrByt(TokenBuffer, CurrentChar) := TokCh; ChTokenType := TokenTypeOfChar TokCh; if CurrentChar < MaxTokenSize then CurrentChar := CurrentChar + 1 else if CurrentChar = MaxTokenSize then << ErrorPrintF("***** READ Buffer overflow, Truncating"); CurrentChar := MaxTokenSize + 1 >> else CurrentChar := MaxTokenSize + 1 >>; CompileTime << syslsp smacro procedure UnReadLastChar(); ChannelUnReadChar(Channel, TokCh); syslsp smacro procedure LowerCaseChar Ch; Ch >= char !a and Ch <= char !z; syslsp smacro procedure RaiseChar Ch; (Ch - char !a) + char A; syslsp smacro procedure RaiseLastChar(); if LowerCaseChar TokCh then StrByt(TokenBuffer, CurrentChar - 1) := RaiseChar TokCh; >>; syslsp procedure MakeBufIntoID(); << LispVar TokType!* := '0; if CurrentChar eq 1 then MkID StrByt(TokenBuffer, 0) else << StrByt(TokenBuffer, CurrentChar) := char NULL; TokenBuffer[0] := CurrentChar - 1; if LispVar !*Compressing then NewID CopyString TokenBuffer else Intern MkSTR TokenBuffer >> >>; syslsp procedure MakeBufIntoString(); << LispVar TokType!* := '1; StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; CopyString TokenBuffer >>; syslsp procedure MakeBufIntoSysNumber(Radix, Sign); << StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; MakeStringIntoSysInteger(TokenBuffer, Radix, Sign) >>; syslsp procedure MakeBufIntoLispInteger(Radix, Sign); << LispVar TokType!* := '2; StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; MakeStringIntoLispInteger(MkSTR TokenBuffer, Radix, Sign) >>; internal WArray MakeFloatTemp1[1], MakeFloatTemp2[1], FloatTen[1], FloatZero[1]; % Changed to use floating point arithmetic on the characters, rather % than converting to an integer. This avoids overflow problems. syslsp procedure MakeBufIntoFloat(Exponent, MinusP); begin scalar F, N; !*WFloat(FloatTen, 10); !*WFloat(MakeFloatTemp1, 0); !*WFloat(FloatZero, 0); N := CurrentChar - 1; for I := 0 step 1 until N do << !*WFloat(MakeFloatTemp2, DigitToNumber StrByt(TokenBuffer, I)); !*FTimes2(MakeFloatTemp1, MakeFloatTemp1, FloatTen); !*FPlus2(MakeFloatTemp1, MakeFloatTemp1, MakeFloatTemp2) >>; if Exponent > 0 then for I := 1 step 1 until Exponent do !*FTimes2(MakeFloatTemp1, MakeFloatTemp1, FloatTen) else if Exponent < 0 then << Exponent := -Exponent; for I := 1 step 1 until Exponent do !*FQuotient(MakeFloatTemp1, MakeFloatTemp1, FloatTen) >>; if Minusp then !*FDifference(MakeFloatTemp1, FloatZero, MakeFloatTemp1); %% Gack. It is necessary to quote 0.0 in SysLISP mode! %% Is it because of the direct call on a CMACRO? Think not. /csp LispVar TokType!* := '2; F := GtFLTN(); !*FAssign(FloatBase F, MakeFloatTemp1); return MkFLTN F; end; syslsp procedure ChannelReadToken Channel; %. Token scanner % % This is the basic Lisp token scanner. The value returned is a Lisp % item corresponding to the next token from the input stream. IDs will % be interned. The global Lisp variable TokType!* will be set to % 0 if the token is an ordinary ID, % 1 if the token is a string (delimited by double quotes), % 2 if the token is a number, or % 3 if the token is an unescaped delimiter. % In the last case, the value returned by this function will be the single % character ID corresponding to the delimiter. % begin TokChannel := Channel; ChangedPackages := 0; ResetBuf(); StartScanning: TokCh := ChannelReadChar Channel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType eq IGNORE then goto StartScanning; StrByt(TokenBuffer, CurrentChar) := TokCh; CurrentChar := CurrentChar + 1; case ChTokenType of 0 to 9: % digit << TokSign := 1; goto InsideNumber >>; 10: % Start of ID << if null LispVar !*Raise then goto InsideID else << RaiseLastChar(); goto InsideRaisedID >> >>; 11: % Delimiter, but not beginning of Diphthong << LispVar TokType!* := '3; return MkID TokCh >>; 12: % Start of comment goto InsideComment; 13: % Diphthong start - Lisp function uses P-list of starting char return ScanPossibleDiphthong(TokChannel, MkID TokCh); 14: % ID escape character << if null LispVar !*Raise then goto GotEscape else goto GotEscapeInRaisedID >>; 15: % string quote << BackupBuf(); goto InsideString >>; 16: % Package indicator - at start of token means use global package << ResetBuf(); ChangedPackages := 1; Package 'Global; if null LispVar !*Raise then goto GotPackageMustGetID else goto GotPackageMustGetIDRaised >>; 17: % Ignore - can't ever happen ScannerError("Internal error - consult a wizard"); 18: % Minus sign << TokSign := -1; goto GotSign >>; 19: % Plus sign << TokSign := 1; goto GotSign >>; 20: % decimal point << ResetBuf(); ReadInBuf(); if ChTokenType >= 10 then << UnReadLastChar(); return ScanPossibleDiphthong(TokChannel, '!.) >> else << TokSign := 1; TokFloatFractionLength := 1; goto InsideFloatFraction >> >>; 21: % IDSURROUND, i.e. vertical bars << BackupBuf(); goto InsideIDSurround >>; default: return ScannerError("Unknown token type") end; GotEscape: BackupBuf(); ReadInBuf(); goto InsideID; InsideID: ReadInBuf(); if ChTokenType <= 10 or ChTokenType eq PLUSSIGN or ChTokenType eq MINUSSIGN then goto InsideID else if ChTokenType eq IDESCAPECHAR then goto GotEscape else if ChTokenType eq PACKAGEINDICATOR then << BackupBuf(); ChangedPackages := 1; Package MakeBufIntoID(); ResetBuf(); goto GotPackageMustGetID >> else << UnReadLastChar(); BackupBuf(); if ChangedPackages neq 0 then Package LispVar CurrentPackage!*; return MakeBufIntoID() >>; GotPackageMustGetID: ReadInBuf(); if ChTokenType eq LETTER then goto InsideID else if ChTokenType eq IDESCAPECHAR then goto GotEscape else ScannerError("Illegal to follow package indicator with non ID"); GotEscapeInRaisedID: BackupBuf(); ReadInBuf(); goto InsideRaisedID; InsideRaisedID: ReadInBuf(); if ChTokenType < 10 or ChTokenType eq PLUSSIGN or ChTokenType eq MINUSSIGN then goto InsideRaisedID else if ChTokenType eq 10 then << RaiseLastChar(); goto InsideRaisedID >> else if ChTokenType eq IDESCAPECHAR then goto GotEscapeInRaisedID else if ChTokenType eq PACKAGEINDICATOR then << BackupBuf(); ChangedPackages := 1; Package MakeBufIntoID(); ResetBuf(); goto GotPackageMustGetIDRaised >> else << UnReadLastChar(); BackupBuf(); if ChangedPackages neq 0 then Package LispVar CurrentPackage!*; return MakeBufIntoID() >>; GotPackageMustGetIDRaised: ReadInBuf(); if ChTokenType eq LETTER then << RaiseLastChar(); goto InsideRaisedID >> else if ChTokenType eq IDESCAPECHAR then goto GotEscapeInRaisedID else ScannerError("Illegal to follow package indicator with non ID"); InsideString: ReadInBuf(); if ChTokenType eq STRINGQUOTE then << BackupBuf(); ReadInBuf(); if ChTokenType eq STRINGQUOTE then goto InsideString else << UnReadLastChar(); BackupBuf(); return MakeBufIntoString() >> >> else if TokCh eq char EOL and not LispVar !*EOLInStringOK then ErrorPrintF("*** String continued over end-of-line") else if TokCh eq char EOF then ScannerError("EOF encountered inside a string"); goto InsideString; InsideIDSurround: ReadInBuf(); if ChTokenType eq IDSURROUND then << BackupBuf(); return MakeBufIntoID() >> else if ChTokenType eq IDESCAPECHAR then << BackupBuf(); ReadInBuf() >> else if TokCh eq char EOF then ScannerError("EOF encountered inside an ID"); goto InsideIDSurround; GotSign: ResetBuf(); ReadInBuf(); if TokCh eq char !. then << PutStrByt(TokenBuffer, 0, char !0); CurrentChar := 2; goto InsideFloat >> else if ChTokenType eq LETTER % patch to be able to read 1+ and 1- or ChTokenType eq MINUSSIGN or ChTokenType eq PLUSSIGN then << ResetBuf(); StrByt(TokenBuffer, 0) := if TokSign < 0 then char !- else char !+; StrByt(TokenBuffer, 1) := TokCh; CurrentChar := 2; if LispVar !*Raise then << RaiseLastChar(); goto InsideRaisedID >> else goto InsideID >> else if ChTokenType eq IDESCAPECHAR then << ResetBuf(); StrByt(TokenBuffer, 0) := if TokSign < 0 then char !- else char !+; CurrentChar := 1; if LispVar !*Raise then goto GotEscapeInRaisedID else goto GotEscape >> else if ChTokenType > 9 then << UnReadLastChar(); % Allow + or - to start a Diphthong return ScanPossibleDiphthong(Channel, MkID(if TokSign < 0 then char !- else char !+)) >> else goto InsideNumber; InsideNumber: ReadInBuf(); if ChTokenType < 10 then goto InsideNumber; if TokCh eq char !# then << BackupBuf(); TokRadix := MakeBufIntoSysNumber(10, 1); ResetBuf(); if TokRadix < 2 or TokRadix > 36 then return ScannerError("Radix out of range"); if TokRadix <= 10 then goto InsideIntegerRadixUnder10 else goto InsideIntegerRadixOver10 >> else if TokCh eq char !. then goto InsideFloat else if TokCh eq char B or TokCh eq char !b then << BackupBuf(); return MakeBufIntoLispInteger(8, TokSign) >> else if TokCh eq char E or TokCh eq char !e then << TokFloatFractionLength := 0; goto InsideFloatExponent >> else if ChTokenType eq LETTER % patch to be able to read 1+ and 1- or ChTokenType eq MINUSSIGN or ChTokenType eq PLUSSIGN then if LispVar !*Raise then << RaiseLastChar(); goto InsideRaisedID >> else goto InsideID else if ChTokenType eq IDESCAPECHAR then if LispVar !*Raise then goto GotEscapeInRaisedID else goto GotEscape else << UnReadLastChar(); BackupBuf(); return MakeBufIntoLispInteger(10, TokSign) >>; InsideIntegerRadixUnder10: ReadInBuf(); if ChTokenType < TokRadix then goto InsideIntegerRadixUnder10; if ChTokenType < 10 then return ScannerError("Digit out of range"); NumReturn: UnReadLastChar(); BackupBuf(); return MakeBufIntoLispInteger(TokRadix, TokSign); InsideIntegerRadixOver10: ReadInBuf(); if ChTokenType < 10 then goto InsideIntegerRadixOver10; if ChTokenType > 10 then goto NumReturn; if LowerCaseChar TokCh then << TokCh := RaiseChar TokCh; StrByt(TokenBuffer, CurrentChar - 1) := TokCh >>; if TokCh >= char A - 10 + TokRadix then goto NumReturn; goto InsideIntegerRadixOver10; InsideFloat: % got decimal point inside number BackupBuf(); ReadInBuf(); if TokCh eq char E or TokCh eq char !e then << TokFloatFractionLength := 0; goto InsideFloatExponent >>; if ChTokenType >= 10 then % nnn. is floating point number << UnReadLastChar(); BackupBuf(); return MakeBufIntoFloat(0,TokSign<0) >>; TokFloatFractionLength := 1; InsideFloatFraction: ReadInBuf(); if ChTokenType < 10 then << if TokFloatFractionLength < 9 then TokFloatFractionLength := TokFloatFractionLength + 1 else BackupBuf(); % don't overflow mantissa goto InsideFloatFraction >>; if TokCh eq char E or TokCh eq char lower e then goto InsideFloatExponent; UnReadLastChar(); BackupBuf(); return MakeBufIntoFloat((-TokFloatFractionLength), TokSign<0); InsideFloatExponent: BackupBuf(); TokFloatExponentSign := 1; TokFloatExponent := 0; TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType < 10 then << TokFloatExponent := ChTokenType; goto DigitsInsideExponent >>; if TokCh eq char '!- then TokFloatExponentSign := -1 else if TokCh neq char '!+ then return ScannerError("Missing exponent in float"); TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType >= 10 then return ScannerError("Missing exponent in float"); TokFloatExponent := ChTokenType; DigitsInsideExponent: TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType < 10 then << TokFloatExponent := TokFloatExponent * 10 + ChTokenType; goto DigitsInsideExponent >>; ChannelUnReadChar(Channel, TokCh); return MakeBufIntoFloat((TokFloatExponentSign * TokFloatExponent - TokFloatFractionLength), TokSign<0); InsideComment: if (TokCh := ChannelReadChar Channel) eq char EOL then << ResetBuf(); goto StartScanning >> else if TokCh eq char EOF then return LispVar !$EOF!$ else goto InsideComment; end; syslsp procedure RAtom(); %. Read token from current input ChannelReadToken LispVar IN!*; syslsp procedure DigitToNumber D; % % if D is not a digit then it is assumed to be an uppercase letter % if D >= char !0 and D <= char !9 then D - char !0 else D - (char A - 10); syslsp procedure MakeStringIntoLispInteger(S, Radix, Sign); Sys2Int MakeStringIntoSysInteger(S, Radix, Sign); syslsp procedure MakeStringIntoSysInteger(Strng, Radix, Sign); % % Unsafe string to integer conversion. Strng is assumed to contain % only digits and possibly uppercase letters for radices > 10. Since it % uses multiplication, arithmetic overflow may occur. Sign is +1 or -1 % begin scalar Count, Tot, RadixExponent; if RadixExponent := SysPowerOf2P Radix then return MakeStringIntoBitString(Strng, Radix, RadixExponent, Sign); Strng := StrInf Strng; Count := StrLen Strng; Tot := 0; for I := 0 step 1 until Count do Tot := Tot * Radix + DigitToNumber StrByt(Strng, I); return if Sign < 0 then -Tot else Tot; end; syslsp procedure MakeStringIntoBitString(Strng, Radix, RadixExponent, Sign); begin scalar Count, Tot; Strng := StrInf Strng; Count := StrLen Strng; Tot := 0; for I := 0 step 1 until Count do << Tot := LSH(Tot, RadixExponent); Tot := LOR(Tot, DigitToNumber StrByt(Strng, I)) >>; if Sign < 0 then return -Tot; return Tot; end; syslsp procedure SysPowerOf2P Num; case Num of 1: 0; 2: 1; 4: 2; 8: 3; 16: 4; 32: 5; default: NIL end; syslsp procedure ScannerError Message; StdError BldMsg("***** Error in token scanner: %s", Message); syslsp procedure ScanPossibleDiphthong(Channel, StartChar); begin scalar Alst, Target, Ch; LispVar TokType!* := '3; if null (Alst := get(StartChar, CurrentDiphthongIndicator())) then return StartChar; if null (Target := Atsoc(Ch := MkID ChannelReadChar Channel, Alst)) then << ChannelUnReadChar(Channel, IDInf Ch); return StartChar >>; return cdr Target; end; syslsp procedure ReadLine(); << MakeInputAvailable(); ChannelReadLine LispVar IN!* >>; syslsp procedure ChannelReadLine Chn; begin scalar C; TokenBuffer[0] := -1; while (C := ChannelReadChar Chn) neq char EOL and C neq char EOF do << TokenBuffer[0] := TokenBuffer[0] + 1; StrByt(TokenBuffer, TokenBuffer[0]) := C >>; return if TokenBuffer[0] >= 0 then << StrByt(TokenBuffer, TokenBuffer[0] + 1) := char NULL; CopyString MkSTR TokenBuffer >> else '""; end; % Dummy definition of package conversion function syslsp procedure Package U; NIL; % Dummy definition of MakeInputAvailable, redefined by Emode syslsp procedure MakeInputAvailable(); NIL; off SysLisp; END; |
Added psl-1983/3-1/kernel/top-loop.red version [da8e3a5f19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TOP-LOOP.RED - Generalized top loop construct % % Author: Eric Benson and M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 October 1981 % Copyright (c) 1981 University of Utah % % 03-Mar-83 Nancy Kendzierski % Added declaration of LispScanTable!* as a fluid. % <PSL.KERNEL>TOP-LOOP.RED.6, 5-Oct-82 11:02:29, Edit by BENSON % Added EvalInitForms, changed SaveSystem to 3 args % <PSL.KERNEL>TOP-LOOP.RED.5, 4-Oct-82 18:09:33, Edit by BENSON % Added GCTime!* % $pi/top-loop.red, Mon Jun 28 10:54:19 1982, Edit by Fish % Conditional output: !*Output, Semic!*, !*NoNil. % <PSL.INTERP>TOP-LOOP.RED.13, 30-Apr-82 14:32:20, Edit by BENSON % Minor change to !*DEFN processing % <PSL.INTERP>TOP-LOOP.RED.5, 29-Apr-82 03:56:06, Edit by GRISS % Initial attempt to add !*DEFN processing %<PSL.INTERP>TOP-LOOP.RED.18 24-Nov-81 15:22:25, Edit by BENSON % Changed Standard!-Lisp to StandardLisp CompileTime flag('(NthEntry DefnPrint DefnPrint1 HistPrint), 'InternalFunction); fluid '(TopLoopRead!* % reading function TopLoopPrint!* % printing function TopLoopEval!* % evaluation function TopLoopName!* % short name to put in prompt TopLoopLevel!* % depth of top loop invocations HistoryCount!* % number of entries read so far HistoryList!* % list of entries read and evaluated PromptString!* % input prompt LispBanner!* % Welcome banner printed in StandardLisp !*EMsgP % whether to print error messages !*BackTrace % whether to print backtrace !*Time % whether to print timing of evaluation GCTime!* % Time spent in garbage collection !*Defn % To "output" rather than process DFPRINT!* % Alternate DEFN print function !*Output % Whether to print output. Semic!* % Input terminator when in Rlisps. !*NoNil % Whether to supress NIL value print. InitForms!* % Forms to be evaluated at startup LispScanTable!* % CurrentScanTable!* when READing ); LoadTime << TopLoopLevel!* := -1; HistoryCount!* := 0; LispBanner!* := "Portable Standard LISP"; !*Output := T; % Output ON by default. >>; lisp procedure TopLoop(TopLoopRead!*, %. Generalized top-loop mechanism TopLoopPrint!*, %. TopLoopEval!*, %. TopLoopName!*, %. WelcomeBanner); %. begin scalar PromptString!*, Semic!*, LevelPrompt, ThisGCTime, InputValue, OutputValue, TimeCheck; Semic!* := '!; ; % Output when semicolon terminator for rlisps. (lambda TopLoopLevel!*; begin TimeCheck := 0; ThisGCTime := GCTime!*; LevelPrompt := MkString(TopLoopLevel!*, char '!> ); Prin2T WelcomeBanner; LoopStart: HistoryCount!* := IAdd1 HistoryCount!*; HistoryList!* := (NIL . NIL) . HistoryList!*; PromptString!* := BldMsg("%w %w%w ", HistoryCount!*, TopLoopName!*, LevelPrompt); InputValue := ErrorSet(quote Apply(TopLoopRead!*, NIL), T, !*Backtrace); if InputValue eq '!$ExitTopLoop!$ then goto LoopExit; if not PairP InputValue then goto LoopStart; InputValue := car InputValue; if InputValue eq '!$ExitTopLoop!$ then goto LoopExit; if InputValue eq !$EOF!$ then goto LoopExit; Rplaca(car HistoryList!*, InputValue); if !*Time then << TimeCheck := Time(); ThisGCTime := GCTime!* >>; if !*Defn then OutputValue := DefnPrint InputValue else OutputValue := ErrorSet(list('Apply, MkQuote TopLoopEval!*, MkQuote list InputValue), T, !*Backtrace); if not PairP OutputValue then goto LoopStart; OutputValue := car OutputValue; if !*Time then << TimeCheck := Time() - TimeCheck; ThisGCTime := GCTime!* - ThisGCTime >>; Rplacd(car HistoryList!*, OutputValue); if !*Output and Semic!* eq '!; and not (!*NoNil and OutputValue eq NIL) then ErrorSet(list('Apply, MkQuote TopLoopPrint!*, MkQuote list OutputValue), T, !*Backtrace); if !*Time then if ThisGCTime = 0 then PrintF("Cpu time: %w ms%n", TimeCheck) else PrintF("Cpu time: %w ms, GC time: %w ms%n", TimeCheck - ThisGCTime, ThisGCTime); goto LoopStart; LoopExit: PrintF("Exiting %w%n", TopLoopName!*); end)(IAdd1 TopLoopLevel!*); end; lisp procedure DefnPrint U; % handle case of !*Defn:=T % % Looks for special action on a form, otherwise prettyprints it; % Adapted from DFPRINT % if PairP U and FlagP(car U, 'Ignore) then DefnPrint1 U else % So 'IGNORE is EVALED, not output << if DfPrint!* then Apply(DfPrint!*, list U) else PrettyPrint U; % So 'EVAL gets EVALED and Output if PairP U and FlagP(car U, 'Eval) then DefnPrint1 U >>; lisp procedure DefnPrint1 U; ErrorSet(list('Apply, MkQuote TopLoopEval!*, MkQuote list U), T, !*Backtrace); fluid '(!*Break); lisp procedure NthEntry N; begin scalar !*Break; return if IGEQ(N, HistoryCount!*) then StdError BldMsg("No history entry %r", N) else car PNth(cdr HistoryList!*, IDifference(HistoryCount!*, N)); end; lisp procedure Inp N; %. Return Nth input car NthEntry N; expr procedure ReDo N; %. Re-evaluate Nth input Apply(TopLoopEval!*, list car NthEntry N); lisp procedure Ans N; %. return Nth output cdr NthEntry N; nexpr procedure Hist AL; %. Print history entries begin scalar I1, I2, L; if ILessP(HistoryCount!*, 2) then return NIL; I1 := 1; I2 := ISub1 HistoryCount!*; if PairP AL then << if car AL = 'CLEAR then << HistoryCount!* := 1; HistoryList!* := NIL . NIL; return NIL >>; if IMinusP car AL then return HistPrint(cdr HistoryList!*, ISub1 HistoryCount!*, IMinus car AL); I1 := Max(I1, car AL); AL := cdr AL >>; if PairP AL then I2 := Min(I2, car AL); return HistPrint(PNTH(cdr HistoryList!*, IDifference(HistoryCount!*, I2)), I2, IAdd1 IDifference(I2, I1)); end; lisp procedure HistPrint(L, N, M); if IZeroP M then NIL else << HistPrint(cdr L, ISub1 N, ISub1 M); PrintF("%w Inp: %p%n Ans: %p%n", N, car first L, cdr first L) >>; lisp procedure Time(); %. Get run-time in milliseconds Sys2Int TimC(); % TimC is primitive runtime function lisp procedure StandardLisp(); %. Lisp top loop (lambda (CurrentReadMacroIndicator!*, CurrentScanTable!*); TopLoop('READ, 'PrintWithFreshLine, 'EVAL, "lisp", LispBanner!*) )('LispReadMacro, LispScanTable!*); lisp procedure PrintWithFreshLine X; PrintF("%f%p%n", X); lisp procedure SaveSystem(Banner, File, InitForms); begin scalar SavedHistoryList, SavedHistoryCount; SavedHistoryCount := HistoryCount!*; SavedHistoryList := HistoryList!*; HistoryList!* := NIL; HistoryCount!* := 0; LispBanner!* := BldMsg("%w, %w", Banner, Date()); !*UserMode := T; InitForms!* := InitForms; DumpLisp File; InitForms!* := NIL; HistoryCount!* := SavedHistoryCount; HistoryList!* := SavedHistoryList; end; lisp procedure EvalInitForms(); %. Evaluate and clear InitForms!* << for each X in InitForms!* do Eval X; InitForms!* := NIL >>; END; |
Added psl-1983/3-1/kernel/type-conversions.red version [b84e512eaa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TYPE-CONVERSIONS.RED - Functions for converting between various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % <PSL.VAX-INTERP>TYPE-CONVERSIONS.RED.2, 20-Jan-82 02:10:24, Edit by GRISS % Fix list2vector for NIL case % The functions in this file are named `argument-type'2`result-type'. % The number 2 is used rather than `To' only for compatibility with old % versions. Any other suggestions for a consistent naming scheme are welcomed. % Perhaps they should also be `result-type'From`argument-type'. % Float and Fix are in ARITH.RED CompileTime flag('(Sys2FIXN), 'InternalFunction); on SysLisp; syslsp procedure ID2Int U; %. Return ID index as Lisp number if IDP U then MkINT IDInf U else NonIDError(U, 'ID2Int); syslsp procedure Int2ID U; %. Return ID corresponding to index begin scalar StripU; return if IntP U then << StripU := IntInf U; if StripU >= 0 then MkID StripU else TypeError(U, 'Int2ID, '"positive integer") >> else NonIntegerError(U, 'Int2ID); end; syslsp procedure Int2Sys N; %. Convert Lisp integer to untagged if IntP N then IntInf N else if FixNP N then FixVal FixInf N else NonIntegerError(N, 'Int2Sys); syslsp procedure Lisp2Char U; %. Convert Lisp item to syslsp char begin scalar C; % integers, IDs and strings are legal return if IntP U and (C := IntInf U) >= 0 and C <= 127 then C else if IDP U then % take first char of ID print name StrByt(StrInf SymNam IDInf U, 0) else if StringP U then StrByt(StrInf U, 0) % take first character of Lisp string else NonCharacterError(U, 'Lisp2Char); end; syslsp procedure Int2Code N; %. Convert Lisp integer to code pointer MkCODE N; syslsp procedure Sys2Int N; %. Convert word to Lisp number if SignedField(N, InfStartingBit - 1, InfBitLength + 1) eq N then N else Sys2FIXN N; syslsp procedure Sys2FIXN N; begin scalar FX; FX := GtFIXN(); FixVal FX := N; return MkFIXN FX; end; syslsp procedure ID2String U; %. Return print name of U (not copy) if IDP U then SymNam IDInf U else NonIDError(U, 'ID2String); % The functions for converting strings to IDs are Intern and NewID. Intern % returns an interned ID, NewID returns an uninterned ID. They are both found % in OBLIST.RED syslsp procedure String2Vector U; %. Make vector of ASCII values in U if StringP U then begin scalar StripU, V, N; N := StrLen StrInf U; V := GtVECT N; StripU := StrInf U; % in case GC occurred for I := 0 step 1 until N do VecItm(V, I) := MkINT StrByt(StripU, I); return MkVEC V; end else NonStringError(U, 'String2Vector); syslsp procedure Vector2String V; %. Make string with ASCII values in V if VectorP V then begin scalar StripV, S, N, Ch; N := VecLen VecInf V; S := GtSTR N; StripV := VecInf V; % in case GC occurred for I := 0 step 1 until N do StrByt(S, I) := Lisp2Char VecItm(StripV, I); return MkSTR S; end else NonVectorError(V, 'Vector2String); syslsp procedure List2String P; %. Make string with ASCII values in P if null P then '"" else if PairP P then begin scalar S, N; N := IntInf Length P - 1; S := GtSTR N; for I := 0 step 1 until N do << StrByt(S, I) := Lisp2Char car P; P := cdr P >>; return MkSTR S; end else NonPairError(P, 'List2String); syslsp procedure String2List S; %. Make list with ASCII values in S if StringP S then begin scalar L, N; L := NIL; N := StrLen StrInf S; for I := N step -1 until 0 do L := MkINT StrByt(StrInf S, I) . L; % strip S each time in case GC return L; end else NonStringError(S, 'String2List); syslsp procedure List2Vector L; %. convert list to vector if PairP L or NULL L then begin scalar V, N;% this function is used by READ N := IntInf Length L - 1; V := GtVECT N; for I := 0 step 1 until N do << VecItm(V, I) := car L; L := cdr L >>; return MkVEC V; end else NonPairError(L, 'List2Vector); syslsp procedure Vector2List V; %. Convert vector to list if VectorP V then begin scalar L, N; L := NIL; N := VecLen VecInf V; for I := N step -1 until 0 do L := VecItm(VecInf V, I) . L; % strip V each time in case GC return L; end else NonVectorError(V, 'Vector2List); off SysLisp; END; |
Added psl-1983/3-1/kernel/type-errors.red version [9b4fa0d5ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TYPE-ERRORS.RED - Error handlers for common type mismatches % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 September 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1621-PST % Added NonIOChannelError % <PSL.INTERP>TYPE-ERRORS.RED.6, 20-Jan-82 03:10:00, Edit by GRISS % Added NonWords Error lisp procedure TypeError(Offender, Fn, Typ); StdError BldMsg("An attempt was made to do %p on %r, which is not %w", Fn, Offender, Typ); lisp procedure UsageTypeError(Offender, Fn, Typ, Usage); StdError BldMsg("An attempt was made to use %r as %w in %p, where %w is needed", Offender, Usage, Fn, Typ); lisp procedure IndexError(Offender, Fn); UsageTypeError(Offender, Fn, "an integer", "an index"); lisp procedure NonPairError(Offender, Fn); TypeError(Offender, Fn, "a pair"); lisp procedure NonIDError(Offender, Fn); TypeError(Offender, Fn, "an identifier"); lisp procedure NonNumberError(Offender, Fn); TypeError(Offender, Fn, "a number"); lisp procedure NonIntegerError(Offender, Fn); TypeError(Offender, Fn, "an integer"); lisp procedure NonPositiveIntegerError(Offender, Fn); TypeError(Offender, Fn, "a non-negative integer"); lisp procedure NonCharacterError(Offender, Fn); TypeError(Offender, Fn, "a character"); lisp procedure NonStringError(Offender, Fn); TypeError(Offender, Fn, "a string"); lisp procedure NonVectorError(Offender, Fn); TypeError(Offender, Fn, "a vector"); lisp procedure NonWords(Offender, Fn); TypeError(Offender, Fn, "a words vector"); lisp procedure NonSequenceError(Offender, Fn); TypeError(Offender, Fn, "a sequence"); lisp procedure NonIOChannelError(Offender, Fn); TypeError(Offender, Fn, "a legal I/O channel"); END; |
Added psl-1983/3-1/kernel/types.build version [d1ca0404f6].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % TYPES.BUILD - Files with type conversions and others % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "type-conversions.red"$ % convert from one type to another PathIn "vectors.red"$ % GetV, PutV, UpbV PathIn "sequence.red"$ % Indx, SetIndx, Sub, SetSub, Concat |
Added psl-1983/3-1/kernel/vectors.red version [e7f4aa89ad].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % VECTORS.RED - Standard Lisp Vector functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>VECTORS.RED.2, 10-Jan-83 15:54:19, Edit by PERDUE % Added EGetV etc. for EVectors, paralleling Vectors % MkVect and MkEVector are found in PK:CONS-MKVECT.RED on SysLisp; syslsp procedure GetV(Vec, I); %. Retrieve the I'th entry of Vec begin scalar StripV, StripI; return if VectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) else StdError BldMsg('"Subscript %r in GetV is out of range", I) >> else IndexError(I, 'GetV) else NonVectorError(Vec, 'GetV); end; syslsp procedure PutV(Vec, I, Val); %. Store Val at I'th position of Vec begin scalar StripV, StripI; return if VectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in PutV is out of range", I) >> else IndexError(I, 'PutV) else NonVectorError(Vec, 'PutV); end; syslsp procedure UpbV V; %. Upper limit of vector V if VectorP V then MkINT VecLen VecInf V else NIL; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% EVectors %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% syslsp procedure EVECTORP V; TAG(V) EQ EVECT; syslsp procedure EGETV(Vec, I); %. Retrieve the I'th entry of Vec begin scalar StripV, StripI; return if EvectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) else StdError BldMsg('"Subscript %r in EGETV is out of range", I) >> else IndexError(I, 'EGETV) else NonVectorError(Vec, 'EGETV); end; syslsp procedure Eputv(Vec, I, Val); %. Store Val at I'th position of Vec begin scalar StripV, StripI; return if EvectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in Eputv is out of range", I) >> else IndexError(I, 'Eputv) else NonVectorError(Vec, 'Eputv); end; syslsp procedure EUpbV V; %. Upper limit of vector V if EvectorP V then MkINT EVecLen EVecInf V else NIL; off SysLisp; END; |
Added psl-1983/3-1/lap/addr2id.b version [bf88e8deed].
cannot compute difference between binary files
Added psl-1983/3-1/lap/association.b version [a78ddbae53].
cannot compute difference between binary files
Added psl-1983/3-1/lap/big-faslend.b version [b23ecea25f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/br-unbr.b version [e93a0538bd].
cannot compute difference between binary files
Added psl-1983/3-1/lap/bug.b version [2181ffa8ad].
cannot compute difference between binary files
Added psl-1983/3-1/lap/build.b version [45684475bd].
cannot compute difference between binary files
Added psl-1983/3-1/lap/char-macro.b version [6ce081b906].
cannot compute difference between binary files
Added psl-1983/3-1/lap/chars.b version [2182653d9c].
cannot compute difference between binary files
Added psl-1983/3-1/lap/clcomp.lap version [1b321e3ada].
> | 1 | (LOAD USEFUL CLCOMP1) |
Added psl-1983/3-1/lap/clcomp1.b version [ebdcf6d010].
cannot compute difference between binary files
Added psl-1983/3-1/lap/common.b version [2008099007].
cannot compute difference between binary files
Added psl-1983/3-1/lap/comp-decls.b version [97ed47d714].
cannot compute difference between binary files
Added psl-1983/3-1/lap/compiler.b version [7d9f549276].
cannot compute difference between binary files
Added psl-1983/3-1/lap/data-machine.b version [23d0e16305].
cannot compute difference between binary files
Added psl-1983/3-1/lap/debug.b version [6420b649b4].
cannot compute difference between binary files
Added psl-1983/3-1/lap/dec20-asm.b version [048f16dcb6].
cannot compute difference between binary files
Added psl-1983/3-1/lap/dec20-cmac.b version [70499d762c].
cannot compute difference between binary files
Added psl-1983/3-1/lap/dec20-comp.b version [bae9589070].
cannot compute difference between binary files
Added psl-1983/3-1/lap/dec20-lap.b version [69ebc4fa6b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/defstruct.b version [efb55bfac0].
cannot compute difference between binary files
Added psl-1983/3-1/lap/dir-stuff.b version [291b834727].
cannot compute difference between binary files
Added psl-1983/3-1/lap/directory.b version [db5e55f86b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/display-char.b version [140d6d96c5].
cannot compute difference between binary files
Added psl-1983/3-1/lap/evalhook.b version [b4602b9591].
cannot compute difference between binary files
Added psl-1983/3-1/lap/exec.b version [1c640e11de].
cannot compute difference between binary files
Added psl-1983/3-1/lap/extended-char.b version [296a6e0088].
cannot compute difference between binary files
Added psl-1983/3-1/lap/f-dstruct.b version [fdb5c49298].
cannot compute difference between binary files
Added psl-1983/3-1/lap/faslout.b version [a5019d9b2a].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-arith.b version [20fe062c4d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-defstruct.lap version [f0a97bdde2].
> | 1 | (LOAD DEFSTRUCT SYSLISP INUM FAST!-VECTOR F-DSTRUCT) |
Added psl-1983/3-1/lap/fast-evectors.b version [264af380e7].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-int.b version [bea8a2ce02].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-strings.b version [b1a054aeb7].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-vector.b version [add420ae88].
cannot compute difference between binary files
Added psl-1983/3-1/lap/fast-vectors.b version [3e447ba341].
cannot compute difference between binary files
Added psl-1983/3-1/lap/file-primitives.b version [c3ee53b700].
cannot compute difference between binary files
Added psl-1983/3-1/lap/file-support.b version [b44738ac6e].
cannot compute difference between binary files
Added psl-1983/3-1/lap/find.b version [ab2afd44cd].
cannot compute difference between binary files
Added psl-1983/3-1/lap/format.b version [d1514aac02].
cannot compute difference between binary files
Added psl-1983/3-1/lap/get-command-args.b version [c76bca0348].
cannot compute difference between binary files
Added psl-1983/3-1/lap/get-command-string.b version [133d24d56f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/get-heap-bounds.b version [5c920b65f4].
cannot compute difference between binary files
Added psl-1983/3-1/lap/graph-tree.b version [6d61ad5053].
cannot compute difference between binary files
Added psl-1983/3-1/lap/gsort.b version [e9c928cbff].
cannot compute difference between binary files
Added psl-1983/3-1/lap/h-stats-1.b version [847316f26d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/hash.b version [b5d83c0405].
cannot compute difference between binary files
Added psl-1983/3-1/lap/hcons.b version [3f2f50b525].
cannot compute difference between binary files
Added psl-1983/3-1/lap/heap-stats.b version [118b22715a].
cannot compute difference between binary files
Added psl-1983/3-1/lap/help.b version [8c5b1afa6a].
cannot compute difference between binary files
Added psl-1983/3-1/lap/history.b version [3cd10be769].
cannot compute difference between binary files
Added psl-1983/3-1/lap/homedir.b version [6c430d65d9].
cannot compute difference between binary files
Added psl-1983/3-1/lap/if-system.b version [f13ad6119e].
cannot compute difference between binary files
Added psl-1983/3-1/lap/if.b version [07f68b21f5].
cannot compute difference between binary files
Added psl-1983/3-1/lap/init-file.b version [0a6a4dd40f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/input-stream.b version [2fb7c51f21].
cannot compute difference between binary files
Added psl-1983/3-1/lap/inspect.b version [faa4bce18b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/interrupt.b version [d12d6f16df].
cannot compute difference between binary files
Added psl-1983/3-1/lap/inum.b version [cfb176e431].
cannot compute difference between binary files
Added psl-1983/3-1/lap/jsys.b version [909fd2064b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/kernel.b version [a3bbe3812e].
cannot compute difference between binary files
Added psl-1983/3-1/lap/lap-to-asm.b version [efde660f8b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/loop.b version [1c4cf31a3b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/mathlib.b version [e52bbc2055].
cannot compute difference between binary files
Added psl-1983/3-1/lap/mini.b version [d66b6d30ef].
cannot compute difference between binary files
Added psl-1983/3-1/lap/monsym.b version [38de717c06].
cannot compute difference between binary files
Added psl-1983/3-1/lap/nbarith.b version [bcde51d72c].
cannot compute difference between binary files
Added psl-1983/3-1/lap/nbig.lap version [072abfcdff].
> | 1 | (load nbarith vector!-fix nbig0) |
Added psl-1983/3-1/lap/nbig0.b version [a205dc8326].
cannot compute difference between binary files
Added psl-1983/3-1/lap/nmode-attributes.b version [6056b592e2].
cannot compute difference between binary files
Added psl-1983/3-1/lap/nmode-parsing.b version [346add12c7].
cannot compute difference between binary files
Added psl-1983/3-1/lap/nmode.lap version [e1578d38c2].
> > | 1 2 | (faslin "pnb:nmode-20.b") (load-nmode) |
Added psl-1983/3-1/lap/nstruct.b version [1ccbe48600].
cannot compute difference between binary files
Added psl-1983/3-1/lap/numeric-operators.b version [a88056e656].
cannot compute difference between binary files
Added psl-1983/3-1/lap/objects.b version [6b6f5b8604].
cannot compute difference between binary files
Added psl-1983/3-1/lap/output-stream.b version [77171b378a].
cannot compute difference between binary files
Added psl-1983/3-1/lap/package.b version [f70aa3317d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/parse-command-string.b version [605ea66a44].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pass-1-lap.b version [8470707e9d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pathin.b version [d067b38901].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pathnames.b version [1c13a8ce69].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pathnamex.b version [86d3e52454].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pcheck.b version [9c61b365f0].
cannot compute difference between binary files
Added psl-1983/3-1/lap/poly.b version [e710c9a052].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pp.b version [c94daf63aa].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr-driv.b version [6694395797].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr-main.b version [f3274498b2].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr-text.b version [9f109bade9].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr2d-driv.b version [5873b3be5c].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr2d-main.b version [91b5a8432d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pr2d-text.b version [36f9cff2f8].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pretty.b version [26948e71ef].
cannot compute difference between binary files
Added psl-1983/3-1/lap/prettyprint.lap version [6166064701].
> > > | 1 2 3 | % The files prettyprint.* were changed to pp.* % This allows old code that loaded prettyprint to still get the module. (load pp) |
Added psl-1983/3-1/lap/prlisp.lap version [f7349a45b9].
> | 1 | (load rawio rawbreak mathlib pr-main pr-text pr-driv) |
Added psl-1983/3-1/lap/prlisp2d.lap version [f65fec04e8].
> | 1 | (load rawio rawbreak mathlib pr2d-main pr2d-text pr2d-driv) |
Added psl-1983/3-1/lap/processor-time.b version [e2b9d7356d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/program-command-interpreter.b version [1461e9b5b3].
cannot compute difference between binary files
Added psl-1983/3-1/lap/psl-input-stream.b version [1eca3d8128].
cannot compute difference between binary files
Added psl-1983/3-1/lap/psl-output-stream.b version [c1c56b970e].
cannot compute difference between binary files
Added psl-1983/3-1/lap/pslcomp-main.b version [7ef18d4efc].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rawbreak.b version [4c12a0c698].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rawio.b version [9b7a114d44].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rcref.b version [bee803dde8].
cannot compute difference between binary files
Added psl-1983/3-1/lap/read-utils.b version [8c1be087b2].
cannot compute difference between binary files
Added psl-1983/3-1/lap/ring-buffer.b version [81df12c16f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rlisp.b version [4c1b16e60b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rlispcomp.b version [27f601fb81].
cannot compute difference between binary files
Added psl-1983/3-1/lap/rprint.b version [956565556b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/slow-strings.b version [9cf85c25ee].
cannot compute difference between binary files
Added psl-1983/3-1/lap/slow-vectors.b version [9e8e1794c6].
cannot compute difference between binary files
Added psl-1983/3-1/lap/sm.b version [f39055060d].
cannot compute difference between binary files
Added psl-1983/3-1/lap/step.b version [37d4a4a8ec].
cannot compute difference between binary files
Added psl-1983/3-1/lap/string-input.b version [1b650fc053].
cannot compute difference between binary files
Added psl-1983/3-1/lap/string-search.b version [8f8877246f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/strings.b version [31d24befec].
cannot compute difference between binary files
Added psl-1983/3-1/lap/stringx.b version [5ab499705b].
cannot compute difference between binary files
Added psl-1983/3-1/lap/syslisp-syntax.b version [adde92fb28].
cannot compute difference between binary files
Added psl-1983/3-1/lap/syslisp.lap version [3b53b3cd99].
> | 1 | (load syslisp-syntax data-machine) |
Added psl-1983/3-1/lap/useful.b version [10fa847508].
cannot compute difference between binary files
Added psl-1983/3-1/lap/util.b version [f3fb08df29].
cannot compute difference between binary files
Added psl-1983/3-1/lap/vector-fix.b version [c3b313dff0].
cannot compute difference between binary files
Added psl-1983/3-1/lap/wait.b version [5f67bf4d26].
cannot compute difference between binary files
Added psl-1983/3-1/lap/windows.lap version [28e9e795da].
> > | 1 2 | (faslin "pwb:windows-20.b") (window-load-all) |
Added psl-1983/3-1/lap/zbasic.b version [dc24c4c6e4].
cannot compute difference between binary files
Added psl-1983/3-1/lap/zboot.b version [b4ba470132].
cannot compute difference between binary files
Added psl-1983/3-1/lap/zfiles.b version [24250affaa].
cannot compute difference between binary files
Added psl-1983/3-1/lap/zmacro.b version [f0239d471f].
cannot compute difference between binary files
Added psl-1983/3-1/lap/zpedit.b version [f8c995eecd].
cannot compute difference between binary files
Added psl-1983/3-1/lpt/0-titlepage.lpt version [10d3f09334].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | TR-10 March 1981 THE PORTABLE STANDARD LISP USERS MANUAL THE PORTABLE STANDARD LISP USERS MANUAL THE PORTABLE STANDARD LISP USERS MANUAL BY BY BY THE UTAH SYMBOLIC COMPUTATION GROUP THE UTAH SYMBOLIC COMPUTATION GROUP THE UTAH SYMBOLIC COMPUTATION GROUP Department of Computer Science University of Utah Salt Lake City, Utah 84112 Version 3.1: 7 February 1983 ABSTRACT ABSTRACT ABSTRACT This manual describes the primitive data structures, facilities and functions present in the Portable Standard LISP (PSL) system. It describes the implementation details and functions of interest to a PSL programmer. Except for a small number of hand-coded routines for I/O and efficient function calling, PSL is written entirely in itself, using a machine-oriented mode of PSL, called SYSLISP, to perform word, byte, and efficient integer and string operations. PSL is compiled by an enhanced version of the Portable LISP Compiler, and currently runs on the DEC-20, VAX, and MC68000. Copyright (c) 1982 W. Galway, M. L. Griss, B. Morrison, and B. Othmer Work supported in part by the National Science Foundation under Grant Numbers MCS80-07034 and MCS82-04247. |
Added psl-1983/3-1/lpt/00-preface.lpt version [0e09c5f676].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Preface Preface Preface This Portable LISP implementation would not have been started without the effort and inspiration of the original STANDARD LISP reporters (A. C. Hearn, J. Marti, M. L. Griss and C. Griss) and the many people who gave freely of their advice (often unsolicited!). We especially appreciate the comments of A. Norman, M. Rothstein, H. Stoyan and T. Ager. It would not have been completed without the efforts of the many people who have worked arduously on SYSLISP and PSL at various levels: Eric Benson, Will Galway, Ellen Gibson, Martin Griss, Bob Kessler, Steve Lowder, Chip Maguire, Beryl Morrison, Don Morrison, Bobbie Othmer, Bob Pendleton, and John Peterson. We are also grateful for the many comments and significant contributions by the LISP users at the Hewlett-Packard Computer Research Center in Palo Alto. This document has been worked on by most members of the current Utah Symbolic Computation Group. The primary editorial function has been in the hands of B. Morrison, M. L. Griss, B. Othmer, and W. Galway; major sections have been contributed by E. Benson, W. Galway, and D. Morrison. This is a preliminary version of the manual, and so may suffer from a number of errors and omissions. Please let us know of problems you may detect. We have also made some stylistic decisions regarding Font to indicate semantic classification and Case to make symbols more readable. Based on feedback from users of the earlier 3.0 PSL release and manual, we have decided to use LISP syntax as the primary description language; where appropriate RLISP syntax also appears. We would appreciate comments on these and other decisions. Based on feedback from numerous users, this issue of the manual uses LISP syntax rather than RLISP as the primary description language; where appropriate, RLISP syntax also appears. Report bugs, errors and mis-features by sending MAIL to PSL-BUGS@Utah-20; Bug Bug alternatively, send a message to Griss from within PSL by calling the Bug function, BUG(); in RLISP. Permission is given to copy this manual for internal use with the PSL system. |
Added psl-1983/3-1/lpt/000-contents.lpt version [46ecf5d04d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 page i Table of Contents TABLE OF CONTENTS TABLE OF CONTENTS TABLE OF CONTENTS CHAPTER 1. INTRODUCTION CHAPTER 1. INTRODUCTION CHAPTER 1. INTRODUCTION 1.1. Opening Remarks . . . . . . . . . . . . . . 1.1 1.2. Scope of the Manual . . . . . . . . . . . . . 1.2 1.2.1. Typographic Conventions within the Manual . . . 1.2 1.2.2. The Organization of the Manual . . . . . . . 1.3 CHAPTER 2. GETTING STARTED WITH PSL CHAPTER 2. GETTING STARTED WITH PSL CHAPTER 2. GETTING STARTED WITH PSL 2.1. Purpose of This Chapter. . . . . . . . . . . . 2.1 2.2. Defining Logical Device Names for PSL . . . . . . . 2.1 2.2.1. DEC-20 . . . . . . . . . . . . . . . 2.2 2.2.2. VAX . . . . . . . . . . . . . . . . 2.2 2.3. Starting PSL . . . . . . . . . . . . . . . 2.3 2.3.1. DEC-20 . . . . . . . . . . . . . . . 2.3 2.3.2. VAX . . . . . . . . . . . . . . . . 2.3 2.4. Running the PSL System . . . . . . . . . . . . 2.4 2.4.1. Loading Optional Modules . . . . . . . . . 2.4 2.4.2. Notes on Running PSL and RLISP . . . . . . . 2.4 2.4.3. Transcript of a Short Session with PSL . . . . 2.5 2.5. Error and Warning Messages. . . . . . . . . . . 2.8 2.6. Compilation Versus Interpretation . . . . . . . . 2.8 2.7. Function Types. . . . . . . . . . . . . . . 2.9 2.8. Switches and Globals. . . . . . . . . . . . . 2.10 2.9. Reporting Errors and Misfeatures. . . . . . . . . 2.10 CHAPTER 3. RLISP SYNTAX CHAPTER 3. RLISP SYNTAX CHAPTER 3. RLISP SYNTAX 3.1. Motivation for RLISP Interface to PSL . . . . . . . 3.1 3.2. An Introduction to RLISP . . . . . . . . . . . 3.2 3.2.1. LISP equivalents of some RLISP constructs . . . 3.2 3.3. An Overview of RLISP and LISP Syntax Correspondence . . 3.3 3.3.1. Function Call Syntax in RLISP and LISP . . . . 3.3 ... 3.3.2. RLISP Infix Operators and Associated LISP Functions....3.4 3.3.3. Differences between Parse and Read. . . . . . 3.6 3.3.4. Procedure Definition . . . . . . . . . . 3.6 3.3.5. Compound Statement Grouping . . . . . . . . 3.7 3.3.6. Blocks with Local Variables . . . . . . . . 3.7 PSL Manual 7 February 1983 page ii Table of Contents 3.3.7. The If Then Else Statement . . . . . . . . 3.8 3.4. Looping Statements . . . . . . . . . . . . . 3.8 3.4.1. While Loop. . . . . . . . . . . . . . 3.8 3.4.2. Repeat Loop . . . . . . . . . . . . . 3.8 3.4.3. For Each Loop. . . . . . . . . . . . . 3.8 3.4.4. For Loop . . . . . . . . . . . . . . 3.9 3.4.5. Loop Examples. . . . . . . . . . . . . 3.9 3.5. Switch Syntax . . . . . . . . . . . . . . . 3.10 3.6. RLISP I/O Syntax . . . . . . . . . . . . . . 3.10 3.7. Transcript of a Short Session with RLISP . . . . . . 3.10 CHAPTER 4. DATA TYPES CHAPTER 4. DATA TYPES CHAPTER 4. DATA TYPES 4.1. Data Types and Structures Supported in PSL . . . . . 4.1 4.1.1. Data Types. . . . . . . . . . . . . . 4.1 4.1.2. Other Notational Conventions. . . . . . . . 4.3 4.1.3. Structures. . . . . . . . . . . . . . 4.4 4.2. Predicates Useful with Data Types . . . . . . . . 4.5 4.2.1. Functions for Testing Equality . . . . . . . 4.5 4.2.2. Predicates for Testing the Type of an Object . . 4.7 4.2.3. Boolean Functions . . . . . . . . . . . 4.8 4.3. Converting Data Types . . . . . . . . . . . . 4.9 CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS 5.1. Big Integers . . . . . . . . . . . . . . . 5.1 5.2. Conversion Between Integers and Floats. . . . . . . 5.1 5.3. Arithmetic Functions. . . . . . . . . . . . . 5.2 5.4. Functions for Numeric Comparison. . . . . . . . . 5.5 5.5. Bit Operations. . . . . . . . . . . . . . . 5.7 5.6. Various Mathematical Functions . . . . . . . . . 5.8 CHAPTER 6. IDENTIFIERS CHAPTER 6. IDENTIFIERS CHAPTER 6. IDENTIFIERS 6.1. Introduction . . . . . . . . . . . . . . . 6.1 6.2. Fields of Ids . . . . . . . . . . . . . . . 6.2 6.3. Identifiers and the Id hash table . . . . . . . . 6.2 6.3.1. Identifier Functions . . . . . . . . . . 6.3 6.3.2. Find. . . . . . . . . . . . . . . . 6.4 6.4. Property List Functions. . . . . . . . . . . . 6.4 6.4.1. Functions for Flagging Ids . . . . . . . . 6.6 6.4.2. Direct Access to the Property Cell. . . . . . 6.7 6.5. Value Cell Functions. . . . . . . . . . . . . 6.7 6.6. Package System Functions . . . . . . . . . . . 6.10 6.7. System Global Variables, Switches and Other "Hooks" . . 6.13 6.7.1. Introduction . . . . . . . . . . . . . 6.13 PSL Manual 7 February 1983 page iii Table of Contents 6.7.2. Setting Switches. . . . . . . . . . . . 6.14 6.7.3. Special Global Variables . . . . . . . . . 6.15 6.7.4. Special Put Indicators. . . . . . . . . . 6.15 6.7.5. Special Flag Indicators . . . . . . . . . 6.16 6.7.6. Displaying Information About Globals . . . . . 6.16 CHAPTER 7. LIST STRUCTURE CHAPTER 7. LIST STRUCTURE CHAPTER 7. LIST STRUCTURE 7.1. Introduction to Lists and Pairs . . . . . . . . . 7.1 7.2. Basic Functions on Pairs . . . . . . . . . . . 7.2 7.3. Functions for Manipulating Lists. . . . . . . . . 7.4 7.3.1. Selecting List Elements . . . . . . . . . 7.4 7.3.2. Membership and Length of Lists . . . . . . . 7.6 7.3.3. Constructing, Appending, and Concatenating Lists . 7.6 7.3.4. Lists as Sets. . . . . . . . . . . . . 7.7 7.3.5. Deleting Elements of Lists . . . . . . . . 7.8 7.3.6. List Reversal. . . . . . . . . . . . . 7.9 7.4. Functions for Building and Searching A-Lists. . . . . 7.10 7.5. Substitutions . . . . . . . . . . . . . . . 7.11 CHAPTER 8. STRINGS AND VECTORS CHAPTER 8. STRINGS AND VECTORS CHAPTER 8. STRINGS AND VECTORS 8.1. Vector-Like Objects . . . . . . . . . . . . . 8.1 8.2. Strings . . . . . . . . . . . . . . . . . 8.1 8.3. Vectors . . . . . . . . . . . . . . . . . 8.3 8.4. Word Vectors . . . . . . . . . . . . . . . 8.5 8.5. General X-Vector Operations . . . . . . . . . . 8.5 8.6. Arrays . . . . . . . . . . . . . . . . . 8.7 8.7. Common LISP String Functions . . . . . . . . . . 8.7 CHAPTER 9. FLOW OF CONTROL CHAPTER 9. FLOW OF CONTROL CHAPTER 9. FLOW OF CONTROL 9.1. Introduction . . . . . . . . . . . . . . . 9.1 9.2. Conditionals . . . . . . . . . . . . . . . 9.1 9.2.1. Conds and Ifs. . . . . . . . . . . . . 9.1 9.2.2. The Case Statement . . . . . . . . . . . 9.3 9.3. Sequencing Evaluation . . . . . . . . . . . . 9.4 9.4. Iteration . . . . . . . . . . . . . . . . 9.6 9.4.1. For . . . . . . . . . . . . . . . . 9.8 9.4.2. Mapping Functions . . . . . . . . . . . 9.13 9.4.3. Do . . . . . . . . . . . . . . . . 9.15 9.5. Non-Local Exits . . . . . . . . . . . . . . 9.17 PSL Manual 7 February 1983 page iv Table of Contents CHAPTER 10. FUNCTION DEFINITION AND BINDING CHAPTER 10. FUNCTION DEFINITION AND BINDING CHAPTER 10. FUNCTION DEFINITION AND BINDING 10.1. Function Definition in PSL . . . . . . . . . . 10.1 10.1.1. Notes on Code Pointers . . . . . . . . . 10.1 10.1.2. Functions Useful in Function Definition. . . . 10.2 10.1.3. Function Definition in LISP Syntax . . . . . 10.4 10.1.4. Function Definition in RLISP Syntax . . . . . 10.5 10.1.5. Low Level Function Definition Primitives . . . 10.6 10.1.6. Function Type Predicates. . . . . . . . . 10.7 10.2. Variables and Bindings. . . . . . . . . . . . 10.7 10.2.1. Binding Type Declaration. . . . . . . . . 10.8 10.2.2. Binding Type Predicates . . . . . . . . . 10.9 10.3. User Binding Functions. . . . . . . . . . . . 10.9 10.3.1. Funargs, Closures and Environments . . . . . 10.10 CHAPTER 11. THE INTERPRETER CHAPTER 11. THE INTERPRETER CHAPTER 11. THE INTERPRETER 11.1. Evaluator Functions Eval and Apply. . . . . . . . 11.1 11.2. Support Functions for Eval and Apply . . . . . . . 11.5 11.3. Special Evaluator Functions, Quote, and Function . . . 11.6 11.4. Support Functions for Macro Evaluation . . . . . . 11.7 CHAPTER 12. INPUT AND OUTPUT CHAPTER 12. INPUT AND OUTPUT CHAPTER 12. INPUT AND OUTPUT 12.1. Introduction . . . . . . . . . . . . . . . 12.1 12.2. The Underlying Primitives for Input and Output. . . . 12.1 12.3. Opening, Closing, and Selecting Channels. . . . . . 12.4 12.4. Functions for Printing. . . . . . . . . . . . 12.6 12.5. Functions for Reading . . . . . . . . . . . . 12.13 12.5.1. Reading S-Expression . . . . . . . . . . 12.13 12.5.2. Reading Files into PSL . . . . . . . . . 12.14 12.5.3. Reading Single Characters . . . . . . . . 12.15 12.5.4. Reading Tokens . . . . . . . . . . . . 12.16 12.5.5. Read Macros . . . . . . . . . . . . . 12.24 12.6. Scan Table Utility Functions. . . . . . . . . . 12.25 12.7. I/O to and from Lists and Strings . . . . . . . . 12.25 12.8. Example of Simple I/O in PSL. . . . . . . . . . 12.27 CHAPTER 13. USER INTERFACE CHAPTER 13. USER INTERFACE CHAPTER 13. USER INTERFACE 13.1. Introduction . . . . . . . . . . . . . . . 13.1 13.2. Stopping PSL and Saving a New Executable Core Image . . 13.1 13.3. Init Files. . . . . . . . . . . . . . . . 13.3 13.4. Changing the Default Top Level Function . . . . . . 13.3 13.5. The General Purpose Top Loop Function. . . . . . . 13.4 PSL Manual 7 February 1983 page v Table of Contents 13.6. The HELP Mechanism . . . . . . . . . . . . . 13.7 13.7. The Break Loop . . . . . . . . . . . . . . 13.8 13.8. Terminal Interaction Commands in RLISP . . . . . . 13.8 CHAPTER 14. ERROR HANDLING CHAPTER 14. ERROR HANDLING CHAPTER 14. ERROR HANDLING 14.1. Introduction . . . . . . . . . . . . . . . 14.1 14.2. The Basic Error Functions. . . . . . . . . . . 14.1 14.3. Break Loop. . . . . . . . . . . . . . . . 14.4 14.4. Interrupt Keys . . . . . . . . . . . . . . 14.8 14.5. Details on the Break Loop. . . . . . . . . . . 14.8 14.6. Some Convenient Error Calls . . . . . . . . . . 14.8 14.7. Special Purpose Error Handlers . . . . . . . . . 14.10 CHAPTER 15. DEBUGGING TOOLS CHAPTER 15. DEBUGGING TOOLS CHAPTER 15. DEBUGGING TOOLS 15.1. Introduction . . . . . . . . . . . . . . . 15.1 15.1.1. Brief Summary of Full Debug Package . . . . . 15.1 15.1.2. Mini-Trace Facility . . . . . . . . . . 15.2 15.1.3. Step . . . . . . . . . . . . . . . 15.3 .... 15.1.4. Functions Which Depend on Redefining User Functions..15.4 15.1.5. A Few Known Deficiencies. . . . . . . . . 15.4 15.2. Tracing Function Execution . . . . . . . . . . 15.5 15.2.1. Tracing Functions . . . . . . . . . . . 15.5 15.2.2. Saving Trace Output . . . . . . . . . . 15.6 15.2.3. Making Tracing More Selective . . . . . . . 15.7 15.2.4. Turning Off Tracing . . . . . . . . . . 15.8 15.2.5. Enabling Debug Facilities and Automatic Tracing . 15.9 15.3. A Heavy Handed Backtrace Facility . . . . . . . . 15.10 15.4. Embedded Functions . . . . . . . . . . . . . 15.11 15.5. Counting Function Invocations . . . . . . . . . 15.11 15.6. Stubs . . . . . . . . . . . . . . . . . 15.12 15.7. Functions for Printing Useful Information . . . . . 15.12 15.8. Printing Circular and Shared Structures . . . . . . 15.13 15.9. Internals and Customization . . . . . . . . . . 15.14 15.9.1. User Hooks . . . . . . . . . . . . . 15.14 15.9.2. Functions Used for Printing/Reading . . . . . 15.15 15.10. Example . . . . . . . . . . . . . . . . 15.16 CHAPTER 16. EDITORS CHAPTER 16. EDITORS CHAPTER 16. EDITORS 16.1. A Mini Structure-Editor . . . . . . . . . . . 16.1 16.2. The EMODE Screen Editor . . . . . . . . . . . 16.3 16.2.1. Windows and Buffers in Emode . . . . . . . 16.5 16.3. Introduction to the Full Structure Editor . . . . . 16.5 PSL Manual 7 February 1983 page vi Table of Contents 16.3.1. Starting the Structure Editor . . . . . . . 16.6 16.3.2. Structure Editor Commands . . . . . . . . 16.7 CHAPTER 17. MISCELLANEOUS UTILITIES CHAPTER 17. MISCELLANEOUS UTILITIES CHAPTER 17. MISCELLANEOUS UTILITIES 17.1. Introduction . . . . . . . . . . . . . . . 17.1 17.2. RCREF - Cross Reference Generator for PSL Files . . . 17.1 17.2.1. Restrictions. . . . . . . . . . . . . 17.2 17.2.2. Usage . . . . . . . . . . . . . . . 17.3 17.2.3. Options . . . . . . . . . . . . . . 17.3 17.3. Picture RLISP. . . . . . . . . . . . . . . 17.4 17.4. Tools for Defining Macros. . . . . . . . . . . 17.11 17.4.1. DefMacro . . . . . . . . . . . . . . 17.12 17.4.2. BackQuote. . . . . . . . . . . . . . 17.12 17.4.3. Sharp-Sign Macros . . . . . . . . . . . 17.13 17.4.4. MacroExpand . . . . . . . . . . . . . 17.14 17.4.5. DefLambda. . . . . . . . . . . . . . 17.14 17.5. Simulating a Stack . . . . . . . . . . . . . 17.14 17.6. DefStruct . . . . . . . . . . . . . . . . 17.15 17.6.1. Options . . . . . . . . . . . . . . 17.17 17.6.2. Slot Options. . . . . . . . . . . . . 17.18 17.6.3. A Simple Example . . . . . . . . . . . 17.18 17.7. DefConst . . . . . . . . . . . . . . . . 17.22 17.8. Functions for Sorting . . . . . . . . . . . . 17.22 17.9. Hashing Cons . . . . . . . . . . . . . . . 17.24 17.10. Graph-to-Tree . . . . . . . . . . . . . . 17.25 17.11. Inspect Utility. . . . . . . . . . . . . . 17.26 CHAPTER 18. LOADER AND COMPILER CHAPTER 18. LOADER AND COMPILER CHAPTER 18. LOADER AND COMPILER 18.1. Introduction . . . . . . . . . . . . . . . 18.1 18.2. The Compiler . . . . . . . . . . . . . . . 18.1 18.2.1. Compiling Functions into Memory . . . . . . 18.2 18.2.2. Compiling Functions into FASL Files . . . . . 18.2 18.2.3. Loading FASL Files. . . . . . . . . . . 18.3 18.2.4. Functions to Control the Time When Something is Done 18.4 . 18.2.5. Order of Functions for Compilation . . . . . 18.5 18.2.6. Fluid and Global Declarations . . . . . . . 18.5 18.2.7. Switches Controlling Compiler . . . . . . . 18.6 18.2.8. Differences between Compiled and Interpreted Code 18.7 18.2.9. Compiler Errors. . . . . . . . . . . . 18.8 18.3. The Loader. . . . . . . . . . . . . . . . 18.9 18.3.1. Legal LAP Format and Pseudos . . . . . . . 18.10 18.3.2. Examples of LAP for DEC-20, VAX and Apollo. . . 18.10 18.3.3. Lap Switches. . . . . . . . . . . . . 18.13 18.4. Structure and Customization of the Compiler. . . . . 18.14 18.5. First PASS of Compiler. . . . . . . . . . . . 18.14 PSL Manual 7 February 1983 page vii Table of Contents 18.5.1. Tagging Information . . . . . . . . . . 18.15 18.5.2. Source to Source Transformations . . . . . . 18.15 18.6. Second PASS - Basic Code Generation . . . . . . . 18.15 18.6.1. The Cmacros . . . . . . . . . . . . . 18.15 18.6.2. Classes of Functions . . . . . . . . . . 18.18 18.6.3. Open Functions . . . . . . . . . . . . 18.18 18.7. Third PASS - Optimizations . . . . . . . . . . 18.22 18.8. Some Structural Notes on the Compiler. . . . . . . 18.23 CHAPTER 19. OPERATING SYSTEM INTERFACE CHAPTER 19. OPERATING SYSTEM INTERFACE CHAPTER 19. OPERATING SYSTEM INTERFACE 19.1. Introduction . . . . . . . . . . . . . . . 19.1 19.2. System Dependent Functions . . . . . . . . . . 19.1 19.3. TOPS-20 Interface . . . . . . . . . . . . . 19.2 19.3.1. User Level Interface . . . . . . . . . . 19.2 19.3.2. The Basic Fork Manipulation Functions . . . . 19.4 19.3.3. File Manipulation Functions. . . . . . . . 19.5 19.3.4. Miscellaneous Functions . . . . . . . . . 19.6 19.3.5. Jsys Interface . . . . . . . . . . . . 19.6 19.3.6. Bit, Word and Address Operations for Jsys Calls . 19.8 19.3.7. Examples . . . . . . . . . . . . . . 19.9 19.4. New Vax Specific Interface . . . . . . . . . . 19.10 19.4.1. Setting Your .LOGIN and .CSHRC files. . . . . 19.10 19.4.2. Important PSL executables . . . . . . . . 19.11 19.4.3. Creating the Init Files . . . . . . . . . 19.11 19.4.4. Directories and Symbols . . . . . . . . 19.11 19.4.5. Miscellaneous Unix Interface Functions . . . 19.14 19.4.6. Oload . . . . . . . . . . . . . . 19.14 19.4.7. Calling oloaded functions . . . . . . . . 19.15 19.4.8. OLOAD Internals. . . . . . . . . . . . 19.16 19.4.9. I/O Control functions . . . . . . . . . 19.17 19.5. Apollo System Calls. . . . . . . . . . . . . 19.18 CHAPTER 20. SYSLISP CHAPTER 20. SYSLISP CHAPTER 20. SYSLISP 20.1. Introduction to the SYSLISP level of PSL. . . . . . 20.1 20.2. The Relationship of SYSLISP to RLISP . . . . . . . 20.2 20.2.1. SYSLISP Declarations . . . . . . . . . . 20.2 20.2.2. SYSLISP Mode Analysis. . . . . . . . . . 20.3 20.2.3. Defining Special Functions for Mode Analysis . . 20.3 20.2.4. Modified FOR Loop . . . . . . . . . . . 20.4 20.2.5. Char and IDLOC Macros. . . . . . . . . . 20.4 20.2.6. The Case Statement. . . . . . . . . . . 20.5 20.2.7. Memory Access and Address Operations. . . . . 20.7 20.2.8. Bit-Field Operation . . . . . . . . . . 20.7 20.3. Using SYSLISP. . . . . . . . . . . . . . . 20.9 20.3.1. To Compile SYSLISP Code . . . . . . . . . 20.9 20.4. SYSLISP Functions . . . . . . . . . . . . . 20.10 PSL Manual 7 February 1983 page viii Table of Contents 20.4.1. W-Arrays . . . . . . . . . . . . . . 20.11 20.5. Remaining SYSLISP Issues . . . . . . . . . . . 20.11 20.5.1. Stand Alone SYSLISP Programs . . . . . . . 20.11 20.5.2. Need for Two Stacks . . . . . . . . . . 20.12 20.5.3. New Mode System. . . . . . . . . . . . 20.12 20.5.4. Extend CREF for SYSLISP . . . . . . . . . 20.12 CHAPTER 21. IMPLEMENTATION CHAPTER 21. IMPLEMENTATION CHAPTER 21. IMPLEMENTATION 21.1. Overview of the Implementation . . . . . . . . . 21.1 21.2. Files of Interest . . . . . . . . . . . . . 21.1 21.3. Building PSL on the DEC-20 . . . . . . . . . . 21.2 21.4. Building the LAP to Assembly Translator . . . . . . 21.5 21.5. The Garbage Collectors and Allocators. . . . . . . 21.5 21.5.1. Compacting Garbage Collector on DEC-20 . . . . 21.5 21.5.2. Two-Space Stop and Copy Collector on VAX . . . 21.6 21.6. The HEAPs . . . . . . . . . . . . . . . . 21.6 21.7. Allocation Functions . . . . . . . . . . . . 21.8 CHAPTER 22. PARSER TOOLS CHAPTER 22. PARSER TOOLS CHAPTER 22. PARSER TOOLS 22.1. Introduction . . . . . . . . . . . . . . . 22.1 22.2. The Table Driven Parser . . . . . . . . . . . 22.2 22.2.1. Flow Diagram for the Parser. . . . . . . . 22.2 22.2.2. Associating the Infix Operator with a Function . 22.4 22.2.3. Precedences . . . . . . . . . . . . . 22.5 22.2.4. Special Cases of 0 <-0 and 0 0. . . . . . . 22.5 22.2.5. Parenthesized Expressions . . . . . . . . 22.5 22.2.6. Binary Operators in General. . . . . . . . 22.6 22.2.7. Assigning Precedences to Key Words . . . . . 22.7 22.2.8. Error Handling . . . . . . . . . . . . 22.7 22.2.9. The Parser Program for the RLISP Language . . . 22.7 22.2.10. Defining Operators . . . . . . . . . . 22.8 22.3. The MINI Translator Writing System. . . . . . . . 22.10 22.3.1. A Brief Guide to MINI. . . . . . . . . . 22.10 22.3.2. Pattern Matching Rules . . . . . . . . . 22.12 22.3.3. A Small Example. . . . . . . . . . . . 22.12 22.3.4. Loading Mini. . . . . . . . . . . . . 22.12 22.3.5. Running Mini. . . . . . . . . . . . . 22.13 22.3.6. MINI Error messages and Error Recovery . . . . 22.13 22.3.7. MINI Self-Definition . . . . . . . . . . 22.13 22.3.8. The Construction of MINI. . . . . . . . . 22.15 22.3.9. History of MINI Development. . . . . . . . 22.16 22.4. BNF Description of RLISP Using MINI . . . . . . . 22.17 PSL Manual 7 February 1983 page ix Table of Contents CHAPTER 23. BIBLIOGRAPHY CHAPTER 23. BIBLIOGRAPHY CHAPTER 23. BIBLIOGRAPHY CHAPTER 24. INDEX OF CONCEPTS CHAPTER 24. INDEX OF CONCEPTS CHAPTER 24. INDEX OF CONCEPTS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 26. INDEX OF GLOBALS AND SWITCHES CHAPTER 26. INDEX OF GLOBALS AND SWITCHES CHAPTER 26. INDEX OF GLOBALS AND SWITCHES |
Added psl-1983/3-1/lpt/01-introduction.lpt version [6b5717432d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Introduction section 1.0 page 1.1 CHAPTER 1 CHAPTER 1 CHAPTER 1 INTRODUCTION INTRODUCTION INTRODUCTION 1.1. Opening Remarks . . . . . . . . . . . . . . 1.1 1.2. Scope of the Manual . . . . . . . . . . . . . 1.2 1.2.1. Typographic Conventions within the Manual . . . 1.2 1.2.2. The Organization of the Manual . . . . . . . 1.3 1.1. Opening Remarks 1.1. Opening Remarks 1.1. Opening Remarks 1 This document describes PSL (PORTABLE STANDARD LISP ), a portable, "modern" LISP developed at the University of Utah for a variety of machines. PSL is upward-compatible with STANDARD LISP [Marti 79]. In most cases, STANDARD LISP did not commit itself to specific implementation details (since it was to be compatible with a portion of "most" LISPs). PSL is more specific and provides many more functions than described in that report. The goals of PSL include: - Providing implementation tools for LISP that can be used to ____ implement a variety of LISP-like systems, including mini-lisps embedded in other language systems (such as existing PASCAL or ADA applications). - Effectively supporting the REDUCE algebra system on a number of machines, and providing algebra modules extracted from (or modeled upon) REDUCE to be included in applications such as CAI and CAGD. - Providing a uniform, modern LISP programming environment on all of the machines that we use (DEC-20, VAX, and 68000 based personal machines)--of the power of FRANZ LISP, UCI LISP or MACLISP. - Studying the utility of a LISP-based systems language for other applications (such as CAGD or VLSI design) in which SYSLISP code provides efficiency comparable to that of C or BCPL, yet enjoys _______________ 1 "LSP" backwards! Introduction 7 February 1983 PSL Manual page 1.2 section 1.1 the interactive program development and debugging environment of LISP. 1.2. Scope of the Manual 1.2. Scope of the Manual 1.2. Scope of the Manual This manual is intended to describe the syntax, semantics, and implementation of PSL. While we have attempted to make it comprehensive, it is not intended for use as a primer. Some prior exposure to LISP will prove very helpful. A selection of LISP primers is listed in the bibliography in Chapter 23; see for example [Allen 79, Charniak 80, Weissman 67, Winston 81]. 1.2.1. Typographic Conventions within the Manual 1.2.1. Typographic Conventions within the Manual 1.2.1. Typographic Conventions within the Manual A large proportion of this manual is devoted to descriptions of the functions that make up PSL. Each function is provided with a prototypical header line. Each argument is given a name and followed by its allowed type. If an argument type is not commonly used, it may be a specific set PutD PutD enclosed in brackets {...}. For example, this header shows that PutD (which defines other functions) takes three arguments: ____ ____ ____ PutD expr PutD _____ __ ____ _____ ____ ______ ____ _______ _____ __ expr (PutD FNAME:id TYPE:ftype BODY:{lambda, code-pointer}): FNAME:id expr _____ __ 1. FNAME, which is an id (identifier). ____ 2. TYPE, which is the "function type" of the function being defined. ____ ______ ____ _______ 3. BODY, which is a lambda expression or a code-pointer. _____ and returns FNAME, the name of the function being defined. Some functions are compiled open; these have a note saying "open-compiled" next to the function type. Some functions accept an arbitrary number of arguments. The header for these functions shows a single argument enclosed in square brackets-- indicating that zero or more occurrences of that argument are allowed. For example: And And _ ____ _____ _______ (And [U:form]): extra-boolean And And And is a function which accepts zero or more arguments each of which may ____ be any form. In some cases, LISP or RLISP code is given in the function documentation as the function's definition. As far as possible, the code is extracted from the the current PSL sources (perhaps converted from one syntax to the other); however, this code is not always necessarily actually used in PSL, and may be given only to clarify the semantics of the function. Please _____ check carefully if you depend on the exact definition. PSL Manual 7 February 1983 Introduction section 1.2 page 1.3 Some features of PSL are anticipated but not yet fully implemented. When these are documented in this manual they are indicated with the words: ___ ___________ ___ ___ ___________ ___ ___ ___________ ___ [not implemented yet] [not implemented yet] [not implemented yet]. 1.2.2. The Organization of the Manual 1.2.2. The Organization of the Manual 1.2.2. The Organization of the Manual This manual is arranged in separate chapters, which are meant to be self-contained units. Each begins with a small table of contents serving as a summary of constructs and as an aid in skimming. Here is a brief overview of the following chapters: Chapter 2 is particularly useful for those using PSL for the first time. It begins with directions for starting PSL and getting help. It also briefly discusses the handling of errors; some of the consequences of PSL being both a compiled and an interpreted language; function types; switches and globals. PSL treats the parameters for various function types rather differently from a number of other dialects, and the serious user should definitely become familiar with this information. While most LISP implementations use only a fully parenthesized syntax, PSL gives the user the option of using an ALGOL-like (or PASCAL-like) syntax (RLISP), which many users prefer. Chapter 3 describes the syntax of RLISP. Chapter 4 describes the data types used in PSL. It includes functions useful for testing equality and for changing data types, and predicates useful with data types. The next seven chapters describe in detail the basic functions provided by PSL. Chapters 5, 6, 7, and 8 describe functions for manipulating the basic ______ __ ____ ______ ______ data structures of LISP: numbers, ids, lists, and strings and vectors. As _______ __________ ____ virtually every LISP program uses integers, identifiers, and lists extensively, these three chapters (5, 6 and 7) should be included in an ______ ______ overview. As vectors and strings are used less extensively, Chapter 8 may be skipped on a first reading. Chapter 9 and, to some extent, Chapter 4 describe the basic functions used to drive a computation. The reader wanting an overview of PSL should certainly read these two. Chapter 10 describes functions useful in function definition and the idea of variable binding. The novice LISP user should definitely read this information before proceeding to the rest of the manual. Also described here is a proposed scheme for context-switching in the form of the funarg and closures. Chapter 11 describes functions associated with the interpreter. It Eval Apply Eval Apply includes functions having to do with evaluation (Eval and Apply.) Introduction 7 February 1983 PSL Manual page 1.4 section 1.2 Chapter 12 describes the I/O facilities. Most LISP programs do not require sophisticated I/O, so this may be skimmed on a first reading. The section dealing with input deals extensively with customizing the scanner and reader, which is only of interest to the sophisticated user. Chapter 13 presents information about the user interface for PSL. It includes some generally useful information on running the system. Chapter 14 discusses error handling. Much of the information is of interest primarily to the sophisticated user. However, LISP provides a convenient interactive facility for correcting certain errors which may be of interest to all, so a first reading should include parts of this chapter. Chapter 15 discusses some tools for debugging and statistics gathering based on the concept of embedding function definitions. Chapter 16 describes the structure editor, which permits the user to construct and modify list structure, including the bodies of interpreted functions, and erroneous expressions within the BREAK loop. It also describes EMODE, an EMACS-like screen editor. Chapter 17 briefly describes modules of useful tools. This includes the PSL cross-reference generator, and various tools for defining macros. The rest of the manual may be skipped on first reading. Chapter 18 describes functions associated with the compiler. Chapter 19 describes some functions for communicating with the TOPS-20 and UNIX operating systems. Chapter 20 describes SYSLISP, a language incorporating features from both BCPL and LISP and which is used as an implementation language for PSL. Chapter 21 presents details of the portable implementation which may be of interest to sophisticated users, including a description of the garbage collector. Chapter 22 describes the extensible parser. Section 22.4 provides BNF descriptions of the input accepted by the token scanner, standard reader, and syntactic (RLISP) reader. Chapter 23 contains the bibliography. Chapter 24 is an alphabetical index of concepts. Chapter 25 is an alphabetical index of all functions defined in the manual. Chapter 26 contains an alphabetical index of all global variables and switches defined in the manual. |
Added psl-1983/3-1/lpt/02-getstart.lpt version [03db65fd31].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Getting Started section 2.0 page 2.1 CHAPTER 2 CHAPTER 2 CHAPTER 2 GETTING STARTED WITH PSL GETTING STARTED WITH PSL GETTING STARTED WITH PSL 2.1. Purpose of This Chapter. . . . . . . . . . . . 2.1 2.2. Defining Logical Device Names for PSL . . . . . . . 2.1 2.2.1. DEC-20 . . . . . . . . . . . . . . . 2.2 2.2.2. VAX . . . . . . . . . . . . . . . . 2.2 2.3. Starting PSL . . . . . . . . . . . . . . . 2.3 2.3.1. DEC-20 . . . . . . . . . . . . . . . 2.3 2.3.2. VAX . . . . . . . . . . . . . . . . 2.3 2.4. Running the PSL System . . . . . . . . . . . . 2.4 2.4.1. Loading Optional Modules . . . . . . . . . 2.4 2.4.2. Notes on Running PSL and RLISP . . . . . . . 2.4 2.4.3. Transcript of a Short Session with PSL . . . . 2.5 2.5. Error and Warning Messages. . . . . . . . . . . 2.8 2.6. Compilation Versus Interpretation . . . . . . . . 2.8 2.7. Function Types. . . . . . . . . . . . . . . 2.9 2.8. Switches and Globals. . . . . . . . . . . . . 2.10 2.9. Reporting Errors and Misfeatures. . . . . . . . . 2.10 2.1. Purpose of This Chapter 2.1. Purpose of This Chapter 2.1. Purpose of This Chapter This chapter is for beginning users of PSL on the DEC-20 and the VAX 750 and 780 at Utah. It also is meant to be a guide to those familiar with LISP, and particularly STANDARD LISP, who would like to use PSL as they read the manual. It begins with descriptions of how to set up various logical device definitions required by PSL and how to run PSL. A number of miscellaneous hints and reminders are given in the remainder of the chapter. 2.2. Defining Logical Device Names for PSL 2.2. Defining Logical Device Names for PSL 2.2. Defining Logical Device Names for PSL When PSL is installed on your system, the person doing the installation has the option of using a number of different directory structures and names, depending on local conventions and available space. There are also options to select a small system (without all source-code online) or a full system. Also, as each release of PSL is prepared, we may find it convenient to change the names and number of sub-directories. In order to minimize the inconvenience, an attempt has been made to refer to such directories through some form of logical name ("logical device name" on DEC-20, shell-variable or link on VAX-UNIX, etc.). In some cases these can be used as if they were directory names (DEC-20), and in some cases not (VAX). These definitions are edited at installation time to reflect local Getting Started 7 February 1983 PSL Manual page 2.2 section 2.2 usage, and stored in a file whose name is something like "logical-names.xxx". This file will be placed on an appropriate directory (often <PSL> on the DEC-20, ~psl on the VAX, etc.). A message should be sent out by your installer to indicate where the file is, and its name. It is suggested that a use of this file be placed in your LOGIN.CMD , .cshrc or equivalent file. 2.2.1. DEC-20 2.2.1. DEC-20 2.2.1. DEC-20 It is absolutely essential that TAKE <PSL>LOGICAL-NAMES.CMD be inserted in your LOGIN.CMD file, or executed at EXEC level before using PSL. PSL is written to rely on these logical device definitions in place of "hard-coded" directory names. PSL also uses TOPS-20 search paths, so that for example, "PH:" is defined as the directory (or search list) on which PSL looks for help files, "PL:" is the directory (or search list) on which Lap Fasl Lap Fasl PSL looks for Lap and Fasl files of the form "xxxx.b", etc. The logical name "PSL:" is defined to be the directory on which the PSL executables reside. Thus "PSL:PSL.EXE" should start PSL executing. There should usually be a PSL:BARE-PSL.EXE, PSL:PSL.EXE and PSL:RLISP.EXE. BARE-PSL is the minimum system that is constructed during the PSL build sequence. PSL and RLISP usually contain additional modules selected by the installer, felt to be most commonly used by your community. 2.2.2. VAX 2.2.2. VAX 2.2.2. VAX In the current version of UNIX (4.1) there is no equivalent of logical device definitions that can be used to access files on other directories from within PSL or many UNIX utilities. We have defined a set of shell variables ($ variables) that may be used outside of an executing PSL to refer to the appropriate directories, and a series of PSL global variables for use inside PSL that contain the equivalent of search paths. In a future release of PSL for the VAX, we may be able to look up such shell or environment variables during the attempt to OPEN a file. These variables are defined in the file "psl-names", usually on the directory "~psl" (actually /u/local/psl at UTAH). Insert a "source ~psl/psl-names" or equivalent in your .cshrc file. Variables such as "$psl", "$pl", and "$pu" (on which many utility sources are stored) are defined. There should usually be a "$psl/bare-psl", "$psl/psl" and "$psl/rlisp". Bare-psl is the minimum system that is constructed during the PSL build sequence. PSL and RLISP usually contain additional modules selected by the installer, felt to be most commonly used by your community. PSL Manual 7 February 1983 Getting Started section 2.3 page 2.3 2.3. Starting PSL 2.3. Starting PSL 2.3. Starting PSL 2.3.1. DEC-20 2.3.1. DEC-20 2.3.1. DEC-20 After defining the device names, type either PSL:RLISP or PSL:PSL to the at-sign prompt, @. A welcome message indicates the nature of the system running, usually with a date and version number. This information may be useful in describing problems. [Messages concerning bugs or misfeatures should be directed to PSL-BUGS@UTAH-20; see Section 2.9.] BARE-PSL.EXE is a "bare" PSL using LISP (i.e. parenthesis) syntax. This is a small core-image and is ideal for simple LISP execution. It also Fasl Fasl includes a resident Fasl, so additional modules can be loaded. In particular, the compiler is not normally part of PSL.EXE. RLISP.EXE is PSL with additional modules loaded, corresponding to the most common system run at Utah. It contains the compiler and an RLISP parser. For more information about RLISP see Chapter 3. It is assumed by PSL and RLISP that file names be of the form "*.sl" or Fasl Fasl "*.lsp" for LISP files, "*.red" for RLISP files, "*.b" for Fasl files, and Lap Lap "*.lap" for Lap files. 2.3.2. VAX 2.3.2. VAX 2.3.2. VAX The executable files are $psl/psl and $psl/rlisp. Loadable modules are on $pl/*.b or $pl/*.lap. Help files are on $ph/*.hlp. $psl/rlisp has the RLISP parser and compiler. Additional modules can be Load Error Load Error loaded from $pl using the Load function. <Ctrl-C> causes a call to Error, and may be used to stop a runaway computation. <Ctrl-Z> or the function Quit Quit Quit cause the process to be stopped, and control returned to the shell; the process may be continued. A sequence of <Ctrl-D>'s (EOF) causes the process to be terminated. This is to allow the use of I/O redirection from the shell. [??? Add Cntrl-B for BREAK loop call ???] [??? Add Cntrl-B for BREAK loop call ???] [??? Add Cntrl-B for BREAK loop call ???] Unix 4.1 and 4.1a allow only 14 characters for file names, and case is significant. The use of ".r" instead of ".red" is recommended as the extension for RLISP files to save on meaningful characters; other extensions are as on the DEC-20. Getting Started 7 February 1983 PSL Manual page 2.4 section 2.4 2.4. Running the PSL System 2.4. Running the PSL System 2.4. Running the PSL System The following sub-sections collect a few miscellaneous notes that are further expanded on elsewhere. They are provided here simply to get you started. 2.4.1. Loading Optional Modules 2.4.1. Loading Optional Modules 2.4.1. Loading Optional Modules Certain modules are not present in the "kernel" or "bare-psl" system, but can be loaded as options. Some of these optional modules will "auto-load" when first referenced; others may be explicitly loaded by the user, or included by the installer when building the "PSL" and "RLISP" core images. Optional modules can be loaded by executing LOAD modulename; % in RLISP syntax or (LOAD modulename) % in LISP syntax. The global variable OPTIONS!* contains a list of modules currently loaded; it does not mention those in the "bare-psl" kernel. Do not reset this variable; it is used by LOAD to avoid loading already present modules. RELOAD RELOAD [See RELOAD in Chapter 18]. 2.4.2. Notes on Running PSL and RLISP 2.4.2. Notes on Running PSL and RLISP 2.4.2. Notes on Running PSL and RLISP Help Help Help Help a. Use Help(); [(Help) in LISP] for general help or an indication Help Help Help Help of what help is available; use Help (a, b, c); [(Help a b c) in LISP] for information on topics a, b, and c. This call prints Help Help files from the PH: (i.e. <PSL.HELP>) directory. Try Help x; Help Help [(Help x) in LISP] on: ? Exec Mini Step Br Find MiniEditor Strings Break Switches MiniTrace TopLoop Bug For Package Tr Debug Globals PRLISP Trace Defstruct GSort PSL UnBr Edit Help RCREF UnTr EditF JSYS RLISP Useful Editor Load ShowSwitches ZFiles Emode Manual Slate ZPEdit EWindow [??? Help() does not work in RLISP ???] [??? Help() does not work in RLISP ???] [??? Help() does not work in RLISP ???] b. File I/O needs string-quotes (") around file names. File names may use full TOPS-20 or UNIX conventions, including directories, PSL Manual 7 February 1983 Getting Started section 2.4 page 2.5 sub-directories, etc. IN IN Input in RLISP mode is done using the 'IN "File-Name";' command. Dskin Dskin Use (Dskin "File-Name") for input from LISP mode. For information on similar I/O functions see Chapter 12. Quit Quit Quit Quit c. Use Quit; [(Quit) in LISP] or <Ctrl-C> on the DEC-20 (<Ctrl-Z> on the VAX) to exit. <Ctrl-C> (<Ctrl-Z> on the VAX) is useful for stopping run-away computations. On the DEC-20, typing START or CONTINUE to the @ prompt from the EXEC usually restarts in a reasonable way. 2.4.3. Transcript of a Short Session with PSL 2.4.3. Transcript of a Short Session with PSL 2.4.3. Transcript of a Short Session with PSL The following is a transcript of running PSL on the DEC-20. Getting Started 7 February 1983 PSL Manual page 2.6 section 2.4 @psl:psl PSL 3.1, 11-Oct-82 1 Lisp> % Notice the numbered prompt. 1 Lisp> % Comments begin with "%" and do not change the prompt 1 Lisp> % number. 1 Lisp> (Setq Z '(1 2 3)) % Make an assignment for Z. (1 2 3) 2 Lisp> (Cdr Z) % Notice the change in prompt number. (2 3) 3 Lisp> (De Count (L) % Count counts the number or elements 3 Lisp> (Cond ((Null L) 0) % in a list L. 3 Lisp> (T (Add1 (Count (Cdr L)))))) COUNT 4 Lisp> (Count Z) % Call Count on Z. 3 5 Lisp> (Tr Count) % Trace the recursive execution of "Count". (COUNT) 6 Lisp> % A call on "Count" now shows the value of 6 Lisp> % "Count" and of its arguments each time 6 Lisp> (Count Z) % it is called. COUNT being entered L: (1 2 3) COUNT (level 2) being entered L: (2 3) COUNT (level 3) being entered L: (3) COUNT (level 4) being entered L: NIL COUNT (level 4) = 0 COUNT (level 3) = 1 COUNT (level 2) = 2 COUNT = 3 3 7 Lisp> (De Factorial (X) 7 Lisp> (Cond ((Eq 1) 7 Lisp> (T (Times X (Factorial (Sub1 X)))))) FACTORIAL 8 Lisp> (Tr Factorial) (FACTORIAL) 9 Lisp> (Factorial 4) % Trace execution of "Factorial". FACTORIAL being entered X: 4 FACTORIAL (level 2) being entered X: 3 FACTORIAL (level 3) being entered X: 2 % Notice values being returned. FACTORIAL (level 4) being entered X: 1 FACTORIAL (level 4) = 1 FACTORIAL (level 3) = 2 FACTORIAL (level 2) = 6 PSL Manual 7 February 1983 Getting Started section 2.4 page 2.7 FACTORIAL = 24 24 10 Lisp> (Untr Count Factorial) NIL 11 Lisp> (Count 'A) % This generates an error causing the break % loop to be entered. ***** An attempt was made to do CDR on `A', which is not a pair Break loop 12 Lisp break>> ? BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, except that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet A Abort to top level, i.e. restart PSL C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. NIL 13 Lisp break>> % Get a Trace-Back of the 13 Lisp break>> I % interpreted functions. Backtrace, including interpreter functions, from top of stack: LIST2 CDR COUNT ADD1 COND COUNT LIST2 NIL 14 Lisp break>> Q % To exit the Break Loop. 15 Lisp> % Load in a file, showing its execution. 15 Lisp> % The file contains the following: 15 Lisp> % (Setq X (Cons 'A (Cons 'B Nil))) 15 Lisp> % (Count X) 15 Lisp> % (Reverse X) 15 Lisp> (Dskin "small-file.sl") (A B) 2 (B A) NIL 16 Lisp> (Quit) @continue "Continued" 17 Lisp> ^C @start 18 Lisp> (Quit) Getting Started 7 February 1983 PSL Manual page 2.8 section 2.5 2.5. Error and Warning Messages 2.5. Error and Warning Messages 2.5. Error and Warning Messages Many functions detect and signal appropriate errors (see Chapter 14 for details); in many cases, an error message is printed. The error conditions are given as part of a function's definition in the manual. An error message is preceded by five stars (*); a warning message is preceded by three. For example, most primitive functions check the type of their arguments and display an error message if an argument is incorrect. The type mismatch error mentions the function in which the error was detected, gives the expected type, and prints the actual value passed. Sometimes one sees a prompt of the form: Do you really want to redefine the system function `FOO'? This means you have tried to define a function with the same name as a function used by the PSL system. A Y, N, YES, NO, or B response is required. B starts a break loop. After quitting the break loop, answer Y, YesP YesP N, Yes, or No to the query. See the definition of YesP in Chapter 13. An affirmative response is extremely dangerous and should be given only if you are a system expert. Usually this means that your function must be given a different name. A common warning message is *** Function "FOO" has been redefined If this occurs without the query above, you are redefining your own function. This happens normally if you read a file, edit it, and read it in again. ________ The switch !*USERMODE controls whether redefinition of functions is "dangerous". When NIL, no query is generated. User functions entered when ________ !*USERMODE is on are flagged with the 'USER indicator, used by this ________ mechanism. The switch !*REDEFMSG, described in section 10.1.2, can be set to suppress these warning messages. There is also a property 'LOSE that will prevent redefinition; the new definition will be ignored, and a warning given. 2.6. Compilation Versus Interpretation 2.6. Compilation Versus Interpretation 2.6. Compilation Versus Interpretation PSL uses both compiled and interpreted code. If compiled, a function usually executes faster and is smaller. However, there are some semantic differences of which the user should be aware. For example, some recursive functions are made non-recursive, and certain functions are open-compiled. A call to an open-compiled function is replaced, on compilation, by a series of online instructions instead of just being a reference to another function. Functions compiled open may not do as much type checking. The user may have to supply some declarations to control this behavior. PSL Manual 7 February 1983 Getting Started section 2.6 page 2.9 The exact semantic differences between compiled and interpreted functions are more fully discussed in Chapter 18 and in the Portable LISP Compiler paper [Griss 81]. [??? We intend to consider the modification of the LISP semantics so as [??? We intend to consider the modification of the LISP semantics so as [??? We intend to consider the modification of the LISP semantics so as to ensure that these differences are minimized. If a conflict occurs, to ensure that these differences are minimized. If a conflict occurs, to ensure that these differences are minimized. If a conflict occurs, we will restrict the interpreter, rather than extending (and slowing we will restrict the interpreter, rather than extending (and slowing we will restrict the interpreter, rather than extending (and slowing down) the capabilities of the compiled code. ???] down) the capabilities of the compiled code. ???] down) the capabilities of the compiled code. ???] We indicate on the function definition line if it is typically compiled OPEN; this information helps in debugging code that uses these functions. These functions do not appear in backtraces and cannot be redefined, traced or broken in compiled code. [??? Should we make open-compiled functions totally un-redefinable [??? Should we make open-compiled functions totally un-redefinable [??? Should we make open-compiled functions totally un-redefinable without special action, even for interpreted code. Consistency! E.g. without special action, even for interpreted code. Consistency! E.g. without special action, even for interpreted code. Consistency! E.g. flag 'COND LOSE. ???] flag 'COND LOSE. ???] flag 'COND LOSE. ???] 2.7. Function Types 2.7. Function Types 2.7. Function Types Eval NoEval Eval NoEval Eval-type functions are those called with evaluated arguments. NoEval Spread Spread functions are called with unevaluated arguments. Spread-type functions have their arguments passed in a one-to-one correspondence with their NoSpread NoSpread formal parameters. NoSpread functions receive their arguments as a single ____ list. There are four function types implemented in PSL: ____ ____ ____ expr Eval Spread expr Eval Spread expr An Eval, Spread function, with a maximum of 15 arguments. In referring to the formal parameters we mean their values. Each function of this type should always be called with the expected number of parameters, as indicated in the function definition. Future versions of PSL will check this consistency. _____ _____ _____ fexpr NoEval NoSpread fexpr NoEval NoSpread fexpr A NoEval, NoSpread function. There is no limit on the number of arguments. In referring to the formal parameters we mean the unevaluated arguments, collected as a single List, and passed as a single formal parameter to the function body. _____ _____ _____ nexpr Eval NoSpread nexpr Eval NoSpread nexpr An Eval, NoSpread function. Each call on this kind of function may present a different number of arguments, which are evaluated, collected into a list, and passed in to the function body as a single formal parameter. _____ _____ _____ _____ _____ _____ macro macro macro macro macro The macro is a function which creates a new S-expression for subsequent evaluation or compilation. There is no limit to the _____ _____ _____ macro macro number of arguments a macro may have. The descriptions of the Eval Expand Eval Expand Eval and Expand functions in Chapter 11 provide precise details. Getting Started 7 February 1983 PSL Manual page 2.10 section 2.8 2.8. Switches and Globals 2.8. Switches and Globals 2.8. Switches and Globals Generally, switch names begin with !* and global names end with !*, where "!" is an escape character. One can set a switch !*xxx to T by using On xxx; in RLISP [(on xxx) in LISP]; one can set it to NIL by using Off xxx; in RLISP [(off xxx) in LISP]. For example) !*ECHO, !*PVAL and !*PECHO are switches that control Input Echo, Value Echo and Parse Echo. These switches are described more fully in Chapters 12 and 13. For more information, type "HELP SWITCHES;" or "HELP GLOBALS;", or see Section 6.7. 2.9. Reporting Errors and Misfeatures 2.9. Reporting Errors and Misfeatures 2.9. Reporting Errors and Misfeatures Send bug MAIL to PSL-BUGS@UTAH-20. The message will be distributed to a list of users concerned with bugs and maintenance, and a copy will be kept in <PSL>BUGS-MISSFEATURES.TXT at UTAH-20. Bug Bug _________ ___ __ ____ ____ (Bug ): undefined DEC-20 only, expr Bug Bug The function Bug(); can be called from within PSL:RLISP. This starts MAIL (actually MM) in a lower fork, with the To: line set up to Griss. Simply type the subject of the complaint, and then the message. After typing message about a bug or a misfeature end finally with a <Ctrl-Z>. <Ctrl-N> aborts the message. [??? needs switches ???] [??? needs switches ???] [??? needs switches ???] |
Added psl-1983/3-1/lpt/03-rlisp.lpt version [4788bbfe3c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 RLISP section 3.0 page 3.1 CHAPTER 3 CHAPTER 3 CHAPTER 3 RLISP SYNTAX RLISP SYNTAX RLISP SYNTAX 3.1. Motivation for RLISP Interface to PSL . . . . . . . 3.1 3.2. An Introduction to RLISP . . . . . . . . . . . 3.2 3.2.1. LISP equivalents of some RLISP constructs . . . 3.2 3.3. An Overview of RLISP and LISP Syntax Correspondence . . 3.3 3.3.1. Function Call Syntax in RLISP and LISP . . . . 3.4 ... 3.3.2. RLISP Infix Operators and Associated LISP Functions....3.4 3.3.3. Differences between Parse and Read. . . . . . 3.6 3.3.4. Procedure Definition . . . . . . . . . . 3.6 3.3.5. Compound Statement Grouping . . . . . . . . 3.7 3.3.6. Blocks with Local Variables . . . . . . . . 3.7 3.3.7. The If Then Else Statement . . . . . . . . 3.8 3.4. Looping Statements . . . . . . . . . . . . . 3.8 3.4.1. While Loop. . . . . . . . . . . . . . 3.8 3.4.2. Repeat Loop . . . . . . . . . . . . . 3.8 3.4.3. For Each Loop. . . . . . . . . . . . . 3.9 3.4.4. For Loop . . . . . . . . . . . . . . 3.9 3.4.5. Loop Examples. . . . . . . . . . . . . 3.9 3.5. Switch Syntax . . . . . . . . . . . . . . . 3.10 3.6. RLISP I/O Syntax . . . . . . . . . . . . . . 3.10 3.7. Transcript of a Short Session with RLISP . . . . . . 3.11 3.1. Motivation for RLISP Interface to PSL 3.1. Motivation for RLISP Interface to PSL 3.1. Motivation for RLISP Interface to PSL Most of the PSL users at Utah prefer to write LISP code using an ALGOL-like (or PASCAL-like) preprocessor language, RLISP, because of its similarity to the heavily used PASCAL and C languages. RLISP was developed as part of the REDUCE Computer Algebra project [Hearn 73], and is the ALGOL-like user language as well as the implementation language. RLISP provides a number of syntactic niceties which we find convenient, such as If-Then-Else If-Then-Else vector subscripts, case statement, If-Then-Else, etc. We usually do not distinguish LISP from RLISP, and can mechanically translate from one to the other in either direction using a parser and pretty-printer written in PSL. That is, RLISP is a convenience, but it is not necessary to use RLISP syntax rather than LISP. A complete BNF-like definition of RLISP and its translation to LISP using the MINI system is given in Section 22.4. Also discussed in Chapter 22 is an extensible table driven parser which is used for the current RLISP parser. There we give explicit tables which define RLISP syntax. In this chapter we provide enough of an introduction to make the examples and sources readable, and to assist the user in writing RLISP code. RLISP 7 February 1983 PSL Manual page 3.2 section 3.2 3.2. An Introduction to RLISP 3.2. An Introduction to RLISP 3.2. An Introduction to RLISP An RLISP program consists of a set of functional commands which are evaluated sequentially. RLISP expressions are built up from declarations, statements and expressions. Such entities are composed of sequences of numbers, variables, operators, strings, reserved words and delimiters (such as commas and parentheses), which in turn are sequences of characters. The evaluation proceeds by a parser first converting the ALGOL-like RLISP source language into LISP S-expressions, and evaluating and printing the Parse-Eval-Print Parse-Eval-Print result. The basic cycle is thus Parse-Eval-Print, although the specific functions, and additional processing, are under the control of a variety of switches, described in appropriate sections. 3.2.1. LISP equivalents of some RLISP constructs 3.2.1. LISP equivalents of some RLISP constructs 3.2.1. LISP equivalents of some RLISP constructs The following gives a few examples of RLISP statements and functions and their corresponding LISP forms. To see the exact LISP equivalent of RLISP code, set the switch !*PECHO to T [On PECHO; in RLISP, (On PECHO) in LISP]. Assignment statements in RLISP and LISP: X := 1; (setq x 1) A procedure to take a factorial, in RLISP: LISP PROCEDURE FACTORIAL N; IF N <= 1 THEN 1 ELSE N * FACTORIAL (N-1); in LISP: (de factorial (n) (cond ((leq n 1) 1) (T (times n (factorial (difference n 1)))))) Take the Factorial of 5 in RLISP and in LISP: FACTORIAL 5; (factorial 5) Build a list X as a series of "Cons"es in RLISP: X := 'A . 'B . 'C . NIL; in LISP: (setq x (cons 'a (cons 'b (cons 'c nil)))) PSL Manual 7 February 1983 RLISP section 3.3 page 3.3 3.3. An Overview of RLISP and LISP Syntax Correspondence 3.3. An Overview of RLISP and LISP Syntax Correspondence 3.3. An Overview of RLISP and LISP Syntax Correspondence The RLISP parser converts RLISP expressions, typed in at the terminal or read from a file, into directly executable LISP expressions. For convenience in the following examples, the "==>" arrow is used to indicate the LISP actually produced from the input RLISP. To see the LISP equivalents of RLISP code on the machine, set the switch !*PECHO to T [On Pecho; in RLISP, (On Pecho) in LISP]. As far as possible, upper and lower cases are used as follows: a. Upper case tokens and punctuation represent items which must appear as is in the source RLISP or output LISP. b. Lower case tokens represent other legal RLISP constructs or corresponding LISP translations. We typically use "e" for ____ expression, "s" for statement, and "v" for variable; "-list" is tacked on for lists of these objects. For example, the following rule describes the syntax of assignment in RLISP: VAR := number; ==> (SETQ VAR number) Another example: __________ ______ _ ______ _ IF expression THEN action_1 ELSE action_2 __________ ______ _ ______ _ ==> (COND ((expression action_1) (T action_2))) In RLISP, a function is recognized as an "ftype" (one of the tokens EXPR, FEXPR, etc. or none) followed by the keyword PROCEDURE, followed by an "id" (the name of the function), followed by a "v-list" (the formal parameter names) enclosed in parentheses. A semicolon terminates the title line. The body of the function is a <statement> followed by a semicolon. In LISP syntax, a function is defined using one of the "Dx" functions, i.e. one of De Df Dm Dn De Df Dm Dn De, Df, Dm, or Dn, depending on "ftype". For example: EXPR PROCEDURE NULL(X); EQ(X, NIL); ==> (DE NULL (X) (EQ X NIL)) 3.3.1. Function Call Syntax in RLISP and LISP 3.3.1. Function Call Syntax in RLISP and LISP 3.3.1. Function Call Syntax in RLISP and LISP A function call with N arguments (called an N-ary function) is most commonly represented as "FN(X1, X2, ... Xn)" in RLISP and as "(FN X1 X2 ... Xn)" in LISP. Commas are required to separate the arguments in RLISP but not in LISP. A zero argument function call is "FN()" in RLISP and "(FN)" in LISP. An unary function call is "FN(a)" or "FN a" in RLISP and "(FN a)" in LISP; i.e. the parentheses may be omitted around the single RLISP 7 February 1983 PSL Manual page 3.4 section 3.3 argument of any unary function in RLISP. 3.3.2. RLISP Infix Operators and Associated LISP Functions 3.3.2. RLISP Infix Operators and Associated LISP Functions 3.3.2. RLISP Infix Operators and Associated LISP Functions Many important PSL binary functions, particularly those for arithmetic operations, have associated infix operators, consisting of one or two special characters. The conversion of an RLISP expression "A op B" to its corresponding LISP form is easy: "(fn A B)", in which "fn" is the associated function. The function name fn may also be used as an ordinary RLISP function call, "fn(A, B)". Refer to Chapter 22 for details on how the association of "op" and "fn" is installed. Parentheses may be used to specify the order of combination. "((A op_a B) op_b C)" in RLISP becomes "(fn_b (fn_a A B) C)" in LISP. If two or more different operators appear in a sequence, such as "A op_a B op_b C", grouping (similar to the insertion of parentheses) is done based on relative precedence of the operators, with the highest precedence operator getting the first argument pair: "(A op_a B) op_b C" if Precedence(op_a) >= Precedence(op_b); "A op_a (B op_b C)" if Precedence(op_a) < Precedence(op_b). If two or more of the same operator appear in a sequence, such as "A op B op C", grouping is normally to the left (Left Associative; i.e. "(fn (fn A B) C)"), unless the operator is explicitly Right Associative Cons SetQ Cons SetQ (such as . for Cons and := for SetQ; i.e. "(fn A (fn B C))"). The operators + and * are N-ary; i.e. "A nop B nop C nop B" parses into "(nfn A B C D)" rather than into "(nfn (nfn (nfn A B) C) D)". The current binary operator-function correspondence is as follows: PSL Manual 7 February 1983 RLISP section 3.3 page 3.5 ________ ________ __________ Operator Function Precedence Cons Cons . Cons 23 Right Associative Expt Expt ** Expt 23 Quotient Quotient / Quotient 19 Times Times * Times 19 N-ary Difference Difference - Difference 17 Plus Plus + Plus 17 N-ary Eq Eq Eq Eq Eq Eq 15 Equal Equal = Equal 15 Geq Geq >= Geq 15 GreaterP GreaterP > GreaterP 15 Leq Leq <= Leq 15 LessP LessP < LessP 15 Member Member Member Member Member Member 15 Memq MemQ Memq MemQ Memq MemQ 15 Neq Neq Neq Neq Neq Neq 15 And And And And And And 11 N-ary Or Or Or Or Or Or 9 N-ary SetQ SetQ := SetQ 7 Right Associative Note: There are other INFIX operators, mostly used as key-words within Then Else If Do Then Else If Do other syntactic constructs (such as Then or Else in the If-..., or Do in While While the While-..., etc.). They have lower precedences than those given above. These key-words include: the parentheses "()", the brackets "[]", the colon ":", the comma ",", the semi-colon ";", the dollar sign "$", and the ids: Collect Conc Do Else End Of Procedure Product Step Such Sum Collect Conc Do Else End Of Procedure Product Step Such Sum Collect, Conc, Do, Else, End, Of, Procedure, Product, Step, Such, Sum, Then To Until Then To Until Then, To, and Until. As pointed out above, an unary function FN can be used with or without parentheses: FN(a); or FN a;. In the latter case, FN is assumed to behave as a prefix operator with highest precedence (99) so that "FOO 1 ** 2" parses as "FOO(1) ** 2;". The operators +, -, and / can also be used as Plus Minus Recip Plus Minus Recip unary prefix operators, mapping to Plus, Minus and Recip, respectively, with precedence 26. Certain other unary operators (RLISP key-words) have low precedences or explicit special purpose parsing functions. These include: BEGIN, CASE, CONT, EXIT, FOR, FOREACH, GO, GOTO, IF, IN, LAMBDA, NOOP, NOT, OFF, ON, OUT, PAUSE, QUIT, RECLAIM, REPEAT, RETRY, RETURN, SCALAR, SHOWTIME, SHUT, WHILE and WRITE. RLISP 7 February 1983 PSL Manual page 3.6 section 3.3 3.3.3. Differences between Parse and Read 3.3.3. Differences between Parse and Read 3.3.3. Differences between Parse and Read A single character can be interpreted in different ways depending on context and on whether it is used in a LISP or in an RLISP expression. Such differences are not immediately apparent to a novice user of RLISP, but an example is given below. The RLISP infix operator "." may appear in an RLISP expression and is Parse Cons Parse Cons converted by the Parse function to the LISP function Cons, as in the expression x := 'y . 'z;. A dot may also occur in a quoted expression in Read Read RLISP mode, in which case it is interpreted by Read as part of the notation Read Read for pairs, as in (SETQ X '(Y . Z)). Note that Read called from LISP or from RLISP uses slightly different scan tables (see Chapter 12). In order Cons Cons Cons Cons to use the function Cons in LISP one must use the word Cons in a prefix position. 3.3.4. Procedure Definition 3.3.4. Procedure Definition 3.3.4. Procedure Definition Procedure definitions in PSL (both RLISP and LISP) are not nested as in ALGOL; all appear at the same top level as in C. The basic function for PutD PutD defining procedures is PutD (see Chapter 10). Special syntactic forms are provided in both RLISP and LISP: mode ftype PROCEDURE name(v_1,...,v_n); body; ==> (Dx name (v_1 ... v_N) body) Examples: PROCEDURE ADD1 N; N+1; ==> (DE ADD1 (N) (PLUS N 1)) MACRO PROCEDURE FOO X; LIST('FUM, CDR X, CDR X); ==> (DM FOO (X) (LIST 'FUM (CDR X) (CDR X)) The value returned by the procedure is the value of the body; no assignment to the function name (as in ALGOL or PASCAL) is needed. In the general definition given above "mode" is usually optional; it can be LISP or SYMBOLIC (which mean the same thing) or SYSLISP [only of ____ _____ ____ _____ ____ _____ expr fexpr expr fexpr importance if SYSLISP and LISP are inter-mixed]. "Ftype" is expr, fexpr, _____ _____ ______ _____ _____ ______ _____ _____ ______ macro nexpr smacro macro nexpr smacro macro, nexpr, or smacro (or can be omitted, in which case it defaults to ____ ____ ____ expr expr expr). Name(v_1,...,v_N) is any legal form of call, including infix. Dx ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ De expr Df fexpr Dm macro Dn nexpr Ds De expr Df fexpr Dm macro Dn nexpr Ds is De for expr, Df for fexpr, Dm for macro, Dn for nexpr, and Ds for ______ ______ ______ smacro smacro smacro. ______ _____ ______ _____ ______ _____ smacro macro smacro macro The smacro is a simple substitution macro. PSL Manual 7 February 1983 RLISP section 3.3 page 3.7 SMACRO PROCEDURE ELEMENT X; % Defines ELEMENT(x) to substitute CAR CDR (X); % as Car Cdr x; ==> (DS ELEMENT (X) (CAR (CDR X))) In code which calls ELEMENT after it was defined, ELEMENT(foo); behaves exactly like CAR CDR foo;. 3.3.5. Compound Statement Grouping 3.3.5. Compound Statement Grouping 3.3.5. Compound Statement Grouping A group of RLISP expressions may be used in any position in which a single expression is expected by enclosing the group of expressions in double angle brackets, << and >>, and separating them by the ; delimiter. The RLISP <<A; B; C; ... Z>> becomes (PROGN A B C ... Z) in LISP. The value of the group is the value of the last expression, Z. Example: X:=<<PRINT X; X+1>>; % prints old X then increments X ==> (SETQ X (PROGN (PRINT X) (PLUS X 1))) 3.3.6. Blocks with Local Variables 3.3.6. Blocks with Local Variables 3.3.6. Blocks with Local Variables A more powerful construct, sometimes used for the same purpose as the Begin-End Prog Begin-End Prog << >> group, is the Begin-End block in RLISP or Prog in LISP. This construct also permits the allocation of 0 or more local variables, initialized to NIL. The normal value of a block is NIL, but it may be Return Return exited at a number of points, using the Return statement, and each can GoTo GoTo return a different value. The block also permits labels and a GoTo construct. Example: BEGIN SCALAR X,Y; % SCALAR declares locals X and Y X:='(1 2 3); L1: IF NULL X THEN RETURN Y; Y:=CAR X; X:=CDR X; GOTO L1; END; ==> (PROG (X Y) (SETQ X '(1 2 3)) L1 (COND ((NULL X) (RETURN Y))) (SETQ Y (CAR X)) (SETQ X (CDR X)) (GO L1)) RLISP 7 February 1983 PSL Manual page 3.8 section 3.3 3.3.7. The If Then Else Statement 3.3.7. The If Then Else Statement 3.3.7. The If Then Else Statement If Cond If Cond RLISP provides an If statement, which maps into the LISP Cond statement. See Chapter 9 for full details. For example: IF e THEN s; ==> (COND (e s)) IF e THEN s1 ELSE s2; ==> (COND (e s1) (T s2)) IF e1 THEN s1 ELSE IF e2 THEN s2 ELSE s3; ==> (COND (e1 s1) (e2 s2) (T s3)) 3.4. Looping Statements 3.4. Looping Statements 3.4. Looping Statements While Repeat For For Each While Repeat For For Each RLISP provides While, Repeat, For and For Each loops. These are discussed in greater detail in Chapter 9. Some examples follow: 3.4.1. While Loop 3.4.1. While Loop 3.4.1. While Loop WHILE e DO s; % As long as e NEQ NIL, do s ==> (WHILE e s) 3.4.2. Repeat Loop 3.4.2. Repeat Loop 3.4.2. Repeat Loop REPEAT s UNTIL e; % repeat doing s until "e" is not NIL ==> (REPEAT s e) 3.4.3. For Each Loop 3.4.3. For Each Loop 3.4.3. For Each Loop For Each For Each The For Each loops provide various mapping options, processing elements of a list in some way and sometimes constructing a new list. FOR EACH x IN y DO s; % y is a list, x traverses list bound to eac % element in turn. ==> (FOREACH x IN y DO s) FOR EACH x ON y DO s; % y is a list, x traverses list Bound to suc % Cdr's of y. ==> (FOREACH x ON y DO s) Other options can return modified lists, etc. See chapter 9. PSL Manual 7 February 1983 RLISP section 3.4 page 3.9 3.4.4. For Loop 3.4.4. For Loop 3.4.4. For Loop For For The For loop permits an iterative form with a compacted control variable. Other options can compute sums and products. FOR i := a:b DO s; % step i successively from a to b in % steps of 1. ==> (FOR (FROM I a b 1) DO s) FOR i := a STEP b UNTIL c DO s; % More general stepping ==> (FOR (FROM I a c b) DO s) 3.4.5. Loop Examples 3.4.5. Loop Examples 3.4.5. Loop Examples LISP PROCEDURE count lst; % Count elements in lst BEGIN SCALAR k; k:=0; WHILE PAIRP lst DO <<k:=k+1; lst:=CDR lst>>; RETURN k; END; ==> (DE COUNT (LST) (PROG (K) (SETQ K 0) (WHILE (PAIRP LST) (PROGN (SETQ K (PLUS K 1)) (SETQ LST (CDR LST)))) (RETURN K))) or LISP PROCEDURE CountNil lst; % Count NIL elements in lst BEGIN SCALAR k; k:=0; FOR EACH x IN lst DO If Null x then k:=k+1; RETURN k; END; ==> (DE COUNTNIL (LST) (PROG (K) (SETQ K 0) (FOREACH X IN LST DO (COND ((NULL X) (SETQ K (PLUS K 1))))) (RETURN K))) RLISP 7 February 1983 PSL Manual page 3.10 section 3.5 3.5. Switch Syntax 3.5. Switch Syntax 3.5. Switch Syntax Two declarations are offered to the user for turning on or off a variety of switches in the system. Switches are global variables that have only the values T or NIL. By convention, the switch name is XXXX, but the associated global variable is !*XXXX. The RLISP commands ON and OFF take a list of switch names as argument and turn them on and off respectively (i.e. set the corresponding !* variable to T or NIL). Example: ON ECHO, FEE, FUM; % Sets !*ECHO, !*FEE, !*FUM to T; ==> (ON ECHO FEE FUM) OFF INT,SYSLISP; % Sets !*INT and !*SYSLISP to NIL ==> (OFF INT SYSLISP) [??? Mention SIMPFG property ???] [??? Mention SIMPFG property ???] [??? Mention SIMPFG property ???] See Section 6.7 for a complete set of switches and global variables. 3.6. RLISP I/O Syntax 3.6. RLISP I/O Syntax 3.6. RLISP I/O Syntax RLISP provides special commands to OPEN and SELECT files for input or for output and to CLOSE files. File names must be enclosed in "....". Files In In with the extension ".sl" or ".lsp" are read by In in LISP mode rather than RLISP mode. IN "<griss.stuff>fff.red","ggg.lsp"; % First reads fff.red % Then reads ggg.lsp OUT "keep-it.output"; % Diverts output to "keep-it.ou OUT "fum"; % now to fum, keeping the other SHUT "fum"; % to close fum and flush the bu File names can use the full system conventions. See Chapter 12 for more detail on I/O. 3.7. Transcript of a Short Session with RLISP 3.7. Transcript of a Short Session with RLISP 3.7. Transcript of a Short Session with RLISP The following is a transcript of RLISP running on the DEC-20. PSL Manual 7 February 1983 RLISP section 3.7 page 3.11 @psl:rlisp PSL 3.1 Rlisp, 27-Oct-82 [1] % Notice the numbered prompt. [1] % Comments begin with "%" and do not change the prompt number. [1] Z := '(1 2 3); % Make an assignment for Z. (1 2 3) [2] Cdr Z; % Notice the change in the prompt nu (2 3) [3] Lisp Procedure Count L; % "Count" counts the number of eleme [3] If Null L Then 0 % in a list L. [3] Else 1 + Count Cdr L; COUNT [4] Count Z; % Try out "Count" on Z. 3 [5] Tr Count; % Trace the recursive execution of "Count". (COUNT) [6] % A call on "Count" now shows the value of [6] % "Count" and of its argument each time it [6] Count Z; % is called. COUNT being entered L: (1 2 3) COUNT (level 2) being entered L: (2 3) COUNT (level 3) being entered L: (3) COUNT (level 4) being entered L: NIL COUNT (level 4) = 0 COUNT (level 3) = 1 COUNT (level 2) = 2 COUNT = 3 3 [7] Lisp Procedure Factorial X; [7] If X <= 1 Then 1 [7] Else X * Factorial (X-1); FACTORIAL [8] Tr Factorial; (FACTORIAL) [9] Factorial 4; % Trace execution of "Factorial". FACTORIAL being entered X: 4 FACTORIAL (level 2) being entered X: 3 FACTORIAL (level 3) being entered X: 2 FACTORIAL (level 4) being entered X: 1 FACTORIAL (level 4) = 1 FACTORIAL (level 3) = 2 FACTORIAL (level 2) = 6 FACTORIAL = 24 24 RLISP 7 February 1983 PSL Manual page 3.12 section 3.7 [10] UnTr Count,Factorial; NIL [11] Count 'A; ***** An attempt was made to do CDR on `A', which is not a pair Break loop 1 lisp break> ? BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, excep that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. NIL 2 lisp break> % Get a Trace-Back of the 2 lisp break> I % interpreted functions. Backtrace, including interpreter functions, from top of stack: LIST2 CDR COUNT PLUS2 PLUS COND COUNT NIL 3 lisp break> Q % To exit the Break Loop. [12] % Load in a file, showing the file [12] In "small-file.red"; % and its execution. X := 'A . 'B . NIL;(A B) % Construct a list with "." for Cons. Count X;2 % Call "Count" on X. Reverse X;(B A) % Call "Reverse" on X. NIL [13] % This leaves RLISP and enters [13] End; % LISP mode. Entering LISP... PSL, 27-Oct-82 6 lisp> (SETQ X 3) % A LISP assignment statement. 3 7 lisp> (FACTORIAL 3) % Call "Factorial" on 3. 6 8 lisp> (BEGINRLISP) % This function returns us to RLISP. Entering RLISP... [14] Quit; % To exit call "Quit". @continue PSL Manual 7 February 1983 RLISP section 3.7 page 3.13 "Continued" [15] X; % Notice the prompt number. 3 [16] ^C % One can also quit with <Ctrl-C>. @start % Alternative immediate re-entry. [17] Quit; @ |
Added psl-1983/3-1/lpt/04-datatypes.lpt version [56ac0d85bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Data Types section 4.0 page 4.1 CHAPTER 4 CHAPTER 4 CHAPTER 4 DATA TYPES DATA TYPES DATA TYPES 4.1. Data Types and Structures Supported in PSL . . . . . 4.1 4.1.1. Data Types. . . . . . . . . . . . . . 4.1 4.1.2. Other Notational Conventions. . . . . . . . 4.4 4.1.3. Structures. . . . . . . . . . . . . . 4.4 4.2. Predicates Useful with Data Types . . . . . . . . 4.5 4.2.1. Functions for Testing Equality . . . . . . . 4.6 4.2.2. Predicates for Testing the Type of an Object . . 4.7 4.2.3. Boolean Functions . . . . . . . . . . . 4.8 4.3. Converting Data Types . . . . . . . . . . . . 4.9 4.1. Data Types and Structures Supported in PSL 4.1. Data Types and Structures Supported in PSL 4.1. Data Types and Structures Supported in PSL 4.1.1. Data Types 4.1.1. Data Types 4.1.1. Data Types Data objects in PSL are tagged with their type. This means that the type declarations required in many programming languages are not needed. Some functions are "generic" in that the result they return depends on the types ____ ___ of the arguments. A tagged PSL object is called an item, and has a tag ____ field (9 bits on the DEC-20, 5 bits on the VAX), an info field (18 bits on the DEC-20, 27 bits on the VAX), and possibly some bits for garbage ____ collection. The info field is either immediate data or an index or address __ into some other structure (such as the heap or id space). For the purposes ____ of input and output of items, an appropriate notation is used (see Chapter 12 for full details on syntax, restrictions, etc.). More explicit implementation details can be found in Chapters 20 and 21. The basic data types supported in PSL and a brief indication of their representations are described below. _______ _______ integer The integers are also called "fixed" numbers. The magnitude _______ of integers is essentially unrestricted if the "big number" _______ module, BIG, is loaded (LOAD BIG). The notation for integers is a sequence of digits in an appropriate radix (radix 10 is the default, which can be overridden by a radix prefix, such as 2#, 8#, 16# etc). There are three internal _______ representations of integers, chosen to suit the implementation: ____ ______ ____ ____ inum A signed number fitting into info. Inums do not require dynamic storage and are represented in the Data Types 7 February 1983 PSL Manual page 4.2 section 4.1 same form as machine integers. (19 bit [-2^18 ... 2^18 - 1] on the DEC-20, 28 bit on the VAX.) ______ ____ _______ fixnum A full-word signed integer, allocated in the heap. (36 bit on the DEC-20, fitting into a register; 32 bit on the VAX.) [??? Do we need fixnums, and if yes how large [??? Do we need fixnums, and if yes how large [??? Do we need fixnums, and if yes how large ???] ???] ???] ______ _______ bignum A signed integer of arbitrary precision, allocated _______ ______ as a vector of integers. Bignums are currently not installed by default; to use them, do (LOAD BIG). _____ ________ _____ float A floating point number, allocated in the heap. The _____ precision of floats is determined solely by the implementation, and is 72-bit double precision on the DEC-20, _____ 64-bit on the VAX. The notation for a float is a sequence of digits with the addition of a single floating point ( . ) and optional exponent (E <integer>). (No spaces may occur between the point and the digits). Radix 10 is used for representing the mantissa and the exponent of dty(floating point) numbers. __ __________ __ ____ id An identifier (or id) is an item whose info field points to a five-item structure containing the print name, property cell, value cell, function cell, and package cell. This structure __ is contained in the id space. The notation for an id is its print name, an alphanumeric character sequence starting with __ a letter. One always refers to a particular id by giving its print name. When presented with an appropriate print name, __ the PSL reader will find a unique id to associate with it. __ See Chapters 6 and 12 for more information on ids and their __ syntax. NIL and T are treated as special ids in PSL. ____ ____ pair A primitive two-item structure which has a left and right ___ ________ part. A notation called dot-notation is used, with the form: (<left-part> . <right-part>). The <left-part> is known as Car Cdr Car Cdr the Car portion and the <right-part> as the Cdr portion. The ____ parts may be any item. (Spaces are used to resolve ambiguity _____ with floats; see Chapter 12). ______ ____ _______ vector A primitive uniform structure of items; an integer index is used to access random values in the structure. The ______ ___ ____ individual elements of a vector may be any item. Access to ______ vectors is by means of functions for indexing, sub-vector extraction and concatenation, defined in Section 8.3. In the ______ ______ notation for vectors, the elements of a vector are surrounded ____ ____ ____ by square brackets: [item-0 item-1 ... item-n]. ______ ______ ______ string A packed vector (or byte vector) of characters; the elements _______ are small integers representing the ASCII codes for the PSL Manual 7 February 1983 Data Types section 4.1 page 4.3 ____ characters (usually inums). The elements may be accessed by indexing, substring and concatenation functions, defined in ______ Chapter 8. String notation consists of a series of characters enclosed in double quotes, as in "THIS IS A STRING". A quote is included by doubling it, as in "HE SAID, ______ ""LISP""". (Input strings may cross the end-of-line boundary, but a warning is given.) See !*EOLINSTRINGOK in chapter 12. ____ ______ ______ ____ word-vector A vector of machine-sized words, used to implement such ______ ______ things as fixnums, bignums, etc. The elements are not ____ considered to be items, and are not examined by the garbage collector. ____ ______ ____ ______ ____ ______ [??? The word-vector could be used to implement [??? The word-vector could be used to implement [??? The word-vector could be used to implement machine-code blocks on some machines. ???] machine-code blocks on some machines. ???] machine-code blocks on some machines. ???] ____ ______ ______ ____ ______ Byte-Vector A vector of bytes. Internally a byte-vector is the same as a ______ string, but it is printed differently as a vector of integers instead of characters. ________ ______ Halfword-Vector ______ A vector of machine-sized halfwords. ____ _______ ____ code-pointer This item is used to refer to the entry point of compiled _____ ______ ______ _____ ______ ______ _____ ______ ______ exprs fexprs macros exprs fexprs macros functions (exprs, fexprs, macros, etc.), permitting compiled functions to be renamed, passed around anonymously, etc. New Lap Fasl ____ _______ Lap Fasl code-pointers are created by the loader (Lap,Fasl) and associated functions. They can be printed; the printing function prints the number of arguments expected as well as the entry point. The value appears in the convention of the implementation (#<Code a nnnn> on the DEC-20 and VAX, where a is the number of arguments and nnnn is the entry point). ___ ___ ___ [not ___ _______ [not env-pointer A data type used to support a funarg capability. [not ___________ ___ ___________ ___ ___________ ___ implemented yet] implemented yet] implemented yet] 4.1.2. Other Notational Conventions 4.1.2. Other Notational Conventions 4.1.2. Other Notational Conventions Certain functional arguments can be any of a number of types. For convenience, we give these commonly used sets a name. We refer to these sets as "classes" of primitive data types. In addition to the types described above and the names for classes of types given below, we use the following conventions in the manual. {XXX, YYY} indicates that either data type XXX or data type YYY will do. {XXX}-{YYY} indicates that any object of type XXX can be used except those of type YYY; in this case, YYY is a _______ _____ subset of XXX. For example, {integer, float} indicates that either an _______ _____ ___ ______ integer or a float is acceptable; {any}-{vector} means any type except a ______ vector. Data Types 7 February 1983 PSL Manual page 4.4 section 4.1 ___ _ __________ any Any of the types given above. S-expression is another term ___ for any. All PSL entities have some value unless an error occurs during evaluation. ____ ___ ____ atom The class {any}-{pair}. _______ boolean The class of global variables {T, NIL}, or their respective values, {T, NIL}. (See Chapter 6.7). _________ _______ character Integers in the range of 0 to 127 representing ASCII character codes. These are distinct from single-character __ ids. ________ _______ _____ ______ ______ ____ _______ constant The class of {integer, float, string, vector, code-pointer}. Eval ________ Eval A constant evaluates to itself (see the definition of Eval in Chapter 11). _____ _______ extra-boolean Any value in the system. Anything that is not NIL has the _______ boolean interpretation T. _____ __ ftype The class of definable function types. The set of ids ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr fexpr macro nexpr expr fexpr macro nexpr {expr, fexpr, macro, nexpr}. _____ __________ The ftype is ONLY an attribute of identifiers, and is not ____ _______ associated with either executable code (code-pointers) or ______ lambda expressions. __ _______ _______ io-channel A small integer representing an io channel. ______ _______ _____ number The class of {integer, float}. _ ______ ______ ______ ______ ____ ______ x-vector Any kind of vector; i.e. a string, vector, word-vector, or ____ word. _________ Undefined An implementation-dependent value returned by some low-level functions; i.e. the user should not depend on this value. ____ ________ None Returned A notational convenience used to indicate control functions that do not return directly to the calling point, and hence Go Go do not return a value. (e.g. Go) 4.1.3. Structures 4.1.3. Structures 4.1.3. Structures ____ ____ Structures are entities created using pairs. Lists are structures very ____ commonly required as parameters to functions. If a list of homogeneous ____ entities is required by a function, this class is denoted by xxx-list, in ____ which xxx is the name of a class of primitives or structures. Thus a list __ __ ____ ____ _______ _______ ____ of ids is an id-list, a list of integers is an integer-list, and so on. ____ ____ ____ ___ ____ list A list is recursively defined as NIL or the pair (any . list). A ____ ________ ____ special notation called list-notation is used to represent lists. List-notation eliminates the extra parentheses and dots required by dot-notation, as illustrated below. List-notation and dot-notation may be mixed, as shown in the second and third examples. (See section 3.3.3.) ____________ _____________ dot-notation list-notation (a . (b . (c . NIL))) (a b c) (a . (b . c)) (a b . c) (a . ((b . c) . (d . NIL))) PSL Manual 7 February 1983 Data Types section 4.1 page 4.5 Note: () is an alternate input representation of NIL. _ ____ _ ____ ___________ ____ a-list An a-list, or association list, is a list in which each element Car ____ Car is a pair, the Car part being a key associated with the value in Cdr Cdr the Cdr part. ____ ____ form A form is an S-expression (any) which is legally acceptable to Eval Eval Eval; that is, it is syntactically and semantically accepted by the interpreter or the compiler. (See Chapter 11 for more details.) ______ lambda A lambda expression must have the form (in list-notation): __ ____ (LAMBDA parameters . body). "Parameters" is an id-list of ____ formal parameters for "body", which is a form to be evaluated ProgN ProgN (note the implicit ProgN). The semantics of the evaluation are Eval Eval defined by the Eval function (see chapter 11). ________ ______ ____ _______ function A lambda, or a code-pointer. A function is always evaluated as Eval Spread Eval Spread Eval, Spread. 4.2. Predicates Useful with Data Types 4.2. Predicates Useful with Data Types 4.2. Predicates Useful with Data Types Most functions in this Section return T if the condition defined is met and NIL if it is not. Exceptions are noted. Defined are type-checking functions and elementary comparisons. 4.2.1. Functions for Testing Equality 4.2.1. Functions for Testing Equality 4.2.1. Functions for Testing Equality Functions for testing equality are listed below. For other functions comparing arithmetic values see Chapter 5. Eq Eq _ ___ _ ___ _______ ____ ________ ____ (Eq U:any V:any): boolean open-compiled, expr _ _ Returns T if U points to the same object as V, i.e. if they are Eq ____ Eq ___ identical items. Eq is not a reliable comparison between numeric arguments. This function should only be used in special Equal Equal circumstances. Normally, equality should be tested with Equal, described below. EqN EqN _ ___ _ ___ _______ ____ (EqN U:any V:any): boolean expr Eq _ _ Eq _ _ Returns T if U and V are Eq or if U and V are numbers and have the same value and type. [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 ???] ???] ???] Data Types 7 February 1983 PSL Manual page 4.6 section 4.2 Equal Equal _ ___ _ ___ _______ ____ (Equal U:any V:any): boolean expr _ _ ____ Returns T if U and V are the same. Pairs are compared ______ recursively to the bottom levels of their trees. Vectors must Equal Equal have identical dimensions and Equal values in all positions. ______ Strings must have identical characters, i.e. all characters must Eq ____ _______ Eq be of the same case. Code-pointers must have Eq values. Other Eqn ____ Eqn atoms must be Eqn equal. A usually valid heuristic is that if Print Print two objects look the same if printed with the function Print, Equal Equal Equal ____ Equal they are Equal. If one argument is known to be an atom, Equal is Eq Eq open-compiled as Eq. For example, if (Setq X '(A B C)) and (Setq Y X) have been executed, then (EQ X Y) is T (EQ X '(A B C)) is NIL (EQUAL X '(A B C)) is T (EQ 1 1) is T (EQ 1.0 1.0) is NIL (EQN 1.0 1.0) is T (EQN 1 1.0) is NIL (EQUAL 0 0.0) is NIL Neq Neq _ ___ _ ___ _______ _____ (Neq U:any V:any): boolean macro Not Equal Not Equal _ _ (Not (Equal U V)). Ne Ne _ ___ _ ___ _______ ____ ________ ____ (Ne U:any V:any): boolean open-compiled, expr Not Eq Not Eq _ _ (Not (Eq U V)). EqStr EqStr _ ___ _ ___ _______ ____ (EqStr U:any V:any): boolean expr ______ Compare two strings, for exact (Case sensitive) equality. For case-INsensitive equality one must load the STRINGS module (see EqStr Eq EqStr _ _ Eq _ _ Section 8.7). EqStr returns T if U and V are Eq or if U and V are equal strings. EqCar EqCar _ ___ _ ___ _______ ____ (EqCar U:any V:any): boolean expr Eq Car Eq Car _ _ Tests whether (Eq (Car U) V)). If the first argument is not a EqCar EqCar pair, EqCar returns NIL. PSL Manual 7 February 1983 Data Types section 4.2 page 4.7 4.2.2. Predicates for Testing the Type of an Object 4.2.2. Predicates for Testing the Type of an Object 4.2.2. Predicates for Testing the Type of an Object Atom Atom _ ___ _______ ____ ________ ____ (Atom U:any): boolean open-compiled, expr _ ____ Returns T if U is not a pair. CodeP CodeP _ ___ _______ ____ ________ ____ (CodeP U:any): boolean open-compiled, expr _ ____ _______ Returns T if U is a code-pointer. ConstantP ConstantP _ ___ _______ ____ (ConstantP U:any): boolean expr _ ________ ____ __ Returns T if U is a constant (that is, neither a pair nor an id). ______ ________ Note that vectors are considered constants. [??? Should Eval U Eq U if U is a constant? ???] [??? Should Eval U Eq U if U is a constant? ???] [??? Should Eval U Eq U if U is a constant? ???] FixP FixP _ ___ _______ ____ ________ ____ (FixP U:any): boolean open-compiled, expr _ _______ Returns T if U is an integer. If BIG is loaded, this function also returns T for bignums. FloatP FloatP _ ___ _______ ____ ________ ____ (FloatP U:any): boolean open-compiled, expr _ _____ Returns T if U is a float. IdP IdP _ ___ _______ ____ ________ ____ (IdP U:any): boolean open-compiled, expr _ __ Returns T if U is an id. Null Null _ ___ _______ ____ ________ ____ (Null U:any): boolean open-compiled, expr Not _ Not Returns T if U is NIL. This is exactly the same function as Not, defined in Section 4.2.3. Both are available solely to increase readability. NumberP NumberP _ ___ _______ ____ ________ ____ (NumberP U:any): boolean open-compiled, expr _ ______ _______ _____ Returns T if U is a number (integer or float). Data Types 7 February 1983 PSL Manual page 4.8 section 4.2 PairP PairP _ ___ _______ ____ ________ ____ (PairP U:any): boolean open-compiled, expr _ ____ Returns T if U is a pair. StringP StringP _ ___ _______ ____ ________ ____ (StringP U:any): boolean open-compiled, expr _ ______ Returns T if U is a string. VectorP VectorP _ ___ _______ ____ ________ ____ (VectorP U:any): boolean open-compiled, expr _ ______ Returns T if U is a vector. 4.2.3. Boolean Functions 4.2.3. Boolean Functions 4.2.3. Boolean Functions Boolean functions return NIL for "false"; anything non-NIL is taken to be true, although a conventional way of representing truth is as T. Note that T always evaluates to itself. NIL may also be represented as '(). The And Or Not And Or Not Boolean functions And, Or, and Not can be applied to any LISP type, and are And Or And Or not bitwise functions. And and Or are frequently used in LISP as control structures as well as Boolean connectives (see Section 9.2). For example, the following two constructs will give the same result: (COND ((AND A B C) D)) (AND A B C D) Since there is no specific Boolean type in LISP and since every LISP expression has a value which may be used freely in conditionals, there is no hard and fast distinction between an arbitrary function and a Boolean function. However, the three functions presented here are by far the most useful in constructing more complex tests from simple predicates. Not Not _ ___ _______ ____ ________ ____ (Not U:any): boolean open-compiled, expr _ Returns T if U is NIL. This is exactly the same function as Null Null Null, defined in Section 4.2.2. Both are available solely to increase readability. And And _ ____ _____ _______ ____ ________ _____ (And [U:form]): extra-boolean open-compiled, fexpr And And _ And evaluates each U until a value of NIL is found or the end of ____ the list is encountered. If a non-NIL value is the last value, And And it is returned; otherwise NIL is returned. Note that And called with zero arguments returns T. PSL Manual 7 February 1983 Data Types section 4.2 page 4.9 Or Or _ ____ _____ _______ ____ ________ _____ (Or [U:form]): extra-boolean open-compiled, fexpr _ U is any number of expressions which are evaluated in order of their appearance. If one is found to be non-NIL, it is returned Or Or as the value of Or. If all are NIL, NIL is returned. Note that Or Or if Or is called with zero arguments, it returns NIL. 4.3. Converting Data Types 4.3. Converting Data Types 4.3. Converting Data Types The following functions are used in converting data items from one type to another. They are grouped according to the type returned. Numeric Fix Float Fix Float types may be converted using functions such as Fix and Float, described in Section 5.2. Intern Intern _ __ ______ __ ____ (Intern U:{id,string}): id expr Intern ______ __ Intern __ ____ _____ Converts string to id. Intern searches the id-hash-table (or __ ____ _____ __ current id-hash-table if the package system is loaded) for an id _ __ with the same print name as U and returns the id on the __ ____ _____ id-hash-table if a match is found. (See Chapter 6 for a __ ____ _____ discussion of the id-hash-table. Any properties and GLOBAL values _ _ associated with the uninterned U are lost. If U does not match _ any entry, a new one is created and returned. If U has more than the maximum number of characters permitted by the implementation (???), an error is signalled: ***** Too many characters to INTERN [??? Rewrite for package system; include search path, global, [??? Rewrite for package system; include search path, global, [??? Rewrite for package system; include search path, global, local, intern, etc. See Chapter 6. ???] local, intern, etc. See Chapter 6. ???] local, intern, etc. See Chapter 6. ???] The maximum number of characters in any token is 5000. NewId NewId _ ______ __ ____ (NewId S:string): id expr __ _____ ____ Allocates a new uninterned id, and sets its print-name to the ______ _ ______ ___ string S. The string is not copied. (Setq New (NewId "NEWONE")) returns NEWONE __ Note that if one refers directly to the id NEWONE, it will become interned and a new position in the id space will be allocated to __ __ it. One has to refer to the new id indirectly through the id New. Data Types 7 February 1983 PSL Manual page 4.10 section 4.3 Int2Id Int2Id _ _______ __ ____ (Int2Id I:integer): id expr _______ __ _ __ Converts an integer to an id; this refers to the I'th id in the Int2Id __ Int2Id id space. Since 0 ... 127 correspond to ASCII characters, Int2Id with an argument in this range converts an ASCII code to the __ corresponding single character id. (Int2Id 250) returns QUOTIENT Id2Int Id2Int _ __ _______ ____ (Id2Int D:id): integer expr __ _ _______ Returns the id space position of D as a LISP integer. (Id2Int 'String) returns 182 Id2String Id2String _ __ ______ ____ (Id2String D:id): string expr Id2String Print __ Id2String Print Get name from id space. Id2String returns the Print name of its ______ argument as a string. This is not a copy, so destructive CopyString CopyString operations should not be performed on the result. See CopyString in Chapter 8. [??? Should it be a copy? ???] [??? Should it be a copy? ???] [??? Should it be a copy? ???] (Id2String 'String) returns "STRING" String2List String2List _ ______ ____ ____ ____ (String2List S:string): inum-list expr Length Add1 Size ____ Length Add1 Size _ Creates a list of Length (Add1 (Size S)), converting the ASCII _______ characters into small integers. [??? What of 0/1 base for length vs length -1. What of the [??? What of 0/1 base for length vs length -1. What of the [??? What of 0/1 base for length vs length -1. What of the NUL char added ???] NUL char added ???] NUL char added ???] (String2List "STRING") returns (83 84 82 73 78 71) List2String List2String _ ____ ____ ______ ____ (List2String L:inum-list): string expr Size ______ Size _ ____ Allocates a string of the same Size as L, and converts inums to ____ characters according to their ASCII code. The inums must be in the range 0 ... 127. [??? Check if 0 ... 127, and signal error ???] [??? Check if 0 ... 127, and signal error ???] [??? Check if 0 ... 127, and signal error ???] (List2String '(83 84 82 73 78 71)) returns "STRING" PSL Manual 7 February 1983 Data Types section 4.3 page 4.11 String String _ ____ ______ _____ (String [I:inum]): string nexpr ______ ____ Creates and returns a string containing all the inums given. (String 83 84 82 73 78 71) returns "STRING" Vector Vector _ ___ ______ _____ (Vector [U:any]): vector nexpr ______ _ Creates and returns a vector containing all the Us given. (Setq X (Vector 83 84 82 73 78 71)) returns [83 84 82 73 78 71] Vector2String Vector2String _ ______ ______ ____ (Vector2String V:vector): string expr _______ ______ ______ Pack the small integers in the vector into a string of the same Size Size _______ Size, using the integers as ASCII values. [??? check for integer in range 0 ... 127 ???] [??? check for integer in range 0 ... 127 ???] [??? check for integer in range 0 ... 127 ???] (Vector2String X) where X is defined as above returns "STRING" String2Vector String2Vector _ ______ ______ ____ (String2Vector S:string): vector expr Size ______ ______ Size Unpack the string into a vector of the same Size. The elements ______ of the vector are small integers, representing the ASCII values _ of the characters in S. (String2Vector "VECTOR") returns [V E C T O R] Vector2List Vector2List _ ______ ____ ____ (Vector2List V:vector): list expr Size Length Upbv ____ Size _ Length Upbv _ Create a list of the same Size as V (i.e. of Length Upbv(V)+1), Upbv Upbv _ copying the elements in order 0, 1, ..., Upbv(V). (Vector2List [L I S T]) returns (L I S T) List2Vector List2Vector _ ____ ______ ____ (List2Vector L:list): vector expr Size ____ ______ Size Copy the elements of the list into a vector of the same Size. (List2Vector '(V E C T O R)) returns [V E C T O R] |
Added psl-1983/3-1/lpt/05-numbers.lpt version [e52f5c1245].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Arithmetic Functions section 5.0 page 5.1 CHAPTER 5 CHAPTER 5 CHAPTER 5 NUMBERS AND ARITHMETIC FUNCTIONS NUMBERS AND ARITHMETIC FUNCTIONS NUMBERS AND ARITHMETIC FUNCTIONS 5.1. Big Integers . . . . . . . . . . . . . . . 5.1 5.2. Conversion Between Integers and Floats. . . . . . . 5.2 5.3. Arithmetic Functions. . . . . . . . . . . . . 5.2 5.4. Functions for Numeric Comparison. . . . . . . . . 5.5 5.5. Bit Operations. . . . . . . . . . . . . . . 5.7 5.6. Various Mathematical Functions . . . . . . . . . 5.8 ______ Most of the arithmetic functions in PSL expect numbers as arguments. In all cases an error occurs if the parameter to an arithmetic function is not ______ a number: ***** Non-numeric argument in arithmetic Exceptions to the rule are noted. The underlying machine arithmetic requires parameters to be either all _______ _____ integers or all floats. If a function receives mixed types of arguments, _______ _____ integers are converted to floats before arithmetic operations are ______ _______ performed. The range of numbers which can be represented by an integer is _____ different than that represented by a float. Because of this difference, a conversion is not always possible; an unsuccessful attempt to convert may cause an error to be signalled. The MATHLIB package contains some useful mathematical functions. See Section 5.6 for documentation for these functions. 5.1. Big Integers 5.1. Big Integers 5.1. Big Integers Loading the BIG module redefines the basic arithmetic operations, including the logical operations, to permit arbitrary precision (or "bignum") integer operations. Note that fixnums which are present before loading BIG can cause problems, because loading BIG restricts the legal range of fixnums. 5.2. Conversion Between Integers and Floats 5.2. Conversion Between Integers and Floats 5.2. Conversion Between Integers and Floats The conversions mentioned above can be done explicitly by the following functions. Other functions which alter types can be found in Section 4.3. Arithmetic Functions 7 February 1983 PSL Manual page 5.2 section 5.2 Fix Fix _ ______ _______ ____ (Fix U:number): integer expr _______ Returns the integer which corresponds to the truncated value of _ U. The result of conversion must retain all significant portions _ _ _______ of U. If U is an integer it is returned unchanged. _____ _____ _____ [??? Note that unless big is loaded, a float with value [??? Note that unless big is loaded, a float with value [??? Note that unless big is loaded, a float with value larger than 2**35-1 on the DEC-20 is converted into something larger than 2**35-1 on the DEC-20 is converted into something larger than 2**35-1 on the DEC-20 is converted into something strange but without any error message. Note how truncation strange but without any error message. Note how truncation strange but without any error message. Note how truncation works on negative numbers (always towards zero). ???] works on negative numbers (always towards zero). ???] works on negative numbers (always towards zero). ???] (Fix 2.1) % returns 2 (Fix -2.1) % returns -2 Float Float _ ______ _____ ____ (Float U:number): float expr _____ _ The float corresponding to the value of the argument U is _______ returned. Some of the least significant digits of an integer may Float Float Float Float _____ be lost due to the implementation of Float. Float of a float ______ _ returns the number unchanged. If U is too large to represent in _____ float, an error occurs: ***** Argument to FLOAT is too large _______ _______ _______ [??? Only if big is loaded can one make an integer of value [??? Only if big is loaded can one make an integer of value [??? Only if big is loaded can one make an integer of value greater than 2**35-1, so without big you won't get this error greater than 2**35-1, so without big you won't get this error greater than 2**35-1, so without big you won't get this error message. The largest representable float is message. The largest representable float is message. The largest representable float is (2**62-1)*(2**65) on the DEC-20. ???] (2**62-1)*(2**65) on the DEC-20. ???] (2**62-1)*(2**65) on the DEC-20. ???] 5.3. Arithmetic Functions 5.3. Arithmetic Functions 5.3. Arithmetic Functions The functions described below handle arithmetic operations. Please note the remarks at the beginning of this Chapter regarding the mixing of argument types. Abs Abs _ ______ ______ ____ (Abs U:number): number expr Returns the absolute value of its argument. Add1 Add1 _ ______ ______ ____ (Add1 U:number): number expr _ Returns the value of U plus 1; the returned value is of the same _ _______ _____ type as U (integer or float). PSL Manual 7 February 1983 Arithmetic Functions section 5.3 page 5.3 Decr Decr _ ____ __ ______ ______ _____ (Decr U:form [Xi:number]): number macro Part of the USEFUL package (LOAD USEFUL). With only one argument, this is equivalent to (SETF U (SUB1 U)) With multiple arguments, it is equivalent to (SETF U (DIFFERENCE U (PLUS X1 ... Xn))) 1 lisp> (Load Useful) NIL 2 lisp> (Setq Y '(1 5 7)) (1 5 7) 3 lisp> (Decr (Car Y)) 0 4 lisp> Y (0 5 7) 5 lisp> (Decr (Cadr Y) 3 4) -2 6 lisp> Y (0 -2 7) Difference Difference _ ______ _ ______ ______ ____ (Difference U:number V:number): number expr _ _ The value of U - V is returned. Divide Divide _ ______ _ ______ ____ ____ (Divide U:number V:number): pair expr ____ ________ _________ The pair (quotient . remainder) is returned, as if the quotient Quotient Quotient part was computed by the Quotient function and the remainder by Remainder Remainder the Remainder function. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in Divide Expt Expt _ ______ _ _______ ______ ____ (Expt U:number V:integer): number expr _ _ _____ _ _______ _ Returns U raised to the V power. A float U to an integer power V ___ _ _____ does not have V changed to a float before exponentiation. Incr Incr _ ____ __ ______ ______ _____ (Incr U:form [Xi:number]): number macro Part of the USEFUL package (LOAD USEFUL). With only one argument, this is equivalent to Arithmetic Functions 7 February 1983 PSL Manual page 5.4 section 5.3 (SETF U (ADD1 U)) With multiple arguments it is equivalent to (SETF U (PLUS U X1 ... Xn)) Minus Minus _ ______ ______ ____ (Minus U:number): number expr _ Returns -U. Plus Plus _ ______ ______ _____ (Plus [U:number]): number macro Plus Plus Forms the sum of all its arguments. Plus may be called with only Plus Plus one argument. In this case it returns its argument. If Plus is called with no arguments, it returns zero. Plus2 Plus2 _ ______ _ ______ ______ ____ (Plus2 U:number V:number): number expr _ _ Returns the sum of U and V. Quotient Quotient _ ______ _ ______ ______ ____ (Quotient U:number V:number): number expr Quotient Quotient _ _ The Quotient of U divided by V is returned. Division of two _______ _ positive or two negative integers is conventional. If both U and _ _______ V are integers and exactly one of them is negative, the value Quotient Abs Quotient Abs _ returned is the negative truncation of the Quotient of Abs U and Abs Abs _ _____ _____ Abs V. If either argument is a float, a float is returned which _____ is exact within the implemented precision of floats. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in QUOTIENT Recip Recip _ ______ _____ ____ (Recip U:number): float expr Recip Recip _ _____ Recip converts U to a float if necessary, and then finds the Quotient Quotient inverse using the function Quotient. Remainder Remainder _ ______ _ ______ ______ ____ (Remainder U:number V:number): number expr _ _ _______ _______ If both U and V are integers the result is the integer remainder _ _ _____ of U divided by V. If either parameter is a float, the result is _ _ _ _ _____ the difference between U and V*(U/V), all in float (probably ______ 0.0). If either number is negative the remainder is negative. If both are positive or both are negative the remainder is _ positive. An error occurs if V is zero: PSL Manual 7 February 1983 Arithmetic Functions section 5.3 page 5.5 ***** Attempt to divide by 0 in REMAINDER Remainder Mod Remainder Mod Note that the Remainder function differs from the Mod function in Remainder Remainder _ _ that Remainder returns a negative number when U is negative and V is positive. Sub1 Sub1 _ ______ ______ ____ (Sub1 U:number): number expr _ _ _____ Returns the value of U minus 1. If U is a float, the value _ returned is U minus 1.0. Times Times _ ______ ______ _____ (Times [U:number]): number macro Times Times Returns the product of all its arguments. Times may be called with only one argument. In this case it returns the value of its Times Times argument. If Times is called with no arguments, it returns 1. Times2 Times2 _ ______ _ ______ ______ ____ (Times2 U:number V:number): number expr _ _ Returns the product of U and V. 5.4. Functions for Numeric Comparison 5.4. Functions for Numeric Comparison 5.4. Functions for Numeric Comparison The following functions compare the values of their arguments. For functions testing equality (or non-equality) see Section 4.2.1. Geq Geq _ ___ _ ___ _______ ____ (Geq U:any V:any): boolean expr _ _ Returns T if U >= V, otherwise returns NIL. In RLISP, the symbol ">=" can be used. GreaterP GreaterP _ ______ _ ______ _______ ____ (GreaterP U:number V:number): boolean expr _ _ Returns T if U is strictly greater than V, otherwise returns NIL. In RLISP, the symbol ">" can be used. Leq Leq _ ______ _ ______ _______ ____ (Leq U:number V:number): boolean expr _ _ Returns T if U <= V, otherwise returns NIL. In RLISP, the symbol "<=" can be used. Arithmetic Functions 7 February 1983 PSL Manual page 5.6 section 5.4 LessP LessP _ ______ _ ______ _______ ____ (LessP U:number V:number): boolean expr _ _ Returns T if U is strictly less than V, otherwise returns NIL. In RLISP, the symbol "<" can be used. Max Max _ ______ ______ _____ (Max [U:number]): number macro _ Returns the largest of the values in U (numeric maximum). If two or more values are the same, the first is returned. Max2 Max2 _ ______ _ ______ ______ ____ (Max2 U:number V:number): number expr _ _ _ _ Returns the larger of U and V. If U and V are of the same value _ _ _ U is returned (U and V might be of different types). Min Min _ ______ ______ _____ (Min [U:number]): number macro _ Returns the smallest (numeric minimum) of the values in U. If two or more values are the same, the first of these is returned. Min2 Min2 _ ______ _ ______ ______ ____ (Min2 U:number V:number): number expr _ _ Returns the smaller of its arguments. If U and V are the same _ _ _ value, U is returned (U and V might be of different types). MinusP MinusP _ ___ _______ ____ (MinusP U:any): boolean expr _ ______ _ ______ Returns T if U is a number and less than 0. If U is not a number ______ or is a positive number, NIL is returned. OneP OneP _ ___ _______ ____ (OneP U:any): boolean expr _ ______ Returns T if U is a number and has the value 1 or 1.0. Returns NIL otherwise. ZeroP ZeroP _ ___ _______ ____ (ZeroP U:any): boolean expr _ ______ Returns T if U is a number and has the value 0 or 0.0. Returns NIL otherwise. PSL Manual 7 February 1983 Arithmetic Functions section 5.5 page 5.7 5.5. Bit Operations 5.5. Bit Operations 5.5. Bit Operations The functions described in this section operate on the binary _______ representation of the integers given as arguments. The returned value is _______ an integer. LAnd LAnd _ _______ _ _______ _______ ____ (LAnd U:integer V:integer): integer expr And And Bitwise or logical And. Each bit of the result is independently determined from the corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 0 0 1 LOr LOr _ _______ _ _______ _______ ____ (LOr U:integer V:integer): integer expr Or Or Bitwise or logical Or. Each bit of the result is independently determined from corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 1 1 1 LNot LNot _ _______ _______ ____ (LNot U:integer): integer expr Not Not _ ______ Logical Not. Defined as (-U + 1) so that it works for bignums as if they were 2's complement. [??? need to clarify a bit more ???] [??? need to clarify a bit more ???] [??? need to clarify a bit more ???] LXOr LXOr _ _______ _ _______ _______ ____ (LXOr U:integer V:integer): integer expr Or Or Bitwise or logical exclusive Or. Each bit of the result is independently determined from the corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 1 1 0 LShift LShift _ _______ _ _______ _______ ____ (LShift N:integer K:integer): integer expr _ _ Shifts N to the left by K bits. The effect is similar to Arithmetic Functions 7 February 1983 PSL Manual page 5.8 section 5.5 _ K _ multiplying by 2 . It is an arithmetic shift. Negative values _ are acceptable for K, and cause a right shift (in the usual manner). 5.6. Various Mathematical Functions 5.6. Various Mathematical Functions 5.6. Various Mathematical Functions The optionally loadable MATHLIB module defines several commonly used mathematical functions. Some effort has been made to be compatible with Common Lisp, but this implementation tends to support fewer features. The examples used here should be taken with a grain of salt, since the precision of the results will depend on the machine being used, and may change in later implementations of the module. Ceiling Ceiling _ ______ _______ ____ (Ceiling X:number): integer expr _______ _ Returns the smallest integer greater than or equal to X. For example: 1 lisp> (ceiling 2.1) 3 2 lisp> (ceiling -2.1) -2 Floor Floor _ ______ _______ ____ (Floor X:number): integer expr _ Returns the largest integer less than or equal to X. (Note that Fix Fix this differs from the Fix function.) 1 lisp> (floor 2.1) 2 2 lisp> (floor -2.1) -3 3 lisp> (fix -2.1) -2 Round Round _ ______ _______ ____ (Round X:number): integer expr 1 _ Returns the nearest integer to X. _______________ 1 Round Round The behavior of Round is ambiguous when its argument ends in ".5"--needs more work. PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.9 TransferSign TransferSign _ ______ ___ ______ ______ ____ (TransferSign S:number Val:number): number expr abs _ ___ abs ___ _ Transfers the sign of S to VAL by returning abs(VAL) if S >= 0, abs sign abs ___ sign and -abs(VAL) otherwise. (The same as FORTRANs sign function.) Mod Mod _ _______ _ _______ _______ ____ (Mod M:integer N:integer): integer expr remainder _ _ remainder Returns M modulo N. Unlike the remainder function, it returns a _ _ _ _ _ positive number in the range 0..N-1 when N is positive, even if M is negative. 1 lisp> (mod -7 5) 3 2 lisp> (remainder -7 5) -2 [??? Allow to "number" arguments instead of just "integers"? [??? Allow to "number" arguments instead of just "integers"? [??? Allow to "number" arguments instead of just "integers"? ???] ???] ???] DegreesToRadians DegreesToRadians _ ______ ______ ____ (DegreesToRadians X:number): number expr Returns an angle in radians given an angle in degrees. 1 lisp> (DegreesToRadians 180) 3.1415926 RadiansToDegrees RadiansToDegrees _ ______ ______ ____ (RadiansToDegrees X:number): number expr Returns an angle in degrees given an angle in radians. 1 lisp> (RadiansToDegrees 3.1415926) 180.0 RadiansToDMS RadiansToDMS _ ______ ____ ____ (RadiansToDMS X:number): list expr _ _______ Given an angle X in radians, returns a list of three integers giving the angle in (Degrees Minutes Seconds) . 1 lisp> (RadiansToDMS 1.0) (57 17 45) Arithmetic Functions 7 February 1983 PSL Manual page 5.10 section 5.6 DMStoRadians DMStoRadians ____ ______ ____ ______ ____ ______ ______ ____ (DMStoRadians Degs:number Mins:number Secs:number): number expr Returns an angle in radians, given three arguments representing an angle in degrees minutes and seconds. 1 lisp> (DMStoRadians 57 17 45) 1.0000009 2 lisp> (DMStoRadians 180 0 0) 3.1415926 DegreesToDMS DegreesToDMS _ ______ ____ ____ (DegreesToDMS X:number): list expr _ _______ Given an angle X in degrees, returns a list of three integers giving the angle in (Degrees Minutes Seconds). DMStoDegrees DMStoDegrees ____ ______ ____ ______ ____ ______ ______ ____ (DMStoDegrees Degs:number Mins:number Secs:number): number expr Returns an angle in degrees, given three arguments representing an angle in degrees minutes and seconds. Sin Sin _ ______ ______ ____ (Sin X:number): number expr sine sine _ Returns the sine of X, an angle in radians. SinD SinD _ ______ ______ ____ (SinD X:number): number expr sine sine _ Returns the sine of X, an angle in degrees. Cos Cos _ ______ ______ ____ (Cos X:number): number expr cosine cosine _ Returns the cosine of X, an angle in radians. CosD CosD _ ______ ______ ____ (CosD X:number): number expr cosine cosine _ Returns the cosine of X, an angle in degrees. Tan Tan _ ______ ______ ____ (Tan X:number): number expr tangent tangent _ Returns the tangent of X, an angle in radians. TanD TanD _ ______ ______ ____ (TanD X:number): number expr tangent tangent _ Returns the tangent of X, an angle in degrees. PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.11 Cot Cot _ ______ ______ ____ (Cot X:number): number expr cotangent cotangent _ Returns the cotangent of X, an angle in radians. CotD CotD _ ______ ______ ____ (CotD X:number): number expr cotangent cotangent _ Returns the cotangent of X, an angle in degrees. Sec Sec _ ______ ______ ____ (Sec X:number): number expr secant secant _ Returns the secant of X, an angle in radians. secant(X) = 1/cos(X) SecD SecD _ ______ ______ ____ (SecD X:number): number expr secant secant _ Returns the secant of X, an angle in degrees. Csc Csc _ ______ ______ ____ (Csc X:number): number expr cosecant cosecant _ Returns the cosecant of X, an angle in radians. secant(X) = 1/sin(X) CscD CscD _ ______ ______ ____ (CscD X:number): number expr cosecant cosecant _ Returns the cosecant of X, an angle in degrees. Asin Asin _ ______ ______ ____ (Asin X:number): number expr arc sine arc sine _ Returns the arc sine, as an angle in radians, of X. sin(asin(X)) = X AsinD AsinD _ ______ ______ ____ (AsinD X:number): number expr arc sine arc sine _ Returns the arc sine, as an angle in degrees, of X. Arithmetic Functions 7 February 1983 PSL Manual page 5.12 section 5.6 Acos Acos _ ______ ______ ____ (Acos X:number): number expr arc cosine arc cosine _ Returns the arc cosine, as an angle in radians, of X. cos(acos(X)) = X AcosD AcosD _ ______ ______ ____ (AcosD X:number): number expr arc cosine arc cosine _ Returns the arc cosine, as an angle in degrees, of X. Atan Atan _ ______ ______ ____ (Atan X:number): number expr arc tangent arc tangent _ Returns the arc tangent, as an angle in radians, of X. tan(atan(X)) = X AtanD AtanD _ ______ ______ ____ (AtanD X:number): number expr arc tangent arc tangent _ Returns the arc tangent, as an angle in degrees, of X. Atan2 Atan2 _ ______ _ ______ ______ ____ (Atan2 Y:number X:number): number expr Returns an angle in radians corresponding to the angle between _ _ _ the X axis and the vector (X,Y). (Note that Y is the first argument.) 1 lisp> (atan2 0 -1) 3.1415927 Atan2D Atan2D _ ______ _ ______ ______ ____ (Atan2D Y:number X:number): number expr Returns an angle in degrees corresponding to the angle between _ _ the X axis and the vector (X,Y). 1 lisp> (atan2D -1 1) 315.0 Acot Acot _ ______ ______ ____ (Acot X:number): number expr arc cotangent arc cotangent _ Returns the arc cotangent, as an angle in radians, of X. cot(acot(X)) = X PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.13 AcotD AcotD _ ______ ______ ____ (AcotD X:number): number expr arc cotangent arc cotangent _ Returns the arc cotangent, as an angle in degrees, of X. Asec Asec _ ______ ______ ____ (Asec X:number): number expr arc secant arc secant _ Returns the arc secant, as an angle in radians, of X. sec(asec(X)) = X AsecD AsecD _ ______ ______ ____ (AsecD X:number): number expr arc secant arc secant _ Returns the arc secant, as an angle in degrees, of X. Acsc Acsc _ ______ ______ ____ (Acsc X:number): number expr arc cosecant arc cosecant _ Returns the arc cosecant, as an angle in radians, of X. csc(acsc(X)) = X AcscD AcscD _ ______ ______ ____ (AcscD X:number): number expr arc cosecant arc cosecant _ Returns the arc cosecant, as an angle in degrees, of X. Sqrt Sqrt _ ______ ______ ____ (Sqrt X:number): number expr _ Returns the square root of X. Exp Exp _ ______ ______ ____ (Exp X:number): number expr _ X _ _ Returns the exponential of X, i.e. e . Log Log _ ______ ______ ____ (Log X:number): number expr _ _ Returns the natural (base e) logarithm of X. log(exp(X)) = X Arithmetic Functions 7 February 1983 PSL Manual page 5.14 section 5.6 Log2 Log2 _ ______ ______ ____ (Log2 X:number): number expr _ Returns the base two logarithm of X. Log10 Log10 _ ______ ______ ____ (Log10 X:number): number expr _ Returns the base ten logarithm of X. Random Random _ _______ _______ ____ (Random N:integer): integer expr Returns a pseudo-random number uniformly selected from the range _ 0..N-1. The random number generator uses a linear congruential method. To get a reproducible sequence of random numbers you should assign one (or some other small number) to the FLUID variable RANDOMSEED. __________ ______ RANDOMSEED [Initially: set from time] global Factorial Factorial _ _______ _______ ____ (Factorial N:integer): integer expr _ Returns the factorial of N. factorial(0) = 1 factorial(N) = N*factorial(N-1) |
Added psl-1983/3-1/lpt/06-ids.lpt version [7fc7d2f684].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Identifiers section 6.0 page 6.1 CHAPTER 6 CHAPTER 6 CHAPTER 6 IDENTIFIERS IDENTIFIERS IDENTIFIERS 6.1. Introduction . . . . . . . . . . . . . . . 6.1 6.2. Fields of Ids . . . . . . . . . . . . . . . 6.2 6.3. Identifiers and the Id-Hash-Table . . . . . . . . 6.2 6.3.1. Identifier Functions . . . . . . . . . . 6.3 6.3.2. Find. . . . . . . . . . . . . . . . 6.4 6.4. Property List Functions. . . . . . . . . . . . 6.5 6.4.1. Functions for Flagging Ids . . . . . . . . 6.6 6.4.2. Direct Access to the Property Cell. . . . . . 6.7 6.5. Value Cell Functions. . . . . . . . . . . . . 6.7 6.6. Package System Functions . . . . . . . . . . . 6.10 6.7. System Global Variables, Switches and Other "Hooks" . . 6.13 6.7.1. Introduction . . . . . . . . . . . . . 6.13 6.7.2. Setting Switches. . . . . . . . . . . . 6.14 6.7.3. Special Global Variables . . . . . . . . . 6.15 6.7.4. Special Put Indicators. . . . . . . . . . 6.15 6.7.5. Special Flag Indicators . . . . . . . . . 6.16 6.7.6. Displaying Information About Globals . . . . . 6.16 6.1. Introduction 6.1. Introduction 6.1. Introduction __________ __ __________ In PSL variables are called identifiers or ids. An identifier is implemented as a tagged data object (described in Chapter 4) containing a __ _____ pointer or offset into a five item structure - the id space. One item in this structure is called the print name, which is the external __ representation of the id. __ ____ _____ The interpreter uses an id hash table to get from the print name of an __________ __ _____ __ _____ __ ____ identifier to its entry in the id space. The id space and the id hash _____ table are described below. Sometimes there is a need for more than one name space when one is building a large system. For example, one may wish to allow several programmers to each produce a part of a system without having to worry about name conflicts. PSL provides a package system for this purpose, __ ____ _____ giving the user a tree-structured id hash table. Identifiers 7 February 1983 PSL Manual page 6.2 section 6.2 6.2. Fields of Ids 6.2. Fields of Ids 6.2. Fields of Ids __ ____ ____ ____ An id is an item with an info field; the info field is an offset into a __ _____ ____ special id space consisting of structures of 5 fields. The fields (items) are: _____ ____ ______ print-name The print name points at a string of characters which is the __________ external representation of the identifier. The syntax for __________ identifiers is described in Section 12.5 on reading functions. ________ ____ property-cell One may want to associate various flags and properties with __________ an identifier. These can be stored on a property-list for __ an id, flags by name and properties by an (indicator . __ value) pair. The property cell of an id contains a pointer to this list. Access is by means of functions defined in Section 6.4. _____ ____ __________ value-cell The value of the identifier or a pointer to the value in the heap is stored in this field. If no value exists, this cell __________ contains an unbound identifier indicator. These cells can be accessed by functions defined in this chapter. _____ _____ _____ macro ________ ____ ________ macro function-cell An id may have a function or macro associated with it. PutD GetD RemD PutD GetD RemD Access is by means of the PutD, GetD, and RemD functions defined in Section 10.1.2. _______ ____ package-cell PSL permits the use of a multiple package facility (multiple __ ____ _____ id hash table). The package cell refers to the appropriate __ ____ _____ id hash table. 6.3. Identifiers and the Id hash table 6.3. Identifiers and the Id hash table 6.3. Identifiers and the Id hash table __________ The method used by PSL to retrieve information about an identifier makes __ ____ _____ use of the id hash table (corresponding to the Oblist, or Object list, in __________ some versions of LISP). A hash function is applied to the identifier name __ ____ _____ giving a position in the id hash table. The contents of the hash table at __ _____ __________ that point contain an offset into the id space. For a new identifier, the __ _____ next free position in the id space is found and a pointer to it is placed in the hash table entry. __ The process of putting an id into the hash table is called interning. __ This is done automatically by the LISP reader, so any id typed in at the terminal is interned. Interning can also be done by the programmer using Intern Intern ______ __ __ the function Intern to convert a string to an id. An id may have an entry __ _____ in the id space without being interned. In fact it is possible to have __ several ids with the same print name, one interned and the others not. __ (The use of the package system allows one to have several interned ids with the same print name.) __ _____ Note that when one starts PSL, the id space already contains __ approximately 2000 ids. These include all of the ASCII characters, the functions and globals described in this manual, plus system functions and PSL Manual 7 February 1983 Identifiers section 6.3 page 6.3 globals. If a user uses any of these names for his own functions or globals, there can be a conflict. This is another reason for having a package system. A warning message appears if a user tries to redefine a system function. ? Do you really want to redefine the system function 'name? (Y or N) If the user answers "Y", his definition replaces the current definition. ________ (See Chapter 10 for a description of the switch !*USERMODE which controls the printing of this message.) __ ____ _____ Basic PSL currently provides a single id hash table. PSL provides all the "hooks" to permit a package system to be loaded as an option; certain functions are redefined in this process. If the package system is loaded, __ ____ _____ a tree-structured id hash table can be created in which each level can be __ ____ _____ __ ______ thought of as a smaller id hash table. If a new id or string is to be interned, it is searched for in the tree according to a specified rule. For more information see Section 6.6. __ Information on converting ids to other types can be found in Chapter 12 and Section 4.3. 6.3.1. Identifier Functions 6.3.1. Identifier Functions 6.3.1. Identifier Functions __________ __ ____ _____ The following functions deal with identifiers and the id hash table. GenSym GenSym __ ____ (GenSym ): id expr __________ Creates an identifier which is not interned on the id hash table Eq Eq __ and consequently not Eq to anything else. The id is derived from a string of the form "G0000", which is incremented upon each call GenSym GenSym to GenSym. [??? Is this interned or recorded on the NIL package ???] [??? Is this interned or recorded on the NIL package ???] [??? Is this interned or recorded on the NIL package ???] [??? Can we change the GenSym string ???] [??? Can we change the GenSym string ???] [??? Can we change the GenSym string ???] InternGenSym InternGenSym __ ____ (InternGenSym ): id expr GenSym GenSym __ Similar to GenSym but returns an interned id. StringGenSym StringGenSym ______ ____ (StringGenSym ): string expr GenSym GenSym ______ Similar to GenSym but returns a string of the form "L0000" __ instead of an id. Identifiers 7 February 1983 PSL Manual page 6.4 section 6.3 RemOb RemOb _ __ _ __ ____ (RemOb U:id): U:id expr _ If U is present on the current package search path it is removed. _ This does not affect U having properties, flags, functions and _ the like. U is returned. InternP InternP _ __ ______ _______ ____ (InternP U:{id,string}): boolean expr _ Returns T if U is interned in the current search path. MapObl MapObl _____ ________ _________ ____ (MapObl FNAME:function): Undefined expr MapObl MapObl _____ __ MapObl applies function FNAME to each id interned in the current hash table. 6.3.2. Find 6.3.2. Find 6.3.2. Find ______ __ __ ____ These functions take a string or id as an argument, and scan the id hash _____ __ table to collect a list of ids with prefix or suffix matching the argument. This is a loadable option (LOAD FIND). FindPrefix FindPrefix ___ __ ______ __ ____ ____ (FindPrefix KEY:{id, string}): id-list expr __ ____ _____ __ ___ Scans current id hash table for all ids whose prefix matches KEY. Returns all the identifiers found as an alphabetically sorted list. FindSuffix FindSuffix ___ __ ______ __ ____ ____ (FindSuffix KEY:{id, string}): id-list expr __ ____ _____ __ ___ Scans current id hash table for all ids whose suffix matches KEY. Returns all the identifiers found as an alphabetically sorted list. (Setq X (FindPrefix '!*) % Finds all identifiers starting with * (Setq Y (FindSuffix "STRING")) % Finds all identifiers ending with S 6.4. Property List Functions 6.4. Property List Functions 6.4. Property List Functions __________ ____ ____ The property cell of an identifier points to a "property list". The list __ is used to quickly associate an id name with a set of entities; those __ entities are called "flags" if their use gives the id a boolean value, and __ "properties" if the id is to have an arbitrary attribute (an indicator with a property). PSL Manual 7 February 1983 Identifiers section 6.4 page 6.5 Put Put _ __ ___ __ ____ ___ ___ ____ (Put U:id IND:id PROP:any): any expr ___ ____ The indicator IND with the property PROP is placed on the Put ____ __ _ Put property list of the id U. If the action of Put occurs, the ____ _ ___ __ value of PROP is returned. If either of U and IND are not ids the type mismatch error occurs and no property is placed. (Put 'Jim 'Height 68) The above returns 68 and places (Height . 68) on the property __ list of the id Jim. Get Get _ __ ___ __ ___ ____ (Get U:id IND:id): any expr ___ Returns the property associated with indicator IND from the ____ _ _ ___ property list of U. If U does not have indicator IND, NIL is Get Get Get Get returned. (In older LISPs, Get could access functions.) Get _ __ returns NIL if U is not an id. (Get 'Jim 'Height) returns 68 DefList DefList _ ____ ___ __ ____ ____ (DefList U:list IND:id): list expr _ U is a list in which each element is a two-element list: __ __ ____ ___ __ _ ___ (ID:ID PROP:ANY). Each id in U has the indicator IND with Put Put property PROP placed on its property list by the Put function. DefList DefList ____ The value of DefList is a list of the first elements of each Put DefList Put DefList two-element list. Like Put, DefList may not be used to define functions. (DE DEFLIST (U IND) (COND ((NULL U) NIL) (T (CONS(PROGN(PUT (CAAR U) IND (CADAR U)) (CAAR U)) (DEFLIST (CDR U) IND))))) RemProp RemProp _ __ ___ __ ___ ____ (RemProp U:id IND:id): any expr ___ ____ Removes the property with indicator IND from the property list of _ U. Returns the removed property or NIL if there was no such indicator. RemPropL RemPropL _ __ ____ ___ __ ___ ____ (RemPropL U:id-list IND:id): NIL expr ___ __ _ Remove property IND from all ids in U. Identifiers 7 February 1983 PSL Manual page 6.6 section 6.4 6.4.1. Functions for Flagging Ids 6.4.1. Functions for Flagging Ids 6.4.1. Functions for Flagging Ids __ In some LISPs, flags and indicators may clash. In PSL, flags are ids and ____ properties are pairs on the prop-list, so no clash occurs. Flag Flag _ __ ____ _ __ ___ ____ (Flag U:id-list V:id): NIL expr Flag Flag Flag __ _ _ Flag Flag flags each id in U with V; that is, the effect of Flag is FlagP __ _ _ FlagP _ that for each id X in U, FlagP(X, V) has the value T. Both V and _ __________ all the elements of U must be identifiers or the type mismatch Flag Flag __ _ error occurs. After Flagging, the id V appears on the property __ _ list of each id X in U. However, flags cannot be accessed, placed on, or removed from property lists using normal property Get Put RemProp Get Put RemProp list functions Get, Put, and RemProp. Note that if an error Flag Flag __ _ occurs during execution of Flag, then some of the ids on U may be _ flagged with V, and others may not be. The statement below causes the flag "Lose" to be placed on the property lists of the __ ids X and Y. (Flag '(X Y) 'Lose) FlagP FlagP _ __ _ __ _______ ____ (FlagP U:id V:id): boolean expr _ _ Returns T if U has been flagged with V; otherwise returns NIL. _ _ __ Returns NIL if either U or V is not an id. RemFlag RemFlag _ __ ____ _ __ ___ ____ (RemFlag U:id-list V:id): NIL expr _ ____ Removes the flag V from the property list of each member of the ____ _ _ _ __ list U. Both V and all the elements of U must be ids or the type mismatch error occurs. Flag1 Flag1 _ __ _ ___ _________ ____ (Flag1 U:id V:any): Undefined expr _ __ _ Puts flag V on the property list of id U. RemFlag1 RemFlag1 _ __ _ ___ _________ ____ (RemFlag1 U:id V:any): Undefined expr _ __ _ Removes the flag V from the property list of id U. [??? Make Flag1 and RemFlag1 return single value. ???] [??? Make Flag1 and RemFlag1 return single value. ???] [??? Make Flag1 and RemFlag1 return single value. ???] PSL Manual 7 February 1983 Identifiers section 6.4 page 6.7 6.4.2. Direct Access to the Property Cell 6.4.2. Direct Access to the Property Cell 6.4.2. Direct Access to the Property Cell Use of the following functions can destroy the integrity of the property ____ list. Since PSL uses properties at a low level, care should be taken in the use of these functions. Prop Prop _ __ ___ ____ (Prop U:id): any expr ____ _ Returns the property list of U. SetProp SetProp _ __ _ ___ _ ___ ____ (SetProp U:id L:any): L:any expr _ ____ _ Store item L as the property list of U. 6.5. Value Cell Functions 6.5. Value Cell Functions 6.5. Value Cell Functions Eval Eval The contents of the value cell are usually accessed by Eval (Chapter 11) ValueCell Set SetQ ValueCell Set SetQ or ValueCell (below) and changed by Set or SetQ. Set Set ___ __ _____ ___ ___ ____ (Set EXP:id VALUE:any): any expr ___ __________ EXP must be an identifier or a type mismatch error occurs. The Set Set effect of Set is replacement of the item bound to the identifier _____ by VALUE. If the identifier is not a LOCAL variable or has not been declared GLOBAL, it is automatically declared FLUID with the resulting warning message: *** EXP declared FLUID ___ EXP must not evaluate to T or NIL or an error occurs: ***** Cannot change T or NIL SetQ SetQ ________ __ _____ ___ ___ _____ (SetQ VARIABLE:id VALUE:any): any fexpr ________ The value of the current binding of VARIABLE is replaced by the _____ value of VALUE. (SETQ X 1) is equivalent to (SET 'X 1) SetQ SetQ SetQ now conforms to the Common LISP standard, allowing sequential assignment: Identifiers 7 February 1983 PSL Manual page 6.8 section 6.5 (SETQ A 1 B 2) ==> (SETQ A 1) (SETQ B 2) DeSetQ DeSetQ _ ___ _ ___ _ ___ _____ (DeSetQ U:any V:any): V:any macro DeSetQ DeSetQ This is a function in "USEFUL" (Load USEFUL; in RLISP). DeSetQ SetQ SetQ is a destructuring SetQ. That is, the first argument is a piece SetQ ____ ____ __ SetQ of list structure whose atoms are all ids. Each is SetQ'd to the corresponding part of the second argument. For instance (DeSetQ (a (b) . c) '((1) (2) (3) 4)) SetQ SetQ SetQ's a to (1), b to 2, and c to ((3) 4). PSetQ PSetQ ________ __ _____ ___ _________ _____ (PSetQ [VARIABLE:id VALUE:any]): Undefined macro Part of the USEFUL package (LOAD USEFUL). (PSETQ VAR1 VAL1 VAR2 VAL2 ... VARn VALn) SetQ SetQ SetQ's the VAR's to the corresponding VAL's. The VAL's are all evaluated before any assignments are made. That is, this is a SetQ SetQ parallel SetQ. SetF SetF ___ ____ ___ ___ ___ ___ _____ (SetF [LHS:form RHS:any]): RHS:any macro SetF SetF SetF SetF There are two versions of SetF. SetF is redefined on loading SetF SetF SetF SetF USEFUL. The description below is for the resident SetF. SetF provides a method for assigning values to expressions more __ general than simple ids. For example: (SETF (CAR X) 2) ==> CAR X := 2; is equivalent to (RPLACA X 2) SetF SetF In general, SetF has the form (SetF LHS RHS) ___ ___ in which LHS is the "left hand side" to be assigned to and RHS is ___ evaluated to the value to be assigned. LHS can be one of the following: SetQ __ SetQ id SetQ is used to assign a value to the PSL Manual 7 February 1983 Identifiers section 6.5 page 6.9 __ id. Eval Set SetQ Eval Set SetQ (Eval expression) Set is used instead of SetQ. In Eval Eval effect, the "Eval" cancels out the Quote Quote "Quote" which would normally be used. Value Eval Value Eval (Value expression) Is treated the same as Eval. Car RplacA Car ____ RplacA (Car pair) RplacA is used to store into the Car "field". Cdr RplacD Cdr ____ RplacD (Cdr pair) RplacD is used to store into the Cdr "field". GetV PutV GetV ______ PutV (GetV vector) PutV is used to store into the appropriate location. Indx SetIndx Indx SetIndx (Indx "indexable object") SetIndx is used to store into the object. Sub SetSub Sub ______ SetSub (Sub vector) SetSub is used to store into the appropriate subrange of the vector. Car Cdr SetF ___ Car ____ Cdr ____ SetF Note that if the LHS is (Car pair) or (Cdr pair), SetF returns SetF RplacA ___ SetF RplacA the modified pair instead of the RHS, because SetF uses RplacA RplacD RplacD and RplacD in these cases. SetF Caar Cadr SetF Caar Cadr Loading USEFUL brings in declarations to SetF about Caar, Cadr, Cddddr Cddddr ... Cddddr. This is rather handy with constructor/selector Cadadr Cadadr macros. For instance, if FOO is a selector which maps to Cadadr, (SETF (FOO X) Y) works; that is, it maps to something which does a (RPLACA (CDADR X) Y) and then returns X. PSetF PSetF ___ ____ ___ ___ _________ _____ (PSetF [LHS:form RHS:any]): Undefined macro PSetF SetF PSetF SetF Part of the USEFUL package (LOAD USEFUL). PSetF does a SetF in ___ parallel: i.e. it evaluates all the right hand sides (RHS) before ___ assigning any to the left hand sides (LHS). MakeUnBound MakeUnBound _ __ _________ ____ (MakeUnBound U:id): Undefined expr _ __ Make U an unbound id by storing a "magic" number in the value cell. ValueCell ValueCell _ __ ___ ____ (ValueCell U:id): any expr __ _ Safe access to the value cell of an id. If U is not an id a type _ mismatch error is signalled; if U is an unbound id, an unbound id Identifiers 7 February 1983 PSL Manual page 6.10 section 6.5 _ error is signalled. Otherwise the current value of U is Value LispVar Value LispVar returned. [See also the Value and LispVar functions, described in Chapter 20, for more direct access]. UnBoundP UnBoundP _ __ _______ ____ (UnBoundP U:id): boolean expr _ Tests whether U has no value. [??? Define and describe General Property LISTs or hash-tables. See [??? Define and describe General Property LISTs or hash-tables. See [??? Define and describe General Property LISTs or hash-tables. See Hcons. ???] Hcons. ???] Hcons. ???] 6.6. Package System Functions 6.6. Package System Functions 6.6. Package System Functions To get the package system (Load Package). An example of the use of this system is at the end of this section. The character "\" is normally reserved in the basic Read-Table (see Chapter 12) to make up multi-part names of the form "PackageName\LocalId". If the package system is loaded, the Intern process starts searching a path in a linked structure from "PackageName", itself an id accessible in the "CurrentPackage". The print-name is still "LocalId", but the additional Prin1 Prin2 Prin1 Prin2 package field in each id records "PackageName". Prin1 and Prin2 are modified to access this field in loading the package system. The root of the tree is the GLOBAL package, indicated by \. If the package system is loaded, the basic id hash table is made into the GLOBAL package. Thus \ID is guaranteed in the root (in fact the pre-existing id hash table). [??? Explain further or at least more clearly. ???] [??? Explain further or at least more clearly. ???] [??? Explain further or at least more clearly. ???] The following fluid variables are managed by the package system. __________ ______ \CURRENTPACKAGE!* [Initially: Global] global This is the start of the search path if interning. \CurrentPackage!* \CurrentPackage!* \CurrentPackage!* is rebound in the token scanner on encountering a "\". __________ ______ \PACKAGENAMES!* [Initially: (Global)] global List of ALL package names currently created. Our current package model uses a set of general path functions that access functions specific to each level of the id hash table tree to do various things: "Localxxxx(s)" and "Pathxxxx(s)" in which "xxxx" is one of InternP, Intern, RemOb, MapObl InternP, Intern, RemOb, MapObl the set (InternP, Intern, RemOb, MapObl). By storing different functions, each package may have a different structure and associated functions. The ______ current implementation of a package uses a vector PSL Manual 7 February 1983 Identifiers section 6.6 page 6.11 [Name Father GetFn PutFn RemFn MapFn] __ stored under the indicator 'Package on the PackageName id. A simple bucket id hash table can also be used for experiments, or the user can build his own. As far as possible, each function checks that a legal package is given before performing the operation. [??? Should we have a package Tag ???] [??? Should we have a package Tag ???] [??? Should we have a package Tag ???] The following functions should be used. \CreatePackage \CreatePackage ____ __ _____________ __ __ ____ (\CreatePackage NAME:id FATHERPACKAGE:id): id expr This creates a convenient size id hash table, generates the functions to manage it for this package, and links the new _____________ package to the FATHERPACKAGE so that path searches for ids are required. \SetPackage \SetPackage ____ __ __ ____ (\SetPackage NAME:id): id expr ______ Selects another package such as GLOBAL\. \PathInternP \PathInternP _ __ ______ _______ ____ (\PathInternP S:{id string}): boolean expr _ Searches from CurrentPackage!* to see if S is interned. \PathIntern \PathIntern _ __ ______ __ ____ (\PathIntern S:{id string}): id expr __ Look up or insert an id. \PathRemob \PathRemob _ __ ______ __ ____ (\PathRemob S:{id string}): id expr Remobs, puts in NIL package. \PathMapObl \PathMapObl _ ________ ___ ____ (\PathMapObl F:function): NIL expr _ __ Applies F to ALL ids in path. \LocalInternP \LocalInternP _ __ ______ _______ ____ (\LocalInternP S:{id string}): boolean expr Searches in CURRENTPACKAGE!*. Identifiers 7 February 1983 PSL Manual page 6.12 section 6.6 \LocalIntern \LocalIntern _ __ ______ __ ____ (\LocalIntern S:{id string}): id expr __ Look up or insert in CURRENTPACKAGE!* (forces ids uninterned in CURRENTPACKAGE!* into CURRENTPACKAGE!*) . \LocalRemob \LocalRemob _ __ ______ __ ____ (\LocalRemob S:{id string}): id expr Remobs, puts in NIL package. \LocalMapObl \LocalMapObl _ ________ ___ ____ (\LocalMapObl F:function): NIL expr _ __ Applies F to ALL ids in (CurrentPackage!*). ______ Note that if a string is used, it CANNOT include the \. Also, since most __ ids are "RAISED" on input, be careful. \PathIntern \PathIntern Current intern, etc. are \PathIntern, etc. Several restrictions are placed on the use of packages when compiled. Since it is a loaded module and not integrated with the basic PSL system, all ids in the compiled package are Interned in Global\ before they are defined. This requires a slightly more complex loading system for packages. Names and function ids which conflict with names in Global\ (or other packages in the path) must be forced into the id hash table of the desired package. The package is compiled WITHOUT the package module loaded. In addition, if a function call must be issued for a function which has been redefined in the package the function name must be changed. When Fasl Fasl PACKAGE has been integrated with Fasl and PSL, it will be sufficient to prefix the function name with the package name (e.g. Global\Print). Currently, one must actually change the function name (e.g. Global!.Print). Other problems in the package system include: a. Single character identifiers are handled specially (i.e. not interned) and therefore may not be used in any packages without doing an explicit intern b. By leaving the the package identifier and '\' off the identifier will place it in the Global\ package instead of the current package c. If an identifier is installed in the Global\ package, then reference to it with another package identifier will return the Global\ value instead of issuing an error Print Print As an example, a small package which redefines the system function Print PSL Manual 7 February 1983 Identifiers section 6.6 page 6.13 is shown. The assumed file name is PrintPack.SL. (De GetFieldFn (Relation Field) (Slotdescslotfn (Cdr (Assoc Field (Dsdescslotalist Getdefstruct Relation))))) (Df Print (Args) (Prog (Fields) (Setq Fields (Get (Car Args) 'Fields)) (Foreach Elem In (Eval (Car Args)) Do (Cons Global!.Print (Foreach Field In Fields Collect (Apply (GetFieldFn (Car Args) Field) ('List Elem))))) (Return (Car Args)))) This package would be compiled as follows (immediately after entering PSL): (Faslout "PrintPackage") (Dskin "PrintPack.SL"$) (Faslend) (Quit) This package would be loaded as follows (immediately after entering PSL): (Load '(Defstruct Package)) (CopyD 'Global!.Print Print) (Progn (\CreatePackage 'PrintPack 'Global) (\SetPAckage 'PrintPack) (LocalIntern 'Print)) (Faslin "PrintPack.B") 6.7. System Global Variables, Switches and Other "Hooks" 6.7. System Global Variables, Switches and Other "Hooks" 6.7. System Global Variables, Switches and Other "Hooks" 6.7.1. Introduction 6.7.1. Introduction 6.7.1. Introduction A number of global variables provide global control of the LISP system, or implement values which are constant throughout execution. Certain options are controlled by switches, with T or NIL properties (e.g. ECHOing as a file is read in); others require a value, such as an integer for the current output base. PSL has the convention (following the REDUCE/RLISP convention) of using a "!*" in the name of the variable: !*XXXXX for GLOBAL variables expecting a T/NIL value (called "switches"), and XXXXX!* for other GLOBALs. Chapter 26 is an index of switches and global variables used in PSL. Identifiers 7 February 1983 PSL Manual page 6.14 section 6.7 [??? These should all be FLUIDs, so that ANY one of these variables may [??? These should all be FLUIDs, so that ANY one of these variables may [??? These should all be FLUIDs, so that ANY one of these variables may be rebound, as appropriate ???] be rebound, as appropriate ???] be rebound, as appropriate ???] 6.7.2. Setting Switches 6.7.2. Setting Switches 6.7.2. Setting Switches Strictly speaking, XXXX is a switch and !*XXXX is a corresponding global variable that assumes the T/NIL value; both are loosely referred to as switches elsewhere in the manual. On Off On Off The On and Off functions are used to change the values of the variables associated with switches. Some switches contain an s-expression on their 1 property lists under the indicator 'SIMPFG . The s-expression has the form Cond Cond of a Cond list: ((T (action-for-ON)) (NIL (action-for-OFF))) On Off On Off If the 'SIMPFG indicator is present, then the On and Off functions also evaluate the appropriate action in the s-expression. On On _ __ ____ _____ (On [U:id]): None macro _ For each U, the associated !*U variable is set to T. If a "(T GET GET _ (action-for-ON))" clause is found by (GET U 'SIMPFG), the "action" is EVAL'ed. Off Off _ __ ____ _____ (Off [U:id]): None macro _ For each U, the associated !*U variable is set to NIL. If a GET GET _ "(NIL (action-for-OFF)" clause is found by (GET U 'SIMPFG), the "action" is EVAL'ed. (On Comp Ord Usermode) will set !*Comp, !*Ord, and !*Usermode to T. Note that _______________ 1 The name SIMPFG comes from its introduction in the REDUCE algebra system, where it was used as a "simp flag" to specify various simplifications to be performed as various switches were turned on or off. PSL Manual 7 February 1983 Identifiers section 6.7 page 6.15 (Get 'Cref 'Simpfg) returns ((T (Crefon)) (Nil (Crefoff))) ____ ____ Setting CREF on will result in !*CREF being set to T and the function Crefon Crefon Crefon being evaluated. 6.7.3. Special Global Variables 6.7.3. Special Global Variables 6.7.3. Special Global Variables __________ ______ NIL [Initially: NIL] global NIL is a special GLOBAL variable. It is protected from being Set SetQ Set SetQ modified by Set or SetQ. __________ ______ T [Initially: T] global T is a special GLOBAL variable. It is protected from being Set SetQ Set SetQ modified by Set or SetQ. 6.7.4. Special Put Indicators 6.7.4. Special Put Indicators 6.7.4. Special Put Indicators __ Some actions search the property list of relevant ids for these indicators: __ 'HELPFUNCTION An id, a function to be executed to give help about the topic; ideally for a complex topic, a clever function is used. 'HELPSTRING A help string, kept in core for important or short topics. 'HELPFILE The most common case, the name of a file to print; later we hope to load this file into an EMODE buffer for perusal in a window. 'SWITCHINFO A string describing the purpose of the SWITCH, see ShowSwitches ShowSwitches ShowSwitches below. 'GLOBALINFO A string describing the purpose of the GLOBAL, see ShowGlobals ShowGlobals ShowGlobals below. __ 'BREAKFUNCTION Associates a function to be run with an Id typed at Break Loop, see Chapter 14. 'TYPE PSL uses the property TYPE to indicate whether a function is a FEXPR, MACRO, or NEXPR; if no property is present, EXPR is Identifiers 7 February 1983 PSL Manual page 6.16 section 6.7 assumed. 'VARTYPE PSL uses the property VARTYPE to indicate whether an __________ identifier is of type GLOBAL or FLUID. '!*LAMBDALINK The interpreter also looks under '!*LAMBDALINK for a Lambda expression, if a procedure is not compiled. 6.7.5. Special Flag Indicators 6.7.5. Special Flag Indicators 6.7.5. Special Flag Indicators __ 'EVAL If the id is flagged EVAL, the RLISP top-loop evaluates and On Defn __ On Defn outputs any expression (id ...) in On Defn (!*DEFN := T) mode. __ 'IGNORE If the id is flagged IGNORE, the RLISP top-loop evaluates but On Defn __ On Defn does NOT output any expression (id ...) in On Defn (!*DEFN := T) mode. PutD __ PutD 'LOSE If an id has the 'LOSE flag, it will not be defined by PutD when it is read in. 'USER 'USER is put on all functions defined when in !*USERMODE, to distinguish them from "system" functions. See Chapter 10. LoadTime CompileTime LoadTime CompileTime See also the functions LoadTime and CompileTime in Chapter 18. [??? Mention Parser properties ???] [??? Mention Parser properties ???] [??? Mention Parser properties ???] 6.7.6. Displaying Information About Globals 6.7.6. Displaying Information About Globals 6.7.6. Displaying Information About Globals Help Help The Help function has two options, (HELP SWITCHES) and (HELP GLOBALS), which should display the current state of a variety of switches and globals respectively. These calls have the same effect as using the functions below, using an initial table of Switches and Globals. ShowSwitches ShowSwitches The function (ShowSwitches switch-list) may be used to print names, current settings and purpose of some switches. Use NIL as the switch-list ShowSwitches ShowSwitches to get information on ALL switches of interest; ShowSwitches in this case MapObl MapObl does a MapObl (Section 6.3.1) looking for 'SwitchInfo property. ShowGlobals ShowGlobals Similarly, (ShowGlobals global-list) may be used to print names, values and purposes of important GLOBALs. Again, NIL used as the global-list ShowGlobals MapObl ShowGlobals MapObl causes ShowGlobals to do a MapObl looking for a 'GlobalInfo property; the result is some information about all globals of interest. |
Added psl-1983/3-1/lpt/07-lists.lpt version [4db5c0a124].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 List Structure section 7.0 page 7.1 CHAPTER 7 CHAPTER 7 CHAPTER 7 LIST STRUCTURE LIST STRUCTURE LIST STRUCTURE 7.1. Introduction to Lists and Pairs . . . . . . . . . 7.1 7.2. Basic Functions on Pairs . . . . . . . . . . . 7.2 7.3. Functions for Manipulating Lists. . . . . . . . . 7.4 7.3.1. Selecting List Elements . . . . . . . . . 7.4 7.3.2. Membership and Length of Lists . . . . . . . 7.6 7.3.3. Constructing, Appending, and Concatenating Lists . 7.6 7.3.4. Lists as Sets. . . . . . . . . . . . . 7.7 7.3.5. Deleting Elements of Lists . . . . . . . . 7.8 7.3.6. List Reversal. . . . . . . . . . . . . 7.9 7.4. Functions for Building and Searching A-Lists. . . . . 7.10 7.5. Substitutions . . . . . . . . . . . . . . . 7.11 7.1. Introduction to Lists and Pairs 7.1. Introduction to Lists and Pairs 7.1. Introduction to Lists and Pairs ____ The pair is a fundamental PSL data type, and is one of the major ____ ____ attractions of LISP programming. A pair consists of a two-item structure. Car Cdr Car Cdr In PSL the first element is called the Car and the second the Cdr; in other LISPs, the physical relationship of the parts may be different. An Car Car illustration of the tree structure is given below as a box diagram; the Car Cdr Cdr and the Cdr are each represented as a portion of the box. ----------------- || Car | Cdr || ----------------- As an example, a tree written as ((A . B) . (C . D)) in dot-notation is drawn below as a box diagram. ----------------- || / | \ || ----/-------\---- / \ ----------------- ----------------- || A | B || || C | D || ----------------- ----------------- The box diagrams are tedious to draw, so dot-notation is normally used. ____ Note that a space is left on each side of the . to ensure that pairs are _____ not confused with floats. Note also that in RLISP a dot may be used as the List Structure 7 February 1983 PSL Manual page 7.2 section 7.1 Cons Cons infix operator for the function Cons, as in the expression x := 'y . 'z;, ____ or as part of the notation for pairs, as in the expression x := '(y . z); (see Section 3.3.3). An important special case occurs frequently enough that it has a special ____ notation. This is a list of items, terminated by convention with the id NIL. The dot and surrounding parentheses are omitted, as well as the trailing NIL. Thus (A . (B . (C . NIL))) can be represented in list-notation as (A B C) 7.2. Basic Functions on Pairs 7.2. Basic Functions on Pairs 7.2. Basic Functions on Pairs ____ The following are elementary functions on pairs. All functions in this Chapter which require pairs as parameters signal a type mismatch error if the parameter given is not a pair. Cons Cons _ ___ _ ___ ____ ____ (Cons U:any V:any): pair expr Eq ____ Eq _ Returns a pair which is not Eq to anything else and has U as its Car Cdr Car _ Cdr Car part and V as its Cdr part. In RLISP syntax the dot, ".", is Cons Cons an infix operator meaning Cons. Thus (A . (B . fn C) . D) is Cons Cons Cons Cons Cons Cons equivalent to Cons (A, Cons (Cons (B, fn C), D)). See Section 3.3.3 for more discussion of how dot is read. Car Car _ ____ ___ ____ ________ ____ (Car U:pair): any open-compiled, expr _ The left part of U is returned. A type mismatch error occurs if _ ____ _ U is not a pair, except when U is NIL. Then NIL is returned. Car Cons Car Cons (Car (Cons a b)) ==> a. Cdr Cdr _ ____ ___ ____ ________ ____ (Cdr U:pair): any open-compiled, expr _ The right part of U is returned. A type mismatch error occurs if _ ____ _ U is not a pair, except when U is NIL. Then NIL is returned. Cdr Cons Cdr Cons (Cdr (Cons a b)) ==> b. Car Cdr Car Cdr The composites of Car and Cdr are supported up to four levels. PSL Manual 7 February 1983 List Structure section 7.2 page 7.3 Car Cdr Car Cdr Car Cdr Caar Cdar Cadr Cddr Caar Cdar Cadr Cddr Caar Cdar Cadr Cddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr ____ ____ ____ expr expr These are all exprs of one argument. They may return any type and are generally open-compiled. An example of their use is that Cddar Cdr Cdr Car Car Cdr Cddar Cdr Cdr Car Car Cdr Cddar p is equivalent to Cdr Cdr Car p. As with Car and Cdr, a type mismatch error occurs if the argument does not possess the specified component. As an alternative to employing chains of CxxxxR to obscure depths, ____ particularly in extracting elements of a list, consider the use of the First Second Third Fourth Nth First Second Third Fourth Nth functions First, Second, Third, Fourth, or Nth (Section 7.3.1), or possibly even the Defstruct package (Section 17.6). NCons NCons _ ___ ____ ____ ________ ____ (NCons U:any): pair open-compiled, expr Cons Cons _ Equivalent to Cons (U, NIL). XCons XCons _ ___ _ ___ ____ ____ ________ ____ (XCons U:any V:any): pair open-compiled, expr Cons Cons _ _ Equivalent to Cons (V, U). Copy Copy _ ___ ___ ____ (Copy X:any): any expr ____ _ Copies all pairs in X, but does not make copies of atoms (including vectors and strings). For example, if A is ([2 5] "ATOM") and B is the result of (Copy A), then (Eq A B) is NIL but (Eq (Car A) (Car B)) is T and (Eq (Cadr A) (Cadr B)) is T TotalCopy Copy TotalCopy Copy See TotalCopy in Section 8.5. Note that Copy is recursive and will not terminate if its argument is a circular list. See Chapter 8 for other relevant functions. The following functions are known as "destructive" functions, because they change the structure of the pair given as their argument, and consequently change the structure of the object containing the pair. They are most frequently used for various "efficient" functions (e.g. the List Structure 7 February 1983 PSL Manual page 7.4 section 7.2 ReverseIP NConc DeleteIP ReverseIP NConc DeleteIP non-copying ReverseIP and NConc functions, and destructive DeleteIP) and to build structures that have deliberately shared sub-structure. They are also capable of creating circular structures, which create havoc with careful careful normal printing and list traversal functions. Be careful using them. RplacA RplacA _ ____ _ ___ ____ ____ ________ ____ (RplacA U:pair V:any): pair open-compiled, expr Car Car _ _ _ The Car of the pair U is replaced by V, and the modified U is _ _ returned. (If U is (a . b) then (V .b) is returned). A type _ mismatch error occurs if U is not a pair. RplacD RplacD _ ____ _ ___ ____ ____ ________ ____ (RplacD U:pair V:any): pair open-compiled, expr Cdr Cdr _ _ _ The Cdr of the pair U is replaced by V, and the modified U is _ _ returned. (If U is (a . b) then (a . V) is returned). A type _ mismatch error occurs if U is not a pair. RplacW RplacW _ ____ _ ____ ____ ____ (RplacW A:pair B:pair): pair expr Car Car Car _ Car Replaces the whole pair: the Car of A is replaced with the Car Cdr Cdr _ Cdr _ Cdr _ _ of B, and the Cdr of A with the Cdr of B. The modified A is returned. [??? Should we add some more functions here someday? Probably the [??? Should we add some more functions here someday? Probably the [??? Should we add some more functions here someday? Probably the RLISP guys that do arbitrary depth member type stuff. ???] RLISP guys that do arbitrary depth member type stuff. ???] RLISP guys that do arbitrary depth member type stuff. ???] 7.3. Functions for Manipulating Lists 7.3. Functions for Manipulating Lists 7.3. Functions for Manipulating Lists ____ ____ The following functions are meant for the special pairs which are lists, as described in Section 7.1. Note that the functions described in Chapter 8 can also be used on lists. [??? Make some mention of mapping with FOR...COLLECT and such like. [??? Make some mention of mapping with FOR...COLLECT and such like. [??? Make some mention of mapping with FOR...COLLECT and such like. ???] ???] ???] 7.3.1. Selecting List Elements 7.3.1. Selecting List Elements 7.3.1. Selecting List Elements First First _ ____ ___ _____ (First L:pair): any macro Car Car _ A synonym for Car L. PSL Manual 7 February 1983 List Structure section 7.3 page 7.5 Second Second _ ____ ___ _____ (Second L:pair): any macro Cadr Cadr _ A synonym for Cadr L. Third Third _ ____ ___ _____ (Third L:pair): any macro Caddr Caddr _ A synonym for Caddr L. Fourth Fourth _ ____ ___ _____ (Fourth L:pair): any macro Cadddr Cadddr _ A synonym for Cadddr L. Rest Rest _ ____ ___ _____ (Rest L:pair): any macro Cdr Cdr _ A synonym for Cdr L. LastPair LastPair _ ____ ___ ____ (LastPair L:pair): any expr ____ ____ Last pair of a list. It is often useful to think of this as a pointer to the last element for use with destructive functions RplacA RplacA _ such as RplacA. Note that if L is atomic a type mismatch error occurs. (De LastPair (L) (Cond ((Null (Rest L)) L) (T (LastPair (Rest L))))) LastCar LastCar _ ___ ___ ____ (LastCar L:any): any expr ____ _ Returns the last element of the list L. A type mismatch error First LastPair _ First LastPair _ results if L is not a list. Equivalent to First LastPair L. Nth Nth _ ____ _ _______ ___ ____ (Nth L:pair N:integer): any expr ____ _ _ Returns the Nth element of the list L. If L is atomic or _ contains fewer than N elements, an out of range error occurs. First PNth First PNth Equivalent to (First (PNth L N)). PNth PNth _ ____ _ _______ ___ ____ (PNth L:list N:integer): any expr ____ ____ _ Returns list starting with the Nth element of a list L. Note that it is often useful to view this as a pointer to the Nth RplacA _ RplacA element of L for use with destructive functions such as RplacA. _ _ If L is atomic or contains fewer than N elements, an out of range error occurs. List Structure 7 February 1983 PSL Manual page 7.6 section 7.3 (De PNth (L N) (Cond ((Leq N 1) L) (T (PNth (Cdr L) (Sub1 N))))) 7.3.2. Membership and Length of Lists 7.3.2. Membership and Length of Lists 7.3.2. Membership and Length of Lists Member Member _ ___ _ ____ _____ _______ ____ (Member A:any L:list): extra-boolean expr Equal _ Equal ____ Returns NIL if A is not Equal to some top level element of list _ _ L; otherwise it returns the remainder of L whose first element is _ A. (De Member (A L) (Cond((Null L) Nil) ((Equal A (First L)) L) (T (Member A (Rest L))))) MemQ MemQ _ ___ _ ____ _____ _______ ____ (MemQ A:any B:list): extra-boolean expr Member Eq Member Eq Same as Member, but an Eq check is used for comparison. (De Memq (A L) (Cond((Null L) Nil) ((Eq A (First L)) L) (T (Memq A (Rest L))))) Length Length _ ___ _______ ____ (Length X:any): integer expr ____ _ The top level length of the list X is returned. (De Length (X) (Cond((Atom X) 0) (T (Plus (Length X) 1)))) 7.3.3. Constructing, Appending, and Concatenating Lists 7.3.3. Constructing, Appending, and Concatenating Lists 7.3.3. Constructing, Appending, and Concatenating Lists List List _ ___ ____ _____ (List [U:any]): list fexpr ____ ____ Construct a list of the evaluated arguments. A list of the _ evaluation of each element of U is returned. Append Append _ ____ _ ____ ____ ____ (Append U:list V:list): list expr ____ _ Returns a constructed list in which the last element of U is _ ____ _ _ followed by the first element of V. The list U is copied, but V PSL Manual 7 February 1983 List Structure section 7.3 page 7.7 is not. (De Append (U V) (Cond ((Null U) V) (T (Cons (Car U) (Append (Cdr U) V))))) NConc NConc _ ____ _ ____ ____ ____ (NConc U:list V:list): list expr Append Append _ _ Destructive version of Append. Concatenates V to U without Cdr _ Cdr _ _ copying U. The last Cdr of U is modified to point to V. See the warning on page 7.3 about the use of destructive functions. (De Nconc (U V) (Cond ((Null U) V) (T (Rplacd (Lastcdr U V))))) AConc AConc _ ____ _ ___ ____ ____ (AConc U:list V:any): list expr _ ____ _ Destructively adds element V to the tail of list U. LConc LConc ___ ____ ____ ____ ____ ____ (LConc PTR:list ELEM:list): list expr NConc NConc Effectively NConc, but avoids scanning from the front to the end RPLACD ___ RPLACD ___ ____ of PTR for the RPLACD(PTR, ELEM) by maintaining a pointer to end LastPair ____ ___ ___ ____ LastPair ____ of the list PTR. PTR is (list . LastPair list). Returns updated ___ ___ PTR. PTR should be initialized to NIL . NIL before calling the ____ first time. Used to build lists from left to right. TConc TConc ___ ____ ____ ___ ____ ____ (TConc PTR:list ELEM:any): list expr AConc AConc Effectively AConc, but avoids scanning from the front to the end RPLACD List ___ RPLACD ___ List ____ of PTR for the RPLACD(PTR, List(ELEM)) by maintaining a pointer LastPair ____ ___ ___ ____ LastPair ____ to end of the list PTR. PTR is (list . LastPair list). Returns ___ ___ updated PTR. PTR should be initialized to NIL . NIL before ____ calling the first time. Used to build lists from left to right. 7.3.4. Lists as Sets 7.3.4. Lists as Sets 7.3.4. Lists as Sets ____ A set is a list in which each element occurs only once. Order of elements does not matter, so these functions may not preserve order. Adjoin Adjoin _______ ___ ___ ____ ____ ____ (Adjoin ELEMENT:any SET:list): list expr Equal _______ ___ Equal Add ELEMENT to SET if it is not already on the top level. Equal is used to test for equality. List Structure 7 February 1983 PSL Manual page 7.8 section 7.3 AdjoinQ AdjoinQ _______ ___ ___ ____ ____ ____ (AdjoinQ ELEMENT:any SET:list): list expr Adjoin Eq Adjoin Eq _______ ___ Adjoin using Eq for the test whether ELEMENT is already in SET. Union Union _ ____ _ ____ ____ ____ (Union X:list Y:list): list expr Set union. UnionQ UnionQ _ ____ _ ____ ____ ____ (UnionQ X:list Y:list): list expr Eq Union Eq Union Eq version of Union. InterSection InterSection _ ____ _ ____ ____ ____ (InterSection U:list V:list): list expr Set intersection. InterSectionQ InterSectionQ _ ____ _ ____ ____ ____ (InterSectionQ U:list V:list): list expr Eq InterSection Eq InterSection Eq version of InterSection. List2Set List2Set ___ ____ ____ ____ (List2Set SET:list): list expr Equal ___ Equal Remove redundant elements from the top level of SET using Equal. List2SetQ List2SetQ ___ ____ ____ ____ (List2SetQ SET:list): list expr Eq ___ Eq Remove redundant elements from the top level of SET using Eq. 7.3.5. Deleting Elements of Lists 7.3.5. Deleting Elements of Lists 7.3.5. Deleting Elements of Lists xxxIP xxx xxxIP xxx Note that functions with names of the form xxxIP indicate that xxx is done InPlace. Delete Delete _ ___ _ ____ ____ ____ (Delete U:any V:list): list expr _ _ Returns V with the first top level occurrence of U removed from _ _ it. That portion of V before the first occurrence of U is copied. (De Delete (U V) (Cond((Null V) Nil) ((Equal (First V) U) (Rest V)) (T (Cons (First V) (Delete U (Rest V)))))) PSL Manual 7 February 1983 List Structure section 7.3 page 7.9 Del Del _ ________ _ ___ _ ____ ____ ____ (Del F:function U:any V:list): list expr Delete Delete _ Generalized Delete function with F as the comparison function. DeletIP DeletIP _ ___ _ ____ ____ ____ (DeletIP U:any V:list): list expr Delete RplacD Delete _ RplacD _ Destructive Delete; modifies V using RplacD. Do not depend on V ____ itself correctly referring to list. DelQ DelQ _ ___ _ ____ ____ ____ (DelQ U:any V:list): list expr Eq _ _ Eq Delete U from V, using Eq for comparison. DelQIP DelQIP _ ___ _ ____ ____ ____ (DelQIP U:any V:list): list expr DelQ DeletIP DelQ DeletIP Destructive version of DelQ; see DeletIP. DelAsc DelAsc _ ___ _ _ ____ _ ____ ____ (DelAsc U:any V:a-list): a-list expr _ _ Remove first (U . xxx) from V. DelAscIP DelAscIP _ ___ _ _ ____ _ ____ ____ (DelAscIP U:any V:a-list): a-list expr DelAsc DelAsc Destructive DelAsc. DelatQ DelatQ _ ___ _ _ ____ _ ____ ____ (DelatQ U:any V:a-list): a-list expr Eq _ _ Eq _ Delete first (U . xxx) from V, using Eq to check equality with U. DelatQIP DelatQIP _ ___ _ _ ____ _ ____ ____ (DelatQIP U:any V:a-list): a-list expr DelatQ DelatQ Destructive DelatQ. 7.3.6. List Reversal 7.3.6. List Reversal 7.3.6. List Reversal Reverse Reverse _ ____ ____ ____ (Reverse U:list): list expr _ Returns a copy of the top level of U in reverse order. List Structure 7 February 1983 PSL Manual page 7.10 section 7.3 (De Reverse (U) (Prog (W) (While U (ProgN (Setq W (Cons (Car U) W)) (Setq U (Cdr U)))) (Return W))) ReversIP ReversIP _ ____ ____ ____ (ReversIP U:list): list expr Reverse Reverse Destructive Reverse. 7.4. Functions for Building and Searching A-Lists 7.4. Functions for Building and Searching A-Lists 7.4. Functions for Building and Searching A-Lists Assoc Assoc _ ___ _ _ ____ ____ ___ ____ (Assoc U:any V:a-list): {pair, NIL} expr Car _ Car _ ____ _ If U occurs as the Car portion of an element of the a-list V, the ____ _ pair in which U occurred is returned, else NIL is returned. Assoc Assoc _ ____ Assoc might not detect a poorly formed a-list so an invalid Car Cdr Car Cdr construction may be detected by Car or Cdr. (De Assoc (U V) (Cond ((Null V) Nil) ((Atom (Car V)) (Error 000 (List V "is a poorly formed alis ((Equal U (Caar V)) (Car V)) (T (Assoc U (Cdr V))))) Atsoc Atsoc __ ___ __ ___ ___ ____ (Atsoc R1:any R2:any): any expr Car Eq Eq Assoc __ ____ Car Eq __ Eq Assoc Scan R2 for pair with Car Eq R1. Eq version of Assoc. Ass Ass _ ________ _ ___ _ _ ____ ____ ___ ____ (Ass F:function U:any V:a-list): {pair, NIL} expr Ass Assoc Ass Assoc _ Ass is a generalized Assoc function. F is the comparison function. SAssoc SAssoc _ ___ _ _ ____ __ ________ ___ ____ (SAssoc U:any V:a-list FN:function): any expr _ ____ _ _ _ Searches the a-list V for an occurrence of U. If U is not in the _ ____ __ a-list, the evaluation of function FN is returned. PSL Manual 7 February 1983 List Structure section 7.4 page 7.11 (De SAssoc (U V FN) (Cond ((Null V) (FN)) ((Equal U (Caar V)) (Car V)) (T (SAssoc U (Cdr V) FN)))) Pair Pair _ ____ _ ____ _ ____ ____ (Pair U:list V:list): a-list expr _ _ ____ U and V are lists which must have an identical number of ____ elements. If not, an error occurs. Returned is a list in which Car ____ Car ____ _ each element is a pair, the Car of the pair being from U and the Cdr Cdr _ Cdr being the corresponding element from V. (De Pair (U V) (Cond ((And U V)(Cons (Cons (Car U)(Car V)) (Pair (Cdr U)(Cdr V)))) ((Or U V)(Error 000 "Different length lists i (T Nil))) 7.5. Substitutions 7.5. Substitutions 7.5. Substitutions Subst Subst _ ___ _ ___ _ ___ ___ ____ (Subst U:any V:any W:any): any expr _ _ Returns the result of substituting U for all occurrences of V in _ _ _ W. Copies all of W which is not replaced by U. The test used is Equal Equal Equal. (De Subst (U V W) (Cond ((Null W) Nil) ((Equal V W) U) ((Atom W) W) (T (Cons (Subst U V (Car W))(Subst U V (Cdr SubstIP SubstIP _ ___ _ ___ _ ___ ___ ____ (SubstIP U:any V:any W:any): any expr Subst Subst Destructive Subst. SubLis SubLis _ _ ____ _ ___ ___ ____ (SubLis X:a-list Y:any): any expr Subst Subst This performs a series of Substs in parallel. The value returned Cdr Cdr is the result of substituting the Cdr of each element of the Car _ ____ _ Car a-list X for every occurrence of the Car part of that element in _ Y. List Structure 7 February 1983 PSL Manual page 7.12 section 7.5 (De SubLis (X Y) (Cond ((Null X) Y) (T (Prog (U) (Setq U (Assoc Y X)) (Return (Cond (U (Cdr U)) ((Atom Y) Y) (T (Cons (SubLis X (Car Y)) (SubLis X (Cdr Y)) SublA SublA _ _ ____ _ ___ ___ ____ (SublA U:a-list V:any): any expr Eq SubLis Eq SubLis Eq version of SubLis; replaces atoms only. |
Added psl-1983/3-1/lpt/08-strings.lpt version [2e547e9c39].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Strings and Vectors section 8.0 page 8.1 CHAPTER 8 CHAPTER 8 CHAPTER 8 STRINGS AND VECTORS STRINGS AND VECTORS STRINGS AND VECTORS 8.1. Vector-Like Objects . . . . . . . . . . . . . 8.1 8.2. Strings . . . . . . . . . . . . . . . . . 8.1 8.3. Vectors . . . . . . . . . . . . . . . . . 8.3 8.4. Word Vectors . . . . . . . . . . . . . . . 8.5 8.5. General X-Vector Operations . . . . . . . . . . 8.5 8.6. Arrays . . . . . . . . . . . . . . . . . 8.7 8.7. Common LISP String Functions . . . . . . . . . . 8.7 8.1. Vector-Like Objects 8.1. Vector-Like Objects 8.1. Vector-Like Objects ______ ______ ____ ______ ________ ______ In this Chapter, LISP strings, vectors, word-vectors, halfword-vectors, ____ ______ and byte-vectors are described. Each may have several elements, accessed _______ by an integer index. For convenience, members of this set are referred to _ ______ _ ______ ____ as x-vectors. X-vector functions also apply to lists. Currently, the Size UpB _ ______ Size UpB index for x-vectors ranges from 0 to an upper limit, called the Size or UpB Size _ ______ Size ______ (upper bound). Thus an x-vector X has 1 + Size(X) elements. Strings index ______ from 0 because they are considered to be packed vectors of bytes. Bytes are 7 bits on the DEC-20 and 8 bits on the VAX. ______ ____ ______ ____ ______ ____ [??? Note that with new integer tagging, strings are "packed" words, [??? Note that with new integer tagging, strings are "packed" words, [??? Note that with new integer tagging, strings are "packed" words, ______ ______ ______ which are special cases of vectors. Should we add byte-vectors too, so which are special cases of vectors. Should we add byte-vectors too, so which are special cases of vectors. Should we add byte-vectors too, so ______ ______ ______ that strings are different print mode of byte vector ???] that strings are different print mode of byte vector ???] that strings are different print mode of byte vector ???] [??? Size should probably be replaced by UPLIM or UPB. ???] [??? Size should probably be replaced by UPLIM or UPB. ???] [??? Size should probably be replaced by UPLIM or UPB. ???] In RLISP syntax, X[i]; may be used to access the i'th element of an _ ______ x-vector, and X[i]:=y; is used to change the i'th element to y. These Indx SetIndx Indx SetIndx functions correspond to the LISP functions Indx and SetIndx. [??? Change names to GetIndex, PutIndex ???] [??? Change names to GetIndex, PutIndex ???] [??? Change names to GetIndex, PutIndex ???] For functions which change an object from one data type to another, see Section 4.3. 8.2. Strings 8.2. Strings 8.2. Strings ______ ______ A string is currently thought of as a Byte vector, or a packed integer ______ ______ vector, with elements that are ASCII characters. A string has a header containing its length and perhaps a tag. The next M words contain the 0 ... Size characters, packed as appropriate, terminated with at least 1 ______ ______ NULL. On the DEC-20, this means that strings have an ASCIZ string starting Strings and Vectors 7 February 1983 PSL Manual page 8.2 section 8.2 in the second word. (ASCIZ strings are NULL terminated.) Make!-String Make!-String ____ _______ _______ _______ ______ ____ (Make!-String SIZE:integer INITVAL:integer): string expr ______ ____ Constructs and returns a string with SIZE characters, each _______ initialized to the ASCII code INITVAL. MkString MkString _____ _______ _______ _______ ______ ____ (MkString UPLIM:integer INITVAL:integer): string expr Make!-String Make!-String An old form of Make!-String. Returns a string of characters all _______ _____ initialized to INITVAL, with upper bound UPLIM. So, the returned _____ _ string contains a total of UPLIM + 1 characters. String String ____ _______ ______ _____ (String [ARGS:integer]): string nexpr ______ ____ Create string of elements from a list of ARGS. [??? Should we check each arg in 0 ... 127. What about 128 [??? Should we check each arg in 0 ... 127. What about 128 [??? Should we check each arg in 0 ... 127. What about 128 - 255 with 8 bit vectors? ???] - 255 with 8 bit vectors? ???] - 255 with 8 bit vectors? ???] (String 65 66 67) returns "ABC" CopyStringToFrom CopyStringToFrom ___ ______ ___ ______ ___ ______ ____ (CopyStringToFrom NEW:string OLD:string): NEW:string expr ___ ___ Copy all characters from OLD into NEW. This function is destructive. CopyString CopyString _ ______ ______ ____ (CopyString S:string): string expr ______ Copy to new heap string, allocating space. [??? Should we add GetS, PutS, UpbS, etc ???] [??? Should we add GetS, PutS, UpbS, etc ???] [??? Should we add GetS, PutS, UpbS, etc ???] When processing strings it is frequently necessary to be able to specify a particular character. In PSL a character is just its ASCII code representation, but it is difficult to remember the code, and the use of Char Char codes does not add to the readability of programs. One can use the Char __ macro, defined in Chapter 20. It expects a single character id as argument and returns the ASCII code of that character. For example (Char A) returns 65 (Char !a) returns 97 (Char !@) returns 64 PSL Manual 7 February 1983 Strings and Vectors section 8.2 page 8.3 Note that to get lower-case a one must precede the a by "!", otherwise the a will be raised. See also the sharp-sign macros in Chapter 17. 8.3. Vectors 8.3. Vectors 8.3. Vectors ______ ____ A vector is a structured entity in which random item elements may be _______ ______ accessed with an integer index. A vector has a single dimension. Its maximum size is determined by the implementation and available space. A ______ suggested input/output "vector notation" is defined (see Chapter 12). GetV GetV _ ______ _____ _______ ___ ____ (GetV V:vector INDEX:integer): any expr _____ ______ _ Returns the value stored at position INDEX of the vector V. The _____ type mismatch error may occur. An error occurs if the INDEX does UPBV UPBV _ not lie within 0 ... (UPBV V) inclusive: ***** INDEX subscript is out of range _ _____ A similar effect may be obtained in RLISP by using V[INDEX];. MkVect MkVect _____ _______ ______ ____ (MkVect UPLIM:integer): vector expr ______ _____ Defines and allocates space for a vector with UPLIM + 1 elements _____ accessed as 0 ... UPLIM. Each element is initialized to NIL. If _____ UPLIM is -1, an empty vector is returned. An error occurs if _____ ______ UPLIM is < -1 or if there is not enough space for a vector of this size: ***** A vector of size UPLIM cannot be allocated Make!-Vector Make!-Vector _____ _______ _______ ___ ______ ____ (Make!-Vector UPLIM:integer INITVAL:any): vector expr MkVect MkVect _______ Like MkVect but each element is initialized to INITVAL. PutV PutV _ ______ _____ _______ _____ ___ ___ ____ (PutV V:vector INDEX:integer VALUE:any): any expr _____ ______ _ _____ _____ Stores VALUE in the vector V at position INDEX. VALUE is _____ returned. The type mismatch error may occur. If INDEX does not UPBV UPBV _ lie in 0 ... UPBV(V), an error occurs: ***** INDEX subscript is out of range A similar effect can be obtained in RLISP by typing in _ _____ _____ V[INDEX]:=VALUE;. It is important to use square brackets, i.e. "[]". Strings and Vectors 7 February 1983 PSL Manual page 8.4 section 8.3 UpbV UpbV _ ___ ___ _______ ____ (UpbV U:any): {NIL, integer} expr _ _ ______ Returns the upper limit of U if U is a vector, or NIL if it is not. Vector Vector ____ ___ ______ _____ (Vector [ARGS:any]): vector nexpr ______ ____ ____ ______ Create vector of elements from list of ARGS. The vector has N Size Size ____ elements, i.e. Size = N - 1, in which N is the number of ARGS. CopyVectorToFrom CopyVectorToFrom ___ ______ ___ ______ ___ ______ ____ (CopyVectorToFrom NEW:vector OLD:vector): NEW:vector expr Move elements, don't recurse. [ ???Check size compatibility? ] [ ???Check size compatibility? ] [ ???Check size compatibility? ] CopyVector CopyVector _ ______ ______ ____ (CopyVector V:vector): vector expr ______ Copy to new vector in heap. The following functions can be used after the FAST!-VECTOR module has been loaded (LOAD FAST!-VECTOR). IGetV IGetV _ ______ _____ _______ ___ ____ ________ ____ (IGetV V:vector INDEX:integer): any open-compiled, expr GetV GetV Used the same way as GetV. IPutV IPutV _ ______ _____ _______ _____ ___ ___ ____ ________ ____ (IPutV V:vector INDEX:integer VALUE:any): any open-compiled, expr PutV PutV Fast version of PutV. ISizeV ISizeV _ ___ ___ _______ ____ ________ ____ (ISizeV U:any): {NIL,integer} open-compiled, expr UpbV UpbV Fast version of UpbV. ISizeS ISizeS _ _ ______ _______ ____ ________ ____ (ISizeS X:x-vector): integer open-compiled, expr Size Size Fast version of Size. IGetS IGetS _ _ ______ _ _______ ___ ____ ________ ____ (IGetS X:x-vector I:integer): any open-compiled, expr Indx Indx Fast version of Indx. PSL Manual 7 February 1983 Strings and Vectors section 8.3 page 8.5 IPutS IPutS _ _ ______ _ _______ _ ___ ___ ____ ________ ____ (IPutS X:x-vector I:integer A:any): any open-compiled, expr SetIndx SetIndx Fast version of SetIndx. 8.4. Word Vectors 8.4. Word Vectors 8.4. Word Vectors ____ ______ _ _______ Word-vectors or w-vectors are vector-like structures, in which each element is a "word" sized, untagged entity. This can be thought of as a ______ ______ special case of fixnum vector, in which the tags have been removed. Make!-Words Make!-Words _____ _______ _______ _______ ____ ______ ____ (Make!-Words UPLIM:integer INITVAL:integer): Word-Vector expr ____ ______ _____ Defines and allocates space for a Word-Vector with UPLIM + 1 _______ elements, each initialized to INITVAL. Make!-Halfwords Make!-Halfwords _____ _______ _______ _______ ________ ______ ____ (Make!-Halfwords UPLIM:integer INITVAL:integer): Halfword-Vector expr ________ ______ _____ Defines and allocates space for a Halfword-vector with UPLIM + 1 _______ elements, each initialized to INITVAL. Make!-Bytes Make!-Bytes _____ _______ _______ _______ ____ ______ ____ (Make!-Bytes UPLIM:integer INITVAL:integer): Byte-vector expr ____ ______ _____ Defines and allocates space for a Byte-Vector with UPLIM + 1 _______ elements, each initialized to INITVAL. [??? Should we convert elements to true integers when accessing ???] [??? Should we convert elements to true integers when accessing ???] [??? Should we convert elements to true integers when accessing ???] [??? Should we add GetW, PutW, UpbW, etc ???] [??? Should we add GetW, PutW, UpbW, etc ???] [??? Should we add GetW, PutW, UpbW, etc ???] 8.5. General X-Vector Operations 8.5. General X-Vector Operations 8.5. General X-Vector Operations Size Size _ _ ______ _______ ____ (Size X:x-vector): integer expr _ ______ Size (upper bound) of x-vector. Indx Indx _ _ ______ _ _______ ___ ____ (Indx X:x-vector I:integer): any expr _ ______ Access the I'th element of an x-vector. [??? Rename to GetIndex, or some such ???] [??? Rename to GetIndex, or some such ???] [??? Rename to GetIndex, or some such ???] Size _ Size _ Generates a range error if I is outside the range 0 ... Size(X): Strings and Vectors 7 February 1983 PSL Manual page 8.6 section 8.5 ***** Index is out of range SetIndx SetIndx _ _ ______ _ _______ _ ___ ___ ____ (SetIndx X:x-vector I:integer A:any): any expr _ Store an appropriate value, A, as the I'th element of an _ ______ _ x-vector. Generates a range error if I is outside the range Size Size _ 0...Size(X): ***** Index is out of range Sub Sub _ _ ______ __ _______ _ _______ _ ______ ____ (Sub X:x-vector I1:integer S:integer): x-vector expr _ ______ __ Extract a subrange of an x-vector, starting at I1, producing a Size Size _ ______ Size _ ____ _ ______ Size ___ new x-vector of Size S. Note that an x-vector of Size 0 has one entry. SetSub SetSub _ _ ______ __ _______ _ _______ _ _ ______ _ ______ ____ (SetSub X:x-vector I1:integer S:integer Y:x-vector): x-vector expr _ _ _ __ _ Store subrange of Y of size S into X starting at I1. Returns Y. SubSeq SubSeq _ _ ______ __ _______ __ _______ _ ______ ____ (SubSeq X:x-vector LO:integer HI:integer): x-vector expr Size _ ______ Size __ __ Returns an x-vector of Size HI-LO-1, beginning with the element _ __ _ of X with index LO. In other words, returns the subsequence of X __ ____ ______ __ starting at LO and ending just before HI. For example, (Setq A '[0 1 2 3 4 5 6]) (SubSeq A 4 6) returns [4 5]. SetSubSeq SetSubSeq _ _ ______ __ _______ __ _______ _ _ ______ _ _ ______ ____ (SetSubSeq X:x-vector LO:integer HI:integer Y:x-vector): Y:x-vector expr Size _ Size __ __ Y must be of Size HI-LO-1; it must also be of the same type of _ ______ _ __ __ _ x-vector as X. Elements LO through HI-1 in X are replaced by Size Size _ _ _ _ elements 0 through Size(Y) of Y. Y is returned and X is changed destructively. If A is "0123456" and B is "abcd", then (SetSubSeq A 3 7 B) returns "abcd". A is "012abcd" and B is unchanged. Concat Concat _ _ ______ _ _ ______ _ ______ ____ (Concat X:x-vector Y:x-vector): x-vector expr _ ______ Concatenate 2 x-vectors. Currently they must be of same type. PSL Manual 7 February 1983 Strings and Vectors section 8.5 page 8.7 [??? Should we do conversion to common type ???] [??? Should we do conversion to common type ???] [??? Should we do conversion to common type ???] TotalCopy TotalCopy _ ___ ___ ____ (TotalCopy S:any): any expr Returns a unique copy of entire structure, i.e., it copies everything for which storage is allocated - everything but inums Copy TotalCopy Copy TotalCopy and ids. Like Copy (Chapter 7)TotalCopy will not terminate when applied to circular structures. 8.6. Arrays 8.6. Arrays 8.6. Arrays _____ _____ _____ macro macro Arrays do not exist in PSL as distinct data-types; rather an array macro package is anticipated for declaring and managing multi-dimensional arrays ____ _________ ____ of items, characters and words, by mapping them onto one dimensional vectors. [??? What operations, how to map, and what sort of checking ???] [??? What operations, how to map, and what sort of checking ???] [??? What operations, how to map, and what sort of checking ???] 8.7. Common LISP String Functions 8.7. Common LISP String Functions 8.7. Common LISP String Functions A Common LISP compatible package of string and character functions has been implemented in PSL, obtained by LOADing the STRINGS module. The following functions are defined from Chapters 13 and 14 of the Common LISP Char String Char String manual [Steele 81]. Char and String are not defined because of PSL functions with the same name. Common LISP provides a character data type in which every character object has three attributes: code, bits, and font. The bits attribute allows extra flags to be associated with a character. The font attribute permits a specification of the style of the glyphs (such as italics). PSL does not support nonzero bit and font attributes. Because of this some of the Common LISP character functions described below have no affect or are not very useful as implemented in PSL. They are present for compatibility. Recall that in PSL a character is represented as its code, a number in the range 0...127. For an argument to the following character functions Char Char give the code or use the Char function or the sharp-sign macros in Chapter 17. Standard!-CharP Standard!-CharP _ _________ _______ ____ (Standard!-CharP C:character): boolean expr Returns T if the argument is a "standard character", that is, one of the ninety-five ASCII printing characters or <return>. Strings and Vectors 7 February 1983 PSL Manual page 8.8 section 8.7 (Standard-CharP (Char A)) returns T (Standard-CharP (Char !^A)) returns NIL GraphicP GraphicP _ _________ _______ ____ (GraphicP C:character): boolean expr _ Returns T if C is a printable character and NIL if it is a non-printable (formatting or control) character. The space character is assumed to be graphic. String!-CharP String!-CharP _ _________ _______ ____ (String!-CharP C:character): boolean expr _ Returns T if C is a character that can be an element of a string. Standard-Charp Graphicp Standard-Charp Graphicp Any character that satisfies Standard-Charp and Graphicp also String-Charp String-Charp satisfies String-Charp. AlphaP AlphaP _ _________ _______ ____ (AlphaP C:character): boolean expr _ Returns T if C is an alphabetic character. UpperCaseP UpperCaseP _ _________ _______ ____ (UpperCaseP C:character): boolean expr _ Returns T if C is an upper case letter. LowerCaseP LowerCaseP _ _________ _______ ____ (LowerCaseP C:character): boolean expr _ Returns T if C is a lower case letter. BothCaseP BothCaseP _ _________ _______ ____ (BothCaseP C:character): boolean expr AlphaP AlphaP In PSL this function is the same as AlphaP. DigitP DigitP _ _________ _______ ____ (DigitP C:character): boolean expr _ Returns T if C is a digit character (optional radix not supported). AlphaNumericP AlphaNumericP _ _________ _______ ____ (AlphaNumericP C:character): boolean expr _ Returns T if C is a digit or an alphabetic. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.9 Char!= Char!= __ _________ __ _________ _______ ____ (Char!= C1:character C2:character): boolean expr __ __ Returns T if C1 and C2 are the same in all three attributes. Char!-Equal Char!-Equal __ _________ __ _________ _______ ____ (Char!-Equal C1:character C2:character): boolean expr __ __ Returns T if C1 and C2 are similar. Differences in case, bits, or font are ignored by this function. Char!< Char!< __ _________ __ _________ _______ ____ (Char!< C1:character C2:character): boolean expr __ __ Returns T if C1 is strictly less than C2. Char!> Char!> __ _________ __ _________ _______ ____ (Char!> C1:character C2:character): boolean expr __ __ Returns T if C1 is strictly greater than C2. Char!-LessP Char!-LessP __ _________ __ _________ _______ ____ (Char!-LessP C1:character C2:character): boolean expr Char!< Char!< Like Char!< but ignores differences in case, fonts, and bits. Char!-GreaterP Char!-GreaterP __ _________ __ _________ _______ ____ (Char!-GreaterP C1:character C2:character): boolean expr Char!> Char!> Like Char!> but ignores differences in case, fonts, and bits. Char!-Code Char!-Code _ _________ _________ ____ (Char!-Code C:character): character expr _ Returns the code attribute of C. In PSL this function is an identity function. Char!-Bits Char!-Bits _ _________ _______ ____ (Char!-Bits C:character): integer expr _ Returns the bits attribute of C, which is always 0 in PSL. Char!-Font Char!-Font _ _________ _______ ____ (Char!-Font C:character): integer expr _ Returns the font attribute of C, which is always 0 in PSL. Code!-Char Code!-Char _ _______ _________ ___ ____ (Code!-Char I:integer): {character,nil} expr The purpose of this function is to be able to construct a character by specifying the code, bits, and font. Because bits Code!-Char Code!-Char and font attributes are not used in PSL, Code!-Char is an Strings and Vectors 7 February 1983 PSL Manual page 8.10 section 8.7 identity function. Character Character _ _________ ______ __ _________ ____ (Character C:{character, string, id}): character expr _ _ _ Attempts to coerce C to be a character. If C is a character, C _ is returned. If C is a string, then the first character of the _ string is returned. If C is a symbol, the first character of the symbol is returned. Otherwise an error occurs. Char!-UpCase Char!-UpCase _ _________ _________ ____ (Char!-UpCase C:character): character expr LowerCaseP Char-UpCase LowerCaseP _ Char-UpCase If LowerCaseP(C) is true, then Char-UpCase returns the code of _ _ the upper case of C. Otherwise it returns the code of C. Char!-DownCase Char!-DownCase _ _________ _________ ____ (Char!-DownCase C:character): character expr UpperCaseP Char-DownCase UpperCaseP _ Char-DownCase If UpperCaseP(C) is true, then Char-DownCase returns the code of _ _ the lower case of C. Otherwise it returns the code of C. Digit!-Char Digit!-Char _ _________ _______ ____ (Digit!-Char C:character): integer expr _ _ Converts character to its code if C is a one-digit number. If C _ is larger than one digit, NIL is returned. If C is not numeric, an error message is caused. Char!-Int Char!-Int _ _________ _______ ____ (Char!-Int C:character): integer expr Converts character to integer. This is the identity operation in PSL. Int!-Char Int!-Char _ _______ _________ ____ (Int!-Char I:integer): character expr Converts integer to character. This is the identity operation in PSL. The string functions follow. RplaChar RplaChar _ ______ _ _______ _ _________ _________ ____ (RplaChar S:string I:integer C:character): character expr _ _ _ Store a character C in a string S at position I. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.11 String!= String!= __ ______ __ ______ _______ ____ (String!= S1:string S2:string): boolean expr __ __ Compares two strings S1 and S2, case sensitive. (Substring options not implemented). String!-Equal String!-Equal __ ______ __ ______ _______ ____ (String!-Equal S1:string S2:string): boolean expr __ __ Compare two strings S1 and S2, ignoring case, bits and font. _____ _______ The following string comparison functions are extra-boolean. If the comparison results in a value of T, the first position of inequality in the strings is returned. String!< String!< __ ______ __ ______ _____ _______ ____ (String!< S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!> String!> __ ______ __ ______ _____ _______ ____ (String!> S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!<!= String!<!= __ ______ __ ______ _____ _______ ____ (String!<!= S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!>!= String!>!= __ ______ __ ______ _____ _______ ____ (String!>!= S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!<!> String!<!> __ ______ __ ______ _____ _______ ____ (String!<!> S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!-LessP String!-LessP __ ______ __ ______ _____ _______ ____ (String!-LessP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-GreaterP String!-GreaterP __ ______ __ ______ _____ _______ ____ (String!-GreaterP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. Strings and Vectors 7 February 1983 PSL Manual page 8.12 section 8.7 String!-Not!-GreaterP String!-Not!-GreaterP __ ______ __ ______ _____ _______ ____ (String!-Not!-GreaterP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Not!-LessP String!-Not!-LessP __ ______ __ ______ _____ _______ ____ (String!-Not!-LessP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Not!-Equal String!-Not!-Equal __ ______ __ ______ _____ _______ ____ (String!-Not!-Equal S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Repeat String!-Repeat _ ______ _ _______ ______ ____ (String!-Repeat S:string I:integer): string expr _ _ Appends copy of S to itself total of I-1 times. String!-Trim String!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Trim BAG:{list, string} S:string): string expr ___ _ Remove leading and trailing characters in BAG from a string S. (String-Trim "ABC" "AABAXYZCB") returns "XYZ" (String-Trim (List (Char A) (Char B) (Char C)) "AABAXYZCB") returns "XYZ" (String-Trim '(65 66 67) "ABCBAVXZCC") returns "VXZ" String!-Left!-Trim String!-Left!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Left!-Trim BAG:{list, string} S:string): string expr Remove leading characters from string. String!-Right!-Trim String!-Right!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Right!-Trim BAG:{list, string} S:string): string expr Remove trailing characters from string. String!-UpCase String!-UpCase _ ______ ______ ____ (String!-UpCase S:string): string expr Copy and raise all alphabetic characters in string. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.13 NString!-UpCase NString!-UpCase _ ______ ______ ____ (NString!-UpCase S:string): string expr Destructively raise all alphabetic characters in string. String!-DownCase String!-DownCase _ ______ ______ ____ (String!-DownCase S:string): string expr Copy and lower all alphabetic characters in string. NString!-DownCase NString!-DownCase _ ______ ______ ____ (NString!-DownCase S:string): string expr Destructively lower all alphabetic characters in string. String!-Capitalize String!-Capitalize _ ______ ______ ____ (String!-Capitalize S:string): string expr Copy and raise first letter of all words in string; other letters in lower case. NString!-Capitalize NString!-Capitalize _ ______ ______ ____ (NString!-Capitalize S:string): string expr Destructively raise first letter of all words; other letters in lower case. String!-to!-List String!-to!-List _ ______ ____ ____ (String!-to!-List S:string): list expr Unpack string characters into a list. String!-to!-Vector String!-to!-Vector _ ______ ______ ____ (String!-to!-Vector S:string): vector expr Unpack string characters into a vector. SubString SubString _ ______ __ _______ __ _______ ______ ____ (SubString S:string LO:integer HI:integer): string expr SubSeq SubSeq ______ Same as SubSeq, but the first argument must be a string. Returns Size _ Size __ __ a substring of S of Size HI - LO - 1, beginning with the element __ with index LO. String!-Length String!-Length _ ______ _______ ____ (String!-Length S:string): integer expr Last index of a string, plus one. |
Added psl-1983/3-1/lpt/09-flowofcontrol.lpt version [42d9810f23].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Flow Of Control section 9.0 page 9.1 CHAPTER 9 CHAPTER 9 CHAPTER 9 FLOW OF CONTROL FLOW OF CONTROL FLOW OF CONTROL 9.1. Introduction . . . . . . . . . . . . . . . 9.1 9.2. Conditionals . . . . . . . . . . . . . . . 9.1 9.2.1. Conds and Ifs. . . . . . . . . . . . . 9.1 9.2.2. The Case Statement . . . . . . . . . . . 9.3 9.3. Sequencing Evaluation . . . . . . . . . . . . 9.4 9.4. Iteration . . . . . . . . . . . . . . . . 9.7 9.4.1. For . . . . . . . . . . . . . . . . 9.8 9.4.2. Mapping Functions . . . . . . . . . . . 9.13 9.4.3. Do . . . . . . . . . . . . . . . . 9.16 9.5. Non-Local Exits . . . . . . . . . . . . . . 9.18 9.1. Introduction 9.1. Introduction 9.1. Introduction Most of the constructs presented in this Chapter have a special syntax in RLISP. This syntax is presented along with the definitions of the underlying functions. Many of the examples are presented using this special RLISP syntax as well as LISP. 9.2. Conditionals 9.2. Conditionals 9.2. Conditionals 9.2.1. Conds and Ifs 9.2.1. Conds and Ifs 9.2.1. Conds and Ifs Cond Cond _ ____ ____ ___ ____ ________ _____ (Cond [U:form-list]): any open-compiled, fexpr Cond If Cond If The LISP function Cond corresponds to the If statement of most If If programming languages. In RLISP this is simply the familiar If Then Else Then Else ... Then ... Else construct. For example: _________ ______ IF predicate THEN action1 ______ ELSE action2 _________ ______ ==> (COND (predicate action1) ______ (T action2)) ______ _________ Action1 is evaluated if the predicate has a non-NIL evaluation; Else ______ Else otherwise, action2 is evaluated. Dangling Elses are resolved in Then Then the ALGOL manner by pairing them with the nearest preceding Then. For example: Flow Of Control 7 February 1983 PSL Manual page 9.2 section 9.2 IF F(X) THEN IF G(Y) THEN PRINT(X) ELSE PRINT(Y); is equivalent to IF F(X) THEN << IF G(Y) THEN PRINT(X) ELSE PRINT(Y) >>; Note that if F(X) is NIL, nothing is printed. Taken simply as a function, without RLISP syntax, the arguments Cond Cond to Cond have the form: _________ ______ ______ (COND (predicate action action ...) _________ ______ ______ (predicate action action ...) ... _________ ______ ______ (predicate action action ...) ) The predicates are evaluated in the order of their appearance until a non-NIL value is encountered. The corresponding actions are evaluated and the value of the last becomes the value of the Cond Else Cond Else Cond. The dangling Else example above is: (COND ((F X) (COND ((G X) (PRINT X)) ( T (PRINT Y)) ) )) Go Return Go Return The actions may also contain the special functions Go, Return, Exit Next Exit Next Exit, and Next, subject to the constraints on placement of these Cond Cond functions given in Section 9.3. In these cases, Cond does not have a defined value, but rather an effect. If no predicate is Cond Cond non-NIL, the value of Cond is NIL. The following MACROs are defined in the USEFUL module for convenience, and are mostly used from LISP syntax: If If _ ____ __ ____ _ ____ ___ _____ (If E:form S0:form [S:form]): any macro If Cond If Cond If is a macro to simplify the writing of a common form of Cond in which there are only two clauses and the antecedent of the second is T. It cannot be used in RLISP syntax. (IF E S0 S1...Sn) __ _ The then-clause S0 is evaluated if and only if the test E is _ non-NIL, otherwise the else-clauses Si are evaluated, and the last returned. There may be no else-clauses. Related macros for common COND forms are WHEN and UNLESS. PSL Manual 7 February 1983 Flow Of Control section 9.2 page 9.3 When When _ ____ _ ____ ___ _____ (When E:form [S:form]): any macro (WHEN E S1 S2 ... Sn) evaluates the Si and returns the value of Sn if and only if the When _ When test E is non-NIL. Otherwise When returns NIL. Unless Unless _ ____ _ ____ ___ _____ (Unless E:form [U:form]): any macro (UNLESS E S1 S2 ... Sn) _ Evaluates the Si if and only if the test E is NIL. It is equivalent to (WHEN (NOT E) S1 S2 ... Sn) And Or And Or While And and Or are primarily of interest as Boolean connectives, they are often used in LISP as conditionals. For example, (AND (FOO) (BAR) (BAZ)) has the same result as (COND ((FOO) (COND ((BAR) (BAZ))))) See Section 4.2.3. 9.2.2. The Case Statement 9.2.2. The Case Statement 9.2.2. The Case Statement PSL provides a numeric case statement, that is compiled quite efficiently; some effort is made to examine special cases (compact vs. non compact sets of cases, short vs. long sets of cases, etc.). It has mostly been used in SYSLISP mode, but can also be used from LISP mode provided that case-tags are numeric. There is also an FEXPR, CASE, for the interpreter. The RLISP syntax is: Case-Statement ::= CASE expr OF case-list END Case-list ::= Case-expr [; Case-list ] Case-expr ::= Tag-expr : expr tag-expr ::= DEFAULT | OTHERWISE | tag | tag, tag ... tag | tag TO tag Tag ::= Integer | Wconst-Integer Flow Of Control 7 February 1983 PSL Manual page 9.4 section 9.2 For example: CASE i OF 1: Print("First"); 2,3: Print("Second"); 4 to 10: Print("Third"); Default: Print("Fourth"); END The RLISP syntax parses into the following LISP form: Case Case _ ____ _ ____ ____ ___ ____ ________ _____ (Case I:form [U:case-list]): any open-compiled, fexpr _ _______ I is meant to evaluate to an integer, and is used as a selector _ amongst the various Us. Each case-list has the form (case-expr form) where case-expr has the form: NIL -> default case (I1 I2 ... In) -> where each Ik is an integer or (RANGE low high) The above example becomes: (CASE i ((1) (Print "First")) ((2 3) (Print "Second")) (((Range 4 10)) (Print "Third")) ( NIL (Print "Fourth"))) [??? Perhaps we should move SELECTQ (and define a SELECT) from the [??? Perhaps we should move SELECTQ (and define a SELECT) from the [??? Perhaps we should move SELECTQ (and define a SELECT) from the COMMON module to the basic system ???] COMMON module to the basic system ???] COMMON module to the basic system ???] . 9.3. Sequencing Evaluation 9.3. Sequencing Evaluation 9.3. Sequencing Evaluation These functions provide for explicit control sequencing, and the definition of blocks altering the scope of local variables. ProgN ProgN _ ____ ___ ____ ________ _____ (ProgN [U:form]): any open-compiled, fexpr _ U is a set of expressions which are executed sequentially. The value returned is the value of the last expression. PSL Manual 7 February 1983 Flow Of Control section 9.3 page 9.5 Prog2 Prog2 _ ____ _ ____ ___ ____ ________ ____ (Prog2 A:form B:form): any open-compiled, expr _ Returns the value of B (the second argument). [??? Redefine prog2 to take N arguments, return second. ???] [??? Redefine prog2 to take N arguments, return second. ???] [??? Redefine prog2 to take N arguments, return second. ???] Prog1 Prog1 _ ____ ___ _____ (Prog1 [U:form]): any macro Prog1 Prog1 Prog1 is a function defined in the USEFUL package; to use it, Prog1 Prog1 type (LOAD USEFUL). Prog1 evaluates its arguments in order, like ProgN ProgN ProgN, but returns the value of the first. Prog Prog ____ __ ____ _______ __ ____ ___ ____ ________ _____ (Prog VARS:id-list [PROGRAM:{id,form}]): any open-compiled, fexpr Prog ____ ____ __ Prog VARS is a list of ids which are considered FLUID if the Prog is interpreted and LOCAL if compiled (see the "Variables and Prog Prog Bindings" Section, 10.2). The Prog's variables are allocated Prog Prog space if the Prog form is applied, and are deallocated if the Prog Prog Prog Prog Prog is exited. Prog variables are initialized to NIL. The _______ PROGRAM is a set of expressions to be evaluated in order of their Prog Prog __________ appearance in the Prog function. identifiers appearing in the _______ top level of the PROGRAM are labels which can be referred to by Go Prog Go Prog Go. The value returned by the Prog function is determined by a Return Prog Return Prog Return function or NIL if the Prog "falls through". There are restrictions as to where a number of control functions, such as Go Return Go Return Go and Return, may be placed. This is so that they may have only locally determinable effects. Unlike most LISPs, which make this restriction only in compiled code, PSL enforces this restriction uniformly in both compiled and interpreted code. Not only does this help keep the semantics of compiled and interpreted code the same, but we believe it leads to more readable programs. For cases in which a non-local exit is truly required, Catch Throw Catch Throw there are the functions Catch and Throw, described in Section 9.5. Go Return Exit Next Go Return Exit Next The functions so restricted are Go, Return, Exit, and Next. They must be placed at top-level within the surrounding control structure to which they Prog Return Prog Return refer (e.g. the Prog which Return causes to be terminated), or nested within only selected functions. The functions in which they may be nested (to arbitrary depth) are: ProgN ProgN - ProgN (compound statement) Cond Cond - actions of Conds (if then else) Case Case - actions in Cases Go Go _____ __ ____ ________ ____ ________ _____ (Go LABEL:id): None Returned open-compiled, fexpr Go Prog Go Prog Go alters the normal flow of control within a Prog function. The Prog Prog next statement of a Prog function to be evaluated is immediately Go _____ Go preceded by LABEL. A Go may appear only in the following situations: Flow Of Control 7 February 1983 PSL Manual page 9.6 section 9.3 Prog Prog _____ a. At the top level of a Prog referring to a LABEL that also Prog Prog appears at the top level of the same Prog. Cond Cond b. As the action of a Cond item Prog Prog i. appearing on the top level of a Prog. Cond Cond ii. which appears as the action of a Cond item to any level. ProgN ProgN c. As the last statement of a ProgN Prog Prog i. which appears at the top level of a Prog or in a ProgN Cond ProgN Cond ProgN appearing in the action of a Cond to any level subject to the restrictions of b.i, or b.ii. ProgN Cond ProgN ProgN Cond ProgN ii. within a ProgN or as the action of a Cond in a ProgN to any level subject to the restrictions of b.i, b.ii, and c.i. Prog _____ Prog If LABEL does not appear at the top level of the Prog in which Go Go the Go appears, an error occurs: ***** LABEL is not a label within the current scope Go Go If the Go has been placed in a position not defined by rules a-c, another error is detected: ***** Illegal use of GO To LABEL Return Return _ ____ ____ ________ ____ ________ ____ (Return U:form): None Returned open-compiled, expr Prog Return Prog Prog Return Prog Within a Prog, Return terminates the evaluation of a Prog and Prog _ Prog returns U as the value of the Prog. The restrictions on the Return Go Return Go placement of Return are exactly those of Go. Improper placement Return Return of Return results in the error: ***** Illegal use of RETURN 9.4. Iteration 9.4. Iteration 9.4. Iteration While While _ ____ _ ____ ___ _____ (While E:form [S:form]): NIL macro This is the most commonly used construct for indefinite iteration _ _ in LISP. E is evaluated; if non-NIL, the S's are evaluated from _ left to right and then the process is repeated. If E evaluates While Exit While Exit to NIL the While returns NIL. Exit may be used to terminate the PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.7 While Next While Next While from within the body and to return a value. Next may be used to terminate the current iteration. In RLISP syntax this is While Do While Do While ... Do ... . Note that in RLISP syntax there may be only a Do ProgN Do ProgN single expression after the Do; however, it may be a ProgN delimited by <<...>>. That is, (While E S1 S2) should be written in RLISP as While E do <<S1; S2>>; Repeat Repeat _ ____ _ ____ ___ _____ (Repeat E:form [S:form]): NIL macro _ _ The S's are evaluated left to right, and then E is evaluated. Repeat _ Repeat This is repeated until the value of E is NIL, if Repeat returns Next Exit Next Exit _ NIL. Next and Exit may be used in the S's branch to the next Repeat Repeat iteration of a Repeat or to terminate one and possibly return a Go Return Go Return _ value. Go, and Return may appear in the S's. The RLISP syntax Repeat Repeat Until While Repeat Repeat Until While for Repeat is Repeat Until. Like While, RLISP syntax only allows _ a single S, so (REPEAT E S1 S2) should be written in RLISP as REPEAT << S1; S2 >> UNTIL E; [??? maybe do REPEAT S1 ... Sn E ???] [??? maybe do REPEAT S1 ... Sn E ???] [??? maybe do REPEAT S1 ... Sn E ???] Next Next ____ ________ ____ ________ __________ _____ (Next ): None Returned open-compiled, restricted, macro This terminates the current iteration of the most closely While Repeat While Repeat surrounding While or Repeat, and causes the next to commence. See the note in Section 9.3 about the lexical restrictions on GO GO placement of this construct, which is essentially a GO to a special label placed at the front of a loop construct. Exit Exit _ ____ ____ ________ ____ ________ __________ _____ (Exit [U:form]): None Returned open-compiled,restricted, macro _ The U's are evaluated left to right, the most closely surrounding While Repeat While Repeat _ While or Repeat is terminated, and the value of the last U is returned. With no arguments, NIL is returned. See the note in Section 9.3 about the lexical restrictions on placement of this Return Return construct, which is essentially a Return. While Repeat Prog Next Exit While Repeat Prog Next Exit While and Repeat each macro expand into a Prog; Next and Exit are macro Go Return Prog Go Return Prog expanded into a Go and a Return respectively to this Prog. Thus using a Next Exit Prog While Repeat Next Exit Prog While Repeat Next or an Exit within a Prog within a While or Repeat will result only in Flow Of Control 7 February 1983 PSL Manual page 9.8 section 9.4 Prog Prog an exit of the internal Prog. In RLISP be careful to use WHILE E DO << S1;...;EXIT(1);...;Sn>> not WHILE E DO BEGIN S1;...;EXIT(1);...;Sn;END; 9.4.1. For 9.4.1. For 9.4.1. For For For A simple For construct is available in the basic PSL system and RLISP; an extended form can obtained by loading USEFUL. It is planned to make the extended form the version available in the basic system, combining all the FOR ForEach For FOR ForEach For features of FOR and ForEach. The basic PSL For provides only the (FROM ..) ForEach ForEach iterator, and (DO ...) action clause, and uses the ForEach construct for some of the (IN ...) and (ON ...) iterators. Most PSL syntax users should For For use the full For construct. For For _ ____ ___ _____ (For [S:form]): any macro For For The arguments to For are clauses; each clause is itself a list of a keyword and one or more arguments. The clauses may introduce local variables, specify return values and when the iteration should cease, have side-effects, and so on. Before going further, it is probably best to give some examples. (FOR (FROM I 1 10 2) (DO (PRINT I))) Prints the numbers 1 3 5 7 9 (FOR (IN U '(A B C)) (DO (PRINT U))) Prints the letters A B C (FOR (ON U '(A B C)) (DO (PRINT U))) Prints the lists (A B C) (B C) and (C) Finally, the function (DE ZIP (X Y) (FOR (IN U X) (IN V Y) (COLLECT (LIST U V)))) produces a list of 2 element lists, each consisting of the the corresponding elements of the three lists X, Y and Z. For example, (ZIP '(1 2 3 4) '(A B C) ) produces PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.9 ((1 a)(2 b)(3 c)) The iteration terminates as soon as one of the (IN ..) clauses is exhausted. Note that the (IN ... ), (ON ...) and (FROM ...) clauses introduce local variables U, V or I, that are referred to in the action clause. All the possible clauses are described below. The first few introduce iteration variables. Most of these also give some means of indicating when iteration should cease. For example, if In ____ In a list being mapped over by an In clause is exhausted, iteration For For must cease. If several such clauses are given in For expression, iteration ceases when one of the clauses indicates it should, whether or not the other clauses indicate that it should cease. (IN V1 V2) ____ assigns the variable V1 successive elements of the list V2. This may take an additional, optional argument: a function to be applied to the extracted element or sublist before it is assigned to the variable. The following returns the sum of the lengths of all the elements of L. [??? Rather a kludge -- not sure why this is here. [??? Rather a kludge -- not sure why this is here. [??? Rather a kludge -- not sure why this is here. Perhaps it should come out again. ???] Perhaps it should come out again. ???] Perhaps it should come out again. ???] (DE LENGTHS (L) (FOR (IN N L LENGTH) (COLLECT (LIST N N))) is the same as (DE LENGTHS (L) (FOR (IN N L) (COLLECT (LIST (LENGTH N) (LENGTH N)))) ) but only calls LENGTH once. Using the (WITH ..) form to introduce a local LN may be clearer. For example, (SUMLENGTHS '((1 2 3 4 5)(a b c)(x y))) is ((5 5) (3 3) (2 2)) Flow Of Control 7 February 1983 PSL Manual page 9.10 section 9.4 (ON V1 V2) Cdr Cdr ____ assigns the variable V1 successive Cdrs of the list V2. (FROM VAR INIT FINAL STEP) is a numeric iteration clause. The variable is first assigned INIT, and then incremented by step until it is larger than FINAL. INIT, FINAL, and STEP are optional. INIT and STEP both default to 1, and if FINAL is omitted the iteration continues until stopped by some other means. To specify a STEP with INIT or FINAL omitted, or a FINAL with INIT omitted, place NIL (the constant -- it cannot be an expression) in the appropriate slot to be omitted. FINAL and STEP are only evaluated once. (FOR VAR INIT NEXT) assigns the variable INIT first, and subsequently the value of the expression NEXT. INIT and NEXT may be omitted. Note that this is identical to the behavior Do Do of iterators in a Do. (WITH V1 V2 ... Vn) introduces N locals, initialized to NIL. In addition, each Vi may also be of the form (VAR INIT), in which case it is initialized to INIT. (DO S1 S2 ... Sn) causes the Si's to be evaluated at each iteration. There are two clauses which allow arbitrary code to be executed before the first iteration, and after the last. (INITIALLY S1 S2 ... Sn) causes the Si's to be evaluated in the new environment (i.e. with the iteration variables bound to their initial values) before the first iteration. (FINALLY S1 S2 ... Sn) causes the Si's to be evaluated just before the function returns. The next few clauses build up return types. Except for the RETURNS/RETURNING clause, they may each take an additional argument which specifies that instead of returning the appropriate value, it is accumulated in the specified variable. For example, an unzipper might be defined as PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.11 (DE UNZIP (L) (FOR (IN U L) (WITH X Y) (COLLECT (FIRST U) X) (COLLECT (SECOND U) Y) (RETURNS (LIST X Y)))) Zip Zip ____ This is essentially the opposite of Zip. Given a list of 2 ____ ____ ____ element lists, it unzips them into 2 lists, and returns a list of ____ those 2 lists. For example, (unzip '((1 a)(2 b)(3 c))) returns is ((1 2 3)(a b c)). (RETURNS EXP) For For causes the given expression to be the value of the For. Returning is synonymous with returns. It may be given additional arguments, in which case they are evaluated in order and the value of the last is returned ProgN ProgN (implicit ProgN). (COLLECT EXP) causes the successive values of the expression to be Append ____ Append collected into a list. Each value is Appended to the ____ end of the list. (UNION EXP) ____ is similar, but only adds an element to the list if it is not equal to anything already there. (CONC EXP) NConc NConc causes the successive values to be NConc'd together. (JOIN EXP) causes them to be appended. (COUNT EXP) returns the number of times EXP was non-NIL. (SUM EXP), (PRODUCT EXP), (MAXIMIZE EXP), and (MINIMIZE EXP) do the obvious. Synonyms are summing, maximizing, and minimizing. (ALWAYS EXP) returns T if EXP is non-NIL on each iteration. If EXP is ever NIL, the loop terminates immediately, no epilogue code, such as that introduced by finally is run, and NIL is returned. (NEVER EXP) is equivalent to (ALWAYS (NOT EXP)). (WHILE EXP) and (UNTIL EXP) Explicit tests for the end of the loop may be given Flow Of Control 7 February 1983 PSL Manual page 9.12 section 9.4 using (WHILE EXP). The loop terminates if EXP becomes NIL at the beginning of an iteration. (UNTIL EXP) is While Until While Until equivalent to (WHILE (NOT EXP)). Both While and Until may be given additional arguments; (WHILE E1 E2 ... En) is equivalent to (WHILE (AND E1 E2 ... En)) and (UNTIL E1 E2 ... En) is equivalent to (UNTIL (OR E1 E2 ... En)). (WHEN EXP) causes a jump to the next iteration if EXP is NIL. (UNLESS EXP) is equivalent to (WHEN (NOT EXP)). For For For is a general iteration construct similar in many ways to the LISP Loop Loop Machine and MACLISP Loop construct, and the earlier Interlisp CLISP For For iteration construct. For, however, is considerably simpler, far more For For "lispy", and somewhat less powerful. For only works in LISP syntax. All variable binding/updating still precedes any tests or other code. When Unless When Unless Also note that all When or Unless clauses apply to all action clauses, not For For just subsequent ones. This fixed order of evaluation makes For less Loop Loop powerful than Loop, but also keeps it considerably simpler. The basic order of evaluation is a. bind variables to initial values (computed in the outer environment) Initially Initially b. execute prologue (i.e. Initially clauses) c. while none of the termination conditions are satisfied: When Unless When Unless i. check conditionalization clauses (When and Unless), and start next iteration if all are not satisfied. ii. perform body, collecting into variables as necessary iii. next iteration d. (after a termination condition is satisfied) execute the Finally Finally epilogue (i.e. Finally clauses) For For For does all variable binding/updating in parallel. There is a similar For* For* macro, For*, which does it sequentially. PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.13 For!* For!* _ ____ ___ _____ (For!* [S:form]): any macro 9.4.2. Mapping Functions 9.4.2. Mapping Functions 9.4.2. Mapping Functions ) The mapping functions long familiar to LISP programmers are present in For For PSL. However, we believe that the For construct described above or the ForEach ForEach simpler ForEach described below is generally more useful, since it obviates the usual necessity of constructing a lambda expression, and is often more transparent. Mapping functions with more than two arguments are not ____ currently supported. Note however that several lists may be iterated along For For with For, and with considerably more generality. For example: (Prog (I) (Setq I 0) (Return (Mapcar L (Function (Lambda (X) (Progn (Setq I (Plus I 1)) (Cons I X))))))) may be expressed more transparently as (For (IN X L) (FROM I 1) (COLLECT (CONS I X))) Note that there is currently no RLISP syntax for this, but we are contemplating something like: FOR X IN L AS I FROM 1 COLLECT I . X; For For To augment the simpler For loop present in basic PSL and support the For Each For Each RLISP For Each construct, the following list iterator has been provided: ForEach ForEach _ ___ ___ _____ (ForEach U:any): any macro _____ _____ _____ macro macro This macro is essentially equivalent to the the map functions as follows: Possible forms are: Setting X to successive elements (CARs) of U: (FOREACH X IN U DO (FOO X)) --> (MAPC U 'FOO) (FOREACH X IN U COLLECT (FOO X))--> (MAPCAR U 'FOO) (FOREACH X IN U CONC (FOO X)) --> (MAPCAN U 'FOO) (FOREACH X IN U JOIN (FOO X)) --> (MAPCAN U 'FOO) Setting X to successive CDRs of U: (FOREACH X ON U DO (FOO X)) --> (MAP U 'FOO) Flow Of Control 7 February 1983 PSL Manual page 9.14 section 9.4 (FOREACH X ON U COLLECT (FOO X))--> (MAPLIST U 'FOO) (FOREACH X ON U CONC (FOO X)) --> (MAPCON U 'FOO) (FOREACH X ON U JOIN (FOO X)) --> (MAPCON U 'FOO) The RLISP syntax is quite simple: FOR EACH x IN y DO z; FOR EACH x ON y COLLECT z; etc. Note that FOR EACH may be written as FOREACH Map Map _ ____ __ ________ ___ ____ (Map X:list FN:function): NIL expr Cdr __ Cdr _ Applies FN to successive Cdr segments of X. NIL is returned. This is equivalent to: (FOREACH u ON x DO (FN u)) MapC MapC _ ____ __ ________ ___ ____ (MapC X:list FN:function): NIL expr Car __ Car ____ _ FN is applied to successive Car segments of list X. NIL is returned. This is equivalent to: (FOREACH u IN x DO (FN u)) MapCan MapCan _ ____ __ ________ ____ ____ (MapCan X:list FN:function): list expr Car ____ __ Car _ A concatenated list of FN applied to successive Car elements of X is returned. This is equivalent to: (FOREACH u IN x CONC (FN u)) MapCar MapCar _ ____ __ ________ ____ ____ (MapCar X:list FN:function): list expr ____ __ Returned is a constructed list, the elements of which are FN Car Car ____ _ applied to each Car of list X. This is equivalent to: (FOREACH u IN x COLLECT (FN u)) MapCon MapCon _ ____ __ ________ ____ ____ (MapCon X:list FN:function): list expr Cdr ____ __ Cdr Returned is a concatenated list of FN applied to successive Cdr _ segments of X. This is equivalent to: PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.15 (FOREACH u ON x CONC (FN u)) MapList MapList _ ____ __ ________ ____ ____ (MapList X:list FN:function): list expr ____ __ Returns a constructed list, the elements of which are FN applied Cdr Cdr _ to successive Cdr segments of X. This is equivalent to: (FOREACH u ON x COLLECT (FN u)) 9.4.3. Do 9.4.3. Do 9.4.3. Do Do Let Do Let The MACLISP style Do and Let are now partially implemented in the USEFUL module. Do Do _ ____ _ ____ _ ____ ___ _____ (Do A:list B:list [S:form]): any macro Do Do The Do macro is a general iteration construct similar to that of LISPM and friends. However, it does differ in some details; in Do Do particular it is not compatible with the "old style Do" of MACLISP, nor does it support the "no end test means once only" Do Do convention. Do has the form (DO (I1 I2 ... In) (TEST R1 R2 ... Rk) S1 S2 ... Sm) in which there may be zero or more I's, R's, and S's. In general the I's have the form (var init step) Do Do On entry to the Do form, all the inits are evaluated, then the variables are bound to their respective inits. The test is evaluated, and if non-NIL the form evaluates the R's and returns the value of the last one. If none are supplied it returns NIL. If the test evaluates to NIL the S's are evaluated, the variables are assigned the values of their respective steps in parallel, and the test evaluated again. This iteration continues until test evaluates to a non-NIL value. Note that the inits are evaluated in the surrounding environment, while the steps are Do Do evaluated in the new environment. The body of the Do (the S's) Prog Go Prog Go is a Prog, and may contain labels and Go's, though use of this is Return Return discouraged. It may be changed at a later date. Return used Do Do within a Do returns immediately without evaluating the test or exit forms (R's). Flow Of Control 7 February 1983 PSL Manual page 9.16 section 9.4 There are alternative forms for the I's: If the step is omitted, the variable's value is left unchanged. If both the init and __ step are omitted or if the I is an id, it is initialized to NIL and left unchanged. This is particularly useful for introducing SetQ SetQ dummy variables which are SetQ'd inside the body. Do!* Do!* _ ____ _ ____ _ ____ ___ _____ (Do!* A:list B:list [C:form]): any macro Do!* Do Do!* Do Do!* is like Do, except the variable bindings and updatings are done sequentially instead of in parallel. Do-Loop Do-Loop _ ____ _ ____ _ ____ _ ____ ___ _____ (Do-Loop A:list B:list C:list [S:form]): any macro Do-Loop Do Do-Loop Do Do-Loop is like Do, except that it takes an additional argument, a prologue. The general form is (DO-LOOP (I1 I2 ... In) (P1 P2 ... Pj) (TEST R1 R2 ... Rk) S1 S2 ... Sm) Do Do This is executed just like the corresponding Do, except that after the bindings are established and initial values assigned, but before the test is first executed the P's are evaluated, in order. Note that the P's are all evaluated exactly once (assuming that none of the P's err out, or otherwise throw to a surrounding context). Do-Loop!* Do-Loop!* _ ____ _ ____ _ ____ _ ____ ___ _____ (Do-Loop!* A:list B:list C:list [S:form_]): any macro Do-Loop!* Do-Loop!* Do-Loop!* does the variable bindings and undates sequentially instead of in parallel. Let Let _ ____ _ ____ ___ _____ (Let A:list [B:form]): any macro Let Let Let is a macro giving a more perspicuous form for writing lambda expressions. The basic form is (LET ((V1 I1) (V2 I2) ...(Vn In)) S1 S2 ... Sn) The I's are evaluated (in an unspecified order), and then the V's are bound to these values, the S's evaluated, and the value of the last is returned. Note that the I's are evaluated in the outer environment before the V's are bound. PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.17 __ Note: the id LET conflicts with a similar construct in RLISP and REDUCE Let!* Let!* _ ____ _ ____ ___ _____ (Let!* A:list [B:form]): any macro Let!* Let Let!* Let Let!* is just like Let except that it makes the assignments sequentially. That is, the first binding is made before the value for the second one is computed. 9.5. Non-Local Exits 9.5. Non-Local Exits 9.5. Non-Local Exits One occasionally wishes to discontinue a computation in which the lexical Return Return restrictions on placement of Return are too restrictive. The non-local Catch Throw Catch Throw exit constructs Catch and Throw exist for these cases. They should not, however, be used indiscriminately. The lexical restrictions on their more local counterparts ensure that the flow of control can be ascertained by Catch Throw Catch Throw looking at a single piece of code. With Catch and Throw, control may be passed to and from totally unrelated pieces of code. Under some conditions, these functions are invaluable. Under others, they can wreak havoc. Catch Catch ___ __ ____ ____ ___ ____ ________ _____ (Catch TAG:id [FORM:form]): any Open-Compiled, fexpr Catch Eval Catch ___ Eval ____ Catch evaluates the TAG and then calls Eval on the FORMs in a Throw Throw ___ ___ protected environment. If during this evaluation (Throw TAG VAL) Catch Throw Catch ___ Throw occurs, Catch immediately returns VAL. If no Throw occurs, the ____ value of the last FORM is returned. Note that in general only Throw Throw Eq Throw ___ Throw ___ Eq Throws with the same TAG are caught. Throws whose TAG is not Eq Catch Catch Catch Catch ___ to that of Catch are passed on out to surrounding Catches. A TAG Catch Catch of NIL, however, is special. (Catch NIL @var[form)] catches any Throw Throw Throw. __________ ______ THROWSIGNAL!* [Initially: NIL] global __________ ______ THROWTAG!* [Initially: NIL] global The FLUID variables THROWSIGNAL!* and THROWTAG!* may be Catch Catch interrogated to find out if the most recently evaluated Catch was Throw Throw Throw Throw Thrown to, and what tag was passed to the Throw. THROWSIGNAL!* Set Catch Set Catch is Set to NIL upon normal exit from a Catch, and to T upon normal Throw Set Throw Set exit from Throw. THROWTAG!* is Set to the first argument passed Throw Throw Eval Throw Throw Eval ____ to the Throw. (Mark a place to Throw to, Eval FORM.) Flow Of Control 7 February 1983 PSL Manual page 9.18 section 9.5 Throw Throw ___ __ ___ ___ ____ ________ ____ (Throw TAG:id VAL:any): None Returned expr Catch Eq Catch Eq This passes control to the closest surrounding Catch with an Eq Catch ___ Catch or null TAG. If there is no such surrounding Catch it is an _____ _____ _____ Throw __ ___ _______ __ ___ Throw error in the context of the Throw. That is, control is not Throw Error Throw Error Thrown to the top level before the call on Error. (Non-local Goto Goto Goto.) Some examples: In LISP syntax, with (DE DOIT (x) (COND ((EQN x 1) 100) (T (THROW 'FOO 200)))) (CATCH 'FOO (DOIT 1) (PRINT "NOPE") 0) will continue and execute the PRINT statement and return 0 while (CATCH 'FOO (DOIT 2) (PRINT "NOPE") 0) will of course THROW, returning 200 and not executing the last forms. A common problem people encounter is how to pass arguments and/or CATCH CATCH computed functions or tags into CATCH for protected evaluation. The following examples should illustrate. Note that TAG is quoted, since it is evaluated before use in CATCH and THROW. In LISP syntax: (DE PASS-ARGS(X1 X2) (CATCH 'FOO (FEE (PLUS2 X1 X2) (DIFFERENCE X1 X2)))) This is simple, because CATCH compiles open. No FLUID declarations or Apply Apply LIST building is needed, as in previous versions of PSL. An explicit Apply must be used for a function argument; usually, the APPLY will compile open, with no overhead: In LISP syntax: (DE PASS-FN(X1 FN) (CATCH 'FOO (APPLY FN (LIST X1)))) Catch Throw Catch Throw The following MACROs are provided to aid in the use of Catch and Throw with a NIL tag, by examining the THROWSIGNAL!* and THROWTAG!*: PSL Manual 7 February 1983 Flow Of Control section 9.5 page 9.19 Catch!-All Catch!-All __ ________ ____ ____ ___ _____ (Catch!-All FN:function [FORM:form]): any macro Catch Catch This issues a (Catch NIL ...); if a Throw was actually done, the __ function FN is applied to the two arguments THROWTAG!* and the throw Throw throw Throw value returned by the throw. Thus FN is applied only if a Throw was executed. Unwind!-All Unwind!-All __ ________ ____ ____ ___ _____ (Unwind!-All FN:function [FORM:form]): any macro Catch Catch __ This issues a (Catch NIL ...). The function FN is always called, and applied to the two arguments THROWTAG!* and the value throw Throw throw Throw __ returned by the throw. If no Throw was done then FN is called on NIL and the value returned. Unwind!-Protect Unwind!-Protect _ ____ _ ____ ___ _____ (Unwind!-Protect F:form [C:form]): any macro _ The idea is to execute the "protected" form, F, and then run some _ "clean-up" forms C even if a Throw (or Error) occurred during the Catch _ Catch evaluation of F. This issues a (Catch NIL ...), the cleanup forms are then run, and finally either the value is returned if no Throw occurred, or the Throw is "re-thrown" to the same tag. A common example is to ensure a file be closed after processing, even if an error or throw occurred: (SETQ chan (OPEN file ....)) (UNWIND-PROTECT (process-file) (CLOSE chan)) Note: Certain special tags are used in the PSL system, and should not be interfered with casually: Error ErrorSet Error ErrorSet !$ERROR!$ Used by Error and ErrorSet which are implemented in terms of Catch Throw Catch Throw Catch and Throw, see Chapter 14). !$UNWIND!-PROTECT!$ A special TAG placed to ensure that ALL throws pause at the UNWIND-PROTECT "mark". PROG GO RETURN PROG GO RETURN !$PROG!$ Used to communicate between interpreted PROGs, GOs and RETURNs. |
Added psl-1983/3-1/lpt/10-functions.lpt version [118390306b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Function Definition section 10.0 page 10.1 CHAPTER 10 CHAPTER 10 CHAPTER 10 FUNCTION DEFINITION AND BINDING FUNCTION DEFINITION AND BINDING FUNCTION DEFINITION AND BINDING 10.1. Function Definition in PSL . . . . . . . . . . 10.1 10.1.1. Notes on Code Pointers . . . . . . . . . 10.1 10.1.2. Functions Useful in Function Definition. . . . 10.2 10.1.3. Function Definition in LISP Syntax . . . . . 10.4 10.1.4. Function Definition in RLISP Syntax . . . . . 10.6 10.1.5. Low Level Function Definition Primitives . . . 10.6 10.1.6. Function Type Predicates. . . . . . . . . 10.7 10.2. Variables and Bindings. . . . . . . . . . . . 10.8 10.2.1. Binding Type Declaration. . . . . . . . . 10.8 10.2.2. Binding Type Predicates . . . . . . . . . 10.9 10.3. User Binding Functions. . . . . . . . . . . . 10.10 10.3.1. Funargs, Closures and Environments . . . . . 10.10 10.1. Function Definition in PSL 10.1. Function Definition in PSL 10.1. Function Definition in PSL Functions in PSL are GLOBAL entities. To avoid function-variable naming clashes, the Standard LISP Report required that no variable have the same name as a function. There is no conflict in PSL, as separate function cells and value cells are used. A warning message is given for compatibility. The first major section in this chapter describes how to define new functions; the second describes the binding of variables in PSL. The final section presents binding functions useful in building new interpreter functions. 10.1.1. Notes on Code Pointers 10.1.1. Notes on Code Pointers 10.1.1. Notes on Code Pointers Print ____ _______ Print A code-pointer may be displayed by the Print functions or expanded by Explode Explode Explode. The value appears in the convention of the implementation (#<Code:a nnnn>, where a is the number of arguments of the function, and ____ _______ nnnn is the function's entry point, on the DEC-20 and VAX). A code-pointer Compress Compress may not be created by Compress. (See Chapter 12 for descriptions of Explode Compress Explode Compress ____ _______ Explode and Compress.) The code-pointer associated with a compiled GetD GetD function may be retrieved by GetD and is valid as long as PSL is in execution (on the DEC-20 and VAX, compiled code is not relocated, so PutD ____ _______ ____ _______ PutD code-pointers do not change). A code-pointer may be stored using PutD, Put SetQ Put SetQ Put, SetQ and the like or by being bound to a variable. It may be checked Eq Eq ____ _______ for equivalence by Eq. The value may be checked for being a code-pointer CodeP CodeP by the CodeP function. Function Definition 7 February 1983 PSL Manual page 10.2 section 10.1 10.1.2. Functions Useful in Function Definition 10.1.2. Functions Useful in Function Definition 10.1.2. Functions Useful in Function Definition __ In PSL, ids have a function cell that usually contains an executable instruction which either JUMPs directly to the entry point of a compiled function or executes a CALL to an auxiliary routine that handles interpreted functions, undefined functions, or other special services (such ________ as auto-loading functions, etc). The user can pass anonymous function ____ _______ objects around either as a code-pointer, which is a tagged object referring ______ to a compiled code block, or a lambda expression, representing an interpreted function. PutD PutD _____ __ ____ _____ ____ ______ ____ _______ __ ____ (PutD FNAME:id TYPE:ftype BODY:{lambda,code-pointer}): id expr _____ ____ ____ Creates a function with name FNAME and type TYPE, with BODY as PutD PutD the function definition. If successful, PutD returns the name of the defined function. ____ _______ If the body is a code-pointer or is compiled (i.e. !*COMP=T as the function was defined), a special instruction to jump to the start of the code is placed in the function cell. If it is a ______ lambda, the lambda expression is saved on the property list under the indicator !*LAMBDALINK and a call to an interpreter function LambdaLink LambdaLink (LambdaLink) is placed in the function cell. ____ ____ _____ The TYPE is recorded on the property list of FNAME if it is not ____ ____ ____ expr expr an expr. [??? We need to add code to check that the the arglist has no [??? We need to add code to check that the the arglist has no [??? We need to add code to check that the the arglist has no more than 15 arguments for exprs, 1 argument for fexprs and more than 15 arguments for exprs, 1 argument for fexprs and more than 15 arguments for exprs, 1 argument for fexprs and macros, and ??? for nexprs. Declaration mechanisms to avoid macros, and ??? for nexprs. Declaration mechanisms to avoid macros, and ??? for nexprs. Declaration mechanisms to avoid overhead also need to be available. (In fact are available overhead also need to be available. (In fact are available overhead also need to be available. (In fact are available for the compiler, although still poorly documented.) When for the compiler, although still poorly documented.) When for the compiler, although still poorly documented.) When should we expand macros? ???] should we expand macros? ???] should we expand macros? ???] PutD GetD PutD _____ GetD ____ _____ After using PutD on FNAME, GetD returns a pair of the the FNAME's ____ ____ (TYPE . BODY). GlobalP GlobalP The GlobalP predicate returns T if queried with the defined _____ function's name. If the function FNAME has already been declared as a GLOBAL or FLUID variable the warning: *** FNAME is a non-local variable _____ occurs, but the function is defined. If function FNAME is already defined, a warning message appears: *** Function FNAME has been redefined ____ Note: All function types may be compiled. The following switches are useful when defining functions. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.3 __________ ______ !*REDEFMSG [Initially: T] switch If !*REDEFMSG is not NIL, the message *** Function `FOO' has been redefined is printed whenever a function is redefined. __________ ______ !*USERMODE [Initially: T] switch Controls action on redefinition of a function. All functions defined if !*USERMODE is T are flagged USER. Functions which are flagged USER can be redefined freely. If an attempt is made to redefine a function which is not flagged USER, the query Do you really want to redefine the system function `FOO'? is made, requiring a Y, N, YES, NO, or B response. B starts the break loop, so that one can change the setting of !*USERMODE. After exiting the break loop, one must answer Y, Yes, N, or No. YesP YesP See YesP in Chapter 13. If !*UserMode is NIL, all functions can be redefined freely, and all functions defined have the USER flag removed. This provides some protection from redefining system functions. __________ ______ !*COMP [Initially: NIL] switch PutD PutD The value of !*COMP controls whether or not PutD compiles the function defined in its arguments before defining it. If !*COMP is NIL the function is defined as a lambda expression. If !*COMP is non-NIL, the function is first compiled. Compilation produces certain changes in the semantics of functions, particularly FLUID type access. GetD GetD _ ___ ___ ____ ____ (GetD U:any): {NIL, pair} expr _ If U is not the name of a defined function, NIL is returned. If _ ____ U is a defined function then the pair ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr, fexpr, macro, nexpr expr, fexpr, macro, nexpr ____ _______ ______ ({expr, fexpr, macro, nexpr} . {code-pointer, lambda}) is returned. CopyD CopyD ___ __ ___ __ ___ __ ____ (CopyD NEW:id OLD:id): NEW:id expr ___ ___ The function body and type for NEW become the same as OLD. If no ___ definition exists for OLD an error: ***** OLD has no definition in COPYD Function Definition 7 February 1983 PSL Manual page 10.4 section 10.1 ___ is given. NEW is returned. RemD RemD _ __ ___ ____ ____ (RemD U:id): {NIL, pair} expr _ Removes the function named U from the set of defined functions. GetD ____ GetD Returns the (ftype . function) pair or NIL, as does GetD. The ________ _ function type attribute of U is removed from the property list of _ U. 10.1.3. Function Definition in LISP Syntax 10.1.3. Function Definition in LISP Syntax 10.1.3. Function Definition in LISP Syntax De Df Dn Dm Ds De Df Dn Dm Ds The functions De, Df, Dn, Dm, and Ds are most commonly used in the LISP syntax form of PSL. They are difficult to use from RLISP as there is not a convenient way to represent the argument list. The functions are compiled if the compiler is loaded and the GLOBAL !*COMP is T. De De _____ __ ______ __ ____ __ ____ __ _____ (De FNAME:id PARAMS:id-list [FN:form]): id macro ____ ____ ____ expr _____ expr ____ __ Defines the function named FNAME, of type expr. The forms FN are made into a lambda expression with the formal parameter list 1 ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Df Df _____ __ _____ __ ____ __ ___ __ _____ (Df FNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ fexpr _____ fexpr ____ __ Defines the function named FNAME, of type fexpr. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Dn Dn _____ __ _____ __ ____ __ ___ __ _____ (Dn FNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ nexpr _____ nexpr ____ __ Defines the function named FNAME, of type nexpr. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. _______________ 1 Or the compiled code pointer for the lambda expression if the compiler is on. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.5 Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Dm Dm _____ __ _____ __ ____ __ ___ __ _____ (Dm MNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ macro _____ macro ____ __ Defines the function named FNAME, of type macro. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Ds Ds _____ __ _____ __ ____ __ ___ __ _____ (Ds SNAME:id PARAM:id-list FN:any): id macro ______ _______ ______ _______ ______ _______ smacro Smacros smacro _____ Smacros Defines the smacro SNAME. Smacros are actually a syntactic _____ _____ _____ macro macro notation for a special class of macros, those that essentially treat the macro's argument as a list of arguments to be substituted into the body of the expression and then expanded in _____ _____ _____ macro macro line, rather than using the computational power of the macro to defmacro defmacro customize code. Thus they are a special case of defmacro. See also the BackQuote facility. For example: Lisp syntax: To make a substitution macro for FIRST ->CAR we could say (DM FIRST(X) (LIST 'CAR (CADR X))) Instead the following is clearer (DS FIRST(X) (CAR X)) 10.1.4. Function Definition in RLISP Syntax 10.1.4. Function Definition in RLISP Syntax 10.1.4. Function Definition in RLISP Syntax [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to chapter 3 or do a better job here. ???] chapter 3 or do a better job here. ???] chapter 3 or do a better job here. ???] In RLISP syntax, procedures are defined by using the Procedure construct, as discussed in Chapter 3. mode type PROCEDURE name(args); body; where mode is SYSLISP or LISP or SYMBOLIC and defaults to LISP, and type defaults to EXPR. Function Definition 7 February 1983 PSL Manual page 10.6 section 10.1 10.1.5. Low Level Function Definition Primitives 10.1.5. Low Level Function Definition Primitives 10.1.5. Low Level Function Definition Primitives PutD GetD PutD GetD The following functions are used especially by PutD and GetD, defined Eval Apply Eval Apply above in Section 10.1.2, and by Eval and Apply, defined in Chapter 11. FUnBoundP FUnBoundP _ __ _______ ____ (FUnBoundP U:id): boolean expr ________ _ Tests whether there is a definition in the function cell of U; returns NIL if so, T if not. Note: Undefined functions actually call a special function, UndefinedFunction Error FUnBoundP UndefinedFunction Error FUnBoundP UndefinedFunction, that invokes Error. FUnBoundP defines UndefinedFunction UndefinedFunction "unbound" to mean "calls UndefinedFunction". FLambdaLinkP FLambdaLinkP _ __ _______ ____ (FLambdaLinkP U:id): boolean expr _ Tests whether U is an interpreted function; return T if so, NIL if not. This is done by checking for the special code-address of lambdaLink lambdaLink the lambdaLink function, which calls the interpreter. FCodeP FCodeP _ __ _______ ____ (FCodeP U:id): boolean expr _ Tests whether U is a compiled function; returns T if so, NIL if not. MakeFUnBound MakeFUnBound _ __ ___ ____ (MakeFUnBound U:id): NIL expr _ Makes U an undefined function by planting a special call to an UndefinedFunction UndefinedFunction ________ _ error function, UndefinedFunction, in the function cell of U. MakeFLambdaLink MakeFLambdaLink _ __ ___ ____ (MakeFLambdaLink U:id): NIL expr _ Makes U an interpreted function by planting a special call to an lambdaLink lambdaLink interpreter support function (lambdaLink) function in the ________ _ function cell of U.} MakeFCode MakeFCode _ __ _ ____ _______ ___ ____ (MakeFCode U:id C:code-pointer): NIL expr _ Makes U a compiled function by planting a special JUMP to the _ code-address associated with C. GetFCodePointer GetFCodePointer _ __ ____ _______ ____ (GetFCodePointer U:id): code-pointer expr ____ _______ _ Gets the code-pointer for U. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.7 Code!-Number!-Of!-Arguments Code!-Number!-Of!-Arguments _ ____ _______ ___ _______ ____ (Code!-Number!-Of!-Arguments C:code-pointer): {NIL,integer} expr Some compiled functions have the argument number they expect _ stored in association with the codepointer C. This integer, or NIL is returned. _____ ____ _____ ____ _____ ____ [??? Should be extended for nexprs and declared exprs. ???] [??? Should be extended for nexprs and declared exprs. ???] [??? Should be extended for nexprs and declared exprs. ???] 10.1.6. Function Type Predicates 10.1.6. Function Type Predicates 10.1.6. Function Type Predicates See Section 2.7 for a discussion of the function types available in PSL. ExprP ExprP _ ___ _______ ____ (ExprP U:any): boolean expr ____ ____ ____ expr _ ____ _______ ______ __ expr Test if U is a code-pointer, lambda form, or an id with expr definition. FExprP FExprP _ ___ _______ ____ (FExprP U:any): boolean expr _____ _____ _____ fexpr _ __ fexpr Test if U is an id with fexpr definition. NExprP NExprP _ ___ _______ ____ (NExprP U:any): boolean expr _____ _____ _____ nexpr _ __ nexpr Test if U is an id with nexpr definition. MacroP MacroP _ ___ _______ ____ (MacroP U:any): boolean expr _____ _____ _____ macro _ __ macro Test if U is an id with macro definition. 10.2. Variables and Bindings 10.2. Variables and Bindings 10.2. Variables and Bindings __ Variables in PSL are ids, and associated values are usually stored in and __ retrieved from the value cell of this id. If variables appear as Prog Prog parameters in lambda expressions or in Prog's, the contents of the value cell are saved on a binding stack. A new value or NIL is stored in the Prog Prog value cell and the computation proceeds. On exit from the lambda or Prog the old value is restored. This is called the "shallow binding" model of LISP. It is chosen to permit compiled code to do binding efficiently. For even more efficiency, compiled code may eliminate the variable names and simply keep values in registers or a stack. The scope of a variable is the range over which the variable has a defined value. There are three different binding mechanisms in PSL. LOCAL BINDING Only compiled functions bind variables locally. Local Function Definition 7 February 1983 PSL Manual page 10.8 section 10.2 variables occur as formal parameters in lambda expressions Prog Prog and as LOCAL variables in Prog's. The binding occurs as a Prog Prog lambda expression is evaluated or as a Prog form is executed. The scope of a local variable is the body of the function in which it is defined. FLUID BINDING FLUID variables are GLOBAL in scope but may occur as formal Prog Prog parameters or Prog form variables. In interpreted functions, all formal parameters and LOCAL variables are considered to have FLUID binding until changed to LOCAL binding by compilation. A variable can be treated as a FLUID only by declaration. If FLUID variables are used as parameters or LOCALs they are rebound in such a way that the previous binding may be restored. All references to FLUID variables are to the currently active binding. Access to the values is by name, going to the value cell. GLOBAL BINDING GLOBAL variables may never be rebound. Access is to the value bound to the variable. The scope of a GLOBAL variable is universal. Variables declared GLOBAL may not appear as Prog Prog parameters in lambda expressions or as Prog form variables. A variable must be declared GLOBAL prior to its use as a GLOBAL variable since the default type for undeclared variables is FLUID. Note that the interpreter does not stop one from rebinding a global variable. The compiler will issue a warning in this situation. 10.2.1. Binding Type Declaration 10.2.1. Binding Type Declaration 10.2.1. Binding Type Declaration Fluid Fluid ______ __ ____ ___ ____ (Fluid IDLIST:id-list): NIL expr __ ______ __ The ids in IDLIST are declared as FLUID type variables (ids not ______ previously declared are initialized to NIL). Variables in IDLIST already declared FLUID are ignored. Changing a variable's type from GLOBAL to FLUID is not permissible and results in the error: ***** ID cannot be changed to FLUID Global Global ______ __ ____ ___ ____ (Global IDLIST:id-list): NIL expr __ ______ __ The ids of IDLIST are declared GLOBAL type variables. If an id has not been previously declared, it is initialized to NIL. Variables already declared GLOBAL are ignored. Changing a variable's type from FLUID to GLOBAL is not permissible and results in the error: ***** ID cannot be changed to GLOBAL PSL Manual 7 February 1983 Function Definition section 10.2 page 10.9 UnFluid UnFluid ______ __ ____ ___ ____ (UnFluid IDLIST:id-list): NIL expr ______ The variables in IDLIST which have been declared as FLUID variables are no longer considered as FLUID variables. Others are ignored. This affects only compiled functions, as free variables in interpreted functions are automatically considered FLUID (see [Griss 81]). 10.2.2. Binding Type Predicates 10.2.2. Binding Type Predicates 10.2.2. Binding Type Predicates FluidP FluidP _ ___ _______ ____ (FluidP U:any): boolean expr _ If U is FLUID (by declaration only), T is returned; otherwise, NIL is returned. GlobalP GlobalP _ ___ _______ ____ (GlobalP U:any): boolean expr _ If U has been declared GLOBAL or is the name of a defined function, T is returned; else NIL is returned. UnBoundP UnBoundP _ __ _______ ____ (UnBoundP U:id): boolean expr _ Tests whether U has no value. 10.3. User Binding Functions 10.3. User Binding Functions 10.3. User Binding Functions The following functions are available to build one's own interpreter functions that use the built-in FLUID binding mechanism, and interact well with the automatic unbinding that takes place during Throw and Error calls. [??? Are these correct when Environments are managed correctly ???] [??? Are these correct when Environments are managed correctly ???] [??? Are these correct when Environments are managed correctly ???] UnBindN UnBindN _ _______ _________ ____ (UnBindN N:integer): Undefined expr Prog Prog Used in user-defined interpreter functions (like Prog) to restore _ previous bindings to the last N values bound. LBind1 LBind1 ______ __ ___________ ___ _________ ____ (LBind1 IDNAME:id VALUETOBIND:any): Undefined expr ______ Support for LAMBDA-like binding. The current value of IDNAME is ___________ saved on the binding stack; the value of VALUETOBIND is then ______ bound to IDNAME. Function Definition 7 February 1983 PSL Manual page 10.10 section 10.3 PBind1 PBind1 ______ __ _________ ____ (PBind1 IDNAME:id): Undefined expr Prog Prog ______ Support for Prog. Binds NIL to IDNAME after saving value on the LBind1 LBind1 ______ binding stack. Essentially LBind1(IDNAME, NIL) 10.3.1. Funargs, Closures and Environments 10.3.1. Funargs, Closures and Environments 10.3.1. Funargs, Closures and Environments [??? Not yet connected to V3 ???] [??? Not yet connected to V3 ???] [??? Not yet connected to V3 ???] We have an experimental implementation of Baker's re-rooting funarg scheme [Baker 78], in which we always re-root upon binding; this permits efficient use of a GLOBAL value cell in the compiler. We are also considering implementing a restricted FUNARG or CLOSURE mechanism. The implementation we have does not work with the current version of PSL. This currently uses a module (ALTBIND) to redefine the fluid binding _ ____ mechanism of PSL to be functionally equivalent to an a-list binding scheme. However, it retains the principal advantage of the usual shallow binding scheme: variable lookup is extremely cheap -- just look in a value cell. Typical LISP programs currently run about 8% slower if using ALTBIND than with the initial shallow binding mechanism. It is expected that this 8% difference will go away presently. This mechanism will also probably become a standard part of PSL, rather than an add on module. To use ALTBIND simply do "load altbind;" ["(load altbind)" in LISP]. Existing code, both interpreted and compiled, should then commence using the new binding mechanism. The following functions are of most interest to the user: Closure Closure _ ____ ____ _____ (Closure U:form): form macro Function Function This is similar to Function, but returns a function closure Function Function including environment information, similar to Function in LISP Function* Eval Apply Function* Eval Apply 1.5 and Function* in LISP 1.6 and MACLISP. Eval and Apply are redefined to handle closures correctly. Currently only closures ____ ____ ____ expr expr of exprs are supported. EvalInEnvironment EvalInEnvironment _ ____ ___ ___ _______ ___ ____ (EvalInEnvironment F:form ENV:env-pointer): any expr ApplyInEnvironment ApplyInEnvironment __ ________ ____ ____ ____ ___ ___ _______ ___ ____ (ApplyInEnvironment FN:function ARGS:form-list ENV:env-pointer): any expr Eval Apply Eval Apply These are like Eval and Apply, but take an extra, last argument, and environment pointer. They perform their work in this environment instead of the current one. The following functions should be used with care: PSL Manual 7 February 1983 Function Definition section 10.3 page 10.11 CaptureEnvironment CaptureEnvironment ___ _______ ____ (CaptureEnvironment ): env-pointer expr Save the current bindings to be restored at some later point. CaptureEnvironment CaptureEnvironment This is best used inside a closure. CaptureEnvironment returns ____ an environment pointer. This object is normally a circular list structure, and so should not be printed. The same warning applies to closures, which contain environment pointers. It is hoped that environment pointers will be made a new LISP data type soon, and will be made to print safely, relaxing this restriction. [??? add true envpointer ???] [??? add true envpointer ???] [??? add true envpointer ???] RestoreEnvironment RestoreEnvironment ___ ___ _______ _________ ____ (RestoreEnvironment PTR:env-pointer): Undefined expr Restore old bindings to what they were in the captured ___ environment, PTR. ClearBindings ClearBindings _________ ____ (ClearBindings ): Undefined expr Restore bindings to top level, i.e strip the entire stack. For a demonstration of closures, do (in RLISP) `in "PU:altbind-tests.red";'. [??? Give a practical example ???] [??? Give a practical example ???] [??? Give a practical example ???] |
Added psl-1983/3-1/lpt/11-interp.lpt version [ad2f6c4498].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 The Interpreter section 11.0 page 11.1 CHAPTER 11 CHAPTER 11 CHAPTER 11 THE INTERPRETER THE INTERPRETER THE INTERPRETER 11.1. Evaluator Functions Eval and Apply. . . . . . . . 11.1 11.2. Support Functions for Eval and Apply . . . . . . . 11.5 11.3. Special Evaluator Functions, Quote, and Function . . . 11.6 11.4. Support Functions for Macro Evaluation . . . . . . 11.6 11.1. Evaluator Functions Eval and Apply 11.1. Evaluator Functions Eval and Apply 11.1. Evaluator Functions Eval and Apply The PSL evaluator uses an identifier's function cell (SYMFNC(id#) which is directly accessible from kernel functions only) to access the address of the code for executing the identifier's function definition, as described in chapter 10. The function cell contains either the entry address of a compiled function, or the address of a support routine that either signals an undefined function or calls the lambda interpreter. The PSL model of a function call is to place the arguments (after treatment appropriate to function type) in "registers", and then to jump to or call the code in the function cell. ____ Expressions which can be legally evaluated are called forms. They are restricted S-expressions: ____ __ form ::= id ________ | constant __ ____ ____ | (id form ... form) ___ | (special . any) % Special cases: COND, PROG, etc. _____ _____ _____ _____ _____ _____ fexpr macro fexpr macro % usually fexprs or macros. Eval Apply Eval Apply ____ The definitions of Eval and Apply may clarify which expressions are forms. Eval Apply ContinuableError Eval Apply ContinuableError In Eval, Apply, and the support functions below, ContinuableError is used ______ to indicate malformed lambda expressions, undefined functions or mismatched argument numbers; the user is permitted to correct the offending expression Break Break or to define a missing function inside a Break loop. Eval Apply Eval Apply The functions Eval and Apply are central to the PSL interpreter. Since their efficiency is important, some of the support functions they use are LambdaApply LambdaEvalApply CodeApply LambdaApply LambdaEvalApply CodeApply hand-coded in LAP. The functions LambdaApply, LambdaEvalApply, CodeApply, CodeEvalApply IDApply1 Eval Apply CodeEvalApply IDApply1 Eval Apply CodeEvalApply, and IDApply1 are support functions for Eval and Apply. CodeApply CodeEvalApply IDApply1 CodeApply CodeEvalApply IDApply1 CodeApply and CodeEvalApply are coded in LAP. IDApply1 is handled by the compiler. The Interpreter 7 February 1983 PSL Manual page 11.2 section 11.1 Eval Eval _ ____ ___ ____ (Eval U:form): any expr _ The value of the form U is computed. The following is an approximation of the real code, leaving out some implementation details. PSL Manual 7 February 1983 The Interpreter section 11.1 page 11.3 (DE EVAL (U) (PROG (FN) (COND ((IDP U) (RETURN (VALUECELL U)))) % ValueCell returns the contents of Value Cell if ID % BoundP, else signals unbound error. (COND ((NOT (PAIRP U)) (RETURN U))) % This is a "constant" which EVAL's to itself (COND ((EQCAR (CAR U) 'LAMBDA) (RETURN (LAMBDAEVALAPPLY (CAR U) (CDR U))))) % LambdaEvalApply applies the lambda- expression Car U % list containing the evaluation of each argument in C (COND ((CODEP (CAR U)) (RETURN (CODEEVALAPPLY (CAR U) (CDR U))))) % CodeEvalApply applies the function with code-pointer % to the list containing the evaluation of each argume % Cdr U. (COND ((NOT (IDP (CAR U))) (RETURN % permit user to correct U, and reevaluate. (CONTINUABLEERROR 1101 "Ill-formed expression in EVAL" U)))) (SETQ FN (GETD (CAR U))) (COND ((NULL FN) % user might define missing function and retry (RETURN (CONTINUABLEERROR 1001 "Undefined function EVAL (COND ((EQ (CAR FN) 'EXPR) (RETURN (COND ((CODEP (CDR FN)) % CodeEvalApply applies the function with % codepointer Cdr FN to the list containing % evaluation of each argument in Cdr U. (CODEEVALAPPLY (CDR FN) (CDR U))) (T (LAMBDAEVALAPPLY (CDR FN) (CDR U))))))) % LambdaEvalApply applies the lambda-expression Cdr FN The Interpreter 7 February 1983 PSL Manual page 11.4 section 11.1 % list containing the evaluation of each argument in C (COND ((EQ (CAR FN) 'FEXPR) % IDApply1 applies the fexpr Car U to the list of % unevaluated arguments. (RETURN (IDAPPLY1 (CDR U) (CAR U)))) ((EQ (CAR FN) 'MACRO) % IDApply1 first expands the macro call U and then % evaluates the result. (RETURN (EVAL (IDAPPLY1 U (CAR U))))) ((EQ (CAR FN) 'NEXPR) % IDApply1 applies the nexpr Car U to the list obt % by evaluating the arguments in Cdr U. (RETURN (IDAPPLY1 (EVLIS (CDR U)) (CAR U))))))) Apply Apply __ __ ________ ____ ____ ____ ___ ____ (Apply FN:{id,function} ARGS:form-list): any expr Apply Apply Apply allows one to make an indirect function call. It returns __ ____ the value of FN with actual parameters ARGS. The actual ____ parameters in ARGS are already in the form required for binding __ to the formal parameters of FN. PSL permits the application of _____ ______ _____ _____ ______ _____ _____ ______ _____ macro nexprs fexpr Apply Cdr macro nexprs fexpr Apply Cdr macros, nexprs and fexprs; the effect is the same as (Apply (Cdr GetD GetD __ ____ (GetD FN)) ARGS); i.e. no fix-up is done to quote arguments, etc. Apply List Apply List as in some LISPs. A call to Apply using List on the second Apply List Apply List argument [e.g. (Apply F (List X Y))] is compiled so that the ____ list is not actually constructed. The following is an approximation of the real code, leaving out implementation details. PSL Manual 7 February 1983 The Interpreter section 11.1 page 11.5 (DE APPLY (FN ARGS) (PROG (DEFN) (COND ((CODEP FN) % Spread the ARGS into the registers and transfer % entry point of the function. (RETURN (CODEAPPLY FN ARGS))) ((EQCAR FN 'LAMBDA) % Bind the actual parameters in ARGS to the formal % parameters of the lambda expression If the two l % are not of equal length then signal % (CONTINUABLEERROR 1204 % "Number of parameters do not match" % (CONS FN ARGS)) (RETURN (LAMBDAAPPLY FN ARGS))) ((NOT (IDP FN)) (RETURN (CONTINUABLEERROR 1104 "Ill-formed function in APPLY" (CONS FN ARG)))) ((NULL (SETQ DEFN (GETD FN))) (RETURN (CONTINUABLEERROR 1004 "Undefined function in Apply" (CONS FN ARGS)))) (T % Do EXPR's, NEXPR's, FEXPR's and MACRO's alike, a % EXPR's (RETURN (APPLY (CDR DEFN) ARGS)))))) [??? Instead, could check for specific function types in Apply ???] [??? Instead, could check for specific function types in Apply ???] [??? Instead, could check for specific function types in Apply ???] 11.2. Support Functions for Eval and Apply 11.2. Support Functions for Eval and Apply 11.2. Support Functions for Eval and Apply EvLis EvLis _ ___ ____ ___ ____ ____ (EvLis U:any-list): any-list expr EvLis EvLis ____ _ EvLis returns a list of the evaluation of each element of U. LambdaApply LambdaApply __ ______ _ ___ ____ ___ ____ (LambdaApply FN:lambda, U:any-list): any expr __ ______ ______ Checks that FN is a legal lambda, binds the formals of the lambda LBind1 EvProgN LBind1 _ EvProgN using LBind1 to the arguments in U, and then uses EvProgN to ______ evaluate the forms in the lambda body. Finally the formals are UnBindN UnBindN unbound, using UnBindN, and the result returned. The Interpreter 7 February 1983 PSL Manual page 11.6 section 11.2 LambdaEvalApply LambdaEvalApply __ ______ _ ____ ____ ___ ____ (LambdaEvalApply FN:lambda, U:form-list): any expr LambdaApply EvLis LambdaApply __ EvLis _ Essentially LambdaApply(FN,EvLis(U)), though done more efficiently. CodeApply CodeApply __ ____ _______ _ ___ ____ ___ ____ (CodeApply FN:code-pointer, U:any-list): any expr _ Efficiently spreads the arguments in U into the "registers", and __ then transfers to the starting address referred to by FN CodeEvalApply CodeEvalApply __ ____ _______ _ ___ ____ ___ ____ (CodeEvalApply FN:code-pointer, U:any-list): any expr CodeApply EvLis CodeApply __ EvLis _ Essentially CodeApply(FN,EvLis(U)), though more efficient. The following entry points are used to get efficient calls on named functions, and are open compiled. IdApply0 IdApply0 __ __ ___ ____ (IdApply0 FN:id): any expr IdApply1 IdApply1 __ ____ __ __ ___ ____ (IdApply1 A1:form, FN:id): any expr IdApply2 IdApply2 __ ____ __ ____ __ __ ___ ____ (IdApply2 A1:form, A2:form, FN:id): any expr IdApply3 IdApply3 __ ____ __ ____ __ ____ __ __ ___ ____ (IdApply3 A1:form, A2:form, A3:form, FN:id): any expr IdApply4 IdApply4 __ ____ __ ____ __ ____ __ ____ __ __ ___ ____ (IdApply4 A1:form, A2:form, A3:form, A4:form, FN:id): any expr EvProgN EvProgN _ ____ ____ ___ ____ (EvProgN U:form-list): any expr _ Evaluates each form in U in turn, returning the value of the ProgN ProgN last. Used for various implied ProgNs. 11.3. Special Evaluator Functions, Quote, and Function 11.3. Special Evaluator Functions, Quote, and Function 11.3. Special Evaluator Functions, Quote, and Function Quote Quote _ ___ ___ _____ (Quote U:any): any fexpr Eval _ Eval Returns U. Thus the argument is not evaluated by Eval. PSL Manual 7 February 1983 The Interpreter section 11.3 page 11.7 MkQuote MkQuote _ ___ ____ ____ (MkQuote U:any): list expr MkQuote List MkQuote _ List (MkQuote U) returns (List 'QUOTE U) Function Function __ ________ ________ _____ (Function FN:function): function fexpr __ __ The function FN is to be passed to another function. If FN is to have side effects its free variables must be FLUID or GLOBAL. Function Quote Function Quote Function is like Quote but its argument may be affected by compilation. [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] Closure Closure See also the discussion of Closure and related functions in Section 10.3. 11.4. Support Functions for Macro Evaluation 11.4. Support Functions for Macro Evaluation 11.4. Support Functions for Macro Evaluation Expand Expand _ ____ __ ________ ____ ____ (Expand L:list, FN:function): list expr __ FN is a defined function of two arguments to be used in the _____ _____ _____ macro Expand macro Expand ____ expansion of a macro. Expand returns a list in the form: (FN L[0] (FN L[1] ... (FN L[n-1] L[n]) ... )) _ "n" is the number of elements in L, L[i] is the i'th element of _ L. (DE EXPAND (L FN) (COND ((NULL (CDR L)) (CAR L)) (T (LIST FN (CAR L) (EXPAND (CDR L) FN))))) [??? Add RobustExpand (sure!) (document) ???] [??? Add RobustExpand (sure!) (document) ???] [??? Add RobustExpand (sure!) (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] |
Added psl-1983/3-1/lpt/12-io.lpt version [e7b26fbeea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Input and Output section 12.0 page 12.1 CHAPTER 12 CHAPTER 12 CHAPTER 12 INPUT AND OUTPUT INPUT AND OUTPUT INPUT AND OUTPUT 12.1. Introduction . . . . . . . . . . . . . . . 12.1 12.2. The Underlying Primitives for Input and Output. . . . 12.1 12.3. Opening, Closing, and Selecting Channels. . . . . . 12.5 12.4. Functions for Printing. . . . . . . . . . . . 12.8 12.5. Functions for Reading . . . . . . . . . . . . 12.16 12.5.1. Reading S-Expression . . . . . . . . . . 12.16 12.5.2. Reading Files into PSL . . . . . . . . . 12.17 12.5.3. Reading Single Characters . . . . . . . . 12.20 12.5.4. Reading Tokens . . . . . . . . . . . . 12.21 12.5.5. Read Macros . . . . . . . . . . . . . 12.30 12.6. Scan Table Utility Functions. . . . . . . . . . 12.31 12.7. I/O to and from Lists and Strings . . . . . . . . 12.32 12.8. Example of Simple I/O in PSL. . . . . . . . . . 12.34 12.1. Introduction 12.1. Introduction 12.1. Introduction Most LISP programs are written with no sophisticated I/O, so this chapter may be skimmed by those with simple I/O requirements. Section 12.8 contains an example showing the use of some I/O functions. This should help the beginning PSL user get started. Sections 12.5 and 12.6 deal extensively with customizing the scanner and reader, which is of interest only to the sophisticated user. 12.2. The Underlying Primitives for Input and Output 12.2. The Underlying Primitives for Input and Output 12.2. The Underlying Primitives for Input and Output All input and output functions are implemented in terms of operations on 1 _______ "channels". A channel is just a small integer which has 3 functions and some other information associated with it. The three functions are: a. A reading function, which is called with the channel as its _______ argument and returns the integer ASCII value of the next _______________ 1 The range of channel numbers is from 0 to MaxChannels, where MaxChannels is a system-dependent constant, currently 31, defined in IO-DATA.RED. MaxChannels is a WCONST, and is not available for use at runtime. Input and Output 7 February 1983 PSL Manual page 12.2 section 12.2 character of the input stream. If the channel is for writing WriteOnlyChannel WriteOnlyChannel only, this function is WriteOnlyChannel. If the channel has not ChannelNotOpen ChannelNotOpen been opened, this function is ChannelNotOpen. The reading function is responsible for echoing characters if the flag WriteChar WriteChar !*ECHO is T. It should use the function WriteChar to echo the character. It may not be appropriate for a read function to echo characters. For example, the "disk" reading function does Compress Compress echoing, while the reader used to implement the Compress function does not. The read function must also be concerned with the handling of ends of "files" (actually, ends of channels) and ends of lines. It should return the ASCII code for an end of file character (system dependent) when reaching the end of a channel. It should return the ASCII code for a line feed character to indicate an end of line (or "newline"). This may require that the ASCII code for carriage return be ignored when read, not returned. b. A writing function, which is called with the channel as its _______ first argument and the integer ASCII value of the character to write as its second argument. If the channel is for reading ReadOnlyChannel ReadOnlyChannel only, this function is ReadOnlyChannel. If the channel has not ChannelNotOpen ChannelNotOpen been opened, this function is ChannelNotOpen. c. A closing function, which is called with the channel as its argument and performs any action necessary for the graceful termination of input and/or output operations to that channel. ChannelNotOpen ChannelNotOpen If the channel is not open, this function is ChannelNotOpen. The other information associated with a channel includes the current Posn Posn position in the output line (used by Posn), the maximum line length allowed LineLength LineLength (used by LineLength and the printing functions), the single character input backup buffer (used by the token scanner), and other system-dependent information. Ordinarily, the user need not be aware of the existence of this mechanism. However, because of its generality, it is possible to implement operations other than just reading from and writing to files using it. In Explode Compress Explode Compress particular, the LISP functions Explode and Compress are performed by ____ ____ writing to a list and reading from a list, respectively (on channels 3 and 4 respectively). Ordinarily, user interaction with the system is done by reading from the standard input channel and writing to the standard output channel. These are 0 and 1 respectively, to which the GLOBAL variables STDIN!* and STDOUT!* are bound. These channels usually refer to the user's terminal, and cannot be closed. Other files are accessed by calling the function Open Open Open, which returns a channel. Most functions which perform input and output come in two forms, one which takes a channel as its first argument, Rds Rds and one which uses the "currently selected channel". The functions Rds and PSL Manual 7 February 1983 Input and Output section 12.2 page 12.3 Wrs Wrs Wrs are used to change the currently selected input and output channels. The GLOBAL variables IN!* and OUT!* are bound to these channels. GLOBAL variables containing information about channels are listed below. __________ ______ IN!* [Initially: 0] global Contains the currently selected input channel. This is changed Rds Rds by the function Rds. __________ ______ OUT!* [Initially: 1] global Contains the currently selected output channel. This is changed Wrs Wrs by the function Wrs. __________ ______ STDIN!* [Initially: 0] global The standard input channel. __________ ______ STDOUT!* [Initially: 1] global The standard output channel. __________ ______ BREAKIN!* [Initially: NIL] global BREAK BREAK The channel from which the BREAK loop gets its input. It has been set to default to STDIN!*, but may have to be changed on some systems with buffered-IO. __________ ______ BREAKOUT!* [Initially: NIL] global BREAK BREAK The channel to which the BREAK loop sends its output. It has been set to default to STDOUT!*, but may have to be changed on some systems with buffered-IO. __________ ______ HELPIN!* [Initially: NIL] global Help Help The channel used for input by the Help mechanism. __________ ______ HELPOUT!* [Initially: NIL] global Help Help The channel used for output by the Help mechanism. Input and Output 7 February 1983 PSL Manual page 12.4 section 12.2 __________ ______ ERROUT!* [Initially: 1] global ErrorPrintF ErrorPrintF The channel used by the ErrorPrintF. __________ ______ PROMPTSTRING!* [Initially: "lisp>"] global Displayed as a prompt when any input is taken from TTY. Thus prompts should not be directly printed. Instead the value should be bound to PROMPTSTRING!*. 12.3. Opening, Closing, and Selecting Channels 12.3. Opening, Closing, and Selecting Channels 12.3. Opening, Closing, and Selecting Channels Open Open ________ ______ __________ __ _______ __ _______ ____ (Open FILENAME:string ACCESSTYPE:id): CHANNEL:io-channel expr Eq __________ Eq If ACCESSTYPE is Eq to INPUT or OUTPUT, an attempt is made to ________ access the system-dependent FILENAME for reading or writing. If the attempt is unsuccessful, an error is generated; otherwise a free channel is returned and initialized to the default conditions for ordinary file input or output. Eq __________ Eq If ACCESSTYPE is Eq to SPECIAL and the GLOBAL variables SPECIALREADFUNCTION!*, SPECIALWRITEFUNCTION!*, and __ SPECIALCLOSEFUNCTION!* are bound to ids, then a free channel is returned and its associated functions are set to the values of these variables. Other non system-dependent status is set to default conditions, which can later be overridden. The functions ReadOnlyChannel WriteOnlyChannel ReadOnlyChannel WriteOnlyChannel ReadOnlyChannel and WriteOnlyChannel are available as error ________ handlers. The parameter FILENAME is used only if an error occurs. [??? We should replace these globals and SPECIAL option by a [??? We should replace these globals and SPECIAL option by a [??? We should replace these globals and SPECIAL option by a (SPECIALOPEN Readfunction writefunction closefunction) call (SPECIALOPEN Readfunction writefunction closefunction) call (SPECIALOPEN Readfunction writefunction closefunction) call ???] ???] ???] If none of these conditions hold, a file is not available, or there are no free channels, an error is generated. ***** Unknown access type ***** Improperly set-up special IO open call ***** File not found ***** No free channels FileP FileP One can use FileP to find out whether a file exists. PSL Manual 7 February 1983 Input and Output section 12.3 page 12.5 FileP FileP ____ ______ _______ ____ (FileP NAME:string): boolean expr ____ This function will return T if file NAME can be opened, and NIL if not, e.g. if it does not exist. Close Close _______ __ _______ __ _______ ____ (Close CHANNEL:io-channel): io-channel expr _______ The closing function associated with CHANNEL is called, with _______ _______ CHANNEL as its argument. If it is illegal to close CHANNEL, if _______ _______ CHANNEL is not open, or if CHANNEL is associated with a file and the file cannot be closed by the operating system, this function _______ generates an error. Otherwise, CHANNEL is marked as free and is returned. Shut Shut _ ______ ____ ________ _____ (Shut [L:string]): None Returned macro Shut _ Shut Closes the output files in the list L. Note that Shut takes file Close Close __ _______ names as arguments, while Close takes an io-channel. The RLISP IN IN IN function maintains a stack of file-name . io-channel shut shut associations for this purpose. Thus a shut will also correctly select the previous file for further output. EvShut EvShut _ ______ ____ ____ ________ ____ (EvShut L:string-list): none Returned expr Shut Shut Does the same as Shut but evaluates its arguments. Rds Rds _______ __ _______ ___ __ _______ ____ (Rds {CHANNEL:io-channel, NIL}): io-channel expr Rds Rds Rds sets IN!* to the value of its argument, and returns the previous value of IN!*. In addition, if SPECIALRDSACTION!* is non-NIL, it should be a function of 2 arguments, which is called _______ _______ with the old CHANNEL as its first argument and the new CHANNEL as Rds Rds Rds Rds its second argument. Rds(NIL) does the same as Rds(STDIN!*). Wrs Wrs _______ __ _______ ___ __ _______ ____ (Wrs {CHANNEL:io-channel, NIL}): io-channel expr Wrs Wrs Wrs sets OUT!* to the value of its argument and returns the previous value of OUT!*. In addition, if SPECIALWRSACTION!* is non-NIL, it should be a function of 2 arguments, which is called _______ _______ with the old CHANNEL as its first argument and the new CHANNEL as Wrs Wrs Wrs Wrs its second argument. Wrs(NIL) does the same as Wrs(STDOUT!*). Out Out _ ______ ____ ________ _____ (Out U:string): None Returned macro _ Opens file U for output, redirecting standard output. Note that Out Wrs Out ______ Wrs __ _______ Out takes a string as an argument, while Wrs takes an io-channel. Input and Output 7 February 1983 PSL Manual page 12.6 section 12.3 EvOut EvOut _ ______ ____ ____ ________ ____ (EvOut L:string-list): None Returned expr _ L is a list containing one file name which must be a string. EvOut Out EvOut Out EvOut is the called by Out after evaluating its argument. The reading and writing functions come in two flavors: those that read or RDS WRS RDS WRS write to the current channel, as set by a previous RDS or WRS into IN!* or OUT!*, and those that explicitly designate the desired input or output Channel Channel channel. The latter typically have a Channel as part of their name. ________ The following GLOBALs are used by the functions in this section. __________ ______ SPECIALCLOSEFUNCTION!* [Initially: NIL] global __________ ______ SPECIALRDSACTION!* [Initially: NIL] global __________ ______ SPECIALREADFUNCTION!* [Initially: NIL] global __________ ______ SPECIALWRITEFUNCTION!* [Initially: NIL] global __________ ______ SPECIALWRSACTION!* [Initially: NIL] global 12.4. Functions for Printing 12.4. Functions for Printing 12.4. Functions for Printing ChannelWriteChar ChannelWriteChar _______ __ _______ __ _________ _________ ____ (ChannelWriteChar CHANNEL:io-channel CH:character): character expr _______ Write one character to CHANNEL. All output is defined in terms __ of this function. If CH is equal to char EOL (ASCII LF, 8#12) _______ the line counter POSN associated with CHANNEL is set to zero. Otherwise, it is increased by one. The writing function _______ _______ __ associated with CHANNEL is called with CHANNEL and CH as its arguments. WriteChar WriteChar __ _________ _________ ____ (WriteChar CH:character): character expr Write single character to current output. (de WRITECHAR (CH) (CHANNELWRITECHAR OUT!* CH)) PSL Manual 7 February 1983 Input and Output section 12.4 page 12.7 ChannelPrin1 ChannelPrin1 ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrin1 CHAN:io-channel ITM:any): ITM:any expr ChannelPrin1 ChannelPrin1 ChannelPrin1 is the basic LISP printing function. For well-formed, non-circular (non-self-referential) structures, the Read Read result can be parsed by the function Read. ______ - Strings are printed surrounded by double quotes ("). __ - Delimiters inside ids are preceded by the escape character (!). _____ - Floats are printed as {-}nnn.nnn{E{-}nn}. _______ - Integers are printed as {-}nnn, unless the value of OUTPUTBASE!* is not 10, in which case they are printed as {-}r#nnn; r is the value of OutPutBase!*. ____ - Pairs are printed in list-notation. For example, (a . (b . c)) is printed as (a b . c) while (a . (b . (c . NIL))) is printed as (a b c) ______ ______ - Vectors are printed in vector-notation; a vector of three elements a, b, and c is printed as [a b c]. Read Read The following items can be printed, but cannot be parsed by Read. ____ _______ - code-pointers are printed as ________ _____ _____ _______ _____ _______ #<Code argument-count octal-address>. where octal-address is the octal machine address of the entry point of the code Input and Output 7 February 1983 PSL Manual page 12.8 section 12.4 ______ ________ _____ vector, and argument-count is the number of arguments that the code takes. The argument count cannot always be determined, in which case nothing is printed for the ________ _____ argument-count. - Anything else is printed as #<Unknown:nnnn>, where nnnn is the octal value found in the argument register. Such items are not legal LISP entities and may cause garbage collector errors if they are found in the heap. Prin1 Prin1 ___ ___ ___ ___ ____ (Prin1 ITM:any): ITM:any expr ErrPrin ErrPrin _ ___ ____ ________ ____ (ErrPrin U:any): None Returned expr Prin1 Prin1 _ Prin1 with special quotes to highlight U. ChannelPrin2 ChannelPrin2 ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrin2 CHAN:io-channel ITM:any): ITM:any expr ChannelPrin2 ChannelPrin1 ChannelPrin2 ChannelPrin1 ______ ChannelPrin2 is similar to ChannelPrin1, except that strings are printed without the surrounding double quotes, and delimiters __ within ids are not preceded by the escape character. Prin2 Prin2 ___ ___ ___ ___ ____ (Prin2 ITM:any): ITM:any expr ChannelPrinC ChannelPrinC ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrinC CHAN:io-channel ITM:any): ITM:any expr ChannelPrint2 ChannelPrint2 Same function as ChannelPrint2. PrinC PrinC ___ ___ ___ ___ ____ (PrinC ITM:any): ITM:any expr Prin2 Prin2 Same function as Prin2. ChannelPrint ChannelPrint ____ __ _______ _ ___ _ ___ ____ (ChannelPrint CHAN:io-channel U:any): U:any expr ChannelPrin1 _ ChannelPrin1 Display U using ChannelPrin1 and terminate line using ChannelTerpri ChannelTerpri ChannelTerpri. Print Print _ ___ _ ___ ____ (Print U:any): U:any expr ChannelPrint ChannelPrint _ ChannelPrint U to current output channel, OUT!*. PSL Manual 7 February 1983 Input and Output section 12.4 page 12.9 ChannelPrintF ChannelPrintF ____ __ _______ ______ ______ ____ ___ ___ ____ (ChannelPrintF CHAN:io-channel FORMAT:string [ARGS:any]): NIL expr ChannelPrintF ChannelPrintF ChannelPrintF is a simple routine for formatted printing, similar ______ to the function with the same name in the C language[22]. FORMAT ______ is either a LISP or SYSLISP string, which is printed on the currently selected output channel. However, if a % is ______ encountered in the string, the character following it is a formatting directive, used to interpret and print the other ChannelPrintF ChannelPrintF arguments to ChannelPrintF in order. The following format characters are currently supported: - For SYSLISP arguments, use: _______ %d print the next argument as a decimal integer _______ %o print the next argument as an octal integer _______ %x print the next argument as a hexadecimal integer %c print the next argument as a single character ______ %s print the next argument as a string - For LISP tagged items, use: %p print the next argument as a LISP item, using Prin1 Prin1 Prin1 %w print the next argument as a LISP item, using Prin2 Prin2 Prin2 %r print the next argument as a LISP item, using ErrPrin Prin2 Prin1 Prin2 ErrPrin Prin2 Prin1 Prin2 ErrPrin (Ordinarily Prin2 "`"; Prin1 Arg; Prin2 "'" ) %l same as %w, except lists are printed without top level parens; NIL is printed as a blank %e eval the next argument for side-effect -- most eval eval useful if the thing evaled does some printing - Control formats: %b take next argument as an integer and print that many blanks %f "fresh-line", print an end-of-line character if not at the beginning of the output line (does not use a matching argument) %n print end-of-line character (does not use a matching argument) %t take the next argument as an integer, and ChannelTab ChannelTab ChannelTab to that position Input and Output 7 February 1983 PSL Manual page 12.10 section 12.4 If the character following % is not either one of the above or another %, it causes an error. Thus, to include a % in the format to be printed, use %%. There is no checking for correspondence between the number of ______ arguments the FORMAT expects and the number given. If the number ______ given is less than the number in the FORMAT string, then garbage will be inserted for the missing arguments. If the number given ______ is greater than the number in the FORMAT string, then the extra ones are ignored. PrintF PrintF ______ ______ ____ ___ ___ ____ (PrintF FORMAT:string [ARGS:any]): NIL expr ChannelPrintF ChannelPrintF ChannelPrintF to the current output channel, OUT!*. ErrorPrintF ErrorPrintF ______ ______ ____ ___ ___ ____ (ErrorPrintF FORMAT:string [ARGS:any]): NIL expr ErrorPrintF PrintF ErrorPrintF PrintF ErrorPrintF is similar to PrintF, except that instead of using the currently selected output channel, ERROUT!* is used. Also, an end-of-line character is always printed after the message, and an end-of-line character is printed before the message if the line position of ERROUT!* is greater than zero. ChannelTerPri ChannelTerPri ____ __ _______ ___ ____ (ChannelTerPri CHAN:io-channel): NIL expr ____ Terminate OUTPUT line on channel CHAN, and reset the POSN counter to 0. TerPri TerPri ___ ____ (TerPri ): NIL expr Terminate current OUTPUT line, and reset the POSN counter to 0. ChannelEject ChannelEject ____ __ _______ ___ ____ (ChannelEject CHAN:io-channel): NIL expr ____ Skip to top of next output page on channel CHAN. Eject Eject ___ ____ (Eject ): NIL expr Skip to top of next output page on current output channel. ChannelPosn ChannelPosn ____ __ _______ _______ ____ (ChannelPosn CHAN:io-channel): integer expr Returns number of characters output on this line (i.e. POSN counter since last Terpri) on this channel. PSL Manual 7 February 1983 Input and Output section 12.4 page 12.11 Posn Posn _______ ____ (Posn ): integer expr Returns number of characters output on this line (i.e. POSN counter since last Terpri) ChannelLPosn ChannelLPosn ____ __ _______ _______ ____ (ChannelLPosn CHAN:io-channel): integer expr LPosn LPosn Returns number of lines output on this page (i.e. LPosn counter since last Eject) on this channel. LPosn LPosn _______ ____ (LPosn ): integer expr LPosn LPosn Returns number of lines output on this page (i.e. LPosn counter since last Eject). ChannelLineLength ChannelLineLength ____ __ _______ ___ _______ ___ _______ ____ (ChannelLineLength CHAN:io-channel LEN:{integer, NIL}): integer expr ____ _______ Set maximum output line length on CHAN if a positive integer, returning previous value. If NIL just return previous value. Terpri Terpri Controls the insertion of automatic Terpri's. LineLength LineLength ___ _______ ___ _______ ____ (LineLength LEN:{integer, NIL}): integer expr Set maximum output line length on current channel OUT!* if a _______ positive integer, returning previous value. If NIL just return Terpri Terpri previous value. Controls the insertion of automatic Terpri's. RPrint RPrint _ ____ ___ ____ (RPrint U:form): NIL expr Print in RLISP format. Autoloading. PrettyPrint PrettyPrint _ ____ _ ____ (PrettyPrint U:form): U expr _ Prettyprints U. Autoloading. Prin2L Prin2L _ ___ _ ____ (Prin2L L:any): L expr Prin2 Prin2 ____ Prin2, except that a list is printed without the top level parens. ChannelSpaces ChannelSpaces ____ __ _______ _ _______ ___ ____ (ChannelSpaces CHAN:io-channel N:integer): NIL expr ChannelPrin2 ChannelPrin2 _ _ ChannelPrin2 N spaces. Will continue across multiple lines if N is greater than the number of positions in the output buffer. Input and Output 7 February 1983 PSL Manual page 12.12 section 12.4 POSN LINELENGTH POSN LINELENGTH (See POSN and LINELENGTH) Spaces Spaces _ _______ ___ ____ (Spaces N:integer): NIL expr Prin2 Prin2 _ Prin2 N spaces. ChannelPrin2T ChannelPrin2T ____ __ _______ _ ___ ___ ____ (ChannelPrin2T CHAN:io-channel X:any): any expr ChannelPrin2 _ ChannelPrin2 Output X using ChannelPrin2 and terminate line with ChannelTerpri ChannelTerpri ChannelTerpri. Prin2T Prin2T _ ___ ___ ____ (Prin2T X:any): any expr ChannelPrin2T ChannelPrin2T _ ChannelPrin2T X to the current output channel, OUT!*. ChannelTab ChannelTab ____ __ _______ _ _______ ___ ____ (ChannelTab CHAN:io-channel N:integer): NIL expr _ ____ Move to position N on channel CHAN, emitting spaces as needed. ChannelTerPri ChannelTerPri _ Calls ChannelTerPri if past column N. Tab Tab _ _______ ___ ____ (Tab N:integer): NIL expr TerPri _ TerPri Move to position N, emitting spaces as needed. TerPri() if past _ column N. _________ __________ The fluid variables PRINLEVEL and PRINLENGTH allow the user to control how deep the printer will print and how many elements at a given level the printer will print. This is useful for debugging or dealing large or deep Prin1 Prin2 PrinC Print Prin1 Prin2 PrinC Print objects. These variables affect the functions Prin1, Prin2, PrinC, Print, PrintF PrintF and PrintF (and the corresponding Channel functions). The documentation of these variables is from the Common Lisp Manual. __________ ______ PRINLEVEL [Initially: Nil] global Controls how many levels deep a nested data object will print. _________ If PRINLEVEL is NIL, then no control is exercised. Otherwise the value should be an integer, indicating the maximum level to be printed. An object to be printed is at level 0. __________ ______ PRINLENGTH [Initially: Nil] global Controls how many elements at a given level are printed. A value of NIL indicates that there be no limit to the number of __________ components printed. Otherwise the value of PRINLENGTH should be an integer. PSL Manual 7 February 1983 Input and Output section 12.5 page 12.13 12.5. Functions for Reading 12.5. Functions for Reading 12.5. Functions for Reading 12.5.1. Reading S-Expression 12.5.1. Reading S-Expression 12.5.1. Reading S-Expression ChannelRead ChannelRead ____ __ _______ ___ ____ (ChannelRead CHAN:io-channel): any expr ____ Reads and returns the next S-expression from input channel CHAN. Valid input forms are: vector-notation, pair-notation, list- ______ ____ _______ ______ __________ notation, numbers, code-pointers, strings, and identifiers. Intern __________ Intern Identifiers are interned (see the Intern function in Chapter 6), ChannelRead ChannelRead unless the FLUID variable !*COMPRESSING is non-NIL. ChannelRead returns the value of the global variable !$EOF!$ when the end of the currently selected input channel is reached. ChannelRead ChannelReadToken ChannelRead ChannelReadToken ChannelRead uses the ChannelReadToken function, with tokens scanned according to the "Lisp scan table". The user can define similar read functions for use with other scan tables. ____ _____ ____ _____ ____ _____ ChannelRead Read macro ChannelRead Read macro ChannelRead uses the Read macro mechanism to do S-expression parsing. See section 12.5.5 for more information on read macros and how to add extensions. The following read macros are defined initially: ( Starts a scan collecting S-expressions according to ____ ____ list or dot notation until terminated by a ). A pair ____ or list is returned. [ Starts a scan collecting S-expressions according to ______ vector notation until terminated by a ]. A vector is returned. Read Read ' Calls Read to get an S-expression, x, and then returns Quote Quote the list (Quote x). !$EOF!$ Generates an error when still inside an S-expression: ***** Unexpected EOF while reading on channel . Otherwise !$EOF!$ is returned. Read Read ___ ____ (Read ): any expr Reads and returns an S-expression from the current input channel. ChannelRead ChannelRead That is, it does a ChannelRead(IN!*). Input and Output 7 February 1983 PSL Manual page 12.14 section 12.5 12.5.2. Reading Files into PSL 12.5.2. Reading Files into PSL 12.5.2. Reading Files into PSL The following procedures are used to read complete files into PSL, by Open Open first calling Open, and then looping until end of file. The effect is similar to what would happen if the file were typed into PSL. Recall that file names are strings, and therefore one needs string-quotes (") around file names. File names may be given using full system dependent file name conventions, including directories and sub-directories, "links" and "logical-device-names", as appropriate on the specific system. __________ ______ !*ECHO [Initially: Nil] switch ____ The switch !*ECHO is used to control the echoing of input. When (On Echo) is placed in an input file, the contents of the file Dskin Dskin are echoed on the standard output device. Dskin does not change ____ the value of !*ECHO, so one may say (On Echo) before calling Dskin Dskin Dskin, and the input will be echoed. DskIn DskIn _ ______ ____ ________ ____ (DskIn F:string): None Returned expr Read Eval Print Read Eval Print _ Enters a Read-Eval-Print loop on the contents of the file F. DskIn DskIn _ DskIn expects LISP syntax in the file F. Use the following format: (DskIn "File"). LapIn LapIn _ ______ ____ ________ ____ (LapIn U:string): None Returned expr Reads a single LISP file as "quietly" as possible, i.e., it does LapIn LapIn not echo or return values. Note that LapIn can be used only for LISP files. By convention, files with the extension ".LAP" are LapIn LapIn intended to be read by LapIn. These files are typically used to load modules made up of several binary (also known as FASL) Load Load files. The use of the Load function is normally preferable to LapIn LapIn using LapIn. For information about fast loading of files of Load FaslIn Load FaslIn compiled functions (FASL files) see FASL and the Load and FaslIn functions in Chapter 18. The following functions are present in RLISP, they can be used from Bare-PSL by loading RLISP. In In _ ______ ____ ________ _____ (In [L:string]): None Returned macro DskIn DskIn Similar to DskIn but expects RLISP syntax in the files it reads unless it can determine that the files are not in RLISP syntax. In In Also In can take more than one file name as an argument. On most In In systems the function In expects files with extension .LSP and .SL to be written in LISP syntax, not in RLISP. This is convenient when using both LISP and RLISP files. It is conventional to use the extension .RED (or .R) for RLISP files and use .LSP or .SL PSL Manual 7 February 1983 Input and Output section 12.5 page 12.15 only for fully parenthesized LISP files. There are some system programs, such as TAGS on the DEC-20, which expect RLISP files to have the extension .RED. If it is not desired to have the contents of the file echoed as In In it is read, either end the In command with a "$" in RLISP, as In "FILE1.RED","FILE2.SL"$ Off Off ____ or include the statement "Off ECHO;" in your file. PathIn PathIn ________ ____ ______ ____ ________ ____ (PathIn FileName-Tail:string): None Returned expr IN IN Allows the use of a directory search path with the Rlisp IN function. It finds a list of search paths in the fluid variable PATHIN!*. These are successively concatenated onto the front of PathIn PathIn the string argument to PathIn until an existing file is found FileP In FileP In (using FileP. If one is found, In will be invoked on this file. If not, a continuable error occurs. For example on the VAX, (Setq PathIn!* '( "" "/u/psl/" "/u/smith/")) (PathIn "foo.red") will attempt to open "foo.red", then "/u/psl/foo.red", and finally "/u/smith/foo.red" until a successful open is achieved. Pathin Pathin To use Pathin in Bare-PSL, load PATHIN as well as RLISP. EvIn EvIn _ ______ ____ ____ ________ ____ (EvIn L:string-list): None Returned expr EvIn _ EvIn L must be a list of strings that are filenames. EvIn is the In In In In function called by In after evaluating its arguments. In is EvIn EvIn useful only at the top-level, while EvIn can be used inside functions with file names passed as parameters. 12.5.3. Reading Single Characters 12.5.3. Reading Single Characters 12.5.3. Reading Single Characters ChannelReadChar ChannelReadChar _______ __ _______ _________ ____ (ChannelReadChar CHANNEL:io-channel): character expr _______ _______ Reads one character (an integer) from CHANNEL. All input is _______ defined in terms of this function. If CHANNEL is not open or is open for writing only, an error is generated. If there is a _______ non-zero value in the backup buffer associated with CHANNEL, the buffer is emptied (set to zero) and the value returned. _______ Otherwise, the reading function associated with CHANNEL is called _______ with CHANNEL as argument, and the value it returns is returned by ChannelReadChar ChannelReadChar ChannelReadChar. Input and Output 7 February 1983 PSL Manual page 12.16 section 12.5 ***** Channel not open ***** Channel open for write only ReadChar ReadChar _________ ____ (ReadChar ): character expr Reads one character from the current input channel. ChannelReadCH ChannelReadCH ____ __ _______ __ ____ (ChannelReadCH CHAN:io-channel): id expr ChannelReadChar ChannelReadChar __ Like ChannelReadChar, but returns the id for the character rather than its ASCII code. ReadCH ReadCH __ ____ (ReadCH ): id expr ChannelReadCH ChannelReadCH ChannelReadCH from the current input channel. ChannelUnReadChar ChannelUnReadChar ____ __ _______ __ _________ _________ ____ (ChannelUnReadChar CHAN:io-channel CH:character): Undefined expr __ The input backup function. CH is deposited in the backup buffer ____ associated with CHAN. This function should be only called after ChannelReadChar ChannelReadChar ChannelReadChar is called, before any intervening input operations, since it is used by the token scanner. UnReadChar UnReadChar __ _________ _________ ____ (UnReadChar CH:character): Undefined expr Backup on the current input channel. 12.5.4. Reading Tokens 12.5.4. Reading Tokens 12.5.4. Reading Tokens The functions described here pertain to the token scanner and reader. Globals and switches used by these functions are defined at the end of this section. ChannelReadToken ChannelReadToken _______ __ _______ __ ______ ______ ____ (ChannelReadToken CHANNEL:io-channel): {id, number, string} expr This is the basic LISP token scanner. The value returned is a LISP item corresponding to the next token from the input stream. __ Ids are interned, unless the FLUID variable !*COMPRESSING is non-NIL. The GLOBAL variable TOKTYPE!* is set to: __ 0 if the token is an ordinary id, ______ 1 if the token is a string, ______ 2 if the token is a number, or PSL Manual 7 February 1983 Input and Output section 12.5 page 12.17 3 if the token is an unescaped delimiter. __ In the last case, the value returned is the id whose print name is the same as the delimiter. The precise behavior of this function depends on two FLUID variables: CURRENTSCANTABLE!* ______ Is bound to a vector known as a scan table. Described below. CURRENTREADMACROINDICATOR!* __ Bound to an id known as a read macro indicator. Described below. Scan tables have 129 entries, indexed by 0 through 128. 0 _______ through 127 are indexed by ASCII character code to get an integer code determining the treatment of the corresponding character. _______ __ The last entry is not an integer, but rather an id which _________ _________ specifies a Diphthong Indicator for the token scanner. [??? A future implementation may replace the FLUID [??? A future implementation may replace the FLUID [??? A future implementation may replace the FLUID CURRENTREADMACROINDICATOR!* with another entry in the scan CURRENTREADMACROINDICATOR!* with another entry in the scan CURRENTREADMACROINDICATOR!* with another entry in the scan table. ???] table. ???] table. ???] The following encoding for characters is used. 0 ... 9 DIGIT: indicates the character is a digit, and gives the corresponding numeric value. 10 LETTER: indicates that the character is a letter. 11 DELIMITER: indicates that the character is a delimiter which is not the starting character of a diphthong. 12 COMMENT: indicates that the character begins a comment terminated by an end of line. 13 DIPHTHONG: indicates that the character is a delimiter which may be the starting character of a diphthong. (A diphthong is a two character sequence read as one token, i.e., "<<" or ":=".) 14 IDESCAPE: indicates that the character is an escape character, to cause the following character to be taken __ as part of an id. (Ordinarily an exclamation point, i.e. "!".) 15 STRINGQUOTE: indicates that the character is a string quote. (Ordinarily a double quote, i.e. '"'.) 16 PACKAGE: indicates that the character is used to introduce explicit package names. (Ordinarily "\".) 17 IGNORE: indicates that the character is to be ignored. Input and Output 7 February 1983 PSL Manual page 12.18 section 12.5 (Ordinarily BLANK, TAB, EOL and NULL.) 18 MINUS: indicates that the character is a minus sign. 19 PLUS: indicates that the character is a plus sign. 20 DECIMAL: indicates that the character is a decimal point. 21 IDSURROUND: indicates that the character is to act for identifiers as a string quote acts for strings. Although this is not used in the default scan table, the intended character for this function is a vertical bar, |.) System builders who wish to define their own parsers can bind an appropriate scan table to CURRENTSCANTABLE!* and then call ChannelReadToken ChannelReadTokenWithHooks ChannelReadToken ChannelReadTokenWithHooks ChannelReadToken or ChannelReadTokenWithHooks for lexical scanning. Utility functions for building scan tables are described in the next section. The following standards for scanning tokens are used. __ - Ids begin with a letter or any character preceded by an escape character. They may contain letters, digits and __ escaped characters. Ids may also start with a digit, if the first non-digit following is a plus sign, minus sign, or letter other than "b" or "e". This is to allow identifiers such as "1+" which occur in some LISPs. Finally, a string of characters bounded by the IDSURROUND character is treated __ as an id. If !*RAISE is non-NIL, unescaped lower case letters are __ folded to upper case. The maximum size of an id (or any other token) is currently 5000 characters. __________ Note: Using lower case letters in identifiers may cause portability problems. Lower case letters are automatically converted to upper case if the !*RAISE switch is T. This __ case conversion is done only for id input, not for single character or string input. [??? Can we retain input Case, but Compare RAISEd ???] [??? Can we retain input Case, but Compare RAISEd ???] [??? Can we retain input Case, but Compare RAISEd ???] Here are some examples, using the RLISP scan table. Note that the first and second examples are read as the same identifier if !*RAISE is T. The fourth and fifth examples are read as the same identifier. * ThisIsALongIdentifier * THISISALONGIDENTIFIER * ThisIsALongIdentifierAndDifferentFromTheOther * this_is_a_long_identifier_with_underscores PSL Manual 7 February 1983 Input and Output section 12.5 page 12.19 * this!_is!_a!_long!_identifier!_with!_underscores * an!-identifier!-with!-dashes * !*RAISE * !2222 The following examples show the same identifiers in a form accepted by the LISP scan table. Note that most characters are treated as letters by the LISP scan table, while they are treated as delimiters by the RLISP scan table. * ThisIsALongIdentifier * THISISALONGIDENTIFIER * ThisIsALongIdentifierAndDifferentFromTheOther * this_is_a_long_identifier_with_underscores * this!_is!_a!_long!_identifier!_with!_underscores * an-identifier-with-dashes * *RAISE * !2222 ______ - Strings begin with a double quote (") and include all characters up to a closing double quote. A double quote can ______ ______ be included in a string by doubling it. An empty string, consisting of only the enclosing quote marks, is allowed. ______ The characters of a string are not affected by the value of the !*RAISE. Examples: * "This is a string" * "This is a ""string""" * "" ____ _______ - Code-pointers cannot be read directly, but can be printed and constructed. Currently printed as ________ _____ _____ _______ #<Code argument-count octal-address>. _______ - Integers begin with a digit, optionally preceded by a + or - sign, and consist only of digits. The GLOBAL input radix is 10; there is no way to change this. However, numbers of different radices may be read by the following convention. A decimal number from 2 to 36 followed by a sharp sign (#), causes the digits (and possibly letters) that follow to be 2 read in the radix of the number preceding the #. Thus 63 _______________ 2 Octal numbers can also be written as a string of digits followed by the letter "B". This "feature" may be removed in the future. Input and Output 7 February 1983 PSL Manual page 12.20 section 12.5 may be entered as 8#77, or 255 as 16#ff or 16#FF. The output radix can be changed, by setting OUTPUTBASE!*. If _______ OutPutBase!* is not 10, the printed integer appears with appropriate radix. Leading zeros are suppressed and a minus _______ sign precedes the digits if the integer is negative. Examples: * 100 * +5234 * -8#44 (equal to -36) [??? Should we permit trailing . in integers for [??? Should we permit trailing . in integers for [??? Should we permit trailing . in integers for compatibility with some LISPs and require digits on each compatibility with some LISPs and require digits on each compatibility with some LISPs and require digits on each side of . for floats ???] side of . for floats ???] side of . for floats ???] _____ - Floats have a period and/or a letter "e" or "E" in them. _____ Any of the following are read as floats. The value appears in the format [-]n.nn...nnE[-]mm if the magnitude of the number is too large or small to display in [-]nnnn.nnnn format. The crossover point is determined by the _____ implementation. In BNF, floats are recognized by the grammar: <base> ::= <unsigned-integer>.| .<unsigned-integer>| <unsigned-integer>.<unsigned-integer> <ebase> ::= <base>|<unsigned-integer> <unsigned-float> ::= <base>| <ebase>e<unsigned-integer>| <ebase>e-<unsigned-integer>| <ebase>e+<unsigned-integer>| <ebase>E<unsigned-integer>| <ebase>E-<unsigned-integer>| <ebase>E+<unsigned-integer> <float> ::= <unsigned-float>| +<unsigned-float>| -<unsigned-float> That is: * [+|-][nnn][.]nnn{e|E}[+|-]nnn * nnn. * .nnn * nnn.nnn Examples: PSL Manual 7 February 1983 Input and Output section 12.5 page 12.21 * 1e6 * .2 * 2. * 2.0 * -1.25E-9 RAtom RAtom __ ______ ______ ____ (RAtom ): {id, number, string} expr Reads a token from the current input channel. (Not called ReadToken ReadToken ReadToken for historical reasons.) [??? Should we bind CurrentScanTable!* for this function too [??? Should we bind CurrentScanTable!* for this function too [??? Should we bind CurrentScanTable!* for this function too ???] ???] ???] __________ ______ !*COMPRESSING [Initially: NIL] switch ChannelReadToken ChannelReadToken If !*COMPRESSING is non-NIL, ChannelReadToken does not intern __ ids. __________ ______ !*EOLINSTRINGOK [Initially: NIL] switch If !*EOLINSTRINGOK is non-NIL, the warning message *** STRING CONTINUED OVER END-OF-LINE is suppressed. __________ ______ !*RAISE [Initially: T] switch __ If !*RAISE is non-NIL, all characters input for ids through PSL input functions are raised to upper case. If !*RAISE is NIL, ______ characters are input as is. A string is unaffected by !*RAISE. __________ ______ CURRENTSCANTABLE!* [Initially: ] global Read Read This variable is set to LISPSCANTABLE!* by the Read function (the "Lisp syntax" reader). The RLISP reader sets it to RLISPSCANTABLE!* or LISPSCANTABLE!* depending on the syntax it expects. Input and Output 7 February 1983 PSL Manual page 12.22 section 12.5 __________ ______ LISPSCANTABLE!* [Initially: as shown in following table] global 0 ^@ IGNORE 32 IGNORE 64 @ LETTER 96 ` DELIMITER 1 ^A LETTER 33 ! IDESCAPECHAR 65 A LETTER 97 a LETTER 2 ^B LETTER 34 " STRINGQUOTE 66 B LETTER 98 b LETTER 3 ^C LETTER 35 # LETTER 67 C LETTER 99 c LETTER 4 ^D LETTER 36 $ LETTER 68 D LETTER 100 d LETTER 5 ^E LETTER 37 % COMMENTCHAR 69 E LETTER 101 e LETTER 6 ^F LETTER 38 & LETTER 70 F LETTER 102 f LETTER 7 ^G LETTER 39 ' DELIMITER 71 G LETTER 103 g LETTER 8 ^H LETTER 40 ( DELIMITER 72 H LETTER 104 h LETTER 9 <tab> IGNORE 41 ) DELIMITER 73 I LETTER 105 i LETTER 10 <lf> IGNORE 42 * LETTER 74 J LETTER 106 j LETTER 11 ^K LETTER 43 + PLUSSIGN 75 K LETTER 107 k LETTER 12 ^L IGNORE 44 , DIPHTHONGSTART 76 L LETTER 108 l LETTER 13 <cr> IGNORE 45 - MINUSSIGN 77 M LETTER 109 m LETTER 14 ^N LETTER 46 . DECIMALPOINT 78 N LETTER 110 n LETTER 15 ^O LETTER 47 / LETTER 79 O LETTER 111 o LETTER 16 ^P LETTER 48 0 DIGIT 80 P LETTER 112 p LETTER 17 ^Q LETTER 49 1 DIGIT 81 Q LETTER 113 q LETTER 18 ^R LETTER 50 2 DIGIT 82 R LETTER 114 r LETTER 19 ^S LETTER 51 3 DIGIT 83 S LETTER 115 s LETTER 20 ^T LETTER 52 4 DIGIT 84 T LETTER 116 t LETTER 21 ^U LETTER 53 5 DIGIT 85 U LETTER 117 u LETTER 22 ^V LETTER 54 6 DIGIT 86 V LETTER 118 v LETTER 23 ^W LETTER 55 7 DIGIT 87 W LETTER 119 w LETTER 24 ^X LETTER 56 8 DIGIT 88 X LETTER 120 x LETTER 25 ^Y LETTER 57 9 DIGIT 89 Y LETTER 121 y LETTER 26 ^Z DELIMITER 58 : LETTER 90 Z LETTER 122 z LETTER 27 $ LETTER 59 ; LETTER 91 [ DELIMITER 123 { LETTER 28 ^\ LETTER 60 < LETTER 92 \ PACKAGE 124 | LETTER 29 ^] LETTER 61 = LETTER 93 ] DELIMITER 125 } LETTER 30 ^^ LETTER 62 > LETTER 94 ^ LETTER 126 ~ LETTER 31 ^_ LETTER 63 ? LETTER 95 _ LETTER 127 <rubout> LETTER _________ _________ The Diphthong Indicator in the 128th entry is the identifier LISPDIPTHONG. [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will probably be corrected in the future. ???] probably be corrected in the future. ???] probably be corrected in the future. ???] PSL Manual 7 February 1983 Input and Output section 12.5 page 12.23 __________ ______ RLISPSCANTABLE!* [Initially: as shown in following table] global 0 ^@ IGNORE 32 IGNORE 64 @ DELIMITER 96 ` DELIMITER 1 ^A DELIMITER 33 ! IDESCAPECHAR 65 A LETTER 97 a LETTER 2 ^B DELIMITER 34 " STRINGQUOTE 66 B LETTER 98 b LETTER 3 ^C DELIMITER 35 # DELIMITER 67 C LETTER 99 c LETTER 4 ^D DELIMITER 36 $ DELIMITER 68 D LETTER 100 d LETTER 5 ^E DELIMITER 37 % COMMENTCHAR 69 E LETTER 101 e LETTER 6 ^F DELIMITER 38 & DELIMITER 70 F LETTER 102 f LETTER 7 ^G DELIMITER 39 ' DELIMITER 71 G LETTER 103 g LETTER 8 ^H DELIMITER 40 ( DELIMITER 72 H LETTER 104 h LETTER 9 <tab> IGNORE 41 ) DELIMITER 73 I LETTER 105 i LETTER 10 <lf> IGNORE 42 * DIPHTHONGSTART 74 J LETTER 106 j LETTER 11 ^K DELIMITER 43 + DELIMITER 75 K LETTER 107 k LETTER 12 ^L IGNORE 44 , DELIMITER 76 L LETTER 108 l LETTER 13 <cr> IGNORE 45 - DELIMITER 77 M LETTER 109 m LETTER 14 ^N DELIMITER 46 . DECIMALPOINT 78 N LETTER 110 n LETTER 15 ^O DELIMITER 47 / DELIMITER 79 O LETTER 111 o LETTER 16 ^P DELIMITER 48 0 DIGIT 80 P LETTER 112 p LETTER 17 ^Q DELIMITER 49 1 DIGIT 81 Q LETTER 113 q LETTER 18 ^R DELIMITER 50 2 DIGIT 82 R LETTER 114 r LETTER 19 ^S DELIMITER 51 3 DIGIT 83 S LETTER 115 s LETTER 20 ^T DELIMITER 52 4 DIGIT 84 T LETTER 116 t LETTER 21 ^U DELIMITER 53 5 DIGIT 85 U LETTER 117 u LETTER 22 ^V DELIMITER 54 6 DIGIT 86 V LETTER 118 v LETTER 23 ^W DELIMITER 55 7 DIGIT 87 W LETTER 119 w LETTER 24 ^X DELIMITER 56 8 DIGIT 88 X LETTER 120 x LETTER 25 ^Y DELIMITER 57 9 DIGIT 89 Y LETTER 121 y LETTER 26 ^Z DELIMITER 58 : DIPHTHONGSTART 90 Z LETTER 122 z LETTER 27 $ DELIMITER 59 ; DELIMITER 91 [ DELIMITER 123 { DELIMITER 28 ^\ DELIMITER 60 < DIPHTHONGSTART 92 \ PACKAGE 124 | DELIMITER 29 ^] DELIMITER 61 = DELIMITER 93 ] DELIMITER 125 } DELIMITER 30 ^^ DELIMITER 62 > DIPHTHONGSTART 94 ^ DELIMITER 126 ~ DELIMITER 31 ^_ DELIMITER 63 ? DELIMITER 95 _ LETTER 127 <rubout> DELIMITER _________ _________ The Diphthong Indicator in the 128th entry is the identifier RLISPDIPTHONG. [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this will probably be corrected in the future. ???] will probably be corrected in the future. ???] will probably be corrected in the future. ???] [??? What about the RlispRead scantable ???] [??? What about the RlispRead scantable ???] [??? What about the RlispRead scantable ???] [??? Perhaps describe one basic table, and changes from one to other, [??? Perhaps describe one basic table, and changes from one to other, [??? Perhaps describe one basic table, and changes from one to other, since mostly the same ???] since mostly the same ???] since mostly the same ???] Input and Output 7 February 1983 PSL Manual page 12.24 section 12.5 __________ ______ OUTPUTBASE!* [Initially: 10] global This global can be set to control the radix in which integers are printed out. If the radix is not 10, the radix is given before a sharp sign, e.g. 8#20 is"20" in base 8, or 16. __________ ______ TOKTYPE!* [Initially: 3] global ChannelReadToken ChannelReadToken ChannelReadToken sets TOKTYPE!* to: __ 0 if the token is an ordinary id, ______ 1 if the token is a string, ______ 2 if the token is a number, or 3 if the token is an unescaped delimiter. __ In the last case, the value returned is the id whose print name is the same as the delimiter. 12.5.5. Read Macros 12.5.5. Read Macros 12.5.5. Read Macros Channel Token Channel Token A function of two arguments (Channel, Token) can be associated with any DELIMITER or DIPHTHONG token (i.e. those that have TOKTYPE!*=3) by calling PutReadMacro ChannelReadTokenWithHooks PutReadMacro _________ ChannelReadTokenWithHooks PutReadMacro. A ReadMacro function is called by ChannelReadTokenWithHooks ChannelReadToken ChannelReadToken if the appropriate token with TOKTYPE!*=3 is returned by ChannelReadToken. This function can then take over the reading (or scanning) process, finally returning a token (actually an S-expression) to be returned in place of the token itself. Quote Quote Example: The quote mark, 'x converting to (Quote x), is done by the PutReadMacro PutReadMacro following example which makes use of the function PutReadMacro which is defined in Section 12.6. In LISP: (de DOQUOTE (CHANNEL TOKEN)) (LIST 'QUOTE (CHANNELREAD CHANNEL)) (PUTREADMACRO LISPSCANTABLE!* '!' (FUNCTION DOQUOTE)) _________ A ReadMacro is installed on the property list of the macro-character as a function under the indicators 'LISPREADMACRO, 'RLISPREADMACRO, etc. A _________ Diphthong is installed on the property list of the first character as (second-character . diphthong) under the indicators 'LISPDIPHTHONG, 'RLISPDIPHTHONG, etc. PSL Manual 7 February 1983 Input and Output section 12.6 page 12.25 12.6. Scan Table Utility Functions 12.6. Scan Table Utility Functions 12.6. Scan Table Utility Functions The following functions are provided to manage scan tables, in the READ-UTILS module (use via LOAD READ-UTILS): PrintScanTable PrintScanTable _____ ______ ___ ____ (PrintScanTable TABLE:vector): NIL expr Prints the entire scantable, gives the 0 ... 127 entries with the name of the character class. Also prints the indicator used for diphthongs. [??? Make smarter, reduce output, use nice names for control [??? Make smarter, reduce output, use nice names for control [??? Make smarter, reduce output, use nice names for control characters, ala EMODE. ???] characters, ala EMODE. ???] characters, ala EMODE. ???] CopyScanTable CopyScanTable ________ ______ ___ ______ ____ (CopyScanTable OLDTABLE:{vector, NIL}): vector expr Copies the existing scantable (or CURRENTSCANTABLE!* if given GenSym GenSym NIL). Currently GenSym()'s the indicators used for diphthongs. [??? Change when we use Property Lists in extra slots of the [??? Change when we use Property Lists in extra slots of the [??? Change when we use Property Lists in extra slots of the Scan-Table ???] Scan-Table ???] Scan-Table ???] PutDipthong PutDipthong _____ ______ __ __ ___ __ ___ __ ___ ____ (PutDipthong TABLE:vector, D1:id ID2:id DIP:id): NIL expr ___ ___ ___ Installs DIP as the name of the diphthong ID1 followed by ID2 in the given scan table. [??? Note that PutDipthong should be spelled PutDiphthong, [??? Note that PutDipthong should be spelled PutDiphthong, [??? Note that PutDipthong should be spelled PutDiphthong, this will probably be corrected in the future. ???] this will probably be corrected in the future. ???] this will probably be corrected in the future. ???] PutReadMacro PutReadMacro _____ ______ ___ __ _____ __ ___ ____ (PutReadMacro TABLE:vector ID1:id FNAME:id): NIL expr ____ _____ ____ _____ ____ _____ Read macro _____ Read macro Installs FNAME as the name of the Read macro function for the ___ ___ ___ [not ___ [not delimiter or diphthong ID1 in the given scan table. [not ___________ ___ ___________ ___ ___________ ___ implemented yet] implemented yet] implemented yet] 12.7. I/O to and from Lists and Strings 12.7. I/O to and from Lists and Strings 12.7. I/O to and from Lists and Strings Digit Digit _ ___ _______ ____ (Digit U:any): boolean expr _ Returns T if U is a digit, otherwise NIL. Effectively this is: (de DIGIT (U) (IF (MEMQ U '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) T NIL)) Input and Output 7 February 1983 PSL Manual page 12.26 section 12.7 Liter Liter _ ___ _______ ____ (Liter U:any): boolean expr _ Returns T if U is a character of the alphabet, NIL otherwise. This is effectively: (de LITER(U) (IF (MEMQ U '(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 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)) T NIL)) Explode Explode _ ___ __ ____ ____ (Explode U:any): id-list expr Explode Explode Explode takes the constituent characters of an S-expression and ____ __ forms a list of single character ids. It is implemented via the ChannelPrin1 ChannelPrin1 ____ function ChannelPrin1, with a list rather than a file or terminal ____ as destination. Returned is a list of interned characters _ representing the characters required to print the value of U. Example: - Explode 'FOO; => (F O O) - Explode '(A . B); => (!( A ! !. ! B !)) [??? add print macros. cf. UCI lisp ???] [??? add print macros. cf. UCI lisp ???] [??? add print macros. cf. UCI lisp ???] Explode2 Explode2 _ ____ ______ __ ____ ____ (Explode2 U:{atom}-{vector}): id-list expr Prin2 Explode Prin2 Explode Prin2 version of Explode. Compress Compress _ __ ____ ____ ______ ____ (Compress U:id-list): {atom}-{vector} expr _ ____ U is a list of single character identifiers which is built into a ______ ______ PSL entity and returned. Recognized are numbers, strings, and __________ identifiers with the escape character prefixing special characters. The formats of these items appear in the "Primitive __________ ___ Data Types" Section, Section 4.1.2. Identifiers are not interned ________ _______ on the ID-HASH-TABLE. Function pointers may not be compressed. _ If an entity cannot be parsed out of U or characters are left over after parsing an error occurs: ***** Poorly formed atom in COMPRESS PSL Manual 7 February 1983 Input and Output section 12.7 page 12.27 Implode Implode _ __ ____ ____ ____ (Implode U:id-list): atom expr Compress Compress __ Compress with ids interned. FlatSize FlatSize _ ___ _______ ____ (FlatSize U:any): integer expr Prin1 Prin1 Character length of Prin1 S-expression. FlatSize2 FlatSize2 _ ___ _______ ____ (FlatSize2 U:any): integer expr Prin2 flatsize Prin2 flatsize Prin2 version of flatsize. BldMsg BldMsg ______ ______ ____ ___ ______ ____ (BldMsg FORMAT:string, [ARGS:any]): string expr PrintF BldMsg PrintF ______ BldMsg ______ PrintF to string. BldMsg returns a string stating that the ______ string could not be constructed if overflow occurs. 12.8. Example of Simple I/O in PSL 12.8. Example of Simple I/O in PSL 12.8. Example of Simple I/O in PSL In the following example a list of S-expressions is read, one expression at a time, from a file STUFF.IN and is written to a file STUFF.OUT. Following is the contents of STUFF.IN: (r e d) (a b c) (1 2 3 4) "ho ho ho" 6.78 5000 xyz The following shows the execution of the function TRYIO. Input and Output 7 February 1983 PSL Manual page 12.28 section 12.8 @psl:psl PSL 3.1, 15-Nov-82 1 lisp> (On Echo) NIL 2 lisp> (Dskin "Exampio.Sl") (De Tryio (Fil1 Fil2) (Prog (Oldin Oldout Exp) (Setq Oldin (Rds (Open Fil1 'input))) (Setq Oldout (Wrs (Open Fil2 'output))) (While (Neq (Setq Exp (Read)) !$EOF!$) (Print Exp)) (Close (Rds Oldin)) (Close (Wrs Oldout)))) TRYIO NIL 3 lisp> (Off Echo) NIL 4 lisp> (Tryio "Stuff.In" "Stuff.Out") NIL The output file STUFF.OUT contains the following. (R E D) (A B C) (1 2 3 4) "ho ho ho" 6.78 5000 XYZ |
Added psl-1983/3-1/lpt/13-toploop.lpt version [649c266976].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 User Interface section 13.0 page 13.1 CHAPTER 13 CHAPTER 13 CHAPTER 13 USER INTERFACE USER INTERFACE USER INTERFACE 13.1. Introduction . . . . . . . . . . . . . . . 13.1 13.2. Stopping PSL and Saving a New Executable Core Image . . 13.1 13.3. Init Files. . . . . . . . . . . . . . . . 13.3 13.4. Changing the Default Top Level Function . . . . . . 13.3 13.5. The General Purpose Top Loop Function. . . . . . . 13.4 13.6. The HELP Mechanism . . . . . . . . . . . . . 13.7 13.7. The Break Loop . . . . . . . . . . . . . . 13.8 13.8. Terminal Interaction Commands in RLISP . . . . . . 13.8 13.1. Introduction 13.1. Introduction 13.1. Introduction In this chapter those functions are presented relating directly to the user interface; for example, the general purpose Top Loop function, the History mechanism, and changing the default Top Level function. 13.2. Stopping PSL and Saving a New Executable Core Image 13.2. Stopping PSL and Saving a New Executable Core Image 13.2. Stopping PSL and Saving a New Executable Core Image Quit Quit The normal way to stop PSL execution is to call the Quit function or to strike <Ctrl-C> on the DEC-20 or <Ctrl-Z> on the VAX. Quit Quit _________ ____ (Quit ): Undefined expr Return from LISP to superior process. After either of these actions, PSL may be re-entered by typing START or CONTINUE to the EXEC on the DEC-20. After exiting, the core image may also be saved using the Tops-20 monitor command "SAVE filename". On the VAX, Quit Quit Quit causes a stop signal to be sent, so that PSL may be continued from the shell. If you desire that the process be killed, use the function ExitLisp ExitLisp ExitLisp. ExitLisp ExitLisp _________ ____ (ExitLisp ): Undefined expr Quit Quit To be used on the VAX. Like Quit except that the process is ExitLisp ExitLisp killed. ExitLisp calls the Unix library routine exit(). A better way to exit and save the core image is to call the function SaveSystem SaveSystem SaveSystem. User Interface 7 February 1983 PSL Manual page 13.2 section 13.2 SaveSystem SaveSystem ___ ______ ____ ______ _____ ____ ____ _________ ____ (SaveSystem MSG:string FILE:string FORMS:form-list): Undefined expr This records the welcome message (after attaching a date) in the StandardLisp StandardLisp global variable LISPBANNER!* used by StandardLisp's call on TopLoop DumpLisp TopLoop DumpLisp TopLoop, and then calls DumpLisp to compact the core image and write it out as a machine dependent executable file with the name ____ ____ FILE. FILE should have the appropriate extension for an SaveSystem SaveSystem executable file. SaveSystem also sets USERMODE!* to T. _____ The forms in the list FORMS will be evaluated when the new core image is started. For example (SaveSystem "PSL 3.1" "PSL.EXE" '((Read-Init-File "PSL") (InitializeInterrupts))) SaveSystem SaveSystem If RLISP has been loaded, SaveSystem will have been redefined to Main Main save the message in the global variable DATE!*, and redefine Main RlispMain Begin1 RlispMain Begin1 to call RlispMain, which uses DATE!* in Begin1. The older SaveSystem LispSaveSystem SaveSystem LispSaveSystem SaveSystem will be saved as the function LispSaveSystem. DumpLisp DumpLisp ____ ______ _________ ____ (DumpLisp FILE:string): Undefined expr Reclaim Reclaim This calls Reclaim to compact the heap, and unmaps the unused pages (DEC-20) or moves various segment pointers (VAX) to decrease the core image. The core image is then written as an ____ executable file, with the name FILE. Reset Reset _________ ____ (Reset ): Undefined expr Return to top level of LISP. Equivalent to <Ctrl-C> and Start on DEC-20. Time Time _______ ____ (Time ): integer expr CPU time in milliseconds since login time. Date Date ______ ____ (Date ): string expr The date in the form 16-Dec-82. __________ ______ LISPBANNER!* [Initially: ] global SaveSystem SaveSystem Records the welcome message given by a call to SaveSystem from Date Date PSL. Also contains the date, given by the function Date. PSL Manual 7 February 1983 User Interface section 13.2 page 13.3 __________ ______ DATE!* [Initially: Nil] global SaveSystem SaveSystem Records the welcome message given by a call to SaveSystem from RLISP. 13.3. Init Files 13.3. Init Files 13.3. Init Files Init files are available to make it easier for the user to customize PSL to his/her own needs. When PSL, RLISP, or PSLCOMP is executed, if a file PSL.INIT, RLISP.INIT, or PSLCOMP.INIT (.pslrc, rlisprc, or .pslcomprc on the VAX) is on the home directory, it will be read and evaluated. Currently all init files must be written in LISP syntax. They may use FASLIN LOAD FASLIN LOAD FASLIN or LOAD as needed. The following functions are used to implement init files, and can be accessed by LOADing the INIT-FILE module. User-HomeDir-String User-HomeDir-String ______ ____ (User-HomeDir-String ): string expr Returns a full pathname for the user's home directory. Init-File-String Init-File-String ___________ ______ ______ ____ (Init-File-String PROGRAMNAME:string): string expr Returns the full pathname of the user's init file for the program ___________ PROGRAMNAME. (Init-File-String "PSL") Read-Init-File Read-Init-File ___________ ______ ___ ____ (Read-Init-File PROGRAMNAME:string): Nil expr ___________ Reads and evaluates the init file with name PROGRAMNAME. Read-Init-File Init-File-String Read-Init-File Init-File-String ___________ Read-Init-File calls Init-File-String with argument PROGRAMNAME. (Read-Init-File "PSL") 13.4. Changing the Default Top Level Function 13.4. Changing the Default Top Level Function 13.4. Changing the Default Top Level Function As PSL starts up, it first sets the stack pointer and various other Main While Main While variables, and then calls the function Main inside a While loop, protected Catch Main StandardLisp Catch Main StandardLisp by a Catch. By default, Main calls a StandardLisp top loop, defined using TopLoop TopLoop the general TopLoop function, described in the next Section. In order to Main Main have a saved PSL come up in a different top loop, the function Main should be appropriately redefined by the user (e.g. as is done to create RLISP). User Interface 7 February 1983 PSL Manual page 13.4 section 13.4 Main Main _________ ____ (Main ): Undefined expr Initialization function, called after setting the stack. Should TopLoop TopLoop be redefined by the user to change the default TopLoop. 13.5. The General Purpose Top Loop Function 13.5. The General Purpose Top Loop Function 13.5. The General Purpose Top Loop Function PSL provides a general purpose Top Loop that allows the user to specify Read Eval Print Read Eval Print his own Read, Eval and Print functions and otherwise obtain a standard set of services, such as Timing, History, Break Loop interface, and Interface to Help system. __________ ______ TOPLOOPEVAL!* [Initially: NIL] global Eval Eval The Eval used in the current Top Loop. __________ ______ TOPLOOPPRINT!* [Initially: NIL] global Print Print The Print used in the current Top Loop. __________ ______ TOPLOOPREAD!* [Initially: NIL] global Read Read The Read used in the current Top Loop. TopLoop TopLoop ___________ ________ ____________ ________ (TopLoop TOPLOOPREAD!*:function TOPLOOPPRINT!*:function ___________ ________ ___________ __ _____________ ______ ___ ____ TOPLOOPEVAL!*:function TOPLOOPNAME!*:id WELCOMEBANNER:string): NIL expr This function is called to establish a new Top Loop (currently Standard LISP Break Standard LISP Break used for Standard LISP, RLISP, and Break). It prints the Read-Eval-Print _____________ Read-Eval-Print WELCOMEBANNER and then invokes a "Read-Eval-Print" loop, using ___________ the given functions. Note that TOPLOOPREAD!*, etc. are FLUID variables, and so may be examined (and changed) within the TopLoop TopLoop executing Top Loop. TopLoop provides a standard History and ____ ___________ timing mechanism, retaining on a list (HISTORYLIST!*) the input ____ ____ and output as a list of pairs. A prompt is constructed from ___________ TOPLOOPNAME!* and is printed out, prefixed by the History count. As a convention, the name is followed by a number of ">"'s, indicating the loop depth. __________ ______ TOPLOOPNAME!* [Initially: ] global Short name to put in prompt. PSL Manual 7 February 1983 User Interface section 13.5 page 13.5 __________ ______ TOPLOOPLEVEL!* [Initially: ] global Depth of top loop invocations. __________ ______ !*EMSGP [Initially: ] switch Whether to print error messages. __________ ______ GCTIME!* [Initially: ] global Time spent in garbage collection. __________ ______ INITFORMS!* [Initially: ] global Forms to be evaluated at startup. __________ ______ !*PECHO [Initially: NIL] switch StandardLisp StandardLisp Causes parsed form read in top-loop StandardLisp to be printed, if T. __________ ______ !*PVAL [Initially: T] switch StandardLisp StandardLisp Causes values computed in top-loop StandardLisp to be printed, if T. __________ ______ !*TIME [Initially: NIL] switch If on, causes a step evaluation time to be printed after each command. Hist Hist _ _______ ___ _____ (Hist [N:integer]): NIL nexpr This function does not work with the Top Loop used by PSL:RLISP or by (beginrlisp); it does work with LISP and with RLISP if it Hist Hist is started from LISP using the RLISP function. Hist is called with 0, 1 or 2 integers, which control how much history is to be printed out: (HIST) Display full history. (HIST n m) Display history from n to m. (HIST n) Display history from n to present. (HIST -n) Display last n entries. User Interface 7 February 1983 PSL Manual page 13.6 section 13.5 [??? Add more info about what a history is. ???] [??? Add more info about what a history is. ???] [??? Add more info about what a history is. ???] The following functions permit the user to access and resubmit previous expressions, and to re-examine previous results. Inp Inp _ _______ ___ ____ (Inp N:integer): any expr Return N'th input at this level. ReDo ReDo _ _______ ___ ____ (ReDo N:integer): any expr Reevaluate N'th input. Ans Ans _ _______ ___ ____ (Ans N:integer): any expr Return N'th result. __________ ______ HISTORYCOUNT!* [Initially: 0] global Number of entries read so far. __________ ______ HISTORYLIST!* [Initially: Nil] global List of entries read and evaluated. TopLoop StandardLisp TopLoop StandardLisp TopLoop has been used to define the following StandardLisp and RLISP top loops. StandardLisp StandardLisp ___ ____ (StandardLisp ): NIL expr Interpreter LISP syntax top loop, defined as: (De StandardLisp Nil (Prog (CurrentReadMacroIndicator!* CurrentScanTable!*) (Setq CurrentReadMacroIndicator!* 'LispReadMacro) (Setq CurrentScanTable!* LispScanTable!*) (Toploop 'Read 'Print 'Eval "LISP" "PORTABLE STANDARD LISP"))) Note that the scan tables are modified. RLisp RLisp ___ ____ (RLisp ): NIL expr Alternative interpreter RLISP syntax top loop, defined as: PSL Manual 7 February 1983 User Interface section 13.5 page 13.7 [??? xread described in RLISP Section ???] [??? xread described in RLISP Section ???] [??? xread described in RLISP Section ???] (De RLisp Nil (Toploop 'XRead 'Print 'Eval "RLISP" "PSL RLISP")) Note that for the moment, the default RLISP loop is not this (though this may be used experimentally); instead a similar BeginRlisp BeginRlisp (special purpose hand coded) function, BeginRlisp, based on the Begin1 Begin1 older Begin1 is used. It is hoped to change the RLISP top-level to use the general purpose capability. BeginRLisp BeginRLisp ____ ________ ____ (BeginRLisp ): None Returned expr Starts RLISP from PSL:PSL only if RLISP is loaded. The module RLISP is present if you started in RLISP and then entered PSL. 13.6. The HELP Mechanism 13.6. The HELP Mechanism 13.6. The HELP Mechanism PSL provides a general purpose Help mechanism, that is called in the TopLoop Help TopLoop Help TopLoop by invoking Help sometimes a ? may be used, as for example in the break loop. Help Help ______ __ ___ _____ (Help [TOPICS:id]): NIL fexpr If no arguments are given, a message describing Help itself and __ known topics is printed. Otherwise, each of the id arguments is checked to see if any help information is available. If it has a value under the property list indicator HelpFunction, that function is called. If it has a value under the indicator HelpString, the value is printed. If it has a value under the indicator HelpFile, the file is displayed on the terminal. By default, a file called "topic.HLP" on the Logical device, "PH:" is looked for, and printed if found. Help Help Help also prints out the values of the TopLoop fluids, and finally searches the current Id-Hash-Table for loaded modules. __________ ______ HELPIN!* [Initially: NIL] global Help Help The channel used for input by the Help mechanism. __________ ______ HELPOUT!* [Initially: NIL] global Help Help The channel used for output by the Help mechanism. User Interface 7 February 1983 PSL Manual page 13.8 section 13.7 13.7. The Break Loop 13.7. The Break Loop 13.7. The Break Loop The Break Loop is described in detail in Chapter 14. For information, look there. 13.8. Terminal Interaction Commands in RLISP 13.8. Terminal Interaction Commands in RLISP 13.8. Terminal Interaction Commands in RLISP Two commands are available in RLISP for use in interactive computing. Pause Pause ___ ____ (Pause ): Nil expr The command PAUSE; may be inserted at any point in an input file. If this command is encountered on input, the system prints the YesP YesP message CONT? on the user's terminal and halts by calling YesP. YesP YesP _______ ______ _______ ____ (YesP MESSAGE:string): boolean expr YesP YesP If the user responds Y or Yes, YesP returns T and the calculation continues from that point in the file. If the user responds N or YesP YesP No, YesP returns NIL and control is returned to the terminal, and the user can type in further commands. However, later on he can use the command CONT; and control is then transferred back to the point in the file after the last PAUSE was encountered. If the user responds B, one enters a break loop. After quitting the break loop, one still must respond Y, N, Yes, or No. |
Added psl-1983/3-1/lpt/14-errors.lpt version [babb18e01e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Error Handling and Recovery section 14.0 page 14.1 CHAPTER 14 CHAPTER 14 CHAPTER 14 ERROR HANDLING ERROR HANDLING ERROR HANDLING 14.1. Introduction . . . . . . . . . . . . . . . 14.1 14.2. The Basic Error Functions. . . . . . . . . . . 14.1 14.3. Break Loop. . . . . . . . . . . . . . . . 14.4 14.4. Interrupt Keys . . . . . . . . . . . . . . 14.7 14.5. Details on the Break Loop. . . . . . . . . . . 14.7 14.6. Some Convenient Error Calls . . . . . . . . . . 14.7 14.7. Special Purpose Error Handlers . . . . . . . . . 14.9 14.1. Introduction 14.1. Introduction 14.1. Introduction In PSL, as in most LISP systems, various kinds of errors are detected by functions in the process of checking the validity of their argument types and other conditions. Errors are then "signalled" to a currently active ErrorSet Error ErrorSet Error error handler (called ErrorSet) by a call on an Error function. In PSL, Break Break the error handler typically calls an interactive Break loop, which permits the user to examine the context of the error and optionally make some corrections and continue the computation, or to abort the computation. Break Break While in the Break loop, the user remains in the binding context of the function that detected the error; the user sees the value of FLUID variables as they are in the function itself. If the user aborts the Throw Throw computation, a call on Throw with a tag of !$ERROR!$ is done, and fluids are unbound. [??? What about errors signalled to the Interrupt Handler ???] [??? What about errors signalled to the Interrupt Handler ???] [??? What about errors signalled to the Interrupt Handler ???] 14.2. The Basic Error Functions 14.2. The Basic Error Functions 14.2. The Basic Error Functions The following two switches and one global variable are used by the functions in this section. __________ ______ !*BACKTRACE [Initially: T] switch ErrorSet ErrorSet Set in ErrorSet. Controls whether an unwind backtrace is requested. Error Handling and Recovery 7 February 1983 PSL Manual page 14.2 section 14.2 __________ ______ !*MSGP [Initially: T] switch ErrorSet ErrorSet Set in ErrorSet. Controls error message printing during call on error. __________ ______ EMSG!* [Initially: NIL] global Contains the message generated by the last error call. ErrorSet ErrorSet _ ___ ____ _______ _________ _______ ___ ____ (ErrorSet U:any !*MSGP:boolean !*BACKTRACE:boolean): any expr _ If an uncorrected error occurs during the evaluation of U, the ______ value of NUMBER from the associated error call is returned as the ____ ____ ____ ErrorSet ErrorSet expr ErrorSet ErrorSet expr _ value of ErrorSet. Note that ErrorSet is an expr, so U gets evaluated twice, once as the parameter is passed and once inside ErrorSet ErrorSet Catch ErrorSet ErrorSet Catch ErrorSet. [Actually, ErrorSet executes a Catch with tag Throw Throw !$ERROR!$, and so intercepts any Throw with this tag.] In addition, if the value of !*MSGP is non-NIL, the message from the error call is displayed upon both the standard output device and the currently selected output device unless the standard output device is not open. The message appears prefixed with 5 asterisks. The message list is displayed without top level parentheses. The message from the error call is available in the GLOBAL variable EMSG!*. The exact format of error messages generated by PSL functions described in this document may not be exactly as given and should not be relied upon to be in any particular form. Likewise, error numbers generated by PSL functions are not fixed. Currently, a number of different calls Error Error on Error result in the same error message, since the cause of the error is the same and the information to the user is the same. The error number is then used to indicate which function actually detected the error. [??? Describe Error # ranges here, or have in a file on [??? Describe Error # ranges here, or have in a file on [??? Describe Error # ranges here, or have in a file on machine ???] machine ???] machine ???] _ If no error occurs during the evaluation of U, the value of List Eval List Eval _ (List (Eval U)) is returned. If an error has been signalled and the value of !*BACKTRACE is non-NIL, a traceback sequence is initiated on the selected output device. The traceback displays information such as unbindings of FLUID variables, argument lists and so on in an implementation-- dependent format. Error Error ______ _______ _______ ___ ____ ________ ____ (Error NUMBER:integer MESSAGE:any): None Returned expr _______ MESSAGE is placed in the GLOBAL variable EMSG!* and the error ErrorSet ErrorSet number becomes the value of the surrounding ErrorSet (if any PSL Manual 7 February 1983 Error Handling and Recovery section 14.2 page 14.3 Break Break intervening Break loop is exited). FLUID variables and LOCAL bindings are unbound to return to the environment of the ErrorSet ErrorSet ErrorSet. GLOBAL variables are not affected by the process. Error Break Error Break Error actually signals a non-continuable error to the Break loop, and it subsequently does a throw with tag !$ERROR!$. ContinuableError ContinuableError ______ _______ _______ ___ ____ ____ ___ ____ (ContinuableError NUMBER:integer MESSAGE:any FORM:form): any expr _______ MESSAGE is placed in the GLOBAL variable EMSG!* and the error ErrorSet ErrorSet number becomes the value of the surrounding ErrorSet if the Break Break intervening Break loop is "QUIT" rather than "Continued" or "Retried". FLUID variables and LOCAL bindings are unbound to ErrorSet ErrorSet return to the environment of the ErrorSet. GLOBAL variables are Error Error not affected by the process. Error actually signals a Break Break continuable error to the Break loop, and it subsequently does a throw with tag !$ERROR!$. The FORM is stored in the GLOBAL variable ERRORFORM!*, for examination, editing or possible reevaluation after defining missing functions, etc. Setting up the ERRORFORM!* can get a bit MkQuote MkQuote tricky, often involving MkQuoteing of already evaluated arguments. The following MACRO may be useful. ContError ContError ____ ___ ___ _____ (ContError [ARGS:any]): any macro ____ The format of ARGS is (ErrorNumber, FormatString, {arguments to ____________ PrintF}, ReEvalForm). The FORMATSTRING is used with the BldMsg BldMsg following arguments in a call on BldMsg to build an error PrintF PrintF message. If the only argument to PrintF is a string, the BldMsg ____________ BldMsg FORMATSTRING may be omitted, and no call to BldMsg is made. The ReEvalForm is something like Foo(X, Y) which becomes list('Foo, MkQuote X, MkQuote Y) to be passed to the function ContinuableError ContinuableError ContinuableError. (DE DIVIDE (U, V) (COND((ZEROP V) (CONTERROR 99 "Attempt to divide by 0 in DIVIDE (DIVIDE U V (T (CONS (QUOTIENT U V) (REMAINDER U V))))) __________ ______ !*CONTINUABLEERROR [Initially: NIL] switch ________________ If !*CONTINUABLEERROR is T, then one is inside a continuable error. Error Handling and Recovery 7 February 1983 PSL Manual page 14.4 section 14.3 14.3. Break Loop 14.3. Break Loop 14.3. Break Loop Read/Eval/Print Read/Eval/Print On detecting an error, PSL normally enters a Read/Eval/Print loop called Break Break a Break loop. Here the user can examine the state of his computation, change the values of FLUIDs, or define missing functions. He can then ErrorSet ErrorSet dismiss the error call to the normal error handling mechanism (the ErrorSet above) or (in some situations) continue the computation. By setting the Break Break switch !*BREAK to NIL, all Break loops can be suppressed, and just an error message is displayed. __________ ______ !*BREAK [Initially: T] switch Break Break Controls whether the Break package is called before unwinding the stack on error. __________ ______ BREAKLEVEL!* [Initially: 0] global The current number of nesting level of breaks. __________ ______ MAXBREAKLEVEL!* [Initially: 5] global The maximum number of nesting levels of breaks permitted. Break Break The prompt "Break>" indicates that PSL has entered a Break loop. A message of the form "Continuation requires a value for ..." may also be printed, in which case the user is able to continue his computation by Break Break repairing the offending expression. By default, a Break loop uses the Read Eval Print Read Eval Print functions Read, Eval, and Print. This may be changed by setting BREAKREADER!*, BREAKEVALUATOR!*, or BREAKPRINTER!* to the appropriate function name. __________ ______ ERRORFORM!* [Initially: NIL] global Break Break Contains an expression to reevaluate inside a Break loop for continuable errors. [Not enough errors set this yet]. Used as a tag for various Error functions. Break __ Break Several ids, if typed at top-level, are special in a Break loop. These are used as commands, and are currently E, M, R, T, Q, A, I, and C. They call functions stored on their property lists under the indicator __ 'BreakFunction. These ids are special only at top-level, and do not cause any difficulty if used as variables inside expressions. However, they may not be simply typed at top-level to see their values. This is not expected to cause any difficulty. If it does, an escape command will be provided for examining the relevant variables. The meanings of these commands are: PSL Manual 7 February 1983 Error Handling and Recovery section 14.3 page 14.5 E Edit the value of ERRORFORM!*. This is the object printed in the "Continuation requires a value for ..." message. The function BreakEdit BreakEdit BreakEdit is the associated function called by this command. The Retry Retry Retry command (below) uses the corrected version of ERRORFORM!*. The currently available editors are described in Chapter 16. BreakErrmsg BreakErrmsg M Show the modified ERRORFORM!*. Calls the function BreakErrmsg. R Retry. This tries to evaluate the offending expression again, and continue the computation. It evaluates the value of ERRORFORM!*. This is often useful after defining a missing Edit Edit function, assigning a value to a variable, or using the Edit BreakRetry BreakRetry command, above. This command calls the function BreakRetry. Break Break C This causes the expression last printed by the Break loop to be returned as the value of the offending expression. This is often useful as an automatic stub. If an expression containing an Break Break undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. This BreakContinue BreakContinue command calls the function BreakContinue. Break Break Q Quit. This exits the Break loop by throwing to the closest ErrorSet BreakQuit ErrorSet BreakQuit surrounding ErrorSet. It calls the function BreakQuit. A Abort. This aborts to the top level, i.e., restarts PSL. It Reset Reset calls the function Reset. T Trace. This prints a backtrace of function calls on the stack except for those on the lists IGNOREDINBACKTRACE!* and BackTrace BackTrace INTERPRETERFUNCTIONS!*. It calls the function BackTrace. I Interpreter Trace. This prints a backtrace of only interpreted functions call on the stack except for those on the list InterpBackTrace InterpBackTrace INTERPRETERFUNCTIONS!*. It calls the function InterpBackTrace. An attempt to continue a non-continuable error with R or C prints a message and behaves as Q. __________ IGNOREDINBACKTRACE!* [Initially: '(Eval Apply FastApply CodeApply CodeEvalApply Catch ErrorSet EvProgN TopLoop BreakEval ______ BindEval Break Main)] global A list of function names that will not be printed by the commands Break Break I and T given within a Break loop. __________ ______ INTERPRETERFUNCTIONS!* [Initially: '(Cond Prog And Or ProgN SetQ)] global A list of function names that will not be printed by the command Break Break I given within a Break loop. Error Handling and Recovery 7 February 1983 PSL Manual page 14.6 section 14.3 The above two globals can be reset in an init file if the programmer desires to do so. The following is a slightly edited transcript, showing some of the BREAK options: PSL Manual 7 February 1983 Error Handling and Recovery section 14.3 page 14.7 % foo is an undefined function, so the following has two errors % in it 1> (Plus2 (foo 1)(foo 2)) ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 1)' Break loop 1 lisp break> (plus2 1 1) % We simply compute a value 2 % prints as 2 2 lisp break> c % continue with this value % it returns to compute "(foo 2)" ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 2)' Break loop 1 lisp break> 3 % again compute a value 3 2 lisp break> c % and return 5 % finally complete % Pretend that we had really meant to call "fee": 2> (de fee (x) (add1 x)) FEE 3> (plus2 (foo 1)(foo 2)) % now the bad expression ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 1)' Break loop 1 lisp break> e % lets edit it Type HELP<CR> for a list of commands. edit> p % print form (FOO 1) edit> (1 fee) % replace 1'st by "fee" edit> p % print again (FEE 1) edit> ok % we like it (FEE 1) 2 lisp break> m % show modified ErrorForm!* ErrorForm!* : `(FEE 1)' NIL 3 lisp break> r % Retry EVAL ErrorForm!* ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 2)' Break loop 1 lisp break> (de foo(x) (plus2 x 1)) % define foo FOO 2 lisp break> r % and retry 5 Error Handling and Recovery 7 February 1983 PSL Manual page 14.8 section 14.4 14.4. Interrupt Keys 14.4. Interrupt Keys 14.4. Interrupt Keys Need to "LOAD INTERRUPT;" to enable. This applies only to the DEC20. <Ctrl-T> indicates routine currently executing, gives the load average, and gives the location counter in octal; <Ctrl-G> returns you to the Top-Loop; <Ctrl-B> takes you into a lower-level Break loop. 14.5. Details on the Break Loop 14.5. Details on the Break Loop 14.5. Details on the Break Loop Break Error Break Error If the SWITCH !*BREAK is T, the function Break() is called by Error or ContinuableError ContinuableError ContinuableError before unwinding the stacks, or printing a backtrace. Break Break Input and output to/from Break loops is done from/to the values (channels) of BREAKIN!* and BREAKOUT!*. The channels selected on entrance to the Break Break Break loop are restored upon exit. __________ ______ BREAKIN!* [Initially: NIL] global Rds Rds So Rds chooses STDIN!*. __________ ______ BREAKOUT!* [Initially: NIL] global Similar to BREAKIN!*. Break Read-Eval-Print Break Read-Eval-Print Break is essentially a Read-Eval-Print function, called in the error context. Any FLUID may be printed or changed, function definitions Break TopLoop Break TopLoop changed, etc. The Break uses the normal TopLoop mechanism (including Catch TopLoop Catch TopLoop History), embedded in a Catch with tag !$BREAK!$. The TopLoop attempts to use the parent loop's TOPLOOPREAD!*, TOPLOOPPRINT!* and TOPLOOPEVAL!*; the BreakEval BreakEval __ BreakEval function first checks top-level ids to see if they have a special BREAKFUNCTION on their property lists, stored under 'BREAKFUNCTION. This is expected to be a function of no arguments, and is applied instead of Eval Eval Eval. 14.6. Some Convenient Error Calls 14.6. Some Convenient Error Calls 14.6. Some Convenient Error Calls The following functions may be useful in user packages: FatalError FatalError _ ___ ____ ________ ____ (FatalError S:any): None Returned expr PSL Manual 7 February 1983 Error Handling and Recovery section 14.6 page 14.9 (ProgN (ErrorPrintF "***** Fatal error: %s" S) (While T Quit)) RangeError RangeError ______ ___ _____ _______ __ ________ ____ ________ ____ (RangeError Object:any Index:integer Fn:function): None Returned expr (StdError (BldMsg "Index %r out of range for %p in %p" Index Object Fn)) StdError StdError _______ ______ ____ ________ ____ (StdError Message:string): None Returned expr (Error 99 Message) TypeError TypeError ________ ___ __ ________ ___ ___ ____ ________ ____ (TypeError Offender:any Fn:function Typ:any): None Returned expr (StdError (BldMsg "An attempt was made to do %p on %r, which is not %w" Fn Offender Typ)) UsageTypeError UsageTypeError ___ ___ __ ________ ___ ___ _____ ___ ____ ________ ____ (UsageTypeError Off:any Fn:function Typ:any Usage:any): None Returned expr (StdError (BldMsg "An attempt was made to use %r as %w in %p, where %w is needed" Offender Usage Fn Typ)) IndexError IndexError ________ ___ __ ________ ____ ________ ____ (IndexError Offender:any Fn:function): None Returned expr (UsageTypeError Offender Fn "an integer" "an index") NonPairError NonPairError ________ ___ __ ________ ____ ________ ____ (NonPairError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a pair") NonIDError NonIDError ________ ___ __ ________ ____ ________ ____ (NonIDError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "an identifier") NonNumberError NonNumberError ________ ___ __ ________ ____ ________ ____ (NonNumberError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a number") NonIntegerError NonIntegerError ________ ___ __ ________ ____ ________ ____ (NonIntegerError Offender:any Fn:function): None Returned expr Error Handling and Recovery 7 February 1983 PSL Manual page 14.10 section 14.6 (TypeError Offender Fn "an integer") NonPositiveIntegerError NonPositiveIntegerError ________ ___ __ ________ ____ ________ ____ (NonPositiveIntegerError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a non-negative integer") NonCharacterError NonCharacterError ________ ___ __ ________ ____ ________ ____ (NonCharacterError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a character") NonStringError NonStringError ________ ___ __ ________ ____ ________ ____ (NonStringError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a string") NonVectorError NonVectorError ________ ___ __ ________ ____ ________ ____ (NonVectorError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a vector") NonSequenceError NonSequenceError ________ ___ __ ________ ____ ________ ____ (NonSequenceError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a sequence") 14.7. Special Purpose Error Handlers 14.7. Special Purpose Error Handlers 14.7. Special Purpose Error Handlers [??? This needs to be rethought and reimplemented. Currently not [??? This needs to be rethought and reimplemented. Currently not [??? This needs to be rethought and reimplemented. Currently not installed. ???] installed. ???] installed. ???] It is possible to handle errors specially. The value of Error _ ____ ____ Error ERRORHANDLERS!* is an a-list of error number/handler pairs. If Error is Car Car called with a number which appears as the Car of an element of Cdr Cdr ERRORHANDLERS!*, its Cdr is taken to be a function of two variables, the error number and the error message, which is called instead. If called ContinuableError ContinuableError from ContinuableError with a non-NIL third argument, any value returned by the error handler is returned as the value of the function call. Throw Throw Otherwise, normal termination of the handler Throws to the closest ErrorSet ErrorSet surrounding ErrorSet. |
Added psl-1983/3-1/lpt/15-debug.lpt version [47126e95b6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Debugging Tools section 15.0 page 15.1 CHAPTER 15 CHAPTER 15 CHAPTER 15 DEBUGGING TOOLS DEBUGGING TOOLS DEBUGGING TOOLS 15.1. Introduction . . . . . . . . . . . . . . . 15.1 15.1.1. Brief Summary of Full Debug Package . . . . . 15.1 15.1.2. Mini-Trace Facility . . . . . . . . . . 15.2 15.1.3. Step . . . . . . . . . . . . . . . 15.3 .... 15.1.4. Functions Which Depend on Redefining User Functions..15.4 15.1.5. A Few Known Deficiencies. . . . . . . . . 15.5 15.2. Tracing Function Execution . . . . . . . . . . 15.5 15.2.1. Tracing Functions . . . . . . . . . . . 15.5 15.2.2. Saving Trace Output . . . . . . . . . . 15.6 15.2.3. Making Tracing More Selective . . . . . . . 15.7 15.2.4. Turning Off Tracing . . . . . . . . . . 15.9 15.2.5. Enabling Debug Facilities and Automatic Tracing of 15.9 Newly Defined Functions . . . . . . . . . 15.3. A Heavy Handed Backtrace Facility . . . . . . . . 15.10 15.4. Embedded Functions . . . . . . . . . . . . . 15.11 15.5. Counting Function Invocations . . . . . . . . . 15.12 15.6. Stubs . . . . . . . . . . . . . . . . . 15.12 15.7. Functions for Printing Useful Information . . . . . 15.13 15.8. Printing Circular and Shared Structures . . . . . . 15.13 15.9. Internals and Customization . . . . . . . . . . 15.14 15.9.1. User Hooks . . . . . . . . . . . . . 15.14 15.9.2. Functions Used for Printing/Reading . . . . . 15.15 15.10. Example . . . . . . . . . . . . . . . . 15.16 15.1. Introduction 15.1. Introduction 15.1. Introduction PSL offers a small group of debugging functions in a mini-trace package described in Section MINITRACE; in addition, there is a separate debugging package which is the subject of the bulk of this Chapter. To use the debugging package (LOAD DEBUG). An extensive example showing the use of the facilities in the debugging package can be found in Section 15.10. 15.1.1. Brief Summary of Full Debug Package 15.1.1. Brief Summary of Full Debug Package 15.1.1. Brief Summary of Full Debug Package The PSL debugging package contains a selection of functions that can be 1 used to aid program development and to investigate faulty programs. _______________ 1 Much of this Chapter was adapted from a paper by Norman and Morrison. Debugging Tools 7 February 1983 PSL Manual page 15.2 section 15.1 It contains the following facilities. - A trace package. This allows the user to see the arguments passed to and the values returned by selected functions. It is also possible to have traced interpreted functions print all the SetQ SetQ assignments they make with SetQ (see Section 15.2). - A backtrace facility. This allows one to see which of a set of selected functions were active as an error occurred (see Section 15.3). - Embedded functions make it possible to do everything that the trace package can do, and much more besides (see Section 15.4). This facility is available only in RLISP. - Some primitive statistics gathering (see Section 15.5). - Generation of simple stubs. If invoked, procedures defined as stubs simply print their argument and read a value to return (see Section 15.6). - Some functions for printing useful information, such as property lists, in an intelligible format (see Section 15.7). PrintX PrintX - PrintX is a function that can print circular and re-entrant lists and vectors, and so can sometimes allow debugging to proceed even RplacA RplacA in the face of severe damage caused by the wild use of RplacA and RplacD RplacD RplacD (see Section 15.8). [??? Install a feature BR and UNBR to wrap a break around functions. [??? Install a feature BR and UNBR to wrap a break around functions. [??? Install a feature BR and UNBR to wrap a break around functions. See the old mini-trace (PK:MINI-TRACE.RED). ???] See the old mini-trace (PK:MINI-TRACE.RED). ???] See the old mini-trace (PK:MINI-TRACE.RED). ???] 15.1.2. Mini-Trace Facility 15.1.2. Mini-Trace Facility 15.1.2. Mini-Trace Facility A small trace package is provided in the bare PSL and RLISP. This Tr Tr provides a command Tr for tracing LISP function calls, as does the full UnTr UnTr Debug package. This command and the associated command UnTr are used in the form: Tr Tr Tr <function name>, <function name>,..., <function name>; or Tr Tr Tr( <function name>, <function name>,..., <function name>); from RLISP, and Tr Tr (Tr <function name> <function name> ... <function name>) from LISP. PSL Manual 7 February 1983 Debugging Tools section 15.1 page 15.3 Tr Tr _____ __ _________ _____ (Tr [FNAME:id]): Undefined macro UnTr UnTr _____ __ _________ _____ (UnTr [FNAME:id]): Undefined macro Mini-Trace also contains the capability for tracing interpreted functions Trst Trst at a deeper level. Trst causes the body of an interpreted function to be Trst Trst redefined so that all assignments in its body are printed. Calling Trst on Tr UnTrst Tr UnTrst a function has the effect of doing a Tr on it too. The function UnTrst is Trst Trst used to turn off the effects of Trst. These functions are used in the same Tr UnTr Tr UnTr way as Tr and UnTr. Trst Trst _____ __ _________ _____ (Trst [FNAME:id]): Undefined macro UnTrst UnTrst _____ __ _________ _____ (UnTrst [FNAME:id]): Undefined macro Tr Trst Tr Trst Note that only the functions Tr and Trst are in Mini-Trace. However invoking either of them causes the debug package to be loaded, making the rest of the functions in Debug available. Do (HELP TRACE) for more information, or see Section 15.2. 15.1.3. Step 15.1.3. Step 15.1.3. Step Step Step _ ____ ___ ____ (Step F:form): any expr Step Step _ Step is a loadable option (LOAD STEP). It evaluates the form F, _ single-stepping. F is printed, preceded by -> on entry, <-> for _ macro expansions. After evaluation, F is printed preceded by <- and followed by the result of evaluation. A single character is read at each step to determine the action to be taken: <Ctrl-N> (Next) Step to the Next thing. The stepper continues until the next thing to print out, and it accepts another command. Space Go to the next thing at this level. In other words, continue to evaluate at this level, but don't step anything at lower levels. This is a good way to skip over parts of the evaluation that don't interest you. <Ctrl-U> (Up) Continue evaluating until we go up one level. This is like the space command, only more so; it skips over anything on the current level as well as lower levels. Debugging Tools 7 February 1983 PSL Manual page 15.4 section 15.1 <Ctrl-X> (eXit) Exit; finish evaluating without any more stepping. <Ctrl-G> or <Ctrl-P> (Grind) Grind (i.e. prettyprint) the current form. <Ctrl-R> Grind the form in Rlisp syntax. <Ctrl-E> (Editor) Invoke the structure editor on the current form. <Ctrl-B> (Break) Enter a break loop from which you can examine the values of variables and other aspects of the current environment. <Ctrl-L> Redisplay the last 10 pending forms. ? Display the help file. H H _ To step through the evaluation of function H on argument X do (Step '(H X)) 15.1.4. Functions Which Depend on Redefining User Functions 15.1.4. Functions Which Depend on Redefining User Functions 15.1.4. Functions Which Depend on Redefining User Functions A number of facilities in Debug depend on redefining user functions, so that they may log or print behavior if called. The Debug package tries to redefine user functions once and for all, and then keep specific information about what is required at run time in a table. This allows considerable flexibility, and is used for a number of different facilities, including trace/traceset in Section 15.2, a backtrace facility in Section 15.3, some statistics gathering in Section 15.5 and embedding functions in Section 15.4. Some facilities, like trace and EMB (the embedding function), only take effect if further action is requested on specific user functions. Others, like backtrace and statistics, are of a more global nature. Once one of these global facilities is enabled it applies to all functions which have Restr Restr been made "known" to Debug. To undo this, use Restr defined in Section 15.2.4. 15.1.5. A Few Known Deficiencies 15.1.5. A Few Known Deficiencies 15.1.5. A Few Known Deficiencies Cons Cons - An attempt to trace certain system functions (e.g. Cons) causes the trace package to overwrite itself. Given the names of functions that cause this sort of trouble it is fairly easy to change the trace package to deal gracefully with them - so report PSL Manual 7 February 1983 Debugging Tools section 15.1 page 15.5 trouble to a system expert. - The Portable LISP Compiler uses information about registers which certain system functions destroy. Tracing these functions may make the optimizations based thereon invalid. The correct way of handling this problem is currently under consideration. In the mean time you should avoid tracing any functions with the ONEREG or TWOREG flags. 15.2. Tracing Function Execution 15.2. Tracing Function Execution 15.2. Tracing Function Execution 15.2.1. Tracing Functions 15.2.1. Tracing Functions 15.2.1. Tracing Functions To see when a function gets called, what arguments it is given and what value it returns, do (TR functionname) or if several functions are of interest, (TR name1 name2 ...) Tr Tr _____ __ _________ _____ (Tr [FNAME:id]): Undefined macro ____ _____ _____ ____ _____ _____ ____ _____ _____ expr fexpr nexpr expr fexpr nexpr If the specified functions are defined (as expr, fexpr, nexpr or _____ _____ _____ macro Tr macro Tr macro), Tr modifies the function definition to include print statements. The following example shows the style of output produced by this sort of tracing: The input... (DE XCDR (A) (CDR A) %A very simple function) (TR XCDR) (XCDR '(P Q R)) gives output... XCDR entered A: (P Q R) XCDR = (Q R) Interpreted functions can also be traced at a deeper level. Debugging Tools 7 February 1983 PSL Manual page 15.6 section 15.2 Trst Trst _____ __ _________ _____ (Trst [FNAME:id]): Undefined macro (TRST name1 name2 ...) causes the body of an interpreted function to be redefined so SetQ SetQ that all assignments (made with SetQ) in its body are printed. Trst Trst Calling Trst on a function automatically has the effect of doing Tr Tr a Tr on it too, so that it is not possible to have a function Trst Tr Trst Tr subject to Trst but not Tr. Trace output often appears mixed up with output from the program being Tr Tr studied, and to avoid too much confusion Tr arranges to preserve the column in which printing was taking place across any output that it generates. If trace output is produced as part of a line has been printed, the trace data are enclosed in markers '<' and '>', and these symbols are placed on the line so as to mark out the amount of printing that had occurred before trace was entered. __________ ______ !*NOTRARGS [Initially: NIL] switch If !*NOTRARGS is T, printing of the arguments of traced functions is suppressed. 15.2.2. Saving Trace Output 15.2.2. Saving Trace Output 15.2.2. Saving Trace Output The trace facility makes it possible to discover in some detail how a function is used, but in certain cases its direct use results in the generation of vast amounts of (mostly useless) print-out. There are several options. One is to make tracing more selective (see Section 15.2.3). The other, discussed here, is to either print only the most recent information, or dump it all to a file to be perused at leisure. Debug has a ring buffer in which it saves information to reproduce the Tr Trst Tr Trst most recent information printed by the trace facility (both Tr and Trst). Tr Tr To see the contents of this buffer use Tr without any arguments (TR) NewTrBuff NewTrBuff _ _______ _________ ____ (NewTrBuff N:integer): Undefined expr To set the number of entries retained to n use (NEWTRBUFF n) Initially the number of entries in the ring buffer is 5. PSL Manual 7 February 1983 Debugging Tools section 15.2 page 15.7 __________ ______ !*TRACE [Initially: T] switch Enables runtime printing of trace information for functions which have been traced. Turning off the TRACE switch (OFF TRACE) suppresses the printing of any trace information at run time; it is still saved in the ring buffer. Thus a useful technique for isolating the function in which an error occurs is to trace a large number of candidate functions, do OFF TRACE and after the failure look at the latest trace Tr Tr information by calling Tr with no arguments. TrOut TrOut _____ __ _________ ____ (TrOut [FNAME:id]): Undefined expr StdTrace StdTrace _________ ____ (StdTrace ): Undefined expr Normally trace information is directed to the standard output, rather than the currently selected output. To send it elsewhere use the statement (TROUT filename) The statement (STDTRACE) closes that file and cause future trace output to be sent to the standard output. Note that output saved in the ring buffer is sent to the currently selected output, not that selected by TrOut TrOut TrOut. 15.2.3. Making Tracing More Selective 15.2.3. Making Tracing More Selective 15.2.3. Making Tracing More Selective TraceCount TraceCount _ _______ _________ ____ (TraceCount N:integer): Undefined expr TraceCount TraceCount The function (TraceCount n) can be used to switch off trace TraceCount TraceCount output. If n is a positive number, after a call to (TraceCount n) the next n items of trace output that are generated are not TraceCount TraceCount printed. (TraceCount n) with n negative or zero switches all TraceCount TraceCount trace output back on. (TraceCount NIL) returns the residual count, i.e. the number of additional trace entries that are suppressed. To get detailed tracing in the stages of a calculation that lead up to an error, try Debugging Tools 7 February 1983 PSL Manual page 15.8 section 15.2 (TRACECOUNT 1000000) % or some other suitable large number (TR ...) % as required %run the failing problem (TRACECOUNT NIL) It is now possible to calculate how many trace entries occurred before the TraceCount TraceCount error, and so the problem can now be re-run with TraceCount set to some number slightly less than that. TraceCount TraceCount An alternative to the use of TraceCount for getting more selective trace TrIn TrIn output is TrIn. TrIn TrIn _____ __ _________ _____ (TrIn [FNAME:id]): Undefined macro TrIn TrIn To use TrIn, establish tracing for a collection of functions, Tr TrIn Tr TrIn using Tr in the normal way. Then do TrIn on some small Tr Tr collection of other functions. The effect is just as for Tr, except that trace output is inhibited except if control is TrIn TrIn dynamically within the TrIn functions. This makes it possible to Tr Tr use Tr on a number of heavily used general purpose functions, and then only see the calls to them that occur within some specific subpart of your entire program. __________ ______ TRACEMINLEVEL!* [Initially: 0] global __________ ______ TRACEMAXLEVEL!* [Initially: 1000] global The global variables TRACEMINLEVEL!* and TRACEMAXLEVEL!* (whose values should be non-negative integers) are the minimum and maximum depths of recursion at which to print trace information. Thus if you only want to see top level calls of a highly Length Length recursive function (like a simple-minded version of Length) simply do (SETQ TRACEMAXLEVEL!* 1) 15.2.4. Turning Off Tracing 15.2.4. Turning Off Tracing 15.2.4. Turning Off Tracing If a particular function no longer needs tracing, do (UNTR functionname) or (UNTR name1 name2 ...) PSL Manual 7 February 1983 Debugging Tools section 15.2 page 15.9 UnTr UnTr _____ __ _________ _____ (UnTr [FNAME:id]): Undefined macro This merely suppresses generation of trace output. Other information, such as invocation counts, backtrace information, and the number of arguments is retained. To completely destroy information about a function use (RESTR name1 name2 ...) Restr Restr _____ __ _________ ____ (Restr [FNAME:id]): Undefined expr This returns the function to it's original state. To suppress traceset output without suppressing normal trace output use (UNTRST name1 name2 ...) UnTrst UnTrst _____ __ _________ _____ (UnTrst [FNAME:id]): Undefined macro UnTr Trst UnTrst UnTr Trst UnTrst UnTring a Trsted function also UnTrst's it. TrIn UnTr UnTrst TrIn UnTr UnTrst TrIn in Section 15.2.3 is undone by UnTr (but not by UnTrst). 15.2.5. Enabling Debug Facilities and Automatic Tracing 15.2.5. Enabling Debug Facilities and Automatic Tracing 15.2.5. Enabling Debug Facilities and Automatic Tracing Under the influence of (ON TRACEALL) PutD PutD PutD PutD any functions successfully defined by PutD are traced. Note that if PutD fails (as might happen under the influence of the LOSE flag) no attempt is made to trace the function. Btr TrCount Btr TrCount To enable those facilities (such as Btr in Section 15.3 and TrCount in Section 15.5) which require redefinition, but without tracing, use (ON INSTALL) Thus, a common scenario might look like (ON INSTALL) (DSKIN "MYFNS.SL") (OFF INSTALL) which would enable the backtrace and statistics routines to work with all the functions defined in the MYFNS file. Debugging Tools 7 February 1983 PSL Manual page 15.10 section 15.2 __________ ______ !*INSTALL [Initially: NIL] switch PutD PutD Causes DEBUG to know about all functions defined with PutD. __________ ______ !*TRACEALL [Initially: NIL] switch PutD PutD Causes all functions defined with PutD to be traced. 15.3. A Heavy Handed Backtrace Facility 15.3. A Heavy Handed Backtrace Facility 15.3. A Heavy Handed Backtrace Facility The backtrace facility allows one to see which of a set of selected Btr Btr functions were active as an error occurred. The function Btr gives the backtrace information. The information kept is controlled by two switches: !*BTR and !*BTRSAVE. When backtracing is enabled (BTR is on), a stack is kept of functions entered but not left. This stack records the names of functions and the arguments that they were called with. If a function returns normally the stack is unwound. If however the function fails, the stack is left alone by the normal LISP error recovery processes. Btr Btr _____ __ _________ _____ (Btr [FNAME:id]): Undefined macro Btr Btr When called with no arguments, Btr prints the backtrace information available. When called with arguments (which should be function names), the stack is reset to NIL, and the functions named are added to the list of functions Debug knows about. ResBtr ResBtr _____ __ _________ ____ (ResBtr [FNAME:id]): Undefined expr ResBtr ResBtr ResBtr resets the backtrace stack to NIL. __________ ______ !*BTR [Initially: T] switch If !*BTR is T, it enables backtracing of functions which the Debug package has been told about. If it is NIL, backtrace information is not saved. __________ ______ !*BTRSAVE [Initially: T] switch Controls the disposition of information about functions which ErrorSet ErrorSet failed within an ErrorSet. If it is on, the information is saved separately and printed when the stack is printed. If it is off, the information is thrown away. PSL Manual 7 February 1983 Debugging Tools section 15.4 page 15.11 15.4. Embedded Functions 15.4. Embedded Functions 15.4. Embedded Functions Embedding means redefining a function in terms of its old definition, usually with the intent that the new version does some tests or printing, uses the old one, does some more printing and then returns. If ff is a function of two arguments, it can be embedded using a statement of the form: SYMBOLIC EMB PROCEDURE ff(A1,A2); << PRINT A1; PRINT A2; PRINT ff(A1,A2) >>; Tr Tr The effect of this particular use of embed is broadly similar to a call Tr ff, and arranges that whenever ff is called it prints both its arguments and its result. After a function has been embedded, the embedding can be temporarily removed by the use of UNEMBED ff; and it can be reinstated by EMBED ff; This facility is available only to RLISP users. 15.5. Counting Function Invocations 15.5. Counting Function Invocations 15.5. Counting Function Invocations __________ ______ !*TRCOUNT [Initially: T] switch Enables counting invocations of functions known to Debug. If the switch TRCOUNT is ON, the number of times user functions known to Debug are entered is counted. The statement (ON TRCOUNT) also resets that count to zero. The statement (OFF TRCOUNT) causes a simple histogram of function invocations to be printed. Tr Tr If regular tracing (provided by Tr) is not desired, but you wish to count the function invocations, use (TRCNT name1 name2 ...) Debugging Tools 7 February 1983 PSL Manual page 15.12 section 15.5 TrCnt TrCnt _____ __ _________ _____ (TrCnt [FNAME:id]): Undefined macro See also Section 15.2.5. 15.6. Stubs 15.6. Stubs 15.6. Stubs Stubs are useful in top-down program development. If a stub is invoked, it prints its arguments and asks for a value to return. Stub Stub __________ ____ _____ (Stub [FuncInvoke:form]): macro __________ Each FUNCINVOKE must be of the form (id arg1 arg2 ...), where ____ ____ ____ Stub expr Stub expr there may be zero arguments. Stub defines an expr for each form with name id and formal arguments arg1, arg2, etc. If executed such a stub prints its arguments and reads a value to return. The statement (STUB (FOO U V)) ____ ____ ____ expr Foo expr Foo defines an expr, Foo, of two arguments. FStub FStub __________ ____ ___ _____ (FStub [FuncInvoke:form]): Nil macro _____ _____ _____ FStub Stub fexpr FStub Stub fexpr FStub does the same as Stub but defines fexprs. At present the currently (i.e. when the stub is executed) selected input and output are used. This may be changed in the future. Algebraic and _____ _____ _____ macro macro possibly macro stubs may be implemented in the future. 15.7. Functions for Printing Useful Information 15.7. Functions for Printing Useful Information 15.7. Functions for Printing Useful Information PList PList _ __ _____ (PList [X:id]): macro (PLIST id1 id2 ...) __ prints the property lists of the specified ids in an easily readable form. Ppf Ppf _____ __ _____ (Ppf [FNAME:id]): macro (PPF fn1 fn2 ...) prints the definitions and other useful information about the PSL Manual 7 February 1983 Debugging Tools section 15.7 page 15.13 specified functions. 15.8. Printing Circular and Shared Structures 15.8. Printing Circular and Shared Structures 15.8. Printing Circular and Shared Structures Some LISP programs rely on parts of their data structures being shared, Eq Equal Eq Equal so that an Eq test can be used rather than the more expensive Equal one. Other programs (either deliberately or by accident) construct circular RplacA RplacD RplacA RplacD lists through the use of RplacA or RplacD. Such lists can be displayed by PrintX PrintX use of the function PrintX. This function also prints circular vectors. PrintX PrintX _ ___ ___ ____ (PrintX A:any): NIL expr If given a normal list the behavior of this function is similar Print Print to that of Print; if it is given a looped or re-entrant data structures it prints it in a special format. The representation PrintX PrintX used by PrintX for re-entrant structures is based on the idea of labels for those nodes in the structure that are referred to more than once. Consider the list created by the operations: (SETQ R '(S W)) (RPLACA R (CDR R)) Print Print _ The function Print called on the list R gives ((W) W) PrintX PrintX _ _ If PrintX is called on the list R, it discovers that the list (W) is referred to twice, and invents the label %L1 for it. The structure is then printed as (%L1: (W) . %L1) %L1: sets the label, and the other instance of %L1 refers back to it. Labeled sublists can appear anywhere within the list being printed. Thus the list created by the following statements (SETQ L '(A B C)) (SETQ K (CDR L)) (SETQ X (CONS L K)) which is printed as ((A B C) B C) Print PrintX Print PrintX by Print could be printed by PrintX as Debugging Tools 7 February 1983 PSL Manual page 15.14 section 15.8 ((A %L1, B C) . %L1) A label set with a comma (rather than a colon) is a label for part of a list, not for the sublist. __________ ______ !*SAVENAMES [Initially: NIL] switch PrintX PrintX If on, names assigned to substructures by PrintX are retained from one use to the next. Thus substructures common to different items will be shown as the same. 15.9. Internals and Customization 15.9. Internals and Customization 15.9. Internals and Customization This Section describes some internal details of the Debug package which may be useful in customizing it for specific applications. The reader is urged to consult the source for further details. 15.9.1. User Hooks 15.9.1. User Hooks 15.9.1. User Hooks These are all global variables whose values are normally NIL. If ____ ____ ____ expr expr non-NIL, they should be exprs taking the number of variables specified, and are called as specified. __________ ______ PUTDHOOK!* [Initially: NIL] global Takes one argument, the function name. It is called after the function has been defined, and any tracing under the influence of !*TRACEALL or !*INSTALL has taken place. It is not called if the function cannot be defined (as might happen if the function has been flagged LOSE). __________ ______ TRACENTRYHOOK!* [Initially: NIL] global Takes two arguments, the function name and a list of the actual arguments. It is called by the trace package if a traced function is entered, but before it is executed. The execution of a surrounding EMB function takes place after TRACENTRYHOOK!* is called. This is useful if you need to call special user-provided print routines to display critical data structures, as are TRACEXITHOOK!* and TRACEXPANDHOOK!*. __________ ______ TRACEXITHOOK!* [Initially: NIL] global Takes two arguments, the function name and the value. It is called after the function has been evaluated. PSL Manual 7 February 1983 Debugging Tools section 15.9 page 15.15 __________ ______ TRACEXPANDHOOK!* [Initially: NIL] global _____ _____ _____ macro macro Takes two arguments, the function name and the macro expansion. _____ _____ _____ _____ _____ _____ macro macro macro macro It is only called for macros, and is called after the macro is expanded, but before the expansion has been evaluated. __________ ______ TRINSTALLHOOK!* [Initially: NIL] global Takes one argument, a function name. It is called if a function is redefined by the Debug package, as for example when it is first traced. It is called before the redefinition takes place. 15.9.2. Functions Used for Printing/Reading 15.9.2. Functions Used for Printing/Reading 15.9.2. Functions Used for Printing/Reading _____ _____ _____ EXPRS EXPRS These should all contain EXPRS taking the specified number of arguments. The initial values are given in square brackets. __________ ______ PPFPRINTER!* [Initially: PRINT] global Ppf Ppf Takes one argument. It is used by Ppf to print the body of an interpreted function. __________ ______ PROPERTYPRINTER!* [Initially: PRETTYPRINT] global PList PList Takes one argument. It is used by PList to print the values of properties. __________ ______ STUBPRINTER!* [Initially: PRINTX] global Stub/FStub Stub/FStub Takes one argument. Stubs defined with Stub/FStub use it to print their arguments. __________ ______ STUBREADER!* [Initially: !-REDREADER] global Stub/FStub Stub/FStub Takes no arguments. Stubs defined with Stub/FStub use it to read their return value. __________ ______ TREXPRINTER!* [Initially: PRINT] global Takes one argument. It is used to print the expansions of traced _____ _____ _____ macro macro macros. Debugging Tools 7 February 1983 PSL Manual page 15.16 section 15.9 __________ ______ TRPRINTER!* [Initially: PRINTX] global Takes one argument. It is used to print the arguments and values of traced functions. __________ ______ TRSPACE!* [Initially: 0] global Controls indentation. 15.10. Example 15.10. Example 15.10. Example This contrived example demonstrates many of the available features. It is a transcript of an actual PSL session. PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.17 @PSL PSL 3.1, 15-Nov-82 1 lisp> (LOAD DEBUG) NIL 2 lisp> (DE FOO (N) 2 lisp> (PROG (A) 2 lisp> (COND ((AND (NEQ (REMAINDER N 2) 0) (LESSP N 0)) 2 lisp> (SETQ A (CAR N)))) %Should err out if N is a n 2 lisp> (COND ((EQUAL N 0) (RETURN 'BOTTOM))) 2 lisp> (SETQ N (DIFFERENCE N 2)) 2 lisp> (SETQ A (BAR N)) 2 lisp> (SETQ N (DIFFERENCE N 2)) 2 lisp> (RETURN (LIST A (BAR N) A)))) FOO 3 lisp> (DE FOOBAR (N) 3 lisp> (PROGN (FOO N) NIL)) FOOBAR 4 lisp> (TR FOO FOOBAR) (FOO FOOBAR) 5 lisp> (PPF FOOBAR FOO) EXPR procedure FOOBAR(N) [TRACED;Invoked 0 times]: PROGN (FOO N) NIL EXPR procedure FOO(N) [TRACED;Invoked 0 times]: PROG (A) (COND ((AND (NEQ (REMAINDER N 2) 0) (LESSP N 0)) (SETQ A (CAR N)))) (COND ((EQUAL N 0) (RETURN 'BOTTOM))) (SETQ N (DIFFERENCE N 2)) (SETQ A (BAR N)) (SETQ N (DIFFERENCE N 2)) (RETURN (LIST A (BAR N) A)) (FOOBAR FOO) 6 lisp> (ON COMP) NIL 7 lisp> (DE BAR (N) 7 lisp> (COND ((EQUAL (REMAINDER N 2) 0) (FOO (TIMES 2 (QUOTIENT N 7 lisp> (T (FOO (SUB1 (TIMES 2 (QUOTIENT N 4))))))) *** (BAR): base 275266, length 21 words BAR 8 lisp> (OFF COMP) NIL 9 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered Debugging Tools 7 February 1983 PSL Manual page 15.18 section 15.10 N: 8 FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 10 lisp> % Notice how in the above PRINTX printed the return values 10 lisp> % to show shared structure 10 lisp> (TRST FOO) (FOO) 11 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered N: 8 N := 6 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) A := (BOTTOM BOTTOM BOTTOM) N := 4 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.19 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 12 lisp> (TR BAR) (BAR) 13 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered N: 8 BAR being entered A1: 6 FOO (level 2) being entered N: 2 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) BAR being entered A1: 4 FOO (level 2) being entered N: 2 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM Debugging Tools 7 February 1983 PSL Manual page 15.20 section 15.10 FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 14 lisp> (OFF TRACE) NIL 15 lisp> (FOOBAR 8) NIL 16 lisp> (TR) *** Start of saved trace information *** BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL *** End of saved trace information *** NIL 17 lisp> (FOOBAR 13) ***** An attempt was made to do CAR on `-1', which is not a pair Break loop 18 lisp break>> Q 19 lisp> (TR) *** Start of saved trace information *** FOO being entered N: 13 BAR being entered A1: 11 FOO (level 2) being entered N: 3 BAR (level 2) being entered A1: 1 FOO (level 3) being entered N: -1 *** End of saved trace information *** NIL 20 lisp> (BTR) *** Backtrace: *** These functions were left abnormally: FOO N: -1 BAR A1: 1 FOO N: 3 BAR A1: 11 FOO N: 13 FOOBAR PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.21 N: 13 *** End of backtrace *** NIL 21 lisp> (STUB (FOO N)) *** Function `FOO' has been redefined NIL 22 lisp> (FOOBAR 13) Stub FOO called N: 13 Return? : 22 lisp> (BAR (DIFFERENCE N 2)) Stub FOO called N: 3 Return? : 22 lisp> (BAR (DIFFERENCE N 2)) Stub FOO called N: -1 Return? : 22 lisp> 'ERROR NIL 23 lisp> (TR) *** Start of saved trace information *** BAR being entered A1: 11 BAR (level 2) being entered A1: 1 BAR (level 2) = ERROR BAR = ERROR FOOBAR = NIL *** End of saved trace information *** NIL 24 lisp> (OFF TRCOUNT) FOOBAR(6) ****************** BAR(16) ************************************************ NIL 22 lisp> (QUIT) |
Added psl-1983/3-1/lpt/16-editor.lpt version [78cbe45cb5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 EDITOR section 16.0 page 16.1 CHAPTER 16 CHAPTER 16 CHAPTER 16 EDITORS EDITORS EDITORS 16.1. A Mini-Structure Editor . . . . . . . . . . . 16.1 16.2. The EMODE Screen Editor . . . . . . . . . . . 16.3 16.2.1. Windows and Buffers in Emode . . . . . . . 16.5 16.3. Introduction to the Full Structure Editor . . . . . 16.6 16.4. User Entry to Editor . . . . . . . . . . . . 16.6 16.5. Editor Command Reference . . . . . . . . . . . 16.8 16.1. A Mini Structure-Editor 16.1. A Mini Structure-Editor 16.1. A Mini Structure-Editor PSL and RLISP provide a fairly simple structure editor, essentially a subset of the structure editor described below in section FULL-STRUCTURE-EDITOR. This mini editor is usually resident in PSL and RLISP, or can be LOADed. It is useful for correcting errors in input, often via the E option in the BREAK loop. Do HELP(EDITOR) for more information. Edit Edit To edit an expression, call the function Edit with the expression as an argument. The edited copy is returned. To edit the definition of a EditF EditF function, call EditF with the function name as an argument. In the editor, the following commands are available (N indicates a _______ non-negative integer): P P ____ P edit Prints the subexpression under consideration. On entry, this is the entire expression. This only prints down PLEVEL levels, replacing all edited subexpressions by ***. PLEVEL is initially 3. PL PL _ ____ PL (N) edit _ Changes PLEVEL to N. ____ _______ ____ _______ ____ _______ N edit-command N _______ edit-command N:integer edit-command Sets the subexpression under consideration to be the nth subexpression of the current one. That is, walk down to the nth subexpression. EDITOR 7 February 1983 PSL Manual page 16.2 section 16.1 ____ _______ ____ _______ ____ _______ -N edit-command -N _______ edit-command -N:integer edit-command Cdr Cdr Sets the current subexpression to be the nth Cdr of the current one. UP UP ____ UP edit Go to the subexpression you were in just before this one. T T ____ T edit Go to the top of the original expression. F F _ ____ F (S) edit _ Find the first occurrence of the S-expression S. The test is Equal Eq Equal Eq performed by Equal, not Eq. The current level is set to the _ first level in which S was found. ____ _______ ____ _______ ____ _______ N edit-command N _______ edit-command (N:integer) edit-command Delete the Nth element of the current expression. ____ _______ ____ _______ ____ _______ N edit-command N _______ ___ edit-command (N:integer [ARG]) edit-command ___ Replace the Nth element by ARGs. ____ _______ ____ _______ ____ _______ -N edit-command -N _______ ___ edit-command (-N:integer [ARG]) edit-command ___ Insert the elements ARGs before the nth element. R R __ __ ____ (R S1 S2) edit Replace all occurrences of S1 (in the tree you are placed at) by S2. B B ____ B edit Break Break Enter a Break loop under the editor. PSL Manual 7 February 1983 EDITOR section 16.1 page 16.3 OK OK ____ OK edit Leave the editor, returning the edited expression. HELP HELP ____ HELP edit Print an explanatory message. Break Break If the editor is called from a Break loop, the edited value is assigned back to ERRORFORM!*. 16.2. The EMODE Screen Editor 16.2. The EMODE Screen Editor 16.2. The EMODE Screen Editor EMODE is an EMACS-like screen editor, written entirely in PSL. To invoke EMODE, call the function EMODE after LOADing the EMODE module. EMODE is modeled after EMACS, so use that fact as a guide. After starting up EMODE, you can use one of the following commands to exit. <Ctrl-X Ctrl-Z> "quits" to the EXEC (you can continue or start again). <Ctrl-Z Ctrl-Z> goes back into "normal" I/O mode. EMODE is built to run on a Teleray terminal as the default. To use some other terminal you must LOAD in a set of different driver functions after loading EMODE. The following drivers are currently available: - HP2648A - TELERAY - VT100 - VT52 - AAA [Ann Arbor Ambassador] The sources for these files are on <PSL.EMODE> (logical name PE:). It should be quite easy to modify one of these files for other terminals. See the file PE:TERMINAL-DRIVERS.TXT for some more information on how this works. An important (but currently somewhat bug-ridden) feature of EMODE is the ability to evaluate expressions that are in your buffer. Use <Meta-E> to evaluate the expression starting on the current line. <Meta-E> (normally) automatically enters two window mode if anything is "printed" to the OUT_WINDOW buffer, which is shown in the lower window. If you don't want EDITOR 7 February 1983 PSL Manual page 16.4 section 16.2 to see things being printed to the output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode if something is printed to OUT_WINDOW. You must still use the "<Ctrl-X> 1" command to enter one window mode initially. You may also find the <Ctrl-Meta-Y> command useful. This inserts into the current buffer the text printed as a result of the last <Meta-E>. The function "PrintAllDispatch" prints out the current dispatch table. You must call EMODE before this table is set up. While in EMODE, the <Meta-?> (meta-question mark) character asks for a command character and tries to print information about it. The basic dispatch table is (roughly) as follows: Character Function Comments <Ctrl-@> SETMARK <Ctrl-A> !$BEGINNINGOFLINE <Ctrl-B> !$BACKWARDCHARACTER <Ctrl-D> !$DELETEFORWARDCHARACTER <Ctrl-E> !$ENDOFLINE <Ctrl-F> !$FORWARDCHARACTER Linefeed !$CRLF Acts like carriage return <Ctrl-K> KILL_LINE <Ctrl-L> FULLREFRESH Return !$CRLF <Ctrl-N> !$FORWARDLINE <Ctrl-O> OPENLINE <Ctrl-P> !$BACKWARDLINE <Ctrl-R> Backward search for string, type a carriage return to terminate the string <Ctrl-S> Forward search for string <Ctrl-U> Repeat a command. Asks for count (terminate with a carriage return), then it asks for the command character <Ctrl-V> DOWNWINDOW <Ctrl-W> KILL_REGION <Ctrl-X> !$DOCNTRLX As in EMACS, <Ctrl-X> is a prefix for "fancier" commands <Ctrl-Y> INSERT_KILL_BUFFER Yanks back killed text <Ctrl-Z> DOCONTROLMETA As in EMACS, acts like <Ctrl-Meta-> escape ESCAPEASMETA As in EMACS, escape acts like the <Meta-> key rubout !$DELETEBACKWARDCHARACTER <Ctrl-Meta-B> BACKWARD_SEXPR PSL Manual 7 February 1983 EDITOR section 16.2 page 16.5 <Ctrl-Meta-F> FORWARD_SEXPR <Ctrl-Meta-K> KILL_FORWARD_SEXPR <Ctrl-Meta-Y> INSERT_LAST_EXPRESSION Insert the last "expression" typed as the result of a <Meta-E> <Ctrl-Meta-Z> OLDFACE Leave EMODE, go back to "regular" RLISP <Meta-Ctrl-rubout> KILL_BACKWARD_SEXPR <Meta-<> !$BEGINNINGOFBUFFER As in EMACS, move to beginning of buffer <Meta->> !$ENDOFBUFFER As in EMACS, move to end of buffer <Meta-?> !$HELPDISPATCH Asks for a character, tries to print information about it <Meta-B> BACKWARD_WORD <Meta-D> KILL_FORWARD_WORD <Meta-E> Evaluate an expression <Meta-V> UPWINDOW As in EMACS, move up a window <Meta-W> COPY_REGION <Meta-X> !$DOMETAX As in EMACS, <Meta-X> is another prefix for "fancy" stuff <Meta-Y> UNKILL_PREVIOUS As in EMACS <Meta-Rubout> KILL_BACKWARD_WORD <Ctrl-X> <Ctrl-B> PRINTBUFFERNAMES Prints a list of buffers <Ctrl-X> <Ctrl-R> CNTRLXREAD Read a file into the buffer <Ctrl-X> <Ctrl-W> CNTRLXWRITE Write the buffer out to a file <Ctrl-X> <Ctrl-X> EXCHANGEPOINTANDMARK <Ctrl-X> <Ctrl-Z> As in EMACS, exits to the EXEC <Ctrl-X> 1 ONEWINDOW Go into one window mode <Ctrl-X> 2 TWOWINDOWS Go into two window mode <Ctrl-X> B CHOOSEBUFFER EMODE asks for a buffer name, and then puts you in that buffer <Ctrl-X> O OTHERWINDOW Select other window <Ctrl-X> P WRITESCREENPHOTO Write a "photograph" of the screen to a file 16.2.1. Windows and Buffers in Emode 16.2.1. Windows and Buffers in Emode 16.2.1. Windows and Buffers in Emode [??? This section to be completed at a later date. ???] [??? This section to be completed at a later date. ???] [??? This section to be completed at a later date. ???] 16.3. Introduction to the Full Structure Editor 16.3. Introduction to the Full Structure Editor 16.3. Introduction to the Full Structure Editor 1 PSL also provides an extremely powerful form-oriented editor . This _______________ 1 This version of the UCI LISP editor was translated to to Standard LISP by Tryg Ager and Jim MacDonald of IMSSS, Stanford, and adapted to PSL by E. Benson. The UCI LISP editor is derived from the INTERLISP editor. EDITOR 7 February 1983 PSL Manual page 16.6 section 16.3 facility allows the user to easily alter function definitions, variable values and property list entries. It thereby makes it entirely unnecessary for the user to employ a conventional text editor in the maintenance of programs. This document is a guide to using the editor. Certain features of the UCI LISP editor have not been incorporated in the translated editor, and we have tried to mark all such differences. 16.3.1. Starting the Structure Editor 16.3.1. Starting the Structure Editor 16.3.1. Starting the Structure Editor EditF EditF This section describes normal user entry to the editor (with the EditF, EditP EditV EditP EditV EditP and EditV fuunctions) and the editing commands which are available. This section is by no means complete. In particular, material covering programmed calls to the editor routines is not treated. Consult the UCI LISP manual for further details. To edit a function named FOO do *(EDITF FOO) To edit the value of an atom named BAZ do *(EDITV BAZ) To edit the property list of an atom named FOOBAZ do *(EDITP FOOBAZ) These functions are described later in the chapter. Warning: Editing the property list of an atom may position pointers at unprintable structures. It is best to use the F (find) command before trying to print property lists. This editor capability is variable from implementation to implementation. The editor prompts with -E- * You can then input any editor command. The input scanner is not very smart. It terminates its scan and begins processing when it sees a printable character immediately followed by a carriage return. Do not use escape to terminate an editor command. If the editor seems to be PSL Manual 7 February 1983 EDITOR section 16.3 page 16.7 repeatedly requesting input type P<ret> (print the current expression) or some other command that ordinarily does no damage, but terminates the input solicitation. The following set of topics makes a good "first glance" at the editor. Entering the editor: EDITF, EDITV. Leaving the editor: OK. Editor's attention: CURRENT-EXP. Changing attention: POS-INTEGER, NEG-INTEGER, 0, ^, NX, BK. Printing: P, PP. Modification: POS-INTEGER, NEG-INTEGER, A, B, :, N. Changing parens: BI, BO. Undoing changes: UNDO. For the more discriminating user, the next topics might be some of the following. Searches: PATTERN, F, BF. Complex commands: R, SW, XTR, MBD, MOVE. Changing parens: LI, LO, RI, RO. Undoing changes: TEST, UNBLOCK, !UNDO. Other features should be skimmed but not studied until it appears that they may be useful. 16.3.2. Structure Editor Commands 16.3.2. Structure Editor Commands 16.3.2. Structure Editor Commands Note that arguments contained in angle brackets <> are optional. A A ___ ____ A ([ARG]) edit ___ _ This command inserts the ARGs (arbitrary LISP expressions) After UP UP the current expression. This is accomplished by doing an UP and a (-2 exp1 exp2 ... expn) or an (N exp1 exp2 ... expn), as appropriate. Note the way in which the current expression is UP UP changed by the UP. B B ___ ____ B ([ARG]) edit ___ _ This command inserts the ARGs (arbitrary LISP forms) Before the UP UP current expression. This is accomplished by doing an UP followed by a (-1 exp1 exp2 ... expn). Note the way in which the current UP UP expression is changed by the UP. EDITOR 7 February 1983 PSL Manual page 16.8 section 16.3 BELOW BELOW ___ _ ____ BELOW (COM, <N>) edit This command changes the current expression in the following ___ ___ manner. The edit command COM is executed. If COM is not a ___ recognized command, then (_ COM) is executed instead. Note that ___ COM should cause ascent in the edit chain (i.e. should be BELOW BELOW equivalent to some number of zeros). BELOW then evaluates (note!) N and descends N links in the resulting edit chain. That BELOW BELOW is, BELOW ascends the edit chain (does repeated 0s) looking for ___ the link specified by COM and stops N links below that (backs off N 0s). If N is not given, 1 is assumed. BF BF ___ ___ ____ BF (PAT, <FLG>) edit Also can be used as: BF PAT _ _ ___ This command performs a Backwards Find, searching for PAT (an edit pattern). Search begins with the expression immediately before the current expression and proceeds in reverse print order. (If the current expression is the top level expression, the entire expression is searched in reverse print order.) Search begins at the end of each list, and descends into each element before attempting to match that element. If the match fails, proceed to the previous element, etc. until the front of BF BF the list is reached. At that point, BF ascends and backs up, etc. The search algorithm may be slightly modified by use of a second ___ argument. Possible FLGs and their meanings are as follows. T begins search with the current expression rather than with the preceding expression at this level. BF BF ___ NIL or missing - same as BF PAT. NOTE: if the variable UPFINDFLG is non-NIL, the editor does an UP UP ___ UP after the expression matching PAT is located. Thus, doing a BF BF BF for a function name yields a current expression which is the entire function call. If this is not desired, UPFINDFLG may be set to NIL. UPFINDFLG is initially T. BF BF BF is protected from circular searches by the variable MAXLEVEL. Car Cdr Car Cdr If the total number of Cars and Cdrs descended into reaches MAXLEVEL (initially 300), search of that tail or element is abandoned exactly as though a complete search had failed. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.9 BI BI __ __ ____ BI (N1, N2) edit This command inserts a pair of parentheses in the current _ _ expression; i.e. it is a Balanced Insert. (Note that parentheses are ALWAYS balanced, and hence must be added or removed in pairs.) A left parenthesis is inserted before element N1 of the current expression. A right parenthesis is inserted after element N2 of the current expression. Both N1 and N2 are usually integers, and element N2 must be to the right of element N1. (BI n1) is equivalent to (BI n1 n1). NTH NTH The NTH command is used in the search, so that N1 and N2 may be any location specifications. The expressions used are the first element of the current expression in which the specified form is found at any level. BIND BIND ___ ____ BIND ([COM]) edit This command provides the user with temporary variables for use during the execution of the sequence of edit commands coms. There are three variables available: #1, #2 and #3. The binding BIND BIND is recursive and BIND may be executed recursively if necessary. All variables are initialized to NIL. This feature is useful chiefly in defining edit macros. BK BK ____ BK edit The current expression becomes the expression immediately _ _ preceding the present current expression; i.e. Back Up. This command generates an error if the current expression is the first expression in the list. BO BO _ ____ BO (N) edit BO BO The BO command removes a pair of parentheses from the Nth element _ _ of the current expression; i.e. it is a Balanced Remove. The NTH NTH parameter N is usually an integer. The NTH command is used in the search, however, so that any location specification may be used. The expression referred to is the first element of the current expression in which the specified form is found at any level. CHANGE CHANGE ___ __ ___ ____ (CHANGE LOC To [ARG]) edit This command replaces the current expression after executing the ___ ___ location specification LOC by ARGs. EDITOR 7 February 1983 PSL Manual page 16.10 section 16.3 COMS COMS ___ ____ (COMS [ARG]) edit ___ This command evaluates its ARGs and executes them as edit commands. COMSQ COMSQ ___ ____ (COMSQ [ARG]) edit ___ This command executes each ARG as an edit command. At any given time, the attention of the editor is focused on a single expression or form. We call that form the current expression. Editor commands may be divided into two broad classes. Those commands which change the current expression are called attention- changing commands. Those commands which modify structure are called structure modification commands. DELETE DELETE ____ DELETE edit This command deletes the current expression. If the current expression is a tail, only the first element is deleted. This command is equivalent to (:). E E ____ _ ____ (E FORM <T>) edit ____ This command evaluates FORM. This may also be typed in as: E FORM but is valid only if typed in from the TTY. (E FORM) evaluates ____ FORM and prints the value on the terminal. The form (E FORM T) ____ evaluates FORM but does not print the result. EditF EditF __ __ ___ ____ (EditF FN:id): any expr __ This function initiates editing of the function whose name is FN. EditFns EditFns __ ____ __ ____ ____ ____ ___ _____ (EditFns FN-LIST:id-list, COMS:form): NIL fexpr ____ This function applies the sequence of editor commands, COMS, to __ ____ each of several functions. The argument FN-LIST is evaluated, ____ and should evaluate to a list of function names. COMS is applied __ ____ to each function in FN-LIST, in turn. Errors in editing one function do not affect editing of others. The editor call is via EditF EditF EditF, so that values may also be edited in this way. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.11 EditP EditP __ __ ____ ____ ____ ___ _____ (EditP AT:id, COMS:form-list): any fexpr This function initiates editing of the property list of the atom ____ whose name is at. The argument COMS is a possibly null sequence of edit commands which is executed before calling for input from the terminal. EditV EditV __ __ ____ _____ ____ ___ _____ (EditV AT:id, COMS:forms-list): NIL fexpr This function initiates editing of the value of the atom whose __ ____ name is AT. The argument COMS is a possibly null sequence of edit commands which is executed before calling for input from the terminal. EMBED EMBED ___ __ ___ ____ (EMBED LOC In ARG) edit This command replaces the expression which would be current after ___ executing the location specification LOC by another expression which has that expression as a sub-expression. The manner in which the transformation is carried out depends on the form of ___ ___ ____ ARG. If ARG is a list, then each occurrence of the atom '*' in ___ ARG is replaced by the expression which would be current after ___ doing LOC. (NOTE: a fresh copy is used for each substitution.) ___ If ARG is atomic, the result is equivalent to: (EMBED loc IN (arg *)) A call of the form (EMBED loc IN exp1 exp2 ... expn) is equivalent to: (EMBED loc IN (exp1 exp2 ... expn *)) EMBED ___ EMBED If the expression after doing LOC is a tail, EMBED behaves as though the expression were the first element of that tail. EXTRACT EXTRACT ____ ____ ____ ____ (EXTRACT LOC1 From LOC2) edit This command replaces the expression which would be current after ____ doing the location specification LOC2 by the expression which ____ would be current after doing LOC1. The expression specified by EDITOR 7 February 1983 PSL Manual page 16.12 section 16.3 ____ ____ LOC1 must be a sub-expression of that specified by LOC2. F F ___ ___ ____ (F PAT <FLG>) edit Also can be used as: F PAT ___ This command causes the next command, PAT, to be interpreted as a pattern. The current expression is searched for the next ___ _ ___ occurrence of PAT; i.e. Find. If PAT is a top level element of ___ the current expression, then PAT matches that top level occurrence and a full recursive search is not attempted. Otherwise, the search proceeds in print order. Recursion is done Car Cdr Car Cdr first in the Car and then in the Cdr direction. The form (F PAT FLG) of the command may be used to modify the ___ search algorithm according to the value of FLG. Possible values and their actions are: N suppresses the top-level check. That is, finds the ___ next print order occurrence of PAT regardless of any top level occurrences. T like N, but may succeed without changing the current expression. That is, succeeds even if the current ___ expression itself is the only occurrence of PAT. positive integer ___ finds the nth place at which PAT is matched. This is equivalent to (F PAT T) followed by n-1 (F PAT N)s. If n occurrences are not found, the current expression is unchanged. NIL or missing Only searches top level elements of the current expression. May succeed without changing the current expression. NOTE: If the variable UPFINDFLG is non-NIL, F does an UP after locating a match. This ensures that F fn, in which fn is a function name, results in a current expression which is the entire function call. If this is undesirable, set UPFINDFLG to NIL. Its initial value is T. As protection against searching circular lists, the search is Car-Cdr Car-Cdr abandoned if the total number of Car-Cdr descents exceeds the PSL Manual 7 February 1983 EDITOR section 16.3 page 16.13 value of the variable MAXLEVEL. (The initial value is 300.) The search fails just as if the entire element had been unsuccessfully searched. FS FS ___ ____ (FS [PAT]) edit FS FS _ _ The FS command does sequential finds; i.e. Find Sequential. That ___ is, it searches (in print order) first for the first PAT, then ___ for the second PAT, etc. If any search fails, the current expression is left at that form which matched in the last successful search. This command is, therefore, equivalent to a F F sequence of F commands. F= F= ___ ___ ____ (F= EXP FLG) edit Eq _ Eq This command is equivalent to (F (== exp) flg); i.e. Find Eq. ___ That is, it searches, in the manner specified by FLG, for a form Eq Eq ___ which is Eq to EXP. Note that for keyboard type-ins, this always ___ fails unless EXP is atomic. HELP HELP ____ HELP edit This command provides an easy way of invoking the HELP system from the editor. I I ___ ___ ____ (I COM [ARG]) edit ___ ___ This command evaluates the ARGs and executes COM on the resulting values. This command is thus equivalent to: (com val1 val2 ... valn), Each vali is equal to (EVAL argi). IF IF ___ ____ (IF ARG) edit This command, useful in edit macros, conditionally causes an editor error. If (EVAL arg) is NIL (or if evaluation of arg IF IF causes a LISP error), then IF generates an editor error. INSERT INSERT ___ ____ (INSERT [EXP ARG LOC]) edit INSERT A B : INSERT A B : The INSERT command provides equivalents of the A, B and : ___ ___ commands incorporating a location specification, LOC. ARG can be ___ AFTER, BEFORE, or FOR. This command inserts EXPs AFTER, BEFORE or FOR (in place of) the expression which is current after ___ executing LOC. Note, however, that the current expression is not changed. EDITOR 7 February 1983 PSL Manual page 16.14 section 16.3 LC LC ___ ____ (LC LOC) edit This command, which takes as an argument a location specification, explicitly invokes the location specification _ _ search; i.e. Locate. The current expression is changed to that ___ which is current after executing LOC. ___ See LOC-SPEC for details on the definition of LOC and the search method in question. LCL LCL ___ ____ (LCL LOC) edit This command, which takes as an argument a location specification, explicitly invokes the location specification search. However, the search is limited to the current expression _ _ _ itself; i.e. Locate Limited. The current expression is changed ___ to that which is current after executing LOC. LI LI _ ____ (LI N) edit This command inserts a left parenthesis (and, of course, a _ _ matching right parenthesis); i.e. Left Parenthesis Insert. The left parenthesis is inserted before the Nth element of the current expression and the right parenthesis at the end of the current expression. Thus, this command is equivalent to (BI n -1). NTH NTH The NTH command is used in the search, so that N, which is usually an integer, may be any location specification. The expression referred to is the first element of the current expression which contains the form specified at any level. LO LO _ ____ (LO N) edit This command removes a left parenthesis (and a matching right parenthesis, of course) from the Nth element of the current _ _ expression; i.e. Left Parenthesis Remove. All elements after the Nth are deleted. NTH NTH The command uses the NTH command for the search. The parameter N, which is usually an integer, may be any location specification. The expression actually referred to is the first element of the current expression which contains the specified form at any depth. Many of the more complex edit commands take as an argument a location ___ specification (abbreviated LOC throughout this document). A location specification is a list of edit commands, which are, with two exceptions, executed in the normal way. Any command not recognized by the editor is PSL Manual 7 February 1983 EDITOR section 16.3 page 16.15 F F treated as though it were preceded by F. Furthermore, if one of the commands causes an error and the current expression has been changed by prior commands, the location operation continues rather than aborting. This is a sort of back-up operation. For example, suppose the location Cond Cond specification is (COND 2 3), and the first clause of the first Cond has only 2 forms. The location operation proceeds by searching for the next Cond Cond Cond and trying again. If a point were reached in which there were no more Cond Cond Conds, the location operation would then fail. LP LP ____ ____ (LP COMS) edit ____ This command, useful in macros, repeatedly executes COMS (a sequence of edit commands) until an editor error occurs; i.e. LP _ _ LP Loop. As LP exits, it prints the number of OCCURRENCES; that is, ____ the number of times COMS was successfully executed. After execution of the command, the current expression is left at what ____ it was after the last complete successful execution of COMS. The command terminates if the number of iterations exceeds the value of the variable MAXLOOP (initially 30). LPQ LPQ ____ ____ (LPQ COMS) edit ____ This command, useful in macros, repeatedly executes COMS (a sequence of edit commands) until an editor error occurs; i.e. _ _ _ Loop Quietly. After execution of the command, the current expression is left at what it was after the last complete ____ successful execution of COMS. The command terminates if the number of iterations exceeds the value of the variable MAXLOOP (initially 30). LP LP This command is equivalent to LP, except that OCCURRENCES is not printed. M M ___ ___ ____ (M (NAM) ([EXP) COMS)]) edit This can also be used as: (M NAM COMS) or as: (M (NAM) ARG COMS) EDITOR 7 February 1983 PSL Manual page 16.16 section 16.3 _ The editor provides the user with a macro facility; i.e. M. The user may define frequently used command sequences to be edit macros, which may then be invoked simply by giving the macro name M M as an edit command. The M command provides the user with a method of defining edit macros. The first alternate form of the command defines an atomic command ___ which takes no arguments. The argument NAM is the atomic name of ___ the macro. This defines NAM to be an edit macro equivalent to ____ ___ the sequence of edit commands COMS. If NAM previously had a definition as an edit macro, the new definition replaces the old. NOTE: Edit command names take precedence over macros. It is not possible to redefine edit command names. The main form of the M command as given above defines a list command, which takes a fixed number of arguments. In this case, ___ NAM is defined to be an edit macro equivalent to the sequence of ____ edit commands COMS. However, as (nam exp1 exp2 ... expn) is executed, the expi are substituted for the corresponding argi in ____ ____ COMS before COMS are executed. The second alternate form of the M command defines a list command which may take an arbitrary number of arguments. Execution of ___ the macro NAM is accomplished by substituting (exp1 exp2 ... Cdr Cdr expn) (that is, the Cdr of the macro call (nam exp1 exp2 ... ___ ____ expn)) for all occurrences of the atom ARG in COMS, and then ____ executing COMS. MAKEFN MAKEFN ___ ____ ____ __ __ ____ (MAKEFN (NAM VARS) ARGS N1 <N2>) edit This command defines a portion of the current expression as a function and replaces that portion of the expression by a call to ____ _ _ ___ ____ the function; i.e. Make Function. The form (NAM VARS) is the __ __ call which replaces the N1st through N2nd elements of the current ___ expression. Thus, NAM is the name of the function to be defined. ____ VARS is a sequence of local variables (in the current ____ expression), and ARGS is a list of dummy variables. The function definition is formed by replacing each occurrence of an element Cdr Cdr ___ ____ in vars (the Cdr of (NAM VARS)) by the corresponding element of ____ ____ ARGS. Thus, ARGS are the names of the formal parameters in the newly defined function. __ __ If N2 is omitted, it is assumed to be equal to N1. MARK MARK ____ MARK edit This command saves the current position within the form in such a way that it can later be returned to. The return is accomplished via _ or __. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.17 MBD MBD ___ ____ MBD (ARG) edit This command replaces the current expression by some form which ___ has the current expression as a sub-expression. If ARG is a MBD ____ MBD list, MBD substitutes a fresh copy of the current expression for ___ ___ each occurrence of the atom '*' in ARG. If ARG is a sequence of expressions, as: (MBD exp1 exp2 ... expn) then the call is equivalent to one of the form: (MBD (exp1 exp2 ... expn *)) The same is true if arg is atomic: (MBD atom) = (MBD (atom *)) MOVE MOVE ____ __ ___ ____ ____ (MOVE <LOC1> To COM <LOC2>) edit MOVE MOVE ____ The MOVE command allows the user to Move a structure from one point to another. The user may specify the form to be moved (via ____ LOC1, the first location specification), the position to which it ____ is to be moved (via LOC2, the second location specification) and ___ ___ the action to be performed there (via COM). The argument COM may be BEFORE, AFTER or the name of a list command (e.g. :, N, etc.). This command performs in the following manner. Take the current ____ expression after executing LOC1 (or its first element, if it is a ____ tail); call it expr. Execute LOC2 (beginning at the current expression AS OF ENTRY TO MOVE -- NOT the expression which would ____ ___ be current after execution of LOC1), and then execute (COM expr). Now go back and delete expr from its original position. The current expression is not changed by this command. ____ If LOC1 is NIL (that is, missing), the current expression is moved. In this case, the current expression becomes the result ___ of the execution of (COM expr). ____ If LOC2 is NIL (that is missing) or HERE, then the current ____ expression specifies the point to which the form given by LOC2 is to be moved. EDITOR 7 February 1983 PSL Manual page 16.18 section 16.3 N N ___ ____ (N [EXP]) edit ___ This command adds the EXPs to the end of the current expression; _ i.e. Add at End. This compensates for the fact that the negative integer command does not allow insertion after the last element. ____ _______ ____ _______ ____ _______ -N:integer edit-command -N:integer ___ edit-command (-N:integer [EXP]) edit-command Also can be used as: -N This is really two separate commands. The atomic form is an attention changing command. The current expression becomes the nth form from the end of the old current expression; i.e. Add _ Before End. That is, -1 specifies the last element, -2 the second from last, etc. The list form of the command is a structure modification command. This command inserts exp1 through expn (at least one expi must be present) before the nth element (counting from the BEGINNING) of the current expression. That is, -1 inserts before the first element, -2 before the second, etc. NEX NEX ___ ____ (NEX COM) edit Also can be used as: NEX BELOW NX BELOW ___ NX This command is equivalent to (BELOW COM) followed by NX. That is, it does repeated 0s until a current expression matching com NX NX is found. It then backs off by one 0 and does a NX. The atomic form of the command is equivalent to (NEX _). This is MARK MARK useful if the user is doing repeated (NEX x)s. He can MARK at x and then use the atomic form. NTH NTH ___ ____ (NTH LOC) edit LCL BELOW UP LCL ___ BELOW UP This command effectively performs (LCL LOC), (BELOW <), UP. The net effect is to search the current expression only for the form ___ specified by the location specification LOC. From there, return to the initial level and set the current expression to be the PSL Manual 7 February 1983 EDITOR section 16.3 page 16.19 ___ tail whose first element contains the form specified by LOC at any level. NX NX _ ____ (NX N) edit Also can be used as: NX The atomic form of this command makes the current expression the expression following the present current expression (at the same _ _ level); i.e. Next. The list form of the command is equivalent to n (an integer NX NX number) repetitions of NX. If an error occurs (e.g. if there are _ not N expressions following the current expression), the current expression is unchanged. OK OK ____ OK edit This command causes normal exit from the editor. The state of the edit is saved on property LASTVALUE of the atom EDIT. If the next form edited is the same, the edit is restored. That is, it is (with the exception of a BLOCK on the undo-list) as though the editor had never been exited. It is possible to save edit states for more than one form by SAVE SAVE exiting from the editor via the SAVE command. ORF ORF ___ ____ (ORF [PAT]) edit This command searches the current expression, in print order, for ___ the first occurrence of any form which matches one of the PATs; UP __ _ UP i.e. Print Order Final. If found, an UP is executed, and the current expression becomes the expression so specified. This command is equivalent to (F (*ANY* pat1 pat2 ... patn) N). Note that the top level check is not performed. ORR ORR ____ ____ (ORR [COMS]) edit ____ This command operates in the following manner. Each COMS is a ORR ORR ____ list of edit commands. ORR first executes the first COMS. If no ORR ORR error occurs, ORR terminates, leaving the current expression as ____ it was at the end of executing COMS. Otherwise, it restores the current expression to what it was on entry and repeats this EDITOR 7 February 1983 PSL Manual page 16.20 section 16.3 ____ ____ operation on the second COMS, etc. If no COMS is successfully ORR ORR executed without error, ORR generates an error and the current expression is unchanged. P P __ __ ____ (P N1 <N2>) edit Also can be used as: P _ This command prints the current expression; i.e. Print. The atomic form of the command prints the current expression to a depth of 2. More deeply nested forms are printed as &. __ The form (P N1) prints the N1st element of the current expression __ to a depth of 2. The argument N1 need not be an integer. It may NTH NTH be a general location specification. The NTH command is used in the search, so that the expression printed is the first element of the current expression which contains the desired form at any level. __ The third form of the command prints the N1st element of the __ __ current expression to a depth of N2. Again, N1 may be a general location specification. __ If N1 is 0, the current expression is printed. Many of the editor commands, particularly those which search, ___ take as an argument a pattern (abbreviated PAT). A pattern may be any combination of literal list structure and special pattern elements. The special elements are as follows. & this matches any single element. *ANY* if (CAR pat) is the atom *ANY*, then (CDR pat) must be ___ a list of patterns. PAT matches any form which matches Cdr Cdr ___ any of the patterns in (Cdr PAT). @ if an element of pat is a literal atom whose last character is @, then that element matches any literal atom whose initial characters match the initial characters of the element. That is, VER matches VERYLONGATOM. -- this matches any tail of a list or any interior segment of a list. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.21 Car Cdr Car ___ ___ Cdr ___ == if (Car PAT) is ==, then PAT matches X iff (Cdr PAT) is Eq Eq Eq to X. Cdr ___ Cdr ___ ::: if PAT begins with :::, the Cdr of PAT is matched against tails of the expression. ____ _______ ____ _______ ____ _______ N:integer edit-command N:integer ___ edit-command (N:integer [EXP]) edit-command Also can be used as: N:integer This command, a strictly positive integer N, is really two commands. The atomic form of the command is an attention-changing command. The current expression becomes the nth element of the current expression. The list form of the command is a structure modification command. It replaces the Nth element of the current expression by the ___ forms EXP. If no forms are given, then the Nth element of the current expression is deleted. PP PP ____ PP edit _ _ This command Pretty-Prints the current expression. R R ____ ____ ____ (R EXP1 EXP2) edit _ ____ ____ This command Replaces all occurrences of EXP1 by EXP2 in the current expression. ____ Note that EXP1 may be either the literal s-expression to be replaced, or it may be an edit pattern. If a pattern is given, the form which first matches that pattern is replaced throughout. All forms which match the pattern are NOT replaced. REPACK REPACK ___ ____ (REPACK LOC) edit Also can be used as: REPACK This command allows the editing of long strings (or atom names) EDITOR 7 February 1983 PSL Manual page 16.22 section 16.3 REPACK REPACK one character at a time. REPACK calls the editor recursively on UNPACK UNPACK UNPACK of the specified atom. (In the atomic form of the command, the current expression is used unless it is a list; then, the first element is used. In the list form of the command, the form specified by the location specification is OK OK treated in the same way.) If the lower editor is exited via OK, STOP STOP the result is repacked and replaces the original atom. If STOP is used, no replacement is done. The new atom is always printed. RI RI __ __ ____ (RI N1 N2) edit This command moves a right parenthesis. The parenthesis is moved __ from the end of the the N1st element of the current expression to __ __ _ after the N2nd element of the N1st element; i.e. Right _ __ Parenthesis Insert. Remaining elements of the N1st element are raised to the top level of the current expression. __ __ The arguments, N1 and N2, are normally integers. However, NTH NTH because the NTH command is used in the search, they may be any location specifications. The expressions referred to are the first element of the current expression in which the specified form is found at any level, and the first element of that __ expression in which the form specified by N2 is found at any level. RO RO _ ____ (RO N) edit This command moves the right parenthesis from the end of the nth element of the current expression to the end of the current _ _ expression; i.e. Right Parenthesis Remove. All elements following the Nth are moved inside the nth element. NTH NTH _ Because the NTH command is used for the search, the argument N, which is normally an integer, may be any location specification. The expression referred to is the first element of the current expression in which the specified form is found at any depth. S S ___ ___ ____ (S VAR LOC) edit SetQ _ SetQ ___ This command Sets (via SetQ) the variable whose name is VAR to the current expression after executing the location specification ___ LOC. The current expression is not changed. SAVE SAVE ____ SAVE edit This command exits normally from the editor. The state of the edit is saved on the property EDIT-SAVE of the atom being edited. When the same atom is next edited, the state of the edit is PSL Manual 7 February 1983 EDITOR section 16.3 page 16.23 restored and (with the exception of a BLOCK on the undo-list) it is as if the editor had never been exited. It is not necessary SAVE SAVE to use the SAVE command if only a single atom is being edited. OK OK See the OK command. SECOND SECOND ___ ____ (SECOND LOC) edit This command changes the current expression to what it would be ___ after the location specification LOC is executed twice. The ___ current expression is unchanged if either execution of LOC fails. STOP STOP ____ STOP edit ____ This command exits abnormally from the editor; i.e. Stop Editing. TTY: TTY: This command is useful mainly in conjunction with TTY: commands which the user wishes to abort. For example, if the user is executing (MOVE 3 TO AFTER COND TTY:) OK MOVE OK MOVE and he exits from the lower editor via OK, the MOVE command completes its operation. If, on the other hand, the user exits STOP TTY: MOVE STOP TTY: MOVE via STOP, TTY: produces an error and MOVE aborts. SW SW __ __ ____ (SW N1 N2) edit __ __ __ This command Swaps the N1st and N2nd elements of the current expression. The arguments are normally but not necessarily SW NTH SW NTH integers. SW uses NTH to perform the search, so that any location specifications may be used. In each case, the first element of the current expression which contains the specified form at any depth is used. TEST TEST ____ TEST edit This command adds an undo-block to the undo-list. This block UNDO !UNDO UNDO !UNDO limits the scope of UNDO and !UNDO commands to changes made after UNBLOCK UNBLOCK the block was inserted. The block may be removed via UNBLOCK. THIRD THIRD ___ ____ (THIRD LOC) edit This command executes the location specification loc three times. LC LC ___ It is equivalent to three repetitions of (LC LOC). Note, however, that if any of the executions causes an editor error, the current expression remains unchanged. EDITOR 7 February 1983 PSL Manual page 16.24 section 16.3 THROUGH ____ THROUGH ____ ____ (LOC1 THROUGH LOC2) edit This command makes the current expression the segment from the ____ form specified by LOC1 through (including) the form specified by LC UP BI ____ LC ____ UP BI ____ LOC2. It is equivalent to (LC LOC1), UP, (BI 1 LOC2), 1. Thus, it makes a single element of the specified elements and makes that the current expression. This command is meant for use in the location specifications DELETE, EMBED, EXTRACT REPLACE DELETE, EMBED, EXTRACT REPLACE given to the DELETE, EMBED, EXTRACT and REPLACE commands, and is THROUGH THROUGH not particularly useful by itself. Use of THROUGH with these commands sets a special flag so that the editor removes the extra THROUGH THROUGH set of parens added by THROUGH. TO ____ TO ____ ____ (LOC1 TO LOC2) edit This command makes the current expression the segment from the ____ form specified by LOC1 up to (but not including) the form LC UP BI ____ LC ____ UP BI specified by LOC2. It is equivalent to (LC LOC1), UP, (BI 1 RI RI loc), (RI 1 -2), 1. Thus, it makes a single element of the specified elements and makes that the current expression. This command is meant for use in the location specifications DELETE, EMBED, EXTRACT REPLACE DELETE, EMBED, EXTRACT REPLACE given to the DELETE, EMBED, EXTRACT and REPLACE commands, and is TO TO not particularly useful by itself. Use of TO with these commands sets a special flag so that the editor removes the extra set of TO TO parens added by TO. TTY: TTY: ____ TTY: edit This command calls the editor recursively, invoking a 'lower editor.' The user may execute any and all edit commands in this TTY: TTY: lower editor. The TTY: command terminates when the lower editor OK STOP OK STOP is exited via OK or STOP. The form being edited in the lower editor is the same as that being edited in the upper editor. Upon entry, the current expression in the lower is the same as that in the upper editor. UNBLOCK UNBLOCK ____ UNBLOCK edit This command removes an undo-block from the undo-list, allowing UNDO !UNDO UNDO !UNDO UNDO and !UNDO to operate on changes which were made before the block was inserted. TEST TEST Blocks may be inserted by exiting from the editor and by the TEST command. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.25 UNDO UNDO ___ ____ UNDO (COM) edit Also can use as: UNDO This command undoes editing changes. All editing changes are undoable, provided that the information is available to the editor. (The necessary information is always available unless SAVE SAVE several forms are being edited and the SAVE command is not used.) Changes made in the current editing session are ALWAYS undoable. The short form of the command undoes the most recent change. UNDO !UNDO UNDO !UNDO Note, however, that UNDO and !UNDO changes are skipped, even though they are themselves undoable. The long form of the command allows the user to undo an arbitrary UNDO !UNDO UNDO !UNDO command, not necessarily the most recent. UNDO and !UNDO may also be undone in this manner. UP UP ____ UP edit If the current expression is a tail of the next higher UP UP expression, UP has no effect. Otherwise the current expression becomes the form whose first element is the old current expression. XTR XTR ___ ____ (XTR LOC) edit This command replaces the current expression by one of its ___ subexpressions. The location specification, LOC, gives the form to be used. Note that only the current expression is searched. If the current expression is a tail, the command operates on the first element of the tail. ____ _______ ____ _______ ____ _______ edit-command edit-command 0 edit-command This command makes the current expression the next higher expression. This usually, but not always, corresponds to returning to the next higher left parenthesis. This command is, in some sense, the inverse of the POS-INTEGER and NEG- INTEGER atomic commands. _____ ____ _______ _____ ____ _______ _____ ____ _______ ## fexpr, edit-command ## ___ ____ ___ fexpr, edit-command ## ([COM:form]): any fexpr, edit-command EDITOR 7 February 1983 PSL Manual page 16.26 section 16.3 The value of this fexpr, useful mainly in macros, is the ___ expression which would be current after executing all of the COMs in sequence. The current expression is not changed. CHANGE INSERT CHANGE INSERT Commands in which this fexpr might be used (e.g. CHANGE, INSERT, and REPLACE REPLACE REPLACE) make special checks and use a copy of the expression returned. ____ _______ ____ _______ ____ _______ ^ edit-command ^ edit-command ^ edit-command This command makes the top level expression the current expression. ____ _______ ____ _______ ____ _______ ? edit-command ? edit-command ? edit-command This command prints the current expression to a level of 100. It is equivalent to (P 0 100). ____ _______ ____ _______ ____ _______ ?? edit-command ?? edit-command ?? edit-command This command displays the entries on the undo-list. ____ _______ ____ _______ ____ _______ _ edit-command _ edit-command _ edit-command This command returns to the position indicated by the most recent MARK MARK MARK MARK MARK command. The MARK is not removed. ____ _______ ____ _______ ____ _______ _ edit-command _ ___ edit-command (_ PAT) edit-command This command ascends (does repeated 0s), testing the current ___ expression at each ascent for a match with PAT. The current expression becomes the first form to match. If pattern is atomic, it is matched with the first element of each expression; otherwise, it is matched against the entire form. ____ _______ ____ _______ ____ _______ __ edit-command __ edit-command __ edit-command This command returns to the position indicated by the most recent MARK MARK MARK MARK MARK command and removes the MARK. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.27 ____ _______ ____ _______ ____ _______ : edit-command : ___ edit-command (: [EXP]) edit-command Also can be used as: (:) ___ This command replaces the current expression by the forms EXP. If no forms are given (as in the second form of the command), the current expression is deleted. ____ _______ ____ _______ ____ _______ :: edit-command ___ :: ___ edit-command (PAT :: LOC) edit-command This command sets the current expression to the first form (in ___ print order) which matches PAT and contains the form specified by ___ the location specification LOC at any level. The command is F LCL F ___ LCL ___ ___ equivalent to (F PAT N), (LCL LOC), (_ PAT). ____ _______ ____ _______ ____ _______ \ edit-command \ edit-command \ edit-command This command returns to the expression which was current before the last 'big jump.' Big jumps are caused by these commands: ^, _, __, !NX, all commands which perform a search or use a location specification, \ itself, and \P. NOTE: \ is shift-L on a teletype. ____ _______ ____ _______ ____ _______ \P edit-command \P edit-command \P edit-command This command returns to the expression which was current before the last print operation (P, PP or ?). Only the two most recent locations are saved. NOTE: \ is shift-L on a teletype. ____ _______ ____ _______ ____ _______ !NX edit-command !NX edit-command !NX edit-command This command makes the next expression at a higher level the current expression. That is, it goes through any number of right parentheses to get to the next expression. ____ _______ ____ _______ ____ _______ !UNDO edit-command !UNDO edit-command !UNDO edit-command EDITOR 7 February 1983 PSL Manual page 16.28 section 16.3 This command undoes all changes made in the current editing session (back to the most recent block). All changes are undoable. TEST TEST Blocks may be inserted by exiting the editor or by the TEST UNBLOCK UNBLOCK command. They may be removed with the UNBLOCK command. ____ _______ ____ _______ ____ _______ !0 edit-command !0 edit-command !0 edit-command This command does repeated 0s until it reaches an expression which is not a tail of the next higher expression. That expression becomes the new current expression. That is, this command returns to the next higher left parenthesis, regardless of intervening tails. |
Added psl-1983/3-1/lpt/17-utilities.lpt version [475c5d270b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Utilities section 17.0 page 17.1 CHAPTER 17 CHAPTER 17 CHAPTER 17 MISCELLANEOUS UTILITIES MISCELLANEOUS UTILITIES MISCELLANEOUS UTILITIES 17.1. Introduction . . . . . . . . . . . . . . . 17.1 17.2. RCREF - Cross Reference Generator for PSL Files . . . 17.1 17.2.1. Restrictions. . . . . . . . . . . . . 17.2 17.2.2. Usage . . . . . . . . . . . . . . . 17.3 17.2.3. Options . . . . . . . . . . . . . . 17.3 17.3. Picture RLISP. . . . . . . . . . . . . . . 17.4 17.3.1. Running PictureRLISP on HP2648A and on TEKTRONIX 17.10 4006-1 Terminals . . . . . . . . . . . 17.4. Tools for Defining Macros. . . . . . . . . . . 17.11 17.4.1. DefMacro . . . . . . . . . . . . . . 17.11 17.4.2. BackQuote. . . . . . . . . . . . . . 17.12 17.4.3. Sharp-Sign Macros . . . . . . . . . . . 17.12 17.4.4. MacroExpand . . . . . . . . . . . . . 17.13 17.4.5. DefLambda. . . . . . . . . . . . . . 17.13 17.5. Simulating a Stack . . . . . . . . . . . . . 17.14 17.6. DefStruct . . . . . . . . . . . . . . . . 17.14 17.6.1. Options . . . . . . . . . . . . . . 17.17 17.6.2. Slot Options. . . . . . . . . . . . . 17.18 17.6.3. A Simple Example . . . . . . . . . . . 17.18 17.7. DefConst . . . . . . . . . . . . . . . . 17.21 17.8. Functions for Sorting . . . . . . . . . . . . 17.22 17.9. Hashing Cons . . . . . . . . . . . . . . . 17.23 17.10. Graph-to-Tree . . . . . . . . . . . . . . 17.25 17.11. Inspect Utility. . . . . . . . . . . . . . 17.25 17.1. Introduction 17.1. Introduction 17.1. Introduction This chapter describes an assortment of utility packages. Its purpose is to record the existence and capabilities of a number of tools. More information on existing packages can be found by looking at the current set of HELP files (DIR PH:*.* on the DEC-20). 17.2. RCREF - Cross Reference Generator for PSL Files 17.2. RCREF - Cross Reference Generator for PSL Files 17.2. RCREF - Cross Reference Generator for PSL Files RCREF is a Standard LISP program for processing a set of Standard LISP function definitions to produce: a. A "Summary" showing: Utilities 7 February 1983 PSL Manual page 17.2 section 17.2 i. A list of files processed. ii. A list of "entry points" (functions which are not called or are called only by themselves). iii. A list of undefined functions (functions called but not defined in this set of functions). iv. A list of variables that were used non-locally but not declared GLOBAL or FLUID before their use. v. A list of variables that were declared GLOBAL but used as FLUIDs (i.e. bound in a function). vi. A list of FLUID variables that were not bound in a function so that one might consider declaring them GLOBALs. vii. A list of all GLOBAL variables present. viii. A list of all FLUID variables present. ix. A list of all functions present. b. A "global variable usage" table, showing for each non-local variable: i. Functions in which it is used as a declared FLUID or GLOBAL. ii. Functions in which it is used but not declared before. iii. Functions in which it is bound. SetQ SetQ iv. Functions in which it is changed by SetQ. c. A "function usage" table showing for each function: i. Where it is defined. ii. Functions which call this function. iii. Functions called by it. iv. Non-local variables used. The output is alphabetized on the first seven characters of each function name. RCREF also checks that functions are called with the correct number of arguments. 17.2.1. Restrictions 17.2.1. Restrictions 17.2.1. Restrictions Algebraic procedures in REDUCE are treated as if they were symbolic, so that algebraic constructs actually appear as calls to symbolic functions, AEval AEval such as AEval. SYSLISP procedures are not correctly analyzed. PSL Manual 7 February 1983 Utilities section 17.2 page 17.3 17.2.2. Usage 17.2.2. Usage 17.2.2. Usage RCREF should be used in PSL:RLISP. To make a file FILE.CRF which is a cross reference listing for files FILE1.EX1 and FILE2.EX2 do the following in RLISP: @PSL:RLISP LOAD RCREF; % RCREF is now autoloading, so this may be omitted OUT "file.crf"; % later, CREFOUT ... ON CREF; IN "file1.ex1","file2.ex2"; OFF CREF; SHUT "file.crf"; % later CREFEND To process more files, more IN statements may be added, or the IN statement may be changed to include more files. 17.2.3. Options 17.2.3. Options 17.2.3. Options __________ ______ !*CREFSUMMARY [Initially: NIL] switch If the switch CREFSUMMARY is ON then only the summary (see 1 above) is produced. Functions with the flag NOLIST are not examined or output. Initially, all Standard LISP functions are so flagged. (In fact, they are kept on a list NOLIST!*, so if you wish to see references to ALL functions, then CREF should be first loaded with the command LOAD RCREF, and this variable then set to NIL). (RCREF is now autoloading.) __________ ______ NOLIST!* [Initially: the following list] global (AND COND LIST MAX MIN OR PLUS PROG PROG2 PROGN TIMES LAMB ADD1 APPEND APPLY ASSOC ATOM CAR CDR CAAR CADR CDAR CDDR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR CAAAAR CAAADR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDDAAR CDDADR CDDDAR CDDDDR CLOSE CODEP COMPRESS CONS CO DE DEFLIST DELETE DF DIFFERENCE DIGIT DIVIDE DM EJECT EQUAL ERROR ERRORSET EVAL EVLIS EXPAND EXPLODE EXPT FIX FI FLAGP FLOAT FLOATP FLUID FLUIDP FUNCTION GENSYM GET GET GLOBAL GLOBALP GO GREATERP IDP INTERN LENGTH LESSP LIN LITER LPOSN MAP MAPC MAPCAN MAPCAR MAPCON MAPLIST MAX2 MEMQ MINUS MINUSP MIN2 MKVECT NCONC NOT NULL NUMBERP ONE PAGELENGTH PAIR PAIRP PLUS2 POSN PRINC PRINT PRIN1 PRIN2 PUT PUTD PUTV QUOTE QUOTIENT RDS READ READCH REMAINDE REMFLAG REMOB REMPROP RETURN REVERSE RPLACA RPLACD SASS SETQ STRINGP SUBLIS SUBST SUB1 TERPRI TIMES2 UNFLUID UPBV WRS ZEROP) Utilities 7 February 1983 PSL Manual page 17.4 section 17.2 It should also be remembered that in RLISP any macros with the flag EXPAND or, if FORCE is on, without the flag NOEXPAND are expanded before the definition is seen by the cross-reference program, so this flag can also be used to select those macros you require expanded and those you do not. The use of ON FORCE; is highly recommended for CREF. 17.3. Picture RLISP 17.3. Picture RLISP 17.3. Picture RLISP [??? ReWrite ???] [??? ReWrite ???] [??? ReWrite ???] Picture RLISP is an ALGOL-like graphics language for Teleray, HP2648a and Tektronix, in which graphics Model primitives are combined into complete Models for display. PRLISP is a 3D version; PRLISP2D is a faster, smaller 2D version which also drives more terminals. Two demonstration files, PR-DEMO.RED and PR-DEMO.Sl, are available on PU. See the help files PH:PRLISP.HLP and PRLISP2D.HLP. Model primitives include: P:={x,y,z}; A point (y, and z may be omitted, default to 0). PS:=P1_ P2_ ... Pn; A Point Set is an ordered set of Points (Polygon). G := PS1 & PS2 & ... PSn; A Group of Polygons. Point Set Modifiers alter the interpretation of Point Sets within their scope. BEZIER() causes the point-set to be interpreted as the specification points for a BEZIER curve, open pointset. BSPLINE() does the same for a Bspline curve, closed pointset. TRANSFORMS: Mostly return a transformation matrix. Translation: Move the specified amount along the specified axis. XMOVE(deltaX); YMOVE(deltaY); ZMOVE(deltaZ); MOVE(deltaX, deltaY, deltaZ); Scale: Scale the Model SCALE (factor) XSCALE(factor); YSCALE(factor); ZSCALE(factor); SCALE1(x.scale.factor, y.scale.factor, z.scale.factor); SCALE<Scale factor>;. Scale along all axes. PSL Manual 7 February 1983 Utilities section 17.3 page 17.5 Rotation: ROT(degrees); ROT(degrees, point.specifying.axis); XROT(degrees); YROT(degrees); ZROT(degrees); Window (z.eye,z.screen): The WINDOW primitives assume that the viewer is located along the z axis looking in the positive z direction, and that the viewing window is to be centered on both the x and y axis. Vwport(leftclip,rightclip,topclip,bottomclip): The VWPORT, which specifies the region of the screen which is used for display. REPEATED (number.of.times, my.transform): The Section of the Model which is contained within the scope of the Repeat Specification is replicated. Note that REPEATED is intended to duplicate a sub-image in several different places on the screen; it was not designed for animation. Identifiers of other Models the Model referred to is displayed as if it were part of the current Model for dynamic display. Calls to PictureRLISP Procedures This Model primitive allows procedure calls to be imbedded within Models. When the Model interpreter reaches the procedure identifier it calls it, passing it the portion of the Model below the procedure as an argument. The current transformation matrix and the current pen position are available to such procedures as the values of the global identifiers GLOBAL!.TRANSFORM and HEREPOINT. If normal procedure call syntax, i.e. proc.name (parameters), is used then the procedure is called at Model-building time, but if only the procedure's identifier is used then the procedure is imbedded in the Model. ERASE() Clears the screen and leaves the cursor at the origin. SHOW(pict) Takes a picture and displays it on the screen. ESHOW (pict) Erases the whole screen and display "pict". HP!.INIT(), TEK!.INIT(), TEL!.INIT() Initializes the operating system's view of the characteristics of HP2648A terminal, TEKTRONIX 4006-1 (also ADM-3A with Retrographics board, and Teleray-1061). For example, the Model Utilities 7 February 1983 PSL Manual page 17.6 section 17.3 (A _ B _ C & {1,2} _ B) | XROT (30) | 'TRAN ; % % PictureRLISP Commands to SHOW lots of Cubes % % Outline is a Point Set defining the 20 by 20 % square which is part of the Cubeface % Outline := { 10, 10} _ {-10, 10} _ {-10,-10} _ { 10,-10} _ {10, 10}; % Cubeface also has an Arrow on it % Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}; % We are ready for the Cubeface Cubeface := (Outline & Arrow) | 'Tranz; % Note the use of static clustering to keep objects % meaningful as well as the quoted Cluster % to the as yet undefined transformation Tranz, % which results in its evaluation being % deferred until SHOW time % and now define the Cube Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90); % In order to have a more pleasant look at % the picture shown on the screen we magnify % cube by 5 times. BigCube := Cube | SCALE 5; % Set up initial Z Transform for each cube face % Tranz := ZMOVE (10); % 10 units out % % GLOBAL!.TRANSFORM has been treated as a global variable. % GLOBAL!.TRANSFORM should be initialized as a perspective % transformation matrix so that a viewer can have a correct % look at the picture as the viewing location changed. % For instance, it may be set as the desired perspective % with a perspective window centered at the origin and % of screen size 60, and the observer at -300 on the z axis. % Currently this has been set as default perspective transformation. PSL Manual 7 February 1983 Utilities section 17.3 page 17.7 % Now draw cube % SHOW BigCube; % Utilities 7 February 1983 PSL Manual page 17.8 section 17.3 % Draw it again rotated and moved left % SHOW (BigCube | XROT 20 | YROT 30 | ZROT 10); % Dynamically expand the faces out % Tranz := ZMOVE 12; % SHOW (BigCube | YROT 30 | ZROT 10); % Now show 5 cubes, each moved further right by 80 % Tranz := ZMOVE 10; % SHOW (Cube | SCALE 2.5 | XMOVE (-240) | REPEATED(5, XMOVE 80)); % % Now try pointset modifier. % Given a pointset (polygon) as control points either a BEZIER or a % BSPLINE curve can be drawn. % Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,13 _ {0,84} $ % % Now draw Bezier curve % Show the polygon and the Bezier curve % SHOW (Cpts & Cpts | BEZIER()); % Now draw Bspline curve % Show the polygon and the Bspline curve % SHOW (Cpts & Cpts | BSPLINE()); % Now work on the Circle % Given a center position and a radius a circle is drawn % SHOW ( {10,10} | CIRCLE(50)); % % Define a procedure which returns a model of % a Cube when passed the face to be used % Symbolic Procedure Buildcube; List 'Buildcube; % put the name onto the property list Put('buildcube, 'pbintrp, 'Dobuildcube); Symbolic Procedure Dobuildcube Face$ Face & Face | XROT(180) & Face | YROT(90) & Face | YROT(-90) PSL Manual 7 February 1983 Utilities section 17.3 page 17.9 & Face | XROT(90) & Face | XROT(-90) ; % just return the value of the one statement % Use this procedure to display 2 cubes, with and % without the Arrow - first do it by calling % Buildcube at time the Model is built % P := Cubeface | Buildcube() | XMOVE(-15) & (Outline | 'Tranz) | Buildcube() | XMOVE 15; % SHOW (P | SCALE 5); % Now define a procedure which returns a Model of % a cube when passed the half size parameter Symbolic Procedure Cubemodel; List 'Cubemodel; %put the name onto the property list Put('Cubemodel,'Pbintrp, 'Docubemodel); Symbolic Procedure Docubemodel HSize; << if idp HSize then HSize := eval HSize$ { HSize, HSize, HSize} _ {-HSize, HSize, HSize} _ {-HSize, -HSize, HSize} _ { HSize, -HSize, HSize} _ { HSize, HSize, HSize} _ { HSize, HSize, -HSize} _ {-HSize, HSize, -HSize} _ {-HSize, -HSize, -HSize} _ { HSize, -HSize, -HSize} _ { HSize, HSize, -HSize} & {-HSize, HSize, -HSize} _ {-HSize, HSize, HSize} & {-HSize, -HSize, -HSize} _ {-HSize, -HSize, HSize} & { HSize, -HSize, -HSize} _ { HSize, -HSize, HSize} >>; % Imbed the parameterized cube in some Models % His!.cube := 'His!.size | Cubemodel(); Her!.cube := 'Her!.size | Cubemodel(); R := His!.cube | XMOVE (60) & Her!.cube | XMOVE (-60) ; % Set up some sizes and SHOW them His!.size := 50; Her!.size := 30; % SHOW R ; Utilities 7 February 1983 PSL Manual page 17.10 section 17.3 % % Set up some different sizes and SHOW them again % His!.size := 35; Her!.size := 60; % SHOW R; % % Now show a triangle rotated 45 degree about the z axis. Rotatedtriangle := {0,0} _ {50,50} _ {100,0} _ {0,0} | Zrot (45); % SHOW Rotatedtriangle; % % Define a procedure which returns a model of a Pyramid % when passed 4 vertices of a pyramid. % Procedure Second,Third, Fourth and Fifth are primitive procedures % written in the source program which return the second, the third, % the fourth and the fifth element of a list respectively. % This procedure simply takes 4 points and connects the vertices to % show a pyramid. Symbolic Procedure Pyramid (Point4); %.point4 is a pointset Point4 & Third Point4 _ Fifth Point4 _ Second Point4 _ Fourth Point4 ; % Now give a pointset indicating 4 vertices build a pyramid % and show it % My!.vertices := {-40,0} _ {20,-40} _ {90,20} _ {70,100}; My!.pyramid := Pyramid Vertices; % SHOW ( My!.pyramid | XROT 30); % % A procedure that makes a wheel with "count" % spokes rotated around the z axis. % in which "count" is the number specified. Symbolic Procedure Dowheel(spoke,count)$ begin scalar rotatedangle$ count := first count$ rotatedangle := 360.0 / count$ return (spoke | REPEATED(count, ZROT rotatedangle)) end$ % % Now draw a wheel consisting of 8 cubes % PSL Manual 7 February 1983 Utilities section 17.3 page 17.11 Cubeonspoke := (Outline | ZMOVE 10 | SCALE 2) | buildcube(); Eight!.cubes := Cubeonspoke | XMOVE 50 | WHEEL(8); % SHOW Eight!.cubes; % %Draw a cube in which each face consists of just % a wheel of 8 Outlines % Flat!.Spoke := outline | XMOVE 25$ A!.Fancy!.Cube := Flat!.Spoke | WHEEL(8) | ZMOVE 50 | Buildcube()$ % SHOW A!.Fancy!.Cube; % % Redraw the fancy cube, after changing perspective by % moving the observer farther out along Z axis % GLOBAL!.TRANSFORM := WINDOW(-500,60); % SHOW A!.Fancy!.Cube; % % Note the flexibility resulting from the fact that % both Buildcube and Wheel simply take or return any % Model as their argument or value The current version of PictureRLISP runs on HP2648A graphics terminal and TEKTRONIX 4006-1 computer display terminal. The screen of the HP terminal is 720 units long in the X direction, and 360 units high in the Y direction. The coordinate system used in HP terminal places the origin in approximately the center of the screen, and uses a domain of -360 to 360 and a range of -180 to 180. Similarly, the screen of the TEKTRONIX terminal is 1024 units long in the X direction, and 780 units high in the Y direction. The same origin is used but the domain is -512 to 512 in the X direction and the range is -390 to 390 in the Y direction. Procedures HP!.INIT and TEK!.INIT are used to set the terminals to graphics mode and initiate the lower level procedures on HP and TEKTRONIX terminals respectively. Basically, INIT procedures are written for different terminals depending on their specific characteristics. Using INIT procedures keeps terminal device dependence at the user's level to a minimum. 17.4. Tools for Defining Macros 17.4. Tools for Defining Macros 17.4. Tools for Defining Macros The following (and other) macro utilities are in the file PU:USEFUL.SL; Utilities 7 February 1983 PSL Manual page 17.12 section 17.4 1 use (LOAD USEFUL) to access. See PH:USEFUL.HLP for more information. 17.4.1. DefMacro 17.4.1. DefMacro 17.4.1. DefMacro DefMacro DefMacro _ __ _ ____ _ ____ __ _____ (DefMacro A:id B:form [C:form]): id macro _____ _____ _____ DefMacro macro DefMacro DefMacro macro DefMacro DefMacro is a useful tool for defining macros. A DefMacro form looks like (DEFMACRO <NAME> <PATTERN> <S1> <S2> ... <Sn>) ____ __ The <PATTERN> is an S-expression made of pairs and ids. It is _____ _____ _____ macro macro matched against the arguments of the macro much like the first DeSetQ DeSetQ __ argument to DeSetQ. All of the non-NIL ids in <pattern> are local variables which may be used freely in the body (the <Si>). _____ _____ _____ macro ProgN macro ProgN If the macro is called the <Si> are evaluated as in a ProgN with the local variables in <pattern> appropriately bound, and the DefMacro DefMacro value of <Sn> is returned. DefMacro is often used with BackQuote. 17.4.2. BackQuote 17.4.2. BackQuote 17.4.2. BackQuote Note that the special symbols described below only work in LISP syntax, BackQuote UnQuote BackQuote UnQuote not RLISP. In RLISP you may simply use the functions BackQuote, UnQuote, UnQuoteL BackQuote UnQuoteL BackQuote and UnQuoteL. Load USEFUL to get the BackQuote function. _____ _____ _____ Read macro Read macro The backquote symbol "`" is a Read macro which introduces a quoted expression which may contain the unquote symbols comma "," and comma-atsign ",@". An appropriate form consisting of the unquoted expression calls to Cons Cons the function Cons and quoted expressions are produced so that the resulting expression looks like the quoted one except that the values of the unquoted expressions are substituted in the appropriate place. ",@" splices in the value of the subsequent expression (i.e. strips off the outer layer of parentheses). Thus `(a (b ,x) c d ,@x e f) is equivalent to (cons 'a (cons (list 'b x) (append '(c d) (append x '(e f))))) In particular, if x is bound to (1 2 3) this evaluates to _______________ 1 Useful was written by D. Morrison. PSL Manual 7 February 1983 Utilities section 17.4 page 17.13 (a (b (1 2 3)) c d 1 2 3 e f) BackQuote BackQuote _ ____ ____ _____ (BackQuote A:form): form macro Function name for back quote `. UnQuote UnQuote _ ___ _________ _____ (UnQuote A:any): Undefined fexpr Eval Eval Function name for comma ,. It is an error to Eval this function; BackQuote BackQuote it should occur only inside a BackQuote. UnQuoteL UnQuoteL _ ___ _________ _____ (UnQuoteL A:any): Undefined fexpr Eval Eval Function name for comma-atsign ,@. It is an error to Eval this BackQuote BackQuote function; it should only occur inside a BackQuote. 17.4.3. Sharp-Sign Macros 17.4.3. Sharp-Sign Macros 17.4.3. Sharp-Sign Macros USEFUL defines several MACLISP style sharp sign read macros. Note that these only work with the LISP reader, not RLISP. Those currently included are #' : this is like the quote mark ' but is for FUNCTION instead of QUOTE. #/ : this returns the numeric form of the following character read without raising it. For example #/a is 97 while #/A is 65. #\ : This is a read macro for the CHAR macro, described in the PSL manual. Not that the argument is raised, if *RAISE is non-nil. For Char Char example, #\a = #\A = 65, while #\!a = #\(lower a) = 97. Char has been redefined in USEFUL to be slightly more table driven -- users can now add new "prefixes" such as META or CONTROL: just hang the appropriate function (from integers to integers) off the char-prefix-function property of the "prefix". A LARGE number of additional alias for various characters have been added, including all the "standard" ASCII names like NAK and DC1. #. : this causes the following expression to be evaluated at read time. For example, `(1 2 #.(plus 1 2) 4) reads as (1 2 3 4) #+ : this reads two expressions, and passes them to the if_system macro. That is, the first should be a system name, and if that is the current system the second argument is returned by the reader. If not, the next expression is returned. #-: #- is similar, but causes the second arg to be returned only if it is NOT the current system. Utilities 7 February 1983 PSL Manual page 17.14 section 17.4 17.4.4. MacroExpand 17.4.4. MacroExpand 17.4.4. MacroExpand MacroExpand MacroExpand _ ____ _ __ ____ _____ (MacroExpand A:form [B:id]): form macro _____ _____ _____ MacroExpand macro MacroExpand macro MacroExpand is a useful tool for debugging macro definitions. If MacroExpand macro MacroExpand macro given one argument, MacroExpand expands all the macros in that form. Often one wishes for more control over this process. For _____ _____ _____ macro Let macro Let example, if a macro expands into a Let, we may not wish to see Let Let the Let itself expanded to a lambda expression. Therefore MacroExpand MacroExpand additional arguments may be given to MacroExpand. If these are _____ _____ _____ macro macro supplied, they should be macros, and only those specified are expanded. 17.4.5. DefLambda 17.4.5. DefLambda 17.4.5. DefLambda DefLambda DefLambda _____ (DefLambda ): macro Yet another little (two line) macro has been added to USEFUL: DefLambda DefLambda DefLambda. This defines a macro much like a substitution macro ______ ______ ______ smacro smacro (smacro) except that it is a lambda expression. Thus, modulo ____ ____ ____ expr expr redefinability, it has the same semantics as the equivalent expr. It is mostly intended as an easy way to open compile things. For example, we would not normally want to define a substitution macro for a constructor (NEW-FOO X) which maps into (CONS X X), in case X is expensive to compute or, far worse, has side effects. (DEFLAMBDA NEW-FOO (X) (CONS X X)) defines it as a macro which maps (NEW-FOO (SETQ BAR (BAZ))) to ((LAMBDA (X) (CONS X X)) (SETQ BAR (BAZ))). 17.5. Simulating a Stack 17.5. Simulating a Stack 17.5. Simulating a Stack The following macros are in the USEFUL package. They are convenient for ____ adding and deleting things from the head of a list. Push Push ___ ___ ___ ____ ___ _____ (Push ITM:any STK:list): any macro (PUSH ITEM STACK) is equivalent to (SETF STACK (CONS ITEM STACK)) PSL Manual 7 February 1983 Utilities section 17.5 page 17.15 Pop Pop ___ ____ ___ _____ (Pop STK:list): any macro (POP STACK) does (SETF STACK (CDR STACK)) _____ and returns the item popped off STACK. An additional argument Pop Pop may be supplied to Pop, in which case it is a variable which is SetQ SetQ SetQ'd to the popped value. 17.6. DefStruct 17.6. DefStruct 17.6. DefStruct (LOAD DEFSTRUCT) to use the functions described below, or FAST!-DEFSTRUCT to use those functions but with fast vector operations used. DefStruct is similar to the Spice (Common) LISP/LISP machine/MacLISP flavor of struct definitions, and is expected to be subsumed by the Mode package. It is 2 implemented in PSL as a function which builds access macros and fns for "typed" vectors, including constructor and alterant macros, a type predicate for the structure type, and individual selector/assignment fns for the elements. DefStruct understands a keyword-option oriented structure specification. DefStruct is now autoloading. First a few miscellaneous functions on types, before getting into the depths of defining DefStructs: DefstructP DefstructP ____ __ _____ _______ ____ (DefstructP NAME:id): extra-boolean expr This is a predicate that returns non-NIL (the Defstruct ____ definition) if NAME is a structured type which has been defined using Defstruct, or NIL if it is not. DefstructType DefstructType _ ______ __ ____ (DefstructType S:struct): id expr This returns the type name field of an instance of a structured _ type, or NIL if S cannot be a Defstruct type. _______________ 2 Defstruct was implemented by Russ Fish. Utilities 7 February 1983 PSL Manual page 17.16 section 17.6 SubTypeP SubTypeP _____ __ _____ __ _______ ____ (SubTypeP NAME1:id NAME2:id): boolean expr _____ This returns true if NAME1 is a structured type which has been _____ !:Included in the definition of structured type NAME2, possibly through intermediate structure definitions. (In other words, the _____ _____ selectors of NAME1 can be applied to NAME2.) Now the function which defines the beasties, in all its gory glory: Defstruct Defstruct ____ ___ _______ __ ____ ____ _____ __ ____ __ _____ (Defstruct NAME-AND-OPTIONS:{id,list} [SLOT-DESCS:{id,list}]): id fexpr Defines a record-structure data type. A general call to Defstruct Defstruct Defstruct looks like this: (in RLISP syntax) defstruct( struct-name( option-1, option-2, ... ), slot-description-1, slot-description-2, ... ); The name of the defined structure is returned. Slot-descriptions are: slot-name( default-init, slot-option-1, slot-option-2, ... ) __ Struct-name and slot-name are ids. If there are no options following a name in a spec, it can be a bare id with no option argument list. The default-init form is optional and may be omitted. The default-init form is evaluated EACH TIME a structure is to be constructed and the value is used as the initial value of the slot. Options are either a keyword id, or the keyword followed by its argument list. Options are described below. _____ _____ _____ macro macro A call to a constructor macro has the form: MakeThing( slot-name-1( value-expr-1 ), slot-name-2( value-expr-2 ), ... ); The slot-name:value lists override the default-init values which were part of the structure definition. Note that the slot-names look like unary functions of the value, so the parens can be left off. A call to MakeThing with no arguments of course takes all of the default values. The order of evaluation of the default-init forms and the list of assigned values is undefined, so code should not depend upon the ordering. ____________ ____ Implementors Note: Common/LispMachine Lisps define it this way, but Is this necessary? It wouldn't be too tough to make the order be the same as the struct defn, or the argument order in the constructor call. Maybe they PSL Manual 7 February 1983 Utilities section 17.6 page 17.17 think such things should not be advertised and thus constrained in the future. Or perhaps the theory is that constructs such as this can be compiled more efficiently if the ordering is flexible?? Also, should the overridden default-init forms be evaluated or not? I think not. _____ _____ _____ macro macro The alterant macro calls have a similar form: AlterThing( thing, slot-name-1 value-expr-1, slot-name-2 value-expr-2, ... ); The first argument evaluates to the struct to be altered. (The optional parens were left off here.) This is just a multiple-assignment form, which eventually goes through the slot depositors. Remember that the slot-names are used, not the depositor names. (See !:Prefix, below.) The altered structure instance is returned as the value of an Alterant macro. Implementators note: Common/LispMachine Lisp defines this such that all of the slots are altered in parallel AFTER the new value forms are evaluated, but still with the order of evaluation of the forms undefined. This seemed to lose more than it gained, but arguments for its worth will be entertained. 17.6.1. Options 17.6.1. Options 17.6.1. Options Structure options appear as an argument list to the struct-name. Many of the options themselves take argument lists, which are sometimes optional. Option ids all start with a colon (!:), on the theory that this distinguishes them from other things. By default, the names of the constructor, alterant and predicate macros are MakeName, AlterName and NameP. "Name" is the struct-name. The !:Constructor, !:Alterant, and !:Predicate options can be used to override the default names. Their argument is the name to use, and a name of NIL causes the respective macro not to be defined at all. The !:Creator option causes a different form of constructor to be defined, in addition to the regular "Make" constructor (which can be suppressed.) As in the !:Constructor option above, an argument supplies the name of the macro, but the default name in this case is CreateName. A call to a Creator macro has the form: CreateThing( slot-value-1, slot-value-2, ... ); ___ ____ __ _______ All of the slot-values of the structure must be present, in the order they appear in the structure definition. No checking is done, other than assuring that the number of values is the same as the number of slots. For ___ ___ ___________ obvious reasons, constructors of this form are not recommended for Utilities 7 February 1983 PSL Manual page 17.18 section 17.6 structures with many fields, or which may be expanded or modified. Slot selector macros may appear on either the left side or the right side of an assignment. They are by default named the same as the slot-names, but can be given a common prefix by the !:Prefix option. If !:Prefix does not have an argument, the structure name is the prefix. If there is an argument, it should be a string or an id whose print name is the prefix. The !:Include option allows building a new structure definition as an extension of an old one. The required argument is the name of a previously defined structure type. The access functions for the slots of the source type also works on instances of the new type. This can be used to build hierarchies of types. The source types contain generic information in common to the more specific subtypes which !:Include them. The !:IncludeInit option takes an argument list of "slot-name(default- init)" pairs, like slot-descriptors without slot-options, and files them away to modify the default-init values for fields inherited as part of the !:Included structure type. 17.6.2. Slot Options 17.6.2. Slot Options 17.6.2. Slot Options Slot-options include the !:Type option, which has an argument declaring the type of the slot as a type id or list of permissible type ids. This is not enforced now, but anticipates the Mode system structures. The !:UserGet and !:UserPut slot-options allow overriding the simple vector reference and assignment semantics of the generated selector macros with user-defined functions. The !:UserGet FNAME is a combination of the slot-name and a !:Prefix if applicable. The !:UserPut FNAME is the same, with "Put" prefixed. One application of this capability is building depositors which handle the incremental maintenance of parallel data structures as a side effect, such as automatically maintaining display file representations of objects which are resident in a remote display processor in parallel with modifications to the LISP structures which describe the objects. The Make and Create macros bypass the depositors, while Alter uses them. 17.6.3. A Simple Example 17.6.3. A Simple Example 17.6.3. A Simple Example (Input lines have a "> " prompt at the beginning.) PSL Manual 7 February 1983 Utilities section 17.6 page 17.19 > % (Do definitions twice to see what functions were defined.) > macro procedure TWICE u; list( 'PROGN, second u, second u ); TWICE > % A definition of Complex, structure with Real and Imaginary parts > % Redefine to see what functions were defined. Give 0 Init values > TWICE > Defstruct( Complex( !:Creator(Complex) ), R(0), I(0) ); *** Function `MAKECOMPLEX' has been redefined *** Function `ALTERCOMPLEX' has been redefined *** Function `COMPLEXP' has been redefined *** Function `COMPLEX' has been redefined *** Function `R' has been redefined *** Function `PUTR' has been redefined *** Function `I' has been redefined *** Function `PUTI' has been redefined *** Defstruct `COMPLEX' has been redefined COMPLEX > C0 := MakeComplex(); % Constructor with default inits. [COMPLEX 0 0] > ComplexP C0;% Predicate. T > C1:=MakeComplex( R 1, I 2 ); % Constructor with named values. [COMPLEX 1 2] > R(C1); I(C1);% Named selectors. 1 2 > C2:=Complex(3,4) % Creator with positional values. [COMPLEX 3 4] > AlterComplex( C1, R(2), I(3) ); % Alterant with named values. [COMPLEX 2 3] > C1; [COMPLEX 2 3] > R(C1):=5; I(C1):=6; % Named depositors. 5 6 > C1; [COMPLEX 5 6] > % Show use of Include Option. (Again, redef to show fns defined.) > TWICE Utilities 7 February 1983 PSL Manual page 17.20 section 17.6 > Defstruct( MoreComplex( !:Include(Complex) ), Z(99) ); *** Function `MAKEMORECOMPLEX' has been redefined *** Function `ALTERMORECOMPLEX' has been redefined *** Function `MORECOMPLEXP' has been redefined *** Function `Z' has been redefined *** Function `PUTZ' has been redefined *** Defstruct `MORECOMPLEX' has been redefined MORECOMPLEX > M0 := MakeMoreComplex(); [MORECOMPLEX 0 0 99] > M1 := MakeMoreComplex( R 1, I 2, Z 3 ); [MORECOMPLEX 1 2 3] > R C1; 5 > R M1; 1 > % A more complicated example: The structures which are used in the > % Defstruct facility to represent defstructs. (The EX prefix has > % been added to the names to protect the innocent...) > TWICE% Redef to show fns generated. > Defstruct( > EXDefstructDescriptor( !:Prefix(EXDsDesc), !:Creator ), >DsSize(!:Type int ), % (Upper Bound of vector.) >Prefix(!:Type string ), >SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) >ConsName( !:Type fnId ), >AltrName( !:Type fnId ), >PredName( !:Type fnId ), >CreateName( !:Type fnId ), >Include( !:Type typeid ), >InclInit( !:Type alist ) > ); *** Function `MAKEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `ALTEREXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDEFSTRUCTDESCRIPTORP' has been redefined *** Function `CREATEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDSDESCDSSIZE' has been redefined *** Function `PUTEXDSDESCDSSIZE' has been redefined *** Function `EXDSDESCPREFIX' has been redefined *** Function `PUTEXDSDESCPREFIX' has been redefined *** Function `EXDSDESCSLOTALIST' has been redefined *** Function `PUTEXDSDESCSLOTALIST' has been redefined *** Function `EXDSDESCCONSNAME' has been redefined *** Function `PUTEXDSDESCCONSNAME' has been redefined *** Function `EXDSDESCALTRNAME' has been redefined *** Function `PUTEXDSDESCALTRNAME' has been redefined PSL Manual 7 February 1983 Utilities section 17.6 page 17.21 *** Function `EXDSDESCPREDNAME' has been redefined *** Function `PUTEXDSDESCPREDNAME' has been redefined *** Function `EXDSDESCCREATENAME' has been redefined *** Function `PUTEXDSDESCCREATENAME' has been redefined *** Function `EXDSDESCINCLUDE' has been redefined *** Function `PUTEXDSDESCINCLUDE' has been redefined *** Function `EXDSDESCINCLINIT' has been redefined *** Function `PUTEXDSDESCINCLINIT' has been redefined *** Defstruct `EXDEFSTRUCTDESCRIPTOR' has been redefined EXDEFSTRUCTDESCRIPTOR > TWICE% Redef to show fns generated. > Defstruct( > EXSlotDescriptor( !:Prefix(EXSlotDesc), !:Creator ), >SlotNum( !:Type int ), >InitForm( !:Type form ), >SlotFn(!:Type fnId ), % Selector/Depositor id. >SlotType( !:Type type ), % Hm... >UserGet( !:Type boolean ), >UserPut( !:Type boolean ) > ); *** Function `MAKEEXSLOTDESCRIPTOR' has been redefined *** Function `ALTEREXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCRIPTORP' has been redefined *** Function `CREATEEXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCSLOTNUM' has been redefined *** Function `PUTEXSLOTDESCSLOTNUM' has been redefined *** Function `EXSLOTDESCINITFORM' has been redefined *** Function `PUTEXSLOTDESCINITFORM' has been redefined *** Function `EXSLOTDESCSLOTFN' has been redefined *** Function `PUTEXSLOTDESCSLOTFN' has been redefined *** Function `EXSLOTDESCSLOTTYPE' has been redefined *** Function `PUTEXSLOTDESCSLOTTYPE' has been redefined *** Function `EXSLOTDESCUSERGET' has been redefined *** Function `PUTEXSLOTDESCUSERGET' has been redefined *** Function `EXSLOTDESCUSERPUT' has been redefined *** Function `PUTEXSLOTDESCUSERPUT' has been redefined *** Defstruct `EXSLOTDESCRIPTOR' has been redefined EXSLOTDESCRIPTOR > END; NIL Utilities 7 February 1983 PSL Manual page 17.22 section 17.7 17.7. DefConst 17.7. DefConst 17.7. DefConst DefConst DefConst _ __ _ ______ _________ _____ (DefConst [U:id V:number]): Undefined macro DefConst DefConst DefConst is a simple means for defining and using symbolic constants, as an alternative to the heavy-handed NEWNAM or DEFINE facility in REDUCE/RLISP. Constants are defined thus: DefConst(FooSize, 3); or as sequential pairs: DEFCONST(FOOSIZE, 3, BARSIZE, 4); Const Const _ __ ______ _____ (Const U:id): number macro Const Const They are referred to by the macro Const, so CONST(FOOSIZE) would be replaced by 3. 17.8. Functions for Sorting 17.8. Functions for Sorting 17.8. Functions for Sorting The Gsort module provides functions for sorting lists and vectors. Some __________ ________ of the functions take a comparison function as an argument. The comparison function takes two arguments and returns NIL if they are out of order, i.e. if the second argument should come before the first in the sorted result. Lambda expressions are acceptable as comparison functions. Gsort Gsort _____ ____ ______ ___ __ __ ________ ____ ______ ____ (Gsort TABLE:{list,vector} leq-fn:{id,function}): {list,vector} expr ____ ______ ___ __ Returns a sorted list or vector. LEQ-FN is the comparison _____ function used to determine the sorting order. The original TABLE Gsort Gsort is unchanged. Gsort uses a stable sorting algorithm. In other _ _ _ words, if X appears before Y in the original table then X will _ _ _ appear before Y in the final table unless X and Y are out of _ _ order. (An unstable sort, on the other hand, might swap X and Y _ _ even if they're in order. This could happen when X and Y have the same "key field", so either one could come first without making a difference to the comparison function.) GmergeSort GmergeSort _____ ____ ______ ___ __ __ ________ ____ ______ ____ (GmergeSort TABLE:{list,vector} leq-fn:{id,function}): {list,vector} expr Gsort Gsort _____ The same as Gsort, but destructively modifies the TABLE argument. GmergeSort Gsort GmergeSort Gsort GmergeSort has the advantage of being somewhat faster than Gsort. Note that you should use the value returned by the function-- PSL Manual 7 February 1983 Utilities section 17.8 page 17.23 don't depend on the modified argument to give the right answer. IdSort IdSort _____ ____ ______ ____ ______ ____ (IdSort TABLE:{list,vector}): {list,vector} expr __ Returns a table of ids sorted into alphabetical order. The original table is unchanged. Case is not significant in determining the alphabetical order. The table may contain ______ __ strings as well as ids. The following example illustrates the use of Gsort. 1 lisp> (load gsort) NIL 2 lisp> (setq X '(3 8 -7 2 1 5)) (3 8 -7 2 1 5) 3 lisp> % Sort from smallest to largest. 3 lisp> (Gsort X 'leq) (-7 1 2 3 5 8) 4 lisp> % Sort from largest to smallest. 4 lisp> (GmergeSort X 'geq) (8 5 3 2 1 -7) 5 lisp> % Note that X was "destroyed" by GmergeSort. 5 lisp> X (3 2 1 -7) 6 lisp> 6 lisp> % Here's IdSort, taking a vector as its argument. 6 lisp> (IdSort '[the quick brown fox jumped over the lazy dog]) [BROWN DOG FOX JUMPED LAZY OVER QUICK THE THE] 7 lisp> 7 lisp> % Some examples of user defined comparison functions... 7 lisp> (setq X '(("Joe" . 20000) ("Moe" . 21000) ("Larry" . 7000))) (("Joe" . 20000) ("Moe" . 21000) ("Larry" . 7000)) 8 lisp> 8 lisp> % First, sort the list alphabetically according to name, 8 lisp> % using a lambda expression as the comparison function. 8 lisp> (Gsort X 8 lisp> '(lambda (X Y) (string-not-greaterp (car X) (car Y)))) (("Joe" . 20000) ("Larry" . 7000) ("Moe" . 21000)) 9 lisp> 9 lisp> % Now, define a comparison function that compares cdrs of 9 lisp> % pairs, and returns T if the first is less than or equal 9 lisp> % to the second. 9 lisp> (de cdr_leq (pair1 pair2) 9 lisp> (leq (cdr pair1) (cdr pair2))) CDR_LEQ 10 lisp> 10 lisp> % Use the cdr_leq function to sort X. 10 lisp> (Gsort X 'cdr_leq) (("Larry" . 7000) ("Joe" . 20000) ("Moe" . 21000)) Utilities 7 February 1983 PSL Manual page 17.24 section 17.9 17.9. Hashing Cons 17.9. Hashing Cons 17.9. Hashing Cons HCons HCons HCONS is a loadable module. The HCons function creates unique dotted HCons Eq HCons Eq HCons _ _ Eq HCons _ _ _ Eq _ pairs. In other words, HCons(A, B) Eq HCons(C, D) if and only if A Eq C Eq _ Eq _ and B Eq D. This allows rapid tests for equality between structures, at the cost of expending more time in creating the structures. The use of HCons HCons HCons may also save space in cases where lists share common substructure, since only one copy of the substructure is stored. Hcons Hcons ____ ____ _____ Hcons works by keeping a pair hash table of all pairs that have been HCons HCons created by HCons. (So the space advantage of sharing substructure may be offset by the space consumed by table entries.) This hash table also allows the system to store property lists for pairs--in the same way that LISP has property lists for identifiers. HCons RplacA RplacD HCons ______ ___ RplacA RplacD Pairs created by HCons should not be modified with RplacA and RplacD. Doing so will make the pair hash table inconsistent, as well as being very likely to modify structure shared with something that you don't wish to change. Also note that large numbers may be equal without being eq, so the HCons Eq HCons HCons Eq HCons HCons of two large numbers may not be Eq to the HCons of two other numbers that appear to be the same. (Similar warnings hold for strings and vectors.) The following "user" functions are provided by HCONS: HCons HCons _ ___ ____ _____ (HCons [U:any]): pair macro HCons HCons The HCons macro takes one or more arguments and returns their "hashed cons" (right associatively). With two arguments this Cons Cons corresponds to a call of Cons. HList HList _ ___ ____ _____ (HList [U:any]): list nexpr HList List HList List HList is the "HCONS version" of the List function. HCopy HCopy _ ___ ___ _____ (HCopy U:any): any macro HCopy Copy HCopy HCopy Copy HCopy HCopy is the HCONS version of the Copy function. Note that HCopy Copy Copy serves a very different purpose than Copy, which is usually used to copy a structure so that destructive changes can be made to HCopy HCopy the copy without changing the original. HCopy only copies those Cons Cons parts of the structure which haven't already been "Consed HCons HCons together" by HCons. HAppend HAppend _ ____ _ ____ ____ ____ (HAppend U:list V:list): list expr HCons Append HCons Append The HCons version of Append. PSL Manual 7 February 1983 Utilities section 17.9 page 17.25 HReverse HReverse _ ____ ____ ____ (HReverse U:list): list expr HCons Reverse HCons Reverse The HCons version of Reverse. Get Put Get Put The following two functions can be used to "Get" and "Put" properties for pairs or identifiers. The pairs for these functions must be created by HCons SetF HCons SetF HCons. These functions are known to the SetF macro. Extended-Put Extended-Put _ __ ____ ___ __ ____ ___ ___ ____ (Extended-Put U:{id,pair} IND:id PROP:any): any expr Extended-Get Extended-Get _ __ ____ ___ ___ ___ ____ (Extended-Get U:{id,pair} IND:any): any expr 17.10. Graph-to-Tree 17.10. Graph-to-Tree 17.10. Graph-to-Tree GRAPH-TO-TREE is a loadable module. For resident functions printing circular lists see Section 15.8. Graph-to-Tree Graph-to-Tree _ ____ ____ ____ (Graph-to-Tree A:form): form expr Graph-to-Tree Graph-to-Tree The function Graph-to-Tree copies an arbitrary s-expression, removing circularity. It does NOT show non-circular shared Eq Eq structure. Places where a substructure is Eq to one of its ancestors are replaced by non-interned ids of the form <n> where n is a small integer. The parent is replaced by a two element list of the form (<n>: u) where the n's match, and u is the (de-circularized) structure. This is most useful in adapting any printer for use with circular structures. CPrint CPrint _ ___ ___ ____ (CPrint A:any): NIL expr CPrint CPrint The function CPrint, also defined in the module GRAPH-TO-TREE, is PrettyPrint Graph-to-Tree PrettyPrint Graph-to-Tree simply (PrettyPrint (Graph-to-Tree X)). Note that GRAPH-TO-TREE is very embryonic. It is MUCH more inefficient than it needs to be, heavily consing. A better implementation would use a stack (vector) instead of lists to hold intermediate expressions for comparison, and would not copy non-circular structure. In addition facilities should be added for optionally showing shared structure, for performing the inverse operation, and for also editing long or deep structures. Finally, the output representation was chosen at random and can probably be improved, or at least brought in line with CL or some other standard. Utilities 7 February 1983 PSL Manual page 17.26 section 17.11 17.11. Inspect Utility 17.11. Inspect Utility 17.11. Inspect Utility INSPECT is a loadable module. Inspect Inspect ________ ______ ____ (Inspect FILENAME:string): expr This is a simple utility which scans the contents of a source file to tell what functions are defined in it. It will be embellished slightly to permit the on-line querying of certain Inspect Inspect attributes of files. Inspect reads one or more files, printing and collecting information on defined functions. Usage: (LOAD INSPECT) (INSPECT "file-name") % Scans the file, and prints proc % names. It also % builds the lists ProcedureList!* % FileList!* and ProcFileList!* % File-Name can DSKIN other files On the Fly printing is controlled by !*PrintInspect, default is T. Other lists built include FileList!* and ProcFileList!*, which is a list of (procedure . filename) for multi-file processing. For more complete process, do: (LOAD INSPECT) (OFF PRINTINSPECT) (INSPECTOUT) (DSKIN ...) (DSKIN ...) (INSPECTEND) |
Added psl-1983/3-1/lpt/18-complr.lpt version [276c7cbd14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Compiler and Loader section 18.0 page 18.1 CHAPTER 18 CHAPTER 18 CHAPTER 18 LOADER AND COMPILER LOADER AND COMPILER LOADER AND COMPILER 18.1. Introduction . . . . . . . . . . . . . . . 18.1 18.2. The Compiler . . . . . . . . . . . . . . . 18.2 18.2.1. Compiling Functions into Memory . . . . . . 18.2 18.2.2. Compiling Functions into FASL Files . . . . . 18.3 18.2.3. Loading FASL Files. . . . . . . . . . . 18.3 18.2.4. Functions to Control the Time When Something is Done 18.5 . 18.2.5. Order of Functions for Compilation . . . . . 18.6 18.2.6. Fluid and Global Declarations . . . . . . . 18.6 18.2.7. Switches Controlling Compiler . . . . . . . 18.8 18.2.8. Differences between Compiled and Interpreted Code 18.10 18.2.9. Compiler Errors. . . . . . . . . . . . 18.11 18.3. The Loader. . . . . . . . . . . . . . . . 18.13 18.3.1. Legal LAP Format and Pseudos . . . . . . . 18.14 18.3.2. Examples of LAP for DEC-20, VAX and Apollo. . . 18.14 18.3.3. Lap Switches. . . . . . . . . . . . . 18.17 18.4. Structure and Customization of the Compiler. . . . . 18.18 18.5. First PASS of Compiler. . . . . . . . . . . . 18.19 18.5.1. Tagging Information . . . . . . . . . . 18.19 18.5.2. Source to Source Transformations . . . . . . 18.20 18.6. Second PASS - Basic Code Generation . . . . . . . 18.20 18.6.1. The Cmacros . . . . . . . . . . . . . 18.20 18.6.2. Classes of Functions . . . . . . . . . . 18.23 18.6.3. Open Functions . . . . . . . . . . . . 18.24 18.7. Third PASS - Optimizations . . . . . . . . . . 18.29 18.8. Some Structural Notes on the Compiler. . . . . . . 18.30 18.1. Introduction 18.1. Introduction 18.1. Introduction The functions and facilities in the PSL LISP/SYSLISP compiler and supporting loaders (LAP and FASL) are described in this chapter. [??? This chapter is out of date and will be rewritten soon. ???] [??? This chapter is out of date and will be rewritten soon. ???] [??? This chapter is out of date and will be rewritten soon. ???] 18.2. The Compiler 18.2. The Compiler 18.2. The Compiler The compiler is a version of the Portable LISP Compiler [Griss 81], Compiler and Loader 7 February 1983 PSL Manual page 18.2 section 18.2 1 modified and extended to more efficiently support both LISP and SYSLISP compilation. See the later sections in this chapter and references [Griss 81] and [Benson 81] for more details. 18.2.1. Compiling Functions into Memory 18.2.1. Compiling Functions into Memory 18.2.1. Compiling Functions into Memory __________ ______ !*COMP [Initially: NIL] switch If the compiler is loaded (which is usually the case, otherwise on on execute LOAD COMPILER;), turning on the switch !*COMP (via on comp; in RLISP) causes all subsequent procedure definitions of appropriate type to be compiled automatically and a message of the form <function-name> COMPILED, <words> WORDS, <words> LEFT to be printed. The first number is the number of words of binary program space the compiled function took, and the second number the number of words left unused in binary program space. See !*PWRDS in Section 18.2.7. ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr fexpr nexpr macro expr fexpr nexpr macro Currently, exprs, fexprs, nexprs and macros may be compiled. This is controlled by a flag ('COMPILE) on the property list of the procedure type. If desired, uncompiled functions already resident may be compiled by using Compile Compile _____ __ ____ ___ ____ (Compile NAMES:id-list): any expr 18.2.2. Compiling Functions into FASL Files 18.2.2. Compiling Functions into FASL Files 18.2.2. Compiling Functions into FASL Files Load FaslIn Load FaslIn In order to produce files that may be input using Load or FaslIn, the FaslOut FaslEnd FaslOut FaslEnd FaslOut and FaslEnd pair may be used in RLISP mode: FaslOut FaslOut ____ ______ ___ ____ (FaslOut FILE:string): NIL expr _______________ 1 Many of the recent extensions to the PLC were implemented by John Peterson. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.3 FaslEnd FaslEnd ___ ____ (FaslEnd ): NIL expr FaslOut FaslOut After the command FaslOut has been given, all subsequent S-expressions and function definitions typed in or input from files are processed by the Compiler, LAP and FASL as needed, and ____ output to FILE. Functions are compiled and partially assembled, and output as in a compressed binary form, involving blocks of code and relocation bits. This activity continues until the FaslEnd FaslEnd function FaslEnd terminates this process. FaslOut FaslEnd FaslOut FaslEnd The FaslOut and FaslEnd pair also use the DFPRINT!* mechanism, turning on the switch !*DEFN, and redefining DFPRINT!* to trap the parsed input in the RLISP top-loop. Currently this is not useable from pure LISP level. [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] 18.2.3. Loading FASL Files 18.2.3. Loading FASL Files 18.2.3. Loading FASL Files Two convenient procedures are available for loading FASL files (.b files on the VAX); see Section 18.2.2 for information on producing FASL files. Load Load ____ ______ __ ___ _____ (Load [FILE:{string, id}]): NIL macro ____ Each FILE is converted into a file name of the form "/u/local/lib/psl/file.b" on the VAX, "pl:file.b" on the DEC-20. FaslIn FaslIn An attempt is made to execute the function FaslIn on it. Once ____ loaded, the symbol FILE is added to the GLOBAL variable OPTIONS!*. FaslIn FaslIn ________ ______ ___ ____ (FaslIn FILENAME:string): NIL expr This is an efficient binary read loop, which fetches blocks of __ code, constants and compactly stored ids. It uses a bit-table to relocate code and to identify special LISP-oriented constructs. ________ FILENAME must be a complete file name. ReLoad ReLoad ____ ______ __ ___ _____ (ReLoad [FILE:{string,id}]): NIL macro Removes the filename from the list OPTIONS!* and executes the Load Load function Load. Imports Imports ___________ ____ ___ ____ (Imports MODULENAMES:list): NIL expr LOAD ___________ __ LOAD MODULENAMES is a list of ids representing modules to be LOAD'ed after the module containing this function has been loaded. Imports Imports Imports works only in compiled code. Compiler and Loader 7 February 1983 PSL Manual page 18.4 section 18.2 __________ ______ LOADDIRECTORIES!* [Initially: A list of strings] global Contains a list of strings to append to the front of file names Load Load given in Load commands. This list may be one of the following, if your system is an Apollo, Dec-20, or Vax: ("" "/utah/psl/lap/") ("" "pl:") ("" "/usr/local/src/cmd/psl/dist/lap/") __________ ______ LOADEXTENSIONS!* [Initially: An a-list] global Contains an a-list of (str . fn) in which the str is an extension to append to the end of the filename and fn is a function to apply. The a-list contains ((".b" . FaslIn)(".lap" . LapIn)(".sl" . LapIN)) [??? Describe FASL format in more detail ???] [??? Describe FASL format in more detail ???] [??? Describe FASL format in more detail ???] 18.2.4. Functions to Control the Time When Something is Done 18.2.4. Functions to Control the Time When Something is Done 18.2.4. Functions to Control the Time When Something is Done Which expressions are evaluated during compilation ONLY, which output to the file for LOAD TIME evaluation, and which do both (such as macro definitions) can be controlled by the properties 'EVAL and 'IGNORE on certain function names, or the following functions. CommentOutCode CommentOutCode _ ____ ___ _____ (CommentOutCode U:form): NIL macro _ Comment out a single expression; use <<U>> to comment out a block of code. CompileTime CompileTime _ ____ ___ ____ (CompileTime U:form): NIL expr _ Evaluate the expression U at compile time only, such as defining auxiliary smacros and macros that should not go into the file. Certain functions have the FLAG 'IGNORE on their property lists to achieve the same effect. E.g. FLAG('(LAPOUT LAPEND),'IGNORE) has been done. BothTimes BothTimes _ ____ _ ____ ____ (BothTimes U:form): U:form expr Evaluate at compile and load time. This is equivalent in effect Flag Flag to executing Flag('(f1 f2),'EVAL) for certain functions. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.5 LoadTime LoadTime _ ____ _ ____ ____ (LoadTime U:form): U:form expr Evaluate at load time only. Should not even compile code, just pass direct to file. [??? EVAL and IGNORE are for compatibility, and enable the above sort [??? EVAL and IGNORE are for compatibility, and enable the above sort [??? EVAL and IGNORE are for compatibility, and enable the above sort of functions to be easily written. The user should AVOID EVAL and of functions to be easily written. The user should AVOID EVAL and of functions to be easily written. The user should AVOID EVAL and IGNORE flags, if Possible ???] IGNORE flags, if Possible ???] IGNORE flags, if Possible ???] 18.2.5. Order of Functions for Compilation 18.2.5. Order of Functions for Compilation 18.2.5. Order of Functions for Compilation ____ ____ ____ expr expr Non-expr procedures must be defined before their use in a compiled function, since the compiler treats the various function types differently. _____ _____ _____ _____ _____ _____ Macro fexpr Macro fexpr Macros are expanded and then compiled; the argument list fexprs quoted; the _____ _____ _____ nexpr nexpr arguments of nexprs are collected into a single list. Sometimes it is convenient to define a Dummy version of the function of appropriate type, to be redefined later. This acts as an "External or Forward" declaration of the function. [??? Add such a declaration. ???] [??? Add such a declaration. ???] [??? Add such a declaration. ???] 18.2.6. Fluid and Global Declarations 18.2.6. Fluid and Global Declarations 18.2.6. Fluid and Global Declarations The FLUID and GLOBAL declarations must be used to indicate variables that are to be used as non-LOCALs in compiled code. Currently, the compiler defaults variables bound in a particular procedure to LOCAL. The effect of this is that the variable only exists as an "anonymous" stack location; its name is compiled away and called routines cannot see it (i.e. they would have to use the name). Undeclared non-LOCAL variables are automatically declared FLUID by the compiler with a warning. In many cases, this means that a previous procedure that bound this variable should have known about this as a FLUID. Declare it with FLUID, below, and recompile, since the caller cannot be automatically fixed. [??? Should we provide an !*AllFluid switch to make the default Fluid, [??? Should we provide an !*AllFluid switch to make the default Fluid, [??? Should we provide an !*AllFluid switch to make the default Fluid, or should we make Interpreter have a LOCAL variable as default, or both or should we make Interpreter have a LOCAL variable as default, or both or should we make Interpreter have a LOCAL variable as default, or both ???] ???] ???] Fluid Fluid _____ __ ____ ___ ____ (Fluid NAMES:id-list): any expr Declares each variable FLUID (if not previously declared); this Prog Prog means that it can be used as a Prog LOCAL, or as a parameter. On entry to the procedure, its current value is saved on the Binding Stack (BSTACK), and all access is always to the VALUE cell Throw Error Throw Error (SYMVAL) of the variable; on exit (or Throw or Error), the old values are restored. Compiler and Loader 7 February 1983 PSL Manual page 18.6 section 18.2 Global Global _____ __ ____ ___ ____ (Global NAMES:id-list): any expr Declares each variable GLOBAL (if not previously declared); this means that it cannot be used as a LOCAL, or as a parameter. Access is always to the VALUE cell (SYMVAL) of the variable. [??? Should we eliminate GLOBALs ???] [??? Should we eliminate GLOBALs ???] [??? Should we eliminate GLOBALs ???] 18.2.7. Switches Controlling Compiler 18.2.7. Switches Controlling Compiler 18.2.7. Switches Controlling Compiler The compilation process is controlled by a number of switches, as well as the above declarations and the !*COMP switch, of course. __________ ______ !*R2I [Initially: T] switch T T If T, causes recursion removal if possible, converting recursive calls on a function into a jump to its start. If this is not possible, it uses a faster call to its own "internal" entry, rather than going via the Symbol Table function cell. The effect in both cases is that tracing this function does not show the internal or eliminated recursive calls, nor the backtrace information. __________ ______ !*NOLINKE [Initially: NIL] switch T NIL T NIL If T, inhibits use of !*LINKE cmacro. If NIL, "exit" calls on functions that would then immediately return. For example, the calls on FOO(x) and FEE(X) in PROCEDURE DUM(X,Y); IF X=Y THEN FOO(X) ELSE FEE(X+Y); can be converted into direct JUMP's to FEE or FOO's entry point. This is known as a "tail-recursive" call being converted to a jump. If this happens, there is no indication of the call of DUM on the backtrace stack if FEE or FOO cause an error. __________ ______ !*ORD [Initially: NIL] switch T T If T, forces the compiler to compile arguments in Left-Right Order, even though more optimal code can be generated. [??? !*ORD currently has a bug, and may not be fixed for some [??? !*ORD currently has a bug, and may not be fixed for some [??? !*ORD currently has a bug, and may not be fixed for some time. Thus do NOT depend on evaluation order in argument time. Thus do NOT depend on evaluation order in argument time. Thus do NOT depend on evaluation order in argument lists ???] lists ???] lists ???] PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.7 __________ ______ !*MODULE [Initially: NIL] switch Indicates block compilation (a future extension of this compiler). When implemented, even more function and variable names are "compiled away". The following switches control the printing of information during the compilation process: __________ ______ !*PWRDS [Initially: NIL] switch T T If T, causes the compiled size to be printed in the form *** NAME: base NNN, length MMM The base is in octal, the length is in current Radix. [??? more mnemonic name ???] [??? more mnemonic name ???] [??? more mnemonic name ???] __________ ______ !*PLAP [Initially: NIL] switch T T If T, causes the printing of the portable cmacros produced by the the compiler. Most of this information is printed by the resident LAP, and controlled by its switches, described below. 18.2.8. Differences between Compiled and Interpreted Code 18.2.8. Differences between Compiled and Interpreted Code 18.2.8. Differences between Compiled and Interpreted Code The following just re-iterates some of the points made above and in other Sections of the manual regarding the "obscure" differences that compilation introduces. [??? This needs some careful work, and perhaps some effort to reduce [??? This needs some careful work, and perhaps some effort to reduce [??? This needs some careful work, and perhaps some effort to reduce the list of differences ???] the list of differences ???] the list of differences ???] In the process of compilation, many functions are open-coded, and hence cannot be redefined or traced in the compiled code. Such functions are noted to be OPEN-CODED in the manual. If called from compiled code, the call on an open-compiled function is replaced by a series of online instructions. Most of these functions have some sort of indicator on their property lists: 'OPEN, 'ANYREG, 'CMACRO, 'COMPFN, etc. For example: SETQ, CAR, CDR, COND, WPLUS2, MAP functions, PROG, PROGN, etc. Also note that _____ _____ _____ macro macro some functions are defined as macros, which convert to some other form (such as PROG), which itself might compile open. Some optimizations are performed that cause inaccessible or redundant code to be removed, e.g. 0*foo(x) could cause foo(x) not to be called. Compiler and Loader 7 February 1983 PSL Manual page 18.8 section 18.2 _____ ______ _____ ______ _____ ______ Fluid global Fluid global Unless variables are declared (or detected) to be Fluid or global, they _____ _____ _____ local local are compiled as local variables. This causes their names to disappear, and so are not visible on the Binding Stack. Further more, these variables are NOT available to functions called in the dynamic scope of the function containing their binding. _____ _____ _____ _____ _____ _____ _____ _____ _____ macro fexpr nexpr macro fexpr nexpr Since compiled calls on macros, fexprs and nexprs are different from the ____ ____ ____ expr expr default exprs, these functions must be declared (or defined) before _____ _____ _____ _____ _____ _____ fexpr nexpr fexpr nexpr compiling the code that uses them. While fexprs and nexprs may _____ _____ _____ macro macro subsequently be redefined (as new functions of same type), macros are executed by the compiler to get the replacement form, which is then compiled. The interpreter of course picks up the most recent definition of ANY function, and so functions can switch type as well as body. [??? If we expand macros at PUTD time, then this difference will go [??? If we expand macros at PUTD time, then this difference will go [??? If we expand macros at PUTD time, then this difference will go away. ???] away. ???] away. ???] As noted above, the !*R2I, !*NOLINKE and !*MODULE switches cause certain functions to call other functions (or themselves usually) by a faster route (JUMP or internal call). This means that the recursion or call may not be visible during tracing or backtrace. 18.2.9. Compiler Errors 18.2.9. Compiler Errors 18.2.9. Compiler Errors A number of compiler errors are listed below with possible explanations of the error. *** Function form converted to APPLY Car Car This message indicates that the Car of a form is either a. Non-atomic, b. a local variable, or c. a global or fluid variable. The compiler converts (F X1 X2 ...), where F is one of the above, to (APPLY F (LIST X1 X2 ...)). *** NAME already SYSLISP non-local This indicates that NAME is either a WVAR or WARRAY in SYSLISP mode, but is being used as a local variable in LISP mode. No special action is taken. *** WVAR NAME used as local This indicates that NAME is a WVAR, but is being used as a bound variable in SYSLISP mode. The variable is treated as an an anonymous local variable within the scope of its binding. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.9 *** NAME already SYSLISP non-local This indicates that a variable was previously declared as a SYSLISP WVAR or WARRAY and is now being used as a LISP fluid or global. No special action is taken. *** NAME already LISP non-local This indicates that a variable was previously declared as a LISP fluid or global and is now being used as a SYSLISP WVAR or WARRAY. No special action is taken. *** Undefined symbol NAME in Syslisp, treated as WVAR A variable was encountered in SYSLISP mode which is not local nor a WVAR or WARRAY. The compiler declares it a WVAR. This is an error, all WVARs should be explicitly declared. *** NAME declared fluid A variable was encountered in LISP mode which is not local nor a previously declared fluid or global. The compiler declares it fluid. This is sometimes an error, if the variable was used strictly locally in an earlier function definition, but was intended to be bound non-locally. All fluids should be declared before being used. 18.3. The Loader 18.3. The Loader 18.3. The Loader [??? update ???] [??? update ???] [??? update ???] Currently, PSL on the DEC-20 provides a simple LISP assembler, LAP. This is modeled after the original LISP 1.6 LAP, although completely reimplemented to take advantage of PSL constructs, and to support the additional requirements of SYSLISP. In the process of implementing the VAX LAP and developing the LAP-to-ASM translator required to bootstrap PSL onto the next machine (Apollo MC68000), a much more table-driven form of LAP was designed to make all LAP's, LAP-to-ASM's and FASL's (fast loaders, sometimes called FAP) easier to maintain. This is now in use on the VAX and being used to implement Apollo PSL. [??? FASL now works ???] [??? FASL now works ???] [??? FASL now works ???] Until that is complete, we will briefly describe the available functions, and give a sample of current and future LAP; this Section will be completely rewritten in the next revision. LAP is currently a full two pass assembler; on the VAX and Apollo it also includes a pass to optimize long and short jumps. Compiler and Loader 7 February 1983 PSL Manual page 18.10 section 18.3 LAP LAP ____ ____ ____ _______ ____ (LAP CODE:list): code-pointer expr ____ CODE is a list of legal LAP forms, including: a. Machine specific Mnemonics (using opcode-names from the assembler on the DEC-20, VAX or Apollo). b. Compiler cmacros (which expand in a machine specific way). These can be thought of as "generic" or LISP-oriented instructions. See the next Section on the Compiler details, and list of legal cmacros. c. LAP pseudo instructions, to declare entry points, indicate data and constants, etc. The first pass of LAP converts mnemonics into LISP integers, doing as much of the assembly as possible, allocating labels and constants. The second (and third?) pass fills in labels and completes the assembly, depositing code into the next available locations in BPS, or creating FASL or LAP files. [??? What is BPS (binary program space) ???] [??? What is BPS (binary program space) ???] [??? What is BPS (binary program space) ???] 18.3.1. Legal LAP Format and Pseudos 18.3.1. Legal LAP Format and Pseudos 18.3.1. Legal LAP Format and Pseudos [??? Describe LAP format in detail ???] [??? Describe LAP format in detail ???] [??? Describe LAP format in detail ???] 18.3.2. Examples of LAP for DEC-20, VAX and Apollo 18.3.2. Examples of LAP for DEC-20, VAX and Apollo 18.3.2. Examples of LAP for DEC-20, VAX and Apollo The following is a piece of VAX specific LAP, using the current "new" format. Apart from the VAX mnemonics, notice the extra tags around the register names, and the symbols to indicate addressing modes (essentially PREFIX syntax rather then INFIX @ etc.). This is from PV:APPLY-LAP.RED. Note they are almost ENTIRELY written in cmacros, to aid in re-coding for the next machine. PSL Manual 7 February 1983 Compiler and Loader section 18.3 page 18.11 lap '((!*entry FastApply expr 0) %. Apply with arguments loaded % Called with arguments in the registers and functional form in t1 (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*FIELD (reg t1) (reg t1) (WConst InfStartingBit) (WConst InfBitLength)) (!*JUMPNOTEQ (Label NotAnID) (reg t2) (WConst ID)) (!*WTIMES2 (reg t1) (WConst AddressingUnitsPerFunctionCell)) (!*JUMP (MEMORY (reg t1) (WArray SymFnc))) NotAnID (!*JUMPNOTEQ (Label NotACodePointer) (reg t2) (WConst CODE)) (!*JUMP (MEMORY (reg t1) (WConst 0))) NotACodePointer (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst (!*MOVE (MEMORY (reg t1) (WConst 0)) (reg t2)) % CAR with pair already unta (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (QUOTE L (!*MOVE (reg t1) (reg t2)) % put lambda form in t2 (!*PUSH (QUOTE NIL)) % align stack (!*JCALL FastLambdaApply) IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form in Apply") (reg 1)) (!*MOVE (reg t1) (reg 2)) (!*CALL List2) (!*JCALL StdError) ); lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code % Called by JSB % (subl3 (immediate (plus2 (WArray SymFnc) 6)) (autoincrement (reg st)) (reg t1)) (divl2 6 (reg t1)) (!*MKITEM (reg t1) (WConst ID)) (!*MOVE (reg t1) (reg 2)) (!*MOVE (QUOTE "Undefined function %r called from compiled c (reg 1)) (!*CALL BldMsg) (!*JCALL StdError) ); The following is a piece of Apollo specific LAP, using the current NEW format. Apart from the MC68000 mnemonics, notice the extra tags around the register names, and the symbols to indicate addressing modes (essentially PREFIX syntax rather then INFIX @ etc.). This is from P68:M68K-USEFUL- LAP.RED. Compiler and Loader 7 February 1983 PSL Manual page 18.12 section 18.3 % Signed multiply of 32 bits numbers in A1 and A2, % returns 64 bits in A1 and A2, low in A1 high in A2 % Clobbers D1,D2,D3,D4,D5,D6,D7, no saving % [Can insert MOVEM!.L D1-D7,-(SP) % and MOVEM!.L (SP)+,D1-D7] LAP '((!*entry Mult32 expr 2) % Arguments in A1 and A2 (move!.l (reg a1) (reg d1)) (move!.l (reg a1) (reg d6)) (move!.l (reg a2) (reg d2)) (move!.l (reg a2) (reg d7)) % Need copies % Now do Unsigned Multiply (move!.l (reg d1) (reg d3)) (move!.l (reg d1) (reg d4)) (swap (reg d4)) (move!.l (reg d2) (reg d5)) (swap (reg d5)) % Swapped for partial products (mulu!.w (reg d2) (reg d1)) % partial products (pp1) (mulu!.w (reg d4) (reg d2)) % pp2 (mulu!.w (reg d5) (reg d3)) % pp3 (mulu!.w (reg d5) (reg d4)) % pp4 (swap (reg d1)) % sum1=pp#2low+pp#1hi (add (reg d2) (reg d1)) (clr!.l (reg d5)) (addx!.l (reg d5) (reg d4)) % propagate carry (add (reg d3) (reg d1)) % sum2=sum1+pp#3low (addx!.l (reg d5) (reg d4)) % carry inot pp#4 (swap (reg d1)) % low order product (clr (reg d2)) (swap (reg d2)) (clr (reg d3)) (swap (reg d3)) (add!.l (reg d3) (reg d2)) % Sum3=pp2low+pp3Hi (add!.l (reg d4) (reg d2)) % Sum4=Sum3+pp4 % Now do adjustment (tst!.l (reg d7)) % Negative (bpl!.s chkd6) % nope (sub!.l (reg d6) (reg d2)) % Flip chkd6 (tst!.l (reg d6)) % Negative (bpl!.s done) % nope (sub!.l (reg d7) (reg d2)) % Flip done (movea!.l (reg d1) (reg a1)) % low part (movea!.l (reg d2) (reg a2)) % high part (rts)); PSL Manual 7 February 1983 Compiler and Loader section 18.3 page 18.13 18.3.3. Lap Switches 18.3.3. Lap Switches 18.3.3. Lap Switches The following switches control the printing of information from LAP and other optional behavior of LAP: __________ ______ !*PLAP [Initially: NIL] switch Causes LAP forms to printed before expansion. Used mainly to see output of compiler before assembly. __________ ______ !*PGWD [Initially: NIL] switch Causes LAP to print the actual DEC-20 mnemonics and corresponding assembled instruction in octal, displaying OPCODE, REGISTER, INDIRECT, INDEX and ADDRESS fields. __________ ______ !*PWRDS [Initially: T] switch Prints a LAP message of the form *** NAME: base NNN, length MMM The base is in octal, the length is in current Radix. __________ ______ !*SAVECOM [Initially: T] switch If T, the LAP is deposited in BPS, and the returned Code-Pointer used to (re)define the procedure associated with the (!*entry name type n). __________ ______ !*SAVEDEF [Initially: NIL] switch If T, and if !*SAVECOM is T, saves any preexisting procedure definition under '!*SAVEDEF on the property list of the procedure name, "just in case". LAP also uses the following indicators on property lists: 'MC Cmacros and some mnemonics have associated PASS1 expansions in terms of simpler instructions or operations. The form (mc a1 ... an) has its associated function applied to (a1 ... an). For more details, see "P20:LAP.RED". Compiler and Loader 7 February 1983 PSL Manual page 18.14 section 18.4 18.4. Structure and Customization of the Compiler 18.4. Structure and Customization of the Compiler 18.4. Structure and Customization of the Compiler The following is a brief summary of the compiler structure and model. The purpose of this Section is to aid the user to add new compilation forms, and to understand the task of bootstrapping a new version of PSL. The original paper on the Portable LISP Compiler [Griss 81] has complete details on the original version of the compiler, and should be read in conjunction with this Section. It might be useful to also examine the paper on recent work on the compiler [Griss 82]. [??? This needs a LOT of work ???] [??? This needs a LOT of work ???] [??? This needs a LOT of work ???] The compiler is basically three-pass: ______ ______ ______ macros macros a. The first pass expands ordinary macros, and compiler specific cmacros. It also uses some special purpose 'PA1REFORM and 'PA1FN functions on the property lists of certain functions to produce a simpler and more explicit LISP for the next pass. Variables and constants, x, are explicitly tagged as (FLUID x), (GLOBAL x), (QUOTE x), (WCONST x), etc. b. The second pass recursively compiles the code, using 'COMPFN's to handle special cases, and the recursive function !&COMPILE for the general case. In general, code is compiled to cause function arguments to be loaded into R1...Rn in order, a CALL to the function to be made, and the returned value to appear in R1. Temporaries and function arguments to be reused later are saved on the stack. The compiler allocates a single FRAME for the maximum stack space that might be needed, and then trims it down in the third pass. PSL requires registers R1 ... R15, though not all need be "REAL registers"; the extra are simulated as memory locations. Special cases avoid a lot of LOAD/STORES to move arguments around. The compiled code is emitted as a sequence of abstract LISP machine cmacros. The current set of cmacros is described below. c. The third pass scans the list of cmacros for patterns, removing LOADs and STOREs, redundant JUMP's and LABEL's, compressings the stack frame, and possibly mapping temporaries stored on the stack into any of the REAL registers that would otherwise be unused. This optimized cmacro list is then passed to LAP. 18.5. First PASS of Compiler 18.5. First PASS of Compiler 18.5. First PASS of Compiler PSL Manual 7 February 1983 Compiler and Loader section 18.5 page 18.15 18.5.1. Tagging Information 18.5.1. Tagging Information 18.5.1. Tagging Information This affects many parts of the compiler. The basic idea is that all information is to be tagged. These tags fit in three categories: variable tags, location (register and frame) tags, and constant tags. Tags used for variables must be flagged 'VAR; tags for constants must be flagged 'CONST. Currently, the register tag is REG and the frame tag is FRAME. Frame locations are always positive integers. These tags are used everywhere; thus, register 1 is always described by (REG 1) in both emitted cmacros and internally in the register list REGS. Pass 1 tags all variable references with a source to source transformation of the variables (suitably obscure names must be used for these tags to prevent conflicts with named functions). The purpose behind this tagging is to make the compiler easier to work with in adding new features; new notions of registers, constants, and variables can all be accommodated through new tags. Also, the components of the cmacros are more clearly identified for pass 3. 18.5.2. Source to Source Transformations 18.5.2. Source to Source Transformations 18.5.2. Source to Source Transformations A PA1REFORMFN has been provided to augment PA1FN's. The only difference between these functions is that the PA1REFORM function is passed code which has already been through PASS1. This was previously done by calling pass 1 within a PA1FN. 18.6. Second PASS - Basic Code Generation 18.6. Second PASS - Basic Code Generation 18.6. Second PASS - Basic Code Generation 18.6.1. The Cmacros 18.6.1. The Cmacros 18.6.1. The Cmacros The compiler second pass compiles the input LISP into a series of abstract machine instructions, called cmacros. These are instructions for a LISP-oriented Register machine. ___ _______ ______ _______ The current DEC-20 cmacros Definitions of arguments reg: (REG n) n = 1,2,... MAXNARGS var: frame | (GLOBAL name) | (FLUID name) frame: (FRAME n) n = 0,1,2, .. const: (QUOTE value) | (WCONST value) label: (LABEL symbol) regn: reg | NIL | frame regf: reg | frame loc: reg | var | const Compiler and Loader 7 February 1983 PSL Manual page 18.16 section 18.6 anyreg: (CAR anyreg) | (CDR anyreg) | loc Basic Cmacros for LISP and SYSLISP (!*ALLOC nframe) (!*DEALLOC nframe) (!*ENTRY fname ftype nargs) (!*EXIT nframe) (!*FREERSTR (NONLOCALVARS f1 f2 ...)) (!*JUMP label) (!*JUMPxx label loc loc') where xx = ATOM, EQ, NOTEQ, NOTTYPE, PAIRP, TYPE (!*JUMPON lower upper (label-1 ... Label-n)) (!*LINK fname ftype nargs) (!*LINKE nframe fn type nargs) (!*LINKF nargs reg) where reg contains the function name, nargs an integer (!*LINKEF nframe nargs reg) %/ ? (!*LBL label) (!*LAMBIND (REGISTERS reg1 reg2 ...) (NONLOCALVARS f1 f2 ...)) where f1, f2, ... = (FLUID name ) No frame location will be allocated (depends on switch) (!*LOAD reg anyreg) (!*PROGBIND (NONLOCALVARS f1 f2 ...)) (!*PUSH reg) (!*RPLACA regf loc) (!*RPLACD regf loc) (!*STORE regn var) | (!*STORE regn reg) SYSLISP oriented Cmacros (!*ADDMEM loc) (!*ADJSP ?) (!*DECMEM loc) (!*INCMEM loc) (!*INTINF loc) (!*JUMPWGEQ label loc loc') (!*JUMPWGREATERP label loc loc') (!*JUMPWITHIN label loc loc') (!*JUMPWLEQ label loc loc') (!*JUMPWLESSP label loc loc') (!*MKITEM loc loc') (!*MPYMEM loc loc') (!*NEGMEM loc) (!*SUBMEM loc loc') (!*WAND loc loc') (!*WDIFFERENCE loc loc') (!*WMINUS loc) (!*WNOT loc) (!*WOR loc loc') (!*WPLUS2 loc loc') (!*WSHIFT loc loc') (!*WTIMES2 loc loc') PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.17 (!*WXOR loc loc') _____ _______ 68000 Cmacros Basic LISP and SYSLISP Cmacros (!*ALLOC nframe) (!*CALL fname) (!*DEALLOC nframe) (!*ENTRY fname ftype nargs) (!*EXIT nframe) (!*JCALL fname) (!*JUMP label) (!*JUMPEQ label loc loc') (!*JUMPINTYPE label type) (!*JUMPNOTEQ label loc loc') (!*JUMPNOTINTYPE label loc type) (!*JUMPNOTTYPE label loc type) (!*JUMPTYPE label loc type) (!*LAMBIND label loc loc') (!*LBL label) (!*LINK fname ftype nargs) (!*LINKE fname ftype nargs nframe) (!*MOVE loc loc') (!*PROGBIND label loc loc') (!*PUSH loc) SYSLISP specific Cmacros (!*APOLLOCALL label loc loc') (!*ASHIFT loc loc') (!*FIELD loc loc') (!*FOREIGNLINK loc loc') (!*INF loc loc') (!*JUMPON loc loc') (!*JUMPWGEQ loc loc') (!*JUMPWGREATERP loc loc') (!*JUMPWITHIN loc loc') (!*JUMPWLEQ loc loc') (!*JUMPWLESSP loc loc') (!*LOC loc loc') (!*MKITEM loc loc') (!*PUTFIELD loc loc') (!*PUTINF loc loc') (!*PUTTAG loc loc') (!*SIGNEDFIELD loc loc') (!*TAG loc loc') (!*WAND loc loc') (!*WDIFFERENCE loc loc') (!*WMINUS loc loc') (!*WNOT loc loc') (!*WOR loc loc') Compiler and Loader 7 February 1983 PSL Manual page 18.18 section 18.6 (!*WPLUS2 loc loc') (!*WSHIFT loc loc') (!*WTIMES2 loc loc') (!*WXOR loc loc') 18.6.2. Classes of Functions 18.6.2. Classes of Functions 18.6.2. Classes of Functions The compiler groups functions into four basic classes: a. ANYREG functions. No side effects and can be done in a single register. Passed directly to CMACROs. Viewed as a form of "extended addressing" mode. b. Specially compiled or "OPEN" functions. These are functions have a special compiling function stored under a 'COMPFN indicator. While many of these functions are specially coded, many are written with the aid of supporting patterns; these are called 'OPENFN or 'OPENTST patterns. Some OPEN functions alter registers which are in use, allocate new frames or obtain unused registers. These open functions also include open compilation of tests. c. Built-in or 'stable' functions. These functions are called in the standard fashion by the compiler, but they have properties which are useful to the compiler and are assumed to always hold. Currently, a function may be flagged as NOSIDEEFFECT and have the property DESTROYS, which contains a list of registers destroyed by the function. d. All other functions are assumed to be totally random, destroying every register and causing side effects. [??? Mark non-random functions of various levels elsewhere ???] [??? Mark non-random functions of various levels elsewhere ???] [??? Mark non-random functions of various levels elsewhere ???] The most important of these categories is the OPEN function. It is hoped that improved OPEN functions will eliminate the need for temporary registers to be allocated by the assembler. Most OPEN functions emit cmacros especially tailored for each function. 18.6.3. Open Functions 18.6.3. Open Functions 18.6.3. Open Functions [??? Explain how to CODE them ???] [??? Explain how to CODE them ???] [??? Explain how to CODE them ???] There are 3 basic kinds of open function: a. Test: the destination is a LABEL. PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.19 b. Value: the result is to be placed in a particular register. c. Effect: the result is a side effect, and no destination is needed. Note that an EFFECT open function does not have a destination. It is not really a separate class of function, just a separate usage. Example: (PROGN (SETQ X 0) ... ) - the SETQ is for effect only - could be implemented with a "clear" instruction. (FOO (SETQ X 0) ... ) - here the 0 is also placed in a register (the destination register). The use of OPENTST is also derived from context: in (COND ((EQ A B) ...)) - EQ is interpreted as a test. (RETURN (EQ A B)) , though, must have a value. It should be noted that a pseudo source-source transformation occurs if an OPENTST is called for value: (RETURN (EQ A B)) -> (RETURN (COND ((EQ A B) T) (T NIL))) An OPENTST function always returns T/NIL if called for value. No separate handling for non test cases is needed (as opposed to the effect/value cases for normal OPEN funs in which two separate expansions can be supplied) Also, there are 3 basic issues encountered in generating the code: a. Bringing arguments into registers as needed. b. Emitting the actual code. c. Updating the final register contents. Initially, the arguments to an open function are removed of all but ANYREG functions. Thus, these arguments fall into four classes: a. Registers b. Memory locations (FLUID, GLOBAL, FRAME, !*MEMORY) c. Constants d. ANYREG functions (viewed as extended addressing modes) Compiler and Loader 7 February 1983 PSL Manual page 18.20 section 18.6 Also, along with the arguments coming in is the destination (register or label). The first step is to replace some arguments by registers by emitting LOAD's. This step can be controlled by a function, called the adjust function, which emits LOAD's and replaces the corresponding arguments by registers. Next, cmacros are emitted. These cmacros are selected through a pattern which defines the format of the particular OPEN function call. Note that the pattern is matching the locations of the arguments to the open function. For example, assume that FOO is OPEN, and the call (FOO 'A (CDR B) C D) is encountered. Assume also that B is frame 1, C is frame 2, and D was found in reg 1. The argument list being matched is thus ('A (CDR (FRAME 1)) (FRAME 2) (REG 1)) For most purposes, this would be interpreted as (const anyreg mem reg). Of course, a pattern can use the value of a constant (you might recognize (!*WPLUS2 1 X) as an increment). Also, the actual register may be important for register args, especially if one of the args is also the destination. You would probably emit different code for (REG 1) := (!*WPLUS2 (REG 2) (REG 3)) than (REG 1) := (!*WPLUS2 (REG 1) (REG 2)) To avoid a profusion of properties which would be associated with an OPEN function, two properties of the function name are used to hold all information associated with OPEN compiling. These properties are OPENFN and OPENTST. The OPENFN and OPENTST properties have the following format: (PATTERN MACRONAME PARAMETERS) or function name. The PATTERN field contains either the pattern itself or a pattern name. __ A pattern name is an id having the PATTERN property. In the following material, DEST refers to the destination label in an OPENTST and to the destination register in an OPENFN. If the function is being evaluated for effect only, DEST is a temporary register which need not be used. A pattern has the following format: PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.21 (ADJUST_FN REG_FN (P1 M11 M12 M13 ..) (P2 M21 M22 M23 ..) ...) The Pi are patterns and Mij are cmacros or pseudo cmacros. ADJUST_FN is a register adjustment function used to place things in registers as required, and to factor out basic properties of the function from the pattern. For example, you almost never could do anything with ANYREG stuff except load it somewhere (emitting (!*WPLUS2 X (CDR (CAR Y))) directly probably won't work - you must bring (CDR (CAR Y)) into a reg before further progress can be made). The most common adjust function is NOANYREG, which replaces ANYREG stuff with registers. This eliminates the problem of having to test for ANYREG stuff in the patterns. Some pattern elements currently supported are: ANY matches anything DEST matches the destination register or label NOTDEST matches any register except the destination REG matches any register REGN Any register or 'NIL or a frame location VAR A LOCAL, GLOBAL, or FLUID variable MEM A memory address, currently constants + vars (NOT REGS) ANYREGFN matches an ANYREG function 'literal matches the literal (p1 p2 ... pn) matches a field whose components match p1 ... pn NOVAL matches only if STATUS > 1; must be the first component of a pattern, consumes no part of the subject. The cmacros associated with the patterns fall into two classes: actual cmacros to be emitted and pseudo cmacros which are interpreted by the compiler. In either case, the components of the cmacros are handled in the same fashion. The cmacros contain: Ai replaced by the ith argument to the OPEN function (after adjustment) Ti replaced by a temporary register Li replaced by a temporary label Pi replaced by corresponding parameter from OPENFN DEST replaced by the destination register or label (depending on OPENFN or OPENTST). FN replaced by the name of the OPEN function MAC synonym for P1, by convention a cmacro name 'literal (x1 x2 ... ) xi as above, forms a list Compiler and Loader 7 February 1983 PSL Manual page 18.22 section 18.6 The pseudo cmacros currently supported are: !*DESTROY !*DESTROY __ __ ____ ______ (!*DESTROY R1, R2, ...): list cmacro __ __ Remove any register values from R1 ... RN. !*DO !*DO ________ ____ ____ ____ ______ (!*DO FUNCTION ARG1 ARG2 ...): list cmacro ________ Call the FUNCTION. !*SET !*SET ___ ___ ____ ______ (!*SET REG VAL): list cmacro ___ ___ Set the value in REG to VAL. The cmacros which are known to the compiler are !*LOAD !*LOAD ____ ______ (!*LOAD ): list cmacro !*STORE !*STORE ____ ______ (!*STORE ): list cmacro !*JUMP !*JUMP ____ ______ (!*JUMP ): list cmacro !*LBL !*LBL ____ ______ (!*LBL ): list cmacro These cmacros have special emit functions which are called as they are emitted; otherwise the cmacro is directly attached to CODELIST. 18.7. Third PASS - Optimizations 18.7. Third PASS - Optimizations 18.7. Third PASS - Optimizations The third pass of the compiler is responsible for doing optimizations, getting rid of extra labels and jumps, removing redundant code, adjusting the stack frame to squeeze out "holes" or even reallocating temporaries to excess registers if no "random" functions are called by this function. This pass also does "peephole" optimizations (controlled by patterns that examine the Output CMACRO list for cmacros that can be merged). These tables can be adjusted by the user. This pass also gathers information on register usage that may be accumulated to aid block compilation or recompilation of a set of functions that are NOT redefined, and so can use information about each other (i.e. become "stable"). The 'OPTFN property is used to associate an optimization function with a particular CMACRO name. This function looks at the CMACRO arguments and PSL Manual 7 February 1983 Compiler and Loader section 18.7 page 18.23 some subsequent CMACROs in the code-list, to see if a transformation is possible. The OPTFN takes a single argument, the code-list in reverse order starting at the associated CMACRO. The OPTFN can also examine certain parameters. Currently !*LBL, !*MOVE and !*JUMP have 'OPTFNS. For example, !&STOPT, associated with !*MOVE, checks if previous CMACRO was !*ALLOC, and that this !*MOVE moves a register to the slot just allocated. If so, it converts the !*ALLOC and !*MOVE into a single !*PUSH. Likewise, !&LBLOPT removes duplicate labels defined at one place, aliasing one with the other, and so permitting certain JUMP optimizations to take place. Tags in the cmacros are processed in a final pass through the code. At this time the compiler can do substitutions using functions attached to these tags. Currently, (!*FRAMESIZE) is converted to the frame size and holes are squeezed out (using the FRAME tag) by !&REFORMMACROS. Transformation functions are attached to tags (or any function) through the TRANFN property currently. 18.8. Some Structural Notes on the Compiler 18.8. Some Structural Notes on the Compiler 18.8. Some Structural Notes on the Compiler [??? This Section is very ROUGH, just to give some additional [??? This Section is very ROUGH, just to give some additional [??? This Section is very ROUGH, just to give some additional information in interim ???] information in interim ???] information in interim ???] External variables and properties used by the compiler: _________ ___ ________ Variables and Switches __________ ______ !*ERFG [Initially: ] switch __________ ______ !*INSTALLDESTROY [Initially: NIL] switch If true, causes the compiler to install the DESTROYS property on any function compiled which leaves one or more registers unchanged __________ ______ !*INT [Initially: T] switch __________ ______ !*NOFRAMEFLUID [Initially: T] switch If true, inhibits allocation of frame locations for FLUIDS __________ ______ !*SHOWDEST [Initially: NIL] switch If true, compiler prints out which registers a function destroys unless all are destroyed Compiler and Loader 7 February 1983 PSL Manual page 18.24 section 18.8 __________ ______ !*SYSLISP [Initially: NIL] switch Switch compilation mode from default of LISP to SYSLISP. This affects constant tagging, and in RLISP also causes LISP functions to be replaced by SYSLISP equivalents. Also, non-locals default to WVAR's rather than FLUIDs. See Chapter 20. __________ ______ !*UNSAFEBINDER [Initially: NIL] switch for Don's BAKER problem...GC may be called in Binder, so regs cannot be preserved, and Binder called as regular function. __________ ______ !*USEREGFLUID [Initially: NIL] switch If true, LAMBIND and PROGBIND cmacros may contain registers as well as frame locations (through FIXFRM). _______ Globals: __________ ______ LASTACTUALREG [Initially: 5] global The number of the last real register; FIXFRM does not map stack locations into registers > LASTACTUALREG. Also, temporary registers are actual registers if possible. __________ ______ MAXNARGS [Initially: 15] global Number of registers __________ ___ _____ Properties and Flags: CONST A tag property, indicates tags for constants (WCONST and QUOTE) EXTVAR A tag property, indicates a variable type whose name is externally known (!$FLUID, !$GLOBAL, !$WVAR) MEMMOD A cmacro property, indicates in place memory operations. The first argument to the cmacro is assumed to be the memory location (var or !*MEMORY) NOSIDEEFFECT A function property, used both in dealing with !*ORD and to determine if the result should be placed in register status REG A tag property, indicates a register (REG) TERMINAL A tag property, indicates terminals (leaves) whose arguments are not tagged items (!$FLUID !$GLOBAL !$WVAR REG LABEL QUOTE WCONST FRAME !*FRAMESIZE IREG) TRANSFER A property of cmacros and functions, indicates cmacros & functions which cause unconditional transfers (!*JUMP !*EXIT !*LINKE !*LINKEF ERROR) PSL Manual 7 February 1983 Compiler and Loader section 18.8 page 18.25 VAR A tag property, indicates a variable type (!$LOCAL !$FLUID !$GLOBAL !$WVAR) __________ Properties: ANYREG A function property, non-NIL indicates an ANYREG function CFNTYPE Used in compiler to relate to Recursion-to-iteration conversion. DESTROYS A function property, contains a (tagged) list of registers destroyed by the function DOFN A function property, contains the name of a compile time evaluation function for numeric arguments. EMITFN A cmacro or pseudo cmacro property, contains the name of a special function for emitting (or executing) the cmacro, such as !&ATTJMP for !*JUMP. EXITING A cmacro property, used in FIXLINKS. Contains the name of an associated exiting cmacro (!*LINK : !*LINKE, !*LINKF : !*LINKEF) FLIPTST A function property, contains the name of the opposite of a test function. All open compiled test functions must have one. (EQ : NOTEQ, ATOM : PAIRP) GROUPOPS A function property, used in constant folding. Attached to the three functions of a group, always a list of the three functions in the order +, -, MINUS. (!*WPLUS2, !*WDIFFERENCE, !*WMINUS : (!*WPLUS2 !*WDIFFERENCE !*WMINUS)) MATCHFN A property attached to an atom in a pattern. Contains the name of a boolean function for use in pattern matching. NEGJMP A cmacro property, contains the inverted test jump cmacro name. (!*JUMPEQ : !*JUMPNOTEQ, !*JUMPNOTEQ : !*JUMPEQ ...) ONE A function property, contains the (numeric) value of an identity associated with the function (!*WPLUS2 : 0, !*WTIMES2 : 1, ...) PATTERN A property associated with atoms appearing in OPENFN or OPENTST properties, contains a pattern for open coding of functions. SUBSTFN A property of atoms found in cmacros which are inside patterns. Contains a function name; the function value is substituted into the cmacro as emitted. ZERO Like ONE, designates a value which acts as a 0 in a ring over *. (!*WTIMES2 : 0 , !*LOGAND : 0) |
Added psl-1983/3-1/lpt/19-dec20.lpt version [19a3ed3bd3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 System Interface section 19.0 page 19.1 CHAPTER 19 CHAPTER 19 CHAPTER 19 OPERATING SYSTEM INTERFACE OPERATING SYSTEM INTERFACE OPERATING SYSTEM INTERFACE 19.1. Introduction . . . . . . . . . . . . . . . 19.1 19.2. System Dependent Functions . . . . . . . . . . 19.2 19.3. TOPS-20 Interface . . . . . . . . . . . . . 19.2 19.3.1. User Level Interface . . . . . . . . . . 19.2 19.3.2. The Basic Fork Manipulation Functions . . . . 19.5 19.3.3. File Manipulation Functions. . . . . . . . 19.6 19.3.4. Miscellaneous Functions . . . . . . . . . 19.7 19.3.5. Jsys Interface . . . . . . . . . . . . 19.8 19.3.6. Bit, Word and Address Operations for Jsys Calls . 19.10 19.3.7. Examples . . . . . . . . . . . . . . 19.12 19.4. New Vax Specific Interface . . . . . . . . . . 19.13 19.4.1. Setting Your .LOGIN and .CSHRC files. . . . . 19.13 19.4.2. Important PSL executables . . . . . . . . 19.14 19.4.3. Creating the Init Files . . . . . . . . . 19.14 19.4.4. Directories and Symbols . . . . . . . . 19.15 19.4.5. Miscellaneous Unix Interface Functions . . . 19.18 19.4.6. Oload . . . . . . . . . . . . . . 19.18 19.4.7. Calling oloaded functions . . . . . . . . 19.20 19.4.8. OLOAD Internals. . . . . . . . . . . . 19.21 19.4.9. I/O Control functions . . . . . . . . . 19.24 19.1. Introduction 19.1. Introduction 19.1. Introduction From within each PSL implementation, there will be a set of functions that permit the user to access specific operating system services. On the DEC-20 and VAX these include the ability to submit commands to be run in a "lower fork", such as starting an editor, submitting a system print command, listing directories, and so on. We will attempt to provide such EXEC CMDS EXEC CMDS calls (EXEC and CMDS) in all PSL implementations. We also will provide as clean an interface to Low-level services as possible. On the DEC-20, this Jsys Jsys is the Jsys function. Appropriate support functions (such as bit operations, byte-pointers, etc.) are also used by the assembler. On the SYSCALL SYSCALL VAX we will provide the SYSCALL capability. 19.2. System Dependent Functions 19.2. System Dependent Functions 19.2. System Dependent Functions If_System If_System ___ ____ __ ____ ____ ___ _____ ____ ___ ___ ______ (If_System SYS-NAME:id, TRUE-CASE:any, FALSE-CASE:any): any cmacro This is a compile-time conditional macro for system-dependent _____ ____ ___ ____ code. FALSE-CASE can be omitted and defaults to NIL. SYS-NAME System Interface 7 February 1983 PSL Manual page 19.2 section 19.2 must be a member of the fluid variable System_List!*. For the Dec-20, System_List!* is (Dec20 PDP10 Tops20 KL10). For the VAX it is (VAX Unix VMUnix). An example of its use follows. PROCEDURE MAIL(); IF_SYSTEM(TOPS20, RUNFORK "SYS:MM.EXE", IF_SYSTEM(UNIX, SYSTEM "/BIN/MAIL", STDERROR "MAIL COMMAND NOT IMPLEMENTED")); 19.3. TOPS-20 Interface 19.3. TOPS-20 Interface 19.3. TOPS-20 Interface 19.3.1. User Level Interface 19.3.1. User Level Interface 19.3.1. User Level Interface DoCmds DoCmds The basic function of interest is DoCmds, which takes a list of strings as arguments, concatenates them together, starts a lower fork, and submits this string (via the Rescan buffer). The string should include appropriate <CR><LF>, "POP" etc. A global variable, CRLF, is provided with the <CR><LF> string. Some additional entry points, and common calls have been defined to simplify the task of submitting these commands. DoCmds DoCmds _ ______ ____ ___ ____ (DoCmds L:string-list): any expr Concatenate strings into a single string (using ConcatS), place into the rescan buffer using PutRescan, and then run a lower EXEC, trying to use an existing Exec fork if possible. __________ ______ CRLF [Initially: "<cr><lf>"] global This variable is "CR-LF", to be appended to or inserted in Command strings for fnc(DoCmds). It is STRING(Char CR,Char LF). ConcatS ConcatS _ ______ ____ ______ ____ (ConcatS L:string-list): string expr Concatenate string-list into a single string, ending with CRLF. [??? Probably ConcatS should be in STRING, we add final CRLF in PutRescan ???] Cmds Cmds _ ______ ___ _____ (Cmds [L:string]): any fexpr Submit a set of commands to lower EXEC E.g. CMDS("VDIR *.RED ", CRLF, "DEL *.LPT", CRLF, "POP");. The following useful commands are defined: PSL Manual 7 February 1983 System Interface section 19.3 page 19.3 VDir VDir _ ______ ___ ____ (VDir L:string): any expr Display a directory and return to PSL, e.g. (VDIR "R.*"). Defined as DoCmds LIST("VDIR ",L,CRLF,"POP"); HelpDir HelpDir ___ ____ (HelpDir ): any expr Display PSL help directory. Defined as DoCmds LIST("DIR PH:*.HLP",CRLF,"POP"). Sys Sys _ ______ ___ ____ (Sys L:string): any expr Defined as DoCmds LIST("SYS ", L, CRLF, "POP"); Take Take _ ____ ___ ____ (Take L:list): any expr Defined as DoCmds LIST("Take ",FileName,CRLF,"POP"); Type Type _ ______ ___ ____ (Type L:string): any expr Type out files. Defined as DoCmds LIST("TYPE ",L,CRLF,"POP"); While definable in terms of the above DoCmds via a string, more direct execution of files and fork manipulation is provided by the following functions. Recall that file names are simply Strings, e.g. "<psl>foo.exe", and that ForkHandles are allocated by TOPS-20 as large integers. Run Run ________ ______ ___ ____ (Run FILENAME:string): any expr Create a fork, into which file name will be loaded, then run it, waiting for completion. Finally Kill the fork. Exec Exec ___ ____ (Exec ): any expr Continue a lower EXEC, return with POP. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable ExecFork. Emacs Emacs ___ ____ (Emacs ): any expr Continue a lower EMACS fork. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable EmacsFork. [??? Figure out how to pass a buffer to from Emacs ???] System Interface 7 February 1983 PSL Manual page 19.4 section 19.3 MM MM ___ ____ (MM ): any expr Continue a lower MM fork. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable MMFork. [??? MM looks in the rescan buffer for commands, so fairly [??? MM looks in the rescan buffer for commands, so fairly [??? MM looks in the rescan buffer for commands, so fairly useful mailers (e.g. for BUG reports) can be created. useful mailers (e.g. for BUG reports) can be created. useful mailers (e.g. for BUG reports) can be created. Perhaps make MM(s:string) for this purpose. ???] Perhaps make MM(s:string) for this purpose. ???] Perhaps make MM(s:string) for this purpose. ???] Reset Reset ____ ________ ____ (Reset ): None Returned expr This function causes the system to be restarted. 19.3.2. The Basic Fork Manipulation Functions 19.3.2. The Basic Fork Manipulation Functions 19.3.2. The Basic Fork Manipulation Functions GetFork GetFork ___ _______ _______ ____ (GetFork JFN:integer): integer expr Create a fork handle for a file; a GET on the file is done. StartFork StartFork __ _______ ____ ________ ____ (StartFork FH:integer): None Returned expr Start a fork running, don't wait, do something else. Can also be used to Restart a fork, after a WaitFork. WaitFork WaitFork __ _______ _______ ____ (WaitFork FH:integer): Unknown expr Wait for a running fork to terminate. RunFork RunFork __ _______ _______ ____ (RunFork FH:integer): Unknown expr Start and Wait for a FORK to terminate. KillFork KillFork __ _______ _______ ____ (KillFork FH:integer): Unknown expr Kill a fork (may not be restarted). OpenFork OpenFork ________ ______ _______ ____ (OpenFork FILENAME:string): integer expr Get a file into a Fork, ready to be run. PSL Manual 7 February 1983 System Interface section 19.3 page 19.5 PutRescan PutRescan _ ______ _______ ____ (PutRescan S:string): Unknown expr Copy a string into the rescan buffer, and announce to system, so that next PBIN will get this characters. Used to pass command strings to lower forks. GetRescan GetRescan ___ ______ ____ (GetRescan ): {NIL,string} expr See if there is a string in the rescan buffer. If not, Return NIL, else extract that string and return it. This is useful for getting command line arguments in PSL, if MAIN() is rewritten by the user. This will also include the program name, under which this is called. 19.3.3. File Manipulation Functions 19.3.3. File Manipulation Functions 19.3.3. File Manipulation Functions These mostly return a JFN, as a small integer. GetOldJfn GetOldJfn ________ ______ _______ ____ (GetOldJfn FILENAME:string): integer expr Get a Jfn on an existing file. GetNewJfn GetNewJfn ________ ______ _______ ____ (GetNewJfn FILENAME:string): integer expr Get a Jfn for an new (non-existing) file. RelJfn RelJfn ___ _______ _______ ____ (RelJfn JFN:integer): integer expr Return Jfn to TOPS-20 for re-use. FileP FileP ________ ______ _______ ____ (FileP FILENAME:string): boolean expr Check if FILENAME is existing file; this is a more efficient method than the kernel version that uses ErrorSet. OpenOldJfn OpenOldJfn ___ _______ _______ ____ (OpenOldJfn JFN:integer): integer expr Open file on Jfn to READ 7-bit bytes. OpenNewJfn OpenNewJfn ___ _______ _______ ____ (OpenNewJfn JFN:integer): Unknown expr Open file on Jfn to write 7 bit bytes. System Interface 7 February 1983 PSL Manual page 19.6 section 19.3 GtJfn GtJfn ________ ______ ____ _______ _______ ____ (GtJfn FILENAME:string,BITS:integer): integer expr Get a Jfn for a file, with standard Tops-20 Access bits set. NameFromJfn NameFromJfn ___ _______ ______ ____ (NameFromJfn JFN:integer): string expr Find the name of the File attached to the Jfn. 19.3.4. Miscellaneous Functions 19.3.4. Miscellaneous Functions 19.3.4. Miscellaneous Functions GetUName GetUName ______ ____ (GetUName ): string expr Get USER name as a string GetCDir GetCDir ______ ____ (GetCDir ): string expr Get Connected DIRECTORY InFile InFile ____ __ ____ _______ _____ (InFile [FILS:id-list]): Unknown fexpr Either solicit user for file name (InFile), and then open that file, else open specified file, for input. 19.3.5. Jsys Interface 19.3.5. Jsys Interface 19.3.5. Jsys Interface Jsys Jsys The Jsys interface and jsys-names (as symbols of the form jsXXX) are defined in the source file PU:JSYS0.RED. The access to the Jsys call is modeled after IDapply to avoid CONS, register reloads. These could easily be done Open coded The following SYSLISP calls, XJsys'n', expect W-values in the registers, R1...R4, a W-value for the Jsys number, Jnum and the contents of the 'nth' register. Unused registers should be given 0. Any errors detected will JsysError JsysError result in the JsysError being called, which will use the system ErStr JSYS StdError StdError to find the error string, and issue a StdError. XJsys0 XJsys0 __ _ _______ __ _ _______ __ _ _______ (XJsys0 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr Used if no result register is needed. PSL Manual 7 February 1983 System Interface section 19.3 page 19.7 XJsys1 XJsys1 __ _ _______ __ _ _______ __ _ _______ (XJsys1 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys2 XJsys2 __ _ _______ __ _ _______ __ _ _______ (XJsys2 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys3 XJsys3 __ _ _______ __ _ _______ __ _ _______ (XJsys3 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys4 XJsys4 __ _ _______ __ _ _______ __ _ _______ (XJsys4 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr The following functions are the LISP level calls, and expect integers or strings for the arguments, which are converted into s-integers by the JConv JConv function JConv, below. We will use JS to indicate the argument type. The _______ result returned is an integer, which should be converted to appropriate type by the user, depending on the nature of the Jsys. See the examples below for clarification. Jsys0 Jsys0 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys0 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Used is no result register is needed. Jsys1 Jsys1 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys1 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys2 Jsys2 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys2 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys3 Jsys3 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys3 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys4 Jsys4 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys4 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr JConv JConv The JConv converts the argument type, JS, to an appropriate s-integer, representing either an integer, or string pointer, or address. JConv JConv _ _______ ______ _ _______ ____ (JConv J:{integer,string}): s-integer expr _______ An integer J is directly converted to a s-integer, by Int2Sys(J). ______ A string J is converted to a byte pointer by the call Lor(8#10700000000,Strinf(J)). Otherwise a StdError, "'J' not known in Jconv" is produced. Additional convertions of interest may be performed by the functions Int2Sys Sys2Int Int2Sys Sys2Int Int2Sys, Sys2Int, and the following functions: System Interface 7 February 1983 PSL Manual page 19.8 section 19.3 Str2Int Str2Int _ ______ _______ ____ (Str2Int S:string): integer expr Returns the physical address of the string start as an integer; this can CHANGE if a GC takes place, so should be done just before calling the jsys. Int2Str Int2Str _ _______ ______ ____ (Int2Str J:integer): string expr J is assumed to be the address of a string, and a legal, tagged string is created. 19.3.6. Bit, Word and Address Operations for Jsys Calls 19.3.6. Bit, Word and Address Operations for Jsys Calls 19.3.6. Bit, Word and Address Operations for Jsys Calls RecopyStringToNULL RecopyStringToNULL _ _ ______ ______ ____ (RecopyStringToNULL S:w-string): string expr S is assumed to be the address of a string, and a legal, tagged string is created, by searching for the terminating NULL, allocating a HEAP string, and copying the characters into it. This is used to ensure that addresses not in the LISP heap are not passed around "cavalierly" (although PSL is designed to permit this quite safely). Swap Swap _ _______ _______ ____ (Swap X:integer): integer expr Swap half words of X; actually Xword(LowHalfWord X,HighHalfWord X). LowHalfWord LowHalfWord _ _______ _______ ____ (LowHalfWord X:integer): integer expr Return the low-half word of the machine representation of X. Actually Land(X,8#777777). HighHalfWord HighHalfWord _ _______ _______ ____ (HighHalfWord X:integer): integer expr Return the Upper half word as a small integer, of the machine word representation of X. Actually Lsh(Land(X,8#777777000000),-18). Xword Xword _ _______ _ _______ _______ ____ (Xword X:integer,Y:integer): integer expr Build a Word from Half-Words, actually Lor(Lsh(LowHalfWord(X),18),LowHalfWord Y). PSL Manual 7 February 1983 System Interface section 19.3 page 19.9 JBits JBits _ ____ _______ ____ (JBits L:list): integer expr Construct a word-image by OR'ing together selected bits or byte-fields. L is list of integers or integer pairs. A single integer in the range 0...35, BitPos, represents a single bit to be turned on. A pair of integers, (FieldValue . RightBitPos), causes the integer FieldValue to be shifted so its least significant bit (LSB) will fall in the position, RightBitPos. This value is then OR'ed into the result. Recall that on the DEC-20, the most significant bit (MSB), is bit 0 and that the LSB is bit 35. Bits Bits _ ____ _______ _____ (Bits L:list): integer macro A convenient access to Jbits: JBits cdr L. 19.3.7. Examples 19.3.7. Examples 19.3.7. Examples The following range of examples illustrate the use of the above functions. More examples can be found in PU:exec0.red. Jsys1 Jsys1 Jsys1(0,0,0,0,jsPBIN); % Reads a character, returns the ASCII code. Jsys0 Jsys0 Jsys0(ch,0,0,0,jsPBOUT); % Takes ch as Ascii code, and prints it out. Procedure OPENOLDJfn Jfn; %. OPEN to READ JSYS0(Jfn,Bits( (7 . 5),19),0,0,jsOPENF); Lisp procedure GetFork Jfn; %. Create Fork, READ File on Jfn Begin scalar FH; FH := JSYS1(Bits(1),0,0,0,jsCFork); JSYS0(Xword(FH ,Jfn),0,0,0,jsGet); return FH END; Procedure GetOLDJfn FileName; %. test If file OLD and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(2,3,17),FileName,0,0,jsGTJfn); % OLD!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Procedure GetUNAME; %. USER name Begin Scalar S; System Interface 7 February 1983 PSL Manual page 19.10 section 19.3 S:=Mkstring 80; % Allocate a 80 char buffer JSYS0(s,JSYS1(0,0,0,0,jsGJINF),0,0,jsDIRST); Return RecopyStringToNULL S; % Since a NULL may be appear before end End; Procedure ReadTTY; Begin Scalar S; S:=MkString(30); % Allocate a String Buffer Jsys0 Jsys0 Jsys0(S,BITS(10,(30 . 35),"Retype it!",0,jsRDTTY); % Sets a length halt (Bit 10), % and length 30 (field at 35) in R2 % Gives a Prompt string in R3 % The input is RAISE'd to upper case. % The Prompt will be typed if <Ctrl-R> is input Return RecopyStringToNULL S; % Since S will now possibly have a shorter % string returned end; 19.4. New Vax Specific Interface 19.4. New Vax Specific Interface 19.4. New Vax Specific Interface Most of this information depends on the use of the Berkeley c-shell (csh) and will need modification (or might not work) if the Bourne shell (sh) is your command shell of choice. Extensive use is made of csh variables to 1 describe path-names to the various PSL subdirectories. 19.4.1. Setting Your .LOGIN and .CSHRC files 19.4.1. Setting Your .LOGIN and .CSHRC files 19.4.1. Setting Your .LOGIN and .CSHRC files During installation of PSL, a file "psl-names" defining these path-names will have been edited and tested by the installer. The message announcing the location of PSL on your system should indicate where this file is. It is often placed on "~psl" or "~psl/dist". It is absolutely essential that you place the line source ~psl/psl-names in your .login and .cshrc files. If you do not have either of these, they _______________ 1 This section was contributed by Russ Fish. The source for most of the functions mentioned is "$pv/system-extras.red". PSL Manual 7 February 1983 System Interface section 19.4 page 19.11 should be created. After execution of this statement, a set of "$ variables" will be available to refer to files of interest in the PSL system from the c-shell, from editors, and from within PSL. You may have to add another directory to the search path of your shell, in the definition of path in your .login file, which gives the location of the PSL executable files. This should be done after the line "source ~psl/psl-names", and is a line of the form set path=(. $psys /bin /usr/bin) $psys is the c-cshell variable defined in psl-names to point at the psl "executables". 19.4.2. Important PSL executables 19.4.2. Important PSL executables 19.4.2. Important PSL executables "psl" is the PSL executable with a LISP syntax toploop. "rlisp" runs an RLISP (Algol-like) toploop syntax. At some installations, "bare-psl" and "pslcomp" also exist, particularly if "psl" has had many modules preloaded for local customization. There are also a set of c-shell scripts that can be run as if they were exectable programs. These include a "build" utility to recompile utility modules, "oload" to permit dynamic loading of non-LISP code into PSL, and "cmds.csh" to define some useful PSL related aliases. 19.4.3. Creating the Init Files 19.4.3. Creating the Init Files 19.4.3. Creating the Init Files On startup PSL, RLISP, and PSLCOMP look for LISP syntax init files on your home (login) directory, respectively named ".pslrc", ".rlisprc" and ".pslcomprc", which are executed in the PSL before it prompts for user SaveSystem SaveSystem input. Other PSL based programs that are saved by SaveSystem can also be made to look for .xxxrc files of their own. These files typically contain code to load modules of interest, set various switches, such as !*BREAK, etc. 19.4.4. Directories and Symbols 19.4.4. Directories and Symbols 19.4.4. Directories and Symbols The specific locations of subtrees of PSL files is left up to the installer, to reflect the conventions of local usage and file system layout. This section discusses the use of c-shell variables ($ variables) for system-invariant navigation. To use these, the lines source ~psl/psl-names source $pvsup/cmds.csh System Interface 7 February 1983 PSL Manual page 19.12 section 19.4 source lisp-psl-names should be placed in your login.cmd file The root of the PSL distribution tree is (usually) located in the home directory of a pseudo-user named "psl", and hence may be accessed as "~psl/dist". During installation, links in ~psl are often also made to startup files in the vax support directory, "$pvsup". (These should be SYMBOLIC links in Berkeley 4.1a VmUnix and above.) Note - the c-shell expands "~user" and "$variable" in filenames. The current version of PSL 3.1 will also permit these constructions in filenames, though in a somewhat limited form. Future PSL releases will integrate this more fully. Currently, a file of psl-names in LISP systax is generated by the "source lisp-psl-names", and it must be read into PSL, etc via the .xxxrc files. File "~psl/psl-names" defines c-shell symbols for the whole hierarchy of distributed PSL directories. File $pvsup/cmds.csh contains c-shell commands useful in conjunction with PSL. As of this writing, there are only two commands (c-shell alias) defined there: a. "lisp-psl-names". When run from the .login file, it creates a file "psl-names.sl" on your home directory. This file contains a series of PUT statements to associate the full Unix path names with ids that have the same name as the C-shell aliases created by various set commands in your .login. Each entry has the form (PUT (quote ID) (quote pslname) "pathname") It is suggested that the line lisp-psl-names be placed at the end of your .login if you wish to use this feature. The file "psl-names.sl" should then be read into the various PSL, RLISP, etc by placing a line (load vax!-path) into your .pslrc, .rlisprc, etc. This loads the VAX-PATH module, and reads the file "psl-names.sl" which was created by the PSL Manual 7 February 1983 System Interface section 19.4 page 19.13 "lisp-psl-names" command on your "home" directory, which can also be loaded to give a procedure PATH that builds files names using a "$ID/.." syntax, and also a modified OPEN. b. "lisp-csh-vars". An older form of lisp-psl-names.It returns LISP syntax assignments for all of the directory variables defined in the c-shell in which it is executed. Its output may be directly put into files ".pslrc" and ".rlisprc" in your home directory by placing this command in your .login file: lisp-csh-vars | tee .pslrc .rlisprc > after which any directory variables set in your c-shell startup will be known in your PSL as arguments for "cd". There are innumerable variations on this, of course. cd cd ___ ______ _______ ____ (cd DIR:string): boolean expr Like the shell "cd" command, sets the current directory (".") of cd cd the running PSL. Unless cd is executed, the current directory __ ___ will remain the same as the current directory of the shell at the ____ ___ ___ ___ _______ time the PSL was started. (Unix filenames are paths relative to Cd Cd the current directory unless they begin with a slash.) Cd returns T if it successfully found the directory given in the argument as a path, NIL otherwise. pwd pwd ______ ____ (pwd ): string expr Like the "pwd" unix command, meaning "print working directory". Returns the current directory of the PSL as a string, terminated with a slash so filenames may be direcly "concat"ed to it. The cd cd trailing slash is ignored by cd. path path _ ______ ______ ____ (path S:string): string expr Examines the argument string; if it starts with $, extracts the next string up to the / (if any), converts it to (an upper-case) __ id. Then an associated string is looked for under the indicator 'pslnames. If an associated string is not found, an Error is _ generated. If S does not start with $, it is returned unchanged. Thus CD PATH "$PU"; will work. When VAX-PATH is loaded, OPEN is redefined to apply PATH to the file-name. Thus OPEN, IN, DSKIN, OUT, FILEP and and LAPIN can use $vars in file names without calling PATH explicitly. LOAD-PATH also reads the "psl-names.sl" files from the user's System Interface 7 February 1983 PSL Manual page 19.14 section 19.4 home-directory. 19.4.5. Miscellaneous Unix Interface Functions 19.4.5. Miscellaneous Unix Interface Functions 19.4.5. Miscellaneous Unix Interface Functions ExitLisp ExitLisp _________ ____ (ExitLisp ): undefined expr Since "quit" uses the Berkeley job-control facility to the PSL (like a ^Z at the keyboard), a separate function is needed when ExitLisp ExitLisp you really want the PSL to terminate. ExitLisp does it. (A "^\" from the keyboard has the same effect, assuming you have your core-dump limit set low.) GetEnv GetEnv __________ ______ ______ ____ (GetEnv ENVVARNAME:string): string expr Returns value of the specified Unix environment variable as a string, or NIL if the argument is not a string or the environment variable is not set. System System _______ ______ _________ ____ (System UNIXCMD:string): undefined expr Starts up a sub-shell and passes the Unix command to it via the Unix "system" command. The working directory of the command will be the same as the PSL. 19.4.6. Oload 19.4.6. Oload 19.4.6. Oload oload( LdSpec:String ) c-shell-script ---------------------- -------------- Oload is a means of linking Unix .o and .a files into a running Vax PSL. It was developed to get access to existing C code driver libraries for graphics devices, but should work for any Unix compiled code with C calling conventions. The single argument to the oload function is a string containing arguments to the Unix "ld" loader, separated by blanks. File names ending in ".o" are compiled relocatable code files. ".a" files are "ar" load libraries, which are assumed to contain a set of ".o" files, all of which are to be loaded. Other loader arguments should follow, specifying whatever libraries are necessary to satisfy all external references from the ".o" and ".a" files mentioned. Library specs are in the form "-lfoo" to search the "libfoo.a" library on /lib, /usr/lib, or /usr/local/lib, e.g. "-lc" for the C library. PSL Manual 7 February 1983 System Interface section 19.4 page 19.15 This is an "incremental" (-A flag) load. Symbols which are already known in the running PSL will be linked to the existing addresses. If the load string argument is NIL, an attempt is made to re-oload from an existing .oload.out file. This can only be done if the BPS and WARRAY base addresses are EXACTLY the same as they were on the previously done, full oload. An error message results if the BPS locations are different. This is meant to facilitate rapidly repeating an oload at startup time. Alternately, a customized version of PSL may be saved by the function SaveSystem SaveSystem SaveSystem, after first performing oloads and loading or compiling in PSL code including functions which interface to the oloaded code. Oload returns a status code of T if it succeded, or NIL if not. 19.4.7. Calling oloaded functions 19.4.7. Calling oloaded functions 19.4.7. Calling oloaded functions All entry points and global data objects in ".o" and ".a" files mentioned are made known to the PSL system. C functions may be called from compiled code ONLY, and are flagged 'ForeignFunction by oload. Data areas are flagged 'ForeignData, with a property containing a pair of the data location and size in bytes for use by SYSLISP interface code. Currently, foreign function calls may not be compiled into Fasl files, so Compile Compile the compilation must be done incrementally, via "on Comp" or Compile. C C The names of oloaded C functions within PSL are the "true" names, which have an underscore ("_") prefixed to the C name. This makes it easy to make a compiled "pass through" interface function which gives the same name within PSL as the C names. e.g. "procedure foo(); _foo();" Functions which take integer arguments can be called directly, due to the invisible tagging of integers up to +-2^^27 in Vax PSL. Similarly, integer return values will be passed back from the C functions. String or structured arguments will require a bit of conversion code in the interface functions, using SYSLISP functions to remove tags on arguments and add them ImportForeignString ImportForeignString to return values. The function ImportForeignString constructs a LISP string, given a C string (char *). Warning: currently, foreign function calls may have no more than 5 arguments and floating point and struct arguments and return values are not supported. This will be remedied in the compiler eventually. In the mean time, both of these restrictions may be easily circumvented by putting arguments in work areas and passing the address of the work area as an argument to an intermediate C "kluge function" which unpacks the real arguments and passes them on to the target C function. If work areas are needed in SYSLISP interface code, as when arrays must be passed to the C code, use a LispVar to hold the address of a word block GtWArray GtWrds GtWArray GtWrds acquired via GtWArray (for static arrays) or GtWrds (for dynamic blocks in C C the heap). Pass the array address to the C function as the pointer System Interface 7 February 1983 PSL Manual page 19.16 section 19.4 argument. 19.4.8. OLOAD Internals 19.4.8. OLOAD Internals 19.4.8. OLOAD Internals Oload invokes the Unix "ld" loader through a c-shell script to convert the relocatable code in .o files inwto absolute form, then reads it into space allocated within the BPS area of the PSL. The text segment goes at the low end of BPS, and the data and bss segments go at the high end, following the BPS storage allocation conventions of the LISP compiler. Since an incremental (-A) load is done, oload needs a filename path to the executable file containing the loader symbol table of the previous load. The variable SymbolFileName!* tells both Oload and SaveSystem/DumpLisp the file name string to use (for this reason, the executable files should be publicly readable.) When PSL is started, SymbolFileName!* is automatically set to the name of the executed PSL file. This is done by importing the Unix argument string to variable UnixArgs!*. UnixArgs!*[0] is the (possibly partial) path to the PSL file which was executed. The unix environment variable PATH contains a set of path prefixes to which partial paths are appended, until a valid filename results. "." refers to the path to the current directory, which is returned by pwd(). [ Unix system interface functions are contained in file $pv/system-extras.red. ] SymbolFileName!* is set to ".oload.out" by oload, so that succesive oloads will accumulate a loader symbol table, and so that unexec, called by DumpSystem DumpSystem DumpSystem, will get the right symbol table in the saved PSL. (It may be useful to know that the initial value of SymbolFileName!* is saved in StartupName!*.) A number of work files are created on the current directory by the oload script, with file names that begin ".oload". The .oload.out file in particular is quite large because it spans the gap of unused space in BPS. It is a good idea to remove those files if you do not intend to repeat the oload exactly. This can be done from your rlisp, via the command '' system( "rm .oload.*" ); ''. ImportForeignString ImportForeignString _ ______ ____ ______ ____ (ImportForeignString C_STRING:word): string expr Constructs and returns a LISP string, given a C string (char *) returned from a C ForeignFunction. A NULL (0) string pointer is returned as NIL. __________ ______ SYMBOLFILENAME!* [Initially: ] global Gives the name of the PSL executable file to be examined by both Oload and SaveSystem/DumpLisp to find the Unix symbol table of the PSL. Set to the executed PSL file at startup, changed to PSL Manual 7 February 1983 System Interface section 19.4 page 19.17 ".oload.out" by Oload. __________ ______ STARTUPNAME!* [Initially: ] global The path to the originally executed PSL file, as returned by GetStartupName GetStartupName function GetStartupName, based on UnixArgs!*[0]. __________ ______ UNIXARGS!* [Initially: ] global A vector of strings, passed to the PSL on startup by the Unix shell. Imported by function "getUnixArgs". 19.4.9. I/O Control functions 19.4.9. I/O Control functions 19.4.9. I/O Control functions EchoOff EchoOff _________ ____ (EchoOff ): undefined expr EchoOn EchoOn _________ ____ (EchoOn ): undefined expr EchoOff EchoOff EchoOff enters raw, character-at-a-time input mode for Emode, EchoOn EchoOn Nmode, and similar keystroke oriented environments. EchoOn returns to normal, line oriented input mode. CharsInInputBuffer CharsInInputBuffer _______ ____ (CharsInInputBuffer ): integer expr Returns the number of characters waiting for input from the TTY, including those still in the Stdio buffer and those not yet read from Unix. FlushStdOutputBuffer FlushStdOutputBuffer ____ ________ ____ (FlushStdOutputBuffer ): None Returned expr The standard output from PSL is in Stdio line-buffered mode, and is normally flushed to the TTY whenever an end-of-line is printed or before waiting for input. In screen-oriented output environements like Emode/Nmode which use screen cursor positioning, it is necessary to explictly flush the buffer at appropriate times. It may also be desireable to see partial lines of output at other times. ChannelFlush ChannelFlush ____ __ _______ ____ ________ ____ (ChannelFlush Chnl:io-channel): None Returned expr Flushes any channel, as FlushStdOutputBuffer does for StdOut!*. System Interface 7 February 1983 PSL Manual page 19.18 section 19.5 19.5. Apollo System Calls 19.5. Apollo System Calls 19.5. Apollo System Calls PSL contains a syscall package for use on the Apollo PSL. See the USCG operating note "Apollo Syscall Package for PSL", by S. Lowder, G. Maguire, and J. W. Peterson. |
Added psl-1983/3-1/lpt/20-syslisp.lpt version [db8843aa04].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 SYSLISP section 20.0 page 20.1 CHAPTER 20 CHAPTER 20 CHAPTER 20 SYSLISP SYSLISP SYSLISP 20.1. Introduction to the SYSLISP level of PSL. . . . . . 20.1 20.2. The Relationship of SYSLISP to RLISP . . . . . . . 20.2 20.2.1. SYSLISP Declarations . . . . . . . . . . 20.2 20.2.2. SYSLISP Mode Analysis. . . . . . . . . . 20.3 20.2.3. Defining Special Functions for Mode Analysis . . 20.4 20.2.4. Modified FOR Loop . . . . . . . . . . . 20.4 20.2.5. Char and IDLOC Macros. . . . . . . . . . 20.5 20.2.6. The Case Statement. . . . . . . . . . . 20.6 20.2.7. Memory Access and Address Operations. . . . . 20.7 20.2.8. Bit-Field Operation . . . . . . . . . . 20.8 20.3. Using SYSLISP. . . . . . . . . . . . . . . 20.9 20.3.1. To Compile SYSLISP Code . . . . . . . . . 20.9 20.4. SYSLISP Functions . . . . . . . . . . . . . 20.10 20.4.1. W-Arrays . . . . . . . . . . . . . . 20.11 20.5. Remaining SYSLISP Issues . . . . . . . . . . . 20.12 20.5.1. Stand Alone SYSLISP Programs . . . . . . . 20.12 20.5.2. Need for Two Stacks . . . . . . . . . . 20.12 20.5.3. New Mode System. . . . . . . . . . . . 20.13 20.5.4. Extend CREF for SYSLISP . . . . . . . . . 20.13 This chapter is very out of date and will be replaced as soon as possible. 20.1. Introduction to the SYSLISP level of PSL 20.1. Introduction to the SYSLISP level of PSL 20.1. Introduction to the SYSLISP level of PSL SYSLISP [Benson 81] is a BCPL-like language, couched in LISP form, providing operations on machine words, machine bytes and LISP ITEMs (tagged objects, packed into one or more words). We actually think of SYSLISP as a lower level of PSL, dealing with words, bytes, bit-fields, machine operations, and compile-time storage allocation, enabling us to write essentially all of the kernel in PSL. The control structures and definition language are those of LISP, but the Plus2 Times2 WPlus2 WTimes2 Plus2 Times2 WPlus2 WTimes2 familiar Plus2, Times2, etc. are mapped to word operations WPlus2, WTimes2, etc. SYSLISP handles static allocation of SYSLISP variables and arrays and initial LISP symbols, permitting the easy definition of higher level Standard LISP functions and storage areas. SYSLISP provides convenient ______ compile-time constants for handling strings, LISP symbols, etc. The SYSLISP compiler is based on the PORTABLE STANDARD LISP Compiler, with extensions to handle word level objects and efficient, open-coded, word-level operations. The SYSLISP mode of the compiler does efficient compile-time folding of constants and more comprehensive register allocation than in the distributed version of the PLC. Currently, SYSLISP handles bytes through the explicit packing and unpacking operations SYSLISP 7 February 1983 PSL Manual page 20.2 section 20.1 GetByte GetByte GetByte(word-address,byte-number) / PutByte PutByte PutByte(word-address,byte-number,byte-value) without the notion of byte- pointer; it is planned to extend SYSLISP to a C-like language by adding the appropriate declarations and analysis of word/byte/structure operations. SYSLISP is a collection of functions and their corresponding data types which are used to implement low level primitives in PSL, such as storage allocation, garbage collection and input and output. The basic data object ____ in SYSLISP is the "word", a unit of storage large enough to contain a LISP ____ ____ ____ item. On the PDP-10, a SYSLISP word is just a 36-bit PDP-10 word. On the ____ VAX and most other byte addressed machines, a word is 4 bytes, or 32 bits. Conceptually, SYSLISP functions manipulate the actual bit patterns found in words, unlike normal LISP functions which manipulate higher-level objects, ____ ______ _____ ______ such as pairs, vectors, and floats or arbitrary-precision numbers. Arithmetic in SYSLISP is comparable to the corresponding operations in FORTRAN or PASCAL. In fact, SYSLISP is most closely modeled after BCPL, in that operations are essentially "typeless". 20.2. The Relationship of SYSLISP to RLISP 20.2. The Relationship of SYSLISP to RLISP 20.2. The Relationship of SYSLISP to RLISP ______ ______ ______ smacro smacro RLISP was extended with a CASE statement, SYSLISP declarations, smacros _____ _____ _____ macro macro and macros to provide convenient infix syntax (+, *, / etc.) for calling the SYSLISP primitives. Even though SYSLISP is semantically somewhat different from LISP (RLISP), we have tried to keep the syntax as similar as possible so that SYSLISP code is "familiar" to RLISP users, and easy to use. RLISP functions can be easily converted and interfaced to functions at the SYSLISP level, gaining considerable efficiency by declaring and directly using words and bytes instead of tagged LISP objects. 20.2.1. SYSLISP Declarations 20.2.1. SYSLISP Declarations 20.2.1. SYSLISP Declarations SYSLISP variables are either GLOBAL, memory locations (allocated by the compiler), or local stack locations. Locals are declared by SCALAR, as usual. Globals come in the following flavors: WCONST id = wconstexp {,id = wconstexp} ; Wconstexp is an expression involving constants and wconsts. WVAR wvardecl {, wvardecl} ; wvardecl ::= id | id = wconstexp WARRAY warraydecl {, warraydecl} ; warraydecl ::= id[wconstexp] | id[] = [ wconstexp {,wconstexp} ] | id[] = string PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.3 WSTRING warraydecl {, warraydecl} ; Each of these declarations can also be prefixed with the keywords: INTERNAL or EXTERNAL. If nothing appears, then a DEFAULT is used. (Notice there are no metasyntactic square brackets here, only curly brackets.) For example, the following GLOBAL-DATA is used in PSL: on SysLisp; exported WConst MaxSymbols = 8000, MaxConstants = 500, HeapSize = 100000; external WArray SymNam, SymVal, SymFnc, SymPrp, ConstantVector; external WVar NextSymbol, NextConstant; exported WConst MaxRealRegs = 5, MaxArgs = 15; external WArray ArgumentBlock; off SysLisp; END; 20.2.2. SYSLISP Mode Analysis 20.2.2. SYSLISP Mode Analysis 20.2.2. SYSLISP Mode Analysis ____ In SYSLISP mode, the basic operators +, *, -, /, etc., are bound to word WPlus2 WTimes2 WMinus WPlus2 WTimes2 WMinus operators (WPlus2, WTimes2, WMinus, etc.), which compile OPEN as ____ conventional machine operations on machine words. Thus most SYSLISP expressions, loops, etc. look exactly like their RLISP equivalents. 20.2.3. Defining Special Functions for Mode Analysis 20.2.3. Defining Special Functions for Mode Analysis 20.2.3. Defining Special Functions for Mode Analysis To have the Mode analyzer (currently a REFORM function) replace LISP function names by SYSLISP ones, do: PUT('LispName,'SYSNAME,'SysLispName); SYSLISP 7 February 1983 PSL Manual page 20.4 section 20.2 The Following have been done: DefList('((Plus WPlus2) (Plus2 WPlus2) (Minus WMinus) (Difference WDifference) (Times WTimes2) (Times2 WTimes2) (Quotient WQuotient) (Remainder WRemainder) (Mod WRemainder) (Land WAnd) (Lor WOr) (Lxor WXor) (Lnot WNot) (LShift WShift) (LSH WShift)), 'SysName); DefList('((Neq WNeq) (Equal WEq) (Eqn WEq) (Eq WEq) (Greaterp WGreaterp) (Lessp WLessp) (Geq WGeq) (Leq WLeq) (Getv WGetv) (Indx WGetv) (Putv WPutv) (SetIndx WPutv)), 'SysName); 20.2.4. Modified FOR Loop 20.2.4. Modified FOR Loop 20.2.4. Modified FOR Loop Wxxxx Wxxxx The FOR loop is modified in SYSLISP mode to use the Wxxxx functions to do loop incrementation and testing. [??? Should pick up via SysReform ???] [??? Should pick up via SysReform ???] [??? Should pick up via SysReform ???] 20.2.5. Char and IDLOC Macros 20.2.5. Char and IDLOC Macros 20.2.5. Char and IDLOC Macros ____ In SYSLISP mode, '<id> refers to the tagged item, just as in LISP mode, IdLoc LispVar IdLoc __ LispVar IdLoc <id> refers to the id space offset of the <id>, and LispVar <id> ____ refers to the GLOBAL value cell of a GLOBAL or FLUID variable. Note: LispVar LispVar LispVar can be used on the left hand side of an argument sentence. For __ example, to store a NIL in the value cell of id FOO, we do any one of the following. PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.5 SYMVAL IDLOC FOO := 'NIL; LISPVAR FOO := MKITEM(ID,IDLOC NIL); Char Char _ __ _______ _____ (Char U:id): integer macro Char Char The Char macro returns the ASCII code corresponding to its single character-id argument. CHAR also can handle alias's for certain special characters, remove QUOTE marks that may be needed to pass special characters through the parser, and can accept a prefixes to compute LOWER case, <Ctrl> characters, and <Meta> characters. For example: Little_a:= Char LOWER A; % In case we think RAISE will occur Little_a:= Char '!a; % !a should not be raised Meta_X := Char META X; Weird := Char META Lower X; Dinger := Char <Ctrl-G>; Dinger := Char BELL; PUT PUT The following Aliases are defined by PUTing the association under the indicator 'CharConst: DefList('((NULL 8#0) (BELL 8#7) (BACKSPACE 8#10) (TAB 8#11) (LF 8#12) (EOL 8#12) (FF 8#14) (CR 8#15) (EOF 26) (ESC 27) (ESCAPE 27) (BLANK 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177)), 'CharConst); 20.2.6. The Case Statement 20.2.6. The Case Statement 20.2.6. The Case Statement RLISP in SYSLISP mode provides a Numeric case statement, that is implemented quite efficiently; some effort is made to examine special cases (compact vs. non compact sets of cases, short vs. long sets of cases, etc.). [??? Note, CASE can also be used from LISP mode, provided tags are [??? Note, CASE can also be used from LISP mode, provided tags are [??? Note, CASE can also be used from LISP mode, provided tags are numeric. There is also an FEXPR, CASE ???] numeric. There is also an FEXPR, CASE ???] numeric. There is also an FEXPR, CASE ???] The syntax is: SYSLISP 7 February 1983 PSL Manual page 20.6 section 20.2 Case-Statement ::= CASE expr OF case-list END Case-list ::= Case-expr [; Case-list ] Case-expr ::= Tag-expr : expr tag-expr ::= DEFAULT | OTHERWISE | tag | tag, tag ... tag | tag TO tag Tag ::= Integer | Wconst-Integer % This is a piece of code from the Token Scanner, % in file "PI:token-Scanner.red" ..... case ChTokenType of 0 to 9: % digit << TokSign := 1; goto InsideNumber >>; 10: % Start of ID << if null LispVar !*Raise then goto InsideID else << RaiseLastChar(); goto InsideRaisedID >> >>; 11: % Delimiter, but not beginning of diphthong << LispVar TokType!* := '3; return MkID TokCh >>; 12: % Start of comment goto InsideComment; 13: % Diphthong start-Lisp function uses P-list of starting char return ScanPossibleDipthong(TokChannel, MkID TokCh); 14: % ID escape character << if null LispVar !*Raise then goto GotEscape else goto GotEscapeInRaisedID >>; 15: % string quote << BackupBuf(); goto InsideString >>; 16: % Package indicator - % at start of token means use global package << ResetBuf(); ChangedPackages := 1; Package 'Global; if null LispVar !*Raise then goto GotPackageMustGetID else goto GotPackageMustGetIDRaised >>; 17: % Ignore - can't ever happen ScannerError("Internal error - consult a wizard"); 18: % Minus sign << TokSign := -1; PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.7 goto GotSign >>; 19: % Plus sign << TokSign := 1; goto GotSign >>; 20: % decimal point << ResetBuf(); ReadInBuf(); if ChTokenType >= 10 then << UnReadLastChar(); return ScanPossibleDipthong(TokChannel, '!.) >> else << TokSign := 1; TokFloatFractionLength := 1; goto InsideFloatFraction >> >>; default: return ScannerError("Unknown token type") end; ..... 20.2.7. Memory Access and Address Operations 20.2.7. Memory Access and Address Operations 20.2.7. Memory Access and Address Operations The operators @ and & (corresponding to GetMem and Loc) may be used to do direct memory operations, similar to * and & in C. @ may also be used on the LHS of an assignment. Example: WARRAY FOO[10]; WVAR FEE=&FOO[0]; ... @(fee+2) := @(fee+4) + & foo(5); ... 20.2.8. Bit-Field Operation 20.2.8. Bit-Field Operation 20.2.8. Bit-Field Operation The Field and PutField operations are used for accessing fields smaller than whole words: PUTFIELD(LOC, BITOFFSET, BITLENGTH, VALUE); and GETFIELD(LOC,BITOFFSET, BITLENGTH); Special cases such as bytes, halfwords, single bits are optimized if possible. For example, the following definitions on the DEC-20 are used to define SYSLISP 7 February 1983 PSL Manual page 20.8 section 20.2 the fields of an item (in file p20c:data-machine.red): % Divide up the 36 bit DEC-20 word: WConst TagStartingBit = 0, TagBitLength = 18, StrictTagStartingBit = 9, StrictTagBitLength = 9, InfStartingBit = 18, InfBitLength = 18, GCStartingBit = 0, GCBitLength = 9; % Access to tag (type indicator) of Lisp item in ordinary code syslsp macro procedure Tag U; list('Field, cadr U, '(wconst TagStartingBit), '(wconst TagBitLe syslsp macro procedure PutTag U; list('PutField, cadr U, '(wconst TagStartingBit), '(wconst TagBitLength), caddr U); % Access to tag of Lisp item in garbage collector, % if GC bits may be in use syslsp macro procedure StrictTag U; list('Field, cadr U, '(wconst StrictTagStartingBit), '(wconst StrictTagBitLength)); syslsp macro procedure PutStrictTag U; list('PutField, cadr U, '(wconst StrictTagStartingBit), '(wconst StrictTagBitLength), caddr U); % Access to info field of item (pointer or immediate operand) syslsp macro procedure Inf U; list('Field, cadr U, '(wconst InfStartingBit), '(wconst InfBitLe syslsp macro procedure PutInf U; list('PutField, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength), caddr U); PSL Manual 7 February 1983 SYSLISP section 20.3 page 20.9 20.3. Using SYSLISP 20.3. Using SYSLISP 20.3. Using SYSLISP ___________ Restriction: SYSLISP code is currently ONLY compiled, since it is converted into machine level operations, most of which are dangerous or tricky to use in an interpreted environment. Note: In SYSLISP mode, we currently execute some commands in the above PARSE/EVAL/PRINT mode, either to load files or select options, but most SYSLISP code is compiled to a file, rather than being immediately interpreted or compiled in-core. 20.3.1. To Compile SYSLISP Code 20.3.1. To Compile SYSLISP Code 20.3.1. To Compile SYSLISP Code Use PSL:RLISP, which usually has the Compiler, with SYSLISP extensions, loaded. Alternatively, one may use <psl>syscmp.exe. This is a version of RLISP built upon <PSL>psl.exe with the SYSLISP compiler and data-machine macros loaded. % Turn on SYSLISP mode: ON SYSLISP; % This is causes the "mode-analysis" to be done % Converting some LISP names to SYSLISP names. % Use SYSLSP as the procedure type. Example: % Small file to access BPS origin and end. % Starts in LISP mode Fluid '(NextBP0 LastBP0); NextBP0:=NIL; LastBP0:=NIL; On SYSLISP,COMP; % Switch to SYSLISP mode syslsp procedure BPSize(); Begin scalar N1,L1; If Null LispVar NextBP0 then LispVar NextBP0:=GtBPS 0; If Null LispVar LastBP0 then LispVar LastBP0:=GtWarray 0; N1 :=GtBPS(0); L1:= GtWarray(0); PrintF('" NextBPS=8#%o, used %d, LastBPS=8#%o, used %d%n", N1, N1-LispVar(NextBP0), L1,LispVar(LastBP0)-L1) LispVar NextBP0:=N1; LispVar LastBP0:=L1; End; BPSize(); % Call the function SYSLISP 7 February 1983 PSL Manual page 20.10 section 20.4 20.4. SYSLISP Functions 20.4. SYSLISP Functions 20.4. SYSLISP Functions [??? What about overflow in Syslisp arithmetic? ???] [??? What about overflow in Syslisp arithmetic? ???] [??? What about overflow in Syslisp arithmetic? ???] WPlus2 WPlus2 _ ____ _ ____ ____ ____ ________ ____ (WPlus2 U:word, V:word): word open-compiled, expr WDifference WDifference _ ____ _ ____ ____ ____ ________ ____ (WDifference U:word, V:word): word open-compiled, expr WTimes2 WTimes2 _ ____ _ ____ ____ ____ ________ ____ (WTimes2 U:word, V:word): word open-compiled, expr WQuotient WQuotient _ ____ _ ____ ____ ____ ________ ____ (WQuotient U:word, V:word): word open-compiled, expr WRemainder WRemainder _ ____ _ ____ ____ ____ ________ ____ (WRemainder U:word, V:word): word open-compiled, expr WShift WShift _ ____ _ ____ ____ ____ ________ ____ (WShift U:word, V:word): word open-compiled, expr WAnd WAnd _ ____ _ ____ ____ ____ ________ ____ (WAnd U:word, V:word): word open-compiled, expr WOr WOr _ ____ _ ____ ____ ____ ________ ____ (WOr U:word, V:word): word open-compiled, expr WXor WXor _ ____ _ ____ ____ ____ ________ ____ (WXor U:word, V:word): word open-compiled, expr WNot WNot _ ____ ____ ____ ________ ____ (WNot U:word): word open-compiled, expr WEQ WEQ _ ____ _ ____ _______ ____ ________ ____ (WEQ U:word, V:word): boolean open-compiled, expr WNEQ WNEQ _ ____ _ ____ _______ ____ ________ ____ (WNEQ U:word, V:word): boolean open-compiled, expr WGreaterP WGreaterP _ ____ _ ____ _______ ____ ________ ____ (WGreaterP U:word, V:word): boolean open-compiled, expr WLessP WLessP _ ____ _ ____ _______ ____ ________ ____ (WLessP U:word, V:word): boolean open-compiled, expr WGEQ WGEQ _ ____ _ ____ _______ ____ ________ ____ (WGEQ U:word, V:word): boolean open-compiled, expr PSL Manual 7 February 1983 SYSLISP section 20.4 page 20.11 WLEQ WLEQ _ ____ _ ____ _______ ____ ________ ____ (WLEQ U:word, V:word): boolean open-compiled, expr WGetV WGetV _ ____ _ ____ ____ ____ ________ _____ (WGetV U:word, V:word): word open-compiled, macro WPutV WPutV _ ____ _ ____ _ ____ ____ ____ ________ _____ (WPutV U:word, V:word, W:word): word open-compiled, macro Byte Byte _ ____ _ ____ ____ ____ ________ ____ (Byte U:word, V:word): word open-compiled, expr PutByte PutByte _ ____ _ ____ _ ____ ____ ____ ________ ____ (PutByte U:word, V:word, W:word): word open-compiled, expr 20.4.1. W-Arrays 20.4.1. W-Arrays 20.4.1. W-Arrays CopyWArray CopyWArray ___ _ ______ ___ _ ______ _____ ___ ___ _ ______ ____ (CopyWArray NEW:w-vector, OLD:w-vector, UPLIM:any): NEW:w-vector expr _____ Copy UPLIM + 1 words. CopyWRDSToFrom CopyWRDSToFrom ___ _ ______ ___ ___ ___ ____ (CopyWRDSToFrom NEW:w-vector, OLD:any): any expr CopyWArray CopyWArray Like CopyWArray in heap. CopyWRDS CopyWRDS _ ___ ___ ____ (CopyWRDS S:any): any expr Allocate new WRDS array in heap. 20.5. Remaining SYSLISP Issues 20.5. Remaining SYSLISP Issues 20.5. Remaining SYSLISP Issues The system should be made less dependent on the assemblers, compilers and loaders of the particular machine it is implemented on. One way to do this is to bring up a very small kernel including a fast loader to load in the rest. 20.5.1. Stand Alone SYSLISP Programs 20.5.1. Stand Alone SYSLISP Programs 20.5.1. Stand Alone SYSLISP Programs In principle it works, but we need to clearly define a small set of support functions. Also, need to implement EXTERNAL properly, so that a normal LINKING loader can be used. In PSL, we currently produce a single kernel module, with resident LAP (or later FAP), and it serves as dynamic linking loader for SYSLISP (ala MAIN SAIL). SYSLISP 7 February 1983 PSL Manual page 20.12 section 20.5 20.5.2. Need for Two Stacks 20.5.2. Need for Two Stacks 20.5.2. Need for Two Stacks We must distinguish between true LISP items and untagged SYSLISP items on the stack for the garbage collector to work properly. Two of the options for this are 1. Put a mark on the stack indicating a region containing untagged items. 2. Use a separate stack for untagged items. Either of these involves a change in the compiler, since it currently only allocates one frame for temporaries on the stack and does not distinguish where they get put. The garbage collector should probably be recoded more modularly and at a higher level, short of redesigning the entire storage management scheme. This in itself would probably require the existence of a separate stack which is not traced through for return addresses and SYSLISP temporaries. 20.5.3. New Mode System 20.5.3. New Mode System 20.5.3. New Mode System A better scheme for intermixing SYSLISP and LISP within a package is needed. Mode Reduce will probably take care of this. 20.5.4. Extend CREF for SYSLISP 20.5.4. Extend CREF for SYSLISP 20.5.4. Extend CREF for SYSLISP The usual range of LISP tools should be available, such as profiling, a break package, tracing, etc. |
Added psl-1983/3-1/lpt/21-implementation.lpt version [8909ccf588].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Implementation section 21.0 page 21.1 CHAPTER 21 CHAPTER 21 CHAPTER 21 IMPLEMENTATION IMPLEMENTATION IMPLEMENTATION 21.1. Overview of the Implementation . . . . . . . . . 21.1 21.2. Files of Interest . . . . . . . . . . . . . 21.1 21.3. Building PSL on the DEC-20 . . . . . . . . . . 21.2 21.4. Building the LAP to Assembly Translator . . . . . . 21.5 21.5. The Garbage Collectors and Allocators. . . . . . . 21.5 21.5.1. Compacting Garbage Collector on DEC-20 . . . . 21.5 21.5.2. Two-Space Stop and Copy Collector on VAX . . . 21.6 21.6. The HEAPs . . . . . . . . . . . . . . . . 21.6 21.7. Allocation Functions . . . . . . . . . . . . 21.8 This chapter is very out of date and will be replaced as soon as possible. Refer to the release notes for your machine and the forthcoming implementation guide. 21.1. Overview of the Implementation 21.1. Overview of the Implementation 21.1. Overview of the Implementation In this Chapter we give a guide to the sources, although they are still rapidly changing. With these notes in mind, and an understanding of SYSLISP and the compiler at the level of Chapters 18 and 20, it is hoped the user will be able to understand and change most of the system. Much of the current information is contained in comments in the source files, and cannot be reproduced here. [??? This Section needs a LOT of work ???] [??? This Section needs a LOT of work ???] [??? This Section needs a LOT of work ???] 21.2. Files of Interest 21.2. Files of Interest 21.2. Files of Interest The complete sources are divided up into a fairly large number of files, spread over a number of sub-directories of <PSL>. This is so that files representing a common machine-independent kernel are in a single directory, and additional machine specific files in others. Furthermore, we have separated the compiler and LAP files from the rest of the files, since they are looked at first when doing a new implementation, but are not actually important to understanding the working of PSL. Some convenient logical device names are defined in <psl>logical- names.cmd. This file should have been TAKEn in your LOGIN.CMD. Current definitions are: ;Officially recognized logical names for PSL subdirectories on UTAH-20 define psl: <psl> ! Executable files and miscellaneous Implementation 7 February 1983 PSL Manual page 21.2 section 21.2 define ploc: <psl.local> ! Non-distributed miscellaneous define pi: <psl.interp> ! Interpreter sources define pc: <psl.comp> ! Compiler sources define pu: <psl.util> ! Utility program sources define plocu: <psl.local.util> ! Non-distributed utility sources define pd: <psl.doc> ! Documentation to TYPE define pe: <psl.emode> ! Emode sources and build files define plpt: <psl.lpt> ! Printer version of Documentation define ph: <psl.help> ! Help files define plap: <psl.lap> ! LAP and B files define ploclap: <psl.local.lap> ! Non-distributed LAP and B files define pred: <reduce.psl-reduce>! Temporary home of Reduce built upon ! PSL define p20: <psl.20-interp> ! Dec-20 specific interpreter sources define p20c: <psl.20-comp> ! Dec-20 specific compiler sources define p20d: <psl.20-dist> ! Dec-20 distribution files define pv: <psl.vax-interp> ! Vax specific interpreter sources define pvc: <psl.vax-comp> ! Vax specific compiler sources define pvd: <psl.vax-dist> ! Vax distribution files define p68: <psl.68000-interp> ! M68000 specific interpreter sources define p68c: <psl.68000-comp> ! M68000 specific compiler sources define pcr: <psl.cray-interp> ! Cray-1 interpreter sources define pcrc: <psl.cray-comp> ! Cray-1 compiler sources define pcrd: <psl.cray-dist> ! Cray-1 distribution files define pl: plap:,ploclap: ! Search list for LOAD Sources mostly live on PI:. DEC-20 build files and very machine specific files live on P20:. 21.3. Building PSL on the DEC-20 21.3. Building PSL on the DEC-20 21.3. Building PSL on the DEC-20 [??? fix as FASL works ???] [??? fix as FASL works ???] [??? fix as FASL works ???] Building proceeds in number of steps. First the kernel files are compiled to MIDAS, using a LAP-to-MIDAS translator, which follows the normal LISP/SYSLISP compilation to LAP. This phase also includes the conversion of constants (atoms names, strings, etc) into structures in the heap, and initialization code into an INIT procedure. The resulting module is assembled, linked, and saved as BARE-PSL.EXE. If executed, it reads in a batch of LAP files, previously compiled, representing those functions that should be in a minimal PSL, but in fact are not needed to implement LAP. [??? When FAP is implemented, these LAP files will become FAP files, [??? When FAP is implemented, these LAP files will become FAP files, [??? When FAP is implemented, these LAP files will become FAP files, and the kernel will get smaller ???] and the kernel will get smaller ???] and the kernel will get smaller ???] . The BARE-PSL kernel build file is P20:PSL-KERNEL.CTL, and is reproduced PSL Manual 7 February 1983 Implementation section 21.3 page 21.3 here, slightly edited: ; This requires PL:PSL-NON-KERNEL.LAP and P20C:PSLDEF.MID copy BARE-PSL.SYM PSL.SYM PSL:MIDASCMP ! previously saved with LAPtoMIDAS in "PSL-KERNEL.RED"; % Files for kernel quit; MIDAS ! assemble kernel data dpsl MIDAS ! assemble kernel init code spsl MIDAS ! assemble kernel code psl load DPSL.REL, SPSL.REL, PSL.REL ! link into one module save BARE-PSL.EXE ! save executable The kernel files mentioned in PSL-KERNEL.RED are: MIDASOUT "PSL"; IN "BINDING.RED"$ % binding from the interpreter IN "FAST-BINDER.RED"$ % for binding in compiled code, % in LAP IN "SYMBOL-VALUES.RED"$ % SET, and support for Eval IN "FUNCTION-PRIMITIVES.RED"$ % used by PutD, GetD and Eval IN "OBLIST.RED"$ % Intern, RemOb and GenSym IN "CATCH-THROW.RED"$ % non-local GOTO mechanism IN "ALLOCATORS.RED"$ % heap, symbol and code space alloc IN "COPIERS.RED"$ % copying functions IN "CONS-MKVECT.RED"$ % SL constructor functions IN "GC.RED"$ % the garbage collector IN "APPLY-LAP.RED"$ % low-level function linkage, in LAP IN "EQUAL.RED"$ % equality predicates IN "EVAL-APPLY.RED"$ % interpreter functions IN "PROPERTY-LIST.RED"$ % PUT and FLAG and friends IN "FLUID-GLOBAL.RED"$ % variable declarations IN "PUTD-GETD.RED"$ % function defining functions IN "KNOWN-TO-COMP-SL.RED"$ % SL functions performed online % in code IN "OTHERS-SL.RED"$ % DIGIT, LITER and LENGTH IN "CARCDR.RED"$ % CDDDDR, etc. IN "EASY-SL.RED"$ % highly portable SL function defns IN "EASY-NON-SL.RED"$ % simple, ubiquitous SL extensions IN "COMP-SUPPORT.RED"$ % optimized CONS and LIST compilation IN "ERROR-HANDLERS.RED"$ % low level error handlers IN "TYPE-CONVERSIONS.RED"$ % convert from one type to another IN "ARITH.RED"$ % Lisp arithmetic functions IN "IO-DATA.RED"$ % Data structures used by IO Implementation 7 February 1983 PSL Manual page 21.4 section 21.3 IN "SYSTEM-IO.RED"$ % system dependent IO functions IN "CHAR-IO.RED"$ % bottom level IO primitives IN "OPEN-CLOSE.RED"$ % file primitives IN "RDS-WRS.RED"$ % IO channel switching functions IN "OTHER-IO.RED"$ % random SL IO functions IN "READ.RED"$ % S-expression parser IN "TOKEN-SCANNER.RED"$ % table-driven token scanner IN "PRINTERS.RED"$ % Printing functions IN "WRITE-FLOAT.RED"$ % Floating point printer IN "PRINTF.RED"$ % formatted print routines IN "IO-ERRORS.RED"$ % I/O error handlers IN "IO-EXTENSIONS.RED"$ % Random non-SL IO functions IN "VECTORS.RED"$ % GetV, PutV, UpbV IN "STRING-OPS.RED"$ % Indx, SetIndx, Sub, SetSub, Concat IN "EXPLODE-COMPRESS.RED"$ % Access to characters of atoms IN "BACKTRACE.RED"$ % Stack backtrace IN "DEC-20-EXTRAS.RED"$ % Dec-20 specific routines IN "LAP.RED"$ % Compiled code loader IN "INTERESTING-SYMBOLS.RED"$ % to access important WCONSTs IN "MAIN-START.RED"$ % first routine called MIDASEND; InitSymTab(); END; The current non-kernel files are defined in PSL-NON-KERNEL.RED: LapOut "PL:PSL-NON-KERNEL.LAP"; in "EVAL-WHEN.RED"$ % control evaluation time(load first) in "CONT-ERROR.RED"$ % macro for ContinuableError in "MINI-TRACE.RED"$ % simple function tracing in "TOP-LOOP.RED"$ % generalized top loop function in "PROG-AND-FRIENDS.RED"$ % Prog, Go and Return in "ERROR-ERRORSET.RED"$ % most basic error handling in "TYPE-ERRORS.RED"$ % type mismatch error calls in "SETS.RED"$ % Set manipulation functions in "DSKIN.RED"$ % Read/Eval/Print from files in "LISP-MACROS.RED"$ % If, SetF in "LOOP-MACROS.RED"$ % While, Repeat, ForEach in "CHAR.RED"$ % Character constant macro in "LOAD.RED"$ % Standard module LAP loader in "PSL-MAIN.RED"$ % SaveSystem and Version stuff LapEnd; The model on the VAX is similar. The file GLOBAL-DATA.RED is automatically loaded by the compiler in the LAP-to-Assembly phase. It defines most important external symbols. PSL Manual 7 February 1983 Implementation section 21.3 page 21.5 A symbol table file, PSL.SYM is produced, and is meant to be used to aid in independent recompilation of modules. It records assigned ID numbers, locations of WVARS, WARRAYS, and WSTRINGs, etc. It is not currently used. The file P20C:DATA-MACHINE.RED defines important macros and constants, allocating fields within a DEC-20 word (the TAGs, etc). It is used only with compiled code, and is so associated with the P20C: (20 compiler specific code); other files on this directory include the code-generator tables and compiler customization files. More information on the compiler and its support can be found in Chapter 18. 21.4. Building the LAP to Assembly Translator 21.4. Building the LAP to Assembly Translator 21.4. Building the LAP to Assembly Translator [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] 21.5. The Garbage Collectors and Allocators 21.5. The Garbage Collectors and Allocators 21.5. The Garbage Collectors and Allocators 21.5.1. Compacting Garbage Collector on DEC-20 21.5.1. Compacting Garbage Collector on DEC-20 21.5.1. Compacting Garbage Collector on DEC-20 DEC-20 PSL uses essentially the same compacting garbage collector developed for the previous MTLISP systems: a single heap with all objects tagged in the heap in such a way that a linear scan from the low end permits objects to be identified; they are either tagged as normal objects, and are thus in a PAIR, or are tagged with a "pseudo-tag", indicating a header item for some sort of BYTE, WORD or ITEM array. Tracing of objects is done using a small stack, and relocation via a segment table and extra bits in the item. The extra bits in the item can be replaced by a bit-table, and this may become the default method. During compaction, objects are "tamped" to the low end of the heap, permitting "genetic" ordering for algebraic operations, and rapid stack-like allocation. Since the MTLISP systems included a number of variable sized data-types ______ ______ (e.g. vectors and strings), we had to reduce the working set, and ease the addition of new data-types, by using a single heap with explicitly tagged objects, and compacting garbage collector. In some versions, a bit-table was used both for marking and for compaction. To preserve locality, structures are "tamped" to one end of the heap, maintaining relative (creation time or "Genetic" [Terashima 78]) ordering. The order preservation was rather useful for an inexpensive canonical ordering required in the REDUCE algebra system (simply compare heap positions, which are "naturally" related to object creation). The single heap, with explicit tags made the addition of new data-types rather easy. The virtual memory was implemented as a low level "memory" extension, invisible to the allocator and garbage collector. Implementation 7 February 1983 PSL Manual page 21.6 section 21.5 This garbage collector has been rewritten a number of times; it is fairly easy to extend, but does waste lot of space in each DEC-20 word. Among possible alternative allocators/GC is a bit-table version, which is semantically equivalent to that described above but has the Dmov field replaced by a procedure to count ones in a segment of the bit-table. At some point, the separate heap model (tried on Z-80 and PDP-11 MTLISP's) may be implemented, but the separate page-per-type method (BIBOP:="big bag of pages") might also be tried; this permits user definition of new types. Allocation proceeds as from a stack, permitting rapid allocation, and preserving creation time ordering. The current implementation uses a recursive mark phase with a small stack (G stack) of about 500 entries. Relocation is accomplished with aid the of the SEGMENT table (overlays G stack), and a small field (Dmov) in each item (header) that gives additional motion of this item relative to the relocation of its segment. 21.5.2. Two-Space Stop and Copy Collector on VAX 21.5.2. Two-Space Stop and Copy Collector on VAX 21.5.2. Two-Space Stop and Copy Collector on VAX Another alternative is a copying, 2-space GC, which is fast and good for large address space (e.g. extended addressing DEC-20 or VAX). 21.6. The HEAPs 21.6. The HEAPs 21.6. The HEAPs The HEAP is used to store variable sized objects. Since one of the possible implementations is to have a separate heap for each of the data types PAIR, STR, CODE, and VECT (or for the groupings PAIR, CODE+STR, VECT), the heap is accessed in type specific fashion only. The current implementation of the allocator and garbage collector maps these type-specific operations onto a single array of item sized blocks, the first of which is a normal tagged item (CAR of a PAIR), or a pseudo-item (header of CODE, STR or VECT). The following blocks are either tagged items or packed bytes. The header item contains a "length" in items, or bytes, as appropriate. Using item sized blocks results in a slight wastage at the end of strings and code-vectors. Reclamation: h:=INF(x) For garbage collection, compaction and relocation. The heap is viewed as a set of ITEM sized blocks PUTINF(x,h) PUTTYPE(x,t) MARK(h) UNMARK(h) Modify the garbage collector mark MARKED(h) Test the mark (in a bit-table, ITEM header, or ITEM itself). Other Garbage collector primitives include: PSL Manual 7 February 1983 Implementation section 21.6 page 21.7 GCPUSH(x) Push an ITEM onto GCSTACK for later trace x:=GCPOP() Retrieve ITEM for tracing x:=GCTOP() Examine top of GCSTACK The Garbage collector uses a GCSTACK for saving pointers still to be traced. The compaction and relocation takes place by "tamping", without structure reorganization, so that any structure is relocated by the same or more than a neighboring structure, lower in the heap. This "monotonicity" means that the heap can be divided into "segments", and the relocation of any structure computed as the relocation of its segment, plus an additional movement within the segment. The segment table is an additional structure, while the "offset" is computed from the bits in the bit-table, or from a small field (if available) in the ITEM. This garbage collector is similar to that described in [Terashima 78]. RELOC(h):=SEGKNT(SEG(h))+DMOV(h) SEGKNT(SEG(h)) is the segment relocation of the segment in which h is, and DMOV is the incremental move within this segment. i:=SEG(h) Computes the segment number i:=DSEG(h) The "offset" in the segment Note that DMOV may actually be a small field in an ITEM header, if there is space, or can be computed from the bits in a segment of the BIT-table, or may map to some other construct. The segment table may actually overlay the GCSTACK space, since these are active in different passes of the garbage collection. The garbage collector used in the MTLISP system is an extension of that attributed to S. Brown in [Harrison 73, Harrison 74]. See also [Terashima 78]. __________ ______ !*GC [Initially: NIL] switch !*GC controls the printing of garbage collector messages. If NIL no indication of garbage collection occurs. If non-NIL various system dependent messages may be displayed. __________ ______ GCKNT!* [Initially: 0] global Reclaim Reclaim Records the number of times that Reclaim has been called to this point. GCKNT!* may be reset to another value to record counts incrementally, as desired. Implementation 7 February 1983 PSL Manual page 21.8 section 21.6 Reclaim Reclaim _______ ____ (Reclaim ): integer expr User call on GC; does a mark-trace and compaction of HEAP. Returns size of current Heap top. If !*GC is T, prints some Reclaim Reclaim statistics. Increments GCKNT!*. Reclaim(); is the user level call to the garbage collector. !%Reclaim !%Reclaim ___ _______ ____ (!%Reclaim ): Not Defined expr !%Reclaim !%Reclaim !%Reclaim(); is the system level call to the garbage collector. Active data in the heap is made contiguous and all tagged pointers into the heap from active local stack frames, the binding stack and the symbol table are relocated. 21.7. Allocation Functions 21.7. Allocation Functions 21.7. Allocation Functions GtHEAP GtHEAP _____ ____ ____ ____ (GtHEAP NWRDS:word): word expr _____ Return address in HEAP of a block of NWRDS item sized pieces. GtHeap GtHeap Generates HeapOverflow Message if can't satisfy. GtHeap NIL; returns the number of words (Lisp items) left in the heap. GtHeap GtHeap GtHeap 0; returns a pointer to the top of the active heap. GtHeap GtHeap GtHeap N; returns a pointer to N words (items). GtStr GtStr _____ ____ ____ ____ (GtStr UPLIM:word): word expr ______ _____ Address of string, 0..UPLIM bytes. (Allocate space for a string _____ UPLIM characters.) GtConstStr GtConstStr _ ______ ____ (GtConstStr N:string): expr GtStr GtStr (Allocate un-collected string for print name. Same as GtStr, but uses BPS, not heap.) GtWrds GtWrds _____ ____ ____ ____ (GtWrds UPLIM:word): word expr _____ _____ Address of WRD, 0..UPLIM WORDS. (Allocate space for UPLIM untraced words.) GtVect GtVect _____ ____ ____ ____ (GtVect UPLIM:word): word expr ______ _____ Address of vector, UPLIM items. (Allocate space for a vector _____ UPLIM items.) PSL Manual 7 February 1983 Implementation section 21.7 page 21.9 GtFixN GtFixN _ _______ ____ (GtFixN ): s-integer expr Allocate space for a fixnum. GtFltN GtFltN _ _______ ____ (GtFltN ): s-integer expr _____ Allocate space for a float. GtID GtID __ ____ (GtID ): id expr __ Allocate a new id. GtBps GtBps _ _ _______ _ _______ ____ (GtBps N:s-integer): s-integer expr _ Allocate N words for binary code. GtWArray GtWArray _ _ _______ _ _______ ____ (GtWArray N:s-integer): s-integer expr _ Allocate N words for WVar/WArray/WString. DelBps DelBps ____ (DelBps ): expr DelWArray DelWArray ____ (DelWArray ): expr GtBps GtWArray GtBps GtWArray GtBps NIL; returns the number of words left in BPS. GtWArray NIL returns the same quantity. GtBps GtBps GtBps 0; returns a pointer to the bottom of BPS, that is, the current GtWArray GtWArray value of NextBPS. GtWArray 0; returns a pointer to the top of BPS, the DelBps DelBps current value of LastBPS. This is sometimes convenient for use with DelBps DelWArray DelWArray and DelWArray. GtBps GtBps GtBps N; returns a pointer to N words in BPS, moving NextBPS up by that GtWArray GtWArray amount. GtWArray returns a pointer to (the bottom of) N words at the top of BPS, pushing LastBPS down by that amount. Remember that the arguments are number of WORDS to allocate, that is, 1/4 the number of bytes on the VAX or 68000. DelBps DelBps DelBps(Lo, Hi) returns a block to BPS, if it is contiguous with the current free space. In other words, if Hi is equal to NextBPS, then NextBPS is set to Lo. Otherwise, NIL is returned and no space is added to DelHeap DelBps DelHeap DelBps BPS. DelHeap(Lo, Hi) is similar in action to DelBps. DelWArray DelWArray DelWArray(Lo, Hi) returns a block to the top of BPS, if it is contiguous with the current free space. In other words, if Lo is equal to LastBPS, then LastBPS is set to Hi. Otherwise, NIL is returned and no space is Implementation 7 February 1983 PSL Manual page 21.10 section 21.7 added to BPS. The storage management routines above are intended for either very long term or very short term use. BPS is not examined by the garbage collector at all. The routines below should be used with great care, as they deal with the heap which must be kept in a consistent state for the garbage collector. All blocks of memory allocated in the heap must have header words describing the size and type of data contained, and all pointers into the heap must have type tags consistent with the data they refer to. |
Added psl-1983/3-1/lpt/22-parser.lpt version [5482c246b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Parser Tools section 22.0 page 22.1 CHAPTER 22 CHAPTER 22 CHAPTER 22 PARSER TOOLS PARSER TOOLS PARSER TOOLS 22.1. Introduction . . . . . . . . . . . . . . . 22.1 22.2. The Table Driven Parser . . . . . . . . . . . 22.2 22.2.1. Flow Diagram for the Parser. . . . . . . . 22.2 22.2.2. Associating the Infix Operator with a Function . 22.4 22.2.3. Precedences . . . . . . . . . . . . . 22.5 22.2.4. Special Cases of 0 <-0 and 0 0. . . . . . . 22.5 22.2.5. Parenthesized Expressions . . . . . . . . 22.5 22.2.6. Binary Operators in General. . . . . . . . 22.6 22.2.7. Assigning Precedences to Key Words . . . . . 22.7 22.2.8. Error Handling . . . . . . . . . . . . 22.7 22.2.9. The Parser Program for the RLISP Language . . . 22.7 22.2.10. Defining Operators . . . . . . . . . . 22.8 22.3. The MINI Translator Writing System. . . . . . . . 22.10 22.3.1. A Brief Guide to MINI. . . . . . . . . . 22.10 22.3.2. Pattern Matching Rules . . . . . . . . . 22.12 22.3.3. A Small Example. . . . . . . . . . . . 22.12 22.3.4. Loading Mini. . . . . . . . . . . . . 22.13 22.3.5. Running Mini. . . . . . . . . . . . . 22.13 22.3.6. MINI Error messages and Error Recovery . . . . 22.13 22.3.7. MINI Self-Definition . . . . . . . . . . 22.13 22.3.8. The Construction of MINI. . . . . . . . . 22.15 22.3.9. History of MINI Development. . . . . . . . 22.16 22.4. BNF Description of RLISP Using MINI . . . . . . . 22.17 22.1. Introduction 22.1. Introduction 22.1. Introduction In many applications, it is convenient to define a special "problem-oriented" language, tailored to provide a natural input format. Examples include the RLISP ALGOL-like surface language for algebraic work, graphics languages, boolean query languages for data-base, etc. Another ________ important case is the requirement to accept existing programs in some language, either to translate them to another language, to compile to machine language, to be able to adapt existing code into the PSL environment (e.g. mathematical libraries, etc.), or because we wish to use PSL based tools to analyze a program written in another language. One approach is to hand-code a program in PSL (called a "parser") that translates the input language to the desired form; this is tedious and error prone, and it is more convenient to use a "parser-writing-tool". In this Chapter we describe in detail two important parser writing tools available to the PSL programmer: an extensible table-driven parser that is used for the RLISP parser (described in Chapter 3), and the MINI parser generator. The table-driven parser is most useful for languages that are Parser Tools 7 February 1983 PSL Manual page 22.2 section 22.1 simple extensions of RLISP, or in fact for rapidly adding new syntactic constructs to RLISP. The MINI system is used for the development of more complete user languages. 22.2. The Table Driven Parser 22.2. The Table Driven Parser 22.2. The Table Driven Parser The parser is a top-down recursive descent parser, which uses a table of ___________ Precedences to control the parse; if numeric precedence is not adequate, LISP functions may be inserted into the table to provide more control. The parser described here was developed by Nordstrom [Nordstrom 73], and is very similar to parser described by Pratt [Pratt 73], and apparently used for the CGOL language, another LISP surface language. Scan Scan Scan Scan The parser reads tokens from an input stream using a function Scan. Scan ChannelReadToken ChannelReadToken calls the ChannelReadToken function described in Chapter 12, and performs some additional checks, described below. Each token is defined to be one of the following: non-operator O right operator O-> binary operator <-O-> All combinations of . . .O-> O. . . and O <-O->. . . are supposed to be legal, while the combinations . . .O-> <-O->. . ., . . .<-O-> <-O->. . . and O O. . . are normally illegal (error ARG MISSING and error OP MISSING, respectively). __ With each operator (which must be an id) is associated a construction function, a right precedence, and for binary operators, a left precedence. The Unary Prefix operators have this information stored under the indicator 'RLISPPREFIX and Binary operators have it stored under 'RLISPINFIX. (Actually, the indicator used at any time during parsing is the VALUE of GRAMPREFIX or GRAMINFIX, which may be changed by the user). 22.2.1. Flow Diagram for the Parser 22.2.1. Flow Diagram for the Parser 22.2.1. Flow Diagram for the Parser In this diagram RP stands for Right Precedence, LP for Left Precedence and CF for Construction Function. OP is a global variable which holds the current token. PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.3 procedure PARSE(RP); RDRIGHT(RP,SCAN()); % SCAN reads next token RDRIGHT(RP,Y) | \|/ | ------------------------ | |yes | Y is Right OP |-----> Y:=APPLY(Y.CF, | | RDRIGHT(Y.RP)); ------------------------ . | . \|/ no . | . ------------------------ . ERROR yes| | no . ARG <----| Y is Binary OP |----> OP:= . MISSING | | SCAN(); . ------------------------ . . |--------<------------<------* RDLEFT: \|/ ^ | ^ ------------------------ ^ ERROR no| | ^ OP <----| OP is Binary | ^ MISSING | | ^ ------------------------ ^ | ^ \|/ yes ^ | ^ ------------------------ ^ RETURN yes| |no ^ (Y) <----| RP > OP.lp |---> Y:=APPLY(OP.cf,Y, ------------------------ PARSE(OP.lp,SCAN()); Parser Tools 7 February 1983 PSL Manual page 22.4 section 22.2 This diagram reflects the major behavior, though some trivial additions are included in the RLISP case to handle cases such as OP-> <-OP, '!;, etc. [See PU:RLISP-PARSER.RED for full details.] The technique involved may also be described by the following figure: . . . 0-> Y <-0 . . . rp lp Y is a token or an already parsed expression between two operators (as indicated). If 0->'s RP is greater than <-0's LP, then 0-> is the winner and Y goes to 0->'s construction function (and vice versa). The result from the construction function is a "new Y" in another parse situation. By associating precedences and construction functions with the operators, we are now able to parse arithmetic expressions (except for function calls) and a large number of syntactical constructions such as IF - THEN - ELSE - ; etc. The following discussion of how to expand the parser to cover a language such as RLISP (or ALGOL) may also be seen as general tools for handling the parser and defining construction functions and precedences. 22.2.2. Associating the Infix Operator with a Function 22.2.2. Associating the Infix Operator with a Function 22.2.2. Associating the Infix Operator with a Function Scan RAtomHook Scan RAtomHook __ __ The Scan, after calling RAtomHook, checks ids and special ids (those with TOKTYPE!* = 3) to see if they should be renamed from external form to Plus2 Plus2 internal form (e.g. '!+ to Plus2). This is done by checking for a NEWNAM __ __ or NEWNAM!-OP property on the id. For special ids, the NEWNAM!-OP property is first checked. The value of the property is a replacement token, i.e. PUT('!+,'NEWNAM!-OP,'PLUS2) has been done. Scan RlispRead Scan RlispRead Scan also handles the ' mark, calling RlispRead to get the S-expression. RlispRead Read RlispRead Read RlispRead is a version of Read, using a special SCANTABLE, RLISPREADSCANTABLE!*. Scan Scan The function Scan also sets SEMIC!* to '!; or '!$ if CURSYM!* is detected to be '!*SEMICOL!* (the internal name for '!; and "!$). This controls the RLISP echo/no-echo capability. Finally, if the renamed token is 'COMMENT ReadCh ReadCh then characters are ReadCh'd until a '!; or '!$ . PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.5 22.2.3. Precedences 22.2.3. Precedences 22.2.3. Precedences To set up precedences, it is often helpful to set up a precedence matrix of the operators involved. If any operator has one "precedence" with respect to one particular operator and another "precedence" with respect to some other, it is sometimes not possible to run the parser with just numbered precedences for the operators without introducing ambiguities. If this is the case, replace the number RP by the operator RP and test with something like: IF RP *GREATER* OP . . . *GREATER* may check in the precedence matrix. An example in which such a scheme might be used is the case for which ALGOL uses ":" both as a label marker and as an index separator (although in this case there is no need for the change above). It is also a good policy to have even numbers for right precedences and odd numbers for left precedences (or vice versa). 22.2.4. Special Cases of 0 <-0 and 0 0 22.2.4. Special Cases of 0 <-0 and 0 0 22.2.4. Special Cases of 0 <-0 and 0 0 If . . .0 0. . . is a legal case (i.e. F A may translate to (F A)), ERROR OP MISSING is replaced by: Y:=REPCOM(Y,RDRIGHT(99,OP)); GO TO RDLEFT; The value 99 is chosen in order to have the first object (F) behave as a right operator with maximum precedence. If . . .0 <-0. . . is legal for some combinations of operators, replace ERROR ARG MISSING by something equivalent to the illegal RLISP statement: IF ISOPOP(OP,RP,Y) THEN <<OP:=Y; Y:=(something else, i.e. NIL); GOTO RDLEFT>> ELSE ERROR ARG MISSING; ISOPOP is supposed to return T if the present situation is legal. 22.2.5. Parenthesized Expressions 22.2.5. Parenthesized Expressions 22.2.5. Parenthesized Expressions (a) is to be translated to a. E.g. Parser Tools 7 February 1983 PSL Manual page 22.6 section 22.2 BEGIN a END translates to (PROG a). Define "(" and BEGIN as right operators with low precedences (2 and -2 respectively). Also define ")" and END as binary operators with matching left precedences (1 and -3 respectively). The construction functions for "(" and BEGIN are then something like: [See pu:RLISP-PARSER.RED for exact details on ParseBEGIN] BEGIN (X);PROG2(OP:=SCAN();MAKEPROG(X)); "(" (X);PROG2(IF OP=') THEN OP:=SCAN() ELSE ERROR, x); Note that the construction functions in these cases have to read the next token; that is the effect of ")" closing the last "(" and not all earlier "("'s. This is also an example of binary operators declared only for the purpose of having a left precedence. 22.2.6. Binary Operators in General 22.2.6. Binary Operators in General 22.2.6. Binary Operators in General As almost all binary operators have a construction function like LIST(OP,X,Y); it is assumed to be of that kind if no other is given. If OP is a binary operator, then "a OP b OP c" is interpreted as "(a OP b) OP c" only if OP's LP is less than OP's RP. Example: A + B + C translates to (A + B) + C because +'RP = 20 and +'LP = 19 A ^ B ^ C translates to A ^ (B ^ C) because ^'RP = 20 and ^'LP = 21 If you want some operators to translate to n-ary expressions, you have to define a proper construction function for that operator. Example: PLUS (X,Y); IF CAR(X) = 'PLUS THEN NCONC(X,LIST(Y)) ELSE LIST('PLUS,X,Y); PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.7 By defining "," and ";" as ordinary binary operators, the parser automatically takes care of constructions like . . .e,e,e,e,e. . . and . . . stm;stm;stm;stm;. . . It is then up to some other operators to remove the "," or the ";" from the parsed result. 22.2.7. Assigning Precedences to Key Words 22.2.7. Assigning Precedences to Key Words 22.2.7. Assigning Precedences to Key Words If you want some operators to have control immediately, insert IF RP = NIL THEN RETURN Y ELSE as the very first test in RDRIGHT and set the right precedence of those to NIL. This is sometimes useful for key-word expressions. If entering a construction function of such an operator, X is the token immediately after the operator. E.g.: We want to parse PROCEDURE EQ(X,Y); . . . Define PROCEDURE as a right operator with NIL as precedence. The construction function for PROCEDURE can always call the parser and set the rest of the expression. Note that if PROCEDURE was not defined as above, the parser would misunderstand the expression in the case of EQ as declared as a binary operator. 22.2.8. Error Handling 22.2.8. Error Handling 22.2.8. Error Handling For the present, if an error occurs a message is printed but no attempt is made to correct or handle the error. Mostly the parser goes wild for a while (until a left precedence less than current right precedence is found) and then goes on as usual. 22.2.9. The Parser Program for the RLISP Language 22.2.9. The Parser Program for the RLISP Language 22.2.9. The Parser Program for the RLISP Language SCAN(); The purpose of this function is to read the next token from the input stream. It uses the general purpose table driven token scanner described in Chapter 12, with a specially set up ReadTable, RLISPSCANTABLE!*. As Scan __________ Scan RLISP has multiple identifiers for the same operators, Scan uses the following translation table: = EQUAL >= GEQ + PLUS > GREATERP - DIFFERENCE <= LEQ / QUOTIENT < LESSP . CONS * TIMES := SETQ ** EXPT Scan Scan In these cases, Scan returns the right hand side of the table values. Scan Scan Also, two special cases are taken care of in Scan: Parser Tools 7 February 1983 PSL Manual page 22.8 section 22.2 a. ' is the QUOTE mark. If a parenthesized expression follows ' then the syntax within the parenthesis is that of LISP, using a special scan table, RLISPREADSCANTABLE!*. The only major difference from ordinary LISP is that ! is required for all special characters. b. ! in RLISP means actually two things: i. the following symbol is not treated as a special symbol (but belongs to the print name of the atom in process); ii. the atom created cannot be an operator. Example: !( in the text behaves as the atom "(". To signal to the parser that this is the case, the flag variable ESCAPEFL must be set to T if this situation occurs. 22.2.10. Defining Operators 22.2.10. Defining Operators 22.2.10. Defining Operators To define operators use: DEFINEROP(op,p{,stm}); For right or prefix operators. DEFINEBOP(op,lp,rp{,stm}); For binary operators. These use the VALUE of DEFPREFIX and DEFINFIX to store the precedences and construction functions. The default is set for RLISP, to be __________ 'RLISPPREFIX and 'RLISPINFIX. The same identifier can be defined both as the right and binary operator. The context defines which one applies. Stm is the construction function. If stm is omitted, the common defaults are used: LIST(OP,x) prefix case, x is parsed expression following, x=RDRIGHT(p,SCAN()). LIST(OP,x,y) binary case, x is previously parsed expression, y is expression following, y=RDRIGHT(rp,SCAN()). __ If stm is an id, it is assumed to be a procedure of one or two arguments, PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.9 for "x" or "x,y". If it is an expression, it is embedded as (LAMBDA(X) stm) or (LAMBDA(X Y) stm), and should refer to X and Y, as needed. Also remember that the free variable OP holds the last token (normally the binary operator which stopped the parser). If "p" or "rp" is NIL, RDRIGHT is not called by default, so that only SCAN() (the next token) is passed. For example, DEFINEBOP('DIFFERENCE,17,18); % Most common case, left associative, stm=LIST(OP,x,y); DEFINEBOP('CONS,23,21); % Right Associative, default stm=LIST(OP,x,y) DEFINEBOP('AND,11,12,ParseAND); % Left Associative, special function PROCEDURE ParseAND(X,Y); NARY('AND,X,Y); DEFINEBOP('SETQ,7,6,ParseSETQ); % Right Associative, Special Function PROCEDURE ParseSETQ(LHS,RHS); LIST(IF ATOM LHS THEN 'SETQ ELSE 'SETF, LHS, RHS); DEFINEROP('MINUS,26); % default C-fn, just (list OP arg) DEFINEROP('PLUS,26,ParsePLUS1); % DEFINEROP('GO,NIL,ParseGO ); % Special Function, DO NOT use default PARSE ahead PROCEDURE ParseGO X; X is now JUST next-token IF X EQ 'TO THEN LIST('GO,PARSE0(6,T)) % Explicit Parse ahead ELSE <<OP := SCAN(); % get Next Token LIST('GO,X)>>; DEFINEROP('GOTO,NIL,ParseGOTO ); % Suppress Parse Ahead, just pass NextToken PROCEDURE ParseGOTO X; <<OP := SCAN(); LIST('GO,X)>>; Parser Tools 7 February 1983 PSL Manual page 22.10 section 22.3 22.3. The MINI Translator Writing System 22.3. The MINI Translator Writing System 22.3. The MINI Translator Writing System Note that MINI is now autoloading. 22.3.1. A Brief Guide to MINI 22.3.1. A Brief Guide to MINI 22.3.1. A Brief Guide to MINI The following is a brief introduction to MINI, the reader is referred to [Marti 79] for a more detailed discussion of the META/RLISP operators, which are very similar to those of MINI. The MINI system reads in a definition of a translator, using a BNF-like form. This is processed by MINI into a set of LISP functions, one for each production, which make calls on each other, and a set of support routines that recognize a variety of simple constructs. MINI uses a stack to perform parsing, and the user can access sub-trees already on the stack, replacing them by other trees built from these sub-trees. The primitive __ _______ functions that recognize ids, integers, etc. each place their recognized token on this stack. For example, FOO: ID '!- ID +(PLUS2 #2 #1) ; defines a rule FOO, which recognizes two identifiers separated by a minus __________ sign (each ID pushes the recognized identifier onto the stack). The last expression replaces the top 2 elements on the stack (#2 pops the first ID pushed onto the stack, while #1 pops the other) with a LISP statement. Id Id _______ ____ (Id ): boolean expr __________ See if current token is an identifier and not a keyword. If it is, then push onto the stack and fetch the next token. AnyId AnyId _______ ____ (AnyId ): boolean expr __ See if current token is an id whether or not it is a key word. AnyTok AnyTok _______ ____ (AnyTok ): boolean expr Always succeeds by pushing the current token onto the stack. Num Num _______ ____ (Num ): boolean expr ______ Tests to see if the current token is a number, if so it pushes ______ the number onto the stack and fetches the next token. PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.11 Str Str _______ ____ (Str ): boolean expr Num Num ______ Same as Num, except for strings. Specification of a parser using MINI consists of defining the syntax with BNF-like rules and semantics with LISP expressions. The following is a brief list of the operators: ' Used to designate a terminal symbol (i.e. 'WHILE, 'DO, '!=). Identifier Specifies a nonterminal. ( ) Used for grouping (i.e. (FOO BAR) requires rule FOO to parse followed immediately by BAR). < > Optional parse, if it fails then continue (i.e. <FOO> tries to parse FOO). / Optional rules (i.e. FOO / BAR allows either FOO or BAR to parse, with FOO tested first). STMT* Parse any number of STMT. STMT[ANYTOKEN]* Parse any number of STMT separated by ANYTOKEN, create a list and __________ push onto the stack (i.e. ID[,]* parses a number of identifiers separated by commas, like in an argument list). _______ ##n Refer to the nth stack location (n must be an integer). _______ #n Pop the nth stack location (n must be an integer). +(STMT) Push the unevaluated (STMT) onto the stack. .(SEXPR) Evaluate the SEXPR and ignore the result. =(SEXPR) Evaluate the SEXPR and test if result non-NIL. +.(SEXPR) Evaluate the SEXPR and push the result on the stack. @ANYTOKEN Specifies a statement terminator; used in the error recovery mechanism to search for the occurrence of errors. @@ANYTOKEN Grammar terminator; also stops scan, but if encountered in error-recovery, terminates grammar. Parser Tools 7 February 1983 PSL Manual page 22.12 section 22.3 22.3.2. Pattern Matching Rules 22.3.2. Pattern Matching Rules 22.3.2. Pattern Matching Rules In addition to the BNF-like rules that define procedures with 0 arguments and which scan tokens by calls on NEXT!-TOK() and operate on the stack, MINI also includes a simple TREE pattern matcher and syntax to define PatternProcedures that accept and return a single argument, trying a series of patterns until one succeeds. E.g. template -> replacement PATTERN = (PLUS2 &1 0) -> &1, (PLUS2 &1 &1) -> (LIST 'TIMES2 2 &1), &1 -> &1; defines a pattern with 3 rules. &n is used to indicate a matched sub-tree in both the template and replacement. A repeated &n, as in the second Equal Equal rule, requires Equal sub-trees. 22.3.3. A Small Example 22.3.3. A Small Example 22.3.3. A Small Example % A simple demo of MINI, to produce a LIST-NOTATION reader. % INVOKE 'LSPLOOP reads S-expressions, separated by ; mini 'lsploop; % Invoke MINI, give name of ROOT % Comments can appear anywhere, % prefix by % to end-of-line lsploop:lsp* @@# ; % @@# is GRAMMAR terminator % like '# but stops TOKEN SCAN lsp: sexp @; % @; is RULE terminator, like '; .(print #1) % but stops SCAN, to print .(next!-tok) ; % so call NEXT!-TOK() explicitly sexp: id / num / str / '( dotexp ') ; dotexp: sexp* < '. sexp +.(attach #2 #1) > ; fin symbolic procedure attach(x,y); <<for each z in reverse x do y:=z . y; y>>; 22.3.4. Loading Mini 22.3.4. Loading Mini 22.3.4. Loading Mini MINI is loaded from PH: using LOAD MINI;. PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.13 22.3.5. Running Mini 22.3.5. Running Mini 22.3.5. Running Mini Invoke Invoke A MINI grammar is run by calling Invoke rootname;. This installs appropriate Key Words (stored on the property list of rootname), and start the grammar by calling the Rootname as first procedure. 22.3.6. MINI Error messages and Error Recovery 22.3.6. MINI Error messages and Error Recovery 22.3.6. MINI Error messages and Error Recovery If MINI detects a non-fatal error, a message be printed, and the current token and stack is shown. MINI then calls NEXT!-TOK() repeatedly until either a statement terminator (@ANYTOKEN) or grammar terminator (@ANYTOKEN) is seen. If a grammar terminator, the grammar is exited; otherwise parsing resumes from the ROOT. [??? Interaction with BREAK loop rather poor at the moment ???] [??? Interaction with BREAK loop rather poor at the moment ???] [??? Interaction with BREAK loop rather poor at the moment ???] 22.3.7. MINI Self-Definition 22.3.7. MINI Self-Definition 22.3.7. MINI Self-Definition % The following is the definition of the MINI meta system in terms of % itself. Some support procedures are needed, and exist in a % separate file. % To define a grammar, call the procedure MINI with the argument % being the root rule name. Then when the grammar is defined it may % be called by using INVOKE root rule name. % The following is the MINI Meta self definition. MINI 'RUL; % Define the diphthongs to be used in the grammar. DIP: !#!#, !-!>, !+!., !@!@ ; % The root rule is called RUL. RUL: ('DIP ': ANYTOK[,]* .(DIPBLD #1) '; / (ID .(SETQ !#LABLIST!# NIL) ( ': ALT +(DE #2 NIL #1) @; / '= PRUL[,]* @; .(RULE!-DEFINE '(PUT(QUOTE ##2)(QUOTE RB) (QUOTE #1))) +(DE ##1 (A) (RBMATCH A (GET (QUOTE #1) (QUOTE RB)) NIL))) .(RULE!-DEFINE #1) .(NEXT!-TOK) ))* @@FIN ; % An alternative is a sequence of statements separated by /'s; ALT: SEQ < '/ ALT +(OR #2 #1) >; % A sequence is a list of items that must be matched. SEQ: REP < SEQ +(AND #2 (FAIL!-NOT #1)) >; Parser Tools 7 February 1983 PSL Manual page 22.14 section 22.3 % A repetition may be 0 or more single items (*) or 0 or more items % separated by any token (ID[,]* parses a list of ID's separated % by ,'s. REP: ONE <'[ (ID +(#1) / '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / ANYKEY +(EQTOK!-NEXT (QUOTE #1))) '] +(AND #2 #1) '* BLD!-EXPR / '* BLD!-EXPR>; % Create an sexpression to build a repetition. BLD!-EXPR: +(PROG (X) (SETQ X (STK!-LENGTH)) $1 (COND (#1 (GO $1))) (BUILD!-REPEAT X) (RETURN T)); ANYKEY: ANYTOK .(ADDKEY ##1) ; % Add a new KEY % One defines a single item. ONE: '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / '@ ANYKEY .(ADDRTERM ##1) +(EQTOK (QUOTE #1)) / '@@ ANYKEY .(ADDGTERM ##1) +(EQTOK (QUOTE #1)) / '+ UNLBLD +(PUSH #1) / '. EVLBLD +(PROGN #1 T) / '= EVLBLD / '< ALT '> +(PROGN #1 T) / '( ALT ') / '+. EVLBLD +(PUSH #1) / ID +(#1) ; % This rule defines an un evaled list. It builds a list with % everything quoted. UNLBLD: '( UNLBLD ('. UNLBLD ') +(CONS #2 #1) / UNLBLD* ') +(LIST . (#2 . #1)) / ') +(LIST . #1)) / LBLD / ID +(QUOTE #1) ; % EVLBLD builds a list of evaled items. EVLBLD: '( EVLBLD ('. EVLBLD ') +(CONS #2 #1) / EVLBLD* ') +(#2 . #1) / ') ) / LBLD / ID ; LBLD: '# NUM +(EXTRACT #1) / '## NUM +(REF #1) / '$ NUM +(GENLAB #1) / '& NUM +(CADR (ASSOC #1 (CAR VARLIST))) / NUM / STR / '' ('( UNLBLD* ') +(LIST . #1) / ANYTOK +(QUOTE #1)); PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.15 % Defines the pattern matching rules (PATTERN -> BODY). PRUL: .(SETQ INDEXLIST!* NIL) PAT '-> (EVLBLD)* +(LAMBDA (VARLIST T1 T2 T3) (AND . #1)) .(SETQ PNAM (GENSYM)) .(RULE!-DEFINE (LIST 'PUTD (LIST 'QUOTE PNAM) '(QUOTE EXPR) (LIST 'QUOTE #1))) +.(CONS #1 PNAM); % Defines a pattern. % We now allow the . operator to be the next to last in a (). PAT: '& ('< PSIMP[/]* '> NUM +.(PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #2 #1) ) / NUM +.(COND ((MEMQ ##1 INDEXLIST!*) (LIST '!& '!& #1)) (T (PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #1)))) ) / ID / '!( PAT* <'. PAT +.(APPEND #2 #1)> '!) / '' ANYTOK / STR / NUM ; % Defines the primitives in a pattern. PSIMP: ID / NUM / '( PSIMP* ') / '' ANYTOK; % The grammar terminator. FIN 22.3.8. The Construction of MINI 22.3.8. The Construction of MINI 22.3.8. The Construction of MINI MINI is actually described in terms of a support package for any MINI-generated parser and a self-description of MINI. The useful files (on PU: and PL:) are as follows: MINI.MIN The self definition of MINI in MINI. MINI.SL A Standard LISP version of MINI.MIN, translated by MINI itself. MINI.RED The support RLISP for MINI. MINI-PATCH.RED and MINI.FIX Some additions being tested. MINI.LAP The precompiled LAP file. Use LOAD MINI. MINI-LAP-BUILD.CTL A batch file that builds PL:MINI.LAP from the above files. MINI-SELF-BUILD.CTL A batch file that builds the MINI.SL file by loading and translating MINI.MIN. Parser Tools 7 February 1983 PSL Manual page 22.16 section 22.3 22.3.9. History of MINI Development 22.3.9. History of MINI Development 22.3.9. History of MINI Development The MINI Translator Writing System was developed in two steps. The first was the enhancement of the META/RLISP [Marti 79] system with the definition of pattern matching primitives to aid in describing and performing tree-to-tree transformations. META/RLISP is very proficient at translating an input programming language into LISP or LISP-like trees, but did not have a good method for manipulating the trees nor for direct generation of target machine code. PMETA (as it was initially called) [Kessler 79] solved these problems and created a very good environment for the development of compilers. In fact, the PMETA enhancements have been fully integrated into META/RLISP. The second step was the elimination of META/RLISP and the development of a smaller, faster system (MINI). Since META/RLISP was designed to provide maximum flexibility and full generality, the parsers that is creates are large and slow. One of its most significant problems is that it uses its own single character driven LISP functions for token scanning and recognition. Elimination of this overhead has produced a faster translator. MINI uses the hand coded scanner in the underlying RLISP. The other main aspect of MINI was the elimination of various META/RLISP features to decrease the size of the system (also decreasing the flexibility, but MINI has been successful for the various purposes in COG). MINI is now small enough to run on small LISP systems (as long as a token scanner is provided). The META/RLISP features that MINI has changed or eliminated include the following: a. The ability to backup the parser state upon failure is supported in META/RLISP. However, by modifying a grammar definition, the need for backup can be mostly avoided and was therefore eliminated from MINI. b. META/RLISP has extensive mechanisms to allow arbitrary length diphthongs. MINI only supports two character diphthongs, declared prior to their use. c. The target machine language and error specification operators are not supported because they can be implemented with support routines. d. RLISP subsyntax for specification of semantic operations is not supported (only LISP is provided). Although MINI lacks many of the features of META/RLISP, it still has been quite sufficient for a variety of languages. PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.17 22.4. BNF Description of RLISP Using MINI 22.4. BNF Description of RLISP Using MINI 22.4. BNF Description of RLISP Using MINI The following formal scheme for the translation of RLISP syntax to LISP syntax is presented to eliminate misinterpretation of the definitions. We have used the above MINI syntactic form since it is close enough to BNF and has also been checked mechanically. Recall that the transformation scheme produces an S-expression corresponding to the input RLISP expression. A rule has a name by which it is known and is defined by what follows the meta symbol :. Each rule of the set consists of one or more "alternatives" separated by the meta symbol /, being the different ways in which the rule is matched by source text. Each rule ends with a ;. Each alternative is composed of a "recognizer" and a "generator". The "generator" is a MINI + expression which builds an S-expression from constants and elements loaded on the stack. The result is then loaded on the stack. The #n and ##n refer to elements loaded by MINI primitives or other rules. The "generator" is thus a template into which previously generated items are substituted. Recall that terminals in both recognizer and generator are quoted with a ' mark. This RLISP/SYSLISP syntax is based on a series of META and MINI definitions, started by R. Loos in 1970, continued by M. Griss, R. Kessler and A. Wang. [??? This MINI.RLISP grammar is a bit out of date ???] [??? This MINI.RLISP grammar is a bit out of date ???] [??? This MINI.RLISP grammar is a bit out of date ???] [??? Need to confirm for latest RLISP ???] [??? Need to confirm for latest RLISP ???] [??? Need to confirm for latest RLISP ???] mini 'rlisp; dip: !: , !<!< , !>!> , !:!= , !*!* , !<!= , !>!= , !' , !#!# ; termin: '; / '$ ; % $ used to not echo result rtermin: @; / @$ ; rlisp: ( cmds rtermin .(next!-tok) )* ; % Note explicit Scan cmds: procdef / rexpr ; %------ Procedure definition: procdef: emodeproc (ftype procs/ procs) / ftype procs / procs ; ftype: 'fexpr .(setq FTYPE!* 'fexpr) / % function type 'macro .(setq FTYPE!* 'macro) / 'smacro .(setq FTYPE!* 'smacro) / 'nmacro .(setq FTYPE!* 'nmacro) / ('expr / =T) .(setq FTYPE!* 'expr) ; Parser Tools 7 February 1983 PSL Manual page 22.18 section 22.4 emodeproc: 'syslsp .(setq EMODE!* 'syslsp)/ ('lisp/'symbolic/=T) .(setq EMODE!* 'symbolic) ; procs: 'procedure id proctail +(putd (quote #2) (quote FTYPE!* ) #1) ; proctail: '( id[,]* ') termin rexpr +(quote (lambda #2 #1)) / termin rexpr +(quote (lambda nil #1)) / id termin rexpr +(quote (lambda (#2) #1)) ; %------ Rexpr definition: rexpr: disjunction ; disjunction: conjunction (disjunctail / =T) ; disjunctail: ('or conjunction ('or conjunction)*) +.(cons 'or (cons #3 (cons #2 #1))) ; conjunction: negation (conjunctail / =T) ; conjunctail: ('and negation ('and negation)*) +.(cons (quote and) (cons #3 (cons #2 #1))) ; negation: 'not negation +(null #1) / 'null negation +(null #1) / relation ; relation: term reltail ; reltail: relop term +(#2 #2 #1) / =T ; term: ('- factor +(minus #1) / factor) termtail ; termtail: (plusop factor +(#2 #2 #1) termtail) / =T ; factor: powerexpr factortail ; factortail: (timop powerexpr +(#2 #2 #1) factortail) / =T ; powerexpr: dotexpr powtail ; powtail: ('** dotexpr +(expt #2 #1) powtail) / =T ; dotexpr: primary dottail ; dottail: ('. primary +(cons #2 #1) dottail) / =T ; primary: ifstate / groupstate / beginstate / PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.19 whilestate / repeatstate / forstmts / definestate / onoffstate / lambdastate / ('( rexpr ') ) / ('' (lists / id / num) +(quote #1)) / id primtail / num ; primtail:(':= rexpr +(setq #2 #1)) / (': labstmts ) / '( actualst / (primary +(#2 #1)) / =T ; lists: '( (elements)* ') ; elements: lists / id / num ; %------ If statement: ifstate: 'if rexpr 'then rexpr elserexpr +(cond (#3 #2) (T #1)) ; elserexpr: 'else rexpr / =T +nil ; %------ While statement: whilestate: 'while rexpr 'do rexpr +(while #2 #1) ; %----- Repeat statement: repeatstate: 'repeat rexpr 'until rexpr +(repeat #2 #1) ; %---- For statement: forstmts: 'for fortail ; fortail: ('each foreachstate) / forstate ; foreachstate: id inoron rexpr actchoice rexpr +(foreach #5 #4 #3 #2 #1) ; inoron: ('in +in / 'on +on) ; actchoice: ('do +do / 'collect +collect / 'conc +conc) ; forstate: id ':= rexpr loops ; loops: (': rexpr types rexpr +(for #5 (#4 1 #3) #2 #1) ) / ('step rexpr 'until rexpr types rexpr +(for #6 (#5 #4 #3) #2 #1) ) ; types: ('do +do / 'sum +sum / 'product +product) ; Parser Tools 7 February 1983 PSL Manual page 22.20 section 22.4 %----- Function call parameter list: actualst: ') +(#1) / rexpr[,]* ') +.(cons #2 #1) ; %------ Compound group statement: groupstate: '<< rexprlist '>> +.(cons (quote progn) #1) ; %------ Compound begin-end statement: beginstate: 'begin blockbody 'end ; blockbody: decllist blockstates +.(cons (quote prog) (cons #2 #1)) ; decllist: (decls[;]* +.(flatten #1)) / (=T +nil) ; decls: ('integer / 'scalar) id[,]* ; blockstates: labstmts[;]* ; labstmts: ('return rexpr +(return #1)) / (('goto / 'go 'to) id +(go #1)) / ('if rexpr 'then labstmts blkelse +(cond (#3 #2) (T #1))) / rexpr ; blkelse: 'else labstmts / =T +nil ; rexprlist: rexpr [;]* ; lambdastate: 'lambda lamtail ; lamtail: '( id[,]* ') termin rexpr +(lambda #2 #1) / termin rexpr +(lambda nil #1) / id termin rexpr +(lambda (#2) #1) ; %------ Define statement: (id and value are put onto table % named DEFNTAB: definestate: 'define delist +.(cons (quote progn) #1) ; delist: (id '= rexpr +(put (quote #2) (quote defntab) (quote #1)))[,]* ; %------ On or off statement: onoffstate: ('on +T / 'off +nil) switchlists ; switchlists: 'defn +(set '!*defn #1) ; PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.21 timop: ('* +times / '/ +quotient) ; plusop: ('+ +plus2 / '- +difference) ; relop: ('< +lessp / '<= +lep / '= +equal / '>= +gep / '> +greaterp) ; FIN |
Added psl-1983/3-1/lpt/23-biblio.lpt version [443b521db0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 14 January 1983 Bibliography section 23.0 page 23.1 CHAPTER 23 CHAPTER 23 CHAPTER 23 BIBLIOGRAPHY BIBLIOGRAPHY BIBLIOGRAPHY The following books and articles either are directly referred to in the manual text, or will be helpful for supplementary reading. [Allen 79] Allen, J. R. ___ _______ __ ____ The Anatomy of LISP. McGraw-Hill, New York, New York, 1979. [Baker 78] Baker, H. G. Shallow Binding in LISP 1.5. ____ CACM 21(7):565, July, 1978. [Benson 81] Benson, E. and Griss, M. L. _______ _ ________ ____ _____ _______ ______________ SYSLISP: A Portable LISP Based Systems Implementation ________ Language. Utah Symbolic Computation Group Report UCP-81, University of Utah, Department of Computer Science, February, 1981. [Bobrow 76] Bobrow, R. J.; Burton, R. R.; Jacobs, J. M.; and Lewis, D. ___ ____ ______ _______ UCI LISP MANUAL (revised). Online Manual RS:UCLSP.MAN, University of California, Irvine, ??, 1976. [Charniak 80] Charniak, E.; Riesbeck, C. K.; and McDermott, D. V. __________ ____________ ___________ Artificial Intelligence Programming. Lawrence Erlbaum Associates, Hillsdale, New Jersey, 1980. [Fitch 77] Fitch, J. and Norman, A. Implementing LISP in a High Level Language. ________ ________ ___ __________ Software: Practise and Experience 7:713-xx, 1977. [Foderaro 81] Foderaro, J. K. and Sklower, K. L. ___ _____ ____ ______ The Franz LISP Manual 1981. [Frick 78] Frick, I. B. ______ ___ ________ ____ __ ___ _________ __ ___ __ Manual for Standard LISP on the DECSYSTEM 10 and 20. Utah Symbolic Computation Group Technical Report TR-2, University of Utah, Department of Computer Science, July, 1978. [Griss 77a] Griss, M. L. ___ _ ________ ______________ ________ ___ ____ ____ BIL: A Portable Implementation Language for LISP-Like _______ Systems. Utah Symbolic Computation Group Opnote No. 36, University of Utah, Department of Computer Science, 1977. Bibliography 14 January 1983 PSL Manual page 23.2 section 23.0 [Griss 77b] Griss, M. L. and Swanson, M. R. MBALM/1700 : A Micro-coded LISP Machine for the Burroughs B1726. ___________ __ _____ __ ___ In Proceedings of Micro-10 ACM, pages 15. ACM, 1977. [Griss 78a] Griss, M. L. and Kessler, R. R. REDUCE 1700: A Micro-coded Algebra System. ___________ __ ___ ____ ______ ________________ In Proceedings of The 11th Annual Microprogramming ________ Workshop, pages 130-138. IEEE, November, 1978. [Griss 78b] Griss, M. L. _____ ___ _ ________ ____ ___________ MBALM/BIL: A Portable LISP Interpreter. Utah Symbolic Computation Group Opnote No. 38, University of Utah, Department of Computer Science, 1978. [Griss 79a] 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. [Griss 79b] Griss, M. L. and Kessler, R. R. _ _______________ ______________ __ ____ ___ ______ __ ___ A Microprogrammed Implementation of LISP and REDUCE on the _________ _____ _____ ________ Burroughs B1700/B1800 Computer. Utah Symbolic Computation Group Report UCP 70, University of Utah, Department of Computer Science, 1979. [Griss 81] Griss, M. L. and Hearn, A. C. A Portable LISP Compiler. ________ ________ ___ __________ Software - Practice and Experience 11:541-605, June, 1981. [Griss 82] Griss, M. L.; Benson. E.; and Hearn, A. C. Current Status of a Portable LISP Compiler. ___________ __ ___ _______ ____ _________ __ ________ In Proceedings of the SIGPLAN 1982 Symposium on Compiler ____________ Construction, pages 276-283. ACM SIGPLAN, June, 1982. Also: Utah Symbolic Computation Group, Report UCP-82. [Harrison 73] Harrison, M. C. ____ __________ ___ ___________ Data structures and Programming. Scott, Foresman and Company, Glenview, Illinois, 1973. [Harrison 74] Harrison, M. C. A Language Oriented Instruction Set for BALM. ___________ __ _______ ________ _ In Proceedings of SIGPLAN/SIGMICRO 9, pages 161. ACM, 1974. [Hearn 66] Hearn, A. C. Standard LISP. _______ _______ _______ SIGPLAN Notices Notices 4(9):xx, September, 1966. Also Published in SIGSAM Bulletin, ACM Vol. 13, 1969, p. 28-49. . PSL Manual 14 January 1983 Bibliography section 23.0 page 23.3 [Hearn 73] Hearn, A. C. ______ _ _____ ______ REDUCE 2 Users Manual. Utah Symbolic Computation Group Report UCP-19, University of Utah, Department of Computer Science, 1973. [Kessler 79] Kessler, R. R. _____ _______ ________ ____ ______ PMETA - Pattern Matching META/REDUCE. Utah Symbolic Computation Group Opnote No. 40, University of Utah, Department of Computer Science, January, 1979. [Lefaivre 78] Lefaivre, R. _______ ___ ____ ______ RUTGERS/UCI LISP MANUAL. Online Manual, RS:RUTLSP.MAN, Rutgers University, Computer Science Department, May, 1978. [LISP360 xx] xx. ____ ___ _________ ______ LISP/360 Reference Manual. Technical Report, Stanford Centre for Information Processing, Stanford University, xx. [MACLISP 76] xx. _______ _________ ______ MACLISP Reference Manual. Technical Report, MIT, March, 1976. [Marti 79] Marti, J. B., et al. Standard LISP Report. _______ _______ SIGPLAN Notices 14(10):48-68, October, 1979. [McCarthy 73] McCarthy, J. C. et al. ____ _ _ __________ _ ______ LISP 1.5 Programmer's Manual. M.I.T. Press, 1973. 7th Printing January 1973. [Moore 76] J. Strother Moore II. ___ _________ _______ _______ _____________ The INTERLISP Virtual Machine Specification. CSL 76-5, Xerox, Palo Alto Research Center, 3333 Coyote Road,etc, September, 1976. [Nordstrom 73] Nordstrom, M. _ _______ _________ A Parsing Technique. Utah Computational Physics Group Opnote No. 12, University of Utah, Department of Computer Science, November, 1973. [Nordstrom 78] Nordstrom, M.; Sandewall, E.; and Breslaw, D. ____ __ _ _______ ______________ __ _________ LISP F3 : A FORTRAN Implementation of InterLISP. Manual, Datalogilaboratoriet, Sturegatan 2 B, S 752 23, Uppsala, SWEDEN, 1978. Mentioned by M. Nordstrom in 'Short Announcement of LISP F3', a handout at LISP80. Bibliography 14 January 1983 PSL Manual page 23.4 section 23.0 [Norman 81] Norman, A.C. and Morrison, D. F. ___ ______ _________ _______ The REDUCE Debugging Package. Utah Symbolic Computation Group Opnote No. 49, University of Utah, Department of Computer Science, February, 1981. [Pratt 73] Pratt, V. Top Down Operator Precedence. ___________ __ ____ _ In Proceedings of POPL-1, pages ??-??. ACM, 1973. [Quam 69] Quam, L. H. and Diffie, W. ________ ____ _ _ ______ Stanford LISP 1.6 Manual. Operating Note 28.7, Stanford Artificial Intelligence Laboratory, 1969. [Sandewall 78] Sandewall, E. Programming in an Interactive Environment : The LISP Experience. _________ _______ Computing Surveys 10(1):35-72, March, 1978. [Steele 81] Steele, G. L. and Fahlman, S. E. _____ ____ _________ ______ Spice LISP Reference Manual. Manual , Carnegie-Mellon University, Pittsburgh, September, 1981. (Preliminary Common LISP Report). [Teitelman 78] Teitelman, W.; et al. _________ _________ ______ ___ ________ Interlisp Reference Manual, (3rd Revision). Xerox Palo Alto Research Center, 3333 Coyote Hill Road, Palo Alto,Calif. 94304, 1978. [Teitelman 81] Teitleman, W. and Masinter, L. The InterLISP Programming Environment. ____ ________ IEEE Computer 14(4):25-34, 1981. [Terashima 78] Terashima, M. and Goto, E. Genetic Order and Compactifying Garbage Collectors. ___________ __________ _______ Information Processing Letters 7(1):27-32, 1978. [Weinreb 81] Weinreb, D. and Moon, D. ____ _______ ______ LISP Machine Manual 1981. Fourth edition. [Weissman 67] Weissman. ____ _ _ ______ LISP 1.5 Primer. Dickenson Publishing Company, Inc., 1967. [Winston 81] Winston, P. H., and Horn, B. K. P. ____ LISP. Addison-Wesley Publishing Company, Reading, Mass., 1981. |
Added psl-1983/3-1/lpt/24-top-index.lpt version [d1ee5e9ee0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Concept Index section 24.0 page 24.1 CHAPTER 24 CHAPTER 24 CHAPTER 24 INDEX OF CONCEPTS INDEX OF CONCEPTS INDEX OF CONCEPTS The following is an alphabetical list of concepts, with the page on which they are discussed. << >> . . . . . . . . . . . . 3.4 A-Lists . . . . . . . . . . . 4.4, 7.8, 7.10 Absolute Value. . . . . . . . 5.2 Abstract Machines . . . . . . 18.15 Access to Value Cell. . . . . 18.5 Addition. . . . . . . . . . . 5.2 Addressing Modes. . . . . . . 18.10 Allocation Functions. . . . . 21.8 Allocation. . . . . . . . . . 18.22 Always. . . . . . . . . . . . 9.8 And function. . . . . . . . . 4.8 And . . . . . . . . . . . . . 9.8 Any -catchall data type . . . 4.3 ANYREG Functions. . . . . . . 18.18 Apollo LAP. . . . . . . . . . 18.10 Appending Lists . . . . . . . 7.6 Arc cosecant function . . . . 5.13 Arc cosine function . . . . . 5.12 Arc cotangent function. . . . 5.12 Arc secant function . . . . . 5.13 Arc sine function . . . . . . 5.11 Arc tangent function. . . . . 5.12 Arguments . . . . . . . . . . 2.9, 10.7 Arithmetic. . . . . . . . . . 5.2 Arrays. . . . . . . . . . . . 8.7 As, (proposed iteration construct . . . . . . . . . . . . . . . . . 9.13 ASCII . . . . . . . . . . . . 12.1, 12.6, 12.13 Assigning Precedence. . . . . 22.7 Assignment. . . . . . . . . . 6.7 Association list. . . . . . . 4.5 Association lists . . . . . . 7.8, 7.10 Atom. . . . . . . . . . . . . 4.7 Atoms . . . . . . . . . . . . 4.3 Auto-load . . . . . . . . . . 2.4 Automatic Tracing . . . . . . 15.9 Back Quote. . . . . . . . . . 17.12 Back Trace Functions. . . . . 15.4 Backtrace . . . . . . . . . . 15.10 Backup Buffer . . . . . . . . 12.13 Big Integers. . . . . . . . . 5.1 BigNum. . . . . . . . . . . . 4.1, 5.1 Binary Infix Operators. . . . 22.2 Concept Index 7 February 1983 PSL Manual page 24.2 section 24.0 Binary Operators. . . . . . . 22.6 Binary Trees. . . . . . . . . 7.1 Binary. . . . . . . . . . . . 12.14 Binding Type. . . . . . . . . 10.8, 10.9 Binding . . . . . . . . . . . 6.7, 10.7, 10.10 Bit Field Operation . . . . . 20.7 Bit Operations. . . . . . . . 5.7 BNF . . . . . . . . . . . . . 22.10, 22.17 Boolean Functions . . . . . . 4.8 Boolean . . . . . . . . . . . 4.7, 5.5 Booleans. . . . . . . . . . . 4.3 Box Diagrams. . . . . . . . . 7.1 Break Commands. . . . . . . . 14.4 Break Loop. . . . . . . . . . 13.8, 14.1, 14.4, 14.8 Buffers in EMODE. . . . . . . 16.5 Bugs. . . . . . . . . . . . . 2.3, 2.10 Building A-Lists. . . . . . . 7.10 Building LAP. . . . . . . . . 21.5 Building PSL. . . . . . . . . 21.2 Built-In Functions. . . . . . 18.18 Byte-Vector . . . . . . . . . 4.1, 8.5 Car Manipulation. . . . . . . 7.2 Case Statement. . . . . . . . 9.3, 20.5 Catch . . . . . . . . . . . . 14.1, 14.8 Cdr Manipulation. . . . . . . 7.2 CGOL. . . . . . . . . . . . . 22.2 Channels. . . . . . . . . . . 12.1, 12.6 Char and IDLOC Macros . . . . 20.4 Characters. . . . . . . . . . 4.3 Circular Functions. . . . . . 5.8 Circular Structures . . . . . 15.13, 17.25 Classes of Data Types . . . . 4.3 Classes of Functions. . . . . 18.18 Closing Functions . . . . . . 12.1 Closure . . . . . . . . . . . 10.10 Cmacros . . . . . . . . . . . 18.15 Code Generation . . . . . . . 18.15 Code-Pointer. . . . . . . . . 4.1, 4.7, 10.1, 10.6, 12.13 Collect . . . . . . . . . . . 9.8 Comments. . . . . . . . . . . 22.4 Common Lisp . . . . . . . . . 8.7 Compacting G. C.. . . . . . . 21.5 Comparison. . . . . . . . . . 17.22 Compilation . . . . . . . . . 2.8, 10.7, 18.7 Compiled Functions. . . . . . 10.6 Compiled vs. Interpreted. . . 18.7 Compiler Second Pass. . . . . 18.15 Compiler Third Pass . . . . . 18.22 Compiler. . . . . . . . . . . 18.1 Compiling Functions . . . . . 18.2 Compiling SYSLISP Code. . . . 20.9 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.3 Compiling to FASL Files . . . 18.2 Compiling to Memory . . . . . 18.2 Composites of Car and Cdr . . 7.2 Compound Statements . . . . . 3.7 Conc. . . . . . . . . . . . . 9.8 Concatenating Lists . . . . . 7.6 Cond. . . . . . . . . . . . . 9.4 Conditional Statements. . . . 3.8 Conditionals. . . . . . . . . 9.1 Constant. . . . . . . . . . . 4.7 Constants . . . . . . . . . . 4.3 Construction Function . . . . 22.2 Construction of MINI. . . . . 22.15 Continuing After Errors . . . 14.1 Control Time of Execution . . 18.4 Converting Data Types . . . . 4.9, 5.1 Copying Functions . . . . . . 10.2 Copying Strings . . . . . . . 8.1 Copying Vectors . . . . . . . 8.3 Copying X-Vectors . . . . . . 8.5 Copying . . . . . . . . . . . 7.2 Cosecant function . . . . . . 5.11 Cosine function . . . . . . . 5.10 Cotangent function. . . . . . 5.11 Count . . . . . . . . . . . . 9.8 Counting Function Calls . . . 15.11 CREF. . . . . . . . . . . . . 17.1 Cross Reference Generator . . 17.1 Customizing Debug . . . . . . 15.14 Data Type Conversion. . . . . 4.9, 5.1 Data Types. . . . . . . . . . 4.1, 12.6, 12.13 Debug and Redefinition. . . . 15.4 Debug Deficiencies. . . . . . 15.4 Debug Example . . . . . . . . 15.16 Debug Printing Functions. . . 15.15 Debug Reading Functions . . . 15.15 Debugging Tools . . . . . . . 15.1 Dec-20 LAP. . . . . . . . . . 18.10 DEC-20 PSL. . . . . . . . . . 21.2, 21.5 Decimal Output. . . . . . . . 12.6 Declaration . . . . . . . . . 10.7, 10.8 Default Top Level . . . . . . 13.3 DefConst. . . . . . . . . . . 17.22 Deficiencies in Debug . . . . 15.4 DefMacro. . . . . . . . . . . 17.12 Deletion from lists . . . . . 7.8 Delimiters. . . . . . . . . . 12.6, 12.13 Details of the Compiler . . . 18.14 Digits. . . . . . . . . . . . 12.13 Diphthong Indicator . . . . . 12.17 Diphthong . . . . . . . . . . 12.25 Concept Index 7 February 1983 PSL Manual page 24.4 section 24.0 Division. . . . . . . . . . . 5.2 Do. . . . . . . . . . . . . . 9.8 Dot Notation. . . . . . . . . 3.6, 7.1 Dot-notation. . . . . . . . . 4.2 Each. . . . . . . . . . . . . 9.13 Edit Commands . . . . . . . . 16.1, 16.7 Editing in the Break Loop . . 14.4, 16.1 Editing with EMODE. . . . . . 16.3 Editor. . . . . . . . . . . . 16.1 Elementary Functions. . . . . 5.8 EMB Functions . . . . . . . . 15.4 Embedded Functions. . . . . . 15.11 EMODE . . . . . . . . . . . . 16.3 Enabling debug facilities . . 15.9 End of file . . . . . . . . . 12.2 End of line . . . . . . . . . 12.2 Environment . . . . . . . . . 10.10 EOF . . . . . . . . . . . . . 12.2 EOL . . . . . . . . . . . . . 12.2 Equality testing functions. . 4.5 Error Calls . . . . . . . . . 14.8 Error Functions . . . . . . . 14.1 Error Handling in MINI. . . . 22.13 Error Handling. . . . . . . . 14.1, 22.7 Error Messages. . . . . . . . 2.8, 12.6 Error Number. . . . . . . . . 14.1 Error Recovery in MINI. . . . 22.13 Errors. . . . . . . . . . . . 2.8, 2.10, 10.9 Escaped Characters. . . . . . 22.7 Eval flag . . . . . . . . . . 6.16 Eval Type Functions . . . . . 2.9 Evaluation. . . . . . . . . . 11.1 Example of MINI . . . . . . . 22.12 Examples. . . . . . . . . . . 2.5, 3.2, 3.3, 14.4, 15.16, 17.18, 18.10, 20.9, 22.6, 22.8 Exclamation Point in RLISP. . 22.7 Executable. . . . . . . . . . 13.1 Exit. . . . . . . . . . . . . 9.1, 9.17 Explicit Sequence Control . . 9.4 Exponent. . . . . . . . . . . 4.1 Exponential Functions . . . . 5.8 Exponentiation. . . . . . . . 5.2 Expr. . . . . . . . . . . . . 2.9, 10.7 Extend CREF for SYSLISP . . . 20.12 Extensible Parser . . . . . . 22.1 External Form . . . . . . . . 22.4 Extra-Booleans. . . . . . . . 4.3 Factorial function. . . . . . 5.14 FASL. . . . . . . . . . . . . 12.14 Fexpr . . . . . . . . . . . . 2.9, 10.7 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.5 Field . . . . . . . . . . . . 4.1 File Input. . . . . . . . . . 12.14 File Names. . . . . . . . . . 12.4, 12.14 File Output . . . . . . . . . 12.14 Filename Conventions. . . . . 12.14 Files about MINI. . . . . . . 22.15 Finally . . . . . . . . . . . 9.8 Find. . . . . . . . . . . . . 6.4 FixNum. . . . . . . . . . . . 4.1 Flag indicators . . . . . . . 6.16 Flagging Ids. . . . . . . . . 6.6 Flags . . . . . . . . . . . . 6.4, 6.6 Float . . . . . . . . . . . . 4.1, 4.7, 12.13 Floats. . . . . . . . . . . . 5.1 Fluid Binding . . . . . . . . 10.7, 10.10 Fluid Declarations. . . . . . 18.5 For . . . . . . . . . . . . . 9.8 Form Oriented Editor. . . . . 16.5 Form. . . . . . . . . . . . . 4.4 Format. . . . . . . . . . . . 12.6, 12.13, 12.25 Formatted Printing. . . . . . 12.6 From. . . . . . . . . . . . . 9.8 FType . . . . . . . . . . . . 4.3 Funarg. . . . . . . . . . . . 10.10 Function Calls. . . . . . . . 22.4 Function Cell . . . . . . . . 6.2, 11.1 Function definition . . . . . 3.3, 3.6, 10.1 Function Execution Tracing. . 15.5 Function Order. . . . . . . . 18.5 Function Redefinition . . . . 2.8, 15.4 Function types. . . . . . . . 2.9, 10.7 Function. . . . . . . . . . . 4.4 Garbage Collector . . . . . . 21.5 GC. . . . . . . . . . . . . . 21.5 Generator . . . . . . . . . . 22.17 Global Binding. . . . . . . . 10.7 Global Declarations . . . . . 18.5 Global Variables. . . . . . . 3.10 Globals . . . . . . . . . . . 2.10, 6.10, 6.16 Go. . . . . . . . . . . . . . 9.1 Graph-to-Tree . . . . . . . . 17.25 Halfword-Vector . . . . . . . 4.1, 8.5 Handlers. . . . . . . . . . . 12.4 Hash table. . . . . . . . . . 17.24 Hashing Cons. . . . . . . . . 17.24 Heap. . . . . . . . . . . . . 4.1, 21.6 Help. . . . . . . . . . . . . 2.4, 6.16, 13.7 Hexadecimal Output. . . . . . 12.6 History Mechanism . . . . . . 2.4, 13.4 History of MINI . . . . . . . 22.16 Concept Index 7 February 1983 PSL Manual page 24.6 section 24.0 Hook. . . . . . . . . . . . . 6.2 I/O Buffer. . . . . . . . . . 12.13 I/O . . . . . . . . . . . . . 12.25 Id hash table . . . . . . . . 6.2, 6.4, 6.10 Id Space. . . . . . . . . . . 4.1, 6.2 Id-Hash-Table . . . . . . . . 13.7 Id. . . . . . . . . . . . . . 4.1, 4.7, 4.9, 6.1, 12.13 Identifier. . . . . . . . . . 4.1, 4.7, 4.9, 6.1, 12.13 If Then Construct . . . . . . 9.1 If Then Statements. . . . . . 3.8 Ignore flag . . . . . . . . . 6.16 Implementation. . . . . . . . 21.1 In. . . . . . . . . . . . . . 9.8 Indexing vectors and strings . . . . . . . . . . . . . . . . . . . 8.1 Indicator, on property list . 6.4 Infix Operators . . . . . . . 3.4, 22.4 Init Files. . . . . . . . . . 13.3 Initially . . . . . . . . . . 9.8 Input Functions . . . . . . . 12.13 Input in Files. . . . . . . . 12.14 Input . . . . . . . . . . . . 3.10, 12.1, 22.2 Integer . . . . . . . . . . . 4.1, 4.7, 4.9, 12.13 Integers. . . . . . . . . . . 5.1 INTERLISP . . . . . . . . . . 16.5 Intern. . . . . . . . . . . . 4.9, 6.2, 6.10 InternalForm. . . . . . . . . 22.4 Internals in Debug. . . . . . 15.14 Interpretation. . . . . . . . 2.8, 18.7 Interpreted Functions . . . . 10.6, 10.9 Interpreter . . . . . . . . . 11.1 Interrupt Keys. . . . . . . . 14.8 Inum. . . . . . . . . . . . . 4.1, 4.9 Inverse Circular Functions. . 5.11 Inverse Trigonometric Functions . . . . . . . . . . . . . . . . . . 5.11 Item. . . . . . . . . . . . . 4.1 Iteration . . . . . . . . . . 9.6 Join. . . . . . . . . . . . . 9.8 Key Words . . . . . . . . . . 22.7 Lambda. . . . . . . . . . . . 4.4, 10.7, 10.9, 11.5 LAP Format. . . . . . . . . . 18.10 Lap Switches. . . . . . . . . 18.13 LAP-to-ASM for Apollo . . . . 18.9 LAP . . . . . . . . . . . . . 21.5 Length. . . . . . . . . . . . 7.6 Letter as Token Type. . . . . 12.13 Line feed . . . . . . . . . . 12.2 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.7 LISP Surface Language . . . . 22.2 Lisp syntax . . . . . . . . . 12.18, 12.21 LISP, compared with RLISP . . 3.3 List Concatenation. . . . . . 7.6 List Element Deletion . . . . 7.8 List Element Selection. . . . 7.4 List IO . . . . . . . . . . . 12.25 List Length . . . . . . . . . 7.6 List Manipulation . . . . . . 7.4 List Membership Functions . . 7.6 List Notation Reader. . . . . 22.12 List Notation . . . . . . . . 7.1 List Reversal . . . . . . . . 7.9 List Substitutions. . . . . . 7.11 List-notation . . . . . . . . 4.4 List. . . . . . . . . . . . . 4.4, 4.9, 6.4, 7.1 Loader. . . . . . . . . . . . 18.9 Loading FASL Files. . . . . . 18.3 Local Binding . . . . . . . . 10.7 Local Variables . . . . . . . 3.7 Logarithms. . . . . . . . . . 5.8 Logical And . . . . . . . . . 5.7 Logical Devices for PSL . . . 2.1, 21.1 Logical Exclusive Or. . . . . 5.7 Logical Not . . . . . . . . . 5.7 Logical Or. . . . . . . . . . 5.7 Looping Constructs. . . . . . 9.6 Loops . . . . . . . . . . . . 3.8, 3.9 Lose flag . . . . . . . . . . 6.16 Machine Instructions. . . . . 18.15 Macro Defining Tools. . . . . 17.11 Macro Expand. . . . . . . . . 17.14 Macro . . . . . . . . . . . . 2.9, 10.7, 11.7 Mapping Functions . . . . . . 9.13 Mathematical Functions. . . . 5.8 MaxChannels . . . . . . . . . 12.1 Maximize. . . . . . . . . . . 9.8 Memory Access Operations. . . 20.7 Memory Address Operations . . 20.7 Messages. . . . . . . . . . . 2.8 Meta Compiler . . . . . . . . 22.1 MINI Development. . . . . . . 22.16 MINI Error Handling . . . . . 22.13 MINI Error Recovery . . . . . 22.13 MINI Example. . . . . . . . . 22.12 MINI Operators. . . . . . . . 22.10 MINI Self-Definition. . . . . 22.13 Mini Trace. . . . . . . . . . 15.2 MINI. . . . . . . . . . . . . 22.10 Minimize. . . . . . . . . . . 9.8 Minus as Token Type . . . . . 12.13 Concept Index 7 February 1983 PSL Manual page 24.8 section 24.0 Mode Analysis Functions . . . 20.3 Modified FOR Loop . . . . . . 20.4 Modules . . . . . . . . . . . 2.4 Modulo function . . . . . . . 5.9 Multiplication. . . . . . . . 5.2 N-ary Expressions . . . . . . 22.6 N-ary Functions . . . . . . . 3.3 Need for Two Stacks . . . . . 20.12 Never . . . . . . . . . . . . 9.8 New Mode System . . . . . . . 20.12 Newline . . . . . . . . . . . 12.2 Nexpr . . . . . . . . . . . . 2.9, 10.7 Next. . . . . . . . . . . . . 9.1 NIL . . . . . . . . . . . . . 4.7, 4.8, 6.15 NoEval Type Functions . . . . 2.9 Non-Local Exit. . . . . . . . 9.17 None Returned . . . . . . . . 4.3 NoSpread Type Functions . . . 2.9 Not function. . . . . . . . . 4.8 Not . . . . . . . . . . . . . 9.8 Notation. . . . . . . . . . . 4.1 Number. . . . . . . . . . . . 4.7, 4.9, 12.13 Numbers . . . . . . . . . . . 4.3, 5.1 Numeric Comparison. . . . . . 5.5 Object list . . . . . . . . . 6.2 Oblist. . . . . . . . . . . . 6.2, 6.4 Octal Output. . . . . . . . . 12.6 OFF command . . . . . . . . . 3.10, 6.14 Oload . . . . . . . . . . . . 19.14 ON command. . . . . . . . . . 3.10, 6.14 On. . . . . . . . . . . . . . 9.8 Open Coding . . . . . . . . . 18.7 OPEN Functions. . . . . . . . 18.18 Operator Definition . . . . . 22.8 Operator Precedence . . . . . 3.4 Operators . . . . . . . . . . 22.2 Optimizations . . . . . . . . 18.22 Optional Modules. . . . . . . 2.4 Or function . . . . . . . . . 4.8 Or. . . . . . . . . . . . . . 9.8 Order of Functions. . . . . . 18.5 Output Base . . . . . . . . . 12.6 Output. . . . . . . . . . . . 3.10, 12.1 OutPutBase!*. . . . . . . . . 12.6 Overflow. . . . . . . . . . . 12.25 Package Cell. . . . . . . . . 6.2 Package . . . . . . . . . . . 6.2, 6.10 Pair Construction . . . . . . 7.2 Pair hash table . . . . . . . 17.24 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.9 Pair Manipulation . . . . . . 7.2 Pair. . . . . . . . . . . . . 4.1, 4.4, 4.7, 7.1 Pairs . . . . . . . . . . . . 7.1 Parameters. . . . . . . . . . 2.9, 10.7 Parentheses . . . . . . . . . 22.5 Parse function. . . . . . . . 3.6 Parser Flow Diagram . . . . . 22.2 Parser Generator. . . . . . . 22.1 Parser. . . . . . . . . . . . 12.13 Parsers . . . . . . . . . . . 22.1 Parsing Precedence. . . . . . 22.2 PASS1 of Compiler . . . . . . 18.14 Pattern Matcher . . . . . . . 22.12 Pattern Matching in MINI. . . 22.12 Picture RLISP . . . . . . . . 17.4 Plus as Token Type. . . . . . 12.13 Precedence Table. . . . . . . 22.2 Precedence. . . . . . . . . . 3.4, 22.5 Predicates. . . . . . . . . . 4.5, 5.5, 7.6, 10.6, 10.7, 10.9 Print Name. . . . . . . . . . 6.2, 22.7 Printing Circular Lists . . . 15.13, 17.25 Printing Circular Vectors . . 17.25 Printing Functions. . . . . . 15.12 Printing Property Lists . . . 15.12 Printing Registers. . . . . . 12.6 Printing. . . . . . . . . . . 12.6 PRLISP. . . . . . . . . . . . 17.4 Procedure definition. . . . . 3.3, 3.6 Product . . . . . . . . . . . 9.8 Productions . . . . . . . . . 22.10 Prog. . . . . . . . . . . . . 3.7, 9.4, 10.7, 10.9 Progn . . . . . . . . . . . . 3.7, 9.4 Properties. . . . . . . . . . 6.4 Property Cell Access. . . . . 6.7 Property Cell . . . . . . . . 6.2, 6.4 Property List . . . . . . . . 6.2, 6.4, 6.15, 22.4 Pseudos . . . . . . . . . . . 18.10 PSL Files . . . . . . . . . . 21.1 PSL Sample Session. . . . . . 2.5 Put Indicators. . . . . . . . 6.15 Quote Mark in RLISP . . . . . 22.7 Quote Mark. . . . . . . . . . 22.4 Radix for I/O . . . . . . . . 12.13 Random Functions. . . . . . . 18.18 Random Numbers. . . . . . . . 5.8 RCREF . . . . . . . . . . . . 17.1 Read function . . . . . . . . 3.6 Read macro indicator. . . . . 12.17 Read Macros . . . . . . . . . 12.24, 12.25 Read. . . . . . . . . . . . . 22.2 Concept Index 7 February 1983 PSL Manual page 24.10 section 24.0 Reading Functions . . . . . . 12.1, 12.13 Recognizer. . . . . . . . . . 22.17 Reduce. . . . . . . . . . . . 3.1 Register and Tracing. . . . . 15.4 Registers . . . . . . . . . . 12.6 Remainder function. . . . . . 5.2 Remaining SYSLISP Issues. . . 20.11 Removing Functions. . . . . . 10.2 Return. . . . . . . . . . . . 9.1 Returns . . . . . . . . . . . 9.8 Reversal of lists . . . . . . 7.9 Right Precedence. . . . . . . 22.2 RLISP Commands. . . . . . . . 13.8 RLISP Input . . . . . . . . . 3.10 RLISP Output. . . . . . . . . 3.10 RLISP Parser. . . . . . . . . 22.7 RLISP Syntax. . . . . . . . . 3.2, 12.18 RLISP to LISP Translation . . 22.17 RLISP to LISP Using MINI. . . 22.17 RLISP, compared with LISP . . 3.3 RLISP, compared with SYSLISP. . . . . . . . . . . . . . . . . . . . 20.2 RLISP . . . . . . . . . . . . 3.1 Running MINI. . . . . . . . . 22.13 S-expression. . . . . . . . . 12.13 S-Expressions . . . . . . . . 4.3 S-Integer . . . . . . . . . . 4.9 Saving Executable PSL . . . . 13.1 Saving Trace Output . . . . . 15.6 Scalar. . . . . . . . . . . . 3.4, 3.7, 3.9 Scan Table. . . . . . . . . . 12.13, 12.17, 12.25, 13.4, 22.4 Scope of Variables. . . . . . 10.7 Screen Editor . . . . . . . . 16.3 Searching A-Lists . . . . . . 7.10 Secant function . . . . . . . 5.11 Selective Trace . . . . . . . 15.7 Sequence of Evaluation. . . . 9.4 Set Functions . . . . . . . . 7.7 Sharp-Sign Macros . . . . . . 17.13 Side Effects. . . . . . . . . 18.18 Sine function . . . . . . . . 5.10 Skip to Top of Page . . . . . 12.6 Sorting . . . . . . . . . . . 17.22 Special Error Handlers. . . . 14.10 Special I/O Functions . . . . 12.4 Spread Type Functions . . . . 2.9 Square Root function. . . . . 5.13 Stable Functions. . . . . . . 18.18 Stack . . . . . . . . . . . . 17.14 Stand Alone SYSLISP . . . . . 20.11 Starting MINI . . . . . . . . 22.12 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.11 Starting PSL. . . . . . . . . 2.1, 2.3, 26.i Statistics Functions. . . . . 15.4 Stop and Copy on VAX. . . . . 21.6 Stopping PSL. . . . . . . . . 13.1 String IO . . . . . . . . . . 12.25 String Operations . . . . . . 8.1 String Quotes . . . . . . . . 12.13 String. . . . . . . . . . . . 4.1, 4.7, 4.9, 12.13 Structural Notes: Compiler. . 18.23 Structure Definition. . . . . 17.15 Structure Editor. . . . . . . 16.5 Structure . . . . . . . . . . 4.4 Stubs . . . . . . . . . . . . 15.12 Substitutions . . . . . . . . 7.11 Substring Matching. . . . . . 6.4 Subtraction . . . . . . . . . 5.2 Sum . . . . . . . . . . . . . 9.8 Switches Controlling Compiler . . . . . . . . . . . . . . . . . . . 18.6 Switches. . . . . . . . . . . 2.10, 3.10, 6.14, 6.16 SYSLISP Arguments . . . . . . 12.6 SYSLISP Declarations. . . . . 20.2 SYSLISP Functions . . . . . . 20.10 SYSLISP Level of PSL. . . . . 20.1 SYSLISP Mode Analysis . . . . 20.3 SYSLISP Programs. . . . . . . 20.11 SYSLISP, compared with RLISP. . . . . . . . . . . . . . . . . . . . 20.2 System Dependent Functions. . 19.1 T . . . . . . . . . . . . . . 6.15 Table Driven Parser . . . . . 22.2 Tag Field . . . . . . . . . . 4.1 Tagging Information . . . . . 18.15 Tangent function. . . . . . . 5.10 Template and Replacement. . . 22.12 Terminal Interaction. . . . . 13.8 Throw . . . . . . . . . . . . 14.1, 14.10 Time Control Functions. . . . 18.4 Token scanner . . . . . . . . 12.13 Tokens. . . . . . . . . . . . 22.2 Top Level Function. . . . . . 13.3 Top Loop Mechanism. . . . . . 14.8 Top Loop. . . . . . . . . . . 13.4 Trace Output. . . . . . . . . 15.6 Trace ring buffer . . . . . . 15.6 Trace . . . . . . . . . . . . 15.4 Tracing Functions . . . . . . 2.4, 15.2, 15.5 Tracing Macros. . . . . . . . 15.4 Tracing New Functions . . . . 15.9 Transcendental Functions. . . 5.8 Trees . . . . . . . . . . . . 22.10 Concept Index 7 February 1983 PSL Manual page 24.12 section 24.0 Trigonometric Functions . . . 5.8 Truth and falsity . . . . . . 4.8 Turning Off Trace . . . . . . 15.8 Type Checking Functions . . . 4.7 Type Conversion . . . . . . . 4.9, 5.1 Type Declarations . . . . . . 4.1 Type Field. . . . . . . . . . 4.1 Type Mismatch . . . . . . . . 12.25 UCI LISP. . . . . . . . . . . 16.5 Unary Functions . . . . . . . 3.3, 5.2 Unary Prefix Operators. . . . 22.2 Undefined . . . . . . . . . . 4.3 Union . . . . . . . . . . . . 9.8 Unix interface functions. . . 19.14 Unless. . . . . . . . . . . . 9.8 Until . . . . . . . . . . . . 9.8 Untraceable Functions . . . . 15.4 User flag . . . . . . . . . . 6.16 User Function Redefinition. . 15.4 User Hooks in Debug . . . . . 15.14 User Interface. . . . . . . . 13.1 Using SYSLISP . . . . . . . . 20.9 Utility modules . . . . . . . 17.1 Value Cell. . . . . . . . . . 6.2, 6.7, 10.7 Variable Binding. . . . . . . 6.7, 10.7 Vax init files. . . . . . . . 19.11 VAX LAP . . . . . . . . . . . 18.9, 18.10 Vax login files . . . . . . . 19.10 Vax PSL directories . . . . . 19.11 VAX PSL . . . . . . . . . . . 21.6 Vax system interface. . . . . 19.10 Vector Indexing . . . . . . . 8.1 Vector Operations . . . . . . 8.3 Vector. . . . . . . . . . . . 4.1, 4.7, 4.9 Warning Messages. . . . . . . 2.8 When. . . . . . . . . . . . . 9.8 While . . . . . . . . . . . . 9.8 Windows in EMODE. . . . . . . 16.5 With. . . . . . . . . . . . . 9.8 Word Operations . . . . . . . 8.5 Word-Vector . . . . . . . . . 4.1, 8.5 Word. . . . . . . . . . . . . 4.1 Writing Functions . . . . . . 12.1 X-Vector Operations . . . . . 8.5 X-Vector. . . . . . . . . . . 8.1 X-Vectors . . . . . . . . . . 4.3 |
Added psl-1983/3-1/lpt/25-fun-index.lpt version [f1e5362f8f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Function Index section 25.0 page 25.1 CHAPTER 25 CHAPTER 25 CHAPTER 25 INDEX OF FUNCTIONS INDEX OF FUNCTIONS INDEX OF FUNCTIONS The following is an alphabetical list of the PSL functions, with the page on which they are defined. !%Reclaim . . . . . . . . . . expr 21.8 !*DESTROY . . . . . . . . . . cmacro 18.22 !*DO. . . . . . . . . . . . . cmacro 18.22 !*JUMP. . . . . . . . . . . . cmacro 18.22 !*LBL . . . . . . . . . . . . cmacro 18.22 !*LOAD. . . . . . . . . . . . cmacro 18.22 !*SET . . . . . . . . . . . . cmacro 18.22 !*STORE . . . . . . . . . . . cmacro 18.22 \CreatePackage. . . . . . . . expr 6.11 \LocalIntern. . . . . . . . . expr 6.12 \LocalInternP . . . . . . . . expr 6.11 \LocalMapObl. . . . . . . . . expr 6.12 \LocalRemob . . . . . . . . . expr 6.12 \PathIntern . . . . . . . . . expr 6.11 \PathInternP. . . . . . . . . expr 6.11 \PathMapObl . . . . . . . . . expr 6.11 \PathRemob. . . . . . . . . . expr 6.11 \SetPackage . . . . . . . . . expr 6.11 A . . . . . . . . . . . . . . edit 16.7 Abs . . . . . . . . . . . . . expr 5.2 AConc . . . . . . . . . . . . expr 7.7 Acos. . . . . . . . . . . . . expr 5.12 AcosD . . . . . . . . . . . . expr 5.12 Acot. . . . . . . . . . . . . expr 5.12 AcotD . . . . . . . . . . . . expr 5.13 Acsc. . . . . . . . . . . . . expr 5.13 AcscD . . . . . . . . . . . . expr 5.13 Add1. . . . . . . . . . . . . expr 5.2 Adjoin. . . . . . . . . . . . expr 7.7 AdjoinQ . . . . . . . . . . . expr 7.8 AlphaNumericP . . . . . . . . expr 8.8 AlphaP. . . . . . . . . . . . expr 8.8 And . . . . . . . . . . . . . fexpr 4.8 Ans . . . . . . . . . . . . . expr 13.6 AnyId . . . . . . . . . . . . expr 22.10 AnyTok. . . . . . . . . . . . expr 22.10 Append. . . . . . . . . . . . expr 7.6 Apply . . . . . . . . . . . . expr 11.4 ApplyInEnvironment. . . . . . expr 10.10 Asec. . . . . . . . . . . . . expr 5.13 AsecD . . . . . . . . . . . . expr 5.13 Asin. . . . . . . . . . . . . expr 5.11 AsinD . . . . . . . . . . . . expr 5.11 Function Index 7 February 1983 PSL Manual page 25.2 section 25.0 Ass . . . . . . . . . . . . . expr 7.10 Assoc . . . . . . . . . . . . expr 7.10 Atan2 . . . . . . . . . . . . expr 5.12 Atan2D. . . . . . . . . . . . expr 5.12 Atan. . . . . . . . . . . . . expr 5.12 AtanD . . . . . . . . . . . . expr 5.12 Atom. . . . . . . . . . . . . expr 4.7 Atsoc . . . . . . . . . . . . expr 7.10 B . . . . . . . . . . . . . . edit 16.2, 16.7 BackQuote . . . . . . . . . . macro 17.13 BeginRLisp. . . . . . . . . . expr 13.7 BELOW . . . . . . . . . . . . edit 16.8 BF. . . . . . . . . . . . . . edit 16.8 BI. . . . . . . . . . . . . . edit 16.9 BIND. . . . . . . . . . . . . edit 16.9 Bits. . . . . . . . . . . . . macro 19.9 BK. . . . . . . . . . . . . . edit 16.9 BldMsg. . . . . . . . . . . . expr 12.27 BO. . . . . . . . . . . . . . edit 16.9 BothCaseP . . . . . . . . . . expr 8.8 BothTimes . . . . . . . . . . expr 18.4 Btr . . . . . . . . . . . . . macro 15.10 Bug . . . . . . . . . . . . . expr 2.10 Byte. . . . . . . . . . . . . expr 20.11 CaptureEnvironment. . . . . . expr 10.11 Car . . . . . . . . . . . . . expr 7.2 Case. . . . . . . . . . . . . fexpr 9.4 Catch!-All. . . . . . . . . . macro 9.19 Catch . . . . . . . . . . . . fexpr 9.17 Cd. . . . . . . . . . . . . . expr 19.13 Cdr . . . . . . . . . . . . . expr 7.2 Ceiling . . . . . . . . . . . expr 5.8 CHANGE. . . . . . . . . . . . edit 16.9 ChannelEject. . . . . . . . . expr 12.10 ChannelFlush. . . . . . . . . expr 19.17 ChannelLineLength . . . . . . expr 12.11 ChannelLPosn. . . . . . . . . expr 12.11 ChannelPosn . . . . . . . . . expr 12.10 ChannelPrin1. . . . . . . . . expr 12.7 ChannelPrin2. . . . . . . . . expr 12.8 ChannelPrin2T . . . . . . . . expr 12.12 ChannelPrinC. . . . . . . . . expr 12.8 ChannelPrint. . . . . . . . . expr 12.8 ChannelPrintF . . . . . . . . expr 12.9 ChannelRead . . . . . . . . . expr 12.13 ChannelReadCH . . . . . . . . expr 12.16 ChannelReadChar . . . . . . . expr 12.15 ChannelReadToken. . . . . . . expr 12.16 ChannelSpaces . . . . . . . . expr 12.11 ChannelTab. . . . . . . . . . expr 12.12 PSL Manual 7 February 1983 Function Index section 25.0 page 25.3 ChannelTerPri . . . . . . . . expr 12.10 ChannelUnReadChar . . . . . . expr 12.16 ChannelWriteChar. . . . . . . expr 12.6 Char!-Bits. . . . . . . . . . expr 8.9 Char!-Code. . . . . . . . . . expr 8.9 Char!-DownCase. . . . . . . . expr 8.10 Char!-Equal . . . . . . . . . expr 8.9 Char!-Font. . . . . . . . . . expr 8.9 Char!-GreaterP. . . . . . . . expr 8.9 Char!-Int . . . . . . . . . . expr 8.10 Char!-LessP . . . . . . . . . expr 8.9 Char!-UpCase. . . . . . . . . expr 8.10 Char!<. . . . . . . . . . . . expr 8.9 Char!=. . . . . . . . . . . . expr 8.9 Char!>. . . . . . . . . . . . expr 8.9 Char. . . . . . . . . . . . . macro 20.5 Character . . . . . . . . . . expr 8.10 CharsInInputBuffer. . . . . . expr 19.17 ClearBindings . . . . . . . . expr 10.11 Close . . . . . . . . . . . . expr 12.5 Closure . . . . . . . . . . . macro 10.10 Cmds. . . . . . . . . . . . . fexpr 19.2 Code!-Char. . . . . . . . . . expr 8.9 Code!-Number!-Of!-Arguments . expr 10.7 CodeApply . . . . . . . . . . expr 11.6 CodeEvalApply . . . . . . . . expr 11.6 CodeP . . . . . . . . . . . . expr 4.7 CommentOutCode. . . . . . . . macro 18.4 Compile . . . . . . . . . . . expr 18.2 CompileTime . . . . . . . . . expr 18.4 Compress. . . . . . . . . . . expr 12.26 COMS. . . . . . . . . . . . . edit 16.10 COMSQ . . . . . . . . . . . . edit 16.10 Concat. . . . . . . . . . . . expr 8.6 ConcatS . . . . . . . . . . . expr 19.2 Cond. . . . . . . . . . . . . fexpr 9.1 Cons. . . . . . . . . . . . . expr 7.2 Const . . . . . . . . . . . . macro 17.22 ConstantP . . . . . . . . . . expr 4.7 ContError . . . . . . . . . . macro 14.3 ContinuableError. . . . . . . expr 14.3 Copy. . . . . . . . . . . . . expr 7.3 CopyD . . . . . . . . . . . . expr 10.3 CopyScanTable . . . . . . . . expr 12.25 CopyString. . . . . . . . . . expr 8.2 CopyStringToFrom. . . . . . . expr 8.2 CopyVector. . . . . . . . . . expr 8.4 CopyVectorToFrom. . . . . . . expr 8.4 CopyWArray. . . . . . . . . . expr 20.11 CopyWRDS. . . . . . . . . . . expr 20.11 CopyWRDSToFrom. . . . . . . . expr 20.11 Cos . . . . . . . . . . . . . expr 5.10 Function Index 7 February 1983 PSL Manual page 25.4 section 25.0 CosD. . . . . . . . . . . . . expr 5.10 Cot . . . . . . . . . . . . . expr 5.11 CotD. . . . . . . . . . . . . expr 5.11 CPrint. . . . . . . . . . . . expr 17.25 Csc . . . . . . . . . . . . . expr 5.11 CscD. . . . . . . . . . . . . expr 5.11 Date. . . . . . . . . . . . . expr 13.2 De. . . . . . . . . . . . . . macro 10.4 Decr. . . . . . . . . . . . . macro 5.3 DefConst. . . . . . . . . . . macro 17.22 DefLambda . . . . . . . . . . macro 17.14 DefList . . . . . . . . . . . expr 6.5 DefMacro. . . . . . . . . . . macro 17.12 Defstruct . . . . . . . . . . fexpr 17.16 DefstructP. . . . . . . . . . expr 17.15 DefstructType . . . . . . . . expr 17.15 DegreesToDMS. . . . . . . . . expr 5.10 DegreesToRadians. . . . . . . expr 5.9 Del . . . . . . . . . . . . . expr 7.9 DelAsc. . . . . . . . . . . . expr 7.9 DelAscIP. . . . . . . . . . . expr 7.9 DelatQ. . . . . . . . . . . . expr 7.9 DelatQIP. . . . . . . . . . . expr 7.9 DelBps. . . . . . . . . . . . expr 21.9 DELETE. . . . . . . . . . . . edit 16.10 Delete. . . . . . . . . . . . expr 7.8 DeletIP . . . . . . . . . . . expr 7.9 DelQ. . . . . . . . . . . . . expr 7.9 DelQIP. . . . . . . . . . . . expr 7.9 DelWArray . . . . . . . . . . expr 21.9 DeSetQ. . . . . . . . . . . . macro 6.8 Df. . . . . . . . . . . . . . macro 10.4 Difference. . . . . . . . . . expr 5.3 Digit!-Char . . . . . . . . . expr 8.10 Digit . . . . . . . . . . . . expr 12.25 DigitP. . . . . . . . . . . . expr 8.8 Divide. . . . . . . . . . . . expr 5.3 Dm. . . . . . . . . . . . . . macro 10.5 DMStoDegrees. . . . . . . . . expr 5.10 DMStoRadians. . . . . . . . . expr 5.10 Dn. . . . . . . . . . . . . . macro 10.4 Do!*. . . . . . . . . . . . . macro 9.16 Do-Loop!* . . . . . . . . . . macro 9.16 Do-Loop . . . . . . . . . . . macro 9.16 Do. . . . . . . . . . . . . . macro 9.15 DoCmds. . . . . . . . . . . . expr 19.2 Ds. . . . . . . . . . . . . . macro 10.5 DskIn . . . . . . . . . . . . expr 12.14 DumpLisp. . . . . . . . . . . expr 13.2 E . . . . . . . . . . . . . . edit 16.10 PSL Manual 7 February 1983 Function Index section 25.0 page 25.5 EchoOff . . . . . . . . . . . expr 19.17 EchoOn. . . . . . . . . . . . expr 19.17 EditF . . . . . . . . . . . . expr 16.10 EditFns . . . . . . . . . . . fexpr 16.10 EditP . . . . . . . . . . . . fexpr 16.11 EditV . . . . . . . . . . . . fexpr 16.11 Eject . . . . . . . . . . . . expr 12.10 Emacs . . . . . . . . . . . . expr 19.3 EMBED . . . . . . . . . . . . edit 16.11 Eq. . . . . . . . . . . . . . expr 4.5 EqCar . . . . . . . . . . . . expr 4.6 EqN . . . . . . . . . . . . . expr 4.5 EqStr . . . . . . . . . . . . expr 4.6 Equal . . . . . . . . . . . . expr 4.6 Error . . . . . . . . . . . . expr 14.2 ErrorPrintF . . . . . . . . . expr 12.10 ErrorSet. . . . . . . . . . . expr 14.2 ErrPrin . . . . . . . . . . . expr 12.8 Eval. . . . . . . . . . . . . expr 11.2 EvalInEnvironment . . . . . . expr 10.10 EvIn. . . . . . . . . . . . . expr 12.15 EvLis . . . . . . . . . . . . expr 11.5 EvOut . . . . . . . . . . . . expr 12.6 EvProgN . . . . . . . . . . . expr 11.6 EvShut. . . . . . . . . . . . expr 12.5 Exec. . . . . . . . . . . . . expr 19.3 Exit. . . . . . . . . . . . . macro 9.7 ExitLisp. . . . . . . . . . . expr 13.1, 19.14 Exp . . . . . . . . . . . . . expr 5.13 Expand. . . . . . . . . . . . expr 11.7 Explode2. . . . . . . . . . . expr 12.26 Explode . . . . . . . . . . . expr 12.26 ExprP . . . . . . . . . . . . expr 10.7 Expt. . . . . . . . . . . . . expr 5.3 Extended-Get. . . . . . . . . expr 17.25 Extended-Put. . . . . . . . . expr 17.25 EXTRACT . . . . . . . . . . . edit 16.11 F=. . . . . . . . . . . . . . edit 16.13 F . . . . . . . . . . . . . . edit 16.2, 16.12 Factorial . . . . . . . . . . expr 5.14 FaslEnd . . . . . . . . . . . expr 18.3 FaslIn. . . . . . . . . . . . expr 18.3 FaslOut . . . . . . . . . . . expr 18.2 FatalError. . . . . . . . . . expr 14.8 FCodeP. . . . . . . . . . . . expr 10.6 FExprP. . . . . . . . . . . . expr 10.7 FileP . . . . . . . . . . . . expr 12.5, 19.5 FindPrefix. . . . . . . . . . expr 6.4 FindSuffix. . . . . . . . . . expr 6.4 First . . . . . . . . . . . . macro 7.4 Fix . . . . . . . . . . . . . expr 5.2 Function Index 7 February 1983 PSL Manual page 25.6 section 25.0 FixP. . . . . . . . . . . . . expr 4.7 Flag1 . . . . . . . . . . . . expr 6.6 Flag. . . . . . . . . . . . . expr 6.6 FlagP . . . . . . . . . . . . expr 6.6 FLambdaLinkP. . . . . . . . . expr 10.6 FlatSize2 . . . . . . . . . . expr 12.27 FlatSize. . . . . . . . . . . expr 12.27 Float . . . . . . . . . . . . expr 5.2 FloatP. . . . . . . . . . . . expr 4.7 Floor . . . . . . . . . . . . expr 5.8 Fluid . . . . . . . . . . . . expr 10.8, 18.5 FluidP. . . . . . . . . . . . expr 10.9 FlushStdOutputBuffer. . . . . expr 19.17 For!* . . . . . . . . . . . . macro 9.13 For . . . . . . . . . . . . . macro 9.8 ForEach . . . . . . . . . . . macro 9.13 Fourth. . . . . . . . . . . . macro 7.5 FS. . . . . . . . . . . . . . edit 16.13 FStub . . . . . . . . . . . . macro 15.12 FUnBoundP . . . . . . . . . . expr 10.6 Function. . . . . . . . . . . fexpr 11.7 GenSym. . . . . . . . . . . . expr 6.3 Geq . . . . . . . . . . . . . expr 5.5 Get . . . . . . . . . . . . . expr 6.5 GetCDir . . . . . . . . . . . expr 19.6 GetD. . . . . . . . . . . . . expr 10.3 GetEnv. . . . . . . . . . . . expr 19.14 GetFCodePointer . . . . . . . expr 10.6 GetFork . . . . . . . . . . . expr 19.4 GetNewJfn . . . . . . . . . . expr 19.5 GetOldJfn . . . . . . . . . . expr 19.5 GetRescan . . . . . . . . . . expr 19.5 GetUName. . . . . . . . . . . expr 19.6 GetV. . . . . . . . . . . . . expr 8.3 Global. . . . . . . . . . . . expr 10.8, 18.6 GlobalP . . . . . . . . . . . expr 10.9 GmergeSort. . . . . . . . . . expr 17.22 Go. . . . . . . . . . . . . . fexpr 9.5 Graph-to-Tree . . . . . . . . expr 17.25 GraphicP. . . . . . . . . . . expr 8.8 GreaterP. . . . . . . . . . . expr 5.5 Gsort . . . . . . . . . . . . expr 17.22 GtBps . . . . . . . . . . . . expr 21.9 GtConstStr. . . . . . . . . . expr 21.8 GtFixN. . . . . . . . . . . . expr 21.9 GtFltN. . . . . . . . . . . . expr 21.9 GtHEAP. . . . . . . . . . . . expr 21.8 GtID. . . . . . . . . . . . . expr 21.9 GtJfn . . . . . . . . . . . . expr 19.6 GtStr . . . . . . . . . . . . expr 21.8 GtVect. . . . . . . . . . . . expr 21.8 PSL Manual 7 February 1983 Function Index section 25.0 page 25.7 GtWArray. . . . . . . . . . . expr 21.9 GtWrds. . . . . . . . . . . . expr 21.8 HAppend . . . . . . . . . . . expr 17.24 HCons . . . . . . . . . . . . macro 17.24 HCopy . . . . . . . . . . . . macro 17.24 HELP. . . . . . . . . . . . . edit 16.3, 16.13 Help. . . . . . . . . . . . . fexpr 13.7 HelpDir . . . . . . . . . . . expr 19.3 HighHalfWord. . . . . . . . . expr 19.8 Hist. . . . . . . . . . . . . nexpr 13.5 HList . . . . . . . . . . . . nexpr 17.24 HReverse. . . . . . . . . . . expr 17.25 I . . . . . . . . . . . . . . edit 16.13 Id2Int. . . . . . . . . . . . expr 4.10 Id2String . . . . . . . . . . expr 4.10 Id. . . . . . . . . . . . . . expr 22.10 IdApply0. . . . . . . . . . . expr 11.6 IdApply1. . . . . . . . . . . expr 11.6 IdApply2. . . . . . . . . . . expr 11.6 IdApply3. . . . . . . . . . . expr 11.6 IdApply4. . . . . . . . . . . expr 11.6 IdP . . . . . . . . . . . . . expr 4.7 IdSort. . . . . . . . . . . . expr 17.23 IF. . . . . . . . . . . . . . edit 16.13 If. . . . . . . . . . . . . . macro 9.2 If_System . . . . . . . . . . cmacro 19.1 IGetS . . . . . . . . . . . . expr 8.4 IGetV . . . . . . . . . . . . expr 8.4 Implode . . . . . . . . . . . expr 12.27 ImportForeignString . . . . . expr 19.16 Imports . . . . . . . . . . . expr 18.3 In. . . . . . . . . . . . . . macro 12.14 Incr. . . . . . . . . . . . . macro 5.3 IndexError. . . . . . . . . . expr 14.9 Indx. . . . . . . . . . . . . expr 8.5 InFile. . . . . . . . . . . . fexpr 19.6 Init-File-String. . . . . . . expr 13.3 Inp . . . . . . . . . . . . . expr 13.6 INSERT. . . . . . . . . . . . edit 16.13 Inspect . . . . . . . . . . . expr 17.26 Int!-Char . . . . . . . . . . expr 8.10 Int2Id. . . . . . . . . . . . expr 4.10 Int2Str . . . . . . . . . . . expr 19.8 Intern. . . . . . . . . . . . expr 4.9 InternGenSym. . . . . . . . . expr 6.3 InternP . . . . . . . . . . . expr 6.4 InterSection. . . . . . . . . expr 7.8 InterSectionQ . . . . . . . . expr 7.8 IPutS . . . . . . . . . . . . expr 8.5 IPutV . . . . . . . . . . . . expr 8.4 Function Index 7 February 1983 PSL Manual page 25.8 section 25.0 ISizeS. . . . . . . . . . . . expr 8.4 ISizeV. . . . . . . . . . . . expr 8.4 JBits . . . . . . . . . . . . expr 19.9 JConv . . . . . . . . . . . . expr 19.7 Jsys0 . . . . . . . . . . . . expr 19.7 Jsys1 . . . . . . . . . . . . expr 19.7 Jsys2 . . . . . . . . . . . . expr 19.7 Jsys3 . . . . . . . . . . . . expr 19.7 Jsys4 . . . . . . . . . . . . expr 19.7 KillFork. . . . . . . . . . . expr 19.4 LambdaApply . . . . . . . . . expr 11.5 LambdaEvalApply . . . . . . . expr 11.6 LAnd. . . . . . . . . . . . . expr 5.7 LAP . . . . . . . . . . . . . expr 18.10 LapIn . . . . . . . . . . . . expr 12.14 LastCar . . . . . . . . . . . expr 7.5 LastPair. . . . . . . . . . . expr 7.5 LBind1. . . . . . . . . . . . expr 10.9 LC. . . . . . . . . . . . . . edit 16.14 LCL . . . . . . . . . . . . . edit 16.14 LConc . . . . . . . . . . . . expr 7.7 Length. . . . . . . . . . . . expr 7.6 Leq . . . . . . . . . . . . . expr 5.5 LessP . . . . . . . . . . . . expr 5.6 Let!* . . . . . . . . . . . . macro 9.17 Let . . . . . . . . . . . . . macro 9.16 LI. . . . . . . . . . . . . . edit 16.14 LineLength. . . . . . . . . . expr 12.11 List2Set. . . . . . . . . . . expr 7.8 List2SetQ . . . . . . . . . . expr 7.8 List2String . . . . . . . . . expr 4.10 List2Vector . . . . . . . . . expr 4.11 List. . . . . . . . . . . . . fexpr 7.6 Liter . . . . . . . . . . . . expr 12.26 LNot. . . . . . . . . . . . . expr 5.7 LO. . . . . . . . . . . . . . edit 16.14 Load. . . . . . . . . . . . . macro 18.3 LoadTime. . . . . . . . . . . expr 18.5 Log10 . . . . . . . . . . . . expr 5.14 Log2. . . . . . . . . . . . . expr 5.14 Log . . . . . . . . . . . . . expr 5.13 LOr . . . . . . . . . . . . . expr 5.7 LowerCaseP. . . . . . . . . . expr 8.8 LowHalfWord . . . . . . . . . expr 19.8 LP. . . . . . . . . . . . . . edit 16.15 LPosn . . . . . . . . . . . . expr 12.11 LPQ . . . . . . . . . . . . . edit 16.15 LShift. . . . . . . . . . . . expr 5.7 LXOr. . . . . . . . . . . . . expr 5.7 PSL Manual 7 February 1983 Function Index section 25.0 page 25.9 M . . . . . . . . . . . . . . edit 16.15 MacroExpand . . . . . . . . . macro 17.14 MacroP. . . . . . . . . . . . expr 10.7 Main. . . . . . . . . . . . . expr 13.4 Make!-Bytes . . . . . . . . . expr 8.5 Make!-Halfwords . . . . . . . expr 8.5 Make!-String. . . . . . . . . expr 8.2 Make!-Vector. . . . . . . . . expr 8.3 Make!-Words . . . . . . . . . expr 8.5 MakeFCode . . . . . . . . . . expr 10.6 MakeFLambdaLink . . . . . . . expr 10.6 MAKEFN. . . . . . . . . . . . edit 16.16 MakeFUnBound. . . . . . . . . expr 10.6 MakeUnBound . . . . . . . . . expr 6.9 Map . . . . . . . . . . . . . expr 9.14 MapC. . . . . . . . . . . . . expr 9.14 MapCan. . . . . . . . . . . . expr 9.14 MapCar. . . . . . . . . . . . expr 9.14 MapCon. . . . . . . . . . . . expr 9.14 MapList . . . . . . . . . . . expr 9.15 MapObl. . . . . . . . . . . . expr 6.4 MARK. . . . . . . . . . . . . edit 16.16 Max2. . . . . . . . . . . . . expr 5.6 Max . . . . . . . . . . . . . macro 5.6 MBD . . . . . . . . . . . . . edit 16.17 Member. . . . . . . . . . . . expr 7.6 MemQ. . . . . . . . . . . . . expr 7.6 Min2. . . . . . . . . . . . . expr 5.6 Min . . . . . . . . . . . . . macro 5.6 Minus . . . . . . . . . . . . expr 5.4 MinusP. . . . . . . . . . . . expr 5.6 MkQuote . . . . . . . . . . . expr 11.7 MkString. . . . . . . . . . . expr 8.2 MkVect. . . . . . . . . . . . expr 8.3 MM. . . . . . . . . . . . . . expr 19.4 Mod . . . . . . . . . . . . . expr 5.9 MOVE. . . . . . . . . . . . . edit 16.17 N . . . . . . . . . . . . . . edit 16.18 NameFromJfn . . . . . . . . . expr 19.6 NConc . . . . . . . . . . . . expr 7.7 NCons . . . . . . . . . . . . expr 7.3 Ne. . . . . . . . . . . . . . expr 4.6 Neq . . . . . . . . . . . . . macro 4.6 NewId . . . . . . . . . . . . expr 4.9 NewTrBuff . . . . . . . . . . expr 15.6 NEX . . . . . . . . . . . . . edit 16.18 NExprP. . . . . . . . . . . . expr 10.7 Next. . . . . . . . . . . . . macro 9.7 NonCharacterError . . . . . . expr 14.10 NonIDError. . . . . . . . . . expr 14.9 Function Index 7 February 1983 PSL Manual page 25.10 section 25.0 NonIntegerError . . . . . . . expr 14.9 NonNumberError. . . . . . . . expr 14.9 NonPairError. . . . . . . . . expr 14.9 NonPositiveIntegerError . . . expr 14.10 NonSequenceError. . . . . . . expr 14.10 NonStringError. . . . . . . . expr 14.10 NonVectorError. . . . . . . . expr 14.10 Not . . . . . . . . . . . . . expr 4.8 NString!-Capitalize . . . . . expr 8.13 NString!-DownCase . . . . . . expr 8.13 NString!-UpCase . . . . . . . expr 8.13 NTH . . . . . . . . . . . . . edit 16.18 Nth . . . . . . . . . . . . . expr 7.5 Null. . . . . . . . . . . . . expr 4.7 Num . . . . . . . . . . . . . expr 22.10 NumberP . . . . . . . . . . . expr 4.7 NX. . . . . . . . . . . . . . edit 16.19 Off . . . . . . . . . . . . . macro 6.14 OK. . . . . . . . . . . . . . edit 16.3, 16.19 On. . . . . . . . . . . . . . macro 6.14 OneP. . . . . . . . . . . . . expr 5.6 Open. . . . . . . . . . . . . expr 12.4 OpenFork. . . . . . . . . . . expr 19.4 OpenNewJfn. . . . . . . . . . expr 19.5 OpenOldJfn. . . . . . . . . . expr 19.5 Or. . . . . . . . . . . . . . fexpr 4.9 ORF . . . . . . . . . . . . . edit 16.19 ORR . . . . . . . . . . . . . edit 16.19 Out . . . . . . . . . . . . . macro 12.5 P . . . . . . . . . . . . . . edit 16.1, 16.20 Pair. . . . . . . . . . . . . expr 7.11 PairP . . . . . . . . . . . . expr 4.8 Path. . . . . . . . . . . . . expr 19.13 PathIn. . . . . . . . . . . . expr 12.15 Pause . . . . . . . . . . . . expr 13.8 PBind1. . . . . . . . . . . . expr 10.10 PL. . . . . . . . . . . . . . edit 16.1 PList . . . . . . . . . . . . macro 15.12 Plus2 . . . . . . . . . . . . expr 5.4 Plus. . . . . . . . . . . . . macro 5.4 PNth. . . . . . . . . . . . . expr 7.5 Pop . . . . . . . . . . . . . macro 17.15 Posn. . . . . . . . . . . . . expr 12.11 PP. . . . . . . . . . . . . . edit 16.21 Ppf . . . . . . . . . . . . . macro 15.12 PrettyPrint . . . . . . . . . expr 12.11 Prin1 . . . . . . . . . . . . expr 12.8 Prin2 . . . . . . . . . . . . expr 12.8 Prin2L. . . . . . . . . . . . expr 12.11 Prin2T. . . . . . . . . . . . expr 12.12 PSL Manual 7 February 1983 Function Index section 25.0 page 25.11 PrinC . . . . . . . . . . . . expr 12.8 Print . . . . . . . . . . . . expr 12.8 PrintF. . . . . . . . . . . . expr 12.10 PrintScanTable. . . . . . . . expr 12.25 PrintX. . . . . . . . . . . . expr 15.13 Prog1 . . . . . . . . . . . . macro 9.5 Prog2 . . . . . . . . . . . . expr 9.5 Prog. . . . . . . . . . . . . fexpr 9.5 ProgN . . . . . . . . . . . . fexpr 9.4 Prop. . . . . . . . . . . . . expr 6.7 PSetF . . . . . . . . . . . . macro 6.9 PSetQ . . . . . . . . . . . . macro 6.8 Push. . . . . . . . . . . . . macro 17.14 Put . . . . . . . . . . . . . expr 6.5 PutByte . . . . . . . . . . . expr 20.11 PutD. . . . . . . . . . . . . expr 10.2 PutDipthong . . . . . . . . . expr 12.25 PutReadMacro. . . . . . . . . expr 12.25 PutRescan . . . . . . . . . . expr 19.5 PutV. . . . . . . . . . . . . expr 8.3 Pwd . . . . . . . . . . . . . expr 19.13 Quit. . . . . . . . . . . . . expr 13.1 Quote . . . . . . . . . . . . fexpr 11.6 Quotient. . . . . . . . . . . expr 5.4 R . . . . . . . . . . . . . . edit 16.2, 16.21 RadiansToDegrees. . . . . . . expr 5.9 RadiansToDMS. . . . . . . . . expr 5.9 Random. . . . . . . . . . . . expr 5.14 RangeError. . . . . . . . . . expr 14.9 RAtom . . . . . . . . . . . . expr 12.21 Rds . . . . . . . . . . . . . expr 12.5 Read-Init-File. . . . . . . . expr 13.3 Read. . . . . . . . . . . . . expr 12.13 ReadCH. . . . . . . . . . . . expr 12.16 ReadChar. . . . . . . . . . . expr 12.16 Recip . . . . . . . . . . . . expr 5.4 Reclaim . . . . . . . . . . . expr 21.8 RecopyStringToNULL. . . . . . expr 19.8 ReDo. . . . . . . . . . . . . expr 13.6 RelJfn. . . . . . . . . . . . expr 19.5 ReLoad. . . . . . . . . . . . macro 18.3 Remainder . . . . . . . . . . expr 5.4 RemD. . . . . . . . . . . . . expr 10.4 RemFlag1. . . . . . . . . . . expr 6.6 RemFlag . . . . . . . . . . . expr 6.6 RemOb . . . . . . . . . . . . expr 6.4 RemProp . . . . . . . . . . . expr 6.5 RemPropL. . . . . . . . . . . expr 6.5 REPACK. . . . . . . . . . . . edit 16.21 Repeat. . . . . . . . . . . . macro 9.7 Function Index 7 February 1983 PSL Manual page 25.12 section 25.0 ResBtr. . . . . . . . . . . . expr 15.10 Reset . . . . . . . . . . . . expr 13.2, 19.4 Rest. . . . . . . . . . . . . macro 7.5 RestoreEnvironment. . . . . . expr 10.11 Restr . . . . . . . . . . . . expr 15.9 Return. . . . . . . . . . . . expr 9.6 Reverse . . . . . . . . . . . expr 7.9 ReversIP. . . . . . . . . . . expr 7.10 RI. . . . . . . . . . . . . . edit 16.22 RLisp . . . . . . . . . . . . expr 13.6 RO. . . . . . . . . . . . . . edit 16.22 Round . . . . . . . . . . . . expr 5.8 RplacA. . . . . . . . . . . . expr 7.4 RplacD. . . . . . . . . . . . expr 7.4 RplaChar. . . . . . . . . . . expr 8.10 RplacW. . . . . . . . . . . . expr 7.4 RPrint. . . . . . . . . . . . expr 12.11 Run . . . . . . . . . . . . . expr 19.3 RunFork . . . . . . . . . . . expr 19.4 S . . . . . . . . . . . . . . edit 16.22 SAssoc. . . . . . . . . . . . expr 7.10 SAVE. . . . . . . . . . . . . edit 16.22 SaveSystem. . . . . . . . . . expr 13.2 Sec . . . . . . . . . . . . . expr 5.11 SecD. . . . . . . . . . . . . expr 5.11 SECOND. . . . . . . . . . . . edit 16.23 Second. . . . . . . . . . . . macro 7.5 Set . . . . . . . . . . . . . expr 6.7 SetF. . . . . . . . . . . . . macro 6.8 SetIndx . . . . . . . . . . . expr 8.6 SetProp . . . . . . . . . . . expr 6.7 SetQ. . . . . . . . . . . . . fexpr 6.7 SetSub. . . . . . . . . . . . expr 8.6 SetSubSeq . . . . . . . . . . expr 8.6 Shut. . . . . . . . . . . . . macro 12.5 Sin . . . . . . . . . . . . . expr 5.10 SinD. . . . . . . . . . . . . expr 5.10 Size. . . . . . . . . . . . . expr 8.5 Spaces. . . . . . . . . . . . expr 12.12 Sqrt. . . . . . . . . . . . . expr 5.13 Standard!-CharP . . . . . . . expr 8.7 StandardLisp. . . . . . . . . expr 13.6 StartFork . . . . . . . . . . expr 19.4 StdError. . . . . . . . . . . expr 14.9 StdTrace. . . . . . . . . . . expr 15.7 Step. . . . . . . . . . . . . expr 15.3 STOP. . . . . . . . . . . . . edit 16.23 Str2Int . . . . . . . . . . . expr 19.8 Str . . . . . . . . . . . . . expr 22.11 String!-Capitalize. . . . . . expr 8.13 String!-CharP . . . . . . . . expr 8.8 PSL Manual 7 February 1983 Function Index section 25.0 page 25.13 String!-DownCase. . . . . . . expr 8.13 String!-Equal . . . . . . . . expr 8.11 String!-GreaterP. . . . . . . expr 8.11 String!-Left!-Trim. . . . . . expr 8.12 String!-Length. . . . . . . . expr 8.13 String!-LessP . . . . . . . . expr 8.11 String!-Not!-Equal. . . . . . expr 8.12 String!-Not!-GreaterP . . . . expr 8.12 String!-Not!-LessP. . . . . . expr 8.12 String!-Repeat. . . . . . . . expr 8.12 String!-Right!-Trim . . . . . expr 8.12 String!-to!-List. . . . . . . expr 8.13 String!-to!-Vector. . . . . . expr 8.13 String!-Trim. . . . . . . . . expr 8.12 String!-UpCase. . . . . . . . expr 8.12 String!<!=. . . . . . . . . . expr 8.11 String!<!>. . . . . . . . . . expr 8.11 String!<. . . . . . . . . . . expr 8.11 String!=. . . . . . . . . . . expr 8.11 String!>!=. . . . . . . . . . expr 8.11 String!>. . . . . . . . . . . expr 8.11 String2List . . . . . . . . . expr 4.10 String2Vector . . . . . . . . expr 4.11 String. . . . . . . . . . . . nexpr 4.11, 8.2 StringGenSym. . . . . . . . . expr 6.3 StringP . . . . . . . . . . . expr 4.8 Stub. . . . . . . . . . . . . macro 15.12 Sub1. . . . . . . . . . . . . expr 5.5 Sub . . . . . . . . . . . . . expr 8.6 SublA . . . . . . . . . . . . expr 7.12 SubLis. . . . . . . . . . . . expr 7.11 SubSeq. . . . . . . . . . . . expr 8.6 Subst . . . . . . . . . . . . expr 7.11 SubstIP . . . . . . . . . . . expr 7.11 SubString . . . . . . . . . . expr 8.13 SubTypeP. . . . . . . . . . . expr 17.16 SW. . . . . . . . . . . . . . edit 16.23 Swap. . . . . . . . . . . . . expr 19.8 Sys . . . . . . . . . . . . . expr 19.3 System. . . . . . . . . . . . expr 19.14 T . . . . . . . . . . . . . . edit 16.2 Tab . . . . . . . . . . . . . expr 12.12 Take. . . . . . . . . . . . . expr 19.3 Tan . . . . . . . . . . . . . expr 5.10 TanD. . . . . . . . . . . . . expr 5.10 TConc . . . . . . . . . . . . expr 7.7 TerPri. . . . . . . . . . . . expr 12.10 TEST. . . . . . . . . . . . . edit 16.23 THIRD . . . . . . . . . . . . edit 16.23 Third . . . . . . . . . . . . macro 7.5 THROUGH . . . . . . . . . . . edit 16.24 Function Index 7 February 1983 PSL Manual page 25.14 section 25.0 Throw . . . . . . . . . . . . expr 9.18 Time. . . . . . . . . . . . . expr 13.2 Times2. . . . . . . . . . . . expr 5.5 Times . . . . . . . . . . . . macro 5.5 TO. . . . . . . . . . . . . . edit 16.24 TopLoop . . . . . . . . . . . expr 13.4 TotalCopy . . . . . . . . . . expr 8.7 Tr. . . . . . . . . . . . . . macro 15.3, 15.5 TraceCount. . . . . . . . . . expr 15.7 TransferSign. . . . . . . . . expr 5.9 TrCnt . . . . . . . . . . . . macro 15.12 TrIn. . . . . . . . . . . . . macro 15.8 TrOut . . . . . . . . . . . . expr 15.7 Trst. . . . . . . . . . . . . macro 15.3, 15.6 TTY:. . . . . . . . . . . . . edit 16.24 Type. . . . . . . . . . . . . expr 19.3 TypeError . . . . . . . . . . expr 14.9 UnBindN . . . . . . . . . . . expr 10.9 UNBLOCK . . . . . . . . . . . edit 16.24 UnBoundP. . . . . . . . . . . expr 6.10, 10.9 UNDO. . . . . . . . . . . . . edit 16.25 UnFluid . . . . . . . . . . . expr 10.9 Union . . . . . . . . . . . . expr 7.8 UnionQ. . . . . . . . . . . . expr 7.8 Unless. . . . . . . . . . . . macro 9.3 UnQuote . . . . . . . . . . . fexpr 17.13 UnQuoteL. . . . . . . . . . . fexpr 17.13 UnReadChar. . . . . . . . . . expr 12.16 UnTr. . . . . . . . . . . . . macro 15.3, 15.9 UnTrst. . . . . . . . . . . . macro 15.3, 15.9 Unwind!-All . . . . . . . . . macro 9.19 Unwind!-Protect . . . . . . . macro 9.19 UP. . . . . . . . . . . . . . edit 16.2, 16.25 UpbV. . . . . . . . . . . . . expr 8.4 UpperCaseP. . . . . . . . . . expr 8.8 UsageTypeError. . . . . . . . expr 14.9 User-HomeDir-String . . . . . expr 13.3 ValueCell . . . . . . . . . . expr 6.9 VDir. . . . . . . . . . . . . expr 19.3 Vector2List . . . . . . . . . expr 4.11 Vector2String . . . . . . . . expr 4.11 Vector. . . . . . . . . . . . nexpr 4.11, 8.4 VectorP . . . . . . . . . . . expr 4.8 WaitFork. . . . . . . . . . . expr 19.4 WAnd. . . . . . . . . . . . . expr 20.10 WDifference . . . . . . . . . expr 20.10 WEQ . . . . . . . . . . . . . expr 20.10 WGEQ. . . . . . . . . . . . . expr 20.10 WGetV . . . . . . . . . . . . macro 20.11 PSL Manual 7 February 1983 Function Index section 25.0 page 25.15 WGreaterP . . . . . . . . . . expr 20.10 When. . . . . . . . . . . . . macro 9.3 While . . . . . . . . . . . . macro 9.6 WLEQ. . . . . . . . . . . . . expr 20.11 WLessP. . . . . . . . . . . . expr 20.10 WNEQ. . . . . . . . . . . . . expr 20.10 WNot. . . . . . . . . . . . . expr 20.10 WOr . . . . . . . . . . . . . expr 20.10 WPlus2. . . . . . . . . . . . expr 20.10 WPutV . . . . . . . . . . . . macro 20.11 WQuotient . . . . . . . . . . expr 20.10 WRemainder. . . . . . . . . . expr 20.10 WriteChar . . . . . . . . . . expr 12.6 Wrs . . . . . . . . . . . . . expr 12.5 WShift. . . . . . . . . . . . expr 20.10 WTimes2 . . . . . . . . . . . expr 20.10 WXor. . . . . . . . . . . . . expr 20.10 XCons . . . . . . . . . . . . expr 7.3 XJsys0. . . . . . . . . . . . expr 19.6 XJsys1. . . . . . . . . . . . expr 19.7 XJsys2. . . . . . . . . . . . expr 19.7 XJsys3. . . . . . . . . . . . expr 19.7 XJsys4. . . . . . . . . . . . expr 19.7 XTR . . . . . . . . . . . . . edit 16.25 Xword . . . . . . . . . . . . expr 19.8 YesP. . . . . . . . . . . . . expr 13.8 ZeroP . . . . . . . . . . . . expr 5.6 |
Added psl-1983/3-1/lpt/26-glo-index.lpt version [34d649eab5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Global Index section 26.0 page 26.1 CHAPTER 26 CHAPTER 26 CHAPTER 26 INDEX OF GLOBALS AND SWITCHES INDEX OF GLOBALS AND SWITCHES INDEX OF GLOBALS AND SWITCHES The following is an alphabetical list of the PSL global variables, with the page on which they are defined. !$BREAK!$ . . . . . . . . . . global 14.8 !$ERROR!$ . . . . . . . . . . global 14.1, 14.2 !*BACKTRACE . . . . . . . . . switch 14.1, 14.2 !*BREAK . . . . . . . . . . . switch 14.4, 14.8 !*BTR . . . . . . . . . . . . switch 15.10 !*BTRSAVE . . . . . . . . . . switch 15.10 !*COMP. . . . . . . . . . . . switch 10.3, 18.2 !*COMPRESSING . . . . . . . . switch 12.13, 12.16, 12.21 !*ContinuableError. . . . . . switch 14.3 !*CREFSUMMARY . . . . . . . . switch 17.3 !*DEFN. . . . . . . . . . . . switch 18.3 !*ECHO. . . . . . . . . . . . switch 12.2, 12.14 !*EMsgP . . . . . . . . . . . switch 13.5 !*EOLINSTRINGOK . . . . . . . switch 12.21 !*ERFG. . . . . . . . . . . . switch 18.23 !*GC. . . . . . . . . . . . . switch 21.7 !*INSTALL . . . . . . . . . . switch 15.10, 15.14 !*INSTALLDESTROY. . . . . . . switch 18.23 !*INT . . . . . . . . . . . . switch 18.23 !*MODULE. . . . . . . . . . . switch 18.7 !*MSGP. . . . . . . . . . . . switch 14.2 !*NOFRAMEFLUID. . . . . . . . switch 18.23 !*NOLINKE . . . . . . . . . . switch 18.6 !*NOTRARGS. . . . . . . . . . switch 15.6 !*ORD . . . . . . . . . . . . switch 18.6 !*PECHO . . . . . . . . . . . switch 13.5 !*PGWD. . . . . . . . . . . . switch 18.13 !*PLAP. . . . . . . . . . . . switch 18.7, 18.13 !*PVAL. . . . . . . . . . . . switch 13.5 !*PWRDS . . . . . . . . . . . switch 18.7, 18.13 !*R2I . . . . . . . . . . . . switch 18.6 !*RAISE . . . . . . . . . . . switch 12.19, 12.21 !*REDEFMSG. . . . . . . . . . switch 10.3 !*SAVECOM . . . . . . . . . . switch 18.13 !*SAVEDEF . . . . . . . . . . switch 18.13 !*SAVENAMES . . . . . . . . . switch 15.14 !*SHOWDEST. . . . . . . . . . switch 18.23 !*SYSLISP . . . . . . . . . . switch 18.24 !*TIME. . . . . . . . . . . . switch 13.5 !*TRACE . . . . . . . . . . . switch 15.7 !*TRACEALL. . . . . . . . . . switch 15.10, 15.14 !*TRCOUNT . . . . . . . . . . switch 15.11 !*UNSAFEBINDER. . . . . . . . switch 18.24 !*USEREGFLUID . . . . . . . . switch 18.24 !*USERMODE. . . . . . . . . . switch 10.3 Global Index 7 February 1983 PSL Manual page 26.2 section 26.0 \CURRENTPACKAGE!* . . . . . . global 6.10 \PACKAGENAMES!* . . . . . . . global 6.10 BREAKEVALUATOR!*. . . . . . . global 14.4 BreakIn!* . . . . . . . . . . global 12.3, 14.8 BreakLevel!*. . . . . . . . . global 14.4 BreakOut!*. . . . . . . . . . global 12.3, 14.8 BREAKPRINTER!*. . . . . . . . global 14.4 BREAKREADER!* . . . . . . . . global 14.4 CRLF. . . . . . . . . . . . . global 19.2 CurrentReadMacroIndicator!* . global 12.17 CurrentScanTable!*. . . . . . global 12.17, 12.18, 12.21, 12.25 Date!*. . . . . . . . . . . . global 13.3 DFPRINT!* . . . . . . . . . . global 18.3 EMSG!*. . . . . . . . . . . . global 14.2 ERRORFORM!* . . . . . . . . . global 14.3, 14.4, 14.5 ERRORHANDLERS!* . . . . . . . global 14.10 ERROUT!*. . . . . . . . . . . global 12.4, 12.10 GCKNT!* . . . . . . . . . . . global 21.7 GCTime!*. . . . . . . . . . . global 13.5 HelpIn!*. . . . . . . . . . . global 12.3, 13.7 HelpOut!* . . . . . . . . . . global 12.3, 13.7 HistoryCount!*. . . . . . . . global 13.6 HistoryList!* . . . . . . . . global 13.6 IgnoredInBacktrace!*. . . . . global 14.5 IN!*. . . . . . . . . . . . . global 12.3, 12.5, 12.13 InitForms!* . . . . . . . . . global 13.5 InterpreterFunctions!*. . . . global 14.5 LASTACTUALREG . . . . . . . . global 18.24 LispBanner!*. . . . . . . . . global 13.2 LISPSCANTABLE!* . . . . . . . global 12.21 LoadDirectories!* . . . . . . global 18.4 LoadExtensions!*. . . . . . . global 18.4 MaxBreakLevel!* . . . . . . . global 14.4 MAXLEVEL. . . . . . . . . . . global 16.12 MAXNARGS. . . . . . . . . . . global 18.24 NIL . . . . . . . . . . . . . global 6.15 NOLIST!*. . . . . . . . . . . global 17.3 OPTIONS!* . . . . . . . . . . global 18.3 OUT!* . . . . . . . . . . . . global 12.3, 12.5 OUTPUTBASE!*. . . . . . . . . global 12.20, 12.24 PSL Manual 7 February 1983 Global Index section 26.0 page 26.3 PATHIN!*. . . . . . . . . . . global 12.15 PLEVEL. . . . . . . . . . . . global 16.1 PPFPRINTER!*. . . . . . . . . global 15.15 PrinLength. . . . . . . . . . global 12.12 PrinLevel . . . . . . . . . . global 12.12 PROMPTSTRING!*. . . . . . . . global 12.4 PROPERTYPRINTER!* . . . . . . global 15.15 PUTDHOOK!*. . . . . . . . . . global 15.14 RandomSeed. . . . . . . . . . global 5.14 RLISPSCANTABLE!*. . . . . . . global 12.21, 12.22 SPECIALCLOSEFUNCTION!*. . . . global 12.4, 12.6 SPECIALRDSACTION!*. . . . . . global 12.5, 12.6 SPECIALREADFUNCTION!* . . . . global 12.4, 12.6 SPECIALWRITEFUNCTION!*. . . . global 12.4, 12.6 SPECIALWRSACTION!*. . . . . . global 12.5, 12.6 StartupName!* . . . . . . . . global 19.17 STDIN!* . . . . . . . . . . . global 12.2, 12.3, 12.5 STDOUT!*. . . . . . . . . . . global 12.2, 12.3, 12.5 STUBPRINTER!* . . . . . . . . global 15.15 STUBREADER!*. . . . . . . . . global 15.15 SymbolFileName!*. . . . . . . global 19.16 T . . . . . . . . . . . . . . global 6.15 ThrowSignal!* . . . . . . . . global 9.17 ThrowTag!*. . . . . . . . . . global 9.17 TOKTYPE!* . . . . . . . . . . global 12.16, 12.24 TopLoopEval!* . . . . . . . . global 13.4, 14.8 TopLoopLevel!*. . . . . . . . global 13.5 TopLoopName!* . . . . . . . . global 13.4 TopLoopPrint!*. . . . . . . . global 13.4, 14.8 TopLoopRead!* . . . . . . . . global 13.4, 14.8 TRACEMAXLEVEL!* . . . . . . . global 15.8 TRACEMINLEVEL!* . . . . . . . global 15.8 TRACENTRYHOOK!* . . . . . . . global 15.14 TRACEXITHOOK!*. . . . . . . . global 15.14 TRACEXPANDHOOK!*. . . . . . . global 15.15 TREXPRINTER!* . . . . . . . . global 15.15 TRINSTALLHOOK!* . . . . . . . global 15.15 TRPRINTER!* . . . . . . . . . global 15.16 TRSPACE!* . . . . . . . . . . global 15.16 UnixArgs!*. . . . . . . . . . global 19.17 UPFINDFLG . . . . . . . . . . global 16.12 |
Added psl-1983/3-1/minimal-logical-names.cmd version [136efe4c63].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Officially recognized logical names for MINIMAL ; PSL system, in single directory ; EDIT <psl> into <name> as appropriate define psl: <psl> ! Executable files and miscellaneous ;define pc: <psl> ! Compiler sources ;define p20c: <psl> ! 20 Specific Compiler sources ;define pdist: <psl> ! Distribution files ;define pd: <psl> ! Documentation files ;define p20d: <psl> ! 20 Specific Documentation files ;define pndoc: <psl> ! NMODE Documentation files ; not distributed define pe: <psl> ! EMODE support and drivers ;define pg: <psl> ! GLISP source define ph: <psl> ! Help files ;define pk: <psl> ! Kernel Source files ;define p20k: <psl> ! 20 Specific Kernel Sources define pl: <psl> ! LAP files ;define plpt: <psl> ! Printer version of Documentation ;define pn: <psl> ! NMODE editor files define pnb: <psl> ! NMODE editor binaries ;define pnk: <psl> ! PSL Non Kernel source files ;define pt: <psl> ! PSL Test files ;define p20t: <psl> ! PSL 20 Specific Test files ;define pu: <psl> ! Utility program sources ;define p20u: <psl> ! 20 specific Utility files ;define pw: <psl> ! NMODE Window files define pwb: <psl> ! NMODE Window binaries take |
Added psl-1983/3-1/minimal-restore.ctl version [d9b9b1fb2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve subset of ssnames for MINIMAL PSL system ; First edit MINIMAL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories or single directory ; then mount TAPE, def X: @DUMPER *tape X: *density 1600 *files *account system-default *; --- Skip over the logical names etc to do the restore. *skip 1 *restore dsk*:<*>*.*.* PSL:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* PC:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* P20C:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PDIST:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PD:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* P20D:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* PNDOC:*.*.* *skip 1 ; --- not distributed anymore --- *restore dsk*:<*>*.*.* pe:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pg:*.*.* *skip 1 *restore dsk*:<*>*.*.* ph:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pk:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20:*.*.* *skip 1 *restore dsk*:<*>*.*.* pl:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* plpt:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pn:*.*.* *skip 1 *restore dsk*:<*>*.*.* pnb:*.*.* ; --- not needed --- *restore dsk*:<*>*.*.* pnk:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pT:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20T:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pu:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* p20u:*.*.* *skip 1 ; --- not needed --- *restore dsk*:<*>*.*.* pw:*.*.* *skip 1 *restore dsk*:<*>*.*.* pwb:*.*.* |
Added psl-1983/3-1/nmode/-file.list version [5f30b1dd5b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE Source Files Summary - 15 February 1983 ------------------------------------------------------------------------------- AUTOFILL.SL - auto fill mode BROWSER.SL - browser object definition BROWSER-SUPPORT.SL - general support functions for browsers BUFFER-BROWSER.SL - the buffer browser (C-X C-B) BUFFER-IO.SL - support for PSL I/O to and from text buffers BUFFER-POSITION.SL - type representing (line,char) pairs BUFFER-WINDOW.SL - abstract data type mapping text buffer to virtual screen BUFFER.SL - auxiliary functions for operating on the current buffer BUFFERS.SL - functions managing set of existing buffers CASE-COMMANDS.SL - commands for changing the case of text COMMAND-INPUT.SL - functions for command input COMMANDS.SL - miscellaneous editor commands DEFUN-COMMANDS.SL - editor commands related to top-level definitions in code DIRED.SL - directory edit subsystem DISPATCH.SL - command dispatch table manager DOC.SL - online documentation facility EXTENDED-INPUT.SL - functions for reading extended characters FILEIO.SL - functions for I/O to and from files INCR.SL - incremental search command INDENT-COMMANDS.SL - editor commands relating to indentation KILL-COMMANDS.SL - editor commands relating to killing text LISP-COMMANDS.SL - miscellaneous editor commands relating to lisp code LISP-INDENTING.SL - commands and functions for indenting lisp code LISP-INTERFACE.SL - interaction between NMODE and Lisp (including MAIN) LISP-PARSER.SL - basic parser for Lisp code M-X.SL - the M-X command reader M-XCMD.SL - miscellaneous extended commands MODE-DEFS.SL - definitions of standard modes MODES.SL - mode definition functions MOVE-COMMANDS.SL - editor commands relating to cursor motion NMODE-20.SL - system dependent functions for Dec-20 NMODE-9836.SL - system dependent functions for HP9836 NMODE-ATTRIBUTES.SL - macros for constructing parsing attributes NMODE-BREAK.SL - NMODE's break handler NMODE-INIT.SL - initialization code NMODE-PARSING.SL - primitive functions for parsing source code PROMPTING.SL - string input and basic prompt line functions QUERY-REPLACE.SL - query-replace subsystem READER.SL - NMODE command reader REC.SL - recursive editing functions SCREEN-LAYOUT.SL - functions managing overall NMODE screen layout SEARCH.SL. - searching functions SET-TERMINAL-20.SL - Dec-20 terminal driver selection SET-TERMINAL-9836.SL - HP9836 terminal driver selection SOFTKEYS.SL - NMode softkeys (Esc-/) STRUCTURE-FUNCTIONS.SL - functions for moving about structured text TERMINAL-INPUT.SL - terminal input functions, including prompted input TEXT-BUFFER.SL - text buffer abstract data type TEXT-COMMANDS.SL - sentence, paragraph, and formatting stuff WINDOW.SL - auxiliary functions for manipulating the current window WINDOW-LABEL.SL - manages label area of a window |
Added psl-1983/3-1/nmode/-nmode.files version [f723f0618a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE Source Files Summary - 5 April 1983 ------------------------------------------------------------------------------- AUTOFILL.SL - auto fill mode BROWSER-BROWSER.SL - the browser browser BROWSER-SUPPORT.SL - general support functions for browsers BROWSER.SL - browser object definition BUFFER-BROWSER.SL - the buffer browser (C-X C-B) BUFFER-IO.SL - support for PSL I/O to and from text buffers BUFFER-POSITION.SL - type representing (line,char) pairs BUFFER-WINDOW.SL - abstract data type mapping text buffer to virtual screen BUFFER.SL - auxiliary functions for operating on the current buffer BUFFERS.SL - functions managing set of existing buffers CASE-COMMANDS.SL - commands for changing the case of text COMMAND-INPUT.SL - functions for command input COMMANDS.SL - miscellaneous editor commands DEFUN-COMMANDS.SL - editor commands related to top-level definitions in code DIRED.SL - directory edit subsystem DISPATCH.SL - command dispatch table manager DOC.SL - online documentation facility EXTENDED-INPUT.SL - functions for reading extended characters FILEIO.SL - functions for I/O to and from files HP9836-DEV.SL - development support for 9836 INCR.SL - incremental search command INDENT-COMMANDS.SL - editor commands relating to indentation KILL-COMMANDS.SL - editor commands relating to killing text LISP-COMMANDS.SL - miscellaneous editor commands relating to lisp code LISP-INDENTING.SL - commands and functions for indenting lisp code LISP-INTERFACE.SL - interaction between NMODE and Lisp (including MAIN) LISP-PARSER.SL - basic parser for Lisp code M-X.SL - the M-X command reader M-XCMD.SL - miscellaneous extended commands MODE-DEFS.SL - definitions of standard modes MODES.SL - mode definition functions MOVE-COMMANDS.SL - editor commands relating to cursor motion NMODE-20.SL - system dependent functions for Dec-20 NMODE-9836.SL - system dependent functions for HP9836 NMODE-ATTRIBUTES.SL - macros for constructing parsing attributes NMODE-BREAK.SL - NMODE's break handler NMODE-INIT.SL - initialization code NMODE-PARSING.SL - primitive functions for parsing source code NMODE-VAX.SL - system dependent functions for Vax-Unix PROMPTING.SL - string input and basic prompt line functions QUERY-REPLACE.SL - query-replace subsystem READER.SL - NMODE command reader REC.SL - recursive editing functions SCREEN-LAYOUT.SL - functions managing overall NMODE screen layout SEARCH.SL. - searching functions SOFTKEYS.SL - NMode softkeys (Esc-/) STRUCTURE-FUNCTIONS.SL - functions for moving about structured text TERMINAL-INPUT.SL - terminal input functions, including prompted input TEXT-BUFFER.SL - text buffer abstract data type TEXT-COMMANDS.SL - sentence, paragraph, and formatting stuff WINDOW-LABEL.SL - manages label area of a window WINDOW.SL - auxiliary functions for manipulating the current window |
Added psl-1983/3-1/nmode/-this-.directory version [182b213b12].
> > | 1 2 | This directory contains the sources and non-loadable binaries for the NMODE editor. |
Added psl-1983/3-1/nmode/autofill.sl version [df81b90130].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % AUTOFILL.SL - NMODE Auto-Fill Mode % % Author: Jeff Soreff % Hewlett-Packard/CRC % Date: 3 November 1982 % Revised: 18 January 1983 % % 16-Nov-82 Jeff Soreff % Fixed bugs (handling very long lines, breaking at punctuation) % and improved efficiency. % 29-Nov-82 Jeff Soreff % Fixed bug with too-long word. % 18-Jan-83 Jeff Soreff % Made autofill preserve textual context of buffer position. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int fast-strings fast-vectors)) % Externals used here: (fluid '(nmode-command-argument nmode-command-argument-given)) % Globals defined here: (fluid '(fill-prefix fill-column auto-fill-mode)) (setf fill-prefix nil) (setf fill-column 70) (setf auto-fill-mode (nmode-define-mode "Fill" '((auto-fill-setup)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de auto-fill-mode-command () (toggle-minor-mode auto-fill-mode)) (de auto-fill-setup () (if (eq (dispatch-table-lookup (x-char SPACE)) 'insert-self-command) (nmode-define-command (x-char SPACE) 'auto-fill-space) )) (de set-fill-column-command () (if nmode-command-argument-given (setq fill-column nmode-command-argument) (setq fill-column (current-display-column))) (write-message (bldmsg "%w%p" "Fill Column = " fill-column))) (de set-fill-prefix-command () (let ((temp (buffer-get-position))) (cond ((at-line-start?) (setq fill-prefix nil) (write-message "Fill Prefix now empty")) (t (move-to-start-of-line) (setq fill-prefix (extract-text nil (buffer-get-position) temp)) (buffer-set-position temp) (write-message (bldmsg "%w%p" "Fill Prefix now " (vector-fetch fill-prefix 0))))))) (de blank-char (char) (or (= char #\tab) (= char #\blank))) (de skip-forward-blanks-in-line () (while (and (not (at-line-end?)) (blank-char (next-character))) (move-forward))) (de skip-backward-blanks-in-line () (while (and (not (at-line-start?)) (blank-char (previous-character))) (move-backward))) (de skip-forward-nonblanks-in-line () (while (and (not (at-line-end?)) (not (blank-char (next-character)))) (move-forward))) (de auto-fill-space () (for (from i 1 nmode-command-argument 1) (do (insert-character #\blank))) (when (> (current-display-column) fill-column) (let ((word-too-long nil) (current-place (buffer-get-position))) (set-display-column fill-column) (while (or (not (at-line-end?)) word-too-long) (let ((start nil)(end nil)) (while (not (or (at-line-start?) (and (blank-char % start natural break (next-character)) (not (blank-char (previous-character)))))) (move-backward)) (unless (setf word-too-long (and (at-line-start?) (not (blank-char (next-character))))) (setf start (buffer-get-position)) (skip-forward-blanks-in-line) (setf end (buffer-get-position)) (when (buffer-position-lessp start current-place) % Correct for (if (buffer-position-lessp current-place end) % the extraction. (setf current-place start) % Within extracted interval (setf current-place % After extracted interval (buffer-position-create (buffer-position-line current-place) (- (buffer-position-column current-place) (- (buffer-position-column end) (buffer-position-column start))))))) (extract-text t start end) (when (buffer-position-lessp (buffer-get-position) current-place) (setf current-place % Correct for new line break being added (buffer-position-create (+ (buffer-position-line current-place) 1) (- (buffer-position-column current-place) (current-char-pos))))) (insert-eol) (when fill-prefix (insert-text fill-prefix) (setf current-place % Correct for prefix length (buffer-position-create (buffer-position-line current-place) (+ (buffer-position-column current-place) (string-length (vector-fetch fill-prefix 0)))))))) (if word-too-long (move-to-end-of-line) (set-display-column fill-column))) (buffer-set-position current-place)))) |
Added psl-1983/3-1/nmode/binary/autofill.b version [7cc0598256].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/browser-browser.b version [fd8e2e67ea].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/browser-support.b version [a6487ff3f0].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/browser.b version [58e736a9a6].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffer-browser.b version [9d7f132439].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffer-io.b version [5c53e5693d].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffer-position.b version [f5b810e489].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffer-window.b version [989a9832a7].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffer.b version [7ee707fb8b].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/buffers.b version [722fbf3c78].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/case-commands.b version [85bdf6184e].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/command-input.b version [268561876d].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/commands.b version [a19abc0b36].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/dabbrevs.b version [f2b8abc0f0].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/defun-commands.b version [3a3db2b84c].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/dired.b version [b61c4f202e].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/dispatch.b version [7a0b8b23a3].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/doc.b version [940741a8ab].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/extended-input.b version [b4fe030f09].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/fileio.b version [fb20538f09].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/incr.b version [6c21657604].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/indent-commands.b version [11ae833721].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/kill-commands.b version [e8f237b4e6].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/lisp-commands.b version [e514e7bf5a].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/lisp-indenting.b version [070a08608a].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/lisp-interface.b version [fb20fcb891].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/lisp-parser.b version [4cf2a2a7cd].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/m-x.b version [2656c09f62].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/m-xcmd.b version [055fc0b222].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/mode-defs.b version [83d3bf6090].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/modes.b version [64968a5db9].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/move-commands.b version [6c6560f0c5].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/nmode-20.b version [8a4e714be3].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/nmode-break.b version [f136d8b512].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/nmode-init.b version [31884223dd].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/process.b version [710d514e97].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/prompting.b version [7e4a9e6805].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/query-replace.b version [294c486a97].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/reader.b version [2ec1d003e7].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/rec.b version [ac3317f397].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/screen-layout.b version [adeb22bc26].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/search.b version [97dab6b4d3].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/set-terminal.b version [80d3649017].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/softkeys.b version [c0b12259b8].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/structure-functions.b version [39cc624171].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/terminal-input.b version [face9117ab].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/text-buffer.b version [837a3c4eee].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/text-commands.b version [f548c44760].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/window-label-rewrite.b version [937a20c8c4].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/window-label.b version [6623a0aed4].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/binary/window.b version [2ed67167e4].
cannot compute difference between binary files
Added psl-1983/3-1/nmode/browser-browser.sl version [4ad7eec209].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Browser-Browser.SL - Browser Browser Subsystem % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 March 1983 % Revised: 12 April 1983 % % This file implements the browser browser subsystem. % % 12-April-83 Jeff Soreff % Bug fix: R and S commented out of the command list, pending sort % implementations. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load extended-char fast-strings)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(read-only-text-mode)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal static variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(browser-browser-mode browser-browser-command-list browser-browser-documentation-text browser-browser-help-text nmode-browser-prototypes )) (setf browser-browser-help-text ["? View-documentation Browse Kill uN/Ignore Quit"]) (setf browser-browser-documentation-text ["The Browser Browser displays all existing browsers, as well as" "prototypes for browsers that can be created. The Browse (B) command" "given when the cursor points at an existing browser will select" "that browser. The Browse (B) command given when the cursor points" "at a prototype browser will cause a new browser of that kind to be" "created, possibly after requesting additional information." "The View-Documentation (V) command will display information about" "the browser or prototype browser pointed at by the cursor." "The Kill (K) command will kill the browser pointed at by the cursor." "The Ignore (I) command will remove the pointed-at browser from the display." "The uNignore (N) command will restore all Ignored browsers to the display." "The Quit (Q) command will exit the browser browser." ]) (setf browser-browser-mode (nmode-define-mode "Browser-Browser" '( (nmode-define-commands browser-browser-command-list) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf browser-browser-command-list (list (cons (x-char ?) 'browser-help-command) (cons (x-char B) 'browser-browser-browse-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char K) 'browser-kill-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char Q) 'browser-exit-command) % (cons (x-char R) 'browser-browser-reverse-sort) % not implemented! % (cons (x-char S) 'browser-browser-sort) % not implemented! (cons (x-char V) 'browser-view-command) (cons (x-char SPACE) 'move-down-command) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-browser-command () % Bring up the browser browser subsystem. (let ((browser (or (find-browser 'BROWSER-BROWSER "") (create-browser-browser) ))) (browser-enter browser) )) (de create-browser-browser () % Create the browser browser subsystem. % The set of items is created when the browser buffer is selected. (let* ((b (create-unnamed-buffer browser-browser-mode)) (header-text (vector "NMODE Browsers" "")) ) (let ((browser (create-browser 'BROWSER-BROWSER "Browsers" "" browser-browser-mode NIL header-text browser-browser-documentation-text browser-browser-help-text () #'browser-browser-name-sorter) )) (=> browser set-select-function 'browser-update) (=> browser set-update-function 'browser-browser-update) (=> browser put 'browser-list ()) browser ))) (de browser-browser-update (browser) % Add any new browsers to the browser browser. (let* ((old-browser-list (=> browser get 'browser-list)) (new-browser-list (delq browser (all-browsers))) (old-prototype-list (=> browser get 'prototype-list)) (new-prototype-list nmode-browser-prototypes) (old-current-item (=> browser current-item)) (new-items (append (for (in br new-browser-list) (when (not (memq br old-browser-list))) (collect (create-browser-browser-item br)) ) (when (not (eq old-prototype-list new-prototype-list)) (for (in pr new-prototype-list) (when (not (memq pr old-prototype-list))) (collect pr) )) ))) (=> browser add-items new-items) (=> browser put 'browser-list new-browser-list) (=> browser put 'prototype-list new-prototype-list) (=> browser select-item old-current-item) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Special Browser Browser commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-browser-browse-command () (let ((item (browser-current-item))) (cond ((not item) (Ding)) ((eq (object-type item) 'BROWSER-BROWSER-ITEM) (browser-enter (=> item browser)) ) (t (=> item instantiate)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Sorting Predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-browser-name-sorter (b1 b2) (let* ((text1 (=> b1 display-text)) (text2 (=> b2 display-text)) ) (StringSortFN text1 text2) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The browser-browser-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-browser-browser-item (b) (make-instance 'browser-browser-item 'browser b )) (defflavor browser-browser-item (display-text browser ) () (gettable-instance-variables) (initable-instance-variables) ) (defmethod (browser-browser-item init) (init-plist) (=> self &update-display-text) ) (defmethod (browser-browser-item &update-display-text) () (let* ((kind-string (=> browser browser-kind-string)) (info-string (=> browser browser-info-string)) ) (setf display-text (string-concat " " kind-string)) (when (and info-string (not (string-empty? info-string))) (setf display-text (string-concat display-text " (" info-string ")"))) )) (defmethod (browser-browser-item update) () (when (browser-is-active? browser) (=> self &update-display-text) T )) (defmethod (browser-browser-item kill) () (kill-browser browser) ) (defmethod (browser-browser-item view-buffer) (x) (=> browser documentation-buffer) ) (defmethod (browser-browser-item cleanup) () ) (defmethod (browser-browser-item apply-filter) (filter) (apply filter (list browser)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The browser-browser-prototype-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de define-browser-prototype (create-function display-text documentation-text) (let ((item (create-browser-browser-prototype-item create-function display-text documentation-text ))) (setf nmode-browser-prototypes (cons item nmode-browser-prototypes)) )) (de create-browser-browser-prototype-item (create-fcn display-text doc-text) (make-instance 'browser-browser-prototype-item 'create-function create-fcn 'display-text display-text 'documentation-text doc-text )) (defflavor browser-browser-prototype-item (display-text create-function documentation-text documentation-buffer ) () (gettable-instance-variables display-text) (initable-instance-variables display-text create-function documentation-text) ) (defmethod (browser-browser-prototype-item init) (init-plist) (setf display-text (string-concat "Prototype: " display-text)) (setf documentation-buffer (create-unnamed-buffer read-only-text-mode)) (=> documentation-buffer insert-text documentation-text) (=> documentation-buffer insert-eol) (=> documentation-buffer set-modified? NIL) (=> documentation-buffer move-to-buffer-start) (=> documentation-buffer set-label-string (string-concat "(Documentation on " display-text ")")) ) (defmethod (browser-browser-prototype-item update) () T ) (defmethod (browser-browser-prototype-item kill) () NIL ) (defmethod (browser-browser-prototype-item view-buffer) (x) documentation-buffer ) (defmethod (browser-browser-prototype-item cleanup) () ) (defmethod (browser-browser-prototype-item apply-filter) (filter) T ) (defmethod (browser-browser-prototype-item instantiate) () (apply create-function '()) ) |
Added psl-1983/3-1/nmode/browser-support.sl version [bb9c41baf7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Browser-Support.SL - General Browser Support % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 October 1982 % Revised: 14 March 1983 % % 14-Mar-83 Alan Snyder % Added functions to find existing browsers. New functions: % browser-current-item, browser-view-buffer, browser-edit-buffer, % browser-help-command, browser-exit, current-browser, kill-browser, % kill-browser-command, browser-update. Change browser-enter to take browser % as arg instead of buffer. Fix browser-enter and browser-exit to % restore old buffers upon exit. % 4-Mar-83 Alan Snyder % New functions: browser-add-item, browser-add-items. % 3-Feb-83 Alan Snyder % Revised to use Browser objects. % % This file contains support functions for browsers, such as the Buffer % Browser and DIRED. A browser is a buffer that displays a set of items, one % item per line, and allows the individual items to be manipulated. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load numeric-operators)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-top-window nmode-bottom-window nmode-current-buffer nmode-current-window nmode-command-argument nmode-command-argument-given )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % User options: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '( browser-split-screen )) (setf browser-split-screen NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal Static Variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-active-browsers)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % General Browser Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-register-browser (browser) % Add the specified browser to the list of active browsers. This list is % used to create the items for the browser browser, for example. This % function is called by create-browser. (if (unboundp 'nmode-active-browsers) (setf nmode-active-browsers ())) (when (not (memq browser nmode-active-browsers)) (setf nmode-active-browsers (cons browser nmode-active-browsers))) ) (de nmode-unregister-browser (browser) % Remove the specified browser from the list of active browsers. (if (unboundp 'nmode-active-browsers) (setf nmode-active-browsers ())) (when (memq browser nmode-active-browsers) (setf nmode-active-browsers (delq browser nmode-active-browsers))) ) (de browser-is-active? (browser) (memq browser nmode-active-browsers) ) (de browser-enter (browser) % Start up a browser. (let ((wp (nmode-window-position))) (=> browser put 'window-status wp) (=> browser put 'old-top (=> (=> nmode-top-window buffer) name)) (=> browser put 'old-bottom (when browser-split-screen (=> (=> nmode-bottom-window buffer) name))) (if browser-split-screen (if (eq wp 'bottom) (nmode-switch-windows)) (nmode-1-window) )) (=> browser enter) ) (de browser-exit (browser) % Exit the browser, which means to detach its buffers from windows and % restore the window to its previous state. (let* ((ws (=> browser get 'window-status)) (old-top (=> browser get 'old-top)) (old-bottom (=> browser get 'old-bottom)) ) (nmode-set-window-position ws) (when old-top (window-select-buffer nmode-top-window (buffer-find old-top))) (when old-bottom (window-select-buffer nmode-bottom-window (buffer-find old-bottom))) (=> browser exit) )) (de kill-browser (browser) % Kill the browser, which means exit it and then remove it from the list % of active browsers (which should allow it to be garbage collected). (=> browser exit) (nmode-unregister-browser browser) ) (de all-browsers () % Return a list of all active browsers. The list should not be modified. nmode-active-browsers ) (de all-browsers-of-a-kind (browser-kind-id) % Return a list of all existing browsers of the specified kind. (for (in br (all-browsers)) (when (eq (=> br browser-kind) browser-kind-id)) (collect br) )) (de find-browser (browser-kind-id info-string) % Search for a browser of the specified kind with the specified info string. (for (in br (all-browsers-of-a-kind browser-kind-id)) (when (equal (=> br browser-info-string) info-string)) (do (exit br)) )) (de browser-update (browser) (=> browser update-items) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Browser commands: attach these to keys in your browser mode %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-kill-and-exit-command () (browser-kill-deleted-items-command) (browser-exit-command) ) (de browser-exit-command () % Exit the current browser. This removes the browser from the display, % but does not destroy it (it can be reentered). (let ((browser (current-browser))) (when browser (browser-exit browser) ))) (de kill-browser-command () % Kill the current browser. This removes the browser from the display, % and removes it from the active browser list (it cannot be reentered). (let ((browser (current-browser))) (when browser (kill-browser browser) ))) (de browser-delete-command () % Mark items as 'deleted'. (browser-do-repeated-command 'delete-item () nil) ) (de browser-undelete-command () % Mark items as not 'deleted'. (browser-do-repeated-command 'undelete-item () nil) ) (de browser-undelete-backwards-command () % Mark items as not 'deleted'. (setf nmode-command-argument (- nmode-command-argument)) (browser-do-repeated-command 'undelete-item () nil) ) (de browser-kill-command () % Kill items. (browser-do-repeated-command 'kill-item () t) ) (de browser-ignore-command () % Ignore items: filter them out. (browser-do-repeated-command 'ignore-item () t) ) (de browser-view-command () % View the current item. (let ((buffer (browser-view-item-in-buffer))) (if buffer (browser-view-buffer buffer nmode-command-argument-given) (Ding) ))) (de browser-edit-command () % Edit the current item. (let ((buffer (browser-view-item-in-buffer))) (if buffer (browser-edit-buffer buffer nmode-command-argument-given) (Ding) ))) (de browser-kill-deleted-items-command () (let ((browser (current-browser))) (=> browser kill-deleted-items) )) (de browser-undo-filter-command () (let* ((browser (current-browser)) (filter (=> browser undo-filter)) ) (if filter (set-prompt (bldmsg "Application of %w undone." filter)) (nmode-error "No filters have been applied to create this list.") ))) (de browser-help-command () (let ((browser (current-browser))) (when browser (=> browser display-documentation) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Browser functions: use these in browser commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-browser () (=> nmode-current-buffer get 'browser)) (de browser-sort (prompt sorter) (let ((browser (current-browser))) (=> browser sort sorter) (write-prompt prompt) )) (de browser-current-item () % Return the current item, if any, NIL otherwise. (let ((browser (current-browser))) (when browser (=> browser current-item) ))) (de browser-view-item (w) % View the current item in the specified window. Return T if successful, % NIL otherwise. (let ((buffer (browser-view-item-in-buffer))) (when buffer (=> buffer set-previous-buffer nmode-current-buffer) (window-select-buffer w buffer) T ))) (de browser-view-item-in-buffer () % View the current item in a buffer. Return the buffer if successful, % NIL otherwise. The buffer is not attached to any window. (let ((browser (current-browser))) (when browser (=> browser view-item) ))) (de browser-view-buffer (b invert-split-screen-option) % View the buffer B like an item is viewed. (let* ((use-other (xor browser-split-screen invert-split-screen-option)) (w (if use-other (nmode-other-window) nmode-current-window)) ) (=> b set-previous-buffer nmode-current-buffer) (window-select-buffer w b) (if use-other (nmode-2-windows) % display the other window (set-message "C-M-L returns to browser.") ))) (de browser-edit-buffer (b invert-split-screen-option) % Edit the buffer B like an item is edited. (let* ((use-other (xor browser-split-screen invert-split-screen-option)) (w (if use-other (nmode-other-window) nmode-current-window)) ) (=> b set-previous-buffer nmode-current-buffer) (window-select-buffer w b) (cond (use-other (nmode-2-windows) % display the other window (nmode-select-window w) (set-message "C-X O returns to browser.") ) (t (set-message "C-M-L returns to browser.") )))) (de browser-add-item-and-view (new-item) % Add the item to the current browser. Then, if in split screen mode, % view the item. (browser-add-item new-item) (when browser-split-screen (setf nmode-command-argument-given NIL) (browser-view-command) )) (de browser-add-item (new-item) % Add the item to the current browser. (let ((browser (current-browser))) (when browser (=> browser add-item new-item) T ))) (de browser-add-items (new-item-list) % Add the items to the current browser. (let ((browser (current-browser))) (when browser (=> browser add-items new-item-list) T ))) (de browser-do-repeated-command (msg args removes?) % Perform a browser command that takes a signed numeric argument to mean % a repetition count. On each iteration, the browser is sent % the specified message with the specified arguments. If REMOVES? is % true, then the browser operation may remove the current item and % it will return true if it does. (let ((browser (current-browser))) (if (> nmode-command-argument 0) (for (from i 1 nmode-command-argument) (do (when (not (=> browser current-item)) (Ding) (exit)) (if (not (and (lexpr-send browser msg args) removes?)) (move-to-next-line) ))) (for (from i 1 (- nmode-command-argument)) (do (when (current-line-is-first?) (Ding) (exit)) (move-to-previous-line) (when (not (=> browser current-item)) (move-to-next-line) (Ding) (exit)) (lexpr-send browser msg args) )) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/browser.sl version [0027d50836].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Browser.SL - Browser object definition % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 February 1983 % Revised: 14 March 1983 % % This file implements browser objects. These objects form the basis of a % general browser support mechanism. See Browser-Support.SL for additional % support functions and Buffer-Browser.SL for an example of a browser using % this mechanism. % % 14-Mar-83 Alan Snyder % New methods: enter, select, display-documentation, set-items, update-items, % filter-count, get, put. New documentation fields, etc. Create-Browser % changed incompatibly. % 4-Mar-83 Alan Snyder % New methods: add-item and add-items. % 14-Feb-83 Alan Snyder % Fix bug in filter application (was trying to apply a macro). % 11-Feb-83 Alan Snyder % Fix &remove-current-item to reset the display buffer's modified flag. % Improve comments. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-vectors numeric-operators)) (on fast-integers) (load gsort) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-top-window nmode-bottom-window nmode-current-window nmode-current-buffer browser-split-screen read-only-text-mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-browser (browser-kind browser-kind-string browser-info-string display-buffer-mode view-buffer header-text documentation-text help-text items current-sorter ) % Create a brower. BROWSER-KIND should be an ID that identifies the kind of % browser this is. This ID is provided for optional use by the creator of % the browser to locate existing browsers of its kind. BROWSER-KIND-STRING % should be a string that identifies the kind of browser this is. This % STRING is used in the browser browser display. BROWSER-INFO-STRING should % be a string that identifies this particular browser, as differentiated % from others of the same kind. This STRING is used in the browser browser % display. % DISPLAY-BUFFER-MODE is the mode to use for the browser display buffer. % VIEW-BUFFER is the buffer to use for viewing an item; if NIL, the item is % expected to provide its own buffer. HEADER-TEXT is a vector of strings to % display at the top of the display buffer; it may be NIL. % DOCUMENTATION-TEXT is a vector of strings to display in the documentation % buffer, which is displayed in the bottom window when there is no % currently-viewed item; it may be NIL. HELP-TEXT is a vector of strings to % display at the bottom of the screen; it may be NIL. The HELP-TEXT should % briefly list the available commands. (Currently the HELP-TEXT should % consist of at most one string, which will be displayed in the message % window.) ITEMS is a list or vector containing the set of items to display % (this data structure will not be modified). CURRENT-SORTER may be NIL or % a function ID. If non-NIL, the function will be used to sort the initial % set of items. (let ((browser (make-instance 'browser 'browser-kind browser-kind 'browser-kind-string browser-kind-string 'browser-info-string browser-info-string 'display-buffer-mode display-buffer-mode 'view-buffer view-buffer 'header-text header-text 'documentation-text documentation-text 'help-text help-text 'items items 'current-sorter current-sorter 'display-width (=> nmode-top-window width) ))) (nmode-register-browser browser) browser )) (defflavor browser ((browser-kind NIL) % ID identifying kind of browser (browser-kind-string "") % string identifying kind of browser (browser-info-string "") % string describing this particular browser (select-function NIL) % function to invoke when selected (arg: self) (update-function NIL) % function to invoke when updated (arg: self) display-width (display-buffer-mode NIL) % mode of browser display buffer display-buffer % buffer used to display items (view-buffer NIL) % buffer used to view items (NIL => ask item) documentation-buffer % buffer used to display documentation (header-text NIL) % text displayed at top of buffer first-item-linepos % line number of first item in display (documentation-text NIL) % text displayed in documentation buffer (help-text NIL) % text displayed in help line items % vector of visible items (may have junk at end) last-item-index % index of last valid item in ITEMS vector (viewed-item NIL) % the item most recently viewed (or NIL) filtered-items % list of lists of items removed by filtering (current-sorter NIL) % sorter used if items are un-filtered (p-list NIL) % association list of properties ) () (gettable-instance-variables browser-kind browser-kind-string display-width display-buffer help-text documentation-buffer ) (settable-instance-variables browser-info-string select-function update-function ) (initable-instance-variables browser-kind browser-kind-string display-width display-buffer-mode view-buffer header-text documentation-text help-text items current-sorter) ) % Methods provided by items: % % (=> item display-text) % Return string used to display the item. % % (=> item delete) % Mark the item as deleted. May do nothing if deletion is not supported. % May change the display-text. This method need not be provided if no % delete commands are provided in the particular browser. % % (=> item undelete) % Mark the item as not deleted. May do nothing if deletion is not % supported. May change the display-text. This method need not be provided % if no delete commands are provided in the particular browser. % % (=> item deleted?) % Return T if the item has been marked for deletion. This method need not % be provided if no delete commands are provided in the particular browser. % % (=> item kill) % Kill the real item. (Instead of just marking the item for deletion, this % should actually dispose of the item, if that action is supported.) May do % nothing if killing is not supported. Return T if the item is actually % killed, NIL otherwise. This method need not be provided if no delete % commands are provided in the particular browser. % % (=> item view-buffer buffer) % Return a buffer containing the item for viewing. If the buffer argument % is non-NIL, then that buffer should be used for viewing. Otherwise, the % item must provide its own buffer. % % (=> item cleanup) % Throw away any unneeded stuff, such as a buffer created for viewing. This % method is invoked when an item is no longer being viewed, or when the item % is being filtered out, or when the browser is being exited. % % (=> item update) % The item should check for any changes in the object that it represents and % update itself accordingly. This method should return NIL if and only if % the object no longer exists, in which case it will be removed. (The item % should clean itself up in this case.) Updating is performed on active % items by the update-items method; in addtion, items that are unfiltered % are also updated at that time. % % (=> item apply-filter filter) % The item should apply the filter to itself and return T if the filter % matches the item and NIL otherwise. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods for browsers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (browser select) () % This method is invoked when the browser buffer is newly selected. (=> self &display-viewed-item) (=> self display-help) (when select-function (apply select-function (list self))) ) (defmethod (browser enter) () % Entering a browser means selecting its display buffer in the current % window. (when (not (eq display-buffer nmode-current-buffer)) (=> display-buffer set-previous-buffer nmode-current-buffer)) (buffer-select display-buffer) ) (defmethod (browser exit) () % Exiting a browser means to clean up its items and detach any of its % buffers from any windows. It is still an active browser and may be % reentered later. (for (from i 0 last-item-index) (do (=> (vector-fetch items i) cleanup))) (if display-buffer (buffer-kill-and-detach display-buffer)) (if documentation-buffer (buffer-kill-and-detach documentation-buffer)) (if view-buffer (buffer-kill-and-detach view-buffer)) ) (defmethod (browser display-help) () (when (and help-text (not (vector-empty? help-text))) (write-message (vector-fetch help-text 0)) )) (defmethod (browser display-documentation) () (=> documentation-buffer move-to-buffer-start) (=> self &set-viewed-item NIL) (cond (browser-split-screen (=> nmode-bottom-window set-line-position 0) (=> nmode-bottom-window adjust-window) ) (t (browser-view-buffer documentation-buffer NIL) ))) (defmethod (browser current-item) () % Return the current item, which is the item that is displayed on the % display-buffer's current line, or NIL, if there is no such item. (let ((index (- (=> display-buffer line-pos) first-item-linepos))) (when (and (>= index 0) (<= index last-item-index)) (vector-fetch items index) ))) (defmethod (browser current-item-index) () % Return the index of the current item, which is the item that is displayed % on the display-buffer's current line, or NIL, if there is no such item. (let ((index (- (=> display-buffer line-pos) first-item-linepos))) (when (and (>= index 0) (<= index last-item-index)) index ))) (defmethod (browser add-item) (new-item) % Add the specified item to the set of items. If a sort function is % currently defined, it will be used to sort the set of items. The new item % becomes the current item. (=> self add-items (list new-item)) ) (defmethod (browser add-items) (new-item-list) % Add the specified items to the set of items. If a sort function is % currently defined, it will be used to sort the set of items. The first % new item becomes the current item. (when new-item-list (let ((new-current-item (first new-item-list))) (=> self &insert-items new-item-list) (=> self &sort-items) (=> self &update-display) (=> self select-item new-current-item) ))) (defmethod (browser kill-item) () % Kill the current item, if any. Return T if the item is killed, % NIL otherwise. (let ((item (=> self current-item))) (when (=> item kill) (=> self &remove-current-item) ))) (defmethod (browser kill-deleted-items) () % Attempts to KILL all items that have been marked for deletion. % Returns a list of the items actually killed. (=> self &keep-items '&browser-item-not-killed ()) ) (defmethod (browser delete-item) () % Mark the current item as deleted, if any. Return T if the item exists, % NIL otherwise. (let ((item (=> self current-item))) (when item (=> item delete) (=> self &update-current-item) T ))) (defmethod (browser undelete-item) () % Mark the current item as not deleted, if any. Return T if the item exists, % NIL otherwise. (let ((item (=> self current-item))) (when item (=> item undelete) (=> self &update-current-item) T ))) (defmethod (browser view-item) () % View the current item, if any, in a separate buffer. Return the buffer if % the item exists, NIL otherwise. (let ((item (=> self current-item))) (when item (=> self &set-viewed-item item) (=> item view-buffer view-buffer) % return the buffer ))) (defmethod (browser ignore-item) () % Ignore the current item, if any. Return T if the item exists. Ignoring % an item is like running a filter that accepts every item except the % current one, except that multiple successive ignores coalesce into one % filtered-item-set for undoing purposes. (let ((item (=> self &remove-current-item))) (when item (cond ((and filtered-items (eqcar (car filtered-items) 'IGNORE-COMMAND)) % add this item to the previous list of ignored items (let ((filter-set (car filtered-items))) (setf (cdr filter-set) (cons item (cdr filter-set))) )) (t (setf filtered-items (cons (list 'IGNORE-COMMAND item) filtered-items)) ))))) (defmethod (browser update-items) () % Ask all active items to update themselves. Items that report that they % are no longer meaningful will be removed. Then, the update-function % is called. This function may choose to add new items for objects that % have been created since the browser was created. (=> self &keep-items 'ev-send '(update)) (when update-function (apply update-function (list self)) )) (defmethod (browser filter-items) (filter) % Remove those items that do not match the specified filter. If some items % are removed, then they are added as a set to the list of filtered items, % so that this step can be undone, and T is returned. Otherwise, no new set % is created, and NIL is returned. (let ((filtered-list (=> self &keep-items 'ev-send (list 'apply-filter (list filter))))) (when filtered-list (setf filtered-list (cons filter filtered-list)) (setf filtered-items (cons filtered-list filtered-items)) T ))) (defmethod (browser undo-filter) () % Undo the effect of the most recent active filtering step. Return the % filter or NIL if there are no active filtering steps. All unfiltered % items are asked to update themselves. Items that report that they are no % longer meaningful will be removed. (when filtered-items (let ((filter (car (car filtered-items))) (the-items (cdr (car filtered-items))) (current-item (=> self current-item)) ) (setf filtered-items (cdr filtered-items)) (while the-items (let ((item (car the-items))) (setf the-items (cdr the-items)) (when (=> item update) (setf last-item-index (+ last-item-index 1)) (vector-store items last-item-index item) ))) (=> self &sort-items) (=> self &update-display) (=> self select-item current-item) filter ))) (defmethod (browser filter-count) () % Return the number of active filters. (length filtered-items) ) (defmethod (browser items) () % Return a list of the active (unfiltered) items. (for (from i 0 last-item-index) (collect (vector-fetch items i))) ) (defmethod (browser set-items) (new-items) % Replace the entire existing set of items (both active items and filtered % items) with a new set of items. NEW-ITEMS may be a list or a vector. (for (from i 0 last-item-index) (do (=> (vector-fetch items i) cleanup))) (setf items (cond ((ListP new-items) (List2Vector new-items)) ((VectorP new-items) (CopyVector new-items)) (t (Vector)) )) (setf last-item-index (vector-upper-bound items)) (setf filtered-items ()) (=> self &set-viewed-item NIL) (=> self &sort-items) (=> self &update-display) ) (defmethod (browser sort) (sorter) % Specify a new sorting function and sort the items accordingly. (let ((current-item (=> self current-item))) (setf current-sorter sorter) (=> self &sort-items) (=> self &update-display) (=> self select-item current-item) )) (defmethod (browser send-item) (msg args) % Send the current item, if any, the specified message with the specified % arguments. Return NIL if there is no current item; otherwise, return the % result of sending the message to the item. (let ((item (=> self current-item))) (when item (prog1 (lexpr-send item msg args) (=> self &update-current-item) )))) (defmethod (browser select-item) (item) % If ITEM is not NIL, then adjust the buffer pointer to point to that item. (for (from i 0 last-item-index) (do (when (eq item (vector-fetch items i)) (=> display-buffer goto (+ i first-item-linepos) 0) (exit) )))) (defmethod (browser get) (property-name) % Return the object associated with the specified property name (ID). % Returns NIL if named property has not been defined. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (cdr pair)))) (defmethod (browser put) (property-name property) % Associate the specified object with the specified property name (ID). % GET on that property-name will henceforth return the object. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (rplacd pair property) (setf p-list (cons (cons property-name property) p-list)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (browser init) (init-plist) (setf last-item-index -1) (when (not display-buffer-mode) (setf display-buffer-mode Read-Only-Text-Mode)) (setf display-buffer (create-unnamed-buffer display-buffer-mode)) (when (and browser-info-string (not (string-empty? browser-info-string))) (=> display-buffer set-label-string (string-concat "(" browser-info-string ")") )) (setf documentation-buffer (create-unnamed-buffer Read-Only-Text-Mode)) (when documentation-text (=> documentation-buffer insert-text documentation-text) (=> documentation-buffer insert-eol) (=> documentation-buffer set-modified? NIL) (=> documentation-buffer move-to-buffer-start) (=> documentation-buffer set-label-string (string-concat "(Documentation on " browser-kind-string " browser)")) ) (let ((old-browser (=> display-buffer get 'browser))) (when old-browser (=> old-browser exit) )) (=> display-buffer put 'browser self) (=> self set-items items) ) (defmethod (browser &update-display) () % Update the display. The cursor is moved to the first item. (=> display-buffer reset) (when header-text (=> display-buffer insert-text header-text) (=> display-buffer insert-eol) ) (setf first-item-linepos (=> display-buffer line-pos)) (for (from i 0 last-item-index) (do (let ((item (vector-fetch items i))) (=> display-buffer insert-line (=> item display-text)) ))) (=> display-buffer set-modified? NIL) (=> display-buffer goto first-item-linepos 0) ) (defmethod (browser &set-viewed-item) (item) (when (not (eq item viewed-item)) (if viewed-item (=> viewed-item cleanup)) (setf viewed-item item) (when (not viewed-item) (=> self &display-viewed-item)) )) (defmethod (browser &display-viewed-item) () % This method causes the viewed item to be displayed in the bottom window, % if the browser is selected in the top window and the split-screen option % is selected. If there is no viewed item, then the documentation buffer is % displayed. (when (and (eq nmode-current-window nmode-top-window) browser-split-screen) (let ((b (if viewed-item (=> viewed-item view-buffer view-buffer) documentation-buffer ))) (when b (=> b set-previous-buffer nmode-current-buffer) (window-select-buffer (nmode-other-window) b) (nmode-2-windows) )))) (defmethod (browser &sort-items) () % Sort the items according to the current sorter, if any. % Do not update the display buffer. (when current-sorter (let ((list ())) (for (from i 0 last-item-index) (do (setf list (cons (vector-fetch items i) list))) ) (setf list (GSort list current-sorter)) (for (from i 0 last-item-index) (do (vector-store items i (car list)) (setf list (cdr list)) )) ))) (defmethod (browser &insert-items) (item-list) % Add the specified items to the end of the current set of items. The % vector size is increased to ensure there is room for all items, including % any that may have been filtered out. (let ((new-items (mkvect (+ (vector-upper-bound items) (length item-list))))) (for (from i 0 last-item-index) (do (vector-store new-items i (vector-fetch items i)))) (for (in item item-list) (do (setf last-item-index (+ last-item-index 1)) (vector-store new-items last-item-index item) )) (setf items new-items) )) (defmethod (browser &remove-current-item) () % Remove the current item from ITEMS and the display. % Return the item or NIL if there is no current item. (let ((index (=> self current-item-index))) (when index (let ((item (vector-fetch items index))) (when (eq item viewed-item) (=> self &set-viewed-item NIL)) (for (from i (+ index 1) last-item-index) (do (vector-store items (- i 1) (vector-fetch items i)) )) (vector-store items last-item-index NIL) (setf last-item-index (- last-item-index 1)) (=> display-buffer move-to-start-of-line) (let ((start-pos (=> display-buffer position))) (=> display-buffer move-to-next-line) (=> display-buffer extract-region T start-pos (=> display-buffer position)) (=> display-buffer set-modified? NIL) ) item )))) (defmethod (browser &update-current-item) () % Update the display for the current item. (let ((index (=> self current-item-index))) (when index (let ((item (vector-fetch items index))) (=> display-buffer store-line (+ index first-item-linepos) (=> item display-text)) (=> display-buffer set-modified? NIL) )))) (defmethod (browser &keep-items) (fcn args) % Apply the function FCN once for each item. The first argument to FCN % is the item; the remaining items are ARGS (a list). % Remove those items for which FCN returns NIL and return them % in a list of items. (let ((removed-items ()) (ptr 0) (current-item-index (=> self current-item-index)) (new-current-item-index 0) ) (for (from i 0 last-item-index) (do (let ((item (vector-fetch items i)) (this-ptr ptr) ) (cond ((apply fcn (cons item args)) % keep it (vector-store items ptr item) (setf ptr (+ ptr 1)) ) (t % remove it (setf removed-items (cons item removed-items)) (=> item cleanup) (when (eq item viewed-item) (=> self &set-viewed-item NIL)) )) (when (and current-item-index (= i current-item-index)) (setf new-current-item-index this-ptr)) ))) (setf last-item-index (- ptr 1)) (=> self &update-display) (=> display-buffer goto (+ new-current-item-index first-item-linepos) 0) removed-items )) (de &browser-item-not-killed (item) (or (not (=> item deleted?)) (not (=> item kill)) )) |
Added psl-1983/3-1/nmode/buffer-browser.sl version [ddb21b4f09].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-Browser.SL - Buffer Browser Subsystem % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 October 1982 % Revised: 8 April 1983 % % This file implements a buffer browser subsystem. % % 8-April-83 Jeff Soreff % Filter commands, predicate, and associated funtions implemented. % Declare is used to speed up code somewhat. % 14-Mar-83 Alan Snyder % Convert for revised browser mechanism (with documentation, etc.) % 4-Mar-83 Alan Snyder % Added Create command. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 4-Feb-83 Alan Snyder % Rewritten using new browser support. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load extended-char fast-vectors fast-strings stringx numeric-operators)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '( nmode-selectable-buffers )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal static variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(buffer-browser-mode buffer-browser-command-list buffer-browser-documentation-text buffer-browser-help-text buffer-browser-argument-list )) (setf buffer-browser-help-text ["? View Edit Filter Write Create Un/Delete Kill uN/Ignore Sort/Reverse Quit"]) (setf buffer-browser-documentation-text ["The Buffer Browser displays the existing editor buffers." "Terminology: the current buffer is the buffer pointed at by the cursor." "The View (V) and Edit (E) commands both display the current buffer." "In split-screen mode, Edit selects the bottom window while View does not." "The Write (W) command saves the current buffer in its file, if needed." "The Create (C) command creates a new buffer, but does not select it." "The Delete (D) command marks the current buffer for deletion upon Quit." "The Undelete (U) command removes the mark made by the Delete command." "The Kill (K) command kills the current buffer immediately." "The Ignore (I) command removes the current buffer from the display." "The Filter (F) command ignores buffer sets, using names, modes and files." "The uNignore (N) command restores all Ignored buffers to the display." "The Sort (S) command sorts the buffers in various ways." "The Reverse (R) command sorts the buffers in reverse order." "The Quit (Q) command exits the browser and deletes any marked buffers." ]) (setf buffer-browser-mode (nmode-define-mode "Buffer-Browser" '( (nmode-define-commands Buffer-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf buffer-browser-command-list (list (cons (x-char ?) 'browser-help-command) (cons (x-char C) 'buffer-browser-create-command) (cons (x-char D) 'browser-delete-command) (cons (x-char E) 'browser-edit-command) (cons (x-char W) 'buffer-browser-save-file-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char K) 'browser-kill-command) (cons (x-char F) 'buffer-browser-filter-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char Q) 'browser-kill-and-exit-command) (cons (x-char R) 'buffer-browser-reverse-sort) (cons (x-char S) 'buffer-browser-sort) (cons (x-char U) 'browser-undelete-command) (cons (x-char V) 'browser-view-command) (cons (x-char X) 'browser-exit-command) (cons (x-char BACKSPACE) 'browser-undelete-backwards-command) (cons (x-char RUBOUT) 'browser-undelete-backwards-command) (cons (x-char SPACE) 'move-down-command) (cons (x-char M-~) 'buffer-browser-not-modified-command) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-browser-command () % Bring up the buffer browser subsystem. (let ((browser (or (find-browser 'BUFFER-BROWSER "") (create-buffer-browser) ))) (browser-enter browser) )) (de create-buffer-browser () % Create the buffer browser subsystem. % The set of items is created when the browser is selected. (let* ((header-text (vector (string-concat " " (string-pad-right "Buffer Name" 24) (string-pad-left "Size" 6) " " "File Name" ) "" )) (browser (create-browser 'BUFFER-BROWSER "Buffers" "" buffer-browser-mode NIL header-text buffer-browser-documentation-text buffer-browser-help-text () #'buffer-browser-name-sorter) )) (=> browser set-select-function 'browser-update) (=> browser set-update-function 'buffer-browser-update) (=> browser put 'buffer-list ()) browser )) (de buffer-browser-update (browser) % Add any new buffers to the buffer browser. (let* ((width (=> browser display-width)) (old-buffer-list (=> browser get 'buffer-list)) (old-current-item (=> browser current-item)) (new-items (for (in b nmode-selectable-buffers) (when (not (memq b old-buffer-list))) (collect (create-buffer-browser-item b width)) )) ) (=> browser add-items new-items) (=> browser put 'buffer-list nmode-selectable-buffers) (=> browser select-item old-current-item) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Special Buffer Browser commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-browser-create-command () (let* ((browser (current-browser)) (new-buffer-name (prompt-for-string "Create buffer whose name is:" NIL)) (b (buffer-create-default new-buffer-name)) (item (create-buffer-browser-item b (=> browser display-width))) ) (write-prompt (bldmsg "Buffer %w created." (=> b name))) (=> browser put 'buffer-list (cons b (=> browser get 'buffer-list))) (browser-add-item-and-view item) )) (de buffer-browser-save-file-command () (browser-do-repeated-command 'send-item '(save-file ()) NIL) ) (de buffer-browser-not-modified-command () (browser-do-repeated-command 'send-item '(set-unmodified ()) NIL) ) (de buffer-browser-reverse-sort () (nmode-set-immediate-prompt "Reverse Sort by ") (buffer-browser-reverse-sort-dispatch) ) (de buffer-browser-reverse-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/N (browser-sort "Reverse Sort by Name" 'buffer-browser-name-reverser)) (#/S (browser-sort "Reverse Sort by Size" 'buffer-browser-size-reverser)) (#/F (browser-sort "Reverse Sort by File" 'buffer-browser-file-reverser)) (#/M (browser-sort "Reverse Sort by Modified" 'buffer-browser-modified-reverser)) (#/? (nmode-set-immediate-prompt "Reverse Sort by (Name, Size, File, Modified) ") (buffer-browser-reverse-sort-dispatch) ) (t (write-prompt "") (Ding)) )) (de buffer-browser-sort () (nmode-set-immediate-prompt "Sort by ") (buffer-browser-sort-dispatch) ) (de buffer-browser-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/N (browser-sort "Sort by Name" 'buffer-browser-name-sorter)) (#/S (browser-sort "Sort by Size" 'buffer-browser-size-sorter)) (#/F (browser-sort "Sort by File" 'buffer-browser-file-sorter)) (#/M (browser-sort "Sort by Modified" 'buffer-browser-modified-sorter)) (#/? (nmode-set-immediate-prompt "Sort by (Name, Size, File, Modified) ") (buffer-browser-sort-dispatch) ) (t (write-prompt "") (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Filtering Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-browser-filter-command () (nmode-set-immediate-prompt "Filter by File-name, Mode, or Name?") (buffer-browser-filter-dispatch1)) (de buffer-browser-filter-dispatch1 () (selectq (char-upcase (input-base-character)) (#/F (buffer-browser-filter-prompter2 (list "file-name" #'buffer-browser-file-name-extractor))) (#/M (buffer-browser-filter-prompter2 (list "mode" #'buffer-browser-mode-extractor))) (#/N (buffer-browser-filter-prompter2 (list "name" #'buffer-browser-name-extractor))) (#/? (nmode-set-immediate-prompt "Type F for File-name, M for Mode, N for Name") (buffer-browser-filter-dispatch1)) (t (write-prompt "") (Ding)))) (declare-flavor text-buffer item-buffer) (de buffer-browser-file-name-extractor (item-buffer) (=> item-buffer file-name)) (declare-flavor mode mode-temp) (de buffer-browser-mode-extractor (item-buffer) (let ((mode-temp (=> item-buffer mode))) (=> mode-temp name))) (undeclare-flavor mode-temp) (de buffer-browser-name-extractor (item-buffer) (=> item-buffer name)) (undeclare-flavor item-buffer) (de buffer-browser-filter-prompter2 (aspect) (nmode-set-immediate-prompt "Flush or Keep matching buffers?") (buffer-browser-filter-dispatch2 aspect)) (de buffer-browser-filter-dispatch2 (aspect) (selectq (char-upcase (input-base-character)) (#/F (buffer-browser-filter-compose t aspect)) (#/K (buffer-browser-filter-compose nil aspect)) (#/? (nmode-set-immediate-prompt (bldmsg "Type F to flush or K to keep buffers with matching %ws." (first aspect))) (buffer-browser-filter-dispatch2 aspect)) (t (write-prompt "") (Ding)))) (de buffer-browser-filter-compose (flag aspect) (let ((browser (current-browser)) (buffer-browser-argument-list (list (string-upcase % Make the search pattern upper case. (prompt-for-string (bldmsg "%w buffers with %w matching string" (if flag "flush" "keep") (first aspect)) "")) flag % Keep or flush flag (second aspect)))) % extractor function (=> browser filter-items #'buffer-browser-filter-predicate))) (declare-flavor buffer-browser-item buffer-browser-item) (de buffer-browser-filter-predicate (buffer-browser-item) (let* ((aspect (or (apply (third buffer-browser-argument-list) (list (=> buffer-browser-item buffer))) "")) (match (forward-search-in-string aspect (first buffer-browser-argument-list)))) (when (second buffer-browser-argument-list) (setf match (not match))) match)) (undeclare-flavor buffer-browser-item) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Sorting Predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor buffer-browser-item b1 b2) (de buffer-browser-name-sorter (b1 b2) (let ((name1 (=> (=> b1 buffer) name)) (name2 (=> (=> b2 buffer) name)) ) (StringSortFn name1 name2) )) (de buffer-browser-name-reverser (b1 b2) (not (buffer-browser-name-sorter))) (de buffer-browser-size-sorter (b1 b2) (let ((s1 (=> (=> b1 buffer) visible-size)) (s2 (=> (=> b2 buffer) visible-size)) ) (or (< s1 s2) (and (= s1 s2) (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-size-reverser (b1 b2) (let ((s1 (=> (=> b1 buffer) visible-size)) (s2 (=> (=> b2 buffer) visible-size)) ) (or (> s1 s2) (and (= s1 s2) (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-file-sorter (b1 b2) (let ((f1 (or (=> (=> b1 buffer) file-name) "")) (f2 (or (=> (=> b2 buffer) file-name) "")) ) (StringSortFn f1 f2) )) (de buffer-browser-file-reverser (b1 b2) (not (buffer-browser-file-sorter b1 b2))) (de buffer-browser-modified-sorter (b1 b2) (let ((m1 (=> (=> b1 buffer) modified?)) (m2 (=> (=> b2 buffer) modified?)) ) (cond ((not (eq m1 m2)) (=> (=> b1 buffer) modified?)) % saying 'M1' results in compiler bug (t (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-modified-reverser (b1 b2) (let ((m1 (=> (=> b1 buffer) modified?)) (m2 (=> (=> b2 buffer) modified?)) ) (cond ((not (eq m1 m2)) (=> (=> b2 buffer) modified?)) % saying 'M2' results in compiler bug (t (buffer-browser-name-sorter b1 b2)) ))) (undeclare-flavor b1 b2) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The buffer-browser-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-buffer-browser-item (b width) (make-instance 'buffer-browser-item 'buffer b 'display-width width )) (defflavor buffer-browser-item (display-text display-width buffer (delete-flag NIL) ) () (gettable-instance-variables display-text buffer) (initable-instance-variables) ) (defmethod (buffer-browser-item init) (init-plist) (=> self &update-display-text) ) (defmethod (buffer-browser-item &update-display-text) () (setf display-text (string-concat (if delete-flag "D" " ") (if (=> buffer modified?) "*" " ") " " (string-pad-right (=> buffer name) 24) (string-pad-left (bldmsg "%d" (=> buffer visible-size)) 6) " " (or (=> buffer file-name) "") ) )) (defmethod (buffer-browser-item update) () (when (memq buffer nmode-selectable-buffers) (=> self &update-display-text) )) (defmethod (buffer-browser-item delete) () (when (not delete-flag) (cond ((not (buffer-killable? buffer)) (nmode-error (BldMsg "Buffer %w may not be deleted!" (=> buffer name))) ) (t (setf delete-flag T) (=> self &update-display-text) )))) (defmethod (buffer-browser-item undelete) () (when delete-flag (setf delete-flag NIL) (=> self &update-display-text) )) (defmethod (buffer-browser-item deleted?) () delete-flag ) (defmethod (buffer-browser-item kill) () (cond ((not (buffer-killable? buffer)) (nmode-error (BldMsg "Buffer %w may not be killed!" (=> buffer name))) NIL ) ((or (not (=> buffer modified?)) (YesP (BldMsg "Kill unsaved buffer %w?" (=> buffer name)))) (=> buffer set-previous-buffer NIL) (buffer-kill-and-detach buffer) T ))) (defmethod (buffer-browser-item view-buffer) (x) (if (buffer-is-selectable? buffer) buffer) ) (defmethod (buffer-browser-item cleanup) () ) (defmethod (buffer-browser-item apply-filter) (filter) (apply filter (list self)) ) (defmethod (buffer-browser-item save-file) () (when (=> buffer modified?) (save-file buffer) (=> self &update-display-text) )) (defmethod (buffer-browser-item set-unmodified) () (when (=> buffer modified?) (=> buffer set-modified? NIL) (=> self &update-display-text) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/buffer-io.sl version [43cb2f493f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-IO.SL - PSL I/O to and from NMODE buffers % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 26 August 1982 % Revised: 18 February 1983 % % Adapted from Will Galway's EMODE % % 18-Feb-83 Alan Snyder % Fix to adjust an exposed window when displaying output. % 16-Feb-83 Alan Snyder % Recode using objects; add output cache for efficiency. % Remove time-since-last-redisplay check (it causes a 2X slowdown); % now display output only after Newline or cache full. % Declare -> Declare-Flavor. % 30-Dec-82 Alan Snyder % Add declarations for buffers and windows; use fast-vectors (for efficiency). % 27-Dec-82 Alan Snyder % Use generic arithmetic for Time (for portability); reformat. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-vectors)) (fluid '(nmode-current-window *nmode-init-running)) (DefConst MaxChannels 32) % Maximum number of channels supported by PSL. (defflavor buffer-channel ( (editor-function NIL) % NIL or a function to obtain new input (input-buffer NIL) % NIL or a buffer to obtain input from (input-position NIL) % the current read pointer (output-buffer NIL) % NIL or a buffer to send output to (output-cache NIL) % cache of output (for efficiency) output-cache-pos % pointer into output cache ) () (settable-instance-variables) ) (fluid '(buffer-channel-vector)) (when (or (not (BoundP 'buffer-channel-vector)) (null buffer-channel-vector)) (setf buffer-channel-vector (MkVect (const MaxChannels))) ) (fluid '(*outwindow % T => expose output window on output )) (setf *outwindow T) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor text-buffer input-buffer output-buffer) (declare-flavor buffer-window w) (declare-flavor buffer-channel bc) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de OpenBufferChannel (input-buffer output-buffer Editor) % Open a channel for buffer I/O. Input-Buffer and Output-Buffer may be buffer % objects or NIL. Input will be read from the current location in the Input % Buffer. Output will be inserted at the current location in the Output % Buffer. Editor may be a function object (ID) or NIL. The Editor function % can be used if you want something to "happen" every time a reader begins to % read from the channel. If Editor is NIL, then the reader will simply % continue reading from the current location in the input buffer. (setf SpecialWriteFunction* 'buffer-print-character) (setf SpecialReadFunction* 'buffer-read-character) (setf SpecialCloseFunction* 'buffer-channel-close) (let ((chn (open "buffers" 'SPECIAL)) (bc (make-instance 'buffer-channel)) ) (vector-store buffer-channel-vector chn bc) (=> bc set-input-buffer input-buffer) (=> bc set-input-position (and input-buffer (=> input-buffer position))) (=> bc set-output-buffer output-buffer) (=> bc set-editor-function Editor) chn )) (de buffer-channel-close (chn) % Close up an NMODE buffer channel. (vector-store buffer-channel-vector chn NIL) ) (de buffer-channel-set-input-buffer (chn input-buffer) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-input-buffer input-buffer) (=> bc set-input-position (=> input-buffer position)) ))) (de buffer-channel-set-input-position (chn bp) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-input-position bp) ))) (de buffer-channel-set-output-buffer (chn output-buffer) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-output-buffer output-buffer) ))) (de buffer-print-character (chn ch) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc putc ch) ))) (de buffer-channel-flush (chn) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc flush) ))) (defmethod (buffer-channel flush) () % If there is output lingering in the output cache, then append it to the % output buffer and return T. Otherwise return NIL. (when (and output-buffer output-cache (> output-cache-pos 0)) (let ((old-pos (=> output-buffer position))) (=> output-buffer move-to-buffer-end) (=> output-buffer insert-string (substring output-cache 0 output-cache-pos)) (=> output-buffer set-position old-pos) (setf output-cache-pos 0) T ))) (defmethod (buffer-channel refresh) () % If this channel is being used for output, then refresh the display of that % output. The buffer will automatically be exposed in a window (if % requested by the *OutWindow flag), the output cache will be flushed, the % display window will be adjusted, and the screen refreshed. (when output-buffer (if (and *OutWindow (not *nmode-init-running) (not (buffer-is-displayed? output-buffer))) (nmode-expose-output-buffer output-buffer)) (let ((window-list (find-buffer-in-exposed-windows output-buffer))) (when window-list (=> self flush) (nmode-adjust-output-window (car window-list)) )))) (defmethod (buffer-channel put-newline) () (=> self flush) (let ((old-pos (=> output-buffer position))) (=> output-buffer move-to-buffer-end) (=> output-buffer insert-eol) (=> output-buffer set-position old-pos) ) (=> self refresh) ) (defmethod (buffer-channel putc) (ch) % "Print" character CH by appending it to the output buffer. (if (= ch #\EOL) (=> self put-newline) (when output-buffer (when (null output-cache) (setf output-cache (make-string 200 #\space)) (setf output-cache-pos 0) ) (string-store output-cache output-cache-pos ch) (setf output-cache-pos (+ output-cache-pos 1)) (when (>= output-cache-pos 200) (=> self flush) (=> self refresh) )))) (de nmode-adjust-output-window (w) (let ((output-buffer (=> w buffer))) (=> w set-position (=> output-buffer buffer-end-position)) (nmode-adjust-window w) (if (=> w exposed?) (nmode-refresh)) )) (de buffer-read-character (chn) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc getc) ))) (defmethod (buffer-channel getc) () % Read a character from the input buffer; advance over that character. % Return End Of File if at end of buffer or if no buffer. If the "read % point" equals the "buffer cursor", then the "buffer cursor" will be % advanced also. (if (not input-buffer) #\EOF % Otherwise (there is an input buffer) (let* ((old-position (=> input-buffer position)) (was-at-cursor (buffer-position-equal input-position old-position)) result ) (=> input-buffer set-position input-position) (if (=> input-buffer at-buffer-end?) (setf result #\EOF) % Otherwise (not at end of buffer) (setf result (=> input-buffer next-character)) (=> input-buffer move-forward) (setf input-position (=> input-buffer position)) ) (if (not was-at-cursor) (=> input-buffer set-position old-position)) (if *ECHO (=> self putc result)) result ))) (de MakeInputAvailable () % THIS IS THE MAGIC FUNCTION invoked by READ, and other "reader functions". % IN* is a FLUID (actually GLOBAL) variable. (let ((bc (vector-fetch buffer-channel-vector IN*))) (when bc (=> bc run-editor) ))) (defmethod (buffer-channel run-editor) () (if editor-function (apply editor-function (list IN*))) NIL ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor input-buffer output-buffer) (undeclare-flavor w) (undeclare-flavor bc) |
Added psl-1983/3-1/nmode/buffer-position.sl version [65f46544e7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % BUFFER-POSITION.SL - Buffer Position Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % % This file implements objects that store buffer positions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (de buffer-position-create (line-number column-number) (cons line-number column-number)) (de buffer-position-line (bp) (car bp)) (de buffer-position-column (bp) (cdr bp)) (de buffer-position-equal (bp1 bp2) (and (= (car bp1) (car bp2)) (= (cdr bp1) (cdr bp2)))) (de buffer-position-compare (bp1 bp2) (cond ((< (buffer-position-line bp1) (buffer-position-line bp2)) -1) ((> (buffer-position-line bp1) (buffer-position-line bp2)) 1) ((< (buffer-position-column bp1) (buffer-position-column bp2)) -1) ((> (buffer-position-column bp1) (buffer-position-column bp2)) 1) (t 0))) (de buffer-position-lessp (bp1 bp2) (<= (buffer-position-compare bp1 bp2) 0)) |
Added psl-1983/3-1/nmode/buffer-window.sl version [6be72667c7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-Window.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 August 1982 % Revised: 24 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A Buffer-Window object maintains an attachment between an editor buffer and a % virtual screen. This module is responsible for mapping the contents of the % editor buffer to an image on the virtual screen. A "window label" object % may be specified to maintain a descriptive label at the bottom of the % virtual screen (see comment for the SET-LABEL method). % % 24-Feb-83 Alan Snyder % Fixed bug: cursor positioning didn't take buffer-left into account. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Refresh now returns a flag indicating completion (no breakout). % Add cached method for label refresh. % 31-Jan-83 Alan Snyder % Modified to use separate window-label object to write the label area. % Note: SET-SIZE height argument is now interpreted as the screen height! % 20-Jan-83 Alan Snyder % Bug fix: adjust window after changing screen size. % 28-Dec-82 Alan Snyder % Replaced call to current-display-column in REFRESH, which was incorrect % because it assumes the buffer is current. Changed to display position of % window, rather than position of buffer (meaningful only when the window % package can display multiple cursors). Added methods: CHAR-POSITION, % SET-SCREEN, and &NEW-SCREEN. Changed EXPOSE to refresh first, for more % graceful screen update when using direct writing. Change label writing to % clear-eol after writing the label, not before, also for more graceful % screen update. Changed &WRITE-LINE-TO-SCREEN to buffer its changes in a % string, for efficiency. General cleanup. % 20-Dec-82 Alan Snyder % Added declarations for buffer and screen instance variables, for % efficiency. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors fast-strings display-char)) (de create-unlabeled-buffer-window (buffer virtual-screen) % Create a buffer window object that presents the specified buffer onto % the specified virtual-screen. There will be no label area. (make-instance 'buffer-window 'buffer buffer 'screen virtual-screen) ) (de create-buffer-window (buffer virtual-screen) % Create a buffer window object that presents the specified buffer onto % the specified virtual-screen. There will be a one-line label. (let ((w (create-unlabeled-buffer-window buffer virtual-screen))) (=> w set-label (create-window-label w)) w )) (defflavor buffer-window (height % number of rows of text (rows are 0 indexed) maxrow % highest numbered row width % number of columns of text (cols are 0 indexed) maxcol % highest numbered column (buffer-left 0) % leftmost buffer column displayed (buffer-top 0) % topmost buffer line displayed (overflow-marker #/!) % display character used to mark overlong lines (saved-position NIL) % buffer position saved here while not selected (label NIL) % the optional label-maintaining object (label-height 0) % number of lines occupied by the label (label-refresh-method NIL) % cached method for refreshing the label (text-enhancement (dc-make-enhancement-mask)) % display enhancement used in text area line-buffer % string of characters used to write line buffer % the buffer being displayed screen % the virtual screen used for display buffer-lines % vector of buffer lines currently displayed % % NIL used for EQable empty string ) () (gettable-instance-variables height width screen buffer buffer-left buffer-top text-enhancement ) (initable-instance-variables screen buffer text-enhancement ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor text-buffer buffer) (declare-flavor virtual-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (buffer-window select) () % This method is invoked when the window is selected. It restores the saved % buffer pointer, if any. It will not scroll the window: instead, it will % adjust the buffer position, if necessary, to keep the buffer pointer within % the window. (when saved-position (=> buffer set-position saved-position) (setf saved-position NIL) ) (=> self adjust-buffer) ) (defmethod (buffer-window deselect) () % This method is invoked when the window is deselected. It saves the current % buffer pointer, which will be restored when the window is again selected. % It adjusts the window to ensure that the window shows the saved position. (setf saved-position (=> buffer position)) (=> self adjust-window) ) (defmethod (buffer-window expose) () % Expose the window, putting it "on top" (expose the attached virtual screen). (=> self refresh nil) (=> screen expose) ) (defmethod (buffer-window deexpose) () % De-expose the window (de-expose the attached virtual screen). (=> screen deexpose) ) (defmethod (buffer-window exposed?) () (=> screen exposed?) ) (defmethod (buffer-window set-screen) (new-screen) (when (not (eq screen new-screen)) (let ((exposed? (=> screen exposed?)) (old-screen screen) ) (setf screen new-screen) (=> self &new-screen) (when exposed? (=> self expose) (=> old-screen deexpose)) ))) (defmethod (buffer-window set-label) (new-label) % Specify a "label" object to write a label at the bottom of the screen. NIL % implies that no label area is wanted. If an object is specified, it % must support the following operations: % (=> label height) % Return the number of lines occupied by the label area at the bottom % of the buffer-window's virtual screen. % (=> label resize) % Tell the label that the window has changed size. This may cause % the label to change its height, but should not cause a refresh. % (=> label refresh) % This instructs the label object to refresh the label area. The label % area is assumed to be the bottom-most <height> lines on the % buffer-window's virtual screen, although it could be on a totally % different virtual screen, if desired (in which case the "height" % operation should return 0). % This operation may change the number of lines available for text, which % may require adjusting the window position. A refresh is not done % immediately. (setf label new-label) (setf label-refresh-method (if label (object-get-handler label 'refresh))) (=> self &new-size) ) (defmethod (buffer-window position) () % If the window is selected, return the position of the buffer. Otherwise, % return the "saved position". (or saved-position (=> buffer position))) (defmethod (buffer-window line-position) () (if saved-position (buffer-position-line saved-position) (=> buffer line-pos) )) (defmethod (buffer-window char-position) () (if saved-position (buffer-position-column saved-position) (=> buffer char-pos) )) (defmethod (buffer-window set-position) (bp) % If the window is selected, set the buffer position. Otherwise, set the % "saved position". (if saved-position (setf saved-position bp) (=> buffer set-position bp) )) (defmethod (buffer-window set-line-position) (line) % If the window is selected, set the buffer position. % Otherwise, set the "saved position". (if saved-position (setf saved-position (buffer-position-create line 0)) (=> buffer set-line-pos line) )) (defmethod (buffer-window adjust-window) () % Adjust the window position, if necessary, to ensure that the current % buffer location (if the window is selected) or the saved buffer location % (if the window is not selected) is within the window. (let ((line (=> self line-position))) (if (or (< line buffer-top) (>= line (+ buffer-top height))) % The desired line doesn't show in the window. (=> self readjust-window) ))) (defmethod (buffer-window readjust-window) () % Adjust the window position to nicely show the current location. (let ((line (=> self line-position)) (one-third-screen (/ height 3)) ) (=> self set-buffer-top (if (>= line (- (=> buffer size) one-third-screen)) (- line (* 2 one-third-screen)) (- line one-third-screen) )))) (defmethod (buffer-window adjust-buffer) () % Adjust the buffer position, if necessary, to ensure that the current % buffer location is visible on the screen. If the window position is % past the end of the buffer, it will be changed. (let ((size (=> buffer size))) (cond ((>= buffer-top size) % The window is past the end of the buffer. (=> self set-buffer-top (- size (/ height 3))) ))) (let ((line (=> buffer line-pos))) (cond ((or (< line buffer-top) (>= line (+ buffer-top height))) % The current line doesn't show in the window. (=> buffer set-line-pos (+ buffer-top (/ height 3))) )))) (defmethod (buffer-window set-buffer) (new-buffer) (setf buffer new-buffer) (setf buffer-left 0) (setf buffer-top 0) (if saved-position (setf saved-position (=> buffer position))) (=> self adjust-window) (=> self &reset) ) (defmethod (buffer-window set-buffer-top) (new-top) (cond ((<= new-top 0) (setf new-top 0)) ((>= new-top (=> buffer visible-size)) (setf new-top (- (=> buffer visible-size) 1))) ) (setf buffer-top new-top) ) (defmethod (buffer-window set-buffer-left) (new-left) (when (~= new-left buffer-left) (if (< new-left 0) (setf new-left 0)) (when (~= new-left buffer-left) (setf buffer-left new-left) (=> self &reset) ))) (defmethod (buffer-window set-size) (new-height new-width) % Change the size of the screen to have the specified height and width. % The size is adjusted to ensure that there is at least one row of text. (setf new-height (max new-height (+ label-height 1))) (setf new-width (max new-width 1)) (when (or (~= new-height (=> screen height)) (~= new-width (=> screen width))) (=> screen set-size new-height new-width) (=> self &new-size) )) (defmethod (buffer-window set-text-enhancement) (e-mask) (when (~= text-enhancement e-mask) (setf text-enhancement e-mask) (=> screen set-default-enhancement e-mask) (=> self &reset) )) (defmethod (buffer-window refresh) (breakout-allowed) % Update the virtual screen (including the label) to correspond to the % current state of the attached buffer. Return true if the refresh % was completed (no breakout occurred). (if (not (and breakout-allowed (input-available?))) (let ((buffer-end (=> buffer visible-size))) (for (from row 0 maxrow) (for line-number buffer-top (+ line-number 1)) (do % NIL is used to represent all EMPTY lines, so that EQ will work. (let ((line (and (< line-number buffer-end) (=> buffer fetch-line line-number)))) (if (and line (string-empty? line)) (setf line NIL)) (when (not (eq line (vector-fetch buffer-lines row))) (vector-store buffer-lines row line) (=> self &write-line-to-screen line row) ))) ) (if (and label label-refresh-method) (apply label-refresh-method (list label))) (let* ((linepos (=> self line-position)) (charpos (=> self char-position)) (row (- linepos buffer-top)) (line (vector-fetch buffer-lines row)) (column (- (map-char-to-column line charpos) buffer-left)) ) (=> screen set-cursor-position row column) ) T % refresh completed ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (buffer-window init) (init-plist) (=> self &new-screen) ) (defmethod (buffer-window &new-screen) () (=> screen set-default-enhancement text-enhancement) (=> self &new-size) ) (defmethod (buffer-window &new-size) () % The size of the screen and/or label may have changed. Adjust % the internal state of the buffer-window accordingly. (if label (=> label resize)) % may change label height (setf label-height (if label (max 0 (=> label height)) 0)) (setf height (- (=> screen height) label-height)) (setf width (=> screen width)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf buffer-lines (make-vector maxrow 'UNKNOWN)) (setf line-buffer (make-string (+ maxcol 10) #\space)) (=> self adjust-window) % ensure that cursor is still visible ) (defmethod (buffer-window &reset) () % "Forget" information about displayed lines. (for (from i 0 maxrow) (do (vector-store buffer-lines i 'UNKNOWN)))) (defmethod (buffer-window &write-line-to-screen) (line row) (if (null line) (=> screen clear-to-eol row 0) % else (let ((count (=> self &compute-screen-line line))) (cond ((> count width) (=> screen write-string row 0 line-buffer maxcol) (=> screen write overflow-marker row maxcol) ) (t (=> screen write-string row 0 line-buffer count) (=> screen clear-to-eol row count) ))))) (defmacro &write-char (ch) % Used by &COMPUTE-SCREEN-LINE. `(progn (if (>= line-index 0) (string-store line-buf line-index ,ch)) (setf line-index (+ line-index 1)) (setf line-column (+ line-column 1)) )) (defmethod (buffer-window &compute-screen-line) (line) % Internal method used by &WRITE-LINE-TO-SCREEN. It fills the line buffer % with the appropriate characters and returns the number of characters in % the line buffer. (let ((line-buf line-buffer) % local variables are more efficient (line-column 0) (line-index (- buffer-left)) (the-width width) % local variables are more efficient ) (for (from i 0 (string-upper-bound line)) (until (> line-index the-width)) % have written past the right edge (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to spaces. (let ((tabcol (& (+ line-column 8) (~ 7)))) (while (< line-column tabcol) (&write-char #\space) ))) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (&write-char #/^) (&write-char (^ ch 8#100)) ) (t (&write-char ch)) )))) line-index )) (de map-char-to-column (line n) % Map character position N to the corresponding display column index with % respect to the specified LINE. Handle funny mapping of TABs and control % characters. (setf n (- n 1)) (let ((upper-bound (string-upper-bound line))) (if (> n upper-bound) (setf n upper-bound))) (for* (from i 0 n) (with (col 0)) (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to an appropriate number of spaces. (setf col (& (+ col 8) (~ 7))) ) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (setf col (+ col 2)) ) (t (setf col (+ col 1)) )))) (returns col))) (de map-column-to-char (line n) % Map display column index N to the corresponding character position with % respect to the specified LINE. Handle funny mapping of TABs and control % characters. (for* (from i 0 (string-upper-bound line)) (with (col 0)) (until (>= col n)) (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to an appropriate number of spaces. (setf col (& (+ col 8) (~ 7))) ) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (setf col (+ col 2)) ) (t (setf col (+ col 1)) )))) (returns i) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor buffer screen) |
Added psl-1983/3-1/nmode/buffer.sl version [9287c0e41d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer.SL - Auxiliary Functions for manipulating the current buffer. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 August 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(nmode-current-buffer)) (declare-flavor text-buffer nmode-current-buffer) (de buffer-get-position () % Return the "current position" in the current buffer as a BUFFER-POSITION % object. (=> nmode-current-buffer position)) (de buffer-set-position (bp) % Set the "current position" in the current buffer from the specified % BUFFER-POSITION object. Clips the line-position and char-position. (if bp (=> nmode-current-buffer set-position bp))) (de current-buffer-goto (line-number char-number) % Set the "current position" in the current buffer. % Clips the line-position and char-position. (=> nmode-current-buffer goto line-number char-number)) (de current-line-pos () % Return the "current line position" in the current buffer. (=> nmode-current-buffer line-pos)) (de set-line-pos (n) % Set the "current line position" in the current buffer. % Clips the line-position and char-position. (=> nmode-current-buffer set-line-pos n)) (de current-char-pos () % Return the "current character position" in the current buffer. (=> nmode-current-buffer char-pos)) (de set-char-pos (n) % Set the "current character position" in the current buffer. % Clips the specified position to lie in the range 0..line-length. (=> nmode-current-buffer set-char-pos n)) (de current-display-column () % Return the column index corresponding to the current character position % in the display of the current line. In other words, what screen column % should the cursor be in (ignoring horizontal scrolling)? (map-char-to-column (current-line) (current-char-pos))) (de set-display-column (n) % Adjust the character position within the current buffer so that % the current display column will be the smallest possible value % not less than N. (The display column may differ than N because % certain characters display in multiple columns.) (set-char-pos (map-column-to-char (current-line) n))) (de current-buffer-size () % Return the number of lines in the current buffer. % This count may include a fake empty line at the end of the buffer. (=> nmode-current-buffer size)) (de current-buffer-visible-size () % Return the apparent number of lines in the current buffer. % The fake empty line that may be present at the end of the % buffer is not counted. (=> nmode-current-buffer visible-size)) (de current-line () % Return the current line in the current buffer (as a string). (=> nmode-current-buffer fetch-line (current-line-pos))) (de current-line-replace (s) % Replace the current line of the current buffer with the specified string. (=> nmode-current-buffer store-line (current-line-pos) s)) (de current-buffer-fetch (n) % Return the line at line position N within the current buffer. (=> nmode-current-buffer fetch-line n)) (de current-buffer-store (n l) % Store the line L at line position N within the current buffer. (=> nmode-current-buffer store-line n l)) (de set-mark (bp) % PUSH the specified position onto the ring buffer of marks associated with % the current buffer. The specified position thus becomes the current "mark". (=> nmode-current-buffer set-mark bp)) (de set-mark-from-point () % PUSH the current position onto the ring buffer of marks associated with % the current buffer. The current position thus becomes the current "mark". (=> nmode-current-buffer set-mark-from-point)) (de current-mark () % Return the current mark associated with the current buffer. (=> nmode-current-buffer mark)) (de previous-mark () % POP the current mark off the ring buffer of marks associated with the % current buffer. Return the new current mark. (=> nmode-current-buffer previous-mark)) (de reset-buffer () % Reset the contents of the current buffer to empty and "not modified". (=> nmode-current-buffer reset)) (de extract-region (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % pair (CONS direction-of-deletion vector-of-strings). The returned % direction is +1 if BP1 <= BP2, and -1 otherwise. The current position is % set to the beginning of the region if deletion is performed. (=> nmode-current-buffer extract-region delete-it bp1 bp2)) (de extract-text (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % vector-of-strings. The current position is set to the beginning of the % region if deletion is performed. (cdr (=> nmode-current-buffer extract-region delete-it bp1 bp2))) (de current-line-length () % Return the number of characters in the current line. (=> nmode-current-buffer current-line-length)) (de current-line-empty? () % Return T if the current line contains no characters. (=> nmode-current-buffer current-line-empty?)) (de current-line-blank? () % Return T if the current line contains no non-blank characters. (=> nmode-current-buffer current-line-blank?)) (de at-line-start? () % Return T if we are positioned at the start of the current line. (=> nmode-current-buffer at-line-start?)) (de at-line-end? () % Return T if we are positioned at the end of the current line. (=> nmode-current-buffer at-line-end?)) (de at-buffer-start? () % Return T if we are positioned at the start of the buffer. (=> nmode-current-buffer at-buffer-start?)) (de at-buffer-end? () % Return T if we are positioned at the end of the buffer. (=> nmode-current-buffer at-buffer-end?)) (de current-line-is-first? () % Return T if the current line is the first line in the buffer. (=> nmode-current-buffer current-line-is-first?)) (de current-line-is-last? () % Return T if the current line is the last line in the buffer. (=> nmode-current-buffer current-line-is-last?)) (de current-line-fetch (n) % Return the character at character position N within the current line. % An error is signalled if N is out of range. (=> nmode-current-buffer current-line-fetch n)) (de current-line-store (n c) % Store the character C at char position N within the current line. % An error is signalled if N is out of range. (=> nmode-current-buffer current-line-store n c)) (de move-to-buffer-start () % Move to the beginning of the current buffer. (=> nmode-current-buffer move-to-buffer-start)) (de move-to-buffer-end () % Move to the end of the current buffer. (=> nmode-current-buffer move-to-buffer-end)) (de move-to-start-of-line () % Move to the beginning of the current line. (=> nmode-current-buffer move-to-start-of-line)) (de move-to-end-of-line () % Move to the end of the current line. (=> nmode-current-buffer move-to-end-of-line)) (de move-to-next-line () % Move to the beginning of the next line. % If already at the last line, move to the end of the line. (=> nmode-current-buffer move-to-next-line)) (de move-to-previous-line () % Move to the beginning of the previous line. % If already at the first line, move to the beginning of the line. (=> nmode-current-buffer move-to-previous-line)) (de move-forward () % Move to the next character in the current buffer. % Do nothing if already at the end of the buffer. (=> nmode-current-buffer move-forward)) (de move-backward () % Move to the previous character in the current buffer. % Do nothing if already at the start of the buffer. (=> nmode-current-buffer move-backward)) (de next-character () % Return the character to the right of the current position. % Return NIL if at the end of the buffer. (=> nmode-current-buffer next-character)) (de previous-character () % Return the character to the left of the current position. % Return NIL if at the beginning of the buffer. (=> nmode-current-buffer previous-character)) (de insert-character (c) % Insert character C at the current position in the buffer and advance past % that character. (=> nmode-current-buffer insert-character c)) (de insert-eol () % Insert a line-break at the current position in the buffer and advance to % the beginning of the newly-formed line. (=> nmode-current-buffer insert-eol)) (de insert-line (l) % Insert the specified string as a new line in front of the % current line. Advance past the newly inserted line. (=> nmode-current-buffer insert-line l)) (de insert-string (s) % Insert the string S at the current position. Advance past the % newly-inserted string. Note: S must not contain EOL characters! (=> nmode-current-buffer insert-string s)) (de insert-text (v) % V is a vector of strings similar to LINES (e.g., the last string in V is % considered to be an unterminated line). Thus, V must have at least one % element. Insert this stuff at the current position and advance past it. (=> nmode-current-buffer insert-text v)) (de delete-next-character () % Delete the next character. % Do nothing if at the end of the buffer. (=> nmode-current-buffer delete-next-character)) (de delete-previous-character () % Delete the previous character. % Do nothing if at the beginning of the buffer. (=> nmode-current-buffer delete-previous-character)) (undeclare-flavor nmode-current-buffer) |
Added psl-1983/3-1/nmode/buffers.sl version [5e550f1609].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffers.SL - Buffer Collection Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 14 March 1983 % % This file contains functions that manipulate the set of existing buffers. % % 14-Mar-83 Alan Snyder % Add new function: nmode-new-window-or-buffer. Extend the notion of % selectable buffer to include unnamed buffers. Replace % buffer-create-unselectable with create-unnamed-buffer. Change % window-select-buffer to do nothing if the buffer is already attached to the % window. % 25-Jan-83 Alan Snyder % Fix bug in buffer name completion: now accepts the name of an existing buffer % even when the name is a prefix of the name of some other buffer. % 29-Dec-82 Alan Snyder % Revise prompt-for-buffer code to use new prompted input. % PROMPT-FOR-EXISTING-BUFFER now completes on CR and LF, as well as SPACE. % 3-Dec-82 Alan Snyder % Added CLEANUP-BUFFERS. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-strings numeric-operators)) (load stringx) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-current-buffer nmode-current-window nmode-main-buffer nmode-output-buffer nmode-default-mode nmode-input-default )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Global variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-selectable-buffers)) (if (not (boundp 'nmode-selectable-buffers)) (setf nmode-selectable-buffers NIL)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % A buffer is selectable if it is a named buffer on the selectable buffer list % (i.e., a buffer that can be selected by name) or if it is an unnamed buffer. % A buffer that has a name but is not on the list may not be selected, since % the user would expect to be able to select it by name. These buffers are % ones that the user has killed. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(prompt-for-buffer-command-list prompt-for-existing-buffer-command-list )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Creating buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-create-default (buffer-name) % Create a new buffer with the default mode. The name of the new buffer will % be the specified name if no buffer already exists with that name. % Otherwise, a similar name will be chosen. The buffer becomes selectable, % but is not selected. (buffer-create buffer-name nmode-default-mode)) (de buffer-create (buffer-name initial-mode) % Create a new buffer. The name of the new buffer will be the specified name % if no buffer already exists with that name. Otherwise, a similar name will % be chosen. The buffer becomes selectable, but is not selected. (setf buffer-name (buffer-make-unique-name buffer-name)) (let ((b (create-text-buffer buffer-name))) (=> b set-mode initial-mode) (=> b set-previous-buffer nmode-current-buffer) (setq nmode-selectable-buffers (cons b nmode-selectable-buffers)) b)) (de create-unnamed-buffer (initial-mode) % Create a new, unnamed buffer with the specified mode. (let ((b (create-text-buffer NIL))) (=> b set-mode initial-mode) (=> b set-previous-buffer nmode-current-buffer) b)) (de buffer-make-unique-name (buffer-name) % Return a buffer name not equal to the name of any existing buffer. (setf buffer-name (string-upcase buffer-name)) (for* (with (root-name (string-concat buffer-name "-"))) (for count 0 (+ count 1)) (for name buffer-name (string-concat root-name (BldMsg "%d" count))) (do (if (not (buffer-exists? name)) (exit name))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Finding buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-find (buffer-name) % If a selectable buffer exists with the specified name (case does % not matter), then return it. Otherwise, return NIL. (for (in b nmode-selectable-buffers) (do (if (string-equal buffer-name (=> b name)) (exit b))) (returns nil) )) (de buffer-find-or-create (buffer-name) % Return the specified buffer, if it exists and is selectable. % Otherwise, create a buffer of that name and return it. (or (buffer-find buffer-name) (buffer-create-default buffer-name) )) (de buffer-exists? (buffer-name) % Return T if a selectable buffer exists with the specified name % (case does not matter), NIL otherwise. (if (buffer-find buffer-name) T NIL)) (de nmode-user-buffers () % Return a list of those selectable buffers whose names do not begin % with a '+'. (for (in b nmode-selectable-buffers) (when (~= (string-fetch (=> b name) 0) #/+)) (collect b) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Manipulating buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-is-selectable? (b) % Return T if the specified buffer is selectable. (or (not (=> b name)) (MemQ b nmode-selectable-buffers) )) (de buffer-set-mode (b mode) % Set the "mode" of the buffer B. If B is the current buffer, then the % mode is "established". (=> b set-mode mode) (when (eq b nmode-current-buffer) (nmode-establish-current-mode) (set-message "") )) (de cleanup-buffers () % Ask each buffer to "clean up" any unneeded storage. (for (in b nmode-selectable-buffers) (do (=> b cleanup)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Selecting Buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-select (b) % If B is not NIL and B is a selectable buffer, then make it the current % buffer, attach it to the current window, and return it. Otherwise, do % nothing and return NIL. (window-select-buffer nmode-current-window b)) (de buffer-select-previous (b) % Select the previous buffer of B, if it exists and is selectable. % Otherwise, select the MAIN buffer. (if (not (buffer-select (=> b previous-buffer))) (buffer-select nmode-main-buffer)) ) (de buffer-select-by-name (buffer-name) % If the specified named buffer exists and is selectable, select it and % return it. Otherwise, return NIL. (buffer-select (buffer-find buffer-name))) (de buffer-select-or-create (buffer-name) % Select the specified named buffer, if it exists and is selectable. % Otherwise, create a buffer of that name and select it. (or (buffer-select-by-name buffer-name) (buffer-select (buffer-create-default buffer-name)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prompting for buffer names: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf prompt-for-buffer-command-list (list (cons (x-char SPACE) 'complete-input-buffer-name) (cons (x-char CR) 'check-input-buffer-name) (cons (x-char LF) 'check-input-buffer-name) )) (setf prompt-for-existing-buffer-command-list (list (cons (x-char SPACE) 'complete-input-buffer-name) (cons (x-char CR) 'complete-input-existing-buffer-name) (cons (x-char LF) 'complete-input-existing-buffer-name) )) (de prompt-for-buffer (prompt default-b) % Ask the user for the name of a buffer. If the user gives a name that does % not name an existing buffer, a new buffer with that name will be created % (but NOT selected), and the prompt "(New Buffer)" will be displayed. % Return the buffer. DEFAULT-B is the buffer to return as default (it may % be NIL). A valid buffer will always be returned (the user may ABORT). (let* ((default-name (and default-b (=> default-b name))) (name (prompt-for-string-special prompt default-name prompt-for-buffer-command-list )) ) (or (buffer-find name) (prog1 (buffer-create-default (string-upcase name)) (write-prompt "(New Buffer)") )))) (de prompt-for-existing-buffer (prompt default-b) % Ask the user for the name of an existing buffer. Return the buffer. % DEFAULT-B is the buffer to return as default (it may be NIL). A valid % buffer will always be returned, unless the user aborts (throw 'ABORT). (let* ((default-name (and default-b (=> default-b name))) (name (prompt-for-string-special prompt default-name prompt-for-existing-buffer-command-list )) ) (buffer-find name) )) % Internal functions: (de complete-input-buffer-name () % Extend the string in the input buffer as far as possible to match the set of % existing buffers. Return T if the resulting string names an existing % buffer; otherwise Beep and return NIL. (let* ((name (nmode-get-input-string)) (names (buffer-names-that-match name)) ) (when (not (null names)) (setf name (strings-largest-common-prefix names)) (nmode-replace-input-string name) ) (if (member name names) T (progn (Ding) NIL) ))) (de check-input-buffer-name () % Check the string in the input buffer to ensure that it is non-empty, or if % it is empty, that the default string exists and is not empty. Beep if this % condition fails, otherwise terminate the input. (if (or (not (string-empty? (nmode-get-input-string))) (and nmode-input-default (not (string-empty? nmode-input-default)))) (nmode-terminate-input) (Ding) )) (de complete-input-existing-buffer-name () % If the input buffer is empty and there is a default string, substitute the % default string. Then, extend the string in the input buffer as far as % possible to match the set of existing buffers. If the resulting string % names an existing buffer, refresh and terminate input. Otherwise, beep. (nmode-substitute-default-input) (when (complete-input-buffer-name) (nmode-refresh) (nmode-terminate-input) )) (de buffer-names-that-match (name) (for (in b nmode-selectable-buffers) (when (buffer-name-matches b name)) (collect (=> b name)))) (de buffer-name-matches (b name2) (let* ((len2 (string-length name2)) (name1 (=> b name)) (len1 (string-length name1)) ) (and (>= len1 len2) (string-equal (substring name1 0 len2) name2) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Attaching buffers to windows %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-select-buffer (w b) % If B is not NIL and B is a selectable buffer, then attach B to the window % W and return B. Otherwise, do nothing and return NIL. If W is the % current window, then the buffer becomes the current buffer. (when (and b (buffer-is-selectable? b) (not (eq b (=> w buffer)))) (=> w set-buffer b) (nmode-adjust-window w) (when (eq w nmode-current-window) (nmode-new-window-or-buffer) ) b )) (de window-select-previous-buffer (w) % Replace window W's current buffer with that buffer's previous buffer, if % it exists and is selectable. Otherwise, replace it with the MAIN buffer. (if (not (window-select-buffer w (=> (=> w buffer) previous-buffer))) (window-select-buffer w nmode-main-buffer))) (de window-copy-buffer (w-source w-dest) % Attach to window W-DEST the buffer belonging to window W-SOURCE. % Duplicate the window's BUFFER-TOP and BUFFER-LEFT as well. If W is the % current window, then the buffer becomes the current buffer. (let ((b (=> w-source buffer))) (=> w-dest set-buffer b) (=> w-dest set-buffer-top (=> w-source buffer-top)) (=> w-dest set-buffer-left (=> w-source buffer-left)) (when (eq w-dest nmode-current-window) (nmode-new-window-or-buffer) ))) (de nmode-new-window-or-buffer () % This function should be called if a new window has been selected or a new % buffer has been attached to the current window. This should be the only % function that sets the variable NMODE-CURRENT-BUFFER. (let ((new-current-buffer (=> nmode-current-window buffer))) (when (not (eq new-current-buffer nmode-current-buffer)) (setf nmode-current-buffer new-current-buffer) (nmode-establish-current-mode) (reset-message) (let ((browser (=> nmode-current-buffer get 'browser))) (when browser (=> browser select) ))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Killing Buffers %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-kill-buffer () % This function kills the buffer associated with the current window and % detaches it from that window or any other window (replacing it with % another buffer, preferrably the buffer's "previous buffer"). % Do not kill the MAIN or OUTPUT buffer. (buffer-kill-and-detach (=> nmode-current-window buffer))) (de buffer-kill-and-detach (b) % Kill the specified buffer and detach it from any existing windows % (replacing with another buffer, preferrably the buffer's previous buffer). % Do not kill the MAIN or OUTPUT buffer. (if (buffer-kill b) (for (in w (find-buffer-in-windows b)) (do (window-select-previous-buffer w))))) (de buffer-killable? (b) (not (or (eq b nmode-main-buffer) (eq b nmode-output-buffer) ))) % Internal function: (de buffer-kill (b) % Remove the specified buffer from the list of selectable buffers and return % T, unless the buffer is the MAIN or OUTPUT buffer, in which case do % nothing and return NIL. (let ((kill? (buffer-killable? b))) (if kill? (setf nmode-selectable-buffers (DelQ b nmode-selectable-buffers)) ) kill? )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/build-vax-nmode.sl version [9fb456678f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % A sketchy build file for NMODE binaries. Probably best executed from within % NMODE itself. (Won't necessarily run "sequentially"--it should work, but % it's never been tried, as of 29-mar-83.) % NOTE: need to build window stuff first, see $pw/VAX-SOURCES/build-windows.sl. (off usermode) % Avoid queries about redefining functions. % NOTE: there are several problems with the PSL compiler (and LAP) that cause % problems when compiling NMODE (29-mar-83). The following "patches" % should fix things (on HP VENUS) until the compiler gets fixed up. (setq options* NIL) % Force reloading of files. (load compiler) % Fix problems with ASHL, etc. (faslin "/vb/griss/vax-lap-fix.b") % Avoid problem with cmacro expansion for the SUBSTRING function (cmacro % seems silly anyway, overkill for imagined efficiency). (Note that the % cmacro isn't really at fault, it simply brings out the real problem(s) % with the compiler.) (load common) (remprop 'substring 'cmacro) (setf old-directory (pwd)) % Connect to the destination directory for the binaries. (cd "$pn/BINARIES") % Augment the directories used to lookup LOAD modules. (setf loaddirectories* (append '("" "$pn/BINARIES/" "$pw/BINARIES/") (delete "" loaddirectories*))) (faslout "browser") (dskin "$pn/browser.sl") (faslend) (faslout "browser-support") (dskin "$pn/browser-support.sl") (faslend) (faslout "buffer") (dskin "$pn/buffer.sl") (faslend) (faslout "buffer-io") (dskin "$pn/buffer-io.sl") (faslend) (faslout "buffer-position") (dskin "$pn/buffer-position.sl") (faslend) (faslout "buffer-window") (dskin "$pn/buffer-window.sl") (faslend) (faslout "buffers") (dskin "$pn/buffers.sl") (faslend) (faslout "case-commands") (dskin "$pn/case-commands.sl") (faslend) (faslout "command-input") (dskin "$pn/command-input.sl") (faslend) (faslout "commands") (dskin "$pn/commands.sl") (faslend) (faslout "defun-commands") (dskin "$pn/defun-commands.sl") (faslend) (faslout "dispatch") (dskin "$pn/dispatch.sl") (faslend) (faslout "extended-input") (dskin "$pn/extended-input.sl") (faslend) (faslout "fileio") (dskin "$pn/fileio.sl") (faslend) (faslout "incr") (dskin "$pn/incr.sl") (faslend) (faslout "indent-commands") (dskin "$pn/indent-commands.sl") (faslend) (faslout "kill-commands") (dskin "$pn/kill-commands.sl") (faslend) (faslout "lisp-commands") (dskin "$pn/lisp-commands.sl") (faslend) (faslout "lisp-indenting") (dskin "$pn/lisp-indenting.sl") (faslend) (faslout "lisp-interface") (dskin "$pn/lisp-interface.sl") (faslend) (faslout "lisp-parser") (dskin "$pn/lisp-parser.sl") (faslend) (faslout "m-x") (dskin "$pn/m-x.sl") (faslend) (faslout "m-xcmd") (dskin "$pn/m-xcmd.sl") (faslend) (faslout "modes") (dskin "$pn/modes.sl") (faslend) (faslout "mode-defs") (dskin "$pn/mode-defs.sl") (faslend) (faslout "move-commands") (dskin "$pn/move-commands.sl") (faslend) (faslout "nmode-attributes") (dskin "$pn/nmode-attributes.sl") (faslend) (faslout "nmode-break") (dskin "$pn/nmode-break.sl") (faslend) (faslout "nmode-init") (dskin "$pn/nmode-init.sl") (faslend) (faslout "nmode-parsing") (dskin "$pn/nmode-parsing.sl") (faslend) % Use Vax version of sources. (faslout "nmode-vax") (dskin "$pn/VAX-SOURCES/nmode-vax.sl") (faslend) (faslout "prompting") (dskin "$pn/prompting.sl") (faslend) (faslout "query-replace") (dskin "$pn/query-replace.sl") (faslend) (faslout "reader") (dskin "$pn/reader.sl") (faslend) (faslout "rec") (dskin "$pn/rec.sl") (faslend) (faslout "screen-layout") (dskin "$pn/screen-layout.sl") (faslend) (faslout "search") (dskin "$pn/search.sl") (faslend) % Use Vax version of sources. (faslout "set-terminal") (dskin "$pn/VAX-SOURCES/set-terminal.sl") (faslend) (faslout "softkeys") (dskin "$pn/softkeys.sl") (faslend) (faslout "structure-functions") (dskin "$pn/structure-functions.sl") (faslend) (faslout "terminal-input") (dskin "$pn/terminal-input.sl") (faslend) (faslout "text-buffer") (dskin "$pn/text-buffer.sl") (faslend) (faslout "text-commands") (dskin "$pn/text-commands.sl") (faslend) (faslout "window") (dskin "$pn/window.sl") (faslend) (faslout "window-label") (dskin "$pn/window-label.sl") (faslend) (faslout "autofill") (dskin "$pn/autofill.sl") (faslend) (faslout "browser-browser") (dskin "$pn/browser-browser.sl") (faslend) (faslout "buffer-browser") (dskin "$pn/buffer-browser.sl") (faslend) %* (faslout "dired") %* (dskin "$pn/dired.sl") %* (faslend) (faslout "doc") (dskin "$pn/doc.sl") (faslend) (cd old-directory) |
Added psl-1983/3-1/nmode/case-commands.sl version [88b3316c73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Case-Commands.SL - NMODE Case Conversion commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 October 1982 % % The original code was contributed by Jeff Soreff. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vectors fast-strings)) (fluid '( nmode-command-argument nmode-current-buffer )) % Global variables: (fluid '(shifted-digits-association-list)) (setf shifted-digits-association-list NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Case Conversion Commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de uppercase-word-command () (transform-region-with-next-word-or-fragment #'string-upcase)) (de lowercase-word-command () (transform-region-with-next-word-or-fragment #'string-downcase)) (de uppercase-initial-command () (transform-region-with-next-word-or-fragment #'string-capitalize)) (de uppercase-region-command () (transform-marked-region #'string-upcase)) (de lowercase-region-command () (transform-marked-region #'string-downcase)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Upcase Digit Command: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de upcase-digit-command () % Convert the previous digit to the corresponding "shifted character" % on the keyboard. Search only within the current line or the previous % line. Ding if no digit found. (let ((point (buffer-get-position)) (limit-line-pos (- (current-line-pos) 1)) (ok NIL) ) (while (and (>= (current-line-pos) limit-line-pos) (not (at-buffer-start?)) (not (setf ok (digitp (previous-character)))) ) (move-backward) ) (cond ((and ok (set-up-shifted-digits-association-list)) (let* ((old (previous-character)) (new (cdr (assoc old shifted-digits-association-list))) ) (delete-previous-character) (insert-character new) )) (t (Ding)) ) (buffer-set-position point) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % General Transformation Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de transform-region (string-conversion-function bp1 bp2) % Transform the region in the current buffer between the positions % BP1 and BP2 by applying the specified function to each partial or % complete line. The function should accept a single string argument % and return the transformed string. Return 1 if BP2 > BP1; % return -1 if BP2 < BP1. The buffer pointer is left at the "end" % of the transformed region (the greater of BP1 and BP2). (let* ((modified-flag (=> nmode-current-buffer modified?)) (extracted-pair (extract-region t bp1 bp2)) (newregion (cdr extracted-pair)) (oldregion (if (not modified-flag) (copyvector newregion))) ) (for (from index 0 (vector-upper-bound newregion) 1) (do (vector-store newregion index (apply string-conversion-function (list (vector-fetch newregion index)))))) (insert-text newregion) (if (and (not modified-flag) (text-equal newregion oldregion)) (=> nmode-current-buffer set-modified? nil) ) (car extracted-pair) )) (de transform-region-with-next-word-or-fragment (string-conversion-function) % Transform the region consisting of the following N words, where N is % the command argument. N may be negative, meaning previous words. (let ((start (buffer-get-position))) (move-over-words nmode-command-argument) (transform-region string-conversion-function start (buffer-get-position)) )) (de transform-marked-region (string-conversion-function) % Transform the region defined by point and mark. (let ((point (buffer-get-position)) (mark (current-mark)) ) (when (= (transform-region string-conversion-function point mark) 1) % The mark was at the end of the region. If the transformation changed % the length of the region, the mark may need to be updated. (previous-mark) % pop off old mark (set-mark-from-point) % set the mark to the end of the transformed region (buffer-set-position point) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de set-up-shifted-digits-association-list () % Ensure that the "shifted digits association list" is set up properly. % If necessary, ask the user for the required information. Returns the % association list if properly set up, NIL if an error occurred. (if (not shifted-digits-association-list) (let ((shifted-digits (prompt-for-string "Type the digits 1, 2, ... 9, 0, holding down Shift:" nil))) (cond ((= (string-length shifted-digits) 10) (setq shifted-digits-association-list (pair (string-to-list "1234567890") (string-to-list shifted-digits)))) ((> (string-length shifted-digits) 10) (nmode-error "Typed too many shifted digits!")) (t (nmode-error "Typed too few shifted digits!")) ))) shifted-digits-association-list ) |
Added psl-1983/3-1/nmode/command-input.sl version [f19b6ee3f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command-Input.SL - NMODE Command Input Routines % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command Prefix Character Functions: % % A command prefix character function must be tagged with the property % 'COMMAND-PREFIX. It should also define the property 'COMMAND-PREFIX-NAME % to be a string that will be used to print the command name of commands % that include a prefix character that is mapped to that function. (The % function DEFINE-COMMAND-PREFIX is used to set these properties.) The % function itself should return a command (see dispatch.sl for a description). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de define-command-prefix (function-name name-string) (put function-name 'command-prefix T) (put function-name 'command-prefix-name name-string) ) (de prefix-name (ch) % Return the string to be used in printing a command with this prefix char. (let ((func (dispatch-table-lookup ch))) (or (and func (get func 'command-prefix-name)) (string-concat (x-char-name ch) " ") ))) % Here we define some prefix command functions: (define-command-prefix 'c-x-prefix "C-X ") (define-command-prefix 'Esc-prefix "Esc-") (define-command-prefix 'Lisp-prefix "Lisp-") (define-command-prefix 'm-x-prefix "M-X ") (de c-x-prefix () (nmode-append-separated-prompt "C-X ") (let ((ch (input-terminal-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char C-X) ch) )) (de Esc-prefix () (nmode-append-separated-prompt "Esc-") (let ((ch (input-extended-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char ESC) ch) )) (de Lisp-prefix () (nmode-append-separated-prompt "Lisp-") (let ((ch (input-terminal-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char C-!]) ch) )) (de m-x-prefix () (list (x-char M-X) (prompt-for-extended-command "Extended Command:"))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command Input Functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de input-base-character () (X-Base (input-terminal-character)) ) (de input-command () % Return either a single (extended) character or a list containing a valid % prefix character plus its argument (character or string). (let* ((ch (input-extended-character)) (func (dispatch-table-lookup ch)) ) (if (and func (get func 'command-prefix)) (apply func ()) ch ))) |
Added psl-1983/3-1/nmode/commands.sl version [2cf532825b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Commands.SL - Miscellaneous NMODE commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 9 March 1983 % % 9-Mar-83 Alan Snyder % Create-buffer-unselectable -> Create-Unnamed-Buffer. % 3-Dec-82 Alan Snyder % Changed Insert-Self-Command to handle control- and meta- characters. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int)) % External variables used: (fluid '(nmode-current-buffer nmode-command-argument nmode-current-window nmode-command-argument-given nmode-current-command nmode-terminal nmode-allow-refresh-breakout Text-Mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de insert-self-command () (if (FixP nmode-current-command) (let ((ch (x-base nmode-current-command))) (if (x-control? nmode-current-command) (let ((nch (char-upcase ch))) (if (and (>= nch #/@) (<= nch #/_)) (setf ch (^ nch #/@)) ))) (for (from i 1 nmode-command-argument) (do (insert-character ch))) ) % otherwise (Ding) )) (de insert-next-character-command () (nmode-append-separated-prompt "C-Q") (let ((ch (x-base (input-direct-terminal-character)))) (nmode-complete-prompt (string-concat " " (x-char-name ch))) (for (from i 1 nmode-command-argument) (do (insert-character ch))))) (de return-command () % Insert an EOL, unless we are at the end of thee current line and the % next line is empty. Repeat as directed. (for (from i 1 nmode-command-argument) (do (cond ((and (at-line-end?) (not (at-buffer-end?))) (move-to-next-line) (cond ((not (current-line-empty?)) (insert-eol) (move-to-previous-line) ))) (t (insert-eol)))))) (de select-buffer-command () (buffer-select (prompt-for-selectable-buffer))) (de prompt-for-selectable-buffer () (let ((default-b (=> nmode-current-buffer previous-buffer))) (if (and default-b (not (buffer-is-selectable? default-b))) (setf default-b NIL)) (prompt-for-buffer "Select Buffer: " default-b))) (de kill-buffer-command () (let ((b (prompt-for-existing-buffer "Kill buffer: " nmode-current-buffer))) (if (or (not (=> b modified?)) (YesP "Kill unsaved buffer?")) (buffer-kill-and-detach b)))) (de insert-buffer-command () (let ((b (prompt-for-existing-buffer "Insert Buffer:" nmode-current-buffer))) (insert-buffer-into-buffer b nmode-current-buffer) )) (de select-previous-buffer-command () (let ((old-buffer nmode-current-buffer)) (buffer-select-previous nmode-current-buffer) (if (eq old-buffer nmode-current-buffer) (Ding)) % nothing visible happened )) (de visit-in-other-window-command () (nmode-2-windows) (selectq (char-upcase (input-base-character)) (#/B (let ((b (prompt-for-selectable-buffer))) (window-select-buffer (nmode-other-window) b))) (#/F (find-file-in-window (nmode-other-window) (prompt-for-file-name "Find file: " NIL) )) (t (Ding)) )) (de nmode-refresh-command () (if nmode-command-argument-given (let* ((arg nmode-command-argument) (w nmode-current-window) (height (=> w height)) (line (current-line-pos)) ) (if (>= arg 0) (=> w set-buffer-top (- line arg)) (=> w set-buffer-top (- (- line height) arg))) (nmode-refresh) ) % Otherwise (=> nmode-current-window readjust-window) (nmode-full-refresh) )) (de open-line-command () (for (from i 1 nmode-command-argument) (do (insert-eol) (move-backward) ))) (de Ding () (=> nmode-terminal ring-bell)) (de buffer-not-modified-command () (=> nmode-current-buffer set-modified? NIL) ) (de set-mark-command () (cond (nmode-command-argument-given (buffer-set-position (current-mark)) (previous-mark) ) (t (set-mark-from-point) ))) (de mark-beginning-command () (let ((old-pos (buffer-get-position))) (move-to-buffer-start) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-end-command () (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (set-mark-from-point) (buffer-set-position old-pos) )) (de transpose-characters-command () (cond ((or (at-line-start?) (< (current-line-length) 2)) (Ding) ) (t (if (at-line-end?) % We are at the end of a non-empty line. (move-backward) ) % We are in the middle of a line. (let ((ch (previous-character))) (delete-previous-character) (move-forward) (insert-character ch) ) ))) (de mark-word-command () (let ((old-pos (buffer-get-position))) (move-forward-word-command) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-form-command () (let ((old-pos (buffer-get-position))) (move-forward-form-command) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-whole-buffer-command () (move-to-buffer-end) (set-mark-from-point) (move-to-buffer-start) ) (de nmode-abort-command () (throw 'abort NIL) ) (de start-scripting-command () (let ((b (prompt-for-buffer "Script Input to Buffer:" NIL))) (nmode-script-terminal-input b) )) (de stop-scripting-command () (nmode-script-terminal-input nil) ) (de execute-buffer-command () (let ((b (prompt-for-buffer "Execute from Buffer:" NIL))) (setf nmode-allow-refresh-breakout nmode-command-argument-given) (nmode-execute-buffer b) )) (de execute-file-command () (nmode-execute-file (prompt-for-file-name "Execute File:" NIL))) (de nmode-execute-file (fn) (let ((b (create-unnamed-buffer Text-Mode))) (read-file-into-buffer b fn) (setf nmode-allow-refresh-breakout nmode-command-argument-given) (nmode-execute-buffer b) )) (de apropos-command () (let ((s (prompt-for-string "Show commands whose names contain the string:" NIL ))) (nmode-begin-typeout) (print-matching-dispatch s) (printf "-----") (nmode-end-typeout) )) |
Added psl-1983/3-1/nmode/dabbrevs.sl version [e8e5e5e384].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Dabbrevs.SL - Dynamic Abbreviations for NMODE % % Author: Mark R. Swanson % University of Utah % Date: 15 June 1983 % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Methods provided: (all internal, really) % initial-expansion % expand-aux % find-next-expansion % get-expansion-from-buffer % expand % save-expansion % % Commands defined: % instant-abbrev-command % Tries to "expand" the word (or prefix) before point by searching for other % words with the same prefix. The search goes back from point (or from the % location of the last expansion found for the current abbreviation); if % unsuccessful, a search is done forward from point. Re-issuing the command % causes a search for the next possible expansion. The command is initially % bound to the M-<space> key. (CompileTime (load objects fast-int)) (fluid '(current-abbrev-expansion)) (setf current-abbrev-expansion nil) (defflavor abbrev-expansion (abbrev % original abbreviation string abbrev-start-pos abbrev-end-pos (expansion-list nil) % list of all expansions tried (including abbrev) expansion-start-pos % start of latest expansion expansion-end-pos % end of latest expansion last-pos % position of end of latest expansion/abbrev in % buffer (direction -1) % initially look backwards (-1) (word-delim-list '(#\!( #\!) #\!' #\- #\space #\<)) % word delimitors ) () ) (defmethod (abbrev-expansion initial-expansion) () % Initial attempt to find an expansion for "word" before point. Search goes % first backward, then forward, through buffer for an appropriate expansion. (setf last-pos (setf abbrev-end-pos (buffer-get-position))) (if (not (move-backward-word)) % is there a word to expand? (ding) % no % else yes (setf abbrev-start-pos (buffer-get-position)) % bracket its position (setf abbrev (cdr (extract-region nil abbrev-start-pos abbrev-end-pos))) (=> self save-expansion abbrev) % abbrev is its own initial "expansion" (=> self expand-aux) )) (defmethod (abbrev-expansion expand-aux) () % Actually do the expansion (or re-expansion); search backwards first, then % forwards if necessary; do not re-present duplicate expansions which have % already been tried. (write-message (concat "Expanding " (vector-fetch abbrev 0))) (let ((found-one nil) new-expansion) (while (and (~= direction 0) % if zero we have searched in both directions (not found-one)) (setf new-expansion (=> self find-next-expansion direction)) (if new-expansion % then (progn (if (< direction 0) % move ptr for next search (may not be necessary) (move-backward) (move-forward)) (setf found-one (not (member new-expansion expansion-list)))) %else (setf direction (if (= direction -1) 1 0)) % change directions (buffer-set-position last-pos) % and start from original location )) % Finally insert expansion and add it to history (if found-one (progn (extract-region T abbrev-start-pos last-pos) %remove old abbrev/expans. (insert-string (vector-fetch new-expansion 0)) % put in new expans. (setf last-pos (buffer-get-position)) % note end of expans. (=> self save-expansion new-expansion)) % else (buffer-set-position last-pos) % put point back where we started (ding) % let user know we failed ))) (defmethod (abbrev-expansion find-next-expansion) (dir) % Search backward/forward from current location for an expansion (string match of % abbreviation preceded by a word delimitor. Returns NIL on failure, % expansion-string on success; leaves point at start of last string match. (let ((found-one nil)) (while (and (not found-one) (buffer-text-search? abbrev dir)) (if (or (=> nmode-current-buffer at-line-start?) (member (=> nmode-current-buffer previous-character) word-delim-list)) (setf found-one T) (if (< dir 0) (move-backward) (move-forward)))) (if found-one (=> self get-expansion-from-buffer)))) (defmethod (abbrev-expansion get-expansion-from-buffer) () % Extracts the expansion from the buffer; on entry point should be at start % of expansion, on exit it will be returned to that position. Form of % result should be a vector containing 1 string. (let (expans) (setf expansion-start-pos (buffer-get-position)) (move-forward-word) (setf expansion-end-pos (buffer-get-position)) (setf expans (cdr (extract-region NIL expansion-start-pos expansion-end-pos))) (buffer-set-position expansion-start-pos) expans)) (defmethod (abbrev-expansion expand) () % Attempt to re-expand last expansion. Point must be at end of previous % expansion, word itself should not have been changed. (let ((cur-pos (buffer-get-position))) (if (and (equal last-pos (buffer-get-position)) (move-backward-word) (equal abbrev-start-pos (buffer-get-position)) (equal (car expansion-list) (cdr (extract-region nil abbrev-start-pos last-pos)))) (progn (buffer-set-position expansion-start-pos) (=> nmode-current-buffer move-backward) (=> self expand-aux)) (buffer-set-position cur-pos) nil ))) (defmethod (abbrev-expansion save-expansion) (expansion) (setf expansion-list (adjoin expansion expansion-list))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % dynamic abbreviation command and its installation % (de instant-abbrev-command () (cond ((or (null current-abbrev-expansion) (null (=> current-abbrev-expansion expand))) (setf current-abbrev-expansion (make-instance 'abbrev-expansion)) (=> current-abbrev-expansion initial-expansion)))) (setf Text-Command-List (NConc Text-Command-List (list (cons (x-char M-! ) 'instant-abbrev-command) ))) |
Added psl-1983/3-1/nmode/defun-commands.sl version [21ed3c9979].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Defun-Commands.SL - NMODE DEFUN commands and functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-command-argument nmode-command-argument-given nmode-current-command )) % Global variables: (fluid '(nmode-defun-predicate nmode-defun-scanner )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Defun Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de reposition-window-command () % Adjust the current window so that the beginning of the % current DEFUN is on the top line of the screen. If this change % would push the current line off the screen, do nothing but ring % the bell. (let ((old-pos (buffer-get-position))) (when (move-to-start-of-current-defun) % if search for defun succeeds (let ((old-line (buffer-position-line old-pos)) (defun-line (current-line-pos)) ) (if (or (< old-line defun-line) % Impossible? (>= old-line (+ defun-line (current-window-height))) ) (Ding) % Old Line wouldn't show on the screen % otherwise (current-window-set-top-line defun-line) )) (buffer-set-position old-pos) ))) (de end-of-defun-command () % This command has a very strange definition in EMACS. I don't even % want to try to explain it! It is probably a kludge in EMACS since % it generates very strange error messages! (if (< nmode-command-argument 0) (move-backward)) % First, we must get positioned up at the beginning of the proper defun. % If we are within a defun, we want to start at the beginning of that % defun. If we are between defuns, then we want to start at the beginning % of the next defun. (if (not (move-to-start-of-current-defun)) (move-forward-defun)) % Next, we move to the requested defun, and complain if we can't find it. (unless (cond ((> nmode-command-argument 1) (move-over-defuns (- nmode-command-argument 1))) ((< nmode-command-argument 0) (move-over-defuns nmode-command-argument)) (t t) ) (Ding) ) % Finally, we move to the end of whatever defun we wound up at. (if (not (move-to-end-of-current-defun)) (Ding)) ) (de mark-defun-command () (cond ((or (move-to-end-of-current-defun) (and (move-forward-defun) (move-to-end-of-current-defun)) ) (set-mark-from-point) (move-backward-defun) (when (not (current-line-is-first?)) (move-to-previous-line) (if (not (current-line-blank?)) (move-to-next-line)) )) (t (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Defun Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-backward-defun () % Move backward at least one character to the previous beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (when (move-backward-character) (or (beginning-of-defun) (progn (move-forward-character) NIL) % return NIL ))) (de beginning-of-defun () % Move backward, if necessary, to the beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) (move-to-start-of-line) (while T (when (current-line-is-defun?) (exit T)) (when (current-line-is-first?) (buffer-set-position old-pos) (exit NIL)) (move-to-previous-line) ))) (de move-forward-defun () % Move forward at least one character to the next beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) (while T (when (current-line-is-last?) (buffer-set-position old-pos) (exit NIL)) (move-to-next-line) (when (current-line-is-defun?) (exit T)) ))) (de move-to-start-of-current-defun () % If point lies within the text of a (possibly incomplete) defun, or on % the last line of a complete defun, then move to the beginning of the % defun. Otherwise, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) % save original position (if (beginning-of-defun) % find previous defun start (let ((start-pos (buffer-get-position))) % save defun starting position % We succeed if the current defun has no end, or if the end is % beyond the old position in the buffer. (if (or (not (scan-past-defun)) (<= (buffer-position-line old-pos) (current-line-pos)) ) (progn (buffer-set-position start-pos) T) (progn (buffer-set-position old-pos) NIL) ))))) (de move-to-end-of-current-defun () % If point lies within the text of a complete defun, or on the last line % of the defun, then move to the next line following the end of the defun. % Otherwise, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) % save original position (if (and (beginning-of-defun) % find previous defun start (scan-past-defun) % find end of that defun (<= (buffer-position-line old-pos) (current-line-pos)) ) (progn (move-to-next-line) T) (progn (buffer-set-position old-pos) NIL) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Defun Scanning Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-line-is-defun? () (if nmode-defun-predicate (apply nmode-defun-predicate ()) )) (de scan-past-defun () % This function should be called with point at the start of a defun. % It will scan past the end of the defun (not to the beginning of the % next line, however). If the end of the defun is not found, it returns % NIL and leaves point unchanged. (if nmode-defun-scanner (apply nmode-defun-scanner ()) )) |
Added psl-1983/3-1/nmode/dired.sl version [4eb5cc3527].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DIRED.SL - Directory Editor Subsystem % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 July 1982 % Revised: 11 April 1983 % % This file implements a directory editor subsystem. % % 5-April-83 Jeff Soreff % Added filter functions to dired commands. % 17-Mar-83 Alan Snyder % Bug fix: new item made by create command had wrong width. % 14-Mar-83 Alan Snyder % Fix C-X D to view directory of current file, rather than connected % directory, when the current filename has only a device field. Add Create % and Look commands. Change to sort based on displayed name rather than full % name (since that's what the user sees). Check for NIL dates in sort % functions. Change to cleanup item when killed. Convert for revised % browser mechanism. % 4-Mar-83 Alan Snyder % Fix to work with files whose names are not valid pathnames. % 3-Mar-83 Alan Snyder % Add Browse command to browse subdirectories. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % Fix cleanup method to NIL out the buffer variable to allow the buffer object % to be garbage collected. % 11-Feb-83 Alan Snyder % Fix bug in previous change. % 8-Feb-83 Alan Snyder % Enlarge width of size field in display. % 4-Feb-83 Alan Snyder % Rewritten to use new browser support. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load extended-char fast-strings numeric-operators)) (load directory stringx) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '( nmode-current-buffer nmode-terminal nmode-command-argument nmode-command-argument-given )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal static variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(file-browser-mode file-browser-command-list file-browser-documentation-text file-browser-help-text dired-argument-list )) (setf file-browser-help-text ["? View Edit Browse Create Filter Un/Delete Kill-now uN/Ignore Sort/Reverse Look Quit"]) (setf file-browser-documentation-text ["The File Browser displays the files in a directory." "Terminology: the current file is the file pointed at by the cursor." "The View (V) and Edit (E) commands both display the current file." "In split-screen mode, Edit selects the bottom window while View does not." "The Create (C) command creates a new file, but does not select it." "The Filter (F) command removes a set of files from the display." "The Delete (D) command marks the current file for deletion upon Quit." "The Undelete (U) command removes the mark made by the Delete command." "The Kill (K) command deletes the current file immediately." "The Ignore (I) command removes the current file from the display." "The uNignore (N) command restores all Ignored files to the display." "The Sort (S) command sorts the files in various ways." "The Reverse (R) command sorts the files in reverse order." "The Look (L) command re-reads the directory to get up-to-date info." "The Quit (Q) command exits the browser and deletes any marked files," "after first asking for permission." ]) (setf file-browser-mode (nmode-define-mode "File-Browser" '( (nmode-define-commands File-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf file-browser-command-list (list (cons (x-char ?) 'browser-help-command) (cons (x-char B) 'dired-browse-command) (cons (x-char C) 'dired-create-command) (cons (x-char D) 'browser-delete-command) (cons (x-char E) 'browser-edit-command) (cons (x-char F) 'dired-filter-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char K) 'browser-kill-command) (cons (x-char L) 'dired-look-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char Q) 'dired-exit) (cons (x-char R) 'dired-reverse-sort) (cons (x-char S) 'dired-sort) (cons (x-char U) 'browser-undelete-command) (cons (x-char V) 'browser-view-command) (cons (x-char X) 'dired-exit) (cons (x-char BACKSPACE) 'browser-undelete-backwards-command) (cons (x-char RUBOUT) 'browser-undelete-backwards-command) (cons (x-char SPACE) 'move-down-command) (cons (x-char control D) 'browser-delete-command) (cons (x-char control K) 'browser-kill-command) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-command () (let ((fn (=> nmode-current-buffer file-name)) directory-name ) (cond ((or (not fn) (>= nmode-command-argument 4)) (setf directory-name (prompt-for-string "Edit Directory: " NIL)) ) (nmode-command-argument-given (setf directory-name (namestring (pathname-without-version fn))) ) (t (setf directory-name (namestring (pathname-without-name fn))) )) (directory-editor directory-name) )) (de edit-directory-command () (let* ((fn (=> nmode-current-buffer file-name)) (directory-name (prompt-for-string "Edit Directory:" (and fn (directory-namestring fn)) ))) (directory-editor directory-name) )) (define-browser-prototype 'edit-directory-command "File Directory Browser" ["This prototype creates a browser for the" "set of files in a directory."]) (de directory-editor (directory-name) % Put up a directory editor subsystem, containing all files that match the % specified string. If the string specifies a directory, then all files in % that directory are displayed. (setf directory-name (fixup-directory-name directory-name)) (write-prompt "Reading directory or directories...") (let ((file-list (find-matching-files directory-name t))) (if (null file-list) (write-prompt (BldMsg "No files match: %w" directory-name)) % otherwise (let* ((browser (or (find-browser 'FILE-BROWSER directory-name) (create-file-browser directory-name) )) (items (dired-create-items file-list (=> browser display-width))) ) (=> browser set-items items) (browser-enter browser) )))) (de create-file-browser (directory-name) (let* ((header-text (vector (string-concat "Directory List of " directory-name) "" )) (browser (create-browser 'FILE-BROWSER "Files" directory-name file-browser-mode NIL header-text file-browser-documentation-text file-browser-help-text () #'dired-filename-sorter) )) (=> browser put 'directory-name directory-name) browser )) (de dired-create-items (file-list display-width) % Accepts a list containing one element per file, where each element is % a list. Returns a list of file-browser-items. (when file-list (let* ((names (for (in f file-list) (collect (fixup-file-name (nth f 1))) )) (prefix (trim-filename-to-prefix (strings-largest-common-prefix names))) (prefix-length (string-length prefix)) ) (for (in f file-list) (collect (create-file-browser-item display-width (nth f 1) % full-name (string-rest (fixup-file-name (nth f 1)) prefix-length) % nice-name (nth f 2) % deleted? (nth f 3) % size (nth f 4) % write-date (nth f 5) % read-date )))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED command procedures: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-exit () (let ((actions (dired-determine-actions nmode-current-buffer))) (if (and (null (first actions)) (null (second actions))) (browser-exit-command) % else (let ((command (dired-present-actions actions))) (cond ((eq command 'exit) (browser-exit-command) ) ((eq command t) (dired-perform-actions actions) (browser-exit-command) ) )) ))) (de dired-browse-command () % Browse the current item (presumably, a subdirectory). (let* ((browser (current-browser)) (item (=> browser current-item)) ) (if item (directory-editor (=> item full-name)) (Ding) ))) (de dired-create-command () (let* ((browser (current-browser)) (dir-pn (pathname-without-name (=> browser get 'directory-name))) (fn (prompt-for-string "Create file whose name is:" NIL)) (pn (maybe-pathname fn)) sout ) (if (not pn) (nmode-error (bldmsg "Invalid pathname: %w" fn)) % otherwise (if (not (and (null (pathname-device pn)) (null (pathname-directory pn)) )) (nmode-error "Device and directory may not be specified.") % otherwise (setf pn (merge-pathname-defaults dir-pn (pathname-name pn) (pathname-type pn) (pathname-version pn) )) (setf fn (namestring pn)) (if (filep fn) (nmode-error (bldmsg "File %w already exists." fn)) % otherwise (setf fn (actualize-file-name fn)) (if (or (not fn) (not (setf sout (attempt-to-open-output fn)))) (nmode-error (bldmsg "Unable to create file: %w" (namestring pn))) % otherwise (=> sout close) (let ((item (create-file-browser-item (=> browser display-width) fn (file-namestring fn) nil 0 nil nil))) (browser-add-item-and-view item) ))))))) (de dired-look-command () % Reinitialize the file directory browser. (write-prompt "Reading directory or directories...") (let* ((browser (current-browser)) (directory-name (=> browser get 'directory-name)) (file-list (find-matching-files directory-name t)) (items (dired-create-items file-list (=> browser display-width))) ) (=> browser set-items items) )) (de dired-filter-command () (nmode-set-immediate-prompt "Flush or Keep matching filenames?") (dired-filter-dispatch)) (de dired-filter-dispatch () (selectq (char-upcase (input-base-character)) (#/F (dired-filter-compose t)) (#/K (dired-filter-compose nil)) (#/? (nmode-set-immediate-prompt "Type F to flush or K to keep matching filenames.") (dired-filter-dispatch)) (t (write-prompt "") (Ding)))) (de dired-filter-compose (flag) (let ((browser (current-browser)) (dired-argument-list (list (string-upcase (prompt-for-string (if flag "Flush filenames matching what string?" "Keep filenames matching what string?") "")) flag))) (=> browser filter-items #'dired-string-filter-predicate))) (de dired-reverse-sort () (nmode-set-immediate-prompt "Reverse Sort by ") (dired-reverse-sort-dispatch) ) (de dired-reverse-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/F (browser-sort "Reverse Sort by Filename" 'dired-filename-reverser)) (#/S (browser-sort "Reverse Sort by Size" 'dired-size-reverser)) (#/W (browser-sort "Reverse Sort by Write date" 'dired-write-reverser)) (#/R (browser-sort "Reverse Sort by Read date" 'dired-read-reverser)) (#/? (nmode-set-immediate-prompt "Reverse Sort by (Filename, Size, Read date, Write date) ") (dired-reverse-sort-dispatch) ) (t (write-prompt "") (Ding)) )) (de dired-sort () (nmode-set-immediate-prompt "Sort by ") (dired-sort-dispatch) ) (de dired-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/F (browser-sort "Sort by Filename" 'dired-filename-sorter)) (#/S (browser-sort "Sort by Size" 'dired-size-sorter)) (#/W (browser-sort "Sort by Write date" 'dired-write-sorter)) (#/R (browser-sort "Sort by Read date" 'dired-read-sorter)) (#/? (nmode-set-immediate-prompt "Sort by (Filename, Size, Read date, Write date) ") (dired-sort-dispatch) ) (t (write-prompt "") (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-string-filter-predicate (file-browser-item) (let* ((nice-name (=> file-browser-item nice-name)) (match (forward-search-in-string nice-name (first dired-argument-list)))) (when (second dired-argument-list) (setf match (not match))) match)) (de dired-determine-actions (b) % Return a list containing two lists: the first a list of file names to be % deleted, the second a list of file names to be undeleted. (let ((items (=> (=> b get 'browser) items)) (delete-list ()) (undelete-list ()) ) (for (in item items) (do (selectq (=> item action-wanted) (delete (setf delete-list (aconc delete-list (=> item full-name)))) (undelete (setf undelete-list (aconc undelete-list (=> item full-name)))) ))) (list delete-list undelete-list) )) (de dired-present-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ) (nmode-begin-typeout) (dired-present-list delete-list "These files to be deleted:") (dired-present-list undelete-list "These files to be undeleted:") (while t (printf "%nDo It (YES, N, X)? ") (selectq (get-upchar) (#/Y (if (= (get-upchar) #/E) (if (= (get-upchar) #/S) (exit T) (Ding) (next)) (Ding) (next)) ) (#/N (exit NIL)) (#/X (exit 'EXIT)) (#/? (printf "%n YES-Do it, N-Return to DIRED, X-Exit from DIRED.")) (t (Ding)) )))) (de get-upchar () % This function is used during "normal PSL" typeout, so we cannot use % the NMODE input functions, for they will refresh the NMODE windows. (let ((ch (X-Base (=> nmode-terminal get-character)))) (when (AlphaP ch) (setf ch (char-upcase ch)) (WriteChar ch)) ch)) (de dired-present-list (list prompt) (when list (printf "%w%n" prompt) (for (in item list) (for count 0 (if (= count 1) 0 (+ count 1))) (do (printf "%w" (string-pad-right item 38)) (if (= count 1) (printf "%n")) ) ) (printf "%n") )) (de dired-perform-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ) (for (in file delete-list) (do (file-delete file))) (for (in file undelete-list) (do (file-undelete file))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Sorting predicates: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor file-browser-item f1 f2) (de dired-filename-sorter (f1 f2) (let ((n1 (=> f1 sort-name)) (n2 (=> f2 sort-name)) ) (if (string= n1 n2) (<= (=> f1 version-number) (=> f2 version-number)) (string<= n1 n2) ))) (de dired-filename-reverser (f1 f2) (not (dired-filename-sorter f1 f2))) (de dired-size-sorter (f1 f2) (let ((size1 (=> f1 size)) (size2 (=> f2 size)) ) (or (< size1 size2) (and (= size1 size2) (dired-filename-sorter f1 f2)) ))) (de dired-size-reverser (f1 f2) (let ((size1 (=> f1 size)) (size2 (=> f2 size)) ) (or (> size1 size2) (and (= size1 size2) (dired-filename-sorter f1 f2)) ))) (de dired-write-sorter (f1 f2) (let ((d1 (or (=> f1 write-date) 0)) (d2 (or (=> f2 write-date) 0)) ) (or (LessP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-write-reverser (f1 f2) (let ((d1 (or (=> f1 write-date) 0)) (d2 (or (=> f2 write-date) 0)) ) (or (GreaterP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-read-sorter (f1 f2) (let ((d1 (or (=> f1 read-date) 0)) (d2 (or (=> f2 read-date) 0)) ) (or (LessP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-read-reverser (f1 f2) (let ((d1 (or (=> f1 read-date) 0)) (d2 (or (=> f2 read-date) 0)) ) (or (GreaterP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (undeclare-flavor f1 f2) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The file-browser-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-file-browser-item (width full-name nice-name deleted? size write-date read-date) (make-instance 'file-browser-item 'full-name full-name 'nice-name nice-name 'deleted? deleted? 'size size 'write-date write-date 'read-date read-date 'display-width width )) (defflavor file-browser-item ( display-text display-width full-name % full name of file nice-name % file name as displayed sort-name % name without version (for sorting purposes) version-number % version number (or 0) (for sorting purposes) size % size of file (arbitrary units) write-date % write date of file (or NIL) read-date % read date of file (or NIL) deleted? % file is actually deleted delete-flag % user wants file deleted (buffer NIL) % buffer created to view file ) () (gettable-instance-variables display-text full-name nice-name sort-name version-number size write-date read-date) (initable-instance-variables) ) (defmethod (file-browser-item init) (init-plist) (let ((pn (maybe-pathname nice-name))) (setf sort-name (if pn (namestring (pathname-without-version pn)) nice-name)) (setf version-number (if pn (pathname-version pn) 0)) (if (not (fixp version-number)) (setf version-number 0)) ) (setf display-text (string-concat (if deleted? "D " " ") (string-pad-right nice-name (- display-width 48)) (string-pad-left (BldMsg "%d" size) 8) (string-pad-left (if write-date (file-date-to-string write-date) "") 19) (string-pad-left (if read-date (file-date-to-string read-date) "") 19) )) (setf delete-flag deleted?) ) (defmethod (file-browser-item update) () % Updating is too expensive, so we do nothing. T ) (defmethod (file-browser-item delete) () (when (not delete-flag) (setf display-text (copystring display-text)) (string-store display-text 0 #/D) (setf delete-flag T) )) (defmethod (file-browser-item undelete) () (when delete-flag (setf display-text (copystring display-text)) (string-store display-text 0 #\space) (setf delete-flag NIL) )) (defmethod (file-browser-item deleted?) () delete-flag ) (defmethod (file-browser-item kill) () (let ((result (nmode-delete-file full-name))) (when result (=> self cleanup) ) result )) (defmethod (file-browser-item view-buffer) (x) (or (find-file-in-existing-buffer full-name) (setf buffer (find-file-in-buffer full-name T)) )) (defmethod (file-browser-item cleanup) () (when (and buffer (not (=> buffer modified?))) (when (buffer-is-selectable? buffer) (=> buffer set-previous-buffer NIL) % don't display the browser (buffer-kill-and-detach buffer) ) (setf buffer NIL) )) (defmethod (file-browser-item apply-filter) (filter) (apply filter (list self)) ) (defmethod (file-browser-item action-wanted) () % Return 'DELETE, 'UNDELETE, or NIL. (if (not (eq deleted? delete-flag)) % user wants some action taken (let ((file-status (file-deleted-status full-name))) (if file-status % File currently exists (otherwise, forget it) (let ((actually-deleted? (eq file-status 'deleted))) (if (not (eq delete-flag actually-deleted?)) (if delete-flag 'DELETE 'UNDELETE) )))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/dispatch.sl version [aa5db0efa5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DISPATCH.SL - NMODE Dispatch table utilities % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int fast-vectors)) (fluid '(nmode-current-buffer nmode-minor-modes)) % A command is represented either as a single extended character (i.e., a % character including Meta and Control bits) or as a list whose first element % is an extended character (a command prefix character, e.g. C-X or M-X) and % whose second element is the "argument", either an extended character or a % string (for M-X). % The dispatch table maps commands (as defined above) to functions (of no % arguments). There is a single command table that defines the "keyboard % bindings" for the current mode. Associated with every buffer is a list of % forms to evaluate which will establish the keyboard bindings for that % buffer. % The dispatch table is represented by a 512-element vector % NMODE-DISPATCH-TABLE which maps extended characters to functions, augmented % by an association list for each prefix character (e.g., C-X and M-X) that % maps extended characters to functions. The prefix character assocation lists % are themselves stored in an association list that maps from prefix % characters. This master association list is bound to the variable % NMODE-PREFIX-DISPATCH-LIST. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following are INTERNAL static variables: (fluid '(nmode-dispatch-table nmode-prefix-dispatch-list)) (if (null nmode-dispatch-table) (setf nmode-dispatch-table (MkVect 511))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Dispatch table lookup functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dispatch-table-lookup (command) % Return the dispatch table entry for the specified character or character % sequence. NIL is returned for undefined commands. (cond % Single character: ((FixP command) (getv nmode-dispatch-table command) ) % Character sequence: ((PairP command) (let* ((prefix-char (car command)) (argument (cadr command)) (prefix-entry (lookup-prefix-character prefix-char)) ) (and prefix-entry % Look up the entry for the prefixed character. (let ((char-entry (Atsoc argument prefix-entry))) (and char-entry (cdr char-entry)) )))) % If we get here, we were given a bad argument (t (StdError (BldMsg "Bad argument %p for Dispatch-Table-Lookup" command)) ))) (de lookup-prefix-character (ch) % Return the pair (PREFIX-CHAR . ASSOCIATION-LIST) for the specified prefix % character. This pair may be modified using RPLACD. (let ((assoc-entry (atsoc ch nmode-prefix-dispatch-list))) (when (null assoc-entry) % Create an entry for this prefix character. (setf assoc-entry (cons ch NIL)) (setf nmode-prefix-dispatch-list (cons assoc-entry nmode-prefix-dispatch-list)) ) assoc-entry )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Manipulating the dispatch table: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-make-self-inserting (chr) % Define the specified character to be "self inserting". (nmode-define-command chr 'insert-self-command)) (de nmode-undefine-command (chr) % Remove the command definition of the specified command. % If the command is entered, the bell will be rung. (nmode-define-command chr NIL)) (de nmode-define-commands (lis) (for (in x lis) (do (nmode-define-command (car x) (cdr x))))) (de nmode-define-normal-self-inserts () (nmode-make-self-inserting (char TAB)) (for (from i 32 126) (do (nmode-make-self-inserting i)))) (de nmode-define-command (command op) % Set up the keyboard dispatch table for a character or a character sequence. % If the character is uppercase, define the equivalent lower case character % also. (cond % Single character: ((FixP command) (vector-store nmode-dispatch-table command op) (cond ((X-UpperCaseP command) (vector-store nmode-dispatch-table (X-Char-DownCase command) op)))) % Character Sequence: ((PairP command) (let* ((prefix-char (car command)) (argument (cadr command)) (prefix-entry (lookup-prefix-character prefix-char)) ) (if (null prefix-entry) (StdError (BldMsg "Undefined prefix-character in command %p" command)) % else % Add the prefixed character to the association list. Note that in % case of duplicate entries the last one added is the one that counts. (rplacd prefix-entry (cons (cons argument op) (cdr prefix-entry))) % Define the lower case version of the character, if relevent. (cond ((and (FixP argument) (X-UpperCaseP argument)) (rplacd prefix-entry (cons (cons (X-Char-DownCase argument) op) (cdr prefix-entry))) ))))) % If we get here, we were given a bad argument (t (StdError (BldMsg "Impossible command %p" command)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Mode Establishing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-establish-current-mode () (when nmode-current-buffer (nmode-clear-dispatch-table) (nmode-establish-mode (=> nmode-current-buffer mode)) (for (in minor-mode nmode-minor-modes) (do (nmode-establish-mode minor-mode))) )) (de nmode-establish-mode (mode) % "Establish" the specified MODE: evaluate its "establish expressions" to set % up the dispatch table. Use reverse so things on front of list are % evaluated last. (So that later incremental changes are added later.) (for (in x (reverse (=> mode establish-expressions))) (do (if (pairp x) (eval x) (StdError (BldMsg "Invalid mode expression: %r" x)) )) )) (de nmode-clear-dispatch-table () % Set up a "clear" dispatch table. (for (from i 0 511) (do (nmode-undefine-command i))) (setf nmode-prefix-dispatch-list NIL)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Help for Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de help-dispatch () % Give a little information on the routine bound to a keyboard character (or % characters, in the case of prefixed things). (nmode-set-delayed-prompt "Show function of command: ") (let* ((command (input-command)) (func (dispatch-table-lookup command)) (prompt (BldMsg "%w %w" (command-name command) (or func "Undefined"))) ) (write-prompt prompt) )) (de print-all-dispatch () % Print out the current dispatch table. (print-matching-dispatch NIL)) (fluid '(function-name-match-string)) (de function-name-matcher (f) (string-indexs (id2string f) function-name-match-string)) (de string-indexs (s pattern) % Search in the string S for the specified pattern. If we find it, we return % the position of the first matching character. Otherwise, we return NIL. (let* ((pattern-length (string-length pattern)) (limit (- (string-length s) pattern-length)) ) (for (from pos 0 limit) (do (if (pattern-in-string pattern s pos) (exit pos))) ) )) (de pattern-in-string (pattern s pos) % Return T if PATTERN occurs as substring of S, starting at POS. % No bounds checking is performed on S. (let ((i 0) (patlimit (string-upper-bound pattern))) (while (and (<= i patlimit) (= (string-fetch pattern i) (string-fetch s (+ i pos))) ) (setf i (+ i 1)) ) (> i patlimit) % T if all chars matched, NIL otherwise )) (de print-matching-dispatch (s) % Print out the current dispatch table, showing only those function % whose names contain the string S (if S is NIL, show all functions). (let (f) (when s (setf function-name-match-string (string-upcase s)) (setf f #'function-name-matcher) ) % List the routines bound to single characters: (for (from ch 0 511) (do (print-dispatch-entry ch f))) % List the routines bound to prefix characters: (for (in prefix-entry nmode-prefix-dispatch-list) (do (for (in char-entry (cdr prefix-entry)) (do (print-dispatch-entry (list (car prefix-entry) (car char-entry)) f ) )))) )) (de print-dispatch-entry (command f) % Print out the dispatch routine for a character or character sequence. % Don't print anything if F is non-nill and (F fname) returns NIL, the % command is a self inserting character, "undefined", or a lower-case % character whose upper-case equivalent has the same definition. (let ((fname (dispatch-table-lookup command))) (if (not (or (null fname) (memq fname '(insert-self-command argument-or-insert-command Ding)) (and f (null (apply f (list fname)))) (is-redundant-command? command) )) (PrintF "%w %w%n" (string-pad-right (command-name command) 22) fname) ))) (de is-redundant-command? (command) (let ((ch (if (FixP command) command (cadr command)))) (and (FixP ch) (X-LowerCaseP ch) (eq (dispatch-table-lookup command) (dispatch-table-lookup (if (FixP command) (X-Char-UpCase command) (list (car command) (X-Char-Upcase (cadr command))) )))))) (de command-name (command) % Return a string giving the name for a character or character sequence. (if (PairP command) (string-concat (prefix-name (car command)) (let ((argument (cadr command))) (cond ((FixP argument) (x-char-name argument)) (t argument) ))) (x-char-name command) )) |
Added psl-1983/3-1/nmode/doc.sl version [1b8be70c87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Doc.SL - NMODE On-line Documentation % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 15 February 1983 % Revised: 8 April 1983 % % 8-April-83 Jeff Soreff % Altered doc-filter-predicate and apply-filter method to adhere to the % "return list of self" convention (see code for apply filter method). % Declare-flavor was used to preserve efficiency of doc-filter-predicate. % 31-Mar-83 Jeff Soreff % Altered set-up-documentation to remove interaction with FRL. % A use of channelread was replaced with nmode-read-and-evaluate-file. % 14-Mar-83 Alan Snyder % Convert for changes in browser mechanism. Clear modified flag of % documentation buffer. Fixup external declarations and load statement. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects extended-char fast-strings numeric-operators)) (on fast-integers) % External variables: (fluid '(text-mode)) % Internal static variables: (fluid '(view-mode doc-obj-list doc-browser-mode doc-browser-command-list doc-browser-documentation-text doc-browser-help-text doc-filter-argument-list doc-text-file reference-text-file doc-text-buffer)) (setf doc-obj-list nil) (setf doc-text-file "SS:<PSL.NMODE-DOC>FRAMES.LPT") (setf reference-text-file "SS:<PSL.NMODE-DOC>COSTLY.SL") (setf doc-browser-help-text ["? View Edit Filter uNdo-filter Ignore Quit"]) (setf doc-browser-documentation-text ["The Documentation Browser displays documentation on NMODE." "Terminology: the current item is the item pointed at by the cursor." "The View (V) and Edit (E) commands both display the current item." "In split-screen mode, Edit selects the bottom window while View does not." "The Filter (F) command asks for a string and removes all items that" "do not match the string." "The Ignore (I) command removes the current item from the display." "The uNdo-Filter (N) command restores the items removed by the most" "recent Filter command or by the most recent series of Ignore commands." "The Quit (Q) command exits the browser." ]) (de set-up-documentation () (when (null doc-obj-list) (setf doc-text-buffer (create-unnamed-buffer text-mode)) (insert-file-into-buffer doc-text-buffer doc-text-file) (=> doc-text-buffer set-modified? NIL) (nmode-read-and-evaluate-file reference-text-file) (let ((browser (create-nmode-documentation-browser))) (=> browser set-items doc-obj-list) ) NIL )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Documentation Browser Commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf view-mode (nmode-define-mode "View" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-commands Basic-Command-List) (nmode-define-commands (list (cons (x-char Q) 'select-previous-buffer-command))) ))) (setf Doc-Browser-Mode (nmode-define-mode "Doc-Browser" '( (nmode-define-commands Doc-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf Doc-Browser-Command-List (list (cons (x-char ?) 'browser-help-command) (cons (x-char F) 'doc-filter-command) (cons (x-char E) 'browser-edit-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char V) 'browser-view-command) (cons (x-char Q) 'browser-exit-command) (cons (x-char SPACE) 'move-down-command) )) (de doc-obj-compare (obj1 obj2) (let ((indx1 (doc-browse-obj$index obj1)) (indx2 (doc-browse-obj$index obj2))) (< indx1 indx2))) (de doc-filter-command () (let ((browser (current-browser)) (doc-filter-argument-list (list (prompt-for-string "Search for what string in a command's name or references?" "")))) (=> browser filter-items #'doc-filter-predicate) )) (declare-flavor doc-browse-obj doc-obj obj-temp) (de doc-filter-predicate (doc-obj) (let* ((old-name (=> doc-obj name)) (ref-list (=> doc-obj ref-list)) (pattern (string-upcase (first doc-filter-argument-list))) (pattern-length (string-length pattern)) (name-list (cons old-name (for (in ref ref-list) (with name-list obj-temp) (collect (let ((obj-temp (eval ref))) (=> obj-temp name)) name-list) (returns name-list))))) (for (in name name-list) (with found) (do (when (let ((limit (- (string-length name) pattern-length)) (char-pos 0)) (while (<= char-pos limit) (if (pattern-matches-in-line pattern name char-pos) (exit char-pos)) (incr char-pos))) (setf found t))) (returns found)))) (undeclare-flavor doc-obj obj-temp) (de create-nmode-documentation-browser () (create-browser 'DOCUMENTATION-BROWSER "Documentation" "NMODE" doc-browser-mode (create-unnamed-buffer view-mode) ["NMODE Documentation Browser Subsystem" ""] doc-browser-documentation-text doc-browser-help-text () #'doc-obj-compare) ) (de apropos-command () (let* ((doc-filter-argument-list (list (prompt-for-string "Search for what string in a command's name or references?" ""))) (jnk (set-up-documentation)) (browser (or (find-browser 'DOCUMENTATION-BROWSER "NMODE") (create-nmode-documentation-browser) ))) (=> browser set-items doc-obj-list) (=> browser filter-items #'doc-filter-predicate) (browser-enter browser) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % The doc-browse-obj (documentation-browser-object) flavor: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor doc-browse-obj ( name type index (start-line NIL) (end-line NIL) (ref-list ()) ) () initable-instance-variables gettable-instance-variables ) (defmethod (doc-browse-obj display-text) () (string-concat (id2string type) ": " name)) (defmethod (doc-browse-obj view-buffer) (buffer) (unless buffer (setf buffer (create-unnamed-buffer view-mode))) (=> buffer reset) (if (not (and start-line end-line)) (=> buffer insert-string "Sorry, no documentation is availible on this topic.") (=> buffer insert-text (cdr (=> doc-text-buffer extract-region NIL (cons start-line 0) (cons end-line 0))))) (=> buffer move-to-buffer-start) (=> buffer set-modified? nil) buffer) (defmethod (doc-browse-obj update) () T ) (defmethod (doc-browse-obj cleanup) () NIL) (defmethod (doc-browse-obj apply-filter) (filter) (apply filter (list self))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/extended-input.sl version [8cb4cbdace].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Extended-Input.SL - 9-bit terminal input (for 7 or 8 bit terminals) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 August 1982 % Revised: 11 April 1983 % % 11-Apr-83 Alan Snyder % Change "obsolete" #\BS to #\BackSpace. % 17-Feb-83 Alan Snyder % Added PUSH-BACK-INPUT-CHARACTER function. Revise mapping so that % bit prefix characters are recognized after mapping. % 22-Dec-82 Jeffrey Soreff % Added PUSH-BACK-EXTENDED-CHARACTER function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int fast-vectors)) % Global variables: (fluid '(nmode-meta-bit-prefix-character nmode-control-bit-prefix-character nmode-control-meta-bit-prefix-character)) (setf nmode-meta-bit-prefix-character (x-char C-!\)) (setf nmode-control-bit-prefix-character (x-char C-^)) (setf nmode-control-meta-bit-prefix-character (x-char C-Z)) % Internal static variables: (fluid '(nmode-terminal-map nmode-lookahead-extended-char nmode-lookahead-char)) (setf nmode-lookahead-extended-char nil) (setf nmode-lookahead-char nil) (de nmode-initialize-extended-input () (setf nmode-terminal-map (MkVect 255)) % Most input characters map to themselves. (for (from i 0 255) (do (vector-store nmode-terminal-map i i))) % Some ASCII control character map to Extended Control characters. % Exceptions: BACKSPACE, TAB, RETURN, LINEFEED, ESCAPE (for (from i 0 31) (unless (member i '#.(list #\BackSpace #\Tab #\CR #\LF #\ESC))) (do (let ((mch (X-Set-Control (+ i 64)))) (vector-store nmode-terminal-map i mch) (vector-store nmode-terminal-map (+ i 128) (+ mch 128)) ))) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de input-extended-character () (if nmode-lookahead-extended-char (prog1 nmode-lookahead-extended-char (setf nmode-lookahead-extended-char nil)) (input-direct-extended-character))) (de push-back-extended-character (ch) (setf nmode-lookahead-extended-char ch)) (de input-direct-extended-character () % Read an extended character from the terminal. % Recognize and interpret bit-prefix characters. (let* ((ch (input-terminal-character))) (cond ((= ch nmode-meta-bit-prefix-character) (nmode-append-separated-prompt "M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-unmeta ch))) (x-set-meta ch) ) ((= ch nmode-control-bit-prefix-character) (nmode-append-separated-prompt "C-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-uncontrol ch))) (x-set-control ch) ) ((= ch nmode-control-meta-bit-prefix-character) (nmode-append-separated-prompt "C-M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-base ch))) (x-set-meta (x-set-control ch)) ) (t ch) ))) (de push-back-input-character (ch) (setf nmode-lookahead-char ch) ) (de input-terminal-character () % Read an extended character from the terminal. Perform mapping from 8-bit % to 9-bit characters. Do not interpret bit prefix characters. (if nmode-lookahead-char (prog1 nmode-lookahead-char (setf nmode-lookahead-char nil)) (vector-fetch nmode-terminal-map (input-direct-terminal-character)) )) |
Added psl-1983/3-1/nmode/fileio.sl version [787ffd7154].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FileIO.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % Revised: 31 March 1983 % % File I/O for NMODE. % % 31-Mar-83 Alan Snyder % Fix bug: Print-Buffer didn't do tabs right (because the PSL manual % incorrectly described the Repeat macro!). % 15-Mar-83 Alan Snyder % Create-buffer-unselectable -> Create-unnamed-buffer. Add % print-buffer-command. Rename write-screen-photo-command to % write-screen-command; Fix to work when there are multiple physical screens; % add a default file name. % 4-Mar-83 Alan Snyder % Added error handling for bad pathname specified by user. Added some % recovery for bad pathnames in general. Pathname-without-version renamed to % Filename-without-version. % 4-Feb-83 Alan Snyder % Added functions for deleting/undeleting files and writing a message. % Find-file-in-buffer changed incompatibly to make it more useful. Use % nmode-error to report errors. % 1-Feb-83 Alan Snyder % Added separate default string for Insert File command. % 27-Dec-82 Alan Snyder % Removed runtime LOAD statements, for portability. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects numeric-operators fast-strings pathnames)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External Variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-selectable-buffers nmode-current-buffer nmode-screen nmode-command-argument-given nmode-current-window Text-Mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal static variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(text-io-default-fn insert-file-default-fn nmode-print-device write-screen-default-fn )) (setf nmode-print-device "PRINTER:") % probably override this in system file (setf text-io-default-fn NIL) (setf insert-file-default-fn NIL) (setf write-screen-default-fn NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de visit-file-command () % Ask for and read in a file. (let ((fn (prompt-for-defaulted-filename "Visit File: " NIL))) (visit-file nmode-current-buffer fn) )) (de insert-file-command () % Ask for and read a file, inserting it into the current buffer. (setf insert-file-default-fn (prompt-for-file-name "Insert File: " insert-file-default-fn)) (insert-file-into-buffer nmode-current-buffer insert-file-default-fn) ) (de write-file-command () % Ask for filename, write out the buffer to the file. (write-buffer-to-file nmode-current-buffer (prompt-for-defaulted-filename "Write File:" NIL))) (de save-file-command () % Save current buffer on its associated file, ask for file if unknown. (cond ((not (=> nmode-current-buffer modified?)) (write-prompt "(No changes need to be written)")) (t (save-file nmode-current-buffer)))) (de save-file-version-command () % Save current buffer on its associated file, ask for file if unknown. % The file is written using the current version number. (cond ((not (=> nmode-current-buffer modified?)) (write-prompt "(No changes need to be written)")) (t (save-file-version nmode-current-buffer)))) (de find-file-command () % Ask for filename and then read it into a buffer created especially for that % file, or select already existing buffer containing the file. (find-file (prompt-for-defaulted-filename "Find file: " NIL)) ) (de write-screen-command () % Ask for filename, write out the screen to the file. (setf write-screen-default-fn (prompt-for-file-name "Write Screen to File: " write-screen-default-fn)) (write-screen write-screen-default-fn) ) (de write-region-command () % Ask for filename, write out the region to the file. (write-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Write Region to File:" text-io-default-fn)))) (de prepend-to-file-command () % Ask for filename, prepend the region to the file. (prepend-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Prepend Region to File:" text-io-default-fn)))) (de append-to-file-command () % Ask for filename, append the region to the file. (append-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Append Region to File:" text-io-default-fn)))) (de delete-file-command () (nmode-delete-file (prompt-for-defaulted-filename "Delete File:" NIL))) (de delete-and-expunge-file-command () (nmode-delete-and-expunge-file (prompt-for-defaulted-filename "Delete and Expunge File:" NIL))) (de undelete-file-command () (nmode-undelete-file (prompt-for-defaulted-filename "Undelete File:" NIL))) (de save-all-files-command () % Save all files. Ask first, unless arg given. (for (in b nmode-selectable-buffers) (do (cond ((and (=> b file-name) (=> b modified?) (or nmode-command-argument-given (nmode-y-or-n? (bldmsg "Save %w in %w (Y or N)?" (=> b name) (=> b file-name))) )) (save-file b)) )))) (de print-buffer-command () % Print the current buffer. Translates tabs and control characters. (setf nmode-print-device (prompt-for-string "Print buffer to device:" nmode-print-device)) (print-buffer nmode-print-device) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-defaulted-filename (prompt b) % The default name is the name associated with the specified buffer (without % Version number). Will throw 'ABORT if a bad file name is given. % If B is NIL, the "current" buffer is used. (let ((fn (=> (or b nmode-current-buffer) file-name))) (prompt-for-file-name prompt (and fn (filename-without-version fn)) ))) (de prompt-for-file-name (prompt default-name) % Default-Name may be NIL. % Will throw 'ABORT if a bad file name is given. (let* ((fn (prompt-for-string prompt default-name)) (pn (maybe-pathname fn)) ) (when (not pn) (nmode-error (bldmsg "Invalid pathname: %w" fn)) (throw 'ABORT) ) (if default-name (setf pn (attempt-to-merge-pathname-defaults pn default-name (pathname-type default-name) NIL))) (namestring pn) )) (de attempt-to-merge-pathname-defaults (pn dn type version) (let ((result (errset (merge-pathname-defaults pn dn type version) NIL))) (cond ((listp result) (car result)) (t (nmode-error EMSG*) (throw 'ABORT))))) (de read-file-into-buffer (b file-name) (=> b set-file-name file-name) (buffer-set-mode b (pathname-default-mode file-name)) (let ((s (attempt-to-open-input file-name))) (if s (read-stream-into-buffer b s) % else (=> b reset) (=> b set-modified? NIL) (write-prompt "(New File)") ))) (de read-stream-into-buffer (b s) (let ((fn (=> s file-name))) (write-prompt (bldmsg "Reading file: %w" fn)) (=> b read-from-stream s) (=> s close) (write-prompt (bldmsg "File read: %w (%d lines)" fn (=> b visible-size))) )) (de insert-file-into-buffer (buf pn) (let ((b (create-unnamed-buffer Text-Mode))) (read-file-into-buffer b pn) (insert-buffer-into-buffer b buf) )) (de insert-buffer-into-buffer (source destination) (let ((old-pos (=> destination position))) (=> destination insert-text (=> source contents)) (=> destination set-mark-from-point) (=> destination set-position old-pos) )) (de save-file (b) % Save the specified buffer on its associated file, ask for file if unknown. (let ((fn (=> b file-name))) (cond ((not (=> b modified?)) nil) (fn (write-buffer-to-file b (filename-without-version fn))) (T (write-file b))))) (de save-file-version (b) % Save the specified buffer on its associated file, ask for file if unknown. % The file is written to the current version number. (let ((fn (=> b file-name))) (cond ((not (=> b modified?)) nil) (fn (write-buffer-to-file b fn)) (T (write-file b))))) (de write-file (b) % Ask for filename, write out the buffer to the file. (let ((msg (bldmsg "Write Buffer %w to File: " (=> b name)))) (write-buffer-to-file b (prompt-for-defaulted-filename msg b)))) (de write-buffer-to-file (b pn) % Write the specified buffer to a file. (write-prompt "") (let* ((file-name (namestring pn)) (s (attempt-to-open-output file-name)) ) (if s (let ((fn (=> s file-name))) (write-prompt (bldmsg "Writing file: %w" fn)) (=> b write-to-stream s) (=> s close) (write-prompt (bldmsg "File written: %w (%d lines)" fn (=> b visible-size))) (=> b set-modified? NIL) (=> b set-file-name fn) ) (nmode-error (bldmsg "Unable to write file: %w" file-name)) ))) (de write-text-to-file (text pn) (let ((b (create-unnamed-buffer Text-Mode))) (=> b insert-text text) (write-buffer-to-file b pn) )) (de prepend-text-to-file (text pn) (let ((b (create-unnamed-buffer Text-Mode))) (read-file-into-buffer b pn) (=> b move-to-buffer-start) (=> b insert-text text) (write-buffer-to-file b pn) )) (de append-text-to-file (text pn) (let ((b (create-unnamed-buffer Text-Mode))) (read-file-into-buffer b pn) (=> b move-to-buffer-end) (=> b insert-text text) (write-buffer-to-file b pn) )) (de visit-file (b file-name) % If the specified file exists, read it into the specified buffer. % Otherwise, clear the buffer for a new file. % If the buffer contains precious data, offer to save it first. (if (=> b modified?) (let* ((fn (=> b file-name)) (msg (if fn (bldmsg "file %w" fn) (bldmsg "buffer %w" (=> b name)))) ) (if (nmode-yes-or-no? (bldmsg "Write out changes in %w?" msg)) (save-file b) ))) (let ((fn (actualize-file-name file-name))) (if fn (read-file-into-buffer b fn) (nmode-error (bldmsg "Unable to read or create file: %w" file-name)) ))) (de find-file (file-name) % Select a buffer containing the specified file. If the file exists in a % buffer already, then that buffer is selected. Otherwise, a new buffer is % created and the file read into it (if the file exists). (find-file-in-window nmode-current-window file-name)) (de find-file-in-window (w file-name) % Attach a buffer to the specified window that contains the specified file. % If the file exists in a buffer already, then that buffer is used. % Otherwise, a new buffer is created and the file read into it (if the file % exists). (let ((b (find-file-in-buffer file-name nil))) (if b (window-select-buffer w b) % otherwise (nmode-error (bldmsg "Unable to read or create file: %w" file-name)) ))) (de find-file-in-buffer (file-name existing-file-only?) % Return a buffer containing the specified file. The buffer is not % selected. If the file exists in a buffer already, then that buffer is % returned. Otherwise, if the file exists and can be read, a new buffer is % created and the file read into it. Otherwise, if EXISTING-FILE-ONLY? is % NIL and the file is potentially creatable, a new buffer is created and % returned. Otherwise, NIL is returned. (setf file-name (actualize-file-name file-name)) (if (and file-name (not (string-empty? file-name))) (or (find-file-in-existing-buffer file-name) % look for existing buffer (let ((s (attempt-to-open-input file-name))) (when (or s (not existing-file-only?)) % create a buffer (let ((b (buffer-create-default (buffer-make-unique-name (filename-to-buffername file-name))))) (=> b set-file-name file-name) (buffer-set-mode b (pathname-default-mode file-name)) (if s (read-stream-into-buffer b s) (write-prompt "(New File)") ) b )))))) (de find-file-in-existing-buffer (file-name) % Look for the specified file in an existing buffer. If found, return % that buffer, otherwise return NIL. The filename should be complete. (let ((pn (maybe-pathname file-name))) (when pn (for (in b nmode-selectable-buffers) (do (if (pathnames-match pn (=> b file-name)) (exit b))) (returns nil)) ))) (de nmode-delete-file (fn) (let ((del-fn (file-delete fn))) (if del-fn (write-prompt (bldmsg "File deleted: %w" del-fn)) (nmode-error (bldmsg "Unable to delete file: %w" fn)) ) del-fn )) (de nmode-delete-and-expunge-file (fn) (let ((del-fn (file-delete-and-expunge fn))) (if del-fn (write-prompt (bldmsg "File deleted and expunged: %w" del-fn)) (nmode-error (bldmsg "Unable to delete file: %w" fn)) ) del-fn )) (de nmode-undelete-file (fn) (let ((del-fn (file-undelete fn))) (if del-fn (write-prompt (bldmsg "File undeleted: %w" del-fn)) (nmode-error (bldmsg "Unable to undelete file: %w" fn)) ) del-fn )) (de write-screen (file-name) % Write the current screen to file. (let ((s (attempt-to-open-output file-name))) (if s (let ((screen (=> (=> nmode-current-window screen) screen))) (nmode-refresh) (=> screen write-to-stream s) (=> s close) (write-prompt (bldmsg "File written: %w" (=> s file-name))) ) (nmode-error (bldmsg "Unable to write file: %w" file-name)) ))) (de print-buffer (print-device) % Print the current buffer. PSL output is used because it is probably more % general (less specialized) and will handle character output devices. This % routine is likely to be redefined in the system file. (let ((result (errset (open print-device 'OUTPUT)))) (if (not (pairp result)) (nmode-error (bldmsg "Unable to write to %w" print-device)) % otherwise (let* ((chn (car result)) (upper-bound (- (current-buffer-size) 1)) ) (for (from i 0 upper-bound) (do (print-buffer-line chn (current-buffer-fetch i)) (channelterpri chn) )) (close chn) )))) (de print-buffer-line (chn line) % Used by print-buffer. (for (from i 0 (string-upper-bound line)) (with (col 0)) (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to an appropriate number of spaces. (repeat (channelwritechar chn #\space) (setf col (+ col 1)) % until (= (& col 7) 0) )) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (channelwritechar chn #/^) (channelwritechar chn (^ ch 8#100)) (setf col (+ col 2)) ) (t (channelwritechar chn ch) (setf col (+ col 1)) )))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output file-name)) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) (de filename-to-buffername (fn) % Convert from a pathname to the "default" corresponding buffer name. (let ((pn (maybe-pathname fn))) (if pn (string-upcase (file-namestring (pathname-without-version pn))) (string-upcase fn) ))) (de pathnames-match (pn1 pn2) (setf pn1 (pathname pn1)) (setf pn2 (pathname pn2)) (and (equal (pathname-device pn1) (pathname-device pn2)) (equal (pathname-directory pn1) (pathname-directory pn2)) (equal (pathname-name pn1) (pathname-name pn2)) (equal (pathname-type pn1) (pathname-type pn2)) (or (null (pathname-version pn1)) (null (pathname-version pn2)) (equal (pathname-version pn1) (pathname-version pn2))) )) (de filename-without-version (fn) (let ((pn (maybe-pathname fn))) (if pn (namestring (pathname-without-version pn)) fn ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/hp9836-dev.sl version [403feefabf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % HP9836-DEV.SL - HP9836 NMODE Development Support (not normally loaded) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 January 1983 % Revised: 4 April 1983 % % 4-Apr-83 Alan Snyder % Changes relating to keeping NMODE source and binary files in separate % directories. % 16-Mar-83 Alan Snyder % New function: window-ftp. % 14-Mar-83 Alan Snyder % Changed nmode-compile and window-compile to take any number of arguments. % New function: nmode-ftp. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings extended-char)) (bothtimes (load strings common)) (fluid '(nmode-source-prefix nmode-binary-prefix window-source-prefix window-binary-prefix )) (setf prinlevel 3) (setf prinlength 10) (dn nmode-compile (s-list) (for (in s s-list) (do (nmode-compile-1 s)) )) (de nmode-compile-1 (s) (setf s (nmode-fixup-name s)) (let ((object-name (string-concat nmode-binary-prefix s)) (source-name (string-concat nmode-source-prefix (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (dn window-compile (s-list) (for (in s s-list) (do (window-compile-1 s)) )) (de window-compile-1 (s) (setf s (nmode-fixup-name s)) (let ((object-name (string-concat window-binary-prefix s)) (source-name (string-concat window-source-prefix (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de pu-compile (s) (let ((object-name (string-concat "pl:" s)) (source-name (string-concat "pu:" (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de phpu-compile (s) (let ((object-name (string-concat "pl:" s)) (source-name (string-concat "phpu:" (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de nmode-compile-all () (for (in s nmode-file-list) (do (nmode-compile s)) )) (de window-compile-all () (for (in s window-file-list) (do (window-compile s)) )) (dn nmode-ftp (s-list) (let* ((sout (open-output "FTP-NMODE")) (dummy (make-string 1 0)) ) (=> sout putl "XTERM") (string-store dummy 0 128) (=> sout puts dummy) (for (in s s-list) (do (nmode-ftp-1 s sout)) ) (=> sout putl "") (=> sout close) )) (de nmode-ftp-1 (s sout) (=> sout puts "S") % Send command (=> sout putl (string-concat nmode-source-prefix (nmode-fixup-name s) ".sl")) (=> sout putl (string-concat "n:" s ".sl")) ) (dn window-ftp (s-list) (let* ((sout (open-output "FTP-WINDOW")) (dummy (make-string 1 0)) ) (=> sout putl "XTERM") (string-store dummy 0 128) (=> sout puts dummy) (for (in s s-list) (do (window-ftp-1 s sout)) ) (=> sout putl "") (=> sout close) )) (de window-ftp-1 (s sout) (=> sout puts "S") % Send command (=> sout putl (string-concat window-source-prefix (window-fixup-name s) ".sl")) (=> sout putl (string-concat "n:" s ".sl")) ) |
Added psl-1983/3-1/nmode/incr.sl version [a05271a7af].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Incremental-Search.SL - Incremental Search Routines for NMODE % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 21 December 1982 % Revised: 17 February 1982 % % 17-Feb-83 Alan Snyder % Fixed to allow pushback of bit-prefix characters. % 7-Feb-83 Alan Snyder % Revised to refresh all windows when writing message (write-message no % longer does this). % 18 January 1982 Jeffrey Soreff % This was revised to preserve the message existing before a search. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-strings fast-vectors fast-int extended-char)) (BothTimes (load objects)) % Global Variables (fluid '(text-last-searched-for)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Actual Command Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de incremental-search-command () (incr-search 1)) (de reverse-search-command () (incr-search -1)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Support Objects and Methods % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor search-state ((state-list nil) (halt nil) % Halt means that the search should halt on this iteration. direct % This is the direction of the search: +1 for forward, -1 for back. (repeat-flag nil) % When repeating a search for the same text as before. (found-flag t) % This flag indicates that the current text was found. (place (buffer-get-position)) % This is set to the start of text found. (apparent-place (buffer-get-position)) % Apparent-place is put where the user should see the cursor: after the % text for forward searching, and before it for backward searching. (text [""])) % The text being searched for. () (gettable-instance-variables halt) (initable-instance-variables direct) ) (defmethod (search-state push) () % This method stores the information needed when one deletes a % character from the search string. It affects only state-list. (setf state-list (cons (vector direct repeat-flag found-flag place apparent-place) state-list))) (defmethod (search-state pop) () % This method restores the last state of the search. The text is % recomputed on the fly, while most of the other elements of the % state are explicitly retrieved from the list. "Halt" is not % retrieved, since the search should never pass a state where halt % is true. In addition to altering local variables, % text-last-searched-for is set equal to the truncated text, and % point is moved to its last location. (unless repeat-flag (setf text (trim-text text))) (when (cdr state-list) (setf state-list (cdr state-list)) (setf text-last-searched-for text)) % see next line. % Don't destroy information from previous search if one is in the % first state of a search and a deletion is attempted. (let ((state (car state-list))) (setf direct (vector-fetch state 0)) (setf repeat-flag (vector-fetch state 1)) (setf found-flag (vector-fetch state 2)) (setf place (vector-fetch state 3)) (setf apparent-place (vector-fetch state 4))) (buffer-set-position apparent-place)) (defmethod (search-state do-search) (next-command) % This method sets up searches. It analyses the current command to % determine if a search for old text is being repeated, or if a new % character is being added on to the existing text. It updates the % text being searched for, the record of the last text searched for, % the direction of the search, and it sets up point before searches. (let ((char-add-list nil)) (cond ((setf repeat-flag (=> next-command repeat-flag)) (setf direct (=> next-command direct)) (when (and (= direct (vector-fetch (car state-list) 0)) % The direction hasn't changed since the last search. (equal text [""])) (setf repeat-flag nil) % This is not a search for the text last searched for. (setf char-add-list (text2list text-last-searched-for)))) (t (setf char-add-list (list (=> next-command char))))) (if repeat-flag (=> self actual-search) % else (for (in current-char char-add-list) (do (setf text (new-text text current-char)) (buffer-set-position place) (=> self actual-search))))) (unless (equal text [""]) (setf text-last-searched-for text))) (defmethod (search-state actual-search) () % This method does the actual searching for text. It first checks to % see if the search could possibly succeed, which it couldn't if the % search just extends a previously unsuccessful search in the old % direction. This method also stores the location of the start of % the new text and the location at which the user should see the % cursor after the search. (when (or found-flag (~= direct (vector-fetch (car state-list) 0))) % One should search if the last text was found or the direction has changed. (let ((backed-up (when (and repeat-flag (< direct 0)) (move-backward-character)))) % Avoid jamming at the current string in repeated backward search. (setf found-flag (buffer-text-search? text direct)) (when (not found-flag) (ding)) (when (and backed-up (not found-flag)) (move-forward-character)))) (when found-flag (setf place (buffer-get-position)) (if (> direct 0) (move-over-text text)) (setf apparent-place (buffer-get-position))) % end of text if forward (buffer-set-position apparent-place) (=> self push)) (defmethod (search-state super-pop) () % This method pops off all unsuccessful searches or, if the last % search was successful, undoes all the searching. (cond (found-flag (setf state-list (lastpair state-list)) % first state (setf text [""]) (setf halt t) (=> self pop)) (t (while (not found-flag) (=> self pop)) (ding)))) (defmethod (search-state init) () (=> self prompt) (=> self push)) (defmethod (search-state prompt) () (update-message text found-flag direct)) (defflavor parsed-char (char halt pop-flag repeat-flag direct) % Char is the next character returned after processing. Halt is a % flag indicating if the searching should halt unconditionally. % Pop-flag indicates whether a delete is being done. Repeat-flag % indicates whether one of the commands (^R and ^S) which trigger % searching for the same text as before (but possibly in a new % direction) has occured. Direct indicates the direction that the % search should take. () gettable-instance-variables) (defmethod (parsed-char parse-next-character) () % This function inputs and parses new characters or commands. (setf char (input-terminal-character)) (setf halt nil) (setf pop-flag nil) (setf repeat-flag nil) (let ((up-char (X-Char-Upcase char))) (cond ((= up-char (x-char C-Q)) (setf char (input-direct-terminal-character))) ((or (= up-char (x-char Rubout))(= up-char (x-char Backspace))) (setf repeat-flag nil) (setf pop-flag t)) ((= up-char (x-char C-G)) (setf repeat-flag t) (setf pop-flag t)) ((or (= up-char (x-char C-S))(= up-char (x-char C-R))) (setf repeat-flag t) (if (= up-char (x-char C-S)) (setf direct +1) (setf direct -1))) ((= up-char (x-char Escape)) (setf halt t)) ((or (= up-char (x-char Return))(not (X-Control? up-char)))) % The last line detects normal characters. (t % normal control character (push-back-input-character char) (setf halt t))))) (de incr-search (direct) % The main function for the search (let* ((old-msg (write-message "")) (search-at (make-instance 'search-state 'direct direct)) (next-command (make-instance 'parsed-char))) (while (continue search-at next-command) % gets and parses next char % The main loop for the search (if (=> next-command pop-flag) (if (=> next-command repeat-flag) (=> search-at super-pop) (=> search-at pop)) (=> search-at do-search next-command)) (=> search-at prompt)) (write-message old-msg))) % This restores the message after the search. (de continue (search-state parsed-char) % This function parses the next input character, if that is called % for, and determines if the search should continue or be halted. It % returns a boolean value which is true if the search should % continue. (unless (=> search-state halt) (=> parsed-char parse-next-character) (not (=> parsed-char halt)))) (de update-message (text found direct) % This function displays the last line of the search string, whether % it was found, and in what direction the search proceeded. (let* ((line-count (vector-upper-bound text)) (last-line (vector-fetch text line-count))) (write-message (string-concat (if found "" "Failing ") (if (> direct 0) "" "Reverse ") "I-search: " last-line)) (nmode-refresh) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Start of text handling functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-text (text) % This function moves point to the end of a chunk of text, assuming % that point is started at the beginning of the text. (let ((line-count (vector-upper-bound text))) (set-line-pos (+ (current-line-pos) line-count)) (if (> line-count 0)(move-to-start-of-line)) (move-over-characters (string-length (vector-fetch text line-count))))) (de trim-text (old-text) % This is a pure function, without side effects. It trims one % character or empty line return off the old text. It will not, % however, delete the last null string from a text vector. In that % case it dings and returns the old text. (let* ((line-count (vector-upper-bound old-text)) (short-text (sub old-text 0 (- line-count 1))) (last-line (vector-fetch old-text line-count)) (last-count (string-length last-line))) (if (> last-count 0) (concat short-text (vector (sub last-line 0 (- last-count 2)))) (if (> line-count 0) short-text (Ding) old-text)))) (de new-text (old-text char) % This is a pure function, without side effects. It returns an % updated version of the text vector. It updates the text vector by % adding a new character or a new line. (let* ((line-count (vector-upper-bound old-text)) (short-text (sub old-text 0 (- line-count 1))) (last-line (vector-fetch old-text line-count))) (if (= char (x-char Return)) (concat old-text [""]) (concat short-text (vector (string-concat last-line (string char))))))) (de text2list (text) % This function converts text into a list of characters, with cursor % returns where the breaks between strings used to be. (append (string2list (vector-fetch text 0)) (for (from indx 1 (vector-upper-bound text) 1) (join (cons (x-char return) (string2list (vector-fetch text indx))))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Start of text searching functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-text-search? (text direct) % This function searches in the buffer for the specified text. The % direct is +1 for forward searching and -1 for backward % searching. This function leaves point at the start of the text, % if it is found, and at the old point if the text is not found. % This function returns a boolean, true if it found the text. (let ((current-place (buffer-get-position)) (match-rest nil)) (while (and (not match-rest) (buffer-search (vector-fetch text 0) direct)) (setf match-rest (match-rest-of-text? text)) (unless match-rest (if (> direct 0)(move-forward)(move-backward)))) (unless match-rest (buffer-set-position current-place)) match-rest)) (de match-rest-of-text? (text) % This function determines if two conditions are satified: First, % that all lines in text except the last fill out their respective % lines. Second, that all lines except the first match their % respective lines. This function assumes that point is initially % at the start of a string which matches the first string in text. % It also assumes that text is in upper case. This function returns % a boolean value. It does not move point. (let ((temp nil) % This avoids a compiler bug. (indx 0) (match-rest t) (line (current-line-pos)) (char-pos (current-char-pos))) (while (and match-rest (< indx (vector-upper-bound text))) (setf temp (+ char-pos (string-length (vector-fetch text indx)))) (setf match-rest (and match-rest % Check filling out of lines. (= temp (string-length (current-buffer-fetch (+ line indx)))))) (setf char-pos 0) % Only the first string is set back on its line. (incr indx) (setf match-rest (and match-rest % Check matching of lines. (pattern-matches-in-line (string-upcase (vector-fetch text indx)) (current-buffer-fetch (+ line indx)) 0)))) (and match-rest (= indx (vector-upper-bound text))))) |
Added psl-1983/3-1/nmode/indent-commands.sl version [0fef30baae].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Indent-commands.SL - NMODE indenting commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 18 February 1983 % % 18-Feb-83 Alan Snyder % Removed use of "obsolete" #\ names. % 11-Nov-82 Alan Snyder % DELETE-INDENTATION-COMMAND (M-^) now obeys command argument. % INDENT-CURRENT-LINE now avoids modifying buffer if indentation unchanged. % Added INDENT-REGION stuff. % General clean-up. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings extended-char common)) (load stringx) (fluid '(nmode-command-argument nmode-command-argument-given nmode-command-number-given )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Indenting Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de indent-new-line-command () (let ((func (dispatch-table-lookup (x-char CR)))) (if func (apply func NIL))) (setf nmode-command-argument 1) (setf nmode-command-argument-given NIL) (setf nmode-command-number-given NIL) (let ((func (dispatch-table-lookup (x-char TAB)))) (if func (apply func NIL)))) (de tab-to-tab-stop-command () (for (from i 1 nmode-command-argument) (do (insert-character #\TAB)) )) (de delete-horizontal-space-command () (while (and (not (at-line-end?)) (char-blank? (next-character))) (delete-next-character) ) (while (and (not (at-line-start?)) (char-blank? (previous-character))) (delete-previous-character) ) ) (de delete-blank-lines-command () (cond ((current-line-blank?) % We are on a blank line. % Replace multiple blank lines with one. % First, search backwards for the first blank line % and save its index. (while (not (current-line-is-first?)) (move-to-previous-line) (cond ((not (current-line-blank?)) (move-to-next-line) (exit)) )) (delete-following-blank-lines) ) (t % We are on a non-blank line. Delete any blank lines % that follow this one. (delete-following-blank-lines) ) )) (de back-to-indentation-command () (move-to-start-of-line) (while (char-blank? (next-character)) (move-forward) )) (de delete-indentation-command () (if nmode-command-argument-given (move-to-next-line)) (current-line-strip-indent) (move-to-start-of-line) (when (not (current-line-is-first?)) (delete-previous-character) (if (and (not (at-line-start?)) (not (= (previous-character) #/( )) (not (= (next-character) #/) )) ) (insert-character #\SPACE) ))) (de split-line-command () (while (char-blank? (next-character)) (move-forward)) (if (> nmode-command-argument 0) (let ((pos (current-display-column))) (for (from i 1 nmode-command-argument) (do (insert-eol))) (indent-current-line pos) ))) (de indent-region-command () (if nmode-command-argument-given (indent-region #'indent-to-argument) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Indenting Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de char-blank? (ch) (or (= ch #\SPACE) (= ch #\TAB))) (de current-line-indent () % Return the indentation of the current line, in terms of spaces. (let ((line (current-line))) (for* (from i 0 (string-upper-bound line)) (with ch) (while (char-blank? (setf ch (string-fetch line i)))) (sum (if (= ch #\TAB) 8 1)) ))) (de current-line-strip-indent () % Strip all leading blanks and tabs from the current line. (let ((line (current-line))) (for* (from i 0 (string-upper-bound line)) (while (char-blank? (string-fetch line i))) (finally (when (> i 0) (set-char-pos (- (current-char-pos) i)) (current-line-replace (string-rest line i)) )) ))) (de strip-previous-blanks () % Strip all blanks and tabs before point. (while (and (not (at-buffer-start?)) (char-blank? (previous-character))) (delete-previous-character) )) (de indent-current-line (n) % Adjust the current line to have the specified indentation. (when (and (~= n (current-line-indent)) (>= n 0)) (current-line-strip-indent) (let ((n-spaces (remainder n 8)) (n-tabs (quotient n 8)) (line (current-line)) (cp (current-char-pos)) ) (for (from i 1 n-spaces) (do (setf line (string-concat #.(string #\SPACE) line)) (setf cp (+ 1 cp)))) (for (from i 1 n-tabs) (do (setf line (string-concat #.(string #\TAB) line)) (setf cp (+ 1 cp)))) (current-line-replace line) (set-char-pos cp) ))) (de delete-following-blank-lines () % Delete any blank lines that immediately follow the current one. (if (not (current-line-is-last?)) (let ((old-pos (buffer-get-position)) first-pos ) % Advance past the current line until the next nonblank line. (move-to-next-line) (setf first-pos (buffer-get-position)) (while (and (not (at-buffer-end?)) (current-line-blank?)) (move-to-next-line)) (extract-region T first-pos (buffer-get-position)) (buffer-set-position old-pos) ))) (de indent-to-argument () % Indent the current line to the position specified by nmode-command-argument. (indent-current-line nmode-command-argument) ) (de indent-region (indenting-function) % Indent the lines whose first characters are between point and mark. % Attempt to adjust point and mark appropriately should their lines % be re-indented. The function INDENTING-FUNCTION is called to indent % the current line. (let* ((point (buffer-get-position)) (mark (current-mark)) (bp1 point) (bp2 mark) ) (if (< 0 (buffer-position-compare bp1 bp2)) (psetf bp1 mark bp2 point)) (let ((first-line (buffer-position-line bp1)) (last-line (buffer-position-line bp2)) ) (if (> (buffer-position-column bp1) 0) (setf first-line (+ first-line 1))) (for (from i first-line last-line) (do (set-line-pos i) (cond ((= i (buffer-position-line point)) (set-char-pos (buffer-position-column point))) ((= i (buffer-position-line mark)) (set-char-pos (buffer-position-column mark))) ) (apply indenting-function ()) (cond ((= i (buffer-position-line point)) (setf point (buffer-position-create i (current-char-pos)))) ((= i (buffer-position-line mark)) (setf mark (buffer-position-create i (current-char-pos)))) )))) (previous-mark) % pop off old mark (set-mark mark) % push (possibly adjusted) mark (buffer-set-position point) )) |
Added psl-1983/3-1/nmode/kill-commands.sl version [4b1878a1de].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Kill-Commands.SL - NMODE Kill and Delete commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 16 November 1982 % % 16-Nov-82 Alan Snyder % Modified C-Y and M-Y to obey comamnd argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-vectors fast-int)) (load gsort) (fluid '(nmode-current-buffer nmode-command-argument nmode-command-argument-given nmode-command-number-given nmode-previous-command-killed nmode-command-killed )) % Internal static variables: (fluid '(nmode-kill-ring)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-initialize-kill-ring () (setf nmode-kill-ring (ring-buffer-create 16)) (setf nmode-command-killed NIL) ) (de insert-kill-buffer () % Insert the specified "kill buffer" into the buffer at the current location. (cond ((<= nmode-command-argument 0) (Ding)) (nmode-command-number-given (insert-from-kill-ring (+ (- nmode-command-argument) 1) NIL)) (nmode-command-argument-given (insert-from-kill-ring 0 T)) (t (insert-from-kill-ring 0 NIL)) )) (de insert-from-kill-ring (index flip-positions) (insert-text-safely (=> nmode-kill-ring fetch index) flip-positions) ) (de insert-text-safely (text flip-positions) (cond (text (=> nmode-current-buffer set-mark-from-point) (insert-text text) (when flip-positions (exchange-point-and-mark)) ) (t (Ding)) )) (de safe-to-unkill () % Return T if the current region contains the same text as the current % kill buffer. (let ((killed-text (ring-buffer-top nmode-kill-ring)) (region (extract-text NIL (buffer-get-position) (current-mark))) ) (and killed-text (text-equal killed-text region)) )) (de unkill-previous () % Delete (without saving away) the current region, and then unkill (yank) the % specified entry in the kill ring. "Ding" if the current region does not % contain the same text as the current entry in the kill ring. (cond ((not (safe-to-unkill)) (Ding)) ((= nmode-command-argument 0) (extract-region T (buffer-get-position) (current-mark))) (t (extract-region T (buffer-get-position) (current-mark)) (=> nmode-kill-ring rotate (- nmode-command-argument)) (insert-from-kill-ring 0 NIL) ) )) (de update-kill-buffer (kill-info) % Update the "kill buffer", either appending/prepending to the current % buffer, or "pushing" the kill ring, as appropriate. kill-info is a pair, % the car of which is +1 if the text was "forward killed", and -1 if % "backwards killed". The cdr is the actual text (a vector of strings). (let ((killed-text (cdr kill-info)) (dir (car kill-info)) ) (if (not nmode-previous-command-killed) % If previous command wasn't a kill, then "push" the new text. (ring-buffer-push nmode-kill-ring killed-text) % Otherwise, append or prepend the text, as appropriate. (let ((text (ring-buffer-top nmode-kill-ring))) % Swap the two pieces of text if deletion was "backwards". (if (< dir 0) (psetf text killed-text killed-text text)) % Replace text with the concatenation of the two. (ring-buffer-pop nmode-kill-ring) (ring-buffer-push nmode-kill-ring (text-append text killed-text)) )))) (de text-append (t1 t2) % Append two text-vectors. % The last line of T1 is concatenated with the first line of T2. (let ((text (MkVect (+ (vector-upper-bound t1) (vector-upper-bound t2)))) (ti 0) % index into TEXT ) (for (from i 0 (- (vector-upper-bound t1) 1)) (do (vector-store text ti (vector-fetch t1 i)) (setf ti (+ ti 1)) )) (vector-store text ti (string-concat (vector-fetch t1 (vector-upper-bound t1)) (vector-fetch t2 0))) (setf ti (+ ti 1)) (for (from i 1 (vector-upper-bound t2)) (do (vector-store text ti (vector-fetch t2 i)) (setf ti (+ ti 1)) )) text)) (de text-equal (t1 t2) % Compare two text vectors for equality. (let ((limit (vector-upper-bound t1))) (and (= limit (vector-upper-bound t2)) (for (from i 0 limit) (always (string= (vector-fetch t1 i) (vector-fetch t2 i))) )))) (de kill-region () % Kill (and save in kill buffer) the region between point and mark. (update-kill-buffer (extract-region T (buffer-get-position) (current-mark))) (setf nmode-command-killed T) ) (de copy-region () (update-kill-buffer (extract-region NIL (buffer-get-position) (current-mark))) ) (de append-to-buffer-command () (let* ((text (cdr (extract-region NIL (buffer-get-position) (current-mark)))) (b (prompt-for-buffer "Append Region to Buffer: " NIL)) ) (=> b insert-text text) )) (de prompt-for-register-name (prompt) % Prompt for the name of a "Register", which must be a letter % or a digit. Return the corresponding Lisp Symbol. Return NIL % if an invalid name is given. (nmode-set-delayed-prompt prompt) (let ((ch (input-base-character))) (cond ((AlphaNumericP ch) (intern (string-concat "nmode-register-" (string ch)))) (t (Ding) NIL)))) (de put-register-command () (let ((register (prompt-for-register-name (if nmode-command-argument-given "Withdraw Region to Register: " "Copy Region to Register: ")))) (cond (register (set register (cdr (extract-region nmode-command-argument-given (buffer-get-position) (current-mark)))) )))) (de get-register-command () (let ((register (prompt-for-register-name "Insert from Register: ")) (old-pos (buffer-get-position)) ) (cond (register (cond ((BoundP register) (insert-text (ValueCell register)) (set-mark-from-point) (buffer-set-position old-pos) (if nmode-command-argument-given (exchange-point-and-mark)) ) (t (Ding)) ))))) (de append-next-kill-command () (if (ring-buffer-top nmode-kill-ring) % If there is a kill buffer... (setf nmode-command-killed T) )) (de kill-line () (let ((old-pos (buffer-get-position))) (if nmode-command-argument-given (cond ((> nmode-command-argument 0) % Kill through that many line terminators (for (from i 1 nmode-command-argument) (do (move-to-next-line))) ) ((= nmode-command-argument 0) % Kill preceding text on this line (move-to-start-of-line) ) (t % Kill through that many previous line starts % This line counts only if we are not at the beginning of it. (if (not (at-line-start?)) (progn (move-to-start-of-line) (setf nmode-command-argument (+ nmode-command-argument 1)) )) (for (from i 1 (- nmode-command-argument)) (do (move-to-previous-line))) )) % else (no argument given) (while (char-blank? (next-character)) (move-forward)) (if (at-line-end?) (move-to-next-line) (move-to-end-of-line) ) ) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) (setf nmode-command-killed T) )) (de kill-forward-word-command () (delete-words nmode-command-argument) (setf nmode-command-killed T) ) (de kill-backward-word-command () (delete-words (- nmode-command-argument)) (setf nmode-command-killed T) ) (de kill-forward-form-command () (delete-forms nmode-command-argument) (setf nmode-command-killed T) ) (de kill-backward-form-command () (delete-forms (- nmode-command-argument)) (setf nmode-command-killed T) ) (de delete-backward-character-command () (cond (nmode-command-argument-given (delete-characters (- nmode-command-argument)) (setf nmode-command-killed T)) (t (if (at-buffer-start?) (Ding) (delete-previous-character) )))) (de delete-forward-character-command () (cond (nmode-command-argument-given (delete-characters nmode-command-argument) (setf nmode-command-killed T)) (t (if (at-buffer-end?) (Ding) (delete-next-character) )))) (de delete-backward-hacking-tabs-command () (cond (nmode-command-argument-given (delete-characters-hacking-tabs (- nmode-command-argument)) (setf nmode-command-killed T)) (t (if (at-buffer-start?) (Ding) (move-backward-character-hacking-tabs) (delete-next-character) )))) (de transpose-words () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-words nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-words (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 word1 word2) (cond ((= n 0) (setf bp1 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp2 (buffer-get-position)) (buffer-set-position (current-mark)) (setf bp3 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp4 (buffer-get-position)) (exchange-regions bp3 bp4 bp1 bp2) (move-backward-word) ) (t (if (not (move-backward-word)) (return NIL)) (setf bp1 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp2 (buffer-get-position)) (if (not (move-over-words (if (< n 0) (- n 1) n))) (return NIL)) (setf bp4 (buffer-get-position)) (if (not (move-over-words (- 0 n))) (return NIL)) (setf bp3 (buffer-get-position)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-lines () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-lines nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-lines (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 line1 line2 current marked last) (setf current (current-line-pos)) (setf last (- (current-buffer-size) 1)) % The last line doesn't count, because it is unterminated. (setf marked (buffer-position-line (current-mark))) (cond ((= n 0) (if (or (>= current last) (>= marked last)) (return NIL)) (setf bp1 (buffer-position-create current 0)) (setf bp2 (buffer-position-create (+ current 1) 0)) (setf bp3 (buffer-position-create marked 0)) (setf bp4 (buffer-position-create (+ marked 1) 0)) (exchange-regions bp3 bp4 bp1 bp2) (move-to-previous-line) ) (t % Dragged line is the previous one. (if (= current 0) (return NIL)) (setf bp1 (buffer-position-create (- current 1) 0)) (setf bp2 (buffer-position-create current 0)) (setf marked (- (+ current n) 1)) (if (or (< marked 0) (>= marked last)) (return NIL)) (setf bp3 (buffer-position-create marked 0)) (setf bp4 (buffer-position-create (+ marked 1) 0)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-forms () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-forms nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-forms (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 form1 form2) (cond ((= n 0) (setf bp1 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp2 (buffer-get-position)) (buffer-set-position (current-mark)) (setf bp3 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp4 (buffer-get-position)) (exchange-regions bp3 bp4 bp1 bp2) (move-backward-form) ) (t (if (not (move-backward-form)) (return NIL)) (setf bp1 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp2 (buffer-get-position)) (if (not (move-over-forms (if (< n 0) (- n 1) n))) (return NIL)) (setf bp4 (buffer-get-position)) (if (not (move-over-forms (- 0 n))) (return NIL)) (setf bp3 (buffer-get-position)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-regions () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-regions nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-regions (n) % Returns non-NIL if successful. % Transpose regions defined by cursor and three most recent marks. % EMACS resets all of the marks; we just reset the cursor to the % end of the higher region. (prog (bp1 bp2 bp3 bp4 bp-list) (setf bp1 (buffer-get-position)) (setf bp2 (current-mark)) (setf bp3 (previous-mark)) (setf bp4 (previous-mark)) (previous-mark) (setf bp-list (list bp1 bp2 bp3 bp4)) (gsort bp-list (function buffer-position-lessp)) (exchange-regions (first bp-list) (second bp-list) (third bp-list) (fourth bp-list)) (buffer-set-position (fourth bp-list)) (return T) )) % Support functions: (de delete-characters (n) (let ((old-pos (buffer-get-position))) (move-over-characters n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-characters-hacking-tabs (n) % Note: EMACS doesn't try to hack tabs when deleting forward. % We do, but it's a crock. What should really happen is that all % consecutive tabs are converted to spaces. (cond ((< n 0) % Deleting backwards is tricky because the conversion of tabs to % spaces may change the numeric value of the original "position". % Our solution is to first move backwards the proper number of % characters (converting tabs to spaces), and then move back over them. (let ((count (- n))) (setf n 0) (while (and (> count 0) (move-backward-character-hacking-tabs)) (setf count (- count 1)) (setf n (- n 1)) ) (move-over-characters (- n)) ))) (let ((old-pos (buffer-get-position))) (move-over-characters-hacking-tabs n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-words (n) (let ((old-pos (buffer-get-position))) (move-over-words n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-forms (n) (let ((old-pos (buffer-get-position))) (move-over-forms n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de exchange-regions (bp1 bp2 bp3 bp4) % The specified positions define two regions: R1=<BP1,BP2> and % R2=<BP3,BP4>. These regions should not overlap, unless they % are identical. The contents of the two regions will be exchanged. % The cursor will be moved to the right of the region R1 (in its new % position). (let ((dir (buffer-position-compare bp1 bp3)) (r1 (cdr (extract-region NIL bp1 bp2))) (r2 (cdr (extract-region NIL bp3 bp4))) ) (cond ((< dir 0) % R1 is before R2 (extract-region T bp3 bp4) (insert-text r1) (extract-region T bp1 bp2) (insert-text r2) (buffer-set-position bp4) ) ((> dir 0) % R2 is before R1 (extract-region T bp1 bp2) (insert-text r2) (extract-region T bp3 bp4) (insert-text r1) )) )) |
Added psl-1983/3-1/nmode/lisp-commands.sl version [7730680804].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Commands.SL - Miscellaneous NMODE Lisp-related commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % Revised: 18 February 1983 % % 18-Feb-83 Alan Snyder % Rename down-list to down-list-command; extend to obey the command argument. % Rename insert-parens to make-parens-command; extend to obey the command % argument and to insert a space if needed (like EMACS). Rename % move-over-paren to move-over-paren-command; revise to follow EMACS more % closely. Remove use of "obsolete" #\ names. % 12-Nov-82 Alan Snyder % This file is the result of a complete rewrite of the Lisp stuff. The only % things that remain in this file are those things that don't fit in elsewhere. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-command-argument nmode-command-argument-given nmode-current-command )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de insert-closing-bracket () % Insert a closing bracket, then display the matching opening bracket. (if (not (fixp nmode-current-command)) (Ding) % otherwise (for (from i 1 nmode-command-argument) (do (insert-character nmode-current-command))) (display-matching-opener) )) (de down-list-command () % Move inside the next or previous contained list. If the command argument % is positive, move forward past the next open bracket without an % intervening close bracket. If the command argument is negative, move % backward to the next previous close bracket without an intervening open % bracket. If the specified bracket cannot be found, Ding, but do not move. % Note: this command differs from the EMACS Down-List command in that it % always stays within the current list. The EMACS command moves forward % as far as needed to find a list at the next lower level. (if (> nmode-command-argument 0) (for (from i 1 nmode-command-argument) (do (when (not (move-forward-down-list)) (Ding) (exit)))) (for (from i 1 (- nmode-command-argument)) (do (when (not (move-backward-down-list)) (Ding) (exit)))) )) (de make-parens-command () % Insert a space if it looks like we need one. Insert an open paren. Skip % forward over the requested number of forms, if any. Insert a close paren. % Move back to the open paren. (when (not (at-line-start?)) (let ((ch (previous-character))) (when (and (not (char-blank? ch)) (not (= ch #/( ))) (insert-character #\Space) ))) (insert-character #/( ) (let ((old-pos (buffer-get-position))) (when nmode-command-argument-given (if (or (<= nmode-command-argument 0) (not (move-over-forms nmode-command-argument))) (Ding))) (insert-character #/) ) (buffer-set-position old-pos) )) (de move-over-paren-command () % Move forward past N closing brackets at any level. Delete any indentation % before the first closing bracket found. Insert an end of line after the % last closing bracket found and indent the new line. Aside: This % definition follows EMACS. I don't understand the motivation for this way % of interpreting the command argument. (if (<= nmode-command-argument 0) (Ding) (for (from i 1 nmode-command-argument) (do (when (not (forward-scan-for-right-paren 10000)) (when (> i 1) (insert-eol) (lisp-indent-current-line) ) (Ding) (exit) ) (when (= i 1) (move-backward-item) (strip-previous-blanks) (move-forward-item) ) (when (= i nmode-command-argument) (insert-eol) (lisp-indent-current-line) ) )))) (de insert-comment-command () (move-to-end-of-line) (insert-string "% ") ) |
Added psl-1983/3-1/nmode/lisp-indenting.sl version [35eba00629].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Indenting.SL - NMODE Lisp Indenting commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 25 August 1982 % Revised: 12 November 1982 % % 25-Feb-83 Alan Snyder % Move-down-list renamed to Move-forward-down-list. % 12-Nov-82 Alan Snyder % Improved indenting using new structure-movement primitives. % Changed multi-line indenting commands to clear any blank lines. % Added LISP-INDENT-REGION-COMMAND. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-vectors)) (fluid '(nmode-command-argument nmode-command-argument-given)) (de lisp-tab-command () (cond (nmode-command-argument-given (let ((n nmode-command-argument)) (cond ((< n 0) (let ((last-line (- (current-line-pos) 1))) (set-line-pos (+ (current-line-pos) n)) (let ((first-line (current-line-pos))) (while (<= (current-line-pos) last-line) (lisp-indent-or-clear-current-line) (move-to-next-line) ) (current-buffer-goto first-line 0) ))) ((> n 0) (while (> n 0) (lisp-indent-or-clear-current-line) (move-to-next-line) (if (at-buffer-end?) (exit)) (setf n (- n 1)) )) (t (lisp-indent-current-line) (move-to-start-of-line) )))) (t (lisp-indent-current-line)))) (de lisp-indent-current-line () (indent-current-line (lisp-current-line-indent))) (de lisp-indent-or-clear-current-line () (indent-current-line (if (current-line-blank?) 0 (lisp-current-line-indent)))) (de lisp-indent-sexpr () (if (not (move-forward-down-list)) % Find next open bracket (Ding) % None found % otherwise (move-backward-item) % Move back to the open bracket (let ((old-line (current-line-pos)) (old-point (current-char-pos)) ) (if (not (move-forward-form)) % Find end of form (Ding) % No matching close bracket found % otherwise (for (from i (+ old-line 1) (current-line-pos)) (do (set-line-pos i) (lisp-indent-or-clear-current-line) )) (current-buffer-goto old-line old-point) )))) (de lisp-indent-region-command () (if nmode-command-argument-given (indent-region #'indent-to-argument) (indent-region #'lisp-indent-or-clear-current-line) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Basic Indenting Primitive % % This function determines what indentation the current line should receive. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-current-line-indent () % Return the desired indentation for the current line. % Point is unchanged. (let ((old-pos (buffer-get-position))) (unwind-protect (unsafe-lisp-current-line-indent) (buffer-set-position old-pos) ))) (de unsafe-lisp-current-line-indent () % Return the desired indentation for the current line. % Point may change. (move-to-start-of-line) (let ((item (move-backward-form)) (number-of-forms 0) (leftmost-form-type NIL) ) % If there are multiple forms at the same level of nesting % on the same line, we want to find the left-most one. (while (or (eq item 'ATOM) (eq item 'STRUCTURE)) (setf number-of-forms (+ number-of-forms 1)) (setf leftmost-form-type item) (let ((next-item (move-backward-form-within-line))) (if (not next-item) (exit)) % We have the first item on the line. (setf item next-item) )) (selectq item ((ATOM STRUCTURE) (current-display-column)) % Line up with form. (OPENER (lisp-indent-under-paren leftmost-form-type number-of-forms)) (t 0) % There is no previous form. ))) (de lisp-indent-under-paren (leftmost-form-type number-of-forms) % This function is called to determine the indentation for a line % that immediately follows (i.e., there is no intervening line % containing a form) the line containing the open paren that % begins the nesting level for the line being indented. This % function is called with the current position being at the open % paren. NUMBER-OF-FORMS specifies the number of forms that % follow the open paren on its line. LEFTMOST-FORM-TYPE specifies % the type of the first such form (either ATOM, STRUCTURE, or NIL). (skip-prefixes) % Skip over any "prefix characters" (like ' in Lisp). (let ((paren-column (current-display-column)) the-atom pos1 pos2 atom-text atom-string second-column ) (if (not (eq leftmost-form-type 'ATOM)) (+ paren-column 1) % Otherwise (move-forward-item) % Move past the paren. (setf pos1 (buffer-get-position)) (move-forward-form) % Move past the first form. (setf pos2 (buffer-get-position)) (setf atom-text (extract-text NIL pos1 pos2)) (setf atom-string (string-upcase (vector-fetch atom-text 0))) (if (internp atom-string) (setf the-atom (intern atom-string))) (when (> number-of-forms 1) (move-forward-form) (move-backward-form) (setf second-column (current-display-column)) ) (lisp-indent-under-atom the-atom paren-column second-column number-of-forms) ))) (de lisp-indent-under-atom (the-id paren-column second-column number-of-forms) % This function is called to determine the indentation for a line % that immediately follows (i.e., there is no intervening line % containing a form) the line containing the open paren that % begins the nesting level for the line being indented. % The open paren is followed on the same line by at least one form % that is not a structure. % NUMBER-OF-FORMS specifies the number of forms that % follow the open paren on its line. If there are two or more forms, % then SECOND-COLUMN is the display column of the second form; % otherwise, SECOND-COLUMN is NIL. If the first % form is recognized as being an % interned ID, then THE-ID is that ID; otherwise, THE-ID is NIL. % PAREN-COLUMN is the display column of the open paren. (or (if the-id (id-specific-indent the-id paren-column second-column)) second-column (+ paren-column 1) )) (put 'prog 'indentation 2) (put 'lambda 'indentation 2) (put 'lambdaq 'indentation 2) (put 'while 'indentation 2) (put 'de 'indentation 2) (put 'defun 'indentation 2) (put 'defmacro 'indentation 2) (put 'df 'indentation 2) (put 'dm 'indentation 2) (put 'dn 'indentation 2) (put 'ds 'indentation 2) (put 'let 'indentation 2) (put 'let* 'indentation 2) (put 'if 'indentation 2) (put 'when 'indentation 2) (put 'unless 'indentation 2) (put 'defmethod 'indentation 2) (put 'defflavor 'indentation 2) (put 'selectq 'indentation 2) (put 'catch 'indentation 2) (put 'catch-all 'indentation 2) (put 'setf 'indentation 2) (put 'setq 'indentation 2) (de id-specific-indent (id paren-column second-column) % The default indentation for a pattern like this: % .... (foo bar ... % bletch ... % is to line up bletch with bar. This pattern applies when FOO % is an atom (not a structure) and there is at least one % form (e.g. BAR) following it on the same line. This function % is used to specify exceptions to this rule. It is invoked % only when FOO is an INTERNed ID, since the exceptions are % defined by putting a property on the ID. (let ((indent (get id 'indentation))) (if indent (+ paren-column indent)) )) |
Added psl-1983/3-1/nmode/lisp-interface.sl version [73d2a585d2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LISP-Interface.SL - NMODE Lisp Text Execution Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 28 February 1983 % % Adapted from Will Galway's EMODE % % 28-Feb-83 Alan Snyder % Change nmode-main to initially call leave-raw-mode. This is to make NMODE % refresh the display automatically when it is restarted. % 14-Feb-83 Alan Snyder % Added statement to flush output buffer cache. % 2-Feb-83 Alan Snyder % Added Execute-Defun-Command. Change to supply the free EOL at the end of % the input buffer whenever the buffer-modified flag is set, instead of only % when currently at the end of the buffer. % 25-Jan-83 Alan Snyder % Check terminal type after resuming. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(nmode-current-buffer nmode-output-buffer nmode-terminal nmode-initialized *NMODE-RUNNING *GC LispBanner* *RAWIO *nmode-init-running *nmode-init-has-run nmode-terminal-input-buffer nmode-default-init-file-name nmode-auto-start nmode-first-start )) (setf *NMODE-RUNNING NIL) (setf *nmode-init-running NIL) (setf *nmode-init-has-run NIL) (setf nmode-default-init-file-name "PSL:NMODE.INIT") (setf nmode-auto-start NIL) (setf nmode-first-start T) (fluid '( nmode-buffer-channel % Channel used for NMODE I/O. nmode-output-start-position % Where most recent "output" started in buffer. nmode-output-end-position % Where most recent "output" ended in buffer. OldStdIn OldStdOut OldErrOut )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de yank-last-output-command () % Insert "last output" typed in the OUTPUT buffer. Output is demarked by % NMODE-OUTPUT-START-POSITION and NMODE-OUTPUT-END-POSITION. (if (not nmode-output-start-position) (Ding) % Otherwise (let ((text (=> nmode-output-buffer extract-region NIL nmode-output-start-position (or nmode-output-end-position (buffer-position-create (=> nmode-output-buffer size) 0) ) ))) (=> nmode-current-buffer insert-text (cdr text)) ))) (de execute-form-command () % Execute starting at the beginning of the current line. (set-mark-from-point) % in case the user wants to come back (move-to-start-of-line) (execute-from-buffer) ) (de execute-defun-command () % Execute starting at the beginning of the current defun (if the current % position is within a defun) or from the current position (otherwise). (set-mark-from-point) % in case the user wants to come back (move-to-start-of-current-defun) (execute-from-buffer) ) (de make-buffer-terminated () % If the current buffer ends with an "unterminated" line, add an EOL to % terminate it. (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (when (not (current-line-empty?)) (insert-eol)) (buffer-set-position old-pos) )) (de execute-from-buffer () % Causes NMODE to return to the procedure that called it (via % nmode-channel-editor) with input redirected to come from the (now) current % buffer. We arrange for output to go to the end of the output buffer. (if (=> nmode-current-buffer modified?) (make-buffer-terminated)) (buffer-channel-set-input-buffer nmode-buffer-channel nmode-current-buffer) % Output will go to end of the output buffer. Supply a free EOL if the last % line is unterminated. Record the current end-of-buffer for later use by % Lisp-Y. (let ((old-pos (=> nmode-output-buffer position))) (=> nmode-output-buffer move-to-buffer-end) (if (not (=> nmode-output-buffer current-line-empty?)) (=> nmode-output-buffer insert-eol)) (setf nmode-output-start-position (=> nmode-output-buffer position)) (=> nmode-output-buffer set-position old-pos) ) % Set things up to read from and write to NMODE buffers. (nmode-select-buffer-channel) (exit-nmode-reader) ) (de nmode-exit-to-superior () (if (not *NMODE-RUNNING) (original-quit) % else (leave-raw-mode) % Turn echoing back on. Next refresh is FULL. (original-quit) (enter-raw-mode) % Turn echoing off. (nmode-set-terminal) % Ensure proper terminal driver is loaded. )) % Redefine QUIT so that it restores the terminal to echoing before exiting. (when (FUnboundP 'original!-quit) (CopyD 'original!-quit 'quit) (CopyD 'quit 'nmode-exit-to-superior) ) (de emode () (nmode)) % for user convenience (de nmode () % Rebind the PSL input channel to the NMODE buffer channel and return. This % will cause the next READ to invoke Nmode-Channel-Editor and start running % NMODE. Use the function "exit-nmode" to switch back to original channels. (nmode-initialize) % does nothing if already initialized (when (neq STDIN* nmode-buffer-channel) (setf OldStdIn STDIN*) (setf OldStdOut STDOUT*) (setf OldErrOut ErrOut*) ) (nmode-select-buffer-input-channel) ) (de nmode-run-init-file () (setf *nmode-init-has-run T) (let ((fn (namestring (init-file-pathname "NMODE")))) (cond ((FileP fn) (nmode-execute-init-file fn)) ((FileP (setf fn nmode-default-init-file-name)) (nmode-execute-init-file fn)) ))) (de nmode-execute-init-file (fn) (let ((*nmode-init-running T)) (nmode-read-and-evaluate-file fn) )) (de nmode-read-and-evaluate-file (fn) (let ((chn (open fn 'INPUT)) exp ) (while (not (eq (setf exp (ChannelRead chn)) $Eof$)) (eval exp) ) (close chn) ) ) (de exit-nmode () % Leave NMODE, return to normal listen loop. (nmode-select-old-channels) (=> nmode-terminal move-cursor (=> nmode-terminal maxrow) 0) (leave-raw-mode) (setf *NMODE-RUNNING NIL) (setf *GC T) (exit-nmode-reader) % Set flag to cause NMODE to exit. ) % The following function is not currently used. (de nmode-invoke-lisp-listener () % Invoke a normal listen loop. (let* ((*NMODE-RUNNING NIL) (OldIN* IN*) (OldOUT* OUT*) (ERROUT* 1) (StdIn* 0) (StdOut* 1) (old-raw-mode (=> nmode-terminal raw-mode)) ) (leave-raw-mode) (RDS 0) (WRS 1) (unwind-protect (TopLoop 'Read 'Print 'Eval "Lisp" "Return to NMODE with ^Z") (RDS OldIN*) (WRS OldOUT*) (if old-raw-mode (enter-raw-mode)) ))) % (de emode () (throw '$read$ $eof$)) % use with above function % (de nmode () (throw '$read$ $eof$)) % use with above function (de nmode-select-old-channels () % Select channels that were in effect when "Lisp Interface" was started up. % (But don't turn echoing on.) NOTE that the "old channels" are normally % selected while NMODE is actually running (this is somewhat counter % intuitive). This is so that any error messages created by bugs in NMODE % will not be printed into NMODE buffers. (If they were, it might break % things recursively!) (setf STDIN* OldStdIn) (setf STDOUT* OldStdOut) (setf ErrOut* OldErrOut) (RDS STDIN*) % Select the channels. (WRS STDOUT*) ) (de nmode-select-buffer-channel () % Select channels that read from and write to NMODE buffers. (nmode-select-buffer-input-channel) (setf STDOUT* nmode-buffer-channel) (setf ErrOut* nmode-buffer-channel) (WRS STDOUT*) ) (de nmode-select-buffer-input-channel () % Select channel that reads from NMODE buffer. "NMODE-Channel-Editor" is % called when read routines invoke the "editor routine" for the newly selected % channel. (if (null nmode-buffer-channel) (setf nmode-buffer-channel (OpenBufferChannel NIL nmode-output-buffer 'nmode-channel-editor))) (setf STDIN* nmode-buffer-channel) (RDS STDIN*) ) (de nmode-channel-editor (chn) % This procedure is called every time that input is requested from an NMODE % buffer. It starts up NMODE (if not already running) and resumes NMODE % execution. When the user has decided on what input to give to the channel % (by performing Lisp-E), the NMODE-reader will return with I/O bound to the % "buffer channel". The reader will also return if the user performs Lisp-L, % in which case I/O will remain bound to the "standard" channels. % Select "old" channels, so if an error occurs we don't get a bad recursive % situation where printing into a buffer causes more trouble! (nmode-select-old-channels) (cond ((not *NMODE-RUNNING) (setf *NMODE-RUNNING T) (setf *GC NIL) (if (not *nmode-init-has-run) (nmode-run-init-file) ) ) (t (buffer-channel-flush nmode-buffer-channel) (setf nmode-output-end-position (=> nmode-output-buffer position)) % compensate for moving to line start on next Lisp-E: (if (not (at-line-start?)) (move-to-next-line)) ) ) (enter-raw-mode) (nmode-select-major-window) % just in case (NMODE-reader NIL) % NIL => don't exit when a command aborts ) (de nmode-main () (setf CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (setf CurrentScanTable* LispScanTable*) (when (not toploopread*) (setf toploopread* 'read) (setf toploopprint* 'print) (setf toploopeval* 'eval) (setf toploopname* "NMODE Lisp") ) (nmode-initialize) % does nothing if already initialized (nmode-set-terminal) % ensure proper terminal driver is loaded % Note: RESET may cause echoing to be turned on without clearing *RawIO. (when *RawIO (setf *RawIO NIL) (EchoOff) ) (leave-raw-mode) (when nmode-first-start (setf nmode-first-start NIL) % never again (cond (nmode-auto-start (setf *NMODE-RUNNING T) % see below (let ((was-modified? (=> nmode-output-buffer modified?))) (=> nmode-output-buffer insert-line LispBanner*) (if (not was-modified?) (=> nmode-output-buffer set-modified? NIL) ))) (t (printf "%w%n" LispBanner*) )) ) (while T (setf nmode-terminal-input-buffer NIL) % flush execution from buffers (cond (*NMODE-RUNNING (setf *NMODE-RUNNING NIL) % force full start-up (nmode) % cause next READ to start up NMODE ) (t (RDS 0) (WRS 1) )) (nmode-top-loop) )) (copyd 'main 'nmode-main) (de nmode-top-loop () (TopLoop toploopread* toploopprint* toploopeval* toploopname* "") (Printf "End of File read!") ) |
Added psl-1983/3-1/nmode/lisp-parser.sl version [d413e919c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Parser.SL - NMODE's Lisp parser % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % Revised: 18 February 1983 % % See the document NMODE-PARSING.TXT for a description of the parsing strategy. % % 18-Feb-1983 Alan Snyder % Removed use of "obsolete" #\ names. % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings fast-vectors nmode-attributes)) % Imported variables: (fluid '(nmode-defun-predicate nmode-defun-scanner nmode-current-parser )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de establish-lisp-parser () (setf nmode-defun-predicate #'lisp-current-line-is-defun?) (setf nmode-defun-scanner #'lisp-scan-past-defun) (setf nmode-current-parser #'lisp-parse-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % This file defines the basic primitive used by NMODE to % analyze Lisp source code. It currently recognizes: % % ( and ) as list brackets % [ and ] as vector brackets % comments beginning with % % #/x as character constants % " ... " as string literals % !x as a quoted character % ' ` #' #. , ,@ as prefixes to ( and [ (de lisp-parse-line (str vec) % Fill Vec[i] to be the attributes of Str[i]. (let* ((previous-attributes -1) attributes ch is-first (high (string-upper-bound str)) (in-comment NIL) (in-string NIL) (last-was-sharp NIL) (last-was-sharp-slash NIL) (last-was-sharp-quote NIL) (last-was-sharp-dot NIL) (last-was-quoter NIL) (last-was-comma NIL) (last-was-comma-atsign NIL) (last-prefix-ending-index NIL) (last-prefix-length NIL) ) (for (from i 0 high) (do (setf ch (string-fetch str i)) % Determine the type attributes of the current character and update % the parsing state for the next character. (cond (in-comment (setf attributes (attributes COMMENT))) (in-string (setf attributes (attributes ATOM)) (setf in-string (not (= ch #/"))) ) (last-was-sharp-slash (setf attributes (attributes ATOM)) (setf last-was-sharp-slash NIL) ) (last-was-quoter (setf attributes (attributes ATOM)) (setf last-was-quoter NIL) ) (t (setf attributes (lisp-character-attributes ch)) (setf in-comment (= ch #/%)) (setf in-string (= ch #/")) (setf last-was-sharp-slash (and last-was-sharp (= ch #//))) (setf last-was-sharp-quote (and last-was-sharp (= ch #/'))) (setf last-was-sharp-dot (and last-was-sharp (= ch #/.))) (setf last-was-sharp (= ch #/#)) (setf last-was-quoter (= ch #/!)) (setf last-was-comma-atsign (and last-was-comma (= ch #/@))) (setf last-was-comma (= ch #/,)) (let ((prefix-length (cond (last-was-sharp-quote 2) (last-was-sharp-dot 2) ((= ch #/') 1) ((= ch #/`) 1) (last-was-comma 1) (last-was-comma-atsign 1) % is 1 because comma is a prefix (t 0) ))) (when (> prefix-length 0) % We just passed a prefix. % Does it merge with the previous prefix? (if (and last-prefix-ending-index (= last-prefix-ending-index (- i prefix-length)) ) (setf last-prefix-length (+ last-prefix-length prefix-length)) % Otherwise (setf last-prefix-length prefix-length) ) (setf last-prefix-ending-index i) )) )) % Determine the position attributes: % LISP is simple: brackets are single characters (except for % prefixes, which are handled below), atoms are maximal % contiguous strings of atomic-characters. (setf is-first (or (= attributes (attributes OPENER)) (= attributes (attributes CLOSER)) (~= attributes previous-attributes))) (setf previous-attributes attributes) (cond % First we test for an open bracket immediately preceded % by one or more prefixes. ((and (= attributes (attributes OPENER)) last-prefix-ending-index (= last-prefix-ending-index (- i 1)) ) (let ((prefix-start (- i last-prefix-length))) (vector-store vec prefix-start (attributes FIRST PREFIX OPENER)) (lp-set-last vec (- prefix-start 1)) (for (from j (+ prefix-start 1) (- i 1)) (do (vector-store vec j (attributes MIDDLE PREFIX OPENER)))) )) (is-first (setf attributes (| attributes (attributes FIRST))) (lp-set-last vec (- i 1)) ) (t (setf attributes (| attributes (attributes MIDDLE))) )) (vector-store vec i attributes) )) (lp-set-last vec high) )) (de lisp-character-attributes (ch) (selectq ch (NIL (attributes)) ((#/( #/[) (attributes OPENER)) ((#/) #/]) (attributes CLOSER)) ((#\SPACE #\TAB #\LF #\CR) (attributes BLANKS)) (#/% (attributes COMMENT)) (t (attributes ATOM)) )) (de lp-set-last (vec i) (if (>= i 0) (vector-store vec i (& (| (attributes LAST) (vector-fetch vec i)) (~ (attributes MIDDLE)))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Lisp Defun Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-current-line-is-defun? () (and (not (current-line-empty?)) (= (current-line-fetch 0) #/() )) (de lisp-scan-past-defun () % This function should be called with point at the start of a defun. % It will scan past the end of the defun (not to the beginning of the % next line, however). If the end of the defun is not found, it returns % NIL and leaves point unchanged. (move-forward-form) ) |
Added psl-1983/3-1/nmode/m-x.sl version [8b4757015f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % M-X.SL - NMODE Extended Command Support % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 September 1982 % Revised: 29 December 1982 % % 29-Dec-82 Alan Snyder % Revise PROMPT-FOR-EXTENDED-COMMAND to use new prompted input. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings extended-char)) (fluid '(nmode-input-buffer)) % Internal variables: (fluid '(prompt-for-extended-command-command-list current-extended-command-list )) (setf prompt-for-extended-command-command-list (list (cons (x-char SPACE) 'complete-input-command-name) (cons (x-char CR) 'complete-and-terminate-input-command-name) (cons (x-char LF) 'complete-and-terminate-input-command-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-extended-command (prompt) % Ask the user for the name of an extended command. Return the full command % name from the dispatch table (so that EQ can be used to compare). (setf current-extended-command-list (lookup-prefix-character (x-char M-X))) (let* ((input-name (prompt-for-string-special prompt nil prompt-for-extended-command-command-list)) (matching-names (extended-command-names-that-match input-name)) ) (first matching-names) )) % Internal functions: (de complete-input-command-name () % Extend the string in the input buffer by at most one word to match % the existing extended command names. Ring the bell if the string % is not extended. (let ((original-length (string-length (nmode-get-input-string)))) (complete-input-extended-command-name NIL) (if (= original-length (string-length (nmode-get-input-string))) (Ding) ))) (de complete-and-terminate-input-command-name () % Extend the string in the input buffer as far as possible to match the % existing extended command names. If the resulting string uniquely % identifies a single command name, refresh and terminate input. Otherwise, % if the string was not extended, ring the bell. (let* ((original-length (string-length (nmode-get-input-string))) (name (complete-input-extended-command-name T)) ) (if name (progn (nmode-refresh) (nmode-terminate-input)) (if (= original-length (string-length (nmode-get-input-string))) (Ding) )))) (de complete-input-extended-command-name (many-ok) % Extend the string in the input buffer BY WORDS. If MANY-OK is non-nil, then % extend by as many words as possible; otherwise, by only one word. If the % extended name matches exactly one command name, return that command name. % Otherwise, return NIL. (let* ((name (nmode-get-input-string)) (names (extended-command-names-that-match name)) ) (cond ((string-equal name "E") (nmode-replace-input-string "Edit ") NIL ) ((string-equal name "L") (nmode-replace-input-string "List ") NIL ) ((string-equal name "K") (nmode-replace-input-string "Kill ") NIL ) ((string-equal name "V") (nmode-replace-input-string "View ") NIL ) ((string-equal name "W") (nmode-replace-input-string "What ") NIL ) ((null names) % The name matches no command. NIL ) ((null (cdr names)) % The name matches exactly one command. (nmode-replace-input-string (extend-name-by-words name names many-ok)) (car names) ) (t % The name matches more than one command. (nmode-replace-input-string (extend-name-by-words name names many-ok)) NIL )) )) (de extend-name-by-words (name names many-ok) % NAME is the current contents of the input buffer. Extend it "by words" as % long as it matches all of the specified NAMES. NAMES must be a list % containing one or more strings. If MANY-OK is non-NIL, then extend it by as % many words as possible. Otherwise, extend it by at most one word. % Extending by words means that you do not append a new partial word, although % you may partially complete a word already started. Return the extended % string. (let* ((match-prefix (strings-largest-common-prefix names)) (partial-word (not (or (string-empty? name) (= (string-fetch name (string-upper-bound name)) #\space) ))) (bound (string-length name)) ) % Try to increase the "bound": (for (from i bound (string-upper-bound match-prefix)) (do (when (= (string-fetch match-prefix i) #\space) (setf bound (+ i 1)) % this far is OK (setf partial-word NIL) % further words will extend only in full (if (not many-ok) (exit)) )) (finally (if (or partial-word (null (cdr names))) (setf bound (string-length match-prefix)) ))) (substring match-prefix 0 bound) )) (de extended-command-names-that-match (name) (for (in pair (cdr current-extended-command-list)) (when (name-matches-prefix name (car pair))) (collect (car pair)) )) (de name-matches-prefix (test-name name) (let ((test-len (string-length test-name)) (name-len (string-length name)) ) (and (>= name-len test-len) (string-equal (substring name 0 test-len) test-name) ))) |
Added psl-1983/3-1/nmode/m-xcmd.sl version [722864dffb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % M-XCMD.SL - Miscellaneous Extended Commands % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 8 March 1983 % % 8-March-83 Jeffrey Soreff % Revert File revised to try and preserve point. % 17-Feb-83 Alan Snyder % Revise M-X Set Visited Filename to actualize the new file name (i.e., % convert it to the true name of the file). Revise M-X Rename Buffer to % convert buffer name to upper case and to check for use of an existing % buffer name. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-int)) (fluid '(nmode-current-buffer)) (de delete-matching-lines-command () (delete-possibly-matching-lines nil)) (de delete-non-matching-lines-command () (delete-possibly-matching-lines t)) (de delete-possibly-matching-lines (retain-if-match) % This function prompts for a string which it searches for in all % lines including and after the current one. The search is % insensitive to case. If retain-if-match is true then all lines % with the string will be retained and all lines lacking it will be % deleted, otherwise all lines with the string will be deleted. % Point is left at the start of the line that it was originally on. % This function does not return a useful value. (move-to-start-of-line) (let ((modified-flag (=> nmode-current-buffer modified?)) (starting-line (current-line-pos)) (next-unfilled-line (current-line-pos)) (match-string (string-upcase (prompt-for-string "Comparison String: " "")))) (for (from test-line starting-line (- (current-buffer-size) 1) 1) (do (when (if retain-if-match % This sets the sign of the selections. (forward-search-on-line test-line 0 match-string) (not (forward-search-on-line test-line 0 match-string))) (current-buffer-store next-unfilled-line (current-buffer-fetch test-line)) (incr next-unfilled-line)))) (if (= next-unfilled-line (current-buffer-size)) % No lines were tossed. (=> nmode-current-buffer set-modified? modified-flag) % Else (extract-region t (buffer-position-create next-unfilled-line 0) (progn (move-to-buffer-end) (buffer-get-position)))) (set-line-pos starting-line))) (de count-occurrences-command () % This function counts the number of instances of a string after the % current buffer position. The counting is insensitive to case. % The user is prompted for the string. If the user supplies an % empty string, they are told that it can't be counted. This avoids % an infinite loop. The count obtained is displayed in the prompt % line. This function does not return a useful value. (let ((count 0) (initial-place (buffer-get-position)) (match-string (string-upcase (prompt-for-string "Count Occurrences: " "")))) (if (equal match-string "") (write-prompt "One can't count instances of the empty string.") (while (forward-search match-string) (incr count) (move-forward)) (buffer-set-position initial-place) (write-prompt (bldmsg "%d occurrences" count))))) (de set-key-command () % This binds a user-selected function to a command. The user is % prompted for the function name and the key sequence of the % command. This function then tests to see if the user's function % exists, then asks for confirmation just before doing the binding. % This function does not return a useful value. (let ((function (intern (string-upcase (prompt-for-string "Function Name: " ""))))) (if (funboundp function) (write-prompt (bldmsg "No function %w was found." function)) (let* ((junk (write-message (bldmsg "Put %p on key:" function))) (command (input-command))) (when (nmode-y-or-n? (bldmsg "Load %w with %w" (command-name command) function)) (set-text-command command function)))))) (de set-visited-filename-command () % This command allows a user to alter the filename associated with the % current buffer. Prompt-for-defaulted-filename is used to set default % characteristics. This function does not return a useful value. (let* ((new-name (prompt-for-defaulted-filename "Set Visited Filename: " NIL))) (=> nmode-current-buffer set-file-name (or (actualize-file-name new-name) new-name) ))) (de rename-buffer-command () % This function allows the user to rename the current buffer if it is not a % system buffer like main or output. It prompts the user for a new buffer % name. If the user inputs an empty string, the buffer name is set to a % converted version of the filename associated with the buffer. Buffer % names are converted to upper case. An error is reported if the user % chooses the name of another existing buffer. This function does not % return a useful value. (if (not (buffer-killable? nmode-current-buffer)) % tests for main and output (nmode-error (bldmsg "Buffer %w cannot be renamed." (=> nmode-current-buffer name))) (let* ((old-name (=> nmode-current-buffer name)) (new-name (string-upcase (prompt-for-string "Rename Buffer: " (let ((filename (=> nmode-current-buffer file-name))) % Default (if filename (filename-to-buffername filename) % Else, if there is no filename (=> nmode-current-buffer name))))))) (when (not (string= new-name old-name)) (if (buffer-exists? new-name) (nmode-error (bldmsg "Name %w already in use." new-name)) (=> nmode-current-buffer set-name new-name) ))))) (de kill-some-buffers-command () % This functions lists the killable buffers one by one, letting the % user kill, retain, or examine each one as it is named. This % function does not return a useful value. (let ((buffer-list (nmode-user-buffers))) (while buffer-list (let ((buffer-to-die (car buffer-list))) (setf buffer-list (cdr buffer-list)) (when (and (buffer-killable? buffer-to-die) (let ((name (=> buffer-to-die name)) (mod-warn (if (=> buffer-to-die modified?) "HAS BEEN EDITED" "is unmodified"))) (recursive-edit-y-or-n buffer-to-die (bldmsg "Buffer %w %w. Kill it? Type Y or N or ^R to edit" name mod-warn) (bldmsg "Type Y to kill or N to save buffer %w" name)))) (buffer-kill-and-detach buffer-to-die)))))) (de insert-date-command () % This inserts the current date into the text, after point, and % moves point past it. It does not return a useful value. (insert-string (current-date-time))) (de revert-file-command () % This function allows the user to replace the current buffer's % contents with the contents of the file associated with the current % buffer, if there is one. It asks for confirmation before actually % performing the replacement. It tries to put point close to the % old position. This function does not return a useful value. (let ((fn (=> nmode-current-buffer file-name)) (bn (=> nmode-current-buffer name)) (current-place (buffer-get-position))) (when (and (if fn T (write-prompt "No file to read old copy from") NIL) (nmode-y-or-n? (BldMsg "Want to replace buffer %w with %w from disk?" bn fn))) (read-file-into-buffer nmode-current-buffer fn) (buffer-set-position current-place)))) |
Added psl-1983/3-1/nmode/mode-defs.sl version [d9c3c8d2fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MODE-DEFS.SL - NMODE Command Table and Mode Definitions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 15 March 1983 % % 15-Mar-83 Alan Snyder % Add M-X List Browsers, M-X Print Buffer, C-X C-P. Define modes at load % time. Rename write-screen-photo-command to write-screen-command; change to % M-X Write Screen (instead of C-X P). % 18-Feb-83 Alan Snyder % Rename down-list and insert-parens. Add M-) command. % 9-Feb-83 Alan Snyder % Add Esc-_ (Help), temporarily attached to M-X Apropos. % Move some M-X commands into text-command-list. % 2-Feb-83 Alan Snyder % Add Lisp-D. % 26-Jan-83 Alan Snyder % Add Esc-/. % 25-Jan-83 Alan Snyder % Created Window-Command-List to allow scrolling in Recurse mode. % Removed modifying text commands from Recurse mode. % 24-Jan-83 Jeffrey Soreff % Added definition of Recurse-Mode % Defined M-X commands: Delete Matching Lines, Flush Lines, % Delete Non-Matching Lines, Keep Lines, How Many, Count Occurrences, % Set Key, Set Visited Filename, Rename Buffer, Kill Some Buffers, % Insert Date, Revert File % 5-Jan-83 Alan Snyder % Revised definition of input mode, C-S, and C-R. % 3-Dec-82 Alan Snyder % New definitions for ) and ] in Lisp mode. % New definitions for C-M-(, C-M-), C-M-U, C-M-N, and C-M-P. % New definitions for C-M-A, C-M-[, and C-M-R. % Define C-M-\ (Indent Region) in Lisp mode and Text mode. % Define C-? same as M-?, C-( same as C-M-(, C-) same as C-M-). % Lisp Mode establishes Lisp Parser. % Define C-M-C. % Define the text commands: C-=, C-X =, M-A, M-E, M-K, C-X Rubout, M-Z, M-Q, % M-G, M-H, M-], M-[, M-S. % Fix definitions of digits and hyphen: inserting definition goes on % text-command-list (where insertion commands go). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % (CompileTime (load objects)) (CompileTime (load extended-char)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-default-mode nmode-current-buffer nmode-input-special-command-list )) % Mode definitions: (fluid '(Lisp-Interface-Mode Text-Mode Basic-Mode Read-Only-Text-Mode Input-Mode Recurse-Mode )) % Command lists: (fluid '(Input-Command-List Read-Only-Text-Command-List Text-Command-List Rlisp-Command-List Lisp-Command-List Read-Only-Terminal-Command-List Modifying-Terminal-Command-List Window-Command-List Basic-Command-List Essential-Command-List Recurse-Command-List )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Mode Definitions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf Basic-Mode (nmode-define-mode "Basic" '((nmode-define-commands Basic-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) ))) (setf Read-Only-Text-Mode (nmode-define-mode "Read-Only-Text" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-establish-mode Basic-Mode) ))) (setf Text-Mode (nmode-define-mode "Text" '((nmode-define-commands Text-Command-List) (nmode-define-commands Modifying-Terminal-Command-List) (nmode-establish-mode Read-Only-Text-Mode) (nmode-define-normal-self-inserts) ))) (setf Lisp-Interface-Mode (nmode-define-mode "Lisp" '((nmode-define-commands Rlisp-Command-List) (establish-lisp-parser) (nmode-define-commands Lisp-Command-List) (nmode-establish-mode Text-Mode) ))) (setf Input-Mode (nmode-define-mode "Input" '((nmode-define-commands nmode-input-special-command-list) (nmode-define-command (x-char CR) 'nmode-terminate-input) (nmode-define-command (x-char LF) 'nmode-terminate-input) (nmode-define-commands Input-Command-List) (nmode-define-commands Text-Command-List) (nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-normal-self-inserts) ))) (setf Recurse-Mode (nmode-define-mode "Recurse" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-commands Recurse-Command-List) ))) (setf nmode-default-mode Text-Mode) (de nmode-initialize-modes () % Define initial set of file modes. (nmode-declare-file-mode "txt" Text-Mode) (nmode-declare-file-mode "red" Lisp-Interface-Mode) (nmode-declare-file-mode "sl" Lisp-Interface-Mode) (nmode-declare-file-mode "lsp" Lisp-Interface-Mode) (nmode-declare-file-mode "lap" Lisp-Interface-Mode) (nmode-declare-file-mode "build" Lisp-Interface-Mode) ) (de lisp-mode-command () (buffer-set-mode nmode-current-buffer Lisp-Interface-Mode) ) (de text-mode-command () (buffer-set-mode nmode-current-buffer Text-Mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Command Lists: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Rlisp-Command-List - commands related to the LISP interface (setf Rlisp-Command-List (list (cons (x-char C-!]) 'Lisp-prefix) (cons (x-chars C-!] !?) 'lisp-help-command) (cons (x-chars C-!] A) 'lisp-abort-command) (cons (x-chars C-!] B) 'lisp-backtrace-command) (cons (x-chars C-!] C) 'lisp-continue-command) (cons (x-chars C-!] D) 'execute-defun-command) (cons (x-chars C-!] E) 'execute-form-command) (cons (x-chars C-!] L) 'exit-nmode) (cons (x-chars C-!] Q) 'lisp-quit-command) (cons (x-chars C-!] R) 'lisp-retry-command) (cons (x-chars C-!] Y) 'yank-last-output-command) )) % Lisp-Command-List - commands related to editing LISP text (setf Lisp-Command-List (list (cons (x-char !)) 'insert-closing-bracket) (cons (x-char !]) 'insert-closing-bracket) (cons (x-char C-!() 'backward-up-list-command) (cons (x-char C-!)) 'forward-up-list-command) (cons (x-char C-M-!() 'backward-up-list-command) (cons (x-char C-M-!)) 'forward-up-list-command) (cons (x-char C-M-![) 'move-backward-defun-command) (cons (x-char C-M-!]) 'end-of-defun-command) (cons (x-char C-M-!\) 'lisp-indent-region-command) (cons (x-char C-M-@) 'mark-form-command) (cons (x-char C-M-A) 'move-backward-defun-command) (cons (x-char C-M-B) 'move-backward-form-command) (cons (x-char C-M-BACKSPACE) 'mark-defun-command) (cons (x-char C-M-D) 'down-list-command) (cons (x-char C-M-E) 'end-of-defun-command) (cons (x-char C-M-F) 'move-forward-form-command) (cons (x-char C-M-H) 'mark-defun-command) (cons (x-char C-M-I) 'lisp-tab-command) (cons (x-char C-M-K) 'kill-forward-form-command) (cons (x-char C-M-N) 'move-forward-list-command) (cons (x-char C-M-P) 'move-backward-list-command) (cons (x-char C-M-Q) 'lisp-indent-sexpr) (cons (x-char C-M-R) 'reposition-window-command) (cons (x-char C-M-RUBOUT) 'kill-backward-form-command) (cons (x-char C-M-T) 'transpose-forms) (cons (x-char C-M-TAB) 'lisp-tab-command) (cons (x-char C-M-U) 'backward-up-list-command) (cons (x-char M-!;) 'insert-comment-command) (cons (x-char M-BACKSPACE) 'mark-defun-command) (cons (x-char M-!() 'make-parens-command) (cons (x-char M-!)) 'move-over-paren-command) (cons (x-char RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char TAB) 'lisp-tab-command) )) % Essential-Command-List: the most essential commands (setf Essential-Command-List (list (cons (x-char C-X) 'c-x-prefix) (cons (x-char ESC) 'Esc-prefix) (cons (x-char M-X) 'm-x-prefix) (cons (x-char C-M-X) 'm-x-prefix) (cons (x-char C-G) 'nmode-abort-command) (cons (x-char C-L) 'nmode-refresh-command) (cons (x-char C-U) 'universal-argument) (cons (x-char 0) 'argument-digit) (cons (x-char 1) 'argument-digit) (cons (x-char 2) 'argument-digit) (cons (x-char 3) 'argument-digit) (cons (x-char 4) 'argument-digit) (cons (x-char 5) 'argument-digit) (cons (x-char 6) 'argument-digit) (cons (x-char 7) 'argument-digit) (cons (x-char 8) 'argument-digit) (cons (x-char 9) 'argument-digit) (cons (x-char -) 'negative-argument) (cons (x-char C-0) 'argument-digit) (cons (x-char C-1) 'argument-digit) (cons (x-char C-2) 'argument-digit) (cons (x-char C-3) 'argument-digit) (cons (x-char C-4) 'argument-digit) (cons (x-char C-5) 'argument-digit) (cons (x-char C-6) 'argument-digit) (cons (x-char C-7) 'argument-digit) (cons (x-char C-8) 'argument-digit) (cons (x-char C-9) 'argument-digit) (cons (x-char C--) 'negative-argument) (cons (x-char M-0) 'argument-digit) (cons (x-char M-1) 'argument-digit) (cons (x-char M-2) 'argument-digit) (cons (x-char M-3) 'argument-digit) (cons (x-char M-4) 'argument-digit) (cons (x-char M-5) 'argument-digit) (cons (x-char M-6) 'argument-digit) (cons (x-char M-7) 'argument-digit) (cons (x-char M-8) 'argument-digit) (cons (x-char M-9) 'argument-digit) (cons (x-char M--) 'negative-argument) (cons (x-char C-M-0) 'argument-digit) (cons (x-char C-M-1) 'argument-digit) (cons (x-char C-M-2) 'argument-digit) (cons (x-char C-M-3) 'argument-digit) (cons (x-char C-M-4) 'argument-digit) (cons (x-char C-M-5) 'argument-digit) (cons (x-char C-M-6) 'argument-digit) (cons (x-char C-M-7) 'argument-digit) (cons (x-char C-M-8) 'argument-digit) (cons (x-char C-M-9) 'argument-digit) (cons (x-char C-M--) 'negative-argument) (cons (x-chars C-X C-Z) 'nmode-exit-to-superior) (cons (x-chars C-X V) 'nmode-invert-video) (cons (x-chars Esc !/) 'execute-softkey-command) )) % Window-Command-List: commands for scrolling, etc. % These commands do not allow selecting a new window, buffer, mode, etc. (setf Window-Command-List (list (cons (x-char C-M-V) 'scroll-other-window-command) (cons (x-char C-V) 'next-screen-command) (cons (x-char M-R) 'move-to-screen-edge-command) (cons (x-char M-V) 'previous-screen-command) (cons (x-chars C-X <) 'scroll-window-left-command) (cons (x-chars C-X >) 'scroll-window-right-command) (cons (x-chars C-X ^) 'grow-window-command) (cons (m-x "Write Screen") 'write-screen-command) )) % Basic-Command-List: contains commands desirable in almost any mode. (setf Basic-Command-List (list (cons (x-char C-!?) 'help-dispatch) (cons (x-char C-M-L) 'select-previous-buffer-command) (cons (x-char M-!/) 'help-dispatch) (cons (x-char M-!?) 'help-dispatch) (cons (x-char M-!~) 'buffer-not-modified-command) (cons (x-chars C-X !.) 'set-fill-prefix-command) (cons (x-chars C-X 1) 'one-window-command) (cons (x-chars C-X 2) 'two-windows-command) (cons (x-chars C-X 3) 'view-two-windows-command) (cons (x-chars C-X 4) 'visit-in-other-window-command) (cons (x-chars C-X B) 'select-buffer-command) (cons (x-chars C-X C-B) 'buffer-browser-command) (cons (x-chars C-X C-F) 'find-file-command) (cons (x-chars C-X C-P) 'print-buffer-command) (cons (x-chars C-X C-S) 'save-file-command) (cons (x-chars C-X C-W) 'write-file-command) % here??? (cons (x-chars C-X D) 'dired-command) (cons (x-chars C-X E) 'exchange-windows-command) (cons (x-chars C-X F) 'set-fill-column-command) (cons (x-chars C-X K) 'kill-buffer-command) (cons (x-chars C-X O) 'other-window-command) (cons (x-chars Esc _) 'apropos-command) (cons (m-x "Append to File") 'append-to-file-command) (cons (m-x "Apropos") 'apropos-command) (cons (m-x "Auto Fill Mode") 'auto-fill-mode-command) (cons (m-x "Count Occurrences") 'Count-Occurrences-command) (cons (m-x "Delete and Expunge File") 'delete-and-expunge-file-command) (cons (m-x "Delete File") 'delete-file-command) (cons (m-x "DIRED") 'edit-directory-command) (cons (m-x "Edit Directory") 'edit-directory-command) (cons (m-x "Execute Buffer") 'execute-buffer-command) (cons (m-x "Execute File") 'execute-file-command) (cons (m-x "Find File") 'find-file-command) (cons (m-x "How Many") 'Count-Occurrences-command) (cons (m-x "Kill Buffer") 'kill-buffer-command) (cons (m-x "Kill File") 'delete-file-command) (cons (m-x "Kill Some Buffers") 'kill-some-buffers-command) (cons (m-x "List Browsers") 'browser-browser-command) (cons (m-x "List Buffers") 'buffer-browser-command) (cons (m-x "Make Space") 'nmode-gc) (cons (m-x "Prepend to File") 'prepend-to-file-command) (cons (m-x "Print Buffer") 'print-buffer-command) (cons (m-x "Rename Buffer") 'rename-buffer-command) (cons (m-x "Save All Files") 'save-all-files-command) (cons (m-x "Select Buffer") 'select-buffer-command) (cons (m-x "Set Key") 'set-key-command) (cons (m-x "Set Visited Filename") 'set-visited-filename-command) (cons (m-x "Start Scripting") 'start-scripting-command) (cons (m-x "Start Timing NMODE") 'start-timing-command) (cons (m-x "Stop Scripting") 'stop-scripting-command) (cons (m-x "Stop Timing NMODE") 'stop-timing-command) (cons (m-x "Undelete File") 'undelete-file-command) (cons (m-x "Write File") 'write-file-command) % here??? (cons (m-x "Write Region") 'write-region-command) )) % Read-Only-Text-Command-List: Commands for editing text buffers that % do not modify the buffer. (setf Read-Only-Text-Command-List (list % These commands are read-only commands for text mode. (cons (x-char BACKSPACE) 'move-backward-character-command) (cons (x-char C-<) 'mark-beginning-command) (cons (x-char C->) 'mark-end-command) (cons (x-char C-=) 'what-cursor-position-command) (cons (x-char C-@) 'set-mark-command) (cons (x-char C-A) 'move-to-start-of-line-command) (cons (x-char C-B) 'move-backward-character-command) (cons (x-char C-E) 'move-to-end-of-line-command) (cons (x-char C-F) 'move-forward-character-command) (cons (x-char C-M-M) 'back-to-indentation-command) (cons (x-char C-M-RETURN) 'back-to-indentation-command) (cons (x-char C-M-W) 'append-next-kill-command) (cons (x-char C-N) 'move-down-command) (cons (x-char C-P) 'move-up-command) (cons (x-char C-R) 'reverse-search-command) (cons (x-char C-S) 'incremental-search-command) (cons (x-char C-SPACE) 'set-mark-command) (cons (x-char M-<) 'move-to-buffer-start-command) (cons (x-char M->) 'move-to-buffer-end-command) (cons (x-char M-![) 'backward-paragraph-command) (cons (x-char M-!]) 'forward-paragraph-command) (cons (x-char M-@) 'mark-word-command) (cons (x-char M-A) 'backward-sentence-command) (cons (x-char M-B) 'move-backward-word-command) (cons (x-char M-E) 'forward-sentence-command) (cons (x-char M-F) 'move-forward-word-command) (cons (x-char M-H) 'mark-paragraph-command) (cons (x-char M-M) 'back-to-indentation-command) (cons (x-char M-RETURN) 'back-to-indentation-command) (cons (x-char M-W) 'copy-region) (cons (x-chars C-X A) 'append-to-buffer-command) (cons (x-chars C-X C-N) 'set-goal-column-command) (cons (x-chars C-X C-X) 'exchange-point-and-mark) (cons (x-chars C-X H) 'mark-whole-buffer-command) (cons (x-chars C-X =) 'what-cursor-position-command) )) % Text-Command-List: Commands for editing text buffers that might modify % the buffer. Note: put read-only commands on % Read-Only-Text-Command-List (above). (setf Text-Command-List (list (cons (x-char 0) 'argument-or-insert-command) (cons (x-char 1) 'argument-or-insert-command) (cons (x-char 2) 'argument-or-insert-command) (cons (x-char 3) 'argument-or-insert-command) (cons (x-char 4) 'argument-or-insert-command) (cons (x-char 5) 'argument-or-insert-command) (cons (x-char 6) 'argument-or-insert-command) (cons (x-char 7) 'argument-or-insert-command) (cons (x-char 8) 'argument-or-insert-command) (cons (x-char 9) 'argument-or-insert-command) (cons (x-char -) 'argument-or-insert-command) (cons (x-char C-!%) 'replace-string-command) (cons (x-char C-D) 'delete-forward-character-command) (cons (x-char C-K) 'kill-line) (cons (x-char C-M-C) 'insert-self-command) (cons (x-char C-M-O) 'split-line-command) (cons (x-char C-M-!\) 'indent-region-command) (cons (x-char C-N) 'move-down-extending-command) (cons (x-char C-O) 'open-line-command) (cons (x-char C-Q) 'insert-next-character-command) (cons (x-char C-RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char C-T) 'transpose-characters-command) (cons (x-char C-W) 'kill-region) (cons (x-char C-Y) 'insert-kill-buffer) (cons (x-char LF) 'indent-new-line-command) (cons (x-char M-!') 'upcase-digit-command) (cons (x-char M-!%) 'query-replace-command) (cons (x-char M-!\) 'delete-horizontal-space-command) (cons (x-char M-C) 'uppercase-initial-command) (cons (x-char M-D) 'kill-forward-word-command) (cons (x-char M-G) 'fill-region-command) (cons (x-char M-I) 'tab-to-tab-stop-command) (cons (x-char M-K) 'kill-sentence-command) (cons (x-char M-L) 'lowercase-word-command) (cons (x-char M-Q) 'fill-paragraph-command) (cons (x-char M-RUBOUT) 'kill-backward-word-command) (cons (x-char M-S) 'center-line-command) (cons (x-char M-T) 'transpose-words) (cons (x-char M-TAB) 'tab-to-tab-stop-command) (cons (x-char M-U) 'uppercase-word-command) (cons (x-char M-Y) 'unkill-previous) (cons (x-char M-Z) 'fill-comment-command) (cons (x-char M-^) 'delete-indentation-command) (cons (x-char RETURN) 'return-command) (cons (x-char RUBOUT) 'delete-backward-character-command) (cons (x-char TAB) 'tab-to-tab-stop-command) (cons (x-chars C-X C-L) 'lowercase-region-command) (cons (x-chars C-X C-O) 'delete-blank-lines-command) (cons (x-chars C-X C-T) 'transpose-lines) (cons (x-chars C-X C-U) 'uppercase-region-command) (cons (x-chars C-X C-V) 'visit-file-command) (cons (x-chars C-X G) 'get-register-command) (cons (x-chars C-X Rubout) 'backward-kill-sentence-command) (cons (x-chars C-X T) 'transpose-regions) (cons (x-chars C-X X) 'put-register-command) (cons (m-x "Delete Matching Lines") 'delete-matching-lines-command) (cons (m-x "Delete Non-Matching Lines") 'delete-non-matching-lines-command) (cons (m-x "Flush Lines") 'delete-matching-lines-command) (cons (m-x "Insert Buffer") 'insert-buffer-command) (cons (m-x "Insert Date") 'insert-date-command) (cons (m-x "Insert File") 'insert-file-command) (cons (m-x "Keep Lines") 'delete-non-matching-lines-command) (cons (m-x "Lisp Mode") 'lisp-mode-command) (cons (m-x "Replace String") 'replace-string-command) (cons (m-x "Query Replace") 'query-replace-command) (cons (m-x "Revert File") 'revert-file-command) (cons (m-x "Text Mode") 'text-mode-command) (cons (m-x "Visit File") 'visit-file-command) )) (setf Read-Only-Terminal-Command-List (list (cons (x-chars ESC !h) 'move-to-buffer-start-command) (cons (x-chars ESC 4) 'move-backward-word-command) (cons (x-chars ESC 5) 'move-forward-word-command) (cons (x-chars ESC A) 'move-up-command) (cons (x-chars ESC B) 'move-down-command) (cons (x-chars ESC C) 'move-forward-character-command) (cons (x-chars ESC D) 'move-backward-character-command) (cons (x-chars ESC F) 'move-to-buffer-end-command) (cons (x-chars ESC J) 'nmode-full-refresh) (cons (x-chars ESC S) 'scroll-window-up-line-command) (cons (x-chars ESC T) 'scroll-window-down-line-command) (cons (x-chars ESC U) 'scroll-window-up-page-command) (cons (x-chars ESC V) 'scroll-window-down-page-command) )) (setf Modifying-Terminal-Command-List (list (cons (x-chars ESC L) 'open-line-command) (cons (x-chars ESC M) 'kill-line) (cons (x-chars ESC P) 'delete-forward-character-command) )) (setf Input-Command-List (list (cons (x-char C-R) 'nmode-yank-default-input) )) (setf Recurse-Command-List (list (cons (x-char y) 'affirmative-exit) (cons (x-char n) 'negative-exit) )) |
Added psl-1983/3-1/nmode/modes.sl version [d4c2dde0e6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MODES.SL - NMODE Mode Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 4 March 1983 % % 4-Mar-83 Alan Snyder % Revise pathname-default-mode to handle invalid pathname. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char)) % Global variables: (fluid '(nmode-default-mode nmode-minor-modes % list of active minor modes (don't modify inplace!) )) % Internal static variables: (fluid '(nmode-defined-modes nmode-file-modes )) (setf nmode-default-mode NIL) (setf nmode-defined-modes ()) (setf nmode-file-modes ()) (setf nmode-minor-modes ()) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Mode Definition: % % The following function is used to define a mode (either major or minor): % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-define-mode (name establish-expressions) (let* ((mode (make-instance 'mode 'name name 'establish-expressions establish-expressions )) (pair (Ass (function string-equal) name nmode-defined-modes ))) (if pair (rplacd pair mode) (setf nmode-defined-modes (cons (cons name mode) nmode-defined-modes) )) mode )) (defflavor mode ( name establish-expressions ) () gettable-instance-variables initable-instance-variables ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % File Modes % % The following functions associate a default mode with certain filename % extensions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-declare-file-mode (file-type mode) (let ((pair (Ass (function string-equal) file-type nmode-file-modes ))) (if pair (rplacd pair mode) (setf nmode-file-modes (cons (cons file-type mode) nmode-file-modes) )) )) (de pathname-default-mode (fn) (let ((pn (maybe-pathname fn))) (if pn (let ((pair (Ass (function string-equal) (pathname-type pn) nmode-file-modes ))) (if pair (cdr pair) nmode-default-mode) ) nmode-default-mode ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Minor Modes % % A minor mode is a mode that can be turned on or off independently of the % current buffer or the current major mode. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de minor-mode-active? (m) % M is a mode object. Return T if it is an active minor mode. (memq m nmode-minor-modes) ) (de activate-minor-mode (m) % M is a mode object. Make it active (if it isn't already). (when (not (minor-mode-active? m)) (setf nmode-minor-modes (cons m nmode-minor-modes)) (nmode-establish-current-mode) )) (de deactivate-minor-mode (m) % M is a mode object. If it is active, deactivate it. (when (minor-mode-active? m) (setf nmode-minor-modes (delq m nmode-minor-modes)) (nmode-establish-current-mode) )) (de toggle-minor-mode (m) % M is a mode object. If it is active, deactivate it and return T; % otherwise, activate it and return NIL. (let ((is-active? (minor-mode-active? m))) (if is-active? (deactivate-minor-mode m) (activate-minor-mode m) ) is-active? )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Manipulating mode lists: % % The following functions are provided for use in user init files. They are % not used in NMODE. See the file -CUSTOMIZING.TXT for information on how to % customize NMODE. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de add-to-command-list (listname command func) (let* ((old-list (eval listname)) (old-binding (assoc command old-list)) (binding (cons command func)) ) (cond % If the binding isn't already in the a-list. ((null old-binding) % Add the new binding (set listname (aconc old-list binding))) % Otherwise, replace the old operation in the binding. (T (setf (cdr old-binding) func))) NIL )) (de remove-from-command-list (listname command) (let* ((old-list (eval listname)) (old-binding (assoc command old-list)) ) (cond (old-binding (set listname (DelQ old-binding old-list)) NIL )))) (de set-text-command (command func) % This function is a shorthand for modifying text mode. The arguments are as % for ADD-TO-COMMAND-LIST. The change takes effect immediately. (add-to-command-list 'Text-Command-List command func) (nmode-establish-current-mode)) |
Added psl-1983/3-1/nmode/move-commands.sl version [13996e70db].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Move-Commands.SL - NMODE Move commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Bug fix: permanent goal column wasn't permanent. % 18-Nov-82 Alan Snyder % Added move-up-list, move-over-list, and move-over-defun commands. % Changed skip-forward-blanks and skip-backward-blanks. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-current-buffer nmode-command-argument nmode-command-argument-given nmode-previous-command-function)) % Internal static variables: (fluid '(nmode-goal-column % permanent goal (set by user) nmode-temporary-goal-column % temporary goal within cmd sequence nmode-goal-column-functions % cmds that don't reset temp goal )) (setf nmode-goal-column nil) (setf nmode-temporary-goal-column nil) (setf nmode-goal-column-functions (list (function move-down-command) (function move-down-extending-command) (function move-up-command) (function set-goal-column-command) )) (de move-to-buffer-start-command () (set-mark-from-point) (move-to-buffer-start) ) (de move-to-buffer-end-command () (set-mark-from-point) (move-to-buffer-end) ) (de move-to-start-of-line-command () (current-buffer-goto (+ (current-line-pos) (- nmode-command-argument 1)) 0) ) (de move-to-end-of-line-command () (move-to-start-of-line-command) (move-to-end-of-line)) (de set-goal-column-command () (cond ((= nmode-command-argument 1) (setf nmode-goal-column (current-display-column)) (write-prompt (BldMsg "Goal Column = %p" nmode-goal-column)) ) (t (setf nmode-goal-column NIL) (write-prompt "No Goal Column") ))) (de setup-goal-column () % If this is the first in a new (potential) sequence of up/down commands, % then set the temporary goal column for that sequence of commands. (if (not (memq nmode-previous-command-function nmode-goal-column-functions)) (setf nmode-temporary-goal-column (current-display-column))) ) (de goto-goal-column () % Move the cursor to the current goal column, which is the permanent goal % column (if set by the user) or the temporary goal column (otherwise). (cond (nmode-goal-column (set-display-column nmode-goal-column)) (nmode-temporary-goal-column (set-display-column nmode-temporary-goal-column)) )) (de move-up-command () (setup-goal-column) (set-line-pos (- (current-line-pos) nmode-command-argument)) (goto-goal-column) ) (de move-down-extending-command () (when (and (not nmode-command-argument-given) (current-line-is-last?)) (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (insert-eol) (buffer-set-position old-pos) )) (move-down-command) ) (de move-down-command () (setup-goal-column) (set-line-pos (+ (current-line-pos) nmode-command-argument)) (goto-goal-column) ) (de exchange-point-and-mark () (let ((old-mark (current-mark))) (previous-mark) % pop off the old mark (set-mark-from-point) % push the new one (buffer-set-position old-mark) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Skipping Blanks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de char-blank-or-newline? (ch) (or (char-blank? ch) (= ch #\LF))) (de skip-forward-blanks () % Skip over "blanks", return the first non-blank character seen. % Cursor is positioned to the left of that character. (while (and (not (at-buffer-end?)) (char-blank-or-newline? (next-character)) ) (move-forward)) (next-character)) (de skip-backward-blanks () % Skip backwards over "blanks", return the first non-blank character seen. % Cursor is positioned to the right of that character. (while (and (not (at-buffer-start?)) (char-blank-or-newline? (previous-character)) ) (move-backward)) (previous-character)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Characters commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-character-command () (if (not (move-over-characters nmode-command-argument)) (Ding))) (de move-backward-character-command () (if (not (move-over-characters (- nmode-command-argument))) (Ding))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Word commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-word-command () (if (not (move-over-words nmode-command-argument)) (Ding))) (de move-backward-word-command () (if (not (move-over-words (- nmode-command-argument))) (Ding))) (de move-over-words (n) % Move forward (n>0) or backwards (n<0) over |n| words. Return T if the % specified number of words were found, NIL otherwise. The cursor remains at % the last word found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-word))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-word))) (setf n (+ n 1))) flag)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Form commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-form-command () (if (not (move-over-forms nmode-command-argument)) (Ding))) (de move-backward-form-command () (if (not (move-over-forms (- nmode-command-argument))) (Ding))) (de move-over-forms (n) % Move forward (n>0) or backwards (n<0) over |n| forms. Return T if the % specified number of forms were found, NIL otherwise. The cursor remains at % the last form found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-form))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-form))) (setf n (+ n 1))) flag)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Up-List commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de forward-up-list-command () (if (not (move-up-lists nmode-command-argument)) (Ding))) (de backward-up-list-command () (if (not (move-up-lists (- nmode-command-argument))) (Ding))) (de move-up-lists (n) % Move forward (n>0) or backwards (n<0) out of |n| lists (structures). % Return T if the specified number of brackets were found, NIL otherwise. % The cursor remains at the last bracket found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-up-list))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-up-list))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-List commands % % Note: In EMACS, these commands were motivated by the fact that EMACS did % not understand Lisp comments. Thus, in EMACS, move-forward-list could be % used as a move-forward-form that ignored comments. Since NMODE does % understand comments, it is not clear that these commands have any use. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-list-command () (if (not (move-over-lists nmode-command-argument)) (Ding))) (de move-backward-list-command () (if (not (move-over-lists (- nmode-command-argument))) (Ding))) (de move-over-lists (n) % Move forward (n>0) or backwards (n<0) over |n| lists (structures). % Return T if the specified number of lists were found, NIL otherwise. % The cursor remains at the last list found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-list))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-list))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Defun commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-defun-command () (if (not (move-over-defuns nmode-command-argument)) (Ding))) (de move-backward-defun-command () (if (not (move-over-defuns (- nmode-command-argument))) (Ding))) (de move-over-defuns (n) % Move forward (n>0) or backwards (n<0) over |n| defuns. % Return T if the specified number of defuns were found, NIL otherwise. % The cursor remains at the last defun found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-defun))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-defun))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Character Movement Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-characters (n) % Move forward (n>0) or backwards (n<0) over |n| characters. Return T if the % specified number of characters were found, NIL otherwise. The cursor % remains at the last character found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-character))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-character))) (setf n (+ n 1))) flag)) (de move-forward-character () % Move forward one character. If there is no next character, leave cursor % unchanged and return NIL; otherwise, return T. (if (at-buffer-end?) NIL (move-forward) T )) (de move-backward-character () % Move backward one character. If there is no previous character, leave % cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-start?) NIL (move-backward) T )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Character Movement Primitives (Hacking Tabs Version) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-characters-hacking-tabs (n) % Move forward (n>0) or backwards (n<0) over |n| characters. Return T if the % specified number of characters were found, NIL otherwise. The cursor % remains at the last character found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-character-hacking-tabs))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-character-hacking-tabs))) (setf n (+ n 1))) flag)) (de move-forward-character-hacking-tabs () % Move forward one character. If the next character is a tab, first % replace it with the appropriate number of spaces. If there is no next % character, leave cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-end?) NIL (cond ((= (next-character) (char TAB)) (delete-next-character) (let ((n (- 8 (& (current-display-column) 7)))) (insert-string (substring " " 0 n)) (set-char-pos (- (current-char-pos) n)) ))) (move-forward) T )) (de move-backward-character-hacking-tabs () % Move backward one character. If the previous character is a tab, first % replace it with the appropriate number of spaces. If there is no previous % character, leave cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-start?) NIL (cond ((= (previous-character) (char TAB)) (delete-previous-character) (let ((n (- 8 (& (current-display-column) 7)))) (insert-string (substring " " 0 n)) ))) (move-backward) T )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Word Movement Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de word-char? (ch) (or (AlphanumericP ch) (= ch (char -)))) (de move-forward-word () % Move forward one "word", starting from point. Leave cursor to the % right of the "word". If there is no next word, leave cursor unchanged % and return NIL; otherwise, return T. (let ((old-pos (buffer-get-position))) (while (and (not (at-buffer-end?)) % scan for start of word (not (word-char? (next-character))) ) (move-forward)) (cond ((at-buffer-end?) (buffer-set-position old-pos) NIL ) (t (while (and (not (at-buffer-end?)) % scan for end of word (word-char? (next-character)) ) (move-forward)) T )))) (de move-backward-word () % Move backward one "word", starting from point. Leave cursor to the left of % the "word". If there is no previous word, leave cursor unchanged and % return NIL; otherwise, return T. (let ((old-pos (buffer-get-position))) (while (and (not (at-buffer-start?)) % scan for end of word (not (word-char? (previous-character))) ) (move-backward)) (cond ((at-buffer-start?) (buffer-set-position old-pos) NIL ) (t (while (and (not (at-buffer-start?)) % scan for start of word (word-char? (previous-character)) ) (move-backward)) T )))) |
Added psl-1983/3-1/nmode/nmode-20.lap version [e1578d38c2].
> > | 1 2 | (faslin "pnb:nmode-20.b") (load-nmode) |
Added psl-1983/3-1/nmode/nmode-20.sl version [d4241e4595].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-20.SL - DEC-20 NMODE Stuff (intended for DEC-20 Version Only) % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 5 April 1983 % % 5-Apr-83 Alan Snyder % Add load-nmode and set-terminal stuff to make it more like other systems. % 15-Mar-83 Alan Snyder % Add nmode-print-device. % 25-Jan-83 Alan Snyder % Add version of actualize-file-name that ensures that transiently-created % file has delete access. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load useful common fast-strings)) % External variables used here: (fluid '(nmode-file-list nmode-source-prefix nmode-binary-prefix *usermode *redefmsg doc-text-file reference-text-file nmode-print-device nmode-terminal )) % Global variables defined here: (fluid '(terminal-type)) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "pn:")) (if (or (unboundp 'nmode-binary-prefix) (null nmode-binary-prefix)) (setf nmode-binary-prefix "pnb:")) (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overridden by the user before NMODE is initialized. (nmode-load-required-modules) (nmode-load-all) (setf nmode-print-device "LPT:") % Set up "pointers" to online documentation. (setf doc-text-file "SS:<PSL.NMODE-DOC>FRAMES.LPT") (setf reference-text-file "SS:<PSL.NMODE-DOC>COSTLY.SL") (let ((*usermode nil) (*redefmsg nil)) (copyd 'actualize-file-name 'dec20-actualize-file-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-set-terminal () (setf terminal-type (jsys2 65 0 0 0 (const jsgttyp))) (selectq terminal-type (21 % HP2621 (ensure-terminal-type 'hp2648a) ) (6 % HP264X (ensure-terminal-type 'hp2648a) ) (15 % VT52 (ensure-terminal-type 'vt52x) ) (t (or nmode-terminal (ensure-terminal-type 'hp2648a)) ) )) % These functions defined for compatibility: (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () % Stolen directly from Nancy Kendzierski % Date/time in appropriate format for the network mail header (let ((date-time (MkString 80))) (jsys1 date-time -1 #.(bits 5 7 10 12 13) 0 (const jsODTIM)) (recopystringtonull date-time))) (de dec20-actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output (string-concat file-name ";P777777") % so we can delete it! )) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load objects) (load common) (load useful) (load strings) (load pathnames) (load pathnamex) (load ring-buffer) (load extended-char) (load directory) (load input-stream) (load output-stream) (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load rawio) (load windows) ) (de nmode-fixup-name (s) s) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-binary-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "browser-browser" "buffer-browser" "dired" "doc" )) |
Added psl-1983/3-1/nmode/nmode-9836.lap version [a36fa60c58].
> > | 1 2 | (faslin "pnb:nmode-9836.b") (load-nmode) |
Added psl-1983/3-1/nmode/nmode-9836.sl version [7fb6f3ad0a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-9836.SL - HP9836 Nmode Stuff (intended only for HP9836 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 January 1983 % Revised: 5 April 1983 % % 5-Apr-83 Alan Snyder % Changes relating to keeping NMODE source and binary files in separate % directories. Add NMODE-SET-TERMINAL from old set-terminal file. % Remove set-terminal from list of source files. % 24-Mar-83 Alan Snyder % External function renamed: System-Date -> Date-and-Time. % 15-Mar-83 Alan Snyder % Add browser-browser. Implement current-date-time. % 4-Mar-83 Alan Snyder % Load pathnamex. Load nmode-aids (instead of lapin). % 15-Feb-83 Alan Snyder % No longer sets NMODE-AUTO-START (inconsistent with other systems). Add new % online documentation stuff. % 7-Feb-83 Alan Snyder % Load browser. % 31-Jan-83 Alan Snyder % Add softkey stuff, keyboard mapping stuff, load window-label. Redefine % PasFiler and PasEditor to refresh the screen upon exit, if NMODE was % running. % 25-Jan-83 Alan Snyder % Added dummy version of current-date-time function; load M-XCMD and REC. % 21-Jan-83 Alan Snyder % Load more stuff. Change INIT to return NIL. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int extended-char)) (bothtimes (load strings common)) (fluid '(alpha-terminal color-terminal nmode-file-list nmode-source-prefix nmode-binary-prefix *quiet_faslout *usermode *redefmsg installkeys-address uninstallkeys-address nmode-softkey-label-screen-height nmode-softkey-label-screen-width doc-text-file reference-text-file )) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "pn:")) (if (or (unboundp 'nmode-binary-prefix) (null nmode-binary-prefix)) (setf nmode-binary-prefix "pnb:")) (if (funboundp 'pre-nmode-main) (copyd 'pre-nmode-main 'main)) (if (funboundp 'pre-nmode-pasfiler) (copyd 'pre-nmode-pasfiler 'pasfiler)) (if (funboundp 'pre-nmode-paseditor) (copyd 'pre-nmode-paseditor 'paseditor)) (setf installkeys-address (system-address "NMODEKEYS_INSTALL_KEYMAP")) (setf uninstallkeys-address (system-address "NMODEKEYS_UNINSTALL_KEYMAP")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 9836 Customization: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-9836-init () % This function modifies "standard" NMODE for use on the 9836. (let ((*usermode nil) (*redefmsg nil)) (copyd 'nmode-initialize 'original-nmode-initialize) (copyd 'actualize-file-name '9836-actualize-file-name) ) (original-nmode-initialize) (add-to-command-list 'basic-command-list (x-chars C-X C-Z) 'exit-nmode) (nmode-establish-current-mode) (setf alpha-terminal nmode-terminal) (setf color-terminal (make-instance '9836-color)) nil % for looks ) (de nmode-set-terminal () (or nmode-terminal (ensure-terminal-type '9836-alpha)) (or nmode-other-terminal (ensure-other-terminal-type '9836-color)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Useful Functions for Compiling: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overrided by the user before nmode is initialized. (nmode-load-required-modules) (nmode-load-all) (setf nmode-softkey-label-screen-height 2) % two rows (setf nmode-softkey-label-screen-width 5) % of five keys each (setf doc-text-file "psl:nmode.frames") (setf reference-text-file "psl:nmode.xref") (let ((*usermode nil) (*redefmsg nil)) (if (funboundp 'original-nmode-initialize) (copyd 'original-nmode-initialize 'nmode-initialize)) (copyd 'nmode-initialize 'nmode-9836-init) )) (de compile-lisp-file (source-name object-name) (let ((*quiet_faslout T)) (if (not (filep source-name)) (printf "Unable to open source file: %w%n" source-name) % else (printf "%n----- Compiling %w to %w%n" source-name (string-concat object-name ".b")) (faslout object-name) (unwind-protect (dskin source-name) (faslend) ) (printf "%n----------------------------------------------------------%n") ))) (de file-compile (s) (let ((object-name s) (source-name (string-concat s ".sl")) ) (compile-lisp-file source-name object-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () (date-and-time)) (de 9836-actualize-file-name (fn) fn) (de nmode-use-color () % Use the COLOR screen (only). (setf nmode-terminal color-terminal) (nmode-new-terminal) ) (de nmode-use-alpha () % Use the ALPHA screen as the primary screen. (setf nmode-terminal alpha-terminal) (nmode-new-terminal) ) (de install-nmode-keymap () (setf nmode-meta-bit-prefix-character (x-char ^!\)) (lpcall0 installkeys-address) ) (de uninstall-nmode-keymap () (setf nmode-meta-bit-prefix-character (x-char ^![)) (lpcall0 uninstallkeys-address) ) (de pasfiler () (pre-nmode-pasfiler) (if *NMODE-RUNNING (nmode-full-refresh)) ) (de paseditor () (pre-nmode-paseditor) (if *NMODE-RUNNING (nmode-full-refresh)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load addr2id) (load objects) (load common) (load useful) (load strings) (load pathnames) (load pathnamex) (load ring-buffer) (load extended-char) (load directory) (load input-stream) (load output-stream) (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load windows) (load nmode-aids) ) (de nmode-fixup-name (s) s) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-binary-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "browser-browser" "buffer-browser" "dired" "doc" )) |
Added psl-1983/3-1/nmode/nmode-attributes.sl version [9c373b007f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Nmode-Attributes.SL - macros for NMODE parsing primitives % [This file used to be Parsing-Attributes.SL] % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 November 1982 % % This file defines Macros! Load it at compile-time! % % See the document NMODE-PARSING.TXT for a description of the parsing strategy. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) % Internal Constants: % Type attributes: % Exactly one of these should always be on. (defconst OPENER-BITS 2#000000001) % part of an opening "bracket" (defconst CLOSER-BITS 2#000000010) % part of a closing "bracket" (defconst ATOM-BITS 2#000000100) % part of an "atom" (defconst BLANKS-BITS 2#000001000) % part of a "blank region" (defconst COMMENT-BITS 2#000010000) % part of a comment % Secondary attributes: % Zero or more of these may be on. (defconst PREFIX-BITS 2#000100000) % a subclass of opening bracket % Position attributes: % One or two of these should always be on. (defconst FIRST-BITS 2#001000000) % the first character of an item (defconst MIDDLE-BITS 2#010000000) % neither first nor last (defconst LAST-BITS 2#100000000) % the last character of an item % Masks: (defconst POSITION-BITS #.(| (const FIRST-BITS) (| (const MIDDLE-BITS) (const LAST-BITS)))) (defconst BRACKET-BITS #.(| (const OPENER-BITS) (const CLOSER-BITS))) (defconst WHITESPACE-BITS #.(| (const BLANKS-BITS) (const COMMENT-BITS))) (defconst NOT-SPACE-BITS #.(| (const BRACKET-BITS) (const ATOM-BITS))) (defconst PRIMARY-TYPE-BITS #.(| (const NOT-SPACE-BITS) (const WHITESPACE-BITS))) (defconst SECONDARY-TYPE-BITS #.(const PREFIX-BITS)) (defconst TYPE-BITS #.(| (const PRIMARY-TYPE-BITS) (const SECONDARY-TYPE-BITS))) (de parse-character-attributes (attribute-list) % Given a list of attribute names, return an integer containing % all of their bits. (let ((bits 0)) (for (in attribute-name attribute-list) (do (selectq attribute-name (OPENER (setf bits (| bits (const OPENER-BITS)))) (CLOSER (setf bits (| bits (const CLOSER-BITS)))) (BRACKET (setf bits (| bits (const BRACKET-BITS)))) (ATOM (setf bits (| bits (const ATOM-BITS)))) (BLANKS (setf bits (| bits (const BLANKS-BITS)))) (COMMENT (setf bits (| bits (const COMMENT-BITS)))) (WHITESPACE (setf bits (| bits (const WHITESPACE-BITS)))) (NOT-SPACE (setf bits (| bits (const NOT-SPACE-BITS)))) (PREFIX (setf bits (| bits (const PREFIX-BITS)))) (FIRST (setf bits (| bits (const FIRST-BITS)))) (MIDDLE (setf bits (| bits (const MIDDLE-BITS)))) (LAST (setf bits (| bits (const LAST-BITS)))) (t (StdError (BldMsg "Invalid character attribute: %p" attribute-name))) ))) bits )) (de unparse-character-attributes (bits) % Return a list of attribute names. (let ((l ())) (if (~= 0 (& bits (const OPENER-BITS))) (setf l (cons 'OPENER l))) (if (~= 0 (& bits (const CLOSER-BITS))) (setf l (cons 'CLOSER l))) (if (~= 0 (& bits (const ATOM-BITS))) (setf l (cons 'ATOM l))) (if (~= 0 (& bits (const BLANKS-BITS))) (setf l (cons 'BLANKS l))) (if (~= 0 (& bits (const COMMENT-BITS))) (setf l (cons 'COMMENT l))) (if (~= 0 (& bits (const PREFIX-BITS))) (setf l (cons 'PREFIX l))) (if (~= 0 (& bits (const LAST-BITS))) (setf l (cons 'LAST l))) (if (~= 0 (& bits (const MIDDLE-BITS))) (setf l (cons 'MIDDLE l))) (if (~= 0 (& bits (const FIRST-BITS))) (setf l (cons 'FIRST l))) l )) (de decode-character-attribute-type (bits) % Return a primary type attribute name or NIL. (cond ((~= 0 (& bits (const OPENER-BITS))) 'OPENER) ((~= 0 (& bits (const CLOSER-BITS))) 'CLOSER) ((~= 0 (& bits (const ATOM-BITS))) 'ATOM) ((~= 0 (& bits (const BLANKS-BITS))) 'BLANKS) ((~= 0 (& bits (const COMMENT-BITS))) 'COMMENT) (t NIL) )) (de fix-attribute-bits (bits) (if (= (& bits (const POSITION-BITS)) 0) % No position specified? Then any position will do. (setf bits (| bits (const POSITION-BITS)))) (if (= (& bits (const TYPE-BITS)) 0) % No type specified? Then any type will do. (setf bits (| bits (const TYPE-BITS)))) bits ) (defmacro attributes attributes-list (parse-character-attributes attributes-list) ) (defmacro test-attributes attributes-list (fix-attribute-bits (parse-character-attributes attributes-list)) ) |
Added psl-1983/3-1/nmode/nmode-break.sl version [8eea19dd9a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-BREAK.SL - NMODE Break Handler % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 26 August 1982 % % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(*NMODE-RUNNING *nmode-init-running *OutWindow nmode-terminal nmode-command-argument nmode-buffer-channel)) (fluid '(BreakLevel* *QuitBreak BreakEval* BreakName* ERROUT* ErrorForm*)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % We redefine BREAK (the break handler) and YESP. % Grab the original versions (if we can find them!). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (if (FUnboundP 'pre-nmode-break) (CopyD 'pre-nmode-break (if (FUnboundP 'pre_rawio_break) 'break 'pre_rawio_break ))) (if (FUnboundP 'pre-nmode-yesp) (CopyD 'pre-nmode-yesp 'yesp)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Initialization: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de enable-nmode-break () (let ((*usermode NIL) (*redefmsg NIL) ) (CopyD 'break 'nmode-break) (CopyD 'yesp 'nmode-yesp) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Break handler: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-break () (cond (*NMODE-RUNNING (nmode-break-handler)) (t (let ((old-raw-mode (=> nmode-terminal raw-mode))) (leave-raw-mode) (prog1 (pre-nmode-break) (if old-raw-mode (enter-raw-mode)) ))))) (de nmode-break-handler () (let* ((BreakLevel* (+ BreakLevel* 1)) (*QuitBreak T) (BreakEval* 'Eval) (BreakName* "NMODE Break") (OldIN* IN*) (OldOUT* OUT*) (nmode-error? (eq in* 0)) (nmode-channel? (eq in* nmode-buffer-channel)) (init-error? *nmode-init-running) (old-raw-mode (=> nmode-terminal raw-mode)) (*OutWindow T) % always pop up on a break (*nmode-init-running NIL) % ditto (*NMODE-RUNNING (not nmode-error?)) ) (cond (nmode-error? (leave-raw-mode) (RDS 0) (WRS 1) ) (t (RDS nmode-buffer-channel) (WRS nmode-buffer-channel) (enter-raw-mode) )) (when init-error? (Printf "Error occurred while executing your NMODE INIT file!%n") (Ding) ) (unwind-protect (Catch '$Break$ (TopLoop 'Read 'Print 'BreakEval BreakName* "NMODE Break loop") ) (RDS OldIN*) (WRS OldOUT*) (if old-raw-mode (enter-raw-mode)) ) (if *QuitBreak (let ((*Break NIL) (*EmsgP NIL) ) (StdError "Exit to ErrorSet"))) ) (Eval ErrorForm*) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Break command functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-quit-command () (cond ((ensure-in-break) (setf *QuitBreak T) (throw '$Break$ NIL) ))) (de lisp-retry-command () (cond ((ensure-in-break) (cond (*ContinuableError (setf *QuitBreak NIL) (throw '$Break$ NIL) ) (t (write-prompt "Cannot retry: error is not continuable.") (Ding))) ))) (de lisp-continue-command () (cond ((ensure-in-break) (cond (*ContinuableError (setf ErrorForm* (MkQuote BreakValue*)) (setf *QuitBreak NIL) (throw '$Break$ NIL) ) (t (write-prompt "Cannot continue: error is not continuable.") (Ding))) ))) (de lisp-abort-command () (cond ((ensure-in-break) (reset)))) (de lisp-backtrace-command () (cond ((ensure-in-break) (nmode-select-buffer-channel) (cond ((>= nmode-command-argument 16) (VerboseBackTrace)) ((>= nmode-command-argument 4) (InterpBackTrace)) (t (BackTrace))) (nmode-select-old-channels) ))) (de lisp-help-command () (write-message (if (> BreakLevel* 0) "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" ))) (de ensure-in-break () (if (> BreakLevel* 0) T (write-prompt "Not in a break loop!") (Ding) NIL )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Query functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-yesp (message) (cond ((and *NMODE-RUNNING (=> nmode-terminal raw-mode)) (nmode-yes-or-no? message)) (t (pre-nmode-yesp message)) )) (de nmode-yes-or-no? (message) (let ((response (prompt-for-string message NIL))) (while T (cond ((string-equal response "Yes") (exit T)) ((string-equal response "No") (exit NIL)) (t (Ding) (write-prompt "Please answer YES or NO.") (sleep-until-timeout-or-input 60) (setf response (prompt-for-string message NIL)) ))))) (de nmode-y-or-n? (message) (write-message message) (nmode-set-immediate-prompt "Y or N: ") (let ((answer (while T (let ((ch (char-upcase (input-direct-terminal-character)))) (when (= ch #/Y) (nmode-complete-prompt "Y") (exit T)) (when (= ch #/N) (nmode-complete-prompt "N") (exit NIL)) (when (= ch #\BELL) (exit 'ABORT)) (Ding) )))) (set-prompt "") (write-message "") (if (eq answer 'ABORT) (throw 'ABORT NIL)) answer )) |
Added psl-1983/3-1/nmode/nmode-ex-20.sl version [b5cf6d08b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-20.SL - DEC-20 NMODE Stuff (intended for DEC-20 Version Only) % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 5 April 1983 % % 15-Jun-83 Robert Kessler % Add ambassador, teleray and VT100 terminal support. % 5-Apr-83 Alan Snyder % Add load-nmode and set-terminal stuff to make it more like other systems. % 15-Mar-83 Alan Snyder % Add nmode-print-device. % 25-Jan-83 Alan Snyder % Add version of actualize-file-name that ensures that transiently-created % file has delete access. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load useful common fast-strings)) % External variables used here: (fluid '(nmode-file-list nmode-source-prefix nmode-binary-prefix *usermode *redefmsg doc-text-file reference-text-file nmode-print-device nmode-terminal )) % Global variables defined here: (fluid '(terminal-type)) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "pn:")) (if (or (unboundp 'nmode-binary-prefix) (null nmode-binary-prefix)) (setf nmode-binary-prefix "pnb:")) (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overridden by the user before NMODE is initialized. (nmode-load-required-modules) (nmode-load-all) (setf nmode-print-device "LPT:") % Set up "pointers" to online documentation. (setf doc-text-file "PS:<PSL.DOC.NMODE>FRAMES.LPT") (setf reference-text-file "PS:<PSL.DOC.NMODE>COSTLY.SL") % Get our version of the prompt line with date/time (load exec) (faslin "pnb:window-label-rewrite.b") (let ((*usermode nil) (*redefmsg nil)) (copyd 'actualize-file-name 'dec20-actualize-file-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-set-terminal () (setf terminal-type (jsys2 65 0 0 0 (const jsgttyp))) (selectq terminal-type (6 % HP264X (ensure-terminal-type 'hp2648a) ) (7 % Teleray (ensure-terminal-type 'teleray) ) (15 % VT52 (ensure-terminal-type 'vt52x) ) (16 % VT100 (ensure-terminal-type 'vt100) ) (19 % ambassador (ensure-terminal-type 'ambassador) ) (21 % HP2621 (ensure-terminal-type 'hp2648a) ) (t (or nmode-terminal (ensure-terminal-type 'hp2648a)) ) )) % These functions defined for compatibility: (de ambassador () (ensure-terminal-type 'ambassador)) (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) (de teleray () (ensure-terminal-type 'teleray)) (de vt100 () (ensure-terminal-type 'vt100)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () % Stolen directly from Nancy Kendzierski % Date/time in appropriate format for the network mail header (let ((date-time (MkString 80))) (jsys1 date-time -1 #.(bits 5 7 10 12 13) 0 (const jsODTIM)) (recopystringtonull date-time))) (de dec20-actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output (string-concat file-name ";P777777") % so we can delete it! )) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load objects) (load common) (load useful) (load strings) (load pathnames) (load pathnamex) (load ring-buffer) (load extended-char) (load directory) (load input-stream) (load output-stream) (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load rawio) (load windows) ) (de nmode-fixup-name (s) s) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-binary-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "browser-browser" "buffer-browser" "dired" "doc" )) |
Added psl-1983/3-1/nmode/nmode-init.sl version [3c08efe708].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-INIT.SL - NMODE Initialization % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 11 March 1983 % % 11-Mar-83 Alan Snyder % Buffer-Create-Unselectable -> Create-Unnamed-Buffer. % Create buffer browser. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(lisp-interface-mode input-mode nmode-main-buffer nmode-output-buffer nmode-input-buffer nmode-initialized )) (setf nmode-initialized NIL) (de nmode-initialize () (cond ((not nmode-initialized) (nmode-initialize-extended-input) (nmode-initialize-modes) (nmode-initialize-buffers) % modes must be initialized previously (nmode-initialize-screen-layout) % buffers must be init previously (nmode-initialize-kill-ring) (create-buffer-browser) (enable-nmode-break) (setf nmode-initialized T) ))) (de nmode-initialize-buffers () (if (null nmode-main-buffer) (setf nmode-main-buffer (buffer-create "MAIN" lisp-interface-mode))) (if (null nmode-output-buffer) (setf nmode-output-buffer (buffer-create "OUTPUT" lisp-interface-mode))) (if (null nmode-input-buffer) (setf nmode-input-buffer (create-unnamed-buffer input-mode))) ) |
Added psl-1983/3-1/nmode/nmode-parsing.sl version [71e3c6ee46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-Parsing.SL - NMODE parsing primitives % [This file used to be Parsing-Functions.SL] % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % Revised: 6 January 1983 % % This file defines Macros! Load it at compile-time! % % This file defines the basic primitives used by NMODE functions to analyze % source code. See the document NMODE-PARSING.TXT for a description of the % parsing strategy. % % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings fast-vectors)) (BothTimes (load nmode-attributes)) % Global Variables: (fluid '(nmode-current-parser)) (setf nmode-current-parser 'lisp-parse-line) % Internal Static Variables: (fluid '(nmode-parsed-line nmode-parsed-line-info )) (setf nmode-parsed-line NIL) (setf nmode-parsed-line-info (make-vector 200 0)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % These are the exported functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro test-current-attributes attributes-list `(test-current-attributes-bits (test-attributes ,@attributes-list)) ) (defmacro move-forward-to attributes-list `(move-forward-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-backward-to attributes-list `(move-backward-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-forward-within-line-to attributes-list `(move-forward-within-line-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-backward-within-line-to attributes-list `(move-backward-within-line-to-bits (test-attributes ,@attributes-list)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % These are internal, non-primitive functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de test-current-attributes-bits (bits) (let* ((x (current-attributes)) (match-bits (& x bits)) ) (and (~= 0 (& match-bits (const POSITION-BITS))) (~= 0 (& match-bits (const TYPE-BITS))) ))) (de move-forward-to-bits (bits) (move-forward-to-bits-until bits #'at-buffer-end?)) (de move-backward-to-bits (bits) (move-backward-to-bits-until bits #'at-buffer-start?)) (de move-forward-within-line-to-bits (bits) (move-forward-to-bits-until bits #'at-line-end?)) (de move-backward-within-line-to-bits (bits) (move-backward-to-bits-until bits #'at-line-start?)) (de move-forward-to-bits-until (bits stop-predicate) (let ((old-pos (buffer-get-position))) (while T (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL)) (when (test-current-attributes-bits bits) (exit (decode-character-attribute-type (current-attributes)))) (move-forward-character) ))) (de move-backward-to-bits-until (bits stop-predicate) (let ((old-pos (buffer-get-position))) (while T (when (test-current-attributes-bits bits) (exit (decode-character-attribute-type (current-attributes)))) (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL)) (move-backward-character) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % The (internal) primitive parsing function: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-attributes () (let* ((str (current-line)) (len (string-length str)) (pos (current-char-pos)) ) (if (>= pos len) (attributes FIRST LAST BLANKS) % Otherwise (when (not (eq nmode-parsed-line str)) (setf nmode-parsed-line str) (if (< (vector-size nmode-parsed-line-info) len) (setf nmode-parsed-line-info (make-vector len 0))) (apply nmode-current-parser (list nmode-parsed-line nmode-parsed-line-info)) ) (vector-fetch nmode-parsed-line-info pos) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Testing code: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char)) (de show-current-character () (write-prompt (bldmsg "%l" (unparse-character-attributes (current-attributes))))) %(set-text-command (x-char C-=) 'show-current-character) |
Added psl-1983/3-1/nmode/nmode-vax.lap version [1dcf9ed429].
> > | 1 2 | (faslin "$pnb/nmode-vax.b") (load-nmode) |
Added psl-1983/3-1/nmode/nmode-vax.sl version [baf48d3635].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-VAX.SL Vax-Unix specific loading and modifications for NMODE. % % Author: William F. Galway % University of Utah % Date: 28 March 1983 % Revised: 5 April 1983 % % 7-Apr-83 Nancy Kendzierski % Added knowledge about hp and 2641 terminal types to table. % 5-Apr-83 Alan Snyder % Revised to be more like the 9836 code: add load-nmode stuff and set-terminal % stuff. % % This file contains functions to load NMODE and make some final changes to % customize things for Vax-Unix. Some modules for NMODE are unimplemented on % the Vax, thus not loaded for now; these are commented out with a "%*". % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load useful common fast-strings)) % External variables used here: (fluid '(nmode-file-list nmode-source-prefix nmode-binary-prefix *usermode *redefmsg doc-text-file reference-text-file nmode-terminal )) % Global variables defined here: (fluid '( % Association list of (Unix-TERM-name . NMODE-terminal-name). The % Unix-TERM-name is a string, the NMODE-terminal-name is an identifier. term-name-table )) (setf term-name-table '( % ("t10" . teleray) % ("aaa" . ambassador) ("hp" . hp2648a) ("2621" . hp2648a) ("vt52" . vt52x))) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "$pn/")) (if (or (unboundp 'nmode-binary-prefix) (null nmode-binary-prefix)) (setf nmode-binary-prefix "$pnb/")) (if (funboundp 'pre-nmode-main) (copyd 'pre-nmode-main 'main)) (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overrided by the user before nmode is initialized. (nmode-load-required-modules) (nmode-load-all) % Set up "pointers" to online documentation. (setf doc-text-file "$pn/ONLINE-DOCS/frames.lpt") (setf reference-text-file "$pn/ONLINE-DOCS/costly.sl") (let ((*usermode nil) (*redefmsg nil)) (copyd 'actualize-file-name 'vax-actualize-file-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-set-terminal () % Needs better error handling? (let* ( % Get terminal name from the system. (system-term-type (GetEnv "TERM")) % Map to NMODE name. (table-entry (assoc system-term-type term-name-table)) (terminal-type (cond (table-entry (cdr table-entry)) (T (StdError (BldMsg "%r is unsupported terminal type" system-term-type)) )))) (ensure-terminal-type terminal-type))) % These functions defined for compatibility: (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de vax-actualize-file-name (file-name) (cond % If the file-name starts with a character that's "special" to % Unix, just pass it on through. ((MemQ (string-fetch file-name 0) '(#// #/~ #/$)) file-name) (T % Otherwise, tack the current working directory onto the front % of the name. (string-concat (pwd) file-name)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load objects) (load common) (load useful) (load strings) (load pathnames) (load pathnamex) (load ring-buffer) (load extended-char) %* (load directory) (load input-stream) (load output-stream) %* (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load windows) (load rawio) ) (de nmode-fixup-name (s) s) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-binary-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "browser-browser" "buffer-browser" %* "dired" "doc" )) |
Added psl-1983/3-1/nmode/nmode.lap version [baf51cf8b4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (load directory) (load extended-char) (load input-stream) (load objects) (load output-stream) (load nmode-parsing) (load pathnames) (load pathnamex) (load processor-time) (load rawio) (load ring-buffer) (load vector-fix) % for TruncateVector (load windows) (faslin "pn:browser.b") (faslin "pn:browser-support.b") (faslin "pn:buffer.b") (faslin "pn:buffer-io.b") (faslin "pn:buffer-position.b") (faslin "pn:buffer-window.b") (faslin "pn:buffers.b") (faslin "pn:case-commands.b") (faslin "pn:command-input.b") (faslin "pn:commands.b") (faslin "pn:defun-commands.b") (faslin "pn:dispatch.b") (faslin "pn:extended-input.b") (faslin "pn:fileio.b") (faslin "pn:incr.b") (faslin "pn:indent-commands.b") (faslin "pn:kill-commands.b") (faslin "pn:lisp-commands.b") (faslin "pn:lisp-indenting.b") (faslin "pn:lisp-interface.b") (faslin "pn:lisp-parser.b") (faslin "pn:m-x.b") (faslin "pn:m-xcmd.b") (faslin "pn:modes.b") (faslin "pn:mode-defs.b") (faslin "pn:move-commands.b") (faslin "pn:nmode-break.b") (faslin "pn:nmode-init.b") (faslin "pn:prompting.b") (faslin "pn:query-replace.b") (faslin "pn:reader.b") (faslin "pn:rec.b") (faslin "pn:screen-layout.b") (faslin "pn:search.b") (faslin "pn:set-terminal.b") % compiled from set-terminal-20, etc. (faslin "pn:softkeys.b") (faslin "pn:structure-functions.b") (faslin "pn:terminal-input.b") (faslin "pn:text-buffer.b") (faslin "pn:text-commands.b") (faslin "pn:window.b") (faslin "pn:window-label.b") % This redefines things: (faslin "pn:nmode-20.b") % Subsystems: load last! (they define modes at load-time) (faslin "pn:autofill.b") (faslin "pn:browser-browser.b") (faslin "pn:buffer-browser.b") (faslin "pn:dired.b") (faslin "pn:doc.b") |
Added psl-1983/3-1/nmode/process.build version [6af2ac57ca].
> > > > > | 1 2 3 4 5 | (faslout "process") (dskin "process.sl") (dskin "wait.sl") (faslend) |
Added psl-1983/3-1/nmode/process.sl version [3585e1b8a1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROCESS.SL % Routines to support generalized inferior processes in TOPS20 PSL. % Much of the code is based on PHOTO.FAI % % Mark R. Swanson % University of Utah % June 17, 1983 % (load objects monsym jsys) (fluid '(current-process process-list nmode-selectable-processes)) (setf current-process nil) (setf process-list nil) (setf nmode-selectable-processes ()) (de create-process-stream (name b) (let ((process (make-instance 'process-stream 'exe-file-name name 'out-buf b))) process)) (defflavor process-stream ( (sys-proc-id 0) ttyjfn ptyjfn (exe-jfn -1) exe-file-name out-buf output-end mode-word string-in status ) () (initable-instance-variables exe-file-name out-buf) (gettable-instance-variables ttyjfn out-buf mode-word status exe-file-name sys-proc-id) ) (defmethod (process-stream init) () (=> self getjfn) % get jfn for executable (=> self getpty) % get a jfn for pty (=> self efork) % create an inferior fork and attach it to PTY (=> self setpty) % set up pty parameters, links, etc. (=> self runfrk) % start up the fork ) (defmethod (process-stream write-to-process) (string) % Send the given string to the inferior process thru the PTY, but do not % block if buffer is full (for whatever reason). Also, only dole out the % string in bite-size pieces. % 91 seems to be a magic number, as far as tty buffers go. (let ((str-len (add1 (size string))) (i 0) cur-sout-len) (while (and (timeout-wait 'accepting-output? (list ttyjfn) 60) (> str-len 0)) (setf cur-sout-len (min 92 str-len)) (jsys0 ptyjfn (sub string i (sub1 cur-sout-len)) cur-sout-len 0 (const jsSOUT)) (setf i (+ i cur-sout-len)) (setf str-len (- str-len cur-sout-len))) (if (~= str-len 0) (write-message "Current process not accepting input")) )) (de user-typed-input? () % Return T if our user has typed something, NIL if not (~= (xsibe 8#100) 0)) (de accepting-output? (jfn) % See if PTY buffer is already filled to capacity (<= (xsibe jfn) 92)) % 8#91 is assumed not to exceed buffer capacity % of a PTY, but be enough to force process wakeup % The following are provided to avoid unwanted error handling on the +1 return (lap '((!*entry xsibe expr 1) (jsys (const jssibe)) (jfcl) (!*move (reg 2) (reg 1)) (!*exit 0))) (lap '((!*entry xsobe expr 1) (jsys (const jssobe)) (jfcl) (!*move (reg 2) (reg 1)) (!*exit 0))) (defmethod (process-stream read-into-buffer) () % Reads output of inferior process into associated buffer, if any output % is to be had; waits only a *small* finite amount of time for input to % appear. (let ((chars-read nil) (input-recvd nil)) (=> out-buf move-to-buffer-end) % New output should appear at buffer end (while (and % Keep reading until no more output from (not (user-typed-input?)) % process or user typein. (setf chars-read (=> self read-from-process))) (setf input-recvd t) % So we will know to refresh window. (let ((string string-in) (i 0) char) (while (< i chars-read) (if (~= (setf char (string-fetch string i)) #\cr) % ignore CR's (=> out-buf insert-character char)) (setf i (+ i 1)) ))) (setf output-end (=> out-buf position)) (if input-recvd (=> self window-refresh)) % refresh window when all done )) (defmethod (process-stream read-from-process) () % READ-FROM-PROCESS reads as many chars as are waiting to be read into % string-in and returns number read, or NIL if there were none. Will % not block if no output is available, though it will wait a short % time for some to arrive. (let ((chars-to-read (timeout-wait 'output-waiting? (list ttyjfn) 20)) ) (if (null chars-to-read) (exit nil)) (setf string-in (mkstring (- chars-to-read 1) 0)) (- chars-to-read (jsys3 ptyjfn string-in chars-to-read 0 (const jsSIN))) )) (de output-waiting? (jfn) % OUTPUT-WAITING? checks inferior process' tty output buffer to see if it's % empty. Returns NIL if it is empty, else the count of characters in buffer. (let ((n (xsobe jfn))) (if (= n 0) nil n))) (defmethod (process-stream getjfn) () % GETJFN -- get a jfn for executable file specified by exe-file-name (setf exe-jfn (jsys1 (bits 2 17) exe-file-name 0 0 (const jsGTJFN))) ) (defmethod (process-stream efork) () % EFORK -- create an inferior fork and get a copy of the desired file into it (setf sys-proc-id (jsys1 (bits 1) 0 0 0 (const jsCFORK))) % create fork (jsys0 sys-proc-id 0 0 0 (const jsFFORK)) % freeze it (jsys0 (xword sys-proc-id exe-jfn) 0 0 0 (const jsGET)) % get the executable into it (jsys0 sys-proc-id % don't allow LOGOff or CTRL-C trap (xword 8#200001 (lowhalfword (jsys2 sys-proc-id 0 0 0 (const jsRPCAP)))) 0 0 (const jsEPCAP)) (jsys0 sys-proc-id (xword ttyjfn ttyjfn) 0 0 (const jsSPJFN)) ) (defmethod (process-stream runfrk) () % RUNFRK -- run something in an inferior fork % returns with ERRFLG T if the fork terminated abnormally (jsys0 sys-proc-id 0 0 0 (const jsSFRKV)) (jsys0 sys-proc-id 0 0 0 (const jsRFORK)) (setf status (jsys1 sys-proc-id 0 0 0 (const jsRFSTS))) % (setf error-flag (not (eqn 2 (land (loworderhalf status) 2)))) ) % (defmethod (process-stream proc-sts) () % (setf status (jsys1 sys-proc-id 0 0 0 (const jsRFSTS))) % (setf mode-word (jsys2 ttyjfn 0 0 0 (const jsRFMOD))) % ) %(defmethod (process-stream running) () % (not (eqn (land (highhalfword status) 8#400000) 8#400000))) %(defmethod (process-stream io-wait) () % (eqn (land (highhalfword status) 8#377777) 1)) (defmethod (process-stream getpty) () % GETPTY - get a jfn on a pty and also its TTY number (let ((curpty (get-1-pty))) (cond ((eqn curpty -1) (ErrorPrintF "There are too many people using PTY's now; try again later."))) (setf ptyjfn (openpty (ptynum curpty))) (setf ttyjfn (openpty (ttynum curpty))) )) (defmethod (process-stream intrpt-process) () % essentially the same as ^C to the inferior (jsys0 sys-proc-id (bits 1) 0 0 (const jsIIC)) ) (defmethod (process-stream close-pty) () (jsys0 ptyjfn 0 0 0 (const jsCLOSF)) (jsys0 ttyjfn 0 0 0 (const jsCLOSF)) (setf ptyjfn 0) (setf ttyjfn 0) ) (defmethod (process-stream kill) () % kil the fork, close its PTY's, reset fork handle (jsys0 sys-proc-id 0 0 0 (const jsKfork)) (setf sys-proc-id 0) (=> self close-pty) ) (de get-1-pty () % find an available PTY; note that TOPS20 will tell us that a PTY is available % to us if we have it in use already--ensure that we get a new one. (for* (with dev-characteristics pty-owning-job (numpty (HighHalfWord (jsys1 26 0 0 0 (const JsGETAB)))) (my-job-num (jsys3 -1 (xword -1 3) 0 0 (const jsGETJI)))) (from curpty 0 numpty 1) (finally (return -1)) % in case none is found (do (setf dev-characteristics (jsys2 (xword 8#600013 curpty) 0 0 0 (const JsDVCHR))) (setf pty-owning-job (highhalfword (jsys3 (xword 8#600013 curpty) 0 0 0 (const JsDVCHR)))) (cond ((and (eqn 8#010000 % is it available? (land (highhalfword dev-characteristics) 8#010000)) % dv%av (not (eqn my-job-num % does it already belong to us? pty-owning-job))) (return curpty)) ) ))) (de openpty (ptynum) % (let ((devnam (Mkstring 10)) ptyjfn) (jsys0 devnam % turn Device descriptor into a name-string (jsys1 ptynum 0 0 0 (const JsDVCHR)) 0 0 (const JsDEVST)) (setf devnam (recopystringtonull devnam)) % truncate it at NULL (setf ptyjfn % make it into a TOPS-20 dev name (jsys1 (Xword 8#001 0) (concat devnam ":") 0 0 (const JsGTJFN))) % gj%sht!gj%acc (jsys0 ptyjfn (Xword 8#70000 8#300000) 0 0 (const JsOPENF)) % 7 bit byte,in-out ptyjfn)) (de ttynum (ptynum) % TTYNUM--given a PTY number, turn it into the device designator of the % associated TTY (plus ptynum (LowHalfWord (jsys1 22 0 0 0 (const JsGETAB))) % 26 is the index of the PTY table 8#400000)) % .ttdes (de ptynum (ptynum) % PTYNUM--given a PTY number, turn it into a PTY device designator (xword 8#600013 ptynum)) (defmethod (process-stream setpty) () % SETPTY-- set up PTY mode (jsys0 ttyjfn 8#525252525252 8#525252525252 0 (const jsSFCOC)) (setf mode-word (jsys2 ttyjfn 0 0 0 (const jsRFMOD))) (jsys0 ttyjfn (land mode-word 8#777777774000) 0 0 (const jsSFMOD)) (jsys0 ttyjfn (land mode-word 8#777777774000) 0 0 (const jsSTPAR)) ) (defmethod (process-stream window-refresh) () (when out-buf (if (and *OutWindow (not (buffer-is-displayed? out-buf))) (nmode-expose-output-buffer out-buf)) (let ((window-list (find-buffer-in-exposed-windows out-buf))) (when window-list (nmode-adjust-output-window (car window-list)) )))) (defmethod (process-stream name) () (=> out-buf name)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de feed-process-from-buffer (terminate-flag) % Causes NMODE to send input to an inferior process from the current buffer. % Output will go to end of the output buffer. Supply a free EOL if the last % line is unterminated. (if (null current-process) (write-message "No process") (if (=> nmode-current-buffer modified?) (make-buffer-terminated)) (let* ((process-output-buffer (=> current-process out-buf)) (old-pos (=> process-output-buffer position)) (input-line (=> nmode-current-buffer current-line)) ) (=> process-output-buffer set-mark-from-point) % Set things up to read from and write to NMODE buffers. (=> current-process write-to-process input-line) (if terminate-flag (=> current-process write-to-process (mkstring 0 #\lf))) (=> nmode-current-buffer move-to-next-line) (=> current-process read-into-buffer) ))) (de create-process-command () (let* ((fn (prompt-for-file-name "Executable file: " "SYSTEM:EXEC.EXE")) (nmode-default-mode process-mode) (b (buffer-create-default (buffer-make-unique-name (filename-to-buffername fn)))) (process (create-process-stream fn b))) (setf nmode-selectable-processes (cons process nmode-selectable-processes)) (setf current-process process) )) (de execute-region-command () % Send region to inferior process; one line at a time. % NOT YET FULLY IMPLEMENTED (set-mark-from-point) % in case the user wants to come back (move-to-start-of-line) (feed-process-from-buffer t) ) (de execute-line-command () % Send current line to inferior process; start at the beginning of the line. (set-mark-from-point) % in case the user wants to come back (move-to-start-of-line) (feed-process-from-buffer t) ) (de execute-unterminated-line-command () % Execute starting at the beginning of the current line, do not send an EOL. (set-mark-from-point) % in case the user wants to come back (move-to-start-of-line) (feed-process-from-buffer nil) ) (de intrpt-process-command () (if (null current-process) (write-message "No process") (=> current-process intrpt-process))) (de kill-process-command () (if current-process (progn (=> current-process kill) (setf current-process (cadr nmode-selectable-processes)) (setf nmode-selectable-processes (cdr nmode-selectable-processes))) (write-message "No process"))) (de send-char-immediate-command () % Send the next character as is, without waiting for a line terminator % Useful for sending control characters, and for talking to programs (such % as DDT, that break on single, non-control characters such as "/" (if current-process (let ((ch (input-direct-terminal-character))) (=> current-process write-to-process (mkstring 0 ch)) (=> current-process read-into-buffer)) (write-message "No process"))) (de execute-from-input-window () (if (null current-process) (write-message "No process") %else (let* ((buf (=> current-process out-buf)) (prompt-string (progn (=> buf move-to-buffer-end) (=> buf current-line)))) (=> current-process write-to-process (prompt-for-process-string prompt-string NIL)) (=> current-process write-to-process (mkstring 0 #\lf)) (=> current-process read-into-buffer)) )) (de cut-line-command () (let ((cur-char-pos (current-char-pos)) (cur-line (current-line))) (update-kill-buffer (cons 1 (vector (sub cur-line cur-char-pos (- (size cur-line) cur-char-pos)))) ))) % A replacement for NMODE-READER-STEP (found in PN:READER.SL); the only % change is to check for output from inferior process(es) (de nmode-reader-step () (cond ((not nmode-timing?) (nmode-refresh) (nmode-gc-check) (nmode-process-output-check) (nmode-read-command) (nmode-execute-current-command) ) (t (nmode-timed-reader-step)) )) (de nmode-process-output-check() % Check for output from the current (if there is one) process; read it if % there is any; the read should not block waiting for further output (cond ((and current-process (output-waiting? (=> current-process ttyjfn))) (=> current-process read-into-buffer))) T ) (de prompt-for-process-string (prompt-string restore-inserts?) % This function is similar to PROMPT-FOR-STRING. (setf nmode-input-special-command-list nil) (if restore-inserts? (self-inserting-command)) (if (> nmode-input-level 0) (throw '$error$ NIL) % else (let ((old-msg nmode-message-string) (old-window nmode-current-window) (nmode-input-level (+ nmode-input-level 1)) % FLUID ) (=> (=> nmode-input-window buffer) reset) (nmode-select-window nmode-input-window) (set-message prompt-string) (set-prompt "") % avoid old prompt popping back up when we're done % Edit the buffer until an "exit" character is typed or the user aborts. (cond ((eq (NMODE-reader T) 'abort) (=> nmode-input-window deexpose) (nmode-select-window old-window) (set-message old-msg) (throw 'abort NIL) )) % Show the user that his input has been accepted. (move-to-start-of-line) (nmode-refresh-one-window nmode-input-window) % Pick up the string that was typed. (let ((return-string (current-line))) % Switch back to old window, etc. (=> nmode-input-window deexpose) (nmode-select-window old-window) % Restore original "message window". (set-message old-msg) return-string )))) (de Process-prefix () (nmode-append-separated-prompt "Process-") (let ((ch (input-terminal-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char C-!\) ch) )) (define-command-prefix 'Process-prefix "Process-") %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Most of what follows really should gpo into MODE-DEFS.SL, if processes become % an accepted part of NMODE (CompileTime (load extended-char)) (fluid '(Process-Mode )) (fluid '(Process-Command-List Process-Mode-Command-List )) (setf Text-Mode (nmode-define-mode "Text" '((nmode-define-commands Text-Command-List) (nmode-define-commands Modifying-Terminal-Command-List) (nmode-define-commands Process-Command-List) (nmode-establish-mode Read-Only-Text-Mode) (nmode-define-normal-self-inserts) ))) (setf Process-Mode (nmode-define-mode "Process" '((nmode-define-commands Process-Command-List) (nmode-define-commands Process-Mode-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf Lisp-Interface-Mode (nmode-define-mode "Lisp" '((nmode-define-commands Rlisp-Command-List) (establish-lisp-parser) (nmode-define-commands Lisp-Command-List) (nmode-define-commands Process-Command-List) (nmode-establish-mode Text-Mode) ))) (de process-mode-command () (buffer-set-mode nmode-current-buffer Process-Mode) ) % Process-Mode-Command-List - commands related to the Process interface (setf Process-Mode-Command-List (list (cons (x-char C-k) 'cut-line-command) (cons (x-char RETURN) 'execute-line-command) )) % Process-Command-List - commands related to the Process interface (setf Process-Command-List (list (cons (x-char C-!\) 'Process-prefix) (cons (x-chars C-!\ C) 'intrpt-process-command) (cons (x-chars C-!\ E) 'execute-line-command) (cons (x-chars C-!\ I) 'execute-from-input-window) (cons (x-chars C-!\ K) 'kill-process-command) (cons (x-chars C-!\ Q) 'send-char-immediate-command) (cons (x-chars C-!\ P) 'process-browser-command) (cons (x-chars C-!\ U) 'execute-unterminated-line-command) )) (setf Basic-Command-List (NConc Basic-Command-List (list (cons (m-x "Create Process") 'create-process-command)))) (setf Text-Command-List (NConc Text-Command-List (list (cons (m-x "Process Mode") 'Process-mode-command)))) |
Added psl-1983/3-1/nmode/prompting.sl version [e6e3c190e5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prompting.SL - NMODE Prompt Line Manager % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 19 August 1982 % Revised: 28 February 1983 % % Adapted from Will Galway's EMODE. % % 28-Feb-83 Alan Snyder % Extend write-prompt to work properly when NMODE is not running. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Use one-window or one-screen refresh. % 29-Dec-82 Alan Snyder % Revised input completion support to run completion characters as commands % rather than terminating and resuming. Added new functions to manipulate the % input buffer. % 22-Dec-82 Jeffrey Soreff % Revised to handle control characters on prompt and message lines. % 21-Dec-82 Alan Snyder % Efficiency improvement: Added declarations for virtual screens and buffer % windows. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-strings numeric-operators)) (on fast-integers) % External variables used: (fluid '(nmode-prompt-screen nmode-message-screen nmode-input-window nmode-current-window *NMODE-RUNNING )) % Global variables defined here: (fluid '(nmode-input-default )) % Internal static variables: (fluid '(nmode-prompt-cursor nmode-message-cursor nmode-message-string nmode-input-level nmode-input-special-command-list )) (setf nmode-prompt-cursor 0) (setf nmode-message-cursor 0) (setf nmode-message-string "") (setf nmode-input-level 0) (setf nmode-input-default NIL) (declare-flavor virtual-screen nmode-prompt-screen nmode-message-screen) (declare-flavor buffer-window nmode-input-window nmode-current-window) (declare-flavor text-buffer input-buffer) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % String input: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-string (prompt-string default-string) % Prompt for a string (terminated by CR or NL). Use default-string if an % empty string is returned (and default-string is non-NIL). The original % message line is restored, but not refreshed. Note: if you attempt to use % this function recursively, it will automatically throw '$ERROR$. The effect % of this action is that in string-input mode, commands that request string % input appear to be undefined. (This assumes that all such commands do % nothing visible before they first request string input.) (prompt-for-string-special prompt-string default-string NIL)) (de prompt-for-string-special (prompt-string default-string command-list) % This function is similar to PROMPT-FOR-STRING, except that it accepts a % command list that specifies a set of additional commands to be defined % while the user is typing at the input window. (if (> nmode-input-level 0) (throw '$error$ NIL) % else (setf nmode-input-special-command-list command-list) (setf nmode-input-default default-string) (let ((old-msg nmode-message-string) (old-window nmode-current-window) (nmode-input-level (+ nmode-input-level 1)) % FLUID ) (if default-string (setf prompt-string (string-concat prompt-string " (Default is: '" default-string "')"))) (=> (=> nmode-input-window buffer) reset) (nmode-select-window nmode-input-window) (set-message prompt-string) (set-prompt "") % avoid old prompt popping back up when we're done % Edit the buffer until an "exit" character is typed or the user aborts. (cond ((eq (NMODE-reader T) 'abort) (=> nmode-input-window deexpose) (nmode-select-window old-window) (set-message old-msg) (throw 'abort NIL) )) % Show the user that his input has been accepted. (move-to-start-of-line) (nmode-refresh-one-window nmode-input-window) % Pick up the string that was typed. (let ((return-string (current-line))) % Switch back to old window, etc. (=> nmode-input-window deexpose) (nmode-select-window old-window) % Restore original "message window". (set-message old-msg) % If an empty string, use default (unless it's NIL). (if (and default-string (equal return-string "")) default-string return-string ))))) (de nmode-substitute-default-input () % If the input buffer is empty and there is a default string, then stuff the % default string into the input buffer. (let ((input-buffer (=> nmode-input-window buffer))) (if (and (=> input-buffer at-buffer-start?) (=> input-buffer at-buffer-end?) nmode-input-default (stringp nmode-input-default) ) (=> input-buffer insert-string nmode-input-default) ))) (de nmode-get-input-string () % Return the contents of the input buffer as a string. If the buffer contains % more than one line, only the current line is returned. (let ((input-buffer (=> nmode-input-window buffer))) (=> input-buffer current-line) )) (de nmode-replace-input-string (s) % Replace the contents of the input buffer with the specified string. (let ((input-buffer (=> nmode-input-window buffer))) (=> input-buffer reset) (=> input-buffer insert-string s) )) (de nmode-terminate-input () % A command bound to this function will act to terminate string input. (exit-nmode-reader) ) (de nmode-yank-default-input () % A command bound to this function will act to insert the default string into % the input buffer. (if nmode-input-default (insert-string nmode-input-default) (Ding) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prompt line functions: % % NOTE: if your intent is to display a prompt string for user input, you should % use a function defined in TERMINAL-INPUT rather than one of these. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de write-prompt (msg) % Write the specified string to the prompt line and refresh the prompt % line. Note: the major windows are not refreshed. (cond (*NMODE-RUNNING (set-prompt msg) (nmode-refresh-virtual-screen nmode-prompt-screen) ) (t (printf "%w%n" msg) ))) (de set-prompt (msg) % Write the specified string to the prompt window, but do not refresh. (setf nmode-prompt-cursor 0) (=> nmode-prompt-screen clear) (prompt-append-string msg) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Message line functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de write-message (msg) % Display a string to the message window and refresh the message window. % Note: the major windows are not refreshed. % Return the previous message string. (prog1 (set-message msg) (nmode-refresh-virtual-screen nmode-message-screen) )) (de rewrite-message () % Rewrite the existing message (used when the default enhancement changes). (set-message nmode-message-string) ) (de set-message (msg) % Display a string in the "message" window, do not refresh. % Message will not appear until a refresh is done. % Return the previous message string. (let ((old-message nmode-message-string)) (setf nmode-message-string msg) (setf nmode-message-cursor 0) (=> nmode-message-screen clear) (message-append-string msg) old-message )) (de reset-message () % Clear the "message" window, but do not refresh. (setf nmode-message-string "") (setf nmode-message-cursor 0) (=> nmode-message-screen clear) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-append-string (s) (for (from i 0 (string-upper-bound s)) (do (prompt-append-character (string-fetch s i))))) (de prompt-append-character (ch) (cond ((or (< ch #\space) (= ch #\rubout)) % Control Characters (=> nmode-prompt-screen write #/^ 0 nmode-prompt-cursor) (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1)) (=> nmode-prompt-screen write (^ ch 8#100) 0 nmode-prompt-cursor) (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1))) (t (=> nmode-prompt-screen write ch 0 nmode-prompt-cursor) % Normal Char (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1))))) (de message-append-string (s) (for (from i 0 (string-upper-bound s)) (do (message-append-character (string-fetch s i))))) (de message-append-character (ch) (cond ((or (< ch #\space) (= ch #\rubout)) % Control Characters (=> nmode-message-screen write #/^ 0 nmode-message-cursor) (setf nmode-message-cursor (+ nmode-message-cursor 1)) (=> nmode-message-screen write (^ ch 8#100) 0 nmode-message-cursor) (setf nmode-message-cursor (+ nmode-message-cursor 1))) (t (=> nmode-message-screen write ch 0 nmode-message-cursor) % Normal Char (setf nmode-message-cursor (+ nmode-message-cursor 1))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-prompt-screen nmode-message-screen) (undeclare-flavor nmode-input-window nmode-current-window) (undeclare-flavor input-buffer) |
Added psl-1983/3-1/nmode/query-replace.sl version [da81804f19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % QUERY-REPLACE.SL - Query/Replace command % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Define backspace to be a synonym for rubout. Terminate when a non-command % character is read and push back the character (like EMACS). % 9-Feb-83 Alan Snyder % Must now refresh since write-message no longer does. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int fast-strings)) % Externals used here: (fluid '(last-search-string nmode-current-buffer)) % Internal static variables: (fluid '(query-replace-message query-replace-help query-replace-pause-help)) (setf query-replace-message "Query-Replace") (setf query-replace-help (string-concat query-replace-message " SPACE:yes RUBOUT:no ESC:exit .:yes&exit ,:yes&show !:do all ^:back" )) (setf query-replace-pause-help (string-concat query-replace-message " SPACE:go on ESC:exit !:do all ^:back" )) (de replace-string-command () (let* ((pattern (setf last-search-string (prompt-for-string "Replace string: " last-search-string))) (replacement (prompt-for-string "Replace string with: " NIL)) (count 0) (old-pos (buffer-get-position)) ) (while (buffer-search pattern 1) (do-string-replacement pattern replacement) (setf count (+ count 1)) ) (buffer-set-position old-pos) (write-prompt (BldMsg "Number of replacements: %d" count)) )) (de query-replace-command () (let* ((ask t) ch pattern replacement (pausing nil) (ring-buffer (ring-buffer-create 16)) ) (setf pattern (setf last-search-string (prompt-for-string "Query Replace (string to replace): " last-search-string ))) (setf replacement (prompt-for-string "Replace string with: " NIL)) (set-message query-replace-message) (while (or pausing (buffer-search pattern 1)) (if ask (progn (cond (pausing (nmode-set-immediate-prompt "Command? ") ) (t (ring-buffer-push ring-buffer (buffer-get-position)) (nmode-set-immediate-prompt "Replace? ") )) (nmode-refresh) (setf ch (input-terminal-character)) (write-prompt "") ) (setf ch (x-char space)) % if not asking ) (if pausing (selectq ch ((#.(x-char space) #.(x-char rubout) #.(x-char backspace) #.(x-char !,)) (write-message query-replace-message) (setf pausing nil)) (#.(x-char !!) (setf ask nil) (setf pausing nil)) ((#.(x-char escape) #.(x-char !.)) (exit)) (#.(x-char C-L) (nmode-full-refresh)) (#.(x-char ^) (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer))) (#.(x-char ?) (write-message query-replace-pause-help) (next)) (t (push-back-input-character ch) (exit)) ) (selectq ch (#.(x-char space) (do-string-replacement pattern replacement)) (#.(x-char !,) (do-string-replacement pattern replacement) (write-message query-replace-message) (setf pausing t)) ((#.(x-char rubout) #.(x-char backspace)) (advance-over-string pattern)) (#.(x-char !!) (do-string-replacement pattern replacement) (setf ask nil)) (#.(x-char !.) (do-string-replacement pattern replacement) (exit)) (#.(x-char ?) (write-message query-replace-help) (next)) (#.(x-char escape) (exit)) (#.(x-char C-L) (nmode-full-refresh)) (#.(x-char ^) (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer)) (setf pausing t)) (t (push-back-input-character ch) (exit)) ) ) ) (reset-message) (write-prompt "Query Replace Done.") )) (de do-string-replacement (pattern replacement) % Both PATTERN and REPLACEMENT must be single line strings. PATTERN is % assumed to be in the current buffer beginning at POINT. It is deleted and % replaced with REPLACEMENT. POINT is left pointing just past the inserted % text. (let ((old-pos (buffer-get-position))) (advance-over-string pattern) (extract-region T old-pos (buffer-get-position)) (insert-string replacement) )) (de advance-over-string (pattern) % PATTERN must be a single line string. PATTERN is assumed to be in the % current buffer beginning at POINT. POINT is advanced past PATTERN. (let ((pattern-length (string-length pattern))) (set-char-pos (+ (current-char-pos) pattern-length)) )) |
Added psl-1983/3-1/nmode/reader.sl version [3262adc69b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Reader.SL - NMODE Command Reader % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 3-Dec-82 Alan Snyder % GC calls cleanup-buffers before reclaiming. % 21-Dec-82 Alan Snyder % Use generic arithmetic on processor times (overflowed on 9836). % Add declaration for NMODE-TIMER-OUTPUT-STREAM. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int pathnames)) % External variables used here: (fluid '(nmode-allow-refresh-breakout)) % Global variables defined here: (fluid '( nmode-command-argument % Numeric C-U argument (default: 1) nmode-command-argument-given % T if C-U used for this command nmode-command-number-given % T if an explicit number given nmode-previous-command-killed % T if previous command KILLED text nmode-current-command % Current command (char or list) nmode-previous-command % Previous command (char or list) nmode-current-command-function % Function for current command nmode-previous-command-function% Function for previous command nmode-autoarg-mode % T => digits start command argument nmode-temporary-autoarg % T while reading command argument nmode-command-killed % Commands set this if they KILL text nmode-command-set-argument % Commands like C-U set this nmode-reader-exit-flag % Internal flag: causes reader to exit nmode-gc-check-level % number of free words causing GC nmode-timing? % T => time command execution nmode-display-times? % T => display times after each command nmode-timer-output-stream % optional stream to write times to % The following variables are set when timing is on: nmode-timed-step-count % number of reader steps timed nmode-refresh-time % time used for last refresh nmode-read-time % time used for last read command nmode-command-execution-time % time to execute last command nmode-total-refresh-time % sum of nmode-refresh-time nmode-total-read-time % sum of nmode-read-time nmode-total-command-execution-time% sum of nmode-command-execution-time nmode-gc-start-count % GCKnt when timing starts nmode-gc-reported-count % GCKnt when last reported nmode-total-cons-count % total words allocated (except GC) )) (setf nmode-timing? NIL) (setf nmode-display-times? NIL) (declare-flavor output-stream nmode-timer-output-stream) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-exit-on-abort)) (de nmode-reader (nmode-exit-on-abort) % Execute refresh/read/dispatch loop. The loop can terminate in the following % ways: (1) A command can cause the reader to exit by either calling % EXIT-NMODE-READER or by throwing 'EXIT-NMODE. In this case, the reader % terminates and returns NIL. (2) A command can throw 'ABORT. If % NMODE-EXIT-ON-ABORT is non-NIL, then the reader will terminate and return % 'ABORT; otherwise, it will ring the bell and continue. (3) A command can % throw '$BREAK$ or 'RESET; this throw is relayed. Other errors and throws % within a command are caught, messages are printed, and execution resumes. (let* ((nmode-reader-exit-flag NIL) % FLUID variable (nmode-previous-command-killed NIL) % FLUID variable (nmode-command-killed NIL) % FLUID variable (nmode-command-argument 1) % FLUID variable (nmode-command-argument-given NIL) % FLUID variable (nmode-command-number-given NIL) % FLUID variable (nmode-current-command NIL) % FLUID variable (nmode-previous-command NIL) % FLUID variable (nmode-current-command-function NIL) % FLUID variable (nmode-previous-command-function NIL) % FLUID variable (nmode-command-set-argument NIL) % FLUID variable (nmode-timing? NIL) % FLUID variable (*MsgP T) % FLUID variable (*BackTrace T) % FLUID variable ) (while (not nmode-reader-exit-flag) (catch-all #'(lambda (tag result) (cond ((eq tag 'abort) (if nmode-exit-on-abort (exit 'abort) (Ding))) ((or (eq tag '$Break$) (eq tag 'RESET)) (nmode-select-buffer-channel) (throw tag NIL)) ((eq tag '$error$) (Ding)) ((eq tag 'exit-nmode) (exit NIL)) (t (Printf "*****Unhandled THROW of %p" tag) (Ding)) )) (nmode-reader-step) )))) (de nmode-reader-step () (cond ((not nmode-timing?) (nmode-refresh) (nmode-gc-check) (nmode-read-command) (nmode-execute-current-command) ) (t (nmode-timed-reader-step)) )) (de nmode-read-command () % Read one command and set the appropriate global variables. (when (not nmode-command-set-argument) % starting a new command (setf nmode-previous-command-killed nmode-command-killed) (setf nmode-previous-command nmode-current-command) (setf nmode-previous-command-function nmode-current-command-function) (setf nmode-command-argument 1) (setf nmode-command-argument-given NIL) (setf nmode-command-number-given NIL) (setf nmode-command-killed NIL) (setf nmode-temporary-autoarg NIL) (nmode-set-delayed-prompt "") ) (setf nmode-current-command (input-command)) (setf nmode-current-command-function (dispatch-table-lookup nmode-current-command)) ) (de nmode-execute-current-command () (setf nmode-command-set-argument NIL) (if nmode-current-command-function (apply nmode-current-command-function NIL) (nmode-undefined-command nmode-current-command) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Timing Support %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de start-timing-command () (let ((fn (prompt-for-file-name "Timing output to file:" (namestring (make-pathname 'name "timing" 'type "txt")) ))) (cond ((not (setf nmode-timer-output-stream (attempt-to-open-output fn))) (write-prompt "Unable to open file.") (Ding) ) (t (reclaim) (nmode-start-timing)) ))) (de stop-timing-command () (cond (nmode-timing? (nmode-stop-timing) (if nmode-timer-output-stream (=> nmode-timer-output-stream close)) (setf nmode-timer-output-stream nil) ))) (de nmode-start-timing () (setf nmode-timing? T) (setf nmode-total-refresh-time 0) (setf nmode-total-read-time 0) (setf nmode-total-command-execution-time 0) (setf nmode-timed-step-count 0) (setf nmode-gc-start-count GCknt*) (setf nmode-gc-reported-count nmode-gc-start-count) (setf nmode-total-cons-count 0) ) (de nmode-stop-timing () (cond (nmode-timing? (setf nmode-timing? NIL) (nmode-timing-message (BldMsg "Total times: Refresh=%d Read=%d Execute=%d Cons=%d #GC=%d" nmode-total-refresh-time nmode-total-read-time nmode-total-command-execution-time nmode-total-cons-count (- GCknt* nmode-gc-start-count) )) (nmode-timing-message (BldMsg "Number of reader steps: %d" nmode-timed-step-count)) (if (> nmode-timed-step-count 0) (nmode-timing-message (BldMsg "Averages: Refresh=%d Read=%d Execute=%d Cons=%d" (/ nmode-total-refresh-time nmode-timed-step-count) (/ nmode-total-read-time nmode-timed-step-count) (/ nmode-total-command-execution-time nmode-timed-step-count) (/ nmode-total-cons-count nmode-timed-step-count) )))))) (de nmode-timed-reader-step () (let ((heapx (GtHeap NIL)) gc-happened ) (nmode-timed-refresh) (nmode-gc-check) (nmode-timed-read-command) (nmode-timed-execute-current-command) (setf heapx (- heapx (GtHeap NIL))) (setf gc-happened (> GCknt* nmode-gc-reported-count)) (setf nmode-gc-reported-count GCknt*) (cond ((not gc-happened) (setf nmode-timed-step-count (+ nmode-timed-step-count 1)) (setf nmode-total-refresh-time (+ nmode-total-refresh-time nmode-refresh-time)) (setf nmode-total-read-time (+ nmode-total-read-time nmode-read-time)) (setf nmode-total-command-execution-time (+ nmode-total-command-execution-time nmode-command-execution-time)) (setf nmode-total-cons-count (+ nmode-total-cons-count heapx)) )) (nmode-timing-message (BldMsg "%w Refresh=%d Read=%d Execute=%d %w" (string-pad-left (command-name nmode-current-command) 20) nmode-refresh-time nmode-read-time nmode-command-execution-time (if gc-happened (BldMsg "#GC=%d" nmode-gc-reported-count) (BldMsg "Cons=%d" heapx) ) )))) (de nmode-timed-refresh () (let ((ptime (processor-time))) (nmode-refresh) (setf nmode-refresh-time (difference (processor-time) ptime)) )) (de nmode-timed-read-command () (let ((ptime (processor-time))) (nmode-read-command) (setf nmode-read-time (difference (processor-time) ptime)) )) (de nmode-timed-execute-current-command () (let ((ptime (processor-time))) (nmode-execute-current-command) (setf nmode-command-execution-time (difference (processor-time) ptime)) )) (de nmode-timing-message (s) (cond (nmode-display-times? (write-message s)) (nmode-timer-output-stream (=> nmode-timer-output-stream putl s)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Garbage Collection %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-gc-check () % Check to see if a garbage collection is needed (because we are low on % space). If so, display a message and invoke the garbage collector. (If a % garbage collection happens "by itself", no message will be displayed.) (if (not nmode-gc-check-level) (setf nmode-gc-check-level 1000)) (when (< (GtHeap NIL) nmode-gc-check-level) (nmode-gc) )) (de nmode-gc () % Perform garbage collection while displaying a message. (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable (write-prompt "Garbage Collecting!") (cleanup-buffers) (reclaim) (write-prompt (BldMsg "Garbage Collection Done: Free Space = %d words" (GtHeap NIL))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Miscellaneous Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de exit-nmode-reader () % Set flag to cause exit from NMODE reader loop. (setf nmode-reader-exit-flag T) ) (de nmode-undefined-command (command) (nmode-error (BldMsg "Undefined command: %w" (command-name command))) ) (de nmode-error (s) (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable (write-prompt s) (Ding) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Numeric Argument Command Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de argument-digit () % This procedure must be attached only to extended characters whose base % characters are digits. (let* ((command nmode-current-command) (base-ch (if (FixP command) (X-base command))) (n (if (and base-ch (digitp base-ch)) (char-digit base-ch))) ) (if (null n) (Ding) (argument-digit-number n) ))) (de negative-argument () (if (not nmode-command-number-given) % make "C-U -" do the right thing (cond ((> nmode-command-argument 0) (setf nmode-command-argument 1)) ((< nmode-command-argument 0) (setf nmode-command-argument -1)) )) (setf nmode-command-argument (- nmode-command-argument)) (setf nmode-command-argument-given T) (setf nmode-command-set-argument T) (nmode-set-delayed-prompt (cond ((= nmode-command-argument 1) "C-U ") ((= nmode-command-argument -1) "C-U -") (t (BldMsg "C-U %d" nmode-command-argument)) ))) (de universal-argument () (setf nmode-command-argument (* nmode-command-argument 4)) (setf nmode-command-argument-given T) (setf nmode-command-set-argument T) (setf nmode-temporary-autoarg T) (cond (nmode-command-number-given (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument)) ) (t (nmode-append-separated-prompt "C-U")) )) (de argument-or-insert-command () % This command interprets digits and leading hyphens as argument % prefix characters if NMODE-AUTOARG-MODE or NMODE-TEMPORARY-AUTOARG % is non-NIL; otherwise, it self-inserts. (let ((base-ch (if (FixP nmode-current-command) (X-base nmode-current-command))) ) (cond ((and (digitp base-ch) (or nmode-temporary-autoarg nmode-autoarg-mode)) (argument-digit (char-digit base-ch))) ((and (= base-ch #/-) (or nmode-temporary-autoarg nmode-autoarg-mode) (not nmode-command-number-given)) (negative-argument)) (t (insert-self-command)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Numeric Argument Support Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de argument-digit-number (n) (cond (nmode-command-number-given % this is not the first digit (setf nmode-command-argument (+ (* nmode-command-argument 10) (if (>= nmode-command-argument 0) n (- n)))) ) (t % this is the first digit (if (> nmode-command-argument 0) (setf nmode-command-argument n) (setf nmode-command-argument (- n)) ))) (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument)) (setf nmode-command-argument-given T) (setf nmode-command-number-given T) (setf nmode-command-set-argument T) ) % Convert from character code to digit. (de char-digit (c) (cond ((digitp c) (difference (char-int c) (char-int #/0))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-timer-output-stream) |
Added psl-1983/3-1/nmode/rec.sl version [c2bf6f8680].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % REC.SL - Recursive Editing Functioons % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 Jan 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load extended-char fast-int objects)) % External variables used here: (fluid '(recurse-mode nmode-current-buffer)) % Global variables defined here: (fluid '(recurse-query recurse-query-answered)) % Recurse-Query will be T if the user leaves a recursive editing level % with a "Y". It will be nil if the user leaves with an "N". In either % of those cases recurse-query-answered will be set to T. If the user % leaves the recursive editing level by some other means then % recurse-query-answered will be NIL. (de recursive-edit-y-or-n (buffer outer-message inner-message) % This function allows a user to make a yes or no decision about % some buffer, either before looking at it with the editor or while % editing within it. Before starting to edit the user is prompted % with the outer message. This function takes care of interpreting a % Y or N prior to editing and of providing a prompt (the outer % message) before editing. The call to recursive-edit takes care of % the prompt during editing and of interpreting a Y or N during % editing. This function returns a boolean value. (prog1 (while t (write-message outer-message) (let ((ch (x-char-upcase (input-extended-character)))) (when (= ch (x-char Y)) (exit T)) (when (= ch (x-char N)) (exit NIL)) (when (= ch (x-char C-R)) (recursive-edit buffer recurse-mode inner-message)) (when recurse-query-answered (exit recurse-query)))) (write-message ""))) (de recursive-edit (new-buffer mode inner-message) % This function triggers the recursive editing loop, switching % buffers, setting the new buffer temporarily into a user selected % mode, and returning the buffer and mode to their old values after % the editing. This function returns a value only through global % variables, particularly recurse-query and recurse-query-answered. (let ((old-buffer nmode-current-buffer) (old-mode (=> new-buffer mode))) (=> new-buffer set-mode mode) (buffer-select new-buffer) (let ((old-message (write-message inner-message))) (setf recurse-query-answered NIL) (nmode-reader NIL) (write-message old-message)) (=> new-buffer set-mode old-mode) (buffer-select old-buffer))) % Note: resets nmode-current-buffer (de affirmative-exit () % Returns T from a recursive editing mode, usually bound to Y. (setf recurse-query T) (setf recurse-query-answered T) (exit-nmode-reader)) (de negative-exit () % Returns NIL from a recursive editing mode, usually bound to N. (setf recurse-query NIL) (setf recurse-query-answered T) (exit-nmode-reader)) |
Added psl-1983/3-1/nmode/screen-layout.sl version [6e843b18e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Screen-Layout.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 19 August 1982 % Revised: 5 April 1983 % % This file contains functions that manage the screen layout for NMODE. % % 5-Apr-83 Alan Snyder % Add system-independent functions from set-terminal files. % Call nmode-set-terminal instead of nmode-default-terminal. % 8-Mar-83 Alan Snyder % Call nmode-new-window-or-buffer (new fcn) when selecting a new window. % 28-Feb-83 Alan Snyder % Reset message line in select-major-window (part of clean up on restart). % Explicitly use fast-integers. % 18-Feb-83 Alan Snyder % Add new function: find-buffer-in-exposed-windows. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Revise handling of refresh breakout to allow refresh-one-window to work. % 31-Jan-83 Alan Snyder % Revise for new interpretation of argument to buffer-window$set-size. % Make input window an unlabeled buffer-window. % 27-Jan-83 Alan Snyder % Added (optional) softkey label screen. % 7-Jan-83 Alan Snyder % Change ENTER-RAW-MODE to not touch the other screen unless we are in % two-screen mode. % 6-Jan-83 Alan Snyder % Change NMODE-SELECT-MAJOR-WINDOW to also deexpose input window. % 30-Dec-82 Alan Snyder % Added two-screen mode. Minor change to NMODE-SELECT-WINDOW to make % things more graceful when using direct writing. % 20-Dec-82 Alan Snyder % Added declarations and made other small changes to improve efficiency by % reducing the amount of run-time method lookup. Fixed efficiency bug in % NMODE-NEW-TERMINAL: it failed to de-expose old screens and windows. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load display-char objects)) (load numeric-operators objects) (on fast-integers) % External variables used here: (fluid '(nmode-command-argument-given nmode-command-argument browser-split-screen )) % Options: (fluid '( nmode-allow-refresh-breakout % Abort refresh if user types something nmode-normal-enhancement % Display enhancement for normal text nmode-inverse-enhancement % Display enhancement for "inverse video" text )) % Global variables defined here: (fluid '( nmode-current-buffer % buffer that commands operate on nmode-current-window % window displaying current buffer nmode-major-window % the user's idea of nmode-current-window nmode-layout-mode % either 1 or 2 nmode-two-screens? % T => each window has its own screen nmode-input-window % window used for string input nmode-message-screen % screen displaying NMODE "message" nmode-prompt-screen % screen displaying NMODE "prompt" nmode-main-buffer % buffer "MAIN" nmode-output-buffer % buffer "OUTPUT" (used for PSL output) nmode-input-buffer % internal buffer used for string input nmode-softkey-label-screen % screen displaying softkey labels (or NIL) nmode-terminal % the terminal object nmode-physical-screen % the physical screen object nmode-screen % the shared screen object nmode-other-terminal % the other terminal object (two-screen mode) nmode-other-physical-screen % the other physical screen object nmode-other-screen % the other shared screen object )) % Internal static variables: (fluid '( nmode-top-window % the top or full major window nmode-bottom-window % the bottom major window full-refresh-needed % next refresh should clear the screen first nmode-breakout-occurred? % last refresh was interrupted nmode-total-lines % total number of screen lines for window(s) nmode-top-lines % number of screen lines for top window nmode-inverse-video? % Display using "inverse video" nmode-blank-screen % blank screen used to clear the display )) (declare-flavor buffer-window nmode-current-window nmode-top-window nmode-bottom-window nmode-input-window) (declare-flavor virtual-screen nmode-blank-screen) (declare-flavor shared-physical-screen nmode-screen nmode-other-screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Initialization Function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-initialize-screen-layout () % This function is called as part of NMODE initialization, which occurs % before NMODE is saved. (setf nmode-allow-refresh-breakout T) (setf nmode-normal-enhancement (dc-make-enhancement-mask)) (setf nmode-inverse-enhancement (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY)) (setf nmode-inverse-video? NIL) (nmode-set-terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions for changing the screen layout: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-1-window () (nmode-expand-top-window) ) (de nmode-expand-top-window () % This function does nothing if already in 1-window mode. % Otherwise: expands the top window to fill the screen; the top window % becomes current. (when (not (= nmode-layout-mode 1)) (nmode-select-window nmode-top-window) (=> nmode-bottom-window deexpose) (setf nmode-layout-mode 1) (nmode-set-window-sizes) )) (de nmode-expand-bottom-window () % This function does nothing if already in 1-window mode. % Otherwise: expands the bottom window to fill the screen; the bottom % window becomes current. (when (not (= nmode-layout-mode 1)) (psetf nmode-top-window nmode-bottom-window nmode-bottom-window nmode-top-window) (nmode-expand-top-window) )) (de nmode-2-windows () % This function does nothing if already in 2-window mode. % Otherwise: shrinks the top window and exposes the bottom window. (cond ((not (= nmode-layout-mode 2)) (setf nmode-layout-mode 2) (nmode-set-window-sizes) ))) (de nmode-set-window-position (p) (selectq p (FULL (nmode-1-window)) (TOP (nmode-2-windows) (nmode-select-window nmode-top-window)) (BOTTOM (nmode-2-windows) (nmode-select-window nmode-bottom-window)) )) (de nmode-exchange-windows () % Exchanges the current window with the other window, which becomes current. % In two window mode, the windows swap physical positions. (let ((w (nmode-other-window))) (psetf nmode-top-window nmode-bottom-window nmode-bottom-window nmode-top-window) (nmode-set-window-sizes) (nmode-select-window w) )) (de nmode-grow-window (n) % Increase (decrease if n<0) the size of the current window by N lines. % Does nothing and returns NIL if not in 2-window mode. (selectq (nmode-window-position) (FULL NIL ) (TOP (setf nmode-top-lines (+ nmode-top-lines n)) (nmode-set-window-sizes) T ) (BOTTOM (setf nmode-top-lines (- nmode-top-lines n)) (nmode-set-window-sizes) T ))) (de nmode-expose-output-buffer (b) % Buffer B is being used as an output channel. It is not currently being % displayed. Cause it to be displayed (in the "other window", if we % are already in 2-window mode, in the bottom window otherwise). (nmode-2-windows) (window-select-buffer (nmode-other-window) b) ) (de nmode-normal-video () % Cause the display to use "normal" video polarity. (when nmode-inverse-video? (setf nmode-inverse-video? NIL) (nmode-establish-video-polarity) )) (de nmode-inverse-video () % Cause the display to use "inverse" video polarity. (when (not nmode-inverse-video?) (setf nmode-inverse-video? T) (nmode-establish-video-polarity) )) (de nmode-invert-video () % Toggle between normal and inverse video. (setf nmode-inverse-video? (not nmode-inverse-video?)) (nmode-establish-video-polarity) ) (de nmode-use-two-screens () % If two screens are available, use them both. (when (and nmode-other-screen (not nmode-two-screens?)) (when (not (=> nmode-other-terminal raw-mode)) (=> nmode-other-terminal enter-raw-mode) (setf full-refresh-needed t) ) (setf nmode-two-screens? T) (setf browser-split-screen T) (setf nmode-layout-mode 2) (nmode-set-window-sizes) )) (de nmode-use-one-screen () % Use only the main screen. (when nmode-two-screens? (setf nmode-two-screens? NIL) (nmode-set-window-sizes) (if nmode-other-screen (=> nmode-other-screen refresh)) % clear it )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Screen Layout Commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de one-window-command () % The "C-X 1" command. Return to one window mode. (when (not (= nmode-layout-mode 1)) (if nmode-command-argument-given (nmode-expand-bottom-window) (nmode-expand-top-window) ))) (de two-windows-command () % The "C-X 2" command. The bottom window is selected. (when (not (= nmode-layout-mode 2)) (nmode-2-windows) (if nmode-command-argument-given (window-copy-buffer nmode-top-window nmode-bottom-window)) (nmode-switch-windows) )) (de view-two-windows-command () % The "C-X 3" command. The top window remains selected. (when (not (= nmode-layout-mode 2)) (nmode-2-windows) (if nmode-command-argument-given (window-copy-buffer nmode-top-window nmode-bottom-window)) )) (de grow-window-command () (if (not (nmode-grow-window nmode-command-argument)) (nmode-error "Not in 2-window mode!") )) (de other-window-command () (let ((old-buffer nmode-current-buffer)) (nmode-switch-windows) (if nmode-command-argument-given (buffer-select old-buffer)) )) (de exchange-windows-command () (selectq nmode-layout-mode (1 (Ding)) (2 (nmode-exchange-windows)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-select-window (window) % Expose the specified window and make it the "current" window. Its buffer % becomes the "current" buffer. This is the only function that should set % the variable "NMODE-CURRENT-WINDOW". (when (not (eq window nmode-current-window)) (if nmode-current-window (=> nmode-current-window deselect)) (when (not (eq window nmode-input-window)) (setf nmode-major-window window) (when (not (eq nmode-current-window nmode-input-window)) (reset-message) )) (setf nmode-current-window window) (=> window expose) (=> window select) (nmode-new-window-or-buffer) )) (de nmode-switch-windows () % Select the "other" window. (selectq nmode-layout-mode (2 (nmode-select-window (nmode-other-window))) (1 (nmode-exchange-windows)) )) (de nmode-select-major-window () % This function is used for possible error recovery. It ensures that the % current window is one of the exposed major windows (not, for example, the % INPUT window) and that the INPUT window is deexposed. (when (not (or (eq nmode-current-window nmode-top-window) (eq nmode-current-window nmode-bottom-window) )) (nmode-select-window nmode-top-window) (reset-message) ) (=> nmode-input-window deexpose) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Screen Information Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-window-position () (cond ((= nmode-layout-mode 1) 'FULL) ((eq nmode-current-window nmode-top-window) 'TOP) (t 'BOTTOM) )) (de nmode-other-window () % Return the "other" window. (if (eq nmode-current-window nmode-top-window) nmode-bottom-window nmode-top-window )) (de find-buffer-in-windows (b) % Return a list containing the windows displaying the specified buffer. % The windows may or may not be displayed. (for (in w (list nmode-bottom-window nmode-top-window)) % Put bottom window first in this list so that it will be % the one that is automatically adjusted on output if the % output buffer is being displayed by both windows. (when (eq b (=> w buffer))) (collect w)) ) (de find-buffer-in-exposed-windows (b) % Return a list containing the exposed windows displaying the specified % buffer. (for (in w (find-buffer-in-windows b)) (when (=> w exposed?)) (collect w)) ) (de buffer-is-displayed? (b) % Return T if the specified buffer is being displayed by an active window. (not (for (in w (nmode-active-windows)) (never (eq b (=> w buffer))) ))) (de nmode-active-windows () (selectq nmode-layout-mode (1 (list nmode-top-window)) (2 (list nmode-top-window nmode-bottom-window)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Typeout Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-begin-typeout () % Call this function before doing typeout using the standard output channel. % Someday this will do something clever, but for now it merely clears the % screen. (nmode-clear-screen) ) (de nmode-end-typeout () % Call this function after doing typeout using the standard output channel. % Someday this will do something clever, but for now it merely waits for % the user to type a character. (pause-until-terminal-input) ) (de nmode-clear-screen () % This is somewhat of a hack to clear the screen for normal typeout. The % next time a refresh is done, a full refresh will be done automatically. (=> nmode-blank-screen expose) (=> nmode-screen full-refresh NIL) (setf full-refresh-needed t) ) (de Enter-Raw-Mode () % Use this function to enter "raw mode", in which terminal input is not % echoed and special terminal keys are enabled. The next REFRESH will % automatically be a "full" refresh. (when (not (=> nmode-terminal raw-mode)) (=> nmode-terminal enter-raw-mode) (setf full-refresh-needed t) ) (when (and nmode-two-screens? nmode-other-terminal (not (=> nmode-other-terminal raw-mode))) (=> nmode-other-terminal enter-raw-mode) (setf full-refresh-needed t) ) ) (de leave-raw-mode () % Use this function to leave "raw mode", i.e. turn on echoing of terminal % input and disable any special terminal keys. The cursor is positioned % on the last line of the screen, which is cleared. (when (=> nmode-terminal raw-mode) (=> nmode-terminal move-cursor (=> nmode-terminal maxrow) 0) (=> nmode-terminal clear-line) (=> nmode-terminal leave-raw-mode) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Refresh functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-refresh () % This function refreshes the screen. It first ensures that all exposed % NMODE windows update their corresponding virtual screens. Then, it % asks the window package to update the display. A "full refresh" will % be done if some prior operation has indicated the need for one. (cond (full-refresh-needed (nmode-full-refresh)) (t (nmode-refresh-windows) (when (not nmode-breakout-occurred?) (=> nmode-screen refresh nmode-allow-refresh-breakout) (if (and nmode-other-screen nmode-two-screens?) (=> nmode-other-screen refresh nmode-allow-refresh-breakout)) )))) (de nmode-full-refresh () % This function refreshes the screen after first clearing the terminal % display. It it used when the state of the terminal display is in doubt. (nmode-refresh-windows) (when (not (setf full-refresh-needed nmode-breakout-occurred?)) (=> nmode-screen full-refresh nil) (if (and nmode-other-screen nmode-two-screens?) (=> nmode-other-screen full-refresh nil)) )) (de nmode-refresh-one-window (w) % This function refreshes the display, but only updates the virtual screen % corresponding to the specified window. (cond (full-refresh-needed (nmode-full-refresh)) (nmode-breakout-occurred? (nmode-refresh)) (t (if (eq (=> nmode-screen owner 0 0) nmode-blank-screen) % hack! (=> nmode-blank-screen deexpose)) (nmode-adjust-window w) (nmode-refresh-window w) (nmode-refresh-screen (=> (=> w screen) screen)) ))) (de nmode-refresh-virtual-screen (s) % This function refreshes the shared screen containing the specified % virtual screen. (cond (full-refresh-needed (nmode-full-refresh)) (nmode-breakout-occurred? (nmode-refresh)) (t (if (eq (=> nmode-screen owner 0 0) nmode-blank-screen) % hack! (=> nmode-blank-screen deexpose)) (nmode-refresh-screen (=> s screen)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-refresh-windows () % Cause all windows to update their corresponding virtual screens. The % variable nmode-breakout-occurred? is set to T if the refresh is % interrupted by user input. (setf nmode-breakout-occurred? NIL) (=> nmode-blank-screen deexpose) % hack! (=> nmode-current-window adjust-window) (nmode-refresh-window nmode-top-window) (nmode-refresh-window nmode-bottom-window) (nmode-refresh-window nmode-input-window) ) (de nmode-refresh-window (w) % Refresh only if window is exposed and no breakout has occurred. % Update the flag nmode-breakout-occurred? (if (not nmode-breakout-occurred?) (if (eq (object-type w) 'buffer-window) % hack for efficiency (if (buffer-window$exposed? w) (setf nmode-breakout-occurred? (not (buffer-window$refresh w nmode-allow-refresh-breakout)))) (if (=> w exposed?) (setf nmode-breakout-occurred? (not (=> w refresh nmode-allow-refresh-breakout)))) ))) (de nmode-refresh-screen (s) % Refresh the specified shared-screen. (if (eq (object-type s) 'shared-physical-screen) % hack for efficiency (shared-physical-screen$refresh s nmode-allow-refresh-breakout) (=> s refresh nmode-allow-refresh-breakout) )) (de nmode-establish-video-polarity () (let ((mask (if nmode-inverse-video? nmode-inverse-enhancement nmode-normal-enhancement ))) (=> nmode-top-window set-text-enhancement mask) (=> nmode-bottom-window set-text-enhancement mask) (=> nmode-input-window set-text-enhancement mask) (=> nmode-prompt-screen set-default-enhancement mask) (=> nmode-message-screen set-default-enhancement mask) (=> nmode-blank-screen set-default-enhancement mask) (=> nmode-prompt-screen clear) (rewrite-message) (=> nmode-blank-screen clear) )) (de ensure-terminal-type (type) % Ensure that NMODE-TERMINAL is bound to an object of the specified type. (cond ((or (null nmode-terminal) (not (eq type (object-type nmode-terminal)))) (setf nmode-terminal (make-instance type)) (nmode-new-terminal) ))) (de ensure-other-terminal-type (type) % Ensure that NMODE-OTHER-TERMINAL is bound to an object of the specified % type. (cond ((or (null nmode-other-terminal) (not (eq type (object-type nmode-other-terminal)))) (setf nmode-other-terminal (make-instance type)) (nmode-new-terminal) ))) (de nmode-new-terminal () % This function should be called when either NMODE-TERMINAL or % NMODE-OTHER-TERMINAL changes. (setf full-refresh-needed T) (setf nmode-physical-screen (create-physical-screen nmode-terminal)) (setf nmode-other-physical-screen (if nmode-other-terminal (create-physical-screen nmode-other-terminal))) (if nmode-screen (=> nmode-screen set-screen nmode-physical-screen) (setf nmode-screen (create-shared-physical-screen nmode-physical-screen)) ) (nmode-setup-softkey-label-screen nmode-screen) (if nmode-other-terminal (if nmode-other-screen (=> nmode-other-screen set-screen nmode-other-physical-screen) (setf nmode-other-screen (create-shared-physical-screen nmode-other-physical-screen)) ) (setf nmode-other-screen nil) ) (let ((height (=> nmode-screen height)) (width (=> nmode-screen width)) ) (when nmode-softkey-label-screen (setf height (- height (=> nmode-softkey-label-screen height))) ) (setf nmode-total-lines (- height 2)) % all but message and prompt lines (setf nmode-top-lines (/ nmode-total-lines 2)) % half for the top window % Throw away the old windows and screens! (if nmode-blank-screen (=> nmode-blank-screen deexpose)) (if nmode-message-screen (=> nmode-message-screen deexpose)) (if nmode-prompt-screen (=> nmode-prompt-screen deexpose)) (if nmode-input-window (=> nmode-input-window deexpose)) % Create new windows and screens: (setf nmode-blank-screen % hack to implement clear screen (nmode-create-screen height width 0 0)) (setf nmode-message-screen (nmode-create-screen 1 width (- height 2) 0)) (setf nmode-prompt-screen (nmode-create-screen 1 width (- height 1) 0)) (setf nmode-input-window (create-unlabeled-buffer-window nmode-input-buffer (nmode-create-screen 1 width (- height 1) 0))) (nmode-fixup-windows) (setf nmode-layout-mode (if nmode-two-screens? 2 1)) (=> nmode-message-screen expose) (=> nmode-prompt-screen expose) (nmode-select-window nmode-top-window) (nmode-establish-video-polarity) (nmode-set-window-sizes) )) (de nmode-create-screen (height width row-origin column-origin) (make-instance 'virtual-screen 'screen nmode-screen 'height height 'width width 'row-origin row-origin 'column-origin column-origin) ) (de nmode-set-window-sizes () % This function ensures that the top and bottom windows are properly % set up and exposed. (cond ((< nmode-top-lines 2) (setf nmode-top-lines 2)) ((> nmode-top-lines (- nmode-total-lines 2)) (setf nmode-top-lines (- nmode-total-lines 2))) ) (nmode-fixup-windows) (cond (nmode-two-screens? (nmode-position-window nmode-top-window nmode-total-lines 0) (nmode-position-window nmode-bottom-window nmode-total-lines 0) (nmode-expose-both-windows) ) ((= nmode-layout-mode 1) (nmode-position-window nmode-top-window nmode-total-lines 0) (nmode-position-window nmode-bottom-window nmode-total-lines 0) (=> nmode-top-window expose) ) ((= nmode-layout-mode 2) (nmode-position-window nmode-top-window nmode-top-lines 0) (nmode-position-window nmode-bottom-window (- nmode-total-lines nmode-top-lines) nmode-top-lines ) (nmode-expose-both-windows) ))) (de nmode-position-window (w height origin) (if (eq (=> (=> w screen) screen) nmode-other-screen) (setf height (=> nmode-other-screen height))) (=> w set-size height (=> w width)) (let ((s (=> w screen))) (=> s set-origin origin 0)) ) (de nmode-expose-both-windows () (cond ((eq nmode-top-window nmode-current-window) (=> nmode-bottom-window expose) (=> nmode-top-window expose) ) (t (=> nmode-top-window expose) (=> nmode-bottom-window expose) ))) (de nmode-fixup-windows () % Ensure that the two buffer-windows exist and are attached to the proper % shared-screens. (let ((top-screen (if (and nmode-two-screens? nmode-other-screen) nmode-other-screen nmode-screen )) (bottom-screen nmode-screen) ) (if (or (not nmode-top-window) (neq (=> (=> nmode-top-window screen) screen) top-screen) ) (nmode-create-top-window) ) (if (or (not nmode-bottom-window) (neq (=> (=> nmode-bottom-window screen) screen) bottom-screen) ) (nmode-create-bottom-window) ) )) (de nmode-create-top-window () (let ((vs (if (and nmode-two-screens? nmode-other-screen) (make-instance 'virtual-screen 'screen nmode-other-screen 'height (=> nmode-other-screen height) 'width (=> nmode-other-screen width) 'row-origin 0 ) (make-instance 'virtual-screen 'screen nmode-screen 'height nmode-total-lines 'width (=> nmode-screen width) 'row-origin 0 ))) ) (if nmode-top-window (=> nmode-top-window set-screen vs) (setf nmode-top-window (create-buffer-window nmode-main-buffer vs)) ))) (de nmode-create-bottom-window () (let ((vs (make-instance 'virtual-screen 'screen nmode-screen 'height nmode-total-lines 'width (=> nmode-screen width) 'row-origin 0 )) ) (if nmode-bottom-window (=> nmode-bottom-window set-screen vs) (setf nmode-bottom-window (create-buffer-window nmode-output-buffer vs)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-top-window nmode-bottom-window nmode-input-window nmode-current-window nmode-blank-screen nmode-screen) |
Added psl-1983/3-1/nmode/search.sl version [3ffe1f5519].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Search.SL - Search utilities % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 5 April 1983 % % 19-June-83 Mark R. Swanson % Added PATTERN-STARTS-IN-LINE to traverse entire line looking for first % character of PATTERN; this avoids many, many procedure calls. % 5-Apr-83 Nancy Kendzierski % Removed extra right parenthesis at end of forward-search and reverse-search. % 5-April-83 Jeff Soreff % Forward-Search-In-String was added to allow use of searching within a % string, as well as within a buffer. % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % These routines to implement minimal string searches for EMODE. Searches % are non-incremental, limited to single line patterns, and always ignore % case. (CompileTime (load objects fast-strings fast-int)) (fluid '(last-search-string)) (setf last-search-string NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de forward-string-search () % Invoked from keyboard, search forward from point for string, leave % "point" unchanged if not found. (let ((strng (prompt-for-string "Forward search: " last-search-string))) (setf last-search-string strng) (if (buffer-search strng 1) (for (from i 0 (string-upper-bound strng)) (do (move-forward)) ) % else (write-prompt "Search failed.") (Ding) ))) (de reverse-string-search () % Invoked from keyboard, search backwards from point for string, leave % "point unchanged if not found. (let ((strng (prompt-for-string "Reverse search: " last-search-string))) (setf last-search-string strng) (move-backward) (if (not (buffer-search strng -1)) (progn (move-forward) (write-prompt "Search failed.") (Ding))) )) (de buffer-search (pattern dir) % Search in buffer for the specified pattern. Dir should be +1 for forward, % -1 for backward. If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (setf pattern (string-upcase pattern)) (if (> dir 0) (forward-search pattern) (reverse-search pattern) )) (de forward-search (pattern) % Search forward in the current buffer for the specified pattern. % If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (let ((line-pos (current-line-pos)) (char-pos (current-char-pos)) (limit (current-buffer-size)) found-pos ) (while (and (< line-pos limit) (not (setf found-pos (forward-search-on-line line-pos char-pos pattern))) ) (setf line-pos (+ line-pos 1)) (setf char-pos NIL) ) (if found-pos (progn (current-buffer-goto line-pos found-pos) T))) ) (de forward-search-in-string (string pattern) % Search in the string for the specified pattern, starting at the % beginning of the string. If we find it, we return the CHAR-POS of % the first matching character. Otherwise, we return NIL. (let* ((pattern-length (string-length pattern)) (limit (- (string-length string) pattern-length)) (char-pos 0)) (while (<= char-pos limit) (if (pattern-matches-in-line pattern string char-pos) (exit char-pos)) (incr char-pos)))) (de forward-search-on-line (line-pos char-pos pattern) % Returns START-POSITION of pattern if it occurs in line, NIL otherwise. % Uses two subroutines: % PATTERN-STARTS-IN-LINE, which scans LINE for the first character of % PATTERN, constrained by the length of pattern % PATTERN-MATCHES-IN-LINE, which tries to match PATTERN with contents of % LINE at POS (let* ((line (current-buffer-fetch line-pos)) (pattern-length (string-length pattern)) (limit (- (string-length line) pattern-length)) (pattern-char (string-fetch pattern 0)) ) (if (null char-pos) (setf char-pos 0)) (while (<= char-pos limit) (setf char-pos (pattern-starts-in-line pattern-char limit line char-pos)) (if (> char-pos limit) (exit nil)) (if (pattern-matches-in-line pattern line char-pos) (exit char-pos)) (setf char-pos (+ char-pos 1)) ))) (de reverse-search (pattern) % Search backward in the current buffer for the specified pattern. % If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (let ((line-pos (current-line-pos)) (char-pos (current-char-pos)) found-pos ) (while (and (>= line-pos 0) (not (setf found-pos (reverse-search-on-line line-pos char-pos pattern))) ) (setf line-pos (- line-pos 1)) (setf char-pos NIL) ) (if found-pos (progn (current-buffer-goto line-pos found-pos) T))) ) (de reverse-search-on-line (line-pos char-pos pattern) % Returns START-POSITION of pattern if it occurs in line, NIL otherwise. % Uses two subroutines: % REV-PATTERN-STARTS-IN-LINE, which scans LINE for the first character of % PATTERN, constrained by the length of pattern % PATTERN-MATCHES-IN-LINE, which tries to match PATTERN with contents of % LINE at POS (let* ((line (current-buffer-fetch line-pos)) (pattern-length (string-length pattern)) (limit (- (string-length line) pattern-length)) (pattern-char (string-fetch pattern 0)) ) (if (or (null char-pos) (> char-pos limit)) (setf char-pos limit)) (while (>= char-pos 0) (setf char-pos (rev-pattern-starts-in-line pattern-char line char-pos)) (if (< char-pos 0) (exit nil)) (if (pattern-matches-in-line pattern line char-pos) (exit char-pos)) (setf char-pos (- char-pos 1)) ))) (de pattern-starts-in-line (pattern-char search-limit line pos) % Return position if PATTERN-CHAR occurs in LINE, with sufficient room % for rest of pattern; start looking at POS. % Ignore case differences. No bounds checking is performed on LINE. (let ((i pos)) (while (<= i search-limit) (if (= pattern-char %(char-upcase (string-fetch line i)) (let ((xchar (string-fetch line i))) (cond ((< xchar #/a) xchar) ((> xchar #/z) xchar) (T (- xchar 32))))) (exit i) (setf i (+ i 1)))) (exit i) % nothing matched, i > limit will indicate such )) (de rev-pattern-starts-in-line (pattern-char line pos) % Return position if PATTERN-CHAR occurs in LINE, with sufficient room % for rest of pattern; start looking at POS. % Ignore case differences. No bounds checking is performed on LINE. (let ((i pos)) (while (>= i 0) (if (= pattern-char %(char-upcase (string-fetch line i)) (let ((xchar (string-fetch line i))) (cond ((< xchar #/a) xchar) ((> xchar #/z) xchar) (T (- xchar 32))))) (exit i) (setf i (- i 1)))) (exit i) % nothing matched, i > limit will indicate such )) (de pattern-matches-in-line (pattern line pos) % Return T if PATTERN occurs as substring of LINE, starting at POS. % Ignore case differences. No bounds checking is performed on LINE. (let ((i 0) (patlimit (string-upper-bound pattern))) (while (and (<= i patlimit) (= (string-fetch pattern i) %(char-upcase (string-fetch line (+ i pos))) (let ((xchar (string-fetch line (+ i pos)))) (cond ((< xchar #/a) xchar) ((> xchar #/z) xchar) (T (- xchar 32)))) ) ) (setf i (+ i 1)) ) (> i patlimit) % T if all chars matched, NIL otherwise )) |
Added psl-1983/3-1/nmode/set-terminal-20.sl version [27da7709e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Set-Terminal-20.SL (Tops-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 1 November 1982 % % This file contains functions that set NMODE's terminal. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) % External variables used here: (fluid '(nmode-terminal)) % Global variables defined here: (fluid '(terminal-type)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-default-terminal () (nmode-set-terminal) ) (de nmode-set-terminal () (setf terminal-type (jsys2 65 0 0 0 (const jsgttyp))) (selectq terminal-type (21 % HP2621 (ensure-terminal-type 'hp2648a) ) (6 % HP264X (ensure-terminal-type 'hp2648a) ) (15 % VT52 (ensure-terminal-type 'vt52x) ) (t (or nmode-terminal (ensure-terminal-type 'hp2648a)) ) )) (de ensure-terminal-type (type) (cond ((or (null nmode-terminal) (not (eq type (object-type nmode-terminal)))) (setf nmode-terminal (make-instance type)) (nmode-new-terminal) ))) % These functions defined for compatibility: (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) |
Added psl-1983/3-1/nmode/set-terminal-9836.sl version [4df47c5bd6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Set-Terminal-9836.SL (9836 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 December 1982 % % This file contains functions that set NMODE's terminal. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) % External variables used here: (fluid '(nmode-terminal nmode-other-terminal)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-default-terminal () (nmode-set-terminal) ) (de nmode-set-terminal () (or nmode-terminal (ensure-terminal-type '9836-alpha)) (or nmode-other-terminal (ensure-other-terminal-type '9836-color)) ) (de ensure-terminal-type (type) (cond ((or (null nmode-terminal) (not (eq type (object-type nmode-terminal)))) (setf nmode-terminal (make-instance type)) (nmode-new-terminal) ))) (de ensure-other-terminal-type (type) (cond ((or (null nmode-other-terminal) (not (eq type (object-type nmode-other-terminal)))) (setf nmode-other-terminal (make-instance type)) (nmode-new-terminal) ))) |
Added psl-1983/3-1/nmode/softkeys.sl version [f1fe54e021].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SoftKeys.SL - NMODE SoftKeys % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 28 January 1983 % % This implementation of softkeys is intended primarily for the HP9836 % implementation. It recognizes the escape-sequence Esc-/, followed by % a single character, as instructing NMODE to execute the softkey % corresponding to that character. In the HP9836 implementation, % we can cause the keys K0-K9 to send the appropriate escape sequence. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings fast-vectors display-char)) % Global variables defined here: (fluid '(nmode-softkey-label-screen nmode-softkey-label-screen-height % number of rows of keys nmode-softkey-label-screen-width % number of keys per row )) % Internal static variables (don't use elsewhere!): (fluid '(nmode-softkey-defs % vector of softkey definitions (see below) nmode-softkey-labels % vector of softkey label strings nmode-softkey-label-width % number of characters wide nmode-softkey-label-count % number of displayed labels )) (when (or (unboundp 'nmode-softkey-defs) (null nmode-softkey-defs)) (setf nmode-softkey-label-screen NIL) (setf nmode-softkey-label-screen-height 0) (setf nmode-softkey-label-screen-width 0) (setf nmode-softkey-defs (make-vector 40 NIL)) (setf nmode-softkey-labels (make-vector 40 NIL)) (setf nmode-softkey-label-width 0) (setf nmode-softkey-label-count 0) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-define-softkey (n fcn label-string) % N should be a softkey number. FCN should be a function ID, a string, % or NIL. Define softkey #n to run the specified function, execute the % specified string (as if typed), or be undefined, respectively. % LABEL-STRING should be a string or NIL. The string will be centered. (if (and (valid-softkey-number? n) (or (null fcn) (idp fcn) (stringp fcn)) (or (null label-string) (stringp label-string)) ) (progn (vector-store nmode-softkey-defs n fcn) (vector-store nmode-softkey-labels n label-string) (nmode-write-softkey-label n) ) (nmode-error "Invalid arguments to Define Softkey") )) (de valid-softkey-number? (n) (and (fixp n) (>= n 0) (<= n (vector-upper-bound nmode-softkey-defs))) ) (de softkey-char-to-number (ch) (- (char-code ch) #/0)) (de softkey-number-to-char (n) (+ n #/0)) (de nmode-execute-softkey (n) % Execute softkey #n. (if (valid-softkey-number? n) (let ((fcn (vector-fetch nmode-softkey-defs n))) (cond ((null fcn) (nmode-error (bldmsg "Softkey %w is undefined." n))) ((stringp fcn) (nmode-execute-string fcn)) ((idp fcn) (apply fcn ())) (t (nmode-error (bldmsg "Softkey %w has a bad definition." n))) )) (nmode-error (bldmsg "Invalid Softkey specified.")) )) (de execute-softkey-command (n) (nmode-set-delayed-prompt "Execute Softkey: ") (let ((ch (input-direct-terminal-character))) (nmode-execute-softkey (softkey-char-to-number ch)) )) (de nmode-setup-softkey-label-screen (sps) % If the requested size of the softkey label screen is nonzero, then % create a virtual screen of that size on the given shared screen. % The requested size is obtained from global variables. (setf nmode-softkey-label-width 0) (setf nmode-softkey-label-count 0) (let ((height nmode-softkey-label-screen-height) (width nmode-softkey-label-screen-width) (screen-height (=> sps height)) (screen-width (=> sps width)) ) (setf nmode-softkey-label-screen (when (and (> height 0) (> width 0) (> screen-width (* 2 width)) (>= screen-height height) ) (let ((s (make-instance 'virtual-screen 'screen sps 'height height 'width screen-width 'row-origin (- screen-height height) 'column-origin 0 ))) (setf nmode-softkey-label-width (/ screen-width width)) (setf nmode-softkey-label-count (* width height)) (=> s set-default-enhancement (=> sps highlighted-enhancement)) s ))) (when nmode-softkey-label-screen (for (from i 0 (- nmode-softkey-label-count 1)) (do (nmode-write-softkey-label i))) (=> nmode-softkey-label-screen expose) ) )) (de nmode-write-softkey-label (n) (when (and nmode-softkey-label-screen (>= n 0) (< n nmode-softkey-label-count) ) (let* ((row (/ n nmode-softkey-label-screen-width)) (lcol (// n nmode-softkey-label-screen-width)) (col (* lcol nmode-softkey-label-width)) (enhancement (if (xor (= (// row 2) 0) (= (// lcol 2) 0)) (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY) (dc-make-enhancement-mask INVERSE-VIDEO) )) (label (vector-fetch nmode-softkey-labels n)) (bound (if label (string-upper-bound label) -1)) (padding (/ (- nmode-softkey-label-width (+ bound 1)) 2)) ) (=> nmode-softkey-label-screen set-default-enhancement enhancement) (if (< padding 0) (setf padding 0)) (for (from i 1 padding) (do (=> nmode-softkey-label-screen write #\space row col) (setf col (+ col 1)) )) (for (from i 0 (- (- nmode-softkey-label-width padding) 1)) (do (let ((ch (if (<= i bound) (string-fetch label i) #\space ))) (=> nmode-softkey-label-screen write ch row (+ col i)) ))) ))) |
Added psl-1983/3-1/nmode/structure-functions.sl version [dc9918369d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Structure-Functions.SL - NMODE functions for moving about structured text % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % Revised: 18 February 1983 % % This file contains functions for moving about structured text, such as Lisp % source code. The functions are based on the primitives in the module % NMODE-Parsing; the variable NMODE-CURRENT-PARSER determines the actual syntax % (e.g., Lisp, RLISP, etc.). See the document NMODE-PARSING.TXT for a % description of the parsing strategy. % % 18-Feb-83 Alan Snyder % Replaced move-down-list with move-forward-down-list and % move-backward-down-list. % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability); reformat source. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int nmode-parsing)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Form Movement Functions % % A form is an ATOM or a nested structure. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-form () % Move to the end (just past the last character) of the current (if any) or % the next (otherwise) complete form or unmatched closing bracket. Returns % either NIL (no complete form found), 'ATOM, 'CLOSER (unmatched closing % bracket), or 'STRUCTURE (complete structure). If NIL is returned, then % point is unchanged. (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-forward-item)) % find next item (see below) ) (if (eq first-item 'OPENER) % it is an opening bracket (while T % scan past complete forms until an unmatched closing bracket (selectq (move-forward-form) (NIL (buffer-set-position old-pos) (exit NIL)) % end of text (CLOSER (exit 'STRUCTURE)) % found the matching closing bracket )) first-item % Otherwise, just return the information. ))) (de move-backward-form () % Move backward at least one character to the preceding character that is not % part of whitespace; then move to the beginning of the smallest form that % contains that character. If no form is found, return NIL and leave point % unchanged. Otherwise, return either 'ATOM, 'STRUCTURE (passed over complete % structure), or 'OPENER (passed over unmatched open bracket). (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-backward-item)) % find previous item (see below) ) (if (eq first-item 'CLOSER) % it is a closing bracket (while T % scan past complete forms until an unmatched opening bracket (selectq (move-backward-form) (NIL (buffer-set-position old-pos) (exit NIL)) % beginning of text (OPENER (exit 'STRUCTURE)) % found the matching opening bracket )) first-item % Otherwise, just return the information. ))) (de move-backward-form-interruptible () % This function is like move-backward-form, except it can be interrupted by % user type-ahead. If it is interrupted, it returns 'INTERRUPT and restores % the old position. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (when (input-available?) (buffer-set-position old-pos) (exit 'INTERRUPT)) (let ((item (move-backward-item))) (selectq item (NIL (buffer-set-position old-pos) (exit NIL)) (OPENER (setf paren-depth (- paren-depth 1)) (if (= paren-depth 0) (exit 'STRUCTURE)) ) (CLOSER (setf paren-depth (+ paren-depth 1))) ) (if (<= paren-depth 0) (exit item)) )))) (de move-backward-form-within-line () % This is the same as MOVE-BACKWARD-FORM, except that it looks only within the % current line. (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-backward-item-within-line)) % find previous item ) (if (eq first-item 'CLOSER) % it is a closing bracket (while T % scan past complete forms until an unmatched opening bracket (selectq (move-backward-form-within-line) (NIL (buffer-set-position old-pos) (exit NIL)) % beginning of text (OPENER (exit 'STRUCTURE)) % found the matching opening bracket )) first-item % Otherwise, just return the information. ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Item Movement Functions % % An item is an ATOM or a structure bracket. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-item () % Move to the end (just past the last character) of the current (if any) or % the next (otherwise) atom or bracket. Returns either NIL (no item found), % 'ATOM, 'OPENER, or 'CLOSER. If NIL is returned, then point is unchanged. (let ((item-type (move-forward-to LAST NOT-SPACE))) (if item-type (move-forward-character)) item-type )) (de move-backward-item () % Move backward at least one character to the preceding character that is not % part of whitespace; then move to the beginning of the atom or bracket that % contains that character. Returns either NIL (no item found), 'ATOM, % 'OPENER, or 'CLOSER. If NIL is returned, then point is unchanged. (let ((old-pos (buffer-get-position)) (item-type nil) ) (if (move-backward-character) (setf item-type (move-backward-to FIRST NOT-SPACE))) (if (not item-type) (buffer-set-position old-pos)) item-type )) (de move-backward-item-within-line () % This is the same as MOVE-BACKWARD-ITEM, except that it looks only within the % current line. (if (not (at-line-start?)) (let ((old-pos (buffer-get-position)) (item-type nil) ) (move-backward-character) (setf item-type (move-backward-within-line-to FIRST NOT-SPACE)) (if (not item-type) (buffer-set-position old-pos)) item-type ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Move-Up-Forms Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-up-list () % Move to the right of the current structure (e.g. list). In other words, % find the next closing structure bracket whose matching opening structure % bracket is before point. If no such bracket can be found, return NIL and % leave point unchanged. (forward-scan-for-right-paren -1) ) (de move-backward-up-list () % Move to the beginning of the current structure (e.g. list). In other words, % find the previous opening structure bracket whose matching closing structure % bracket is after point. If no such bracket can be found, return NIL and % leave point unchanged. (reverse-scan-for-left-paren 1) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % List Movement Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-list () % Move to the right of the current or next structure (e.g. list). In other % words, find the next closing structure bracket whose matching opening % structure bracket is before point or is the first opening structure bracket % after point. If no such bracket can be found, return NIL and leave point % unchanged. (forward-scan-for-right-paren 0) ) (de move-backward-list () % Move to the beginning of the current or previous structure (e.g. list). In % other words, find the previous opening structure bracket whose matching % closing structure bracket is after point or is the first closing structure % bracket before point. If no such bracket can be found, return NIL and leave % point unchanged. (reverse-scan-for-left-paren 0) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Display Commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de display-matching-opener () % If the previous character is the last character of a closing bracket, then % move backward to the beginning of the form, wait a while so that the user % can see where it is, then return to the previous position. (let ((old-pos (buffer-get-position))) (unwind-protect (unsafe-display-matching-opener) (buffer-set-position old-pos) ))) (de unsafe-display-matching-opener () (move-backward-character) (when (test-current-attributes LAST CLOSER) (move-forward-character) (selectq (move-backward-form-interruptible) (STRUCTURE (nmode-refresh) % Show the user where we are. (sleep-until-timeout-or-input 30) % wait a while ) (INTERRUPT) (t (Ding)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal List Scanning Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de reverse-scan-for-left-paren (depth) % Scan backwards (starting with the character before point) for a left paren % at depth >= the specified depth. If found, the left paren will be after % point and T will be returned. Otherwise, point will not change and NIL will % be returned. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (selectq (move-backward-item) (NIL (buffer-set-position old-pos) (exit NIL)) (CLOSER (setf paren-depth (- paren-depth 1))) (OPENER (setf paren-depth (+ paren-depth 1)) (if (>= paren-depth depth) (exit T)) ) )))) (de forward-scan-for-right-paren (depth) % Scan forward (starting with the character after point) for a right paren at % depth <= the specified depth. If found, the right paren will be before % point and T will be returned. Otherwise, point will not change and NIL will % be returned. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (selectq (move-forward-item) (NIL (buffer-set-position old-pos) (exit NIL)) (CLOSER (setf paren-depth (- paren-depth 1)) (if (<= paren-depth depth) (exit T)) ) (OPENER (setf paren-depth (+ paren-depth 1))) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Down-List functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-down-list () % Move forward past the next open bracket at the current level. (let ((old-pos (buffer-get-position))) (while T (selectq (move-forward-item) ((NIL CLOSER) (buffer-set-position old-pos) (exit NIL)) (OPENER (exit T)) )))) (de move-backward-down-list () % Move backward past the previous close bracket at the current level. (let ((old-pos (buffer-get-position))) (while T (selectq (move-backward-item) ((NIL OPENER) (buffer-set-position old-pos) (exit NIL)) (CLOSER (exit T)) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de skip-prefixes () % Skip over any "prefix characters" (like ' in Lisp). (while (test-current-attributes PREFIX) (move-forward)) ) |
Added psl-1983/3-1/nmode/terminal-input.sl version [1232fdbe83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Terminal-Input.SL - NMODE Terminal Input Routines % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 August 1982 % Revised: 14 March 1983 % % 14-Mar-83 Alan Snyder % Get terminal character from physical screen, to take advantage of its % cached method. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 26-Jan-83 Alan Snyder % Add ability to read from string. % 21-Dec-82 Alan Snyder % Efficiency improvement: Added declarations for text buffers. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings)) (load wait) % External variables used: (fluid '(nmode-terminal nmode-allow-refresh-breakout nmode-physical-screen )) % Internal static variables (don't use elsewhere!): (fluid '(nmode-prompt-string % current prompt for character input nmode-prompt-immediately % true => show prompt immediately nmode-terminal-script-buffer % if non-NIL, is a buffer to script to nmode-terminal-input-buffer % if non-NIL, is a buffer to read from nmode-terminal-input-string % if non-NIL, is a string to read from nmode-terminal-input-string-pos % index of next character in string )) (setf nmode-prompt-string "") (setf nmode-prompt-immediately NIL) (setf nmode-terminal-script-buffer NIL) (setf nmode-terminal-input-buffer NIL) (setf nmode-terminal-input-string NIL) (declare-flavor text-buffer nmode-terminal-input-buffer nmode-terminal-script-buffer) (declare-flavor physical-screen nmode-physical-screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % A primary goal of this module is to support delayed prompting. Prompting can % mean both echoing (some kind of confirmation) of the previous input and % information relating to expected input. The basic idea behind delayed % prompting is that as long as the user is rapidly typing input characters, % there is no need for the system to display any prompts, since the user % probably knows what he is doing. However, should the user ever pause for a % "sufficiently long" time, then the current prompt should be displayed to % inform the user of the current state. % An important notion is that some command interactions form a logical sequence. % In the case of a logical sequence of prompted inputs, each additional prompt % string should be appended to the existing prompt string, without first erasing % the prompt line. Furthermore, once the prompt line for this sequence is % displayed, any further prompts within the same sequence should be output % immediately. A command sequence is started using the function % NMODE-SET-DELAYED-PROMPT. Additional prompting within the same sequence is % specified using either NMODE-APPEND-DELAYED-PROMPT or % NMODE-APPEND-SEPARATED-PROMPT. (de nmode-set-immediate-prompt (prompt-string) % This function is used to specify the beginning of a command sequence. It % causes the existing prompt string to be discarded and replaced by the % specified string. The specified string may be empty to indicate that the % new command sequence has no initial prompt. The prompt string will be % output immediately upon the next request for terminal input. (setf nmode-prompt-string prompt-string) (setf nmode-prompt-immediately T) ) (de nmode-set-delayed-prompt (prompt-string) % This function is used to specify the beginning of a command sequence. It % causes the existing prompt string to be discarded and replaced by the % specified string. The specified string may be empty to indicate that the % new command sequence has no initial prompt. The prompt string will be % output when terminal input is next requested, provided that the user has % paused. (setf nmode-prompt-string prompt-string) (setf nmode-prompt-immediately NIL) ) (de nmode-append-delayed-prompt (prompt-string) % This function is used to specify an additional prompt for the current % command sequence. The prompt string will be appended to the existing prompt % string. The prompt string will be output when terminal input is next % requested, provided that the user has paused within the current command % sequence. If the prompt string is currently empty, then the user must pause % at some future input request to cause the prompt to be displayed. (setf nmode-prompt-string (string-concat nmode-prompt-string prompt-string)) ) (de nmode-append-separated-prompt (prompt-string) % This function is the same as NMODE-APPEND-DELAYED-PROMPT, except that if the % existing prompt string is non-null, an extra space is appended before the % new prompt-string is appended. (nmode-append-delayed-prompt (if (not (string-empty? nmode-prompt-string)) (string-concat " " prompt-string) prompt-string ))) (de nmode-complete-prompt (prompt-string) % This function is used to specify an additional prompt for the current % command sequence. The prompt string will be appended to the existing prompt % string. The prompt string will be output immediately, if the current prompt % has already been output. This function is to be used for "completion" or % "echoing" of previously read input. (setf nmode-prompt-string (string-concat nmode-prompt-string prompt-string)) (if nmode-prompt-immediately (write-prompt nmode-prompt-string)) ) (de input-available? () % Return Non-NIL if and only if new terminal input is available. Note: this % function might be somewhat expensive. (or (and nmode-terminal-input-buffer (not (=> nmode-terminal-input-buffer at-buffer-end?))) nmode-terminal-input-string (~= (CharsInInputBuffer) 0))) (de input-direct-terminal-character () % Prompt for (but do not echo) a single character from the terminal. The % above functions are used to specify the prompt string. Avoid displaying the % prompt string if the user has already typed a character or types a character % right away. Within a sequence of related prompts, once a non-empty prompt % is output, further prompting is done immediately. (cond (nmode-terminal-input-buffer (&input-character-from-buffer)) (nmode-terminal-input-string (&input-character-from-string)) (t (&input-character-from-terminal)) )) (de &input-character-from-buffer () % Internal function for reading from a buffer. (cond ((=> nmode-terminal-input-buffer at-buffer-end?) (setf nmode-terminal-input-buffer NIL) (setf nmode-allow-refresh-breakout T) (input-direct-terminal-character) ) ((=> nmode-terminal-input-buffer at-line-end?) (=> nmode-terminal-input-buffer move-to-next-line) (input-direct-terminal-character) ) (t (prog1 (=> nmode-terminal-input-buffer next-character) (=> nmode-terminal-input-buffer move-forward) )) )) (de &input-character-from-string () % Internal function for reading from a string. (let ((upper-bound (string-upper-bound nmode-terminal-input-string)) (pos nmode-terminal-input-string-pos) ) (cond ((= pos upper-bound) (let ((ch (string-fetch nmode-terminal-input-string pos))) (setf nmode-terminal-input-string NIL) (setf nmode-allow-refresh-breakout T) ch )) (t (let ((ch (string-fetch nmode-terminal-input-string pos))) (setf nmode-terminal-input-string-pos (+ pos 1)) ch )) ))) (de &input-character-from-terminal () % Internal function for reading from the terminal. (let ((prompt-is-empty (string-empty? nmode-prompt-string))) (if (not nmode-prompt-immediately) (sleep-until-timeout-or-input (if prompt-is-empty 120 30) % don't rush to erase the prompt line )) (if (or nmode-prompt-immediately (not (input-available?))) (progn (write-prompt nmode-prompt-string) (setf nmode-prompt-immediately (not prompt-is-empty)) )) (let ((ch (=> nmode-physical-screen get-character))) (if nmode-terminal-script-buffer (nmode-script-character ch)) ch ))) (de pause-until-terminal-input () % Return when the user has typed a character. The character is eaten. % No refresh is performed. (=> nmode-physical-screen get-character) ) (de sleep-until-timeout-or-input (n-60ths) (wait-timeout 'input-available? n-60ths) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-script-terminal-input (b) % Make a script of all terminal (command) input by appending characters to the % specified buffer. Supercedes any previous such request. If B is NIL, then % no scripting is performed. Note: to keep the lines of reasonable length, % free Newlines will be inserted from time to time. Because of this, and % because many file systems cannot represent stray Newlines, the Newline % character is itself scripted as a CR followed by a TAB, since this is its % normal definition. Someday, perhaps, this hack will be replaced by a better % one. (setf nmode-terminal-script-buffer b) ) (de nmode-execute-buffer (b) % Take input from the specified buffer. Supercedes any previous such request. % If B is NIL, then input is taken from the terminal. Newline characters are % ignored when reading from a buffer! (setf nmode-terminal-input-buffer b) (if b (=> b move-to-buffer-start)) ) (de nmode-execute-string (s) % Take input from the specified string. Supercedes any previous such request. % If S is NIL or empty, then input is taken from the terminal. (if (string-empty? s) (setf s NIL)) (setf nmode-terminal-input-string s) (setf nmode-terminal-input-string-pos 0) ) (de nmode-script-character (ch) % Write CH to the script buffer. (let* ((b nmode-terminal-script-buffer) (old-pos (=> b position)) ) (=> b move-to-buffer-end) (cond ((= ch #\LF) (=> b insert-character #\CR) (=> b insert-character #\TAB) ) (t (=> b insert-character ch)) ) (if (>= (=> b current-line-length) 60) (=> b insert-eol) ) (=> b set-position old-pos) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-terminal-input-buffer nmode-terminal-script-buffer) (undeclare-flavor nmode-physical-screen) |
Added psl-1983/3-1/nmode/text-buffer.sl version [6356936b45].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Text-Buffer.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 August 1982 % Revised: 29 March 1983 % % A text buffer. Supports the primitive editing functions. The strings in a % text buffer are never modified. This allows EQ to be used to minimize % redisplay. % % 29-Mar-83 Alan Snyder % Removed extra definition of with-current-line (compiler bug seems to have % gone away). % 14-Mar-83 Alan Snyder % Change comment to indicate that a buffer's name may be NIL. Add % label-string attribute for display in window-label. % 3-Mar-83 Alan Snyder % Add option to read from input stream using GETL. % 23-Feb-83 Alan Snyder % Revise stream operations to work with any type of object. % 15-Feb-83 Alan Snyder % Revise insertion code to reduce unnecessary consing. % Remove char-blank? macro (NMODE has a function char-blank?). % 19-Jan-83 Jeff Soreff % Name made settable in text buffer. % 3-Dec-82 Alan Snyder % Added cleanup method. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load numeric-operators fast-vectors fast-strings)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-text-buffer (name) % not for direct use in NMODE (let ((buffer (make-instance 'text-buffer 'name name))) buffer)) (defflavor text-buffer ( (last-line 0) % index of last line in buffer (n >= 0) (line-pos 0) % index of "current" line (0 <= n <= last-line) (char-pos 0) % index of "current" character in current line % (0 <= n <= linelength) lines % vector of strings name % string name of buffer (or NIL) (file-name NIL) % string name of attached file (or NIL) (modified? NIL) % T => buffer is different than file (label-string NIL) % optional string for display in window label marks % ring buffer of marks (mode NIL) % the buffer's Mode (previous-buffer NIL) % (optional) previous buffer (p-list NIL) % association list of properties ) () (gettable-instance-variables line-pos char-pos) (settable-instance-variables file-name modified? mode previous-buffer name label-string) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (CompileTime (progn (defmacro with-current-line ((var) . forms) `(let ((,var (vector-fetch lines line-pos))) ,@forms )) (defmacro with-current-line-copied ((var) . forms) `(let ((**LINES** lines) (**LINE-POS** line-pos)) (let ((,var (copystring (vector-fetch **LINES** **line-pos**)))) (vector-store **LINES** **line-pos** ,var) ,@forms ))) )) % End of CompileTime %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (text-buffer position) () % Return the "current position" in the buffer as a BUFFER-POSITION object. (buffer-position-create line-pos char-pos) ) (defmethod (text-buffer set-position) (bp) % Set the "current position" in the buffer from the specified % BUFFER-POSITION object. Clips the line-position and char-position. (=> self goto (buffer-position-line bp) (buffer-position-column bp)) ) (defmethod (text-buffer buffer-end-position) () % Return the BUFFER-POSITION object corresponding to the end of the buffer. (buffer-position-create last-line (string-length (vector-fetch lines last-line)) )) (defmethod (text-buffer goto) (lpos cpos) % Set the "current position" in the buffer. Clips the line-position and % char-position. (if (< lpos 0) (setf lpos 0)) (if (> lpos last-line) (setf lpos last-line)) (setf line-pos lpos) (=> self set-char-pos cpos) ) (defmethod (text-buffer set-line-pos) (lpos) % Set the "current line position" in the buffer. Clips the line-position % and char-position. (when (~= lpos line-pos) (if (< lpos 0) (setf lpos 0)) (if (> lpos last-line) (setf lpos last-line)) (setf line-pos lpos) (with-current-line (l) (if (> char-pos (string-length l)) (setf char-pos (string-length l)) )) )) (defmethod (text-buffer set-char-pos) (cpos) % Set the "current character position" in the buffer. Clips the specified % position to lie in the range 0..line-length. (if (< cpos 0) (setf cpos 0)) (with-current-line (l) (if (> cpos (string-length l)) (setf cpos (string-length l)) )) (setf char-pos cpos) ) (defmethod (text-buffer clip-position) (bp) % Return BP if BP is a valid position for this buffer, otherwise return a new % buffer-position with clipped values. (let ((lpos (buffer-position-line bp)) (cpos (buffer-position-column bp)) (clipped NIL) ) (cond ((< lpos 0) (setf lpos 0) (setf clipped T)) ((> lpos last-line) (setf lpos last-line) (setf clipped T)) ) (cond ((< cpos 0) (setf cpos 0) (setf clipped T)) ((> cpos (string-length (vector-fetch lines lpos))) (setf cpos (string-length (vector-fetch lines lpos))) (setf clipped T) )) (if clipped (buffer-position-create lpos cpos) bp ))) (defmethod (text-buffer size) () % Return the actual size of the buffer (number of lines). This number will % include the "fake" empty line at the end of the buffer, should it exist. (+ last-line 1) ) (defmethod (text-buffer visible-size) () % Return the apparent size of the buffer (number of lines). This number % will NOT include the "fake" empty line at the end of the buffer, should it % exist. (if (>= (string-upper-bound (vector-fetch lines last-line)) 0) (+ last-line 1) % The last line is real! last-line % The last line is fake! )) (defmethod (text-buffer contents) () % Return the text contents of the buffer (a copy thereof) as a vector of % strings (the last string is implicitly without a terminating NewLine). (sub lines 0 last-line) ) (defmethod (text-buffer current-line) () % Return the current line (as a string). (with-current-line (l) l)) (defmethod (text-buffer fetch-line) (n) % Fetch the specified line (as a string). Lines are indexed from 0. (if (or (< n 0) (> n last-line)) (ContinuableError 0 (BldMsg "Line index %w out of range." n) "") (vector-fetch lines n) )) (defmethod (text-buffer store-line) (n new-line) % Replace the specified line with a new string. (if (or (< n 0) (> n last-line)) (ContinuableError 0 (BldMsg "Line index %w out of range." n) "") % else (setf modified? T) (vector-store lines n new-line) (if (= line-pos n) (let ((len (string-length new-line))) (if (> char-pos len) (setf char-pos len) ))) )) (defmethod (text-buffer select) () % Attach the buffer to the current window, making it the current buffer. (buffer-select self) ) (defmethod (text-buffer set-mark) (bp) % PUSH the specified position onto the ring buffer of marks. % The specified position thus becomes the current "mark". (ring-buffer-push marks bp) ) (defmethod (text-buffer set-mark-from-point) () % PUSH the current position onto the ring buffer of marks. % The current position thus becomes the current "mark". (ring-buffer-push marks (buffer-position-create line-pos char-pos)) ) (defmethod (text-buffer mark) () % Return the current "mark". (ring-buffer-top marks) ) (defmethod (text-buffer previous-mark) () % POP the current mark off the ring buffer of marks. % Return the new current mark. (ring-buffer-pop marks) (ring-buffer-top marks) ) (defmethod (text-buffer get) (property-name) % Return the object associated with the specified property name (ID). % Returns NIL if named property has not been defined. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (cdr pair)))) (defmethod (text-buffer put) (property-name property) % Associate the specified object with the specified property name (ID). % GET on that property-name will henceforth return the object. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (rplacd pair property) (setf p-list (cons (cons property-name property) p-list)) ))) (defmethod (text-buffer reset) () % Reset the contents of the buffer to empty and "not modified". (setf lines (MkVect 1)) (vector-store lines 0 "") (setf last-line 0) (setf line-pos 0) (setf char-pos 0) (setf modified? NIL) ) (defmethod (text-buffer extract-region) (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % pair (CONS direction-of-deletion vector-of-strings). The returned % direction is +1 if BP1 <= BP2, and -1 otherwise. The current position is % set to the beginning of the region if deletion is performed. (setf bp1 (=> self clip-position bp1)) (setf bp2 (=> self clip-position bp2)) (prog (dir text text-last l1 c1 l2 c2 line1 line2) (setf dir 1) % the default case % ensure that BP1 is not beyond BP2 (let ((comparison (buffer-position-compare bp1 bp2))) (if (> comparison 0) (psetq dir -1 bp1 bp2 bp2 bp1)) (if (and delete-it (~= comparison 0)) (setf modified? T)) ) (setf l1 (buffer-position-line bp1)) (setf c1 (buffer-position-column bp1)) (setf l2 (buffer-position-line bp2)) (setf c2 (buffer-position-column bp2)) % Ensure the continued validity of the current position. (if delete-it (=> self set-position bp1)) % Create a vector for the extracted text. (setf text-last (- l2 l1)) % highest index in TEXT vector (setf text (MkVect text-last)) (setf line1 (vector-fetch lines l1)) % first line (partially) in region (cond ((= l1 l2) % region lies within a single line (easy!) (vector-store text 0 (substring line1 c1 c2)) (if delete-it (vector-store lines l1 (string-concat (substring line1 0 c1) (string-rest line1 c2) ))) (return (cons dir text)))) % Here if region spans multiple lines. (setf line2 (vector-fetch lines l2)) % last line (partially) in region (vector-store text 0 (string-rest line1 c1)) (vector-store text text-last (substring line2 0 c2)) % Copy remaining text from region. (for (from i 1 (- text-last 1)) (do (vector-store text i (vector-fetch lines (+ l1 i))))) (when delete-it (vector-store lines l1 (string-concat (substring line1 0 c1) (string-rest line2 c2))) (=> self &delete-lines (+ l1 1) text-last) ) (return (cons dir text)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following methods are not really primitive, but are provided as % a public service. (defmethod (text-buffer current-line-length) () % Return the number of characters in the current line. (with-current-line (l) (string-length l))) (defmethod (text-buffer current-line-empty?) () % Return T if the current line contains no characters. (with-current-line (l) (string-empty? l))) (defmethod (text-buffer current-line-blank?) () % Return T if the current line contains no non-blank characters. (with-current-line (l) (for (from i 0 (string-upper-bound l)) (always (char-blank? (string-fetch l i))) ))) (defmethod (text-buffer at-line-start?) () % Return T if we are positioned at the start of the current line. (= char-pos 0)) (defmethod (text-buffer at-line-end?) () % Return T if we are positioned at the end of the current line. (with-current-line (l) (> char-pos (string-upper-bound l)))) (defmethod (text-buffer at-buffer-start?) () % Return T if we are positioned at the start of the buffer. (and (= line-pos 0) (= char-pos 0))) (defmethod (text-buffer at-buffer-end?) () % Return T if we are positioned at the end of the buffer. (and (>= line-pos last-line) (> char-pos (string-upper-bound (vector-fetch lines last-line))))) (defmethod (text-buffer current-line-is-first?) () % Return T if the current line is the first line in the buffer. (= line-pos 0)) (defmethod (text-buffer current-line-is-last?) () % Return T if the current line is the last line in the buffer. (>= line-pos last-line)) (defmethod (text-buffer current-line-fetch) (n) % Return the character at character position N within the current line. % An error is generated if N is out of range. (with-current-line (l) (if (and (>= n 0) (<= n (string-upper-bound l))) (string-fetch l n) (ContinuableError 0 (BldMsg "Character index %w out of range." n) "") ))) (defmethod (text-buffer current-line-store) (n c) % Store the character C at char position N within the current line. % An error is generated if N is out of range. (with-current-line-copied (l) (if (and (>= n 0) (<= n (string-upper-bound l))) (progn (string-store l n c) (vector-store lines line-pos l) (setf modified? T) ) (ContinuableError 0 (BldMsg "Character index %w out of range." n) "") ))) (defmethod (text-buffer move-to-buffer-start) () % Move to the beginning of the buffer. (setf line-pos 0) (setf char-pos 0) ) (defmethod (text-buffer move-to-buffer-end) () % Move to the end of the buffer. (setf line-pos last-line) (with-current-line (l) (setf char-pos (string-length l))) ) (defmethod (text-buffer move-to-start-of-line) () % Move to the beginning of the current line. (setf char-pos 0)) (defmethod (text-buffer move-to-end-of-line) () % Move to the end of the current line. (with-current-line (l) (setf char-pos (string-length l)))) (defmethod (text-buffer move-to-next-line) () % Move to the beginning of the next line. % If already at the last line, move to the end of the line. (cond ((< line-pos last-line) (setf line-pos (+ line-pos 1)) (setf char-pos 0)) (t (=> self move-to-end-of-line)))) (defmethod (text-buffer move-to-previous-line) () % Move to the beginning of the previous line. % If already at the first line, move to the beginning of the line. (if (> line-pos 0) (setf line-pos (- line-pos 1))) (setf char-pos 0)) (defmethod (text-buffer move-forward) () % Move to the next character in the current buffer. % Do nothing if already at the end of the buffer. (if (=> self at-line-end?) (=> self move-to-next-line) (setf char-pos (+ char-pos 1)) )) (defmethod (text-buffer move-backward) () % Move to the previous character in the current buffer. % Do nothing if already at the start of the buffer. (if (> char-pos 0) (setf char-pos (- char-pos 1)) (when (> line-pos 0) (setf line-pos (- line-pos 1)) (=> self move-to-end-of-line) ))) (defmethod (text-buffer next-character) () % Return the character to the right of the current position. % Return NIL if at the end of the buffer. (with-current-line (l) (if (>= char-pos (string-length l)) (if (= line-pos last-line) NIL (char EOL) ) (string-fetch l char-pos) ))) (defmethod (text-buffer previous-character) () % Return the character to the left of the current position. % Return NIL if at the beginning of the buffer. (if (= char-pos 0) (if (= line-pos 0) NIL #\EOL) (with-current-line (l) (string-fetch l (- char-pos 1))) )) (defmethod (text-buffer insert-character) (c) % Insert character C at the current position in the buffer and advance past % that character. Implementation note: some effort is made here to avoid % unnecessary consing. (if (= c #\EOL) (=> self insert-eol) % else (with-current-line (l) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) (s (string c)) ) (when head-string (setf s (string-concat head-string s))) (when tail-string (setf s (string-concat s tail-string))) (vector-store lines line-pos s) (setf char-pos (+ char-pos 1)) (setf modified? T) )))) (defmethod (text-buffer insert-eol) () % Insert a line-break at the current position in the buffer and advance to % the beginning of the newly-formed line. Implementation note: some effort % is made here to avoid unnecessary consing. (with-current-line (l) (=> self &insert-gap line-pos 1) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) ) (vector-store lines line-pos (or head-string "")) (setf line-pos (+ line-pos 1)) (vector-store lines line-pos (or tail-string "")) (setf char-pos 0) (setf modified? T) ))) (defmethod (text-buffer insert-line) (l) % Insert the specified string as a new line in front of the current line. % Advance past the newly inserted line. Note: L henceforth must never be % modified. (=> self &insert-gap line-pos 1) (vector-store lines line-pos l) (setf line-pos (+ line-pos 1)) (setf modified? T) ) (defmethod (text-buffer insert-string) (s) % Insert the string S at the current position. Advance past the % newly-inserted string. Note: S must not contain EOL characters! Note: S % henceforth must never be modified. Implementation note: some effort is % made here to avoid unnecessary consing. (let ((insert-length (string-length s))) (when (> insert-length 0) (with-current-line (l) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) ) (when head-string (setf s (string-concat head-string s))) (when tail-string (setf s (string-concat s tail-string))) (vector-store lines line-pos s) (setf char-pos (+ char-pos insert-length)) (setf modified? T) ))))) (defmethod (text-buffer insert-text) (v) % V is a vector of strings similar to LINES (e.g., the last string in V is % considered to be an unterminated line). Thus, V must have at least one % element. Insert this stuff at the current position and advance past it. (with-current-line (l) (let ((v-last (vector-upper-bound v))) (=> self &insert-gap line-pos v-last) (let ((vec lines) (prefix-text (substring l 0 char-pos)) (suffix-text (string-rest l char-pos)) ) (vector-store vec line-pos (string-concat prefix-text (vector-fetch v 0))) (for (from i 1 v-last) (do (setf line-pos (+ line-pos 1)) (vector-store vec line-pos (vector-fetch v i)))) (setf char-pos (string-length (vector-fetch vec line-pos))) (vector-store vec line-pos (string-concat (vector-fetch vec line-pos) suffix-text)) (setf modified? T) )))) (defmethod (text-buffer delete-next-character) () % Delete the next character. % Do nothing if at the end of the buffer. (with-current-line (l) (if (= char-pos (string-length l)) (if (= line-pos last-line) NIL % else (at end of line other than last) (vector-store lines line-pos (string-concat l (vector-fetch lines (+ line-pos 1)))) (=> self &delete-lines (+ line-pos 1) 1) (setf modified? T) ) % else (not at the end of a line) (vector-store lines line-pos (string-concat (substring l 0 char-pos) (string-rest l (+ char-pos 1)) )) (setf modified? T) ))) (defmethod (text-buffer delete-previous-character) () % Delete the previous character. % Do nothing if at the beginning of the buffer. (if (not (=> self at-buffer-start?)) (progn (=> self move-backward) (=> self delete-next-character) (setf modified? T) ))) (defmethod (text-buffer read-from-stream) (s) (if (and (object-get-handler-quietly s 'getl) (object-get-handler-quietly s 'last-line-is-terminated?) ) (=> self read-from-stream-using-getl s) (=> self read-from-stream-using-getc s) )) (defmethod (text-buffer read-from-stream-using-getl) (s) (=> self reset) (let* ((getl-method (object-get-handler s 'getl)) line ) (while (setf line (apply getl-method (list s))) (=> self insert-line line) ) (if (and (not (at-buffer-start?)) (not (=> s last-line-is-terminated?)) ) (=> self delete-previous-character) ) (=> self move-to-buffer-start) (=> self set-modified? NIL) )) (defmethod (text-buffer read-from-stream-using-getc) (s) (=> self reset) (let* ((line-buffer (make-string 200 0)) (buffer-top 200) (getc-method (object-get-handler s 'getc)) line-size ch ) (while T (setf line-size 0) (setf ch (apply getc-method (list s))) (while (not (or (null ch) (= ch #\LF))) (cond ((>= line-size buffer-top) (setf line-buffer (concat line-buffer (make-string 200 0))) (setf buffer-top (+ buffer-top 200)) )) (string-store line-buffer line-size ch) (setf line-size (+ line-size 1)) (setf ch (apply getc-method (list s))) ) (if (not (and (null ch) (= line-size 0))) (=> self insert-line (sub line-buffer 0 (- line-size 1))) ) (when (null ch) (if (> line-size 0) (=> self delete-previous-character)) (exit) )) (=> self move-to-buffer-start) (=> self set-modified? NIL) )) (defmethod (text-buffer write-to-stream) (s) (let* ((vec lines) (putl-method (object-get-handler s 'putl)) ) (for (from i 0 (- last-line 1)) (do (apply putl-method (list s (vector-fetch vec i))))) (=> s puts (vector-fetch vec last-line)) )) (defmethod (text-buffer cleanup) () % Discard any unused storage. (if (and previous-buffer (not (buffer-is-selectable? previous-buffer))) (setf previous-buffer NIL)) (TruncateVector lines last-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (text-buffer init) (init-plist) (setf lines (MkVect 0)) (vector-store lines 0 "") (setf marks (ring-buffer-create 16)) (ring-buffer-push marks (buffer-position-create 0 0)) ) (defmethod (text-buffer &insert-gap) (lpos n-lines) % Insert N-LINES lines at position LPOS, moving the remaining lines upward % (if any). LPOS may range from 0 (insert at beginning of buffer) to % LAST-LINE + 1 (insert at end of buffer). The new lines are not % specifically initialized (they retain their old values). (when (> n-lines 0) (=> self &ensure-room n-lines) (let ((vec lines)) (for (from i last-line lpos -1) (do (vector-store vec (+ i n-lines) (vector-fetch vec i))) ) (setf last-line (+ last-line n-lines)) ))) (defmethod (text-buffer &ensure-room) (lines-needed) % Ensure that the LINES vector is large enough to add the specified number % of additional lines. (let* ((current-bound (vector-upper-bound lines)) (lines-available (- current-bound last-line)) (lines-to-add (- lines-needed lines-available)) ) (when (> lines-to-add 0) (let ((minimum-incr (>> current-bound 2))) % Increase by at least 25% (if (< minimum-incr 64) (setf minimum-incr 64)) (if (< lines-to-add minimum-incr) (setf lines-to-add minimum-incr)) ) (let ((new-lines (make-vector (+ current-bound lines-to-add) NIL))) (for (from i 0 current-bound) (do (vector-store new-lines i (vector-fetch lines i)))) (setf lines new-lines) )))) (defmethod (text-buffer &delete-lines) (lpos n-lines) % Remove N-LINES lines starting at position LPOS, moving the remaining lines % downward (if any) and NILing out the obsoleted lines at the end of the % LINES vector (to allow the strings to be reclaimed). LPOS may range from % 0 to LAST-LINE. (when (> n-lines 0) (let ((vec lines)) (for (from i (+ lpos n-lines) last-line) (do (vector-store vec (- i n-lines) (vector-fetch vec i))) ) (setf last-line (- last-line n-lines)) (for (from i 1 n-lines) (do (vector-store vec (+ last-line i) NIL)) ) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/nmode/text-commands.sl version [fcfe4c6f87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TEXT-COMMANDS.SL - NMODE Sentence, Paragraph, Filling, and Formatting % % Author: Jeff Soreff % Hewlett-Packard/CRC % Date: 8 December 1982 % Revised: 1 February 1983 % Revised: 2 March 1983 % % 2-Mar-83 Jeff Soreff % Mark-paragraph-command was altered to push the current position % onto the ring of marks before marking the paragraph. % 15-Feb-83 Jeff Soreff % Bugs were removed from fill-comment-command and from next-char-list. % A test for arriving at a line end was added to fill-comment-command % in the while loop which locates the fill prefix to be used. It fixed an % infinite loop in this while which occurred when one did a % fill-comment-command while on the last line in the buffer, if the % prefix-finding loop got to the buffer's end. An at-line-end? test was used % instead of an at-buffer-end? test since the fill prefix found should never % go over a line. % In next-char-list the initialization of final-char-pos was changed % from 0 to char-count. This removed a bug that led to setting the point % at the start of a prefixed line after a fill which moved point to the first % availible position on that new line. Point should have been left AFTER the % prefix. Changing the initialization of final-char-position allows % next-char-list to accurately account for the spaces taken up by the prefix, % since this count is passed to its char-count argument. % 1-Feb-83 Alan Snyder % Changed literal ^L in source to #\FF. % 30-Dec-82 Alan Snyder % Extended C-X = to set the current line number if a command number is % given. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-strings fast-int)) (fluid '(nmode-current-buffer text-mode fill-prefix fill-column nmode-command-argument nmode-command-argument-given nmode-command-number-given nmode-command-killed sentence-terminators sentence-extenders)) (setf sentence-terminators '(#/! #/. #/?)) (setf sentence-extenders '(#/' #/" #/) #/])) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % User/Enhancer option sensitive function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The text-justifier function may be altered if one wishes to have the % same flexibility as EMACS'S TECO search strings provide. (de text-justifier-command? () % This function checks to see if the rest of the line is a text % justifier command. It returns a boolean and leaves point alone. (= (next-character) #/.)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Sentence Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de valid-sentence-end? () % This function checks that a sentence is followed by two blanks, a % newline or a blank and a newline. It advances point one space. % It returns a boolean value. (if (at-line-end?) t (move-forward) (and (= (previous-character) #\blank) (or (at-line-end?)(= (next-character) #\blank))))) (de move-to-end-of-last-sentence () % This function moves point to the end of the preceding sentence, % after extenders. This function does not return a useful value (while (not (or (at-buffer-start?) (when % This when returns true if it hits a valid sentence end. (member (previous-character) sentence-terminators) (let ((scan-place (buffer-get-position))) (while (member (next-character) sentence-extenders) (move-forward)) (let* ((tentative-sentence-end (buffer-get-position)) (true-end (valid-sentence-end?))) (buffer-set-position (if true-end tentative-sentence-end scan-place)) true-end))))) (move-backward))) (de start-of-last-sentence () % This function restores point to its former place. It returns the % location of the start of the preceding sentence. (let ((place (buffer-get-position))(start nil)(end nil)) (move-to-end-of-last-sentence) (setf end (buffer-get-position)) (skip-forward-blanks) % possibly past starting position this time (setf start (buffer-get-position)) (when (buffer-position-lessp place start) (buffer-set-position end) % end of last sentence, after extenders (while % push back past extenders (member (previous-character) sentence-extenders) (move-backward)) (move-backward) % push back past sentence terminator character (move-to-end-of-last-sentence) (skip-forward-blanks) (setf start (buffer-get-position))) (buffer-set-position place) start)) (de end-of-next-sentence () % This function restores point to its former place. It returns the % location of the end of the next sentence. (let ((place (buffer-get-position))) (while (not % the next sexp detects sentence ends and moves point to them (or (at-buffer-end?) (when % note that this returns (valid-sentence-end?)'s value (member (next-character) sentence-terminators) (move-forward) (while (member (next-character) sentence-extenders) (move-forward)) (let ((tentative-sentence-end (buffer-get-position))) (if (valid-sentence-end?) (buffer-set-position tentative-sentence-end)))))) (move-forward)) (prog1 (buffer-get-position) (buffer-set-position place)))) (de forward-one-sentence () % This function moves point to the end of the next sentence or % paragraph, whichever one is closer, and does not return a useful % value. (let ((sentence-end (end-of-next-sentence))) (if (at-line-end?)(move-forward)) % kludge to get around xtra newline (forward-one-paragraph) (if (at-line-start?)(move-backward)) % kludge to get around xtra newline (let ((paragraph-end (buffer-get-position))) (buffer-set-position (if (buffer-position-lessp sentence-end paragraph-end) % "closer" is "earlier" or "before", in this case sentence-end paragraph-end))))) (de backward-one-sentence () % This function moves point to the start of the preceding sentence % or paragraph, whichever one is closer. It does not return a useful % value (let ((sentence-start (start-of-last-sentence))) (skip-backward-blanks) (backward-one-paragraph) (skip-forward-blanks) (let ((paragraph-start (buffer-get-position))) (buffer-set-position (if (buffer-position-lessp sentence-start paragraph-start) % "closer" is "later" or "after", in this case paragraph-start sentence-start))))) (de forward-sentence-command () % If nmode-command-argument is positive this function moves point % forward by nmode-command-argument sentences , leaving it at the % end of a sentence. If nmode-command-argument is negative it moves % backwards by abs(nmode-command-argument) sentences, leaving it at % the start of a sentence. This function does not return a useful % value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (backward-one-sentence))) (for (from i 1 nmode-command-argument 1) (do (forward-one-sentence))))) (de backward-sentence-command () % If nmode-command-argument is positive this function moves point % backward by nmode-command-argument sentences , leaving it at the % start of a sentence. If nmode-command-argument is negative it % moves forwards by abs(nmode-command-argument) sentences, leaving % it at the end of a sentence. This function does not return a % useful value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (forward-one-sentence))) (for (from i 1 nmode-command-argument 1) (do (backward-one-sentence))))) (de kill-sentence-command () % This function kills whatever forward-sentence-command jumps over. % It leaves point after the killed text. This function is sensitive % to the nmode command argument through forward-sentence-command. (let ((place (buffer-get-position))) (forward-sentence-command) (update-kill-buffer (extract-region t place (buffer-get-position))) (setf nmode-command-killed t))) (de backward-kill-sentence-command () % This function kills whatever backward-sentence-command jumps over. % It leaves point after the killed text. This function is sensitive % to the nmode command argument through forward-sentence-command. (let ((place (buffer-get-position))) (backward-sentence-command) (update-kill-buffer (extract-region t place (buffer-get-position))) (setf nmode-command-killed t))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Paragraph Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de rest-of-current-line-blank? () % This function detects if the rest of the line is blank. It % returns a boolean value. It restores point. (let ((last-position (buffer-get-position))) (while (and (not (at-line-end?)) (char-blank? (next-character))) (move-forward)) (prog1 (at-line-end?) (buffer-get-position last-position)))) (de mismatched-prefix? () % This function checks to see if there is a fill prefix which % doesn't match the start of the current line. It leaves point at % the start of the current line if there is a mismatch, or just % after the prefix if matched. It returns t if there is a fill % prefix which does NOT match the line's start. (move-to-start-of-line) (when fill-prefix (let ((start-line (buffer-get-position))) (move-over-characters (string-length % count of characters in fill-prefix (getv fill-prefix 0))) (when (not (text-equal (extract-text nil start-line (buffer-get-position)) fill-prefix)) (buffer-set-position start-line) t)))) (de pseudo-blank-line? () % This function tests to see if the current line should be kept out % of paragraphs. It tests for: lines which don't match an existing % fill prefix, blank lines, lines with only the fill prefix present, % text justifier commands, and properly prefixed text justifier % commands. It only checks for the text justifier commands in text % mode. It leaves point at the start of the current line and % returns a boolean value. (or (mismatched-prefix?) (prog1 (or (and (text-justifier-command?) (eq text-mode (=> nmode-current-buffer mode))) (rest-of-current-line-blank?)) (move-to-start-of-line)))) (de pseudo-indented-line? () % This function looks for page break characters or (in text mode) % indentation (after a fill prefix, if present) which signal the % start of a real paragraph. It always leaves point at the start of % the current line and returns a boolean. (prog1 (or (= #\FF (next-character)) % page break character (progn (mismatched-prefix?) (and (char-blank? (next-character)) (eq text-mode (=> nmode-current-buffer mode))))) (move-to-start-of-line))) (de start-line-paragraph? () % This function tests the current line to see if it is the first % line (not counting an empty line) in a paragraph. It leaves point % at the start of line and returns a boolean value. (and (not (pseudo-blank-line?)) (or (pseudo-indented-line?) % next sexp checks for a previous blank line (if (current-line-is-first?) t (move-to-previous-line) (prog1 (pseudo-blank-line?) (move-to-next-line)))))) (de end-line-paragraph? () % This function tests the current line to see if it is the last line % in a paragraph. It leaves point at the start of line and returns % a boolean value. (and (not (pseudo-blank-line?)) % The next sexp checks for the two things on the next line of % text that can end a paragraph: a blank line or an indented % line which would start a new paragraph. (if (current-line-is-last?) t (move-to-next-line) (prog1 (or (pseudo-indented-line?) (pseudo-blank-line?)) (move-to-previous-line))))) (de forward-one-paragraph () % This function moves point to the end of the next or current % paragraph, as EMACS defines it. This is either start of the line % after the last line with any characters or, if the paragraph % extends to the end of the buffer, then the end of the last line % with characters. This function returns a boolean which is true if % the function was stopped by a real paragraph end, rather than by % the buffer's end. (let ((true-end nil)) (while (not (or (setf true-end (end-line-paragraph?)) (current-line-is-last?))) (move-to-next-line)) (move-to-next-line) true-end)) (de forward-paragraph-command () % If nmode-command-argument is positive this function moves point % forward by nmode-command-argument paragraphs , leaving it at the % end of a paragraph. If nmode-command-argument is negative it moves % backwards by abs(nmode-command-argument) paragraphs, leaving it at % the start of a paragraph. This function does not return a useful % value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (backward-one-paragraph))) (for (from i 1 nmode-command-argument 1) (do (forward-one-paragraph))))) (de backward-one-paragraph () % This function moves point backward to the start of the previous % paragraph. It returns a boolean which is true if the function was % stopped by a real paragraph's start, instead of by the buffer's % start. (if (and (at-line-start?) % if past start of start line, don't miss (start-line-paragraph?)) % start of current paragraph (move-to-previous-line)) (let ((real-start nil)) (while (not (or (setf real-start (start-line-paragraph?)) (current-line-is-first?))) (move-to-previous-line)) (unless (current-line-is-first?) % this sexp gets previous empty line on (move-to-previous-line) (unless (current-line-empty?) (move-to-next-line))) real-start)) (de backward-paragraph-command () % If nmode-command-argument is positive this function moves point % backward by nmode-command-argument paragraphs , leaving it at the % start of a paragraph. If nmode-command-argument is negative it % moves forwards by abs(nmode-command-argument) paragraphs, leaving % it at the end of a paragraph. This function does not return a % useful value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (forward-one-paragraph))) (for (from i 1 nmode-command-argument 1) (do (backward-one-paragraph))))) (de paragraph-limits () % This function returns a list of positions marking the next % paragraph. Only real paragraph limits are returned. If there is % only stuff that should be excluded from a paragraph between point % and the end or the start of the buffer, then the appropriate limit % of the paragraph is filled with the current buffer position. This % function restores point. (let* ((temp (buffer-get-position))(top temp)(bottom temp)) (when (forward-one-paragraph) (setf bottom (buffer-get-position))) (when (backward-one-paragraph) (setf top (buffer-get-position))) (buffer-set-position temp) (list top bottom))) (de mark-paragraph-command () % This function sets the mark to the end of the next paragraph, and % moves point to its start. It returns nothing useful. (let ((pair (paragraph-limits))) (set-mark-from-point) (buffer-set-position (first pair)) (set-mark (second pair)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Fill Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de next-char-list (end char-count init-pos) % This function returns a list, the first element of which is a list % of characters, with their order the reverse of that in the % original text, spaces squeezed to a single space between words, % and with two spaces between sentences. The second element on the % list returned is how far along the new line the position % corresponding to "init-pos" wound up. Point is left after the % last character packed in but before "end" or the next nonblank % character. (let* ((from-end-last-blanks 0) (from-start-last-blanks 0) (final-char-pos char-count) (line-not-full (lessp char-count fill-column)) (first-end (buffer-get-position)) (next-sentence-wont-exhaust-region (not (buffer-position-lessp end first-end))) (new-char (next-character)) (line-list ())) % start of loop for successive sentences (while (and next-sentence-wont-exhaust-region line-not-full) % The next sexp checks to see if the next sentence fits within % the main region (from initial "point" to "end") with a % character to spare for the next sentence iteration. (let* ((next-sentence-end (end-of-next-sentence))) (setf next-sentence-wont-exhaust-region (not (buffer-position-lessp end next-sentence-end))) (setf first-end (if next-sentence-wont-exhaust-region next-sentence-end end))) (skip-forward-blanks) % ignore blanks just before next sentence % start of loop for successive characters (while (and (setf line-not-full (or (lessp char-count fill-column) % next sexp allows oversize words (eq char-count from-end-last-blanks))) (not (buffer-position-lessp first-end (buffer-get-position)))) (setf new-char % character compression sexp (let ((next (next-character))) (if (not (= (skip-forward-blanks) next)) #\blank (move-forward) next))) (setq line-list (cons new-char line-list)) (incr char-count) (when (buffer-position-lessp (buffer-get-position) init-pos) (setf final-char-pos char-count)) (cond ((= new-char #\blank) (setf from-end-last-blanks 0) (setf from-start-last-blanks 1)) (t % normal character (incr from-end-last-blanks) (incr from-start-last-blanks)))) % The next sexp terminates sentences properly. (when (and line-not-full next-sentence-wont-exhaust-region) (setf line-list (append '(#\blank #\blank) line-list)) (incr char-count 2) (setf from-end-last-blanks 0) (setf from-start-last-blanks 2))) % The next sexp trims off the last partial word or extra blank(s). (when (or (char-blank? (car line-list)) % extra blank(s) (not (or line-not-full % last partial word (at-line-end?) (char-blank? (next-character))))) (for (from i 1 from-start-last-blanks 1) (do (setf line-list (cdr line-list)))) (move-over-characters (- from-end-last-blanks))) % guarantee that buffer-position is left at or before end (if (buffer-position-lessp end (buffer-get-position)) (buffer-set-position end)) (list line-list final-char-pos))) (de justify (input desired-length) % This function pads its input with blanks and reverses it. It % leaves point alone. (let* ((input-length (length input)) (output ()) (needed-blanks (- desired-length input-length)) % total number needed to fill out line (input-blanks % count preexisting blanks in input (for (in char input) (with blanks) (count (= char #\blank) blanks) (returns blanks)))) (for (in char input) (with (added-blanks 0) % number of new blanks added so far (handled-blanks 0)) % number of input blanks considered so far (do (setf output (cons char output)) (when (= char #\blank) (incr handled-blanks) % calculate number of new blanks needed here % fraction of original blanks passed=handled-blanks/input-blanks % blanks needed here~fraction*[needed-blanks(for whole line)]-(added-blanks) (let ((new-blanks (- (/ (* needed-blanks handled-blanks) input-blanks) added-blanks))) (when (> new-blanks 0) (for (from new 1 new-blanks 1) (do (setf output (cons #\blank output)))) (incr added-blanks new-blanks)))))) output)) (de position-adjusted-for-prefix (position) % This is a pure function which returns a position, corrected for % the length of the prefix on the position's line. (let ((current-place (buffer-get-position))) (buffer-set-position position) (mismatched-prefix?) (let ((prefix-length-or-zero (current-char-pos))) (buffer-set-position current-place) (let ((adjusted-char-pos (- (buffer-position-column position) prefix-length-or-zero))) (if (< adjusted-char-pos 0)(setf adjusted-char-pos 0)) (buffer-position-create (buffer-position-line position) adjusted-char-pos))))) (de remove-prefix-from-region (start end) % The main effect of this function is to strip the fill prefix off a % region in the buffer. this function does not return a useful value % or move point. (let ((current-place (buffer-get-position))) (buffer-set-position start) (if (current-line-empty?)(move-to-next-line)) (while (not (buffer-position-lessp end (buffer-get-position))) (setf start (buffer-get-position)) (unless (or (mismatched-prefix?) (buffer-position-lessp end (buffer-get-position))) (extract-text t start (buffer-get-position))) (move-to-next-line)) (buffer-set-position current-place))) (de fill-directed-region (start end init-pos) % The main effect of this function is to replace text with filled or % justified text. This function returns a list. The first element % is the increase in the number of lines in the text due to filling. % The second element is the filled position equivalent to "init-pos" % in the original text. The point is left at the end of the new % text (let ((modified-flag (=> nmode-current-buffer modified?)) (old-text (extract-text nil start end)) (final-pos init-pos) (adj-end (position-adjusted-for-prefix end)) (adj-init-pos (position-adjusted-for-prefix init-pos))) (when fill-prefix (remove-prefix-from-region start end)) (setf end adj-end) (buffer-set-position start) (let* ((list-of-new-lines (when % handles first blank line (current-line-empty?) (move-to-next-line) '(""))) (new-packed-line '(nil 0)) (prefix-list (if fill-prefix (string-to-list (getv fill-prefix 0)))) (prefix-column (map-char-to-column (list2string prefix-list) (length prefix-list))) (new-line nil) (place (buffer-get-position)) % handles indentation (junk (skip-forward-blanks)) % handles indentation (start-char-pos (+ (current-display-column) % handles indentation prefix-column)) % and first time switch (indent-list (string-to-list % handles indentation (getv (extract-text nil place (buffer-get-position)) 0)))) (while (let* ((after-line-start (buffer-position-lessp (buffer-get-position) adj-init-pos)) (new-packed-line (next-char-list end start-char-pos adj-init-pos)) (before-line-end (buffer-position-lessp adj-init-pos (buffer-get-position)))) (when (and after-line-start before-line-end) (setf final-pos (buffer-position-create (+ (buffer-position-line start) (length list-of-new-lines)) (second new-packed-line)))) % test that anything is left in the region, as well as getting line (setf new-line (first new-packed-line))) (setf new-line (list2string (append % add in fill prefix and indentation (append prefix-list (unless (= start-char-pos prefix-column) indent-list)) (if (and nmode-command-argument-given % triggers justification (not (or % don't justify the last line in a paragraph (buffer-position-lessp end (buffer-get-position)) (at-buffer-end?)))) (justify new-line (- fill-column start-char-pos)) (reverse new-line))))) (setf list-of-new-lines (cons new-line list-of-new-lines)) % only the first line in a paragraph is indented (setf start-char-pos prefix-column)) (setf list-of-new-lines (cons (list2string nil) list-of-new-lines)) % The last line in the new paragraph is added in last setf. (let ((line-change 0) (new-text (list2vector (reverse list-of-new-lines)))) (when list-of-new-lines (extract-text t start end) (setf line-change (- (size new-text) (size old-text))) (insert-text new-text) (if (and (not modified-flag) (text-equal new-text old-text)) (=> nmode-current-buffer set-modified? nil))) (list line-change final-pos))))) (de clip-region (limits region) % This is a pure function with no side effects. It returns the % "region" position pair, sorted so that first buffer position is % the first element, and clipped so that the region returned is % between the buffer-positions in "limits". (let ((limit-pair (if (buffer-position-lessp (cadr limits) (car limits)) (reverse limits) limits)) (region-pair (copy (if (buffer-position-lessp (cadr region) (car region)) (reverse region) region)))) (if (buffer-position-lessp (car region-pair) (car limit-pair)) (setf (car region-pair) (car limit-pair))) (if (buffer-position-lessp (cadr region-pair) (car limit-pair)) (setf (cadr region-pair) (car limit-pair))) (if (buffer-position-lessp (cadr limit-pair) (car region-pair)) (setf (car region-pair) (cadr limit-pair))) (if (buffer-position-lessp (cadr limit-pair) (cadr region-pair)) (setf (cadr region-pair) (cadr limit-pair))) region-pair)) (de fill-region-command () % This function replaces the text between point and the current mark % with a filled version of the same text. It leaves the % buffer-position at the end of the new text. It does not return % anything useful. (let* ((current-place (buffer-get-position)) (limits (list (current-mark) current-place))) (setf limits (if (buffer-position-lessp (car limits) (cadr limits)) limits (reverse limits))) (buffer-set-position (car limits)) (let ((at-limits nil)(new-region nil)(lines-advance 0)) (while (not at-limits) % paragraph loop (setf new-region (paragraph-limits)) (setf new-region (clip-region limits new-region)) (setf at-limits (= (car new-region) (cadr new-region))) (unless at-limits (setf lines-advance (first (fill-directed-region % expansion-of-text-information used (car new-region) (cadr new-region) current-place))) (setf limits % compensate for expansion of filled text (list (first limits) (let ((bottom (second limits))) (buffer-position-create (+ lines-advance (buffer-position-line bottom)) (buffer-position-column bottom)))))) (setf limits % guarantee that no text is filled twice (list (buffer-get-position)(second limits))))))) (de fill-paragraph-command () % This function replaces the next paragraph with filled version. It % leaves point at the a point bearing the same relation to the % filled text that the old point did to the old text. It does not % return a useful value. (let* ((current-place (buffer-get-position)) (pos-list (paragraph-limits))) (buffer-set-position (second (fill-directed-region (first pos-list) (second pos-list) current-place))))) (de fill-comment-command () % This function creates a temporary fill prefix from the start of % the current line. It replaces the surrounding paragraph % (determined using fill-prefix) with a filled version. It leaves % point at the a position bearing the same relation to the filled % text that the old point did to the old text. It does not return a % useful value. (let ((current-place (buffer-get-position))) (move-to-start-of-line) (let ((place (buffer-get-position))) % get fill prefix ends set up (skip-forward-blanks-in-line) (while (not (or (alphanumericp (next-character)) (at-line-end?) (char-blank? (next-character)))) (move-forward)) (skip-forward-blanks-in-line) (let* ((fill-prefix (extract-text nil place (buffer-get-position))) (pos-list (paragraph-limits))) (if (buffer-position-lessp (first pos-list) current-place) (buffer-set-position (second (fill-directed-region (first pos-list) (second pos-list) current-place))) (buffer-set-position current-place)))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Misc Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de center-current-line () % This function trims and centers the current line. It does not % return a useful value. It leaves point at a point in the text % equivalent to that before centering. (current-line-strip-indent) (let ((current-place (buffer-get-position))) (move-to-end-of-line) (strip-previous-blanks) (buffer-set-position current-place)) (let ((needed-blanks (/ (- fill-column (current-display-column)) 2))) (unless (minusp needed-blanks) (indent-current-line needed-blanks)))) (de center-line-command () % This function centers a number of lines, depending on the % argument. It leaves point at the end of the last line centered. % It does not return a useful value. (center-current-line) (when (> (abs nmode-command-argument) 1) (if (minusp nmode-command-argument) (for (from i 2 (- nmode-command-argument) 1) (do (move-to-previous-line) (center-current-line))) (for (from i 2 nmode-command-argument 1) (do (move-to-next-line) (center-current-line)))))) (de what-cursor-position-command () % This function tells the user where they are in the buffer or sets % point to the specified line number. It does not return a useful % value. (cond (nmode-command-number-given (set-line-pos nmode-command-argument) ) (t (write-message (if (at-buffer-end?) (bldmsg "X=%w Y=%w line=%w (%w percent of %w lines)" (current-display-column) (- (current-line-pos)(current-window-top-line)) (current-line-pos) (/ (* 100 (current-line-pos)) (current-buffer-visible-size)) (current-buffer-visible-size)) (bldmsg "X=%w Y=%w CH=%w line=%w (%w percent of %w lines)" (current-display-column) (- (current-line-pos)(current-window-top-line)) (next-character) % omitted at end of buffer (current-line-pos) (/ (* 100 (current-line-pos)) (current-buffer-visible-size)) (current-buffer-visible-size)))) ))) |
Added psl-1983/3-1/nmode/wait.sl version [38939cff95].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Wait.SL - Wait Primitive (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 19-June-1983 Mark R. Swanson % Changed timeout-wait to accept a third argument: a list of args for F, its % first arg. This routine is nearly identical to WAIT-TIMEOUT, found in % P20U:WAIT.SL and could replace it if calls on WAIT-TIMEOUT are converted to % three args. (CompileTime (load fast-int)) (BothTimes (load jsys)) (de timeout-wait (f args n-60ths) % Return when either of two conditions are met: (1) The function F (of no % arguments) returns non-NIL; (2) The specified elapsed time (in units of % 1/60th second) has elapsed. Don't waste CPU cycles! Return the last % value returned by F (which is always invoked at least once). (let (result) (while (and (not (setf result (apply f args))) (> n-60ths 0)) (Jsys0 250 0 0 0 (const jsDISMS)) (setf n-60ths (- n-60ths 15)) ) result )) |
Added psl-1983/3-1/nmode/window-label-rewrite.sl version [f5602b39c6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Some people desire a different date format on the status line. By % setting *DateSelect* to the appropriate value (see Clockdatetime in % exec), this will be done. (Global '(*DateSelect*)) (defmethod (window-label &rewrite) () % Unconditionally rewrite the entire label. (let ((buffer (=> window buffer))) (setf screen (=> window screen)) (setf buffer-name (=> buffer name)) (setf buffer-mode (=> buffer mode)) (setf minor-modes nmode-minor-modes) (setf buffer-file (=> buffer file-name)) (setf buffer-top (=> window buffer-top)) (setf buffer-left (=> window buffer-left)) (setf buffer-size (=> buffer visible-size)) (setf buffer-modified (=> buffer modified?)) (setf current-window nmode-major-window) (if PromptString* (setf prompt-string PromptString*)) (let ((old-enhancement (=> screen default-enhancement))) (=> screen set-default-enhancement label-enhancement) (setf pos 0) (if (eq window current-window) (progn (cond ((telerayp) (=> self &write-char 132))) (=> self &write-string "NMODE ") (cond ((telerayp) (=> self &write-char 136)))) (progn (cond ((telerayp) (=> self &write-char 136))) (=> self &write-string " ") (cond ((telerayp) (=> self &write-char 136))))) (=> self &write-string (concat (clocktimedate *DateSelect*) " ")) (=> self &write-string (getloadaverage)) (=> self &write-string (=> buffer-mode name)) (if (and minor-modes (eq window current-window)) (let ((leader-string " (")) (for (in minor-mode minor-modes) (do (=> self &write-string leader-string) (setf leader-string " ") (=> self &write-string (=> minor-mode name)) )) (=> self &write-string ")") )) % Omit the buffer name if it is directly derived from the file name. (cond ((or (not buffer-file) (not (string= buffer-name (filename-to-buffername buffer-file)))) (=> self &write-string " [") (=> self &write-string buffer-name) (=> self &write-string "]") )) (when buffer-file (=> self &write-string " ") (=> self &write-string buffer-file) ) (when (> buffer-left 0) (=> self &write-string " >") (=> self &write-string (BldMsg "%d" buffer-left)) ) (cond ((and (= buffer-top 0) (<= buffer-size (=> window height))) % The entire buffer is showing on the screen. % Do nothing. ) ((= buffer-top 0) % The window is showing the top end of the buffer. (=> self &write-string " --TOP--") ) ((>= buffer-top (- buffer-size (=> window height))) % The window is showing the bottom end of the buffer. (=> self &write-string " --BOT--") ) (t % Otherwise... (let ((percentage (/ (* buffer-top 100) buffer-size))) (=> self &write-string " --") (=> self &write-char (+ #/0 (/ percentage 10))) (=> self &write-char (+ #/0 (// percentage 10))) (=> self &write-string "%--") ))) (if buffer-modified (=> self &write-string " *")) (when (and (StringP prompt-string) (eq buffer nmode-output-buffer)) (=> self &write-string " ") (=> self &advance-pos (- width (string-length prompt-string))) (=> screen set-default-enhancement prompt-enhancement) (=> self &write-string prompt-string) ) (=> screen clear-to-eol maxrow pos) (=> screen set-default-enhancement old-enhancement) ))) (de telerayp nil (eq terminal-type 7)) |
Added psl-1983/3-1/nmode/window-label.sl version [588d56dbf7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Window-Label.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 January 1983 % Revised: 14 March 1983 % % A Window-Label object maintains the "label" portion of a buffer-window. % This always occupies the lowermost "n" lines of the virtual screen, % where "n" is 1 by default in this implementation. % % 14-Mar-83 Alan Snyder % Extend to handle buffers with no name. Extend to display label-string % attribute of buffers. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 10-Feb-83 Alan Snyder % Fix bug: minor modes did not display. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors fast-strings display-char)) (de create-window-label (w) % Create a window-label object that will maintain the label portion % of the specified buffer-window. (make-instance 'window-label 'window w)) (defflavor window-label (window % the buffer-window object (height 1) % number of screen rows occupied by the label minrow % location of top row of the label maxrow % location of the bottom row of the label width % width of the screen maxcol % highest numbered screen column pos % current position while writing label screen % output screen while writing label (label-enhancement (dc-make-enhancement-mask INVERSE-VIDEO)) (prompt-enhancement (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY)) % The following instance variables store the various information used % in the construction of the label as currently displayed. This information % is saved so that it can be compared against the current information % to determine whether the displayed label needs to be recomputed. (buffer-name NIL) % name of buffer (as displayed) (buffer-mode NIL) % buffer's mode (as displayed) (minor-modes NIL) % minor mode list (as displayed) (buffer-file NIL) % buffer's filename (as displayed) (buffer-top NIL) % buffer-top (as used in label) (buffer-left NIL) % buffer-left (as used in label) (buffer-size NIL) % current buffer size (as used in label) (buffer-modified NIL) % buffer-modified flag (as used in label) (current-window NIL) % current-window (at time label was written) (prompt-string NIL) % PromptString* (at time label was written) (label-string NIL) % label-string attribute of buffer (browser-filter-count NIL) % filter count for browser buffer ) () (gettable-instance-variables height ) (settable-instance-variables label-enhancement prompt-enhancement ) (initable-instance-variables window height ) ) (fluid '(nmode-major-window nmode-output-buffer nmode-minor-modes)) (declare-flavor text-buffer buffer) (declare-flavor buffer-window window) (declare-flavor virtual-screen screen) (declare-flavor browser browser) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (window-label refresh) () % Update the label are to correspond to the % current state of the attached buffer window. % Conditionally rewrite the entire label, if any relevant % information has changed. (let* ((buffer (=> window buffer)) (browser (=> buffer get 'browser)) ) (if (not (and (eq buffer-name (=> buffer name)) (eq buffer-mode (=> buffer mode)) (eq minor-modes nmode-minor-modes) (eq buffer-file (=> buffer file-name)) (= buffer-top (=> window buffer-top)) (= buffer-left (=> window buffer-left)) (= buffer-size (=> buffer visible-size)) (eq buffer-modified (=> buffer modified?)) (eq current-window nmode-major-window) (eq prompt-string PromptString*) (eq label-string (=> buffer label-string)) (eq browser-filter-count (when browser (=> browser filter-count))) )) (=> self &rewrite) ))) (defmethod (window-label resize) () % This method must be invoked whenever the window's size may have changed. (setf screen (=> window screen)) (setf width (=> screen width)) (setf maxrow (- (=> screen height) 1)) (setf minrow (- maxrow (- height 1))) (setf maxcol (- width 1)) (setf buffer-name T) % force complete rewrite ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (window-label init) (init-plist) (=> self resize) ) (defmethod (window-label &rewrite) () % Unconditionally rewrite the entire label. (let* ((buffer (=> window buffer)) (browser (=> buffer get 'browser)) ) (setf screen (=> window screen)) (setf buffer-name (=> buffer name)) (setf buffer-mode (=> buffer mode)) (setf minor-modes nmode-minor-modes) (setf buffer-file (=> buffer file-name)) (setf buffer-top (=> window buffer-top)) (setf buffer-left (=> window buffer-left)) (setf buffer-size (=> buffer visible-size)) (setf buffer-modified (=> buffer modified?)) (setf current-window nmode-major-window) (if PromptString* (setf prompt-string PromptString*)) (setf label-string (=> buffer label-string)) (setf browser-filter-count (when browser (=> browser filter-count))) (let ((old-enhancement (=> screen default-enhancement))) (=> screen set-default-enhancement label-enhancement) (setf pos 0) (if (eq window current-window) (=> self &write-string "NMODE ") (=> self &write-string " ")) (=> self &write-string (=> buffer-mode name)) (if (and minor-modes (eq window current-window)) (let ((leader-string " (")) (for (in minor-mode minor-modes) (do (=> self &write-string leader-string) (setf leader-string " ") (=> self &write-string (=> minor-mode name)) )) (=> self &write-string ")") )) % Omit the buffer name if it is directly derived from the file name. (cond ((and buffer-name (or (not buffer-file) (not (string= buffer-name (filename-to-buffername buffer-file))) )) (=> self &write-string " [") (=> self &write-string buffer-name) (=> self &write-string "]") )) (when buffer-file (=> self &write-string " ") (=> self &write-string buffer-file) ) (when (and label-string (not (string-empty? label-string))) (=> self &write-string " ") (=> self &write-string label-string) ) (when (and browser-filter-count (> browser-filter-count 0)) (=> self &write-string (bldmsg " <%w %w>" browser-filter-count (if (~= browser-filter-count 1) "filters" "filter") )) ) (when (> buffer-left 0) (=> self &write-string (bldmsg " >%d" buffer-left)) ) (cond ((and (= buffer-top 0) (<= buffer-size (=> window height))) % The entire buffer is showing on the screen. % Do nothing. ) ((= buffer-top 0) % The window is showing the top end of the buffer. (=> self &write-string " --TOP--") ) ((>= buffer-top (- buffer-size (=> window height))) % The window is showing the bottom end of the buffer. (=> self &write-string " --BOT--") ) (t % Otherwise... (let ((percentage (/ (* buffer-top 100) buffer-size))) (=> self &write-string " --") (=> self &write-char (+ #/0 (/ percentage 10))) (=> self &write-char (+ #/0 (// percentage 10))) (=> self &write-string "%--") ))) (if buffer-modified (=> self &write-string " *")) (when (and (StringP prompt-string) (eq buffer nmode-output-buffer)) (=> self &write-string " ") (=> self &advance-pos (- width (string-length prompt-string))) (=> screen set-default-enhancement prompt-enhancement) (=> self &write-string prompt-string) ) (=> screen clear-to-eol maxrow pos) (=> screen set-default-enhancement old-enhancement) ))) (defmethod (window-label &write-string) (string) (for (from i 0 (string-upper-bound string)) (do (=> screen write (string-fetch string i) maxrow pos) (setf pos (+ pos 1)) ))) (defmethod (window-label &write-char) (ch) (=> screen write ch maxrow pos) (setf pos (+ pos 1)) ) (defmethod (window-label &advance-pos) (col) (while (< pos col) (=> self &write-char #\space)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor buffer screen window browser) |
Added psl-1983/3-1/nmode/window.sl version [64e36497fa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Window.SL - Commands and Functions for manipulating windows. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 30 December 1982 % % 30-Dec-82 Alan Snyder % Change scrolling commands to Ding if no scrolling is actually done. Fix bug % in backwards scroll by pages that failed to preserve relative cursor % position. Change behavior of scroll-by-pages upon excessive request. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-current-window nmode-command-argument nmode-command-number-given nmode-command-argument-given nmode-layout-mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-window-height () % Return the number of text lines displayable on the current window. (=> nmode-current-window height)) (de current-window-top-line () % Return the index of the buffer line at the top of the current window. (=> nmode-current-window buffer-top) ) (de current-window-set-top-line (new-top-line) % Change which buffer line displays at the top of the current window. (=> nmode-current-window set-buffer-top new-top-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de scroll-window-according-to-command (w) % Scroll the contents of the specified window according to the command % argument. If the command argument was set by C-U or C-U -, then scroll the % contents of the window up or down one page. Otherwise, scroll the window up % or down the specified number of lines. (if (and (or (= nmode-command-argument 1) (= nmode-command-argument -1)) (not nmode-command-number-given)) (scroll-window-by-pages w nmode-command-argument) (scroll-window-by-lines w nmode-command-argument) )) (de scroll-window-by-lines (w n) % Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines. % The "window position" may be adjusted to keep it within the window. Ding if % the window contents does not move. (let* ((old-top-line (=> w buffer-top)) (new-top-line (+ old-top-line n)) ) % adjust to keep something in the window (let ((buffer-last-line (- (=> (=> w buffer) visible-size) 1))) (cond ((< new-top-line 0) (setf new-top-line 0)) ((> new-top-line buffer-last-line) (setf new-top-line buffer-last-line)) )) % adjust "window position" if no longer in window (let ((line (=> w line-position)) (max (+ new-top-line (- (=> w height) 1))) ) (cond ((< line new-top-line) (=> w set-line-position new-top-line)) ((> line max) (=> w set-line-position max)) )) (if (~= old-top-line new-top-line) (=> w set-buffer-top new-top-line) (Ding) ))) (de scroll-window-by-pages (w n) % Scroll the contents of the window up (n > 0) or down (n < 0) by |n| % screenfuls. The "window position" may be adjusted to keep it within the % window. Ding if the window contents does not move. (let* ((old-top-line (=> w buffer-top)) (window-height (=> w height)) (buffer-last-line (- (=> (=> w buffer) visible-size) 1)) (new-top-line old-top-line) ) (if (>= n 0) % moving towards the end of the buffer (for (from i 1 n) % do as many complete screenfuls as possible (do (let ((next-top-line (+ new-top-line window-height))) (if (<= next-top-line buffer-last-line) (setf new-top-line next-top-line) (exit) )))) % moving towards the beginning of the buffer (setf new-top-line (max 0 (+ new-top-line (* n window-height)))) ) (if (~= new-top-line old-top-line) % keep the cursor at the same relative location in the window! (let ((delta (- new-top-line old-top-line))) (=> w set-line-position (min (+ (=> w line-position) delta) (+ buffer-last-line 1))) (=> w set-buffer-top new-top-line) ) % otherwise (no change) (Ding) ))) (de scroll-window-horizontally (w n) % Scroll the contents of the specified window left (n > 0) or right (n < 0) % by |n| columns. (let ((old-buffer-left (=> w buffer-left))) (=> w set-buffer-left (+ old-buffer-left n)) (if (= old-buffer-left (=> w buffer-left)) (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de next-screen-command () (scroll-window-according-to-command nmode-current-window) ) (de previous-screen-command () (setf nmode-command-argument (- 0 nmode-command-argument)) (scroll-window-according-to-command nmode-current-window) ) (de scroll-other-window-command () (selectq nmode-layout-mode (1 (Ding)) (2 (scroll-window-according-to-command (nmode-other-window))) )) (de scroll-window-up-line-command () (scroll-window-by-lines nmode-current-window nmode-command-argument) ) (de scroll-window-down-line-command () (scroll-window-by-lines nmode-current-window (- nmode-command-argument)) ) (de scroll-window-up-page-command () (scroll-window-by-pages nmode-current-window nmode-command-argument) ) (de scroll-window-down-page-command () (scroll-window-by-pages nmode-current-window (- nmode-command-argument)) ) (de scroll-window-right-command () (scroll-window-horizontally nmode-current-window nmode-command-argument) ) (de scroll-window-left-command () (scroll-window-horizontally nmode-current-window (- nmode-command-argument)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Adjusting Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-adjust-window (w) % Adjust BUFFER-TOP to show current position. (=> w adjust-window) ) (de move-to-screen-edge-command () (let* ((n nmode-command-argument) (line (current-line-pos)) (top (current-window-top-line)) (height (current-window-height)) ) (set-line-pos (+ top (cond ((not nmode-command-argument-given) (/ height 2)) ((>= n 0) n) (t (+ height n)) ))))) |
Added psl-1983/3-1/nonkernel/char-macro.b version [6ce081b906].
cannot compute difference between binary files
Added psl-1983/3-1/nonkernel/char-macro.sl version [6490dac554].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR-MACRO.SL - Character constant macro % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 1 Feb 1983 1355-PST % pk:char.red merged with the version in USEFUL. Some symbolic names % for characters removed (not needed, I hope). (dm Char (U) %. Character constant macro (DoChar (cadr U))) % Table driven char macro expander (de DoChar (u) (cond ((idp u) (or (get u 'CharConst) ((lambda (n) (cond ((lessp n 128) n))) (id2int u)) (CharError u))) ((pairp u) % Here's the real change -- let users add "functions" ((lambda (fn) (cond (fn (apply fn (list (dochar (cadr u))))) (t (CharError u)))) (cond ((idp (car u)) (get (car u) 'char-prefix-function))))) ((and (fixp u) (geq u 0) (leq u 9)) (plus u #\!0)) (t (CharError u)))) (deflist `((lower ,(function (lambda(x) (lor x 2#100000)))) (quote ,(function (lambda(x) x))) (control ,(function (lambda(x) (land x 2#11111)))) (cntrl ,(function (lambda(x) (land x 2#11111)))) (meta ,(function (lambda(x) (lor x 2#10000000))))) 'char-prefix-function) (de CharError (u) (ErrorPrintF "*** Unknown character constant: %r" u) 0) (DefList '((NULL 0) (BELL 7) (BACKSPACE 8) (TAB 8#11) (LF 8#12) % (RETURN 8#12) % RETURN is LF: it's end-of-line. Out! /csp (EOL 8#12) (FF 8#14) (CR 8#15) (ESC 27) (ESCAPE 27) (BLANK 32) (SPACE 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177) ) 'CharConst) |
Added psl-1983/3-1/psl/news-28-aug-82.txt version [01c69b30f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 30-Jul-82 17:06:17-PDT,2293;000000000001 Date: 30 Jul 1982 1706-PDT From: Alan Snyder <AS> Subject: NEW EMODE To: PSL-News: ;, PSL-Users: ; cc: AS ------------------------------ EMODE Changes ------------------------------ A new PSL has been installed with the following changes made to EMODE: 1. C-X C-R (Read File) now replaces the contents of the current buffer with the contents of the file, instead of inserting the contents of the file at the current location in the buffer. This is an INCOMPATIBLE change. (If you want to insert a file, you can first read it into an auxiliary buffer.) 2. File INPUT and OUTPUT have been speeded up greatly (by a factor of 5). Still noticably slower than EMACS, however. 3. Three bugs in file I/O have been fixed: (a) EMODE no longer treats a ^Z in a file as an end-of-file mark; (b) EMODE will no longer lose the last line of a file should it lack a terminating CRLF; (c) EMODE no longer appends a spurious blank line when writing to a file. 4. Many more EMACS commands have been implemented (see list below). Please note that Lisp Indentation (available using TAB, LineFeed, and C-M-Q) makes many bad choices. These deficiencies are known, but it was decided that in this case something was better than nothing. Complaints about indentation are considered redundant. Send bug reports to "PSL@Hulk". New EMODE commands: C-Q (Quoted Insert) M-\ (Delete Horizontal Space) C-X C-O (Delete Blank Lines) M-M and C-M-M (Back to Indentation) M-^ (Delete Indentation) M-@ (Mark Word) C-X H (Mark Whole Buffer) C-M-@ (Mark Sexp) Tab (Indent for Lisp) LineFeed (Indent New Line) C-M-U (Backward Up List) [ should also be C-M-( ] C-M-O (Forward Up List) [ should be C-M-) ] C-M-A and C-M-[ (Beginning of Defun) C-M-D (Down List) C-M-E and C-M-] (End of Defun) C-M-H (Mark Defun) C-M-N (Next List) C-M-P (Previous List) C-M-Q (Indent Sexp) M-( (Insert Parens) M-) (Move over Paren) ------------------------------------------------------------------------------- ------- 10-Aug-82 17:02:41-PDT,1652;000000000001 Date: 10 Aug 1982 1702-PDT From: Cris Perdue <Perdue> Subject: Latest, hottest PSL news To: PSL-News: ;, PSL-Users: ; PSL NEWS FLASH!! -- August 10, 1982 CATCH An implementation of CATCH with "correct" semantics is on its way. Eric Benson has an implementation that allows code for the body of the CATCH to be compiled in line. Variables used free inside the body will not have to be declared fluid. Unhandled exceptions will, unfortunately, continue to result in abort to the top level. BUG FIXES Be sure to peruse PSL:BUGS.TXT. In addition to an invaluable compilation of commentary, bug reports and just plain flaming, this file contains reports of some fixes to bugs! TOKEN SCANNER FOUND WANTING The current PSL token scanner has been tried in the balance and found wanting. Eric Benson says it was ripped off from some other token scanner in rather a hurry and needs to be replaced. PACKAGE SYSTEM ALSO FOUND WANTING Sources close to Doug Lanam report that the PSL "package system" is not adequate. We asked Martin Griss, "What about the package system?". He admitted the inadequacy, calling the package system "experimental" and saying that the fasloader needs to know about packages. EMODE IMPROVED AND DOCUMENTED Some improvements to EMODE are described in the key documentation file PSL:HP-PSL.IBM (and .LPT). Enhancements continue at a rapid pace, leading one experienced observer to comment, "Looks like Alan has really been tearing into EMODE -- impressive!". The file PE:DISPATCH.DOC contains some key information on customization of EMODE. More reports to come. ------- 16-Aug-82 09:59:32-PDT,520;000000000001 Date: 16 Aug 1982 0959-PDT From: Alan Snyder <AS> Subject: New PSL To: PSL-News: ;, PSL-Users: ; cc: AS A new version of "NPSL" has been installed with the following changes: * EMODE now uses clear-EOL for faster redisplay. * EMODE's start-up glitches have been removed. EMODE will now start up in 1-window mode. * A "compile" command has been added; you can now say "PSL compile foo" to EXEC to compile the file "foo.sl". (This feature has been added to both PSL and NPSL.) ------- |
Added psl-1983/3-1/psl/news.txt version [5537baf101].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 28-Sep-82 17:50:20-PDT,3097;000000000000 Date: 28 Sep 1982 1750-PDT From: Alan Snyder <AS> Subject: new PSL!!!! To: PSL-News: ;, PSL-Users: ; cc: AS Important Change to PSL! We have installed a new version of PSL on HULK. It contains a number of significant changes which are described here. In addition, you must change your LOGIN.CMD file to TAKE PSL:LOGICAL-NAMES.CMD instead of <PSL>LOGICAL-NAMES.CMD. The <PSL> directory will disappear soon, so make this change right away! [These changes, except for NMODE, will appear on THOR and HEWEY shortly. There are no immediate plans to move NMODE to the Vax.] Summary of changes: * If you run "PSL", you will now get a PSL that contains the NMODE editor, which is a replacement for EMODE. PSL will start up in the editor, instead of the PSL listen loop. You can easily get back to the PSL listen loop from NMODE by typing C-] L. NMODE is a decent subset of EMACS, so if you are familiar with EMACS you should be able to use NMODE without too much difficulty. If you are familiar with EMODE, you should read the file PSL:NMODE-GUIDE.TXT, which explains the differences between NMODE and EMODE. A printed copy of this memo, including the NMODE command chart, is available in the documentation area next to Helen Asakawa's office. * The "PSL" program (what you get when you say "PSL" to EXEC) no longer contains the PSL compiler. Instead, there is a separate program for compiling (Lisp) files. To compile a file "FOO.SL", give the command "PSLCOMP FOO" to EXEC. PSLCOMP will produce a binary file "FOO.B" that can then be LOADed or FASLINed. To run the compiler interactively, just say "PSLCOMP" to EXEC. * The PSL directories that contain the source and binaries for all PSL modules have been moved to a private structure called SS: (the directories are now SS:<PSL*>). The old PSL directories (PS:<PSL*>) will disappear soon. In addition, the new directories have been reorganized somewhat to better reflect the structure of the implementation. The file PSL:-THIS-.DIRECTORY contains a brief description of the new structure. If you have used logical names to refer to PSL directories, then this change should not cause too many problems. * A number of small bug fixes and improvements have been made. The most notable improvements are (1) a more readable backtrace, (2) a better prettyprinter, and (3) the definition of a "complete" set of I/O functions taking an explicit channel argument (these functions all have names like ChannelTerpri, where Terpri is an example of an I/O function that uses the default I/O channels). The file PSL:BUG-FIX.LOG contains an exhaustive listing of the recent changes. The documentation has been updated to reflect these changes. The following new or revised documents are available in the documentation area next to Helen Asakawa's office: Notes on PSL at HP DEC-20 PSL New Users' Guide NMODE for EMODE Users How to customize NMODE We have made "documentation packets" containing copies of these documents. Users are encouraged to pick up a copy! ------- 11-Oct-82 15:55:41-PDT,5771;000000000000 Date: 11 Oct 1982 1555-PDT From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; cc: AS PSL NEWS - 11 October 1982 A new PSL has been installed on Hulk and Hewey. There are a number of improvements, plus some INCOMPATIBLE changes (see below). A most noticable change (on Hulk) is that PSL no longer automatically starts up in the NMODE editor. However, if you want PSL to start up in the editor, you can still make this happen using another new feature, INIT files (see below). Otherwise, you can explicitly enter NMODE by invoking the function NMODE, with no arguments. In addtion, NMODE now supports the extended VT52 emulator on the 9836 (get the latest version from Tracy). (No, NMODE is not yet installed on Hewey.) ------------------------------------------------------------------------------- INCOMPATIBLE CHANGES TO PSL: ------------------------------------------------------------------------------- This latest version of PSL has 3 changes which may require some application programs to be changed: 1. SAVESYSTEM SaveSystem now takes 3 arguments. The first argument is the banner, the second is the file to be written, and the third is a list of forms to evaluated when the new core image is started. For example: (SaveSystem "PSL 3.1" "PSL.EXE" '((InitializeInterrupts))) 2. DUMPLISP Dumplisp now takes 1 argument, the file to be written. For example: (Dumplisp "PSL.EXE") 3. DSKIN Dskin has been changed from a FEXPR to a single-argument EXPR. This should only affect calls to DSKIN with multiple arguments. They will have to be changed to several calls, each with one argument. 4. BR and UNBR The functions BR and UNBR are no longer part of PSL. These functions provided a facility for breaking on entry and exit to specific functions. However, they didn't work very well and no one has figured out how to make them work, so they have been removed. Send complaints to PSL. ------------------------------------------------------------------------------- MAJOR IMPROVEMENTS TO PSL: ------------------------------------------------------------------------------- The following features have been added to PSL: 1. Init files When PSL, RLISP, or PSLCOMP (note: not BARE-PSL) is executed, if a file PSL.INIT, RLISP.INIT, or PSLCOMP.INIT, respectively, is in your home (login) directory, it will be read and evaluated. This allows you to automatically customize your Lisp environment. (The init files are .pslrc, .rlisprc, and .pslcomprc on the Vax.) If you want PSL to come up in NMODE, include the statement (setf nmode-auto-start T) in your PSL.INIT file. 2. Prinlevel and Prinlength The variables PRINLEVEL and PRINLENGTH now exist, as described in the Common Lisp Reference Manual. These variables allow you to limit the depth of printing of nested structures and the number of elements of structured objects printed. These variables affect Prin1 and Prin2 (Princ) and those functions that use them (Printf, Print). They do not currently affect Prettyprint, although this may be done in the future. The Printx function now properly handles circular vectors. ------------------------------------------------------------------------------- CHANGES TO NMODE: ------------------------------------------------------------------------------- * NMODE also supports init files (this isn't new, but wasn't stressed in previous documentation). When NMODE starts up, it will read and execute the file NMODE.INIT in the user's home (login) directory. This file should contain PSL (Lisp) forms. * NMODE now reads a default init file if the user has no personal init file. The name of this default init file is "PSL:NMODE.INIT". If you make your own NMODE.INIT file, you should consider including in it the statement "(nmode-read-and-evaluate-file nmode-default-init-file-name)", which will execute the default init file. * NMODE now supports the 9836 VT52 emulator (which has recently been extended to accept commands to change the display enhancement). The default NMODE init file will set up the NMODE VT52 driver if the system terminal type is VT52. * NMODE no longer always starts up in the editor after it is RESET, ABORTed, or ^C'ed and STARTed. It will only restart in the editor if it was in the editor beforehand. * NMODE will now read and write files containing stray CRs. * M-X command completion is more like EMACS. * Typing an undefined command now tells you what command you typed. * New commands: C-X C-L (Lowercase Region) C-X C-U (Uppercase Region) C-X E (Exchange Windows) C-X ^ (Grow Window) M-' (Upcase Digit) M-C (Uppercase Initial) M-L (Lowercase Word) M-U (Uppercase Word) M-X Append to File M-X DIRED M-X Delete File M-X Delete and Expunge File M-X Edit Directory M-X Find File M-X Insert Buffer M-X Insert File M-X Kill Buffer M-X Kill File M-X List Buffers M-X Prepend to File M-X Query Replace M-X Replace String M-X Save All Files M-X Select Buffer M-X Undelete File M-X Visit File M-X Write File M-X Write Region (Case conversion commands contributed by Jeff Soreff) * Some bugs relating to improper window adjustment have been fixed. For example, when the bottom window "pops up", the top window will now be adjusted. Also, C-X O now works properly in 1-window mode when the two windows refer to the same buffer (i.e., it switches between two independent buffer positions). * Bug fix: It should no longer be possible to find a "killed" buffer in a previously unexposed window. ------- 9-Nov-82 08:17:56-PST,4505;000000000000 Date: 9 Nov 1982 0817-PST From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; A new version of PSL has been installed on Hulk. Here are the details: New PSL Changes (9 November 1982) ---- PSL Changes ------------------------------------------------------------- * The major change in PSL is that CATCH/THROW has been reimplemented to conform to the Common Lisp definition (see Section 7.10 of the Common Lisp manual). In particular, CATCH has been changed to a special form so that its second argument is evaluated only once, instead of twice. THIS IS AN INCOMPATIBLE CHANGE: if you use CATCH, you must change your programs. For example, if you wrote: (catch 'foo (list 'frobnicate x y z)) you should change it to: (catch 'foo (frobnicate x y z)) One aspect of this change is that an "unhandled" throw is now reported as an error in the context of the throw, rather than (as before) aborting to top-level and restarting the job. Also implemented are UNWIND-PROTECT, CATCH-ALL, and UNWIND-ALL, as described in the Common Lisp manual, with the exception that the catch-function in CATCH-ALL and UNWIND-ALL should expect exactly 2 arguments. Note that in Common Lisp, the proper way to catch any throw is to use CATCH-ALL, not CATCH with a tag of NIL. * A related change is that the RESET function is now implemented by THROWing 'RESET, which is caught at the top-level. Thus, UNWIND-PROTECTs cannot be circumvented by RESET. ---- NMODE Changes ----------------------------------------------------------- New Features: * C-X C-B now enters a DIRED-like "Buffer Browser" that allows you to select a buffer, delete buffers, etc. * DIRED and the Buffer Browser can now operate in a split-screen mode, where the upper window is used for displaying the buffer/file list and the bottom window is used to examine a particular buffer/file. This mode is enabled by setting the variable BROWSER-SPLIT-SCREEN to T. If this variable is NIL, then DIRED and the Buffer Browser will automatically start up in one window mode. * M-X Apropos has been implemented. It will show you all commands whose corresponding function names contain a given string. Thus, if you enter "window", you will see all commands whose names include the string "window", such as "ONE-WINDOW-COMMAND". * M-X Auto Fill Mode has been implemented by Jeff Soreff, along with C-X . (Set Fill Prefix) and C-X F (Set Fill Column). If you want NMODE to start up in Auto Fill mode, put the following in your NMODE.INIT file: (activate-minor-mode auto-fill-mode) * NMODE now attempts to display a message whenever PSL is garbage-collecting. This feature is not 100% reliable: sometimes a garbage collect will happen and no message will be displayed. Minor Improvements: * C-N now extends the buffer (like EMACS) if typed without a command argument while on the last line of the buffer. * Lisp break handling has been made more robust. In particular, NMODE now ensures that IN* and OUT* are set to reasonable values. * The OUTPUT buffer now starts out with the "modified" attribute ("*") off. * The implementation of command prefix characters (i.e., C-X, M-X, C-], and Escape) and command arguments (i.e., C-U, etc.) has changed. The most visible changes are that C-U, etc. echo differently, and that Escape can now be followed by bit-prefix characters. (In other words, NMODE will recognize "Escape ^\ E" as Esc-M-E, rather than "Esc-C-\ E"; the 9836 terminal emulator has been modified to generate such escape sequences under some circumstances.) NMODE customizers may be interested to know that all of these previously-magic characters can now be redefined (on a per-mode basis, even), just like any other character. * If you are at or near the end of the buffer, NMODE will put the current line closer to the bottom of the screen when it adjusts the window. * C-X C-F (Find File) and the Dired 'E' command will no longer "find" an incorrect version of the specified file, should one happen to already be in a buffer. * The 'C' (continue) command to the PSL break loop now works again. * The "NMODE" indicator on the current window's mode line no longer disappears when the user is entering string input. * The command C-X 4 F (Find File in Other Window) now sets the buffer's file name properly. ------- 6-Dec-82 18:41:19-PST,1969;000000000000 Date: 6 Dec 1982 1841-PST From: Cris Perdue <Perdue> Subject: LOADable modules, and HELP for them To: PSL-News: ;, PSL-Users: ; NEW PACKAGES: Some relatively new packages have been made available by various people here. These belong in PU: (loadable utilities) at some point, but for now they are all on PNEW:, both the source code and the object code. See below for an explanation of PNEW:. Documentation for each of these is either in the source file or in PH:<file>.DOC, which has been greatly cleaned up. HASH.SL HISTORY.SL IF.SL MAN.SL NEWPP.SL STRING-INPUT.SL STRING-SEARCH.SL TIME-FNC.SL DOCUMENTATION ON PH: (the HELP directory): PH: has been greatly cleaned up. It should now be reasonable to browse through PH: for information on packages not described in the PSL reference manual. TO THE USERS: These files are intended to be IMPORTed or LOADed. If you wish to use modules from PNEW:, you must put PNEW: into your definition of the "logical device" PL:. The command "INFO LOGICAL PL:" to the EXEC will tell you what the current definition of PL: is. Put a line of the form: "DEFINE PL: <directory>,<directory>, ..., PNEW:" into your LOGIN.CMD file, including the same directories that are given when you ask the EXEC, with PNEW: added at the end as shown. GETTING MOST RECENT VERSIONS OF MODULES: PNEW: also contains the object files for new versions of existing modules where the latest version is more recent than the latest "release" of PSL. In particular, where PSL.EXE includes the module preloaded in it, PSL.EXE will not include the version in PNEW:. If you want the latest version when you LOAD or IMPORT, put PNEW: at the front of the list defining PL:. TO THE IMPLEMENTORS: If one of these is your product and you feel it is well tried and no longer experimental, please send a note to Nancy K. asking her to move the source to PU: and the object file to PL:. ------- 4-Jan-83 14:37:11-PST,1577;000000000000 Date: 4 Jan 1983 1437-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; FILES THAT DESCRIBE OTHER FILES If you need to look at the PSL directories on HULK or find something in those directories, look for files with names that start with "-", such as -THIS-.DIRECTORY or -FILE-NOTES.TXT. These files appear at the beginning of an ordinary directory listing and they describe the directory they are in, plus the files and/or subdirectories of that directory. PSL directories likely to be of interest to users are: PSL: (PSL root directory), PU: (source code for libraries), PNEW: (place to keep revisions of source files), PH: (help files and documentation for libraries). LIBRARY MODULES NOW LISTED PU: is the repository for the source code of library modules, generally contributed by users. The file PU:-FILE-NOTES.TXT contains a listing of available library modules, in most cases with a one-line description of each module. Please look here for interesting utilities. If no documentation appears to exist, bug the author of the module, also listed. (Documentation may appear in PH: or in the source file itself on PU:.) SAVESYSTEM The function SAVESYSTEM, which used to take one argument, now takes three arguments. The first is the banner, the second is the file to be written, and the third is a list of forms to be evaluated when the new core image is started. PSL.TAGS For those of you who browse through PSL source code, the file PSL.TAGS moved to p20sup: from psl:. ------- 11-Jan-83 13:09:13-PST,1516;000000000000 Date: 11 Jan 1983 1309-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; When compiled code calls a function that is undefined, the error is now continuable. If the error is continued, the function call is repeated. The function EXITLISP is now available in DEC-20 PSL, where it is currently a synonym for QUIT. Both functions cause PSL to return to a command interpreter. If the operating system permits a choice, QUIT is a continuable exit, and EXITLISP is a permanent exit (that terminates the PSL process). The functions LPOSN and CHANNELLPOSN now exist. These return a meaningful value for channels that are open for output, giving the number of the current line within the current output page. To be precise, the value is the number of newlines output since the most recent formfeed. People have been using the undocumented STRING-CONCAT function. This function is NOT actually compatible with Common LISP. It should be used as a function that applies only to string arguments, and is otherwise like CONCAT. Various bugs have been fixed, notably in the compiler and debugging facilities. A new directory of possible interest is PSYS:. This contains executable files. Executables already documented as being on PSL: will stay there for some time, but new ones are on PSYS:. DOCUMENTATION The reference manual has been significantly revised and a new version will be made available to all PSL users within a week or two. ------- 11-Jan-83 13:20:09-PST,4950;000000000000 Date: 11 Jan 1983 1319-PST From: Alan Snyder <AS> Subject: NMODE news To: PSL-News: ;, PSL-Users: ; cc: AS NMODE changes (10-Nov-1982 through 5-Jan-1983): * Bug fix: In the previous version of NMODE, digits and hyphen would insert themselves in the buffer even in "read-only" modes like Dired. They now act to specify command arguments in those modes. * Bug fix: control characters are now displayed properly in the message lines at the bottom of the screen. * Some bugs in auto fill mode have been fixed. * C-S and C-R now get you an incremental search, very much like that in EMACS. [Incremental search was implemented by Jeff Soreff.] * The window scrolling commands have been changed to ring the bell if no actual scrolling takes place (because you are already at the end of the buffer, etc.). In addition, some bugs in the scroll-by-pages commands have been fixed: (1) Previously, a request to scroll by too many pages was ignored; now it will scroll by as many pages as possible. (2) Previously, a backwards scroll near the beginning of the buffer could fail to leave the cursor in the same relative position on the screen. * A number of changes have been made that improve the efficiency of refresh, input completion (on buffer names and M-X command names), and Lisp I/O to and from buffers (Lisp-E). * Jeff Soreff has implemented the following commands: M-A (Backward Sentence) M-E (Forward Sentence) M-K (Kill Sentence) C-X Rubout (Backward Kill Sentence) M-[ (Backward Paragraph) M-] (Forward Paragraph) M-H (Mark Paragraph) M-Q (Fill Paragraph) M-G (Fill Region) M-Z (Fill Comment) M-S (Center Line) C-X = and C-= (What Cursor Position) These are basically the same as EMACS, except for M-Z, which is new. M-Z (Fill Comment) is like M-Q (Fill Paragraph), except that it first scans the beginning of the current line for a likely prefix and temporarily sets the fill prefix to that string. The prefix is determined to be any string of indentation, followed by zero or more non-alphanumeric, non-blank characters, followed by any indentation. The Fill Prefix works somewhat better than EMACS: lines not containing the fill prefix delimit paragraphs. * New EMACS commands implemented: C-M-\ (Indent Region) (for both Text and Lisp modes) C-M-C (inserts a ^C) * Defined C-? same as M-?, C-( same as C-M-(, C-) same as C-M-), for the convenience of 9836 users. * The following commands have been enhanced to obey the C-U argument as in EMACS: C-Y (Insert Kill Buffer) M-Y (Unkill Previous) M-^ (Delete Indentation) C-M-(, C-M-U, and C-( (Backward Up List) C-M-) and C-) (Forward Up List) C-M-N (Move Forward List) C-M-P (Move Backward List) C-M-A and C-M-[ (Move Backward Defun) C-M-E and C-M-] (End of Defun) * The C-X = command has been extended: if you give it a numeric argument, it will go to the specified line number. * NMODE's Lisp parsing has been vastly improved. It now recognizes the following: lists, vectors, comments, #/ character constants, string literals, ! as the escape character, and prefixes (including quote, backquote, comma, comma-atsign, and #-quote). The only restriction is that parsing is always done from the beginning of the line; thus newline cannot appear in string literals or be quoted in any way. * NMODE's Lisp indenting has also been improved. It now recognizes special cases of indenting under functional forms, and indents to match the leftmost (rather than the rightmost) of a sequence of forms on a line. It also knows about prefixes, like quote. * Inserting a right bracket in Lisp mode now displays the matching bracket, just as inserting a right paren does. * Inserting a right paren (or right bracket) now will avoid trying to display the "matching" left paren (or left bracket) when inside a comment, etc. * Changed multi-line Lisp indenting commands to avoid indenting (in fact, remove any indentation from) blank lines. * The indenting commands now avoid modifying the buffer if the indentation remains unchanged. * When a command (such as C-X K) asks for the name of an existing buffer, CR will now complete the name, if possible, and terminate if the name uniquely specifies one existing buffer. This behavior is more similar to EMACS than the previous behavior, where CR did no completion. * String input is now confirmed by moving the cursor to the beginning of the input line. ------- 11-Jan-83 17:19:31-PST,1032;000000000001 Date: 11 Jan 1983 1719-PST From: Cris Perdue <Perdue> Subject: More PSL News To: PSL-News: ;, PSL-Users: ; The behavior of LOAD has been modified so it is possible to use LOAD to load in ".SL" files. As in the past, LOAD searches in two places for a file to load: first in the connected directory (DSK: for the DEC-20 cognoscenti), then on PL: (or the equivalent on other machines). On each of these directories it searches through a list of file extensions (.b, .lap, and .sl) for a file with the right name and that extension. Thus LOAD looks first for <file>.b, then <file>.lap, then <file>.sl, then pl:<file>.b, then pl:<file>.lap, finally pl:<file>.sl. Until the latest version of PSL, LOAD would only search for .b and .lap files. The extended behavior should help people who often do not compile files. The main thing to remember is to either keep any .b file in the same directory with the .sl, or else make sure that the .b file's directory is searched before the .sl file's directory. ------- 19-Jan-83 18:28:27-PST,1437;000000000003 Date: 19 Jan 1983 1826-PST From: PERDUE at HP-HULK Subject: PSL News Update To: psl-news LOADing files The LOAD function uses two lists in searching for a file to actually load. The lists are: loaddirectories* This initially has the value: ("" "pl:"). It is a list of strings which indicate the directory to look in. Directories are searched in order of the list. loadextensions* This initially has the value: ((".b" . FASLIN) (".lap" . LAPIN) (".sl" . LAPIN)). It is an association list. Each element is a pair whose CAR is a string representing a file extension and whose CDR is a function to apply to LOAD a file of this extension. Within each directory of loaddirectories*, the members of loadextensions* are used in order in searching for a file to load. NOTES: The value of loadextensions* has recently changed. Removal of the last element of loadextensions* will restore the old behavior. Do not expect the exact strings that appear in these lists to remain identical across machines or across time, but it is reasonable to believe that the lists and their use will be stable for some time. DEBUGGING: BR and UNBR BR and UNBR were removed from the PSL system some time ago. To satisfy their devotees, they have been resurrected in a library named BR-UNBR. A bug has also been fixed and very soon the system library file will have the fix (if in a hurry see pnew:). ------- 24-Jan-83 09:42:10-PST,703;000000000000 Date: 21 Jan 1983 1909-PST From: PERDUE at HP-HULK Subject: Documentation directories To: psl-news The PSL documentation directory "pd:" has been cleaned up and there are now also machine-dependent directories p20d:, pvd:, phpd:, and pad: (Apollo). No great news of yet concerning the contents of these directories, though they do contain some rather new documents in source and final form. Note that some of these logical names are new, and there are some other new logical names as well: the group based on the root name "pdist" has been filled out, and the group based on the name "psup:" has also been filled out with a couple of new directories and their logical names. ------- 9-Feb-83 13:22:20-PST,4442;000000000000 Date: 9 Feb 1983 1317-PST From: AS at HP-HULK Subject: NMODE changes To: psl-news The following recent changes are available in PSL:NMODE.EXE on Hulk, and on the 9836 (except for Dired). Recent NMODE changes (20-Jan-1983 through 9-Feb-1983): Changes: * The Buffer Browser (C-X C-B) has changed in a number of ways. It has three new commands: F Saves the buffer in a file, if there are unsaved changes. M-~ Turns off the buffer-modified flag. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,F,N, and M-~ all obey a numeric argument of either sign. The Buffer Browser now starts up pointing at the previously-current buffer. After performing a sort command, the cursor now continues to point at the same buffer. * DIRED (the File browser) has been changed in a number of ways. One SIGNIFICANT INCOMPATIBLE change is that the K and C-K commands now delete the file immediately and remove the file from the display (instead of just marking them for later deletion). In addition, there are two new commands: I (Ignore File) Removes the file from the display list, without any effect on the actual file. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,and N all obey a numeric argument of either sign. The sort-by-filename procedure has been changed to sort version numbers in numerical, rather than lexicographic order. When Dired starts, the files are sorted using this procedure, instead of leaving them in the order returned by the file system. After performing a sort command, the cursor now continues to point at the same file. Dired will now automatically kill any buffer it had created for viewing a file as soon as you view a new file or exit Dired, unless the buffer contains unsaved changes. * M-X Insert File now takes as its default the file name used in the previous M-X Insert File command. This behavior matches EMACS. * Lisp-E (and Lisp-D, a new command) now insert a free EOL at the end of the buffer, if needed, whenever the buffer-modified flag is set. Previously the free EOL was inserted only when the current position was at the end of the buffer, regardless of the state of the buffer-modified flag. New commands: M-X Count Occurrences (aka M-X How Many) M-X Delete Matching Lines (aka M-X Flush Lines) M-X Delete Non-Matching Lines (aka M-X Keep Lines) M-X Insert Date (not on 9836 yet) M-X Kill Some Buffers M-X Rename Buffer M-X Revert File M-X Set Key M-X Set Visited Filename Lisp-D (in Lisp mode) executes the current defun (if the current position is within a defun) or executes from the current position (otherwise). Improvements: * NMODE now checks the system's terminal type every time it is restarted. This change allows you to use an NMODE that was detached from one kind of terminal and later attached on another kind of terminal. * Fixed bug in Dec-20 version: Find File could leave around an empty file if you tried to find a nonexistent file in a directory that allows you to create new files but whose default file protection does not allow you to delete them. (On the Dec-20, Find File determines the name of a new file by writing an empty file and immediately deleting it.) * A soft-key feature has been added, intended primarily for use on the 9836. The command Esc-/ will read a soft-key designator (a single character in the range '0' to 'W') and execute the definition of the corresponding softkey (numbered 0 through 39). Softkeys are defined using the function (nmode-define-softkey n fcn label-string), where n is the softkey number and fcn is either NIL (for undefined), a function ID (which will be invoked), or a string (which will be executed as if typed at the keyboard). NMODE on the 9836 sets up the keyboard so that the function keys K0 through K9 send an appropriate Esc-/ sequence (using shift and control as modifiers). * The two message/prompt lines at the bottom of the screen are now sometimes updated independently of the rest of the screen. This change makes writing messages and prompts more efficient. ------- 25-Feb-83 11:03:02-PST,2247;000000000000 Date: 25 Feb 1983 1059-PST From: AS at HP-HULK Subject: recent NMODE changes To: psl-news Recent NMODE changes (14-Feb-1983 through 24-Feb-1983): Bugs fixed: * Dired wasn't garbage collecting old buffers used to view files, as had been intended. * M-Z would enter an infinite loop on a paragraph at the end of the buffer whose last line had no terminating Newline character. * When filling with a fill prefix, the cursor would sometimes be placed improperly. * M-X Rename Buffer didn't convert the new buffer name to upper case. * The Permanent Goal Column feature (Set by C-X C-N) didn't work. * The incremental search commands did not handle bit-prefix characters (e.g., the Meta prefix) properly. Typing a bit-prefix character would terminate the search, but then the bit-prefix character would not be recognized as such. * When executing Lisp from the OUTPUT buffer in one-window mode, the window would not be adjusted if the other (unexposed) window also was attached to the OUTPUT buffer. * The cursor was being positioned improperly when the window was scrolled horizontally. Performance Improvements: * The efficiency of Lisp printing to the OUTPUT buffer has been improved significantly through the use of internal buffering. One visible change is that the screen is updated only after an entire line is written. * Insertion into text buffers has been speeded up by eliminating some unnecessary string consing that occurred when inserting at the beginning or end of a line (which is very common). EMACS Compatibility Enhancements: * M-X Set Visited Filename now converts the new name to the true name of the file, if possible. * M-X Rename Buffer now checks for attempts to use the name of an existing buffer. * Query-Replace now terminates when you type a character that is not a query-replace command and rereads that character. * C-M-D has been extended to obey the command argument (either positive or negative). It still differs from the EMACS C-M-D command in that it always stays within the current enclosing list. * M-( has been extended to obey the command argument. * The M-) command (Move Over Paren) has been implemented. ------- 18-Mar-83 16:29:39-PST,6873;000000000000 Date: 18 Mar 1983 1626-PST From: AS at HP-HULK Subject: recent NMODE changes To: psl-news cc: AS Recent NMODE changes (28-Feb-1983 through 16-Mar-1983): (Not all of these changes have been installed on all systems.) Bugs Fixed: * NMODE will now refresh the display and clear the message line when it is interrupted and restarted. * The C-X D command would list the connected directory, rather than the directory of the current file, if the current file name contained a device specification but no directory specification (e.g., "FOO:BAR.TXT"). * The 9836 color screen driver would crash if it tried to display a buffer containing characters with integer values greater than 127. * The command to write the contents of the current screen to a file would always write the main screen, even when NMODE was using multiple screens. * NMODE would crash if it encountered a file (on the 9836) with an "invalid" file name (e.g., "FOO.BAR.TEXT"). Performance Improvements: * File I/O on the 9836 has been speeded up greatly. * The 9836 color screen driver has been modified to speed up refresh. * Keyboard interaction has been speeded up significantly following the discovery that certain keyboard input functions were not compiled. New Commands: * DIRED is now available on the 9836. * There is a new command, M-X List Browsers, which brings up a Browser Browser showing all existing browsers (i.e., the Buffers browser and, on the 9836, the NMODE Documentation browser), as well as all potential browsers (i.e., File Directory browsers). Potential browsers are displayed as prototype browsers. Commands are provided to view documentation on a browser (or prototype) and to enter a browser (or instantiate a prototype). * There is a new command, M-X Print Buffer, also available as C-X C-P, which prints the contents of the current buffer in a format suitable for printing devices. A file/device name is requested from the user; the default is LPT: on the Dec-20 and PRINTER: on the 9836. This command translates tabs to spaces and control characters to ^X form. Note: using C-X C-W on the 9836 to write the buffer to PRINTER: does not work. * A Browse command has been added to Dired. This command allows one to browse thru a subdirectory. * A Create command has been added to the Buffer Browser to create new buffers. A Create command has been added to Dired to create new files. Changes: * The command to write the contents of the current screen to a file has been changed from C-X P to M-X Write Screen. In addition, this command now has its own default file name. * The Buffer Browser (C-X C-B) now always displays all named buffers. Previously, it would ignore buffers whose names began with a "+", unless an argument was specified to the C-X C-B command. The use of "+" to name "internal" buffers has been replaced by the use of "unnamed" buffers. * A number of changes have been made to the common browser mechanism, which affect the behavior of all browsers (Buffers, Files, Documentation, and the Browser Browser): Browsers now use "unnamed" buffers (a new NMODE feature) to display the lists of items. This change means that browsers no longer appear in the Buffer Browser list of buffers and cannot be selected using C-X B. Instead, the Browser Browser (M-X List Browsers) can be used to display all existing browsers and to select an existing browser. The Buffer Browser and the Browser Browser now update themselves automatically under various circumstances, most notably when you enter or select them, to take account of any items created or deleted since the browser was last updated. The File Directory Browser (DIRED) does not update itself automatically, since that operation would be too time-consuming. However, it supports a new command, Look (L), which causes it to re-read the specified directory. When you attempt to create a browser, NMODE will first look for an existing browser with the desired information. If an existing browser is found, it will be reentered. As described above, the Buffers and Browser browsers update themselves automatically when they are entered. When a File Directory browser is reused, it also updates itself automatically. Quitting a browser no longer kills the browser, but merely returns the display to its previous state. This change encourages reentering existing browsers instead of unnecessarily creating new ones. It is possible to kill a browser using the Kill (K) command of the Browser Browser, if you desperately need to reclaim the space taken up by a browser. Quitting a browser now does a better job of restoring the previous screen contents. The help line at the bottom of the screen is now automatically maintained. Previously, it was displayed only when the browser was entered and would not be restored when returning to the browser from another window or buffer. The ? command (which used to refresh the help line) now displays a buffer of documentation about the browser. Browsers now do a better job of managing the screen, especially when the split-screen option is enabled. (When the split-screen option is enabled, the top window is used to display the list of items, and the bottom window is used to display a particular item. The split-screen option is enabled by including the statement (SETF BROWSER-SPLIT-SCREEN T) in your NMODE.INIT file. Split-screen will probably become the default soon.) When the split-screen option is enabled, each browser will endeavor to ensure that the bottom window displays the most-recently selected item. When there is no selected item, the browser will display documentation in the bottom window (using an "unnamed" buffer). The window label line for a browser now displays additional information about the browser. For example, the label line for a File Directory Browser displays the name of the directory. In addition, the label line for a browser documentation buffer displays a descriptive sentence. * A number of incompatible changes have been made to the common browser mechanism to support the above changes. If you have written your own browser using these mechanisms, you should consult the sources of the standard browsers to see the kinds of changes you should make. (See Buffer-Browser.SL, Dired.SL, Doc.SL, Browser.SL, and Browser-Support.SL, all in the PN: directory.) * Another incompatible change: the function buffer-create-unselectable has been replaced by the function create-unnamed-buffer, which (as the name suggests) does not take a name-of-buffer argument. (See PN:Buffers.SL.) ------- |
Added psl-1983/3-1/psl/nmode-chart.txt version [eea7c24a86].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE command list (Lisp mode) - 25 January 1983 -------------------------------------------------------- ) INSERT-CLOSING-BRACKET Backspace DELETE-BACKWARD-HACKING-TABS-COMMAND C-% REPLACE-STRING-COMMAND C-( BACKWARD-UP-LIST-COMMAND C-) FORWARD-UP-LIST-COMMAND C-- NEGATIVE-ARGUMENT C-0 ARGUMENT-DIGIT C-1 ARGUMENT-DIGIT C-2 ARGUMENT-DIGIT C-3 ARGUMENT-DIGIT C-4 ARGUMENT-DIGIT C-5 ARGUMENT-DIGIT C-6 ARGUMENT-DIGIT C-7 ARGUMENT-DIGIT C-8 ARGUMENT-DIGIT C-9 ARGUMENT-DIGIT C-< MARK-BEGINNING-COMMAND C-= WHAT-CURSOR-POSITION-COMMAND C-> MARK-END-COMMAND C-? HELP-DISPATCH C-@ SET-MARK-COMMAND C-A MOVE-TO-START-OF-LINE-COMMAND C-B MOVE-BACKWARD-CHARACTER-COMMAND C-D DELETE-FORWARD-CHARACTER-COMMAND C-E MOVE-TO-END-OF-LINE-COMMAND C-F MOVE-FORWARD-CHARACTER-COMMAND C-G NMODE-ABORT-COMMAND C-K KILL-LINE C-L NMODE-REFRESH-COMMAND C-M-( BACKWARD-UP-LIST-COMMAND C-M-) FORWARD-UP-LIST-COMMAND C-M-- NEGATIVE-ARGUMENT C-M-0 ARGUMENT-DIGIT C-M-1 ARGUMENT-DIGIT C-M-2 ARGUMENT-DIGIT C-M-3 ARGUMENT-DIGIT C-M-4 ARGUMENT-DIGIT C-M-5 ARGUMENT-DIGIT C-M-6 ARGUMENT-DIGIT C-M-7 ARGUMENT-DIGIT C-M-8 ARGUMENT-DIGIT C-M-9 ARGUMENT-DIGIT C-M-@ MARK-FORM-COMMAND C-M-A MOVE-BACKWARD-DEFUN-COMMAND C-M-B MOVE-BACKWARD-FORM-COMMAND C-M-Backspace MARK-DEFUN-COMMAND C-M-D DOWN-LIST C-M-E END-OF-DEFUN-COMMAND C-M-F MOVE-FORWARD-FORM-COMMAND C-M-H MARK-DEFUN-COMMAND C-M-I LISP-TAB-COMMAND C-M-K KILL-FORWARD-FORM-COMMAND C-M-L SELECT-PREVIOUS-BUFFER-COMMAND C-M-M BACK-TO-INDENTATION-COMMAND C-M-N MOVE-FORWARD-LIST-COMMAND C-M-O SPLIT-LINE-COMMAND C-M-P MOVE-BACKWARD-LIST-COMMAND C-M-Q LISP-INDENT-SEXPR C-M-R REPOSITION-WINDOW-COMMAND C-M-Return BACK-TO-INDENTATION-COMMAND C-M-Rubout KILL-BACKWARD-FORM-COMMAND C-M-T TRANSPOSE-FORMS C-M-Tab LISP-TAB-COMMAND C-M-U BACKWARD-UP-LIST-COMMAND C-M-V SCROLL-OTHER-WINDOW-COMMAND C-M-W APPEND-NEXT-KILL-COMMAND C-M-X M-X-PREFIX C-M-[ MOVE-BACKWARD-DEFUN-COMMAND C-M-\ LISP-INDENT-REGION-COMMAND C-M-] END-OF-DEFUN-COMMAND C-N MOVE-DOWN-EXTENDING-COMMAND C-O OPEN-LINE-COMMAND C-P MOVE-UP-COMMAND C-Q INSERT-NEXT-CHARACTER-COMMAND C-R REVERSE-SEARCH-COMMAND C-Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND C-S INCREMENTAL-SEARCH-COMMAND C-Space SET-MARK-COMMAND C-T TRANSPOSE-CHARACTERS-COMMAND C-U UNIVERSAL-ARGUMENT C-V NEXT-SCREEN-COMMAND C-W KILL-REGION C-X C-X-PREFIX C-X . SET-FILL-PREFIX-COMMAND C-X 1 ONE-WINDOW-COMMAND C-X 2 TWO-WINDOWS-COMMAND C-X 3 VIEW-TWO-WINDOWS-COMMAND C-X 4 VISIT-IN-OTHER-WINDOW-COMMAND C-X < SCROLL-WINDOW-LEFT-COMMAND C-X = WHAT-CURSOR-POSITION-COMMAND C-X > SCROLL-WINDOW-RIGHT-COMMAND C-X A APPEND-TO-BUFFER-COMMAND C-X B SELECT-BUFFER-COMMAND C-X C-B BUFFER-BROWSER-COMMAND C-X C-F FIND-FILE-COMMAND C-X C-L LOWERCASE-REGION-COMMAND C-X C-N SET-GOAL-COLUMN-COMMAND C-X C-O DELETE-BLANK-LINES-COMMAND C-X C-S SAVE-FILE-COMMAND C-X C-T TRANSPOSE-LINES C-X C-U UPPERCASE-REGION-COMMAND C-X C-V VISIT-FILE-COMMAND C-X C-W WRITE-FILE-COMMAND C-X C-X EXCHANGE-POINT-AND-MARK C-X C-Z NMODE-EXIT-TO-SUPERIOR C-X D DIRED-COMMAND C-X E EXCHANGE-WINDOWS-COMMAND C-X F SET-FILL-COLUMN-COMMAND C-X G GET-REGISTER-COMMAND C-X H MARK-WHOLE-BUFFER-COMMAND C-X K KILL-BUFFER-COMMAND C-X O OTHER-WINDOW-COMMAND C-X P WRITE-SCREEN-PHOTO-COMMAND C-X Rubout BACKWARD-KILL-SENTENCE-COMMAND C-X T TRANSPOSE-REGIONS C-X V NMODE-INVERT-VIDEO C-X X PUT-REGISTER-COMMAND C-X ^ GROW-WINDOW-COMMAND C-Y INSERT-KILL-BUFFER C-] LISP-PREFIX Esc-4 MOVE-BACKWARD-WORD-COMMAND Esc-5 MOVE-FORWARD-WORD-COMMAND Esc-A MOVE-UP-COMMAND Esc-B MOVE-DOWN-COMMAND Esc-C MOVE-FORWARD-CHARACTER-COMMAND Esc-D MOVE-BACKWARD-CHARACTER-COMMAND Esc-F MOVE-TO-BUFFER-END-COMMAND Esc-J NMODE-FULL-REFRESH Esc-L OPEN-LINE-COMMAND Esc-M KILL-LINE Esc-P DELETE-FORWARD-CHARACTER-COMMAND Esc-S SCROLL-WINDOW-UP-LINE-COMMAND Esc-T SCROLL-WINDOW-DOWN-LINE-COMMAND Esc-U SCROLL-WINDOW-UP-PAGE-COMMAND Esc-V SCROLL-WINDOW-DOWN-PAGE-COMMAND Esc-h MOVE-TO-BUFFER-START-COMMAND Escape ESC-PREFIX Lisp-? LISP-HELP-COMMAND Lisp-A LISP-ABORT-COMMAND Lisp-B LISP-BACKTRACE-COMMAND Lisp-C LISP-CONTINUE-COMMAND Lisp-E EXECUTE-FORM-COMMAND Lisp-L EXIT-NMODE Lisp-Q LISP-QUIT-COMMAND Lisp-R LISP-RETRY-COMMAND Lisp-Y YANK-LAST-OUTPUT-COMMAND M-% QUERY-REPLACE-COMMAND M-' UPCASE-DIGIT-COMMAND M-( INSERT-PARENS M-- NEGATIVE-ARGUMENT M-/ HELP-DISPATCH M-0 ARGUMENT-DIGIT M-1 ARGUMENT-DIGIT M-2 ARGUMENT-DIGIT M-3 ARGUMENT-DIGIT M-4 ARGUMENT-DIGIT M-5 ARGUMENT-DIGIT M-6 ARGUMENT-DIGIT M-7 ARGUMENT-DIGIT M-8 ARGUMENT-DIGIT M-9 ARGUMENT-DIGIT M-; INSERT-COMMENT-COMMAND M-< MOVE-TO-BUFFER-START-COMMAND M-> MOVE-TO-BUFFER-END-COMMAND M-? HELP-DISPATCH M-@ MARK-WORD-COMMAND M-A BACKWARD-SENTENCE-COMMAND M-B MOVE-BACKWARD-WORD-COMMAND M-Backspace MARK-DEFUN-COMMAND M-C UPPERCASE-INITIAL-COMMAND M-D KILL-FORWARD-WORD-COMMAND M-E FORWARD-SENTENCE-COMMAND M-F MOVE-FORWARD-WORD-COMMAND M-G FILL-REGION-COMMAND M-H MARK-PARAGRAPH-COMMAND M-I TAB-TO-TAB-STOP-COMMAND M-K KILL-SENTENCE-COMMAND M-L LOWERCASE-WORD-COMMAND M-M BACK-TO-INDENTATION-COMMAND M-Q FILL-PARAGRAPH-COMMAND M-R MOVE-TO-SCREEN-EDGE-COMMAND M-Return BACK-TO-INDENTATION-COMMAND M-Rubout KILL-BACKWARD-WORD-COMMAND M-S CENTER-LINE-COMMAND M-T TRANSPOSE-WORDS M-Tab TAB-TO-TAB-STOP-COMMAND M-U UPPERCASE-WORD-COMMAND M-V PREVIOUS-SCREEN-COMMAND M-W COPY-REGION M-X M-X-PREFIX M-X Append to File APPEND-TO-FILE-COMMAND M-X Apropos APROPOS-COMMAND M-X Auto Fill Mode AUTO-FILL-MODE-COMMAND M-X Count Occurrences COUNT-OCCURRENCES-COMMAND M-X DIRED EDIT-DIRECTORY-COMMAND M-X Delete File DELETE-FILE-COMMAND M-X Delete Matching Lines DELETE-MATCHING-LINES-COMMAND M-X Delete Non-Matching Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Delete and Expunge File DELETE-AND-EXPUNGE-FILE-COMMAND M-X Edit Directory EDIT-DIRECTORY-COMMAND M-X Execute Buffer EXECUTE-BUFFER-COMMAND M-X Execute File EXECUTE-FILE-COMMAND M-X Find File FIND-FILE-COMMAND M-X Flush Lines DELETE-MATCHING-LINES-COMMAND M-X How Many COUNT-OCCURRENCES-COMMAND M-X Insert Buffer INSERT-BUFFER-COMMAND M-X Insert Date INSERT-DATE-COMMAND M-X Insert File INSERT-FILE-COMMAND M-X Keep Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Kill Buffer KILL-BUFFER-COMMAND M-X Kill File DELETE-FILE-COMMAND M-X Kill Some Buffers KILL-SOME-BUFFERS-COMMAND M-X Lisp Mode LISP-MODE-COMMAND M-X List Buffers BUFFER-BROWSER-COMMAND M-X Make Space NMODE-GC M-X Prepend to File PREPEND-TO-FILE-COMMAND M-X Query Replace QUERY-REPLACE-COMMAND M-X Rename Buffer RENAME-BUFFER-COMMAND M-X Replace String REPLACE-STRING-COMMAND M-X Revert File REVERT-FILE-COMMAND M-X Save All Files SAVE-ALL-FILES-COMMAND M-X Select Buffer SELECT-BUFFER-COMMAND M-X Set Key SET-KEY-COMMAND M-X Set Visited Filename SET-VISITED-FILENAME-COMMAND M-X Start Scripting START-SCRIPTING-COMMAND M-X Start Timing NMODE START-TIMING-COMMAND M-X Stop Scripting STOP-SCRIPTING-COMMAND M-X Stop Timing NMODE STOP-TIMING-COMMAND M-X Text Mode TEXT-MODE-COMMAND M-X Undelete File UNDELETE-FILE-COMMAND M-X Visit File VISIT-FILE-COMMAND M-X Write File WRITE-FILE-COMMAND M-X Write Region WRITE-REGION-COMMAND M-Y UNKILL-PREVIOUS M-Z FILL-COMMENT-COMMAND M-[ BACKWARD-PARAGRAPH-COMMAND M-\ DELETE-HORIZONTAL-SPACE-COMMAND M-] FORWARD-PARAGRAPH-COMMAND M-^ DELETE-INDENTATION-COMMAND M-~ BUFFER-NOT-MODIFIED-COMMAND Newline INDENT-NEW-LINE-COMMAND Return RETURN-COMMAND Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND Tab LISP-TAB-COMMAND ] INSERT-CLOSING-BRACKET C-\ "Meta" prefix on Dec-20 C-[ (Escape) "Meta" prefix on 9836 C-^ "Control" prefix C-Z "Control-Meta" prefix |
Added psl-1983/3-1/psl/nmode-customizing.txt version [caf7643a39].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | How to customize NMODE Alan Snyder 24 September 1982 ------------------------------------------------------------------------------- This memo explains how to customize NMODE by redefining the effect of input keystrokes. NMODE is customized by executing Lisp forms. These forms may be executed directly within NMODE (using Lisp-E), or may be stored in an INIT file, which is read by NMODE when it first starts up. The name of the INIT file read by NMODE is "NMODE.INIT" in the user's home directory. There are three concepts that must be understood to customize NMODE: Commands, Functions, and Modes. 1) Commands. The effect of given keystroke or sequence of keystrokes in NMODE is based on a mapping between "commands" and "functions". A "command" may be either a single "extended character" or a sequence of characters. An extended character is a 9-bit character with distinct "Control" and "Meta" bits. Thus "C-M-A" is a single "extended character", even though on many terminals you have to use two keystrokes to enter it. Extended characters are specified using the macro X-CHAR, for example: (x-char A) the letter "A" (upper case) (x-char C-F) Control-F (x-char C-M-Z) Control-Meta-Z (x-char CR) Carriage-Return (x-char TAB) Tab (x-char BACKSPACE) Backspace (x-char NEWLINE) Newline (x-char RUBOUT) Rubout (x-char C-M-RUBOUT) Control-Meta-Rubout (The macros described in this section are defined in the load module EXTENDED-CHAR.) It is important to note that on most terminals, some Ascii control characters are mapped to extended "Control" characters and some aren't. Those that aren't are: Backspace, CR, Newline, Tab, and Escape. Even if you type "CNTL-I" on the keyboard, you will get "Tab" and not "Control-I". The remaining Ascii control characters are mapped to extended "Control" characters, thus typing "CNTL-A" on the keyboard gives "Control-A". As mentioned above, a command can be a sequence of characters. There are two forms: Prefix commands and Extended commands. Prefix commands: A prefix command consists of two characters, the first of which is a defined "prefix character". In NMODE, there are 3 predefined prefix characters: C-X, ESC, and C-]. Prefix commands are specified using the X-CHARS macro, for example: (x-chars C-X C-F) (x-chars ESC A) (x-chars C-] E) Extended commands: An extended command consists of the character M-X and a string. Extended commands are defined using the M-X macro, for example: (M-X "Lisp Mode") (M-X "Revert File") The case of the letters in the string is irrelevant, except to specify how the command name will be displayed when "completion" is used by the user. By convention, the first letter of each word in an extended command name is capitalized. 2) Functions. NMODE commands are implemented by PSL functions. By convention, most (but not all) PSL functions that implement NMODE commands have names ending with "-COMMAND", for example, MOVE-FORWARD-CHARACTER-COMMAND. An NMODE command function should take no arguments. The function can perform its task using a large number of existing support functions; see PN:BUFFER.SL and PN:MOVE-COMMANDS.SL for examples. A command function can determine the command argument (given by C-U) by inspecting global variables: nmode-command-argument: the numeric value (default: 1) nmode-command-argument-given: T if the user specified an argument nmode-command-number-given: T if the user typed digits in the argument See the files PN:MOVE-COMMANDS.SL, PN:LISP-COMMANDS.SL, and PN:COMMANDS.SL for many examples of NMODE command functions. 3) Modes. The mapping between commands and functions is dependent on the current "mode". Examples of existing modes are "Text Mode", which is the basic mode for text editing, "Lisp Mode", which is an extension of "Text Mode" for editing and executing Lisp code, and "Dired Mode", which is a specialized mode for the Directory Editor Subsystem. A mode is defined by a list of Lisp forms which are evaluated to determine the state of a Dispatch Table. The Dispatch Table is what is actually used to map from commands to functions. Every time the user selects a new buffer, the Dispatch Table is cleared and the Lisp forms defining the mode for the new buffer are evaluated to fill the Dispatch Table. The forms are evaluated in reverse order, so that the first form is evaluated last. Thus, any command definitions made by one form supercede those made by forms appearing after it in the list. Two functions are commonly invoked by mode-defining forms: NMODE-ESTABLISH-MODE and NMODE-DEFINE-COMMANDS. NMODE-ESTABLISH-MODE takes one argument, a list of mode defining forms, and evaluates those forms. Thus, NMODE-ESTABLISH-MODE can be used to define one mode in terms of (as an extension of or a modification to) another mode. NMODE-DEFINE-COMMANDS takes one argument, a list of pairs, where each pair consists of a COMMAND and a FUNCTION. This form of list is called a "command list". Command lists are not used directly to map from commands to functions. Instead, NMODE-DEFINE-COMMANDS reads the command list it is given and for each COMMAND-FUNCTION pair in the command list (in order), it alters the Dispatch Table to map the specified COMMAND to the corresponding FUNCTION. Note that as a convenience, whenever you define an "upper case" command, the corresponding "lower case" command is also defined to map to the same function. Thus, if you define C-M-A, you automatically define C-M-a to map to the same function. If you want the lower case command to map to a different function, you must define the lower case command "after" defining the upper case command. The usual technique for modifying one or more existing modes is to modify one of the command lists given to NMODE-DEFINE-COMMANDS. The file PN:MODE-DEFS.SL contains the definition of most predefined NMODE command lists, as well as the definition of most predefined modes. To modify a mode or modes, you must alter one or more command lists by adding (or perhaps removing) entries. Command lists are manipulated using two functions: (add-to-command-list list-name command func) (remove-from-command-list list-name command) Here are some examples: (add-to-command-list 'text-command-list (x-char BACKSPACE) 'delete-backward-character-command) (add-to-command-list 'lisp-command-list (x-char BACKSPACE) 'delete-backward-hacking-tabs-command) (remove-from-command-list 'read-only-text-command-list (x-char BACKSPACE)) [The above forms change BACKSPACE from being the same as C-B to being the same as RUBOUT.] (add-to-command-list 'read-only-text-command-list (x-char M-@) 'set-mark-command) [The above form makes M-@ set the mark.] (add-to-command-list 'read-only-terminal-command-list (x-chars ESC Y) 'print-buffer-names-command) [The above form makes Esc-Y print a list of all buffer names. Esc-Y is sent by HP264X terminals when the "Display Functions" key is hit.] Note that these functions change only the command lists, not the Dispatch Table which is actually used to map from commands to functions. To cause the Dispatch Table to be updated to reflect any changes in the command lists, you must invoke the function NMODE-ESTABLISH-CURRENT-MODE. |
Added psl-1983/3-1/psl/nmode-emacs.txt version [4eebcfbf6a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMACS users - A quick comparison Alan Snyder (2 February 1983) -------------------------------------------------------------------------------- Introduction If you are familiar with EMACS on the Dec-20, then you should have little trouble using NMODE, since NMODE is largely compatible with EMACS. If you are using an HP terminal or the 9836 VT52 emulator, then you can use the cursor keys and other special function keys with NMODE. There are some differences between NMODE and EMACS, and these are described below. What you are most likely to find is that there are some EMACS commands that have not (yet) been implemented in NMODE; section I below lists the most significant of these. (We are not promising to implement all EMACS commands, but if there is some command you just can't live without, let us know, or volunteer to implement it yourself!) Section II describes areas of inconsistency between NMODE and EMACS; some of these are deficiencies in NMODE that may someday be fixed, others are regarded as features of NMODE, and others are just plain differences which are not likely to go away. Section III lists other known deficiencies in NMODE, many of which we hope to fix. Section IV summarizes those features of NMODE that EMACS doesn't have. -------------------------------------------------------------------------------- I. Things that EMACS has that NMODE doesn't (an incomplete list) * Auto Save * Help Character (C-_) * Many 'options' variables (NMODE has almost none) * Most Minor Modes, including: Word Abbrev Mode Auto Arg Mode Atom Word Mode Overwrite Mode Indent Tabs Mode * The Tags Package M-. (find tag) M-X Visit Tag Table M-X Tags Search * Local Modes specification in files * Syntax Table * Miscellaneous commands: C-M-G (grind form) M-= (count lines region) C-M-Z (exit recursive edit) M-Esc (Execute Minibuffer) C-X Esc (ReExecute Minibuffer) * Mail Commands: C-X M (Send Mail) C-X R (Read Mail) M-X Check Mail * Comment commands: C-; (indent for comment) C-M-; (kill comment) Return (skip trailing comment terminator) C-X ; (set comment column) M-N (down comment line) M-P (up comment line) M-J or M-Linefeed (indent new comment line) * Indentation commands: C-X Tab (indent rigidly) * Text-Processor commands: M-# (change font word) M-_ (underline word) C-X # (change font region) C-X _ (underline region) * File commands: C-X C-D (directory display) C-X C-Q (set file read only) M-X Clean Directory M-X Copy File M-X List Files M-X Reap File M-X Rename File M-X View Directory M-X View File * Page commands: C-X [ (previous page) C-X ] (next page) C-X L (count lines page) C-X C-P (mark page) M-X What Page * Many M-X commands, including: M-X Compare Windows M-X List Matching Lines M-X Occur M-X Tabify M-X Untabify M-X View Buffer * Keyboard macros C-X ( C-X ) C-X E C-X Q M-X Name Kbd Macro M-X Write Kbd Macro * Command Libraries M-X Kill Libraries M-X List Library M-X List Loaded Libraries M-X Load Library M-X Run Library * Spelling Correction (M-$) * Narrowing: C-X N (Narrow Bounds to Region) C-X P (Narrow Bounds to Page) C-X W (Widen Bounds) -------------------------------------------------------------------------------- II. Inconsistencies between NMODE and EMACS A. NMODE Features * NMODE DIRED 'E' and 'V' commands allow editing of the file. These commands do not use "recursive editing": arbitrary switching between buffers and windows is allowed; C-M-L returns to the previous buffer (not C-M-Z). * NMODE has a separate ring of marks for each buffer. * NMODE C-X C-B brings up a buffer browser, instead of just listing the buffers. * NMODE's Lisp parsing commands recognize comments, string literals, character literals, etc. For this reason, the commands C-M-N (Forward List) and C-M-P (Backward List) are not really needed, although they are presently still provided. * When the fill prefix is non-null, NMODE treats lines not beginning with the fill prefix as delimiting a paragraph (ZMACS does this, too). EMACS will treat a single preceding line without the fill prefix as the first line of the paragraph and will insert the prefix onto that line when you do M-Q. * NMODE's incremental search allows you to rubout the old search string (inserted by an immediate C-S or C-R) one character at a time, instead of all at once (like EMACS). B. NMODE Deficiencies (may be fixed someday) * NMODE Query-Replace does not alter the case of the replacement string, does not support word search, does not support recursive edit. * NMODE does not have a ring buffer of buffers; the default buffer for C-X B may be different than in EMACS. * NMODE's incremental search does not escape to a non-incremental search, does not do word searches, always ignores case. * No completion on File Name input. * NMODE doesn't set the Mode from the first line of a file. * In NMODE, M-digit does not enter autoarg mode (i.e., if you then type a digit (without Meta), the digit is inserted. * NMODE search commands never set the Mark. * NMODE lacks true read-only buffers. * NMODE's Dired does not support C, H, or N. Dired commands do not take a command argument. * NMODE's Kill Buffer commands ask for confirmation rather than offering to write out the buffer. * NMODE's C-M-Q command does not use the command argument. * NMODE's C-X H command does not use the command argument. * NMODE's M-< command does not use the command argument. * NMODE's M-> command does not use the command argument. * NMODE's C-X C-Z command does not save any files. * NMODE's M-X Make Space command does not offer to delete buffers, kill rings, etc. * NMODE's C-M-R command works only in Lisp mode (it doesn't do paragraphs). * NMODE's Return command doesn't delete blanks and tabs when moving onto a new line. * NMODE's Return command is not changed in Auto Fill mode. * NMODDE's LineFeed command is quite a bit different: (1) it doesn't delete spaces before the inserted CRLF; (2) it doesn't use the fill prefix to indent; (3) it passes the command argument to the Return command, rather than to the Tab command. * NMODE's C-X T command doesn't try to readjust the marks. * NMODE's C-X 4 command recognizes only B and F as options (not C-B or C-F). C. Just Plain Differences * NMODE customization is completely different than EMACS customization. * NMODE M-X commands always prompt for their arguments; Escape is not a terminator for the command name. * Find File in NMODE creates a buffer whose name is of the form "foo.bar", rather than "foo". * In NMODE, the various Lisp-related commands (C-M-B, etc.) are defined only in Lisp mode. * NMODE's "defun" commands don't set the mark. * C-M-L means "return to previous buffer" instead of "insert formfeed". * C-] is a prefix character (in Lisp mode) instead of meaning "abort". * C-X P means "write screen photo" instead of "narrow bounds to page". * NMODEs text filling commands compress non-leading tabs into spaces; EMACS leaves them alone. -------------------------------------------------------------------------------- III. Known deficiencies of NMODE * During prompted character input, the cursor remains in the edit window. * Printing to the OUTPUT buffer is slow. * Quitting out of NMODE to the standard break handler won't restore echoing. * NMODE does not provide a good way to interrupt a Lisp-E execution or printout. (The only way is to ^C NMODE and then START it.) * "Typeout" is clumsy. * If you type ^^x to get C-X, the prompt string is sort of strange. -------------------------------------------------------------------------------- IV. Things that NMODE has that EMACS doesn't * Miscellaneous Commands: M-Z - format comment (automatically sets the fill prefix) C-X V - toggle between normal and inverse-video C-X < - scroll window left C-X > - scroll window right C-X P - write screen photograph to file C-X E - exchange windows * Lisp Interface Commands * Buffer Browser * Split Screen option for Dired (and the Buffer Browser) * Two-Screen option (on 9836 with auxiliary color monitor) ------------------------------------------------------------------------------- |
Added psl-1983/3-1/psl/nmode-guide.txt version [d9690c387b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMODE users Alan Snyder 28 October 1982 ------------------------------------------------------------------------------- NMODE is a new PSL text editor installed at HP. This note describes the NMODE editor in terms of its differences from EMODE, the previous PSL text editor. NMODE is a new editor that retains much of the basic structure and algorithms of EMODE. However, there are many differences between NMODE and EMODE, of interest to both users and experts. For experts, the differences can be summed up very easily: NMODE is a complete rewrite of EMODE. Virtually no EMODE function or fluid variable is present in NMODE. Thus, any code that interacts with the insides of EMODE must be rewritten to run in NMODE. Even code to define new function keys must be changed. In many cases, it is only necessary to change function names. However, code that accesses EMODE fluid variables probably requires greater revision, since many EMODE fluid variables have no counterparts in NMODE. In particular, there are no fluid variables containing information about the current buffer or the current window. Information describing how to customize NMODE by redefining keys or defining new commands may be found in the file "PSL:NMODE-CUSTOMIZING.TXT". For users, the differences between NMODE and EMODE can be divided into a number of categories: * New Lisp Interaction * Incompatible Changes * Limitations * Extension of existing commands to conform to EMACS * New EMACS commands implemented * Bug Fixes * Miscellaneous Improvements These categories are described below: ------------------------------------------------------------------------------- * New Lisp Interaction NMODE provides a new set of editor commands for executing forms from a buffer and interacting with the Break Handler. These commands use a new prefix character, C-], which echoes as "Lisp-". In the remainder of this document, the notation "Lisp-X" will be used to refer to the command sequence C-] X (where X is an arbitrary character). The "Lisp-" commands are available only in Lisp Mode. Three "Lisp-" commands are always available in Lisp mode: Lisp-E executes a form in the current buffer beginning at the start of the current line. (This command was invoked as M-E in EMODE.) Output produced by the execution of a Lisp form is written to an output buffer (called "OUTPUT" in NMODE), which will pop up automatically in the "other" window if it is not exposed when output occurs. As in EMODE, this automatic pop-up can be suppressed by setting the global variable *OutWindow to NIL; however, in NMODE, this flag will be ignored when a Break occurs. In NMODE, output is always written at the END of the output buffer, even if the input is coming from the same buffer. Thus, when you execute a form from the output buffer, the cursor will jump to the end of the buffer when the output is printed. However, the mark is set at the point where you did the Lisp-E, so you can get back using C-X C-X. Lisp-Y will yank the output from the previous Lisp-E into the current buffer. (This command was invoked as C-M-Y in EMODE.) The output is obtained from the output buffer. Only the starting and ending positions of the last output text are saved, so that if the output buffer has been modified, Lisp-Y may get the wrong text. Lisp-L will transfer to a "normal" PSL Lisp Listener. (This command was invoked as C-M-Z in EMODE.) To return to NMODE, evaluate the form (NMODE). In NMODE, the Lisp prompt is displayed as part of the window label when the OUTPUT buffer is displayed, as opposed to permanently reserving a separate line on the screen for the Lisp prompt as EMODE does. NMODE does not use a break menu. However, NMODE does provide a set of special commands that can be used when a Lisp evaluation has entered a break loop. These commands are: Lisp-B: print a backtrace Lisp-Q: quit out of current break loop Lisp-A: abort to top-level (restarts NMODE) Lisp-R: retry (from a continuable error) (existing ErrorForm is re-evaluated) Lisp-C: continue (from a continuable error) (value of the last form executed is used for the value) Lisp-?: Brief help on above commands. Lisp-C is used to return a new value as the result value of the offending form (in the case of a continuable error). The value is specified by executing a form using Lisp-E; Lisp-C then "returns" the most recent result of execution. Lisp-B by itself prints the normal backtrace. C-U Lisp-B will in addition print the names of "interpreter" functions, such as COND and PROG. C-U C-U Lisp-B will print a verbose backtrace that displays the entire contents of the stack. The PSL function YesP has been redefined in NMODE to use NMODE prompted string input. It requires that the user type "Yes" or "No". ------------------------------------------------------------------------------- * Incompatible Changes A number of existing EMODE functions are performed using different commands in NMODE, leaving their original commands either undefined or doing something different. These are: C-X C-R (Visit File): now C-X C-V (to conform with EMACS) M-E (Execute Form): now Lisp-E (typed as: C-] E) C-M-Y (Yank Last Output): now Lisp-Y (typed as: C-] Y) C-M-Z (Exit NMode): now Lisp-L (typed as: C-] L) C-X 2 (View Two Windows): now C-X 3 (to conform with EMACS) C-M-O (Forward Up List): now C-M-) (same as EMACS) ------------------------------------------------------------------------------- * Limitations There are limitations imposed by NMODE that are not present in EMODE: * Currently, NMODE can be used only with HP terminals and with the 9836 running an extended VT52 emulator (the extensions are to support display enhancements). * Currently, NMODE runs only on TOPS-20. ------------------------------------------------------------------------------- * Extension of existing commands to conform to EMACS A large number of existing EMODE commands have been extended in NMODE to conform either exactly or more closely to the EMACS definitions. Many of these changes relate to the use of command arguments (specified by C-U). In EMODE, C-U simply defines a positive repetition count and repetitively executes the definition of the following command character. In NMODE, C-U works as in EMACS: it can accept either a positive or negative argument, which is interpreted in arbitrary ways by the following command. The following EMODE commands have been extended in notable ways: C-@ With an argument, pops a ring of marks (which is per-buffer). C-K Is unaffected by trailing white space at the end of the line. C-L Now repositions the current window. Accepts C-U argument. C-N and C-P Now remember the "goal column". C-V and M-V Scroll by lines or screenfuls, according to C-U argument. C-X 1 With an argument, expands the bottom window instead of the top. C-X 2 Now makes the bottom window current (use C-X 3 for top window). C-X C-S Now won't save an unmodified buffer. C-X C-V Now offers to save a modified buffer. C-X D Obeys command argument (without arg, uses current directory). C-X K Now asks for the name of the buffer to kill. C-X O Now works even in 1-window mode. M-< and M-> Now set the mark. Return Now will move "into" a region of blank lines. ------------------------------------------------------------------------------- * New EMACS commands implemented The following EMACS commands are newly implemented in NMODE: BackSpace Move Backward Character C-% Replace String C-< Mark Beginning C-> Mark End C-G Aborts commands that request string input C-M-( Backward Up List C-M-) Forward Up List C-M-O Split Line C-M-R Reposition Window (for Lisp DEFUNs only) C-M-Return Same as M-M C-M-T Transpose Forms C-M-Tab Lisp Tab (also C-M-I) C-M-V Scroll other window C-M-W Append Next Kill C-Rubout Delete Backward Hacking Tabs C-Space Same as C-@ C-X 3 View Two Windows C-X 4 Visit in Other Window (Find File or Select Buffer) C-X A Append to Buffer C-X C-N Set Goal Column C-X C-T Transpose Lines C-X G Get Register C-X T Transpose Regions C-X X Put Register C-^ The "control prefix" (used to type things like C-%) M-0 thru M-9 Define a numeric argument (also C-0, C-M-0, etc.) M-Hyphen Defines a numeric argument (also C-Hyphen, C-M-Hyphen, etc.) M-R Move to Screen Edge M-Return Same as M-M M-T Transpose Words M-Tab inserts a "Tab" (also M-I) M-~ Buffer Not Modified ------------------------------------------------------------------------------- * Bug Fixes In the process of writing NMODE, a number of bugs in EMODE were fixed. These include: * M-Y has been made "safe". It checks that the contents of the region equal the contents of the current kill buffer before killing the region. * Dired SORT commands no longer throw away all user-specified changes. * The interaction between NMODE and the Lisp Environment is much more robust. It is much more difficult to get NMODE "screwed up". In NMODE, it is possible to Quit out of an "Unexpected EOF" error. * NMODE does not allow the user to select one of its internal buffers. * In NMODE, string input can be terminated only by Return or C-G (C-G aborts the command). * The M-? command now accepts any syntactically valid command, including character sequences using prefix characters. * NMODE will not screw up if the cursor is moved into a part of a line that does not show on the display. * The window position indicator ("--68%--") now works reasonably. * EMODE always advances to the next line after a M-E; NMODE suppresses this action in two cases where it is spurious: (1) when NMODE is starting up, (2) when the buffer pointer is at the beginning of the line, such as after "executing" a number. ------------------------------------------------------------------------------- * Miscellaneous Improvements * NMODE supports INIT files. When first started up, NMODE will execute the file "NMODE.INIT" on the user's home directory, if the file exists. The file should contain a sequence of Lisp forms. * Completion of buffer names is implemented in NMODE. Completion is requested using the Space character. * File names now always expand to the full "true" file name (as in EMACS). As a result, Find File will always find a file in an existing buffer if possible, regardless of the exact string typed by the user. In addition, file names specified by the user now MERGE with the default file name. * Find File now creates a reasonable buffer name, instead of using the exact string typed by the user. The buffer name will not be displayed on the mode line, if it is completely redundant. * "Lisp" and "Text" modes are now available; the choice is based on file name. In "Text" mode, the Lisp related commands (both C-M-* and Lisp-*) are undefined, Tab is self-inserting, and Rubout does not "hack tabs". * The M-X extended command interface has been implemented. The following M-X commands are defined: "M-X Lisp Mode" and "M-X Text Mode", which set the mode of the current buffer. * Display Refresh is interruptible, allowing faster type-ahead. Parenthesis matching is also interruptible, which is especially important in the case of inserting an unmatched parenthesis. * Prompting has been improved. * Horizontal scrolling is supported. Two new commands, C-X < and C-X >, are provided to scroll the window horizontally. They accept a C-U argument. * The buffer display now shows a '!' at the end of any line that extends past the right edge of the screen. * Displaying one buffer in two windows now works reasonably. * Each buffer has a modified flag which indicates whether the contents of the buffer have been changed since the buffer was last read or written. * The "mode line" now uses inverse video and is much more like EMACS. * Display enhancements are supported in a general fashion. A new command C-X V has been implemented to switch between normal and inverse video. * When entering string input, C-R will yank the default string into the input buffer. ------------------------------------------------------------------------------- |
Added psl-1983/3-1/psl/nmode.exe version [a154b2077a].
cannot compute difference between binary files
Added psl-1983/3-1/psl/nmode.init version [54466585b2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This is the "default" NMODE.INIT file. It will be evaluated when NMODE starts % up, unless the file *NMODE.INIT exists, in which case that file will be % evaluated instead. It is recommended that any personal NMODE.INIT file begin % with the form: % % (nmode-read-and-evaluate-file nmode-default-init-file-name) % % which will cause this file to be evaluated first. % Make the BACKSPACE key behave like Rubout! % Make M-BACKSPACE behave like M-Rubout! (remove-from-command-list 'Read-Only-Text-Command-List (x-char BACKSPACE)) (remove-from-command-list 'Lisp-Command-List (x-char M-BACKSPACE)) (add-to-command-list 'Text-Command-List (x-char BACKSPACE) 'delete-backward-character-command) (add-to-command-list 'Text-Command-List (x-char M-BACKSPACE) 'kill-backward-word-command) (add-to-command-list 'Lisp-Command-List (x-char BACKSPACE) 'delete-backward-hacking-tabs-command) (nmode-establish-current-mode) (when (not (funboundp 'nmode-define-softkey)) (nmode-define-softkey 0 'exit-nmode "Exit") (nmode-define-softkey 1 'buffer-browser-command "Buffers") (nmode-define-softkey 2 'find-file-command "Find File") (nmode-define-softkey 3 'save-file-command "Save File") (if (not (funboundp 'browser-browser-command)) (nmode-define-softkey 4 'browser-browser-command "Browsers") (nmode-define-softkey 4 'fill-paragraph-command "Fill Para") ) (nmode-define-softkey 5 'pasemulate "Hulk") (nmode-define-softkey 6 'pasfiler "Filer") (nmode-define-softkey 8 (string (x-char ^!])) "Lisp-") (nmode-define-softkey 9 (string (x-char ^!\) #/X) "M-X") ) |
Added psl-1983/3-1/psl/psl.exe version [bc1ed81ce5].
cannot compute difference between binary files
Added psl-1983/3-1/psl/pslcomp.exe version [2243384eb6].
cannot compute difference between binary files
Added psl-1983/3-1/psl/rlisp.exe version [f931b16115].
cannot compute difference between binary files
Added psl-1983/3-1/tests/16mhz-hp9836.tim version [4bb0ad4b67].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("PSL 3.1, Faster 16Mhz with cache HP9836" . " 5-Mar-83") (EmptyTest-10000 . 30) (GEmptyTest-10000 . 740) (Cdr1Test-100 . 1050) (Cdr2Test-100 . 440) (CddrTest-100 . 340) (ListOnlyCdrTest1 . 2520) (ListOnlyCddrTest1 . 4160) (ListOnlyCdrTest2 . 6160) (ListOnlyCddrTest2 . 7790) (ReverseTest-10 . 640) (MyReverse1Test-10 . 650) (MyReverse2Test-10 . 580) (LengthTest-100 . 1230) (ArithmeticTest-10000 . 2690) (EvalTest-10000 . 7220) (tak-18-12-6 . 1240) (gtak-18-12-6 . 5190) (gtsta-g0 . 2350) (gtsta-g1 . 2400) ) |
Added psl-1983/3-1/tests/20/008lnk.exe version [f0524f632a].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/20-test-global-data.red version [18859a06a5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 20-TEST-GLOBAL-DATA - Data used by everyone, test version % % Author: Eric Benson, M Griss, S Lowder % Computer Science Dept. % University of Utah % Date: 1 September 1981 % Copyright (c) 1981 University of Utah on SysLisp; % For testing with MAINn, see P20T:XXX-HEADER.RED % Want a small SYMTAB and HEAP exported WConst MaxSymbols = 800, % Use 500 upto MAIN7 MaxChannels = 31, MaxObArray = 800, % Use 500 upto MAIN7 MaxRealRegs = 5, MaxArgs = 15; % BitPositions for testing, etc: exported Wconst BitsPerWord=36; % The STACK stuff external WVAR ST, StackLowerBound, StackUpperBound; % "standard" Symbol table Data structures, handled % specially in Compiler external Warray Symnam,SymVal,SymFnc,SymPrp; external WVar NextSymbol; % For extra arguments not in Real registers external WArray ArgumentBlock; % For the Foreign Function Calling Protocol external Wvar Arg1,Arg2,Arg3,Arg4,Arg5,Arg6,Arg7,Arg8,Arg9, Arg10,Arg11,Arg12,Arg13,Arg14,Arg15; external Warray HashTable; off SysLisp; END; |
Added psl-1983/3-1/tests/20/20-test.output version [86d7cb83aa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @@ex @@main1 LINK: Loading [LNKXCT MAIN1 execution] Call on Init AB 9 10 8 90 7 720 6 5040 5 30240 4 151200 3 604800 2 1814400 1 3628800 3628800 Ctime: 98662 ms, 98662 ms Ctime: 99412 ms, 750 ms Ctime: 99450 ms, 38 ms 7 Ctime: 99913 ms, 463 ms Quitting @NEWPAGE() @@ex @@main2 LINK: Loading [LNKXCT MAIN2 execution] Call on Init StrInf 55688 55688 Strlen 51 51 Byte 0 65 A 1 97 a 2 66 B 3 98 b 4 67 C 5 99 c 6 68 D 7 100 d 8 69 E 9 101 e 10 70 F String AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUnVvWwXxYyZz "----- Now input characters until #" 11223344556677 aaaabbbbccddeeffgg #"----- First Print Called" 1 ANATOM (1 . 2) (AA (B1 . B2 ) . B3 ) (AA (B1 ) ) Quitting @NEWPAGE() @@ex @@main3 LINK: Loading [LNKXCT MAIN3 execution] Call on Init "MAIN3: Casetest" Test case from -1 to 11 Will classify argument Show for N=-1, expect default case Show for N=0, expect 0 case Show for N=1, expect 1,2,3 case Show for N=2, expect 1,2,3 case Show for N=3, expect 1,2,3 case Show for N=4, expect default case Show for N=5, expect default case Show for N=6, expect 6 ... 10 case Show for N=7, expect 6 ... 10 case Show for N=8, expect 6 ... 10 case Show for N=9, expect 6 ... 10 case Show for N=10, expect 6 ... 10 case Show for N=11, expect default case Show for N=12, expect default case "MAIN3: test CONS" (2 . 1) (3 2 . 1) (4 3 2 . 1) (5 4 3 2 . 1) (6 5 4 3 2 . 1) (7 6 5 4 3 2 . 1) (8 7 6 5 4 3 2 . 1) (9 8 7 6 5 4 3 2 . 1) Quitting @NEWPAGE() @@ex @@main4 LINK: Loading [LNKXCT MAIN4 execution] 1. --- Test EQSTR ----- For EqStr(AB,AB) T should be T OK ------ ----- For EqStr(AB,AB) T should be T OK ------ ----- For EqStr(AB,Ab) NIL should be NIL OK ------ ----- For EqStr(AB,ABC) NIL should be NIL OK ------ 2. --- Test FindId on existing ID's Lookup string="A" Found In LookUpId=65 ----- For FindId(A) A should be A OK ------ Lookup string="AB" Found In LookUpId=190 ----- For FindId(AB) AB should be AB OK ------ 3. --- Test FindId on new ID, make sure same place Lookup string="ABC" Not Found in LookupId New ID# 192 Lookup string="ABC" Found In LookUpId=192 ----- For FindId(ABC) ABC should be ABC OK ------ Lookup string="FOO" Not Found in LookupId New ID# 193 Lookup string="ABC" Found In LookUpId=192 ----- For FindId(ABC) again ABC should be ABC OK ------ 4. --- Test RATOM loop. Type various ID's, STRING's and INTEGER's Move to next part of test by typing the id Q Inspect printout carefully NextSymbol =194 1 Item read= <0:1> 1 "123"Item read= <4:5890> "123" A Lookup string="A" Found In LookUpId=65 Item read= <30:65> A a Lookup string="a" Found In LookUpId=97 Item read= <30:97> a AA Lookup string="AA" Not Found in LookupId New ID# 194 Item read= <30:194> AA aa Lookup string="aa" Not Found in LookupId New ID# 195 Item read= <30:195> aa abc Lookup string="abc" Not Found in LookupId New ID# 196 Item read= <30:196> abc ABC Lookup string="ABC" Found In LookUpId=192 Item read= <30:192> ABC abc Lookup string="abc" Found In LookUpId=196 Item read= <30:196> abc Q Lookup string="Q" Found In LookUpId=81 Item read= <30:81> Q 5. --- Test READ loop. Type various S-expressions Move to next part of test by typing the id Q Inspect printout carefully 'A Item read= <9:5912> (QUOTE A ) (12 '(34) (5 (6))) Item read= <9:5930> (12 (QUOTE (34) ) (5 (6) ) ) Q Item read= <30:81> Q Quitting @NEWPAGE() @@ex @@main5 LINK: Loading [LNKXCT MAIN5 execution] (very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q 1 lisp> 1 1 2 lisp> 'A A 3 lisp> (SETQ A 3) 3 4 lisp> A 3 5 lisp> (PRINT (CONS A A)) (3 . 3) (3 . 3) 6 lisp> (QUIT) Quitting @NEWPAGE() @@ex @@main6 LINK: Loading %LNKFTH Fullword value RESET being truncated to halfword %LNKMDS Multiply-defined global symbol RESET Detected in module .MAIN from file DSK:SUB6.REL Defined value = 104000000147, this value = 163306 [LNKXCT MAIN6 execution] Test BINDING Primitives ----- For 3rd bound AA 3 should be 3 OK ------ ----- For 2rd bound AA NIL should be NIL OK ------ ----- For Original AA 1 should be 1 OK ------ MINI-PSL: A Read-Eval-Print Loop, terminate with Q 1 lisp> (DE FOO (X) (COND ((NULL X) 2) (T 3))) FOO 2 lisp> (FOO NIL) 2 3 lisp> (FOO 2) 3 4 lisp> (DF E (TIM) (TIMEEVAL TIM)) E 5 lisp> (TESTSETUP) (SETQ FOO (CADR (QUOTE (1 2 3) ) ) ) 6 lisp> (E EMPTYTEST 10000) Ctime: 118090 ms, 118090 ms Ctime: 118127 ms, 37 ms 37 7 lisp> (E SLOWEMPTYTEST 10000) Ctime: 118259 ms, 132 ms Ctime: 118413 ms, 154 ms 154 8 lisp> (E LISTONLYCDRTEST1) Ctime: 118534 ms, 121 ms Ctime: 120275 ms, 1741 ms 1741 9 lisp> (FUM) **** Uncompiled function in APPLY: FUM NIL NIL 10 lisp> (QUIT) Quitting |
Added psl-1983/3-1/tests/20/20io.mac version [e075133e46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; 20IO: simple 20 Support routines TITLE 20IO SEARCH MONSYM RADIX ^D10 ENTRY GETC20,PUTC20,INIT20,QUIT20,TIMC20,ERR20,PUTI20 ST=15 INIT20: HRROI 1,[Asciz/ Call on Init /] PSOUT JFCL POPJ ST,0 GETC20: PBIN JFCL POPJ ST,0 PUTC20: PBOUT JFCL CAIE 1,10 ; Is it EOL POPJ ST,0 ; No MOVEI 1,13 PBOUT JFCL MOVEI 1,10 POPJ ST,0 PUTI20: MOVEM 1,JUNK MOVE 2,1 MOVEI 1,^O101 MOVEI 3,^D10 NOUT JFCL MOVE 1,JUNK POPJ ST,0 ERR20: MOVEM 1,Junk HRROI 1,[ASCIZ/ *** ERR20: /] PSOUT MOVE 1,Junk PUSHJ ST,PUTI20 MOVEI 1,10 PBOUT HALTF HALTF POPJ ST,0 Junk: Block 1 QUIT20: Hrroi 1,[ASCIZ/ Quitting /] PSOUT HALTF TIMC20: MOVEI 1,-5 RUNTM JFCL MOVEM 1,NTIME ; Hrroi 1,[ASCIZ/ ;Ctime: /] ; PSOUT ; MOVE 1,NTIME ; PUSHJ ST,PutI20 ; Hrroi 1,[ASCIZ/ ms, /] ; PSOUT MOVE 1,NTIME ; SUB 1,OTIME ; PUSHJ ST,PutI20 ; Hrroi 1,[ASCIZ/ ms ; /] ; PSOUT MOVE 1,NTIME MOVEM 1,OTIME POPJ ST,0 Otime: 0 Ntime: 0 END |
Added psl-1983/3-1/tests/20/20io.rel version [79e2055c17].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/20main.mac version [17d23a1274].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | ; 20-main: simple driver to test MACRO version of 20 tests TITLE MAIN SEARCH MONSYM RADIX ^D10 EXTERN INIT20,MAIN20,QUIT20 ST=15 MAIN: RESET MOVE ST,[-1000,Stack] PUSHJ ST,INIT20 PUSHJ ST,MAIN20 PUSHJ ST,QUIT20 stack: block 1000 END MAIN |
Added psl-1983/3-1/tests/20/20test.mac version [b1eb7a94bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; 20-TEST SIMPLE I/O TESTS, HANDCODED TITLE 20TEST ; MLG, 20 JULY 1982 SEARCH MONSYM RADIX ^D10 EXTERN GETC20,PUTC20,PUTI20,ERR20,TIMC20,QUIT20 ENTRY MAIN20 ST=15 MAIN20: MOVEI 1,1 PUSHJ ST, PUTI20 ; Print a 1 for first test MOVEI 1,10 PUSHJ ST, PUTC20 ; EOL to flush line MOVEI 1,2 PUSHJ ST, PUTI20 ; Second test MOVEI 1,65 PUSHJ ST, PUTC20 ; A capital A MOVEI 1,66 PUSHJ ST, PUTC20 ; A capital B MOVEI 1,10 PUSHJ ST, PUTC20 ; EOL to flush line MOVEI 1,3 PUSHJ ST, PUTI20 ; Third test, type in AB <cr> PUSHJ ST, GETC20 PUSHJ ST, PUTC20 ; Should print A65 PUSHJ ST, PUTI20 MOVEI 1,10 PUSHJ ST,PUTC20 PUSHJ ST, GETC20 PUSHJ ST, PUTC20 ; Should print B66 PUSHJ ST, PUTI20 MOVEI 1,10 PUSHJ ST,PUTC20 PUSHJ ST, GETC20 PUSHJ ST, PUTI20 ; should print 10 and EOL PUSHJ ST, PUTC20 MOVEI 1,10 PUSHJ ST,PUTC20 movei 1,4 pushj st, puti20 ; last test Pushj st,timc20 PushJ st, puti20 movei 1,100 pushj st, err20 movei 1,26 pushj st, putc20 ; eof to flush buffer movei 1,0 pushj st, quit20 POPJ ST, END |
Added psl-1983/3-1/tests/20/dec20-patches.sl version [f3fb26b511].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DEC20-PATCHES.SL % to convert to Portable, 2 reg for LINK model % From DEC20-Asm.RED % These will now be simpler than 20, just JRST % Should even be InternalEntry for efficiency, avoid circular defns % Right now, expect same as !%Store!-JCALL would install (SETQ UndefinedFunctionCellInstructions!* '((!*JCALL UndefinedFunction))) (SETQ LambdaFunctionCellInstructions!* '((!*JCALL CompiledCallingInterpreted))) (Put 'LinkReg 'RegisterName 12) (Put 'NargReg 'RegisterName 13) % From PC:Common-Cmacros.sl (de MakeLinkRegs(Fn Nargs) (cond ((FlagP Fn 'NoLinkage) NIL) (T (list (list '!*Move (list 'IdLoc FunctionName) '(reg LinkReg) ) (list '!*Move (list 'Wconst NumberofArguments) '(reg NargReg) ) )))) (FLAG '(IDapply0 IDapply1 IDapply2 IDapply3 IDapply4) 'NoLinkage) (de !*Link (FunctionName FunctionType NumberOfArguments) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments))) (t (append (MakeLinkRegs FunctionName NumberofArguments) (list (list '!*Call FunctionName)))))) (de !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) (cons (list '!*DeAlloc DeAllocCount) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments) '(!*Exit 0))) (t (Append (MakeLinkRegs FunctionName NumberofArguments) (list (list '!*JCall FunctionName))))))) (DefList '((IDApply0 ( (!*move (Wconst 0) (reg NargReg)) (!*move (reg 1) (reg LinkReg)) % (!*Wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ( (!*move (Wconst 1) (reg NargReg)) (!*move (reg 2) (reg LinkReg)) % (!*Wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ( (!*move (Wconst 2) (reg NargReg)) (!*move (reg 3) (reg LinkReg)) % (!*Wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ( (!*move (Wconst 3) (reg NargReg)) (!*move (reg 4) (reg LinkReg)) % (!*Wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ( (!*move (Wconst 4) (reg NargReg)) (!*move (reg 5) (reg LinkReg)) % (!*Wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell)) (pushj (reg st) (Indexed (reg 5) (WArray SymFnc))))) ) 'OpenCode) (DefList '((IDApply0 ( (!*move (Wconst 0) (reg NargReg)) (!*move (reg 1) (reg LinkReg)) % (!*wtimes2 (reg 1) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 1) (WArray SymFnc))))) (IDApply1 ( (!*move (Wconst 1) (reg NargReg)) (!*move (reg 2) (reg LinkReg)) % (!*wtimes2 (reg 2) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 2) (WArray SymFnc))))) (IDApply2 ( (!*move (Wconst 2) (reg NargReg)) (!*move (reg 3) (reg LinkReg)) % (!*wtimes2 (reg 3) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 3) (WArray SymFnc))))) (IDApply3 ( (!*move (Wconst 3) (reg NargReg)) (!*move (reg 4) (reg LinkReg)) % (!*wtimes2 (reg 4) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 4) (WArray SymFnc))))) (IDApply4 ( (!*move (Wconst 4) (reg NargReg)) (!*move (reg 5) (reg LinkReg)) % (!*wtimes2 (reg 5) (Wconst AddressingUnitsPerFunctionCell)) (jrst (Indexed (reg 5) (WArray SymFnc))))) ) 'ExitOpenCode) % From PC:lap-to-asm.red (de DataPrintUndefinedFunctionCell () (Prog (OldOut) (setq OldOut (WRS DataOut!*)) (foreach X in (Pass1Lap UndefinedFunctionCellInstructions!*) do (ASMOutLap1 X)) (WRS OldOut))) (DSKIN "PT:P-LAMBIND.SL") % new SYSLISP bug, perhaps useful refefined it? (off usermode) (dm for(u) ( MkFor1 u)) |
Added psl-1983/3-1/tests/20/dfield.mac version [d6fe9e5e78].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 301 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+300 intern L0002 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <29_31>+133 <29_31>+134 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <29_31>+150 block 50 SYMNAM: intern SYMNAM extern L0063 <4_31>+L0063 extern L0064 <4_31>+L0064 extern L0065 <4_31>+L0065 extern L0066 <4_31>+L0066 extern L0067 <4_31>+L0067 extern L0068 <4_31>+L0068 extern L0069 <4_31>+L0069 extern L0070 <4_31>+L0070 extern L0071 <4_31>+L0071 extern L0072 <4_31>+L0072 extern L0073 <4_31>+L0073 extern L0074 <4_31>+L0074 extern L0075 <4_31>+L0075 extern L0076 <4_31>+L0076 extern L0077 <4_31>+L0077 extern L0078 <4_31>+L0078 extern L0079 <4_31>+L0079 extern L0080 <4_31>+L0080 extern L0081 <4_31>+L0081 extern L0082 <4_31>+L0082 extern L0083 <4_31>+L0083 extern L0084 <4_31>+L0084 extern L0085 <4_31>+L0085 extern L0086 <4_31>+L0086 extern L0087 <4_31>+L0087 extern L0088 <4_31>+L0088 extern L0089 <4_31>+L0089 extern L0090 <4_31>+L0090 extern L0091 <4_31>+L0091 extern L0092 <4_31>+L0092 extern L0093 <4_31>+L0093 extern L0094 <4_31>+L0094 extern L0095 <4_31>+L0095 extern L0096 <4_31>+L0096 extern L0097 <4_31>+L0097 extern L0098 <4_31>+L0098 extern L0099 <4_31>+L0099 extern L0100 <4_31>+L0100 extern L0101 <4_31>+L0101 extern L0102 <4_31>+L0102 extern L0103 <4_31>+L0103 extern L0104 <4_31>+L0104 extern L0105 <4_31>+L0105 extern L0106 <4_31>+L0106 extern L0107 <4_31>+L0107 extern L0108 <4_31>+L0108 extern L0109 <4_31>+L0109 extern L0110 <4_31>+L0110 extern L0111 <4_31>+L0111 extern L0112 <4_31>+L0112 extern L0113 <4_31>+L0113 extern L0114 <4_31>+L0114 extern L0115 <4_31>+L0115 extern L0116 <4_31>+L0116 extern L0117 <4_31>+L0117 extern L0118 <4_31>+L0118 extern L0119 <4_31>+L0119 extern L0120 <4_31>+L0120 extern L0121 <4_31>+L0121 extern L0122 <4_31>+L0122 extern L0123 <4_31>+L0123 extern L0124 <4_31>+L0124 extern L0125 <4_31>+L0125 extern L0126 <4_31>+L0126 extern L0127 <4_31>+L0127 extern L0128 <4_31>+L0128 extern L0129 <4_31>+L0129 extern L0130 <4_31>+L0130 extern L0131 <4_31>+L0131 extern L0132 <4_31>+L0132 extern L0133 <4_31>+L0133 extern L0134 <4_31>+L0134 extern L0135 <4_31>+L0135 extern L0136 <4_31>+L0136 extern L0137 <4_31>+L0137 extern L0138 <4_31>+L0138 extern L0139 <4_31>+L0139 extern L0140 <4_31>+L0140 extern L0141 <4_31>+L0141 extern L0142 <4_31>+L0142 extern L0143 <4_31>+L0143 extern L0144 <4_31>+L0144 extern L0145 <4_31>+L0145 extern L0146 <4_31>+L0146 extern L0147 <4_31>+L0147 extern L0148 <4_31>+L0148 extern L0149 <4_31>+L0149 extern L0150 <4_31>+L0150 extern L0151 <4_31>+L0151 extern L0152 <4_31>+L0152 extern L0153 <4_31>+L0153 extern L0154 <4_31>+L0154 extern L0155 <4_31>+L0155 extern L0156 <4_31>+L0156 extern L0157 <4_31>+L0157 extern L0158 <4_31>+L0158 extern L0159 <4_31>+L0159 extern L0160 <4_31>+L0160 extern L0161 <4_31>+L0161 extern L0162 <4_31>+L0162 extern L0163 <4_31>+L0163 extern L0164 <4_31>+L0164 extern L0165 <4_31>+L0165 extern L0166 <4_31>+L0166 extern L0167 <4_31>+L0167 extern L0168 <4_31>+L0168 extern L0169 <4_31>+L0169 extern L0170 <4_31>+L0170 extern L0171 <4_31>+L0171 extern L0172 <4_31>+L0172 extern L0173 <4_31>+L0173 extern L0174 <4_31>+L0174 extern L0175 <4_31>+L0175 extern L0176 <4_31>+L0176 extern L0177 <4_31>+L0177 extern L0178 <4_31>+L0178 extern L0179 <4_31>+L0179 extern L0180 <4_31>+L0180 extern L0181 <4_31>+L0181 extern L0182 <4_31>+L0182 extern L0183 <4_31>+L0183 extern L0184 <4_31>+L0184 extern L0185 <4_31>+L0185 extern L0186 <4_31>+L0186 extern L0187 <4_31>+L0187 extern L0188 <4_31>+L0188 extern L0189 <4_31>+L0189 extern L0190 <4_31>+L0190 extern L0191 <4_31>+L0191 extern L0192 <4_31>+L0192 extern L0193 <4_31>+L0193 extern L0194 <4_31>+L0194 extern L0195 <4_31>+L0195 extern L0196 <4_31>+L0196 extern L0197 <4_31>+L0197 extern L0198 <4_31>+L0198 extern L0199 <4_31>+L0199 extern L0200 <4_31>+L0200 extern L0201 <4_31>+L0201 extern L0202 <4_31>+L0202 extern L0203 <4_31>+L0203 extern L0204 <4_31>+L0204 extern L0205 <4_31>+L0205 extern L0206 <4_31>+L0206 extern L0207 <4_31>+L0207 extern L0208 <4_31>+L0208 extern L0209 <4_31>+L0209 extern L0210 <4_31>+L0210 extern L0211 <4_31>+L0211 extern L0212 <4_31>+L0212 extern L0213 <4_31>+L0213 block 50 SYMFNC: intern SYMFNC JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 JSP 10,SYMFNC+137 extern MAIN. jrst MAIN.## extern L0008 jrst L0008## extern INIT jrst INIT## extern GETC jrst GETC## extern TIMC jrst TIMC## extern PUTC jrst PUTC## extern QUIT jrst QUIT## extern PUTINT jrst PUTINT## extern L0006 jrst L0006## extern FLAG jrst FLAG## extern L0007 jrst L0007## extern MSG5 jrst MSG5## extern TESTOK jrst TESTOK## extern L0059 jrst L0059## JSP 10,SYMFNC+137 extern L0014 jrst L0014## extern L0028 jrst L0028## extern L0043 jrst L0043## extern L0061 jrst L0061## extern L0058 jrst L0058## extern L0060 jrst L0060## extern L0062 jrst L0062## block 50 L0003: intern L0003 151 end |
Added psl-1983/3-1/tests/20/dfoo.rel version [dac78c6829].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain0.mac version [437806d82e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 5001 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 HEAP: block 150001 intern HEAP L0006: HEAP+0 intern L0006 L0007: HEAP+150000 intern L0007 L0008: 0 intern L0008 L0009: 0 intern L0009 L0010: 0 intern L0010 L0011: 0 intern L0011 L0012: block 20 intern L0012 BPS: block 501 intern BPS L0013: BPS+0 intern L0013 L0014: BPS+0 intern L0014 L0015: BPS+500 intern L0015 L0016: BPS+500 intern L0016 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 L0005: block 401 intern L0005 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <30_31>+128 <30_31>+128 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <30_31>+128 <30_31>+128 <29_31>+152 <29_31>+153 <29_31>+154 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 block 641 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 641 SYMNAM: intern SYMNAM extern L0037 <4_31>+L0037 extern L0038 <4_31>+L0038 extern L0039 <4_31>+L0039 extern L0040 <4_31>+L0040 extern L0041 <4_31>+L0041 extern L0042 <4_31>+L0042 extern L0043 <4_31>+L0043 extern L0044 <4_31>+L0044 extern L0045 <4_31>+L0045 extern L0046 <4_31>+L0046 extern L0047 <4_31>+L0047 extern L0048 <4_31>+L0048 extern L0049 <4_31>+L0049 extern L0050 <4_31>+L0050 extern L0051 <4_31>+L0051 extern L0052 <4_31>+L0052 extern L0053 <4_31>+L0053 extern L0054 <4_31>+L0054 extern L0055 <4_31>+L0055 extern L0056 <4_31>+L0056 extern L0057 <4_31>+L0057 extern L0058 <4_31>+L0058 extern L0059 <4_31>+L0059 extern L0060 <4_31>+L0060 extern L0061 <4_31>+L0061 extern L0062 <4_31>+L0062 extern L0063 <4_31>+L0063 extern L0064 <4_31>+L0064 extern L0065 <4_31>+L0065 extern L0066 <4_31>+L0066 extern L0067 <4_31>+L0067 extern L0068 <4_31>+L0068 extern L0069 <4_31>+L0069 extern L0070 <4_31>+L0070 extern L0071 <4_31>+L0071 extern L0072 <4_31>+L0072 extern L0073 <4_31>+L0073 extern L0074 <4_31>+L0074 extern L0075 <4_31>+L0075 extern L0076 <4_31>+L0076 extern L0077 <4_31>+L0077 extern L0078 <4_31>+L0078 extern L0079 <4_31>+L0079 extern L0080 <4_31>+L0080 extern L0081 <4_31>+L0081 extern L0082 <4_31>+L0082 extern L0083 <4_31>+L0083 extern L0084 <4_31>+L0084 extern L0085 <4_31>+L0085 extern L0086 <4_31>+L0086 extern L0087 <4_31>+L0087 extern L0088 <4_31>+L0088 extern L0089 <4_31>+L0089 extern L0090 <4_31>+L0090 extern L0091 <4_31>+L0091 extern L0092 <4_31>+L0092 extern L0093 <4_31>+L0093 extern L0094 <4_31>+L0094 extern L0095 <4_31>+L0095 extern L0096 <4_31>+L0096 extern L0097 <4_31>+L0097 extern L0098 <4_31>+L0098 extern L0099 <4_31>+L0099 extern L0100 <4_31>+L0100 extern L0101 <4_31>+L0101 extern L0102 <4_31>+L0102 extern L0103 <4_31>+L0103 extern L0104 <4_31>+L0104 extern L0105 <4_31>+L0105 extern L0106 <4_31>+L0106 extern L0107 <4_31>+L0107 extern L0108 <4_31>+L0108 extern L0109 <4_31>+L0109 extern L0110 <4_31>+L0110 extern L0111 <4_31>+L0111 extern L0112 <4_31>+L0112 extern L0113 <4_31>+L0113 extern L0114 <4_31>+L0114 extern L0115 <4_31>+L0115 extern L0116 <4_31>+L0116 extern L0117 <4_31>+L0117 extern L0118 <4_31>+L0118 extern L0119 <4_31>+L0119 extern L0120 <4_31>+L0120 extern L0121 <4_31>+L0121 extern L0122 <4_31>+L0122 extern L0123 <4_31>+L0123 extern L0124 <4_31>+L0124 extern L0125 <4_31>+L0125 extern L0126 <4_31>+L0126 extern L0127 <4_31>+L0127 extern L0128 <4_31>+L0128 extern L0129 <4_31>+L0129 extern L0130 <4_31>+L0130 extern L0131 <4_31>+L0131 extern L0132 <4_31>+L0132 extern L0133 <4_31>+L0133 extern L0134 <4_31>+L0134 extern L0135 <4_31>+L0135 extern L0136 <4_31>+L0136 extern L0137 <4_31>+L0137 extern L0138 <4_31>+L0138 extern L0139 <4_31>+L0139 extern L0140 <4_31>+L0140 extern L0141 <4_31>+L0141 extern L0142 <4_31>+L0142 extern L0143 <4_31>+L0143 extern L0144 <4_31>+L0144 extern L0145 <4_31>+L0145 extern L0146 <4_31>+L0146 extern L0147 <4_31>+L0147 extern L0148 <4_31>+L0148 extern L0149 <4_31>+L0149 extern L0150 <4_31>+L0150 extern L0151 <4_31>+L0151 extern L0152 <4_31>+L0152 extern L0153 <4_31>+L0153 extern L0154 <4_31>+L0154 extern L0155 <4_31>+L0155 extern L0156 <4_31>+L0156 extern L0157 <4_31>+L0157 extern L0158 <4_31>+L0158 extern L0159 <4_31>+L0159 extern L0160 <4_31>+L0160 extern L0161 <4_31>+L0161 extern L0162 <4_31>+L0162 extern L0163 <4_31>+L0163 extern L0164 <4_31>+L0164 extern L0165 <4_31>+L0165 extern L0166 <4_31>+L0166 extern L0167 <4_31>+L0167 extern L0168 <4_31>+L0168 extern L0169 <4_31>+L0169 extern L0170 <4_31>+L0170 extern L0171 <4_31>+L0171 extern L0172 <4_31>+L0172 extern L0173 <4_31>+L0173 extern L0174 <4_31>+L0174 extern L0175 <4_31>+L0175 extern L0176 <4_31>+L0176 extern L0177 <4_31>+L0177 extern L0178 <4_31>+L0178 extern L0179 <4_31>+L0179 extern L0180 <4_31>+L0180 extern L0181 <4_31>+L0181 extern L0182 <4_31>+L0182 extern L0183 <4_31>+L0183 extern L0184 <4_31>+L0184 extern L0185 <4_31>+L0185 extern L0186 <4_31>+L0186 extern L0187 <4_31>+L0187 extern L0188 <4_31>+L0188 extern L0189 <4_31>+L0189 extern L0190 <4_31>+L0190 extern L0191 <4_31>+L0191 extern L0192 <4_31>+L0192 extern L0193 <4_31>+L0193 extern L0194 <4_31>+L0194 extern L0195 <4_31>+L0195 extern L0196 <4_31>+L0196 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 extern L0017 jrst L0017## extern L0035 jrst L0035## extern MAIN. jrst MAIN.## extern INIT jrst INIT## JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 extern GETC jrst GETC## extern TIMC jrst TIMC## JRST SYMFNC+149 extern PUTC jrst PUTC## extern QUIT jrst QUIT## extern L0021 jrst L0021## JRST SYMFNC+149 extern RESET jrst RESET## extern DATE jrst DATE## extern L0028 jrst L0028## extern PUTINT jrst PUTINT## extern L0029 jrst L0029## extern L0030 jrst L0030## extern L0031 jrst L0031## JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 extern L0032 jrst L0032## JRST SYMFNC+149 extern L0033 jrst L0033## JRST SYMFNC+149 extern L0034 jrst L0034## extern TERPRI jrst TERPRI## extern L0036 jrst L0036## block 641 L0003: intern L0003 160 end |
Added psl-1983/3-1/tests/20/dmain0.rel version [87aa8239f6].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain1.mac version [c06818f782].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | radix 10 STACK: block 5001 intern STACK L0001: STACK+0 intern L0001 L0002: STACK+5000 intern L0002 HEAP: block 150001 intern HEAP L0006: HEAP+0 intern L0006 L0007: HEAP+150000 intern L0007 L0008: 0 intern L0008 L0009: 0 intern L0009 L0010: 0 intern L0010 L0011: 0 intern L0011 L0012: block 20 intern L0012 BPS: block 501 intern BPS L0013: BPS+0 intern L0013 L0014: BPS+0 intern L0014 L0015: BPS+500 intern L0015 L0016: BPS+500 intern L0016 L0004: block 10 intern L0004 ARG1: 0 intern ARG1 ARG2: 0 intern ARG2 ARG3: 0 intern ARG3 ARG4: 0 intern ARG4 ARG5: 0 intern ARG5 ARG6: 0 intern ARG6 ARG7: 0 intern ARG7 ARG8: 0 intern ARG8 ARG9: 0 intern ARG9 ARG10: 0 intern ARG10 ARG11: 0 intern ARG11 ARG12: 0 intern ARG12 ARG13: 0 intern ARG13 ARG14: 0 intern ARG14 ARG15: 0 intern ARG15 L0005: block 401 intern L0005 SYMVAL: intern SYMVAL <29_31>+0 <29_31>+1 <29_31>+2 <29_31>+3 <29_31>+4 <29_31>+5 <29_31>+6 <29_31>+7 <29_31>+8 <29_31>+9 <29_31>+10 <29_31>+11 <29_31>+12 <29_31>+13 <29_31>+14 <29_31>+15 <29_31>+16 <29_31>+17 <29_31>+18 <29_31>+19 <29_31>+20 <29_31>+21 <29_31>+22 <29_31>+23 <29_31>+24 <29_31>+25 <29_31>+26 <29_31>+27 <29_31>+28 <29_31>+29 <29_31>+30 <29_31>+31 <29_31>+32 <29_31>+33 <29_31>+34 <29_31>+35 <29_31>+36 <29_31>+37 <29_31>+38 <29_31>+39 <29_31>+40 <29_31>+41 <29_31>+42 <29_31>+43 <29_31>+44 <29_31>+45 <29_31>+46 <29_31>+47 <29_31>+48 <29_31>+49 <29_31>+50 <29_31>+51 <29_31>+52 <29_31>+53 <29_31>+54 <29_31>+55 <29_31>+56 <29_31>+57 <29_31>+58 <29_31>+59 <29_31>+60 <29_31>+61 <29_31>+62 <29_31>+63 <29_31>+64 <29_31>+65 <29_31>+66 <29_31>+67 <29_31>+68 <29_31>+69 <29_31>+70 <29_31>+71 <29_31>+72 <29_31>+73 <29_31>+74 <29_31>+75 <29_31>+76 <29_31>+77 <29_31>+78 <29_31>+79 <29_31>+80 <29_31>+81 <29_31>+82 <29_31>+83 <30_31>+84 <29_31>+85 <29_31>+86 <29_31>+87 <29_31>+88 <29_31>+89 <29_31>+90 <29_31>+91 <29_31>+92 <29_31>+93 <29_31>+94 <29_31>+95 <29_31>+96 <29_31>+97 <29_31>+98 <29_31>+99 <29_31>+100 <29_31>+101 <29_31>+102 <29_31>+103 <29_31>+104 <29_31>+105 <29_31>+106 <29_31>+107 <29_31>+108 <29_31>+109 <29_31>+110 <29_31>+111 <29_31>+112 <29_31>+113 <29_31>+114 <29_31>+115 <29_31>+116 <29_31>+117 <29_31>+118 <29_31>+119 <29_31>+120 <29_31>+121 <29_31>+122 <29_31>+123 <29_31>+124 <29_31>+125 <29_31>+126 <29_31>+127 <30_31>+128 <29_31>+129 <29_31>+130 <29_31>+131 <29_31>+132 <30_31>+128 <30_31>+128 <29_31>+135 <29_31>+136 <29_31>+137 <29_31>+138 <29_31>+139 <29_31>+140 <29_31>+141 <29_31>+142 <29_31>+143 <29_31>+144 <29_31>+145 <29_31>+146 <29_31>+147 <29_31>+148 <29_31>+149 <30_31>+128 <30_31>+128 <29_31>+152 <29_31>+153 <29_31>+154 <29_31>+155 <29_31>+156 <29_31>+157 <29_31>+158 <29_31>+159 <29_31>+160 <29_31>+161 <29_31>+162 <29_31>+163 <29_31>+164 <29_31>+165 <29_31>+166 block 634 SYMPRP: intern SYMPRP <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 <30_31>+128 block 634 SYMNAM: intern SYMNAM extern L0055 <4_31>+L0055 extern L0056 <4_31>+L0056 extern L0057 <4_31>+L0057 extern L0058 <4_31>+L0058 extern L0059 <4_31>+L0059 extern L0060 <4_31>+L0060 extern L0061 <4_31>+L0061 extern L0062 <4_31>+L0062 extern L0063 <4_31>+L0063 extern L0064 <4_31>+L0064 extern L0065 <4_31>+L0065 extern L0066 <4_31>+L0066 extern L0067 <4_31>+L0067 extern L0068 <4_31>+L0068 extern L0069 <4_31>+L0069 extern L0070 <4_31>+L0070 extern L0071 <4_31>+L0071 extern L0072 <4_31>+L0072 extern L0073 <4_31>+L0073 extern L0074 <4_31>+L0074 extern L0075 <4_31>+L0075 extern L0076 <4_31>+L0076 extern L0077 <4_31>+L0077 extern L0078 <4_31>+L0078 extern L0079 <4_31>+L0079 extern L0080 <4_31>+L0080 extern L0081 <4_31>+L0081 extern L0082 <4_31>+L0082 extern L0083 <4_31>+L0083 extern L0084 <4_31>+L0084 extern L0085 <4_31>+L0085 extern L0086 <4_31>+L0086 extern L0087 <4_31>+L0087 extern L0088 <4_31>+L0088 extern L0089 <4_31>+L0089 extern L0090 <4_31>+L0090 extern L0091 <4_31>+L0091 extern L0092 <4_31>+L0092 extern L0093 <4_31>+L0093 extern L0094 <4_31>+L0094 extern L0095 <4_31>+L0095 extern L0096 <4_31>+L0096 extern L0097 <4_31>+L0097 extern L0098 <4_31>+L0098 extern L0099 <4_31>+L0099 extern L0100 <4_31>+L0100 extern L0101 <4_31>+L0101 extern L0102 <4_31>+L0102 extern L0103 <4_31>+L0103 extern L0104 <4_31>+L0104 extern L0105 <4_31>+L0105 extern L0106 <4_31>+L0106 extern L0107 <4_31>+L0107 extern L0108 <4_31>+L0108 extern L0109 <4_31>+L0109 extern L0110 <4_31>+L0110 extern L0111 <4_31>+L0111 extern L0112 <4_31>+L0112 extern L0113 <4_31>+L0113 extern L0114 <4_31>+L0114 extern L0115 <4_31>+L0115 extern L0116 <4_31>+L0116 extern L0117 <4_31>+L0117 extern L0118 <4_31>+L0118 extern L0119 <4_31>+L0119 extern L0120 <4_31>+L0120 extern L0121 <4_31>+L0121 extern L0122 <4_31>+L0122 extern L0123 <4_31>+L0123 extern L0124 <4_31>+L0124 extern L0125 <4_31>+L0125 extern L0126 <4_31>+L0126 extern L0127 <4_31>+L0127 extern L0128 <4_31>+L0128 extern L0129 <4_31>+L0129 extern L0130 <4_31>+L0130 extern L0131 <4_31>+L0131 extern L0132 <4_31>+L0132 extern L0133 <4_31>+L0133 extern L0134 <4_31>+L0134 extern L0135 <4_31>+L0135 extern L0136 <4_31>+L0136 extern L0137 <4_31>+L0137 extern L0138 <4_31>+L0138 extern L0139 <4_31>+L0139 extern L0140 <4_31>+L0140 extern L0141 <4_31>+L0141 extern L0142 <4_31>+L0142 extern L0143 <4_31>+L0143 extern L0144 <4_31>+L0144 extern L0145 <4_31>+L0145 extern L0146 <4_31>+L0146 extern L0147 <4_31>+L0147 extern L0148 <4_31>+L0148 extern L0149 <4_31>+L0149 extern L0150 <4_31>+L0150 extern L0151 <4_31>+L0151 extern L0152 <4_31>+L0152 extern L0153 <4_31>+L0153 extern L0154 <4_31>+L0154 extern L0155 <4_31>+L0155 extern L0156 <4_31>+L0156 extern L0157 <4_31>+L0157 extern L0158 <4_31>+L0158 extern L0159 <4_31>+L0159 extern L0160 <4_31>+L0160 extern L0161 <4_31>+L0161 extern L0162 <4_31>+L0162 extern L0163 <4_31>+L0163 extern L0164 <4_31>+L0164 extern L0165 <4_31>+L0165 extern L0166 <4_31>+L0166 extern L0167 <4_31>+L0167 extern L0168 <4_31>+L0168 extern L0169 <4_31>+L0169 extern L0170 <4_31>+L0170 extern L0171 <4_31>+L0171 extern L0172 <4_31>+L0172 extern L0173 <4_31>+L0173 extern L0174 <4_31>+L0174 extern L0175 <4_31>+L0175 extern L0176 <4_31>+L0176 extern L0177 <4_31>+L0177 extern L0178 <4_31>+L0178 extern L0179 <4_31>+L0179 extern L0180 <4_31>+L0180 extern L0181 <4_31>+L0181 extern L0182 <4_31>+L0182 extern L0183 <4_31>+L0183 extern L0184 <4_31>+L0184 extern L0185 <4_31>+L0185 extern L0186 <4_31>+L0186 extern L0187 <4_31>+L0187 extern L0188 <4_31>+L0188 extern L0189 <4_31>+L0189 extern L0190 <4_31>+L0190 extern L0191 <4_31>+L0191 extern L0192 <4_31>+L0192 extern L0193 <4_31>+L0193 extern L0194 <4_31>+L0194 extern L0195 <4_31>+L0195 extern L0196 <4_31>+L0196 extern L0197 <4_31>+L0197 extern L0198 <4_31>+L0198 extern L0199 <4_31>+L0199 extern L0200 <4_31>+L0200 extern L0201 <4_31>+L0201 extern L0202 <4_31>+L0202 extern L0203 <4_31>+L0203 extern L0204 <4_31>+L0204 extern L0205 <4_31>+L0205 extern L0206 <4_31>+L0206 extern L0207 <4_31>+L0207 extern L0208 <4_31>+L0208 extern L0209 <4_31>+L0209 extern L0210 <4_31>+L0210 extern L0211 <4_31>+L0211 extern L0212 <4_31>+L0212 extern L0213 <4_31>+L0213 extern L0214 <4_31>+L0214 extern L0215 <4_31>+L0215 extern L0216 <4_31>+L0216 extern L0217 <4_31>+L0217 extern L0218 <4_31>+L0218 extern L0219 <4_31>+L0219 extern L0220 <4_31>+L0220 extern L0221 <4_31>+L0221 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 0 SYMFNC: intern SYMFNC JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 extern L0017 jrst L0017## extern L0035 jrst L0035## extern MAIN. jrst MAIN.## extern INIT jrst INIT## JRST SYMFNC+149 JRST SYMFNC+149 JRST SYMFNC+149 extern GETC jrst GETC## extern TIMC jrst TIMC## JRST SYMFNC+149 extern PUTC jrst PUTC## extern QUIT jrst QUIT## extern L0021 jrst L0021## JRST SYMFNC+149 extern RESET jrst RESET## extern DATE jrst DATE## extern L0028 jrst L0028## extern PUTINT jrst PUTINT## extern L0029 jrst L0029## extern L0030 jrst L0030## extern L0031 jrst L0031## JRST SYMFNC+149 JRST SYMFNC+149 extern L0053 jrst L0053## extern L0032 jrst L0032## JRST SYMFNC+149 extern L0033 jrst L0033## JRST SYMFNC+149 extern L0034 jrst L0034## extern IFACT jrst IFACT## extern TERPRI jrst TERPRI## extern L0036 jrst L0036## extern L0042 jrst L0042## extern L0038 jrst L0038## extern FACT jrst FACT## extern L0049 jrst L0049## extern TAK jrst TAK## extern L0054 jrst L0054## block 634 L0003: intern L0003 167 end |
Added psl-1983/3-1/tests/20/dmain1.rel version [997b574b6d].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain2.rel version [177d8400c1].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain3.rel version [08d3cc5412].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain4.rel version [f596247179].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain5.rel version [c3580a29ed].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain6.rel version [05d3dc7e40].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain7.rel version [f2d10877fa].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dmain9.rel version [f5cc0d9155].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub2.rel version [89daf39997].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub3.rel version [27a6da78ab].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub4.rel version [16964e97fd].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub5a.rel version [d9a6416f5e].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub5b.rel version [89daf39997].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub6.rel version [3d4f1d3ae2].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub7.rel version [22940fcc21].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub8.rel version [313107f535].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/dsub9.rel version [e2f6e345af].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/fiddle.bar version [d6e32eac4d].
> | 1 | THIS IS A STRING OF N |
Added psl-1983/3-1/tests/20/field.init version [d53707583f].
> | 1 | (FLAG '(INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20) 'INTERNALFUNCTION) |
Added psl-1983/3-1/tests/20/fresh.init version [a7ffc6f8bf].
Added psl-1983/3-1/tests/20/fresh.mic version [abb22e0bce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independant compilation of a PSL program ; ; DO FRESH modulename ; ; Initialize for new sequence of builds ; @delete 'a.SYM @copy pc:bare-psl.sym 'A.sym @define DSK:, DSK:, PT:, P20:, PI: ;avoid obnoixous ^Q halts... @terminal length 0 @get s:test-DEC20-cross.exe @st off break; %kill obnoxious break loops off USERMODE ; InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''NIL; ModName!*:='''A; ASMOUT "FRESH"$ ASMEnd$ quit$ @reset . @terminal length 24 @delete Fresh.mac @delete DFresh.mac |
Added psl-1983/3-1/tests/20/init7 version [284359ef8c].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (de mkquote(x) (list 'quote x)) (de flag(x y) NIL) (prin2t "sub2.init")(lapin "sub2.init") (prin2t "sub3.init")(lapin "sub3.init") (prin2t "sub4.init")(lapin "sub4.init") (prin2t "sub5a.init")(lapin "sub5a.init") (prin2t "sub5b.init")(lapin "sub5b.init") (prin2t "sub6.init")(lapin "sub6.init") (prin2t "sub7.init")(lapin "sub7.init") (prin2t "main7.init")(lapin "main7.init") |
Added psl-1983/3-1/tests/20/init8 version [e156af1c7e].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | (setq !*pval nil) (de mkquote(x) (list 'quote x)) (de flag(x y) NIL) (prin2t "sub2.init")(lapin "sub2.init") (prin2t "sub3.init")(lapin "sub3.init") (prin2t "sub4.init")(lapin "sub4.init") (prin2t "sub5a.init")(lapin "sub5a.init") (prin2t "sub5b.init")(lapin "sub5b.init") (prin2t "sub6.init")(lapin "sub6.init") (prin2t "sub7.init")(lapin "sub7.init") (prin2t "sub8.init")(lapin "sub8.init") (prin2t "main8.init")(lapin "main8.init") (setq !*pval T) |
Added psl-1983/3-1/tests/20/init9 version [a17699b460].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (prin2t "sub2.init")(lapin "sub2.init") (prin2t "sub3.init")(lapin "sub3.init") (prin2t "sub4.init")(lapin "sub4.init") (prin2t "sub5a.init")(lapin "sub5a.init") (prin2t "sub5b.init")(lapin "sub5b.init") (prin2t "sub6.init")(lapin "sub6.init") (prin2t "sub7.init")(lapin "sub7.init") (prin2t "sub8.init")(lapin "sub8.init") (prin2t "sub9.init")(lapin "sub9.init") (prin2t "main9.init")(lapin "main9.init") |
Added psl-1983/3-1/tests/20/junk.it version [3ba39ac3ed].
> > > | 1 2 3 | This is the Test.It file. It has 3 lines (this is Line 2) This is the last line. |
Added psl-1983/3-1/tests/20/junk.junk version [e713e948aa].
> > > | 1 2 3 | Line 1 Line 2 Line 3 (last) |
Added psl-1983/3-1/tests/20/main0.cmd version [9d9dfdd287].
> > | 1 2 | main0,Dmain0,20io |
Added psl-1983/3-1/tests/20/main0.init version [d86574d3c4].
> > > > | 1 2 3 4 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/3-1/tests/20/main0.mac version [9925d53285].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern HEAP extern L0006 extern L0007 extern L0008 extern L0009 extern L0010 extern L0011 extern L0012 extern BPS extern L0013 extern L0014 extern L0015 extern L0016 ; (!*ENTRY INITHEAP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR HEAPLOWERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPLOWERBOUND)) ; (MOVEM (REG T1) (WVAR HEAPLAST)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (MOVEM (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INITHEAP EXPR 0) L0017: intern L0017 MOVE 6,L0006 MOVEM 6,L0008 SETZM 1 MOVEM 1,L0010 POPJ 15,0 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 extern L0005 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 130) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L0018 MOVE 0,SYMVAL+128 HRRZI 12,130 SETZM 13 JRST SYMFNC+130 L0018: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+133 HRRZI 6,1 MOVEM 6,SYMVAL+134 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 135) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+133 JRST L0019 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L0019: MOVE 1,SYMVAL+133 HRRZI 12,135 HRRZI 13,1 JRST SYMFNC+135 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+134 CAIE 7,1 JRST L0020 PUSHJ 15,PUTC20 POPJ 15,0 L0020: MOVE 2,1 MOVE 1,SYMVAL+134 HRRZI 12,138 HRRZI 13,2 JRST SYMFNC+138 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY EXITLISP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY EXITLISP EXPR 0) L0021: intern L0021 SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY RESET EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Should RESET here, but will QUIT") (REG 1)) ; (MOVE (REG 1) (QUOTE "Should RESET here, but will QUIT")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 140) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0023: 31 byte(7)83,104,111,117,108,100,32,82,69,83,69,84,32,104,101,114,101,44,32,98,117,116,32,119,105,108,108,32,81,85,73,84,0 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 1,L0022 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZI 12,140 SETZM 13 PUSHJ 15,SYMFNC+140 MOVE 1,0 POPJ 15,0 L0022: <4_31>+L0023 ; (!*ENTRY DATE EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "No-Date-Yet") (REG 1)) ; (MOVE (REG 1) (QUOTE "No-Date-Yet")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0025: 10 byte(7)78,111,45,68,97,116,101,45,89,101,116,0 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE MOVE 1,L0024 POPJ 15,0 L0024: <4_31>+L0025 ; (!*ENTRY VERSIONNAME EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "DEC-20 test system") (REG 1)) ; (MOVE (REG 1) (QUOTE "DEC-20 test system")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0027: 17 byte(7)68,69,67,45,50,48,32,116,101,115,116,32,115,121,115,116,101,109,0 0 ; (!*ENTRY VERSIONNAME EXPR 0) L0028: intern L0028 MOVE 1,L0026 POPJ 15,0 L0026: <4_31>+L0027 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*ALLOC 0) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L0029: intern L0029 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L0030: intern L0030 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L0031: intern L0031 MOVEM 12,SYMVAL+150 MOVEM 13,SYMVAL+151 JRST SYMFNC+152 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L0032: intern L0032 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 154) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L0033: intern L0033 HRRZI 12,154 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 156) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L0034: intern L0034 HRRZI 12,156 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 0) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 132) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*MOVE (QUOTE 65) (REG 1)) ; (HRRZI (REG 1) 65) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 66) (REG 1)) ; (HRRZI (REG 1) 66) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 158) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 158) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE 2) (REG 1)) ; (HRRZI (REG 1) 2) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 158) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 158) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 158) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 140) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY FIRSTCALL EXPR 0) L0035: intern L0035 HRRZI 12,132 SETZM 13 PUSHJ 15,SYMFNC+132 HRRZI 1,65 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,66 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 12,158 SETZM 13 PUSHJ 15,SYMFNC+158 HRRZI 1,1 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,158 SETZM 13 PUSHJ 15,SYMFNC+158 HRRZI 1,2 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,158 SETZM 13 PUSHJ 15,SYMFNC+158 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,158 SETZM 13 PUSHJ 15,SYMFNC+158 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,158 SETZM 13 PUSHJ 15,SYMFNC+158 HRRZI 12,140 SETZM 13 PUSHJ 15,SYMFNC+140 MOVE 1,0 POPJ 15,0 ; (!*ENTRY TERPRI EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 0 ; (!*ENTRY TERPRI EXPR 0) TERPRI: intern TERPRI HRRZI 1,10 HRRZI 12,139 HRRZI 13,1 JRST SYMFNC+139 0 ; (!*ENTRY INITCODE EXPR 0) L0036: intern L0036 MOVE 1,0 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L0037: 0 byte(7)0,0 intern L0037 L0038: 0 byte(7)1,0 intern L0038 L0039: 0 byte(7)2,0 intern L0039 L0040: 0 byte(7)3,0 intern L0040 L0041: 0 byte(7)4,0 intern L0041 L0042: 0 byte(7)5,0 intern L0042 L0043: 0 byte(7)6,0 intern L0043 L0044: 0 byte(7)7,0 intern L0044 L0045: 0 byte(7)8,0 intern L0045 L0046: 0 byte(7)9,0 intern L0046 L0047: 0 byte(7)10,0 intern L0047 L0048: 0 byte(7)11,0 intern L0048 L0049: 0 byte(7)12,0 intern L0049 L0050: 0 byte(7)13,0 intern L0050 L0051: 0 byte(7)14,0 intern L0051 L0052: 0 byte(7)15,0 intern L0052 L0053: 0 byte(7)16,0 intern L0053 L0054: 0 byte(7)17,0 intern L0054 L0055: 0 byte(7)18,0 intern L0055 L0056: 0 byte(7)19,0 intern L0056 L0057: 0 byte(7)20,0 intern L0057 L0058: 0 byte(7)21,0 intern L0058 L0059: 0 byte(7)22,0 intern L0059 L0060: 0 byte(7)23,0 intern L0060 L0061: 0 byte(7)24,0 intern L0061 L0062: 0 byte(7)25,0 intern L0062 L0063: 0 byte(7)26,0 intern L0063 L0064: 0 byte(7)27,0 intern L0064 L0065: 0 byte(7)28,0 intern L0065 L0066: 0 byte(7)29,0 intern L0066 L0067: 0 byte(7)30,0 intern L0067 L0068: 0 byte(7)31,0 intern L0068 L0069: 0 byte(7)32,0 intern L0069 L0070: 0 byte(7)33,0 intern L0070 L0071: 0 byte(7)34,0 intern L0071 L0072: 0 byte(7)35,0 intern L0072 L0073: 0 byte(7)36,0 intern L0073 L0074: 0 byte(7)37,0 intern L0074 L0075: 0 byte(7)38,0 intern L0075 L0076: 0 byte(7)39,0 intern L0076 L0077: 0 byte(7)40,0 intern L0077 L0078: 0 byte(7)41,0 intern L0078 L0079: 0 byte(7)42,0 intern L0079 L0080: 0 byte(7)43,0 intern L0080 L0081: 0 byte(7)44,0 intern L0081 L0082: 0 byte(7)45,0 intern L0082 L0083: 0 byte(7)46,0 intern L0083 L0084: 0 byte(7)47,0 intern L0084 L0085: 0 byte(7)48,0 intern L0085 L0086: 0 byte(7)49,0 intern L0086 L0087: 0 byte(7)50,0 intern L0087 L0088: 0 byte(7)51,0 intern L0088 L0089: 0 byte(7)52,0 intern L0089 L0090: 0 byte(7)53,0 intern L0090 L0091: 0 byte(7)54,0 intern L0091 L0092: 0 byte(7)55,0 intern L0092 L0093: 0 byte(7)56,0 intern L0093 L0094: 0 byte(7)57,0 intern L0094 L0095: 0 byte(7)58,0 intern L0095 L0096: 0 byte(7)59,0 intern L0096 L0097: 0 byte(7)60,0 intern L0097 L0098: 0 byte(7)61,0 intern L0098 L0099: 0 byte(7)62,0 intern L0099 L0100: 0 byte(7)63,0 intern L0100 L0101: 0 byte(7)64,0 intern L0101 L0102: 0 byte(7)65,0 intern L0102 L0103: 0 byte(7)66,0 intern L0103 L0104: 0 byte(7)67,0 intern L0104 L0105: 0 byte(7)68,0 intern L0105 L0106: 0 byte(7)69,0 intern L0106 L0107: 0 byte(7)70,0 intern L0107 L0108: 0 byte(7)71,0 intern L0108 L0109: 0 byte(7)72,0 intern L0109 L0110: 0 byte(7)73,0 intern L0110 L0111: 0 byte(7)74,0 intern L0111 L0112: 0 byte(7)75,0 intern L0112 L0113: 0 byte(7)76,0 intern L0113 L0114: 0 byte(7)77,0 intern L0114 L0115: 0 byte(7)78,0 intern L0115 L0116: 0 byte(7)79,0 intern L0116 L0117: 0 byte(7)80,0 intern L0117 L0118: 0 byte(7)81,0 intern L0118 L0119: 0 byte(7)82,0 intern L0119 L0120: 0 byte(7)83,0 intern L0120 L0121: 0 byte(7)84,0 intern L0121 L0122: 0 byte(7)85,0 intern L0122 L0123: 0 byte(7)86,0 intern L0123 L0124: 0 byte(7)87,0 intern L0124 L0125: 0 byte(7)88,0 intern L0125 L0126: 0 byte(7)89,0 intern L0126 L0127: 0 byte(7)90,0 intern L0127 L0128: 0 byte(7)91,0 intern L0128 L0129: 0 byte(7)92,0 intern L0129 L0130: 0 byte(7)93,0 intern L0130 L0131: 0 byte(7)94,0 intern L0131 L0132: 0 byte(7)95,0 intern L0132 L0133: 0 byte(7)96,0 intern L0133 L0134: 0 byte(7)97,0 intern L0134 L0135: 0 byte(7)98,0 intern L0135 L0136: 0 byte(7)99,0 intern L0136 L0137: 0 byte(7)100,0 intern L0137 L0138: 0 byte(7)101,0 intern L0138 L0139: 0 byte(7)102,0 intern L0139 L0140: 0 byte(7)103,0 intern L0140 L0141: 0 byte(7)104,0 intern L0141 L0142: 0 byte(7)105,0 intern L0142 L0143: 0 byte(7)106,0 intern L0143 L0144: 0 byte(7)107,0 intern L0144 L0145: 0 byte(7)108,0 intern L0145 L0146: 0 byte(7)109,0 intern L0146 L0147: 0 byte(7)110,0 intern L0147 L0148: 0 byte(7)111,0 intern L0148 L0149: 0 byte(7)112,0 intern L0149 L0150: 0 byte(7)113,0 intern L0150 L0151: 0 byte(7)114,0 intern L0151 L0152: 0 byte(7)115,0 intern L0152 L0153: 0 byte(7)116,0 intern L0153 L0154: 0 byte(7)117,0 intern L0154 L0155: 0 byte(7)118,0 intern L0155 L0156: 0 byte(7)119,0 intern L0156 L0157: 0 byte(7)120,0 intern L0157 L0158: 0 byte(7)121,0 intern L0158 L0159: 0 byte(7)122,0 intern L0159 L0160: 0 byte(7)123,0 intern L0160 L0161: 0 byte(7)124,0 intern L0161 L0162: 0 byte(7)125,0 intern L0162 L0163: 0 byte(7)126,0 intern L0163 L0164: 0 byte(7)127,0 intern L0164 L0165: 2 byte(7)78,73,76,0 intern L0165 L0166: 7 byte(7)73,78,73,84,72,69,65,80,0 intern L0166 L0167: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L0167 L0168: 4 byte(7)77,65,73,78,46,0 intern L0168 L0169: 3 byte(7)73,78,73,84,0 intern L0169 L0170: 2 byte(7)73,78,42,0 intern L0170 L0171: 3 byte(7)79,85,84,42,0 intern L0171 L0172: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L0172 L0173: 3 byte(7)71,69,84,67,0 intern L0173 L0174: 3 byte(7)84,73,77,67,0 intern L0174 L0175: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L0175 L0176: 3 byte(7)80,85,84,67,0 intern L0176 L0177: 3 byte(7)81,85,73,84,0 intern L0177 L0178: 7 byte(7)69,88,73,84,76,73,83,80,0 intern L0178 L0179: 5 byte(7)80,82,73,78,50,84,0 intern L0179 L0180: 4 byte(7)82,69,83,69,84,0 intern L0180 L0181: 3 byte(7)68,65,84,69,0 intern L0181 L0182: 10 byte(7)86,69,82,83,73,79,78,78,65,77,69,0 intern L0182 L0183: 5 byte(7)80,85,84,73,78,84,0 intern L0183 L0184: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L0184 L0185: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L0185 L0186: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L0186 L0187: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L0187 L0188: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L0188 L0189: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L0189 L0190: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L0190 L0191: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L0191 L0192: 6 byte(7)76,79,78,71,68,73,86,0 intern L0192 L0193: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L0193 L0194: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L0194 L0195: 5 byte(7)84,69,82,80,82,73,0 intern L0195 L0196: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L0196 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/3-1/tests/20/main0.red version [75a4e052d7].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Simple 1 file test % This is program MAIN1.RED On SYSLISP; IN "XXX-HEADER.RED"$ Procedure FirstCall; <<Init(); PutC Char A; PutC Char B; Terpri(); PutInt 1; Terpri(); PutInt 2; Terpri(); Putint Timc(); Terpri(); Putint Timc(); Terpri(); Quit;>>; procedure terpri(); PutC Char EOL; end; |
Added psl-1983/3-1/tests/20/main0.rel version [fb29f1819e].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main0.sym version [33ae87d2e6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE NIL)) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 129)) (SETQ STRINGGENSYM!* (QUOTE "L0005")) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) |
Added psl-1983/3-1/tests/20/main1.cmd version [f2564ec47d].
> > | 1 2 | main1,Dmain1,20io |
Added psl-1983/3-1/tests/20/main1.init version [d86574d3c4].
> > > > | 1 2 3 4 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/3-1/tests/20/main1.mac version [d1fd6afb2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | search monsym radix 10 extern STACK extern L0001 extern L0002 extern HEAP extern L0006 extern L0007 extern L0008 extern L0009 extern L0010 extern L0011 extern L0012 extern BPS extern L0013 extern L0014 extern L0015 extern L0016 ; (!*ENTRY INITHEAP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WVAR HEAPLOWERBOUND) (WVAR HEAPLAST)) ; (MOVE (REG T1) (WVAR HEAPLOWERBOUND)) ; (MOVEM (REG T1) (WVAR HEAPLAST)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*MOVE (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (MOVEM (REG 1) (WVAR HEAPPREVIOUSLAST)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INITHEAP EXPR 0) L0017: intern L0017 MOVE 6,L0006 MOVEM 6,L0008 SETZM 1 MOVEM 1,L0010 POPJ 15,0 extern L0004 extern ARG1 extern ARG2 extern ARG3 extern ARG4 extern ARG5 extern ARG6 extern ARG7 extern ARG8 extern ARG9 extern ARG10 extern ARG11 extern ARG12 extern ARG13 extern ARG14 extern ARG15 extern L0005 ; (!*ENTRY MAIN!. EXPR 0) ; (RESET) ; (MOVE (REG ST) (LIT (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)))) ; (MOVE (REG NIL) (FLUID NIL)) ; (!*LINKE 0 FIRSTCALL EXPR 0) ; (HRRZI (REG LINKREG) 130) ; (SETZM (REG NARGREG)) ; (JRST (ENTRY FIRSTCALL)) ; (HALFWORD (MINUS (WCONST STACKSIZE)) (DIFFERENCE (WCONST STACK) 1)) 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.: RESET MOVE 15,L0018 MOVE 0,SYMVAL+128 HRRZI 12,130 SETZM 13 JRST SYMFNC+130 L0018: byte(18)-5000,STACK-1 ; (!*ENTRY INIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINK INIT20 EXPR 1) extern INIT20 ; (PUSHJ (REG ST) (INTERNALENTRY INIT20)) ; (!*MOVE (WCONST 0) (!$FLUID IN!*)) ; (SETZM (!$FLUID IN!*)) ; (!*MOVE (WCONST 1) (!$FLUID OUT!*)) ; (HRRZI (REG T1) 1) ; (MOVEM (REG T1) (!$FLUID OUT!*)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY INIT EXPR 0) INIT: intern INIT SETZM 1 PUSHJ 15,INIT20 SETZM SYMVAL+133 HRRZI 6,1 MOVEM 6,SYMVAL+134 MOVE 1,0 POPJ 15,0 ; (!*ENTRY GETC EXPR 0) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 0) (!$FLUID IN!*)) ; (SKIPE (!$FLUID IN!*)) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 GETC20 EXPR 1) extern GETC20 ; (PUSHJ (REG ST) (INTERNALENTRY GETC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (!$FLUID IN!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID IN!*)) ; (!*LINKE 0 INDEPENDENTREADCHAR EXPR 1) ; (HRRZI (REG LINKREG) 135) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY INDEPENDENTREADCHAR)) 0 ; (!*ENTRY GETC EXPR 0) GETC: intern GETC SKIPE SYMVAL+133 JRST L0019 SETZM 1 PUSHJ 15,GETC20 POPJ 15,0 L0019: MOVE 1,SYMVAL+133 HRRZI 12,135 HRRZI 13,1 JRST SYMFNC+135 ; (!*ENTRY TIMC EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 TIMC20 EXPR 1) extern TIMC20 ; (PUSHJ (REG ST) (INTERNALENTRY TIMC20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TIMC EXPR 0) TIMC: intern TIMC SETZM 1 PUSHJ 15,TIMC20 POPJ 15,0 ; (!*ENTRY PUTC EXPR 1) ; (!*ALLOC 0) ; (!*JUMPNOTEQ (LABEL G0004) (WCONST 1) (!$FLUID OUT!*)) ; (MOVE (REG T2) (!$FLUID OUT!*)) ; (CAIE (REG T2) 1) ; (JRST (LABEL G0004)) ; (!*LINKE 0 PUTC20 EXPR 1) extern PUTC20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTC20)) ; (POPJ (REG ST) 0) ; (!*LBL (LABEL G0004)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (!$FLUID OUT!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID OUT!*)) ; (!*LINKE 0 INDEPENDENTWRITECHAR EXPR 2) ; (HRRZI (REG LINKREG) 138) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY INDEPENDENTWRITECHAR)) 1 ; (!*ENTRY PUTC EXPR 1) PUTC: intern PUTC MOVE 7,SYMVAL+134 CAIE 7,1 JRST L0020 PUSHJ 15,PUTC20 POPJ 15,0 L0020: MOVE 2,1 MOVE 1,SYMVAL+134 HRRZI 12,138 HRRZI 13,2 JRST SYMFNC+138 ; (!*ENTRY QUIT EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) extern QUIT20 ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY QUIT EXPR 0) QUIT: intern QUIT SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY EXITLISP EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 0) (REG 1)) ; (SETZM (REG 1)) ; (!*LINKE 0 QUIT20 EXPR 1) ; (PUSHJ (REG ST) (INTERNALENTRY QUIT20)) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY EXITLISP EXPR 0) L0021: intern L0021 SETZM 1 PUSHJ 15,QUIT20 POPJ 15,0 ; (!*ENTRY RESET EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "Should RESET here, but will QUIT") (REG 1)) ; (MOVE (REG 1) (QUOTE "Should RESET here, but will QUIT")) ; (!*LINK PRIN2T EXPR 1) ; (HRRZI (REG LINKREG) 142) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PRIN2T)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 140) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0023: 31 byte(7)83,104,111,117,108,100,32,82,69,83,69,84,32,104,101,114,101,44,32,98,117,116,32,119,105,108,108,32,81,85,73,84,0 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 1,L0022 HRRZI 12,142 HRRZI 13,1 PUSHJ 15,SYMFNC+142 HRRZI 12,140 SETZM 13 PUSHJ 15,SYMFNC+140 MOVE 1,0 POPJ 15,0 L0022: <4_31>+L0023 ; (!*ENTRY DATE EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "No-Date-Yet") (REG 1)) ; (MOVE (REG 1) (QUOTE "No-Date-Yet")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0025: 10 byte(7)78,111,45,68,97,116,101,45,89,101,116,0 0 ; (!*ENTRY DATE EXPR 0) DATE: intern DATE MOVE 1,L0024 POPJ 15,0 L0024: <4_31>+L0025 ; (!*ENTRY VERSIONNAME EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE "DEC-20 test system") (REG 1)) ; (MOVE (REG 1) (QUOTE "DEC-20 test system")) ; (!*EXIT 0) ; (POPJ (REG ST) 0) L0027: 17 byte(7)68,69,67,45,50,48,32,116,101,115,116,32,115,121,115,116,101,109,0 0 ; (!*ENTRY VERSIONNAME EXPR 0) L0028: intern L0028 MOVE 1,L0026 POPJ 15,0 L0026: <4_31>+L0027 ; (!*ENTRY PUTINT EXPR 1) ; (!*ALLOC 0) ; (!*LINKE 0 PUTI20 EXPR 1) extern PUTI20 ; (PUSHJ (REG ST) (INTERNALENTRY PUTI20)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY PUTINT EXPR 1) PUTINT: intern PUTINT PUSHJ 15,PUTI20 POPJ 15,0 ; (!*ENTRY !%STORE!-JCALL EXPR 2) ; (!*ALLOC 0) ; (!*WOR (REG 1) 23085449216) ; (IOR (REG 1) 23085449216) ; (!*MOVE (REG 1) (MEMORY (REG 2) (WCONST 0))) ; (MOVEM (REG 1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%STORE!-JCALL EXPR 2) L0029: intern L0029 IOR 1,[23085449216] MOVEM 1,0(2) POPJ 15,0 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) ; (!*ALLOC 0) ; (!*MOVE (MEMORY (REG 1) (WCONST 0)) (MEMORY (REG 2) (WCONST 0))) ; (MOVE (REG T1) (INDEXED (REG 1) 0)) ; (MOVEM (REG T1) (INDEXED (REG 2) 0)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY !%COPY!-FUNCTION!-CELL EXPR 2) L0030: intern L0030 MOVE 6,0(1) MOVEM 6,0(2) POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) ; (!*MOVE (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (MOVEM (REG LINKREG) (FLUID UNDEFNCODE!*)) ; (!*MOVE (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (MOVEM (REG NARGREG) (FLUID UNDEFNNARG!*)) ; (!*JCALL UNDEFINEDFUNCTIONAUX) ; (JRST (ENTRY UNDEFINEDFUNCTIONAUX)) 0 ; (!*ENTRY UNDEFINEDFUNCTION EXPR 0) L0031: intern L0031 MOVEM 12,SYMVAL+150 MOVEM 13,SYMVAL+151 JRST SYMFNC+152 ; (!*ENTRY LONGTIMES EXPR 2) ; (!*ALLOC 0) ; (!*WTIMES2 (REG 1) (REG 2)) ; (IMUL (REG 1) (REG 2)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGTIMES EXPR 2) L0032: intern L0032 IMUL 1,2 POPJ 15,0 ; (!*ENTRY LONGDIV EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WQUOTIENT EXPR 2) ; (HRRZI (REG LINKREG) 154) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGDIV EXPR 2) L0033: intern L0033 HRRZI 12,154 HRRZI 13,2 IDIV 1,2 POPJ 15,0 ; (!*ENTRY LONGREMAINDER EXPR 2) ; (!*ALLOC 0) ; (!*LINKE 0 WREMAINDER EXPR 2) ; (HRRZI (REG LINKREG) 156) ; (HRRZI (REG NARGREG) 2) ; (IDIV (REG 1) (REG 2)) ; (MOVE (REG 1) (REG 2)) ; (POPJ (REG ST) 0) 2 ; (!*ENTRY LONGREMAINDER EXPR 2) L0034: intern L0034 HRRZI 12,156 HRRZI 13,2 IDIV 1,2 MOVE 1,2 POPJ 15,0 ; (!*ENTRY FIRSTCALL EXPR 0) ; (!*ALLOC 0) ; (!*LINK INIT EXPR 0) ; (HRRZI (REG LINKREG) 132) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY INIT)) ; (!*MOVE (WCONST 70) (REG 1)) ; (HRRZI (REG 1) 70) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 97) (REG 1)) ; (HRRZI (REG 1) 97) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 99) (REG 1)) ; (HRRZI (REG 1) 99) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 61) (REG 1)) ; (HRRZI (REG 1) 61) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINK IFACT EXPR 1) ; (HRRZI (REG LINKREG) 158) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY IFACT)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 101) (REG 1)) ; (HRRZI (REG 1) 101) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 115) (REG 1)) ; (HRRZI (REG 1) 115) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 116) (REG 1)) ; (HRRZI (REG 1) 116) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 70) (REG 1)) ; (HRRZI (REG 1) 70) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 97) (REG 1)) ; (HRRZI (REG 1) 97) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 99) (REG 1)) ; (HRRZI (REG 1) 99) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 116) (REG 1)) ; (HRRZI (REG 1) 116) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TESTFACT EXPR 0) ; (HRRZI (REG LINKREG) 160) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TESTFACT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 101) (REG 1)) ; (HRRZI (REG 1) 101) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 115) (REG 1)) ; (HRRZI (REG 1) 115) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 116) (REG 1)) ; (HRRZI (REG 1) 116) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 84) (REG 1)) ; (HRRZI (REG 1) 84) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 97) (REG 1)) ; (HRRZI (REG 1) 97) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (WCONST 107) (REG 1)) ; (HRRZI (REG 1) 107) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TESTTAK EXPR 0) ; (HRRZI (REG LINKREG) 161) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TESTTAK)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 140) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY FIRSTCALL EXPR 0) L0035: intern L0035 HRRZI 12,132 SETZM 13 PUSHJ 15,SYMFNC+132 HRRZI 1,70 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,97 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,99 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,61 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,10 HRRZI 12,158 HRRZI 13,1 PUSHJ 15,SYMFNC+158 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 1,84 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,101 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,115 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,116 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,70 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,97 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,99 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,116 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 12,160 SETZM 13 PUSHJ 15,SYMFNC+160 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 1,84 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,101 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,115 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,116 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,84 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,97 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,107 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 12,161 SETZM 13 PUSHJ 15,SYMFNC+161 HRRZI 12,140 SETZM 13 PUSHJ 15,SYMFNC+140 MOVE 1,0 POPJ 15,0 ; (!*ENTRY TERPRI EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (WCONST 10) (REG 1)) ; (HRRZI (REG 1) 10) ; (!*LINKE 0 PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (JRST (ENTRY PUTC)) 0 ; (!*ENTRY TERPRI EXPR 0) TERPRI: intern TERPRI HRRZI 1,10 HRRZI 12,139 HRRZI 13,1 JRST SYMFNC+139 ; (!*ENTRY TESTFACT EXPR 0) ; (!*ALLOC 0) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 10000) (REG 1)) ; (HRRZI (REG 1) 10000) ; (!*LINK ARITHMETICTEST EXPR 1) ; (HRRZI (REG LINKREG) 162) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY ARITHMETICTEST)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TESTFACT EXPR 0) L0036: intern L0036 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 1,10000 HRRZI 12,162 HRRZI 13,1 PUSHJ 15,SYMFNC+162 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 MOVE 1,0 POPJ 15,0 ; (!*ENTRY ARITHMETICTEST EXPR 1) ; (!*PUSH (WCONST 0)) ; (PUSH (REG ST) (LIT (FULLWORD 0))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPWLEQ (LABEL G0005) (FRAME 2) (FRAME 1)) ; (MOVE (REG T1) (INDEXED (REG ST) -1)) ; (CAMG (REG T1) (INDEXED (REG ST) 0)) ; (JRST (LABEL G0005)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (WCONST 9) (REG 1)) ; (HRRZI (REG 1) 9) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 163) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY FACT)) ; (!*WPLUS2 (FRAME 2) (WCONST 1)) ; (AOS (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 0) 1 ; (!*ENTRY ARITHMETICTEST EXPR 1) L0038: intern L0038 PUSH 15,L0037 PUSH 15,1 L0039: MOVE 6,-1(15) CAMG 6,0(15) JRST L0040 MOVE 1,0 JRST L0041 L0040: HRRZI 1,9 HRRZI 12,163 HRRZI 13,1 PUSHJ 15,SYMFNC+163 AOS -1(15) JRST L0039 L0041: ADJSP 15,-2 POPJ 15,0 L0037: 0 ; (!*ENTRY TESTTAK EXPR 0) ; (!*ALLOC 0) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (WCONST 6) (REG 3)) ; (HRRZI (REG 3) 6) ; (!*MOVE (WCONST 12) (REG 2)) ; (HRRZI (REG 2) 12) ; (!*MOVE (WCONST 18) (REG 1)) ; (HRRZI (REG 1) 18) ; (!*LINK TOPLEVELTAK EXPR 3) ; (HRRZI (REG LINKREG) 164) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (ENTRY TOPLEVELTAK)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK TIMC EXPR 0) ; (HRRZI (REG LINKREG) 137) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TIMC)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY TESTTAK EXPR 0) L0042: intern L0042 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 3,6 HRRZI 2,12 HRRZI 1,18 HRRZI 12,164 HRRZI 13,3 PUSHJ 15,SYMFNC+164 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 12,137 SETZM 13 PUSHJ 15,SYMFNC+137 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 MOVE 1,0 POPJ 15,0 ; (!*ENTRY FACT EXPR 1) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*JUMPWGEQ (LABEL G0004) (REG 1) (WCONST 2)) ; (CAIL (REG 1) 2) ; (JRST (LABEL G0004)) ; (!*MOVE (WCONST 1) (REG 1)) ; (HRRZI (REG 1) 1) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK FACT EXPR 1) ; (HRRZI (REG LINKREG) 163) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (INTERNALENTRY FACT)) ; (!*MOVE (REG 1) (REG 2)) ; (MOVE (REG 2) (REG 1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINKE 1 LONGTIMES EXPR 2) ; (ADJSP (REG ST) (MINUS 1)) ; (HRRZI (REG LINKREG) 153) ; (HRRZI (REG NARGREG) 2) ; (JRST (ENTRY LONGTIMES)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 1) ; (ADJSP (REG ST) (MINUS 1)) ; (POPJ (REG ST) 0) 1 ; (!*ENTRY FACT EXPR 1) FACT: intern FACT PUSH 15,1 CAIL 1,2 JRST L0043 HRRZI 1,1 JRST L0044 L0043: SOS 1 HRRZI 12,163 HRRZI 13,1 PUSHJ 15,FACT MOVE 2,1 MOVE 1,0(15) ADJSP 15,-1 HRRZI 12,153 HRRZI 13,2 JRST SYMFNC+153 L0044: ADJSP 15,-1 POPJ 15,0 ; (!*ENTRY IFACT EXPR 1) ; (!*PUSH (WCONST 1)) ; (PUSH (REG ST) (LIT (FULLWORD 1))) ; (!*PUSH (REG 1)) ; (PUSH (REG ST) (REG 1)) ; (!*LBL (LABEL G0004)) ; (!*JUMPNOTEQ (LABEL G0005) (FRAME 1) (WCONST 1)) ; (MOVE (REG T1) (INDEXED (REG ST) 0)) ; (CAIE (REG T1) 1) ; (JRST (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0005)) ; (!*MOVE (FRAME 2) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK LONGTIMES EXPR 2) ; (HRRZI (REG LINKREG) 153) ; (HRRZI (REG NARGREG) 2) ; (PUSHJ (REG ST) (ENTRY LONGTIMES)) ; (!*MOVE (REG 1) (FRAME 2)) ; (MOVEM (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (FRAME 1) (WCONST -1)) ; (SOS (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 1) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) 0)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*JUMP (LABEL G0004)) ; (JRST (LABEL G0004)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 2) ; (ADJSP (REG ST) (MINUS 2)) ; (POPJ (REG ST) 0) ; (FULLWORD 1) 1 ; (!*ENTRY IFACT EXPR 1) IFACT: intern IFACT PUSH 15,L0045 PUSH 15,1 L0046: MOVE 6,0(15) CAIE 6,1 JRST L0047 MOVE 1,-1(15) JRST L0048 L0047: MOVE 2,-1(15) MOVE 1,0(15) HRRZI 12,153 HRRZI 13,2 PUSHJ 15,SYMFNC+153 MOVEM 1,-1(15) SOS 0(15) MOVE 1,0(15) HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 MOVE 1,-1(15) HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 JRST L0046 L0048: ADJSP 15,-2 POPJ 15,0 L0045: 1 ; (!*ENTRY TOPLEVELTAK EXPR 3) ; (!*ALLOC 0) ; (!*LINKE 0 TAK EXPR 3) ; (HRRZI (REG LINKREG) 165) ; (HRRZI (REG NARGREG) 3) ; (JRST (ENTRY TAK)) 3 ; (!*ENTRY TOPLEVELTAK EXPR 3) L0049: intern L0049 HRRZI 12,165 HRRZI 13,3 JRST SYMFNC+165 ; (!*ENTRY TAK EXPR 3) ; (!*ALLOC 5) ; (ADJSP (REG ST) 5) ; (!*LBL (LABEL G0002)) ; (!*MOVE (REG 1) (FRAME 1)) ; (MOVEM (REG 1) (INDEXED (REG ST) 0)) ; (!*MOVE (REG 2) (FRAME 2)) ; (MOVEM (REG 2) (INDEXED (REG ST) -1)) ; (!*MOVE (REG 3) (FRAME 3)) ; (MOVEM (REG 3) (INDEXED (REG ST) -2)) ; (!*JUMPWLESSP (LABEL G0004) (REG 2) (REG 1)) ; (CAMGE (REG 2) (REG 1)) ; (JRST (LABEL G0004)) ; (!*MOVE (REG 3) (REG 1)) ; (MOVE (REG 1) (REG 3)) ; (!*JUMP (LABEL G0001)) ; (JRST (LABEL G0001)) ; (!*LBL (LABEL G0004)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 165) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 4)) ; (MOVEM (REG 1) (INDEXED (REG ST) -3)) ; (!*MOVE (FRAME 1) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -2)) ; (!*MOVE (FRAME 2) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -1)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 165) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (FRAME 5)) ; (MOVEM (REG 1) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 2) (REG 3)) ; (MOVE (REG 3) (INDEXED (REG ST) -1)) ; (!*MOVE (FRAME 1) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) 0)) ; (!*MOVE (FRAME 3) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -2)) ; (!*WPLUS2 (REG 1) (WCONST -1)) ; (SOS (REG 1)) ; (!*LINK TAK EXPR 3) ; (HRRZI (REG LINKREG) 165) ; (HRRZI (REG NARGREG) 3) ; (PUSHJ (REG ST) (INTERNALENTRY TAK)) ; (!*MOVE (REG 1) (REG 3)) ; (MOVE (REG 3) (REG 1)) ; (!*MOVE (FRAME 5) (REG 2)) ; (MOVE (REG 2) (INDEXED (REG ST) -4)) ; (!*MOVE (FRAME 4) (REG 1)) ; (MOVE (REG 1) (INDEXED (REG ST) -3)) ; (!*JUMP (LABEL G0002)) ; (JRST (LABEL G0002)) ; (!*LBL (LABEL G0001)) ; (!*EXIT 5) ; (ADJSP (REG ST) (MINUS 5)) ; (POPJ (REG ST) 0) 3 ; (!*ENTRY TAK EXPR 3) TAK: intern TAK ADJSP 15,5 L0050: MOVEM 1,0(15) MOVEM 2,-1(15) MOVEM 3,-2(15) CAMGE 2,1 JRST L0051 MOVE 1,3 JRST L0052 L0051: SOS 1 HRRZI 12,165 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-3(15) MOVE 3,0(15) MOVE 2,-2(15) MOVE 1,-1(15) SOS 1 HRRZI 12,165 HRRZI 13,3 PUSHJ 15,TAK MOVEM 1,-4(15) MOVE 3,-1(15) MOVE 2,0(15) MOVE 1,-2(15) SOS 1 HRRZI 12,165 HRRZI 13,3 PUSHJ 15,TAK MOVE 3,1 MOVE 2,-4(15) MOVE 1,-3(15) JRST L0050 L0052: ADJSP 15,-5 POPJ 15,0 ; (!*ENTRY UNDEFINEDFUNCTIONAUX EXPR 0) ; (!*ALLOC 0) ; (!*MOVE (QUOTE 85) (REG 1)) ; (HRRZI (REG 1) 85) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 110) (REG 1)) ; (HRRZI (REG 1) 110) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 100) (REG 1)) ; (HRRZI (REG 1) 100) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 101) (REG 1)) ; (HRRZI (REG 1) 101) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 102) (REG 1)) ; (HRRZI (REG 1) 102) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (QUOTE 32) (REG 1)) ; (HRRZI (REG 1) 32) ; (!*LINK PUTC EXPR 1) ; (HRRZI (REG LINKREG) 139) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTC)) ; (!*MOVE (!$FLUID UNDEFNCODE!*) (REG 1)) ; (MOVE (REG 1) (!$FLUID UNDEFNCODE!*)) ; (!*LINK PUTINT EXPR 1) ; (HRRZI (REG LINKREG) 146) ; (HRRZI (REG NARGREG) 1) ; (PUSHJ (REG ST) (ENTRY PUTINT)) ; (!*LINK TERPRI EXPR 0) ; (HRRZI (REG LINKREG) 159) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY TERPRI)) ; (!*LINK QUIT EXPR 0) ; (HRRZI (REG LINKREG) 140) ; (SETZM (REG NARGREG)) ; (PUSHJ (REG ST) (ENTRY QUIT)) ; (!*MOVE (QUOTE NIL) (REG 1)) ; (MOVE (REG 1) (REG NIL)) ; (!*EXIT 0) ; (POPJ (REG ST) 0) 0 ; (!*ENTRY UNDEFINEDFUNCTIONAUX EXPR 0) L0053: intern L0053 HRRZI 1,85 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,110 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,100 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,101 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,102 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 HRRZI 1,32 HRRZI 12,139 HRRZI 13,1 PUSHJ 15,SYMFNC+139 MOVE 1,SYMVAL+150 HRRZI 12,146 HRRZI 13,1 PUSHJ 15,SYMFNC+146 HRRZI 12,159 SETZM 13 PUSHJ 15,SYMFNC+159 HRRZI 12,140 SETZM 13 PUSHJ 15,SYMFNC+140 MOVE 1,0 POPJ 15,0 0 ; (!*ENTRY INITCODE EXPR 0) L0054: intern L0054 MOVE 1,0 POPJ 15,0 extern SYMVAL extern SYMPRP extern SYMNAM L0055: 0 byte(7)0,0 intern L0055 L0056: 0 byte(7)1,0 intern L0056 L0057: 0 byte(7)2,0 intern L0057 L0058: 0 byte(7)3,0 intern L0058 L0059: 0 byte(7)4,0 intern L0059 L0060: 0 byte(7)5,0 intern L0060 L0061: 0 byte(7)6,0 intern L0061 L0062: 0 byte(7)7,0 intern L0062 L0063: 0 byte(7)8,0 intern L0063 L0064: 0 byte(7)9,0 intern L0064 L0065: 0 byte(7)10,0 intern L0065 L0066: 0 byte(7)11,0 intern L0066 L0067: 0 byte(7)12,0 intern L0067 L0068: 0 byte(7)13,0 intern L0068 L0069: 0 byte(7)14,0 intern L0069 L0070: 0 byte(7)15,0 intern L0070 L0071: 0 byte(7)16,0 intern L0071 L0072: 0 byte(7)17,0 intern L0072 L0073: 0 byte(7)18,0 intern L0073 L0074: 0 byte(7)19,0 intern L0074 L0075: 0 byte(7)20,0 intern L0075 L0076: 0 byte(7)21,0 intern L0076 L0077: 0 byte(7)22,0 intern L0077 L0078: 0 byte(7)23,0 intern L0078 L0079: 0 byte(7)24,0 intern L0079 L0080: 0 byte(7)25,0 intern L0080 L0081: 0 byte(7)26,0 intern L0081 L0082: 0 byte(7)27,0 intern L0082 L0083: 0 byte(7)28,0 intern L0083 L0084: 0 byte(7)29,0 intern L0084 L0085: 0 byte(7)30,0 intern L0085 L0086: 0 byte(7)31,0 intern L0086 L0087: 0 byte(7)32,0 intern L0087 L0088: 0 byte(7)33,0 intern L0088 L0089: 0 byte(7)34,0 intern L0089 L0090: 0 byte(7)35,0 intern L0090 L0091: 0 byte(7)36,0 intern L0091 L0092: 0 byte(7)37,0 intern L0092 L0093: 0 byte(7)38,0 intern L0093 L0094: 0 byte(7)39,0 intern L0094 L0095: 0 byte(7)40,0 intern L0095 L0096: 0 byte(7)41,0 intern L0096 L0097: 0 byte(7)42,0 intern L0097 L0098: 0 byte(7)43,0 intern L0098 L0099: 0 byte(7)44,0 intern L0099 L0100: 0 byte(7)45,0 intern L0100 L0101: 0 byte(7)46,0 intern L0101 L0102: 0 byte(7)47,0 intern L0102 L0103: 0 byte(7)48,0 intern L0103 L0104: 0 byte(7)49,0 intern L0104 L0105: 0 byte(7)50,0 intern L0105 L0106: 0 byte(7)51,0 intern L0106 L0107: 0 byte(7)52,0 intern L0107 L0108: 0 byte(7)53,0 intern L0108 L0109: 0 byte(7)54,0 intern L0109 L0110: 0 byte(7)55,0 intern L0110 L0111: 0 byte(7)56,0 intern L0111 L0112: 0 byte(7)57,0 intern L0112 L0113: 0 byte(7)58,0 intern L0113 L0114: 0 byte(7)59,0 intern L0114 L0115: 0 byte(7)60,0 intern L0115 L0116: 0 byte(7)61,0 intern L0116 L0117: 0 byte(7)62,0 intern L0117 L0118: 0 byte(7)63,0 intern L0118 L0119: 0 byte(7)64,0 intern L0119 L0120: 0 byte(7)65,0 intern L0120 L0121: 0 byte(7)66,0 intern L0121 L0122: 0 byte(7)67,0 intern L0122 L0123: 0 byte(7)68,0 intern L0123 L0124: 0 byte(7)69,0 intern L0124 L0125: 0 byte(7)70,0 intern L0125 L0126: 0 byte(7)71,0 intern L0126 L0127: 0 byte(7)72,0 intern L0127 L0128: 0 byte(7)73,0 intern L0128 L0129: 0 byte(7)74,0 intern L0129 L0130: 0 byte(7)75,0 intern L0130 L0131: 0 byte(7)76,0 intern L0131 L0132: 0 byte(7)77,0 intern L0132 L0133: 0 byte(7)78,0 intern L0133 L0134: 0 byte(7)79,0 intern L0134 L0135: 0 byte(7)80,0 intern L0135 L0136: 0 byte(7)81,0 intern L0136 L0137: 0 byte(7)82,0 intern L0137 L0138: 0 byte(7)83,0 intern L0138 L0139: 0 byte(7)84,0 intern L0139 L0140: 0 byte(7)85,0 intern L0140 L0141: 0 byte(7)86,0 intern L0141 L0142: 0 byte(7)87,0 intern L0142 L0143: 0 byte(7)88,0 intern L0143 L0144: 0 byte(7)89,0 intern L0144 L0145: 0 byte(7)90,0 intern L0145 L0146: 0 byte(7)91,0 intern L0146 L0147: 0 byte(7)92,0 intern L0147 L0148: 0 byte(7)93,0 intern L0148 L0149: 0 byte(7)94,0 intern L0149 L0150: 0 byte(7)95,0 intern L0150 L0151: 0 byte(7)96,0 intern L0151 L0152: 0 byte(7)97,0 intern L0152 L0153: 0 byte(7)98,0 intern L0153 L0154: 0 byte(7)99,0 intern L0154 L0155: 0 byte(7)100,0 intern L0155 L0156: 0 byte(7)101,0 intern L0156 L0157: 0 byte(7)102,0 intern L0157 L0158: 0 byte(7)103,0 intern L0158 L0159: 0 byte(7)104,0 intern L0159 L0160: 0 byte(7)105,0 intern L0160 L0161: 0 byte(7)106,0 intern L0161 L0162: 0 byte(7)107,0 intern L0162 L0163: 0 byte(7)108,0 intern L0163 L0164: 0 byte(7)109,0 intern L0164 L0165: 0 byte(7)110,0 intern L0165 L0166: 0 byte(7)111,0 intern L0166 L0167: 0 byte(7)112,0 intern L0167 L0168: 0 byte(7)113,0 intern L0168 L0169: 0 byte(7)114,0 intern L0169 L0170: 0 byte(7)115,0 intern L0170 L0171: 0 byte(7)116,0 intern L0171 L0172: 0 byte(7)117,0 intern L0172 L0173: 0 byte(7)118,0 intern L0173 L0174: 0 byte(7)119,0 intern L0174 L0175: 0 byte(7)120,0 intern L0175 L0176: 0 byte(7)121,0 intern L0176 L0177: 0 byte(7)122,0 intern L0177 L0178: 0 byte(7)123,0 intern L0178 L0179: 0 byte(7)124,0 intern L0179 L0180: 0 byte(7)125,0 intern L0180 L0181: 0 byte(7)126,0 intern L0181 L0182: 0 byte(7)127,0 intern L0182 L0183: 2 byte(7)78,73,76,0 intern L0183 L0184: 7 byte(7)73,78,73,84,72,69,65,80,0 intern L0184 L0185: 8 byte(7)70,73,82,83,84,67,65,76,76,0 intern L0185 L0186: 4 byte(7)77,65,73,78,46,0 intern L0186 L0187: 3 byte(7)73,78,73,84,0 intern L0187 L0188: 2 byte(7)73,78,42,0 intern L0188 L0189: 3 byte(7)79,85,84,42,0 intern L0189 L0190: 18 byte(7)73,78,68,69,80,69,78,68,69,78,84,82,69,65,68,67,72,65,82,0 intern L0190 L0191: 3 byte(7)71,69,84,67,0 intern L0191 L0192: 3 byte(7)84,73,77,67,0 intern L0192 L0193: 19 byte(7)73,78,68,69,80,69,78,68,69,78,84,87,82,73,84,69,67,72,65,82,0 intern L0193 L0194: 3 byte(7)80,85,84,67,0 intern L0194 L0195: 3 byte(7)81,85,73,84,0 intern L0195 L0196: 7 byte(7)69,88,73,84,76,73,83,80,0 intern L0196 L0197: 5 byte(7)80,82,73,78,50,84,0 intern L0197 L0198: 4 byte(7)82,69,83,69,84,0 intern L0198 L0199: 3 byte(7)68,65,84,69,0 intern L0199 L0200: 10 byte(7)86,69,82,83,73,79,78,78,65,77,69,0 intern L0200 L0201: 5 byte(7)80,85,84,73,78,84,0 intern L0201 L0202: 11 byte(7)37,83,84,79,82,69,45,74,67,65,76,76,0 intern L0202 L0203: 18 byte(7)37,67,79,80,89,45,70,85,78,67,84,73,79,78,45,67,69,76,76,0 intern L0203 L0204: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L0204 L0205: 10 byte(7)85,78,68,69,70,78,67,79,68,69,42,0 intern L0205 L0206: 10 byte(7)85,78,68,69,70,78,78,65,82,71,42,0 intern L0206 L0207: 19 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,65,85,88,0 intern L0207 L0208: 8 byte(7)76,79,78,71,84,73,77,69,83,0 intern L0208 L0209: 8 byte(7)87,81,85,79,84,73,69,78,84,0 intern L0209 L0210: 6 byte(7)76,79,78,71,68,73,86,0 intern L0210 L0211: 9 byte(7)87,82,69,77,65,73,78,68,69,82,0 intern L0211 L0212: 12 byte(7)76,79,78,71,82,69,77,65,73,78,68,69,82,0 intern L0212 L0213: 4 byte(7)73,70,65,67,84,0 intern L0213 L0214: 5 byte(7)84,69,82,80,82,73,0 intern L0214 L0215: 7 byte(7)84,69,83,84,70,65,67,84,0 intern L0215 L0216: 6 byte(7)84,69,83,84,84,65,75,0 intern L0216 L0217: 13 byte(7)65,82,73,84,72,77,69,84,73,67,84,69,83,84,0 intern L0217 L0218: 3 byte(7)70,65,67,84,0 intern L0218 L0219: 10 byte(7)84,79,80,76,69,86,69,76,84,65,75,0 intern L0219 L0220: 2 byte(7)84,65,75,0 intern L0220 L0221: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L0221 extern SYMFNC extern L0003 end MAIN. |
Added psl-1983/3-1/tests/20/main1.rel version [4a433bf7bc].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main1.sym version [33ae87d2e6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE NIL)) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 129)) (SETQ STRINGGENSYM!* (QUOTE "L0005")) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) |
Added psl-1983/3-1/tests/20/main2.cmd version [e95583b75a].
> > | 1 2 | main2,Dmain2,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main2.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/3-1/tests/20/main2.rel version [71236d4fa0].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main2.sym version [aa3690ee91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 180)) (SETQ STRINGGENSYM!* (QUOTE "L0135")) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) |
Added psl-1983/3-1/tests/20/main3.cmd version [1f300e0572].
> > | 1 2 | main3,Dmain3,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main3.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/3-1/tests/20/main3.rel version [8970e96f68].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main3.sym version [739545cf20].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 207)) (SETQ STRINGGENSYM!* (QUOTE "L0189")) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) |
Added psl-1983/3-1/tests/20/main4.cmd version [0ea02d84c5].
> > | 1 2 | main4,Dmain4,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main4.init version [b85f7234c7].
> > > > > > > | 1 2 3 4 5 6 7 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (PUT (QUOTE SYMFNCBASE) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) |
Added psl-1983/3-1/tests/20/main4.rel version [76f582e3cf].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main4.sym version [ce461e890a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 252)) (SETQ STRINGGENSYM!* (QUOTE "L0307")) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/main5.cmd version [6002e5c0a4].
> > | 1 2 | main5,Dmain5,sub5a,Dsub5a,sub5b,dsub5b,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main5.init version [1fd5728396].
> > > > > | 1 2 3 4 5 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) |
Added psl-1983/3-1/tests/20/main5.rel version [e70d98b8d8].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main5.sym version [e2b054e0e7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL CODEPRIMITIVEWGETV BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK EVPROGN UNBINDN SYS2INT PLUS2 MINUS ELSE ADD1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAAAR CAAAAR CAAADR CAADR CAADAR CAADDR CADAR CADAAR CADADR CADDR CADDAR CADDDR CDAAR CDAAAR CDAADR CDADR CDADAR CDADDR CDDAR CDDAAR CDDADR CDDDR CDDDAR CDDDDR CAAR CADR CDAR CDDR SAFECAR CAR CDR ATOM CONSTANTP NULL LIST PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO SET SETQ PROGN EVCOND COND NOT APPEND MEMQ REVERSE EVLIS ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE TYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP RPLACA RPLACD LENGTH1 FLUID FLUIDP GLOBAL GLOBALP UNFLUID PROP REMPROP SYS2FIXN))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 393)) (SETQ STRINGGENSYM!* (QUOTE "L1338")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0315")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0319")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0685")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L0779")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0749")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0349")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0353")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0430")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0437") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0583")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 270)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0363")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0791")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0419")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0752")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE CODEPRIMITIVEWGETV) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0719")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0465")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0588")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0324")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 271)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0796")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0736")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0730")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0396")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0809")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0723")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0333")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0720")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0431")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0611")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0477")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0645")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0328")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0344")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L0777")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 268)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/main6.cmd version [56cfd91564].
> > | 1 2 | main6,Dmain6,sub6,Dsub6,sub5a,Dsub5a,sub5b,Dsub5b,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main6.init version [b74096dbf7].
> > > > > > | 1 2 3 4 5 6 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (GLOBAL (QUOTE (LAMBDA1 LAMBDA2 CODEFORM!*))) |
Added psl-1983/3-1/tests/20/main6.rel version [5d1979527d].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main6.sym version [ec698f5146].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL CODEPRIMITIVEWGETV BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK EVPROGN UNBINDN SYS2INT PLUS2 MINUS ELSE ADD1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAAAR CAAAAR CAAADR CAADR CAADAR CAADDR CADAR CADAAR CADADR CADDR CADDAR CADDDR CDAAR CDAAAR CDAADR CDADR CDADAR CDADDR CDDAR CDDAAR CDDADR CDDDR CDDDAR CDDDDR CAAR CADR CDAR CDDR SAFECAR CAR CDR ATOM CONSTANTP NULL LIST PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO SET SETQ PROGN EVCOND COND NOT APPEND MEMQ REVERSE EVLIS ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE TYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP RPLACA RPLACD LENGTH1 FLUID FLUIDP GLOBAL GLOBALP UNFLUID PROP REMPROP SYS2FIXN RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 LAMBIND LAMBINDARGS!* PROGBIND CODE!-NUMBER!-OF!-ARGUMENTS))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 406)) (SETQ STRINGGENSYM!* (QUOTE "L1409")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0315")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1340")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0319")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0685")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1363")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L0779")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0749")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0349")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0353")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0430")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0437") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1352")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0583")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 270)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0363")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0791")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0419")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0752")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE CODEPRIMITIVEWGETV) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1341")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1366")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0719")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0465")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0588")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0324")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 271)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L1407")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1349")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1348")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0796")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0736")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1344")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0730")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0396")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0809")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0723")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1347")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0333")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0720")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0431")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0611")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0477")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1353")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0645")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0328")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0344")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L0777")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1339")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 268)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/main7.cmd version [c3b37addf4].
> > | 1 2 | main7,dmain7,sub7,Dsub7,sub6,Dsub6,sub5a,Dsub5a,sub5b,Dsub5b,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main7.init version [fb9224ee67].
> > > > > > > | 1 2 3 4 5 6 7 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (TESTLIST TESTLIST2 LONGLIST EVALFORM))) (GLOBAL (QUOTE (TESTGLOBALVAR))) |
Added psl-1983/3-1/tests/20/main7.rel version [aad4627f3c].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main7.sym version [8e20da347b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL CODEPRIMITIVEWGETV BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK EVPROGN UNBINDN SYS2INT PLUS2 MINUS ELSE ADD1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAAAR CAAAAR CAAADR CAADR CAADAR CAADDR CADAR CADAAR CADADR CADDR CADDAR CADDDR CDAAR CDAAAR CDAADR CDADR CDADAR CDADDR CDDAR CDDAAR CDDADR CDDDR CDDDAR CDDDDR CAAR CADR CDAR CDDR SAFECAR CAR CDR ATOM CONSTANTP NULL LIST PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO SET SETQ PROGN EVCOND COND NOT APPEND MEMQ REVERSE EVLIS ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE TYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP RPLACA RPLACD LENGTH1 FLUID FLUIDP GLOBAL GLOBALP UNFLUID PROP REMPROP SYS2FIXN RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 LAMBIND LAMBINDARGS!* PROGBIND CODE!-NUMBER!-OF!-ARGUMENTS SYSCLEARIO DEC20OPEN CONTOPENERROR SYSOPENREAD INPUT SYSOPENWRITE OUTPUT DEC20READCHAR SYSREADREC IOERROR DEC20WRITECHAR SYSWRITEREC SYSCLOSE CHANNELERROR SYSMAXBUFFER TERMINALINPUTHANDLER WRITEONLYCHANNEL COMPRESSREADCHAR CHANNELNOTOPEN READONLYCHANNEL TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR ILLEGALSTANDARDCHANNELCLOSE !$EOL!$ RDS WRS OPEN CLOSE TYPEFILE DSKIN !$EOF!$ !*PVAL !*ECHO LAPIN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT INDEPENDENTCLOSECHANNEL IN!* STDIN!* STDOUT!* PROMPTOUT!* FINDFREECHANNEL IOBUFFER INDEPENDENTREADCHAR SYSTEMOPENFILESPECIAL TESTLEGALCHANNEL FLUSHBUFFER SYSTEMMARKASCLOSEDCHANNEL CLEARONECHANNEL CLEARIO CHANNELWRITESTRING PROMPTSTRING!*))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 459)) (SETQ STRINGGENSYM!* (QUOTE "L1530")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0315")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1340")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1455")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE MAXBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1451")) (PUT (QUOTE MAXBUFFER) (QUOTE WARRAY) (QUOTE MAXBUFFER)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L1490")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0319")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE SYSOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L1415")) (PUT (QUOTE SYSOPENWRITE) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0685")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1363")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L0779")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0749")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1444")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0349")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 436)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE PROMPTOUT!*) (QUOTE IDNUMBER) (QUOTE 447)) (PUT (QUOTE PROMPTOUT!*) (QUOTE INITIALVALUE) (QUOTE 6)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0353")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0430")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0437") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE SYSCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1440")) (PUT (QUOTE SYSCLOSE) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1502")) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE IDNUMBER) (QUOTE 450)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE SYSREADREC) (QUOTE ENTRYPOINT) (QUOTE "L1420")) (PUT (QUOTE SYSREADREC) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1352")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0583")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE SYSWRITEREC) (QUOTE ENTRYPOINT) (QUOTE "L1432")) (PUT (QUOTE SYSWRITEREC) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE IOBUFFER) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 270)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0363")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE !*PVAL) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*PVAL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SYSCLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1410")) (PUT (QUOTE SYSCLEARIO) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE CHANNELSTATUS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELSTATUS) (QUOTE ASMSYMBOL) (QUOTE "L1450")) (PUT (QUOTE CHANNELSTATUS) (QUOTE WARRAY) (QUOTE CHANNELSTATUS)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0791")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0419")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE NEXTPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1453")) (PUT (QUOTE NEXTPOSITION) (QUOTE WARRAY) (QUOTE NEXTPOSITION)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0752")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE CODEPRIMITIVEWGETV) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 437)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1341")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1366")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1511")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE SYSOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L1412")) (PUT (QUOTE SYSOPENREAD) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0719")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0465")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE FLUSHBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1509")) (PUT (QUOTE FLUSHBUFFER) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE CHANNELTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELTABLE) (QUOTE ASMSYMBOL) (QUOTE "L1452")) (PUT (QUOTE CHANNELTABLE) (QUOTE WARRAY) (QUOTE CHANNELTABLE)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L1495")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1512")) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 443)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L1526")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 446)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1483")) (PUT (QUOTE FINDFREECHANNEL) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1506")) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0588")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0324")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 271)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1445")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE CLEARONECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1514")) (PUT (QUOTE CLEARONECHANNEL) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L1407")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1436")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE SYSMAXBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1442")) (PUT (QUOTE SYSMAXBUFFER) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1349")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE BUFFERLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BUFFERLENGTH) (QUOTE ASMSYMBOL) (QUOTE "L1454")) (PUT (QUOTE BUFFERLENGTH) (QUOTE WARRAY) (QUOTE BUFFERLENGTH)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1348")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0796")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0736")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1344")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1447")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1448")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1443")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0730")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0396")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0809")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0723")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1347")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE TYPEFILE) (QUOTE ENTRYPOINT) (QUOTE "L1462")) (PUT (QUOTE TYPEFILE) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0333")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1427")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0720")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0431")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L1449")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0611")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0477")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1446")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1353")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0645")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0328")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L1494")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L1460")) (PUT (QUOTE CONTOPENERROR) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0344")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L0777")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1339")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1498")) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 268)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L1417")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/main8.cmd version [0284630a13].
> > | 1 2 | main8,dmain8,sub8,dsub8,sub7,Dsub7,sub6,Dsub6,sub5a,Dsub5a,sub5b,Dsub5b,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main8.sym version [9f0f40b7c6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL CODEPRIMITIVEWGETV BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK EVPROGN UNBINDN SYS2INT PLUS2 MINUS ELSE ADD1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAAAR CAAAAR CAAADR CAADR CAADAR CAADDR CADAR CADAAR CADADR CADDR CADDAR CADDDR CDAAR CDAAAR CDAADR CDADR CDADAR CDADDR CDDAR CDDAAR CDDADR CDDDR CDDDAR CDDDDR CAAR CADR CDAR CDDR SAFECAR CAR CDR ATOM CONSTANTP NULL LIST PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO SET SETQ PROGN EVCOND COND NOT APPEND MEMQ REVERSE EVLIS ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE TYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP RPLACA RPLACD LENGTH1 FLUID FLUIDP GLOBAL GLOBALP UNFLUID PROP REMPROP SYS2FIXN RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 LAMBIND LAMBINDARGS!* PROGBIND CODE!-NUMBER!-OF!-ARGUMENTS SYSCLEARIO DEC20OPEN CONTOPENERROR SYSOPENREAD INPUT SYSOPENWRITE OUTPUT DEC20READCHAR SYSREADREC IOERROR DEC20WRITECHAR SYSWRITEREC SYSCLOSE CHANNELERROR SYSMAXBUFFER TERMINALINPUTHANDLER WRITEONLYCHANNEL COMPRESSREADCHAR CHANNELNOTOPEN READONLYCHANNEL TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR ILLEGALSTANDARDCHANNELCLOSE !$EOL!$ RDS WRS OPEN CLOSE TYPEFILE DSKIN !$EOF!$ !*PVAL !*ECHO LAPIN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT INDEPENDENTCLOSECHANNEL IN!* STDIN!* STDOUT!* PROMPTOUT!* FINDFREECHANNEL IOBUFFER INDEPENDENTREADCHAR SYSTEMOPENFILESPECIAL TESTLEGALCHANNEL FLUSHBUFFER SYSTEMMARKASCLOSEDCHANNEL CLEARONECHANNEL CLEARIO CHANNELWRITESTRING PROMPTSTRING!* BEFOREGCSYSTEMHOOK AFTERGCSYSTEMHOOK !*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL TIMC MARKFROMALLBASES MAKEIDFREELIST BUILDRELOCATIONFIELDS UPDATEALLBASES COMPACTHEAP GCMESSAGE KNOWN!-FREE!-SPACE CONTINUABLEERROR MARKFROMSYMBOLS MARKFROMRANGE MARKFROMBASE MARKFROMONESYMBOL HALFWORD MARKFROMVECTOR GCERROR UPDATESYMBOLS UPDATEREGION UPDATEITEM UPDATEHEAP))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 485)) (SETQ STRINGGENSYM!* (QUOTE "L1714")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0315")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1340")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1455")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE MAXBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1451")) (PUT (QUOTE MAXBUFFER) (QUOTE WARRAY) (QUOTE MAXBUFFER)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L1490")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0319")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE SYSOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L1415")) (PUT (QUOTE SYSOPENWRITE) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0685")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1363")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L0779")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0749")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE GCARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE GCARRAY) (QUOTE ASMSYMBOL) (QUOTE "L1542")) (PUT (QUOTE GCARRAY) (QUOTE WARRAY) (QUOTE GCARRAY)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1444")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0349")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE IDNUMBER) (QUOTE 472)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 436)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE PROMPTOUT!*) (QUOTE IDNUMBER) (QUOTE 447)) (PUT (QUOTE PROMPTOUT!*) (QUOTE INITIALVALUE) (QUOTE 6)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1564")) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE GCERROR) (QUOTE ENTRYPOINT) (QUOTE "L1708")) (PUT (QUOTE GCERROR) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0353")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0430")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0437") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE SYSCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1440")) (PUT (QUOTE SYSCLOSE) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1502")) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE IDNUMBER) (QUOTE 450)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE SYSREADREC) (QUOTE ENTRYPOINT) (QUOTE "L1420")) (PUT (QUOTE SYSREADREC) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1352")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0583")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE SYSWRITEREC) (QUOTE ENTRYPOINT) (QUOTE "L1432")) (PUT (QUOTE SYSWRITEREC) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE MARKFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1557")) (PUT (QUOTE MARKFROMALLBASES) (QUOTE IDNUMBER) (QUOTE 466)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE IOBUFFER) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE UPDATEREGION) (QUOTE ENTRYPOINT) (QUOTE "L1646")) (PUT (QUOTE UPDATEREGION) (QUOTE IDNUMBER) (QUOTE 482)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 270)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0363")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE !*PVAL) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*PVAL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SYSCLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1410")) (PUT (QUOTE SYSCLEARIO) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE CHANNELSTATUS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELSTATUS) (QUOTE ASMSYMBOL) (QUOTE "L1450")) (PUT (QUOTE CHANNELSTATUS) (QUOTE WARRAY) (QUOTE CHANNELSTATUS)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0791")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0419")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE ENTRYPOINT) (QUOTE "L1612")) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE UPDATEITEM) (QUOTE ENTRYPOINT) (QUOTE "L1677")) (PUT (QUOTE UPDATEITEM) (QUOTE IDNUMBER) (QUOTE 483)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE NEXTPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1453")) (PUT (QUOTE NEXTPOSITION) (QUOTE WARRAY) (QUOTE NEXTPOSITION)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0752")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE INITIALVALUE) (QUOTE 1000)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE HALFWORD) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE MARKFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1580")) (PUT (QUOTE MARKFROMBASE) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MARKFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1573")) (PUT (QUOTE MARKFROMRANGE) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE UPDATESYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1641")) (PUT (QUOTE UPDATESYMBOLS) (QUOTE IDNUMBER) (QUOTE 481)) (PUT (QUOTE GCMESSAGE) (QUOTE ENTRYPOINT) (QUOTE "L1714")) (PUT (QUOTE GCMESSAGE) (QUOTE IDNUMBER) (QUOTE 471)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE CODEPRIMITIVEWGETV) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 437)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1341")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1366")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1511")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE HEAPTRAPPED) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPPED) (QUOTE ASMSYMBOL) (QUOTE "L1541")) (PUT (QUOTE HEAPTRAPPED) (QUOTE WVAR) (QUOTE HEAPTRAPPED)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE SYSOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L1412")) (PUT (QUOTE SYSOPENREAD) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0719")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0465")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE FLUSHBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1509")) (PUT (QUOTE FLUSHBUFFER) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE CHANNELTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELTABLE) (QUOTE ASMSYMBOL) (QUOTE "L1452")) (PUT (QUOTE CHANNELTABLE) (QUOTE WARRAY) (QUOTE CHANNELTABLE)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L1495")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1512")) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 443)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L1526")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 446)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1483")) (PUT (QUOTE FINDFREECHANNEL) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1506")) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0588")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0324")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 271)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE AFTERGCSYSTEMHOOK) (QUOTE ENTRYPOINT) (QUOTE "L1539")) (PUT (QUOTE AFTERGCSYSTEMHOOK) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1445")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE CLEARONECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1514")) (PUT (QUOTE CLEARONECHANNEL) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L1407")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE BEFOREGCSYSTEMHOOK) (QUOTE ENTRYPOINT) (QUOTE "L1534")) (PUT (QUOTE BEFOREGCSYSTEMHOOK) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1436")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE SYSMAXBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1442")) (PUT (QUOTE SYSMAXBUFFER) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1349")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE BUFFERLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BUFFERLENGTH) (QUOTE ASMSYMBOL) (QUOTE "L1454")) (PUT (QUOTE BUFFERLENGTH) (QUOTE WARRAY) (QUOTE BUFFERLENGTH)) (PUT (QUOTE MARKFROMVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1592")) (PUT (QUOTE MARKFROMVECTOR) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1348")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0796")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0736")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1344")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1447")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1448")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1443")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0730")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0396")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0809")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0723")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1553")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1347")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE TYPEFILE) (QUOTE ENTRYPOINT) (QUOTE "L1462")) (PUT (QUOTE TYPEFILE) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0333")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1427")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0720")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0431")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L1449")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE UPDATEALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1635")) (PUT (QUOTE UPDATEALLBASES) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0611")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0477")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1446")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1353")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0645")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0328")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1548")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L1494")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L1460")) (PUT (QUOTE CONTOPENERROR) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0344")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L0777")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1339")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1498")) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE UPDATEHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1656")) (PUT (QUOTE UPDATEHEAP) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1597")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE IDNUMBER) (QUOTE 467)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 268)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L1417")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE COMPACTHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1688")) (PUT (QUOTE COMPACTHEAP) (QUOTE IDNUMBER) (QUOTE 470)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE ENTRYPOINT) (QUOTE "L1572")) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/main9.cmd version [2c771b3c27].
> > | 1 2 | main9,Dmain9,sub9,Dsub9,sub8,dsub8,sub7,Dsub7,sub6,Dsub6,sub5a,Dsub5a,sub5b,Dsub5b,sub4,Dsub4,sub3,Dsub3,sub2,Dsub2,20io |
Added psl-1983/3-1/tests/20/main9.init version [a9bbec79f0].
> > > > > > > > | 1 2 3 4 5 6 7 8 | (FLAG (QUOTE (INIT20 PUTC20 GETC20 TIMC20 QUIT20 ERR20 PUTI20)) (QUOTE FOREIGNFUNCTION)) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (UNDEFNCODE!* UNDEFNNARG!*))) (FLUID (QUOTE (TESTLIST TESTLIST2 LONGLIST EVALFORM))) (GLOBAL (QUOTE (TESTGLOBALVAR))) (FLUID (QUOTE (HEAP!-WARN!-LEVEL))) |
Added psl-1983/3-1/tests/20/main9.rel version [152d73a69e].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/main9.sym version [7838c00851].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (SETQ LAMBINDARGS!* (GTWARRAY 15))))) (SETQ ORDEREDIDLIST!* (QUOTE (PUTC CHANNELWRITECHAR INDEPENDENTWRITECHAR WRITECHAR OUT!* PRIN1ID PRIN1INT PRIN1STRING PRIN1PAIR PRTITM PRIN1 PRIN2ID PRIN2STRING PRIN2PAIR PRIN2 TERPRI PRINT PRIN2T PBLANK PRIN1INTX LONGDIV LONGREMAINDER BYTE CHANNELPRIN2 PRINTF ERRORPRINTF LIST5 XCONS BLDMSG ERRPRIN ERRORHEADER ERRORTRAILER ERROR PRIN2L QUIT FATALERROR STDERROR TYPEERROR USAGETYPEERROR INDEXERROR NONPAIRERROR NONIDERROR NONNUMBERERROR NONINTEGERERROR NONPOSITIVEINTEGERERROR NONCHARACTERERROR NONSTRINGERROR NONVECTORERROR NONWORDS NONSEQUENCEERROR NONIOCHANNELERROR WQUOTIENT !%RECLAIM GTHEAP DELHEAP GTSTR GTBPS GTCONSTSTR GTHALFWORDS GTVECT GTEVECT GTWRDS GTFIXN GTFLTN RECLAIM GTID DELBPS GTWARRAY DELWARRAY HARDCONS CONS NCONS MKVECT LIST4 LIST3 LIST2 PUTBYTE MKSTRING EQSTR INITREAD !*RAISE CH!* TOK!* TOKTYPE!* DEBUG SETRAISE CLEARWHITE CLEARCOMMENT READSTR DIGITP READINT ALPHAESCP READID RATOM WHITEP GETC LONGTIMES BUFFERTOSTRING RAISECHAR ALPHANUMESCP INTERN ESCAPEP ALPHAP LOWERCASEP UPPERCASEP ALPHANUMP LOOKUPSTRING NEWID INITNEWID MAKEFUNBOUND PUTHALFWORD MAPOBL PRINTFEXPRS PRINT1FEXPR FEXPRP PRINTFUNCTIONS PRINT1FUNCTION FUNBOUNDP INITOBLIST READ1 READ READLIST QUOTE SAFECDR SYMFNCBASE WPLUS2 SYMFNC WTIMES2 ADDRESSINGUNITSPERFUNCTIONCELL SHOULDBEUNDEFINED !%COPY!-FUNCTION!-CELL COMPILEDCALLINGINTERPRETED FLAMBDALINKP !%STORE!-JCALL MAKEFLAMBDALINK FCODEP MAKEFCODE GETFCODEPOINTER CODEPRIMITIVE CODEPTR!* SAVEREGISTERS CODEFORM!* CODENARG!* COMPILEDCALLINGINTERPRETEDAUX FASTAPPLY FASTLAMBDAAPPLY LAMBDA UNDEFINEDFUNCTIONAUX UNDEFINEDFUNCTIONAUXAUX CODEAPPLY CODEEVALAPPLY CODEEVALAPPLYAUX EVAL CODEPRIMITIVEWGETV BINDEVALAUX BINDEVAL LBIND1 GET COMPILEDCALLINGINTERPRETEDAUXAUX !*LAMBDALINK EVPROGN UNBINDN SYS2INT PLUS2 MINUS ELSE ADD1 SUB1 GREATERP LESSP DIFFERENCE TIMES2 CAAAR CAAAAR CAAADR CAADR CAADAR CAADDR CADAR CADAAR CADADR CADDR CADDAR CADDDR CDAAR CDAAAR CDAADR CDADR CDADAR CDADDR CDDAR CDDAAR CDDADR CDDDR CDDDAR CDDDDR CAAR CADR CDAR CDDR SAFECAR CAR CDR ATOM CONSTANTP NULL LIST PUTD DE EXPR DF FEXPR DN NEXPR DM MACRO SET SETQ PROGN EVCOND COND NOT APPEND MEMQ REVERSE EVLIS ATSOC GEQ LEQ EQCAR GETD COPYD DELATQ PUT INITEVAL WHILE TYPE LAMBDAP GETLAMBDA LAMBDAEVALAPPLY GETFNTYPE LAMBDAAPPLY APPLY DOLAMBDA LENGTH CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP RPLACA RPLACD LENGTH1 FLUID FLUIDP GLOBAL GLOBALP UNFLUID PROP REMPROP SYS2FIXN RESET BSTACKOVERFLOW ERROUT!* BSTACKUNDERFLOW CAPTUREENVIRONMENT RESTOREENVIRONMENT !%CLEAR!-CATCH!-STACK CLEARBINDINGS PBIND1 LAMBIND LAMBINDARGS!* PROGBIND CODE!-NUMBER!-OF!-ARGUMENTS SYSCLEARIO DEC20OPEN CONTOPENERROR SYSOPENREAD INPUT SYSOPENWRITE OUTPUT DEC20READCHAR SYSREADREC IOERROR DEC20WRITECHAR SYSWRITEREC SYSCLOSE CHANNELERROR SYSMAXBUFFER TERMINALINPUTHANDLER WRITEONLYCHANNEL COMPRESSREADCHAR CHANNELNOTOPEN READONLYCHANNEL TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR ILLEGALSTANDARDCHANNELCLOSE !$EOL!$ RDS WRS OPEN CLOSE TYPEFILE DSKIN !$EOF!$ !*PVAL !*ECHO LAPIN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT INDEPENDENTCLOSECHANNEL IN!* STDIN!* STDOUT!* PROMPTOUT!* FINDFREECHANNEL IOBUFFER INDEPENDENTREADCHAR SYSTEMOPENFILESPECIAL TESTLEGALCHANNEL FLUSHBUFFER SYSTEMMARKASCLOSEDCHANNEL CLEARONECHANNEL CLEARIO CHANNELWRITESTRING PROMPTSTRING!* BEFOREGCSYSTEMHOOK AFTERGCSYSTEMHOOK !*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL TIMC MARKFROMALLBASES MAKEIDFREELIST BUILDRELOCATIONFIELDS UPDATEALLBASES COMPACTHEAP GCMESSAGE KNOWN!-FREE!-SPACE CONTINUABLEERROR MARKFROMSYMBOLS MARKFROMRANGE MARKFROMBASE MARKFROMONESYMBOL HALFWORD MARKFROMVECTOR GCERROR UPDATESYMBOLS UPDATEREGION UPDATEITEM UPDATEHEAP !&!&VALUE!&!& THROWTAG!* CATCH!-ALL CATCH THROWSIGNAL!* AND UNWIND!-ALL !&!&THROWN!&!& !$UNWIND!-PROTECT!$ !&!&TAG!&!& !%THROW UNWIND!-PROTECT CATCHSETUP !%UNCATCH !*CATCH THROW !*THROW EMSG!* THROWAUX FINDCATCHMARKANDTHROW MKQUOTE !$ERROR!$ PROG PROGBODY!* PROGJUMPTABLE!* !$PROG!$ GO RETURN FREERSTRSAVE!*))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 514)) (SETQ STRINGGENSYM!* (QUOTE "L2289")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE PRINT1FEXPR) (QUOTE ENTRYPOINT) (QUOTE "L0285")) (PUT (QUOTE PRINT1FEXPR) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE THROWSIGNAL!*) (QUOTE IDNUMBER) (QUOTE 489)) (FLAG (QUOTE (THROWSIGNAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE READINT) (QUOTE ENTRYPOINT) (QUOTE "L0212")) (PUT (QUOTE READINT) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE SYMFNCBASE) (QUOTE ENTRYPOINT) (QUOTE "L0315")) (PUT (QUOTE SYMFNCBASE) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1340")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1455")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE MAXBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1451")) (PUT (QUOTE MAXBUFFER) (QUOTE WARRAY) (QUOTE MAXBUFFER)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L0147")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L1490")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L0319")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE SYSOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L1415")) (PUT (QUOTE SYSOPENWRITE) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L0078")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE ARG14) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG14) (QUOTE ASMSYMBOL) (QUOTE ARG14)) (PUT (QUOTE ARG14) (QUOTE WVAR) (QUOTE ARG14)) (PUT (QUOTE SYMFNC) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE PRIN2ID) (QUOTE ENTRYPOINT) (QUOTE "L0028")) (PUT (QUOTE PRIN2ID) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE ENTRYPOINT) (QUOTE "L1779")) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE LAMBINDARGS!*) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE INITEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0685")) (PUT (QUOTE INITEVAL) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE TOK!*) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE LAMBIND) (QUOTE ENTRYPOINT) (QUOTE "L1363")) (PUT (QUOTE LAMBIND) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE ARG10) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG10) (QUOTE ASMSYMBOL) (QUOTE ARG10)) (PUT (QUOTE ARG10) (QUOTE WVAR) (QUOTE ARG10)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L0779")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE !$PROG!$) (QUOTE IDNUMBER) (QUOTE 510)) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0749")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE !*THROW) (QUOTE ENTRYPOINT) (QUOTE "L1767")) (PUT (QUOTE !*THROW) (QUOTE IDNUMBER) (QUOTE 501)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0625")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE LONGDIV) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE GCARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE GCARRAY) (QUOTE ASMSYMBOL) (QUOTE "L1542")) (PUT (QUOTE GCARRAY) (QUOTE WARRAY) (QUOTE GCARRAY)) (PUT (QUOTE WHITEP) (QUOTE ENTRYPOINT) (QUOTE WHITEP)) (PUT (QUOTE WHITEP) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1444")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L0349")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE IDNUMBER) (QUOTE 472)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 436)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE PROMPTOUT!*) (QUOTE IDNUMBER) (QUOTE 447)) (PUT (QUOTE PROMPTOUT!*) (QUOTE INITIALVALUE) (QUOTE 6)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1564")) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE WTIMES2) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE CLEARWHITE) (QUOTE ENTRYPOINT) (QUOTE "L0206")) (PUT (QUOTE CLEARWHITE) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE GCERROR) (QUOTE ENTRYPOINT) (QUOTE "L1708")) (PUT (QUOTE GCERROR) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE CODEPRIMITIVE) (QUOTE ENTRYPOINT) (QUOTE "L0353")) (PUT (QUOTE CODEPRIMITIVE) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE PRIN2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE PRIN2STRING) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE ENTRYPOINT) (QUOTE "L0430")) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUX) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE ENTRYPOINT) (QUOTE "L0437") ) (PUT (QUOTE COMPILEDCALLINGINTERPRETEDAUXAUX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE SYSCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1440")) (PUT (QUOTE SYSCLOSE) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1502")) (PUT (QUOTE INDEPENDENTREADCHAR) (QUOTE IDNUMBER) (QUOTE 450)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0136")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE SYSREADREC) (QUOTE ENTRYPOINT) (QUOTE "L1420")) (PUT (QUOTE SYSREADREC) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0369")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE READSTR) (QUOTE ENTRYPOINT) (QUOTE "L0221")) (PUT (QUOTE READSTR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L0062")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L0138")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0141")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L0058")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L1352")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0137")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0583")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE SYSWRITEREC) (QUOTE ENTRYPOINT) (QUOTE "L1432")) (PUT (QUOTE SYSWRITEREC) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE MARKFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1557")) (PUT (QUOTE MARKFROMALLBASES) (QUOTE IDNUMBER) (QUOTE 466)) (PUT (QUOTE PUTBYTE) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE IOBUFFER) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE !%STORE!-JCALL) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE UPDATEREGION) (QUOTE ENTRYPOINT) (QUOTE "L1646")) (PUT (QUOTE UPDATEREGION) (QUOTE IDNUMBER) (QUOTE 482)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L0149")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE THROWAUX) (QUOTE ENTRYPOINT) (QUOTE "L1783")) (PUT (QUOTE THROWAUX) (QUOTE IDNUMBER) (QUOTE 503)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0140")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE !%THROW) (QUOTE ENTRYPOINT) (QUOTE !%THROW)) (PUT (QUOTE !%THROW) (QUOTE IDNUMBER) (QUOTE 495)) (PUT (QUOTE ALPHANUMP) (QUOTE ENTRYPOINT) (QUOTE "L0254")) (PUT (QUOTE ALPHANUMP) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0805")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE ALPHANUMESCP) (QUOTE ENTRYPOINT) (QUOTE "L0256")) (PUT (QUOTE ALPHANUMESCP) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CODEFORM!*) (QUOTE IDNUMBER) (QUOTE 270)) (FLAG (QUOTE (CODEFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CODEARGS) (QUOTE ASMSYMBOL) (QUOTE "L0363")) (PUT (QUOTE CODEARGS) (QUOTE WARRAY) (QUOTE CODEARGS)) (PUT (QUOTE ALPHAP) (QUOTE ENTRYPOINT) (QUOTE ALPHAP)) (PUT (QUOTE ALPHAP) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE LONGTIMES) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE BITSPERWORD) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BITSPERWORD) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BITSPERWORD) (QUOTE WCONST) (QUOTE 36)) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0150")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE !$UNWIND!-PROTECT!$) (QUOTE IDNUMBER) (QUOTE 493)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0079")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE PROG) (QUOTE ENTRYPOINT) (QUOTE PROG)) (PUT (QUOTE PROG) (QUOTE IDNUMBER) (QUOTE 507)) (PUT (QUOTE ERRORHEADER) (QUOTE ENTRYPOINT) (QUOTE "L0065")) (PUT (QUOTE ERRORHEADER) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE ARG13) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG13) (QUOTE ASMSYMBOL) (QUOTE ARG13)) (PUT (QUOTE ARG13) (QUOTE WVAR) (QUOTE ARG13)) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 800)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0120")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE !*PVAL) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*PVAL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SYSCLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1410")) (PUT (QUOTE SYSCLEARIO) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE PRIN2PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0045")) (PUT (QUOTE PRIN2PAIR) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE SAVEREGISTERS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE SAVEREGISTERS) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE ARG9) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG9) (QUOTE ASMSYMBOL) (QUOTE ARG9)) (PUT (QUOTE ARG9) (QUOTE WVAR) (QUOTE ARG9)) (PUT (QUOTE CHANNELSTATUS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELSTATUS) (QUOTE ASMSYMBOL) (QUOTE "L1450")) (PUT (QUOTE CHANNELSTATUS) (QUOTE WARRAY) (QUOTE CHANNELSTATUS)) (PUT (QUOTE MKQUOTE) (QUOTE ENTRYPOINT) (QUOTE "L2225")) (PUT (QUOTE MKQUOTE) (QUOTE IDNUMBER) (QUOTE 505)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE !&!&VALUE!&!&) (QUOTE IDNUMBER) (QUOTE 485)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L0791")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L0292")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L0419")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE ENTRYPOINT) (QUOTE "L1612")) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L0167")) (PUT (QUOTE HARDCONS) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE UPDATEITEM) (QUOTE ENTRYPOINT) (QUOTE "L1677")) (PUT (QUOTE UPDATEITEM) (QUOTE IDNUMBER) (QUOTE 483)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE ARG7) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG7) (QUOTE ASMSYMBOL) (QUOTE ARG7)) (PUT (QUOTE ARG7) (QUOTE WVAR) (QUOTE ARG7)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L0055")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE THROW) (QUOTE ENTRYPOINT) (QUOTE THROW)) (PUT (QUOTE THROW) (QUOTE IDNUMBER) (QUOTE 500)) (PUT (QUOTE NEXTPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1453")) (PUT (QUOTE NEXTPOSITION) (QUOTE WARRAY) (QUOTE NEXTPOSITION)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0752")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE INITIALVALUE) (QUOTE 1000)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0165")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE CH!*) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE HALFWORD) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0086")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE ELSE) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE ARG5) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG5) (QUOTE ASMSYMBOL) (QUOTE ARG5)) (PUT (QUOTE ARG5) (QUOTE WVAR) (QUOTE ARG5)) (PUT (QUOTE ADDRESSINGUNITSPERFUNCTIONCELL) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE MARKFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1580")) (PUT (QUOTE MARKFROMBASE) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE UPPERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0242")) (PUT (QUOTE UPPERCASEP) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0129")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE LOOKUPSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0273")) (PUT (QUOTE LOOKUPSTRING) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L0102")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L0265")) (PUT (QUOTE INITNEWID) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE MARKFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1573")) (PUT (QUOTE MARKFROMRANGE) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE UPDATESYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1641")) (PUT (QUOTE UPDATESYMBOLS) (QUOTE IDNUMBER) (QUOTE 481)) (PUT (QUOTE GCMESSAGE) (QUOTE ENTRYPOINT) (QUOTE "L1714")) (PUT (QUOTE GCMESSAGE) (QUOTE IDNUMBER) (QUOTE 471)) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE CODEPRIMITIVEWGETV) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 437)) (PUT (QUOTE DIGITP) (QUOTE ENTRYPOINT) (QUOTE DIGITP)) (PUT (QUOTE DIGITP) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE ARG3) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG3) (QUOTE ASMSYMBOL) (QUOTE ARG3)) (PUT (QUOTE ARG3) (QUOTE WVAR) (QUOTE ARG3)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0114")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1341")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0359")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE PROGBIND) (QUOTE ENTRYPOINT) (QUOTE "L1366")) (PUT (QUOTE PROGBIND) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1511")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0006")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE HEAPTRAPPED) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPPED) (QUOTE ASMSYMBOL) (QUOTE "L1541")) (PUT (QUOTE HEAPTRAPPED) (QUOTE WVAR) (QUOTE HEAPTRAPPED)) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE SHOULDBEUNDEFINED) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE SYSOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L1412")) (PUT (QUOTE SYSOPENREAD) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE ARG1) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG1) (QUOTE ASMSYMBOL) (QUOTE ARG1)) (PUT (QUOTE ARG1) (QUOTE WVAR) (QUOTE ARG1)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0772")) (PUT (QUOTE LENGTH1) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE !*CATCH) (QUOTE ENTRYPOINT) (QUOTE "L1766")) (PUT (QUOTE !*CATCH) (QUOTE IDNUMBER) (QUOTE 499)) (PUT (QUOTE GETC) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0117")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0719")) (PUT (QUOTE LAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE !%UNCATCH) (QUOTE ENTRYPOINT) (QUOTE "L1778")) (PUT (QUOTE !%UNCATCH) (QUOTE IDNUMBER) (QUOTE 498)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L0126")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L0465")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE FLUSHBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1509")) (PUT (QUOTE FLUSHBUFFER) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE WQUOTIENT) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0097")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE CHANNELTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CHANNELTABLE) (QUOTE ASMSYMBOL) (QUOTE "L1452")) (PUT (QUOTE CHANNELTABLE) (QUOTE WARRAY) (QUOTE CHANNELTABLE)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE PRIN1INTX) (QUOTE ENTRYPOINT) (QUOTE "L0024")) (PUT (QUOTE PRIN1INTX) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE PRINT1FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0289")) (PUT (QUOTE PRINT1FUNCTION) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE ARG12) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG12) (QUOTE ASMSYMBOL) (QUOTE ARG12)) (PUT (QUOTE ARG12) (QUOTE WVAR) (QUOTE ARG12)) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L1495")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L0123")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE !$ERROR!$) (QUOTE IDNUMBER) (QUOTE 506)) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1512")) (PUT (QUOTE INDEPENDENTCLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 443)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L1526")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE GO) (QUOTE ENTRYPOINT) (QUOTE GO)) (PUT (QUOTE GO) (QUOTE IDNUMBER) (QUOTE 511)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 446)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE ASMSYMBOL) (QUOTE "L0139")) (PUT (QUOTE HEAPPREVIOUSLAST) (QUOTE WVAR) (QUOTE HEAPPREVIOUSLAST)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1483")) (PUT (QUOTE FINDFREECHANNEL) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE !&!&TAG!&!&) (QUOTE IDNUMBER) (QUOTE 494)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE EMSG!*) (QUOTE IDNUMBER) (QUOTE 502)) (FLAG (QUOTE (EMSG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1506")) (PUT (QUOTE INDEPENDENTWRITECHAR) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE PRIN1PAIR) (QUOTE ENTRYPOINT) (QUOTE "L0037")) (PUT (QUOTE PRIN1PAIR) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PROGBODY!*) (QUOTE IDNUMBER) (QUOTE 508)) (FLAG (QUOTE (PROGBODY!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE ENTRYPOINT) (QUOTE "L1763")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE IDNUMBER) (QUOTE 496)) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0588")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L0324")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0005")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE !%COPY!-FUNCTION!-CELL) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE "L0151")) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE CODENARG!*) (QUOTE IDNUMBER) (QUOTE 271)) (FLAG (QUOTE (CODENARG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE AFTERGCSYSTEMHOOK) (QUOTE ENTRYPOINT) (QUOTE "L1539")) (PUT (QUOTE AFTERGCSYSTEMHOOK) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1445")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE CLEARONECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1514")) (PUT (QUOTE CLEARONECHANNEL) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L1407")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE BEFOREGCSYSTEMHOOK) (QUOTE ENTRYPOINT) (QUOTE "L1534")) (PUT (QUOTE BEFOREGCSYSTEMHOOK) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L0162")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L1436")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE ALPHAESCP) (QUOTE ENTRYPOINT) (QUOTE "L0252")) (PUT (QUOTE ALPHAESCP) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE SYSMAXBUFFER) (QUOTE ENTRYPOINT) (QUOTE "L1442")) (PUT (QUOTE SYSMAXBUFFER) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1349")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE PUTHALFWORD) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE BUFFERLENGTH) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BUFFERLENGTH) (QUOTE ASMSYMBOL) (QUOTE "L1454")) (PUT (QUOTE BUFFERLENGTH) (QUOTE WARRAY) (QUOTE BUFFERLENGTH)) (PUT (QUOTE MARKFROMVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1592")) (PUT (QUOTE MARKFROMVECTOR) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE LOWERCASEP) (QUOTE ENTRYPOINT) (QUOTE "L0246")) (PUT (QUOTE LOWERCASEP) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE PRTITM) (QUOTE ENTRYPOINT) (QUOTE PRTITM)) (PUT (QUOTE PRTITM) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L1348")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L0796")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE GETLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0736")) (PUT (QUOTE GETLAMBDA) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1344")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1447")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE BYTE) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE ENTRYPOINT) (QUOTE "L0288")) (PUT (QUOTE PRINTFUNCTIONS) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE PRIN1INT) (QUOTE ENTRYPOINT) (QUOTE "L0020")) (PUT (QUOTE PRIN1INT) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L1448")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L1443")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE LAMBDAP) (QUOTE ENTRYPOINT) (QUOTE "L0730")) (PUT (QUOTE LAMBDAP) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE ENTRYPOINT) (QUOTE "L0396")) (PUT (QUOTE CODEEVALAPPLYAUX) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0809")) (PUT (QUOTE SYS2FIXN) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE CATCH) (QUOTE ENTRYPOINT) (QUOTE CATCH)) (PUT (QUOTE CATCH) (QUOTE IDNUMBER) (QUOTE 488)) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE DOLAMBDA) (QUOTE ENTRYPOINT) (QUOTE "L0723")) (PUT (QUOTE DOLAMBDA) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1553")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L1347")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE INITREAD) (QUOTE ENTRYPOINT) (QUOTE "L0197")) (PUT (QUOTE INITREAD) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE AND) (QUOTE IDNUMBER) (QUOTE 490)) (PUT (QUOTE TYPEFILE) (QUOTE ENTRYPOINT) (QUOTE "L1462")) (PUT (QUOTE TYPEFILE) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L0333")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE !&!&THROWN!&!&) (QUOTE IDNUMBER) (QUOTE 492)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L1427")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE PRINTFEXPRS) (QUOTE ENTRYPOINT) (QUOTE "L0284")) (PUT (QUOTE PRINTFEXPRS) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE UNWIND!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1739")) (PUT (QUOTE UNWIND!-ALL) (QUOTE IDNUMBER) (QUOTE 491)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L0135")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE PRIN1ID) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE PRIN1ID) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0720")) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L0431")) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L1449")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE WPLUS2) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE ENTRYPOINT) (QUOTE "L0365")) (PUT (QUOTE UNDEFINEDFUNCTIONAUX) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE ARG15) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG15) (QUOTE ASMSYMBOL) (QUOTE ARG15)) (PUT (QUOTE ARG15) (QUOTE WVAR) (QUOTE ARG15)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L0142")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0184")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE LONGREMAINDER) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE UPDATEALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1635")) (PUT (QUOTE UPDATEALLBASES) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0611")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE THROWTAG!*) (QUOTE IDNUMBER) (QUOTE 486)) (FLAG (QUOTE (THROWTAG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0004")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE ERRORTRAILER) (QUOTE ENTRYPOINT) (QUOTE "L0067")) (PUT (QUOTE ERRORTRAILER) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE ARG11) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG11) (QUOTE ASMSYMBOL) (QUOTE ARG11)) (PUT (QUOTE ARG11) (QUOTE WVAR) (QUOTE ARG11)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L0477")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE ARG8) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG8) (QUOTE ASMSYMBOL) (QUOTE ARG8)) (PUT (QUOTE ARG8) (QUOTE WVAR) (QUOTE ARG8)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0007")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L0132")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE BINDEVALAUX) (QUOTE ENTRYPOINT) (QUOTE "L0423")) (PUT (QUOTE BINDEVALAUX) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L1446")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE ENTRYPOINT) (QUOTE "L1784")) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE IDNUMBER) (QUOTE 504)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE READ1) (QUOTE ENTRYPOINT) (QUOTE READ1)) (PUT (QUOTE READ1) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE CATCHSETUPAUX) (QUOTE ENTRYPOINT) (QUOTE "L1771")) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE SETRAISE) (QUOTE ENTRYPOINT) (QUOTE "L0199")) (PUT (QUOTE SETRAISE) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE READID) (QUOTE ENTRYPOINT) (QUOTE READID)) (PUT (QUOTE READID) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE PRIN1STRING) (QUOTE ENTRYPOINT) (QUOTE "L0029")) (PUT (QUOTE PRIN1STRING) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE FREERSTRSAVE!*) (QUOTE IDNUMBER) (QUOTE 513)) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L1353")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE ARG6) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG6) (QUOTE ASMSYMBOL) (QUOTE ARG6)) (PUT (QUOTE ARG6) (QUOTE WVAR) (QUOTE ARG6)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L0105")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0645")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L0328")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE PROGJUMPTABLE!*) (QUOTE IDNUMBER) (QUOTE 509)) (FLAG (QUOTE (PROGJUMPTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1548")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE BUFFERTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0216")) (PUT (QUOTE BUFFERTOSTRING) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L0108")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE PBLANK) (QUOTE ENTRYPOINT) (QUOTE PBLANK)) (PUT (QUOTE PBLANK) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE ARG4) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG4) (QUOTE ASMSYMBOL) (QUOTE ARG4)) (PUT (QUOTE ARG4) (QUOTE WVAR) (QUOTE ARG4)) (PUT (QUOTE CATCH!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1727")) (PUT (QUOTE CATCH!-ALL) (QUOTE IDNUMBER) (QUOTE 487)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L1494")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE CATCHSETUP) (QUOTE ENTRYPOINT) (QUOTE "L1770")) (PUT (QUOTE CATCHSETUP) (QUOTE IDNUMBER) (QUOTE 497)) (PUT (QUOTE ESCAPEP) (QUOTE ENTRYPOINT) (QUOTE "L0250")) (PUT (QUOTE ESCAPEP) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L1460")) (PUT (QUOTE CONTOPENERROR) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L0344")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L0777")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1339")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1498")) (PUT (QUOTE TESTLEGALCHANNEL) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE UPDATEHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1656")) (PUT (QUOTE UPDATEHEAP) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE ARG2) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARG2) (QUOTE ASMSYMBOL) (QUOTE ARG2)) (PUT (QUOTE ARG2) (QUOTE WVAR) (QUOTE ARG2)) (PUT (QUOTE RETURN) (QUOTE ENTRYPOINT) (QUOTE RETURN)) (PUT (QUOTE RETURN) (QUOTE IDNUMBER) (QUOTE 512)) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1597")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE IDNUMBER) (QUOTE 467)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE READLIST) (QUOTE ENTRYPOINT) (QUOTE "L0304")) (PUT (QUOTE READLIST) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE CODEPTR!*) (QUOTE IDNUMBER) (QUOTE 268)) (FLAG (QUOTE (CODEPTR!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNDEFINEDFUNCTIONAUXAUX) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L1417")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE COMPACTHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1688")) (PUT (QUOTE COMPACTHEAP) (QUOTE IDNUMBER) (QUOTE 470)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE RAISECHAR) (QUOTE ENTRYPOINT) (QUOTE "L0227")) (PUT (QUOTE RAISECHAR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE ENTRYPOINT) (QUOTE "L1572")) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE CLEARCOMMENT) (QUOTE ENTRYPOINT) (QUOTE "L0209")) (PUT (QUOTE CLEARCOMMENT) (QUOTE IDNUMBER) (QUOTE 216)) |
Added psl-1983/3-1/tests/20/mini-known-to-comp-sl.red version [27946b048f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-KNOWN-TO-COMP-SL.RED Procedure Car x; if Pairp x then car x else NonPairError(x,'CAR); Procedure Cdr x; if Pairp x then cdr x else NonPairError(x,'CDR); procedure CodeP x; CodeP x; Procedure Pairp x; Pairp x; Procedure Idp x; Idp x; procedure Eq(x,y); eq(x,y); procedure Null x; x eq 'NIL; procedure Not x; x eq 'NIL; End; |
Added psl-1983/3-1/tests/20/module.mic version [c6e726a164].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; independant compilation a program for the 20 ; MIC MODULE modulename,symbolmname @define DSK:, DSK:, PT:, P20:, PI: @delete 'A.mac,'A.rel,'A.init @delete D'A.mac,D'A.rel @exp ;avoid obnoixous ^Q halts... @terminal length 0 @get s:TEST-DEC20-cross @st off break; %kill obnoxious break loops off USERMODE ; InputSymFile!* := "'B.sym"$ OutputSymFile!* := "'B.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''NIL; ModName!*:='''A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @reset . @terminal length 24 @get sys:macro.exe @st *'A.rel='A.mac *D'A.rel=D'A.mac @reset . |
Added psl-1983/3-1/tests/20/p version [9fb4669c27].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (de errorprintf(a1 a2 a3 a4 a5) (prin2 a1) (prin2 " ") (prin2 a2) (prin2 " ") (prin2 a3) (prin2 " ") (prin2 a4) (prin2 " ") (prin2t a5)) (setq knt 0) (df tr (z) (setq old (car z)) (setq new (cadr z)) (setq args (cddr z)) (copyd new old) (putd old 'expr (list 'lambda args '(setq knt (add1 knt)) (list 'print (list 'list ">>>>" (list 'quote old) 'knt)) (list 'setq 'ans (cons new args)) (list 'print (list 'list " <" (list 'quote old) 'knt)) '(setq knt (sub1 knt)) 'ans))) (df m (z) (setq old (car z)) (setq new (cadr z)) (setq args (cddr z)) (copyd new old) (print (list old (inf old))) (putd old 'expr (list 'lambda args (list 'print (list 'inf old)) (cons new args)))) |
Added psl-1983/3-1/tests/20/pk-red.dir version [b7f05f280d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SS:<PSL.KERNEL> ALLOCATORS.RED.4 ARITHMETIC.RED.2 AUTOLOAD.RED.3 AUTOLOAD-TRACE.RED.7 BACKTRACE.RED.18 BINDING.RED.2 BREAK.RED.4 CARCDR.RED.1 CATCH-THROW.RED.14 CHAR-IO.RED.2,3 COMP-SUPPORT.RED.1 COMPACTING-GC.RED.9 CONS-MKVECT.RED.2 CONT-ERROR.RED.1 COPIERS.RED.2 COPYING-GC.RED.9 DEFCONST.RED.1 DEFINE-SMACRO.RED.3 DSKIN.RED.3 EASY-NON-SL.RED.5 EASY-SL.RED.3 EQUAL.RED.2 ERROR-ERRORSET.RED.5 ERROR-HANDLERS.RED.4 EVAL-APPLY.RED.5 EVAL-WHEN.RED.1 EXPLODE-COMPRESS.RED.3 FASL-INCLUDE.RED.1 FASLIN.RED.2 FAST-BINDER.RED.1 FLUID-GLOBAL.RED.1 IO-ERRORS.RED.1 IO-EXTENSIONS.RED.1 KNOWN-TO-COMP-SL.RED.1 LISP-MACROS.RED.1 LOAD.RED.12 LOOP-MACROS.RED.1 MINI-EDITOR.RED.3 MINI-TRACE.RED.2 OBLIST.RED.3 OLD-STRING-GENSYM.RED.1 ONOFF.RED.1 OPEN-CLOSE.RED.1,2 OTHER-IO.RED.5 OTHERS-SL.RED.1 P-APPLY-LAP.RED.1 PRINTERS.RED.15 PRINTF.RED.3 PROG-AND-FRIENDS.RED.2 PROPERTY-LIST.RED.1 PUTD-GETD.RED.3 RDS-WRS.RED.1 READ.RED.6 SEQUENCE.RED.2 SETS.RED.1 STRING-GENSYM.RED.2 SYMBOL-VALUES.RED.1 TOKEN-SCANNER.RED.4 TOP-LOOP.RED.12 TYPE-CONVERSIONS.RED.1 TYPE-ERRORS.RED.1,3 VECTORS.RED.2 Total of 140 pages in 65 files |
Added psl-1983/3-1/tests/20/program.mic version [ba18a745a9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independent compilation a program for the 20 ;; MAIN module and data_segement, do last ; do PROGRAM modulename ; modulename=symboltablename @define DSK:, DSK:, PT:, P20:, PV:, PI: @delete 'A.mac,'A.rel,'A.init @delete D'A.mac,D'A.rel @exp ;avoid obnoixous ^Q halts... @terminal length 0 @get s:TEST-DEC20-CROSS.EXE @st off break; % avoid obnoxios breaks InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''T; ModName!*:='' 'A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @reset . @terminal length 24 @get sys:macro @st *'A.rel='A.mac *D'A.rel=D'A.mac @reset . |
Added psl-1983/3-1/tests/20/rand-psl.times version [34acba8be5].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | RAND-RELAY (VAX 11/750-1Mb) RAND-UNIX (VAX 11/780 4Mb ) *** GC 5: time 1122 ms, EmptyTest 10000 85 0 SlowEmptyTest 10000 1122 663 Cdr1Test 100 2074 1632 Cdr2Test 100 1598 1224 CddrTest 100 1326 1071 ListOnlyCdrTest1 9435 7208 ListOnlyCddrTest1 15283 12410 ListOnlyCdrTest2 12189 9418 ListOnlyCddrTest2 18105 15164 ReverseTest 10 1054 748 *** GC 6: time 1139 ms, 782 ms, MyReverse1Test 10 1156 697 *** GC 7: time 1224 ms, 646ms MyReverse2Test 10 1003 629 *** GC 8: time 1190 ms, 765 ms LengthTest 100 2210 1700 ArithmeticTest 10000 1938 867 EvalTest 10000 8687 5083 tak 18 12 6 1326 765 gtak 18 12 6 7361 4267 gtsta g0 5253 2533 gtsta g1 5355 2465 |
Added psl-1983/3-1/tests/20/sub2.init version [a7ffc6f8bf].
Added psl-1983/3-1/tests/20/sub2.rel version [8443994ad3].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub3.init version [a7ffc6f8bf].
Added psl-1983/3-1/tests/20/sub3.rel version [2201d9791d].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub4.init version [a7ffc6f8bf].
Added psl-1983/3-1/tests/20/sub4.rel version [e499edb4b0].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub5a.init version [51d9a35a8b].
> > | 1 2 | (PUT (QUOTE SYMFNCBASE) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (CODEPTR!* CODEFORM!* CODENARG!*))) |
Added psl-1983/3-1/tests/20/sub5a.rel version [8849f85475].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub5b.init version [4ba4b10519].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (PUT (QUOTE LIST) (QUOTE TYPE) (QUOTE NEXPR)) (PUT (QUOTE DE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DF) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE DM) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE SETQ) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE COND) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE WHILE) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/3-1/tests/20/sub5b.rel version [b816aa1833].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub6.init version [a7ffc6f8bf].
Added psl-1983/3-1/tests/20/sub6.rel version [b72a478cd4].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub7.init version [bf984f29e8].
> > > > > | 1 2 3 4 5 | (GLOBAL (QUOTE (!$EOL!$))) (FLUID (QUOTE (!*ECHO !*PVAL))) (FLUID (QUOTE (IN!* OUT!*))) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!* ERROUT!* PROMPTOUT!* !*ECHO))) |
Added psl-1983/3-1/tests/20/sub7.rel version [816c66a070].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub8.init version [59f4b945b6].
> > > | 1 2 3 | (PUT (QUOTE BEFOREGCSYSTEMHOOK) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE AFTERGCSYSTEMHOOK) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (!*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL))) |
Added psl-1983/3-1/tests/20/sub8.rel version [94564d109f].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/sub9.init version [d64fcdb267].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (FLUID (QUOTE (THROWSIGNAL!* THROWTAG!*))) (GLOBAL (QUOTE (EMSG!*))) (PUT (QUOTE CATCH!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CATCH) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !*CATCH) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (PROGJUMPTABLE!* PROGBODY!*))) (PUT (QUOTE PROG) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE GO) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/3-1/tests/20/sub9.rel version [348a4778bb].
cannot compute difference between binary files
Added psl-1983/3-1/tests/20/test-dec20-cross.mic version [a2007e334d].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | @ren home:rlisp.init home:saved-rlisp.init @get PSL:RLISP @st *Options!* := nil; % Force reload *load(zboot, syslisp, if!-system, lap!-to!-asm); *load(dec20!-comp,dec20!-cmac,dec20!-asm); *remflag(''(extrareg),''terminaloperand); *off usermode; *in "p20t:dec20-patches.sl"$ *Date!* := concat("Dec 20 cross compiler",date()); *Dumplisp "S:TEST-DEC20-CROSS.EXE"; *Quit; @reset . @ren home:saved-rlisp.init home:rlisp.init |
Added psl-1983/3-1/tests/20/test-guide.err version [689c76ff59].
> > > > > | 1 2 3 4 5 | @Comment{ErrLog of TEST-GUIDE.MSS.17 by Scribe 3C(1254) on 24 July 1982 at 13:19} Error in MAINN command found while processing the manuscript. TEST-GUIDE.MSS.17 line 287: @@EX @MAINn.CMD The name @MAINN is not defined in document type article. |
Added psl-1983/3-1/tests/20/test-guide.otl version [312ccb6cab].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @Comment{OUTLINE of TEST-GUIDE.MSS.17 by Scribe 3C(1254) on 24 July 1982 at 13:19} 1. Introduction 1 TEST-GUIDE.MSS.17 line 51 2. Basic I/O Support 1 TEST-GUIDE.MSS.17 line 64 3. LAP and CMACRO Tests 4 TEST-GUIDE.MSS.17 line 181 4. SysLisp Tests 4 TEST-GUIDE.MSS.17 line 189 5. Mini PSL Tests 7 TEST-GUIDE.MSS.17 line 295 6. Full PSL Tests 7 TEST-GUIDE.MSS.17 line 306 7. References 8 TEST-GUIDE.MSS.17 line 322 I. Sample DEC-20 Output 9 TEST-GUIDE.MSS.17 line 325 Table of Contents 1 <PSL.TESTS.20>-SCRIBE-SCRATCH-.15-3-1.100015 line 3 |
Added psl-1983/3-1/tests/20/time-psl.out version [fe95d23655].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Spectral Tests, DEC-20 test system, No-Date-Yet --------------------------------------------------------------- *** Dummy RECLAIM: 9772 Items used, 140228 Items left. EmptyTest 10000 18 SlowEmptyTest 10000 187 Cdr1Test 100 521 Cdr2Test 100 365 CddrTest 100 268 ListOnlyCdrTest1 1764 ListOnlyCddrTest1 3207 ListOnlyCdrTest2 2708 ListOnlyCddrTest2 4127 ReverseTest 10 458 *** Dummy RECLAIM: 46868 Items used, 103132 Items left. MyReverse1Test 10 463 *** Dummy RECLAIM: 83532 Items used, 66468 Items left. MyReverse2Test 10 447 *** Dummy RECLAIM: 120196 Items used, 29804 Items left. LengthTest 100 554 ArithmeticTest 10000 644 EvalTest 10000 2680 tak 18 12 6 477 gtak 18 12 6 1378 gtsta g0 1133 gtsta g1 1196 |
Added psl-1983/3-1/tests/20/time-psl.out8 version [835ef26baf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Spectral Tests, DEC-20 test system, No-Date-Yet, test8 --------------------------------------------------------------- *** Garbage collection starting NIL 3191 193 69 *** GC %w: time %d ms 2 489 18 6 *** %d recovered, %d stable, %d active, %d free 204 157 9413 1 EmptyTest 10000 18 SlowEmptyTest 10000 187 Cdr1Test 100 527 Cdr2Test 100 372 CddrTest 100 274 ListOnlyCdrTest1 1769 ListOnlyCddrTest1 3194 ListOnlyCdrTest2 2790 ListOnlyCddrTest2 4083 ReverseTest 10 458 *** Garbage collection starting NIL 3191 193 77 *** GC %w: time %d ms 3 1071 5669 5656 *** %d recovered, %d stable, %d active, %d free 37096 9533 37 1 MyReverse1Test 10 458 *** Garbage collection starting NIL 3191 193 77 *** GC %w: time %d ms 4 1064 5237 5224 *** %d recovered, %d stable, %d active, %d free 36664 9533 37 1 MyReverse2Test 10 441 *** Garbage collection starting NIL 3191 193 76 *** GC %w: time %d ms 5 1063 5237 5224 *** %d recovered, %d stable, %d active, %d free 36664 9533 37 1 LengthTest 100 560 ArithmeticTest 10000 643 EvalTest 10000 2434 tak 18 12 6 476 gtak 18 12 6 1378 gtsta g0 1132 gtsta g1 1195 |
Added psl-1983/3-1/tests/20/xxx-gc.red version [60b9faf04c].
> > > > > | 1 2 3 4 5 | % XXX-GC.RED for 20 IN "XXX-SYSTEM-GC.RED"$ IN "PT:P-COMP-GC.RED"$ END; |
Added psl-1983/3-1/tests/20/xxx-header.red version [da08f7123d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % XXX-HEADER.RED for DEC20 % Defines Data spaces, MAIN!. for 20 and I/O interface % % Revisions: MLG, 18 Feb 1983 % Move HEAP declarations from PT:SUB3 % and P20T:20-TEST-GLOBAL-DATA.RED % Add dummy DATE and VersionName routines on syslisp; % -----Allocate the stack area Internal WConst StackSize = 5000; Internal WArray Stack[StackSize]; exported WVar StackLowerBound = &Stack[0], StackUpperBound = &Stack[StackSize]; external WVar ST; %--- Allocate HEAP and BPS areas Internal Wconst HeapSize = 150000; % Enough for PSL-TIMER Internal Warray HEAP[HeapSize]; % Could do a Dynamic alloc exported Wvar HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], HeapLast, % next free slot in heap HeapTrapBound, % To catch impending HEAP full HeapPreviousLast; % save start of new block CommentOutcode << % If Copying GC Internal Warray OtherHeap[HeapSize]; exported WVar OldHeapLast, OldHeapLowerBound = &OtherHeap[0]; OldHeapUpperBound = &OtherHeap[HeapSize]; >>; % Stuff for Compacting GC exported Wvar HeapTrapped; internal WConst BitsInsegment=13, GCArraySize = LShift(HeapSize, -BitsInSegment) + 1; exported WArray GCArray[GCArraySize]; Internal Wconst BPSSize = 500; internal Warray BPS[BPSsize]; % Could do a Dynamic alloc exported WVar FirstBPS=&BPS[0], % Base of BPS, for info NextBPS = &BPS[0], % allocate CODE up LastBPS = &BPS[BPSSize], % allocate Warray down FinalBPS= &BPS[BPSSize]; % For info purposes syslsp procedure InitHeap(); % Set up Heap base etc. <<HeapLast:=HeapLowerBound; HeapPreviousLast := 0>>; % allocate for the "extra" arguments % 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1; exported WArray ArgumentBlock[MaxArgBlock]; % For the ForeignFunction calling protocol exported Wvar Arg1,Arg2,Arg3,ARg4,Arg5,Arg6,Arg7,Arg8, Arg9, Arg10,Arg11,Arg12,Arg13,Arg14,Arg15; % The hashtable exported WArray HashTable[MaxObArray/2]; %--- End of Data Definitions ---------- %--- Now do 20 Specific MAIN!. and I/O Interface: lap '((!*entry Main!. expr 0) (reset) (move (reg st) (lit (halfword (minus (WConst StackSize)) (difference (WConst Stack) 1)))) (move (reg NIL) (fluid NIL)) (!*LINKE 0 FirstCall Expr 0) % Call the MAINn firstroutine ); % Define "standard" LISP equivalents for the DEC20-MACRO foreign % functions defined in 20IO.MAC FLAG('( Init20 % Initialize I/O, Timer, etc PutC20 % Print Ascii Character, use 10=EOL to get end of line GetC20 % Return Ascii Character Timc20 % Return CPU time (can also print time check) Quit20 % Terminate execution, finalize Err20 % Print error message PutI20 % print an Integer ),'ForeignFunction); Global '(IN!* OUT!*); Procedure Init(); <<Init20 0; LispVar IN!*:=0; LispVar Out!*:=1; >>; % Always need one dummy argument Procedure GetC(); If LispVar IN!* eq 0 then Getc20 0 % Always need one dummy argument else IndependentReadChar LispVar IN!*; Procedure TimC(); TimC20 0; % Always need one dummy argument procedure PutC x; If LispVar Out!* eq 1 then Putc20 x else IndependentWriteChar(LispVar Out!*,x); procedure Quit; Quit20 0; % always need 1 argument procedure ExitLisp; Quit20 0; Procedure Reset(); <<Prin2T "Should RESET here, but will QUIT"; Quit;>>; procedure Date; '"No-Date-Yet"; Procedure VersionName; '"DEC-20 test system"; procedure PutInt I; PutI20 I; % SYMFNC storage routine: LAP '((!*entry !%Store!-Jcall Expr 2) % CodeAddress, Storage Address (!*alloc 0) (!*WOR (reg 1) 8#254000000000) % Load a JRST in higher-bits (!*MOVE (reg 1) (memory (reg 2) (wconst 0))) (!*EXIT 0)); LAP '((!*entry !%copy!-function!-cell Expr 2) % from to (!*alloc 0) (!*move (memory (reg 1) (Wconst 0)) (memory (reg 2) (wconst 0))) (!*exit 0)); FLUID '(UndefnCode!* UndefnNarg!*); LAP '((!*ENTRY UndefinedFunction expr 0) % For missing Function % No alloc 0 ? and no LINKE because dont want to change LinkReg (!*MOVE (reg LinkReg) (Fluid UndefnCode!*)) (!*Move (reg NargReg) (Fluid UndefnNarg!*)) (!*JCALL UndefinedFunctionAux) ); procedure LongTimes(x,y); x*y; procedure LongDiv(x,y); x/y; procedure LongRemainder(x,y); Remainder(x,y); off syslisp; end; |
Added psl-1983/3-1/tests/20/xxx-system-gc.red version [4305ebeac6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % XXX-SYSTEM-GC.RED - System dependent before and after GC hooks, stubs % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 March 1982 % Copyright (c) 1982 University of Utah % % Do nothing on the Dec-20 on Syslisp; syslsp smacro procedure BeforeGCSystemHook(); NIL; syslsp smacro procedure AfterGCSystemHook(); NIL; off Syslisp; END; |
Added psl-1983/3-1/tests/20/xxx-system-io.red version [d5dae81b3c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %============================================================================== % % PT20:XXX-SYSTEM-IO.RED - 20 specific IO routines for PSL % % Author: Modified by Robert R. Kessler and MLG % From System-io.red for the 20 by Eric Benson % Computer Science Dept. % University of Utah % Date: Modified 16 August 1982 % Original Date 16 September 1981 % % Copyright (c) 1982 University of Utah % %============================================================================== ON Syslisp; % Each individual system must have the following routines defined. % SysClearIo, SysOpenRead, SysOpenWrite, SysReadRec, SysWriteRec, SysClose, % SysMaxBuffer % % The following definitions are used in the routines: % FileDescriptor - A machine dependent word that references a file once % opened. % FileName - A Lisp string of the file name. % % ---------- SysClearIo: % called by Cleario for system dep extras lap '((!*entry SysClearIO expr 0) % % ^C from RDTTY and restart causes trouble, but we don't want a full RESET % (don't want to close files or kill forks), so we'll just do the % part of RESET that we want, for terminal input % (!*MOVE (WConst 8#100) (reg 1)) % .priin (rfmod) (tro 2 2#001111100001000000) % tt%wak + tt%eco + .ttasi, like RESET (sfmod) (!*EXIT 0) ); syslsp procedure SysOpenRead(Channel,FileName); % % Open FileName for input and % % return a file descriptor used % % in later references to the % % file. Begin scalar Jfn; Jfn:=Dec20Open(FileName, % gj%old gj%sht 2#001000000000000001000000000000000000, % 7*of%bsz of%rd 2#000111000000000000010000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'INPUT); return Jfn; End; syslsp procedure SysOpenWrite(Channel,FileName); Begin scalar Jfn; Jfn:=Dec20Open(FileName, % gj%fou gj%new gj%sht 2#110000000000000001000000000000000000, % 7*of%bsz of%wr 2#000111000000000000001000000000000000); if JFN eq 0 then return ContOpenError(FileName, 'OUTPUT); return Jfn; End; lap '((!*entry Dec20Open expr 3) % % Dec20Open(Filename string, GTJFN bits, OPENF bits) % (!*WPLUS2 (reg 1) (WConst 1)) % increment r1 to point to characters (hrli (reg 1) 8#440700) % turn r1 into a byte pointer (!*MOVE (reg 1) (reg 4)) % save filename string in r4 (!*MOVE (reg 2) (reg 1)) % GTJFN flag bits in r1 (!*MOVE (reg 4) (reg 2)) % string in r2 (gtjfn) (!*JUMP (Label CantOpen)) (!*MOVE (reg 3) (reg 2)) % OPENF bits in r2, JFN in r1 (openf) CantOpen (!*MOVE (WConst 0) (reg 1)) % return 0 on error (!*EXIT 0) % else return the JFN ); syslsp procedure SysReadRec(FileDescriptor,StringBuffer); % % Read from the FileDescriptor, a % % record into the StringBuffer. % % Return the length of the % % string read. Begin scalar N,Ch; N:=0; Loop: Ch:=Dec20ReadChar(FileDescriptor); StrByt(StringBuffer,N):=Ch; If Ch eq Char EOL or Ch eq Char EOF then return N; N:=N+1; % Check buffer size here goto Loop; End; lap '((!*entry Dec20ReadChar expr 1) Loop (bin) % read a character (erjmp CheckEOF) % check for end-of-file on error (!*JUMPEQ (Label Loop) (reg 2) (WConst 0))% try again if it's null char (!*JUMPEQ (Label Loop) (reg 2) (WConst 8#15))% or carriage return (!*MOVE (reg 2) (reg 1)) % move char to reg 1 %/ (camn (reg nil) (fluid !*ECHO)) % is echo on? (!*EXIT 0) % no, just return char %/ (!*PUSH (reg 1)) % yes, save char %/ (!*CALL WriteChar) % and write it %/ (!*POP (reg 1)) % restore it %/ (!*EXIT 0) % and return CheckEOF (gtsts) % check file status (tlnn (reg 2) 2#000000001000000000) % gs%eof (!*JUMP (Label ReadError)) (!*MOVE (WConst 26) (reg 1)) % return EOF char (!*EXIT 0) ReadError (!*MOVE (QUOTE "Attempt to read from file failed") (reg 1)) (!*JCALL IoError) ); syslsp procedure SysWriteRec (FileDescriptor, StringToWrite, StringLength); % % Write StringLength characters % % from StringToWrite from the % % first position. for i:=0:StringLength do Dec20WriteChar(FileDescriptor,strbyt(StringToWrite,i)); lap '((!*entry Dec20WriteChar expr 2) % Jfn,Chr (!*JUMPEQ (Label CRLF) (reg 2) (WConst 8#12)) % if LF, echo CRLF (bout) % no, just echo char (!*EXIT 0) % return CRLF (!*MOVE (WConst 8#15) (reg 2)) % write carriage-return (bout) (!*MOVE (WConst 8#12) (reg 2)) % write linefeed (bout) (!*EXIT 0) % return ); % SysClose (FileDescriptor); % Close FileDescriptor, allowing % % it to be reused. lap '((!*entry SysClose expr 1) (closf) (!*JUMP (Label CloseError)) (!*EXIT 0) CloseError (!*MOVE (QUOTE "Channel could not be closed") (reg 1)) (!*JCALL ChannelError) ); syslsp procedure SysMaxBuffer(FileDesc); 200; End; |
Added psl-1983/3-1/tests/all-test.headers version [1697d8fc59].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | "XXX-HEADER.RED"$ MAIN2 6/1 FIRSTCALL; MAIN2 14/2 UNDEFINEDFUNCTIONAUX; MAIN2 77/3 "PT:MINI-CHAR-IO.RED"$ SUB2 3/1 "PT:MINI-PRINTERS.RED"$ SUB2 4/2 "PT:MINI-ERROR-ERRORSET.RED"$ SUB2 5/3 "PT:MINI-ERROR-HANDLERS.RED"$ SUB2 6/4 "PT:MINI-TYPE-ERRORS.RED"$ SUB2 7/5 "XXX-HEADER.RED"$ MAIN3 6/1 "PT:STUBS3.RED"$ MAIN3 7/2 FIRSTCALL; MAIN3 12/3 CASETEST; MAIN3 23/4 CTEST N; MAIN3 41/5 SHOW(N,S); MAIN3 49/6 CONSTEST(); MAIN3 56/7 UNDEFINEDFUNCTIONAUX; MAIN3 68/8 "PT:P-ALLOCATORS.RED"$ SUB3 3/1 "PT:MINI-CONS-MKVECT.RED"$ SUB3 4/2 "PT:MINI-COMP-SUPPORT.RED"$ SUB3 5/3 "PT:MINI-SEQUENCE.RED"$ SUB3 7/4 "PT:MINI-GC.RED"$ STUBS3 4/1 "XXX-HEADER.RED"$ MAIN4 5/1 "PT:P-FUNCTION-PRIMITIVES.RED"$ MAIN4 6/2 "PT:STUBS4.RED"$ MAIN4 7/3 "PT:STUBS3.RED"$ MAIN4 8/4 FIRSTCALL; MAIN4 15/5 MORESTUFF; MAIN4 68/6 FUNCTIONTEST(); MAIN4 74/7 COMPILED1; MAIN4 124/8 COMPILED2; MAIN4 128/9 COMPILED3(A1,A2,A3,A4); MAIN4 132/10 UNDEFINEDFUNCTIONAUXAUX ; MAIN4 142/11 COMPILEDCALLINGINTERPRETEDAUX(); MAIN4 155/12 "PT:MINI-EQUAL.RED"$ SUB4 6/1 "PT:MINI-TOKEN.RED"$ SUB4 7/2 "PT:MINI-READ.RED"$ SUB4 8/3 SPACED(M); STUBS4 3/1 DASHED(M); STUBS4 7/2 DOTTED(M); STUBS4 12/3 SHOULDBE(M,V,E); STUBS4 18/4 "XXX-HEADER.RED"$ MAIN5 4/1 "PT:STUBS3.RED"$ MAIN5 5/2 "PT:STUBS4.RED"$ MAIN5 6/3 "PT:STUBS5.RED"$ MAIN5 7/4 FIRSTCALL; MAIN5 13/5 TESTSERIES(); MAIN5 45/6 TESTGET(); MAIN5 49/7 TESTUNDEFINED; MAIN5 59/8 UNBINDN N; MAIN5 64/9 LBIND1(X,Y); MAIN5 67/10 "PT:P-FUNCTION-PRIMITIVES.RED"$ SUB5 5/1 "PT:P-APPLY-LAP.RED"$ SUB5 6/2 "PT:MINI-ARITHMETIC.RED"$ SUB5 8/3 "PT:MINI-CARCDR.RED"$ SUB5 9/4 "PT:MINI-EASY-SL.RED"$ SUB5 10/5 "PT:MINI-EASY-NON-SL.RED"$ SUB5 11/6 "PT:MINI-EVAL-APPLY.RED"$ SUB5 12/7 "PT:MINI-KNOWN-TO-COMP.RED"$ SUB5 13/8 "PT:MINI-LOOP-MACROS.RED"$ SUB5 14/9 "PT:MINI-OTHERS-SL.RED"$ SUB5 15/10 "PT:MINI-OBLIST.RED"$ SUB5 16/11 "PT:MINI-PROPERTY-LIST.RED"$ SUB5 17/12 "PT:MINI-SYMBOL-VALUES.RED"$ SUB5 18/13 "PT:MINI-TYPE-CONVERSIONS.RED"$ SUB5 19/14 UNDEFINEDFUNCTIONAUXAUX; STUBS5 6/1 INF X; STUBS5 22/2 TAG X; STUBS5 25/3 MKITEM(X,Y); STUBS5 28/4 "XXX-HEADER.RED"$ MAIN6 5/1 "PT:STUBS3.RED"$ MAIN6 6/2 "PT:STUBS4.RED"$ MAIN6 7/3 "PT:STUBS5.RED"$ MAIN6 8/4 "PT:STUBS6.RED"$ MAIN6 9/5 FIRSTCALL; MAIN6 15/6 TESTSERIES(); MAIN6 48/7 BINDINGTEST; MAIN6 55/8 INTERPTEST(); MAIN6 71/9 TESTFASTAPPLY EXPR 0) MAIN6 102/10 TESTAPPLY(MSG,FN,ANSWER); MAIN6 107/11 COMPILED1(XXX,YYY); MAIN6 117/12 COMPILED2(XXX,YYY); MAIN6 122/13 COMPBINDTEST(); MAIN6 129/14 CBIND1(X,CFL1,CFL2); MAIN6 139/15 CBIND2(); MAIN6 149/16 "PK:BINDING.RED"$ SUB6 3/1 "PT:P-FAST-BINDER.RED"$ SUB6 4/2 "PT:MINI-PUTD-GETD.RED"$ SUB6 6/3 RESET(); SUB6 8/4 "PT:MINI-PRINTF.RED"$ STUBS6 3/1 "PT:MINI-TOP-LOOP.RED"$ STUBS6 4/2 FUNCALL(FN,I); STUBS6 8/3 "XXX-HEADER.RED"$ MAIN7 5/1 "PT:STUBS3.RED"$ MAIN7 6/2 "PT:STUBS4.RED"$ MAIN7 7/3 "PT:STUBS5.RED"$ MAIN7 8/4 "PT:STUBS6.RED"$ MAIN7 9/5 "PT:STUBS7.RED"$ MAIN7 10/6 "PT:PSL-TIMER.SL"$ MAIN7 11/7 FIRSTCALL; MAIN7 17/8 IOTEST; MAIN7 61/9 "XXX-SYSTEM-IO.RED"$ SUB7 5/1 "PT:IO-DATA.RED"$ SUB7 6/2 "PT:MINI-IO-ERRORS.RED"$ SUB7 7/3 "PT:MINI-DSKIN.RED"$ SUB7 8/4 "PT:MINI-OPEN-CLOSE.RED"$ SUB7 9/5 "PT:MINI-RDS-WRS.RED"$ SUB7 10/6 "PT:SYSTEM-IO.RED"$ SUB7 11/7 GTHEAP N; MINI-ALLOCATOR 14/1 GTSTR N; MINI-ALLOCATOR 27/2 GTVECT N; MINI-ALLOCATOR 36/3 GTWARRAY N; MINI-ALLOCATOR 44/4 GTID(); MINI-ALLOCATOR 48/5 PLUS2(X,Y); MINI-ARITHMETI 4/1 MINUS(X); MINI-ARITHMETI 8/2 ADD1 N; MINI-ARITHMETI 12/3 SUB1 N; MINI-ARITHMETI 16/4 GREATERP(N1,N2); MINI-ARITHMETI 21/5 LESSP(N1,N2); MINI-ARITHMETI 24/6 DIFFERENCE(N1,N2); MINI-ARITHMETI 27/7 TIMES2(N1,N2); MINI-ARITHMETI 31/8 CAR X; MINI-CARCDR 5/1 CDR X; MINI-CARCDR 8/2 CAAR X; MINI-CARCDR 13/3 CADR X; MINI-CARCDR 16/4 CDAR X; MINI-CARCDR 19/5 CDDR X; MINI-CARCDR 22/6 CHANNELWRITECHAR(CHN,X); MINI-CHAR-IO 3/1 WRITECHAR CH; MINI-CHAR-IO 6/2 LIST2(A1,A2); MINI-COMP-SUPP 4/1 LIST3(A1,A2,A3); MINI-COMP-SUPP 7/2 LIST4(A1,A2,A3,A4); MINI-COMP-SUPP 10/3 LIST5(A1,A2,A3,A4,A5); MINI-COMP-SUPP 13/4 HARDCONS(X,Y); MINI-CONS-MKVE 6/1 CONS(X,Y); MINI-CONS-MKVE 14/2 XCONS(X,Y); MINI-CONS-MKVE 17/3 NCONS X; MINI-CONS-MKVE 20/4 MKVECT N; MINI-CONS-MKVE 23/5 TYPEFILE F; MINI-DSKIN 3/1 DSKIN F; MINI-DSKIN 12/2 LAPIN F; MINI-DSKIN 25/3 ATSOC(X,Y); MINI-EASY-NON- 3/1 GEQ(N1,N2); MINI-EASY-NON- 9/2 LEQ(N1,N2); MINI-EASY-NON- 12/3 EQCAR(X,Y); MINI-EASY-NON- 15/4 COPYD(NEWID,OLDID); MINI-EASY-NON- 18/5 DELATQ(X,Y); MINI-EASY-NON- 28/6 ATOM X; MINI-EASY-SL 8/1 APPEND(U,V); MINI-EASY-SL 13/2 MEMQ(X,Y); MINI-EASY-SL 17/3 REVERSE U; MINI-EASY-SL 22/4 EVLIS X; MINI-EASY-SL 31/5 EVPROGN FL; MINI-EASY-SL 35/6 PROGN X; MINI-EASY-SL 42/7 EVCOND FL; MINI-EASY-SL 45/8 COND X; MINI-EASY-SL 51/9 QUOTE A; MINI-EASY-SL 54/10 SETQ A; MINI-EASY-SL 57/11 DE(X); MINI-EASY-SL 60/12 DF(X); MINI-EASY-SL 63/13 DN(X); MINI-EASY-SL 66/14 DM(X); MINI-EASY-SL 69/15 LIST X; MINI-EASY-SL 73/16 EQSTR(S1,S2); MINI-EQUAL 5/1 ERRORHEADER; MINI-ERROR-ERR 4/1 ERROR S; MINI-ERROR-ERR 7/2 ERRORTRAILER S; MINI-ERROR-ERR 11/3 FATALERROR S; MINI-ERROR-HAN 5/1 STDERROR M; MINI-ERROR-HAN 8/2 INITEVAL; MINI-EVAL-APPL 5/1 EVAL X; MINI-EVAL-APPL 19/2 APPLY(FN,A); MINI-EVAL-APPL 43/3 LAMBDAAPPLY(X,A); MINI-EVAL-APPL 60/4 LAMBDAEVALAPPLY(X,Y); MINI-EVAL-APPL 68/5 DOLAMBDA(VARS,BODY,ARGS); MINI-EVAL-APPL 71/6 LAMBDAP(X); MINI-EVAL-APPL 86/7 GETLAMBDA(FN); MINI-EVAL-APPL 89/8 !%RECLAIM(); MINI-GC 9/1 RECLAIM(); MINI-GC 13/2 HEAPINFO(); MINI-GC 17/3 IOERROR M; MINI-IO-ERRORS 3/1 CODEP X; MINI-KNOWN-TO- 3/1 PAIRP X; MINI-KNOWN-TO- 6/2 IDP X; MINI-KNOWN-TO- 9/3 EQ(X,Y); MINI-KNOWN-TO- 12/4 NULL X; MINI-KNOWN-TO- 15/5 NOT X; MINI-KNOWN-TO- 18/6 WHILE FL; MINI-LOOP-MACR 3/1 MAPOBL(FN); MINI-OBLIST 6/1 PRINTFEXPRS; MINI-OBLIST 9/2 PRINT1FEXPR(X); MINI-OBLIST 12/3 PRINTFUNCTIONS; MINI-OBLIST 15/4 PRINT1FUNCTION(X); MINI-OBLIST 18/5 OPEN(FILENAME,HOW); MINI-OPEN-CLOS 3/1 CLOSE N; MINI-OPEN-CLOS 8/2 LENGTH U; MINI-OTHERS-SL 4/1 LENGTH1(U, N); MINI-OTHERS-SL 8/2 PRIN1 X; MINI-PRINTERS 8/1 PRIN2 X; MINI-PRINTERS 15/2 PRINT X; MINI-PRINTERS 22/3 PRIN2T X; MINI-PRINTERS 25/4 PBLANK; MINI-PRINTERS 30/5 PRIN1INT X; MINI-PRINTERS 33/6 PRIN1INTX X; MINI-PRINTERS 40/7 PRIN1ID X; MINI-PRINTERS 45/8 PRIN2ID X; MINI-PRINTERS 50/9 PRIN1STRING X; MINI-PRINTERS 53/10 PRIN2STRING X; MINI-PRINTERS 60/11 PRIN1PAIR X; MINI-PRINTERS 67/12 PRIN2PAIR X; MINI-PRINTERS 78/13 TERPRI(); MINI-PRINTERS 89/14 PRTITM X; MINI-PRINTERS 92/15 CHANNELPRIN2(CHN,X); MINI-PRINTERS 102/16 BLDMSG(FMT,A1,A2,A3,A4,A5,A6); MINI-PRINTF 3/1 PROP X; MINI-PROPERTY- 5/1 GET(X,Y); MINI-PROPERTY- 9/2 PUT(X,Y,Z); MINI-PROPERTY- 17/3 REMPROP(X,Y); MINI-PROPERTY- 28/4 GETFNTYPE X; MINI-PROPERTY- 38/5 GETD(FN); MINI-PUTD-GETD 6/1 PUTD(FN,TYPE,BODY); MINI-PUTD-GETD 21/2 RDS N; MINI-RDS-WRS 5/1 WRS N; MINI-RDS-WRS 13/2 READ; MINI-READ 6/1 READ1(X); MINI-READ 10/2 READLIST(X); MINI-READ 15/3 MKSTRING(L, C); MINI-SEQUENCE 5/1 SET(X,Y); MINI-SYMBOL-VA 3/1 INITREAD; MINI-TOKEN 11/1 SETRAISE X; MINI-TOKEN 21/2 RATOM; MINI-TOKEN 24/3 CLEARWHITE(); MINI-TOKEN 41/4 CLEARCOMMENT(); MINI-TOKEN 45/5 READINT; MINI-TOKEN 50/6 BUFFERTOSTRING N; MINI-TOKEN 59/7 READSTR; MINI-TOKEN 67/8 READID; MINI-TOKEN 77/9 RAISECHAR C; MINI-TOKEN 88/10 INTERN S; MINI-TOKEN 95/11 INITNEWID(D,S); MINI-TOKEN 105/12 LOOKUPID(S); MINI-TOKEN 115/13 WHITEP X; MINI-TOKEN 131/14 DIGITP X; MINI-TOKEN 135/15 ALPHAP(X); MINI-TOKEN 138/16 UPPERCASEP X; MINI-TOKEN 141/17 LOWERCASEP X; MINI-TOKEN 144/18 ESCAPEP X; MINI-TOKEN 147/19 ALPHAESCP X; MINI-TOKEN 150/20 ALPHANUMP X; MINI-TOKEN 153/21 ALPHANUMESCP X; MINI-TOKEN 156/22 TIME(); MINI-TOP-LOOP 3/1 SYS2INT N; %. CONVERT WORD TO LISP NUMBER MINI-TYPE-CONV 5/1 SYS2FIXN N; MINI-TYPE-CONV 9/2 TYPEERROR(OFFENDER, FN, TYP); MINI-TYPE-ERRO 3/1 USAGETYPEERROR(OFFENDER, FN, TYP, USAGE); MINI-TYPE-ERRO 14/2 NONIDERROR(X,Y); MINI-TYPE-ERRO 28/3 NONNUMBERERROR(OFFENDER, FN); MINI-TYPE-ERRO 31/4 NONINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 34/5 NONPOSITIVEINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 37/6 CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 CODEEVALAPPLYAUX(CODEPTR, ARGLIST, P); P-APPLY-LAP 213/3 BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 COMPILEDCALLINGINTERPRETEDAUXAUX FN; P-APPLY-LAP 391/8 LAMBIND V; P-FAST-BINDER 23/1 PROGBIND V; P-FAST-BINDER 32/2 SYMFNCBASE D; % THE ADDRESS OF CELL, P-FUNCTION-PRI 57/1 FUNBOUNDP FN; P-FUNCTION-PRI 65/2 MAKEFUNBOUND(D); P-FUNCTION-PRI 73/3 FLAMBDALINKP FN; P-FUNCTION-PRI 79/4 MAKEFLAMBDALINK D; P-FUNCTION-PRI 85/5 FCODEP FN; P-FUNCTION-PRI 91/6 MAKEFCODE(U, CODEPTR); P-FUNCTION-PRI 96/7 GETFCODEPOINTER U; P-FUNCTION-PRI 106/8 CODEPRIMITIVE EXPR 15) P-FUNCTION-PRI 121/9 COMPILEDCALLINGINTERPRETED EXPR 15) P-FUNCTION-PRI 136/10 FASTAPPLY EXPR 0) P-FUNCTION-PRI 153/11 SAVEREGISTERS(A1, A2, A3, A4, A5, P-FUNCTION-PRI 193/12 UNDEFINEDFUNCTIONAUX EXPR 0) P-FUNCTION-PRI 214/13 ERNAL WCONST STACKSIZE = 5000; P20T:XXX-HEADE 11/1 ERNAL WARRAY STACK[STACKSIZE]; P20T:XXX-HEADE 12/2 ERNAL WCONST HEAPSIZE = 150000; % ENOUGH FOR PSL-TIM P20T:XXX-HEADE 21/3 ERNAL WARRAY HEAP[HEAPSIZE]; % COULD DO A DYNAMIC A P20T:XXX-HEADE 22/4 ERNAL WARRAY OTHERHEAP[HEAPSIZE]; P20T:XXX-HEADE 30/5 ERNAL WCONST BPSSIZE = 500; P20T:XXX-HEADE 36/6 ERNAL WARRAY BPS[BPSSIZE]; % COULD DO A DYNAMIC ALL P20T:XXX-HEADE 37/7 INITHEAP(); P20T:XXX-HEADE 44/8 ERNAL WCONST MAXARGBLOCK = (MAXARGS - MAXREALREGS) - P20T:XXX-HEADE 54/9 MAIN!. EXPR 0) P20T:XXX-HEADE 68/10 INIT(); P20T:XXX-HEADE 92/11 GETC(); P20T:XXX-HEADE 98/12 TIMC(); P20T:XXX-HEADE 102/13 PUTC X; P20T:XXX-HEADE 105/14 QUIT; P20T:XXX-HEADE 109/15 DATE; P20T:XXX-HEADE 112/16 VERSIONNAME; P20T:XXX-HEADE 115/17 PUTINT I; P20T:XXX-HEADE 118/18 !%STORE!-JCALL EXPR 2) % CODEADDRESS, STORAGE ADDRESS P20T:XXX-HEADE 122/19 !%COPY!-FUNCTION!-CELL EXPR 2) % FROM TO P20T:XXX-HEADE 128/20 UNDEFINEDFUNCTION EXPR 0) % FOR MISSING FUNCTION P20T:XXX-HEADE 135/21 FLAG EXPR 2) % DUMMY FOR INIT P20T:XXX-HEADE 142/22 LONGTIMES(X,Y); P20T:XXX-HEADE 148/23 LONGDIV(X,Y); P20T:XXX-HEADE 151/24 LONGREMAINDER(X,Y); P20T:XXX-HEADE 154/25 SYSCLEARIO EXPR 0) P20T:XXX-SYSTE 30/1 SYSOPENREAD(CHANNEL,FILENAME); P20T:XXX-SYSTE 44/2 SYSOPENWRITE(CHANNEL,FILENAME); P20T:XXX-SYSTE 56/3 DEC20OPEN EXPR 3) P20T:XXX-SYSTE 64/4 SYSREADREC(FILEDESCRIPTOR,STRINGBUFFER); P20T:XXX-SYSTE 83/5 DEC20READCHAR EXPR 1) P20T:XXX-SYSTE 98/6 SYSWRITEREC (FILEDESCRIPTOR, STRINGTOWRITE, STRINGLE P20T:XXX-SYSTE 123/7 DEC20WRITECHAR EXPR 2) P20T:XXX-SYSTE 130/8 SYSCLOSE EXPR 1) P20T:XXX-SYSTE 145/9 SYSMAXBUFFER(FILEDESC); P20T:XXX-SYSTE 154/10 2964 lines, 316 procedures found |
Added psl-1983/3-1/tests/all-test.sorted version [c3fc210c69].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 2964 lines, 316 procedures found SYSWRITEREC (FILEDESCRIPTOR, STRINGTOWRITE, STRINGLE P20T:XXX-SYSTE 123/7 !%COPY!-FUNCTION!-CELL EXPR 2) % FROM TO P20T:XXX-HEADE 128/20 !%RECLAIM(); MINI-GC 9/1 !%STORE!-JCALL EXPR 2) % CODEADDRESS, STORAGE ADDRESS P20T:XXX-HEADE 122/19 "PK:BINDING.RED"$ SUB6 3/1 "PT:IO-DATA.RED"$ SUB7 6/2 "PT:MINI-ARITHMETIC.RED"$ SUB5 8/3 "PT:MINI-CARCDR.RED"$ SUB5 9/4 "PT:MINI-CHAR-IO.RED"$ SUB2 3/1 "PT:MINI-COMP-SUPPORT.RED"$ SUB3 5/3 "PT:MINI-CONS-MKVECT.RED"$ SUB3 4/2 "PT:MINI-DSKIN.RED"$ SUB7 8/4 "PT:MINI-EASY-NON-SL.RED"$ SUB5 11/6 "PT:MINI-EASY-SL.RED"$ SUB5 10/5 "PT:MINI-EQUAL.RED"$ SUB4 6/1 "PT:MINI-ERROR-ERRORSET.RED"$ SUB2 5/3 "PT:MINI-ERROR-HANDLERS.RED"$ SUB2 6/4 "PT:MINI-EVAL-APPLY.RED"$ SUB5 12/7 "PT:MINI-GC.RED"$ STUBS3 4/1 "PT:MINI-IO-ERRORS.RED"$ SUB7 7/3 "PT:MINI-KNOWN-TO-COMP.RED"$ SUB5 13/8 "PT:MINI-LOOP-MACROS.RED"$ SUB5 14/9 "PT:MINI-OBLIST.RED"$ SUB5 16/11 "PT:MINI-OPEN-CLOSE.RED"$ SUB7 9/5 "PT:MINI-OTHERS-SL.RED"$ SUB5 15/10 "PT:MINI-PRINTERS.RED"$ SUB2 4/2 "PT:MINI-PRINTF.RED"$ STUBS6 3/1 "PT:MINI-PROPERTY-LIST.RED"$ SUB5 17/12 "PT:MINI-PUTD-GETD.RED"$ SUB6 6/3 "PT:MINI-RDS-WRS.RED"$ SUB7 10/6 "PT:MINI-READ.RED"$ SUB4 8/3 "PT:MINI-SEQUENCE.RED"$ SUB3 7/4 "PT:MINI-SYMBOL-VALUES.RED"$ SUB5 18/13 "PT:MINI-TOKEN.RED"$ SUB4 7/2 "PT:MINI-TOP-LOOP.RED"$ STUBS6 4/2 "PT:MINI-TYPE-CONVERSIONS.RED"$ SUB5 19/14 "PT:MINI-TYPE-ERRORS.RED"$ SUB2 7/5 "PT:P-ALLOCATORS.RED"$ SUB3 3/1 "PT:P-APPLY-LAP.RED"$ SUB5 6/2 "PT:P-FAST-BINDER.RED"$ SUB6 4/2 "PT:P-FUNCTION-PRIMITIVES.RED"$ MAIN4 6/2 "PT:P-FUNCTION-PRIMITIVES.RED"$ SUB5 5/1 "PT:PSL-TIMER.SL"$ MAIN7 11/7 "PT:STUBS3.RED"$ MAIN3 7/2 "PT:STUBS3.RED"$ MAIN4 8/4 "PT:STUBS3.RED"$ MAIN5 5/2 "PT:STUBS3.RED"$ MAIN6 6/2 "PT:STUBS3.RED"$ MAIN7 6/2 "PT:STUBS4.RED"$ MAIN4 7/3 "PT:STUBS4.RED"$ MAIN5 6/3 "PT:STUBS4.RED"$ MAIN6 7/3 "PT:STUBS4.RED"$ MAIN7 7/3 "PT:STUBS5.RED"$ MAIN5 7/4 "PT:STUBS5.RED"$ MAIN6 8/4 "PT:STUBS5.RED"$ MAIN7 8/4 "PT:STUBS6.RED"$ MAIN6 9/5 "PT:STUBS6.RED"$ MAIN7 9/5 "PT:STUBS7.RED"$ MAIN7 10/6 "PT:SYSTEM-IO.RED"$ SUB7 11/7 "XXX-HEADER.RED"$ MAIN2 6/1 "XXX-HEADER.RED"$ MAIN3 6/1 "XXX-HEADER.RED"$ MAIN4 5/1 "XXX-HEADER.RED"$ MAIN5 4/1 "XXX-HEADER.RED"$ MAIN6 5/1 "XXX-HEADER.RED"$ MAIN7 5/1 "XXX-SYSTEM-IO.RED"$ SUB7 5/1 ADD1 N; MINI-ARITHMETI 12/3 ALPHAESCP X; MINI-TOKEN 150/20 ALPHANUMESCP X; MINI-TOKEN 156/22 ALPHANUMP X; MINI-TOKEN 153/21 ALPHAP(X); MINI-TOKEN 138/16 APPEND(U,V); MINI-EASY-SL 13/2 APPLY(FN,A); MINI-EVAL-APPL 43/3 ATOM X; MINI-EASY-SL 8/1 ATSOC(X,Y); MINI-EASY-NON- 3/1 BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 BINDINGTEST; MAIN6 55/8 BLDMSG(FMT,A1,A2,A3,A4,A5,A6); MINI-PRINTF 3/1 BUFFERTOSTRING N; MINI-TOKEN 59/7 CAAR X; MINI-CARCDR 13/3 CADR X; MINI-CARCDR 16/4 CAR X; MINI-CARCDR 5/1 CASETEST; MAIN3 23/4 CBIND1(X,CFL1,CFL2); MAIN6 139/15 CBIND2(); MAIN6 149/16 CDAR X; MINI-CARCDR 19/5 CDDR X; MINI-CARCDR 22/6 CDR X; MINI-CARCDR 8/2 CHANNELPRIN2(CHN,X); MINI-PRINTERS 102/16 CHANNELWRITECHAR(CHN,X); MINI-CHAR-IO 3/1 CLEARCOMMENT(); MINI-TOKEN 45/5 CLEARWHITE(); MINI-TOKEN 41/4 CLOSE N; MINI-OPEN-CLOS 8/2 CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 CODEEVALAPPLYAUX(CODEPTR, ARGLIST, P); P-APPLY-LAP 213/3 CODEP X; MINI-KNOWN-TO- 3/1 CODEPRIMITIVE EXPR 15) P-FUNCTION-PRI 121/9 COMPBINDTEST(); MAIN6 129/14 COMPILED1(XXX,YYY); MAIN6 117/12 COMPILED1; MAIN4 124/8 COMPILED2(XXX,YYY); MAIN6 122/13 COMPILED2; MAIN4 128/9 COMPILED3(A1,A2,A3,A4); MAIN4 132/10 COMPILEDCALLINGINTERPRETED EXPR 15) P-FUNCTION-PRI 136/10 COMPILEDCALLINGINTERPRETEDAUX(); MAIN4 155/12 COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 COMPILEDCALLINGINTERPRETEDAUXAUX FN; P-APPLY-LAP 391/8 COND X; MINI-EASY-SL 51/9 CONS(X,Y); MINI-CONS-MKVE 14/2 CONSTEST(); MAIN3 56/7 COPYD(NEWID,OLDID); MINI-EASY-NON- 18/5 CTEST N; MAIN3 41/5 DASHED(M); STUBS4 7/2 DATE; P20T:XXX-HEADE 112/16 DE(X); MINI-EASY-SL 60/12 DEC20OPEN EXPR 3) P20T:XXX-SYSTE 64/4 DEC20READCHAR EXPR 1) P20T:XXX-SYSTE 98/6 DEC20WRITECHAR EXPR 2) P20T:XXX-SYSTE 130/8 DELATQ(X,Y); MINI-EASY-NON- 28/6 DF(X); MINI-EASY-SL 63/13 DIFFERENCE(N1,N2); MINI-ARITHMETI 27/7 DIGITP X; MINI-TOKEN 135/15 DM(X); MINI-EASY-SL 69/15 DN(X); MINI-EASY-SL 66/14 DOLAMBDA(VARS,BODY,ARGS); MINI-EVAL-APPL 71/6 DOTTED(M); STUBS4 12/3 DSKIN F; MINI-DSKIN 12/2 EQ(X,Y); MINI-KNOWN-TO- 12/4 EQCAR(X,Y); MINI-EASY-NON- 15/4 EQSTR(S1,S2); MINI-EQUAL 5/1 ERNAL WARRAY BPS[BPSSIZE]; % COULD DO A DYNAMIC ALL P20T:XXX-HEADE 37/7 ERNAL WARRAY HEAP[HEAPSIZE]; % COULD DO A DYNAMIC A P20T:XXX-HEADE 22/4 ERNAL WARRAY OTHERHEAP[HEAPSIZE]; P20T:XXX-HEADE 30/5 ERNAL WARRAY STACK[STACKSIZE]; P20T:XXX-HEADE 12/2 ERNAL WCONST BPSSIZE = 500; P20T:XXX-HEADE 36/6 ERNAL WCONST HEAPSIZE = 150000; % ENOUGH FOR PSL-TIM P20T:XXX-HEADE 21/3 ERNAL WCONST MAXARGBLOCK = (MAXARGS - MAXREALREGS) - P20T:XXX-HEADE 54/9 ERNAL WCONST STACKSIZE = 5000; P20T:XXX-HEADE 11/1 ERROR S; MINI-ERROR-ERR 7/2 ERRORHEADER; MINI-ERROR-ERR 4/1 ERRORTRAILER S; MINI-ERROR-ERR 11/3 ESCAPEP X; MINI-TOKEN 147/19 EVAL X; MINI-EVAL-APPL 19/2 EVCOND FL; MINI-EASY-SL 45/8 EVLIS X; MINI-EASY-SL 31/5 EVPROGN FL; MINI-EASY-SL 35/6 FASTAPPLY EXPR 0) P-FUNCTION-PRI 153/11 FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 FATALERROR S; MINI-ERROR-HAN 5/1 FCODEP FN; P-FUNCTION-PRI 91/6 FIRSTCALL; MAIN2 14/2 FIRSTCALL; MAIN3 12/3 FIRSTCALL; MAIN4 15/5 FIRSTCALL; MAIN5 13/5 FIRSTCALL; MAIN6 15/6 FIRSTCALL; MAIN7 17/8 FLAG EXPR 2) % DUMMY FOR INIT P20T:XXX-HEADE 142/22 FLAMBDALINKP FN; P-FUNCTION-PRI 79/4 FUNBOUNDP FN; P-FUNCTION-PRI 65/2 FUNCALL(FN,I); STUBS6 8/3 FUNCTIONTEST(); MAIN4 74/7 GEQ(N1,N2); MINI-EASY-NON- 9/2 GET(X,Y); MINI-PROPERTY- 9/2 GETC(); P20T:XXX-HEADE 98/12 GETD(FN); MINI-PUTD-GETD 6/1 GETFCODEPOINTER U; P-FUNCTION-PRI 106/8 GETFNTYPE X; MINI-PROPERTY- 38/5 GETLAMBDA(FN); MINI-EVAL-APPL 89/8 GREATERP(N1,N2); MINI-ARITHMETI 21/5 GTHEAP N; MINI-ALLOCATOR 14/1 GTID(); MINI-ALLOCATOR 48/5 GTSTR N; MINI-ALLOCATOR 27/2 GTVECT N; MINI-ALLOCATOR 36/3 GTWARRAY N; MINI-ALLOCATOR 44/4 HARDCONS(X,Y); MINI-CONS-MKVE 6/1 HEAPINFO(); MINI-GC 17/3 IDP X; MINI-KNOWN-TO- 9/3 INF X; STUBS5 22/2 INIT(); P20T:XXX-HEADE 92/11 INITEVAL; MINI-EVAL-APPL 5/1 INITHEAP(); P20T:XXX-HEADE 44/8 INITNEWID(D,S); MINI-TOKEN 105/12 INITREAD; MINI-TOKEN 11/1 INTERN S; MINI-TOKEN 95/11 INTERPTEST(); MAIN6 71/9 IOERROR M; MINI-IO-ERRORS 3/1 IOTEST; MAIN7 61/9 LAMBDAAPPLY(X,A); MINI-EVAL-APPL 60/4 LAMBDAEVALAPPLY(X,Y); MINI-EVAL-APPL 68/5 LAMBDAP(X); MINI-EVAL-APPL 86/7 LAMBIND V; P-FAST-BINDER 23/1 LAPIN F; MINI-DSKIN 25/3 LBIND1(X,Y); MAIN5 67/10 LENGTH U; MINI-OTHERS-SL 4/1 LENGTH1(U, N); MINI-OTHERS-SL 8/2 LEQ(N1,N2); MINI-EASY-NON- 12/3 LESSP(N1,N2); MINI-ARITHMETI 24/6 LIST X; MINI-EASY-SL 73/16 LIST2(A1,A2); MINI-COMP-SUPP 4/1 LIST3(A1,A2,A3); MINI-COMP-SUPP 7/2 LIST4(A1,A2,A3,A4); MINI-COMP-SUPP 10/3 LIST5(A1,A2,A3,A4,A5); MINI-COMP-SUPP 13/4 LONGDIV(X,Y); P20T:XXX-HEADE 151/24 LONGREMAINDER(X,Y); P20T:XXX-HEADE 154/25 LONGTIMES(X,Y); P20T:XXX-HEADE 148/23 LOOKUPID(S); MINI-TOKEN 115/13 LOWERCASEP X; MINI-TOKEN 144/18 MAIN!. EXPR 0) P20T:XXX-HEADE 68/10 MAKEFCODE(U, CODEPTR); P-FUNCTION-PRI 96/7 MAKEFLAMBDALINK D; P-FUNCTION-PRI 85/5 MAKEFUNBOUND(D); P-FUNCTION-PRI 73/3 MAPOBL(FN); MINI-OBLIST 6/1 MEMQ(X,Y); MINI-EASY-SL 17/3 MINUS(X); MINI-ARITHMETI 8/2 MKITEM(X,Y); STUBS5 28/4 MKSTRING(L, C); MINI-SEQUENCE 5/1 MKVECT N; MINI-CONS-MKVE 23/5 MORESTUFF; MAIN4 68/6 NCONS X; MINI-CONS-MKVE 20/4 NONIDERROR(X,Y); MINI-TYPE-ERRO 28/3 NONINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 34/5 NONNUMBERERROR(OFFENDER, FN); MINI-TYPE-ERRO 31/4 NONPOSITIVEINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 37/6 NOT X; MINI-KNOWN-TO- 18/6 NULL X; MINI-KNOWN-TO- 15/5 OPEN(FILENAME,HOW); MINI-OPEN-CLOS 3/1 PAIRP X; MINI-KNOWN-TO- 6/2 PBLANK; MINI-PRINTERS 30/5 PLUS2(X,Y); MINI-ARITHMETI 4/1 PRIN1 X; MINI-PRINTERS 8/1 PRIN1ID X; MINI-PRINTERS 45/8 PRIN1INT X; MINI-PRINTERS 33/6 PRIN1INTX X; MINI-PRINTERS 40/7 PRIN1PAIR X; MINI-PRINTERS 67/12 PRIN1STRING X; MINI-PRINTERS 53/10 PRIN2 X; MINI-PRINTERS 15/2 PRIN2ID X; MINI-PRINTERS 50/9 PRIN2PAIR X; MINI-PRINTERS 78/13 PRIN2STRING X; MINI-PRINTERS 60/11 PRIN2T X; MINI-PRINTERS 25/4 PRINT X; MINI-PRINTERS 22/3 PRINT1FEXPR(X); MINI-OBLIST 12/3 PRINT1FUNCTION(X); MINI-OBLIST 18/5 PRINTFEXPRS; MINI-OBLIST 9/2 PRINTFUNCTIONS; MINI-OBLIST 15/4 PROGBIND V; P-FAST-BINDER 32/2 PROGN X; MINI-EASY-SL 42/7 PROP X; MINI-PROPERTY- 5/1 PRTITM X; MINI-PRINTERS 92/15 PUT(X,Y,Z); MINI-PROPERTY- 17/3 PUTC X; P20T:XXX-HEADE 105/14 PUTD(FN,TYPE,BODY); MINI-PUTD-GETD 21/2 PUTINT I; P20T:XXX-HEADE 118/18 QUIT; P20T:XXX-HEADE 109/15 QUOTE A; MINI-EASY-SL 54/10 RAISECHAR C; MINI-TOKEN 88/10 RATOM; MINI-TOKEN 24/3 RDS N; MINI-RDS-WRS 5/1 READ1(X); MINI-READ 10/2 READ; MINI-READ 6/1 READID; MINI-TOKEN 77/9 READINT; MINI-TOKEN 50/6 READLIST(X); MINI-READ 15/3 READSTR; MINI-TOKEN 67/8 RECLAIM(); MINI-GC 13/2 REMPROP(X,Y); MINI-PROPERTY- 28/4 RESET(); SUB6 8/4 REVERSE U; MINI-EASY-SL 22/4 SAVEREGISTERS(A1, A2, A3, A4, A5, P-FUNCTION-PRI 193/12 SET(X,Y); MINI-SYMBOL-VA 3/1 SETQ A; MINI-EASY-SL 57/11 SETRAISE X; MINI-TOKEN 21/2 SHOULDBE(M,V,E); STUBS4 18/4 SHOW(N,S); MAIN3 49/6 SPACED(M); STUBS4 3/1 STDERROR M; MINI-ERROR-HAN 8/2 SUB1 N; MINI-ARITHMETI 16/4 SYMFNCBASE D; % THE ADDRESS OF CELL, P-FUNCTION-PRI 57/1 SYS2FIXN N; MINI-TYPE-CONV 9/2 SYS2INT N; %. CONVERT WORD TO LISP NUMBER MINI-TYPE-CONV 5/1 SYSCLEARIO EXPR 0) P20T:XXX-SYSTE 30/1 SYSCLOSE EXPR 1) P20T:XXX-SYSTE 145/9 SYSMAXBUFFER(FILEDESC); P20T:XXX-SYSTE 154/10 SYSOPENREAD(CHANNEL,FILENAME); P20T:XXX-SYSTE 44/2 SYSOPENWRITE(CHANNEL,FILENAME); P20T:XXX-SYSTE 56/3 SYSREADREC(FILEDESCRIPTOR,STRINGBUFFER); P20T:XXX-SYSTE 83/5 TAG X; STUBS5 25/3 TERPRI(); MINI-PRINTERS 89/14 TESTAPPLY(MSG,FN,ANSWER); MAIN6 107/11 TESTFASTAPPLY EXPR 0) MAIN6 102/10 TESTGET(); MAIN5 49/7 TESTSERIES(); MAIN5 45/6 TESTSERIES(); MAIN6 48/7 TESTUNDEFINED; MAIN5 59/8 TIMC(); P20T:XXX-HEADE 102/13 TIME(); MINI-TOP-LOOP 3/1 TIMES2(N1,N2); MINI-ARITHMETI 31/8 TYPEERROR(OFFENDER, FN, TYP); MINI-TYPE-ERRO 3/1 TYPEFILE F; MINI-DSKIN 3/1 UNBINDN N; MAIN5 64/9 UNDEFINEDFUNCTION EXPR 0) % FOR MISSING FUNCTION P20T:XXX-HEADE 135/21 UNDEFINEDFUNCTIONAUX EXPR 0) P-FUNCTION-PRI 214/13 UNDEFINEDFUNCTIONAUX; MAIN2 77/3 UNDEFINEDFUNCTIONAUX; MAIN3 68/8 UNDEFINEDFUNCTIONAUXAUX ; MAIN4 142/11 UNDEFINEDFUNCTIONAUXAUX; STUBS5 6/1 UPPERCASEP X; MINI-TOKEN 141/17 USAGETYPEERROR(OFFENDER, FN, TYP, USAGE); MINI-TYPE-ERRO 14/2 VERSIONNAME; P20T:XXX-HEADE 115/17 WHILE FL; MINI-LOOP-MACR 3/1 WHITEP X; MINI-TOKEN 131/14 WRITECHAR CH; MINI-CHAR-IO 6/2 WRS N; MINI-RDS-WRS 13/2 XCONS(X,Y); MINI-CONS-MKVE 17/3 |
Added psl-1983/3-1/tests/block-dolphin.tim version [940aa7bc1d].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("Block Compiled, Dolphin, InterLISP D, Jed Marti, 10-March-83, Rand") (EmptyTest-10000 . 360) (GEmptyTest-10000 . 360) (Cdr1Test-100 . 6497) (Cdr2Test-100 . 2919) (CddrTest-100 . 2411) (ListOnlyCdrTest1 . 20525) (ListOnlyCddrTest1 . 31736) (ListOnlyCdrTest2 . 38786) (ListOnlyCddrTest2 . 49978) (ReverseTest-10 . 4095) (MyReverse1Test-10 . 5087) (MyReverse2Test-10 . 4417) (LengthTest-100 . 8570) (ArithmeticTest-10000 . 12759) (EvalTest-10000 . 15782) (tak-18-12-6 . 4817) (gtak-18-12-6 . 4737) (gtsta-g0 . 79000) (gtsta-g1 . 93854) ) |
Added psl-1983/3-1/tests/boot-list version [b8cb2b5a01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Cross-compiler Test and Bootstrap series page 1 PK: modules/files PT: status ALLOC Allocators P-allocators sub3 cleaned up Copiers Cons-mkvect m-cons-mkvect sub3 almost same Comp-support PK:comp-support sub3 same P20:System-gc xxx-system-gc sub8 same P20:Gc m-gc stubs3 STUB until test 8 xxx-gc sub8 compacting-gc p-comp-gc sub8 cleaned up ARITH Arithmetic m-arithmetic sub5 simpler DEBG p20:Mini-trace Mini-editor Backtrace ERROR Error-handlers m-error-handlers sub2 simple subset Type-errors m-type-errors sub2 same, with fake StdError,Bldmsg Error-errorset m-error-errorset sub2 trivial subset Io-errors m-io-errors sub2 simple subset EVAL P20:Apply-lap p-apply-lap sub5a less efficient Eval-apply m-eval-apply sub5a simpler Catch-throw PK:catch-throw sub9 same Prog-and-friends PK:prog-and-friends sub9 same EXTRA p20:Timc xxx-header p20:System-extras xxx-header p20:Trap P20:Dumplisp FASL p20:System-faslout p20:System-faslin Faslin Load Autoload P20:HEAP [Declare HEAP,BPS] xxx-header Cross-compiler Test and Bootstrap series page 2 IO P20:Io-data io-data sub7 same? Char-io m-char-io sub7 simple subset Open-close m-open-close sub7 simpler Rds-wrs m-rds-wrs sub7 simpler Other-io Read m-read sub4 simpler Token-scanner m-token sub4 simpler Printers m-printers sub2 simpler p20:Write-float Printf m-printf sub2 trivial subset Explode-compress Io-extensions MACRO Eval-when Cont-error Lisp-macros Onoff Define-smacro Defconst String-gensym Loop-macros m-loop-macros sub5 simpler MAIN P20:Main-start xxx-header simpler PROP P20:Function-primitives p-function-primitives sub5b less efficient Property-list m-property-list sub5b simpler? Fluid-global m-fluid-global sub5b trivial Putd-getd m-putd-getd sub6 simpler? RANDM Known-to-comp-sl PK:known-to-comp-sl sub5b same Others-sl M-others-sl sub5b subset Equal m-equal sub5b subset Carcdr PK:carcdr sub5b same Easy-sl M-easy-sl sub5b subset Easy-non-sl M-easy-non-sl sub5b subset Sets SYMBL Binding PK:binding sub6 same P20:Fast-binder P-fast-binder sub6 less-efficient Symbol-values m-symbol-values sub5b subset Oblist m-oblist sub5b subset SYSIO p20:System-io system-io, xxx-system-io sub7 same? P20:Scan-table TLOOP Break Top-loop m-top-loop sub7 trivial subset Dskin m-dskin sub7 simpler TYPES Type-conversions m-type-conversions sub5b simpler Vectors Sequence m-sequence sub3 simpler |
Added psl-1983/3-1/tests/catch.tst version [3834d281bb].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % Some interpreted tests of CATCH and THROW for MAIN 9 (Dashed "Expect an Error, that FOO uncaught") (THROW 'FOO 1) (shouldbe "Catch should return argument " (CATCH 'FOO 1) 1) (Dashed "Expect 1 to be printed, and 2 returned, no 3") (Shouldbe "Catch the Thrown value" (CATCH 'FOO (PROGN (print 1) (throw 'foo 2) (print 3))) 2) |
Added psl-1983/3-1/tests/cray-time.red version [68d277913e].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | % A small timing test to compare DEC-20, VAX and Cray % in syslisp and FORTRAN and C % An iterative FACTORIAL on comp; on syslisp; syslsp procedure IFAC n; begin scalar m; m:=1; while n >0 do <<m:=m*n; n := n-1>>; return m; end; procedure NCALL(N,M); begin scalar tim1,tim2,i; tim1:=time(); while N>0 do <<i:=Ifac(m);n:=n-1>>; tim2:=time()-tim1; %/had bug if same tim printf(" took %p ms%n",tim2); end; off syslisp; |
Added psl-1983/3-1/tests/extended-20.tim version [2443754337].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | ( ("DEC-20, extended 3.1 PSL" . "2-Apr-83 ") (EmptyTest-10000 . 18) (GEmptyTest-10000 . 298) (Cdr1Test-100 . 572) (Cdr2Test-100 . 385) (CddrTest-100 . 274) (ListOnlyCdrTest1 . 1801) (ListOnlyCddrTest1 . 3237) (ListOnlyCdrTest2 . 2997) (ListOnlyCddrTest2 . 4520) (ReverseTest-10 . 341) (MyReverse1Test-10 . 602) (MyReverse2Test-10 . 316) (LengthTest-100 . 613) (ArithmeticTest-10000 . 617) (EvalTest-10000 . 2096) (tak-18-12-6 . 468) (gtak-18-12-6 . 2011) (gtsta-g0 . 900) (gtsta-g1 . 970) ) % GC average about 680ms per |
Added psl-1983/3-1/tests/extended-test-20.tim version [8235550422].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | (("Extended Test 20 ". " 20 Feb 1983") (EmptyTest-10000 . 27) (SlowEmptyTest-10000 . 83) (Cdr1Test-100 . 579) (Cdr2Test-100 . 381 ) (CddrTest-100 . 299 ) (ListOnlyCdrTest1 . 1762 ) (ListOnlyCddrTest1 . 3483 ) (ListOnlyCdrTest2 . 3005 ) (ListOnlyCddrTest2 . 4704 ) (ReverseTest-10 . 620 ) (MyReverse1Test-10 . 594 ) (MyReverse2Test-10 . 523 ) (LengthTest-100 . 624 ) (ArithmeticTest-10000 . 661 ) (EvalTest-10000 . 3118 ) (tak-18-12-6 . 477 ) (gtak-18-12-6 . 705 ) (gtsta-g0 . 1249) (gtsta-g1 . 1308) ) |
Added psl-1983/3-1/tests/fast-780.tim version [2b323d0d0c].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("PSL 3.1, Faster VAX 780 " . " 31-Mar-83") (EmptyTest-10000 . 34) (GEmptyTest-10000 . 630) (Cdr1Test-100 . 1309) (Cdr2Test-100 . 850) (CddrTest-100 . 663) (ListOnlyCdrTest1 . 5219) (ListOnlyCddrTest1 . 8262) (ListOnlyCdrTest2 . 7616) (ListOnlyCddrTest2 . 11866) (ReverseTest-10 . 714) (MyReverse1Test-10 . 612) (MyReverse2Test-10 . 442) (LengthTest-100 . 1650) (ArithmeticTest-10000 . 833) (EvalTest-10000 . 6200) (tak-18-12-6 . 714) (gtak-18-12-6 . 4029) (gtsta-g0 . 2227) (gtsta-g1 . 2329) ) |
Added psl-1983/3-1/tests/field.red version [267f04a61f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % FIELD.RED - Exhaustively Test the Field Operator On SYSLISP; In "XXX-Header.red"$ Procedure FirstCall; Begin Scalar X,BPW; Msg5(Char M, Char S, Char G, Char '! ,Char EOL); TestOK Char '!?; %/ Confirm the test message TestErr Char '!?; % Set up test pattern %0001122233444556 % Bit Number T %0482604826048260 U BPW:=BitsPerWord; % For bug in !*JUMPxx If BPW eq 64 then X:=16#0123456789ABCDEF % 16 nibbles=8 bytes else if BPW eq 32 then X:=16#01234567 % 8 nibbles=4 bytes else if BPW eq 36 then X:=16#012345678 % 9 nibbles=4.5 bytes else ERR 99; AShiftTest(X); %/ Arithmetic Test FieldTest(X); %/ FieldExtract LshiftTest(X); %/ Shift and Masks with Field Quit; End; % Ashift can only be tested by a multiply of a 2 to a power. Therefore % it is only used in the left shift case. Procedure AShiftTest TestVal; Begin Scalar X, Y; Msg5(Char A,Char S,Char H,Char I,Char F); Msg5(Char T,Char '! ,Char '! ,Char '! , Char EOL); Y := 10; Y := Y*4; If Y NEQ 40 Then TestErr Char 1 Else TestOk Char 1; Y := -5; Y := Y*16; If Y NEQ -80 Then TestErr Char 2 Else TestOk Char 2; Y := 6; X := 4; Y := Y * 4; If Y NEQ 6*X Then TestErr Char 3 Else TestOk Char 3; End; Procedure FieldTest(x); % Extract a field from a variable and see if it works. Begin scalar Y; Msg5(Char F,Char I,Char E,Char L,Char D); PutC Char EOL; Y:=Field(X, 0, BitsPerWord);% FullWord If Y NEQ X Then TestErr Char 1 Else TestOk Char 1; Y:=Field(X, 0, 8); % First Byte If Y NEQ 16#01 Then TestErr Char 2 Else TestOk Char 2; Y:=Field(X, 8, 8); % Second Byte If Y NEQ 16#23 Then TestErr Char 3 Else TestOk Char 3; Y:=Field(X, 16, 8); % Third Byte If Y NEQ 16#45 Then TestErr Char 4 Else TestOk Char 4; Y:=Field(X, 24, 8 ); % Fourth Byte If Y NEQ 16#67 Then TestErr Char 5 Else TestOk Char 5; Y:=Field(X, 0, 16); % First 16 bit If Y NEQ 16#0123 Then TestErr Char 6 Else TestOk Char 6; Y:=Field(X, 16, 16); % Second 16 bit If Y NEQ 16#4567 Then TestErr Char 7 Else TestOk Char 7; End; Procedure LshiftTest x; Begin Scalar Y; Msg5(Char L,Char S,Char H,Char I,Char F); Msg5(Char T ,Char '! ,Char '! ,Char '! , Char EOL); Y:=Extract(X, 0, BitsPerWord); % FullWord If Y NEQ X Then TestErr Char 1 Else TestOk Char 1; Y:=Extract(X, 0, 8); % First Byte If Y NEQ 16#01 Then TestErr Char 2 Else TestOk Char 2; Y:=Extract(X, 8, 8); % Second Byte If Y NEQ 16#23 Then TestErr Char 3 Else TestOk Char 3; Y:=Extract(X, 16, 8); % Third Byte If Y NEQ 16#45 Then TestErr Char 4 Else TestOk Char 4; Y:=Extract(X, 24, 8 ); % Fourth Byte If Y NEQ 16#67 Then TestErr Char 5 Else TestOk Char 5; Y:=Extract(X, 0, 16); % First 16 bit If Y NEQ 16#0123 Then TestErr Char 6 Else TestOk Char 6; Y:=Extract(X, 16, 16); % Second 16 bit If Y NEQ 16#4567 Then TestErr Char 7 Else TestOk Char 7; End; %%% Signals that Test OK or Error %%%%% Procedure Msg5(C1,C2,C3,C4,C5); <<PutC C1; PutC C2; PutC C3; PutC C4; PutC C5>>; Procedure TestNum X; <<Msg5(Char T,Char Lower e,Char Lower s,Char lower t, Char '! ); PutC X; PutC Char '! ;>>; Procedure TestErr X; <<TestNum X; Msg5(Char E, Char lower r,Char Lower r,Char '! , Char Eol)>>; Procedure TestOk X; <<TestNum X; Msg5(Char O, Char lower k,Char '! ,Char '! , Char Eol)>>; %%% Dynamic Field Extracts %%%%% Procedure MakeMask(N); % Make a mask of N 1's LSH(1,N)-1; Procedure Extract(Z,sbit,lfld); % Dynamic Field Extract Begin scalar m,s; m:=MakeMask(Lfld); s:=Sbit+Lfld-BitsPerWord; Return LAnd(m,Lsh(Z,s)); end; End; |
Added psl-1983/3-1/tests/foo.headers version [abefd6e542].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | SYSLSP PROCEDURE CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 LAP '((!*ENTRY CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 SYSLSP PROCEDURE CODEEVALAPPLYAUX(CODEPTR, ARGLIST, PP-APPLY-LAP 213/3 SYSLSP PROCEDURE BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 SYSLSP PROCEDURE BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 SYSLSP PROCEDURE COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 SYSLSP PROCEDURE FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 SYSLSP PROCEDURE COMPILEDCALLINGINTERPRETEDAUXAUX FN;P-APPLY-LAP 391/8 409 lines, 8 procedures found |
Added psl-1983/3-1/tests/franz-750.tim version [310b7672d0].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("Franz Opus 38, Utah Cs VAX 750 " . " 20-Feb-82") (EmptyTest-10000 . 391) (GEmptyTest-10000 . 3451) (Cdr1Test-100 . 3740) (Cdr2Test-100 . 1309) (CddrTest-100 . 867) (ListOnlyCdrTest1 . 6953) (ListOnlyCddrTest1 . 9435) (ListOnlyCdrTest2 . 21556) (ListOnlyCddrTest2 . 24361) (ReverseTest-10 . 680) (MyReverse1Test-10 . 952) (MyReverse2Test-10 . 714) (LengthTest-100 . 5287) (ArithmeticTest-10000 . 7667) (EvalTest-10000 . 9486) (tak-18-12-6 . 1887) (gtak-18-12-6 . 18853) (gtsta-g0 . 14280) % Use GTSTB (gtsta-g1 . 24956) % GC ) |
Added psl-1983/3-1/tests/franz-780.tim version [98943345ed].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("Franz Opus 37, Mars VAX 780 " . " 30-Mar-83") (EmptyTest-10000 . 230) (GEmptyTest-10000 . 2200) (Cdr1Test-100 . 2280) (Cdr2Test-100 . 910) (CddrTest-100 . 610) (ListOnlyCdrTest1 . 3420) (ListOnlyCddrTest1 . 6900) (ListOnlyCdrTest2 . 12150) (ListOnlyCddrTest2 . 15100) (ReverseTest-10 . 462) (MyReverse1Test-10 . 605) (MyReverse2Test-10 . 490) (LengthTest-100 . 3026) (ArithmeticTest-10000 . 4830) (EvalTest-10000 . 5510) (tak-18-12-6 . 1105) (gtak-18-12-6 . 11696) (gtsta-g0 . 13000) % Estimate from KIM (gtsta-g1 . 18000) % GC overflow ) |
Added psl-1983/3-1/tests/gc-test.red version [3dfcd9135a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GC-TEST.RED - Test of P-COMP-GC Marking primitives % M. L. Griss, 17 June 1983 % MAcros extracted for file, P-COMP-GC.RED On Syslisp; internal WConst GCMarkValue = 8#777, HSkip = Forward; CompileTime << syslsp smacro procedure Mark X; % Get GC mark bits in item X points to GCField @X; syslsp smacro procedure SetMark X; % Set GC mark bits in item X points to GCField @X := GCMarkValue; syslsp smacro procedure ClearMark X; % Clear GC mark bits in item X points to GCField @X := if NegIntP @X then -1 else 0; syslsp smacro procedure Marked X; % Is item pointed to by X marked? Mark X eq GCMarkValue; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; % Relocation primitives syslsp smacro procedure SkipLength X; % Stored in heap header Inf @X; syslsp smacro procedure PutSkipLength(X, L); % Store in heap header Inf @X := L; put('SkipLength, 'Assign!-Op, 'PutSkipLength); >>; internal WConst BitsInSegment = 13, SegmentLength = LShift(1, BitsInSegment), SegmentMask = SegmentLength - 1; %/ External WArray GCArray; CompileTime << syslsp smacro procedure SegmentNumber X; % Get segment part of pointer LShift(X - HeapLowerBound, -BitsInSegment); syslsp smacro procedure OffsetInSegment X; % Get offset part of pointer LAnd(X - HeapLowerBound, SegmentMask); syslsp smacro procedure MovementWithinSegment X; % Reloc field in item GCField @X; syslsp smacro procedure PutMovementWithinSegment(X, M); % Store reloc field GCField @X := M; syslsp smacro procedure ClearMovementWithinSegment X; % Clear reloc field GCField @X := if NegIntP @X then -1 else 0; put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment); syslsp smacro procedure SegmentMovement X; % Segment table GCArray[X]; syslsp smacro procedure PutSegmentMovement(X, M); % Store in seg table GCArray[X] := M; put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement); syslsp smacro procedure Reloc X; % Compute pointer adjustment X - (SegmentMovement SegmentNumber X + MovementWithinSegment X); >>; syslsp procedure testmarking; begin Prin2T "---- Test GC MARK of various HEAP structures ----"; Prin2T " Examine each case carefully, see MARK go on and back off"; Test1Mark cons(1 , 2); % Build a fresh one Test1Mark cons(- 1 , -2); % testing sign extend Test1Mark cons('A, 'B); Test1Mark '[0 1 2 3]; Test1Mark "01234"; TestIdmark 'A; TestIdmark 'JUNK; TestIdmark 'NIL; Prin2T "---- Mark tests all done --- "; End; syslsp procedure Test1Mark X; Begin scalar P; Prin2 ".... Object to mark: "; Print X; P:=Inf X; Prin2 " MARK field: "; Print Mark P; Prin2 " MARKED should be NIL: "; Print Marked P; PrintBits @P; Prin2 " .. SETMARK : "; Print SetMark P; Prin2 " MARK field now: "; Print Mark P; Prin2 " MARKED should be T: "; Print Marked P; PrintBits @P; Prin2 " .. CLEARMARK: "; Print ClearMark P; Prin2 " MARK field finally: "; Print Mark P; Prin2 " MARKED should be NIL: "; Print Marked P; PrintBits @P; Prin2 " .. Object again legal: "; Print X; End; syslsp procedure TestIDMark X; Begin scalar P; Prin2 ".... ID to mark: "; Print X; P:=IDInf X; Prin2 " MARKEDID should be NIL: "; Print MARKEDID P; PrintBits SYMNAM P; Prin2 " .. MARKID : "; Print MarkId P; Prin2 " MARKEDID should be T: "; Print MARKEDID P; PrintBits SYMNAM P; Prin2 " .. CLEARIDMARK: "; Print Clearidmark P; Prin2 " MARKEDID should be NIL: "; Print MARKEDID P; PrintBits SYMNAM P; Prin2 " .. ID again legal: "; Print X; End; syslsp procedure PrintBits x; <<Prin2 " BitPattern: "; Prin2 Tag x; Prin2 ": "; Prin2 Inf x; Terpri(); >>; off syslisp; procedure GCTEST; Begin scalar X,N,M; Prin2T "---- GTEST series -----"; Prin2T ".... Try individual Types first ..."; Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Allocate a PAIR: "; Print (x:=cons(1,2)); Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Release the PAIR: "; Print (X:=NIL); Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Allocate a VECTOR: "; Print (x:=Mkvect(4)); Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Release the VECTOR: "; Print (X:=NIL); Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Allocate a STRING: "; Print (x:=Mkstring(5,65)); Prin2 " Reclaim called: "; Reclaim(); Prin2 " .. Release the STRING: "; Print (X:=NIL); Prin2 " Reclaim called: "; Reclaim(); M:=2; Prin2 ".... Loop until RECLAIM automatically called :"; Prin2 M; Prin2t " times"; N:=GCknt!*+M; Prin2T " .. Loop on PAIRs: "; While GCKnt!* <=N do list(1,2,3,4,5,6,7,8,9,10); N:=GCknt!*+M; Prin2T " .. Loop on VECTORs: "; While GCknt!* <=N do MkVect 5; N:=GCknt!*+M; Prin2T " .. Loop on STRINGs: "; While GCKnt!* <=N do Mkstring(20,65); End; off syslisp; End; |
Added psl-1983/3-1/tests/init8 version [af909e048d].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | (de mkquote(x) (list 'quote x)) (de flag(x y) NIL) (prin2t "sub2.init")(lapin "sub2.init") (prin2t "sub3.init")(lapin "sub3.init") (prin2t "sub4.init")(lapin "sub4.init") (prin2t "sub5a.init")(lapin "sub5a.init") (prin2t "sub5b.init")(lapin "sub5b.init") (prin2t "sub6.init")(lapin "sub6.init") (prin2t "sub7.init")(lapin "sub7.init") (prin2t "sub8.init")(lapin "sub8.init") (prin2t "main8.init")(lapin "main8.init") |
Added psl-1983/3-1/tests/init9 version [a17699b460].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (prin2t "sub2.init")(lapin "sub2.init") (prin2t "sub3.init")(lapin "sub3.init") (prin2t "sub4.init")(lapin "sub4.init") (prin2t "sub5a.init")(lapin "sub5a.init") (prin2t "sub5b.init")(lapin "sub5b.init") (prin2t "sub6.init")(lapin "sub6.init") (prin2t "sub7.init")(lapin "sub7.init") (prin2t "sub8.init")(lapin "sub8.init") (prin2t "sub9.init")(lapin "sub9.init") (prin2t "main9.init")(lapin "main9.init") |
Added psl-1983/3-1/tests/interlisp.tim version [24c538d0ab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 15-Apr-83 17:10:22-MST,2596;000000000001 Return-path: <marti@rand-unix> Received: from RAND-UNIX by UTAH-20; Fri 15 Apr 83 17:10:03-MST Date: Friday, 15 Apr 1983 16:02-PST To: Masinter at PARC-MAXC, hearn at RAND-RELAY, griss at UTAH-20, kessler at UTAH-20 Cc: marti at rand-unix, henry at rand-unix Subject: New Dolphin timinings. From: marti at rand-unix Larry Masinter at Xerox as kindly suggested a number of changes in the Griss timing suite which resulted in the tests running more than 1.4 times faster than previously. Significant speedups resulted from the use of NLISTP rather than ATOM, and APPLY* rather than APPLY. This brings the Dolphin to not quite 1/4 the speed of the Rand Vax 780 running PSL 3.1c. The following are timings for the Griss test suite under various conditions. All times are in milliseconds. Machine: Dolphin, 1.5 megabytes, InterLisp-D Block Standard Improved EmptyTest 10000 360 360 360 SlowEmptyTest 10000 360 360 361 Cdr1Test 100 6497 6497 3884* Cdr2Test 100 2919 2919 2917 CddrTest 100 2411 2410 2404 ListOnlyCdrTest1 20525 20519 20524 ListOnlyCddrTest1 31736 31733 31713 ListOnlyCdrTest2 38786 38778 26295* ListOnlyCddrTest2 49978 49949 37489* ReverseTest 10 4095 6360 6465 MyReverse1Test 10 5087 5405 5023 MyReverse2Test 10 4417 5390 5493 LengthTest 100 8570 8568 8562 ArithmeticTest 10000 12759 14542 14228 EvalTest 10000 15782 15837 15491 tak 18 12 6 4817 4817 4814 gtak 18 12 6 4737 4737 4729 gtsta g0 79000 80874 26708+ gtsta g1 93854 94149 40291+ MKVECT 1000 52630 51850 51047 GETV 10000 432 432 431 PUTV 10000 3807 3808 3807 Total: 443559 450294 313036 Block Compilation: Used (bcompl ...) on standard test file with declarations of local variables and block apply. Standard Compilation: Used (tcompl ...) on standard test file. Improved: * means use of NLISTP rather than ATOM. + means use of APPLY* rather than APPLY. Machine: VAX 11/780, 4 megabytes, PSL V3.1c EmptyTest 10000 34 SlowEmptyTest 10000 646 Cdr1Test 100 1649 Cdr2Test 100 1173 CddrTest 100 1003 ListOnlyCdrTest1 7174 ListOnlyCddrTest1 12869 ListOnlyCdrTest2 9622 ListOnlyCddrTest2 15878 ReverseTest 10 680 MyReverse1Test 10 612 MyReverse2Test 10 697 LengthTest 100 1615 ArithmeticTest 10000 850 EvalTest 10000 5967 tak 18 12 6 714 gtak 18 12 6 4165 gtsta g0 2244 gtsta g1 2397 MKVECT 1000 119 GETV 10000 425 PUTV 10000 442 Total 70975 24-Apr-83 14:13:22-MDT,3391;000000000001 Return-path: <Masinter.PA@PARC-MAXC> Received: from PARC-MAXC by UTAH-20; Sun 24 Apr 83 14:10:12-MDT Date: 24 Apr 83 13:08:50 PDT (Sunday) From: Masinter.PA@PARC-MAXC.ARPA Subject: Re: New Dolphin timinings. In-reply-to: marti's message of Fri, 15 Apr 83 16:02 PST To: marti@rand-unix.ARPA cc: Masinter.PA@PARC-MAXC.ARPA, hearn@RAND-RELAY.ARPA, griss@UTAH-20.ARPA, kessler@UTAH-20.ARPA, henry@rand-unix.ARPA I haven't had a lot of time to spend on this, and I am going to be out of town for the next two weeks. I will comment on your revised figures, and hope that I can get through. To summarize: Averaging the figures for a set of simple benchmarks is nonsense. If you are planning to write a summary of performance of Lisp systems, I suggest you read the paper Dick Gabriel and I put together for the last Lisp conference, and then attempt to measure some of the more important dimensions at the various levels to get an accurate picture of total system performance. You should be careful (by analyzing the compiled code of your benchmarks) to use examples that scale appropriately. Thus, the series of CDR1TEST and CDDRTEST is incomplete until you complete the suite with enough instances to exceed the available register space. Finally, at the very least, you should report a range of performance data, rather than an average, since averages depend so heavily on the weighting you give to each end of the range. You should also be careful to identify the version number of the software and the date when you ran the test. Some minor additional comments about the nature of the "Griss suite": The "Arithmetic Test" is configured such that it operates in the range which is outside of the "small number range" of Interlisp-D (+/- 2^16) but still inside the "small number range" of PSL on the VAX and 9836 (+/- 2^31, no?). Ether larger or smaller would have given figures which were more comperable. On storage allocation: Interlisp-D has two kinds of allocation, of "fixed size" blocks (i.e., DATATYPES which you declare) and of "variable size" blocks. While ARRAY is the allocator for variable sized blocks, you create the fixed size ones with "create". Thus, one 'might' translate MKVECT and PUTV for some applications into the equivalents of (create DATATYPE) and (fetch FIELD --) and (replace FIELD --). I think you will get dramaticly different results if you use those instead. Is the "reverse" in REVERSETEST handcoded? Why is ReverseTest slower on the VAX/PSL than MyReverse? In Interlisp-D, you cannot "turn off" the overhead for the reference count GC: every operation, including CONS, does reference counting. There is in addition some time associated with "RECLAIM" which is the time to thread items onto the free list. However, we've found for most serious programs which have resident large address space data (e.g., AI systems which might have a "knowledge base" or a set of theorems or some reformulation rules rather than simple benchmarks) that it was important that GC time be proportional to the amount of garbage rather than the size of the address space. Several of the benchmarks you quote do significant amounts of CONSing however, do not include GC time. Of course, GC time can be highly variable under most GC algorithms because it is proportional to the size of the address space. Larry 26-Apr-83 20:58:56-MDT,1436;000000000001 Return-path: <@UTAH-CS:GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Tue 26 Apr 83 20:58:35-MDT Date: 25 Apr 1983 2005-PDT From: GRISS@HP-HULK Subject: Marti's latest Message-Id: <420175670.20672.hplabs@HP-VENUS> Received: by HP-VENUS via CHAOSNET; 25 Apr 1983 20:27:49-PDT Received: by UTAH-CS.ARPA (3.320.6/3.7.8) id AA03294; 26 Apr 83 20:53:59 MDT (Tue) To: kessler@HP-VENUS, griss@HP-VENUS NIL RATIO FASTDOLPHIN STD20 EMPTYTEST-10000 20.000 GEMPTYTEST-10000 1.286 CDR1TEST-100 7.398 CDR2TEST-100 7.847 CDDRTEST-100 8.799 LISTONLYCDRTEST1 11.531 LISTONLYCDDRTEST1 9.356 LISTONLYCDRTEST2 9.664 LISTONLYCDDRTEST2 9.113 REVERSETEST-10 15.453 MYREVERSE1TEST-10 18.813 MYREVERSE2TEST-10 17.955 LENGTHTEST-100 15.088 ARITHMETICTEST-10000 21.516 EVALTEST-10000 8.224 TAK-18-12-6 9.771 GTAK-18-12-6 2.398 GTSTA-G0 36.437 GTSTA-G1 50.427 NIL (TOTAL (RATIO FASTDOLPHIN STD20)): Tot 281.075, avg 14.793, dev 11.423 , 19.000 tests NIL As you see, variation tremendous. ------- |
Added psl-1983/3-1/tests/io-data.red version [7c724c47fb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-DATA.RED - Data structures used by input and output % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 21 September 1981 % Copyright (c) 1981 Eric Benson % on SysLisp; WConst ChannelClosed = 0, ChannelOpenRead = 1, ChannelOpenWrite = 2, ChannelOpenSpecial = 3; internal WConst MaxTokenSize = 5000; exported WString TokenBuffer[MaxTokenSize]; exported WConst MaxChannels = 31; exported WArray ReadFunction = ['TerminalInputHandler, 'WriteOnlyChannel, 'WriteOnlyChannel, 'CompressReadChar, 'WriteOnlyChannel, 'WriteOnlyChannel, 'WriteOnlyChannel, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], WriteFunction = ['ReadOnlyChannel, 'IndependentWriteChar, 'ToStringWriteChar, 'ExplodeWriteChar, 'FlatSizeWriteChar, 'IndependentWriteChar, 'IndependentWriteChar, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], CloseFunction = ['IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], UnReadBuffer[MaxChannels], LinePosition[MaxChannels], MaxLine = [0, 80,80, 10000, 10000, 80, 80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], ChannelStatus = [ChannelOpenRead, ChannelOpenWrite, ChannelOpenSpecial, ChannelOpenSpecial, ChannelOpenSpecial, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed], MaxBuffer [MaxChannels], ChannelTable [MaxChannels], NextPosition [MaxChannels], BufferLength [MaxChannels]; off SysLisp; global '(!$EOL!$); LoadTime(!$EOL!$ := '! ); END; |
Added psl-1983/3-1/tests/irewrite.sl version [492e3d8e51].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}IREWRITE.PSL;2 6-JAN-83 10:08:06 (FLUID '(unify-subst)) (FLAG '( ADD-LEMMA ADD-LEMMA-LST Apply-subst Apply-subst-lst false one-way-unify one-way-unify1 one-way-unify1-lst ptime rewrite rewrite-with-lemmas tautologyP tautp trans-of-implies trans-of-implies1 truep ) 'InternalFunction) (DE ADD-LEMMA (TERM) (COND ((AND (NOT (ATOM TERM)) (EQ (CAR TERM) 'EQUAL) (NOT (ATOM (CADR TERM)))) (PUT (CAR (CADR TERM)) 'LEMMAS (CONS TERM (GET (CAR (CADR TERM)) 'LEMMAS)))) (T (ERROR 0 (LIST 'ADD-LEMMA-DID-NOT-LIKE-TERM TERM))))) (DE ADD-LEMMA-LST (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST))))) % lmm 7-JUN-81 10:07 (DE APPLY-SUBST (ALIST TERM) (COND ((NOT (PAIRP TERM)) ((LAMBDA (TEM) (COND (TEM (CDR TEM)) (T TERM))) (ASSOC TERM ALIST))) (T (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION (LAMBDA (X) (APPLY-SUBST ALIST X)))))))) (DE APPLY-SUBST-LST (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST)))))) (DE FALSEP (X LST) (OR (EQUAL X '(F)) (MEMBER X LST))) (DE ONE-WAY-UNIFY (TERM1 TERM2) (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2))) % lmm 7-JUN-81 09:47 (DE ONE-WAY-UNIFY1 (TERM1 TERM2) (COND ((NOT (PAIRP TERM2)) ((LAMBDA (TEM) (COND (TEM (EQUAL TERM1 (CDR TEM))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) (ASSOC TERM2 UNIFY-SUBST))) ((NOT (PAIRP TERM1)) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL))) (DE ONE-WAY-UNIFY1-LST (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL))) (DE PTIME NIL (PROG (GCTM) (SETQ GCTM 0) (RETURN (CONS (time) GCTM)))) % lmm 7-JUN-81 10:04 (DE REWRITE (TERM) (COND ((NOT (PAIRP TERM)) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION REWRITE))) (GET (CAR TERM) 'LEMMAS))))) (DE REWRITE-WITH-LEMMAS (TERM LST) (COND ((NULL LST) TERM) ((ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST))))) (T (REWRITE-WITH-LEMMAS TERM (CDR LST))))) (DE SETUP NIL (ADD-LEMMA-LST '((EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL)))) (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) (EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F)))) (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) (EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (SUB1 X)))) (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) (EQUAL (PRIME X) (AND (NOT (ZEROP X)) (NOT (EQUAL X (ADD1 (ZERO)))) (PRIME1 X (SUB1 X)))) (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) (EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X)))) (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) (EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y)))) (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUS J K)) (TIMES (EXP I J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) (EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE)))) (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) (EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1))))) (EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y)))) (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) (EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A))))) (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) (EQUAL (TIMES X (DIFFERENCE C W)) (DIFFERENCE (TIMES C X) (TIMES W X))) (EQUAL (REMAINDER (TIMES X Z) Z) (ZERO)) (EQUAL (DIFFERENCE (PLUS B (PLUS A C)) A) (PLUS B C)) (EQUAL (DIFFERENCE (ADD1 (PLUS Y Z)) Z) (ADD1 Y)) (EQUAL (LESSP (PLUS X Y) (PLUS X Z)) (LESSP Y Z)) (EQUAL (LESSP (TIMES X Z) (TIMES Y Z)) (AND (NOT (ZEROP Z)) (LESSP X Y))) (EQUAL (LESSP Y (PLUS X Y)) (NOT (ZEROP X))) (EQUAL (GCD (TIMES X Z) (TIMES Y Z)) (TIMES Z (GCD X Y))) (EQUAL (VALUE (NORMALIZE X) A) (VALUE X A)) (EQUAL (EQUAL (FLATTEN X) (CONS Y (NIL))) (AND (NLISTP X) (EQUAL X Y))) (EQUAL (LISTP (GOPHER X)) (LISTP X)) (EQUAL (SAMEFRINGE X Y) (EQUAL (FLATTEN X) (FLATTEN Y))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) (ZERO)) (AND (OR (ZEROP Y) (EQUAL Y 1)) (EQUAL X (ZERO)))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) 1) (EQUAL X 1)) (EQUAL (NUMBERP (GREATEST-FACTOR X Y)) (NOT (AND (OR (ZEROP Y) (EQUAL Y 1)) (NOT (NUMBERP X))))) (EQUAL (TIMES-LIST (APPEND X Y)) (TIMES (TIMES-LIST X) (TIMES-LIST Y))) (EQUAL (PRIME-LIST (APPEND X Y)) (AND (PRIME-LIST X) (PRIME-LIST Y))) (EQUAL (EQUAL Z (TIMES W Z)) (AND (NUMBERP Z) (OR (EQUAL Z (ZERO)) (EQUAL W 1)))) (EQUAL (GREATEREQPR X Y) (NOT (LESSP X Y))) (EQUAL (EQUAL X (TIMES X Y)) (OR (EQUAL X (ZERO)) (AND (NUMBERP X) (EQUAL Y 1)))) (EQUAL (REMAINDER (TIMES Y X) Y) (ZERO)) (EQUAL (EQUAL (TIMES A B) 1) (AND (NOT (EQUAL A (ZERO))) (NOT (EQUAL B (ZERO))) (NUMBERP A) (NUMBERP B) (EQUAL (SUB1 A) (ZERO)) (EQUAL (SUB1 B) (ZERO)))) (EQUAL (LESSP (LENGTH (DELETE X L)) (LENGTH L)) (MEMBER X L)) (EQUAL (SORT2 (DELETE X L)) (DELETE X (SORT2 L))) (EQUAL (DSORT X) (SORT2 X)) (EQUAL (LENGTH (CONS X1 (CONS X2 (CONS X3 (CONS X4 (CONS X5 (CONS X6 X7))))))) (PLUS 6 (LENGTH X7))) (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)) (EQUAL (QUOTIENT (PLUS X (PLUS X Y)) 2) (PLUS X (QUOTIENT Y 2))) (EQUAL (SIGMA (ZERO) I) (QUOTIENT (TIMES I (ADD1 I)) 2)) (EQUAL (PLUS X (ADD1 Y)) (IF (NUMBERP Y) (ADD1 (PLUS X Y)) (ADD1 X))) (EQUAL (EQUAL (DIFFERENCE X Y) (DIFFERENCE Z Y)) (IF (LESSP X Y) (NOT (LESSP Y Z)) (IF (LESSP Z Y) (NOT (LESSP Y X)) (EQUAL (FIX X) (FIX Z))))) (EQUAL (MEANING (PLUS-TREE (DELETE X Y)) A) (IF (MEMBER X Y) (DIFFERENCE (MEANING (PLUS-TREE Y) A) (MEANING X A)) (MEANING (PLUS-TREE Y) A))) (EQUAL (TIMES X (ADD1 Y)) (IF (NUMBERP Y) (PLUS X (TIMES X Y)) (FIX X))) (EQUAL (NTH (NIL) I) (IF (ZEROP I) (NIL) (ZERO))) (EQUAL (LAST (APPEND A B)) (IF (LISTP B) (LAST B) (IF (LISTP A) (CONS (CAR (LAST A)) B) B))) (EQUAL (EQUAL (LESSP X Y) Z) (IF (LESSP X Y) (EQUAL T Z) (EQUAL F Z))) (EQUAL (ASSIGNMENT X (APPEND A B)) (IF (ASSIGNEDP X A) (ASSIGNMENT X A) (ASSIGNMENT X B))) (EQUAL (CAR (GOPHER X)) (IF (LISTP X) (CAR (FLATTEN X)) (ZERO))) (EQUAL (FLATTEN (CDR (GOPHER X))) (IF (LISTP X) (CDR (FLATTEN X)) (CONS (ZERO) (NIL)))) (EQUAL (QUOTIENT (TIMES Y X) Y) (IF (ZEROP Y) (ZERO) (FIX X))) (EQUAL (GET J (SET I VAL MEM)) (IF (EQP J I) VAL (GET J MEM)))))) % lmm 7-JUN-81 09:44 (DE TAUTOLOGYP (X TRUE-LST FALSE-LST) (COND ((TRUEP X TRUE-LST) T) ((FALSEP X FALSE-LST) NIL) ((NOT (PAIRP X)) NIL) ((EQ (CAR X) 'IF) (COND ((TRUEP (CADR X) TRUE-LST) (TAUTOLOGYP (CADDR X) TRUE-LST FALSE-LST)) ((FALSEP (CADR X) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST FALSE-LST)) (T (AND (TAUTOLOGYP (CADDR X) (CONS (CADR X) TRUE-LST) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST (CONS (CADR X) FALSE-LST)))))) (T NIL))) (DE TAUTP (X) (TAUTOLOGYP (REWRITE X) NIL NIL)) (DE TEST NIL (PROG (TM1 TM2 ANS TERM) (SETQ TM1 (PTIME)) (SETQ TERM (APPLY-SUBST '((X F (PLUS (PLUS A B) (PLUS C (ZERO)))) (Y F (TIMES (TIMES A B) (PLUS C D))) (Z F (REVERSE (APPEND (APPEND A B) (NIL)))) (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B)))) '(IMPLIES (AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W)))) (IMPLIES X W)))) (SETQ ANS (TAUTP TERM)) (SETQ TM2 (PTIME)) (RETURN (LIST ANS (DIFFERENCE (CAR TM2) (CAR TM1)) (DIFFERENCE (CDR TM2) (CDR TM1)))))) (DE TRANS-OF-IMPLIES (N) (LIST 'IMPLIES (TRANS-OF-IMPLIES1 N) (LIST 'IMPLIES 0 N))) (DE TRANS-OF-IMPLIES1 (N) (COND ((EQUAL N 1) (LIST 'IMPLIES 0 1)) (T (LIST 'AND (LIST 'IMPLIES (SUB1 N) N) (TRANS-OF-IMPLIES1 (SUB1 N)))))) (DE TRUEP (X LST) (OR (EQUAL X '(T)) (MEMBER X LST))) |
Added psl-1983/3-1/tests/laptest-alm.lap version [4ad534b790].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (LAP '( (*ENTRY FOO1 EXPR 1) (*ALLOC 0) (*EXIT 0) )) (LAP '( (*ENTRY FOO2 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 1) (REG 1)) (*EXIT 0) )) (LAP '( (*ENTRY FOO3 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 3) (REG 2)) (*LINKE 0 PLUS2 EXPR 2) )) (LAP '( (*ENTRY FOO4 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 4) (REG 2)) (*LINK PLUS2 EXPR 2) (*LINKE 0 PRINT EXPR 1) )) (LAP '( (*ENTRY FOO5 EXPR 1) (*ALLOC 0) (*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE 1)) (*MOVE (QUOTE ONE) (REG 1)) (*EXIT 0) (*LBL (LABEL G0004)) (*MOVE (QUOTE NOT-ONE) (REG 1)) (*EXIT 0) )) (FLUID (QUOTE (FLU1 FLU2))) (LAP '( (*ENTRY FOO6A EXPR 2) (*ALLOC 0) (*LAMBIND (REGISTERS (REG 2) (REG 1)) (NONLOCALVARS ($FLUID FLU2) ($FLUID FLU1)) ) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE BEFORE) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE 10) ($FLUID FLU1)) (*MOVE (QUOTE 20) ($FLUID FLU2)) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE AFTER) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE NIL) (REG 1)) (*FREERSTR (NONLOCALVARS ($FLUID FLU2) ($FLUID FLU1))) (*EXIT 0) )) (LAP '( (*ENTRY FOO6 EXPR 0) (*ALLOC 0) (*MOVE (QUOTE 1) ($FLUID FLU1)) (*MOVE (QUOTE 2) ($FLUID FLU2)) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE BEFORE) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE B) (REG 2)) (*MOVE (QUOTE A) (REG 1)) (*LINK FOO6A EXPR 2) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE AFTER) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE NIL) (REG 1)) (*EXIT 0) )) |
Added psl-1983/3-1/tests/laptest-tlm-20.lap version [21ce522e87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (LAP '( (FULLWORD 1) (*ENTRY FOO1 EXPR 1) (POPJ (REG ST) 0) )) (LAP '( (FULLWORD 1) (*ENTRY FOO2 EXPR 1) (HRRZI (REG 1) 1) (POPJ (REG ST) 0) )) (LAP '( (FULLWORD 1) (*ENTRY FOO3 EXPR 1) (HRRZI (REG 2) 3) (JRST (ENTRY PLUS2)) )) (LAP '( (FULLWORD 1) (*ENTRY FOO4 EXPR 1) (HRRZI (REG 2) 4) (PUSHJ (REG ST) (ENTRY PLUS2)) (JRST (ENTRY PRINT)) )) (LAP '( (FULLWORD 1) (*ENTRY FOO5 EXPR 1) (CAIE (REG 1) 1) (JRST G0004) (MOVE (REG 1) L0001) (POPJ (REG ST) 0) G0004 (MOVE (REG 1) L0002) (POPJ (REG ST) 0) L0002 (FULLWORD (MKITEM 30 (IDLOC NOT-ONE))) L0001 (FULLWORD (MKITEM 30 (IDLOC ONE))) )) (FLUID (QUOTE (FLU1 FLU2))) (LAP '( (FULLWORD 2) (*ENTRY FOO6A EXPR 2) (JSP (REG T5) (ENTRY FASTBIND)) (HALFWORD 2 (IDLOC FLU2)) (HALFWORD 1 (IDLOC FLU1)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0003) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (HRRZI (REG T1) 10) (MOVEM (REG T1) ($FLUID FLU1)) (HRRZI (REG T1) 20) (MOVEM (REG T1) ($FLUID FLU2)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0004) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 1) (REG NIL)) (JSP (REG T5) (ENTRY FASTUNBIND)) (FULLWORD 2) (POPJ (REG ST) 0) L0004 (FULLWORD (MKITEM 30 (IDLOC AFTER))) L0003 (FULLWORD (MKITEM 30 (IDLOC BEFORE))) )) (LAP '( (FULLWORD 0) (*ENTRY FOO6 EXPR 0) (HRRZI (REG T1) 1) (MOVEM (REG T1) ($FLUID FLU1)) (HRRZI (REG T1) 2) (MOVEM (REG T1) ($FLUID FLU2)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0005) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 2) L0006) (MOVE (REG 1) L0007) (PUSHJ (REG ST) (ENTRY FOO6A)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0008) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 1) (REG NIL)) (POPJ (REG ST) 0) L0008 (FULLWORD (MKITEM 30 (IDLOC AFTER))) L0007 (FULLWORD (MKITEM 30 (IDLOC A))) L0006 (FULLWORD (MKITEM 30 (IDLOC B))) L0005 (FULLWORD (MKITEM 30 (IDLOC BEFORE))) )) |
Added psl-1983/3-1/tests/laptest.red version [eb02f4cb86].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % LAPTEST.RED - A selection of small procedures for testing LAP % MLG % Run through LAPOUT for CMACRO (ALM) level, % and turn on DOPASS1LAP for TLM level. procedure foo1 x; x; procedure foo2 x; 1; procedure foo3 x; x+3; procedure foo4 x; print(x+4); procedure foo5 x; if x=1 then 'one else 'not!-one; FLUID '(FLU1 FLU2); procedure foo6a(Flu1,Flu2); begin Print List('before,FLU1,Flu2); Flu1:=10; Flu2:=20; Print List('after,FLU1,Flu2); end; procedure foo6(); <<Flu1:=1; Flu2 :=2; Print List('before,FLU1,Flu2); Foo6a('a,'b); Print List('after,FLU1,Flu2); >>; End; |
Added psl-1983/3-1/tests/lm2-hp.tim version [76f1ee52b0].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("LM2, by Letsinger at HP, 25 February") (EmptyTest-10000 . 171) (GEmptyTest-10000 . 171) (Cdr1Test-100 . 2096) (Cdr2Test-100 . 2063) (CddrTest-100 . 1338) (ListOnlyCdrTest1 . 10826) (ListOnlyCddrTest1 . 15442) (ListOnlyCdrTest2 . 10877) (ListOnlyCddrTest2 . 15486) (ReverseTest-10 . 1027) (MyReverse1Test-10 . 995) (MyReverse2Test-10 . 950) (LengthTest-100 . 671) (ArithmeticTest-10000 . 5845) (EvalTest-10000 . 13468) (tak-18-12-6 . 3190) (gtak-18-12-6 . 3186) (gtsta-g0 . 5333) (gtsta-g1 . 5836) ) |
Added psl-1983/3-1/tests/main0.red version [95addc9ce7].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MAIN0.RED - A "trivial" file of ALM level LAP to test basic set of % tools: LAP-TO-ASM mostly, and CMACROs LAP '((!*ENTRY DummyFunctionDefinition Expr 1) (!*ALLOC 0) (!*MOVE (REG 1) (REG 2)) (!*EXIT 0)); END; |
Added psl-1983/3-1/tests/main1.red version [b772c3060d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Simple 1 file test % This is program MAIN1.RED IN "XXX-HEADER.RED"$ On SYSLISP; Procedure FirstCall; <<Init(); PutC Char F; PutC Char !a; PutC Char !c; PutC Char !=; PutInt Ifact 10; Terpri(); PutC Char T; PutC Char !e; PutC Char !s; PutC Char !t; PutC Char F; PutC Char !a; PutC Char !c; PutC Char !t; Terpri(); TestFact(); Terpri(); PutC Char T; PutC Char !e; PutC Char !s; PutC Char !t; PutC Char T; PutC Char !a; PutC Char !k; Terpri(); TestTak(); Quit;>>; procedure terpri(); PutC Char EOL; Procedure TestFact(); << PutInt Timc(); Terpri(); ArithmeticTest 10000; PutInt Timc(); Terpri(); >>; Procedure ArithmeticTest (N); begin scalar I; I:= 0; loop: if Igreaterp(I,N) then return NIL; Fact 9; I := iadd1 I; goto loop end; procedure TestTak(); <<PutInt Timc(); Terpri(); PutInt TopLevelTak (18,12,6); Terpri(); PutInt Timc(); Terpri();>>; syslsp procedure Fact (N); If ilessp(N,2) then 1 else LongTimes(N,Fact isub1 N); syslsp procedure Ifact u; Begin scalar m; m:=1; L1: if u eq 1 then return M; M:=LongTimes(U,M); u:=u-1; PutInt(u); Terpri(); PutInt(M); Terpri(); goto L1; end; in "pt:tak.sl"$ off syslisp; procedure UndefinedFunctionAux; <<Putc Char U; Putc Char !n; Putc Char !d; Putc Char !e; Putc Char !f; Putc Char Blank; Putint UndefnCode!*; Terpri(); Quit;>>; end; |
Added psl-1983/3-1/tests/main2.red version [7009645941].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN2.RED - Test Byte and String I/O, some PRINT ing % Need: SUB2.RED simple print routines IN "XXX-HEADER.RED"$ on SysLisp; % some strings to work with WString TestString = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUnVvWwXxYyZz"; Wstring Buffer[100]; syslsp Procedure FirstCall; begin scalar X, Y; init(); % test STRINF Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char I; Putc Char Lower n ; Putc Char Lower f; Putc Char Eol; X:=TestString; Y:=StrInf(X); PutInt X; PutC Char '! ; PutInt Y;PutC Char EOL; % test STrlen Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char Lower l; Putc Char Lower e; Putc Char Lower n; Putc Char Eol; X:=StrLen(testString); PutInt X;PutC Char '! ;PutInt 51;PutC Char EOL; % test Byte access. X:=TestString+AddressingUnitsPerItem; Putc Char B; PutC Char Lower y; PutC Char Lower t; Putc Char Lower e; Putc Char Eol; For i:=0:10 do <<Y:=Byte(X,i); PutInt i; PutC Char '! ; PutInt Y; PutC Char '! ; PutC Y; PutC Char EOL>>; % Now a string: Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char Lower i; Putc Char Lower n; Putc Char Lower g; Putc Char Eol; Prin2String TestString; Terpri(); Prin1String "----- Now input characters until #"; Terpri(); while (X := GetC X) neq char !# do PutC X; Print '"----- First Print Called"; Print '1; Print 'ANATOM; Print '( 1 . 2 ); Print '(AA (B1 . B2) . B3); Print '(AA (B1 . NIL) . NIL); Prin2T "Expect UNDEFINED FUNCTION MESSAGE for a function of 3 arguments"; ShouldNotBeThere(1,2,3); quit; end; Fluid '(UndefnCode!* UndefnNarg!*); syslsp procedure UndefinedFunctionAux; % Should preserve all regs <<Terpri(); Prin2String "**** Undefined Function: "; Prin1ID LispVar UndefnCode!*; Prin2String " , called with "; Prin2 LispVar UndefnNarg!*; Prin2T " arguments"; Quit;>>; Off syslisp; End; |
Added psl-1983/3-1/tests/main3.red version [886cec5eb1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN3.RED - Test CASE and CONS % Need: SUB2.RED simple print routines % SUB3.RED simple allocator IN "XXX-HEADER.RED"$ IN "PT:STUBS3.RED"$ on syslisp; syslsp Procedure FirstCall; begin scalar X, Y; Init(); Print '"MAIN3: Casetest"$ CaseTest(); Print '"MAIN3: test CONS"$ InitHeap(); ConsTest(); quit; end; syslsp procedure CaseTest; <<Prin2t '"Test case from -1 to 11"; Prin2t '"Will classify argument"; Ctest (-1); Ctest 0; Ctest 1; Ctest 2; Ctest 3; Ctest 4; Ctest 5; Ctest 6; Ctest 7; Ctest 8; Ctest 9; Ctest 10; Ctest 11; Ctest 12>>; syslsp procedure CTest N; Case N of 0: Show(N,"0 case"); 1,2,3: Show(N,"1,2,3 case"); 6 to 10:Show(N,"6 ... 10 case"); default:Show(N,"default case"); end; syslsp procedure Show(N,S); <<Prin2String "Show for N="; Prin1Int N; Prin2String ", expect "; Prin2String S; Terpri()>>; Procedure CONStest(); Begin scalar Z,N; Z:='1; N:='2; While N<10 do <<z:=cons(N,z); Print z; N:=N+1>>; End; FLUID '(UndefnCode!* UndefnNarg!*); syslsp procedure UndefinedFunctionAux; % Should preserve all regs <<Terpri(); Prin2String "**** Undefined Function: "; Prin1ID LispVar UndefnCode!*; Prin2String " , called with "; Prin2 LispVar UndefnNarg!*; Prin2T " arguments"; Quit;>>; Off syslisp; End; |
Added psl-1983/3-1/tests/main4.red version [f6e132ce95].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN4.RED : Test Mini reader and function primitives, % needs IO, SUB2, SUB3 and SUB4 IN "xxx-header.red"$ In "PT:P-function-primitives.red"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS3.RED"$ on syslisp; Compiletime GLOBAL '(DEBUG); Procedure FirstCall; Begin scalar x,s1,s2,s3, Done,D1,D2; Init(); InitHeap(); InitObList(); LispVar(DEBUG) := 'T; % To get ID stuff out Dashed "Test EQSTR"; s1:='"AB"; s2:='"Ab"; s3:='"ABC"; ShouldBe("EqStr(AB,AB)",EqStr(s1,s1),'T); ShouldBe("EqStr(AB,AB)",EqStr(s1,"AB"),'T); ShouldBe("EqStr(AB,Ab)",EqStr(s1,s2),'NIL); ShouldBe("EqStr(AB,ABC)",EqStr(s1,s3),'NIL); Dashed "Test Intern on existing ID's"; ShouldBe("Intern(A)",Intern "A", 'A); ShouldBe("Intern(AB)",Intern S1, 'AB); Dashed "Test Intern on new ID, make sure same place"; D1:=Intern S3; ShouldBe("Intern(ABC)",Intern("ABC"),D1); D2:=Intern "FOO"; ShouldBe("Intern(ABC) again",Intern("ABC"),D1); Dashed "Test RATOM loop. Type various ID's, STRING's and INTEGER's"; MoreStuff(); InitRead(); While Not Done do <<x:=Ratom(); prin2 "Item read="; Prtitm x; Print x; if x eq 'Q then Done := 'T;>>; LispVar(DEBUG) := 'NIL; % Turn off PRINT Dashed "Test READ loop. Type various S-expressions"; MoreStuff(); Done:= 'NIL; While Not Done do <<x:=READ(); Prin2 '" Item read="; Prtitm x; Print x; if x eq 'Q then Done := 'T;>>; Functiontest(); Quit; End; Procedure MoreStuff; <<Spaced "Move to next part of test by typing the id Q"; Spaced "Inspect printout carefully">>; Fluid '(CodePtr!* CodeForm!* CodeNarg!*); procedure FunctionTest(); Begin scalar c1,c2,ID1,x; Dashed "Tests of FUNCTION PRIMITIVES "; ShouldBe("FunBoundP(Compiled1)",FunBoundP 'Compiled1,NIL); ShouldBe("FunBoundP(ShouldBeUnbound)",FunBoundP 'ShouldBeUnBound,T); ShouldBe("FCodeP(Compiled1)",FCodeP 'Compiled1,T); ShouldBe("FCodeP(ShouldBeUnbound)",FcodeP 'ShouldBeUnBound,NIL); ShouldBe("FCodeP(Compiled2)",FCodeP 'Compiled2,T); Dashed "Now MakeFunBound"; MakeFunBound('Compiled2); ShouldBe("FCodeP(Compiled2)",FCodeP 'Compiled2,NIL); ShouldBe("FUnBoundP(Compiled2)",FUnBoundP 'Compiled2,T); Dashed "Now copy CODEPTR of Compiled1 to Compiled2 "; C1:=GetFCodePointer('Compiled1); C2:=GetFCodePointer('Compiled2); ShouldBe("CodeP(C1)",CodeP C1,T); ShouldBe("CodeP(C2)",CodeP C2,NIL); MakeFcode('Compiled2,C1); ShouldBe("C1=GetFcodePointer 'Compiled2", C1=GetFCodePointer 'Compiled2,T); ShouldBe("Compiled2()",Compiled2(),12345); Dashed "Now test CodePrimitive"; CodePtr!* := GetFCodePointer 'Compiled3; X:= CodePrimitive(10,20,30,40); Shouldbe(" X=1000",1000,X); Dashed "Test CompiledCallingInterpreted hook"; CompiledCallingInterpreted(); Dashed "Now Create PRETENDINTERPRETIVE"; MakeFlambdaLink 'PretendInterpretive; Shouldbe("FlambdaLinkP",FlambdaLinkP 'PretendInterpretive,T); Shouldbe("Fcodep",FCodeP 'PretendInterpretive,NIL); Shouldbe("FUnBoundP",FUnBoundP 'PretendInterpretive,NIL); Dashed "Now call PRETENDINTERPRETIVE"; x:=PretendInterpretive(500,600); ShouldBe("PretendInterpretive",x,1100); End; % Auxilliary Compiled routines for CodeTests: Procedure Compiled1; << Dotted "Compiled1 called"; 12345>>; Procedure Compiled2; << Dotted"Compiled2 called"; 67890>>; Procedure Compiled3(A1,A2,A3,A4); <<Dotted "Compiled3 called with 4 arguments , expect 10,20,30,40"; Prin2 " A1=";Prin2T A1; Prin2 " A2=";Prin2T A2; Prin2 " A3=";Prin2T A3; Prin2 " A4=";Prin2T A4; Prin2t "Now return 1000 to caller"; 1000>>; syslsp procedure UndefinedFunctionAuxAux ; Begin scalar FnId; FnId := MkID UndefnCode!*; Prin2 "Undefined Function "; Prin1 FnId; Prin2 " called with "; Prin2 LispVar UndefnNarg!*; prin2T " args from compiled code"; Quit; End; % some primitives use by FastApply syslsp procedure CompiledCallingInterpretedAux(); Begin scalar FnId,Nargs; Prin2t "COMPILED Calling INTERPRETED"; Prin2 "CODEFORM!*= "; Print LispVar CodeForm!*; Nargs:=LispVar CodeNarg!*; FnId := MkID LispVar CodeForm!*; Prin2 "Function: "; Prin1 FnId; Prin2 " called with "; Prin2 Nargs; prin2T " args from compiled code"; Return 1100; End; Off syslisp; End; |
Added psl-1983/3-1/tests/main4.sym version [de0ae8e130].
> > > > > | 1 2 3 4 5 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE NIL)) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 129)) (SETQ STRINGGENSYM!* (QUOTE "L0000")) |
Added psl-1983/3-1/tests/main5.red version [f56883e9bd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN5.RED : Small READ-EVAL-PRINT Loop % Needs IO, SUB2, SUB3, SUB4, SUB5 IN "xxx-header.red"$ IN "PT:STUBS3.RED"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS5.RED"$ on syslisp; Compiletime FLUID '(DEBUG FnTypeList !*RAISE !$EOF!$ !*PVAL !*ECHO); Procedure FirstCall; Begin scalar x, Done, Hcount; Init(); InitHeap(); InitObList(); TestGet(); InitEval(); Prin2t '"(very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q"; Prin2T '" !*RAISE and !*PVAL have been set T"; Prin2T '" Should be able to execute any COMPILED expressions"; Prin2T '" typed in. Run (TESTSERIES) when ready"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!$EOF!$) := MkID Char EOF$ Hcount :=0; LispVar(!*RAISE) := 'T; % Upcase input IDs While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x eq 'Q then Done := 'T else if x eq !$EOF!$ then <<terpri(); Prin2T " **** Top Level EOF ****">> else <<Terpri(); x:=EVAL x; If LISPVAR(!*PVAL) then Print x>>; >>; Quit; End; % ---- Test Routines: syslsp procedure TestSeries(); <<Dashed "TESTs called by TESTSERIES"; TestUndefined()>>; syslsp procedure TestGet(); Begin Dashed "Tests of GET and PUT"; Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),NIL); Shouldbe("PUT('FOO,'FEE,'FUM)",PUT('FOO,'FEE,'FUM),'FUM); Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),'FUM); Shouldbe("REMPROP('FOO,'FEE)",REMPROP('FOO,'FEE),'FUM); Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),NIL); end; syslsp procedure TestUndefined; <<Print "Calling SHOULDBEUNDEFINED"; ShouldBeUndefined(1)>>; % Some dummies: procedure UnbindN N; Stderror '"UNBIND only added at MAIN6"; procedure Lbind1(x,y); StdError '"LBIND1 only added at MAIN6"; Off syslisp; End; |
Added psl-1983/3-1/tests/main6.red version [13cb7c0bd6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN6.RED : Small READ-EVAL-PRINT Loop, Binding test % Needs IO, SUB2, SUB3, SUB4, SUB5, SUB6 % Added REsult after FREErstr check IN "xxx-header.red"$ IN "PT:STUBS3.RED"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS5.RED"$ IN "PT:STUBS6.RED"$ on syslisp; Compiletime GLOBAL '(DEBUG !*RAISE !$EOF!$); Procedure FirstCall; Begin scalar x, Done, Hcount; Init(); InitHeap(); InitObList(); InitEval(); Prin2t '"MINI-PSL: A Read-Eval-Print Loop, terminate with Q"; Prin2T '" !*RAISE has been set T"; Prin2T '" Run (TESTSERIES) to check BINDING etc"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t " .... Now Call INITCODE"; InitCode(); Prin2t " .... Return from INITCode, Now toploop"; While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x eq 'Q then Done := 'T else if x = !$EOF!$ then <<Terpri(); Prin2T " **** Top Level EOF **** ">> else <<Terpri(); x:=EVAL x; Print x>>; >>; Quit; End; CompileTime FLUID '(AA); Procedure TESTSERIES(); Begin BindingTest(); InterpTest(); CompBindTest(); End; Procedure BindingTest; Begin Dashed "Test BINDING Primitives"$ LispVar(AA):=1; PBIND1('AA); % Save the 1, insert a NIL LBIND1('AA,3); % save the NIL, insert a 3 ShouldBe('"3rd bound AA",LispVar(AA),3); UnBindN 1; ShouldBe('"2rd bound AA",LispVar(AA),NIL); UnBindN 1; ShouldBe('"Original AA",LispVar(AA),1); End; Global '(Lambda1 Lambda2 CodeForm!*); Procedure InterpTest(); Begin Dashed "TEST of Interpreter Primitives for LAMBDA's "; Lambda1:='(LAMBDA (X1 X2) (PRINT (LIST 'LAMBDA1 X1 X2)) 'L1); Lambda2:='(LAMBDA (Y1 Y2) (PRINT (LIST 'LAMBDA2 Y1 Y2)) 'L2); Spaced "LAMBDA1: "; Print Lambda1; Dashed "FastLambdaApply on Lambda1"; CodeForm!*:=Lambda1; ShouldBe("FastLambdaApply", FastLambdaApply(10,20),'L1); Dashed "Now Test FASTAPPLY"; TestApply(" Compiled ID 1 ", 'Compiled1,'C1); TestApply(" CodePointer 2 ", GetFcodePointer 'Compiled2,'C2); TestApply(" Lambda Expression 1 ", Lambda1,'L1); Dashed "Test a compiled call on Interpreted code "; PutD('Interpreted3,'Expr, '(LAMBDA (ag1 ag2 ag3) (Print (list 'Interpreted3 Ag1 Ag2 Ag3)) 'L3)); ShouldBe(" FlambdaLinkP",FlambdaLinkP 'Interpreted3,T); ShouldBe(" Interp3", Interpreted3(300,310,320),'L3); PutD('Interpreted2,'Expr,Lambda2); TestApply(" Interpreted ID 2 ", 'Interpreted2,'L2); End; LAP '((!*entry TestFastApply expr 0) (!*alloc 0) % Args loaded so move to fluid and go (!*Move (FLUID TestCode!*) (reg t1)) (!*dealloc 0) (!*JCALL FastApply)); Procedure TestApply(Msg,Fn,Answer); Begin scalar x; Prin2 " Testapply case "; prin2 Msg; Prin2 " given "; Print Fn; TestCode!* := Fn; x:=TestFastApply('A,'B); Return ShouldBe(" answer",x,Answer); End; Procedure Compiled1(xxx,yyy); <<Prin2 " Compiled1("; Prin1 xxx; Prin2 " "; Prin1 yyy; Prin2T ")"; 'C1>>; Procedure Compiled2(xxx,yyy); <<Prin2 " Compiled2("; Prin1 xxx; Prin2 " "; Prin1 yyy; Prin2T ")"; 'C2>>; CompileTime Fluid '(CFL1 CFL2 CFL3); Procedure CompBindTest(); Begin Dashed "Test LAMBIND and PROGBIND in compiled code"; CFL1:='TOP1; CFL2:='TOP2; Shouldbe("After Cbind1, result ", Cbind1('Mid0,'Mid1,'Mid2), 'Result!-Cbind1); Shouldbe("CFL1",CFL1,'Top1); Shouldbe("CFL2",CFL2,'Top2); End; procedure Cbind1(x,CFL1,CFL2); Begin Shouldbe("x ",x ,'Mid0); Shouldbe("CFL1",CFL1,'Mid1); Shouldbe("CFL2",CFL2,'Mid2); Shouldbe("After Cbind2, result ", Cbind2(),'Result!-Cbind2); Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Mid2); Return 'Result!-Cbind1; End; Procedure Cbind2(); Begin scalar zz; Shouldbe("CFL1",CFL1,'Mid1); Shouldbe("CFL2",CFL2,'Mid2); zz:=Begin scalar x,CFL2; CFL1:='Bot1; CFL2:='Bot2; Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Bot2); Return 'Inner!-Cbind2; End; Shouldbe("After inner BEGIN ",zz,'Inner!-Cbind2); Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Mid2); Return 'Result!-Cbind2; End; End; |
Added psl-1983/3-1/tests/main7.red version [9b36242096].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % main7.red : Small READ-EVAL-PRINT Loop WITH IO % Needs IO, SUB2, SUB3, SUB4, SUB5, SUB6,SUB7 IN "xxx-header.red"$ in "pt:stubs3.red"$ in "pt:stubs4.red"$ in "pt:stubs5.red"$ in "pt:stubs6.red"$ in "pt:stubs7.red"$ in "pt:psl-timer.sl"$ on syslisp; Compiletime GLOBAL '(DEBUG IN!* OUT!* !$EOF!$ !*PVAL); Procedure FirstCall; Begin scalar x, Done, Hcount; INIT(); InitHeap(); InitObList(); InitEval(); Prin2t '"MINI-PSL with File I/O"; Prin2T '" Type (IOTEST) to test basic file I/O"; Prin2T '" Future tests will be READ in this way"; Prin2T '" !*RAISE and !*PVAL set T"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!*PVAL) := 'T; % Print VALUEs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t " .... Now we test INITCODE"; InitCode(); LISPVAR(IN!*):=0; LISPVAR(OUT!*):=1; Hcount :=0; ClearIo(); While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x EQ !$EOF!$ then <<Terpri(); Prin2T " *** Top Level EOF *** ">> else if x eq 'QUIT then Done := 'T else <<Terpri(); x:=EVAL x; if Lispvar(!*PVAL) then Print x>>; >>; Quit; End; %---- File Io tests ---- Off syslisp; Procedure Iotest; Begin scalar InFile, OutFile,Ch,S,InString,OutString; Prin2T "---- Test of File IO"; IN!*:=0; Out!*:=1; Prin2T " Test CLEARIO"; A: Prin2T " Input String for Input File"; Instring:=Read(); Terpri(); If not StringP Instring then goto A; B: Prin2T " Input String for OutPut File"; OutString:=Read(); Terpri(); If not StringP Outstring then goto B; Infile:=Open(InString,'Input); prin2 " Input File Opened on "; Prin2 Infile; PRIN2T ", copy to TTY "; While Not ((ch:=IndependentReadChar(InFILE)) eq 26) do PutC Ch; Close Infile; Prin2T " File Closed, Input test done"; Infile:=Open(InString,'Input); OutFile:=Open(OutString,'OutPut); prin2 " Input File on "; Prin2 Infile; PRIN2 ", copy to Output File on"; Prin2T OutFile; While Not ((ch:=IndependentReadChar(InFILE)) eq 26) do IndependentWriteChar(outFile,Ch); Close Infile; Close OutFile; Prin2 "Both Files Closed, Inspect File:"; Prin2T OutString; End; End; |
Added psl-1983/3-1/tests/main8.red version [5aa4574143].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN8.RED Small READ-EVAL-PRINT Loop WITH IO % Needs IO, SUB2, SUB3, SUB4, SUB5, SUB6,SUB7 IN "xxx-header.red"$ %/ in "pt:stubs3.red" real gc installed$ in "pt:stubs4.red"$ in "pt:stubs5.red"$ in "pt:stubs6.red"$ in "pt:stubs7.red"$ in "pt:stubs8.red"$ in "pt:psl-timer.sl"$ in "PT:GC-TEST.RED"$ on syslisp; Compiletime GLOBAL '(DEBUG IN!* OUT!* !$EOF!$ !*PVAL); FLUID '(Heap!-Warn!-Level); Procedure FirstCall; Begin scalar x, Done, Hcount; INIT(); InitHeap(); InitObList(); InitEval(); InitRead(); LispVar(DEBUG) := 'NIL; % For nice I/O Lispvar(Heap!-Warn!-Level) := 0; % Set for Non-trap LispVar(!*GC) :=T; LispVar(GCKnt!*) :=0; LispVar(GCTime!*) :=0; LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!*PVAL) := 'T; % Print VALUEs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t "Invoke STARTUP Code"; InitCode(); LISPVAR(IN!*):=0; LISPVAR(OUT!*):=1; Hcount :=0; ClearIo(); Prin2T "Reading Init Files"; Lapin "INIT8"; Prin2t '"MINI-PSL with File I/O and RECLAIM"; Prin2T "Invoke (TESTMARKING) and then (GCTEST)"; While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x EQ !$EOF!$ then <<Terpri(); Prin2T " *** Top Level EOF *** ">> else if x eq 'QUIT then Done := 'T else <<Terpri(); x:=EVAL x; if Lispvar(!*PVAL) then Print x>>; >>; Quit; End; off syslisp; End; |
Added psl-1983/3-1/tests/main9.red version [8018ec0419].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN9.RED READ-EVAL-PRINT, RECLAIM, CATCH and PROG IN "xxx-header.red"$ %/ in "pt:stubs3.red" % -- real gc installed as SUB8 in "pt:stubs4.red"$ in "pt:stubs5.red"$ in "pt:stubs6.red"$ in "pt:stubs7.red"$ in "pt:stubs8.red"$ in "pt:stubs9.red"$ in "pt:psl-timer.sl"$ on syslisp; Compiletime GLOBAL '(DEBUG IN!* OUT!* !$EOF!$ !*PVAL); FLUID '(Heap!-Warn!-Level); Procedure FirstCall; Begin scalar x, Done, Hcount; INIT(); InitHeap(); InitObList(); InitEval(); InitRead(); LispVar(DEBUG) := 'NIL; % For nice I/O Lispvar(Heap!-Warn!-Level) := 0; % Set for Non-trap LispVar(!*GC) :=T; LispVar(GCKnt!*) :=0; LispVar(GCTime!*) :=0; LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!*PVAL) := 'T; % Print VALUEs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t "Invoking STARTUP Code"; InitCode(); LISPVAR(IN!*):=0; LISPVAR(OUT!*):=1; Hcount :=0; ClearIo(); Prin2T "Reading the INIT files"; Lapin "INIT9"; Prin2t '"MINI-PSL with File I/O, RECLAIM and CATCH/THROW"; While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x EQ !$EOF!$ then <<Terpri(); Prin2T " *** Top Level EOF *** ">> else if x eq 'QUIT then Done := 'T else <<Terpri(); x:=EVAL x; if Lispvar(!*PVAL) then Print x>>; >>; Quit; End; Off syslisp; End; |
Added psl-1983/3-1/tests/make-headers.mic version [e3e34abf17].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @conn pt: @get psl:rlisp @st *load "g:proc-headers"; *on nocomment, noprefix; % Set up for smallest output *remd ''ImportantLine; *copyd(''ImportantLine,''ImportantLine2); *Manyheaders(''(main2 sub2 stubs2 main3 sub3 stubs3 main4 sub4 stubs4 main5 sub5a sub5b stubs5 main6 sub6 stubs6 main7 sub7 stubs7 main8 sub8 stubs8 main9 sub9 stubs9 mini!-allocators mini!-arithmetic pk!:carcdr pk!:catch!-throw mini!-char!-io pk!:comp!-support mini!-cons!-mkvect mini!-dskin mini!-easy!-non!-sl mini!-easy!-sl mini!-equal mini!-error!-errorset mini!-error!-handlers mini!-eval!-apply mini!-fluid!-global mini!-gc mini!-io!-errors pk!:known!-to!-comp!-sl mini!-loop!-macros mini!-oblist mini!-open!-close mini!-others!-sl mini!-printers mini!-printf mini!-property-list mini!-putd!-getd mini!-rds!-wrs mini!-read mini!-sequence mini!-symbol!-values mini!-token mini!-top!-loop mini!-type!-conversions mini!-type!-errors p!-apply!-lap p!-fast!-binder pk!:binding p!-function!-primitives p!-comp!-gc p20t!:xxx!-gc p20t!:xxx!-header p20t!:xxx!-system!-gc p20t!:xxx!-system!-io p20t!:20!-test!-global!-data ), ''all!-test); *load "g:sort-file"; *sort!-file("all-test.headers","all-test.sorted"); *quit; @reset . |
Added psl-1983/3-1/tests/mathlib.tst version [98678d1b91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. MATHLIB.TST % A simple set of tests for MAthLIB LOAD MATHLIB$ Global '(EPS); EPS:=1.0/(1.0E6); Fexpr procedure TS L$ % (Function,Arg,Expected Value) Begin scalar Fn,Arg,Val,x,y; Fn:=car L$ Arg:=EVAL cadr L$ Val:=EVAL Caddr L$ x:=Apply(fn, list arg)$ PrintF(" %r(%p) = %p, expect %p%n",Fn,arg,x,val)$ y:=abs(x-val); if y>=EPS then PrintF(" ***** %p exceeds EPS%n",y); End$ TS(Ceiling,3,3); TS(Ceiling,3.1,4); TS(Ceiling,3.7,4); TS(Ceiling,-3,-3); TS(Ceiling,-3.5,-2); TS(Round,3,3); TS(Round,3.1,3); TS(Round,3.5,4); TS(Round,3.7,4); TS(Round,-3,-3); TS(Round,-3.4,-2); TS(Round,-3.7,-3); TwoPI := 6.2831853; PI:=TwoPI/2; PI2:=PI/2; PI4:=PI/4; PI8:=PI/8; Root2:=1.4142136; Root2**2 - 2.0; TS(sin, 0.0, 0.0)$ TS(cos, 0.0, 1.0)$ TS(sin, PI4, Root2/2)$ TS(cos, PI4, Root2/2)$ TS(sin, PI2, 1.0)$ TS(cos, PI2, 0.0)$ TS(sin, 3*PI4, Root2/2)$ TS(cos, 3*PI4, -Root2/2)$ TS(sin, PI, 0.0)$ TS(cos, PI, -1.0)$ procedure SC2 x; sin(x)**2+cos(x)**2; TS(SC2,0.0,1)$ TS(SC2,0.25,1)$ TS(SC2,0.5,1)$ TS(SC2,0.75,1)$ TS(SC2,1.0,1)$ TS(SC2,1.25,1)$ TS(SC2,1.5,1)$ TS(SC2,1.75,1)$ TS(SC2,2.0,1)$ TS(SC2,2.25,1)$ TS(SC2,2.5,1)$ TS(SC2,2.75,1)$ TS(SC2,3.0,1)$ TS(TAN,0.0,0.0)$ TS(TAN,PI8,SIN(PI8)/COS(PI8))$ TS(TAN,PI4,1.0)$ TS(COT,PI8,COS(pi8)/SIN(pi8))$ TS(COT,PI4,1.0)$ TS(SIND,30.0,0.5)$ TS(ASIND,0.5,30.0)$ TS(SQRT,2.0,Root2)$ TS(SQRT,9.0,3.0)$ TS(SQRT,100.0,10.0)$ NaturalE:=2.718281828$ TS(EXP,1.0,NaturalE)$ TS(LOG,SQRT(NaturalE),0.5)$ TS(LOG,NaturalE,1.0)$ TS(LOG,NaturalE**2,2.0)$ TS(LOG,1.0/NaturalE**2, -2.0)$ TS(LOG2,Root2,0.5)$ TS(LOG2,2.0,1.0)$ TS(LOG2,4.0,2.0)$ TS(LOG2,0.5, -1.0)$ TS(LOG10,SQRT(10.0),0.5)$ TS(LOG10,10.0,1.0)$ TS(LOG10,100.0,2.0)$ TS(LOG10, 1.0E30, 30.0)$ TS(LOG10, 1.0E-30, -30.0)$ End$ |
Added psl-1983/3-1/tests/mini-allocators.red version [d919fb0fd6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-ALLOC.RED : Crude Mini Allocator and support % See PT:P-ALLOCATORS.RED % Revisions: MLG, 18 Feb,1983 % Moved HEAP declaration to XXX-HEADER % Had to provide an InitHeap routine % (or will be LoadTime :=) on syslisp; external Wvar HeapLowerBound, HeapUpperBound; external WVar HeapLast, % next free slot in heap HeapPreviousLast; % save start of new block syslsp procedure GtHEAP N; % get heap block of N words if null N then (HeapUpperBound - HeapLast) / AddressingUnitsPerItem else << HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then << !%Reclaim(); HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then FatalError "Heap space exhausted" >>; HeapPreviousLast >>; syslsp procedure GtSTR N; % Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtVECT N; % Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; Procedure GtWarray N; % Dummy for Now, since no GC GtVect N; Procedure GtID(); % Simple ID Allocator Begin scalar D; D:=NextSymbol; NextSymbol:=NextSymbol+1; return D; End; Off syslisp; End; |
Added psl-1983/3-1/tests/mini-arithmetic.red version [4ae92b191a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-ARITHMETIC.RED simple ARITHmetic functions Procedure Plus2(x,y); if numberp x and numberp y then sys2int(wplus2(intinf x,intinf y)) else NonNumberError(cons(x,y),'Plus2); Procedure Minus(x); if numberp x then sys2int wminus intinf x else NonNumberError(x,'Minus); Procedure Add1 N; If Numberp N then sys2int wplus2(N,1) else else NonNumberError(N,'Add1); Procedure SUB1 N; If Numberp N then sys2int wdifference(N,1) else NonNumberError(N,'SUB1); Procedure GreaterP(N1,N2); If NumberP N1 and NumberP N2 then wGreaterp(intinf N1,intinf N2) else NIL; Procedure LessP(N1,N2); If NumberP N1 and NumberP N2 then Wlessp(intinf N1,intinf N2) else NIL; Procedure DIFFERENCE(N1,N2); If NumberP N1 and NumberP N2 then sys2int wdifference(intinf N1,intinf N2) else NonNumberError(cons(N1,N2),'Difference); Procedure TIMES2(N1,N2); If NumberP N1 and NumberP N2 then sys2int Wtimes2(intinf N1,intinf N2) else NonNumberError(cons(N1,N2),'TIMES2); End; |
Added psl-1983/3-1/tests/mini-carcdr.red version [c6fe3a68bd].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % MINI-CARCDR.RED % ---- Some Basic LIST support Functions % -- CxxR -- may need in EVAL if not open coded Procedure Caar x; Car Car x; Procedure Cadr x; Car Cdr x; Procedure Cdar x; Cdr Car x; Procedure Cddr x; Cdr Cdr x; end; |
Added psl-1983/3-1/tests/mini-char-io.red version [9a224f7efa].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MINI-CHAR-IO.RED Procedure ChannelWriteChar(chn,x); PutC x; Procedure WriteChar Ch; IndependentWriteChar(Out!*,Ch); End; |
Added psl-1983/3-1/tests/mini-comp-support.red version [a200588768].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % MINI-COMP-SUPPORT.RED - Support for LIST etc %/ Identical to PK:COMP-SUPPORT? procedure List2(A1,A2); Cons(A1,Ncons A2); procedure List3(A1,A2,A3); Cons(A1,List2(A2,A3)); procedure List4(A1,A2,A3,A4); Cons(A1,List3(A2,A3,A4)); procedure List5(A1,A2,A3,A4,A5); Cons(A1,List4(A2,A3,A4,A5)); end; |
Added psl-1983/3-1/tests/mini-cons-mkvect.red version [498e774757].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-CONS.RED : Cons, MkVect etc for testing %/Almost identical to PK:CONS-MKVECT on syslisp; procedure HardCons(x,y); Begin scalar c; c:=GtHeap PairPack(); c[0]:=x; c[1]:=y; Return MkPAIR(c); End; procedure Cons(x,y); HardCons(x,y); procedure Xcons(x,y); HardCons(y,x); procedure Ncons x; HardCons(x,'NIL); syslsp procedure MkVect N; % Allocate vector, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"A vector with fewer than zero elements cannot be allocated" else begin scalar V; V := GtVect N; for I := 0 step 1 until N do VecItm(V, I) := NIL; return MkVEC V; % Tag it end >> else NonIntegerError(N, 'MkVect); off syslisp; End; |
Added psl-1983/3-1/tests/mini-dskin.red version [947b931a4b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-DSKIN.RED Procedure TypeFile F; Begin Scalar InChan,OldChan,c; InChan:=Open(F,'Input); OldChan:=Rds InChan; While Not ((c:=Getc()) eq 26) do PutC(c); rds OldChan; close InChan; end; Procedure DskIn F; Begin scalar Infile, OldFile,x; Infile:=Open(F,'Input); OldFile:=RDS Infile; While not ((x:=Read()) eq !$eof!$) do << x:=Eval x; If !*Pval then Print x>>; RDS OldFile; Close InFile; End; FLUID '(!*Echo !*PVAL); procedure Lapin F; Begin scalar !*echo, !*pval; Return Dskin F; End; End; |
Added psl-1983/3-1/tests/mini-easy-non-sl.red version [383d3c0358].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-NON-SL.RED Simple non sl functions Procedure Atsoc(x,y); If Not PAIRP y then NIL else if Not PAIRP car y then Atsoc(x,cdr y) else if x EQ car car y then car y else Atsoc(x, cdr y); Procedure GEQ(N1,N2); not(N1< N2); Procedure LEQ(N1,N2); not(N1 > N2); Procedure EqCar(x,y); PairP x and (Car(x) eq y); procedure COPYD(newId,OldId); Begin scalar x; x:=Getd OldId; If not Pairp x then return <<Print List(OLDID, " has no definition in COPYD "); NIL>>; Return PUTD(newId,car x,cdr x); End; Procedure Delatq(x,y); If not Pairp y then NIL else if not Pairp car y then CONS(car y,Delatq(x,cdr y)) else if x eq caar y then cdr y else CONS(car y,Delatq(x,cdr y)); procedure MkQuote x; List('quote,x); End; |
Added psl-1983/3-1/tests/mini-easy-sl.red version [e136c45ddd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-EASY-SL.RED --- Simple functions % 3.1 -- Some basic predicates % Note that the bodies open compile, so this is just for % interpreter entries Procedure Atom x; Atom x; procedure ConstantP U; Not PairP U and not IDP U; Procedure Null U; U eq NIL; % 3.2 -- Simple LIST stuff nexpr procedure List x; x; % 3.5 -- Function definition fexpr Procedure De(x); PutD(car x,'Expr,'LAMBDA . cdr x); fexpr Procedure Df(x); PutD(car x,'Fexpr,'LAMBDA . Cdr x); fexpr Procedure Dn(x); PutD(car x,'NExpr,'LAMBDA . cdr x); fexpr Procedure Dm(x); PutD(car x,'Macro,'LAMBDA . Cdr x); % 3.6 -- Variables and Binding Fexpr Procedure SETQ a; Set(car a,Eval Cadr a); % 3.7 -- Program function features fexpr procedure Progn x; EvProgn x; procedure EvProgn fl; Begin scalar x; While PairP fl do <<x:=Eval Car fl; fl:=Cdr fl>>; Return x; End; % 3.10 -- Boolean functions procedure EvCond fl; if not PairP fl then 'NIL else if not PairP car fl then EvCond cdr fl else if Eval car car fl then EvProgn cdr car fl else EvCond cdr fl; fexpr procedure Cond x; EvCond x; procedure Not U; U eq NIL; % 3.13 -- Composite Procedure append(U,V); if not PairP U then V else Cons(Car U,Append(Cdr U,V)); Procedure MemQ(x,y); If Not PAIRP y then NIL else if x EQ car y then T else MemQ(x, cdr y); Procedure REVERSE U; Begin Scalar V; While PairP U do <<V:=CONS(Car U,V); U:=CDR U>>; Return V; End; % Simple EVAL support procedure Evlis x; if Not Pairp x then x else Eval(car x) . Evlis(cdr x); Fexpr Procedure Quote a; Car a; End; |
Added psl-1983/3-1/tests/mini-equal.red version [1182cc7bed].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % MINI-EQUAL.RED on syslisp; Procedure EqStr(s1,S2); Begin scalar n; s1:=strinf(s1); s2:=strinf(s2); n:=strlen(s1); if n neq strlen(s2) then return 'NIL; L:if n<0 then return 'T; if strbyt(s1,n) neq strbyt(s2,n) then return 'NIL; n:=n-1; goto L; End; off syslisp; end; |
Added psl-1983/3-1/tests/mini-error-errorset.red version [b933afaa88].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % MINI-ERROR-ERRORSET on syslisp; syslsp procedure ErrorHeader; Prin2String "*** ERROR *** "; syslsp procedure Error s; <<ErrorHeader(); ErrorTrailer s>>; syslsp procedure ErrorTrailer s; <<If pairp s then Prin2L s else Prin2T s; Quit;>>; syslsp procedure Prin2L s; % Should be in PrintF? <<While Pairp s do <<prin2 car s; s:=cdr s; prin2 " ">>; Terpri()>>; off syslisp; End; |
Added psl-1983/3-1/tests/mini-error-handlers.red version [ce82b88393].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % MINI-ERROR-HANDLERS.RED - Error Handler stubs on syslisp; syslsp procedure FatalError s; <<ErrorHeader(); Prin2 " FATAL "; ErrorTrailer s>>; syslsp procedure StdError m; Error m; off syslisp; end; |
Added psl-1983/3-1/tests/mini-eval-apply.red version [c0a9ca84b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-EVAL-APPLY.RED - A small EVAL, uses P-APPLY-LAP On syslisp; Procedure InitEval; Begin Put('Quote,'TYPE,'FEXPR); Put('Setq,'TYPE,'FEXPR); Put('Cond,'TYPE,'FEXPR); Put('Progn,'TYPE,'FEXPR); Put('While,'TYPE,'FEXPR); Put('List,'TYPE,'NEXPR); Put('De,'TYPE,'FEXPR); Put('Df,'TYPE,'FEXPR); Put('Dn,'TYPE,'FEXPR); Put('Dm,'TYPE,'FEXPR); End; syslsp procedure Eval x; If IDP x then SYMVAL(IdInf x) else if not PairP x then x else begin scalar fn,a,FnType; fn:=car x; a:=cdr x; if LambdaP fn then Return LambdaEvalApply(GetLambda fn, a); if CodeP fn then Return CodeEvalApply(fn,a); if not Idp fn then Return <<Prin2('"**** Non-ID function in EVAL: "); Print fn; NIL>>; if FunBoundP fn then Return <<Prin2('"**** UnBound Function in EVAL: "); Print fn; NIL>>; FnType :=GetFnType Fn; if FnType = 'FEXPR then return IDApply1(a, Fn); if FnType = 'NEXPR then return IDApply1(Evlis a, Fn); if FnType = 'MACRO then return Eval IDApply1(x, Fn); if FLambdaLinkP fn then return LambdaEvalApply(GetLambda fn,a); return CodeEvalApply(GetFcodePointer fn, a); end; procedure Apply(fn,a); Begin scalar N; If LambdaP fn then return LambdaApply(fn,a); If CodeP fn then CodeApply(fn,a); If Not Idp Fn then return <<prin2 '" **** Non-ID function in APPLY: "; prin1 fn; prin2 " "; Print a; NIL>>; if FLambdaLinkP fn then return LambdaApply(GetLambda fn,a); If FunBoundP Fn then return <<prin2 '" **** Unbound function in APPLY: "; prin1 fn; prin2 " "; Print a; NIL>>; Return CodeApply(GetFcodePointer Fn,a); End; % -- User Function Hooks --- Procedure LambdaApply(x,a); Begin scalar v,b; x:=cdr x; v:=car x; b:=cdr x; Return DoLambda(v,b,a) End; Procedure LambdaEvalApply(x,y); LambdaApply(x,Evlis y); Procedure DoLambda(vars,body,args); % Args already EVAL'd as appropriate Begin scalar N,x,a; N:=Length vars; For each v in VARS do <<if pairp args then <<a:=car args; args:=cdr args>> else a:=Nil; LBIND1(v,a)>>; %/ Should try BindEVAL here x:=EvProgn Body; UnBindN N; Return x; End; Procedure LambdaP(x); EqCar(x,'LAMBDA); Procedure GetLambda(fn); Get(fn,'!*LambdaLink); off syslisp; End; |
Added psl-1983/3-1/tests/mini-fluid-global.red version [577b8a48fe].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % MINI-FLUID-GLOBAL.RED % Stubs procedure fluid u; list ('fluid, u); procedure FluidP U; NIL; procedure global u; list ('global, u); procedure GlobalP u; NIL; procedure Unfluid U; list('Unfluid,U); End; |
Added psl-1983/3-1/tests/mini-gc.red version [47687fbb7b].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-RECLAIM.RED - RECLAIM stubs for TEST series on syslisp; External Wvar HeapLowerBound, HeapUpperBound, HeapLast; Procedure !%Reclaim(); <<Prin2 '" *** Dummy !%RECLAIM: "; HeapInfo()>>; Procedure Reclaim(); <<Prin2 '"*** Dummy RECLAIM: "; HeapInfo()>>; Procedure HeapInfo(); << Prin1 ((HeapLast-HeapLowerBound)/AddressingUnitsPerItem); Prin2 '" Items used, "; Prin1 ((HeapUpperBound -HeapLast)/AddressingUnitsPerItem); Prin2t '" Items left."; 0>>; off syslisp; End; |
Added psl-1983/3-1/tests/mini-io-errors.red version [cb046f88c3].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % MINI-IO-ERRORS.RED Procedure IoError M; <<terpri(); ErrorHeader(); Prin2t M; RDS 0; WRS 1; NIL>>; procedure ContOpenError(fil,how); IoError List("Cant Open file ",fil," for ",how); End; |
Added psl-1983/3-1/tests/mini-loop-macros.red version [002d731364].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MINI-LOOP-MACROS.RED fexpr procedure While fl; Begin if not PairP fl then return 'NIL; While Eval Car fl do EvProgn cdr fl; End; End; |
Added psl-1983/3-1/tests/mini-oblist.red version [7938b8bece].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %F PT MINI-OBLIST RED 18-MAR-83 on syslisp; internal WConst DeletedSlotValue = -1, EmptySlotValue = 0; syslsp procedure Intern s; % Lookup string, find old ID or return a new one Begin scalar D; If IDP s then s :=SymNam IdInf s; If (D:=LookupString( s)) then return MkItem(ID,D); Return NewId s; End; syslsp procedure NewId S; InitNewId(GtId(),s); Syslsp procedure InitNewId(D,s); Begin If LispVar(DEBUG) then <<Prin2 '"New ID# "; Print D>>; Symval(D):=NIL; SymPrp(D):=NIL; SymNam(D):=s; D:=MkItem(ID,D); MakeFUnBound(D); % Machine dependent, in XXX-HEADER Obarray(D):=D; % For GC hook Return D; End; Syslsp procedure LookupString(s); % Linear scan of SYMNAM field to find string s Begin scalar D; D:=NextSymbol; If LispVar(DEBUG) then <<Prin2 '"Lookup string=";Prin1String s; Terpri()>>; L: If D<=0 then return <<If LispVar(DEBUG) then Prin2T '"Not Found in LookupString"; NIL>>; D:=D-1; If EqStr(SymNam(D),s) then return <<If LispVar(DEBUG) then <<Prin2 '"Found In LookupString="; print D>>; D>>; goto L End; % ---- Small MAPOBL and printers Syslsp procedure MapObl(Fn); For i:=0:NextSymbol-1 do IdApply1(MkItem(ID,I),Fn); Syslsp procedure PrintFexprs; MapObl 'Print1Fexpr; Syslsp procedure Print1Fexpr(x); If FexprP x then Print x; Syslsp procedure PrintFunctions; MapObl 'Print1Function; Syslsp procedure Print1Function(x); If Not FUnboundP x then Print x; syslisp procedure InitObList(); % Dummy, non hashed version Begin scalar Tmp; For i:=0 step 1 until MaxObarray do ObArray I := EmptySlotValue; Tmp:= NextSymbol -1; For I := 128 step 1 until Tmp do ObArray I := I; End; off syslisp; End; |
Added psl-1983/3-1/tests/mini-open-close.red version [7fe51b852a].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | % MINI-OPEN-CLOSE.RED Some minimal User Level I/O routines: Procedure Open(FileName,How); If how eq 'Input then SystemOpenFileForInput FileName else if how eq 'OutPut then SystemOpenFileForOutPut FileName else IoError "Cant Open"; Procedure Close N; IndependentCloseChannel N; end; |
Added psl-1983/3-1/tests/mini-others-sl.red version [34ea1acd25].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % MINI-OTHERS-SL.RED on syslisp; procedure Length U; % Length of list U, fast version Length1(U, 0); procedure Length1(U, N); if PairP U then Length1(cdr U, N+1) else N; off syslisp; end; |
Added psl-1983/3-1/tests/mini-printers.red version [4df1d986c0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PRINT.RED - More comprehensive Mini I/O % A mini Print routine % uses PutC and PutInt On syslisp; syslsp procedure Prin1 x; if IDP x then Prin1ID x else if IntP x then Prin1Int x else if StringP x then Prin1String x else if PairP x then Prin1Pair x else PrtItm x; syslsp procedure Prin2 x; if IDP x then Prin2ID x else if IntP x then Prin1Int x else if StringP x then Prin2String x else if PairP x then Prin2Pair x else PrtItm x; syslsp procedure Print x; <<Prin1 X; Terpri(); x>>; syslsp procedure Prin2t x; <<Prin2 X; Terpri(); x>>; % Support syslsp procedure Pblank; PutC Char '! ; syslsp procedure Prin1Int x; <<if x=0 then PutC Char 0 else if x<0 then <<PutC Char '!-; Prin1Int (-x)>> else Prin1IntX x; x>>; Procedure Prin1IntX x; If x=0 then NIL else <<Prin1IntX LongDiv(x,10); PutC (LongRemainder(x,10)+Char 0)>>; syslsp procedure Prin1ID x; <<Prin2String Symnam IdInf x; PBlank(); x>>; syslsp procedure Prin2Id x; prin1Id x; syslsp procedure Prin1String x; <<PutC Char '!"; Prin2String x; PutC Char '!"; Pblank(); x>>; syslsp procedure Prin2String x; Begin scalar s; s:=StrInf x; For i:=0:StrLen(s) do PutC StrByt(S,I); return x End; syslsp procedure Prin1Pair x; <<PutC Char '!(; Prin1 Car x; x:=Cdr X; While Pairp X do <<Pblank(); Prin1 Car X; X:=Cdr x>>; If Not NULL X then <<Prin2String " . "; Prin1 x>>; PutC Char '!) ; Pblank(); x>>; syslsp procedure Prin2Pair x; <<PutC Char '!(; Prin2 Car x; x:=Cdr X; While Pairp X do <<Pblank(); Prin2 Car X; X:=Cdr x>>; If Not NULL X then <<Prin2String " . "; Prin2 x>>; PutC Char '!) ; Pblank(); x>>; syslsp procedure terpri(); Putc Char EOL; syslsp procedure PrtItm x; <<Prin2String " <"; Prin1Int Tag x; PutC Char '!:; Prin1Int Inf x; Prin2String "> "; x>>; % Some stubs for later stuff Procedure ChannelPrin2(chn,x); Prin2 x; Off syslisp; End; |
Added psl-1983/3-1/tests/mini-printf.red version [605aed27b6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PRINTF.RED procedure PrintF(FMT, A1,A2,A3,A4,A5,A6); % Dummy PRINTF << Prin2 FMT; Prin2 " "; Prin2 A1; Prin2 " "; Prin2 A2; Prin2 " "; Prin2 A3; Prin2 " "; Prin2T A4; >>; procedure errorprintf(FMT,a1,a2,a3,a4); % Dummy ErrorPrintf PrintF(FMT,A1,A2,A3,A4); procedure BLDMSG(FMT,A1,A2,A3,A4,A5,A6); % Dummy BLDMSG LIST ('BLDMSG, FMT,A1,A2,A3,A4); procedure ErrPrin U; <<Prin2 '!`; Prin1 U; Prin2 '!' >>; End; |
Added psl-1983/3-1/tests/mini-property-list.red version [5ddeb8946e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PROPERTY-LIST.RED - Small GET and PUT on syslisp; Procedure Prop x; If not IDP x then NIL else SYMPRP IDINF x; Procedure Get(x,y); Begin scalar z,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If (Z:=Atsoc(y,L)) then return CDR Z; Return NIL; End; Procedure Put(x,y,z); Begin scalar P,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If (P:=Atsoc(y,L)) then return % <<CDR(PairInf P):=z; z>>; L:=CONS(CONS(y,z),L); SYMPRP(IDINF x):=L; Return z; End; Procedure RemProp(x,y); Begin scalar P,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If not(P:=Atsoc(y,L)) then return NIL; L:=Delatq(y,L); SYMPRP(IDINF x):=L; Return CDR P; End; Procedure GetFnType x; Get(x,'TYPE); off syslisp; end; |
Added psl-1983/3-1/tests/mini-putd-getd.red version [bdab5ede36].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PUTD-GETD.RED Small COPYD, GETD, PUTD on syslisp; Procedure Getd(fn); Begin scalar type; if Not IDP fn then return <<Prin2 "*** Can only GETD off ID's: "; Print fn; NIL>>; if FunBoundP fn then return NIL; if null(type:=Get(fn,'TYPE)) then type:='Expr; if FCodeP fn then return ( type . GetFcodePointer fn); If FLambdaLinkP fn then return (type .Get(fn,'!*LambdaLink)); Prin2 "*** GETD should find a LAMBDA or CODE"; print fn; return NIL; End; Procedure PutD(fn,type,body); Begin if Not IDP fn then return <<Prin2 "*** Can only define ID's as functions: "; Print fn; NIL>>; if FCodeP fn then <<Prin2 "*** Redefining a COMPILED function: "; Print fn>> else if not FunBoundP fn then <<prin2 " Redefining function "; print fn>>; Remprop(fn,'!*LambdaLink); Remprop(fn,'TYPE); MakeFUnBound fn; If LambdaP body then << Put(fn,'!*LambdaLink,body); MakeFlambdaLink fn>> else if CodeP body then MakeFcode(fn,body) else return <<Prin2 "*** Body must be a LAMBDA or CODE"; prin1 fn; prin2 " "; print body; NIL>>; If not(type eq 'expr) then Put(fn,'TYPE,type); return fn; End; syslsp procedure code!-number!-of!-arguments cp; begin scalar n; return if codep cp then << n := !%code!-number!-of!-arguments CodeInf cp; if n >= 0 and n <= MaxArgs then n >>; end; off syslisp; End; |
Added psl-1983/3-1/tests/mini-rds-wrs.red version [a0f0f6c58f].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % MINI-RDS-WRS.RED Fluid '(IN!* Out!*); Procedure RDS N; If NULL N then RDS 0 else begin scalar K; K:=IN!*; IN!*:=N; Return K end; Procedure WRS N; If NULL N then WRS 1 else begin scalar K; K:=Out!*; Out!*:=N; Return K end; End; |
Added psl-1983/3-1/tests/mini-read.red version [e65e25c076].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-READ.RED - A small reader CompileTime <<GLOBAL '(DEBUG); FLUID '(TOK!* TOKTYPE!* CH!* !*RAISE);>>; Procedure READ; % start RATOM, get first fresh token Read1(Ratom()); Procedure READ1(x); If x eq '!( then READLIST(RATOM()) % Skip the ( else if x eq '!' then CONS('QUOTE, NCONS READ()) else x; Procedure ReadList(x); % read LIST, starting at token x Begin scalar y; If x eq '!) then Return NIL; y:=Read1(x); % Finish read CAR of pair x:=Ratom(); % Check dot If x eq '!. then return CONS(y,car READLIST(RATOM())); Return CONS(y , READLIST(x)) End; End; |
Added psl-1983/3-1/tests/mini-sequence.red version [0621b1393a].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % MINI-SEQUENCE.RED: Susbet of Strings, sequence etc for testing on syslisp; syslsp procedure MkString(L, C); % Make str with upb L, all chars C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'MkString); if L1 < -1 then return NonPositiveIntegerError(L, 'MkString); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkSTR S; end; off syslisp; End; |
Added psl-1983/3-1/tests/mini-symbol-values.red version [2f5df62185].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | % MINI-SYMBOL-VALUES.RED Procedure Set(x,y); Begin If IDP x then SYMVAL(IDINF x):=y else <<prin2 '"**** Non-ID in SET: ";Print x>>; return y; End; End; |
Added psl-1983/3-1/tests/mini-token.red version [4855344ae9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-TOKEN.RED - Small Token scanner for testing CompileTime <<GLOBAL '(DEBUG); FLUID '(TOK!* TOKTYPE!* CH!* !*RAISE);>>; ON SYSLISP; Wstring Buffer[100]; % Will hold characters as they are parsed for ID, INT and string Procedure InitRead; % Initialize various RATOM and READ properties Begin LISPVAR(!*RAISE) := 'NIL; LISPVAR(CH!*) := Char '! ; LispVar(Tok!*):= 'NIL; LispVar(TokType!*) := 2; If LispVar(DEBUG) then <<Prin2 '"NextSymbol ="; Print Nextsymbol>>; End; Procedure SetRaise x; LISPVAR(!*RAISE) := x; Procedure Ratom; % Read a single ATOM: ID, POSINT, STRING or SPECIAL Begin L: ClearWhite(); If LispVar(CH!*) eq Char '!% then <<ClearComment(); goto L>>; If LISPVAR(CH!*) eq Char '!" then Return <<LispVar(TokType!*):=0;LispVar(Tok!*):=ReadStr()>>; If DigitP LISPVAR(CH!*) then Return <<LispVar(TokType!*):=1;LispVar(Tok!*):=ReadInt()>>; If AlphaEscP LISPVAR(CH!*) then Return <<LispVar(TokType!*):=2;LispVar(Tok!*):=ReadId()>>; LispVar(TokType!*):=3; LispVar(Tok!*):=MkItem(ID,LISPVAR(CH!*)); LISPVAR(CH!*):=Char '! ; % For read Ahead Return LispVar(Tok!*) End; Procedure ClearWhite(); % Clear out white space While WhiteP LISPVAR(CH!*) do LISPVAR(CH!*):=GetC(); Procedure ClearComment(); % Scan for Comment EOL While LispVar(CH!*) neq char EOL do LISPVAR(CH!*):=GetC(); Procedure ReadInt; % Parse NUMERIC characters into a POSITIVE integer Begin scalar N; N:=LISPVAR(CH!*)-Char 0; While DigitP(LISPVAR(CH!*):=GetC()) do N:=LongTimes(10,N)+(LISPVAR(CH!*)-Char 0); Return Mkitem(POSINT,N); End; Procedure BufferToString n; % Convert first n chars of Buffer into a heap string Begin scalar s; s:=GtStr(n); for i:=0:n do strbyt(s,i):=strbyt(Buffer,i); return MkStr s; End; Procedure ReadStr; % Parse "...." into a heap string Begin scalar n; n:=-1; While ((LISPVAR(CH!*):=Getc())neq Char '!") do <<N:=N+1;Strbyt(Buffer,n):=LISPVAR(CH!*)>>; LISPVAR(CH!*):=char '! ; Return BufferToString(n); End; Procedure ReadID; % Parse Characters into Buffer, Make into an ID Begin scalar n,s,D; n:=0; StrByt(Buffer,0):=RaiseChar LISPVAR(CH!*); While AlphaNumEscP(LISPVAR(CH!*):=Getc()) do <<N:=N+1;Strbyt(Buffer,n):=RaiseChar LISPVAR(CH!*)>>; Return Intern BufferToString(n); End; Procedure RaiseChar c; If EscapeP c then Getc() else if not LispVar !*Raise then c else if not AlphaP c then c else if LowerCaseP c then Char A +(c-Char Lower a) else c; Procedure WhiteP x; x=CHAR(BLANK) or x=CHAR(EOL) or x=CHAR(TAB) or x=CHAR(LF) or x=CHAR(FF) or x =CHAR(CR); Procedure DigitP x; Char(0) <=x and x <=Char(9); Procedure AlphaP(x); UpperCaseP x or LowerCaseP x; Procedure UpperCaseP x; Char(A)<=x and x<=Char(Z); Procedure LowerCaseP x; Char(Lower A)<=x and x<=Char(Lower Z); Procedure EscapeP x; x eq Char '!!; Procedure AlphaEscP x; EscapeP x or AlphaP x; Procedure AlphaNumP x; DigitP(x) or AlphaP(x); Procedure AlphaNumEscP x; EscapeP x or AlphaNumP x; Off syslisp; End; |
Added psl-1983/3-1/tests/mini-top-loop.red version [1107bd3591].
> > > > > > | 1 2 3 4 5 6 | % MINI-TOP-LOOP.RED Procedure Time(); Timc(); End; |
Added psl-1983/3-1/tests/mini-type-conversions.red version [e9e4ac7195].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % MINI-TYPE-CONVERSIONS.RED on syslisp; syslsp procedure Sys2Int N; %. Convert word to Lisp number if SignedField(N, InfStartingBit - 1, InfBitLength + 1) eq N then N else Sys2FIXN N; syslsp procedure SYS2FIXN N; STDerror LIST(N, "too big for mini arith"); off syslisp; End; |
Added psl-1983/3-1/tests/mini-type-errors.red version [5a0db4ac3a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-TYPE-ERRORS.RED % Almost identical, just faked StdError and Bldmsg procedure TypeError(Offender, Fn, Typ); <<Errorheader(); Prin2 "An attempt was made to do "; prin1 Fn; prin2 " on `"; prin1 Offender; prin2 "', which is not "; print Typ; quit; >>; procedure UsageTypeError(Offender, Fn, Typ, Usage); <<Errorheader(); Prin2 "An attempt was made to use "; prin1 Offender; Prin2 " as "; Prin1 Usage; prin2 " in `"; prin1 Fn; prin2 "`, where "; prin1 Typ; prin2t " is needed"; quit; >>; procedure IndexError(Offender, Fn); UsageTypeError(Offender, Fn, "an integer", "an index"); procedure NonPairError(Offender, Fn); TypeError(Offender, Fn, "a pair"); procedure NonIdError(Offender, Fn); TypeError(Offender, Fn, "an identifier"); procedure NonNumberError(Offender, Fn); TypeError(Offender, Fn, "a number"); procedure NonIntegerError(Offender, Fn); TypeError(Offender, Fn, "an integer"); procedure NonPositiveIntegerError(Offender, Fn); TypeError(Offender, Fn, "a non-negative integer"); procedure NonCharacterError(Offender, Fn); TypeError(Offender, Fn, "a character"); procedure NonStringError(Offender, Fn); TypeError(Offender, Fn, "a string"); procedure NonVectorError(Offender, Fn); TypeError(Offender, Fn, "a vector"); procedure NonWords(Offender, Fn); TypeError(Offender, Fn, "a words vector"); procedure NonSequenceError(Offender, Fn); TypeError(Offender, Fn, "a sequence"); procedure NonIOChannelError(Offender, Fn); TypeError(Offender, Fn, "a legal I/O channel"); End; |
Added psl-1983/3-1/tests/nbigtest.doc version [01f8253bd4].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 15-Mar-83 08:09:34-MST,000000728;000000000001 Date: 15 Mar 1983 0809-MST From: Martin.Griss <Griss@UTAH-20> To: kessLER cc: griss Need to experiment with NBIG0 on Apollo. There may be still a small bug. Test as follows. Ship that latest NBIG0.RED that I sent you, rebuild it. Then ship and built PT:nbtest stuff. Load NBIG.LAP and NBTEST.B, call NTEST1 40; show1 40. This should work, and you should see a smooth range of INTEGERS, NEG intergers and correspnding floats (good test of WRUTE-FLOAT) Then call SETBITS 32; rerun NTEST1 40; SHOW1 40; I get signs incorrectly flipping at FIXNUM/BIGNUM transition points. I belive its related to a possibel BUG in 32-bit arith. Also compare <griss>32-bit.red with what lowder is running. M ------- |
Added psl-1983/3-1/tests/nbtest.b version [b9c33d0d05].
cannot compute difference between binary files
Added psl-1983/3-1/tests/nbtest.build version [436f627238].
> | 1 | in "nbtest.red"$ |
Added psl-1983/3-1/tests/nbtest.red version [bcca005784].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBTEST.RED - Test Bignum Numeric transition points % And other numeric tests % M. L. Griss, 6 Feb 1983 procedure fact N; Begin scalar m; m:=1; while n>0 do <<m:=m*n; n:=n-1>>; return m; End; on syslisp; syslsp procedure Ifact N; Begin scalar m; m:=1; while n>0 do <<m:=m*n; n:=n-1>>; return m; End; syslsp procedure ftest(n,m); for i:=1:n do fact m; syslsp procedure Iftest(n,m); for i:=1:n do ifact m; off syslisp; procedure Ntest0; Begin scalar n; N:=36; pos:=mkvect n; neg:=mkvect n; pos[0]:=1; neg[0]:=-1; for i:=1:N do <<pos[i]:=2*pos[i-1]; neg[i]:=(-pos[i])>>; end; procedure show0 n; <<show(n,pos,'ntype0); show(n,neg,'ntype0)>>; procedure Ntest1; Begin scalar n; N:=40; newpos:=mkvect n; newneg:=mkvect n; newpos[0]:=1; newneg[0]:=-1; for i:=1:n do <<newpos[i]:=2*newpos[i-1]; newneg[i]:=(-newpos[i])>>; end; procedure show1 n; <<show(n,newpos,'ntype1); show(n,newneg,'ntype1)>>; on syslisp; procedure NType0 x; case tag x of posint: 'POSINT; negint: 'negint; fixn: 'FIXN; bign: 'BIGN; fltn: 'fltn; default: 'NIL; end; procedure NType1 x; if Betap x and x>=0 then 'POSBETA else if Betap x and x<0 then 'NEGBETA else case tag x of posint: 'POSINT; negint: 'negint; fixn: 'FIXN; bign: 'BIGN; fltn: 'fltn; default: 'NIL; end; off syslisp; procedure show(N,v,pred); for i:=0:N do printf("%p%t%p%t%p%t%p%n",i,5,apply(pred,list(v[i])),20,v[i],40,float v[i]); end; |
Added psl-1983/3-1/tests/new-sym.red version [ee18a475fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Replacements for functions in usual xxx-CROSS.EXE which only read/write % xxx.SYM if flags !*symread/!*symwrite are T; otherwise symbols are % assumed to be already loaded (read case) or the cross-compiler is to % be saved intact with symbols (write case). lisp procedure ASMEnd; << off SysLisp; if !*MainFound then << CompileUncompiledExpressions(); % WriteInitFile(); InitializeSymbolTable() >> else WriteSymFile(); CodeFileTrailer(); Close CodeOut!*; DataFileTrailer(); Close DataOut!*; Close InitOut!*; RemD 'Lap; PutD('Lap, 'EXPR, cdr GetD 'OldLap); DFPRINT!* := NIL; !*DEFN := NIL; WriteSaveFile() >>; lisp procedure ReadSymFile(); if !*symread then LapIN InputSymFile!* else off usermode; lisp procedure WriteSymFile(); begin scalar NewOut, OldOut; if !*symwrite then << OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT)); print list('SaveForCompilation, MkQuote('progn . car ToBeCompiledExpressions!*)); SaveIDList(); SetqPrint 'NextIDNumber!*; SetqPrint 'StringGenSym!*; MapObl function PutPrintEntryAndSym; WRS OldOut; Close NewOut; >>; end; lisp procedure WriteSaveFile(); if !*symsave and (null !*mainfound) then % restore some initial conditions <<!*usermode := nil; DataExporteds!* := DataExternals!* := nil; CodeExporteds!* := CodeExternals!* := nil; !*MainFound:= nil; % save the cross-compiler with symbol tables intact dumplisp(cross!-compiler!-name) >>; !*symwrite := !*symread := nil; !*symsave := T; |
Added psl-1983/3-1/tests/new-test-case.red version [7c77b34739].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 5-Apr-83 07:45:58-MST,6502;000000000001 Return-path: <@UTAH-CS:GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Tue 5 Apr 83 07:43:05-MST Date: 5 Apr 1983 0633-PST From: GRISS@HP-HULK Subject: New-test-case.red Message-Id: <418401289.19796.hplabs@HP-VENUS> Received: by HP-VENUS via CHAOSNET; 5 Apr 1983 06:34:46-PST Received: by UTAH-CS.ARPA (3.320.5/3.7.6) id AA04736; 5 Apr 83 07:41:40 MST (Tue) To: kessler@HP-VENUS, griss@HP-VENUS % Tools to analyse the standard timing tests Fluid '(TestNames Fullnames Tests); imports '(mathlib); procedure readtest(name,fil); Begin scalar chan,body; chan := open(fil,'input); body:=channelread chan; put(name,'fullname,car body); body:=list(name) . cdr body; set(name,body); TestNames := name . TestNames; close chan; return body; End; procedure readalltests; Begin TestNames:=nil; Readtest('TestCray,"test-cray.tim"); Readtest('Std20,"standard-20.tim"); Readtest('Test20,"test-20.tim"); Readtest('Ext20,"extended-20.tim"); Readtest('TestExt20,"extended-test-20.tim"); Readtest('Fasthp9836,"16mhz-hp9836.tim"); Readtest('Std780,"standard-vax-780.tim"); Readtest('Fast780,"fast-780.tim"); Readtest('Franz780,"Franz-780.tim"); Readtest('Std750,"standard-vax-750.tim"); Readtest('Franz750,"Franz-750.tim"); Readtest('Stdhp9836,"standard-hp9836.tim"); Readtest('StdApollo,"standard-Apollo.tim"); % Non PSL Readtest('LM2,"LM2-hp.tim"); Readtest('BlkDolphin,"Block-dolphin.tim"); Print Testnames; Tests :=Evlis TestNames; return TestNames; End; Procedure Show body; Begin scalar HDR,fn; HDR:=car body; If (fn:=Get(car HDR,'ShowFn)) then return Apply(fn,list body); % Default Case Terpri(); prin2l car body; % Header Terpri(); While (body:=cdr body) do printf("%w%t%w%n",trimblanks caar body,Tab!*,NiceNum cdar body); End; procedure Lookup(Body,Facet); Begin scalar value; If pairp(value:=assoc(Facet,cdr Body)) then return cdr value; return 0.0; End; procedure ShowTotal Body; Begin scalar Hdr; Hdr:=car Body; printf("%p: %tTot%w, avg%w, dev %w , %w tests%n", Hdr, 10, Nicenum Lookup(Body,'total), nicenum Lookup(Body,'Average), nicenum Lookup(Body,'Deviation), Nicenum Lookup(Body,'Number)); End; put('total, 'showfn,' ShowTotal); Procedure Total body; Begin scalar Hdr,knt,tot,avg,dev,b; Knt:=0; Tot:=0; Dev:=0; Hdr:=car Body; While body:=cdr body do <<knt:=knt+1; b:=cdar body; tot:=tot + b; dev := b*b+dev; >>; Avg:=float(Tot)/knt; dev:=float(dev)/knt; dev:=dev-(avg*avg); dev:=sqrt(dev); b:=list('Total . Hdr, 'Total . tot, 'Average . avg, 'Deviation . dev, 'Number .knt); return b End; procedure Ratio(Body1,Body2); % Divide elements of Body1 by Elements of Body2 Begin scalar Hdr1,Hdr2,Rat,b1,b2,r,knt,avg,dev; Hdr1:=car body1; Hdr2:= car Body2; Body1:=cdr body1; Body2:=cdr Body2; If length body1 neq length body2 Then return "Length mismatch"; knt:=0; avg:=0; dev:=0; While Body1 do <<b1:=cdar body1; c:= caar body1; body1:=cdr body1; b2:=cdar body2; body2:=cdr body2; r:=float(b1)/b2; avg:=r + avg; dev:=r*r +dev; knt:=knt+1; rat := (c . r) . rat; >>; avg:=float(avg)/knt; dev:=float(dev)/knt; dev:=dev-(avg*avg); dev:=sqrt dev; rat := list('ratio,hdr1,hdr2) . reverse rat; return rat; end; procedure ratio20 body; Ratio(Body,std20); procedure Ratio780 body; Ratio(Body,std780); procedure Ratio750 body; Ratio(body,std780); procedure Ratiohp9836 body; Ratio(body,stdhp9836); procedure MapTest(Fns,TestList); % Apply each Fn in Fns to each test in list for each Test in TestList collect applyFns(Reverse FnS,list Test); Procedure ApplyFns(Fns,Args); If Not Pairp Fns then Car Args % Pass back else ApplyFns(cdr Fns, List Apply(car Fns,Args)); procedure MapBody(Fns,Body); % Apply series of Fns to each Element in Body of test Begin For each Fn in Fns do Body:=(Fn . car Body) . MapBody1(Fn, cdr body); return Body; End; procedure MapBody1(Fn,Body); If Null Body then NIL else ( caar body . Apply(Fn,list cdar body)) . MapBody1 (fn,cdr Body); %standard Maps Procedure Invert Body; MapBody('(Inverted), Body); Procedure Inverted x; 1.0/x; procedure Logarithm Body; MapBody('(LOG),Body); procedure summary(); <<readalltests(); wrs open("summary.tim",'output); printf("%n%n SUMMARY TESTS on %w%n%n",DATE()); mapall(); close wrs nil>>; Procedure MapAll; Begin scalar t20; T20:=Total Std20; Printf "%n Total Times %n"; MapTest('(show total),Tests); Printf "%n Ratio of Total Times to STD20%n"; for each test in Tests do showtotal ratio(Total test,t20); Printf "%n Average Each test Ratios to STD20%n"; MapTest('(show total ratio20),Tests); PrintF "%n 68000 Total times%n"; showtotal ratio(total StdHp9836,total FastHp9836); showtotal ratio(total StdApollo,total StdHp9836); PrintF "%n 68000 average ratios%n"; show total ratio(StdHp9836,FastHp9836); show total ratio(StdApollo,StdHp9836); End; procedure MapFileAll(fil,Fns); Begin scalar chan; chan:=open(fil,'output); wrs chan; MapTest(Fns,Tests); wrs nil; close chan; End; % Nicer printing procedure MakePowers(Base,M); Begin scalar V; V:=Mkvect M; v[0]:=1; for i:=1:M do V[i]:=Base* V[i-1]; return V; End; Tens!* := MakePowers(10,10); Procedure FLTRND(N,fld); If floatp N then Fix(FLD*N+.5)/float(fld) else N; Procedure NiceNum N; PadNM(N,nice!*,Fld!*); FLD!*:=3; Nice!*:=7; Tab!*:=30; Procedure PADNM(Num,n,m); % LeftPAD number in Field of N; Begin scalar m1,m2,FixPart; FixPart :=Fix Num; m1:=BLDMSG("%p",FIXPART); N:=N-Size(m1)-1; % Number of Blanks if n>0 then m1:=Concat(MkString(n-1,32),m1); if m>0 then <<NUM := NUM-Fixpart; m2:=BLDMSG("%p",FIX(num*Tens!*[m]+0.5)); M:=M-size(m2)-1; % Number of 0s if m>0 then m2:=Concat(MkString(m-1,48),m2); m1:=Concat(m1,concat(".",m2))>>; return m1; End; procedure TrimBlanks S; Begin scalar N; if not stringp s then return s; n:=Size s; While n>0 and (s[n]=char BLANK or s[n] = char TAB) do n:=n-1; return sub(s,0,n); End; End; ------- |
Added psl-1983/3-1/tests/new-time-psl.sl version [1f91e40057].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NEW-TIME.SL Driver of PSL "spectral" tests % After loading psl-timer.b, LAPIN this file (de test(x y) (prin2 x) (setq y (timeeval y)) (print y) (setq Cases!* (cons (cons x y) Cases!*)) 0) (de rtest(x y) (reclaim) (test x y)) (de printcases (fil) (wrs (open fil 'output)) (setq c (reverse Cases!*)) (prin2t "(") (while (pairp c) (print (car c)) (setq c (cdr c))) (prin2t ")") (close (wrs NIL)) ) (TestSetup) (setq Cases!* (cons (cons (versionname) (date)) NIL)) (prin2 '!") (prin2 "PSL Spectral Tests, ") (prin2 (versionname)) (prin2 ", ") (prin2 (date)) (prin2t '!") (rtest "EmptyTest-10000 " '(EmptyTest 10000)) (test "GEmptyTest-10000 " '(SlowEmptyTest 10000)) (test "Cdr1Test-100 " '(Cdr1Test 100)) (test "Cdr2Test-100 " '(Cdr2Test 100)) (test "CddrTest-100 " '(CddrTest 100)) (test "ListOnlyCdrTest1 " '(ListOnlyCdrTest1)) (test "ListOnlyCddrTest1 " '(ListOnlyCddrTest1)) (test "ListOnlyCdrTest2 " '(ListOnlyCdrTest2)) (test "ListOnlyCddrTest2 " '(ListOnlyCddrTest2)) (test "ReverseTest-10 " '(ReverseTest 10)) (rtest "MyReverse1Test-10 " '(MyReverse1Test 10)) (rtest "MyReverse2Test-10 " '(MyReverse2Test 10)) (rtest "LengthTest-100 " '(LengthTest 100)) (test "ArithmeticTest-10000 " '(ArithmeticTest 10000)) (test "EvalTest-10000 " '(EvalTest 10000)) (test "tak-18-12-6 " '(topleveltak 18 12 6)) (test "gtak-18-12-6 " '(toplevelgtak 18 12 6)) (test "gtsta-g0 " '(gtsta 'g0)) (test "gtsta-g1 " '(gtsta 'g1)) |
Added psl-1983/3-1/tests/old-time-psl.sl version [22a7cbd9f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % TIME-PSL.SL Driver of PSL "spectral" tests % After loading psl-timer.b, LAPIN this file (TestSetup) (progn (reclaim) (prin2 "EmptyTest 10000 ") (print (TimeEval '(EmptyTest 10000))) 0) (progn (prin2 "SlowEmptyTest 10000 ") (print (TimeEval '(SlowEmptyTest 10000))) 0) (progn (prin2 "Cdr1Test 100 ") (print (TimeEval '(Cdr1Test 100))) 0) (progn (prin2 "Cdr2Test 100 ") (print (TimeEval '(Cdr2Test 100))) 0) (progn (prin2 "CddrTest 100 ") (print (TimeEval '(CddrTest 100))) 0) (progn (prin2 "ListOnlyCdrTest1 ") (print (TimeEval '(ListOnlyCdrTest1))) 0) (progn (prin2 "ListOnlyCddrTest1 ") (print (TimeEval '(ListOnlyCddrTest1))) 0) (progn (prin2 "ListOnlyCdrTest2 ") (print (TimeEval '(ListOnlyCdrTest2))) 0) (progn (prin2 "ListOnlyCddrTest2 ") (print (TimeEval '(ListOnlyCddrTest2))) 0) (progn (prin2 "ReverseTest 10 ") (print (TimeEval '(ReverseTest 10))) 0) (progn (reclaim) (prin2 "MyReverse1Test 10 ") (print (TimeEval '(MyReverse1Test 10))) 0) (progn (reclaim) (prin2 "MyReverse2Test 10 ") (print (TimeEval '(MyReverse2Test 10))) 0) (progn (reclaim) (prin2 "LengthTest 100 ") (print (TimeEval '(LengthTest 100))) 0) (progn (prin2 "ArithmeticTest 10000 ") (print (TimeEval '(ArithmeticTest 10000))) 0) (progn (prin2 "EvalTest 10000 ") (print (TimeEval '(EvalTest 10000))) 0) (progn (prin2 "tak 18 12 6 ") (print (TimeEval '(topleveltak 18 12 6))) 0) (progn (prin2 "gtak 18 12 6 ") (print (TimeEval '(toplevelgtak 18 12 6))) 0) (progn (prin2 "gtsta g0 ") (print (TimeEval '(gtsta 'g0))) 0) (progn (prin2 "gtsta g1 ") (print (TimeEval '(gtsta 'g1))) 0) |
Added psl-1983/3-1/tests/other-machine.tim version [83912bf483].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 12-Apr-83 10:11:22-MST,1358;000000000001 Return-path: <marti@rand-unix> Received: from RAND-UNIX by UTAH-20; Tue 12 Apr 83 10:09:52-MST Date: Tuesday, 12 Apr 1983 09:05-PST To: griss at UTAH-20, kessler at UTAH-20 Subject: Timing test foul up. From: marti at rand-unix Yes, you are right, they are for the 780. Corrected table is: a b c d e Empty 10000 360 360 432 51 85 Slow 10000 360 360 1072 629 1258 CDR 1 (100) 6496 6497 5632 1700 2142 CDR 2 (100) 2919 2918 1296 1292 1734 CDDR (100) 2410 2410 912 1088 1377 ListOnlyCDR1 20253 20522 5264 6630 9656 ListOnlyCDDR 31733 31741 8080 13940 15708 ListOnlyCDR2 38784 38784 30368 9299 10761 ListOnlyCDDR2 49969 49978 33328 14569 18139 REVERSE (10) 4402 4443 976 714 1156 MyREVERSE (10) 5353 4340 2640 782 1139 MyREVERSE2 (10) 4965 4861 1472 612 1479 LENGTH (100) 8569 8570 5872 1734 2380 Arithmetic (10000) 12694 13083 23808 952 1632 EVAL (10000) 15374 15783 19616 6511 10200 TAK 18 12 6 4813 4818 4880 765 1377 GTAK 18 12 6 4732 4738 7408 4454 7463 gtsta g0 77765 80279 66656 2363 4573 gtsta g1 92125 93813 74544 2431 4505 a = Dolphin 1.5 meg, Interlisp-D. b = Dolphin 1 meg, Interlisp-D. c = VAX Interlisp (not newest??). d = VAX 780 PSL RAND (tests by JBM). e = VAX 750 PSL RAND (tests by JBM). Heaven only knows where I got those from. I can't find them in the newsletters. Jed. |
Added psl-1983/3-1/tests/p-allocators.red version [9d702bf105].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % P-ALLOCATORS.RED - Low level storage management % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % Revisions: % MLG, 19 June 1983 % Reset HeapLast to HeapPreviousLast in GTheap. % MLG, 20 Feb 1983 % Moved space declarations to XXX-HEADER.RED % Duplicated code body for GtEvect % Added InitHeap in XXX-HEADER.RED % Modified comments % <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE % Added GtEVect on SysLisp; external Wvar HeapLowerBound, HeapUpperBound, HeapLast, HeapPreviousLast, HeapTrapBound, NextBPS, LastBPS; syslsp procedure GtHEAP N; % get heap block of N words if null N then (HeapUpperBound - HeapLast) / AddressingUnitsPerItem else << HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then << HeapLast:=HeapPreviousLast; % Reset pointer before RECLAIM !%Reclaim(); HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then FatalError "Heap space exhausted" >>; HeapPreviousLast >>; syslsp procedure DelHeap(LowPointer, HighPointer); if HighPointer eq HeapLast then HeapLast := LowPointer; syslsp procedure GtSTR N; % Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtConstSTR N; % allocate un-collected string for print name begin scalar S, NW; % same as GtSTR, but uses BPS, not heap S := GtBPS((NW := STRPack N) + 1); @S := N; S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtHalfWords N; % Allocate space for N halfwords begin scalar S, NW; S := GtHEAP((NW := HalfWordPack N) + 1); @S := MkItem(HHalfWords, N); return S; end; syslsp procedure GtVECT N; % Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; syslsp procedure GtEVECT N; % Allocate space for a Evector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; syslsp procedure GtWRDS N; % Allocate space for N untraced words begin scalar W; W := GtHEAP(WRDPack N + 1); @W := MkItem(HWRDS, N); return W; end; syslsp procedure GtFIXN(); % allocate space for a fixnum begin scalar W; W := GtHEAP(WRDPack 0 + 1); @W := MkItem(HWRDS, 0); return W; end; syslsp procedure GtFLTN(); % allocate space for a float begin scalar W; W := GtHEAP(WRDPack 1 + 1); @W := MkItem(HWRDS, 1); return W; end; syslsp procedure GtID(); % Allocate a new ID % NextSymbol and HashTable are globally declared % IDs are allocated as a linked free list through the SymNam cell, % with a 0 to indicate the end of the list. begin scalar U; if NextSymbol = 0 then << Reclaim(); if NextSymbol = 0 then return FatalError "Ran out of ID space" >>; U := NextSymbol; NextSymbol := SymNam U; return U; end; syslsp procedure GtBPS N; % Allocate N words for binary code begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GTBPS NIL returns # left B := NextBPS; NextBPS := NextBPS + N*AddressingUnitsPerItem; return if NextBPS > LastBPS then StdError '"Ran out of binary program space" else B; end; syslsp procedure DelBPS(Bottom, Top); % Return space to BPS if NextBPS eq Top then NextBPS := Bottom; syslsp procedure GtWArray N; % Allocate N words for WVar/WArray/WString begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GtWArray NIL returns # left B := LastBPS - N*AddressingUnitsPerItem; return if NextBPS > B then StdError '"Ran out of WArray space" else LastBPS := B; end; syslsp procedure DelWArray(Bottom, Top); % Return space for WArray if LastBPS eq Bottom then LastBPS := Top; off SysLisp; END; |
Added psl-1983/3-1/tests/p-apply-lap.red version [31efd240f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-APPLY-LAP.RED - Inefficient, portable version of APPLY-LAP % % Author: Eric Benson and M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 29 July 1982 % Copyright (c) 1982 University of Utah % % Modifications by M.L. Griss 25 October, 1982. % Added J. MacDonalds Mods of 29 January (for IBM, non neg stack index) % In CODEEVALAPLY % Functions which must be written non-portably, % "portable" versions defined in PT:TEST-FUNCTION-PRIMITIVES.RED % CodePrimitive % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without distubing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. % CompiledCallingInterpreted % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the ID % in the fluid variable CodeForm!* without disturbing the argument % registers, then finish with % (!*JCALL CompiledCallingInterpretedAux) % (CompiledCallingInterpretedAux may be flagged 'InternalFunction). % FastApply % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). % UndefinedFunction % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. Compiletime << fluid '(CodePtr!* % gets code pointer used by CodePrimitive CodeForm!* % gets fn to be called from code ); >>; on Syslisp; external WArray CodeArgs; syslsp procedure CodeApply(CodePtr, ArgList); begin scalar I; I := 0; LispVar CodePtr!* := CodePtr; while PairP ArgList and ILessP(I, 15) do << WPutV(CodeArgs , I, first ArgList); I := IAdd1 I; ArgList := rest ArgList >>; if IGEQ(I, 15) then return StdError List("Too many arguments to function",I,CodePtr); return case I of 0: CodePrimitive(); 1: CodePrimitive WGetV(CodeArgs, 0); 2: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1)); 3: CodePrimitive(WGetV(CodeArgs, 0), WgetV(CodeArgs, 1), WGetV(CodeArgs, 2)); 4: CodePrimitive(WGetV(CodeArgs, 0), WgetV(CodeArgs, 1), WGetV(CodeArgs, 2), WgetV(CodeArgs, 3)); 5: CodePrimitive(WGetV(CodeArgs, 0), WgetV(CodeArgs, 1), WGetV(CodeArgs, 2), WgetV(CodeArgs, 3), WGetV(CodeArgs, 4)); 6: CodePrimitive(WGetV(CodeArgs, 0), WgetV(CodeArgs, 1), WGetV(CodeArgs, 2), WgetV(CodeArgs, 3), WGetV(CodeArgs, 4), WgetV(CodeArgs, 5)); 7: CodePrimitive(WGetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6)); 8: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7)); 9: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8)); 10: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9)); 11: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9), WgetV(CodeArgs, 10)); 12: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9), WgetV(CodeArgs, 10), WgetV(CodeArgs, 11)); 13: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9), WgetV(CodeArgs, 10), WgetV(CodeArgs, 11), WgetV(CodeArgs, 12)); 14: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9), WgetV(CodeArgs, 10), WgetV(CodeArgs, 11), WgetV(CodeArgs, 12), WgetV(CodeArgs, 13)); 15: CodePrimitive(WgetV(CodeArgs, 0), WgetV(CodeArgs, 1), WgetV(CodeArgs, 2), WgetV(CodeArgs, 3), WgetV(CodeArgs, 4), WgetV(CodeArgs, 5), WgetV(CodeArgs, 6), WgetV(CodeArgs, 7), WgetV(CodeArgs, 8), WgetV(CodeArgs, 9), WgetV(CodeArgs, 10), WgetV(CodeArgs, 11), WgetV(CodeArgs, 12), WgetV(CodeArgs, 13), WgetV(CodeArgs, 14)); end; end; %lisp procedure CodeEvalApply(CodePtr, ArgList); % CodeApply(CodePtr, EvLis ArgList); lap '((!*entry CodeEvalApply expr 2) (!*ALLOC 15) (!*LOC (reg 3) (frame 15)) %/jim really wrong/ % (!*LOC (reg 3) (frame 1)) %/jim: for non-neg stack indices on IBM/ % But must be base of a block of ascending % addresses, check cmacros (!*CALL CodeEvalApplyAux) (!*EXIT 15) ); syslsp procedure CodeEvalApplyAux(CodePtr, ArgList, P); begin scalar N; N := 0; while PairP ArgList and ILessP(N, 15) do %/ << WPutV(P, ITimes2(StackDirection, N), Eval first ArgList); %/jim/ << WPutV(P, N, Eval first ArgList); %/jim/ ArgList := rest ArgList; N := IAdd1 N >>; if IGEQ(N, 15) then return StdError list("Too many arguments to function",N,CodePtr); LispVar CodePtr!* := CodePtr; return case N of 0: CodePrimitive(); 1: CodePrimitive(WgetV(P, 0)); 2: CodePrimitive(WgetV(P, 0), WgetV(P, 1)); 3: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2)); 4: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3)); 5: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4)); 6: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5)); 7: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6)); 8: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7)); 9: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8)); 10: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9)); 11: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9), WgetV(P, 10)); 12: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9), WgetV(P, 10), WgetV(P, 11)); 13: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9), WgetV(P, 10), WgetV(P, 11), WgetV(P, 12)); 14: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9), WgetV(P, 10), WgetV(P, 11), WgetV(P, 12), WgetV(P, 13)); 15: CodePrimitive(WgetV(P, 0), WgetV(P, 1), WgetV(P, 2), WgetV(P, 3), WgetV(P, 4), WgetV(P, 5), WgetV(P, 6), WgetV(P, 7), WgetV(P, 8), WgetV(P, 9), WgetV(P, 10), WgetV(P, 11), WgetV(P, 12), WgetV(P, 13), WgetV(P, 14)); end; end; syslsp procedure BindEval(Formals, Args); BindEvalAux(Formals, Args, 0); syslsp procedure BindEvalAux(Formals, Args, N); begin scalar F, A; return if PairP Formals then if PairP Args then << F := first Formals; A := Eval first Args; N := BindEvalAux(rest Formals, rest Args, IAdd1 N); if N = -1 then -1 else << LBind1(F, A); N >> >> else -1 else if PairP Args then -1 else N; end; syslsp procedure CompiledCallingInterpretedAux(); << %Later Use NARGS also % Recall that ID# in CODEFORM CompiledCallingInterpretedAuxAux get(MkID(LispVar CodeForm!*), '!*LambdaLink)>>; syslsp procedure FastLambdaApply(); << SaveRegisters(); CompiledCallingInterpretedAuxAux LispVar CodeForm!* >>; syslsp procedure CompiledCallingInterpretedAuxAux Fn; if not (PairP Fn and car Fn = 'LAMBDA) then StdError BldMsg("Ill-formed functional expression %r for %r", Fn, LispVar CodeForm!*) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals do << LBind1(car Formals,WgetV(CodeArgs, N)); Formals := cdr Formals; N := IAdd1 N >>; Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off Syslisp; END; |
Added psl-1983/3-1/tests/p-comp-gc.red version [7875bd20bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % p-comp-GC.RED - Compacting garbage collector for PSL % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % WARNING! This file has not been parameterized using % AddressingUnitsPerItem. It will not work on machines that % address bytes. /csp 3-1-83 % All data types have either explicit header tag in first item, % or are assumed to be 1st element of pair. % Revision History: % Edit by Griss, 17 March 1983. % Move major data structures to XXX-HEADER: GCArray % Edit by Cris Perdue, 16 Feb 1983 1407-PST % Fixed GtHeap and collector(s) to use only HeapLast, not HeapPreviousLast % Sets HeapTrapped to NIL now. % Using known-free-space function % Added check of Heap-Warn-Level after %Reclaim % Defined and used known-free-space function % <PSL.KERNEL>COMPACTING-GC.RED.9, 4-Oct-82 17:59:55, Edit by BENSON % Added GCTime!* % <PSL.KERNEL>COMPACTING-GC.RED.3, 21-Sep-82 10:43:21, Edit by BENSON % Flagged most functions internal % (M.L. Griss, March, 1977). % (Update to speed up, July 1978) % Converted to Syslisp July 1980 % En-STRUCT-ed, Eric Benson April 1981 % Added EVECT tag, M. Griss, 3 July 1982 fluid '(!*GC % Controls printing of statistics GCTime!* % Total amount of time spent in GC GCKnt!* % count of # of GC's since system build heap!-warn!-level); % Continuable error if this much not % free after %Reclaim. LoadTime << !*GC := T; % Do print GC messages (SL Rep says no) GCTime!* := 0; GCKnt!* := 0; % Initialize to zero Heap!-Warn!-Level := 1000; >>; on Syslisp; % Predicates for whether to follow pointers external WVar HeapLowerBound, % Bottom of heap HeapUpperBound, % Top of heap HeapLast, % Last item allocated HeapTrapped; % Boolean: has trap occurred since GC? CompileTime << flag('(MarkFromAllBases BuildRelocationFields UpdateAllBases CompactHeap MarkFromOneSymbol MakeIDFreeList GCMessage MarkFromSymbols MarkFromRange MarkFromBase MarkFromVector GCError UpdateSymbols UpdateRegion UpdateItem UpdateHeap), 'NotYetInternalFunction); syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinHeapPointer X; X >= HeapLowerBound and X <= HeapLast; >>; % Marking primitives internal WConst GCMarkValue = 8#777, HSkip = Forward; CompileTime << syslsp smacro procedure Mark X; % Get GC mark bits in item X points to GCField @X; syslsp smacro procedure SetMark X; % Set GC mark bits in item X points to GCField @X := GCMarkValue; syslsp smacro procedure ClearMark X; % Clear GC mark bits in item X points to GCField @X := if NegIntP @X then -1 else 0; syslsp smacro procedure Marked X; % Is item pointed to by X marked? Mark X eq GCMarkValue; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; % Relocation primitives syslsp smacro procedure SkipLength X; % Stored in heap header Inf @X; syslsp smacro procedure PutSkipLength(X, L); % Store in heap header Inf @X := L; put('SkipLength, 'Assign!-Op, 'PutSkipLength); >>; internal WConst BitsInSegment = 13, SegmentLength = LShift(1, BitsInSegment), SegmentMask = SegmentLength - 1; External WArray GCArray; CompileTime << syslsp smacro procedure SegmentNumber X; % Get segment part of pointer LShift(X - HeapLowerBound, -BitsInSegment); syslsp smacro procedure OffsetInSegment X; % Get offset part of pointer LAnd(X - HeapLowerBound, SegmentMask); syslsp smacro procedure MovementWithinSegment X; % Reloc field in item GCField @X; syslsp smacro procedure PutMovementWithinSegment(X, M); % Store reloc field GCField @X := M; syslsp smacro procedure ClearMovementWithinSegment X; % Clear reloc field GCField @X := if NegIntP @X then -1 else 0; put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment); syslsp smacro procedure SegmentMovement X; % Segment table GCArray[X]; syslsp smacro procedure PutSegmentMovement(X, M); % Store in seg table GCArray[X] := M; put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement); syslsp smacro procedure Reloc X; % Compute pointer adjustment X - (SegmentMovement SegmentNumber X + MovementWithinSegment X); >>; external WVar ST, % stack pointer StackLowerBound; % bottom of stack % Base registers marked from by collector % SymNam, SymPrp and SymVal are declared for all external WVar NextSymbol; % next ID number to be allocated external WVar BndStkLowerBound, % Bottom of binding stack BndStkPtr; % Binding stack pointer internal WVar StackEnd, % Holds address of bottom of stack StackStart, % Holds address of top of stack MarkTag, % Used by MarkFromBase only Hole, % First location moved in heap HeapShrink, % Total amount reclaimed StartingRealTime; syslsp procedure Reclaim(); %. User call to garbage collector << !%Reclaim(); NIL >>; syslsp procedure !%Reclaim(); % Garbage collector << StackEnd := MakeAddressFromStackPointer ST - FrameSize(); StackStart := StackLowerBound; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; StartingRealTime := TimC(); LispVar GCKnt!* := LispVar GCKnt!* + 1; % must be INUM > 0, so needn't chk MarkFromAllBases(); MakeIDFreeList(); BuildRelocationFields(); UpdateAllBases(); CompactHeap(); HeapLast := HeapLast - HeapShrink; StartingRealTime := TimC() - StartingRealTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, StartingRealTime); if LispVar !*GC then GCMessage(); HeapTrapped := NIL; if IntInf known!-free!-space() < IntInf (LispVar Heap!-Warn!-Level) then ContinuableError(99, "Heap space low", NIL); >>; syslsp procedure MarkFromAllBases(); begin scalar B; MarkFromSymbols(); MarkFromRange(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do MarkFromBase @B; end; syslsp procedure MarkFromSymbols(); begin scalar B; MarkFromOneSymbol 128; % mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkFromOneSymbol I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkFromOneSymbol B >>; end; syslsp procedure MarkFromOneSymbol X; % SymNam has to be marked from before marking ID, since the mark uses its tag % No problem since it's only a string, can't reference itself. << MarkFromBase SymNam X; MarkID X; MarkFromBase SymPrp X; MarkFromBase SymVal X >>; syslsp procedure MarkFromRange(Low, High); for Ptr := Low step 1 until High do MarkFromBase @Ptr; syslsp procedure MarkFromBase Base; begin scalar MarkInfo; MarkTag := Tag Base; if not PointerTagP MarkTag then return << if MarkTag = ID and not null Base then << MarkInfo := IDInf Base; if not MarkedID MarkInfo then MarkFromOneSymbol MarkInfo >> >>; MarkInfo := Inf Base; if not WithinHeapPointer MarkInfo or Marked MarkInfo then return; SetMark MarkInfo; CommentOutCode CheckAndSetMark MarkInfo; return if MarkTag eq VECT or MarkTag eq EVECT then MarkFromVector MarkInfo else if MarkTag eq PAIR then << MarkFromBase car Base; MarkFromBase cdr Base >>; end; CommentOutCode << syslsp procedure CheckAndSetMark P; begin scalar HeadAtP; HeadAtP := Tag @P; case MarkTag of STR: if HeadAtP eq HBYTES then SetMark P; FIXN, FLTN, BIGN, WRDS: if HeadAtP eq HWRDS then SetMark P; VECT, EVECT: if HeadAtP eq HVECT then SetMark P; PAIR: SetMark P; default: GCError("Internal error in marking phase, at %o", P) end; end; >>; syslsp procedure MarkFromVector Info; begin scalar Uplim; CommentOutCode if Tag @Info neq HVECT then return; Uplim := &VecItm(Info, VecLen Info); for Ptr := &VecItm(Info, 0) step 1 until Uplim do MarkFromBase @Ptr; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure BuildRelocationFields(); % % Pass 2 - Turn off GC marks and Build SEGKNTs % begin scalar CurrentItem, SGCurrent, IGCurrent, TmpIG, DCount, SegLen; SGCurrent := IGCurrent := 0; SegmentMovement SGCurrent := 0; % Dummy Hole := HeapLowerBound - 1; % will be first hole DCount := HeapShrink := 0; % holes in current segment, total holes CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin scalar Incr; SegLen := case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: 2; % must be first of pair HBYTES: 1 + StrPack StrLen CurrentItem; HHalfwords: 1 + HalfWordPack StrLen CurrentItem; HWRDS: 1 + WrdPack WrdLen CurrentItem; HVECT: 1 + VectPack VecLen CurrentItem; HSKIP: SkipLength CurrentItem; default: GCError("Illegal item in heap at %o", CurrentItem) end; % case if Marked CurrentItem then % a hole if HeapShrink = 0 then ClearMark CurrentItem else % segment also clears mark << MovementWithinSegment CurrentItem := DCount; % incremental shift Incr := 0 >> % no shift else << @CurrentItem := MkItem(HSKIP, SegLen); % a skip mark Incr := 1; % more shift if Hole < HeapLowerBound then Hole := CurrentItem >>; TmpIG := IGCurrent + SegLen; % set SEG size CurrentItem := CurrentItem + SegLen; while TmpIG >= SegmentLength do begin scalar Tmp; Tmp := SegmentLength - IGCurrent; % Expand to next SEGMENT SegLen := SegLen - Tmp; if Incr eq 1 then HeapShrink := HeapShrink + Tmp; DCount := IGCurrent := 0; SGCurrent := SGCurrent + 1; SegmentMovement SGCurrent := HeapShrink; % Store Next Base TmpIG := TmpIG - SegmentLength; end; IGCurrent := TmpIG; if Incr eq 1 then << HeapShrink := HeapShrink + SegLen; DCount := DCount + SegLen >>; % Add in Hole Size end; SegmentMovement(SGCurrent + 1) := HeapShrink; end; syslsp procedure UpdateAllBases(); begin scalar B; UpdateSymbols(); UpdateRegion(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do UpdateItem B; UpdateHeap() >>; syslsp procedure UpdateSymbols(); for I := 0 step 1 until MaxSymbols do begin scalar NameLoc; NameLoc := &SymNam I; if StringP @NameLoc then << UpdateItem NameLoc; UpdateItem &SymVal I; UpdateItem &SymPrp I >>; end; syslsp procedure UpdateRegion(Low, High); for Ptr := Low step 1 until High do UpdateItem Ptr; syslsp procedure UpdateHeap(); begin scalar CurrentItem; CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND: CurrentItem := CurrentItem + 1; STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: << if Inf @CurrentItem >= Hole and Inf @CurrentItem <= HeapLast then Inf @CurrentItem := Reloc Inf @CurrentItem; CurrentItem := CurrentItem + 1 >>; HBYTES: CurrentItem := CurrentItem + 1 + StrPack StrLen CurrentItem; HHalfwords: CurrentItem := CurrentItem + 1 + HalfwordPack StrLen CurrentItem; HWRDS: CurrentItem := CurrentItem + 1 + WrdPack WrdLen CurrentItem; HVECT: begin scalar Tmp; Tmp := VecLen CurrentItem; CurrentItem := CurrentItem + 1; % Move over header for I := 0 step 1 until Tmp do % VecLen + 1 items begin scalar Tmp2, Tmp3; Tmp2 := @CurrentItem; Tmp3 := Tag Tmp2; if PointerTagP Tmp3 and Inf Tmp2 >= Hole and Inf Tmp2 <= HeapLast then Inf @CurrentItem := Reloc Inf Tmp2; CurrentItem := CurrentItem + 1; end; end; HSKIP: CurrentItem := CurrentItem + SkipLength CurrentItem; default: GCError("Internal error in updating phase at %o", CurrentItem) end; % case end end; syslsp procedure UpdateItem Ptr; begin scalar Tg, Info; Tg := Tag @Ptr; if not PointerTagP Tg then return; Info := INF @Ptr; if Info < Hole or Info > HeapLast then return; Inf @Ptr := Reloc Info; end; syslsp procedure CompactHeap(); begin scalar OldItemPtr, NewItemPtr, SegLen; if Hole < HeapLowerBound then return; NewItemPtr := OldItemPtr := Hole; while OldItemPtr < HeapLast do begin; case Tag @OldItemPtr of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: SegLen := PairPack OldItemPtr; HBYTES: SegLen := 1 + StrPack StrLen OldItemPtr; HHalfwords: SegLen := 1 + HalfWordPack HalfwordLen OldItemPtr; HWRDS: SegLen := 1 + WrdPack WrdLen OldItemPtr; HVECT: SegLen := 1 + VectPack VecLen OldItemPtr; HSKIP: << OldItemPtr := OldItemPtr + SkipLength OldItemPtr; goto WhileNext >>; default: GCError("Internal error in compaction at %o", OldItemPtr) end; % case ClearMovementWithinSegment OldItemPtr; for I := 1 step 1 until SegLen do << @NewItemPtr := @OldItemPtr; NewItemPtr := NewItemPtr + 1; OldItemPtr := OldItemPtr + 1 >>; WhileNext: end; end; syslsp procedure GCError(Message, P); << ErrorPrintF("***** Fatal error during garbage collection"); ErrorPrintF(Message, P); while T do Quit; >>; syslsp procedure GCMessage(); << ErrorPrintF("*** GC %w: time %d ms", LispVar GCKnt!*, StartingRealTime); ErrorPrintF("*** %d recovered, %d stable, %d active, %d free", HeapShrink, Hole - HeapLowerBound, HeapLast - Hole, intinf known!-free!-space() ) >>; off SysLisp; END; |
Added psl-1983/3-1/tests/p-fast-binder.red version [f13cb3baa8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % P-FAST-BINDER.RED - Portable version of binding from compiled code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % % This file is for use with *LAMBIND and *PROGBIND in % PC:P-LAMBIND.SL StartupTime << LambindArgs!* := GtWArray 15; >>; on Syslisp; syslsp procedure LamBind V; % V is vector of IDs begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do LBind1(VecItm(V, I), (LispVar LambindArgs!*)[I]); end; syslsp procedure ProgBind V; begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do PBind1 VecItm(V, I); end; off Syslisp; END; |
Added psl-1983/3-1/tests/p-function-primitives.red version [fa3bc82727].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % P-FUNCTION-PRIMITIVES Machine Independent for Test 5 and 6 % % Author: M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 October 1982 % Copyright (c) 1982 University of Utah % % Based on P20:Function-Primitives.Red % <PSL.TESTS>P-FUNCTION-PRIMITIVES.RED.4, 2-Mar-83 11:46:30, Edit by KESSLER % Put in Dealloc's before jump and jcall (search rrk) % Every ID has a "function cell". It does not necessarily contain a legal % Lisp item, and therefore should not be accessed directly by Lisp functions. % In this implementation the function cell contains an instruction to be % executed. There are 3 possibilites for this instruction, for which the % following predicates and updating functions exist: % % FUnBoundP(ID) -- the function is not defined % FLambdaLinkP(ID) -- the function is interpreted % FCodeP(ID) -- the function is compiled % % MakeFUnBound(ID) -- undefine the function % MakeFLambdaLink(ID) -- specify that the function is interpreted % MakeFCode(ID, CodePtr) -- specify that the function is compiled, % and that the code resides at the address % associated with CodePtr % % GetFCodePointer(ID) -- returns the contents of the function cell as a % code pointer % % See the templates in XXX-ASM.RED: % % DefinedFunctionCellFormat!* % UndefinedFunctionCellFormat!* % These functions currently check that they have proper arguments, % but this may change since they are only used by functions that % have checked them already. % Note that on some machines, SYMFNC(x) is entire SYMFNC cell. % on others it points into the cell, at the "address" part. % % Fairly Portable versions, based on assumption that % Starts with OPCODE, probably !*JCALL % !*Jcall SymfncBase UndefinedFunction in ShouldBeUndefined cell % Needs the machine-dependent procedures in XXX-HEADER: % !%Store!-JCALL(CodeAddress,StoreAddress) % to Create a !*Jcall(CodeAddress) at StoreAddress % !%Copy!-Function!-Cell(From,to) % to copy appropriate # words or bytes of Function cell on syslisp; smacro procedure SymFncBase D; % The Address of CELL, % to which !*JCALL and !*CALL jump Symfnc + AddressingUnitsPerFunctionCell*D; % Unbound Functions have a JCALL UndefinedFunction: % in the function cell, installed by the template syslsp procedure FUnBoundP Fn; % Check If undefn or Not If not IDP Fn then NonIdError(Fn,'FunboundP) else if (SymFnc IdLoc ShouldBeUndefined eq SymFnc IdInf Fn) % Instead of SYMFNCBASE Idloc UndefinedFunction, since its % of course DEFINED, and has to agree with the KernelTime template then 'T else 'NIL; syslsp procedure MakeFUnBound(D); % Install the correct Bit Pattern in SYMFNC cell If not IDP D then NonIdError(D,'MakeFUnbound) else !%copy!-function!-cell(symfncbase Idloc ShouldBeUndefined, symfncbase IdInf D); syslsp procedure FLambdaLinkP fn; If not IDP Fn then NonIdError(Fn,'FunboundP) else if (SymFnc IdLoc CompiledCallingInterpreted eq SymFnc(IdInf Fn)) % This installed by MakeFlambdaLink then 'T else 'NIL; syslsp procedure MakeFlambdaLink D; % Install the correct Bit Pattern in SYMFNC cell If not IDP D then NonIdError(D,'MakeFUnbound) else !%store!-JCALL(symfnc Idloc CompiledCallingInterpreted, Symfncbase IdInf D); % SetUp as above syslsp procedure FcodeP Fn; % Check if Code or Interp If not IDP Fn then NonIdError(Fn,'FcodeP) else if FUnboundP Fn or FLambdaLinkP Fn then NIL else T; syslsp procedure MakeFCode(U, CodePtr); % Make U a compiled function if IDP U then if CodeP CodePtr then <<!%Store!-JCALL(CodeInf Codeptr, SymfncBase IdInf U); NIL >> else NonIDError(U, 'MakeFCode); syslsp procedure GetFCodePointer U; % Get code pointer for U if IDP U then if FCodeP U then MkCODE SymFnc U % do we want Fcodep check else NIL else NonIDError(U, 'GetFCodePointer); %/Check that IS codeP? % Code Calling Primitives % See PI: P-APPLY-LAP.RED by BENSON % See also Pxxx:APPLY-LAP.RED Fluid '(CodePtr!* CodeForm!* CodeNarg!*); LAP '((!*entry CodePrimitive expr 15) % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without disturbing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. (!*ALLOC 0) (!*MOVE (Fluid CodePtr!*) (reg t1)) (!*FIELD (reg t1) (reg t1) % get CodeINF (WConst InfStartingBit) (WConst InfBitLength)) % rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump (!*Dealloc 0) (!*JUMP (memory (reg t1) (Wconst 0))) (!*EXIT 0) ); LAP '((!*entry CompiledCallingInterpreted expr 15) % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the % Linkreg into % the fluid variable CodeForm!* without disturbing the argument % registers % % (!*ALLOC 0) (!*CALL SaveRegisters) % !*CALL to avoid resetting LinkInfo (!*Move (reg LinkReg) (fluid CodeForm!*)) (!*Move (reg NargReg) (fluid CodeNarg!*)) % rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump (!*Dealloc 0) (!*JCALL CompiledCallingInterpretedAux) (!*Exit 0) ); LAP '((!*entry FastApply expr 0) % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). (!*ALLOC 0) (!*MOVE (reg t1) (FLUID CodeForm!*)) % save input form (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*FIELD (reg t1) (reg t1) (WConst InfStartingBit) (WConst InfBitLength)) (!*JUMPNOTEQ (Label NotAnID) (reg t2) (WConst ID)) (!*MOVE (reg t1) (reg LinkReg)) % Reset IDLOC name % NargReg is OK (!*WTIMES2 (reg t1) (WConst AddressingUnitsPerFunctionCell)) % rrk 03/03/83 (!*Dealloc 0) (!*JUMP (MEMORY (reg t1) (WArray SymFnc))) NotAnID (!*JUMPNOTEQ (Label NotACodePointer) (reg t2) (WConst CODE)) % rrk 03/03/83 (!*Dealloc 0) (!*JUMP (MEMORY (reg t1) (WConst 0))) NotACodePointer (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR)) (!*MOVE (MEMORY (reg t1) (WConst 0)) (reg t2)) % CAR with pair already untagged (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (QUOTE LAMBDA)) % rrk 03/03/83 (!*Dealloc 0) % Note that t1 is INF of the PAIR (!*JCALL FastLambdaApply) % CodeForm!* % Already Loaded IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form in Apply") (reg 1)) (!*MOVE (FLUID CodeForm!*) (reg 2)) (!*CALL List2) % rrk 03/03/83 (!*Dealloc 0) (!*JCALL StdError) % (!*EXIT 0) --> what is this! ); Exported Warray CodeArgs[15]; syslsp procedure SaveRegisters(A1, A2, A3, A4, A5, % Duplicate in P-APPLY A6, A7, A8, A9, A10, A11, A12, A13, A14, A15); << CodeArgs[14] := A15; CodeArgs[13] := A14; CodeArgs[12] := A13; CodeArgs[11] := A12; CodeArgs[10] := A11; CodeArgs[9] := A10; CodeArgs[8] := A9; CodeArgs[7] := A8; CodeArgs[6] := A7; CodeArgs[5] := A6; CodeArgs[4] := A5; CodeArgs[3] := A4; CodeArgs[2] := A3; CodeArgs[1] := A2; CodeArgs[0] := A1 >>; LAP '((!*ENTRY UndefinedFunctionAux expr 0) % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. (!*ALLOC 0) (!*CALL SaveRegisters) % !*CALL so as not to change LinkInfo % Was stored in UndefnCode!* UndefnNarg!* % rrk 03/03/83 (!*Dealloc 0) (!*JCALL UndefinedFunctionAuxAux) % (!*EXIT 0) ); off syslisp; End; |
Added psl-1983/3-1/tests/p-lambind.sl version [5459cc7ece].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-LAMBIND.SL - Portable cmacro definitions *LAMBIND, *PROGBIND and *FREERSTR % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % % Modification by MLG to preserve REG 1 across FREERSTR % 19 March,1983 (compiletime (load useful)) (imports '(syslisp)) % requires SYSLISP for AddrUnitsPerItem (de *lambind (regs fluids) (prog (n firstreg) (setq n 0) (setq regs (rest regs)) % remove REGISTERS at the front (setq fluids (rest fluids)) % remove NONLOCALVARS at the front (setq fluids % convert fluids list into vector (list2vector (foreach x in fluids collect (second x)))) (setq firstreg (first regs)) (setq regs (rest regs)) (return (if (null regs) % only one to bind `((*move ,firstreg (reg 2)) (*move `,',(getv fluids 0) (reg 1)) (*call lbind1)) `((*move ,firstreg (memory (fluid LambindArgs*) (wconst 0))) (*move (fluid LambindArgs*) ,firstreg) ,@(foreach x in regs collect (progn (setq n (add1 n)) `(*move ,x (memory ,firstreg (wconst (wtimes2 (wconst AddressingUnitsPerItem) (wconst ,n))))))) (*move `,',fluids (reg 1)) (*call lambind)))))) (defcmacro *lambind) (de *progbind (fluids) (if (null (rest (rest fluids))) `((*move `,',(second (first (rest fluids))) (reg 1)) (*call pbind1)) `((*move `,',(list2vector (foreach x in (rest fluids) collect (second x))) (reg 1)) (*call progbind)))) (defcmacro *progbind) (de *freerstr (fluids) `((*move (reg 1) (Fluid FreeRstrSave!*)) (*move `,',(length (rest fluids)) (reg 1)) (*call UnBindN) (*move (Fluid FreeRstrSave!*) (reg 1)))) (defcmacro *freerstr) (setq *unsafebinder t) % has to save registers across calls |
Added psl-1983/3-1/tests/pascal-support.red version [619838df2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | { XXX Support Routines, Test Version M. L. Griss, and S. Lowder 9 July 1982 } Var Ctime:Integer; { For CPU Time } Procedure XXX_Init(var c:integer); begin WriteLn(Output, ' Init the XXX package ',c); Ctime :=10*SysClock; { First Call on Timer } end; Procedure XXX_PutC(var c:integer); begin Write(Output,chr(c)); end; Procedure XXX_GetC(var c:integer); var ch:char; begin read(keyboard,ch); c := ord(ch); end; Procedure XXX_TimC(var c:integer); var i:integer; begin i:=10* SysClock; {Call timer again} c := i-Ctime; Writeln(Output,' Ctime ', i, c); Ctime := i; end; Procedure XXX_Quit(var c:integer); { close files, cleanup and exit } begin Writeln(Output,' Quitting '); ESCAPE(0); { "normal" exit, ie HALT} end; Procedure XXX_Err(var c:integer); begin Writeln(Output,' XXX Error call Number: ', c); ESCAPE(c); end; Procedure XXX_PutI(var c:integer); { Print an Integer } begin Writeln(Output,' PutI: ', c); end; end. |
Added psl-1983/3-1/tests/pk-modules.list version [071ea82c04].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PK: modules/files ALLOC Allocators Copiers Cons-mkvect Comp-support System-gc Gc ARITH Arithmetic DEBG Mini-trace Mini-editor Backtrace ERROR Error-handlers Type-errors Error-errorset Io-errors EVAL Apply-lap Eval-apply Catch-throw Prog-and-friends EXTRA Timc System-extras Trap Dumplisp FASL System-faslout System-faslin Faslin Load Autoload P20:HEAP [Declare HEAP,BPS] IO Io-data Char-io Open-close Rds-wrs Other-io Read Token-scanner Printers Write-float Printf Explode-compress Io-extensions MACRO Eval-when Cont-error Lisp-macros Onoff Define-smacro Defconst String-gensym Loop-macros MAIN Main-start PROP Function-primitives Property-list Fluid-global Putd-getd RANDM Known-to-comp-sl Others-sl Equal Carcdr Easy-sl Easy-non-sl Sets SYMBL Binding Fast-binder Symbol-values Oblist SYSIO System-io Scan-table TLOOP Break Top-loop Dskin TYPES Type-conversions Vectors Sequence |
Added psl-1983/3-1/tests/prog.tst version [8647271c53].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Some interpreted tests of PROG for MAIN9 (Dashed "Expect 1 printed") (shouldbe "Prog Value" (PROG NIL (print 1)) NIL) (Dashed "Expect 1 and 2 printed") (shouldbe "Prog value" (PROG NIL (print 1) (print 2) (return 3)) 3) (Dashed "Test 1 var PROG binding") (ShouldBe "Before PROG, x=" (setq x 2) 2) (Shouldbe "Prog value" (PROG (X) (ShouldBe "Inside prog, x=" x NIL) (setq x 3) (ShouldBe "After setq, x=" x 3) ) NIL) (ShouldBe "after exit, x=" x 2) (Dashed "Test 2 var PROG binding") (ShouldBe "Before PROG, x=" (setq x 2) 2) (ShouldBe "Before PROG, y=" (setq y 20) 20) (Shouldbe "Prog value" (PROG (X Y) (ShouldBe "Inside prog, x=" x NIL) (ShouldBe "Inside prog, y=" y NIL) (setq x 3) (setq y 30) (ShouldBe "After setq, x=" x 3) (ShouldBe "After setq, y=" y 30) ) NIL) (ShouldBe "after exit, x=" x 2) (ShouldBe "after exit, y=" y 20) (dashed "Test simple loop in prog") (shouldbe "Return 0 after 5 loops" (prog (x) (setq x 6) (prin2t "Expect x to decrease from 5 to 1") L (setq x (sub1 x)) (prin2 " In loop x=")(prin2T x) (cond ((greaterp x 1) (go L))) (return 0)) 0) (shouldbe "Return 1 after 5 loops" (prog (x) (setq x 5) (prin2T "Expect x to decrease from 5 to 1") L (cond ((lessp x 1) (return 1))) (prin2 " In loop, x=") (Prin2t x) (setq x (sub1 x)) (go L)) 1) |
Added psl-1983/3-1/tests/psl-timer.b version [a08a50216b].
cannot compute difference between binary files
Added psl-1983/3-1/tests/psl-timer.sl version [ebd057d2e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PSL-TIMER.SL Source of PSL "spectral" tests % Compile this file to produce psl-timer.b % then LAPIN the file "time-psl.sl" '( (sstatus translink t) (declare (localf tak gtak)) (def de (macro (x) (cons 'defun (cdr x)))) (def igreaterp (macro (x) (cons '> (cdr x)))) (def ilessp (macro (x) (cons '< (cdr x)))) (def iadd1 (macro (x) (cons '1+ (cdr x)))) (def isub1 (macro (x) (cons '1- (cdr x)))) (def itimes2 (macro (x) (cons '* (cdr x)))) (allocate 'fixnum 2000) (allocate 'list 500) (setq $gcprint t) (defun time () (* (car (ptime)) 17)) (defun reclaim () (gc)) ) (fluid '(TestList TestList2 LongList EvalForm)) (de TestSetup () (progn (setq TestList (PrepareTest 1000)) (setq TestList2 (PrepareTest 2000)) (MakeLongList) (setq EvalForm '(setq Foo (cadr '(1 2 3)))))) (de MakeLongList () (prog (I) (setq LongList '(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 I 0) loop (cond ((igreaterp I 5) (return nil))) (setq LongList (append LongList LongList)) (setq I (iadd1 I)) (go loop))) (de PrepareTest (n) (prog (l i) (setq i -1 l nil) top (cond ((ilessp n i) (return l))) (setq i (iadd1 i) l (cons nil l)) (go top))) (de Cdr1Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((atom (setq L (cdr L))) (go loop))) (go loop1))) (de Cdr2Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cdr L))) (go loop))) (go loop1))) (de CddrTest (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cddr L))) (go loop))) (go loop1))) (de ListOnlyCdrTest1 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((null (setq l2 (cdr l2))) (cond ((null (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest1 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((null (setq l2 (cddr l2))) (cond ((null (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCdrTest2 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((atom (setq l2 (cdr l2))) (cond ((atom (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest2 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((atom (setq l2 (cddr l2))) (cond ((atom (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de EmptyTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (setq I (iadd1 I)) (go loop))) (de SlowEmptyTest (N) (prog (I) (setq I 0) loop (cond ((greaterp I N) (return nil))) (setq I (add1 I)) (go loop))) (de ReverseTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (reverse LongList) (setq I (iadd1 I)) (go loop))) (de MyReverse1Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse1 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse1 (L) (prog (M) loop (cond ((atom L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de MyReverse2Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse2 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse2 (L) (prog (M) loop (cond ((null L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de LengthTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (length LongList) (setq I (iadd1 I)) (go loop))) (de Fact (N) (cond ((ilessp N 2) 1) (t (itimes2 N (Fact (isub1 N)))))) (de ArithmeticTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (Fact 9) (setq I (iadd1 I)) (go loop))) (de EvalTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (eval EvalForm) (setq I (iadd1 I)) (go loop))) (de TimeEval (Form) (prog (I) (setq I (time)) (eval Form) (return (difference (time) I)))) (de topleveltak (x y z) (tak x y z)) (de tak (x y z) (cond ((null (ilessp y x)) z) (t (tak (tak (isub1 x) y z) (tak (isub1 y) z x) (tak (isub1 z) x y))))) (de toplevelgtak (x y z) (gtak x y z)) (de gtak (x y z) (cond ((null (lessp y x)) z) (t (gtak (gtak (sub1 x) y z) (gtak (sub1 y) z x) (gtak (sub1 z) x y))))) (de gtsta (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (apply F (list I)) (setq I (iadd1 I)) (go Loop))) (de gtstb (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (funcall F I) (setq I (iadd1 I)) (go Loop))) (de g0 (X) X) (de g1 (X) (iadd1 X)) (de nreverse (x) (nreconc x nil)) (de nreconc (x y) (prog (z) L (cond ((atom x) (return y))) (setq z x) (setq x (cdr x)) (setq y (rplacd z y)) (go L))) (de nnils (N) (prog (LST i) (setq i 0) loop (cond ((igreaterp i N) (return LST))) (setq LST (cons nil LST)) (setq i (iadd1 i)) (go loop))) (global '(TestGlobalVar)) (de nils (N) (setq TESTGLOBALVAR (nnils N)) N) (de nr () (setq TESTGLOBALVAR (nreverse TESTGLOBALVAR)) nil) |
Added psl-1983/3-1/tests/psl-times.lpt version [e02bbb62d8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL 3.1 times in ms, taken at HP Computer Research Center, 5 Dec 1982 --------------------------------------------------------------------- DEC-20 VAX-780 HP9836 Empty 20 34 70 SlowEmpty 284 612 1930 Cdr1 531 1632 2660 Cdr2 385 1241 1120 Cddr 304 986 850 ListOnlyCdr1 1806 5695 6700 ListOnlyCddr1 3703 11832 10090 ListOnlyCdr2 2804 8806 15960 ListOnlyCddr2 4599 14875 19270 Reverse 273 646 1480 MyReverse1 270 629 1470 MyReverse2 253 680 1310 Length 567 1632 3080 Arithmetic 605 833 6560 Eval 1901 5865 17650 tak(18,12,6) 446 697 2770 gtak(18,12,6) 1882 4029 13130 gtsta g0 727 2363 5810 gtsta g1 789 2397 5980 PSL 3.0 Times in ms taken at Utah and RAND, July-Aug 1982 or earlier -------------------------------------------------------------------- PSL PSL PSL FRANZ APOLLO APOLLO TEST 20 750 780 OPUS 38 8 Mhz 10 Mhz Empty 25 68 0 391 105 56 SlowEmpty 344 1139 663 3587 2330 1289 Cdr1 576 2023 1632 3791 3281 1886 Cdr2 367 1581 1224 1326 1449 648 Cddr 293 1275 1071 867 1068 851 ListOnlyCdr1 1754 9367 7208 6902 8658 4975 ListOnlyCddr1 3487 15232 12410 9027 12761 7734 ListOnlyCdr2 2864 12206 9418 21590 19611 11159 ListOnlyCddr2 4644 18003 15164 24106 23696 13933 Reverse 335 1037 748 663 3102 1806 MyReverse1 269 1071 697 867 3094 1826 MyReverse2 249 1020 629 697 2746 984 Length 585 2142 1700 4811 3847 2203 Arithmetic 589 1887 867 7667 3007 1852 Eval 1857 9384 5083 10098 15759 9509 tak(18,12,6) 442 1292 765 1887 2644 1627 gtak(18,12,6) 1902 7344 4267 18479 15140 8433 gtsta g0 829 4675 2533 13617 7720 4284 gtsta g1 890 4709 2465 25143 7888 4371 [The initial HP9836 times are uniformly between those of the small 8Mz and large 10Mz Apollo, Wicat was slightly slower] |
Added psl-1983/3-1/tests/psltest.sl version [291f15bb73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%% Standard - LISP Verification file. %%%%%%%%%%%%%%%%%%%%%%% % % Copyright (C) M. Griss and J. Marti, February 1981 % Adapted to test PSL by M. L. Griss and E. Benson % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Set ECHO In caller, as desired (SETQ !*RAISE NIL) % Checks in ID tests (SETQ !*BREAK NIL) % So error messages proceed (DE MSG(X) % Prints general message (COND (!*ECHO NIL) (T (PROGN (PRIN2T X) NIL)))) (DE EXPECT(X) % Prints message about values (COND (!*ECHO NIL) (T (PROGN (PRIN2 " ----- Expect the following to Return: ") (PRIN2T X) NIL)))) (EXPECT "T T T T") T (NULL NIL) (COND (T T)) (COND (NIL NIL) (T T)) (EXPECT "NIL NIL NIL NIL") NIL (NULL T) (COND (T NIL)) (COND (NIL T) (T NIL)) (EXPECT "0 0") 0 (QUOTE 0) (MSG "Test the following minimum set of functions:") (MSG "PUTD, PROG, SET, QUOTE, COND, NULL, RETURN, LIST, CAR, CDR,") (MSG "EVAL, PRINT, PRIN1, TERPRI, PROGN, GO.") (MSG "Check PUTD, GETD, LAMBDA ") (PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) 3))) (EXPECT "(EXPR LAMBDA (X) 3)") (GETD (QUOTE FOO)) (EXPECT "3 3") (FOO 1) (FOO 2) (EXPECT "1 1") (SET (QUOTE A) 1) A (EXPECT "2 2") (SET (QUOTE B) 2) B (MSG "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) (MSG "Test REDEFINITION in PUTD, PROGN, PRIN1, TERPRI") (PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) (PROGN (PRIN1 X) (TERPRI))))) (EXPECT "1 2 NIL") (FOO 1) (FOO 2) (EXPECT "Test simple PROG, GO, RETURN: expect 1 2 NIL 1") (PROG NIL (PRINT 1) (PRINT 2)) (PROG (A) (PRINT A) (PRINT 1)) (MSG "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) ) (MSG "Test that A,B correctly rebound, expect AA and BB") A B (MSG "Redefine FOO as simple FEXPR") (PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (X) (PRINT X)))) (EXPECT "(FEXPR LAMBDA (X) (PRINT X))") (GETD (QUOTE FOO)) (EXPECT "FOO calls to return (1) (1 2) and (1 2 3)") (FOO 1) (FOO 1 2) (FOO 1 2 3) (MSG "Finally, TEST EVAL inside an FEXPR") (PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (XX) (PRINT (EVAL (CAR XX)))))) (EXPECT "1 T") (FOO 1) (FOO (NULL NIL)) %---- The main tester ----- % PUTD is being used here to define a function !$TEST. (PUTD (QUOTE !$TEST) (QUOTE FEXPR) (QUOTE (LAMBDA (!$X) (PROG (A B) (SETQ A (CDR !$X)) % Space for test set (TERPRI) (PRIN2 "------ Beginning ") (PRIN1 (CAR !$X)) (PRIN2T " tests -----") LOOP (COND ((NULL (PAIRP A)) (RETURN (PROGN (PRIN2 "------ Finished ") (PRIN1 (CAR !$X)) (PRIN2T " tests -----") 0)))) (PRIN2 " try: ") (PRINT (CAR A)) (SETQ B (EVAL (CAR A))) (COND ( (NULL (EQ B 'T)) (PROGN (PRIN2 "****** ") (PRINT A) (PRIN2 " -> ") (PRINT B)))) (SETQ A (CDR A)) (GO LOOP) )))) (EXPECT "T and T if $TEST correctly defined") (PAIRP (GETD (QUOTE !$TEST))) (EQCAR (GETD (QUOTE !$TEST)) (QUOTE FEXPR)) % 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 1.0 1.0) (EQN 0.0 0.0) (NULL (EQN 1.0 0.0)) (NULL (EQN 0.0 1.0)) (NULL (EQN 1 1.0)) (NULL (EQN 0 0.0)) (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-----% (!$TEST ABS (EQN 0 (ABS 0)) (EQN 1 (ABS 1)) (EQN 1 (ABS -1)) (EQN 0.0 (ABS 0.0)) (EQN 1.0 (ABS 1.0)) (EQN 1.0 (ABS (MINUS 1.0))) ) (!$TEST ADD1 (EQN 1 (ADD1 0)) (EQN 0 (ADD1 -1)) (EQN 2 (ADD1 1)) (EQN 1.0 (ADD1 0.0)) (EQN 2.0 (ADD1 1.0)) ) (!$TEST DIFFERENCE (EQN 0 (DIFFERENCE 1 1)) (EQN 0.0 (DIFFERENCE 1.0 1.0)) (EQN 0.0 (DIFFERENCE 1 1.0)) (EQN 0.0 (DIFFERENCE 1.0 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 1.0)) (FIXP (FIX 1.0)) (NULL (FLOATP (FIX 1.0))) (EQN (FIX 1.0 ) 1) (NUMBERP (FIX 1)) (FIXP (FIX 1)) ) (!$TEST FLOAT (NUMBERP (FLOAT 1)) (FLOATP (FLOAT 1)) (NULL (FIXP (FLOAT 1))) (EQN 1.0 (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) ; (MAX) (!$TEST MAX2 (EQN (MAX2 1 2) 2) (EQN (MAX2 2 1) 2) (EQN 1 (MAX2 1 0)) (EQN 1 (MAX2 0 1)) (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) ; (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) ; (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) ; (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))))) ) (SETQ DIGITLST (QUOTE (!0 !1 !2 !3 !4 !5 !6 !7 !8 !9))) (DE TESTEACH (LST FN) (PROG (X) L1 (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 ; |
Added psl-1983/3-1/tests/reduce-timing.txt version [529e6874f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 6-Apr-83 12:04:55-MST,1641;000000000001 Return-path: <@UTAH-CS:GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Wed 6 Apr 83 12:03:19-MST Date: 6 Apr 1983 1049-PST From: GRISS@HP-HULK Subject: Latest REDUCE-TIMES.DOC Message-Id: <418503140.11433.hplabs@HP-VENUS> Received: by HP-VENUS via CHAOSNET; 6 Apr 1983 10:52:19-PST Received: by UTAH-CS.ARPA (3.320.5/3.7.6) id AA16318; 6 Apr 83 12:00:03 MST (Wed) To: kessler@HP-VENUS, griss@HP-VENUS Standard Reduce Test file, as of 6 April 1983 This is IN "RTEST:REDUCE.TST"; which echoes to the terminal. MATR and HIPHYS modules autoload. Includes NBIG module. Need LISP ON GC; before IN of REDUCE.TST. System Heap Run GC time #GC Sys Total Time Date PSL 3.1 based: DEC-20/60, Utah 90K 24.4 7.0 3 ? 31.4 3/6/83 Extended DEC-20/60, Utah 260K 25.9 1.0 1 ? 26.9 3/6/83 VAX-780, Unix 4.1, HP 400K 48.3 0 0 ~12 ~60 3/6/83 VAX-750, Unix 4.1a, Utah VAX-750, Unix 4.1a, Rand ~90 HP9836, 8Mhz MC68000, HP ~120 Apollo, 8Mhz MC68000, Utah ~175 [We still need to include some SYSTEM or I/O time, on VAX it is quite high. Ie, need TIMS() and TIMR() calls for load, paging, etc. What is equivalent on other machines?. Memory sizes Utah 20/60 HP DEC-20/60 5.625 Mb (1.25M 36 bit words) HP VAX-780 4.0 Mb Utah Vax 750 Rand Vax 750 HP9836 4.5 Mb Apollo 1 Mb LISP 1.6 IBM Standard LISP ------- |
Added psl-1983/3-1/tests/seive.tst version [0c286976b2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 27-Mar-83 09:09:18-MST,4778;000000000001 Return-path: <GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Sun 27 Mar 83 09:07:41-MST Date: 27 Mar 1983 0753-PST From: GRISS@HP-HULK Subject: String and vector Message-Id: <417628520.17208.hplabs@HP-VENUS> Received: by HP-VENUS via CHAOSNET; 27 Mar 1983 07:55:19-PST Received: by UTAH-CS.ARPA (3.320.3/3.7.4) id AA28476; 27 Mar 83 08:59:13 MST (Sun) To: kessler@HP-VENUS, griss@HP-VENUS I was doing some timings on SIEVE.RED (attached) on VAX and 20. Havent yet done for 68000. Compared with C on VAX: a) Proportionately, VECTOR much slower on VAX; due to need to multiply by 4 to convert VECITM(V,i)=> V+4*(i+1) on VAX; if I work with P4=4*P, (CheatVtest), am getting code about as fast as C on the VAX for Vectors. b) On VAX, string pointer of course just byte address, while on 20 have to unpack bytes, using LDB and ADJBP, so that STRING much slower than even on VAX! 26 March, tests of SIEVE.C and SIEVE.RED on MARS, vax-790 --------------------------------------------------------- 100 loops of sieve of Eratosthenes, on 1000 length sieve. This is a set of LOOPs with no procedure calls (in C or SYSLISP). Test C Fast C PSL SYSLISP SYSLISP/fast C STRING 3264 2941 66130 3519 1.2 VECTOR 3077 2720 26520 4284 (a) 1.6 On DEC-20, String 33970 5970 (b) Vector 11370 1896 (c) Notes: (a) on VAX, use 4*index as pointer, get 2618, and code similar to C. (b) notice that this slower than VAX, since using LDB and ADJBP on 20 but direct BYTE address on VAX. (c) on 20, if we use pointer rather than index, get 1541 which is not as dramatic as on the VAx, since not saving the 4* to convert index to BYTE address (d) Fast-C uses the -O code improvment option, and some loops seem to use a AOBLEQ (on VAX, like AOBJN on 20). May want to start thinking about Code-Gen improvments, and source to source improvements to catch these and similar constructs. Discuss with Mark, Jed, Bobbie % sieve.red ----- on comp; Fluid '(Tim1 Tim2); on syslisp; procedure start(); Lispvar(tim1) :=timc(); procedure done s; <<lispvar(tim2):=timc(); printf(" ---- %p ---%p%n",s,lispvar(tim2)-lispvar(tim1)); >>; procedure TestSL n; begin scalar primes; primes := Mkstring(1000,1); start(); for i:=1:n do Lsieve primes; done "lsieve, string"; end; procedure TestVL n; begin scalar primes; primes := MkVect(1000); start(); for i:=1:n do Lsieve primes; done "lsieve, vector"; end; procedure TestV n; begin scalar primes; primes := Mkvect 1000; start(); for i:=1:n do Vsieve primes; done "Vsieve"; end; procedure TestCheatV n; begin scalar primes; primes := Mkvect 1000; start(); for i:=1:n do CheatVsieve primes; done "CheatVsieve"; end; procedure TestS n; begin scalar primes; primes := Mkstring(1000,1); start(); for i:=1:n do Ssieve primes; done "Ssieve"; end; off syslisp; lisp procedure lsieve(primes); begin scalar p, mp; for i:=0:1000 do setindx(primes,1); % printf("Primes%n"); for p := 2:1000 do if indx(primes, p) eq 1 then << % printf(" %d%n", p); for mp := 2*p step p until 1000 do setindx(primes, mp, 0) >> end; on syslisp; syslisp procedure ssieve(primes); begin scalar p, mp; primes := strinf primes; for i:=0:1000 do strbyt(primes,i):=1; % printf("Primes%n"); for p := 2:1000 do if strbyt(primes, p) eq 1 then << % printf(" %d%n", p); for mp := 2*p step p until 1000 do strbyt(primes, mp) := 0 >> end; syslisp procedure vsieve(primes); begin scalar p, mp; primes := vecinf(primes); for p:=0:1000 do vecitm(vecinf primes,p):=1; % printf("Primes%n"); for p := 2:1000 do if vecitm(primes, p) eq 1 then << % printf(" %d%n", p); for mp := 2*p step p until 1000 do vecitm(primes, mp) := 0 >> end; syslisp procedure Cheatvsieve(primes); begin scalar p, p4, mp,mp4, base; primes := vecinf(primes); base := primes +addressingunitsperitem; p4:= base +0; for p:=0:1000 do <<putmem(p4,1); p4:=p4+addressingunitsperitem>>; % printf("Primes%n"); p4:=base+2*addressingunitsperitem; for p := 2:1000 do << if getmem( p4) eq 1 then << % printf(" %d%n", p); mp4 := base +2*addressingunitsperitem*p; for mp := 2*p step p until 1000 do <<putmem(mp4,0); mp4:=mp4+addressingunitsperitem >> >>; p4 :=p4 +addressingunitsperitem>> end; off syslisp; end; ------- |
Added psl-1983/3-1/tests/simpler-time.sl version [4a87e8ec06].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | (TESTSETUP) % USE after each fresh start (TIMEEVAL '(EMPTYTEST 10000)) (TIMEEVAL '(SLOWEMPTYTEST 10000)) (TIMEEVAL '(CDR1TEST 100)) (TIMEEVAL '(CDR2TEST 100)) (TIMEEVAL '(CDDRTEST 100)) (TIMEEVAL '(LISTONLYCDRTEST1)) (TIMEEVAL '(LISTONLYCDDRTEST1)) (TIMEEVAL '(LISTONLYCDRTEST2)) (TIMEEVAL '(LISTONLYCDDRTEST2)) (TIMEEVAL '(REVERSETEST 10)) (TIMEEVAL '(MYREVERSE1TEST 10)) (TIMEEVAL '(MYREVERSE2TEST 10)) (TIMEEVAL '(LENGTHTEST 100)) (TIMEEVAL '(ARITHMETICTEST 10000)) (TIMEEVAL '(EVALTEST 10000)) (TIMEEVAL '(TOPLEVELTAK 18 12 6)) (TIMEEVAL '(TOPLEVELGTAK 18 12 6)) (TIMEEVAL '(GTSTB 'G0)) (TIMEEVAL '(GTSTB 'G1)) |
Added psl-1983/3-1/tests/standard-20.tim version [bf93b74b0d].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("DEC-20, standard 3.1 PSL" . "5-Mar-83 ") (EmptyTest-10000 . 18) (GEmptyTest-10000 . 280) (Cdr1Test-100 . 525) (Cdr2Test-100 . 372) (CddrTest-100 . 274) (ListOnlyCdrTest1 . 1780) (ListOnlyCddrTest1 . 3392) (ListOnlyCdrTest2 . 2721) (ListOnlyCddrTest2 . 4114) (ReverseTest-10 . 265) (MyReverse1Test-10 . 267) (MyReverse2Test-10 . 246) (LengthTest-100 . 568) (ArithmeticTest-10000 . 593) (EvalTest-10000 . 1919) (tak-18-12-6 . 493) (gtak-18-12-6 . 1975) (gtsta-g0 . 733) (gtsta-g1 . 799) ) |
Added psl-1983/3-1/tests/standard-apollo.tim version [7d83e87742].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % improved PAIRP added (("standard Apollo 3.1 PSL 29-mar-83") (EmptyTest-10000 . 75) (SlowEmptyTest-10000 . 1939) (Cdr1Test-100 . 1806) (Cdr2Test-100 . 1268) (CddrTest-100 . 943) (ListOnlyCdrTest1 . 7629) (ListOnlyCddrTest1 . 11280) (ListOnlyCdrTest2 . 10843) (ListOnlyCddrTest2 . 14615) (ReverseTest-10 . 1532) (MyReverse1Test-10 . 1517) % slower 2492 (MyReverse2Test-10 . 1438) (LengthTest-100 . 2261) (ArithmeticTest-10000 . 6832) (EvalTest-10000 . 16336) (tak-18-12-6 . 2318) (gtak-18-12-6 . 12644) (gtsta-g0 . 6658) % slower 7098 (gtsta-g1 . 6880) % slower 7150 ) %(EmptyTest-10000 . 0.803816) %(SlowEmptyTest-10000 . 2.1205428) %(Cdr1Test-100 . 2.9690535) %(Cdr2Test-100 . 1.2983992) %(CddrTest-100 . 0.9800398) %(ListOnlyCdrTest1 . 7.7453597) %(ListOnlyCddrTest1 . 11.5986295) %(ListOnlyCdrTest2 . 17.7415738) %(ListOnlyCddrTest2 . 21.4907193) %(ReverseTest-10 . 2.9006324) %(MyReverse1Test-10 . 2.7918677) %(MyReverse2Test-10 . 1.5556617) %(LengthTest-100 . 3.4324918) %(ArithmeticTest-10000 . 7.2217984) %(EvalTest-10000 . 19.1918912) %(tak-18-12-6 . 2.4505582) %(gtak-18-12-6 . 13.8012662) %(gtsta-g0 . 6.8267789) %(gtsta-g1 . 7.385675) ) ------- |
Added psl-1983/3-1/tests/standard-cray.tim version [129cf3de7c].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Spectral Tests, Cray test system, No-Date-Yet --------------------------------------------------------------- *** Dummy RECLAIM: 19587 Items used, 130413 Items left. EmptyTest 10000 2414 SlowEmptyTest 10000 35791 Cdr1Test 100 58905 Cdr2Test 100 50505 CddrTest 100 38961 ListOnlyCdrTest1 301698 ListOnlyCddrTest1 439219 ListOnlyCdrTest2 352000 ListOnlyCddrTest2 489314 ReverseTest 10 91640 *** Dummy RECLAIM: 56645 Items used, 93355 Items left. MyReverse1Test 10 92964 *** Dummy RECLAIM: 93304 Items used, 56696 Items left. MyReverse2Test 10 85904 *** Dummy RECLAIM: 129963 Items used, 20037 Items left. LengthTest 100 54925 ArithmeticTest 10000 87468 EvalTest 10000 533178 tak 18 12 6 49782 gtak 18 12 6 237455 gtsta g0 280169 gtsta g1 282683 |
Added psl-1983/3-1/tests/standard-hp9836.tim version [3689146d8a].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("PSL 3.1, Standard 8Mhz HP9836" . " 5-Mar-83") (EmptyTest-10000 . 70) (GEmptyTest-10000 . 1930) (Cdr1Test-100 . 2660) (Cdr2Test-100 . 1120) (CddrTest-100 . 850) (ListOnlyCdrTest1 . 6700) (ListOnlyCddrTest1 . 10090) (ListOnlyCdrTest2 . 15960) (ListOnlyCddrTest2 . 19270) (ReverseTest-10 . 1480) (MyReverse1Test-10 . 1470) (MyReverse2Test-10 . 1310) (LengthTest-100 . 3080) (ArithmeticTest-10000 . 6560) (EvalTest-10000 . 17650) (tak-18-12-6 . 2770) (gtak-18-12-6 . 13130) (gtsta-g0 . 5810) (gtsta-g1 . 5980) ) |
Added psl-1983/3-1/tests/standard-vax-750.tim version [1595d88708].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("PSL 3.1, Standard VAX 750, Utah-cs, 6-Mar-83") (EmptyTest-10000 . 51) (GEmptyTest-10000 . 1224) (Cdr1Test-100 . 2074) (Cdr2Test-100 . 1530) (CddrTest-100 . 1411) (ListOnlyCdrTest1 . 9860) (ListOnlyCddrTest1 . 15793) (ListOnlyCdrTest2 . 12937) (ListOnlyCddrTest2 . 19023) (ReverseTest-10 . 1139) (MyReverse1Test-10 . 1207) (MyReverse2Test-10 . 1088) (LengthTest-100 . 2482) (ArithmeticTest-10000 . 1972) (EvalTest-10000 . 10268) (tak-18-12-6 . 1326) (gtak-18-12-6 . 7565) (gtsta-g0 . 4539) (gtsta-g1 . 4879) ) |
Added psl-1983/3-1/tests/standard-vax-780.tim version [0fcaf46cc7].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("PSL 3.1, Standard VAX 780 " . " 5-Mar-83") (EmptyTest-10000 . 51) (GEmptyTest-10000 . 646) (Cdr1Test-100 . 1564) (Cdr2Test-100 . 1105) (CddrTest-100 . 969) (ListOnlyCdrTest1 . 6749) (ListOnlyCddrTest1 . 12070) (ListOnlyCdrTest2 . 9384) (ListOnlyCddrTest2 . 14824) (ReverseTest-10 . 714) (MyReverse1Test-10 . 697) (MyReverse2Test-10 . 612) (LengthTest-100 . 1666) (ArithmeticTest-10000 . 833) (EvalTest-10000 . 6562) (tak-18-12-6 . 816) (gtak-18-12-6 . 5627) (gtsta-g0 . 2720) (gtsta-g1 . 3077) ) |
Added psl-1983/3-1/tests/stubs2.red version [098674cfe9].
> > > > > > > | 1 2 3 4 5 6 7 | % STUBS2.RED % just a dummy for now procedure Flag(x, y); List('dummy, 'flag, x,y); END; |
Added psl-1983/3-1/tests/stubs3.red version [4ed3308e7a].
> > > > > > | 1 2 3 4 5 6 | % STUBS3.RED - Mini RECLAIM called % MLG, 18 Feb 1983 in "pt:mini-gc.red"$ End; |
Added psl-1983/3-1/tests/stubs4.red version [21f08977b0].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % STUBS4.RED - Stubs to support more automatic testing from TEST4 and on procedure SpaceD(M); <<Prin2 " "; Prin2t M>>; procedure DasheD(M); <<Terpri(); Prin2 "---------- "; Prin2T M>>; procedure DotteD(M); <<Terpri(); Prin2 " ....... "; Prin2T M>>; Procedure ShouldBe(M,v,e); % test if V eq e; <<Prin2 " ....... For ";Prin2 M; Prin2 '" "; Prin1 v; Prin2 '" should be "; Prin1 e; if v eq e then Prin2T '" [OK ]" else Prin2T '" [BAD] *******">>; End; |
Added psl-1983/3-1/tests/stubs5.red version [f5274cc99e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % STUBS5.RED - Stubs for TEST5 and Above Fluid '(UndefnCode!* UndefnNarg!*); on syslisp; syslsp procedure UndefinedFunctionAuxAux; % Interim version of UndefinedFunctionAux; Begin scalar FnId,Nargs; Nargs:=LispVar UndefnNarg!*; FnId := MkID (LispVar UndefnCode!*); Prin2 "Undefined Function "; Prin1 FnId; Prin2 " called with "; Prin2 Nargs; prin2T " args from compiled code"; Quit; End; % Some SYSLISP tools for debugging: syslsp procedure INF x; Inf x; syslsp procedure TAG x; TAG x; syslsp procedure MKITEM(x,y); MkItem(X,y); off syslisp; End; |
Added psl-1983/3-1/tests/stubs6.red version [dfef47434c].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % STUBS6.RED -Stubs introduced for TEST6 and up in "PT:mini-top-loop.red"$ On syslisp; Procedure FUNCALL(FN,I); IDApply1(I,FN); off syslisp; END; |
Added psl-1983/3-1/tests/stubs7.red version [6b98bac22d].
> > > > > | 1 2 3 4 5 | % STUBS7.RED % none yet End; |
Added psl-1983/3-1/tests/stubs8.red version [b51e3c4194].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % STUBS8.RED - Stubs as GC is installed procedure Known!-free!-space(); 1; procedure ContinuableError(x,y); <<print list ("Continuable Error ",x,y); y>>; END; |
Added psl-1983/3-1/tests/stubs9.red version [ca5f0eccf4].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % STUBS9.RED procedure MkQuote x; List('quote,x); procedure flag(x,y); NIL; End; |
Added psl-1983/3-1/tests/sub2.red version [c1ab97d426].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | % SUB2.RED - More comprehensive Mini I/O in "pt:mini-char-io.red"$ In "pt:mini-printers.red"$ In "pt:mini-printf.red"$ In "pt:mini-error-errorset.red"$ In "pt:mini-error-handlers.red"$ In "pt:mini-type-errors.red"$ End; |
Added psl-1983/3-1/tests/sub3.red version [b26fcbd896].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % SUB3.RED : Crude Mini Allocator and CONS In "pt:P-allocators.red"$ In "pt:mini-cons-mkvect.red"$ in "pk:comp-support.red"$ In "pt:mini-sequence.red"$ End; |
Added psl-1983/3-1/tests/sub4.red version [95690aed86].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % SUB4.RED - Mini RATOM and READ. Requires SUB3, SUB2 and IO % Note setting of DEBUG to get diagnostic output % Revisions: MLG, 18 Feb 1983 % ADD %..EOL as comment for test files in "pt:mini-equal.red"$ in "pt:mini-token.red"$ in "pt:mini-oblist.red"$ in "pt:mini-read.red"$ End; |
Added psl-1983/3-1/tests/sub5a.red version [3d6484a4eb].
> > > > > > > | 1 2 3 4 5 6 7 | % SUB5a.RED, part 1, EVAL part in "pt:p-function-primitives.red"$ in "pt:p-apply-lap.red"$ in "pt:mini-eval-apply.red"$ End; |
Added psl-1983/3-1/tests/sub5b.red version [627a09f8c8].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % SUB5b.RED : EVAL and support functions % Needs SUB4, SUB3, SUB2, IO modules in "pt:mini-arithmetic.red"$ in "pk:carcdr.red"$ in "pt:mini-easy-sl.red"$ in "pt:mini-easy-non-sl.red"$ in "pk:known-to-comp-sl.red"$ in "pt:mini-loop-macros.red"$ in "pt:mini-others-sl.red"$ in "pt:mini-fluid-global.red"$ in "pt:mini-property-list.red"$ in "pt:mini-symbol-values.red"$ in "pt:mini-type-conversions.red"$ off syslisp; end; |
Added psl-1983/3-1/tests/sub6.red version [eb06dfe0a4].
> > > > > > > > | 1 2 3 4 5 6 7 8 | % SUB6.RED - User defined LAMBDAs and BINDING, etc. in "pk:binding.red"$ in "pt:p-fast-binder.red"$ in "pt:mini-putd-getd.red"$ End; |
Added psl-1983/3-1/tests/sub7.red version [a0d62b1bce].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % SUB7.RED - Support and tests of File I/O % Will Also test BINARY I/O for FASL in "xxx-system-io.red"$ in "pt:io-data.red"$ In "pt:mini-io-errors.red"$ in "pt:mini-dskin.red"$ in "pt:mini-open-close.red"$ in "pt:mini-rds-wrs.red"$ in "pt:system-io.red"$ End; |
Added psl-1983/3-1/tests/sub8.red version [d954ede403].
> > > | 1 2 3 | % SUB8.RED - Install GC for machine IN "xxx-GC.RED"; End; |
Added psl-1983/3-1/tests/sub9.red version [14d630e6a2].
> > > > > > | 1 2 3 4 5 6 | % SUB9.RED - Catch and throw stuff in "pk:catch-throw.red"$ in "pk:prog-and-friends.red"$ end; |
Added psl-1983/3-1/tests/summary.tim version [8759b11cc9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 5-Apr-83 07:45:56-MST,6095;000000000001 Return-path: <@UTAH-CS:GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Tue 5 Apr 83 07:42:55-MST Date: 5 Apr 1983 0632-PST From: GRISS@HP-HULK Subject: summary.tim Message-Id: <418401264.19777.hplabs@HP-VENUS> Received: by HP-VENUS via CHAOSNET; 5 Apr 1983 06:34:23-PST Received: by UTAH-CS.ARPA (3.320.5/3.7.6) id AA04724; 5 Apr 83 07:41:25 MST (Tue) To: kessler@HP-VENUS, griss@HP-VENUS SUMMARY TESTS on 2-Apr-83 Total Times (TOTAL BLKDOLPHIN): Tot 386690.000, avg 20352.105, dev 26417.830 , 19.000 tests (TOTAL LM2): Tot 98971.000, avg 5209.000, dev 5183.557 , 19.000 tests (TOTAL STDAPOLLO): Tot 108814.000, avg 5727.053, dev 5053.535 , 19.000 tests (TOTAL STDHP9836): Tot 117890.000, avg 6204.737, dev 5954.895 , 19.000 tests (TOTAL FRANZ750): Tot 156825.000, avg 8253.947, dev 8252.232 , 19.000 tests (TOTAL STD750): Tot 100368.000, avg 5282.526, dev 5518.533 , 19.000 tests (TOTAL FRANZ780): Tot 102524.000, avg 5396.000, dev 5561.586 , 19.000 tests (TOTAL FAST780): Tot 56199.000, avg 2957.842, dev 3255.864 , 19.000 tests (TOTAL STD780): Tot 70686.000, avg 3720.316, dev 4218.948 , 19.000 tests (TOTAL FASTHP9836): Tot 47420.000, avg 2495.789, dev 2380.819 , 19.000 tests (TOTAL TESTEXT20): Tot 24202.000, avg 1273.789, dev 1291.616 , 19.000 tests (TOTAL EXT20): Tot 23036.000, avg 1212.421, dev 1204.962 , 19.000 tests (TOTAL TEST20): Tot 23300.000, avg 1226.316, dev 1211.688 , 19.000 tests (TOTAL STD20): Tot 21334.000, avg 1122.842, dev 1158.361 , 19.000 tests (TOTAL TESTCRAY): Tot 3511.080, avg 184.794, dev 166.001 , 19.000 tests Ratio of Total Times to STD20 (RATIO (TOTAL BLKDOLPHIN) (TOTAL STD20)): Tot 18.126, avg 18.126, dev 22.806 , 1.000 tests (RATIO (TOTAL LM2) (TOTAL STD20)): Tot 4.639, avg 4.639, dev 4.475 , 1.000 tests (RATIO (TOTAL STDAPOLLO) (TOTAL STD20)): Tot 5.100, avg 5.100, dev 4.363 , 1.000 tests (RATIO (TOTAL STDHP9836) (TOTAL STD20)): Tot 5.526, avg 5.526, dev 5.141 , 1.000 tests (RATIO (TOTAL FRANZ750) (TOTAL STD20)): Tot 7.351, avg 7.351, dev 7.124 , 1.000 tests (RATIO (TOTAL STD750) (TOTAL STD20)): Tot 4.705, avg 4.705, dev 4.764 , 1.000 tests (RATIO (TOTAL FRANZ780) (TOTAL STD20)): Tot 4.806, avg 4.806, dev 4.801 , 1.000 tests (RATIO (TOTAL FAST780) (TOTAL STD20)): Tot 2.634, avg 2.634, dev 2.811 , 1.000 tests (RATIO (TOTAL STD780) (TOTAL STD20)): Tot 3.313, avg 3.313, dev 3.642 , 1.000 tests (RATIO (TOTAL FASTHP9836) (TOTAL STD20)): Tot 2.223, avg 2.223, dev 2.055 , 1.000 tests (RATIO (TOTAL TESTEXT20) (TOTAL STD20)): Tot 1.134, avg 1.134, dev 1.115 , 1.000 tests (RATIO (TOTAL EXT20) (TOTAL STD20)): Tot 1.080, avg 1.080, dev 1.040 , 1.000 tests (RATIO (TOTAL TEST20) (TOTAL STD20)): Tot 1.092, avg 1.092, dev 1.046 , 1.000 tests (RATIO (TOTAL STD20) (TOTAL STD20)): Tot 1.000, avg 1.000, dev 1.000 , 1.000 tests (RATIO (TOTAL TESTCRAY) (TOTAL STD20)): Tot 0.165, avg 0.165, dev 0.143 , 1.000 tests Average Each test Ratios to STD20 (TOTAL RATIO (BLKDOLPHIN) (STD20)): Tot 432.295, avg 22.752, dev 31.310 , 19.000 tests (TOTAL RATIO (LM2) (STD20)): Tot 95.112, avg 5.006, dev 2.463 , 19.000 tests (TOTAL RATIO (STDAPOLLO) (STD20)): Tot 106.651, avg 5.613, dev 2.300 , 19.000 tests (TOTAL RATIO (STDHP9836) (STD20)): Tot 109.025, avg 5.738, dev 2.072 , 19.000 tests (TOTAL RATIO (FRANZ750) (STD20)): Tot 168.689, avg 8.878, dev 7.563 , 19.000 tests (TOTAL RATIO (STD750) (STD20)): Tot 85.098, avg 4.479, dev 0.923 , 19.000 tests (TOTAL RATIO (FRANZ780) (STD20)): Tot 112.513, avg 5.922, dev 5.652 , 19.000 tests (TOTAL RATIO (FAST780) (STD20)): Tot 46.153, avg 2.429, dev 0.517 , 19.000 tests (TOTAL RATIO (STD780) (STD20)): Tot 56.645, avg 2.981, dev 0.672 , 19.000 tests (TOTAL RATIO (FASTHP9836) (STD20)): Tot 44.557, avg 2.345, dev 0.849 , 19.000 tests (TOTAL RATIO (TESTEXT20) (STD20)): Tot 24.473, avg 1.288, dev 0.539 , 19.000 tests (TOTAL RATIO (EXT20) (STD20)): Tot 21.802, avg 1.147, dev 0.279 , 19.000 tests (TOTAL RATIO (TEST20) (STD20)): Tot 22.377, avg 1.178, dev 0.336 , 19.000 tests (TOTAL RATIO (STD20) (STD20)): Tot 19.000, avg 1.000, dev 0.000 , 19.000 tests (TOTAL RATIO (TESTCRAY) (STD20)): Tot 3.605, avg 0.190, dev 0.095 , 19.000 tests 68000 Total times (RATIO (TOTAL STDHP9836) (TOTAL FASTHP9836)): Tot 2.486, avg 2.486, dev 2.501 , 1.000 tests (RATIO (TOTAL STDAPOLLO) (TOTAL STDHP9836)): Tot 0.923, avg 0.923, dev 0.849 , 1.000 tests 68000 average ratios (TOTAL RATIO (STDHP9836) (FASTHP9836)): Tot 46.617, avg 2.454, dev 0.119 , 19.000 tests (TOTAL RATIO (STDAPOLLO) (STDHP9836)): Tot 18.653, avg 0.982, dev 0.160 , 19.000 tests ------- |
Added psl-1983/3-1/tests/system-io.red version [9529278456].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %============================================================================== % % SYSTEM-IO.RED - System independent IO routines for PSL % % Author: Modified by Robert R. Kessler % From System-io.red for the VAX by Eric Benson % Computer Science Dept. % University of Utah % Date: Modified 16 August 1982 % Original Date 16 September 1981 % % Copyright (c) 1982 University of Utah % %============================================================================== % Each individual system must have the following routines defined. % % The following definitions are used in the routines: % FileDescriptor - A machine dependent word that references a file once % opened; generated by the Open % FileName - A Lisp string of the file name. % % FileDescriptor := SysOpenRead (Channel,FileName); % % Open FileName for input and % % return a file descriptor used % % in later references to the % % file. Channel used only % % if needed to generate FileDesc % FileDescriptor := SysOpenWrite (Channel,FileName); % % Open FileName for output and % % return a file descriptor used % % in later references to the % % file. Channel used only % % if needed to generate FileDesc % SysWriteRec (FileDescriptor, StringToWrite, StringLength); % % Write StringLength characters % % from StringToWrite from the % % first position. % LengthRead := SysReadRec (FileDescriptor, StringBuffer); % % Read from the FileDescriptor, a % % record into the StringBuffer. % % Return the length of the % % string read. % SysClose (FileDescriptor); % Close FileDescriptor, allowing % % it to be reused. % TerminalInputHandler (FileDescriptor); % Input from the terminal, on % % FileDescriptor. This routine % % is expected to use the prompt % % in PromptString!*. % %============================================================================== CompileTime Load Fast!-Vector; global '(IN!* OUT!*); LoadTime << IN!* := 0; OUT!* := 1; >>; fluid '(StdIN!* StdOUT!* ErrOUT!* PromptOUT!* !*Echo); LoadTime << StdIN!* := 0; StdOUT!* := 1; ErrOUT!* := 5; PromptOUT!* := 6; >>; %============================================================================== % on SysLisp; % The channel table contains the actual file descriptor as returned from % the open routines. Since the file descriptor may be any value, it % may not be used in finding a free channel. Therefore, we now have a % warray ChannelStatus that is the current status of the channel. % NOTE: ChannelStatus must be initialized to all closed. % The following constants are used to indicate the status of the Channel. WConst ChannelClosed = 0, ChannelOpenRead = 1, ChannelOpenWrite = 2, ChannelOpenSpecial = 3; % Look into the ChannelStatus array for a free channel. syslsp procedure FindFreeChannel(); begin scalar Channel; Channel := 0; while ChannelStatus [Channel] neq ChannelClosed do << if Channel >= MaxChannels then IOError "No free channels left"; Channel := Channel + 1 >>; return Channel; end; CompileTime fluid '(IOBuffer); % Open the argument filename as a read only file. syslsp procedure SystemOpenFileForInput FileName; begin scalar Channel; Channel := FindFreeChannel(); ChannelTable [Channel] := SysOpenRead (Channel,FileName); ChannelStatus[Channel] := ChannelOpenRead; MaxBuffer [Channel] := SysMaxBuffer (ChannelTable [Channel]); ReadFunction [Channel] := 'IndependentReadChar; WriteFunction [Channel] := 'ReadOnlyChannel; CloseFunction [Channel] := 'IndependentCloseChannel; IGetV (LispVar IOBuffer, Channel) := MkString (MaxBuffer [Channel], 32); NextPosition [Channel] := 0; % Will be post Incremented BufferLength [Channel] := -1; return Channel; end; syslsp procedure SystemOpenFileForOutput FileName; begin scalar Channel; Channel := FindFreeChannel(); ChannelTable [Channel] := SysOpenWrite (Channel,FileName); ChannelStatus[Channel] := ChannelOpenWrite; MaxBuffer [Channel] := SysMaxBuffer (ChannelTable [Channel]); ReadFunction [Channel] := 'WriteOnlyChannel; WriteFunction [Channel] := 'IndependentWriteChar; CloseFunction [Channel] := 'IndependentCloseChannel; Igetv(LispVar IOBuffer,Channel) := MkString (MaxBuffer [Channel], 32); NextPosition [Channel] := -1; % Will be set pre-incremented BufferLength [Channel] := MaxBuffer [Channel]; return Channel; end; % Mark a channel as open for a special purpose. syslsp procedure SystemOpenFileSpecial FileName; begin scalar Channel; ChannelStatus [Channel] := ChannelOpenSpecial; return Channel end; syslsp procedure TestLegalChannel Channel; If not( PosIntP Channel and Channel <=MaxChannels) then IoError List(Channel," is not a legal channel "); % This function will read in a character from the buffer. It will read % the record on buffer length overflow only. Thus when an EOL character % is read, it is processed as any other character, except, if it is the last % one, in the record, it will do the read automatically. % Note, this will not read the next record until after the final character % has been processed. syslsp procedure IndependentReadChar Channel; begin scalar Chr; TestLegalChannel Channel; if NextPosition [Channel] > BufferLength [Channel] then << BufferLength [Channel] := SysReadRec (ChannelTable[Channel], IGetV(LispVar IOBuffer, Channel)); NextPosition [Channel] := 0 >>; Chr := StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition [Channel] := NextPosition [Channel] + 1; if LispVar !*Echo then WriteChar Chr; return Chr; end; % Write a character into the buffer. Actually dump the buffer when the % EOL character is found, or when the buffer is full. This happens % immediately upon meeting this condition, not waiting for the % next character. Note, that this places the EOL character into the % buffer for machine dependent treatment as CR/LF etc syslsp procedure IndependentWriteChar (Channel, Chr); Begin TestLegalChannel Channel; NextPosition [Channel] := NextPosition [Channel] + 1; StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]) := Chr; if (Chr eq char EOL) or (NextPosition [Channel] >= BufferLength [Channel]) then % 12/13/82 - rrk Placed code in FlushBuffer and added a call. FlushBuffer Channel; End; % 12/13/82 - rrk Added FlushBuffer procedure. % Flush out the buffer whether or not we have an EOL character. Procedure FlushBuffer Channel; << SysWriteRec (ChannelTable[Channel], IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition[Channel] :=-1 >>; % Start Fresh Buffer % Mark the argument channel as closed and update the read, write and % close functions likewise. Careful, if the caller does this first % and then trys to access a read, write or close function we are % in big trouble. Is it correct to do this????? Or is a marking of % the channel status table sufficient. syslsp procedure SystemMarkAsClosedChannel Channel; << TestLegalChannel Channel; ChannelStatus [Channel] := ChannelClosed; ReadFunction [Channel] := WriteFunction [Channel] := CloseFunction [Channel] := 'ChannelNotOpen >>; % Actually close the argument channel. syslsp procedure IndependentCloseChannel Channel; << TestLegalChannel Channel; SysClose ChannelTable [Channel]>>; % Initialize Channel Tables etc Syslsp procedure ClearOneChannel(Chn,Bufflen,How); << MaxBuffer [Chn] := Bufflen; NextPosition [Chn] := 0; % SAL - Next two not properly initialized. LinePosition [Chn] := 0; UnreadBuffer [Chn] := 0; If how eq 'Input then BufferLength [Chn] := -1 else BufferLength [Chn] := 0; IGetV (LispVar IOBuffer, Chn) := MkString(Bufflen,32)>>; syslsp procedure ClearIO(); << SysClearIo(); If not VectorP LispVar Iobuffer then <<LispVar IOBuffer := MkVect (MaxChannels); ClearOneChannel(LispVar StdIn!*,200,'Input); ClearOneChannel(LispVar StdOut!*,200,'Output); ClearOneChannel(LispVar ErrOut!*,200,'OutPut); ClearOneChannel(LispVar PromptOut!*,200,'Output)>>; LispVar IN!* := LispVar StdIN!*; LispVar OUT!* := LispVar StdOUT!* >>; syslsp procedure TerminalInputHandler Channel; begin scalar Chr; TestLegalChannel Channel; if NextPosition [Channel] > BufferLength [Channel] then << ChannelWriteString(LispVar PromptOUT!*, if StringP LispVar PromptString!* then LispVar PromptString!* else ">"); % 12/13/82 - rrk Flush out the Prompt character. FlushBuffer LispVar PromptOut!*; BufferLength [Channel] := SysReadRec (ChannelTable[Channel], IGetV (LispVar IOBuffer, Channel)); NextPosition [Channel] := 0 >>; Chr := StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition [Channel] := NextPosition [Channel] + 1; if LispVar !*Echo then WriteChar Chr; return Chr; end; off SysLisp; END; |
Added psl-1983/3-1/tests/tak.sl version [92d6e4c353].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (de topleveltak (x y z) (tak x y z)) (de tak (x y z) (cond ((null (ilessp y x)) z) (t (tak (tak (isub1 x) y z) (tak (isub1 y) z x) (tak (isub1 z) x y))))) |
Added psl-1983/3-1/tests/test version [e713e948aa].
> > > | 1 2 3 | Line 1 Line 2 Line 3 (last) |
Added psl-1983/3-1/tests/test-20.tim version [d85c1b66f5].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("DEC-20 test system" . "No-Date-Yet" ) (EmptyTest-10000 . 18) (GEmptyTest-10000 . 187) (Cdr1Test-100 . 525) (Cdr2Test-100 . 370) (CddrTest-100 . 295) (ListOnlyCdrTest1 . 1772) (ListOnlyCddrTest1 . 3487) (ListOnlyCdrTest2 . 2735) (ListOnlyCddrTest2 . 4443) (ReverseTest-10 . 461) (MyReverse1Test-10 . 468) (MyReverse2Test-10 . 452) (LengthTest-100 . 560) (ArithmeticTest-10000 . 647) (EvalTest-10000 . 2676) (tak-18-12-6 . 482) (gtak-18-12-6 . 1390) (gtsta-g0 . 1137) (gtsta-g1 . 1195) ) |
Added psl-1983/3-1/tests/test-cray.tim version [e390f8ac42].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ( ("CRAY D test system" "12-mar-83") (EmptyTest-10000 . 2.16) (GEmptyTest-10000 . 39.82) (Cdr1Test-100 . 58.89) (Cdr2Test-100 . 50.50) (CddrTest-100 . 36.84) (ListOnlyCdrTest1 . 301.76) (ListOnlyCddrTest1 . 439.14) (ListOnlyCdrTest2 . 352.00) (ListOnlyCddrTest2 . 489.39) (ReverseTest-10 . 84.53) (MyReverse1Test-10 . 83.94) (MyReverse2Test-10 . 84.99) (LengthTest-100 . 54.92) (ArithmeticTest-10000 . 87.46) (EvalTest-10000 . 538.16) (tak-18-12-6 . 49.75) (gtak-18-12-6 . 226.23) (gtsta-g0 . 264.09) (gtsta-g1 . 266.51) ) |
Added psl-1983/3-1/tests/test-guide.mss version [b05210375a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Make(article) @device(LPT) @style(Spacing 1) @use(Bibliography "<griss.docs>mtlisp.bib") @modify(enumerate,numbered=<@a. @,@i. >, spread 1) @modify(itemize,spread 1) @modify(description,leftmargin +2.0 inch,indent -2.0 inch) @LibraryFile(PSLMacrosNames) @comment{ The logos and other fancy macros } @pageheading(Left "Utah Symbolic Computation Group", Right "July 1982", Line "Operating Note No. 71" ) @set(page=1) @newpage() @Begin(TitlePage) @begin(TitleBox) @center[ @b(The PSL Bootstrap Test Files) M. L. Griss, S. Lowder, E. Gibson, E. Benson, R. R. Kessler, and G. Q. Maguire Jr. Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 @value(date)] @end(TitleBox) @begin(abstract) This note describes how use a suite of tests designed to exhaustively exercise all facets of the PSL bootstrap sequence. Each test is a step towards boostrapping a complete mini-LISP and then complete PSL. @end(abstract) @begin(ResearchCredit) Work supported in part by the National Science Foundation under Grant No. MCS-8204247, and by Lawrence Livermore Laboratories under Subcontract No. 7752601. @end(ResearchCredit) @end(TitlePage) @pageheading(Left "PSL Testing", Right "Page @Value(Page)" ) @set(Page=1) @newpage() @section(Introduction) In order to accomplish the PSL bootstrap with a minimum of fuss, a carefully graded set of tests is being developed, to help pinpoint each error as rapidly as possible. This preliminary note describes the current status of the test files. The first phase requires the coding of an initial machine dependent I/O package and its testing using a familar system language. Then the code-generator macros can be succesively tested, making calls on this I/O package as needed. Following this is a series of graded SYSLISP files, each relying on the correct working of a large set of SYSLISP constructs. At the end of this sequence, a fairly complete "mini-LISP" is obtained. At last the complete PSL interpreter is bootstrapped, and a variety of PSL functional and timing tests are run. @section(Basic I/O Support) The test suite requires a package of I/O routines to read and print characters, and print integers. These support routines are usually written in a "foreign" language (call it "F"), such as PASCAL, C or FORTRAN; they could also be coded in LAP, using CMACROs to call operating system commands, if simple enough. (E.g., JSYS's on DEC-20, Traps on 68000, etc.). These routines typically are limited to using the user's terminal/console for input and output. Later steps in the bootstraping sequence introduce a more complete stream based I/O module, with file-IO. On some systems, it is appropriate to have a main routine written in "F" which initializes various things, and then calls the "LISP" entry point; on others, it is better to have "LISP" as the main routine, and have it call the initialization routines itself. In any event, it is best to first write a MAIN routine in "F", have it call a subroutine (called, say TEST), which then calls the basic I/O routines to test them. The documentation for the operating system should be consulted to determine the subroutine calling conventions. Often, the "F" compiler has an "ASSEMBLY Listing switch", which can be turned on to see how the standard "F" to "F" calling sequence is constructed, and to give some useful guidance to writing correct assembly code. This can also be misleading, if the assembler switch only shows part of the assembly code, thus the user is cautioned to examine both the code and the documentation. On directory PT: (which stands for /psl/tests or <PSL.TESTS>), or its subdirectories, we have a number of sample I/O packages, written in various languages: PASCAL, FORTRAN, C and DEC20 assembly code. Each has been used successfully with some PSL bootstrap. The primitives provided in these files are often named XXX-yyyy, where XXX is the machine name, and yyyy is the primitive, provided that these are legal symbols. Of course, the name XXX-yyyy may have to be changed to conform to "F" and the associated linker symbol conventions. Each name XXX-yyyy will be flagged as a "ForeignFunction", and called by a non-LISP convention. The following is a brief description of each primitive, and its use. For uniformity we assume each "foreign" primitive gets a single integer argument, which it may use, ignore, or change (VAR c:integer in PASCAL). @Comment{Is this assumed to be a WORD size quantity, i.e. on the 68000 a 32 bit quantity or can it be a small integer???} The following routines ("yyyy") in LISP, will be associated with the corresponding "foreign" routine "XXX-yyyy" in an appropriate way: @begin(description) init(C)@\Called once to set up I/O channels, open devices, print welcome message, initialize timer. Ignores the argument C. Quit()@\Called to terminate execution; may close all open files. C is ignored. PutC(C)@\C is the ASCII equivalent of a character, and is printed out without line termination (I/O buffering may be needed). C=EOL=10 (ASCII LF) @Comment{does this mean that the character should appear right away, or can it wait till the EOL is sent???} will be used to signal end-of-line, C=EOF=26 (ASCII SUB) will be used to signal end of file. GetC()@\Returns the ASCII equivalent of the next input character; C=EOL=10 for end of line, and C=EOF=26 for end of file. Note it is assumed that GetC does not echo the character. TimC()@\Returns the runtime since the start of this program, in milli-seconds, unless micro-seconds is more appropriate. For testing purposes this routine could also print out the time since last called. PutI(C)@\Print C as an integer, until a SYSLISP based Integer printer that calls XXX-PutC works. This function is used to print integers in the initial tests before the full I/O implementation is ready. Err(C)@\Called in test code if an error occurs, and prints C as an error number. It should then call Quit() . @end(description) As a simple test of these routines implement in "F" the following. Based on the "MainEntryPointName!*" set in XXX-ASM.RED, and the decision as to whether the Main toutine is in "F" or in "LISP", XXX-MAIN() is the main routine or first subroutine called: @begin(verbatim) % MAIN-ROUTINE: CALL XXX-INIT(0); CALL XXX-MAIN(0); CALL XXX-QUIT(0); % XXX-MAIN(DUMMY): INTEGER DUMMY,C; CALL XXX-PUTI(1); % Print a 1 for first test CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(2); % Second test CALL XXX-PUTC(65); % A capital "A" CALL XXX-PUTC(66); % A capital "B" CALL XXX-PUTC(97); % A lowercase "a" CALL XXX-PUTC(98); % A lowercase "b" CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(3); % Third test, type in "AB<cr>" CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print A65 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print B66 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTI(C); % should print 10 and EOL CALL XXX-PUTC(C); CALL XXX-PUTI(4); % Last Test CALL XXX-ERR(100); CALL XXX-PUTC(26); % EOF to flush buffer CALL XXX-QUIT(0); % END @end(verbatim) For examples, see PT20:20IO.MAC for DEC-20 version, PHP:HP.TEXT for HP9836 PASCAL version, PCR:shell for CRAY fortran version. @section(LAP and CMACRO Tests) After the basic XXX-ASM.RED file has been written and the XXX-CROSS.EXE has been built, and seems to be working, an exhastive set of CMACRO tests should be run. The emitted code should be carefully examined, and the XXX-CMAC.SL adjusted as seems necessary. Part of the CMACRO tests are to ensure that !*MOVEs in and out of the registers, and the ForeignFunction calling mechanism work. @section(SysLisp Tests) This set of tests involve the compilation to target assmbly code, the linking and execution of a series of increasingly more complex tests. The tests are organized as a set of modules, called by a main driver. Two of these files are machine dependent, associating convenient LISP names and calling conventions with the "Foreign" XXX-yyyy function, define basic data-spaces, define external definitions of them for inclusion, and also provide the appropriate MAIN routine, if needed. These files should probably be put on a separte subdirectory of PT: (e.g., PT20:, PT68:, etc.) The machine dependent files are: @begin(description) XXX-HEADER.RED@\Is a machine dependent "main" include file, read into each MAINn.RED file, to define the data-spaces needed, and perhaps define a main routine in LAP, and have the appropriate XXX-MAIN call the "FirstCall" function, used to start the body of the test. Also included are the interface routines to the "F" coded I/O package. providing a set of LISP entry-points to the XXX-yyy functions. This should be copied and edited for the new target machine as needed. Notice that in most cases, it simply defines "procedure yyyy(x); XXX-yyyy(x);", relying on "ForeignFunction" declaration of XXX-yyyy. Notice that "UndefinedFunction" is defined in LAP, to call Err, as appropriate. This will trap some erroneous calls, since a call to it is planted in all "unused" SYMFNC cells. Some effort to make it pick up the ID number of the offending undefined function (by carefully choosing the instructions to be planted in the function cell), will be a great help. Once coded and tested by running MAIN1, it need not be changed for the subsequent MAINn/SUBn combinations to work. XXX-TEST-GLOBAL-DATA.RED@\This contains a series of external declarations to correspond to the Global Data definitions in the above header file file. It is automatically included in all but the MAINn module via the "GlobalDataFileName!*" option of XXX-ASM.RED. @end(description) The machine independent test files and drivers are: @begin(description) MAIN1.RED@\Is a very simple driver, that calls Getc and Putc, does a few tests. It does an 'IN "XXX-HEADER.RED";'. The "FirstCall" procedure then calls "init", uses "putc" to print AB on one line. It should then print factorial 10, and some timings for 1000 calls on Factorial 9 and Tak(18,12,6). Build by iteself, and run with IO. @Comment{This seems to hide the assumption that 10! can be done in the integer size of the test implementation.??? } SUB2.RED@\Defines a simple print function, to print ID's, Integer's, Strings and Dotted pairs in terms of repeated calls on PutC. Defines TERPRI, PRIN1, PRIN2, PRINT, PRIN2T and a few other auxilliary print functions used in other tests. Tries to print "nice" list notation. MAIN2.RED@\Uses Prin2String to print a welcome message, solicit a sequence of characters to be input, terminated by "#". Watch how end-of-line is handled. Then Print is called, to check that TAG's are correctly recognized, by printing a LISP integer, an ID and 2 dotted pairs. Requires SUB2 and IO modules. SUB3.RED@\Defines a mini-allocator, with the functions CONS, XCONS and NCONS, GTHEAP, GTSTR. Requires primitives in SUB2 module. MAIN3.RED@\First Executes a Casetest, trying a variety of Branches and Defaults in the case staement. There a number of calls on Ctest with an integer from -1 to 12; Ctest tries to classify its argument using a case statement. ConsTest simply calls the mini-allocator version of CONS to build up a list and then prints it. Requires SUB2, SUB3 and IO modules. SUB4.RED@\Defines a mini-reader, with RATOM and READ. This mini-READ does not read vectors, and does not know about the escape character, ! . Requires SUB3, SUB2, and IO modules. MAIN4.RED@\The test loop calls RATOM, printing the internal representation of each token. Type in a series of id's, integer's, string'ss etc. Watch that same ID goes to same place. After typing a Q, goes into a READ-PRINT loop, until Q is again input. Requires SUB3, SUB2 and IO modules. SUB5.RED@\Defines a mini-EVAL. Does not permit user define functions. Can eval ID's, numbers, and simple forms. No LAMBDA expressions. FEXPR Functions known are: QUOTE, SETQ and LIST. Can call any compiled EXPR, with upto 4 arguments. Rather inefficient, but could be used for quick bootstrap. Requires SUB4, SUB3, SUB2 and I/O. MAIN5.RED@\Tests the IDAPPLY constructs, and FUNBOUNDP. Then starts a mini-READ-EVAL-PRINT loop. Requires SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are not case raised, so input should be in UPPERCASE for builtin functions. Terminates on Q input. SUB6.RED@\Defines a more extensive set of primitives to support the mini-EVAL, including LAMBDA expressions, and user defined EXPR and FEXPR functions. Can call any compiled EXPR, with up to 4 arguments. COND, WHILE, etc. are defined. Requires SUB5, SUB4, SUB3, SUB2 and I/O. MAIN6.RED@\Tests the full PSL BINDING module (PI:BINDING.RED). Also includes the standard PSL-TIMER.RED (describd below), which must be driven by hand, since file I/O is not yet present. Requires SUB6,SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are not case raised, so input should be in UPPERCASE for builtin functions. Terminates on Q input. SUB7.RED@\A set of routines to define a minimal file-io package, loading the machine independent files: PT:SYSTEM-IO.RED and PT:IO-DATA.RED, and a machine dependent file XXX-SYSTEM-IO.RED. The latter file defines primitives to OPEN and CLOSE files, and read and write RECORDS of some size. The following definitions are used in the routines: @begin(verbatim) FileDescriptor: A machine dependent word to references an open file. FileName: A Lisp string @end(verbatim) @begin(description) SYSCLEARIO()@\Called by Cleario to do any machine specific initialization needed, such as clearing buffers, initialization tables, setting interrupt characters, etc. SysOpenRead(Channel,FileName)@\Open FileName for input and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysOpenWrite(Channel,FileName)@\Open FileName for Output and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysReadRec(FileDescriptor,StringBuffer)@\Read from the FileDescriptor, a record into the StringBuffer. Return the length of the string read. SysWriteRec (FileDescriptor, StringToWrite, StringLength)@\ StringLength characters from StringToWrite from the first position. SysClose (FileDescriptor)@\Close FileDescriptor, allowing it to be reused. SysMaxBuffer(FileDesc)@\Return a number to allocate the file-buffer as a string; this should be maximum for this descriptor. @end(description) MAIN7.RED@\Is an interface to the Mini-Eval in SUB5.RED and SUB6.RED and defines an (IOTEST) function that should be called. Other functions to try are (OPEN "foo" 'OUTPUT), (WRS n), (RDS n) etc. Note also that XXX-HEADER will have to be changed at this point to have GETC and PUTC use the IndependentReadChar and IndependentWriteChar. FIELD.RED@\A a set of extensive tests of the Field and Shift functions. Needs a WCONST BitsPerWord defined in XXX-HEADER.RED. Build by itself, and execute with the IO support. @end(description) Test set "n" is run by using a set of command files to set up a multi-module program. These files are stored on the approriate subdirectory (PT20: for the DEC20). Note that each module usually produces 2-3 files ("code", "data" and "init") @begin(Enumerate) First Connect to the Test subdirectory for XXX: @verbatim[ @@CONN PTxxx:] Then initialize a fresh symbol table for program MAINn, MAINn.SYM: @verbatim[ @@MIC FRESH MAINn] Now successively compile each module, SUB2..SUBn @verbatim[ @@MIC MODULE SUB2,MAINn @@MIC MODULE SUB3,MAINn @@MIC MODULE SUBn,MAINn] Now compile the MAIN program itself @verbatim[ @@MIC MAIN MAINn] As appropriate, compile or assemble the output "F" language modules (after shipping to the remote machine, removing tabs, etc..). Then "link" the modules, with the XXX-IO support, and execute. On the DEC-20, the @verbatim[ @@EX @@MAINn.CMD command files are provided as a guide] See the Appendix (file PT20:20-TEST.OUTPUT) for an example of the output on the DEC-20. @end(enumerate) @section(Mini PSL Tests) The next step is to start incorporating portions of the PSL kernel into the test series (the "full" Printer, the "full" reader, the "full" Allocator, the "full" Eval, etc.), driving each with more comprehensive tests. Most of these should just "immediately" run. There some peices of Machine specific code that have to be written (in LAP or SYSLISP), to do channel I/O, replacing the simple XXX-IO; to do fast APPLY; Fluid Binding and Arithmetic. This set of tests will help check these peices out before getting involved with large files. @section(Full PSL Tests) Now that PSL seems to be running, a spectrum of functional tests and timing tests should be run to catch any oversights, missing modules or bugs, and as a guide to optimization. The following tests exist: @Description[ PSLTEST.SL@\A fairly comprehensive test of the Standard LISP subset of PSL. Do (DSKIN "pt:psltest.sl"). There are a few tests of the error mechanism that have to be "pushed" through for a full test. MATHLIB.TST@\A series of tests of MATHLIB. First LAOD MATHLIB; into RLISP, then do IN "MATHLIB.TST"; . PSL-TIMER.SL, TIME-PSL.SL@\A standard timimg test covering PSL basics. Compile PSL-TIMER.SL into kernel, or with resident compiler, then (LAPIN "PT:TIME-PSL.TEST"). ] @section(References) @bibliography @NewPage() @appendix(Sample DEC-20 Output) @begin(verbatim) @include(PT20:20-TEST.OUTPUT) @end(verbatim) |
Added psl-1983/3-1/tests/test-guide.otl version [19f5403831].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @Comment{OUTLINE of TEST-GUIDE.MSS.32 by Scribe 3C(1254) on 22 August 1982 at 08:54} 1. Introduction 1 TEST-GUIDE.MSS.32 line 54 2. Basic I/O Support 1 TEST-GUIDE.MSS.32 line 67 3. LAP and CMACRO Tests 4 TEST-GUIDE.MSS.32 line 184 4. SysLisp Tests 4 TEST-GUIDE.MSS.32 line 192 5. Mini PSL Tests 10 TEST-GUIDE.MSS.32 line 375 6. Full PSL Tests 10 TEST-GUIDE.MSS.32 line 386 7. References 10 TEST-GUIDE.MSS.32 line 402 I. Sample DEC-20 Output 11 TEST-GUIDE.MSS.32 line 405 Table of Contents 1 -SCRIBE-SCRATCH-.15-5-1.100015 line 3 |
Added psl-1983/3-1/tests/time-psl.sl version [06e9ed4ee1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % TIME-PSL.SL Driver of PSL "spectral" tests % After loading psl-timer.b, LAPIN this file (wrs (open "time-psl.out" 'output)) (prin2 "PSL Spectral Tests, ") (prin2 (versionname)) (prin2 ", ") (prin2T (date)) (prin2t "---------------------------------------------------------------") (TestSetup) (progn (reclaim) (prin2 "EmptyTest 10000 ") (print (TimeEval '(EmptyTest 10000))) 0) (progn (prin2 "SlowEmptyTest 10000 ") (print (TimeEval '(SlowEmptyTest 10000))) 0) (progn (prin2 "Cdr1Test 100 ") (print (TimeEval '(Cdr1Test 100))) 0) (progn (prin2 "Cdr2Test 100 ") (print (TimeEval '(Cdr2Test 100))) 0) (progn (prin2 "CddrTest 100 ") (print (TimeEval '(CddrTest 100))) 0) (progn (prin2 "ListOnlyCdrTest1 ") (print (TimeEval '(ListOnlyCdrTest1))) 0) (progn (prin2 "ListOnlyCddrTest1 ") (print (TimeEval '(ListOnlyCddrTest1))) 0) (progn (prin2 "ListOnlyCdrTest2 ") (print (TimeEval '(ListOnlyCdrTest2))) 0) (progn (prin2 "ListOnlyCddrTest2 ") (print (TimeEval '(ListOnlyCddrTest2))) 0) (progn (prin2 "ReverseTest 10 ") (print (TimeEval '(ReverseTest 10))) 0) (progn (reclaim) (prin2 "MyReverse1Test 10 ") (print (TimeEval '(MyReverse1Test 10))) 0) (progn (reclaim) (prin2 "MyReverse2Test 10 ") (print (TimeEval '(MyReverse2Test 10))) 0) (progn (reclaim) (prin2 "LengthTest 100 ") (print (TimeEval '(LengthTest 100))) 0) (progn (prin2 "ArithmeticTest 10000 ") (print (TimeEval '(ArithmeticTest 10000))) 0) (progn (prin2 "EvalTest 10000 ") (print (TimeEval '(EvalTest 10000))) 0) (progn (prin2 "tak 18 12 6 ") (print (TimeEval '(topleveltak 18 12 6))) 0) (progn (prin2 "gtak 18 12 6 ") (print (TimeEval '(toplevelgtak 18 12 6))) 0) (progn (prin2 "gtsta g0 ") (print (TimeEval '(gtsta 'g0))) 0) (progn (prin2 "gtsta g1 ") (print (TimeEval '(gtsta 'g1))) 0) (close (wrs NIL)) |
Added psl-1983/3-1/tests/timer.notes version [64ea57788d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Some notes on the PSL "spectral" timing Tests Martin L. Griss March 17 1982 The tests in the file PT:PSL-TIMER.SL (which is compiled and then driven by calls in PT:TIME-PSL.SL) have been gathered by us, with assistance/requests/suggestions from Fateman and Foderaro at Berkeley, JONL White and George Charrette at MIT, and Gabriel at Stanford as part of hist tests for the analysis of different LISP systems. They range over a number of LISP fundamentals, such as function calling speed, compiler quality, simple EVAL speed, INUM/FIXNUM arithmetic, CAR/CDR speeds, CONS speed, Type-testing predicates, etc. In most cases, the times quoted are for N iterations of some basic loop, with N fixed at some convenient quantity; the current N is given. The tests first set up some lists, which are then used for CDR'ing and counting loops. These are: LONGLIST 1664 elements TESTLIST 1002 elements TESTLIST2 2002 elements TEST N Description and comments Empty 10k Fastest Empty loop, using INUM or FIXNUM arithmetic as measure of overhead. SlowEmpty 10k Empty loop using generic arithmetic, usually much slower than Empty because of subroutine call. The loop indices are still in INUM range, and some implementations may opencode part of the arithmetic. Cdr1 100 Cdr down LONGLIST N times, using ATOM to terminate. The loop is done using INUM arithmetic If there is no INUM/FIXNUM arithmetic, this time is swamped by arithmetic time. In PSL, ATOM test requires TAG extraction, while NULL test is just an EQ with NIL. In some implementations CAR and CDR require the TAG to be masked off with an extra instruction, while in others the hardware ignores the tag field in addressing operations, speed this up. Cdr2 100 Cdr down LONGLIST N times, using NULL to terminate. Compare with CDR1 tests. Cddr 100 Cddr down LONGLIST N times, using NULL to terminate Note that some time CDDR is done better than just CDR since addressing modes may help. ListOnlyCdr1 Cdr down TESTLIST, length TESTLIST times, using NULL These LISTONLY... tests do not use arithmetic to loop. ListOnlyCddr Cddr down TESTLIST, length TESTLIST times, using NULL ListOnlyCdr2 Cdr down TESTLIST, length TESTLIST, using ATOM This does not use arithmetic to loop. ListOnlyCddr Cddr down TESTLIST2, length TESTLIST times, using ATOM. Reverse 10 Call system reverse on LONGLIST, N times. This CONS's a lot, also some SYSTEM reverse's handcoded, e.g. LISP 1.6. MyReverse1 10 Reverse compiled, using ATOM to terminate MyReverse2 10 Reverse compiled, using NULL to terminate Length 100 Built-in length, on LONGLIST. Arithmetic 10k Call FACTORIAL 9, N times, generic arithmetic. Looping as in EMPTYtest. Eval 10k EVAL EvalForm N times. EvalForm is (SETQ FOO (CADR '(1 2 3))) . tak 18 12 6 Gabriel's test function that has been used on MANY LISP systems. Using INUM/FIXNUM arithmetic. gtak 18 12 6 As above, using Generic arithmetic. gtsta g0 Charrete's FUNCALL/APPLY test. 100000 loops on (APPLY F (list I)) or (FUNCALL F I), whichever exists and is fastest in system. [PSL converts (APPLY F (list I)) into a fast-apply]. g0 is a NOOP. gtsta g1 g1 calls ADD1 |
Added psl-1983/3-1/tests/todo.txt version [84cd6de33f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | Improvement to Test Series and Boot Sequence Start using the LinkReg in Link, LinkE [See PT20:dec20-patches.sl] Improve portability of FUNCTION-PRIMITIVES.RED [See TEST-FUNCTION-PRIMITIVES, using *JCALL for all. Maybe go to SYMFNC=ADDRESS table ?] May need to add a new CMACRO or two, or expand CMACRO's, to permit indirect JUMP via a register/location, to define CodePrimitive(). Modify TEST5 and TEST6 to use the various portable APPLY etc. Add BINARY IO tests to I/O. Perhaps as a file of LAP to read in? Define a FASLIN/FASLOUT tester. |
Added psl-1983/3-1/tests/write-real-in-psl.red version [a0d04daf63].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WRITE-REAL.RED - Procedure to write a floating point number % Author: Martin Griss % Date: ~July 1982. % Notes by Maguire on 27.7.82: % Original version will use ~18K bytes for it's tables on the Apollo % due to the large exponent allowed. % See the common lisp manual, for names for base-B operations; % and constants for a re-write of this, to handle rounding etc. % Algorithm: By searching a table of powers of 10, previously % set up in a vector, determine % the Exponent and Mantissa of the given Float. % Then convert the mantissa to a pair of integers % and finally assembly the printed form as a string Fluid '(FltZero!* % Representation of 0.0 FltTen!* % 10.0 FltExponents % vector of (10^n) MinFltExponent % range of Exponents in table MaxFltExponent MaxFlt MinFlt MaxFltDigits % Maximum number of digits of precision FltDigits % Digits 0.0 ... 9.0 ); Procedure InitWriteFloats(MinEx,MaxEx,NDig); % Declare Maximum Number of Exponents and Digits Begin scalar Flt1,Flt!.1; FltZero!* := Float(0); Flt1 := Float(1); FltTen!* :=Float(10); Flt!.1 := Flt1/FltTen!*; MinFltExponent :=MinEx; MaxFltExponent:=MaxEx; NumberOfExponents := MaxEx-MinEx; % For UpLim on vector. MaxFltDigits:=Ndig; FltDigits:=MkVect 9; For I:=0:9 do FltDigits[I]:=Float I; FltExponents:=MkVect(NumberOfExponents); FltExponents[-MinEx]:=Flt1; FltExponents[1-Minex]:=FltTen!*; FltExponents[-1-Minex]:=Flt!.1; For i:=2-Minex:NumberOfExponents do FltExponents[i] := FltTen!* * FltExponents[i-1]; For i:=-2-MinEx Step -1 Until 0 do FltExponents[i] := Flt!.1 * FltExponents[i+1]; MinFlt := FltExponents[0]; MaxFlt := FltExponents[NumberOfExponents]; end; InitWriteFloats(-10,10,10); Procedure FindExponent(Flt); % return Exponent as Integer % First reduce Flt to table range then search. % Should Be Primitive, and done in Appropriate Float Base (2, or 16?) If Flt=FltZero!* then 0 else if Flt <FltZero!* then FindExponent(-Flt) else Begin scalar N; If Flt >= MaxFlt then return(MaxFltExponent+FindExponent(Flt/MaxFlt)); If Flt <= MinFlt then return(MinFltExponent+FindExponent(Flt/MinFlt)); N:=0; While N < NumberOfExponents and FltExponents[N] < Flt do N:=N+1; Return (N+MinFltExponent); End; Procedure FindMantissa(Flt); % return Mantissa as a (signed)float in [0.0 ..1.0) Flt/FloatPower10(FindExponent(Flt)); Procedure FloatPower10(n); % Returns 1FltZero!*^n, using table If N>MaxFltExponent then MaxFlt*FloatPower10(n-MaxFltExponent) else if N<MinFltExponent then MinFlt*FloatPower10(n-MinFltExponent) else FltExponents[n-MinFltExponent]; Procedure Flt2String(Flt); ScaledFloat2String(Flt,MaxFltDigits,0,-3,3); Procedure ScaledFloat2String(Flt,Ndigits,Scale, MinNice,MaxNice); % "print" a float, either in IIII.FFFF format, or SS.FFFFFeN % First format, if MinNice <=N<=MaxNice % ss controlled by Scale if second chosen % Begin Scalar Fsign,Fex,Fdigits,K,N,Flist,Ilist; If Flt = FltZero!* then return "0.0"; If Flt < FltZero!* then <<Fsign:='T; Flt:=-Flt>>; Fex:=FindExponent(Flt); Flt:=Flt/FloatPower10(Fex); % Ie, FindMantissa % At this point, % FEX is an integer % and 0.0 =< Flt <1.0 % Now we can move the Point and adjust the Exponent by a scale % factor for "nicety", or to eliminate En If Fex>=MinNice and Fex<=maxNice then <<Flt:=Flt*FloatPower10(Fex); Fex:=0>> else if scale neq 0 then <<Flt:=Flt*FloatPower10(Scale); Fex:=Fex-Scale>>; % Remove and convert the Integer Part (0 if scale=0 and not-nice). Ilist:=Fix(Flt); Flt:=Flt-Float(Ilist); If Fsign then Ilist:=-Ilist; Ilist:=Char('!.) . Reverse Int2List Ilist; % Reverse % Start shifting off digits in fraction by multiplying by 10 % Also Round here. % Should we adjust Ndigits if "nice/scale" ?? Flist:=Ilist; % Add in fraction digits, remember point for trailing % Zero Removal For K:=1:NDigits do << Flt := Flt * FltTen!*; N:=Fix(Flt); Flt:=Flt-FltDigits[N]; Flist := (N + Char '0) . Flist; >>; % Truncate excess trailing 0's While PairP Flist and Not (Cdr Flist eq Ilist) and Car(Flist)=Char '0 do Flist:=cdr Flist; % Now Optimize format, omitting En if 0 If Fex=0 then Return List2String Reverse Flist; % Now convert the Exponent and Insert Fex:=Int2List Fex; Flist := Char('E) . Flist; % The "E" For each x in Fex do Flist:= x . Flist; Return List2String Reverse Flist; end; procedure Int2String N; % Convert signed integer into a string List2String Int2List N; Procedure Int2List N; % Return "exploded" number, forward order Begin scalar L,Nsign; If N=0 then return List Char '0; If N<0 then <<N := -N; Nsign :=T>>; While N>0 do <<L := (Remainder(N,10) + Char '!0 ) . L; N := N / 10>>; If Nsign then L := Char('!-) . L; Return L; End; %Syslsp Procedure WriteFloat(Buffer,Fbase); % Buffer is Wstring[0..40], % Fbase is FloatBase FltInf Flt % Begin Scalar s,flt,i,ss; % flt := MKFLTN (Fbase-4); %/4 or 1 % s:=Flt2String flt; % ss:=strinf(s); % i:=strlen(ss); % strlen(Buffer):=i; % i:=i+1; % while i>=0 do <<strbyt(Buffer,i) := StrByt(ss,i); % i:=i-1>>; % end; End; |
Added psl-1983/3-1/util/-file-notes.txt version [1600b42639].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NOTES ON THE FILES IN PU: Cris Perdue 12/17/82 ------------------- PACKAGES BY LOCAL AUTHORS File Author Synopsis ---------------------------------------------------------------------------- extended-char.sl AS 9-bit characters, notably "x-char" fast-int.sl AS In lieu of declarations fast-strings.sl AS In lieu of declarations fast-vectors.sl AS In lieu of declarations format.red Benson Subset of Common LISP "format" hash.sl Perdue General hash table pkg. history.sl Lanam Fancy user-level history pkg. if.sl Perdue Fancy if-then-else compatible w. "if" man.sl Perdue Experimental ref. manual browser objects.sl AS Subset of "flavors" program-command-interpreter.sl AS pslcomp-main.sl AS ring-buffer.sl AS slow-strings.sl AS In lieu of declarations slow-vectors.sl AS In lieu of declarations string-input.sl Perdue Fns. for input from strings, e.g. READ string-search.sl Perdue Functions for searching in strings stringx.sl AS Miscellaneous string functions util.sl Nancy K Miscellaneous useful functions "WELL-KNOWN" FILES The following files implement facilities described in the reference manual, except for a few exceptions. BUILD.MIC is a support file to aid building of modules in PU:. It is in PU: for the system maintainer's convenience. Other exceptions are cryptically noted by mention of the logical name of the directory they appear to belong in. addr2id.sl pnk (autoload) backquote.sl In the USEFUL library bigbig.red bigface.red bind-macros.sl In the USEFUL library build.mic support for rebuilding modules build.red chars.lsp part of strings clcomp1.sl incompatible common lisp fns + reader common.sl cond-macros.sl In the USEFUL library debug.red defstruct.examples-red defstruct defstruct.red demo-defstruct.red defstruct destructure.sl evalhook.lsp used by step fast-struct.lsp ??? fast-vector.red filedate.mic p20sup find.red for-macro.sl graph-tree.sl gsort.red hcons.sl help.red pnk? if-system.red pnk? init-file.sl pnk? => bare-psl iter-macros.sl kernel.sl psup macroexpand.sl mathlib.red mini.demo mini.fix mini.min mini.red mini.sl mini-patch.red misc-macros.sl nstruct.ctl nstruct.lsp package.red pathin.sl pc? pr-driv.red pr-main.red pr2d-driv.red pr2d-main.red pr2d-text.red prettyprint.sl prlisp.demo prlisp-driver.red psl-cref.red psl-crefio.red read-macros.sl read-utils.red change to read-table-utils? rlisp-parser.red rlisp-support.red rprint.red set-macros.sl step.lsp strings.lsp struct.initial bootstrap for nstruct sysbuild.mic like build, but to connected directory test-arith.red generates pl:arith.b for use in big. useful.ctl vector-fix.red pnk -- document this! zbasic.lsp used by zpedit zboot.lsp used by zpedit zmacro.lsp used by zpedit zpedit.lsp "LESS WELL-KNOWN FILES" The following files are also in PU:, but without documentation that appears in the reference manual. Some have documentation in a file on PH:, some have documentation included in the source file, some have no documentation. association.sl f-dstruct.red inspect.red inum.red loop.lsp parse-command-string.sl pathnamex.sl pcheck.red poly.red zfiles.lsp Obsolete zsys.lsp Obsolete "MARTIN GRISS'S FILES" The following are thought to be creations of Martin Griss and we need to talk with him about whether or not they belong in PU:. datetime.red parser-fix.red sm.red |
Added psl-1983/3-1/util/20/20-interrupt.red version [8902b587cb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-INTERRUPT.RED -- Crude Interrupt Handler for DEC-20 % Author: M. L. Griss and D. Morrison % Utah Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 May 1981 % Copyright (c) University of Utah % % 9-June-1983 Mark R. Swanson % Changes for extended addressing % % It is assumed that the system dependent portion of an implementation will %supply the following 3 functions: % % InitializeInterrupts % EnableInterrupts % DisableInterrupts % DismissInterrupt % % While these are machine dependent, the interrupt handlers themselves are % are expected to generally be machine independent, simply calling % DismissInterrupt when done. The assignment of terminal-initiated interrupts % to keys is machine dependent. imports '(Addr2ID); % for code-address-to-symbol on Syslisp; %internal WARRAY InterruptLevelTable[2], % InterruptPCStorage[2], % InterruptChannelTable[35]; FLUID '(InterruptLevelTable LoadAverageStore InterruptPCStorage InterruptArgBlock InterruptChannelTable ); compiletime << WCONST !.FHSLF=8#400000;>>; if FUnBoundP 'XJsysError then << syslsp procedure XJsysError(); % autoloading stub << Load JSYS; Apply(function XJsysError, '()) >>; >>; syslsp procedure InitializeInterrupts(); % Initializes interrupt handlers for both machine- and terminal-initiated % interrupts. Most cases should dispatch to machine-independent handlers. % Leaves the interrupt system enabled. % In this Tops-20 (machine-code) version we currently handle: % just playing, for now begin (LispVar InterruptArgBlock):=GtWarray 3; (LispVar InterruptLevelTable):=GtWarray 3; (LispVar InterruptPCStorage):=GtWarray 6; (LispVar InterruptChannelTable):=GtWarray 36; (LispVar LoadAverageStore) := MkString(4, char BLANK); ClearInterrupts(); (LispVar InterruptArgBlock)[0]:=3; % block length (LispVar InterruptArgBlock)[1]:=(LispVar InterruptLevelTable); (LispVar InterruptArgBlock)[2]:=(LispVar InterruptChannelTable); % set up interrupt tables -- see Monitor Calls Manual for details For i := 0:35 do %/ Some bug, wiped out next one when after (LispVar InterruptChannelTable)[i]:=0; for i := 0:2 do (LispVar InterruptLevelTable)[i]:=(LispVar InterruptPCStorage) + (i * 2); % each entry is 2 words % Terminal Interupts (Procedure on channel/level) % Note LEVEL is 1,2,3 PutInterrupt(0,1,'DoControlG); PutInterrupt(1,1,'SaveAndCallControlT); % control T not working yet PutInterrupt(2,1,'SaveAndBreak); % special channels PutInterrupt(6,1,'ArithOverflow); PutInterrupt(7,1,'FloatArithOverflow); PutInterrupt(9,1,'PushDownOverflow); % Now Install tables Xjsys0(!.FHSLF, (LispVar InterruptArgBlock),0,0,const jsXSIR!%); EnableInterrupts(); ActivateChannel(0); ActivateChannel(1); ActivateChannel(2); ActivateChannel(6); ActivateChannel(7); ActivateChannel(9); PutTerminalInterrupt(7,0); % Char CNTRL-G on 0 PutTerminalInterrupt(4,0); % Char CNTRL-D on 2 PutTerminalInterrupt(20,1); % Char cntrl-t on 1, not working yet PutTerminalInterrupt(0,2); % Char BREAK on 2 PutTerminalInterrupt(2,2); % Char cntrl-B on 2 ClearInterrupts(); end; syslsp procedure SetContinueAddress(Level,Address); begin scalar x; x:=(LispVar InterruptLevelTable)[Level-1]; x[1]:=address; % second word is for PC end; % FunctionCellLocation is used by LAP off Syslisp; fluid '(!*WritingFaslFile); lisp procedure SetContinueFunction(Level,FunctionName); begin scalar !*WritingFaslFile; % assume all function cells in section 1 for global addressing SetContinueAddress(Level, 8#1000000 + FunctionCellLocation FunctionName); end; lisp procedure PutInterrupt(Channel,Level,ActionId); begin scalar !*WritingFaslFile; % assume all function cells in section 1 for global addressing WPutV(InterruptChannelTable, Channel, MkItem(Level,8#1000000 + FunctionCellLocation ActionId)); end; on Syslisp; syslsp procedure XWD(a,b); Lor(Lsh(a,18),b); syslsp procedure PutTerminalInterrupt(CntrlChar,Channel); Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsATI); syslsp procedure RemoveTerminalInterrupt(CntrlChar,Channel); Xjsys0(XWD(CntrlChar,Channel),0,0,0,const jsDTI); syslsp procedure ReadTerminalWord; Xjsys1(0,0,0,0,Const jsRTIW); syslsp procedure SetTerminalWordBit(n); <<XJsys0(Lor(ReadTerminalLWord(),Dec20Bit n),0,0,const jsSTIW); ReadTerminalWord()>>; syslsp procedure SetTerminalWord(MSK); <<Xjsys0(Lor(ReadTerminalWord(),MSK),0,0,0,const jsSTIW); ReadTerminalWord()>>; syslsp procedure ClearInterrupts; Xjsys0(0,0,0,0,const jsCIS); % clear any pending interrupts syslsp procedure SignalChannel n; %. Test on channel n Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsIIC); syslsp procedure EnableInterrupts; Xjsys0(!.FHSLF,0,0,0,const jsEIR); syslsp procedure DisableInterrupts; Xjsys0(!.FHSLF,0,0,0,const jsDIR); syslsp procedure ActivateChannel(n); %. Inform OS of channel Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsAIC); syslsp procedure DeActivateChannel(n); %. Inform OS of channel Xjsys0(!.FHSLF,Dec20Bit n,0,0,const jsDIC); syslsp procedure Dec20Bit n; %. Bits [0 to 35] Dec20Fld(1,35-n); syslsp procedure Dec20Fld(x,y); LSH(x,y); syslsp procedure DismissInterrupt; % Warning: an interrupt handler should not attempt to resume if may have % caused a garbage collection. Xjsys0(0,0,0,0,const jsDEBRK); % ----- Some default handlers ---------- syslsp procedure DoControlG; << ClearTerminalInputBuffer(); % CFIBF ClearIO(); % also clear internal buffer, etc. ChannelWriteChar(LispVAR StdOUT!*, Char BELL); ErrorPrintF "*** Restarting"; SetContinueFunction(1,'Reset); DismissInterrupt()>>; syslsp procedure ClearTerminalInputBuffer(); Xjsys0(8#100,0,0,0,const jsCFIBF); syslsp procedure ArithOverflow; <<SetContinueFunction(1,'ArithOverFlowError); DismissInterrupt()>>; syslsp procedure ArithOverFlowError; StdError('"Integer overflow"); syslsp procedure FloatArithOverflow; <<SetContinueFunction(1,'FloatArithOverFlowError); DismissInterrupt()>>; syslsp procedure FloatArithOverFlowError; StdError('"Floating point overflow"); lap '((!*entry PushDownOverflow expr 0) (sub (reg st) (lit (halfword 1000 1000))) % move the stack back (!*MOVE (WConst 1) (REG 1)) (xmovei 2 ErrorAddress) (!*CALL SetContinueAddress) (!*JCALL DismissInterrupt) ErrorAddress (!*MOVE '"Stack overflow" (reg 1)) (!*JCALL StdError) % normal error ); lap '((!*entry FindLoadAverage expr 0) (move 1 (lit (fullword 8#000014000014))) % 1 min avg, .systa (getab) (!*EXIT 0) (move 2 (fluid LoadAverageStore)) (tlz 2 8#770000) (tlo 2 8#660000) % make a byte pointer (exch 1 2) (move 3 (lit (fullword 8#024037020200))) (flout) (!*EXIT 0) (!*EXIT 0) ); syslsp procedure DoControlT(); begin scalar RunningFunctionID, CameFrom; % ClearTerminalInputBuffer(); FindLoadAverage(); CameFrom := LowHalfWord ((LispVar InterruptPCStorage)[1]); RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN; ErrorPrintF("^T: in %p at %o, load %w", RunningFunctionID, CameFrom, LispVar LoadAverageStore); end; >>; syslsp procedure DoBreak(); begin scalar RunningFunctionID, CameFrom, CurrentChannel; ClearTerminalInputBuffer(); ClearIO(); CameFrom := LowHalfWord ((LispVar InterruptPCStorage)[1]); RunningFunctionID := code!-address!-to!-symbol CameFrom or 'UNKNOWN; CurrentChannel := WRS NIL; ErrorPrintF("*** Break in %p at %o", RunningFunctionID, CameFrom); ErrorSet(quote Break(), NIL, NIL); WRS CurrentChannel; end; lap '((!*Entry SaveAndCallControlT expr 0) % % Save all regs, call DoControlT and dismiss % (adjsp (reg st) 14) % allocate 14 slots on the stack (hrri (reg nil) (indexed (reg st) -13)) % set up BLT pointer (hrli (reg nil) 1) % move regs 1..14 onto the stack (blt (reg nil) (indexed (reg st) 0)) (move (reg nil) (fluid nil)) % fix reg nil (!*CALL DoControlT) % call the function (hrli (reg nil) (indexed (reg st) -13)) (hrri (reg nil) 1) (blt (reg nil) 14) % move the registers back off the stack (move (reg nil) (fluid nil)) % restore reg nil again (adjsp (reg st) -14) (debrk) ); >>; lap '((!*Entry SaveAndBreak expr 0) % % Save all regs, call DoBreak and dismiss % (adjsp (reg st) 14) % allocate 14 slots on the stack (hrri (reg nil) (indexed (reg st) -13)) % set up BLT pointer (hrli (reg nil) 1) % move regs 1..14 onto the stack (blt (reg nil) (indexed (reg st) 0)) (move (reg nil) (fluid nil)) % fix reg nil (!*CALL DoBreak) % call the function (hrli (reg nil) (indexed (reg st) -13)) (hrri (reg nil) 1) (blt (reg nil) 14) % move the registers back off the stack (move (reg nil) (fluid nil)) % restore reg nil again (adjsp (reg st) -14) (debrk) ); InitializeInterrupts(); off syslisp; END; |
Added psl-1983/3-1/util/20/bug.sl version [c51e3f2bcb].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BUG.SL - Send bug reports % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 December 1981 % Copyright (c) 1981 University of Utah % % <PERDUE.PSL>BUG.SL.2, 7-Jan-83 16:52:07, Edit by PERDUE % Changed to LISP syntax, added bug-mail-to variable. % Each site may set bug-mail-to as desired. (imports '(exec)) (fluid '(bug-mail-to)) (cond ((null bug-mail-to) (setq bug-mail-to ""))) (defun bug () (printf "*** PSL Bug reporter, ^N to abort%n") (putrescan (bldmsg "mail %w%n" bug-mail-to)) (mm) (terpri) t) |
Added psl-1983/3-1/util/20/dir-stuff.build version [ab90f26ff4].
> | 1 | in "p20:dir-stuff.red"$ |
Added psl-1983/3-1/util/20/dir-stuff.red version [19cb5f9ed9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MLG, 6:01am Thursday, 10 June 1982 % Utilities to read and process DIR files % IMPORTS '(EXEC); % -------- Basic File Reader ------------- Fluid '(File); procedure ReadOneLine; % Read a single line, return as string begin scalar c,l; while ((c:=ReadCh()) NEQ !$EOL!$) do If c EQ !$EOF!$ then Throw('Filer,'Done) else l:=c . l; Return list2string reverse l; end; procedure ReadDirFile F; % Read in a file as vector of strings begin scalar oldF,x; OldF:=Rds(F:=Open(F,'input)); File:=NIL; Catch('Filer,'(ReadAllFile1)); Rds OldF; Close F; Return List2vector Reverse File; end; procedure ReadAllFile1; % support for Read Dir File begin scalar l; While (l:=ReadOneLine()) do if Size(l)>=0 then file:= segmentstring(l,char '! ) . file; return List2Vector reverse file; end; %--------------------------------------------------- procedure ReadCleanDir F; % read in a Dir File without dates, and clean up Begin scalar x; x:=ReadDirFile F; % As a vector of strings %/ x:=ExpandNames x; % Handle .xxx case x:=RemoveAllVersionNumbers x; %/ x:=RemoveDuplicates x; % Assume ordered Return x; End; %---- Now take apart the fields Procedure GetFileName(S); % Find part before dot begin scalar N,I; n:=Size S; i:=0; While i<=n and S[i] neq Char '!. do i:=i+1; return Sub(S,0,i-1); end; procedure GetExtension(S); % Find second part, after dot begin scalar N,I; n:=Size S; i:=n; While i>=0 and S[i] neq Char '!. do i:=i-1; return Sub(S,i+1,n-i-1); end; % Dont need to expand names anymore CommentOutCode << procedure ExpandNames(Fvector); % replace .xxxx with yyy.xxx from previous Begin scalar F; for i:=1:Size(Fvector) do <<F:=Fvector[I]; if F[0] EQ char '!. then Fvector[I]:=concat(GetFileName Fvector[I-1],F)>>; return Fvector; end; >>; procedure RemoveVersionNumber F; % replace xxxx.yyyy.nnn with xxxx.yyyy Begin scalar I; i:=Size(F); While i>=0 and F[i] NEQ char '!. do i:=i-1; Return Sub(F,0,i-1); end; procedure RemoveAllVersionNumbers(Fvector); % replace xxxx.yyy.nnn with xxx.yyy Begin For i:=0:Size(Fvector) do Fvector[I]:=RemoveVersionNumber Car Fvector[I]; return Fvector; end; procedure GetDirInFile(Dstring,FileName); Docmds List("Dir ",Dstring,",",crlf, "out ",Filename,crlf, "no heading ",crlf, "separate ",crlf, "no summary ",crlf, crlf,"pop"); procedure GetCleanDir Dstring; Begin Scalar x; GetDirInFile(Dstring,"Junk.Dir"); x:=ReadCleanDir "junk.Dir"; DoCmds List("Del junk.dir,",crlf, "exp ",crlf,crlf,"pop"); return x End; procedure GetDatedDirInFile(Dstring,FileName); Docmds List("Dir ",Dstring,",",crlf, "out ",Filename,crlf, "no heading ",crlf, "separate ",crlf, "no summary ",crlf, "time write ",crlf, crlf,"pop"); procedure GetCleanDatedDir Dstring; Begin Scalar x; GetDatedDirInFile(Dstring,"Junk.Dir"); x:=ReadCleanDatedDir "junk.Dir"; DoCmds List("Del junk.dir,",crlf, "exp ",crlf,crlf,"pop"); return x End; procedure ReadCleanDatedDir F; begin scalar x; x:=ReadDirFile F; %/ x:=ExpandNames x; % Handle .xxx case For i:=0:Size(x) do Rplaca(x[i],RemoveVersionNumber Car x[I]); return x end; % Segment a string into fields: Procedure SegmentString(S,ch); % "parse" string in pieces at CH Begin scalar s0,sN,sN1, Parts, sa,sb; s0:=0; sn:=Size(S); sN1:=sN+1; L1:If s0>sn then goto L2; sa:=NextNonCh(Ch,S,s0,sN); if sa>sN then goto L2; sb:=NextCh(Ch,S,sa+1,sN); if sb>SN1 then goto L2; Parts:=SubSeq(S,sa,sb) . Parts; s0:=sb; goto L1; L2:Return Reverse Parts; End; Procedure NextCh(Ch,S,s1,s2); <<While (S1<=S2) and not(S[S1] eq Ch) do s1:=s1+1; S1>>; Procedure NextNonCh(Ch,S,s1,s2); <<While (S1<=S2) and (S[S1] eq Ch) do s1:=s1+1; S1>>; End; |
Added psl-1983/3-1/util/20/directory.sl version [1c96635953].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Directory.SL - File Directory Primitives (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 13 July 1982 % Revised: 4 March 1983 % % 4-Mar-83 Alan Snyder % Revised to accept FOO.DIRECTORY as the name of a subdirectory. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common jsys pathnames file-primitives)) (de find-matching-files (filename include-deleted-files) % Return a list describing all files that match the specified filename. The % filename may specify a directory and/or may contain wildcard characters. % Each element of the returned list corresponds to one matching file. The % format of each list element is: % (file-name full file name string % deleted-flag T or NIL % file-size integer count of pages in file % write-date integer representing date/time of last write % read-date integer representing date/time of last read % ) (setf filename (fixup-directory-name filename)) (let (jfn-word jfn file-name deleted-flag file-size write-date read-date) (cond ((and (stringp filename) (setf jfn-word (attempt-to-get-jfn filename (if include-deleted-files #.(bits 2 8 11 13 17) #.(bits 2 11 13 17) ) ))) (for* (while (>= jfn-word 0)) (do (setf jfn (lowhalfword jfn-word)) (setf file-name (MkString 100 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 (const jsJFNS)) (setf file-name (recopystringtonull file-name)) (setf deleted-flag (jfn-deleted? jfn)) (setf file-size (jfn-page-count jfn)) (setf write-date (jfn-write-date jfn)) (setf read-date (jfn-read-date jfn)) ) (collect (list file-name deleted-flag file-size write-date read-date )) (do (if (FixP (ErrorSet (list 'jsys1 jfn-word 0 0 0 (const jsGNJFN)) NIL NIL)) (setf jfn-word -1))) )) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de fixup-directory-name (pn) % Replace all missing Name, Type, and Version components of the specified % filename with "*". Recognize FOO.DIRECTORY as the name of a subdirectory. (let ((wild-name (make-pathname 'name 'wild))) (setf pn (pathname pn)) (when (and (equal (pathname-host pn) "LOCAL") (stringp (pathname-type pn)) (string-equal (pathname-type pn) "DIRECTORY") (stringp (pathname-name pn)) (stringp (pathname-directory pn)) ) (setf pn (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (string-concat (pathname-directory pn) "." (pathname-name pn)) ))) (namestring (merge-pathname-defaults pn wild-name 'wild 'wild)) )) |
Added psl-1983/3-1/util/20/exec.build version [ae5aa3c685].
> | 1 | in "exec.red"$ |
Added psl-1983/3-1/util/20/exec.red version [afdb90b3c5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EXEC.RED - Simple TOPS20 Interfaces, "EXEC Fork", etc % % Author: Martin L. Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 March 1981 % Copyright (c) 1981 University of Utah % % <PSL.UTIL.20>EXEC.RED.6, 25-Mar-83 14:32:06, Edit by BARBOUR % Updated clocktimedate to return the string with nulls stripped off % Edit by Cris Perdue, 23 Mar 1983 1453-PST % Changed from clocktime to ClockTimeDate % Edit by Cris Perdue, 21 Mar 1983 1003-PST % Added Kessler's clocktime and getloadaverage from CLOCKTIME.RED % <PERDUE>EXEC.RED.2, 21-Mar-83 11:02:46, Edit by PERDUE % Put JSYS names in const(<name>) form to match current JSYS module % <PSL.UTIL>EXEC.RED.5, 24-May-82 13:01:50, Edit by BENSON % Changed <EDITORS> and <SUBSYS> to SYS: in filenames %/ Changed FILNAM->FileName, due to GLOBAL conflict %/ Changed JSYS calls, so LIST(..) rather than '(..) used %/ Changed for V3:JSYS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Simple JSYS interfaces CompileTime load(Syslisp, Jsys, Monsym); imports '(JSYS); GLOBAL '(ForkNAMES!* EXECFork EMacsFork MMFork); Lisp procedure GetOLDJfn FileName; %. test If file OLD and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(2,3,17),FileName,0,0,const(jsGTJfn)); % OLD!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Lisp procedure GetNEWJfn FileName; %. test If file NEW and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(0,1,3,17),FileName,0,0,const(jsGTJfn)); % GEN!NEW!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Lisp procedure RELJfn Jfn; %. return Jfn to system JSYS0(Jfn,0,0,0,const(jsRLJfn)); Lisp procedure OPENOLDJfn Jfn; %. OPEN to READ JSYS0(Jfn,Bits( (7 . 5),19),0,0,const(jsOPENF)); Lisp procedure OPENNEWJfn Jfn; %. Open to WRITE JSYS0(Jfn,Bits( (7 . 5),20),0,0,const(jsOPENF)); Lisp procedure GetFork Jfn; %. Create Fork, READ File on Jfn Begin scalar FH; FH := JSYS1(Bits(1),0,0,0,const(jsCFork)); JSYS0(Xword(FH ,Jfn),0,0,0,const(jsGet)); return FH END; Lisp procedure STARTFork FH; %. Start (Restart) a Fork JSYS0(FH, 0,0,0,const(jsSFRKV)); Lisp procedure WAITFork FH; %. Wait for completion JSYS0(FH,0,0,0,const(jsWFork)); Lisp procedure RUNFork FH; %. Normal use, to run a Fork <<STARTFork FH; WAITFork FH>>; Lisp procedure KILLFork FH; %. Kill a Fork JSYS0(FH,0,0,0,const(jsKFork)); Lisp procedure SETPRIMARYJfnS(FH,INJfn,OUTJfn); JSYS0(FH,Xword(INJfn , OUTJfn),0,0,const(JSSPJfn)); %. Change PRIMARY Jfns (BAD?) Lisp procedure OPENFork FileName; %. Get a File into a Fork Begin scalar FH,Jfn; If NULL FileP FileName then StdError CONCAT("Cant find File ",FileName); Jfn := GetOLDJfn FileName; FH := GetFork Jfn; return FH END; Lisp procedure RUN FileName; %. Run A File Begin scalar FH; FH := OPENFork FileName; RUNFork FH; KILLFork FH END; Lisp Procedure ForkP FH; %. test if Valid Fork Handle FixP FH and not Zerop FH; %/Kludge Lisp procedure EXEC; <<If Not ForkP EXECFork then EXECFork := OPENFork "SYSTEM:EXEC.EXE"; RUNFork EXECFork>>; Lisp procedure EMACS; <<If Not ForkP EMacsFork then EMACSFork := OPENFork "SYS:EMACS.EXE"; RUNFork EMACSFork>>; Lisp procedure MM; <<If Not ForkP MMFork then MMFork := OPENFork "SYS:MM.EXE"; RUNFork MMFork>>; Lisp procedure GetUNAME; %. USER name Begin Scalar S; S:=Mkstring 80; JSYS0(s,JSYS1(0,0,0,0,const(JSGJINF)),0,0,const(JSDIRST)); Return RecopyStringToNULL S End; Lisp procedure GetCDIR; %. Connected DIRECTORY Begin scalar s; S:=Mkstring 80; JSYS0(S,JSYS2(0,0,0,0,const(jsGJINF)),0,0,const(jsDIRST)); return RecopyStringToNULL S end; % Determine the current time or date or both and stripped off trailing % nulls, with ONE blank Char concatenated on the end of the returned string. % % RETURNS STRING FORMS ARE SHOWN BELOW: % 1 -> Returns Date & Time .. Day Date First & 24 hr format % 2 -> Returns Date & Time .. Day Date First & 12 hr format % 3 -> Returns Date & Time .. Month first & 24 hr format % 4 -> Returns Date & Time .. Month first & 12 hr format % 5 -> Returns Weekday,Date, & Time .. Month first & 24 hr format % 6 -> Returns Weekday,Date, & Time .. Month first & 12 hr format % 7 -> Returns Weekday,Date, & Time .. Month first & 12 hr format % day-3 letters and no seconds % 8 -> Returns time only ... hh:mm:ss 12 hr format %Otherwise -> Returns time only ... hh:mm:ss 24 hr format % % PROCEDURE ClockTimeDate (Time_Selector); % old ClockTime BEGIN SCALAR Ret_String ; Ret_String := MKSTRING 30; CASE Time_Selector OF 1: << JSYS1( Ret_String,-1,bits(2),0,const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 17 ) >>; 2: << JSYS1(Ret_String, -1,bits(2,11),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 19 ) >> ; 3: << JSYS1(Ret_String, -1,bits(6),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 17 ) >> ; 4: << JSYS1(Ret_String, -1,bits(6,11),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 19 ) >> ; 5: << JSYS1(Ret_String, -1,bits(1,2,6),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 27 ) >> ; 6: << JSYS1(Ret_String, -1,bits(1,2,6,11),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 29 ) >> ; 7: << JSYS1(Ret_String, -1,bits(1,6,10,11),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 20 ) >> ; 8: << JSYS1(Ret_String, -1,bits(0,11),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 9 ) >> ; Otherwise: << JSYS1(Ret_String, -1,bits(0),0, const jsODTIM) ; Ret_String := SUB(Ret_String, 0, 7 ) >> ; END ; %end for case Ret_String := ConCat( Ret_String, " ") ; RETURN Ret_String ; END; % Determine the current 1 minute load average and return as a string. procedure GetLoadAverage; begin scalar s; s:=mkstring 6; jsys1(s,Jsys1(8#000014000014, 0, 0, 0, const jsGETAB),8#024037020200, 0, const jsFLOUT); return s end; Lisp procedure PSOUT S; %. Print String JSYS0(S,0,0,0,const(jsPSOUT)); Lisp procedure GTJfn L; %. Get a Jfn JSYS1(L,0,0,0,const(jsGTJFN)); Lisp procedure NAMEFROMJfn J; %. name of File on a Jfn Begin scalar S; s:=Mkstring 100; JSYS0(S,J,0,0,const(JSJfnS)); return RecopyStringToNULL S; end; Fexpr Procedure InFile(U); %. INPUT FILE, (prompt for name too?) If StringP U then DskIn EVAL CAR U else Begin scalar Jfn,Fname; PSOUT "Input file:"; Jfn:=Jsys1(BITS(2,3,4,16,17),Xword(8#100,8#101),0,0,const(jsGTJFN)); Fname:= NAMEFROMJFN JFN; RELJFN JFN; PRINTF("reading file %r %n", FNAME); DSKIN Fname; end; %-- Command string processor and take Lisp procedure PutRescan(S); %. Enter String <<JSYS0(S,0,0,0,const(jsRSCAN)); JSYS0(0,0,0,0,const(jsRSCAN))>>; On SYSLISP; syslsp procedure GetRescan(); %. Return as String Begin scalar N,S; XJSYS1(0,0,0,0,const(jsRSCAN)); % Announce to Get N:=XJSYS1(1,0,0,0,const(jsRSCAN)); % How Many IF N=0 then return 'Nil; S:=GtStr N-1; % To Drop Trailing EOL For I:=0:N-2 do StrByt(S,I):=XJsys1(0,0,0,0,const(JsPBIN)); Return MkSTR S; % Will include Program name end; OFF SYSLISP; Global '(CRLF BL); CRLF :=STRING(8#15,8#12); %. CR-LF BL :=STRING(8#40); %. Blank Lisp procedure CONCATS (L); %. Combine list of strings If PAIRP L then CONCAT(CAR L,CONCATS CDR L) else CRLF; Lisp Fexpr Procedure CMDS (!%L); %. user COMMAND submit DOCMDS EVLIS !%L; Lisp procedure DOCMDS (L); %. Submit via PutRescan <<PutRescan CONCATS L; % Add CR, plant in RSCAN EXEC()>>; % Run 'em %. -------- Sample Commands Lisp procedure VDIR (L); DOCMDS LIST("VDIR ",L,CRLF,"POP"); Lisp procedure HelpDir(); DOCMDS LIST("DIR PH:*.HLP",CRLF,"POP"); Lisp procedure Take (FileName); If FileP FileName then DOCMDS LIST("Take ",FileName,CRLF,"POP"); Lisp procedure SYS (L); DOCMDS LIST("SYS ", L, CRLF, "POP"); Lisp procedure TALK (L); DOCMDS LIST("TALK ",L,CRLF); Lisp procedure TYPE (L); DOCMDS LIST("TYPE ",L,CRLF,"POP"); END; |
Added psl-1983/3-1/util/20/file-primitives.sl version [4808a23aad].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % File-Primitives - File System primitive functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 September 1982 % Revised: 22 November 1982 % % *** THIS FILE IS TOPS-20 SPECIFIC *** % % This file contains the TOPS-20 implementation of a set of "common" % file system primitives. % % 22-Nov-82 Alan Snyder % Added error handling. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common)) (CompileTime (load jsys)) (load file-support) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de file-deleted-status (file-name) % This function will return T if the specified file exists and is not % marked as "deleted"; it will return 'DELETED if the file exists and % is marked as "deleted"; it will return NIL otherwise. (On a system % that does not support "deleted" files, this function will return % either T or NIL.) (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-deleted? jfn) nil))) (if (pairp result) (if (car result) 'DELETED T) )) (jfn-release jfn) )))) (de file-delete (file-name) % This function attempts to delete the specified file. (This action may % be undone using the FILE-UNDELETE function, if the system supports it.) % If the attempt fails, NIL is returned (no error is reported). % Otherwise, a string is returned which is the true name of the file % that was deleted (as best as can be determined). (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 17)))) (when jfn (let ((fn (jfn-truename jfn))) (if (pairp (errset (jfn-delete jfn) nil)) fn) )))) (de file-delete-and-expunge (file-name) % This function attempts to delete the specified file and reclaim its % storage. (On systems that do not support UNDELETE, this function is the % same as FILE-DELETE.) % If the attempt fails, NIL is returned (no error is reported). % Otherwise, a string is returned which is the true name of the file % that was deleted (as best as can be determined). (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 17)))) (when jfn (let ((fn (jfn-truename jfn))) (if (pairp (errset (jfn-delete-and-expunge jfn) nil)) fn) )))) (de file-undelete (file-name) % This function attempts to undelete the specified file. % If the attempt fails, NIL is returned (no error is reported). % Otherwise, a string is returned which is the true name of the file % that was undeleted (as best as can be determined). % (On systems that do not support UNDELETE, this function always returns NIL.) (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((fn (jfn-truename jfn))) (if (pairp (errset (jfn-undelete jfn) nil)) fn) ) (jfn-release jfn) )))) (de file-read-date (file-name) % This function returns an integer representing the date and time at % which the specified file was last read. It returns NIL if it is % unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-read-date jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) (de file-write-date (file-name) % This function returns an integer representing the date and time at % which the specified file was last written. It returns NIL if it is % unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-write-date jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) (de file-byte-count (file-name) % This function returns an integer representing the number of bytes % in the specified file (without necessarily converting CRLF's into % LFs). It returns NIL if it is unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-byte-count jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) (de file-page-count (file-name) % This function returns an integer representing the number of "pages" % in the specified file. (The notion of a "page" is system-dependent.) % It returns NIL if it is unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-page-count jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) (de file-original-author (file-name) % This function returns the name of the user who created the specified % file. It returns NIL if it is unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-original-author jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) (de file-author (file-name) % This function returns the name of the user who last modified the specified % file. It returns NIL if it is unable to obtain that information. (let ((jfn (attempt-to-get-jfn file-name #.(bits 2 8 17)))) (when jfn (unwind-protect (let ((result (errset (jfn-author jfn) nil))) (if (pairp result) (car result)) ) (jfn-release jfn) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de file-date-to-string (fdate) % Convert a file date as returned by FILE-READ-DATE and FILE-WRITE-DATE to % a meaningful string. Note that 0 is converted to the string "Never". (if (or (not (integerp fdate)) (= fdate 0)) "Never" (let ((buf (make-string 30 0))) (Jsys0 buf fdate 0 0 (const jsODTIM)) (recopystringtonull buf)))) (de fixup-file-name (name) % Make the specified file name nice to print, e.g. by removing escape % prefix characters. In this case, simply remove all control characters % (^V is the TOPS-20 escape prefix character). (for (in ch (String2List name)) (with the-list) (when (GraphicP ch)) (collect ch the-list) (returns (List2String the-list)) )) (de trim-filename-to-prefix (s) % Remove trailing characters until the string ends with % a device or directory prefix. (Used to determine a % "meaningful" common prefix of a collection of file names.) (for (from i (size s) 0 -1) (until (let ((ch (indx s i))) (or (= ch #\:) (= ch #\>)))) (returns (substring s 0 (+ i 1))) )) |
Added psl-1983/3-1/util/20/file-support.sl version [5845cd5f7d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % File-Support.SL - System-Dependent Support for File Primitives (TOPS-20) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 September 1982 % % This file contains support functions used in the implementation of file % primitives for TOPS-20. The existence of the functions in this file should % be ignored when writing system-independent code. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load jsys common pathnames)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % JFN Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de jfn-truename (jfn) (let ((file-name (make-string 200 #\space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 (const jsJFNS)) (recopystringtonull file-name) )) (de jfn-deleted? (jfn) (if (integerp jfn) (not (= (LAnd (Jsys4 jfn #.(xword 1 1) 4 0 (const jsGTFDB)) (bits 3)) 0)))) (de jfn-write-date (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#14) 4 0 (const jsGTFDB)))) (de jfn-read-date (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#15) 4 0 (const jsGTFDB)))) (de jfn-byte-count (jfn) (if (integerp jfn) (Jsys4 jfn #.(xword 1 8#12) 4 0 (const jsGTFDB)))) (de jfn-page-count (jfn) (if (integerp jfn) (lowhalfword (Jsys4 jfn #.(xword 1 8#11) 4 0 (const jsGTFDB))))) (de jfn-original-author (jfn) (if (integerp jfn) (let ((str (make-string 100 0))) (Jsys0 (xword 0 jfn) str 0 0 (const jsGFUST)) (recopystringtonull str) ))) (de jfn-author (jfn) (if (integerp jfn) (let ((str (make-string 100 0))) (Jsys0 (xword 1 jfn) str 0 0 (const jsGFUST)) (recopystringtonull str) ))) (de jfn-delete (jfn) (if (integerp jfn) (jsys0 jfn 0 0 0 (const jsDELF)) )) (de jfn-delete-and-expunge (jfn) (if (integerp jfn) (jsys0 (xword 2#010000000000000000 jfn) 0 0 0 (const jsDELF)) )) (de jfn-undelete (jfn) (if (integerp jfn) (jsys0 (xword 1 jfn) #.(bits 3) 0 0 (const jsCHFDB)) )) (de jfn-release (jfn) (if (integerp jfn) (jsys0 jfn 0 0 0 (const jsRLJFN)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % GTJFN Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de attempt-to-get-jfn (file-name the-bits) (setf file-name (namestring file-name)) (let ((jfn (ErrorSet (list 'jsys1 the-bits file-name 0 0 (const jsGTJFN)) nil nil) )) (cond ((listp jfn) (car jfn)) ))) |
Added psl-1983/3-1/util/20/get-command-args.sl version [cf53a910ff].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% GET-COMMAND-ARGS -- get command line arguments %%% %%% Author: Cris Perdue %%% 5 Apr 1983 1320-PST %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load parse-command-string get-command-string) %%% Returns a list of strings which are the command line %%% arguments to the program that was run. Program name is not %%% included. The code per se is not machine-dependent, but the %%% idea of getting a "command string" is so. (de get-command-args () (parse-command-string (get-command-string))) |
Added psl-1983/3-1/util/20/get-command-string.sl version [af7c252135].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Get-Command-String.SL (TOPS-20 Version) - Get Program Command String % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common jsys)) (load strings) % The function GET-COMMAND-STRING returns the string argument given % to the program when it was invoked. (de char-blank? (ch) (or (= ch (char space)) (= ch (char tab)))) (fluid '(command-string*)) (de get-command-string () (or command-string* (setq command-string* (dec20-get-command-string)))) (de dec20-get-command-string () % Read the process command string. This function should only be invoked once % in a given fork, and should be invoked as soon as possible. The process % command string is massaged to remove the program name and any trailing % CRLF. (prog (s high i j) (setq s (dec20-read-process-arg)) (setq high (size s)) (if (< high 0) (return "")) (setq i 0) (while (and (<= i high) (char-blank? (igets s i))) (setq i (+ i 1))) (setq j i) (while (and (<= j high) (not (char-blank? (igets s j)))) (setq j (+ j 1))) (if (string-equal (substring s i j) "run") (return "")) (while (and (<= j high) (char-blank? (igets s j))) (setq j (+ j 1))) (while (and (> high j) (not (graphicp (igets s high)))) (setq high (- high 1))) (return (substring s j (+ high 1))) )) (CompileTime (put 'prarg 'OpenCode '((jsys 357) (move (reg 1) (reg 3))))) (CompileTime (put 'rscan 'OpenCode '((jsys 320) (move (reg 1) (reg 1))))) (CompileTime (put 'sin 'OpenCode '((jsys 42) (move (reg 1) (reg 3))))) (de dec20-read-process-arg () % On TOPS-20, the command argument can be passed to an inferior fork in two % ways. The first (and better) way is to pass a string in the process % argument block. The second (and more popular) way is to pass a string in % the RESCAN buffer (what a crock!). We will use the process argument block, % if it is nonempty, otherwise we will read from the RESCAN buffer. (prog (arg-len str) (setq arg-len (prarg #.(int2sys (xword 1 8#400000)) 4 0)) (cond ((> arg-len 0) (setq str (MkString arg-len)) (prarg #.(int2sys (xword 1 8#400000)) (jconv str) arg-len) (return (recopystringtonull str)) )) (setq arg-len (rscan 0)) (if (= arg-len 0) (return "")) % no input string (setq str (MkString arg-len)) (sin 8#777777 (jconv str) (- arg-len)) (return str) )) |
Added psl-1983/3-1/util/20/get-heap-bounds.sl version [e9774ef393].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%% GET-HEAP-BOUNDS - looks up the addresses of the Syslisp variables %%% HeapLast and HeapLowerBound and makes it so that the Lisp function %%% HeapLast() returns the value of the variable HeapLast and the %%% Lisp function HeapLowerBound() returns the value of the variable %%% HeapLowerBound. Dec-20 only. (compiletime (load if-system syslisp)) % This depends on exactly the code generated for the CONS function % on the Dec-20. Very, very brittle code! (fluid '(!%heaplast-address)) (if_system PDP10 (de get-heap-bounds () (setq !%heaplast-address (inf (wgetv (getfcodepointer 'cons) 2))))) (de heaplast () (getmem !%heaplast-address)) % This depends on the order of declarations in PI:ALLOCATORS.RED and the % way storage is assigned for Syslisp variables. (de heaplowerbound () (wgetv !%heaplast-address 2)) (get-heap-bounds) |
Added psl-1983/3-1/util/20/homedir.build version [6e432a143f].
> | 1 | in "homedir.sl"$ |
Added psl-1983/3-1/util/20/homedir.sl version [c42a3aa0ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HOMEDIR.SL - USER-HOMEDIR-STRING function for Tops-20 % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1982 % Copyright (c) 1982 University of Utah % % 6 June 1983 Mark R. Swanson % Changes for extended addressing. (compiletime (progn (load monsym syslisp) (put 'get-user-number 'opencode '((gjinf))) (flag '(user-homedir-string-aux get-dir-string) 'internalfunction))) % Returns a string which is the init file for program-name. % Optional HOST is not supported. (de init-file-string (program-name) (concat (user-homedir-string) (concat program-name ".INIT"))) % Returns a string which is the users home directory name. % Optional HOST is not supported. (lap '((*entry user-homedir-string expr 0) (xmovei (reg 1) (indexed (reg st) 1)) % Pointer into the stack (*alloc 20) % allocate space (*call user-homedir-string-aux) % call the real function (*exit 20))) % deallocate and return (de user-homedir-string-aux (p) (concat "PS:<" (mkstr (get-dir-string p (get-user-number))))) (lap '((*entry get-dir-string expr 2) (*move (reg 1) (reg 5)) % save original addr in ac5 % (tlz (reg 1) 8#770000) % mask out old TAG (which % isn't there) (tlo (reg 1) 8#660000) % make it a global byte % pointer which will start % with next word (*move (reg 1) (reg 3)) % save it in ac3 (dirst) (erjmp cant-get-dir) (movei (reg 4) 62) % put a closing > on it (idpb (reg 4) (reg 1)) (setz (reg 4) 0) % put a null char on the end (idpb (reg 4) (reg 1)) (seto (reg 4) 0) % initialize length to -1 string-length-loop (ildb (reg 2) (reg 3)) (jumpe (reg 2) done-computing-length) (aoja (reg 4) string-length-loop) done-computing-length (movem (reg 4) (indexed (reg 5) 0)) % put len in string header (*move (reg 5) (reg 1)) % return original pointer (*exit 0) cant-get-dir (*move (reg 1) '"UNKNOWN>") (*exit 0))) |
Added psl-1983/3-1/util/20/input-stream.sl version [7806b22771].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Input-Stream.SL (TOPS-20 Version) - File Input Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.6 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.7 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % % Summary of public functions: % % (setf s (open-input "file name")) % generates error on failure % (setf s (attempt-to-open-input "file name")) % returns NIL on failure % (setf ch (=> s getc)) % read character (map CRLF to LF) % (setf ch (=> s getc-image)) % read character (don't map CRLF to LF) % (setf ch (=> s peekc)) % peek at next character % (setf ch (=> s peekc-image)) % peek at next character (don't map CRLF to LF) % (setf str (=> s getl)) % Read a line; return string without terminating LF. % (=> s empty?) % Are there no more characters? % (=> s close) % Close the file. % (setf fn (=> s file-name)) % Return "true" name of file. % (setf date (=> s read-date)) % Return date that file was last read. % (setf date (=> s write-date)) % Return date that file was last written. % (=> s delete-file) % Delete the associated file. % (=> s undelete-file) % Undelete the associated file. % (=> s delete-and-expunge) % Delete and expunge the associated file. % (setf name (=> s author)) % Return the name of the file's author. % (setf name (=> s original-author)) % Return the original author's name. % (setf count (=> s file-length)) % Return the byte count of the file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Changes: % % 9/29/82 Alan Snyder % Changed GETC to return stray CRs. % Now uses (=> self ...) form (produces same object code). % Added operations PEEKC-IMAGE, GETL, TELL-POSITION, SEEK-POSITION % (written by Nancy Kendzierski). % % 11/22/82 Alan Snyder % Changed SEEK-POSITION to work with large byte pointers (> 256K). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings)) (BothTimes (load objects jsys)) (load directory file-support) (de attempt-to-open-input (file-name) (let ((p (ErrorSet (list 'open-input file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-input (file-name) (let ((s (make-instance 'input-stream))) (=> s open file-name) s)) (DefConst FILE-BUFFER-SIZE #.(* 5 512)) (defflavor input-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next char in buffer count % number of valid chars in buffer eof-flag % T => this bufferfull is the last file-name % full name of actual file buffer % input buffer ) () (gettable-instance-variables file-name) ) % Note: The JSYS function can't be used for the 'SIN' JSYS because the JSYS % function handles errors. The 'SIN' JSYS will report an error on end-of-file % if errors are being handled. We don't want that to happen! (CompileTime (progn (put 'SIN 'OpenCode '((jsys 8#52) (move (reg 1) (reg 3)))) (put 'BIN 'OpenCode '((jsys 8#50) (move (reg 1) (reg 2)))) (put 'CLOSF 'OpenCode '((jsys 8#22) (move (reg 1) (reg 1)))) (put 'RFPTR 'OpenCode '((jsys 8#43) (jfcl) (move (reg 1) (reg 2)))) (put 'SFPTR 'OpenCode '((jsys 8#27) (jfcl) (move (reg 1) (reg 1)))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (input-stream getc) () % Return the next character from the file. Line termination is represented % by a single NEWLINE (LF) character. Returns NIL on end of file. % Implementation note: It was determined by experiment that the PSL % compiler produces much better code if there are no function calls other % than tail-recursive ones. That's why this function is written the way % it is. (if (< ptr count) (let ((ch (prog1 (string-fetch buffer ptr) (setf ptr (+ ptr 1)) ))) % Ignore CR followed by LF (if (= ch #\CR) (=> self &getc-after-CR) ch )) (=> self &fill-buffer-and-getc) )) (defmethod (input-stream &getc-after-CR) () % Internal method. % We have just read a CR from the buffer. If the next character % is a LF, then we should ignore the CR and return the LF. % Otherwise, we should return the CR. (if (= (=> self peekc-image) #\LF) (=> self getc-image) #\CR )) (defmethod (input-stream &fill-buffer-and-getc) () % Internal method. (and (=> self &fill-buffer) (=> self getc))) (defmethod (input-stream getc-image) () % Return the next character from the file. Do not perform any translation. % In particular, return all <CR>s. Returns NIL on end of file. (if (< ptr count) (prog1 (string-fetch buffer ptr) (setf ptr (+ ptr 1)) ) (=> self &fill-buffer-and-getc-image) )) (defmethod (input-stream &fill-buffer-and-getc-image) () % Internal method. (and (=> self &fill-buffer) (=> self getc-image))) (defmethod (input-stream empty?) () (null (=> self peekc-image))) (defmethod (input-stream peekc) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. Maps CRLF to LF. (if (< ptr count) (let ((ch (string-fetch buffer ptr))) % Ignore CR if followed by LF (if (and (= ch #\CR) (= (=> self &peek2) #\LF) ) #\LF ch )) (=> self &fill-buffer-and-peekc) )) (defmethod (input-stream &fill-buffer-and-peekc) () % Internal method. (and (=> self &fill-buffer) (=> self peekc))) (defmethod (input-stream peekc-image) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. (if (< ptr count) (string-fetch buffer ptr) (=> self &fill-buffer-and-peekc-image) )) (defmethod (input-stream &fill-buffer-and-peekc-image) () % Internal method. (and (=> self &fill-buffer) (=> self peekc-image))) (defmethod (input-stream &peek2) () % Internal method. % Return the character after the next character in the file, but don't % advance. Does not map CRLF. Returns Ascii NUL on end of file. Requires % that the buffer contain at least one character. This is a hack required % to implement PEEKC. (let ((next-ptr (+ ptr 1))) (cond ((>= next-ptr count) % The next character has not yet been read into the buffer. (let* ((old-pos (RFPTR jfn)) (ch (BIN jfn)) ) (SFPTR jfn old-pos) ch )) (t (string-fetch buffer next-ptr)) ))) (defmethod (input-stream &fill-buffer) () % Internal method. % Return NIL iff there are no more characters. (if eof-flag NIL (let ((n (SIN jfn (jconv buffer) (- (const FILE-BUFFER-SIZE))))) (if (~= n 0) (setf eof-flag T)) (setf count (+ (const FILE-BUFFER-SIZE) n)) (setf ptr 0) (~= count 0)))) (defmethod (input-stream getl) () % Read and return (the remainder of) the current input line. % Read, but don't return the terminating EOL (if any). % (EOL is interpreted as LF or CRLF) % Return NIL if no characters and end-of-file detected. (if (and (>= ptr count) (not (=> self &fill-buffer))) NIL % Else (let ((start ptr) (save-buffer NIL) (eof? NIL)) (while (and (not eof?) (~= (string-fetch buffer ptr) #\LF)) (setf ptr (+ ptr 1)) (cond ((>= ptr count) (setf save-buffer (concat save-buffer (subseq buffer start ptr))) (setf eof? (not (=> self &fill-buffer))) (setf start ptr) )) ) (if eof? save-buffer % Else (setf ptr (+ ptr 1)) (if (= ptr 1) (if save-buffer (if (= (string-fetch save-buffer (size save-buffer)) #\CR) (subseq save-buffer 0 (size save-buffer)) (sub save-buffer 0 (size save-buffer))) (subseq buffer start ptr)) (if (= (string-fetch buffer (- ptr 2)) #\CR) (concat save-buffer (subseq buffer start (- ptr 2))) (concat save-buffer (subseq buffer start (- ptr 1))) ))) ))) (defmethod (input-stream tell-position) () % Return an integer representing the current "position" of the stream. About % all we can guarantee about this integer is (1) it will be 0 at the % beginning of the file and (2) if you later SEEK-POSITION to this integer, % the stream will be reset to its current position. The reason for this % fuzziness is that the translation of CRLF into LF performed by the "normal" % input operations makes it impossible to predict the relationship between % the apparent file position and the actual file position. (- (RFPTR jfn) (- count ptr)) ) (defmethod (input-stream seek-position) (p) (setf p (int2sys p)) (let* ((buffer-end (RFPTR jfn)) (buffer-start (- buffer-end count))) (if (and (>= p buffer-start) (< p buffer-end)) (setf ptr (- p buffer-start)) % Else (SFPTR jfn p) (setf ptr 0) (setf count 0) (setf eof-flag NIL) ) )) (defmethod (input-stream open) (name-of-file) % Open the specified file for input via SELF. If the file cannot be opened, % a Continuable Error is generated. (if jfn (=> self close)) (setf buffer (MkString (const FILE-BUFFER-SIZE) #\space)) (setf ptr 0) (setf count 0) (setf eof-flag NIL) (setf jfn (Dec20Open name-of-file (int2sys 2#001000000000000001000000000000000000) (int2sys 2#000111000000000000010000000000100000) )) (if (= jfn 0) (setf jfn NIL)) (if (null jfn) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Input." name-of-file) name-of-file)) % Else (setf file-name (jfn-truename jfn)) )) (defmethod (input-stream close) () (when jfn (CLOSF jfn) (setf jfn NIL) (setf buffer NIL) (setf count 0) (setf ptr 0) (setf eof-flag T) )) (defmethod (input-stream read-date) () (jfn-read-date jfn)) (defmethod (input-stream write-date) () (jfn-write-date jfn)) (defmethod (input-stream delete-file) () (jfn-delete jfn)) (defmethod (input-stream undelete-file) () (jfn-undelete jfn)) (defmethod (input-stream delete-and-expunge-file) () (jfn-delete-and-expunge jfn)) (defmethod (input-stream author) () (jfn-author jfn)) (defmethod (input-stream original-author) () (jfn-original-author jfn)) (defmethod (input-stream file-length) () (jfn-byte-count jfn)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CommentOutCode (progn (de test-buffered-input (name-of-file) (setf s (open-input name-of-file)) (while (setf ch (input-stream$getc s)) (WriteChar ch) ) (=> s close) (Prin2 "---EOF---") NIL ) (de time-buffered-input (name-of-file) (setf start-time (time)) (setf s (open-input name-of-file)) (while (setf ch (input-stream$getc s)) ) (=> s close) (- (time) start-time) ) (de time-buffered-input-1 (name-of-file) (setf start-time (time)) (setf s (open-input name-of-file)) (while (setf ch (=> s getc)) ) (=> s close) (- (time) start-time) ) (de time-standard-input (name-of-file) (setf start-time (time)) (setf chan (open name-of-file 'INPUT)) (while (not (= (setf ch (ChannelReadChar chan)) $EOF$)) ) (close chan) (- (time) start-time) ) (de time-input (name-of-file) (list (time-buffered-input name-of-file) (time-buffered-input-1 name-of-file) (time-standard-input name-of-file) )) )) % End CommentOutCode |
Added psl-1983/3-1/util/20/interrupt.build version [a61aa846c7].
> > | 1 2 | CompileTime load Syslisp, Monsym, Jsys; in "20-interrupt.red"$ |
Added psl-1983/3-1/util/20/jsys.build version [415e3b24fb].
> > | 1 2 | CompileTime load Monsym; in "jsys.red"$ |
Added psl-1983/3-1/util/20/jsys.red version [179406df9b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % JSYS.RED - Simple XJSYS function % % Author: Martin L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 March 1981 % Copyright (c) 1981 University of Utah % % <PSL.UTIL>JSYS.RED.9, 18-May-82 13:24:36, Edit by BENSON % Made XJSYSn OpenCode'ed %/ Changed FILNAM->FileName, due to GLOBAL conflict %/ Changed JSYS calls, so LIST(..) rather than '(..) used %/ Changed for V3:JSYS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % <PSL.UTIL>JSYS.RED.2, 18-Mar-82 21:49:32, Edit by GRISS % Converted to V3 %. M. Griss 3:32pm Saturday, 7 November 1981 %. MLG: Fixed GetErrorString and BITS macro, 8:57am Friday, 25 December 1981 on syslisp; % Modeled after the IDapply to avoid CONS, register reloads % could easily be done Opencoded % SYSLSP calls, expect W value, return appropriate register %. syslsp procedure XJsys0(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys1(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys2(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys3(Jr1,Jr2,Jr3,Jr4,Jnum) %. syslsp procedure XJsys4(Jr1,Jr2,Jr3,Jr4,Jnum) lap '((!*entry xjsys0 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (wconst 0) (reg 1)) (!*exit 0))$ BothTimes put('xjsys0, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (setzm (reg 1)))); lap '((!*entry xjsys1 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*exit 0))$ BothTimes put('xjsys1, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)))); lap '((!*entry xjsys2 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 2) (reg 1)) (!*exit 0))$ BothTimes put('xjsys2, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 2)))); lap '((!*entry xjsys3 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 3) (reg 1)) (!*exit 0))$ BothTimes put('xjsys3, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 3)))); lap '((!*entry xjsys4 expr 5) (jsys (indirect (reg 5))) (erjmp (entry xjsyserror)) (!*move (reg 4) (reg 1)) (!*exit 0))$ BothTimes put('xjsys4, 'OpenCode, '((jsys (indexed (reg 5) 0)) (jump 8#16 (entry xjsyserror)) (move (reg 1) (reg 4)))); lap '((!*entry geterrorstring expr 1) (!*move (wconst -1) (reg 2)) % most recent error (hrli (reg 2) 8#400000) % self process (!*move (wconst 0) (reg 3)) % all string (erstr) % get the error string to a1 buffer (jfcl) (jfcl) (!*exit 0))$ syslsp procedure xjsyserror$ %/ should load up errstr begin scalar s; s:=gtstr 200; geterrorstring lor(lsh(8#660700,18), s)$ return stderror recopystringtonull s; end; % --- conversions for lisp level calls syslsp procedure str2int s; sys2int strinf s; syslsp procedure int2str i; mkstr int2sys i; syslsp procedure jconv j; %. handle untagging if fixp j then int2sys j else if stringp j then lor(lsh(8#660000,18),strinf(j)) % Bug in LONG const else stderror list(j,'" not known in jconv"); % lisp calls. untag args, then tag result as integer % user has to convert result from xword, stringbase, etc syslsp procedure jsys0(jr1,jr2,jr3,jr4,jnum); sys2int xjsys0(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys1(jr1,jr2,jr3,jr4,jnum); sys2int xjsys1(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys2(jr1,jr2,jr3,jr4,jnum); sys2int xjsys2(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys3(jr1,jr2,jr3,jr4,jnum); sys2int xjsys3(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure jsys4(jr1,jr2,jr3,jr4,jnum); sys2int xjsys4(jconv jr1,jconv jr2,jconv jr3,jconv jr4,int2sys jnum)$ syslsp procedure checknum(x,y); if intp x then intinf x else nonintegererror(x,y); CommentOutCode<< syslsp procedure insertstringsize s; begin scalar l,s1; % this must not be done to a string l:=0; s1:=strinf(s); % in the heap! while not (strbyt(s1,l)= char null) do l:=l+1; @s1:=mkitem(hstr,l-1); return s; end; >>; syslsp procedure recopystringtonull s; begin scalar l,s1,s2,ch; l:=0; s1:=strinf(s); while not (strbyt(s1,l)= char null) do l:=l+1; s2:=gtstr(l-1); l:=0; while not ((ch:=strbyt(s1,l))= char null) do <<strbyt(s2,l):= ch; l:=l+1>>; return mkstr s2; end; % ------------ useful bit, byte and word utilities syslsp procedure swap(x); %. swap half words xword(lowhalfword x,highhalfword x); syslsp procedure lowhalfword n; sys2int land(int2sys n,8#777777); compiletime << syslsp smacro procedure rsh(x,y); lsh(x,-y); >>; syslsp procedure highhalfword n; sys2int land(rsh(int2sys n,18),8#777777); syslsp procedure xword(x,y); %. build word from half-words % sys2int lor(lsh(lowhalfword(int2sys x),18), % lowhalfword int2sys y); %/Compiler error begin scalar Tmp; Tmp := lowhalfword int2sys x; Tmp := lsh(Tmp, 18); Tmp := lor(Tmp, lowhalfword int2sys y); return sys2int Tmp; end; syslsp procedure jbits l; %. convert bit and byte fields % l is list of bitpos or (fieldvalue . rightbitpos) % msb is #0, lsb is #35 on dec-20 begin scalar wd,x,fldpos,fldval; wd:=0; lb: if not pairp l then return sys2int wd; x:=car l; l := cdr l; if pairp x then <<fldpos:=cdr x; fldval:=car x>> else <<fldpos:=x; fldval:=1>>; if not (fixp fldval and fixp fldpos) then goto lb; if fldpos <0 or fldpos > 35 then goto lb; wd := lor(wd,lsh(fldval,35-fldpos)); goto lb; end; macro procedure bits l; list('jbits, 'list . cdr l); %. load jSYS Names procedure MakeJsys(Name, Number); EvDefConst(Name, Number); off syslisp; MakeJsys( 'jsJSYS , 8#0)$ MakeJsys( 'jsLOGIN , 8#1)$ MakeJsys( 'jsCRJOB , 8#2)$ MakeJsys( 'jsLGOUT , 8#3)$ MakeJsys( 'jsCACCT , 8#4)$ MakeJsys( 'jsEFACT , 8#5)$ MakeJsys( 'jsSMON , 8#6)$ MakeJsys( 'jsTMON , 8#7)$ MakeJsys( 'jsGETAB , 8#10)$ MakeJsys( 'jsERSTR , 8#11)$ MakeJsys( 'jsGETER , 8#12)$ MakeJsys( 'jsGJINF , 8#13)$ MakeJsys( 'jsTIME , 8#14)$ MakeJsys( 'jsRUNTM , 8#15)$ MakeJsys( 'jsSYSGT , 8#16)$ MakeJsys( 'jsGNJFN , 8#17)$ MakeJsys( 'jsGTJFN , 8#20)$ MakeJsys( 'jsOPENF , 8#21)$ MakeJsys( 'jsCLOSF , 8#22)$ MakeJsys( 'jsRLJFN , 8#23)$ MakeJsys( 'jsGTSTS , 8#24)$ MakeJsys( 'jsSTSTS , 8#25)$ MakeJsys( 'jsDELF , 8#26)$ MakeJsys( 'jsSFPTR , 8#27)$ MakeJsys( 'jsJFNS , 8#30)$ MakeJsys( 'jsFFFFP , 8#31)$ MakeJsys( 'jsRDDIR , 8#32)$ MakeJsys( 'jsCPRTF , 8#33)$ MakeJsys( 'jsCLZFF , 8#34)$ MakeJsys( 'jsRNAMF , 8#35)$ MakeJsys( 'jsSIZEF , 8#36)$ MakeJsys( 'jsGACTF , 8#37)$ MakeJsys( 'jsSTDIR , 8#40)$ MakeJsys( 'jsDIRST , 8#41)$ MakeJsys( 'jsBKJFN , 8#42)$ MakeJsys( 'jsRFPTR , 8#43)$ MakeJsys( 'jsCNDIR , 8#44)$ MakeJsys( 'jsRFBSZ , 8#45)$ MakeJsys( 'jsSFBSZ , 8#46)$ MakeJsys( 'jsSWJFN , 8#47)$ MakeJsys( 'jsBIN , 8#50)$ MakeJsys( 'jsBOUT , 8#51)$ MakeJsys( 'jsSIN , 8#52)$ MakeJsys( 'jsSOUT , 8#53)$ MakeJsys( 'jsRIN , 8#54)$ MakeJsys( 'jsROUT , 8#55)$ MakeJsys( 'jsPMAP , 8#56)$ MakeJsys( 'jsRPACS , 8#57)$ MakeJsys( 'jsSPACS , 8#60)$ MakeJsys( 'jsRMAP , 8#61)$ MakeJsys( 'jsSACTF , 8#62)$ MakeJsys( 'jsGTFDB , 8#63)$ MakeJsys( 'jsCHFDB , 8#64)$ MakeJsys( 'jsDUMPI , 8#65)$ MakeJsys( 'jsDUMPO , 8#66)$ MakeJsys( 'jsDELDF , 8#67)$ MakeJsys( 'jsASND , 8#70)$ MakeJsys( 'jsRELD , 8#71)$ MakeJsys( 'jsCSYNO , 8#72)$ MakeJsys( 'jsPBIN , 8#73)$ MakeJsys( 'jsPBOUT , 8#74)$ MakeJsys( 'jsPSIN , 8#75)$ MakeJsys( 'jsPSOUT , 8#76)$ MakeJsys( 'jsMTOPR , 8#77)$ MakeJsys( 'jsCFIBF , 8#100)$ MakeJsys( 'jsCFOBF , 8#101)$ MakeJsys( 'jsSIBE , 8#102)$ MakeJsys( 'jsSOBE , 8#103)$ MakeJsys( 'jsDOBE , 8#104)$ MakeJsys( 'jsGTABS , 8#105)$ MakeJsys( 'jsSTABS , 8#106)$ MakeJsys( 'jsRFMOD , 8#107)$ MakeJsys( 'jsSFMOD , 8#110)$ MakeJsys( 'jsRFPOS , 8#111)$ MakeJsys( 'jsRFCOC , 8#112)$ MakeJsys( 'jsSFCOC , 8#113)$ MakeJsys( 'jsSTI , 8#114)$ MakeJsys( 'jsDTACH , 8#115)$ MakeJsys( 'jsATACH , 8#116)$ MakeJsys( 'jsDVCHR , 8#117)$ MakeJsys( 'jsSTDEV , 8#120)$ MakeJsys( 'jsDEVST , 8#121)$ MakeJsys( 'jsMOUNT , 8#122)$ MakeJsys( 'jsDSMNT , 8#123)$ MakeJsys( 'jsINIDR , 8#124)$ MakeJsys( 'jsSIR , 8#125)$ MakeJsys( 'jsEIR , 8#126)$ MakeJsys( 'jsSKPIR , 8#127)$ MakeJsys( 'jsDIR , 8#130)$ MakeJsys( 'jsAIC , 8#131)$ MakeJsys( 'jsIIC , 8#132)$ MakeJsys( 'jsDIC , 8#133)$ MakeJsys( 'jsRCM , 8#134)$ MakeJsys( 'jsRWM , 8#135)$ MakeJsys( 'jsDEBRK , 8#136)$ MakeJsys( 'jsATI , 8#137)$ MakeJsys( 'jsDTI , 8#140)$ MakeJsys( 'jsCIS , 8#141)$ MakeJsys( 'jsSIRCM , 8#142)$ MakeJsys( 'jsRIRCM , 8#143)$ MakeJsys( 'jsRIR , 8#144)$ MakeJsys( 'jsGDSTS , 8#145)$ MakeJsys( 'jsSDSTS , 8#146)$ MakeJsys( 'jsRESET , 8#147)$ MakeJsys( 'jsRPCAP , 8#150)$ MakeJsys( 'jsEPCAP , 8#151)$ MakeJsys( 'jsCFORK , 8#152)$ MakeJsys( 'jsKFORK , 8#153)$ MakeJsys( 'jsFFORK , 8#154)$ MakeJsys( 'jsRFORK , 8#155)$ MakeJsys( 'jsRFSTS , 8#156)$ MakeJsys( 'jsSFORK , 8#157)$ MakeJsys( 'jsSFACS , 8#160)$ MakeJsys( 'jsRFACS , 8#161)$ MakeJsys( 'jsHFORK , 8#162)$ MakeJsys( 'jsWFORK , 8#163)$ MakeJsys( 'jsGFRKH , 8#164)$ MakeJsys( 'jsRFRKH , 8#165)$ MakeJsys( 'jsGFRKS , 8#166)$ MakeJsys( 'jsDISMS , 8#167)$ MakeJsys( 'jsHALTF , 8#170)$ MakeJsys( 'jsGTRPW , 8#171)$ MakeJsys( 'jsGTRPI , 8#172)$ MakeJsys( 'jsRTIW , 8#173)$ MakeJsys( 'jsSTIW , 8#174)$ MakeJsys( 'jsSOBF , 8#175)$ MakeJsys( 'jsRWSET , 8#176)$ MakeJsys( 'jsGETNM , 8#177)$ MakeJsys( 'jsGET , 8#200)$ MakeJsys( 'jsSFRKV , 8#201)$ MakeJsys( 'jsSAVE , 8#202)$ MakeJsys( 'jsSSAVE , 8#203)$ MakeJsys( 'jsSEVEC , 8#204)$ MakeJsys( 'jsGEVEC , 8#205)$ MakeJsys( 'jsGPJFN , 8#206)$ MakeJsys( 'jsSPJFN , 8#207)$ MakeJsys( 'jsSETNM , 8#210)$ MakeJsys( 'jsFFUFP , 8#211)$ MakeJsys( 'jsDIBE , 8#212)$ MakeJsys( 'jsFDFRE , 8#213)$ MakeJsys( 'jsGDSKC , 8#214)$ MakeJsys( 'jsLITES , 8#215)$ MakeJsys( 'jsTLINK , 8#216)$ MakeJsys( 'jsSTPAR , 8#217)$ MakeJsys( 'jsODTIM , 8#220)$ MakeJsys( 'jsIDTIM , 8#221)$ MakeJsys( 'jsODCNV , 8#222)$ MakeJsys( 'jsIDCNV , 8#223)$ MakeJsys( 'jsNOUT , 8#224)$ MakeJsys( 'jsNIN , 8#225)$ MakeJsys( 'jsSTAD , 8#226)$ MakeJsys( 'jsGTAD , 8#227)$ MakeJsys( 'jsODTNC , 8#230)$ MakeJsys( 'jsIDTNC , 8#231)$ MakeJsys( 'jsFLIN , 8#232)$ MakeJsys( 'jsFLOUT , 8#233)$ MakeJsys( 'jsDFIN , 8#234)$ MakeJsys( 'jsDFOUT , 8#235)$ MakeJsys( 'jsCRDIR , 8#240)$ MakeJsys( 'jsGTDIR , 8#241)$ MakeJsys( 'jsDSKOP , 8#242)$ MakeJsys( 'jsSPRIW , 8#243)$ MakeJsys( 'jsDSKAS , 8#244)$ MakeJsys( 'jsSJPRI , 8#245)$ MakeJsys( 'jsSTO , 8#246)$ MakeJsys( 'jsBBNIIT , 8#247)$ MakeJsys( 'jsARCF , 8#247)$ MakeJsys( 'jsASNDP , 8#260)$ MakeJsys( 'jsRELDP , 8#261)$ MakeJsys( 'jsASNDC , 8#262)$ MakeJsys( 'jsRELDC , 8#263)$ MakeJsys( 'jsSTRDP , 8#264)$ MakeJsys( 'jsSTPDP , 8#265)$ MakeJsys( 'jsSTSDP , 8#266)$ MakeJsys( 'jsRDSDP , 8#267)$ MakeJsys( 'jsWATDP , 8#270)$ MakeJsys( 'jsATNVT , 8#274)$ MakeJsys( 'jsCVSKT , 8#275)$ MakeJsys( 'jsCVHST , 8#276)$ MakeJsys( 'jsFLHST , 8#277)$ MakeJsys( 'jsGCVEC , 8#300)$ MakeJsys( 'jsSCVEC , 8#301)$ MakeJsys( 'jsSTTYP , 8#302)$ MakeJsys( 'jsGTTYP , 8#303)$ MakeJsys( 'jsBPT , 8#304)$ MakeJsys( 'jsGTDAL , 8#305)$ MakeJsys( 'jsWAIT , 8#306)$ MakeJsys( 'jsHSYS , 8#307)$ MakeJsys( 'jsUSRIO , 8#310)$ MakeJsys( 'jsPEEK , 8#311)$ MakeJsys( 'jsMSFRK , 8#312)$ MakeJsys( 'jsESOUT , 8#313)$ MakeJsys( 'jsSPLFK , 8#314)$ MakeJsys( 'jsADVIS , 8#315)$ MakeJsys( 'jsJOBTM , 8#316)$ MakeJsys( 'jsDELNF , 8#317)$ MakeJsys( 'jsSWTCH , 8#320)$ MakeJsys( 'jsOPRFN , 8#326)$ MakeJsys( 'jsCGRP , 8#327)$ MakeJsys( 'jsVACCT , 8#330)$ MakeJsys( 'jsGDACC , 8#331)$ MakeJsys( 'jsATGRP , 8#332)$ MakeJsys( 'jsGACTJ , 8#333)$ MakeJsys( 'jsGPSGN , 8#334)$ MakeJsys( 'jsRSCAN , 8#500)$ MakeJsys( 'jsHPTIM , 8#501)$ MakeJsys( 'jsCRLNM , 8#502)$ MakeJsys( 'jsINLNM , 8#503)$ MakeJsys( 'jsLNMST , 8#504)$ MakeJsys( 'jsRDTXT , 8#505)$ MakeJsys( 'jsSETSN , 8#506)$ MakeJsys( 'jsGETJI , 8#507)$ MakeJsys( 'jsMSEND , 8#510)$ MakeJsys( 'jsMRECV , 8#511)$ MakeJsys( 'jsMUTIL , 8#512)$ MakeJsys( 'jsENQ , 8#513)$ MakeJsys( 'jsDEQ , 8#514)$ MakeJsys( 'jsENQC , 8#515)$ MakeJsys( 'jsSNOOP , 8#516)$ MakeJsys( 'jsSPOOL , 8#517)$ MakeJsys( 'jsALLOC , 8#520)$ MakeJsys( 'jsCHKAC , 8#521)$ MakeJsys( 'jsTIMER , 8#522)$ MakeJsys( 'jsRDTTY , 8#523)$ MakeJsys( 'jsTEXTI , 8#524)$ MakeJsys( 'jsUFPGS , 8#525)$ MakeJsys( 'jsSFPOS , 8#526)$ MakeJsys( 'jsSYERR , 8#527)$ MakeJsys( 'jsDIAG , 8#530)$ MakeJsys( 'jsSINR , 8#531)$ MakeJsys( 'jsSOUTR , 8#532)$ MakeJsys( 'jsRFTAD , 8#533)$ MakeJsys( 'jsSFTAD , 8#534)$ MakeJsys( 'jsTBDEL , 8#535)$ MakeJsys( 'jsTBADD , 8#536)$ MakeJsys( 'jsTBLUK , 8#537)$ MakeJsys( 'jsSTCMP , 8#540)$ MakeJsys( 'jsSETJB , 8#541)$ MakeJsys( 'jsGDVEC , 8#542)$ MakeJsys( 'jsSDVEC , 8#543)$ MakeJsys( 'jsCOMND , 8#544)$ MakeJsys( 'jsPRARG , 8#545)$ MakeJsys( 'jsGACCT , 8#546)$ MakeJsys( 'jsLPINI , 8#547)$ MakeJsys( 'jsGFUST , 8#550)$ MakeJsys( 'jsSFUST , 8#551)$ MakeJsys( 'jsACCES , 8#552)$ MakeJsys( 'jsRCDIR , 8#553)$ MakeJsys( 'jsRCUSR , 8#554)$ MakeJsys( 'jsXRIR!% , 8#601)$ MakeJsys( 'jsXSIR!% , 8#602)$ MakeJsys( 'jsSNDIM , 8#750)$ MakeJsys( 'jsRCVIM , 8#751)$ MakeJsys( 'jsASNSQ , 8#752)$ MakeJsys( 'jsRELSQ , 8#753)$ MakeJsys( 'jsTHIBR , 8#770)$ MakeJsys( 'jsTWAKE , 8#771)$ MakeJsys( 'jsMRPAC , 8#772)$ MakeJsys( 'jsSETPV , 8#773)$ MakeJsys( 'jsMTALN , 8#774)$ MakeJsys( 'jsTTMSG , 8#775)$ End$ |
Added psl-1983/3-1/util/20/monsym.build version [6593a960b2].
> | 1 | in "monsym.red"$ |
Added psl-1983/3-1/util/20/monsym.red version [d40386e46d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MONSYM.RED - Support for Dec-20 system LAP code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 March 1982 % Copyright (c) 1982 University of Utah % CompileTime << macro procedure DefineJSYSRangeFrom X; begin scalar Start, L; Start := Sub1 second X; L := third X; return ('progn . for each Name in second L collect list('progn, list('put, MkQuote Name,'(quote JSYSValue), Start := Add1 Start), list('put,MkQuote Name, '(quote InstructionDepositFunction), '(quote JSYSDeposit)))); end; >>; lisp procedure JSYSDeposit X; << if !*WritingFaslFile then UpdateBitTable(1, 0); DepositAllFields(8#104, 0, get(car X, 'JSYSValue)) >>; flag('(ERJMP ERCAL), 'MC); lisp procedure ERJMP Address; list list('jump, 8#16, Address); lisp procedure ERCAL Address; list list('jump, 8#17, Address); DefineJSYSRangeFrom(1, '( LOGIN CRJOB LGOUT CACCT EFACT SMON TMON GETAB ERSTR GETER GJINF TIME RUNTM SYSGT GNJFN GTJFN OPENF CLOSF RLJFN GTSTS STSTS DELF SFPTR JFNS FFFFP RDDIR CPRTF CLZFF RNAMF SIZEF GACTF STDIR DIRST BKJFN RFPTR CNDIR RFBSZ SFBSZ SWJFN BIN BOUT SIN SOUT RIN ROUT PMAP RPACS SPACS RMAP SACTF GTFDB CHFDB DUMPI DUMPO DELDF ASND RELD CSYNO PBIN PBOUT PSIN PSOUT MTOPR CFIBF CFOBF SIBE SOBE DOBE GTABS STABS RFMOD SFMOD RFPOS RFCOC SFCOC STI DTACH ATACH DVCHR STDEV DEVST MOUNT DSMNT INIDR SIR EIR SKPIR DIR AIC IIC DIC RCM RWM DEBRK ATI DTI CIS SIRCM RIRCM RIR GDSTS SDSTS RESET RPCAP EPCAP CFORK KFORK FFORK RFORK RFSTS SFORK SFACS RFACS HFORK WFORK GFRKH RFRKH GFRKS DISMS HALTF GTRPW GTRPI RTIW STIW SOBF RWSET GETNM GET SFRKV SAVE SSAVE SEVEC GEVEC GPJFN SPJFN SETNM FFUFP DIBE FDFRE GDSKC LITES TLINK STPAR ODTIM IDTIM ODCNV IDCNV NOUT NIN STAD GTAD ODTNC IDTNC FLIN FLOUT DFIN DFOUT )); DefineJSYSRangeFrom(160, '( CRDIR GTDIR DSKOP SPRIW DSKAS SJPRI STO ARCF )); %define(jsASNDP,8%260) # NOT IMPLEMENTED %define(jsRELDP,8%261) # NOT IMPLEMENTED %define(jsASNDC,8%262) # NOT IMPLEMENTED %define(jsRELDC,8%263) # NOT IMPLEMENTED %define(jsSTRDP,8%264) # NOT IMPLEMENTED %define(jsSTPDP,8%265) # NOT IMPLEMENTED %define(jsSTSDP,8%266) # NOT IMPLEMENTED %define(jsRDSDP,8%267) # NOT IMPLEMENTED %define(jsWATDP,8%270) # NOT IMPLEMENTED DefineJSYSRangeFrom(188, '( ATNVT CVSKT CVHST FLHST GCVEC SCVEC STTYP GTTYP BPT GTDAL WAIT HSYS USRIO PEEK MSFRK ESOUT SPLFK ADVIS JOBTM DELNF SWTCH TFORK RTFRK UTFRK )); DefineJSYSRangeFrom(214, '( OPRFN CGRP VACCT GDACC ATGRP GACTJ GPSGN )); DefineJSYSRangeFrom(320, '( RSCAN HPTIM CRLNM INLNM LNMST RDTXT SETSN GETJI MSEND MRECV MUTIL ENQ DEQ ENQC SNOOP SPOOL ALLOC CHKAC TIMER RDTTY TEXTI UFPGS SFPOS SYERR DIAG SINR SOUTR RFTAD SFTAD TBDEL TBADD TBLUK STCMP SETJB GDVEC SDVEC COMND PRARG GACCT LPINI GFUST SFUST ACCES RCDIR RCUSR )); DefineJSYSRangeFrom(488, '( SNDIM RCVIM ASNSQ RELSQ )); DefineJSYSRangeFrom(504, '( THIBR TWAKE MRPAC SETPV MTALN TTMSG )); END; |
Added psl-1983/3-1/util/20/output-stream.sl version [4540cd6db5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Output-Stream.SL (TOPS-20 Version) - File Output Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.7 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.9 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vectors fast-strings)) (BothTimes (load objects jsys)) (de attempt-to-open-output (file-name) (let ((p (ErrorSet (list 'open-output file-name) NIL NIL))) (and (PairP p) (car p)) )) (de attempt-to-open-append (file-name) (let ((p (ErrorSet (list 'open-append file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-output (file-name) (let ((s (make-instance 'output-stream))) (=> s open file-name) s)) (de open-append (file-name) (let ((s (make-instance 'output-stream))) (=> s open-append file-name) s)) (defconst FILE-BUFFER-SIZE #.(* 5 512)) (defflavor output-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next free slot in buffer file-name % full name of actual file buffer % output buffer ) () (gettable-instance-variables file-name) ) (CompileTime (put 'SOUT 'OpenCode '((jsys 43) (move (reg 1) (reg 3))))) (CompileTime (put 'CLOSF 'OpenCode '((jsys 18) (move (reg 1) (reg 1))))) (defmethod (output-stream putc) (ch) % Append the character CH to the file. Line termination is indicated by % writing a single NEWLINE (LF) character. % Implementation note: It was determined by experiment that the PSL % compiler produces much better code if there are no function calls other % than tail-recursive ones. That's why this function is written the way % it is. (if (= ch #\LF) (=> self put-newline) % Otherwise: (string-store buffer ptr ch) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) )) (defmethod (output-stream put-newline) () % Output a line terminator. (string-store buffer ptr #\CR) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) (string-store buffer ptr #\LF) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) ) (defmethod (output-stream putc-image) (ch) % Append the character CH to the file. No translation of LF character. (string-store buffer ptr ch) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) ) (defmethod (output-stream puts) (str) % Write string to output stream (highly optimized!) (let ((i 0) (high (string-upper-bound str)) ) (while (<= i high) (string-store buffer ptr (string-fetch str i)) (if (>= (setf ptr (+ ptr 1)) (const FILE-BUFFER-SIZE)) (=> self flush)) (setf i (+ i 1)) ))) (defmethod (output-stream putl) (str) % Write string followed by line terminator to output stream. (=> self puts str) (=> self put-newline) ) (defmethod (output-stream open) (name-of-file) % Open the specified file for output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (=> self close)) (setf jfn (Dec20Open name-of-file (int2sys 2#100000000000000001000000000000000000) (int2sys 2#000111000000000000001000000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Output" name-of-file) name-of-file)) (=> self &fixup) )) (defmethod (output-stream open-append) (name-of-file) % Open the specified file for append output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (=> self close)) (setf jfn (Dec20Open name-of-file (int2sys 2#000000000000000001000000000000000000) (int2sys 2#000111000000000000000010000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open-append (ContinuableError 0 (BldMsg "Unable to Open '%w' for Append" name-of-file) name-of-file)) (=> self &fixup) )) (defmethod (output-stream attach-to-jfn) (new-jfn) % Attach the output-stream to the specified JFN. (if jfn (=> self close)) (setf jfn new-jfn) (=> self &fixup) ) (defmethod (output-stream &fixup) () % Internal method for initializing instance variables after setting JFN. (setf buffer (make-string (const FILE-BUFFER-SIZE) #\space)) % It is necessary to clear out the low-order bit, lest some programs % think we are writing "line numbers" (what a crock!). (for (from i 0 (- (/ (const FILE-BUFFER-SIZE) 5) 1)) (do (vector-store buffer i 0))) (setf ptr 0) (setf file-name (jfn-truename jfn)) ) (defmethod (output-stream close) () (when jfn (=> self flush) (CLOSF jfn) (setf jfn NIL) (setf buffer NIL) )) (defmethod (output-stream flush) () (when (> ptr 0) (SOUT jfn (jconv buffer) (- ptr)) (setf ptr 0) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (setf time-output-test-string "This is a line of text for testing.")) (CommentOutCode (progn (de time-buffered-output (n-lines) % This is the FAST way to do buffered output. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (output-stream$putc s ch)) ) (output-stream$put-newline s) )) (=> s close) (- (time) start-time) ) (de time-buffered-output-1 (n-lines) % This is the SLOW (but GENERAL) way to do buffered output. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (=> s putc ch)) ) (=> s put-newline) )) (=> s close) (- (time) start-time) ) (de time-standard-output (n-lines) (setf start-time (time)) (setf chan (open "test.output" 'OUTPUT)) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (ChannelWriteChar chan ch)) ) (ChannelWriteChar chan #\LF) )) (close chan) (- (time) start-time) ) (de time-output (n-lines) (list (time-buffered-output-string n-lines) (time-buffered-output n-lines) (time-buffered-output-1 n-lines) (time-standard-output n-lines) )) (de time-buffered-output-string (n-lines) % This is the FAST way to do buffered output from strings. (setf start-time (time)) (setf s (open-output "test.output")) (for (from i 1 n-lines 1) (do (output-stream$putl s #.time-output-test-string)) ) (=> s close) (- (time) start-time) ) )) % End CommentOutCode |
Added psl-1983/3-1/util/20/pathnames.sl version [fc386fd8c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PathNames.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 9 February 1983 % % DEC-20 implementation of some Common Lisp pathname functions. % % 9-Feb-83 Alan Snyder % Revise conversion to string to omit the dot if there is no type or version. % Revise conversion from string to interpret trailing dot as specifying % an empty type or version. Change home-directory to specify PS: % Fix bug in make-pathname. Convert to using fast-strings stuff. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vector fast-strings)) (BothTimes (load objects)) (when (funboundp 'string2integer) (de string2integer (s) (makestringintolispinteger s 10 1) )) % The following function is an NEXPR: be sure this module is loaded at % compile-time if you use this function in code to be compiled! (dn make-pathname (keyword-arg-list) (let ((pn (make-instance 'pathname))) (while (not (null keyword-arg-list)) (let ((keyword (car keyword-arg-list))) (setf keyword-arg-list (cdr keyword-arg-list)) (cond (keyword-arg-list (let ((value (car keyword-arg-list))) (setf keyword-arg-list (cdr keyword-arg-list)) (selectq keyword (host (=> pn set-host value)) (device (=> pn set-device value)) (directory (=> pn set-directory value)) (name (=> pn set-name value)) (type (=> pn set-type value)) (version (=> pn set-version value)) )))))) pn )) (de pathname-host (pn) (=> (pathname pn) host)) (de pathname-device (pn) (=> (pathname pn) device)) (de pathname-directory (pn) (=> (pathname pn) directory)) (de pathname-name (pn) (=> (pathname pn) name)) (de pathname-type (pn) (=> (pathname pn) type)) (de pathname-version (pn) (=> (pathname pn) version)) (de PathnameP (x) (and (VectorP x) (eq (getv x 0) 'pathname))) (de StreamP (x) (and (VectorP x) (object-get-handler-quietly x 'file-name))) (de truename (x) (pathname x)) (de pathname (x) (cond ((PathnameP x) x) ((StringP x) (string-to-pathname x)) ((IdP x) (string-to-pathname (id2string x))) ((StreamP x) (string-to-pathname (=> x file-name))) (t (TypeError x "PathName" "convertible to a pathname")) )) (de namestring (x) (setf x (pathname x)) (let ((dev (pathname-device x)) (dir (pathname-directory x)) (name (pathname-name x)) (type (pathname-type x)) (vers (pathname-version x)) ) (string-concat (if dev (string-concat (pathname-field-to-string dev) ":") "") (if dir (string-concat "<" (pathname-field-to-string dir) ">") "") (if name (pathname-field-to-string name) "") (if (or (not (pathname-empty-field? type)) (not (pathname-empty-field? vers))) (string-concat "." (pathname-field-to-string type)) "") (if (not (pathname-empty-field? vers)) (string-concat "." (pathname-field-to-string vers)) "") ))) (de file-namestring (x) (setf x (pathname x)) (let ((name (pathname-name x)) (type (pathname-type x)) (vers (pathname-version x)) ) (string-concat (if name (pathname-field-to-string name) "") (if type (string-concat "." (pathname-field-to-string type)) "") (if vers (string-concat "." (pathname-field-to-string vers)) "") ))) (de directory-namestring (x) (setf x (pathname x)) (let ((dir (pathname-directory x)) ) (if dir (string-concat "<" (pathname-field-to-string dir) ">") "") )) (de user-homedir-pathname () (let ((pn (make-instance 'pathname)) (user-number (Jsys1 0 0 0 0 (const jsGJINF))) (dir-name (MkString 100 (char space))) ) (Jsys1 dir-name user-number 0 0 (const jsDIRST)) (setf dir-name (recopystringtonull dir-name)) (=> pn set-device "PS") (=> pn set-directory dir-name) pn )) (de init-file-pathname (program-name) (let ((pn (user-homedir-pathname))) (=> pn set-name program-name) (=> pn set-type "INIT") pn )) (de merge-pathname-defaults (pn defaults-pn default-type default-version) (setf pn (pathname pn)) (setf defaults-pn (pathname defaults-pn)) (setf pn (CopyVector pn)) (if (not (=> pn host)) (=> pn set-host (=> defaults-pn host))) (cond ((not (=> pn device)) (=> pn set-device (=> defaults-pn device)) (if (not (=> pn directory)) (=> pn set-directory (=> defaults-pn directory))) )) (cond ((not (=> pn name)) (=> pn set-name (=> defaults-pn name)) (if (not (=> pn type)) (=> pn set-type (=> defaults-pn type))) (if (not (=> pn version)) (=> pn set-version (=> defaults-pn version))) )) (if (not (=> pn type)) (=> pn set-type default-type)) (if (not (=> pn version)) (=> pn set-version default-version)) pn ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor pathname ((host "LOCAL") (device NIL) (directory NIL) (name NIL) (type NIL) (version NIL) ) () gettable-instance-variables ) (defmethod (pathname set-host) (new-host) (cond ((StringP new-host) (setf host (string-upcase new-host))) ((and (ListP new-host) (not (null new-host)) (StringP (car new-host))) (setf host (string-upcase (car new-host)))) (t (StdError "Invalid host specified for pathname.")) )) (defmethod (pathname set-device) (new-device) (cond ((StringP new-device) (setf device (string-upcase new-device))) ((null new-device) (setf device NIL)) ((and (ListP new-device) (StringP (car new-device))) (setf device (string-upcase (car new-device)))) ((and (IdP new-device) (or (eq new-device 'unspecific) (eq new-device 'wild))) (setf device new-device)) (t (StdError "Invalid device specified for pathname.")) )) (defmethod (pathname set-directory) (new-directory) (cond ((StringP new-directory) (setf directory (string-upcase new-directory))) ((null new-directory) (setf directory NIL)) ((and (ListP new-directory) (StringP (car new-directory))) (setf directory (string-upcase (car new-directory)))) ((and (IdP new-directory) (or (eq new-directory 'unspecific) (eq new-directory 'wild))) (setf directory new-directory)) (t (StdError "Invalid directory specified for pathname.")) )) (defmethod (pathname set-name) (new-name) (cond ((StringP new-name) (setf name (string-upcase new-name))) ((null new-name) (setf name NIL)) ((and (ListP new-name) (StringP (car new-name))) (setf name (string-upcase (car new-name)))) ((and (IdP new-name) (or (eq new-name 'unspecific) (eq new-name 'wild))) (setf name new-name)) (t (StdError "Invalid name specified for pathname.")) )) (defmethod (pathname set-type) (new-type) (cond ((StringP new-type) (setf type (string-upcase new-type))) ((null new-type) (setf type NIL)) ((and (IdP new-type) (or (eq new-type 'unspecific) (eq new-type 'wild))) (setf type new-type)) (t (StdError "Invalid type specified for pathname.")) )) (defmethod (pathname set-version) (new-version) (cond ((and (FixP new-version) (>= new-version 0)) (setf version new-version)) ((null new-version) (setf version NIL)) ((and (IdP new-version) (or (eq new-version 'unspecific) (eq new-version 'wild) (eq new-version 'newest) (eq new-version 'oldest) )) (setf version new-version)) (t (StdError "Invalid version specified for pathname.")) )) (de string-to-pathname (s) (let ((pn (make-instance 'pathname)) (i 0) j ch (len (string-length s)) (name-count 0) field ) (while (< i len) (setf j (pathname-bite s i)) (selectq (string-fetch s (- j 1)) (#\: (=> pn set-device (pathname-field-from-string (substring s i (- j 1))))) (#\> (=> pn set-directory (pathname-field-from-string (substring s (+ i 1) (- j 1))))) (#\. (setf name-count (+ name-count 1)) (setf field (substring s i (- j 1))) (selectq name-count (1 (=> pn set-name (pathname-field-from-string field)) (if (>= j len) (=> pn set-type 'UNSPECIFIC)) ) (2 (=> pn set-type (pathname-field-from-string field)) (if (>= j len) (=> pn set-version 'UNSPECIFIC)) ) (3 (=> pn set-version (pathname-version-from-string field))) )) (t (setf name-count (+ name-count 1)) (setf field (substring s i j)) (selectq name-count (1 (=> pn set-name (pathname-field-from-string field))) (2 (=> pn set-type (pathname-field-from-string field))) (3 (=> pn set-version (pathname-version-from-string field))) ))) (setf i j) ) pn )) (de pathname-bite (pn i) (let* ((len (string-length pn)) (ch (string-fetch pn i)) ) (cond ((= ch #\<) (setf i (+ i 1)) (while (< i len) (setf ch (string-fetch pn i)) (setf i (+ i 1)) (if (= ch #\>) (exit)) ) ) (t (while (< i len) (setf ch (string-fetch pn i)) (setf i (+ i 1)) (if (= ch #\:) (exit)) (if (= ch #\.) (exit)) ))) i )) (de pathname-field-from-string (s) (cond ((StringP s) (cond ((string-empty? s) 'UNSPECIFIC) ((string= s "*") 'WILD) (t s) )) (t s))) (de pathname-version-from-string (s) (cond ((StringP s) (cond ((string-empty? s) NIL) ((string= s "-2") 'OLDEST) ((string= s "0") 'NEWEST) ((string= s "*") 'WILD) ((string-is-integer s) (string2integer s)) (t s) )) (t s))) (de pathname-empty-field? (x) (string-empty? (pathname-field-to-string x)) ) (de pathname-field-to-string (x) (cond ((StringP x) x) ((eq x 'OLDEST) "-2") ((eq x 'NEWEST) "0") ((eq x 'UNSPECIFIC) "") ((eq x 'WILD) "*") ((null x) "") (t (BldMsg "%w" x)))) (de string-is-integer (s) (for (from i 0 (string-upper-bound s)) (always (DigitP (string-fetch s i))) )) |
Added psl-1983/3-1/util/20/processor-time.sl version [951a6316cb].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Processor-Time.SL (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (put 'hptim 'OpenCode '((jsys 8#501) (jfcl)))) (de processor-time () % Return accumulated processor time for the current process in microseconds. (WTimes2 (hptim 1) 10) ) |
Added psl-1983/3-1/util/20/wait.sl version [72cd54a7f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Wait.SL - Wait Primitive (TOPS-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (BothTimes (load jsys)) (de wait-timeout (f n-60ths) % Return when either of two conditions are met: (1) The function F (of no % arguments) returns non-NIL; (2) The specified elapsed time (in units of % 1/60th second) has elapsed. Don't waste CPU cycles! Return the last % value returned by F (which is always invoked at least once). (let (result) (while (and (not (setf result (apply f nil))) (> n-60ths 0)) (Jsys0 250 0 0 0 (const jsDISMS)) (setf n-60ths (- n-60ths 15)) ) result )) |
Added psl-1983/3-1/util/20/whereis.red version [c5dd0960bf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Scan the *.ins files % for a special Token Loadtime Load DIR!-STUFF$ InsList!*:=Vector2List GetCleanDir "<psl.util.ins>*.ins"$ Procedure ShowAllIns(); Begin scalar R,C,OldC; For each F in InsList!* do <<C:=OPEN(F,'input); OldC:=RDS C; R:=READ(); RDS OldC; Close C; Print F; Print R>>; End; Procedure LoadAllIns(); Begin scalar R,C,OldC; For each F in InsList!* do <<C:=OPEN(F,'input); OldC:=RDS C; R:=READ(); RDS OldC; Close C; For Each x in R do Put(x,'DefinedIn,F); PrintF(" %r loaded %n",F)>> End; Procedure WhereIs X; Begin scalar y; if(y:=get(x,'DefinedIn)) then Return y; if getd x then return "In The Kernel "; return NIL; end; |
Added psl-1983/3-1/util/addr2id.build version [1211fa62ca].
> | 1 | in "addr2id.sl"$ |
Added psl-1983/3-1/util/addr2id.sl version [c51be0ad85].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ADDR2ID.RED - Attempt to find out what function an address is in % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 May 1982 % Copyright (c) 1982 University of Utah % (compiletime (load syslisp useful)) (compiletime (fluid '(code-address* closest-address* closest-symbol*))) (de code-address-to-symbol (code-address*) (let ((closest-symbol* ()) (closest-address* 0)) (mapobl #'(lambda (symbol) (when (fcodep symbol) (let ((address (inf (getfcodepointer symbol)))) (when (and (ileq address code-address*) (igreaterp address closest-address*)) (setq closest-address* address) (setq closest-symbol* symbol)))))) closest-symbol*)) |
Added psl-1983/3-1/util/arith.build version [4c37efbac7].
> > | 1 2 | CompileTime load Syslisp; in "test-arith.red"$ |
Added psl-1983/3-1/util/association.build version [22d5876f89].
> | 1 | in "association.sl"$ |
Added psl-1983/3-1/util/association.sl version [086f16caf9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Association.SL - Mutable Association Lists % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 21 July 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common)) (defun association-create () % Create an empty association list (that is mutable!). (list (cons '*DUMMY* '*DUMMY*))) (defun association-bind (alist indicator value) % Change or extend the ALIST to map INDICATOR to VALUE. (let ((pair (atsoc indicator alist))) (if pair (rplacd pair value) % ELSE (aconc alist (cons indicator value)) (setq pair (car alist)) (if (and (eq (car pair) '*DUMMY*) (eq (cdr pair) '*DUMMY*)) (progn (rplacw pair (cadr alist)) (rplacd alist (cddr alist))) ) ))) (defun association-lookup (alist indicator) % Return the value attached to the given indicator (using EQ for % comparing indicators). If there is no attached value, return NIL. (let ((pair (atsoc indicator alist))) (if pair (cdr pair) NIL))) (defmacro map-over-association ((alist indicator-var value-var) . body) % Execute the body once for each indicator in the alist, binding % the specified indicator-var to the indicator and the specified % value-var to the attached value. Return the result of the body % (implicit PROGN). `(for (in ***PAIR*** ,alist) (with ***RESULT***) (do (let ((,indicator-var (car ***PAIR***)) (,value-var (cdr ***PAIR***)) ) (cond ((not (eq ,indicator-var '*DUMMY*)) (setf ***RESULT*** (progn ,@body)) )))) (returns ***RESULT***) )) |
Added psl-1983/3-1/util/backquote.sl version [34bbc4e7f6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BACKQUOTE.SL - tool for building partially quoted lists % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % Backquote is similar to MACLISP's ` (that's backwards!) mechanism. In % essence the body of the backquote is quoted, except for those things % surrounded by unquote, which are evaluated at macro expansion time. UNQUOTEL % splices in a list, and unquoted splices in a list destructively. Mostly % useful for defining macro's. (dm backquote (u) (backquote-form (cadr u))) (de backquote-form (u) (cond ((vectorp u) (backquote-vector u)) ((atom u) (cond ((and (idp u) (not (memq u '(t nil)))) (mkquote u)) (t u))) ((eq (car u) 'unquote) (cadr u)) ((eq (car u) 'backquote) (backquote-form (backquote-form (cadr u)))) ((memq (car u) '(unquotel unquoted)) (ContinuableError 99 (BldMsg "%r can't be spliced in here." u)) u) ((eqcar (car u) 'unquotel) (cond ((cdr u) (list 'append (cadar u) (backquote-form (cdr u)))) (t (cadar u)))) ((eqcar (car u) 'unquoted) (cond ((cdr u) (list 'nconc (cadar u) (backquote-form (cdr u)))) (t (cadar u)))) (t (backquote-list u)))) (de backquote-vector (u) ((lambda (n rslt all-quoted) % can't use LET 'cause it ain't defined yet ((lambda (i) (while (not (minusp i)) % can't use FOR or DO for the same reason ((lambda (x) (setq all-quoted (and all-quoted (backquote-constantp x))) (setq rslt (cons x rslt))) (backquote-form (getv u i))) (setq i (sub1 i)))) n) (cond (all-quoted ((lambda (i vec) (while (not (greaterp i n)) (putv vec i (backquote-constant-value (car rslt))) (setq rslt (cdr rslt)) (setq i (add1 i))) vec) 0 (mkvect n))) (t (cons 'vector rslt)))) (upbv u) nil t)) (de backquote-list (u) ((lambda (car-u cdr-u) % can't use LET 'cause it ain't defined yet (cond ((null cdr-u) (cond ((backquote-constantp car-u) (list 'quoted-list (backquote-constant-value car-u))) (t (list 'list car-u)))) ((constantp cdr-u) (cond ((backquote-constantp car-u) (list 'quoted-list* (backquote-constant-value car-u) cdr-u)) (t (list 'list* car-u cdr-u)))) ((and (pairp cdr-u) (memq (car cdr-u) '(list list*))) (cons (car cdr-u) (cons car-u (cdr cdr-u)))) ((and (pairp cdr-u) (memq (car cdr-u) '(quoted-list quoted-list*))) (cond ((backquote-constantp car-u) (cons (car cdr-u) (cons (backquote-constant-value car-u) (cdr cdr-u)))) (t (list 'list* car-u (mkquote (backquote-constant-value cdr-u)))))) ((eqcar cdr-u 'quote) (cond ((backquote-constantp car-u) (list 'quoted-list* (backquote-constant-value car-u) (cadr cdr-u))) (t (list 'list* car-u cdr-u)))) (t (list 'list* car-u cdr-u)))) (backquote-form (car u)) (backquote-form (cdr u)))) (de backquote-constantp (u) (cond ((pairp u) (memq (car u) '(quote quoted-list quoted-list*))) (t (not (idp u))))) (de backquote-constant-value (x) (cond ((eqcar x 'quote) (cadr x)) ((eqcar x 'quoted-list) (cdr x)) ((eqcar x 'quoted-list*) (cadr (apply 'quoted-list* (list x)))) (t x))) % The following, while possibly useful in themselves, are mostly included % for use by backquote and friends. (dm quoted-list (u) (mkquote (cdr u))) (dm list* (u) (expand (cdr u) 'cons)) (dm quoted-list* (u) (cond ((pairp (cdr u)) (setq u (reverse (cdr u))) ((lambda (a) (foreach elem in (cdr u) do (setq a (cons elem a))) (mkquote a)) (car u))))) % (t (error ... ? % Since unquote and friends should be completely stripped out by backquote, % make it an error to try and evaluate them. These could be much better... (dm unquote (u) (ContinuableError 99 (BldMsg "%r is not within backquote." u) u)) (copyd 'unquotel 'unquote) (copyd 'unquoted 'unquote) |
Added psl-1983/3-1/util/bigbig.build version [604e1ff956].
> > > > > > > > | 1 2 3 4 5 6 7 8 | % MLG, move BUILD info imports '(vector!-fix arith); Compiletime<<load syslisp; Load Fast!-Vector; load inum; load if!-system>>; in "bigbig.red"$ |
Added psl-1983/3-1/util/bigbig.red version [bb94f11108].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BIGBIG.RED - Vector based BIGNUM package with INUM operations % M. L. Griss & B Morrison % 25 June 1982. % % Revision log: % 20 Dec: % MLG, changed TrimBigNUM to TrimBigNum1 in BhardDivide % 14 Dec: % Changed by MLG to put LOAD and IMPORTS in BUILD file % A. C . Norman - adjstments to many routines! % in particular corrections to BHardDivide (case D6 utterly wrong), % and adjustments to BExpt (for performance) and all logical % operators (for treatment of negative inputs); % 31 August 1982: % Copyright (C) 1982, A. C. Norman, B. Morrison, M. Griss % --------------------------------------------------------------- % ----------------------- % A bignum will be a VECTOR of Bigits: (digits in base BigBase): % [BIGPOS b1 ... bn] or [BIGNEG b1 ... bn]. BigZero is thus [BIGPOS] % All numbers are positive, with BIGNEG as 0 element to indicate negatives. Fluid '(BBase!* BBits!* LogicalBits!* WordHi!* WordLow!* Digit2Letter!* FloatHi!* FloatLow!* SysHi!* SysLo!* Carry!* OutputBase!*); % -------------------------------------------------------------------------- % -------------------------------------------------------------------------- % Support functions: % % U, V, V1, V2 for arguments are Bignums. Other arguments are usually % fix/i-nums. lisp procedure setbits x; % % This function sets the globals for big bignum package. % "x" should be total # of bits per word. <<BBits!*:=iquotient(isub1 x,2); % Total number of bits per word used. BBase!*:=TwoPower BBits!*; % "Beta", where n=A0 + A1*beta + A2*(beta^2)... WordHi!*:=BNum Isub1 BBase!*; % Highest value of Ai WordLow!*:=BMinus WordHi!*; % Lowest value of Ai LogicalBits!*:=ISub1 BBase!*; % Used in LAnd,Lor, etc. SysHi!*:=bsub1 btwopower isub1 x; % Largest representable Syslisp integer. SysLo!*:=BMinus BAdd1 SysHi!*; % Smallest representable Syslisp integer. BBase!*>>; lisp procedure BignumP (V); VectorP V and ((V[0] eq 'BIGPOS) or (V[0] eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and UpbV V) or 0; lisp procedure GtPOS N; % Creates a positive Bignum with N "Bigits". Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return B; End; lisp procedure GtNeg N; % Creates a negative Bignum with N "Bigits". Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return B; End; lisp procedure TrimBigNum V3; % Truncate trailing 0. If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(V3,L3); % V3 is a bignum and L3 is the position in it of the highest % possible non-zero digit. Truncate V3 to remove leading zeros, % and if this leaves V3 totally zero make its sign positive; Begin While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop Bsize TruncateVector(V3,L3) then IPutV(V3,0,'BIGPOS); return V3; end; lisp procedure big2sys U; if BLessP(U, SysLo!*) or BGreaterP(U, SysHi!*) then Error(99,list(U," is too large to be a Syslisp integer for BIG2SYS")) else begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while not IZeroP I do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; lisp procedure TwoPower N; %fix/i-num 2**n 2**n; lisp procedure BTwoPower N; % gives 2**n; n is fix/i-num; result BigNum if not (fixp N or BignumP N) then NonIntegerError(N, 'BTwoPower) else begin scalar quot, rem, V; if bignump N then n:=big2sys n; quot:=Quotient(N,Bbits!*); rem:=Remainder(N,Bbits!*); V:=GtPOS(IAdd1 quot); IFor i:=1:quot do IPutV(v,i,0); IPutV(V,IAdd1 quot,twopower rem); return TrimBigNum1(V,IAdd1 quot); end; lisp procedure BZeroP V1; IZerop BSize V1 and not BMinusP V1; lisp procedure BOneP V1; Not BMinusP V1 and IOneP (BSize V1) and IOneP IGetV(V1,1); lisp procedure BAbs V1; if BMinusP V1 then BMinus V1 else V1; lisp procedure BMax(V1,V2); if BGreaterP(V2,V1) then V2 else V1; lisp procedure BMin(V1,V2); if BLessP(V2,V1) then V2 else V1; lisp procedure BExpt(V1,N); % V1 is Bignum, N is fix/i-num if not fixp N then NonIntegerError(N,'BEXPT) else if IZeroP N then int2B 1 else if IOneP N then V1 else if IMinusP N then BQuotient(int2B 1,BExpt(V1,IMinus N)) else begin scalar V2; V2 := BExpt(V1,IQuotient(N,2)); if IZeroP IRemainder(N,2) then return BTimes2(V2,V2) else return BTimes2(BTimes2(V2,V1),V2) end; % --------------------------------------- % Logical Operations % % All take Bignum arguments lisp procedure BLOr(V1,V2); % The main body of the OR code is only obeyed when both arguments % are positive, and so the result will be positive; if BMinusp V1 or BMinusp V2 then BLnot BLand(BLnot V1,BLnot V2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); Return V3 end; lisp procedure BLXor(V1,V2); % negative arguments are coped with using the identity % LXor(a,b) = LNot LXor(Lnot a,b) = LNor LXor(a,Lnot b); begin scalar L1,L2,L3,V3,S; if BMinusp V1 then << V1 := BLnot V1; S := t >>; if BMinusp V2 then << V2 := BLnot V2; S := not S >>; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILXor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); V1:=TrimBigNum1(V3,L1); if S then V1:=BLnot V1; return V1 end; % Not Used Currently: % % lisp Procedure BLDiff(V1,V2); % ***** STILL NEEDS ADJUSTING WRT -VE ARGS ***** % begin scalar V3,L1,L2; % L1:=BSize V1; % L2:=BSize V2; % V3:=GtPOS(max(L1,L2)); % IFor i:=1:min(L1,L2) do % IPutV(V3,i,ILAnd(IGetV(V1,i),ILXor(LogicalBits!*,IGetV(V2,i)))); % if IGreaterP(L1,L2) then IFor i:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,i)); % if IGreaterP(L2,L1) then IFor i:=(IAdd1 L1):L2 do IPutV(V3,i,0); % return TrimBigNum1(V3,max(L1,L2)); % end; lisp procedure BLAnd(V1,V2); % If both args are -ve the result will be too. Otherwise result will % be positive; if BMinusp V1 and BMinusp V2 then BLnot BLor(BLnot V1,BLnot v2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; L3:=Min(L1,L2); V3:=GtPOS L3; if BMinusp V1 then IFor I:=1:L3 do IPutV(V3,I,ILand(ILXor(Logicalbits!*,IGetV(V1,I)), IGetV(V2,I))) else if BMinusp V2 then IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I), ILXor(Logicalbits!*,IGetV(V2,I)))) else IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I),IGetV(V2,I))); return TrimBigNum1(V3,L3); End; lisp procedure BLNot(V1); BMinus BSmallAdd(V1,1); lisp procedure BLShift(V1,V2); % This seems a grimly inefficient way of doing things given that % the representation of big numbers uses a base that is a power of 2. % However it will do for now; if BMinusP V2 then BQuotient(V1, BTwoPower BMinus V2) else BTimes2(V1, BTwoPower V2); % ----------------------------------------- % Arithmetic Functions: % % U, V, V1, V2 are Bignum arguments. lisp procedure BMinus V1; % Negates V1. if BZeroP V1 then V1 else begin scalar L1,V2; L1:=BSize V1; if BMinusP V1 then V2 := GtPOS L1 else V2 := GtNEG L1; IFor I:=1:L1 do IPutV(V2,I,IGetV(V1,I)); return V2; end; % Returns V1 if V1 is strictly less than 0, NIL otherwise. % lisp procedure BMinusP V1; if (IGetV(V1,0) eq 'BIGNEG) then V1 else NIL; % To provide a conveninent ADD with CARRY. lisp procedure AddCarry A; begin scalar S; S:=IPlus2(A,Carry!*); if IGeq(S,BBase!*) then <<Carry!*:= 1; S:=IDifference(S,BBase!*)>> else Carry!*:=0; return S; end; lisp procedure BPlus2(V1,V2); begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if Sn1 and Not Sn2 then return BDifference2(V2,BMinus V1,Nil); if Sn2 and Not Sn1 then return BDifference2(V1,BMinus V2,Nil); return BPlusA2(V1,V2,Sn1); end; lisp procedure BPlusA2(V1,V2,Sn1); % Plus with signs pre-checked and begin scalar L1,L2,L3,V3,temp; % identical. L1:=BSize V1; L2:=BSize V2; If IGreaterP(L2,L1) then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; L3:=IAdd1 L1; If Sn1 then V3:=GtNeg L3 else V3:=GtPOS L3; Carry!*:=0; IFor I:=1:L2 do <<temp:=IPlus2(IGetV(V1,I),IGetV(V2,I)); IPutV(V3,I,AddCarry temp)>>; temp:=IAdd1 L2; IFor I:=temp:L1 do IPutV(V3,I,AddCarry IGetV(V1,I)); IPutV(V3,L3,Carry!*); % Carry Out Return TrimBigNum1(V3,L3); end; lisp procedure BDifference(V1,V2); if BZeroP V2 then V1 else if BZeroP V1 then BMinus V2 else begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if (Sn1 and Not Sn2) or (Sn2 and Not Sn1) then return BPlusA2(V1,BMinus V2,Sn1); return BDifference2(V1,V2,Sn1); end; lisp procedure SubCarry A; begin scalar S; S:=IDifference(A,Carry!*); if ILessP(S,0) then <<Carry!*:=1; S:=IPlus2(BBase!*,S)>> else Carry!*:=0; return S; end; Lisp procedure BDifference2(V1,V2,Sn1); % Signs pre-checked and identical. begin scalar i,L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3; Sn1:=not Sn1>> else if L1 Eq L2 then <<i:=L1; while (IGetV(V2,i) Eq IGetV(V1,i) and IGreaterP(i,1)) do i:=ISub1 i; if IGreaterP(IGetV(V2,i),IGetV(V1,i)) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3;Sn1:=not Sn1>> >>; if Sn1 then V3:=GtNEG L1 else V3:=GtPOS L1; carry!*:=0; IFor I:=1:L2 do IPutV(V3,I,SubCarry IDifference(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,I,SubCarry IGetV(V1,I)); return TrimBigNum1(V3,L1); end; lisp procedure BTimes2(V1,V2); begin scalar L1,L2,L3,Sn1,Sn2,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<V3:=V1; V1:=V2; V2:=V3; % If V1 is larger, will be fewer L3:=L1; L1:=L2; L2:=L3>>; % iterations of BDigitTimes2. L3:=IPlus2(L1,L2); Sn1:=BMinusP V1; Sn2:=BMinusP V2; If (Sn1 and Sn2) or not(Sn1 or Sn2) then V3:=GtPOS L3 else V3:=GtNEG L3; IFor I:=1:L3 do IPutV(V3,I,0); IFor I:=1:L2 do BDigitTimes2(V1,IGetV(V2,I),L1,I,V3); return TrimBigNum1(V3,L3); end; Lisp procedure BDigitTimes2(V1,V2,L1,I,V3); % V1 is a bignum, V2 a fixnum, L1=BSize L1, I=position of V2 in a bignum, % and V3 is bignum receiving result. I affects where in V3 the result of % a calculation goes; the relationship is that positions I:I+(L1-1) % of V3 receive the products of V2 and positions 1:L1 of V1. % V3 is changed as a side effect here. begin scalar J,carry,temp1,temp2; if zerop V2 then return V3 else << carry:=0; IFor H:=1:L1 do << temp1:=ITimes2(IGetV(V1,H),V2); temp2:=IPlus2(H,ISub1 I); J:=IPlus2(IPlus2(temp1,IGetV(V3,temp2)),carry); IPutV(V3,temp2,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IPutV(V3,IPlus2(L1,I),carry)>>; % carry should be < BBase!* here return V3; end; Lisp procedure BSmallTimes2(V1,C); % V1 is a BigNum, C a fixnum. % Assume C positive, ignore sign(V1) % also assume V1 neq 0. if ZeroP C then return GtPOS 0 % Only used from BHardDivide, BReadAdd. else begin scalar J,carry,L1,L2,L3,V3; L1:=BSize V1; L2:=IPlus2(IQuotient(C,BBase!*),L1); L3:=IAdd1 L2; V3:=GtPOS L3; carry:=0; IFor H:=1:L1 do << J:=IPlus2(ITimes2(IGetV(V1,H),C),carry); IPutV(V3,H,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IFor H:=(IAdd1 L1):L3 do << IPutV(V3,H,IRemainder(J:=carry,BBase!*)); carry:=IQuotient(J,BBase!*)>>; return TrimBigNum1(V3,L3); end; lisp procedure BQuotient(V1,V2); car BDivide(V1,V2); lisp procedure BRemainder(V1,V2); cdr BDivide(V1,V2); % BDivide returns a dotted pair, (Q . R). Q is the quotient and R is % the remainder. Both are bignums. R is of the same sign as V1. %; smacro procedure BSimpleQuotient(V1,L1,C,SnC); car BSimpleDivide(V1,L1,C,SnC); smacro procedure BSimpleRemainder(V1,L1,C,SnC); cdr BSimpleDivide(V1,L1,C,SnC); lisp procedure BDivide(V1,V2); begin scalar L1,L2,Q,R,V3; L2:=BSize V2; If IZerop L2 then error(99, "Attempt to divide by 0 in BDIVIDE"); L1:=BSize V1; If ILessP(L1,L2) or (L1 Eq L2 and ILessP(IGetV(V1,L1),IGetV(V2,L2))) % This also takes care of case then return (GtPOS 0 . V1); % when V1=0. if IOnep L2 then return BSimpleDivide(V1,L1,IGetV(V2,1),BMinusP V2); return BHardDivide(V1,L1,V2,L2); end; % C is a fixnum (inum?); V1 is a bignum and L1 is its length. % SnC is T if C (which is positive) should be considered negative. % Returns quotient . remainder; each is a bignum. % lisp procedure BSimpleDivide(V1,L1,C,SnC); begin scalar I,P,R,RR,Sn1,V2; Sn1:=BMinusP V1; if (Sn1 and SnC) or not(Sn1 or SnC) then V2:=GtPOS L1 else V2:=GtNEG L1; R:=0; I:=L1; While not IZeroP I do <<P:=IPlus2(ITimes2(R,BBase!*),IGetV(V1,I)); % Overflow. IPutV(V2,I,IQuotient(P, C)); R:=IRemainder(P, C); I:=ISub1 I>>; If Sn1 then RR:=GtNeg 1 else RR:=GtPOS 1; IPutV(RR,1,R); return (TrimBigNum1(V2,L1) . TrimBigNum1(RR,1)); end; lisp procedure BHardDivide(U,Lu,V,Lv); % This is an algorithm taken from Knuth. begin scalar U1,V1,A,D,LCV,LCV1,f,f2,J,K,Lq,carry,temp, LL,M,N,N1,P,Q,QBar,SnU,SnV,U2; N:=Lv; N1:=IAdd1 N; M:=IDifference(Lu,Lv); Lq:=IAdd1 M; % Deal with signs of inputs; SnU:=BMinusP U; SnV:=BMinusp V; % Note that these are not extra-boolean, i.e. % for positive numbers MBinusP returns nil, for % negative it returns its argument. Thus the % test (SnU=SnV) does not reliably compare the signs of % U and V; if SnU then if SnV then Q := GtPOS Lq else Q := GtNEG Lq else if SnV then Q := GtNEG Lq else Q := GtPOS Lq; U1 := GtPOS IAdd1 Lu; % U is ALWAYS stored as if one digit longer; % Compute a scale factor to normalize the long division; D:=IQuotient(BBase!*,IAdd1 IGetV(V,Lv)); % Now, at the same time, I remove the sign information from U and V % and scale them so that the leading coefficeint in V is fairly large; carry := 0; IFor i:=1:Lu do << temp := IPlus2(ITimes2(IGetV(U,I),D),carry); IPutV(U1,I,IRemainder(temp,BBase!*)); carry := IQuotient(temp,BBase!*) >>; Lu := IAdd1 Lu; IPutV(U1,Lu,carry); V1:=BSmallTimes2(V,D); % So far all variables contain safe values, % i.e. numbers < BBase!*; IPutV(V1,0,'BIGPOS); if ILessp(Lv,2) then NonBigNumError(V,'BHARDDIVIDE); % To be safe; LCV := IGetV(V1,Lv); LCV1 := IGetv(V1,ISub1 Lv); % Top two digits of the scaled V accessed once % here outside the main loop; % Now perform the main long division loop; IFor I:=0:M do << J:=IDifference(Lu,I); % J>K; working on U1[K:J] K:=IDifference(J,N1); % in this loop. A:=IGetV(U1,J); P := IPlus2(ITimes2(A,BBase!*),IGetv(U1,Isub1 J)); % N.B. P is up to 30 bits long. Take care! ; if A Eq LCV then QBar := ISub1 BBase!* else QBar := Iquotient(P,LCV); % approximate next digit; f:=ITimes2(QBar,LCV1); f2:=IPlus2(ITimes2(IDifference(P,ITimes2(QBar,LCV)),BBase!*), IGetV(U1,IDifference(J,2))); while IGreaterP(f,f2) do << % Correct most overshoots in Qbar; QBar:=ISub1 QBar; f:=IDifference(f,LCV1);; f2:=IPlus2(f2,ITimes2(LCV,BBase!*)) >>; carry := 0; % Ready to subtract QBar*V1 from U1; IFor L:=1:N do << temp := IPlus2( Idifference( IGetV(U1,IPlus2(K,L)), ITimes2(QBar,IGetV(V1,L))), carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusp temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,IPlus2(K,L),temp) >>; % Now propagate borrows up as far as they go; LL := IPlus2(K,N); while (not IZeroP carry) and ILessp(LL,J) do << LL := IAdd1 LL; temp := IPlus2(IGetV(U1,LL),carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusP temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,LL,temp) >>; if not IZerop carry then << % QBar was still wrong - correction step needed. % This should not happen very often; QBar := ISub1 QBar; % Add V1 back into U1; carry := 0; IFor L := 1:N do << carry := IPlus2( IPlus2(IGetV(U1,Iplus2(K,L)), IGetV(V1,L)), carry); IPutV(U1,IPlus2(K,L),IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >>; LL := IPlus2(K,N); while ILessp(LL,J) do << LL := IAdd1 LL; carry := IPlus2(IGetv(U1,LL),carry); IPutV(U1,LL,IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >> >>; IPutV(Q,IDifference(Lq,I),QBar) >>; % End of main loop; U1 := TrimBigNum1(U1,IDifference(Lu,M)); f := 0; f2 := 0; % Clean up potentially wild values; if not BZeroP U1 then << % Unnormalize the remainder by dividing by D if SnU then IPutV(U1,0,'BIGNEG); if not IOnep D then << Lu := BSize U1; carry := 0; IFor L:=Lu step -1 until 1 do << P := IPlus2(ITimes2(carry,BBase!*),IGetV(U1,L)); IPutv(U1,L,IQuotient(P,D)); carry := IRemainder(P,D) >>; P := 0; if not IZeroP carry then BHardBug("remainder when unscaling", U,V,TrimBigNum1(U1,Lu),TrimBigNum1(Q,Lq)); U1 := TrimBigNum1(U1,Lu) >> >>; Q := TrimBigNum1(Q,Lq); % In case leading digit happened to be zero; P := 0; % flush out a 30 bit number; % Here, for debugging purposes, I will try to validate the results I % have obtained by testing if Q*V+U1=U and 0<=U1<V. I Know this slows things % down, but I will remove it when my confidence has improved somewhat; % if not BZerop U1 then << % if (BMinusP U and not BMinusP U1) or % (BMinusP U1 and not BMinusP U) then % BHardBug("remainder has wrong sign",U,V,U1,Q) >>; % if not BAbs U1<BAbs V then BHardBug("remainder out of range",U,V,U1,Q) % else if not BZerop(BDifference(BPlus2(BTimes2(Q,V),U1),U)) then % BHardBug("quotient or remainder incorrect",U,V,U1,Q); return (Q . U1) end; lisp procedure BHardBug(msg,U,V,R,Q); % Because the inputs to BHardDivide are probably rather large, I am not % going to rely on BldMsg to display them; << Prin2T "***** Internal error in BHardDivide"; Prin2 "arg1="; Prin2T U; Prin2 "arg2="; Prin2T V; Prin2 "computed quotient="; Prin2T Q; Prin2 "computed remainder="; Prin2T R; StdError msg >>; lisp procedure BGreaterP(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(V,U) else nil else if BMinusP V then U else BUnsignedGreaterP(U,V); lisp procedure BLessp(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(U,V) else U else if BMinusP V then nil else BUnsignedGreaterP(V,U); lisp procedure BGeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(V,U) else nil else if BMinusP V then U else BUnsignedGeq(U,V); lisp procedure BLeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(U,V) else U else if BMinusP V then nil else BUnsignedGeq(V,U); lisp procedure BUnsignedGreaterP(U,V); % Compare magnitudes of two bignums; begin scalar Lu,Lv,I; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; if IGreaterP(IGetV(U,Lv),IGetV(V,Lv)) then return U else return nil end; symbolic procedure BUnsignedGeq(U,V); % Compare magnitudes of two unsigned bignums; begin scalar Lu,Lv; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; If IGreaterP(IGetV(V,Lv),IGetV(U,Lv)) then return nil else return U end; lisp procedure BAdd1 V; BSmallAdd(V,1); lisp procedure BSub1 U; BSmallDiff(U,1); % ------------------------------------------------ % Conversion to Float: lisp procedure FloatFromBigNum V; if BZeroP V then 0.0 else if BGreaterP(V, FloatHi!*) or BLessp(V, FloatLow!*) then Error(99,list("Argument, ",V," to FLOAT is too large")) else begin scalar L,Res,Sn,I; L:=BSize V; Sn:=BMinusP V; Res:=float IGetv(V,L); I:=ISub1 L; While not IZeroP I do << Res:=res*BBase!*; Res:=Res +IGetV(V,I); I:=ISub1 I>>; if Sn then Res:=minus res; return res; end; % ------------------------------------------------ % Input and Output: Digit2Letter!* := % Ascii values of digits and characters. '[48 49 50 51 52 53 54 55 56 57 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]; % OutputBase!* is assumed to be positive and less than 37. lisp procedure BChannelPrin2(Channel,V); If not BignumP V then NonBigNumError(V, 'BPrin) %need? else begin scalar quot, rem, div, result, resultsign, myobase; myobase:=OutputBase!*; resultsign:=BMinusP V; div:=BSimpleDivide(V,Bsize V,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result; while Not BZeroP quot do <<div:=BSimpleDivide(quot,Bsize quot,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result>>; if resultsign then channelwritechar(Channel,char !-); if myobase neq 10 then <<ChannelWriteSysInteger(channel,myobase,10); ChannelWriteChar(Channel, char !#)>>; For each u in result do ChannelWriteChar(Channel, IGetV(digit2letter!*,u)); OutputBase!*:=myobase; return; end; lisp procedure BRead(s,radix,sn); % radix is < Bbase!* %s=string of digits, radix=base, sn=1 or -1 begin scalar sz, res, ch; sz:=size s; res:=GtPOS 1; ch:=indx(s,0); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IPlus2(IDifference(ch,char A),10); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); IPutV(res,1,ch); IFor i:=1:sz do <<ch:=indx(s,i); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IDifference(ch,IDifference(char A,10)); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); res:=BReadAdd(res, radix, ch)>>; if iminusp sn then res:=BMinus res; return res; end; lisp procedure BReadAdd(V, radix, ch); << V:=BSmallTimes2(V, radix); V:=BSmallAdd(V,ch)>>; lisp procedure BSmallAdd(V,C); %V big, C fix. if IZerop C then return V else if Bzerop V then return int2B C else if BMinusp V then BMinus BSmallDiff(BMinus V, C) else if IMinusP C then BSmallDiff(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS(IAdd1 L1); IFor i:=1:L1 do IPutV(V1,i,addcarry IGetV(V,i)); if IOneP carry!* then IPutV(V1,IAdd1 L1,1) else return TrimBigNum1(V1,L1); return V1 end; lisp procedure BNum N; % temporary? Creates a Bignum of one digit, value N. begin scalar B; if IZerop n then return GtPOS 0 else if IMinusp N then <<b:=GtNEG 1; n:= IMinus n>> else b:=GtPos 1; IPutV(b,1,N); Return b; end; lisp procedure BSmallDiff(V,C); %V big, C fix if IZerop C then V else if BZeroP V then int2B IMinus C else if BMinusP V then BMinus BSmallAdd(BMinus V, C) else if IMinusP C then BSmallAdd(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS L1; IFor i:=1:L1 do IPuTV(V1,i,subcarry IGetV(V,i)); if not IZeroP carry!* then StdError BldMsg(" BSmallDiff V<C %p %p%n",V,C); return TrimBigNum1(V1,L1); end; lisp procedure int2B n; % Temporary? Creates BigNum of value N. if not fixp n then NonIntegerError(n, 'int2B) else if ILessP(n,Bbase!*) then BNum n else begin scalar Str,ind,rad,Sn,r; Str:=bldmsg("%w",n); % like an "int2string" if indx(str,0)=char '!- then <<Sn:=-1; str:=sub(str,1,ISub1 (size str))>> else Sn:=1; IFor i:=0:size str do if indx(str,i)=char '!# then ind:=i; if ind then <<r:=sub(str,0,ISub1 ind); rad:=0; IFor i:=0:size r do rad:=IPlus2(ITimes2(rad,10),IDifference(indx(r,i),char 0)); str:=sub(str,IAdd1 ind,IDifference(size str,IAdd1 ind))>> else rad:=10; return Bread(str,rad,sn); end; %----------------------------------------------------- % "Fix" for Bignums lisp procedure bigfromfloat X; if fixp x or bigp x then x else begin scalar bigpart,floatpart,power,sign,thispart; if minusp X then <<sign:=-1; X:=minus X>> else sign:=1; bigpart:=bnum 0; while neq(X, 0) and neq(x,0.0) do << if X < bbase!* then << bigpart:=bplus2(bigpart, bnum fix x); X:=0 >> else <<floatpart:=x; power:=0; while floatpart>=bbase!* do % get high end of number. <<floatpart:=floatpart/bbase!*; power:=power + bbits!* >>; thispart:=btimes2(btwopower power, bnum fix floatpart); X:=X- floatfrombignum thispart; bigpart:=bplus2(bigpart, thispart) >> >>; if minusp sign then bigpart := bminus bigpart; return bigpart; end; if_system(VAX, <<setbits 32; FloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. FloatLow!*:=BMinus FloatHi!*>>); if_system(PDP10, <<setbits 36; FloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); FloatLow!*:=BMinus FloatHi!*>>); % End of BIGBIG.RED ; |
Added psl-1983/3-1/util/bigface.build version [eea09281f5].
> | 1 | in "bigface.red"$ |
Added psl-1983/3-1/util/bigface.red version [429cbd5313].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. BIGFACE.RED - Bignum Interfacing % M.L. Griss and B Morrison % 25 June 1982 % -------------------------------------------------------------------------- % Revision History: % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman off usermode; % Use the BIGN tag for better Interface imports '(vector!-fix arith bigbig); compiletime<<load syslisp; load fast!-vector; load inum; load if!-system>>; on comp; fluid '(WordHi!* WordLow!* BBase!* FloatHi!* FloatLow!*); smacro procedure PutBig(b,i,val); IputV(b,i,val); smacro procedure GetBig(b,i); IgetV(B,i); % on syslisp; % % procedure BigP x; % Tag(x) eq BIGN; % % off syslisp; lisp procedure BignumP (V); BigP V and ((GetBig(V,0) eq 'BIGPOS) or (GetBig(V,0) eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and VecLen VecInf V) or 0; lisp procedure GtPOS N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return MkBigN Vecinf B; End; lisp procedure GtNeg N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return MkBigN VecInf B; End; lisp procedure TrimBigNum V3; % truncate trailing 0 If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; lisp procedure BigAsVec B; MkVec Inf B; lisp procedure VecAsBig V; MkBig Inf V; % -- Output--- if_system(VAX, <<setbits 32; FloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. FloatLow!*:=BMinus FloatHi!*>>); if_system(PDP10, <<setbits 36; FloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); FloatLow!*:=BMinus FloatHi!*>>); % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Lisp Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigNumP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Lisp Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigNumP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; lisp procedure big2sys U; begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while I neq 0 do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; smacro procedure checkifreallybig U; (lambda UU; % This construction needed to avoid repeated evaluation; if BLessP(UU, WordLow!*) or BGreaterp(UU,WordHi!*) then UU else sys2int big2sys UU)(U); smacro procedure checkifreallybigpair U; (lambda VV; checkifreallybig car VV . checkifreallybig cdr VV)(U); smacro procedure checkifreallybigornil U; (lambda UU; if Null UU or BLessp(UU, WordLow!*) or BGreaterP(UU,WordHi!*) then UU else sys2int big2sys UU)(U); lisp procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); lisp procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); lisp procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); lisp procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); lisp procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); lisp procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); lisp procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); lisp procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); lisp procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); lisp procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); lisp procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); lisp procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); lisp procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; lisp procedure BigSub1 U; CheckIfReallyBig BSub1 U; lisp procedure BigLNot U; CheckIfReallyBig BLNot U; lisp procedure BigMinus U; CheckIfReallyBig BMinus U; lisp procedure FloatBigArg U; FloatFromBigNum U; lisp procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; % ---- Input ---- lisp procedure MakeStringIntoLispInteger(Str,Radix,Sn); CheckIfReallyBig BRead(Str,Radix,Sn); % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure floatfix U; if U < BBase!* then OldFloatFix U else bigfromfloat U; copyd('oldMakeFixNum, 'MakeFixNum); procedure MakeFixNum N; % temporary; check range? Begin; n:=oldMakeFixNum N; return int2b N; end; syslsp procedure StaticIntBig Arg; % Convert an INT to a BIG int2b Arg; syslsp procedure StaticBigFloat Arg; % Convert a BigNum to a FLOAT; FloatFromBignum Arg; copyd('oldInt2Sys, 'Int2Sys); procedure Int2Sys N; if BigP N then Big2Sys N else OldInt2Sys n; on syslisp; syslsp procedure IsInum U; U < lispvar bbase!* and U > minus lispvar bbase!*; off syslisp; on usermode; |
Added psl-1983/3-1/util/bind-macros.sl version [124e1f6a59].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BIND-MACROS.SL - convenient macros for binding variables % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>BIND-MACROS.SL.2, 18-Oct-82 14:31:17, Edit by BENSON % Reversed vars and vals after collecting them in LET, so that the order % of things in the LAMBDA is the same as the LET. Not necessary, % but it makes it easier to follow macroexpanded things. (defmacro prog1 (first . body) (if (null body) first `((lambda (***PROG1-VAR***) ,@body ***PROG1-VAR***) ,first))) (defmacro let (specs . body) (if (null specs) (cond ((null body) nil) ((and (pairp body) (null (cdr body))) (car body)) (t `(progn ,@body))) (prog (vars vals) (foreach U in specs do (cond ((atom U) (setq vars (cons U vars)) (setq vals (cons nil vals))) (t (setq vars (cons (car U) vars)) (setq vals (cons (and (cdr U) (cadr U)) vals))))) (return `((lambda ,(reversip vars) ,@body ) ,@(reversip vals)))))) (defmacro let* (specs . body) (if (null specs) (cond ((null body) nil) ((and (pairp body) (null (cdr body))) (car body)) (t `(progn ,@body))) (let*1 specs body))) (de let*1 (specs body) (let ((s (car specs))(specs (cdr specs))) `((lambda (,(if (atom s) s (car s))) ,@(if specs (list (let*1 specs body)) body)) ,(if (and (pairp s) (cdr s)) (cadr s) nil)))) |
Added psl-1983/3-1/util/br-unbr.red version [0cb6fae3c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Just stuff for BR and UNBR from MINI-TRACE.RED %%% This code also appears in MINI-TRACE.RED %%% Cris Perdue %%% 1/6/83 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % <PSL.UTIL>BR-UNBR.RED.2, 19-Jan-83 13:29:43, Edit by PERDUE % Fixed problem with the value returned from a broken function fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb, Ans; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Ans := Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, Ans); TrSpace!* := TrSpace!* - 1; return Ans end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; for each X in L do Br!.1 X; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; END; |
Added psl-1983/3-1/util/build.build version [a161cd3bd8].
> > | 1 2 | CompileTime load(If!-System, Syslisp); in "build.red"$ |
Added psl-1983/3-1/util/build.mic version [d09ab69281].
> > > > > > > | 1 2 3 4 5 6 7 | get PSL:RLISP.EXE START load Build; BuildFileFormat!* := "%w"; Build '''A; quit; RESET . |
Added psl-1983/3-1/util/build.red version [ed1003e831].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BUILD.RED - Compile a module from .BUILD or .RED file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 March 1982 % Copyright (c) 1982 University of Utah % % Edit by MLG, 9 April 1983 % added MakeBuildFilename, and ERRSET, so Build more robust % and more like Compile-file. Also turned off break, % and do closing FASLEND in case of error. % Edit by Cris Perdue, 23 Mar 1983 0856-PST % Added BuildFileFormat for Apollo as requested by Kessler % 07-Mar-83 Nancy Kendzierski % Added load if-system, since many .build files use the if_system macro. % 09-Feb-83 MLG % Changed Buildformat to use $pl/ % <PSL.UTIL>BUILD.RED.3, 1-Dec-82 16:12:33, Edit by BENSON % Added if_system(HP9836, ... ) Compiletime load if!-system; Imports '(If!-system); % useful for most "built" systems fluid '(!*quiet_faslout % turns off welcome message in faslout !*Lower % lowercase ids on output !*UserMode % query on redefinition BuildFileFormat!* ); if_system(Tops20, BuildFileFormat!* := "pl:%w"); if_system(Unix, BuildFileFormat!* := "$pl/%w"); if_system(HP9836, BuildFileFormat!* := "pl:%w"); if_system(Apollo, BuildFileFormat!* := "~p/l/%w"); Lisp Procedure MakeBuildFileName(ModuleName,ExtList); % Try to construct Filename form Modulename Begin scalar y; If Null ExtList then return StdError BldMsg("Cant find a complete filename for %r",ModuleName); If FileP(y:=BldMsg("%w.%w",ModuleName,car Extlist)) then return <<ErrorPrintF("--- Building %w%n",Y); Y>>; Return MakeBuildFileName(ModuleName,Cdr ExtList); End; lisp procedure Build X; Begin scalar result; result:=Errset(BuildAux X, T); if fixp Result then <<if !*WritingFaslFile then faslend; Errorprintf("***** Error during build of %w%n",X)>>; End; Lisp Procedure BuildAux X; begin scalar !*UserMode, !*quiet_faslout,y,!*break,result; !*quiet_faslout := T; (lambda (!*Lower); << y:=MakeBuildFileName(X,'(build red sl)); faslout BldMsg(BuildFileFormat!*, X) >>)(T); EvIn list y; % Examines .RED, .SL FaslEnd; end; END; |
Added psl-1983/3-1/util/chars.build version [8522132837].
> > > > > | 1 2 3 4 5 | CompileTime << load(Useful, CLComp); put('Space, 'CharConst, 32); % temporary patch >>; in "chars.lsp"$ |
Added psl-1983/3-1/util/chars.lsp version [d50a4c91f4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; CHARS.LSP - Common Lisp operations on characters ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 7 April 1982 ;;; Copyright (c) 1982 University of Utah ;;; ; <PSL.UTIL>CHARS.LSP.4, 2-Sep-82 14:22:45, Edit by BENSON ; Fixed bug in CHAR-UPCASE and CHAR-DOWNCASE (defvar char-code-limit 128 "Upper bound of character code values") (defvar char-font-limit 1 "Upper bound on supported fonts") (defvar char-bits-limit 1 "Upper bound on values produces by char-bits") ;;;; STANDARD-CHARP - ASCII definition (defun standard-charp (c) (and (characterp c) (or (not (or (char< c #\Space) (char> c #\Rubout))) (eq c #\Eol) (eq c #\Tab) (eq c #\FF)))) ;;;; GRAPHICP - printable character (defun graphicp (c) (and (characterp c) (not (char< c #\Space)) (char< c #\Rubout))) ;;;; STRING-CHARP - a character that can be an element of a string (defun string-charp (c) (and (characterp c) (>= (char-int c) 0) (<= (char-int c) #\Rubout))) ;;;; ALPHAP - an alphabetic character (defun alphap (c) (or (uppercasep c) (lowercasep c))) ;;;; UPPERCASEP - an uppercase letter (defun uppercasep (c) (and (characterp c) (not (char< c #\A)) (not (char> c #\Z)))) ;;;; LOWERCASEP - a lowercase letter (defun lowercasep (c) (and (characterp c) (not (char< c #\\a)) (not (char> c #\\z)))) ;;;; BOTHCASEP - same as ALPHAP (fset 'bothcasep (fsymeval 'alphap)) ;;;; DIGITP - a digit character (optional radix not supported) (defun digitp (c) (when (and (characterp c) (not (char< c #\0)) (not (char> c #\9))) (- (char-int c) (char-int #\0)))) ;;;; ALPHANUMERICP - a digit or an alphabetic (defun alphanumericp (c) (or (alphap c) (digitp c))) ;;;; CHAR= - strict character comparison (defun char= (c1 c2) (eql (char-int c1) (char-int c2))) ;;;; CHAR-EQUAL - similar character objects (defun char-equal (c1 c2) (or (char= c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (eql (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR< - strict character comparison (defun char< (c1 c2) (< (char-int c1) (char-int c2))) ;;;; CHAR> - strict character comparison (defun char> (c1 c2) (> (char-int c1) (char-int c2))) ;;;; CHAR-LESSP - ignore case and bits for CHAR< (defun char-lessp (c1 c2) (or (char< c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (< (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR-GREATERP - ignore case and bits for CHAR> (defun char-greaterp (c1 c2) (or (char> c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (> (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR-CODE - character to integer conversion (defmacro char-code (c) c) ;;;; CHAR-BITS - bits attribute of a character (defmacro char-bits (c) 0) ;;;; CHAR-FONT - font attribute of a character (defmacro char-font (c) 0) ;;;; CODE-CHAR - integer to character conversion, optional bits, font ignored (defmacro code-char (c) c) ;;;; CHARACTER - character plus bits and font, which are ignored (defun character (c) (cond ((characterp c) c) ((stringp c) (char c 0)) ((symbolp c) (char (get-pname c) 0)) (t (stderror (bldmsg "%r cannot be coerced to a character" c))))) ;;;; CHAR-UPCASE - raise a character (defun char-upcase (c) (if (not (or (char< c #\\a) (char> c #\\z))) (int-char (+ (char-int #\A) (- (char-int c) (char-int #\\a)))) c)) ;;;; CHAR-DOWNCASE - lower a character (defun char-downcase (c) (if (not (or (char< c #\A) (char> c #\Z))) (int-char (+ (char-int #\\a) (- (char-int c) (char-int #\A)))) c)) ;;;; DIGIT-CHAR - convert character to digit (optional radix, bits, font NYI) (defun digit-char (i) (when (and (>= i 0) (<= i 10)) (int-char (+ (char-int #\0) i)))) ;;;; CHAR-INT - convert character to integer (defmacro char-int (c) ;; Identity operation in PSL c) ;;;; INT-CHAR - convert integer to character (defmacro int-char (c) ;; Identity operation in PSL c) |
Added psl-1983/3-1/util/clcomp1.build version [8772d10010].
> > > > > | 1 2 3 4 5 | CompileTime << load Useful, Common; off UserMode; >>; in "clcomp1.sl"$ |
Added psl-1983/3-1/util/clcomp1.sl version [a24dac532a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CLCOMP.SL - Incompatible Common Lisp compatibility % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 April 1982 % Copyright (c) 1982 University of Utah % % These are Common Lisp compatiblity definitions that cause Standard Lisp % to break. Changes character definitions and redefines functions. (imports '(useful common fast-vector)) (defmacro prog2 (first second . others) `(progn ,first (prog1 ,second ,@others))) (remprop 'prog2 'compfn) (defun char (s i) (igets s i)) (put 'char 'cmacro '(lambda (s i) (igets s i))) % NTH is a problem, hasn't been dealt with yet % Also MAP functions... (comment "make backslash the escape character") (setf IDEscapeChar* #\!\) (setf (elt lispscantable* #\!\) 14) (comment "Make percent a letter") (setf (elt lispscantable* #\!%) 10) (comment "Make semicolon start comments") (setf (elt lispscantable* #\;) 12) (comment "make bang a letter") (setf (elt lispscantable* #\!!) 10) (comment "Make colon the package character") (setf PackageCharacter* #\:) (setf (elt lispscantable* #\:) 16) (comment "Add vertical bars for reading IDs") (setf (elt lispscantable* #\|) 21) (comment "#M and #Q mean if_maclisp and if_lispm") (defun throw-away-next-form (channel qt) (ChannelReadTokenWithHooks channel) (ChannelReadTokenWithHooks channel)) (put '!#M 'LispReadMacro 'throw-away-next-form) (put '!#Q 'LispReadMacro 'throw-away-next-form) (push '(M . !#M) (get '!# (getv LispScanTable* 128))) (push '(Q . !#Q) (get '!# (getv LispScanTable* 128))) (comment "So we can add #+psl to maclisp code") (push 'psl system_list*) |
Added psl-1983/3-1/util/common.build version [82e48c324b].
> > > > > | 1 2 3 4 5 | CompileTime << load Useful; off UserMode; >>; in "common.sl"$ |
Added psl-1983/3-1/util/common.sl version [0e2abee702].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMMON.SL - Compile- and read-time support for Common Lisp compatibility. % In a few cases, actually LISP Machine Lisp compatibility? % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 31 March 1982 % Copyright (c) 1982 University of Utah % % Edit by Lon Willett, 24 May 1984 % Fixed bug in MakUnBound and FMakUnBound (misplaced parens) % % Edit by Cris Perdue, 7 Mar 1983 1335-PST % Left-expand is now available outside this module. (No longer flagged % as internalfunction.) % Edit by Cris Perdue, 4 Feb 1983 1047-PST % Removed ERRSET (redundant and not COMMON Lisp) and MOD (incorrect). % <PSL.UTIL.NEWVERSIONS>COMMON.SL.2, 13-Dec-82 21:30:58, Edit by GALWAY % Fixed bugs in copylist and copyalist that copied the first element % twice. Also fixed bug in copyalist where it failed to copy first pair % in the list. % Also started commenting the functions defined here. % These are only the Common Lisp definitions that do not conflict with % Standard Lisp or other PSL functions. Currently growing on a daily basis (imports '(useful fast-vector)) (compiletime (defmacro cl-alias (sl-name cl-name) `(defmacro ,cl-name form `(,',sl-name . ,form))) (flag '(expand-funcall* butlast-aux nbutlast-aux left-expand-aux) 'internalfunction) ) (cl-alias de defun) (defmacro defvar (name . other) (if *defn (fluid (list name))) (if (atom other) `(fluid `(,',name)) `(progn (fluid `(,',name)) (setq ,name ,(car other))))) (cl-alias idp symbolp) (cl-alias pairp consp) (defun listp (x) (or (null x) (consp x))) (put 'listp 'cmacro '(lambda (x) ((lambda (y) (or (null y) (consp y))) x))) (cl-alias fixp integerp) (cl-alias fixp characterp) (put 'characterp 'cmacro '(lambda (x) (posintp x))) (cl-alias vectorp arrayp) (cl-alias codep subrp) (defun functionp (x) (or (symbolp x) (codep x) (and (consp x) (eq (car x) 'lambda)))) (cl-alias eqn eql) (cl-alias equal equalp) (cl-alias valuecell symeval) (defmacro fsymeval (symbol) `((lambda (***fsymeval***) (or (cdr (getd ***fsymeval***)) (stderror (bldmsg "%r has no function definition" ***fsymeval***)))) ,symbol)) (defmacro boundp (name) `(not (unboundp ,name))) (defmacro fboundp (name) `(not (funboundp ,name))) (defmacro macro-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'macro)) (cdr y) nil))) (defmacro special-form-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'fexpr)) (cdr y) nil))) (defmacro fset (symbol value) `(putd ,symbol 'expr ,value)) (defmacro makunbound (x) `(let ((y ,x)) (makunbound y) y)) (defmacro fmakunbound (x) `(let ((y ,x)) (remd y) y)) (defmacro funcall* (fn . args) `(apply ,fn ,(expand-funcall* args))) (defun expand-funcall* (args) (if (null (cdr args)) (car args) `(cons ,(car args) ,(expand-funcall* (cdr args))))) (cl-alias funcall* lexpr-funcall) % only works when calls are compiled right now % need to make a separate special form and compiler macro prop. (defmacro progv (symbols values . body) `(let ((***bindmark*** (captureenvironment))) (do ((symbols ,symbols (cdr symbols)) (values ,values (cdr values))) ((null symbols) nil) (lbind1 (car symbols) (car values))) (prog1 (progn ,@body) (restoreenvironment ***bindmark***)))) (defmacro dolist (bindspec . progbody) `(prog (***do-list*** ,(first bindspec)) (setq ***do-list*** ,(second bindspec)) $loop$ (if (null ***do-list***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (car ***do-list***)) ,@progbody (setq ***do-list*** (cdr ***do-list***)) (go $loop$))) (defmacro dotimes (bindspec . progbody) `(prog (***do-times*** ,(first bindspec)) (setq ,(first bindspec) 0) (setq ***do-times*** ,(second bindspec)) $loop$ (if (= ,(first bindspec) ***do-times***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (+ ,(first bindspec) 1)) ,@progbody (go $loop$))) (cl-alias map mapl) % neither PROG or PROG* supports initialization yet (cl-alias prog prog*) (cl-alias dm macro) % DECLARE, LOCALLY ignored now (defmacro declare forms ()) (defmacro locally forms `(let () ,forms)) % version of THE which does nothing (defmacro the (type form) form) (cl-alias get getpr) (cl-alias put putpr) (cl-alias remprop rempr) (cl-alias prop plist) (cl-alias id2string get-pname) (defun samepnamep (x y) (equal (get-pname x) (get-pname y))) (cl-alias newid make-symbol) (cl-alias internp internedp) (defun plusp (x) (and (not (minusp x)) (not (zerop x)))) (defun oddp (x) (and (integerp x) (equal (remainder x 2) 1))) (defun evenp (x) (and (integerp x) (equal (remainder x 2) 0))) (cl-alias eqn =) (cl-alias lessp <) (cl-alias greaterp >) (cl-alias leq <=) (cl-alias geq >=) (cl-alias neq /=) (cl-alias plus +) (defmacro - args (cond ((null (cdr args)) `(minus ,@args)) ((null (cddr args)) `(difference ,@args)) (t (left-expand args 'difference)))) (cl-alias times *) (defmacro / args (cond ((null (cdr args)) `(recip ,(car args))) ((null (cddr args)) `(quotient ,@args)) (t (left-expand args 'quotient)))) (defun left-expand (arglist op) (left-expand-aux `(,op ,(first arglist) ,(second arglist)) (rest (rest arglist)) op)) (defun left-expand-aux (newform arglist op) (if (null arglist) newform (left-expand-aux `(,op ,newform ,(first arglist)) (rest arglist) op))) (cl-alias add1 !1+) (cl-alias sub1 !1-) (cl-alias incr incf) (cl-alias decr decf) (defmacro logior args (robustexpand args 'lor 0)) (defmacro logxor args (robustexpand args 'lxor 0)) (defmacro logand args (robustexpand args 'land -1)) (cl-alias lnot lognot) (cl-alias lshift ash) (put 'ldb 'assign-op 'dpb) % Not defined, but used in NSTRUCT (put 'rplachar 'cmacro '(lambda (s i x) (iputs s i x))) (put 'char-int 'cmacro '(lambda (x) x)) (put 'int-char 'cmacro '(lambda (x) x)) (put 'char= 'cmacro '(lambda (x y) (eq x y))) (put 'char< 'cmacro '(lambda (x y) (ilessp x y))) (put 'char> 'cmacro '(lambda (x y) (igreaterp x y))) (cl-alias indx elt) (cl-alias setindx setelt) (defun copyseq (seq) (subseq seq 0 (+ (size seq) 1))) (defun endp (x) (cond ((consp x) ()) ((null x) t) (t (stderror (bldmsg "%r is not null at end of list" x))))) (cl-alias length list-length) (cl-alias reversip nreverse) (cl-alias getv vref) (cl-alias putv vset) (put 'string= 'cmacro '(lambda (x y) (eqstr x y))) (put 'string-length 'cmacro '(lambda (x) (iadd1 (isizes x)))) (put 'string-to-list 'cmacro '(lambda (x) (string2list x))) (put 'list-to-string 'cmacro '(lambda (x) (list2string x))) (put 'string-to-vector 'cmacro '(lambda (x) (string2vector x))) (put 'vector-to-string 'cmacro '(lambda (x) (vector2string x))) (put 'substring 'cmacro '(lambda (s low high) (sub s low (idifference high (iadd1 low))))) (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (cl-alias copy copytree) (cl-alias pair pairlis) (put 'make-string 'cmacro '(lambda (i c) (mkstring (isub1 i) c))) (defmacro putprop (symbol value indicator) `(put ,symbol ,indicator ,value)) (defmacro defprop (symbol value indicator) `(putprop `,',symbol `,',value `,',indicator)) (defmacro eval-when (time . forms) (if *defn (progn (when (memq 'compile time) (evprogn forms)) (when (memq 'load time) `(progn ,@forms))) (when (memq 'eval time) `(progn ,@forms)))) % This name is already used by PSL /csp % (defmacro case tail % (cons 'selectq tail) % Selectq is actually a LISP Machine LISP name /csp (defmacro selectq (on . s-forms) (if (atom on) `(cond ,@(expand-select s-forms on)) `((lambda (***selectq-arg***) (cond ,@(expand-select s-forms '***selectq-arg***))) ,on))) (defun expand-select (s-forms formal) (cond ((null s-forms) ()) (t `((,(let ((selector (first (first s-forms)))) (cond ((consp selector) `(memq ,formal `,',selector)) ((memq selector '(otherwise t)) t) (t `(eq ,formal `,',selector)))) ,@(rest (first s-forms))) ,@(expand-select (rest s-forms) formal))))) (defmacro comment form ()) (defmacro special args `(fluid `,',args)) (defmacro unspecial args `(unfluid `,',args)) (cl-alias atsoc assq) (cl-alias lastpair last) (cl-alias flatsize2 flatc) (cl-alias explode2 explodec) % swapf, exchf ...? (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (defun tree-equal (x y) (if (atom x) (eql x y) (and (tree-equal (car x) (car y)) (tree-equal (cdr x) (cdr y))))) % Return a "top level copy" of a list. (defun copylist (x) (if (atom x) x (let* ((x1 (cons (car x) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (car x) ())) (setq x (cdr x)))))) % Return a copy of an a-list (copy down to the pairs but no deeper). (defun copyalist (x) (if (atom x) x (let* ((x1 (cons (cons (caar x) (cdar x)) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (cons (caar x) (cdar x)) ())) (setq x (cdr x)))))) (defun revappend (x y) (if (atom x) y (revappend (cdr x) (cons (car x) y)))) (defun nreconc (x y) (if (atom x) y (let ((z (cdr x))) (rplacd x y) (nreconc z x)))) (defun butlast (x) (if (or (atom x) (atom (cdr x))) x (butlast-aux x ()))) (defun butlast-aux (x y) (let ((z (cons (car x) y))) (if (atom (cddr x)) z (butlast-aux (cdr x) z)))) (defun nbutlast (x) (if (or (atom x) (atom (cdr x))) x (do ((y x (cdr y))) ((atom (cddr y)) (rplacd y ()))) x)) (defun buttail (list sublist) (if (atom list) list (let ((list1 (cons (car list) ()))) (setq list (cdr list)) (do ((list2 list1 (cdr list2))) ((or (atom list) (eq list sublist)) list1) (rplacd list2 (cons (car list) ())) (setq list (cdr list)))))) (cl-alias substip nsubst) (defmacro ouch (char . maybe-channel) (if maybe-channel `(channelwritechar ,(car maybe-channel) ,char) `(writechar ,char))) (defmacro inch maybe-channel (if maybe-channel `(channelreadchar ,(car maybe-channel)) `(readchar))) (defmacro uninch (char . maybe-channel) (if maybe-channel `(channelunreadchar ,(car maybe-channel) ,char) `(unreadchar ,char))) |
Added psl-1983/3-1/util/cond-macros.sl version [a955a45f26].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % COND-MACROS.SL - convenient macros for conditional expressions % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (defmacro if (predicate then . else) (cond ((null else) `(cond (,predicate ,then))) (t `(cond (,predicate ,then) (t . ,else))))) (defmacro xor (u v) % done this way to both "semi-open-code" but not repeat the code for either % arg; also evaluates args in the correct (left to right) order. `((lambda (***XOR-ARG***) (if ,v (not ***XOR-ARG***) ***XOR-ARG***)) ,u)) (defmacro when (p . c) `(cond (,p . ,c))) (defmacro unless (p . c) `(cond ((not ,p) . ,c))) |
Added psl-1983/3-1/util/datetime.build version [af688151a7].
> | 1 | in "datetime.red"$ |
Added psl-1983/3-1/util/datetime.red version [f082c98868].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAKE.RED % Will read in two directories and compare them for DATE and TIME % Segment a string into fields: Procedure SegmentString(S,ch); % "parse" string in pieces at CH Begin scalar s0,sN,sN1, Parts, sa,sb; s0:=0; sn:=Size(S); sN1:=sN+1; L1:If s0>sn then goto L2; sa:=NextNonCh(Ch,S,s0,sN); if sa>sN then goto L2; sb:=NextCh(Ch,S,sa+1,sN); if sb>SN1 then goto L2; Parts:=SubSeq(S,sa,sb) . Parts; s0:=sb; goto L1; L2:Return Reverse Parts; End; Procedure NextCh(Ch,S,s1,s2); <<While (S1<=S2) and not(S[S1] eq Ch) do s1:=s1+1; S1>>; Procedure NextNonCh(Ch,S,s1,s2); <<While (S1<=S2) and (S[S1] eq Ch) do s1:=s1+1; S1>>; Fluid '(Months!*); Months!*:='( ("JAN" . 1) ("FEB" . 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6) ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10) ("NOV" . 11) ("DEC" . 12) ("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12) ); Procedure Month2Integer m; cdr assoc(m,Months!*); Procedure DateTime2IntegerList(wdate,wtime); Begin Scalar V; V:=0; wdate:=SegmentString(wdate,char '!-); wtime:=SegmentString(wtime,char '!:); Rplaca(cdr WDate,Month2Integer Cadr Wdate); wdate:=MakeNumeric(wdate); wtime:=MakeNumeric(wtime); return append(wdate , wtime); end; procedure MakeNumeric(L); If null L then NIL else String2Integer(car L) . MakeNumeric(cdr L); procedure String2Integer S; if numberP s then s else if stringp s then MakeStringIntoLispInteger(s,10,1) else StdError "Non-string in String2Integer"; procedure CompareIntegerLists(L1,L2); % L1 <= L2 If Null L1 then T else if Null L2 then Nil else if Car L1 < Car L2 then T else if Car L1 > Car L2 then NIL else CompareIntegerLists(cdr L1, cdr L2); end; |
Added psl-1983/3-1/util/debug.build version [4bbf5ee989].
> | 1 | in "debug.red"$ |
Added psl-1983/3-1/util/debug.red version [5020e3ca8e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DEBUG.RED - General tracing capabilities % Norman and Morisson %--------- % Revision History: % <PSL.UTIL>DEBUG.RED.21, 4-Feb-83 13:01:05, Edit by OTHMER % Added Br - UnBr from Mini-Trace.Red % Added functions UnBrAll, UnTrAll % Added globals TracedFns!*, BrokenFns!* % Changed Restr to be a macro that can take a list of file names % as argument % Removed many lines of code that had been commented out % <PSL.UTIL>DEBUG.RED.20, 3-Feb-83 11:00:06, Edit by KESSLER % Remove fluid defintion of !*mode % Edit by Griss, 25 January 1983, fix !*MODE and DEFINEROP % for REDUCE % <PSL.NEW>DEBUG.RED.2, 29-Dec-82 15:28:13, Edit by PERDUE % In the fix of 12-december, changed > to !-greaterp % Also added a << >> pair to !-findentries % <PSL.UTIL>DEBUG.RED.16, 28-Dec-82 13:50:19, Edit by PERDUE % Added !-TRSTCOND to handle COND correctly % <PSL.UTIL>DEBUG.RED, 12-Dec-82 15:59:45, Edit by GRISS % Fixed printx to handle 0 SIZE (i.e. one-element) vectors CompileTime flag('(!-LPRIE !-LPRIM !-PAD !-IDLISTP !-CIRLIST !-FIRSTN !-LISTOFATOMS !-!-PUTD !-LABELNAME !-FINDENTRIES !-PRINTPASS !-PRINS !-TRGET !-TRGETX !-TRFLAGP !-TRPUT !-TRPUTX !-TRPUTX1 !-TRFLAG !-TRFLAG1 !-TRREMPROP !-TRREMPROPX !-TRREMFLAG !-TRREMFLAG1 !-TRINSTALL !-ARGNAMES !-TRRESTORE !-OUTRACE1 !-DUMPTRACEBUFF !-ERRAPPLY !-ENTERPRI !-EXITPRI !-TRINDENT !-TRACEPRI1 !-TRACENTRYPRI1 !-TRACEXPANDPRI !-MKTRST !-MKTRST1 !-BTRPUSH !-BTRPOP !-BTRDUMP !-EMBSUBST !-TR1 !-MKSTUB !-PLIST1 !-PPF1 !-GETC), 'InternalFunction); %********************* Implementation dependent procedures *********** fluid '(IgnoredInBacktrace!*); IgnoredInBacktrace!* := Append('(!-TRACEDCALL !-APPLY !-GET), IgnoredInBacktrace!*); %ON NOUUO; % Slow links PUTD('!-!%PROP,'EXPR,CDR GETD 'PROP); SYMBOLIC PROCEDURE !-GETPROPERTYLIST U; % U is an id. Returns a list of all the flags (id's) and property-values % (dotted pairs) of U. !-!%PROP U; %DEFINE !-GETPROPERTYLIST=!-!%CDR; % %PUTD('!-ATOM,'EXPR,CDR GETD 'ATOM); % % SYMBOLIC PROCEDURE !-ATOM U; % A safe version of ATOM. % !-!%PATOM U; % %DEFINE !-ATOM=!-!%PATOM; % %GLOBAL '(!*NOUUO); % CompileTime << SYMBOLIC SMACRO PROCEDURE !-SLOWLINKS; % Suppresses creation of fast-links % No-op in PSL NIL; >>; %****************************************************************** % Needs REDIO for sorting routine. If compiled without it only % the printing under the influence of COUNT will be affected. % I systematically use names starting with a '-' within this % package for internal routines that must not interfere with the % user. This means that the debug package may behave incorrectly % if user functions or variables have names starting with a '-'; %******************** Globals declarations ************************ GLOBAL '( % Boolean valued flags !*BTR % T -> stack traced function calls for backtrace !*BTRSAVE % T -> bactrace things which fail in errorsets !*INSTALL % T -> "install" trace info on all PUTD'd functions !*SAVENAMES % controlls saving of substructure names in PRINTX !*TRACE % T -> print trace information at run time !*TRACEALL % T -> trace all functions defined with PUTD !*TRSTEXPANDMACROS % T -> expand macros before embedding SETQs to print !*TRUNKNOWN % T -> never ask for the number of args !*TRCOUNT % T -> count # of invocations of traced functions % Other globals intended to be accessed outside of DEBUG !*MSG % BROKENFNS!* % List of functions that have been broken TRACEDFNS!* % List of functions that have been traced EMSG!* % ERFG!* % Reduce flag MSGCHNL!* % Channel to output trace information PPFPRINTER!* % Used by PPF to print function bodies PROPERTYPRINTER!* % Used by PLIST to print property values PUTDHOOK!* % User hook run after a successful PUTD STUBPRINTER!* % For printing arguments in calls on stubs STUBREADER!* % For reading the return value in calls on stubs TRACEMINLEVEL!* % Minimum recursive depth at which to trace TRACEMAXLEVEL!* % Maximum " " " " " " TRACENTRYHOOK!* % User hook into traced functions TRACEXITHOOK!* % " " " " " TRACEXPANDHOOK!* % " " " " " TREXPRINTER!* % Function used to print args/values in traced fns TRINSTALLHOOK!* % User hook called when a function is first traced TRPRINTER!* % Function used to print macro expansions % Globals principally for internal use !-ARBARGNAMES!* % List of ids to be used for unspecified names !-ARGINDENT!* % Number of spaces to indent when printing args !-BTRSAVEDINTERVALS!* % Saved BTR frames from within errorsets !-BTRSTK!* % Stack for bactrace info % !-COLONERRNUM!* % Error number used by failing :CAR,:CDR, etc. !-FUNCTIONFLAGS!* % Flags which PPF considers printing !-GLOBALNAMES!* % Used by PRINTX to store common substructure names !-INDENTCUTOFF!* % Furthest right to indent trace output !-INDENTDEPTH!* % Number of spaces to indent each level trace output !-INVISIBLEPROPS!* % Properties which PLIST should ignore !-INVISIBLEFLAGS!* % Flags which PLIST should ignore !-INSTALLEDFNS!* % Functions which have had information installed !-NONSTANDARDFNS!* % Properties under which special MACRO's are stored % !-SAFEFNSINSTALLED!* % T -> :CAR, etc have replaced CAR, etc !-TRACEBUFF!* % Ringbuffer to save recent trace output !-TRACECOUNT!* % Decremented -- if >0 it may suppresses tracing !-TRACEFLAG!* % Enables tracing ); FLUID '( !*COMP % Standard Lisp flag !*BACKTRACE % Reduce flag !*DEFN % Reduce flag !-ENTRYPOINTS!* % for PRINTX !-ORIGINALFN!* % fluid argument in EMBed function calls !-PRINTXCOUNT!* % Used by PRINTX for making up names for EQ structures !-TRINDENT!* % Current level of indentation of trace output !-VISITED!* % for PRINTX ); !*BTR := T; !*BTRSAVE := T; !*TRACE := T; !*TRCOUNT := T; !*TRSTEXPANDMACROS := T; !-ARBARGNAMES!* := '(A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15); !-ARGINDENT!* := 3; %!-COLONERRNUM!* := 993; % Any ideas of anything particularly appropriate? !-FUNCTIONFLAGS!* := '(EVAL IGNORE LOSE NOCHANGE EXPAND NOEXPAND OPFN DIRECT); !-INDENTCUTOFF!* := 12; !-INDENTDEPTH!* := 2; !-INVISIBLEPROPS!*:= '(TYPE !*LAMBDALINK); !-NONSTANDARDFNS!*:= '(SMACRO NMACRO CMACRO); !-TRACECOUNT!* := 0; !-TRINDENT!* := -1; % It's always incremented BEFORE use !-TRACEFLAG!* := T; !*MSG := T; PPFPRINTER!* := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT; PROPERTYPRINTER!* := IF GETD 'PRETTYPRINT THEN 'PRETTYPRINT ELSE 'PRINT; STUBPRINTER!* := 'PRINTX; STUBREADER!* := IF GETD 'XREAD THEN '!-REDREADER ELSE '!-READ; TRACEMAXLEVEL!* := 10000; % Essentially no limit TRACEMINLEVEL!* := 0; TREXPRINTER!* := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT; TRPRINTER!* := 'PRINTX; BrokenFns!* := Nil; TracedFns!* := Nil; % Let TRST know about the behaviour of some common FEXPRs FLAG('( % common FEXPRs which never pass back an unEVALed argument AND LIST MAX MIN OR PLUS PROGN REPEAT TIMES WHILE ),'TRSTINSIDE); DEFLIST ('( % special sorts of FEXPRs (LAMBDA !-TRSTPROG) % Not really a function, but handled by TRST as such (PROG !-TRSTPROG) (SETQ !-TRSTSETQ) (COND !-TRSTCOND) ),'TRSTINSIDEFN); %****************** Utility functions ******************************** % Copy the entrypoints of various key functions so that % nobody gets muddled by trying to trace or redefine them; PUTD('!-APPEND,'EXPR,CDR GETD 'APPEND); PUTD('!-APPLY,'EXPR,CDR GETD 'APPLY); PUTD('!-ATSOC,'EXPR,CDR GETD 'ATSOC); %PUTD('!-CAR,'EXPR,CDR GETD 'CAR); %PUTD('!-CDR,'EXPR,CDR GETD 'CDR); %PUTD('!-CODEP,'EXPR,CDR GETD 'CODEP); PUTD('!-COMPRESS,'EXPR,CDR GETD 'COMPRESS); %PUTD('!-CONS,'EXPR,CDR GETD 'CONS); PUTD('!-EQUAL,'EXPR,CDR GETD 'EQUAL); PUTD('!-ERRORSET,'EXPR,CDR GETD 'ERRORSET); PUTD('!-EVAL,'EXPR,CDR GETD 'EVAL); %PUTD('!-EVLIS,'EXPR,CDR GETD 'EVLIS); PUTD('!-EXPLODE,'EXPR,CDR GETD 'EXPLODE); PUTD('!-FLAG,'EXPR,CDR GETD 'FLAG); PUTD('!-FLAGP,'EXPR,CDR GETD 'FLAGP); PUTD('!-FLUID,'EXPR,CDR GETD 'FLUID); PUTD('!-GET,'EXPR,CDR GETD 'GET); PUTD('!-GETD,'EXPR,CDR GETD 'GETD); %PUTD('!-IDP,'EXPR,CDR GETD 'IDP); PUTD('!-INTERN,'EXPR,CDR GETD 'INTERN); PUTD('!-LENGTH,'EXPR,CDR GETD 'LENGTH); PUTD('!-MAX2,'EXPR,CDR GETD 'MAX2); PUTD('!-MEMQ,'EXPR,CDR GETD 'MEMQ); PUTD('!-MIN2,'EXPR,CDR GETD 'MIN2); PUTD('!-OPEN,'EXPR,CDR GETD 'OPEN); %PUTD('!-PATOM,'EXPR,CDR GETD 'PATOM); PUTD('!-PLUS2,'EXPR,CDR GETD 'PLUS2); PUTD('!-POSN,'EXPR,CDR GETD 'POSN); PUTD('!-PRIN1,'EXPR,CDR GETD 'PRIN1); PUTD('!-PRIN2,'EXPR,CDR GETD 'PRIN2); PUTD('!-PRINC,'EXPR,CDR GETD 'PRINC); PUTD('!-PRINT,'EXPR,CDR GETD 'PRINT); %PUTD('!-PROG,'FEXPR,CDR GETD 'PROG); PUTD('!-PUT,'EXPR,CDR GETD 'PUT); PUTD('!-PUTD,'EXPR,CDR GETD 'PUTD); PUTD('!-READ,'EXPR,CDR GETD 'READ); PUTD('!-REMD,'EXPR,CDR GETD 'REMD); PUTD('!-REMPROP,'EXPR,CDR GETD 'REMPROP); %PUTD('!-RETURN,'EXPR,CDR GETD 'RETURN); PUTD('!-REVERSE,'EXPR,CDR GETD 'REVERSE); %PUTD('!-RPLACA,'EXPR,CDR GETD 'RPLACA); %PUTD('!-RPLACD,'EXPR,CDR GETD 'RPLACD); PUTD('!-SET,'EXPR,CDR GETD 'SET); PUTD('!-TERPRI,'EXPR,CDR GETD 'TERPRI); PUTD('!-WRS,'EXPR,CDR GETD 'WRS); %PUTD('!-ZEROP,'EXPR,CDR GETD 'ZEROP); CompileTime << smacro procedure alias(x, y); macro procedure x u; 'y . cdr u; alias(!-DIFFERENCE, IDifference); alias(!-GREATERP, IGreaterP); alias(!-LESSP, ILessP); alias(!-SUB1, ISub1); alias(!-TIMES2, ITimes2); load Fast!-Vector; alias(!-GETV, IGetV); alias(!-UPBV, ISizeV); %alias(!-ADD1, IAdd1); put('!-add1, 'cmacro , '(lambda (x) (iadd1 x))); >>; lisp procedure !-ADD1 X; % because it gets called from EVAL IAdd1 X; SYMBOLIC PROCEDURE !-LPRIE U; << ERRORPRINTF("***** %L", U); ERFG!* := T >>; SYMBOLIC PROCEDURE !-LPRIM U; !*MSG AND ERRORPRINTF("*** %L", U); PUTD('!-REVERSIP, 'EXPR, CDR GETD 'REVERSIP); PUTD('!-MKQUOTE, 'EXPR, CDR GETD 'MKQUOTE); PUTD('!-EQCAR, 'EXPR, CDR GETD 'EQCAR); PUTD('!-SPACES, 'EXPR, CDR GETD 'SPACES); PUTD('!-SPACES2, 'EXPR, CDR GETD 'SPACES2); PUTD('!-PRIN2T, 'EXPR, CDR GETD 'PRIN2T); SYMBOLIC PROCEDURE !-PAD(L, N); IF FIXP N THEN IF N < !-LENGTH L THEN !-PAD(!-REVERSIP CDR !-REVERSE L, N) ELSE IF N > !-LENGTH L THEN !-PAD(!-APPEND(L, LIST NIL), N) ELSE L ELSE REDERR "!-PAD given nonintegral second arg"; SYMBOLIC PROCEDURE !-IDLISTP L; NULL L OR IDP CAR L AND !-IDLISTP CDR L; SYMBOLIC PROCEDURE !-CIRLIST(U,N); % Returns a circular list consisting of N U's. BEGIN SCALAR A,B; IF NOT !-GREATERP(N,0) THEN RETURN NIL; B := A := U . NIL; FOR I := 2:N DO B := U . B; RETURN RPLACD(A,B) END !-CIRCLIST; SYMBOLIC PROCEDURE !-FIRSTN(N,L); IF N=0 THEN NIL ELSE IF NULL L THEN !-FIRSTN(N,LIST GENSYM()) ELSE CAR L . !-FIRSTN(!-DIFFERENCE(N,1),CDR L); SYMBOLIC PROCEDURE !-LISTOFATOMS L; IF NULL L THEN T ELSE IF IDP CAR L THEN !-LISTOFATOMS CDR L ELSE NIL; SYMBOLIC PROCEDURE !-!-PUTD(NAME,TYPE,BODY); % as PUTD but never compiles, and preserves TRACE property; BEGIN SCALAR COMP,SAVER,BOL; COMP:=!*COMP; % REMEMBER STATE OF !*COMP FLAG; !*COMP:=NIL; % TURN OFF COMPILATION; SAVER:=!-GET(NAME,'TRACE); BOL:=FLAGP(NAME,'LOSE); REMFLAG(LIST NAME,'LOSE); % IGNORE LOSE FLAG; !-REMD NAME; % TO MAKE THE NEXT PUTD QUIET EVEN IF I AM REDEFINING; BODY:=!-PUTD(NAME,TYPE,BODY); IF NOT NULL SAVER THEN !-PUT(NAME,'TRACE,SAVER); !*COMP:=COMP; % RESTORE COMPILATION FLAG; IF BOL THEN FLAG(LIST NAME,'LOSE); RETURN BODY END; %******* Routines for printing looped and shared structures ****** % % MAIN ENTRYPOINT: % % PRINTX (A) % % !-PRINTS THE LIST A. IF !*SAVENAMES IS TRUE CYCLES ARE PRESERVED % BETWEEN CALLS TO !-PRINTS; % PRINTX RETURNS NIL; %VARIABLES USED - % % !-ENTRYPOINTS!* ASSOCIATION LIST OF POINTS WHERE THE LIST % RE-ENTERS ITSELF. VALUE PART OF A-LIST ENTRY % IS NIL IF NODE HAS NOT YET BEEN GIVEN A NAME, % OTHERWISE IT IS THE NAME USED. % % !-VISITED!* LIST OF NODES THAT HAVE BEEN ENCOUNTERED DURING % CURRENT SCAN OF LIST % % !-GLOBALNAMES!* LIKE !-ENTRYPOINTS!*, BUT STAYS ACTIVE BETWEEN CALLS % TO PRINTX % % !-PRINTXCOUNT!* USED TO DECIDE ON A NAME FOR THE NEXT NODE; SYMBOLIC PROCEDURE !-LABELNAME(); BldMsg("%%L%W", !-PRINTXCOUNT!* := !-PLUS2(!-PRINTXCOUNT!*,1)); SYMBOLIC PROCEDURE !-FINDENTRIES A; IF NOT (PAIRP A OR VECTORP A) THEN NIL ELSE IF !-ATSOC(A,!-ENTRYPOINTS!*) THEN NIL ELSE IF !-MEMQ(A,!-VISITED!*) THEN !-ENTRYPOINTS!*:=(A . NIL) . !-ENTRYPOINTS!* ELSE << !-VISITED!*:=A . !-VISITED!*; IF VECTORP A THEN BEGIN SCALAR N, I; I := 0; N := !-UPBV A; WHILE NOT !-GREATERP(I, N) DO << !-FINDENTRIES !-GETV(A,I); I := !-ADD1 I >>; END ELSE << !-FINDENTRIES CAR A; !-FINDENTRIES CDR A >> >>; SYMBOLIC PROCEDURE !-PRINTPASS A; IF NOT (PAIRP A OR VECTORP A) THEN !-PRIN1 A ELSE BEGIN SCALAR W, N, I; IF !-GREATERP(!-POSN(),50) THEN !-TERPRI(); W:=!-ATSOC(A,!-ENTRYPOINTS!*); IF NULL W THEN GO TO ORDINARY; IF CDR W THEN RETURN !-PRIN2 CDR W; RPLACD(W,!-PRIN2 !-LABELNAME()); !-PRIN2 ": "; ORDINARY: IF VECTORP A THEN RETURN << N := !-UPBV A; !-PRINC '![; IF !-GREATERP(N,-1) THEN % perdue fix << !-PRINTPASS !-GETV(A, 0); I := 1; WHILE NOT !-GREATERP(I, N) DO << !-PRINC '! ; !-PRINTPASS !-GETV(A, I); I := !-ADD1 I >> >>; !-PRINC '!] >>; !-PRINC '!(; LOOP: !-PRINTPASS CAR A; A:=CDR A; IF NULL A THEN GOTO NILEND ELSE IF ATOM A THEN GO TO ATOMEND ELSE IF (W:=!-ATSOC(A,!-ENTRYPOINTS!*)) THEN GOTO LABELED; BLANKIT: !-PRINC '! ; GO TO LOOP; LABELED: IF CDR W THEN GOTO REFER; !-PRINC '! ; RPLACD(W,!-PRIN2 !-LABELNAME()); !-PRIN2 ", "; GO TO LOOP; REFER: !-PRIN2 " . "; !-PRIN2 CDR W; GO TO NILEND; ATOMEND: !-PRIN2 " . "; !-PRIN1 A; NILEND: !-PRINC '!); RETURN NIL END; SYMBOLIC PROCEDURE !-PRINS(A,L); BEGIN SCALAR !-VISITED!*,!-ENTRYPOINTS!*,!-PRINTXCOUNT!*; IF ATOM L THEN !-PRINTXCOUNT!*:=0 ELSE << !-PRINTXCOUNT!*:=CAR L; !-ENTRYPOINTS!*:=CDR L >>; !-FINDENTRIES A; !-PRINTPASS A; RETURN (!-PRINTXCOUNT!* . !-ENTRYPOINTS!*) END; SYMBOLIC PROCEDURE PRINTX A; <<IF !*SAVENAMES THEN !-GLOBALNAMES!*:=!-PRINS(A,!-GLOBALNAMES!*) ELSE !-PRINS(A,NIL); !-TERPRI(); NIL >>; %****************** Trace sub-property-list functions ****************** % The property TRACE is removed from any function that is subject % to definition or redefinition by PUTD, and so it represents % a good place to hide information about the function. The following % set of functions run a sub-property-list stored under this % indicator; SYMBOLIC PROCEDURE !-TRGET(ID,IND); !-TRGETX(!-GET(ID,'TRACE),IND); SYMBOLIC PROCEDURE !-TRGETX(L,IND); % L IS A 'PROPERTY LIST' AND IND IS AN INDICATOR; IF NULL L THEN NIL ELSE IF !-EQCAR(CAR L,IND) THEN CDAR L ELSE !-TRGETX(CDR L,IND); SYMBOLIC PROCEDURE !-TRFLAGP(ID,IND); !-MEMQ(IND,!-GET(ID,'TRACE)); SYMBOLIC PROCEDURE !-TRPUT(ID,IND,VAL); !-PUT(ID,'TRACE,!-TRPUTX(!-GET(ID,'TRACE),IND,VAL)); SYMBOLIC PROCEDURE !-TRPUTX(L,IND,VAL); IF !-TRPUTX1(L,IND,VAL) THEN L ELSE (IND . VAL) . L; SYMBOLIC PROCEDURE !-TRPUTX1(L,IND,VAL); BEGIN L: IF NULL L THEN RETURN NIL; IF !-EQCAR(CAR L,IND) THEN << RPLACD(CAR L,VAL); RETURN T >>; L := CDR L; GO TO L END; SYMBOLIC PROCEDURE !-TRFLAG(L,IND); FOR EACH ID IN L DO !-TRFLAG1(ID,IND); SYMBOLIC PROCEDURE !-TRFLAG1(ID,IND); BEGIN SCALAR A; A:=!-GET(ID,'TRACE); IF NOT !-MEMQ(IND,A) THEN !-PUT(ID,'TRACE,IND . A) END; SYMBOLIC PROCEDURE !-TRREMPROP(ID,IND); << IND:=!-TRREMPROPX(!-GET(ID,'TRACE),IND); IF NULL IND THEN !-REMPROP(ID,'TRACE) ELSE !-PUT(ID,'TRACE,IND) >>; SYMBOLIC PROCEDURE !-TRREMPROPX(L,IND); IF NULL L THEN NIL ELSE IF !-EQCAR(CAR L,IND) THEN CDR L ELSE CAR L . !-TRREMPROPX(CDR L,IND); SYMBOLIC PROCEDURE !-TRREMFLAG(L,IND); FOR EACH ID IN L DO !-TRREMFLAG1(ID,IND); SYMBOLIC PROCEDURE !-TRREMFLAG1(ID,IND); << IND:=DELETE(IND,!-GET(ID,'TRACE)); IF NULL IND THEN !-REMPROP(ID,'TRACE) ELSE !-PUT(ID,'TRACE,IND) >>; %******************* Basic functions for TRACE and friends *********** SYMBOLIC PROCEDURE !-TRINSTALL(NAM,ARGNUM); % Sets up TRACE properties for function NAM. This is common to all TRACE-like % actions. Function NAM is redefined to dispatch through !-TRACEDCALL which % takes various actions (which may simply be to run the original function). % Important items stored under the TRACE property include ORIGINALFN, which is % the original definition, FNTYPE, the original function "type" (e.g. EXPR, % MACRO ...), and ARGNAMES, a list of the names of the arguments to NAM. % arguments to the function. Runs TRINSTALLHOOK!* if non-nil. Returns non-nil % if it succeeds, nil if for some reason it fails. BEGIN SCALAR DEFN,CNTR,ARGS,TYP; if Memq (Nam,BrokenFns!*) then << EvUnBr List Nam; BrokenFns!* := DelQ(Nam,BrokenFns!*) >>; DEFN := !-GETD NAM; IF NULL DEFN THEN << !-LPRIM LIST("Function",NAM,"is not defined."); RETURN NIL >>; TYP := CAR DEFN; DEFN := CDR DEFN; IF !-GET(NAM,'TRACE) THEN IF NUMBERP ARGNUM AND TYP EQ 'FEXPR AND !-TRGET(NAM,'FNTYPE) EQ 'EXPR THEN << TYP := 'EXPR; !-TRREMFLAG(LIST NAM,'UNKNOWNARGS); DEFN := !-TRGET(NAM,'ORIGINALFN) >> ELSE RETURN T ELSE IF TRINSTALLHOOK!* AND NOT !-ERRAPPLY(TRINSTALLHOOK!*,LIST NAM,'TRINSTALLHOOK) THEN RETURN NIL; !-TRPUT(NAM,'ORIGINALFN,DEFN); !-TRPUT(NAM,'FNTYPE,TYP); ARGS := !-ARGNAMES(NAM,DEFN,TYP,ARGNUM); IF ARGS EQ 'UNKNOWN THEN << !-TRPUT(NAM,'ARGNAMES,!-ARBARGNAMES!*); !-TRFLAG(LIST NAM,'UNKNOWNARGS) >> ELSE !-TRPUT(NAM,'ARGNAMES,ARGS); CNTR := GENSYM(); !-FLUID LIST CNTR; !-TRPUT(NAM,'LEVELVAR,CNTR); !-SET(CNTR,0); !-TRPUT(NAM,'COUNTER,0); IF ARGS EQ 'UNKNOWN THEN !-!-PUTD(NAM, 'FEXPR, LIST('LAMBDA, '(!-L), LIST(LIST('LAMBDA, LIST(CNTR,'!-TRINDENT!*), LIST('!-TRACEDCALL, !-MKQUOTE NAM, '(!-EVLIS !-L) ) ), LIST('!-ADD1,CNTR), '!-TRINDENT!*) ) ) ELSE !-!-PUTD(NAM, TYP, LIST('LAMBDA, ARGS, LIST(LIST('LAMBDA, LIST(CNTR,'!-TRINDENT!*), LIST('!-TRACEDCALL, !-MKQUOTE NAM, 'LIST . ARGS) ), LIST('!-ADD1,CNTR), '!-TRINDENT!*) ) ); IF NOT !-MEMQ(NAM,!-INSTALLEDFNS!*) THEN !-INSTALLEDFNS!* := NAM . !-INSTALLEDFNS!*; RETURN T END !-TRINSTALL; SYMBOLIC PROCEDURE !-TRINSTALLIST U; FOR EACH V IN U DO !-TRINSTALL(V,NIL); SYMBOLIC PROCEDURE !-ARGNAMES(FN,DEFN,TYPE,NM); % Tries to discover the names of the arguments of FN. NM is a good guess, as % for instance based on the arguments to an EMB procedure. Returns UNKNOWN if % it can't find out. ON TRUNKNOWN will cause it to return UNKNOWN rather than % asking the user. IF !-EQCAR(DEFN,'LAMBDA) THEN % otherwise it must be a code pointer CADR DEFN ELSE IF NOT TYPE EQ 'EXPR THEN LIST CAR !-ARBARGNAMES!* ELSE IF (TYPE:=!-GET(FN,'ARGUMENTS!*)) or (TYPE := code!-number!-of!-arguments DEFN) THEN IF NUMBERP TYPE THEN !-FIRSTN(TYPE,!-ARBARGNAMES!*) ELSE CAR TYPE ELSE IF NUMBERP NM THEN !-FIRSTN(NM,!-ARBARGNAMES!*) ELSE IF !*TRUNKNOWN THEN 'UNKNOWN ELSE !-ARGNAMES1 FN; % BEGIN SCALAR RESULT; % RESULT := ERRORSET(LIST('!-ARGNAMES1,!-MKQUOTE FN),NIL,NIL); % IF PAIRP RESULT THEN % RETURN CAR RESULT % ELSE % ERROR(RESULT,EMSG!*) % END; FLUID '(PROMPTSTRING!*); SYMBOLIC PROCEDURE !-ARGNAMES1 FN; BEGIN SCALAR N, PROMPTSTRING!*; PROMPTSTRING!* := BLDMSG("How many arguments does %r take? ", FN); AGAIN: N:=READ(); IF N='!? THEN << !-TERPRI(); %EXPLAIN OPTIONS; !-PRIN2 "Give a number, a list of atoms (for the names of"; !-TERPRI(); !-PRIN2 "the arguments) or the word 'UNKNOWN'. System security"; !-TERPRI(); !-PRIN2 "will not be good if you say UNKNOWN, but LISP will"; !-TERPRI(); !-PRIN2 "at least try to help you"; !-TERPRI(); % !-PRIN2 "Number of arguments"; GO TO AGAIN >> ELSE IF N='UNKNOWN THEN RETURN N ELSE IF FIXP N AND NOT !-LESSP(N,0) THEN RETURN !-FIRSTN(N,!-ARBARGNAMES!*) ELSE IF !-LISTOFATOMS N THEN RETURN N; !-TERPRI(); !-PRIN2 "*** Please try again, ? will explain options "; GO TO AGAIN END !-ARGNAMES1; SYMBOLIC PROCEDURE !-TRRESTORE U; BEGIN SCALAR BOD,TYP; IF NOT !-GET(U,'TRACE) THEN RETURN; BOD := !-TRGET(U,'ORIGINALFN); TYP := !-TRGET(U,'FNTYPE); IF NULL BOD OR NULL TYP THEN << !-LPRIM LIST("Can't restore",U); RETURN >>; !-REMD U; !-PUTD(U,TYP,BOD); !-REMPROP(U,'TRACE) END !-TRRESTORE; SYMBOLIC PROCEDURE REDEFINED!-PUTD(NAM,TYP,BOD); BEGIN SCALAR ANSWER; REMPROP(NAM,'TRACE); ANSWER := !-PUTD(NAM,TYP,BOD); IF NULL ANSWER THEN RETURN NIL; IF !*TRACEALL OR !*INSTALL THEN !-TRINSTALL(NAM,NIL); IF !*TRACEALL THEN << !-TRFLAG(LIST NAM,'TRPRINT); If Not Memq (NAM, TracedFns!*) then TracedFns!* := NAM . TracedFns!*>>; IF PUTDHOOK!* THEN APPLY(PUTDHOOK!*,LIST NAM); RETURN ANSWER END; PUTD('PUTD, 'EXPR, CDR GETD 'REDEFINED!-PUTD); %FEXPR PROCEDURE DE U; %PUTD(CAR U,'EXPR,'LAMBDA . CADR U . CDDR U); % %FEXPR PROCEDURE DF U; %PUTD(CAR U,'FEXPR,'LAMBDA . CADR U . CDDR U); % %FEXPR PROCEDURE DM U; %PUTD(CAR U,'MACRO,'LAMBDA . CADR U . CDDR U); PUT('TRACEALL,'SIMPFG,'((T (SETQ !*INSTALL T))(NIL (SETQ !*INSTALL NIL)))); PUT('INSTALL,'SIMPFG,'((NIL (SETQ !*TRACEALL NIL)))); %********************************************************************* SYMBOLIC PROCEDURE TROUT U; % U is a filename. Redirects trace output there. << IF MSGCHNL!* THEN CLOSE MSGCHNL!*; MSGCHNL!* := !-OPEN(U,'OUTPUT) >>; SYMBOLIC PROCEDURE STDTRACE; << IF MSGCHNL!* THEN CLOSE MSGCHNL!*; MSGCHNL!* := NIL >>; CompileTime << SYMBOLIC MACRO PROCEDURE !-OUTRACE U; % Main trace output handler. !-OUTRACE(fn,arg1,...argn) calls fn(arg1,...argn) % as appropriate to print trace information. LIST('!-OUTRACE1, 'LIST . MKQUOTE CADR U . FOR EACH V IN CDDR U COLLECT LIST('!-MKQUOTE,V) ); >>; SYMBOLIC PROCEDURE !-OUTRACE1 !-U; BEGIN SCALAR !-STATE; IF !-TRACEBUFF!* THEN << RPLACA(!-TRACEBUFF!*,!-U); !-TRACEBUFF!* := CDR !-TRACEBUFF!* >>; IF !*TRACE THEN << !-STATE := !-ENTERPRI(); !-EVAL !-U; !-EXITPRI !-STATE >> END !-OUTRACE; SYMBOLIC PROCEDURE !-DUMPTRACEBUFF DELFLG; % Prints the ring buffer of saved trace output stored by OUTRACE. % DELFLG non-nil wipes it clean as well. BEGIN SCALAR PTR; IF NOT !-EQUAL(!-POSN(),0) THEN !-TERPRI(); IF NULL !-TRACEBUFF!* THEN << !-PRIN2T "*** No trace information has been saved ***"; RETURN >>; !-PRIN2T "*** Start of saved trace information ***"; PTR := !-TRACEBUFF!*; REPEAT << !-EVAL CAR PTR; IF DELFLG THEN RPLACA(PTR,NIL); PTR := CDR PTR >> UNTIL PTR EQ !-TRACEBUFF!*; !-PRIN2T "*** End of saved trace information ***"; END !-DUMPTRACEBUFF; SYMBOLIC PROCEDURE NEWTRBUFF N; % Makes a new ring buffer for trace output with N entries. << !-TRACEBUFF!* := !-CIRLIST(NIL,N); NIL >>; !-FLAG('(NEWTRBUFF),'OPFN); NEWTRBUFF 5; SYMBOLIC PROCEDURE !-TRACEDCALL(!-NAM,!-ARGS); % Main routine for handling traced functions. Currently saves the number of % invocations of the function, prints trace information, causes EMB and TRST % functions to be handled correctly, calls several hooks, and stacks and % unstacks information in the BTR stack, if appropriate. Examines several % state variables and a number of function specific flags to determine what % must be done. BEGIN SCALAR !-A,!-BOD,!-VAL,!-FLG,!-LOCAL,!-STATE,!-BTRTOP,!-TYP,!-LEV,!-EMB; IF !*TRCOUNT THEN IF !-A := !-TRGET(!-NAM,'COUNTER) THEN !-TRPUT(!-NAM,'COUNTER,!-ADD1 !-A); !-TRACECOUNT!* := !-SUB1 !-TRACECOUNT!*; IF !-LESSP(!-TRACECOUNT!*,1) THEN << !-TRACEFLAG!* := T; IF !-EQUAL(!-TRACECOUNT!*,0) THEN << !-STATE := !-ENTERPRI(); !-PRIN2 "*** TRACECOUNT reached ***"; !-EXITPRI !-STATE >> >>; IF NOT !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRACEWITHIN) THEN << !-TRACEFLAG!* := !-LOCAL := T; !-STATE := !-ENTERPRI(); !-LPRIM LIST("TRACECOUNT =",!-TRACECOUNT!*); !-EXITPRI !-STATE >>; IF TRACENTRYHOOK!* THEN !-FLG := !-ERRAPPLY(TRACENTRYHOOK!*, LIST(!-NAM,!-ARGS), 'TRACENTRYHOOK) ELSE !-FLG := T; !-LEV := !-EVAL !-TRGET(!-NAM,'LEVELVAR); !-FLG := !-FLG AND !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRPRINT) AND NOT(!-LESSP(!-LEV,TRACEMINLEVEL!*) OR !-GREATERP(!-LEV,TRACEMAXLEVEL!*) ); IF !-FLG AND !-TRFLAGP(!-NAM,'TRST) THEN !-BOD := !-TRGET(!-NAM,'TRSTFN) OR !-TRGET(!-NAM,'ORIGINALFN) ELSE !-BOD := !-TRGET(!-NAM,'ORIGINALFN); IF !-FLG THEN << !-TRINDENT!* := !-ADD1 !-TRINDENT!*; !-OUTRACE(!-TRACENTRYPRI,!-NAM,!-ARGS,!-LEV,!-TRINDENT!*) >>; IF !*BTR THEN !-BTRTOP := !-BTRPUSH(!-NAM,!-ARGS); !-TYP := !-TRGET(!-NAM,'FNTYPE); IF NOT(!-TYP EQ 'EXPR) THEN !-ARGS := LIST CAR !-ARGS; IF !-TRFLAGP(!-NAM,'EMB) AND (!-EMB := !-TRGET(!-NAM,'EMBFN)) THEN !-VAL := !-APPLY(!-EMB,!-BOD . !-ARGS) ELSE !-VAL := !-APPLY(!-BOD,!-ARGS); IF !-TYP EQ 'MACRO THEN << IF TRACEXPANDHOOK!* THEN !-ERRAPPLY(TRACEXPANDHOOK!*, LIST(!-NAM,!-VAL), 'TRACEXPANDHOOK); % IF !-FLG THEN % !-OUTRACE(!-TRACEXPANDPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*); % !-VAL := !-EVAL !-VAL >>; IF !*BTR THEN !-BTRPOP !-BTRTOP; IF !-FLG THEN !-OUTRACE(!-TRACEXITPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*); IF !-LOCAL AND !-GREATERP(!-TRACECOUNT!*,0) THEN !-TRACEFLAG!* := NIL; IF TRACEXITHOOK!* THEN !-ERRAPPLY(TRACEXITHOOK!*,LIST(!-NAM,!-VAL),'TRACEXITHOOK); RETURN !-VAL END !-TRACEDCALL; SYMBOLIC PROCEDURE !-ERRAPPLY(!-FN,!-ARGS,!-NAM); BEGIN SCALAR !-ANS,!-CHN; !-ANS := !-ERRORSET(LIST('!-APPLY,!-FN,!-ARGS),T,!*BACKTRACE); IF ATOM !-ANS THEN << !-CHN := !-WRS MSGCHNL!*; !-PRIN2 "***** Error occured evaluating "; !-PRIN2 !-NAM; !-PRIN2 " *****"; !-TERPRI(); !-WRS !-CHN; RETURN !-ANS >> ELSE RETURN CAR !-ANS END !-ERRAPPLY; %************ Routines for printing trace information *************** SYMBOLIC PROCEDURE TRACECOUNT N; % Suppresses TRACE output until N traced function invocations have passed. BEGIN SCALAR OLD; OLD:=!-TRACECOUNT!*; IF NUMBERP N THEN << !-TRACECOUNT!*:=N; IF !-GREATERP(N,0) THEN !-TRACEFLAG!*:=NIL ELSE !-TRACEFLAG!*:=T >>; RETURN OLD END; !-FLAG('(TRACECOUNT),'OPFN); SYMBOLIC PROCEDURE TRACEWITHIN L; % L is a list of function names. Forces tracing to be enabled within them. << !-TRFLAG(L,'TRACEWITHIN); IF NOT !-GREATERP(!-TRACECOUNT!*,0) THEN << !-TRACECOUNT!*:=100000; !-TRACEFLAG!*:=NIL; !-LPRIM "TRACECOUNT set to 100000" >>; FOR EACH U IN L CONC IF !-TRINSTALL(U,NIL) THEN LIST U >>; SYMBOLIC PROCEDURE TRACE L; % Enables tracing on each function in the list L. FOR EACH FN IN L CONC IF !-TRINSTALL(FN,NIL) THEN << !-TRFLAG(LIST FN,'TRPRINT); If Not Memq (FN, TracedFns!*) then TracedFns!* := FN . TracedFns!*; LIST FN >>; SYMBOLIC PROCEDURE UNTRACE L; % Disables tracing for each function in the list L. FOR EACH FN IN L CONC << !-TRREMFLAG(LIST FN,'TRACEWITHIN); !-TRREMFLAG(LIST FN,'TRST); IF !-TRFLAGP(FN,'TRPRINT) THEN << !-TRREMFLAG(LIST FN,'TRPRINT); FN >> ELSE << !-LPRIM LIST("Function",FN,"was not traced."); NIL >> >>; SYMBOLIC PROCEDURE !-ENTERPRI; BEGIN SCALAR !-CHN,!-PSN; !-CHN := !-WRS MSGCHNL!*; !-PSN := !-POSN(); IF !-GREATERP(!-PSN,0) THEN << !-PRIN2 '!< ; !-TERPRI() >>; RETURN !-CHN . !-PSN END !-ENTERPRI; SYMBOLIC PROCEDURE !-EXITPRI !-STATE; BEGIN SCALAR !-PSN; !-PSN := CDR !-STATE; IF !-GREATERP(!-PSN,0) THEN << IF NOT !-LESSP(!-POSN(),!-PSN) THEN !-TERPRI(); !-SPACES2 !-SUB1 !-PSN; !-PRIN2 '!> >> ELSE IF !-GREATERP(!-POSN(),0) THEN !-TERPRI(); !-WRS CAR !-STATE END; SYMBOLIC PROCEDURE !-TRINDENT !-INDNT; BEGIN SCALAR !-N; !-N := !-TIMES2(!-INDNT,!-INDENTDEPTH!*); IF NOT !-GREATERP(!-N,!-INDENTCUTOFF!*) THEN !-SPACES2 !-N ELSE << !-SPACES2 !-INDENTCUTOFF!*; !-PRIN2 '!* >> END !-TRINDENT; SYMBOLIC PROCEDURE !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); << !-TRINDENT !-INDNT; !-PRIN1 !-NAM; IF !-GREATERP(!-LEV,1) THEN << !-PRIN2 " (level "; !-PRIN2 !-LEV; !-PRIN2 '!) >> >>; SYMBOLIC PROCEDURE !-TRACENTRYPRI(!-NAM,!-ARGS,!-LEV,!-INDNT); % Handles printing trace information at entry to a function. !-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT," being entered"); SYMBOLIC PROCEDURE !-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT,!-S); BEGIN SCALAR !-ARGNAMS; !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 !-S; !-TERPRI(); !-ARGNAMS := !-TRGET(!-NAM,'ARGNAMES); WHILE !-ARGS DO << !-TRINDENT !-INDNT; !-SPACES !-ARGINDENT!*; IF !-ARGNAMS THEN << !-PRIN2 CAR !-ARGNAMS; !-ARGNAMS := CDR !-ARGNAMS >> ELSE !-PRIN2 '!?!?!?!? ; !-PRIN2 ": "; APPLY(TRPRINTER!*,LIST CAR !-ARGS); !-ARGS := CDR !-ARGS; IF !-ARGS AND NOT !-POSN() = 0 THEN !-TERPRI() >>; END !-TRACENTRYPRI; SYMBOLIC PROCEDURE !-TRACEXPANDPRI(!-NAM,!-EXP,!-LEV,!-INDNT); % Prints macro expansions. << !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 " MACRO expansion = "; APPLY(TREXPRINTER!*,LIST !-EXP) >>; SYMBOLIC PROCEDURE !-TRACEXITPRI(!-NAM,!-VAL,!-LEV,!-INDNT); % Prints information upon exiting a function. << !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 " = "; APPLY(TRPRINTER!*,LIST !-VAL) >>; %*************** TRST functions *********************************** SYMBOLIC PROCEDURE TRACESET L; BEGIN SCALAR DFN; RETURN FOR EACH FN IN L CONC IF !-TRINSTALL(FN,NIL) THEN << !-TRFLAG(LIST FN,'TRPRINT); If Not Memq (FN, TracedFns!*) then TracedFns!* := FN . TracedFns!*; DFN := !-TRGET(FN,'ORIGINALFN); IF CODEP DFN THEN << !-LPRIM LIST("Function",FN,"is compiled. It cannot be traceset."); NIL >> ELSE << !-TRFLAG(LIST FN,'TRST); IF NOT !-TRGET(FN,'TRSTFN) THEN !-TRPUT(FN,'TRSTFN,!-MKTRST DFN); LIST FN >> >> END TRACESET; SYMBOLIC PROCEDURE UNTRACESET L; FOR EACH FN IN L CONC IF !-TRFLAGP(FN,'TRST) THEN << !-TRREMFLAG(LIST FN,'TRST); LIST FN >> ELSE << !-LPRIM LIST("Function",FN,"was not traceset."); NIL >>; SYMBOLIC PROCEDURE !-TRSTPRI(!-NAM,!-VAL); << !-OUTRACE(!-TRSTPRI1,!-NAM,!-VAL,!-TRINDENT!*); !-VAL >>; SYMBOLIC PROCEDURE !-TRSTPRI1(!-NAM,!-VAL,!-INDNT); BEGIN SCALAR !-STATE; !-STATE := !-ENTERPRI(); !-TRINDENT !-INDNT; !-PRIN2 !-NAM; !-PRIN2 " := "; APPLY(TRPRINTER!*,LIST !-VAL); !-EXITPRI !-STATE; END !-TRSTPRI; SYMBOLIC PROCEDURE !-MKTRST U; BEGIN SCALAR V; IF ATOM U THEN RETURN U; IF !-FLAGP(CAR U,'TRSTINSIDE) THEN RETURN !-MKTRST1 U; IF V := !-GET(CAR U,'TRSTINSIDEFN) THEN RETURN APPLY(V,LIST U); IF IDP CAR U AND (V := !-GETD CAR U) THEN << V := CAR V; IF V EQ 'FEXPR THEN RETURN U; IF V EQ 'MACRO THEN IF !*TRSTEXPANDMACROS THEN RETURN !-MKTRST APPLY(CAR U,LIST U) ELSE RETURN U >>; RETURN !-MKTRST1 U END; SYMBOLIC PROCEDURE !-MKTRST1 U; FOR EACH V IN U COLLECT !-MKTRST V; % Functions for TRSTing certain special functions SYMBOLIC PROCEDURE !-TRSTSETQ U; IF ATOM CDR U OR ATOM CDDR U THEN !-LPRIE LIST("Malformed expression",U) ELSE LIST(CAR U,CADR U,LIST('!-TRSTPRI,!-MKQUOTE CADR U,!-MKTRST CADDR U)); symbolic procedure !-TrstCond u; cons(car u, for each v in cdr u collect !-MkTrST1 v); SYMBOLIC PROCEDURE !-TRSTPROG U; IF ATOM CDR U THEN !-LPRIE LIST("Malformed expression",U) ELSE CAR U . CADR U . !-MKTRST1 CDDR U; %****************** Heavy handed backtrace routines ******************* SYMBOLIC PROCEDURE !-BTRPUSH(!-NAM,!-ARGS); BEGIN SCALAR !-OSTK; !-OSTK := !-BTRSTK!*; !-BTRSTK!* := (!-NAM . !-ARGS) . !-OSTK; RETURN !-OSTK END !-BTRPUSH; SYMBOLIC PROCEDURE !-BTRPOP !-PTR; BEGIN SCALAR !-A; IF !*BTRSAVE AND NOT(!-PTR EQ CDR !-BTRSTK!*) THEN << WHILE !-BTRSTK!* AND NOT(!-PTR EQ !-BTRSTK!*) DO << !-A := CAR !-BTRSTK!* . !-A; !-BTRSTK!* := CDR !-BTRSTK!* >>; IF NOT(!-PTR EQ !-BTRSTK!*) THEN << !-TERPRI(); !-PRIN2 "***** Internal error in DEBUG: BTR stack underflow *****"; !-TERPRI() >>; !-BTRSAVEDINTERVALS!* := !-A . !-BTRSAVEDINTERVALS!* >> ELSE !-BTRSTK!* := !-PTR END !-BTRPOP; SYMBOLIC PROCEDURE !-BTRDUMP; BEGIN SCALAR STK; STK := !-BTRSTK!*; IF NOT (!-POSN() = 0) THEN !-TERPRI(); IF NULL STK AND NOT(!*BTRSAVE AND !-BTRSAVEDINTERVALS!*) THEN << !-PRIN2T "*** No traced functions were left abnormally ***"; RETURN >>; !-PRIN2T "*** Backtrace: ***"; IF STK THEN << !-PRIN2T "These functions were left abnormally:"; REPEAT << !-TRACENTRYPRI1(CAAR STK,CDAR STK,1,1,""); STK := CDR STK >> UNTIL NULL STK >>; IF !*BTRSAVE THEN FOR EACH U IN !-BTRSAVEDINTERVALS!* DO << !-PRIN2T "These functions were left abnormally, but without"; !-PRIN2T "returning to top level:"; FOR EACH V IN U DO !-TRACENTRYPRI1(CAR V,CDR V,1,1,"") >>; !-PRIN2T "*** End of backtrace ***" END !-BTRDUMP; SYMBOLIC PROCEDURE BTRACE L; << !*BTR := T; !-BTRNEWSTK(); FOR EACH U IN L CONC IF !-TRINSTALL(U,NIL) THEN LIST U >>; SYMBOLIC PROCEDURE !-BTRNEWSTK; !-BTRSTK!* := !-BTRSAVEDINTERVALS!* := NIL; !-BTRNEWSTK(); PUT('BTR,'SIMPFG,'((NIL (!-BTRNEWSTK))(T (!-BTRNEWSTK)))); %********************* Embed functions **************************** SYMBOLIC PROCEDURE !-EMBSUBST(NAM,FN,NEW); IF ATOM FN OR CAR FN EQ 'QUOTE THEN FN ELSE IF CAR FN EQ NAM THEN NEW . '!-ORIGINALFN!* . CDR FN ELSE FOR EACH U IN FN COLLECT !-EMBSUBST(NAM,U,NEW); SYMBOLIC MACRO PROCEDURE !-EMBCALL !-U; LIST('!-APPLY,CADR !-U,'LIST . CDDR !-U); SYMBOLIC PROCEDURE EMBFN(NAM,VARS,BOD); BEGIN SCALAR EMBF; IF !*DEFN THEN << % For REDUCE; OUTDEF LIST('EMBFN,!-MKQUOTE NAM,!-MKQUOTE VARS,!-MKQUOTE BOD); RETURN >>; IF !-TRINSTALL(NAM,!-LENGTH VARS) THEN << EMBF := !-TRGET(NAM,'EMBFN); EMBF := LIST('LAMBDA, '!-ORIGINALFN!* . VARS, !-EMBSUBST(NAM,BOD,IF EMBF THEN EMBF ELSE '!-EMBCALL) ); !-TRPUT(NAM,'EMBFN,EMBF); !-TRFLAG(LIST NAM,'EMB); RETURN !-MKQUOTE NAM >> END; SYMBOLIC PROCEDURE EMBEDFNS U; FOR EACH X IN U CONC IF !-TRGET(X,'EMBFN) THEN << X := LIST X; !-TRFLAG(X,'EMB); X >> ELSE << !-LPRIM LIST("Procedure",X,"has no EMB definition"); NIL >>; SYMBOLIC PROCEDURE UNEMBEDFNS U; FOR EACH X IN U CONC IF !-TRFLAGP(X,'EMB) THEN << X := LIST X; !-TRREMFLAG(X,'EMB); X >>; %***************** Function call histogram routines ************* SYMBOLIC PROCEDURE !-HISTOGRAM; % Simplistic histogram routine for number of function calls. BEGIN INTEGER M,N,NM; SCALAR NAM,NMS,NEW; IF !-GETD 'TREESORT THEN % If REDIO is available !-INSTALLEDFNS!* := MSORT !-INSTALLEDFNS!*; !-TERPRI(); !-TERPRI(); N := 0; FOR EACH U IN !-INSTALLEDFNS!* DO IF !-GET(U,'TRACE) THEN << N := !-MAX2(!-TRGET(U,'COUNTER),N); NEW := U . NEW >>; !-INSTALLEDFNS!* := NEW; N := FLOAT(LINELENGTH NIL - 21) / FLOAT N; FOR EACH U IN !-INSTALLEDFNS!* DO << NAM := !-EXPLODE U; NM := !-TRGET(U,'COUNTER); NMS := !-EXPLODE NM; M := !-MIN2(LENGTH NAM,17-LENGTH NMS); FOR I := 1:M DO << !-PRINC CAR NAM; NAM := CDR NAM >>; !-PRINC '!( ; WHILE NMS DO << !-PRINC CAR NMS; NMS := CDR NMS >>; !-PRINC '!) ; !-SPACES2 20; FOR I := FIX(NM*N) STEP -1 UNTIL 1 DO !-PRINC '!* ; !-TERPRI() >>; !-TERPRI(); !-TERPRI() END !-HISTOGRAM; SYMBOLIC PROCEDURE !-CLEARCOUNT; BEGIN SCALAR NEWVAL; FOR EACH U IN !-INSTALLEDFNS!* DO IF !-GET(U,'TRACE) THEN << !-TRPUT(U,'COUNTER,0); NEWVAL := U . NEWVAL >>; !-INSTALLEDFNS!* := NEWVAL END !-CLEARCOUNT; % SIMPFG so ON/OFF TRCOUNT will do a histogram PUT('TRCOUNT,'SIMPFG,'((T (!-CLEARCOUNT)) (NIL (!-HISTOGRAM)))); %************************ TRACE related statements ********************* %SYMBOLIC PROCEDURE TRSTAT; %% Nearly the same as RLIS2, but allows zero or more args rather than one or %% more. %BEGIN SCALAR NAM,ARGS; % NAM := CURSYM!*; % IF FLAGP!*!*(SCAN(),'DELIM) THEN % RETURN LIST(NAM,NIL); % RETURN LOOP << % ARGS := MKQUOTE CURSYM!* . ARGS; % IF FLAGP!*!*(SCAN(),'DELIM) THEN % EXIT LIST(NAM,'LIST . REVERSIP ARGS) % ELSE IF CURSYM!* NEQ '!*COMMA!* THEN % SYMERR("Syntax Error",NIL); % SCAN() >> %END TRSTAT; SYMBOLIC PROCEDURE !-TR1(L,FN); BEGIN SCALAR X; !-SLOWLINKS(); X := APPLY(FN,LIST L); IF !*MODE EQ 'ALGEBRAIC THEN << % For REDUCE; !-TERPRI(); !-PRINT X >> ELSE RETURN X END; MACRO PROCEDURE TR U; LIST('EVTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTR U; IF U THEN !-TR1(U,'TRACE) ELSE !-DUMPTRACEBUFF NIL; MACRO PROCEDURE UNTR U; LIST('EVUNTR, MKQUOTE CDR U); procedure UnTrAll(); <<EvUnTr TracedFns!*; TracedFns!* := Nil>>; SYMBOLIC PROCEDURE EVUNTR U; BEGIN SCALAR L; IF U THEN <<!-TR1(U,'UNTRACE); Foreach L in U do TracedFns!*:=DelQ(L,TracedFns!*)>> ELSE << !-TRACEFLAG!* := NIL; !-LPRIM "TRACECOUNT set to 10000"; !-TRACECOUNT!* := 10000 >>; END; MACRO PROCEDURE RESTR U; LIST ('EVRESTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVRESTR U; BEGIN SCALAR L; IF U THEN <<FOR EACH L IN U DO !-TRRESTORE L; !-INSTALLEDFNS!* := DELQ (L,!-INSTALLEDFNS!*); TRACEDFNS!* := DELQ (L,TRACEDFNS!*)>> ELSE << FOR EACH U IN !-INSTALLEDFNS!* DO !-TRRESTORE U; !-INSTALLEDFNS!* := NIL; TRACEDFNS!* := NIL>>; END; MACRO PROCEDURE TRIN U; LIST('EVTRIN, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRIN U; !-TR1(U,'TRACEWITHIN); MACRO PROCEDURE TRST U; LIST('EVTRST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRST U; !-TR1(U,'TRACESET); MACRO PROCEDURE UNTRST U; LIST('EVUNTRST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVUNTRST U; !-TR1(U,'UNTRACESET); MACRO PROCEDURE BTR U; LIST('EVBTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVBTR U; IF U THEN !-TR1(U,'BTRACE) ELSE !-BTRDUMP(); SYMBOLIC PROCEDURE RESBTR; !-BTRNEWSTK(); MACRO PROCEDURE EMBED U; LIST('EVEMBED, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVEMBED U; !-TR1(U,'EMBEDFNS); MACRO PROCEDURE UNEMBED U; LIST('EVUNEMBED, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVUNEMBED U; !-TR1(U,'UNEMBEDFNS); MACRO PROCEDURE TRCNT U; LIST('EVTRCNT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRCNT U; !-TR1(U,'!-TRINSTALLIST); IF NOT FUNBOUNDP 'DEFINEROP THEN << RLISTAT('(TR UNTR TRIN TRST UNTRST BTR EMBED UNEMBED TRCNT RESTR FSTUB STUB PLIST PPF), 'NOQUOTE); RLISTAT('(TROUT), 'NOQUOTE); DEFINEROP('RESBTR,NIL,ESTAT('RESBTR)); DEFINEROP('STDTRACE,NIL,ESTAT('STDTRACE)); >>; %DEFLIST('( % (TR TRSTAT) % (UNTR RLIS2) % (TRIN RLIS2) % (TRST RLIS2) % (UNTRST RLIS2) % (BTR TRSTAT) % (EMBED RLIS2) % (UNEMBED RLIS2) % (TRCNT RLIS2) % (RESBTR ENDSTAT) % (RESTR RLIS2) % (STDTRACE ENDSTAT) % (TROUT IOSTAT) % ), 'STAT); FLAG('(TR UNTR BTR),'GO); FLAG('(TR TRIN UNTR TRST UNTRST BTR EMBED UNEMBED RESBTR RESTR TRCNT TROUT STDTRACE), 'IGNORE); %******************Break Functions*********************************** fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb, Result; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Result:=Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, Result); TrSpace!* := TrSpace!* - 1; return Result end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Break a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; if Memq (Nam,TracedFns!*) or Memq (Nam,!-InstalledFns!*) then <<!-TrRestore Nam; Y:=GetD Nam; !-InstalledFns!*:=DelQ(Nam,!-InstalledFns!*); TracedFns!*:=DelQ(Nam,TracedFns!*)>>; if Not Memq (Nam,BrokenFns!*) then BrokenFns!*:=Cons(Nam, BrokenFns!*); PN := GenSym(); !-!-PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else if (N:=Code!-Number!-Of!-Arguments Cdr Y) then Args := TrMakeArgList N else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); !-!-PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; !-!-PutD(Nam, caar X, cdar X); RemProp(Nam, 'OldCod); RemProp(Nam, 'Breakcode); BrokenFns!*:=DelQ(Nam,BrokenFns!*); end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; Begin; for each X in L do Br!.1 X; Return L end; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; expr procedure UnBrAll(); <<EvUnBr BrokenFns!*; BrokenFns!* := Nil>>; %************************ Stubs ************************************* % These procedures implement stubs for Rlisp/Reduce. Usage is "STUB % <model function invocation> [,<model function invocation>]* % <semicol>". For example, to declare function FOO, BAR, and BLETCH % with formal parameters X,Y,Z for FOO, U for BAR, and none for BLETCH % do "STUB FOO(X,Y,Z),BAR U, BLETCH();". When a stub is executed it % announces its invocation, prettyprints its arguments, and asks for % the value to return. Fexpr stubs may be declared with the analogous % statement FSTUB. MACRO PROCEDURE STUB U; LIST('EVSTUB, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVSTUB FNLIS; FOR EACH Y IN FNLIS DO IF NOT PAIRP Y THEN IF NOT IDP Y THEN !-LPRIE "Function name must be an ID" ELSE << !-LPRIM LIST("Stub",Y,"declared as a function of zero arguments"); !-MKSTUB(Y,NIL,'EXPR) >> ELSE IF NOT IDP CAR Y THEN !-LPRIE "Function name must be an ID" ELSE IF NOT !-IDLISTP CDR Y THEN !-LPRIE "Formal parameter must be an ID" ELSE !-MKSTUB(CAR Y,CDR Y,'EXPR); MACRO PROCEDURE FSTUB U; LIST('EVFSTUB, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVFSTUB FNLIS; FOR EACH Y IN FNLIS DO IF NOT PAIRP Y THEN !-LPRIE "Arguments to FSTUB must be model function calls" ELSE IF NOT IDP CAR Y THEN !-LPRIE "Function name must be an ID" ELSE IF NOT !-IDLISTP CDR Y THEN !-LPRIE "Formal parameter must be an ID" ELSE IF !-LENGTH CDR Y NEQ 1 THEN !-LPRIE "An FEXPR must have exactly one formal parameter" ELSE !-MKSTUB(CAR Y, CDR Y, 'FEXPR); SYMBOLIC PROCEDURE !-MKSTUB(NAME, VARLIS, TYPE); PUTD(NAME, TYPE, LIST('LAMBDA, VARLIS, LIST('!-STUB1, !-MKQUOTE NAME, !-MKQUOTE VARLIS, 'LIST . VARLIS, !-MKQUOTE TYPE) ) ); SYMBOLIC PROCEDURE !-STUB1(!-PNAME, !-ANAMES, !-AVALS, !-TYPE); % Weird variable names because of call to EVAL. BEGIN INTEGER !-I; IF !-TYPE NEQ 'EXPR THEN !-PRIN2 !-TYPE; !-PRIN2 " Stub "; !-PRIN2 !-PNAME; !-PRIN2 " called"; !-TERPRI(); !-TERPRI(); !-I := 1; FOR EACH !-U IN PAIR(!-PAD(!-ANAMES,!-LENGTH !-AVALS),!-AVALS) DO << IF CAR !-U THEN !-PRIN2 CAR !-U ELSE << !-SET(!-INTERN !-COMPRESS !-APPEND('(A R G),!-EXPLODE !-I), CDR !-U); !-PRIN2 "Arg #"; !-PRIN2 !-I >>; !-PRIN2 ": "; APPLY(STUBPRINTER!*, LIST CDR !-U); !-I := !-I + 1 >>; !-PRIN2T "Return? :"; RETURN !-EVAL APPLY(STUBREADER!*,NIL) END; SYMBOLIC PROCEDURE !-REDREADER; XREAD NIL; %*************** Functions for printing useful information ************* MACRO PROCEDURE PLIST U; LIST('EVPLIST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVPLIST U; % Prints the property list and flags of U in a descent format, % prettyprinting nasty things. Does not print properties in the % global list !-INVISIBLEPROPS!* or flags in !-INVISIBLEFLAGS!*. Usage is % "PLIST <id> [,<id>]* <semicol>". << !-TERPRI(); FOR EACH V IN U CONC IF V := !-PLIST1 V THEN LIST V >>; SYMBOLIC PROCEDURE !-PLIST1 U; BEGIN SCALAR PLST,FLGS,HASPROPS; !-TERPRI(); IF NOT IDP U THEN << !-LPRIE LIST(U,"is not an ID"); RETURN NIL >>; PLST := !-GETPROPERTYLIST U; % System dependent kludge FOR EACH V IN PLST DO IF ATOM V AND NOT !-MEMQ(V,!-INVISIBLEFLAGS!*) THEN FLGS := V . FLGS ELSE IF NOT !-MEMQ(CAR V,!-INVISIBLEPROPS!*) THEN << IF NOT HASPROPS THEN << HASPROPS := T; !-PRIN2 "Properties for "; !-PRIN1 U; !-PRIN2T ":"; !-TERPRI() >>; !-SPACES 4; !-PRIN1 CAR V; !-PRIN2 ":"; !-SPACES 2; !-SPACES2 15; APPLY(PROPERTYPRINTER!*,LIST CDR V) >>; IF FLGS THEN << IF HASPROPS THEN !-PRIN2 "Flags: " ELSE << !-PRIN2 "Flags for "; !-PRIN1 U; !-PRIN2 ": " >>; FOR EACH V IN FLGS DO << !-PRIN1 V; !-SPACES 1 >>; !-TERPRI(); !-TERPRI() >> ELSE IF NOT HASPROPS THEN << !-PRIN2 "No Flags or Properties for "; !-PRINT U; !-TERPRI() >>; IF HASPROPS OR FLGS THEN RETURN U END !-PLIST1; MACRO PROCEDURE PPF U; LIST('EVPPF, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVPPF FLIS; % Pretty prints one or more function definitions, from their % names. Usage is "PPF <name> [,<name>]* <semicol>". << !-TERPRI(); FOR EACH FN IN FLIS CONC IF FN := !-PPF1 FN THEN LIST FN >>; SYMBOLIC PROCEDURE !-PPF1 FN; BEGIN SCALAR BOD,TYP,ARGS,TRC,FLGS; IF !-GET(FN,'TRACE) THEN << BOD := !-TRGET(FN,'ORIGINALFN); IF NOT CODEP BOD THEN BOD := CADDR BOD; TYP := !-TRGET(FN,'FNTYPE); IF NOT !-TRFLAGP(FN,'UNKNOWNARGS) THEN ARGS := !-TRGET(FN,'ARGNAMES); IF !-TRFLAGP(FN,'TRST) THEN TRC := 'TraceSet . TRC ELSE IF !-TRFLAGP(FN,'TRPRINT) THEN TRC := 'Traced . TRC; IF !-TRFLAGP(FN,'TRACEWITHIN) THEN TRC := 'TracedWithin . TRC; IF !-TRFLAGP(FN,'EMB) THEN TRC := 'Embeded . TRC; IF NULL TRC THEN TRC := '(Installed) >> ELSE IF BOD := !-GETC FN THEN << TYP := CAR BOD; BOD := CDR BOD; IF NOT CODEP BOD THEN << ARGS := CADR BOD; BOD := CDDR BOD >> >> ELSE << !-LPRIE LIST("Procedure",FN,"is not defined."); RETURN NIL >>; FOR EACH U IN !-FUNCTIONFLAGS!* DO IF !-FLAGP(FN,U) THEN FLGS := U . FLGS; IF NOT (!-POSN() = 0) THEN !-TERPRI(); !-TERPRI(); !-PRIN2 TYP; !-PRIN2 " procedure "; !-PRIN1 FN; IF ARGS THEN << !-PRIN2 '!( ; FOR EACH U ON ARGS DO << !-PRIN1 CAR U; IF CDR U THEN !-PRIN2 '!, >>; !-PRIN2 '!) >>; IF TRC OR FLGS THEN << !-PRIN2 " ["; FOR EACH U IN !-REVERSIP TRC DO << !-PRIN2 U; !-PRIN2 '!; >>; IF TRC THEN << !-PRIN2 "Invoked "; !-PRIN2 !-TRGET(FN,'COUNTER); !-PRIN2 " times"; IF FLGS THEN !-PRIN2 '!; >>; IF FLGS THEN << !-PRIN2 "Flagged: "; FOR EACH U ON FLGS DO << !-PRIN1 CAR U; IF CDR U THEN !-PRIN2 '!, >> >>; !-PRIN2 '!] >>; IF CODEP BOD THEN << !-PRIN2 " is compiled ("; !-PRIN2 BOD; !-PRIN2T ")." >> ELSE << !-PRIN2T '!: ; FOR EACH FORM IN BOD DO APPLY(PPFPRINTER!*,LIST FORM); !-TERPRI() >>; RETURN FN END !-PPF1; SYMBOLIC PROCEDURE !-GETC U; % Like GETD, but also looks for non-standard functions, such as % SMACROs. The only non-standard functions looked for are those whose % tags appear in the list NONSTANDARDFNS!*. BEGIN SCALAR X,Y; X := !-NONSTANDARDFNS!*; Y := !-GETD U; WHILE X AND NOT Y DO << Y := !-GET(U,CAR X); IF Y THEN Y := CAR X . Y; X := CDR X >>; RETURN Y END !-GETC; FLAG('(PPF PLIST), 'IGNORE); END; |
Added psl-1983/3-1/util/defstruct.build version [335ac41f39].
> > > > > | 1 2 3 4 5 | CompileTime << load Defstruct; off UserMode; >>; in "defstruct.red"$ |
Added psl-1983/3-1/util/defstruct.examples-red version [fdcfbef5c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % (Do definitions twice to see what functions were defined.) macro procedure TWICE u; list( 'PROGN, second u, second u ); % A definition of Complex, structure with Real and Imaginary parts. % Give 0 Init values. TWICE Defstruct( Complex( !:Creator(Complex) ), R(0), I(0) ); C0 := MakeComplex(); % Constructor with default inits. ComplexP C0; % Predicate. C1:=MakeComplex( R 1, I 2 ); % Constructor with named values. R(C1); I(C1); % Named selectors. C2:=Complex(3,4); % Creator with positional values. AlterComplex( C1, R(2), I(3) ); % Alterant with named values. C1; R(C1):=5; I(C1):=6; % Named depositors. C1; % Show use of Include Option. (Again, redef to show fns defined.) TWICE Defstruct( MoreComplex( !:Include(Complex) ), Z(99) ); M0 := MakeMoreComplex(); M1 := MakeMoreComplex( R 1, I 2, Z 3 ); R C1; R M1; % A more complicated example: The structures which are used in the % Defstruct facility to represent defstructs. (The EX prefix has % been added to the names to protect the innocent...) TWICE % Redef to show fns generated. Defstruct( EXDefstructDescriptor( !:Prefix(EXDsDesc), !:Creator ), DsSize( !:Type int ), % (Upper Bound of vector.) Prefix( !:Type string ), SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) ConsName( !:Type fnId ), AltrName( !:Type fnId ), PredName( !:Type fnId ), CreateName( !:Type fnId ), Include( !:Type typeid ), InclInit( !:Type alist ) ); TWICE % Redef to show fns generated. Defstruct( EXSlotDescriptor( !:Prefix(EXSlotDesc), !:Creator ), SlotNum( !:Type int ), InitForm( !:Type form ), SlotFn( !:Type fnId ), % Selector/Depositor id. SlotType( !:Type type ), % Hm... UserGet( !:Type boolean ), UserPut( !:Type boolean ) ); END; |
Added psl-1983/3-1/util/defstruct.red version [5659f6c5cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFSTRUCT.RED - Interim structure definition facility. % % Author: Russ Fish % Computer Science Dept. % University of Utah % Date: 18 December 1981 % Copyright (c) 1981 University of Utah % % See files Defstruct.{Hlp,Doc} for description of usage. %%%% To compile this code, it must first be loaded interpretively. %%%% %%%% Bootstrap is necessary because defstructs are used internally %%%% %%%% to record the descriptions of structures, including the %%%% %%%% descriptions of the defstruct descriptors themselves. %%%% % First, an aside to the compiler. CompileTime % Compiler needs to know about LHS forms which will be used. put( 'SlotDescInitForm, 'Assign!-Op, 'PUTSlotDescInitForm ); BothTimes % Declare lists of fluids used for binding options. << fluid '( DefstructOptions SlotOptions ); fluid ( DefstructOptions := '( !:Constructor !:Alterant !:Predicate !:Creator !:Prefix !:Include !:IncludeInit ) ); fluid ( SlotOptions := '( !:Type !:UserGet !:UserPut ) ); flag('(defstruct), 'Eval); >>; % ////////////// Externally known fns ////////////////////////// % Struct type predicate. lisp procedure DefstructP( Name ); get( Name, 'Defstruct ); % Access to "struct type name" field of structure. lisp procedure DefstructType( Struct ); if VectorP Struct then % Minimal checking. getv( Struct, 0 ) else NIL; % Type inclusion predicate. lisp procedure SubTypeP( I1, I2 ); % T if I1 is a subtype of I2. begin scalar Incl; return I1 eq I2 % Type is subtype of itself. (LEQ.) or (Incl := DsDescInclude GetDefstruct I2) % Done if no subtype. and ( I1 eq Incl % Proper subtype. or SubTypeP( I1, Incl ) ) % Or a subsubtype, or... end; % ////////////// Defstruct ///////////////////////////////////// fexpr procedure Defstruct( Spec ); begin scalar StructName, Init, NameValue, Desc, DsSize, SlotSpec, SlotAlist; if atom Spec then % Spec must be a list. TypeError( Spec, 'Defstruct, "a spec list" ); StructName := if atom first Spec then first Spec % Grab the struct id. else first first Spec; if not idp StructName then % Struct id better be one. UsageTypeError( StructName, 'Defstruct, "an id", "a StructName" ); % Defaults for options. !:Constructor := !:Alterant := !:Predicate := T; !:Creator := !:Include := !:IncludeInit := NIL; !:Prefix := ""; % Process option list if present. if pairp first Spec then ProcessOptions( rest first Spec, DefstructOptions ); if !:Prefix = T then % Default prefix is StructName. !:Prefix := id2string StructName; if idp !:Prefix then % Convert id to printname string. !:Prefix := id2string !:Prefix else if not stringp !:Prefix then % Error if not id or string. UsageTypeError( !:Prefix, 'Defstruct, "an id or a string", "a SlotName prefix" ); % Construct macro names in default pattern if necessary. if !:Constructor eq T then !:Constructor := IdConcat( 'MAKE, StructName ); if !:Alterant eq T then !:Alterant := IdConcat( 'ALTER, StructName ); if !:Predicate eq T then !:Predicate := IdConcat( StructName, 'P ); if !:Creator eq T then !:Creator := IdConcat( 'CREATE, StructName ); % Define the constructor, alterant, predicate, and creator, if desired. MkStructMac( !:Constructor, 'Make, StructName ); MkStructMac( !:Alterant, 'Alter, StructName ); MkStructPred( !:Predicate, StructName ); MkStructMac( !:Creator, 'Create, StructName ); DsSize := 0; % Accumulate size, starting with the DefstructType. SlotAlist := NIL; if !:Include then % If including another struct, start after it. if Desc := GetDefstruct( !:Include ) then << DsSize := DsDescDsSize( Desc ); % Get slots of included type, modified by !:IncludeInit. SlotAlist := for each Init in DsDescSlotAlist( Desc ) collect << if !:IncludeInit and (NameValue := atsoc( car Init, !:IncludeInit )) then << Init := TotalCopy Init; SlotDescInitForm cdr Init := second NameValue >>; Init >> >> else TypeError( !:Include, "Defstruct !:Include", "a type id" ); % Define the Selector macros, and build the alist of slot ids. SlotAlist := append( SlotAlist, for each SlotSpec in rest Spec collect ProcessSlot( SlotSpec, !:Prefix, DsSize := DsSize+1 ) ); if Defstructp Structname then ErrorPrintF("*** Defstruct %r has been redefined", StructName); Put( StructName, 'Defstruct, % Stash the Structure Descriptor. CreateDefstructDescriptor( DsSize, !:Prefix, SlotAlist, !:Constructor, !:Alterant, !:Predicate, !:Creator, !:Include, !:IncludeInit ) ); return StructName end; % Turn slot secifications into (SlotName . SlotDescriptor) pairs. lisp procedure ProcessSlot( SlotSpec, Prefix, SlotNum ); begin scalar SlotName, SlotFn, It, OptList, InitForm; % Got a few possibilities to unravel. InitForm := OptList := NIL; % Only slot-name required. if atom SlotSpec then SlotName := SlotSpec % Bare slot-name, no default-init or options. else << SlotName := first SlotSpec; if It := rest SlotSpec then % Default-init and/or options provided. << % See if option immediately after name. while pairp It do It := first It; % Down to first atom. if idp It and memq( It, SlotOptions ) then % Option keyword? OptList := rest SlotSpec % Yes, no init-form. else << InitForm := second SlotSpec; % Init-form after keyword. OptList := rest rest SlotSpec % Options or NIL. >> >> >>; if not idp SlotName then % Slot id better be one. UsageTypeError( SlotName, 'Defstruct, "an id", "a SlotName" ); SlotFn := if Prefix eq "" then % Slot fns may have a prefix. SlotName else IdConcat( Prefix, Slotname ); % Defaults for options. !:Type := !:UserGet := !:UserPut := NIL; if OptList then % Process option list ProcessOptions( OptList, SlotOptions ); % Make Selector and Depositor unless overridden. if not !:UserGet then MkSelector( SlotFn, SlotNum ); if not !:UserPut then MkDepositor( SlotFn, SlotNum ); % Return the ( SlotName . SlotDescriptor ) pair. return SlotName . CreateSlotDescriptor( SlotNum, InitForm, SlotFn, !:Type, !:UserGet, !:UserPut ) end; % ////////////// Internal fns ////////////////////////////////// % Process defstruct and slot options, binding values of valid options. lisp procedure ProcessOptions( OptList, OptVarList ); begin scalar OptSpec, Option, OptArg; for each OptSpec in OptList do << if atom OptSpec then % Bare option id. << Option := OptSpec; OptArg := T >> else << Option := first OptSpec; OptArg := rest OptSpec; % List of args to option. if not rest OptArg then % Single arg, unlist it. OptArg := first OptArg >>; if memq( Option, OptVarList ) then set( Option, OptArg ) else UsageTypeError( Option, 'ProcessOptions, ("one of" . OptVarList . "is needed"), "an option id" ) >> end; lisp procedure GetDefstruct( StructId ); % Yank struct defn from id. begin scalar Desc; if Desc := get( StructId, 'Defstruct ) then return Desc % Return Struct defn. else TypeError( StructId, 'GetDefstruct, "a defstruct id" ) end; lisp procedure IdConcat( I1, I2 ); % Make two-part names. << if idp I1 then I1 := id2String I1; if idp I2 then I2 := id2String I2; intern concat( I1, I2 ) >>; % ////////////// Fn building fns /////////////////////////////// % Fn to build specific Structure Fns as macros which use generic macros. % The generic macro is called with the StructName and the original % list of arguments. % MacName( arg1, arg2, ... ) % => GenericMac( StructName, arg1, arg2, ... ) lisp procedure MkStructMac( MacName, GenericMac, StructName ); if MacName then % No macro if NIL name. putd( MacName, 'macro, list( 'lambda, '(MacroArgs), list( 'append, list( 'quote, list( GenericMac, StructName ) ), '(rest MacroArgs) ) ) ); % Fn to build specific Structure Predicates. lisp procedure MkStructPred( FnName, StructName ); putd( FnName, 'expr, list( 'lambda, '(PredArg), list( 'and, '(vectorp PredArg), list( 'eq, list('quote,StructName), '(DefstructType PredArg) ) ) ) ); % RHS selector (get fn) constructor. lisp procedure MkSelector( Name, Slotnum ); putd( Name, 'expr, list( 'lambda, '(Struct), List( 'getV, 'Struct, SlotNum ) ) ); % LHS depositor (put fn) constructor. lisp procedure MkDepositor( Name, Slotnum ); begin scalar PutName; PutName := intern concat( "PUT", id2string Name ); putd( PutName, 'expr, list( 'lambda, '(Struct Val), List( 'putV, 'Struct, SlotNum, 'Val ) ) ); put( Name, 'Assign!-Op, PutName ); return PutName end; % ////////////// Fns used by macros. /////////////////////////// % Generic macro for constructors, called with structure name and list % of slot-name:value-form pairs to merge with default-inits. % Returns vector constructor. macro procedure Make( ArgList ); begin scalar StructName, OverrideAlist, Slot, NameValue; StructName := second ArgList; OverrideAlist := rest rest ArgList; return append( % Return vector constructor. list( 'vector, list('quote,StructName) ), % Mark struct type as first element. % Build list of init forms for vector constructor. for each Slot in DsDescSlotAlist GetDefstruct StructName collect if NameValue := atsoc( car Slot, OverrideAlist ) then second NameValue else SlotDescInitForm cdr Slot ) end; % Generic Alterant macro, called with structure name, struct instance and % slot name:value alist. A list of depositor calls is returned, with a % PROGN wrapped around it and the struct instance at the end for a return % value. macro procedure Alter( ArgList ); begin scalar StructName, StructInstance, SlotValueDlist, SlotAlist, NameValue, Slot; StructName := second ArgList; StructInstance := third ArgList; SlotValueDlist := rest rest rest ArgList; SlotAlist := DsDescSlotAList GetDefstruct StructName; return append( append( '(PROGN), % wraparound PROGN. % List of depositor calls. for each NameValue in SlotValueDlist collect if Slot := atsoc( first NameValue, SlotAlist) then list( % Use depositors, which may be user fns, rather than PutV. IdConCat( 'PUT, SlotDescSlotFn cdr Slot ), StructInstance, second NameValue ) else TypeError( car NameValue, 'Alter, concat( "a slot of ", id2string StructName ) ) ), list( StructInstance ) ) % Value of PROGN is altered instance. end; % Generic Create macro, called with struct name and list of positional args % which are slot value forms. Returns struct vector constructor. macro procedure Create( ArgList ); begin scalar StructName, SlotValues, DsSize; StructName := second ArgList; SlotValues := rest rest ArgList; DsSize := DsDescDsSize GetDefstruct StructName; if DsSize = Length SlotValues then return append( list( 'VECTOR, list( 'quote, StructName ) ), % Mark with struct id. SlotValues ) else UsageTypeError( SlotValues, 'Create, BldMsg( "a list of length %p", DsSize ), concat( "an initializer for ", id2string StructName) ) end; % ////////////// Boot Defstruct structs. /////////////////////// % Chicken-and-egg problem, need some knowledge of Defstruct descriptor % structures before they are defined, in order to define them. CompileTime << MkSelector( 'DsDescDsSize, 1 ); MkStructMac( 'CreateDefstructDescriptor, 'Create, 'DefstructDescriptor ); MkStructMac( 'CreateSlotDescriptor, 'Create, 'SlotDescriptor ); put( 'DefstructDescriptor, 'Defstruct, % Abbreviated struct defns for boot. '[ DefstructDescriptor 9 ] ); % Just DsSize, for Create Fns. put( 'SlotDescriptor, 'Defstruct, '[ SlotDescriptor 6 ] ); >>; % Now really declare the Defstruct Descriptor structs. Defstruct( DefstructDescriptor( !:Prefix(DsDesc), !:Creator ), DsSize( !:Type int ), % (Upper Bound of vector.) Prefix( !:Type string ), SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) ConsName( !:Type fnId ), AltrName( !:Type fnId ), PredName( !:Type fnId ), CreateName( !:Type fnId ), Include( !:Type typeid ), InclInit( !:Type alist ) ); Defstruct( SlotDescriptor( !:Prefix(SlotDesc), !:Creator ), SlotNum( !:Type int ), InitForm( !:Type form ), SlotFn( !:Type fnId ), % Selector/Depositor id. SlotType( !:Type type ), % Hm... UserGet( !:Type boolean ), UserPut( !:Type boolean ) ); END; |
Added psl-1983/3-1/util/demo-defstruct.red version [d44c2e9a48].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Sample of use of <Fish.iact>DefStruct.RED % See <fish.iact>Defstruct.HLP Defstruct(Complex, R, I); Defstruct(Complex, R(0), I(0)); % Redefine to see what functions defined % Give 0 Inits C0:=MakeComplex(); ComplexP C0; C1:=MakeComplex(('R . 1), ('I . 2)); AlterComplex(C1,'(R . 2), '(I . 3)); Put('R,'Assign!-op,'PutR); % for LHS. R(C1):=3; I(C1):=4; C1; % Show use of Include Option. Defstruct(MoreComplex(!:Include(Complex)),Z(99)); Defstruct(MoreComplex(!:Include(Complex)),Z(99)); M0 := MakeMoreComplex(); M1:=MakeMoreComplex('R . 1, 'I . 2, ' Z . 3); R C1; R M1; |
Added psl-1983/3-1/util/destructure.sl version [eac54f3f17].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DESTRUCTURE.SL - Tools for destructuring and macro definition % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (de destructure-form (target path) (cond ((null target) nil) ((idp target) `((setq ,target ,path))) ((atom target) (destructure-form (ContinuableError 99 (BldMsg "Can't assign to %r" target) target) path)) (t (nconc (destructure-form (car target) `(car ,path)) (destructure-form (cdr target) `(cdr ,path)))))) (de flatten (U) (cond ((null U) nil) ((atom U) (list U)) ((null (car U)) (cons nil (flatten (cdr U)))) (t (append (flatten (car U)) (flatten (cdr U)))))) (fluid '(*defmacro-displaces)) ((lambda (ub-flg) (fluid '(*macro-displace)) (cond (ub-flg (setq *macro-displace t)))) % Only do if not already set (unboundp '*macro-displace)) (de defmacro-1 (U) % This, too, can be made more efficient if desired. Seems unnecessary, though. `(dm ,(cadr U) (***DEFMACRO-ARG***) (prog ,(flatten (caddr U)) ,.(destructure-form (caddr U) '(cdr ***DEFMACRO-ARG***)) (return ,(cond (*defmacro-displaces `(macro-displace ***DEFMACRO-ARG*** (progn ,@(cdddr U)))) (t `(progn ,@(cdddr U)))))))) (de macro-displace (u v) (cond (*macro-displace (rplacw u `(!%displaced-macro ',(cons (car u) (cdr u)) ,(macroexpand v)))) (t v))) (dm defmacro (u) (defmacro-1 u)) (dm defmacro-displace (u) ((lambda (*defmacro-displaces) (defmacro-1 u)) t)) (dm defmacro-no-displace (u) ((lambda (*defmacro-displaces) (defmacro-1 u)) nil)) (copyd '!%displaced-macro 'prog2) (setf (get '!%displaced-macro 'compfn) #'&comprogn) (defmacro desetq (U V) % a destructuring setq - should be made more efficient and robust `((lambda (***DESETQ-VAR***) ,.(destructure-form U '***DESETQ-VAR***) ***DESETQ-VAR***) ,V)) (fluid '(*macro-debug)) (defmacro-no-displace deflambda (nam vars . bod) (if *macro-debug % T => deflambdas are functions and can be traced, etc. `(de ,nam ,vars ,@bod) `(defmacro ,nam ,vars `((lambda ,',vars ,.',bod) ,.(list ,@vars))))) |
Added psl-1983/3-1/util/evalhook.build version [3b3d2082ab].
> > | 1 2 | CompileTime load(Useful, CLComp); in "evalhook.lsp"$ |
Added psl-1983/3-1/util/evalhook.lsp version [cca6c59ce9].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; EVALHOOK.LSP - Support for special evaluation ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 30 March 1982 ;;; Copyright (c) 1982 University of Utah ;;; (defvar evalhook () "Variable to be funcalled if not () when Eval is called") (fset 'old-eval (fsymeval 'eval)) ; Redefine Eval (defun eval (form) (if evalhook (let ((outer-evalhook evalhook)) ; Bind evalhook to (), then funcall it (let ((evalhook ())) (funcall outer-evalhook form))) (old-eval form))) ;;;; EVALHOOKFN - outer evaluation uses old-eval, inner evaluations use hook (defun evalhookfn (form hook) (let ((evalhook hook)) (old-eval form))) |
Added psl-1983/3-1/util/extended-char.sl version [ada4791f0f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Extender-Char.SL - 9-bit terminal input characters % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 August 1982 % % Changes: % 10/15/82: added M-X macro, for convenience % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Note: this file defines MACROS, so you may need to load it at compile-time. % Note: this file loads FAST-INT. (load fast-int common strings) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Extended Character Manipulation Functions (or Macros) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (ds X-Base (chr) % Return the base character corresponding to CHR. In other words, clear the % Meta and Control bits. (& chr 2#001111111)) (ds X-Zero-Base (chr) % Return the given character with its base code set to 0. (& chr 2#110000000)) (ds X-UnMeta (chr) % Turn off the Meta bit in the given character. (& chr 2#101111111)) (ds X-UnControl (chr) % Turn off the Control bit in the given character. (& chr 2#011111111)) (ds X-Meta? (chr) % Does CHR have the Meta bit set? (not (= (& chr 2#010000000) 0))) (ds X-Control? (chr) % Does CHR have the Control bit set? (not (= (& chr 2#100000000) 0))) (ds X-Set-Meta (chr) % Set the Meta bit in CHR. (| chr 2#010000000)) (ds X-Set-Control (chr) % Set the Control bit in CHR. (| chr 2#100000000)) % This version of "UpperCaseP" handles extended characters. (de X-UpperCaseP (chr) (UpperCaseP (X-Base chr))) % This version of "LowerCaseP" handles extended characters. (de X-LowerCaseP (chr) (LowerCaseP (X-Base chr))) (de X-Char-DownCase (chr) (let ((bits (X-Zero-Base chr)) (base (X-Base chr)) ) (| bits (Char-DownCase base)))) (de X-Char-UpCase (chr) (let ((bits (X-Zero-Base chr)) (base (X-Base chr)) ) (| bits (Char-UpCase base)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Extended Character Creation Macro % % Examples of legal uses: % (x-char a) => A % (x-char lower a) => a % (x-char control a) => C-A % (x-char c-a) => C-A % (x-char ^A) => (ascii control A - code 1) % (x-char meta control TAB) => C-M-Tab % (x-char control ^A) => C-^A (^A is ASCII code 1) % (x-char C-M-^A) => C-M-^A (^A is ASCII code 1) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (dm X-Char (form) (Create-Extended-Character (cdr form))) (de Create-Extended-Character (L) (let ((plist (gensym))) (for (in x L) (do (cond ((IdP x) (X-Char-process-id x plist)) ((FixP x) (X-Char-process-fix x plist)) (t (put plist 'error T)) ))) (let ((base (get plist 'base))) (if (or (get plist 'error) (null base)) (StdError (BldMsg "Invalid X-CHAR: %p" (cons 'X-CHAR L)))) (if (and (get plist 'Lower) (>= base #\A) (<= base #\Z)) (setf base (+ base 2#100000))) (if (get plist 'Control) (setf base (X-Set-Control base))) (if (get plist 'Meta) (setf base (X-Set-Meta base))) base ))) (de X-char-process-id (id plist) (prog (temp id2) (cond ((eq id 'Meta) (put plist 'Meta T)) ((eq id 'Control) (put plist 'Control T)) ((eq id 'Lower) (put plist 'Lower T)) ((eq id 'Return) (put plist 'base 13)) ((< (setf temp (ID2Int id)) 128) (put plist 'base temp)) ((setf temp (get id 'CharConst)) (put plist 'base temp)) ((and (>= (size (setf temp (id2string id))) 2) (= (indx temp 1) #\-)) (setf id2 (intern (substring temp 2 (+ 1 (size temp))))) (selectq (indx temp 0) (#\M (put plist 'Meta T) (X-char-process-id id2 plist)) (#\C (put plist 'Control T) (X-char-process-id id2 plist)) (t (put plist 'error T)) )) ((and (= (size temp) 1) (= (indx temp 0) #\^)) (put plist 'Ascii-Control T) (put plist 'base (& (indx temp 1) 2#11111)) ) (t (put plist 'error T)) ))) (de X-Char-process-fix (x plist) (cond ((and (>= x 0) (<= x 9)) (put plist 'base (+ x #\0))) (t (put plist 'error T)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % X-Chars %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generate a list of character codes from a list of "character descriptors", % which are argument lists to the X-CHAR macro. (dm x-chars (chlist) (cons 'list (for (in x (cdr chlist)) (collect (cons 'x-char (if (pairp x) x (list x))))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Printable names for extended characters: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(character-name-table)) % An association list of (character code . name), used by x-char-name. (setf character-name-table '( (8#0 . "Null") (8#7 . "Bell") (8#10 . "Backspace") (8#11 . "Tab") (8#12 . "Newline") (8#15 . "Return") (8#33 . "Escape") (8#40 . "Space") (8#177 . "Rubout") )) (de x-char-name (ch) % Return a string giving the name for an extended character. (cond ((not (FixP ch)) (BldMsg "<%o>" ch)) ((atsoc ch character-name-table) (cdr (atsoc ch character-name-table))) ((X-Control? ch) (string-concat "C-" (x-char-name (X-UnControl ch)))) ((X-Meta? ch) (string-concat "M-" (x-char-name (X-UnMeta ch)))) ((GraphicP ch) (string ch)) ((and (>= ch 0) (< ch (char space))) (string-concat "^" (x-char-name (LXor ch 8#100)))) (t (BldMsg "<%o>" ch)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % M-X Macro %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro m-x (command-string) `(list (x-char M-X) ,command-string)) |
Added psl-1983/3-1/util/f-dstruct.build version [3ea6ea7499].
> > | 1 2 | CompileTime LOAD(DEFSTRUCT,SYSLISP,INUM,FAST!-VECTOR); in "f-dstruct.red"$ |
Added psl-1983/3-1/util/f-dstruct.red version [6a29e1ffaf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Fast Defstruct Improvements; % M.L. Griss % Load after Defstruct to redefine basic Selectors FLUID '(DefGetFn!* DefPutFn!* !*DefFnAsExpr); LoadTime << DefGetFn!*:='IGetv; DefPutFn!*:='IPutv; !*DefFnAsExpr:=NIL;>>; % RHS selector (get fn) constructor. lisp procedure MkSelector( Name, Slotnum ); If !*DefFnAsExpr then putd( Name, 'expr, list( 'lambda, '(Struct), List( DefGetFn!*, 'Struct, SlotNum ) ) ) else Putd(name,'macro, list('lambda,'(struct), List('LIST,MkQuote DefGetFn!*,'(Cadr Struct),MkQuote SlotNum))); % LHS depositor (put fn) constructor. lisp procedure MkDepositor( Name, Slotnum ); begin scalar PutName; PutName := intern concat( "PUT", id2string Name ); If !*DefFnAsExpr then putd( PutName, 'expr, list( 'lambda, '(Struct Val), List( DefPutFn!*, 'Struct, SlotNum, 'Val ) ) ) else Putd(PutName,'macro, list('lambda,'(struct), List('List,MkQuote DefPutFn!*, '(Cadr Struct), MkQuote SlotNum, '(Caddr Struct) )) ); put( Name, 'Assign!-Op, PutName ); return PutName end; END; |
Added psl-1983/3-1/util/fast-arith.build version [f58190493c].
> > | 1 2 | CompileTime load Syslisp; in "fast-arith.red"$ |
Added psl-1983/3-1/util/fast-arith.red version [bbb5809064].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % speed up generic arith for V3 % MLG, 9:25pm Friday, 21 May 1982 ON SYSLISP; SYSLSP PROCEDURE FASTPLUS2(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:= WPLUS2(I1,I2)) EQ X THEN RETURN X; Return Oldplus2(I1,I2); End; SYSLSP PROCEDURE FASTTIMES2(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:= WTIMES2(I1,I2)) EQ X Then return X; RETURN OLDTimes2(I1,I2); END; SYSLSP PROCEDURE FASTDIFFERENCE(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:=WDIFFERENCE(I1,I2)) EQ X Then return x; RETURN OldDifference(I1,I2); END; SYSLSP PROCEDURE FASTADD1 I1; Begin Scalar x; IF INTP(I1) AND (x:= IADD1 I1) EQ x then Return x; RETURN OldAdd1 I1; END; SYSLSP PROCEDURE FASTSUB1 I1; Begin Scalar x; IF INTP(I1) AND (X:= ISUB1 I1) EQ X then Return x; RETURN OldSub1 I1; end; SYSLSP PROCEDURE FASTZerop I1; IF INTP(I1) THEN WEQ(I1, 0) else OldZerop I1; SYSLSP PROCEDURE FASTMinusp I1; IF INTP(I1) THEN WLESSP(I1, 0) ELSE OldMinusp I1; SYSLSP PROCEDURE FASTGreaterp(I1,I2); IF INTP(I1) AND INTP(I2) THEN WGREATERP(I1,I2) ELSE OldGreaterp I1; SYSLSP PROCEDURE FASTlessP(I1,I2); IF INTP(I1) AND INTP(I2) THEN WLESSP(I1,I2) ELSE OldLessP I1; off syslisp; lisp procedure Faster; Begin !*usermode:=NIL; COPYD('OLDPlus2,'Plus2); COPYD('OLDTimes2,'Times2); COPYD('OLDDifference,'Difference); COPYD('OLDZeroP,'Zerop); COPYD('OLDLessP,'LessP); COPYD('OLDGreaterP,'GreaterP); COPYD('OLDAdd1,'Add1); COPYD('OLDSub1,'Sub1); COPYD('Plus2,'FastPlus2); COPYD('Times2,'FastTimes2); COPYD('Difference,'FastDifference); COPYD('ZeroP,'FastZerop); COPYD('LessP,'FastLessP); COPYD('GreaterP,'FastGreaterP); COPYD('Add1,'FastAdd1); COPYD('Sub1,'FastSub1); end; END; |
Added psl-1983/3-1/util/fast-evectors.sl version [fb37b1776a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Fast-EVectors.sl -- Fast compiled EVector operations %%% Author: Cris Perdue %%% Date: 8 Apr 1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% This is a facility so the user can generate code to access %%% evectors that runs fast. To use this facility, LOAD (don't %%% IMPORT) it at compiletime. It does an (on fast-evectors), %%% turning on the generation of faster code. The feature may be %%% turned off and on by the user. The affected evector %%% functions are EGetV, EPutV, and ESizeV. (compiletime (load if-system data-machine)) (put 'fast-evectors 'simpfg '((t (enable-fast-evectors)) (nil (disable-fast-evectors)))) (if_system VAX (de enable-fast-evectors () (DefList '((EGetV (lambda (V I) (EVecItm (EVecInf V) I))) (EPutV (lambda (V I X) (PutEVecItm (EVecInf V) I X))) (ESizeV (lambda (V) (EVecLen (EVecInf V))))) 'CMacro))) (if_system PDP10 % tags don't need to be stripped on the PDP10 (de enable-fast-evectors () (DefList '((EGetV (lambda (V I) (EVecItm V I))) (EPutV (lambda (V I X) (PutEVecItm V I X))) (ESizeV (lambda (V) (EVecLen V)))) 'CMacro))) (if_system MC68000 % tags don't need to be stripped on the 68000 (de enable-fast-evectors () (DefList '((EGetV (lambda (V I) (EVecItm V I))) (EPutV (lambda (V I X) (PutEVecItm V I X))) (ESizeV (lambda (V) (EVecLen V)))) 'CMacro))) (de disable-fast-evectors () (remprop 'egetv 'cmacro) (remprop 'eputv 'cmacro) (remprop 'esizev 'cmacro)) (loadtime (on fast-evectors)) |
Added psl-1983/3-1/util/fast-int.sl version [0882fca332].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Fast-Int.SL - Integer Operators (Compiled "Open") % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 September 1982 % Revised: 11 January 1983 % % This file survives only for backward compatibility. % It has been replaced by NUMERIC-OPERATORS. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load numeric-operators) (bothtimes (on fast-integers)) |
Added psl-1983/3-1/util/fast-strings.sl version [33111c7fc8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FAST-STRINGS - Fast (unchecked) version of String Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Load this at compile-time to make compiled invocations of the following % functions fast (and unchecked): % % (string-fetch s i) % (string-store s i ch) % (string-length s) % (string-upper-bound s) % (string-empty? s) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load slow-strings) % for the interpreted versions (CompileTime (load fast-vector)) % for machine-dependent primitives (put 'string-fetch 'cmacro '(lambda (s i) (igets s i))) (put 'string-store 'cmacro '(lambda (s i c) (iputs s i c))) (put 'string-length 'cmacro '(lambda (s) (Wplus2 (isizes s) 1))) (put 'string-upper-bound 'cmacro '(lambda (s) (isizes s))) (put 'string-empty? 'cmacro '(lambda (s) (WLessP (isizes s) 0))) |
Added psl-1983/3-1/util/fast-struct.lsp version [71cbe0b1b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (defstruct-define-type :fast-vector (:named :named-fast-vector) ; but probably not much point (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ,@arg)) (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil)) (:ref (n description arg) description ;ignored `(igetv ,arg ,n))) ;added for PSL (defstruct-define-type :named-fast-vector (:keywords :make-vector) :named (:overhead 1) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ',(defstruct-description-name) ,@arg)) (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil)) (:ref (n description arg) description ;ignored `(igetv ,arg ,(add1 n)))) (defstruct-define-type hashed-list (:named :named-hashed-list) (:cons (arg description etc) :list description ;ignored etc ;ignored `(hlist . ,arg)) (:ref (n description arg) description ;ignored #+Multics `(,(let ((i (\ n 4))) (cond ((= i 0) 'car) ((= i 1) 'cadr) ((= i 2) 'caddr) (t 'cadddr))) ,(do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(add1 n)))) ; #-Multics `(nth ,n ,arg))) (defstruct-define-type :named-hashed-list :named (:overhead 1) (:cons (arg description etc) :list etc ;ignored `(hlist ',(defstruct-description-name) . ,arg)) (:ref (n description arg) description ;ignored ; #+Multics `(,(let ((i (\ (1+ n) 4))) ; (cond ((= i 0) 'car) ; ((= i 1) 'cadr) ; ((= i 2) 'caddr) ; (t 'cadddr))) ; ,(do ((a arg `(cddddr ,a)) ; (i (// (1+ n) 4) (1- i))) ; ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(+ n 2)))) ; #-Multics `(nth ,(1+ n) ,arg))) (defstruct-define-type :hashed-list* (:cons (arg description etc) :list description ;ignored etc ;ignored `(hcons . ,arg)) (:ref (n description arg) ; PSL change 1- ==> sub1 (let ((size (sub1 (defstruct-description-size)))) ; (let ((size (1- (defstruct-description-size)))) #+Multics (do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) (let* ((i (\ n 4)) (a (cond ((= i 0) a) ((= i 1) `(cdr ,a)) ((= i 2) `(cddr ,a)) (t `(cdddr ,a))))) (if (< n size) `(car ,a) a)))) #-Multics (if (< n size) ; PSL change incompatible NTH `(nth ,arg ,(add1 n)) `(pnth ,arg ,(add1 n))))) ; `(nth ,n ,arg) ; `(nthcdr ,n ,arg)))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type hashed-list* cannot include another" (defstruct-description-name))) nil)) (defstruct-define-type :hashed-tree (:cons (arg description etc) :list etc ;ignored (if (null arg) (defstruct-error "defstruct cannot make an empty tree" (defstruct-description-name))) (make-hashed-tree-for-defstruct arg (defstruct-description-size))) (:ref (n description arg) (do ((size (defstruct-description-size)) (a arg) (tem)) (()) (cond ((= size 1) (return a)) ; PSL change // ==> / ((< n (setq tem (/ size 2))) ; ((< n (setq tem (// size 2))) (setq a `(car ,a)) (setq size tem)) (t (setq a `(cdr ,a)) (setq size (- size tem)) (setq n (- n tem)))))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type tree cannot include another" (defstruct-description-name))) nil)) (defun make-hashed-tree-for-defstruct (arg size) (cond ((= size 1) (car arg)) ((= size 2) `(hcons ,(car arg) ,(cadr arg))) (t (do ((a (cdr arg) (cdr a)) ; PSL change // ==> /, 1- ==> sub1 (m (/ size 2)) (n (sub1 (/ size 2)) (sub1 n))) ; (m (// size 2)) ; (n (1- (// size 2)) (1- n))) ((zerop n) `(hcons ,(make-hashed-tree-for-defstruct arg m) ,(make-hashed-tree-for-defstruct a (- size m)))))))) |
Added psl-1983/3-1/util/fast-vector.build version [5a4073d5af].
> > > > > | 1 2 3 4 5 | CompileTime << load If!-System; load Syslisp; >>; in "fast-vector.red"$ |
Added psl-1983/3-1/util/fast-vector.red version [21e4030132].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>FAST-VECTOR.RED.1, 18-Mar-82 21:26:35, Edit by GRISS % Fast Vector operations imports '(Syslisp); % Uses syslisp macros CopyD('IGetV, 'GetV); CopyD('IPutV, 'PutV); CopyD('ISizeV, 'Size); Put('IGetV, 'Assign!-Op, 'IPutV); CopyD('IGetS, 'Indx); CopyD('IPutS, 'SetIndx); CopyD('ISizeS, 'Size); Put('IGetS, 'Assign!-Op, 'IPutS); if_system(VAX, DefList('((IGetV (lambda (V I) (VecItm (VecInf V) I))) (IPutV (lambda (V I X) (PutVecItm (VecInf V) I X))) (IGetS (lambda (S I) (StrByt (StrInf S) I))) (IPutS (lambda (S I X) (PutStrByt (StrInf S) I X))) (ISizeV (lambda (V) (VecLen (VecInf V)))) (ISizeS (lambda (V) (StrLen (StrInf V))))), 'CMacro)); if_system(PDP10, % tags don't need to be stripped on the PDP10 DefList('((IGetV (lambda (V I) (VecItm V I))) (IPutV (lambda (V I X) (PutVecItm V I X))) (IGetS (lambda (S I) (StrByt S I))) (IPutS (lambda (S I X) (PutStrByt S I X))) (ISizeV (lambda (V) (VecLen V))) (ISizeS (lambda (S) (StrLen S)))), 'CMacro)); if_system(MC68000, % tags don't need to be stripped on the 68000 DefList('((IGetV (lambda (V I) (VecItm V I))) (IPutV (lambda (V I X) (PutVecItm V I X))) (IGetS (lambda (S I) (StrByt S I))) (IPutS (lambda (S I X) (PutStrByt S I X))) (ISizeV (lambda (V) (VecLen V))) (ISizeS (lambda (S) (StrLen S)))), 'CMacro)); END; |
Added psl-1983/3-1/util/fast-vectors.sl version [a0c0336965].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FAST-VECTORS - Fast (unchecked) version of Vector Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Load this at compile-time to make compiled invocations of the following % functions fast (and unchecked): % % (vector-fetch v i) % (vector-store v i x) % (vector-size v) % (vector-upper-bound v) % (vector-empty? v) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load slow-vectors) % for the interpreted versions (CompileTime (load fast-vector)) % for machine-dependent primitives (put 'vector-fetch 'cmacro '(lambda (v i) (igetv v i))) (put 'vector-store 'cmacro '(lambda (v i x) (iputv v i x))) (put 'vector-size 'cmacro '(lambda (v) (Wplus2 (isizev v) 1))) (put 'vector-upper-bound 'cmacro '(lambda (v) (isizev v))) (put 'vector-empty? 'cmacro '(lambda (v) (WLessP (isizev v) 0))) |
Added psl-1983/3-1/util/find.build version [6cc7123ca2].
> > > | 1 2 3 | % Build the FIND utility Imports '(Gsort); in "find.red"$ |
Added psl-1983/3-1/util/find.red version [7e91df4da4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. FIND.RED - Start of recognition and search OBLIST functions %. M. L. Griss % 30 Dec 1982, Mlg % Move IMPORTS etc to BUILD file Fluid '(CollectID!* TestString!*); Lisp Procedure FindPrefix(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindPrefix1; Return IDSort CollectId!* end; Lisp procedure FindPrefix1 x; If IsPrefixString(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; Lisp Procedure FindSuffix(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindSuffix1; Return IDSort CollectId!* end; Lisp procedure FindSuffix1 x; If IsSuffixString(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; Lisp procedure IsPrefixString(s1,s2); %. test if exact string prefix begin scalar l1,l2,L; l1:=size s1; l2:=size s2; L:=0; if l1> l2 then return NIL; Loop: if not( s1[L] eq s2[L] ) then return NIL; if (L:=add1 L)> L1 then return T; goto loop; end; Lisp procedure IsSuffixString(s1,s2); %. test if exact string prefix begin scalar l1,l2,L; l1:=size s1; l2:=size s2; if l1> l2 then return NIL; Loop: if not( s1[L1] eq s2[L2] ) then return NIL; if L1<=0 then return T; l1:=L1-1; L2:=L2-1; goto loop; end; % More extensive String matcher procedure StringMatch(p,s); StringMatch1(p,0,size(p),s,0,size(s)); procedure StringMatch1(p,p1,p2,s,s1,s2); Begin scalar c; L1: % test Range if p1>p2 then return (if s1>s2 then T else NIL) else if s1>s2 then return NIL; % test if % something if (c:=p[p1]) eq char !% then goto L3; L2: % exact match if c eq s[s1] then <<p1:=p1+1; s1:=s1+1; goto L1>>; return NIL; L3: % special cases p1:=p1+1; if p1>p2 then return stderror "pattern ran out in % case of StringMatch"; c:=p[p1]; if c eq char !% then goto L2; if c eq char !? then <<p1:=p1+1; s1:=s1+1; goto L1>>; if c eq char !* then % 0 or more vs 1 or more return <<while not(c:=StringMatch1(p,p1+1,p2,s,s1,s2)) and s1<=s2 do s1:=s1+1; c>>; Return Stderror Bldmsg(" %% %r not known in StringMatch",int2id c); end; Lisp Procedure Find(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindStringMatch; Return IDSort CollectId!* end; Lisp procedure FindStringMatch x; If StringMatch(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; End; |
Added psl-1983/3-1/util/for-macro.sl version [0dffff4e6f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % FOR-MACRO.SL - fancy FOR loop % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>FOR-MACRO.SL.3, 7-Oct-82 15:46:11, Edit by BENSON % Changed NULL tests to ATOM tests % Fancy for loop. Similar to MACLISP and clones' loop function, but with % LISPier "syntax" and slightly reduced functionality and concommitant hair. (fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions* for-body* for-epilogue* for-result*)) (dm for (U) (for-build-loop (cdr U) 'do-loop 'let)) (defmacro for* U (for-build-loop U 'do-loop* 'let*)) (de for-build-loop (U loop-fn let-fn) % Simply calls the function stored under the for-function property of the % keyword at the begining of each clause, and then builds the DO form from % the fluids below. These are in TCONC format. The clause specific % functions should do their stuff by TCONC/LCONCing onto these variables. % The clause specific functions take one argument, the list of arguments to % the clause keyword. (let ((for-outside-vars* (list nil)) (for-vars* (list nil)) (for-tests* (list nil)) (for-prologue* (list nil)) (for-conditions* (list nil)) (for-body* (list nil)) (for-epilogue* (list nil)) (for-result* (list nil))) (foreach clause in U do (process-for-clause clause)) % "UnTCONCify" everybody (setf for-outside-vars* (car for-outside-vars*) for-vars* (car for-vars*) for-tests* (car for-tests*) for-prologue* (car for-prologue*) for-conditions* (car for-conditions*) for-body* (car for-body*) for-epilogue* (car for-epilogue*) for-result* (car for-result*)) % Now, back to work... (if for-tests* (setf for-tests* (if (cdr for-tests*) (cons 'or for-tests*) (car for-tests*)))) (when for-conditions* (setf for-conditions* (if (cdr for-conditions*) (cons 'and for-conditions*) (car for-conditions*))) (setf for-body* `((when ,for-conditions* ,.for-body*)))) (if (and for-result* (cdr for-result*)) (StdError "For loops may only return one value")) % msg needs improving % Finally build up the form to return (let ((form `(,loop-fn ,for-vars* ,for-prologue* (,for-tests* ,.for-epilogue* ,.for-result*) ,.for-body*))) (if for-outside-vars* `(,let-fn ,for-outside-vars* ,form) form)))) (de process-for-clause (clause) (let ((op (car clause)) fn) (cond ((atom clause) (process-for-clause (ContinuableError 99 (BldMsg "For clauses may not be atomic: %r." clause) clause))) ((setf fn (get op 'for-function)) (call fn (cdr clause))) (t (ContinuableError 99 (BldMsg "Unknown for clause operator: %r." op) op))))) (de for-in-function (clause) (let ((var (car clause)) (lst (cadr clause)) (fn (and (cddr clause) (caddr clause))) (dummy (gensym))) (tconc for-outside-vars* dummy) (tconc for-vars* `(,var (progn (setf ,dummy ,lst) (if (pairp ,dummy) ,(if fn `(,fn (car ,dummy)) `(car ,dummy)) ())) (progn (setf ,dummy (cdr ,dummy)) (if (pairp ,dummy) ,(if fn `(,fn (car ,dummy)) `(car ,dummy)) ())))) (tconc for-tests* `(atom ,dummy)))) (de for-on-function (clause) (let ((var (car clause)) (lst (cadr clause))) (tconc for-vars* `(,var ,lst (cdr ,var))) (tconc for-tests* `(atom ,var)))) (de for-from-function (clause) (let* ((var (car clause)) (var1 (if (pairp var) (car var) var)) (clause (cdr clause)) (init (if (pairp clause) (or (pop clause) 1) 1)) (fin (if (pairp clause) (pop clause) nil)) (fin-var (if (and fin (not (numberp fin))) (gensym) nil)) (step (if (pairp clause) (car clause) 1)) (step-var (if (and step (not (numberp step))) (gensym) nil))) (tconc for-vars* (list* var init (cond (step-var `((plus2 ,var1 ,step-var))) ((zerop step) nil) ((onep step) `((add1 ,var1))) ((eqn step -1) `((sub1 ,var1))) (t `((plus ,var1 ,step)))))) (if fin-var (tconc for-vars* `(,fin-var ,fin))) (if step-var (tconc for-vars* `(,step-var ,step))) (cond (step-var (tconc for-tests* `(if (minusp ,step-var) (lessp ,var1 ,(or fin-var fin)) (greaterp ,var1 ,(or fin-var fin))))) ((null fin)) ((minusp step) (tconc for-tests* `(lessp ,var1 ,(or fin-var fin)))) (t (tconc for-tests* `(greaterp ,var1 ,(or fin-var fin))))))) (de for-for-function (clause) (tconc for-vars* clause)) (de for-with-function (clause) (lconc for-vars* (append clause nil))) % copy it for safety (de for-initially-function (clause) (lconc for-prologue* (append clause nil))) % copy it for safety (de for-finally-function (clause) (lconc for-epilogue* (append clause nil))) % copy it for safety (de for-do-function (clause) (lconc for-body* (append clause nil))) % copy it for safety (de for-collect-function (clause) (let ((tail (gensym))(reslt)) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (cdr (rplacd ,tail (ncons ,(car clause))))) (setf ,reslt (setf ,tail (ncons ,(car clause)))))))) (de for-conc-function (clause) (let ((reslt)(tail (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (LastPair (rplacd ,tail ,(car clause)))) (setf ,reslt ,(car clause)) (setf ,tail (LastPair ,reslt)))))) (de for-join-function (clause) (let ((reslt)(tail (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (LastPair (rplacd ,tail (append ,(car clause) nil)))) (setf ,reslt (append ,(car clause) nil)) (setf ,tail (LastPair ,reslt)))))) (defmacro-no-displace def-for-basic-return-function (name var init exp bod) `(de ,name (clause) (let ((reslt)) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt ,,init))) (setf reslt (gensym)) (tconc for-vars* `(,reslt ,,init)) (tconc for-result* reslt)) (tconc for-body* ,(subst 'reslt var (subst '(car clause) exp bod)))))) (def-for-basic-return-function for-union-function reslt nil exp `(setf ,reslt (union ,reslt ,exp))) (def-for-basic-return-function for-unionq-function reslt nil exp `(setf ,reslt (unionq ,reslt ,exp))) (de for-intersection-function (clause) (let ((reslt)(flg (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* flg) (tconc for-body* `(setf ,reslt (if ,flg (intersection ,reslt ,(car clause)) (setf ,flg t) ,(car clause)))))) (de for-intersectionq-function (clause) (let ((reslt)(flg (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* flg) (tconc for-body* `(setf ,reslt (if ,flg (intersectionq ,reslt ,(car clause)) (setf ,flg t) ,(car clause)))))) (def-for-basic-return-function for-adjoin-function reslt nil exp `(setf ,reslt (adjoin ,exp ,reslt))) (def-for-basic-return-function for-adjoinq-function reslt nil exp `(setf ,reslt (adjoinq ,exp ,reslt))) (def-for-basic-return-function for-count-function reslt 0 exp `(if ,exp (incr ,reslt))) (def-for-basic-return-function for-sum-function reslt 0 exp `(incr ,reslt ,exp)) (def-for-basic-return-function for-product-function reslt 1 exp `(setf ,reslt (times ,reslt ,exp))) (def-for-basic-return-function for-maximize-function reslt nil exp `(setf ,reslt (if ,reslt (max ,reslt ,(car clause)) ,(car clause)))) (def-for-basic-return-function for-minimize-function reslt nil exp `(setf ,reslt (if ,reslt (min ,reslt ,(car clause)) ,(car clause)))) (de for-always-function (clause) (tconc for-body* `(if (null ,(if (cdr clause) `(and ,@clause) (car clause))) (return nil))) (tconc for-result* t)) (de for-never-function (clause) (tconc for-body* `(if ,(if (cdr clause) `(or ,@clause) (car clause)) (return nil))) (tconc for-result* t)) (de for-thereis-function (clause) (let ((temp (gensym))) (tconc for-result* nil) (tconc for-vars* temp) (tconc for-body* `(if (setf ,temp ,(car clause)) (return ,temp))))) (de for-returns-function (clause) (tconc for-result* (if (cdr clause) (cons 'progn clause) (car clause)))) (de for-while-function (clause) (lconc for-tests* (foreach u in clause collect `(null ,u)))) (de for-until-function (clause) (lconc for-tests* (append clause nil))) % copy for safety (de for-when-function (clause) (lconc for-conditions* (append clause nil))) % copy for safety (de for-unless-function (clause) (lconc for-conditions* (foreach u in clause collect `(not ,u)))) (deflist `( (in ,#'for-in-function) (on ,#'for-on-function) (from ,#'for-from-function) (for ,#'for-for-function) (as ,#'for-for-function) (with ,#'for-with-function) (initially ,#'for-initially-function) (finally ,#'for-finally-function) (do ,#'for-do-function) (doing ,#'for-do-function) (collect ,#'for-collect-function) (collecting ,#'for-collect-function) (conc ,#'for-conc-function) (concing ,#'for-conc-function) (join ,#'for-join-function) (joining ,#'for-join-function) (count ,#'for-count-function) (counting ,#'for-count-function) (sum ,#'for-sum-function) (summing ,#'for-sum-function) (product ,#'for-product-function) (maximize ,#'for-maximize-function) (maximizing ,#'for-maximize-function) (minimize ,#'for-minimize-function) (minimizing ,#'for-minimize-function) (union ,#'for-union-function) (unionq ,#'for-unionq-function) (intersection ,#'for-intersection-function) (intersectionq ,#'for-intersectionq-function) (adjoin ,#'for-adjoin-function) (adjoinq ,#'for-adjoinq-function) (always ,#'for-always-function) (never ,#'for-never-function) (thereis ,#'for-thereis-function) (returns ,#'for-returns-function) (returning ,#'for-returns-function) (while ,#'for-while-function) (until ,#'for-until-function) (when ,#'for-when-function) (unless ,#'for-unless-function) ) 'for-function) |
Added psl-1983/3-1/util/format.red version [2984850046].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Format.RED - Formatted print routine % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % CompileTime << load(Syslisp, Fast!-Vector); flag('(format!-freshline format1 format2 clear!-string!-write return!-string!-write), 'internalfunction); fluid '(FormatForFormat!* string!-write!-channel next!-string!-write!-char string!-write!-buffer); >>; % First, lambda-bind FormatForFormat!* lisp procedure Format(Stream, FormatForFormat!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); Format1(Stream, FormatForFormat!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); % Then, push all the registers on the stack and set up a pointer to them lap '((!*entry Format1 expr 15) (!*PUSH (reg 3)) (!*LOC (reg 2) (frame 1)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*CALL Format2) (!*EXIT 14) ); on SysLisp; % Finally, actual Format, with 2 arguments, stream and % pointer to array of parameters syslsp procedure Format2(Stream, FormatArgs); %. Formatted print % % If the character is not one of these (either upper or lower case), then an % error occurs. % begin scalar UpLim, I, Ch, UpCh; if Stream eq NIL then << Stream := lispvar string!-write!-channel; clear!-string!-write() >> else if Stream eq T then Stream := LispVar OUT!*; UpLim := StrLen StrInf LispVar FormatForFormat!*; I := 0; while I <= UpLim do << Ch := StrByt(StrInf LispVar FormatForFormat!*, I); if Ch neq char !~ then ChannelWriteChar(Stream, Ch) else begin I := I + 1; Ch := StrByt(StrInf LispVar FormatForFormat!*, I); UpCh := if Ch >= char lower A and Ch <= char lower Z then IPlus2(IDifference(Ch, char lower A), char A) else Ch; case UpCh of char A: << ChannelPrin2(Stream, FormatArgs[0]); FormatArgs := &FormatArgs[StackDirection] >>; char S: << ChannelPrin1(Stream, FormatArgs[0]); FormatArgs := &FormatArgs[StackDirection] >>; char D: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 10); FormatArgs := &FormatArgs[StackDirection] >>; char B: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 2); FormatArgs := &FormatArgs[StackDirection] >>; char O: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 8); FormatArgs := &FormatArgs[StackDirection] >>; char X: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 16); FormatArgs := &FormatArgs[StackDirection] >>; char !~: ChannelWriteChar(Stream, char !~); char !%: ChannelWriteChar(Stream, char EOL); char '!&: format!-freshline Stream; default: StdError BldMsg('"Unknown character code for Format: %r", MkID Ch); end; end; I := I + 1 >>; if Stream eq LispVar string!-write!-channel then return return!-string!-write(); end; off SysLisp; lisp procedure format!-freshline Stream; (lambda out!*; if IGreaterP(Posn(), 0) then ChannelWriteChar(Stream, char EOL))(Stream); lisp procedure Ferror(Condition, FMT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); Error(Condition, Format(NIL, FMT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13)); lisp procedure string!-write!-char(stream, ch); if IGEQ(next!-string!-write!-char, 5000) then StdError "String overflow in FORMAT" else << next!-string!-write!-char := iadd1 next!-string!-write!-char; iputs(string!-write!-buffer, next!-string!-write!-char, ch) >>; lisp procedure clear!-string!-write(); << channelwritechar(string!-write!-channel, char EOL); next!-string!-write!-char := -1 >>; lisp procedure return!-string!-write(); begin scalar x, y; y := 0; next!-string!-write!-char := iadd1 next!-string!-write!-char; x := make!-string(next!-string!-write!-char, char NULL); while ILEQ(y, next!-string!-write!-char) do << iputs(x, y, igets(string!-write!-buffer, y)); y := iadd1 y >>; return x; end; string!-write!-buffer := make!-string(5000, char NULL); specialreadfunction!* := 'WriteOnlyChannel; specialwritefunction!* := 'string!-write!-char; specialclosefunction!* := 'IllegalStandardChannelClose; string!-write!-channel := open("", 'special); (lambda (x); << LineLength 10000; WRS x >> )(WRS string!-write!-channel); END; |
Added psl-1983/3-1/util/graph-tree.build version [3abf483c84].
> > | 1 2 | compiletime <<load useful>>; in "graph-tree.sl"$ |
Added psl-1983/3-1/util/graph-tree.sl version [61511a059b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Needs USEFUL at compile time (fluid '(graph-nodes* node-index*)) (de graph-to-tree (u) (let ((graph-nodes* nil)(node-index* 0)) (graph-to-tree-1 u))) (de graph-to-tree-1 (u) (let ((x)) (cond ((not (or (pairp u) (vectorp u))) u) ((setf x (atsoc u graph-nodes*)) (when (null (cdr x)) (setf (cdr x) (incr node-index*))) (newid (bldmsg "<%w>" (cdr x)))) (t (let* ((p (ncons u)) (graph-nodes* (cons p graph-nodes*)) (v (if (vectorp u) (for (from i 0 (upbv u)) (with (v (mkvect (upbv u)))) (do (setf (getv v i) (graph-to-tree-1 (getv u i)))) (returns v)) (cons (graph-to-tree-1 (car u)) (graph-to-tree-1 (cdr u)))))) (if (cdr p) (list (newid (bldmsg "<%w>:" (cdr p))) v) v)))))) (de cprint (u) (let ((currentscantable* lispscantable*)) (prettyprint (graph-to-tree u)) nil)) |
Added psl-1983/3-1/util/gsort.build version [bb407f4173].
> > | 1 2 | CompileTime load Syslisp; in "gsort.red"$ |
Added psl-1983/3-1/util/gsort.red version [4d18fbc016].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %=================================================================== % Simple sorting functions for PSL strings and Ids % use with FindPrefix and FindSuffix % MLG, 8:16pm Monday, 14 December 1981 %=================================================================== % Revision History % % Edit by Cris Perdue, 26 Jan 1983 1343-PST % Fixed the order of arguments in one call to make GMergeSort stable. % MLG, 2 Jan 1983 % Changed IDSORT form Macro to procedure, so that % it could be redefined for experiments with alternate GSORT % Affected RCREF and FIND lisp procedure StringCompare(S1,S2); % Returns 1,0,-1 for S1<S2,S1=S2,S1>S2 % String Comparison Begin scalar L1,L2,I,L; L1:=Size(S1); L2:=Size(S2); L:=MIN2(L1,L2); I:=0; loop: If I>L then return(If L1 <L2 then 1 else if L1 > L2 then -1 else 0); if S1[I] < S2[I] then return 1; if S1[I] > S2[I] then return (-1); I:=I+1; goto loop; End; lisp procedure IdCompare(D1,D2); % Compare IDs via print names %/ What of case StringCompare(Id2String D1,Id2String D2); lisp procedure SlowIdSort DList; % Worst Possible Sort; If Null DList then NIL else InsertId(car Dlist, SlowIdSort Cdr Dlist); lisp procedure InsertId(D,DL); If Null DL then D . Nil else if IdCompare(D,Car DL)>=0 then D . DL else Car Dl . InsertId(D,Cdr Dl); % ======= Tree based ALPHA-SORT package, derived from CREF % routines modified from FUNSTR for alphabetic sorting % % Tree Sort of list of ELEM % % Tree is NIL or STRUCT(VAL:value,SONS:Node-pair) % Node-pair=STRUCT(LNode:tree,RNode:tree); lisp smacro procedure NewNode(Elem); %/ use A vector? LIST(Elem,NIL); lisp smacro procedure VAL Node; % Access the VAL in node CAR Node; lisp smacro procedure LNode Node; CADR Node; lisp smacro procedure RNode Node; CDDR Node; lisp smacro procedure NewLeftNode(Node,Elem); RPLACA(CDR Node,NewNode Elem); lisp smacro procedure NewRightNode(Node,Elem); RPLACD(CDR Node,NewNode Elem); lisp procedure IdSort LST; % Sort a LIST of ID's. Do not remove Dups % Build Tree then collapse; Tree2LST(IdTreeSort(LST),NIL); lisp procedure IdTreeSort LST; % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO IdPutTree(CAR LST,Tree); Return Tree; END; lisp smacro procedure IdPlaceToLeft (Elem1,Elem2); % ReturnS T If Elem to go to left of Node IdCompare(Elem1,Elem2)>=0; lisp procedure IdPutTree(Elem,Node); % Insert Elements into Tree Begin DWN: If Not IdPlaceToLeft(Elem,VAL Node) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; lisp procedure Tree2LST(Tree,LST); % Collapse Tree to LIST Begin While Tree DO <<LST:=VAL(Tree) .Tree2LST(RNode Tree,LST); Tree:=LNode Tree>>; Return LST; END; % More General Sorting, given Fn=PlaceToRight(a,b); lisp procedure GenSort(LST,Fn); % Sort a LIST of elems % Build Tree then collapse; Tree2LST(GenTreeSort(LST,Fn),NIL); lisp procedure GenTreeSort(LST,Fn); % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO GenPutTree(CAR LST,Tree,Fn); Return Tree; END; lisp procedure GenPutTree(Elem,Node,SortFn); % Insert Elements into Tree Begin DWN: If Not Apply(SortFn,list(Elem,VAL Node)) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; % More General Sorting, given SortFn=PlaceToLeft(a,b); lisp procedure GSort(LST,SortFn); % Sort a LIST of elems % Build Tree then collapse; Begin CopyD('GsortFn!*,SortFn); LST:= Tree2LST(GTreeSort LST,NIL); RemD('GsortFn!*); Return LST; End; lisp procedure GTreeSort LST; % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO GPutTree(CAR LST,Tree); Return Tree; END; lisp procedure GPutTree(Elem,Node); % Insert Elements into Tree Begin DWN: If Not GSortFn!*(Elem,VAL Node) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; % Standard Comparison Functions: lisp procedure IdSortFn(Elem1,Elem2); % ReturnS T If Elem1 to go to right of Elem 2; IdCompare(Elem1,Elem2)>=0; lisp procedure NumberSortFn(Elem1,Elem2); Elem1 <= Elem2; lisp procedure NumberSort Lst; Gsort(Lst,'NumberSortFn); lisp procedure StringSortFn(Elem1,Elem2); StringCompare(Elem1,Elem2)>=0; lisp procedure StringSort Lst; Gsort(Lst,'StringSortFn); lisp procedure NoSortFn(Elem1,Elem2); NIL; lisp procedure AtomSortFn(E1,E2); % Ids, Numbers, then strings; If IdP E1 then If IdP E2 then IdSortFn(E1,E2) else NIL else if Numberp E1 then if IdP E2 then T else if NumberP E2 then NumberSortFn (E1,E2) else NIL else if StringP(E1) then if IDP(E2) then T else if Numberp E2 then T else StringSortFn(E1,E2) else NIL; lisp procedure AtomSort Lst; Gsort(Lst,'AtomSortFn); lisp procedure StringLengthFn(S1,S2); % For string length % String Length Comparison Size(S1)<=Size(S2); procedure IdLengthFn(e1,e2); StringLengthFn(Id2string e1,Id2string e2); On syslisp; syslsp procedure SC1(S1,S2); % Returns T if S1<=S2 % String Comparison Begin scalar L1,L2,I,L; S1:=Strinf s1; S2:=Strinf S2; L1:=StrLen(S1); L2:=StrLen(S2); If L1>L2 then L:=L2 else L:=L1; I:=0; loop: If I>L then return(If L1 <=L2 then T else NIL); if StrByt(S1,I) < StrByt(S2,I) then return T; if StrByt(S1,I) > StrByt(S2,I) then return NIL; I:=I+1; goto loop; End; syslsp procedure IdC1(e1,e2); Sc1(ID2String e1, ID2String e2); syslsp procedure SC2(S1,S2); % Returns T if S1<=S2 % String Comparison done via packed word compare, may glitch Begin scalar L1,L2,I,L; S1:=Strinf s1; S2:=Strinf S2; L1:=Strpack StrLen(S1); L2:=strpack StrLen(S2); S1:=S1+1; S2:=S2+1; If L1>L2 then L:=L2 else L:=L1; I:=0; %/ May be off by one? loop: If I>L then return(If L1 <=L2 then T else NIL); if S1[I] < S2[I] then return T; if S1[I] > S2[I] then return NIL; I:=I+1; goto loop; End; syslsp procedure IdC2(e1,e2); Sc2(ID2String e1,ID2String e2); Off syslisp; Lisp procedure GsortP(Lst,SortFn); Begin If Not PairP Lst then return T; L: If Not PairP Cdr Lst then Return T; If Not Apply(SortFn,list(Car Lst, Cadr Lst)) then return NIL; Lst :=Cdr Lst; goto L; END; Lisp procedure GMergeLists(L1,L2,SortFn); If Not PairP L1 then L2 else if Not PairP L2 then L1 else if Apply(SortFn,list(Car L1, Car L2)) then Car(L1) . GMergeLists(cdr L1, L2,SortFn) else car(L2) . GmergeLists(L1, cdr L2,SortFn); Lisp procedure MidPoint(Lst1,Lst2,M); % Set MidPointer List at M Begin While Not (Lst1 eq Lst2) and M>0 do <<Lst1 := cdr Lst1; M:=M-1>>; return Lst1; End; Lisp procedure GMergeSort(Lst,SortFn); GMergeSort1(Lst,NIL,Length Lst,SortFn); Lisp procedure GMergeSort1(Lst1,Lst2,M,SortFn); If M<=0 then NIL else if M =1 then if null cdr Lst1 then Lst1 else List Car lst1 else if M=2 then (if Apply(SortFn,list(Car Lst1,Cadr Lst1)) then List(Car Lst1, Cadr Lst1) else List(Cadr Lst1,Car lst1)) else begin scalar Mid,M1; M1:=M/2; Mid :=MidPoint(Lst1,Lst2,M1); Lst1 :=GMergeSort1(Lst1,Mid, M1,SortFn); Lst2 :=GmergeSort1(Mid,Lst2, M-M1,SortFn); Return GmergeLists(Lst1,Lst2,SortFn); end; end; |
Added psl-1983/3-1/util/h-stats-1.red version [e3f3b5815c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% "SysLisp" part of the HEAP-STATS package. %%% %%% Author: Cris Perdue %%% December 1982 %%% Documented January 1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% on SysLisp; compiletime << put('igetv,'assign!-op,'iputv); >>; %%% Magic constants defining the layout of a "heap-stats" object. compiletime << Internal WConst TemplateX = 2, StringTabX = 3, StringSpaceX = 4, VectTabX = 5, VectSpaceX = 6, WordTabX = 7, WordSpaceX = 8, Pairs = 9, Strings = 10, HalfWords = 11, WordVecs = 12, Vectors = 13; >>; %%% This procedure sweeps the heap and collects statistics into %%% its argument, which is a heap-stats object. This routine may %%% be called as part of a garbage collection, so it may not do %%% any allocation whatsoever from the heap. Moderate size %%% integers are assumed to have in effect no tag. syslsp procedure HeapStats(Results); begin scalar CurrentItem, ObjLen, Last, HistoSize, StdTemplate, StringHTab, StringSpaceTab, VectHTab, VectSpaceTab, WordHTab, WordSpaceTab, Len; %% Check that the argument looks reasonable. if neq(isizev(Results), 13) then return nil; StdTemplate := igetv(Results,TemplateX); StringHTab := igetv(Results,StringTabX); StringSpaceTab := igetv(Results,StringSpaceX); VectHTab := igetv(Results,VectTabX); VectSpaceTab := igetv(Results,VectSpaceX); WordHTab := igetv(Results,WordTabX); WordSpaceTab := igetv(Results,WordSpaceX); %% Check the various subobjects of the argument to see that %% they look reasonable. The returns are all errors effectively. HistoSize := isizev(StdTemplate) + 1; if neq(isizev(StringHTab),HistoSize) then return 1; if neq(isizev(StringSpaceTab),HistoSize) then return 2; if neq(isizev(VectHTab),HistoSize) then return 3; if neq(isizev(VectSpaceTab),HistoSize) then return 4; if neq(isizev(WordHTab),HistoSize) then return 5; if neq(isizev(WordSpaceTab),HistoSize) then return 6; igetv(Results,Pairs) := 0; igetv(Results,Strings) := 0; igetv(Results,HalfWords) := 0; igetv(Results,WordVecs) := 0; igetv(Results,Vectors) := 0; FillVector(StringHTab,0); FillVector(StringSpaceTab,0); FillVector(VectHTab,0); FillVector(VectSpaceTab,0); FillVector(WordHTab,0); FillVector(WordSpaceTab,0); Last := HeapLast(); CurrentItem := HeapLowerBound(); while CurrentItem < Last do begin case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: << ObjLen := 2; % must be first of pair igetv(Results,Pairs) := igetv(Results,Pairs) + 1; >>; HBYTES: << Len := StrLen CurrentItem; ObjLen := 1 + StrPack Len; igetv(Results,Strings) := igetv(Results,Strings) + 1; Histo(StdTemplate,StringHTab,Len+1,StringSpaceTab,ObjLen); >>; HHalfwords: << ObjLen := 1 + HalfWordPack HalfWordLen CurrentItem; igetv(Results,HalfWords) := igetv(Results,HalfWords) + 1; >>; HWRDS: << Len := WrdLen CurrentItem; ObjLen := 1 + WrdPack Len; igetv(Results,WordVecs) := igetv(Results,WordVecs) + 1; Histo(StdTemplate,WordHTab,Len+1,WordSpaceTab,ObjLen); >>; HVECT: << Len := VecLen CurrentItem; ObjLen := 1 + VectPack Len; igetv(Results,Vectors) := igetv(Results,Vectors) + 1; Histo(StdTemplate,VectHTab,Len+1,VectSpaceTab,ObjLen); >>; default: Error(0,"Illegal item in heap at %o", CurrentItem); end; % case CurrentItem := CurrentItem + ObjLen; end; Results; end; %%% Internal utility routine used by heapstats to accumulate %%% values into the statistics tables. The template is a %%% histogram template. The table is a histogram table. The %%% "value" is tallied into the appropriate bucket of the table %%% based on the template. Spacetab is similar to "table", but %%% the value of "space" will be added rather than tallied into %%% spacetab. Syslsp procedure Histo(Template,Table,Value,SpaceTab,Space); begin for i := 0 step 1 until isizev(Template) do if igetv(Template,i) >= Value then << igetv(Table,i) := igetv(Table,i) + 1; igetv(SpaceTab,i) := igetv(SpaceTab,i) + Space; return; >>; if Value > igetv(Template,isizev(Template)) then << igetv(Table,isizev(Template)+1) := igetv(Table,isizev(Template)+1) + 1; igetv(SpaceTab,isizev(Template)+1) := igetv(SpaceTab,isizev(Template)+1) + Space; >>; end; SysLsp procedure FillVector(v,k); for i := 0 step 1 until isizev(v) do igetv(v,i) := k; |
Added psl-1983/3-1/util/hash.sl version [7334d961d3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Hash table package, rather general purpose. %%% Author: Cris Perdue 8/25/82 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Edit by Cris Perdue, 9 Apr 1983 1159-PST % Now uses fast, open-coded operations. % Edit by Cris Perdue, 25 Feb 1983 1408-PST % Cleaned up code and documentation for demo. % Added NBuckets as an INITable variable. (compiletime (load if data-machine numeric-operators fast-vector)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Hash table flavor. %%% %%% This is an external chaining hash table. Thus the table can never %%% overflow and collision path length grows slowly, though search time %%% can theoretically grow large. The implementation includes ability %%% to delete an association plus several other bells and whistles. %%% %%% Hash table instantiation can be as simple as: %%% (make-instance 'hash). %%% %%% Options to make-instance are: %%% NBuckets: Number of hash buckets to create initially. Defaults %%% to 100. %%% HashFn: Given a key, must return a fairly large pseudo-random %%% integer. Defaults to StrHash, for string keys. %%% NullValue: A value for Lookup to return if no association is found. %%% Defaults to NIL. %%% MaxFillRatio: A floating point number which is the maximum ratio of %%% the number of associations to the number of buckets. %%% If this ratio is reached, the table will be enlarged %%% to make the ratio about .5. Defaults to 2.0. %%% KeyCopyFn: Used by PutAssn. In some cases when a new association %%% is created one may want to copy the key so that it %%% will be guaranteed not to be modified. Defaults to %%% a function that returns its argument without any copying. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Gettable state: %%% %%% Usage: Number of associations currently in the table. %%% NullValue: Value for Lookup to return if no association found. %%% %%% The following relate specifically to associations made via %%% hash table: %%% MaxFillRatio %%% NBuckets %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Operations: %%% %%% Present?(key) %%% %%% Returns T or NIL depending on whether there is an association with %%% the given key. %%% %%% Lookup(key) %%% %%% Returns the value associated with the key, or the NullValue for the %%% table if no association exists. %%% %%% PutAssn(key value) %%% %%% Makes an association between the key and value, replacing any old %%% association. The key may be copied if a new association is created, %%% otherwise the copy of the key already stored continues to be used. %%% Returns the value. %%% %%% DeleteAssn(key) %%% %%% Deletes any association that may exist for the key. Returns a value %%% in the manner of Lookup. %%% %%% ReSize(size) %%% %%% Rehashes the table into "size" buckets. This operation is specific %%% to associations made with hash tables. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Preliminaries: definitions, etc. %(setq bitsperword 32) % Hack to use from LISP. % Available as constant in SYSLISP. % In this package need only be no % greater than actual bits per word. (defmacro funcall (fn . args) `(apply ,fn (list ,@args))) %%% Hash flavor definition. (defflavor Hash (Table (NBuckets 100) (Usage 0) OverFlowLevel (MaxFillRatio 2.0) (HashFn 'StrHash) (NullValue NIL) (CompareFn 'String=) (KeyCopyFn 'no-op)) () (gettable-instance-variables NBuckets Usage NullValue MaxFillRatio) (initable-instance-variables NBuckets MaxFillRatio HashFn NullValue KeyCopyFn) ) (defmethod (Hash init) (init-plist) %% Perhaps the table size should be prime . . . (setf Table (MkVect (- NBuckets 1))) (while (leq MaxFillRatio .5) (ContinuableError 0 "Set MaxFillRatio greater than .5 before continuing" t)) (setf OverFlowLevel (Fix (* NBuckets MaxFillRatio)))) (defmethod (Hash Present?) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (if (Ass CompareFn Key (igetv Table i)) then t else nil))) (defmethod (Hash Lookup) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (igetv Table i)))) (if Entry then (cdr Entry) else NullValue)))) (defmethod (Hash PutAssn) (key value) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (igetv Table i)))) (if Entry then (RplacD Entry value) else (setf (igetv Table i) (cons (cons (funcall KeyCopyfn key) value) (igetv Table i))) (setf Usage (add1 Usage)) (if (not (< Usage OverFlowLevel)) then (=> Self resize (* 2 Usage)))))) value) (defmethod (Hash DeleteAssn) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (igetv Table i))) (Value)) (if Entry then (setq Value (cdr Entry)) (setf (igetv Table i) (DelQIP Entry (igetv Table i))) (setf Usage (- Usage 1)) Value else NullValue)))) (defmethod (Hash MapAssn) (fn) (for (from i 0 (Size Table)) (do (for (in a (igetv Table i)) (do (funcall fn (car a))))))) % Operations that are not basic (defmethod (Hash ReSize) (new-size) (if (< new-size 1) (StdError (BldMsg "Hash table size of %p too small" new-size))) (let ((newtable (mkvect (- new-size 1))) (oldtable table)) (setf NBuckets new-size) (setf Table newtable) (setf OverFlowLevel (Fix (* NBuckets MaxFillRatio))) (setf Usage 0) (for (from i 0 (Size oldtable)) (do (for (in a (igetv oldtable i)) (do (=> Self PutAssn (car a) (cdr a)))))) Self)) %%% Internal functions (on fast-integers) (defun Hash$HashBucket (table hashed-key) % Returns index of bucket (remainder hashed-key (isizev table))) (defun no-op (x) x) %%% Useful related function (defun StrHash (S) % Compute hash function of string (let ((len (StrLen S)) (AvailableBits (- (wconst InfBitLength) 8)) (HashVal 0)) (if (> Len AvailableBits) then (setq Len AvailableBits)) (setq s (StrBase (StrInf s))) (for (from I 0 Len) (do (setq HashVal (LXOR HashVal (LShift (Byte S I) (- AvailableBits I)))))) HashVal)) (off fast-integers) |
Added psl-1983/3-1/util/hcons.sl version [ee0ba306b8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % HCONS.SL - Hashing (unique) CONS and associated utilities. % % Author: William Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 2 June 1982 % Copyright (c) 1982 University of Utah % (BothTimes % ?? Compile time may suffice. (load useful) (load fast-vector)) % Summary of "user level" functions provided: % (DM Hcons (X) ...) % Nary hashed cons, right associative. % (DN Hlist (X) ...) % Hcons version of "list" function. % Hcons version of "copy" function. Note that unlike copy, this is not % guaranteed to create a new copy of a structure. (In fact, rather the % opposite.) % (DE Hcopy (lst) ...) % (DE Happend (U V) ...) % Hcons version of "append" function. % (DE Hreverse (U) ...) % Hcons version of "reverse" function. % Pairs for property list functions must be created by Hcons. % Get property of id or pair. % (DE extended-get (id-or-pair indicator) ...) % Put property of id or pair. Known to setf. % (DE extended-put (id-or-pair indicator val) ...) % Number of hash "slots" in table, should be a prime number to get an even % spread of hits (??). This package has been written so that it should be % possible to modify this size at runtime (I hope). So if the hash-tables % get too heavily loaded they can be copied to larger ones. (DefConst hcons-table-size 103) % Build the two tables (we switch from one to the other on each garbage % collection. Note that (MkVect 1) gives TWO locations. (setf hash-cons-tables (MkVect 1)) (setf (IGetV hash-cons-tables 0) (MkVect (sub1 (const hcons-table-size)))) (setf (IGetV hash-cons-tables 1) (MkVect (sub1 (const hcons-table-size)))) % current-table-number switches between 0 and one at each garbage % collection--selecting the current table to use. (setf current-table-number 0) (DE next-table-number (table-number) (cond ((equal table-number 0) 1) (T 0))) % Should really use structs for this, but I'm unsure on the exact details % of how structs work, and it's very important to understand how much free % space will be demanded by any routines that are called. % Anyway, each location in a "hash table" is either NIL, or an "entry", % where an entry is implemented as a vector of % [ <dotted-pair> <property-list-for-pair> <next-entry-in-chain> ] % This should be done differently too. (DefConst entry-size 4) % The size of an entry in "heap units"?? (DefConst pair-size 2) % Similarly for pairs. (DS create-hash-entry () % Create a 3 element vector. (MkVect 2)) (DS pair-info (ent) (IGetV ent 0)) (DS prop-list-info (ent) (IGetV ent 1)) (DS next-entry (ent) (IGetV ent 2)) % Finds a location within a "hash table", for a pair (X,Y). % This version is very simpleminded! (DS hcons-hash-function (htable X Y) (remainder % Take absolute value to avoid sign problems with remainder. (abs (plus (Sys2Int X) (Sys2Int Y))) (add1 (ISizeV htable)))) % Copy entries from one "hash cons table" to another, setting the source % table to all NILs. Return the dst-table, as well as copying into it. % This routine is used to place entries in their new locations after a % garbage collection. This routine MUST NOT allocate anything on the heap. (DE move-hcons-table (src-table dst-table) (prog (dst-index src-entry src-pair nxt-entry) (for (from src-index 0 (ISizeV src-table) 1) (do (progn (setf src-entry (IGetV src-table src-index)) % Use GetV here, until "the bug" in IGetV gets fixed. (setf (GetV src-table src-index) NIL) (while src-entry (progn (setf src-pair (pair-info src-entry)) (setf dst-index (hcons-hash-function dst-table (car src-pair) (cdr src-pair))) % Save the next entry in the the chain, and then relink the % current entry into its new location. (setf nxt-entry (next-entry src-entry)) (setf (next-entry src-entry) (IGetV dst-table dst-index)) (setf (IGetV dst-table dst-index) src-entry) % Move to next thing in chain. (setf src-entry nxt-entry)))))) (return dst-table))) % Nary version of hashed cons. (DM Hcons (X) (RobustExpand (cdr X) 'hcons2 NIL)) % Binary "hashed" cons of X and Y, returns pointer to previously % constructed pair if it can be found in the hash table. (DE Hcons2 (X Y) (prog (hashloc hitchain tmpchain newpair newentry) (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) X Y)) % Get chain of entries at the appropriate hash location in the % appropriate table. (setf hitchain (IGetV (IGetV hash-cons-tables current-table-number) hashloc)) % Search for a previously constructed pair, if any, with car and cdr % equal to X and Y respectively. % Note that tmpchain is not a list, but a "chain" of "entries". (setf tmpchain hitchain) (while (and tmpchain % Keep searching unless an exact match is found. (not (and % EqN test might be better, so that we handle numbers % intelligently? Probably have to worry about hash % code also. (eq X (car (setf newpair (pair-info tmpchain)))) (eq Y (cdr newpair))))) % do (setf tmpchain (next-entry tmpchain))) (cond % If no entry was found, create a new one. ((null tmpchain) (progn % We need enough room for one new pair, plus one new entry. If % there isn't enough room on the heap then collect garbage (and % in the process move EVERYTHING around, switch hash tables, % etc.) (cond ((LessP (GtHeap NIL) % Returns free space in heap. (plus (const pair-size) (const entry-size))) (progn (reclaim) % Recalculate locations of everything. (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) X Y)) % Get chain of entries at the appropriate hash location in % the appropriate table. (setf hitchain (IGetV (IGetV hash-cons-tables current-table-number) hashloc))))) % Allocate the new pair, store information into the appropriate % spot in appropriate table. (setf newpair (cons X Y)) (setf newentry (create-hash-entry)) (setf (pair-info newentry) newpair) (setf (prop-list-info newentry) NIL) (setf (next-entry newentry) hitchain) % Link the new entry into the front of the table. (setf (IGetV (IGetV hash-cons-tables current-table-number) hashloc) newentry)))) % Return the pair (either newly constructed, or old). (return newpair))) % "hcons" version of "list" function. (DN Hlist (X) (do-hlist X)) (DE do-hlist (X) (cond ((null X) NIL) (T (hcons (car X) (do-hlist (cdr X)))))) % "hcons" version of copy. Note that unlike copy, this is not guaranteed % to create a new copy of a structure. (In fact, rather the opposite.) (DE Hcopy (lst) (cond ((not (pairp lst)) lst) (T (hcons (hcopy (car lst)) (hcopy (cdr lst)))))) % "hcons" version of Append function. (DE Happend (U V) (cond % First arg is NIL, or some other non-pair. ((not (PairP U)) V) % else ... (T (hcons (car U) (Happend (cdr U) V))))) % Hcons version of Reverse. (DE Hreverse (U) (prog (V) (while (PairP U) (progn (setf V (hcons (car U) V)) (setf U (cdr U)))) (return V))) % Look up and return the entry for a pair, if any. Return NIL if argument % is not a pair. (DE entry-for-pair (p) (cond ((PairP p) (prog (hashloc ent) (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) (car p) (cdr p))) % Look at appropriate spot in hash table. (setf ent (IGetV (IGetV hash-cons-tables current-table-number) hashloc)) % Search through chain for p. (while (and ent (not (eq (pair-info ent) p))) (setf ent (next-entry ent))) % Return the entry, or NIL if none found. (return ent))))) % Get a property for a pair or identifier. Only pairs stored in the hash % table have properties. (DE extended-get (id-or-pair indicator) (cond ((IdP id-or-pair) (get id-or-pair indicator)) ((PairP id-or-pair) (prog (proplist prop-pair) (setf proplist (pair-property-list id-or-pair)) (setf prop-pair (atsoc indicator proplist)) (return (cond ((PairP prop-pair) (cdr prop-pair)))))))) % Put function for pairs and identifiers. Only pairs in the hash table can % be given properties. (We are very sloppy about case when pair isn't in % table, but hopefully the code won't blow up.) "val" is returned in all % cases. (DE extended-put (id-or-pair indicator val) (cond ((IdP id-or-pair) (put id-or-pair indicator val)) ((PairP id-or-pair) (prog (proplist prop-pair) (setf proplist (pair-property-list id-or-pair)) % Get the information (if any) stored under the indicator. (setf prop-pair (Atsoc indicator proplist)) (cond % Modify the information under the indicator, if any. ((PairP prop-pair) (setf (cdr prop-pair) val)) % Otherwise (nothing found under indicator), create new % (indicator . value) pair. (T (progn % Note use of cons, not Hcons, WHICH IS RIGHT? (I think cons.) (setf prop-pair (cons indicator val)) % Tack new (indicator . value) pair onto property list, and % store in entry for the pair who's property list is being % hacked. (set-pair-property-list id-or-pair (cons prop-pair proplist))))) % We return the value even if the pair isn't in the hash table. (return val))))) (PUT 'extended-get 'assign-op 'extended-put) (FLAG '(extended-get) 'SETF-SAFE) % Return the "property list" associated with a pair. (DE pair-property-list (p) (prog (ent) (setf ent (entry-for-pair p)) (return (cond (ent (prop-list-info ent)) (T NIL))))) % Set the "property list" cell for a pair, return the new "property list". (DE set-pair-property-list (p val) (prog (ent) (setf ent (entry-for-pair p)) (return (cond (ent (setf (prop-list-info ent) val)) (T NIL))))) % We redefine the garbage collector so that it rebuilds the hash table % after garbage collection has moved everything. (putd 'original-!%Reclaim (car (getd '!%Reclaim)) (cdr (getd '!%Reclaim))) % New version of !%reclaim--shuffles stuff in cons tables after collecting % garbage. (DE !%Reclaim () (prog1 (original-!%Reclaim) % Move the old table to the new one, shuffling everything into its % correct position. (move-hcons-table % Would use IGetV, but there appears to be a bug preventing it from % working. % Source (GetV hash-cons-tables current-table-number) % Destination (GetV hash-cons-tables (next-table-number current-table-number))) % Point to new "current-table". (setf current-table-number (next-table-number current-table-number)))) |
Added psl-1983/3-1/util/heap-stats.sl version [5b1d9328b0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Ordinary LISP part of the heap statistics gathering package, HEAP-STATS. %%% Load this file to get the package. %%% The top-level function is collect-stats. See its description. %%% %%% Author: Cris Perdue %%% December 1982 %%% Documented and cleaned up a litte, January 1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load if)) (load h-stats-1 get-heap-bounds) %%% An object that holds a complete set of statistics for the heap %%% at some moment in time. When one of these is created, the %%% instance variable "template" must be initialized, and the %%% template must be a "histogram template" as discussed below. %%% Maintainer note: the code that actually gathers statistics assumes %%% that the heap-stats object is a vector (or evector) with a header, %%% 2 items of data allocated by the objects package, then the data shown %%% here, in order. (defflavor heap-stats (template string-count string-space vector-count vector-space wordvec-count wordvec-space (pairs 0) (strings 0) (halfwords 0) (wordvecs 0) (vectors 0)) () (initable-instance-variables template) gettable-instance-variables) (defmethod (heap-stats init) (init-plist) (if (not (vectorp template)) then (error 0 "The TEMPLATE of a HEAP-STATS object must be initialized.")) (let ((s (+ (size template) 1))) (setf string-count (make-vector s 0)) (setf string-space (make-vector s 0)) (setf vector-count (make-vector s 0)) (setf vector-space (make-vector s 0)) (setf wordvec-count (make-vector s 0)) (setf wordvec-space (make-vector s 0)))) (global '(old-!%reclaim stats-channel)) %%% This method prints statistics on a particular snapshot of the heap %%% onto the given channel. (defmethod (heap-stats print-stats) (channel) (channelprintf channel "%w pairs, %w strings, %w vectors, %w wordvecs, %w halfwordvecs%n%n" pairs strings vectors wordvecs halfwords) (for (in table (list string-count vector-count)) (in spacetable (list string-space vector-space)) (in title '("STRINGS" "VECTORS")) (do (channelprintf channel "%w%n%n" title) (print-histo template table spacetable channel) (channelterpri channel) (channelterpri channel)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Internal functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Prints a single histogram onto the given channel. Arguments %%% are the template from which the histogram was generated, a %%% corresponding table with a count of the number of objects of %%% each size range, and another corresponding table with the %%% total space occupied by the objects within each size range. (defun print-histo (template table spacetable channel) (channelprintf channel "Size <= n%tHow many%tStorage items used%n" 12 24) (channelprintf channel "------------------------------------------%n") (for (from i 0 (size template)) (do (channelprintf channel "%w%t%w%t%w%n" (indx template i) 12 (indx table i) 24 (indx spacetable i)))) (channelprintf channel "> %w%t%w%t%w%n" (indx template (size template)) 12 (indx table (+ (size template) 1)) 24 (indx spacetable (+ (size template) 1)))) (fluid '(before-stats after-stats print-stats? stdtemplate)) %%% This function initializes the collecting of statistics and %%% printing them to a file. The name of the file is the %%% argument to collect-stats. NIL rather than a string for the file %%% name turns statistics collection off. In statistics collection mode %%% statistics are gathered just before and after each garbage collection. (defun collect-stats (file) (if (and file (not old-!%reclaim)) then (if (not (and (eq (object-type before-stats) 'heap-stats) (eq (object-type after-stats) 'heap-stats))) then (printf "Caution: before- and after-stats are not both bound.%n")) (setq old-!%reclaim (cdr (getd '!%reclaim))) (setq stats-channel (open file 'output)) (putd '!%reclaim 'expr '(lambda () (heapstats before-stats) (apply old-!%reclaim nil) (heapstats after-stats) (channelprintf stats-channel "BEFORE RECLAIMING%n%n") (=> before-stats print-stats stats-channel) (channelterpri stats-channel) (channelprintf stats-channel "AFTER RECLAIMING%n%n") (=> after-stats print-stats stats-channel))) elseif (and (not file) old-!%reclaim) then (close stats-channel) (putd '!%reclaim 'expr old-!%reclaim) (setq old-!%reclaim nil) elseif old-!%reclaim then (printf "Statistics collecting is apparently already turned on.%n") else (printf "Statistics collecting is apparently already off.%n") (printf "Trying to close the channel anyway.%n") (close stats-channel))) %%% This is initialized here to be a reasonable histogram template for %%% statistics on heap usage. A histogram template is a vector of %%% integers that define the buckets to be used in collecting the %%% histogram data. All values less than or equal to template[0] %%% go into data[0]. Of those values that do not go into data[0], %%% all less than or equal to template[1] go into data[1], etc.. %%% The vector of data must have at least one more element that %%% the template does. All values greater than the last value in %%% the template go into the following element of the data vector. (setq StdTemplate (make-vector 27 0)) (for (from i 0 16) (do (setf (indx StdTemplate i) i))) (for (from i 17 27) (for k 32 (* k 2)) (do (setf (indx StdTemplate i) k))) (setq before-stats (make-instance 'heap-stats 'template StdTemplate)) (setq after-stats (make-instance 'heap-stats 'template StdTemplate)) |
Added psl-1983/3-1/util/help.build version [97448822dd].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | % Build file for HELP.RED module % MLG, 9 Feb, 1983 % Changed Unix paths to use $ vars CompileTime load If!-System; if_system(Tops20, << HelpFileFormat!* := "ph:%w.hlp"; HelpTable!* := "ph:help.tbl"; >>); if_system(Unix, << HelpFileFormat!* := "$ph/%w.hlp"; HelpTable!* := "$ph/help.tbl"; >>); if_system(HP9836, << HelpFileFormat!* := "ph:%w.hlp"; HelpTable!* := "ph:help.tbl"; >>); in "help.red"$ |
Added psl-1983/3-1/util/help.red version [e584a129fc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HELP.RED - User assistance and documentation % % Author: Eric Benson and Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % 30 Dec, 1982, MLG % Move IF_SYSTEM to the Build file % <PSL.UTIL.NEWVERSIONS>HELP.RED, 30-Nov-82 16:31, Edit by GALWAY % Changed "FLAG" to "SWITCH" to avoid confusion with flags on property % lists and to bring terminology in line with PSL manual. % <PSL.UTIL>HELP.RED.3, 1-Dec-82 16:16:39, Edit by BENSON % Added if_system(HP9836, ... ) % <PSL.UTIL>HELP.RED.4, 10-Aug-82 00:54:26, Edit by BENSON % Changed ReadCh to ReadChar in DisplayHelpFile % <PSL.INTERP>HELP.RED.5, 31-May-82 11:50:48, Edit by GRISS % Make it LAPIN Help.Tbl % Changed: to use PH: % Display help texts, invoke interactive HELPs or print default values % Place a HELP function on topic name under 'HelpFunction % Or HELP file on topic name under 'HelpFile % Or even a short string under 'HelpString (this may be removed) fluid '(TopLoopRead!* TopLoopPrint!* TopLoopEval!* TopLoopName!* HelpFileFormat!* Options!* !*Echo HelpIn!* HelpOut!* !*Lower !*ReloadHelpTable HelpTable!* ); !*ReloadHelpTable := T; lisp procedure ReloadHelpTable(); % Set !*ReloadHelpTable to T to cause a fresh help table to be loaded if !*ReloadHelpTable then << LapIn HelpTable!*; !*ReloadHelpTable := NIL >>; lisp procedure DisplayHelpFile F; % Type help file about 'F' begin scalar NewIn, C, !*Echo; (lambda(!*Lower); F := BldMsg(HelpFileFormat!*, F))(T); NewIn := ErrorSet(list('Open, MkQuote F, '(quote Input)), NIL, NIL); if not PairP NewIn then ErrorPrintF("*** Couldn't find help file %r", F) else << NewIn := car NewIn; while not ((C := ChannelReadChar NewIn) = char EOF) do WriteChar C; Close NewIn >>; end; fexpr procedure Help U; % Look for Help on topics U begin scalar OldOut; OldOut := WRS HelpOut!*; ReloadHelpTable(); % Conditional Reload HelpTopicList U; WRS OldOut; end; lisp procedure HelpTopicList U; % Auxilliary function to prind help for each topic in list U if null U then HelpHelp() else for each X in U do begin scalar F; if F := get(X, 'HelpFunction) then Apply(F, NIL) else if F := get(X, 'HelpFile) then DisplayHelpFile F else if F := get(X, 'HelpString) then Prin2T F else DisplayHelpFile X; % Perhaps a File Exists. end; lisp procedure HelpHelp(); % HELPFUNCTION: for help itself << DisplayHelpFile 'Help; FindHelpTopics(); PrintF("%nOptional modules now loaded:%n%l%n",Options!*); >>; lisp procedure FindHelpTopics(); % Scan the ID HAST TABLE for loaded HELP info << PrintF("Help is available on the following topics:%n"); MapObl Function TestHelpTopic; TerPri(); PrintF("The files in the help directory can be read using Help.%n") >>; lisp procedure TestHelpTopic X; % auxilliary function applied to each ID to see if % some help info exists if get(X, 'HelpFunction) or get(X, 'HelpFile) or get(X, 'HelpString) then << Prin2 '! ; Prin1 X >>; lisp procedure HelpTopLoop(); % HELPFUNCTION: for TopLoop, show READER/WRITERS << DisplayHelpFile 'Top!-Loop; if TopLoopName!* then << PrintF("%nCurrently inside %w top loop%n", TopLoopName!*); PrintF("Reader: %p, Evaluator: %p, Printer: %p%n", TopLoopRead!*, TopLoopEval!*, TopLoopPrint!*) >> else PrintF("%nNot currently inside top loop%n") >>; % Switch and global help - record and display all switches and globals. lisp procedure DefineSwitch(Name, Info); % Define important switch % Name does Not have the !*, Info should be a string. % << put(Name, 'SwitchInfo, Info); Name >>; lisp procedure Show1Switch(Name); % Display a single switch begin scalar X; Prin1 Name; Tab 15; Prin1 Eval Intern Concat("*", ID2String Name); If (X := Get(Name, 'SwitchInfo)) then << Tab 25; Prin2 X >>; TerPri(); end; lisp procedure ShowSwitches L; % Display all switches in a list << if not PairP L then MapObl function TestShowSwitch; for each X in L do Show1Switch X >>; lisp procedure TestShowSwitch X; % Support function for 1 switch display if get(X, 'SwitchInfo) then Show1Switch X; lisp procedure DefineGlobal(Name, Info); % Define important global % Name is an ID, Info should be a string. % << put(Name, 'GlobalInfo, Info); Name >>; lisp procedure Show1Global Name; % Display a Single Global begin scalar X; Prin1 Name; Tab 15; Prin1 Eval Name; If (X := get(Name, 'GlobalInfo)) then << Tab 25; Prin2 X >>; TerPri(); end; lisp procedure TestShowGlobal X; % Support for GLOBAL info if get(X, 'GlobalInfo) then Show1Global X; lisp procedure Show1State Name; % Display a single switch or global << if get(Name, 'GlobalInfo) then Show1Global Name; if get(Name, 'SwitchInfo) then Show1Switch Name >>; lisp procedure ShowGlobals L; % Display all globals in a list << if not PairP L then MapObl Function TestShowGlobal; for each X in L do Show1Global X >>; lisp procedure ShowState L; % Display all globals in a list << if not PairP L then MapObl function TestShowState; for each X in L do Show1State X >>; lisp procedure TestShowState X; % Support for a Global if get(X, 'SwitchInfo) or get(X, 'GlobalInfo) then Show1State X; END; |
Added psl-1983/3-1/util/history.sl version [5d255989c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; File containing functions to create a history mechanism. ;; (exploited what is there with (inp n) (ans n) and historylist*). ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; This file depends upon : init.lisp (basic lisp functions and syntax). ;; (in <lanam.dhl>). ;; ;; This file written by Douglas H. Lanam. September 1982. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; How to use the history mechanism implemented in this file: ;; ;; This file allows you to take any previous input or output and substitute ;; it in place of what you typed. Thus you can either print or redo ;; any input you have previously done. You can also print or ;; execute any result you have previously received. ;; The system will work identify commands by either their history number, ;; or by a subword in the input command. ;; ;; This file also allows you to take any previously expression and do ;; global substitutions on subwords inside words or numbers inside ;; expressions(Thus allowing spelling corrections, and other word ;; changes easily.) ;; ;; This file has a set of read macros that insert the previous history ;; text asked for inplace of them selves. Thus they can be put inside ;; any lisp expression typed by the user. The system will evaluate ;; the resulting expression the same as if the user had retyped everything ;; in himself. ;; ;; ^^ : means insert last input command inplace of ^^. ;; As an input command by itself, ;; ^^ by itself means redo last command. ;; ;; ^n : where n is a number replaces itself with the result of ;; (inp n). ^n by itself means (redo n). ;; ^+n : same as ^n. ;; ^-n : is replaced by the nth back command. ;; replaced with the result of ;; (inp (- current-history-number n)). ;; by itself means (redo (- current-history-number n)) ;; ;; ^word : where word starts with 'a'-'z' or 'A'-'Z', means ;; take the last input command that has word as a subword ;; or pattern of what was typed (after readmacros were ;; executed.), and replace that ^word with that entire input ;; command. ;; If you want a word that doesn't begin with 'a'-'z', or 'A'-'Z', ;; use ^?word where word can be any lisp atom. ;; (say 23, *, |"ab|, word). ;; ex.: 1 lisp> (plus 2 3) ;; 5 ;; 2 lisp> (* 4 5) ;; 20 ;; 3 lisp> ^us ;; (PLUS 2 3) ;; 5 ;; 4 lisp> (* 3 ^lu) ;; (PLUS 2 3) ;; 15 ;; ;; Case is ignored in word. Word is read by the command read, ;; And thus should be a normal lisp atom. Use the escape ;; character as needed. ;; ;; If the first ^ in any of the above commands is replaced with ;; ^@, then instead of (inp n) , the read macro is replaced with ;; (ans n). Words are still matched against the input, not the ;; answer. (Probably something should be added to allow matching ;; of subwords against the answer also.) ;; ;; Thus:(if typed as commands by themselves): ;; ;; ^@^ = (eval (ans (last-command))) ;; ^@3 = (eval (ans 3)) ;; ;; ^@plus = (eval (ans (last-command which has plus as a subword in ;; its input))). ;; ;; ;; Once the ^ readmacro is replaced with its history expression, you are ;; allowed to do some editing of the command. The way to do this ;; is to type a colon immediately after the ^ command as described ;; above before any space or other delimiting character. ;; ex.: ^plus:p ;; ^2:s/ab/cd/ ;; ^^:p ;; ^@^:p ;; ;; Currently there are two types of editing commands allowed. ;; ;; :p means print only, do not insert in expression, whole ;; read macro returns only nil. ;; ;; :s/word1/word2/ means take each atom in the expression found, ;; and if word1 is a subword of that atom, replace the ;; subword word1 with word2. Read is used to read word1 ;; and word2, thus the system expects an atom and will ;; ignore anything after what read sees before the /. ;; Use escape characters as necessary. ;; ;; :n where n is a positive unsigned number, means take the nth ;; element of the command(must be a list) and return it. ;; ;; ^string1^string2^ is equivalent to ^string1:s/string1/string2/ ;; ex.: ^plus^times^ is equivalent to ^plus:s/plus/times/ . ;; ;; After a :s, ^ or :<n> command you may have another :s command, ^ ;; or a :p ;; command. :p command may not be followed by any other command. ;; ;; The expression as modified by the :s commands is what is ;; returned in place of the ^ readmacro. ;; You need a closing / as seen in the :s command above. ;; After the command you should type a delimiting character if ;; you wish the next expression to begin with a :, since a : ;; will be interpreted as another editing command. ;; ;; On substitution, case is ignored when matching the subword, ;; and the replacement subword ;; is capitalized(unless you use an escape character before ;; typing a lowercase letter). ;; ;; Examples: ;; 1 lisp> (plus 23 34) ;; 57 ;; 2 lisp> ^^:s/plus/times/ ;; (TIMES 23 34) ;; 782 ;; 3 lisp> ^plus:s/3/5/ ;; (PLUS 25 54) ;; 79 ;; 4 lisp> ;; ;; (defmacro unreadch (x) `(unreadchar (id2int ,x))) (defmacro last-command () `(caadr historylist*)) (defmacro last-answer () `(cdadr historylist*)) (defun nth-command (n part) (cond ((eq part 'input) (inp n)) (t (ans n)))) (defun my-nthcdr (l n) (cond ((<= n 0) l) ((null l) nil) ((my-nthcdr (cdr l) (- n 1))))) (defvar *print-history-command-expansion t) (de skip-if (stop-char) (let ((x (readch))) (or (eq x stop-char) (unreadch x)))) (defun return-command (command) (and *print-history-command-expansion command ($prpr command) (terpri)) command) (defun do-history-command-and-return-command (string1 c) (let ((command (do-history-command string1 c))) (and *print-history-command-expansion command ($prpr command) (terpri)) command)) (defun nth-back-command (n) (do ((i n (+ 1 i)) (command-list historylist* (cdr command-list))) ((eq i 0) (caar command-list)))) (defvar *flink (*makhunk 80)) (defun kmp-flowchart-construction (p m) (rplacx 0 *flink -1) (do ((i 1 (+ 1 i))) ((> i m)) (do ((j (cxr (- i 1) *flink) (cxr j *flink))) ((or (= j -1) (= (cxr j p) (cxr (- i 1) p))) (rplacx i *flink (+ j 1)))))) (defun kmp-scan (p m s) (and s (prog (j) (setq j 0) loop (cond ((and (<> j -1) (<> (uppercassify (cxr j p)) (uppercassify (car s)))) (setq j (cxr j *flink)) (go loop))) (and (= j m) (return t)) (or (setq j (+ 1 j) s (cdr s)) (return nil)) (go loop)))) (defun match-list-beginnings (starting-list list) (do ((x starting-list (cdr x)) (y list (cdr y))) ((null x) t) (or (eq (car x) (car y)) (return nil)))) (defun uppercassify (y) (cond ((and (>= y '|a|) (<= y '|z|)) (+ y (- '|A| '|a|))) (t y))) (defun read-till-and-raise (stop-char) (let ((s (my-syntax stop-char)) (d)) (my-set-syntax stop-char 17) (setq d (read)) (skip-if stop-char) (my-set-syntax stop-char s) d)) (defun do-history-command (string1 command) (let ((b)) ;; colon after word indicates history command. ;; (cond ((eq (setq b (readch)) '|:|) ;; read key command (selectq (setq b (readch)) (p ;; only print result - dont execute ;; return nil so that a quoted version doesn't confuse the ;; history mechanism later. ( i would like to change this ;; to enter command in the history list but not execute). ($prpr command) (terpri) (rplaca (car historylist*) command) (*throw '$error$ nil)) (s ; change all subwords of string1 with string2. (do-history-command string1 (let ((delimiter (readch))) (match-and-substitute (read-till-and-raise delimiter) command (read-till-and-raise delimiter))))) ;; ;; number indicates get that element of the command out of ;; the list. ;; ((|0| |1| |2| |3| |4| |5| |6| |7| |8| |9|) (unreadch b) (let ((s (my-syntax '|:|)) (s1 (my-syntax '|^|)) (n)) (my-set-syntax '|:| 17) (my-set-syntax '|^| 17) (setq n (read)) (my-set-syntax '|:| s) (my-set-syntax '|^| s1) (cond ((null (dtpr command)) (princ "Error: not a list : ") ($prpr command) (terpri) nil) ((null (numberp n)) (princ "Error: expected number. ") (princ n) (princ " is not a number.") (terpri) nil) ((> n (length command)) (princ "Error: ") (princ n) (princ " is out of range for ") ($prpr command) (terpri) nil) (t (do-history-command string1 (nth command n)))))) (t (princ "Error: unknown command key : \|") (princ b) (princ "|") (terpri) ;; return original command command))) ((eq b '|^|) ;; equivalent to :s/string1/string2/ ;; is ^string1^string2^ (cond (string1 (match-and-substitute string1 command (read-till-and-raise '|^|))) (t (terpri) (princ "illegal option to history command.") (terpri) nil))) (t (unreadch b) ;; return original command command)))) (defun match-back-command (partial-match /&optional (part-to-return 'input)) (let ((p (list2vector (explode partial-match)))) (let ((m (upbv p))) (kmp-flowchart-construction p m) (do ((x (cdr historylist*) (cdr x))) ((null x) nil) (and (kmp-scan p m (explode (caar x))) (cond ((eq part-to-return 'input) (return (caar x))) (t (return (cdar x))))))))) (defun match-and-substitute (partial-match command replacement) (let ((p (list2vector (explode partial-match)))) (let ((m (upbv p))) (kmp-flowchart-construction p m) (let ((l (flatsize partial-match))) (match-and-substitute1 p m (explode partial-match) command (explode replacement) l))))) (defun match-and-substitute1 (p m s command replacement l) (cond ((or (atom command) (numberp command)) (kmp-scan-and-replace p m (explode command) replacement l command)) (t (cons (match-and-substitute1 p m s (car command) replacement l) (match-and-substitute1 p m s (cdr command) replacement l))))) (defun kmp-scan-and-replace (p m s replacement l command) (and s (prog (j k flag) (setq flag (stringp command)) (setq j 0) (setq k nil) loop (cond ((and (<> j -1) (<> (uppercassify (cxr j p)) (uppercassify (car s)))) (setq j (cxr j *flink)) (go loop))) (setq k (cons (car s) k)) (and (= j m) (return (cond ((stringp command) (list2string (cdr (append (append (nreverse (my-nthcdr k l)) replacement) (cdr (nreverse (cdr (nreverse s)))))))) (t (let ((x (append (append (nreverse (my-nthcdr k l)) replacement) (cdr s)))) (and (= (my-syntax (car x)) 14) (<= (my-syntax (cadr x)) 10) (setq x (cdr x))) (let ((y (implode x))) (cond ((eq (flatsize y) (length x)) y) (t (intern (list2string x)))))))))) (or (setq j (+ 1 j) s (cdr s)) (return command)) (go loop)))) (defun read-sub-word () (let ((c (my-syntax '|:|)) (d)) ;; dont read : since it is the special command character. (my-set-syntax '|:| 17) (setq d (read)) (my-set-syntax '|:| c) d)) (defun re-execute-command (/&optional (part 'input)) (let ((y (readch))) (cond ((eq y '\^) (do-history-command-and-return-command nil (last-command))) ((eq y '\*) (do-history-command-and-return-command nil (last-answer))) ((eq y '\@) (re-execute-command 'answer)) ((eq y '\?) (let ((yy (read-sub-word))) (do-history-command-and-return-command yy (match-back-command yy part)))) ((or (digit y) (memq y '(|+| |-|))) (unreadch y) (let ((y (read-sub-word))) (cond ((numberp y) (cond ((> y 0) (do-history-command-and-return-command nil (nth-command y part))) ((< y 0) (do-history-command-and-return-command nil (nth-back-command y)))))))) ((liter y) (unreadch y) (let ((yy (read-sub-word))) (do-history-command-and-return-command yy (match-back-command yy)))) ))) (my-set-readmacro '\^ (function re-execute-command)) |
Added psl-1983/3-1/util/if-system.build version [811abf5c2c].
> | 1 | in "if-system.red"$ |
Added psl-1983/3-1/util/if-system.red version [2715c12271].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | % % IF-SYSTEM.RED - Conditional compilation for system-dependent code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 March 1982 % Copyright (c) 1982 University of Utah % fluid '(system_list!*); macro procedure if_system U; do_if_system(cadr U, caddr U, if cdddr U then cadddr U else NIL); expr procedure do_if_system(system_name, true_case, false_case); if system_name memq system_list!* then true_case else false_case; END; |
Added psl-1983/3-1/util/if.sl version [21a0e15e4d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % IF macro % Cris Perdue 8/19/82 (setq *usermode nil) % Syntax of new IF is: % (if <expr> [then <expr> ... ] [<elseif-part> ... ] [else <expr> ... ]) % <elseif-part> = elseif <expr> [then <expr> ... ] % This syntax allows construction of arbitrary CONDs. (defun construct-new-if (form) (let ( (clause) (next-clause) (stmt (list 'cond)) (e form)) (while e (cond ((or (sym= (first e) 'if) (sym= (first e) 'elseif)) (cond ((or (null (rest e)) (not (or (null (rest (rest e))) (sym= (third e) 'then) (sym= (third e) 'else) (sym= (third e) 'elseif)))) (error 0 "Can't expand IF."))) (setq next-clause (next-if-clause e)) (setq clause (cond ((and (rest (rest e)) (sym= (third e) 'then)) (cons (second e) (ldiff (pnth e 4) next-clause))) (t (list (second e))))) (nconc stmt (list clause)) (setq e next-clause) (next)) ((sym= (first e) 'else) (cond ((or (null (rest e)) (next-if-clause e)) (error 0 "Can't expand IF."))) (nconc stmt (list (cons t (rest e)))) (exit)))) stmt)) (defun next-if-clause (tail) (for (on x (rest tail)) (do (cond ((or (sym= (first x) 'else) (sym= (first x) 'elseif)) (return x)))) (returns nil))) (defun sym= (a b) (eq a b)) (defun ldiff (x y) (cond ((null x) nil) ((eq x y) nil) (t (cons (first x) (ldiff (rest x) y))))) % Checks for (IF <expr> <KEYWORD> . . . ) form. If keyword form, % does fancy expansion, otherwise expands compatibly with MacLISP % IF expression. <KEYWORD> ::= THEN | ELSE | ELSEIF (dm if (form) (let ((b (rest (rest form))) (test (second form))) (cond ((or (sym= (first b) 'then) (sym= (first b) 'else) (sym= (first b) 'elseif)) (construct-new-if form)) ((eq (length b) 1) `(cond (,test ,(nth b 1)))) (t `(cond (,test ,(nth b 1)) (t ,@(pnth b 2))))))) |
Added psl-1983/3-1/util/init-file.build version [5422138ff3].
> > | 1 2 | CompileTime load If!-System; in "init-file.sl"$ |
Added psl-1983/3-1/util/init-file.sl version [b29ae13a46].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | % % INIT-FILE.SL - Function which reads an init file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1982 % Copyright (c) 1982 University of Utah % (if_system Tops20 (imports '(homedir))) (de read-init-file (program-name) ((lambda (f) (cond ((filep f) (lapin f)))) (init-file-string program-name))) |
Added psl-1983/3-1/util/inspect.build version [690245ece4].
> > | 1 2 | Compiletime Load Gsort; % Need a macro In "inspect.red"$ |
Added psl-1983/3-1/util/inspect.red version [c565938fe4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % INSPECT.RED - Scan files for defined functions % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 31 May 1982 % Copyright (c) 1982 University of Utah % % adapted from CREF and BUILD Imports '(Gsort Dir!-Stuff); FLUID '(!*UserMode % To control USER Redef message !*ECHO !*RedefMsg % To suppress REDEF messages CurrentFile!* % To keep tack of this file FileList!* % Files seen so far ProcedureList!* % procedures seen so far ProcFileList!* % (PROC . FILE) so far !*PrintInspect % Print each proc !*QuietInspect % Suppress INSPECTOUT messages ); !*PrintInspect:=T; !*QuietInspect:=NIL; Procedure Inspect X; begin scalar !*UserMode,!*Redefmsg,!*QuietInspect; !*QuietInspect:=T; INSPECTOut(); !*ECHO:=NIL; If Not FunboundP 'Begin1 then EvIn list X else EVAL LIST('Dskin, x); INSPECTEnd(); end; Procedure InspectOut; % Scan Files for Definitions Begin !*DEFN:=T; !*ECHO:=NIL; SEMIC!*:= '!$ ; DFPRINT!* := 'InspectPrint; ProcedureList!*:=FileList!* :=ProcFileList!*:=NIL; CurrentFile!* := NIL; if not !*QuietInspect then << if not FUnBoundP 'Begin1 then << Prin2T "INSPECTOUT: IN files; or type in expressions"; Prin2T "When all done execute INSPECTEND;" >> else << Prin2T "INSPECTOUT: (DSKIN files) or type in expressions"; Prin2T "When all done execute (INSPECTEND)" >> >>; End; Procedure InspectEnd; Begin If !*PrintInspect then PrintF "%n%% --- Done with INSPECTION ---%n"; Dfprint!*:=NIL; !*Defn:=NIL; ProcedureList!* := IdSort ProcedureList!*; If !*PrintInspect then <<Prin2T "% --- PROCS: --- "; Print ProcedureList!*>>; End; Procedure InspectPrint U; BEGIN scalar x; !*ECHO:=NIL; SEMIC!*:='!$; x:=IF PairP CLOC!* THEN CAR CLOC!* ELSE "*TTYInput*"; If x NEQ CurrentFile!* and !*PrintInspect then PrintF("%n%% --- Inspecting File : %r --- %n",x); CurrentFile!* := x; % Find current FILE name, see if new IF Not MEMBER(CurrentFile!*,FileList!*) THEN FileList!*:=CurrentFile!* . FileList!*; InspectForm U; END; FLAG('(INSPECTEND),'IGNORE); PUT('InspectEnd,'RlispPrefix,'(NIL LAMBDA(X) (ESTAT 'Inspectend))); procedure InspectForm U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn; if not PairP U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; InspectProc(Nam,Ty); RETURN NIL; DB1: % Simple S-EXPRESSION look for LAP etc. IF EQCAR(U,'LAP) Then Return InspectLap U; IF EQCAR(U,'Imports) then Return PrintF("%% --- Imports: %w in %w%n",Cadr U, CurrentFile!*); % Maybe indicate IMPORTS etc. RETURN NIL; DB2: % analyse PUTD NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; Procedure InspectProc(Nam,Ty); <<If !*PrintInspect then <<Prin1 NAM; Prin2 " ">>; ProcedureList!*:=NAM . ProcedureList!*; ProcFileList!*:=(NAM . CurrentFile!*) . ProcFileList!*>>; Procedure InspectLap U; For each x in U do if EQcar(x,'!*ENTRY) then InspectProc(Cadr U,Caddr U); % -- Handle LISTs of files and dirs --- Fluid '(!*PrintInspect !*QuietInspect); Nexpr procedure GetFileList L; GetFiles1 L; Procedure GetFiles1 L; If null L then Nil else append(Vector2List GetCleandir Car L, GetFiles1 Cdr L); procedure InspectToFile F; Begin scalar f1,c; f1:=Bldmsg("%s-%s.ins",GetFileName(f),GetExtension(f)); Printf(" Inspecting %r to %r%n",F,F1); c:=open(f1,'output); WRS c; !*PrintInspect:=NIL; Inspect F$ Prin2 "(ProcList '"$ Print ProcedureList!*; Prin2T ")"; WRS NIL; close c; End; procedure InspectAllFiles Files; For each x in files do <<PrintF("Doing file: %w%n",x); InspectToFile x>>; Procedure InspectAllPU(); InspectAllFiles getFileList("pu:*.red","PU:*.sl"); END; |
Added psl-1983/3-1/util/inum.build version [6105c2df6b].
> > | 1 2 | CompileTime load Syslisp; in "inum.red"$ |
Added psl-1983/3-1/util/inum.red version [ef4b74fbb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % INUM.RED - Interpreter entries for open-compiled integer arithmetic % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 March 1982 % Copyright (c) 1982 University of Utah % off R2I; CompileTime << smacro procedure InumTwoArg IName; lisp procedure IName(Arg1, Arg2); begin scalar Result; return if IntP Arg1 and IntP Arg2 and IntP(Result := IName(Arg1, Arg2)) then Result else Inum2Error(Arg1, Arg2, quote IName); end; smacro procedure InumTwoArgBool IName; lisp procedure IName(Arg1, Arg2); if IntP Arg1 and IntP Arg2 then IName(Arg1, Arg2) else Inum2Error(Arg1, Arg2, quote IName); smacro procedure InumOneArg IName; lisp procedure IName Arg; begin scalar Result; return if IntP Arg and IntP(Result := IName Arg) then Result else Inum1Error(Arg, quote IName); end; smacro procedure InumOneArgBool IName; lisp procedure IName Arg; if IntP Arg then IName Arg else Inum1Error(Arg, quote IName); >>; lisp procedure Inum2Error(Arg1, Arg2, Name); ContinuableError(99, "Inum out of range", list(Name, Arg1, Arg2)); lisp procedure Inum1Error(Arg, Name); ContinuableError(99, "Inum out of range", list(Name, Arg)); InumTwoArg IPlus2; InumTwoArg IDifference; InumTwoArg ITimes2; InumTwoArg IQuotient; InumTwoArg IRemainder; InumTwoArgBool ILessP; InumTwoArgBool IGreaterP; InumTwoArgBool ILEQ; InumTwoArgBool IGEQ; InumTwoArg ILOR; InumTwoArg ILAND; InumTwoArg ILXOR; InumTwoArg ILSH; InumOneArg IAdd1; InumOneArg ISub1; InumOneArg IMinus; InumOneArgBool IZeroP; InumOneArgBool IOneP; InumOneArgBool IMinusP; on R2I; macro procedure IFor U; MkSysFor U; if not FUnBoundP 'Begin1 then << DEFINEROP('IFOR,NIL,ParseIFOR); SYMBOLIC PROCEDURE ParseIFOR X; BEGIN SCALAR INIT,STP,UNTL,ACTION,ACTEXPR; IF (OP := SCAN()) EQ 'SETQ THEN INIT := PARSE0(6,T) ELSE PARERR("FOR missing loop VAR assignment",T); IF OP EQ '!*COLON!* THEN <<STP := 1; OP := 'UNTIL>> ELSE IF OP EQ 'STEP THEN STP := PARSE0(6,T) ELSE PARERR("FOR missing : or STEP clause",T); IF OP EQ 'UNTIL THEN UNTL := PARSE0(6,T) ELSE PARERR("FOR missing UNTIL clause",T); ACTION := OP; IF ACTION MEMQ '(DO SUM PRODUCT) THEN ACTEXPR := PARSE0(6,T) ELSE PARERR("FOR missing action keyword",T); RETURN LIST('IFOR, LIST('FROM,X,INIT,UNTL,STP), LIST(ACTION,ACTEXPR)) END; >>; END; |
Added psl-1983/3-1/util/iter-macros.sl version [e477afa829].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % ITER-MACROS.SL - macros for generalized iteration % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>ITER-MACROS.SL.9, 15-Sep-82 17:06:49, Edit by BENSON % Fixed typo, ((null (cdr result) nil)) ==> ((null (cdr result)) nil) (defmacro do (iterators result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (setq steps (cons (if (atom (car U)) (car U) (caar U)) (cons (caddr U) steps))) (list (car U) (cadr U))) U))) (let ((form `(prog () ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body (psetq ,.steps) (go ***DO-LABEL***)))) (if vars `(let ,vars ,form) form)))) (defmacro do* (iterators result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (push `(setq ,(if (atom (car U)) (car U) (caar U)) ,(caddr U)) steps) (list (car U) (cadr U))) U))) (let ((form `(prog () ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body ,.(reversip steps) (go ***DO-LABEL***)))) (if vars `(let* ,vars ,form) form)))) (defmacro do-loop (iterators prologue result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (setq steps (cons (if (atom (car U)) (car U) (caar U)) (cons (caddr U) steps))) (list (car U) (cadr U))) U))) (let ((form `(prog () ,@prologue ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body (psetq ,.steps) (go ***DO-LABEL***)))) (if vars `(let ,vars ,form) form)))) (defmacro do-loop* (iterators prologue result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (push `(setq ,(if (atom (car U)) (car U) (caar U)) ,(caddr U)) steps) (list (car U) (cadr U))) U))) (let ((form `(prog () ,@prologue ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body ,.(reversip steps) (go ***DO-LABEL***)))) (if vars `(let* ,vars ,form) form)))) |
Added psl-1983/3-1/util/kernel.build version [9817537c18].
> | 1 | in "kernel.sl"$ |
Added psl-1983/3-1/util/kernel.sl version [76849483bc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % KERNEL.SL - Generate scripts for building PSL kernel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.UTIL>KERNEL.SL.2, 20-Dec-82 11:21:03, Edit by BENSON % Added kernel-header and kernel-trailer % <PSL.UTIL>KERNEL.SL.9, 7-Jun-82 12:22:48, Edit by BENSON % Changed kernel-file to all-kernel-script-name* and all-kernel-script-format* % <PSL.UTIL>KERNEL.SL.8, 6-Jun-82 05:23:40, Edit by GRISS % Added kernel-file (compiletime (load useful)) (compiletime (flag '(build-link-script build-kernel-file build-init-file build-file-aux insert-file-names insert-file-names-aux) 'InternalFunction)) (fluid '(kernel-name-list* command-file-name* command-file-format* init-file-name* init-file-format* all-kernel-script-name* all-kernel-script-header* all-kernel-script-format* all-kernel-script-trailer* code-object-file-name* data-object-file-name* link-script-name* link-script-format* script-file-name-separator*)) (de kernel (kernel-name-list*) (let ((*lower t)) % For the benefit of Unix (build-command-files kernel-name-list*) % MAIN is not included in all-kernel-script (build-kernel-file (delete 'main kernel-name-list*)) (build-link-script) (build-init-file))) (de build-command-files (k-list) (unless (null k-list) (let ((name-stem (first k-list))) (let ((f (wrs (open (bldmsg command-file-name* name-stem) 'output)))) (printf command-file-format* name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem) (close (wrs f)))) (build-command-files (rest k-list)))) (de build-link-script () (let ((f (wrs (open link-script-name* 'output)))) (linelength 1000) (printf link-script-format* '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names)) (close (wrs f)))) (de build-kernel-file (n-list) (let ((f (wrs (open all-kernel-script-name* 'output)))) (linelength 1000) (unless (null all-kernel-script-header*) (prin2 all-kernel-script-header*)) (build-file-aux n-list all-kernel-script-format*) (unless (null all-kernel-script-trailer*) (prin2 all-kernel-script-trailer*)) (close (wrs f)))) (de insert-link-file-names () (insert-file-names kernel-name-list* code-object-file-name*) (prin2 script-file-name-separator*) (insert-file-names kernel-name-list* data-object-file-name*)) (de insert-file-names (n-list format) (printf format (first n-list)) (insert-file-names-aux (rest n-list) format)) (de insert-file-names-aux (n-list format) (unless (null n-list) (prin2 script-file-name-separator*) (printf format (first n-list)) (insert-file-names-aux (rest n-list) format))) (de build-init-file () (let ((f (wrs (open init-file-name* 'output)))) (build-file-aux kernel-name-list* init-file-format*) (close (wrs f)))) (de build-file-aux (n-list format) (unless (null n-list) (printf format (first n-list)) (build-file-aux (rest n-list) format))) |
Added psl-1983/3-1/util/loop.build version [f0e11f1f37].
> > > | 1 2 3 | CompileTime load Clcomp; off Usermode; in "loop.lsp"$ |
Added psl-1983/3-1/util/loop.lsp version [81c163669c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;(setq |SCCS-loop| "@(#)loop.l 1.2 7/9/81") ;-*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*- ;The master copy of this file is on ML:LSB1;LOOP > ;The current Lisp machine copy is on AI:LISPM2;LOOP > ;The FASL and QFASL should also be accessible from LIBLSP; on all machines. ; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP ; at any ITS site. ;; the file was franzified by JKF. ; ;; PSLified by Eric Benson, October 1982 ;;;; LOOP Iteration Macro ; Hack up the stuff for data-types. DATA-TYPE? will always be a macro ; so that it will not require the data-type package at run time if ; all uses of the other routines are conditionalized upon that value. (defmacro data-type? (x) `(get ,x ':data-type)) ;(declare ; (*lexpr variable-declarations) ; (*expr initial-value form-wrapper)) (eval-when (eval compile) (macro status (x) (errorprintf "***** %p" x) ()) (copyd 'sstatus 'status) (copyd 'variable-declarations 'status) (defmacro c-mapc (x y) `(mapc ,y ,x)) (defmacro c-mapcar (x y) `(mapcar ,y ,x)) (defmacro loop-error (x y) `(stderror (list ,x ,y))) ) ;Loop macro ;(eval-when (eval compile) ; (defun lexpr-funcall macro (x) ; `(apply ,(cadr x) (list* . ,(cddr x))))) (defun loop-displace (x y) ((lambda (val) (rplaca x (car val)) (rplacd x (cdr val)) x) (cond ((atom y) (list 'progn y)) (t y)))) (defmacro loop-finish () '(go end-loop)) (macro neq (x) `(not (eq . ,(cdr x)))) (defun loop-make-psetq (frobs) (loop-make-setq (car frobs) (cond ((null (cddr frobs)) (cadr frobs)) (t `(prog1 ,(cadr frobs) ,(loop-make-psetq (cddr frobs))))))) (defmacro loop-psetq frobs (loop-make-psetq frobs)) (defvar loop-keyword-alist ;clause introducers '( (initially loop-do-initially) (finally loop-do-finally) (do loop-do-do) (doing loop-do-do) (return loop-do-return) (collect loop-do-collect list) (collecting loop-do-collect list) (append loop-do-collect append) (appending loop-do-collect append) (nconc loop-do-collect nconc) (nconcing loop-do-collect nconc) (count loop-do-collect count) (counting loop-do-collect count) (sum loop-do-collect sum) (summing loop-do-collect sum) (maximize loop-do-collect max) (minimize loop-do-collect min) (always loop-do-always t) (never loop-do-always nil) (thereis loop-do-thereis) (while loop-do-while or) (until loop-do-while and) (when loop-do-when nil) (unless loop-do-when t) (with loop-do-with) (for loop-do-for) (as loop-do-for))) (defvar loop-for-keyword-alist ;Types of FOR '( (= loop-for-equals) (in loop-for-in) (on loop-for-on) (from loop-for-arithmetic nil) (downfrom loop-for-arithmetic down) (upfrom loop-for-arithmetic up) (being loop-for-being))) (defvar loop-path-keyword-alist nil) ; PATH functions (defvar loop-variables) ;Variables local to the loop (defvar loop-declarations) ; Local dcls for above (defvar loop-variable-stack) (defvar loop-declaration-stack) (defvar loop-prologue) ;List of forms in reverse order (defvar loop-body) ;.. (defvar loop-after-body) ;.. for FOR steppers (defvar loop-epilogue) ;.. (defvar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY (defvar loop-conditionals) ;If non-NIL, condition for next form in body ;The above is actually a list of entries of the form ;(condition forms...) ;When it is output, each successive condition will get ;nested inside the previous one, but it is not built up ;that way because you wouldn't be able to tell a WHEN-generated ;COND from a user-generated COND. (defvar loop-when-it-variable) ;See LOOP-DO-WHEN (defvar loop-collect-cruft) ; for multiple COLLECTs (etc) (defvar loop-source-code) (defvar loop-attachment-transformer ; see attachment definition (cond ((status feature lms) 'progn) (t nil))) (macro loop-lookup-keyword (x) `(assq . ,(cdr x))) (defun loop-add-keyword (cruft alist-name) (let ((val (symeval alist-name)) (known?)) (and (setq known? (loop-lookup-keyword (car cruft) val)) (set alist-name (delqip known? val))) (set alist-name (cons cruft val)))) (defmacro define-loop-macro (keyword) (or (eq keyword 'loop) (loop-lookup-keyword keyword loop-keyword-alist) (loop-error "lisp: Not a loop keyword -- " keyword)) `(eval-when (compile load eval) (putd ',keyword 'macro #'(lambda (macroarg) (loop-translate macroarg))))) (define-loop-macro loop) (defun loop-translate (x) (loop-displace x (loop-translate-1 x))) (defun loop-translate-1 (loop-source-code) (and (eq (car loop-source-code) 'loop) (setq loop-source-code (cdr loop-source-code))) (do ((loop-variables nil) (loop-declarations nil) (loop-variable-stack nil) (loop-declaration-stack nil) (loop-prologue nil) (loop-body nil) (loop-after-body nil) (loop-epilogue nil) (loop-after-epilogue nil) (loop-conditionals nil) (loop-when-it-variable nil) (loop-collect-cruft nil) (keyword) (tem)) ((null loop-source-code) (and loop-conditionals (loop-error "lisp: hanging conditional in loop macro -- " (caar loop-conditionals))) (cond (loop-variables (push loop-variables loop-variable-stack) (push loop-declarations loop-declaration-stack))) (setq tem `(prog () ,@(nreverse loop-prologue) next-loop ,@(nreverse loop-body) ,@(nreverse loop-after-body) (go next-loop) end-loop ,@(nreverse loop-epilogue) ,@(nreverse loop-after-epilogue))) (do ((vars) (dcls)) ((null loop-variable-stack)) (setq vars (pop loop-variable-stack) dcls (pop loop-declaration-stack)) (and dcls (setq dcls `((declare . ,(nreverse dcls))))) (setq tem `(,@dcls ,tem)) (cond ((do ((l vars (cdr l))) ((null l) nil) (and (not (atom (car l))) (not (atom (caar l))) (return t))) (setq tem `(let ,(nreverse vars) ,.tem))) (t (let ((lambda-vars nil) (lambda-vals nil)) (do ((l vars (cdr l)) (v)) ((null l)) (cond ((atom (setq v (car l))) (push v lambda-vars) (push nil lambda-vals)) (t (push (car v) lambda-vars) (push (cadr v) lambda-vals)))) (setq tem `((lambda ,(nreverse lambda-vars) ,.tem) ,.(nreverse lambda-vals)))))) ) tem) (if (symbolp (setq keyword (pop loop-source-code))) (if (setq tem (loop-lookup-keyword keyword loop-keyword-alist)) (apply (cadr tem) (cddr tem)) (loop-error "lisp: unknown keyword in loop macro -- " keyword)) (loop-error "lisp: loop found object where keyword expected -- " keyword)))) (defun loop-bind-block () (cond ((not (null loop-variables)) (push loop-variables loop-variable-stack) (push loop-declarations loop-declaration-stack) (setq loop-variables nil loop-declarations nil)) (loop-declarations (break)))) ;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary. (defun loop-get-form () (do ((forms (list (pop loop-source-code)) (cons (pop loop-source-code) forms)) (nextform (car loop-source-code) (car loop-source-code))) ((atom nextform) (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) (defun loop-make-setq (var-or-pattern value) (list (if (atom var-or-pattern) 'setq 'desetq) var-or-pattern value)) (defun loop-imply-type (expression type) (let ((frob (and (data-type? type) (form-wrapper type expression)))) (cond ((not (null frob)) frob) (t expression)))) (defun loop-make-variable (name initialization dtype) (cond ((null name) (and initialization (push (list nil initialization) loop-variables))) ((atom name) (cond ((data-type? dtype) (setq loop-declarations (append (variable-declarations dtype name) loop-declarations)) (or initialization (setq initialization (initial-value dtype)))) ((memq dtype '(fixnum flonum number)) (or initialization (setq initialization (if (eq dtype 'flonum) 0.0 0))))) (push (if initialization (list name initialization) name) loop-variables)) (initialization (push (list name initialization) loop-variables) (loop-declare-variable name dtype)) (t (let ((tcar) (tcdr)) (cond ((atom dtype) (setq tcar (setq tcdr dtype))) (t (setq tcar (car dtype) tcdr (cdr dtype)))) (loop-make-variable (car name) nil tcar) (loop-make-variable (cdr name) nil tcdr)))) name) (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype)) nil) ((atom name) (cond ((data-type? dtype) (setq loop-declarations (append (variable-declarations dtype name) loop-declarations))) )) ((atom dtype) (loop-declare-variable (car name) dtype) (loop-declare-variable (cdr name) dtype)) (t (loop-declare-variable (car name) (car dtype)) (loop-declare-variable (cdr name) (cdr dtype))))) (defun loop-maybe-bind-form (form data-type?) (cond ((or (numberp form) (memq form '(t nil)) (and (not (atom form)) (eq (car form) 'quote))) form) (t (loop-make-variable (gensym) form data-type?)))) (defun loop-optional-type () (let ((token (car loop-source-code))) (and (not (null token)) (or (not (atom token)) (data-type? token) (memq token '(fixnum flonum number))) (pop loop-source-code)))) ;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE, ;the second a string (lispm) or symbol (maclisp) to check against. (defmacro loop-tequal (x1 x2) `(eq ,x1 ,x2)) ;Incorporates conditional if necessary (defun loop-emit-body (form) (cond (loop-conditionals (rplacd (last (car (last loop-conditionals))) (cond ((and (not (atom form)) ;Make into list of forms (eq (car form) 'progn)) (append (cdr form) nil)) (t (list form)))) (cond ((loop-tequal (car loop-source-code) "and") (pop loop-source-code)) (t ;Nest up the conditionals and output them (do ((prev (car loop-conditionals) (car l)) (l (cdr loop-conditionals) (cdr l))) ((null l)) (rplacd (last prev) `((cond ,(car l))))) (push `(cond ,(car loop-conditionals)) loop-body) (setq loop-conditionals nil)))) (t (push form loop-body)))) (defun loop-do-initially () (push (loop-get-form) loop-prologue)) (defun loop-do-finally () (push (loop-get-form) loop-epilogue)) (defun loop-do-do () (loop-emit-body (loop-get-form))) (defun loop-do-return () (loop-emit-body `(return ,(loop-get-form)))) (defun loop-do-collect (type) (let ((var) (form) (tem) (tail) (dtype) (cruft) (rvar) (ctype (cond ((memq type '(max min)) 'maxmin) ((memq type '(nconc list append)) 'list) ((memq type '(count sum)) 'sum) (t (loop-error "lisp: unrecognized loop collecting keyword -- " type))))) (setq form (loop-get-form) dtype (loop-optional-type)) (cond ((loop-tequal (car loop-source-code) 'into) (pop loop-source-code) (setq rvar (setq var (pop loop-source-code))))) ; CRUFT will be (varname ctype dtype var tail (optional tem)) (cond ((setq cruft (assq var loop-collect-cruft)) (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) (loop-error "lisp: incompatible loop collections -- " (list ctype (car cruft)))) ((and dtype (not (eq dtype (cadr cruft)))) (loop-error "lisp: loop found unequal types in collector -- " (list type (list dtype (cadr cruft)))))) (setq dtype (car (setq cruft (cdr cruft))) var (car (setq cruft (cdr cruft))) tail (car (setq cruft (cdr cruft))) tem (cadr cruft)) (and (eq ctype 'maxmin) (not (atom form)) (null tem) (rplaca (cdr cruft) (setq tem (loop-make-variable (gensym) nil dtype))))) (t (and (null dtype) (setq dtype (cond ((eq type 'count) 'fixnum) ((memq type '(min max sum)) 'number)))) (or var (push `(return ,(setq var (gensym))) loop-after-epilogue)) (loop-make-variable var nil dtype) (setq tail (cond ((eq ctype 'list) (setq tem (loop-make-variable (gensym) nil nil)) (loop-make-variable (gensym) nil nil)) ((eq ctype 'maxmin) (or (atom form) (setq tem (loop-make-variable (gensym) nil dtype))) (loop-make-variable (gensym) nil nil)))) (push (list rvar ctype dtype var tail tem) loop-collect-cruft))) (loop-emit-body (selectq type (count (setq tem `(setq ,var (1+ ,var))) (cond ((eq form t) tem) (t `(and ,form ,tem)))) (sum `(setq ,var (plus ,(loop-imply-type form dtype) ,var))) ((max min) `(setq ,@(and tem (prog1 `(,tem ,form) (setq form tem))) ,var (cond (,tail (,type ,(loop-imply-type form dtype) ,var)) (t (setq ,tail t) ,form)))) (list `(setq ,tem (ncons ,form) ,tail (cond (,tail (cdr (rplacd ,tail ,tem))) ((setq ,var ,tem)))) ) (nconc `(setq ,tem ,form ,tail (last (cond (,tail (rplacd ,tail ,tem)) ((setq ,var ,tem)))))) (append `(setq ,tem (append ,form nil) ,tail (last (cond (,tail (rplacd ,tail ,tem)) ((setq ,var ,tem)))))))))) (defun loop-do-while (cond) (loop-emit-body `(,cond ,(loop-get-form) (go end-loop)))) (defun loop-do-when (negate?) (let ((form (loop-get-form)) (cond)) (cond ((loop-tequal (cadr loop-source-code) 'it) ;WHEN foo RETURN IT and the like (or loop-when-it-variable (setq loop-when-it-variable (loop-make-variable (gensym) nil nil))) (setq cond `(setq ,loop-when-it-variable ,form)) (setq loop-source-code ;Plug in variable for IT (list* (car loop-source-code) loop-when-it-variable (cddr loop-source-code)))) (t (setq cond form))) (and negate? (setq cond `(not ,cond))) (setq loop-conditionals (nconc loop-conditionals (ncons (list cond)))))) (defun loop-do-with () (do ((var) (equals) (val) (dtype)) (nil) (setq var (pop loop-source-code) equals (car loop-source-code)) (cond ((loop-tequal equals '=) (pop loop-source-code) (setq val (pop loop-source-code) dtype nil)) ((or (loop-tequal equals 'and) (loop-lookup-keyword equals loop-keyword-alist)) (setq val nil dtype nil)) (t (setq dtype (pop loop-source-code) equals (car loop-source-code)) (cond ((loop-tequal equals '=) (pop loop-source-code) (setq val (pop loop-source-code))) ((and (not (null loop-source-code)) (not (loop-lookup-keyword equals loop-keyword-alist)) (not (loop-tequal equals 'and))) (loop-error "lisp: loop was expecting = but found " equals)) (t (setq val nil))))) (loop-make-variable var val dtype) (cond ((not (loop-tequal (car loop-source-code) 'and)) (return nil)) ((pop loop-source-code)))) (loop-bind-block)) (defun loop-do-always (true) (let ((form (loop-get-form))) (or true (setq form `(not ,form))) (loop-emit-body `(or ,form (return nil))) (push '(return t) loop-after-epilogue))) ;THEREIS expression ;If expression evaluates non-nil, return that value. (defun loop-do-thereis () (let ((var (loop-make-variable (gensym) nil nil)) (expr (loop-get-form))) (loop-emit-body `(and (setq ,var ,expr) (return ,var))))) ;FOR variable keyword ..args.. {AND more-clauses} ;For now AND only allowed with the = keyword (defun loop-do-for () (and loop-conditionals (loop-error "lisp: loop for or as starting inside of conditional")) (do ((var) (data-type?) (keyword) (first-arg) (tem) (pretests) (posttests) (inits) (steps)) (nil) (setq var (pop loop-source-code) data-type? (loop-optional-type) keyword (pop loop-source-code) first-arg (pop loop-source-code)) (and (or (not (symbolp keyword)) (null (setq tem (loop-lookup-keyword keyword loop-for-keyword-alist)))) (loop-error "lisp: unknown keyword in for or as loop clause -- " keyword)) (setq tem (lexpr-funcall (cadr tem) var first-arg data-type? (cddr tem))) (and (car tem) (push (car tem) pretests)) (setq inits (nconc inits (append (car (setq tem (cdr tem))) nil))) (and (car (setq tem (cdr tem))) (push (car tem) posttests)) (setq steps (nconc steps (append (car (setq tem (cdr tem))) nil))) (cond ((not (loop-tequal (car loop-source-code) 'and)) (cond ((cdr (setq pretests (nreverse pretests))) (push 'or pretests)) (t (setq pretests (car pretests)))) (cond ((cdr (setq posttests (nreverse posttests))) (push 'or posttests)) (t (setq posttests (car posttests)))) (and pretests (push `(and ,pretests (go end-loop)) loop-body)) (and inits (push (loop-make-psetq inits) loop-body)) (and posttests (push `(and ,posttests (go end-loop)) loop-after-body)) (and steps (push (loop-make-psetq steps) loop-after-body)) (loop-bind-block) (return nil)) (t (pop loop-source-code))))) (defun loop-for-equals (var val data-type?) (cond ((loop-tequal (car loop-source-code) 'then) ;FOR var = first THEN next (pop loop-source-code) (loop-make-variable var val data-type?) (list nil nil nil `(,var ,(loop-get-form)))) (t (loop-make-variable var nil data-type?) (list nil `(,var ,val) nil nil)))) (defun loop-for-on (var val data-type?) (let ((step (if (loop-tequal (car loop-source-code) 'by) (progn (pop loop-source-code) (pop loop-source-code)) '(function cdr))) (var1 (cond ((not (atom var)) ; Destructuring? Then we can't use VAR as the ; iteration variable. (loop-make-variable var nil nil) (loop-make-variable (gensym) val nil)) (t (loop-make-variable var val nil) var)))) (setq step (cond ((or (atom step) (not (memq (car step) '(quote function)))) `(funcall ,(loop-make-variable (gensym) step nil) ,var1)) (t (list (cadr step) var1)))) (list `(null ,var1) (and (not (eq var var1)) `(,var ,var1)) nil `(,var1 ,step)))) (defun loop-for-in (var val data-type?) (let ((var1 (gensym)) ;VAR1 is list, VAR is element (step (if (loop-tequal (car loop-source-code) 'by) (progn (pop loop-source-code) (pop loop-source-code)) '(function cdr)))) (loop-make-variable var1 val nil) (loop-make-variable var nil data-type?) (setq step (cond ((or (atom step) (not (memq (car step) '(quote function)))) `(funcall (loop-make-variable (gensym) step nil) var1)) (t (list (cadr step) var1)))) (list `(null ,var1) `(,var (car ,var1)) nil `(,var1 ,step)))) (defun loop-for-arithmetic (var val data-type? forced-direction) (let ((limit) (step 1) (test) (direction) (eval-to-first t) (inclusive)) (do () (nil) (cond ((not (symbolp (car loop-source-code))) (return nil)) ((loop-tequal (car loop-source-code) 'by) (pop loop-source-code) (setq step (loop-get-form) eval-to-first t)) ((loop-tequal (car loop-source-code) 'to) (pop loop-source-code) (setq limit (loop-get-form) inclusive t eval-to-first nil)) ((loop-tequal (car loop-source-code) 'downto) (pop loop-source-code) (setq limit (loop-get-form) inclusive t eval-to-first nil direction 'down)) ((loop-tequal (car loop-source-code) 'below) (pop loop-source-code) (setq limit (loop-get-form) direction 'up eval-to-first nil)) ((loop-tequal (car loop-source-code) 'above) (pop loop-source-code) (setq limit (loop-get-form) direction 'down eval-to-first nil)) (t (return nil)))) (cond ((null direction) (setq direction (or forced-direction 'up))) ((and forced-direction (not (eq forced-direction direction))) (loop-error "lisp: loop variable stepping lossage with " var))) (or data-type? (setq data-type? 'fixnum)) (and (eq data-type? 'flonum) (fixp step) (setq step (float step))) (loop-make-variable var val data-type?) (cond ((and limit eval-to-first) (setq limit (loop-maybe-bind-form limit data-type?)))) (setq step (loop-maybe-bind-form step data-type?)) (cond ((and limit (not eval-to-first)) (setq limit (loop-maybe-bind-form limit data-type?)))) (cond ((not (null limit)) (let ((z (list var limit))) (setq test (cond ((eq direction 'up) (cond (inclusive `(greaterp . ,z)) (t `(not (lessp . ,z))))) (t (cond (inclusive `(lessp . ,z)) (t `(not (greaterp . ,z)))))))))) (setq step (cond ((eq direction 'up) (cond ((equal step 1) `(add1 ,var)) (t `(plus ,var ,step)))) ((equal step 1) `(sub1 ,var)) (t `(difference ,var ,step)))) ;; The object of the following crock is to get the INTERPRETER to ;; do error checking. This is only correct for data-type of FIXNUM, ;; since floating-point arithmetic is contagious. #+Maclisp (and (eq data-type? 'fixnum) (rplaca step (cdr (assq (car step) '((sub1 . 1-) (add1 . 1+) (plus . +) (difference . -)))))) (list test nil nil `(,var ,step)))) (defun loop-for-being (var val data-type?) ; FOR var BEING something ... - var = VAR, something = VAL. ; If what passes syntactically for a pathname isn't, then ; we trap to the ATTACHMENTS path; the expression which looked like ; a path is given as an argument to the IN preposition. If ; LOOP-ATTACHMENT-TRANSFORMER is not NIL, then we call that on the ; "form" to get the actual form; otherwise, we quote it. Thus, ; by default, FOR var BEING EACH expr OF expr-2 ; ==> FOR var BEING ATTACHMENTS IN 'expr OF expr-2. (let ((tem) (inclusive?) (ipps) (each?) (attachment)) (cond ((loop-tequal val "each") (setq each? t val (car loop-source-code))) (t (push val loop-source-code))) (cond ((and (setq tem (loop-lookup-keyword val loop-path-keyword-alist)) (or each? (not (loop-tequal (cadr loop-source-code) 'and)))) ;; FOR var BEING {each} path {prep expr}..., but NOT ;; FOR var BEING var-which-looks-like-path AND {ITS} ... (pop loop-source-code)) (t (setq val (loop-get-form)) (cond ((loop-tequal (car loop-source-code) 'and) ;; FOR var BEING value AND ITS path-or-ar (or (null each?) (loop-error "lisp: malformed being clause in loop of var " var)) (setq ipps `((of ,val)) inclusive? t) (pop loop-source-code) (or (loop-tequal (setq tem (pop loop-source-code)) 'its) (loop-tequal tem 'his) (loop-tequal tem 'her) (loop-tequal tem 'their) (loop-tequal tem 'each) (loop-error "lisp: loop expected its or each but found " tem)) (cond ((setq tem (loop-lookup-keyword (car loop-source-code) loop-path-keyword-alist)) (pop loop-source-code)) (t (push (setq attachment `(in ,(loop-get-form))) ipps)))) ((not (setq tem (loop-lookup-keyword (car loop-source-code) loop-path-keyword-alist))) ; FOR var BEING {each} a-r ... (setq ipps (list (setq attachment (list 'in val))))) (t ; FOR var BEING {each} pathname ... ; Here, VAL should be just PATHNAME. (pop loop-source-code))))) (cond ((not (null tem))) ((not (setq tem (loop-lookup-keyword 'attachments loop-path-keyword-alist))) (loop-error "lisp: loop trapped to attachments path illegally")) (t (or attachment (break)) (rplaca (cdr attachment) (cond (loop-attachment-transformer (funcall loop-attachment-transformer (cadr attachment))) (t (list 'quote (cadr attachment))))))) (setq tem (funcall (cadr tem) (car tem) var data-type? (nreconc ipps (loop-gather-preps (caddr tem))) inclusive? (caddr tem) (cdddr tem))) ;; TEM is now (bindings prologue-forms endtest setups steps) (c-mapc #'(lambda (x) (let (var val dtype) (cond ((atom x) (setq var x)) (t (setq var (car x) val (cadr x) dtype (caddr x)))) (loop-make-variable var val dtype))) (car tem)) (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue)) (cddr tem))) (defun loop-gather-preps (preps-allowed) (do ((list nil (cons (list (pop loop-source-code) (loop-get-form)) list)) (token (car loop-source-code) (car loop-source-code))) ((not (memq token preps-allowed)) (nreverse list)))) (defun loop-add-path (name data) (loop-add-keyword (cons name data) 'loop-path-keyword-alist)) (defmacro define-loop-path (names . cruft) (let ((forms ())) (setq forms (c-mapcar #'(lambda (name) `(loop-add-path ',name ',cruft)) (cond ((atom names) (list names)) (t names)))) `(eval-when (eval load compile) ,@forms))) (defun loop-path-carcdr (name var dtype pps inclusive? preps data) preps dtype ;Prevent unused arguments error (let ((vars) (step) (endtest `(,(cadr data) ,var)) (tem)) (or (setq tem (loop-lookup-keyword 'of pps)) (loop-error "lisp: loop path has no initialization -- " name)) (setq vars `((,var ,(cond (inclusive? (cadr tem)) (t `(,(car data) ,(cadr tem)))) ,dtype))) (setq step `(,var (,(car data) ,var))) (list vars nil nil nil endtest step))) (defun loop-interned-symbols-path (path variable data-type prep-phrases inclusive? allowed-preps data) path data-type allowed-preps data ; unused vars ; data-type should maybe be error-checked..... (let ((bindings) (presteps) (pretest) (poststeps) (posttest) (prologue) (indexv) (listv) (ob) (test) (step)) (push variable bindings) (and (not (null prep-phrases)) (or (cdr prep-phrases) (and (not (loop-tequal (caar prep-phrases) 'in)) (not (loop-tequal (caar prep-phrases) 'of)))) (loop-error "Illegal prep phrase(s) in interned-symbols path --" (list* variable 'being path prep-phrases))) (push (list (setq ob (gensym)) (cond ((null prep-phrases) 'obarray ) (t (cadar prep-phrases)))) bindings) ; Multics lisp does not store single-char-obs in the obarray buckets. ; Thus, we need to iterate over the portion of the obarray ; containing them also. (511. = (ascii 0)) (push `(,(setq indexv (gensym)) #+Multics 639. #+(and Maclisp (not Multics)) 511. #+Lispm 0 fixnum) bindings) #+Maclisp (push `(,(setq listv (gensym)) nil) bindings) #+Lispm (push `(setq ,indexv (array-dimension-n 2 ,ob)) prologue) (setq test `(and #-Multics (null ,listv) #+Multics (or (> ,indexv 510.) (null ,listv)) (prog () lp (cond ((< (setq ,indexv (1- ,indexv)) 0) (return t)) ((setq ,listv (arraycall #+Multics obarray #-Multics t ,ob ,indexv)) (return nil)) (t (go lp))))) ) (setq step `(,variable #+Multics (cond ((> ,indexv 510.) ,listv) (t (prog2 nil (car ,listv) (setq ,listv (cdr ,listv))))) #+(and Maclisp (not Multics)) (car ,listv) #+Lispm (ar-2 ,ob 1 ,indexv))) (cond (inclusive? (setq posttest test poststeps step prologue `((setq ,variable ,ob)))) (t (setq pretest test presteps step))) #+(and Maclisp (not Multics)) (setq poststeps `(,@poststeps ,listv (cdr ,listv))) (list bindings prologue pretest presteps posttest poststeps))) ; We don't want these defined in the compilation environment because ; the appropriate environment hasn't been set up. So, we just bootstrap ; them up. (c-mapc #'(lambda (x) (c-mapc #'(lambda (y) (loop-add-path y (cdr x))) (car x))) '(((car cars) loop-path-carcdr (of) car atom) ((cdr cdrs) loop-path-carcdr (of) cdr atom) ((cddr cddrs) loop-path-carcdr (of) cddr null) ((interned-symbols interned-symbol) loop-interned-symbols-path (in)) )) (or (status feature loop) (sstatus feature loop)) ;Loop macro blathering. ; ; This doc is totally wrong. Complete documentation (nice looking ; hardcopy) is available from GSB, or from ML:LSBDOC;LPDOC (which ; needs to be run through BOLIO). ; ;This is intended to be a cleaned-up version of PSZ's FOR package ;which is a cleaned-up version of the Interlisp CLisp FOR package. ;Note that unlike those crocks, the order of evaluation is the ;same as the textual order of the code, always. ; ;The form is introduced by the word LOOP followed by a series of clauses, ;each of which is introduced by a keyword which however need not be ;in any particular package. Certain keywords may be made "major" ;which means they are global and macros themselves, so you could put ;them at the front of the form and omit the initial "LOOP". ; ;Each clause can generate: ; ; Variables local to the loop. ; ; Prologue Code. ; ; Main Code. ; ; Epilogue Code. ; ;Within each of the three code sections, code is always executed strictly ;in the order that the clauses were written by the user. For parallel assignments ;and such there are special syntaxes within a clause. The prologue is executed ;once to set up. The main code is executed several times as the loop. The epilogue ;is executed once after the loop terminates. ; ;The term expression means any Lisp form. The term expression(s) means any number ;of Lisp forms, where only the first may be atomic. It stops at the first atom ;after the first form. ; ;The following clauses exist: ; ;Prologue: ; INITIALLY expression(s) ; This explicitly inserts code into the prologue. More commonly ; code comes from variable initializations. ; ;Epilogue: ; FINALLY expression(s) ; This is the only way to explicitly insert code into the epilogue. ; ;Side effects: ; DO expression(s) ; The expressions are evaluated. This is how you make a "body". ; DOING is synonymous with DO. ; ;Return values: ; RETURN expression(s) ; The last expression is returned immediately as the value of the form. ; This is equivalent to DO (RETURN expression) which you will ; need to use if you want to return multiple values. ; COLLECT expression(s) ; The return value of the form will be a list (unless over-ridden ; with a RETURN). The list is formed out of the values of the ; last expression. ; COLLECTING is synonymous with COLLECT. ; APPEND (or APPENDING) and NCONC (or NCONCING) can be used ; in place of COLLECT, forming the list in the appropriate ways. ; COUNT expression(s) ; The return value of the form will be the number of times the ; value of the last expression was non-NIL. ; SUM expression(s) ; The return value of the form will be the arithmetic sum of ; the values of the last expression. ; The following are a bit wierd syntactically, but Interlisp has them ; so they must be good. ; ALWAYS expression(s) ; The return value will be T if the last expression is true on ; every iteration, NIL otherwise. ; NEVER expressions(s) ; The return value will be T if the last expression is false on ; every iteration, NIL otherwise. ; THEREIS expression(s) ; This is wierd, I'm not sure what it really does. ; You probably want WHEN (NUMBERP X) RETURN X ; or maybe WHEN expression RETURN IT ; ;Conditionals: (these all affect only the main code) ; ; WHILE expression ; The loop terminates at this point if expression is false. ; UNTIL expression ; The loop terminates at this point if expression is true. ; WHEN expression clause ; Clause is performed only if expression is true. ; This affects only the main-code portion of a clause ; such as COLLECT. Use with FOR is a little unclear. ; IF is synonymous with WHEN. ; WHEN expression RETURN IT (also COLLECT IT, COUNT IT, SUM IT) ; This is a special case, the value of expression is returned if non-NIL. ; This works by generating a temporary variable to hold ; the value of the expression. ; UNLESS expression clause ; Clause is performed only if expression is false. ; ;Variables and iterations: (this is the hairy part) ; ; WITH variable = expression {AND variable = expression}... ; The variable is set to the expression in the prologue. ; If several variables are chained together with AND ; the setq's happen in parallel. Note that all variables ; are bound before any expressions are evaluated (unlike DO). ; ; FOR variable = expression {AND variable = expression}... ; At this point in the main code the variable is set to the expression. ; Equivalent to DO (PSETQ variable expression variable expression...) ; except that the variables are bound local to the loop. ; ; FOR variable FROM expression TO expression {BY expression} ; Numeric iteration. BY defaults to 1. ; BY and TO may be in either order. ; If you say DOWNTO instead of TO, BY defaults to -1 and ; the end-test is reversed. ; If you say BELOW instead of TO or ABOVE instead of DOWNTO ; the iteration stops before the end-value instead of after. ; The expressions are evaluated in the prologue then the ; variable takes on its next value at this point in the loop; ; hair is required to win the first time around if this FOR is ; not the first thing in the main code. ; FOR variable IN expression ; Iteration down members of a list. ; FOR variable ON expression ; Iteration down tails of a list. ; FOR variable IN/ON expression BY expression ; This is an Interlisp crock which looks useful. ; FOR var ON list BY expression[var] ; is the same as FOR var = list THEN expression[var] ; FOR var IN list BY expression[var] ; is similar except that var gets tails of the list ; and, kludgiferously, the internal tail-variable ; is substituted for var in expression. ; FOR variable = expression THEN expression ; General DO-type iteration. ; Note that all the different types of FOR clauses can be tied together ; with AND to achieve parallel assignment. Is this worthwhile? ; [It's only implemented for = mode.] ; AS is synonymous with FOR. ; ; FOR variable BEING expression(s) AND ITS pathname ; FOR variable BEING expression(s) AND ITS a-r ; FOR variable BEING {EACH} pathname {OF expression(s)} ; FOR variable BEING {EACH} a-r {OF expression(s)} ; Programmable iteration facility. Each pathname has a ; function associated with it, on LOOP-PATH-KEYWORD-ALIST; the ; alist has entries of the form (pathname function prep-list). ; prep-list is a list of allowed prepositions; after either of ; the above formats is parsed, then pairs of (preposition expression) ; are collected, while preposition is in prep-list. The expression ; may be a progn if there are multiple prepositions before the next ; keyword. The function is then called with arguments of: ; pathnname variable prep-phrases inclusive? prep-list ; Prep-phrases is the list of pairs collected, in order. Inclusive? ; is T for the first format, NIL otherwise; it says that the init ; value of the form takes on expression. For the first format, the ; list (OF expression) is pushed onto the fromt of the prep-phrases. ; In the above examples, a-r is a form to be evaluated to get an ; attachment-relationship. In this case, the pathname is taken as ; being ATTACHMENTS, and a-r is passed in by being treated as if it ; had been used with the preposition IN. The function should return ; a list of the form (bindings init-form step-form end-test); bindings ; are stuffed onto loop-variables, init-form is initialization code, ; step-form is step-code, and end-test tells whether or not to exit. ; ;Declarations? Not needed by Lisp machine. For Maclisp these will be done ;by a reserved word in front of the variable name as in PSZ's macro. ; ;The implementation is as a PROG. No initial values are given for the ;PROG-variables. PROG1 is used for parallel assignment. ; ;The iterating forms of FOR present a special problem. The problem is that ;you must do everything in the order that it was written by the user, but the ;FOR-variable gets its value in a different way in the first iteration than ;in the subsequent iterations. Note that the end-tests created by FOR have ;to be done in the appropriate order, since otherwise the next clause might get ;an error. ; ;The most general way is to introduce a flag, !FIRST-TIME, and compile the ;clause "FOR var = first TO last" as "INITIALLY (SETQ var first) ;WHEN (NOT !FIRST-TIME) DO (SETQ var (1+ var)) WHILE (<= var last)". ;However we try to optimize this by recognizing a special case: ;The special case is recognized where all FOR clauses are at the front of ;the main code; in this case if there is only one its stepping and ;endtest are moved to the end, and a jump to the endtest put at the ;front. If there are more than one their stepping and endtests are moved ;to the end, with duplicate endtests at the front except for the last ;which doesn't need a duplicate endtest. If FORs are embedded in the ;main code it can only be implemented by either a first-time flag or ;starting the iteration variable at a special value (initial minus step ;in the numeric iteration case). This could probably just be regarded as ;an error. The important thing is that it never does anything out of ;order. |
Added psl-1983/3-1/util/macroexpand.sl version [207f063148].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MACROEXPAND.SL - tools for expanding macros in forms % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>MACROEXPAND.SL.15, 2-Sep-82 10:32:10, Edit by BENSON % Fixed multiple argument SETQ macro expansion (defmacro macroexpand (form . macros) `(macroexpand1 ,form (list ,@macros))) (fluid '(macroexpand-signal*)) (de macroexpand1 (U L) (let ((macroexpand-signal* nil)(*macro-displace nil)) (while (null macroexpand-signal*) (setq macroexpand-signal* t) (setq U (macroexpand2 U L)))) U) (de macroexpand2 (U L) (cond ((or (atom U) (constantp (car U))) U) ((eqcar (car U) 'lambda) `((lambda ,(cadar U) ,.(foreach V in (cddar U) collect (macroexpand2 V L))) ,.(foreach V in (cdr U) collect (macroexpand2 V L)))) ((not (idp (car U))) U) (t (let ((fn (getd (car U)))(spfn (get (car U) 'macroexpand-func))) (cond (spfn (apply spfn (list U L))) ((eqcar fn 'fexpr) U) ((and (eqcar fn 'macro) (or (null L) (memq (car U) L))) (setq macroexpand-signal* nil) (apply (cdr fn) (list U))) (t (cons (car U) (foreach V in (cdr U) collect (macroexpand2 V L))))))))) (de macroexpand-cond (U L) (cons 'cond (foreach V in (cdr U) collect (foreach W in V collect (macroexpand2 W L))))) (de macroexpand-prog (U L) `(prog ,(cadr U) ,.(foreach V in (cddr U) collect (macroexpand2 V L)))) (de macroexpand-random (U L) (cons (car U) (foreach V in (cdr U) collect (macroexpand2 V L)))) (deflist '( % Should probably add a bunch more... (prog macroexpand-prog) (progn macroexpand-random) (cond macroexpand-cond) (and macroexpand-random) (or macroexpand-random) (setq macroexpand-random) (function macroexpand-random) ) 'macroexpand-func) (de macroexpand-loop () (catch 'macroexpand-loop `(toploop ',(and toploopread* #'read) ',#'prettyprint ',#'(lambda (u) (if (atom u) (throw 'macroexpand-loop) (macroexpand u))) "expand" ',(bldmsg "Entering macroexpand loop (atomic input forces exit) %w..." (if (and toploopread* (idp toploopread*) (not (eq toploopread* 'read))) (bldmsg "[reading with %w]" toploopread*) "")))) (printf "... Leaving macroexpand loop.")) |
Added psl-1983/3-1/util/man.sl version [3ff2d1677b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% MAN -- an online PSL reference manual facility. %%% Principal features are easy access to the index and %%% a command to jump directly from a line in the index %%% to the place in the manual referred to. %%% %%% Author: Cris Perdue %%% Date: 12/1/82 %%% %%% This package is still under development. %%% An index browsing mode is contemplated, also use of a specialized %%% representation of the reference manual. %%% A concept index browser and a table of contents browser %%% are contemplated as extensions. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Edit by Cris Perdue, 8 Feb 1983 1145-PST % Modified to use functions now defined in their own modules. (compiletime (load fast-int if extended-char)) (imports '(nmode string-search string-input)) %%% Defines 2 new nondestructive commands for text mode, %%% which seems to make them apply in LISP mode as well. %%% One is M-!, which takes you to information about the %%% subject of interest in the chapter and page referred to %%% by the next index reference. %%% The other is C-X I, which does a "Find File" on the file %%% containing the function index to the PSL manual. (add-to-command-list 'read-only-text-command-list (x-char M-!!) 'index-browse-command) (add-to-command-list 'read-only-text-command-list (x-chars C-X i) 'get-index-buffer) (nmode-establish-current-mode) (fluid '(manual-chapters manual-file-template)) % 0-TITLEPAGE % 00-PREFACE % 000-CONTENTS %%% A list of strings, each containing the base name of a chapter %%% of the manual. The first member of this list must be %%% referred to as chapter 1 in index references, and similarly %%% for other elements of the list. (setq manual-chapters '( "01-INTRODUCTION" "02-GETSTART" "03-RLISP" "04-DATATYPES" "05-NUMBERS" "06-IDS" "07-LISTS" "08-STRINGS" "09-FLOWOFCONTROL" "10-FUNCTIONS" "11-INTERP" "12-GLOBALS" "13-IO" "14-TOPLOOP" "15-ERRORS" "16-DEBUG" "17-EDITOR" "18-UTILITIES" "19-COMPLR" "20-DEC20" "21-SYSLISP" "22-IMPLEMENTATION" "23-PARSER" "24-BIBLIO" "25-FUN-INDEX" "26-TOP-INDEX" )) %%% This variable is a template for the name of a file that is %%% part of the manual. Actual manual file names are obtained by %%% substituting a name from the name list into this template. (setq manual-file-template "plpt:%w.lpt") (defun get-index-buffer () (find-file (bldmsg manual-file-template "25-FUN-INDEX"))) %%% This function gets the name that information is desired for, %%% gets the chapter and page of the "next" index reference after %%% point, does a "Find File" on the appropriate manual file, %%% goes to the appropriate page, and searches for an occurrence %%% of the key string. (defun index-browse-command () (let ((l (=> nmode-current-buffer current-line))) (let ((key (get-key l)) (dotpos (get-dot-pos l (=> nmode-current-buffer char-pos))) digitpos endpos chapter page) %% The first "." coming after point and with a digit on either %% side is used as the "." of the index entry. %% Contiguous digits to either side of the "." are taken %% to be chapter and page of the reference. %% This allows the user to distinguish between different %% index references even on the same line. (if (or (null key) (null dotpos)) then (ding) else (setq digitpos %% Search for non-digit or beginning of line. %% Position of earliest digit is returned. (for (from i (- dotpos 2) 0 -1) (do (if (not (digitp (indx l i))) then (return (+ i 1)))) (finally (return 0)))) (setq chapter (string-read (substring l digitpos dotpos))) %% Endpos is set to position of first non-digit after %% the page number, or end of line position, if all digits %% to end of line. (setq endpos (search-in-string-fn 'not-digitp l (+ dotpos 1))) (if (null endpos) then (setq endpos (+ (isizes l) 1))) (setq page (string-read (substring l (+ dotpos 1) endpos))) (find-file (bldmsg manual-file-template (nth manual-chapters chapter))) (move-to-buffer-start) %% Skip over pages preceding the desired one. (for (from i 1 (- page 1)) (do (forward-search "") (move-over-characters 1))) %% Search for an occurrence of the key string. %% This part should perhaps be refined to only move to %% a place within the page of interest. %% Note that forward-search expects the key to be entirely %% upper case and leaves point at the beginning of the string %% if found. (forward-search (string-upcase key)))))) %%% The key is taken to be a substring of the line string. %%% The key starts at the first nonblank character and runs %%% up to the first occurrence of either ". " or " .". This %%% is dependent on the precise format of index files produced %%% by Scribe. %%% This function is capable of returning NIL. (defun get-key (line) (let ((p1 (string-search ". " line)) (p2 (string-search " ." line))) (let ((end-pos (if (and p1 p2) then (min p1 p2) elseif (and p1 (null p2)) then p1 elseif (and p2 (null p1)) then p2 else nil)) (key-pos (search-in-string-fn 'nonblank line 0))) (if (and key-pos end-pos) then (substring line key-pos end-pos) else nil)))) %%% Searches for a dot which must be at or after "start". %%% The dot must be surrounded by a digit on either side. %%% NIL is returned if none found. (defun get-dot-pos (line start) (for (for dotpos (string-search-from "." line start) (string-search-from "." line (+ dotpos 1))) (while dotpos) (do (if (and (digitp (indx line (- dotpos 1))) (digitp (indx line (+ dotpos 1)))) then (return dotpos))))) (defun not-digitp (c) (not (digitp c))) (defun nonblank (c) (neq c #\SPACE)) %%% The position of the first character of the domain for which %%% testfn returns true and whose index is at least "start" is %%% returned. If none such exists, NIL is returned. (defun search-in-string-fn (testfn domain start) (if (not (stringp domain)) then (error 0 "Arg to search-in-string-fn not a string")) (for (from i start (isizes domain)) (do (if (funcall testfn (igets domain i)) then (return i))) (finally (return nil)))) |
Added psl-1983/3-1/util/mathlib.build version [a671fc4fa9].
> | 1 | in "mathlib.red"$ |
Added psl-1983/3-1/util/mathlib.red version [0fa5c5ceb3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. MATHLIB.RED - Some useful mathematical functions for PSL % % Most of these routines not very heavily tested. % Contributions from Galway, Griss, Irish, Morrison, and others. % % MATHLIB.RED, 16-Dec-82 21:56:52, Edit by GALWAY % Various fixes and enhancements too numerous for me to remember. % Includes fixes in SQRT function, modifications of RANDOM and other % functions to bring them more in line with Common Lisp, addition of MOD % and FLOOR. % <PSL.UTIL>MATHLIB.RED.13, 13-Sep-82 08:49:52, Edit by BENSON % Bug in EXP, changed 2**N to 2.0**N % <PSL.UTIL>MATHLIB.RED.12, 2-Sep-82 09:22:19, Edit by BENSON % Changed all calls in REDERR to calls on STDERROR % <PSL.UTIL>MATHLIB.RED.2, 17-Jan-82 15:48:21, Edit by GRISS % changed for PSL % Should these names be changed so that they all begin with an F or some % other distinguishing mark? Are they in conflict with anything? Or should % we wait until we have packages? % Consider using Sasaki's BigFloat package -- it has all this and more, to % arbitrary precision. The only drawback is speed. %***************** Constants declared as NewNam's **************************** % We can't use these long ones in Lisp1.6 'cause the reader craps out (and % it would truncate instead of round, anyway). These are here for reference % for implementation on other machines. % put('NumberPi,'NewNam,3.14159265358979324); % put('NumberPi!/2,'NewNam,1.57079632679489662); % put('NumberPi!/4,'NewNam,0.785398163397448310); BothTimes << put('Number2Pi,'NewNam,6.2831853); put('NumberPi,'NewNam,3.1415927); put('NumberPi!/2,'NewNam,1.5707963); put('NumberPi!/4,'NewNam,0.78539816); put('Number3Pi!/4,'NewNam,2.3561945); put('Number!-2Pi,'Newnam,-6.2831853); put('Number!-Pi,'NewNam,-3.1415927); put('Number!-Pi!/2,'NewNam,-1.5707963); put('Number!-Pi!/4,'NewNam,-0.78539816); put('SqrtTolerance,'NewNam,0.0000001); put('NumberE, 'NewNam, 2.718281828); put('NumberInverseE, 'NewNam, 0.36787944); % 1/e put('NaturalLog2,'NewNam,0.69314718); put('NaturalLog10,'NewNam,2.3025851); put('TrigPrecisionLimit,'NewNam,80); >>; %********************* Basic functions *************************************** lisp procedure mod(M,N); % Return M modulo N. Unlike remainder function--it returns positive result % in range 0..N-1, even if M is negative. (Needs more work for case of % negative N.) begin scalar result; result := remainder(M,N); if result >= 0 then return result; % else return N + result; end; lisp procedure Floor X; % Returns the largest integer less than or equal to X. (I.e. the "greatest % integer" function.) if fixp X then X else begin scalar N; N := fix X; % Note the trickiness to compensate for fact that (unlike APL's "FLOOR" % function) FIX truncates towards zero. return if X = float N then N else if X>=0 then N else N-1; end; lisp procedure Ceiling X; % Returns the smallest integer greater than or equal to X. if fixp X then X else begin scalar N; N := fix X; % Note the trickiness to compensate for fact that (unlike APL's "FLOOR" % function) FIX truncates towards zero. return if X = float N then N else if X>0 then N+1 else N; end; lisp procedure Round X; % Rounds to the closest integer. % Kind of sloppy -- it's biased when the digit causing rounding is a five, % it's a bit weird with negative arguments, round(-2.5)= -2. if fixp X then X else floor(X+0.5); %***************** Trigonometric Functions *********************************** % Trig functions are all in radians. The following few functions may be used % to convert to/from degrees, or degrees/minutes/seconds. lisp procedure DegreesToRadians x; x*0.017453292; % 2*pi/360 lisp procedure RadiansToDegrees x; x*57.29578; % 360/(2*pi) lisp procedure RadiansToDMS x; % Converts radians to a list of degrees, minutes, and seconds (rounded, not % truncated, to the nearest integer). begin scalar Degs,Mins; x := RadiansToDegrees x; Degs := fix x; x := 60*(x-Degs); Mins := fix x; return list(Degs,Mins, Round(60*(x-Mins))) end; lisp procedure DMStoRadians(Degs,Mins,Sex); % Converts degrees, minutes, seconds to radians. % DegreesToRadians(Degs+Mins/60.0+Sex/3600.0) DegreesToRadians(Degs+Mins*0.016666667+Sex*0.00027777778); lisp procedure sin x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of SIN"; if x > NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then << neg := not neg; x := -x >>; if x > NumberPi!/2 then x := NumberPi-x; return if neg then -ScaledSine x else ScaledSine x end; lisp procedure ScaledSine x; % assumes its argument is scaled to between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return x*(1+xsqrd*(-0.16666667+xsqrd*(0.0083333315+xsqrd*(-0.0001984090+ xsqrd*(0.0000027526-xsqrd*0.0000000239))))) end; lisp procedure cos x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. << if minusp x then x := - x; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of COS"; if x > NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then x := - x; if x > NumberPi!/2 then -ScaledCosine(NumberPi-x) else ScaledCosine x >>; lisp procedure ScaledCosine x; % Expects its argument to be between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return 1+xsqrd*(-0.5+xsqrd*(0.041666642+xsqrd*(-0.0013888397+ xsqrd*(0.0000247609-xsqrd*0.0000002605)))) end; lisp procedure tan x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of TAN"; if x > NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if minusp x then << neg := not neg; x := - x >>; if x < NumberPi!/4 then x := ScaledTangent x else x := ScaledCotangent(-(x-numberpi!/2)); return if neg then -x else x end; lisp procedure cot x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of COT"; if minusp x then << neg := not neg; x := - x >>; if x < NumberPi!/4 then x := ScaledCotangent x else x := ScaledTangent(-(x-numberpi!/2)); return if neg then -x else x end; lisp procedure ScaledTangent x; % Expects its argument to be between 0 and pi/4. begin scalar xsqrd; xsqrd := x*x; return x*(1.0+xsqrd*(0.3333314+xsqrd*(0.1333924+xsqrd*(0.05337406 + xsqrd*(0.024565089+xsqrd*(0.002900525+xsqrd*0.0095168091)))))) end; lisp procedure ScaledCotangent x; % Expects its argument to be between 0 and pi/4. begin scalar xsqrd; xsqrd := x*x; return (1.0-xsqrd*(0.33333334+xsqrd*(0.022222029+xsqrd*(0.0021177168 + xsqrd*(0.0002078504+xsqrd*0.0000262619)))))/x end; lisp procedure sec x; 1.0/cos x; lisp procedure csc x; 1.0/sin x; lisp procedure sinD x; sin DegreesToRadians x; lisp procedure cosD x; cos DegreesToRadians x; lisp procedure tanD x; tan DegreesToRadians x; lisp procedure cotD x; cot DegreesToRadians x; lisp procedure secD x; sec DegreesToRadians x; lisp procedure cscD x; csc DegreesToRadians x; lisp procedure asin x; begin scalar neg; if minusp x then << neg := T; x := -x >>; if x > 1.0 then stderror list("Argument to ASIN too large:",x); return if neg then CheckedArcCosine x - NumberPi!/2 else NumberPi!/2 - CheckedArcCosine x end; lisp procedure acos x; begin scalar neg; if minusp x then << neg := T; x := -x >>; if x > 1.0 then stderror list("Argument to ACOS too large:",x); return if neg then NumberPi - CheckedArcCosine x else CheckedArcCosine x end; lisp procedure CheckedArcCosine x; % Return cosine of a "checked number", assumes its argument is in the range % 0 <= x <= 1. sqrt(1.0-x)*(1.5707963+x*(-0.2145988+x*(0.088978987+x*(-0.050174305+ x*(0.030891881+x*(-0.017088126+x*(0.0066700901-x*(0.0012624911)))))))); lisp procedure atan x; if minusp x then if x < -1.0 then Number!-Pi!/2 + CheckedArcTangent(-1.0/x) else -CheckedArcTangent(-x) else if x > 1.0 then NumberPi!/2 - CheckedArcTangent(1.0/x) else CheckedArcTangent x; lisp procedure acot x; if minusp x then if x < -1.0 then -CheckedArcTangent(-1.0/x) else Number!-Pi!/2 + CheckedArcTangent(-x) else if x > 1.0 then CheckedArcTangent(1.0/x) else NumberPi!/2 - CheckedArcTangent x; lisp procedure CheckedArcTangent x; begin scalar xsqrd; xsqrd := x*x; return x*(1+xsqrd*(-0.33333145+xsqrd*(0.19993551+xsqrd*(-0.14208899+ xsqrd*(0.10656264+xsqrd*(-0.07528964+xsqrd*(0.042909614+ xsqrd*(-0.016165737+xsqrd*0.0028662257)))))))) end; lisp procedure asec x; acos(1.0/x); lisp procedure acsc x; asin(1.0/x); lisp procedure asinD x; RadiansToDegrees asin x; lisp procedure acosD x; RadiansToDegrees acos x; lisp procedure atanD x; RadiansToDegrees atan x; lisp procedure acotD x; RadiansToDegrees acot x; lisp procedure asecD x; RadiansToDegrees asec x; lisp procedure acscD x; RadiansToDegrees acsc x; %****************** Roots and such ******************************************* lisp procedure sqrt N; % Simple Newton-Raphson floating point square root calculator. % Not waranted against truncation errors, etc. begin integer answer,scale; N:=FLOAT N; if N < 0.0 then stderror list("SQRT given negative argument:",N); if zerop N then return N; % Scale argument to within 1e-10 to 1e+10; scale := 0; while N > 1.0E10 do << scale := scale + 1; N := N * 1.0E-10 >>; while N < 1.0E-10 do << scale := scale - 1; N := N * 1.0E10 >>; answer := if N>2.0 then (N+1)/2 else if N<0.5 then 2/(N+1) else N; % Here's the heart of the algorithm. while abs(answer**2/N - 1.0) > SqrtTolerance do answer := 0.5*(answer+N/answer); return answer * 10.0**(5*scale) end; %******************** Logs and Exponentials ********************************** lisp procedure exp x; % Returns the exponential (ie, e**x) of its floatnum argument as % a flonum. The argument is scaled to % the interval -ln 2 to 0, and a Taylor series expansion % used (formula 4.2.45 on page 71 of Abramowitz and Stegun, % "Handbook of Mathematical Functions"). begin scalar N; N := ceiling(x / NaturalLog2); x := N * NaturalLog2 - x; return 2.0**N * (1.0+x*(-0.9999999995+x*(0.4999999206+x*(-0.1666653019+ x*(0.0416573475+x*(-0.0083013598+x*(0.0013298820+ x*(-0.0001413161)))))))) end; lisp procedure log x; % See Abramowitz and Stegun, page 69. if x <= 0.0 then stderror list("LOG given non-positive argument:",x) else if x < 1.0 then -log(1.0/x) else % Find natural log of x > 1; begin scalar nextx, ipart; % ipart is the "integer part" of the % logarithm. ipart := 0; % Keep multiplying by 1/e until x is small enough, may want to be more % "efficient" if we ever use really big numbers. while (nextx := NumberInverseE * x) > 1.0 do << x := nextx; ipart := ipart + 1; >>; return ipart + if x < 2.0 then CheckedLogarithm x else 2.0 * CheckedLogarithm(sqrt(x)); end; lisp procedure CheckedLogarithm x; % Should have 1 <= x <= 2. (i.e. x = 1+y 0 <= y <= 1) << x := x-1.0; x*(0.99999642+x*(-0.49987412+x*(0.33179903+x*(-0.24073381+x*(0.16765407+ x*(-0.09532939+x*(0.036088494-x*0.0064535442))))))) >>; lisp procedure log2 x; log x / NaturalLog2; lisp procedure log10 x; log x / NaturalLog10; %********************* Random Number Generator ******************************* % The declarations below constitute a linear, congruential % random number generator (see Knuth, "The Art of Computer % Programming: Volume 2: Seminumerical Algorithms", pp9-24). % With the given constants it has a period of 392931 and % potency 6. To have deterministic behaviour, set % RANDOMSEED. % % Constants are: 6 2 % modulus: 392931 = 3 * 7 * 11 % multiplier: 232 = 3 * 7 * 11 + 1 % increment: 65537 is prime % % Would benefit from being recoded in SysLisp, when full word integers should % be used with "automatic" modular arithmetic (see Knuth). Perhaps we should % have a longer period version? % By E. Benson, W. Galway and M. Griss fluid '(RandomSeed RandomModulus); RandomModulus := 392931; RandomSeed := remainder(time(),RandomModulus); lisp procedure next!-random!-number; % Returns a pseudo-random number between 0 and RandomModulus-1 (inclusive). RandomSeed := remainder(232*RandomSeed + 65537, RandomModulus); lisp procedure Random(N); % Return a pseudo-random number uniformly selected from the range 0..N-1. % NOTE that this used to be called RandomMod(N). Needs to be made more % compatible with Common LISP's random? fix( (float(N) * next!-random!-number()) / RandomModulus); procedure FACTORIAL N; % Simple factorial Begin scalar M; M:=1; for i:=1:N do M:=M*I; Return M; end; % Some functions from ALPHA_1 users lisp procedure Atan2D( Y, X ); RadiansToDegrees Atan2( Y, X ); lisp procedure Atan2( Y, X ); << X := float X; Y := Float Y; if X = 0.0 then % Y axis. if Y >= 0.0 then NumberPI!/2 else NumberPi + NumberPI!/2 else if X >= 0.0 and Y >= 0.0 then % First quadrant. Atan( Y / X ) else if X < 0.0 and Y >= 0.0 then % Second quadrant. NumberPI - Atan( Y / -X ) else if X < 0.0 and Y < 0.0 then % Third quadrant. NumberPI + Atan( Y / X ) else % Fourth quadrant. Number2Pi - Atan( -Y / X ) >>; lisp procedure TransferSign( S, Val ); % Transfers the sign of S to Val by returning abs(Val) if S >= 0, % otherwise -abs(Val). if S >= 0 then abs(Val) else -abs(Val); lisp procedure DMStoDegrees(Degs,Mins,Sex); % Converts degrees, minutes, seconds to degrees % Degs+Mins/60.0+Sex/3600.0 Degs+Mins*0.016666667+Sex*0.00027777778; lisp procedure DegreesToDMS x; % Converts degrees to a list of degrees, minutes, and seconds (all integers, % rounded, not truncated). begin scalar Degs,Mins; Degs := fix x; x := 60*(x-Degs); Mins := fix x; return list(Degs,Mins, round(60*(x-Mins))) end; end; |
Added psl-1983/3-1/util/mini-support-patch.red version [65b08a1674].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | GLOBAL '(SCNVAL); LISP PROCEDURE !%SCAN; <<SCNVAL := CHANNELREADTOKEN IN!*; TOKTYPE!*>>; PROCEDURE UNREADCH U; UNREADCHAR (ID2INT (U)); END; |
Added psl-1983/3-1/util/mini-support.fix version [f3b7b33f62].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | FLUID '(PromptString!* !*Break); % Error-print is called when the major loop returns a NIL. SYMBOLIC PROCEDURE ERROR!-PRINT; <<PRIN2 "ERROR in grammar, current token is "; PRIN2 !#TOK!#; PRIN2 " and stack is "; PRIN2 !#STACK!#; TERPRI() >>; % The following errs out if its argument is NIL SYMBOLIC PROCEDURE FAIL!-NOT U; IF U then T else begin scalar Promptstring!*; PRIN2T "FAIL-NOT called in a concatenation"; ERROR!-PRINT(); PromptString!*:="Mini-Error>"; U:=ContinuableERROR(997,"Failure scanning a concatenation",'(QUOTE T)); IF U AND SCAN!-TERM() THEN RETURN T; return begin scalar !*Break; return Error(997, "Could not Recover from FAIL-NOT"); end; end; % Invoke starts execution of a previously defined grammar. SYMBOLIC PROCEDURE INVOKE U; BEGIN SCALAR X,PromptString!*; PromptString!*:=Concat(Id2String U,">"); !#IDTYPE!# := 0; !#NUMTYPE!# := 2; !#STRTYPE!# := 1; FLAG (GET (U, 'KEYS), 'KEY); DIPBLD (GET (U, 'DIPS)); !#RTNOW!# := GET (U, 'RTS); !#GTNOW!# := GET (U, 'GTS); !#DIP!# := !#KEY!# := !#RT!# := !#GT!# := !#GENLABLIST!# := NIL; L: !#STACK!# := NIL; NEXT!-TOK(); X := APPLY (U, NIL); IF NULL X THEN << ERROR!-PRINT(); IF SCAN!-TERM() THEN <<PRIN2 ("Resuming scan"); TERPRI(); GOTO L>> >>; REMFLAG (GET (U, 'KEYS), 'KEY) END; |
Added psl-1983/3-1/util/mini-support.red version [0a7859a076].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % % % MINI % % (A SMALL META SYSTEM) % % % % % % Copyright (c) Robert R. Kessler 1979 % % Mods: MLG, Feb 1981 % % % This file is the support routines. % % The file MINI.MIN contains the MINI % % system self definition and MINI.SL % % is the Standard LISP translation % % of MINI.MIN. % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% GLOBAL '(!#KEY!# !#DIP!# !*MDEFN !#STACK!# !#STACK!-ELE!# !#TOK!# !#TOKTYPE!# !#NTOK!# !#LABLIST!# SINGLEOP!* FAILURE!* INDEXLIST!* !#RT!# !#GT!# !#RTNOW!# !#GTNOW!# !#IDTYPE!# !#NUMTYPE!# !#STRTYPE!# !#GENLABLIST!#); % Global description: % !#DIP!# - List of diphthongs for grammar being defined. % FAILURE!* - Value of failed match in pattern matcher. % !#GENLABLIST!# - List of generated labels used in push/pop lab. % !#GT!# - List of grammar terminators for invoked grammar. % !#GTNOW!# - List of grammar terminators for grammar being def. % !#IDTYPE!# - The value of toktype for id's (0) % INDEXLIST!* - List of number value pairs for pattern matcher. % !#KEY!# - List of key workds for grammar being defined. % !#LABLIST!# - The list of gensymed labels ($n). % !*MDEFN - Flag to MPRINT (ON) or EVAL (OFF) defined rule. % !#NUMTYPE!# - The value of toktype for numbers (2) % !#NTOK!# - Next token, used for diphthong checking. % !#RT!# - List of rule terminators for invoked grammar. % !#RTNOW!# - List of rule terminators for grammar being defined. % SINGLEOP!* - The operator for any match pattern (&). % !#STACK!# - The stack list: push +, pop #n , ref ##n % !#STACK!-ELE!# - Used to pass info between stack operations % !#SPECTYPE!# - The value of toktype for specials (3) % !#STRTYPE!# - The value of toktype for strings (1) % !#TOK!# - The current token % !#TOKTYPE!# - The type of the token from rSYMBOLIC Parser % (0-id, 1-str, 2-num, 3-special) % A grammar is defined by calling the function MINI with argument of % the name of the goal rule. i.e. MINI 'RUL redefines MINI itself. % Then to invoke a grammar, you use INVOKE goal rule name.(INVOKE 'RUL). SYMBOLIC PROCEDURE MINI U; << INVOKE 'RUL; RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE KEYS), LIST('QUOTE, !#KEY!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE DIPS), LIST('QUOTE, !#DIP!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE RTS), LIST('QUOTE, !#RT!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE GTS), LIST('QUOTE, !#GT!#)); NIL >>; % Invoke starts execution of a previously defined grammar. SYMBOLIC PROCEDURE INVOKE U; BEGIN SCALAR X; !#IDTYPE!# := 0; !#NUMTYPE!# := 2; !#STRTYPE!# := 1; FLAG (GET (U, 'KEYS), 'KEY); DIPBLD (GET (U, 'DIPS)); !#RTNOW!# := GET (U, 'RTS); !#GTNOW!# := GET (U, 'GTS); !#DIP!# := !#KEY!# := !#RT!# := !#GT!# := !#GENLABLIST!# := NIL; L: !#STACK!# := NIL; NEXT!-TOK(); X := APPLY (U, NIL); IF NULL X THEN << ERROR!-PRINT(); IF SCAN!-TERM() THEN <<PRIN2 ("Resuming scan"); TERPRI(); GOTO L>> >>; REMFLAG (GET (U, 'KEYS), 'KEY) END; % The following errs out if its argument is NIL SYMBOLIC PROCEDURE FAIL!-NOT U; U OR <<ERROR!-PRINT(); ERROR(997,"Failure scanning a concatenation.")>>; % This procedure is called when a rule is defined. If ON MDEFN then the % value is MPRINTed, otherwise, it is evaled. SYMBOLIC PROCEDURE RULE!-DEFINE U; << IF !*MDEFN THEN MPRINT U ELSE EVAL U>>; % Mprint is used so it may be redefined if something other than PRINT % is desired when ON MDEFN is used. SYMBOLIC PROCEDURE MPRINT U; << TERPRI(); PRINT U>>; % Error-print is called when the major loop returns a NIL. SYMBOLIC PROCEDURE ERROR!-PRINT; <<PRIN2 "ERROR in grammar, current token is "; PRIN2 !#TOK!#; PRIN2 " and stack is "; PRIN2 !#STACK!#; TERPRI() >>; % Scan for a rule terminator or grammar terminator by fetching tokens. % Returns T if a rule terminator is found and NIL for a grammar term. % The rule terminator causes processing to continue after the terminator. % The grammar terminator ceases processing. SYMBOLIC PROCEDURE SCAN!-TERM; BEGIN SCALAR X; PRIN2 ("Scanning for rule terminator: "); PRIN2 !#RTNOW!#; PRIN2 (" or grammar terminator: "); PRIN2 !#GTNOW!#; TERPRI(); L: X := NEXT!-TOK(); IF MEMQ (X, !#GTNOW!#) THEN RETURN NIL ELSE IF MEMQ (X, !#RTNOW!#) THEN RETURN T ELSE GOTO L END; % Add the argument to the current key list, if not already there. SYMBOLIC PROCEDURE ADDKEY U; <<IF NOT MEMQ (U, !#KEY!#) THEN !#KEY!# := U . !#KEY!#; T>>; % Add the argument to the current grammar terminator list. SYMBOLIC PROCEDURE ADDGTERM U; <<IF NOT MEMQ (U, !#GT!#) THEN !#GT!# := U . !#GT!#; T>>; % Add the argument to the current rule terminator list. SYMBOLIC PROCEDURE ADDRTERM U; <<IF NOT MEMQ (U, !#RT!#) THEN !#RT!# := U . !#RT!#; T>>; % This procedure will take a list of identifiers and flag them as % diphthongs (2 character max). SYMBOLIC PROCEDURE DIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << IF NOT MEMQ (X, !#DIP!#) THEN !#DIP!# := X . !#DIP!#; Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; W := GET (CAR Y, 'FOLLOW); % Property follow is list of legal dip terms; PUT (CAR Y, 'FOLLOW, (LIST (CADR Y, X)) . W) >>; RETURN T END; SYMBOLIC PROCEDURE UNDIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; REMPROP(CAR Y, 'FOLLOW) >>; RETURN T END; % Following procedure will eliminate the escapes in a list SYMBOLIC PROCEDURE STRIP!! U; IF PAIRP U THEN IF CAR U EQ '!! THEN CADR U . STRIP!! CDDR U ELSE CAR U . STRIP!! CDR U ELSE NIL; % Push something onto the stack; SYMBOLIC PROCEDURE PUSH U; !#STACK!# := U . !#STACK!#; % Reference a stack element SYMBOLIC PROCEDURE REF U; SCAN!-STACK (U, !#STACK!#); % Stack underflow is called then that error happens. Right now, it errors % out. Future enhancement is to make it more friendly to the user. SYMBOLIC PROCEDURE STACK!-UNDERFLOW; ERROR (4000, "Stack underflow"); % Like above, a stack error has occured, so quit the game. SYMBOLIC PROCEDURE STACK!-ERROR; ERROR (4001, "Error in stack access"); % Search stack for the element U elements from the top (1 is top). SYMBOLIC PROCEDURE SCAN!-STACK (U, STK); IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U = 1 THEN CAR STK ELSE SCAN!-STACK (U-1, CDR STK); % Remove the Uth element from the stack (1 is the top). SYMBOLIC PROCEDURE EXTRACT U; << !#STACK!# := FETCH!-STACK (U, !#STACK!#); !#STACK!-ELE!# >>; % Return the value found; % Recursive routine to remove the Uth element from the stack. SYMBOLIC PROCEDURE FETCH!-STACK (U, STK); BEGIN SCALAR X; IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U EQ 1 THEN <<!#STACK!-ELE!# := CAR STK; RETURN CDR STK>> ELSE RETURN CAR STK . FETCH!-STACK (U-1, CDR STK) END; % Retrieve the length of the stack. This is used to build a single % list used in repetition. It takes the top of the stack down to % the stack length at the beginning to build the list. Therefore, % STK!-LENGTH must be called prior to calling BUILD!-REPEAT, which % must be passed the value returned by the call to STK!-LENGTH. SYMBOLIC PROCEDURE STK!-LENGTH; LENGTH !#STACK!#; % The procedure to handle repetition by building a list out of the % top n values on the stack. SYMBOLIC PROCEDURE BUILD!-REPEAT U; BEGIN SCALAR V; V := STK!-LENGTH(); IF U > V THEN STACK!-ERROR() ELSE IF U = V THEN PUSH NIL ELSE IF U < V THEN BEGIN SCALAR L, I; % Build it for the top V-U elements L := NIL; FOR I := 1:(V-U) DO L := (EXTRACT 1) . L; PUSH L END; RETURN T END; % Actually get the next token, if !#NTOK!# has a value then use that, % else call your favorite token routine. % This routine must return an identifier, string or number. % If U is T then don't break up a quoted list right now. SYMBOLIC PROCEDURE GET!-TOK U; BEGIN SCALAR X; IF !#NTOK!# THEN << X := !#NTOK!#; !#NTOK!# := NIL; RETURN X >> ELSE << X := !%SCAN(); % Scan sets the following codes: % 0 - ID, and thus was escapeed % 1 - STRING % 2 - Integer % 3 - Special (;, (, ), etc.) % Therefore, it is important to distinguish between % the special and ID for key words. IF (X EQ 2) OR (X EQ 1) THEN RETURN (X . SCNVAL) ELSE RETURN (0 . INTERN SCNVAL) >> %//Ignore ESCAPE for now END; % Fetch the next token, if a diphthong, turn into an identifier SYMBOLIC PROCEDURE NEXT!-TOK; BEGIN SCALAR X,Y; !#TOK!# := GET!-TOK(NIL); !#TOKTYPE!# := CAR !#TOK!#; !#TOK!# := CDR !#TOK!#; IF (Y:=GET(!#TOK!#, 'FOLLOW)) THEN << !#NTOK!# := 0 . READCH(); % Use READCH since white space IF X := ATSOC(CDR !#NTOK!#, Y) THEN % within diphthong is illegal << !#TOK!# := CADR X; !#TOKTYPE!# := !#IDTYPE!# >> ELSE UNREADCH CDR !#NTOK!#; % Push the character back for the !#NTOK!# := NIL >>; % scanner if not part of diphthong RETURN !#TOK!# END; SYMBOLIC PROCEDURE T!-NTOK; <<NEXT!-TOK(); 'T>>; SYMBOLIC PROCEDURE EQTOK(X); % Test Token Value EQUAL(!#TOK!#,X); % maybe use EQ? SYMBOLIC PROCEDURE EQTOK!-NEXT(X); EQTOK(X) AND T!-NTOK(); % See if current token is an identifier and not a keyword. If it is, % then push onto the stack and fetch the next token. SYMBOLIC PROCEDURE ID; IF !#TOKTYPE!# EQ !#IDTYPE!# AND NOT FLAGP(!#TOK!#,'KEY) THEN <<PUSH !#TOK!#; IF NOT (MEMQ (!#TOK!#, !#GTNOW!#) OR MEMQ(!#TOK!#, !#RTNOW!#)) THEN NEXT!-TOK(); T>> ELSE NIL; % See if current token is an id whether or not it is a keyword. SYMBOLIC PROCEDURE ANYID; IF (!#TOKTYPE!# EQ !#IDTYPE!#) THEN % (!#TOKTYPE!# EQ !#SPECTYPE!#) OR FLAGP(!#TOK!#, 'KEY) THEN ANYTOK() ELSE NIL; % Always succeeds by pushing the current token onto the stack. SYMBOLIC PROCEDURE ANYTOK; <<PUSH !#TOK!#; NEXT!-TOK(); T>>; % Tests to see if the current token is a number, if so it pushes the % number onto the stack and fetches the next token. SYMBOLIC PROCEDURE NUM; IF (!#TOKTYPE!# EQ !#NUMTYPE!#) THEN ANYTOK() ELSE NIL; % Same as NUM, except for strings. SYMBOLIC PROCEDURE STR; IF (!#TOKTYPE!# EQ !#STRTYPE!#) THEN ANYTOK() ELSE NIL; % Generate a label. If the label has been previously generated, the % return the old value. (used by $n). SYMBOLIC PROCEDURE GENLAB U; BEGIN SCALAR X; IF X:=ASSOC(U, !#LABLIST!#) THEN RETURN CADR X; X:=INTERN GENSYM(); !#LABLIST!# := LIST(U, X) . !#LABLIST!#; RETURN X END; % Push the current label lists so we don't get any conflicts. LISP PROCEDURE PUSH!-LAB; << !#GENLABLIST!# := !#LABLIST!# . !#GENLABLIST!#; !#LABLIST!# := NIL; T>>; % Pop label lists. LISP PROCEDURE POP!-LAB; <<!#LABLIST!# := CAR !#GENLABLIST!#; !#GENLABLIST!# := CDR !#GENLABLIST!#; T>>; GLOBAL '(!*DO!#); ON DO!#; FLUID '(NEWENV!*); % RBMATCH will accept a list of rules and subject list and % search for a match on one of the rules. Upon finding the % match, the body will be executed. SYMBOLIC PROCEDURE RBMATCH (SUBLIST, RULESLIST, INITENV); BEGIN SCALAR TEMP, ENVLIST, RULFOUND, RVAL, TRYAGAIN, SN; % IF NUMARGS() EQ 4 THEN TRYAGAIN := T ELSE TRYAGAIN := NIL; % IF NUMARGS() > 2 THEN INITENV := ARGUMENT(3) ELSE INITENV:=NIL; RVAL := FAILURE!*; WHILE RULESLIST DO << RULFOUND := CAR RULESLIST; RULESLIST := CDR RULESLIST; ENVLIST := LIST (LIST (0, SUBLIST)); IF INITENV THEN ENVLIST := APPEND (ENVLIST, INITENV); IF (NEWENV!* := PEVAL (CAR RULFOUND, SUBLIST, ENVLIST)) NEQ FAILURE!* THEN IF (TEMP := EVAL (LIST (CDR RULFOUND, 'NEWENV!*, NIL, NIL, NIL))) NEQ FAILURE!* THEN IF TEMP EQ 'FAIL THEN <<RVAL := NIL; RETURN NIL>> ELSE IF TRYAGAIN THEN << PRIN2T ("Success, will try again"); RVAL := APPEND (TEMP, RVAL) >> ELSE <<RVAL := TEMP; RETURN TEMP >> >>; RETURN RVAL END RBMATCH; % % PEVAL accepts a subjectlist, a pattern and an environment. % It then determines if the subjectlist matches the pattern % with the particular environment. The pattern may contain % lists or variable expressions. The variable expressions are % of two form: & "ATOM" which will match a single list or % ATOM and & & "ATOM" which will test to see if the match is % equal to a previously matched item. %; SINGLEOP!* := '&; FAILURE!* := NIL; SYMBOLIC PROCEDURE PEVAL(P, S, ENV); IF P EQ S THEN LIST ENV ELSE IF EQCAR (S, '!#) AND !*DO!# THEN TST!#(P, S, ENV) ELSE IF ATOM P THEN NIL ELSE IF CAR P EQ SINGLEOP!* THEN TST!-SINGLE(P, S, ENV) ELSE IF ATOM S THEN NIL ELSE BEGIN SCALAR ENVL; ENVL := PEVAL (CAR P, CAR S, ENV); RETURN PEVALL (CDR P, CDR S, ENVL) END; SYMBOLIC PROCEDURE PEVALL (P, S, ENVL); IF NULL ENVL THEN NIL ELSE IF NULL CDR ENVL THEN PEVAL (P, S, CAR ENVL) ELSE APPEND (PEVAL(P, S, CAR ENVL), PEVALL(P, S, CDR ENVL)); SYMBOLIC PROCEDURE TST!-SINGLE (P, S, ENV); BEGIN SCALAR IDX; IF LENGTH (IDX := CDR P) NEQ 1 THEN << IF CAR IDX EQ SINGLEOP!* THEN (IF EQUAL (S, CADR ASSOC (CADR IDX, ENV)) THEN RETURN LIST (ENV)) ELSE IF MEMBER (S, CAR IDX) THEN RETURN LIST (LIST(CADR IDX, S) . ENV); RETURN FAILURE!* >>; RETURN LIST (LIST (CAR IDX, S) . ENV) END; SYMBOLIC PROCEDURE TST!# (P, S, ENV); BEGIN SCALAR OLST, N, ENVL, CLST, X; OLST := CADR S; N := CADDR S; ENVL := NIL; L: IF NULL OLST THEN RETURN ENVL; CLST := CAR OLST; X := PEVAL (P, CLST, ENV); OLST := CDR OLST; FOR EACH Y IN X DO ENVL := (LIST (N, CLST) . Y) . ENVL; GO TO L END; END; |
Added psl-1983/3-1/util/mini.build version [d95845b6fa].
> > > > > | 1 2 3 4 5 | in "mini-support-patch.red"$ in "mini-support.red"$ in "mini-support.fix"$ global '(PNAM); in "mini.sl"$ |
Added psl-1983/3-1/util/mini.demo version [876c3d55fc].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | % ----- A simple DEMO of MINI ------- % Use after IN "/utah/psl/mini.build" MINI 'ROOT; % starts the mini parser generator ROOT: STMT* / 'QUIT ; % Define ROOT STMT: ID '= EXP @; +(SETQ #2 #1) .(PRINT #1) .(NEXT!-TOK) ; % Define STMT EXP: TERM < '+ EXP +(PLUS #2 #1) / '- EXP +(DIFFERENCE #2 #1)>; TERM: NUM / ID / '( EXP ') ; FIN % To run it, use % INVOKE 'ROOT; END; |
Added psl-1983/3-1/util/mini.min version [a5d4e4ca14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % MINI - a small META system % % % % Copyright (c) Robert R. Kessler 1979 % % Mods: MLG, Feb 1981 % % % % This is the MINI system self definition. % % The file MINI-SUPPORT.RED contains the % % support routines and MINI.SL is the % % Standard LISP translation of this file. % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following is the definition of the mini meta system in terms of % itself. MINI is very similar to META/REDUCE, except a lot of it has % been eliminated. The following features that are in META/REDUCE, are % not present in MINI: % - Backup is not supported. % - Diphthongs of more than 2 characters are not supported. Also, in % MINI, the diphthongs must be declared before they are used. % - Format operations are not supported (the => op). % - The symbol table operations are not supported (however, they could % easily be added as calls to the routines. % - The - operator for stripping off a level of parens is not supported. % - The META/REDUCE error operators are not supported (*** *****). % The following is a list of the differences between MINI and META/REDUCE: % - The += operator has been changed to +. to be consistent with the % meanings of the + (PUSH) and . (EVAL) operators. % - The @ operator also includes the semantics that it's token is used % as a rule terminator (for error recovery). When a token is found % during error recovery that is a rule terminator, the grammar is % reset to its initial stage and scanning continues. % - A new operator @@ has been added that is the same as the @ operator % but it signifies a grammar terminator. During error recovery, if % a grammar terminator is scanned, parsing will stop. % - The flag MDEFN controls whether a rule defined is EVALED or MPRINTed. % - MINI uses the RLISP token reader and is therefore much faster. % One consequences of this is that comments may be embedded anywhere % in the text and are ignored by %SCAN % Also, since %SCAN is used, certain quoted keywords need to have a % escape in front of them. The ones discovered so far are: '!+ '!- % '!( and '!). This also means that diphthongs that use these as % the first character must also be quoted (i.e. '!+= or '!-.). % The safe approach is to quote every special character. % To define a grammar, call the procedure MINI with the argument being the % root rule name. Then when the grammar is defined it may be called by % using INVOKE root rule name. % The following is the MINI Meta self definition. GLOBAL '(PNAM); MINI 'RUL; % Define the diphthongs to be used in the grammar. DIP: !#!#, !-!>, !+!., !@!@ ; % The root rule is called RUL. RUL: ('DIP ': ANYTOK[,]* .(DIPBLD #1) '; / (ID .(SETQ !#LABLIST!# NIL) ( ': ALT +(DE #2 NIL #1) @; / '= PRUL[,]* @; .(RULE!-DEFINE '(PUT (QUOTE ##2) (QUOTE RB) (QUOTE #1))) +(DE ##1 (A) (RBMATCH A (GET (QUOTE #1) (QUOTE RB)) NIL))) .(RULE!-DEFINE #1) .(NEXT!-TOK) ))* @@FIN ; % An alternative is a sequence of statements separated by /'s; ALT: SEQ < '/ ALT +(OR #2 #1) >; % A sequence is a list of items that must be matched. SEQ: REP < SEQ +(AND #2 (FAIL!-NOT #1)) >; % A repetition may be 0 or more single items (*) or 0 or more items % separated by any token (ID[,]* will parse a list of ID's separated by ,'s. REP: ONE <'[ (ID +(#1) / '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / ANYKEY +(EQTOK!-NEXT (QUOTE #1))) '] +(AND #2 #1) '* BLD!-EXPR / '* BLD!-EXPR>; % Create an sexpression to build a repetition. BLD!-EXPR: +(PROG (X) (SETQ X (STK!-LENGTH)) $1 (COND (#1 (GO $1))) (BUILD!-REPEAT X) (RETURN T)); ANYKEY: ANYTOK .(ADDKEY ##1) ; % Add a new KEY % One defines a single item. ONE: '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / '@ ANYKEY .(ADDRTERM ##1) +(EQTOK (QUOTE #1)) / '@@ ANYKEY .(ADDGTERM ##1) +(EQTOK (QUOTE #1)) / '+ UNLBLD +(PUSH #1) / '. EVLBLD +(PROGN #1 T) / '= EVLBLD / '< ALT '> +(PROGN #1 T) / '( ALT ') / '+. EVLBLD +(PUSH #1) / ID +(#1) ; % This rule defines an un evaled list. It builds a list with everything % quoted. UNLBLD: '( UNLBLD ('. UNLBLD ') +(CONS #2 #1) / UNLBLD* ') +(LIST . (#2 . #1)) / ') +(LIST . #1)) / LBLD / ID +(QUOTE #1) ; % EVLBLD builds a list of evaled items. EVLBLD: '( EVLBLD ('. EVLBLD ') +(CONS #2 #1) / EVLBLD* ') +(#2 . #1) / ') ) / LBLD / ID ; LBLD: '# NUM +(EXTRACT #1) / '## NUM +(REF #1) / '$ NUM +(GENLAB #1) / '& NUM +(CADR (ASSOC #1 (CAR VARLIST))) / NUM / STR / '' ('( UNLBLD* ') +(LIST . #1) / ANYTOK +(QUOTE #1)); % Defines the pattern matching rules (PATTERN -> BODY). PRUL: .(SETQ INDEXLIST!* NIL) PAT '-> (EVLBLD)* +(LAMBDA (VARLIST T1 T2 T3) (AND . #1)) .(SETQ PNAM (GENSYM)) .(RULE!-DEFINE (LIST 'PUTD (LIST 'QUOTE PNAM) '(QUOTE EXPR) (LIST 'QUOTE #1))) +.(CONS #1 PNAM); % Defines a pattern. % We now allow the . operator to be the next to last in a (). PAT: '& ('< PSIMP[/]* '> NUM +.(PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #2 #1) ) / NUM +.(COND ((MEMQ ##1 INDEXLIST!*) (LIST '!& '!& #1)) (T (PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #1)))) ) / ID / '!( PAT* <'. PAT +.(APPEND #2 #1)> '!) / '' ANYTOK / STR / NUM ; % Defines the primitives in a pattern. PSIMP: ID / NUM / '( PSIMP* ') / '' ANYTOK; % The grammar terminator. FIN END; |
Added psl-1983/3-1/util/mini.sl version [15c3c91025].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NIL (DE RUL NIL (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0109 (COND ((OR (AND ( EQTOK!-NEXT (QUOTE DIP)) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !:)) (FAIL!-NOT ( AND (PROG (X) (SETQ X (STK!-LENGTH)) G0109 (COND ((AND (ANYTOK) (EQTOK!-NEXT ( QUOTE !,))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND ( PROGN (DIPBLD (EXTRACT 1)) T) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !;)))))))))) ( AND (ID) (FAIL!-NOT (AND (PROGN (SETQ !#LABLIST!# NIL) T) (FAIL!-NOT (AND ( OR (AND (EQTOK!-NEXT (QUOTE !:)) (FAIL!-NOT (AND (ALT) (FAIL!-NOT (AND (PUSH ( LIST (QUOTE DE) (EXTRACT 2) (QUOTE NIL) (EXTRACT 1))) (FAIL!-NOT (EQTOK ( QUOTE !;)))))))) (AND (EQTOK!-NEXT (QUOTE !=)) (FAIL!-NOT (AND (PROG (X) ( SETQ X (STK!-LENGTH)) G0109 (COND ((AND (PRUL) (EQTOK!-NEXT (QUOTE !,))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (EQTOK (QUOTE !;)) ( FAIL!-NOT (AND (PROGN (RULE!-DEFINE (LIST (QUOTE PUT) (LIST (QUOTE QUOTE) ( REF 2)) (LIST (QUOTE QUOTE) (QUOTE RB)) (LIST (QUOTE QUOTE) (EXTRACT 1)))) T) ( FAIL!-NOT (PUSH (LIST (QUOTE DE) (REF 1) (LIST (QUOTE A)) (LIST (QUOTE RBMATCH) (QUOTE A) (LIST (QUOTE GET) (LIST (QUOTE QUOTE) (EXTRACT 1)) (LIST ( QUOTE QUOTE) (QUOTE RB))) (QUOTE NIL))))))))))))) (FAIL!-NOT (AND (PROGN ( RULE!-DEFINE (EXTRACT 1)) T) (FAIL!-NOT (PROGN (NEXT!-TOK) T)))))))))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (EQTOK (QUOTE FIN))))) (DE ALT NIL (AND (SEQ) (FAIL!-NOT (PROGN (AND (EQTOK!-NEXT (QUOTE !/)) ( FAIL!-NOT (AND (ALT) (FAIL!-NOT (PUSH (LIST (QUOTE OR) (EXTRACT 2) (EXTRACT 1))))))) T)))) (DE SEQ NIL (AND (REP) (FAIL!-NOT (PROGN (AND (SEQ) (FAIL!-NOT (PUSH (LIST ( QUOTE AND) (EXTRACT 2) (LIST (QUOTE FAIL!-NOT) (EXTRACT 1)))))) T)))) (DE REP NIL (AND (ONE) (FAIL!-NOT (PROGN (OR (AND (EQTOK!-NEXT (QUOTE ![)) ( FAIL!-NOT (AND (OR (AND (ID) (FAIL!-NOT (PUSH (LIST (EXTRACT 1))))) (OR (AND ( EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (AND (ANYKEY) (FAIL!-NOT (PUSH (LIST ( QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (AND (ANYKEY) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !])) (FAIL!-NOT (AND (PUSH ( LIST (QUOTE AND) (EXTRACT 2) (EXTRACT 1))) (FAIL!-NOT (AND (EQTOK!-NEXT ( QUOTE !*)) (FAIL!-NOT (BLD!-EXPR))))))))))) (AND (EQTOK!-NEXT (QUOTE !*)) ( FAIL!-NOT (BLD!-EXPR)))) T)))) (DE BLD!-EXPR NIL (PUSH (LIST (QUOTE PROG) (LIST (QUOTE X)) (LIST (QUOTE SETQ) (QUOTE X) (LIST (QUOTE STK!-LENGTH))) (GENLAB 1) (LIST (QUOTE COND) ( LIST (EXTRACT 1) (LIST (QUOTE GO) (GENLAB 1)))) (LIST (QUOTE BUILD!-REPEAT) ( QUOTE X)) (LIST (QUOTE RETURN) (QUOTE T))))) (DE ANYKEY NIL (AND (ANYTOK) (FAIL!-NOT (PROGN (ADDKEY (REF 1)) T)))) (DE ONE NIL (OR (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (AND (ANYKEY) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (OR (AND (EQTOK!-NEXT (QUOTE !@)) (FAIL!-NOT (AND (ANYKEY) ( FAIL!-NOT (AND (PROGN (ADDRTERM (REF 1)) T) (FAIL!-NOT (PUSH (LIST (QUOTE EQTOK) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))))) (OR (AND (EQTOK!-NEXT (QUOTE !@!@)) (FAIL!-NOT (AND (ANYKEY) (FAIL!-NOT (AND (PROGN (ADDGTERM (REF 1)) T) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))))) ( OR (AND (EQTOK!-NEXT (QUOTE !+)) (FAIL!-NOT (AND (UNLBLD) (FAIL!-NOT (PUSH ( LIST (QUOTE PUSH) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT (QUOTE !.)) ( FAIL!-NOT (AND (EVLBLD) (FAIL!-NOT (PUSH (LIST (QUOTE PROGN) (EXTRACT 1) ( QUOTE T))))))) (OR (AND (EQTOK!-NEXT (QUOTE !=)) (FAIL!-NOT (EVLBLD))) (OR ( AND (EQTOK!-NEXT (QUOTE !<)) (FAIL!-NOT (AND (ALT) (FAIL!-NOT (AND ( EQTOK!-NEXT (QUOTE !>)) (FAIL!-NOT (PUSH (LIST (QUOTE PROGN) (EXTRACT 1) ( QUOTE T))))))))) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (ALT) ( FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))) (OR (AND (EQTOK!-NEXT (QUOTE !+!.)) ( FAIL!-NOT (AND (EVLBLD) (FAIL!-NOT (PUSH (LIST (QUOTE PUSH) (EXTRACT 1))))))) ( AND (ID) (FAIL!-NOT (PUSH (LIST (EXTRACT 1))))))))))))))) (DE UNLBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (UNLBLD) ( FAIL!-NOT (OR (AND (EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (UNLBLD) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (LIST (QUOTE CONS) ( EXTRACT 2) (EXTRACT 1))))))))) (OR (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0110 (COND ((UNLBLD) (GO G0110))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT ( AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (QUOTE LIST) (CONS ( EXTRACT 2) (EXTRACT 1)))))))) (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH ( CONS (QUOTE LIST) (EXTRACT 1))))))))))) (OR (LBLD) (AND (ID) (FAIL!-NOT ( PUSH (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (DE EVLBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (EVLBLD) ( FAIL!-NOT (OR (AND (EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (EVLBLD) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (LIST (QUOTE CONS) ( EXTRACT 2) (EXTRACT 1))))))))) (OR (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0111 (COND ((EVLBLD) (GO G0111))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT ( AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (EXTRACT 2) (EXTRACT 1))))))) (EQTOK!-NEXT (QUOTE !))))))))) (OR (LBLD) (ID)))) (DE LBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !#)) (FAIL!-NOT (AND (NUM) ( FAIL!-NOT (PUSH (LIST (QUOTE EXTRACT) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT ( QUOTE !#!#)) (FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (LIST (QUOTE REF) ( EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT (QUOTE !$)) (FAIL!-NOT (AND (NUM) ( FAIL!-NOT (PUSH (LIST (QUOTE GENLAB) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT ( QUOTE !&)) (FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (LIST (QUOTE CADR) (LIST ( QUOTE ASSOC) (EXTRACT 1) (LIST (QUOTE CAR) (QUOTE VARLIST))))))))) (OR (NUM) ( OR (STR) (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (OR (AND (EQTOK!-NEXT ( QUOTE !()) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0112 (COND (( UNLBLD) (GO G0112))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND ( EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (QUOTE LIST) (EXTRACT 1))))))))) (AND (ANYTOK) (FAIL!-NOT (PUSH (LIST (QUOTE QUOTE) (EXTRACT 1))))))))))))))) (DE PRUL NIL (AND (PROGN (SETQ INDEXLIST!* NIL) T) (FAIL!-NOT (AND (PAT) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !-!>)) (FAIL!-NOT (AND (PROG (X) (SETQ X ( STK!-LENGTH)) G0113 (COND ((EVLBLD) (GO G0113))) (BUILD!-REPEAT X) (RETURN T)) ( FAIL!-NOT (AND (PUSH (LIST (QUOTE LAMBDA) (LIST (QUOTE VARLIST) (QUOTE T1) ( QUOTE T2) (QUOTE T3)) (CONS (QUOTE AND) (EXTRACT 1)))) (FAIL!-NOT (AND ( PROGN (SETQ PNAM (GENSYM)) T) (FAIL!-NOT (AND (PROGN (RULE!-DEFINE (LIST ( QUOTE PUTD) (LIST (QUOTE QUOTE) PNAM) (LIST (QUOTE QUOTE) (QUOTE EXPR)) ( LIST (QUOTE QUOTE) (EXTRACT 1)))) T) (FAIL!-NOT (PUSH (CONS (EXTRACT 1) PNAM)))) ))))))))))))) (DE PAT NIL (OR (AND (EQTOK!-NEXT (QUOTE !&)) (FAIL!-NOT (OR (AND ( EQTOK!-NEXT (QUOTE !<)) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0114 (COND ((AND (PSIMP) (EQTOK!-NEXT (QUOTE !/))) (GO G0114))) ( BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !>)) ( FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (PROGN (SETQ INDEXLIST!* (CONS (REF 1) INDEXLIST!*)) (LIST (QUOTE !&) (EXTRACT 2) (EXTRACT 1)))))))))))) (AND ( NUM) (FAIL!-NOT (PUSH (COND ((MEMQ (REF 1) INDEXLIST!*) (LIST (QUOTE !&) ( QUOTE !&) (EXTRACT 1))) (T (PROGN (SETQ INDEXLIST!* (CONS (REF 1) INDEXLIST!*)) (LIST (QUOTE !&) (EXTRACT 1))))))))))) (OR (ID) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0114 (COND ((PAT) (GO G0114))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (PROGN (AND ( EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (PAT) (FAIL!-NOT (PUSH (APPEND ( EXTRACT 2) (EXTRACT 1))))))) T) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))))) ( OR (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (ANYTOK))) (OR (STR) (NUM))))))) (DE PSIMP NIL (OR (ID) (OR (NUM) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT ( AND (PROG (X) (SETQ X (STK!-LENGTH)) G0115 (COND ((PSIMP) (GO G0115))) ( BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))) (AND ( EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (ANYTOK))))))) (PUT (QUOTE RUL) (QUOTE KEYS) (QUOTE (!-!> !& !$ !#!# !# !+!. !) !( !> !< !. !+ !@!@ !@ !* !] !' ![ !/ FIN != !; !, !: DIP))) (PUT (QUOTE RUL) (QUOTE DIPS) (QUOTE (!@!@ !+!. !-!> !#!#))) (PUT (QUOTE RUL) (QUOTE RTS) (QUOTE (!;))) (PUT (QUOTE RUL) (QUOTE GTS) (QUOTE (FIN))) NIL NIL |
Added psl-1983/3-1/util/misc-macros.sl version [d4cc40e130].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MISC-MACROS.SL - assorted useful macros % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (defmacro funcall u `(apply ,(car u) (list ,@(cdr u)))) (copyd 'call 'funcall) (defmacro eqfirst (u v) `(eqcar ,u ,v)) (defmacro bldid (s . args) `(intern (bldmsg ,s ,@args))) (defmacro nary-concat u (expand u 'concat)) (defmacro-no-displace defstub (name . rst) % quick, kludgy hack -- should be much better (let ((args (if (pairp rst) (pop rst)))) `(de ,name ,args (stub-print ',name ',args (list ,@args)) ,@rst (let ((*ContinuableError t)) (break))))) (de stub-print (name arg-names actual-args) (errorprintf "Stub %w called with arguments:" name) (for (in u arg-names) (in v actual-args) (do (errorprintf " %w: %p%n" u v))) (terpri)) (defmacro circular-list L `(let ((***CIRCULAR-LIST-ARG*** (list ,@L))) (nconc ***CIRCULAR-LIST-ARG*** ***CIRCULAR-LIST-ARG***))) (defmacro nothing U nil) % Nary no-op returning nil; args not evaluated. (defmacro make-list (N . rst) `(make-list-1 ,N ,(if (pairp rst) (car rst) nil))) (de make-list-1 (N init) (for (from i 1 N) (collect init))) |
Added psl-1983/3-1/util/narith.build version [cebe4aae5a].
> > > > | 1 2 3 4 | % NARITH.BUILD - Changes built-in arith to include BIGNUM hooks %/ Should later install as basic BIGNUM package in "narith.red"$ |
Added psl-1983/3-1/util/narith.red version [9028a22a9d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Generic arithmetic routines for PSL % New model, much less hairy lap % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 August 1982 % Copyright (c) 1982 University of Utah %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Note: Loading BIGFACE is supposed to define (or redefine) % the functions: % ISINUM % StaticIntBig % StaticBigFloat % Sys2Int % Int2Sys % FloatFix % % Mods by MLG, 21 dec 1982 % Take off INTERNALFUNCTION form FLOATFIX and StaticFloatBig % Change IsInum to be a procedure % Change names of FAKE and SFL to xxxxLOC CompileTime << % Some aliases Fluid '(ArithArgLoc StaticFloatLoc); put('ArithArg, 'NewNam, '(LispVar ArithArgLoc)); put('StaticFloat, 'NewNam, '(LispVar StaticFloatLoc)); >>; LoadTime << % Allocate Physical Space ArithArgLoc := GtWArray 2; StaticFloatLoc := GtWArray 3; >>; on Syslisp; %internal WArray ArithArg[1], StaticFloat = [1, 0, 0]; CompileTime << flag('(Coerce2 FloatPlus2 FloatDifference FloatTimes2 FloatQuotient FloatGreaterP FloatLessP IntFloat NonInteger2Error NonNumber1Error ), 'InternalFunction); syslsp macro procedure IsInumMac U; << U := second U; if atom U then list('eq, list('SignedField, U, '(ISub1 (WConst InfStartingBit)), '(IAdd1 (WConst InfBitLength))), U) else list('(lambda (X) (eq (SignedField X (ISub1 (WConst InfStartingBit)) (IAdd1 (WConst InfBitLength))) X)), U) >>; expr procedure NameGen Name; Intern Concat(ID2String Name, StringGensym()); macro procedure DefArith2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y); expr procedure GEN0(x, y, z); if isinum z then z else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArithPred2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then WGEN(x, y) else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefInt2Entry U; begin scalar generic, wgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN BGEN HARDGEN GEN0), list(generic, wgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y); expr procedure GEN0(x, y, z); if isinum z then z else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: NonInteger2Error(x, y, 'GENERIC); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArith1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC x; if intp x then GEN0(x, WGEN x) else HARDGEN x; expr procedure GEN0(x, z); if isinum z then z else HARDGEN x; expr procedure HARDGEN x; case Tag x of NEGINT, POSINT: Sys2Int WGEN x; FIXN: Sys2Int WGEN FixVal FixInf x; FLTN: FGEN x; BIGN: BGEN x; default: NonNumber1Error(x, 'GENERIC); end; >>); end; macro procedure DefArithPred1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC x; if intp x then WGEN x else HARDGEN x; expr procedure HARDGEN x; case Tag x of NEGINT, POSINT: WGEN x; FIXN: WGEN FixVal FixInf x; FLTN: FGEN x; BIGN: BGEN x; default: NIL; end; >>); end; smacro procedure DefFloatEntry(Name, Prim); procedure Name(x, y); begin scalar f; f := GtFLTN(); Prim(FloatBase f, FloatBase FltInf x, FloatBase FltInf y); return MkFLTN f; end; >>; procedure Coerce2(X, Y, F); % % Returns type tag of strongest type and sets ArithArg[0] to be coerced X % and ArithArg[1] to coerced Y. % begin scalar T1, T2, P, C; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; T2 := Tag Y; case T2 of NEGINT: T2 := POSINT; FIXN: << T2 := POSINT; Y := FixVal FixInf Y >>; end; ArithArg[0] := X; ArithArg[1] := Y; if T1 eq T2 then return T1; % no coercion to be done if T1 < T2 then % coerce first arg to second << P := &ArithArg[0]; % P points to first (to be coerced) C := T2; % swap T1 and T2 T2 := T1; T1 := C >> else P := &ArithArg[1]; % P points to second if T1 > FLTN then return ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X, MkQuote Y)); case T1 of FLTN: case T2 of POSINT: @P := StaticIntFloat @P; BIGN: @P := StaticBigFloat @P; end; BIGN: @P := StaticIntBig @P; % @P must be inum end; return T1; end; procedure StaticIntFloat X; << !*WFloat(&StaticFloat[1], X); MkFLTN &StaticFloat[0] >>; procedure NonInteger2Error(X, Y, F); ContinuableError(99, "Non-integer argument in arithmetic", list(F, MkQuote X, MkQuote Y)); procedure NonNumber1Error(X, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X)); DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2); DefFloatEntry(FloatPlus2, !*FPlus2); DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference); DefFloatEntry(FloatDifference, !*FDifference); DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2); DefFloatEntry(FloatTimes2, !*FTimes2); DefArith2Entry(Quotient, WQuotient, FloatQuotient, BigQuotient); DefFloatEntry(FloatQuotient, !*FQuotient); DefArithPred2Entry(GreaterP, WGreaterP, FloatGreaterP, BigGreaterP); procedure FloatGreaterP(X, Y); if !*FGreaterP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefArithPred2Entry(LessP, WLessP, FloatLessP, BigLessP); procedure FloatLessP(X, Y); if !*FLessP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefInt2Entry(Remainder, WRemainder, BigRemainder); DefInt2Entry(LAnd, WAnd, BigLAnd); DefInt2Entry(LOr, WOr, BigLOr); DefInt2Entry(LXOr, WXOr, BigLXOr); DefInt2Entry(LShift, WShift, BigLShift); PutD('LSH, 'EXPR, cdr GetD 'LShift); DefArith1Entry(Add1, IAdd1, lambda X; FloatPlus2(X, '1.0), BigAdd1); DefArith1Entry(Sub1, ISub1, lambda X; FloatDifference(X, '1.0), BigSub1); DefArith1Entry(Minus, IMinus, lambda X; FloatDifference('0.0, X), BigMinus); DefArith1Entry(Fix, lambda X; X, FloatFix, lambda X; X); procedure FloatFix X; Sys2Int !*WFix FloatBase FltInf X; procedure Float X; case Tag X of POSINT, NEGINT: IntFloat X; FIXN: IntFloat FixVal FixInf X; FLTN: X; BIGN: FloatBigArg X; default: NonNumber1Error(X, 'Float); end; procedure IntFloat X; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, X); return MkFLTN F; end; DefArithPred1Entry(MinusP, IMinusP, lambda X; FloatLessP(X, '0.0), BigMinusP); DefArithPred1Entry(ZeroP, IZeroP, lambda X; EQN(X, '0.0), ReturnNil); DefArithPred1Entry(OneP, IOneP, lambda X; EQN(X, '1.0), ReturnNil); syslsp procedure ReturnNil U; NIL; syslsp procedure IsInum U; IsInumMac U; off Syslisp; END; |
Added psl-1983/3-1/util/nbarith.build version [0630aaaa9e].
> > > > | 1 2 3 4 | % NARITH.BUILD - Changes built-in arith to include BIGNUM hooks %/ Should later install as basic BIGNUM package in "nbarith.red"$ |
Added psl-1983/3-1/util/nbarith.red version [30832500cb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBARITH.RED - Generic arithmetic routines for PSL % New model, much less hairy lap % Author: Eric Benson and Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 August 1982 % Copyright (c) 1982 University of Utah %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The MODEL: % It is assumed that there is a range of INUMs (subset) called % BETAnums that can be safely operated on by the Wxxx or Ixxx routines % without loss of precesion or overflow, and return an INUM (or at least % a SYSINT. % % A UNARY operation (UN x) is done as: % Procedure UN x; % If BetaP x then <<x:=WUN x; if IntRangeP x then x else Sys2Int x>> % else UN!-HARD(x); % A UNARY predicate (UNP x) is done as: % Procedure UNP x; % If BetaP x then WUNP x % else UNP!-HARD(x); % A BINARY operation (BIN x y) is done as: % Procedure BIN(x,y); % If BetaP x and BetaP y % then <<x:=WBIN(x,y); % if IntRangeP x then x else Sys2Int x>> % else BIN!-HARD(x,y); % A BINARY predicate (BINP x y) is done as: % Procedure BINP(x,y); % If BetaP x and BetaP y then WBINP(x,y) % else BINP!-HARD(x,y); % IN some "safe" cases, BetaP can become IntP (beware of *) % In others, BetaP(y) may be too weak (eg, Lshift and Expt) % Note: Loading NBIG0 is supposed to define (or redefine) % the functions: % BetaP % Beta2P % BetaRangeP % Sys2Big % FloatFromBignum % Sys2Int % FloatFix % Removed IsInum and INTP in favor of BetaP % % Mods by MLG, 21 dec 1982 % Take off INTERNALFUNCTION form FLOATxxx % Change names of FAKE and SFL to xxxxLOC CompileTime << % Some aliases Fluid '(ArithArgLoc StaticFloatLoc); put('ArithArg, 'NewNam, '(LispVar ArithArgLoc)); put('StaticFloat, 'NewNam, '(LispVar StaticFloatLoc)); >>; LoadTime << % Allocate Physical Space ArithArgLoc := GtWArray 2; StaticFloatLoc := GtWArray 3; >>; expr procedure BetaP x; % Test tagged number is in Beta Range when BIGNUM loaded % Will redefine if NBIG loaded IntP x; expr procedure BetaRangeP w; % Test Word is in Beta Range when BIGNUM loaded % Ie, is FIXNUM size with no NBIG % Will redefine if NBIG loaded 'T; expr procedure Beta2P(x,y); % Test if BOTH in Beta range % Will be redefined if NBIG loaded if IntP x then Intp y else NIL; expr procedure Sys2Big W; % Out of safe range, convert to BIGN ContinuableError(99, "Sys2Big cant convert Word to BIGNUM, no BIGNUM's loaded", Sys2Int W); on Syslisp; CompileTime << %flag('(Coerce2 FloatPlus2 FloatDifference FloatTimes2 % FloatQuotient FloatGreaterP FloatLessP IntFloat % NonInteger2Error NonNumber1Error NonNumber2Error %), 'NotYetInternalFunction); expr procedure NameGen(Name,Part); % Generate Nice specific name from Generic name Intern Concat(ID2String Name,ID2String Part); smacro procedure NextArg(); % Just substitute in the context of U <<U:=cdr U; car U>>; smacro procedure Prologue(); % Common Prologue << generic := NextArg(); wgen := NextArg(); fgen := NextArg(); bgen := NextArg(); hardgen := NameGen(generic,'!-Hardcase); Flag1(hardgen, 'NotYetInternalFunction); >>; macro procedure DefArith2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then <<x:=WGEN(x,y); If IntP x then x else Sys2Int x>> else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); %/ Beware of Overflow, WGEN maybe should test args %/ Coerce2 is supposed to check this case FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArithPred2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then WGEN(x, y) else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); %/ Assumes Preds are safe against Overflow FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefInt2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN BGEN HARDGEN), list(generic, wgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then <<x:=WGEN(x, y); if IntP x then x else Sys2Int x>> else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: NonInteger2Error(x, y, 'GENERIC); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArith1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC x; if BetaP x then <<x:=WGEN x; if IntP x then x else Sys2Int x>> else HARDGEN x; expr procedure HARDGEN x; case Coerce1(x,'GENERIC) of POSINT: Sys2Int WGEN WGetv(ArithArg,0); FLTN: FGEN WGetv(ArithArg,0); BIGN: BGEN WGetv(ArithArg,0); default: NonNumber1Error(x,'GENERIC); end; >>); end; macro procedure DefArithPred1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC x; if BetaP x then WGEN x else HARDGEN x; expr procedure HARDGEN x; case Coerce1(x,'GENERIC) of POSINT: WGEN Wgetv(ArithArg,0); FLTN: FGEN Wgetv(ArithArg,0); BIGN: BGEN Wgetv(ArithArg,0); default: NIL; end; >>); end; smacro procedure DefFloatEntry(Name, Prim); procedure Name(x, y); begin scalar f; f := GtFLTN(); Prim(FloatBase f, FloatBase FltInf x, FloatBase FltInf y); return MkFLTN f; end; >>; % The support procedures for coercing types procedure Coerce1(X, F); % Returns type tag of coerced X type and sets ArithArg[0] to be coerced X % Beware of ADD1/SUB1 cases, maybe can optimize later begin scalar T1; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>; WPutv(ArithArg,0,X); return T1; end; procedure Coerce2(X, Y, F); % Returns type tag of strongest type and sets ArithArg[0] to be coerced X % and ArithArg[1] to coerced Y. begin scalar T1, T2, P, C; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>; T2 := Tag Y; case T2 of NEGINT: T2 := POSINT; FIXN: << T2 := POSINT; Y := FixVal FixInf Y >>; end; If T2=POSINT and not BetaRangeP(Y) then <<T2:=BIGN; y:=Sys2Big y>>; ArithArg[0] := X; ArithArg[1] := Y; if T1 eq T2 then return T1; % no coercion to be done if T1 < T2 then % coerce first arg to second << P := &ArithArg[0]; % P points to first (to be coerced) C := T2; % swap T1 and T2 T2 := T1; T1 := C >> else P := &ArithArg[1]; % P points to second if T1 > FLTN then return NonNumber2Error(X,Y,F); % Here, since no 2 arg Arith Preds that accept 1 number, one not case T1 of FLTN: case T2 of POSINT: @P := StaticIntFloat @P; BIGN: @P := FloatFromBignum @P; end; BIGN: @P := Sys2Big @P; % @P must be SYSint end; return T1; end; procedure StaticIntFloat X; << !*WFloat(&StaticFloat[1], X); MkFLTN &StaticFloat[0] >>; procedure NonInteger2Error(X, Y, F); ContinuableError(99, "Non-integer argument in arithmetic", list(F, MkQuote X, MkQuote Y)); procedure NonNumber1Error(X, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X)); procedure NonNumber2Error(X, Y, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X,Mkquote Y)); % Now generate the entries for each operator DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2); DefFloatEntry(FloatPlus2, !*FPlus2); DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference); DefFloatEntry(FloatDifference, !*FDifference); DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2); % Beware of Overflow DefFloatEntry(FloatTimes2, !*FTimes2); DefArith2Entry(Quotient, WQuotient, FloatQuotient, BigQuotient); DefFloatEntry(FloatQuotient, !*FQuotient); DefArithPred2Entry(GreaterP, WGreaterP, FloatGreaterP, BigGreaterP); procedure FloatGreaterP(X, Y); if !*FGreaterP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefArithPred2Entry(LessP, WLessP, FloatLessP, BigLessP); procedure FloatLessP(X, Y); if !*FLessP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; procedure Fdummy(x,y); StdError "Fdummy should never be called"; DefInt2Entry(Remainder, WRemainder, Fdummy, BigRemainder); DefInt2Entry(LAnd, WAnd, Fdummy, BigLAnd); DefInt2Entry(LOr, WOr, Fdummy, BigLOr); DefInt2Entry(LXOr, WXOr, Fdummy, BigLXOr); % Cant DO Lshift in terms of BETA sized shifts % Will toatlly redefine in BIG package DefInt2Entry(LShift, WShift, BigLShift); PutD('LSH, 'EXPR, cdr GetD 'LShift); DefArith1Entry(Add1, IAdd1, lambda X; FloatPlus2(X, '1.0), BigAdd1); DefArith1Entry(Sub1, ISub1, lambda X; FloatDifference(X, '1.0), BigSub1); DefArith1Entry(Minus, IMinus, lambda X; FloatDifference('0.0, X), BigMinus); DefArith1Entry(Fix, lambda X; X, FloatFix, lambda X; X); procedure FloatFix X; Sys2Int !*WFix FloatBase FltInf X; procedure Float X; case Tag X of POSINT, NEGINT: IntFloat X; FIXN: IntFloat FixVal FixInf X; FLTN: X; BIGN: FloatFromBigNum X; default: NonNumber1Error(X, 'Float); end; procedure IntFloat X; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, X); return MkFLTN F; end; DefArithPred1Entry(MinusP, IMinusP, lambda X; FloatLessP(X, '0.0), BigMinusP); DefArithPred1Entry(ZeroP, IZeroP, lambda X; EQN(X, '0.0), ReturnNil); DefArithPred1Entry(OneP, IOneP, lambda X; EQN(X, '1.0), ReturnNil); syslsp procedure ReturnNil U; NIL; off Syslisp; END; |
Added psl-1983/3-1/util/nbig0.build version [4de290d1e9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBIG0.BUILD - MLG, move BUILD info, add MC68000 case Compiletime<<load syslisp; Load Fast!-Vector; load inum; load if!-system>>; in "nbig0.red"$ % Now install the important globals for this machine if_system(VAX, << BigFloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. BigFloatLow!*:=BMinus BigFloatHi!*>>); if_system(MC68000, <<Setbits 30$ %/ Some BUG? % HP9836 sizes, range 10^-308 .. 10 ^308 % i GUESS: % 10^308 = 2 ^1025 % 15.8 digits, IEEE double ~56 bits BigFloatHi!*:=btimes2(BSUB1 BTWOPOWER 56, btwopower 961);% Largest representable float. BigFloatLow!*:=BMinus BigFloatHi!*>>); if_system(PDP10, << BigFloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); BigFloatLow!*:=BMinus BigFloatHi!*>>); FloatSysHi!* := Float SysHi!*; FloatSysLow!* := Float SysLow!*; END; |
Added psl-1983/3-1/util/nbig0.red version [0119817a7e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBIG0.RED - Vector based BIGNUM package with INUM operations % M. L. Griss & B Morrison, 25 June 1982. % Copyright (C) 1982, A. C. Norman, B. Morrison, M. Griss % % Revision log: % 10 March, 1983, MLG % LSH in Twopower replaced by 2**n % Fixed a bug in SYS2BIG that did not convert negative BIGNUMS correctly % 7 February 1983, MLG % Merged in NBIG1 (see its "revision history" below), plus clean-up. % Revision History of old NBIG1: % 28 Dec 1982, MLG: % Added BigZeroP and BigOneP for NArith % Changed Name to NBIG1.RED from BIGFACE % 22 Dec 1982, MLG: % Change way of converting from VECT to BIGN % Move Module dependency to .BUILD file % Changes for NEW-ARITH, involve name changes for MAKEFIXNUM % ISINUM, etc. % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman % Use the BIGN tag for better Interface % % 31 Dec 1982, MLG % Changed BNUM to check if arg ALREADY Big. Kludge % since new NARITH makes some things BIG earlier % since it calls the BIG funcs directly % 20 Dec 1982, MLG % Changed TrimBigNUM to TrimBigNum1 in BhardDivide % % 14 Dec 1982, MLG % Changed to put LOAD and IMPORTS in BUILD file % % 31 August 1982, A. C . Norman % Adjustments to many routines: in particular corrections to BHardDivide % (case D6 utterly wrong), and adjustments to BExpt (for performance) and % all logical operators (for treatment of negative inputs); % --------------------------------------------------------------- % ----------------------- % A bignum will be a VECTOR of Bigits: (digits in base BigBase): % [BIGPOS b1 ... bn] or [BIGNEG b1 ... bn]. BigZero is thus [BIGPOS] % All numbers are positive, with BIGNEG as 0 element to indicate negatives. % BETA.RED - some values of BETA testing % On DEC-20, Important Ranges are: % -------------------------------- % POSBETA | 0 | n | % -------------------------------- % 19 17 bits % -------------------------------- % NEGBETA | -1 | | % -------------------------------- % % -------------------------------- % POSINT | 0 | 0 | | % -------------------------------- % 5 13 18 bits % -------------------------------- % NEGINT | -1 | -1 | | % -------------------------------- % Thus BETA: 2^17-1 -131072 ... 131071 % INT 2^18-1 -262144 ... 262143 % FIX 2^35-1 -34359738368 ... 34359738367 % [Note that one bit used for sign in 36 bit word] fluid '(BigBetaHi!* % Largest BetaNum in BIG format BigBetaLow!* % Smallest BetaNum in BIG format BetaHi!* % Largest BetaNum as Inum BetaLow!* % Smallest BetaNum as Inum SysHi!* % Largest SYSINT in FixN format SysLow!* % Smallest SYSINT in FixN format BigSysHi!* % Largest SYSINT in BIG format BigSysLow!* % Smallest SYSINT in BIG format FloatSysHi!* % Largest SYSINT in Float format FloatSysLow!* % Smallest SYSINT in Float format BBase!* % BETA, base of system FloatBbase!* % As a float BigFloatHi!* % Largest Float in BIG format BigFloatLow!* % Smallest Float in BIG format StaticBig!* % Warray for conversion of SYS to BIG Bone!* % A one Bzero!* % A zero BBits!* % Number of Bits in BBASE!* LogicalBits!* Digit2Letter!* Carry!* OutputBase!* ); % -------------------------------------------------------------------------- % -------------------------------------------------------------------------- % Support functions: % % U, V, V1, V2 for arguments are Bignums. Other arguments are usually % fix/i-nums. smacro procedure PutBig(b,i,val); % Access elements of a BIGNUM IputV(b,i,val); smacro procedure GetBig(b,i); % Access elements of a BIGNUM IgetV(B,i); procedure setbits x; % % This function sets the globals for big bignum package. % "x" should be total # of bits per word. Begin scalar y; BBits!*:=iquotient(isub1 x,2); % Total number of bits per word used. BBase!*:=TwoPower BBits!*; % "Beta", where n=A0 + A1*beta + A2*(beta^2). FloatBbase!* := IntFloat Bbase!*; LogicalBits!*:=ISub1 BBase!*; % Used in LAnd,Lor, etc. BetaHi!*:=isub1 Bbase!*; BetaLow!* :=Iminus Bbase!*; Bone!* := Bnum 1; Bzero!* := Bnum 0; BigBetaHi!*:=BNum BetaHi!*; % Highest value of Ai BigBetaLow!*:=BMinus BigBetaHi!*; % Lowest value of Ai % here assume 2's complement y:=TwoPower idifference (x,2); % eg, 36 bits, 2^35-1=2^34+2^34-1 SysHi!* :=y+(y-1); y:=-y; Syslow!* :=y+y; BigSysHi!*:=bdifference(btwopower isub1 x, Bone!*); % Largest representable Syslisp integer. % Note that SYSPOS has leading 0, ie only x-1 active bits BigSysLow!*:=BMinus BPlus2(Bone!*, BigSysHi!*); % Smallest representable Syslisp integer. end; procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); procedure BSize V; % Upper Limit of [BIGxxx a1 ... An] If BigP V then VecLen VecInf V else 0; procedure GtPOS N; % Allocate [BIGPOS a1 ... an] Begin N:=MkVect N; IPutV(N,0,'BIGPOS); Return MkBigN Vecinf N; End; procedure GtNeg N; % Allocate [BIGNEG a1 ... an] Begin N:=MkVect N; IPutV(N,0,'BIGNEG); Return MkBigN VecInf N; End; procedure TrimBigNum V3; % truncate trailing 0 If Not BigP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; procedure BigAsVec B; % In order to see BIGITS MkVec Inf B; procedure VecAsBig V; MkBigN VecInf V; Procedure BIG2Sys U; % Convert a BIG to SYS, if in range If Blessp(U,BigSysLow!*) or Bgreaterp(U,BigSysHi!*) then ContinuableError(99,"BIGNUM too large to convert to SYS", U) else Big2SysAux U; procedure Big2SysAux U; % Convert a BIGN that is in range to a SYSINT begin scalar L,Sn,res; L:=BSize U; if IZeroP L then return 0; res:=IGetV(U,L); L:=ISub1 L; If BMinusP U then <<res:=-res; while L neq 0 do <<res:=ITimes2(res, Bbase!*); res:=IDifference(res, IGetV(U,L)); L:=ISub1 L>>; >> else while L neq 0 do <<res:=ITimes2(res, Bbase!*); res:=IPlus2(res, IGetV(U,L)); L:=ISub1 L>>; return Res; end; procedure TwoPower N; %fix/i-num 2**n 2**n; procedure BTwoPower N; % gives 2**n; n is fix/i-num; result BigNum if not (fixp N or BigP N) then NonIntegerError(N, 'BTwoPower) else begin scalar quot, rem, V; if BigP N then n:=big2sys n; quot:=Quotient(N,Bbits!*); rem:=Remainder(N,Bbits!*); V:=GtPOS(IAdd1 quot); IFor i:=1:quot do IPutV(v,i,0); IPutV(V,IAdd1 quot,twopower rem); return TrimBigNum1(V,IAdd1 quot); end; procedure BZeroP V1; IZerop BSize V1 and not BMinusP V1; procedure BOneP V1; Not BMinusP V1 and IOneP (BSize V1) and IOneP IGetV(V1,1); procedure BAbs V1; if BMinusP V1 then BMinus V1 else V1; procedure BMax(V1,V2); if BGreaterP(V2,V1) then V2 else V1; procedure BMin(V1,V2); if BLessP(V2,V1) then V2 else V1; procedure BExpt(V1,N); % V1 is Bignum, N is fix/i-num if not fixp N then NonIntegerError(N,'BEXPT) else if IZeroP N then Bone!* else if IOneP N then V1 else if IMinusP N then BQuotient(Bone!*,BExpt(V1,IMinus N)) else begin scalar V2; V2 := BExpt(V1,IQuotient(N,2)); if IZeroP IRemainder(N,2) then return BTimes2(V2,V2) else return BTimes2(BTimes2(V2,V1),V2) end; % --------------------------------------- % Logical Operations % % All take Bignum arguments procedure BLOr(V1,V2); % The main body of the OR code is only obeyed when both arguments % are positive, and so the result will be positive; if BMinusp V1 or BMinusp V2 then BLnot BLand(BLnot V1,BLnot V2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); Return V3 end; procedure BLXor(V1,V2); % negative arguments are coped with using the identity % LXor(a,b) = LNot LXor(Lnot a,b) = LNor LXor(a,Lnot b); begin scalar L1,L2,L3,V3,S; if BMinusp V1 then << V1 := BLnot V1; S := t >>; if BMinusp V2 then << V2 := BLnot V2; S := not S >>; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILXor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); V1:=TrimBigNum1(V3,L1); if S then V1:=BLnot V1; return V1 end; % Not Used Currently: % % procedure BLDiff(V1,V2); % ***** STILL NEEDS ADJUSTING WRT -VE ARGS ***** % begin scalar V3,L1,L2; % L1:=BSize V1; % L2:=BSize V2; % V3:=GtPOS(max(L1,L2)); % IFor i:=1:min(L1,L2) do % IPutV(V3,i,ILAnd(IGetV(V1,i),ILXor(LogicalBits!*,IGetV(V2,i)))); % if IGreaterP(L1,L2) then IFor i:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,i)); % if IGreaterP(L2,L1) then IFor i:=(IAdd1 L1):L2 do IPutV(V3,i,0); % return TrimBigNum1(V3,max(L1,L2)); % end; procedure BLAnd(V1,V2); % If both args are -ve the result will be too. Otherwise result will % be positive; if BMinusp V1 and BMinusp V2 then BLnot BLor(BLnot V1,BLnot v2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; L3:=Min(L1,L2); V3:=GtPOS L3; if BMinusp V1 then IFor I:=1:L3 do IPutV(V3,I,ILand(ILXor(Logicalbits!*,IGetV(V1,I)), IGetV(V2,I))) else if BMinusp V2 then IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I), ILXor(Logicalbits!*,IGetV(V2,I)))) else IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I),IGetV(V2,I))); return TrimBigNum1(V3,L3); End; procedure BLNot(V1); BMinus BSmallAdd(V1,1); procedure BLShift(V1,V2); % This seems a grimly inefficient way of doing things given that % the representation of big numbers uses a base that is a power of 2. % However it will do for now; if BMinusP V2 then BQuotient(V1, BTwoPower BMinus V2) else BTimes2(V1, BTwoPower V2); % ----------------------------------------- % Arithmetic Functions: % % U, V, V1, V2 are Bignum arguments. procedure BMinus V1; % Negates V1. if BZeroP V1 then V1 else begin scalar L1,V2; L1:=BSize V1; if BMinusP V1 then V2 := GtPOS L1 else V2 := GtNEG L1; IFor I:=1:L1 do IPutV(V2,I,IGetV(V1,I)); return V2; end; % Returns V1 if V1 is strictly less than 0, NIL otherwise. % procedure BMinusP V1; if (IGetV(V1,0) eq 'BIGNEG) then V1 else NIL; % To provide a conveninent ADD with CARRY. procedure AddCarry A; begin scalar S; S:=IPlus2(A,Carry!*); if IGeq(S,BBase!*) then <<Carry!*:= 1; S:=IDifference(S,BBase!*)>> else Carry!*:=0; return S; end; procedure BPlus2(V1,V2); begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if Sn1 and Not Sn2 then return BDifference2(V2,BMinus V1,Nil); if Sn2 and Not Sn1 then return BDifference2(V1,BMinus V2,Nil); return BPlusA2(V1,V2,Sn1); end; procedure BPlusA2(V1,V2,Sn1); % Plus with signs pre-checked and begin scalar L1,L2,L3,V3,temp; % identical. L1:=BSize V1; L2:=BSize V2; If IGreaterP(L2,L1) then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; L3:=IAdd1 L1; If Sn1 then V3:=GtNeg L3 else V3:=GtPOS L3; Carry!*:=0; IFor I:=1:L2 do <<temp:=IPlus2(IGetV(V1,I),IGetV(V2,I)); IPutV(V3,I,AddCarry temp)>>; temp:=IAdd1 L2; IFor I:=temp:L1 do IPutV(V3,I,AddCarry IGetV(V1,I)); IPutV(V3,L3,Carry!*); % Carry Out Return TrimBigNum1(V3,L3); end; procedure BDifference(V1,V2); if BZeroP V2 then V1 else if BZeroP V1 then BMinus V2 else begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if (Sn1 and Not Sn2) or (Sn2 and Not Sn1) then return BPlusA2(V1,BMinus V2,Sn1); return BDifference2(V1,V2,Sn1); end; procedure SubCarry A; begin scalar S; S:=IDifference(A,Carry!*); if ILessP(S,0) then <<Carry!*:=1; S:=IPlus2(BBase!*,S)>> else Carry!*:=0; return S; end; Procedure BDifference2(V1,V2,Sn1); % Signs pre-checked and identical. begin scalar i,L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3; Sn1:=not Sn1>> else if L1 Eq L2 then <<i:=L1; while (IGetV(V2,i) Eq IGetV(V1,i) and IGreaterP(i,1)) do i:=ISub1 i; if IGreaterP(IGetV(V2,i),IGetV(V1,i)) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3;Sn1:=not Sn1>> >>; if Sn1 then V3:=GtNEG L1 else V3:=GtPOS L1; carry!*:=0; IFor I:=1:L2 do IPutV(V3,I,SubCarry IDifference(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,I,SubCarry IGetV(V1,I)); return TrimBigNum1(V3,L1); end; procedure BTimes2(V1,V2); begin scalar L1,L2,L3,Sn1,Sn2,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<V3:=V1; V1:=V2; V2:=V3; % If V1 is larger, will be fewer L3:=L1; L1:=L2; L2:=L3>>; % iterations of BDigitTimes2. L3:=IPlus2(L1,L2); Sn1:=BMinusP V1; Sn2:=BMinusP V2; If (Sn1 and Sn2) or not(Sn1 or Sn2) then V3:=GtPOS L3 else V3:=GtNEG L3; IFor I:=1:L3 do IPutV(V3,I,0); IFor I:=1:L2 do BDigitTimes2(V1,IGetV(V2,I),L1,I,V3); return TrimBigNum1(V3,L3); end; Procedure BDigitTimes2(V1,V2,L1,I,V3); % V1 is a bignum, V2 a fixnum, L1=BSize L1, I=position of V2 in a bignum, % and V3 is bignum receiving result. I affects where in V3 the result of % a calculation goes; the relationship is that positions I:I+(L1-1) % of V3 receive the products of V2 and positions 1:L1 of V1. % V3 is changed as a side effect here. begin scalar J,carry,temp1,temp2; if zerop V2 then return V3 else << carry:=0; IFor H:=1:L1 do << temp1:=ITimes2(IGetV(V1,H),V2); temp2:=IPlus2(H,ISub1 I); J:=IPlus2(IPlus2(temp1,IGetV(V3,temp2)),carry); IPutV(V3,temp2,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IPutV(V3,IPlus2(L1,I),carry)>>; % carry should be < BBase!* here return V3; end; Procedure BSmallTimes2(V1,C); % V1 is a BigNum, C a fixnum. % Assume C positive, ignore sign(V1) % also assume V1 neq 0. if ZeroP C then return GtPOS 0 % Only used from BHardDivide, BReadAdd. else begin scalar J,carry,L1,L2,L3,V3; L1:=BSize V1; L2:=IPlus2(IQuotient(C,BBase!*),L1); L3:=IAdd1 L2; V3:=GtPOS L3; carry:=0; IFor H:=1:L1 do << J:=IPlus2(ITimes2(IGetV(V1,H),C),carry); IPutV(V3,H,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IFor H:=(IAdd1 L1):L3 do << IPutV(V3,H,IRemainder(J:=carry,BBase!*)); carry:=IQuotient(J,BBase!*)>>; return TrimBigNum1(V3,L3); end; procedure BQuotient(V1,V2); car BDivide(V1,V2); procedure BRemainder(V1,V2); cdr BDivide(V1,V2); % BDivide returns a dotted pair, (Q . R). Q is the quotient and R is % the remainder. Both are bignums. R is of the same sign as V1. %; smacro procedure BSimpleQuotient(V1,L1,C,SnC); car BSimpleDivide(V1,L1,C,SnC); smacro procedure BSimpleRemainder(V1,L1,C,SnC); cdr BSimpleDivide(V1,L1,C,SnC); procedure BDivide(V1,V2); begin scalar L1,L2,Q,R,V3; L2:=BSize V2; If IZerop L2 then error(99, "Attempt to divide by 0 in BDIVIDE"); L1:=BSize V1; If ILessP(L1,L2) or (L1 Eq L2 and ILessP(IGetV(V1,L1),IGetV(V2,L2))) % This also takes care of case then return (GtPOS 0 . V1); % when V1=0. if IOnep L2 then return BSimpleDivide(V1,L1,IGetV(V2,1),BMinusP V2); return BHardDivide(V1,L1,V2,L2); end; % C is a fixnum (inum?); V1 is a bignum and L1 is its length. % SnC is T if C (which is positive) should be considered negative. % Returns quotient . remainder; each is a bignum. % procedure BSimpleDivide(V1,L1,C,SnC); begin scalar I,P,R,RR,Sn1,V2; Sn1:=BMinusP V1; if (Sn1 and SnC) or not(Sn1 or SnC) then V2:=GtPOS L1 else V2:=GtNEG L1; R:=0; I:=L1; While not IZeroP I do <<P:=IPlus2(ITimes2(R,BBase!*),IGetV(V1,I)); % Overflow. IPutV(V2,I,IQuotient(P, C)); R:=IRemainder(P, C); I:=ISub1 I>>; If Sn1 then RR:=GtNeg 1 else RR:=GtPOS 1; IPutV(RR,1,R); return (TrimBigNum1(V2,L1) . TrimBigNum1(RR,1)); end; procedure BHardDivide(U,Lu,V,Lv); % This is an algorithm taken from Knuth. begin scalar U1,V1,A,D,LCV,LCV1,f,f2,J,K,Lq,carry,temp, LL,M,N,N1,P,Q,QBar,SnU,SnV,U2; N:=Lv; N1:=IAdd1 N; M:=IDifference(Lu,Lv); Lq:=IAdd1 M; % Deal with signs of inputs; SnU:=BMinusP U; SnV:=BMinusp V; % Note that these are not extra-boolean, i.e. % for positive numbers MBinusP returns nil, for % negative it returns its argument. Thus the % test (SnU=SnV) does not reliably compare the signs of % U and V; if SnU then if SnV then Q := GtPOS Lq else Q := GtNEG Lq else if SnV then Q := GtNEG Lq else Q := GtPOS Lq; U1 := GtPOS IAdd1 Lu; % U is ALWAYS stored as if one digit longer; % Compute a scale factor to normalize the long division; D:=IQuotient(BBase!*,IAdd1 IGetV(V,Lv)); % Now, at the same time, I remove the sign information from U and V % and scale them so that the leading coefficeint in V is fairly large; carry := 0; IFor i:=1:Lu do << temp := IPlus2(ITimes2(IGetV(U,I),D),carry); IPutV(U1,I,IRemainder(temp,BBase!*)); carry := IQuotient(temp,BBase!*) >>; Lu := IAdd1 Lu; IPutV(U1,Lu,carry); V1:=BSmallTimes2(V,D); % So far all variables contain safe values, % i.e. numbers < BBase!*; IPutV(V1,0,'BIGPOS); if ILessp(Lv,2) then NonBigNumError(V,'BHARDDIVIDE); % To be safe; LCV := IGetV(V1,Lv); LCV1 := IGetv(V1,ISub1 Lv); % Top two digits of the scaled V accessed once % here outside the main loop; % Now perform the main long division loop; IFor I:=0:M do << J:=IDifference(Lu,I); % J>K; working on U1[K:J] K:=IDifference(J,N1); % in this loop. A:=IGetV(U1,J); P := IPlus2(ITimes2(A,BBase!*),IGetv(U1,Isub1 J)); % N.B. P is up to 30 bits long. Take care! ; if A Eq LCV then QBar := ISub1 BBase!* else QBar := Iquotient(P,LCV); % approximate next digit; f:=ITimes2(QBar,LCV1); f2:=IPlus2(ITimes2(IDifference(P,ITimes2(QBar,LCV)),BBase!*), IGetV(U1,IDifference(J,2))); while IGreaterP(f,f2) do << % Correct most overshoots in Qbar; QBar:=ISub1 QBar; f:=IDifference(f,LCV1);; f2:=IPlus2(f2,ITimes2(LCV,BBase!*)) >>; carry := 0; % Ready to subtract QBar*V1 from U1; IFor L:=1:N do << temp := IPlus2( Idifference( IGetV(U1,IPlus2(K,L)), ITimes2(QBar,IGetV(V1,L))), carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusp temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,IPlus2(K,L),temp) >>; % Now propagate borrows up as far as they go; LL := IPlus2(K,N); while (not IZeroP carry) and ILessp(LL,J) do << LL := IAdd1 LL; temp := IPlus2(IGetV(U1,LL),carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusP temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,LL,temp) >>; if not IZerop carry then << % QBar was still wrong - correction step needed. % This should not happen very often; QBar := ISub1 QBar; % Add V1 back into U1; carry := 0; IFor L := 1:N do << carry := IPlus2( IPlus2(IGetV(U1,Iplus2(K,L)), IGetV(V1,L)), carry); IPutV(U1,IPlus2(K,L),IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >>; LL := IPlus2(K,N); while ILessp(LL,J) do << LL := IAdd1 LL; carry := IPlus2(IGetv(U1,LL),carry); IPutV(U1,LL,IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >> >>; IPutV(Q,IDifference(Lq,I),QBar) >>; % End of main loop; U1 := TrimBigNum1(U1,IDifference(Lu,M)); f := 0; f2 := 0; % Clean up potentially wild values; if not BZeroP U1 then << % Unnormalize the remainder by dividing by D if SnU then IPutV(U1,0,'BIGNEG); if not IOnep D then << Lu := BSize U1; carry := 0; IFor L:=Lu step -1 until 1 do << P := IPlus2(ITimes2(carry,BBase!*),IGetV(U1,L)); IPutv(U1,L,IQuotient(P,D)); carry := IRemainder(P,D) >>; P := 0; if not IZeroP carry then BHardBug("remainder when unscaling", U,V,TrimBigNum1(U1,Lu),TrimBigNum1(Q,Lq)); U1 := TrimBigNum1(U1,Lu) >> >>; Q := TrimBigNum1(Q,Lq); % In case leading digit happened to be zero; P := 0; % flush out a 30 bit number; % Here, for debugging purposes, I will try to validate the results I % have obtained by testing if Q*V+U1=U and 0<=U1<V. I Know this slows things % down, but I will remove it when my confidence has improved somewhat; % if not BZerop U1 then << % if (BMinusP U and not BMinusP U1) or % (BMinusP U1 and not BMinusP U) then % BHardBug("remainder has wrong sign",U,V,U1,Q) >>; % if not BAbs U1<BAbs V then BHardBug("remainder out of range",U,V,U1,Q) % else if not BZerop(BDifference(BPlus2(BTimes2(Q,V),U1),U)) then % BHardBug("quotient or remainder incorrect",U,V,U1,Q); return (Q . U1) end; procedure BHardBug(msg,U,V,R,Q); % Because the inputs to BHardDivide are probably rather large, I am not % going to rely on BldMsg to display them; << Prin2T "***** Internal error in BHardDivide"; Prin2 "arg1="; Prin2T U; Prin2 "arg2="; Prin2T V; Prin2 "computed quotient="; Prin2T Q; Prin2 "computed remainder="; Prin2T R; StdError msg >>; procedure BGreaterP(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(V,U) else nil else if BMinusP V then U else BUnsignedGreaterP(U,V); procedure BLessp(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(U,V) else U else if BMinusP V then nil else BUnsignedGreaterP(V,U); procedure BGeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(V,U) else nil else if BMinusP V then U else BUnsignedGeq(U,V); procedure BLeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(U,V) else U else if BMinusP V then nil else BUnsignedGeq(V,U); procedure BUnsignedGreaterP(U,V); % Compare magnitudes of two bignums; begin scalar Lu,Lv,I; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; if IGreaterP(IGetV(U,Lv),IGetV(V,Lv)) then return U else return nil end; procedure BUnsignedGeq(U,V); % Compare magnitudes of two unsigned bignums; begin scalar Lu,Lv; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; If IGreaterP(IGetV(V,Lv),IGetV(U,Lv)) then return nil else return U end; procedure BAdd1 V; BSmallAdd(V, 1); procedure BSub1 U; BSmallDiff(U, 1); % ------------------------------------------------ % Conversion to Float: procedure FloatFromBigNum V; if BZeroP V then 0.0 else if BGreaterP(V, BigFloatHi!*) or BLessp(V, BigFloatLow!*) then Error(99,list("Argument, ",V," to FLOAT is too large")) else begin scalar L,Res,Sn,I; % Careful, do not want to call itself recursively L:=BSize V; Sn:=BMinusP V; Res:=IntFloat IGetv(V,L); I:=ISub1 L; While not IZeroP I do << Res:=FloatTimes2(res,FloatBBase!*); Res:=FloatPlus2(Res, IntFloat IGetV(V,I)); I:=ISub1 I>>; if Sn then Res:=minus res; return res; end; % ------------------------------------------------ % Input and Output: Digit2Letter!* := % Ascii values of digits and characters. '[48 49 50 51 52 53 54 55 56 57 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]; % OutputBase!* is assumed to be positive and less than 37. procedure BChannelPrin2(Channel,V); If not BigP V then NonBigNumError(V, 'BPrin) %need? else begin scalar quot, rem, div, result, resultsign, myobase; myobase:=OutputBase!*; resultsign:=BMinusP V; div:=BSimpleDivide(V,Bsize V,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result; while Not BZeroP quot do <<div:=BSimpleDivide(quot,Bsize quot,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result>>; if resultsign then channelwritechar(Channel,char !-); if myobase neq 10 then <<ChannelWriteSysInteger(channel,myobase,10); ChannelWriteChar(Channel, char !#)>>; For each u in result do ChannelWriteChar(Channel, IGetV(digit2letter!*,u)); OutputBase!*:=myobase; return; end; procedure BRead(s,radix,sn); % radix is < Bbase!* %s=string of digits, radix=base, sn=1 or -1 begin scalar sz, res, ch; sz:=size s; res:=GtPOS 1; ch:=indx(s,0); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IPlus2(IDifference(ch,char A),10); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); IPutV(res,1,ch); IFor i:=1:sz do <<ch:=indx(s,i); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IDifference(ch,IDifference(char A,10)); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); res:=BReadAdd(res, radix, ch)>>; if iminusp sn then res:=BMinus res; return res; end; procedure BReadAdd(V, radix, ch); << V:=BSmallTimes2(V, radix); V:=BSmallAdd(V,ch)>>; procedure BSmallAdd(V,C); %V big, C fix. if IZerop C then return V else if Bzerop V then return int2Big C else if BMinusp V then BMinus BSmallDiff(BMinus V, C) else if IMinusP C then BSmallDiff(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS(IAdd1 L1); IFor i:=1:L1 do IPutV(V1,i,addcarry IGetV(V,i)); if IOneP carry!* then IPutV(V1,IAdd1 L1,1) else return TrimBigNum1(V1,L1); return V1 end; procedure BNum N; % Creates a Bignum of one BETA digit, value N. % N is POS or NEG IF BIGP N then N else BnumAux N; procedure BNumAux N; % Creates a Bignum of one BIGIT value N. % N is POS or NEG begin scalar B; if IZerop n then return GtPOS 0 else if IMinusp N then <<b:=GtNEG 1; n:= IMinus n>> else b:=GtPos 1; IPutV(b,1,N); Return b; end; procedure BSmallDiff(V,C); %V big, C fix if IZerop C then V else if BZeroP V then int2Big IMinus C else if BMinusP V then BMinus BSmallAdd(BMinus V, C) else if IMinusP C then BSmallAdd(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS L1; IFor i:=1:L1 do IPuTV(V1,i,subcarry IGetV(V,i)); if not IZeroP carry!* then StdError BldMsg(" BSmallDiff V<C %p %p%n",V,C); return TrimBigNum1(V1,L1); end; on syslisp; syslsp procedure int2Big n; % Creates BigNum of value N. % From any N, BETA,INUM,FIXNUM or BIGNUM case tag n of NEGINT,POSINT: sys2Big n; FIXN: sys2Big fixval fixinf n; BIGN: N; default: NonIntegerError(n, 'int2Big); End; off syslisp; % Convert BIGNUMs to FLOAT procedure bigfromfloat X; if fixp x or bigp x then x else begin scalar bigpart,floatpart,power,sign,thispart; if minusp X then <<sign:=-1; X:=minus X>> else sign:=1; bigpart:=bzero!*; while neq(X, 0) and neq(x,0.0) do << if X < bbase!* then << bigpart:=bplus2(bigpart, bnum fix x); X:=0 >> else <<floatpart:=x; power:=0; while floatpart>=bbase!* do % get high end of number. <<floatpart:=floatpart/bbase!*; power:=power + bbits!* >>; thispart:=btimes2(btwopower power, bnum fix floatpart); X:=X- floatfrombignum thispart; bigpart:=bplus2(bigpart, thispart) >> >>; if minusp sign then bigpart := bminus bigpart; return bigpart; end; % Now Install Interfacing on syslisp; syslsp procedure SetUpGlobals; << Prin2t '"SetupGlobals"; SetBits BitsPerWord; Prin2T '" ... done";>>; off syslisp; SetupGlobals(); LoadTime << StaticBig!*:=GtWarray 10>>; % Assume dont need more than 10 slots to represent a BigNum % Version of SYSint % -- Output--- % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; procedure checkifreallybig UU; % If BIGNUM result is in older FIXNUM or INUM range % Convert Back. %/ Need a faster test if BLessP(UU, BigSysLow!*) or BGreaterp(UU,BigSysHi!*) then UU else Sys2Int Big2SysAux UU; procedure checkifreallybigpair VV; % Used to process DIVIDE checkifreallybig car VV . checkifreallybig cdr VV; procedure checkifreallybigornil UU; % Used for EXTRA-boolean tests if Null UU or BLessp(UU, BigSysLow!*) or BGreaterP(UU,BigSysHi!*) then UU else Sys2Int Big2SysAux UU; procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); on syslisp; procedure Lshift(U,V); If BetaP U and BetaP V then (if V<0 then Sys2Int Wshift(U,V) else if V< LispVar (BBits!* ) then Sys2Int Wshift(U,V) else BigLshift(Sys2Big U, Sys2Big V) ) else BigLshift(Sys2Big U, Sys2Big V) ; off syslisp; Copyd('LSH,'Lshift); procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; procedure BigSub1 U; CheckIfReallyBig BSub1 U; procedure BigLNot U; CheckIfReallyBig BLNot U; procedure BigMinus U; CheckIfReallyBig BMinus U; procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; procedure BigOneP U; CheckIfReallyBigOrNil BOneP U; procedure BigZeroP U; CheckIfReallyBigOrNil BZeroP U; % ---- Input ---- procedure MakeStringIntoLispInteger(S,Radix,Sn); CheckIfReallyBig BRead(S,Radix,Sn); on syslisp; procedure Int2Sys N; % Convert a random FIXed number to WORD Integer case tag(N) of POSINT,NEGINT: N; FIXN: FixVal FixInf N; BIGN: Big2SysAux N; default: NonNumber1Error(N,'Int2SYS); End; syslsp procedure Sys2Big N; % Convert a SYSint to a BIG % Must NOT use generic arith here % Careful that no GC if this BIGger than INUM Begin scalar Sn, A, B; If N=0 then return GtPos 0; A:= LispVar StaticBig!*; % Grab the base If N<0 then sn:=T; A[1]:=N; % Plant number N:=1; % now use N as counter % Careful handling of -N in case have largest NEG, not just % flip sign If Sn then <<B:=-Bbase!*; While A[n]<=B do <<N:=N+1; A[n]:=A[n-1]/Bbase!*; A[n-1]:=A[n-1]-a[n]*Bbase!*>>; B:=GtNeg N; For i:=1:N do Iputv(B,i,-A[i])>> else << While A[n]>=Bbase!* do <<N:=N+1; A[n]:=A[n-1]/Bbase!*; A[n-1]:=A[n-1]-a[n]*Bbase!*>>; B:= GtPos N; For i:=1:N do IputV(B,i,A[i])>>; Return B; End; off syslisp; % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure FloatFix U; % Careful of sign and range If FloatSysLow!* <= U and U <= FloatSysHi!* then Oldfloatfix U else bigfromfloat U; on syslisp; procedure BetaP x; % test if NUMBER in reduced INUM range If Intp x then (x <= Lispvar(betaHi!*)) and (x >= LispVar(betaLow!*)) else NIL; procedure BetaRangeP x; % Test if SYSINT in reduced INUM range if (x <= Lispvar(betaHi!*)) then (x>=LispVar(betaLow!*)) else NIL; procedure Beta2P(x,y); % Check for 2 argument arithmetic functions if BetaP x then BetaP y; off syslisp; End; end; |
Added psl-1983/3-1/util/nstruct.build version [ddd821daec].
> > > | 1 2 3 | compiletime load clcomp,strings; in "nstruct.lsp"$ in "fast-struct.lsp"$ |
Added psl-1983/3-1/util/nstruct.lsp version [769e49e6f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; -*- Mode:Lisp; Package:SI; Lowercase:True; Base:8 -*- ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;The master copy of this file is in MC:ALAN;NSTRUCT > ;The current Lisp machine copy is in AI:LISPM2;STRUCT > ;The current Multics copy is in >udd>Mathlab>Bawden>defstruct.lisp ;***** READ THIS PLEASE! ***** ;If you are thinking of munging anything in this file you might want ;to consider finding me (ALAN) and asking me to mung it for you. ;There is more than one copy of this file in the world (it runs in PDP10 ;and Multics MacLisp and on LispMachines) and whatever amazing ;features you are considering adding might be usefull to those people ;as well. If you still cannot contain yourself long enough to find ;me, AT LEAST send me a piece of mail describing what you did and why. ;Thanks for reading this flame. ; Alan Bawden (ALAN@MC) ;Things to fix: ;For LispMachine: ; :%P-LDB type (this is hard to do, punt for now.) ;For Multics: ; displacement is a problem (no displace) ; nth, nthcdr don't exist there ; ldb, dpb don't exist, so byte fields don't work without Mathlab macros ; callable accessors don't work ; dpb is needed at the user's compile time if he is using byte fields. ; PSL change deleted ;(eval-when (compile) ; (cond ((status feature ITS) ; (load '|alan;lspenv init|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>lspenv.lisp|)))) ; ;#+PDP10 ;(cond ((status nofeature noldmsg) ; (terpri msgfiles) ; (princ '#.(and (status feature PDP10) ; (maknam (nconc (exploden ";Loading DEFSTRUCT ") ; (exploden (caddr (truename infile)))))) ; msgfiles))) ; ;#+Multics ;(declare (genprefix defstruct-internal-) ; (macros t)) ; ;#M ;(eval-when (eval compile) ; (setsyntax #/: (ascii #\space) nil)) ; PSL change -- make sure everything we need at run time gets loaded (imports '(useful common strings)) (eval-when (eval) ;;So we may run the thing interpreted we need the simple ;;defstruct that lives here: ; PSL change (lapin "struct.initial")) ; (cond ((status feature ITS) ; (load '|alan;struct initial|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>initial_defstruct|)))) (eval-when (compile) ;;To compile the thing this probably is an old fasl: (!) ; PSL change (load nstruct)) ; (cond ((status feature ITS) ; (load '|alan;struct boot|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>boot_defstruct|)))) #+Multics (defun nth (n l) (do ((n n (sub1 n)) (l l (cdr l))) ((zerop n) (car l)))) #+Multics (defun nthcdr (n l) (do ((n n (1- n)) (l l (cdr l))) ((zerop n) l))) ; PSL change I'm not sure whether we need this at all ;#+Multics (defun displace (x y) (cond ((atom y) (rplaca x 'progn) (rplacd x (list y))) (t (rplaca x (car y)) (rplacd x (cdr y)))) x) ;;; You might think you could use progn for this, but you can't! (defun defstruct-dont-displace (x y) x ;ignored y) ;;; Eval this before attempting incremental compilation (eval-when (eval compile) ; PSL change ;#+PDP10 ;(defmacro append-symbols args ; (do ((l (reverse args) (cdr l)) ; (x) ; (a nil (if (or (atom x) ; (not (eq (car x) 'quote))) ; (if (null a) ; `(exploden ,x) ; `(nconc (exploden ,x) ,a)) ; (let ((l (exploden (cadr x)))) ; (cond ((null a) `',l) ; ((= 1 (length l)) `(cons ,(car l) ,a)) ; (t `(append ',l ,a))))))) ; ((null l) `(implode ,a)) ; (setq x (car l)))) ; ;#+Multics ;(defmacro append-symbols args ; `(make_atom (catenate . ,args))) ; ;#+LispM ;(defmacro append-symbols args ; `(intern (string-append . ,args))) (defmacro append-symbols args `(intern (string-concat . ,args))) (defmacro defstruct-putprop (sym val ind) `(push `(defprop ,,sym ,,val ,,ind) returns)) (defmacro defstruct-put-macro (sym fcn) ; PSL change `(push `(putd ',,sym 'macro (function (lambda (**put-mac**) (,,fcn **put-mac**)))) returns)) ; #M `(defstruct-putprop ,sym ,fcn 'macro) ; #Q (setq fcn (if (and (not (atom fcn)) ; (eq (car fcn) 'quote)) ; `'(macro . ,(cadr fcn)) ; `(cons 'macro ,fcn))) ; #Q `(push `(fdefine ',,sym ',,fcn t) returns)) (defmacro make-empty () `'%%defstruct-empty%%) (defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%)) ;;;Here we must deal with the fact that error reporting works ;;;differently everywhere! ; PSL change (defmacro defstruct-error (message . args) `(stderror (list ,message . ,args))) ;#+PDP10 ;;;;first arg is ALWAYS a symbol or a quoted symbol: ;(defmacro defstruct-error (message &rest args) ; (let* ((chars (nconc (exploden (if (atom message) ; message ; (cadr message))) ; '(#/.))) ;"Bad frob" => "Bad frob." ; (new-message ; (maknam (if (null args) ; chars ; (let ((c (car chars))) ;"Bad frob." => "-- bad frob." ; (or (< c #/A) ; (> c #/Z) ; (rplaca chars (+ c #o40))) ; (append '(#/- #/- #\space) chars)))))) ; `(error ',new-message ; ,@(cond ((null args) `()) ; ((null (cdr args)) `(,(car args))) ; (t `((list ,@args))))))) ; ;#+Multics ;;;;first arg is ALWAYS a string: ;(defmacro defstruct-error (message &rest args) ; `(error ,(catenate "defstruct: " ; message ; (if (null args) ; "." ; ": ")) ; ,@(cond ((null args) `()) ; ((null (cdr args)) `(,(car args))) ; (t `((list ,@args)))))) ; ;#+LispM ;;;;first arg is ALWAYS a string: ;(defmacro defstruct-error (message &rest args) ; (do ((l args (cdr l)) ; (fs "") ; (na nil)) ; ((null l) ; `(ferror nil ; ,(string-append message ; (if (null args) ; "." ; (string-append ":" fs))) ; ,.(nreverse na))) ; (cond ((and (not (atom (car l))) ; (eq (caar l) 'quote) ; (symbolp (cadar l))) ; (setq fs (string-append fs " " (string-downcase (cadar l))))) ; (t ; (push (car l) na) ; (setq fs (string-append fs " ~S")))))) );End of eval-when (eval compile) ;;;If you mung the the ordering af any of the slots in this structure, ;;;be sure to change the version slot and the definition of the function ;;;get-defstruct-description. Munging the defstruct-slot-description ;;;structure should also cause you to change the version "number" in this manner. (defstruct (defstruct-description (:type :list) (:default-pointer description) (:conc-name defstruct-description-) (:alterant nil)) (version 'one) type (displace 'defstruct-dont-displace) slot-alist ; PSL change (named-p t) ; named-p constructors (default-pointer nil) (but-first nil) size (property-alist nil) ;;end of "expand-time" slots name include (initial-offset 0) (eval-when '(eval compile load)) alterant (conc-name nil) ; PSL change (callable-accessors nil) ; (callable-accessors #M nil #Q t) (size-macro nil) (size-symbol nil) ) (defun get-defstruct-description (name) (let ((description (get name 'defstruct-description))) (cond ((null description) (defstruct-error "A structure with this name has not been defined" name)) ((not (eq (defstruct-description-version) 'one)) (defstruct-error "The description of this structure is out of date, it should be recompiled using the current version of defstruct" name)) (t description)))) ;;;See note above defstruct-description structure before munging this one. (defstruct (defstruct-slot-description (:type :list) (:default-pointer slot-description) (:conc-name defstruct-slot-description-) (:alterant nil)) number (ppss nil) init-code (type 'notype) (property-alist nil) ref-macro-name ) ;;;Perhaps this structure wants a version slot too? (defstruct (defstruct-type-description (:type :list) (:default-pointer type-description) (:conc-name defstruct-type-description-) (:alterant nil)) ref-expander ref-no-args cons-expander cons-flavor (cons-keywords nil) (named-type nil) (overhead 0) (defstruct-expander nil) ) ;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>) ;; ;; <options> is of the form (<option> <option> (<option> <val>) ...) ;; ;; <slots> is of the form (<slot> (<slot> <initial-value>) ...) ;; ;; Options: ;; :TYPE defaults to HUNK ;; :CONSTRUCTOR defaults to "MAKE-<name>" ;; :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>") ;; :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-") ;; :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE") ;; :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE") ;; :ALTERANT defaults to "ALTER-<name>" ;; :BUT-FIRST must have a <val> given ;; :INCLUDE must have a <val> given ;; :PROPERTY (:property foo bar) gives the structure a foo property of bar. ;; :INITIAL-OFFSET can cause defstruct to skip over that many slots. ;; :NAMED takes no value. Tries to make the structure a named type. ;; :CALLABLE-ACCESSORS defaults to T on the LispMachine, NIL elsewhere. ;; <type> any type name can be used without a <val> instead of saying (TYPE <type>) ;; <other> any symbol with a non-nil :defstruct-option property. You say ;; (<other> <val>) and the effect is that of (:property <other> <val>) ;; ;; Properties used: ;; DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description. ;; DEFSTRUCT-NAME each constructor, alterant and size macro has one, it is a name. ;; DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below). ;; DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>) ;; :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as an ;; option giving the structure a FOO property of the value (which must be given). ; PSL change ;#Q ;(defprop defstruct "Structure" definition-type-name) ; PSL change (defmacro defstruct (options . items) ;(defmacro defstruct (options &body items) (let* ((description (defstruct-parse-options options)) (type-description (get (defstruct-description-type) 'defstruct-type-description)) (name (defstruct-description-name)) (new-slots (defstruct-parse-items items description)) (returns nil)) (push `',name returns) (or (null (defstruct-type-description-defstruct-expander)) (setq returns (append (funcall (defstruct-type-description-defstruct-expander) description) returns))) ; PSL change ; #Q (push `(record-source-file-name ',name 'defstruct) returns) (defstruct-putprop name description 'defstruct-description) (let ((alterant (defstruct-description-alterant)) (size-macro (defstruct-description-size-macro)) (size-symbol (defstruct-description-size-symbol))) (cond (alterant (defstruct-put-macro alterant 'defstruct-expand-alter-macro) (defstruct-putprop alterant name 'defstruct-name))) (cond (size-macro (defstruct-put-macro size-macro 'defstruct-expand-size-macro) (defstruct-putprop size-macro name 'defstruct-name))) (cond (size-symbol ; PSL change (push `(defvar ,size-symbol ; (push `(#M defvar #Q defconst ,size-symbol ,(+ (defstruct-description-size) (defstruct-type-description-overhead))) returns)))) ; PSL change old style DO (do ((cs (defstruct-description-constructors) (cdr cs))) ((null cs)) ; (do cs (defstruct-description-constructors) (cdr cs) (null cs) (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro) (defstruct-putprop (caar cs) name 'defstruct-name)) `(eval-when ,(defstruct-description-eval-when) ,.(defstruct-define-ref-macros new-slots description) . ,returns))) (defun defstruct-parse-options (options) (let ((name (if (atom options) options (car options))) (type nil) (constructors (make-empty)) (alterant (make-empty)) (included nil) (named-p nil) (but-first nil) (description (make-defstruct-description))) (setf (defstruct-description-name) name) (do ((op) (val) (vals) (options (if (atom options) nil (cdr options)) (cdr options))) ((null options)) (if (atom (setq op (car options))) (setq vals nil) (setq op (prog1 (car op) (setq vals (cdr op))))) (setq val (if (null vals) (make-empty) (car vals))) ; PSL change ; #Q AGAIN (selectq op (:type (if (emptyp val) (defstruct-error "The type option to defstruct must have a value given" name)) (setq type val)) (:default-pointer (setf (defstruct-description-default-pointer) (if (emptyp val) name val))) (:but-first (if (emptyp val) (defstruct-error "The but-first option to defstruct must have a value given" name)) (setq but-first val) (setf (defstruct-description-but-first) val)) (:conc-name (setf (defstruct-description-conc-name) (if (emptyp val) (append-symbols name '-) val))) (:callable-accessors (setf (defstruct-description-callable-accessors) (if (emptyp val) t val))) (:displace (setf (defstruct-description-displace) (cond ((or (emptyp val) (eq val 't)) 'displace) ((null val) 'defstruct-dont-displace) (t val)))) (:constructor (cond ((null val) (setq constructors nil)) (t (and (emptyp val) (setq val (append-symbols 'make- name))) (setq val (cons val (cdr vals))) (if (emptyp constructors) (setq constructors (list val)) (push val constructors))))) (:alterant (setq alterant val)) (:size-macro (setf (defstruct-description-size-macro) (if (emptyp val) ; PSL change (append-symbols name '\-size) ; (append-symbols name '-size) val))) (:size-symbol (setf (defstruct-description-size-symbol) (if (emptyp val) ; PSL change (append-symbols name '\-size) ; (append-symbols name '-size) val))) (:include (and (emptyp val) (defstruct-error "The include option to defstruct requires a value" name)) (setq included val) (setf (defstruct-description-include) vals)) (:property (push (cons (car vals) (if (null (cdr vals)) t (cadr vals))) (defstruct-description-property-alist))) (:named (or (emptyp val) (defstruct-error "The named option to defstruct doesn't take a value" name)) (setq named-p t)) (:eval-when (and (emptyp val) (defstruct-error "The eval-when option to defstruct requires a value" name)) (setf (defstruct-description-eval-when) val)) (:initial-offset (and (or (emptyp val) (not (fixp val))) (defstruct-error "The initial-offset option to defstruct requires a fixnum" name)) (setf (defstruct-description-initial-offset) val)) (otherwise (cond ((get op 'defstruct-type-description) (or (emptyp val) (defstruct-error "defstruct type used as an option with a value" op 'in name)) (setq type op)) ((get op ':defstruct-option) (push (cons op (if (emptyp val) t val)) (defstruct-description-property-alist))) (t ; PSL change ; #Q (multiple-value-bind (new foundp) ; (intern-soft op si:pkg-user-package) ; (or (not foundp) ; (eq op new) ; (progn (setq op new) (go AGAIN)))) (defstruct-error "defstruct doesn't understand this option" op 'in name)))))) (cond ((emptyp constructors) (setq constructors (list (cons (append-symbols 'make- name) nil))))) (setf (defstruct-description-constructors) constructors) (cond ((emptyp alterant) (setq alterant (append-symbols 'alter- name)))) (setf (defstruct-description-alterant) alterant) (cond ((not (null type)) (let ((type-description (or (get type 'defstruct-type-description) ; PSL change ; #Q (multiple-value-bind ; (new foundp) ; (intern-soft type si:pkg-user-package) ; (and foundp ; (not (eq type new)) ; (progn (setq type new) ; (get type 'defstruct-type-description)))) (defstruct-error "Unknown type in defstruct" type 'in name)))) (if named-p (setq type (or (defstruct-type-description-named-type) (defstruct-error "There is no way to make this defstruct type named" type 'in name))))))) (cond (included (let ((d (get-defstruct-description included))) (if (null type) (setq type (defstruct-description-type d)) (or (eq type (defstruct-description-type d)) (defstruct-error "defstruct types must agree for include option" included 'included 'by name))) (and named-p (not (eq type (defstruct-type-description-named-type (or (get type 'defstruct-type-description) (defstruct-error "Unknown type in defstruct" type 'in name 'including included))))) (defstruct-error "Included defstruct's type isn't a named type" included 'included 'by name)) (if (null but-first) (setf (defstruct-description-but-first) (defstruct-description-but-first d)) (or (equal but-first (defstruct-description-but-first d)) (defstruct-error "but-first options must agree for include option" included 'included 'by name))))) ((null type) (setq type (cond (named-p ; PSL change ':named-vector) ; #+PDP10 ':named-hunk ; #+Multics ':named-list ; #+LispM ':named-array) (t ':vector))))) ; #+PDP10 ':hunk ; #+Multics ':list ; #+LispM ':array))))) (let ((type-description (or (get type 'defstruct-type-description) (defstruct-error "Undefined defstruct type" type 'in name)))) (setf (defstruct-description-type) type) (setf (defstruct-description-named-p) (eq (defstruct-type-description-named-type) type))) description)) (defun defstruct-parse-items (items description) (let ((name (defstruct-description-name)) (offset (defstruct-description-initial-offset)) (include (defstruct-description-include)) (o-slot-alist nil) (conc-name (defstruct-description-conc-name))) (or (null include) (let ((d (get (car include) 'defstruct-description))) (setq offset (+ offset (defstruct-description-size d))) (setq o-slot-alist (subst nil nil (defstruct-description-slot-alist d))) (do ((l (cdr include) (cdr l)) (it) (val)) ((null l)) (cond ((atom (setq it (car l))) (setq val (make-empty))) (t (setq val (cadr it)) (setq it (car it)))) (let ((slot-description (cdr (assq it o-slot-alist)))) (and (null slot-description) (defstruct-error "Unknown slot in included defstruct" it 'in include 'included 'by name)) (setf (defstruct-slot-description-init-code) val))))) ; PSL change 1+ ==> add1 (do ((i offset (add1 i)) ; (do ((i offset (1+ i)) (l items (cdr l)) (slot-alist nil) ; PSL change ) ; #+PDP10 (chars (exploden conc-name))) ((null l) (setq slot-alist (nreverse slot-alist)) (setf (defstruct-description-size) i) (setf (defstruct-description-slot-alist) (nconc o-slot-alist slot-alist)) slot-alist) (cond ((atom (car l)) (push (defstruct-parse-one-field ; PSL change (car l) i nil nil conc-name) ; (car l) i nil nil conc-name #+PDP10 chars) slot-alist)) ((atom (caar l)) (push (defstruct-parse-one-field ; PSL change (caar l) i nil (cdar l) conc-name) ; (caar l) i nil (cdar l) conc-name #+PDP10 chars) slot-alist)) (t ; PSL change old style DO (do ((ll (car l) (cdr ll))) ((null ll)) ; (do ll (car l) (cdr ll) (null ll) (push (defstruct-parse-one-field (caar ll) i (cadar ll) ; PSL change (cddar ll) conc-name) ; (cddar ll) conc-name #+PDP10 chars) slot-alist))))))) ; PSL change (defun defstruct-parse-one-field (it number ppss rest conc-name) ;(defun defstruct-parse-one-field (it number ppss rest conc-name #+PDP10 chars) ; PSL change (let ((mname (if conc-name (intern (string-concat conc-name it)) ; (let ((mname (if conc-name #+PDP10 (implode (append chars (exploden it))) ; #+Multics (make_atom (catenate conc-name it)) ; #+LispM (intern (string-append conc-name it)) it))) ; PSL change bootstrap apparently doesn't work (cons it (let ((kludge (make-defstruct-slot-description))) (setf (defstruct-slot-description-number kludge) number) (setf (defstruct-slot-description-ppss kludge) ppss) (setf (defstruct-slot-description-init-code kludge) (if (null rest) (make-empty) (car rest))) (setf (defstruct-slot-description-ref-macro-name kludge) mname) kludge)))) ; (cons it (make-defstruct-slot-description ; number number ; ppss ppss ; init-code (if (null rest) (make-empty) (car rest)) ; ref-macro-name mname)))) (defun defstruct-define-ref-macros (new-slots description) (let ((name (defstruct-description-name)) (returns nil)) (if (not (defstruct-description-callable-accessors)) (do ((l new-slots (cdr l)) ; PSL change ; #Q (parent `(,name defstruct)) (mname)) ((null l)) (setq mname (defstruct-slot-description-ref-macro-name (cdar l))) (defstruct-put-macro mname 'defstruct-expand-ref-macro) (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot)) (let ((type-description (get (defstruct-description-type) 'defstruct-type-description))) (let ((code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (but-first (defstruct-description-but-first)) (default-pointer (defstruct-description-default-pointer))) (do ((args nil (cons (gensym) args)) ; PSL change 1- ==> sub1 (i n (sub1 i))) ; (i n (1- i))) ((< i 2) ;;Last arg (if it exists) is name of structure, ;; for documentation purposes. (and (= i 1) (setq args (cons name args))) (let ((body (cons (if but-first `(,but-first ,(car args)) (car args)) (cdr args)))) (and default-pointer (setq args `((,(car args) ,default-pointer) &optional . ,(cdr args)))) (setq args (reverse args)) (setq body (reverse body)) (do ((l new-slots (cdr l)) (mname)) ((null l)) (setq mname (defstruct-slot-description-ref-macro-name (cdar l))) ; PSL change ; #M ;;This must come BEFORE the defun. THINK! (defstruct-put-macro mname 'defstruct-expand-ref-macro) (let ((ref (lexpr-funcall code (defstruct-slot-description-number (cdar l)) description body)) (ppss (defstruct-slot-description-ppss (cdar l)))) ; PSL change (push `(defun ,mname ,args ; (push `(#M defun #Q defsubst-with-parent ,mname #Q ,parent ,args ,(if (null ppss) ref `(ldb ,ppss ,ref))) returns)) (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot)))))))) returns)) ; PSL change ;#Q ;(defprop defstruct-expand-cons-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-size-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-alter-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-ref-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defun defstruct-function-parent (sym) ; (values (or (get sym 'defstruct-name) ; (car (get sym 'defstruct-slot))) ; 'defstruct)) ; (defun defstruct-expand-size-macro (x) (let ((description (get-defstruct-description (get (car x) 'defstruct-name)))) (let ((type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type))))) (funcall (defstruct-description-displace) x (+ (defstruct-description-size) (defstruct-type-description-overhead)))))) (defvar defstruct-ref-macro-name) (defun defstruct-expand-ref-macro (x) (let* ((defstruct-ref-macro-name (car x)) (pair (get (car x) 'defstruct-slot)) (description (get-defstruct-description (car pair))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (args (reverse (cdr x))) (nargs (length args)) (default (defstruct-description-default-pointer)) (but-first (defstruct-description-but-first))) (cond ((= n nargs) (and but-first (rplaca args `(,but-first ,(car args))))) ; PSL change 1+ ==> add1 ((and (= n (add1 nargs)) default) ; ((and (= n (1+ nargs)) default) (setq args (cons (if but-first `(,but-first ,default) default) args))) (t (defstruct-error "Wrong number of args to an accessor macro" x))) (let* ((slot-description (cdr (or (assq (cdr pair) (defstruct-description-slot-alist)) (defstruct-error "This slot no longer exists in this structure" (cdr pair) 'in (car pair))))) (ref (lexpr-funcall code (defstruct-slot-description-number) description (nreverse args))) (ppss (defstruct-slot-description-ppss))) (funcall (defstruct-description-displace) x (if (null ppss) ref `(ldb ,ppss ,ref)))))) (defun defstruct-parse-setq-style-slots (l slots others x) (do ((l l (cddr l)) (kludge (cons nil nil))) ((null l) kludge) (or (and (cdr l) (symbolp (car l))) (defstruct-error "Bad argument list to constructor or alterant macro" x)) (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x))) (defun defstruct-make-init-dsc (kludge name code slots others x) (let ((p (assq name slots))) (if (null p) (if (memq name others) (push (cons name code) (cdr kludge)) (defstruct-error "Unknown slot to constructor or alterant macro" name 'in x)) (let* ((slot-description (cdr p)) (number (defstruct-slot-description-number)) (ppss (defstruct-slot-description-ppss)) (dsc (assoc number (car kludge)))) (cond ((null dsc) (setq dsc (list* number nil (make-empty) 0 0 nil)) (push dsc (car kludge)))) (cond ((null ppss) (setf (car (cddr dsc)) code) (setf (cadr dsc) t)) (t (cond ((and (numberp ppss) (numberp code)) (setf (ldb ppss (cadr (cddr dsc))) -1) (setf (ldb ppss (caddr (cddr dsc))) code)) (t (push (cons ppss code) (cdddr (cddr dsc))))) (or (eq t (cadr dsc)) (push name (cadr dsc))))))))) (defun defstruct-code-from-dsc (dsc) (let ((code (car (cddr dsc))) (mask (cadr (cddr dsc))) (bits (caddr (cddr dsc)))) (if (emptyp code) (setq code bits) (or (zerop mask) (setq code (if (numberp code) (boole 7 bits (boole 2 mask code)) (if (zerop (logand mask ; PSL change (next 2 lines) 1+ => add1, 1- => sub1 ; (1+ (logior mask (1- mask))))) ; (let ((ss (haulong (boole 2 mask (1- mask))))) (add1 (logior mask(sub1 mask))))) (let ((ss (haulong (boole 2 mask (sub1 mask))))) `(dpb ,(lsh bits (- ss)) ,(logior (lsh ss 6) ; PSL change (logand 8#77 ; (logand #o77 (- (haulong mask) ss))) ,code)) `(boole 7 ,bits (boole 2 ,mask ,code))))))) ; PSL change old style DO (do ((l (cdddr (cddr dsc)) (cdr l))) ((null l)) ; (do l (cdddr (cddr dsc)) (cdr l) (null l) (setq code `(dpb ,(cdar l) ,(caar l) ,code))) code)) (defun defstruct-expand-cons-macro (x) (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (slot-alist (defstruct-description-slot-alist)) (cons-keywords (defstruct-type-description-cons-keywords)) inits kludge (constructor-description (cdr (or (assq (car x) (defstruct-description-constructors)) (defstruct-error "This constructor is no longer defined for this structure" (car x) 'in (defstruct-description-name))))) (aux nil) (aux-init nil)) (if (null constructor-description) (setq kludge (defstruct-parse-setq-style-slots (cdr x) slot-alist cons-keywords x)) (prog (args l) (setq kludge (cons nil nil)) (setq args (cdr x)) (setq l (car constructor-description)) R (cond ((null l) (if (null args) (return nil) (go barf-tma))) ((atom l) (go barf)) ((eq (car l) '&optional) (go O)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go A)) ((null args) (go barf-tfa))) (defstruct-make-init-dsc kludge (pop l) (pop args) slot-alist cons-keywords x) (go R) O (and (null args) (go OD)) (pop l) (cond ((null l) (go barf-tma)) ((atom l) (go barf)) ((eq (car l) '&optional) (go barf)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go barf-tma))) (defstruct-make-init-dsc kludge (if (atom (car l)) (car l) (caar l)) (pop args) slot-alist cons-keywords x) (go O) OD (pop l) (cond ((null l) (return nil)) ((atom l) (go barf)) ((eq (car l) '&optional) (go barf)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go A))) (or (atom (car l)) (defstruct-make-init-dsc kludge (caar l) (cadar l) slot-alist cons-keywords x)) (go OD) S (and (atom (cdr l)) (go barf)) (defstruct-make-init-dsc kludge (cadr l) `(list . ,args) slot-alist cons-keywords x) (setq l (cddr l)) (and (null l) (return nil)) (and (atom l) (go barf)) (or (eq (car l) '&aux) (go barf)) A (pop l) (cond ((null l) (return nil)) ((atom l) (go barf)) ((atom (car l)) (push (car l) aux) (push (make-empty) aux-init)) (t (push (caar l) aux) (push (cadar l) aux-init))) (go A) barf (defstruct-error "Bad format for defstruct constructor arglist" `(,(car x) . ,(car constructor-description))) barf-tfa (defstruct-error "Too few arguments to constructor macro" x) barf-tma (defstruct-error "Too many arguments to constructor macro" x))) ; PSL change old style DO (do ((l slot-alist (cdr l))) ((null l)) ; (do l slot-alist (cdr l) (null l) (let* ((name (caar l)) (slot-description (cdar l)) (code (do ((aux aux (cdr aux)) (aux-init aux-init (cdr aux-init))) ((null aux) (defstruct-slot-description-init-code)) (and (eq name (car aux)) (return (car aux-init))))) (ppss (defstruct-slot-description-ppss))) (or (and (emptyp code) (null ppss)) (let* ((number (defstruct-slot-description-number)) (dsc (assoc number (car kludge)))) (cond ((null dsc) (setq dsc (list number nil (make-empty) 0 0)) (setq dsc (list* number nil (make-empty) 0 0 nil)) (push dsc (car kludge)))) (cond ((emptyp code)) ((eq t (cadr dsc))) ((null ppss) (and (emptyp (car (cddr dsc))) (setf (car (cddr dsc)) code))) ((memq name (cadr dsc))) ((and (numberp ppss) (numberp code)) (setf (ldb ppss (cadr (cddr dsc))) -1) (setf (ldb ppss (caddr (cddr dsc))) code)) (t (push (cons ppss code) (cdddr (cddr dsc))))))))) (selectq (defstruct-type-description-cons-flavor) (:list (do ((l nil (cons nil l)) ; PSL change 1- ==> sub1 (i (defstruct-description-size) (sub1 i))) ; (i (defstruct-description-size) (1- i))) ((= i 0) (setq inits l))) ; PSL change old style DO (do ((l (car kludge) (cdr l))) ((null l)) ; (do l (car kludge) (cdr l) (null l) ; PSL change incompatible NTH (setf (nth inits (add1 (caar l))) ; (setf (nth (caar l) inits) (defstruct-code-from-dsc (car l))))) (:alist (setq inits (car kludge)) ; PSL change old style DO (do ((l inits (cdr l))) ((null l)) ; (do l inits (cdr l) (null l) (rplacd (car l) (defstruct-code-from-dsc (car l))))) (otherwise (defstruct-error "Unknown constructor kind in this defstruct type" (defstruct-description-type)))) (funcall (defstruct-description-displace) x (funcall (defstruct-type-description-cons-expander) inits description (cdr kludge))))) (defun defstruct-expand-alter-macro (x) (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (ref-code (defstruct-type-description-ref-expander))) (or (= 1 (defstruct-type-description-ref-no-args)) (defstruct-error "Alterant macros cannot handle this defstruct type" (defstruct-description-type))) (do ((l (car (defstruct-parse-setq-style-slots (cddr x) (defstruct-description-slot-alist) nil x)) (cdr l)) (but-first (defstruct-description-but-first)) (body nil) (var (gensym)) (vars nil) (vals nil)) ((null l) (funcall (defstruct-description-displace) x `((lambda (,var) . ,(if (null vars) body `(((lambda ,vars . ,body) . ,vals)))) ,(if but-first `(,but-first ,(cadr x)) (cadr x))))) (let ((ref (funcall ref-code (caar l) description var))) (and (emptyp (car (cddr (car l)))) (setf (car (cddr (car l))) ref)) (let ((code (defstruct-code-from-dsc (car l)))) (if (null (cdr l)) (push `(setf ,ref ,code) body) (let ((sym (gensym))) (push `(setf ,ref ,sym) body) (push sym vars) (push code vals)))))))) (defmacro defstruct-define-type (type . options) (do ((options options (cdr options)) (op) (args) (type-description (make-defstruct-type-description)) (cons-expander nil) (ref-expander nil) (defstruct-expander nil)) ((null options) (or cons-expander (defstruct-error "No cons option in defstruct-define-type" type)) (or ref-expander (defstruct-error "No ref option in defstruct-define-type" type)) `(progn 'compile ,cons-expander ,ref-expander ,@(and defstruct-expander (list defstruct-expander)) (defprop ,type ,type-description defstruct-type-description))) (cond ((atom (setq op (car options))) (setq args nil)) (t (setq args (cdr op)) (setq op (car op)))) ; PSL change ;#Q AGAIN (selectq op (:cons (or (> (length args) 2) (defstruct-error "Bad cons option in defstruct-define-type" (car options) 'in type)) (let ((n (length (car args))) ; PSL change (name (append-symbols type '\-defstruct-cons))) ; (name (append-symbols type '-defstruct-cons))) (or (= n 3) (defstruct-error "Bad cons option in defstruct-define-type" (car options) 'in type)) (setf (defstruct-type-description-cons-flavor) #-LispM (cadr args) ; PSL change ) ; #+LispM (intern (string (cadr args)) si:pkg-user-package)) (setf (defstruct-type-description-cons-expander) name) (setq cons-expander `(defun ,name ,(car args) . ,(cddr args))))) (:ref (or (> (length args) 1) (defstruct-error "Bad ref option in defstruct-define-type" (car options) 'in type)) (let ((n (length (car args))) ; PSL change (name (append-symbols type '\-defstruct-ref))) ; (name (append-symbols type '-defstruct-ref))) (or (> n 2) (defstruct-error "Bad ref option in defstruct-define-type" (car options) 'in type)) (setf (defstruct-type-description-ref-no-args) (- n 2)) (setf (defstruct-type-description-ref-expander) name) (setq ref-expander `(defun ,name ,(car args) . ,(cdr args))))) (:overhead (setf (defstruct-type-description-overhead) (if (null args) (defstruct-error "Bad option to defstruct-define-type" (car options) 'in type) (car args)))) (:named (setf (defstruct-type-description-named-type) (if (null args) type (car args)))) (:keywords (setf (defstruct-type-description-cons-keywords) args)) (:defstruct (or (> (length args) 1) (defstruct-error "Bad defstruct option in defstruct-define-type" (car options) 'in type)) ; PSL change (let ((name (append-symbols type '\-defstruct-expand))) ; (let ((name (append-symbols type '-defstruct-expand))) (setf (defstruct-type-description-defstruct-expander) name) (setq defstruct-expander `(defun ,name . ,args)))) (otherwise ; PSL change ; #Q (multiple-value-bind (new foundp) ; (intern-soft op si:pkg-user-package) ; (or (not foundp) ; (eq op new) ; (progn (setq op new) (go AGAIN)))) (defstruct-error "Unknown option to defstruct-define-type" (car options) 'in type))))) ; PSL change ;#Q ;(defprop :make-array t :defstruct-option) ; ;(defstruct-define-type :array ; #Q (:named :named-array) ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc nil nil nil 1) ; #M (maclisp-array-for-defstruct arg description 't)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall t ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;#Q ;(defstruct-define-type :named-array ; (:keywords :make-array) ; :named (:overhead 1) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i))) ; description etc nil t nil 1)) ; (:ref (n description arg) ; description ;ignored ; `(aref ,arg ,(1+ n)))) ; ;(defstruct-define-type :fixnum-array ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc 'art-32b nil nil 1) ; #M (maclisp-array-for-defstruct arg description 'fixnum)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall fixnum ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;(defstruct-define-type :flonum-array ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc 'art-float nil nil 1) ; #M (maclisp-array-for-defstruct arg description 'flonum)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall flonum ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;#M ;(defstruct-define-type :un-gc-array ; (:cons ; (arg description etc) :alist ; etc ;ignored ; (maclisp-array-for-defstruct arg description 'nil)) ; (:ref ; (n description arg) ; description ;ignored ; `(arraycall nil ,arg ,n))) ; ;#Q ;(defstruct-define-type :array-leader ; (:named :named-array-leader) ; (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct arg #'(lambda (v a i) ; `(store-array-leader ,v ,a ,i)) ; description etc nil nil t 1)) ; (:ref ; (n description arg) ; description ;ignored ; `(array-leader ,arg ,n))) ; ;#Q ;(defstruct-define-type :named-array-leader ; (:keywords :make-array) ; :named (:overhead 1) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct ; arg ; #'(lambda (v a i) ; `(store-array-leader ,v ,a ,(if (zerop i) ; 0 ; (1+ i)))) ; description etc nil t t 1)) ; (:ref ; (n description arg) ; description ;ignored ; (if (zerop n) ; `(array-leader ,arg 0) ; `(array-leader ,arg ,(1+ n))))) ; ;#Q ;(defprop :times t :defstruct-option) ; ;#Q ;(defstruct-define-type :grouped-array ; (:keywords :make-array :times) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct ; arg ; #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc nil nil nil ; (or (cdr (or (assq ':times etc) ; (assq ':times (defstruct-description-property-alist)))) ; 1))) ; (:ref ; (n description index arg) ; description ;ignored ; (cond ((numberp index) ; `(aref ,arg ,(+ n index))) ; ((zerop n) ; `(aref ,arg ,index)) ; (t `(aref ,arg (+ ,n ,index)))))) ; ;#Q ;(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times) ; (let ((p (cons nil nil)) ; (no-op 'nil)) ; (defstruct-grok-make-array-args ; (cdr (assq ':make-array (defstruct-description-property-alist))) ; p) ; (defstruct-grok-make-array-args ; (cdr (assq ':make-array etc)) ; p) ; (and type (putprop p type ':type)) ; (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol)) ; (putprop p ; (let ((size (if named-p ; (1+ (defstruct-description-size)) ; (defstruct-description-size)))) ; (if (numberp times) ; (* size times) ; `(* ,size ,times))) ; (if leader-p ':leader-length ':dimensions)) ; (or leader-p ; (let ((type (get p ':type))) ; (or (atom type) ; (not (eq (car type) 'quote)) ; (setq type (cadr type))) ; (caseq type ; ((nil art-q art-q-list)) ; ((art-32b art-16b art-8b art-4b art-2b art-1b art-string) (setq no-op '0)) ; ((art-float) (setq no-op '0.0)) ; (t (setq no-op (make-empty)))))) ; (do ((creator ; (let ((dims (remprop p ':dimensions))) ; (do l (cdr p) (cddr l) (null l) ; (rplaca l `',(car l))) ; `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p)))) ; (var (gensym)) ; (set-ups nil (if (equal (cdar l) no-op) ; set-ups ; (cons (funcall cons-init (cdar l) var (caar l)) ; set-ups))) ; (l arg (cdr l))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator))))) ; ;#Q ;(defun defstruct-grok-make-array-args (args p) ; (let ((nargs (length args))) ; (if (and (not (> nargs 7)) ; (or (oddp nargs) ; (do ((l args (cddr l))) ; ((null l) nil) ; (or (memq (car l) '(:area :type :displaced-to :leader-list ; :leader-length :displaced-index-offset ; :named-structure-symbol :dimensions ; :length)) ; (return t))))) ; (do ((l args (cdr l)) ; (keylist '(:area :type :dimensions :displaced-to :old-leader-length-or-list ; :displaced-index-offset :named-structure-symbol) ; (cdr keylist))) ; ((null l) ; (and (boundp 'compiler:compiler-warnings-context) ; (boundp 'compiler:last-error-function) ; (not (null compiler:compiler-warnings-context)) ; (compiler:barf args '|-- old style :MAKE-ARRAY constructor keyword argument| ; 'compiler:warn)) ; p) ; (putprop p (car l) (car keylist))) ; (do ((l args (cddr l))) ; ((null l) p) ; (if (or (null (cdr l)) ; (not (memq (car l) '(:area :type :displaced-to :leader-list ; :leader-length :displaced-index-offset ; :named-structure-symbol :dimensions ; :length)))) ; (defstruct-error ; "defstruct can't grok these make-array arguments" ; args)) ; (putprop p ; (cadr l) ; (if (eq (car l) ':length) ; ':dimensions ; (car l))))))) ; ;#M ;(defun maclisp-array-for-defstruct (arg description type) ; (do ((creator `(array nil ,type ,(defstruct-description-size))) ; (var (gensym)) ; (no-op (caseq type ; (fixnum 0) ; (flonum 0.0) ; ((t nil) nil))) ; (set-ups nil (if (equal (cdar l) no-op) ; set-ups ; (cons `(store (arraycall ,type ,var ,(caar l)) ; ,(cdar l)) ; set-ups))) ; (l arg (cdr l))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator)))) ; ;#+PDP10 ;(defprop :sfa-function t :defstruct-option) ; ;#+PDP10 ;(defprop :sfa-name t :defstruct-option) ; ;#+PDP10 ;(defstruct-define-type :sfa ; (:keywords :sfa-function :sfa-name) ; (:cons ; (arg description etc) :alist ; (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc) ; (assq ':sfa-function (defstruct-description-property-alist)))) ; `',(defstruct-description-name)) ; ,(defstruct-description-size) ; ,(or (cdr (or (assq ':sfa-name etc) ; (assq ':sfa-name (defstruct-description-property-alist)))) ; `',(defstruct-description-name)))) ; (l arg (cdr l)) ; (var (gensym)) ; (set-ups nil (if (null (cdar l)) ; set-ups ; (cons `(sfa-store ,var ,(caar l) ; ,(cdar l)) ; set-ups)))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator)))) ; (:ref ; (n description arg) ; description ;ignored ; `(sfa-get ,arg ,n))) ; ;#+PDP10 ;(defstruct-define-type :hunk ; (:named :named-hunk) ; (:cons ; (arg description etc) :list ; description ;ignored ; etc ;ignored ; (if arg ; `(hunk . ,(nconc (cdr arg) (ncons (car arg)))) ; (defstruct-error "No slots in hunk type defstruct"))) ; (:ref ; (n description arg) ; description ;ignored ; `(cxr ,n ,arg))) ; ;#+PDP10 ;(defstruct-define-type :named-hunk ; :named (:overhead 1) ; (:cons ; (arg description etc) :list ; etc ;ignored ; (if arg ; `(hunk ',(defstruct-description-name) ; . ,(nconc (cdr arg) (ncons (car arg)))) ; `(hunk ',(defstruct-description-name) nil))) ; (:ref ; (n description arg) ; description ;ignored ; (cond ((= n 0) `(cxr 0 ,arg)) ; (t `(cxr ,(1+ n) ,arg))))) ; ; PSL change ;#+(or PDP10 NIL) (defstruct-define-type :vector (:named :named-vector) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ,@arg)) (:ref (n description arg) description ;ignored `(vref ,arg ,n))) ;added for PSL (defstruct-define-type :named-vector (:keywords :make-vector) :named (:overhead 1) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ',(defstruct-description-name) ,@arg)) (:ref (n description arg) description ;ignored `(vref ,arg ,(add1 n)))) ;#+(or PDP10 NIL) ;;;;Do this (much) better someday: ;(defstruct-define-type :extend ; :named ; (:defstruct (description) ; (and (defstruct-description-include) ; (error "--structure of type extend cannot include another." ; (defstruct-description-name))) ; (let* ((name (defstruct-description-name)) ; (ica-name (append-symbols 'internal-cons-a- name)) ; (v-slots nil)) ; (do ((i (defstruct-description-size) (1- i))) ; ((zerop i)) ; (push (do ((l (defstruct-description-slot-alist) (cdr l)) ; (n (1- i))) ;; ((null l) (let ((base 10.) ; (*nopoint t)) ; (implode (cons #/# (exploden n))))) ; (let ((slot-description (cdar l))) ; (and (= (defstruct-slot-description-number) n) ; (null (defstruct-slot-description-ppss)) ; (return (caar l))))) ; v-slots)) ; (push (cons 'extend-internal-conser ica-name) ; (defstruct-description-property-alist)) ; `((defvst (,name (no-selector-macros) (constructor ,ica-name)) ; ,@v-slots)))) ; (:cons (arg description etc) alist ; etc ;ignored ; (do ((alist arg (cdr alist)) ; (var (gensym)) ; (name (defstruct-description-name)) ; (conser `(,(cdr (assq 'extend-internal-conser ; (defstruct-description-property-alist))))) ; (inits nil (if (null (cdar alist)) ; inits ; (cons `(setf (|defvst-reference-by-name/|| ; ,name ,(caar alist) ,conser ,var) ; ,(cdar alist)) ; inits)))) ; ((null alist) ; (if (null inits) ; conser ; `((lambda (,var) ; ,.inits ; ,var) ; ,conser))))) ; (:ref (n description arg) ; `(|defvst-reference-by-name/|| ; ,(defstruct-description-name) ,n ,defstruct-ref-macro-name ,arg))) ; (defstruct-define-type :list (:named :named-list) (:cons (arg description etc) :list description ;ignored etc ;ignored `(list . ,arg)) (:ref (n description arg) description ;ignored #+Multics `(,(let ((i (\ n 4))) (cond ((= i 0) 'car) ((= i 1) 'cadr) ((= i 2) 'caddr) (t 'cadddr))) ,(do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(add1 n)))) ; #-Multics `(nth ,n ,arg))) (defstruct-define-type :named-list :named (:overhead 1) (:cons (arg description etc) :list etc ;ignored `(list ',(defstruct-description-name) . ,arg)) (:ref (n description arg) description ;ignored ; #+Multics `(,(let ((i (\ (1+ n) 4))) ; (cond ((= i 0) 'car) ; ((= i 1) 'cadr) ; ((= i 2) 'caddr) ; (t 'cadddr))) ; ,(do ((a arg `(cddddr ,a)) ; (i (// (1+ n) 4) (1- i))) ; ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(+ n 2)))) ; #-Multics `(nth ,(1+ n) ,arg))) (defstruct-define-type :list* (:cons (arg description etc) :list description ;ignored etc ;ignored `(list* . ,arg)) (:ref (n description arg) ; PSL change 1- ==> sub1 (let ((size (sub1 (defstruct-description-size)))) ; (let ((size (1- (defstruct-description-size)))) #+Multics (do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) (let* ((i (\ n 4)) (a (cond ((= i 0) a) ((= i 1) `(cdr ,a)) ((= i 2) `(cddr ,a)) (t `(cdddr ,a))))) (if (< n size) `(car ,a) a)))) #-Multics (if (< n size) ; PSL change incompatible NTH `(nth ,arg ,(add1 n)) `(pnth ,arg ,(add1 n))))) ; `(nth ,n ,arg) ; `(nthcdr ,n ,arg)))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type list* cannot include another" (defstruct-description-name))) nil)) (defstruct-define-type :tree (:cons (arg description etc) :list etc ;ignored (if (null arg) (defstruct-error "defstruct cannot make an empty tree" (defstruct-description-name))) (make-tree-for-defstruct arg (defstruct-description-size))) (:ref (n description arg) (do ((size (defstruct-description-size)) (a arg) (tem)) (()) (cond ((= size 1) (return a)) ; PSL change // ==> / ((< n (setq tem (/ size 2))) ; ((< n (setq tem (// size 2))) (setq a `(car ,a)) (setq size tem)) (t (setq a `(cdr ,a)) (setq size (- size tem)) (setq n (- n tem)))))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type tree cannot include another" (defstruct-description-name))) nil)) (defun make-tree-for-defstruct (arg size) (cond ((= size 1) (car arg)) ((= size 2) `(cons ,(car arg) ,(cadr arg))) (t (do ((a (cdr arg) (cdr a)) ; PSL change // ==> /, 1- ==> sub1 (m (/ size 2)) (n (sub1 (/ size 2)) (sub1 n))) ; (m (// size 2)) ; (n (1- (// size 2)) (1- n))) ((zerop n) `(cons ,(make-tree-for-defstruct arg m) ,(make-tree-for-defstruct a (- size m)))))))) ;(defstruct-define-type :fixnum ; (:cons ; (arg description etc) :list ; etc ;ignored ; (and (or (null arg) ; (not (null (cdr arg)))) ; (defstruct-error ; "Structure of type fixnum must have exactly 1 slot to be constructable" ; (defstruct-description-name))) ; (car arg)) ; (:ref ; (n description arg) ; n ;ignored ; description ;ignored ; arg)) ; #+Multics (defprop :external-ptr t :defstruct-option) #+Multics (defstruct-define-type :external (:keywords :external-ptr) (:cons (arg description etc) :alist (let ((ptr (cdr (or (assq ':external-ptr etc) (assq ':external-ptr (defstruct-description-property-alist)) (defstruct-error "No pointer given for external array" (defstruct-description-name)))))) (do ((creator `(array nil external ,ptr ,(defstruct-description-size))) (var (gensym)) (alist arg (cdr alist)) (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist)) ,(cdar alist)) inits))) ((null alist) (if (null inits) creator `((lambda (,var) ,.inits ,var) ,creator)))))) (:ref (n description arg) description ;ignored `(arraycall fixnum ,arg ,n))) ;(defvar *defstruct-examine&deposit-arg*) ; ;(defun defstruct-examine (*defstruct-examine&deposit-arg* ; name slot-name) ; (eval (list (defstruct-slot-description-ref-macro-name ; (defstruct-examine&deposit-find-slot-description ; name slot-name)) ; '*defstruct-examine&deposit-arg*))) ; ;(defvar *defstruct-examine&deposit-val*) ; ;(defun defstruct-deposit (*defstruct-examine&deposit-val* ; *defstruct-examine&deposit-arg* ; name slot-name) ; (eval (list 'setf ; (list (defstruct-slot-description-ref-macro-name ; (defstruct-examine&deposit-find-slot-description ; name slot-name)) ; '*defstruct-examine&deposit-arg*) ; '*defstruct-examine&deposit-val*))) ;#Q ;(defun defstruct-get-locative (*defstruct-examine&deposit-arg* ; name slot-name) ; (let ((slot-description (defstruct-examine&deposit-find-slot-description ; name slot-name))) ; (or (null (defstruct-slot-description-ppss)) ; (defstruct-error ; "You cannot get a locative to a byte field" ; slot-name 'in name)) ; (eval (list 'locf ; (list (defstruct-slot-description-ref-macro-name) ; '*defstruct-examine&deposit-arg*))))) ; ;(defun defstruct-examine&deposit-find-slot-description (name slot-name) ; (let ((description (get-defstruct-description name))) ; (let ((slot-description ; (cdr (or (assq slot-name (defstruct-description-slot-alist)) ; (defstruct-error ; "No such slot in this structure" ; slot-name 'in name)))) ; (type-description ; (or (get (defstruct-description-type) 'defstruct-type-description) ; (defstruct-error ; "Undefined defstruct type" ; (defstruct-description-type))))) ; (or (= (defstruct-type-description-ref-no-args) 1) ; (defstruct-error ; "defstruct-examine and defstruct-deposit cannot handle structures of this type" ; (defstruct-description-type))) ; slot-description))) ; ; PSL change ;#+PDP10 ;(defprop defstruct ; #.(and (status feature PDP10) ; (caddr (truename infile))) ; version) ; ;(sstatus feature defstruct) |
Added psl-1983/3-1/util/numeric-operators.sl version [b372c6aa47].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Numeric-Operators.SL - Definitions of Numeric Operators with "Fast" Option % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 7 January 1983 (based on the earlier Fast-Int module) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Edit by Cris Perdue, 7 Mar 1983 1131-PST % Redefined + and * to take any number of arguments. % This involved defining exprs fast-plus and fast-times. % Added an error check to - and / % WARNING: + and * are no longer exprs. Code using this module and COMPILED % with the fast-integers switch set to NIL will not work until it is % recompiled. /csp % Note: This must be LOAD, not IMPORTS. Common also defines +, others. /csp (BothTimes (load common useful)) % This file defines a set of C-like numeric operators that are a superset of the % numeric operators defined by the Common Lisp compatibility package. % The operators are: % % = Numeric Equal % /= Numeric Not Equal (common lisp) % ~= Numeric Not Equal (CLU) % < Numeric Less Than % > Numeric Greater Than % <= Numeric Less Than or Equal % >= Numeric Greater Than or Equal % + Numeric Addition % - Numeric Minus or Subtraction % * Numeric Multiplication % / Numeric Division % // Numeric Remainder % ~ Integer Bitwise Logical Not % & Integer Bitwise Logical And % | Integer Bitwise Logical Or % ^ Integer Bitwise Logical Xor % << Integer Bitwise Logical Left Shift % >> Integer Bitwise Logical Right Shift % +, -, *, and / are defined as in Common LISP, but when compiled they % do open-coded arithmetic only, just like all the other operators. % The arithmetic relational operators all take exactly 2 arguments, % unlike the genuine Common LISP versions. % The switch FAST-INTEGERS controls an option that provides for an efficient % compiled implementation of these operators using Syslisp arithmetic. When the % switch is on, uses of these operators will compile into the corresponding % Syslisp arithmetic operators, which generally are open-compiled and fast. % However, the Syslisp operators perform machine arithmetic on untagged % integers: they will work only if their inputs are untagged integers, and they % produce untagged integer outputs. The (undocumented) functions Int2Sys and % Sys2Int can be used to convert between tagged Lisp integers and Syslisp % integers; however, no conversion is needed to convert between INUMs and % Syslisp integers within the valid range of INUMs. % This module modifies the FOR macro to use the numeric operators to implement % the FROM clause; thus, the FOR statement will use Syslisp arithmetic when the % FAST-INTEGERS switch is on. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The Implementation: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generic definitions of functions defined in the Common Lisp package: (de = (a b) (EqN a b)) (de < (a b) (LessP a b)) (de > (a b) (GreaterP a b)) (de <= (a b) (LEq a b)) (de >= (a b) (GEq a b)) (defmacro + args (cond ((null args) 0) ((null (rest args)) (first args)) ((null (cddr args)) `(fast-plus ,@args)) (t (left-expand args 'fast-plus)))) (defmacro * args (cond ((null args) 1) ((null (rest args)) (first args)) ((null (cddr args)) `(fast-times ,@args)) (t (left-expand args 'fast-times)))) (defmacro - args (cond ((null args) (stderror "No args supplied to ""-""")) ((null (cdr args)) `(fast-minus ,@args)) ((null (cddr args)) `(fast-difference ,@args)) (t (left-expand args 'fast-difference)))) (defmacro / args (cond ((null args) (stderror "No args supplied to ""/""")) ((null (cdr args)) `(recip ,(car args))) ((null (cddr args)) `(fast-quotient ,@args)) (t (left-expand args 'fast-quotient)))) % Generic definitions of functions not defined by the Common Lisp package: (de ~= (a b) (not (EqN a b))) (de fast-plus (a b) (Plus a b)) (de fast-times (a b) (Times a b)) (de fast-minus (a) (Minus a)) (de fast-difference (a b) (Difference a b)) (de fast-quotient (a b) (Quotient a b)) (de // (a b) (Remainder a b)) (de ~ (a) (LNot a)) (de & (a b) (LAnd a b)) (de | (a b) (LOr a b)) (de ^ (a b) (LXor a b)) (de << (a b) (LShift a b)) (de >> (a b) (LShift a (Minus b))) % Enable and Disable "fast" compiled definitions: (fluid '(*fast-integers)) (put 'fast-integers 'simpfg '((T (enable-fast-numeric-operators)) (NIL (disable-fast-numeric-operators)) )) (de enable-fast-numeric-operators () (put '= 'cmacro '(lambda (a b) (WEQ a b))) (put '/= 'cmacro '(lambda (a b) (WNEQ a b))) (put '~= 'cmacro '(lambda (a b) (WNEQ a b))) (put '< 'cmacro '(lambda (a b) (WLessP a b))) (put '> 'cmacro '(lambda (a b) (WGreaterP a b))) (put '<= 'cmacro '(lambda (a b) (WLEQ a b))) (put '>= 'cmacro '(lambda (a b) (WGEQ a b))) (put 'fast-plus 'cmacro '(lambda (a b) (WPlus2 a b))) (put 'fast-difference 'cmacro '(lambda (a b) (WDifference a b))) (put 'fast-minus 'cmacro '(lambda (a) (WDifference 0 a))) (put 'fast-times 'cmacro '(lambda (a b) (WTimes2 a b))) (put 'fast-quotient 'cmacro '(lambda (a b) (WQuotient a b))) (put '// 'cmacro '(lambda (a b) (WRemainder a b))) (put '~ 'cmacro '(lambda (a) (WNot a))) (put '& 'cmacro '(lambda (a b) (WAnd a b))) (put '| 'cmacro '(lambda (a b) (WOr a b))) (put '^ 'cmacro '(lambda (a b) (WXor a b))) (put '<< 'cmacro '(lambda (a b) (WShift a b))) (put '>> 'cmacro '(lambda (a b) (WShift a (WDifference 0 b)))) ) (de disable-fast-numeric-operators () (remprop '= 'cmacro) (remprop '/= 'cmacro) (remprop '~= 'cmacro) (remprop '< 'cmacro) (remprop '> 'cmacro) (remprop '<= 'cmacro) (remprop '>= 'cmacro) (remprop '+ 'cmacro) (remprop 'fast-difference 'cmacro) (remprop 'fast-minus 'cmacro) (remprop '* 'cmacro) (remprop 'fast-quotient 'cmacro) (remprop '// 'cmacro) (remprop '~ 'cmacro) (remprop '& 'cmacro) (remprop '| 'cmacro) (remprop '^ 'cmacro) (remprop '<< 'cmacro) (remprop '>> 'cmacro) ) % Here we redefine the FROM clause of FOR statements: (fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions* for-body* for-epilogue* for-result*)) (de for-from-function (clause) (let* ((var (car clause)) (var1 (if (pairp var) (car var) var)) (clause (cdr clause)) (init (if (pairp clause) (or (pop clause) 1) 1)) (fin (if (pairp clause) (pop clause) nil)) (fin-var (if (and fin (not (numberp fin))) (gensym) nil)) (step (if (pairp clause) (car clause) 1)) (step-var (if (and step (not (numberp step))) (gensym) nil))) (tconc for-vars* (list* var init (cond (step-var `((+ ,var1 ,step-var))) ((zerop step) nil) ((onep step) `((+ ,var1 1))) ((eqn step -1) `((- ,var1 1))) (t `((+ ,var1 ,step)))))) (if fin-var (tconc for-vars* `(,fin-var ,fin))) (if step-var (tconc for-vars* `(,step-var ,step))) (cond (step-var (tconc for-tests* `(if (< ,step-var 0) (< ,var1 ,(or fin-var fin)) (> ,var1 ,(or fin-var fin))))) ((null fin)) ((minusp step) (tconc for-tests* `(< ,var1 ,(or fin-var fin)))) (t (tconc for-tests* `(> ,var1 ,(or fin-var fin))))))) |
Added psl-1983/3-1/util/objects.sl version [b50da80015].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Objects.SL - A simple facility for object-oriented programming. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 July 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Add ev-send function. Rename declare and undeclare to declare-flavor % and undeclare-flavor, to avoid conflict with common lisp declare. % 30-Dec-82 Alan Snyder % General clean-up; rename internal functions and variables; document % method lookup functions; add method lookup trace facility. % 1-Nov-82 Alan Snyder % Added Object-Type function. % 27-Sept-82 Alan Snyder % Removed Variable-Table (which was available only at compile-time); made % Variable-Names available at both compile-time and load-time; now use % Variable-Names to "compile" method bodies. Result: now can compile new % method bodies after loading a "compiled" flavor definition. % 27-Sept-82 Alan Snyder % Evaluating (or loading) a DEFFLAVOR no longer clears the method table, if it % had been defined previously. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (Bothtimes (imports '(common fast-vector))) (imports '(association strings)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NOTE: THIS FILE DEFINES MACROS. IT MUST BE LOADED BEFORE ANY OF THESE % FUNCTIONS ARE USED. The recommended way to do this is to put the statement % (BothTimes (load objects)) at the beginning of your source file. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Summary of Public Functions: % % (defflavor flavor-name (var1 var2 ...) (flav1 flav2 ...) option1 option2 ...) % (defmethod (flavor-name message-name) (arg1 arg2 ...) form1 form2 ...) % % (make-instance 'flavor-name 'var1 value1 ...) % % (=> foo message-name arg1 arg2 ...) % % (send foo 'message-name arg1 arg2 ...) % (lexpr-send foo 'message-name arg1 arg2 ... rest-arg-list) % (lexpr-send-1 foo 'message-name arg-list) % (ev-send foo 'message-name arg-list) {EXPR form} % % (send-if-handles foo 'message-name arg1 arg2 ...) % (lexpr-send-if-handles foo 'message-name arg1 arg2 ... rest-arg-list) % (lexpr-send-1-if-handles foo 'message-name arg-list) % % (instantiate-flavor 'flavor-name init-list) % % (object-type x) --- returns the type of an object, or NIL if not an object % % (object-get-handler x message-name) -- lookup method function (see below) % (object-get-handler-quietly x message-name) % % (trace-method-lookups) - start recording stats about method lookup % (untrace-method-lookups) - stop recording stats about method lookup % (print-method-lookup-info) - untrace and print accumulated stats % % (declare-flavor flavor var1 var2 ...) NOTE: see warnings below! % (undeclare-flavor var1 var2 ...) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Constants, Fluids, and Macros (mere mortals should ignore these) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '($defflavor-expansion-context $object-number-of-reserved-slots $object-flavor-slot $object-debug-slot $defflavor-option-table $method-lookup-stats )) (setf $defflavor-expansion-context NIL) (BothTimes (progn (setf $object-number-of-reserved-slots 2) (setf $object-flavor-slot 0) (setf $object-debug-slot 1) )) (setf $defflavor-option-table (list (cons 'gettable-instance-variables '$defflavor-do-gettable-option) (cons 'settable-instance-variables '$defflavor-do-settable-option) (cons 'initable-instance-variables '$defflavor-do-initable-option) )) % Note the free variable FLAVOR-NAME in this macro: (defmacro $defflavor-error (format . arguments) `(ContinuableError 1000 (BldMsg ,(string-concat "DEFFLAVOR %w: " format) flavor-name . ,arguments) NIL)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DEFFLAVOR - Define a new flavor of Object % % Examples: % % (defflavor complex-number (real-part imaginary-part) ()) % % (defflavor complex-number (real-part imaginary-part) () % gettable-instance-variables % initable-instance-variables % ) % % (defflavor complex-number ((real-part 0.0) % (imaginary-part 0.0) % ) % () % gettable-instance-variables % (settable-instance-variables real-part) % ) % % An object is represented by a vector; instance variables are allocated % specific slots in the vector. Do not use names like "IF" or "WHILE" for % instance varibles: they are translated freely within method bodies (see % DEFMETHOD). Initial values for instance variables may be specified as % arguments to MAKE-INSTANCE, or as initializing expressions in the variable % list, or may be supplied by an INIT method (see MAKE-INSTANCE). % Uninitializied instance variables are bound to *UNBOUND*. % % The component flavor list currently must be null. Recognized options are: % % (GETTABLE-INSTANCE-VARIABLES var1 var2 ...) % (SETTABLE-INSTANCE-VARIABLES var1 var2 ...) % (INITABLE-INSTANCE-VARIABLES var1 var2 ...) % GETTABLE-INSTANCE-VARIABLES [make all instance variables GETTABLE] % SETTABLE-INSTANCE-VARIABLES [make all instance variables SETTABLE] % INITABLE-INSTANCE-VARIABLES [make all instance variables INITABLE] % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro defflavor (flavor-name variable-list flavor-list . options-list) (prog (var-names % List of valid instance variable names init-code % body of DEFAULT-INIT method describe-code % body of DESCRIBE method defmethod-list % list of created DEFMETHODs var-options % AList mapping var names to option list initable-vars % list of INITABLE instance variables ) (desetq (var-names init-code) ($defflavor-process-varlist flavor-name variable-list) ) (setf describe-code ($defflavor-build-describe flavor-name var-names)) (setf var-options ($defflavor-process-options-list flavor-name var-names options-list) ) (setf defmethod-list ($defflavor-create-methods flavor-name var-options)) (setf initable-vars ($defflavor-initable-vars flavor-name var-options)) (put flavor-name 'variable-names var-names) (setf defmethod-list (cons `(defmethod (,flavor-name default-init) () . ,init-code) defmethod-list)) (setf defmethod-list (cons `(defmethod (,flavor-name describe) () . ,describe-code) defmethod-list)) (if flavor-list ($defflavor-error "Component Flavors not implemented") ) % The previous actions happen at compile or dskin time. % The following actions happen at dskin or load time. (return `(progn (if (not (get ',flavor-name 'method-table)) (put ',flavor-name 'method-table (association-create))) (put ',flavor-name 'instance-vector-size ,(+ #.$object-number-of-reserved-slots (length var-names))) (put ',flavor-name 'variable-names ',var-names) (put ',flavor-name 'initable-variables ',initable-vars) ,@defmethod-list '(flavor ,flavor-name) % for documentation only )) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DEFMETHOD - Define a method on an existing flavor. % % Examples: % % (defmethod (complex-number real-part) () % real-part) % % (defmethod (complex-number set-real-part) (new-real-part) % (setf real-part new-real-part)) % % The body of a method can freely refer to the instance variables of the flavor % and can set them using SETF. Each method defines a function FLAVOR$METHOD % whose first argument is SELF, the object that is performing the method. All % references to instance variables (except within vectors or quoted lists) are % translated to an invocation of the form (IGETV SELF n). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro defmethod ((flavor-name method-name) argument-list . body) (setf argument-list (cons 'self argument-list)) (let ((function-name ($defflavor-function-name flavor-name method-name))) (put function-name 'source-code `(lambda ,argument-list . ,body)) (let ((new-code ($create-method-source-code function-name flavor-name))) % The previous actions happen at compile or dskin time. % The following actions happen at dskin or load time. `(progn ($flavor-define-method ',flavor-name ',method-name ',function-name) (putd ',function-name 'expr ',new-code) '(method ,flavor-name ,method-name) % for documentation only )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % => - Convenient form for sending a message % % Examples: % % (=> r real-part) % % (=> r set-real-part 1.0) % % The message name is not quoted. Arguments to the method are supplied as % arguments to =>. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro => (object message-name . arguments) `(send ,object ',message-name . ,arguments)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SEND - Send a Message (Evaluated Message Name) % % Examples: % % (send r 'real-part) % % (send r 'set-real-part 1.0) % % Note that the message name is quoted. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro send (target-form method-form . argument-forms) % If the method name is known at compile time (i.e., the method-form is of % the form (QUOTE <id>)) and the target is either SELF (within the body of a % DEFMETHOD) or a variable which has been declared (using DECLARE-FLAVOR), % then optimize the form to a direct invocation of the method function. (if (and (PairP method-form) (eq (car method-form) 'quote) (not (null (cdr method-form))) (IdP (cadr method-form)) ) (let ((method-name (cadr method-form))) (cond ((and (eq target-form 'self) $defflavor-expansion-context) ($self-send-expansion method-name argument-forms)) ((and (IdP target-form) (get target-form 'declared-type)) ($direct-send-expansion target-form method-name argument-forms)) (t ($normal-send-expansion target-form method-form argument-forms)) )) ($normal-send-expansion target-form method-form argument-forms) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SEND-IF-HANDLES - Conditionally Send a Message (Evaluated Message Name) % % Examples: % % (send-if-handles r 'real-part) % % (send-if-handles r 'set-real-part 1.0) % % SEND-IF-HANDLES is like SEND, except that if the object defines no method % to handle the message, no error is reported and NIL is returned. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro send-if-handles (object message-name . arguments) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF*** ,@arguments))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND - Send a Message (Explicit "Rest" Argument List) % % Examples: % % (lexpr-send foo 'bar a b c list) % % The last argument to LEXPR-SEND is a list of the remaining arguments. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send (object message-name . arguments) (if arguments (let ((explicit-args (reverse (cdr (reverse arguments)))) (last-arg (LastCar arguments)) ) (if explicit-args `(lexpr-send-1 ,object ,message-name (append (list ,@explicit-args) ,last-arg)) `(lexpr-send-1 ,object ,message-name ,last-arg) ) ) `(let ((***SELF*** ,object)) (apply (object-get-handler ***SELF*** ,message-name) (list ***SELF***))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-IF-HANDLES % % This is the same as LEXPR-SEND, except that no error is reported % if the object fails to handle the message. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-if-handles (object message-name . arguments) (if arguments (let ((explicit-args (reverse (cdr (reverse arguments)))) (last-arg (LastCar arguments)) ) (if explicit-args `(lexpr-send-1-if-handles ,object ,message-name (append (list ,@explicit-args) ,last-arg)) `(lexpr-send-1-if-handles ,object ,message-name ,last-arg) ) ) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF***)))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-1 - Send a Message (Explicit Argument List) % % Examples: % % (lexpr-send-1 r 'real-part nil) % % (lexpr-send-1 r 'set-real-part (list 1.0)) % % Note that the message name is quoted and that the argument list is passed as a % single argument to LEXPR-SEND-1. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-1 (object message-name argument-list) `(let ((***SELF*** ,object)) (apply (object-get-handler ***SELF*** ,message-name) (cons ***SELF*** ,argument-list)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % EV-SEND - EXPR form of LEXPR-SEND-1 % % EV-SEND is just like LEXPR-SEND-1, except that it is an EXPR instead of % a MACRO. Its sole purpose is to be used as a run-time function object, % for example, as a function argument to a function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de ev-send (obj msg arg-list) (lexpr-send-1 obj msg arg-list) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-1-IF-HANDLES % % This is the same as LEXPR-SEND-1, except that no error is reported if the % object fails to handle the message. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-1-if-handles (object message-name argument-list) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (cons ***SELF*** ,argument-list))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MAKE-INSTANCE - Create a new instance of a flavor. % % Examples: % % (make-instance 'complex-number) % (make-instance 'complex-number 'real-part 0.0 'imaginary-part 1.0) % % MAKE-INSTANCE accepts an optional initialization list, consisting of % alternating pairs of instance variable names and corresponding initial values. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro make-instance (flavor-name . init-plist) `(instantiate-flavor ,flavor-name (list . ,init-plist) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % INSTANTIATE-FLAVOR % % This is the same as MAKE-INSTANCE, except that the initialization list is % provided as a single (required) argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun instantiate-flavor (flavor-name init-plist) (let* ((vector-size (get flavor-name 'instance-vector-size))) (if vector-size (let* ((object (MkVect (- vector-size 1))) ) (setf (igetv object #.$object-flavor-slot) flavor-name) (setf (igetv object #.$object-debug-slot) NIL) (for (from i #.$object-number-of-reserved-slots (- vector-size 1) 1) (do (iputv object i '*UNBOUND*)) ) ($object-perform-initialization object init-plist) (send-if-handles object 'default-init) (send-if-handles object 'init init-plist) object ) (ContError 0 "Attempt to instantiate undefined flavor: %w" flavor-name (Instantiate-Flavor flavor-name init-plist)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Object-Type % % The OBJECT-TYPE function returns the type (an ID) of the specified object, or % NIL, if the argument is not an object. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun object-type (object) (if (and (VectorP object) (> (UpbV object) 1)) (let ((flavor-name (igetv object #.$object-flavor-slot))) (if (IdP flavor-name) flavor-name) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Method Lookup % % The following functions return method functions given an object and a message % name. The returned function can be invoked, passing the object as the first % argument and the message arguments as the remaining arguments. For example, % the expression (=> foo gorp a b c) is equivalent to: % % (apply (object-get-handler foo 'gorp) (list foo a b c)) % % It can be useful for efficiency reasons to lookup a method function once and % then apply it many times to the same object. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun object-get-handler (object message-name) % Returns the method function that implements the specified message when sent % to the specified object. If no such method exists, generate a continuable % error. (let ((flavor-name (object-type object))) (cond (flavor-name (let ((function-name ($flavor-fetch-method flavor-name message-name))) (or function-name (ContError 1000 "Flavor %w has no method %w." flavor-name message-name (object-get-handler object message-name) )))) (t (ContError 1000 "Object %w cannot receive messages." object (object-get-handler object message-name) ))))) (defun object-get-handler-quietly (object message-name) % Returns the method function that implements the specified message when sent % to the specified object, if it exists, otherwise returns NIL. (let ((flavor-name (object-type object))) (if flavor-name ($flavor-fetch-method flavor-name message-name)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Method Lookup Tracing % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de trace-method-lookups () % Begin accumulating information about method lookups (invocations of % object-get-handler). The statistics are reset. (setf $method-lookup-stats (association-create)) (copyd 'object-get-handler '$traced-object-get-handler) ) (de untrace-method-lookups () % Stop accumulating information about method lookups. (copyd 'object-get-handler '$untraced-object-get-handler) ) (de print-method-lookup-info () % Stop accumulating information about method lookups and print a summary of % the accumulated information about method lookups. This summary shows which % methods were looked up and how many times each method was looked up. (untrace-method-lookups) (load gsort stringx) (setf $method-lookup-stats (gsort $method-lookup-stats '$method-info-sortfn)) (for (in pair $method-lookup-stats) (do (printf "%w %w%n" (string-pad-left (bldmsg "%w" (cdr pair)) 6) (car pair)))) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DECLARE-FLAVOR % % *** Read these warnings carefully! *** % % The DECLARE-FLAVOR macro allows you to declare that a specific symbol is % bound to an object of a specific flavor. This allows the flavors % implementation to eliminate the run-time method lookup normally associated % with sending a message to that variable, which can result in an appreciable % improvement in execution speed. This feature is motivated solely by % efficiency considerations and should be used ONLY where the performance % improvement is critical. % % Details: if you declare the variable X to be bound to an object of flavor % FOO, then WITHIN THE CONTEXT OF THE DECLARATION (see below), expressions of % the form (=> X GORP ...) or (SEND X 'GORP ...) will be replaced by function % invocations of the form (FOO$GORP X ...). Note that there is no check made % that the flavor FOO actually contains a method GORP. If it does not, then a % run-time error "Invocation of undefined function FOO$GORP" will be reported. % % WARNING: The DECLARE-FLAVOR feature is not presently well integrated with % the compiler. Currently, the DECLARE-FLAVOR macro may be used only as a % top-level form, like the PSL FLUID declaration. It takes effect for all % code evaluated or compiled henceforth. Thus, if you should later compile a % different file in the same compiler, the declaration will still be in % effect! THIS IS A DANGEROUS CROCK, SO BE CAREFUL! To avoid problems, I % recommend that DECLARE-FLAVOR be used only for uniquely-named variables. % The effect of a DECLARE-FLAVOR can be undone by an UNDECLARE-FLAVOR, which % also may be used only as a top-level form. Therefore, it is good practice % to bracket your code in the source file with a DECLARE-FLAVOR and a % corresponding UNDECLARE-FLAVOR. % % Here are the syntactic details: % % (DECLARE-FLAVOR FLAVOR-NAME VAR1 VAR2 ...) % (UNDECLARE-FLAVOR VAR1 VAR2 ...) % % *** Did you read the above warnings??? *** % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro declare-flavor (flavor-name . variable-names) (prog () % This macro returns NIL! (if (not (IdP flavor-name)) (StdError (BldMsg "Flavor name in DECLARE-FLAVOR is not an ID: %p" flavor-name)) % else (for (in var-name variable-names) (do (if (not (IdP var-name)) (StdError (BldMsg "Variable name in DECLARE-FLAVOR is not an ID: %p" var-name)) % else (put var-name 'declared-type flavor-name) ))) ))) (dm undeclare-flavor (form) (prog () % This macro returns NIL! (for (in var-name (cdr form)) (do (if (not (IdP var-name)) (StdError (BldMsg "Variable name in UNDECLARE-FLAVOR is not an ID: %p" var-name)) % else (remprop var-name 'declared-type) ))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Representation Information: % % (You don't need to know any of this to use this stuff.) % % A flavor-name is an ID. It has the following properties: % % VARIABLE-NAMES A list of the instance variables of the flavor, in % order of their location in the instance vector. This % property exists at compile time, dskin time, and load % time. % % INITABLE-VARIABLES A list of the instance variables that have been declared % to be INITABLE. This property exists at dskin time and % at load time. % % METHOD-TABLE An association list mapping each method name (ID) % defined for the flavor to the corresponding function % name (ID) that implements the method. This property % exists at dskin time and at load time. % % INSTANCE-VECTOR-SIZE An integer that specifies the number of elements in the % vector that represents an instance of this flavor. This % property exists at dskin time and at load time. It is % used by MAKE-INSTANCE. % % The function that implements a method has a name of the form FLAVOR$METHOD. % Each such function ID has the following properties: % % SOURCE-CODE A list of the form (LAMBDA (SELF ...) ...) which is the % untransformed source code for the method. This property % exists at compile time and dskin time. % % Implementation Note: % % A tricky aspect of this code is making sure that the right things happen at % the right time. When a source file is read and evaluated (using DSKIN), then % everything must happen at once. However, when a source file is compiled to % produce a FASL file, then some actions must be performed at compile-time, % whereas other actions are supposed to occur when the FASL file is loaded. % Actions to occur at compile time are performed by macros; actions to occur at % load time are performed by the forms returned by macros. % % Another goal of the implementation is to avoid consing whenever possible % during method invocation. The current scheme prefers to compile into (APPLY % HANDLER (LIST args...)), for which the PSL compiler will produce code that % performs no consing. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun $object-perform-initialization (object init-plist) % Perform the initialization of instance variables in OBJECT as specified by % the INIT-PLIST, which contains alternating instance variable names and % initializing values. (let* ((flavor-name (igetv object #.$object-flavor-slot)) (initable-vars (get flavor-name 'initable-variables)) (variable-names (get flavor-name 'variable-names)) name value ) (while init-plist (setf name (car init-plist)) (setf init-plist (cdr init-plist)) (if init-plist (progn (setf value (car init-plist)) (setf init-plist (cdr init-plist))) (setf value nil) ) (if (memq name initable-vars) (iputv object ($object-lookup-variable-in-list variable-names name) value) (ContinuableError 1000 (BldMsg "%p not an initable instance variable of flavor %w" name flavor-name) NIL) )))) (defun $object-lookup-variable-in-list (variable-names name) (for (in v-name variable-names) (for i #.$object-number-of-reserved-slots (+ i 1)) (do (if (eq v-name name) (exit i))) (returns nil) )) (defun $substitute-for-symbols (U var-names) % Substitute in U for all unquoted instances of the symbols defined in % Var-Names. Also, change SETQ to SETF in forms, since only SETF can handle % the substituted forms. (cond ((IdP U) (let ((address ($object-lookup-variable-in-list var-names U))) (if address (list 'igetv 'self address) U) )) ((PairP U) (cond ((eq (car U) 'quote) U) ((eq (car U) 'setq) (cons 'setf ($substitute-for-symbols (cdr U) var-names))) (t (cons ($substitute-for-symbols (car U) var-names) ($substitute-for-symbols (cdr U) var-names))) ) ) (t U) )) (defun $flavor-define-method (flavor-name method-name function-name) (let ((method-table (get flavor-name 'method-table))) (association-bind method-table method-name function-name))) (copyd 'flavor-define-method '$flavor-define-method) % for compatibility! (defun $flavor-fetch-method (flavor-name method-name) % Returns NIL if the method is undefined. (let* ((method-table (get flavor-name 'method-table)) (assoc-pair (atsoc method-name method-table)) ) (if assoc-pair (cdr assoc-pair) nil))) (defun $create-method-source-code (function-name flavor-name) (let ((var-names (get flavor-name 'variable-names)) (source-code (get function-name 'source-code)) ($defflavor-expansion-context flavor-name) % FLUID variable! ) ($substitute-for-symbols (MacroExpand source-code) var-names) )) (defun $defflavor-process-varlist (flavor-name variable-list) % Process the instance variable list of a DEFFLAVOR. Create a list of valid % instance variable names and a list of forms to perform default % initialization of instance variables. (prog (var-names default-init-code init-form v) (for (in v-entry variable-list) (do (cond ((and (PairP v-entry) (IdP (car v-entry))) (setf v (car v-entry)) (setf init-form (cdr v-entry)) (if init-form (setf init-form (car init-form))) (setf init-form `(if (eq ,v '*UNBOUND*) (setf ,v ,init-form))) (setf default-init-code (aconc default-init-code init-form)) ) ((IdP v-entry) (setf v v-entry)) (t ($defflavor-error "Bad item in variable list: %p" v-entry) (setf v NIL) ) ) (if v (setf var-names (aconc var-names v))) )) (return (list var-names default-init-code)))) (defun $defflavor-build-describe (flavor-name var-names) % Return a list of forms that print a description of an instance. (let ((describe-code `((printf ,(string-concat "An object of flavor " (id2string flavor-name) ", has instance variable values:%n"))))) (for (in v var-names) (do (setf describe-code (aconc describe-code `(printf " %w: %p%n" ',v ,v))) )) (aconc describe-code NIL) )) (defun $defflavor-process-options-list (flavor-name var-names options-list) % Return an AList mapping var-names to a list of options (let ((var-options (association-create))) (for (in option options-list) (do ($defflavor-process-option flavor-name var-names var-options option) )) var-options )) (defun $defflavor-process-option (flavor-name var-names var-options option) % Process the option by modifying the AList VAR-OPTIONS. (let (option-keyword option-arguments) (cond ((PairP option) (setf option-keyword (car option)) (setf option-arguments (cdr option)) ) ((IdP option) (setf option-keyword option) ) (t ($defflavor-error "Bad item in options list: %p" option) (setf option-keyword '*NONE*) ) ) (when (neq option-keyword '*NONE*) (let ((pair (atsoc option-keyword $defflavor-option-table))) (if (null pair) ($defflavor-error "Bad option in options list: %w" option) (apply (cdr pair) (list flavor-name var-names var-options option-arguments)) ))))) (defun $defflavor-do-gettable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'GETTABLE) ) (defun $defflavor-do-settable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'SETTABLE) ) (defun $defflavor-do-initable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'INITABLE) ) (defun $defflavor-insert-keyword (flavor-name var-names var-options args key) (if (null args) (setf args var-names)) % default: applies to all variables (for (in var args) % for each specified instance variable (do (if (not (memq var var-names)) ($defflavor-error "%p (in keyword option) not a variable." var) % else (let ((pair (atsoc var var-options))) (when (null pair) (setf pair (cons var nil)) (aconc var-options pair) ) (setf (cdr pair) (adjoinq key (cdr pair))) ))))) (defun $defflavor-define-access-function (flavor-name var-name) `(defmethod (,flavor-name ,var-name) () ,var-name)) (defun $defflavor-define-update-function (flavor-name var-name) (let ((method-name (intern (string-concat "SET-" (id2string var-name))))) `(defmethod (,flavor-name ,method-name) (new-value) (setf ,var-name new-value)))) (defun $defflavor-create-methods (flavor-name var-options) % Return a list of DEFMETHODs for GETTABLE and SETTABLE instance variables. (let ((defmethod-list)) (for (in pair var-options) (do (let ((var-name (car pair)) (keywords (cdr pair)) ) (if (or (memq 'GETTABLE keywords) (memq 'SETTABLE keywords)) (setf defmethod-list (cons ($defflavor-define-access-function flavor-name var-name) defmethod-list ))) (if (memq 'SETTABLE keywords) (setf defmethod-list (cons ($defflavor-define-update-function flavor-name var-name) defmethod-list ))) ))) defmethod-list )) (defun $defflavor-initable-vars (flavor-name var-options) % Return a list containing the names of instance variables that have been % declared to be INITable. (for (in pair var-options) (when (and (PairP pair) (or (memq 'INITABLE (cdr pair)) (memq 'SETTABLE (cdr pair)) ))) (collect (car pair)) ) ) (de $defflavor-function-name (flavor-name method-name) (intern (string-concat (id2string flavor-name) "$" (id2string method-name)))) (de $normal-send-expansion (target-form method-form argument-forms) `(let ((***SELF*** ,target-form)) (apply (object-get-handler ***SELF*** ,method-form) (list ***SELF*** ,@argument-forms)))) (de $self-send-expansion (method-name argument-forms) (cons ($defflavor-function-name $defflavor-expansion-context method-name) (cons 'self argument-forms))) (de $direct-send-expansion (target-id method-name argument-forms) (let ((target-type (get target-id 'declared-type))) (cons ($defflavor-function-name target-type method-name) (cons target-id argument-forms)))) (copyd '$untraced-object-get-handler 'object-get-handler) (de $traced-object-get-handler (obj method-name) (let* ((result ($untraced-object-get-handler obj method-name)) (count (association-lookup $method-lookup-stats result)) ) (association-bind $method-lookup-stats result (if count (+ count 1) 1)) result )) (de $method-info-sortfn (m1 m2) (numbersortfn (cdr m2) (cdr m1)) ) |
Added psl-1983/3-1/util/old-prettyprint.sl version [e5c9189a19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %(!* YPP -- THE PRETTYPRINTER % % <BENSON>YPP.SL.19, 17-Sep-82 09:52:42, Edit by BENSON % Courtesy of IMSSS, with modifications for PSL % % %PP( LST:list ) FEXPR %PRETTYPRINT( X:any ) EXPR % %") (COMPILETIME (FLAG '(WARNING PP-VAL PP-DEF PP-DEF-1 BROKEN GET-GOOD-DEF S2PRINT SPRINT CHRCT SPACES-LEFT SAFE-PPOS PPFLATSIZE PP-SAVINGS POSN1 POSN2 PPOS) 'INTERNALFUNCTION)) (DE WARNING (X) (ERRORPRINTF "*** %L" X)) %(!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (X) (PROGN (SPRINT X 1) (TERPRI))) (DM PP (L) (LIST 'EVPP (LIST 'QUOTE (CDR L)))) (DE EVPP (L) (PROGN (MAPC L (FUNCTION PP1)) (TERPRI) T)) (DE PP1 (EXP) (PROG NIL (COND ((IDP EXP) (PROGN (PP-VAL EXP) (PP-DEF EXP))) (T (PROGN (SPRINT EXP 1) (TERPRI)))))) (DE PP-VAL (ID) (PROG (VAL) (COND ((ATOM (SETQ VAL (ERRORSET ID NIL NIL))) (RETURN NIL))) (TERPRI) (PRIN2 "(SETQ ") (PRIN1 ID) (S2PRINT " '" (CAR VAL)) (PRIN2 ")") (TERPRI))) (DE PP-DEF (ID) (PROG (DEF TYPE ORIG-DEF) (SETQ DEF (GETD ID)) TEST (COND ((NULL DEF) (RETURN (AND ORIG-DEF (WARNING (LIST "Gack. " ID " has no unbroken definition."))))) ((CODEP (CDR DEF)) (RETURN (WARNING (LIST "Can't PP compiled definition for" ID)))) ((AND (NOT ORIG-DEF) (BROKEN ID)) (PROGN (WARNING (LIST "Note:" ID "is broken or traced.")) (SETQ ORIG-DEF DEF) (SETQ DEF (CONS (CAR DEF) (GET-GOOD-DEF ID))) (GO TEST)))) (SETQ TYPE (CAR DEF)) (TERPRI) (SETQ ORIG-DEF (ASSOC TYPE '((EXPR . DE) (MACRO . DM) (FEXPR . DF) (NEXPR . DN)))) (RETURN (PP-DEF-1 (CDR ORIG-DEF) ID (CDDR DEF))))) (DE PP-DEF-1 (FN NAME TAIL) (PROGN (PRIN2 "(") (PRIN1 FN) (PRIN2 " ") (PRIN1 NAME) (PRIN2 " ") (COND ((NULL (CAR TAIL)) (PRIN2 "()")) (T (PRIN1 (CAR TAIL)))) (MAPC (CDR TAIL) (FUNCTION (LAMBDA (X) (S2PRINT " " X)))) (PRIN2 ")") (TERPRI))) (DE BROKEN (X) (GET X 'TRACE)) (DE GET-GOOD-DEF (X) (PROG (XX) (COND ((AND (SETQ XX (GET X 'TRACE)) (SETQ XX (ASSOC 'ORIGINALFN XX))) (RETURN (CDR XX)))))) %(!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (S EXP) (PROGN (OR (GREATERP (SPACES-LEFT) (PLUS (FLATSIZE2 S) (FLATSIZE EXP))) (TERPRI)) (PRIN2 S) (SPRINT EXP (ADD1 (POSN))))) (DE SPRINT (EXP LEFT-MARGIN) (PROG (ORIGINAL-SPACE NEW-SPACE CAR-EXP P-MACRO CADR-MARGIN ELT-MARGIN LBL-MARGIN SIZE) (COND ((ATOM EXP) (PROGN (SAFE-PPOS LEFT-MARGIN (FLATSIZE EXP)) (RETURN (PRIN1 EXP))))) (PPOS LEFT-MARGIN) (SETQ LEFT-MARGIN (ADD1 LEFT-MARGIN)) (SETQ ORIGINAL-SPACE (SPACES-LEFT)) (COND ((PAIRP (SETQ CAR-EXP (CAR EXP))) (PROGN (PRIN2 "(") (SPRINT CAR-EXP LEFT-MARGIN))) ((AND (IDP CAR-EXP) (SETQ P-MACRO (GET CAR-EXP 'PRINTMACRO))) (COND ((AND (STRINGP P-MACRO) (PAIRP (CDR EXP)) (NULL (CDDR EXP))) (PROGN (SAFE-PPOS (POSN1) (FLATSIZE2 P-MACRO)) (PRIN2 P-MACRO) (RETURN (AND (CDR EXP) (SPRINT (CADR EXP) (POSN1)))))) (T (PROGN (RETURN (APPLY P-MACRO (LIST EXP))))))) (T (PROGN (PRIN2 "(") (SAFE-PPOS (POSN1) (FLATSIZE CAR-EXP)) (PRIN1 CAR-EXP)))) (COND ((ATOM (SETQ EXP (CDR EXP))) (GO C))) (SETQ CADR-MARGIN (POSN2)) (SETQ NEW-SPACE (SPACES-LEFT)) (SETQ SIZE (PPFLATSIZE CAR-EXP)) (COND ((NOT (LESSP SIZE ORIGINAL-SPACE)) (SETQ CADR-MARGIN (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) ((OR (LESSP (PPFLATSIZE EXP) NEW-SPACE) (PROG (E1) (SETQ E1 EXP) LP (COND ((PAIRP (CAR E1)) (RETURN NIL)) ((ATOM (SETQ E1 (CDR E1))) (RETURN T)) (T (GO LP))))) (SETQ ELT-MARGIN (SETQ LBL-MARGIN NIL))) ((LESSP NEW-SPACE 24) (PROGN (COND ((NOT (AND (MEMQ CAR-EXP '(PROG LAMBDA SETQ)) (LESSP (PPFLATSIZE (CAR EXP)) NEW-SPACE))) (SETQ CADR-MARGIN LEFT-MARGIN))) (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) ((EQ CAR-EXP 'LAMBDA) (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN))) ((EQ CAR-EXP 'PROG) (PROGN (SETQ ELT-MARGIN CADR-MARGIN) (SETQ LBL-MARGIN LEFT-MARGIN))) ((OR (GREATERP SIZE 14) (AND (GREATERP SIZE 4) (NOT (LESSP (PPFLATSIZE (CAR EXP)) NEW-SPACE)))) (SETQ CADR-MARGIN (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) (T (SETQ ELT-MARGIN (SETQ LBL-MARGIN CADR-MARGIN)))) (COND ((ATOM (SETQ CAR-EXP (CAR EXP))) (PROGN (SAFE-PPOS CADR-MARGIN (PPFLATSIZE CAR-EXP)) (PRIN1 CAR-EXP))) (T (SPRINT CAR-EXP CADR-MARGIN))) A (COND ((ATOM (SETQ EXP (CDR EXP))) (GO C))) B (SETQ CAR-EXP (CAR EXP)) (COND ((ATOM CAR-EXP) (PROGN (SETQ SIZE (PPFLATSIZE CAR-EXP)) (COND (LBL-MARGIN (SAFE-PPOS LBL-MARGIN SIZE)) ((LESSP SIZE (SPACES-LEFT)) (PRIN2 " ")) (T (SAFE-PPOS LEFT-MARGIN SIZE))) (PRIN1 CAR-EXP))) (T (SPRINT CAR-EXP (COND (ELT-MARGIN ELT-MARGIN) (T (POSN2)))))) (GO A) C (COND (EXP (PROGN (COND ((LESSP (SPACES-LEFT) 3) (PPOS LEFT-MARGIN))) (PRIN2 " . ") (SETQ SIZE (PPFLATSIZE EXP)) (COND ((GREATERP SIZE (SPACES-LEFT)) (SAFE-PPOS LEFT-MARGIN SIZE))) (PRIN1 EXP)))) (COND ((LESSP (SPACES-LEFT) 1) (PPOS LEFT-MARGIN))) (PRIN2 ")"))) (PUT 'QUOTE 'PRINTMACRO "'") (PUT 'BACKQUOTE 'PRINTMACRO "`") (PUT 'UNQUOTE 'PRINTMACRO ",") (PUT 'UNQUOTEL 'PRINTMACRO ",@") (PUT 'UNQUOTED 'PRINTMACRO ",.") (PUT 'DE 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DM 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DF 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DN 'PRINTMACRO (FUNCTION PM-DEF)) (DE PM-DEF (FORM) (PP-DEF-1 (CAR FORM) (CADR FORM) (CDDR FORM))) (DE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES-LEFT NIL (SUB1 (CHRCT))) (DE SAFE-PPOS (N SIZE) (PROG (MIN-N) (SETQ MIN-N (SUB1 (DIFFERENCE (LINELENGTH NIL) SIZE))) (COND ((LESSP MIN-N N) (PROGN (OR (GREATERP MIN-N (POSN1)) (TERPRI)) (PPOS MIN-N))) (T (PPOS N))))) (DE PPFLATSIZE (EXP) (DIFFERENCE (FLATSIZE EXP) (PP-SAVINGS EXP))) (DE PP-SAVINGS (Y) (PROG (N) (COND ((ATOM Y) (RETURN 0)) ((AND (EQ (CAR Y) 'QUOTE) (CDR Y) (NOT (NUMBERP (CADR Y)))) (RETURN (PLUS 7 (PP-SAVINGS (CDR Y)))))) (SETQ N 0) LP (COND ((ATOM Y) (RETURN N))) (SETQ N (PLUS N (PP-SAVINGS (CAR Y)))) (SETQ Y (CDR Y)) (GO LP))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) |
Added psl-1983/3-1/util/package.build version [e60ae9d248].
> > | 1 2 | CompileTime load Syslisp; in "package.red"$ |
Added psl-1983/3-1/util/package.red version [4af7c710cd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PACKAGE.RED - Start of small package system % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Friday, 23 October 1981 % Copyright (c) 1981 University of Utah % % Idea is that Hierachical ObLists created % Permit Root at NIL, ie Forest Of Trees % CurrentPackage!* is Name of package % Structure [Name,Father,Getfn,PutFn,RemFn,MapFn] under 'Package % Have set of Localxxxx(s) and Pathxxxx(s) for % xxxx= InternP Intern RemOb MapObl % By Storing Functions, have possibility of different % Oblist models at each level (Abstract data Type for Local Obarray ) CompileTime << Lisp Procedure PACKAGE x; %. Called from Token reader NIL; % dummy % To chnge package >>; Fluid '(\CurrentPackage!* %. Start of Search Path \PackageNames!* %. List of ALL package names PackageCharacter!* %. Character prefix for package ); PackageCharacter!* := char !\; % used for output Global '(SymPak!* MaxSym!*); % Dummy Package Field, to be SYSLSP <<MaxSym!*:=8000; SymPak!*:=Mkvect MaxSym!*; MaxSym!*>>; Lisp procedure SymPak d; % Access SYPAK field SymPak!*[d]; Lisp procedure PutSymPak(d,v); SymPak!*[d]:=v; CompileTime Put('SymPak,'Assign!-op,'PutSymPak); % -Hook in GetFn,PutFn, RemFn and MapFn for \Global ------ CopyD('GlobalMapObl,'MapObl); Lisp Procedure \SetUpInitialPackage; Begin Put('\Global,'\Package, '[\Global NIL \GlobalLookup \GlobalInstall \GlobalRemove \GlobalMapObl]); % Package is [name of self, father, GetFn, PutFn,RemFn,MapFn] \PackageNames!* := '(\Global); \CurrentPackage!* := '\Global; End; CompileTime << Lisp Smacro Procedure PackageName x; x[0]; Lisp Smacro Procedure PackageFather x; x[1]; Lisp Smacro Procedure PackageGetFn x; x[2]; Lisp Smacro Procedure PackagePutFn x; x[3]; Lisp Smacro Procedure PackageRemFn x; x[4]; Lisp Smacro Procedure PackageMapFn x; x[5]; >>; \SetupInitialPackage(); Lisp Procedure \PackageP(Name); %. test if legal package IdP(Name) and Get(Name,'\Package); Lisp Procedure \CreateRawPackage(Name,Father, GetFn, PutFn, RemFn, MapFn); %. Build New Package Begin Scalar V; If \PackageP Name then return ErrorPrintF("*** %r is already a package",Name); If Not \PackageP Father then return ErrorPrintF("*** %r cant be Father package",Father); V:=Mkvect(5); V[0]:=Name; V[1]:=Father; V[2]:=GetFn; V[3]:=PutFn; V[4] := RemFn; V[5] := MapFn; \PackageNames!* := Name . \PackageNames!*; Put(Name,'\Package,V); Return V End; Lisp Procedure \SetPackage(Name); %. Change Default If \PackageP(Name) then <<%PrintF(" Pack: %r->%r %n",\CurrentPackage!*,Name); \CurrentPackage!*:=Name>> else if Null Name then \SetPackage('\Global) else \PackageError(Name); Lisp procedure \PackageError(Name); Error(99, LIST(Name, " Is not a Package ")); % Note that we have to cleanup to some default package if % there is an error during ID name reading: CopyD('UnSafeToken,'ChannelReadToken); Lisp Procedure SafeToken(Channel); (LAMBDA (\CurrentPackage!*); UnSafeToken(Channel)) (\CurrentPackage!*); CopyD('ChannelReadToken,'SafeToken); Lisp Procedure PACKAGE x; %. Called from Token reader \SetPackage x; % --- User Package Stuff % --- Simple Buck Hash, using PAIRs (could later use Blocks) lisp Procedure HashFn(S,Htab); begin scalar Len, HashVal; % Fold together a bunch of bits S := StrInf S; HashVal := 0; % from the first 28 characters of the Len := StrLen S; % string. if IGreaterP(Len, 25) then Len := 25; for I := 0 step 1 until Len do HashVal := ILXOR(HashVal, ILSH(StrByt(S, I), IDifference(25, I))); return IRemainder(HashVal, VecLen VecInf Htab); end; Lisp Procedure HashGetFn(S,Htab); %. See if String S is There % Htab is Vector of Buckets Begin Scalar H,Buk,Hashloc; If not StringP S then Return NonStringError(S,'HashGetFn); HashLoc:=HashFn(S,Htab); Buk:=Htab[HashLoc]; Loop: If Null Buk then return 0; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then return H; goto Loop; End; Lisp Procedure HashPutFn(S,Htab); %. Install String at HashLoc Begin Scalar H,TopBuk,Buk,HashLoc; If not StringP S then NonStringError(S,'HashPutFn); HashLoc :=HashFn(S,Htab); TopBuk:=Buk:=Htab[HashLoc]; Loop: If Null Buk then goto new; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then return H; goto Loop; New: S:=CopyString S; % So doesnt grab I/O buffer H:=NewID S; SymPak(ID2Int H) := CurrentPackage!*; TopBuk:= H . TopBuk; Htab[HashLoc] := TopBuk; Return H; End; Lisp Procedure HashRemFn(S,Htab); %. remove String if there Begin Scalar H,TopBuk,Buk,HashLoc; If not StringP S then Return NonStringError(S,'HashRemFn); HashLoc :=HashFn(S,Htab); TopBuk:=Buk:=Htab[HashLoc]; Loop: If Null Buk then return 0; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then goto Rem; goto Loop; Rem: Htab[HashLoc] :=DelQ(H,TopBuk); SymPak(ID2Int H) := NIL; Return H End; Lisp Procedure HashMapFn(F,Htab); Begin Scalar H,Buk,HashLoc,Hmax; Hmax:=UPBV Htab; For HashLoc:=0:Hmax do <<Buk:=Htab[HashLoc]; For each H in Buk do Apply(F, List H)>>; Return Hmax; End; % -------- Generic routines over hash tables % --- Local Only Lisp procedure LocalIntern S; %. Force Into Current Package If IDP S then return LocalIntern Id2String S else if not StringP S then NonStringError(S,'LocalIntern) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalInstall S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; % already there Return Apply(PackagePutFn P,list S); End; Lisp procedure LocalInternP S; %. Test in Current Package If IDP S then LocalInternP ID2String S else if not StringP S then NonStringError(S,'LocalInternP) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageGetFn P,list S); End; Lisp procedure LocalRemOb S; %. Remove from Current Package If IDP S then LocalRemob ID2String S else if not StringP S then NonStringError(S,'LocalRemob) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalRemove S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageRemFn P,list S); End; Lisp procedure LocalMapObl F; %. Force Into Current Package if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalMapObl F else begin scalar P; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageMapFn P,list F); End; % Over Full Tree From CurrentPackage!* Lisp procedure PathIntern S; %. Do in Current If not Internd If IDP S then PathIntern ID2String S else if not StringP S then NonStringError(S,'PathIntern) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalInstall S else begin scalar H,P; If IDP(H:=PathIntern1(S,CurrentPackage!*)) then return H; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackagePutFn P,list S); % Do it at top level end; Lisp Procedure PathIntern1(S,CurrentPackage!*); % Search Ancestor Chain if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; Return PathIntern1(S,PackageFather P); % try ancestor End; Lisp Procedure AlternatePathIntern S; begin scalar H; H:=PathInternP S; If IDP H then return H; return LocalIntern S; End; Lisp procedure PathInternP S; %. TEST if Interned on Path PathInternP1(S,CurrentPackage!*); Lisp Procedure PathInternP1(S,CurrentPackage!*); If IDP S then PathInternP1(ID2String S,CurrentPackage!*) else if not StringP S then NonStringError(S,'PathInternP) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; return PathInternP1(S,PackageFather P); % try ancestor End; Lisp procedure PathRemOb S; %. Remove First On Path PathRemOb1(S,CurrentPackage!*); Lisp Procedure PathRemOb1(S,CurrentPackage!*); If IDP S then PathRemOb1(ID2String S,CurrentPackage!*) else if not StringP S then NonStringError(S,'PathRemob) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalRemove S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageRemFn P,list S); If IDP H then return H; return PathRemob1(S,PackageFather P); % try ancestor End; Lisp procedure PathMapObl F; %. Full path PathMapObl1(F,CurrentPackage!*); Lisp procedure PathMapObl1(F,Pack); if Pack eq NIL or Pack eq '\Global then GlobalMapObl F else begin scalar P,H; P:=Get(Pack,'\Package); Apply(PackageMapFn P,list F); Return PathMapObl1(F,PackageFather P); End; % ---- Build default Htabs for Bucket Hashed Case Lisp Procedure \CreateHashedPackage(Name,Father,n); Begin Scalar Gf,Pf,Rf,Mf,G; G:=Gensym(); Set(G, Mkvect n); Gf:=Gensym(); Pf:=Gensym(); Rf:=Gensym(); Mf:=Gensym(); PutD(Gf,'Expr,LIST('Lambda,'(S),LIST('HashGetFn,'S,G))); PutD(Pf,'Expr,LIST('Lambda,'(S),LIST('HashPutFn,'S,G))); PutD(Rf,'Expr,LIST('Lambda,'(S),LIST('HashRemFn,'S,G))); PutD(Mf,'Expr,LIST('Lambda,'(F),LIST('HashMapFn,'F,G))); Return \CreateRawPackage(Name,Father,Gf,Pf,Rf,Mf); End; Lisp Procedure \CreatePackage(Name,Father); \CreateHashedPackage(Name,Father,100); % ------ OutPut Functions CopyD('OldCprin2,'ChannelPrin2); CopyD('OldCprin1,'ChannelPrin1); %/ Take Channel and Itm Lisp Procedure NewCprin1(Channel,Itm); If IDP Itm then Begin Scalar IDN,PN; IDN:=ID2Int Itm; PN:=SymPak IDN; If IDP PN and PN then <<NewCprin1(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>; OldCprin1(Channel,Itm); End else OldCprin1(Channel,Itm); Lisp Procedure NewCprin2(Channel,Itm); If IDP Itm then Begin Scalar IDN,PN; IDN:=ID2Int Itm; PN:=SymPak IDN; If IDP PN and PN then <<NewCprin2(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>; OldCprin2(Channel,Itm); End else OldCprin2(Channel,Itm); % ----- A simple Demo --------------- Procedure redef; Begin CopyD('Intern,'PathIntern ); CopyD('InternP,'PathInternP ); CopyD('RemOb ,'PathRemOb ); CopyD('MapObl ,'PathMapObl); CopyD('ChannelPrin1,'NewCPrin1); CopyD('ChannelPrin2,'NewCPrin2); end; CopyD('CachedGlobalLookup,'GlobalLookup); Procedure GlobalLookup S; <<LastLookedUp:=NIL; %/ Fix Cache Bug that always said YES CachedGlobalLookup S>>; CopyD('NonCopyInstall,'GlobalInstall); % Some Bug in this too, clobers string Procedure GlobalInstall(S); NonCopyInstall CopyString S; Redef(); \CreatePackage('\P1,'\Global); \CreatePackage('\P2,'\Global); end; |
Added psl-1983/3-1/util/parse-command-string.sl version [8fe170d992].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Parse-Command-String.SL - Parse Program Command String % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common fast-vector)) (de parse-command-string (s) % This procedure accepts a string and parses it into a sequence % of substrings separated by spaces. It is used to parse the % "command string" given to the PSL program when it is invoked. (let (s-list j (high (size s)) (i 0)) (while T % Scan for the beginning of an argument. (while (<= i high) (cond ((= (igets s i) (char space)) (setq i (+ i 1)) ) (t (exit))) ) (if (> i high) (exit)) % Scan for the end of the argument. (setq j i) (while (<= j high) (cond ((= (igets s j) (char space)) (exit) ) (t (setf j (+ j 1)))) ) (setq s-list (aconc s-list (substring s i j))) (setq i (+ j 1)) ) s-list)) |
Added psl-1983/3-1/util/parser-fix.red version [7ecf54b4d1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %7:51am Sunday, 4 April 1982 Some parser fixes. FLUID '(!*BREAK); procedure ParErr(x,y); Begin Scalar !*BREAK; % Turn off BREAK StdError(x); End; procedure ElseError x; ParErr("ELSE should appear only in IF statement",T); procedure ThenError x; ParErr("THEN should appear only in IF statement",T); DefineRop('THEN,4,ThenError); DefineRop('ELSE,4,ElseError); procedure DoError x; ParErr("DO should appear only in WHILE or FOR statements",T); procedure UntilError x; ParErr("UNTIL should appear only in REPEAT statement",T); DefineRop('Do,4,DoPError); DefineRop('Until,4,UntilMError); procedure SUMError x; ParErr("SUM should appear only in FOR statements",T); procedure STEPError x; ParErr("STEP should appear only in FOR statement",T); procedure ProductError x; ParErr("PRODUCT should appear only in FOR statement",T); DefineRop('STEP,4,STEPError); DefineRop('SUM,4,SUMError); DefineRop('PRODUCT,4,ProductError); procedure CollectError x; ParErr("COLLECT should appear only in FOR EACH statements",T); procedure CONCError x; ParErr("CONC should appear only in FOR EACH statement",T); procedure JOINError x; ParErr("JOIN should appear only in FOR EACH statement",T); DefineRop('CONC,4,CONCError); DefineRop('Collect,4,CollectError); DefineRop('JOIN,4,JOINError); % Parse Simple ATOM list SYMBOLIC PROCEDURE ParseAtomList(U,V,W); %. parse LIST of Atoms, maybe quoted % U=funcname, V=following Token, W=arg treatment BEGIN Scalar Atoms; IF V EQ '!*SEMICOL!* THEN RETURN ParErr("Missing AtomList after KEYWORD",T); L: Atoms:=V . Atoms; SCAN(); IF CURSYM!* eq '!*COMMA!* then <<V:=SCAN(); goto L>>; IF CURSYM!* eq '!*SEMICOL!* then Return <<OP := CURSYM!*; If W eq 'FEXPR then U . Reverse Atoms else LIST(U,MkQuotList Reverse Atoms)>>; ParErr("Expect only Comma delimeter in ParseAtomList",T); END; DefineRop('Load,NIL,ParseAtomList('Load,X,'Fexpr)); Definerop('A1,NIL,ParseAtomList('A0,X,'Expr)); Definerop('A2,NIL,ParseAtomList('A0,X,'FExpr)); procedure a0 x; print x; |
Added psl-1983/3-1/util/pathin.build version [b2b346730f].
> > | 1 2 | CompileTime load Useful; in "pathin.sl"$ |
Added psl-1983/3-1/util/pathin.sl version [5a2d0b39d4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PATHIN.SL - Rlisp IN function with a search path % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 July 1982 % Copyright (c) 1982 University of Utah % % PATHIN(filename-tail:string):none EXPR % % PATHIN allows the use of a directory search path with the Rlisp IN function. % The fluid variable PATHIN* should be a list of strings, which are directory % names. These will be successively concatenated onto the front of the % string argument to PATHIN until an existing file is found. If one is found, % IN will be invoked on the file. If not, a continuable error occurs. % E.g, if PATHIN* is ("" "/usr/src/cmd/psl/" "/u/smith/"), (pathin "foo.red") % will attempt to open "foo.red", then "/usr/src/cmd/psl/foo.red", and finally % "/u/smith/foo.red". (bothtimes (fluid '(pathin*))) (compiletime (flag '(pathin-aux) 'internalfunction)) (loadtime (flag '(pathin) 'ignore)) % just like IN, gets done while compiling (loadtime (if (null pathin*) (setq pathin* '("")))) % acts like IN until path is changed (de pathin (filename-tail) (pathin-aux filename-tail pathin*)) (de pathin-aux (filename-tail search-path-list) (if (null search-path-list) (conterror 99 "File not found in path" (pathin filename-tail)) (let ((test-file (concat (first search-path-list) filename-tail))) (if (filep test-file) (evin (list test-file)) (pathin-aux filename-tail (rest search-path-list)))))) |
Added psl-1983/3-1/util/pathnamex.sl version [26f1fb2159].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PathNameX.SL - Useful Functions involving Pathnames % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % Revised: 4 March 1983 % % 4-Mar-83 Alan Snyder % Added maybe-pathname function. % 4-Feb-83 Alan Snyder % Added pathname-without-name function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load pathnames)) (de maybe-pathname (x) % Attempt to convert X to a pathname. If not possible, return NIL. (let ((result (errset (pathname x) NIL))) (when (listp result) (car result)) )) (de pathname-without-name (pn) % Return a pathname like PN but with no NAME, TYPE, or VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) )) (de pathname-without-type (pn) % Return a pathname like PN but with no TYPE or VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) )) (de pathname-without-version (pn) % Return a pathname like PN but with no VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type (pathname-type pn) )) (de pathname-set-default-type (pn typ) % Return a pathname like PN, except that if PN specifies no TYPE, % then with type TYP and no version. (setf pn (pathname pn)) (cond ((not (pathname-type pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type typ )) (t pn))) (de pathname-set-type (pn typ) % Return a pathname like PN, except with type TYP and no version. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type typ )) |
Added psl-1983/3-1/util/pcheck.build version [219fc451ab].
> | 1 | in "pcheck.red"$ |
Added psl-1983/3-1/util/pcheck.red version [9d7eef5695].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>PCHECK.RED.3, 11-Oct-82 18:14:36, Edit by BENSON % Changed CATCH to *CATCH % A little program to check parens in a LISP file Fluid '(LastSexpr!*); procedure Pcheck F; begin scalar Chan,OldChan; LastSexpr!*:=NIL; Chan:=Open(F,'Input); OldChan:=RDS(Chan); !*Catch(NIL,Pcheck1()); Rds(OldChan); Close chan; % Printf("last Full S-expression%r%n",LastSexpr!*); end; %/ can we enable Line counter somehow? procedure Pcheck1(); Begin Scalar x; L: x:=Read(); if x eq !$EOF!$ then return NIL; LastSexpr!*:=x; PrintSome x; Goto L; End; procedure printsome x; <<Prinsomelevel(x,2,3);terpri()>>; procedure prinsomelevel(x,l1,l2); If not pairp x then <<prin1 x; prin2 " ">> else if l1 <=0 then prin2 " ... " else if l2 <=0 then prin2 " ... " else <<prin2 "("; prinsomelevel(car x,l1-1,l2); if null cdr x then prin2 ")" else if ListP cdr x then <<prinsomelevel(cdr x,l1,l2-1); prin2 ")">> else <<prin2 " . "; prinsomelevel(cdr x,l1,l2-1); prin2 ")">> >>; procedure ListP x; null x or (Pairp x and ListP cdr x); end; |
Added psl-1983/3-1/util/poly.build version [42a531fa5a].
> | 1 | in "poly.red"$ |
Added psl-1983/3-1/util/poly.red version [cd130098a1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Simple POLY, RAT AND ALG system, based on POLY by Fitch and Marti. % Edit by Cris Perdue, 28 Jan 1983 2045-PST % "Dipthong" -> "Diphthong", order of revision history reversed % Modified by GRISS, JUly 1982 for PSL % MORRISON again, March 1981. % Parses INFIX expressions to PREFIX, then SIMPlifies and PRINTs % Handles also PREFIX expressions % Parser modified by OTTENHEIMER % February 1981, to be left associative March 1981. % Further modified by MORRISON % October 1980. % Modifed by GRISS and GALWAY % September 1980. % 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 ********************** smacro procedure RATNUM X; % parts of Rational CAR X; smacro procedure RATDEN X; CDR X; smacro procedure MKRAT(X,Y); CONS(X,Y); smacro procedure POLTRM X; % parts of Poly CAR X; smacro procedure POLRED X; CDR X; smacro procedure MKPOLY(X,Y); CONS(X,Y); smacro procedure TRMPWR X; % parts of TERM CAR X; smacro procedure TRMCOEF X; CDR X; smacro procedure MKTERM(X,Y); CONS(X,Y); smacro procedure PWRVAR X; % parts of Poly CAR X; smacro procedure PWREXPT X; CDR X; smacro procedure MKPWR(X,Y); CONS(X,Y); smacro procedure POLVAR X; PWRVAR TRMPWR POLTRM X; smacro procedure POLEXPT X; PWREXPT TRMPWR POLTRM X; smacro procedure POLCOEF X; TRMCOEF POLTRM X; %*********************** Utility Routines ***************************** procedure VARP X; IDP X OR (PAIRP X AND IDP CAR X); %*********************** Entry Point ********************************** FLUID '(!*RBACKTRACE !*RECHO REXPRESSION!* !*RMESSAGE PromptString!* TOK!* CurrentScantable!* ); !*RECHO := NIL; % No echo of parse !*RMESSAGE := T; % Do Print messages procedure RAT(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; Prin2T "Canonical Rational Evaluator"; PromptString!*:="poly> "; ALGINIT(); CLEARTOKEN(); % Initialize scanner LOOP: VVV := ERRORSET('(RPARSE),T,!*RBACKTRACE); IF ATOM VVV THEN % What about resetting the Scanner? <<PRINT LIST('RATT, 'error, VVV); CLEARTOKEN();GO TO LOOP>>; REXPRESSION!* := CAR VVV; IF !*RECHO THEN PRINT LIST('parse,REXPRESSION!*); IF REXPRESSION!* EQ 'QUIT THEN << PRINT 'QUITTING; RETURN >>; ERRORSET('(RATPRINT (RSIMP REXPRESSION!*)),T,!*RBACKTRACE); GOTO LOOP END RAT; procedure ALGG(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; prin2t "non-canonical rational evaluator"; alginit(); promptstring!* := "poly> "; 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; procedure alginit(); %. called to init tables begin inittoken(); prin2t "quit; to exit"; 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; procedure cleartoken; nil; procedure inittoken; << AlgScantable!* := '[17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 Algdiphthong]; AlgScanTable!*[char '!+]:=11; AlgScanTable!*[char '!-]:=11; >>; procedure NTOKEN; Begin Scalar CurrentScantable!*; CurrentScanTable!* := AlgScanTable!*; TOK!* := RATOM(); Return Tok!*; End; 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 APPLY(Y,RSIMPL CDR X); Y:=PRESIMP X; % As "variable" ? IF ATOM Y OR NOT(X=Y) THEN RETURN RSIMP Y; RETURN RCREATE Y; END; procedure RSIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE RSIMP(CAR X) . RSIMPL CDR X; 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 APPLY(Y,RSIMPL CDR X); X:=PRESIMPL CDR X; IF (Y:=GET(OP,'PRESIMP)) THEN RETURN APPLY(Y,X); RETURN (OP . X); END; procedure PRESIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE PRESIMP(CAR X) . PRESIMPL CDR X; %**************** Simplification Routines for Rationals *************** procedure R!+(A,B); %. RAT addition IF RATDEN A = RATDEN B THEN %/ Risa MAKERAT(P!+(RATNUM A,RATNUM B),RATDEN A) ELSE MAKERAT(P!+(P!*(RATNUM A,RATDEN B), P!*(RATDEN A,RATNUM B)), P!*(RATDEN A,RATDEN B)); procedure R!-(A,B); %. RAT subtraction R!+(A,R!.NEG B); procedure R!.NEG A; %. RAT negation MKRAT(P!.NEG RATNUM A,RATDEN A); 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; procedure R!.RECIP A; %. RAT inverse IF RATNUM A=0 THEN ERROR(777,'(ZERO DIVISOR)) ELSE MKRAT(RATDEN A,RATNUM A); procedure R!/(A,B); %. RAT division R!*(A,R!.RECIP B); 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; 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) ) ) >>; 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))); 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; 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 ************* 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 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; IF POLEXPT A>POLEXPT B THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B)); RETURN MKPOLY(POLTRM B,P!+(POLRED B,A)) END; procedure PORDERP(A,B); %. POL variable ordering IF A EQ B THEN 0 ELSE IF ORDERP(A,B) THEN 1 ELSE -1; 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)); 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)); 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)); 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; procedure ZCONS A; %. Make single term POL CONS(A,0); procedure PCREATE1(X); %. Create POLY from Variable/KERNEL ZCONS(CONS(CONS(X,1),1)); 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))); 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; procedure NUMGCD(A,B); %. Numeric GCD IF A=0 THEN ABS B ELSE NUMGCD(REMAINDER(B,A),A); 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; 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; procedure DIVIDEOUT(A,B); %. POL exact division CAR PDIVIDE(A,B); 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; procedure P!-(A,B); %. POL subtract P!+(A,P!.NEG B); procedure P!.NEG(A); %. POL Negate IF NUMBERP A THEN -A ELSE CONS(CONS(CAAR A,P!.NEG CDAR A),P!.NEG CDR A); 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; 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 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; 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; 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; 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; 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; 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; procedure MKATOM X; % Use LIST('RCREATE, LIST('QUOTE,x)); if doing EVAL mode X; %******************* Printing Routines ******************************** 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 NIL 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; procedure RPREC!* X; %. T if there is no significant addition in X. ATOM X OR (NUMBERP POLRED X AND POLRED X = 0); 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)); procedure SIMPLE X; %. POL that doest need () ATOM X OR ((POLRED X=0) AND (POLEXPT X=1) AND (POLCOEF X =1)); 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; 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 procedure RAT2PRE X; %. RATIONAL to Prefix IF RATDEN X = 1 THEN POL2PRE RATNUM X ELSE LIST('QUOTIENT,POL2PRE RATNUM X, POL2PRE RATDEN X); 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; 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); procedure PWR2PRE X; %. Power to Prefix IF PWREXPT X = 1 THEN PWRVAR X ELSE LIST('EXPT,PWRVAR X,PWREXPT X); %. prefix Pretty print 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 APPLY(PRINOP,LIST(A,PARENS)); PRIN2(CAR A); PRINARGS CDR A; RETURN A; END; 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 '!)>>; procedure PREPRINT A; <<PREPRIN(A,NIL); TERPRI(); A>>; 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 '!)>>; procedure PLUSPRIN(A,PARENS); NARYPRIN('! !+! ,CDR A,PARENS); procedure DIFFERENCEPRIN(A,PARENS); NARYPRIN('! !-! ,CDR A,PARENS); procedure TIMESPRIN(A,PARENS); NARYPRIN('!*,CDR A,PARENS); procedure QUOTPRIN(A,PARENS); NARYPRIN('!/,CDR A,PARENS); procedure EXPPRIN(A,PARENS); NARYPRIN('!^,CDR A,PARENS); procedure OrderP(x,y); % ordering of ID's as VARS Id2int(x) <= Id2Int (y); End; |
Added psl-1983/3-1/util/pp.build version [d6c13af036].
> > | 1 2 | Compiletime Load Useful; in "pp.sl"$ |
Added psl-1983/3-1/util/pp.sl version [9d4cf73bfd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %(!* YPP -- THE PRETTYPRINTER % % <BENSON>YPP.SL.19, 17-Sep-82 09:52:42, Edit by BENSON % Courtesy of IMSSS, with modifications for PSL % % PP( LST:list ) FEXPR % PRETTYPRINT( X:any ) EXPR % % Revision History: % % April 4, 1983: Douglas % Take the words "cond" and "lambda" out of strings % so that they are not printed in the wrong case. % % March 17, 1983: Douglas % Patched bug introduced tuesday in let clause. % % March 15, 1983: Douglas % Modularized code for linear vertical lists. % Modified and simplified % special code for cond, do, do*, let, and let*. % % March 10, 1983: Douglas % Added dn to lists of functions specially printed. % (same as definitions of de,df,dm). Added a terpri % after printing function definitions. % % March 8, 1983: Douglas % Added a special feature to prettyprint lambda expression % in a more readable fashion. Added a line to load useful % when compiling. % % March 3, 1983: Douglas % Added line to load fast-int when compiling. % % Feb. 23, 1983 Douglas % Seperated the testing of specially treated test functions % and the printing of these special test functions to % eliminate a recursion problem with special forms in % the cdr slot. % % Feb. 10, 1983 Douglas Lanam % Fixed a bug where special list structures in the cdr position % were not handled correctly. % Also removed calls to the function "add" since this is not % a basic psl function. Replaced them with "plus". % % Feb. 8, 1983 Douglas Lanam % Fix of many numerous small bugs and some clean up of code. % % Feb. 5, 1983 MLG % Changed the nflatsize1 definition line to correct parens. % % Dec. 14, 1982 Douglas Lanam % Fixed bug with sprint-prog and sprint-lamdba, so that it % gets the correct left-margin for sub-expression. % % Dec. 13, 1982 Douglas Lanam % Removal of old code that put properties on 'de','df','dm', % than messed up prettyprint on expressions with that atom % in the car of the expression. Also handles prinlevel, and % prinlength. % Fix bug with '(quote x y). Taught system about labels in % progs and dos. Taught system about special forms: do,let, % de, df, dm, defmacro, and cond. % % November 1982 Douglas Lanam % Rewritten to be more compact, more modular, % and handle vectors. %") (compiletime (load useful fast-int)) (COMPILETIME (FLAG '(WARNING PP-VAL PP-DEF PP-DEF-1 BROKEN GET-GOOD-DEF S2PRINT sprint-dtpr sprint-vector sprint-read-macro read-macro-internal-sprint is-read-macrop handle-read-macros handle-special-list-structures check-if-room-for-and-back-indent nflatsize1 CHRCT SPACES-LEFT SAFE-PPOS POSN1 POSN2 PPOS) 'INTERNALFUNCTION)) (compiletime (fluid '(prinlength prinlevel sprint-level))) (setq sprint-level 0) (DE WARNING (X) (ERRORPRINTF "*** %L" X)) %(!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (X) (PROGN (SPRINT X (posn)) (TERPRI))) (DM PP (L) (LIST 'EVPP (LIST 'QUOTE (CDR L)))) (DE EVPP (L) (PROGN (MAPC L (FUNCTION PP1)) (TERPRI) T)) (DE PP1 (EXP) (PROG NIL (COND ((IDP EXP) (PROGN (PP-VAL EXP) (PP-DEF EXP))) (T (PROGN (SPRINT EXP 1) (TERPRI)))))) (DE PP-VAL (ID) (PROG (VAL) (COND ((ATOM (SETQ VAL (ERRORSET ID NIL NIL))) (RETURN NIL))) (TERPRI) (sprint `(setq ,id ',(car val)) (posn)) (TERPRI))) (DE PP-DEF (ID) (PROG (DEF TYPE ORIG-DEF) (SETQ DEF (GETD ID)) TEST (COND ((NULL DEF) (RETURN (AND ORIG-DEF (WARNING (LIST ID " has no unbroken definition."))))) ((CODEP (CDR DEF)) (RETURN (WARNING (LIST "Can't PP compiled definition for" ID)))) ((AND (NOT ORIG-DEF) (BROKEN ID)) (PROGN (WARNING (LIST "Note:" ID "is broken or traced.")) (SETQ ORIG-DEF DEF) (SETQ DEF (CONS (CAR DEF) (GET-GOOD-DEF ID))) (GO TEST)))) (SETQ TYPE (CAR DEF)) (TERPRI) (SETQ ORIG-DEF (ASSOC TYPE '((EXPR . DE) (MACRO . DM) (FEXPR . DF) (NEXPR . DN)))) (RETURN (PP-DEF-1 (CDR ORIG-DEF) ID (CDDR DEF))))) (DE PP-DEF-1 (FN NAME TAIL) (sprint (cons fn (cons name tail)) (posn)) (terpri)) (DE BROKEN (X) (GET X 'TRACE)) (DE GET-GOOD-DEF (X) (PROG (XX) (COND ((AND (SETQ XX (GET X 'TRACE)) (SETQ XX (ASSOC 'ORIGINALFN XX))) (RETURN (CDR XX)))))) %(!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (S EXP) (PROGN (OR (GREATERP (SPACES-LEFT) (PLUS (FLATSIZE2 S) (nFLATSIZE EXP))) (TERPRI)) (PRIN2 S) (SPRINT EXP (ADD1 (POSN))))) (de make-room-for (left-margin size flag) (cond ((or %flag (greaterp (add1 size) (difference 75 (posn))) (lessp (add1 (posn)) left-margin)) (tab left-margin)))) (de is-read-macrop (exp) (and (pairp exp) (atom (car exp)) (pairp (cdr exp)) (null (cddr exp)) (get (car exp) 'printmacro))) (de read-macro-internal-sprint (read-macro-c a lm1) (make-room-for lm1 (plus2 (flatsize2 read-macro-c) (nflatsize a)) (or (pairp a) (vectorp a))) (princ read-macro-c) (internal-sprint a (plus2 (flatsize2 read-macro-c) lm1))) (de sprint-read-macro (exp left-margin) (let ((c (get (car exp) 'printmacro))) (read-macro-internal-sprint c (cadr exp) left-margin))) (de handle-read-macros (exp left-margin) (prog (c) (cond ((and (pairp exp) (atom (car exp)) (pairp (cdr exp)) (null (cddr exp)) (setq c (get (car exp) 'printmacro))) (read-macro-internal-sprint c (cadr exp) left-margin) (return t))))) (dm define-special-sprint-list-structure (x) ((lambda (tag test-if-special sprint-function) `(progn (put ',tag 'sprint-test ',test-if-special) (put ',tag 'sprint-function ',sprint-function))) (cadr x) (caddr x) (cadr (cddr x)))) (de handle-special-list-structures (exp left-margin) (prog (c test) (cond ((pairp exp) (cond ((idp (car exp)) (setq test (get (car exp) 'sprint-test)) (setq c (get (car exp) 'sprint-function)) (cond ((and (or (null test) (apply test (list exp))) c) (apply c (list exp left-margin)) (return t)))) ((and (pairp (car exp)) (eq (caar exp) 'lambda)) (special-sprint-lambda-expression exp left-margin) (return t))))))) (de handle-special-list-structures-in-cdr-slot (exp left-margin) (prog (c test) (cond ((and (pairp exp) (atom (car exp))) (setq test (get (car exp) 'sprint-test)) (setq c (get (car exp) 'sprint-function)) (cond ((and (or (null test) (apply test (list exp))) c) (princ ". ") (apply c (list exp left-margin)) (return t))))))) (define-special-sprint-list-structure lambda sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure cond sprint-cond-test sprint-cond) (define-special-sprint-list-structure progn sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure prog1 sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure let sprint-let-test sprint-let) (define-special-sprint-list-structure let* sprint-let-test sprint-let) (define-special-sprint-list-structure defun sprint-defun-test sprint-defun) (define-special-sprint-list-structure do sprint-do-test sprint-do) (define-special-sprint-list-structure do* sprint-do-test sprint-do) (define-special-sprint-list-structure prog sprint-prog-test sprint-prog) (define-special-sprint-list-structure de sprint-defun-test sprint-defun) (define-special-sprint-list-structure df sprint-defun-test sprint-defun) (define-special-sprint-list-structure dn sprint-defun-test sprint-defun) (define-special-sprint-list-structure dm sprint-defun-test sprint-defun) (define-special-sprint-list-structure defmacro sprint-defun-test sprint-defun) (de sprint-cond-test (exp) (and (pairp (cdr exp)) (pairp (cdr exp)))) (de sprint-cond (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") (princ 'cond) (princ " ") %) (sprint-rest-of-vertical-list (cdr exp) (posn))) (de sprint-defun-test (exp) (and (pairp (cdr exp)) (pairp (cddr exp)))) (de sprint-defun (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (let ((a (plus2 1 (posn)))) (princ (car exp)) (princ " ") (internal-sprint (cadr exp) (posn)) (princ " ") (internal-sprint (caddr exp) a) (sprint-rest-of-vertical-list (cdddr exp) a))) (defun sprint-rest-of-vertical-list (list left-margin) (do ((i list (cdr i))) ((null i) %( (princ ")")) (tab left-margin) (cond ((atom i) (princ ". ") (internal-sprint i (plus2 2 left-margin)) %( (princ ")") (return nil)) ((is-read-macrop i) (make-room-for left-margin (plus2 2 (nflatsize i)) nil) (princ ". ") (sprint-read-macro i left-margin) %( (princ ")") (return nil)) (t (internal-sprint (car i) left-margin))))) (de special-sprint-lambda-expression (exp left-margin) (princ "((") (princ 'lambda)(princ " ") %)) (let ((a (posn))) (sprint-rest-of-vertical-list (cdar exp) a) (sprint-rest-of-vertical-list (cdr exp) (plus2 left-margin 1)))) (de sprint-prog-test (exp) (and (pairp (cdr exp)) (pairp (cddr exp)))) (de sprint-prog (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (let ((b (posn)) (a (plus2 1 (plus2 (posn) (flatsize (car exp)))))) (princ (car exp)) (princ " ") (internal-sprint (cadr exp) a) (sprint-rest-of-prog-vertical-list (cddr exp) a b))) (de sprint-let-test (exp) (and (pairp (cdr exp)) (pairp (cadr exp)))) (de sprint-let (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (princ (car exp)) (princ " ") (princ "(") %) (let ((b (posn))) (sprint-rest-of-vertical-list (cadr exp) b) (let ((c (idifference b 1))) (tab c) (sprint-rest-of-vertical-list (cddr exp) c)))) (de sprint-do-test (exp) (and (pairp exp) (pairp (cdr exp)) (pairp (cadr exp)) (pairp (cddr exp)) (pairp (caddr exp)) (pairp (cdddr exp)))) (de sprint-do (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (princ (car exp)) (princ " (") (let ((b (posn))) (sprint-rest-of-vertical-list (cadr exp) b) (let ((c (idifference b 1))) (tab c) (princ "(") %) (sprint-rest-of-vertical-list (caddr exp) b) (sprint-rest-of-prog-vertical-list (cdddr exp) c (idifference b 3))))) (de sprint-rest-of-prog-vertical-list (exp a b) (do ((i exp (cdr i))) ((null i) %( (princ ")")) (tab b) (cond ((atom i) (princ ". ") (internal-sprint i (plus2 2 a) ) %( (princ ")") (return nil)) ((is-read-macrop i) (make-room-for a (plus2 2 (nflatsize i)) nil) (princ ". ") (sprint-read-macro i a) %( (princ ")") (return nil)) ((atom (car i)) (internal-sprint (car i) b)) (t (internal-sprint (car i) a))))) (de sprint-lambda-test (exp) (and (cdr exp) (pairp (cdr exp)))) (de sprint-lambda (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (princ (car exp)) (princ " ") (let ((a (posn))) (internal-sprint (cadr exp) a) (sprint-rest-of-vertical-list (cddr exp) a))) (de depth-greater-than-n (l n) (cond ((weq n 0) t) ((pairp l) (do ((i l (cdr i))) ((null i)) (cond ((atom i) (return nil)) ((and (pairp i) (depth-greater-than-n (car i) (sub1 n))) (return t))))))) (de sprint-dtpr2 (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (prog (lm) (princ "(") %) (setq lm (plus2 1 (cond ((and (atom (car exp)) (null (vectorp (car exp))) (lessp (plus2 (posn) (nflatsize (car exp))) 40) (null (depth-greater-than-n exp 13))) (plus2 1 (plus2 left-margin (nflatsize (car exp))))) (t left-margin)))) (do ((a exp (cdr a)) (i 1 (add1 i)) (l (add1 left-margin) lm)) ((null a) % ( (princ ")")) (cond ((and (numberp prinlength) (greaterp i prinlength)) % ( (princ "...)") (return nil))) (cond ((atom a) (make-room-for l (plus2 2 (nflatsize a)) nil) (princ ". ") (internal-sprint a l) %( (princ ")") (return nil)) ((is-read-macrop a) (princ ". ") (sprint-read-macro a (plus2 l 2)) %( (princ ")") (return nil)) ((handle-special-list-structures-in-cdr-slot a left-margin) %( (princ ")") (return nil)) (t (internal-sprint (car a) l))) (cond ((cdr a) (cond ((greaterp (nflatsize (car a)) (difference 75 l)) (tab l)) (t (princ " ")))))))) (de sprint-dtpr (exp left-margin) ((lambda (sprint-level) (cond ((and (numberp prinlevel) (greaterp sprint-level prinlevel)) (princ "#")) ((handle-read-macros exp left-margin)) ((handle-special-list-structures exp left-margin)) (t (sprint-dtpr2 exp left-margin)))) (add1 sprint-level))) (de sprint-vector (vector left-margin) ((lambda (sprint-level) (cond ((and (Numberp prinlevel) (greaterp sprint-level prinlevel)) (princ "#")) (t (prog (c) (princ "[") (let ((lm (add1 left-margin))) (do ((i 0 (1+ i)) (size (size vector))) ((greaterp i size) (princ "]")) (cond ((and (numberp prinlength) (greaterp i prinlength)) (princ "...]") (return nil))) (internal-sprint (getv vector i) lm) (cond ((lessp i size) (cond ((greaterp (nflatsize (getv vector (plus2 i 1))) (difference 75 lm)) (tab lm)) ((lessp (posn) lm) (tab lm)) (t (princ " "))))))))))) (add1 sprint-level))) (de check-if-room-for-and-back-indent (a lm) (cond ((and (atom a) (null (vectorp a)) (greaterp (add1 (nflatsize a)) (difference (linelength nil) lm)) (null (lessp (posn) 2))) (terpri) (cond ((eq (getv lispscantable* (id2int '!%)) 12) (princ "%")) ((eq (getv lispscantable* (id2int '!;)) 12) (princ ";")) (t (princ "%"))) (princ "**** <<<<<< Reindenting.") (terpri) lm))) (de internal-sprint (a lm) (let ((indent (check-if-room-for-and-back-indent a lm))) (cond ((lessp (posn) lm) (tab lm))) (cond ((handle-read-macros a lm)) ((handle-special-list-structures a lm)) (t (make-room-for lm (nflatsize a) (or (pairp a) (vectorp a))) (cond ((pairp a) (sprint-dtpr a (posn))) ((vectorp a) (sprint-vector a (posn))) (t (and (lessp (posn) lm) (tab lm)) (prin1 a))))) (cond (indent (terpri) (cond ((eq (getv lispscantable* (id2int '!%)) 12) (princ "%")) ((eq (getv lispscantable* (id2int '!;)) 12) (princ ";")) (t (princ "%"))) (princ "**** >>>>> Reindenting.") (terpri))))) (de sprint (exp left-margin) (let ((a (posn)) (sprint-level 0) (b (linelength nil))) (linelength 600) (cond ((eq a left-margin)) (t (tab left-margin))) (internal-sprint exp left-margin) (linelength b) nil)) (PUT 'QUOTE 'PRINTMACRO "'") (PUT 'BACKQUOTE 'PRINTMACRO "`") (PUT 'UNQUOTE 'PRINTMACRO ",") (PUT 'UNQUOTEL 'PRINTMACRO ",@") (PUT 'UNQUOTED 'PRINTMACRO ",.") (DE PM-DEF (FORM) (PP-DEF-1 (CAR FORM) (CADR FORM) (CDDR FORM))) (DE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES-LEFT NIL (SUB1 (CHRCT))) (DE SAFE-PPOS (N SIZE) (PROG (MIN-N) (SETQ MIN-N (SUB1 (DIFFERENCE (LINELENGTH NIL) SIZE))) (COND ((LESSP MIN-N N) (PROGN (OR (GREATERP MIN-N (POSN1)) (TERPRI)) (PPOS MIN-N))) (T (PPOS N))))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) (de nflatsize (n) (nflatsize1 n sprint-level)) (de nflatsize1 (n currentlevel) (cond ((and (numberp prinlevel) (wgreaterp currentlevel prinlevel)) 1) ((vectorp n) (do ((i (size n) (sub1 i)) (s (iplus2 1 (size n)) (iplus2 1 (iplus2 s (nflatsize1 (getv n i) (iplus2 1 currentlevel)))))) ((wlessp i 0) s))) ((atom n) (flatsize n)) ((is-read-macrop n) (let ((c (get (car n) 'printmacro))) (iplus2 (flatsize2 c) (nflatsize1 (cadr n) (iplus2 1 currentlevel))))) ((do ((i n (cdr i)) (s 1 (iplus2 (nflatsize1 (car i) (iplus2 1 currentlevel)) (iplus2 1 s)))) ((null i) s) (cond ((atom i) (return (iplus2 3 (iplus2 s (nflatsize1 i (iplus2 1 currentlevel)))))) ((is-read-macrop i) (return (iplus2 3 (iplus2 s (nflatsize1 i (iplus2 1 currentlevel))))))))))) %*************************************************************************** % % End of Prettyprinter. % %*************************************************************************** |
Added psl-1983/3-1/util/pr-demo.red version [ebde01d357].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PR-DEMO.RED: A small 3D version Picture RLISP demo file % See also the LISP syntax form in PR-DEMO.SL % Use IN "PU:PR-DEMO.RED"$ for best effects LOAD PRLISP; HP!.INIT(); % For HP2648a Outline := { 10, 10} _ {-10, 10} _ % Outline is 20 by 20 {-10,-10} _ { 10,-10} _ {10, 10}$ % Square Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}$ Cubeface := (Outline & Arrow) | ZMOVE 10$ Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90)$ % Make it larger for better viewing BigCube := Cube | Scale 5$ % and show it ESHOW BigCube$ % Some more views ESHOW (BigCube | XROT 20 | YROT 30 | ZROT 10)$ ESHOW (Cube | scale 2 | XMOVE (-240) | REPEATED(5, XMOVE 80))$ % Some curves: ESHOW {10,10} | circle(70)$ SHOW {10,10} | circle(50) | Xmove 20$ % Some control points for BSPLINE and BEZIER curves Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ ESHOW (Cpts & Cpts | BEZIER())$ ESHOW (Cpts & Cpts | BSPLINE())$ END; |
Added psl-1983/3-1/util/pr-demo.sl version [83a3c2b011].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PR-DEMO.SL: A small 3D Picture RLISP demo file, using LISP syntax % Is equivalent to the PR-DEMO.RED form in RLISP syntax % Use (LAPIN "PU:PR-DEMO.SL") for best effects (LOAD PRLISP) % First call the xxx!.INIT routine, (HP!.INIT) % For HP2648a % Define a 20 x 20 square (SETQ OUTLINE (POINTSET (ONEPOINT 10 10) (ONEPOINT -10 10) (ONEPOINT -10 -10) (ONEPOINT 10 -10) (ONEPOINT 10 10))) % and an Arrow to place in square (SETQ ARROW (GROUP (POINTSET (ONEPOINT 0 -1) (ONEPOINT 0 2)) (POINTSET (ONEPOINT -1 1) (ONEPOINT 0 2) (ONEPOINT 1 1)))) % to produce the CubeFace. Will be shifted out by 10 units (SETQ CUBEFACE (TRANSFORM (GROUP OUTLINE ARROW) (ZMOVE 10))) % to produce a 20 x 20 x 20 Cube (SETQ CUBE (GROUP CUBEFACE (TRANSFORM CUBEFACE (XROT 180)) (TRANSFORM CUBEFACE (YROT 90)) (TRANSFORM CUBEFACE (YROT -90)) (TRANSFORM CUBEFACE (XROT 90)) (TRANSFORM CUBEFACE (XROT -90)))) % This is a bigger cube to be seen more clearly (SETQ BIGCUBE (TRANSFORM CUBE (SCALE 5))) % as can be seen (ESHOW BIGCUBE) % Some more views of the CUBE (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM BIGCUBE (XROT 20)) (YROT 30)) (ZROT 10))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM CUBE (SCALE 2)) (XMOVE -240)) (REPEATED 5 (XMOVE 80)))) % Draw a circle (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 70))) % and another (SHOW (TRANSFORM (TRANSFORM (ONEPOINT 10 10) (CIRCLE 50)) (XMOVE 20))) % Define Some control points for Bspline and Bezier (SETQ CPTS (POINTSET (ONEPOINT 0 0) (ONEPOINT 70 -60) (ONEPOINT 189 -69) (ONEPOINT 206 33) (ONEPOINT 145 130) (ONEPOINT 48 130) (ONEPOINT 0 84))) % And show the BSPLINE and BEZIER curves (ESHOW (GROUP CPTS (TRANSFORM CPTS (BEZIER)))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BSPLINE)))) |
Added psl-1983/3-1/util/pr-driv.build version [b6e7bd5f3b].
> > | 1 2 | CompileTime load pr!-main; in "pr-driv.red"$ |
Added psl-1983/3-1/util/pr-driv.red version [914f1faee0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. PR-DRIV.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE FLUID '(!*EMODE); loadtime <<!*EMODE:=NIL;>>; % initialize emode to off %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MoveToXY(0,0)>>$ Procedure HP!.Erase()$ %. Erase graphic diaplay screen <<HP!.Graphon(); HP!.Erases(); HP!.Graphoff()>>; Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. move pen to absolute location << HP!.GRCMD("d")$ XDEST := HP!.NormX XDEST$ YDEST := HP!.NormY YDEST$ HP!.OutInt XDEST$ HP!.OutChar Char '!,$ HP!.OutInt YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ XDEST := HP!.NormX XDEST$ %. destination and draw a YDEST := HP!.NormY YDEST$ HP!.OutInt XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'HP!.Erase)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<Graphoff(); Tek!.Erase(); Graphon()>>; Procedure TEK!.Erase(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. draw the line. TEK!.4BYTES (Xprevious, Yprevious)$ TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) echooff(); % also issue GS? Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); % Also issue US? Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'TEK!.Erase)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Top . . Bottom) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; FIX(Y)+12; Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.Erase(); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.EraseS(); % Delete Entire Screen <<GraphOFF(); Tel!.Erase(); Graphon()>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xprevious,Yprevious, X1, Y1,function dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); Echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('Erase,'TEL!.Erase); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Top . . Bottom) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.Erase(); % Delete Entire Screen <<Graphon(); ANN!.Erases(); GraphOff()>>; Procedure ANN!.DDA(X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL end; Procedure ANN!.MoveS(X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure ANN!.DrawS(X1,Y1); << ANN!.DDA(Xprevious,Yprevious, X1, Y1,function ANN!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(ANN!.DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('Erase,'ANN!.Erase); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Print "Device Now ANN60"; end; %********************************** % MPS device routines will only * % work If the MPS C library is * % resident in the system * % contact Paul Stay or Russ Fish * % University of Utah * %********************************** Fluid '(DDDD MDDD ABSDD); Procedure MPS!.DrawS (XDEST, YDEST); <<PSdraw2d(LIST(XDEST,YDEST) ,DDDD,ABSDD,0,1); %draw a line from cursor 0; %do x and y coordinates >>; Procedure MPS!.MoveS (XDEST, YDEST); <<PSdraw2d( LIST(XDEST,YDEST) , MDDD,ABSDD,0,1); %move to point x,y 0; >>; Procedure MPS!.Delay(); % no Delay function for mps NIL; Procedure MPS!.EraseS(); % setdisplay list to nil DISPLAY!.LIST := NIL$ Procedure MPS!.Erase(); % setdisplay list to nil <<MPS!.GraphOn(); DISPLAY!.LIST := NIL$ MPS!.GraphOff()>>; Procedure MPS!.VWPORT( X1, X2, Y1, Y2); %set up viewport << PSsetscale(300); %set up scale factor X1CLIP := MAX2(-500, X1); X2CLIP := MIN2(500, X2); Y1CLIP := MAX2(-500, Y1); Y2CLIP := MIN2(500, Y2); >>; Procedure MPS!.GRAPHON(); % Check this echooff(); Procedure MPS!.GRAPHOFF(); If not !*emode then echoon(); Procedure MPS!.INIT$ << PRINT "MPS IS DISPLAY DEVICE"; DEV!. := 'MPS; FNCOPY ( 'EraseS, 'MPS!.ERASES)$ FNCOPY ( 'Erase, 'MPS!.ERASE)$ % Add NORM functions FNCOPY ( 'MoveS, 'MPS!.MoveS)$ FNCOPY ( 'DrawS, 'MPS!.DrawS)$ FNCOPY ( 'VWPORT, 'MPS!.VWPORT)$ FNCOPY ( 'Delay, 'MPS!.Delay)$ FNCOPY( 'GraphOn, 'MPS!.GraphOn)$ FNCOPY( 'GraphOff, 'MPS!.GraphOff)$ PSINIT(1,0); % initialize device ERASE(); MPS!.VWPORT(-500,500,-500,500); % setup viewport Psscale(1,1,1,500); % setup scale hardware GLOBAL!.TRANSFORM := WINdoW(-300,60); >>; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen in G-mode << Graphoff(); ST!.OutChar 27; ST!.OutChar 12; GraphOn(); >>; Procedure ST!.Erase(); % erase screen in Text mode << Echooff(); ST!.OutChar 27; ST!.OutChar 12; If not !*emode then Echoon();>>; Procedure ST!.GraphOn(); << EchoOff(); ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); <<ST!.OutChar 31; % Maybe mixed VT-52/tek problem If Not !*EMODE Then EchoOn()>>; Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. so next X,Y set is MOVE >>$ Procedure ST!.DrawS (XDEST,YDEST)$ << %/ ST!.OutChar 29$ %/ Always after MOVE %/ ST!.4bytes(Xprevious, Yprevious)$ ST!.4BYTES (XDEST, YDEST)$ %. draw the line. >>$ Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'ST!.Erase)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/3-1/util/pr-main.build version [fbaa2db00f].
> | 1 | in "pr-main.red"$ |
Added psl-1983/3-1/util/pr-main.red version [4bdda55b20].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % % % Author: Fuh-Meei Chen, Paul Stay and Martin L. Griss % % Symbolic Computation Group % % Computer Science Dept. % % University of Utah % % % % <PSL.UTIL>PRLISP.RED.21, 9-Jan-82 22:47:43, Edit by GRISS % % <STAY.PICT>PRLISP.B 12-april-82 8:00:00 by Paul Stay % % changed bezier circle and bspline drivers and hp terminal % % on 10-april-82 by Paul Stay % % Added MPS support software for use on the graphics vax % % Added ST.INIT % % Copyright (c) 1981 University of Utah % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Part of the parser to accomplish the Pratt parser written % % in New-Rlisp runs at DEC-20. % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% RemFlag('(MKVECT),'TWOREG); %/ Seems in Error RemProp('!{,'NEWNAM!-OP); %. left and right brackets RemProp('!},'NEWNAM!-OP); %. handling. RemProp('!{,'NEWNAM); % left and right brackets are RemProp('!},'NEWNAM); % used to Define points. Put('!{, 'NEWNAM,'!*LBRAC!*); Put('!}, 'NEWNAM,'!*RBRAC!*); % Put on to the property list. DefineROP('!*LBRAC!*,NIL,LBC); % Define the precedence. DefineBOP('!*RBRAC!*,1,0); FLUID '(OP); Procedure LBC X; Begin scalar RES; If X EQ '!*RBRAC!* then <<OP := X; RES := '!*EMPTY!*>> else RES:= RDRIGHT(2,X); If OP EQ '!*RBRAC!* then OP := SCAN() else PARERR("Missing } after argument list",NIL); Return REPCOM('OnePoint,RES) end; Procedure REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); RemProp('!_,'NEWNAM); %. underscore handling. Put('!_,'NEWNAM,'POINTSET); % "_" is used for Pointset. DefineBOP('POINTSET,17,18,NARY('POINTSET,X,Y)); Put('!&,'NEWNAM,'GROUP); %. and sign handling. DefineBOP('GROUP,13,14,NARY('GROUP,X,Y)); % "&" is used for Group. Put('!|,'NEWNAM,'TRANSFORM); %. back slash handling. DefineROP('TRANSFORM,20, % "|" is used for transform. If EQCAR(X,'!*COMMA!*) then REPCOM('TRANSFORM,X)); DefineBOP('TRANSFORM,15,16); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of external Procedures to % % internal form. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ************************************** % conversion on structures of models. * % ************************************** NExpr Procedure POINTSET L$ 'POINTSET . L$ NExpr Procedure GROUP L$ 'GROUP . L$ NExpr Procedure TRANSFORM L$ 'TRANSFORM . L$ % *********************************** % conversion on interpreter level * % Procedures. * % *********************************** Procedure BSPLINE; LIST 'BSPLINE; Procedure BEZIER; LIST 'BEZIER; Procedure LINE; LIST 'LINE; Procedure CIRCLE(R); LIST('CIRCLE,R); Procedure COLOR N; List('Color,N); Procedure REPEATED(COUNT,TRANS); LIST('REPEATED,COUNT,TRANS); BothTimes <<Procedure MKLIST L$ 'LIST . L; >>; MACRO Procedure OnePoint L$ LIST('MKPOINT, MKLIST CDR L)$ MACRO Procedure MAT16 L; LIST('LIST2VECTOR, MKLIST (NIL. CDR L))$ Procedure PNT4(X1,X2,X3,X4); % create a vector of a point Begin scalar V; V:=MKVECT 4; V[1]:=X1; V[2]:=X2; V[3]:=X3; V[4]:=X4; Return V; end; % %%%%%%%%%%%%%%%%%%%%%%%%% % PAIR KLUDGES % % %%%%%%%%%%%%%%%%%%%%%%%%% Procedure PRLISPCDR L$ %. PRLISPCDR of a list. If PAIRP L then CDR L else 'NIL$ Procedure CAR1 L$ %. the Car1 element of If PAIRP L then CAR L else 'NIL$ %. a list. Procedure CAR2 L$ %. the CAR2 element of If LENGTH L > 1 then CADR L else 'NIL$ %. a list. Procedure CAR3 L$ %. the CAR3 element of If LENGTH L > 2 then CADDR L else 'NIL$ %. a list. Procedure CAR4 L$ %. the CAR4 element of If LENGTH L > 3 then CADDDR L else 'NIL$ %. a list. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % interpreter supporting Procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure V!.COPY V1$ %. Copy a vector Begin scalar N, V2$ V2 := MKVECT(N := SIZE V1)$ FOR I := 0 : N DO V2[I] := V1[I]$ Return V2$ end$ % ********************* % point primitive * % ********************* Procedure MKPOINT (POINTLIST)$ %. make a vector form for Begin scalar P,I; P:=Pnt4(0,0,0,1); I:=1; While PairP PointList and I<=4 do <<P[I]:=Car PointList; I:=I+1; PointList:=Cdr PointList>>; Return P End; % ************************** % initialize globals and * % and fluids * % set up for compiled * % version * % ************************** FLUID '( DISPLAY!.LIST %. Used for object definition for MPS MAT!*0 %. 4 x 4 Zero Matrix MAT!*1 %. 4 x 4 Unit Matrix FirstPoint!* % FirstPoint of PointSet is MOVED to GLOBAL!.TRANSFORM %. Accumulation Transform CURRENT!.TRANSFORM CURRENT!.LINE %. Line Style CURRENT!.COLOR %. Default Color X1CLIP % Set by VWPORT for Clipping X2CLIP Y1CLIP Y2CLIP FourClip % Vector to return New Clipped point Xprevious Yprevious DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := MAT16 ( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0)$ MAT!*1 := MAT16 (1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1)$ % unit matrix. GLOBAL!.TRANSFORM := MAT!*1$ CURRENT!.TRANSFORM := MAT!*1$ % current transformation matrix % initialized as mat!*1. CURRENT!.LINE := 'LINE$ CURRENT!.COLOR := 'BLACK$ Xprevious := 0; Yprevious:=0; FourClip := PNT4(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 4 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); Xprevious := X; Yprevious := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); Xprevious := X; Yprevious := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeFourClip(X1,Y1,X2,Y2); <<FourClip[1]:=x1; FourClip[2]:=y1; FourClip[3]:=x2; FourClip[4]:=y2; FourClip>>; Procedure InView (L); NULL(Car L) and NULL(cadr L) and NULL(caddr L) and NULL (cadddr L); Procedure CLIP2D (x1,y1,x2,y2); % Iterative Clipper Begin scalar P1,P2,TMP; % Newmann and Sproull P1 := TESTPOINT(x1,y1); % Classify EndPoints, get 4 List P2 := TESTPOINT(x2,y2); If InView(P1) and InView(P2) then Return MakeFourClip(x1,y1,X2,Y2); WHILE NOT(InView(P1) AND InView(P2) OR LOGICAND(P1,P2)) DO << If InView(P1) then % SWAP to get Other END <<TMP := P1$ P1 := P2$ P2 := TMP$ TMP := X1$ X1 := X2$ X2 := TMP$ TMP := Y1$ Y1 := Y2$ Y2 := TMP>>$ If CADDDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X1CLIP-X1)) / (X2-X1)$ X1 := X1CLIP>> else If CADDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X2CLIP-X1)) / (X2-X1)$ X1 := X2CLIP>> else If CADR P1 then <<X1 := X1 + ((X2-X1)*(Y1CLIP-Y1)) / (Y2-Y1)$ Y1 := Y1CLIP>> else If CAR P1 then <<X1 := X1 + ((X2-X1)*(Y2CLIP-Y1)) / (Y2-Y1)$ Y1 := Y2CLIP>>$ P1 := TESTPOINT(X1,Y1)>>; % reTest P1 after clipping If Not LOGICAND(P1,P2) then Return MakeFourClip(X1,Y1,X2,Y2); Return NIL end$ Procedure LOGICAND (P1, P2)$ %. logical "and". (CAR P1 AND CAR P2) OR %. use in clipping (CADR P1 AND CADR P2) OR (CADDR P1 AND CADDR P2) OR (CADDDR P1 AND CADDDR P2) $ Procedure TESTPOINT(x,y)$ %. test If "P" LIST (If y > Y2CLIP then T else NIL, %. inside the viewport. If y < Y1CLIP then T else NIL, %.used in clipping If x > X2CLIP then T else NIL, If x < X1CLIP then T else NIL)$ % All NIL if Inside % ********************************** % tranformation matrices * % matrices internal are stored as * % OnePoint = [x y z w] * % matrix = [v1 v5 v9 v13 * % v2 v6 v10 v14 * % v3 v7 v11 v15 * % v4 v8 v12 v16 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 4 by 4 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. MAT16 ( % V1 and V2 are 4 by 4 matrices. V1[ 1] * V2[ 1] + V1[ 5] * V2[ 2] + V1[ 9] * V2[ 3] + V1[ 13] * V2[ 4], V1[ 2] * V2[ 1] + V1[ 6] * V2[ 2] + V1[ 10] * V2[ 3] + V1[ 14] * V2[ 4], V1[ 3] * V2[ 1] + V1[ 7] * V2[ 2] + V1[ 11] * V2[ 3] + V1[ 15] * V2[ 4], V1[ 4] * V2[ 1] + V1[ 8] * V2[ 2] + V1[ 12] * V2[ 3] + V1[ 16] * V2[ 4], V1[ 1] * V2[ 5] + V1[ 5] * V2[ 6] + V1[ 9] * V2[ 7] + V1[ 13] * V2[ 8], V1[ 2] * V2[ 5] + V1[ 6] * V2[ 6] + V1[ 10] * V2[ 7] + V1[ 14] * V2[ 8], V1[ 3] * V2[ 5] + V1[ 7] * V2[ 6] + V1[ 11] * V2[ 7] + V1[ 15] * V2[ 8], V1[ 4] * V2[ 5] + V1[ 8] * V2[ 6] + V1[ 12] * V2[ 7] + V1[ 16] * V2[ 8], V1[ 1] * V2[ 9] + V1[ 5] * V2[ 10] + V1[ 9] * V2[ 11] + V1[ 13] * V2[ 12], V1[ 2] * V2[ 9] + V1[ 6] * V2[ 10] + V1[ 10] * V2[ 11] + V1[ 14] * V2[ 12], V1[ 3] * V2[ 9] + V1[ 7] * V2[ 10] + V1[ 11] * V2[ 11] + V1[ 15] * V2[ 12], V1[ 4] * V2[ 9] + V1[ 8] * V2[ 10] + V1[ 12] * V2[ 11] + V1[ 16] * V2[ 12], V1[ 1] * V2[ 13] + V1[ 5] * V2[ 14] + V1[ 9] * V2[ 15] + V1[ 13] * V2[ 16], V1[ 2] * V2[ 13] + V1[ 6] * V2[ 14] + V1[ 10] * V2[ 15] + V1[ 14] * V2[ 16], V1[ 3] * V2[ 13] + V1[ 7] * V2[ 14] + V1[ 11] * V2[ 15] + V1[ 15] * V2[ 16], V1[ 4] * V2[ 13] + V1[ 8] * V2[ 14] + V1[ 12] * V2[ 15] + V1[ 16] * V2[ 16])$ Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[1] * V[1] + %. 1 by 4 and 4 by 1. U[2] * V[2] + % Returning a value. U[3] * V[3] + U[4] * V[4] $ Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U1,U2,U3,U4$ %. 1 by 4 with 4 by 4. U1 := U[1]$ % Returning a 1 by 4 vector. U2 := U[2]$ U3 := U[3]$ U4 := U[4]$ U:=Mkvect 4; u[1]:= U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; u[2]:= U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; u[3]:= U1 * V[9] + U2 * V[10] + U3 * V[11] + U4 * V[12]; u[4]:= U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; Return U; end$ % ************************************ % set up perspective transformtion * % given eye and screen distances * % ************************************ Procedure WINDOW(EYE,SCREEN)$ %. perspective transformation. Begin scalar SE$ SE := SCREEN - EYE$ % EYE and SCREEN are distances Return MAT16(SE,0.0,0.0,0.0, % from eye and screen to 0.0,SE,0.0,0.0, % origin respectively. 0.0,0.0,SE,0.0, 0.0,0.0,1.0, -EYE) end$ % ********************** % translation * % ********************** Procedure XMove (TX)$ %. x translation only Move (TX,0,0) $ Procedure YMove (TY)$ %. y translation only Move (0,TY,0) $ Procedure ZMove (TZ)$ %. z translation only Move (0,0,TZ) $ Procedure Move (TX,TY,TZ)$ %. Move origin / object$ MAT16 (1, 0, 0, TX, %. make a translation 0, 1, 0, TY, %. transformation matrix 0, 0, 1, TZ, %. [ 1 O O O 0, 0, 0, 1)$ %. 0 1 0 0 %. 0 0 1 0 %. Tx Ty Tz 1 ] % ******************* % rotation * % ******************* Procedure XROT (X)$ %. rotation about x FROTATE (X,2,3) $ Procedure YROT (X)$ %. rotation about y FROTATE (X,3,1) $ Procedure ZROT (X)$ %. rotation about z FROTATE (X,1,2) $ Procedure FROTATE (THETA,I,J)$ %. scale factor Begin scalar S,C,W,TEMP$ %. i and j are the index %. values to set up matrix S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib TEMP := V!.COPY MAT!*1; PutV (TEMP, 5 * I-4, C)$ PutV(TEMP, 5 * J-4, C)$ PutV (TEMP, I+4 * J-4,-S)$ PutV (TEMP, J+4 * I-4, S)$ Return TEMP end $ %/ Need to add rotate about an AXIS % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY,1) $ Procedure ZSCALE (SZ)$ %. scaling along Z axis only. SCALE1 (1,1,SZ) $ Procedure SCALE1(XT,YT,ZT)$ %. scaling transformation MAT16 ( XT, 0, 0, 0, %. matrix. 0 ,YT, 0, 0, 0 , 0,ZT, 0, 0 , 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 3 axes. SCALE1(SFACT,SFACT,SFACT); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Procedure definitions % % in the interpreter % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Put('OnePoint,'PBINTRP,'DrawPOINT)$ Put('POINTSET,'PBINTRP,'DrawPOINTSET)$ Put('GROUP,'PBINTRP,'DrawGROUP)$ Put('TRANSFORM,'PBINTRP,'PERFORMTRANSFORM)$ Put('PICTURE,'PBINTRP,'DrawModel)$ Put('CIRCLE,'PBINTRP,'DrawCIRCLE)$ Put('BEZIER,'PBINTRP,'DOBEZIER)$ Put('LINE,'PBINTRP,'DOLINE)$ Put('BSPLINE,'PBINTRP,'DOBSPLINE)$ Put('REPEATED, 'PBINTRP,'DOREPEATED)$ Put('Color,'pbintrp,'Docolor); %****************************************** % SETUP Procedure FOR BEZIER AND BSPLINE * % LINE and COLOR %****************************************** procedure DoColor(Object,N); Begin scalar SaveColor; SaveColor:=Current!.color; N:=Car1 N; % See CIRCLE example, huh? If IDP N then N:=EVAL N; ChangeColor N; Draw1(Object,CURRENT!.TRANSFORM); ChangeColor SaveColor; Return NIL; End; Procedure DOBEZIER OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BEZIER$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOBSPLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BSPLINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'LINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ %************************************* % interpreted function calls * %************************************* Procedure DOREPEATED(MODEL,REPTFUN)$ %. repeat applying Begin scalar TEMP,I,TRANS,COUNT,TS,TA,GRP$ %. transformations. TRANS := PRLISPCDR REPTFUN$ If LENGTH TRANS = 1 then TRANS := EVAL CAR1 TRANS else % "TRANS": transformation << TS :=CAR1 TRANS$ % matrix. TA := PRLISPCDR TRANS $ % "MODEL": the model. TRANS := APPLY(TS,TA) >> $ % "COUNT": the times "MODEL" COUNT := CAR1 REPTFUN$ % is going to be GRP := LIST('GROUP)$ % repeated. TEMP := V!.COPY TRANS$ FOR I := 1 : COUNT DO << GRP := LIST('TRANSFORM,MODEL,TEMP) . GRP$ TEMP := MAT!*MAT(TEMP,TRANS) >>$ GRP := REVERSE GRP$ Return GRP end$ %*********************************** % Define SHOW ESHOW Draw AND EDraw * % ESHOW AND EDraw ERASE THE SCREEN * %*********************************** Procedure SHOW X; %. ALIAS FOR Draw << If DEV!. = 'MPS then %. MPS driver don't call << %. echo functions for diplay %. device DISPLAY!.LIST := LIST (X, DISPLAY!.LIST); FOR EACH Z IN DISPLAY!.LIST DO If Z neq NIL then Draw1(Z,GLOBAL!.TRANSFORM); % Draw object list % to frame PSnewframe(); % display frame >> else << GraphOn(); % call echo off If not emode % If neccessary turn low level Draw1(X,GLOBAL!.TRANSFORM); % Draw model tekronix style GraphOff(); % call echoon >>; >>; Procedure ESHOW ZZ$ %. erases the screen and << Erase(); GraphOn(); DELAY(); Draw1(ZZ,GLOBAL!.TRANSFORM); % Draw model tekronix style If DEV!. = 'MPS then << % Mps display frame PSnewframe(); DISPLAY!.LIST := ZZ; >>; GraphOff(); 0 >>; DefineROP('SHOW,10); %. set up precedence DefineROP('ESHOW,10); Procedure Draw X; %. ALIAS FOR SHOW SHOW X$ Procedure EDraw ZZ$ %. erases the screen and ESHOW ZZ$ DefineROP('Draw,10); DefineROP('EDraw,10); Procedure Col N; % User top-level color <<GraphOn(); ChangeColor N; GraphOff()>>; %************************************* % Define Draw FUNCTIONS FOR VARIOUS * % TYPES OF DISPLAYABLE OBJECTS * %************************************* Procedure DrawModel PICT$ %. given picture "PICT" will Draw1(PICT,CURRENT!.TRANSFORM)$ %. be applyied with global Procedure DERROR(MSG,OBJECT); <<PRIN2 " Draw Error `"; PRIN2T MSG; PRIN2 OBJECT; ERROR(700,MSG)>>; Procedure Draw1 (PICT,CURRENT!.TRANSFORM)$ % Draw PICT with TRANSFORMATION Begin scalar ITM,ITSARGS$ If NULL Pict then Return NIL; If IDP PICT then PICT:=EVAL PICT; If VECTORP PICT AND SIZE(PICT)=4 then Return DrawPOINT PICT$ If NOT PAIRP PICT then DERROR("Non Pair in Draw1: ",PICT); ITM := CAR1 PICT$ ITSARGS := PRLISPCDR PICT$ If NOT (ITM = 'TRANSFORM) then ITSARGS := LIST ITSARGS$ % gets LIST of args ITM := GET (ITM,'PBINTRP)$ If NULL ITM then DERROR("Unknown Operator in Draw1:",PICT); APPLY(ITM,ITSARGS)$ Return PICT$ end$ Procedure DrawGROUP(GRP)$ % Draw a group object Begin scalar ITM,ITSARGS,LMNT$ If PAIRP GRP then FOR EACH LMNT IN GRP DO If PAIRP LMNT then Draw1 (LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL GRP,CURRENT!.TRANSFORM)$ Return GRP$ end$ Procedure DrawPOINTSET (PNTSET)$ Begin scalar ITM,ITSARGS,PT$ FirstPoint!* := 'T$ If PAIRP PNTSET then << If CURRENT!.LINE = 'BEZIER then PNTSET := DrawBEZIER PNTSET else If CURRENT!.LINE = 'BSPLINE then PNTSET := DrawBSPLINE PNTSET$ FOR EACH PT IN PNTSET DO <<If PAIRP PT then Draw1 (PT,CURRENT!.TRANSFORM) else Draw1 (EVAL PT,CURRENT!.TRANSFORM)$ FirstPoint!* := 'NIL>> >> else Draw1 (EVAL PNTSET,CURRENT!.TRANSFORM)$ Return PNTSET$ end$ Procedure DrawPOINT (PNT)$ Begin scalar CLP,X1,Y1,W1,V,U1,U2,U3,U4; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U1:=PNT[1]; U2:=PNT[2]; U3:= PNT[3]; U4:=PNT[4]; X1:=U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; Y1:=U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; W1:=U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; IF NOT (W1 = 1.0) then <<x1:=x1/w1; y1:=y1/w1>>; If FirstPoint!* then Return MoveToXY(X1,Y1); % back to w=1 plane If needed. CLP := CLIP2D(Xprevious,Yprevious, X1,Y1)$ If CLP then <<MoveToXY(CLP[1],CLP[2])$ DrawToXY(CLP[3],CLP[4])>>$ end$ Procedure PERFORMTRANSFORM(PCTSTF,TRNSFRM)$ Begin scalar PROC,OLDTRNS,TRNSFMD,TRANSFOP, TRANSARG,ITM,ITSARGS$ If IDP TRNSFRM then TRNSFRM := EVAL TRNSFRM$ If VECTORP TRNSFRM AND SIZE(TRNSFRM) = 16 then Draw1 (PCTSTF,MAT!*MAT(TRNSFRM,CURRENT!.TRANSFORM)) else If PAIRP TRNSFRM then <<TRANSFOP := CAR1 TRNSFRM$ If (TRANSARG := PRLISPCDR TRNSFRM) then TRANSARG := LIST (PCTSTF,TRANSARG) else TRANSARG := LIST PCTSTF$ If (TRANSFOP = 'BEZIER OR TRANSFOP = 'BSPLINE) then APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG) else Draw1 (APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG), CURRENT!.TRANSFORM) >> end$ %*************************************** % circle bezier and bspline functions * %*************************************** Procedure DrawCIRCLE(CCNTR,RADIUS); %. Draw a circle with radius Begin scalar APNT,POLY,APNTX, APNTY$ %. "RADIUS". POLY := LIST('POINTSET)$ If IDP CCNTR then CCNTR := EVAL CCNTR$ RADIUS := CAR1 RADIUS$ If IDP RADIUS then RADIUS := EVAL RADIUS$ FOR ANGL := 180 STEP -15 UNTIL -180 DO % each line segment << APNTX := CCNTR[1] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[2] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBSPLINE CONPTS$ %. a closed bspline curve Begin scalar N,TWOLIST,PX,PY,CURPTS, %. will be Drawn when given BSMAT,II,TFAC,CPX,CPY$ %. a polygon "CONPTS". BSMAT := MAT16 % " CONPTS" is a pointset. ( -0.166666, 0.5, -0.5, 0.166666, 0.5 , -1.0, 0.0, 0.666666, -0.5 , 0.5, 0.5, 0.166666, 0.166666, 0.0, 0.0, 0.0 )$ CURPTS := NIL$ N := LENGTH CONPTS$ TWOLIST := APPend (CONPTS,CONPTS)$ WHILE N > 0 DO << PX :=PNT4 (GETV(CAR1 TWOLIST,1), GETV(CAR2 TWOLIST,1), GETV(CAR3 TWOLIST,1),GETV(CAR4 TWOLIST,1))$ PY := PNT4 (GETV(CAR1 TWOLIST,2), GETV(CAR2 TWOLIST,2), GETV(CAR3 TWOLIST,2), GETV(CAR4 TWOLIST,2))$ FOR I := 0.0 STEP 1.0 UNTIL 4.0 DO << II := I/4.$ TFAC := PNT4 (II*II*II, II*II, II, 1.)$ TFAC := PNT!*MAT(TFAC,BSMAT)$ CPX := PNT!*PNT(TFAC,PX)$ CPY := PNT!*PNT(TFAC,PY)$ CURPTS := LIST ('Onepoint, CPX, CPY) . CURPTS >>$ N := N - 1$ TWOLIST := PRLISPCDR TWOLIST >>$ Return REVERSE CURPTS end$ LISP Procedure DrawBEZIER CNTS; Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, I, T0, TEMP, FACTL; CURPTS := NIL; SAVEX := NIL; SAVEY := NIL; LEN := LENGTH CNTS; FOR I := 1 STEP 1 UNTIL LEN DO << SAVEX := GETV(CAR1 CNTS, 1) . SAVEX; SAVEY := GETV(CAR1 CNTS, 2) . SAVEY; CNTS := PRLISPCDR CNTS >>; SAVEX := LIST2VECTOR SAVEX; SAVEY := LIST2VECTOR SAVEY; NALL := 8.0 * (LEN - 1); FACTL := FACT (LEN - 1); T0 := 0.0; FOR T0 := 0.0 STEP 1.0 / NALL UNTIL 1.0 DO << CPX := 0.0; CPY := 0.0; TEMP := 0.0; FOR I := 0 STEP 1 UNTIL LEN - 1 DO << TEMP := FACTL / ((FACT I) * (FACT (LEN -1 - I))) * (T0 ** I) * (1.0 - T0)**(LEN -1 - I); CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY, 0.0) . CURPTS >>; Return REVERSE CURPTS; end; procedure FACT N; % Simple factorial Begin scalar M; M:=1; for i:=1:N do M:=M*I; Return M; end; LoadTime SetUpVariables(); |
Added psl-1983/3-1/util/pr-text.build version [c04e13d445].
> > | 1 2 | CompileTime load pr!-main; in "pr-text.red"$ |
Added psl-1983/3-1/util/pr-text.red version [bf51b5bc48].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 8 * 12 Vector Characters CV := MkVect(127)$ BlankChar := 'NIL$ % Labeled Points on Rectangle (8 x 12 ) % C4 Q6 S3 Q5 C3 % % % Q7 M3 Q4 % % % S4 M4 M0 M2 S2 % % % Q8 M1 Q3 % % % C1 Q1 S1 Q2 C2 % Corners: C1:={0,0}$ C2 := {8,0}$ C4:={0,12}$ C3:= {8,12}$ % Side MidPoints: S1 := {4,0}$ S3 := {4,12}$ S4 := {0,6}$ S2 := {8,6}$ % Middle: M0 := {4,6}$ M1 := {4,3}$ M2 := {6,6}$ M3 := {4,9}$ M4 := {2,6}$ % Side Quarter Points: Q1 := {2,0}$ Q2 := {6,0}$ Q3 := {8,3}$ Q4 := {8,9}$ Q5 := {6,12}$ Q6 := {2,12}$ Q7 := {0,9}$ Q8 := {0,3}$ For i:=0:127 do CV[I]:=BlankChar; % UpperCase: CV[Char A] := C1 _ S3 _ C2 & M4 _ M2$ CV[Char B] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M2 _ Q3 _ Q2 _ C1 $ CV[Char C] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char D] := C1 _ C4 _ Q5 _ Q4 _ Q3 _ Q2 _ C1$ CV[Char E] := C3 _ C4 _ C1 _ C2 & S4 _ S2$ CV[Char F] := C3 _ C4 _ C1 & S4 _ S2$ CV[Char G] := M0 _ S2 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char H] := C4 _ C1 & S4 _ S2 & C3 _ C2$ CV[Char I] := S1 _ S3$ CV[Char J] := C3 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char K] := C4 _ C1 & C3 _ S4 _ C2$ CV[Char L] := C4 _ C1 _ C2$ CV[Char M] := C1 _ C4 _ M0 _ C3 _ C2$ CV[Char N] := C1 _ C4 _ C2 _ C3$ CV[Char O] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3$ CV[Char P] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4$ CV[Char Q] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3 & C2 _ M1$ CV[Char R] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M0 _ C2$ CV[Char S] := Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char T] := C4 _ C3 & S3 _ S1$ CV[Char U] := C4 _ Q8 _ Q1 _ Q2 _ Q3 _ C3$ CV[Char V] := C4 _ S1 _ C3$ CV[Char W] := C4 _ Q1 _ M0 _ Q2 _ C3$ CV[Char X] := C1 _ C3 & C4 _ C2$ CV[Char Y] := C4 _ M0 _ C3 & M0 _ S1$ CV[Char Z] := C4 _ C3 _ C1 _ C2$ % Lower Case, Alias for Now: CV[Char Lower A] := CV[Char A]$ CV[Char Lower B] := CV[Char B]$ CV[Char Lower C] := CV[Char C]$ CV[Char Lower D] := CV[Char D]$ CV[Char Lower E] := CV[Char E]$ CV[Char Lower F] := CV[Char F]$ CV[Char Lower G] := CV[Char G]$ CV[Char Lower H] := CV[Char H]$ CV[Char Lower I] := CV[Char I]$ CV[Char Lower J] := CV[Char J]$ CV[Char Lower K] := CV[Char K]$ CV[Char Lower L] := CV[Char L]$ CV[Char Lower M] := CV[Char M]$ CV[Char Lower N] := CV[Char N]$ CV[Char Lower O] := CV[Char O]$ CV[Char Lower P] := CV[Char P]$ CV[Char Lower Q] := CV[Char Q]$ CV[Char Lower R] := CV[Char R]$ CV[Char Lower S] := CV[Char S]$ CV[Char Lower T] := CV[Char T]$ CV[Char Lower U] := CV[Char U]$ CV[Char Lower V] := CV[Char V]$ CV[Char Lower W] := CV[Char W]$ CV[Char Lower X] := CV[Char X]$ CV[Char Lower Y] := CV[Char Y]$ CV[Char Lower Z] := CV[Char Z]$ % Digits: CV[Char 0] := CV[Char O]$ CV[Char 1] := CV[Char I]$ CV[Char 2] := Q7 _ Q6 _ Q5 _ Q4 _ M0 _ C1 _ C2$ CV[Char 3] := C4 _ C3 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 4] := S1 _ S3 _ S4 _ S2$ CV[Char 5] := C3 _ C4 _ S4 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 6] := Q4 _ Q5 _ Q6 _ Q7 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M4 _ Q8$ CV[Char 7] := C4 _ C3 _ S1$ CV[Char 8] := M0 _ M4 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M0 & M2 _ Q4 _ Q5 _ Q6 _ Q7 _ M4$ CV[Char 9] := Q8 _ Q1 _ Q2 _ Q3 _ Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q4$ % Some Special Chars: CV[Char !+ ] := S1 _ S3 & S4 _ S2$ CV[Char !- ] := S4 _ S2 $ CV[Char !* ] := S1 _ S3 & S4 _ S2 & C1 _ C3 & C4 _ C2 $ CV[Char !/ ] := C1 _ C3 $ CV[Char !\ ] := C4 _ C2 $ CV[Char !( ] := Q6 _ Q7 _ Q8 _ Q1 $ CV[Char !) ] := Q5 _ Q4 _ Q3 _ Q2 $ CV[Char ![ ] := Q6 _ C4 _ C1 _ Q1$ CV[Char !] ] := Q5 _ C3 _ C2 _ Q2$ CV[Char != ] := Q7 _ Q4 & Q8 _ Q3 $ % Some Simple Display Routines: Xshift := Xmove(10)$ Yshift := Ymove(15)$ Procedure ShowString(S); <<Graphon(); ShowString1(S,Global!.Transform); Graphoff()>>; Procedure ShowString1(S,Current!.Transform); Begin scalar i,ch; For i:=0:Size S do <<Draw1(CV[S[i]],Current!.Transform); Current!.Transform := Mat!*mat(XShift,Current!.TRansform)>>; End; Procedure C x; if x:=CV[x] then EShow x; Procedure FullTest(); <<Global!.Transform := MAT!*1; ShowString "ABCDEFGHIJKLMNOPQRTSUVWXYZ 0123456789"; NIL>>; Procedure SpeedTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do C i; NIL>>; Procedure SlowTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do <<C i; Delay()>>; NIL>>; Procedure Delay; For i:=1:500 do nil; Procedure Text(S); List('TEXT,S); Put('TEXT,'PBINTRP,'DrawTEXT)$ Procedure DrawText(StartPoint,S); %. Draw a Text String Begin scalar MoveP; If IDP StartPoint then StartPoint := EVAL StartPoint$ S := CAR1 S$ If IDP S then S := EVAL S$ MoveP:=PositionAt StartPoint; ShowString1(S,Mat!*Mat(MoveP,Current!.Transform)); Return NIL; end$ Procedure PositionAt StartPoint; % return A matrix to set relative Origin << If IDP StartPoint then StartPoint := EVAL StartPoint$ Mat16(1,0,0,StartPoint[1], 0,1,0,StartPoint[2], 0,0,1,StartPoint[3], 0,0,0,StartPoint[4])>>; |
Added psl-1983/3-1/util/pr2d-demo.red version [1e41f74a3f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This is a small Picture RLISP demo file % For the simpler 2D version Load prlisp2d$ HP!.Init()$ Outline := { 10, 10} _ {-10, 10} _ % Outline is 20 by 20 {-10,-10} _ { 10,-10} _ {10, 10}$ % Square Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}$ Cube := (Outline & Arrow)$ BigCube := Cube | Scale 5$ Eshow Cube$ Show Cube | Xmove 30$ SHOW BigCube$ ESHOW BigCube | Zrot 30$ ESHOW {10,10} | circle(70)$ Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ ESHOW ( {10,10} | CIRCLE(50))$ ESHOW (Cpts & Cpts | BEZIER())$ ESHOW (Cpts & Cpts | BSPLINE())$ ESHOW (Cube | scale 2 | XMOVE (-240) | REPEATED(5, XMOVE 80))$ ESHOW {0,0} | Text("ABC DEF")$ ESHOW {5,5} | Text("123 456") | Zrot 25 | Scale 2$ Eshow { 10,10} | Text("123")$ Show {30,30} | Text("456") | scale 3$ END$ |
Added psl-1983/3-1/util/pr2d-demo.sl version [172b1629be].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Lisp Syntax form of PR2D-DEMO.RED % 2D Version (LOAD PRLISP2D) % Initialize for HP2648 (HP!.INIT) % Build some ObJects (SETQ OUTLINE (POINTSET (ONEPOINT 10 10) (ONEPOINT -10 10) (ONEPOINT -10 -10) (ONEPOINT 10 -10) (ONEPOINT 10 10))) (SETQ ARROW (GROUP (POINTSET (ONEPOINT 0 -1) (ONEPOINT 0 2)) (POINTSET (ONEPOINT -1 1) (ONEPOINT 0 2) (ONEPOINT 1 1)))) (SETQ CUBE (GROUP OUTLINE ARROW)) (SETQ BIGCUBE (TRANSFORM CUBE (SCALE 5))) (ESHOW CUBE) (SHOW (TRANSFORM CUBE (XMOVE 30))) (SHOW BIGCUBE) (ESHOW (TRANSFORM BIGCUBE (ZROT 30))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 70))) (SETQ CPTS (POINTSET (ONEPOINT 0 0) (ONEPOINT 70 -60) (ONEPOINT 189 -69) (ONEPOINT 206 33) (ONEPOINT 145 130) (ONEPOINT 48 130) (ONEPOINT 0 84))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 50))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BEZIER)))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BSPLINE)))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM CUBE (SCALE 2)) (XMOVE -240)) (REPEATED 5 (XMOVE 80)))) (ESHOW (TRANSFORM (ONEPOINT 0 0) (TEXT "ABC DEF"))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM (ONEPOINT 5 5) (TEXT "123 456")) (ZROT 25)) (SCALE 2))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (TEXT "123"))) (SHOW (TRANSFORM (TRANSFORM (ONEPOINT 30 30) (TEXT "456")) (SCALE 3))) |
Added psl-1983/3-1/util/pr2d-driv.build version [9378b17ab6].
> > | 1 2 | CompileTime load Pr2d!-Main; in "pr2d-driv.red"$ |
Added psl-1983/3-1/util/pr2d-driv.red version [d5a33b98d3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %--------------------------------- %. PRLISP-DRIVER.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Symbolic Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE FLUID '(!*EMODE); loadtime <<!*EMODE:=NIL;>>; % initialize emode to off %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; Procedure DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MoveToXY(0,0)>>; Procedure HP!.Erase()$ %. EraseS graphic diaplay screen <<HP!.GraphOn(); HP!.Erases(); HP!.GraphOff()>>; Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. Move pen to absolute location << HP!.GRCMD("d")$ HP!.OutInt HP!.NormX XDEST$ HP!.OutChar Char '!,$ HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ HP!.OutInt HP!.NormX XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff If not !*emode then echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'HP!.Erase)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<Tek!.GraphOn(); Tek!.Erases(); TEK!.GraphOff()>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ %/ Dont do 31 unless go back to text mode TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. Draw the line. TEK!.4BYTES (HerePointX, HerePointY)$ %/ Can just do this, ignore reset TEXT or GRPAHICS mode, see ST! TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) If not !*emode then echooff(); Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'TEK!.Erase)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X+0.5)+40; Procedure TEL!.NormY Y; 12- FIX(Y+0.5); Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.Erase (); % Delete Entire Screen <<TEL!.GraphON(); TEL!.Erases(); TEL!.GraphOff()>>; Procedure Tel!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure Tel!.DrawS (X1,Y1); << DDA (Xprevious,Yprevious, X1, Y1,function TEL!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (DDA (X1,Y1,X2,Y2,function TEL!.Tdotc)) end; Procedure TEL!.Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure TEL!.dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('Erase,'TEL!.Erase); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Global!.Transform := MAT!*1; Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Top . . Bottom) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.Erase(); <<ANN!.Graphon(); ANN!.Erases(); Ann!.GraphOff()>>; Procedure ANN!.MoveS(X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure ANN!.DrawS(X1,Y1); << DDA(Xprevious,Yprevious, X1, Y1,function ANN!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); If not !*emode then echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('Erase,'ANN!.Erase); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Global!.Transform := Mat!*1; Print "Device Now ANN60"; end; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen << GraphOff(); ST!.OutChar 27; ST!.OutChar 12; Graphon()>>; Procedure ST!.Erase(); % erase screen << EchoOff(); ST!.OutChar 27; ST!.OutChar 12; If Not !*EMODE then EchoOn()>>; Procedure ST!.GraphOn(); << EchoOff(); ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); <<ST!.OutChar 31$ % Maybe mixed VT-52/tek problem If Not !*Emode Then EchoOn()>>; Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. US: sets terminal to Alpha mode. >>; Procedure ST!.DrawS (XDEST,YDEST)$ %. Same as MoveS but << %/ ST!.OutChar 29$ % Always after move %/ ST!.4bytes(HerePointX, HerePointY)>>$ ST!.4BYTES (XDEST, YDEST)$ %. Draw the line. >>; Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'ST!.Erase)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % HP2382 specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Hp2382 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) Procedure HP2382!.OutChar x; PBOUT x; Procedure HP2382!.OutCharString S; % Pbout a string For i:=0:Size S do HP2382!.OutChar S[i]; Procedure HP2382!.NormX X; FIX(X+0.5)+40; Procedure HP2382!.NormY Y; 12- FIX(Y+0.5); Procedure HP2382!.ChPrt(X,Y,Ch); <<HP2382!.OutChar Char ESC; HP2382!.OutChar Char '!&; HP2382!.OutChar Char '!a; HP2382!.OutINT (HP2382!.NormY Y); HP2382!.OutChar Char '!r; HP2382!.OutINT (HP2382!.NormX X); HP2382!.OutChar Char '!C; HP2382!.OutChar Ch>>; procedure HP2382!.OutINT x; <<If x>9 then HP2382!.OutChar(Char 0 +(x/10)); HP2382!.OutChar(Char 0 +remainder(x,10))>>; Procedure HP2382!.IdPrt(X,Y,Id); HP2382!.ChPrt(X,Y,ID2Int ID); Procedure HP2382!.StrPrt (X,Y,S); <<HP2382!.OutChar Char ESC; HP2382!.OutChar 89; HP2382!.OutChar (32+HP2382!.NormY Y); HP2382!.OutChar (32+ HP2382!.NormX X); HP2382!.OutCharString S>>; Procedure HP2382!.HOME (); % Home (0,0) <<HP2382!.OutChar CHAR ESC; HP2382!.OutChar 'H>>; Procedure HP2382!.EraseS (); % Delete Entire Screen <<HP2382!.HOME(); HP2382!.OutChar CHAR ESC; HP2382!.OutChar 'J>>; Procedure HP2382!.Erase (); % Delete Entire Screen <<HP2382!.GraphON(); HP2382!.Erases(); HP2382!.GraphOff()>>; Procedure HP2382!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure HP2382!.DrawS (X1,Y1); << DDA (Xprevious,Yprevious, X1, Y1,function HP2382!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (DDA (X1,Y1,X2,Y2,function HP2382!.Tdotc)) end; Procedure HP2382!.Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; HP2382!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure HP2382!.dotc (X1,Y1); % Draw And Clip An X HP2382!.ChClip (X1,Y1,Char X) ; Procedure HP2382!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; HP2382!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure HP2382!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure HP2382!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do HP2382!.ChClip (X,Y,Id); end; Procedure HP2382!.Wzap (X1,X2,Y1,Y2); HP2382!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure HP2382!.Delay; NIL; Procedure HP2382!.GRAPHON(); If not !*emode then echooff(); Procedure HP2382!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP2382!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'HP2382!.EraseS); FNCOPY('Erase,'HP2382!.Erase); FNCOPY('MoveS,'HP2382!.MoveS); FNCOPY('DrawS,'HP2382!.DrawS); FNCOPY( 'NormX, 'HP2382!.NormX)$ FNCOPY( 'NormY, 'HP2382!.NormY)$ FNCOPY('VwPort,'HP2382!.VwPort); FNCOPY('Delay,'HP2382!.Delay); FNCOPY( 'GraphOn, 'HP2382!.GraphOn)$ FNCOPY( 'GraphOff, 'HP2382!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Global!.Transform := MAT!*1; Print "Device Now TEL"; end; |
Added psl-1983/3-1/util/pr2d-main.build version [8b89d4f3b4].
> | 1 | in "pr2d-main.red"$ |
Added psl-1983/3-1/util/pr2d-main.red version [c69ceaf080].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % 2D version................ % % Author: Fuh-Meei Chen, Paul Stay and Martin L. Griss % % Symbolic Computation Group % % Computer Science Dept. % % University of Utah % % % % <PSL.UTIL>PRLISP.RED.21, 9-Jan-82 22:47:43, Edit by GRISS % % <STAY.PICT>PRLISP.B 12-april-82 8:00:00 by Paul Stay % % changed bezier circle and bspline drivers and hp terminal % % on 10-april-82 by Paul Stay % % Added MPS support software for use on the graphics vax % % Added ST.INIT % % Copyright (c) 1981 University of Utah % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Part of the parser to accomplish the Pratt parser written % % in New-Rlisp runs at DEC-20. % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% RemFlag('(MKVECT),'TWOREG); %/ Seems in Error RemProp('!{,'NEWNAM!-OP); %. left and right brackets RemProp('!},'NEWNAM!-OP); %. handling. RemProp('!{,'NEWNAM); % left and right brackets are RemProp('!},'NEWNAM); % used to Define points. Put('!{, 'NEWNAM,'!*LBRAC!*); Put('!}, 'NEWNAM,'!*RBRAC!*); % Put on to the property list. DefineROP('!*LBRAC!*,NIL,LBC); % Define the precedence. DefineBOP('!*RBRAC!*,1,0); FLUID '(OP); Procedure LBC X; Begin scalar RES; If X EQ '!*RBRAC!* then <<OP := X; RES := '!*EMPTY!*>> else RES:= RDRIGHT(2,X); If OP EQ '!*RBRAC!* then OP := SCAN() else PARERR("Missing } after argument list",NIL); Return REPCOM('OnePoint,RES) end; Procedure REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); RemProp('!_,'NEWNAM); %. underscore handling. Put('!_,'NEWNAM,'POINTSET); % "_" is used for Pointset. DefineBOP('POINTSET,17,18,NARY('POINTSET,X,Y)); Put('!&,'NEWNAM,'GROUP); %. and sign handling. DefineBOP('GROUP,13,14,NARY('GROUP,X,Y)); % "&" is used for Group. Put('!|,'NEWNAM,'TRANSFORM); %. back slash handling. DefineROP('TRANSFORM,20, % "|" is used for transform. If EQCAR(X,'!*COMMA!*) then REPCOM('TRANSFORM,X)); DefineBOP('TRANSFORM,15,16); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of external Procedures to % % internal form. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ************************************** % conversion on structures of models. * % ************************************** NExpr Procedure POINTSET L$ 'POINTSET . L$ NExpr Procedure GROUP L$ 'GROUP . L$ NExpr Procedure TRANSFORM L$ 'TRANSFORM . L$ % *********************************** % conversion on interpreter level * % Procedures. * % *********************************** Procedure BSPLINE; LIST 'BSPLINE; Procedure BEZIER; LIST 'BEZIER; Procedure LINE; LIST 'LINE; Procedure CIRCLE(R); LIST('CIRCLE,R); Procedure COLOR N; List('Color,N); Procedure REPEATED(COUNT,TRANS); LIST('REPEATED,COUNT,TRANS); BothTimes <<Procedure MKLIST L$ 'LIST . L; >>; MACRO Procedure OnePoint L$ LIST('MKPOINT, MKLIST CDR L)$ MACRO Procedure Mat8 L; LIST('LIST2VECTOR, MKLIST (CDR L))$ Procedure Pnt2(X1,X2,X3); % create a vector of a point Begin scalar V; V:=MKVECT 2; V[0]:=X1; V[1]:=X2; V[2]:=X3; Return V; end; % %%%%%%%%%%%%%%%%%%%%%%%%% % PAIR KLUDGES % % %%%%%%%%%%%%%%%%%%%%%%%%% Procedure PRLISPCDR L$ %. PRLISPCDR of a list. If PAIRP L then CDR L else 'NIL$ Procedure CAR1 L$ %. the Car1 element of If PAIRP L then CAR L else 'NIL$ %. a list. Procedure CAR2 L$ %. the CAR2 element of If LENGTH L > 1 then CADR L else 'NIL$ %. a list. Procedure CAR3 L$ %. the CAR3 element of If LENGTH L > 2 then CADDR L else 'NIL$ %. a list. Procedure CAR4 L$ %. the CAR4 element of If LENGTH L > 3 then CADDDR L else 'NIL$ %. a list. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % interpreter supporting Procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure V!.COPY V1$ %. Copy a vector Begin scalar N, V2$ V2 := MKVECT(N := SIZE V1)$ FOR I := 0 : N DO V2[I] := V1[I]$ Return V2$ end$ % ********************* % point primitive * % ********************* Procedure MKPOINT (POINTLIST)$ %. make a vector form for Begin scalar P,I; P:=Pnt2(0,0,1); I:=0; While PairP PointList and I<=2 do <<P[I]:=Car PointList; I:=I+1; PointList:=Cdr PointList>>; Return P End; % ************************** % initialize globals and * % and fluids * % set up for compiled * % version * % ************************** FLUID '( DISPLAY!.LIST %. Used for object definition for MPS MAT!*0 %. 3 x 3 Zero Matrix MAT!*1 %. 3 x 3 Unit Matrix FirstPoint!* % FirstPoint of PointSet is MOVED to GLOBAL!.TRANSFORM %. Accumulation Transform CURRENT!.TRANSFORM CURRENT!.LINE %. Line Style CURRENT!.COLOR %. Default Color X1CLIP % Set by VWPORT for Clipping X2CLIP Y1CLIP Y2CLIP ThreeClip % Vector to return New Clipped point HEREPOINTX %/ Same as Xprevious? HEREPOINTY Xprevious % To do DDA on TEL and AAA Yprevious % Set by Move, used by DRAW DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := Mat8 ( 0,0,0, 0,0,0, 0,0,0)$ MAT!*1 := Mat8 (1,0,0, 0,1,0, 0,0,1)$ % unit matrix. GLOBAL!.TRANSFORM := MAT!*1$ CURRENT!.TRANSFORM := MAT!*1$ % current transformation matrix % initialized as mat!*1. CURRENT!.LINE := 'LINE$ CURRENT!.COLOR := 'BLACK$ HEREPOINTX := 0; HEREPOINTY:=0; ThreeClip := Vector(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 3 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeThreeClip(X1,Y1,X2,Y2); <<ThreeClip[0]:=x1; ThreeClip[1]:=y1; ThreeClip[2]:=x2; ThreeClip[3]:=y2; ThreeClip>>; Procedure InView (L); NULL(Car L) and NULL(cadr L) and NULL(caddr L) and NULL (cadddr L); Procedure CLIP2D (x1,y1,x2,y2); % Iterative Clipper Begin scalar P1,P2,TMP; % Newmann and Sproull P1 := TESTPOINT(x1,y1); % Classify EndPoints, get 4 List P2 := TESTPOINT(x2,y2); If InView(P1) and InView(P2) then Return MakeThreeClip(x1,y1,X2,Y2); WHILE NOT(InView(P1) AND InView(P2) OR LOGICAND(P1,P2)) DO << If InView(P1) then % SWAP to get Other END <<TMP := P1$ P1 := P2$ P2 := TMP$ TMP := X1$ X1 := X2$ X2 := TMP$ TMP := Y1$ Y1 := Y2$ Y2 := TMP>>$ If CADDDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X1CLIP-X1)) / (X2-X1)$ X1 := X1CLIP>> else If CADDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X2CLIP-X1)) / (X2-X1)$ X1 := X2CLIP>> else If CADR P1 then <<X1 := X1 + ((X2-X1)*(Y1CLIP-Y1)) / (Y2-Y1)$ Y1 := Y1CLIP>> else If CAR P1 then <<X1 := X1 + ((X2-X1)*(Y2CLIP-Y1)) / (Y2-Y1)$ Y1 := Y2CLIP>>$ P1 := TESTPOINT(X1,Y1)>>; % reTest P1 after clipping If Not LOGICAND(P1,P2) then Return MakeThreeClip(X1,Y1,X2,Y2); Return NIL end$ Procedure LOGICAND (P1, P2)$ %. logical "and". (CAR P1 AND CAR P2) OR %. use in clipping (CADR P1 AND CADR P2) OR (CADDR P1 AND CADDR P2) OR (CADDDR P1 AND CADDDR P2) $ Procedure TESTPOINT(x,y)$ %. test If "P" LIST (If y > Y2CLIP then T else NIL, %. inside the viewport. If y < Y1CLIP then T else NIL, %.used in clipping If x > X2CLIP then T else NIL, If x < X1CLIP then T else NIL)$ % All NIL if Inside % ********************************** % tranformation matrices * % matrices internal are stored as * % OnePoint = [x y w] * % matrix = [v0 v3 v6 * % v1 v4 v7 * % v2 v5 v8 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 3 by 3 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. Mat8 ( % V1 and V2 are 3 by 3 matrices. V1[0] * V2[0] + V1[3] * V2[1] + V1[6] * V2[2], V1[1] * V2[0] + V1[4] * V2[1] + V1[7] * V2[2], V1[2] * V2[0] + V1[5] * V2[1] + V1[8] * V2[2], V1[0] * V2[3] + V1[3] * V2[4] + V1[6] * V2[5], V1[1] * V2[3] + V1[4] * V2[4] + V1[7] * V2[5], V1[2] * V2[3] + V1[5] * V2[4] + V1[8] * V2[5], V1[0] * v2[6] + V1[3] * V2[7] + V1[6] * V2[8], V1[1] * v2[6] + V1[4] * V2[7] + V1[7] * V2[8], V1[2] * v2[6] + V1[5] * V2[7] + V1[8] * V2[8]); Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[0] * V[0] + U[1] * V[1] + %. 1 by 3 and 3 by 1. U[2] * V[2] $ % Returning a value. Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U0,U1,U2$ %. 1 by 3 with 3 by 3. U0 := U[0]$ U1 := U[1]$ % Returning a 1 by 3 vector. U2 := U[2]$ U:=Mkvect 2; u[0]:= U0 * V[0] + U1 * V[3] + U2 * V[6]; u[1]:= U0 * V[1] + U1 * V[4] + U2 * V[7]; u[2]:= U0 * V[2] + U1 * V[5] + U2 * V[8]; Return U; end$ % ********************** % translation * % ********************** Procedure XMove(TX)$ %. x translation only Move (TX,0) $ Procedure YMove(TY)$ %. y translation only Move (0,TY) $ Procedure Move(TX,TY)$ %. Move origin / object$ Mat8(1, 0, TX, %. make a translation 0, 1, TY, %. transformation matrix 0, 0, 1)$ % ******************* % Z rotation * % ******************* Procedure ZROT(Theta)$ %. rotation about z Begin scalar S,C; S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib Return Mat8( C,-S,0, S,C,0, 0,0,1); end $ % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY) $ Procedure SCALE1(XT,YT)$ %. scaling transformation Mat8 ( XT, 0, 0, %. matrix. 0 ,YT, 0, 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 2 axes. SCALE1(SFACT,SFACT); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Procedure definitions % % in the interpreter % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Put('OnePoint,'PBINTRP,'DrawPOINT)$ Put('POINTSET,'PBINTRP,'DrawPOINTSET)$ Put('GROUP,'PBINTRP,'DrawGROUP)$ Put('TRANSFORM,'PBINTRP,'PERFORMTRANSFORM)$ Put('PICTURE,'PBINTRP,'DrawModel)$ Put('CIRCLE,'PBINTRP,'DrawCIRCLE)$ Put('BEZIER,'PBINTRP,'DOBEZIER)$ Put('LINE,'PBINTRP,'DOLINE)$ Put('BSPLINE,'PBINTRP,'DOBSPLINE)$ Put('REPEATED, 'PBINTRP,'DOREPEATED)$ Put('Color,'pbintrp,'Docolor); %****************************************** % SETUP Procedure FOR BEZIER AND BSPLINE * % LINE and COLOR %****************************************** procedure DoColor(Object,N); Begin scalar SaveColor; SaveColor:=Current!.color; N:=Car1 N; % See CIRCLE example, huh? If IDP N then N:=EVAL N; ChangeColor N; Draw1(Object,CURRENT!.TRANSFORM); ChangeColor SaveColor; Return NIL; End; Procedure DOBEZIER OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BEZIER$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOBSPLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BSPLINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'LINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ %************************************* % interpreted function calls * %************************************* Procedure DOREPEATED(MODEL,REPTFUN)$ %. repeat applying Begin scalar TEMP,I,TRANS,COUNT,TS,TA,GRP$ %. transformations. TRANS := PRLISPCDR REPTFUN$ If LENGTH TRANS = 1 then TRANS := EVAL CAR1 TRANS else % "TRANS": transformation << TS :=CAR1 TRANS$ % matrix. TA := PRLISPCDR TRANS $ % "MODEL": the model. TRANS := APPLY(TS,TA) >> $ % "COUNT": the times "MODEL" COUNT := CAR1 REPTFUN$ % is going to be GRP := LIST('GROUP)$ % repeated. TEMP := V!.COPY TRANS$ FOR I := 1 : COUNT DO << GRP := LIST('TRANSFORM,MODEL,TEMP) . GRP$ TEMP := MAT!*MAT(TEMP,TRANS) >>$ GRP := REVERSE GRP$ Return GRP end$ %*********************************** % Define SHOW ESHOW Draw AND EDraw * % ESHOW AND EDraw ERASE THE SCREEN * %*********************************** Procedure SHOW X; %. ALIAS FOR Draw << If DEV!. = 'MPS then %. MPS driver don't call << %. echo functions for diplay %. device DISPLAY!.LIST := LIST (X, DISPLAY!.LIST); FOR EACH Z IN DISPLAY!.LIST DO If Z neq NIL then Draw1(Z,GLOBAL!.TRANSFORM); % Draw object list % to frame PSnewframe(); % display frame >> else << GraphOn(); % call echo off If not emode % If neccessary turn low level Draw1(X,GLOBAL!.TRANSFORM); % Draw model tekronix style GraphOff(); % call echoon >>; >>; Procedure ESHOW ZZ$ %. erases the screen and <<Erase(); %. display the picture "ZZ" GraphOn(); DELAY(); Draw1(ZZ,GLOBAL!.TRANSFORM); % Draw model tekronix style If DEV!. = 'MPS then << % Mps display frame PSnewframe(); DISPLAY!.LIST := ZZ; >>; GraphOff(); 0 >>; DefineROP('SHOW,10); %. set up precedence DefineROP('ESHOW,10); Procedure Draw X; %. ALIAS FOR SHOW SHOW X$ Procedure EDraw ZZ$ %. erases the screen and ESHOW ZZ$ DefineROP('Draw,10); DefineROP('EDraw,10); Procedure Col N; % User top-level color <<GraphOn(); ChangeColor N; GraphOff()>>; %************************************* % Define Draw FUNCTIONS FOR VARIOUS * % TYPES OF DISPLAYABLE OBJECTS * %************************************* Procedure DrawModel PICT$ %. given picture "PICT" will Draw1(PICT,CURRENT!.TRANSFORM)$ %. be applyied with global Procedure DERROR(MSG,OBJECT); <<PRIN2 " Draw Error `"; PRIN2T MSG; PRIN2 OBJECT; ERROR(700,MSG)>>; Procedure Draw1 (PICT,CURRENT!.TRANSFORM)$ % Draw PICT with TRANSFORMATION Begin scalar ITM,ITSARGS$ If NULL Pict then Return NIL; If IDP PICT then PICT:=EVAL PICT; If VECTORP PICT AND SIZE(PICT)=2 then Return DrawPOINT PICT$ If NOT PAIRP PICT then DERROR("Non Pair in Draw1: ",PICT); ITM := CAR1 PICT$ ITSARGS := PRLISPCDR PICT$ If NOT (ITM = 'TRANSFORM) then ITSARGS := LIST ITSARGS$ % gets LIST of args ITM := GET (ITM,'PBINTRP)$ If NULL ITM then DERROR("Unknown Operator in Draw1:",PICT); APPLY(ITM,ITSARGS)$ Return PICT$ end$ Procedure DrawGROUP(GRP)$ % Draw a group object Begin scalar ITM,ITSARGS,LMNT$ If PAIRP GRP then FOR EACH LMNT IN GRP DO If PAIRP LMNT then Draw1 (LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL GRP,CURRENT!.TRANSFORM)$ Return GRP$ end$ Procedure DrawPOINTSET (PNTSET)$ Begin scalar ITM,ITSARGS,PT$ FirstPoint!* := 'T$ If PAIRP PNTSET then << If CURRENT!.LINE = 'BEZIER then PNTSET := DrawBEZIER PNTSET else If CURRENT!.LINE = 'BSPLINE then PNTSET := DrawBSPLINE PNTSET$ FOR EACH PT IN PNTSET DO <<If PAIRP PT then Draw1 (PT,CURRENT!.TRANSFORM) else Draw1 (EVAL PT,CURRENT!.TRANSFORM)$ FirstPoint!* := 'NIL>> >> else Draw1 (EVAL PNTSET,CURRENT!.TRANSFORM)$ Return PNTSET$ end$ Procedure DrawPOINT (PNT)$ Begin scalar CLP,X1,Y1,W1,V,U0,U1,U2; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U0:=PNT[0]; U1:=PNT[1]; U2:=PNT[2]; X1:=U0 * V[0] + U1 * V[1] + U2 * V[2]; Y1:=U0 * V[3] + U1 * V[4] + U2 * V[5]; W1:=U0 * V[6] + U1 * V[7] + U2 * V[8]; IF NOT( (W1=1) or (W1 = 1.0)) then <<x1:=x1/w1; y1:=y1/w1>>; If FirstPoint!* then Return MoveToXY(X1,Y1); % back to w=1 plane If needed. CLP := CLIP2D(HEREPOINTX,HerePointY, X1,Y1)$ If CLP then <<MoveToXY(CLP[0],CLP[1])$ DrawToXY(CLP[2],CLP[3])>>$ end$ Procedure PERFORMTRANSFORM(PCTSTF,TRNSFRM)$ Begin scalar PROC,OLDTRNS,TRNSFMD,TRANSFOP, TRANSARG,ITM,ITSARGS$ If IDP TRNSFRM then TRNSFRM := EVAL TRNSFRM$ If VECTORP TRNSFRM AND SIZE(TRNSFRM) = 8 then Draw1 (PCTSTF,MAT!*MAT(TRNSFRM,CURRENT!.TRANSFORM)) else If PAIRP TRNSFRM then <<TRANSFOP := CAR1 TRNSFRM$ If (TRANSARG := PRLISPCDR TRNSFRM) then TRANSARG := LIST (PCTSTF,TRANSARG) else TRANSARG := LIST PCTSTF$ If (TRANSFOP = 'BEZIER OR TRANSFOP = 'BSPLINE) then APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG) else Draw1 (APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG), CURRENT!.TRANSFORM) >> end$ %*************************************** % circle bezier and bspline functions * %*************************************** Procedure DrawCIRCLE(CCNTR,RADIUS); %. Draw a circle Begin scalar APNT,POLY,APNTX, APNTY$ POLY := LIST('POINTSET)$ If IDP CCNTR then CCNTR := EVAL CCNTR$ RADIUS := CAR1 RADIUS$ If IDP RADIUS then RADIUS := EVAL RADIUS$ FOR ANGL := 180 STEP -15 UNTIL -180 DO % each line segment << APNTX := CCNTR[0] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[1] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBspline CONPTS$ %. a "closed" Periodic bspline curve Begin scalar N,CURPTS, % See CATMUL thesis Appendix CPX,CPY, % Note correction in Matrix! X0,X1,X2,X3, Y0,Y1,Y2,Y3, T1,T2,T3, J0,J1,J2, NPTS; NPTS := 4; N := LENGTH CONPTS$ %/ Check at least 4 ? CONPTS := Append (CONPTS,CONPTS)$ % To make a Closed Loop % Set the Initial 4 points X0:=0; % Dummy Y0:=0; X1:=GETV(CAR CONPTS,0); % Will Be X0,Y0 in loop Y1:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X2:=GETV(CAR CONPTS,0); Y2:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); WHILE N > 0 DO << X0 := X1; Y0 := Y1; % Cycle Points X1 := X2; Y1 := Y2; X2 := X3; Y2 := Y3; CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); % Compute X(t) and Y(t) for NPTS points on [0.0,1.0] FOR I := 0:NPTS-1 DO << T1 := FLOAT(I)/NPTS$ % Powers of t T2 := T1 * T1; T3 := T2 * T1; %/ ( -1 3 -3 1 %/ 3 -6 3 0 %/ -3 0 3 0 %/ 1 4 1 0 ) J0:= (1.0-T3) + 3.0*(T2-T1); J1 := 3.0*T3 - 6*T2 +4.0; J2 := 1.0+ 3.0*(T1 +T2- T3); CPX := (X0*J0 +X1*J1 + X2 *J2 +X3*T3)/6.0; CPY := (Y0*J0 +Y1*J1 + Y2 *J2 +Y3*T3)/6.0; CURPTS := Pnt2(CPX, CPY,1.0) . CURPTS >>$ N := N - 1>>; Return CURPTS end$ % Faster 2-d Bezier procedure DrawBEZIER CNTS; % Give list of Points Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, T0, T1, TEMP, FACTL, TI, FI,COEFF; LEN := Isub1 LENGTH(CNTS); SaveX := MKVect Len; SaveY := MKVect Len; FACTL := IFACT LEN; FOR I := 0:LEN DO <<Coeff := FactL/(IFACT(i)*IFACT(Len-i)); SAVEX[I] := GETV(CAR CNTS, 0) * Coeff; SAVEY[I] := GETV(CAR CNTS, 1) * Coeff;; CNTS := CDR CNTS>>; NALL := 1.0/(8.0 * LEN); % Step Size FOR T0 := 0.0 STEP NALL UNTIL 1.0 DO << T1 := 1.0-T0; TI := T0; TEMP := T1**LEN; CPX := TEMP * SAVEX[0]; CPY := TEMP * SAVEY[0]; FOR I := 1:LEN DO << TEMP := (TI * (T1**(LEN - I))); TI := TI * T0; CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY) . CURPTS >>; Return REVERSE CURPTS; end; procedure IFACT N; % fast factorial Begin scalar M; M:=1; While Igreaterp(N,1) do <<M:=Itimes2(N,M); N :=Isub1 N>>; Return M; end; LoadTime SetUpVariables(); % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/3-1/util/pr2d-text.build version [c7d7007ab5].
> > | 1 2 | CompileTime load pr2d!-main; in "pr2d-text.red"$ |
Added psl-1983/3-1/util/pr2d-text.red version [f81e924f12].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 8 * 12 Vector Characters CV := MkVect(127)$ BlankChar := 'NIL$ % Labeled Points on Rectangle (8 x 12 ) % C4 Q6 S3 Q5 C3 % % % Q7 M3 Q4 % % % S4 M4 M0 M2 S2 % % % Q8 M1 Q3 % % % C1 Q1 S1 Q2 C2 % Corners: C1:={0,0}$ C2 := {8,0}$ C4:={0,12}$ C3:= {8,12}$ % Side MidPoints: S1 := {4,0}$ S3 := {4,12}$ S4 := {0,6}$ S2 := {8,6}$ % Middle: M0 := {4,6}$ M1 := {4,3}$ M2 := {6,6}$ M3 := {4,9}$ M4 := {2,6}$ % Side Quarter Points: Q1 := {2,0}$ Q2 := {6,0}$ Q3 := {8,3}$ Q4 := {8,9}$ Q5 := {6,12}$ Q6 := {2,12}$ Q7 := {0,9}$ Q8 := {0,3}$ For i:=0:127 do CV[I]:=BlankChar; % UpperCase: CV[Char A] := C1 _ S3 _ C2 & M4 _ M2$ CV[Char B] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M2 _ Q3 _ Q2 _ C1 $ CV[Char C] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char D] := C1 _ C4 _ Q5 _ Q4 _ Q3 _ Q2 _ C1$ CV[Char E] := C3 _ C4 _ C1 _ C2 & S4 _ S2$ CV[Char F] := C3 _ C4 _ C1 & S4 _ S2$ CV[Char G] := M0 _ S2 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char H] := C4 _ C1 & S4 _ S2 & C3 _ C2$ CV[Char I] := S1 _ S3$ CV[Char J] := C3 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char K] := C4 _ C1 & C3 _ S4 _ C2$ CV[Char L] := C4 _ C1 _ C2$ CV[Char M] := C1 _ C4 _ M0 _ C3 _ C2$ CV[Char N] := C1 _ C4 _ C2 _ C3$ CV[Char O] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3$ CV[Char P] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4$ CV[Char Q] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3 & C2 _ M1$ CV[Char R] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M0 _ C2$ CV[Char S] := Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char T] := C4 _ C3 & S3 _ S1$ CV[Char U] := C4 _ Q8 _ Q1 _ Q2 _ Q3 _ C3$ CV[Char V] := C4 _ S1 _ C3$ CV[Char W] := C4 _ Q1 _ M0 _ Q2 _ C3$ CV[Char X] := C1 _ C3 & C4 _ C2$ CV[Char Y] := C4 _ M0 _ C3 & M0 _ S1$ CV[Char Z] := C4 _ C3 _ C1 _ C2$ % Lower Case, Alias for Now: CV[Char Lower A] := CV[Char A]$ CV[Char Lower B] := CV[Char B]$ CV[Char Lower C] := CV[Char C]$ CV[Char Lower D] := CV[Char D]$ CV[Char Lower E] := CV[Char E]$ CV[Char Lower F] := CV[Char F]$ CV[Char Lower G] := CV[Char G]$ CV[Char Lower H] := CV[Char H]$ CV[Char Lower I] := CV[Char I]$ CV[Char Lower J] := CV[Char J]$ CV[Char Lower K] := CV[Char K]$ CV[Char Lower L] := CV[Char L]$ CV[Char Lower M] := CV[Char M]$ CV[Char Lower N] := CV[Char N]$ CV[Char Lower O] := CV[Char O]$ CV[Char Lower P] := CV[Char P]$ CV[Char Lower Q] := CV[Char Q]$ CV[Char Lower R] := CV[Char R]$ CV[Char Lower S] := CV[Char S]$ CV[Char Lower T] := CV[Char T]$ CV[Char Lower U] := CV[Char U]$ CV[Char Lower V] := CV[Char V]$ CV[Char Lower W] := CV[Char W]$ CV[Char Lower X] := CV[Char X]$ CV[Char Lower Y] := CV[Char Y]$ CV[Char Lower Z] := CV[Char Z]$ % Digits: CV[Char 0] := CV[Char O]$ CV[Char 1] := CV[Char I]$ CV[Char 2] := Q7 _ Q6 _ Q5 _ Q4 _ M0 _ C1 _ C2$ CV[Char 3] := C4 _ C3 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 4] := S1 _ S3 _ S4 _ S2$ CV[Char 5] := C3 _ C4 _ S4 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 6] := Q4 _ Q5 _ Q6 _ Q7 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M4 _ Q8$ CV[Char 7] := C4 _ C3 _ S1$ CV[Char 8] := M0 _ M4 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M0 & M2 _ Q4 _ Q5 _ Q6 _ Q7 _ M4$ CV[Char 9] := Q8 _ Q1 _ Q2 _ Q3 _ Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q4$ % Some Special Chars: CV[Char !+ ] := S1 _ S3 & S4 _ S2$ CV[Char !- ] := S4 _ S2 $ CV[Char !* ] := S1 _ S3 & S4 _ S2 & C1 _ C3 & C4 _ C2 $ CV[Char !/ ] := C1 _ C3 $ CV[Char !\ ] := C4 _ C2 $ CV[Char !( ] := Q6 _ Q7 _ Q8 _ Q1 $ CV[Char !) ] := Q5 _ Q4 _ Q3 _ Q2 $ CV[Char ![ ] := Q6 _ C4 _ C1 _ Q1$ CV[Char !] ] := Q5 _ C3 _ C2 _ Q2$ CV[Char != ] := Q7 _ Q4 & Q8 _ Q3 $ % Some Simple Display Routines: Xshift := Xmove(10)$ Yshift := Ymove(15)$ Procedure ShowString(S); <<Graphon(); ShowString1(S,Global!.Transform); Graphoff()>>; Procedure ShowString1(S,Current!.Transform); Begin scalar i,ch; For i:=0:Size S do <<Draw1(CV[S[i]],Current!.Transform); Current!.Transform := Mat!*mat(XShift,Current!.TRansform)>>; End; Procedure C x; if x:=CV[x] then EShow x; Procedure FullTest(); <<Global!.Transform := MAT!*1; ShowString "ABCDEFGHIJKLMNOPQRTSUVWXYZ 0123456789"; NIL>>; Procedure SpeedTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do C i; NIL>>; Procedure SlowTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do <<C i; Delay()>>; NIL>>; Procedure Delay; For i:=1:500 do nil; Procedure Text(S); List('TEXT,S); Put('TEXT,'PBINTRP,'DrawTEXT)$ Procedure DrawText(StartPoint,S); %. Draw a Text String Begin scalar MoveP; If IDP StartPoint then StartPoint := EVAL StartPoint$ S := CAR1 S$ If IDP S then S := EVAL S$ MoveP:=PositionAt StartPoint; ShowString1(S,Mat!*Mat(MoveP,Current!.Transform)); Return NIL; end$ Procedure PositionAt StartPoint; % return A matrix to set relative Origin << If IDP StartPoint then StartPoint := EVAL StartPoint$ Mat8(1,0,StartPoint[0], 0,1,StartPoint[1], 0,0,StartPoint[2])>>; |
Added psl-1983/3-1/util/pretty.build version [5d38e1e846].
> | 1 | in "pretty.red"$ |
Added psl-1983/3-1/util/pretty.red version [18ef06a09c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>PRETTY.RED.2, 2-Sep-82 09:16:32, Edit by BENSON % PRETTYPRINT returns NIL instead of its argument % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % A. C. Norman. July 1978; % Functions: % SUPERPRINT(X) print expression X % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = << SUPERPRINTM(X,POSN()), TERPRI() >> % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; SYMBOLIC; GLOBAL '(!*SYMMETRIC !*QUOTES THIN!*); !*SYMMETRIC:=T; !*QUOTES:=T; THIN!*:=5; SYMBOLIC PROCEDURE SUPERPRINT X; << SUPERPRINM(X,0); TERPRI(); X>>; SYMBOLIC PROCEDURE PRETTYPRINT X; << SUPERPRINM(X,POSN()); %WHAT REDUCE DOES NOW; TERPRI(); NIL >>; SYMBOLIC PROCEDURE SUPERPRINTM(X,LMAR); << SUPERPRINM(X,LMAR); TERPRI(); X >>; % FROM HERE DOWN THE FUNCTIONS ARE NOT INTENDED FOR DIRECT USE; FLUID '(STACK BUFFERI BUFFERO BN LMAR RMAR INITIALBLANKS PENDINGRPARS INDENTLEVEL INDBLANKS RPARCOUNT); SYMBOLIC PROCEDURE SUPERPRINM(X,LMAR); BEGIN SCALAR STACK,BUFFERI,BUFFERO,BN,INITIALBLANKS,RMAR, PENDINGRPARS,INDENTLEVEL,INDBLANKS,RPARCOUNT,W; BUFFERI:=BUFFERO:=LIST NIL; %FIFO BUFFER; INITIALBLANKS:=0; RPARCOUNT:=0; INDBLANKS:=0; RMAR:=LINELENGTH NIL-3; %RIGHT MARGIN; IF RMAR<25 THEN ERROR(0,LIST(RMAR+3, "LINELENGTH TOO SHORT FOR SUPERPRINTING")); BN:=0; %CHARACTERS IN BUFFER; INDENTLEVEL:=0; %NO INDENTATION NEEDED, YET; IF LMAR+20>=RMAR THEN LMAR:=RMAR-21; %NO ROOM FOR SPECIFIED MARGIN; W:=POSN(); IF W>LMAR THEN << TERPRI(); W:=0 >>; IF W<LMAR THEN INITIALBLANKS:=LMAR-W; PRINDENT(X,LMAR+3); %MAIN RECURSIVE PRINT ROUTINE; % TRAVERSE ROUTINE FINISHED - NOW TIDY UP BUFFERS; OVERFLOW 'NONE; %FLUSH OUT THE BUFFER; RETURN X END; % ACCESS FUNCTIONS FOR A STACK ENTRY; CompileTime << SMACRO PROCEDURE TOP; CAR STACK; SMACRO PROCEDURE DEPTH FRM; CAR FRM; SMACRO PROCEDURE INDENTING FRM; CADR FRM; SMACRO PROCEDURE BLANKCOUNT FRM; CADDR FRM; SMACRO PROCEDURE BLANKLIST FRM; CDDDR FRM; SMACRO PROCEDURE SETINDENTING(FRM,VAL); RPLACA(CDR FRM,VAL); SMACRO PROCEDURE SETBLANKCOUNT(FRM,VAL); RPLACA(CDDR FRM,VAL); SMACRO PROCEDURE SETBLANKLIST(FRM,VAL); RPLACD(CDDR FRM,VAL); SMACRO PROCEDURE NEWFRAME N; LIST(N,NIL,0); SMACRO PROCEDURE BLANKP CHAR; NUMBERP CAR CHAR; >>; SYMBOLIC PROCEDURE PRINDENT(X,N); % PRINT LIST X WITH INDENTATION LEVEL N; IF ATOM X THEN IF VECTORP X THEN PRVECTOR(X,N) ELSE FOR EACH C IN (IF !*SYMMETRIC THEN IF STRINGP X THEN EXPLODES X ELSE EXPLODE X ELSE EXPLODEC X) DO PUTCH C ELSE IF READMACROP X THEN << FOR EACH C IN GET(CAR X,'READMACROTOKEN) DO PUTCH C; PRINDENT(CADR X,N+GET(CAR X,'READMACROSIZE)) >> ELSE BEGIN SCALAR CX; IF 4*N>3*RMAR THEN << %LIST IS TOO DEEP FOR SANITY; OVERFLOW 'ALL; N:=N/8; IF INITIALBLANKS>N THEN << LMAR:=LMAR-INITIALBLANKS+N; INITIALBLANKS:=N >> >>; STACK := (NEWFRAME N) . STACK; PUTCH ('LPAR . TOP()); CX:=CAR X; PRINDENT(CX,N+1); IF IDP CX AND NOT ATOM CDR X THEN CX:=GET(CX,'PPFORMAT) ELSE CX:=NIL; IF CX=2 AND ATOM CDDR X THEN CX:=NIL; IF CX='PROG THEN << PUTCH '! ; PRINDENT(CAR (X:=CDR X),N+3) >>; % CX NOW CONTROLS THE FORMATTING OF WHAT FOLLOWS: % NIL DEFAULT ACTION % <NUMBER> FIRST FEW BLANKS ARE NON-INDENTING % PROG DISPLAY ATOMS AS LABELS; X:=CDR X; SCAN: IF ATOM X THEN GO TO OUTL; FINISHPENDING(); %ABOUT TO PRINT A BLANK; IF CX='PROG THEN << PUTBLANK(); OVERFLOW BUFFERI; %FORCE FORMAT FOR PROG; IF ATOM CAR X THEN << % A LABEL; LMAR:=INITIALBLANKS:=MAX(LMAR-6,0); PRINDENT(CAR X,N-3); % PRINT THE LABEL; X:=CDR X; IF NOT ATOM X AND ATOM CAR X THEN GO TO SCAN; IF LMAR+BN>N THEN PUTBLANK() ELSE FOR I:=LMAR+BN:N-1 DO PUTCH '! ; IF ATOM X THEN GO TO OUTL >> >> ELSE IF NUMBERP CX THEN << CX:=CX-1; IF CX=0 THEN CX:=NIL; PUTCH '! >> ELSE PUTBLANK(); PRINDENT(CAR X,N+3); X:=CDR X; GO TO SCAN; OUTL: IF NOT NULL X THEN << FINISHPENDING(); PUTBLANK(); PUTCH '!.; PUTCH '! ; PRINDENT(X,N+5) >>; PUTCH ('RPAR . (N-3)); IF INDENTING TOP()='INDENT AND NOT NULL BLANKLIST TOP() THEN OVERFLOW CAR BLANKLIST TOP() ELSE ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE EXPLODES X; %dummy function just in case another format is needed; EXPLODE X; SYMBOLIC PROCEDURE PRVECTOR(X,N); BEGIN SCALAR BOUND; BOUND:=UPBV X; % LENGTH OF THE VECTOR; STACK:=(NEWFRAME N) . STACK; PUTCH ('LSQUARE . TOP()); PRINDENT(GETV(X,0),N+3); FOR I:=1:BOUND DO << % PUTCH '!,; % removed "," between vector elements for PSL PUTBLANK(); PRINDENT(GETV(X,I),N+3) >>; PUTCH('RSQUARE . (N-3)); ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE PUTBLANK(); BEGIN SCALAR B; PUTCH TOP(); %REPRESENTS A BLANK CHARACTER; SETBLANKCOUNT(TOP(),BLANKCOUNT TOP()+1); SETBLANKLIST(TOP(),BUFFERI . BLANKLIST TOP()); %REMEMBER WHERE I WAS; INDBLANKS:=INDBLANKS+1 END; SYMBOLIC PROCEDURE ENDLIST L; %FIX UP THE BLANKS IN A COMPLETE LIST SO THAT THEY %WILL NOT BE TURNED INTO INDENTATIONS; PENDINGRPARS:=L . PENDINGRPARS; % WHEN I HAVE PRINTED A ')' I WANT TO MARK ALL OF THE BLANKS % WITHIN THE PARENTHESES AS BEING UNINDENTED, ORDINARY BLANK % CHARACTERS. IT IS HOWEVER POSSIBLE THAT I MAY GET A BUFFER % OVERFLOW WHILE PRINTING A STRING OF )))))))))), AND SO THIS % MARKING SHOULD BE DELAYED UNTIL I GET ROUND TO PRINTING % A FURTHER BLANK (WHICH WILL BE A CANDIDATE FOR A PLACE TO % SPLIT LINES). THIS DELAY IS DEALT WITH BY THE LIST % PENDINGRPARS WHICH HOLDS A LIST OF LEVELS THAT, WHEN % CONVENIENT, CAN BE TIDIED UP AND CLOSED OUT; SYMBOLIC PROCEDURE FINISHPENDING(); << FOR EACH STACKFRAME IN PENDINGRPARS DO << IF INDENTING STACKFRAME NEQ 'INDENT THEN FOR EACH B IN BLANKLIST STACKFRAME DO << RPLACA(B,'! ); INDBLANKS:=INDBLANKS-1 >>; % BLANKLIST OF STACKFRAME MUST BE NON-NIL SO THAT OVERFLOW % WILL NOT TREAT THE '(' SPECIALLY; SETBLANKLIST(STACKFRAME,T) >>; PENDINGRPARS:=NIL >>; SYMBOLIC PROCEDURE READMACROP X; !*QUOTES AND NOT ATOM X AND IDP CAR X AND GET(CAR X,'READMACROTOKEN) AND NOT ATOM CDR X AND NULL CDDR X; DEFLIST('( (QUOTE (!')) (BACKQUOTE (!`)) (UNQUOTE (!,)) (UNQUOTEL (!, !@)) (UNQUOTED (!, !.))), 'READMACROTOKEN); FOR EACH U IN '(QUOTE BACKQUOTE UNQUOTE) DO PUT(U,'READMACROSIZE,1); FOR EACH U IN '(UNQUOTEL UNQUOTED) DO PUT(U,'READMACROSIZE,2); % PROPERTY PPFORMAT DRIVES THE PRETTYPRINTER - % PROG : SPECIAL FOR PROG ONLY % 1 : (FN A1 % A2 % ... ) % 2 : (FN A1 A2 % A3 % ... ) ; PUT('PROG,'PPFORMAT,'PROG); PUT('LAMBDA,'PPFORMAT,1); PUT('LAMBDAQ,'PPFORMAT,1); PUT('SETQ,'PPFORMAT,1); PUT('SET,'PPFORMAT,1); PUT('WHILE,'PPFORMAT,1); PUT('T,'PPFORMAT,1); PUT('DE,'PPFORMAT,2); PUT('DF,'PPFORMAT,2); PUT('DM,'PPFORMAT,2); PUT('FOREACH,'PPFORMAT,4); % (FOREACH X IN Y DO ...) ETC; % NOW FOR THE ROUTINES THAT BUFFER THINGS ON A CHARACTER BY CHARACTER % BASIS, AND DEAL WITH BUFFER OVERFLOW; SYMBOLIC PROCEDURE PUTCH C; BEGIN IF ATOM C THEN RPARCOUNT:=0 ELSE IF BLANKP C THEN << RPARCOUNT:=0; GO TO NOCHECK >> ELSE IF CAR C='RPAR THEN << RPARCOUNT:=RPARCOUNT+1; % FORMAT FOR A LONG STRING OF RPARS IS: % )))) ))) ))) ))) ))) ; IF RPARCOUNT>4 THEN << PUTCH '! ; RPARCOUNT:=2 >> >> ELSE RPARCOUNT:=0; WHILE LMAR+BN>=RMAR DO OVERFLOW 'MORE; NOCHECK: BUFFERI:=CDR RPLACD(BUFFERI,LIST C); BN:=BN+1 END; SYMBOLIC PROCEDURE OVERFLOW FLG; BEGIN SCALAR C,BLANKSTOSKIP; %THE CURRENT BUFFER HOLDS SO MUCH INFORMATION THAT IT WILL %NOT ALL FIT ON A LINE. TRY TO DO SOMETHING ABOUT IT; % FLG IS ONE OF: % 'NONE DO NOT FORCE MORE INDENTATION % 'MORE FORCE ONE LEVEL MORE INDENTATION % <A POINTER INTO THE BUFFER> % PRINTS UP TO AND INCLUDING THAT CHARACTER, WHICH % SHOULD BE A BLANK; IF INDBLANKS=0 AND INITIALBLANKS>3 AND FLG='MORE THEN << INITIALBLANKS:=INITIALBLANKS-3; LMAR:=LMAR-3; RETURN 'MOVED!-LEFT >>; FBLANK: IF BN=0 THEN << %NO BLANK FOUND - CAN DO NO MORE FOR NOW; % IF FLG='MORE I AM IN TROUBLE AND SO HAVE TO PRINT % A CONTINUATION MARK. IN THE OTHER CASES I CAN JUST EXIT; IF NOT(FLG = 'MORE) THEN RETURN 'EMPTY; IF ATOM CAR BUFFERO THEN % CONTINUATION MARK NOT NEEDED IF LAST CHAR PRINTED WAS % SPECIAL (E.G. LPAR OR RPAR); PRIN2 "%+"; %CONTINUATION MARKER; TERPRI(); LMAR:=0; RETURN 'CONTINUED >> ELSE << SPACES INITIALBLANKS; INITIALBLANKS:=0 >>; BUFFERO:=CDR BUFFERO; BN:=BN-1; LMAR:=LMAR+1; C:=CAR BUFFERO; IF ATOM C THEN << PRINC C; GO TO FBLANK >> ELSE IF BLANKP C THEN IF NOT ATOM BLANKSTOSKIP THEN << PRINC '! ; INDBLANKS:=INDBLANKS-1; % BLANKSTOSKIP = (STACK-FRAME . SKIP-COUNT); IF C EQ CAR BLANKSTOSKIP THEN << RPLACD(BLANKSTOSKIP,CDR BLANKSTOSKIP-1); IF CDR BLANKSTOSKIP=0 THEN BLANKSTOSKIP:=T >>; GO TO FBLANK >> ELSE GO TO BLANKFOUND ELSE IF CAR C='LPAR OR CAR C='LSQUARE THEN << PRINC GET(CAR C,'PPCHAR); IF FLG='NONE THEN GO TO FBLANK; % NOW I WANT TO FLAG THIS LEVEL FOR INDENTATION; C:=CDR C; %THE STACK FRAME; IF NOT NULL BLANKLIST C THEN GO TO FBLANK; IF DEPTH C>INDENTLEVEL THEN << %NEW INDENTATION; % THIS LEVEL HAS NOT EMITTED ANY BLANKS YET; INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >>; GO TO FBLANK >> ELSE IF CAR C='RPAR OR CAR C='RSQUARE THEN << IF CDR C<INDENTLEVEL THEN INDENTLEVEL:=CDR C; PRINC GET(CAR C,'PPCHAR); GO TO FBLANK >> ELSE ERROR(0,LIST(C,"UNKNOWN TAG IN OVERFLOW")); BLANKFOUND: IF EQCAR(BLANKLIST C,BUFFERO) THEN SETBLANKLIST(C,NIL); % AT LEAST ONE ENTRY ON BLANKLIST OUGHT TO BE VALID, SO IF I % PRINT THE LAST BLANK I MUST KILL BLANKLIST TOTALLY; INDBLANKS:=INDBLANKS-1; % CHECK IF NEXT LEVEL REPRESENTS NEW INDENTATION; IF DEPTH C>INDENTLEVEL THEN << IF FLG='NONE THEN << %JUST PRINT AN ORDINARY BLANK; PRINC '! ; GO TO FBLANK >>; % HERE I INCREASE THE INDENTATION LEVEL BY ONE; IF BLANKSTOSKIP THEN BLANKSTOSKIP:=NIL ELSE << INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >> >>; %OTHERWISE I WAS INDENTING AT THAT LEVEL ANYWAY; IF BLANKCOUNT C>(THIN!*-1) THEN << %LONG THIN LIST FIX-UP HERE; BLANKSTOSKIP:=C . ((BLANKCOUNT C) - 2); SETINDENTING(C,'THIN); SETBLANKCOUNT(C,1); INDENTLEVEL:=(DEPTH C)-1; PRINC '! ; GO TO FBLANK >>; SETBLANKCOUNT(C,BLANKCOUNT C-1); TERPRI(); LMAR:=INITIALBLANKS:=DEPTH C; IF BUFFERO EQ FLG THEN RETURN 'TO!-FLG; IF BLANKSTOSKIP OR NOT (FLG='MORE) THEN GO TO FBLANK; % KEEP GOING UNLESS CALL WAS OF TYPE 'MORE'; RETURN 'MORE; %TRY SOME MORE; END; PUT('LPAR,'PPCHAR,'!(); PUT('LSQUARE,'PPCHAR,'![); PUT('RPAR,'PPCHAR,'!)); PUT('RSQUARE,'PPCHAR,'!]); |
Added psl-1983/3-1/util/printer-fix.build version [98f3bfa5e8].
> | 1 | in "printer-fix.red"$ |
Added psl-1983/3-1/util/printer-fix.red version [a9261531a4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Some patches to I/O modules Fluid '(DigitStrBase); DigitStrBase:='"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; on syslisp; smacro procedure DigitStr(); strinf LispVar DigitstrBase; syslsp procedure SysPowerOf2P Num; case Num of 1: 0; 2: 1; 4: 2; 8: 3; 16: 4; 32: 5; default: NIL end; syslsp procedure ChannelWriteSysInteger(Channel, Number, Radix); begin scalar Exponent,N1; return if (Exponent := SysPowerOf2P Radix) then ChannelWriteBitString(Channel, Number, Radix - 1, Exponent) else if Number < 0 then << ChannelWriteChar(Channel, char '!-); WriteNumber1(Channel,-(Number/Radix),Radix); % To catch largest NEG ChannelWriteChar(Channel, strbyt(DigitStr(), - MOD(Number, Radix))) >> else if Number = 0 then ChannelWriteChar(Channel, char !0) else WriteNumber1(Channel, Number, Radix); end; syslsp procedure WriteNumber1(Channel, Number, Radix); if Number = 0 then Channel else << WriteNumber1(Channel, Number / Radix, Radix); ChannelWriteChar(Channel, strbyt(Digitstr(), MOD(Number, Radix))) >>; syslsp procedure ChannelWriteBitString(Channel, Number, DigitMask, Exponent); if Number = 0 then ChannelWriteChar(Channel,char !0) else ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); syslsp procedure ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); if Number = 0 then Channel % Channel means nothing here else % just trying to fool the compiler << ChannelWriteBitStrAux(Channel, LSH(Number, -Exponent), DigitMask, Exponent); ChannelWriteChar(Channel, StrByt(DigitStr(), LAND(Number, DigitMask))) >>; |
Added psl-1983/3-1/util/prlisp-driver.red version [d8d853f1bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. PRLISP-DRIVER.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE % csp 7/13/82 % Change to only set !*EMODE to NIL if it is unbound. FLUID '(!*EMODE); % initialize emode to off loadtime <<if UnboundP '!*EMODE then !*EMODE:=NIL;>>; %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MOVETOPOINT ORIGIN >>$ Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. move pen to absolute location << HP!.GRCMD("d")$ X := HP!.NormX XDEST$ Y := HP!.NormY YDEST$ HP!.OutInt HP!.NormX XDEST$ HP!.OutChar Char '!,$ HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ X := HP!.NormX XDEST$ %. destination and draw a Y := HP!.NormY YDEST$ HP!.OutInt HP!.NormX XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.CRSRWT()$ %. waiting for input a Begin scalar P,C1,C2,a$ %. character to position HP!.GRCMD("s4^")$ %. a cursor. C1:= READ()$ C2:= READ()$ a := READ()$ P := LIST ('POINT,C1-360,C2-180,HEREPOINT[3])$ HP!.GRCMD("dkZ")$ Return a.P$ end$ Procedure HP!.BUILDP()$ %. builds a list of Begin scalar PNTLST,UNFINISHED,PNT,PNT2,ACT,GRP, %. points from cursor PRVPNT,RAD$ %. MoveS. UNFINISHED := 'T$ PNTLST := LIST(HERE,'POINTSET)$ GRP := LIST('GROUP)$ While UNFINISHED do <<UNFINISHED := HP!.CRSRWT()$ HP!.OutInt UNFINISHED$ ACT := CAR1 UNFINISHED$ PNT := PRLISPCDR UNFINISHED$ HP!.OutInt PNT$HP!.OutInt ACT$ If ACT = 32 then % draw : using "space-bar" <<DrawModel PNT$ % key. PNTLST :=PNT . PNTLST>> else If ACT = 127 then % move : using "del" key. <<MOVEPOINT (PRLISPCDR PNT)$ PNTLST := REVERSE PNTLST$ GRP := PNTLST . GRP $ PNTLST := LIST (PNT,'POINTSET)>> else If ACT = 67 then % draw circle around center <<PNT2 := POINT % passing through cursor (NILTOZERO CAR2 PNT, % using "uppercase c" key. NILTOZERO CAR3 PNT)$ RAD := DISTANCE(CCNTR, PNT2)$ DRAWCIRCLE(LIST RAD)$ PNT := LIST('CIRCLE,RAD)$ PNTLST := PNT . PNTLST >> else If ACT = 99 then % sets circle center : <<MOVEPOINT (PRLISPCDR PNT)$ % using "lowercase c" key. SETCENTER LIST PNT$ PNTLST := LIST('CENTER,PNT) . PNTLST >> else If ACT = 13 then % finish : using "Return" <<UNFINISHED := NIL$ % key. GRP := REVERSE PNTLST . GRP >> >>$ Return REVERSE GRP$ end$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff If not !*emode then echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'CRSRWT, 'HP!.CRSRWT)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. draw the line. TEK!.4BYTES (CAR2 HERE, CAR3 HERE)$ TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) If not !*emode then echooff(); Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Top . . Bottom) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; FIX(Y)+12; Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xhere,Yhere, X1, Y1,function dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; %********************************** % MPS device routines will only * % work If the MPS C library is * % resident in the system * % contact Paul Stay or Russ Fish * % University of Utah * %********************************** Procedure MPS!.DrawS (XDEST, YDEST); << X := XDEST; Y := YDEST; PSdraw2d(LIST(X,Y) ,DDDD,ABS,0,1); %draw a line from cursor 0; %do x and y coordinates >>; Procedure MPS!.MoveS (XDEST, YDEST); << X := XDEST; Y := YDEST; PSdraw2d( LIST(X,Y) , MDDD,ABS,0,1); %move to point x,y 0; >>; Procedure MPS!.Delay(); % no Delay function for mps NIL; Procedure MPS!.EraseS(); % setdisplay list to nil DISPLAY!.LIST := NIL$ Procedure MPS!.VWPORT( X1, X2, Y1, Y2); %set up viewport << PSsetscale(300); %set up scale factor X1CLIP := MAX2(-500, X1); X2CLIP := MIN2(500, X2); Y1CLIP := MAX2(-500, Y1); Y2CLIP := MIN2(500, Y2); >>; Procedure MPS!.GRAPHON(); % Check this If not !*emode then echooff(); Procedure MPS!.GRAPHOFF(); If not !*emode then echoon(); Procedure MPS!.INIT$ << PRINT "MPS IS DISPLAY DEVICE"; DEV!. := 'MPS; FNCOPY ( 'EraseS, 'MPS!.ERASE)$ % Add NORM functions FNCOPY ( 'MoveS, 'MPS!.MoveS)$ FNCOPY ( 'DrawS, 'MPS!.DrawS)$ FNCOPY ( 'VWPORT, 'MPS!.VWPORT)$ FNCOPY ( 'Delay, 'MPS!.Delay)$ FNCOPY( 'GraphOn, 'MPS!.GraphOn)$ FNCOPY( 'GraphOff, 'MPS!.GraphOff)$ PSINIT(1,0); % initialize device ERASE(); MPS!.VWPORT(-500,500,-500,500); % setup viewport Psscale(1,1,1,500); % setup scale hardware GLOBAL!.TRANSFORM := WINdoW(-300,60); >>; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen << ST!.OutChar 27; ST!.OutChar 12>>; Procedure ST!.GraphOn(); << If Not !*Emode Then EchoOff(); If !*emode then ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); << If Not !*Emode Then EchoOn(); If !*emode then ST!.OutChar 31>>$ % Maybe mixed VT-52/tek problem Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. US: sets terminal to Alpha mode. If not !*emode then ST!.OutChar 31>>$ Procedure ST!.DrawS (XDEST,YDEST)$ %. Same as MoveS but << If not !*emode then << ST!.OutChar 29$ ST!.4bytes(car2 here, car3 here)>>$ ST!.4BYTES (XDEST, YDEST)$ %. draw the line. If not !*emode then ST!.OutChar 31 >>$ Procedure PRLISP(); <<PRIN2T "Set Up for Apollo under EMODE"; !*Emode:=T; ST!.INIT()>>; Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/3-1/util/program-command-interpreter.sl version [ae09e097f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Program-Command-Interpreter.SL - Perform Program Command % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 August 1982 % Revised: 8 December 1982 % % 8-Dec-82 Alan Snyder % Changed use of DSKIN (now an EXPR). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This file redefines the start-up routine for PSL (Lisp Reader) to first read % and interpret the program command string. If the command string contains a % recognized command name, then the corresponding function is immediately % executed and the program QUITs. Otherwise, the normal top-level function % definition is restored and invoked as normal. Commands are defined using the % property PROGRAM-COMMAND (see below). This file defines only one command, % COMPILE, which is used to compile Lisp files (not RLisp files). (BothTimes (load common)) (load parse-command-string get-command-string compiler) (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (cond ((funboundp 'original-main) (copyd 'original-main 'main))) (de main () (let ((CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (CurrentScanTable* LispScanTable*) (c-list (parse-command-string (get-command-string))) (*usermode nil) (*redefmsg nil)) (perform-program-command c-list) (copyd 'main 'original-main) ) (original-main) ) (de perform-program-command (c-list) (if (not (Null c-list)) (let ((command (car c-list))) (if (StringP command) (let* ((command-id (intern (string-upcase command))) (func (get command-id 'PROGRAM-COMMAND))) (if func (apply func (list c-list)))))))) (put 'COMPILE 'PROGRAM-COMMAND 'compile-program-command) (fluid '(*quiet_faslout *WritingFASLFile)) (de compile-program-command (c-list) (setq c-list (cdr c-list)) (for (in file-name-root c-list) (do (let* ((form (list 'COMPILE-FILE file-name-root)) (*break NIL) (result (ErrorSet form T NIL)) ) (if (FixP result) (progn (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" file-name-root) )) ))) (quit)) (de compile-file (file-name-root) (let ((source-fn (string-concat file-name-root ".SL")) (binary-fn (string-concat file-name-root ".B")) (*quiet_faslout T) ) (if (not (FileP source-fn)) (printf "Unable to open source file: %w%n" source-fn) % else (printf "%n----- Compiling %w%n" source-fn binary-fn) (faslout file-name-root) (dskin source-fn) (faslend) (printf "%nDone compiling %w%n%n" source-fn) ))) |
Added psl-1983/3-1/util/psl-cref.red version [c4e8dd2cc3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % =============================================================== % CREF for PSL, requires GSORT and PSL-CREFIO.RED % Adapted from older RCREF % MLG, 6:28am Tuesday, 15 December 1981 % =============================================================== % MLG 20 Dec 1982: % Add FOR WHILE REPEAT FOREACH to EXPAND!* list % Ensures that not treated as undefined functions in processing % May need to add some other (CATCH?) % MLG 20 Dec 1982 % Add DS and DN as new ANLFN types, similar to DE, DF, DM etc %FLAG('(ANLFN CRFLAPO),'FTYPE); % To force PUTC %FLAG('(ANLFN CRFLAPO),'COMPILE); CompileTime << macro procedure DefANLFN U; list('put, MkQuote cadr U, ''ANLFN, list('function, 'lambda . cddr U)); flag('(ANLFN), 'FType); put('ANLFN, 'FunctionDefiningFunction, 'DefANLFN); >>; GLOBAL '(UNDEFG!* GSEEN!* BTIME!* EXPAND!* HAVEARGS!* NOTUSE!* NOLIST!* DCLGLB!* ENTPTS!* UNDEFNS!* SEEN!* TSEEN!* OP!*!* CLOC!* PFILES!* CURLIN!* PRETITL!* !*CREFTIME !*SAVEPROPS MAXARG!* !*CREFSUMMARY !*RLISP !*CREF !*DEFN !*MODE !*GLOBALS !*ALGEBRAICS ); FLUID '(GLOBS!* CALLS!* LOCLS!* TOPLV!* CURFUN!* DFPRINT!* ); !*ALGEBRAICS:='T; % Default is normal parse of algebraic; !*GLOBALS:='T; % Do analyse globals; !*RLISP:=NIL; % REDUCE as default; !*SAVEPROPS:=NIL; MAXARG!*:=15; % Maximum args in Standard Lisp; COMMENT EXPAND flag on these forces expansion of MACROS; EXPAND!*:='( WHILE FOREACH FOR REPEAT ); SYMBOLIC PROCEDURE STANDARDFUNCTIONS L; NOLIST!* := NCONC(DEFLIST(L,'ARGCOUNT),NOLIST!*); STANDARDFUNCTIONS '( (ABS 1) (ADD1 1) (APPEND 2) (APPLY 2) (ASSOC 2) (ATOM 1) (CAR 1) (CDR 1) (CAAR 1) (CADR 1) (CDAR 1) (CDDR 1) (CAAAR 1) (CAADR 1) (CADAR 1) (CADDR 1) (CDAAR 1) (CDADR 1) (CDDAR 1) (CDDDR 1) (CAAAAR 1) (CAAADR 1) (CAADAR 1) (CAADDR 1) (CADAAR 1) (CADADR 1) (CADDAR 1) (CADDDR 1) (CDAAAR 1) (CDAADR 1) (CDADAR 1) (CDADDR 1) (CDDAAR 1) (CDDADR 1) (CDDDAR 1) (CDDDDR 1) (CLOSE 1) (CODEP 1) (COMPRESS 1) (CONS 2) (CONSTANTP 1) (DE 3) (DEFLIST 2) (DELETE 2) (DF 3) (DIFFERENCE 2) (DIGIT 1) (DIVIDE 2) (DM 3) (DS 3) (DN 3) (EJECT 0) (EQ 2) (EQN 2) (EQUAL 2) (ERROR 2) (ERRORSET 3) (EVAL 1) (EVLIS 1) (EXPAND 2) (EXPLODE 1) (EXPT 2) (FIX 1) (FIXP 1) (FLAG 2) (FLAGP 2) (FLOAT 1) (FLOATP 1) (FLUID 1) (FLUIDP 1) (FUNCTION 1) (GENSYM 0) (GET 2) (GETD 1) (GETV 2) (GLOBAL 1) (GLOBALP 1) (GO 1) (GREATERP 2) (IDP 1) (INTERN 1) (LENGTH 1) (LESSP 2) (LINELENGTH 1) (LITER 1) (LPOSN 0) (MAP 2) (MAPC 2) (MAPCAN 2) (MAPCAR 2) (MAPCON 2) (MAPLIST 2) (MAX2 2) (MEMBER 2) (MEMQ 2) (MINUS 1) (MINUSP 1) (MIN2 2) (MKVECT 1) (NCONC 2) (NOT 1) (NULL 1) (NUMBERP 1) (ONEP 1) (OPEN 2) (PAGELENGTH 1) (PAIR 2) (PAIRP 1) (PLUS2 2) (POSN 0) (PRINC 1) (PRINT 1) (PRIN1 1) (PRIN2 1) (PROG2 2) (PUT 3) (PUTD 3) (PUTV 3) (QUOTE 1) (QUOTIENT 2) (RDS 1) (READ 0) (READCH 0) (REMAINDER 2) (REMD 1) (REMFLAG 2) (REMOB 1) (REMPROP 2) (RETURN 1) (REVERSE 1) (RPLACA 2) (RPLACD 2) (SASSOC 3) (SET 2) (SETQ 2) (STRINGP 1) (SUBLIS 2) (SUBST 3) (SUB1 1) (TERPRI 0) (TIMES2 2) (UNFLUID 1) (UPBV 1) (VECTORP 1) (WRS 1) (ZEROP 1) ); NOLIST!*:=APPEND('(AND COND LIST MAX MIN OR PLUS PROG PROG2 LAMBDA PROGN TIMES),NOLIST!*); FLAG ('(PLUS TIMES AND OR PROGN MAX MIN COND PROG LAMBDA CASE LIST), 'NARYARGS); DCLGLB!*:='(!*COMP EMSG!* !*RAISE); FLAG('(RDS DEFLIST FLAG FLUID GLOBAL REMPROP REMFLAG UNFLUID SETQ CREFOFF),'EVAL); SYMBOLIC PROCEDURE CREFON; BEGIN SCALAR A,OCRFIL,CRFIL; BTIME!*:=TIME(); DFPRINT!* := 'REFPRINT; !*DEFN := T; IF NOT !*ALGEBRAICS THEN PUT('ALGEBRAIC,'NEWNAM,'SYMBOLIC); FLAG(NOLIST!*,'NOLIST); FLAG(EXPAND!*,'EXPAND); FLAG(DCLGLB!*,'DCLGLB); % Global lists; ENTPTS!*:=NIL; % Entry points to package; UNDEFNS!*:=NIL; % Functions undefined in package; SEEN!*:=NIL; % List of all encountered functions; TSEEN!*:=NIL; % List of all encountered types not flagged FUNCTION; GSEEN!*:=NIL; % All encountered globals; PFILES!*:=NIL; % Processed files; UNDEFG!*:=NIL; % Undeclared globals encountered; CURLIN!*:=NIL; % Position in file(s) of current command ; PRETITL!*:=NIL; % T if error or questionables found ; % Usages in specific function under analysis; GLOBS!*:=NIL; % Globals refered to in this ; CALLS!*:=NIL; % Functions called by this; LOCLS!*:=NIL; % Defined local variables in this ; TOPLV!*:=T; % NIL if inside function body ; CURFUN!*:=NIL; % Current function beeing analysed; OP!*!*:=NIL; % Current op. in LAP code; SETPAGE(" Errors or questionables",NIL); END; SYMBOLIC PROCEDURE UNDEFDCHK FN; IF NOT FLAGP(FN,'DEFD) THEN UNDEFNS!* := FN . UNDEFNS!*; SYMBOLIC PROCEDURE PRINCNG U; PRINCN GETES U; SYMBOLIC PROCEDURE CREFOFF; % main call, sets up, alphabetizes and prints; BEGIN SCALAR TIM,X; DFPRINT!* := NIL; !*DEFN:=NIL; IF NOT !*ALGEBRAICS THEN REMPROP('ALGEBRAIC,'NEWNAM); %back to normal; TIM:=TIME()-BTIME!*; FOR EACH FN IN SEEN!* DO <<IF NULL GET(FN,'CALLEDBY) THEN ENTPTS!*:=FN . ENTPTS!*; UNDEFDCHK FN>>; TSEEN!*:=FOR EACH Z IN IDSORT TSEEN!* COLLECT <<REMPROP(Z,'TSEEN); FOR EACH FN IN (X:=GET(Z,'FUNS)) DO <<UNDEFDCHK FN; REMPROP(FN,'RCCNAM)>>; Z.X>>; FOR EACH Z IN GSEEN!* DO IF GET(Z,'USEDUNBY) THEN UNDEFG!*:=Z . UNDEFG!*; SETPAGE(" Summary",NIL); NEWPAGE(); PFILES!*:=PUNUSED("Crossreference listing for files:", FOR EACH Z IN PFILES!* COLLECT CDR Z); ENTPTS!*:=PUNUSED("Entry Points:",ENTPTS!*); UNDEFNS!*:=PUNUSED("Undefined Functions:",UNDEFNS!*); UNDEFG!*:=PUNUSED("Undeclared Global Variables:",UNDEFG!*); GSEEN!*:=PUNUSED("Global variables:",GSEEN!*); SEEN!*:=PUNUSED("Functions:",SEEN!*); FOR EACH Z IN TSEEN!* DO <<RPLACD(Z,PUNUSED(LIST(CAR Z," procedures:"),CDR Z)); X:='!( . NCONC(EXPLODE CAR Z,LIST '!)); FOR EACH FN IN CDR Z DO <<FN:=GETES FN; RPLACD(FN,APPEND(X,CDR FN)); RPLACA(FN,LENGTH CDR FN)>> >>; IF !*CREFSUMMARY THEN GOTO XY; IF !*GLOBALS AND GSEEN!* THEN <<SETPAGE(" Global Variable Usage",1); NEWPAGE(); FOR EACH Z IN GSEEN!* DO CREF6 Z>>; IF SEEN!* THEN CREF52(" Function Usage",SEEN!*); FOR EACH Z IN TSEEN!* DO CREF52(LIST(" ",CAR Z," procedures"),CDR Z); SETPAGE(" Toplevel calls:",NIL); X:=T; FOR EACH Z IN PFILES!* DO IF GET(Z,'CALLS) OR GET(Z,'GLOBS) THEN <<IF X THEN <<NEWPAGE(); X:=NIL>>; NEWLINE 0; NEWLINE 0; PRINCNG Z; SPACES2 15; UNDERLINE2 (LINELENGTH(NIL)-10); CREF51(Z,'CALLS,"Calls:"); IF !*GLOBALS THEN CREF51(Z,'GLOBS,"Globals:")>>; XY: IF !*SAVEPROPS THEN GOTO XX; REMPROPSS(SEEN!*,'(GALL CALLS GLOBS CALLEDBY ALSOIS SAMEAS)); REMFLAGSS(SEEN!*,'(SEEN CINTHIS DEFD)); REMPROPSS(GSEEN!*,'(USEDBY USEDUNBY BOUNDBY SETBY)); REMFLAGSS(GSEEN!*,'(DCLGLB GSEEN GLB2RF GLB2BD GLB2ST)); FOR EACH Z IN TSEEN!* DO REMPROP(CAR Z,'FUNS); FOR EACH Z IN HAVEARGS!* DO REMPROP(Z,'ARGCOUNT); HAVEARGS!* := NIL; XX: NEWLINE 2; IF NOT !*CREFTIME THEN RETURN; BTIME!*:=TIME()-BTIME!*; SETPAGE(" Timing Information",NIL); NEWPAGE(); NEWLINE 0; PRTATM " Total Time="; PRTNUM BTIME!*; PRTATM " (ms)"; NEWLINE 0; PRTATM " Analysis Time="; PRTNUM TIM; NEWLINE 0; PRTATM " Sorting Time="; PRTNUM (BTIME!*-TIM); NEWLINE 0; NEWLINE 0 END; SYMBOLIC PROCEDURE PUNUSED(X,Y); IF Y THEN <<NEWLINE 2; PRTLST X; NEWLINE 0; LPRINT(Y := IDSORT Y,8); NEWLINE 0; Y>>; SYMBOLIC PROCEDURE CREF52(X,Y); <<SETPAGE(X,1); NEWPAGE(); FOR EACH Z IN Y DO CREF5 Z>>; SYMBOLIC PROCEDURE CREF5 FN; % Print single entry; BEGIN SCALAR X,Y; NEWLINE 0; NEWLINE 0; PRIN1 FN; SPACES2 15; Y:=GET(FN,'GALL); IF Y THEN <<PRIN1 CDR Y; X:=CAR Y>> ELSE PRIN2 "Undefined"; SPACES2 25; IF FLAGP(FN,'NARYARGS) THEN PRIN2 " Nary Args " ELSE IF (Y:=GET(FN,'ARGCOUNT)) THEN <<PRIN2 " "; PRIN2 Y; PRIN2 " Args ">>; UNDERLINE2 (LINELENGTH(NIL)-10); IF X THEN <<NEWLINE 15; PRTATM '!Line!:; SPACES2 27; PRTNUM CDDR X; PRTATM '!/; PRTNUM CADR X; PRTATM " in "; PRTATM CAR X>>; CREF51(FN,'CALLEDBY,"Called by:"); CREF51(FN,'CALLS,"Calls:"); CREF51(FN,'ALSOIS,"Is also:"); CREF51(FN,'SAMEAS,"Same as:"); IF !*GLOBALS THEN CREF51(FN,'GLOBS,"Globals:") END; SYMBOLIC PROCEDURE CREF51(X,Y,Z); IF (X:=GET(X,Y)) THEN <<NEWLINE 15; PRTATM Z; LPRINT(IDSORT X,27)>>; SYMBOLIC PROCEDURE CREF6 GLB; % print single global usage entry; <<NEWLINE 0; PRIN1 GLB; SPACES2 15; NOTUSE!*:=T; CREF61(GLB,'USEDBY,"Global in:"); CREF61(GLB,'USEDUNBY,"Undeclared:"); CREF61(GLB,'BOUNDBY,"Bound in:"); CREF61(GLB,'SETBY,"Set by:"); IF NOTUSE!* THEN PRTATM "*** Not Used ***">>; SYMBOLIC PROCEDURE CREF61(X,Y,Z); IF (X:=GET(X,Y)) THEN <<IF NOT NOTUSE!* THEN NEWLINE 15 ELSE NOTUSE!*:=NIL; PRTATM Z; LPRINT(IDSORT X,27)>>; % Analyse bodies of LISP functions for % functions called, and globals used, undefined %; SMACRO PROCEDURE ISGLOB U; FLAGP(U,'DCLGLB); SMACRO PROCEDURE CHKSEEN S; % Has this name been encountered already?; IF NOT FLAGP(S,'SEEN) THEN <<FLAG1(S,'SEEN); SEEN!*:=S . SEEN!*>>; SMACRO PROCEDURE GLOBREF U; IF NOT FLAGP(U,'GLB2RF) THEN <<FLAG1(U,'GLB2RF); GLOBS!*:=U . GLOBS!*>>; SMACRO PROCEDURE ANATOM U; % Global seen before local..ie detect extended from this; IF !*GLOBALS AND U AND NOT(U EQ 'T) AND IDP U AND NOT ASSOC(U,LOCLS!*) THEN GLOBREF U; SMACRO PROCEDURE CHKGSEEN G; IF NOT FLAGP(G,'GSEEN) THEN <<GSEEN!*:=G . GSEEN!*; FLAG1(G,'GSEEN)>>; SYMBOLIC PROCEDURE DO!-GLOBAL L; % Catch global defns; % Distinguish FLUID from GLOBAL later; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; FLAG(L,'DCLGLB)>>; PUT('GLOBAL,'ANLFN,'DO!-GLOBAL); PUT('FLUID,'ANLFN,'DO!-GLOBAL); SYMBOLIC ANLFN PROCEDURE UNFLUID L; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; REMFLAG(L,'DCLGLB)>>; SYMBOLIC PROCEDURE ADD2LOCS LL; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH GG IN LL DO <<OLDLOC:=ASSOC(GG,LOCLS!*); IF NOT NULL OLDLOC THEN << QERLINE 0; PRIN2 "*** Variable "; PRIN1 GG; PRIN2 " nested declaration in "; PRINCNG CURFUN!*; NEWLINE 0; RPLACD(OLDLOC,NIL.OLDLOC)>> ELSE LOCLS!*:=(GG . LIST NIL) . LOCLS!*; IF ISGLOB(GG) OR FLAGP(GG,'GLB2RF) THEN GLOBIND GG; IF FLAGP(GG,'SEEN) THEN <<QERLINE 0; PRIN2 "*** Function "; PRINCNG GG; PRIN2 " used as variable in "; PRINCNG CURFUN!*; NEWLINE 0>> >> END; SYMBOLIC PROCEDURE GLOBIND GG; <<FLAG1(GG,'GLB2BD); GLOBREF GG>>; SYMBOLIC PROCEDURE REMLOCS LLN; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH LL IN LLN DO <<OLDLOC:=ASSOC(LL,LOCLS!*); IF NULL OLDLOC THEN IF GETD 'BEGIN THEN REDERR LIST(" Lvar confused",LL) ELSE ERROR(0,LIST(" Lvar confused",LL)); IF CDDR OLDLOC THEN RPLACD(OLDLOC,CDDR OLDLOC) ELSE LOCLS!*:=EFFACE1(OLDLOC,LOCLS!*)>> END; SYMBOLIC PROCEDURE ADD2CALLS FN; % Update local CALLS!*; IF NOT(FLAGP(FN,'NOLIST) OR FLAGP(FN,'CINTHIS)) THEN <<CALLS!*:=FN . CALLS!*; FLAG1(FN,'CINTHIS)>>; SYMBOLIC PROCEDURE ANFORM U; IF ATOM U THEN ANATOM U ELSE ANFORM1 U; SYMBOLIC PROCEDURE ANFORML L; BEGIN WHILE NOT ATOM L DO <<ANFORM CAR L; L:=CDR L>>; IF L THEN ANATOM L END; SYMBOLIC PROCEDURE ANFORM1 U; BEGIN SCALAR FN,X; FN:=CAR U; U:=CDR U; IF NOT ATOM FN THEN RETURN <<ANFORM1 FN; ANFORML U>>; IF NOT IDP FN THEN RETURN NIL ELSE IF ISGLOB FN THEN <<GLOBREF FN; RETURN ANFORML U>> ELSE IF ASSOC(FN,LOCLS!*) THEN RETURN ANFORML U; ADD2CALLS FN; CHECKARGCOUNT(FN,LENGTH U); IF FLAGP(FN,'NOANL) THEN NIL ELSE IF X:=GET(FN,'ANLFN) THEN APPLY(X,LIST U) ELSE ANFORML U END; SYMBOLIC ANLFN PROCEDURE LAMBDA U; <<ADD2LOCS CAR U; ANFORML CDR U; REMLOCS CAR U>>; SYMBOLIC PROCEDURE ANLSETQ U; <<ANFORML U; IF !*GLOBALS AND FLAGP(U:=CAR U,'GLB2RF) THEN FLAG1(U,'GLB2ST)>>; PUT('SETQ,'ANLFN,'ANLSETQ); SYMBOLIC ANLFN PROCEDURE COND U; FOR EACH X IN U DO ANFORML X; SYMBOLIC ANLFN PROCEDURE PROG U; <<ADD2LOCS CAR U; FOR EACH X IN CDR U DO IF NOT ATOM X THEN ANFORM1 X; REMLOCS CAR U>>; SYMBOLIC ANLFN PROCEDURE FUNCTION U; IF PAIRP(U:=CAR U) THEN ANFORM1 U ELSE IF ISGLOB U THEN GLOBREF U ELSE IF NULL ASSOC(U,LOCLS!*) THEN ADD2CALLS U; FLAG('(QUOTE GO),'NOANL); SYMBOLIC ANLFN PROCEDURE ERRORSET U; BEGIN SCALAR FN,X; ANFORML CDR U; IF EQCAR(U:=CAR U,'QUOTE) THEN RETURN ERSANFORM CADR U ELSE IF NOT((EQCAR(U,'CONS) OR (X:=EQCAR(U,'LIST))) AND QUOTP(FN:=CADR U)) THEN RETURN ANFORM U; ANFORML CDDR U; IF PAIRP(FN:=CADR FN) THEN ANFORM1 FN ELSE IF FLAGP(FN,'GLB2RF) THEN NIL ELSE IF ISGLOB FN THEN GLOBREF FN ELSE <<ADD2CALLS FN; IF X THEN CHECKARGCOUNT(FN,LENGTH CDDR U)>> END; SYMBOLIC PROCEDURE ERSANFORM U; BEGIN SCALAR LOCLS!*; RETURN ANFORM U END; SYMBOLIC PROCEDURE ANLMAP U; <<ANFORML CDR U; IF QUOTP(U:=CADDR U) AND IDP(U:=CADR U) AND NOT ISGLOBL U AND NOT ASSOC(U,LOCLS!*) THEN CHECKARGCOUNT(U,1)>>; FOR EACH X IN '(MAP MAPC MAPLIST MAPCAR MAPCON MAPCAN) DO PUT(X,'ANLFN,'ANLMAP); SYMBOLIC ANLFN PROCEDURE APPLY U; BEGIN SCALAR FN; ANFORML CDR U; IF QUOTP(FN:=CADR U) AND IDP(FN:=CADR FN) AND EQCAR(U:=CADDR U,'LIST) THEN CHECKARGCOUNT(FN,LENGTH CDR U) END; SYMBOLIC PROCEDURE QUOTP U; EQCAR(U,'QUOTE) OR EQCAR(U,'FUNCTION); PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); SYMBOLIC PROCEDURE OUTREF(S,VARLIS,BODY,TYPE); BEGIN SCALAR CURFUN!*,CALLS!*,GLOBS!*,LOCLS!*,TOPLV!*,A; A:=IF VARLIS MEMQ '(ANP!!ATOM ANP!!IDB ANP!!EQ ANP!!UNKNOWN) THEN NIL ELSE LENGTH VARLIS; S := OUTRDEFUN(S,TYPE,IF A THEN A ELSE GET(BODY,'ARGCOUNT)); IF A THEN <<ADD2LOCS VARLIS; ANFORM(BODY); REMLOCS VARLIS>> ELSE IF NULL BODY OR NOT IDP BODY THEN NIL ELSE IF VARLIS EQ 'ANP!!EQ THEN <<PUT(S,'SAMEAS,LIST BODY); TRAPUT(BODY,'ALSOIS,S)>> ELSE ADD2CALLS BODY; OUTREFEND S END; SYMBOLIC PROCEDURE TRAPUT(U,V,W); BEGIN SCALAR A; IF A:=GET(U,V) THEN (IF NOT(TOPLV!* OR W MEMQ A) THEN RPLACD(A,W . CDR A)) ELSE PUT(U,V,LIST W) END; SMACRO PROCEDURE TOPUT(U,V,W); IF W THEN PUT(U,V,IF TOPLV!* THEN UNION(W,GET(U,V)) ELSE W); SYMBOLIC PROCEDURE OUTREFEND S; <<TOPUT(S,'CALLS,CALLS!*); FOR EACH X IN CALLS!* DO <<REMFLAG1(X,'CINTHIS); IF NOT X EQ S THEN <<CHKSEEN X; TRAPUT(X,'CALLEDBY,S)>> >>; TOPUT(S,'GLOBS,GLOBS!*); FOR EACH X IN GLOBS!* DO <<TRAPUT(X,IF ISGLOB X THEN 'USEDBY ELSE <<CHKGSEEN X; 'USEDUNBY>>,S); REMFLAG1(X,'GLB2RF); IF FLAGP(X,'GLB2BD) THEN <<REMFLAG1(X,'GLB2BD); TRAPUT(X,'BOUNDBY,S)>>; IF FLAGP(X,'GLB2ST) THEN <<REMFLAG1(X,'GLB2ST); TRAPUT(X,'SETBY,S)>> >> >>; SYMBOLIC PROCEDURE RECREF(S,TYPE); <<QERLINE 2; PRTATM "*** Redefinition to "; PRIN1 TYPE; PRTATM " procedure, of:"; CREF5 S; REMPROPSS(S,'(CALLS GLOBS SAMEAS)); NEWLINE 2>>; SYMBOLIC PROCEDURE OUTRDEFUN(S,TYPE,V); BEGIN S:=QTYPNM(S,TYPE); IF FLAGP(S,'DEFD) THEN RECREF(S,TYPE) ELSE FLAG1(S,'DEFD); IF FLAGP(TYPE,'FUNCTION) AND (ISGLOB S OR ASSOC(S,LOCLS!*)) THEN <<QERLINE 0; PRIN2 "**** Variable "; PRINCNG S; PRIN2 " defined as function"; NEWLINE 0>>; IF V AND NOT FLAGP(TYPE,'NARYARG) THEN DEFINEARGS(S,V); PUT(S,'GALL,CURLIN!* . TYPE); GLOBS!*:=NIL; CALLS!*:=NIL; RETURN CURFUN!*:=S END; FLAG('(MACRO FEXPR),'NARYARG); SYMBOLIC PROCEDURE QTYPNM(S,TYPE); IF FLAGP(TYPE,'FUNCTION) THEN <<CHKSEEN S; S>> ELSE BEGIN SCALAR X,Y,Z; IF (Y:=GET(TYPE,'TSEEN)) AND (X:=ATSOC(S,CDR Y)) THEN RETURN CDR X; IF NULL Y THEN <<Y:=LIST ('!( . NCONC(EXPLODE TYPE,LIST '!))); PUT(TYPE,'TSEEN,Y); TSEEN!* := TYPE . TSEEN!*>>; X := COMPRESS (Z := EXPLODE S); CDR Y := (S . X) . CDR Y; Y := APPEND(CAR Y,Z); PUT(X,'RCCNAM,LENGTH Y . Y); TRAPUT(TYPE,'FUNS,X); RETURN X END; SYMBOLIC PROCEDURE DEFINEARGS(NAME,N); BEGIN SCALAR CALLEDWITH,X; CALLEDWITH:=GET(NAME,'ARGCOUNT); IF NULL CALLEDWITH THEN RETURN HASARG(NAME,N); IF N=CALLEDWITH THEN RETURN NIL; IF X := GET(NAME,'CALLEDBY) THEN INSTDOF(NAME,N,CALLEDWITH,X); HASARG(NAME,N) END; SYMBOLIC PROCEDURE INSTDOF(NAME,N,M,FNLST); <<QERLINE 0; PRIN2 "***** "; PRIN1 NAME; PRIN2 " called with "; PRIN2 M; PRIN2 " instead of "; PRIN2 N; PRIN2 " arguments in:"; LPRINT(IDSORT FNLST,POSN()+1); NEWLINE 0>>; SYMBOLIC PROCEDURE HASARG(NAME,N); <<HAVEARGS!*:=NAME . HAVEARGS!*; IF N>MAXARG!* THEN <<QERLINE 0; PRIN2 "**** "; PRIN1 NAME; PRIN2 " has "; PRIN2 N; PRIN2 " arguments"; NEWLINE 0 >>; PUT(NAME,'ARGCOUNT,N)>>; SYMBOLIC PROCEDURE CHECKARGCOUNT(NAME,N); BEGIN SCALAR CORRECTN; IF FLAGP(NAME,'NARYARGS) THEN RETURN NIL; CORRECTN:=GET(NAME,'ARGCOUNT); IF NULL CORRECTN THEN RETURN HASARG(NAME,N); IF NOT CORRECTN=N THEN INSTDOF(NAME,CORRECTN,N,LIST CURFUN!*) END; SYMBOLIC PROCEDURE REFPRINT U; BEGIN SCALAR X,Y; X:=IF CLOC!* THEN CAR CLOC!* ELSE "*TTYINPUT*"; IF (CURFUN!*:=ASSOC(X,PFILES!*)) THEN <<X:=CAR CURFUN!*; CURFUN!*:=CDR CURFUN!*>> ELSE <<PFILES!*:=(X.(CURFUN!*:=GENSYM())).PFILES!*; Y:=REVERSIP CDR REVERSIP CDR EXPLODE X; PUT(CURFUN!*,'RCCNAM,LENGTH Y . Y)>>; CURLIN!*:=IF CLOC!* THEN X.CDR CLOC!* ELSE NIL; CALLS!*:=GLOBS!*:=LOCLS!*:=NIL; ANFORM U; OUTREFEND CURFUN!* END; FLAG('(SMACRO NMACRO),'CREF); SYMBOLIC ANLFN PROCEDURE PUT U; IF TOPLV!* AND QCPUTX CADR U THEN ANPUTX U ELSE ANFORML U; PUT('PUTC,'ANLFN,GET('PUT,'ANLFN)); SYMBOLIC PROCEDURE QCPUTX U; EQCAR(U,'QUOTE) AND (FLAGP(CADR U,'CREF) OR FLAGP(CADR U,'COMPILE)); SYMBOLIC PROCEDURE ANPUTX U; BEGIN SCALAR NAM,TYP,BODY; NAM:=QCRF CAR U; TYP:=QCRF CADR U; U:=CADDR U; IF ATOM U THEN <<BODY:=QCRF U; U:='ANP!!ATOM>> ELSE IF CAR U MEMQ '(QUOTE FUNCTION) THEN IF EQCAR(U:=CADR U,'LAMBDA) THEN <<BODY:=CADDR U; U:=CADR U>> ELSE IF IDP U THEN <<BODY:=U; U:='ANP!!IDB>> ELSE RETURN NIL ELSE IF CAR U EQ 'CDR AND EQCAR(CADR U,'GETD) THEN <<BODY:=QCRF CADADR U; U:='ANP!!EQ>> ELSE IF CAR U EQ 'GET AND QCPUTX CADDR U THEN <<BODY:=QTYPNM(QCRF CADR U,CADR CADDR U); U:='ANP!!EQ>> ELSE IF CAR U EQ 'MKCODE THEN <<ANFORM CADR U; U:=QCRF CADDR U; BODY:=NIL>> ELSE <<BODY:=QCRF U; U:='ANP!!UNKNOWN>>; OUTREF(NAM,U,BODY,TYP) END; SYMBOLIC ANLFN PROCEDURE PUTD U; IF TOPLV!* THEN ANPUTX U ELSE ANFORML U; SYMBOLIC ANLFN PROCEDURE DE U; OUTDEFR(U,'EXPR); SYMBOLIC ANLFN PROCEDURE DN U; OUTDEFR(U,'NEXPR); SYMBOLIC ANLFN PROCEDURE DF U; OUTDEFR(U,'FEXPR); SYMBOLIC ANLFN PROCEDURE DM U; OUTDEFR(U,'MACRO); SYMBOLIC ANLFN PROCEDURE DS U; OUTDEFR(U,'SMACRO); SYMBOLIC PROCEDURE OUTDEFR(U,TYPE); OUTREF(CAR U,CADR U,CADDR U,TYPE); SYMBOLIC PROCEDURE QCRF U; IF NULL U OR U EQ T THEN U ELSE IF EQCAR(U,'QUOTE) THEN CADR U ELSE <<ANFORM U; COMPRESS EXPLODE '!?VALUE!?!?>>; FLAG('(EXPR FEXPR MACRO SMACRO NMACRO),'FUNCTION); CommentOutCode << % Lisp 1.6 LAP only SYMBOLIC ANLFN PROCEDURE LAP U; IF PAIRP(U:=QCRF CAR U) THEN BEGIN SCALAR GLOBS!*,LOCLS!*,CALLS!*,CURFUN!*,TOPLV!*,X; WHILE U DO <<IF PAIRP CAR U THEN IF X:=GET(OP!*!*:=CAAR U,'CRFLAPO) THEN APPLY(X,LIST U) ELSE IF !*GLOBALS THEN FOR EACH Y IN CDAR U DO ANLAPEV Y; U:=CDR U>>; QOUTREFE() END; SYMBOLIC CRFLAPO PROCEDURE !*ENTRY U; <<QOUTREFE(); U:=CDAR U; OUTRDEFUN(CAR U,CADR U,CADDR U)>>; SYMBOLIC PROCEDURE QOUTREFE; BEGIN IF NULL CURFUN!* THEN IF GLOBS!* OR CALLS!* THEN <<CURFUN!*:=COMPRESS EXPLODE '!?LAP!?!?; CHKSEEN CURFUN!*>> ELSE RETURN; OUTREFEND CURFUN!* END; SYMBOLIC CRFLAPO PROCEDURE !*LAMBIND U; FOR EACH X IN CADDAR U DO GLOBIND CAR X; SYMBOLIC CRFLAPO PROCEDURE !*PROGBIND U; FOR EACH X IN CADAR U DO GLOBIND CAR X; SYMBOLIC PROCEDURE LINCALL U; <<ADD2CALLS CAR (U:=CDAR U); CHECKARGCOUNT(CAR U,CADDR U)>>; PUT('!*LINK,'CRFLAPO,'LINCALL); PUT('!*LINKE,'CRFLAPO,'LINCALL); SYMBOLIC PROCEDURE ANLAPEV U; IF PAIRP U THEN IF CAR U MEMQ '(GLOBAL FLUID) THEN <<U:=CADR U; GLOBREF U; IF FLAGP(OP!*!*,'STORE) THEN PUT(U,'GLB2ST,'T)>> ELSE <<ANLAPEV CAR U; ANLAPEV CDR U>>; FLAG('(!*STORE),'STORE); FLAG('(POP MOVEM SETZM HRRZM),'STORE); SYMBOLIC PROCEDURE LAPCALLF U; BEGIN SCALAR FN; RETURN IF EQCAR(CADR (U:=CDAR U),'E) THEN <<ADD2CALLS(FN:=CADADR U); CHECKARGCOUNT(FN,CAR U)>> ELSE IF !*GLOBALS THEN ANLAPEV CADR U END; PUT('JCALL,'CRFLAPO,'LAPCALLF); PUT('CALLF,'CRFLAPO,'LAPCALLF); PUT('JCALLF,'CRFLAPO,'LAPCALLF); SYMBOLIC CRFLAPO PROCEDURE CALL U; IF NOT(CADDAR U = '(E !*LAMBIND!*)) THEN LAPCALLF U ELSE WHILE ((U:=CDR U) AND PAIRP CAR U AND CAAR U = 0) DO GLOBIND CADR CADDAR U; >>; SYMBOLIC PROCEDURE QERLINE U; IF PRETITL!* THEN NEWLINE U ELSE <<PRETITL!*:=T; NEWPAGE()>>; % These functions defined to be able to run in bare LISP % EQCAR MKQUOTE SYMBOLIC PROCEDURE EFFACE1(U,V); IF NULL V THEN NIL ELSE IF U EQ CAR V THEN CDR V ELSE RPLACD(V,EFFACE1(U,CDR V)); MAXARG!*:=15; END; |
Added psl-1983/3-1/util/psl-crefio.red version [27d4083135].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % =============================================================== % General Purpose I/O package for CREF, adapted to PSL % MLG, 6:19am Tuesday, 15 December 1981 % =============================================================== %============================================================================== % 11/18/82 - rrk - The function REMPROPSS was being called from RECREF in the % redefintion of a procedure with a single procedure name as the first % argument. This somehow caused the routine to go into an infinite loop. A % quick to turn the ID into a list within REMPROPSS solves the problem. The % reason that the call to REMPROPSS was not changed, is because it is not % clear if in some cases the argument will be a list. %============================================================================== GLOBAL '(!*FORMFEED ORIG!* LNNUM!* MAXLN!* TITLE!* PGNUM!* ); % FLAGS: FORMFEED (ON) controls ^L or spacer of ====; SYMBOLIC PROCEDURE INITIO(); % Set-up common defaults; BEGIN !*FORMFEED:=T; ORIG!*:=0; LNNUM!*:=0; LINELENGTH(75); MAXLN!*:=55; TITLE!*:=NIL; PGNUM!*:=1; END; SYMBOLIC PROCEDURE LPOSN(); LNNUM!*; INITIO(); SYMBOLIC PROCEDURE SETPGLN(P,L); BEGIN IF P THEN MAXLN!*:=P; IF L THEN LINELENGTH(L); END; % We use EXPLODE to produce a list of chars from atomname, % and TERPRI() to terminate a buffer..all else % done in package..spaces,tabs,etc. ; COMMENT Character lists are (length . chars), for FITS; SYMBOLIC PROCEDURE GETES U; % Returns for U , E=(Length . List of char); BEGIN SCALAR E; IF NOT IDP U THEN RETURN<<E:=EXPLODE U;LENGTH(E).E>>; IF NOT(E:=GET(U,'RCCNAM)) THEN <<E:=EXPLODE(U); E:=LENGTH(E) . E; PUT(U,'RCCNAM,E)>>; RETURN E; END; SYMBOLIC SMACRO PROCEDURE PRTWRD U; IF NUMBERP U THEN PRTNUM U ELSE PRTATM U; SYMBOLIC PROCEDURE PRTATM U; PRIN2 U; % For a nice print; SYMBOLIC PROCEDURE PRTLST U; IF ATOM U THEN PRIN2 U ELSE FOR EACH X IN U DO PRIN2 X; SYMBOLIC PROCEDURE PRTNUM N; PRIN2 N; SYMBOLIC PROCEDURE PRINCN E; % output a list of chars, update POSN(); WHILE (E:=CDR E) DO PRINC CAR E; CommentOutCode << % Defined in PSL SYMBOLIC PROCEDURE SPACES N; FOR I:=1:N DO PRINC '! ; SYMBOLIC PROCEDURE SPACES2 N; BEGIN SCALAR X; X := N - POSN(); IF X<1 THEN NEWLINE N ELSE SPACES X; END; >>; SYMBOLIC PROCEDURE SETPAGE(TITLE,PAGE); % Initialise current page and title; BEGIN TITLE!*:= TITLE ; PGNUM!*:=PAGE; END; SYMBOLIC PROCEDURE NEWLINE N; % Begins a fresh line at posn N; BEGIN LNNUM!*:=LNNUM!*+1; IF LNNUM!*>=MAXLN!* THEN NEWPAGE() ELSE TERPRI(); SPACES(ORIG!*+N); END; SYMBOLIC PROCEDURE NEWPAGE(); % Start a fresh page, with PGNUM and TITLE, if needed; BEGIN SCALAR A; A:=LPOSN(); LNNUM!*:=0; IF POSN() NEQ 0 THEN NEWLINE 0; IF A NEQ 0 THEN FORMFEED(); IF TITLE!* THEN <<SPACES2 5; PRTLST TITLE!*>>; SPACES2 (LINELENGTH(NIL)-4); IF PGNUM!* THEN <<PRTNUM PGNUM!*; PGNUM!*:=PGNUM!*+1>> ELSE PGNUM!*:=2; NEWLINE 10; NEWLINE 0; END; SYMBOLIC PROCEDURE UNDERLINE2 N; IF N>=LINELENGTH(NIL) THEN <<N:=LINELENGTH(NIL)-POSN(); FOR I:=0:N DO PRINC '!- ; NEWLINE(0)>> ELSE BEGIN SCALAR J; J:=N-POSN(); FOR I:=0:J DO PRINC '!-; END; SYMBOLIC PROCEDURE LPRINT(U,N); % prints a list of atoms within block LINELENGTH(NIL)-n; BEGIN SCALAR E, L,M; SPACES2 N; L := LINELENGTH NIL-POSN(); IF L<=0 THEN ERROR(13,"WINDOW TOO SMALL FOR LPRINT"); WHILE U DO <<E:=GETES CAR U; U:=CDR U; IF LINELENGTH NIL<POSN() THEN NEWLINE N; IF CAR E<(M := LINELENGTH NIL-POSN()) THEN PRINCN E ELSE IF CAR E<L THEN <<NEWLINE N; PRINCN E>> ELSE BEGIN E := CDR E; A: FOR I := 1:M DO <<PRINC CAR E; E := CDR E>>; NEWLINE N; IF NULL E THEN NIL ELSE IF LENGTH E<(M := L) THEN PRINCN(NIL . E) ELSE GO TO A END; PRINC '! >> END; % 11/18/82 rrk - Infinite loop caused by calls to this function with an % id as the ATMLST instead of a list. A quick patch to turn the single % id into a list is provided, eliminating the infinite loop. SYMBOLIC PROCEDURE REMPROPSS(ATMLST,LST); << IF NOT PAIRP ATMLST THEN ATMLST := LIST (ATMLST); WHILE ATMLST DO <<WHILE LST DO <<REMPROP(CAR ATMLST,CAR LST); LST:=CDR LST>>; ATMLST:=CDR ATMLST>> >>; SYMBOLIC PROCEDURE REMFLAGSS(ATMLST,LST); WHILE LST DO <<REMFLAG(ATMLST,CAR LST); LST:=CDR LST>>; CommentOutCode << % These are defined EXPRs in PSL SMACRO PROCEDURE REMFLAG1(U,V); REMFLAG(LIST U,V); SMACRO PROCEDURE FLAG1(U,V); FLAG(LIST U,V); >>; SYMBOLIC PROCEDURE FORMFEED; IF !*FORMFEED THEN EJECT() ELSE <<TERPRI(); PRIN2 " ========================================= "; TERPRI()>>; |
Added psl-1983/3-1/util/psl-input-stream.sl version [326ea20ca1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PSL-Input-Stream.SL - File Input Stream Objects (Portable PSL Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % % Summary of public functions: % % (setf s (open-input "file name")) % generates error on failure % (setf s (attempt-to-open-input "file name")) % returns NIL on failure % (setf ch (=> s getc)) % read character (map CRLF to LF) % (setf ch (=> s getc-image)) % read character (don't map CRLF to LF) % (setf ch (=> s peekc)) % peek at next character % (setf ch (=> s peekc-image)) % peek at next character (don't map CRLF to LF) % (setf str (=> s getl)) % Read a line; return string without terminating LF. % (=> s empty?) % Are there no more characters? % (=> s close) % Close the file. % (setf fn (=> s file-name)) % Return "true" name of file. % (setf date (=> s read-date)) % Return date that file was last read. % (setf date (=> s write-date)) % Return date that file was last written. % (=> s delete-file) % Delete the associated file. % (=> s undelete-file) % Undelete the associated file. % (=> s delete-and-expunge) % Delete and expunge the associated file. % (setf name (=> s author)) % Return the name of the file's author. % (setf name (=> s original-author)) % Return the original author's name. % (setf count (=> s file-length)) % Return the byte count of the file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (BothTimes (load objects)) (de attempt-to-open-input (file-name) (let ((p (ErrorSet (list 'open-input file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-input (file-name) (let ((s (make-instance 'input-stream))) (=> s open file-name) s)) (defflavor input-stream ((chn NIL) % PSL "channel" eof-flag % T => EOF has been detected file-name % file name given to OPEN ) () (gettable-instance-variables file-name) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (input-stream getc) () % Return the next character from the file. Line termination is represented % by a single NEWLINE (LF) character. Returns NIL on end of file. (if (not eof-flag) (let ((ch (ChannelReadChar chn))) (if (= ch #\EOF) (prog () (setf eof-flag T)) % return NIL on EOF ch % return the character, otherwise )))) (defmethod (input-stream getc-image) () (=> self getc)) (defmethod (input-stream empty?) () (null (=> self peekc-image))) (defmethod (input-stream peekc) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. (let ((ch (=> self getc))) (when ch (ChannelUnReadChar chn ch) ch))) (defmethod (input-stream peekc-image) () (=> self peekc)) (defmethod (input-stream getl) () % Read and return (the remainder of) the current input line. % Read, but don't return the terminating EOL (if any). % Return NIL if no characters and end-of-file detected. (let ((s "")) (while T (let ((ch (=> self getc))) (if (null ch) (exit (if (string-empty? s) NIL s))) (if (= ch #\EOL) (exit s)) (setf s (string-concat s (string ch))) )))) (defmethod (input-stream tell-position) () NIL ) (defmethod (input-stream seek-position) (p) ) (defmethod (input-stream open) (name-of-file) % Open the specified file for input via SELF. If the file cannot be opened, % a Continuable Error is generated. (if chn (=> self close)) (setf eof-flag NIL) (setf chn (open name-of-file 'input)) (setf file-name (copystring name-of-file)) ) (defmethod (input-stream close) () (when chn (close chn) (setf chn NIL) (setf eof-flag T) )) (defmethod (input-stream read-date) () 0) (defmethod (input-stream write-date) () 0) (defmethod (input-stream delete-file) () ) (defmethod (input-stream undelete-file) () ) (defmethod (input-stream delete-and-expunge-file) () ) (defmethod (input-stream author) () "") (defmethod (input-stream original-author) () "") (defmethod (input-stream file-length) () 0) |
Added psl-1983/3-1/util/psl-output-stream.sl version [88bbd855f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PSL-Output-Stream.SL - File Output Stream Objects (Portable PSL Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings)) (BothTimes (load objects)) (de attempt-to-open-output (file-name) (let ((p (ErrorSet (list 'open-output file-name) NIL NIL))) (and (PairP p) (car p)) )) (de attempt-to-open-append (file-name) (let ((p (ErrorSet (list 'open-append file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-output (file-name) (let ((s (make-instance 'output-stream))) (=> s open file-name) s)) (de open-append (file-name) (let ((s (make-instance 'output-stream))) (=> s open-append file-name) s)) (defflavor output-stream ((chn NIL) % PSL "channel" file-name % file name given to open ) () (gettable-instance-variables file-name) ) (defmethod (output-stream putc) (ch) % Append the character CH to the file. Line termination is indicated by % writing a single NEWLINE (LF) character. (ChannelWriteChar chn ch) ) (defmethod (output-stream put-newline) () % Output a line terminator. (ChannelWriteChar chn #\EOL) ) (defmethod (output-stream putc-image) (ch) (ChannelWriteChar chn ch) ) (defmethod (output-stream puts) (str) (for (from i 0 (string-upper-bound str)) (do (=> self putc (string-fetch str i))) )) (defmethod (output-stream putl) (str) % Write string followed by line terminator to output stream. (=> self puts str) (=> self put-newline) ) (defmethod (output-stream open) (name-of-file) % Open the specified file for output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if chn (=> self close)) (setf chn (open name-of-file 'output)) (setf file-name (copystring name-of-file)) ) (defmethod (output-stream open-append) (name-of-file) (=> self open name-of-file)) (defmethod (output-stream close) () (when chn (close chn) (setf chn NIL) )) (defmethod (output-stream flush) () ) |
Added psl-1983/3-1/util/pslcomp-main.sl version [559924f839].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PSLCOMP-MAIN.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % Revised: 8 December 1982 % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This file redefines the start-up routine for PSLCOMP to read and interpret % the program command string as a list of source files to be compiled. % Edit by Cris Perdue, 8 Apr 1983 1401-PST % Compile-files now does exitlisp rather than quit. % EvIn is only given a definition if not already defined. % Syntax is assumed to be LISP if given a crazy file extension. % Edit by Cris Perdue, 5 Apr 1983 1421-PST % Changed to use get-command-args rather than get-command-string % and parse-command-string. % Uses EVIN to read the file, thus compiles any type of file. % If no extension specified, tries "sl", "build", and "red" extensions. % Defines EVIN to load RLISP if needed. This also gets around the % problem of starting up in the RLISP top level with RLISP % loaded. % Now uses ErrSet rather than ErrorSet. % 8-Dec-82 Alan Snyder % Changed use of DSKIN (now an EXPR). (CompileTime (load common pathnames)) (imports '(pathnamex get-command-args compiler)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (fluid '(*quiet_faslout *WritingFASLFile)) (cond ((funboundp 'original-main) (copyd 'original-main 'main))) (de main () (let ((CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (CurrentScanTable* LispScanTable*) (c-list (get-command-args)) (*usermode nil) (*redefmsg nil)) (compile-files c-list) (copyd 'main 'original-main) ) (original-main) ) (de pslcomp () % Not in use. /csp (let ((*usermode nil) (*redefmsg nil)) (compile-files (get-command-args)))) (if (funboundp 'evin) (de evin (x) (load rlisp) (eval (list 'in x)))) % Hack. /csp (de compile-files (c-list) (cond ((null c-list) (PrintF "Portable Standard Lisp Compiler%n") (PrintF "Usage: PSLCOMP source-file ...%n") ) (t (for (in fn c-list) (do (attempt-to-compile-file fn)) ) (exitlisp) ))) (de attempt-to-compile-file (fn) (let* ((*break NIL) (result (ErrSet (compile-file fn) T)) ) (cond ((FixP result) (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" fn) )) )) (de compile-file (fn) (let* ((pathname (pathname fn)) (source-names (cond ((pathname-type pathname) (list (namestring pathname))) (t (for (in ext '("build" "sl" "red")) (collect (namestring (pathname-set-default-type pathname ext))))))) (binary-fn (namestring (pathname-set-type fn "b"))) (*quiet_faslout T) (type NIL) ) (for (in source-fn source-names) (do (cond ((FileP source-fn) (printf "%n----- Compiling %w%n" source-fn) (faslout (namestring (pathname-without-type binary-fn))) (setq type (pathname-type (pathname source-fn))) (funcall (cond ((string-equal type "sl") 'dskin) ((string-equal type "build") 'evin) ((string-equal type "red") 'evin) (t 'dskin)) source-fn) (faslend) (printf "%nDone compiling %w%n%n" source-fn) (return t) ))) (finally (printf "Unable to find source file for: %w%n" fn))))) |
Added psl-1983/3-1/util/rawbreak.build version [7179ba0ee3].
> | 1 | in "rawbreak.red"$ |
Added psl-1983/3-1/util/rawbreak.red version [3817b60e20].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % RAWBREAK.RED - A safer break loop if RAWIO is loaded % MLG 16 Jan 1983 FLUID '(!*RAWIO); CopyD('OldBreak,'break); procedure newbreak(); Begin scalar OldRaw,x; OldRaw :=!*RawIo; If OldRaw then EchoOn(); x:=OldBreak(); If OldRaw Then EchoOff(); return x; End; Copyd('break,'newbreak); flag('break,'lose); |
Added psl-1983/3-1/util/rawio.red version [45a78adf61].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % RAWIO.RED - Support routines for PSL Emode % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981, 1982 University of Utah % Modified and maintained by William F. Galway. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DEC-20 version FLUID '(!*rawio); % T if terminal is using "raw" i.o. CompileTime << load if!-system; load syslisp$ off UserMode; % csp 8/20/82 if_system(Dec20, << load monsym$ load jsys$ >>) >>; BothTimes if_system(Dec20, % CompileTime probably suffices. << FLUID '( % Global? OldCCOCWords OldTIW OldJFNModeWord ); lisp procedure BITS1 U; if not NumberP U then Error(99, "Non-numeric argument to BITS") else lsh(1, 35 - U); macro procedure BITS U; begin scalar V; V := 0; for each X in cdr U do V := lor(V, BITS1 X); return V; end; >>); LoadTime if_system(Dec20, << OldJfnModeWord := NIL; % Flag "modes not saved yet" lap '((!*entry PBIN expr 0) % Read a single character from the TTY as a Lisp integer (pbin) % Issue PBIN (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry PBOUT expr 1) % write a single charcter to the TTY, works for integers and single char IDs % Don't bother with Int2Sys? (pbout) (!*exit 0) ); lap '((!*entry CharsInInputBuffer expr 0) % Returns the number of characters in the terminal input buffer. (!*MOVE (WConst 8#101) (reg 1)) % The input file (the terminal, = % 8#101) (sibe) % skip if input buffer empty (skipa (reg 1) (reg 2)) % otherwise # chars in r2 (setz (reg 1) 0) % if skipped, then zero (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry RFMOD expr 1) % returns the JFN mode word as Lisp integer (hrrzs (reg 1)) (rfmod) (!*MOVE (reg 2) (reg 1)) % Get mode word from R2 (!*CALL Sys2Int) (!*exit 0) ); lap '((!*entry RFCOC expr 1) % returns the 2 CCOC words for JFN as dotted pair of Lisp integers (hrrzs (reg 1)) (rfcoc) (!*PUSH (reg 2)) % save the first word (!*MOVE (reg 3) (reg 1)) (!*CALL Sys2Int) % make second into number (exch (reg 1) (indexed (reg st) 0)) % grab first word, save % tagged 2nd word. (!*CALL Sys2Int) % make first into number (!*POP (reg 2)) (!*JCALL Cons) % and cons them together ); lap '((!*entry RTIW expr 1) % Returns terminal interrupt word for specified process, or -5 for entire job, % as Lisp integer (hrrzs (reg 1)) % strip tag (rtiw) (!*MOVE (reg 2) (reg 1)) % result in r2, return in r1 (!*JCALL Sys2Int) % return as Lisp integer ); lisp procedure SaveInitialTerminalModes(); % Save the terminal modes, if not already saved. if null OldJfnModeWord then << OldJFNModeWord := RFMOD(8#101); OldCCOCWords := RFCOC(8#101); OldTIW := RTIW(-5); >>; lap '((!*entry SFMOD expr 2) % SFMOD(JFN, ModeWord); % set program related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (sfmod) (!*exit 0) ); lap '((!*entry STPAR expr 2) % STPAR(JFN, ModeWord); % set device related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stpar) (!*exit 0) ); lap '((!*entry SFCOC expr 3) % SFCOC(JFN, CCOCWord1, CCOCWord2); % set control character output control for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*PUSH (reg 3)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (exch (reg 1) (indexed (reg st) 0)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (sfcoc) (!*exit 0) ); lap '((!*entry STIW expr 2) % STIW(JFN, ModeWord); % set terminal interrupt word for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stiw) (!*exit 0) ); lisp procedure EchoOff(); % A bit of a misnomer, perhaps "on_rawio" would be better. % Off echo, On formfeed, send all control characters % Allow input of 8-bit characters (meta key) if not !*rawio then % Avoid doing anything if already "raw mode" << SaveInitialTerminalModes(); % Note that 8#101, means "the terminal". % Clear bit 24 to turn echo off, % bits 28,29 turn off "translation" SFMOD(8#101, LAND(OldJFNModeWord, LNOT BITS(24, 28, 29))); % Set bit 0 to indicate "has mechanical tab" (so cntrl-L gets % through?). % Clear bit 34 to turn off cntrl-S/cntrl-Q STPAR(8#101, LAND(lor(OldJFNModeWord, BITS 1), LNOT BITS(34))); % More nonsense to turn off processing of control characters? SFCOC(8#101, LNOT(8#252525252525), LNOT(8#252525252525)); % Turn off terminal interrupts for entire job (-5), for everything % except cntrl-C (the bit number three that's one). STIW(-5,8#040000000000); !*rawio := T; % Turn on flag >>; lisp procedure EchoOn(); % Restore initial terminal echoing modes << % Avoid doing anything if OldJFNModeWord is NIL, means terminal mode % already "restored". if OldJFNModeWord then << SFMOD(8#101,OldJFNModeWord); STPAR(8#101,OldJFNModeWord); SFCOC(8#101,car OldCCOCWords,cdr OldCCOCWords); STIW(-5,OldTIW); >>; % Set to NIL so that things get saved again by % SaveInitialTerminalModes. (The terminal status may have been changed % between times.) OldJFNModeWord := NIL; !*rawio := NIL; % Indicate "cooked" i/o. >>; % Flush output buffer for stdoutput. (On theory that we're using buffered % I/O to speed things up.) Symbolic Procedure FlushStdOutputBuffer(); NIL; % Just a dummy routine for the 20. >> ); % END OF DEC-20 version. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % VAX Unix version LoadTime if_system(Unix, << % EchoOn, EchoOff, and CharsInInputBuffer are part of "kernel". Symbolic Procedure PBIN(); % Read a "raw character". NOTE--assumption that 0 gives terminal input. VaxReadChar(0); % Just call this with "raw mode" on. Symbolic Procedure PBOUT(chr); % NOTE ASSUMPTION that 1 gives terminal output. VaxWriteChar(1,chr); >>); % END OF Unix version. fluid '(!*EMODE); LoadTime << !*EMODE := NIL; Symbolic Procedure rawio_break(); % Redefined break handler to turn echoes back on after a break, unless % EMODE is running. << if !*rawio and not !*EMODE then EchoOn(); pre_rawio_break(); % May want to be paranoid and use a "catch(nil, % '(pre_rawio_break)" here. >>; % Carefully redefine the break handler. if null getd('pre_rawio_break) then << CopyD('pre_rawio_break, 'Break); CopyD('break, 'rawio_break); >>; >>; |
Added psl-1983/3-1/util/rcref.build version [80e3e73931].
> > > > | 1 2 3 4 | % changed to LOAD GSORT when needed. in "psl-crefio.red"$ Imports '(Gsort); in "psl-cref.red"$ |
Added psl-1983/3-1/util/read-macros.sl version [1166665d06].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % READ-MACROS.SL - some specilized reader macros % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % Edit by Cris Perdue, 1 Feb 1983 1400-PST % Dochar moved into "nonkernel", "C" for "CONTROL", etc. commented out. % Many miscellaneous symbolic names for characters removed. ((lambda (o-table) (setq LispScanTable* (TotalCopy o-table)) % in case it's in pure space (cond ((eq CurrentScanTable* o-table) (setq CurrentScanTable* LispScanTable*)))) LispScanTable*) % plug backquote and friends into the lisp reader via read macros % ` for backquote, , for unquote, ,@ for unquotel, and ,. for unquoted (de backquote-read-macro (channel qt) (list 'backquote (ChannelReadTokenWithHooks channel))) (de unquote-read-macro (channel qt) (list 'unquote (ChannelReadTokenWithHooks channel))) (de unquotel-read-macro (channel qt) (list 'unquotel (ChannelReadTokenWithHooks channel))) (de unquoted-read-macro (channel qt) (list 'unquoted (ChannelReadTokenWithHooks channel))) (putv LispScanTable* (char !`) 11) (putv LispScanTable* (char !,) 13) (put '!, (getv LispScanTable* 128) '((!@ . !,!@)(!. . !,!.))) (deflist '((!` backquote-read-macro) (!, unquote-read-macro) (!,!@ unquotel-read-macro) (!,!. unquoted-read-macro)) 'LispReadMacro) % A couple of MACLISP style sharp sign read macros... (putv LispScanTable* (char !#) 13) (put '!# (getv LispScanTable* 128) '((!. . !#!.) (!/ . !#!/) (!' . !#!') (!+ . !#!+) (!- . !#!-) (!\ . !#!\))) (deflist `((!#!' ,(function function-read-macro)) (!#!. ,(function eval-read-macro)) (!#!\ ,(function char-read-macro)) (!#!+ ,(function if-system-read-macro)) (!#!- ,(function if-not-system-read-macro)) (!#!/ ,(function single-char-read-macro))) 'LispReadMacro) (de function-read-macro (channel qt) `(function ,(ChannelReadTokenWithHooks channel))) (de eval-read-macro (channel qt) (eval (ChannelReadTokenWithHooks channel))) % (imports '(if-system)) % actually doesn't use the code, just the convention (fluid '(system_list*)) (de if-system-read-macro (channel qt) ((lambda (system) ((lambda (when_true) (cond ((memq system system_list*) when_true) (t (ChannelReadTokenWithHooks channel)))) (ChannelReadTokenWithHooks channel))) (ChannelReadTokenWithHooks channel))) (de if-not-system-read-macro (channel qt) ((lambda (system) ((lambda (when_false) (cond ((not (memq system system_list*)) when_false) (t (ChannelReadTokenWithHooks channel)))) (ChannelReadTokenWithHooks channel))) (ChannelReadTokenWithHooks channel))) %(de when-read-macro (channel qt) % (let ((a (ChannelReadTokenWithHooks channel))) % (let ((b (ChannelReadTokenWithHooks channel)) % (fn (and (idp a) (get a 'when-macro)))) % (if fn % (apply fn (list b)) % (StdError (BldMsg "Can't evaluate %r at %r time" b a)))))) % CompileTime and friends have to be made to work from LISP before these % will be of much use. %(foreach u in '(compile c CompileTime compile-time comp) do % (put u 'when-macro #'(lambda(x) `(CompileTime ,x)))) %(foreach u in '(load l LoadTime load-time) do % (put u 'when-macro #'(lambda(x) `(LoadTime ,x)))) %(foreach u in '(both b BothTimes both-times BothTime both-time) do % (put u 'when-macro #'(lambda(x) `(BothTimes ,x)))) %(foreach u in '(read r ReadTime read-time) do % (put u 'when-macro #'eval)) (de single-char-read-macro (channel qt) (ChannelReadChar channel)) % % Frightfully kludgey. Anybody know how to just read the one character? % ((lambda (*raise) % ((lambda (ch) % ((lambda (n) % (if (lessp n 128) % n % (StdError (BldMsg "%r is illegal after #/" ch)))) % (dochar ch))) % (ChannelReadTokenWithHooks channel))) % nil)) (de char-read-macro (channel qt) (dochar (ChannelReadTokenWithHooks channel))) % Definition of dochar moved to char-macro.sl in the kernel /csp % Alternative modifiers (below) removed, hope they aren't needed (yuk) /csp % (put 'c 'char-prefix-function (get 'control 'char-prefix-function)) % (put '!^ 'char-prefix-function (get 'control 'char-prefix-function)) % (put 'm 'char-prefix-function (get 'meta 'char-prefix-function)) (commentoutcode (deflist % let char know all about the "standard" two and three letter names for % non-printing ASCII characters. '((NUL 0) (SOH 1) (STX 2) (ETX 3) (EOT 4) (ENQ 5) (ACK 6) (BEL 7) (BS 8) (HT 9) (NL 10) (VT 11) (NP 12) (CR 13) (SO 14) (SI 15) (DLE 16) (DC1 17) (DC2 18) (DC3 19) (DC4 20) (NAK 21) (SYN 22) (ETB 23) (CAN 24) (EM 25) (SUB 26) (ESC 27) (FS 28) (GS 29) (RS 30) (US 31) (SP 32) (DEL 127)) 'charconst) ) (commentoutcode (deflist '((!^!@ 0) % "creeping featurism" here for sure... (!^A 1) (!^B 2) (!^C 3) (!^D 4) (!^E 5) (!^F 6) (!^G 7) (!^H 8) (!^I 9) (!^J 10) (!^K 11) (!^L 12) (!^M 13) (!^N 14) (!^O 15) (!^P 16) (!^Q 17) (!^R 18) (!^S 19) (!^T 20) (!^U 21) (!^V 22) (!^W 23) (!^X 24) (!^Y 25) (!^Z 26) (!^![ 8#33) (!^!\ 8#34) (!^!] 8#35) (!^!^ 8#36) (!^!~ 8#36) % for telerays... (!^!_ 8#37) (!^!/ 8#37) % for telerays... (!^!? 8#177)) 'charconst) ) (commentoutcode % It has been suggested that nice names for printing characters would be good, % too, so here are some. I don't really see that they're all that much use, % but I guess they don't do any harm. I doubt I'll ever use them, though. % If this isn't "creeping featurism" I don't know what is.... (foreach u in '((BANG !!) (EXCLAMATION !!) (AT !@) (ATSIGN !@) (SHARP !#) (POUND !#) (NUMBER !#) (NUMBER-SIGN !#) (HASH !#) (NOT-EQUAL !#) % For Algol 60 fans... (DOLLAR !$) (PERCENT !%) (CARET !^) (UPARROW !^) (AND !&) (AMPERSAND !&) (STAR !*) (TIMES !*) (LPAREN !( ) (LEFT-PARENTHESIS !( ) (LEFT-PAREN !( ) (LPAR !( ) (OPEN !( ) (RPAREN !) ) (RIGHT-PARENTHESIS !) ) (RIGHT-PAREN !) ) (RPAR !) ) (CLOSE !) ) (MINUS !-) (DASH !-) (UNDERSCORE !_) (UNDERLINE !_) (BACKARROW !_) (PLUS !+) (EQUAL !=) (EQUALS !=) (TILDE !~) (BACKQUOTE !`) (LBRACE !{) (LEFT-BRACE !{) (RBRACE !}) (RIGHT-BRACE !}) (LBRACKET ![) (LEFT-BRACKET ![) (LBRA ![) (RBRACKET !]) (RIGHT-BRACKET !]) (RBRA !]) (APOSTROPHE !') (SINGLE-QUOTE !') (QUOTE-MARK !') (DOUBLE-QUOTE !") (STRING-MARK !") % (QUOTE should this be ' or " -- I'll play it safe and not use either (COLON !:) (SEMI !;) (SEMICOL !;) (SEMICOLON !;) (QUESTION !?) (QUESTION-MARK !?) (QUESTIONMARK !?) (LESS !<) (LESS-THAN !<) (LANGLE !<) (LEFT-ANGLE !<) (LEFT-ANGLE-BRACKET !<) (GREATER !>) (GREATER-THAN !>) (GRTR !>) (RANGLE !>) (RIGHT-ANGLE !>) (RIGHT-ANGLE-BRACKET !>) (COMMA !,) (DOT !.) (PERIOD !.) (FULL-STOP !.) % For the English among us... (SLASH !/) (SOLIDUS !/) (DIVIDE !/) (BACKSLASH !\) (BAR !|) (VERTICAL !|) (VETICAL-BAR !|) (ZERO !0) (NAUGHT !0) % For the English among us... (ONE !1) (TWO !2) (THREE !3) (FOUR !4) (FIVE !5) (SIX !6) (SEVEN !7) (EIGHT !8) (NINE !9)) do (put (car u) 'charconst (dochar (cadr u)))) ) |
Added psl-1983/3-1/util/read-utils.build version [a87b59ebdc].
> | 1 | in "read-utils.red"$ |
Added psl-1983/3-1/util/read-utils.red version [933e38b624].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % READ-TABLE-UTILS.RED - Read Table Utils % % Author: M. L. Griss % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % NOTE: Rather Crude, needs some work. % Edit by Cris Perdue, 28 Jan 1983 2040-PST % Occurrences of dipthong changed to diphthong Fluid '( CharacterClass!* ); Lisp procedure PrintScanTable (Table); Begin Scalar I; I := 0; For I :=0:127 do <<Prin1 I; TAB 5; prin2 Int2Id I; Tab 15; print CharacterClass!*[Table[I]] >>; PrintF(" Diphthong name: %r%n",Table[128]); %/ PrintF(" ReadMacro name: %r%n",Table[129]); %/ PrintF(" SpliceMacro name: %r%n",Table[130]); End; %%% Some id names for the classes Lisp Procedure CopyScanTable(OldTable); Begin If Null OldTable then OldTable:=CurrentScanTable!*; If not (vectorp OldTable and UpbV(oldTable)=130) then return StdError "CopyScanTable expects a valid Readtable"; OldTable:=Copy OldTable; OldTable[128]:=Gensym(); OldTable[129]:=Gensym(); OldTable[130]:=Gensym(); Return OldTable; End; LoadTime << CharacterClass!*:= '[Digit Digit Digit Digit Digit Digit Digit Digit Digit Digit Letter Delimiter Comment Diphthong IdEscape StringQuote Package Ignore Minus Plus Decimal]; Put('Letter, 'CharacterClass!*, 10); Put('Delimiter, 'CharacterClass!*, 11); Put('Comment, 'CharacterClass!*, 12); Put('Diphthong, 'CharacterClass!*, 13); Put('IdEscape, 'CharacterClass!*, 14); Put('StringQuote, 'CharacterClass!*, 15); Put('Package, 'CharacterClass!*, 16); Put('Ignore, 'CharacterClass!*, 17); Put('Minus, 'CharacterClass!*, 18); Put('Plus, 'CharacterClass!*, 19); Put('Decimal, 'CharacterClass!*, 20) >>; Lisp procedure PutCharacterClass(Table,Ch,Val); ChangeCharType(Table,Ch,Val); Symbolic Procedure ChangeCharType(TBL,Ch,Ty); %. Set Character type begin scalar IDNum; If IdP Ty then Ty := Get(Ty,'CharacterClass!*); If IDP Ch and (IDNum := ID2Int Ch) < 128 and Numberp Ty and Ty >=0 and Ty <=20 then PutV(TBL,IDNum,Ty) Else Error(99,"Cant Set ReadTable"); end; Symbolic Procedure PutDiphthong(TBL,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,TBL[128], (FollowCh . Diphthong) . GET(StartCh,TBL[128]))>> else Error(99, "Cant Declare Diphthong"); Symbolic Procedure MakeDiphthong(TBL,DipIndicator,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,DipIndicator, (FollowCh . Diphthong) . GET(StartCh,DipIndicator))>> else Error(99, "Cant Declare Diphthong"); Lisp procedure PutReadMacro(Table,x,Fn); Begin If not IdP x then IdError(x,'PutReadMacro); If Not IdP Fn then return IDError(x,'PutReadMacro); % Check Delimiter Class as 11 or 23 Put(x,Table[129],Fn); Remprop(x,Table[130]); End; %/ Splice macros currently "frowned" upon Lisp procedure PutSpliceMacro(Table,x,Fn); Begin If not IdP x then IdError(x,'PutSpliceMacro); If Not IdP Fn then return IDError(x,'PutSpliceMacro); % Check Delimiter Class as 11 or 13 Put(x,Table[130],Fn); Remprop(x,Table[129]); End; end; |
Added psl-1983/3-1/util/ring-buffer.sl version [2504c42f57].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % RING-BUFFER.SL - General Ring Buffers % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % Revised: 16 November 1982 % % 16-Nov-82 Alan Snyder % Recoded using OBJECTS package. Added FETCH and ROTATE operations. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors)) (de ring-buffer-create (maximum-size) (make-instance 'ring-buffer 'maximum-size maximum-size)) (defflavor ring-buffer ((maximum-size 16) % Maximum number of elements. vec % Stores the elements. (size 0) % Elements 0..size-1 are valid. (ptr -1) % Element vec[ptr] is current. ) () (gettable-instance-variables maximum-size size) (initable-instance-variables maximum-size) ) (defmethod (ring-buffer init) (init-plist) (setf vec (mkvect (- maximum-size 1)))) (defmethod (ring-buffer push) (new-element) (let ((new-ptr (+ ptr 1))) (when (> new-ptr (vector-upper-bound vec)) (setf new-ptr 0)) (when (>= new-ptr size) (setf size (+ new-ptr 1))) (setf ptr new-ptr) (vector-store vec new-ptr new-element) new-element )) (defmethod (ring-buffer top) () % Returns NIL if the buffer is empty. (=> self fetch 0)) (defmethod (ring-buffer pop) () % Returns NIL if the buffer is empty. (when (> size 0) (let ((old-element (vector-fetch vec ptr))) (setf ptr (- ptr 1)) (when (< ptr 0) (setf ptr (- size 1))) old-element ))) (defmethod (ring-buffer fetch) (index) % Index 0 is the top element. % Index -1 is the next previous element, etc. % Index 1 is the most previous element, etc. % Returns NIL if the buffer is empty. (when (> size 0) (vector-fetch vec (ring-buffer-mod (+ ptr index) size)) )) (defmethod (ring-buffer rotate) (count) % Rotate -1 makes the next "older" element current (like POP), etc. % Rotate 1 makes the next "newer" element current, etc. (when (> size 0) (setf ptr (ring-buffer-mod (+ ptr count) size)) )) (de ring-buffer-mod (a b) (let ((remainder (// a b))) (if (>= remainder 0) remainder (+ b remainder)) )) % The following functions are defined for backwards compatibility: (de ring-buffer-push (rb new-element) (=> rb push new-element)) (de ring-buffer-top (rb) (=> rb top)) (de ring-buffer-pop (rb) (=> rb pop)) |
Added psl-1983/3-1/util/rlisp-parser.red version [e6926e1f90].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RLISP-PARSER.RED - RLISP parser based on Nordstrom and Pratt model % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: May 1981 % Copyright (c) 1981 University of Utah % % Known Bugs and Problems: % Procedure TEMPLATES parsed at wrong precendence, so % procedure x/y; is ok % procedure (x/Y) fails! % % IF a Then B; ELSE c; parses badly, doesnt catch ELSE % QUOTIENT(A,B) parses as RECIP(A) % % Edit by Nancy Kendzierski, 07 Apr 1983 1337-PST % Changed SEMIC!* to fluid (also in rlisp-support) to match kernel decls. % Edit by Cris Perdue, 28 Jan 1983 2038-PST % Occurrences of "dipthong" changed to "diphthong" % <PSL.UTIL.NEWVERSIONS>RLISP-PARSER.RED.4, 16-Dec-82 12:11:15, Edit by KESSLER % Make SEMIC!* a Global (as in rlisp-support), so it won't be made fluid in % compilation of Scan. % <PSL.UTIL>RLISP-PARSER.RED.3, 13-Dec-82 13:14:36, Edit by OTHMER % Flagged EMB as 'FTYPE so debug functions will work % <PSL.UTIL>RLISP-PARSER.RED.42, 17-Mar-82 02:36:14, Edit by BENSON % Finally infix as prefix works!!! % <PSL.UTIL>RLISP-PARSER.RED.25, 14-Jan-82 13:16:34, Edit by BENSON % Added JOIN to for each % <PSL.UTIL>RLISP-PARSER.RED.24, 30-Dec-81 01:01:30, Edit by BENSON % Unfixed infix as prefix. Have to check to make sure the thing is an arglist % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:22:37, Edit by BENSON % fixed LAMBDA();... % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:21:43, Edit by BENSON % Infix operators used as prefix are parsed correctly % <PSL.UTIL>RLISP-PARSER.RED.19, 28-Dec-81 14:44:47, Edit by BENSON % Removed assign-op in favor of SetF % <PSL.UTIL>RLISP-PARSER.RED.36, 5-Feb-82 07:17:34, Edit by GRISS % Add NE as infix CompileTime flag('(DefineBOpX DefineROpX DoInfixAsPrefix IsOpOp DoPrefix DoInfix MakeLocals MkQuotList PrecSet InfixOp PrefixOp RlispRead RemSemicol SymErr RAtomHook CommentPart), 'InternalFunction); FLUID '(CURSYM!* !*InsideStructureRead SEMIC!*); CURSYM!*:='! ; global '(TokType!*); lisp procedure SymErr(X, Y); StdError BldMsg("Syntax error %r", X); SYMBOLIC PROCEDURE SCAN; BEGIN SCALAR X; A: CURSYM!* := RATOMHOOK(); IF TOKTYPE!* EQ 3 THEN %/ Also a R, (IF CURSYM!* EQ '!' THEN CURSYM!* := LIST('QUOTE, RLISPREAD()) ELSE IF (X:=GET(CURSYM!*,'NeWNAM!-OP))THEN <<IF X EQ '!*SEMICOL!* THEN SEMIC!* := CURSYM!*; CURSYM!*:=X >> ); IF (X:=(GET(CURSYM!*,'NEWNAM))) THEN CURSYM!*:=X; IF CURSYM!* EQ 'COMMENT THEN << WHILE NOT (READCH() MEMQ '(!; !$)) DO ; GOTO A >>; RETURN CURSYM!*; END; SYMBOLIC PROCEDURE RESETPARSER; CURSYM!*:= '! ; %----------------------------------------------------------------- %--- Boot strap functions, move to build file-----; FLUID '( %. Name of Grammer being defined DEFPREFIX DEFINFIX GRAMPREFIX GRAMINFIX ); %. Name of grammer running DEFPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined DEFINFIX := 'RLISPINFIX; %. Key for Grammer being defined GRAMPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined GRAMINFIX := 'RLISPINFIX; %. Key for Grammer being defined SYMBOLIC FEXPR PROCEDURE DEFINEBOP U; DEFINEBOPX U; SYMBOLIC PROCEDURE DEFINEBOPX U; % u=(opname, lprec, rprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Opname; Remove ' which used to suppress OP props Y := EVAL CADR U % Lprec . EVAL CADDR U % Rprec . IF NULL CDDDR U THEN NIL % Default function is NIL ELSE IF ATOM CADDDR U THEN CADDDR U ELSE LIST('LAMBDA,'(X Y),CADDDR U); PUT(W,DEFINFIX,Y) % Binop in CAR END; SYMBOLIC PROCEDURE INFIXOP U; % Used also in REDUCE GET(U,GRAMINFIX); SYMBOLIC PROCEDURE INFIXPREC U; % Used in REDUCE MathPrint BEGIN SCALAR V; IF NULL(V:=INFIXOP U) THEN RETURN NIL; IF PAIRP V AND NUMBERP CAR V THEN RETURN CAR V; RETURN NIL; END; SYMBOLIC FEXPR PROCEDURE DEFINEROP U; DEFINEROPX U; SYMBOLIC PROCEDURE DEFINEROPX U; % u=(opname,lprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Name, remove ' mark Y := EVAL CADR U % Lprec . IF NULL CDDR U THEN NIL % Default is NIL ELSE IF ATOM CADDR U THEN CADDR U % function name ELSE LIST('LAMBDA,'(X),CADDR U); % PUT(W,DEFPREFIX,Y) END; SYMBOLIC PROCEDURE PREFIXOP U; GET(U,GRAMPREFIX); FLUID '(OP); %. Current TOKEN being studied % ***** General Parser Functions *****; SYMBOLIC PROCEDURE PARSE0(RP,PRESCAN); %. Collect Phrase to LP<RP BEGIN SCALAR CURSYM,U; %/ IF COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; OP := IF PRESCAN THEN SCAN() ELSE CURSYM!*; %/ IF PRESCAN AND COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; U := RDRIGHT(RP,OP); %/ IF CURSYM THEN RPLACA(CURSYM,U); RETURN U END; SYMBOLIC PROCEDURE RDRIGHT(RP,Y); %. Collect phrase until OP with LP<RP % Y is starting TOKEN. % RP=NIL - Caller applies Function to Y, without collecting RHS subphrase BEGIN SCALAR TEMP,OP1,TEMPSCAN, TEMPOP, !*InsideStructureRead; !*InsideStructureRead := T; IF NULL RP THEN RETURN Y %/ ELSE IF IDFLAG THEN OP := SCAN() % Set IDFLAG if not Operator ELSE IF RP=0 AND Y EQ '!*SEMICOL!* THEN RETURN NIL %/ Toplevel ; or $? ELSE IF (TEMP:=PREFIXOP Y) THEN << TEMPSCAN := SCAN(); IF STRONGERINFIXOP(TEMPSCAN, Y, CAR TEMP) THEN OP := TEMPSCAN ELSE Y := DOPREFIX(CDR TEMP,Y,RDRIGHT(CAR TEMP,TEMPSCAN)) >> ELSE IF NOT INFIXOP Y THEN OP := SCAN() %/ Binary OP in Prefix Position ELSE IF ISOPOP(OP,RP,Y) THEN <<OP := Y; Y := NIL>> ELSE OP := SCAN();% Y:=DoINFIXasPREFIX(Y,OP:=SCAN()); RDLEFT: IF %/IDFLAG OR NOT (TEMP := INFIXOP OP) THEN IF NULL OP THEN <<Y := LIST(Y,NIL); OP := SCAN()>> ELSE Y := REPCOM(Y,RDRIGHT(99,OP)) %. Do as PREFIX ELSE IF RP>CAR TEMP THEN RETURN Y ELSE <<OP1:=OP; %/ !*ORD PROBLEM? TEMPSCAN := SCAN(); IF TEMPSCAN = '!*LPAR!* AND NOT FUNBOUNDP OP1 THEN << OP := TEMPSCAN; %/ kludge to allow infix/prefix TEMPSCAN := RDRIGHT(CADR TEMP, OP); IF EQCAR(TEMPSCAN, '!*COMMA!*) THEN Y := LIST(Y, REPCOM(OP1, TEMPSCAN)) ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,TEMPSCAN) >> ELSE IF STRONGERINFIXOP(TEMPSCAN, OP1, CADR TEMP) THEN << Y := LIST(Y, OP1); OP := TEMPSCAN >> ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,RDRIGHT(CADR TEMP,TEMPSCAN))>>; GO TO RDLEFT END; SYMBOLIC PROCEDURE STRONGERINFIXOP(NEXTOP, LASTOP, LASTPREC); BEGIN SCALAR TEMPOP, MATCHER; RETURN NOT PREFIXOP NEXTOP AND (TEMPOP := INFIXOP NEXTOP) AND NUMBERP LASTPREC AND NUMBERP CAR TEMPOP AND CAR TEMPOP <= 6 AND CAR TEMPOP <= LASTPREC AND NOT ((MATCHER := GET(LASTOP, 'CLOSER)) AND MATCHER EQ NEXTOP) AND NOT ISOPOP(NEXTOP, LASTPREC, LASTOP); END; DefList('((BEGIN END) (!*LPAR!* !*RPAR!*) (!*LSQB!* !*RSQB!*) (!*LVEC!* !*RVEC!*)), 'CLOSER); SYMBOLIC PROCEDURE DoINFIXasPREFIX(LHS,BOP); REPCOM(LHS,RDRIGHT(99,BOP)); %. Note that PREFIX functions have next token SCANed, and get an argument, %. "X", that is either this TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOPREFIX(ACT,ROP,RHS); IF NULL ACT THEN LIST(ROP,RHS) ELSE APPLY(ACT,LIST RHS); %. Note that INFIX functions have next token SCANed, and get two arguments, %. "X" and "Y"; "X" is LHS phrase, %. "Y" is either the scanned TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOINFIX(ACT,LHS,BOP,RHS); IF NULL ACT THEN LIST(BOP,LHS,RHS) ELSE APPLY(ACT,LIST(LHS,RHS)); SYMBOLIC PROCEDURE ISOPOP(XOP,RP,Y); %. Test for legal OP-> <-OP IF RP=2 THEN Y EQ '!*RPAR!* % LPAR scans for LP 2 ELSE IF RP=0 AND XOP EQ 'END AND Y MEMBER '(!*SEMICOL!* !*COLON!* !*RSQB!* END) THEN T ELSE IF Y MEMQ '(!*SEMICOL!* END !*RSQB!*) % Special cases in BEGIN-END THEN RP= -2 OR XOP MEMQ '(!*SEMICOL!* !*COLON!* !*RSQB!*) ELSE NIL; SYMBOLIC PROCEDURE PARERR(X,Y); StdError X; SYMBOLIC PROCEDURE REMCOM X; %. (, x y z) -> (x y z) IF EQCAR(X,'!*COMMA!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REMSEMICOL X; %. (; x y z) -> (x y z) IF EQCAR(X,'!*SEMICOL!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); %SYMBOLIC PROCEDURE SELF RHS; %. Prefix Operator returns RHS % RHS; SYMBOLIC PROCEDURE ParseNOOP X; <<OP:=SCAN();X>>; DEFINEROP('NOOP,NIL,ParseNOOP); %. Prevent TOKEN from being an OP SYMBOLIC PROCEDURE MKQUOTLIST U; %this could be replaced by MKQUOTE in most cases; 'LIST . FOR EACH X IN U COLLECT IF CONSTANTP X THEN X ELSE MKQUOTE X; SYMBOLIC PROCEDURE NARY(XOP,LHS,RHS); %. Remove repeated NARY ops IF EQCAR(LHS,XOP) THEN ACONC(LHS,RHS) ELSE LIST(XOP,LHS,RHS); % ***** Tables for Various Infix Operators *****; SYMBOLIC PROCEDURE ParseCOMMA(X,Y); NARY('!*COMMA!*,X,Y); DEFINEBOP('!*COMMA!*,5,6,ParseCOMMA ); SYMBOLIC PROCEDURE ParseSEMICOL(X,Y); NARY('!*SEMICOL!*,X,Y); DEFINEBOP('!*SEMICOL!*, - 1,0,ParseSEMICOL ); SYMBOLIC PROCEDURE ParseSETQ(LHS,RHS); %. Extended SETQ LIST(IF ATOM LHS THEN 'SETQ ELSE 'SETF, LHS, RHS); DEFINEBOP('SETQ,7,6,ParseSETQ); DEFINEBOP('CONS,23,21); SYMBOLIC PROCEDURE ParsePLUS2(X,Y); NARY('PLUS,X,Y); DEFINEBOP('PLUS,17,18,ParsePLUS2); %SYMBOLIC PROCEDURE ParsePLUS1(X); % IF EQCAR(X,'!*COMMA!*) THEN REPCOM('PLUS,X) ELSE X; % %DEFINEROP('PLUS,26,ParsePLUS1); %/ **** Prefix + sign... DEFINEROP('MINUS,26); SYMBOLIC PROCEDURE ParseDIFFERENCE(X); IF NUMBERP X THEN (0 - X ) ELSE IF EQCAR(X,'!*COMMA!*) THEN REPCOM('DIFFERENCE,X) ELSE LIST('MINUS,X); DEFINEROP('DIFFERENCE,26,ParseDIFFERENCE ); DEFINEBOP('DIFFERENCE,17,18); DEFINEBOP('TIMES,19,20); SYMBOLIC PROCEDURE ParseQUOTIENT(X); IF NOT EQCAR(X,'!*COMMA!*) THEN LIST('RECIP,X) ELSE REPCOM('QUOTIENT,X); DEFINEROP('QUOTIENT,26,ParseQUOTIENT); DEFINEBOP('QUOTIENT,19,20); DEFINEROP('RECIP,26); DEFINEBOP('EXPT,23,24); SYMBOLIC PROCEDURE ParseOR(X,Y); NARY('OR,X,Y); DEFINEBOP('OR,9,10,ParseOR); %/DEFINEROP('OR,26,REPCOM('OR,X)); SYMBOLIC PROCEDURE ParseAND(X,Y); NARY('AND,X,Y); DEFINEBOP('AND,11,12,ParseAND); %/DEFINEROP('AND,26,REPCOM('AND,X)); DEFINEROP('NOT,14); DEFINEBOP('MEMBER,15,16); %/DEFINEROP('MEMBER,26,REPCOM('MEMBER,X)); DEFINEBOP('MEMQ,15,16); %/DEFINEROP('MEMQ,26,REPCOM('MEMQ,X)); DEFINEBOP('EQ,15,16); %/DEFINEROP('EQ,26,REPCOM('EQ,X)); DEFINEBOP('EQUAL,15,16); DEFINEBOP('GEQ,15,16); DEFINEBOP('GREATERP,15,16); DEFINEBOP('LEQ,15,16); DEFINEBOP('LESSP,15,16); DEFINEBOP('NEQ,15,16); DEFINEBOP('NE,15,16); % ***** Tables and Definitions for Particular Parsing Constructs *****; % ***** IF Expression *****; DEFINEROP('IF,4,ParseIF); DEFINEBOP('THEN,3,6); DEFINEBOP('ELSE,3,6); SYMBOLIC PROCEDURE ParseIF X; BEGIN SCALAR Y,Z; IF OP EQ 'THEN THEN Y := PARSE0(6,T) ELSE PARERR("IF missing THEN",T); IF OP EQ 'ELSE THEN Z := LIST PARSE0(6,T); RETURN 'COND . LIST(X,Y) . IF Z THEN IF EQCAR(CAR Z,'COND) THEN CDAR Z ELSE LIST (T . Z) ELSE NIL END; SYMBOLIC PROCEDURE ParseCASE(X); %. Parser function BEGIN IF NOT (OP EQ 'OF) THEN PARERR("CASE Missing OF",T); RETURN 'CASE . X . CASELIST() END; DEFINEBOP('OF,3,6); DEFINEBOP('TO,8,9); DEFINEROP('CASE,4,ParseCASE); SYMBOLIC PROCEDURE CASELIST; BEGIN SCALAR TG,BOD,TAGLIST,BODLIST; L1: OP := SCAN(); % Drop OF, : , etc IF OP EQ 'END THEN GOTO L2; % For optional ; before END TG := PARSETAGS(); % The TAG expressions BOD:= PARSE0(6,T); % The expression BODLIST:=LIST(TG,BOD) . BODLIST; IF OP EQ '!*SEMICOL!* THEN GOTO L1; IF OP NEQ 'END THEN PARERR("Expect END after CASE list",T); L2: OP:=SCAN(); % Skip 'END RETURN REVERSE BODLIST; END; SYMBOLIC PROCEDURE PARSETAGS(); % Collects a single CASE-tag form; OP prescanned BEGIN SCALAR TG,TGLST; TG:=PARSE0(6,NIL); % , and : below 6 IF EQCAR(TG,'TO) THEN TG:='RANGE . CDR TG; % TO is infix OP IF TG MEMQ '(OTHERWISE DEFAULT) THEN RETURN <<IF OP NEQ '!*COLON!* THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); NIL>>; IF OP EQ '!*COLON!* THEN RETURN LIST(TG); IF OP EQ '!*COMMA!* THEN RETURN <<OP:=SCAN(); TGLST:=PARSETAGS(); IF NULL TGLST THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); TG . TGLST>>; PARERR("Expect one or more tags before : in CASE",T); END; % ***** Block Expression *****; fluid '(BlockEnders!*); BlockEnders!* :='(END !*RPAR!* !*SEMICOL!* ELSE UNTIL !*RSQB!*); SYMBOLIC PROCEDURE ParseBEGIN(X); ParseBEGIN1(REMSEMICOL X, COMMENTPART(SCAN(),BlockEnders!*)); DEFINEROP('BEGIN,-2,ParseBEGIN); DEFINEBOP('END,-3,-2); SYMBOLIC PROCEDURE ParseGO X; IF X EQ 'TO THEN LIST('GO,PARSE0(6,T)) % Why not Just SCAN? ELSE <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GO,NIL,ParseGO ); SYMBOLIC PROCEDURE ParseGOTO X; <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GOTO,NIL,ParseGOTO ); SYMBOLIC PROCEDURE ParseRETURN X; Begin Scalar XOP; RETURN LIST('RETURN, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('RETURN,NIL,ParseRETURN); SYMBOLIC PROCEDURE ParseEXIT X; Begin Scalar XOP; RETURN LIST('EXIT, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('EXIT,NIL,ParseEXIT); DEFINEBOP('!*COLON!*,1,0 ); SYMBOLIC PROCEDURE COMMENTPART(A,L); IF A MEMQ L THEN <<OP := A; NIL>> ELSE A . COMMENTPART(SCAN(),L); SYMBOLIC PROCEDURE ParseBEGIN1(L,COMPART); BEGIN SCALAR DECLS,S; % Look for Sequence of Decls after Block Header A: IF NULL L THEN GO TO ND %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; ELSE IF NULL CAR L THEN <<L := CDR L; GO TO A>> ELSE IF EQCAR(CAR L,'DECLARE) THEN <<DECLS :=APPEND(CDAR L, DECLS); % Reverse order collection L := CDR L>> ELSE <<S:=L; GO TO B>>; % Hold Body for Rescan GO TO A; B: IF NULL L THEN GO TO ND ELSE IF EQCAR(CAR L,'DECLARE) THEN PARERR("DECLARATION invalid in BEGIN body",NIL) ELSE IF EQCAR(CAR L,'!*COLON!*) THEN <<RPLACD(CDDAR L,CDR L); RPLACD(L,CDDAR L); RPLACA(L,CADAR L)>> ELSE IF CDR L AND NULL CADR L THEN <<RPLACD(L,CDDR L); L := NIL . L>>; L := CDR L; GO TO B; ND: RETURN ('PROG . MAKELOCALS(DECLS) . S); END; SYMBOLIC PROCEDURE MAKELOCALS(U); %. Remove Types from Reversed DECLARE IF NULL U THEN NIL ELSE APPEND(CDAR U,MAKELOCALS CDR U); % ***** Procedure Expression *****; GLOBAL '(!*MODE); !*MODE := 'SYMBOLIC; SYMBOLIC PROCEDURE NMODESTAT VV; % Parses TOP-LEVEL mode ....; BEGIN SCALAR TMODE,X; X:= CURSYM!*; % SCAN(); IF CURSYM!* EQ '!*SEMICOL!* THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; IF FLAGP(CURSYM!*,'DELIM) THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; TMODE := !*MODE; !*MODE := VV; % Local MODE change for MKPROC X := ERRORSET('(PARSE0 0 NIL),T,!*BACKTRACE); !*MODE := TMODE; RETURN IF ATOM X OR CDR X THEN NIL ELSE CAR X END; SYMBOLIC PROCEDURE NEWMODE VV; <<PRINT LIST('NEWMODE,LIST('QUOTE,VV)); IF NULL VV THEN VV:='SYMBOLIC; !*MODE := VV>>; CommentOutCode << fluid '(FTypes!*); FTYPES!* := '(EXPR FEXPR MACRO); SYMBOLIC PROCEDURE OLDPROCSTAT; BEGIN SCALAR BOOL,U,TYPE,X,Y,Z; IF FNAME!* THEN GO TO B ELSE IF CURSYM!* EQ 'PROCEDURE THEN TYPE := 'EXPR ELSE PROGN(TYPE := CURSYM!*,SCAN()); IF NOT CURSYM!* EQ 'PROCEDURE THEN GO TO C; X := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF ATOM X OR CDR X THEN GO TO A ELSE IF ATOM (X := CAR X) THEN X := LIST X; %no arguments; FNAME!* := CAR X; %function name; IF IDP FNAME!* %AND NOT(TYPE MEMQ FTYPES!*); THEN IF NULL FNAME!* OR (Z := GETTYPE FNAME!*) AND NOT Z MEMQ '(PROCEDURE OPERATOR) THEN GO TO D ELSE IF NOT GETD FNAME!* THEN FLAG(LIST FNAME!*,'FNC); %to prevent invalid use of function name in body; U := CDR X; Y := ERRORSET(LIST('FLAGTYPE,MKQUOTE U,MKQUOTE 'SCALAR), T,!*BACKTRACE); IF ATOM Y OR CDR Y THEN Y := NIL ELSE Y := CAR Y; X := CAR X . Y; A: Z := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF NOT ATOM Z AND NULL CDR Z THEN Z := CAR Z; IF NULL ERFG!* THEN Z:=PROCSTAT1(X,Z,TYPE); REMTYPE Y; REMFLAG(LIST FNAME!*,'FNC); FNAME!*:=NIL; IF NOT BOOL AND ERFG!* THEN REDERR "ERROR TERMINATION"; RETURN Z; B: BOOL := T; C: ERRORSET('(SYMERR (QUOTE PROCEDURE) T),T,!*BACKTRACE); GO TO A; D: LPRIE LIST(Z,FNAME!*,"INVALID AS PROCEDURE"); GO TO A END; >>; % Some OLD Crap looks at 'STAT values!!! DEFLIST ('((PROCEDURE PROCSTAT) (EXPR PROCSTAT) (FEXPR PROCSTAT) (EMB PROCSTAT) (MACRO PROCSTAT) (NMACRO PROCSTAT) (SMACRO PROCSTAT)), 'STAT); DEFLIST ('((ALGEBRAIC MODESTAT) (SYMBOLIC MODESTAT) (SYSLSP MODESTAT) ), 'STAT); %/ STAT used for OLD style BEGIN KEY search DEFLIST('((LISP SYMBOLIC)),'NEWNAM); DEFINEROP('SYMBOLIC,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEROP('ALGEBRAIC,NIL,NMODESTAT('ALGEBRAIC)); % Make it a Prefix OP DEFINEROP('SYSLSP,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEBOP('PROCEDURE,1,NIL,ParsePROCEDURE); % Pick up MODE -- will go DEFINEROP('PROCEDURE,NIL,ParsePROCEDURE('EXPR,X)); %/ Unary, use DEFAULT mode? SYMBOLIC PROCEDURE ParsePROCEDURE2(NAME,VARLIS,BODY,TYPE); BEGIN SCALAR Y; % IF FLAGP(NAME,'LOSE) AND (!*LOSE OR NULL !*DEFN) % THEN RETURN PROGN(LPRIM LIST(NAME, % "Not defined (LOSE Flag)"), % NIL); if (Y := get(Type, 'FunctionDefiningFunction)) then Body := list(Y, Name, VarLis, Body) else if (Y := get(Type, 'ImmediateDefiningFunction)) then return Apply(Y, list(Name, VarLis, Body)) ELSE BODY := LIST('PUTC, MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE LIST('LAMBDA,VARLIS, REFORM BODY)); RETURN IF !*MODE NEQ 'ALGEBRAIC THEN BODY %/ ELSE LIST('PROGN, %/ LIST('FLAG,MKQUOTE LIST NAME,MKQUOTE 'OPFN), %/ BODY) END; DefList('((Expr DE) (FExpr DF) (Macro DM) (NExpr DN) (SMacro DS)), 'FunctionDefiningFunction); put('Emb, 'ImmediateDefiningFunction, 'EmbFn); SYMBOLIC PROCEDURE ParsePROCEDURE1(NAM,ARGS,BODY,ARGTYPE,TYPES); %/ Crude conversion of PROC to PUTD. Need make Etypes and Ftypes %/ Keywords also. BEGIN SCALAR ETYPE,FTYPE; ETYPE:=!*MODE; FTYPE:='EXPR; IF NOT PAIRP TYPES THEN TYPES:=TYPES . NIL; FOR EACH Z IN TYPES DO IF FLAGP(Z,'ETYPE) THEN ETYPE:=Z ELSE IF FLAGP(Z,'FTYPE) THEN FTYPE:=Z; RETURN ParsePROCEDURE2(NAM,ARGS,BODY,FTYPE); END; FLAG('(EXPR FEXPR NEXPR NFEXPR MACRO SMACRO NMACRO EMB),'FTYPE); FLAG('(SYMBOLIC ALGEBRAIC LISP SYSLISP SYSLSP),'ETYPE); SYMBOLIC PROCEDURE ParsePROCEDURE(EFTYPES,Y); BEGIN SCALAR OP1,Z,Z1; OP := OP1 := SCAN(); IF OP1 EQ '!*SEMICOL!* THEN Y := LIST Y ELSE IF INFIXOP OP1 THEN Y := LIST(OP1,Y,PARSE0(8,T)) % Binary as Prefix ELSE Y := REPCOM(Y,PARSE0(8,NIL)); %/ Why 8 IF OP NEQ '!*SEMICOL!* THEN PARERR("PROCEDURE missing terminator after template",T); %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; Z := PARSE0(0,T); IF EQCAR(Z,'DECLARE) THEN <<Z1 := Z; Z := PARSE0(0,T)>>; % repeated DECL? RETURN ParsePROCEDURE1(CAR Y,CDR Y,Z,Z1,EFTYPES); % Nam, args, body, arg decl, E/Fmode END; % ***** Left and Right Parentheses Handling *****; DEFINEROP('!*LPAR!*,NIL,ParseLPAR); DEFINEBOP('!*RPAR!*,1,0); SYMBOLIC PROCEDURE ParseLPAR X; BEGIN SCALAR RES; IF X EQ '!*RPAR!* THEN <<OP := X; RES := '!*EMPTY!*>> ELSE RES:= RDRIGHT(2,X); IF OP EQ '!*RPAR!* THEN OP := SCAN() ELSE PARERR("Missing ) after argument list",NIL); RETURN RES END; % ***** Left and Right << and >> Handling *****; DEFINEROP('!*LSQB!*,-2,ParseRSQB); SYMBOLIC PROCEDURE ParseRSQB(X); IF OP EQ '!*RSQB!* THEN <<OP := SCAN(); 'PROGN . REMSEMICOL X>> ELSE PARERR("Missing right >> after Group",NIL); DEFINEBOP('!*RSQB!*,-3,0); %COMMENT ***** [] vector syntax; REMPROP('![,'NEWNAM); REMPROP('!],'NEWNAM); % ***** [] vector syntax; DEFINEBOP('!*LVEC!*,121,6,ParseLVEC); SYMBOLIC PROCEDURE ParseLVEC(X,Y); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,X,Y)>> ELSE PARERR("Missing ] in index expression ",NIL); % INDX is used for both Vectors and Strings in PSL. You will need to % have INDX map to GETV in vanilla Standard Lisp DEFINEBOP('!*RVEC!*,5,7); % ***** Lambda Expression *****; DEFINEROP('LAMBDA,0,ParseLAMBDA); SYMBOLIC PROCEDURE ParseLAMBDA X; LIST('LAMBDA,IF X AND X NEQ '!*EMPTY!* THEN REMCOM X ELSE NIL, PARSE0(6,T)); % ***** Repeat Expression *****; DEFINEROP('REPEAT,4,ParseREPEAT); SYMBOLIC PROCEDURE ParseREPEAT X; LIST('REPEAT,X, IF OP EQ 'UNTIL THEN PARSE0(6,T) ELSE PARERR("REPEAT missing UNTIL clause",T)) ; DEFINEBOP('UNTIL,3,6); % ***** While Expression *****; DEFINEROP('WHILE,4, ParseWHILE); SYMBOLIC PROCEDURE ParseWHILE X; LIST('WHILE,X, IF OP EQ 'DO THEN PARSE0(6,T) ELSE PARERR("WHILE missing DO clause",T)) ; DEFINEBOP('DO,3,6); % ***** Declare Expression *****; DEFINEROP('DECLARE,2,ParseDECL); DEFINEROP('DCL,2,ParseDECL); SYMBOLIC PROCEDURE ParseDECL X; BEGIN SCALAR Y,Z; A: IF OP NEQ '!*COLON!* THEN PARERR("DECLARE needs : before mode",T); IF (Z := SCAN()) MEMQ '(INTEGER REAL SCALAR) THEN OP := SCAN() ELSE Z := PARSE0(6,NIL); Y := ACONC(Y,Z . REMCOM X); IF OP EQ '!*SEMICOL!* THEN RETURN 'DECLARE . Y ELSE IF OP NEQ '!*COMMA!* THEN PARERR("DECLAREd variables separated by ,",T); X := PARSE0(2,T); GO TO A END; SYMBOLIC FEXPR PROCEDURE DECLARE U; %to take care of top level declarations; <<LPRIM "Declarations are not permitted at the top level"; NMODESTAT U>>; % ***** For Expression *****; DEFINEROP('FOR,NIL,ParseFOR); DEFINEBOP('STEP,3,6); DEFINEBOP('SUM,3,6); DEFINEBOP('PRODUCT,3,6); SYMBOLIC PROCEDURE ParseFOR X; BEGIN SCALAR INIT,STP,UNTL,ACTION,ACTEXPR; IF X EQ 'EACH THEN RETURN ParseFOREACH SCAN() ELSE IF X EQ 'ALL THEN RETURN ParseFORALL PARSE0(4,T) ELSE IF (OP := SCAN()) EQ 'SETQ THEN INIT := PARSE0(6,T) ELSE PARERR("FOR missing loop VAR assignment",T); IF OP EQ '!*COLON!* THEN <<STP := 1; OP := 'UNTIL>> ELSE IF OP EQ 'STEP THEN STP := PARSE0(6,T) ELSE PARERR("FOR missing : or STEP clause",T); IF OP EQ 'UNTIL THEN UNTL := PARSE0(6,T) ELSE PARERR("FOR missing UNTIL clause",T); ACTION := OP; IF ACTION MEMQ '(DO SUM PRODUCT) THEN ACTEXPR := PARSE0(6,T) ELSE PARERR("FOR missing action keyword",T); RETURN LIST('FOR, LIST('FROM,X,INIT,UNTL,STP), LIST(ACTION,ACTEXPR)) END; % ***** Foreach Expression *****; DEFINEROP('FOREACH,NIL,ParseFOREACH); DEFINEBOP('COLLECT,3,6); DEFINEBOP('CONC,3,6); DEFINEBOP('JOIN,3,6); SYMBOLIC PROCEDURE ParseFOREACH X; BEGIN SCALAR L,INON,ACTION; IF NOT ((INON := SCAN()) EQ 'IN OR INON EQ 'ON) THEN PARERR("FOR EACH missing iterator clause",T); L := PARSE0(6,T); IF NOT ((ACTION := OP) MEMBER '(DO COLLECT CONC JOIN)) THEN PARERR("FOR EACH missing action clause",T); RETURN LIST('FOREACH,X,INON,L,ACTION,PARSE0(6,T)) END; % ***** Let Expression *****; DEFINEBOP('LET,1,0,ParseLET); DEFINEROP('LET,0,ParseLET(NIL . NIL,X) ); DEFINEBOP('CLEAR,0,1,ParseCLEAR); DEFINEROP('CLEAR,0,ParseCLEAR(NIL . NIL,X)); DEFINEBOP('SUCH,3,6); SYMBOLIC PROCEDURE ParseLET(X,Y); ParseLET1(X,Y,NIL); SYMBOLIC PROCEDURE ParseCLEAR(X,Y); ParseLET1(X,Y,T); SYMBOLIC PROCEDURE ParseLET1(X,Y,Z); LIST('LET!*,CAR X,REMCOM Y,CDR X,NIL,Z); SYMBOLIC PROCEDURE ParseFORALL X; BEGIN SCALAR BOOL; IF OP EQ 'SUCH THEN IF SCAN() EQ 'THAT THEN BOOL := PARSE0(6,T) ELSE PARERR("FOR ALL missing SUCH THAT clause",T); IF NOT OP MEMQ '(LET CLEAR) THEN PARERR("FOR ALL missing ACTION",T); RETURN REMCOM X . BOOL END; % ******** Standard Qoted LIST collectors SYMBOLIC PROCEDURE RLISF(U,V,W); %. Used to Collect a list of IDs to %. FLAG with Something BEGIN V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; RETURN FLAG(V,U) END; SYMBOLIC PROCEDURE FLAGOP U; %. Declare U as Flagger RLISTAT(U,'FLAGOP); SYMBOLIC PROCEDURE RLISTAT(OPLIST,B); %. Declare els of OPLIST to be RLIS FOR EACH U IN OPLIST DO DEFINEROPX LIST(MKQUOTE U,NIL, LIST(IF B EQ 'FLAGOP THEN 'RLISF ELSE 'RLIS1, MKQUOTE U,'X,MKQUOTE B)); SYMBOLIC PROCEDURE RLIS1(U,V,W); %. parse LIST of args, maybe quoted % U=funcname, V=following Phrase, W=arg treatment BEGIN IF V EQ '!*SEMICOL!* THEN RETURN <<OP := V; IF W = 'NOQUOTE THEN LIST U ELSE LIST(U, NIL) >> ELSE V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; IF W EQ 'IO THEN V := MAPCAR(V,FUNCTION (LAMBDA J; NEWMKFIL J)); RETURN IF W EQ 'NOQUOTE THEN U . V ELSE LIST(U,MKQUOTLIST V) END; % ***** Parsing Rules For Various IO Expressions *****; RLISTAT('(IN OUT SHUT),'NOQUOTE); RLISTAT('(TR UNTR BR UNBR),'NOQUOTE); % for mini-trace in PSL RLISTAT('(LOAD HELP), 'NOQUOTE); FLAG('(IN OUT SHUT ON OFF TR UNTR UNTRST TRST),'NOCHANGE); % No REVAL of args DEFINEROP('FSLEND,NIL,ESTAT('FasLEND)); DEFINEROP('FaslEND,NIL,ESTAT('FaslEND)); RLISTAT('(WRITE),'NOQUOTE); RLISTAT('(ARRAY),1); % 2.11.3 ON/OFF STATEMENTS RLISTAT('(ON OFF), 'NOQUOTE); % ***** Parsing Rules for INTEGER/SCALAR/REAL *****; % These will eventually be removed in favor of DECLARE; DEFINEROP('INTEGER,0,ParseINTEGER); SYMBOLIC PROCEDURE ParseINTEGER X; LIST('DECLARE,REPCOM('INTEGER,X)); DEFINEROP('REAL,0,ParseREAL); SYMBOLIC PROCEDURE ParseREAL X; LIST('DECLARE,REPCOM('REAL,X)); DEFINEROP('SCALAR,0,ParseSCALAR); SYMBOLIC PROCEDURE ParseSCALAR X; LIST('DECLARE,REPCOM('SCALAR,X)); %/ Cuase problems in INTEGER procedure foo;... SYMBOLIC PROCEDURE COMM1 U; %. general Comment Parser BEGIN IF U EQ 'END THEN SCAN(); A: IF CURSYM!* EQ '!*SEMICOL!* OR U EQ 'END AND CURSYM!* MEMQ '(END ELSE UNTIL !*RPAR!* !*RSQB!*) THEN RETURN NIL; SCAN(); GOTO A; END; SYMBOLIC PROCEDURE ESTAT(FN); %. returns (FN), dropping till semicol ; BEGIN WHILE CURSYM!* NEQ '!*SEMICOL!* DO SCAN(); OP := '!*SEMICOL!*; RETURN LIST(FN); END; SYMBOLIC PROCEDURE ENDSTAT; %This procedure can also be used for any key-words which take no %arguments; BEGIN SCALAR X; X := OP; COMM1 'END; OP := '!*SEMICOL!*; RETURN LIST X END; % Some useful ESTATs: DEFINEROP('QUIT,NIL,ESTAT('QUIT)); DEFINEROP('PAUSE,NIL,ESTAT('PAUSE)); DEFINEROP('CONT,NIL,ESTAT('CONT)); DEFINEROP('RECLAIM,NIL,ESTAT('RECLAIM)); DEFINEROP('RETRY,NIL,ESTAT('RETRY)); DEFINEROP('SHOWTIME,NIL,ESTAT('SHOWTIME)); FLAG('(FSLEND CONT RECLAIM RETRY SHOWTIME QUIT PAUSE),'OPFN); % Symbolic OPS, or could use NOCHANGE RLISTAT('(FLAGOP),1); CommentOutCode << SYMBOLIC PROCEDURE INFIX X; % Makes Left ASSOC, not like CONS FOR EACH Y IN X DO DEFINEBOPX LIST(MKQUOTE Y,8,9,NIL); >>; FLAG('(NEWTOK),'EVAL); SYMBOLIC PROCEDURE PRECEDENCE U; PRECSET(CAR U,CADR U); SYMBOLIC PROCEDURE PRECSET(U,V); BEGIN SCALAR Z; IF NULL (Z := INFIXOP V) OR NULL (Z := CDR Z) THEN REDERR LIST(V,"NOT INFIX") ELSE DEFINEBOPX LIST(MKQUOTE U,CAR Z,CADR Z,NIL) END; RLISTAT('(INFIX PRECEDENCE),3); REMPROP('SHOWTIME,'STAT); %********************************************************************* % DEFINE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseDEFINE(X); % X is following Token BEGIN SCALAR Y,Z; B: IF X EQ '!*SEMICOL!* THEN RETURN <<OP:='!*SEMICOL!*; MKPROG(NIL,Z)>> ELSE IF X EQ '!*COMMA!* THEN <<X:=SCAN(); %/ Should use SCAN0 GO TO B>> ELSE IF NOT IDP X THEN GO TO ER; Y := SCAN(); IF NOT (Y EQ 'EQUAL) THEN GO TO ER; Z := ACONC(Z,LIST('PUT,MKQUOTE X,MKQUOTE 'NEWNAM, MKQUOTE PARSE0(6,T))); % So doesnt include , X := CURSYM!*; GO TO B; ER: SYMERR('DEFINE,T) END; DEFINEROP('DEFINE,NIL,ParseDEFINE); FLAG('(DEFINE),'EVAL); %********************************************************************* % 3.2.4 WRITE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseWRITE(X); BEGIN SCALAR Y,Z; X := REMCOM XREAD1 'LAMBDA; A: IF NULL X THEN RETURN MKPROG(NIL,'(TERPRI) . Y); Z := LIST('PRIN2,CAR X); IF NULL CDR X THEN Z := LIST('RETURN,Z); B: Y := ACONC(Y,Z); X := CDR X; GO TO A; END; DEFINEROP('WRITE,NIL,ParseWRITE); %********************************************************************* % VARIOUS DECLARATIONS %********************************************************************; SYMBOLIC PROCEDURE ParseOPERATOR(X); BEGIN SCALAR Y; Y := REMCOM PARSE0(0,NIL); RETURN IF !*MODE EQ 'SYMBOLIC THEN MKPROG(NIL,LIST LIST('FLAG,MKQUOTE Y,MKQUOTE 'OPFN)) ELSE IF X NEQ 'OPERATOR THEN IF EQCAR(CAR Y,'PROG) THEN CAR Y ELSE X . MAPCAR(LIST Y,FUNCTION MKARG) ELSE IF KEY!* NEQ 'OPERATOR AND GET(KEY!*,'FN) THEN (LAMBDA K; MKPROG(NIL,MAPCAR(Y,FUNCTION (LAMBDA J; LIST('FLAG,LIST('LIST,MKQUOTE J), K,K))))) MKQUOTE GET(KEY!*,'FN) ELSE MKPROG(NIL, LIST LIST('OPERATOR,MKQUOTE Y)) END; SYMBOLIC PROCEDURE OPERATOR U; MAPCAR(U,FUNCTION MKOP); DEFINEROP('OPERATOR,NIL,ParseOPERATOR); %. Diphthongs and READtable Changes Symbolic Procedure ChangeCharType(TBL,Ch,Ty); %. Set Character type begin scalar IDNum; If IDP Ch and (IDNum := ID2Int Ch) < 128 and Numberp Ty and Ty >=0 and Ty <=19 then PutV(TBL,IDNum,Ty) Else Error(99,"Cant Set ReadTable"); end; Symbolic Procedure MakeDiphthong(TBL,DipIndicator,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,DipIndicator, (FollowCh . Diphthong) . GET(StartCh,DipIndicator))>> else Error(99, "Cant Declare Diphthong"); SYMBOLIC PROCEDURE MYNEWTOK(X,REPLACE,PRTCHARS); BEGIN SCALAR Y; PUT(X,'NEWNAM!-OP,REPLACE); IF NULL PRTCHARS THEN Y:=LIST(X,X) ELSE IF IDP PRTCHARS THEN Y:=LIST(PRTCHARS,X) ELSE Y:=PRTCHARS; PUT(REPLACE,'PRTCH,Y); END; MYNEWTOK('!;,'!*SEMICOL!*,NIL)$ MYNEWTOK('!$,'!*SEMICOL!*,NIL)$ MYNEWTOK('!,,'!*COMMA!*,NIL)$ MYNEWTOK('!.,'CONS,NIL)$ MYNEWTOK('!:!=,'SETQ,'! !:!=! )$ MYNEWTOK('!+,'PLUS,'! !+! )$ MYNEWTOK('!-,'DIFFERENCE,'! !-! )$ MYNEWTOK('!*,'TIMES,NIL)$ MYNEWTOK('!/,'QUOTIENT,NIL)$ MYNEWTOK('!*!*,'EXPT,NIL)$ MYNEWTOK('!^,'EXPT,NIL)$ MYNEWTOK('!=,'EQUAL,NIL)$ MYNEWTOK('!:,'!*COLON!*,NIL)$ MYNEWTOK('!(,'!*LPAR!*,NIL)$ MYNEWTOK('!),'!*RPAR!*,NIL)$ MYNEWTOK('!{,'!*LSQB!*,NIL)$ MYNEWTOK('!},'!*RSQB!*,NIL)$ MYNEWTOK('!<!<,'!*LSQB!*,NIL)$ MYNEWTOK('!>!>,'!*RSQB!*,NIL)$ MYNEWTOK('![,'!*LVEC!*,NIL)$ MYNEWTOK('!],'!*RVEC!*,NIL)$ MYNEWTOK('!<,'LESSP,NIL)$ MYNEWTOK('!<!=,'LEQ,NIL)$ MYNEWTOK('!>!=,'GEQ,NIL)$ MYNEWTOK('!>,'GREATERP,NIL)$ fluid '(RLispScanTable!* RLispReadScanTable!*); RLispReadScanTable!* := ' [17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 LispDiphthong]; RLispScanTable!* := TotalCopy RLispReadScanTable!*; PutV(RLispScanTable!*, 128, 'RLISPDIPHTHONG); ChangeCharType(RLispScanTable!*, '!-, 11); ChangeCharType(RLispScanTable!*, '!+, 11); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!:,'!=,'!:!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!=,'!<!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!=,'!>!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!<,'!<!< ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!>,'!>!> ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!*,'!*,'!*!* ); Symbolic Procedure XReadEof(Channel,Ef); if !*InsideStructureRead then StdError BldMsg("Unexpected EOF while parsing on channel %r", Channel) else Throw('!$ERROR!$, list !$EOF!$); % embarrasingly gross kludge Put(Int2ID char EOF, 'RlispReadMacro, 'XReadEOF); Symbolic Procedure RatomHOOK(); %. To get READ MACRO', EG EOF ChannelReadTokenWithHooks IN!*; lisp procedure RlispChannelRead Channel; %. Parse S-expression from channel begin scalar CurrentScanTable!*, CurrentReadMacroIndicator!*, CurrentDiphthongIndicator!*; CurrentScanTable!* := RLispReadScanTable!*; CurrentReadMacroIndicator!* := 'LispReadMacro; CurrentDiphthongIndicator!* := 'LispDiphthong; return ChannelReadTokenWithHooks Channel; end; lisp procedure RlispRead(); %. Parse S-expr from current input RlispChannelRead IN!*; END; |
Added psl-1983/3-1/util/rlisp-support.red version [360281923e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>RLISP-SUPPORT.RED.14, 07-Apr-83 13:34:02, Edit by KENDZIERSKI % Changed !*OUTPUT and SEMIC!* to fluid from global to agree w/kernel decls. % <PSL.UTIL>RLISP-SUPPORT.RED.8, 13-Oct-82 10:21:02, Edit by BENSON % !*INT is globally T % <PSL.UTIL>RLISP-SUPPORT.RED.5, 5-Oct-82 11:05:30, Edit by BENSON % Changed SaveSystem to 3 arguments % <PSL.UTIL>RLISP-SUPPORT.RED.3, 20-Sep-82 11:57:21, Edit by BENSON % Added Begin1 and BeginRlisp to IgnoredInBacktrace!* CompileTime REMPROP('SHOWTIME,'STAT); %********************************************************************* % RLISP and REDUCE Support Code for NEW-RLISP / On PSL %********************************************************************; GLOBAL '(FLG!*); GLOBAL '(BLOCKP!* CMSG!* ERFG!* INITL!* LETL!* PRECLIS!* VARS!* !*FORCE CLOC!* !*DEMO !*QUIET OTIME!* !*SLIN LREADFN!* TSLIN!* !*NAT NAT!*!* CRCHAR!* IFL!* IPL!* KEY!* KEY1!* OFL!* OPL!* PROGRAM!* PROGRAML!* EOF!* TECHO!* !*INT !*MODE !*CREF !*MSG !*PRET !*EXTRAECHO); FLUID '(!*DEFN !*ECHO DFPRINT!* !*TIME !*BACKTRACE CURSYM!* SEMIC!* !*OUTPUT); % These global variables divide into two classes. The first %class are those which must be initialized at the top level of the %program. These are as follows; BLOCKP!* := NIL; %keeps track of which block is active; CMSG!* := NIL; %shows that continuation msg has been printed; EOF!* := NIL; %flag indicating an end-of-file; ERFG!* := NIL; %indicates that an input error has occurred; INITL!* := '(BLOCKP!* VARS!*); %list of variables initialized in BEGIN1; KEY!* := 'SYMBOLIC; %stores first word read in command; LETL!* := NIL; %used in algebraic mode for special delimiters; LREADFN!* := NIL; %used to define special reading function; %OUTL!* := NIL; %storage for output of input line; PRECLIS!*:= '(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ LESSP PLUS DIFFERENCE TIMES QUOTIENT EXPT CONS); %precedence list of infix operators; TECHO!* := NIL; %terminal echo status; VARS!* := NIL; %list of current bound variables during parse; !*BACKTRACE := NIL; %if ON, prints a LISP backtrace; !*CREF := NIL; %used by cross-reference program; !*DEMO := NIL; % causes a PAUSE (READCH) in COMMAND loop !*ECHO := NIL; %indicates echoing of input; !*FORCE := NIL; %causes all macros to expand; !*INT := T; % system is interactive %!*LOSE := T; %determines whether a function flagged LOSE %is defined; %!*MSG:=NIL; %flag to indicate whether messages should be %printed; !*NAT := NIL; %used in algebraic mode to denote 'natural' %output. Must be on in symbolic mode to %ensure input echoing; NAT!*!* := NIL; %temporary variable used in algebraic mode; !*OUTPUT := T; %used to suppress output; !*SLIN := NIL; %indicates that LISP code should be read; !*TIME := NIL; %used to indicate timing should be printed; % The second class are those global variables which are %initialized within some function, although they do not appear in that %function's variable list. These are; % CRCHAR!* next character in input line % CURSYM!* current symbol (i. e. identifier, parenthesis, % delimiter, e.t.c,) in input line % FNAME!* name of a procedure being read % FTYPES!* list of regular procedure types % IFL!* input file/channel pair - set in BEGIN to NIL % IPL!* input file list- set in BEGIN to NIL % KEY1!* current key-word being analyzed - set in RLIS1; % NXTSYM!* next symbol read in TOKEN % OFL!* output file/channel pair - set in BEGIN to NIL % OPL!* output file list- set in BEGIN to NIL % PROGRAM!* current input program % PROGRAML!* stores input program when error occurs for a % later restart % SEMIC!* current delimiter character (used to decide % whether to print result of calculation) % TTYPE!* current token type; % WS used in algebraic mode to store top level value % !*FORT used in algebraic mode to denote FORTRAN output % !*INT indicates interactive system use % !*MODE current mode of calculation % !*PRET indicates REDUCE prettyprinting of input; fluid '(IgnoredInBacktrace!*); IgnoredInBacktrace!* := Append(IgnoredInBacktrace!*, '(Begin1 BeginRlisp)); CompileTime flag('(FlagP!*!* CondTerPri LispFileNameP MkFil SetLispScanTable SetRlispScanTable ProgVr), 'InternalFunction); CompileTime << macro procedure PgLine U; % needed for LOCN ''(1 . 1); >>; %********************************************************************* % REDUCE SUPERVISOR %********************************************************************; % The true REDUCE supervisory function is BEGIN, again defined in %the system dependent part of this program. However, most of the work %is done by BEGIN1, which is called by BEGIN for every file %encountered on input; SYMBOLIC PROCEDURE FLAGP!*!*(U,V); IDP U AND FLAGP(U,V); FLUID '(PROMPTSTRING!*); fluid '(STATCOUNTER!*); STATCOUNTER!* := 0; lisp procedure RlispPrompt(); BldMsg("[%w] ", StatCounter!*); put('Symbolic, 'PromptFn, 'RlispPrompt); SYMBOLIC PROCEDURE BEGIN1; BEGIN SCALAR MODE,PARSERR,RESULT,PROMPT,WRKSP,MODEPRINT,PROMPTFN,RESULTL, PROMPTSTRING!*; A0: CURSYM!* := '!*SEMICOL!*; OTIME!* := TIME(); GO TO A1; A: %IF NULL IFL!* AND !*INT % THEN <<%/CRBUFLIS!* := (STATCOUNTER!* . CRBUF!*) . CRBUFLIS!*; % CRBUF!* := NIL>>; A1: IF NULL IFL!* AND !*INT THEN STATCOUNTER!* := STATCOUNTER!* + 1; IF PROMPTFN := GET(!*MODE,'PROMPTFN) THEN PROMPTSTRING!* := APPLY(PROMPTFN,NIL); A2: PARSERR := NIL; % IF !*OUTPUT AND !*INT AND NULL IFL!* AND NULL OFL!* % AND NULL !*DEFN % THEN TERPRI(); IF !*TIME THEN SHOWTIME(); IF TSLIN!* THEN PROGN(!*SLIN := CAR TSLIN!*, LREADFN!* := CDR TSLIN!*, TSLIN!* := NIL); MAPC(INITL!*,FUNCTION SINITL); IF !*INT THEN ERFG!* := NIL; %to make editing work properly; IF CURSYM!* EQ 'END THEN GO TO ND0; PROGRAM!* := ERRORSET('(COMMAND),T,!*BACKTRACE); CONDTERPRI(); IF ATOM PROGRAM!* OR CDR PROGRAM!* THEN GO TO ERR1; PROGRAM!* := CAR PROGRAM!*; IF PROGRAM!* EQ !$EOF!$ THEN GO TO ND1 ELSE IF EQCAR(PROGRAM!*,'!*COMMA!*) THEN GO TO ER ELSE IF CURSYM!* EQ 'END THEN GO TO ND0 ELSE IF EQCAR(PROGRAM!*,'RETRY) THEN PROGRAM!* := PROGRAML!* ;% ELSE IF PROGRAM!* EQ 'ED % THEN PROGN(CEDIT NIL,GO TO A2) % ELSE IF EQCAR(PROGRAM!*,'ED) % THEN PROGN(CEDIT CDR PROGRAM!*,GO TO A2); IF !*DEFN THEN GO TO D; B: %IF !*OUTPUT AND IFL!* AND !*ECHO THEN TERPRI(); RESULTL := ERRORSET(PROGRAM!*,T,!*BACKTRACE); IF ATOM RESULTL OR CDR RESULTL OR ERFG!* THEN GO TO ERR2 ELSE IF !*DEFN THEN GO TO A; RESULT := CAR RESULTL; IF IDP KEY!* AND GET(KEY!*,'STAT) EQ 'MODESTAT THEN MODE := KEY!* ELSE MODE := !*MODE; IF NULL !*OUTPUT OR IFL!* AND !*QUIET THEN GO TO C; IF SEMIC!* EQ '!; THEN << MODEPRINT := GET(MODE,'MODEPRINFN) OR 'PrintWithFreshLine; % IF NOT FLAGP(MODE,'NOTERPRI) THEN % TERPRI(); APPLY(MODEPRINT,RESULTL) >>; C: IF WRKSP := GET(MODE,'WORKSPACE) THEN SET(WRKSP,RESULT); GO TO A; D: IF ERFG!* THEN GO TO A ELSE IF FLAGP!*!*(KEY!*,'IGNORE) OR EQCAR(PROGRAM!*,'QUOTE) THEN GO TO B; IF PROGRAM!* THEN DFPRINT PROGRAM!*; IF FLAGP!*!*(KEY!*,'EVAL) THEN GO TO B ELSE GO TO A; ND0:COMM1 'END; ND1: EOF!* := NIL; IF NULL IPL!* %terminal END; THEN BEGIN IF OFL!* THEN WRS NIL; AA: IF NULL OPL!* THEN RETURN(OFL!* := NIL); CLOSE CDAR OPL!*; OPL!* := CDR OPL!*; GO TO AA END; RETURN NIL; ERR1: IF EOF!* OR PROGRAM!* EQ !$EOF!$ THEN GO TO ND1 ELSE IF PROGRAM!* EQ 'EXTRA! BEGIN THEN GO TO A % ELSE IF PROGRAM!* EQ !*!*ESC THEN GO TO A0 ELSE GO TO ER1; ER: LPRIE IF NULL ATOM CADR PROGRAM!* THEN LIST(CAADR PROGRAM!*,"UNDEFINED") ELSE "SYNTAX ERROR"; ER1: PARSERR := T; GO TO ERR3; ERR2: PROGRAML!* := PROGRAM!*; ERR3: RESETPARSER(); % IF NULL ERFG!* OR ERFG!* EQ 'HOLD % THEN LPRIE "ERROR TERMINATION *****"; ERFG!* := T; IF NULL !*INT THEN GO TO E; RESULT := PAUSE1 PARSERR; IF RESULT THEN RETURN NULL EVAL RESULT; ERFG!* := NIL; GO TO A; E: !*DEFN := T; %continue syntax analyzing but not evaluation; !*ECHO := T; IF NULL CMSG!* THEN LPRIE "CONTINUING WITH PARSING ONLY ..."; CMSG!* := T; GO TO A END; SYMBOLIC PROCEDURE CONDTERPRI; !*OUTPUT AND !*ECHO AND !*EXTRAECHO AND (NULL !*INT OR IFL!*) AND NULL !*DEFN AND POSN() > 0 AND TERPRI(); CommentOutCode << SYMBOLIC PROCEDURE ASSGNL U; IF ATOM U OR NULL (CAR U MEMQ '(SETK SETQ SETEL)) THEN NIL ELSE IF ATOM CADR U THEN MKQUOTE CADR U . ASSGNL CADDR U ELSE CADR U . ASSGNL CADDR U; >>; SYMBOLIC PROCEDURE DFPRINT U; %Looks for special action on a form, otherwise prettyprints it; IF DFPRINT!* THEN APPLY(DFPRINT!*,LIST U) % ELSE IF CMSG!* THEN NIL ELSE IF NULL EQCAR(U,'PROGN) THEN << PRINTF "%f"; PRETTYPRINT U >> ELSE BEGIN A: U := CDR U; IF NULL U THEN RETURN NIL; DFPRINT CAR U; GO TO A END; SYMBOLIC PROCEDURE SHOWTIME; BEGIN SCALAR X; X := OTIME!*; OTIME!* := TIME(); X := OTIME!*-X; % TERPRI(); PRIN2 "TIME: "; PRIN2 X; PRIN2T " MS"; END; SYMBOLIC PROCEDURE SINITL U; SET(U,GET(U,'INITL)); FLAG ('(IN OUT ON OFF SHUT),'IGNORE); %********************************************************************* % IDENTIFIER AND RESERVED CHARACTER READING %********************************************************************; % The function TOKEN defined below is used for reading %identifiers and reserved characters (such as parentheses and infix %operators). It is called by the function SCAN, which translates %reserved characters into their internal name, and sets up the output %of the input line. The following definitions of TOKEN and SCAN are %quite general, but also inefficient. THE READING PROCESS CAN OFTEN %BE SPEEDED UP BY A FACTOR OF AS MUCH AS FIVE IF THESE FUNCTIONS %(ESPECIALLY TOKEN) ARE CODED IN ASSEMBLY LANGUAGE; CommentOutCode << SYMBOLIC PROCEDURE PRIN2X U; OUTL!*:=U . OUTL!*; SYMBOLIC PROCEDURE PTOKEN; BEGIN SCALAR X; X := TOKEN(); IF X EQ '!) AND EQCAR(OUTL!*,'! ) THEN OUTL!*:= CDR OUTL!*; %an explicit reference to OUTL!* used here; PRIN2X X; IF NULL ((X EQ '!() OR (X EQ '!))) THEN PRIN2X '! ; RETURN X END; >>; SYMBOLIC PROCEDURE MKEX U; IF NOT(!*MODE EQ 'ALGEBRAIC) OR EQCAR(U,'AEVAL) THEN U ELSE NIL;%APROC(U,'AEVAL); SYMBOLIC PROCEDURE MKSETQ(U,V); LIST('SETQ,U,V); SYMBOLIC PROCEDURE MKVAR(U,V); U; SYMBOLIC PROCEDURE RPLCDX(U,V); IF CDR U=V THEN U ELSE RPLACD(U,V); SYMBOLIC PROCEDURE REFORM U; IF ATOM U OR CAR U EQ 'QUOTE THEN U ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U ELSE IF CAR U EQ 'PROG THEN PROGN(RPLCDX(CDR U,MAPCAR(CDDR U,FUNCTION REFORM)),U) ELSE IF CAR U EQ 'LAMBDA THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U) ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U THEN BEGIN SCALAR X; IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO)) THEN RETURN LIST('FUNCTION,X) ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U THEN REDERR "MACRO USED AS FUNCTION" ELSE RETURN U END % ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM)) ELSE IF ATOM CAR U THEN BEGIN SCALAR X,Y; IF (Y := GETD CAR U) AND CAR Y EQ 'MACRO AND EXPANDQ CAR U THEN RETURN REFORM APPLY(CDR Y,LIST U); X := REFORMLIS CDR U; IF NULL IDP CAR U THEN RETURN(CAR U . X) ELSE IF (NULL !*CREF OR EXPANDQ CAR U) AND (Y:= GET(CAR U,'NMACRO)) THEN RETURN APPLY(Y,IF FLAGP(CAR U,'NOSPREAD) THEN LIST X ELSE X) ELSE IF (NULL !*CREF OR EXPANDQ CAR U) AND (Y:= GET(CAR U,'SMACRO)) THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y) %we could use an atom SUBLIS here (eg, SUBLA); ELSE RETURN PROGN(RPLCDX(U,X),U) END ELSE REFORM CAR U . REFORMLIS CDR U; SYMBOLIC PROCEDURE REFORMLIS U; IF ATOM U THEN U ELSE REFORM CAR U . REFORMLIS CDR U; SYMBOLIC PROCEDURE EXPANDQ U; %determines if macro U should be expanded in REFORM; FLAGP(U,'EXPAND) OR !*FORCE AND NULL FLAGP(U,'NOEXPAND); CommentOutCode << SYMBOLIC PROCEDURE ARRAYP U; GET(U,'ARRAY); SYMBOLIC PROCEDURE GETTYPE U; %it might be better to use a table here for more generality; IF NULL ATOM U THEN 'FORM ELSE IF NUMBERP U THEN 'NUMBER ELSE IF ARRAYP U THEN 'ARRAY ELSE IF GETD U THEN 'PROCEDURE ELSE IF GLOBALP U THEN 'GLOBAL ELSE IF FLUIDP U THEN 'FLUID ELSE IF GET(U,'MATRIX) THEN 'MATRIX ELSE IF GET(U,'SIMPFN) OR GET(U,'MSIMPFN) THEN 'OPERATOR ELSE IF FLAGP(U,'PARM) THEN 'PARAMETER ELSE NIL; SYMBOLIC PROCEDURE GETELS U; GETEL(CAR U . EVLIS(CDR U)); SYMBOLIC PROCEDURE SETELS(U,V); SETEL(CAR U . EVLIS(CDR U),V); >>; %. Top Level Entry Function %. --- Special Flags ----- % !*DEMO - SYMBOLIC PROCEDURE COMMAND; BEGIN SCALAR X,Y; IF !*DEMO AND (X := IFL!*) THEN PROGN(TERPRI(),RDS NIL,READCH(),RDS CDR X); % IF EDIT!* THEN EDITLINE() ELSE IF FLG!* THEN GO TO A; IF !*SLIN THEN <<KEY!* := SEMIC!* := '!;; CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; X := IF LREADFN!* THEN APPLY(LREADFN!*,NIL) ELSE READ(); IF KEY!* EQ '!; THEN KEY!* := IF ATOM X THEN X ELSE CAR X>> ELSE <<SetRlispScanTable(); MakeInputAvailable(); SCAN(); CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; KEY!* := CURSYM!*; X := XREAD1 NIL>>; IF !*PRET THEN PROGN(TERPRI(),RPRINT X); X := REFORM X; IF CLOC!* AND NOT ATOM X AND CAR X MEMQ '(DE DF DM) THEN PUT(CADR X,'LOCN,CLOC!*) ELSE IF CLOC!* AND EQCAR(X,'PROGN) AND CDDR X AND NOT ATOM CADDR X AND CAADDR X MEMQ '(DE DF DM) THEN PUT(CADR CADDR X,'LOCN,CLOC!*); % IF IFL!*='(DSK!: (INPUT . TMP)) AND % (Y:= PGLINE()) NEQ '(1 . 0) % THEN LPL!*:= Y; %use of IN(noargs); IF NULL IDP KEY!* OR NULL(GET(KEY!*,'STAT) EQ 'MODESTAT) AND NULL(KEY!* EQ 'ED) THEN X := MKEX X; A: IF FLG!* AND IFL!* THEN BEGIN CLOSE CDR IFL!*; IPL!* := DELETE(IFL!*,IPL!*); IF IPL!* THEN RDS CDAR IPL!* ELSE RDS NIL; IFL!* := NIL END; FLG!* := NIL; RETURN X END; OFF R2I; SYMBOLIC PROCEDURE RPRINT U; % Autoloading stub << LOAD RPRINT; RPRINT U >>; ON R2I; %********************************************************************* % GENERAL FUNCTIONS %********************************************************************; %SYMBOLIC PROCEDURE MAPC2(U,V); % %this very conservative definition is to allow for systems with % %poor handling of functional arguments, and because of bootstrap- % %ping difficulties; % BEGIN SCALAR X,Y,Z; % A: IF NULL U THEN RETURN REVERSIP Z; % X := CAR U; % Y := NIL; % B: IF NULL X THEN GO TO C; % Y := APPLY(V,LIST CAR X) . Y; % X := CDR X; % GO TO B; % C: U := CDR U; % Z := REVERSIP Y . Z: % GO TO A % END; %********************************************************************* % FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES %********************************************************************; SYMBOLIC PROCEDURE LPRIE U; << ERRORPRINTF("***** %L", U); ERFG!* := T >>; SYMBOLIC PROCEDURE LPRIM U; !*MSG AND ERRORPRINTF("*** %L", U); SYMBOLIC PROCEDURE REDERR U; BEGIN %TERPRI(); LPRIE U; ERROR(99,NIL) END; SYMBOLIC PROCEDURE PROGVR VAR; IF NOT ATOM VAR THEN NIL ELSE IF NUMBERP VAR OR FLAGP(VAR,'SHARE) OR NOT(!*MODE EQ 'ALGEBRAIC) AND FLUIDP VAR THEN T ELSE BEGIN SCALAR X; IF X := GET(VAR,'DATATYPE) THEN RETURN CAR X END; SYMBOLIC PROCEDURE MKARG U; IF NULL U THEN NIL ELSE IF ATOM U THEN IF PROGVR U THEN U ELSE MKQUOTE U ELSE IF CAR U EQ 'QUOTE THEN MKQUOTE U ELSE IF FLAGP!*!*(CAR U,'NOCHANGE) AND NOT FLAGP(KEY1!*,'QUOTE) THEN U ELSE 'LIST . MAPCAR(U,FUNCTION MKARG); SYMBOLIC PROCEDURE MKPROG(U,V); 'PROG . (U . V); CommentOutCode << SYMBOLIC PROCEDURE SETDIFF(U,V); IF NULL V THEN U ELSE SETDIFF(DELETE(CAR V,U),CDR V); SYMBOLIC PROCEDURE REMTYPE VARLIS; BEGIN SCALAR X,Y; VARS!* := SETDIFF(VARS!*,VARLIS); A: IF NULL VARLIS THEN RETURN NIL; X := CAR VARLIS; Y := CDR GET(X,'DATATYPE); IF Y THEN PUT(X,'DATATYPE,Y) ELSE PROGN(REMPROP(X,'DATATYPE),REMFLAG(LIST X,'PARM)); VARLIS := CDR VARLIS; GO TO A END; >>; DEFLIST('((LISP SYMBOLIC)),'NEWNAM); FLAG('(FOR),'NOCHANGE); FLAG('(REPEAT),'NOCHANGE); FLAG('(WHILE),'NOCHANGE); CommentOutCode << COMMENT LISP arrays built with computed index into a vector; % FLUID '(U V X Y N); %/ Fix for MAPC closed compile SYMBOLIC PROCEDURE ARRAY U; FOR EACH X IN U DO BEGIN INTEGER Y; IF NULL CDR X OR NOT IDP CAR X THEN REDERR LIST(X,"CANNOT BECOME AN ARRAY"); Y:=1; FOR EACH V IN CDR X DO Y:=Y*(V+1); PUT(CAR X,'ARRAY,MKVECT(Y-1)); PUT(CAR X,'DIMENSION,ADD1LIS CDR X); END; SYMBOLIC PROCEDURE CINDX!* U; BEGIN SCALAR V; INTEGER N; N:=0; IF NULL(V:=DIMENSION CAR U) THEN REDERR LIST(CAR U,"NOT AN ARRAY"); FOR EACH Y IN CDR U DO <<IF NULL V THEN REDERR LIST(U,"TOO MANY INDICES"); IF Y<0 OR Y>CAR V-1 THEN REDERR LIST(U,"INDEX OUT OF RANGE"); N:=Y+N*CAR V; V:=CDR V>>; IF V THEN REDERR LIST(U,"TOO FEW INDICES"); RETURN N END; %UNFLUID '(U V X Y N); %/ Fix for MAPC closed compile SYMBOLIC PROCEDURE GETEL U; GETV(ARRAYP CAR U,CINDX!* U); SYMBOLIC PROCEDURE SETEL(U,V); PUTV(ARRAYP CAR U,CINDX!* U,V); SYMBOLIC PROCEDURE DIMENSION U; GET(U,'DIMENSION); COMMENT further support for REDUCE arrays; SYMBOLIC PROCEDURE TYPECHK(U,V); BEGIN SCALAR X; IF (X := GETTYPE U) EQ V OR X EQ 'PARAMETER THEN LPRIM LIST(U,"ALREADY DEFINED AS",V) ELSE IF X THEN REDERR LIST(X,U,"INVALID AS",V) END; SYMBOLIC PROCEDURE NUMLIS U; NULL U OR (NUMBERP CAR U AND NUMLIS CDR U); CompileTime REMPROP('ARRAY,'STAT); %for bootstrapping purposes; SYMBOLIC PROCEDURE ARRAYFN U; BEGIN SCALAR X,Y; A: IF NULL U THEN RETURN; X := CAR U; IF ATOM X THEN REDERR "SYNTAX ERROR" ELSE IF TYPECHK(CAR X,'ARRAY) THEN GO TO B; Y := IF NOT(!*MODE EQ 'ALGEBRAIC) THEN !*EVLIS CDR X ELSE REVLIS CDR X; IF NOT NUMLIS Y THEN LPRIE LIST("INCORRECT ARRAY ARGUMENTS FOR",CAR X); ARRAY LIST (CAR X . Y); B: U := CDR U; GO TO A END; SYMBOLIC PROCEDURE ADD1LIS U; IF NULL U THEN NIL ELSE (CAR U+1) . ADD1LIS CDR U; >>; %********************************************************************* %********************************************************************* % REDUCE FUNCTIONS FOR HANDLING INPUT AND OUTPUT OF FILES %********************************************************************* %********************************************************************; GLOBAL '(CONTL!*); MACRO PROCEDURE IN U; LIST('EVIN, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVIN U; BEGIN SCALAR CHAN,ECHO,ECHOP,EXTN,OSLIN,OLRDFN,OTSLIN; ECHOP := SEMIC!* EQ '!;; ECHO := !*ECHO; IF NULL IFL!* THEN TECHO!* := !*ECHO; %terminal echo status; OSLIN := !*SLIN; OLRDFN := LREADFN!*; OTSLIN := TSLIN!*; TSLIN!* := NIL; FOR EACH FL IN U DO <<CHAN := OPEN(FL,'INPUT); IFL!* := FL . CHAN; IPL!* := IFL!* . IPL!*; RDS (IF IFL!* THEN CDR IFL!* ELSE NIL); !*ECHO := ECHOP; !*SLIN := T; IF LISPFILENAMEP FL THEN LREADFN!* := NIL ELSE !*SLIN := OSLIN; BEGIN1(); IF !*SLIN THEN RESETPARSER(); IF CHAN THEN CLOSE CHAN; LREADFN!* := OLRDFN; !*SLIN := OSLIN; IF FL EQ CAAR IPL!* THEN IPL!* := CDR IPL!* ELSE REDERR LIST("FILE STACK CONFUSION",FL,IPL!*)>>; !*ECHO := ECHO; %restore echo status; TSLIN!* := OTSLIN; IF IPL!* AND NULL CONTL!* THEN IFL!* := CAR IPL!* ELSE IFL!* := NIL; RDS(IF IFL!* THEN CDR IFL!* ELSE NIL); RETURN NIL END; CommentOutCode << lisp procedure RedIN F; begin scalar !*Echo, !*Output, !*SLIN, Chan; IPL!* := (IFL!* := (F . (Chan := Open(F, 'Input)))) . IPL!*; RDS Chan; Begin1(); IPL!* := cdr IPL!*; RDS(if not null IPL!* then cdr first IPL!* else NIL); end; >>; SYMBOLIC PROCEDURE LISPFILENAMEP S; %. Look for ".SL" or ".LSP" BEGIN SCALAR C, I, SS; SS := SIZE S; IF SS < 3 THEN RETURN NIL; I := SS; LOOP: IF I < 0 THEN RETURN NIL; IF INDX(S, I) = CHAR '!. THEN GOTO LOOPEND; I := I - 1; GOTO LOOP; LOOPEND: I := I + 1; C := SS - I; IF NOT (C MEMBER '(1 2)) THEN RETURN NIL; C := SUBSEQ(S, I, SS + 1); RETURN IF C MEMBER '("SL" "sl" "LSP" "lsp" "Sl" "Lsp") THEN T ELSE NIL; END; MACRO PROCEDURE OUT U; LIST('EVOUT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVOUT U; %U is a list of one file; BEGIN SCALAR CHAN,FL,X; IF NULL U THEN RETURN NIL ELSE IF CAR U EQ 'T THEN RETURN <<WRS(OFL!* := NIL); NIL>>; FL := MKFIL CAR U; IF NOT (X := ASSOC(FL,OPL!*)) THEN <<CHAN := OPEN(FL,'OUTPUT); OFL!* := FL . CHAN; OPL!* := OFL!* . OPL!*>> ELSE OFL!* := X; WRS CDR OFL!* END; MACRO PROCEDURE SHUT U; LIST('EVSHUT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVSHUT U; %U is a list of names of files to be shut; BEGIN SCALAR FL,FL1; A: IF NULL U THEN RETURN NIL ELSE IF FL1 := ASSOC((FL := MKFIL CAR U),OPL!*) THEN GO TO B ELSE IF NOT (FL1 := ASSOC(FL,IPL!*)) THEN REDERR LIST(FL,"NOT OPEN"); IF FL1 NEQ IFL!* THEN <<CLOSE CDR FL1; IPL!* := DELETE(FL1,IPL!*)>> ELSE REDERR LIST("CANNOT CLOSE CURRENT INPUT FILE",CAR FL); GO TO C; B: OPL!* := DELETE(FL1,OPL!*); IF FL1=OFL!* THEN <<OFL!* := NIL; WRS NIL>>; CLOSE CDR FL1; C: U := CDR U; GO TO A END; %/ removed STAT property %********************************************************************* % FUNCTIONS HANDLING INTERACTIVE FEATURES %********************************************************************; %GLOBAL Variables referenced in this Section; CONTL!* := NIL; SYMBOLIC PROCEDURE PAUSE; PAUSE1 NIL; SYMBOLIC PROCEDURE PAUSE1 BOOL; BEGIN % IF BOOL THEN % IF NULL IFL!* % THEN RETURN IF !*INT AND GETD 'CEDIT AND YESP 'EDIT!? % THEN CEDIT() ELSE % NIL % ELSE IF GETD 'EDIT1 AND ERFG!* AND CLOC!* AND YESP 'EDIT!? % THEN RETURN <<CONTL!* := NIL; % IF OFL!* THEN <<LPRIM LIST(CAR OFL!*,'SHUT); % CLOSE CDR OFL!*; % OPL!* := DELETE(OFL!*,OPL!*); % OFL!* := NIL>>; % EDIT1(CLOC!*,NIL)>> % ELSE IF FLG!* THEN RETURN (EDIT!* := NIL); IF NULL IFL!* OR YESP 'CONT!? THEN RETURN NIL; CONTL!* := IFL!* . !*ECHO . CONTL!*; RDS (IFL!* := NIL); !*ECHO := TECHO!* END; SYMBOLIC PROCEDURE CONT; BEGIN SCALAR FL,TECHO; IF IFL!* THEN RETURN NIL %CONT only active from terminal; ELSE IF NULL CONTL!* THEN REDERR "NO FILE OPEN"; FL := CAR CONTL!*; TECHO := CADR CONTL!*; CONTL!* := CDDR CONTL!*; IF FL=CAR IPL!* THEN <<IFL!* := FL; RDS IF FL THEN CDR FL ELSE NIL; !*ECHO := TECHO>> ELSE <<EOF!* :=T; LPRIM LIST(FL,"NOT OPEN"); ERROR(99,NIL)>> END; %/DEFLIST ('((PAUSE ENDSTAT) (CONT ENDSTAT) (RETRY ENDSTAT)),'STAT); %/PUT('RETRY,'STAT,'ENDSTAT); FLAG ('(CONT),'IGNORE); %******** "rend" fixups GLOBAL '(!*INT CONTL!* DATE!* !*MODE IMODE!* CRCHAR!* !*SLIN LREADFN!*); REMFLAG('(BEGINRLISP),'GO); %---- Merge into XREAD1 in command ---- % Shouldnt USE Scan in COMMAND, since need change Parser first FLUID '(!*PECHO); Symbolic Procedure XREAD1 x; %. With Catches Begin scalar Form!*; Form!*:=PARSE0(0, NIL); If !*PECHO then PRIN2T LIST("parse>",Form!*); Return Form!* end; lisp procedure Xread X; Begin scalar Form!*; MakeInputAvailable(); Form!*:=PARSE0(0, T); If !*PECHO then PRIN2T LIST("parse>",Form!*); Return Form!* end; !*PECHO:=NIL; SYMBOLIC PROCEDURE BEGINRLISP; BEGIN SCALAR A,B,PROMPTSTRING!*; %/ !*BAKGAG := NIL; !*INT := T; !*ECHO := NIL; A := !*SLIN; !*SLIN := LREADFN!* := NIL; CONTL!* := IFL!* := IPL!* := OFL!* := OPL!* := NIL; !*MODE := IMODE!*; CRCHAR!* := '! ; %/ RDSLSH NIL; %/ SETPCHAR '!*; SetRlispScanTable(); % IF SYSTEM!* NEQ 0 THEN CHKLEN(); IF DATE!* EQ NIL THEN IF A THEN <<PRIN2 "Entering RLISP..."; GO TO B>> ELSE GO TO A; %/ IF FILEP '((REDUCE . INI)) THEN <<IN REDUCE.INI; TERPRI()>>; %/ ERRORSET(QUOTE LAPIN "PSL.INI", NIL, NIL); % no error if not there PRIN2 DATE!*; DATE!* := NIL; % IF SYSTEM!* NEQ 1 THEN GO TO A; % IF !*HELP THEN PRIN2 "For help, type HELP()"; B: TERPRI(); A: BEGIN1(); % TERPRI(); !*SLIN := T; %/ RDSLSH NIL; SetLispScanTable(); PRIN2T "Entering LISP..." END; FLAG('(BEGINRLISP),'GO); PUTD('BEGIN,'EXPR, CDR GETD 'BEGINRLISP); SYMBOLIC PROCEDURE MKFIL U; %converts file descriptor U into valid system filename; U; SYMBOLIC PROCEDURE NEWMKFIL U; %converts file descriptor U into valid system filename; U; lisp procedure SetPChar C; %. Set prompt, return old one begin scalar OldPrompt; OldPrompt := PromptString!*; PromptString!* := if StringP C then C else if IDP C then CopyString ID2String C else BldMsg("%w", C); return OldPrompt; end; COMMENT Some Global Variables required by REDUCE; %GLOBAL '(!*!*ESC); % %!*!*ESC := 'ESC!.NOT!.NEEDED!.NOW; %to make it user settable (used to be a NEWNAM); COMMENT The remaining material in this file introduces extensions or redefinitions of code in the REDUCE source files, and is not really necessary to run a basic system; lisp procedure SetRlispScanTable(); << CurrentReadMacroIndicator!* :='RLispReadMacro; CurrentScanTable!* := RLispScanTable!* >>; lisp procedure SetLispScanTable(); << CurrentReadMacroIndicator!* :='LispReadMacro; CurrentScanTable!* := LispScanTable!* >>; PutD('LispSaveSystem, 'EXPR, cdr GetD 'SaveSystem); lisp procedure SaveSystem(S, F, I); %. Set up for saving EXE file << StatCounter!* := 0; RemD 'Main; Copyd('Main, 'RlispMain); Date!* := BldMsg("%w, %w", S, Date()); LispSaveSystem("PSL", F, I) >>; lisp procedure RlispMain(); << BeginRlisp(); StandardLisp() >>; lisp procedure Rlisp(); % Uses new top loop << SetRlispScanTable(); TopLoop('ReformXRead, 'PrintWithFreshLine, 'Eval, "rlisp", "PSL Rlisp") >>; lisp procedure ReformXRead(); Reform XRead T; !*RAISE := T; %IF GETD 'ADDSQ THEN IMODE!* := 'ALGEBRAIC ELSE IMODE!* := 'SYMBOLIC; IMODE!* := 'SYMBOLIC; TSLIN!* := NIL; !*MSG := T; END; |
Added psl-1983/3-1/util/rlisp.build version [008da78a20].
> > | 1 2 | in "rlisp-parser.red"$ in "rlisp-support.red"$ |
Added psl-1983/3-1/util/rlispcomp.sl version [04de8e3ce2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % RLISPCOMP.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This program reads and interprets % the program command string as a list of source files to be compiled. (CompileTime (load common pathnames)) (load pathnamex parse-command-string get-command-string compiler) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (fluid '(*quiet_faslout *WritingFASLFile)) (de rlispcomp () (let ((c-list (parse-command-string (get-command-string))) (*usermode nil) (*redefmsg nil)) (compile-files c-list) ) ) (de compile-files (c-list) (cond ((null c-list) (PrintF "RLisp Compiler%n") (PrintF "Usage: RLISPCOMP source-file ...%n") ) (t (for (in fn c-list) (do (attempt-to-compile-file fn)) ) (quit) ))) (de attempt-to-compile-file (fn) (let* ((form (list 'COMPILE-FILE fn)) (*break NIL) (result (ErrorSet form T NIL)) ) (cond ((FixP result) (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" fn) )) )) (de compile-file (fn) (let ((source-fn (namestring (pathname-set-default-type fn "RED"))) (binary-fn (namestring (pathname-set-type fn "B"))) (*quiet_faslout T) ) (if (not (FileP source-fn)) (printf "Unable to open source file: %w%n" source-fn) % else (printf "%n----- Compiling %w%n" source-fn binary-fn) (faslout (namestring (pathname-without-type binary-fn))) (eval (list 'in source-fn)) % Damn FEXPRs (faslend) (printf "%nDone compiling %w%n%n" source-fn) ))) |
Added psl-1983/3-1/util/rprint.build version [3f6c215438].
> | 1 | in "rprint.red"$ |
Added psl-1983/3-1/util/rprint.red version [4840e5e9cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE RPRINT; COMMENT THE STANDARD LISP TO REDUCE PRETTY PRINTER; COMMENT THESE GUYS ARE SET BY THE OLD PARSER AND DO NOT NORMALLY EXIST IN PSL; PUT('EXPT,'OP,'((19 19))); PUT('TIMES,'OP,'((17 17))); PUT('!*SEMICOL!*,'OP,'((-1 0))); PUT('OR,'OP,'((3 3))); PUT('GEQ,'OP,'((11 11))); PUT('NOT,'OP,'(NIL 5)); PUT('RECIP,'OP,'(NIL 18)); PUT('QUOTIENT,'OP,'((18 18))); PUT('MEMQ,'OP,'((7 7))); PUT('MINUS,'OP,'(NIL 16)); PUT('SETQ,'OP,'((2 2))); PUT('GREATERP,'OP,'((12 12))); PUT('MEMBER,'OP,'((6 6))); PUT('AND,'OP,'((4 4))); PUT('CONS,'OP,'((20 20))); PUT('PLUS,'OP,'((15 15))); PUT('EQUAL,'OP,'((8 8))); PUT('LEQ,'OP,'((13 13))); PUT('DIFFERENCE,'OP,'((16 16))); PUT('NEQ,'OP,'((9 9))); PUT('LESSP,'OP,'((14 14))); PUT('!*COMMA!*,'OP,'((5 6))); PUT('EQ,'OP,'((10 10))); FLUID '(PRETOP PRETOPRINF); PRETOP := 'OP; PRETOPRINF := 'OPRINF; FLUID '(COMBUFF); FLUID '(CURMARK BUFFP RMAR !*N); SYMBOLIC PROCEDURE RPRINT U; BEGIN INTEGER !*N; SCALAR BUFF,BUFFP,CURMARK,RMAR,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); RMAR := LINELENGTH NIL; X := GET('!*SEMICOL!*,PRETOP); !*N := 0; MPRINO1(U,LIST(CAAR X,CADAR X)); PRIN2OX ";"; OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE RPRIN1 U; BEGIN SCALAR BUFF,BUFFP,CURMARK,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); X := GET('!*SEMICOL!*,PRETOP); MPRINO1(U,LIST(CAAR X,CADAR X)); OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE MPRINO U; MPRINO1(U,LIST(0,0)); SYMBOLIC PROCEDURE MPRINO1(U,V); BEGIN SCALAR X; IF X := ATSOC(U,COMBUFF) THEN <<FOR EACH Y IN CDR X DO COMPROX Y; COMBUFF := DELETE(X,COMBUFF)>>; IF NUMBERP U AND U<0 AND (X := GET('DIFFERENCE,PRETOP)) THEN RETURN BEGIN SCALAR P; X := CAR X; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; PRINOX U; IF P THEN PRINOX ")" END ELSE IF ATOM U THEN RETURN PRINOX U ELSE IF NOT ATOM CAR U THEN <<CURMARK := CURMARK+1; PRIN2OX "("; MPRINO CAR U; PRIN2OX ")"; OMARK LIST(CURMARK,3); CURMARK := CURMARK-1>> ELSE IF X := GET(CAR U,PRETOPRINF) THEN RETURN BEGIN SCALAR P; P := CAR V>0 AND NOT CAR U MEMQ '(BLOCK PROG QUOTE STRING); IF P THEN PRIN2OX "("; APPLY(X,LIST CDR U); IF P THEN PRIN2OX ")" END ELSE IF X := GET(CAR U,PRETOP) THEN RETURN IF CAR X THEN INPRINOX(U,CAR X,V) ELSE IF CDDR U THEN REDERR "SYNTAX ERROR" ELSE IF NULL CADR X THEN INPRINOX(U,LIST(100,1),V) ELSE INPRINOX(U,LIST(100,CADR X),V) ELSE PRINOX CAR U; IF RLISTATP CAR U THEN RETURN RLPRI(CDR U,V); U := CDR U; IF NULL U THEN PRIN2OX "()" ELSE MPRARGS(U,V) END; SYMBOLIC PROCEDURE MPRARGS(U,V); IF NULL CDR U THEN <<PRIN2OX " "; MPRINO1(CAR U,LIST(100,100))>> ELSE INPRINOX('!*COMMA!* . U,LIST(0,0),V); SYMBOLIC PROCEDURE INPRINOX(U,X,V); BEGIN SCALAR P; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; OMARK '(M U); INPRINO(CAR U,X,CDR U); IF P THEN PRIN2OX ")"; OMARK '(M D) END; SYMBOLIC PROCEDURE INPRINO(OPR,V,L); BEGIN SCALAR FLG,X; CURMARK := CURMARK+2; X := GET(OPR,PRETOP); IF X AND CAR X THEN <<MPRINO1(CAR L,LIST(CAR V,0)); L := CDR L; FLG := T>>; WHILE L DO <<IF OPR EQ '!*COMMA!* THEN <<PRIN2OX ","; OMARKO CURMARK>> ELSE IF OPR EQ 'SETQ THEN <<PRIN2OX " := "; OMARK LIST(CURMARK,1)>> ELSE IF ATOM CAR L OR NOT OPR EQ GET!*(CAAR L,'ALT) THEN <<OMARK LIST(CURMARK,1); OPRINO(OPR,FLG); FLG := T>>; MPRINO1(CAR L,LIST(IF NULL CDR L THEN 0 ELSE CAR V, IF NULL FLG THEN 0 ELSE CADR V)); L := CDR L>>; CURMARK := CURMARK-2 END; SYMBOLIC PROCEDURE OPRINO(OPR,B); (LAMBDA X; IF NULL X THEN <<IF B THEN PRIN2OX " "; PRINOX OPR; PRIN2OX " ">> ELSE PRIN2OX CAR X) GET(OPR,'PRTCH); SYMBOLIC PROCEDURE PRIN2OX U; <<RPLACD(BUFFP,EXPLODE2 U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE PRINOX U; <<RPLACD(BUFFP,EXPLODE U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE GET!*(U,V); IF NUMBERP U THEN NIL ELSE GET(U,V); SYMBOLIC PROCEDURE OMARK U; <<RPLACD(BUFFP,LIST U); BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE OMARKO U; OMARK LIST(U,0); SYMBOLIC PROCEDURE COMPROX U; BEGIN SCALAR X; IF CAR BUFFP = '(0 0) THEN RETURN <<FOR EACH J IN U DO PRIN2OX J; OMARK '(0 0)>>; X := CAR BUFFP; RPLACA(BUFFP,LIST(CURMARK+1,3)); FOR EACH J IN U DO PRIN2OX J; OMARK X END; SYMBOLIC PROCEDURE RLISTATP U; GET(U,'STAT) MEMBER '(ENDSTAT RLIS RLIS2); SYMBOLIC PROCEDURE RLPRI(U,V); IF NULL U THEN NIL ELSE IF NOT CAAR U EQ 'LIST OR CDR U THEN REDERR "RPRINT FORMAT ERROR" ELSE BEGIN PRIN2OX " "; OMARK '(M U); INPRINO('!*COMMA!*,LIST(0,0),RLPRI1 CDAR U); OMARK '(M D) END; SYMBOLIC PROCEDURE RLPRI1 U; IF NULL U THEN NIL ELSE IF EQCAR(CAR U,'QUOTE) THEN CADAR U . RLPRI1 CDR U ELSE IF STRINGP CAR U THEN CAR U . RLPRI1 CDR U ELSE REDERR "RPRINT FORMAT ERROR"; SYMBOLIC PROCEDURE CONDOX U; BEGIN SCALAR X; OMARK '(M U); CURMARK := CURMARK+2; WHILE U DO <<PRIN2OX "IF "; MPRINO CAAR U; OMARK LIST(CURMARK,1); PRIN2OX " THEN "; IF CDR U AND EQCAR(CADAR U,'COND) AND NOT EQCAR(CAR REVERSE CADAR U,'T) THEN <<X := T; PRIN2OX "(">>; MPRINO CADAR U; IF X THEN PRIN2OX ")"; U := CDR U; IF U THEN <<OMARKO(CURMARK-1); PRIN2OX " ELSE ">>; IF U AND NULL CDR U AND CAAR U EQ 'T THEN <<MPRINO CADAR U; U := NIL>>>>; CURMARK := CURMARK-2; OMARK '(M D) END; PUT('COND,PRETOPRINF,'CONDOX); SYMBOLIC PROCEDURE BLOCKOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "BEGIN "; IF CAR U THEN VARPRX CAR U; U := CDR U; OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3); WHILE U DO <<MPRINO CAR U; IF NOT EQCAR(CAR U,'!*LABEL) AND CDR U THEN PRIN2OX "; "; U := CDR U; IF U THEN OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3)>>; OMARK LIST(CURMARK-1,-1); PRIN2OX " END"; CURMARK := CURMARK-2; OMARK '(M D) END; SYMBOLIC PROCEDURE RETOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "RETURN "; OMARK '(M U); MPRINO CAR U; CURMARK := CURMARK-2; OMARK '(M D); OMARK '(M D) END; PUT('RETURN,PRETOPRINF,'RETOX); %SYMBOLIC PROCEDURE VARPRX U; % MAPC(CDR U,FUNCTION (LAMBDA J; % <<PRIN2OX CAR J; % PRIN2OX " "; % INPRINO('!*COMMA!*,LIST(0,0),CDR J); % PRIN2OX "; "; % OMARK LIST(CURMARK,6)>>)); COMMENT a version for the old parser; SYMBOLIC PROCEDURE VARPRX U; BEGIN SCALAR TYP; U := REVERSE U; WHILE U DO <<IF CDAR U EQ TYP THEN <<PRIN2OX ","; OMARKO(CURMARK+1); PRINOX CAAR U>> ELSE <<IF TYP THEN <<PRIN2OX "; "; OMARK '(M D)>>; PRINOX (TYP := CDAR U); PRIN2OX " "; OMARK '(M U); PRINOX CAAR U>>; U := CDR U>>; PRIN2OX "; "; OMARK '(M D) END; PUT('BLOCK,PRETOPRINF,'BLOCKOX); SYMBOLIC PROCEDURE PROGOX U; BLOCKOX(MAPCAR(REVERSE CAR U,FUNCTION (LAMBDA J; J . 'SCALAR)) . LABCHK CDR U); SYMBOLIC PROCEDURE LABCHK U; BEGIN SCALAR X; FOR EACH Z IN U DO IF ATOM Z THEN X := LIST('!*LABEL,Z) . X ELSE X := Z . X; RETURN REVERSIP X END; PUT('PROG,PRETOPRINF,'PROGOX); SYMBOLIC PROCEDURE GOX U; <<PRIN2OX "GO TO "; PRINOX CAR U>>; PUT('GO,PRETOPRINF,'GOX); SYMBOLIC PROCEDURE LABOX U; <<PRINOX CAR U; PRIN2OX ": ">>; PUT('!*LABEL,PRETOPRINF,'LABOX); SYMBOLIC PROCEDURE QUOTOX U; IF STRINGP U THEN PRINOX U ELSE <<PRIN2OX "'"; PRINSOX CAR U>>; SYMBOLIC PROCEDURE PRINSOX U; IF ATOM U THEN PRINOX U ELSE <<PRIN2OX "("; OMARK '(M U); CURMARK := CURMARK+1; WHILE U DO <<PRINSOX CAR U; U := CDR U; IF U THEN <<OMARK LIST(CURMARK,-1); IF ATOM U THEN <<PRIN2OX " . "; PRINSOX U; U := NIL>> ELSE PRIN2OX " ">>>>; CURMARK := CURMARK-1; OMARK '(M D); PRIN2OX ")">>; PUT('QUOTE,PRETOPRINF,'QUOTOX); SYMBOLIC PROCEDURE PROGNOX U; BEGIN CURMARK := CURMARK+1; PRIN2OX "<<"; OMARK '(M U); WHILE U DO <<MPRINO CAR U; U := CDR U; IF U THEN <<PRIN2OX "; "; OMARKO CURMARK>>>>; OMARK '(M D); PRIN2OX ">>"; CURMARK := CURMARK-1 END; PUT('PROG2,PRETOPRINF,'PROGNOX); PUT('PROGN,PRETOPRINF,'PROGNOX); SYMBOLIC PROCEDURE REPEATOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "REPEAT "; MPRINO CAR U; PRIN2OX " UNTIL "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('REPEAT,PRETOPRINF,'REPEATOX); SYMBOLIC PROCEDURE WHILEOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "WHILE "; MPRINO CAR U; PRIN2OX " DO "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('WHILE,PRETOPRINF,'WHILEOX); SYMBOLIC PROCEDURE PROCOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; IF CADDDR CDR U THEN <<MPRINO CADDDR CDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCOX1(CAR U,CADR U,CADDR U) END; SYMBOLIC PROCEDURE PROCOX1(U,V,W); BEGIN PRINOX U; IF V THEN MPRARGS(V,LIST(0,0)); PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK-1; OMARK '(M D) END; PUT('PROC,PRETOPRINF,'PROCOX); SYMBOLIC PROCEDURE PROCEOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; MPRINO CADR U; PRIN2OX " "; IF NOT CADDR U EQ 'EXPR THEN <<MPRINO CADDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCEOX1(CAR U,CADDDR U,CAR CDDDDR U) END; SYMBOLIC PROCEDURE PROCEOX1(U,V,W); BEGIN PRINOX U; IF V THEN MPRARGS(MAPCAR(V,FUNCTION CAR),LIST(0,0)); %we need to check here for non-default type; PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK -1; OMARK '(M D) END; PUT('PROCEDURE,PRETOPRINF,'PROCEOX); SYMBOLIC PROCEDURE PROCEOX0(U,V,W,X); PROCEOX LIST(U,'SYMBOLIC,V,MAPCAR(W,FUNCTION (LAMBDA J; J . 'SYMBOLIC)),X); SYMBOLIC PROCEDURE DEOX U; PROCEOX0(CAR U,'EXPR,CADR U,CADDR U); PUT('DE,PRETOPRINF,'DEOX); SYMBOLIC PROCEDURE DFOX U; PROCEOX0(CAR U,'FEXPR,CADR U,CADDR U); PUT('DF,PRETOPRINF,'DFOX); SYMBOLIC PROCEDURE DMOX U; PROCEOX0(CAR U,'MACRO,CADR U,CADDR U); PUT('DM,PRETOPRINF,'DMOX); SYMBOLIC PROCEDURE LAMBDOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; PROCOX1('LAMBDA,CAR U,CADR U) END; PUT('LAMBDA,PRETOPRINF,'LAMBDOX); SYMBOLIC PROCEDURE EACHOX U; <<PRIN2OX "FOR EACH "; WHILE CDR U DO <<MPRINO CAR U; PRIN2OX " "; U := CDR U>>; MPRINO CAR U>>; PUT('FOREACH,PRETOPRINF,'EACHOX); COMMENT Declarations needed by old parser; IF NULL GET('!*SEMICOL!*,'OP) THEN <<PUT('!*SEMICOL!*,'OP,'((-1 0))); PUT('!*COMMA!*,'OP,'((5 6)))>>; COMMENT RPRINT MODULE, Page 2; FLUID '(ORIG CURPOS); SYMBOLIC PROCEDURE PRINOS U; BEGIN INTEGER CURPOS; SCALAR ORIG; ORIG := LIST POSN(); CURPOS := CAR ORIG; PRINOY(U,0); TERPRI0X() END; SYMBOLIC PROCEDURE PRINOY(U,N); BEGIN SCALAR X; IF CAR(X := SPACELEFT(U,N)) THEN RETURN PRINOM(U,N) ELSE IF NULL CDR X THEN RETURN IF CAR ORIG<10 THEN PRINOM(U,N) ELSE <<ORIG := 9 . CDR ORIG; TERPRI0X(); RPSPACES2(CURPOS := 9+CADAR U); PRINOY(U,N)>> ELSE BEGIN A: U := PRINOY(U,N+1); IF NULL CDR U OR CAAR U<=N THEN RETURN; TERPRI0X(); RPSPACES2(CURPOS := CAR ORIG+CADAR U); GO TO A END; RETURN U END; SYMBOLIC PROCEDURE SPACELEFT(U,MARK); %U is an expanded buffer of characters delimited by non-atom marks %of the form: '(M ...) or '(INT INT)) %MARK is an integer; BEGIN INTEGER N; SCALAR FLG,MFLG; N := RMAR - CURPOS; U := CDR U; %move over the first mark; WHILE U AND NOT FLG AND N>=0 DO <<IF ATOM CAR U THEN N := N-1 ELSE IF CAAR U EQ 'M THEN NIL ELSE IF MARK>=CAAR U THEN <<FLG := T; U := NIL . U>> ELSE MFLG := T; U := CDR U>>; RETURN ((N>=0) . MFLG) END; SYMBOLIC PROCEDURE PRINOM(U,MARK); BEGIN INTEGER N; SCALAR FLG,X; N := CURPOS; U := CDR U; WHILE U AND NOT FLG DO <<IF ATOM CAR U THEN <<X := PRIN20X CAR U; N := N+1>> ELSE IF CAAR U EQ 'M THEN IF CADAR U EQ 'U THEN ORIG := N . ORIG ELSE ORIG := CDR ORIG ELSE IF MARK>=CAAR U AND NOT(X='!, AND RMAR-N-6>CHARSPACE(U,X,MARK)) THEN <<FLG := T; U := NIL . U>>; U := CDR U>>; CURPOS := N; IF MARK=0 AND CDR U THEN <<TERPRI0X(); TERPRI0X(); ORIG := LIST 0; CURPOS := 0; PRINOY(U,MARK)>>; %must be a top level constant; RETURN U END; SYMBOLIC PROCEDURE CHARSPACE(U,CHR,MARK); %determines if there is space until the next character CHR; BEGIN INTEGER N; N := 0; WHILE U DO <<IF CAR U = CHR THEN U := LIST NIL ELSE IF ATOM CAR U THEN N := N+1 ELSE IF CAR U='(M U) THEN <<N := 1000; U := LIST NIL>> ELSE IF NUMBERP CAAR U AND CAAR U<MARK THEN U := LIST NIL; U := CDR U>>; RETURN N END; SYMBOLIC PROCEDURE RPSPACES2 N; %FOR I := 1:N DO PRIN20X '! ; WHILE N>0 DO <<PRIN20X '! ; N := N-1>>; SYMBOLIC PROCEDURE PRIN2ROX U; BEGIN INTEGER M,N; SCALAR X,Y; M := RMAR-12; N := RMAR-1; WHILE U DO IF CAR U EQ '!" THEN <<IF NOT STRINGSPACE(CDR U,N-!*N) THEN <<TERPRI0X(); !*N := 0>> ELSE NIL; PRIN20X '!"; U := CDR U; WHILE NOT CAR U EQ '!" DO <<PRIN20X CAR U; U := CDR U; !*N := !*N+1>>; PRIN20X '!"; U := CDR U; !*N := !*N+2; X := Y := NIL>> ELSE IF ATOM CAR U AND NOT(CAR U EQ '! AND (!*N=0 OR NULL X OR CDR U AND BREAKP CADR U OR BREAKP X AND NOT Y EQ '!!)) THEN <<Y := X; PRIN20X(X := CAR U); !*N := !*N+1; U := CDR U; IF !*N=N OR !*N>M AND NOT BREAKP CAR U AND NOSPACE(U,N-!*N) THEN <<TERPRI0X(); X := Y := NIL>> ELSE NIL>> ELSE U := CDR U END; SYMBOLIC PROCEDURE NOSPACE(U,N); IF N<1 THEN T ELSE IF NULL U THEN NIL ELSE IF NOT ATOM CAR U THEN NOSPACE(CDR U,N) ELSE IF NOT CAR U EQ '!! AND (CADR U EQ '! OR BREAKP CADR U) THEN NIL ELSE NOSPACE(CDR U,N-1); SYMBOLIC PROCEDURE BREAKP U; U MEMBER '(!< !> !; !: != !) !+ !- !, !' !"); SYMBOLIC PROCEDURE STRINGSPACE(U,N); IF N<1 THEN NIL ELSE IF CAR U EQ '!" THEN T ELSE STRINGSPACE(CDR U,N-1); COMMENT Some interfaces needed; PUT('CONS,'PRTCH,'(! !.! !.)); GLOBAL '(RPRIFN!* RTERFN!*); COMMENT RPRIFN!* allows output from RPRINT to be handled differently, RTERFN!* allows end of lines to be handled differently; SYMBOLIC PROCEDURE PRIN20X U; IF RPRIFN!* THEN APPLY(RPRIFN!*,LIST U) ELSE PRIN2 U; SYMBOLIC PROCEDURE TERPRI0X; IF RTERFN!* THEN APPLY(RTERFN!*,NIL) ELSE TERPRI(); END; |
Added psl-1983/3-1/util/set-macros.sl version [05d585cfef].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % SET-MACROS.SL - macros for various flavors of assignments % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>SET-MACROS.SL.2, 12-Oct-82 15:53:58, Edit by BENSON % Added IGETV to SETF-SAFE list % Somewhat expanded setf macro. Major difference between this and the builtin % version is that it always returns the RHS, instead of something % indeterminant. Note that the setf-safe flag can be used to indicate that % the assignment function itself returns the "right thing", so setf needn't % do anything special. Also a lot more functions are represented in this % version, including c....r (mostly useful for macros) and list/cons (which % gives a primitive sort of destructuring setf). (defmacro setf u (cond ((atom u) nil) ((atom (cdr u)) (stderror "Odd number of arguments to setf.")) ((atom (cddr u)) (setf2 (car u) (cadr u))) (t `(progn ,@(setf1 u))))) (de setf1 (u) (cond ((atom u) nil) ((atom (cdr u)) (stderror "Odd number of arguments to setf.")) (t (cons (setf2 (car u) (cadr u)) (setf1 (cddr u)))))) (de setf2 (lhs rhs) (if (atom lhs) `(setq ,lhs ,rhs) (cond ((and (idp (car lhs)) (flagp (car lhs) 'setf-safe)) (expand-setf lhs rhs)) ((atom rhs) `(progn ,(expand-setf lhs rhs) ,rhs)) (t `(let ((***SETF-VAR*** ,rhs)) ,(expand-setf lhs '***SETF-VAR***) ***SETF-VAR***))))) (de expand-setf (lhs rhs) (let ((fn (car lhs)) (op)) (cond ((and (idp fn) (setq op (get fn 'assign-op))) `(,op ,@(cdr lhs) ,rhs)) ((and (idp fn) (setq op (get fn 'setf-expand))) (apply op (list lhs rhs))) ((and (idp fn) (setq op (getd fn)) (eqcar op 'macro)) (expand-setf (apply (cdr op) (list lhs)) rhs)) (t (expand-setf (ContinuableError 99 (BldMsg "%r is not a known form for assignment" `(setf ,lhs ,rhs)) lhs) rhs))))) (flag '(getv indx eval value get list cons vector getd igetv) 'setf-safe) (defmacro-no-displace car-cdr-setf (rplacfn pathfn) `#'(lambda (lhs rhs) `(,',rplacfn (,',pathfn ,(cadr lhs)) ,rhs))) (deflist '( (car rplaca) (cdr rplacd) (getv putv) (igetv iputv) (indx setindx) (sub setsub) (eval set) (value set) (get put) (flagp flag-setf) (getd getd-setf) ) 'assign-op) (remprop 'nth 'assign-op) % Remove default version (which is incorrect anyway) (deflist `( (caar ,(car-cdr-setf rplaca car)) (cadr ,(car-cdr-setf rplaca cdr)) (caaar ,(car-cdr-setf rplaca caar)) (cadar ,(car-cdr-setf rplaca cdar)) (caadr ,(car-cdr-setf rplaca cadr)) (caddr ,(car-cdr-setf rplaca cddr)) (caaaar ,(car-cdr-setf rplaca caaar)) (cadaar ,(car-cdr-setf rplaca cdaar)) (caadar ,(car-cdr-setf rplaca cadar)) (caddar ,(car-cdr-setf rplaca cddar)) (caaadr ,(car-cdr-setf rplaca caadr)) (cadadr ,(car-cdr-setf rplaca cdadr)) (caaddr ,(car-cdr-setf rplaca caddr)) (cadddr ,(car-cdr-setf rplaca cdddr)) (cdar ,(car-cdr-setf rplacd car)) (cddr ,(car-cdr-setf rplacd cdr)) (cdaar ,(car-cdr-setf rplacd caar)) (cddar ,(car-cdr-setf rplacd cdar)) (cdadr ,(car-cdr-setf rplacd cadr)) (cdddr ,(car-cdr-setf rplacd cddr)) (cdaaar ,(car-cdr-setf rplacd caaar)) (cddaar ,(car-cdr-setf rplacd cdaar)) (cdadar ,(car-cdr-setf rplacd cadar)) (cdddar ,(car-cdr-setf rplacd cddar)) (cdaadr ,(car-cdr-setf rplacd caadr)) (cddadr ,(car-cdr-setf rplacd cdadr)) (cdaddr ,(car-cdr-setf rplacd caddr)) (cddddr ,(car-cdr-setf rplacd cdddr)) (nth ,#'(lambda (lhs rhs) `(rplaca (pnth ,@(cdr lhs)) ,rhs))) (pnth ,#'expand-pnth-setf) (lastcar ,#'(lambda (lhs rhs) `(rplaca (lastpair ,(cadr lhs)) ,rhs))) (list ,#'list-setf) (cons ,#'cons-setf) (vector ,#'vector-setf) ) 'setf-expand) (fluid '(*setf-debug)) (de expand-pnth-setf (lhs rhs) (let ((L (cadr lhs))(n (caddr lhs))) (cond ((onep n) `(setf ,L ,rhs)) ((fixp n) `(rplacd (pnth ,L (sub1 ,n)) ,rhs)) (t (let ((expnsn (errorset `(setf2 ',L ',rhs) *setf-debug *setf-debug))) (if (atom expnsn) `(rplacd (pnth ,L (sub1 ,n) ,rhs)) `(let ((***PNTH-SETF-VAR*** ,n)) (if (onep ***PNTH-SETF-VAR***) ,(car expnsn) (rplacd (pnth ,L (sub1 ***PNTH-SETF-VAR***)) ,rhs))))))))) (de flag-setf (nam flg val) (cond (val (flag (list nam) flg) t) (t (remflag (list nam) flg) nil))) (de getd-setf (trgt src) (cond % not correct for the parallel case... % ((idp src) (copyd trgt src)) ((or (codep src) (eqcar src 'lambda)) % is this kludge worthwhile? (progn (putd trgt 'expr src) (cons 'expr src))) ((pairp src) (progn (putd trgt (car src) (cdr src)) src)) (t (ContinuableError 99 (bldmsg "%r is not a funtion spec." src) src)))) (de list-setf (lhs rhs) (if (atom rhs) `(progn ,.(destructure-form (cdr lhs) rhs) ,rhs) `(let ((***LIST-SETF-VAR*** ,rhs)) ,.(destructure-form (cdr lhs) '***LIST-SETF-VAR***) ***LIST-SETF-VAR***))) (de cons-setf (lhs rhs) (if (atom rhs) `(progn (setf ,(cadr lhs) (car ,rhs)) (setf ,(caddr lhs) (cdr ,rhs)) ,rhs) `(let ((***CONS-SETF-VAR*** ,rhs)) (setf ,(cadr lhs) (car ***CONS-SETF-VAR***)) (setf ,(caddr lhs) (cdr ***CONS-SETF-VAR***)) ***CONS-SETF-VAR***))) (de vector-setf (lhs rhs) (let ((x (if (atom rhs) rhs '***VECTOR-SETF-VAR***))) (let ((L (for (in u (cdr lhs)) (from i 0) (collect `(setf ,u (getv ,x ,i)))))) (if (atom rhs) `(progn ,.L ,x) `(let ((***VECTOR-SETF-VAR*** ,rhs)) ,.L ,x))))) % Some more useful assignment macros (defmacro push (item stack) `(setf ,stack (cons ,item ,stack))) (defmacro pop (stack . rst) (let ((x `(prog1 (car ,stack) (setf ,stack (cdr ,stack))))) (if rst `(setf ,(car rst) ,x) x))) (defmacro adjoin-to (e s) `(setf ,s (adjoin ,e ,s))) (defmacro adjoinq-to (e s) `(setf ,s (adjoinq ,e ,s))) (defmacro incr (var . rst) `(setf ,var ,(if rst `(plus ,var ,@rst) `(add1 ,var)))) (defmacro decr (var . rst) `(setf ,var ,(if rst `(difference ,var (plus ,@rst)) `(sub1 ,var)))) (defmacro clear L `(setf ,.(foreach u in L conc `(,u nil)))) % Parallel assignment macros (defmacro psetq rst % psetq looks like a multi-arg setq but does its work in parallel. (cond ((null rst) nil) ((cddr rst) `(setq ,(car rst) (prog1 ,(cadr rst) (psetq . ,(cddr rst))))) % the last pair. keep it simple; no superfluous % (prog1 (setq...) (psetq)). ((cdr rst) `(setq . ,rst)) (t (StdError "psetq passed an odd number of arguments")))) (defmacro psetf rst % psetf looks like a multi-arg setf but does its work in parallel. (cond ((null rst) nil) ((cddr rst) `(setf ,(car rst) (prog1 ,(cadr rst) (psetf . ,(cddr rst))))) ((cdr rst) `(setf . ,rst)) (t (StdError "psetf passed an odd number of arguments")))) (defmacro defswitch (nam var . acts) (let ((read-act (if (pairp acts) (car acts) nil)) (set-acts (if (pairp acts) (cdr acts) nil))) (when (null var) (setf var (newid (bldmsg "%w-SWITCH-VAR*" nam)))) `(progn (fluid '(,var)) (de ,nam () (let ((,nam ,var)) ,read-act) ,var) (setf (get ',nam 'assign-op) #'(lambda (,nam) ,@set-acts (setq ,var ,nam))) (flag '(,nam) 'setf-safe)))) |
Added psl-1983/3-1/util/slow-strings.sl version [4505d0eae4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SLOW-STRINGS - Useful String Functions (with lots of error checking) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Defines the following functions: % % (string-fetch s i) % (string-store s i ch) % (string-length s) % (string-upper-bound s) % (string-empty? s) % % See FAST-STRINGS for faster (unchecked) compiled versions of these functions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de string-fetch (s i) (cond ((not (StringP s)) (NonStringError s 'String-Fetch)) ((not (FixP i)) (NonIntegerError i 'String-Fetch)) (t (indx s i)) )) (de string-store (s i c) (cond ((not (StringP s)) (NonStringError s 'String-Store)) ((not (FixP i)) (NonIntegerError i 'String-Store)) ((not (FixP c)) (NonCharacterError c 'String-Store)) (t (setindx s i c)) )) (de string-length (s) (cond ((not (StringP s)) (NonStringError s 'String-Length)) (t (Plus2 (size s) 1)) )) (de string-upper-bound (s) (cond ((not (StringP s)) (NonStringError s 'String-Upper-Bound)) (t (size s)) )) (de string-empty? (s) (cond ((not (StringP s)) (NonStringError s 'String-Empty?)) (t (EqN (size s) -1)) )) |
Added psl-1983/3-1/util/slow-vectors.sl version [0d5025f39e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SLOW-VECTORS - Useful Vector Functions (with lots of error checking) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Defines the following functions: % % (vector-fetch v i) % (vector-store v i x) % (vector-size v) % (vector-upper-bound v) % (vector-empty? v) % % See FAST-VECTORS for faster (unchecked) compiled versions of these functions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de vector-fetch (v i) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Fetch)) ((not (FixP i)) (NonIntegerError i 'Vector-Fetch)) (t (indx v i)) )) (de vector-store (v i x) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Store)) ((not (FixP i)) (NonIntegerError i 'Vector-Store)) (t (setindx v i x)) )) (de vector-size (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Size)) (t (Plus2 (size v) 1)) )) (de vector-upper-bound (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Upper-Bound)) (t (size v)) )) (de vector-empty? (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Empty?)) (t (EqN (size v) -1)) )) |
Added psl-1983/3-1/util/sm.build version [608fcdb372].
> | 1 | in "sm.red"$ |
Added psl-1983/3-1/util/sm.red version [0b8ca6fee7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % SM.RED - String match to replace find % M.L.G procedure sm(p,s); Sm1(p,0,size(p),s,0,size(s)); procedure sm1(p,p1,p2,s,s1,s2); Begin scalar c; L1: % test Range if p1>p2 then return (if s1>s2 then T else NIL) else if s1>s2 then return NIL; % test if % something if (c:=p[p1]) eq char !% then goto L3; L2: % exact match if c eq s[s1] then <<p1:=p1+1; s1:=s1+1; goto L1>>; return NIL; L3: % special cases p1:=p1+1; if p1>p2 then return stderror "pattern ran out in % case of sm"; c:=p[p1]; if c eq char !% then goto L2; if c eq char !? then <<p1:=p1+1; s1:=s1+1; goto L1>>; if c eq char !* then % 0 or more vs 1 or more return <<while not(c:=sm1(p,p1+1,p2,s,s1,s2)) and s1<=s2 do s1:=s1+1; c>>; Return Stderror Bldmsg(" %% %r not known in sm",int2id c); end; |
Added psl-1983/3-1/util/step.build version [d787d9c8db].
> > | 1 2 | CompileTime load(Useful, CLComp); in "step.lsp"$ |
Added psl-1983/3-1/util/step.lsp version [712f92701c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; STEP.LSP - Single-step evaluator ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 30 March 1982 ;;; Copyright (c) 1982 University of Utah ;;; #+Tops20 (eval-when (compile eval) ; Needed for PBIN in STEP-GET-CHAR (load monsym)) (imports '(evalhook)) ; Tell the loader that evalhook is needed (defvar step-level 0 "Level of recursion while stepping") (defvar step-form () "Current form being evaluated") (defvar step-pending-forms () "Buffer of forms being evaluated") (defvar abort-step () "Flag to indicate exiting step") (defvar step-dispatch (make-vector 127 t ()) "Dispatch table for character commands") (defvar step-channel () "I/O Channel used for printing truncated forms.") (eval-when (compile eval) ;;;; DEF-STEP-COMMAND - define a character command routine (defmacro def-step-command (char . form) `(vset step-dispatch ,char (function (lambda () ,@form)))) ) ;;;; STEP - user entry point (defun step (form) (let ((step-level 0) (step-pending-forms ()) (abort-step ())) (prog1 (step-eval form) (terpri)))) ;;;; STEP-EVAL - main routine (defun step-eval (step-form) (if abort-step (eval step-form) (let ((step-pending-forms (cons step-form step-pending-forms))) (step-print-form step-form "-> ") (let ((macro-call (macro-p (first step-form)))) (when macro-call (setq step-form (funcall macro-call step-form)) (step-print-form step-form "<->"))) (let ((step-value (let ((step-level (add1 step-level))) (step-command)))) (unless (and abort-step (not (eql abort-step step-level))) (setq abort-step ()) ;; Print the non macro-expanded form (step-print-value (first step-pending-forms) step-value)) step-value)))) ;;;; Control-N - Continue stepping each time (def-step-command #\ (evalhookfn step-form #'step-eval)) ;;;; Space - do not step lower levels (def-step-command #\blank (eval step-form)) ;;;; Control-U - go up to next higher evaluation level (def-step-command #\ (setq abort-step (- step-level 2)) (eval step-form)) ;;;; Control-X - abort stepping entirely (def-step-command #\ (setq abort-step -1) (eval step-form)) ;;;; Control-G - grind the current form (def-step-command #\bell (terpri) (prettyprint (first step-pending-forms)) (step-command)) ;;;; Control-P is the same as Control-G (vset step-dispatch #\ (vref step-dispatch #\bell)) ;;;; Control-R grinds the form in Rlisp syntax (def-step-command #\ (terpri) (rprint (first step-pending-forms)) ; This will only (step-command)) ; work in Rlisp ;;;; Control-E - edit the current form (def-step-command #\ (setq step-form (edit step-form)) (step-command)) ;;;; Control-B - go into a break loop (def-step-command #\ (step-break) (step-command)) ;;;; Control-L redisplay the last 10 pending forms (def-step-command #\ff (display-last-10) (step-command)) ;;;; ? - help (def-step-command #\? (load help) (displayhelpfile 'step) (step-command)) (defun display-last-10 () (display-aux step-pending-forms 10)) (defun display-aux (b n) (let ((step-level (sub1 step-level))) (unless (or (null b) (eql n 0)) (display-aux (rest b) (sub1 n)) (step-print-form (first b) "-> ")))) ;;;; STEP-COMMAND - read a character and dispatch on it (defun step-command () (let ((c (vref step-dispatch (step-get-char)))) (if c (funcall c) (ouch #\bell) (step-command)))) ;;;; STEP-PRINT-FORM - print incoming form with indentation (defun step-print-form (form herald) (terpri) (tab (min step-level 15)) (princ herald) (channelprin1 step-channel form)) ;;;; STEP-PRINT-VALUE - print form and result of evaluation (defun step-print-value (form value) (terpri) (tab (min step-level 15)) (princ "<- ") (channelprin1 step-channel form) (terpri) (tab (+ (min step-level 15) 3)) (prin1 value)) ;;;; STEP-BREAK - errset-protected break loop (defun step-break () (errset (break) ())) ;;;; STEP-GET-CHAR - read a single character #+Tops20 (lap '((*entry step-get-char expr 0) (*move #\? (reg 1)) (pbout) (pbin) (*exit 0))) #-Tops20 (defun step-get-char () (let ((promptstring* "?")) (do ((ch (channelreadchar stdin*) (channelreadchar stdin*))) ((not (eql ch #\eol)) ch)))) ;;;; STEP-PUT-CHAR - prints on current channel, truncates to one line (defun step-put-char (channel ch) (if (not (eql ch #\eol)) (unless (> (posn) 75) (writechar ch)))) (eval-when (load eval) ; Open a special channel (let ((specialwritefunction* #'step-put-char) (specialreadfunction* #'writeonlychannel) (specialclosefunction* #'illegalstandardchannelclose)) (setq step-channel (open "" 'special))) ) |
Added psl-1983/3-1/util/string-input.sl version [b5488c07e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Input from strings %%% Cris Perdue %%% 12/1/82 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load if fast-int)) (fluid '(channel-string channel-string-pos)) %%% Takes two arguments: a string and a function. %%% The function must take 1 argument. With-input-from-string %%% will call the function and pass it a channel number. If the %%% function takes input from the channel (which is the point of %%% all this), it will receive successive characters from the %%% string as its input. %%% %%% This is not currently unwind-protected. (defun with-input-from-string (str fn) (let ((specialreadfunction* 'string-readchar) (specialwritefunction* 'readonlychannel) (specialclosefunction* 'null) (channel-string str) (channel-string-pos 0)) (let ((chan (open "" 'special)) value) (setq value (apply fn (list chan))) (close chan) value))) %%% This is similar to with-input-from-string, but the string %%% passed in is effectively padded on the right with a single %%% blank. No storage allocation is performed to give this %%% effect. (defun with-input-from-terminated-string (str fn) (let ((specialreadfunction* 'string-readchar-terminated) (specialwritefunction* 'readonlychannel) (specialclosefunction* 'null) (channel-string str) (channel-string-pos 0)) (let ((chan (open "" 'special)) value) (setq value (apply fn (list chan))) (close chan) value))) %%% Reads from the string. The string is effectively padded with %%% a blank at the end so if the expression in the string is for %%% example a single token, it need not be followed by a terminator. (defun string-read (str) (with-input-from-terminated-string str 'channelread)) %%% Reads a single token from the string using channelreadtoken. %%% The string need contain no terminator character; a blank is %%% provided if necessary by string-readtoken. (defun string-readtoken (str) (with-input-from-terminated-string str 'channelreadtoken)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Internal routines. (defun string-readchar (chan) (if (> channel-string-pos (size channel-string)) then $eof$ else (prog1 (indx channel-string channel-string-pos) (setq channel-string-pos (+ channel-string-pos 1))))) %%% Includes hack that tacks on a blank for termination of READ %%% and friends. (defun string-readchar-terminated (chan) (if (<= channel-string-pos (size channel-string)) then (prog1 (indx channel-string channel-string-pos) (setq channel-string-pos (+ channel-string-pos 1))) elseif (= channel-string-pos (+ 1 (size channel-string))) then (prog1 32 % Blank (setq channel-string-pos (+ channel-string-pos 1))) else $eof$)) |
Added psl-1983/3-1/util/string-search.sl version [143a9308fc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% STRING-SEARCH %%% %%% Author: Cris Perdue %%% 11/23/82 %%% %%% General-purpose searches for substring. Case is important. %%% If the target is found, the index in the domain of the %%% leftmost character of the leftmost match is returned, %%% otherwise NIL. %%% %%% (STRING-SEARCH TARGET DOMAIN). %%% %%% If passed two strings, Common LISP "search" will give the %%% same results. %%% %%% (STRING-SEARCH-FROM TARGET DOMAIN START) %%% %%% Like string-search, but the search effectively starts at index %%% START in the domain. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Implementation note: In both of these, the value of the first %%% character of the target is precomputed and it is tested against %%% characters of the domain separately from the other characters of %%% the target. (compiletime (load fast-int if)) (defun string-search (target domain) (if (not (and (stringp target) (stringp domain))) then (error 0 "Arg to string-search not a string")) (let* ((s (isizes target)) (m (- (isizes domain) s))) (if (= s -1) then 0 else (let ((c (igets target 0))) (for (from i 0 m) (do (if (eq (igets domain i) c) then (if (for (from u 1 s) (from v (+ i 1)) (do (if (neq (igets target u) (igets domain v)) then (return nil))) (finally (return t))) then (return i))))))))) %%% Like string-search, but takes an explicit starting index %%% in the domain string. (defun string-search-from (target domain start) (if (not (and (stringp target) (stringp domain))) then (error 0 "Arg to substring-search not a string")) (let* ((s (isizes target)) (m (- (isizes domain) s))) (if (= s -1) then start else (let ((c (igets target 0))) (for (from i start m) (do (if (eq (igets domain i) c) then (if (for (from u 1 s) (from v (+ i 1)) (do (if (neq (igets target u) (igets domain v)) then (return nil))) (finally (return t))) then (return i))))))))) |
Added psl-1983/3-1/util/strings.build version [160fbec5df].
> > | 1 2 | CompileTime load(SysLisp, Useful, CLComp); in "strings.lsp"$ |
Added psl-1983/3-1/util/strings.lsp version [e9a20ea9cf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; STRINGS.LSP - Common Lisp string operations ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 7 April 1982 ;;; Copyright (c) 1982 University of Utah ;;; (eval-when (load) (imports '(chars))) ; Uses the CHARS module (eval-when (compile) ; Local functions (localf string-equal-aux string<-aux string<=-aux string<>-aux string-lessp-aux string-not-greaterp-aux string-not-equal-aux string-trim-left-index string-trim-right-index bag-element bag-element-aux string-concat-aux)) ;;;; CHAR - fetch a character in a string ;(defun char (s i) ; not defined because CHAR means something else in PSL ; (elt (stringify s) i)) ;;;; RPLACHAR - store a character in a string (defun rplachar (s i x) (setelt s i x)) ;;;; STRING= - compare two strings (substring options not implemented) (fset 'string= (fsymeval 'eqstr)) ; Same function in PSL ;;;; STRING-EQUAL - compare two strings, ignoring case, bits and font (defun string-equal (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (or (eq s1 s2) (let ((len1 (string-length s1)) (len2 (string-length s2))) (and (eql len1 len2) (string-equal-aux s1 s2 len1 0))))) (defun string-equal-aux (s1 s2 len i) (or (eql len i) (and (char-equal (char s1 i) (char s2 i)) (string-equal-aux s1 s2 len (add1 i))))) ;;;; STRING< - lexicographic comparison of strings (defun string< (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string<-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string<-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((eql i len2) ()) ((char= (char s1 i) (char s2 i)) (string<-aux s1 s2 len1 len2 (add1 i))) ((char< (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING> - lexicographic comparison of strings (defun string> (s1 s2) (string< s2 s1)) ;;;; STRING<= - lexicographic comparison of strings (defun string<= (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string<=-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string<=-aux (s1 s2 len1 len2 i) (cond ((eql i len1) i) ((eql i len2) ()) ((char= (char s1 i) (char s2 i)) (string<=-aux s1 s2 len1 len2 (add1 i))) ((char< (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING>= - lexicographic comparison of strings (defun string>= (s1 s2) (string<= s2 s1)) ;;;; STRING<> - lexicographic comparison of strings (defun string<> (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (let ((len1 (string-length s1)) (len2 (string-length s2))) (if (<= len1 len2) (string<>-aux s1 s2 len1 len2 0) (string<>-aux s2 s1 len2 len1 0)))) (defun string<>-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((char= (char s1 i) (char s2 i)) (string<>-aux s1 s2 len1 len2 (add1 i))) (t i))) ;;;; STRING-LESSP - lexicographic comparison of strings (defun string-lessp (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string-lessp-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string-lessp-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((eql i len2) ()) ((char-equal (char s1 i) (char s2 i)) (string-lessp-aux s1 s2 len1 len2 (add1 i))) ((char-lessp (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING-GREATERP - lexicographic comparison of strings (defun string-greaterp (s1 s2) (string-lessp s2 s1)) ;;;; STRING-NOT-GREATERP - lexicographic comparison of strings (defun string-not-greaterp (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string-not-greaterp-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string-not-greaterp-aux (s1 s2 len1 len2 i) (cond ((eql i len1) i) ((eql i len2) ()) ((char-equal (char s1 i) (char s2 i)) (string-not-greaterp-aux s1 s2 len1 len2 (add1 i))) ((char-lessp (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING-NOT-LESSP - lexicographic comparison of strings (defun string-not-lessp (s1 s2) (string-lessp= s2 s1)) ;;;; STRING-NOT-EQUAL - lexicographic comparison of strings (defun string-not-equal (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (let ((len1 (string-length s1)) (len2 (string-length s2))) (if (<= len1 len2) (string-not-equal-aux s1 s2 len1 len2 0) (string-not-equal-aux s2 s1 len2 len1 0)))) (defun string-not-equal-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((char-equal (char s1 i) (char s2 i)) (string-not-equal-aux s1 s2 len1 len2 (add1 i))) (t i))) ;;;; MAKE-STRING - construct a string (defun make-string (count fill-character) (mkstring (sub1 count) fill-character)) ;;;; STRING-REPEAT - concat together copies of a string (defun string-repeat (s i) (setq s (stringify s)) (cond ((eql i 0) "") ((eql i 1) (copystring s)) (t (let ((len (string-length s))) (let ((s1 (make-string (* i len) #\Space))) (do ((j 1 (+ j 1)) (i1 -1)) ((> j i)) (do ((k 0 (+ k 1))) ((eql k len)) (setq i1 (add1 i1)) (rplachar s1 i1 (char s k)))) s1))))) ;;;; STRING-TRIM - remove leading and trailing characters from a string (defun string-trim (c-bag s) (setq s (stringify s)) (let ((len (string-length s))) (let ((i1 (string-trim-left-index c-bag s 0 len)) (i2 (string-trim-right-index c-bag s len))) (if (<= i2 i1) "" (substring s i1 i2))))) (defun string-trim-left-index (c-bag s i uplim) (if (or (eql i uplim) (not (bag-element (char s i) c-bag))) i (string-trim-left-index c-bag s (add1 i) uplim))) (defun string-trim-right-index (c-bag s i) (if (or (eql i 0) (not (bag-element (char s (sub1 i)) c-bag))) i (string-trim-right-index c-bag s (sub1 i)))) (defun bag-element (elem c-bag) (cond ((consp c-bag) (memq elem c-bag)) ((stringp c-bag) (bag-element-aux elem c-bag 0 (string-length c-bag))) (t ()))) (defun bag-element-aux (elem c-bag i uplim) (and (< i uplim) (or (char= elem (char c-bag i)) (bag-element-aux elem c-bag (add1 i) uplim)))) ;;;; STRING-LEFT-TRIM - remove leading characters from string (defun string-left-trim (c-bag s) (setq s (stringify s)) (let ((len (string-length s))) (let ((i1 (string-trim-left-index c-bag s 0 len))) (if (<= len i1) "" (substring s i1 len))))) ;;;; STRING-RIGHT-TRIM - remove trailing characters from string (defun string-right-trim (c-bag s) (setq s (stringify s)) (let ((i2 (string-trim-right-index c-bag s (string-length s)))) (if (<= i2 0) "" (substring s 0 i2)))) ;;;; STRING-UPCASE - copy and raise all alphabetic characters in string (defun string-upcase (s) (setq s (stringify s)) (nstring-upcase (copystring s))) ;;;; NSTRING-UPCASE - destructively raise all alphabetic characters in string (defun nstring-upcase (s) (let ((len (string-length s))) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (when (lowercasep c) (rplachar s i (char-upcase c))))) s)) ;;;; STRING-DOWNCASE - copy and lower all alphabetic characters in string (defun string-downcase (s) (setq s (stringify s)) (nstring-downcase (copystring s))) ;;;; NSTRING-DOWNCASE - destructively raise all alphabetic characters in string (defun nstring-downcase (s) (let ((len (string-length s))) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (when (uppercasep c) (rplachar s i (char-downcase c))))) s)) ;;;; STRING-CAPITALIZE - copy and raise first letter of all words in string (defun string-capitalize (s) (setq s (stringify s)) (nstring-capitalize (copystring s))) ;;;; NSTRING-CAPITALIZE - destructively raise first letter of all words (defun nstring-capitalize (s) (let ((len (string-length s)) (in-word-flag ())) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (cond ((uppercasep c) (if in-word-flag (rplachar s i (char-downcase c)) (setq in-word-flag t))) ((lowercasep c) (when (not in-word-flag) (rplachar s i (char-upcase c)) (setq in-word-flag t))) (t (setq in-word-flag ()))))) s)) ;;;; STRING - coercion to a string, named STRINGIFY in PSL (defun stringify (x) (cond ((stringp x) x) ((symbolp x) (get-pname x)) (t (stderror (bldmsg "%r cannot be coerced to a string" x))))) ;;;; STRING-TO-LIST - unpack string characters into a list (defun string-to-list (s) (string2list s)) ; PSL function ;;;; STRING-TO-VECTOR - unpack string characters into a vector (defun string-to-vector (s) (string2vector s)) ; PSL function ;;;; SUBSTRING - subsequence restricted to strings (defun substring (string start end) (subseq (stringify string) start end)) ;;;; STRING-LENGTH - last index of a string, plus one (defun string-length (s) (add1 (size s))) ;;;; STRING-CONCAT - concatenate strings (defmacro string-concat args (let ((len (length args))) (cond ((eql len 0) "") ((eql len 1) `(copystring (stringify ,(first args)))) (t (string-concat-aux args len))))) (defun string-concat-aux (args len) (if (eql len 2) `(concat (stringify ,(first args)) (stringify ,(second args))) `(concat (stringify ,(first args)) ,(string-concat-aux (rest args) (sub1 len))))) |
Added psl-1983/3-1/util/stringx.sl version [763cf966b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % STRINGX - Useful String Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 9 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings common)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (CompileTime (progn (put 'make-string 'cmacro % temporary bug fix '(lambda (sz init) (mkstring (- sz 1) init))) )) % End of CompileTime %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de string-rest (s i) (substring s i (string-length s))) (de string-pad-right (s desired-length) % Pad the specified string with spaces on the right side to the specified % length. Returns a new string. (let ((len (string-length s))) (if (< len desired-length) (string-concat s (make-string (- desired-length len) #\space)) s))) (de string-pad-left (s desired-length) % Pad the specified string with spaces on the left side to the specified % length. Returns a new string. (let ((len (string-length s))) (if (< len desired-length) (string-concat (make-string (- desired-length len) #\space) s) s))) (de string-largest-common-prefix (s1 s2) % Return the string that is the largest common prefix of S1 and S2. (for (from i 0 (min (string-upper-bound s1) (string-upper-bound s2)) 1) (while (= (string-fetch s1 i) (string-fetch s2 i))) (returns (substring s1 0 i)) )) (de strings-largest-common-prefix (l) % Return the string that is the largest common prefix of the elements % of L, which must be a list of strings. (cond ((null l) "") ((null (cdr l)) (car l)) (t (let* ((prefix (car l)) (limit (string-length prefix)) ) % Prefix[0..LIMIT-1] is the string that is a prefix of all % strings so far examined. (for (in s (cdr l)) (with i) (do (let ((n (string-length s))) (if (< n limit) (setf limit n)) ) (setf i 0) (while (< i limit) (if (~= (string-fetch prefix i) (string-fetch s i)) (setf limit i) (setf i (+ i 1)) )) )) (substring prefix 0 limit) )))) |
Added psl-1983/3-1/util/struct.initial version [a012f0708a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;-*-lisp-*- (defmacro defstruct ((name . opts) . slots) (let ((dp (cadr (assq 'default-pointer opts))) (conc-name (cadr (assq 'conc-name opts))) (cons-name (implode (append '(m a k e -) (explodec name))))) ; #Q (fset-carefully cons-name '(macro . initial_defstruct-cons)) ; #M (putprop cons-name 'initial_defstruct-cons 'macro) ; PSL change (putd cons-name 'macro (cdr (getd 'initial_defstruct-cons))) ; PSL change 1+ ==> add1 (do ((i 0 (add1 i)) (l slots (cdr l)) (foo nil (cons (list slot init) foo)) (chars (explodec conc-name)) (slot) (acsor) (init)) ((null l) (putprop cons-name foo 'initial_defstruct-inits) `',name) (cond ((atom (car l)) (setq slot (car l)) (setq init nil)) (t (setq slot (caar l)) (setq init (cadar l)))) (setq acsor (implode (append chars (explodec slot)))) (putprop acsor dp 'initial_defstruct-dp) ; #Q (fset-carefully acsor '(macro . initial_defstruct-ref)) ; #M (putprop acsor 'initial_defstruct-ref 'macro) ; PSL change (putd acsor 'macro (cdr (getd 'initial_defstruct-ref))) (putprop acsor i 'initial_defstruct-i)))) (defun initial_defstruct-ref (form) (let ((i (get (car form) 'initial_defstruct-i)) (p (if (null (cdr form)) (get (car form) 'initial_defstruct-dp) (cadr form)))) ; PSL change incompatible NTH #-Multics `(nth ,p ,(add1 i)) ; #-Multics `(nth ,i ,p) #+Multics `(car ,(do ((i i (1- i)) (x p `(cdr ,x))) ((zerop i) x))) )) (defun initial_defstruct-cons (form) (do ((inits (get (car form) 'initial_defstruct-inits) (cdr inits)) (gen (gensym)) (x nil (cons (or (get form (caar inits)) (cadar inits)) x))) ((null inits) `(list . ,x)))) |
Added psl-1983/3-1/util/sysbuild.mic version [4962874d84].
> > > > > > > | 1 2 3 4 5 6 7 | @def pl: dsk:,plap: @PSL:RLISP *LOAD BUILD; *BUILD '''A; *QUIT; @def pl: plap: @reset . |
Added psl-1983/3-1/util/tel-ann-driver.red version [b00b28347a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) % Physical Size is D.X=~8inch, D.Y=~6inch % Want square asp[ect ratio for 100*100 Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; 12 - FIX(Y); Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xhere,Yhere, X1, Y1,function TEL!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure TEL!.dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Bottom . . Top) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.DDA(X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL end; Procedure ANN!.MoveS(X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure ANN!.DrawS(X1,Y1); << ANN!.DDA(Xhere,Yhere, X1, Y1,function ANN!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(ANN!.DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); If not !*emode then echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Print "Device Now ANN60"; end; |
Added psl-1983/3-1/util/test-arith.red version [2905b61015].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 January 1982 % Copyright (c) 1982 University of Utah % on SysLisp; syslsp procedure IsInum U; SignedField(U, InfStartingBit - 1, InfBitLength + 1) eq U; CompileTime << internal WConst IntFunctionEntry = 0, BigFunctionEntry = 1, FloatFunctionEntry = 2, FunctionNameEntry = 3; >>; syslsp procedure TwoArgDispatch(FirstArg, SecondArg); TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg); lap '((!*entry TwoArgDispatch1 expr 4) (!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 3)) NotNeg1 (!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 4)) NotNeg2 (!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN)) (!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN)) (!*WSHIFT (reg 3) (WConst 2)) (!*WPLUS2 (reg 4) (reg 3)) (!*POP (reg 3)) (!*JUMPON (reg 4) 0 15 ((Label IntInt) (Label IntFix) (Label IntBig) (Label IntFloat) (Label FixInt) (Label FixFix) (Label FixBig) (Label FixFloat) (Label BigInt) (Label BigFix) (Label BigBig) (Label BigFloat) (Label FloatInt) (Label FloatFix) (Label FloatBig) (Label FloatFloat))) (!*JCALL TwoArgError) FixBig (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntBig (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntBig) (!*POP (reg 2)) (!*POP (reg 3)) BigBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) BigFix (!*FIELD (reg 2) (reg 2) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) BigInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntBig) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FixInt (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) FixFix (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) IntInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) FixFloat (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) FloatInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) BigFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticBigFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatBig (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticBigFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) NonNumeric (!*POP (reg 3)) (!*JCALL TwoArgError) ); syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger1Error(Arg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], Arg)); syslsp procedure OneArgDispatch FirstArg; OneArgDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label OneBig) (Label OneFloat))) (!*JCALL OneArgError) OneBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) OneFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) ); syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg)); syslsp procedure OneArgPredicateDispatch FirstArg; OneArgPredicateDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgPredicateDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label OneBig) (Label OneFloat))) (!*MOVE (QUOTE NIL) (reg 1)) (!*EXIT 0) OneBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) OneFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) ); syslsp procedure MakeFixnum N; begin scalar F; F := GtFIXN(); FixVal F := N; return MkFIXN F; end; syslsp procedure BigFloatFix N; StdError List('"Bignums not yet supported [BigFloatFix]",N); syslsp procedure ReturnNIL(); NIL; syslsp procedure ReturnFirstArg Arg; Arg; %internal WArray StaticFloatBuffer = [1, 0, 0]; % %internal WConst StaticFloatItem = MkItem(FLTN, StaticFloatBuffer); % syslsp procedure StaticIntFloat Arg; %<< !*WFloat(&StaticFloatBuffer[1], Arg); % StaticFloatItem >>; FloatIntArg Arg; syslsp procedure StaticIntBig Arg; StdError LIST('"Bignums not yet supported [StaticIntBig]",Arg); syslsp procedure StaticBigFloat Arg; StdError LIST('"Bignums not yet supported [StaticBigFloat]",Arg); off SysLisp; CompileTime << macro procedure DefArith2Entry U; DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U); macro procedure DefArith1Entry U; DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U); macro procedure DefArith1PredicateEntry U; DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U); lisp procedure StupidParserFix X; % Goddamn Rlisp parser won't let me just give "Difference" as the parameter % to a macro if null X then X else RemQuote car X . StupidParserFix cdr X; lisp procedure RemQuote X; if EqCar(X, 'QUOTE) then cadr X else X; lisp procedure DefArithEntry L; SublA(Pair('(NumberOfArguments DispatchRoutine NameOfFunction IntFunction BigFunction FloatFunction), L), quote(lap '((!*entry NameOfFunction expr NumberOfArguments) (!*Call DispatchRoutine) % 30 is ID, won't do for 68000 (fullword (MkItem 30 (IDLoc IntFunction))) (fullword (MkItem 30 (IDLoc BigFunction))) (fullword (MkItem 30 (IDLoc FloatFunction))) (fullword (MkItem 30 (IDLoc NameOfFunction)))))); >>; DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2); syslsp procedure IntPlus2(FirstArg, SecondArg); if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatPlus2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FPlus2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference); syslsp procedure IntDifference(FirstArg, SecondArg); if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatDifference(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2); % What about overflow? syslsp procedure IntTimes2(FirstArg, SecondArg); begin scalar Result; Result := WTimes2(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatTimes2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FTimes2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Divide, IntDivide, BigDivide, FloatDivide); DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient); syslsp procedure IntDivide(FirstArg, SecondArg); IntQuotient(FirstArg, SecondArg) . IntRemainder(FirstArg, SecondArg); syslsp procedure FloatDivide(FirstArg, SecondArg); FloatQuotient(FirstArg, SecondArg) . FloatRemainder(FirstArg, SecondArg); syslsp procedure IntQuotient(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); Result := WQuotient(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatQuotient(FirstArg, SecondArg); begin scalar F; if FloatZeroP SecondArg then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); F := GtFLTN(); !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder); syslsp procedure IntRemainder(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Remainder", Remainder(FirstArg, SecondArg)); Result := WRemainder(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatRemainder(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FRemainder(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error); syslsp procedure IntLAnd(FirstArg, SecondArg); if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error); syslsp procedure IntLOr(FirstArg, SecondArg); if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error); syslsp procedure IntLXOr(FirstArg, SecondArg); if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error); PutD('LSH, 'EXPR, cdr GetD 'LShift); procedure IntLShift(FirstArg, SecondArg); BigLShift(Int2B FirstArg, Int2B SecondArg); DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP); syslsp procedure IntGreaterP(FirstArg, SecondArg); WGreaterP(FirstArg, SecondArg); syslsp procedure FloatGreaterP(FirstArg, SecondArg); !*FGreaterP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP); syslsp procedure IntLessP(FirstArg, SecondArg); WLessP(FirstArg, SecondArg); syslsp procedure FloatLessP(FirstArg, SecondArg); !*FLessP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1); syslsp procedure IntAdd1 FirstArg; if IsInum(FirstArg := WPlus2(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatAdd1 FirstArg; FloatPlus2(FirstArg, 1.0); DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1); lisp procedure IntSub1 FirstArg; if IsInum(FirstArg := WDifference(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatSub1 FirstArg; FloatDifference(FirstArg, 1.0); DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error); lisp procedure IntLNot X; if IsInum(X := WNot X) then X else MakeFixnum X; DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus); lisp procedure IntMinus FirstArg; if IsInum(FirstArg := WMinus FirstArg) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatMinus FirstArg; FloatDifference(0.0, FirstArg); DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix); syslsp procedure FloatFix Arg; begin scalar R; return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R else MakeFixnum R; end; DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg); syslsp procedure FloatIntArg Arg; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, Arg); return MkFLTN F; end; DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP); syslsp procedure IntMinusP FirstArg; WLessP(FirstArg, 0); lisp procedure FloatMinusP FirstArg; FloatLessP(FirstArg, 0.0); DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP); lisp procedure IntZeroP FirstArg; FirstArg = 0; lisp procedure FloatZeroP FirstArg; EQN(FirstArg, 0.0); DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP); lisp procedure IntOneP FirstArg; FirstArg = 1; lisp procedure FloatOneP FirstArg; EQN(FirstArg, 1.0); END; |
Added psl-1983/3-1/util/time-fnc.sl version [5d20e26e01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Time-fnc.sl : code to time function calls. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Written by Douglas Lanam. (November 1982). ;; ;; To be compiled inside `pfrl' using the command: ;; (compile-file time-fnc). ;; ;; The object created is usuable in any psl on machine it is compiled for. ;; ;; Usage: ;; ;; do ;; (timef function-name-1 function-name-2 ...) ;; ;; Timef is a fexpr. ;; It will redefine the functions named so that timing information is ;; kept on these functions. ;; This information is kept on the property list of the function name. ;; The properties used are `time' and `number-of-calls'. ;; ;; (get function-name 'time) gives you the total time in the function. ;; (not counting gc time). ;; Note, this is the time from entrance to exit. ;; The timef function redefines the function with an ;; unwind-protect, so calls that are interrupted ;; by *throws are counted. ;; ;; (get function-name 'number-of-calls) gives you the number of times ;; the function is called. ;; ;; To stop timing do : ;; (untimef function-name1 ..) ;; or do (untimef) for all functions. ;; (untimef) is a fexpr. ;; ;; To print timing information do ;; (print-time-info function-name-1 function-name-2 ..) ;; ;; or do (print-time-info) for timing information on all function names. ;; ;; special variables used: ;; *timed-functions* : list of all functions currently being timed. ;; *all-timed-functions* : list of all functions ever timed in the ;; current session. ;; ;; Comment: if tr is called on a called on a function that is already ;; being timed, and then untimef is called on the function, the ;; function will no longer be traced. ;; (defvar *timed-functions* nil) (defvar *all-timed-functions* nil) (defun timef fexpr (names) (cond ((null names) *timed-functions*) ((f-mapc '(lambda (x) (or (memq x *timed-functions*) (let ((a (getd x))) (cond (a (put x 'orig-function-def a) (setq *timed-functions* (cons x *timed-functions*)) (or (memq x *all-timed-functions*) (setq *all-timed-functions* (cons x *all-timed-functions*))) (set-up-time-function (car a) x (cdr a))) (t (princ x) (princ " is not a defined function.") (terpri)))))) names)))) (defun set-up-time-function (type x old-func) (let ((y (cond ((codep old-func) (code-number-of-arguments old-func)) (t (length (cadr old-func))))) (args) (function) (result-var (gensym)) (gc-time-var (gensym)) (time-var (gensym))) (do ((i y (difference i 1))) ((= i 0)) (setq args (cons (gensym) args))) (putd x type `(lambda ,args (time-function ',x ',old-func (list (time) . ,args)))) x)) (defvar |* timing time *| 0) #+dec20 (defvar *call-overhead-time* 0.147) #+vax (defvar *call-overhead-time* 0.1) #+dec20 (defvar *time-overhead-time* 0.437) #+vax (defvar *time-overhead-time* 1.3) (defvar |* number of sub time calls *| 0) (defun time-function (name function-pointer arguments) (let ((itime-var (car arguments)) (result) (n) (endt) (total-fnc-time) (time-var) (gc-time-var)) (unwind-protect (let ((|* timing time *| 0) (|* number of sub time calls *| 0)) (unwind-protect (let () (setq gc-time-var gctime* time-var (time) result (apply function-pointer (cdr arguments)) endt (time)) result) (cond (time-var (or endt (setq endt (time))) (Setq n |* number of sub time calls *|) (put name 'number-of-sub-time-calls (+ n (or (get name 'number-of-sub-time-calls) 0))) (setq total-fnc-time (- (- endt time-var) |* timing time *|)) (put name 'time (+ (or (get name 'time) 0) (- total-fnc-time (- gctime* gc-time-var)))) (put name 'number-of-calls (1+ (or (get name 'number-of-calls) 0))))))) (prog () (setq |* timing time *| (- (- |* timing time *| itime-var) total-fnc-time))) (setq |* number of sub time calls *| (1+ |* number of sub time calls *|)) (setq |* timing time *| (+ |* timing time *| (time))))))) (defun untimef fexpr (names) (f-mapc '(lambda (x) (cond ((memq x *timed-functions*) (let ((a (get x 'orig-function-def))) (cond (a (putd x (car a) (cdr a))))) (setq *timed-functions* (delq x *timed-functions*))))) (or names *timed-functions*))) (defun print-time-info fexpr (names) (f-mapc '(lambda (x) (let ((n (get x 'number-of-calls)) (ns (get x 'number-of-sub-time-calls)) (time) (t1 (get x 'time))) (princ x) (princ " ") (tab 20) (princ (or n 0)) (princ " calls") (cond (n (setq time (max 0 (difference (difference (or t1 0) (times *call-overhead-time* (or n 0))) (times *time-overhead-time* (or ns 0))))) (tab 31) (princ time) (princ " ms") (tab 48) (princ (quotient (float time) (float n))) (princ " ms\/call"))) (terpri))) (or names *all-timed-functions*)) (terpri)) |
Added psl-1983/3-1/util/useful.build version [fbb85a415c].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | CompileTime load Useful; in "backquote.sl"$ in "read-macros.sl"$ in "destructure.sl"$ in "cond-macros.sl"$ in "bind-macros.sl"$ in "set-macros.sl"$ in "iter-macros.sl"$ in "for-macro.sl"$ in "misc-macros.sl"$ in "macroexpand.sl"$ |
Added psl-1983/3-1/util/useful.ctl version [a22a625429].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @cd pu: @psl:rlisp load build,useful; off redefmsg,usermode; in "backquote.sl"$ in "read-macros.sl"$ in "destructure.sl"$ in "cond-macros.sl"$ in "bind-macros.sl"$ in "set-macros.sl"$ in "iter-macros.sl"$ remflag('(for),'lose); in "for-macro.sl"$ in "misc-macros.sl"$ in "macroexpand.sl"$ build 'useful; quit; @tags pu:useful.tags pu:backquote.sl pu:read-macros.sl pu:destructure.sl pu:cond-macros.sl pu:bind-macros.sl pu:set-macros.sl pu:iter-macros.sl pu:for-macro.sl pu:misc-macros.sl pu:macroexpand.sl * |
Added psl-1983/3-1/util/util.sl version [01886823db].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % UTIL.SL - General Utility/Support functions % % Author: Nancy Kendzierski % Hewlett-Packard/CRC % Date: 23 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common strings objects)) (fluid '(nmode-terminal)) (defun integer$parse (str) % Return an integer corresponding to the string -- not the characters % in the string, but the number in the string. (prog (i negative error ch num) (setf i 0) (setf num 0) (if (<= (string-length str) 0) (return NIL)) (setf ch (indx str 0)) (cond ((= ch (char -)) (let () (setf negative t) (setf i (add1 i)))) ((= ch (char +)) (setf i (add1 i)))) (if (>= i (string-length str)) (return NIL)) (for (from i i (size str)) (do (setq ch (indx str i)) (cond ((or (< ch (char 0)) (> ch (char 9))) (exit (setq error t))) (t (setq num (+ (* num 10) (- ch (char 0)))))))) (cond (error (return NIL)) (negative (return (setq num (minus num)))) (t (return num))))) (defun integer$unparse (num) % Return an ASCII string version of the integer. (let ((str "") (negative nil) temp) (cond ((< num 0) (setf negative t) (setf num (minus num)))) (while (> num 0) (setq temp (divide num 10)) (setq num (car temp)) (setq str (string-concat (string (+ (cdr temp) (char 0))) str))) (cond ((equal str "") "0") (negative (string-concat "-" str)) (t str)) )) (defun integer-base$parse (base str) % Return an integer corresponding to the string -- not the characters % in the string, but the number in the string. (prog (i negative error ch num max-digit) (setf max-digit (+ #\0 (- base 1))) (setf i 0) (setf num 0) (if (<= (string-length str) 0) (return NIL)) (setf ch (indx str 0)) (cond ((= ch (char -)) (let () (setf negative t) (setf i (add1 i)))) ((= ch (char +)) (setf i (add1 i)))) (if (>= i (string-length str)) (return NIL)) (for (from i i (size str)) (do (setq ch (indx str i)) (cond ((or (< ch (char 0)) (> ch max-digit)) (exit (setq error t))) (t (setq num (+ (* num base) (- ch (char 0)))))))) (cond (error (return NIL)) (negative (return (setq num (minus num)))) (t (return num))))) (defun integer-base$unparse (base num) % Return an ASCII string version of the integer. (let ((str "") (negative nil) temp) (cond ((< num 0) (setf negative t) (setf num (minus num)))) (while (> num 0) (setq temp (divide num base)) (setq num (car temp)) (setq str (string-concat (string (+ (cdr temp) (char 0))) str))) (cond ((equal str "") "0") (negative (string-concat "-" str)) (t str)) )) (defun LoadSoftKey (key mode command label) % Load a soft key on an HP264X terminal % key: 0 <= key <= 8 % mode: 'N 'L or 'T % command: string (maximum 80 characters) % label: string (maximum 80 characters) (prog (cmd command-size label-size restore-echo?) (setq cmd (string 27 38)) % Escape-& is soft-key command prefix start. % Set up proper mode. (cond ((= mode 'N) (setq cmd (concat cmd "f0a"))) ((= mode 'L) (setq cmd (concat cmd "f1a"))) ((= mode 'T) (setq cmd (concat cmd "f2a"))) (t (return "Illegal mode") )) % Set up soft-key number. (if (or (< key 0) (> key 8)) (return "Illegal soft-key number")) (setq cmd (string-concat cmd (integer$unparse key) "k")) % Set up label length, command length, and command. (setq label-size (+ 1 (size label))) (if (> label-size 80) (return "Label too long")) (setq command-size (+ 1 (size command))) (if (> command-size 80) (return "Command too long")) (setq cmd (string-concat cmd (integer$unparse label-size) "d" (integer$unparse command-size) "L" label command)) % Turn echoing off, if necessary. (cond ((not (=> nmode-terminal raw-mode)) (=> nmode-terminal enter-raw-mode) (setq restore-echo? t))) % Output the string of command characters. (for (from i 0 (size cmd)) (do (pbout (indx cmd i)))) (if restore-echo? (=> nmode-terminal leave-raw-mode)) )) |
Added psl-1983/3-1/util/vector-fix.build version [922e47a4a3].
> > | 1 2 | CompileTime load Syslisp; in "vector-fix.red"$ |
Added psl-1983/3-1/util/vector-fix.red version [2aea2cd204].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>VECTOR-FIX.RED.5, 18-Mar-82 13:50:06, Edit by BENSON % Removed patches that were installed in V3 interp % <PSL.UTIL>VECTOR-FIX.RED.4, 20-Jan-82 12:15:26, Edit by GRISS % Patch to allow 0 element vectors % on Syslisp; syslsp procedure MkWords N; %. Allocate vector, init all to #0 if IntP N then << if N < (-1) then StdError '"A WORD vector with fewer than zero elements cannot be allocated" else begin scalar W; W := GtWRDS N; for I := 0 step 1 until N do WrdItm(W, I) := 0; return MkWRDS W; % Tag it end >> else NonIntegerError(N, 'MkWords); % A special facility to truncate X-vects in place % extract peices syslsp procedure TruncateVector(V,I); If Not VectorP V then NonVectorError(V,'TruncateVector) else if not IntP I then NonIntegerError(I,'TruncateVector) else begin scalar Len,Len2,VI; VI:=VecInf V; Len:=VecLen VI; If Len=I then return V; % Already the size If Len<I then return StdError "Cannot Lengthen a Vector in TruncateVector"; If Len<(-1) then return StdError "Cant TruncateVector to less then -1"; @VI := MkItem(HVECT,I); VecItm(VI, I+1) := MkItem(HVECT, Len-I-2); return V end; % Missing Words Operations syslsp procedure WordsP W; tag(w) eq Wrds; syslsp procedure TruncateWords(V,I); If Not WordsP V then NonWordsError(V,'TruncateWords) else if not IntP I then NonIntegerError(I,'TruncateWords) else begin scalar Len,Len2,VI; VI:=WRDInf V; Len:=WRDLen VI; If Len=I then return V; % Already the size If Len<I then return StdError "Cannot Lengthen a Words in TruncateWords"; If Len<(-1) then return StdError "Cant TruncateWords to less then -1"; @VI := MkItem(HWRDS,I); WrdItm(VI, I+1) := MkItem(HWRDS, Len-I-2); return V end; syslsp procedure GetWords(WRD, I); %. Retrieve the I'th entry of WRD begin scalar StripV, StripI; return if WordsP WRD then if IntP I then % can't have Wordss bigger than INUM << StripV := WRDInf WRD; StripI := IntInf I; if StripI >= 0 and StripI <= WRDLen StripV then WRDItm(StripV, StripI) else StdError BldMsg('"Subscript %r in GetWords is out of range", I) >> else IndexError(I, 'GetWords) else NonWordsError(WRD, 'GetWords); end; syslsp procedure PutWords(WRD, I, Val); %. Store Val at I'th position of WRD begin scalar StripV, StripI; return if WordsP WRD then if IntP I then % can't have Wordss bigger than INUM << StripV := WRDInf WRD; StripI := IntInf I; if StripI >= 0 and StripI <= WRDLen StripV then WRDItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in PutWords is out of range", I) >> else IndexError(I, 'PutWords) else NonWordsError(WRD, 'PutWords); end; syslsp procedure UpbW V; %. Upper limit of Words V if WordsP V then MkINT WRDLen WRDInf V else NIL; off Syslisp; END; |
Added psl-1983/3-1/util/zbasic.build version [b1e95bf621].
> > | 1 2 | CompileTime load ZBoot; in "zbasic.lsp"$ |
Added psl-1983/3-1/util/zbasic.lsp version [9dd663d2dc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZBASIC contains 6 packages -- (1) YLSTS -- useful functions for lists. (2) YNUMS -- useful functions for numbers. (3) YSTRS -- useful functions for strings. (4) YIO -- useful functions for user io. (5) YCNTRL -- useful functions for program control. (6) YRARE -- functions we use now, but may eliminate. ") (!* " YLSTS -- BASIC LIST UTILITIES CCAR ( X:any ):any CCDR ( X:any ):any LAST ( X:list ):any NTH-CDR ( L:list N:number ):list NTH-ELT ( L:list N:number ):elt of list NTH-TAIL( L:list N:number ):list TAIL-P ( X:list Y:list ):extra-boolean NCONS ( X:any ): (CONS X NIL) KWOTE ( X:any ): '<eval of #X> MKQUOTE ( X:any ): '<eval of #X> RPLACW ( X:list Y:list ):list DREMOVE ( X:any L:list ):list REMOVE ( X:any L:list ):list DSUBST ( X:any Y:any Z:list ):list LSUBST ( NEW:list OLD:list X:any ):list COPY ( X:list ):list TCONC ( P:list X:any ): tconc-ptr LCONC ( P:list X:list ):list CVSET ( X:list ):set ENTER ( ELT:element SET:list ):set ABSTRACT( FN:function L:list ):list EACH ( L:list FN:function ):extra-boolean SOME ( L:list FN:function ):extra-boolean INTERSECTION ( SET1:list SET2:list ):extra-boolean SETDIFFERENCE ( SET1:list SET2:list ):extra-boolean SUBSET ( SET1:any SET2:list ):extra boolean UNION ( X:list Y:list ):list SEQUAL ( X:list Y:list ):extra boolean MAP2C ( X:list Y:list FN:function ):NIL MAP2 ( X:list Y:list FN:function ):NIL ATSOC ( ALST:list, KEY:atom ):any ") (FLUID '(!#SET2)) (!* "CCAR( X:any ):any ---- Careful Car. Returns car of x if x is a list, else NIL.") (CDE CCAR (!#X) (COND ((PAIRP !#X) (CAR !#X)))) (!* "CCDR( X:any ):any ---- Careful Cdr. Returns cdr of x if x is a list, else NIL.") (CDE CCDR (!#X) (COND ((PAIRP !#X) (CDR !#X)))) (!* "LAST( X:list ):any ---- Returns the last cell in X. E.g. (LAST '(A B C)) = (C), (LAST '(A B . C)) = C.") (!* (CDE LAST (!#X) (COND ((ATOM !#X) !#X) ((NULL (CDR !#X)) !#X) (T (LAST (CDR !#X))))) ) (CDM LAST (!#X) (CONS 'LASTPAIR (CDR !#X))) (!* "NTH-CDR( L:list N:number ):list ------- Returns the nth cdr of list--0 is the list, 1 the cdr ...") (CDE NTH!-CDR (!#L !#N) (COND ((LESSP !#N 1) !#L) ((ATOM !#L) NIL) (T (NTH!-CDR (CDR !#L) (SUB1 !#N))))) (!* "NTH-TAIL( L:list N:number ):list ------- Returns the nth tail of list--1 is the list, 2 the cdr ...") (CDE NTH!-TAIL (!#L !#N) (COND ((LESSP !#N 2) !#L) ((ATOM !#L) NIL) (T (NTH!-TAIL (CDR !#L) (SUB1 !#N))))) (!* "NTH-ELT( L:list N:number ):list ------- Returns the nth elt of list--1 is the car, 2 the cadr ...") (CDE NTH!-ELT (!#L !#N) (CAR (NTH!-TAIL !#L !#N))) (!* "TAIL-P( X:list Y:list ):extra-boolean ------ If X is a non-nil tail of Y (X eq cdr Y or cddr Y or...), return X. Renamed to avoid a conflict with TAILP in compiler") (CDE TAIL!-P (!#X !#Y) (COND (!#X (PROG NIL LP (COND ((ATOM !#Y) (RETURN NIL)) ((EQ !#X !#Y) (RETURN !#X))) (SETQ !#Y (CDR !#Y)) (GO LP))))) (!* " NCONS( X:any ): (CONS X NIL) ----- Returns (CONS X NIL) ") (!* (CDE NCONS (!#X) (CONS !#X NIL)) ) (!* " KWOTE( X:any ): '<eval of #X> MKQUOTE( X:any ): '<eval of #X> ------- Returns the quoted value of its argument. ") (CDM KWOTE (!#X) (CONS 'MKQUOTE (CDR !#X))) (!* (CDE MKQUOTE (!#X) (LIST 'QUOTE !#X)) ) (!* "RPLACW( X:list Y:list ):list ------ Destructively replace the Whole list X by Y.") (!* (CDE RPLACW (!#X !#Y) (RPLACA (RPLACD !#X (CDR !#Y)) (CAR !#Y))) ) (!* "DREMOVE( X:any L:list ):list ------- Remove destructively all equal occurrances of X from L.") (CDE DREMOVE (!#X !#L) (COND ((ATOM !#L) NIL) ((EQUAL !#X (CAR !#L)) (COND ((CDR !#L) (PROGN (RPLACA !#L (CADR !#L)) (RPLACD !#L (CDDR !#L)) (DREMOVE !#X !#L))))) (T (PROG (!#Z) (SETQ !#Z !#L) LP (COND ((ATOM (CDR !#L)) (RETURN !#Z)) ((EQUAL !#X (CADR !#L)) (RPLACD !#L (CDDR !#L))) (T (SETQ !#L (CDR !#L)))) (GO LP))))) (!* "REMOVE( X:any L:list ):list ------ Return copy of L with all equal occurrences of X removed.") (CDE REMOVE (!#X !#L) (COND ((ATOM !#L) !#L) ((EQUAL (CAR !#L) !#X) (REMOVE !#X (CDR !#L))) (T (CONS (CAR !#L) (REMOVE !#X (CDR !#L)))))) (!* "COPY( X:list ):list ---- Make a copy of X--EQUAL but not EQ (except for atoms).") (!* (CDE COPY (!#X) (SUBST 0 0 !#X)) ) (!* "DSUBST( X:any Y:any Z:list ):list ------ Destructively substitute copies(??) of X for Y in Z.") (!* (CDE DSUBST (!#X !#Y !#Z) (PROG (!#B) (COND ((EQUAL !#Y (SETQ !#B !#Z)) (RETURN (COPY !#X)))) LP (COND ((VECTORP !#Z) (RETURN (PROG (!#I) (SETQ !#I (UPBV !#Z)) LOOP (COND ((LESSP !#I 1) (RETURN NIL))) (PUTV !#Z !#I (DSUBST !#X !#Y (GETV !#Z !#I))) (SETQ !#I (SUB1 !#I)) (GO LOOP)))) ((ATOM !#Z) (RETURN !#B)) ((EQUAL !#Y (CAR !#Z)) (RPLACA !#Z (COPY !#X))) (T (DSUBST !#X !#Y (CAR !#Z)))) (COND ((AND !#Y (EQUAL !#Y (CDR !#Z))) (PROGN (RPLACD !#Z (COPY !#X)) (RETURN !#B)))) (SETQ !#Z (CDR !#Z)) (GO LP))) ) (!* "DSUBST is the same as SubstIP.") (CDM DSUBST (!#X) (CONS 'SUBSTIP (CDR !#X))) (!* "LSUBST( NEW:list OLD:list X:any ):list ------ Substitute elts of NEW (splicing) for the element old in X") (CDE LSUBST (!#NEW !#OLD !#X) (COND ((NULL !#X) NIL) ((VECTORP !#X) (PROG (!#V !#I) (SETQ !#I (UPBV !#X)) (SETQ !#V (MKVECT !#I)) LOOP (COND ((LESSP !#I 1) (RETURN !#V))) (PUTV !#V !#I (LSUBST !#NEW !#OLD (GETV !#V !#I))) (SETQ !#I (SUB1 !#I)) (GO LOOP))) ((ATOM !#X) (COND ((EQUAL !#OLD !#X) !#NEW) (T !#X))) ((EQUAL !#OLD (CAR !#X)) (NCONC (COPY !#NEW) (LSUBST !#NEW !#OLD (CDR !#X)))) (T (CONS (LSUBST !#NEW !#OLD (CAR !#X)) (LSUBST !#NEW !#OLD (CDR !#X)))) )) (!* (!* "TCONC( P:list X:any ): tconc-ptr ----- Pointer consists of (CONS LIST (LAST LIST)). Returns (and alters) pointer consisting of (CONS LIST1 (LAST LIST1)), where LIST1 = (NCONC1 LIST X). Avoids searching down the list as nconc1 does, by pointing at last elt of list for nconc1. To use, setq ptr to (NCONS NIL), tconc elts, return car of ptr.") (CDE TCONC (!#P !#X) (COND ((NULL !#P) (CONS (SETQ !#X (NCONS !#X)) !#X)) ((ATOM !#P) (PROGN (PRINT !#P) (ERROR 24 "BAD ARGUMENT 0 TCONC"))) ((CDR !#P) (RPLACD !#P (CDR (RPLACD (CDR !#P) (NCONS !#X))))) (T (RPLACA (RPLACD !#P (SETQ !#X (NCONS !#X))) !#X)))) (!* "LCONC( P:list X:list ):list ----- Same as TCONC, but NCONCs instead of NCONC1s.") (CDE LCONC (!#P !#X) (PROG (!#Y) (COND ((NULL !#X) (RETURN !#P)) ((OR (ATOM !#X) (CDR (SETQ !#Y (LAST !#X)))) (PRINT !#X)) ((NULL !#P) (RETURN (CONS !#X !#Y))) ((ATOM !#P) (PRINT !#P)) ((NULL (CAR !#P)) (RETURN (RPLACA (RPLACD !#P !#Y) !#X))) (T (PROGN (RPLACD (CDR !#P) !#X) (RETURN (RPLACD !#P !#Y))))) (ERROR 25 "BAD ARGUMENT 0 LCONC"))) ) (!* "CVSET( X:list ):list -------------------- Converts list to set, i.e., removes redundant elements.") (CDE CVSET (!#X) (PROG (!#RES) (COND ((NULL !#X) (RETURN NIL))) (SETQ !#RES (NCONS NIL)) LOOP (COND ((NULL !#X) (RETURN (CAR !#RES)))) (COND ((NOT (MEMBER (CAR !#X) (CDR !#X))) (TCONC !#RES (CAR !#X)))) (SETQ !#X (CDR !#X)) (GO LOOP))) (!* "ENTER( ELT:element SET:list ):list ----- Returns (ELT . SET) if ELT is not member of SET, else SET.") (CDE ENTER (!#ELT !#SET) (COND ((MEMBER !#ELT !#SET) !#SET) (T (CONS !#ELT !#SET)))) (!* "ABSTRACT( FN:function L:list ):list -------- Returns list of elts of list satisfying FN.") (CDE ABSTRACT (!#FN !#L) (PROG (!#ABSTRACTED) (SETQ !#ABSTRACTED (NCONS NIL)) (MAPC !#L (FUNCTION (LAMBDA (!#Z) (COND ((APPLY !#FN (LIST !#Z)) (TCONC !#ABSTRACTED !#Z)))))) (RETURN (CAR !#ABSTRACTED)))) (!* "EACH( L:list FN:function ):extra boolean ---- Returns L if each elt satisfies FN, else NIL.") (CDE EACH (!#L !#FN) (PROG (!#LIS) (SETQ !#LIS !#L) LOOP (COND ((NULL !#LIS) (RETURN (COND (!#L !#L) (T T)))) ((NOT (APPLY !#FN (NCONS (CAR !#LIS)))) (RETURN NIL))) (SETQ !#LIS (CDR !#LIS)) (GO LOOP))) (!* "SOME( L:list FN:function ):extra boolean ---- Returns the first tail of the list whose CAR satisfies function.") (CDE SOME (!#L !#FN) (PROG NIL LOOP (COND ((NULL !#L) (RETURN NIL)) ((APPLY !#FN (LIST (CAR !#L))) (RETURN !#L))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "INTERSECTION( #SET1:list #SET2:list ):extra boolean ------------ Returns list of elts in SET1 which are also members of SET2 ") (CDE INTERSECTION (!#SET1 !#SET2) (ABSTRACT (FUNCTION INTERSECTION1) !#SET1)) (CDE INTERSECTION1 (!#ELT) (MEMBER !#ELT !#SET2)) (!* "SETDIFFERENCE( #SET1:list #SET2:list ):extra boolean ------------- Returns all elts of SET1 not members of SET2.") (CDE SETDIFFERENCE (!#SET1 !#SET2) (ABSTRACT (FUNCTION SETDIFFERENCE1) !#SET1)) (CDE SETDIFFERENCE1 (!#ELT) (NOT (MEMBER !#ELT !#SET2))) (!* "SUBSET( #SET1:any #SET2:list ):extra boolean ------ Returns SET1 if each element of SET1 is a member of SET2.") (CDE SUBSET (!#SET1 !#SET2) (AND !#SET1 (EACH !#SET1 (FUNCTION SUBSET1)))) (CDE SUBSET1 (!#ELT) (MEMBER !#ELT !#SET2)) (!* "UNION( X:list Y:list ):list ----- Returns the union of lists X, Y") (CDE UNION (!#X !#Y) (APPEND !#X (SETDIFFERENCE !#Y !#X))) (!* "SEQUAL( X:list Y:list ):extra boolean ------ Returns X if X and Y are set-equal: same length and X subset of Y.") (CDE SEQUAL (!#X !#Y) (AND (EQUAL (LENGTH !#X) (LENGTH !#Y)) (SUBSET !#X !#Y))) (!* "MAP2( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired tails of X and Y.") (DE MAP2 (!#L1 !#L2 !#FN) (PROG NIL LOOP (COND ((NULL (AND !#L1 !#L2)) (COND ((OR !#L1 !#L2) (ERROR 0 "MAP2: mismatched lists")) (T (RETURN NIL))))) (APPLY !#FN (LIST !#L1 !#L2)) (SETQ !#L1 (CDR !#L1)) (SETQ !#L2 (CDR !#L2)) (GO LOOP))) (!* "MAP2C( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired elts of X and Y.") (DE MAP2C (!#L1 !#L2 !#FN) (PROG NIL LOOP (COND ((NULL (AND !#L1 !#L2)) (COND ((OR !#L1 !#L2) (ERROR 0 "MAP2C: mismatched lists")) (T (RETURN NIL))))) (APPLY !#FN (LIST (CAR !#L1) (CAR !#L2))) (SETQ !#L1 (CDR !#L1)) (SETQ !#L2 (CDR !#L2)) (GO LOOP))) (!* "ATSOC( ALST:list, KEY:atom ):any ----- Like ASSOC, except uses an EQ check. Returns first element of ALST whose CAR is KEY.") (!* (CDE ATSOC (KEY ALST) (COND ((NULL ALST) NIL) ((EQ (CAAR ALST) KEY) (CAR ALST)) (T (ATSOC KEY (CDR ALST))))) ) (!* " YNUMS -- BASIC NUMBER UTILITIES ADD1 ( number ):number EXPR SUB1 ( number ):number EXPR ZEROP ( any ):boolean EXPR MINUSP ( number ):boolean EXPR PLUSP ( number ):boolean EXPR POSITIVE( X:any ):extra-boolean EXPR NEGATIVE( X:any ):extra-boolean EXPR NUMERAL ( X:number/digit/any ):boolean EXPR GREAT1 ( X:number Y:number ):extra-boolean EXPR LESS1 ( X:number Y:number ):extra-boolean EXPR GEQ ( X:number Y:number ):extra-boolean EXPR LEQ ( X:number Y:number ):extra-boolean EXPR ODD ( X:integer ):boolean EXPR SIGMA ( L:list FN:function ):integer EXPR RAND16 ( ):integer EXPR IRAND ( N:integer ):integer EXPR ") (!* "The DEC compiler may optimize calls to PLUS2, DIFFERENCE, EQUAL, LESSP, etc. by converting them to calls to ADD1, SUB1, ZEROP, MINUSP, etc. This will create circular defintions in the conditional defintions, about which the compiler will complain. Such complaints can be ignored.") (!* (COND ((AND (CODEP (CCDR (GETD 'ADD1))) (CODEP (CCDR (GETD 'SUB1))) (CODEP (CCDR (GETD 'MINUSP)))) (PROGN (TERPRI) (PRIN2 "Ignore any circular definition msg for ADD1, SUB1, MINUSP") (TERPRI)))) (!* "ADD1( number ):number EXPR ---- Note: DEC compiler optimizes (PLUS2 N 1) into (ADD1 N). ") (CDE ADD1 (!#N) (PLUS2 !#N 1)) (!* "SUB1( number ):number EXPR ---- Note: DEC compiler optimizes (DIFFERENCE N 1) into (SUB1 N). ") (CDE SUB1 (!#N) (DIFFERENCE !#N 1)) (!* "ZEROP( X:any ):boolean EXPR ----- Returns non-nil iff X equals 0.") (CDE ZEROP (!#X) (EQN !#X 0)) (!* "MINUSP( N:number ):boolean EXPR ------ Returns non-nil iff N is less than 0.") (CDE MINUSP (!#N) (LESSP !#N 0)) ) (!* "PLUSP( N:number ):boolean EXPR ----- Returns non-nil iff N is greater than 0.") (CDE PLUSP (!#N) (GREATERP !#N 0)) (!* "ODD( X:integer ):boolean EXPR --- Returns T if x is odd, else NIL. WARNING: EVENP is used by REDUCE to test if a list has even length. ODD and EVENP are thus highly distinct.") (CDE ODD (!#X) (EQN 1 (REMAINDER !#X 2))) (!* "POSITIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a positive number.") (CDE POSITIVE (!#X) (AND (NUMBERP !#X) (GREATERP !#X 0))) (!* "NEGATIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a negative number.") (CDE NEGATIVE (!#X) (AND (NUMBERP !#X) (LESSP !#X 0))) (!* "NUMERAL( X:any ): boolean EXPR ------- Returns true for both numbers and digits. Some dialects had been treating the digits as numbers, and this fn is included as a replacement for NUMBERP where NUMBERP might really be checking for digits. N.B.: Digits are characters and thus ID's") (DE NUMERAL (!#X) (OR (DIGIT !#X) (NUMBERP !#X))) (!* "GREAT1( X:number Y:number ):extra-boolean EXPR ------ Returns X if it is strictly greater than Y, else NIL. GREATERP is simpler if only T/NIL is needed.") (CDE GREAT1 (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (GREATERP !#X !#Y)) !#X))) (!* "LESS1( X:number Y:number ):extra-boolean EXPR ----- Returns X if it is strictly less than Y, else NIL LESSP is simpler if only T/NIL is needed.") (CDE LESS1 (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (LESSP !#X !#Y)) !#X))) (!* (!* "GEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is greater than or equal to Y, else NIL.") (CDE GEQ (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (NOT (LESSP !#X !#Y))) !#X))) (!* "LEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is less than or equal to Y, else NIL.") (CDE LEQ (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (NOT (GREATERP !#X !#Y))) !#X))) ) (!* "SIGMA( L:list, FN:function ):integer EXPR ----- Returns sum of results of applying FN to each elt of LST.") (CDE SIGMA (!#L !#FN) (COND ((NULL !#L) 0) (T (PLUS2 (APPLY !#FN (LIST (CAR !#L))) (SIGMA (CDR !#L) !#FN))))) (!* "RAND16( ):integer EXPR IRAND ( N:integer ):integer EXPR ------ Linear-congruential random-number generator. To avoid dependence upon the big number package, we are forced to use 16-bit numbers, which means the generator will cycle after only 2^16. The randomness obtained should be sufficient for selecting choices in VOCAL, but not for monte-carlo experiments and other sensitive stuff.") (GLOBAL '(G!:RANDOM G!:RADD G!:RMUL G!:RMOD)) (!* "decimal 14933 = octal 35125, decimal 21749 = octal 52365 ") (SETQ G!:RANDOM 0) (SETQ G!:RADD 14933) (SETQ G!:RMUL 21749) (SETQ G!:RMOD (TIMES 256 256)) (!* "Returns a new 16-bit unsigned random integer. Leftmost bits are most random so you shouldn't use REMAINDER to scale this to range") (DE RAND16 NIL (SETQ G!:RANDOM (REMAINDER (TIMES G!:RMUL (PLUS G!:RADD G!:RANDOM)) G!:RMOD))) (!* "Scale new random number to range 0 to N-1 with approximately equal probability. Uses times/quotient instead of remainder to make best use of high-order bits which are most random") (DE IRAND (N) (QUOTIENT (TIMES (RAND16) N) G!:RMOD)) (!* " YSTRS -- BASIC STRING UTILITIES EXPLODEC ( X:any ):char-list EXPR EXPLODE2 ( X:any ):char-list EXPR FLATSIZE ( X:str ):integer EXPR FLATSIZE2( X:str ):integer EXPR NTHCHAR ( X:str N:number ):char-id EXPR ICOMPRESS( LST:lst ):<interned id> EXPR SUBSTR ( STR:str START:num LENGTH:num ):string EXPR CAT-DE ( L: list of strings ):string EXPR CAT-ID-DE( L: list of strings ):<uninterned id> EXPR SSEXPR ( S: string ):<interned id> EXPR ") (!* (!* "EXPLODE2( X:any ):char-list EXPR EXPLODEC( X:any ):char-list EXPR -------- List of characters which would appear in PRIN2 of X. If either is built into the interpreter, we will use that defintion for both. Otherwise, the definition below should work, but inefficiently. Note that this definition does not support vectors and lists. (The DEC and IBM interpreters support EXPLODE and EXPLODE2 by using the same internal algorithm that is used for PRIN1 (PRIN2), but put the chars generated into a list instead of printing them. Thus, they work on arbitrary s-expressions.) ") (!* "If either EXPLODEC or EXPLODE2 is defined, the CDE does nothing.") (COND ((GETD 'EXPLODEC) (FLAG '(EXPLODE2) 'LOSE))) (CDE EXPLODE2 (!#X) (PROG (!#BIG !#TAIL) (COND ((IDP !#X) (GO IDS)) ((STRINGP !#X) (GO STRS)) ((NUMBERP !#X) (RETURN (EXPLODE !#X))) ((CODEP !#X) (RETURN (EXPLODE !#X))) (T (ERROR "EXPLODE2 -- bad argument"))) (!* "For ids -- Note: last elt of #BIG will never be bang unless char before it was also a bang.") IDS (SETQ !#TAIL (SETQ !#BIG (EXPLODE !#X))) IDLP (COND ((EQUAL (CAR !#TAIL) '!!) (RPLACW !#TAIL (CDR !#TAIL))) ((NULL (CDR !#TAIL)) (RETURN !#BIG))) (SETQ !#TAIL (CDR !#TAIL)) (GO IDLP) (!* "For strings. #BIG has at least 2 elts, the quotes") STRS (SETQ !#TAIL (SETQ !#BIG (EXPLODE !#X))) STRLP(COND ((NULL (CDDR !#TAIL)) (PROGN (RPLACD !#TAIL NIL) (RETURN (CDR !#BIG)))) ((EQUAL (CAR (SETQ !#TAIL (CDR !#TAIL))) '!") (RPLACD !#TAIL (CDDR !#TAIL)))) (GO STRLP))) (REMFLAG '(EXPLODEC EXPLODE2) 'LOSE) (CDE EXPLODEC (!#X) (EXPLODE2 !#X)) (CDE EXPLODE2 (!#X) (EXPLODEC !#X)) (!* "Note: According to the STANDARD LISP REPORT, EXPLODE and EXPLODE2 are only defined for atoms. If your interpreter does not support extended EXPLODE and EXPLODE2, then change the second CDE's below for FLATSIZE and FLATSIZE2 to get recursive versions of them.") (!* " FLATSIZE( X:any ):integer EXPR -------- Number of chars in a PRIN1 of X. Also equals length of list created by EXPLODE of X, assuming that EXPLODE extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN1, but count chars instead of printing them. ") (CDE FLATSIZE (!#X) (LENGTH (EXPLODE !#X))) (!* "If your EXPLODE only works for atoms, comment out the above CDE and turn the CDE below into DE.") (CDE FLATSIZE (E) (COND ((ATOM E) (LENGTH (EXPLODE E))) (T ((LAMBDA (L1 D) (COND ((NULL D) (PLUS L1 2)) (T ((LAMBDA (L2) (COND ((ATOM D) (PLUS 5 L1 L2)) (T (PLUS 1 L1 L2)))) (FLATSIZE D))))) (FLATSIZE (CAR E)) (CDR E))))) (!* " FLATSIZE2( X:any ):integer EXPR --------- Number of chars in a PRIN2 of X. Also equals length of list created by EXPLODE2 of X, assuming that EXPLODE2 extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN2, but count chars instead of printing them. ") (!* " FLATSIZE will often suffice for FLATSIZE2 ") (CDE FLATSIZE2 (!#X) (LENGTH (EXPLODE2 !#X))) (!* "If your EXPLODE2 only works for atoms, comment out the CDE above and turn the CDE below into DE.") (CDE FLATSIZE2 (E) (COND ((ATOM E) (LENGTH (EXPLODE2 E))) (T ((LAMBDA (L1 D) (COND ((NULL D) (PLUS L1 2)) (T ((LAMBDA (L2) (COND ((ATOM D) (PLUS 5 L1 L2)) (T (PLUS 1 L1 L2)))) (FLATSIZE2 D))))) (FLATSIZE2 (CAR E)) (CDR E))))) ) (!* " NTHCHAR( X:any, N:number ):character-id EXPR ------- Returns nth character of EXPLODE2 of X.") (CDE NTHCHAR (!#X !#N) (PROG (!#Y) (COND ((SETQ !#Y (NTH!-TAIL (EXPLODE2 !#X) !#N)) (RETURN (CAR !#Y)))))) (!* "ICOMPRESS( LST:list ):interned atom EXPR --------- Returns INTERN'ed atom made by COMPRESS.") (!* (CDE ICOMPRESS (!#LST) (INTERN (COMPRESS !#LST))) ) (!* "Implode is the same as ICOMPRESS, but more efficient.") (CDM ICOMPRESS (!#X) (CONS 'IMPLODE (CDR !#X))) (!* "SUBSTR( STR:string START:number LENGTH:number ):string EXPR ------ Returns a substring of the given LENGTH beginning with the character at location START in the string. NB: The first location of the string is 0. If START or LENGTH is negative, 0 is assumed. If the length given would exceed the end of the string, the subtring returned quietly goes to end of string, no error.") (!* (CDE SUBSTR (!#STR !#START !#LENGTH) (PROG (!#BIG !#TAIL) (COND ((NOT (STRINGP !#STR)) (ERROR 0 "SUBSTR -- argument not a string.")) ((OR (NOT (NUMBERP !#START)) (NOT (NUMBERP !#LENGTH))) (ERROR 0 "SUBSTR -- start or length not number")) ((LESSP !#LENGTH 1) (RETURN "")) ((EQUAL !#STR "") (RETURN "")) ((MINUSP !#START) (SETQ !#START 0))) (!* "Fall thru when CDR of #BIG is desired first character") (SETQ !#BIG (EXPLODE !#STR)) LP (COND ((MINUSP (SETQ !#START (SUB1 !#START))) NIL) ((NULL (CDR (SETQ !#BIG (CDR !#BIG)))) (RETURN "")) ((EQUAL (CAR !#BIG) '!") (PROGN (!* "Next char must also be quote") (SETQ !#BIG (CDR !#BIG)) (GO LP))) (T (GO LP))) (!* "CDR of #BIG is desired first character") (!* "When length drops below zero, chop off remainder") (!* "If list ends first, make string from what we have") (SETQ !#TAIL !#BIG) LP2 (COND ((MINUSP (SETQ !#LENGTH (SUB1 !#LENGTH))) (RPLACD !#TAIL (LIST '!"))) ((NULL (CDR (SETQ !#TAIL (CDR !#TAIL)))) NIL) ((EQUAL (CAR !#TAIL) '!") (PROGN (SETQ !#TAIL (CDR !#TAIL)) (GO LP2))) (T (GO LP2))) (RETURN (COMPRESS (RPLACA !#BIG '!"))))) ) (!* "SUBSTR is handled more efficiently by PSL function SUB") (CDE SUBSTR (!#S !#ST !#LEN) (SUB !#S (COND ((MINUSP !#ST) 0) (T !#ST)) (SUB1 !#LEN))) (!* "CAT-DE( L: list of expressions ):string EXPR ------- Returns a string made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT macro.") (DE CAT!-DE (!#L) (COMPRESS (CONS '!" (NCONC (MAPCAN !#L (FUNCTION EXPLODE2)) (LIST '!"))))) (!* "CAT-ID-DE( L: list of any ):uninterned id EXPR ------- Returns an id made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT-ID macro.") (DE CAT!-ID!-DE (!#L) (COMPRESS (MAPCAN !#L (FUNCTION EXPLODE2)))) (!* "SSEXPR( S: string ): id EXPR ------ Returns ID `read' from string. Not very robust.") (DE SSEXPR (!#STR) (COND ((STRINGP !#STR) (ICOMPRESS (EXPLODE2 !#STR))) (T !#STR))) (!* "YIO -- simple I/O utilities. All EXPR's. CONFIRM (#QUEST: string ):boolean EATEOL ():NIL TTY-DE (#L: list ):NIL TTY-TX-DE (#L: list ):NIL TTY-XT-DE (#L: list ):NIL TTY-TT-DE (#L: list ):NIL TTY-ELT (#X: elt ):NIL PRINA (#X: any ):NIL PRIN1SQ (#X: any ):NIL PRIN2SQ (#X: any ):NIL PRINCS (#X: single-char-id ):NIL --queue-code-- SEND ():NIL SEND-1 (#EE) ENQUEUE (#FN #ARG) Q-PRIN1 (#E: any ):NIL Q-PRINT (#E: any ):NIL Q-PRIN2 (#E: any ):NIL Q-TERPRI () ONEARG-TERPRI (#E: any ):NIL Q-TYO (#N: ascii-code ):NIL Q-PRINC (#C: single-char-id ):NIL * Q-TTY-DE (#CMDS: list ):NIL * Q-TTY-XT-DE (#CMDS: list ):NIL * Q-TTY-TX-DE (#CMDS: list ):NIL * Q-TTY-TT-DE (#CMDS: list ):NIL ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (FLAG '(PRINT PRIN1 PRIN2 PRINC SETCUR TYO PPRINT TERPRI POSN PPOS) 'SAY!:PRINT) (DE PRINT2 (!#X) (PROGN (PRIN2 !#X) (TERPRI) !#X)) (DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) (SETQ !#ANS (UPPER!-CASE (READCH))) (COND ((EQUAL !#ANS !$EOL!$) (SETQ !#ANS (UPPER!-CASE (READCH))))) (COND ((EQUAL !#ANS 'Y) (PROGN (EATEOL) (RETURN T))) ((EQUAL !#ANS 'N) (PROGN (EATEOL) (RETURN NIL))) ((EQUAL !#ANS '!?) (PROGN (EATEOL) (GO LP0))) (T (PROGN (EATEOL) (TTY!-XT "Please type Y, N or ?.")))) (GO LP1))) (CDE UPPER!-CASE (CH) (PROG (TMP) (COND ((AND (LITER CH) (SETQ TMP (MEMQ CH '(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)))) (RETURN (CAR (NTH!-TAIL '(Z Y X W V U T S R Q P O N M L K J I H G F E D C B A) (LENGTH TMP))))) (T (RETURN CH))))) (!* DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) (SETQ !#ANS (CAR (EXPLODEC (READ)))) (COND ((EQ !#ANS 'Y) (PROGN (EATEOL) (RETURN T))) ((EQ !#ANS 'N) (PROGN (EATEOL) (RETURN NIL))) ((EQ !#ANS '!?) (GO LP0)) (T (TTY!-XT "Please type Y, N or ?."))) (GO LP1))) (!* "Eat (discard) text until $EOL$ or <ESC> seen. <ESC> meaningful only on PDP-10 systems. $EOL$ meaningful only on correctly-implemented Standard-LISP systems. ") (DE EATEOL NIL (PROG (!#CH) LP (SETQ !#CH (READCH)) (COND ((MEMQ !#CH (LIST '!$EOL!$ !$EOL!$)) (RETURN NIL))) (GO LP))) (!* "An idea whose time has not yet come... ") (!* DE TTY!-DE (EOLS!#BEFORE !#L EOLS!#AFTER) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) LP1 (COND ((ONEP EOLS!#BEFORE) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#BEFORE) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#BEFORE (SUB1 EOLS!#BEFORE)) (GO LP1)))) (MAPC !#L (FUNCTION TTY!-ELT)) LP1 (COND ((ONEP EOLS!#AFTER) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#AFTER) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#AFTER (SUB1 EOLS!#AFTER)) (GO LP2)))) (WRS OLD!#CHAN))) (!* "So, for now at least, ... ") (DE TTY!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (MAPC !#L (FUNCTION TTY!-ELT)) (WRS OLD!#CHAN))) (DE TTY!-TX!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (TTY!-ELT !$EOL!$) (MAPC !#L (FUNCTION TTY!-ELT)) (WRS OLD!#CHAN))) (DE TTY!-XT!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (MAPC !#L (FUNCTION TTY!-ELT)) (TTY!-ELT !$EOL!$) (WRS OLD!#CHAN))) (DE TTY!-TT!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (TTY!-ELT !$EOL!$) (MAPC !#L (FUNCTION TTY!-ELT)) (TTY!-ELT !$EOL!$) (WRS OLD!#CHAN))) (DE TTY!-ELT (!#E) (COND ((EQ !#E !$EOL!$) (Q!-TERPRI)) (T (Q!-PRIN2 !#E)))) (!* "PRINA( X:any ): any ----- Prin2s expression, after TERPRIing if it is too big for line, or spacing if it is not at the beginning of a line. Returns the value of X. Except for the space, this is just PRIN2 in the IBM interpreter.") (DE PRINA (!#X) (PROGN (COND ((LEQ (CHRCT) (FLATSIZE !#X)) (TERPRI)) ((GREATERP (POSN) 0) (PRIN2 " "))) (PRIN2 !#X))) (!* "CHRCT (): <number> ----- CHaRacter CounT left in line. Also a CDE in YPP.LSP -- built into IMSSS DEC interpreter.") (CDE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (!* "BINARY (#X: boolean): old-value ------ Stub for non-IMSSS interpreters. In IMSSS interpreter, will put terminal into binary mode or take it out, according to argument, and return old value.") (CDE BINARY (!#X) NIL) (!* "PRIN1SQ (#X: any) ------- PRIN1, Safe, use apostrophe for Quoted expressions. This is essentially a PRIN1 which tries not to exceed the right margin. It exceeds it only in those cases where the pname of a single atom exceeds the entire linelength. In such cases, <big> is printed at the terminal as a warning. (QUOTE xxx) structures are printed in 'xxx form to save space. Again, this is a little superfluous for the IBM interpreter. ") (DE PRIN1SQ (!#X) (PROG (!#SIZE) (COND ((ATOM !#X) (PROGN (SETQ !#SIZE (FLATSIZE !#X)) (COND ((LESSP (CHRCT) !#SIZE) (PROGN (TERPRI) (COND ((LESSP (CHRCT) !#SIZE) (TTY "<big>")))))) (RETURN (PRIN1 !#X)))) ((AND (EQ (CAR !#X) 'QUOTE) (CDR !#X) (NULL (CDDR !#X)) (NOT (NUMBERP (CADR !#X)))) (PROGN (PRINCS "'") (RETURN (PRIN1SQ (CADR !#X)))))) (PRINCS "(") LP (PRIN1SQ (CAR !#X)) (SETQ !#X (CDR !#X)) (COND ((NULL !#X) (RETURN (PRINCS ")")))) (PRINCS " ") (COND ((NULL (ATOM !#X)) (GO LP))) (PRINCS ".") (PRINCS " ") (PRIN1SQ !#X) (PRINCS ")"))) (!* "PRIN2SQ (#X: any) ------- PRIN2, Safe, use apostrophe for Quoted expressions. Just like PRIN1SQ, but uses PRIN2 as a basis. ") (DE PRIN2SQ (!#X) (PROG (!#SIZE) (COND ((ATOM !#X) (PROGN (SETQ !#SIZE (FLATSIZE !#X)) (COND ((LESSP (CHRCT) !#SIZE) (PROGN (TERPRI) (COND ((LESSP (CHRCT) !#SIZE) (TTY "<big>")))))) (RETURN (PRIN2 !#X)))) ((AND (EQ (CAR !#X) 'QUOTE) (CDR !#X) (NULL (CDDR !#X)) (NOT (NUMBERP (CADR !#X)))) (PROGN (PRINCS "'") (RETURN (PRIN2SQ (CADR !#X)))))) (PRINCS "(") LP (PRIN2SQ (CAR !#X)) (SETQ !#X (CDR !#X)) (COND ((NULL !#X) (RETURN (PRINCS ")")))) (PRINCS " ") (COND ((NULL (ATOM !#X)) (GO LP))) (PRINCS ".") (PRINCS " ") (PRIN2SQ !#X) (PRINCS ")"))) (!* "PRINCS (#X: single-character-atom) ------- PRINC Safe. Does a PRINC, but first worries about right margin. ") (DE PRINCS (!#X) (PROGN (COND ((LESSP (CHRCT) 1) (TERPRI))) (PRINC !#X))) (!* "1980 Jul 24 -- New Queued-I/O routines. To interface other code to this new I/O method, the following changes must be made in other code: PRIN2 --> TTY TERPRI --> $EOL$ inside a TTY, which causes Q-TERPRI to be called TYO --> Q-TYO PRIN1, PRINT -- These are used only for debugging. Do a (SEND) just before starting to print things in realtime, or use Q-PRIN1 etc. TTY -- Ok, expands into TTY-DE which calls Q-PRIN2 and Q-TERPRI. SAY -- I don't know what to do with this crock. It seems to be a poor substitute for TTY. If so it can be changed to TTY with the arguments fixed to be correct. <!GRAM>LPARSE.LSP ") (GLOBAL '(!*BATCHOUT !*BATCHQUEUE !*BATCHMAX !*BATCHCNT G!:WASTED!:SENDS G!:GOOD!:SENDS G!:GOOD!:OUTPUTS)) (!* "When *BATCHOUT is NIL, output is done in realtime and *BATCHQUEUE remains NIL. When *BATCHOUT is true, output is queued and SEND executes&dequeues it later.") (!* "Initialize *BATCHQUEUE for TCONC operations.") (SETQ !*BATCHQUEUE (NCONS NIL)) (!* "Initialize *BATCHMAX and *BATCHCNT ") (SETQ !*BATCHMAX 100) (SETQ !*BATCHCNT !*BATCHMAX) (DE SEND NIL (PROGN (COND ((CAR !*BATCHQUEUE) (PROGN (SETQ G!:GOOD!:SENDS (ADD1 G!:GOOD!:SENDS)) (SETQ G!:GOOD!:OUTPUTS (PLUS G!:GOOD!:OUTPUTS (LENGTH (CAR !*BATCHQUEUE)))) (MAPC (CAR !*BATCHQUEUE) (FUNCTION SEND!-1)) (SETQ !*BATCHCNT !*BATCHMAX) (!* "Set it again up for TCONC's.") (SETQ !*BATCHQUEUE (NCONS NIL)))) (T (SETQ G!:WASTED!:SENDS (ADD1 G!:WASTED!:SENDS)))))) (DE SEND!-1 (!#EE) (APPLY (CAR !#EE) (NCONS (CDR !#EE)))) (DE ENQUEUE (!#FN !#ARG) (PROGN (COND ((ZEROP (SETQ !*BATCHCNT (SUB1 !*BATCHCNT))) (SEND))) (SETQ !*BATCHQUEUE (TCONC !*BATCHQUEUE (CONS !#FN !#ARG))))) (DE Q!-PRIN1 (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRIN1 !#E)) (1 (PRIN1 !#E)))) (DE Q!-PRINT (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRINT !#E)) (1 (PRINT !#E)))) (DE Q!-PRIN2 (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRIN2 !#E)) (1 (PRIN2 !#E)))) (DE Q!-TERPRI NIL (COND (!*BATCHOUT (ENQUEUE 'ONEARG!-TERPRI NIL)) (1 (TERPRI)))) (DE ONEARG!-TERPRI (!#E) (TERPRI)) (DE Q!-TYO (!#N) (COND (!*BATCHOUT (ENQUEUE 'TYO !#N)) (1 (TYO !#N)))) (DE Q!-PRINC (!#C) (COND (!*BATCHOUT (ENQUEUE 'PRINC !#C)) (1 (PRINC !#C)))) (!* " These call PRIN2, so they would cause double-enqueuing. ") (!* DE Q!-TTY!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-DE !#CMDS)) (1 (TTY!-DE !#CMDS)))) (!* DE Q!-TTY!-XT!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-XT!-DE !#CMDS)) (1 (TTY!-XT!-DE !#CMDS)))) (!* DE Q!-TTY!-TX!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-TX!-DE !#CMDS)) (1 (TTY!-TX!-DE !#CMDS)))) (!* DE Q!-TTY!-TT!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-TT!-DE !#CMDS)) (1 (TTY!-TT!-DE !#CMDS)))) (SETQ G!:WASTED!:SENDS (SETQ G!:GOOD!:SENDS (SETQ G!:GOOD!:OUTPUTS 0))) (!* " YCNTRL -- ROUTINES INVOLVED WITH PROGRAM CONTROL STRUCTURES CATCH ( EXP:s-expression LABELS:id or idlist ):any EXPR THROW ( VALU:any LABEL:id ): error label EXPR ERRSET-DE ( #EXP #LBL ):any EXPR APPLY# ( ARG1: function ARG2: argument:list ):any EXPR BOUND ( X:any ):boolean EXPR MKPROG ( VARS:id-lst BODY:exp ):prog EXPR BUG-STOP (): any EXPR ") (GLOBAL '(!$THROWN!$ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* (!* "CATCH( EXP:s-expression LABELS:id or idlist ): any EXPR ----- For use with throw. If no THROW occurs in expression, then returns value of expression. If thrown label is MEMQ or EQ to labels, then returns thrown value. OW, thrown label is passed up higher. Expression should be quoted, as in ERRORSET.") (CDE CATCH (!#EXP !#LABELS) (PROG (!#EE) (COND ((PAIRP (SETQ !#EE (ERRORSET !#EXP G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (RETURN (CAR !#EE))) ((OR (EQ !#LABELS T) (EQ !#EE !#LABELS) (MEMQ !#EE !#LABELS)) (RETURN !$THROWN!$)) (T (ERROR !#EE NIL))))) (!* "THROW( VALU:any LABEL:id ): error label EXPR ----- Throws value with label up to enclosing CATCH having label. If there is no such CATCH, causes error.") (CDE THROW (!#VALU !#LABEL) (PROGN (SETQ !$THROWN!$ !#VALU) (ERROR !#LABEL NIL))) ) (!* "ERRSET-DE ( EXP LBL ):any EXPR Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. Usually called via ERRSET macro.") (DE ERRSET!-DE (!#EXP !#LBL) (PROG (!#Y) (SETQ !#Y (ERRORSET !#EXP G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (COND ((OR (PAIRP !#Y) (NULL !#Y) (EQ !#Y '!$EOF!$) (EQ !#Y !#LBL) (EQ !#LBL 'ERRORX)) (RETURN !#Y)) (T (ERROR !#Y "propagated"))))) (!* "APPLY#(ARG1: function ARG2: argument:list): any EXPR ------ Like APPLY, but can use fexpr and macro functions.") (CDE APPLY!# (!#ARG1 !#ARG2) (EVAL (CONS !#ARG1 !#ARG2))) (!* "BOUND( X:any ): boolean EXPR ----- Returns T if X is a bound id.") (CDE BOUND (!#X) (AND (IDP !#X) (PAIRP (ERRORSET !#X NIL NIL)))) (!* "MKPROG( VARS:id-lst BODY:exp ) EXPR ------ Makes a prog around the body, binding the vars.") (CDE MKPROG (!#VARS !#BODY) (CONS 'PROG (CONS !#VARS !#BODY))) (!* "BUGSTOP ():NIL EXPR ------- Enter a read/eval/print loop, exit when OK is seen.") (DE BUG!-STOP (!#STR) (PROG (!#EXP OLD!#ICHAN OLD!#OCHAN OLD!#LENGTH) (SETQ OLD!#ICHAN (RDS NIL)) (SETQ OLD!#OCHAN (WRS NIL)) (SETQ OLD!#LENGTH (LINELENGTH NIL)) (LINELENGTH 78) (COND ((PAIRP !#STR) (TTY!-DE !#STR)) (T (PRIN2 !#STR))) LOOP (TERPRI) (PRIN2 "--Bug Stop-- Type OK to continue.") (TERPRI) (SETQ !#EXP (ERRORSET '(READ) T NIL)) (COND ((ATOM !#EXP) (PROGN (PRIN2 " --Read failed-- ") (GO LOOP)))) (SETQ !#EXP (CAR !#EXP)) (COND ((EQ !#EXP 'OK) (PROGN (EATEOL) (PRIN2 "resuming... ") (TERPRI) (LINELENGTH OLD!#LENGTH) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN NIL))) ((AND (PAIRP !#EXP) (EQ (CAR !#EXP) 'RETURN)) (PROGN (EATEOL) (PRIN2 "returning... ") (TERPRI) (LINELENGTH OLD!#LENGTH) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN (EVAL (CADR !#EXP)))))) (SETQ !#EXP (ERRORSET !#EXP T NIL)) (COND ((ATOM !#EXP) (PRIN2 " --EVAL failed-- ")) (T (PRIN1 (CAR !#EXP)))) (GO LOOP))) (!* " YRARE -- ROUTINES WHICH ARE USED, BUT OF DUBIOUS USEFULNESS ?? DELETE THESE ?? LOADV ( V:vector FN:function ):vector EXPR AMONG ( ALST KEY ITEM ) EXPR INSERT ( ITEM ALST KEY ) EXPR DCONS ( X:any Y:list ):list EXPR SUBLIST ( X:list P1:integer P2:integer ):list EXPR SUBLIST1( Y ) EXPR LDIFF ( X:list Y:list ):list EXPR used in editor/copy in ZEDIT MAPCAR# ( L:list FN:function ):any EXPR MAP# ( L:list FN:function ):any EXPR INITIALP( X:list Y:list ):boolean EXPR SUBLISTP( X:list Y:list ):list EXPR INITQ ( X:any Y:list R:fn ):boolean EXPR ") (!* "LOADV( V:vector FN:function ):vector EXPR ----- Loads vector with values. Function should be 1-place numerical. V[I] _ FN( I ). If value of function is 'novalue, then doesn't change value. ??") (CDE LOADV (!#V !#FN) (PROG (!#CTR !#LEN) (COND ((NOT (SETQ !#LEN (VECTORP !#V))) (RETURN !#V))) (SETQ !#CTR 0) LOOP (PUTV !#V !#CTR (APPLY !#FN (LIST !#CTR))) (COND ((LESSP !#CTR !#LEN) (PROGN (MAKE !#CTR 1) (GO LOOP)))) (RETURN !#V))) (!* "AMONG(ALST:association-list KEY:atom ITEM:atom):boolean EXPR ----- Tests if item is found under key in association list. Uses EQUAL tests.") (CDE AMONG (!#ALST !#KEY !#ITEM) (PROG (RES) (SETQ RES (ERRORSET (LIST 'AMONG1 (MKQUOTE !#ALST) (MKQUOTE !#KEY) (MKQUOTE !#ITEM)) NIL NIL)) (COND ((EQ RES 'FOUND) (RETURN T)) ((NULL RES) (RETURN NIL)) ((ATOM RES) (ERROR RES NIL))))) (CDE AMONG1 (!#ALST !#KEY !#ITEM) (MAPC !#ALST (FUNCTION (LAMBDA (!#ENTRY) (AND (EQUAL (CAR !#ENTRY) !#KEY) (MEMQ !#ITEM (CDR !#ENTRY)) (ERROR 'FOUND NIL)))))) (!* "INSERT (ITEM:item ALST:association:list KEY:any):association list ------ EXPR (destructive operation on ALST) Inserts item in association list under key or if key not present adds (KEY ITEM) to the ALST.") (CDE INSERT (!#ITEM !#ALST !#KEY) (PROG (!#AS!:ITEM) (COND ((SETQ !#AS!:ITEM (ASSOC !#KEY !#ALST)) (COND ((NOT (MEMBER !#ITEM (CCDR !#AS!:ITEM))) (RPLACD !#AS!:ITEM (CONS !#ITEM (CDR !#AS!:ITEM)))))) (T (DCONS (LIST !#KEY !#ITEM) !#ALST))) (RETURN !#ALST))) (!* "DCONS( X:any Y:list ):list EXPR ----- Destructively cons x to list.") (CDE DCONS (!#X !#Y) (PROGN (RPLACD !#Y (CONS (CAR !#Y) (CDR !#Y))) (RPLACA !#Y !#X))) (!* "SUBLIST( X:list P1:integer P2:integer ):list EXPR ------- Returns sublist from p1 to p2 positions, negatives counting from end. I.e., (SUBLIST '(A B C D E) 2 -2) = (B C D)") (CDE SUBLIST (!#X !#P1 !#P2) (LDIFF (NTH!-TAIL !#X (SETQ !#P1 (SUBLIST1 !#X !#P1))) (NTH!-TAIL !#X (ADD1 (SUBLIST1 !#X !#P2))))) (CDE SUBLIST1 (!#X !#Y) (COND ((LESSP !#Y 0) (MAX 1 (PLUS 1 !#Y (LENGTH !#X)))) (T !#Y))) (!* "LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X.") (CDE LDIFF (!#X !#Y) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) NIL) ((NULL !#Y) !#X) (T (PROG (!#V !#Z) (SETQ !#Z (SETQ !#V (NCONS (CAR !#X)))) LOOP (SETQ !#X (CDR !#X)) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) (RETURN !#Z))) (SETQ !#V (CDR (RPLACD !#V (NCONS (CAR !#X))))) (GO LOOP))))) (!* "MAPCAR#( L:list FN:function ):any EXPR ------- Extends mapcar to work on general s-expressions as well as lists. The return is of same form, i.e. (MAPCAR# 'ATOM '(A B C . D)) = (T T T . T) Also, if for any member of list the variable SPLICE is set to true by function, then for that member the return from the function is spliced into the return.") (CDE MAPCAR!# (!#L !#FN) (PROG (!#M !#SPLICE !#TEMP) (SETQ !#M (NCONS NIL)) LOOP (COND ((NULL !#L) (RETURN (CAR !#M))) ((ATOM !#L) (RETURN (COND ((NULL (CAR !#M)) (APPLY !#FN (LIST !#L))) (T (PROGN (RPLACD (CDR !#M) (APPLY !#FN (LIST !#L))) (CAR !#M))))))) (SETQ !#TEMP (APPLY !#FN (LIST (CAR !#L)))) (COND (!#SPLICE (PROGN (SETQ !#SPLICE NIL) (LCONC !#M !#TEMP))) (T (TCONC !#M !#TEMP))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "MAP#( L:list FN:function ):any EXPR ---- Extends map to work on general s-expressions as well as lists.") (CDE MAP!# (!#L !#FN) (PROG (!#MAPPED) LOOP (COND ((NULL !#L) (RETURN !#MAPPED))) (APPLY !#FN (LIST !#L)) (COND ((ATOM !#L) (RETURN !#MAPPED))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "INITIALP( X:list Y:list ):boolean EXPR -------- Returns T if X is EQUAL to some ldiff of Y.") (CDE INITIALP (!#X !#Y) (COND ((NULL !#X) (COND (!#Y !#Y) (T T))) ((NULL !#Y) NIL) ((NOT (EQUAL (CAR !#X) (CAR !#Y))) NIL) (T (INITIALP (CDR !#X) (CDR !#Y))))) (!* "SUBLISTP( X:list Y:list ):list EXPR -------- Returns a tail of Y (or T) if X is a sublist of Y.") (CDE SUBLISTP (!#X !#Y) (COND ((NULL !#X) (COND (!#Y !#Y) (T T))) ((NULL !#Y) NIL) ((INITIALP !#X !#Y) T) (T (SUBLISTP !#X (CDR !#Y))))) (!* "INITQ( X:any Y:list R:fn ):boolean EXPR ----- Returns T if x is an initial portion of Y under the relation R.") (CDE INITQ (!#X !#Y !#R) (COND ((OR (NULL !#X) (NULL !#Y)) NIL) ((APPLY !#R (LIST (CAR !#X) (CAR !#Y))) (CONS (CAR !#X) (INITQ (CDR !#X) (CDR !#Y) !#R))))) |
Added psl-1983/3-1/util/zboot.build version [a01c9dacb4].
> > | 1 2 | compiletime load zboot; in "zboot.lsp"$ |
Added psl-1983/3-1/util/zboot.lsp version [16e9d05d1c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (DM !* (!#X) NIL) (SETQ !*EOLINSTRINGOK T) (!* "Needed for PSL, to avoid error messages while reading strings which contain carriage returns.") (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* " ZBOOT -- Bootstrapping functions and SLISP extensions ONEP (U) EXPR used where? LIST2 (U V) EXPR compiler support fn LIST3 (U V W) EXPR compiler support fn LIST4 (U V W X) EXPR compiler support fn LIST5 (U V W X Y) EXPR compiler support fn MAPOBL (!*PI!*) EXPR UTAH random utility REVERSIP (U) EXPR UTAH support fn WARNING (U) EXPR UTAH support fn IMSSS additions: (complement LOSE mechanism) CDEF (FDSCR TYPE) EXPR conditional function definition CDE (Z) FEXPR conditional expr definition CDF (Z) FEXPR conditional fexpr definition CDM (Z) FEXPR conditional macro definition CLAP( LAPCODE ) FEXPR conditional lap definition C-SETQ (#ARGS) FEXPR conditional setq These are for compatibility with the IBM interpreter: ERASE( #FILE: file descriptor ):NIL EXPR ") (!* "ARE THESE USED ONLY IN COMPILER PACKAGE?") (!* (REMFLAG '(LIST2 LIST3 LIST4 LIST5 REVERSIP) 'LOSE)) (!* (GLOBAL '(OBLIST))) (!* "IMSSS additions: ") (!* "CDEF( FNDSCR: pair, TYPE: {expr,fexpr,macro} ): {id,NIL} EXPR ---- Conditional function definition. #FNDSCR = (NAME ARGS BODY) #TYPE = {EXPR, FEXPR, or MACRO} If the function is already defined, a warning is printed, the function is not redefined, and nil is returned. Otherwise, the function is defined and the name is returned. CDEF is called by CDE, CDM and CDF, analogs to DE, DF and DM.") (!* (DE CDEF (!#FDSCR !#TYPE) (PROG (!#NAME !#NEWARGS !#NEWBODY !#OLDDEF) (COND ((ATOM !#FDSCR) (RETURN (WARNING "Bad arg to CDEF.")))) (SETQ !#NAME (CAR !#FDSCR)) (COND ((NOT (EQUAL (LENGTH !#FDSCR) 3)) (RETURN (WARNING (LIST "Bad args to CDEF for " !#NAME))))) (SETQ !#NEWARGS (CADR !#FDSCR)) (SETQ !#NEWBODY (CADDR !#FDSCR)) (COND ((NULL (SETQ !#OLDDEF (GETD !#NAME))) (RETURN (PUTD !#NAME !#TYPE (LIST 'LAMBDA !#NEWARGS !#NEWBODY)))) ((PAIRP (CDR !#OLDDEF)) (WARNING (LIST !#NAME " already " (LENGTH (CADDR !#OLDDEF)) "-arg " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE))) (T (WARNING (LIST !#NAME " is a compiled " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE)))))) (DF CDE (!#Z) (CDEF !#Z 'EXPR)) (DF CDF (!#Z) (CDEF !#Z 'FEXPR)) (DF CDM (!#Z) (CDEF !#Z 'MACRO)) (!* "CLAP( LAPCODE ): {id,NIL} EXPR ---- Conditional lap definition. If the function already has a compiled definition, warning is given, the function is not redefined, and nil is returned. Otherwise, LAP is called.") (DE CLAP (LAP!#CODE) (PROG (!#ENTRY !#ID OLD!#DEF) (COND ((NULL (SETQ !#ENTRY (ASSOC '!*ENTRY LAP!#CODE))) (RETURN (WARNING "CLAP: No *ENTRY in lap code.")))) (SETQ !#ID (CADR !#ENTRY)) (SETQ OLD!#DEF (GETD !#ID)) (COND ((OR (NULL OLD!#DEF) (PAIRP (CDR OLD!#DEF))) (LAP LAP!#CODE)) (T (WARNING (LIST !#ID " is compiled " (CAR OLD!#DEF) ", not changed to compiled " (CADDR !#ENTRY) ".")))))) ) (DM CDE (!#X) (CONS 'DE (CDR !#X))) (DM CDF (!#X) (CONS 'DF (CDR !#X))) (DM CDM (!#X) (CONS 'DM (CDR !#X))) (!* "C-SETQ( ARGS: (id any)): any FEXPR ------ Conditional SETQ. If the cadr of #ARGS is already defined, it is not reset and its old value is returned. Otherwise, it acts like SETQ. ") (DF C!-SETQ (!#ARGS) (COND ((PAIRP (ERRORSET (CAR !#ARGS) NIL NIL)) (EVAL (CAR !#ARGS))) (T (SET (CAR !#ARGS) (EVAL (CADR !#ARGS)))))) (!* "This CDE is best left here to avoid bootstrapping problems.") (CDE WARNING (!#X!#) (PROG (!#CHAN!#) (SETQ !#CHAN!# (WRS NIL)) (TERPRI) (PRIN2 "*** ") (COND ((ATOM !#X!#) (PRIN2 !#X!#)) (T (MAPC !#X!# (FUNCTION PRIN2)))) (TERPRI) (WRS !#CHAN!#))) (!* (CDE ONEP (U) (OR (EQUAL U 1) (EQUAL U 1.0))) (CDE LIST2 (U V) (CONS U (CONS V NIL))) (CDE LIST3 (U V W) (CONS U (CONS V (CONS W NIL)))) (CDE LIST4 (U V W X) (CONS U (CONS V (CONS W (CONS X NIL))))) (CDE LIST5 (U V W X Y) (CONS U (CONS V (CONS W (CONS X (CONS Y NIL)))))) ) (!* "This definition of MAPOBL doesn't work in PSL, because the oblist has a different structure. MAPOBL is defined in the interpreter though.") (!*(CDE MAPOBL (!*PI!*) (FOREACH X IN OBLIST DO (FOREACH Y IN X DO (APPLY !*PI!* (LIST Y)))))) (!* (CDE REVERSIP (U) (PROG (X Y) (WHILE U (PROGN (SETQ X (CDR U)) (SETQ Y (RPLACD U Y)) (SETQ U X))) (RETURN Y))) ) (!* "ERASE( #FILE: file descriptor ):NIL EXPR ----- This is defined in the IBM interpreter to (irrevocably) delete a file from the file system, which is a highly necessary operation when you are not allowed versions of files. It should be a no-op in the TENEX interpreters until such an operation seems necessary. This assumes the user will delete and expunge old versions from the exec.") (CDE ERASE (!#FILE) NIL) |
Added psl-1983/3-1/util/zfiles.build version [8ffb82c309].
> > > | 1 2 3 | CompileTime load(ZBoot, ZBasic, ZMacro, If!-System); in "zfiles.lsp"$ in "zsys.lsp"$ |
Added psl-1983/3-1/util/zfiles.lsp version [c2f77b2248].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZFILES contains 2 packages -- (1) YFILES -- useful functions for accessing files. (2) YTOPCOM -- useful functions for compiling files. ") (!* " YFILES -- BASIC FILE ACCESSING UTILITIES FORM-FILE ( FILE:DSCR ): filename EXPR GRABBER ( SELECTION FILE:DSCR ): NIL EXPR DUMPER ( FILE:DSCR ): NIL EXPR DUMPFNS-DE ( SELECTION FILE:DSCR ): NIL EXPR DUMP-REMAINING ( SELECTION:list DUMPED:list ): NIL EXPR FCOPY ( IN:DSCR OUT:DSCR filedscrs ):boolean EXPR REFPRINT-FOR-GRAB-CTL( #X: any ):NIL EXPR G:CREFON Switched on by cross reference program CREF:FILE G:JUST:FNS Save only fn names in variable whose name is the first field of filename if T, O/W save all exprs in that variable G:FILES List of files read into LISP G:SHOW:TRACE Turns backtrace in ERRORSET on if T G:SHOW:ERRORS Prints ERRORSET error messages if T ") (GLOBAL '(G!:FILES G!:CREFON G!:JUST!:FNS)) (GLOBAL '(G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (FLUID '(F!:FILE!:ID F!:OLD!:FILE PPPRINT)) (FLUID '(DUMP!#ID)) (!* "GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. See ZMACROS.") (!* "GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER IDS <file-dscr>) Like GRAB, but only reads in specified ids. See ZMACROS.") (!* "FORM-FILE( FILE:DSCR ): filename EXPR --------- Takes a file dscr, possibly NIL, and returns a file name corresponding to that dscr and suitable as an argument to OPEN. F:OLD:FILE is set to this file name for future reference. Meanwhile, F:FILE:ID is set to a lisp identifier, and the file name is put on the OPEN:FILE:NAME property of that identifier. The identifier can be used to hold info about the file. E.g. its value may be a list of objects read from the file. NB: FORM-FILE is at the lowest level of machine-independant code. MAKE-OPEN-FILE-NAME is a system dependant routine that creates file names specifically tailored to the version of SLISP in use. ") (DE FORM!-FILE (FILE!#DSCR) (PROG (!#TEMP) (COND ((IDP FILE!#DSCR) (MAKE FILE!#DSCR NCONS))) (!* "COND below: case 1--defaults to most recent file referenced case 2--virtual file name: access property list case 3--build usable file name from all or part of FILE:DSCR given") (COND ((NULL (CAR FILE!#DSCR)) (COND (F!:OLD!:FILE (PROGN (TTY " = " F!:FILE!:ID) (RETURN F!:OLD!:FILE))) (T (ERROR 0 "No file specified and no default file.")))) ((SETQ !#TEMP (GET (CAR FILE!#DSCR) 'OPEN!:FILE!:NAME)) (PROGN (SETQ F!:FILE!:ID (CAR FILE!#DSCR)) (RETURN (SETQ F!:OLD!:FILE !#TEMP)))) (T (RETURN (MAKE!-OPEN!-FILE!-NAME FILE!#DSCR)))))) (!* "GRABBER( SELECTION:id-list FILE:DSCR ):T EXPR ------- Opens the specified file, applies GRAB-EVAL-CTL to each expression on it, and then closes it. Returns T. See GRAB-EVAL-CTL for important side effects.") (DE GRABBER (!#SELECTION FILE!#DSCR) (PROG (!#Y EXPR!#READ !#ICHAN IBASE FILE!#ID FILE!#NAME) (SETQ FILE!#NAME (FORM!-FILE FILE!#DSCR)) (!* SETQ FILE!#NAME (GET FILE!#ID 'FILE!:NAME)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ G!:FILES (NCONC1 G!:FILES FILE!#ID)) (SET FILE!#ID (LIST NIL)) (SETQ IBASE (PLUS 5 5)) (RDS (SETQ !#ICHAN (OPEN FILE!#NAME 'INPUT))) LOOP (SETQ EXPR!#READ (ERRORSET '(READ) T G!:SHOW!:TRACE)) (COND (!#SELECTION (PRINA "."))) (COND ((AND (PAIRP EXPR!#READ) (NEQ !$EOF!$ (CAR EXPR!#READ))) (PROGN (ERRORSET (LIST 'GRAB!-EVAL!-CTL (MKQUOTE !#SELECTION) (MKQUOTE (CAR EXPR!#READ)) (MKQUOTE FILE!#ID)) T G!:SHOW!:TRACE) (COND ((NOT (SUBSET !#SELECTION (CDR (EVAL FILE!#ID)))) (GO LOOP)))))) (RDS NIL) (CLOSE !#ICHAN) (SET FILE!#ID (DREMOVE NIL (EVAL FILE!#ID))) (TERPRI) (RETURN T))) (!* "GRAB-EVAL-CTL( #SELECTION EXPR#READ FILE#ID ) EXPR ------------- Examines each expression read from file, and determines whether to EVAL that expression. Also decides whether to append the expression, or an id taken from it, or nothing at all, to the value of the file id poined at by FILE#ID. The file id is stored for use as an argument to DUMP or COMPILE, for example. Note: G:JUSTFNS suppresses the storage of comments from the file. When reading LAP files, no list of fns is made.") (DE GRAB!-EVAL!-CTL (!#SELECTION EXPR!#READ FILE!#ID) (COND ((ATOM EXPR!#READ) NIL) ((AND (EQ (CAR EXPR!#READ) 'SETQ) (EQ (CADR EXPR!#READ) FILE!#ID)) NIL) ((AND (OR (NULL !#SELECTION) (MEMBER (CADR EXPR!#READ) !#SELECTION)) (MEMBER (CAR EXPR!#READ) '(DE DF DM SETQ CDE CDF CDM C!-SETQ))) (PROGN (PRINA (CADR EXPR!#READ)) (EVAL EXPR!#READ) (COND ((AND (NEQ (CADR EXPR!#READ) 'IBASE) (NOT (MEMBER (CADR EXPR!#READ) (EVAL FILE!#ID))) (NOT (MEMBER (CAR EXPR!#READ) '(LAP CLAP)))) (NCONC1 (EVAL FILE!#ID) (CADR EXPR!#READ)))))) ((NULL !#SELECTION) (PROGN (OR G!:JUST!:FNS (NCONC1 (EVAL FILE!#ID) EXPR!#READ)) (!* "G:JUST:FNS reduces consumption of string space.") (COND (G!:CREFON (REFPRINT!-FOR!-GRAB!-CTL EXPR!#READ))) (EVAL EXPR!#READ) (PRINA (CCAR EXPR!#READ)))))) (!* "DUMPER( FILE:DSCR : file-dscr ): NIL EXPR ------ Dumps file onto disk. Filename as in GRABBER. Prettyprints the defined functions, set variables, and evaluated expressions which are members of the value of the variable filename. (For DEC versions: If IBASE neq 10, puts (SETQ IBASE current:base) at head of file.)") (DE DUMPER (!#DSCR) (PROG (!#OCHAN OLD!#OCHAN FILE!#ID) (!* SETQ FILE!#ID (FORM!-FILE !#DSCR)) (SETQ !#OCHAN (OPEN (FORM!-FILE !#DSCR) 'OUTPUT)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ OLD!#OCHAN (WRS !#OCHAN)) (MAPC (EVAL FILE!#ID) (FUNCTION PP1)) (CLOSE !#OCHAN) (WRS OLD!#OCHAN) (RETURN T))) (!* "DUMPFNS-DE( FNS FILE:DSCR ): NIL EXPR ---------- Like DUMPER. Copies old file, putting new definitions for specified functions/variables. E.g.: (DUMPFNS-DE '(A B) '(FOO)) will first copy verbatim all the expressions on FOO.LSP which do not define A or B. Then the core definitions of A and B are dumped onto the file.") (DE DUMPFNS!-DE (!#SELECTION FILE!#DSCR) (PROG (FILE!#ID FILE!#NAME IBASE !#OLD !#DUMPED !#ICHAN !#OCHAN OLD!#ICHAN OLD!#OCHAN !#ID) (SETQ FILE!#NAME (FORM!-FILE FILE!#DSCR)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ IBASE (PLUS 5 5)) (SETQ OLD!#ICHAN (RDS (SETQ !#ICHAN (OPEN FILE!#NAME 'INPUT)))) (SETQ OLD!#OCHAN (WRS (SETQ !#OCHAN (OPEN FILE!#NAME 'OUTPUT)))) LOOP (SETQ !#OLD (ERRORSET '(READ) G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (COND ((OR (ATOM !#OLD) (EQ (SETQ !#OLD (CAR !#OLD)) !$EOF!$)) (PROGN (!* "dump remaining selected objects") (DUMP!-REMAINING !#SELECTION !#DUMPED) (CLOSE !#ICHAN) (CLOSE !#OCHAN) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN T)))) (COND ((AND (PAIRP !#OLD) (MEMBER (CAR !#OLD) '(SETQ DE DF DM CDE CDF CDM)) (MEMBER (SETQ !#ID (CADR !#OLD)) !#SELECTION)) (PROGN (SETQ !#DUMPED (CONS (CONS !#ID (COND ((EQ 'SETQ (CAR !#OLD)) (PROGN (PP!-VAL !#ID) 'VAL)) (T (PROGN (PP!-DEF !#ID) 'DEF)))) !#DUMPED)) (GO LOOP)))) (COND ((AND (PAIRP !#OLD) (EQ (CAR !#OLD) 'SETQ) (EQ (CADR !#OLD) 'IBASE)) (ERRORSET !#OLD T G!:SHOW!:TRACE))) (TERPRI) (APPLY PPPRINT (LIST !#OLD 1)) (TERPRI) (TERPRI) (GO LOOP))) (!* "DUMP-REMAINING( SELECTION:list DUMPED:list ) EXPR -------------- Taken out of DUMPFNS for ease of reading. Dumps those properties of items in selection which have not already been dumped.") (DE DUMP!-REMAINING (!#SELECTION !#DUMPED) (PROG (DUMP!#ID !#IGNORE) LOOP (SETQ DUMP!#ID (CAR !#SELECTION)) (SETQ !#IGNORE (MAPCAN !#DUMPED (FUNCTION (LAMBDA (!#PAIR) (COND ((EQ DUMP!#ID (CAR !#PAIR)) (LIST (CDR !#PAIR))))) ))) (OR (MEMBER 'VAL !#IGNORE) (PP!-VAL DUMP!#ID)) (OR (MEMBER 'DEF !#IGNORE) (PP!-DEF DUMP!#ID)) (COND ((SETQ !#SELECTION (CDR !#SELECTION)) (GO LOOP))))) (!* "FCOPY( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the prettyprinter. Useful for removing angle brackets or for tightening up function format. Returns T on normal exit, NIL if error reading file. ") (DE FCOPY (IN!#DSCR OUT!#DSCR) (PROG (IN!#CHAN OUT!#CHAN !#EXP) (SETQ IN!#CHAN (OPEN (FORM!-FILE IN!#DSCR) 'INPUT)) (SETQ OUT!#CHAN (OPEN (FORM!-FILE OUT!#DSCR) 'OUTPUT)) (RDS IN!#CHAN) (WRS OUT!#CHAN) (LINELENGTH 80) LOOP (SETQ !#EXP (ERRORSET '(READ) T T)) (COND ((OR (ATOM !#EXP) (EQ (CAR !#EXP) !$EOF!$)) (PROGN (CLOSE IN!#CHAN) (RDS NIL) (CLOSE OUT!#CHAN) (WRS NIL) (RETURN (EQ !#EXP !$EOF!$))))) (SETQ !#EXP (CAR !#EXP)) (TTY ".") (COND ((ATOM !#EXP) (SPRINT !#EXP 1)) ((MEMQ (CAR !#EXP) '(DE DF DM CDE CDF CDM)) (PROGN (PRIN2 "(") (PRIN1 (CAR !#EXP)) (PRIN2 " ") (PRIN1 (CADR !#EXP)) (PRIN2 " ") (PRIN1 (CADDR !#EXP)) (S2PRINT " " (CADDDR !#EXP)) (PRIN2 ")"))) ((EQ (CAR !#EXP) 'SETQ) (PROGN (PRIN2 "(") (PRIN1 (CAR !#EXP)) (PRIN2 " ") (PRIN1 (CADR !#EXP)) (S2PRINT " " (CADDR !#EXP)) (PRIN2 ")"))) (T (SPRINT !#EXP 1))) (TERPRI) (TERPRI) (GO LOOP))) (!* "FCOPY-SQ ( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the compacting printer. Letterizes and reports via '<big>' message long strings. Returns T on normal exit, NIL if error reading file. ") (DE FCOPY!-SQ (IN!#DSCR OUT!#DSCR) (PROG (IN!#CHAN OUT!#CHAN !#EXP) (SETQ IN!#CHAN (OPEN (FORM!-FILE IN!#DSCR) 'INPUT)) (SETQ OUT!#CHAN (OPEN (FORM!-FILE OUT!#DSCR) 'OUTPUT)) (RDS IN!#CHAN) (WRS OUT!#CHAN) LOOP (SETQ !#EXP (ERRORSET '(READ) T T)) (COND ((ATOM !#EXP) (PROGN (CLOSE IN!#CHAN) (RDS NIL) (CLOSE OUT!#CHAN) (WRS NIL) (RETURN (EQ !#EXP !$EOF!$)))) ((EQ (SETQ !#EXP (CAR !#EXP)) !$EOF!$) (PROGN (CLOSE IN!#CHAN) (CLOSE OUT!#CHAN) (RETURN T)))) (TTY ".") (PRIN1SQ !#EXP) (TERPRI) (TERPRI) (GO LOOP))) (!* "Dummy -- may be replaced by real cref routine.") (DE REFPRINT!-FOR!-GRAB!-CTL (!#X) NIL) (!* " YTOPCOM -- Compiler Control functions (DF COMPILE-FILE (FILE:NAME) (DF COMPILE-IN-CORE (FILE:NAME) ") (!* "Commonly used globals. Declared in this file so each individual file doesn't have to declare them. ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "Other globals/fluids") (GLOBAL '(!*SAVEDEF)) (FLUID '(F!:FILE!:ID COMPILED!:FNS)) (!* "This flag is checked by COMPILE-FILE.") (FLAG '(EXPR FEXPR) 'COMPILE) (!* "PPLAP( MODE CODE ) EXPR ----- Prints the lap code in some appropriate format. Currently uses PRIN1SQ (PRIN1, Safe, use apostrophe to Quote non-numeric expressions).") (DE PPLAP (!#MODE !#CODE) (PRIN1SQ (LIST !#MODE (MKQUOTE !#CODE)))) (!* "COMPILE-FILE( FILE:DSCR ) FEXPR ------------ Reads the given file, and creates a corresponding LAP file. Each expression on the original file is mapped into an expression on the LAP file. Comments map into NIL. Function definitions map into the corresponding LAP code. These definitions are compiled, but NOT evaluated -- hence the functions will not be loaded into this core image by this routine. All other expressions are evaluated in an errorset then copied verbatim. EXCEPTION: UNFLUID is evalutated, but converted into a comment when printed, to avoid confusing loader. ") (FLUID '(QUIET_FASLOUT!*)) (!* "Controls printing of welcome message in FASLOUT.") (DF COMPILE!-FILE (FILE!:DSCR) (PROG (IN!:SEXPR LSP!:FILE LAP!:FILE OLD!:SAVEDEF LAP!:FN!:NAME LAP!:OUT QUIET_FASLOUT!* LAP!:FN LSP!:FILE!:ID OCHAN ICHAN TYPE MODE) (!* "*SAVEDEF Saves LAP code generated by the compiler on the property list of the function under indicator COMPEXP") (!* (SETQ OLD!:SAVEDEF !*SAVEDEF) (SETQ !*SAVEDEF T)) (SETQ QUIET_FASLOUT!* T) (GCMSG NIL) (!* "Note: If FILE:DSCR = (AAA BBB) then TENEX: from LSP:FILE = '<AAA>BBB.LSP', LSP:FILE:ID = BBB to LAP:FILE = '<AAA>BBB.LAP', LAP:FILE:ID = BBB CMS: from LSP:FILE = 'AAA BBB', LSP:FILE:ID = AAA to LAP:FILE = 'AAA LAP', LAP:FILE:ID = AAA This is non-ideal, since the first filename gets lost. It is not clear, however, what an elegant solution would be. Perhaps the file id should have a list of filenames, one for each extension... ") (SETQ LSP!:FILE (FORM!-FILE FILE!:DSCR)) (SETQ LSP!:FILE!:ID F!:FILE!:ID) (SETQ ICHAN (OPEN LSP!:FILE 'INPUT)) (!* "Try to create lap file corresponding to LSP file.") (SETQ LAP!:FILE (SUBST '!; 'LSP LSP!:FILE)) (!* "But if that doesn't work out..") (COND ((EQUAL LSP!:FILE LAP!:FILE) (SETQ LAP!:FILE (FORM!-FILE (CONS LSP!:FILE!:ID '!;))))) (!* SETQ LAP!:FILE!:ID F!:FILE!:ID) (ERRORSET (LIST 'ERASE (MKQUOTE LAP!:FILE)) G!:SHOW!:ERRORS G!:SHOW!:TRACE) (!*(SETQ OCHAN (OPEN LAP!:FILE 'OUTPUT))) (FASLOUT LAP!:FILE) (RDS ICHAN) (WHILE (AND (PAIRP (SETQ IN!:SEXPR (ERRORSET '(READ) NIL NIL))) (NOT (EQ (SETQ IN!:SEXPR (CAR IN!:SEXPR)) !$EOF!$))) (!* PROGN (SETQ COMPILED!:FNS NIL) (SETQ TYPE (SELECTQ (CAR IN!:SEXPR) ((DE CDE) 'EXPR) ((DF CDF) 'FEXPR) ((DM CDM) 'MACRO) NIL)) (SETQ MODE (SELECTQ (CAR IN!:SEXPR) ((CDE CDF CDM) 'CLAP) ((DE DF DM) 'LAP) NIL)) (COND ((FLAGP TYPE 'COMPILE) (PROG NIL (PRINA (SETQ LAP!:FN!:NAME (CADR IN!:SEXPR))) (SETQ LAP!:OUT (SIMPLIFYLAP (CONS (LIST '!*ENTRY LAP!:FN!:NAME TYPE (LENGTH (CADDR IN!:SEXPR))) (!&COMPROC (CONS 'LAMBDA (CDDR IN!:SEXPR)) LAP!:FN!:NAME)))) (WRS OCHAN) (!* LOOP (SETQ LAP!:OUT (CDR (REMPROP LAP!:FN!:NAME 'COMPEXP)))) (PPLAP MODE LAP!:OUT) (TERPRI) (!*(COND ((SETQ COMPILED!:FNS (DREMOVE LAP!:FN!:NAME COMPILED!:FNS)) (PROGN (SETQ LAP!:FN!:NAME (CCAR COMPILED!:FNS)) (GO LOOP))))) (WRS NIL) (PRINA "ok"))) ((MEMQ (CAR IN!:SEXPR) '(!* !*!*)) NIL) ((EQ (CAR IN!:SEXPR) 'UNFLUID) (EVAL IN!:SEXPR)) (T (PROGN (ERRORSET (LIST 'EVAL (MKQUOTE IN!:SEXPR)) T NIL) (!* "Be sure errors are printed to terminal") (WRS OCHAN) (SPRINT IN!:SEXPR 1) (TERPRI) (WRS NIL))))) (DFPRINTFASL IN!:SEXPR)) (SETQ !*SAVEDEF OLD!:SAVEDEF) (CLOSE ICHAN) (RDS NIL) (!* (CLOSE OCHAN)) (FASLEND))) (!* "COMPILE-IN-CORE( FILE:DSCR ):NIL FEXPR --------------- Compiles all EXPRS and FEXPRS on a file and loads compiled code into core. Creates a file FILE:NAME.cpl which is a compilation log consisting of the names of functions compiled and the space used in their loading.") (DF COMPILE!-IN!-CORE (FILE!:DSCR) (PROG (IN!:SEXPR LAP!:FN!:NAME LAP!:FN LOG!:FILE LOG!:CHAN LSP!:CHAN LSP!:FILE!:ID LSP!:FILE) (SETQ LSP!:FILE (FORM!-FILE FILE!:DSCR)) (SETQ LSP!:FILE!:ID F!:FILE!:ID) (SETQ LSP!:CHAN (OPEN LSP!:FILE 'INPUT)) (SETQ LOG!:FILE (FORM!-FILE (CONS LSP!:FILE!:ID 'CPL))) (SETQ LOG!:CHAN (OPEN LOG!:FILE 'OUTPUT)) (RDS LSP!:CHAN) (WHILE (AND (PAIRP (SETQ IN!:SEXPR (ERRORSET '(READ) G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (NOT (EQ !$EOF!$ (SETQ IN!:SEXPR (CAR IN!:SEXPR)))) (PAIRP (ERRORSET IN!:SEXPR G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (COND ((MEMQ (CAR IN!:SEXPR) '(DE DF CDE CDF)) (PROGN (SETQ LAP!:FN!:NAME (CADR IN!:SEXPR)) (WRS LOG!:CHAN) (COMPILE (NCONS LAP!:FN!:NAME)) (WRS NIL) (PRINA LAP!:FN!:NAME))))) (SETQ COMPILED!:FNS NIL) (RDS NIL) (CLOSE LSP!:CHAN) (CLOSE LOG!:CHAN))) (!* "GCMSG( X:boolean ):any EXPR ----- Pre-defined in both SLISP and new IBM intpreter, so this cde shouln't do anything. GCMSG turns the garbage collection msgs on or off.") (CDE GCMSG (!#X) NIL) |
Added psl-1983/3-1/util/zmacro.build version [fba4d3e5b7].
> > | 1 2 | compiletime load(zboot,zbasic,zmacro); in "zmacro.lsp"$ |
Added psl-1983/3-1/util/zmacro.lsp version [767d0232b8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZMACRO contains two macro packages -- (1) YMACS -- basically useful macros and fexprs. (2) YSAIMACS -- macros used to simulate many SAIL constructs. ") (!* " YMACS -- USEFUL MACROS AND FEXPRS (see also YSAIMAC) * ( X:any ): NIL MACRO ** ( X:list ) MACRO NEQ ( X:any Y:any ):boolean MACRO NEQN ( X:any Y:any ):boolean MACRO NEQUAL ( X:any Y:any ):boolean MACRO MAKE ( variable template ) MACRO SETQQ ( variable value ) MACRO EXTEND ( function series ) MACRO DREVERSE( list ):list MACRO APPENDL ( lists ) MACRO NCONCL ( lists ) MACRO NCONC1 ( lst exp1 ... expn ): any MACRO SELECTQ ( exp cases last-resort ) MACRO WHILE ( test body ) MACRO REPEAT ( body test ) MACRO FOREACH ( var in/of lst do/collect exp ) MACRO SAY ( test expressions ) MACRO DIVERT ( channel expressions ) MACRO CAT ( list of any ):string MACRO CAT-ID ( list of any ):<uninterned id> MACRO TTY ( L:list ):NIL MACRO TTY-TX ( L:list ):NIL MACRO TTY-XT ( L:list ):NIL MACRO TTY-TT ( L:list ):NIL MACRO ERRSET ( expression label ) MACRO GRAB ( file ) MACRO GRABFNS ( ids file-dscr ) MACRO DUMP ( file-dscr ) MACRO DUMPFNS ( ids file-dscr ) MACRO used to expand macros: XP#SELECTQ (#L#) EXPR XP#WHILE (#BOOL #BODY) EXPR XP#FOREACH (#VAR #MOD #LST #ACTION #BODY) EXPR XP#SAY1 ( expression ) EXPR ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "In ZBOOT, not needed here." (CDM !* (!#X) NIL) ) (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* "**( X:list ) MACRO ===> (PROGN <lists>) For comments--all atoms are ignored, lists evaluated as in PROGN.") (CDM !*!* (!#X) (CONS 'PROGN (ABSTRACT (FUNCTION PAIRP) (CDR !#X)))) (!* "NEQ( X:any Y:any ):boolean MACRO ===> (NOT (EQ X Y)) ") (!* "Changed to CDM because NEQ in PSL means NOT EQUAL. We hope to change that situation, however.") (CDM NEQ (!#X) (LIST 'NOT (CONS 'EQ (CDR !#X)))) (!* "NEQN( X:any Y:any ):boolean MACRO ===> (NOT (EQN X Y)) ") (DM NEQN (!#X) (LIST 'NOT (CONS 'EQN (CDR !#X)))) (!* "NEQUAL( X:any Y:any ):boolean MACRO ===> (NOT (EQUAL X Y)) ") (DM NEQUAL (!#X) (LIST 'NOT (CONS 'EQUAL (CDR !#X)))) (!* "MAKE( variable template ) MACRO ===> (SETQ <var> <some form using var>) To change the value of a variable depending upon template. Uses similar format for template as editor MBD. There are 3 cases. 1) template is numerical: (MAKE VARIABLE 3) = (SETQ VARIABLE (PLUS VARIABLE 3)) 2) Template is a series, whose first element is an atom: (MAKE VARIABLE ASSOC ITEM) = (SETQ VARIABLE (ASSOC ITEM VARIABLE)) 3) Otherwise, variable is substituted for occurrences of * in template. (MAKE VARIABLE (ASSOC (CADR *) (CDDR *)) = (SETQ VARIABLE (ASSOC (CADR VARIABLE) (CDDR VARIABLE))") (CDM MAKE (!#X) (PROGN (SETQ !#X (CDR !#X)) (LIST 'SETQ (CAR !#X) (COND ((NUMBERP (CADR !#X)) (CONS 'PLUS !#X)) ((ATOM (CADR !#X)) (APPEND (CDR !#X) (LIST (CAR !#X)))) (T (SUBST (CAR !#X) '!* (CADR !#X))))))) (!* "SETQQ( variable value ) MACRO ===> (SETQ VARIABLE 'VALUE) ") (CDM SETQQ (!#X) (LIST 'SETQ (CADR !#X) (MKQUOTE (CADDR !#X)))) (!* "EXTEND( function series ) MACRO ===> (FN ELT1 (FN ELT2 ... (FN ELTn-1 ELTn))) Applies 2-place function to series, similarly to PLUS. E.g.: (EXTEND SETQ A B C D 5) = (SETQ A (SETQ B (SETQ C (SETQ D 5))))") (CDM EXTEND (!#X) (EXPAND (CDDR !#X) (CADR !#X))) (!* "DREVERSE( L: list ):list MACRO ===> (REVERSIP L) Synonym for REVERSIP.") (DM DREVERSE (!#X) (CONS 'REVERSIP (CDR !#X))) (!* "APPENDL( lists ) MACRO ===> (APPEND LIST1 (APPEND LIST2 ....)) EXPAND's APPEND to a list of arguments instead of just 2.") (CDM APPENDL (!#X) (EXPAND (CDR !#X) 'APPEND)) (!* "NCONCL( lists ) MACRO ===> (NCONC LST1 (NCONC LST2 ....)) EXPAND's NCONC to a list of arguments instead of just 2.") (CDM NCONCL (!#X) (EXPAND (CDR !#X) 'NCONC)) (!* "NCONC1( lst exp1 ... expn ): any MACRO ===> (NCONC LST (LIST EXP1 ... EXPn)) Destructively add exp1 ... exp-n to the end of lst.") (CDM NCONC1 (!#X) (LIST 'NCONC (CADR !#X) (CONS 'LIST (CDDR !#X)))) (!* "SELECTQ( exp cases last-resort ) MACRO ===> (COND ...) Exp is a lisp expression to be evaluated. Each case-i is of the form (key-i exp1 exp2...expm). Last-resort is a lisp expression to be evaluated. Generates a COND statement: If key-i is an atom, case-i becomes the cond-pair: ((EQUAL exp key-i) (PROGN exp1 exp2 ... expm)) If key-i is a list, case-i becomes the cond-pair: ((MEMBER exp key-i) (PROGN exp1 exp2 ... expm)) Last-resort becomes the final cond-pair: (T last-resort) If exp is non-atomic, it should not be re-evaluated in each clause, so a dummy variable (#SELECTQ) is set to the value of exp in the first test and that dummy variable is used in all successive tests. Note: (1) A FEXPR version of SELECTQ would forbid use of RETURN and GO. (2) The form created must NOT have a prog or lambda wrapped around the cond expression, as this would also forbid RETURN and GO. Since #SELECTQ can't be lambda-bound by any means whatsoever and remain consistent with the standard-lisp report (if GO or RETURN appears inside a consequent), there is no way we can make SELECTQ re-entrant. If you go into a break with ^B or ^H and execute another SELECTQ you will clobber the one and only incarnation of #SELECTQ, and if it happened to be in the middle of deciding which consequent to execute, then when you continue the computation it won't work correctly. Update -- IMSSS break pkg now tries to protect #SELECTQ. Update -- uses XP#SELECTQ which can be compiled to speed up macro expansion. ") (CDM SELECTQ (!#SLQ) (XP!#SELECTQ (CDR !#SLQ))) (DE XP!#SELECTQ (!#L!#) (PROG (!#FIRSTCL !#RESTCL !#RSLT) (SETQ !#RSLT (NCONS 'COND)) (COND ((ATOM (CAR !#L!#)) (SETQ !#FIRSTCL (SETQ !#RESTCL (CAR !#L!#)))) ((EQ (CAAR !#L!#) 'SETQ) (PROGN (SETQ !#FIRSTCL (CAR !#L!#)) (SETQ !#RESTCL (CADAR !#L!#)))) (T (SETQ !#FIRSTCL (LIST 'SETQ (SETQ !#RESTCL '!#SELECTQ) (CAR !#L!#))))) LP (COND ((CDR (SETQ !#L!# (CDR !#L!#))) (PROGN (NCONC !#RSLT (NCONS (CONS (LIST (COND ((ATOM (CAAR !#L!#)) 'EQUAL) (T 'MEMBER)) !#FIRSTCL (LIST 'QUOTE (CAAR !#L!#))) (COND ((NULL (CDDAR !#L!#)) (CDAR !#L!#)) (T (NCONS (CONS 'PROGN (CDAR !#L!#)))))))) (SETQ !#FIRSTCL !#RESTCL) (GO LP)))) (NCONC !#RSLT (NCONS (CONS T !#L!#))) (RETURN !#RSLT))) (!* "WHILE( test body ) MACRO ===> (PROG ...) <while loop> While test is true do body.") (!* (CDM WHILE (!#X) (XP!#WHILE (CADR !#X) (CDDR !#X))) (DE XP!#WHILE (!#BOOL !#BODY) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (NCONC (LIST 'PROG NIL !#LAB (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'RETURN NIL)))) (APPEND !#BODY (LIST (LIST 'GO !#LAB))))))) ) (!* (!* "REPEAT( body test ) MACRO ===> (PROG ...) <repeat loop> Repeat body until test is true. Jim found that this fn as we had it was causing compiler errors. The BODY was (CDDR U) and the BOOL was (CADR U). Question: Does the fact that Utah was unable to reproduce our compiler errors lie in this fact. Does function until test becomes non-NIL.") (CDM REPEAT (!#X) (XP!#REPEAT (CADR !#X) (CADDR !#X))) (DE XP!#REPEAT (!#BODY !#BOOL) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (LIST 'PROG NIL !#LAB !#BODY (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'GO !#LAB))))))) ) (!* (!* "FOREACH( var in/of lst do/collect exp ) MACRO ===> (MAPxx LST (FUNCTION (LAMBDA (VAR) EXP))) Undocumented FOREACH supplied by Utah. Required by compiler. Update: modified to call xp#foreach which can be compiled to speed up macro expansion.") (CDM FOREACH (!#X) (XP!#FOREACH (CADR !#X) (CADDR !#X) (CAR (SETQ !#X (CDDDR !#X))) (CADR !#X) (CADDR !#X))) (DE XP!#FOREACH (!#VAR !#MOD !#LST !#ACTION !#BODY) (PROG (!#FN) (SETQ !#FN (COND ((EQ !#ACTION 'DO) (COND ((EQ !#MOD 'IN) 'MAPC) (T 'MAP))) ((EQ !#MOD 'IN) 'MAPCAR) (T 'MAPLIST))) (RETURN (LIST !#FN !#LST (LIST 'FUNCTION (LIST 'LAMBDA (LIST !#VAR) !#BODY)))))) ) (!* "SAY( test expressions ) MACRO ===> (COND (<test> (PROGN (PRIN2 ...) (PRIN2 ...) ...))) If test is true then evaluate and prin2 all expressions. Exceptions: the value of printing functions, those flaged with SAY:PRINT (including: PRINT PRIN1 PRIN2 PRINC TYO PPRINT TERPRI POSN DOHOME DORIGH DOLEFT DOUP DODOWN DPYNCH DPYCHR SETCUR MOVECUR) are just evaluated. E.g.: (In the example @ is used for quotes) (SAY T @this @ (PRIN1 '!!AND!!) @ that@) appears as: this !!AND!! that ") (DM SAY (!#X) (LIST 'COND (LIST (CADR !#X) (CONS 'PROGN (MAPCAR (CDDR !#X) (FUNCTION XP!#SAY1)))))) (DE XP!#SAY1 (!#Y) (COND ((AND (PAIRP !#Y) (EQ (CAR !#Y) 'PRINTER)) (CADR !#Y)) ((AND (PAIRP !#Y) (FLAGP (CAR !#Y) 'SAY!:PRINT)) !#Y) (T (LIST 'Q!-PRIN2 !#Y)))) (FLAG '(Q!-PRINT Q!-PRIN1 Q!-PRIN2 Q!-PRINC SETCUR Q!-TYO PPRINT POSN PPOS TTY) 'SAY!:PRINT) (!* "DIVERT( channel expressions ) MACRO ===> (PROG (ochan) <select given chan> <eval exps> <select ochan>) Yields PROG that selects channel for output, evaluates each expression, and then reselects prior channel.") (CDM DIVERT (!#L) (CONS 'PROG (CONS (LIST 'OLD!#CHAN) (CONS (LIST 'SETQ 'OLD!#CHAN (LIST 'WRS (CADR !#L))) (APPEND (CDDR !#L) (LIST (LIST 'WRS 'OLD!#CHAN))))))) (!* "CAT( list of any ):string MACRO ===> (CAT-DE (LIST <list>)) Evaluates all arguments given and forms a string from the concatenation of their prin2 names. ") (CDM CAT (!#X) (LIST 'CAT!-DE (CONS 'LIST (CDR !#X)))) (!* "CAT-ID( list of any ):<uninterned id> MACRO ===> (CAT-ID-DE (LIST <list>)) Evaluates all arguments given and forms an id from the concatenation of their prin2 names. ") (CDM CAT!-ID (!#X) (LIST 'CAT!-ID!-DE (CONS 'LIST (CDR !#X)))) (!* "TTY ( L:list ):NIL MACRO TTY-TX( L:list ):NIL MACRO TTY-XT( L:list ):NIL MACRO TTY-TT( L:list ):NIL MACRO ===> (TTY-xx-DE (LIST <list>)) TTY is selected for output, then each elt of list is evaluated and PRIN2'ed, except for $EOL$'s, which cause a TERPRI. Then prior output channel is reselected. TTY-TX adds leading TERPRI. TTY-XT adds trailing TERPRI. TTY-TT adds leading and trailing TERPRI's. ") (!* "CDMs were making all of the following unloadable into existing QDRIVER.SAV core image. I flushed the 'C' July 27") (!* "TTY-DE now takes two extra arguments, for the number of TERPRIs to preceed and follow the other printed material.") (DM TTY (!#X) (LIST 'TTY!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TX (!#X) (LIST 'TTY!-TX!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-XT (!#X) (LIST 'TTY!-XT!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TT (!#X) (LIST 'TTY!-TT!-DE (CONS 'LIST (CDR !#X)))) (!* "ERRSET (expression label) MACRO ===> (ERRSET-DE 'exp 'label) Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them.") (CDM ERRSET (!#X) (LIST 'ERRSET!-DE (MKQUOTE (CADR !#X)) (MKQUOTE (CADDR !#X)))) (!* "GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE.") (DM GRAB (!#X) (LIST 'GRABBER NIL (MKQUOTE (CDR !#X)))) (!* "GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER FNS <file-dscr>) Like grab, but only reads in specified fns/vars.") (DM GRABFNS (!#X) (LIST 'GRABBER (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* "DUMP( <file description> ) MACRO ===> (DUMPER '<file-dscr>) Dumps file onto disk. Filename as in GRAB. Prettyprints.") (DM DUMP (!#X) (LIST 'DUMPER (MKQUOTE (CDR !#X)))) (!* "DUMPFNS( <ids> . <file dscr> ) MACRO ===> (DUMPFNS-DE <fns> '<file-dscr>) Like DUMP, but copies old file, inserting new defs for specified fns/vars") (DM DUMPFNS (!#X) (LIST 'DUMPFNS!-DE (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* " We are currently defining these to be macros everywhere, but might want them to be exprs while interpreted, in which case use the following to get compile-time macros.") (!* PUT 'NEQ 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQ !#X !#Y)))) (!* PUT 'NEQN 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQN !#X !#Y)))) (!* PUT 'NEQUAL 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQUAL !#X !#Y)))) (!* " YSAIMAC -- MACROS used to simulate SAIL constructs. macros: DO-UNTIL SAI-IF SAI2-IF SAI-DONE SAI-CONTINUE SAI-WHILE SAI-FOREACH SAI-FOR SAI-BEGIN PBEGIN PRETURN SAI-ASSIGN MSETQ SAI-COLLECT IFC OUTSTR SAI-SAY SAI-& SAI-LENGTH CVSEST CVSEN CVS SUBSTRING-FOR SUBSTRING-TO PUSHES PUSHVARS SLIST SAI-MAPC SAI-EQU auxiliary exprs used to expand macros: XP#SAY-IF XP#SAI-WHILE XP#SAI-FOREACH XP#SAI-FOR XP#SUBSTRING-TO ") (DM DO!-UNTIL (FORM) (LIST 'PROG NIL 'L (CADR FORM) (LIST 'COND (LIST (CADDDR FORM) NIL) (LIST 1 '(GO L))))) (!* "SAI-IF ( sailish if-expression ) MACRO (IF test1 THEN exp1 [ ELSEIF testi THEN expi ] [ELSE expn]) ===> (COND (test1 exp1) ... (testi expi) ... (T expn)) Embedded expressions do not cause embedded COND's, (unlike ALGOL!). Examples: (IF (ATOM Y) THEN (CAR X)) (IF (ATOM Y) THEN (CAR X) ELSE (CADR X)) (IF (ATOM Y) THEN (CAR X) ELSEIF (ATOM Z) THEN (CADR X)) ") (DM SAI!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DM SAI2!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DE XP!#SAI!-IF (IF!#X) (PROG (!#ANTE !#CONSEQ !#TEMP !#ANS) (SETQ !#ANS NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#ANTE (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ (SETQ !#TEMP (CAR IF!#X)) 'THEN) (SETQ IF!#X (CDR IF!#X)))) (SETQ !#CONSEQ NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#TEMP (CAR IF!#X)) (COND ((OR (EQ !#TEMP 'ELSE) (EQ !#TEMP 'ELSEIF) (EQ !#TEMP 'EF)) (RETURN NIL))) (SETQ !#CONSEQ (CONS !#TEMP !#CONSEQ)) (SETQ IF!#X (CDR IF!#X)) (GO WHTAG))))) (SETQ !#ANS (CONS (CONS !#ANTE (REVERSE !#CONSEQ)) !#ANS)) (COND ((NOT IF!#X) (RETURN NIL))) (SETQ !#TEMP (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ !#TEMP 'ELSE) (PROGN (SETQ !#ANS (CONS (CONS 'T IF!#X) !#ANS)) (RETURN NIL)))) (!* " MUST BE ELSEIF") (GO WHTAG))))) (RETURN (CONS 'COND (REVERSE !#ANS))))) (DM SAI!-DONE (C!#X) '(RETURN NIL)) (DM SAI!-CONTINUE (C!#X) '(GO CONTINUE!:)) (!* "SAI-WHILE ( sailish while-expression ) MACRO (WHILE b DO e1 e2 ... en) does e1,..., en as long as b is non-nil. ===> (PROG NIL CONTINUE: (COND ((NULL b) (RETURN NIL))) e1 ... en (GO CONTINUE:)) N.B. (WHILE b DO ... (RETURN e)) has the RETURN relative to the PROG in the expansion. As in SAIL, (CONTINUE) and DONE work as statements. (They are also macros.) ") (DM SAI!-WHILE (WH!#X) (XP!#SAI!-WHILE WH!#X)) (DE XP!#SAI!-WHILE (WH!#X) (APPENDL (LIST 'PROG NIL 'CONTINUE!: (LIST 'COND (LIST (LIST 'NOT (CADR WH!#X)) (LIST 'RETURN NIL)))) (SAI!-IF (EQ (CADDR WH!#X) 'DO) THEN (CDDDR WH!#X) ELSE (CDDR WH!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOREACH (FOREACH!#X) (XP!#SAI!-FOREACH FOREACH!#X)) (DE XP!#SAI!-FOREACH (FORE!#X) (APPENDL (LIST 'PROG '(FORE!#TEMP) (LIST 'SETQ 'FORE!#TEMP (CADDDR FORE!#X)) 'CONTINUE!: '(SAI!-IF (NULL FORE!#TEMP) THEN (RETURN NIL)) (LIST 'SETQ (CADR FORE!#X) '(CAR FORE!#TEMP)) '(SETQ FORE!#TEMP (CDR FORE!#TEMP))) (CDR (CDDDDR FORE!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOR (FOR!#X) (XP!#SAI!-FOR FOR!#X)) (DE XP!#SAI!-FOR (FOR!#X) (CONS 'PROG (CONS NIL (CONS (LIST 'SETQ (CADR FOR!#X) (CADDDR FOR!#X)) (CONS 'FOR!#LOOP!: (CONS (LIST 'SAI!-IF (LIST (COND ((GREATERP (EVAL (CADR (CDDDDR FOR!#X))) 0) 'GREATERP) (T 'LESSP)) (CADR FOR!#X) (CADDDR (CDDDDR FOR!#X))) 'THEN '(RETURN NIL)) (APPEND (CDR (CDDDDR (CDDDDR FOR!#X))) (LIST 'CONTINUE!: (LIST 'SETQ (CADR FOR!#X) (LIST 'PLUS (CADR FOR!#X) (CADR (CDDDDR FOR!#X)))) '(GO FOR!#LOOP!:))))))))) (DM SAI!-BEGIN (BEG!#X) (CONS 'DO (CDR BEG!#X))) (DM PBEGIN (PBEG!#X) (LIST 'CATCH (KWOTE (CONS 'PROG (CDR PBEG!#X))) ''!$PLAB)) (DM PRETURN (PRET!#X) (LIST 'THROW (KWOTE (CADR PRET!#X)) (KWOTE '!$PLAB))) (DM SAI!-ASSIGN (!#X) (LIST 'SETQ (CADR !#X) (CADDR !#X))) (DM MSETQ (MSETQ!#X) (CONS 'PROG (CONS '(!#!#RESULT) (CONS (LIST 'SETQ '!#!#RESULT (CADDR MSETQ!#X)) (MAPCAR (CADR MSETQ!#X) (FUNCTION (LAMBDA (X) (LIST 'SETQ X '(POP !#!#RESULT))))))))) (DM SAI!-COLLECT (X) (LIST 'SETQ (CADDDR X) (LIST 'CONS (CADR X) (CADDDR X)))) (DM IFC (X) (COND ((EVAL (CADR X)) (CADDDR X)) ((EQ (CAR (CDDDDR X)) 'ELSEC) (CADR (CDDDDR X))) (T NIL))) (DM OUTSTR (!#X) (CONS 'TTY (CDR !#X))) (!* DE TTYMSG (!#X) (MAPC !#X (FUNCTION (LAMBDA (!#ELT) (COND ((STRINGP !#ELT) (PRIN2 !#ELT)) ((EQ !#ELT 'T) (TERPRI)) (T (PRINT (EVAL !#ELT)))))))) (DM SAI!-SAY (!#X) (CONS 'TTY (CDR !#X))) (DM SAI!-!& (!#X) (CONS 'CAT (CDR !#X))) (DM SAI!-LENGTH (!#X) (CONS 'FLATSIZE2 (CDR !#X))) (DM CVSEST (!#X) (CADR !#X)) (DM CVSEN (!#X) (CADR !#X)) (DM CVS (!#X) (CADR !#X)) (DM SUBSTRING!-FOR (!#L) (LIST 'SUBSTR (CADR !#L) (LIST 'SUB1 (CADDR !#L)) (CADDDR !#L))) (!* "REM is planning on cleaning this up so it works in all cases... The form that (SUBSTRING-TO stringexpr low high) should expand into is ((LAMBDA (#STRING) (SUBSTR #STRING low high)) stringexpr) except that low and high have been modified to replace INF by explicit calls to (FLATSIZE2 #STRING). Thus things like (SUBSTRING-TO (READ) 2 (SUB1 INF)) should work without requiring the user to type the same string twice. Probably that inner (SUBSTR ...) should simply be ((LAMBDA (INF) (SUBSTR #STRING low high)) (FLATSIZE2 #STRING)) where we don't have to internally modify low or high at all!") (DM SUBSTRING!-TO (!#L) (XP!#SUBSTRING!-TO (CDR !#L))) (DE XP!#SUBSTRING!-TO (!#L) (PROG (STREXP LOWEXP HIEXP IN!:LOW!:BOUND INNER!:INF!:BOUND OUTER!:STRING!:BOUND OLDRES NEWRES) (SETQ STREXP (CAR !#L)) (SETQ LOWEXP (CADR !#L)) (SETQ HIEXP (CADDR !#L)) (SETQ IN!:LOW!:BOUND (LIST (LIST 'LAMBDA '(!#LOW !#HIGH) '(SUBSTR !#STRING !#LOW (DIFFERENCE !#HIGH !#LOW))) (LIST 'SUB1 (LIST 'MAX 1 LOWEXP)) HIEXP)) (SETQ INNER!:INF!:BOUND (LIST (LIST 'LAMBDA '(INF) IN!:LOW!:BOUND) '(FLATSIZE2 !#STRING))) (SETQ OUTER!:STRING!:BOUND (LIST (LIST 'LAMBDA '(!#STRING) INNER!:INF!:BOUND) STREXP)) (RETURN OUTER!:STRING!:BOUND))) (DM PUSHES (!#X) NIL) (DM PUSHVARS (!#X) NIL) (DM SLIST (!#X) (CONS 'LIST (CDR !#X))) (DM SAI!-MAPC (!#L) (LIST 'MAPC (CADDR !#L) (CADR !#L))) (DM SAI!-EQU (!#L) (CONS 'EQUAL (CDR !#L))) |
Added psl-1983/3-1/util/zpedit.build version [a53a3976fc].
> > | 1 2 | CompileTime load(ZBoot, ZBasic, ZMacro); in "zpedit.lsp"$ |
Added psl-1983/3-1/util/zpedit.lsp version [8c7739dd3b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZPEDIT contains two packages -- (1) YPP -- a derivative of the ILISP pretty-printer. (2) YEDIT -- a derivative of the ILISP form-oriented editor. ") (!* " YPP -- THE PRETTYPRINTER PP( LST:list ) FEXPR PP1( X:any ) EXPR PP-VAL ( X:id ) EXPR PP-DEF ( X:id ) EXPR SPRINT( X:any COL:number ) EXPR and others... ") (FLUID '(PP!#PROPS PP!#FLAGS PRINTMACRO COMMENTCOL COMMENTFLG CONTOURFLG PPPRINT)) (FLUID '(!#FILE)) (SETQ PP!#PROPS '(READMACRO PRINTMACRO)) (SETQ PP!#FLAGS '(FLUID GLOBAL)) (SETQ COMMENTCOL 50) (SETQ COMMENTFLG NIL) (SETQ CONTOURFLG T) (!* "Tell the loader we need ZBasic and ZMacro.") (IMPORTS '(ZBOOT ZBASIC ZMACRO)) (!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (!#X) (PROGN (SPRINT !#X 1) (TERPRI))) (!* "Tell editor to use SPRINT for PP command.") (SETQ PPPRINT 'SPRINT) (PUT 'QUOTE 'PRINTMACRO '!#QUOTE) (PUT '!* 'PRINTMACRO '!#!*) (CDF PP (!#L) (PROGN (MAPC !#L (FUNCTION PP1)) (TERPRI) T)) (DF PPL (!#L) (PROG (!#FILE) (SETQ !#L (APPLY (FUNCTION APPEND) (MAPCAR !#L (FUNCTION ADD!#SELF!#REF)))) (!* "Print the readmacros at the front of the file in a PROGN") (!* "#FILE becomes non-nil when printing to files") (WRS (SETQ !#FILE (WRS NIL))) (COND ((AND !#FILE (MEMQ 'READMACRO PP!#PROPS)) (PROGN (MAPC !#L (FUNCTION FPP!#READMACRO)) (!* "Trick: #FILE is now NIL if readmacros were printed") (COND ((NULL !#FILE) (PROGN (SPRINT ''READMACROS!-LOADED 1) (PRIN2 ")"))))))) (MAPC !#L (FUNCTION PP1)))) (!* "SETCHR is only meaningful in the dec slisp, where it is defined") (CDE SETCHR (CHR FLAGS) NIL) (DE FPP!#READMACRO (!#A) (COND ((GET !#A 'READMACRO) (PROGN (!* "Put the readmacros inside a PROGN") (COND (!#FILE (PROGN (TERPRI) (PRIN2 "(PROGN") (SETQ !#FILE NIL)))) (SPRINT (LIST 'SETCHR (LIST 'QUOTE !#A) (SETCHR !#A NIL)) 2))))) (DE PP1 (!#EXP) (PROG NIL (TERPRI) (COND ((IDP !#EXP) (PROG (!#PROPS !#FLAGS) (SETQ !#PROPS PP!#PROPS) LP1 (COND (!#PROPS (PROGN (PP!-PROP !#EXP (CAR !#PROPS)) (SETQ !#PROPS (CDR !#PROPS)) (GO LP1)))) (SETQ !#FLAGS PP!#FLAGS) LP2 (COND (!#FLAGS (PROGN (PP!-FLAG !#EXP (CAR !#FLAGS)) (SETQ !#FLAGS (CDR !#FLAGS)) (GO LP2)))) (PP!-VAL !#EXP) (PP!-DEF !#EXP))) (T (PROGN (SPRINT !#EXP 1) (TERPRI)))))) (DE PP!-VAL (!#ID) (PROG (!#VAL) (COND ((ATOM (SETQ !#VAL (ERRORSET !#ID NIL NIL))) (RETURN NIL))) (TERPRI) (PRIN2 "(SETQ ") (PRIN1 !#ID) (S2PRINT " '" (CAR !#VAL)) (PRIN2 ")") (TERPRI))) (DE PP!-DEF (!#ID) (PROG (!#DEF !#TYPE ORIG!#DEF) (SETQ !#DEF (GETD !#ID)) TEST (COND ((NULL !#DEF) (RETURN (AND ORIG!#DEF (WARNING (LIST "Gack. " !#ID " has no unbroken definition."))))) ((ATOM !#DEF) (RETURN (WARNING (LIST "Bad definition for " !#ID " : " !#DEF)))) ((CODEP (CDR !#DEF)) (RETURN (WARNING (LIST "Can't PP compiled def for " !#ID)))) ((NOT (AND (CDR !#DEF) (EQ (CADR !#DEF) 'LAMBDA) (CDDR !#DEF) (CDDDR !#DEF) (NULL (CDDDDR !#DEF)))) (WARNING (LIST !#ID " has ill-formed definition."))) ((AND (NOT ORIG!#DEF) (BROKEN !#ID)) (PROGN (WARNING (LIST "Note: " !#ID " is broken or traced.")) (SETQ ORIG!#DEF !#DEF) (SETQ !#DEF (GET!#GOOD!#DEF !#ID)) (GO TEST)))) (SETQ !#TYPE (CAR !#DEF)) (TERPRI) (COND ((EQ !#TYPE 'EXPR) (PRIN2 "(DE ")) ((EQ !#TYPE 'FEXPR) (PRIN2 "(DF ")) ((EQ !#TYPE 'MACRO) (PRIN2 "(DM ")) (T (RETURN (WARNING (LIST "Bad fntype for " !#ID " : " !#TYPE))))) (PRIN1 !#ID) (PRIN2 " ") (PRIN1 (CADDR !#DEF)) (MAPC (CDDDR !#DEF) (FUNCTION (LAMBDA (!#X) (S2PRINT " " !#X)))) (PRIN2 ")") (TERPRI))) (DE BROKEN (!#X) (GET !#X 'TRACE)) (DE GET!#GOOD!#DEF (!#X) (PROG (!#XX!#) (COND ((AND (SETQ !#XX!# (GET !#X 'TRACE)) (IDP (SETQ !#XX!# (CDR !#XX!#)))) (RETURN (GETD !#XX!#)))))) (DE PP!-PROP (!#ID !#PROP) (PROG (!#VAL) (COND ((NULL (SETQ !#VAL (GET !#ID !#PROP))) (RETURN NIL))) (TERPRI) (PRIN2 "(PUT '") (PRIN1 !#ID) (PRIN2 " '") (PRIN1 !#PROP) (S2PRINT " '" !#VAL) (PRIN2 ")") (TERPRI))) (DE PP!-FLAG (!#ID !#FLAG) (PROG NIL (COND ((NULL (FLAGP !#ID !#FLAG)) (RETURN NIL))) (TERPRI) (PRIN2 "(FLAG '(") (PRIN1 !#ID) (PRIN2 ") '") (PRIN1 !#FLAG) (PRIN2 ")") (TERPRI))) (DE ADD!#SELF!#REF (!#ID) (PROG (!#L) (COND ((NOT (MEMQ !#ID (SETQ !#L (EVAL !#ID)))) (PROGN (RPLACD !#L (CONS (CAR !#L) (CDR !#L))) (RPLACA !#L !#ID)))) (RETURN !#L))) (!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (!#S !#EXP) (PROGN (OR (GREATERP (SPACES!#LEFT) (PLUS (FLATSIZE2 !#S) (FLATSIZE !#EXP))) (TERPRI)) (PRIN2 !#S) (SPRINT !#EXP (ADD1 (POSN))))) (DE SPRINT (!#EXP LEFT!#MARGIN) (PROG (ORIGINAL!#SPACE NEW!#SPACE CAR!#EXP P!#MACRO CADR!#MARGIN ELT!#MARGIN LBL!#MARGIN !#SIZE) (COND ((ATOM !#EXP) (PROGN (SAFE!#PPOS LEFT!#MARGIN (FLATSIZE !#EXP)) (RETURN (PRIN1 !#EXP))))) (PPOS LEFT!#MARGIN) (SETQ LEFT!#MARGIN (ADD1 LEFT!#MARGIN)) (SETQ ORIGINAL!#SPACE (SPACES!#LEFT)) (COND ((PAIRP (SETQ CAR!#EXP (CAR !#EXP))) (PROGN (PRIN2 "(") (SPRINT CAR!#EXP LEFT!#MARGIN))) ((AND (IDP CAR!#EXP) (SETQ P!#MACRO (GET CAR!#EXP 'PRINTMACRO))) (COND ((STRINGP P!#MACRO) (PROGN (SAFE!#PPOS (POSN1) (FLATSIZE2 P!#MACRO)) (PRIN2 P!#MACRO) (RETURN (AND (CDR !#EXP) (SPRINT (CADR !#EXP) (POSN1)))))) (T (PROGN (SETQ PRINTMACRO NIL) (SETQ !#EXP (APPLY P!#MACRO (LIST !#EXP))) (COND ((NULL PRINTMACRO) (RETURN NIL)) ((ATOM PRINTMACRO) (PROGN (SETQ CAR!#EXP PRINTMACRO) (PRIN2 "(") (SPRINT (CAR !#EXP) LEFT!#MARGIN))) (T (PROGN (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (CDR PRINTMACRO))) (SETQ LBL!#MARGIN (COND ((EQ (CAR PRINTMACRO) 'PROG) LEFT!#MARGIN) (T CADR!#MARGIN))) (GO B)))))))) (T (PROGN (PRIN2 "(") (SAFE!#PPOS (POSN1) (FLATSIZE CAR!#EXP)) (PRIN1 CAR!#EXP)))) (COND ((ATOM (SETQ !#EXP (CDR !#EXP))) (GO C))) (SETQ CADR!#MARGIN (POSN2)) (SETQ NEW!#SPACE (SPACES!#LEFT)) (SETQ !#SIZE (PPFLATSIZE CAR!#EXP)) (COND ((NOT (LESSP !#SIZE ORIGINAL!#SPACE)) (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) ((EQ CAR!#EXP '!*) (PROGN (SETQ LEFT!#MARGIN (SETQ CADR!#MARGIN (PLUS LEFT!#MARGIN 2))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN NIL)))) ((OR (LESSP (PPFLATSIZE !#EXP) NEW!#SPACE) (PROG (!#E1) (SETQ !#E1 !#EXP) LP (COND ((PAIRP (CAR !#E1)) (RETURN NIL)) ((ATOM (SETQ !#E1 (CDR !#E1))) (RETURN T)) (T (GO LP))))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN NIL))) ((LESSP NEW!#SPACE 24) (PROGN (COND ((NOT (AND (MEMQ CAR!#EXP '(SETQ LAMBDA PROG SELECTQ SET)) (LESSP (PPFLATSIZE (CAR !#EXP)) NEW!#SPACE))) (SETQ CADR!#MARGIN LEFT!#MARGIN))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) ((EQ CAR!#EXP 'LAMBDA) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN))) ((EQ CAR!#EXP 'PROG) (PROGN (SETQ ELT!#MARGIN CADR!#MARGIN) (SETQ LBL!#MARGIN LEFT!#MARGIN))) ((OR (GREATERP !#SIZE 14) (AND (GREATERP !#SIZE 4) (NOT (LESSP (PPFLATSIZE (CAR !#EXP)) NEW!#SPACE)))) (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) (T (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN CADR!#MARGIN)))) (COND ((ATOM (SETQ CAR!#EXP (CAR !#EXP))) (PROGN (SAFE!#PPOS CADR!#MARGIN (PPFLATSIZE CAR!#EXP)) (PRIN1 CAR!#EXP))) (T (SPRINT CAR!#EXP CADR!#MARGIN))) A (COND ((ATOM (SETQ !#EXP (CDR !#EXP))) (GO C))) B (SETQ CAR!#EXP (CAR !#EXP)) (COND ((ATOM CAR!#EXP) (PROGN (SETQ !#SIZE (PPFLATSIZE CAR!#EXP)) (COND (LBL!#MARGIN (SAFE!#PPOS LBL!#MARGIN !#SIZE)) ((LESSP !#SIZE (SPACES!#LEFT)) (PRIN2 " ")) (T (SAFE!#PPOS LEFT!#MARGIN !#SIZE))) (PRIN1 CAR!#EXP))) (T (SPRINT CAR!#EXP (COND (ELT!#MARGIN ELT!#MARGIN) (T (POSN2))))) ) (GO A) C (COND (!#EXP (PROGN (COND ((LESSP (SPACES!#LEFT) 3) (PPOS LEFT!#MARGIN))) (PRIN2 " . ") (SETQ !#SIZE (PPFLATSIZE !#EXP)) (COND ((GREATERP !#SIZE (SPACES!#LEFT)) (SAFE!#PPOS LEFT!#MARGIN !#SIZE))) (PRIN1 !#EXP)))) (COND ((LESSP (SPACES!#LEFT) 1) (PPOS LEFT!#MARGIN))) (PRIN2 ")"))) (DE SPRIN1 (!#EXP !#C1 !#C2) (PROG (!#ROOM) (SETQ !#ROOM (DIFFERENCE (LINELENGTH NIL) !#C1)) (COND ((GREATERP (PLUS (FLATSIZE !#EXP) 3) !#ROOM) (COND ((NULL (STRINGP !#EXP)) (SPRINT !#EXP !#C2)) ((FIRSTLINE!-FITS !#EXP !#ROOM) (PROGN (PPOS !#C1) (PRIN1 !#EXP))) (T (PROGN (TERPRI) (PRIN1 !#EXP))))) (T (SPRINT !#EXP !#C1))))) (DE SPRINL (!#EXP !#C1 !#C2) (PROG (!#SIZE) (COND ((ATOM !#EXP) (RETURN (SPRIN1 !#EXP !#C1 !#C2))) (T (PROGN (PPOS !#C1) (PRIN2 "(")))) A (SPRIN1 (CAR !#EXP) (ADD1 !#C1) !#C2) (COND ((NULL (SETQ !#EXP (CDR !#EXP))) (PROGN (COND ((LESSP (SPACES!#LEFT) 1) (PPOS !#C2))) (RETURN (PRIN2 ")")))) ((ATOM !#EXP) (PROGN (COND ((LESSP (SPACES!#LEFT) 3) (PPOS !#C1))) (PRIN2 " . ") (SETQ !#SIZE (ADD1 (PPFLATSIZE !#EXP))) (COND ((GREATERP !#SIZE (SPACES!#LEFT)) (SAFE!#PPOS !#C1 !#SIZE))) (PRIN1 !#EXP) (PRIN2 ")"))) (T (PROGN (SETQ !#C1 (POSN1)) (GO A)))))) (DE !#QUOTE (!#L) (!#QUOTES !#L "'")) (DE !#QUOTES (!#L !#CH) (PROG (!#N) (COND ((ATOM (CDR !#L)) (PROGN (SETQ !#N (POSN1)) (SPRINL !#L !#N (PLUS !#N 3)))) (T (PROGN (PRIN2 !#CH) (SETQ !#N (POSN1)) (SPRIN1 (CADR !#L) !#N !#N)))))) (!* "Addition for PSL, backquote and friends.") (PUT 'BACKQUOTE 'PRINTMACRO '!#BACKQUOTE) (DE !#BACKQUOTE (!#L) (!#QUOTES !#L "`")) (PUT 'UNQUOTE 'PRINTMACRO '!#UNQUOTE) (DE !#UNQUOTE (!#L) (!#QUOTES !#L ",")) (PUT 'UNQUOTEL 'PRINTMACRO '!#UNQUOTEL) (DE !#UNQUOTEL (!#L) (!#QUOTES !#L ",@")) (PUT 'UNQUOTED 'PRINTMACRO '!#UNQUOTED) (DE !#UNQUOTED (!#L) (!#QUOTES !#L ",.")) (DE !#!* (!#L) (PROG (!#F !#N) (COND ((ATOM (CDR !#L)) (RETURN (SPRINL !#L (SETQ !#N (POSN1)) (PLUS !#N 3))))) (!* COND ((EQ (CADR !#L) 'E) (EVAL (CADDR !#L)))) (WRS (SETQ !#F (WRS NIL))) (COND ((OR !#F COMMENTFLG) (SPRINL !#L (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) (PLUS (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) 3))) (T (PRIN2 "(* ...)"))))) (!* DE SPRINL (!#EXP !#C1 !#C2) (PROG NIL (COND ((ATOM !#EXP) (RETURN (SPRIN1 !#EXP !#C1 !#C2))) (T (PROGN (PPOS !#C1) (PRIN2 "(")))) A (SPRIN1 (CAR !#EXP) (ADD1 !#C1) !#C2) (COND ((NULL (SETQ !#EXP (CDR !#EXP))) (PROGN (COND ((LESSP (SPACES!#LEFT) 1) (PPOS !#C2))) (RETURN (PRIN2 ")")))) (T (PROGN (SETQ !#C1 (POSN1)) (GO A)))))) (!* DE !#QUOTE (!#L) (PROG (!#N) (COND ((NUMBERP (CADR !#L)) (SPRINL !#L (SETQ !#N (POSN1)) (PLUS !#N 3))) (T (PROGN (PRIN2 "'") (SETQ !#N (POSN1)) (SPRIN1 (CADR !#L) !#N !#N)))))) (!* DE !#!* (!#L) (PROG (!#F) (COND ((EQ (CADR !#L) 'E) (EVAL (CADDR !#L)))) (WRS (SETQ !#F (WRS NIL))) (COND ((OR !#F COMMENTFLG) (SPRINL !#L (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) (PLUS (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) 3))) (T (PRIN2 "(* ...)"))))) (DE PRINCOMMA (!#LIST FIRST!#COL) (COND (!#LIST (PROGN (PRIN2 (CAR !#LIST)) (MAPC (CDR !#LIST) (FUNCTION (LAMBDA (ELT) (PROGN (PRIN2 ", ") (COND ((LESSP (SPACES!#LEFT) (PLUS 2 (FLATSIZE2 ELT))) (PROGN (TERPRI) (PPOS FIRST!#COL)))) (PRIN2 ELT))))) (PRIN2 "."))))) (CDE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES!#LEFT NIL (SUB1 (CHRCT))) (DE SAFE!#PPOS (!#N !#SIZE) (PROG (MIN!#N) (SETQ MIN!#N (SUB1 (DIFFERENCE (LINELENGTH NIL) !#SIZE))) (COND ((LESSP MIN!#N !#N) (PROGN (OR (GREATERP MIN!#N (POSN1)) (TERPRI)) (PPOS MIN!#N))) (T (PPOS !#N))))) (DE PPFLATSIZE (!#EXP) (DIFFERENCE (FLATSIZE !#EXP) (PP!#SAVINGS !#EXP))) (DE PP!#SAVINGS (Y) (PROG (N) (COND ((ATOM Y) (RETURN 0)) ((AND (EQ (CAR Y) 'QUOTE) (CDR Y) (NOT (NUMBERP (CADR Y)))) (RETURN (PLUS 7 (PP!#SAVINGS (CDR Y)))))) (SETQ N 0) LP (COND ((ATOM Y) (RETURN N))) (SETQ N (PLUS N (PP!#SAVINGS (CAR Y)))) (SETQ Y (CDR Y)) (GO LP))) (DE FIRSTLINE!-FITS (!#STR !#N) (PROG (!#BIG) (!* "This addition is an empirical hack") (SETQ !#N (PLUS2 !#N 2)) (SETQ !#BIG (EXPLODE !#STR)) LP (COND ((EQ (CAR !#BIG) !$EOL!$) (RETURN T)) ((NULL (SETQ !#BIG (CDR !#BIG))) (RETURN T)) ((ZEROP (SETQ !#N (SUB1 !#N))) (RETURN NIL))) (GO LP))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) (!* " YEDIT -- THE EDITOR " " Originally from ilisp editor -- see zedit.doc for evolution. EDITF (X) FEXPR EDITFNS (X) FEXPR EDITV (X) FEXPR EDITP (X) FEXPR EDITE (EXPR COMS ATM) EXPR ") (!* "Due to deficiency in standard-lisp") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "G!:EDIT!:ERRORS and G!:EDIT!:TRACE switch editor errorset args on/off") (GLOBAL '(G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (!* " Global to editor") (FLUID '(F!:E!#LOOKDPTH F!:E!#TRACEFLG F!:E!#LAST!#ID F!:E!#MAXLEVEL F!:E!#UPFINDFLG F!:E!#MAXLOOP F!:E!#EDITCOMSL F!:E!#USERMACROS F!:E!#MACROS F!:E!#OPS F!:E!#MAX!#PLENGTH)) (!* " Fluid in editor, but initialized to non-NIL at top level") (FLUID '(F!:E!#DEPTH)) (!* " Fluid in editor ") (FLUID '(F!:E!#LOCLST F!:E!#LOCLST!#0 F!:E!#MARKLST F!:E!#UNDOLST F!:E!#UNDOLST!#1 F!:E!#OLDPROMPT F!:E!#ID F!:E!#INBUF F!:E!#CMD F!:E!#UNFIND F!:E!#FINDFLAG F!:E!#COM0 F!:E!#TOPFLG F!:E!#COPYFLG F!:E!#LASTP1 F!:E!#LASTP2 F!:E!#LCFLG F!:E!#LASTAIL F!:E!#SN F!:E!#TOFLG F!:E!#1 F!:E!#2 F!:E!#3)) (!* "EDITLINEREAD():list EXPR ------------ Prints a supplementary prompt before the READ generated prompt. Reads a line of input containing a series of LISP expressions. But the several expressions on the line must be separated by spaces or commas and terminated with a bare CR. ") (FLUID '(PROMPTSTRING!*)) (DE EDITLINEREAD NIL (PROG (!#NEXT !#RES PROMPTSTRING!*) (!* "PromptString!* for PSL (EAB 2:08am Friday, 6 November 1981)") (SETQ PROMPTSTRING!* "-E- ") (!* (PRIN2 "-E-")) (TERPRI) LOOP (SETQ !#RES (NCONC !#RES (LIST (READ)))) (COND ((NOT (MEMQ (SETQ !#NEXT (READCH)) '(!, ! ))) (RETURN !#RES)) (T (GO LOOP))))) (DM EDIT!#!# (!#X) (LIST 'EDIT!#!#DE (MKQUOTE (CDR !#X)))) (DE EDIT!#!#DE (!#COMS) ((LAMBDA (F!:E!#LOCLST F!:E!#UNDOLST!#1) (EDITCOMS !#COMS)) F!:E!#LOCLST NIL)) (DF EDITFNS (!#X) (PROG (!#Y) (SETQ !#Y (EVAL (CAR !#X))) LP (COND ((NULL !#Y) (RETURN NIL))) (ERRORSET (CONS 'EDITF (CONS (PRIN1 (CAR !#Y)) (CDR !#X))) G!:EDIT!:ERRORS G!:EDIT!:TRACE) (SETQ !#Y (CDR !#Y)) (GO LP))) (DF EDITF (!#X) (PROG (!#Y !#FN) (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((IDP (CAR !#X)) (PROGN (COND ((SETQ !#Y (GET (SETQ !#FN (CAR !#X)) 'TRACE)) (SETQ !#FN (CDR !#Y)))) (COND ((SETQ !#Y (GETD !#FN)) (PROGN (RPLACD !#Y (EDITE (CDR !#Y) (CDR !#X) (CAR !#X))) (RETURN (SETQ F!:E!#LAST!#ID (CAR !#X))))) ((AND (SETQ !#Y (GET !#FN 'VALUE)) (PAIRP (CDR !#Y))) (GO L1))))) ((PAIRP (CAR !#X)) (GO L1))) (PRIN1 (CAR !#X)) (PRIN2 " not editable.") (ERROR NIL NIL) L1 (PRINT2 "=EDITV") (RETURN (EVAL (CONS 'EDITV !#X))))) (DF EDITV (!#X) (PROG (!#Y) (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((PAIRP (CAR !#X)) (PROGN (EDITE (EVAL (CAR !#X)) (CDR !#X) NIL) (RETURN T))) ((AND (IDP (CAR !#X)) (PAIRP (ERRORSET (CAR !#X) G!:EDIT!:ERRORS G!:EDIT!:TRACE))) (PROGN (SET (CAR !#X) (EDITE (EVAL (CAR !#X)) (CDR !#X) (CAR !#X))) (RETURN (SETQ F!:E!#LAST!#ID (CAR !#X))))) (T (PROGN (TERPRI) (PRIN1 (CAR !#X)) (PRIN2 " not editable") (ERROR NIL NIL)))))) (!* "For PSL, the BREAK function uses an EXPR, EDIT. I don't know how else to edit a form but to call the FEXPR EDITV.") (FLUID '(EDIT!:FORM)) (DE EDIT (EDIT!:FORM) (PROGN (EDITV EDIT!:FORM) EDIT!:FORM)) (DF EDITP (!#X) (PROGN (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((PAIRP (CAR !#X)) (PROGN (PRIN2 "=EDITV") (EVAL (CONS 'EDITV !#X)))) ((IDP (CAR !#X)) (PROGN (!* "For PSL, changed (CDAR !#X) to (PROP (CAR !#X))") (EDITE (PROP (CAR !#X)) (CDR !#X) (CAR !#X)) (SETQ F!:E!#LAST!#ID (CAR !#X)))) (T (PROGN (TERPRI) (PRIN1 (CAR !#X)) (PRIN2 " not editable.") (ERROR NIL NIL)))))) (DE EDITE (!#EXPR !#COMS !#ATM) (COND ((NULL (PAIRP !#EXPR)) (PROGN (PRINT !#EXPR) (PRIN2 " not editable.") (ERROR NIL NIL))) (T (CAR (LAST (EDITL (LIST !#EXPR) !#COMS !#ATM NIL NIL)))))) (DE EDITL (F!:E!#LOCLST !#COMS !#ATM F!:E!#MARKLST !#MESS) (PROG (F!:E!#CMD F!:E!#LASTAIL F!:E!#UNDOLST F!:E!#UNDOLST!#1 F!:E!#FINDFLAG F!:E!#LCFLG F!:E!#UNFIND F!:E!#LASTP1 F!:E!#LASTP2 F!:E!#INBUF F!:E!#LOCLST!#0 F!:E!#COM0 F!:E!#OLDPROMPT) (SETQ F!:E!#LOCLST (ERRORSET (LIST 'EDITL0 (ADD1 F!:E!#DEPTH) (MKQUOTE !#COMS) (MKQUOTE !#MESS) (MKQUOTE !#ATM)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((PAIRP F!:E!#LOCLST) (RETURN (CAR F!:E!#LOCLST))) (T (ERROR NIL NIL))))) (DE EDITL0 (F!:E!#DEPTH !#COMS !#MESS F!:E!#ID) (PROG (!#RES) (COND ((NULL !#COMS) NIL) ((EQ (CAR !#COMS) 'START) (SETQ F!:E!#INBUF (CDR !#COMS))) ((PAIRP (ERRORSET (LIST 'EDIT1 (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (RETURN F!:E!#LOCLST)) (T (ERROR NIL NIL))) (TERPRI) (PRINT2 (OR !#MESS "EDIT")) (COND ((OR (EQ (CAR F!:E!#LOCLST) (CAR (LAST (CAR (COND ((SETQ F!:E!#CMD (GET 'EDIT 'LASTVALUE)) F!:E!#CMD) (T '((NIL)))))))) (AND F!:E!#ID (EQ (CAR F!:E!#LOCLST) (CAR (LAST (CAR (COND ((SETQ F!:E!#CMD (GET F!:E!#ID 'EDIT!-SAVE)) F!:E!#CMD) (T '((NIL)))))))))) (PROGN (SETQ F!:E!#LOCLST (CAR F!:E!#CMD)) (SETQ F!:E!#MARKLST (CADR F!:E!#CMD)) (SETQ F!:E!#UNDOLST (CADDR F!:E!#CMD)) (COND ((CAR F!:E!#UNDOLST) (SETQ F!:E!#UNDOLST (CONS NIL F!:E!#UNDOLST)))) (SETQ F!:E!#UNFIND (CDDDR F!:E!#CMD))))) LP (SETQ !#RES (ERRORSET '(EDITL1) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'OK) (RETURN F!:E!#LOCLST)) ((EQ !#RES 'STOP) (ERROR 'STOP NIL)) (T (GO LP))))) (DE EDIT1 (!#COMS) (PROG (!#X) (SETQ !#X !#COMS) L1 (COND ((NULL !#X) (RETURN NIL))) (EDITCOM (SETQ F!:E!#CMD (CAR !#X)) NIL) (SETQ !#X (CDR !#X)) (GO L1))) (DE EDITVAL (!#X) (PROG (!#RES) (SETQ !#RES (ERRORSET !#X G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (AND !#RES (ATOM !#RES) (ERROR !#RES NIL)) (RETURN !#RES))) (DE EDITL1 NIL (PROG (!#RES) CT (SETQ F!:E!#FINDFLAG NIL) (COND ((NULL F!:E!#OLDPROMPT) (SETQ F!:E!#OLDPROMPT (CONS F!:E!#DEPTH '!#)))) A (SETQ F!:E!#UNDOLST!#1 NIL) (SETQ F!:E!#CMD (EDITREAD)) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ F!:E!#COM0 (COND ((ATOM F!:E!#CMD) F!:E!#CMD) (T (CAR F!:E!#CMD)))) (SETQ !#RES (ERRORSET (LIST 'EDITCOM (MKQUOTE F!:E!#CMD) T) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'OK) (ERROR 'OK NIL)) ((EQ !#RES 'STOP) (ERROR 'STOP NIL)) (F!:E!#UNDOLST!#1 (PROGN (SETQ F!:E!#UNDOLST!#1 (CONS F!:E!#COM0 (CONS F!:E!#LOCLST!#0 F!:E!#UNDOLST!#1))) (SETQ F!:E!#UNDOLST (CONS F!:E!#UNDOLST!#1 F!:E!#UNDOLST))))) (COND ((PAIRP !#RES) (GO A))) (SETQ F!:E!#INBUF NIL) (TERPRI) (COND (F!:E!#CMD (PROGN (PRIN1 F!:E!#CMD) (PRIN2 " ?")))) (GO CT))) (DE EDITREAD NIL (PROG (!#X) (COND ((NULL F!:E!#INBUF) (PROG NIL LP (TERPRI) (COND ((NOT (EQUAL (CAR F!:E!#OLDPROMPT) 0)) (PRIN2 (CAR F!:E!#OLDPROMPT)))) (SETQ F!:E!#INBUF (ERRORSET '(EDITLINEREAD) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((ATOM F!:E!#INBUF) (PROGN (TERPRI) (GO LP)))) (SETQ F!:E!#INBUF (CAR F!:E!#INBUF))))) (SETQ !#X (CAR F!:E!#INBUF)) (SETQ F!:E!#INBUF (CDR F!:E!#INBUF)) (RETURN !#X))) (DE EDITCOM (!#CMD F!:E!#TOPFLG) (PROGN (SETQ F!:E!#CMD !#CMD) (COND (F!:E!#TRACEFLG (EDITRACEFN !#CMD))) (COND (F!:E!#FINDFLAG (COND ((EQ F!:E!#FINDFLAG 'BF) (PROGN (SETQ F!:E!#FINDFLAG NIL) (EDITBF !#CMD NIL))) (T (PROGN (SETQ F!:E!#FINDFLAG NIL) (EDITQF !#CMD))))) ((NUMBERP !#CMD) (SETQ F!:E!#LOCLST (EDIT1F !#CMD F!:E!#LOCLST))) ((ATOM !#CMD) (EDITCOMA !#CMD (NULL F!:E!#TOPFLG))) (T (EDITCOML !#CMD (NULL F!:E!#TOPFLG)))) (CAR F!:E!#LOCLST))) (DE EDITCOMA (!#CMD F!:E!#COPYFLG) (PROG (!#TEM) (SELECTQ !#CMD (NIL NIL) (OK (COND (F!:E!#ID (REMPROP F!:E!#ID 'EDIT!-SAVE))) (PUT 'EDIT 'LASTVALUE (CONS (LAST F!:E!#LOCLST) (CONS F!:E!#MARKLST (CONS F!:E!#UNDOLST F!:E!#LOCLST)))) (ERROR 'OK NIL)) (STOP (ERROR 'STOP NIL)) (SAVE (COND (F!:E!#ID (PUT 'EDIT 'LASTVALUE (PUT F!:E!#ID 'EDIT!-SAVE (CONS F!:E!#LOCLST (CONS F!:E!#MARKLST (CONS F!:E!#UNDOLST F!:E!#UNFIND))))))) (ERROR 'OK NIL)) (TTY!: (SETQ F!:E!#CMD F!:E!#COM0) (SETQ F!:E!#LOCLST (EDITL F!:E!#LOCLST NIL NIL NIL 'TTY!:))) (E (COND (F!:E!#TOPFLG (COND ((PAIRP (SETQ !#TEM (EDITVAL (EDITREAD)))) (EDIT!#PRINT (CAR !#TEM) F!:E!#LOOKDPTH NIL))) ) (T (PROGN (EDITQF !#CMD) T)))) (P (EDITBPNT0 (CAR F!:E!#LOCLST) 2)) (!? (EDITBPNT0 (CAR F!:E!#LOCLST) 100)) (PP (EDITBPNT0 (CAR F!:E!#LOCLST) NIL)) (!^ (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (LAST F!:E!#LOCLST))) (!@0 (COND ((NULL (CDR F!:E!#LOCLST)) (ERROR NIL NIL))) (PROG NIL LP (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST)) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (GO LP))))) (MARK (SETQ F!:E!#MARKLST (CONS F!:E!#LOCLST F!:E!#MARKLST))) (UNDO (EDITUNDO F!:E!#TOPFLG NIL (COND (F!:E!#INBUF (EDITREAD))))) (TEST (SETQ F!:E!#UNDOLST (CONS NIL F!:E!#UNDOLST))) (!@UNDO (EDITUNDO T T NIL)) (UNBLOCK (COND ((SETQ !#TEM (MEMQ NIL F!:E!#UNDOLST)) (EDITSMASH !#TEM (LIST NIL) (CDR !#TEM))) (T (PRINT2 " not blocked")))) (!_ (COND (F!:E!#MARKLST (PROGN (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (CAR F!:E!#MARKLST)))) (T (ERROR NIL NIL)))) (!\ (COND (F!:E!#UNFIND (PROGN (SETQ !#CMD F!:E!#LOCLST) (SETQ F!:E!#LOCLST F!:E!#UNFIND) (AND (CDR !#CMD) (SETQ F!:E!#UNFIND !#CMD)))) (T (ERROR NIL NIL)))) (!\P (COND ((AND F!:E!#LASTP1 (NOT (EQ F!:E!#LASTP1 F!:E!#LOCLST))) (SETQ F!:E!#LOCLST F!:E!#LASTP1)) ((AND F!:E!#LASTP2 (NOT (EQ F!:E!#LASTP2 F!:E!#LOCLST))) (SETQ F!:E!#LOCLST F!:E!#LASTP2)) (T (ERROR NIL NIL)))) (!_!_ (COND (F!:E!#MARKLST (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (SETQ F!:E!#LOCLST (CAR F!:E!#MARKLST)) (SETQ F!:E!#MARKLST (CDR F!:E!#MARKLST)))) (T (ERROR NIL NIL)))) ((F BF) (COND ((NULL F!:E!#TOPFLG) (PROGN (SETQ F!:E!#FINDFLAG !#CMD) (RETURN NIL))) (T (PROGN (SETQ !#TEM (EDITREAD)) (SELECTQ !#CMD (F (EDITQF !#TEM)) (BF (EDITBF !#TEM NIL)) (ERROR NIL NIL)))))) (UP (EDITUP)) (DELETE (SETQ !#CMD '(DELETE)) (EDIT!: '!: NIL NIL)) (NX (EDIT!* 1)) (BK (EDIT!* -1)) (!@NX (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROG (!#UF) (SETQ !#UF F!:E!#LOCLST) LP (COND ((OR (NULL (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (NULL (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((OR (NULL (SETQ !#TEM (MEMQ (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)))) (NULL (CDR !#TEM))) (GO LP))) (EDITCOM 'NX NIL) (SETQ F!:E!#UNFIND !#UF) (RETURN F!:E!#LOCLST))) F!:E!#LOCLST))) (!?!? (EDITH F!:E!#UNDOLST)) (COND ((AND (NULL (SETQ !#TEM (EDITMAC !#CMD F!:E!#MACROS NIL))) (NULL (SETQ !#TEM (EDITMAC !#CMD F!:E!#USERMACROS NIL)))) (RETURN (EDITDEFAULT !#CMD))) (T (EDITCOMS (COPY (CDR !#TEM)))))))) (DE EDITCOML (!#CMD F!:E!#COPYFLG) (PROG (!#C2 !#C3 !#TEM) LP (COND ((PAIRP (CDR !#CMD)) (PROGN (SETQ !#C2 (CADR !#CMD)) (COND ((PAIRP (CDDR !#CMD)) (SETQ !#C3 (CADDR !#CMD))))))) (COND ((AND F!:E!#LCFLG (SELECTQ !#C2 ((TO THRU THROUGH) (COND ((NULL (CDDR !#CMD)) (PROGN (SETQ !#C3 -1) (SETQ !#C2 'THRU)))) T) NIL)) (PROGN (EDITTO (CAR !#CMD) !#C3 !#C2) (RETURN NIL))) ((NUMBERP (CAR !#CMD)) (PROGN (EDIT2F (CAR !#CMD) (CDR !#CMD)) (RETURN NIL))) ((EQ !#C2 '!:!:) (PROGN (EDITCONT (CAR !#CMD) (CDDR !#CMD)) (RETURN NIL)))) (SELECTQ (CAR !#CMD) (S (SET !#C2 (COND ((NULL !#C2) (ERROR NIL NIL)) (T ((LAMBDA (F!:E!#LOCLST) (EDITLOC (CDDR !#CMD))) F!:E!#LOCLST))))) (R (SETQ !#C2 (EDITNEWC2 (LIST (CAR F!:E!#LOCLST)) !#C2)) (EDITDSUBST !#C3 !#C2 (CAR F!:E!#LOCLST))) (E (SETQ !#TEM (EVAL !#C2)) (COND ((NULL (CDDR !#CMD)) (PRINT !#TEM))) (RETURN !#TEM)) (I (SETQ !#CMD (CONS (COND ((ATOM !#C2) !#C2) (T (EVAL !#C2))) (MAPCAR (CDDR !#CMD) (FUNCTION (LAMBDA (X) (COND (F!:E!#TOPFLG (PRINT (EVAL X))) (T (EVAL X)))))))) (SETQ F!:E!#COPYFLG NIL) (GO LP)) (N (COND ((ATOM (CAR F!:E!#LOCLST)) (ERROR NIL NIL))) (EDITNCONC (CAR F!:E!#LOCLST) (COND (F!:E!#COPYFLG (COPY (CDR !#CMD))) (T (APPEND (CDR !#CMD) NIL))))) (P (COND ((NOT (EQ F!:E!#LASTP1 F!:E!#LOCLST)) (PROGN (SETQ F!:E!#LASTP2 F!:E!#LASTP1) (SETQ F!:E!#LASTP1 F!:E!#LOCLST)))) (EDITBPNT (CDR !#CMD))) (F (EDIT4F !#C2 !#C3)) (FS (PROG NIL L1 (COND ((SETQ !#CMD (CDR !#CMD)) (PROGN (EDITQF (SETQ F!:E!#CMD (CAR !#CMD))) (GO L1)))))) (F!= (EDIT4F (CONS '!=!= !#C2) !#C3)) (ORF (EDIT4F (CONS '!*ANY!* (CDR !#CMD)) 'N)) (BF (EDITBF !#C2 !#C3)) (NTH (COND ((NOT (EQ (SETQ !#TEM (EDITNTH (CAR F!:E!#LOCLST) !#C2)) (CAR F!:E!#LOCLST))) (SETQ F!:E!#LOCLST (CONS !#TEM F!:E!#LOCLST))))) (IF (COND ((AND (PAIRP (SETQ !#TEM (EDITVAL !#C2))) (CAR !#TEM)) (COND ((CDR !#CMD) (EDITCOMS !#C3)))) ((AND (CDDR !#CMD) (CDDDR !#CMD)) (EDITCOMS (CADDDR !#CMD))) (T (ERROR NIL NIL)))) (BI (EDITBI !#C2 (COND ((CDDR !#CMD) !#C3) (T !#C2)) (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (RI (EDITRI !#C2 !#C3 (AND (CDR !#CMD) (CDDR !#CMD) (CAR F!:E!#LOCLST)))) (RO (EDITRO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (LI (EDITLI !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (LO (EDITLO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (BO (EDITBO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (M (EDITM !#CMD !#C2)) (NX (EDIT!* !#C2)) (BK (EDIT!* (MINUS !#C2))) (ORR (EDITOR (CDR !#CMD))) (MBD (EDITMBD NIL (CDR !#CMD))) (XTR (EDITXTR NIL (CDR !#CMD))) ((THRU TO) (EDITTO NIL !#C2 (CAR !#CMD))) ((A B !: AFTER BEFORE) (EDIT!: (CAR !#CMD) NIL (CDR !#CMD))) (MV (EDITMV NIL (CADR !#CMD) (CDDR !#CMD))) ((LP LPQ) (EDITRPT (CDR !#CMD) (EQ (CAR !#CMD) 'LPQ))) (LC (EDITLOC (CDR !#CMD))) (LCL (EDITLOCL (CDR !#CMD))) (!_ (SETQ F!:E!#LOCLST (EDITNEWLOCLST F!:E!#LOCLST !#C2))) (BELOW (EDITBELOW !#C2 (COND ((CDDR !#CMD) !#C3) (T 1)))) (SW (EDITSW (CADR !#CMD) (CADDR !#CMD))) (BIND (PROG (F!:E!#1 F!:E!#2 F!:E!#3) (EDITCOMS (CDR !#CMD)))) (COMS (PROG NIL L1 (COND ((SETQ !#CMD (CDR !#CMD)) (PROGN (EDITCOM (SETQ F!:E!#CMD (EVAL (CAR !#CMD))) NIL) (GO L1)))))) (COMSQ (EDITCOMS (CDR !#CMD))) (COND ((AND (NULL (SETQ !#TEM (EDITMAC (CAR !#CMD) F!:E!#MACROS T))) (NULL (SETQ !#TEM (EDITMAC (CAR !#CMD) F!:E!#USERMACROS T)))) (RETURN (EDITDEFAULT !#CMD))) ((NOT (ATOM (SETQ !#C3 (CAR !#TEM)))) (EDITCOMS (SUBLIS (PAIR !#C3 (CDR !#CMD)) (CDR !#TEM)))) (T (EDITCOMS (SUBST (CDR !#CMD) !#C3 (CDR !#TEM)))))))) (DE EDITNEWC2 (F!:E!#LOCLST !#C2) (PROGN (EDIT4F !#C2 T) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (COND ((AND (ATOM !#C2) F!:E!#UPFINDFLG (PAIRP (CAR F!:E!#LOCLST))) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST))))) (DE EDITM (!#CMD !#C2) (PROG (!#NEWMACRO !#TEM) (COND ((ATOM !#C2) (COND ((SETQ !#TEM (EDITMAC !#C2 F!:E!#USERMACROS NIL)) (PROGN (RPLACD !#TEM (CDDR !#CMD)) (RETURN NIL))) (T (SETQ !#NEWMACRO (CONS !#C2 (CONS NIL (CDDR !#CMD))))))) ((SETQ !#TEM (EDITMAC (CAR !#C2) F!:E!#USERMACROS T)) (PROGN (RPLACA !#TEM (CADDR !#CMD)) (RPLACD !#TEM (CDDDR !#CMD)) (RETURN NIL))) (T (PROGN (NCONC F!:E!#EDITCOMSL (LIST (CAR !#C2))) (SETQ !#NEWMACRO (CONS (CAR !#C2) (CDDR !#CMD)))))) (SETQ F!:E!#USERMACROS (CONS !#NEWMACRO F!:E!#USERMACROS)))) (DE EDITNEWLOCLST (F!:E!#LOCLST !#C2) (PROG (!#UF !#TEM) (SETQ !#UF F!:E!#LOCLST) (SETQ !#C2 (EDITFPAT !#C2)) LP (COND ((COND ((AND (ATOM !#C2) (PAIRP (CAR F!:E!#LOCLST))) (EQ !#C2 (CAAR F!:E!#LOCLST))) ((EQ (CAR !#C2) 'IF) (COND ((ATOM (SETQ !#TEM (EDITVAL (CADR !#C2)))) NIL) (T !#TEM))) (T (EDIT4E !#C2 (COND ((EQ (CAR !#C2) '!') (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))))) (PROGN (SETQ F!:E!#UNFIND !#UF) (RETURN F!:E!#LOCLST))) ((SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST)) (GO LP))) (ERROR NIL NIL))) (DE EDITMAC (!#C !#LST !#FLG) (PROG (!#X !#Y) LP (COND ((NULL !#LST) (RETURN NIL)) ((EQ !#C (CAR (SETQ !#X (CAR !#LST)))) (PROGN (SETQ !#Y (CDR !#X)) (COND ((COND (!#FLG (CAR !#Y)) (T (NULL (CAR !#Y)))) (RETURN !#Y)))))) (SETQ !#LST (CDR !#LST)) (GO LP))) (DE EDITCOMS (!#COMS) (PROG NIL L1 (COND ((ATOM !#COMS) (RETURN (CAR F!:E!#LOCLST)))) (EDITCOM (CAR !#COMS) NIL) (SETQ !#COMS (CDR !#COMS)) (GO L1))) (DE EDITH (!#LST) (PROG NIL (TERPRI) (MAPC !#LST (FUNCTION (LAMBDA (!#ELT) (PROGN (COND ((NULL !#ELT) (PRIN2 " block")) ((NULL (CAR !#ELT)) NIL) ((NUMBERP (CAR !#ELT)) (PRIN2 (LIST (CAR !#ELT) "--"))) (T (PRIN1 (CAR !#ELT)))) (PRIN2 " "))))))) (DE EDITUNDO (!#PRINTFLG !#UNDOFLG !#UNDOP) (PROG (!#LST !#FLG) (SETQ !#LST F!:E!#UNDOLST) LP (COND ((OR (NULL !#LST) (NULL (CAR !#LST))) (GO OUT))) (COND ((NULL !#UNDOP) (SELECTQ (CAAR !#LST) ((NIL !@UNDO UNBLOCK) (GO LP1)) (UNDO (COND ((NULL !#UNDOFLG) (GO LP1)))) NIL)) ((NOT (EQ !#UNDOP (CAAR !#LST))) (GO LP1))) (EDITUNDOCOM (CAR !#LST) !#PRINTFLG) (COND ((NULL !#UNDOFLG) (RETURN NIL))) (SETQ !#FLG T) LP1 (SETQ !#LST (CDR !#LST)) (GO LP) OUT (COND (!#FLG NIL) ((AND !#LST (CDR !#LST)) (PRINT2 " blocked")) (T (PRINT2 " nothing saved"))))) (DE EDITUNDOCOM (!#X !#FLG) (PROG (!#C !#Y !#Z) (COND ((ATOM !#X) (ERROR NIL NIL)) ((NOT (EQ (CAR (LAST F!:E!#LOCLST)) (CAR (LAST (CADR !#X))))) (PROGN (PRINT2 " different expression") (SETQ F!:E!#CMD NIL) (ERROR NIL NIL)))) (SETQ !#C (CAR !#X)) (SETQ F!:E!#LOCLST (CADR !#X)) (SETQ !#Y (CDR !#X)) L1 (COND ((SETQ !#Y (CDR !#Y)) (PROGN (SETQ !#Z (CAR !#Y)) (COND ((EQ (CAR !#Z) 'R) ((LAMBDA (F!:E!#LOCLST) (EDITCOM (LIST 'R (CADR !#Z) (CADDR !#Z)) NIL)) (CADDDR !#Z))) (T (EDITSMASH (CAR !#Z) (CADR !#Z) (CDDR !#Z)))) (GO L1)))) (EDITSMASH !#X NIL (CONS (CAR !#X) (CDR !#X))) (COND (!#FLG (PROGN (COND ((NUMBERP !#C) (PRINT2 (LIST !#C "--"))) (T (PRIN1 !#C))) (PRIN2 " undone")))) (RETURN T))) (DE EDITSMASH (!#OLD !#A !#D) (PROGN (COND ((ATOM !#OLD) (ERROR NIL NIL))) (SETQ F!:E!#UNDOLST!#1 (CONS (CONS !#OLD (CONS (CAR !#OLD) (CDR !#OLD))) F!:E!#UNDOLST!#1)) (RPLACA !#OLD !#A) (RPLACD !#OLD !#D))) (DE EDITNCONC (!#X !#Y) (PROG (!#TEM) (RETURN (COND ((NULL !#X) !#Y) ((ATOM !#X) (ERROR NIL NIL)) (T (PROGN (EDITSMASH (SETQ !#TEM (LAST !#X)) (CAR !#TEM) !#Y) !#X)))))) (DE EDITDSUBST (!#X !#Y !#Z) (PROG NIL LP (COND ((NULL (PAIRP !#Z)) (RETURN NIL)) ((EQUAL !#Y (CAR !#Z)) (EDITSMASH !#Z (COPY !#X) (CDR !#Z))) (T (EDITDSUBST !#X !#Y (CAR !#Z)))) (COND ((AND !#Y (EQ !#Y (CDR !#Z))) (PROGN (EDITSMASH !#Z (CAR !#Z) (COPY !#X)) (RETURN NIL)))) (SETQ !#Z (CDR !#Z)) (GO LP))) (DE EDIT1F (!#C F!:E!#LOCLST) (COND ((EQUAL !#C 0) (COND ((NULL (CDR F!:E!#LOCLST)) (ERROR NIL NIL)) (T (CDR F!:E!#LOCLST)))) ((ATOM (CAR F!:E!#LOCLST)) (ERROR NIL NIL)) ((GREATERP !#C 0) (COND ((GREATERP !#C (LENGTH (CAR F!:E!#LOCLST))) (ERROR NIL NIL)) (T (CONS (CAR (SETQ F!:E!#LASTAIL (NTH!-TAIL (CAR F!:E!#LOCLST) !#C))) F!:E!#LOCLST)))) ((GREATERP (MINUS !#C) (LENGTH (CAR F!:E!#LOCLST))) (ERROR NIL NIL)) (T (CONS (CAR (SETQ F!:E!#LASTAIL (NTH!-TAIL (CAR F!:E!#LOCLST) (PLUS (LENGTH (CAR F!:E!#LOCLST)) (PLUS !#C 1))))) F!:E!#LOCLST)))) (DE EDIT2F (!#N !#X) (PROG (!#CL) (SETQ !#CL (CAR F!:E!#LOCLST)) (COND ((ATOM !#CL) (ERROR NIL NIL)) (F!:E!#COPYFLG (SETQ !#X (COPY !#X))) (T (SETQ !#X (APPEND !#X NIL)))) (COND ((GREATERP !#N 0) (COND ((GREATERP !#N (LENGTH !#CL)) (ERROR NIL NIL)) ((NULL !#X) (GO DELETE)) (T (GO REPLACE)))) ((OR (EQUAL !#N 0) (NULL !#X) (GREATERP (MINUS !#N) (LENGTH !#CL))) (ERROR NIL NIL)) (T (PROGN (COND ((NOT (EQUAL !#N -1)) (SETQ !#CL (NTH!-TAIL !#CL (MINUS !#N))))) (EDITSMASH !#CL (CAR !#X) (CONS (CAR !#CL) (CDR !#CL))) (COND ((CDR !#X) (EDITSMASH !#CL (CAR !#CL) (NCONC (CDR !#X) (CDR !#CL))))) (RETURN NIL)))) DELETE (COND ((EQUAL !#N 1) (PROGN (OR (PAIRP (CDR !#CL)) (ERROR NIL NIL)) (EDITSMASH !#CL (CADR !#CL) (CDDR !#CL)))) (T (PROGN (SETQ !#CL (NTH!-TAIL !#CL (DIFFERENCE !#N 1))) (EDITSMASH !#CL (CAR !#CL) (CDDR !#CL))))) (RETURN NIL) REPLACE (COND ((NOT (EQUAL !#N 1)) (SETQ !#CL (NTH!-TAIL !#CL !#N)))) (EDITSMASH !#CL (CAR !#X) (CDR !#CL)) (COND ((CDR !#X) (EDITSMASH !#CL (CAR !#CL) (NCONC (CDR !#X) (CDR !#CL))))))) (DE EDIT4E (!#PAT !#Y) (COND ((EQ !#PAT !#Y) T) ((ATOM !#PAT) (OR (EQ !#PAT '!&) (EQUAL !#PAT !#Y))) ((EQ (CAR !#PAT) '!*ANY!*) (PROG NIL LP (COND ((NULL (SETQ !#PAT (CDR !#PAT))) (RETURN NIL)) ((EDIT4E (CAR !#PAT) !#Y) (RETURN T))) (GO LP))) ((AND (EQ (CAR !#PAT) '!') (ATOM !#Y)) (PROG (!#Z) (SETQ !#PAT (CDR !#PAT)) (SETQ !#Z (EXPLODE2 !#Y)) LP (COND ((EQ (CAR !#PAT) '!') (PROGN (FREELIST !#Z) (PRINT2 "=") (PRIN1 !#Y) (RETURN T))) ((NULL !#Z) (RETURN NIL)) ((NOT (EQ (CAR !#PAT) (CAR !#Z))) (PROGN (FREELIST !#Z) (RETURN NIL)))) (SETQ !#PAT (CDR !#PAT)) (SETQ !#Z (CDR !#Z)) (GO LP))) ((EQ (CAR !#PAT) '!-!-) (OR (NULL (SETQ !#PAT (CDR !#PAT))) (PROG NIL LP (COND ((EDIT4E !#PAT !#Y) (RETURN T)) ((ATOM !#Y) (RETURN NIL))) (SETQ !#Y (CDR !#Y)) (GO LP)))) ((EQ (CAR !#PAT) '!=!=) (EQ (CDR !#PAT) !#Y)) ((ATOM !#Y) NIL) ((EDIT4E (CAR !#PAT) (CAR !#Y)) (EDIT4E (CDR !#PAT) (CDR !#Y))))) (DE EDITQF (!#PAT) (PROG (!#Q1) (COND ((AND (PAIRP (CAR F!:E!#LOCLST)) (PAIRP (SETQ !#Q1 (CDAR F!:E!#LOCLST))) (SETQ !#Q1 (MEMQ !#PAT !#Q1))) (SETQ F!:E!#LOCLST (CONS (COND (F!:E!#UPFINDFLG !#Q1) (T (PROGN (SETQ F!:E!#LASTAIL !#Q1) (CAR !#Q1)))) F!:E!#LOCLST))) (T (EDIT4F !#PAT 'N))))) (DE EDIT4F (!#PAT F!:E!#SN) (PROG (!#LL !#X !#FF) (SETQ !#FF (LIST NIL)) (SETQ F!:E!#CMD !#PAT) (SETQ !#PAT (EDITFPAT !#PAT)) (SETQ !#LL F!:E!#LOCLST) (COND ((EQ F!:E!#SN 'N) (PROGN (SETQ F!:E!#SN 1) (COND ((ATOM (CAR F!:E!#LOCLST)) (GO LP1)) ((AND (ATOM (CAAR F!:E!#LOCLST)) F!:E!#UPFINDFLG) (PROGN (SETQ !#LL (CONS (CAAR F!:E!#LOCLST) F!:E!#LOCLST)) (GO LP1))) (T (SETQ !#LL (CONS (CAAR F!:E!#LOCLST) F!:E!#LOCLST))))) )) (COND ((AND F!:E!#SN (NOT (NUMBERP F!:E!#SN))) (SETQ F!:E!#SN 1))) (COND ((AND (EDIT4E (COND ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:)) (CDR !#PAT)) (T !#PAT)) (CAR !#LL)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (RETURN (SETQ F!:E!#LOCLST !#LL)))) (SETQ !#X (CAR !#LL)) LP (COND ((EDIT4F1 !#PAT !#X F!:E!#MAXLEVEL !#FF) (PROGN (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (RETURN (CAR (SETQ F!:E!#LOCLST (NCONC (CAR !#FF) (COND ((EQ (CADR !#FF) (CAR !#LL)) (CDR !#LL)) (T !#LL)))))))) ((NULL F!:E!#SN) (ERROR NIL NIL))) LP1 (SETQ !#X (CAR !#LL)) (COND ((NULL (SETQ !#LL (CDR !#LL))) (ERROR NIL NIL)) ((AND (SETQ !#X (MEMQ !#X (CAR !#LL))) (PAIRP (SETQ !#X (CDR !#X)))) (GO LP))) (GO LP1))) (DE EDITFPAT (!#PAT) (COND ((PAIRP !#PAT) (COND ((OR (EQ (CAR !#PAT) '!=!=) (EQ (CAR !#PAT) '!')) !#PAT) (T (MAPCAR !#PAT (FUNCTION EDITFPAT))))) ((EQ (NTHCHAR !#PAT -1) '!') (CONS '!' (EXPLODE2 !#PAT))) (T !#PAT))) (DE EDIT4F1 (!#PAT !#X !#LVL !#FF) (PROG NIL LP (COND ((NOT (GREATERP !#LVL 0)) (PROGN (PRINT2 " maxlevel exceeded") (RETURN NIL))) ((ATOM !#X) (RETURN NIL)) ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:) (EDIT4E (CDR !#PAT) !#X) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) T) ((AND (OR (ATOM !#PAT) (NOT (EQ (CAR !#PAT) '!:!:!:))) (EDIT4E !#PAT (CAR !#X)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (COND ((OR (NULL F!:E!#UPFINDFLG) (PAIRP (CAR !#X))) (PROGN (SETQ F!:E!#LASTAIL !#X) (SETQ !#X (CAR !#X)))))) ((AND !#PAT (EQ !#PAT (CDR !#X)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (SETQ !#X (CDR !#X))) ((AND F!:E!#SN (PAIRP (CAR !#X)) (EDIT4F1 !#PAT (CAR !#X) (DIFFERENCE !#LVL 1) !#FF) (EQUAL F!:E!#SN 0)) (SETQ !#X (CAR !#X))) (T (PROGN (SETQ !#X (CDR !#X)) (SETQ !#LVL (DIFFERENCE !#LVL 1)) (GO LP)))) (COND ((AND !#FF (NOT (EQ !#X (CADR !#FF)))) (TCONC !#FF !#X))) (RETURN (OR !#FF T)))) (DE EDITFINDP (!#X !#PAT !#FLG) (PROG (F!:E!#SN F!:E!#LASTAIL !#FF) (SETQ F!:E!#SN 1) (AND (NULL !#FLG) (SETQ !#PAT (EDITFPAT !#PAT))) (RETURN (OR (EDIT4E !#PAT !#X) (EDIT4F1 !#PAT !#X F!:E!#MAXLEVEL !#FF))) )) (DE EDITBF (!#PAT !#N) (PROG (!#LL !#X !#Y !#FF) (SETQ !#LL F!:E!#LOCLST) (SETQ !#FF (LIST NIL)) (SETQ F!:E!#CMD !#PAT) (SETQ !#PAT (EDITFPAT !#PAT)) (COND ((AND (NULL !#N) (CDR !#LL)) (GO LP1))) LP (COND ((EDITBF1 !#PAT (CAR !#LL) F!:E!#MAXLEVEL !#Y !#FF) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) (RETURN (CAR (SETQ F!:E!#LOCLST (NCONC (CAR !#FF) (COND ((EQ (CAR !#LL) (CADR !#FF)) (CDR !#LL)) (T !#LL))))))))) LP1 (SETQ !#X (CAR !#LL)) (COND ((NULL (SETQ !#LL (CDR !#LL))) (ERROR NIL NIL)) ((OR (SETQ !#Y (MEMQ !#X (CAR !#LL))) (SETQ !#Y (TAIL!-P !#X (CAR !#LL)))) (GO LP))) (GO LP1))) (DE EDITBF1 (!#PAT !#X !#LVL !#TAIL !#FF) (PROG (!#Y) LP (COND ((NOT (GREATERP !#LVL 0)) (PROGN (PRINT2 " maxlevel exceeded") (RETURN NIL))) ((EQ !#TAIL !#X) (RETURN (COND ((EDIT4E (COND ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:)) (CDR !#PAT)) (T !#PAT)) !#X) (TCONC !#FF !#X)))))) (SETQ !#Y !#X) LP1 (COND ((NULL (OR (EQ (CDR !#Y) !#TAIL) (ATOM (CDR !#Y)))) (PROGN (SETQ !#Y (CDR !#Y)) (GO LP1)))) (SETQ !#TAIL !#Y) (COND ((AND (PAIRP (CAR !#TAIL)) (EDITBF1 !#PAT (CAR !#TAIL) (DIFFERENCE !#LVL 1) NIL)) (SETQ !#TAIL (CAR !#TAIL))) ((AND (EQ (CAR !#PAT) '!:!:!:) (EDIT4E (CDR !#PAT) !#TAIL)) T) ((AND (OR (ATOM !#PAT) (NOT (EQ (CAR !#PAT) '!:!:!:))) (EDIT4E !#PAT (CAR !#TAIL))) (COND ((OR (NULL F!:E!#UPFINDFLG) (PAIRP (CAR !#TAIL))) (PROGN (SETQ F!:E!#LASTAIL !#TAIL) (SETQ !#TAIL (CAR !#TAIL)))))) ((AND !#PAT (EQ !#PAT (CDR !#TAIL))) (SETQ !#X (CDR !#X))) (T (PROGN (SETQ !#LVL (DIFFERENCE !#LVL 1)) (GO LP)))) (COND ((NOT (EQ !#TAIL (CADR !#FF))) (TCONC !#FF !#TAIL))) (RETURN !#FF))) (DE EDITNTH (!#X !#N) (COND ((ATOM !#X) (ERROR NIL NIL)) ((NOT (NUMBERP !#N)) (OR (MEMQ !#N !#X) (MEMQ (SETQ !#N (EDITELT !#N (LIST !#X))) !#X) (TAIL!-P !#N !#X))) ((EQUAL !#N 0) (ERROR NIL NIL)) ((NULL (SETQ !#N (COND ((OR (NOT (LESSP !#N 0)) (GREATERP (SETQ !#N (PLUS (LENGTH !#X) !#N 1)) 0)) (NTH!-TAIL !#X !#N))))) (ERROR NIL NIL)) (T !#N))) (DE EDITBPNT0 (!#EXP !#DEPTH) (PROGN (COND ((NOT (EQUAL F!:E!#LASTP1 F!:E!#LOCLST)) (PROGN (SETQ F!:E!#LASTP2 F!:E!#LASTP1) (SETQ F!:E!#LASTP1 F!:E!#LOCLST)))) (TERPRI) (!* " 3nd arg to edit#print indicates whether print should start with ... ") (!* " 2nd arg to sprint is left margin") (COND (!#DEPTH (EDIT!#PRINT !#EXP !#DEPTH (TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)))) (T (SPRINT !#EXP 1))))) (DE EDITBPNT (!#X) (PROG (!#Y !#N) (COND ((EQUAL (CAR !#X) 0) (SETQ !#Y (CAR F!:E!#LOCLST))) (T (SETQ !#Y (CAR (EDITNTH (CAR F!:E!#LOCLST) (CAR !#X)))))) (COND ((NULL (CDR !#X)) (SETQ !#N 2)) ((NOT (NUMBERP (SETQ !#N (CADR !#X)))) (ERROR NIL NIL)) ((LESSP !#N 0) (ERROR NIL NIL))) (TERPRI) (!* " 3nd arg indicates whether print should start with ... ") (EDIT!#PRINT !#Y !#N (TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST))) (RETURN !#Y))) (DE EDITRI (!#M !#N !#X) (PROG (!#A !#B) (SETQ !#A (EDITNTH !#X !#M)) (SETQ !#B (EDITNTH (CAR !#A) !#N)) (COND ((OR (NULL !#A) (NULL !#B)) (ERROR NIL NIL))) (EDITSMASH !#A (CAR !#A) (EDITNCONC (CDR !#B) (CDR !#A))) (EDITSMASH !#B (CAR !#B) NIL))) (DE EDITRO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((OR (NULL !#X) (ATOM (CAR !#X))) (ERROR NIL NIL))) (EDITSMASH (SETQ !#N (LAST (CAR !#X))) (CAR !#N) (CDR !#X)) (EDITSMASH !#X (CAR !#X) NIL))) (DE EDITLI (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((NULL !#X) (ERROR NIL NIL))) (EDITSMASH !#X (CONS (CAR !#X) (CDR !#X)) NIL))) (DE EDITLO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((OR (NULL !#X) (ATOM (CAR !#X))) (ERROR NIL NIL))) (EDITSMASH !#X (CAAR !#X) (CDAR !#X)))) (DE EDITBI (!#M !#N !#X) (PROG (!#A !#B) (SETQ !#B (CDR (SETQ !#A (EDITNTH !#X !#N)))) (SETQ !#X (EDITNTH !#X !#M)) (COND ((AND !#A (NOT (GREATERP (LENGTH !#A) (LENGTH !#X)))) (PROGN (EDITSMASH !#A (CAR !#A) NIL) (EDITSMASH !#X (CONS (CAR !#X) (CDR !#X)) !#B))) (T (ERROR NIL NIL))))) (DE EDITBO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((ATOM (CAR !#X)) (ERROR NIL NIL))) (EDITSMASH !#X (CAAR !#X) (EDITNCONC (CDAR !#X) (CDR !#X))))) (DE EDITDEFAULT (!#X) (PROG (!#Y) (COND (F!:E!#LCFLG (RETURN (COND ((EQ F!:E!#LCFLG T) (EDITQF !#X)) (T (EDITCOM (LIST F!:E!#LCFLG !#X) F!:E!#TOPFLG))))) ((PAIRP !#X) (RETURN (COND ((SETQ !#Y (ATSOC (CAR !#X) F!:E!#OPS)) (EDITRAN !#X (CDR !#Y))) (T (ERROR NIL NIL))))) ((NULL F!:E!#TOPFLG) (ERROR NIL NIL)) ((MEMQ !#X F!:E!#EDITCOMSL) (COND (F!:E!#INBUF (PROGN (SETQ !#X (CONS !#X F!:E!#INBUF)) (SETQ F!:E!#INBUF NIL))) (T (ERROR NIL NIL)))) ((AND (EQ (NTHCHAR !#X -1) 'P) (MEMQ (SETQ !#X (ICOMPRESS (REVERSIP (CDR (REVERSIP (EXPLODE !#X)))))) '(!^ !_ UP NX BK !@NX UNDO))) (SETQ F!:E!#INBUF (CONS 'P F!:E!#INBUF))) (T (ERROR NIL NIL))) (RETURN (COND ((SETQ !#Y (ATSOC (CAR !#X) F!:E!#OPS)) (EDITRAN !#X (CDR !#Y))) (T (EDITCOM (SETQ F!:E!#CMD !#X) F!:E!#TOPFLG)))))) (DE EDITUP NIL (PROG (!#CL F!:E!#LOCLST!#1 !#X !#Y) (SETQ !#CL (CAR F!:E!#LOCLST)) (!* "unused LP was here") (COND ((NULL (SETQ F!:E!#LOCLST!#1 (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((TAIL!-P !#CL (CAR F!:E!#LOCLST!#1)) (RETURN NIL)) ((NOT (SETQ !#X (MEMQ !#CL (CAR F!:E!#LOCLST!#1)))) (ERROR NIL NIL)) ((OR (EQ !#X F!:E!#LASTAIL) (NOT (SETQ !#Y (MEMQ !#CL (CDR !#X))))) NIL) ((AND (EQ !#CL (CAR F!:E!#LASTAIL)) (TAIL!-P F!:E!#LASTAIL !#Y)) (SETQ !#X F!:E!#LASTAIL)) (T (PROGN (TERPRI) (PRIN2 !#CL) (PRINT2 " - location uncertain"))) ) (COND ((EQ !#X (CAR F!:E!#LOCLST!#1)) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#1)) (T (SETQ F!:E!#LOCLST (CONS !#X F!:E!#LOCLST!#1)))) (RETURN NIL))) (DE EDIT!* (!#N) (CAR (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#CMD F!:E!#LOCLST !#M) (PROGN (COND ((NOT (GREATERP !#M !#N)) (ERROR NIL NIL))) (EDITCOM '!@0 NIL) (EDITCOM (DIFFERENCE !#N !#M) NIL) F!:E!#LOCLST)) NIL F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (EDITUP) (LENGTH (CAR F!:E!#LOCLST)))) F!:E!#LOCLST))))) (DE EDITOR (!#COMS) (PROG (!#RES) LP (COND ((NULL !#COMS) (ERROR NIL NIL))) (SETQ !#RES (ERRORSET (LIST 'EDITOR1 (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((PAIRP !#RES) (RETURN (CAR F!:E!#LOCLST))) (!#RES (ERROR !#RES NIL))) (SETQ !#COMS (CDR !#COMS)) (GO LP))) (DE EDITOR1 (!#COMS) (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (COND ((ATOM (CAR !#COMS)) (EDITCOM (CAR !#COMS))) (T (EDITCOMS (CAR !#COMS)))) F!:E!#LOCLST)) F!:E!#LOCLST))) (DE EDITERRCOM (!#COMS) (ERRORSET (LIST 'EDITCOMS (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (DE EDITRPT (!#EDRX !#QUIET) (PROG (!#EDRL !#EDRPTCNT) (SETQ !#EDRL F!:E!#LOCLST) (SETQ !#EDRPTCNT 0) LP (COND ((GREATERP !#EDRPTCNT F!:E!#MAXLOOP) (PRINT2 " maxloop exceeded")) ((PAIRP (EDITERRCOM !#EDRX)) (PROGN (SETQ !#EDRL F!:E!#LOCLST) (SETQ !#EDRPTCNT (PLUS !#EDRPTCNT 1)) (GO LP))) ((NULL !#QUIET) (PROGN (PRIN1 !#EDRPTCNT) (PRINT2 " occurrences")))) (SETQ F!:E!#LOCLST !#EDRL))) (DE EDITLOC (!#X) (PROG (!#OLDL !#OLDF F!:E!#LCFLG !#L) (SETQ !#OLDL F!:E!#LOCLST) (SETQ !#OLDF F!:E!#UNFIND) (SETQ F!:E!#LCFLG T) (COND ((ATOM !#X) (EDITCOM !#X NIL)) ((AND (NULL (CDR !#X)) (ATOM (CAR !#X))) (EDITCOM (CAR !#X) NIL)) (T (GO LP))) (SETQ F!:E!#UNFIND !#OLDL) (RETURN (CAR F!:E!#LOCLST)) LP (SETQ !#L F!:E!#LOCLST) (COND ((PAIRP (EDITERRCOM !#X)) (PROGN (SETQ F!:E!#UNFIND !#OLDL) (RETURN (CAR F!:E!#LOCLST))))) (COND ((EQUAL !#L F!:E!#LOCLST) (PROGN (SETQ F!:E!#LOCLST !#OLDL) (SETQ F!:E!#UNFIND !#OLDF) (ERROR NIL NIL)))))) (DE EDITLOCL (!#COMS) (CAR (SETQ F!:E!#LOCLST (NCONC ((LAMBDA (F!:E!#LOCLST F!:E!#UNFIND) (PROGN (EDITLOC !#COMS) F!:E!#LOCLST)) (LIST (CAR F!:E!#LOCLST)) NIL) (CDR F!:E!#LOCLST))))) (DE EDIT!: (!#TYPE !#LC !#X) (PROG (F!:E!#TOFLG F!:E!#LOCLST!#0) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ !#X (MAPCAR !#X (FUNCTION (LAMBDA (!#X) (COND ((AND (PAIRP !#X) (EQ (CAR !#X) '!#!#)) ((LAMBDA (F!:E!#LOCLST F!:E!#UNDOLST!#1) (COPY (EDITCOMS (CDR !#X)))) F!:E!#LOCLST NIL)) (T !#X)))))) (COND (!#LC (PROGN (COND ((EQ (CAR !#LC) 'HERE) (SETQ !#LC (CDR !#LC)))) (EDITLOC !#LC)))) (EDITUP) (COND ((EQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ !#LC NIL))) (SELECTQ !#TYPE ((B BEFORE) (EDIT2F -1 !#X)) ((A AFTER) (COND ((CDAR F!:E!#LOCLST) (EDIT2F -2 !#X)) (T (EDITCOML (CONS 'N !#X) F!:E!#COPYFLG)))) ((!: FOR) (COND ((OR !#X (CDAR F!:E!#LOCLST)) (EDIT2F 1 !#X)) ((MEMQ (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (PROGN (EDITUP) (EDIT2F 1 (LIST NIL)))) (T (EDITCOMS '(0 (NTH -2) (2))))) (RETURN (COND ((NULL !#LC) F!:E!#LOCLST)))) (ERROR NIL NIL)) (RETURN NIL))) (DE EDITMBD (!#LC !#X) (PROG (!#Y F!:E!#TOFLG) (COND (!#LC (EDITLOC !#LC))) (EDITUP) (SETQ !#Y (COND (F!:E!#TOFLG (CAAR F!:E!#LOCLST)) (T (LIST (CAAR F!:E!#LOCLST))))) (EDIT2F 1 (LIST (COND ((OR (ATOM (CAR !#X)) (CDR !#X)) (APPEND !#X !#Y)) (T (LSUBST !#Y '!* (CAR !#X)))))) (SETQ F!:E!#LOCLST (CONS (CAAR F!:E!#LOCLST) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CDR F!:E!#LOCLST)) (T F!:E!#LOCLST)))) (RETURN (COND ((NULL !#LC) F!:E!#LOCLST))))) (DE EDITXTR (!#LC !#X) (PROG (F!:E!#TOFLG) (COND (!#LC (EDITLOC !#LC))) ((LAMBDA (F!:E!#LOCLST F!:E!#UNFIND) (PROGN (EDITLOC !#X) (SETQ !#X (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))))) (LIST (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))) NIL) (EDITUP) (EDIT2F 1 (COND (F!:E!#TOFLG (APPEND !#X NIL)) (T (LIST !#X)))) (AND (NULL F!:E!#TOFLG) (PAIRP (CAAR F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (CONS (CAAR F!:E!#LOCLST) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CDR F!:E!#LOCLST)) (T F!:E!#LOCLST))))))) (DE EDITELT (!#LC F!:E!#LOCLST) (PROG (!#Y) (EDITLOC !#LC) LP (SETQ !#Y F!:E!#LOCLST) (COND ((CDR (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (GO LP))) (RETURN (CAR !#Y)))) (DE EDITCONT (!#LC1 F!:E!#SN) (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROG (!#RES) (SETQ !#LC1 (EDITFPAT !#LC1)) LP (COND ((NULL (EDIT4F !#LC1 'N)) (ERROR NIL NIL))) (SETQ !#RES (ERRORSET (LIST 'EDITLOCL (MKQUOTE F!:E!#SN)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((NULL !#RES) (GO LP)) ((ATOM !#RES) (ERROR !#RES NIL))) LP1 (COND ((NULL (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((COND ((ATOM !#LC1) (EQ !#LC1 (CAAR F!:E!#LOCLST))) ((EQ (CAR !#LC1) '!') (EDIT4E !#LC1 (CAAR F!:E!#LOCLST))) (T (EDIT4E !#LC1 (CAR F!:E!#LOCLST)))) (RETURN F!:E!#LOCLST))) (GO LP1))) F!:E!#LOCLST))) (DE EDITSW (!#M !#N) (PROG (!#Y !#Z !#TEM) (SETQ !#Y (EDITNTH (CAR F!:E!#LOCLST) !#M)) (SETQ !#Z (EDITNTH (CAR F!:E!#LOCLST) !#N)) (SETQ !#TEM (CAR !#Y)) (EDITSMASH !#Y (CAR !#Z) (CDR !#Y)) (EDITSMASH !#Z !#TEM (CDR !#Z)))) (DE EDITMV (!#LC !#OP !#X) (PROG (F!:E!#LOCLST!#0 F!:E!#LOCLST!#1 !#Z F!:E!#TOFLG) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (AND !#LC (EDITLOC !#LC)) (COND ((EQ !#OP 'HERE) (PROGN (COND ((NULL !#LC) (PROGN (EDITLOC !#X) (SETQ !#X NIL)))) (SETQ !#OP '!:))) ((EQ (CAR !#X) 'HERE) (COND ((NULL !#LC) (PROGN (EDITLOC (CDR !#X)) (SETQ !#X NIL))) (T (SETQ !#X (CDR !#X)))))) (EDITUP) (SETQ F!:E!#LOCLST!#1 F!:E!#LOCLST) (SETQ !#Z (CAAR F!:E!#LOCLST)) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#0) (AND !#X (EDITLOC !#X)) (EDITCOML (COND (F!:E!#TOFLG (CONS !#OP (APPEND !#Z NIL))) (T (LIST !#OP !#Z))) NIL) (PROG (F!:E!#LOCLST) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#1) (EDITCOMS '(1 DELETE))) (RETURN (COND ((NULL !#LC) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST!#1) F!:E!#LOCLST)) ((NULL !#X) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST!#1) F!:E!#LOCLST!#0)) (T (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) F!:E!#LOCLST!#0)))))) (DE EDITTO (!#LC1 !#LC2 !#FLG) (PROGN (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (COND (!#LC1 (PROGN (EDITLOC !#LC1) (EDITUP)))) (EDITBI 1 (COND ((AND (NUMBERP !#LC1) (NUMBERP !#LC2) (GREATERP !#LC2 !#LC1)) (DIFFERENCE (PLUS !#LC2 1) !#LC1)) (T !#LC2)) (CAR F!:E!#LOCLST)) (COND ((AND (EQ !#FLG 'TO) (CDAAR F!:E!#LOCLST)) (EDITRI 1 -2 (CAR F!:E!#LOCLST)))) (EDITCOM 1 NIL) F!:E!#LOCLST)) F!:E!#LOCLST)) (SETQ F!:E!#TOFLG T))) (DE EDITBELOW (!#PLACE !#DEPTH) (PROGN (COND ((LESSP (SETQ !#DEPTH (EVAL !#DEPTH)) 0) (ERROR NIL NIL))) (PROG (!#N1 !#N2) (SETQ !#N1 (LENGTH ((LAMBDA (F!:E!#LOCLST F!:E!#LCFLG) (PROGN (EDITCOM !#PLACE NIL) F!:E!#LOCLST)) F!:E!#LOCLST '!_))) (SETQ !#N2 (LENGTH F!:E!#LOCLST)) (COND ((LESSP !#N2 (PLUS !#N1 !#DEPTH)) (ERROR NIL NIL))) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (SETQ F!:E!#LOCLST (NTH!-TAIL F!:E!#LOCLST (DIFFERENCE (DIFFERENCE (PLUS !#N2 1) !#N1) !#DEPTH)))))) (DE EDITRAN (!#C !#DEF) (SETQ F!:E!#LOCLST (OR ((LAMBDA (F!:E!#LOCLST) (PROG (!#Z !#W) (COND ((NULL !#DEF) (ERROR NIL NIL)) ((NULL (SETQ !#Z (CAR !#DEF))) (GO OUT))) LP (COND ((NULL !#Z) (ERROR NIL NIL)) ((NULL (SETQ !#W (MEMQ (CAR !#Z) !#C))) (PROGN (SETQ !#Z (CDR !#Z)) (GO LP)))) OUT (SETQ !#Z (APPLY (CAR (SETQ !#DEF (CADR !#DEF))) (PROG (F!:E!#1 F!:E!#2 F!:E!#3) (SETQ F!:E!#1 (CDR (LDIFF !#C !#W))) (SETQ F!:E!#2 (CAR !#Z)) (SETQ F!:E!#3 (CDR !#W)) (RETURN (MAPCAR (CDR !#DEF) (FUNCTION (LAMBDA (!#X) (SELECTQ !#X (!#1 F!:E!#1) (!#2 F!:E!#2) (!#3 F!:E!#3) (EVAL !#X))))))))) (RETURN (COND ((NULL !#Z) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) NIL)) (T !#Z))))) F!:E!#LOCLST) F!:E!#LOCLST))) (DE EDIT!#PRINT (!#E !#DEPTH !#DOTFLG) (PROG (!#RES) (SETQ !#RES (ERRORSET (LIST 'DEPTH!#PRINT (MKQUOTE !#E) !#DEPTH 0 (MKQUOTE !#DOTFLG)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'TOOBIG) (RETURN (PRINT2 " ...> "))) ((ATOM !#RES) (ERROR !#RES NIL))) (RETURN !#E))) (DE DEPTH!#PRINT (!#E !#DEPTH !#PLENGTH !#DOTFLG) (PROG NIL (OR (LESSP (SETQ !#PLENGTH (ADD1 !#PLENGTH)) F!:E!#MAX!#PLENGTH) (ERROR 'TOOBIG NIL)) (COND ((ATOM !#E) (PROGN (PRIN1 !#E) (RETURN !#PLENGTH))) ((ZEROP !#DEPTH) (PROGN (PRIN2 "&") (RETURN !#PLENGTH)))) (PRIN2 (COND (!#DOTFLG "... ") (T "("))) (SETQ !#DEPTH (SUB1 !#DEPTH)) LOOP (SETQ !#PLENGTH (DEPTH!#PRINT (CAR !#E) !#DEPTH !#PLENGTH NIL)) (SETQ !#E (CDR !#E)) (COND ((NULL !#E) NIL) ((ATOM !#E) (PROGN (PRIN2 " . ") (PRIN1 !#E))) (T (PROGN (PRIN2 " ") (GO LOOP)))) (PRIN2 ")") (RETURN !#PLENGTH))) (!* "LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X.") (CDE LDIFF (!#X !#Y) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) NIL) ((NULL !#Y) !#X) (T (PROG (!#V !#Z) (SETQ !#Z (SETQ !#V (LIST (CAR !#X)))) LOOP (SETQ !#X (CDR !#X)) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) (RETURN !#Z))) (SETQ !#V (CDR (RPLACD !#V (LIST (CAR !#X))))) (GO LOOP))))) (!* "FREELIST is an efficiency hack in the DEC interpreter." "It explicitly returns the cells of a list to the freelist.") (CDE FREELIST (!#X) NIL) (!* "EDITRACEFN is an optional debugging routine for the editor.") (CDE EDITRACEFN (!#X) NIL) (DE PRINT2 (!#X) (PROGN (PRIN2 !#X) (TERPRI) !#X)) (SETQ F!:E!#LOOKDPTH -1) (SETQ F!:E!#DEPTH -1) (SETQ F!:E!#TRACEFLG NIL) (SETQ F!:E!#LAST!#ID NIL) (SETQ F!:E!#MAXLEVEL 300) (SETQ F!:E!#UPFINDFLG T) (SETQ F!:E!#MAXLOOP 30) (SETQ F!:E!#EDITCOMSL '(S R E I N P F FS F!= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR MBD XTR THRU TO A B !: AFTER BEFORE FOR MV LP LPQ LC LCL !_ BELOW SW BIND COMS COMSQ INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SECOND THIRD NEX REPACK MAKEFN)) (SETQ F!:E!#USERMACROS NIL) (SETQ F!:E!#MAX!#PLENGTH 1750) (SETQ F!:E!#MACROS '((MAKEFN (EX ARGS N M) (IF 'M ((BI N M) (LC . N) (BELOW !\)) ((IF 'N ((BI N) (LC . N) (BELOW !\))))) (E (MAPC '(LAMBDA (!#X !#Y) (EDITDSUBST !#X !#Y (EDIT!#!#))) 'ARGS (CDR 'EX)) T) (E (PUTD (CAR 'EX) 'EXPR (CONS 'LAMBDA (CONS 'ARGS (EDIT!#!#)))) T) UP (1 EX)) (REPACK !#X (LC . !#X) REPACK) (REPACK NIL (IF (PAIRP (EDIT!#!#)) (1) NIL) (I !: (PRINT (READLIST (EDITE (EXPLODE (EDIT!#!#)) NIL NIL))))) (NEX (!#X) (BELOW !#X) NX) (NEX NIL (BELOW !_) NX) (THIRD !#X (ORR ((LC . !#X) (LC . !#X) (LC . !#X)))) (SECOND !#X (ORR ((LC . !#X) (LC . !#X)))))) (SETQ F!:E!#OPS '((INSERT (BEFORE AFTER FOR) (EDIT!: F!:E!#2 F!:E!#3 F!:E!#1)) (REPLACE (WITH BY) (EDIT!: !: F!:E!#1 F!:E!#3)) (CHANGE (TO) (EDIT!: !: F!:E!#1 F!:E!#3)) (DELETE NIL (EDIT!: !: F!:E!#1 NIL)) (EMBED (IN WITH) (EDITMBD F!:E!#1 F!:E!#3)) (SURROUND (WITH IN) (EDITMBD F!:E!#1 F!:E!#3)) (MOVE (TO) (EDITMV F!:E!#1 (CAR F!:E!#3) (CDR F!:E!#3))) (EXTRACT (FROM) (EDITXTR F!:E!#3 F!:E!#1)))) |
Added psl-1983/3-1/util/zsys.lsp version [16649324f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZSYS -- the system dependent file. Currently, the only code in it is MAKE-OPEN-FILE-NAME, which uses a semi machine-independant file description to create a filename suitable for OPEN in the resident system. N.B.: TO SET THIS CODE UP FOR A PARTICULAR INTEPRETER, REMOVE THE * FROM BEFORE THE APPROPRIATE SETQ BELOW. THAT SHOULD BE ALL YOU NEED TO DO. ") (COMPILETIME (GLOBAL '(G!:SYSTEM)) (IF!_SYSTEM TOPS20 (SETQ G!:SYSTEM 'PSL!-TOPS20)) (IF!_SYSTEM UNIX (SETQ G!:SYSTEM 'PSL!-UNIX)) (!* SETQ G!:SYSTEM 'IMSSS!-TENEX) (!* SETQ G!:SYSTEM 'UTAH!-TOPS10) (!* SETQ G!:SYSTEM 'UTAH!-TENEX) (!* SETQ G!:SYSTEM 'CMS) (!* SETQ G!:SYSTEM 'ORVYL) (PROGN (TERPRI) (PRIN2 "Filenames will be made for ") (PRIN2 G!:SYSTEM) (PRIN2 " system.") (TERPRI)) ) (FLUID '(F!:FILE!:ID F!:OLD!:FILE)) (COMPILETIME (!* "This macro (and those following) are separated only for readability. The appropriate MAKE-xxx-NAME will provide the body of the definition for MAKE-OPEN-FILE-NAME. Note: (a) #DSCR can be mentioned free in the macros since it is the lambda variable for MAKE-OPEN-FILE-NAME. (b) ORVYL and CMS differ only in the delimiter they use. (c) When compiling, all these macros are REMOB'ed to clear up otherwise extraneous code.") (DM MAKE!-SYS!-FILE!-NAME (!#X) (SELECTQ G!:SYSTEM (PSL!-TOPS20 '(MAKE!-PSL!-TOPS20!-NAME)) (PSL!-UNIX '(MAKE!-PSL!-UNIX!-NAME)) (UTAH!-TENEX '(MAKE!-UTAH!-TENEX!-NAME)) (UTAH!-TOPS10 '(MAKE!-UTAH!-TOPS10!-NAME)) (IMSSS!-TENEX '(MAKE!-IMSSS!-TENEX!-NAME)) (ORVYL '(MAKE!-IBM!-NAME !.)) (CMS '(MAKE!-IBM!-NAME ! )) (ERROR 0 (LIST "Don't know how to make file names for system " G!:SYSTEM)))) (DM MAKE!-UTAH!-TENEX!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST 'DIR!: !#DIR (CONS !#NAM !#EXT))))))))) (!* "Use decimal equivalent of PPNs for tops 10. Maybe the ROCT switch in the interpreter will allow octal PPNS??") (DM MAKE!-UTAH!-TOPS10!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (COND ((NOT (AND (PAIRP !#DIR) (NUMBERP (CAR !#DIR)) (NUMBERP (CADR !#DIR)))) (BUG!-STOP "Bad PPN: USE (<n> <n>) w/ decimal equiv of octal PPN.") )) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST !#DIR (CONS !#NAM !#EXT))))))))) (DM MAKE!-IMSSS!-TENEX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (RETURN (SETQ F!:OLD!:FILE (LIST (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP)) ((EQ (CDR !#DSCR) '!;) (SETQ F!:FILE!:ID (CAR !#DSCR))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) !#DSCR)) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (CONS DIR!#NAM !#EXT))))))))) (DM MAKE!-PSL!-TOPS20!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR))) ) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT))))))))) (DM MAKE!-PSL!-UNIX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR)))) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (EXPLODE (CAR !#DSCR)) (LIST '!! '!/) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT)))))))))) (IF!_SYSTEM TOPS20 (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a TOPS-20 filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (ID2STRING (CAR !#X)))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (IF!_SYSTEM UNIX (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a UNIX filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (FLUID '(!*LOWER)) (!* "*LOWER when T all output (including EXPLODE) is in lowercase") (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S !*LOWER) (SETQ !*LOWER T) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (LIST2STRING (EXPLODE2 (CAR !#X))))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (!* "IBM code got lost") (DE MAKE!-OPEN!-FILE!-NAME (!#DSCR) (MAKE!-SYS!-FILE!-NAME)) (!* "Remove excess baggage once macros have been used.") (!* COND ((CODEP (CDR (GETD 'MAKE!-OPEN!-FILE!-NAME))) (PROGN (REMOB 'MAKE!-SYS!-FILE!-NAME) (REMOB 'MAKE!-UTAH!-TENEX!-NAME) (REMOB 'MAKE!-UTAH!-TOPS10!-NAME) (REMOB 'MAKE!-IMSSS!-TENEX!-NAME) (REMOB 'MAKE!-IBM!-NAME)))) |
Added psl-1983/3-1/windows/-this-.directory version [d50cf29108].
> > > > > > | 1 2 3 4 5 6 | This directory contains the sources and non-loadable binaries for the Window package used by NMode. The window package consists of two loadable modules: WINDOWS and DISPLAY-CHAR. WINDOWS is the main module and is essential. DISPLAY-CHAR is a module that defines some macros for manipulating "display characters", which are used in the Window Package. Load this module at compile time if you use any of these macros. |
Added psl-1983/3-1/windows/-windows.files version [fbdd865a14].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | Window Package Source Files Summary - 5 April 1983 ------------------------------------------------------------------------------- 9836-ALPHA.SL - display driver for 9836 alpha display 9836-BITMAP.SL - display driver for memory-mapped raster displays 9836-COLOR.SL - display driver for 9836 color display (Moon Unit) DIRECT-PHYSICAL-SCREEN.SL - direct-writing version of Physical Screen (for 9836) DISPLAY-CHAR.SL - type representing chars on display screen (with enhancements) FONT8.SL - font definition for bitmapped displays HP2648A.SL - terminal handler for HP2648A family PHYSICAL-SCREEN.SL - physical screen abstract data type SHARED-PHYSICAL-SCREEN.SL - shared physical screen: handles overlapping screens TELERAY.SL - terminal handler for Teleray terminal VAX-PHYSICAL-SCREEN.SL - Vax version of Physical Screen (flushes buffers) VIRTUAL-SCREEN.SL - virtual screen abstract data type VT52X.SL - terminal handler for 9836 extended VT52 emulator WINDOWS-20.SL - Dec-20 specific stuff WINDOWS-9836.SL - 9836 specific stuff WINDOWS-VAX.SL - Vax-Unix specific stuff |
Added psl-1983/3-1/windows/9836-alpha.sl version [c6e648ccc0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 9836-Alpha.SL - Terminal Interface for 9836 Alpha Memory % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 13 December 1982 % Revised: 27 January 1983 % % Note: uses efficiency hacks that require 80-column width! % Note: contains 68000 LAP code; must be compiled! % Note: uses all 25 lines; assumes keyboard input buffer has been relocated % % 27-Jan-83 Alan Snyder % Revise to use all 25 lines of the screen. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int syslisp)) (defflavor 9836-alpha ( (height 25) % number of rows (0 indexed) (maxrow 24) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (buffer-address (int2sys 16#512000)) % an absolute address ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (9836-alpha get-character) () (keyboard-input-character) ) (defmethod (9836-alpha ring-bell) () (ChannelWriteChar 1 #\Bell) ) (defmethod (9836-alpha move-cursor) (row column) (setf cursor-row row) (setf cursor-column column) (screen-set-cursor-position row column) ) (defmethod (9836-alpha enter-raw-mode) () (when (not raw-mode) % (EchoOff) % Enable Keypad? (setf raw-mode T) )) (defmethod (9836-alpha leave-raw-mode) () (when raw-mode (setf raw-mode NIL) % Disable Keypad? % (EchoOn) )) (defmethod (9836-alpha erase) () % This method should be invoked to initialize the screen to a known state. (setf cursor-column 0) (for (from row 0 maxrow) (do (setf cursor-row row) (=> self clear-line) )) (setf cursor-row 0) ) (defmethod (9836-alpha clear-line) () (=> self write-line cursor-row #.(make-vector 80 32)) ) (defmethod (9836-alpha convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) ch) (defmethod (9836-alpha normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (9836-alpha highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (9836-alpha supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (9836-alpha write-char) (row column ch) (screen80-write-char buffer-address row column ch) ) (defmethod (9836-alpha write-line) (row data) (screen80-write-line buffer-address row data) ) (defmethod (9836-alpha read-char) (row column) (let ((offset (+ column (* row width)))) (halfword buffer-address offset) )) % The following methods are provided for INTERNAL use only! (defmethod (9836-alpha init) () ) (lap '((*entry screen80-write-char expr 4) % buffer-address row column word (move!.l (reg 2) (reg t1)) (moveq 80 (reg t2)) (mulu (reg t1) (reg t2)) (add!.l (reg 3) (reg t2)) (lsl!.l 1 (reg t2)) (move!.w (reg 4) (indexed (reg t2) (displacement (reg 1) 0))) (rts) )) (lap '((*entry screen80-write-line expr 3) % buffer-address row data (move!.l (reg 2) (reg t1)) % move row address to T1 (moveq 80 (reg t2)) % move 80 to T2 (mulu (reg t1) (reg t2)) % multiply row address by 80 (lsl!.l 1 (reg t2)) % convert to byte offset (adda!.l (reg t2) (reg 1)) % A1: address of line in buffer (move!.l (minus 80) (reg t1)) (addq!.l 4 (reg 3)) % skip data header word (*lbl (label loop)) (addq!.l 2 (reg 3)) % skip upper halfword in data (move!.w (autoincrement (reg 3)) (autoincrement (reg 1))) (addq!.l 1 (reg t1)) (bmi (label loop)) (rts) )) |
Added psl-1983/3-1/windows/9836-bitmap.sl version [5184d5a9f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 9836-Bitmap.SL - Terminal Interface for 9836 Bitmap Display % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 March 1983 % % This code is adapted from 9836-COLOR.SL. It assumes a contiguous bitmap % memory, one bit per pixel, byte-aligned, with an integral number of bytes % per scan row. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-vectors numeric-operators syslisp)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(font8-patterns)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor 9836-bitmap ( % The following parameters may be set at initialization: (device-address (+ 16#600000 (* 28 16#10000))) % address of device (plane device-address) % address of bitmap (raster-width 512) % must be a multiple of 8! (raster-height 392) (character-height 14) % raster lines in each character (interline-spacing 0) % raster lines between each text row (patterns font8-patterns) % raster images of characters (display-on-function NIL) % optional function to turn on display (display-off-function NIL) % optional function to turn off display % the following variables are computed from the above: character-row-spacing % number of raster lines per text row height % number of rows of characters width % number of columns of characters maxrow % highest numbered row of characters maxcol % highest numbered column of characters raster-area % number of bits in display raster raster-area-words % number of words in display raster bytes-per-row % number of bytes per raster row bytes-per-character-row % number of bytes per character row blank-pattern % raster for blank character % State variables: (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (inverse-video? NIL) ) () (gettable-instance-variables height width maxrow maxcol raw-mode) (settable-instance-variables inverse-video?) (initable-instance-variables device-address plane raster-width raster-height character-height interline-spacing patterns display-on-function display-off-function ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (9836-bitmap get-character) () (keyboard-input-character) ) (defmethod (9836-bitmap ring-bell) () (ChannelWriteChar 1 #\Bell) ) (defmethod (9836-bitmap move-cursor) (row column) (=> self xor-cursor) (setf cursor-row row) (setf cursor-column column) (=> self xor-cursor) ) (defmethod (9836-bitmap xor-cursor) () (when (and cursor-row cursor-column) (let ((byte-offset (* cursor-row bytes-per-character-row))) (setf byte-offset (+ byte-offset cursor-column)) (for (from i 1 character-height) (do (putbyte plane byte-offset (~ (byte plane byte-offset))) (setf byte-offset (+ byte-offset bytes-per-row)) ))))) (defmethod (9836-bitmap enter-raw-mode) () (when (not raw-mode) % (EchoOff) % Enable Keypad? (=> self display-on) (setf raw-mode T) )) (defmethod (9836-bitmap leave-raw-mode) () (when raw-mode (setf raw-mode NIL) % Disable Keypad? % (EchoOn) )) (defmethod (9836-bitmap display-on) () (when display-on-function (apply display-on-function (list device-address)) )) (defmethod (9836-bitmap display-off) () (when display-off-function (apply display-off-function (list device-address)) )) (defmethod (9836-bitmap erase) () % This method should be invoked to initialize the screen to a known state. (=> self &fill-plane plane 0 raster-area-words) (setf cursor-column NIL) (setf cursor-row NIL) (=> self move-cursor 0 0) ) (defmethod (9836-bitmap &fill-plane) (address word-value count) (when (> count 0) (wputv address 0 word-value) (=> self &fill-plane (+ address 4) word-value (- count 1)) )) (defmethod (9836-bitmap clear-line) () % Not implemented yet. ) (defmethod (9836-bitmap convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO) (dc-make-font-mask 0) 16#FF))) % 8 bits ch) (defmethod (9836-bitmap normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (9836-bitmap highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (9836-bitmap supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (9836-bitmap write-line) (row line) (for (from col 0 maxcol) (do (=> self write-char row col (vector-fetch line col))) )) (defmethod (9836-bitmap write-char) (row column ch) (let* ((pattern (vector-fetch patterns (dc-character-code ch))) (inverse-bit (& ch (dc-make-enhancement-mask INVERSE-VIDEO))) (byte-offset (mul16 row bytes-per-character-row)) (address (+ plane (+ byte-offset column))) (inverse? (xor (~= 0 inverse-bit) inverse-video?)) ) (if (xor inverse? (and (= cursor-row row) (= cursor-column column))) (write-inverted-char-raster pattern address bytes-per-row 14) (write-char-raster pattern address bytes-per-row 14) ))) (defmethod (9836-bitmap set-character-pattern) (ch pattern) % CH must be an ASCII code (0..255); pattern must be a vector of bytes or % NIL. (when (and (fixp ch) (>= ch 0) (<= ch (vector-upper-bound patterns)) (or (null pattern) (vectorp pattern)) ) (if (null pattern) (setf pattern blank-pattern) (setf pattern (copyvector pattern)) ) (when (< (vector-size pattern) character-height) (setf pattern (concat pattern (make-vector (- character-height (vector-size pattern)) 0)))) (vector-store patterns ch pattern) )) % The following methods are provided for INTERNAL use only! (defmethod (9836-bitmap init) (init-plist) (setf raster-area (* raster-width raster-height)) (setf raster-area-words (/ raster-area 32)) (setf character-row-spacing (+ character-height interline-spacing)) (setf height (/ (+ raster-height interline-spacing) character-row-spacing)) (setf width (/ raster-width 8)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf bytes-per-row (/ raster-width 8)) (setf bytes-per-character-row (* bytes-per-row character-row-spacing)) (setf blank-pattern (make-vector character-height 0)) (fixup-font-patterns patterns character-height) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Examples of bitmap devices: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-color-bitmap () (create-color-bitmap-selectcode 28) ) (de create-color-bitmap-selectcode (select-code) (let ((device-address (+ 16#600000 (* select-code 16#10000)))) (make-instance '9836-bitmap 'device-address device-address 'plane (+ device-address (* 2 32768)) 'raster-width 512 'raster-height 392 'character-height 14 'interline-spacing 0 'patterns font8-patterns 'display-on-function #'color-display-on-function 'display-off-function #'color-display-off-function ))) (de color-display-on-function (device-address) (let ((device-register-values [41 32 34 3 50 5 49 49 0 7 0 0 0 0 0 0 0 0])) (for (from i 0 17) (do (putbyte device-address 16 i) (putbyte device-address 18 (vector-fetch device-register-values i)) )) (putbyte device-address 1 -128) )) (de color-display-off-function (device-address) (putbyte device-address 1 0) ) (de create-graphics-bitmap () (let ((device-address 16#530000)) (make-instance '9836-bitmap 'device-address device-address 'plane device-address 'raster-width 512 'raster-height 392 'character-height 14 'interline-spacing 0 'patterns font8-patterns ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/windows/9836-color.sl version [b95d1091ff].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 9836-Color.SL - Terminal Interface for 9836 Color Display % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 December 1982 % Revised: 16 March 1983 % % 16-Mar-83 Alan Snyder % Removed font definition (now in Font8.SL). New font definition supports % 8-bit characters. Speed up write-char using hand-coded assembly language % routines. Speed up erase using tail recursion. % 4-Mar-83 Alan Snyder % Check for 8-bit characters being displayed. % 29-Dec-82 Alan Snyder % Added SET-CHARACTER-PATTERN method. % Font hacking; changed: ' ` " a b d p q r s u % Use WPUTV instead of PutWord (it's faster, because it's open-coded). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-vectors numeric-operators syslisp)) (on fast-integers) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % External variables: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(font8-patterns)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor 9836-color ( (height 28) % number of rows (0 indexed) (maxrow 27) % highest numbered row (width 64) % number of columns (0 indexed) (maxcol 63) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (inverse-video? NIL) (color-card (+ 16#600000 (* 28 16#10000))) (blue-plane (+ color-card 32768)) (green-plane (+ blue-plane 32768)) (red-plane (+ green-plane 32768)) (text-plane green-plane) (cursor-plane red-plane) (background-plane blue-plane) (color-register-values [41 32 34 3 50 5 49 49 0 7 0 0 0 0 0 0 0 0]) (color-raster-width 512) (color-raster-height 392) (color-raster-area (* color-raster-width color-raster-height)) (color-raster-area-bytes (/ color-raster-area 8)) (color-raster-area-halfwords (/ color-raster-area 16)) (color-raster-area-words (/ color-raster-area 32)) (bytes-per-row (/ color-raster-width 8)) (character-height 14) (character-row-spacing 14) (bytes-per-character-row (* bytes-per-row character-row-spacing)) (blank-pattern (make-vector character-height 0)) (full-pattern (make-vector character-height -1)) patterns ) () (gettable-instance-variables height width maxrow maxcol raw-mode) (settable-instance-variables inverse-video?) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (9836-color select-color) (new-color) (selectq new-color (GREEN (setf text-plane green-plane)) (BLUE (setf text-plane blue-plane)) (RED (setf text-plane red-plane)) )) (defmethod (9836-color select-cursor-color) (new-color) (=> self write-cursor 0) (selectq new-color (GREEN (setf cursor-plane green-plane)) (BLUE (setf cursor-plane blue-plane)) (RED (setf cursor-plane red-plane)) ) (=> self write-cursor -1) ) (defmethod (9836-color select-background-color) (new-color) (selectq new-color (GREEN (setf background-plane green-plane)) (BLUE (setf background-plane blue-plane)) (RED (setf background-plane red-plane)) (nil (setf background-plane nil)) ) ) (defmethod (9836-color get-character) () (keyboard-input-character) ) (defmethod (9836-color ring-bell) () (ChannelWriteChar 1 #\Bell) ) (defmethod (9836-color move-cursor) (row column) (=> self write-cursor 0) (setf cursor-row row) (setf cursor-column column) (=> self write-cursor -1) ) (defmethod (9836-color write-cursor) (bits) (let ((byte-offset (* cursor-row bytes-per-character-row))) (setf byte-offset (+ byte-offset cursor-column)) (for (from i 0 13) (do (putbyte cursor-plane byte-offset bits) (setf byte-offset (+ byte-offset bytes-per-row)) )))) (defmethod (9836-color enter-raw-mode) () (when (not raw-mode) % (EchoOff) % Enable Keypad? (=> self display-on) (setf raw-mode T) )) (defmethod (9836-color leave-raw-mode) () (when raw-mode (setf raw-mode NIL) % Disable Keypad? % (EchoOn) )) (defmethod (9836-color display-on) () (for (from i 0 17) (do (putbyte color-card 16 i) (putbyte color-card 18 (vector-fetch color-register-values i)) )) (putbyte color-card 1 -128) ) (defmethod (9836-color display-off) () (putbyte color-card 1 0) ) (defmethod (9836-color erase) () % This method should be invoked to initialize the screen to a known state. (let ((blue-word (if (= background-plane blue-plane) -1 0)) (green-word (if (= background-plane green-plane) -1 0)) (red-word (if (= background-plane red-plane) -1 0)) (count color-raster-area-words) ) (=> self &fill-plane blue-plane blue-word count) (=> self &fill-plane green-plane green-word count) (=> self &fill-plane red-plane red-word count) ) (setf cursor-column 0) (setf cursor-row 0) (=> self move-cursor 0 0) ) (defmethod (9836-color &fill-plane) (plane word-value count) % Fill the specified plane with the specified word. (when (> count 0) (wputv plane 0 word-value) (=> self &fill-plane (+ plane 4) word-value (- count 1)) )) (defmethod (9836-color clear-line) () % Not implemented yet. ) (defmethod (9836-color convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO % BLINK % UNDERLINE % INTENSIFY ) (dc-make-font-mask 0) 16#FF))) % 8 bits ch) (defmethod (9836-color normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (9836-color highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (9836-color supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO % BLINK UNDERLINE INTENSIFY ) ) (defmethod (9836-color write-line) (row line) (for (from col 0 maxcol) (do (=> self write-char row col (vector-fetch line col))) )) (defmethod (9836-color write-char) (row column ch) (let* ((pattern (vector-fetch patterns (dc-character-code ch))) (inverse-bit (& ch (dc-make-enhancement-mask INVERSE-VIDEO))) (byte-offset (mul16 row bytes-per-character-row)) (address (+ text-plane (+ byte-offset column))) (inverse? (xor (~= 0 inverse-bit) inverse-video?)) ) (if inverse? (write-inverted-char-raster pattern address bytes-per-row 14) (write-char-raster pattern address bytes-per-row 14) ))) (defmethod (9836-color set-character-pattern) (ch pattern) % CH must be an ASCII code (0..255); pattern must be a vector % of bytes or NIL. (when (and (fixp ch) (>= ch 0) (<= ch (vector-upper-bound patterns)) (or (null pattern) (vectorp pattern)) ) (if (null pattern) (setf pattern blank-pattern) (setf pattern (copyvector pattern)) ) (when (< (vector-size pattern) character-height) (setf pattern (concat pattern (make-vector (- character-height (vector-size pattern)) 0)))) (vector-store patterns ch pattern) )) % The following methods are provided for INTERNAL use only! (defmethod (9836-color init) (init-plist) (setf patterns font8-patterns) (fixup-font-patterns patterns character-height) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/3-1/windows/binary/ambassador.b version [f99e57e3c7].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/hazeltine-1500.b version [b36120be62].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/hp2648a.b version [b38fd06b80].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/physical-screen.b version [7c2dce0c89].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/shared-physical-screen.b version [d8c3c396c4].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/teleray.b version [e8af7f9eff].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/televideo.b version [c07104b24f].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/virtual-screen.b version [2844112150].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/vt100.b version [e34dbdcb7b].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/vt52nx.b version [9f48d50bed].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/vt52x.b version [8d2aa95fdd].
cannot compute difference between binary files
Added psl-1983/3-1/windows/binary/windows-20.b version [3d048c687d].
cannot compute difference between binary files
Added psl-1983/3-1/windows/direct-physical-screen.sl version [118feabdad].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Direct-Physical-Screen.SL - Write-Line and Direct-Write Version % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 20 December 1982 % % Adapted from Will Galway's EMODE Virtual Screen package. % % A physical screen is a rectangular character display. Changes to the physical % screen are made using the Write operation. FULL-REFRESH should be called to % initialize the state of the display. % % 20-Dec-82 Alan Snyder % Added cached methods for terminal Convert-Character and Get-Character. % 17-Dec-82 Alan Snyder % Revised for the 9836 to write whole lines at a time, keeping track only % of which lines have been modified, or write each character directly, % according to the DIRECT? variable. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-physical-screen (display-terminal) (make-instance 'physical-screen 'terminal display-terminal)) (defflavor physical-screen (height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column cursor-row % desired cursor position after refresh cursor-column % desired cursor position after refresh terminal % the display terminal new-image % image for next refresh row-modified? % which rows need to be rewritten? (direct? T) % write directly to the terminal write-char-method % terminal's write-char method write-line-method % terminal's write-line method move-cursor-method % terminal's move-cursor method get-char-method % terminal's get-character method convert-char-method % terminal's convert-character method ) () (gettable-instance-variables height width cursor-row cursor-column) (settable-instance-variables direct?) (initable-instance-variables terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (physical-screen ring-bell) () (=> terminal ring-bell)) (defmethod (physical-screen enter-raw-mode) () (=> terminal enter-raw-mode)) (defmethod (physical-screen leave-raw-mode) () (=> terminal leave-raw-mode)) (defmethod (physical-screen get-character) () (apply get-char-method (list terminal))) (defmethod (physical-screen convert-character) (ch) (apply convert-char-method (list terminal ch))) (defmethod (physical-screen normal-enhancement) () (=> terminal normal-enhancement)) (defmethod (physical-screen highlighted-enhancement) () (=> terminal highlighted-enhancement)) (defmethod (physical-screen supported-enhancements) () (=> terminal supported-enhancements)) (defmethod (physical-screen write) (ch row col) (when (not (= ch (image-fetch new-image row col))) (image-store new-image row col ch) (if direct? (apply write-char-method (list terminal row col ch)) (vector-store row-modified? row T) ))) (defmethod (physical-screen set-cursor-position) (row col) (setf cursor-row row) (setf cursor-column col) (if direct? (apply move-cursor-method (list terminal row col))) ) (defmethod (physical-screen refresh) (breakout-allowed) (when (and (not direct?) (not (and breakout-allowed (input-available?))) ) (for (from row 0 maxrow) (when (vector-fetch row-modified? row)) (do (apply write-line-method (list terminal row (vector-fetch new-image row))) (vector-store row-modified? row NIL) )) (apply move-cursor-method (list terminal cursor-row cursor-column)) )) (defmethod (physical-screen full-refresh) (breakout-allowed) (=> terminal erase) (when (not (and breakout-allowed (input-available?))) (for (from row 0 maxrow) (do (apply write-line-method (list terminal row (vector-fetch new-image row))) (vector-store row-modified? row NIL) )) (apply move-cursor-method (list terminal cursor-row cursor-column)) )) (defmethod (physical-screen write-to-stream) (s) (for (from row 0 maxrow) (with line) (do (setf line (vector-fetch new-image row)) (for (from col 0 maxcol) (do (=> s putc (dc-character-code (vector-fetch line col)))) ) (=> s put-newline) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (physical-screen init) (init-plist) % For internal use only! (setf height (=> terminal height)) (setf maxrow (- height 1)) (setf width (=> terminal width)) (setf maxcol (- width 1)) (setf cursor-row 0) (setf cursor-column 0) (setf new-image (=> self create-image)) (setf row-modified? (make-vector height NIL)) (setf write-char-method (object-get-handler terminal 'write-char)) (setf write-line-method (object-get-handler terminal 'write-line)) (setf move-cursor-method (object-get-handler terminal 'move-cursor)) (setf get-char-method (object-get-handler terminal 'get-character)) (setf convert-char-method (object-get-handler terminal 'convert-character)) ) (defmethod (physical-screen create-image) () (let ((image (MkVect maxrow)) (line (MkVect maxcol)) ) (for (from col 0 maxcol) (do (vector-store line col #\space)) ) (for (from row 0 maxrow) (do (vector-store image row (copyvector line))) ) image)) |
Added psl-1983/3-1/windows/display-char.sl version [7154b7f967].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DISPLAY-CHAR.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 8 October 1982 % % This file defines MACROS. Load it at Compile Time! % % Display characters are ASCII characters that are "tagged" with display % enhancement bits. They are used by the Windows package. This file defines % macros for creating and manipulating display characters. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load fast-int) (put 'INVERSE-VIDEO 'enhancement-bits 1) (put 'BLINK 'enhancement-bits 2) (put 'UNDERLINE 'enhancement-bits 4) (put 'INTENSIFY 'enhancement-bits 8) (dm dc-make-enhancement-mask (form) (setf form (cdr form)) (let ((mask 0) bits) (for (in keyword form) (do (if (setf bits (get keyword 'enhancement-bits)) (setf mask (| mask bits)) (StdError (BldMsg "Undefined enhancement: %p" keyword)) ))) (<< mask 8))) (defmacro dc-make-font-mask (font-number) `(<< ,font-number 12)) (defmacro display-character-cons (enhancement-mask font-mask char-code) `(| (| ,enhancement-mask ,font-mask) ,char-code)) (defmacro dc-enhancement-mask (dc) `(& ,dc 16#F00)) (defmacro dc-enhancement-index (dc) % Use this to index an array. `(& (>> ,dc 8) 16#F)) (defmacro dc-font-mask (dc) `(& ,dc 16#F000)) (defmacro dc-font-number (dc) `(>> ,dc 12)) (defmacro dc-character-code (dc) `(& ,dc 16#FF)) |
Added psl-1983/3-1/windows/display-char.t version [a91d191dd5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NOTES ON THE DISPLAY CHARACTER DATATYPE Cris Perdue 10/11/82 File: PW:DISPLAY-CHAR.T ----------------------------------- This module provides a set of macros for manipulating "display-character" objects. These objects are represented to LISP as integers, but are dealt with as a separate type of object. (DC-MAKE-ENHANCEMENT-MASK KEYWORD . . . ) Macro This macro generates a specific enhancement mask object. The keywords are unevaluated identifiers. At present, the possible keywords are INVERSE-VIDEO, BLINK, UNDERLINE, and INTENSIFY, which should be meaningful with respect to HP terminals. (DC-MAKE-FONT-MASK FONT-NUMBER) Macro This makes a font mask object, given a font number. Font numbers have no definition yet, because we have no fonts. (DISPLAY-CHARACTER-CONS ENHANCEMENT-MASK FONT-MASK CHAR-CODE) Macro This macro generates a display character object, given an enhancement mask, a font mask, and a character code. The mask objects' purpose in life is to be used as arguments to this function and to be compared against each other. (DC-ENHANCEMENT-MASK DC) Macro Extracts the enhancement mask from a display character. (DC-ENHANCEMENT-INDEX DC) Macro There are a finite number of different combinations of display enhancements that are possible for a display-character. This macro returns an integer in the range from 0 that uniquely identifies the combination of enhancements in effect for this display-character. There should probably be a symbolic constant giving the maximum value for the identifying integer. With N different enhancements, the value turns out to be 2 raised to the Nth power, minus 1. (DC-FONT-MASK DC) Macro Extracts the font mask from a display character. (DC-FONT-NUMBER DC) Macro Obtains the font number from a display character. (DC-CHARACTER-CODE DC) Macro Obtains the character code from a display character object. |
Added psl-1983/3-1/windows/font8.sl version [4c89248888].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Font8.SL - Font Description with 8-bit wide characters % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 March 1983 (code taken from 9836-COLOR.SL) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-vectors)) % Font8-Patterns is a vector of 256 elements. Each element is either NIL or a % Vector of integers. If NIL, the character has no definition and should be % displayed as blank space. If a Vector, then each Integer in the Vector % represents one scan line of the character, right adjusted, starting with the % top scan line. Blank scan lines at the bottom of the raster are not % included in the vector. The function fixup-font-patterns, defined at the % end of this file, can be used to convert this vector so that all elements % are vectors with a minimum size. The recommended character height is 14 % scan lines, which includes interline spacing. (fluid '(font8-patterns)) (setf font8-patterns (vector % this vector must go in the heap, since it may be modified NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL [2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00000000 2#00000000 2#00010000 2#00010000 ] [2#00100100 2#00100100 2#00100100 2#00100100 ] [2#00000000 2#00000000 2#01000100 2#01000100 2#11111110 2#01000100 2#01000100 2#11111110 2#01000100 2#01000100 ] [2#00010000 2#01111100 2#11010110 2#10010000 2#11010000 2#01111100 2#00010110 2#00010010 2#11010110 2#01111100 2#00010000 ] [2#01100000 2#10010000 2#10010010 2#01100100 2#00001000 2#00010000 2#00100000 2#01001100 2#10010010 2#00010010 2#00001100 ] [2#00110000 2#01001000 2#10001000 2#10001000 2#10010000 2#01100000 2#01100000 2#10010000 2#10001010 2#10000100 2#01111010 ] [2#00001000 2#00001000 2#00010000 2#00010000 ] [2#00001000 2#00010000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00010000 2#00001000 ] [2#00100000 2#00010000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00010000 2#00100000 ] [2#00000000 2#00000000 2#10010010 2#01010100 2#00111000 2#11111110 2#00111000 2#01010100 2#10010010 ] [2#00000000 2#00000000 2#00010000 2#00010000 2#00010000 2#11111110 2#00010000 2#00010000 2#00010000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00011000 2#00011000 2#00010000 2#00100000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#11111110 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00110000 2#00110000 ] [2#00000010 2#00000010 2#00000100 2#00000100 2#00001000 2#00001000 2#00010000 2#00010000 2#00100000 2#00100000 2#01000000 2#01000000 ] [2#00111000 2#01000100 2#10000010 2#10000110 2#10001010 2#10010010 2#10100010 2#11000010 2#10000010 2#01000100 2#00111000 ] [2#00010000 2#00110000 2#01010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#01111100 ] [2#01111100 2#11000110 2#00000010 2#00000100 2#00001000 2#00010000 2#00100000 2#01000000 2#10000000 2#10000000 2#11111110 ] [2#01111100 2#11000110 2#00000010 2#00000010 2#00000110 2#01111100 2#00000110 2#00000010 2#00000010 2#11000110 2#01111100 ] [2#00001000 2#00011000 2#00101000 2#01001000 2#10001000 2#11111110 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 ] [2#11111110 2#10000000 2#10000000 2#10000000 2#10000000 2#11111100 2#00000110 2#00000010 2#00000010 2#11000110 2#01111100 ] [2#01111100 2#11000110 2#10000000 2#10000000 2#10000000 2#11111100 2#10000110 2#10000010 2#10000010 2#11000110 2#01111100 ] [2#11111110 2#00000010 2#00000010 2#00000010 2#00000100 2#00001000 2#00010000 2#00100000 2#00100000 2#00100000 2#00100000 ] [2#01111100 2#11000110 2#10000010 2#10000010 2#11000110 2#01111100 2#11000110 2#10000010 2#10000010 2#11000110 2#01111100 ] [2#01111100 2#11000110 2#10000010 2#10000010 2#11000110 2#01111010 2#00000010 2#00000010 2#00000010 2#11000110 2#01111100 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#00110000 2#00110000 2#00000000 2#00000000 2#00110000 2#00110000 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00011000 2#00011000 2#00000000 2#00000000 2#00011000 2#00011000 2#00010000 2#00100000 ] [2#00000100 2#00001000 2#00010000 2#00100000 2#01000000 2#10000000 2#01000000 2#00100000 2#00010000 2#00001000 2#00000100 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#11111110 2#00000000 2#00000000 2#11111110 2#00000000 2#00000000 2#00000000 ] [2#01000000 2#00100000 2#00010000 2#00001000 2#00000100 2#00000010 2#00000100 2#00001000 2#00010000 2#00100000 2#01000000 ] [2#01111100 2#10000010 2#10000010 2#00000010 2#00000100 2#00001000 2#00010000 2#00010000 2#00000000 2#00000000 2#00010000 ] [2#00000000 2#00000000 2#00000000 2#01111110 2#10000010 2#10111010 2#10101010 2#10111010 2#10001110 2#10000000 2#01111110 ] [2#00010000 2#00101000 2#01000100 2#10000010 2#10000010 2#10000010 2#11111110 2#10000010 2#10000010 2#10000010 2#10000010 ] [2#11111100 2#10000110 2#10000010 2#10000010 2#10000110 2#11111100 2#10000110 2#10000010 2#10000010 2#10000110 2#11111100 ] [2#01111100 2#11000110 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#11000110 2#01111100 ] [2#11111000 2#10001100 2#10000110 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000110 2#10001100 2#11111000 ] [2#11111110 2#10000000 2#10000000 2#10000000 2#10000000 2#11111000 2#10000000 2#10000000 2#10000000 2#10000000 2#11111110 ] [2#11111110 2#10000000 2#10000000 2#10000000 2#11111000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 ] [2#01111100 2#11000110 2#10000000 2#10000000 2#10000000 2#10000000 2#10001110 2#10000010 2#10000010 2#11000110 2#01111100 ] [2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#11111110 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 ] [2#01111100 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#01111100 ] [2#00000100 2#00000100 2#00000100 2#00000100 2#00000100 2#00000100 2#00000100 2#00000100 2#10000100 2#11001100 2#01111000 ] [2#10000010 2#10000100 2#10001000 2#10010000 2#10100000 2#11000000 2#10100000 2#10010000 2#10001000 2#10000100 2#10000010 ] [2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#11111110 ] [2#10000010 2#11000110 2#10101010 2#10111010 2#10010010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 ] [2#11000010 2#11000010 2#11100010 2#10100010 2#10110010 2#10010010 2#10011010 2#10001010 2#10001110 2#10000110 2#10000110 ] [2#01111100 2#11000110 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#11000110 2#01111100 ] [2#11111100 2#10000110 2#10000010 2#10000010 2#10000110 2#11111100 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 ] [2#00111000 2#01000100 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10010010 2#10011010 2#01001100 2#00111110 ] [2#11111100 2#10000110 2#10000010 2#10000010 2#10000110 2#11111100 2#10100000 2#10010000 2#10001000 2#10000100 2#10000010 ] [2#01111100 2#11000110 2#10000000 2#10000000 2#11000000 2#01111100 2#00000110 2#00000010 2#00000010 2#11000110 2#01111100 ] [2#11111110 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 ] [2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#11000110 2#01111100 ] [2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#01000100 2#01000100 2#00101000 2#00101000 2#00010000 ] [2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10010010 2#10010010 2#10101010 2#10101010 2#11000110 2#10000010 ] [2#10000010 2#01000100 2#01000100 2#00101000 2#00101000 2#00010000 2#00101000 2#00101000 2#01000100 2#01000100 2#10000010 ] [2#10000010 2#01000100 2#01000100 2#00101000 2#00101000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 ] [2#11111110 2#00000010 2#00000010 2#00000100 2#00001000 2#01111100 2#00100000 2#01000000 2#10000000 2#10000000 2#11111110 ] [2#00111000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 2#00111000 ] [2#01000000 2#01000000 2#00100000 2#00100000 2#00010000 2#00010000 2#00001000 2#00001000 2#00000100 2#00000100 2#00000010 2#00000010 ] [2#00111000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00111000 ] [2#00010000 2#00101000 2#01000100 2#10000010 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#00000000 2#11111110 ] [2#00010000 2#00010000 2#00001000 2#00001000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111100 2#00000010 2#00000010 2#01111110 2#10000010 2#10000110 2#01111010 ] [2#10000000 2#10000000 2#10000000 2#10000000 2#10111100 2#11000010 2#10000010 2#10000010 2#10000010 2#11000010 2#10111100 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111100 2#10000010 2#10000000 2#10000000 2#10000000 2#10000010 2#01111100 ] [2#00000010 2#00000010 2#00000010 2#00000010 2#01111010 2#10000110 2#10000010 2#10000010 2#10000010 2#10000110 2#01111010 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111100 2#10000010 2#10000010 2#11111100 2#10000000 2#10000000 2#01111110 ] [2#00011100 2#00100010 2#00100000 2#00100000 2#00100000 2#11111000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111100 2#10000010 2#10000010 2#10000010 2#01111110 2#00000010 2#00000010 2#10000010 2#01111100 ] [2#10000000 2#10000000 2#10000000 2#10000000 2#11111100 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 2#10000010 ] [2#00000000 2#00010000 2#00000000 2#00000000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00000000 ] [2#00000000 2#00001000 2#00000000 2#00000000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#00001000 2#01001000 2#00110000 2#00000000 ] [2#10000000 2#10000000 2#10000000 2#10000000 2#10000100 2#10001000 2#10010000 2#10100000 2#11010000 2#10001000 2#10000100 ] [2#01110000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#01111100 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#11101100 2#10010010 2#10010010 2#10010010 2#10010010 2#10010010 2#10010010 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#11111000 2#10000100 2#10000100 2#10000100 2#10000100 2#10000100 2#10000100 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111000 2#10000100 2#10000100 2#10000100 2#10000100 2#10000100 2#01111000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10111100 2#11000010 2#10000010 2#10000010 2#10000010 2#11000010 2#10111100 2#10000000 2#10000000 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111010 2#10000110 2#10000010 2#10000010 2#10000010 2#10000110 2#01111010 2#00000010 2#00000010 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10111100 2#11000010 2#10000000 2#10000000 2#10000000 2#10000000 2#10000000 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#01111100 2#10000010 2#10000000 2#01111100 2#00000010 2#10000010 2#01111100 2#00000000 ] [2#00000000 2#00100000 2#00100000 2#00100000 2#11111000 2#00100000 2#00100000 2#00100000 2#00100000 2#00100100 2#00011000 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10000100 2#10000100 2#10000100 2#10000100 2#10000100 2#10001100 2#01110100 2#00000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10000010 2#10000010 2#01000100 2#01000100 2#00101000 2#00111000 2#00010000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10000010 2#10000010 2#10000010 2#10010010 2#10101010 2#11000110 2#10000010 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10000010 2#01000100 2#00101000 2#00010000 2#00101000 2#01000100 2#10000010 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10000010 2#01000100 2#01000100 2#00101000 2#00010000 2#00100000 2#01000000 2#01000000 2#10000000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#11111110 2#00000100 2#00001000 2#00010000 2#00100000 2#01000000 2#11111110 ] [2#00001110 2#00010000 2#00010000 2#00010000 2#00110000 2#11100000 2#00110000 2#00010000 2#00010000 2#00010000 2#00001110 ] [2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 2#00010000 ] [2#11100000 2#00010000 2#00010000 2#00010000 2#00011000 2#00001110 2#00011000 2#00010000 2#00010000 2#00010000 2#11100000 ] [2#00000000 2#00000000 2#00000000 2#00000000 2#10011100 2#01110010 ] NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL )) (de fixup-font-patterns (patterns character-height) % Ensure that each element of a font pattern vector is a vector with at % least Character-Height elements. This modification does not change the % appearance of the font, but allows the code using the font description to % be more efficient (avoid bounds checking, etc.) (let ((blank-pattern (make-vector character-height 0))) (for (from i 0 (vector-upper-bound patterns)) (do (let ((fc (vector-fetch patterns i))) (when (null fc) (setf fc blank-pattern)) (when (< (vector-size fc) character-height) (setf fc (concat fc (make-vector (- character-height (vector-size fc)) 0)))) (vector-store patterns i fc) ))))) |
Added psl-1983/3-1/windows/hp2648a.sl version [7eeaa0a8f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % HP2648A.SL - Terminal Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor hp2648a ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) markers % vector indicating locations of field markers (marker-table % table for generating markers (Vector (char @) (char B) (char A) (char C) (char D) (char F) (char E) (char G) (char H) (char J) (char I) (char K) (char L) (char N) (char M) (char O) )) ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move () `(out-chars ESC & !a))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (hp2648a get-character) () (& (PBIN) 8#377) ) (defmethod (hp2648a ring-bell) () (out-char BELL) ) (defmethod (hp2648a move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move) (out-n column) (out-char C)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move) (out-n row) (out-char R)))) (t % arbitrary movement (out-move) (out-n row) (out-char (lower R)) (out-n column) (out-char C))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (hp2648a enter-raw-mode) () (when (not raw-mode) (EchoOff) (out-chars ESC & !s 1 A) % Enable Keypad (setf raw-mode T))) (defmethod (hp2648a leave-raw-mode) () (when raw-mode (setf raw-mode NIL) (out-chars ESC & !s 0 A) % Disable Keypad (EchoOn))) (defmethod (hp2648a erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (for (from row 0 maxrow) (do (let ((marker-line (vector-fetch markers row))) (for (from col 0 maxcol) (do (vector-store marker-line col NIL)) )))) ) (defmethod (hp2648a clear-line) () (out-chars ESC K) (let ((marker-line (vector-fetch markers cursor-row))) (for (from col cursor-column maxcol) (do (vector-store marker-line col NIL)) ))) (defmethod (hp2648a convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (hp2648a normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (hp2648a highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (hp2648a supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (hp2648a update-line) (row old-line new-line columns) % Old-Line is updated. % This code is particularly complicated because of the way HP terminals % implement display enhancements using field markers. Most terminals % don't require this level of complexity. (prog (last-nonblank-column col terminal-enhancement old new marker-line first-col last-col) (setf first-col (car columns)) (setf last-col (cdr columns)) (setf marker-line (vector-fetch markers row)) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (if (> first-col last-col) (return NIL)) % No change at all! (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. % Using ClearEOL can cause problems when display enhancements are used. If % you write to the position just to the right of the terminal's % end-of-line, the existing field will be extended. To avoid this problem, % we will avoid using ClearEOL where the immediately preceding character % has a non-zero enhancement. (when (= (vector-fetch new-line last-col) #\space) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) #\space) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2)) (or (<= last-nonblank-column 0) (~= (dc-enhancement-mask (vector-fetch old-line last-nonblank-column)) 0))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col #\space) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (other than those that will be taken care % of by ClearEOL): (setf col first-col) % current column under examination (setf old (vector-fetch old-line col)) % terminal's contents at that location (setf new (vector-fetch new-line col)) % new contents for that location (setf terminal-enhancement (dc-enhancement-mask old)) % terminal's enhancement for that location % (enhancement in OLD will not always be correct as we go) (if (not (and (= cursor-row row) (<= cursor-column col))) (=> self move-cursor row col)) (while (<= col last-col) % First, we check to see if we need to write a new field marker. % A field marker is needed if the terminal's idea of the current % character's enhancement is different than the desired enhancement. (when (~= terminal-enhancement (dc-enhancement-mask new)) (=> self move-cursor-forward col old-line) (=> self write-field-marker new) ) % Next, we check to see if we need to write a new character code. (when (~= old new) % check this first for efficiency (let ((old-code (dc-character-code old)) (new-code (dc-character-code new)) ) (when (or (and (= new-code #\space) (= col last-col)) % last SPACE must be written (may extend EOL) (~= old-code new-code)) (=> self move-cursor-forward col old-line) (PBOUT new-code) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0))) )) (vector-store old-line col new) ) % The following code is executed only if there is a next character. (if (< col maxcol) (let* ((next-col (+ col 1)) (next-old (vector-fetch old-line next-col)) (next-new (vector-fetch new-line next-col)) ) % Compute the terminal's idea of the enhancement for the next % character. This is invalid if we are about to ClearEOL, but % that case doesn't matter. (setf terminal-enhancement (if (vector-fetch marker-line next-col) % field marker there (dc-enhancement-mask next-old) (dc-enhancement-mask new))) (setf old next-old) (setf new next-new) )) (setf col (+ col 1)) ) % Check to see if a final field marker is needed. (when (and (<= col maxcol) (or (null last-nonblank-column) (<= col last-nonblank-column)) (~= terminal-enhancement (dc-enhancement-mask old))) (=> self move-cursor-forward col old-line) (=> self write-field-marker new) ) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (hp2648a init) () (setf markers (MkVect maxrow)) (for (from row 0 maxrow) (do (vector-store markers row (MkVect maxcol))) ) ) (defmethod (hp2648a move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move) (out-n column) (out-char C) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (hp2648a write-field-marker) (ch) (out-chars ESC & !d) (PBOUT (vector-fetch marker-table (dc-enhancement-index ch))) (vector-store (vector-fetch markers cursor-row) cursor-column T) ) |
Added psl-1983/3-1/windows/perq.sl version [3cd2f05efb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PERQ.SL - Terminal Interface % % Author: Robert Kessler, U of Utah % Date: 27 Jan 1983 % based on teleray.SL by G.Q.Maguire,Jr. % U of Utah % 3 November 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor perq ( (height 70) % number of rows (0 indexed) (maxrow 69) % highest numbered row (width 84) % number of columns (0 indexed) (maxcol 83) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (perq get-character) () (& (PBIN) 8#377) ) (defmethod (perq ring-bell) () (out-char BELL) ) (defmethod (perq move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (perq enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (perq leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (perq erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (perq clear-line) () (out-chars ESC K) ) (defmethod (perq convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (perq normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (perq highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (perq supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (perq update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (PBOUT new-code) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0) )) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (perq init) () ) (defmethod (perq &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (perq &set-terminal-enhancement) (enh) ) |
Added psl-1983/3-1/windows/physical-screen.sl version [41c073c121].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 20 December 1982 % % Adapted from Will Galway's EMODE Virtual Screen package. % % A physical screen is a rectangular character display. Changes to the physical % screen are made using the Write operation. These changes are saved and sent % to the actual display only when REFRESH or FULL-REFRESH is performed. % FULL-REFRESH should be called to initialize the state of the display. % % 20-Dec-82 Alan Snyder % Added cached terminal methods to improve efficiency. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-physical-screen (display-terminal) (make-instance 'physical-screen 'terminal display-terminal)) (defflavor physical-screen (height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column cursor-row % desired cursor position after refresh cursor-column % desired cursor position after refresh changed-row-range % bounds on rows where new-image differs from display changed-column-ranges % bounds on columns in each row terminal % the display terminal new-image % new image (after refresh) displayed-image % image on the display terminal update-line-method % terminal's update-line method move-cursor-method % terminal's move-cursor method get-char-method % terminal's get-character method convert-char-method % terminal's convert-character method ) () (gettable-instance-variables height width cursor-row cursor-column) (initable-instance-variables terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (defmacro range-create () `(cons 10000 0)) (defmacro range-cons (min max) `(cons ,min ,max)) (defmacro range-min (r) `(car ,r)) (defmacro range-max (r) `(cdr ,r)) (defmacro range-set-min (r x) `(rplaca ,r ,x)) (defmacro range-set-max (r x) `(rplacd ,r ,x)) (defmacro range-reset (r) `(let ((*r* ,r)) (rplaca *r* 10000) (rplacd *r* 0))) (defmacro range-empty? (r) `(< (range-max ,r) (range-min ,r))) (defmacro range-within? (r x) `(and (<= (range-min ,r) ,x) (<= ,x (range-max ,r)))) (defmacro range-extend (r x) `(let ((*r* ,r) (*x* ,x)) % New minimum if x < old minimum (if (< *x* (range-min *r*)) (range-set-min *r* *x*)) % New maximum if x > old maximum. (if (> *x* (range-max *r*)) (range-set-max *r* *x*)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (physical-screen ring-bell) () (=> terminal ring-bell)) (defmethod (physical-screen enter-raw-mode) () (=> terminal enter-raw-mode)) (defmethod (physical-screen leave-raw-mode) () (=> terminal leave-raw-mode)) (defmethod (physical-screen get-character) () (apply get-char-method (list terminal))) (defmethod (physical-screen convert-character) (ch) (apply convert-char-method (list terminal ch))) (defmethod (physical-screen normal-enhancement) () (=> terminal normal-enhancement)) (defmethod (physical-screen highlighted-enhancement) () (=> terminal highlighted-enhancement)) (defmethod (physical-screen supported-enhancements) () (=> terminal supported-enhancements)) (defmethod (physical-screen write) (ch row col) (when (~= ch (image-fetch new-image row col)) (image-store new-image row col ch) (range-extend changed-row-range row) (range-extend (vector-fetch changed-column-ranges row) col) )) (defmethod (physical-screen set-cursor-position) (row col) (setf cursor-row row) (setf cursor-column col)) (defmethod (physical-screen refresh) (breakout-allowed) (for (from row (range-min changed-row-range) (range-max changed-row-range)) (for break-count 0 (+ break-count 1)) (with changed-columns breakout) (until (and breakout-allowed (= (& break-count 3) 0) % test every 4 lines (input-available?) (setf breakout T))) (do (setf changed-columns (vector-fetch changed-column-ranges row)) (when (not (range-empty? changed-columns)) (apply update-line-method (list terminal row (vector-fetch displayed-image row) (vector-fetch new-image row) changed-columns )) (range-reset changed-columns))) (finally (range-set-min changed-row-range row) (if (range-empty? changed-row-range) (range-reset changed-row-range)) (if (not (or breakout (and breakout-allowed (input-available?)))) (apply move-cursor-method (list terminal cursor-row cursor-column))) ) )) (defmethod (physical-screen full-refresh) (breakout-allowed) (=> terminal erase) (for (from row 0 maxrow) (with line range) (do (setq range (vector-fetch changed-column-ranges row)) (range-set-min range 0) (range-set-max range maxcol) (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) )) (range-set-min changed-row-range 0) (range-set-max changed-row-range maxrow) (=> self refresh breakout-allowed) ) (defmethod (physical-screen write-to-stream) (s) (for (from row 0 maxrow) (with line) (do (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (=> s putc (dc-character-code (vector-fetch line col)))) ) (=> s put-newline) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (physical-screen init) (init-plist) % For internal use only! (setf height (=> terminal height)) (setf maxrow (- height 1)) (setf width (=> terminal width)) (setf maxcol (- width 1)) (setf cursor-row 0) (setf cursor-column 0) (setf displayed-image (=> self create-image)) (setf new-image (=> self create-image)) (setf changed-row-range (range-create)) (setf changed-column-ranges (MkVect maxrow)) (for (from row 0 maxrow) (do (vector-store changed-column-ranges row (range-create)))) (setf update-line-method (object-get-handler terminal 'update-line)) (setf move-cursor-method (object-get-handler terminal 'move-cursor)) (setf get-char-method (object-get-handler terminal 'get-character)) (setf convert-char-method (object-get-handler terminal 'convert-character)) ) (defmethod (physical-screen create-image) () (let ((image (MkVect maxrow)) (line (MkVect maxcol)) ) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) (for (from row 0 maxrow) (do (vector-store image row (copyvector line))) ) image)) |
Added psl-1983/3-1/windows/shared-physical-screen.sl version [eaaf319c74].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Shared-Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 22 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A shared-physical-screen is a rectangular character display whose display % area is shared by a number of different owners. An owner can be any object % that supports the following operations: % % Assert-Ownership () - assert ownership of all desired screen locations % Send-Changes (break-ok) - send all changed contents to the shared screen % Send-Contents (break-ok) - send entire contents to the shared screen % Screen-Cursor-Position () - return desired cursor position on screen % % Each character position on the physical screen is owned by a single owner. % Each owner is responsible for asserting ownership of those character % positions it wishes to be able to write on. The actual ownership of each % character position is determined by a prioritized list of owners. Owners % assert ownership in reverse order of priority; the highest priority owner % therefore appears to "overlap" all other owners. % % A shared physical screen object provides an opaque interface: no access to % the underlying physical screen object should be required. % % 22-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 27-Dec-82 Alan Snyder % Changed SELECT-PRIMARY-OWNER and REMOVE-OWNER to avoid redundant % recomputation (and screen rewriting). % 21-Dec-82 Alan Snyder % Efficiency hacks: Special tests for owners that are virtual-screens. % Added methods: &GET-OWNER-CHANGES, &GET-OWNER-CONTENTS, and % &ASSERT-OWNERSHIP. % 16-Dec-82 Alan Snyder % Bug fix: SET-SCREEN failed to update size (invoked the wrong method). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors)) (de create-shared-physical-screen (physical-screen) (make-instance 'shared-physical-screen 'screen physical-screen)) (defflavor shared-physical-screen ( height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column (owner-list NIL) % prioritized list of owners (lowest priority first) (recalculate T) % T => must recalculate ownership owner-map % maps screen location to owner (or NIL) screen % the physical-screen ) () (gettable-instance-variables height width) (initable-instance-variables screen) ) (declare-flavor physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro map-fetch (map row col) `(vector-fetch (vector-fetch ,map ,row) ,col)) (defmacro map-store (map row col value) `(vector-store (vector-fetch ,map ,row) ,col ,value)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (shared-physical-screen ring-bell) () (=> screen ring-bell)) (defmethod (shared-physical-screen enter-raw-mode) () (=> screen enter-raw-mode)) (defmethod (shared-physical-screen leave-raw-mode) () (=> screen leave-raw-mode)) (defmethod (shared-physical-screen get-character) () (=> screen get-character)) (defmethod (shared-physical-screen convert-character) (ch) (=> screen convert-character ch)) (defmethod (shared-physical-screen normal-enhancement) () (=> screen normal-enhancement)) (defmethod (shared-physical-screen highlighted-enhancement) () (=> screen highlighted-enhancement)) (defmethod (shared-physical-screen supported-enhancements) () (=> screen supported-enhancements)) (defmethod (shared-physical-screen write-to-stream) (s) (=> screen write-to-stream s)) (defmethod (shared-physical-screen set-screen) (new-screen) (setf screen new-screen) (=> self &new-screen) ) (defmethod (shared-physical-screen owner) (row col) % Return the current owner of the specified screen location. (if recalculate (=> self &recalculate-ownership)) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-fetch owner-map row col))) (defmethod (shared-physical-screen select-primary-owner) (owner) % Make the specified OWNER the primary owner (adding it to the list of owners, % if not already there). (when (not (eq (lastcar owner-list) owner)) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf owner-list (aconc owner-list owner)) (when (not recalculate) (=> self &assert-ownership owner) (=> self &get-owner-contents owner nil) (=> self &update-cursor owner) ))) (defmethod (shared-physical-screen remove-owner) (owner) % Remove the specified owner from the list of owners. The owner will lose % ownership of his screen area. Screen ownership will be recalculated in its % entirety when necessary (to determine the new ownership of the screen area). (when (memq owner owner-list) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf recalculate T) )) (defmethod (shared-physical-screen refresh) (breakout-allowed) % Update the screen: obtain changed contents from the owners, % send it to the screen, refresh the screen. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen refresh breakout-allowed)) (defmethod (shared-physical-screen full-refresh) (breakout-allowed) % Just like REFRESH, except that the screen is cleared first. This operation % should be used to initialize the state of the screen when the program % starts or when uncontrolled output may have occured. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen full-refresh breakout-allowed)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods % The following methods are for use only by owners to perform the % AssertOwnership operation when invoked by this object: (defmethod (shared-physical-screen set-owner) (row col owner) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-store owner-map row col owner))) (defmethod (shared-physical-screen set-owner-region) (row col h w owner) % This method provided for convenience and efficiency. (let ((last-row (+ row (- h 1))) (last-col (+ col (- w 1))) (map owner-map) ) (cond ((and (<= row maxrow) (<= col maxcol) (>= last-row 0) (>= last-col 0)) (if (< row 0) (setf row 0)) (if (< col 0) (setf col 0)) (if (> last-row maxrow) (setf last-row maxrow)) (if (> last-col maxcol) (setf last-col maxcol)) (for (from r row last-row) (do (for (from c col last-col) (do (map-store map r c owner)) ))))))) % The following method is for use only by owners: (defmethod (shared-physical-screen write) (ch row col owner) % Conditional write: write the specified character to the specified location % only if that location is owned by the specified owner. The actual display % will not be updated until REFRESH or FULL-REFRESH is performed. (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (progn (if recalculate (=> self &recalculate-ownership)) (if (eq owner (map-fetch owner-map row col)) (=> screen write ch row col))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (shared-physical-screen init) (init-plist) (=> self &new-screen) ) (defmethod (shared-physical-screen &new-screen) () (setf height (=> screen height)) (setf width (=> screen width)) (=> self &new-size) ) (defmethod (shared-physical-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf owner-map (mkvect maxrow)) (for (from row 0 maxrow) (do (iputv owner-map row (mkvect maxcol)))) (setf recalculate t)) (defmethod (shared-physical-screen &recalculate-ownership) () % Reset ownership to NIL, then ask all OWNERS to assert ownership. % Then ask all OWNERS to send all contents. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (map-store map r c NIL)))))) (for (in owner owner-list) (do (=> self &assert-ownership owner))) (setf recalculate NIL) (=> self &get-owners-contents)) (defmethod (shared-physical-screen &get-owners-changes) (breakout-allowed) % Ask all OWNERS to send any changed contents. (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-changes owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-changes) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-changes owner breakout-allowed) (=> owner send-changes breakout-allowed) )) (defmethod (shared-physical-screen &get-owners-contents) (breakout-allowed) % Ask all OWNERS to send all of their contents; unowned screen area % is blanked. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (if (null (map-fetch map r c)) (=> screen write #\space r c))))))) (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-contents owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-contents) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-contents owner breakout-allowed) (=> owner send-contents breakout-allowed) )) (defmethod (shared-physical-screen &assert-ownership) (owner) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$assert-ownership owner) (=> owner assert-ownership) )) (defmethod (shared-physical-screen &update-cursor) (owner) (let ((pair (if (eq (object-type owner) 'virtual-screen) (virtual-screen$screen-cursor-position owner) (=> owner screen-cursor-position) ))) (if (PairP pair) (=> screen set-cursor-position (car pair) (cdr pair))))) (undeclare-flavor screen) |
Added psl-1983/3-1/windows/teleray.sl version [4c83f1a64a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TELERAY.SL - Terminal Interface % % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor teleray ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (teleray get-character) () (& (PBIN) 8#377) ) (defmethod (teleray ring-bell) () (out-char BELL) ) (defmethod (teleray move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (teleray enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (teleray leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (teleray erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (teleray clear-line) () (out-chars ESC K) ) (defmethod (teleray convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (teleray normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (teleray update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (if (> new-code 127) (progn (PBOUT 27) (PBOUT 82) (PBOUT (+ 64 (- new-code 128)))) (PBOUT new-code)) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0) )) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (teleray init) () ) (defmethod (teleray &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (teleray &set-terminal-enhancement) (enh) ) |
Added psl-1983/3-1/windows/vax-physical-screen.sl version [2959da1b1e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 20 December 1982 % % Adapted from Will Galway's EMODE Virtual Screen package. % % A physical screen is a rectangular character display. Changes to the physical % screen are made using the Write operation. These changes are saved and sent % to the actual display only when REFRESH or FULL-REFRESH is performed. % FULL-REFRESH should be called to initialize the state of the display. % % 20-Dec-82 Alan Snyder % Added cached terminal methods to improve efficiency. % % 3-Mar-83 17:40:36, Edit by GALWAY % Inserted calls to FlushStdOutputBuffer, to make refresh work on the % Vax. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-physical-screen (display-terminal) (make-instance 'physical-screen 'terminal display-terminal)) (defflavor physical-screen (height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column cursor-row % desired cursor position after refresh cursor-column % desired cursor position after refresh changed-row-range % bounds on rows where new-image differs from display changed-column-ranges % bounds on columns in each row terminal % the display terminal new-image % new image (after refresh) displayed-image % image on the display terminal update-line-method % terminal's update-line method move-cursor-method % terminal's move-cursor method get-char-method % terminal's get-character method convert-char-method % terminal's convert-character method ) () (gettable-instance-variables height width cursor-row cursor-column) (initable-instance-variables terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (defmacro range-create () `(cons 10000 0)) (defmacro range-cons (min max) `(cons ,min ,max)) (defmacro range-min (r) `(car ,r)) (defmacro range-max (r) `(cdr ,r)) (defmacro range-set-min (r x) `(rplaca ,r ,x)) (defmacro range-set-max (r x) `(rplacd ,r ,x)) (defmacro range-reset (r) `(let ((*r* ,r)) (rplaca *r* 10000) (rplacd *r* 0))) (defmacro range-empty? (r) `(< (range-max ,r) (range-min ,r))) (defmacro range-within? (r x) `(and (<= (range-min ,r) ,x) (<= ,x (range-max ,r)))) (defmacro range-extend (r x) `(let ((*r* ,r) (*x* ,x)) % New minimum if x < old minimum (if (< *x* (range-min *r*)) (range-set-min *r* *x*)) % New maximum if x > old maximum. (if (> *x* (range-max *r*)) (range-set-max *r* *x*)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (physical-screen ring-bell) () (=> terminal ring-bell)) (defmethod (physical-screen enter-raw-mode) () (=> terminal enter-raw-mode)) (defmethod (physical-screen leave-raw-mode) () (=> terminal leave-raw-mode)) (defmethod (physical-screen get-character) () (apply get-char-method (list terminal))) (defmethod (physical-screen convert-character) (ch) (apply convert-char-method (list terminal ch))) (defmethod (physical-screen normal-enhancement) () (=> terminal normal-enhancement)) (defmethod (physical-screen highlighted-enhancement) () (=> terminal highlighted-enhancement)) (defmethod (physical-screen supported-enhancements) () (=> terminal supported-enhancements)) (defmethod (physical-screen write) (ch row col) (when (~= ch (image-fetch new-image row col)) (image-store new-image row col ch) (range-extend changed-row-range row) (range-extend (vector-fetch changed-column-ranges row) col) )) (defmethod (physical-screen set-cursor-position) (row col) (setf cursor-row row) (setf cursor-column col)) (defmethod (physical-screen refresh) (breakout-allowed) (for (from row (range-min changed-row-range) (range-max changed-row-range)) (for break-count 0 (+ break-count 1)) (with changed-columns breakout) (until (and breakout-allowed (= (& break-count 3) 0) % test every 4 lines (input-available?) (setf breakout T))) (do (setf changed-columns (vector-fetch changed-column-ranges row)) (when (not (range-empty? changed-columns)) (apply update-line-method (list terminal row (vector-fetch displayed-image row) (vector-fetch new-image row) changed-columns )) (range-reset changed-columns) (FlushStdOutputBuffer))) (finally (range-set-min changed-row-range row) (if (range-empty? changed-row-range) (range-reset changed-row-range)) (if (not (or breakout (and breakout-allowed (input-available?)))) (apply move-cursor-method (list terminal cursor-row cursor-column))) % Perhaps the "move-cursor-method" should do the flushing? (FlushStdOutputBuffer) ) )) (defmethod (physical-screen full-refresh) (breakout-allowed) (=> terminal erase) (for (from row 0 maxrow) (with line range) (do (setq range (vector-fetch changed-column-ranges row)) (range-set-min range 0) (range-set-max range maxcol) (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) )) (range-set-min changed-row-range 0) (range-set-max changed-row-range maxrow) (=> self refresh breakout-allowed) ) (defmethod (physical-screen write-to-stream) (s) (for (from row 0 maxrow) (with line) (do (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (=> s putc (dc-character-code (vector-fetch line col)))) ) (=> s put-newline) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (physical-screen init) (init-plist) % For internal use only! (setf height (=> terminal height)) (setf maxrow (- height 1)) (setf width (=> terminal width)) (setf maxcol (- width 1)) (setf cursor-row 0) (setf cursor-column 0) (setf displayed-image (=> self create-image)) (setf new-image (=> self create-image)) (setf changed-row-range (range-create)) (setf changed-column-ranges (MkVect maxrow)) (for (from row 0 maxrow) (do (vector-store changed-column-ranges row (range-create)))) (setf update-line-method (object-get-handler terminal 'update-line)) (setf move-cursor-method (object-get-handler terminal 'move-cursor)) (setf get-char-method (object-get-handler terminal 'get-character)) (setf convert-char-method (object-get-handler terminal 'convert-character)) ) (defmethod (physical-screen create-image) () (let ((image (MkVect maxrow)) (line (MkVect maxcol)) ) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) (for (from row 0 maxrow) (do (vector-store image row (copyvector line))) ) image)) |
Added psl-1983/3-1/windows/virtual-screen.sl version [a771de14f2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Virtual-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 August 1982 % Revised: 22 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A virtual screen is an object that can be used as independent rectangular % character display, but in fact shares a physical screen with other objects. A % virtual screen object maintains a stored representation of the image on the % virtual screen, which is used to update the physical screen when new areas of % the virtual screen become "exposed". A virtual screen does not itself % maintain any information about changes to its contents. It sends all changes % directly to the physical screen as they are made, and sends the entire screen % contents to the physical screen upon its request. % % A virtual screen is a legitimate "owner" for a shared physical screen, in that % it satisfies the required interface. % % 22-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 28-Dec-82 Alan Snyder % Avoid writing to shared screen when virtual screen is not exposed. Add % WRITE-STRING and WRITE-VECTOR methods. Improve efficiency of CLEAR-TO-EOL % method. Remove patch that avoided old compiler bug. Reformat. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-virtual-screen (shared-physical-screen) (make-instance 'virtual-screen 'screen shared-physical-screen)) (defflavor virtual-screen ((height (=> screen height)) % number of rows (0 indexed) maxrow % highest numbered row (width (=> screen width)) % number of columns (0 indexed) maxcol % highest numbered column (row-origin 0) % position of upper left on the shared screen (column-origin 0) % position of upper left on the shared screen (default-enhancement (=> screen normal-enhancement)) (cursor-row 0) % the virtual cursor position (cursor-column 0) % the virtual cursor position (exposed? NIL) image % the virtual image screen % the shared-physical-screen ) () (gettable-instance-variables height width row-origin column-origin screen exposed?) (settable-instance-variables default-enhancement) (initable-instance-variables height width row-origin column-origin screen default-enhancement) ) (declare-flavor shared-physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (dm for-all-positions (form) % Executes the body repeatedly with the following variables % bound: ROW, COL, SCREEN-ROW, SCREEN-COL. `(for (from row 0 maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))))) (dm for-all-columns (form) % Executes the body repeatedly with the following variables % bound: COL, SCREEN-COL. `(for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen set-size) (new-height new-width) % Change the size of the screen. The screen is first DeExposed. The contents % are cleared. You must Expose the screen yourself if you want it to be % displayed. (=> self deexpose) (setf height new-height) (setf width new-width) (=> self &new-size) ) (defmethod (virtual-screen set-origin) (new-row new-column) % Change the location of the screen. The screen is first DeExposed. You must % Expose the screen yourself if you want it to be displayed. (=> self deexpose) (setf row-origin new-row) (setf column-origin new-column) ) (defmethod (virtual-screen set-cursor-position) (row column) (cond ((< row 0) (setf row 0)) ((> row maxrow) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((> column maxcol) (setf column maxcol))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (virtual-screen write) (ch row column) % Write one character using the default enhancement. (if (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc screen-row (+ column column-origin) self)) ))) (defmethod (virtual-screen write-range) (ch row left-column right-column) % Write repeatedly. (when (and (>= row 0) (<= row maxrow) (<= left-column maxcol) (>= right-column 0) ) (if (< left-column 0) (setf left-column 0)) (if (> right-column maxcol) (setf right-column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (for (from col left-column right-column) (do (image-store image row col dc) (if exposed? (=> screen write dc screen-row (+ col column-origin) self)) ))))) (defmethod (virtual-screen write-display-character) (dc row column) % Write one character (explicit enhancement) (when (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc (+ row row-origin) (+ column column-origin) self)) )) (defmethod (virtual-screen write-string) (row left-column s count) % S is a string of characters. Write S[0..COUNT-1] using the default % enhancement to the specified row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((smax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column smax) maxcol) (setf smax (- maxcol left-column))) (for (from i 0 smax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (string-fetch s i))) (setf ch (display-character-cons default-enhancement 0 ch)) (setf ch (=> screen convert-character ch)) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen write-vector) (row left-column v count) % V is a vector of display-characters. Write V[0..COUNT-1] to the specified % row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((vmax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column vmax) maxcol) (setf vmax (- maxcol left-column))) (for (from i 0 vmax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (vector-fetch v i))) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen clear) () (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for-all-positions (image-store image row col dc) ) (if exposed? (for-all-positions (=> screen write dc screen-row screen-col self) )) )) (defmethod (virtual-screen clear-to-end) (first-row) (if (< first-row 0) (setf first-row 0)) (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for (from row first-row maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for-all-columns (image-store image row col dc) ) (if exposed? (for-all-columns (=> screen write dc screen-row screen-col self) )) )))) (defmethod (virtual-screen clear-to-eol) (row first-column) (when (and (>= row 0) (<= row maxrow)) (if (< first-column 0) (setf first-column 0)) (let ((dc (display-character-cons default-enhancement 0 #\space)) (image-row (vector-fetch image row)) ) (setq dc (=> screen convert-character dc)) (for (from col first-column maxcol) (do (vector-store image-row col dc))) (if exposed? (let ((screen-row (+ row row-origin))) (for (from col (+ first-column column-origin) (+ maxcol column-origin)) (do (=> screen write dc screen-row col self))))) ))) (defmethod (virtual-screen expose) () % Expose the screen. Make it overlap all other screens. (=> screen select-primary-owner self) (setf exposed? T) ) (defmethod (virtual-screen deexpose) () % Remove the screen from the display. (when exposed? (=> screen remove-owner self) (setf exposed? NIL) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods: % The following methods are for use ONLY by the shared physical screen. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen send-changes) (breakout-allowed) % This method is invoked by the shared physical screen to obtain any buffered % changes to the virtual screen image. Since the virtual screen does not % buffer any changes, this method does nothing. ) (defmethod (virtual-screen send-contents) (breakout-allowed) % This method is invoked by the shared physical screen to obtain the entire % virtual screen image. (for-all-positions (let ((ch (image-fetch image row col))) (=> screen write ch screen-row screen-col self) ))) (defmethod (virtual-screen assert-ownership) () % This method is invoked by the shared physical screen to obtain the desired % area for the virtual screen. (=> screen set-owner-region row-origin column-origin height width self) ) (defmethod (virtual-screen screen-cursor-position) () % This method is invoked by the shared physical screen to obtain the desired % cursor position for the virtual screen. (cons (+ cursor-row row-origin) (+ cursor-column column-origin) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen init) (init-plist) (=> self &new-size) ) (defmethod (virtual-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf image (make-vector maxrow NIL)) (let ((line (make-vector maxcol #\space))) (for (from row 0 maxrow) (do (vector-store image row (copyvector line)))) ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor screen) |
Added psl-1983/3-1/windows/vscreen.t version [acaca8705e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SPECIFICATION OF THE VIRTUAL-SCREEN DATATYPE Cris Perdue 10/1/82 File: pw:vscreen.t VIRTUAL-SCREEN Flavor A virtual screen is an object that can be used as independent rectangular character display, but in fact shares a physical screen with other objects. The coordinate system is based at (0,0) with the origin at the upper left-hand corner of the screen. A virtual-screen has an associated virtual cursor position. Each character on a virtual screen has a specific associated display enhancement, such as inverse video or underlining. A virtual screen object maintains a stored representation of the image on the virtual screen, which is used to update the physical screen when new areas of the virtual screen become "exposed". A virtual screen does not itself maintain any information about changes to its contents. It informs the physical screen of all changes as they are made, and sends the entire screen contents to the physical screen upon its request. In contrast with LISP Machine "windows" (the equivalent of these virtual-screens), a program may write onto a virtual screen at any time. Whether the virtual screen is exposed, covered, or partially covered by virtual screens makes no difference. In all cases any change to a virtual screen that shows is permitted and sent to the shared-physical-screen as soon as it is made. The change is visible to the user as soon as a refresh operation is done. The following initialization options exist: screen (required) The shared-physical-screen on which this screen may become exposed. height, width (optional) The height and width of this screen, in characters. These default to the height and width of the shared-physical-screen of this screen. row-origin, column-origin (optional) Offset of the upper left-hand corner (origin) of this screen from the upper left-hand corner of the associated shared-physical-screen. These may be negative. (?) default-enhancement (optional) Display enhancement(s) to be applied to characters written into this screen by the "write" method. Display enhancements include inverse video and underlining. Defaults to the value of the normal-enhancement of the associated shared-physical-screen. Enhancement values may be legally generated by the function dc-make-enhancement, not documented here. (Defined in the file pw:display-char.sl.) Note: Characters written to this screen by write-display-character do not have the default enhancement applied. Note on clipping: All operations that modify the contents of the virtual screen effectively clip. If any or all of the coordinates to be modified lie outside the screen, any part of the operation applying to those coordinates is ignored and no warning is given. Attempts to move the cursor off the virtual screen just move it to the nearest border point. (CREATE-VIRTUAL-SCREEN SHARED-PHYSICAL-SCREEN) Creates a virtual-screen associated with the specified shared-physical-screen. All the rest of the virtual-screen's attributes are defaulted. (=> VIRTUAL-SCREEN SET-CURSOR-POSITION ROW COLUMN) Sets the virtual-screen's (virtual) cursor position. It is intended that virtual screens will be shown on actual screens that have at least one actual cursor. At certain times there will be an actual cursor displayed at the position of the virtual-screen's cursor. If the position is out of range, the nearest in-range values will be used instead without complaint. (=> VIRTUAL-SCREEN WRITE CH ROW COLUMN) Write a single character, represented as an integer, at the given coordinates. The character is written with the virtual-screen's default enhancements. (=> VIRTUAL-SCREEN WRITE-RANGE CH ROW LEFT-COLUMN RIGHT-COLUMN) Writes the same character to a range of positions within a line of the virtual-screen. The left-column and right-column coordinates are inclusive. The default-enhancements are used. (=> VIRTUAL-SCREEN WRITE-DISPLAY-CHARACTER DC ROW COLUMN) A single character is written to the virtual-screen with explicit enhancements. The DC argument is a character-with-enhancements object, not documented here. (=> VIRTUAL-SCREEN CLEAR) The entire contents of the virtual-screen is set to blanks with the default enhancement. All clearing operations set the cleared portion of the screen to blanks with the default enhancement. (=> VIRTUAL-SCREEN CLEAR-TO-END FIRST-ROW) Clears the entire contents of the rows from first-row to the end of the screen. (=> VIRTUAL-SCREEN CLEAR-TO-EOL ROW FIRST-COLUMN) Clears the given row from first-column to the end. (=> VIRTUAL-SCREEN EXPOSE) Causes the select-primary-owner method to be invoked on the shared-physical-screen of the virtual screen. The effect of this should be to guarantee that the virtual screen is exposed in front of all other virtual screens associated with the same shared-physical-screen (until this operation is invoked on some other virtual-screen). Also guarantees that the actual screen's cursor is displayed at the position of this virtual-screen's cursor. (=> VIRTUAL-SCREEN DEEXPOSE) Causes the remove-owner method to be invoked on the shared-physical-screen of this virtual screen. The effect should be to entirely remove this virtual screen from display on the shared-physical-screen. SEMI-PRIVATE METHODS These methods are invoked by the shared-physical-screen. They are not intended for public use. Shared-physical-screens require their "owner" objects to supply these methods. (=> VIRTUAL-SCREEN SEND-CHANGES BREAKOUT-ALLOWED) An "owner" object is permitted to delay sending changes to the shared-physical-screen. When the shared-physical-screen is to be brought up to date, it invokes this operation on its owners, which must write onto the shared-physical-screen to bring it up to date. Virtual-screens do not buffer or delay any updating, so this operation is a no-op. (=> VIRTUAL-SCREEN SEND-CONTENTS BREAKOUT-ALLOWED) This method is invoked by the shared-physical-screen to force an owner to write its entire contents out to the shared-physical-screen. (=> VIRTUAL-SCREEN ASSERT-OWNERSHIP) This method is invoked by the shared-physical-screen with the expectation that it in turn will invoke the shared-physical-screen's set-owner-region operation with parameters specifying what area is to be occupied by the owner. (=> VIRTUAL-SCREEN SCREEN-CURSOR-POSITION) This method is expected to return the coordinates of the virtual-screen's cursor, in the coordinate system of the shared-physical-screen. |
Added psl-1983/3-1/windows/vt52x.sl version [9a6ec8bc1c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % VT52X.SL - Terminal Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 October 1982 % Revised: 1 March 1983 % % 1-Mar-83 Alan Snyder % Removed right-corner-of-screen hack (no longer needed). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor vt52x ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (vt52x get-character) () (& (PBIN) 8#377) ) (defmethod (vt52x ring-bell) () (out-char BELL) ) (defmethod (vt52x move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (vt52x enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (vt52x leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (vt52x erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (vt52x clear-line) () (out-chars ESC K) ) (defmethod (vt52x convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (vt52x normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (vt52x highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (vt52x supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (vt52x update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (PBOUT new-code) (if (< cursor-column maxcol) (setf cursor-column (+ cursor-column 1)) % otherwise % (pretend we don't know the cursor position... % the two versions of the emulator differ at this point!) (setf cursor-column 10000) (setf cursor-row 10000) ) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (vt52x init) () ) (defmethod (vt52x &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (vt52x &set-terminal-enhancement) (enh) (setf terminal-enhancement enh) (out-char ESC) (PBOUT 3) (PBOUT (dc-enhancement-index enh)) ) |
Added psl-1983/3-1/windows/windows-20.sl version [0fc1b9024d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WINDOWS-20.SL - Dec-20 Windows Stuff (intended only for Dec-20 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 April 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int)) (bothtimes (load strings common)) (fluid '(window-file-list window-source-prefix window-binary-prefix)) (if (or (unboundp 'window-source-prefix) (null window-source-prefix)) (setf window-source-prefix "pw:")) (if (or (unboundp 'window-binary-prefix) (null window-binary-prefix)) (setf window-binary-prefix "pwb:")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building WINDOWS: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-fixup-name (s) s) (de window-load-all () (for (in s window-file-list) (do (window-load s)) )) (de window-load (s) (window-faslin window-binary-prefix s) ) (de window-faslin (directory-name module-name) (setf module-name (window-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf window-file-list (list "hp2648a" "physical-screen" "shared-physical-screen" "virtual-screen" "vt52x" )) |
Added psl-1983/3-1/windows/windows-9836.lap version [c55a8dc1ae].
> > | 1 2 | (faslin "pwb:windows-9836.b") (window-load-all) |
Added psl-1983/3-1/windows/windows-9836.sl version [6ac4e043c5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WINDOWS-9836.SL - HP9836 Windows Stuff (intended only for HP9836 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 January 1983 % Revised: 5 April 1983 % % 5-Apr-83 Alan Snyder % Changes relating to keeping WINDOWS source and binary files in separate % directories. Rename Shared-Screen to Shared-Physical-Screen, for % compatibility with other systems. % 16-Mar-83 Alan Snyder % Add font8, LAP support. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int)) (bothtimes (load strings common)) (fluid '(window-file-list window-source-prefix window-binary-prefix)) (if (or (unboundp 'window-source-prefix) (null window-source-prefix)) (setf window-source-prefix "pw:")) (if (or (unboundp 'window-binary-prefix) (null window-binary-prefix)) (setf window-binary-prefix "pwb:")) (de charsininputbuffer () (if (keyboard-input-available?) 1 0)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building WINDOWS: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-fixup-name (s) s) (de window-load-all () (for (in s window-file-list) (do (window-load s)) )) (de window-load (s) (window-faslin window-binary-prefix s) ) (de window-faslin (directory-name module-name) (setf module-name (window-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf window-file-list (list "font8" "9836-alpha" "9836-color" "direct-physical-screen" "shared-physical-screen" "virtual-screen" )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % LAP support for Window operations %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (lap '((*entry mul16 expr 2) (move!.l (reg 1) (reg t1)) (move!.l (reg 2) (reg t2)) (muls (reg t1) (reg t2)) (movea!.l (reg t2) (reg 1)) (rts) )) (lap '((*entry write-char-raster expr 4) % Arguments are: % 1. the raster pattern (vector of integers) % 2. the initial screen address (address of top scan line) % 3. the row-size (number of bytes per row of screen) % 4. count (the number of scan lines in the pattern) (must be positive) (move!.l (reg 4) (reg t2)) % loop control (addq!.l 4 (reg 1)) % skip vector header (*lbl (label loop)) (move!.l (autoincrement (reg 1)) (reg t1)) % read next row from pattern (move!.b (reg t1) (displacement (reg 2) 0)) % store in screen memory (adda!.l (reg 3) (reg 2)) % advance to next row of screen (subq!.l 1 (reg t2)) % decrement loop counter (bgt (label loop)) % loop if more bytes to copy (move!.l (reg nil) (reg 1)) % avoid returning bad pointer (rts) )) (lap '((*entry write-inverted-char-raster expr 4) % Arguments are: % 1. the raster pattern (vector of integers) % 2. the initial screen address (address of top scan line) % 3. the row-size (number of bytes per row of screen) % 4. count (the number of scan lines in the pattern) (must be positive) (move!.l (reg 4) (reg t2)) % loop control (addq!.l 4 (reg 1)) % skip vector header (*lbl (label loop)) (move!.l (autoincrement (reg 1)) (reg t1)) % read next row from pattern (not!.l (reg t1)) % complement the raster pattern (move!.b (reg t1) (displacement (reg 2) 0)) % store in screen memory (adda!.l (reg 3) (reg 2)) % advance to next row of screen (subq!.l 1 (reg t2)) % decrement loop counter (bgt (label loop)) % loop if more bytes to copy (move!.l (reg nil) (reg 1)) % avoid returning bad pointer (rts) )) |
Added psl-1983/3-1/windows/windows-ex-20.sl version [9b56b57b4b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WINDOWS-20.SL - Dec-20 Windows Stuff (intended only for Dec-20 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 April 1983 % % 15-Jun-83 - Robert Kessler % Added faslin of the 3 new device drivers: VT100, Ambassador and Teleray % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int)) (bothtimes (load strings common)) (fluid '(window-file-list window-source-prefix window-binary-prefix)) (if (or (unboundp 'window-source-prefix) (null window-source-prefix)) (setf window-source-prefix "pw:")) (if (or (unboundp 'window-binary-prefix) (null window-binary-prefix)) (setf window-binary-prefix "pwb:")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building WINDOWS: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-fixup-name (s) s) (de window-load-all () (for (in s window-file-list) (do (window-load s)) )) (de window-load (s) (window-faslin window-binary-prefix s) ) (de window-faslin (directory-name module-name) (setf module-name (window-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf window-file-list (list "ambassador" "hp2648a" "physical-screen" "shared-physical-screen" "teleray" "virtual-screen" "vt100" "vt52x" )) |
Added psl-1983/3-1/windows/windows-vax.lap version [eeba4cb87f].
> > | 1 2 | (faslin "$pwb/windows-vax.b") (window-load-all) |
Added psl-1983/3-1/windows/windows-vax.sl version [4487fb8eba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WINDOWS-VAX.SL - Vax-Unix Windows Stuff (intended only for Vax version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 April 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int)) (bothtimes (load strings common)) (fluid '(window-file-list window-source-prefix window-binary-prefix)) (if (or (unboundp 'window-source-prefix) (null window-source-prefix)) (setf window-source-prefix "$pw/")) (if (or (unboundp 'window-binary-prefix) (null window-binary-prefix)) (setf window-binary-prefix "$pwb/")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building WINDOWS: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-fixup-name (s) s) (de window-load-all () (for (in s window-file-list) (do (window-load s)) )) (de window-load (s) (window-faslin window-binary-prefix s) ) (de window-faslin (directory-name module-name) (setf module-name (window-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf window-file-list (list "hp2648a" "physical-screen" "shared-physical-screen" "virtual-screen" "vt52x" )) |
Added psl-1983/3-1/windows/windows.lap version [900262c232].
> > > > > | 1 2 3 4 5 | (faslin "pw:hp2648a.b") (faslin "pw:physical-screen.b") (faslin "pw:shared-physical-screen.b") (faslin "pw:virtual-screen.b") (faslin "pw:vt52x.b") |
Added psl-1983/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 psl-1983/a-full-build.mic version [55b31bb877].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @build rel4:<psl> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.comp> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.20-comp> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.doc> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.doc-nmode> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.emode> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.glisp> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.help> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.kernel> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.20-kernel> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.lap> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.lpt> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.nmode> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.nonkernel> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.tests> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.20-tests> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.util> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.20-util> @per 1000 @work 2000 @fi @gen 0 @pres @ @build rel4:<psl.windows> @per 1000 @work 2000 @fi @gen 0 @pres @ |
Added psl-1983/a-full-logical-names.cmd version [3c12b2a740].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ; Officially recognized logical names for FULL set of ; PSL subdirectories on UTAH-20 for V3 PSL distribution ; EDIT <PSL to your <name define psl: rel4:<psl> ! Executable files and miscellaneous define pc: rel4:<psl.comp> ! Compiler sources define p20c: rel4:<psl.20-comp> ! 20 Specific Compiler sources define pd: rel4:<psl.doc> ! Documentation files define pnd: rel4:<psl.doc-nmode> ! NMODE Documentation files define pe: rel4:<psl.emode> ! EMODE support and drivers define pg: rel4:<psl.glisp> ! Glisp sources define ph: rel4:<psl.help> ! Help files define pk: rel4:<psl.kernel> ! Kernel Source files define p20k: rel4:<psl.20-kernel> ! 20 Specific Kernel Sources define pl: rel4:<psl.lap> ! LAP files define plpt: rel4:<psl.lpt> ! Printer version of Documentation define pn: rel4:<psl.nmode> ! NMODE editor files define pnk: rel4:<psl.nonkernel> ! PSL Non Kernel source files define pt: rel4:<psl.tests> ! Test files define p20t: rel4:<psl.20-tests> ! 20 Specific Test files define pu: rel4:<psl.util> ! Utility program sources define p20u: rel4:<psl.20-util> ! 20 Specific Utility files define pw: rel4:<psl.windows> ! NMODE Window files take |
Added psl-1983/a-full-restore.mic version [6f642d265b].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | @DUMPER *tape 'a *account system-default *restore dsk*:<*>*.*.* PSL:*.*.* *restore dsk*:<*>*.*.* PSL:*.*.* *restore dsk*:<*>*.*.* PC:*.*.* *restore dsk*:<*>*.*.* P20C:*.*.* *restore dsk*:<*>*.*.* PD:*.*.* *restore dsk*:<*>*.*.* PND:*.*.* *restore dsk*:<*>*.*.* PE:*.*.* *restore dsk*:<*>*.*.* PG:*.*.* *restore dsk*:<*>*.*.* ph:*.*.* *restore dsk*:<*>*.*.* pk:*.*.* *restore dsk*:<*>*.*.* p20K:*.*.* *restore dsk*:<*>*.*.* pl:*.*.* *restore dsk*:<*>*.*.* plpt:*.*.* *restore dsk*:<*>*.*.* pn:*.*.* *restore dsk*:<*>*.*.* pnk:*.*.* *restore dsk*:<*>*.*.* pT:*.*.* *restore dsk*:<*>*.*.* p20T:*.*.* *restore dsk*:<*>*.*.* pu:*.*.* *restore dsk*:<*>*.*.* p20u:*.*.* *restore dsk*:<*>*.*.* pw:*.*.* |
Added psl-1983/bboard.msg version [4642dcd854].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Version 3.1 PSL Available We have just installed the latest version of Utah's PSL (Portable Standard LISP) system. This system is written almost entirely in itself, and is compiled with an efficient optimizing LISP compiler, with machine oriented extensions (called "SYSLISP"). The LISP itself is based on Utah Standard LISP, with modernizations and extensions derived from FranzLISP, Common-LISP, etc. PSL currently runs on DEC-20 under TOPS-20, VAX under UNIX, and a number of Motorola MC68000 systems. Future implementations for VAX-VMS, CRAY-1, IBM-370 and extended addressing TOPS-20 are envisioned or already underway. In order to run PSL, you must use a set of logical names, defined in <name>MINIMAL-LOGICAL-NAMES.CMD. You should insert a @TAKE of this file in your LOGIN.CMD file. A printed copy of the preliminary PSL manual can be obtained from [........]; there is also a complete online version of this manual, organized as a set of files, one per chapter. These are stored as PLPT:nnnn-chaptername.LPT. PLEASE DO NOT print your own copy. There are a set of short HELP files, on directory PH:. To get started, read PH:PSL-INTRO.HLP. The licence agrrement under which we have recieved this version of PSL restricts it to our internal use. Please do not distribute the code (source or listings), or documentation outside of our group. If there are any problems, please MAIL to [.....]. |
Added psl-1983/comp/anyreg-cmacro.sl version [88b7daffcf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% ANYREG-CMACRO.SL - Table-driven Anyreg and C-macro expander % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(ResultingCode!* TempLabel!* TempLabel2!*)) (* "Generated code is collected in reverse order in ResultingCode*") (CompileTime (flag '(SafePair PatternSublA WConstEvaluabLis AnyregPatternMatch1 MatchAll AnyregSubstitute1 TempLabelGen CMacroSubstitute1) 'InternalFunction)) (dm DefAnyreg (Form) (prog (AnyregName FunctionName Pattern) (setq Form (cdr Form)) (setq AnyregName (car Form)) (setq Form (cdr Form)) (setq FunctionName (car Form)) (setq Pattern (cdr Form)) (return (list 'progn (list 'put (MkQuote AnyregName) '(quote AnyregResolutionFunction) (MkQuote FunctionName)) (list 'put (MkQuote AnyregName) '(quote AnyregPatternTable) (MkQuote Pattern)))))) (dm DefCMacro (Form) (prog (CMacroName Pattern) (setq Form (cdr Form)) (setq CMacroName (car Form)) (setq Pattern (cdr Form)) (return (list 'progn (list 'flag (MkQuote (list CMacroName)) '(quote MC)) (list 'put (MkQuote CMacroName) '(quote CMacroPatternTable) (MkQuote Pattern)))))) (de ResolveOperand (Register Source) (prog (ResolveAnyregFunction) (return (cond ((IDP Source) (ResolveWConst Source)) ((atom Source) Source) ((FlagP (car Source) 'TerminalOperand) Source) ((setq ResolveAnyregFunction (get (car Source) 'AnyregResolutionFunction)) (Apply ResolveAnyregFunction (cons Register (cdr Source)))) (t (ResolveWConst Source)))))) (de ResolveWConst (Expression) (prog (ResolvedExpression) (setq ResolvedExpression (ResolveWConstExpression Expression)) (return (cond ((NumberP ResolvedExpression) ResolvedExpression) (t (list 'Immediate Expression)))))) (de ResolveWConstExpression (Expression) (cond ((EqCar Expression 'WConst) (ResolveWConstExpression (cadr Expression))) (t (prog (ResultExpression) (return (cond ((or (NumberP Expression) (StringP Expression)) Expression) ((IDP Expression) (cond ((setq ResultExpression (get Expression 'WConst)) ResultExpression) (t Expression))) (t (progn (cond ((MacroP (car Expression)) (return (ResolveWConstExpression (Apply (car Expression) (list Expression)))))) (setq Expression (cons (car Expression) (MapCar (cdr Expression) (Function ResolveWConstExpression)))) (cond ((setq ResultExpression (WConstEvaluable Expression)) ResultExpression) (t Expression)))))))))) (de WConstEvaluable (Expression) (prog (WC WCLis DoFn) (return (cond ((NumberP Expression) Expression) ((and (IDP Expression) (setq WC (get Expression 'WConst))) WC) ((and (PairP Expression) (IDP (setq WC (car Expression)))) (cond ((MacroP WC) (WConstEvaluable (apply (car Expression) (list Expression)))) ((and (or (and (setq DoFn (get WC 'DoFn)) (setq WC DoFn)) (not (FUnBoundP WC))) (not (eq (setq WCLis (WConstEvaluabLis (cdr Expression))) 'not))) (Eval (cons WC WCLis))) (T NIL))) (T NIL))))) (de WConstEvaluabLis (ExpressionTail) (prog (WC WCLis) (return (cond ((null ExpressionTail) NIL) ((not (setq WC (WConstEvaluable (car ExpressionTail)))) 'not) ((eq (setq WCLis (WConstEvaluabLis (cdr ExpressionTail))) 'not) 'not) (T (cons WC WCLis)))))) (de OneOperandAnyreg (Register Source AnyregName) (ExpandOneArgumentAnyreg Register (ResolveOperand Register Source) AnyregName)) (* "SecondArg must not require a register for evaluation. It is currently used only for (MEMORY reg const).") (de TwoOperandAnyreg (Register Source SecondArg AnyregName) (ExpandTwoArgumentAnyreg Register (ResolveOperand Register Source) (ResolveOperand '(REG Error) SecondArg) AnyregName)) (de ExpandOneArgumentAnyreg (Register Source AnyregName) (AnyregPatternExpand (list Register Source) (get AnyregName 'AnyregPatternTable))) (de ExpandTwoArgumentAnyreg (Register Source SecondArg AnyregName) (AnyregPatternExpand (list Register Source SecondArg) (get AnyregName 'AnyregPatternTable))) (de ExpandThreeArgumentAnyreg (Register Source SecondArg ThirdArg AnyregName) (AnyregPatternExpand (list Register Source SecondArg ThirdArg) (get AnyregName 'AnyregPatternTable))) (de AnyregPatternExpand (ArgumentList PatternTable) (AnyregSubstitute ArgumentList (AnyregPatternMatch (cdr ArgumentList) PatternTable))) (* "The label operand must not require a register to resolve.") (de Expand2OperandAndLabelCMacro (Arg1 Arg2 Label CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2) (ResolveOperand '(REG Error) Label)) (get CMacroName 'CMacroPatternTable))))) (de Expand4OperandCMacro (Arg1 Arg2 Arg3 Arg4 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2) (ResolveOperand '(REG Error) Arg3) (ResolveOperand '(REG Error) Arg4)) (get CMacroName 'CMacroPatternTable))))) (de Expand2OperandCMacro (Arg1 Arg2 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1) (ResolveOperand '(REG t2) Arg2)) (get CMacroName 'CMacroPatternTable))))) (de Expand1OperandCMacro (Arg1 CMacroName) (prog (ResultingCode!*) (return (CMacroPatternExpand (list (ResolveOperand '(REG t1) Arg1)) (get CMacroName 'CMacroPatternTable))))) (de CMacroPatternExpand (ArgumentList PatternTable) (CMacroSubstitute ArgumentList (AnyregPatternMatch ArgumentList PatternTable))) (de AnyregPatternMatch (ArgumentList PatternTable) (cond ((null (cdr PatternTable)) (car PatternTable)) ((AnyregPatternMatch1 ArgumentList (caar PatternTable)) (cdar PatternTable)) (t (AnyregPatternMatch ArgumentList (cdr PatternTable))))) (de AnyregPatternMatch1 (ArgumentList PredicateOrPredicateList) (cond ((atom PredicateOrPredicateList) (Apply PredicateOrPredicateList ArgumentList)) (t (MatchAll ArgumentList PredicateOrPredicateList)))) (de MatchAll (ArgumentList PredicateList) (or (atom ArgumentList) (atom PredicateList) (and (Apply (car PredicateList) (list (car ArgumentList))) (MatchAll (cdr ArgumentList) (cdr PredicateList))))) (de AnyregSubstitute (ArgumentList CodeAndAddressExpressionList) (AnyregSubstitute1 (SafePair '(Register Source ArgTwo ArgThree) ArgumentList) CodeAndAddressExpressionList)) (de AnyregSubstitute1 (NameExpressionAList CodeAndAddressExpressionList) (cond ((null (cdr CodeAndAddressExpressionList)) (SublA NameExpressionAList (car CodeAndAddressExpressionList))) (t (progn (setq ResultingCode!* (cons (SublA NameExpressionAList (car CodeAndAddressExpressionList)) ResultingCode!*)) (AnyregSubstitute1 NameExpressionAList (cdr CodeAndAddressExpressionList)))))) (de CMacroSubstitute (ArgumentList CodeTemplateList) (prog (TempLabel!* TempLabel2!*) (return (CMacroSubstitute1 (SafePair '(ArgOne ArgTwo ArgThree ArgFour ArgFive) ArgumentList) CodeTemplateList)))) (de CMacroSubstitute1 (NameExpressionAList CodeTemplateList) (cond ((null CodeTemplateList) (ReversIP ResultingCode!*)) (t (progn (setq ResultingCode!* (cons (PatternSublA NameExpressionAList (car CodeTemplateList)) ResultingCode!*)) (CMacroSubstitute1 NameExpressionAList (cdr CodeTemplateList)))))) (de SafePair (CarList CdrList) (cond ((and (PairP CarList) (PairP CdrList)) (cons (cons (car CarList) (car CdrList)) (SafePair (cdr CarList) (cdr CdrList)))) (t NIL))) (de PatternSublA (AList Expression) (prog (X) (return (cond ((null Expression) Expression) ((atom Expression) (cond ((eq Expression 'TempLabel) (TempLabelGen 'TempLabel!*)) ((eq Expression 'TempLabel2) (TempLabelGen 'TempLabel2!*)) ((setq X (atsoc Expression AList)) (cdr X)) (t Expression))) (t (cons (PatternSublA AList (car Expression)) (PatternSublA AList (cdr Expression)))))))) (de TempLabelGen (X) ((lambda (Y) (cond ((StringP Y) Y) (T (set X (StringGensym))))) (Eval X))) |
Added psl-1983/comp/bare-psl.sym version [14527ad530].
> > > > | 1 2 3 4 | (setq OrderedIDList!* (NCons NIL)) (setq UncompiledExpressions!* (NCons NIL)) (setq ToBeCompiledExpressions!* (NCons NIL)) (setq NextIDNumber!* 129) |
Added psl-1983/comp/big-faslend.build version [8dcfaa402d].
> | 1 | in "big-faslend.red"$ |
Added psl-1983/comp/big-faslend.red version [14dcdf4b53].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BIG-FASLEND.RED - Patch to FASLEND for huge files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 7 May 1982 % Copyright (c) 1982 University of Utah % <PSL.COMP>BIG-FASLEND.RED.4, 10-Jun-82 10:39:32, Edit by GRISS % Added InitCodeMax!* for testing % lisp procedure CompileUncompiledExpressions(); <<ErrorPrintF("%n*** Init code length is %w%n", length car UncompiledExpressions!*); CompileInitCode('!*!*Fasl!*!*InitCode!*!*, car UncompiledExpressions!*)>>; FLUID '(InitCodeMax!*); LoadTime <<InitCodeMax!*:=350>>; lisp procedure CompileInitCode(Name, InitCodeList); begin scalar X, Len, LastHalf; return if ILessP(Len := length InitCodeList, InitCodeMax!*) then DfPrintFasl list('de, Name, '(), 'progn . InitCodeList) else << ErrorPrintF( "*** Initcode length %w too large, splitting into smaller pieces", Len); ErrorPrintF("*** Please use smaller files in FASL"); X := PNTH(InitCodeList, IQuotient(Len, 2)); LastHalf := cdr X; Rplacd(X, NIL); % tricky, split the code in 2 X := Intern Concat(ID2String Name, StringGensym()); Flag1(X, 'InternalFunction); % has to be internal to get called! CompileInitCode(X, InitCodeList); CompileInitCode(Name, list X . LastHalf) >>; % call previous end; |
Added psl-1983/comp/common-cmacros.sl version [f5e3ff0acf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% COMMON-CMACROS.SL - C-macros and Anyregs common to all implementations % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(NAlloc!* AddressingUnitsPerItem StackDirection ResultingCode!*)) (de !*Link (FunctionName FunctionType NumberOfArguments) (list (cond ((FlagP FunctionName 'ForeignFunction) (list '!*ForeignLink FunctionName FunctionType NumberOfArguments)) (t (list '!*Call FunctionName))))) (DefCMacro !*Link) (de !*Call (FunctionName) (prog (ResultingCode!* OpenCodeSequence) (return (cond ((setq OpenCodeSequence (get FunctionName 'OpenCode)) OpenCodeSequence) (t (CMacroPatternExpand (list FunctionName) (get '!*Call 'CMacroPatternTable))))))) (de !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) (cons (list '!*DeAlloc DeAllocCount) (cond ((FlagP FunctionName 'ForeignFunction) (list (list '!*ForeignLink FunctionName FunctionType NumberOfArguments) '(!*Exit 0))) (t (list (list '!*JCall FunctionName)))))) (DefCMacro !*LinkE) (de !*JCall (FunctionName) (prog (ResultingCode!* OpenCodeSequence) (return (cond ((setq OpenCodeSequence (get FunctionName 'ExitOpenCode)) OpenCodeSequence) ((setq OpenCodeSequence (get FunctionName 'OpenCode)) (Append OpenCodeSequence (list '(!*Exit 0)))) (t (CMacroPatternExpand (list FunctionName) (get '!*JCall 'CMacroPatternTable))))))) (de !*DeAlloc (DeAllocCount) (Expand1OperandCMacro (times DeAllocCount AddressingUnitsPerItem) '!*DeAlloc)) (de !*Alloc (N) (progn (setq NAlloc!* N) (Expand1OperandCMacro (times N AddressingUnitsPerItem) '!*Alloc))) (de !*Exit (N) (Expand1OperandCMacro (times N AddressingUnitsPerItem) '!*Exit)) (de !*JumpWithin (Label LowerBound UpperBound) (prog (ExitLabel) (setq ExitLabel (list 'Label (GenSym))) (return (list (list '!*JumpWLessP ExitLabel '(Reg 1) LowerBound) (list '!*JumpWLeq Label '(Reg 1) UpperBound) (list '!*Lbl ExitLabel))))) (DefCMacro !*JumpWithin) (de !*ProgBind (FluidsList) (!*LamBind '(Registers) FluidsList)) (DefCMacro !*ProgBind) (de !*FreeRstr (FluidsList) (Expand1OperandCMacro (length (cdr FluidsList)) '!*FreeRstr)) (de !*Jump (Arg1) (Expand1OperandCMacro Arg1 '!*Jump)) (de !*Lbl (Arg1) (cdr Arg1)) (de !*Push (Arg1) (Expand1OperandCMacro Arg1 '!*Push)) (de !*Pop (Arg1) (Expand1OperandCMacro Arg1 '!*Pop)) (de !*Move (Source Destination) (prog (ResultingCode!* ResolvedDestination) (setq ResolvedDestination (ResolveOperand '(REG t2) Destination)) (return (CMacroPatternExpand (list (ResolveOperand (cond ((RegisterP ResolvedDestination) ResolvedDestination) (t '(REG t1))) Source) ResolvedDestination) (get '!*Move 'CMacroPatternTable))))) (de !*JumpEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpEQ)) (de !*JumpNotEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpNotEQ)) (de !*JumpWLessP (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWLessP)) (de !*JumpWGreaterP (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWGreaterP)) (de !*JumpWLEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWLEQ)) (de !*JumpWGEQ (Label Arg1 Arg2) (Expand2OperandAndLabelCMacro Arg1 Arg2 Label '!*JumpWGEQ)) (de !*JumpType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpType)) (de !*JumpNotType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpNotType)) (de !*JumpInType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpInType)) (de !*JumpNotInType (Label Arg TypeTag) (Expand2OperandAndLabelCMacro Arg (list 'WConst (get TypeTag 'WConst)) Label '!*JumpNotInType)) (de !*MkItem (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*MkItem)) (de !*WPlus2 (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WPlus2)) (de !*WDifference (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WDifference)) (de !*WTimes2 (Arg1 Arg2) (prog (P) (return (cond ((and (or (EqCar Arg2 'Quote) (EqCar Arg2 'WConst)) (setq P (PowerOf2P (cadr Arg2)))) (!*AShift Arg1 (list (car Arg2) P))) (t (Expand2OperandCMacro Arg1 Arg2 '!*WTimes2)))))) (* "PowerOf2P(X:integer):{integer,NIL} If X is a positive power of 2, log base 2 of X is returned. Otherwise NIL is returned.") (de PowerOf2P (X) (prog (N) (return (cond ((or (not (FixP X)) (MinusP X) (equal X 0)) NIL) (t (progn (setq N 0) (while (not (equal (lor x 1) x)) (progn (setq N (add1 N)) (setq X (lsh X -1)))) (cond ((equal X 1) N) (T NIL)))))))) (de !*AShift (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*AShift)) (de !*WShift (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WShift)) (de !*WAnd (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WAnd)) (de !*WOr (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WOr)) (de !*WXOr (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WXOr)) (de !*WMinus (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WMinus)) (de !*WNot (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WNot)) (de !*Loc (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*Loc)) (de !*Field (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*Field)) (de !*SignedField (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*SignedField)) (de !*PutField (Arg1 Arg2 Arg3 Arg4) (Expand4OperandCMacro Arg1 Arg2 Arg3 Arg4 '!*PutField)) (de AnyregCAR (Register Source) (OneOperandAnyreg Register Source 'car)) (de AnyregCDR (Register Source) (OneOperandAnyreg Register Source 'cdr)) (de AnyregQUOTE (Register Source) (ExpandOneArgumentAnyreg Register Source 'quote)) (de AnyregWVAR (Register Source) (ExpandOneArgumentAnyreg Register Source 'WVar)) (de AnyregREG (Register Source) (ExpandOneArgumentAnyreg Register Source 'REG)) (de AnyregWCONST (Register Source) (OneOperandAnyreg Register Source 'WConst)) (DefAnyreg WCONST AnyregWCONST (SOURCE)) (de AnyregFRAME (Register Source) (ExpandOneArgumentAnyreg Register (times StackDirection AddressingUnitsPerItem (difference 1 Source)) 'Frame)) (de AnyregFRAMESIZE (Register) (times NAlloc!* AddressingUnitsPerItem)) (DefAnyreg FrameSize AnyregFRAMESIZE) (de AnyregMEMORY (Register Source ArgTwo) (TwoOperandAnyreg Register Source ArgTwo 'MEMORY)) (flag '(FLUID !$FLUID GLOBAL !$GLOBAL ExtraReg Label) 'TerminalOperand) (fluid '(labelgen*)) % a-list of tags and labels % (labelgen tag) and (labelref tag) can be used as either ANYREG or CMACRO. % (labelgen tag) creates and returns a unique label, (labelref tag) returns % the same one. Useful for 'OpenCode lists. (de anyreglabelgen (reg name) ((lambda (lb al) (cond ((null al) (setq labelgen* (cons (cons name lb) labelgen*))) (t (rplacd al lb))) lb) (gensym) (assoc name labelgen*))) (defanyreg labelgen anyreglabelgen) (de labelgen (name) (list (anyreglabelgen nil name))) (defcmacro labelgen) (de anyreglabelref (reg name) (cdr (assoc name labelgen*))) (defanyreg labelref anyreglabelref) (de labelref (name) (list (anyreglabelref nil name))) (defcmacro labelref) |
Added psl-1983/comp/common-predicates.sl version [e18b5b5696].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% COMMON-PREDICATES.SL - Predicates used for Anyreg and C-macro expansion % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 December 1981 % Copyright (c) 1981 University of Utah %") (fluid '(EntryPoints!* !*FastLinks)) (global '(!*R2I)) (de RegisterP (Expression) (EqCar Expression 'REG)) (de AnyP (Expression) T) (de TaggedLabel (X) (EqCar X 'Label)) (de EqTP (Expression) (equal Expression T)) (de MinusOneP (Expression) (equal Expression -1)) (de InternallyCallableP (X) % only when writing a file (and (or !*WritingFaslFile (not (FUnBoundP 'AsmOut))) (or !*FastLinks (and !*R2I (memq X EntryPoints!*)) (FlagP X 'InternalFunction) (FlagP X 'FastLink)))) (de AddressConstantP (Expression) (or (atom Expression) (equal (car Expression) 'Immediate))) |
Added psl-1983/comp/comp-decls.build version [df33a3fc05].
> | 1 | in "comp-decls.red"$ |
Added psl-1983/comp/comp-decls.red version [d852803e8e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMP-DECLS.RED - Machine-independent declaractions used by the compiler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.COMP>COMP-DECLS.RED.16, 3-Sep-82 09:46:43, Edit by BENSON % Added PA1REFORMFN for WNOT % <PSL.COMP>COMP-DECLS.RED.5, 3-Dec-82 18:20:08, Edit by PERDUE % Removed PA1REFORMFN for NE % <PSL.COMP>COMP-DECLS.RED.6, 24-Jan-83 16:04:00, Edit by MLGriss % Changed W to !%!%!%W in the EQCAR to avoid subst W into EQCAR form % Pass 1 functions put('Apply, 'PA1FN, '!&PaApply); PUT('ASSOC, 'PA1FN, '!&PAASSOC); PUT('EQUAL, 'PA1FN, '!&PAEQUAL); PUT('MEMBER, 'PA1FN, '!&PAMEMBER); put('Catch, 'Pa1Fn, '!&PaCatch); PUT('COND, 'PA1FN, '!&PACOND); PUT('DIFFERENCE,'PA1FN, '!&PADIFF); PUT('FUNCTION, 'PA1FN, '!&PAFUNCTION); PUT('GETMEM, 'PA1FN, '!&PAGETMEM); PUT('GO, 'PA1FN, '!&PAIDENT); PUT('CASE, 'PA1FN, '!&PACASE); PUT('INTERN, 'PA1FN, '!&PAINTERN); PUT('LAMBDA, 'PA1FN, '!&PALAMBDA); PUT('LESSP, 'PA1FN, '!&PALESSP); PUT('LIST, 'PA1FN, '!&PALIST); PUT('LOC, 'PA1REFORMFN, '!&REFORMLOC); PUT('MAP, 'PA1FN, '!&PAMAP); PUT('MAPC, 'PA1FN, '!&PAMAPC); PUT('MAPCAN, 'PA1FN, '!&PAMAPCAN); PUT('MAPCAR, 'PA1FN, '!&PAMAPCAR); PUT('MAPCON, 'PA1FN, '!&PAMAPCON); PUT('MAPLIST, 'PA1FN, '!&PAMAPLIST); PUT('MINUS, 'PA1FN, '!&PAMINUS); PUT('NULL, 'PA1REFORMFN, '!&REFORMNULL); % PUT('NE, 'PA1REFORMFN, '!&REFORMNE); % Perdue 12/3/82 put('Nth, 'Pa1Fn, '!&PaNth); put('PNth, 'Pa1Fn, '!&PaPNth); PUT('PLUS2, 'PA1FN, '!&PAPLUS2); PUT('PROG, 'PA1FN, '!&PAPROG); PUT('PUTMEM, 'PA1FN, '!&PAPUTMEM); PUT('PUTLISPVAR,'PA1FN, '!&PAPUTLISPVAR); PUT('LISPVAR, 'PA1FN, '!&PALISPVAR); PUT('QUOTE, 'PA1FN, '!&PAIDENT); PUT('WCONST, 'PA1FN, '!&PAWCONST); PUT('SETQ, 'PA1FN, '!&PASETQ); PUT('WPLUS2, 'PA1FN, '!&GROUP); PUT('WDIFFERENCE,'PA1FN, '!&GROUP); PUT('WMINUS, 'PA1FN, '!&GROUP); PUT('WTIMES2, 'PA1FN, '!&ASSOCOP); PUT('WAND, 'PA1FN, '!&ASSOCOP); PUT('WOR, 'PA1FN, '!&ASSOCOP); PUT('WXOR, 'PA1FN, '!&ASSOCOP); PUT('WPLUS2, 'PA1ALGFN, '!&GROUPV); PUT('WDIFFERENCE,'PA1ALGFN, '!&GROUPV); PUT('WMINUS, 'PA1ALGFN, '!&GROUPV); PUT('WTIMES2, 'PA1ALGFN, '!&ASSOCOPV); PUT('WAND, 'PA1ALGFN, '!&ASSOCOPV); PUT('WOR, 'PA1ALGFN, '!&ASSOCOPV); PUT('WXOR, 'PA1ALGFN, '!&ASSOCOPV); PUT('WSHIFT, 'PA1REFORMFN, '!&DOOP); PUT('WNOT, 'PA1REFORMFN, '!&DOOP); put('WTimes2, 'PA1Reformfn, function !&PaReformWTimes2); % Simplification PUT('WPLUS2, 'DOFN, 'PLUS2); PUT('WDIFFERENCE,'DOFN, 'DIFFERENCE); PUT('WMINUS, 'DOFN, 'MINUS); PUT('WTIMES2, 'DOFN, 'TIMES2); PUT('WQUOTIENT, 'DOFN, 'QUOTIENT); PUT('WREMAINDER,'DOFN, 'REMAINDER); PUT('WAND, 'DOFN, 'LAND); PUT('WOR, 'DOFN, 'LOR); PUT('WXOR, 'DOFN, 'LXOR); PUT('WNOT, 'DOFN, 'LNOT); PUT('WSHIFT, 'DOFN, 'LSHIFT); PUT('WTIMES2, 'ONE, 1); PUT('WTIMES2, 'ZERO, 0); PUT('WPLUS2, 'ONE, 0); PUT('WPLUS2, 'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WMINUS, 'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WDIFFERENCE,'GROUPOPS, '(WPLUS2 WDIFFERENCE WMINUS)); PUT('WAND, 'ZERO, 0); PUT('WOR, 'ONE, 0); PUT('WXOR, 'ONE, 0); % Compile functions PUT('AND, 'COMPFN, '!&COMANDOR); PUT('APPLY, 'COMPFN, '!&COMAPPLY); PUT('COND, 'COMPFN, '!&COMCOND); PUT('CONS, 'COMPFN, '!&COMCONS); PUT('GO, 'COMPFN, '!&COMGO); PUT('CASE, 'COMPFN, '!&COMCASE); PUT('OR, 'COMPFN, '!&COMANDOR); PUT('PROG, 'COMPFN, '!&COMPROG); PUT('PROG2, 'COMPFN, '!&COMPROGN); PUT('PROGN, 'COMPFN, '!&COMPROGN); PUT('RETURN, 'COMPFN, '!&COMRETURN); % Patterns for the tests and SETQ PUT('EQ, 'OPENTST, '(TSTPAT !*JUMPEQ)); PUT('EQ, 'OPENFN, '(TVPAT !*JUMPEQ)); PUT('NE, 'OPENTST, '(TSTPAT !*JUMPNOTEQ)); PUT('NE, 'OPENFN, '(TVPAT !*JUMPNOTEQ)); PUT('AND, 'OPENTST, '!&TSTANDOR); PUT('OR, 'OPENTST, '!&TSTANDOR); PUT('PAIRP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE PAIR)); PUT('ATOM, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE PAIR)); PUT('STRINGP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE STR)); PUT('NOTSTRINGP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE STR)); PUT('VECTORP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE VECT)); PUT('NOTVECTORP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE VECT)); PUT('CODEP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE CODE)); PUT('NOTCODEP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE CODE)); PUT('FLOATP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE FLTN)); PUT('NOTFLOATP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE FLTN)); PUT('INTP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE POSINT)); PUT('NOTINTP, 'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE POSINT)); PUT('FIXP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE BIGN)); PUT('NOTFIXP, 'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE BIGN)); PUT('NUMBERP, 'OPENTST, '(TSTPAT2 !*JUMPINTYPE FLTN)); PUT('NOTNUMBERP,'OPENTST, '(TSTPAT2 !*JUMPNOTINTYPE FLTN)); PUT('FIXNP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE FIXN)); PUT('NOTFIXNP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE FIXN)); PUT('BIGP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE BIGN)); PUT('NOTBIGP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE BIGN)); PUT('POSINTP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE POSINT)); PUT('NOTPOSINTP,'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE POSINT)); PUT('NEGINTP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE NEGINT)); PUT('NOTNEGINTP,'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE NEGINT)); PUT('IDP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE ID)); PUT('NOTIDP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE ID)); PUT('BYTESP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE BYTES)); PUT('NOTBYTESP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE BYTES)); PUT('WRDSP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE WRDS)); PUT('NOTWRDSP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE WRDS)); PUT('HALFWORDSP, 'OPENTST, '(TSTPAT2 !*JUMPTYPE HALFWORDS)); PUT('NOTHALFWORDSP, 'OPENTST, '(TSTPAT2 !*JUMPNOTTYPE HALFWORDS)); PUT('PAIRP, 'OPENFN, '(TVPAT1 !*JUMPTYPE PAIR)); PUT('ATOM, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE PAIR)); PUT('STRINGP, 'OPENFN, '(TVPAT1 !*JUMPTYPE STR)); PUT('NOTSTRINGP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE STR)); PUT('VECTORP, 'OPENFN, '(TVPAT1 !*JUMPTYPE VECT)); PUT('NOTVECTORP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE VECT)); PUT('CODEP, 'OPENFN, '(TVPAT1 !*JUMPTYPE CODE)); PUT('NOTCODEP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE CODE)); PUT('FLOATP, 'OPENFN, '(TVPAT1 !*JUMPTYPE FLTN)); PUT('NOTFLOATP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE FLTN)); PUT('INTP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE POSINT)); PUT('NOTINTP, 'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE POSINT)); PUT('FIXP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE BIGN)); PUT('NOTFIXP, 'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE BIGN)); PUT('NUMBERP, 'OPENFN, '(TVPAT1 !*JUMPINTYPE FLTN)); PUT('NOTNUMBERP,'OPENFN, '(TVPAT1 !*JUMPNOTINTYPE FLTN)); PUT('FIXNP, 'OPENFN, '(TVPAT1 !*JUMPTYPE FIXN)); PUT('NOTFIXNP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE FIXN)); PUT('BIGP, 'OPENFN, '(TVPAT1 !*JUMPTYPE BIGN)); PUT('NOTBIGP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE BIGN)); PUT('POSINTP, 'OPENFN, '(TVPAT1 !*JUMPTYPE POSINT)); PUT('NOTPOSINTP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE POSINT)); PUT('NEGINTP, 'OPENFN, '(TVPAT1 !*JUMPTYPE NEGINT)); PUT('NOTNEGINTP,'OPENFN, '(TVPAT1 !*JUMPNOTTYPE NEGINT)); PUT('IDP, 'OPENFN, '(TVPAT1 !*JUMPTYPE ID)); PUT('NOTIDP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE ID)); PUT('BYTESP, 'OPENFN, '(TVPAT1 !*JUMPTYPE BYTES)); PUT('NOTBYTESP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE BYTES)); PUT('WRDSP, 'OPENFN, '(TVPAT1 !*JUMPTYPE WRDS)); PUT('NOTWRDSP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE WRDS)); PUT('HALFWORDSP, 'OPENFN, '(TVPAT1 !*JUMPTYPE HALFWORDS)); PUT('NOTHALFWORDSP, 'OPENFN, '(TVPAT1 !*JUMPNOTTYPE HALFWORDS)); PUT('SETQ, 'OPENFN, '(SETQPAT NIL)); PUT('RPLACA, 'OPENFN, '(RPLACPAT CAR)); PUT('RPLACD, 'OPENFN, '(RPLACPAT CDR)); PUT('WPLUS2, 'OPENFN, '(ASSOCPAT !*WPLUS2)); PUT('WDIFFERENCE,'OPENFN, '(SUBPAT !*WDIFFERENCE)); PUT('WTIMES2, 'OPENFN, '(ASSOCPAT !*WTIMES2)); PUT('WMINUS, 'OPENFN, '(UNARYPAT !*WMINUS)); PUT('WAND, 'OPENFN, '(ASSOCPAT !*WAND)); PUT('WOR, 'OPENFN, '(ASSOCPAT !*WOR)); PUT('WXOR, 'OPENFN, '(ASSOCPAT !*WXOR)); PUT('WNOT, 'OPENFN, '(UNARYPAT !*WNOT)); PUT('WSHIFT, 'OPENFN, '(NONASSOCPAT !*WSHIFT)); PUT('MKITEMREV, 'OPENFN, '(NONASSOCPAT !*MKITEM)); PUT('LOC, 'OPENFN, '(UNARYPAT !*LOC)); PUT('!*ADDMEM, 'OPENFN, '(MODMEMPAT !*ADDMEM)); PUT('!*MPYMEM, 'OPENFN, '(MODMEMPAT !*MPYMEM)); PUT('FIELD, 'OPENFN, '(FIELDPAT !*FIELD)); PUT('SIGNEDFIELD,'OPENFN, '(FIELDPAT !*SIGNEDFIELD)); PUT('PUTFIELDREV,'OPENFN, '(PUTFIELDPAT !*PUTFIELD)); PUT('WGREATERP,'OPENTST, '(TSTPATC !*JUMPWGREATERP !*JUMPWLESSP)); PUT('WLEQ, 'OPENTST, '(TSTPATC !*JUMPWLEQ !*JUMPWGEQ)); PUT('WGEQ, 'OPENTST, '(TSTPATC !*JUMPWGEQ !*JUMPWLEQ)); PUT('WLESSP, 'OPENTST, '(TSTPATC !*JUMPWLESSP !*JUMPWGREATERP)); PUT('WGREATERP, 'OPENFN, '(TVPAT !*JUMPWGREATERP)); PUT('WLEQ, 'OPENFN, '(TVPAT !*JUMPWLEQ)); PUT('WGEQ, 'OPENFN, '(TVPAT !*JUMPWGEQ)); PUT('WLESSP, 'OPENFN, '(TVPAT !*JUMPWLESSP)); PUT('EQ,'FLIPTST,'NE); PUT('NE,'FLIPTST,'EQ); PUT('ATOM,'FLIPTST,'PAIRP); PUT('PAIRP,'FLIPTST,'ATOM); PUT('STRINGP,'FLIPTST,'NOTSTRINGP); PUT('NOTSTRINGP,'FLIPTST,'STRINGP); PUT('BytesP,'FLIPTST,'NOTBytesP); PUT('NOTBytesP,'FLIPTST,'BytesP); PUT('WrdsP,'FLIPTST,'NOTWrdsP); PUT('NOTWrdsP,'FLIPTST,'WrdsP); PUT('HalfwordsP,'FLIPTST,'NOTHalfwordsP); PUT('NOTHalfwordsP,'FLIPTST,'HalfwordsP); PUT('CODEP,'FLIPTST,'NOTCODEP); PUT('NOTCODEP, 'FLIPTST,'CODEP); PUT('IDP,'FLIPTST,'NOTIDP); PUT('NOTIDP,'FLIPTST,'IDP); PUT('INTP,'FLIPTST,'NOTINTP); PUT('NOTINTP,'FLIPTST,'INTP); PUT('POSINTP,'FLIPTST,'NOTPOSINTP); PUT('NOTPOSINTP,'FLIPTST,'POSINTP); PUT('NEGINTP,'FLIPTST,'NOTNEGINTP); PUT('NOTNEGINTP,'FLIPTST,'NEGINTP); PUT('FIXP,'FLIPTST,'NOTFIXP); PUT('NOTFIXP,'FLIPTST,'FIXP); PUT('NUMBERP,'FLIPTST,'NOTNUMBERP); PUT('NOTNUMBERP,'FLIPTST,'NUMBERP); PUT('FIXNP,'FLIPTST,'NOTFIXNP); PUT('NOTFIXNP,'FLIPTST,'FIXNP); PUT('FLOATP,'FLIPTST,'NOTFLOATP); PUT('NOTFLOATP,'FLIPTST,'FLOATP); PUT('BIGP,'FLIPTST,'NOTBIGP); PUT('NOTBIGP,'FLIPTST,'BIGP); PUT('VECTORP,'FLIPTST,'NOTVECTORP); PUT('NOTVECTORP,'FLIPTST,'VECTORP); PUT('WLESSP,'FLIPTST,'WGEQ); PUT('WGEQ,'FLIPTST,'WLESSP); PUT('WLEQ,'FLIPTST,'WGREATERP); PUT('WGREATERP,'FLIPTST,'WLEQ); % Match functions PUT('ANY,'MATCHFN,'!&ANY); PUT('VAR,'MATCHFN,'!&VAR); PUT('REG,'MATCHFN,'!®FP); PUT('DEST,'MATCHFN,'!&DEST); PUT('USESDEST,'MATCHFN,'!&USESDEST); PUT('REGN,'MATCHFN,'!®N); PUT('NOTDEST,'MATCHFN,'!&NOTDEST); PUT('NOTANYREG,'MATCHFN,'!&NOTANYREG); PUT('MEM,'MATCHFN,'!&MEM); PUT('ANYREGFN,'MATCHFN,'!&ANYREGFNP); % Tag properties FLAG('(!$LOCAL !$GLOBAL !$FLUID QUOTE WCONST IDLOC WVAR REG LABEL FRAME !*FRAMESIZE IREG), 'TERMINAL); FLAG('(!$LOCAL !$GLOBAL !$FLUID WVAR),'VAR); FLAG('(QUOTE WCONST IDLOC FRAMESIZE),'CONST); FLAG('(REG),'REG); FLAG('(!$FLUID !$GLOBAL),'EXTVAR); FLAG('(CAR CDR !$NAME MEMORY FRAMESIZE), 'ANYREG); FLAG('(!*ADDMEM !*MPYMEM),'MEMMOD); % Optimizing functions PUT('!*LBL, 'OPTFN, '!&LBLOPT); PUT('!*MOVE, 'OPTFN, '!&STOPT); PUT('!*JUMP, 'OPTFN, '!&JUMPOPT); % Things which can be compiled FLAG('(EXPR FEXPR MACRO NEXPR),'COMPILE); % Some compiler macros DEFLIST('((CAAR (LAMBDA (U) (CAR (CAR U)))) (CADR (LAMBDA (U) (CAR (CDR U)))) (CDAR (LAMBDA (U) (CDR (CAR U)))) (CDDR (LAMBDA (U) (CDR (CDR U)))) (CAAAR (LAMBDA (U) (CAR (CAR (CAR U))))) (CAADR (LAMBDA (U) (CAR (CAR (CDR U))))) (CADAR (LAMBDA (U) (CAR (CDR (CAR U))))) (CADDR (LAMBDA (U) (CAR (CDR (CDR U))))) (CDAAR (LAMBDA (U) (CDR (CAR (CAR U))))) (CDADR (LAMBDA (U) (CDR (CAR (CDR U))))) (CDDAR (LAMBDA (U) (CDR (CDR (CAR U))))) (CDDDR (LAMBDA (U) (CDR (CDR (CDR U))))) (EQCAR (LAMBDA (U V) ((LAMBDA (!%!%!%W) (AND (PAIRP !%!%!%W) (EQ (CAR !%!%!%W) V))) U))) (CONSTANTP (LAMBDA (U) ((LAMBDA (V) (NOT (OR (PAIRP V) (IDP V)))) U))) (WEQ (LAMBDA (U V) (EQ U V))) (WNEQ (LAMBDA (U V) (NE U V))) (IPLUS2 (LAMBDA (U V) (WPLUS2 U V))) (IADD1 (LAMBDA (U) (WPLUS2 U 1))) (IDIFFERENCE (LAMBDA (U V) (WDIFFERENCE U V))) (ISUB1 (LAMBDA (U) (WDIFFERENCE U 1))) (ITIMES2 (LAMBDA (U V) (WTIMES2 U V))) (IQUOTIENT (LAMBDA (U V) (WQUOTIENT U V))) (IREMAINDER (LAMBDA (U V) (WREMAINDER U V))) (IGREATERP (LAMBDA (U V) (WGREATERP U V))) (ILESSP (LAMBDA (U V) (WLESSP U V))) (ILEQ (LAMBDA (U V) (WLEQ U V))) (IGEQ (LAMBDA (U V) (WGEQ U V))) (ILOR (LAMBDA (U V) (WOR U V))) (ILSH (LAMBDA (U V) (WSHIFT U V))) (ILAND (LAMBDA (U V) (WAND U V))) (ILXOR (LAMBDA (U V) (WXOR U V))) (IZEROP (LAMBDA (U) (EQ U 0))) (IONEP (LAMBDA (U) (EQ U 1))) (IMINUSP (LAMBDA (U) (WLESSP U 0))) (IMINUS (LAMBDA (U) (WMINUS U))) (PUTFIELD (LAMBDA (U V W X) (PUTFIELDREV X U V W))) (MKITEM (LAMBDA (U V) (MKITEMREV V U))) (NEQ (LAMBDA (U V) (NOT (EQUAL U V)))) (GEQ (LAMBDA (U V) (NOT (LESSP U V)))) (LEQ (LAMBDA (U V) (NOT (GREATERP U V)))) (NOT (LAMBDA (U) (NULL U)))),'CMACRO); % Macro functions PUT('A1,'SUBSTFN,'!&ARG1); PUT('A2,'SUBSTFN,'!&ARG2); PUT('A3,'SUBSTFN,'!&ARG3); PUT('A4,'SUBSTFN,'!&ARG4); PUT('FN,'SUBSTFN,'!&PARAM1); PUT('MAC,'SUBSTFN,'!&PARAM2); PUT('P2,'SUBSTFN,'!&PARAM3); PUT('P3,'SUBSTFN,'!&PARAM4); PUT('T1,'SUBSTFN,'!&GETTEMP); PUT('T2,'SUBSTFN,'!&GETTEMP); PUT('T3,'SUBSTFN,'!&GETTEMP); PUT('T4,'SUBSTFN,'!&GETTEMP); PUT('L1,'SUBSTFN,'!&GETTEMPLBL); PUT('L2,'SUBSTFN,'!&GETTEMPLBL); PUT('L3,'SUBSTFN,'!&GETTEMPLBL); PUT('L4,'SUBSTFN,'!&GETTEMPLBL); % Emit functions PUT('!*LOAD,'EMITFN,'!&EMITLOAD); PUT('!*STORE,'EMITFN,'!&EMITSTORE); PUT('!*JUMP,'EMITFN,'!&EMITJUMP); PUT('!*LBL,'EMITFN,'!&EMITLBL); PUT('!*ADDMEM,'EMITFN,'!&EMITMEMMOD); PUT('!*MPYMEM,'EMITFN,'!&EMITMEMMOD); PUT('!*ADDMEM, 'UNMEMMOD, '!*WPLUS2); PUT('!*MPYMEM, 'UNMEMMOD, '!*WTIMES2); % In memory operations PUT('WPLUS2,'MEMMODFN,'!*ADDMEM); PUT('WTIMES2,'MEMMODFN,'!*MPYMEM); % Flip jump for conditional jump macros PUT('!*JUMPEQ,'NEGJMP,'!*JUMPNOTEQ); PUT('!*JUMPNOTEQ,'NEGJMP,'!*JUMPEQ); PUT('!*JUMPTYPE,'NEGJMP,'!*JUMPNOTTYPE); PUT('!*JUMPNOTTYPE,'NEGJMP,'!*JUMPTYPE); PUT('!*JUMPINTYPE,'NEGJMP,'!*JUMPNOTINTYPE); PUT('!*JUMPNOTINTYPE,'NEGJMP,'!*JUMPINTYPE); PUT('!*JUMPWEQ,'NEGJMP,'!*JUMPWNEQ); PUT('!*JUMPWNEQ,'NEGJMP,'!*JUMPWEQ); PUT('!*JUMPWLESSP,'NEGJMP,'!*JUMPWGEQ); PUT('!*JUMPWGEQ,'NEGJMP,'!*JUMPWLESSP); PUT('!*JUMPWLEQ,'NEGJMP,'!*JUMPWGREATERP); PUT('!*JUMPWGREATERP,'NEGJMP,'!*JUMPWLEQ); % Assorted other flags FLAG('(!*JUMP !*LINKE !*EXIT),'TRANSFER); FLAG('(!*LINK !*LINKE),'UNKNOWNUSE); PUT('!*LINK, 'EXITING, '!*LINKE); % Initialize variables !*MSG := T; % Do print messages !*INSTALLDESTROY := NIL; !*USINGDESTROY := T; !*SHOWDEST := NIL; !*NOFRAMEFLUID := T; !*USEREGFLUID := NIL; !*NOLINKE := NIL; %. Permit LINKE !*ORD := NIL; %. Dont force ORDER !*R2I := T; %. Do convert Rec to Iter GLOBALGENSYM!&:=LIST GENSYM(); % initialize symbol list MAXNARGS!&:=15; LASTACTUALREG!& := 5; END; |
Added psl-1983/comp/compiler.build version [7c5494f6df].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | CompileTime << load If!-System; >>; if_system(PDP10, << imports '(comp!-decls pass!-1!-lap dec20!-lap dec20!-cmac faslout); if_system(KL10, NIL, imports '(non!-kl!-comp)); >>); if_system(VAX, imports '(comp!-decls pass!-1!-lap vax!-lap vax!-cmac faslout)); if_system(HP9836, imports '(comp!-decls pass!-1!-lap hp!-lap hp!-cmac hp!-comp faslout)); in "compiler.red"$ |
Added psl-1983/comp/compiler.ctl version [0806832b87].
> > > > > | 1 2 3 4 5 | psl:rlisp loaddirectories!*:='("pl:"); load build; build 'compiler; quit; |
Added psl-1983/comp/compiler.log version [5609eb7b14].
cannot compute difference between binary files
Added psl-1983/comp/compiler.red version [afd6baa852].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 | % MLG: 15 Dec % added additional arguments to % Compiler BUG message in &LOCATE to get more info % <PSL.COMP>COMPILER.RED.19, 3-Dec-82 18:21:21, Edit by PERDUE % Removed REFORMNE, which was over-optimizing sometimes % <PSL.COMP>COMPILER.RED.18, 1-Dec-82 15:59:45, Edit by BENSON % Fixed car of atom bug in &PaApply % New extended compiler for PSL % John Peterson 4-5-81 % <PSL.COMP>COMPILER.RED.4, 20-Sep-82 11:40:31, Edit by BENSON % Slight improvement to "FOO not compiled" messages % <PSL.COMP>COMPILER.RED.2, 20-Sep-82 10:32:51, Edit by BENSON % (DE FOO (LIST) (LIST LIST)) does the right thing % <PSL.COMP>COMPILER.RED.10, 10-Sep-82 12:43:27, Edit by BENSON % NONLOCALSYS calls NONLOCALLISP if not WVAR or WARRAY % <PSL.COMP>COMPILER.RED.9, 10-Sep-82 09:53:08, Edit by BENSON % Changed error and warning messages CompileTime flag( '(!&COMPERROR !&COMPWARN !&IREG !&ADDRVALS !&ALLARGS1 !&ALLCONST !&ANYREG !&ANYREGL !&ANYREGP !&ARGLOC !&ASSOCOP1 !&ASSOCOP2 !&ATTACH !&ATTJMP !&ATTLBL !&CALL !&CALL1 !&CALLOPEN !&CFNTYPE !&CLASSMEMBER !&CLRSTR !&COMLIS !&COMLIS1 !&COMOPENTST !&COMPLY !&COMTST !&COMVAL !&COMVAL1 !&CONSTTAG !&DEFEQLBL !&DEFEQLBL1 !&DELARG !&DELCLASS !&DELETEMAC !&DELMAC !&EMITMAC !&EQP !&EQPL !&EQVP !&EXTERNALVARP !&FIXCHAINS !&FIXFRM !&FIXLABS !&FIXLINKS !&FIXREGTEST1 !&FRAME !&FREERSTR !&GENLBL !&GENSYM !&GETFRAMES !&GETFRAMES1 !&GETFRAMES2 !&GETFRM !&GETFVAR !&GETGROUPARGS !&GETGROUPARGS1 !&GETGROUPARGS2 !&GETLBL !&GETNUM !&HIGHEST !&HIGHEST1 !&HIGHEST2 !&INALL !&INSERTMAC !&INSOP !&INSOP1 !&INSTALLDESTROY !&INSTBL !&JUMPNIL !&JUMPT !&LABCLASS !&LBLEQ !&LOADARGS !&LOADOPENEXP !&LOADTEMP1 !&LOADTEMP2 !&LOADTEMPREG !&LOCATE !&LOCATEL !&LREG !&LREG1 !&MACROSUBST !&MACROSUBST1 !&MACROSUBST2 !&MAKEADDRESS !&MAKEXP !&MATCHES !&MEMADDRESS !&MKFRAME !&MKFUNC !&MKNAM !&MKPROGN !&MKREG !&MOVEJUMP &NOANYREG1 !&NOSIDEEFFECTP !&NOSIDEEFFECTPL !&OPENFNP !&OPENP !&OPENPL !&PA1V !&PALISV !&PA1X !&PAASSOC1 !&PAEQUAL1 !&PALIS !&PAMAPCOLLECT !&PAMAPCONC !&PAMAPDO !&PAMEMBER1 !&PANONLOCAL !&PAPROGBOD !&PASS1 !&PASS2 !&PASS3 !&PEEPHOLEOPT !&PROTECT !&RASSOC !&REFERENCES !&REFERENCESL !&REFEXTERNAL !&REFEXTERNALL !&REFMEMORY !&REFMEMORYL !&REFORMMACROS !®P !®VAL !&REMCODE !&REMMREFS !&REMMREFS1 !&REMOPEN !&REMREFS !&REMREFS1 !&REMREGS !&REMREGSL !&REMTAGS !&REMTAGS1 !&REMTAGS2 !&REMTAGS3 !&REMTAGS4 !&REMUNUSEDMAC !&REMVARL !&REMVREFS !&REMVREFS1 !&REPASC !&RMERGE !&RSTVAR !&RSTVARL !&RVAL !&SAVER1 !&STORELOCAL !&STOREVAR !&SUBARG !&SUBARGS !&TEMPREG !&TRANSFERP !&UNPROTECT !&UNUSEDLBLS !&USESDESTL !&VARBIND !&VARP !&WCONSTP !&CONSTP ISAWCONST MKNONLOCAL MKWCONST NONLOCAL NONLOCALLISP NONLOCALSYS PA1ERR WARRAYP WCONSTP WVARP), 'InternalFunction); GLOBAL '(ERFG!* !*NOLINKE !*ORD !*R2I !*UNSAFEBINDER MAXNARGS!& !*NOFRAMEFLUID !*USEREGFLUID !*INSTALLDESTROY !*USINGDESTROY !*SHOWDEST GLOBALGENSYM!&); % list of symbols to be re-used by the compiler FLUID '(ALSTS!& FLAGG!& NAME!& GOLIST!& CODELIST!& CONDTAIL!& LLNGTH!& NARG!& REGS!& EXITT!& LBLIST!& JMPLIST!& SLST!& STOMAP!& LASTACTUALREG!& DFPRINT!* !*PLAP !*SYSLISP SWITCH!& TOPLAB!& FREEBOUND!& STATUS!& REGS1!& PREGS!& DESTREG!& EXITREGS!& DEST!& ENVIRONMENT!& HOLEMAP!& LOCALGENSYM!&); % traveling pointer into GLOBALGENSYM!& %COMMENT ************************************************************** %********************************************************************** % THE STANDARD LISP COMPILER %********************************************************************** % Augmented for SYSLISP %*********************************************************************; % %COMMENT machine dependent parts are in a separate file; % %COMMENT these include the macros described below and, in addition, % an auxiliary function !&MKFUNC which is required to pass % functional arguments (input as FUNCTION <func>) to the % loader. In most cases, !&MKFUNC may be defined as MKQUOTE; % %COMMENT Registers used: %1-MAXNARGS!& used for args of link. result returned in reg 1; % %COMMENT Macros used in this compiler; % %COMMENT The following macros must NOT change REGS!& 1-MAXNARGS!&: %!*ALLOC nw allocate new stack frame of nw words %!*DEALLOC nw deallocate above frame %!*ENTRY name type noargs entry point to function name of type type % with noargs args %!*EXIT EXIT to previously saved return address %!*JUMP adr unconditional jump %!*LBL adr define label %!*LAMBIND regs alst bind free lambda vars in alst currently in regs %!*PROGBIND alst bind free prog vars in alst %!*FREERSTR alst unbind free variables in alst %!*STORE reg floc store contents of reg (or NIL) in floc % %COMMENT the following macro must only change specific register being % loaded: % %!*LOAD reg exp load exp into reg; % %COMMENT the following macros do not protect regs 1-MAXNARGS!&: % %!*LINK fn type nargs link to fn of type type with nargs args %!*LINKE fn type nargs nw link to fn of type type with nargs args % and EXITT!& removing frame of nw words; % % %COMMENT variable types are: % % LOCAL allocated on stack and known only locally % GLOBAL accessed via cell (GLOBAL name) known to % loader at load time % WGLOBAL accessed via cell (WGLOBAL name) known to % loader at load time, SYSLISP % FLUID accessed via cell (FLUID name) % known to loader. This cell is rebound by LAMBIND/ % PROGBIND if variable used in lambda/prog list % and restored by FREERSTR; % %COMMENT global flags used in this compiler: %!*UNSAFEBINDER for Don's BAKER problem...GC may be called in % Binder, so regs cant be preserved %!*MODULE indicates block compilation (a future extension of % this compiler) %!*NOLINKE if ON inhibits use of !*LINKE macro %!*ORD if ON forces left-to-right argument evaluation %!*PLAP if ON causes LAP output to be printed %!*R2I if ON causes recursion removal where possible; % % %COMMENT global variables used: % %DFPRINT!* name of special definition process (or NIL) %ERFG!* used by REDUCE to control error recovery %MAXNARGS!& maximum number of arguments permitted in implementation; % % % %%Standard LISP limit; % %COMMENT fluid variables used: % %ALSTS alist of fluid parameters %FLAGG used in COMTST, and in FIXREST %FREEBOUND indicates that some variables were FLUID %GOLIST storage map for jump labels %PREGS A list of protected registers %CODELIST code being built %CONDTAIL simulated stack of position in the tail of a COND %LLNGTH cell whose CAR is length of frame %NAME NAME!& of function being currently compiled %FNAME!& name of function being currently compiled, set by COMPILE %NARG number of arguments in function %REGS known current contents of registers as an alist with elements % of form (<reg> . <contents>) %EXITT label for *EXIT jump %EXITREGS List or register statuses at return point %LBLIST list of label words %JMPLIST list of locations in CODELIST!& of transfers %SLST association list for stores which have not yet been used %STOMAP storage map for variables %SWITCH boolean expression value flag - keeps track of NULLs; % SYMBOLIC PROCEDURE !&MKFUNC FN; MKQUOTE FN; SYMBOLIC PROCEDURE WARRAYP X; GET(X,'WARRAY) OR GET(X, 'WSTRING); SYMBOLIC PROCEDURE WVARP X; GET(X,'WVAR); SYMBOLIC PROCEDURE WCONSTP X; NUMBERP X OR (IDP X AND GET(X,'WCONST)); SYMBOLIC PROCEDURE !&ANYREGP X; FLAGP(X, 'ANYREG); macro procedure LocalF U; % declare functions internal, ala Franz list('flag, Mkquote cdr U, ''InternalFunction); %************************************************************ % The compiler %************************************************************ % Top level compile entry - X is list of functions to compile SYMBOLIC PROCEDURE COMPILE X; BEGIN SCALAR EXP; FOR EACH FNAME!& IN X DO <<EXP := GETD FNAME!&; IF NULL EXP THEN !&COMPWARN LIST("No definition for", FNAME!&) ELSE IF CODEP CDR EXP THEN !&COMPWARN LIST(FNAME!&, "already compiled") ELSE COMPD(FNAME!&,CAR EXP,CDR EXP)>> END; % COMPD - Single function compiler % Makes sure function type is compilable; sends original definition to % DFPRINT!*, then compiles the function. Shows LAP code when PLAP is on. % Runs LAP and adds COMPFN property if LAP indeed redefines the function. SYMBOLIC PROCEDURE COMPD(NAME!&,TY,EXP); BEGIN IF NOT FLAGP(TY,'COMPILE) THEN <<!&COMPERROR LIST("Uncompilable function type", TY); RETURN NIL>>; IF NOT EQCAR(EXP, 'LAMBDA) THEN << !&COMPERROR LIST("Attempt to compile non-lambda expression", EXP); RETURN NIL >> %/ ELSE IF !*MODULE THEN MODCMP(NAME!&,TY,EXP) % ELSE IF DFPRINT!* % THEN APPLY(DFPRINT!*,LIST IF TY EQ 'EXPR % THEN 'DE . (NAME!& . CDR EXP) % ELSE IF TY EQ 'FEXPR % THEN 'DF . (NAME!& . CDR EXP) % ELSE IF TY EQ 'MACRO %% THEN 'DM . (NAME!& . CDR EXP) % ELSE IF TY EQ 'NEXPR % THEN 'DN . (NAME!& . CDR EXP) % ELSE LIST('PUTD,MKQUOTE NAME!&, % MKQUOTE TY, % MKQUOTE EXP)) ELSE BEGIN SCALAR X; IF TY MEMQ '(EXPR FEXPR) THEN PUT(NAME!&,'CFNTYPE,LIST TY); X := LIST('!*ENTRY,NAME!&,TY,LENGTH CADR EXP) . !&COMPROC(EXP, IF TY MEMQ '(EXPR FEXPR) THEN NAME!&); IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y; % ***Code**Pointer** is a magic token that tells % COMPD to return a code pointer instead of an ID IF NAME!& = '!*!*!*Code!*!*Pointer!*!*!* then NAME!& := LAP X ELSE << LAP X; %this is the hook to the assembler. LAP must %remove old function definition if it exists; IF (X := GET(NAME!&,'CFNTYPE)) AND EQCAR(GETD NAME!&,CAR X) THEN REMPROP(NAME!&,'CFNTYPE) >> END; RETURN NAME!& END; %************************************************************ % Pass 1 routines %************************************************************ SYMBOLIC PROCEDURE !&PASS1 EXP; %. Pass1- reform body of expression for !&PA1(EXP,NIL); % Compilation SYMBOLIC PROCEDURE PA1ERR(X); %. Error messages from PASS1 STDERROR LIST("-- PA1 --", X); lisp procedure !&Pa1(U, Vbls); !&Pa1V(U, Vbls, NIL); % Do the real pass1 and an extra reform SYMBOLIC PROCEDURE !&PA1V(U,VBLS, VAR); BEGIN SCALAR Z,FN; % Z is the pass1 result. Reform if necessary Z:=!&PA1X(U,VBLS, VAR); IF IDP CAR Z AND (FN:=GET(CAR Z,'PA1REFORMFN)) THEN Z := APPLY(FN,LIST Z); RETURN Z; END; SYMBOLIC PROCEDURE !&PA1X(U,VBLS,VAR); %. VBLS are current local vars BEGIN SCALAR X; RETURN IF ATOM U % tag variables and constants THEN IF ISAWCONST U THEN MKWCONST U ELSE IF CONSTANTP U OR U MEMQ '(NIL T) THEN MKQUOTE U ELSE IF NONLOCAL U THEN !&PANONLOCAL(U, VBLS) ELSE IF U MEMQ VBLS THEN LIST('!$LOCAL,U) ELSE <<MKNONLOCAL U; !&PANONLOCAL(U, VBLS) >> ELSE IF NOT IDP CAR U THEN IF EQCAR(CAR U,'LAMBDA) THEN !&PA1V(CAR U,VBLS,VAR) . !&PALISV(CDR U,VBLS,VAR) ELSE % Change to APPLY << !&COMPERROR list("Ill-formed function expression", U); '(QUOTE NIL) >> % Changed semantics of EVAL to conform to Common Lisp. % CAR of a form is NEVER evaluated. % ELSE IF CAR U MEMQ VBLS OR FLUIDP CAR U % OR (GLOBALP CAR U % AND NOT GETD CAR U) THEN % Change to APPLY % << !&COMPWARN list("Functional form converted to APPLY", U); % !&PA1(LIST('APPLY, CAR U, 'LIST . CDR U), VBLS) >> ELSE IF X := GET(CAR U,'PA1ALGFN) % Do const folding, etc. THEN APPLY(X,LIST(U,VBLS,VAR)) ELSE IF X := GET(CAR U,'PA1FN) % Do PA1FN's THEN APPLY(X,LIST(U,VBLS)) ELSE IF X := GET(CAR U,'CMACRO) % CMACRO substitution THEN !&PA1V(SUBLIS(PAIR(CADR X,CDR U),CADDR X),VBLS,VAR) ELSE IF (X := GETD CAR U) % Expand macros AND CAR X EQ 'MACRO AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN !&PA1V(APPLY(CDR X,LIST U),VBLS,VAR) ELSE IF !&CFNTYPE CAR U EQ 'FEXPR % Transform FEXPR calls to AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN LIST(CAR U,MKQUOTE CDR U) % EXPR calls ELSE IF !&CFNTYPE CAR U EQ 'NEXPR % Transform NEXPR calls to AND NOT (GET(CAR U,'COMPFN) OR GET(CAR U,'OPENFN)) THEN LIST(CAR U,!&PA1V('LIST . CDR U,VBLS,VAR)) % EXPR calls ELSE CAR U . !&PALISV(CDR U,VBLS,VAR); END; SYMBOLIC PROCEDURE !&PALIS(U,VBLS); !&PALISV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&PALISV(U,VBLS, VAR); FOR EACH X IN U COLLECT !&PA1V(X,VBLS,VAR); SYMBOLIC PROCEDURE ISAWCONST X; %. Check to see if WCONST, %. in SYSLISP only !*SYSLISP AND WCONSTP X; SYMBOLIC PROCEDURE !&CONSTTAG(); IF !*SYSLISP THEN 'WCONST ELSE 'QUOTE; SYMBOLIC PROCEDURE MKWCONST X; %. Made into WCONST BEGIN SCALAR Y; RETURN LIST('WCONST, IF (Y := GET(X, 'WCONST)) AND NOT GET(X, 'WARRAY) AND NOT GET(X, 'WSTRING) THEN Y ELSE X); END; SYMBOLIC PROCEDURE !&PAWCONST(U, VBLS); MKWCONST CADR U; SYMBOLIC PROCEDURE NONLOCAL X; %. Default NON-LOCAL types IF !*SYSLISP THEN NONLOCALSYS X ELSE NONLOCALLISP X; SYMBOLIC PROCEDURE NONLOCALLISP X; IF FLUIDP X THEN '!$FLUID ELSE IF GLOBALP X THEN '!$GLOBAL ELSE IF WVARP X OR WARRAYP X THEN <<!&COMPWARN LIST(X,"already SYSLISP non-local");NIL>> ELSE NIL; SYMBOLIC PROCEDURE NONLOCALSYS X; IF WARRAYP X THEN 'WARRAY ELSE IF WVARP X THEN 'WVAR ELSE NONLOCALLISP X; SYMBOLIC PROCEDURE !&PANONLOCAL(X, VBLS); %. Reform Non-locals % X will be a declared NONLOCAL BEGIN SCALAR Z; RETURN IF NOT IDP X OR NOT NONLOCAL X THEN PA1ERR LIST("non-local error",X) ELSE IF FLUIDP X THEN LIST('!$FLUID,X) ELSE IF GLOBALP X THEN LIST('!$GLOBAL,X) ELSE IF GET(X,'WVAR) THEN IF X MEMBER VBLS THEN <<!&COMPWARN(LIST('WVAR,X,"used as local")); LIST('!$LOCAL,X)>> ELSE LIST('WVAR,X) ELSE IF WARRAYP X THEN LIST('WCONST, X) ELSE PA1ERR LIST("Unknown in PANONLOCAL",X); END; % Make unknown symbols into FLUID for LISP, WVAR for SYSLISP, with warning % Changed to just declare it fluid, EB, 9:36am Friday, 10 September 1982 SYMBOLIC PROCEDURE MKNONLOCAL U; % IF !*SYSLISP THEN % << !&COMPERROR LIST("Undefined symbol", U, % "in Syslisp, treated as WVAR"); % WDECLARE1(U, 'INTERNAL, 'WVAR, NIL, 0); % LIST('WVAR, U) >> % ELSE <<!&COMPWARN LIST(U,"declared fluid"); FLUID LIST U; LIST('!$FLUID,U)>>; % Utility stuff for the PA1 functions SYMBOLIC PROCEDURE !&MKNAM U; %generates unique name for auxiliary function in U; IMPLODE NCONC(EXPLODE U,EXPLODE !&GENSYM()); % For making implied PROGN's into explicit ones (as in COND) SYMBOLIC PROCEDURE !&MKPROGN U; IF NULL U OR CDR U THEN 'PROGN . U ELSE CAR U; SYMBOLIC PROCEDURE !&EQP U; %!&EQP is true if U is an object for which EQ can replace EQUAL; INUMP U OR IDP U; SYMBOLIC PROCEDURE !&EQVP U; %!&EQVP is true if EVAL U is an object for which EQ can %replace EQUAL; INUMP U OR NULL U OR U EQ 'T OR EQCAR(U,'QUOTE) AND !&EQP CADR U; % !&EQPL U is true if !&EQP of all elements of U SYMBOLIC PROCEDURE !&EQPL U; NULL U OR !&EQP(CAR U) AND !&EQPL(CDR U); SYMBOLIC PROCEDURE !&MAKEADDRESS U; % convert an expression into an addressing expression, (MEMORY var const), % where var is the variable part & const is the constant part (tagged, of % course). It is assumed that U has been through pass 1, which does constant % folding & puts any constant term at the top level. IF EQCAR(U,'LOC) THEN CADR U ELSE % GETMEM LOC x == x 'MEMORY . (IF EQCAR(U,'WPLUS2) AND !&CONSTP CADDR U THEN CDR U ELSE IF EQCAR(U,'WDIFFERENCE) AND !&CONSTP CADR U THEN LIST(LIST('WMINUS,CADDR U),CADR U) ELSE LIST(U,'(WCONST 0))); SYMBOLIC PROCEDURE !&DOOP U; % simplification for random operators - op is doable only when all operands % are constant IF !&ALLCONST CDR U THEN LIST(CAR CADR U, APPLY(GET(CAR U,'DOFN) or car U, FOR EACH X IN CDR U COLLECT CADR X)) ELSE U; SYMBOLIC PROCEDURE !&ALLCONST L; NULL L OR (car L = 'QUOTE or !&WCONSTP CAR L AND NUMBERP CADR CAR L) AND !&ALLCONST CDR L; lisp procedure !&PaReformWTimes2 U; begin scalar X; U := !&Doop U; return if first U = 'WTimes2 then if !&WConstP second U and (X := PowerOf2P second second U) then list('WShift, third U, list(!&ConstTag(), X)) else if !&WConstP third U and (X := PowerOf2P second third U) then list('WShift, second U, list(!&ConstTag(), X)) else U else U; end; SYMBOLIC PROCEDURE !&ASSOCOP(U,VBLS); % For abelian semi-groups & monoids % given an associative, communitive operation (TIMES2, AND, ...) collect all % arguments, seperate constant args, evaluate true constants, check for zero's % and ones (0*X = 0, 1*X = X) !&ASSOCOPV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&ASSOCOPV(U,VBLS,VAR); BEGIN SCALAR ARGS,NUM,CONSTS,VARS; ARGS := !&ASSOCOP1(CAR U,!&PALIS(CDR U,VBLS)); CONSTS := VARS := NUM := NIL; FOR EACH ARG IN ARGS DO IF !&WCONSTP ARG THEN IF NUMBERP CADR ARG THEN IF NUM THEN NUM := APPLY(GET(CAR U,'DOFN),LIST(NUM,CADR ARG)) ELSE NUM := CADR ARG ELSE CONSTS := NCONC(CONSTS,LIST ARG) ELSE VARS := NCONC(VARS,LIST ARG); IF NUM THEN <<IF NUM = GET(CAR U,'ZERO) THEN RETURN LIST(!&CONSTTAG(),NUM); IF NUM NEQ GET(CAR U,'ONE) THEN CONSTS := NUM . CONSTS ELSE IF NULL VARS AND NULL CONSTS THEN RETURN LIST(!&CONSTTAG(), NUM) >>; IF CONSTS THEN VARS := NCONC(VARS,LIST LIST('WCONST,!&INSOP(CAR U,CONSTS))); IF VAR MEMBER VARS THEN <<VARS := DELETIP(VAR,VARS); RETURN !&INSOP(CAR U,REVERSIP(VAR . REVERSIP VARS))>>; RETURN !&INSOP(CAR U,VARS); END; SYMBOLIC PROCEDURE !&ASSOCOP1(OP,ARGS); IF NULL ARGS THEN NIL ELSE NCONC(!&ASSOCOP2(OP,CAR ARGS),!&ASSOCOP1(OP,CDR ARGS)); SYMBOLIC PROCEDURE !&ASSOCOP2(OP,ARG); IF EQCAR(ARG,OP) THEN !&ASSOCOP1(OP,CDR ARG) ELSE LIST ARG; SYMBOLIC PROCEDURE !&INSOP(OP,L); % Insert OP into a list of operands as follows: INSOP(~,'(A B C D)) = % (~ (~ (~ A B) C) D) IF NULL L THEN NIL ELSE if null cdr L then car L else !&INSOP1(list(OP, first L, second L), rest rest L, OP); SYMBOLIC PROCEDURE !&INSOP1(NEW, RL, OP); if null RL then NEW else !&INSOP1(list(OP, NEW, first RL), rest RL, OP); SYMBOLIC PROCEDURE !&GROUP(U,VBLS); % Like ASSOP, except inverses exist. All operands are partitioned into two % lists, non-inverted and inverted. Cancellation is done between these two % lists. The group is defined by three operations, the group operation (+), % inversion (unary -), and subtraction (dyadic -). The GROUPOPS property on % all three of there operators must contain the names of these operators in % the order (add subtract minus) !&GROUPV(U,VBLS,NIL); SYMBOLIC PROCEDURE !&GROUPV(U,VBLS,VAR); BEGIN SCALAR X,ARGS,INVARGS,FNS,CONSTS,INVCONSTS,CON,RES,VFLG,INVFLG,ONE; FNS := GET(CAR U,'GROUPOPS); ONE := LIST(!&CONSTTAG(),GET(CAR FNS,'ONE)); X := !&GETGROUPARGS(FNS,CAR U . !&PALIS(CDR U, VBLS),NIL,'(NIL NIL)); ARGS := CAR X; INVARGS := CADR X; FOR EACH ARG IN ARGS DO IF ARG MEMBER INVARGS THEN <<ARGS := !&DELARG(ARG,ARGS); INVARGS := !&DELARG(ARG,INVARGS)>>; CONSTS := INVCONSTS := CON := NIL; FOR EACH ARG IN ARGS DO IF !&WCONSTP ARG THEN <<ARGS := !&DELARG(ARG,ARGS); IF NUMBERP CADR ARG THEN IF CON THEN CON := APPLY(GET(CAR FNS,'DOFN),LIST(CON,CADR ARG)) ELSE CON := CADR ARG ELSE CONSTS := NCONC(CONSTS,LIST ARG)>>; FOR EACH ARG IN INVARGS DO IF !&WCONSTP ARG THEN <<INVARGS := !&DELARG(ARG,INVARGS); IF NUMBERP CADR ARG THEN IF CON THEN CON := APPLY(GET(CADR FNS,'DOFN),LIST(CON,CADR ARG)) ELSE CON := APPLY(GET(CADDR FNS,'DOFN),LIST CADR ARG) ELSE INVCONSTS := NCONC(INVCONSTS,LIST ARG)>>; IF CON AND CON = GET(CAR FNS,'ZERO) THEN RETURN LIST(!&CONSTTAG(),CON); IF CON AND CON = CADR ONE THEN CON := NIL; IF CON THEN CONSTS := CON . CONSTS; CONSTS := !&MAKEXP(CONSTS,INVCONSTS,FNS); IF CONSTS AND NOT !&WCONSTP CONSTS THEN CONSTS := LIST('WCONST,CONSTS); IF VAR MEMBER ARGS THEN <<ARGS := DELETE(VAR,ARGS); VFLG := T; INVFLG := NIL>>; IF VAR MEMBER INVARGS THEN <<INVARGS := DELETE(VAR,INVARGS); VFLG := T; INVFLG := T>>; ARGS := !&MAKEXP(ARGS,INVARGS,FNS); RES := IF NULL ARGS THEN IF NULL CONSTS THEN ONE ELSE CONSTS ELSE IF NULL CONSTS THEN ARGS ELSE IF EQCAR(ARGS,CADDR FNS) THEN LIST(CADR FNS,CONSTS,CADR ARGS) ELSE LIST(CAR FNS,ARGS,CONSTS); IF VFLG THEN IF RES = ONE THEN IF INVFLG THEN RES := LIST(CADDR FNS,VAR) ELSE RES := VAR ELSE RES := LIST(IF INVFLG THEN CADR FNS ELSE CAR FNS,RES,VAR); RETURN RES; END; SYMBOLIC PROCEDURE !&MAKEXP(ARGS,INVARGS,FNS); IF NULL ARGS THEN IF NULL INVARGS THEN NIL ELSE LIST(CADDR FNS,!&INSOP(CAR FNS,INVARGS)) ELSE IF NULL INVARGS THEN !&INSOP(CAR FNS,ARGS) ELSE !&INSOP(CADR FNS,!&INSOP(CAR FNS,ARGS) . INVARGS); SYMBOLIC PROCEDURE !&GETGROUPARGS(FNS,EXP,INVFLG,RES); IF ATOM EXP OR NOT(CAR EXP MEMBER FNS) THEN !&GETGROUPARGS1(EXP,INVFLG,RES) ELSE IF CAR EXP EQ CAR FNS THEN !&GETGROUPARGS2(FNS,CDR EXP,INVFLG,RES) ELSE IF CAR EXP EQ CADR FNS THEN !&GETGROUPARGS(FNS,CADR EXP,INVFLG, !&GETGROUPARGS(FNS,CADDR EXP,NOT INVFLG,RES)) ELSE IF CAR EXP EQ CADDR FNS THEN !&GETGROUPARGS(FNS,CADR EXP,NOT INVFLG,RES) ELSE !&COMPERROR(LIST("Compiler bug in constant folding",FNS,EXP)); SYMBOLIC PROCEDURE !&GETGROUPARGS1(THING,INVFLG,RES); IF INVFLG THEN LIST(CAR RES,THING . CADR RES) ELSE (THING . CAR RES) . CDR RES; SYMBOLIC PROCEDURE !&GETGROUPARGS2(FNS,ARGS,INVFLG,RES); IF NULL ARGS THEN RES ELSE !&GETGROUPARGS2(FNS,CDR ARGS,INVFLG, !&GETGROUPARGS(FNS,CAR ARGS,INVFLG,RES)); SYMBOLIC PROCEDURE !&DELARG(ARG,ARGS); IF ARG = CAR ARGS THEN CDR ARGS ELSE CAR ARGS . !&DELARG(ARG,CDR ARGS); %************************************************************ % Pass 1 functions %************************************************************ lisp procedure !&PaApply(U, Vars); if EqCar(third U, 'LIST) then % set up for !&COMAPPLY if EqCar(second U, 'function) and !&CfnType second second U = 'EXPR then !&Pa1(second second U . rest third U, Vars) else list('APPLY, !&Pa1(second U, Vars), 'LIST . !&PaLis(rest third U, Vars)) else 'APPLY . !&PaLis(rest U, Vars); % Try to turn ASSOC into ATSOC SYMBOLIC PROCEDURE !&PAASSOC(U,VARS); !&PAASSOC1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAASSOC1(ASSOCVAR,ASSOCLIST); IF !&EQVP ASSOCVAR OR EQCAR(ASSOCLIST,'QUOTE) AND !&EQPL(FOR EACH U IN CADR ASSOCLIST COLLECT CAR U) THEN 'ATSOC ELSE 'ASSOC; SYMBOLIC PROCEDURE !&PACOND(U,VBLS); begin scalar RevU, Result, Temp; if null cdr U then return '(QUOTE NIL); % (COND) == NIL RevU := reverse cdr U; if first first RevU neq T then RevU := '(T NIL) . RevU; for each CondForm in RevU do if null rest CondForm then << if not Temp then << Temp := !&Gensym(); VBLS := Temp . VBLS >>; Result := list(!&PA1(list('SETQ, Temp, first CondForm), VBLS), !&PA1(Temp, VBLS)) . Result >> else Result := list(!&PA1(first CondForm, VBLS), !&PA1(!&MkProgN rest CondForm, VBLS)) . Result; return if Temp then list(list('LAMBDA, list !&PA1(Temp, VBLS), 'COND . Result), '(QUOTE NIL)) else 'COND . Result; end; lisp procedure !&PaCatch(U, Vbls); (lambda(Tag, Forms); << if null cdr Forms and (atom car Forms or car car Forms = 'QUOTE or car car Forms = 'LIST) then !&CompWarn list("Probable obsolete use of CATCH:", U); !&Pa1(list(list('lambda, '(!&!&HiddenVar!&!&), list('cond, list('(null ThrowSignal!*), list('(lambda (xxx) (!%UnCatch !&!&HiddenVar!&!&) xxx), 'progn . Forms)), '(t !&!&HiddenVar!&!&))), list('CatchSetup, Tag)), Vbls)>>)(cadr U, cddr U); % X-1 -> SUB1 X SYMBOLIC PROCEDURE !&PADIFF(U,VARS); IF CADDR U=1 THEN LIST('SUB1,!&PA1(CADR U,VARS)) ELSE 'DIFFERENCE . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAEQUAL(U,VARS); !&PAEQUAL1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAEQUAL1(LEFT,RIGHT); IF !&EQVP LEFT OR !&EQVP RIGHT THEN 'EQ ELSE IF NUMBERP LEFT OR NUMBERP RIGHT THEN 'EQN ELSE 'EQUAL; % FUNCTION will compile a non-atomic arg into a GENSYMed name. % Currently, MKFUNC = MKQUOTE SYMBOLIC PROCEDURE !&PAFUNCTION(U,VBLS); IF ATOM CADR U THEN !&MKFUNC CADR U % COMPD returns a code pointer here ELSE !&MKFUNC COMPD('!*!*!*Code!*!*Pointer!*!*!*, 'EXPR,CADR U); SYMBOLIC PROCEDURE !&PAGETMEM(U,VBLS); !&MAKEADDRESS !&PA1(CADR U,VBLS); SYMBOLIC PROCEDURE !&PAIDENT(U,VBLS); %. return form U; % LAMBDA - pick up new vars, check implicit PROGN SYMBOLIC PROCEDURE !&PACASE(U,VBLS); 'CASE . !&PA1(CADR U,VBLS) . FOR EACH EXP IN CDDR U COLLECT LIST(!&PALIS(CAR EXP,VBLS),!&PA1(CADR EXP,VBLS)); SYMBOLIC PROCEDURE !&PALAMBDA(U,VBLS); <<VBLS := APPEND(CADR U,VBLS); 'LAMBDA . LIST(!&PALIS(CADR U,VBLS),!&PA1(!&MKPROGN CDDR U,VBLS)) >>; % X<0 -> MINUSP(X) SYMBOLIC PROCEDURE !&PALESSP(U,VARS); IF CADDR U=0 THEN LIST('MINUSP,!&PA1(CADR U,VARS)) ELSE 'LESSP . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PALIST(U, VBLS); BEGIN SCALAR L,FN; L := LENGTH CDR U; RETURN IF L = 0 THEN '(QUOTE NIL) ELSE IF FN := ASSOC(L,'((1 . NCONS) (2 . LIST2) (3 . LIST3) (4 . LIST4) (5 . LIST5))) THEN !&PA1(CDR FN . CDR U, VBLS) ELSE !&PA1(LIST('CONS,CADR U, 'LIST . CDDR U), VBLS); END; lisp procedure !&PaNth(U, Vbls); !&PaNths(U, Vbls, '((1 . CAR) (2 . CADR) (3 . CADDR) (4 . CADDDR))); lisp procedure !&PaPNth(U, Vbls); !&PaNths(U, Vbls, '((1 . CR) (2 . CDR) (3 . CDDR) (4 . CDDDR) (5 . CDDDDR))); lisp procedure !&PaNths(U, Vbls, FnTable); begin scalar N, X, Fn; N := !&Pa1(third U, Vbls); X := second U; return if first N memq '(QUOTE WCONST) and FixP second N and (Fn := Assoc(second N, FnTable)) then if cdr Fn = 'CR then !&Pa1(X, Vbls) else !&Pa1(list(cdr Fn, X), Vbls) else list(car U, !&Pa1(X, Vbls), N); end; SYMBOLIC PROCEDURE !&PAMAP(U, VBLS); !&PAMAPDO(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPC(U, VBLS); !&PAMAPDO(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPDO(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP; TMP := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP) (SETQ TMP STARTINGLIST) LOOPLABEL (COND ((ATOM TMP) (RETURN NIL))) FNCALL (SETQ TMP (CDR TMP)) (GO LOOPLABEL))), VBLS); END; SYMBOLIC PROCEDURE !&PAMAPLIST(U, VBLS); !&PAMAPCOLLECT(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPCAR(U, VBLS); !&PAMAPCOLLECT(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPCOLLECT(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP, RESULT, ENDPTR; TMP := !&GENSYM(); RESULT := !&GENSYM(); ENDPTR := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'RESULT . RESULT, 'ENDPTR . ENDPTR, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP RESULT ENDPTR) (SETQ TMP STARTINGLIST) (COND ((ATOM TMP) (RETURN NIL))) (SETQ RESULT (SETQ ENDPTR (NCONS FNCALL))) LOOPLABEL (SETQ TMP (CDR TMP)) (COND ((ATOM TMP) (RETURN RESULT))) (RPLACD ENDPTR (NCONS FNCALL)) (SETQ ENDPTR (CDR ENDPTR)) (GO LOOPLABEL))), VBLS); END; SYMBOLIC PROCEDURE !&PAMAPCON(U, VBLS); !&PAMAPCONC(U, VBLS, NIL); SYMBOLIC PROCEDURE !&PAMAPCAN(U, VBLS); !&PAMAPCONC(U, VBLS, T); SYMBOLIC PROCEDURE !&PAMAPCONC(U, VBLS, CARFLAG); IF NOT EQCAR(CADDR U,'FUNCTION) THEN CAR U . !&PALIS(CDR U,VBLS) ELSE BEGIN SCALAR TMP, RESULT, ENDPTR; TMP := !&GENSYM(); RESULT := !&GENSYM(); ENDPTR := !&GENSYM(); RETURN !&PA1(SUBLA(LIST('TMP . TMP, 'RESULT . RESULT, 'ENDPTR . ENDPTR, 'STARTINGLIST . CADR U, 'FNCALL . LIST(CADR CADDR U, IF CARFLAG THEN LIST('CAR, TMP) ELSE TMP)), '(PROG (TMP RESULT ENDPTR) (SETQ TMP STARTINGLIST) STARTOVER (COND ((ATOM TMP) (RETURN NIL))) (SETQ RESULT FNCALL) (SETQ ENDPTR (LASTPAIR RESULT)) (SETQ TMP (CDR TMP)) (COND ((ATOM ENDPTR) (GO STARTOVER))) LOOPLABEL (COND ((ATOM TMP) (RETURN RESULT))) (RPLACD ENDPTR FNCALL) (SETQ ENDPTR (LASTPAIR ENDPTR)) (SETQ TMP (CDR TMP)) (GO LOOPLABEL))), VBLS); END; % Attempt to change MEMBER to MEMQ SYMBOLIC PROCEDURE !&PAMEMBER(U,VARS); !&PAMEMBER1(CADR U,CADDR U) . !&PALIS(CDR U,VARS); SYMBOLIC PROCEDURE !&PAMEMBER1(THING,LST); IF !&EQVP THING OR EQCAR(LST,'QUOTE) AND !&EQPL CADR LST THEN 'MEMQ ELSE 'MEMBER; % (Intern (Compress X)) == (Implode X) % (Intern (Gensym)) == (InternGensym) SYMBOLIC PROCEDURE !&PAINTERN(U, VBLS); << U := !&PA1(CADR U, VBLS); IF EQCAR(U, 'COMPRESS) THEN 'IMPLODE . CDR U ELSE IF EQCAR(U, 'GENSYM) THEN 'INTERNGENSYM . CDR U ELSE LIST('INTERN, U) >>; % Do MINUS on constants. SYMBOLIC PROCEDURE !&PAMINUS(U,VBLS); IF EQCAR(U := !&PA1(CADR U,VBLS),'QUOTE) AND NUMBERP CADR U THEN MKQUOTE ( - CADR U) ELSE IF EQCAR(U ,'WCONST) AND NUMBERP CADR U THEN MKWCONST ( - CADR U) ELSE LIST('MINUS,U); SYMBOLIC PROCEDURE !&REFORMLOC U; IF EQCAR(CADR U, 'MEMORY) THEN LIST('WPLUS2, CADDR CADR U, CADR CADR U) ELSE U; SYMBOLIC PROCEDURE !&REFORMNULL U; BEGIN SCALAR FLIP; RETURN IF PAIRP CADR U AND (FLIP := GET(CAADR U,'FLIPTST)) THEN FLIP . CDADR U ELSE LIST('EQ, CADR U, '(QUOTE NIL)); END; % Perdue 12/3/82 % This optimization causes compiled code to behave differently % from interpreted code. The FLIPTST property on NE and PASS2 % handling of negation in tests (&COMTST) are enough to cause good code % to be generated when NE is used as a test. % SYMBOLIC PROCEDURE !&REFORMNE U; % IF CADR U = '(QUOTE NIL) THEN CADDR U % ELSE IF CADDR U = '(QUOTE NIL) THEN CADR U % ELSE U; % PLUS2(X,1) -> ADD1(X) SYMBOLIC PROCEDURE !&PAPLUS2(U,VARS); IF CADDR U=1 THEN !&PA1(LIST('ADD1, CADR U),VARS) ELSE IF CADR U=1 THEN !&PA1('ADD1 . CDDR U,VARS) ELSE 'PLUS2 . !&PALIS(CDR U,VARS); % Pick up PROG vars, ignore labels. SYMBOLIC PROCEDURE !&PAPROG(U,VBLS); <<VBLS := APPEND(CADR U,VBLS); 'PROG . (!&PALIS(CADR U,VBLS) . !&PAPROGBOD(CDDR U,VBLS)) >>; SYMBOLIC PROCEDURE !&PAPROGBOD(U,VBLS); FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VBLS); SYMBOLIC PROCEDURE !&PAPUTMEM(U,VBLS); !&PA1('SETQ . LIST('GETMEM, CADR U) . CDDR U, VBLS); SYMBOLIC PROCEDURE !&PAPUTLISPVAR(U, VBLS); !&PA1('SETQ . LIST('LISPVAR, CADR U) . CDDR U, VBLS); SYMBOLIC PROCEDURE !&PALISPVAR(U, VBLS); LIST('!$FLUID, CADR U); SYMBOLIC PROCEDURE !&PASETQ(U,VBLS); BEGIN SCALAR VAR,FN,EXP, LN; LN := LENGTH CDR U; IF LN NEQ 2 THEN RETURN << LN := DIVIDE(LN, 2); IF CDR LN NEQ 0 THEN << !&COMPERROR LIST("Odd number of arguments to SETQ", U); U := APPEND(U, LIST NIL); LN := CAR LN + 1 >> ELSE LN := CAR LN; U := CDR U; FOR I := 1 STEP 1 UNTIL LN DO << EXP := LIST('SETQ, CAR U, CADR U) . EXP; U := CDDR U >>; !&PA1('PROGN . REVERSIP EXP, VBLS) >>; VAR := !&PA1(CADR U,VBLS); EXP := !&PA1V(CADDR U, VBLS, VAR); U := IF FLAGP(CAR VAR,'VAR) THEN LIST('!$NAME,VAR) ELSE VAR; IF (NOT (FN := GET(CAR EXP,'MEMMODFN))) OR not (LastCar EXP = VAR) THEN RETURN LIST('SETQ,U,EXP) ELSE RETURN FN . U . REVERSIP CDR REVERSIP CDR EXP; END; SYMBOLIC PROCEDURE !&INSTALLDESTROY(NAME!&); % determine which (if any) registers are unaltered by the function. % Print this information out if !*SHOWDEST, install it on the % property list of the function if !*INSTALLDESTOY BEGIN SCALAR DESTL,R,HRU; HRU := !&HIGHEST(CODELIST!&,NIL,NARG!&,T); % Find the highest register used in the code. Registers above this are % unchanged. Incoming registers have a distinguished value, IREG n, placed % in register n. If this value remains, it has not been destroyed. IF HRU = 'ALL THEN RETURN NIL; DESTL := NIL; FOR I := 1:NARG!& DO <<R := !&MKREG I; IF NOT (!&IREG I MEMBER !®VAL R) THEN DESTL := R . DESTL>>; FOR I := NARG!&+1 : HRU DO DESTL := !&MKREG I . DESTL; IF NULL DESTL THEN DESTL := '((REG 1)); IF !*INSTALLDESTROY THEN PUT(NAME!&,'DESTROYS,DESTL); IF !*SHOWDEST THEN <<PRIN2 NAME!&;PRIN2 " DESTROYS ";PRIN2T DESTL>>; END; % COMPROC does the dirty work - initializes variables and gets the % three passes going. SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME!&); %compiles a function body, returning the generated LAP; BEGIN SCALAR CODELIST!&,FLAGG!&,JMPLIST!&,LBLIST!&, LOCALGENSYM!&, LLNGTH!&,REGS!&,REGS1!&,ALSTS!&, EXITT!&,TOPLAB!&,SLST!&,STOMAP!&, CONDTAIL!&,FREEBOUND!&,HOLEMAP!&,PREGS!&, SWITCH!&,EXITREGS!&,RN; INTEGER NARG!&; LOCALGENSYM!& := GLOBALGENSYM!&; PREGS!& := NIL; REGS!& := NIL; LLNGTH!& := 0; IF NOT EQCAR(EXP, 'LAMBDA) THEN << !&COMPERROR LIST("Attempt to compile a non-lambda expression", EXP); RETURN NIL >>; NARG!& := LENGTH CADR EXP; EXITREGS!& := NIL; EXITT!& := !&GENLBL(); TOPLAB!& := !&GENLBL(); STOMAP!& := NIL; CODELIST!& := LIST '(!*ALLOC (!*FRAMESIZE)); !&ATTLBL TOPLAB!&; EXP := !&PASS1 EXP; IF NARG!& > MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments",NARG!&); ALSTS!& := !&VARBIND(CADR EXP,T); % Generate LAMBIND RN := 1; FOR I := 1:LENGTH CADR EXP DO REGS!& := !&ADDRVALS(!&MKREG I,REGS!&,LIST( !&IREG I)); !&PASS2 CADDR EXP; !&FREERSTR(ALSTS!&,0); %Restores old fluid bindings !&PASS3(); IF !*INSTALLDESTROY OR !*SHOWDEST THEN !&INSTALLDESTROY(NAME!&); !&REFORMMACROS(); % Plugs compile time constants into macros. FIXFRM? !&REMTAGS(); % Kludge RETURN CODELIST!& END; lisp procedure !&IReg N; if N > 0 and N <= 15 then GetV('[() (IREG 1) (IREG 2) (IREG 3) (IREG 4) (IREG 5) (IREG 6) (IREG 7) (IREG 8) (IREG 9) (IREG 10) (IREG 11) (IREG 12) (IREG 13) (IREG 14) (IREG 15)], n) else list('IREG, N); SYMBOLIC PROCEDURE !&WCONSTP X; PairP X and (first X = 'WConst or first X = 'Quote and FixP second X); %************************************************************ % Pass 2 * %************************************************************ % Initialize STATUS!&=0 (Top level) SYMBOLIC PROCEDURE !&PASS2 EXP; !&COMVAL(EXP,0); SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS!&); % Compile EXP. Special cases: if STATUS!&>1 (compiling for side effects), % anyreg functions are ignored since they have no side effects. % Otherwise, top level ANYREG stuff is factored out and done via a LOAD % instead of a LINK. IF !&ANYREG(EXP) THEN IF STATUS!&>1 THEN <<IF NOT (CAR EXP MEMBER '(QUOTE !$LOCAL !$FLUID)) THEN !&COMPWARN(LIST("Value of", EXP, "not used, therefore not compiled")); NIL >> ELSE !&LREG1(EXP) % Just a LOAD ELSE % When not all ANYREG IF !&ANYREGFNP EXP % Is the top level an ANYREG fn? THEN IF STATUS!&>1 THEN <<!&COMVAL(CADR EXP,STATUS!&); !&COMPWARN LIST("Top level", CAR EXP, "in", EXP, "not used, therefore not compiled"); NIL>> ELSE !&LREG1(CAR EXP . !&COMLIS CDR EXP) % Preserve the anyreg fn ELSE !&COMVAL1(EXP,STOMAP!&,STATUS!&); % no anyregs in sight % Generate code which loads the value of EXP into register 1 % Patch to COMVAL1 for better register allocation SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP!&,STATUS!&); BEGIN SCALAR X; IF !&ANYREG EXP OR !&OPENFNP EXP OR !&ANYREGFNP EXP THEN IF STATUS!&<2 AND !&NOSIDEEFFECTP EXP THEN !&COMPWARN(LIST(EXP," not compiled")) ELSE <<!&LOADOPENEXP(IF STATUS!& > 1 THEN !&AllocTemp(Exp) ELSE '(REG 1), CAR EXP . !&COMLIS CDR EXP,STATUS!&,PREGS!&)>> ELSE IF NOT ATOM CAR EXP % Non atomic function? THEN IF CAAR EXP EQ 'LAMBDA THEN !&COMPLY(CAR EXP,CDR EXP,STATUS!&) % LAMBDA compilation ELSE !&COMPERROR LIST(CAR EXP, "Invalid as function") % Should be noticed in pass 1 ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS!&)) % Dispatch built in compiler functions ELSE IF CAR EXP EQ 'LAMBDA THEN !&COMPERROR LIST("Invalid use of LAMBDA in COMVAL1",EXP) ELSE !&CALL(CAR EXP,CDR EXP,STATUS!&); % Call a function RETURN NIL END; % Procedure to allocate temps for OPEN exprs. Used only when STATUS!&<1 to % set up destination. Only special case is SETQ. SETQ tries to put the % value of X:=... into a register containing X (keeps variables in the same % register if possible. Symbolic Procedure !&Alloctemp(Exp); if car Exp = 'Setq then if car caddr exp = 'Setq then % Nested setq - move to actual RHS !&Alloctemp(caddr Exp) else begin Scalar Reg; If (Reg := !&RAssoc(Cadr Cadr Exp,Regs!&)) % LHS variable already in reg? and not (Car Reg member PRegs!&) then % and reg must be available Return Car Reg % Return the reg previously used for the var else Return !&Tempreg() % Just get a temp end else !&TempReg(); % not SETQ - any old temp will do SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS!&); !&CALL1(FN,!&COMLIS1 ARGS,STATUS!&); %Args have been compiled SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS!&); %ARGS is reversed list of compiled arguments of FN; BEGIN INTEGER ARGNO; SCALAR DEST!&; ARGNO := LENGTH ARGS; IF !&ANYREGP FN THEN !&LREG1(FN . ARGS) ELSE <<!&LOADARGS(ARGS,1,PREGS!&); %Emits loads to registers !&ATTACH LIST('!*LINK,FN,!&CFNTYPE FN,ARGNO); !&REMMREFS(); !&REMVREFS(); % Default - all registers destroyed IF !*USINGDESTROY THEN DEST!& := GET(FN,'DESTROYS); IF NULL DEST!& THEN REGS!& := NIL ELSE BEGIN SCALAR TEMP; TEMP := NIL; FOR EACH R IN REGS!& DO IF NOT(CAR R MEMBER DEST!&) THEN TEMP := R . TEMP; REGS!& := TEMP END >> END; % Comlis altered to return unreversed list SYMBOLIC PROCEDURE !&COMLIS EXP; REVERSIP !&COMLIS1 EXP; % COMLIS1 returns reversed list of compiled arguments; SYMBOLIC PROCEDURE !&COMLIS1 EXP; BEGIN SCALAR ACUSED,Y; % Y gathers a set of ANYREG expressions denoting % the params. Code for non ANYREG stuff is emitted by ATTACH. ACUSED is % name of psuedo variable holding results of non anyreg stuff. Y := NIL; WHILE EXP DO <<IF !&CONSTP CAR EXP OR !&OPENP CAR EXP AND (NOT !*ORD OR !&NOSIDEEFFECTPL CDR EXP) THEN Y := CAR EXP . Y % Anyreg stuff is handled later. Anyreg args are not loaded until after % all others. % If !*ORD is true, order is still switched unless no side effects ELSE << %/ Special coding for top level ANYREG IF ACUSED THEN !&SAVER1(); IF (!&ANYREGFNP CAR EXP OR !&OPENFNP CAR EXP) AND (NOT !*ORD OR !&NOSIDEEFFECTPL CDR EXP) THEN <<Y := (CAAR EXP . !&COMLIS CDAR EXP) . Y; ACUSED := T>> % Emit code to place arg in R1, generate a name for the result to put in R1 ELSE <<!&COMVAL1(CAR EXP,STOMAP!&,1); ACUSED := LIST('!$LOCAL,!&GENSYM()); REGS!& := !&ADDRVALS('(REG 1),REGS!&,LIST ACUSED); % REGS!& the new variable name goes on the code list (rest already emitted) Y := ACUSED . Y>>>>; % place arg in memory while doing others EXP := CDR EXP>>; RETURN Y END; % SAVE R1 IF NECESSARY SYMBOLIC PROCEDURE !&SAVER1; %MARKS CONTENTS OF REGISTER 1 FOR STORAGE; BEGIN SCALAR X; X := !®VAL '(REG 1); % Contents of R1 IF NULL X OR NOT !&VARP CAR X THEN RETURN NIL % Dont save constants ELSE IF NOT ASSOC(CAR X,STOMAP!&) THEN !&FRAME CAR X; % For temporaries % as generated in COMLIS !&STORELOCAL(CAR X,'(REG 1)) % Emit a store END; % Compiler for LAMBDA SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS!&); BEGIN SCALAR ALSTS!&,VARS, N, I; %SCALAR OLDSTOMAP,OLDCODE; % OLDSTOMAP := STOMAP!&; % OLDCODE := CODELIST!&; VARS := CADR FN; % Compile args to the lambda ARGS := !&COMLIS1 ARGS; N := LENGTH ARGS; IF N>MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments in LAMBDA form",FN); % Put the args into registers !&LOADARGS(ARGS,1,PREGS!&); % Enter new ENVIRONMENT!& ARGS := !&REMVARL VARS; % The stores that were protected; I := 1; % Put this junk on the frame ALSTS!& := !&VARBIND(VARS,T); %Old fluid values saved; % compile the body !&COMVAL(CADDR FN,STATUS!&); % Restore old fluids !&FREERSTR(ALSTS!&,STATUS!&); % Go back to the old ENVIRONMENT!& !&RSTVARL(VARS,ARGS); %/ !&FIXFRM(OLDSTOMAP,OLDCODE,0) END; % Load a sequence of expressions into the registers SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS!&,PREGS!&); BEGIN INTEGER N; SCALAR FN,DESTREG!&; N := LENGTH ARGS; IF N>MAXNARGS!& THEN !&COMPERROR LIST("Too many arguments",ARGS); WHILE ARGS DO % Generate a load for each arg <<DESTREG!& := !&MKREG N; !&LOADOPENEXP(DESTREG!&,CAR ARGS,STATUS!&,PREGS!&); PREGS!& := DESTREG!& . PREGS!&; N := N - 1; ARGS := CDR ARGS>> END; SYMBOLIC PROCEDURE !&LOADOPENEXP(DESTREG!&,ARG,STATUS!&,PREGS!&); BEGIN SCALAR R; IF !&ANYREG ARG OR !&RASSOC(ARG,REGS!&) THEN !&LREG(DESTREG!&,!&LOCATE ARG) ELSE IF !&ANYREGFNP ARG THEN <<!&LOADOPENEXP(DESTREG!&,CADR ARG,1,PREGS!&); !&LREG(DESTREG!&,!&LOCATE (CAR ARG . DESTREG!& . CDDR ARG)) >> ELSE % Must be an open function IF FLAGP(CAR ARG,'MEMMOD) AND STATUS!& < 2 THEN <<!&LOADOPENEXP(DESTREG!&,ARG,2,PREGS!&); !&LREG(DESTREG!&,IF EQCAR(CADR ARG,'!$NAME) THEN !&LOCATE CADR CADR ARG ELSE !&LOCATE CADR ARG)>> ELSE BEGIN SCALAR OPFN,ADJFN,ANYREGARGS; ANYREGARGS := !&REMOPEN(DESTREG!&,CDR ARG); OPFN := GET(CAR ARG,'OPENFN); IF IDP OPFN THEN APPLY(OPFN,LIST(DESTREG!&,ANYREGARGS,ARG)) ELSE !&CALLOPEN(OPFN,DESTREG!&,ANYREGARGS,CAR ARG) END; END; SYMBOLIC PROCEDURE !&REMOPEN(DESTREG!&,ARGS); FOR EACH ARG IN ARGS COLLECT !&ARGLOC ARG; SYMBOLIC PROCEDURE !&ARGLOC ARG; BEGIN SCALAR LOC; IF EQCAR(ARG,'!$NAME) THEN RETURN ARG; IF !&CONSTP ARG THEN RETURN ARG; IF EQCAR(ARG,'MEMORY) THEN RETURN !&MEMADDRESS ARG; IF LOC := !&RASSOC(ARG,REGS!&) THEN <<PREGS!& := CAR LOC . PREGS!&; RETURN CAR LOC>>; IF !&ANYREG ARG THEN RETURN ARG; IF !&ANYREGFNP ARG THEN RETURN (CAR ARG . !&ARGLOC CADR ARG . CDDR ARG); IF NULL DESTREG!& OR DESTREG!& MEMBER PREGS!& THEN DESTREG!& := !&TEMPREG(); IF FLAGP(CAR ARG,'MEMMOD) THEN <<!&LOADOPENEXP(DESTREG!&,ARG,2,PREGS!&); RETURN CADR CADR ARG>> ELSE !&LOADOPENEXP(DESTREG!&,ARG,1,PREGS!&); PREGS!& := DESTREG!& . PREGS!&; RETURN DESTREG!& END; SYMBOLIC PROCEDURE !&MEMADDRESS ARG; BEGIN SCALAR TEMPDEST; PREGS!& := DESTREG!& . PREGS!&; TEMPDEST := !&TEMPREG(); PREGS!& := CDR PREGS!&; ARG := CAR ARG . !&REMOPEN(TEMPDEST,CDR ARG); IF NOT(CADDR ARG = '(WCONST 0) AND NOT !&ANYREGFNP CADR ARG OR !®FP CADR ARG) THEN <<!&LREG(TEMPDEST,!&LOCATE CADR ARG); ARG := CAR ARG . TEMPDEST . CDDR ARG>>; IF CADR ARG = TEMPDEST THEN PREGS!& := TEMPDEST . PREGS!&; RETURN ARG; END; SYMBOLIC PROCEDURE !&CALLOPEN(OPFN,DEST!&,ARGS,OP); BEGIN SCALAR PATS,PARAMS,ADJFN,REGFN,ENVIRONMENT!&; PATS := CAR OPFN; IF IDP PATS THEN PATS := GET(PATS,'PATTERN); PARAMS := OP . CDR OPFN; ADJFN := CAR PATS; REGFN := CADR PATS; IF ADJFN THEN ARGS := APPLY(ADJFN,LIST ARGS); PATS := CDDR PATS; WHILE NOT NULL PATS AND NOT !&MATCHES(CAAR PATS,ARGS) DO PATS := CDR PATS; IF NULL PATS THEN <<!&COMPERROR(LIST("Compiler bug - no pattern for",OP . ARGS)); RETURN NIL>>; FOR EACH MAC IN CDAR PATS DO !&EMITMAC(!&SUBARGS(MAC,ARGS,PARAMS)); IF REGFN THEN IF IDP REGFN THEN APPLY(REGFN,LIST(OP, ARGS)) ELSE !&EMITMAC(!&SUBARGS(REGFN,ARGS,PARAMS)); RETURN NIL; END; SYMBOLIC PROCEDURE !&MATCHES(PAT,SUBJ); IF EQCAR(PAT,'QUOTE) THEN CADR PAT = SUBJ ELSE IF NULL PAT THEN NULL SUBJ ELSE IF EQCAR(PAT,'NOVAL) THEN STATUS!& > 1 AND !&MATCHES(CDR PAT,SUBJ) ELSE IF ATOM PAT THEN APPLY(GET(PAT,'MATCHFN),LIST SUBJ) ELSE PAIRP SUBJ AND !&MATCHES(CAR PAT,CAR SUBJ) AND !&MATCHES(CDR PAT,CDR SUBJ); SYMBOLIC PROCEDURE !&ANY U;T; SYMBOLIC PROCEDURE !&DEST U;U = DEST!&; % An anyreg which uses DEST!& at any level SYMBOLIC PROCEDURE !&USESDEST U; !&DEST U OR PAIRP U AND !&USESDESTL CDR U; SYMBOLIC PROCEDURE !&USESDESTL U; PAIRP U AND (!&DEST CAR U OR !&USESDEST CAR U OR !&USESDESTL CDR U); SYMBOLIC PROCEDURE !®FP U;!®P U OR EQCAR(U,'!$LOCAL); SYMBOLIC PROCEDURE !®N U; !®P U OR EQCAR(U,'!$LOCAL) OR U = '(QUOTE NIL); SYMBOLIC PROCEDURE !&MEM U; NOT(U = '(QUOTE NIL) OR EQCAR(U,'!$LOCAL)) AND (!&CONSTP U OR !&VARP U OR CAR U = 'MEMORY); SYMBOLIC PROCEDURE !&NOTANYREG U;!&MEM U OR !®FP U; SYMBOLIC PROCEDURE !&SUBARGS(MAC,ARGS,PARAMS); FOR EACH ARG IN MAC COLLECT !&SUBARG(ARG,ARGS,PARAMS); SYMBOLIC PROCEDURE !&SUBARG(ARG,ARGS,PARAMS); BEGIN SCALAR ARGFN; RETURN IF EQCAR(ARG,'QUOTE) THEN CADR ARG ELSE IF PAIRP ARG THEN !&SUBARGS(ARG,ARGS,PARAMS) ELSE IF ARG = 'DEST THEN DEST!& ELSE IF ARGFN := GET(ARG,'SUBSTFN) THEN APPLY(ARGFN,LIST(ARG,ARGS,PARAMS)) ELSE !&COMPERROR(LIST("Compiler bug", ARG,"invalid in macro")) END; SYMBOLIC PROCEDURE !&ARG1(ARG,ARGS,PARAMS); !&LOCATE CAR ARGS; SYMBOLIC PROCEDURE !&ARG2(ARG,ARGS,PARAMS); !&LOCATE CADR ARGS; SYMBOLIC PROCEDURE !&ARG3(ARG,ARGS,PARAMS); !&LOCATE CADDR ARGS; SYMBOLIC PROCEDURE !&ARG4(ARG,ARGS,PARAMS); !&LOCATE CADDDR ARGS; SYMBOLIC PROCEDURE !&PARAM1(ARG,ARGS,PARAMS); CAR PARAMS; SYMBOLIC PROCEDURE !&PARAM2(ARG,ARGS,PARAMS); CADR PARAMS; SYMBOLIC PROCEDURE !&PARAM3(ARG,ARGS,PARAMS); CADDR PARAMS; SYMBOLIC PROCEDURE !&PARAM4(ARG,ARGS,PARAMS); CADDDR PARAMS; SYMBOLIC PROCEDURE !&GETTEMP(TNAME,ARGS,PARAMS); BEGIN SCALAR TN; RETURN IF TN := ASSOC(TNAME,ENVIRONMENT!&) THEN CDR TN ELSE <<TN := !&TEMPREG(); ENVIRONMENT!& := (TNAME . TN) . ENVIRONMENT!&; PREGS!& := TN . PREGS!&; TN>>; END; SYMBOLIC PROCEDURE !&GETTEMPLBL(LNAME,ARGS,PARAMS); BEGIN SCALAR LAB; RETURN IF LAB := ASSOC(LNAME,ENVIRONMENT!&) THEN CDR LAB ELSE <<LAB := !&GENLBL(); ENVIRONMENT!& := (LNAME . LAB) . ENVIRONMENT!&; LAB>> END; SYMBOLIC PROCEDURE !&GENSYM(); % gensym local to compiler, reuses symbols BEGIN SCALAR SYMB; IF NULL CDR LOCALGENSYM!& THEN RPLACD(LOCALGENSYM!&, LIST GENSYM()); SYMB := CAR LOCALGENSYM!&; LOCALGENSYM!& := CDR LOCALGENSYM!&; RETURN SYMB; END; SYMBOLIC PROCEDURE !&COMPERROR U; << ERRORPRINTF("***** in %P: %L", NAME!&, U); ERFG!* := T >>; SYMBOLIC PROCEDURE !&COMPWARN U; !*MSG AND ERRORPRINTF("*** in %P: %L", NAME!&, U); SYMBOLIC PROCEDURE !&EMITMAC MAC; BEGIN SCALAR EMITFN; IF CAR MAC = '!*DO THEN APPLY(CADR MAC,CDDR MAC) ELSE IF CAR MAC = '!*DESTROY THEN FOR EACH REG IN CDR MAC DO REGS!& := DELASC(REG,REGS!&) ELSE IF CAR MAC = '!*SET THEN REGS!& := !&REPASC(CADR MAC,!&REMREGSL CADDR MAC,REGS!&) ELSE IF EMITFN := GET(CAR MAC,'EMITFN) THEN APPLY(EMITFN,LIST MAC) ELSE !&ATTACH MAC END; SYMBOLIC PROCEDURE !&EMITLOAD M; !&LREG(CADR M,CADDR M); SYMBOLIC PROCEDURE !&EMITSTORE M; !&STOREVAR(CADDR M,CADR M); SYMBOLIC PROCEDURE !&EMITJUMP M; !&ATTJMP CADR M; SYMBOLIC PROCEDURE !&EMITLBL M; !&ATTLBL CADR M; SYMBOLIC PROCEDURE !&EMITMEMMOD M; BEGIN SCALAR Y, X; X := CADR M; !&REMREFS X; IF EQCAR(X,'!$LOCAL) THEN WHILE Y := ASSOC(X,SLST!&) DO SLST!& := DELETIP(Y,SLST!&); IF EQCAR(X,'!$LOCAL) THEN M := CAR M . !&GETFRM X . CDDR M; !&ATTACH(GET(CAR M, 'UNMEMMOD) . CDR M); END; % Support to patterns - register adjustment functions SYMBOLIC PROCEDURE !&NOANYREG ARGS; % remove all ANYREG stuff except top level MEMORY IF NULL ARGS THEN NIL ELSE !&NOANYREG1 CAR ARGS . !&NOANYREG CDR ARGS; SYMBOLIC PROCEDURE !&NOANYREG1 ARG; IF !&ANYREGFNP ARG AND NOT EQCAR(ARG,'MEMORY) THEN !&LOADTEMPREG ARG ELSE ARG; SYMBOLIC PROCEDURE !&INREG ARGS; IF NOT !®FP CAR ARGS THEN LIST !&LOADTEMPREG CAR ARGS ELSE ARGS; SYMBOLIC PROCEDURE !®MEM ARGS; <<ARGS := !&NOANYREG ARGS; IF !&MEM CAR ARGS AND !&MEM CADR ARGS THEN !&LOADTEMPREG CAR ARGS . CDR ARGS ELSE ARGS>>; SYMBOLIC PROCEDURE !&DESTMEM ARGS; % A1 in DEST!&, A2 in MEM, rest (if any) not anyreg <<ARGS := CAR ARGS . !&NOANYREG CDR ARGS; IF STATUS!& > 1 THEN IF !®FP CAR ARGS THEN ARGS ELSE !&LOADTEMPREG CAR ARGS . CDR ARGS ELSE IF !&DEST CADR ARGS OR !&USESDEST CADR ARGS THEN !&DESTMEM(CAR ARGS . !&LOADTEMPREG CADR ARGS . CDDR ARGS) ELSE IF CAR ARGS NEQ DEST!& THEN <<!&LREG(DEST!&,!&LOCATE CAR ARGS); DEST!& . CDR ARGS>> ELSE ARGS>>; SYMBOLIC PROCEDURE !&DESTMEMA ARGS; % put either a1or A2 into DEST!&, the other to MEM. IF CAR ARGS = DEST!& THEN % A1 = DEST!&, make A1 mem or reg IF !&NOTANYREG CADR ARGS AND NOT !&USESDEST CADR ARGS THEN ARGS ELSE !&LOADTEMP2 ARGS ELSE IF CADR ARGS = DEST!& THEN % A2 = DEST!&, make A2 mem or reg IF !&NOTANYREG CAR ARGS AND NOT !&USESDEST CAR ARGS THEN ARGS ELSE !&LOADTEMP1 ARGS ELSE IF !&NOTANYREG CADR ARGS OR NOT !&NOTANYREG CAR ARGS THEN % A2 is MEM or A1 is anyreg: make A1 the destination <<IF NOT !&NOTANYREG CADR ARGS OR !&USESDEST CADR ARGS THEN ARGS := !&LOADTEMP2 ARGS; !&LREG(DEST!&,!&LOCATE CAR ARGS); DEST!& . CDR ARGS>> ELSE % Make A2 the DEST!& - only when A2 is anyreg and a1 is mem <<IF NOT !&NOTANYREG CAR ARGS OR !&USESDEST CAR ARGS THEN ARGS := !&LOADTEMP1 ARGS; !&LREG(DEST!&,!&LOCATE CADR ARGS); LIST(CAR ARGS,DEST!&)>>; SYMBOLIC PROCEDURE !&LOADTEMP1 U; % Bring first arg into a temp !&LOADTEMPREG CAR U . CDR U; SYMBOLIC PROCEDURE !&LOADTEMP2 U; % put second arg in a temp CAR U . !&LOADTEMPREG CADR U . CDDR U; SYMBOLIC PROCEDURE !&CONSARGS ARGS; IF NOT !&ANYREGFNP CADR ARGS AND CADR ARGS NEQ DEST!& OR NOT !&ANYREGFNP CAR ARGS AND CAR ARGS NEQ DEST!& THEN ARGS ELSE LIST(CAR ARGS,!&LOADTEMPREG CADR ARGS); SYMBOLIC PROCEDURE !&LOADTEMPREG ARG; % Load ARG into a temporary register. Return the register. BEGIN SCALAR TEMP; TEMP := !&TEMPREG(); PREGS!& := TEMP . PREGS!&; !&LREG(TEMP,!&LOCATE ARG); RETURN TEMP END; SYMBOLIC PROCEDURE !&FIXREGTEST(OP,ARGS); !&FIXREGTEST1(OP, first ARGS, second ARGS); SYMBOLIC PROCEDURE !&FIXREGTEST1(OP, A1, A2); % Fixes up the registers after a conditional jump has been emitted. % For JUMPEQ and JUMPNE, equalities can be assumed in REGS!& or REGS1!& % For other jumps, REGS!& copied onto REGS1!&. <<REGS1!& := REGS!&; IF OP = 'EQ OR OP = 'NE THEN IF NOT !®P A1 THEN << IF !®P A2 THEN !&FIXREGTEST1(OP,A2,A1) >> ELSE <<IF OP = 'EQ THEN REGS1!& := !&ADDRVALS(A1,REGS1!&,!&REMREGS A2) ELSE REGS!& := !&ADDRVALS(A1,REGS!& ,!&REMREGS A2)>>>>; SYMBOLIC PROCEDURE !&SETREGS1(OP, ARGS); REGS1!& := REGS!&; % Find the location of a variable SYMBOLIC PROCEDURE !&LOCATE X; BEGIN SCALAR Y,VTYPE; % Constants are their own location IF ATOM X OR EQCAR(X,'LABEL) OR !&CONSTP X THEN RETURN X; IF EQCAR(X,'!$NAME) THEN RETURN CADR X; IF CAR X = 'MEMORY THEN RETURN(CAR X . !&LOCATE CADR X . CDDR X); IF Y := !&RASSOC(X,REGS!&) THEN RETURN CAR Y; % If in a register, return the register number % Registers are their own location % For ANYREG stuff, locate each constant IF !&ANYREGFNP X THEN RETURN CAR X . !&LOCATEL CDR X; IF NOT EQCAR(X,'!$LOCAL) THEN RETURN X; % Since the value of the variable has been referenced, a previous store was % justified, so it can be removed from SLST!& % Must be in the frame, otherwise make nonlocal (really ought to be an error) % Frame location (<=0) is returned WHILE Y := ASSOC(X,SLST!&) DO SLST!& := DELETIP(Y,SLST!&); IF Y := ASSOC(X,STOMAP!&) THEN RETURN CADR Y; % Nasty compiler bug. Until we fix it, tell the user to simplify expressions !&COMPERROR LIST ("Compiler bug: expression too complicated, please simplify",X); RETURN '(QUOTE 0); % just so it doesn't blow up END; SYMBOLIC PROCEDURE !&LOCATEL U; FOR EACH X IN U COLLECT !&LOCATE X; % Load register REG with value U. V (always NIL except when called from % LOADARGS) is a list of other loads to be done SYMBOLIC PROCEDURE !&LREG(REG,VAL); BEGIN SCALAR ACTUALVAL; ACTUALVAL := !&REMREGS VAL; IF REG = VAL OR ACTUALVAL MEMBER !®VAL REG THEN RETURN NIL; !&ATTACH LIST('!*MOVE,VAL,REG); REGS!& := !&REPASC(REG,ACTUALVAL,REGS!&); END; % Load register 1 with X SYMBOLIC PROCEDURE !&LREG1(X); !&LOADOPENEXP('(REG 1),X,1,PREGS!&); SYMBOLIC PROCEDURE !&JUMPT LAB; !&ATTACH LIST('!*JUMPNOTEQ,LAB,'(REG 1),'(QUOTE NIL)); SYMBOLIC PROCEDURE !&JUMPNIL LAB; !&ATTACH LIST('!*JUMPEQ,LAB,'(REG 1),'(QUOTE NIL)); COMMENT Functions for Handling Non-local Variables; SYMBOLIC PROCEDURE !&VARBIND(VARS,LAMBP); %bind FLUID variables in lambda or prog lists; %LAMBP is true for LAMBDA, false for PROG; BEGIN SCALAR VLOCS,VNAMES,FREGS,Y,REG,TAIL; INTEGER I; I := 1; FOR EACH X IN VARS DO << REG := !&MKREG I; IF EQCAR(X,'!$GLOBAL) THEN % whoops << !&COMPWARN LIST("Illegal to bind global", CADR X, "but binding anyway"); RPLACA(X,'!$FLUID) >>; % cheat a little IF EQCAR(X,'!$FLUID) THEN <<FREEBOUND!& := T; VNAMES := X . VNAMES; IF NOT !*NOFRAMEFLUID THEN VLOCS := !&FRAME X . VLOCS; FREGS := REG . FREGS>> ELSE IF EQCAR(X,'!$LOCAL) THEN <<!&FRAME X; !&STORELOCAL(X,IF LAMBP THEN REG ELSE NIL)>> ELSE !&COMPERROR LIST("Cannot bind non-local variable",X); IF LAMBP THEN IF EQCAR(X,'!$LOCAL) THEN REGS!& := !&REPASC(REG,LIST X,REGS!&) ELSE REGS!& := !&REPASC(REG,NIL,REGS!&); I := I + 1>>; IF NULL VNAMES THEN RETURN NIL; VNAMES := 'NONLOCALVARS . VNAMES; FREGS := 'REGISTERS . FREGS; VLOCS := 'FRAMES . VLOCS; TAIL := IF !*NOFRAMEFLUID THEN LIST VNAMES ELSE LIST(VNAMES,VLOCS); IF LAMBP THEN !&ATTACH('!*LAMBIND . FREGS . TAIL) ELSE !&ATTACH('!*PROGBIND . TAIL); IF !*UNSAFEBINDER THEN REGS!& := NIL; RETURN TAIL; END; SYMBOLIC PROCEDURE !&FREERSTR(ALSTS!&,STATUS!&); %restores FLUID variables; IF ALSTS!& THEN << !&ATTACH('!*FREERSTR . ALSTS!&); IF !*UNSAFEBINDER THEN REGS!& := NIL >>; % ATTACH is used to emit code SYMBOLIC PROCEDURE !&ATTACH U; CODELIST!& := U . CODELIST!&; SYMBOLIC PROCEDURE !&STORELOCAL(U,REG); %marks expression U in register REG for storage; BEGIN SCALAR X; IF NULL REG THEN REG := '(QUOTE NIL); X := LIST('!*MOVE,REG,!&GETFRM U); % Update list of stores done so far !&ATTACH X; % Zap out earlier stores if there were never picked up % ie, if you store to X, then a ref to X will remove this store from % SLST!&. Otherwise, the previous store will be removed by CLRSTR % SLST!& is for variables only (anything else?) !&CLRSTR U; SLST!& := (U . CODELIST!&) . SLST!&; END; SYMBOLIC PROCEDURE !&CLRSTR VAR; %removes unneeded stores; BEGIN SCALAR X; % Inside conditionals, you cant tell if store was on the same path IF CONDTAIL!& THEN RETURN NIL; X := ASSOC(VAR,SLST!&); IF NULL X THEN RETURN NIL; SLST!& := DelQIP(X,SLST!&); !&DELMAC CDR X; END; COMMENT Functions for general tests; SYMBOLIC PROCEDURE !&COMTST(EXP,LABL); %compiles boolean expression EXP. %If EXP has the same value as SWITCH!& then branch to LABL, %otherwise fall through; %REGS are active registers for fall through, %REGS1 for branch; BEGIN SCALAR X,FN,REG; % First factor out NOT's to set up the SWITCH!& WHILE EQCAR(EXP,'EQ) AND CADDR EXP = '(QUOTE NIL) DO <<SWITCH!& := NOT SWITCH!&; EXP := CADR EXP>>; % Dispatch a built in compiling function IF NOT SWITCH!& AND (FN := GET(CAR EXP,'FLIPTST)) THEN EXP := FN . CDR EXP; % SWITCH!& is assumed to be true by fn's with % a flip test IF FN := GET(CAR EXP,'OPENTST) THEN <<IF ATOM FN THEN APPLY(FN,LIST(EXP,LABL)) ELSE !&COMOPENTST(FN,EXP,LABL,PREGS!&)>> % Trivial case of condition is T. FLAGG!& indicates jump cannot take place ELSE <<IF EQCAR(EXP,'QUOTE) THEN IF SWITCH!& AND CADR EXP OR (NOT SWITCH!&) AND (NOT CADR EXP) THEN <<REGS1!& := REGS!&; !&ATTJMP LABL>> ELSE FLAGG!& := T ELSE <<!&COMTST(LIST('NE,EXP,'(QUOTE NIL)),LABL)>>>> END; SYMBOLIC PROCEDURE !&COMOPENTST(PAT,EXP,DESTLAB,PREGS!&); BEGIN SCALAR ANYREGARGS,ADJFN; ANYREGARGS := !&REMOPEN(!&TEMPREG(),!&COMLIS CDR EXP); !&CALLOPEN(PAT,DESTLAB,ANYREGARGS,CAR EXP) END; % Remove variables to avoid name conflicts: Hide variable names which match % new names when entering an inner function. Other names will be available % as global info. VARS is the list of new variable names, the result is a % list of protected stores. SYMBOLIC PROCEDURE !&REMVARL VARS; FOR EACH X IN VARS COLLECT !&PROTECT X; % Delete all references to U from SLST!& % return the protected store SYMBOLIC PROCEDURE !&PROTECT U; BEGIN SCALAR X; IF X := ASSOC(U,SLST!&) THEN SLST!& := DelQIP(X,SLST!&); RETURN X END; % Restore a previous ENVIRONMENT!&. VARS is the list of variables taken out % of the ENVIRONMENT!&; LST is the list of protected stores. One or zero % stores for each variable. SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST); WHILE VARS DO <<!&RSTVAR(CAR VARS,CAR LST); VARS := CDR VARS; LST := CDR LST>>; % Restore a particular variable and STORE SYMBOLIC PROCEDURE !&RSTVAR(VAR,VAL); BEGIN !&REMREFS VAR; !&CLRSTR VAR; % Put back on store list if not NIL !&UNPROTECT VAL END; SYMBOLIC PROCEDURE !&UNPROTECT VAL; %restores VAL to SLST!&; IF VAL THEN SLST!& := VAL . SLST!&; SYMBOLIC PROCEDURE !&STOREVAR(U,V); % The store generated by a SETQ BEGIN SCALAR VTYPE,X; !&REMREFS U; IF CAR U = '!$LOCAL THEN !&STORELOCAL(U,V) ELSE !&ATTACH LIST('!*MOVE,V,U); IF !®P V THEN REGS!& := !&ADDRVALS(V,REGS!&,LIST U) END; COMMENT Support Functions; SYMBOLIC PROCEDURE !&REFERENCES(EXP,VAR); % True if expression EXP (probably ANYREG) references VAR. EXP = VAR OR IF ATOM EXP OR FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE !&REFERENCESL(CDR EXP,VAR); SYMBOLIC PROCEDURE !&REFERENCESL(EXP,VAR); IF NULL EXP THEN NIL ELSE !&REFERENCES(CAR EXP,VAR) OR !&REFERENCESL(CDR EXP,VAR); SYMBOLIC PROCEDURE !&CFNTYPE FN; BEGIN SCALAR X; RETURN IF X := GET(FN,'CFNTYPE) THEN CAR X ELSE IF X := GETD FN THEN CAR X ELSE 'EXPR END; SYMBOLIC PROCEDURE !&GENLBL; BEGIN SCALAR L; L := LIST('LABEL,!&GENSYM()); LBLIST!& := LIST L . LBLIST!&; RETURN L END; SYMBOLIC PROCEDURE !&GETLBL LABL; BEGIN SCALAR X; X := ASSOC(LABL,GOLIST!&); IF NULL X THEN !&COMPERROR LIST("Compiler bug: missing label", LABL); RETURN CDR X END; SYMBOLIC PROCEDURE !&ATTLBL LBL; IF CAAR CODELIST!& EQ '!*LBL THEN !&DEFEQLBL(LBL,CADR CAR CODELIST!&) ELSE !&ATTACH LIST('!*LBL,LBL); SYMBOLIC PROCEDURE !&ATTJMP LBL; BEGIN IF CAAR CODELIST!& EQ '!*LBL THEN <<!&DEFEQLBL(LBL,CADR CAR CODELIST!&); !&DELMAC CODELIST!&>>; IF !&TRANSFERP CODELIST!& THEN RETURN NIL; !&ATTACH LIST('!*JUMP,LBL); END; SYMBOLIC PROCEDURE !&TRANSFERP X; IF CAAR X = '!*NOOP THEN !&TRANSFERP CDR X ELSE FLAGP(IF CAAR X EQ '!*LINK THEN CADAR X ELSE CAAR X,'TRANSFER); SYMBOLIC PROCEDURE !&DEFEQLBL(LAB1,LAB2); LBLIST!& := !&DEFEQLBL1(LBLIST!&,LAB1,LAB2); SYMBOLIC PROCEDURE !&DEFEQLBL1(LABS,LAB1,LAB2); IF LAB1 MEMBER CAR LABS THEN IF LAB2 MEMBER CAR LABS THEN LABS ELSE APPEND(!&LABCLASS LAB2,CAR LABS) . !&DELCLASS(LAB2,CDR LABS) ELSE IF LAB2 MEMBER CAR LABS THEN APPEND(!&LABCLASS LAB1,CAR LABS) . !&DELCLASS(LAB1,CDR LABS) ELSE CAR LABS . !&DEFEQLBL1(CDR LABS,LAB1,LAB2); SYMBOLIC PROCEDURE !&LABCLASS(LAB); BEGIN SCALAR TEMP; TEMP := LBLIST!&; WHILE TEMP AND NOT (LAB MEMBER CAR TEMP) DO TEMP := CDR TEMP; RETURN IF TEMP THEN CAR TEMP ELSE NIL; END; SYMBOLIC PROCEDURE !&DELCLASS(LAB,LABS); IF LAB MEMBER CAR LABS THEN CDR LABS ELSE CAR LABS . !&DELCLASS(LAB,CDR LABS); SYMBOLIC PROCEDURE !&LBLEQ(LAB1,LAB2); LAB1 MEMBER !&LABCLASS LAB2; SYMBOLIC PROCEDURE !&FRAME U; %allocates space for U in frame; BEGIN SCALAR Z,RES; Z := IF NULL STOMAP!& THEN 1 ELSE 1 + CADR CADAR STOMAP!&; RES := !&MKFRAME Z; STOMAP!& := LIST(U,RES) . STOMAP!&; LLNGTH!& := MAX(Z,LLNGTH!&); RETURN RES END; % GETFRM returns the frame location on a variable SYMBOLIC PROCEDURE !&GETFRM U; BEGIN SCALAR X; IF X:=ASSOC(U,STOMAP!&) THEN RETURN CADR X; !&COMPERROR LIST("Compiler bug: lost variable",U) END; %************************************************************************* % The following functions determine classes or properties of expressions * %************************************************************************* SYMBOLIC PROCEDURE !&ANYREG U; % !&ANYREG determines if U is an ANYREG expression % % ANYREG expressions are those expressions which may be loaded into any % register without the use of (visable) temporary registers. It is assumed % that ANYREG expressions have no side effects. % % ANYREG expressions are defined as constants, variables, and ANYREG functions % whose arguments are ANYREG expressions. Note that ANYREG functions are % not necessarily a part of ANYREG expressions; their arguments may not be % ANYREG expressions. !&CONSTP U OR !&VARP U OR !&ANYREGFNP U AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&ANYREGL U; NULL U OR !&ANYREG(CAR U) AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&ANYREGFNP U; % !&ANYREGFNP is true when U is an ANYREG function. The arguments are not % checked !&ANYREGP CAR U; SYMBOLIC PROCEDURE !&OPENP U; !&CONSTP U OR !&VARP U OR (!&ANYREGFNP U OR !&OPENFNP U) AND !&OPENPL CDR U; SYMBOLIC PROCEDURE !&OPENPL U; NULL U OR !&OPENP CAR U AND !&OPENPL CDR U; SYMBOLIC PROCEDURE !&OPENFNP U; GET(CAR U,'OPENFN); SYMBOLIC PROCEDURE !&CONSTP U; % True if U is a constant expression IDP CAR U AND FLAGP(CAR U,'CONST); SYMBOLIC PROCEDURE !&VARP U; % True if U is a variable: (LOCAL x),(FLUID x), ... PAIRP U AND FLAGP(CAR U,'VAR); SYMBOLIC PROCEDURE !®P U; PAIRP U AND FLAGP(CAR U,'REG); SYMBOLIC PROCEDURE !&NOSIDEEFFECTP U; % True if the expression U has no side effects. ANYREG expressions and % functions are assumed to have no side effects; other functions must be % flagged NOSIDEEFFECT. All arguments to a function must also be NOSIDEEFFECT. !&ANYREG U OR (!&ANYREGFNP U OR FLAGP(CAR U,'NOSIDEEFFECT)) AND !&NOSIDEEFFECTPL CDR U; SYMBOLIC PROCEDURE !&NOSIDEEFFECTPL U; NULL U OR !&NOSIDEEFFECTP CAR U AND !&NOSIDEEFFECTPL CDR U; %********************************************************************** % Basic register manipulation utilities %********************************************************************** SYMBOLIC PROCEDURE !&RVAL(R,RGS); % Return the set of values in register R as determined by register list RGS IF NULL RGS THEN NIL ELSE IF CAAR RGS = R THEN CDAR RGS ELSE !&RVAL(R,CDR RGS); SYMBOLIC PROCEDURE !®VAL R; % Normally, register contents are found in register list REGS!&. !&RVAL(R,REGS!&); SYMBOLIC PROCEDURE !&ADDRVALS(REG,RGS,VALS); % Add the values VALS to the contents of REG in register list RGS IF NULL RGS THEN LIST (REG . VALS) ELSE IF CAAR RGS = REG THEN (CAAR RGS . APPEND(VALS,CDAR RGS)) . CDR RGS ELSE CAR RGS . !&ADDRVALS(REG,CDR RGS,VALS); SYMBOLIC PROCEDURE !&MKREG NUM; % Used to generate a tagged register from a register number BEGIN SCALAR AENTRY; RETURN IF AENTRY := ASSOC(NUM, '((1 . (REG 1)) (2 . (REG 2)) (3 . (REG 3)) (4 . (REG 4)) (5 . (REG 5)) (6 . (REG 6)) (7 . (REG 7)) (8 . (REG 8)) (9 . (REG 9)))) THEN CDR AENTRY ELSE LIST('REG,NUM); END; SYMBOLIC PROCEDURE !&MKFRAME NUM; % Used to generate a tagged register from a register number BEGIN SCALAR AENTRY; RETURN IF AENTRY := ASSOC(NUM, '((1 . (FRAME 1)) (2 . (FRAME 2)) (3 . (FRAME 3)) (4 . (FRAME 4)) (5 . (FRAME 5)) (6 . (FRAME 6)) (7 . (FRAME 7)) (8 . (FRAME 8)) (9 . (FRAME 9)))) THEN CDR AENTRY ELSE LIST('FRAME,NUM); END; SYMBOLIC PROCEDURE !&RASSOC(VAL,RGS); % Find a register in register list RGS which contains VAL. NIL is returned if % VAL is not present in RGS IF NULL RGS THEN NIL ELSE IF VAL MEMBER CDAR RGS THEN CAR RGS ELSE !&RASSOC(VAL,CDR RGS); SYMBOLIC PROCEDURE !&REPASC(REG,VAL,REGL); % Replace the contants of REG in list REGL by the value VAL IF NULL REGL THEN LIST (REG . VAL) ELSE IF REG=CAAR REGL THEN (REG . VAL) . CDR REGL ELSE CAR REGL . !&REPASC(REG,VAL,CDR REGL); SYMBOLIC PROCEDURE !&RMERGE U; % RMERGE takes a list of register contents representing the information % present in the registers from a number of different ways to reach the same % place. RMERGE returns whatever information is known to be in the registers % regardless of which path was taken. IF NULL U THEN NIL ELSE BEGIN SCALAR RES,CONTENTS; RES := NIL; FOR EACH RG IN CAR U DO <<CONTENTS := NIL; FOR EACH THING IN CDR RG DO IF !&INALL(THING,CAR RG,CDR U) THEN CONTENTS := THING . CONTENTS; IF CONTENTS THEN RES := (CAR RG . CONTENTS) . RES>>; RETURN RES; END; SYMBOLIC PROCEDURE !&INALL(THING,RG,LST); NULL LST OR (THING MEMBER !&RVAL(RG,CAR LST)) AND !&INALL(THING,RG,CDR LST); SYMBOLIC PROCEDURE !&TEMPREG(); BEGIN SCALAR I,R,EMPTY,UNPROT; EMPTY := UNPROT := NIL; I := 1; WHILE I <= MAXNARGS!& AND NOT EMPTY DO <<R := !&MKREG I; IF NOT(R MEMBER PREGS!&) THEN IF I <= LASTACTUALREG!& AND NULL !®VAL R THEN EMPTY := R ELSE IF NOT UNPROT THEN UNPROT := R; I := I + 1 >>; IF EMPTY THEN RETURN EMPTY; IF UNPROT THEN RETURN UNPROT; !&COMPERROR("Compiler bug: Not enough registers"); RETURN '(REG ERROR); END; SYMBOLIC PROCEDURE !&REMREGS U; IF !®P U THEN !®VAL U ELSE IF EQCAR(U,'FRAME) THEN LIST !&GETFVAR (U,STOMAP!&) ELSE IF !&CONSTP U OR !&VARP U THEN LIST U ELSE !&REMREGSL U; SYMBOLIC PROCEDURE !&GETFVAR (V,SMAP); IF NULL SMAP THEN !&COMPERROR(LIST("Compiler bug:", V,"evaporated?")) ELSE IF CADAR SMAP = V THEN CAAR SMAP ELSE !&GETFVAR (V,CDR SMAP); SYMBOLIC PROCEDURE !&REMREGSL U; FOR EACH ARG IN !&ALLARGS CDR U COLLECT (CAR U . ARG); SYMBOLIC PROCEDURE !&ALLARGS ARGLST; if null Arglst then NIL else IF NULL CDR ARGLST THEN FOR EACH VAL IN !&REMREGS CAR ARGLST COLLECT LIST VAL ELSE !&ALLARGS1(!&REMREGS CAR ARGLST,!&ALLARGS CDR ARGLST); SYMBOLIC PROCEDURE !&ALLARGS1(FIRSTARGS,RESTARGS); BEGIN SCALAR RES; RES := NIL; FOR EACH A1 IN FIRSTARGS DO FOR EACH A2 IN RESTARGS DO RES := (A1 . A2) . RES; RETURN RES; END; SYMBOLIC PROCEDURE !&REMMREFS(); REGS!& := FOR EACH R IN REGS!& COLLECT (CAR R . !&REMMREFS1 CDR R); SYMBOLIC PROCEDURE !&REMMREFS1 L; IF NULL L THEN L ELSE IF !&REFMEMORY CAR L THEN !&REMMREFS1 CDR L ELSE CAR L . !&REMMREFS1 CDR L; SYMBOLIC PROCEDURE !&REFMEMORY EXP; IF ATOM EXP OR FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE CAR EXP MEMBER '(MEMORY CAR CDR) OR !&REFMEMORYL CDR EXP; SYMBOLIC PROCEDURE !&REFMEMORYL L; IF NULL L THEN NIL ELSE !&REFMEMORY CAR L OR !&REFMEMORYL CDR L; SYMBOLIC PROCEDURE !&REMVREFS; BEGIN SCALAR S; REGS!& := FOR EACH R IN REGS!& COLLECT (CAR R . !&REMVREFS1 CDR R); % Slow version: % SLST!& := FOR EACH S IN SLST!& CONC % IF !&EXTERNALVARP CAR S THEN NIL ELSE LIST S; % Faster version: while not null Slst!& and !&ExternalVarP car car Slst!& do Slst!& := cdr Slst!&; S := Slst!&; while not null S and not null cdr S do << if !&ExternalVarP car car cdr S then Rplacd(S, cddr S); S := cdr S >>; END; SYMBOLIC PROCEDURE !&REMVREFS1 L; FOR EACH THING IN L CONC IF !&REFEXTERNAL THING THEN NIL ELSE LIST THING; SYMBOLIC PROCEDURE !&REFEXTERNAL EXP; IF ATOM EXP THEN NIL ELSE IF !&EXTERNALVARP EXP THEN T ELSE IF FLAGP(CAR EXP,'TERMINAL) THEN NIL ELSE !&REFEXTERNALL CDR EXP; SYMBOLIC PROCEDURE !&REFEXTERNALL EXPS; IF NULL EXPS THEN NIL ELSE !&EXTERNALVARP CAR EXPS OR !&REFEXTERNALL CDR EXPS; SYMBOLIC PROCEDURE !&EXTERNALVARP U; PAIRP U AND FLAGP(CAR U,'EXTVAR); SYMBOLIC PROCEDURE !&REMREFS V; % Remove all references to V from REGS!& IF CAR V MEMBER '(MEMORY CAR CDR) THEN !&REMMREFS() ELSE REGS!& := FOR EACH R IN REGS!& COLLECT CAR R . !&REMREFS1(V,CDR R); SYMBOLIC PROCEDURE !&REMREFS1(X,LST); % Remove all expressions from LST which reference X IF NULL LST THEN NIL ELSE IF !&REFERENCES(CAR LST,X) THEN !&REMREFS1(X,CDR LST) ELSE CAR LST . !&REMREFS1(X,CDR LST); %************************************************************ % Test functions %************************************************************ SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL); BEGIN SCALAR FLG,FLG1,FN,LAB2,REGSL,REGS1L, TAILP; %FLG is initial SWITCH!& condition; %FN is appropriate AND/OR case; %FLG1 determines appropriate switching state; FLG := SWITCH!&; SWITCH!& := NIL; FN := CAR EXP EQ 'AND; FLG1 := FLG EQ FN; EXP := CDR EXP; LAB2 := !&GENLBL(); WHILE EXP DO <<SWITCH!& := NIL; IF NULL CDR EXP AND FLG1 THEN <<IF FN THEN SWITCH!& := T; !&COMTST(CAR EXP,LABL); REGSL := REGS!& . REGSL; REGS1L := REGS1!& . REGS1L>> ELSE <<IF NOT FN THEN SWITCH!& := T; IF FLG1 THEN <<!&COMTST(CAR EXP,LAB2); REGSL := REGS1!& . REGSL; REGS1L := REGS!& . REGS1L>> ELSE <<!&COMTST(CAR EXP,LABL); REGSL := REGS!& . REGSL; REGS1L := REGS1!& . REGS1L>>>>; IF NULL TAILP THEN <<CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T>>; EXP := CDR EXP>>; !&ATTLBL LAB2; REGS!& := IF NOT FLG1 THEN CAR REGSL ELSE !&RMERGE REGSL; REGS1!& := IF FLG1 THEN CAR REGS1L ELSE !&RMERGE REGS1L; IF TAILP THEN CONDTAIL!& := CDR CONDTAIL!&; SWITCH!& := FLG END; %************************************************************ % Pass2 compile functions %************************************************************ SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS!&); BEGIN SCALAR FN,LABL,REGSL; FN := CAR EXP EQ 'AND; LABL := !&GENLBL(); EXP := CDR EXP; WHILE EXP DO <<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS!&); %to allow for recursion on last entry; REGSL := REGS!& . REGSL; IF CDR EXP THEN IF FN THEN !&JUMPNIL LABL ELSE !&JUMPT LABL; EXP := CDR EXP>>; REGS!& := !&RMERGE REGSL; !&ATTLBL LABL END; SYMBOLIC PROCEDURE !&COMAPPLY(EXP,STATUS); % Look for LIST; BEGIN SCALAR FN,ARGS, N,NN; EXP := CDR EXP; FN := CAR EXP; ARGS := CDR EXP; IF NULL ARGS OR CDR ARGS OR NOT (PAIRP CAR ARGS AND CAAR ARGS MEMBER '(LIST QUOTE NCONS LIST1 LIST2 LIST3 LIST4 LIST5)) OR LENGTH CDAR ARGS>MAXNARGS!& THEN RETURN !&CALL('APPLY,EXP,STATUS); ARGS := IF EQCAR(CAR ARGS,'QUOTE) THEN FOR EACH THING IN CADAR ARGS COLLECT LIST('QUOTE,THING) ELSE CDAR ARGS; NN := LENGTH ARGS; ARGS := REVERSIP (FN . REVERSE ARGS); !&LOADARGS(REVERSIP !&COMLIS ARGS,1,PREGS!&); !&ATTACH LIST('!*MOVE, !&MKREG(NN + 1), '(REG T1)); !&ATTACH LIST('!*LINK,'FASTAPPLY,'EXPR, NN); REGS!& := NIL; !&REMVREFS(); END; %Bug fix to COMCOND - tail has (QUOTE T) not T. Test for tail screwed up anyway SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS!&); %compiles conditional expressions; %registers REGS!& are set for dropping through, %REGS1 are set for a branch; BEGIN SCALAR REGS1!&,FLAGG!&,SWITCH!&,LAB1,LAB2,REGSL, TAILP; EXP := CDR EXP; LAB1 := !&GENLBL(); FOR EACH X ON EXP DO % Changed IN -> ON <<LAB2 := !&GENLBL(); SWITCH!& := NIL; IF CDR X THEN !&COMTST(CAAR X,LAB2) % CAR -> CAAR %update CONDTAIL!&; ELSE IF CAAR X = '(QUOTE T) THEN % CAR -> CAAR, T->(QUOTE T) FLAGG!& := T ELSE <<!&COMVAL(CAAR X,1); % CAR -> CAAR !&JUMPNIL LAB2; REGS1!& := !&ADDRVALS('(REG 1), REGS!&, list '(QUOTE NIL)) >>; IF NULL TAILP THEN <<CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T>>; !&COMVAL(CADR CAR X,STATUS!&); %X -> CAR X % Branch code; %test if need jump to LAB1; IF NOT FLAGG!& THEN % New line <<IF NOT !&TRANSFERP CODELIST!& THEN <<!&ATTJMP LAB1; REGSL := REGS!& . REGSL>>; REGS!& := REGS1!&;>>; %restore register status for next iteration; %we do not need to set REGS1!& to NIL since all COMTSTs %are required to set it; !&ATTLBL LAB2>>; IF NULL FLAGG!& AND STATUS!&<2 THEN <<!&LREG1('(QUOTE NIL)); REGS!& := !&RMERGE(REGS!& . REGSL)>> ELSE IF REGSL THEN REGS!& := !&RMERGE(REGS!& . REGSL); !&ATTLBL LAB1; IF TAILP THEN CONDTAIL!& := CDR CONDTAIL!& END; SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS!&); IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP THEN !&COMPERROR LIST("Wrong number of arguments to CONS",EXP) ELSE IF CADR EXP='(QUOTE NIL) THEN !&CALL('NCONS,LIST CAR EXP,STATUS!&) ELSE IF CADR EXP MEMBER !®VAL '(REG 1) AND !&OPENP CAR EXP THEN !&CALL1('XCONS,!&COMLIS EXP,STATUS!&) ELSE IF !&OPENP CADR EXP THEN !&CALL('CONS,EXP,STATUS!&) ELSE !&CALL1('XCONS,!&COMLIS EXP,STATUS!&); SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS!&); << IF STATUS!&>1 THEN <<!&ATTJMP !&GETLBL CADR EXP; SLST!& := NIL>> ELSE !&COMPERROR LIST(EXP,"invalid go")>>; SYMBOLIC PROCEDURE !&COMCASE(EXP,STATUS!&); BEGIN SCALAR BOTTOMLAB,REGS1!&,JUMPS,EXPS,ELSELAB,HIGH,LOW,SAVEREGS, JMPS,JLIST,RANGES,TABLE,TAILP; BOTTOMLAB := !&GENLBL(); REGS1!& := NIL; !&COMVAL(CADR EXP,1); JUMPS := EXPS := NIL; CONDTAIL!& := NIL . CONDTAIL!&; TAILP := T; FOR EACH THING ON CDDR EXP DO BEGIN SCALAR LAB; LAB := !&GENLBL(); JUMPS := NCONC(JUMPS,LIST LIST(CAAR THING,LAB)); EXPS := NCONC(EXPS,LIST LIST(LAB,CADAR THING)); IF NULL CDR THING THEN IF NOT NULL CAAR THING THEN IF STATUS!& > 1 THEN <<REGS1!& := REGS!& . REGS1!&; ELSELAB := BOTTOMLAB>> ELSE EXPS := NCONC(EXPS,LIST LIST(ELSELAB := !&GENLBL(), '(QUOTE NIL))) ELSE ELSELAB := LAB; END; RANGES := NIL; TABLE := NIL; FOR EACH JMP IN JUMPS DO FOR EACH NUM IN CAR JMP DO IF EQCAR(NUM,'RANGE) THEN BEGIN SCALAR HIGH,LOW; LOW := !&GETNUM CADR NUM; HIGH := !&GETNUM CADDR NUM; IF HIGH >= LOW THEN IF HIGH - LOW < 6 THEN FOR I := LOW:HIGH DO TABLE := !&INSTBL(TABLE,I,CADR JMP) ELSE RANGES := NCONC(RANGES,LIST LIST(LOW,HIGH,CADR JMP)); END ELSE TABLE := !&INSTBL(TABLE,!&GETNUM NUM,CADR JMP); FOR EACH R IN RANGES DO !&ATTACH LIST('!*JUMPWITHIN,CADDR R,CAR R,CADR R); WHILE TABLE DO <<JMPS := LIST CAR TABLE; LOW := HIGH := CAAR TABLE; JLIST := LIST CADAR TABLE; WHILE CDR TABLE AND CAR CADR TABLE < HIGH + 5 DO <<TABLE := CDR TABLE; WHILE HIGH < (CAAR TABLE) - 1 DO <<HIGH := HIGH + 1; JLIST := NCONC(JLIST,LIST ELSELAB)>>; HIGH := HIGH + 1; JLIST := NCONC(JLIST,LIST CADAR TABLE); JMPS := NCONC(JMPS,LIST CAR TABLE)>>; IF LENGTH JMPS < 4 THEN FOR EACH J IN JMPS DO !&ATTACH LIST('!*JUMPEQ,CADR J,'(REG 1),LIST('WCONST,CAR J)) ELSE !&ATTACH('!*JUMPON . '(REG 1) . LOW . HIGH . JLIST); TABLE := CDR TABLE>>; !&ATTJMP ELSELAB; SAVEREGS := REGS!&; FOR EACH THING IN EXPS DO <<!&ATTLBL CAR THING; REGS!& := SAVEREGS; IF CADR THING THEN !&COMVAL(CADR THING,STATUS!&); IF NOT !&TRANSFERP CODELIST!& THEN <<!&ATTJMP BOTTOMLAB; REGS1!& := REGS!& . REGS1!&>> >>; !&ATTLBL BOTTOMLAB; REGS!& := !&RMERGE REGS1!&; CONDTAIL!& := CDR CONDTAIL!& END; SYMBOLIC PROCEDURE !&INSTBL(TBL,I,L); IF NULL TBL THEN LIST LIST(I,L) ELSE IF I < CAAR TBL THEN LIST(I,L) . TBL ELSE IF I = CAAR TBL THEN !&COMPERROR LIST("Ambiguous case",TBL) ELSE CAR TBL . !&INSTBL(CDR TBL,I,L); SYMBOLIC PROCEDURE !&GETNUM X; IF !&WCONSTP X AND NUMBERP CADR X THEN CADR X ELSE !&COMPERROR(LIST("Number expected for CASE label",X)); SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS!&); %compiles program blocks; BEGIN SCALAR ALSTS!&,GOLIST!&,PG,PROGLIS,EXITT!&,EXITREGS!&; INTEGER I; %SCALAR OLDSTOMAP,OLDCODE; % OLDCODE := CODELIST!&; % OLDSTOMAP := STOMAP!&; EXITREGS!& := NIL; PROGLIS := CADR EXP; EXP := CDDR EXP; EXITT!& := !&GENLBL(); PG := !&REMVARL PROGLIS; %protect prog variables; ALSTS!& := !&VARBIND(PROGLIS,NIL); FOR EACH X IN EXP DO IF ATOM X THEN GOLIST!& := (X . !&GENLBL()) . GOLIST!&; WHILE EXP DO <<IF ATOM CAR EXP THEN <<!&ATTLBL !&GETLBL CAR EXP; REGS!& := NIL>> ELSE !&COMVAL(CAR EXP,IF STATUS!&>2 THEN 4 ELSE 3); EXP := CDR EXP>>; IF NOT !&TRANSFERP CODELIST!& AND STATUS!& < 2 THEN !&LREG1('(QUOTE NIL)); !&ATTLBL EXITT!&; REGS!& := !&RMERGE (REGS!& . EXITREGS!&); !&FREERSTR(ALSTS!&,STATUS!&); !&RSTVARL(PROGLIS,PG); %/ !&FIXFRM(OLDSTOMAP,OLDCODE,0); END; SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS!&); BEGIN EXP := CDR EXP; IF NULL EXP THEN RETURN !&COMVAL('(QUOTE NIL), STATUS!&); WHILE CDR EXP DO <<!&COMVAL(CAR EXP,IF STATUS!&<2 THEN 2 ELSE STATUS!&); EXP := CDR EXP>>; !&COMVAL(CAR EXP,STATUS!&) END; SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS!&); << EXP := CDR EXP; IF NULL EXP OR NOT NULL CDR EXP THEN << !&COMPERROR LIST("RETURN must have exactly one argument",EXP); EXP := '((QUOTE NIL)) >>; IF STATUS!&<4 OR NOT !&NOSIDEEFFECTP(CAR EXP) THEN !&LREG1(CAR !&COMLIS1 EXP); SLST!& := NIL; EXITREGS!& := REGS!& . EXITREGS!&; !&ATTJMP EXITT!& >>; SYMBOLIC PROCEDURE !&DELMAC X; % Delete macro CAR X from CODELIST!& RPLACA(X,'(!*NOOP)); %************************************************************* % Pass 3 %************************************************************* COMMENT Post Code Generation Fixups; SYMBOLIC PROCEDURE !&PASS3; % Pass 3 - optimization. % The optimizations currently performed are: % 1. Deletion of stores not yet picked up from SLST!&. % 2. Removal of unreachable macros. % 3. A peep hole optimizer, currently only optmizing LBL macros. % 4. Removal of common code chains % 5. Changing LINK to LINKE where possible % 6. Squeezing out unused frame locations and mapping the stack onto % the registers. % Other functions of PASS3 are to tack exit code on the end and reverse % the code list. << FOR EACH J IN SLST!& DO !&DELMAC CDR J; !&ATTLBL EXITT!&; !&ATTACH '(!*EXIT (!*FRAMESIZE)); !&REMCODE(T); !&FIXLABS(); !&FIXCHAINS(); !&FIXLINKS(); !&REMCODE(NIL); !&FIXFRM(NIL,NIL,NARG!&); !&PEEPHOLEOPT(); !&REMCODE(NIL); CODELIST!& := REVERSIP CODELIST!&; >>; SYMBOLIC PROCEDURE !&INSERTMAC(PLACE,MAC); RPLACW(PLACE,MAC . (CAR PLACE . CDR PLACE)); SYMBOLIC PROCEDURE !&DELETEMAC(PLACE); RPLACW(PLACE,CDR PLACE); SYMBOLIC PROCEDURE !&REMCODE(KEEPTOP); BEGIN SCALAR UNUSEDLBLS; UNUSEDLBLS := !&UNUSEDLBLS(KEEPTOP); !&REMUNUSEDMAC(UNUSEDLBLS); WHILE (UNUSEDLBLS := !&UNUSEDLBLS(KEEPTOP)) DO !&REMUNUSEDMAC(UNUSEDLBLS); END; SYMBOLIC PROCEDURE !&UNUSEDLBLS(KEEPTOP); BEGIN SCALAR USED,UNUSED; USED := NIL; UNUSED := LBLIST!&; IF KEEPTOP THEN <<USED := !&LABCLASS(TOPLAB!&) . USED; UNUSED := !&DELCLASS(TOPLAB!&,UNUSED)>>; FOR EACH MAC IN CODELIST!& DO IF CAR MAC NEQ '!*LBL THEN FOR EACH FLD IN CDR MAC DO IF EQCAR(FLD,'LABEL) AND !&CLASSMEMBER(FLD,UNUSED) THEN <<USED := !&LABCLASS(FLD) . USED; UNUSED := !&DELCLASS(FLD,UNUSED)>>; LBLIST!& := USED; RETURN UNUSED; END; SYMBOLIC PROCEDURE !&CLASSMEMBER(LAB,CLASSES); IF NULL CLASSES THEN NIL ELSE LAB MEMBER CAR CLASSES OR !&CLASSMEMBER(LAB,CDR CLASSES); SYMBOLIC PROCEDURE !&REMUNUSEDMAC(UNUSEDLABS); BEGIN SCALAR P,Q,R; CODELIST!& := P := REVERSIP CODELIST!&; WHILE CDR P DO <<Q := CDR P; IF CAAR Q = '!*NOOP OR !&TRANSFERP P AND CAAR Q NEQ '!*LBL OR CAAR Q = '!*LBL AND !&CLASSMEMBER(CADAR Q,UNUSEDLABS) THEN RPLACD(P,CDR Q) ELSE P := CDR P >>; CODELIST!& := REVERSIP CODELIST!&; END; lisp procedure !&FixLinks(); % % replace LINK by LINKE where appropriate % if not !*NoLinkE and not FreeBound!& then begin scalar Switched; for each Inst on CodeList!& do begin scalar SaveRest; if ExitT!& and first first Inst = '!*JUMP and second first Inst = ExitT!& or first first Inst = '!*EXIT then << if first second Inst = '!*LBL then << if first third Inst = '!*LINK then << Inst := cdr Inst; SaveRest := T >> >>; if first second Inst = '!*LINK then << if second second Inst eq NAME!& and !*R2I then Rplaca(rest Inst, list('!*JUMP, TopLab!&)) else Rplaca(rest Inst, '!*LINKE . '(!*FRAMESIZE) . rest second Inst); if not SaveRest then !&DeleteMac Inst >> >>; end; end; SYMBOLIC PROCEDURE !&PEEPHOLEOPT; %'peep-hole' optimization for various cases; BEGIN SCALAR X,Z; Z := CODELIST!&; WHILE Z DO IF CAAR Z = '!*NOOP THEN !&DELETEMAC Z ELSE IF NOT (X := GET(CAAR Z,'OPTFN)) OR NOT APPLY(X,LIST Z) THEN Z := CDR Z END; COMMENT Peep-hole optimization tables; SYMBOLIC PROCEDURE !&STOPT U; IF CAADR U = '!*ALLOC AND LLNGTH!& = 1 AND CDDAR U = '((FRAME 1)) THEN <<RPLACW(U,LIST('!*PUSH,CADAR U) . CDDR U)>> ELSE IF CAADR U = '!*MOVE AND CAADDR U = '!*ALLOC AND LLNGTH!& = 2 AND CDDAR U = '((FRAME 2)) AND CDDADR U = '((FRAME 1)) THEN <<RPLACW(U,LIST('!*PUSH,CADADR U) . LIST('!*PUSH,CADAR U) . CDDDR U)>>; SYMBOLIC PROCEDURE !&LBLOPT U; BEGIN SCALAR Z; IF CADR U = '!*LBL THEN <<!&DEFEQLBL(CADR U,CADR CDR U); RPLACD(U,CDDR U); RETURN T>>; IF CDADR U AND EQCAR(CADADR U,'LABEL) AND !&LBLEQ(CADAR U,CADADR U) THEN RETURN RPLACW(CDR U,CDDR U) ELSE IF CAADR U = '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP)) AND !&LBLEQ(CADAR U,CADR CADDR U) THEN RETURN <<Z := Z . (CADADR U . CDDR CADDR U); RPLACD(U,(Z . CDDDR U)); T>> ELSE RETURN NIL END; SYMBOLIC PROCEDURE !&JUMPOPT U; IF CADAR U = EXITT!& AND LLNGTH!& = 0 THEN RPLACA(U,'(!*EXIT (!*FRAMESIZE))); SYMBOLIC PROCEDURE !&FIXCHAINS(); BEGIN SCALAR LAB; FOR EACH LABCODE ON CODELIST!& DO IF CAAR LABCODE = '!*LBL % OR CAAR LABCODE = '!*JUMP % croaks on this one THEN <<LAB := CADAR LABCODE; FOR EACH JUMPCODE ON CDR LABCODE DO IF CAAR JUMPCODE = '!*JUMP AND CADAR JUMPCODE = LAB THEN !&MOVEJUMP(LABCODE,JUMPCODE)>> END; SYMBOLIC PROCEDURE !&MOVEJUMP(LABCODE,JUMPCODE); IF CADR LABCODE = CADR JUMPCODE THEN BEGIN SCALAR LAB; REPEAT <<IF CADR LABCODE = CADR JUMPCODE THEN <<JUMPCODE := CDR JUMPCODE; LABCODE := CDR LABCODE>>; WHILE CAADR LABCODE = '!*LBL DO LABCODE := CDR LABCODE; WHILE CAADR JUMPCODE = '!*LBL DO JUMPCODE := CDR JUMPCODE;>> UNTIL NOT(CADR JUMPCODE = CADR LABCODE); IF CAAR LABCODE = '!*LBL THEN RPLACD(JUMPCODE,LIST('!*JUMP,CADR CAR LABCODE) . CDR JUMPCODE) ELSE <<LAB := !&GENLBL(); RPLACD(JUMPCODE,LIST('!*JUMP,LAB) . CDR JUMPCODE); RPLACD(LABCODE,LIST('!*LBL,LAB) . CDR LABCODE)>>; END; SYMBOLIC PROCEDURE !&FIXFRM(OLDSTOMAP,OLDCODE,HIGHREG); % Should change FIXFRM to do sliding squeeze, not reorder; BEGIN SCALAR LST,GAZINTA,N,NF,TOP,FRAMESUSED,R,USED,FR,P,HMAP; HOLEMAP!& := NIL; % No stores were generated - frame size = 0 N := 1; GAZINTA := 1; % Now, loop through every allocated slot in the frame FRAMESUSED := !&GETFRAMES(CODELIST!&,OLDCODE,NIL); WHILE N <= LLNGTH!& DO <<USED := NIL; FR := !&MKFRAME N; FOR EACH VAR IN OLDSTOMAP DO IF CADR VAR = FR THEN USED := T; IF FR MEMBER FRAMESUSED THEN USED := T; % Find out if a frame location was used. N and GAZINTA used for squeeze % HOLEMAP!& is an association list between old and new frame locations. IF USED THEN <<HOLEMAP!& := LIST(FR,!&MKFRAME GAZINTA) . HOLEMAP!&; GAZINTA := GAZINTA + 1 >>; N := N + 1>>; LLNGTH!& := GAZINTA - 1; %now see if we can map stack to registers; TOP := !&HIGHEST(CODELIST!&,OLDCODE,HIGHREG,NIL); IF NOT(TOP = 'ALL OR FREEBOUND!& AND NOT !*USEREGFLUID) THEN <<HMAP := NIL; NF := 0; FOR EACH HOLE IN HOLEMAP!& DO IF TOP < LASTACTUALREG!& THEN << TOP := TOP + 1; LLNGTH!& := LLNGTH!& - 1; R := !&MKREG TOP; REGS!& := DELASC(R,REGS!&); HMAP := LIST(CAR HOLE,R) . HMAP>> ELSE << NF := NF + 1; HMAP := LIST(CAR HOLE, !&MKFRAME NF) . HMAP >>; IF NF NEQ 0 THEN LLNGTH!& := NF; HOLEMAP!& := HMAP; >> ELSE IF N = GAZINTA THEN RETURN NIL; P := CODELIST!&; WHILE NOT (P EQ OLDCODE) DO <<RPLACA(P,!&MACROSUBST(CAR P,HOLEMAP!&)); P := CDR P>>; END; SYMBOLIC PROCEDURE !&GETFRAMES(CODE,OLDCODE,RES); IF CODE EQ OLDCODE THEN RES ELSE !&GETFRAMES(CDR CODE,OLDCODE,!&GETFRAMES1(CDAR CODE,RES)); SYMBOLIC PROCEDURE !&GETFRAMES1(MACARGS,RES); IF NULL MACARGS THEN RES ELSE !&GETFRAMES1(CDR MACARGS, !&GETFRAMES2(CAR MACARGS,RES)); SYMBOLIC PROCEDURE !&GETFRAMES2(MACARG,RES); IF ATOM MACARG OR !&VARP MACARG OR !&CONSTP MACARG OR !®P MACARG THEN RES ELSE IF EQCAR(MACARG,'FRAME) THEN IF MACARG MEMBER RES THEN RES ELSE MACARG . RES ELSE !&GETFRAMES1(CDR MACARG,RES); SYMBOLIC PROCEDURE !&HIGHEST(START,STOP,HIGHREG,EXITFLAG); % Find the highest register used. 'ALL is returned if all are used. IF START EQ STOP THEN HIGHREG ELSE BEGIN SCALAR FN,MAC; MAC := CAR START; RETURN IF CAR MAC = '!*LINK OR CAR MAC = '!*LINKE AND EXITFLAG THEN <<FN := CADR MAC; IF FN = NAME!& THEN IF EXITFLAG THEN !&HIGHEST(CDR START,STOP,HIGHREG,EXITFLAG) ELSE 'ALL ELSE IF (DEST!& := GET(FN,'DESTROYS)) AND !*USINGDESTROY THEN <<FOR EACH R IN DEST!& DO HIGHREG := MAX(HIGHREG,CADR R); !&HIGHEST(CDR START,STOP,HIGHREG,EXITFLAG)>> ELSE 'ALL>> ELSE IF CAR MAC = '!*LINKF OR CAR MAC = '!*LINKEF AND EXITFLAG THEN 'ALL ELSE !&HIGHEST(CDR START,STOP,!&HIGHEST1(HIGHREG,CDR MAC),EXITFLAG); END; SYMBOLIC PROCEDURE !&HIGHEST1(H,ARGS); BEGIN FOR EACH A IN ARGS DO H := MAX(H,!&HIGHEST2(H,A)); RETURN H; END; SYMBOLIC PROCEDURE !&HIGHEST2(H,ARG); IF ATOM ARG THEN H ELSE IF NOT ATOM CAR ARG THEN !&HIGHEST1(H,ARG) ELSE IF !&CONSTP ARG THEN H ELSE IF CAR ARG = 'REG AND NUMBERP CADR ARG THEN MAX(H,CADR ARG) ELSE !&HIGHEST1(H,CDR ARG); SYMBOLIC PROCEDURE !&REFORMMACROS; BEGIN SCALAR FINALTRANSFORM; FINALTRANSFORM := LIST(LIST('(!*FRAMESIZE),LLNGTH!&)); FOR EACH MAC ON CODELIST!& DO RPLACA(MAC,!&MACROSUBST(CAR MAC,FINALTRANSFORM)); END; SYMBOLIC PROCEDURE !&FIXLABS(); BEGIN SCALAR TRANSFORM,U; TRANSFORM := NIL; FOR EACH LAB IN LBLIST!& DO FOR EACH EQLAB IN CDR LAB DO TRANSFORM := LIST(EQLAB,CAR LAB) . TRANSFORM; FOR EACH MAC ON CODELIST!& DO RPLACA(MAC,!&MACROSUBST(CAR MAC,TRANSFORM)); IF U := ASSOC(EXITT!&,TRANSFORM) THEN EXITT!& := CADR U; IF U := ASSOC(TOPLAB!&,TRANSFORM) THEN TOPLAB!& := CADR U; LBLIST!& := FOR EACH LAB IN LBLIST!& COLLECT LIST CAR LAB; END; SYMBOLIC PROCEDURE !&MACROSUBST(MAC,ALIST); CAR MAC . !&MACROSUBST1(CDR MAC,ALIST); SYMBOLIC PROCEDURE !&MACROSUBST1(ARGS,ALIST); FOR EACH ARG IN ARGS COLLECT !&MACROSUBST2(ARG,ALIST); SYMBOLIC PROCEDURE !&MACROSUBST2(ARG,ALIST); BEGIN SCALAR U; U:=ASSOC(ARG,ALIST); RETURN IF U THEN CADR U ELSE IF ATOM ARG OR FLAGP(CAR ARG,'TERMINAL) THEN ARG ELSE (CAR ARG . !&MACROSUBST1(CDR ARG,ALIST)); END; SYMBOLIC PROCEDURE !&REMTAGS(); FOR EACH MAC IN CODELIST!& DO !&REMTAGS1 MAC; SYMBOLIC PROCEDURE !&REMTAGS1 MAC; << IF CAR MAC = '!*JUMPON THEN RPLACD(CDDDR MAC, LIST CDDDDR MAC); FOR EACH MACFIELD IN CDR MAC DO !&REMTAGS2 MACFIELD >>; SYMBOLIC PROCEDURE !&REMTAGS2 U; IF EQCAR(U, 'WCONST) THEN !&REMTAGS3 CADR U; SYMBOLIC PROCEDURE !&REMTAGS3 U; BEGIN SCALAR DOFN; IF ATOM U THEN RETURN NIL; IF DOFN := GET(CAR U, 'DOFN) THEN RPLACA(U, DOFN); !&REMTAGS4 CDR U; END; SYMBOLIC PROCEDURE !&REMTAGS4 U; FOR EACH X IN U DO !&REMTAGS3 X; % Entry points used in setting up the system SYMBOLIC PROCEDURE !&ONEREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1))); SYMBOLIC PROCEDURE !&TWOREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1) (REG 2))); SYMBOLIC PROCEDURE !&THREEREG U; FOR EACH X IN U DO PUT(X,'DESTROYS,'((REG 1) (REG 2) (REG 3))); END; |
Added psl-1983/comp/data-machine.red version [b0ac0119c5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DATA-MACHINE.RED - Macros for fast access to data structures % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 April 1982 % Copyright (c) 1982 University of Utah % % Edit by GRISS, 3Nov: Added missing EVEC operations % Primitives handled by the compiler are BYTE, PUTBYTE, GETMEM, PUTMEM, % MKITEM, FIELD, SIGNEDFIELD, PUTFIELD, HALFWORD, PUYTHALFWORD on Syslisp; off R2I; % These definitions are for interpretive testing of Syslisp code. % They may be dangerous in some cases. CommentOutCode << syslsp procedure Byte(WAddr, ByteOffset); Byte(WAddr, ByteOffset); syslsp procedure PutByte(WAddr, ByteOffset, Val); PutByte(WAddr, ByteOffset, Val); syslsp procedure Halfword(WAddr, HalfwordOffset); Halfword(WAddr, HalfwordOffset); syslsp procedure PutHalfword(WAddr, HalfwordOffset, Val); PutHalfword(WAddr, HalfwordOffset, Val); syslsp procedure GetMem Addr; GetMem Addr; syslsp procedure PutMem(Addr, Val); PutMem(Addr, Val); syslsp procedure MkItem(TagPart, InfPart); MkItem(TagPart, InfPart); CommentOutCode << % can't do FIELD w/ non constants syslsp procedure Field(Cell, StartingBit, BitLength); Field(Cell, StartingBit, BitLength); syslsp procedure SignedField(Cell, StartingBit, BitLength); SignedField(Cell, StartingBit, BitLength); syslsp procedure PutField(Cell, StartingBit, BitLength, Val); PutField(Cell, StartingBit, BitLength, Val); >>; syslsp procedure WPlus2(R1, R2); WPlus2(R1, R2); syslsp procedure WDifference(R1, R2); WDifference(R1, R2); syslsp procedure WTimes2(R1, R2); WTimes2(R1, R2); syslsp procedure WQuotient(R1, R2); WQuotient(R1, R2); syslsp procedure WRemainder(R1, R2); WRemainder(R1, R2); syslsp procedure WMinus R1; WMinus R1; syslsp procedure WShift(R1, R2); WShift(R1, R2); syslsp procedure WAnd(R1, R2); WAnd(R1, R2); syslsp procedure WOr(R1, R2); WOr(R1, R2); syslsp procedure WXor(R1, R2); WXor(R1, R2); syslsp procedure WNot R1; WNot R1; syslsp procedure WLessP(R1, R2); WLessP(R1, R2); syslsp procedure WGreaterP(R1, R2); WGreaterP(R1, R2); syslsp procedure WLEQ(R1, R2); WLEQ(R1, R2); syslsp procedure WGEQ(R1, R2); WGEQ(R1, R2); >>; on R2I; off Syslisp; % SysLisp array accessing primitives syslsp macro procedure WGetV U; list('GetMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem)))); syslsp macro procedure WPutV U; list('PutMem, list('WPlus2, cadr U, list('WTimes2, caddr U, '(WConst AddressingUnitsPerItem))), cadddr U); % tags CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure HighTags U; DeclareTagRange(cdr U, LSH(1, get('TagBitLength, 'WConst)) - 1, -1); >>; LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair, Evect); put('Code, 'WConst, 15); HighTags(NegInt, ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); % Item constructor macros lisp procedure MakeItemConstructor(TagPart, InfPart); list('MkItem, TagPart, InfPart); syslsp macro procedure MkBTR U; MakeItemConstructor('(wconst BtrTag), cadr U); syslsp macro procedure MkID U; MakeItemConstructor('(wconst ID), cadr U); syslsp macro procedure MkFIXN U; MakeItemConstructor('(wconst FIXN), cadr U); syslsp macro procedure MkFLTN U; MakeItemConstructor('(wconst FLTN), cadr U); syslsp macro procedure MkBIGN U; MakeItemConstructor('(wconst BIGN), cadr U); syslsp macro procedure MkPAIR U; MakeItemConstructor('(wconst PAIR), cadr U); syslsp macro procedure MkVEC U; MakeItemConstructor('(wconst VECT), cadr U); syslsp macro procedure MkEVECT U; MakeItemConstructor('(wconst EVECT), cadr U); syslsp macro procedure MkWRDS U; MakeItemConstructor('(wconst WRDS), cadr U); syslsp macro procedure MkSTR U; MakeItemConstructor('(wconst STR), cadr U); syslsp macro procedure MkBYTES U; MakeItemConstructor('(wconst BYTES), cadr U); syslsp macro procedure MkHalfWords U; MakeItemConstructor('(wconst HalfWords), cadr U); syslsp macro procedure MkCODE U; MakeItemConstructor('(wconst CODE), cadr U); % Access to tag (type indicator) of Lisp item in ordinary code syslsp macro procedure Tag U; list('Field, cadr U, '(wconst TagStartingBit), '(wconst TagBitLength)); % Access to info field of item (pointer or immediate operand) syslsp macro procedure Inf U; list('Field, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength)); syslsp macro procedure PutInf U; list('PutField, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength), caddr U); for each X in '(IDInf StrInf VecInf EvecInf PairInf WrdInf HalfWordInf CodeInf FixInf FltInf BigInf) do PutD(X, 'Macro, cdr getd 'Inf); for each X in '(PutIDInf PutStrInf PutVecInf PutPairInf PutWrdInf PutHalfWordInf PutEvecInf PutFixInf PutFltInf PutBigInf) do PutD(X, 'Macro, cdr getd 'PutInf); % IntInf is no longer needed, will be a macro no-op % for the time being RemProp('IntInf, 'OpenFn); macro procedure IntInf U; cadr U; % Similarly for MkINT macro procedure MkINT U; cadr U; % # of words in a pair syslsp macro procedure PairPack U; 2; % length (in characters, words, etc.) of a string, vector, or whatever, % stored in the first word pointed to syslsp macro procedure GetLen U; list('SignedField, list('GetMem, cadr U), '(WConst InfStartingBit), '(WConst InfBitLength)); syslsp macro procedure StrBase U; % point to chars of string list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); % chars string length --> words string length % Note that StrPack and HalfWordPack do not include the header word, % VectPack and WrdPack do. syslsp macro procedure StrPack U; list('WQuotient, list('WPlus2, cadr U, list('WPlus2, '(WConst CharactersPerWord), 1)), '(WConst CharactersPerWord)); % access to bytes of string; skip first word syslsp macro procedure StrByt U; list('Byte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutStrByt U; list('PutByte, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % access to halfword entries; skip first word syslsp macro procedure HalfWordItm U; list('HalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U); syslsp macro procedure PutHalfWordItm U; list('PutHalfWord, list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)), caddr U, cadddr U); % halfword length --> words length syslsp macro procedure HalfWordPack U; list('WPlus2, list('WShift, cadr U, -1), 1); % length (in Item size quantities) of Lisp vectors % size of Lisp vector in words syslsp macro procedure VectPack U; list('WPlus2, cadr U, 1); % size of Lisp Evector in words syslsp macro procedure EVectPack U; list('WPlus2, cadr U, 1); % access to elements of Lisp vector syslsp macro procedure VecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % access to elements of Lisp Evector syslsp macro procedure EVecItm U; list('WGetV, cadr U, list('WPlus2, caddr U, 1)); syslsp macro procedure PutEVecItm U; list('WPutV, cadr U, list('WPlus2, caddr U, 1), cadddr U); % Wrd is like Vect, but not traced by the garbage collector syslsp macro procedure WrdPack U; list('WPlus2, cadr U, 1); for each X in '(StrLen ByteLen VecLen EVecLen WrdLen HalfWordLen) do PutD(X, 'Macro, cdr getd 'GetLen); PutD('WrdItm, 'Macro, cdr GetD 'VecItm); PutD('PutWrdItm, 'Macro, cdr GetD 'PutVecItm); syslsp macro procedure FixVal U; list('WGetV, cadr U, 1); syslsp macro procedure PutFixVal U; list('WPutV, cadr U, 1, caddr U); syslsp macro procedure FloatBase U; list('WPlus2, cadr U, '(WConst AddressingUnitsPerItem)); syslsp macro procedure FloatHighOrder U; list('WGetV, cadr U, 1); syslsp macro procedure FloatLowOrder U; list('WGetV, cadr U, 2); % New addition: A code pointer can have the number of arguments it expects % stored in the word just before the entry syslsp macro procedure !%code!-number!-of!-arguments U; list('WGetV, cadr U, -1); % The four basic cells for each symbol: Val, Nam, Fnc, Prp, corresponding to % variable value, symbol name (as string), function cell (jump to compiled % code or lambda linker) and property list (pairs for PUT, GET, atoms for FLAG, % FLAGP). These are currently 4 separate arrays, but this representation may % be changed to a contiguous 4 element record for each symbol or something else % and therefore should not be accessed as arrays. syslsp macro procedure SymVal U; list('WGetV, '(WConst SymVal), cadr U); syslsp macro procedure PutSymVal U; list('WPutV, '(WConst SymVal), cadr U, caddr U); syslsp macro procedure LispVar U; % Access value cell by name list('(WConst SymVal), list('IDLoc, cadr U)); syslsp macro procedure PutLispVar U; list('PutSymVal, list('IDLoc, cadr U), caddr U); syslsp macro procedure SymNam U; list('WGetV, '(WConst SymNam), cadr U); syslsp macro procedure PutSymNam U; list('WPutV, '(WConst SymNam), cadr U, caddr U); % Retrieve the address stored in the function cell % SymFnc and PutSymFnc are not defined portably syslsp macro procedure SymPrp U; list('WGetV, '(WConst SymPrp), cadr U); syslsp macro procedure PutSymPrp U; list('WPutV, '(WConst SymPrp), cadr U, caddr U); % Binding stack primitives syslsp macro procedure BndStkID U; list('WGetV, cadr U, -1); syslsp macro procedure PutBndStkID U; list('WPutV, cadr U, -1, caddr U); syslsp macro procedure BndStkVal U; list('GetMem, cadr U); syslsp macro procedure PutBndStkVal U; list('PutMem, cadr U, caddr U); syslsp macro procedure AdjustBndStkPtr U; list('WPlus2, cadr U, list('WTimes2, caddr U, list('WTimes2, '(WConst AddressingUnitsPerItem), 2))); % ObArray is a linearly allocated hash table containing ID numbers of entries % maintained as a circular buffer. It is referenced only via these macros % because we may decide to change to some other representation. syslsp smacro procedure ObArray I; HalfWord(HashTable, I); syslsp smacro procedure PutObArray(I, X); HalfWord(HashTable, I) := X; put('ObArray, 'Assign!-Op, 'PutObArray); syslsp smacro procedure OccupiedSlot U; ObArray U > 0; DefList('((GetMem PutMem) (Field PutField) (Byte PutByte) (HalfWord PutHalfWord) (Tag PutTag) (Inf PutInf) (IDInf PutIDInf) (StrInf PutStrInf) (VecInf PutVecInf) (EVecInf PutEVecInf) (WrdInf PutWrdInf) (PairInf PutPairInf) (FixInf PutFixInf) (FixVal PutFixVal) (FltInf PutFltInf) (BigInf PutBigInf) (StrLen PutStrLen) (StrByt PutStrByt) (VecLen PutVecLen) (VecInf PutVecInf) (VecItm PutVecItm) (EVecItm PutEVecItm) (WrdLen PutWrdLen) (WrdItm PutWrdItm) (SymVal PutSymVal) (LispVar PutLispVar) (SymNam PutSymNam) (SymFnc PutSymFnc) (SymPrp PutSymPrp) (BndStkID PutBndStkID) (BndStkVal PutBndStkVal)), 'Assign!-Op); % This is redefined for the HP 9836 to cure the high-order FF problem macro procedure !%chipmunk!-kludge x; cadr x; END; |
Added psl-1983/comp/faslout.build version [babaa196cb].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | CompileTime load If!-system, Syslisp; CompileTime if_system(PDP10, << load Monsym; in "p20:system-faslout.red"$ >>)$ CompileTime if_system(Unix, << in "../kernel/vax/system-faslout.red"$ >>)$ CompileTime if_system(HP9836, << in "php:system-faslout.red"$ >>)$ in "faslout.red"$ |
Added psl-1983/comp/faslout.red version [4b496b5191].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FASLOUT.RED - Top level of fasl file writer % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 16 February 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP>FASLOUT.RED.6, 16-Dec-82 12:49:59, Edit by KESSLER % Take out Semic!* as a fluid. Not used by anyone that I can see % and is already a global in RLISP. % <PSL.COMP>FASLOUT.RED.35, 10-Jun-82 10:41:18, Edit by GRISS % Made CompileUncompiledExpressions regular func % <PSL.COMP>FASLOUT.RED.12, 30-Apr-82 14:45:59, Edit by BENSON % Removed EVAL and IGNORE processing % <PSL.COMP>FASLOUT.RED.8, 29-Apr-82 06:23:18, Edit by GRISS % moved DEFINEROP call to RLISP-PARSER CompileTime << flag('(CodeFileHeader CodeFileTrailer AllocateFaslSpaces), 'InternalFunction); load Fast!-Vector; >>; fluid '(!*WritingFaslFile !*Lower !*quiet_faslout DfPrint!* UncompiledExpressions!* ModuleName!* CodeOut!* InitOffset!* CurrentOffset!* FaslBlockEnd!* MaxFaslOffset!* BitTableOffset!* FaslFilenameFormat!*); FaslFilenameFormat!* := "%w.b"; lisp procedure DfPrintFasl U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn, !*WritingFaslFile; !*WritingFaslFile := T; if atom U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; IF FLAGP(TY,'COMPILE) THEN << PUT(NAM,'CFNTYPE,LIST TY); U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U) . !&COMPROC(U, NAM); LAP U >> ELSE % should never happen SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM, MKQUOTE TY, MKQUOTE U); if IGreaterP(Posn(), 0) then WriteChar char BLANK; Prin1 NAM; RETURN NIL; DB1: % Simple S-EXPRESSION, maybe EVAL it; IF NOT PAIRP U THEN RETURN NIL; if (Fn := get(car U, 'FaslPreEval)) then return Apply(Fn, list U) else if (Fn := GetD car U) and car Fn = 'MACRO then return DFPRINTFasl Apply(cdr Fn, list U); SaveUncompiledExpression U; RETURN NIL; DB2: NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; FLAG ('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL); lisp procedure FaslPreEvalLoadTime U; DFPrintFasl cadr U; % remove LOADTIME put('LoadTime, 'FaslPreEval, 'FaslPreEvalLoadTime); put('BothTimes, 'FaslPreEval, 'FaslPreEvalLoadTime); put('StartupTime, 'FaslPreEval, 'FaslPreEvalLoadTime); % used in kernel % A few things to save space when loading put('Flag, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Flag1, MkQuote X, third U)) else SaveUncompiledExpression U); put('fluid, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Fluid1, MkQuote X)) else SaveUncompiledExpression U); put('global, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('Global1, MkQuote X)) else SaveUncompiledExpression U); put('DefList, 'FaslPreEval, function lambda U; if EqCar(second U, 'QUOTE) then DFPrintFasl('progn . for each X in second second U collect list('put, MkQuote first X, third U, MkQuote second X)) else SaveUncompiledExpression U); put('ProgN, 'FaslPreEval, function lambda U; for each X in cdr U do DFPrintFasl X); put('LAP, 'FaslPreEval, function lambda U; if EqCar(cadr U, 'QUOTE) then Lap cadr cadr U else SaveUncompiledExpression U); UncompiledExpressions!* := NIL . NIL; lisp procedure SaveUncompiledExpression U; << if atom U then NIL else TConc(UncompiledExpressions!*, U); NIL >>; lisp procedure FaslOut FIL; << ModuleName!* := FIL; if not !*quiet_faslout then << if not FUnBoundP 'Begin1 then << Prin2T "FASLOUT: IN files; or type in expressions"; Prin2T "When all done execute FASLEND;" >> else << Prin2T "FASLOUT: (DSKIN files) or type in expressions"; Prin2T "When all done execute (FASLEND)" >> >>; CodeOut!* := BinaryOpenWrite BldMsg(FaslFilenameFormat!*, ModuleName!*); CodeFileHeader(); DFPRINT!* := 'DFPRINTFasl; !*WritingFaslFile := T; !*DEFN := T >>; lisp procedure FaslEnd; if not !*WritingFaslFile then StdError "FASLEND not within FASLOUT" else << CompileUncompiledExpressions(); UncompiledExpressions!* := NIL . NIL; CodeFileTrailer(); BinaryClose CodeOut!*; DFPRINT!* := NIL; !*WritingFaslFile := NIL; !*DEFN := NIL >>; FLAG('(FaslEND), 'IGNORE); lisp procedure ComFile Filename; begin scalar !*Defn, !*WritingFaslFile, TestFile, FileBase, FileExt, I, N, DotFound, TestExts, !*quiet_faslout; if IDP Filename then (lambda (!*Lower); Filename := BldMsg("%w", Filename))(T); if not StringP Filename then return NonStringError(Filename, 'ComFile); N := ISizeS Filename; I := 0; while not DotFound and ILEQ(I, N) do << if IGetS(Filename, I) = char '!. then DotFound := T; I := IAdd1 I >>; if DotFound then << if not FileP Filename then return ContError(99, "Couldn't find file", ComFile Filename) else << FileBase := SubSeq(Filename, 0, I); FileExt := SubSeq(Filename, ISub1 I, IAdd1 N) >> >> else << TestExts := '(".build" ".sl" ".red"); while not null TestExts and not FileP(TestFile := Concat(Filename, first TestExts)) do TestExts := rest TestExts; if null TestExts then return ContError(99, "Couldn't find file", ComFile Filename) else << FileExt := first TestExts; FileBase := Filename; Filename := TestFile >> >>; ErrorPrintF("*** Compiling %w", Filename); !*quiet_faslout := T; Faslout FileBase; if FileExt member '(".build" ".red") then EvIn list Filename else DskIn Filename; Faslend; return T; end; lisp procedure CompileUncompiledExpressions(); << ErrorPrintF("*** Init code length is %w", length car UncompiledExpressions!*); DFPRINTFasl list('DE, '!*!*Fasl!*!*InitCode!*!*, '(), 'PROGN . car UncompiledExpressions!*) >>; lisp procedure CodeFileHeader(); << BinaryWrite(CodeOut!*, const FASL_MAGIC_NUMBER); AllocateFaslSpaces() >>; fluid '(CodeBase!* BitTableBase!* OrderedIDList!* NextIDNumber!*); lisp procedure FindIDNumber U; begin scalar I; return if ILEQ(I := IDInf U, 128) then I else if (I := get(U, 'IDNumber)) then I else << put(U, 'IDNumber, I := NextIDNumber!*); OrderedIDList!* := TConc(OrderedIDList!*, U); NextIDNumber!* := IAdd1 NextIDNumber!*; I >>; end; lisp procedure CodeFileTrailer(); begin scalar S; SystemFaslFixup(); BinaryWrite(CodeOut!*, IDifference(ISub1 NextIDNumber!*, 2048)); % Number of local IDs for each X in car OrderedIDList!* do << RemProp(X, 'IDNumber); X := StrInf ID2String X; S := StrLen X; BinaryWriteBlock(CodeOut!*, X, IAdd1 StrPack S) >>; BinaryWrite(CodeOut!*, % S is size in words S := IQuotient(IPlus2(CurrentOffset!*, ISub1 const AddressingUnitsPerItem), const AddressingUnitsPerItem)); BinaryWrite(CodeOut!*, InitOffset!*); BinaryWriteBlock(CodeOut!*, CodeBase!*, S); BinaryWrite(CodeOut!*, S := IQuotient(IPlus2(BitTableOffset!*, ISub1 const BitTableEntriesPerWord), const BitTableEntriesPerWord)); BinaryWriteBlock(CodeOut!*, BitTableBase!*, S); DelWArray(BitTableBase!*, FaslBlockEnd!*); end; lisp procedure UpdateBitTable(NumberOfEntries, FirstEntry); if !*WritingFaslFile then << PutBitTable(BitTableBase!*, BitTableOffset!*, FirstEntry); BitTableOffset!* := IAdd1 BitTableOffset!*; for I := 2 step 1 until NumberOfEntries do << PutBitTable(BitTableBase!*, BitTableOffset!*, 0); BitTableOffset!* := IAdd1 BitTableOffset!* >>; if IGreaterP(BitTableOffset!*, MaxFaslOffset!*) then FatalError "BPS exhausted during FaslOut; output file too large" >>; lisp procedure AllocateFaslSpaces(); begin scalar B; B := GTWarray NIL; % how much is left? B := IDifference(B, IQuotient(B, 3)); FaslBlockEnd!* := GTWArray 0; % pointer to top of space BitTableBase!* := GTWarray B; % take 2/3 of whatever's left CurrentOffset!* := 0; BitTableOffset!* := 0; CodeBase!* := Loc WGetV(BitTableBase!*, % split the space between IQuotient(B, % bit table and code IQuotient(const BitTableEntriesPerWord, const AddressingUnitsPerItem))); MaxFaslOffset!* := IDifference(FaslBlockEnd!*, CodeBase!*); OrderedIDList!* := NIL . NIL; NextIDNumber!* := 2048; % local IDs start at 2048 end; END; |
Added psl-1983/comp/lap-to-asm.build version [7654a0381f].
> | 1 | in "lap-to-asm.red"$ |
Added psl-1983/comp/lap-to-asm.red version [232c93f1e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LAP-TO-ASM.RED - LAP to assembler translator % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 13 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.COMP>LAP-TO-ASM.RED.5, 30-Apr-82 14:47:52, Edit by BENSON % Removed EVAL and IGNORE processing Imports '(PathIn); % kernel build files use PATHIN fluid '(!*Comp !*PLap DfPrint!* CharactersPerWord AddressingUnitsPerItem AddressingUnitsPerFunctionCell InputSymFile!* OutputSymFile!* CodeOut!* DataOut!* InitOut!*; CodeFileNameFormat!* DataFileNameFormat!* InitFileNameFormat!* ModuleName!* UncompiledExpressions!* NextIDNumber!* OrderedIDList!* NilNumber!* !*MainFound !*MAIN !*DeclareBeforeUse MainEntryPointName!* EntryPoints!* LocalLabels!* CodeExternals!* CodeExporteds!* DataExternals!* DataExporteds!* ExternalDeclarationFormat!* ExportedDeclarationFormat!* LabelFormat!* FullWordFormat!* DoubleFloatFormat!* ReserveDataBlockFormat!* ReserveZeroBlockFormat!* UndefinedFunctionCellInstructions!* DefinedFunctionCellFormat!* PrintExpressionForm!* PrintExpressionFormPointer!* CommentFormat!* NumericRegisterNames!* ExpressionCount!* ASMOpenParen!* ASMCloseParen!* ToBeCompiledExpressions!* GlobalDataFileName!* ); global '(Semic!*); InputSymFile!* := "psl.sym"; OutputSymFile!* := "psl.sym"; GlobalDataFileName!* := "global-data.red"; InitFileNameFormat!* := "%w.init"; lisp procedure DfPrintASM U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn; if atom U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; IF FLAGP(TY,'COMPILE) THEN << PUT(NAM,'CFNTYPE,LIST TY); U := LIST('!*ENTRY,NAM,TY,LENGTH CADR U) . !&COMPROC(U, NAM); if !*PLAP then for each X in U do Print X; if TY neq 'EXPR then DfPrintASM list('put, MkQuote Nam, '(quote TYPE), MkQuote TY); ASMOUTLAP U >> ELSE % should never happen SaveUncompiledExpression LIST('PUTD, MKQUOTE NAM, MKQUOTE TY, MKQUOTE U); RETURN NIL; DB1: % Simple S-EXPRESSION, maybe EVAL it; IF NOT PAIRP U THEN RETURN NIL; if (Fn := get(car U, 'ASMPreEval)) then return Apply(Fn, list U) else if (Fn := GetD car U) and car Fn = 'MACRO then return DFPRINTASM Apply(cdr Fn, list U); SaveUncompiledExpression U; RETURN NIL; DB2: NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; lisp procedure ASMPreEvalLoadTime U; DFPrintASM cadr U; % remove LOADTIME put('LoadTime, 'ASMPreEval, 'ASMPreEvalLoadTime); lisp procedure ASMPreEvalStartupTime U; SaveForCompilation cadr U; put('StartupTime, 'ASMPreEval, 'ASMPreEvalStartupTime); lisp procedure ASMPreEvalProgN U; for each X in cdr U do DFPrintASM X; put('ProgN, 'ASMPreEval, 'ASMPreEvalProgN); put('WDeclare, 'ASMPreEval, 'Eval); % do it now lisp procedure ASMPreEvalSetQ U; begin scalar X, Val; X := cadr U; Val := caddr U; return if ConstantP Val or Val = T then << FindIDNumber X; put(X, 'InitialValue, Val); NIL >> else if null Val then << FindIDNumber X; RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue); NIL >> else if EqCar(Val, 'QUOTE) then << FindIDNumber X; Val := cadr Val; if null Val then << RemProp(X, 'InitialValue); Flag(list X, 'NilInitialValue) >> else put(X, 'InitialValue, Val); NIL >> else if IDP Val and get(Val, 'InitialValue) or FlagP(Val, 'NilInitialValue) then << if (Val := get(Val, 'InitialValue)) then put(X, 'InitialValue, Val) else Flag(list X, 'NilInitialValue) >> else SaveUncompiledExpression U; % just check simple cases, else return end; put('SetQ, 'ASMPreEval, 'ASMPreEvalSetQ); lisp procedure ASMPreEvalPutD U; SaveUncompiledExpression CheckForEasySharedEntryPoints U; lisp procedure CheckForEasySharedEntryPoints U; % % looking for (PUTD (QUOTE name1) xxxx (CDR (GETD (QUOTE name2)))) % begin scalar NU, Nam, Exp; NU := cdr U; Nam := car NU; if car Nam = 'QUOTE then Nam := cadr Nam else return U; NU := cdr NU; Exp := cadr NU; if not (car Exp = 'CDR) then return U; Exp := cadr Exp; if not (car Exp = 'GETD) then return U; Exp := cadr Exp; if not (car Exp = 'QUOTE) then return U; Exp := cadr Exp; FindIDNumber Nam; put(Nam, 'EntryPoint, FindEntryPoint Exp); if not (car NU = '(QUOTE EXPR)) then return list('Put, '(Quote Type), car NU); return NIL; end; put('PutD, 'ASMPreEval, 'ASMPreEvalPutD); lisp procedure ASMPreEvalFluidAndGlobal U; << if EqCar(cadr U, 'QUOTE) then Flag(cadr cadr U, 'NilInitialValue); SaveUncompiledExpression U >>; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); CommentOutCode << fluid '(NewFluids!* NewGlobals!*); lisp procedure ASMPreEvalFluidAndGlobal U; begin scalar L; L := cadr U; return if car L = 'QUOTE then << L := cadr L; if car U = 'FLUID then NewFluids!* := UnionQ(NewFluids!*, L) % take union else NewGlobals!* := UnionQ(NewGlobals!*, L); Flag(L, 'NilInitialValue); NIL >> else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); put('Global, 'ASMPreEval, 'ASMPreEvalFluidAndGlobal); >>; lisp procedure ASMPreEvalLAP U; if EqCar(cadr U, 'QUOTE) then ASMOutLap cadr cadr U else SaveUncompiledExpression U; put('LAP, 'ASMPreEval, 'ASMPreEvalLAP); CommentOutCode << lisp procedure InitialPut(Nam, Ind, Val); begin scalar L, P; FindIDNumber Nam; if (P := Atsoc(Ind, L := get(Nam, 'InitialPropertyList))) then Rplacd(P, Val) else put(Nam, 'InitialPropertyList, (Ind . Val) . L); end; lisp procedure InitialRemprop(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelAtQIP(Ind, L)); end; lisp procedure InitialFlag1(Nam, Ind); begin scalar L, P; FindIDNumber Nam; if not Ind memq (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, Ind . L); end; lisp procedure InitialRemFlag1(Nam, Ind); begin scalar L; if (L := get(Nam, 'InitialPropertyList)) then put(Nam, 'InitialPropertyList, DelQIP(Ind, L)); end; lisp procedure ASMPreEvalPut U; begin scalar Nam, Ind, Val; Nam := second U; Ind := third U; Val := fourth U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) and (ConstantP Val or Val = T or EqCar(Val, 'QUOTE)) then InitialPut(second Nam, second Ind, if EqCar(Val, 'QUOTE) then second Val else Val) else SaveUncompiledExpression U; end; put('put, 'ASMPreEval, 'ASMPreEvalPut); lisp procedure ASMPreEvalRemProp U; begin scalar Nam, Ind; Nam := second U; Ind := third U; if EqCar(Nam, 'QUOTE) and EqCar(Ind, 'QUOTE) then InitialRemProp(second Nam, second Ind) else SaveUncompiledExpression U; end; put('RemProp, 'ASMPreEval, 'ASMPreEvalRemProp); lisp procedure ASMPreEvalDefList U; begin scalar DList, Ind; DList := second U; Ind := third U; if EqCar(DList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << DList := second DList; Ind := second Ind; for each X in Dlist do InitialPut(first X, Ind, second X) >> else SaveUncompiledExpression U; end; put('DefList, 'ASMPreEval, 'ASMPreEvalDefList); lisp procedure ASMPreEvalFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('flag, 'ASMPreEval, 'ASMPreEvalFlag); lisp procedure ASMPreEvalRemFlag U; begin scalar NameList, Ind; NameList := second U; Ind := third U; if EqCar(NameList, 'QUOTE) and EqCar(Ind, 'QUOTE) then << Ind := second Ind; for each X in second NameList do InitialRemFlag1(X, Ind) >> else SaveUncompiledExpression U; end; put('RemFlag, 'ASMPreEval, 'ASMPreEvalRemFlag); lisp procedure ASMPreEvalGlobal U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'Global) else SaveUncompiledExpression U; end; put('Global, 'ASMPreEval, 'ASMPreEvalGlobal); lisp procedure ASMPreEvalFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialPut(X, 'TYPE, 'FLUID) else SaveUncompiledExpression U; end; put('Fluid, 'ASMPreEval, 'ASMPreEvalFluid); lisp procedure ASMPreEvalUnFluid U; begin scalar NameList; NameList := second U; if EqCar(NameList, 'QUOTE) then for each X in second NameList do InitialRemProp(X, 'TYPE) else SaveUncompiledExpression U; end; put('UnFluid, 'ASMPreEval, 'ASMPreEvalUnFluid); >>; lisp procedure SaveUncompiledExpression U; if PairP U then begin scalar OldOut; OldOut := WRS InitOut!*; Print U; WRS OldOut; end; ToBeCompiledExpressions!* := NIL . NIL; lisp procedure SaveForCompilation U; if atom U or U member car ToBeCompiledExpressions!* then NIL else if car U = 'progn then for each X in cdr U do SaveForCompilation X else TConc(ToBeCompiledExpressions!*, U); SYMBOLIC PROCEDURE ASMOUT FIL; begin scalar OldOut; ModuleName!* := FIL; Prin2T "ASMOUT: IN files; or type in expressions"; Prin2T "When all done execute ASMEND;"; CodeOut!* := Open(BldMsg(CodeFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS CodeOut!*; LineLength 1000; WRS OldOut; CodeFileHeader(); DataOut!* := Open(BldMsg(DataFileNameFormat!*, ModuleName!*), 'OUTPUT); OldOut := WRS DataOut!*; LineLength 1000; WRS OldOut; DataFileHeader(); InitOut!* := Open(BldMsg(InitFileNameFormat!*, ModuleName!*), 'OUTPUT); ReadSYMFile(); DFPRINT!* := 'DFPRINTASM; RemD 'OldLap; PutD('OldLap, 'EXPR, cdr RemD 'Lap); PutD('Lap, 'EXPR, cdr GetD 'ASMOutLap); !*DEFN := T; SEMIC!* := '!$ ; % to turn echo off for IN if not ((ModuleName!* = "main") or !*Main) then EVIN list GlobalDataFileName!* else !*Main := T; end; lisp procedure ASMEnd; << off SysLisp; if !*MainFound then << CompileUncompiledExpressions(); % WriteInitFile(); InitializeSymbolTable() >> else WriteSymFile(); CodeFileTrailer(); Close CodeOut!*; DataFileTrailer(); Close DataOut!*; Close InitOut!*; RemD 'Lap; PutD('Lap, 'EXPR, cdr GetD 'OldLap); DFPRINT!* := NIL; !*DEFN := NIL >>; FLAG('(ASMEND), 'IGNORE); DEFINEROP('ASMEND,NIL,ESTAT('ASMEND)); lisp procedure CompileUncompiledExpressions(); << CommentOutCode << AddFluidAndGlobalDecls(); >>; DFPRINTASM list('DE, 'INITCODE, '(), 'PROGN . car ToBeCompiledExpressions!*) >>; CommentOutCode << lisp procedure AddFluidAndGlobalDecls(); << SaveUncompiledExpression list('GLOBAL, MkQuote NewGlobals!*); SaveUncompiledExpression list('FLUID, MkQuote NewFluids!*) >>; >>; lisp procedure ReadSymFile(); LapIN InputSymFile!*; lisp procedure WriteSymFile(); begin scalar NewOut, OldOut; OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT)); print list('SaveForCompilation, MkQuote('progn . car ToBeCompiledExpressions!*)); SaveIDList(); SetqPrint 'NextIDNumber!*; SetqPrint 'StringGenSym!*; MapObl function PutPrintEntryAndSym; WRS OldOut; Close NewOut; end; CommentOutCode << lisp procedure WriteInitFile(); begin scalar OldOut, NewOut; NewOut := Open(InitFileName!*, 'OUTPUT); OldOut := WRS NewOut; for each X in car UncompiledExpressions!* do PrintInit X; Close NewOut; WRS OldOut; end; lisp procedure PrintInit X; if EqCar(X, 'progn) then for each Y in cdr X do PrintInit Y else Print X; >>; lisp procedure SaveIDList(); << Print list('setq, 'OrderedIDList!*, MkQuote car OrderedIDList!*); Print quote(OrderedIDList!* := OrderedIDList!* . LastPair OrderedIDList!*) >>; lisp procedure SetqPrint U; print list('SETQ, U, MkQuote Eval U); lisp procedure PutPrint(X, Y, Z); print list('PUT, MkQuote X, MkQuote Y, MkQuote Z); lisp procedure PutPrintEntryAndSym X; begin scalar Y; if (Y := get(X, 'EntryPoint)) then PutPrint(X, 'EntryPoint, Y); if (Y := get(X, 'IDNumber)) then PutPrint(X, 'IDNumber, Y); CommentOutCode << if (Y := get(X, 'InitialPropertyList)) then PutPrint(X, 'InitialPropertyList, Y); >>; if (Y := get(X, 'InitialValue)) then PutPrint(X, 'InitialValue, Y) else if FlagP(X, 'NilInitialValue) then print list('flag, MkQuote list X, '(quote NilInitialValue)); if get(X, 'SCOPE) = 'EXTERNAL then << PutPrint(X, 'SCOPE, 'EXTERNAL); PutPrint(X, 'ASMSymbol, get(X, 'ASMSymbol)); if get(X, 'WVar) then PutPrint(X, 'WVar, X) else if get(X, 'WArray) then PutPrint(X, 'WArray, X) else if get(X, 'WString) then PutPrint(X, 'WString, X) else if (Y := get(X, 'WConst)) then PutPrint(X, 'WConst, Y) >>; end; lisp procedure FindIDNumber U; begin scalar I; return if (I := ID2Int U) <= 128 then I else if (I := get(U, 'IDNumber)) then I else << put(U, 'IDNumber, I := NextIDNumber!*); OrderedIDList!* := TConc(OrderedIDList!*, U); NextIDNumber!* := NextIDNumber!* + 1; I >>; end; OrderedIDList!* := NIL . NIL; NextIDNumber!* := 129; lisp procedure InitializeSymbolTable(); begin scalar MaxSymbol; MaxSymbol := get('MaxSymbols, 'WConst); if MaxSymbol < NextIDNumber!* then << ErrorPrintF("*** MaxSymbols %r is too small; at least %r is needed", MaxSymbol, NextIDNumber!*); MaxSymbol := NextIDNumber!* + 100 >>; Flag('(NIL), 'NilInitialValue); put('T, 'InitialValue, 'T); put('!$EOF!$, 'InitialValue, Int2ID get('EOF, 'CharConst)); put('!$EOL!$, 'InitialValue, '! ); NilNumber!* := CompileConstant NIL; DataAlignFullWord(); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymVal(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); InitializeSymPrp(); DataReserveBlock((MaxSymbol - NextIDNumber!*) + 1); %/ This is a BUG? M.L. G. %/ for I := NextIDNumber!* step 1 until MaxSymbol do %/ DataPrintFullWord NilNumber!*; InitializeSymNam MaxSymbol; InitializeSymFnc(); DataReserveFunctionCellBlock((MaxSymbol - NextIDNumber!*) + 1); DataAlignFullWord(); DataPrintGlobalLabel FindGlobalLabel 'NextSymbol; DataPrintFullWord NextIDNumber!*; end; lisp procedure InitializeSymPrp(); << CommentOutCode << InitializeHeap(); >>; % init prop lists DataPrintGlobalLabel FindGlobalLabel 'SymPrp; for I := 0 step 1 until 128 do InitSymPrp1 Int2ID I; for each X in car OrderedIDList!* do InitSymPrp1 X >>; lisp procedure InitSymPrp1 X; << CommentOutCode << DataPrintFullWord(if (X := get(X, 'InitialPropertyList)) then X else NilNumber!*); >>; DataPrintFullWord NilNumber!* >>; CommentOutCode << lisp procedure InitializeHeap(); begin scalar L; DataPrintGlobalLabel FindGlobalLabel 'Heap; for I := 0 step 1 until 128 do PrintPropertyList Int2ID I; for each X in car OrderedIDList!* do PrintPropertyList X; L := get('HeapSize, 'WConst); end; >>; lisp procedure InitializeSymNam MaxSymbol; << DataPrintGlobalLabel FindGlobalLabel 'SymNam; for I := 0 step 1 until 128 do DataPrintFullWord CompileConstant ID2String Int2ID I; for each IDName in car OrderedIDList!* do DataPrintFullWord CompileConstant ID2String IDName; MaxSymbol := MaxSymbol - 1; for I := NextIDNumber!* step 1 until MaxSymbol do DataPrintFullWord(I + 1); DataPrintFullWord 0 >>; lisp procedure InitializeSymVal(); << DataPrintGlobalLabel FindGlobalLabel 'SymVal; for I := 0 step 1 until 128 do InitSymVal1 Int2ID I; for each X in car OrderedIDList!* do InitSymVal1 X >>; lisp procedure InitSymVal1 X; begin scalar Val; return DataPrintFullWord(if (Val := get(X, 'InitialValue)) then CompileConstant Val else if FlagP(X, 'NilInitialValue) then NilNumber!* else list('MkItem, get('Unbound, 'WConst), FindIDNumber X)); end; lisp procedure InitializeSymFnc(); << DataPrintGlobalLabel FindGlobalLabel 'SymFnc; for I := 0 step 1 until 128 do InitSymFnc1 Int2ID I; for each X in car OrderedIDList!* do InitSymFnc1 X >>; lisp procedure InitSymFnc1 X; begin scalar EP; EP := get(X, 'EntryPoint); if null EP then DataPrintUndefinedFunctionCell() else DataPrintDefinedFunctionCell EP; end; lisp procedure ASMOutLap U; begin scalar LocalLabels!*, OldOut; U := Pass1Lap U; % Expand cmacros, quoted expressions CodeBlockHeader(); OldOut := WRS CodeOut!*; for each X in U do ASMOutLap1 X; WRS OldOut; CodeBlockTrailer(); end; lisp procedure ASMOutLap1 X; begin scalar Fn; return if StringP X then PrintLabel X else if atom X then PrintLabel FindLocalLabel X else if (Fn := get(car X, 'ASMPseudoOp)) then Apply(Fn, list X) else % instruction output form is: % "space" <opcode> [ "space" <operand> { "comma" <operand> } ] "newline" << Prin2 '! ; % Space PrintOpcode car X; X := cdr X; if not null X then << Prin2 '! ; % SPACE PrintOperand car X; for each U in cdr X do << Prin2 '!,; % COMMA PrintOperand U >> >>; Prin2 !$EOL!$ >>; % NEWLINE end; put('!*Entry, 'ASMPseudoOp, 'ASMPrintEntry); lisp procedure ASMPrintEntry X; begin scalar Y; PrintComment X; X := cadr X; Y := FindEntryPoint X; if not FlagP(X, 'InternalFunction) then FindIDNumber X; if X eq MainEntryPointName!* then << !*MainFound := T; SpecialActionForMainEntryPoint() >> else CodeDeclareExportedUse Y; end; Procedure CodeDeclareExportedUse Y; if !*DeclareBeforeUse then << CodeDeclareExported Y; PrintLabel Y >> else << PrintLabel Y; CodeDeclareExported Y >>; lisp procedure FindEntryPoint X; begin scalar E; return if (E := get(X, 'EntryPoint)) then E else if ASMSymbolP X and not get(X, 'ASMSymbol) then << put(X, 'EntryPoint, X); X >> else << E := StringGenSym(); put(X, 'EntryPoint, E); E >>; end; lisp procedure ASMPseudoPrintFloat X; PrintF(DoubleFloatFormat!*, cadr X); put('Float, 'ASMPseudoOp, 'ASMPseudoPrintFloat); lisp procedure ASMPseudoPrintFullWord X; for each Y in cdr X do PrintFullWord Y; put('FullWord, 'ASMPseudoOp, 'ASMPseudoPrintFullWord); lisp procedure ASMPseudoPrintByte X; PrintByteList cdr X; put('Byte, 'ASMPseudoOp, 'ASMPseudoPrintByte); lisp procedure ASMPseudoPrintHalfWord X; PrintHalfWordList cdr X; put('HalfWord, 'ASMPseudoOp, 'ASMPseudoPrintHalfWord); lisp procedure ASMPseudoPrintString X; PrintString cadr X; put('String, 'ASMPseudoOp, 'ASMPseudoPrintString); lisp procedure PrintOperand X; if StringP X then Prin2 X else if NumberP X then PrintNumericOperand X else if IDP X then Prin2 FindLabel X else begin scalar Hd, Fn; Hd := car X; if (Fn := get(Hd, 'OperandPrintFunction)) then Apply(Fn, list X) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintOperand Apply(cdr Fn, list X) else if (Fn := WConstEvaluable X) then PrintOperand Fn else PrintExpression X; end; put('REG, 'OperandPrintFunction, 'PrintRegister); lisp procedure PrintRegister X; begin scalar Nam; X := cadr X; if StringP X then Prin2 X else if NumberP X then Prin2 GetV(NumericRegisterNames!*, X) else if Nam := RegisterNameP X then Prin2 Nam else << ErrorPrintF("***** Unknown register %r", X); Prin2 X >>; end; lisp procedure RegisterNameP X; get(X, 'RegisterName); lisp procedure ASMEntry X; PrintExpression list('plus2, 'SymFnc, list('times2, AddressingUnitsPerFunctionCell, list('IDLoc, cadr X))); put('Entry, 'OperandPrintFunction, 'ASMEntry); lisp procedure ASMInternalEntry X; Prin2 FindEntryPoint cadr X; put('InternalEntry, 'OperandPrintFunction, 'ASMInternalEntry); put('InternalEntry, 'ASMExpressionFunction, 'ASMInternalEntry); macro procedure ExtraReg U; list('plus2, '(WArray ArgumentBlock), (cadr U - (LastActualReg!& + 1)) * AddressingUnitsPerItem); lisp procedure ASMSyslispVarsPrint X; Prin2 FindGlobalLabel cadr X; DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'OperandPrintFunction); DefList('((WVar ASMSyslispVarsPrint) (WArray ASMSyslispVarsPrint) (WString ASMSyslispVarsPrint)), 'ASMExpressionFunction); lisp procedure ASMPrintValueCell X; PrintExpression list('plus2, 'SymVal, list('times, AddressingUnitsPerItem, list('IDLoc, cadr X))); DefList('((fluid ASMPrintValueCell) (!$fluid ASMPrintValueCell) (global ASMPrintValueCell) (!$global ASMPrintValueCell)), 'OperandPrintFunction); % Redefinition of WDeclare for output to assembler file % if either UpperBound or Initializer are NIL, they are considered to be % unspecified. fexpr procedure WDeclare U; for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X); flag('(WDeclare), 'IGNORE); lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer); if Typ = 'WCONST then if Scope = 'EXTERNAL and not get(Name, 'WCONST) then ErrorPrintF("*** A value has not been defined for WConst %r", Name) else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); put(Name, 'WCONST, WConstReform Initializer) >> else << put(Name, Typ, Name); if Scope = 'EXTERNAL then << put(Name, 'SCOPE, 'EXTERNAL); if not RegisterNameP Name then % kludge to avoid declaring << Name := LookupOrAddASMSymbol Name; DataDeclareExternal Name; % registers as variables CodeDeclareExternal Name >> >> else << put(Name, 'SCOPE, if Scope = 'EXPORTED then 'EXTERNAL else Scope); Name := LookupOrAddASMSymbol Name; if !*DeclareBeforeUse then DataDeclareExported Name; DataInit(Name, Typ, UpperBound, Initializer); if not !*DeclareBeforeUse then DataDeclareExported Name; CodeDeclareExternal Name >> >>; lisp procedure DataInit(ASMSymbol, Typ, UpperBound, Initializer); << DataAlignFullWord(); if Typ = 'WVAR then << if UpperBound then ErrorPrintF "*** An UpperBound may not be specified for a WVar"; Initializer := if Initializer then WConstReform Initializer else 0; DataPrintVar(ASMSymbol, Initializer) >> else << if UpperBound and Initializer then ErrorPrintF "*** Can't have both UpperBound and initializer" else if not (UpperBound or Initializer) then ErrorPrintF "*** Must have either UpperBound or initializer" else if UpperBound then DataPrintBlock(ASMSymbol, WConstReform UpperBound, Typ) else << Initializer := if StringP Initializer then Initializer else WConstReformLis Initializer; DataPrintList(ASMSymbol, Initializer, Typ) >> >> >>; lisp procedure WConstReform U; begin scalar X; return if FixP U or StringP U then U else if IDP U then if get(U, 'WARRAY) or get(U, 'WSTRING) then U else if get(U,'WVAR) then list('GETMEM,U) else if (X := get(U, 'WCONST)) then X else ErrorPrintF("*** Unknown symbol %r in WConstReform", U) else if PairP U then if (X := get(car U, 'WConstReformPseudo)) then Apply(X, list U) else if (X := get(car U, 'DOFN)) then X . WConstReformLis cdr U else if MacroP car U then WConstReform Apply(cdr GetD car U, list U) else car U . WConstReformLis cdr U else ErrorPrintF("*** Illegal expression %r in WConstReform", U); end; lisp procedure WConstReformIdent U; U; put('InternalEntry, 'WConstReformPseudo, 'WConstReformIdent); lisp procedure WConstReformQuote U; CompileConstant cadr U; put('QUOTE, 'WConstReformPseudo, 'WConstReformQuote); lisp procedure WConstReformLis U; for each X in U collect WConstReform X; lisp procedure WConstReformLoc U; %. To handle &Foo[23] << U := WConstReform cadr U; if car U neq 'GETMEM then ErrorPrintF("*** Illegal constant addressing expression %r", list('LOC, U)) else cadr U >>; put('LOC, 'WConstReformPseudo, 'WConstReformLoc); lisp procedure WConstReformIDLoc U; FindIDNumber cadr U; put('IDLoc, 'WConstReformPseudo, 'WConstReformIDLoc); lisp procedure LookupOrAddASMSymbol U; begin scalar X; if not (X := get(U, 'ASMSymbol)) then X := AddASMSymbol U; return X; end; lisp procedure AddASMSymbol U; begin scalar X; X := if ASMSymbolP U and not get(U, 'EntryPoint) then U else StringGensym(); put(U, 'ASMSymbol, X); return X; end; lisp procedure DataPrintVar(Name, Init); begin scalar OldOut; DataPrintLabel Name; OldOut := WRS DataOut!*; PrintFullWord Init; WRS OldOut; end; lisp procedure DataPrintBlock(Name, Siz, Typ); << if Typ = 'WSTRING then Siz := list('quotient, list('plus2, Siz, CharactersPerWord + 1), CharactersPerWord) else Siz := list('plus2, Siz, 1); DataReserveZeroBlock(Name, Siz) >>; lisp procedure DataPrintList(Nam, Init, Typ); begin scalar OldOut; DataPrintLabel Nam; OldOut := WRS DataOut!*; if Typ = 'WSTRING then if StringP Init then << PrintFullWord Size Init; PrintString Init >> else << PrintFullWord(Length Init - 1); PrintByteList Append(Init, '(0)) >> else if StringP Init then begin scalar S; S := Size Init; for I := 0 step 1 until S do PrintFullWord Indx(Init, I); end else for each X in Init do PrintFullWord X; WRS OldOut; end; lisp procedure DataPrintGlobalLabel X; << if !*DeclareBeforeUse then DataDeclareExported X; DataPrintLabel X; if not !*DeclareBeforeUse then DataDeclareExported X; CodeDeclareExternal X >>; lisp procedure DataDeclareExternal X; if not (X member DataExternals!* or X member DataExporteds!*) then << DataExternals!* := X . DataExternals!*; DataPrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExternal X; if not (X member CodeExternals!* or X member CodeExporteds!*) then << CodeExternals!* := X . CodeExternals!*; CodePrintF(ExternalDeclarationFormat!*, X, X) >>; lisp procedure DataDeclareExported X; << if X member DataExternals!* or X member DataExporteds!* then ErrorPrintF("***** %r multiply defined", X); DataExporteds!* := X . DataExporteds!*; DataPrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure CodeDeclareExported X; << if X member CodeExternals!* or X member CodeExporteds!* then ErrorPrintF("***** %r multiply defined", X); CodeExporteds!* := X . CodeExporteds!*; CodePrintF(ExportedDeclarationFormat!*, X, X) >>; lisp procedure PrintLabel X; PrintF(LabelFormat!*, X,X); lisp procedure DataPrintLabel X; DataPrintF(LabelFormat!*, X,X); lisp procedure CodePrintLabel X; CodePrintF(LabelFormat!*, X,X); lisp procedure PrintComment X; PrintF(CommentFormat!*, X); PrintExpressionForm!* := list('PrintExpression, MkQuote NIL); PrintExpressionFormPointer!* := cdadr PrintExpressionForm!*; % Save some consing % instead of list('PrintExpression, MkQuote X), reuse the same list structure lisp procedure PrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); PrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); DataPrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure CodePrintFullWord X; << RplacA(PrintExpressionFormPointer!*, X); CodePrintF(FullWordFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveZeroBlock(Nam, X); << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveZeroBlockFormat!*, Nam, PrintExpressionForm!*) >>; lisp procedure DataReserveBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerItem, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataReserveFunctionCellBlock X; << RplacA(PrintExpressionFormPointer!*, list('Times2, AddressingUnitsPerFunctionCell, X)); DataPrintF(ReserveDataBlockFormat!*, PrintExpressionForm!*) >>; lisp procedure DataPrintUndefinedFunctionCell(); begin scalar OldOut; OldOut := WRS DataOut!*; for each X in UndefinedFunctionCellInstructions!* do ASMOutLap1 X; WRS OldOut; end; lisp procedure DataPrintDefinedFunctionCell X; <<DataDeclareExternal X; DataPrintF(DefinedFunctionCellFormat!*, X, X)>>; % in case it's needed twice lisp procedure DataPrintByteList X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintByteList X; WRS OldOut; end; lisp procedure DataPrintExpression X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintExpression X; WRS OldOut; end; lisp procedure CodePrintExpression X; begin scalar OldOut; OldOut := WRS CodeOut!*; PrintExpression X; WRS OldOut; end; ExpressionCount!* := -1; lisp procedure PrintExpression X; (lambda(ExpressionCount!*); begin scalar Hd, Tl, Fn; X := ResolveWConstExpression X; if NumberP X or StringP X then Prin2 X else if IDP X then Prin2 FindLabel X else if atom X then << ErrorPrintF("***** Oddity in expression %r", X); Prin2 X >> else << Hd := car X; Tl := cdr X; if (Fn := get(Hd, 'BinaryASMOp)) then << if ExpressionCount!* > 0 then Prin2 ASMOpenParen!*; PrintExpression car Tl; Prin2 Fn; PrintExpression cadr Tl; if ExpressionCount!* > 0 then Prin2 ASMCloseParen!* >> else if (Fn := get(Hd, 'UnaryASMOp)) then << Prin2 Fn; PrintExpression car Tl >> else if (Fn := get(Hd, 'ASMExpressionFormat)) then Apply('PrintF, Fn . for each Y in Tl collect list('PrintExpression, MkQuote Y)) else if (Fn := GetD Hd) and car Fn = 'MACRO then PrintExpression Apply(cdr Fn, list X) else if (Fn := get(Hd, 'ASMExpressionFunction)) then Apply(Fn, list X) else << ErrorPrintF("***** Unknown expression %r", X); PrintF("*** Expression error %r ***", X) >> >>; end)(ExpressionCount!* + 1); lisp procedure ASMPrintWConst U; PrintExpression cadr U; put('WConst, 'ASMExpressionFunction, 'ASMPrintWConst); DefList('((Plus2 !+) (WPlus2 !+) (Difference !-) (WDifference !-) (Times2 !*) (WTimes2 !*) (Quotient !/) (WQuotient !/)), 'BinaryASMOp); DefList('((Minus !-) (WMinus !-)), 'UnaryASMOp); lisp procedure CompileConstant X; << X := BuildConstant X; if null cdr X then car X else << If !*DeclareBeforeUse then CodeDeclareExported cadr X; ASMOutLap cdr X; DataDeclareExternal cadr X; If Not !*DeclareBeforeUse then CodeDeclareExported cadr X; car X >> >>; CommentOutCode << lisp procedure CompileHeapData X; begin scalar Y; X := BuildConstant X; return if null cdr X then car X else << Y := WRS DataOut!*; for each Z in cdr X do ASMOutLap1 Z; DataDeclareExported cadr X; WRS Y; car X >>; end; >>; lisp procedure DataPrintString X; begin scalar OldOut; OldOut := WRS DataOut!*; PrintString X; WRS OldOut; end; lisp procedure FindLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else if (Y := get(X, 'ASMSymbol)) then Y else if (Y := get(X, 'WConst)) then Y else FindLocalLabel X; end; lisp procedure FindLocalLabel X; begin scalar Y; return if (Y := Atsoc(X, LocalLabels!*)) then cdr Y else << LocalLabels!* := (X . (Y := StringGensym())) . LocalLabels!*; Y >>; end; lisp procedure FindGlobalLabel X; get(X, 'ASMSymbol) or ErrorPrintF("***** Undefined symbol %r", X); lisp procedure CodePrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS CodeOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; lisp procedure DataPrintF(Fmt, A1, A2, A3, A4); begin scalar OldOut; OldOut := WRS DataOut!*; PrintF(Fmt, A1, A2, A3, A4); WRS OldOut; end; % Kludge of the year, just to avoid having IDLOC defined during compilation CompileTime fluid '(MACRO); MACRO := 'MACRO; PutD('IDLoc, MACRO, function lambda X; FindIDNumber cadr X); END; |
Added psl-1983/comp/opencodedfunctions.lst version [8b44d31d19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | These functions where tagged as open coded in the Dec20 PSL. ADDRESSAPPLY0 ADDRESSAPPLY1 ADDRESSAPPLY2 ADDRESSAPPLY3 ADDRESSAPPLY4 CODEAPPLY0 CODEAPPLY1 CODEAPPLY2 CODEAPPLY3 CODEAPPLY4 IDAPPLY0 IDAPPLY1 IDAPPLY2 IDAPPLY3 IDAPPLY4 % These represent the interface tothe users float capability. !*FEQ !*FGREATERP !*WFIX !*WFLOAT !*FDIFFERENCE !*FASSIGN !*FLESSP !*FPLUS2 !*FQUOTIENT !*FTIMES2 %These are for standard division. WREMAINDER WQUOTIENT % These arethe primitives for dealing with the machine words of various sizes. BYTE HALFWORD BITTABLE PUTBYTE PUTHALFWORD PUTBITTABLE |
Added psl-1983/comp/p-lambind.sl version [dea1bda62b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-LAMBIND.SL - Portable cmacro definitions *LAMBIND, *PROGBIND and *FREERSTR % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % (compiletime (load useful)) (imports '(syslisp)) % requires SYSLISP for AddrUnitsPerItem (de *lambind (regs fluids) (prog (n firstreg) (setq n 0) (setq regs (rest regs)) % remove REGISTERS at the front (setq fluids (rest fluids)) % remove NONLOCALVARS at the front (setq fluids % convert fluids list into vector (list2vector (foreach x in fluids collect (second x)))) (setq firstreg (first regs)) (setq regs (rest regs)) (return (if (null regs) % only one to bind `((*move ,firstreg (reg 2)) (*move `,',(getv fluids 0) (reg 1)) (*call lbind1)) `((*move ,firstreg (memory (fluid LambindArgs*) (wconst 0))) (*move (fluid LambindArgs*) ,firstreg) ,@(foreach x in regs collect (progn (setq n (add1 n)) `(*move ,x (memory ,firstreg (wconst (wtimes2 (wconst AddressingUnitsPerItem) (wconst ,n))))))) (*move `,',fluids (reg 1)) (*call lambind)))))) (defcmacro *lambind) (de *progbind (fluids) (if (null (rest (rest fluids))) `((*move `,',(second (first (rest fluids))) (reg 1)) (*call pbind1)) `((*move `,',(list2vector (foreach x in (rest fluids) collect (second x))) (reg 1)) (*call progbind)))) (defcmacro *progbind) (de *freerstr (fluids) `((*move `,',(length (rest fluids)) (reg 1)) (*call UnBindN))) (defcmacro *freerstr) (setq *unsafebinder t) % has to save registers across calls |
Added psl-1983/comp/pass-1-lap.build version [66091f31c0].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | CompileTime << on EolInStringOK; macro procedure !* U; NIL; load Syslisp; >>; in "anyreg-cmacro.sl"$ in "pass-1-lap.sl"$ in "common-cmacros.sl"$ in "common-predicates.sl"$ |
Added psl-1983/comp/pass-1-lap.sl version [7b2f061946].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (* "% PASS-1-LAP.SL - Expand c-macros and allocate quoted expressions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 December 1981 % Copyright (c) 1981 University of Utah % % Added MCprint and InstructionPrint - MLG % <PSL.COMP>PASS-1-LAP.SL.17, 4-Aug-82 00:35:54, Edit by BENSON % Added bignum constants; won't work for cross-compilation, though %") (* "Pass1Lap takes a list of c-macros and instructions, and attempts to simplify them whenever possible. C-macros are expanded by APPLY(CAR X, CDR X), which will return another instruction list to be processed recursively by Pass1Lap. Quoted expressions are allocated at the end of the code, in the following way: In an instruction or c-macro (.... (QUOTE (A B C)) ...) the following is tacked onto the end of the constructed code list: L2 (MKITEM ID A) (MKITEM PAIR L3) L3 (MKITEM ID B) (MKITEM PAIR L4) L4 (MKITEM ID C) (MKITEM ID NIL) If *ImmediateQuote is NIL, the quoted reference becomes: (... L1 ...) ... L1 (fullword (MKITEM PAIR L2)) Otherwise, it becomes: (... (immediate (MKITEM PAIR L2)) ...)") (fluid '(!*ImmediateQuote !*PCMAC !*PrintedOneCMacro Pass1CodeList Pass1ConstantList Pass1ConstantContentsList Pass1AddedCode EntryPoints!* AddressingUnitsPerItem LastActualReg!&)) (CompileTime (flag '(Pass1Code OneLapPass1 AddInstruction ExpandPseudoOps ExpandOnePseudoOp GenerateLabel GenerateCodeLabel AddCodeLabel AddCode ExpandQuote1 ExpandImmediateQuote ExpandItem ExpandNonImmediateQuote SaveConstant SaveContents AppendConstants AppendOneConstant AppendItem AddFullWord AppendContents MakeMkItem) 'InternalFunction)) (CompileTime (load fast-vector)) (de Pass1Lap (InstructionList) (prog (Pass1CodeList Pass1ConstantList Pass1ConstantContentsList EntryPoints!* Pass1AddedCode) (setq Pass1CodeList (cons NIL NIL)) (* "Init a TCONC pointer") (setq Pass1ConstantContentsList (cons NIL NIL)) (Pass1Code InstructionList) (* "Expand macros") (Pass1Code Pass1AddedCode) (AppendConstants) (* "Tack the constants on the end") (return (car Pass1CodeList)))) (* "BuildConstant takes an S-expression and returns the LAP version of it.") (* "The car is the expanded item, cdr is the contents") (de BuildConstant (Expression) (prog (Pass1CodeList Pass1ConstantList Pass1ConstantContentsList ExpandedExpression) (setq Pass1CodeList (cons NIL NIL)) (* "Init a TCONC pointer") (setq Pass1ConstantContentsList (cons NIL NIL)) (setq ExpandedExpression (ExpandItem Expression)) (* "Expand the item") (AppendConstants) (* "Tack the contents on the end") (return (cons ExpandedExpression (car Pass1CodeList))))) (de Pass1Code (InstructionList) (ForEach Instruction in InstructionList do (OneLapPass1 Instruction))) (de OneLapPass1 (Instruction) (cond ((atom Instruction) (AddCodeLabel Instruction)) ((eq (car Instruction) '!*ENTRY) (progn (* "ENTRY directives are passed unchanged") (cond ((and (not (or (FlagP (second Instruction) 'InternalFunction) (equal (second Instruction) '**fasl**initcode**))) (null (car Pass1CodeList))) (* "Header word says how many arguments to expect") (AddCode (list 'FULLWORD (fourth Instruction))))) (setq EntryPoints!* (cons (second Instruction) EntryPoints!*)) (cond (!*PCMAC (MCPrint Instruction))) (AddCode Instruction))) ((FlagP (car Instruction) 'MC) (progn (cond ((and !*PCMAC (not !*PrintedOneCMacro)) (MCPrint Instruction))) ((lambda (!*PrintedOneCMacro) (Pass1Code (Apply (car Instruction) (cdr Instruction)))) T))) (t (progn (cond (!*PCMAC (InstructionPrint Instruction))) (AddInstruction Instruction))))) (de MCPrint(x) (print x)) (de InstructionPrint(x) (PrintF " %p%n" x)) (de AddInstruction (Instruction) (AddCode (ExpandPseudoOps Instruction))) (de ExpandPseudoOps (X) (cond ((atom X) X) (t (cons (ExpandOnePseudoOp (car X)) (ExpandPseudoOps (cdr X)))))) (de ExpandOnePseudoOp (X) (prog (PseudoOpFunction) (return (cond ((atom X) X) ((setq PseudoOpFunction (get (car X) 'Pass1PseudoOp)) (ExpandOnePseudoOp (Apply PseudoOpFunction (list X)))) ((setq PseudoOpFunction (WConstEvaluable X)) PseudoOpFunction) (t (cons (car X) (ExpandPseudoOps (cdr X)))))))) (de PassOneUnImmediate (X) (progn (setq X (cadr X)) (cond ((EqCar X 'Immediate) (cadr X)) (t X)))) (put 'UnImmediate 'Pass1PseudoOp 'PassOneUnImmediate) (de PassOneLabel (U) (cadr U)) (put 'Label 'Pass1PseudoOp 'PassOneLabel) (de PassOneUnDeferred (X) (progn (setq X (cadr X)) (cond ((EqCar X 'Deferred) (cadr X)) (t X)))) (put 'UnDeferred 'Pass1PseudoOp 'PassOneUnDeferred) (* "Removed because ExtraReg has to be processed differently by resident LAP" (de PassOneExtraReg (X) (progn (setq X (cadr X)) (list 'plus2 '(WArray ArgumentBlock) (times (difference (Add1 LastActualReg!&) X) AddressingUnitsPerItem)))) (put 'ExtraReg 'Pass1PseudoOp 'PassOneExtraReg) ) (de GenerateCodeLabel () (prog (NewLabel) (setq NewLabel (GenerateLabel)) (AddCodeLabel NewLabel) (return NewLabel))) (de GenerateLabel () (StringGenSym)) (de AddCodeLabel (Label) (AddCode Label)) (de AddCode (C) (TConc Pass1CodeList C)) (de ExpandLit (U) (prog (L) (cond ((setq L (FindPreviousLit (cdr U))) (return L))) (setq L (GenerateLabel)) (setq Pass1AddedCode (NConc Pass1AddedCode (cons L (ForEach X in (cdr U) collect X)))) (return L))) (de FindPreviousLit (U) (cond ((not (null (rest U))) NIL) (t (prog (L) (setq L Pass1AddedCode) (cond ((null L) (return NIL))) (setq U (first U)) loop (cond ((null (rest L)) (return NIL))) (cond ((equal U (second L)) (return (cond ((atom (first L)) (first L)) (t (prog (B) (setq L (rest L)) (rplacd L (cons (first L) (rest L))) (rplaca L (setq B (GenerateLabel))) (return B))))))) (setq L (rest L)) (go loop))))) (put 'lit 'Pass1PseudoOp 'ExpandLit) (flag '(lit) 'TerminalOperand) (de ExpandQuote (QuotedExpression) (ExpandQuote1 (cadr QuotedExpression))) (put 'Quote 'Pass1PseudoOp 'ExpandQuote) (de ExpandQuote1 (Expression) (cond (!*ImmediateQuote (ExpandImmediateQuote Expression)) (t (ExpandNonImmediateQuote Expression)))) (de ExpandImmediateQuote (Expression) (list 'IMMEDIATE (ExpandItem Expression))) (de ExpandItem (Expression) (prog (LabelOfContents) (return (cond ((InumP Expression) Expression) ((IDP Expression) (MakeMkItem (TagNumber Expression) (list 'IDLoc Expression))) ((CodeP Expression) (MakeMkItem (TagNumber Expression) Expression)) (t (progn (setq LabelOfContents (SaveContents Expression)) (MakeMkItem (TagNumber Expression) LabelOfContents))))))) (de ExpandNonImmediateQuote (Expression) (SaveConstant Expression)) (de SaveConstant (Expression) (prog (TableEntry) (return (cond ((setq TableEntry (Assoc Expression Pass1ConstantList)) (cdr TableEntry)) (t (progn (setq TableEntry (GenerateLabel)) (setq Pass1ConstantList (cons (cons Expression TableEntry) Pass1ConstantList)) TableEntry)))))) (de SaveContents (Expression) (prog (TableEntry) (return (cond ((setq TableEntry (Assoc Expression (car Pass1ConstantContentsList))) (cdr TableEntry)) (t (progn (setq TableEntry (GenerateLabel)) (TConc Pass1ConstantContentsList (cons Expression TableEntry)) TableEntry)))))) (de AppendConstants () (prog (TempCodeList) (cond ((not !*ImmediateQuote) (ForEach TableEntry in Pass1ConstantList do (AppendOneConstant TableEntry)))) (setq TempCodeList Pass1CodeList) (setq Pass1CodeList (cons NIL NIL)) (ForEach TableEntry in (car Pass1ConstantContentsList) do (AppendContents TableEntry)) (* "The contents go on the begininning of the list") (LConc Pass1CodeList (car TempCodeList)))) (de AppendOneConstant (ExpressionLabelPair) (progn (AddCodeLabel (cdr ExpressionLabelPair)) (AppendItem (car ExpressionLabelPair)))) (de AppendItem (Expression) (AddFullWord (ExpandItem Expression))) (de AddFullWord (Expression) (AddCode (list 'FULLWORD Expression))) (de AppendContents (ExpressionLabelPair) (prog (Expression UpperBound I) (AddCodeLabel (cdr ExpressionLabelPair)) (setq Expression (car ExpressionLabelPair)) (cond ((PairP Expression) (progn (AppendItem (car Expression)) (AppendItem (cdr Expression)))) ((StringP Expression) (progn (AddFullWord (Size Expression)) (AddCode (list 'STRING Expression)))) ((VectorP Expression) (progn (setq UpperBound (ISizeV Expression)) (AddFullWord UpperBound) (setq I 0) (while (ILEQ I UpperBound) (progn (AppendItem (IGetV Expression I)) (setq I (IAdd1 I)))))) ((BigP Expression) (progn (setq UpperBound (ISizeV Expression)) (AddFullWord UpperBound) (setq I 0) (while (ILEQ I UpperBound) (progn (AppendItem (IGetV Expression I)) (setq I (IAdd1 I)))))) ((FixP Expression) (progn (AddFullWord 0) (* "Header of full word fixnum") (AddFullWord Expression))) ((FloatP Expression) (progn (AddFullWord 1) (* "Header of float") (AddCode (list 'FLOAT Expression))))))) (de MakeMkItem (TagPart InfPart) (list 'MKITEM TagPart InfPart)) (de InumP (N) (IntP N)) (* "Must be changed for cross-compilation") (de TagNumber (Expression) (MkINT (Tag Expression))) (* "Must be redefined for cross-compilation") |
Added psl-1983/comp/readme version [ba91a5cacf].
> > | 1 2 | This directory contains only sources for the Portable Standard LISP compiler. |
Added psl-1983/comp/syslisp-syntax.red version [5ee5e62cd5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSLISP-SYNTAX.RED - SMacros and redefinition of arithmetic operators % and other syslisp syntax % % Author: Eric Benson and M. L. griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 July 1981 % Copyright (c) 1981 University of Utah % fluid '(!*SYSLISP); % <PSL.COMP>SYSLISP-SYNTAX.RED.3, 5-May-82 11:33:48, Edit by BENSON % Wrapped if GetD 'BEGIN1 around parser calls % New WDECLARE constructs % Modify ***** [] vector syntax for PREFIX and INFIX forms % At lower prec SYMBOLIC PROCEDURE ParseLVEC(VNAME,VEXPR); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,VNAME,VEXPR)>> ELSE PARERR("Missing ] in index expression "); % Use normal parsing, then CLEAN SYMBOLIC PROCEDURE ParseWDEC0(FN,DMODES,DLIST); BEGIN SCALAR PLIST; IF EQCAR(DLIST,'!*COMMA!*) THEN DLIST:=REVERSE CDR DLIST ELSE DLIST:=LIST DLIST; PLIST:=FOR EACH DEC IN DLIST COLLECT ParseWDEC1(FN,DEC); RETURN ('WDECLARE . DMODES . FN . REVERSE PLIST); END; SYMBOLIC PROCEDURE ParseWDEC1(FN,DEC); % Process each WDEC to check legal modes if EqCar(DEC,'EQUAL) THEN AConc(ParseWDEC2(FN,CADR DEC), ParseWDEC3(FN,CADDR DEC)) ELSE AConc(ParseWDEC2(FN,DEC), NIL); SYMBOLIC PROCEDURE ParseWDEC2(FN,X); % Remove INDXs from LHS of = IF IDP X THEN list(X, NIL) ELSE IF EQCAR(X,'INDX) THEN LIST(CADR X,CADDR X) ELSE PARERR "Only [] allowed on LHS of WDECLARATION"; SYMBOLIC PROCEDURE ParseWDEC3(FN,X); % Remove INDX's from RHS of = IF IDP X THEN X ELSE IF EQCAR(X,'INDX) THEN (IF CADR X EQ '!*PREFIXVECT!* THEN REMCOM(CADDR X) ELSE PARERR("Only [...] is legal INIT in WDECLARE")) ELSE X; if not FUnBoundP 'BEGIN1 then << % kludge #+Rlisp DEFINEBOP('!*LVEC!*,121,5,ParseLVEC); DEFINEROP('!*LVEC!*,5,ParseLVEC('!*PREFIXVECT!*,X)); DEFINEBOP('!*RVEC!*,4,5); DEFINEROP('WCONST,1,ParseWDEC0('WCONST,'DEFAULT,X)); DEFINEROP('WVAR,1,ParseWDEC0('WVAR,'DEFAULT,X)); DEFINEROP('WARRAY,1,ParseWDEC0('WARRAY,'DEFAULT,X)); DEFINEROP('WSTRING,1,ParseWDEC0('WSTRING,'DEFAULT,X)); DEFINEBOP('WCONST,1,1,ParseWDEC0('WCONST,X,Y)); DEFINEBOP('WVAR,1,1,ParseWDEC0('WVAR,X,Y)); DEFINEBOP('WARRAY,1,1,ParseWDEC0('WARRAY,X,Y)); DEFINEBOP('WSTRING,1,1,ParseWDEC0('WSTRING,X,Y)); % Operators @ for GetMem, & for Loc put('!@, 'NewNam, 'GetMem); put('!&, 'NewNam, 'Loc); >>; % SysName hooks for REFORM REMFLAG('(REFORM),'LOSE); SYMBOLIC PROCEDURE REFORM U; IF ATOM U OR CAR U MEMQ '(QUOTE WCONST) THEN U ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U ELSE IF CAR U EQ 'PROG THEN PROGN(RPLCDX(CDR U,REFORMLIS CDDR U),U) ELSE IF CAR U EQ 'LAMBDA THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U) ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U THEN BEGIN SCALAR X; IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO)) THEN RETURN LIST('FUNCTION,X) ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U THEN REDERR "MACRO USED AS FUNCTION" ELSE RETURN U END % ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM)) ELSE IF ATOM CAR U THEN BEGIN SCALAR X,Y,FN; FN := CAR U; IF (Y := GETD FN) AND CAR Y EQ 'MACRO AND EXPANDQ FN THEN RETURN REFORM APPLY(CDR Y,LIST U); X := REFORMLIS CDR U; IF NULL IDP FN THEN RETURN(FN . X); IF !*SYSLISP AND (Y:=GET(FN,'SYSNAME)) THEN <<FN:=Y;U:=FN.CDR U>>; IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'NMACRO)) THEN RETURN APPLY(Y,IF FLAGP(FN,'NOSPREAD) THEN LIST X ELSE X) ELSE IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'SMACRO)) THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y) %we could use an atom SUBLIS here (eg, SUBLA); ELSE RETURN PROGN(RPLCDX(U,X),U) END ELSE REFORM CAR U . REFORMLIS CDR U; RemFlag('(Plus Times), 'NARY)$ DefList('((Plus WPlus2) (Plus2 WPlus2) (Minus WMinus) (Difference WDifference) (Times WTimes2) (Times2 WTimes2) (Quotient WQuotient) (Remainder WRemainder) (Mod WRemainder) (Land WAnd) (Lor WOr) (Lxor WXor) (Lnot WNot) (LShift WShift) (LSH WShift)), 'SysName); DefList('((Neq WNeq) (Equal WEq) (Eqn WEq) (Eq WEq) (Greaterp WGreaterp) (Lessp WLessp) (Geq WGeq) (Leq WLeq) (Getv WGetv) (Indx WGetv) (Putv WPutv) (SetIndx WPutv)), 'SysName); % modification to arithmetic FOR loop for SysLisp LISP PROCEDURE MKSYSFOR U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,LAB2,RESULT,TAIL,VAR,X; VAR := second second U; INCR := cddr second U; if FixP third Incr or WConstEvaluable third Incr then return ConstantIncrementFor U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := LIST('WDIFFERENCE,first INCR,VAR); IF second INCR NEQ 1 THEN X := LIST('WTIMES2,second INCR,X); IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); LAB2 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST('WLESSP,X,0),LIST('GO,LAB2))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,second INCR)) . LIST('GO,LAB1) . LAB2 . TAIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE ConstantIncrementFor U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,RESULT,VAR,X, StepValue, Limit; VAR := second second U; INCR := cddr second U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; StepValue := if FixP second Incr then second Incr else WConstEvaluable second Incr; Limit := first Incr; IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST(if MinusP StepValue then 'WLessP else 'WGreaterP, Var, Limit),'(return 0))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,StepValue)) . LIST('GO,LAB1) . NIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE MKFOR1 U; IF !*SYSLISP THEN MKSYSFOR U ELSE MKLISPFOR U; PUTD('MKLISPFOR,'EXPR,CDR GETD 'FOR); % grab old FOR definition macro procedure For U; MkFor1 U; % redefine FOR END; |
Added psl-1983/comp/syslisp.build version [ea4009e4f1].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | CompileTime << load if!-system, syslisp; % Assume still there, else load source off UserMode; >>; in "syslisp-syntax.red"$ in "wdeclare.red"$ CompileTime if_system(PDP10, << in "P20C:DEC20-DATA-MACHINE.RED"$ >>)$ CompileTime if_system(VAX, << in "vax/vax-data-machine.red"$ >>)$ in "data-machine.red"$ RemProp('Syslisp, 'SimpFg); % so ON SYSLISP doesn't try to load |
Added psl-1983/comp/tags.red version [8637527903].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | CompileTime << lisp procedure DeclareTagRange(NameList, StartingValue, Increment); begin scalar Result; Result := list 'progn; while NameList do << Result := list('put, MkQuote car NameList, '(quote WConst), StartingValue) . Result; StartingValue := StartingValue + Increment; NameList := cdr NameList >>; return ReversIP Result; end; macro procedure LowTags U; DeclareTagRange(cdr U, 0, 1); macro procedure HighTags U; DeclareTagRange(cdr U, if_system(MC68000, 16#FF, 31), -1); >>; LowTags(PosInt, FixN, BigN, FltN, Str, Bytes, HalfWords, Wrds, Vect, Pair); put('Code, 'WConst, 15); HighTags(NegInt, ID, Unbound, BtrTag, Forward, HVect, HWrds, HHalfWords, HBytes); |
Added psl-1983/comp/time.stamp version [98d88f33b3].
> | 1 | 13-Aug-82 15:59:07 |
Added psl-1983/comp/updated.files version [d8a76c6c83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PS:<PSL.COMP> ANYREG-CMACRO.SL.12 BARE-PSL.SYM.1 BIG-FASLEND.BUILD.1 BIG-FASLEND.RED.4 COMMON-CMACROS.SL.4 COMMON-PREDICATES.SL.5 COMP-DECLS.BUILD.3 COMP-DECLS.RED.15 COMPILER.BUILD.7 COMPILER.CTL.1 COMPILER.RED.8 DATA-MACHINE.RED.1 FASLOUT.BUILD.11 FASLOUT.RED.35 LAP-TO-ASM.BUILD.2 LAP-TO-ASM.RED.8 P-LAMBIND.SL.13 PASS-1-LAP.BUILD.5 PASS-1-LAP.SL.17 README..1 SYSLISP.BUILD.4 SYSLISP-SYNTAX.RED.8 TAGS.RED.1 TIME.STAMP.42 UPDATED.FILES.2 WDECLARE.RED.4 |
Added psl-1983/comp/wdeclare.red version [f3b3178e88].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % WDECLARE.RED - Skeleton WDeclare for WConsts % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 March 1982 % Copyright (c) 1982 University of Utah % % <PSL.COMP>WDECLARE.RED.2, 17-Nov-82 17:09:39, Edit by PERDUE % Flagged WDeclare IGNORE rather than EVAL, so it takes effect % at compile time rather than load time! fexpr procedure WDeclare U; for each X in cddr U do WDeclare1(car X, car U, cadr U, cadr X, caddr X); flag('(WDeclare), 'IGNORE); lisp procedure WDeclare1(Name, Scope, Typ, UpperBound, Initializer); if Typ = 'WCONST then if Scope = 'EXTERNAL and not get(Name, 'WCONST) then ErrorPrintF("*** A value has not been defined for WConst %r", Name) else% EvDefConst(Name, Initializer) put(Name, 'WConst, Initializer) else StdError BldMsg("%r is not currently supported", Typ); |
Added psl-1983/doc-nmode/chart.ibm version [baf2c6684b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>CHART.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 202/9836 NMODE Command Summary 201/11 February 1983 202/Information 201/What Cursor Position C-X = Show Function on Key M-? List Matching Commands <help> 202/Files 201/Find File C-X C-F Write File C-X C-W Save File C-X C-S Save All Files M-X Save All Files Write Region to File M-X Write Region Append Region to File M-X Append to File Prepend Region to File M-X Prepend to File Insert File M-X Insert File Revert File M-X Revert File Set Visited Filename M-X Set Visited Filename 202/Buffers 201/Find File C-X C-F Select Buffer C-X B Select Previous Buffer C-M-L List Buffers C-X C-B Go to Buffer Start M-< (or) <clr-end> Go to Buffer End M-> (or) Shift-<clr-end> Kill Buffer C-X K Kill Some Buffers M-X Kill Some Buffers Append Region to Buffer C-X A Rename Buffer M-X Rename Buffer Insert Buffer M-X Insert Buffer Set Buffer Not-Modified M-~ 202/Regions 201/Kill Region C-W Copy Region M-W Fill Region M-G Upcase Region C-X C-U Downcase Region C-X C-L Append Region to File M-X Append to File Prepend Region to File M-X Prepend to File Append Region to Buffer C-X A 202/The Mark 201/Set/Pop Mark C-@ Exchange Point and Mark C-X C-X Set Mark at Beginning C-< Set Mark at End C-> Mark Word M-@ Mark Paragraph M-H Mark Form C-M-@ Mark Defun M-Backspace Mark Whole Buffer C-X H 202/Characters 201/Move Forward Character C-F (or) <right-arrow> Move Backward Character C-B (or) <left-arrow> Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Transpose Characters C-T Quote Character C-Q 202/Lines 201/Move to Next Line C-N (or) <down-arrow> Move to Previous Line C-P (or) <up-arrow> Goto Start of Line C-A Goto End of Line C-E Kill Line C-K (or) <del-ln> Transpose Lines C-X C-T Center Line M-S Join To Previous Line M-^ Insert Blank Line C-O (or) <ins-ln> Split Line C-M-O Delete Blank Lines C-X C-O Delete Matching Lines M-X Delete Matching Lines Delete Non-Matching Lines M-X Delete Non-Matching Lines 202/Words 201/Move Forward Word M-F (or) Control-<right-arrow> Move Backward Word M-B (or) Control-<left-arrow> Forward Kill Word M-D Backward Kill Word M-Rubout Mark Word M-@ Transpose Words M-T Upcase Word M-U Downcase Word M-L Capitalize Word M-C 202/Sentences 201/Move Forward Sentence M-E Move Backward Sentence M-A Forward Kill Sentence M-K Backward Kill Sentence C-X Rubout 202/Paragraphs 201/Move Forward Paragraph M-] Move Backward Paragraph M-[ Mark Paragraph M-H Fill Paragraph M-Q 202/Killing and Unkilling Text 201/Kill Line C-K (or) <del-ln> Forward Kill Word M-D Backward Kill Word M-Rubout Forward Kill Sentence M-K Backward Kill Sentence C-X Rubout Forward Kill Form C-M-K Backward Kill Form C-M-Rubout Kill Region C-W Copy Region M-W Yank Killed Text C-Y Yank Previous Kill M-Y Append Next Kill C-M-W 202/Deleting Text 201/Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Delete Horizontal Spaces M-\ Delete Blank Lines C-X C-O Delete Matching Lines M-X Delete Matching Lines Delete Non-Matching Lines M-X Delete Non-Matching Lines 202/String Search 201/Foward Search C-S Reverse Search C-R Count Occurrences M-X Count Occurrences 202/String Replacement 201/Query Replace M-% Replace String C-% 202/Indentation 201/Back to Indentation on Line M-M Indent Line Tab Indent New Line Newline Indent Form C-M-Q Indent Region C-M-\ 202/Text Filling and Justification 201/Set Fill Prefix C-X . Set Right Margin C-X F Fill Region M-G Fill Paragraph M-Q Fill Comment M-Z Auto Fill Mode (toggle) M-X Auto Fill Mode 202/Case Conversion 201/Upcase Word M-U Downcase Word M-L Capitalize Word M-C Upcase Region C-X C-U Downcase Region C-X C-L 202/Modes 201/Enter Lisp Mode M-X Lisp Mode Enter Text Mode M-X Text Mode 202/Lisp Forms 201/Move Forward Form C-M-F Move Backward Form C-M-B Forward Kill Form C-M-K Backward Kill Form C-M-Rubout Transpose Forms C-M-T Mark Form C-M-@ Indent Form C-M-Q 202/Lisp Lists 201/Move Backward Up List C-( Move Forward Up List C-) Move Forward Into List C-M-D Insert Parens M-( 202/Lisp Defuns 201/Mark Defun C-M-H Beginning of Defun C-M-A End of Defun C-M-E Execute Defun C-] D 202/Lisp Execution 201/Execute Form C-] E Execute Defun C-] D Quit from Break Loop C-] Q Abort from Break Loop C-] A Backtrace from Break Loop C-] B Continue from Break Loop C-] C Retry from Break Loop C-] R 202/Screen Management 201/Redisplay Screen C-L Reposition Window C-M-R Scroll to Next Screenful C-V (or) <recall> Scroll to Previous Screenful M-V (or) Shift-<recall> Scroll Buffer Up One Line Control-<recall> Scroll Buffer Down One Line Shift-Control-<recall> Invert Video C-X V 202/Windows 201/Two Windows C-X 2 One Window C-X 1 Go to Other Window C-X O Exchange Windows C-X E Scroll Other Window C-M-V Grow Window C-X ^ |
Added psl-1983/doc-nmode/command-index.data version [402bf4ea25].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Append Next Kill} idx 14 .silent_index {Append To Buffer} idx 14 .silent_index {Append To File} idx 14 .silent_index {Apropos} idx 14 .silent_index {Argument Digit} idx 15 .silent_index {Auto Fill Mode} idx 15 .silent_index {Back To Indentation} idx 16 .silent_index {Backward Kill Sentence} idx 16 .silent_index {Backward Paragraph} idx 16 .silent_index {Backward Sentence} idx 16 .silent_index {Backward Up List} idx 17 .silent_index {Buffer Browser} idx 17 .silent_index {Buffer Not Modified} idx 17 .silent_index {C-X Prefix} idx 17 .silent_index {Center Line} idx 18 .silent_index {Copy Region} idx 18 .silent_index {Count Occurrences} idx 18 .silent_index {Delete And Expunge File} idx 18 .silent_index {Delete Backward Hacking Tabs} idx 19 .silent_index {Delete Blank Lines} idx 19 .silent_index {Delete File} idx 19 .silent_index {Delete Forward Character} idx 19 .silent_index {Delete Horizontal Space} idx 20 .silent_index {Delete Indentation} idx 20 .silent_index {Delete Matching Lines} idx 20 .silent_index {Delete Non-Matching Lines} idx 20 .silent_index {Dired} idx 20 .silent_index {Down List} idx 21 .silent_index {Edit Directory} idx 21 .silent_index {End Of Defun} idx 21 .silent_index {Esc Prefix} idx 22 .silent_index {Exchange Point And Mark} idx 22 .silent_index {Exchange Windows} idx 22 .silent_index {Execute Buffer} idx 22 .silent_index {Execute File} idx 22 .silent_index {Execute Form} idx 23 .silent_index {Exit Nmode} idx 23 .silent_index {Fill Comment} idx 23 .silent_index {Fill Paragraph} idx 23 .silent_index {Fill Region} idx 24 .silent_index {Find File} idx 24 .silent_index {Forward Paragraph} idx 24 .silent_index {Forward Sentence} idx 25 .silent_index {Forward Up List} idx 25 .silent_index {Get Register} idx 25 .silent_index {Grow Window} idx 25 .silent_index {Help Dispatch} idx 26 .silent_index {Incremental Search} idx 26 .silent_index {Indent New line} idx 26 .silent_index {Insert Buffer} idx 26 .silent_index {Insert Closing bracket} idx 27 .silent_index {Insert Comment} idx 27 .silent_index {Insert Date} idx 27 .silent_index {Insert File} idx 27 .silent_index {Insert Kill Buffer} idx 28 .silent_index {Insert Next Character} idx 28 .silent_index {Insert Parens} idx 28 .silent_index {Kill Backward Form} idx 28 .silent_index {Kill Backward Word} idx 29 .silent_index {Kill Buffer} idx 29 .silent_index {Kill Forward Form} idx 29 .silent_index {Kill Forward Word} idx 29 .silent_index {Kill Line} idx 30 .silent_index {Kill Region} idx 30 .silent_index {Kill Sentence} idx 30 .silent_index {Kill Some Buffers} idx 30 .silent_index {Lisp Abort} idx 31 .silent_index {Lisp Backtrace} idx 31 .silent_index {Lisp Continue} idx 31 .silent_index {Lisp Help} idx 31 .silent_index {Lisp Indent Region} idx 32 .silent_index {Lisp Indent sexpr} idx 32 .silent_index {Lisp Mode} idx 32 .silent_index {Lisp Prefix} idx 32 .silent_index {Lisp Quit} idx 33 .silent_index {Lisp Retry} idx 33 .silent_index {Lisp Tab} idx 33 .silent_index {Lowercase Region} idx 33 .silent_index {Lowercase Word} idx 34 .silent_index {M-X Prefix} idx 34 .silent_index {Mark Beginning} idx 34 .silent_index {Mark Defun} idx 34 .silent_index {Mark End} idx 35 .silent_index {Mark Form} idx 35 .silent_index {Mark Paragraph} idx 35 .silent_index {Mark Whole Buffer} idx 35 .silent_index {Mark Word} idx 35 .silent_index {Move Backward Character} idx 36 .silent_index {Move Backward Defun} idx 36 .silent_index {Move Backward Form} idx 36 .silent_index {Move Backward List} idx 36 .silent_index {Move Backward Word} idx 37 .silent_index {Move Down} idx 37 .silent_index {Move Down Extending} idx 37 .silent_index {Move Forward Character} idx 37 .silent_index {Move Forward Form} idx 38 .silent_index {Move Forward List} idx 38 .silent_index {Move Forward Word} idx 38 .silent_index {Move To Buffer End} idx 38 .silent_index {Move To Buffer Start} idx 39 .silent_index {Move To End Of Line} idx 39 .silent_index {Move To Screen Edge} idx 39 .silent_index {Move To Start Of Line} idx 39 .silent_index {Move Up} idx 39 .silent_index {Negative Argument} idx 40 .silent_index {Next Screen} idx 40 .silent_index {Nmode Abort} idx 40 .silent_index {Nmode Exit To Superior} idx 40 .silent_index {Nmode Full Refresh} idx 40 .silent_index {Nmode Gc} idx 41 .silent_index {Nmode Invert Video} idx 41 .silent_index {Nmode Refresh} idx 41 .silent_index {One Window} idx 41 .silent_index {Open Line} idx 41 .silent_index {Other Window} idx 42 .silent_index {Prepend To File} idx 42 .silent_index {Previous Screen} idx 42 .silent_index {Put Register} idx 42 .silent_index {Query Replace} idx 42 .silent_index {Rename Buffer} idx 43 .silent_index {Replace String} idx 43 .silent_index {Reposition Window} idx 43 .silent_index {Return} idx 43 .silent_index {Reverse Search} idx 44 .silent_index {Revert File} idx 44 .silent_index {Save All Files} idx 44 .silent_index {Save File} idx 44 .silent_index {Scroll Other Window} idx 44 .silent_index {Scroll Window Down Line} idx 45 .silent_index {Scroll Window Down Page} idx 45 .silent_index {Scroll Window Left} idx 45 .silent_index {Scroll Window Right} idx 45 .silent_index {Scroll Window Up Line} idx 45 .silent_index {Scroll Window Up Page} idx 46 .silent_index {Select Buffer} idx 46 .silent_index {Select Previous Buffer} idx 46 .silent_index {Set Fill Column} idx 46 .silent_index {Set Fill Prefix} idx 47 .silent_index {Set Goal Column} idx 47 .silent_index {Set Key} idx 47 .silent_index {Set Mark} idx 47 .silent_index {Set Visited Filename} idx 48 .silent_index {Split Line} idx 48 .silent_index {Start Scripting} idx 48 .silent_index {Start Timing} idx 48 .silent_index {Stop Scripting} idx 49 .silent_index {Stop Timing} idx 49 .silent_index {Tab To Tab Stop} idx 49 .silent_index {Text Mode} idx 49 .silent_index {Transpose Characters} idx 50 .silent_index {Transpose Forms} idx 50 .silent_index {Transpose Lines} idx 50 .silent_index {Transpose Regions} idx 50 .silent_index {Transpose Words} idx 51 .silent_index {Two Windows} idx 51 .silent_index {Undelete File} idx 51 .silent_index {Universal Argument} idx 51 .silent_index {Unkill Previous} idx 52 .silent_index {Upcase Digit} idx 52 .silent_index {Uppercase Initial} idx 52 .silent_index {Uppercase Region} idx 52 .silent_index {Uppercase Word} idx 53 .silent_index {View Two Windows} idx 53 .silent_index {Visit File} idx 53 .silent_index {Visit In Other Window} idx 53 .silent_index {What Cursor Position} idx 54 .silent_index {Write File} idx 54 .silent_index {Write Region} idx 54 .silent_index {Write Screen Photo} idx 54 .silent_index {Yank Last Output} idx 55 |
Added psl-1983/doc-nmode/costly.sl version [d959c0bd7e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SETQ DOC-OBJ-LIST (LIST (SETQ DOC1 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Alter Display Format") (QUOTE TYPE) (QUOTE ACTION) ( QUOTE INDEX) (QUOTE 1) (QUOTE START-LINE) (QUOTE 1) (QUOTE END-LINE) (QUOTE 6) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC2 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Alter Existing Text") (QUOTE TYPE) ( QUOTE ACTION) (QUOTE INDEX) (QUOTE 2) (QUOTE START-LINE) (QUOTE 7) (QUOTE END-LINE) (QUOTE 12) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC3 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Change Mode") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 3) (QUOTE START-LINE) (QUOTE 13) (QUOTE END-LINE) (QUOTE 18) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC4 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Escape") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 4) (QUOTE START-LINE) (QUOTE 19) (QUOTE END-LINE) (QUOTE 23) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC5 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Inform") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 5) (QUOTE START-LINE) (QUOTE 24) (QUOTE END-LINE) (QUOTE 30) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC6 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Constant") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 6) (QUOTE START-LINE) (QUOTE 31) (QUOTE END-LINE) (QUOTE 36) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC7 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark") (QUOTE TYPE) ( QUOTE ACTION) (QUOTE INDEX) (QUOTE 7) (QUOTE START-LINE) (QUOTE 37) (QUOTE END-LINE) (QUOTE 41) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC8 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Data") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 8) (QUOTE START-LINE) (QUOTE 42) (QUOTE END-LINE) (QUOTE 47) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC9 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Point") ( QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 9) (QUOTE START-LINE) (QUOTE 48) (QUOTE END-LINE) (QUOTE 53) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC10 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Preserve") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 10) (QUOTE START-LINE) (QUOTE 54) (QUOTE END-LINE) (QUOTE 58) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC11 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Remove") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 11) (QUOTE START-LINE) (QUOTE 59) (QUOTE END-LINE) (QUOTE 64) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC12 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Select") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 12) (QUOTE START-LINE) (QUOTE 65) (QUOTE END-LINE) (QUOTE 70) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC13 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Global Variable") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) (QUOTE 13) (QUOTE START-LINE) ( QUOTE 71) (QUOTE END-LINE) (QUOTE 76) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC14 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Subsequent Command Modifier") (QUOTE TYPE) (QUOTE ACTION) (QUOTE INDEX) ( QUOTE 14) (QUOTE START-LINE) (QUOTE 77) (QUOTE END-LINE) (QUOTE 82) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC15 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Defun") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 15) (QUOTE START-LINE) (QUOTE 83) (QUOTE END-LINE) (QUOTE 88) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC16 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Paragraph") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 16) (QUOTE START-LINE) (QUOTE 89) (QUOTE END-LINE) (QUOTE 98) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC17 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Region") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 17) (QUOTE START-LINE) (QUOTE 99) (QUOTE END-LINE) (QUOTE 104) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC18 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Sentence") (QUOTE TYPE) (QUOTE DEFINITION) (QUOTE INDEX) ( QUOTE 18) (QUOTE START-LINE) (QUOTE 105) (QUOTE END-LINE) (QUOTE 112) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC19 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Fill Column") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 19) (QUOTE START-LINE) (QUOTE 113) (QUOTE END-LINE) (QUOTE 119) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC20 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Fill Prefix") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 20) (QUOTE START-LINE) (QUOTE 120) (QUOTE END-LINE) (QUOTE 128) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC21 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Goal Column") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 21) (QUOTE START-LINE) (QUOTE 129) (QUOTE END-LINE) (QUOTE 133) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC22 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Kill Ring") (QUOTE TYPE) (QUOTE GLOBAL) (QUOTE INDEX) ( QUOTE 22) (QUOTE START-LINE) (QUOTE 134) (QUOTE END-LINE) (QUOTE 152) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC23 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Append Next Kill") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 23) (QUOTE START-LINE) (QUOTE 153) (QUOTE END-LINE) (QUOTE 164) (QUOTE REF-LIST) (QUOTE (DOC8 DOC22)))) (SETQ DOC24 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Append To Buffer") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 24) (QUOTE START-LINE) (QUOTE 165) ( QUOTE END-LINE) (QUOTE 178) (QUOTE REF-LIST) (QUOTE (DOC8 DOC17 DOC197)))) ( SETQ DOC25 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Append To File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 25) ( QUOTE START-LINE) (QUOTE 179) (QUOTE END-LINE) (QUOTE 189) (QUOTE REF-LIST) ( QUOTE (DOC8 DOC17 DOC196)))) (SETQ DOC26 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Apropos") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 26) (QUOTE START-LINE) (QUOTE 190) (QUOTE END-LINE) ( QUOTE 199) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC27 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Argument Digit") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 27) (QUOTE START-LINE) (QUOTE 200) ( QUOTE END-LINE) (QUOTE 238) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC28 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Auto Fill Mode") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 28) (QUOTE START-LINE) ( QUOTE 239) (QUOTE END-LINE) (QUOTE 252) (QUOTE REF-LIST) (QUOTE (DOC3 DOC159)))) (SETQ DOC29 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Back To Indentation") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 29) (QUOTE START-LINE) (QUOTE 253) (QUOTE END-LINE) (QUOTE 264) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC30 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Backward Kill Sentence") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 30) (QUOTE START-LINE) (QUOTE 265) (QUOTE END-LINE) ( QUOTE 276) (QUOTE REF-LIST) (QUOTE (DOC11 DOC18 DOC22)))) (SETQ DOC31 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 31) (QUOTE START-LINE) ( QUOTE 277) (QUOTE END-LINE) (QUOTE 287) (QUOTE REF-LIST) (QUOTE (DOC9 DOC16)))) (SETQ DOC32 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 32) (QUOTE START-LINE) (QUOTE 288) (QUOTE END-LINE) (QUOTE 298) (QUOTE REF-LIST) (QUOTE (DOC9 DOC18)))) (SETQ DOC33 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Backward Up List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 33) (QUOTE START-LINE) (QUOTE 299) (QUOTE END-LINE) (QUOTE 312) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC34 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Buffer Browser") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 34) ( QUOTE START-LINE) (QUOTE 313) (QUOTE END-LINE) (QUOTE 324) (QUOTE REF-LIST) ( QUOTE (DOC5 DOC197)))) (SETQ DOC35 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Buffer Not Modified") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 35) (QUOTE START-LINE) (QUOTE 325) (QUOTE END-LINE) ( QUOTE 334) (QUOTE REF-LIST) (QUOTE (DOC13 DOC197)))) (SETQ DOC36 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "C-X Prefix") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 36) (QUOTE START-LINE) ( QUOTE 335) (QUOTE END-LINE) (QUOTE 344) (QUOTE REF-LIST) (QUOTE (DOC14)))) ( SETQ DOC37 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Center Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 37) (QUOTE START-LINE) (QUOTE 345) (QUOTE END-LINE) (QUOTE 357) (QUOTE REF-LIST) (QUOTE ( DOC2 DOC19 DOC193)))) (SETQ DOC38 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Copy Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 38) (QUOTE START-LINE) (QUOTE 358) (QUOTE END-LINE) (QUOTE 369) (QUOTE REF-LIST) (QUOTE (DOC10 DOC17 DOC22)))) (SETQ DOC39 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Count Occurrences") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 39) (QUOTE START-LINE) (QUOTE 370) (QUOTE END-LINE) (QUOTE 380) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC40 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete And Expunge File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 40) (QUOTE START-LINE) (QUOTE 381) (QUOTE END-LINE) (QUOTE 393) (QUOTE REF-LIST) (QUOTE (DOC11 DOC196)))) (SETQ DOC41 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Backward Hacking Tabs") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 41) (QUOTE START-LINE) (QUOTE 394) (QUOTE END-LINE) (QUOTE 409) (QUOTE REF-LIST) (QUOTE (DOC11 DOC195)))) ( SETQ DOC42 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Blank Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 42) (QUOTE START-LINE) (QUOTE 410) (QUOTE END-LINE) (QUOTE 421) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC43 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Delete File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 43) (QUOTE START-LINE) (QUOTE 422) (QUOTE END-LINE) (QUOTE 432) (QUOTE REF-LIST) (QUOTE (DOC11 DOC196)))) (SETQ DOC44 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Forward Character") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 44) (QUOTE START-LINE) (QUOTE 433) ( QUOTE END-LINE) (QUOTE 444) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22)))) (SETQ DOC45 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Horizontal Space") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 45) (QUOTE START-LINE) (QUOTE 445) (QUOTE END-LINE) (QUOTE 453) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC46 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Delete Indentation") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 46) (QUOTE START-LINE) (QUOTE 454) (QUOTE END-LINE) (QUOTE 464) (QUOTE REF-LIST) (QUOTE (DOC11)))) (SETQ DOC47 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Matching Lines") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 47) (QUOTE START-LINE) (QUOTE 465) ( QUOTE END-LINE) (QUOTE 476) (QUOTE REF-LIST) (QUOTE (DOC11 DOC12)))) (SETQ DOC48 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Delete Non-Matching Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 48) (QUOTE START-LINE) (QUOTE 477) (QUOTE END-LINE) (QUOTE 488) (QUOTE REF-LIST) (QUOTE (DOC11 DOC12)))) (SETQ DOC49 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Dired") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 49) (QUOTE START-LINE) (QUOTE 489) (QUOTE END-LINE) ( QUOTE 499) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC50 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Down List") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 50) (QUOTE START-LINE) (QUOTE 500) (QUOTE END-LINE) ( QUOTE 511) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC51 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Edit Directory") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 51) (QUOTE START-LINE) ( QUOTE 512) (QUOTE END-LINE) (QUOTE 531) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC52 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "End Of Defun") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 52) (QUOTE START-LINE) ( QUOTE 532) (QUOTE END-LINE) (QUOTE 545) (QUOTE REF-LIST) (QUOTE (DOC9 DOC15 DOC194 DOC195)))) (SETQ DOC53 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Esc Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 53) (QUOTE START-LINE) (QUOTE 546) (QUOTE END-LINE) (QUOTE 556) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC54 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Exchange Point And Mark") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 54) (QUOTE START-LINE) (QUOTE 557) (QUOTE END-LINE) ( QUOTE 566) (QUOTE REF-LIST) (QUOTE (DOC9 DOC7)))) (SETQ DOC55 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Exchange Windows") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 55) (QUOTE START-LINE) (QUOTE 567) ( QUOTE END-LINE) (QUOTE 576) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC56 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Execute Buffer") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 56) (QUOTE START-LINE) ( QUOTE 577) (QUOTE END-LINE) (QUOTE 589) (QUOTE REF-LIST) (QUOTE (DOC197)))) ( SETQ DOC57 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Execute File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 57) (QUOTE START-LINE) (QUOTE 590) (QUOTE END-LINE) (QUOTE 602) (QUOTE REF-LIST) (QUOTE ( DOC196)))) (SETQ DOC58 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Execute Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 58) (QUOTE START-LINE) (QUOTE 603) (QUOTE END-LINE) (QUOTE 616) (QUOTE REF-LIST) (QUOTE (DOC7 DOC194 DOC195)))) (SETQ DOC59 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Exit Nmode") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 59) (QUOTE START-LINE) (QUOTE 617) (QUOTE END-LINE) (QUOTE 627) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC60 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Comment") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 60) (QUOTE START-LINE) ( QUOTE 628) (QUOTE END-LINE) (QUOTE 642) (QUOTE REF-LIST) (QUOTE (DOC2 DOC16 DOC19 DOC20)))) (SETQ DOC61 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Paragraph") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 61) (QUOTE START-LINE) (QUOTE 643) (QUOTE END-LINE) (QUOTE 657) (QUOTE REF-LIST) (QUOTE (DOC2 DOC16 DOC19 DOC20 DOC193)))) (SETQ DOC62 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Fill Region") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 62) (QUOTE START-LINE) ( QUOTE 658) (QUOTE END-LINE) (QUOTE 677) (QUOTE REF-LIST) (QUOTE (DOC2 DOC18 DOC16 DOC19 DOC20 DOC160 DOC159 DOC193)))) (SETQ DOC63 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Find File") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 63) (QUOTE START-LINE) (QUOTE 678) (QUOTE END-LINE) ( QUOTE 691) (QUOTE REF-LIST) (QUOTE (DOC9 DOC8 DOC197 DOC196)))) (SETQ DOC64 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Forward Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 64) (QUOTE START-LINE) ( QUOTE 692) (QUOTE END-LINE) (QUOTE 704) (QUOTE REF-LIST) (QUOTE (DOC9 DOC16 DOC193)))) (SETQ DOC65 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Forward Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 65) (QUOTE START-LINE) (QUOTE 705) (QUOTE END-LINE) (QUOTE 717) (QUOTE REF-LIST) (QUOTE (DOC9 DOC18 DOC193)))) (SETQ DOC66 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Forward Up List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 66) (QUOTE START-LINE) (QUOTE 718) (QUOTE END-LINE) (QUOTE 730) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC67 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Get Register") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 67) (QUOTE START-LINE) ( QUOTE 731) (QUOTE END-LINE) (QUOTE 742) (QUOTE REF-LIST) (QUOTE (DOC7 DOC8)))) ( SETQ DOC68 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Grow Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 68) (QUOTE START-LINE) (QUOTE 743) (QUOTE END-LINE) (QUOTE 752) (QUOTE REF-LIST) (QUOTE ( DOC1)))) (SETQ DOC69 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Help Dispatch") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 69) (QUOTE START-LINE) (QUOTE 753) (QUOTE END-LINE) (QUOTE 764) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC70 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Incremental Search") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 70) (QUOTE START-LINE) (QUOTE 765) (QUOTE END-LINE) (QUOTE 782) (QUOTE REF-LIST) (QUOTE (DOC12 DOC9)))) (SETQ DOC71 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Indent New line") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 71) (QUOTE START-LINE) (QUOTE 783) ( QUOTE END-LINE) (QUOTE 793) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC72 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Buffer") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 72) (QUOTE START-LINE) ( QUOTE 794) (QUOTE END-LINE) (QUOTE 805) (QUOTE REF-LIST) (QUOTE (DOC8 DOC197)))) (SETQ DOC73 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Closing bracket") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 73) (QUOTE START-LINE) (QUOTE 806) (QUOTE END-LINE) (QUOTE 818) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC74 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Comment") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 74) (QUOTE START-LINE) (QUOTE 819) (QUOTE END-LINE) (QUOTE 830) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC75 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Date") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 75) (QUOTE START-LINE) ( QUOTE 831) (QUOTE END-LINE) (QUOTE 840) (QUOTE REF-LIST) (QUOTE (DOC8)))) ( SETQ DOC76 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 76) (QUOTE START-LINE) (QUOTE 841) (QUOTE END-LINE) (QUOTE 851) (QUOTE REF-LIST) (QUOTE ( DOC8 DOC196)))) (SETQ DOC77 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Kill Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 77) (QUOTE START-LINE) (QUOTE 852) (QUOTE END-LINE) (QUOTE 864) (QUOTE REF-LIST) (QUOTE (DOC7 DOC8 DOC22)))) (SETQ DOC78 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Next Character") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 78) (QUOTE START-LINE) (QUOTE 865) ( QUOTE END-LINE) (QUOTE 873) (QUOTE REF-LIST) (QUOTE (DOC8)))) (SETQ DOC79 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Insert Parens") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 79) (QUOTE START-LINE) ( QUOTE 874) (QUOTE END-LINE) (QUOTE 887) (QUOTE REF-LIST) (QUOTE (DOC6 DOC194 DOC195)))) (SETQ DOC80 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Kill Backward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 80) (QUOTE START-LINE) (QUOTE 888) (QUOTE END-LINE) (QUOTE 900) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC194 DOC195)))) (SETQ DOC81 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Backward Word") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 81) (QUOTE START-LINE) (QUOTE 901) ( QUOTE END-LINE) (QUOTE 912) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC193)))) ( SETQ DOC82 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 82) (QUOTE START-LINE) (QUOTE 913) (QUOTE END-LINE) (QUOTE 925) (QUOTE REF-LIST) (QUOTE ( DOC11 DOC197)))) (SETQ DOC83 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Forward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 83) (QUOTE START-LINE) (QUOTE 926) (QUOTE END-LINE) (QUOTE 938) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC194 DOC195)))) (SETQ DOC84 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Forward Word") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 84) (QUOTE START-LINE) (QUOTE 939) ( QUOTE END-LINE) (QUOTE 950) (QUOTE REF-LIST) (QUOTE (DOC11 DOC22 DOC193)))) ( SETQ DOC85 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 85) (QUOTE START-LINE) (QUOTE 951) (QUOTE END-LINE) (QUOTE 966) (QUOTE REF-LIST) (QUOTE ( DOC11 DOC22)))) (SETQ DOC86 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 86) (QUOTE START-LINE) (QUOTE 967) (QUOTE END-LINE) (QUOTE 977) (QUOTE REF-LIST) (QUOTE (DOC11 DOC17 DOC22)))) (SETQ DOC87 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Sentence") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 87) (QUOTE START-LINE) (QUOTE 978) (QUOTE END-LINE) (QUOTE 991) (QUOTE REF-LIST) (QUOTE (DOC11 DOC18 DOC22 DOC193)))) ( SETQ DOC88 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Kill Some Buffers") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 88) (QUOTE START-LINE) (QUOTE 992) (QUOTE END-LINE) (QUOTE 1002) (QUOTE REF-LIST) (QUOTE (DOC11 DOC197)))) (SETQ DOC89 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Abort") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 89) (QUOTE START-LINE) (QUOTE 1003) (QUOTE END-LINE) (QUOTE 1013) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC90 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Backtrace") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 90) ( QUOTE START-LINE) (QUOTE 1014) (QUOTE END-LINE) (QUOTE 1025) (QUOTE REF-LIST) ( QUOTE (DOC5 DOC194 DOC195)))) (SETQ DOC91 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Continue") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 91) (QUOTE START-LINE) (QUOTE 1026) (QUOTE END-LINE) (QUOTE 1041) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC92 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Help") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 92) (QUOTE START-LINE) ( QUOTE 1042) (QUOTE END-LINE) (QUOTE 1055) (QUOTE REF-LIST) (QUOTE (DOC5 DOC194 DOC195)))) (SETQ DOC93 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Indent Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 93) (QUOTE START-LINE) (QUOTE 1056) (QUOTE END-LINE) (QUOTE 1068) ( QUOTE REF-LIST) (QUOTE (DOC194 DOC195)))) (SETQ DOC94 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Indent sexpr") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 94) (QUOTE START-LINE) (QUOTE 1069) (QUOTE END-LINE) (QUOTE 1079) (QUOTE REF-LIST) (QUOTE (DOC194 DOC195)))) (SETQ DOC95 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Mode") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 95) (QUOTE START-LINE) ( QUOTE 1080) (QUOTE END-LINE) (QUOTE 1091) (QUOTE REF-LIST) (QUOTE (DOC3 DOC194)))) (SETQ DOC96 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Lisp Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 96) (QUOTE START-LINE) (QUOTE 1092) (QUOTE END-LINE) (QUOTE 1103) (QUOTE REF-LIST) (QUOTE (DOC14 DOC194 DOC195)))) (SETQ DOC97 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Quit") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 97) (QUOTE START-LINE) (QUOTE 1104) (QUOTE END-LINE) ( QUOTE 1114) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC98 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Retry") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 98) (QUOTE START-LINE) ( QUOTE 1115) (QUOTE END-LINE) (QUOTE 1127) (QUOTE REF-LIST) (QUOTE (DOC4 DOC194 DOC195)))) (SETQ DOC99 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lisp Tab") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 99) (QUOTE START-LINE) (QUOTE 1128) (QUOTE END-LINE) (QUOTE 1145) (QUOTE REF-LIST) (QUOTE (DOC2 DOC170 DOC194 DOC195)))) (SETQ DOC100 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lowercase Region") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 100) (QUOTE START-LINE) (QUOTE 1146) ( QUOTE END-LINE) (QUOTE 1155) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC101 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Lowercase Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 101) ( QUOTE START-LINE) (QUOTE 1156) (QUOTE END-LINE) (QUOTE 1166) (QUOTE REF-LIST) ( QUOTE (DOC2 DOC193)))) (SETQ DOC102 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "M-X Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 102) (QUOTE START-LINE) (QUOTE 1167) (QUOTE END-LINE) (QUOTE 1179) ( QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC103 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Beginning") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 103) (QUOTE START-LINE) (QUOTE 1180) (QUOTE END-LINE) (QUOTE 1188) (QUOTE REF-LIST) (QUOTE (DOC7)))) (SETQ DOC104 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Defun") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 104) (QUOTE START-LINE) ( QUOTE 1189) (QUOTE END-LINE) (QUOTE 1202) (QUOTE REF-LIST) (QUOTE (DOC7 DOC15 DOC194 DOC195)))) (SETQ DOC105 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Mark End") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 105) (QUOTE START-LINE) (QUOTE 1203) (QUOTE END-LINE) (QUOTE 1211) ( QUOTE REF-LIST) (QUOTE (DOC7)))) (SETQ DOC106 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Form") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 106) (QUOTE START-LINE) (QUOTE 1212) (QUOTE END-LINE) ( QUOTE 1223) (QUOTE REF-LIST) (QUOTE (DOC7 DOC194 DOC195)))) (SETQ DOC107 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Paragraph") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 107) (QUOTE START-LINE) ( QUOTE 1224) (QUOTE END-LINE) (QUOTE 1236) (QUOTE REF-LIST) (QUOTE (DOC9 DOC7 DOC16 DOC193)))) (SETQ DOC108 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Whole Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 108) (QUOTE START-LINE) (QUOTE 1237) (QUOTE END-LINE) (QUOTE 1247) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC7)))) (SETQ DOC109 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Mark Word") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 109) (QUOTE START-LINE) (QUOTE 1248) (QUOTE END-LINE) ( QUOTE 1258) (QUOTE REF-LIST) (QUOTE (DOC7 DOC193)))) (SETQ DOC110 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Character") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 110) (QUOTE START-LINE) (QUOTE 1259) (QUOTE END-LINE) (QUOTE 1269) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC111 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move Backward Defun") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 111) (QUOTE START-LINE) (QUOTE 1270) (QUOTE END-LINE) ( QUOTE 1283) (QUOTE REF-LIST) (QUOTE (DOC9 DOC15 DOC194 DOC195)))) (SETQ DOC112 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 112) (QUOTE START-LINE) (QUOTE 1284) (QUOTE END-LINE) (QUOTE 1295) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC113 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward List") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 113) (QUOTE START-LINE) (QUOTE 1296) ( QUOTE END-LINE) (QUOTE 1307) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) ( SETQ DOC114 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Backward Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 114) (QUOTE START-LINE) (QUOTE 1308) (QUOTE END-LINE) (QUOTE 1319) (QUOTE REF-LIST) (QUOTE (DOC9 DOC193)))) (SETQ DOC115 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Down") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 115) (QUOTE START-LINE) (QUOTE 1320) (QUOTE END-LINE) ( QUOTE 1330) (QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC116 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Down Extending") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 116) (QUOTE START-LINE) ( QUOTE 1331) (QUOTE END-LINE) (QUOTE 1342) (QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC117 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Move Forward Character") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 117) (QUOTE START-LINE) (QUOTE 1343) (QUOTE END-LINE) (QUOTE 1353) ( QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC118 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward Form") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 118) (QUOTE START-LINE) (QUOTE 1354) (QUOTE END-LINE) (QUOTE 1365) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC119 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward List") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 119) (QUOTE START-LINE) (QUOTE 1366) (QUOTE END-LINE) (QUOTE 1377) (QUOTE REF-LIST) (QUOTE (DOC9 DOC194 DOC195)))) (SETQ DOC120 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move Forward Word") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 120) (QUOTE START-LINE) (QUOTE 1378) (QUOTE END-LINE) (QUOTE 1389) (QUOTE REF-LIST) (QUOTE (DOC9 DOC193)))) (SETQ DOC121 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Buffer End") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 121) (QUOTE START-LINE) ( QUOTE 1390) (QUOTE END-LINE) (QUOTE 1399) (QUOTE REF-LIST) (QUOTE (DOC9)))) ( SETQ DOC122 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Buffer Start") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 122) (QUOTE START-LINE) (QUOTE 1400) (QUOTE END-LINE) (QUOTE 1409) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC123 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move To End Of Line") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 123) (QUOTE START-LINE) (QUOTE 1410) (QUOTE END-LINE) ( QUOTE 1420) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC124 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Screen Edge") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 124) (QUOTE START-LINE) (QUOTE 1421) ( QUOTE END-LINE) (QUOTE 1432) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC125 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Move To Start Of Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 125) (QUOTE START-LINE) (QUOTE 1433) (QUOTE END-LINE) (QUOTE 1444) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC126 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Move Up") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 126) (QUOTE START-LINE) (QUOTE 1445) (QUOTE END-LINE) (QUOTE 1456) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC21)))) (SETQ DOC127 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Negative Argument") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 127) (QUOTE START-LINE) (QUOTE 1457) (QUOTE END-LINE) (QUOTE 1467) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC128 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Next Screen") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 128) (QUOTE START-LINE) ( QUOTE 1468) (QUOTE END-LINE) (QUOTE 1478) (QUOTE REF-LIST) (QUOTE (DOC9)))) ( SETQ DOC129 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Abort") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 129) (QUOTE START-LINE) (QUOTE 1479) (QUOTE END-LINE) (QUOTE 1487) (QUOTE REF-LIST) ( QUOTE (DOC4)))) (SETQ DOC130 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Exit To Superior") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 130) (QUOTE START-LINE) (QUOTE 1488) (QUOTE END-LINE) (QUOTE 1496) (QUOTE REF-LIST) (QUOTE (DOC4)))) (SETQ DOC131 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Full Refresh") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 131) (QUOTE START-LINE) (QUOTE 1497) ( QUOTE END-LINE) (QUOTE 1506) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC132 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Gc") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 132) (QUOTE START-LINE) (QUOTE 1507) (QUOTE END-LINE) (QUOTE 1514) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC133 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Nmode Invert Video") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 133) (QUOTE START-LINE) (QUOTE 1515) (QUOTE END-LINE) (QUOTE 1523) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC134 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Nmode Refresh") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 134) (QUOTE START-LINE) (QUOTE 1524) (QUOTE END-LINE) (QUOTE 1534) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC135 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "One Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 135) (QUOTE START-LINE) (QUOTE 1535) (QUOTE END-LINE) (QUOTE 1544) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC136 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Open Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 136) (QUOTE START-LINE) (QUOTE 1545) (QUOTE END-LINE) (QUOTE 1556) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC137 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 137) (QUOTE START-LINE) ( QUOTE 1557) (QUOTE END-LINE) (QUOTE 1569) (QUOTE REF-LIST) (QUOTE (DOC9 DOC1)))) (SETQ DOC138 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Prepend To File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 138) ( QUOTE START-LINE) (QUOTE 1570) (QUOTE END-LINE) (QUOTE 1580) (QUOTE REF-LIST) ( QUOTE (DOC8 DOC17 DOC196)))) (SETQ DOC139 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Previous Screen") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 139) (QUOTE START-LINE) (QUOTE 1581) (QUOTE END-LINE) (QUOTE 1591) (QUOTE REF-LIST) (QUOTE (DOC9)))) (SETQ DOC140 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Put Register") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 140) (QUOTE START-LINE) ( QUOTE 1592) (QUOTE END-LINE) (QUOTE 1601) (QUOTE REF-LIST) (QUOTE (DOC10)))) ( SETQ DOC141 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Query Replace") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 141) ( QUOTE START-LINE) (QUOTE 1602) (QUOTE END-LINE) (QUOTE 1620) (QUOTE REF-LIST) ( QUOTE (DOC12 DOC2)))) (SETQ DOC142 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Rename Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 142) (QUOTE START-LINE) (QUOTE 1621) (QUOTE END-LINE) (QUOTE 1632) (QUOTE REF-LIST) (QUOTE (DOC13 DOC197)))) (SETQ DOC143 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Replace String") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 143) (QUOTE START-LINE) (QUOTE 1633) ( QUOTE END-LINE) (QUOTE 1643) (QUOTE REF-LIST) (QUOTE (DOC12 DOC2)))) (SETQ DOC144 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Reposition Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 144) (QUOTE START-LINE) (QUOTE 1644) (QUOTE END-LINE) (QUOTE 1655) (QUOTE REF-LIST) (QUOTE (DOC1 DOC194 DOC195)))) (SETQ DOC145 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Return") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 145) (QUOTE START-LINE) (QUOTE 1656) (QUOTE END-LINE) ( QUOTE 1665) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC146 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Reverse Search") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 146) (QUOTE START-LINE) (QUOTE 1666) ( QUOTE END-LINE) (QUOTE 1676) (QUOTE REF-LIST) (QUOTE (DOC12 DOC9 DOC70)))) ( SETQ DOC147 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Revert File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 147) (QUOTE START-LINE) (QUOTE 1677) (QUOTE END-LINE) (QUOTE 1686) (QUOTE REF-LIST) ( QUOTE (DOC11 DOC196)))) (SETQ DOC148 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Save All Files") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 148) (QUOTE START-LINE) (QUOTE 1687) (QUOTE END-LINE) (QUOTE 1699) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196 DOC197)))) (SETQ DOC149 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Save File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 149) (QUOTE START-LINE) (QUOTE 1700) (QUOTE END-LINE) (QUOTE 1709) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) ( SETQ DOC150 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 150) (QUOTE START-LINE) (QUOTE 1710) (QUOTE END-LINE) (QUOTE 1720) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC151 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Scroll Window Down Line") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 151) (QUOTE START-LINE) (QUOTE 1721) (QUOTE END-LINE) ( QUOTE 1731) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC152 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Down Page") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 152) (QUOTE START-LINE) (QUOTE 1732) (QUOTE END-LINE) (QUOTE 1742) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC153 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Left") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 153) (QUOTE START-LINE) (QUOTE 1743) (QUOTE END-LINE) (QUOTE 1752) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC154 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Scroll Window Right") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 154) (QUOTE START-LINE) (QUOTE 1753) (QUOTE END-LINE) ( QUOTE 1762) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC155 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Up Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 155) (QUOTE START-LINE) (QUOTE 1763) (QUOTE END-LINE) (QUOTE 1773) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC156 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Scroll Window Up Page") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 156) (QUOTE START-LINE) (QUOTE 1774) (QUOTE END-LINE) (QUOTE 1784) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC157 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Select Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 157) (QUOTE START-LINE) (QUOTE 1785) (QUOTE END-LINE) (QUOTE 1796) (QUOTE REF-LIST) (QUOTE (DOC9 DOC197)))) (SETQ DOC158 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Select Previous Buffer") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 158) (QUOTE START-LINE) (QUOTE 1797) (QUOTE END-LINE) (QUOTE 1807) (QUOTE REF-LIST) (QUOTE (DOC9 DOC197)))) ( SETQ DOC159 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Fill Column") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 159) ( QUOTE START-LINE) (QUOTE 1808) (QUOTE END-LINE) (QUOTE 1820) (QUOTE REF-LIST) ( QUOTE (DOC13 DOC19)))) (SETQ DOC160 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Set Fill Prefix") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 160) (QUOTE START-LINE) (QUOTE 1821) (QUOTE END-LINE) (QUOTE 1834) (QUOTE REF-LIST) (QUOTE (DOC13 DOC20)))) (SETQ DOC161 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Goal Column") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 161) (QUOTE START-LINE) (QUOTE 1835) ( QUOTE END-LINE) (QUOTE 1846) (QUOTE REF-LIST) (QUOTE (DOC13)))) (SETQ DOC162 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Key") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 162) (QUOTE START-LINE) (QUOTE 1847) (QUOTE END-LINE) (QUOTE 1857) (QUOTE REF-LIST) (QUOTE (DOC13)))) (SETQ DOC163 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Mark") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 163) (QUOTE START-LINE) ( QUOTE 1858) (QUOTE END-LINE) (QUOTE 1868) (QUOTE REF-LIST) (QUOTE (DOC7)))) ( SETQ DOC164 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Set Visited Filename") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 164) (QUOTE START-LINE) (QUOTE 1869) (QUOTE END-LINE) (QUOTE 1881) (QUOTE REF-LIST) (QUOTE (DOC13 DOC196)))) (SETQ DOC165 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Split Line") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 165) (QUOTE START-LINE) (QUOTE 1882) (QUOTE END-LINE) (QUOTE 1894) (QUOTE REF-LIST) (QUOTE (DOC6)))) (SETQ DOC166 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Start Scripting") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 166) (QUOTE START-LINE) ( QUOTE 1895) (QUOTE END-LINE) (QUOTE 1910) (QUOTE REF-LIST) (QUOTE (DOC3)))) ( SETQ DOC167 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Start Timing") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 167) ( QUOTE START-LINE) (QUOTE 1911) (QUOTE END-LINE) (QUOTE 1923) (QUOTE REF-LIST) ( QUOTE (DOC3)))) (SETQ DOC168 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Stop Scripting") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 168) (QUOTE START-LINE) (QUOTE 1924) (QUOTE END-LINE) (QUOTE 1933) ( QUOTE REF-LIST) (QUOTE (DOC3)))) (SETQ DOC169 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Stop Timing") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 169) (QUOTE START-LINE) (QUOTE 1934) (QUOTE END-LINE) (QUOTE 1946) (QUOTE REF-LIST) (QUOTE (DOC3)))) (SETQ DOC170 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Tab To Tab Stop") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 170) (QUOTE START-LINE) ( QUOTE 1947) (QUOTE END-LINE) (QUOTE 1960) (QUOTE REF-LIST) (QUOTE (DOC6 DOC99)))) (SETQ DOC171 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "Text Mode") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 171) ( QUOTE START-LINE) (QUOTE 1961) (QUOTE END-LINE) (QUOTE 1971) (QUOTE REF-LIST) ( QUOTE (DOC3 DOC193)))) (SETQ DOC172 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Transpose Characters") (QUOTE TYPE) (QUOTE COMMAND) ( QUOTE INDEX) (QUOTE 172) (QUOTE START-LINE) (QUOTE 1972) (QUOTE END-LINE) ( QUOTE 1983) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176)))) (SETQ DOC173 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Forms") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 173) (QUOTE START-LINE) ( QUOTE 1984) (QUOTE END-LINE) (QUOTE 1996) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176 DOC194 DOC195)))) (SETQ DOC174 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Transpose Lines") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 174) (QUOTE START-LINE) (QUOTE 1997) (QUOTE END-LINE) (QUOTE 2007) (QUOTE REF-LIST) (QUOTE (DOC2 DOC176)))) (SETQ DOC175 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Regions") (QUOTE TYPE) ( QUOTE COMMAND) (QUOTE INDEX) (QUOTE 175) (QUOTE START-LINE) (QUOTE 2008) ( QUOTE END-LINE) (QUOTE 2019) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC176 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Transpose Words") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 176) ( QUOTE START-LINE) (QUOTE 2020) (QUOTE END-LINE) (QUOTE 2035) (QUOTE REF-LIST) ( QUOTE (DOC2 DOC193)))) (SETQ DOC177 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Two Windows") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 177) (QUOTE START-LINE) (QUOTE 2036) (QUOTE END-LINE) (QUOTE 2045) ( QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC178 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Undelete File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 178) (QUOTE START-LINE) (QUOTE 2046) (QUOTE END-LINE) (QUOTE 2059) (QUOTE REF-LIST) (QUOTE (DOC10 DOC8 DOC196)))) (SETQ DOC179 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Universal Argument") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 179) (QUOTE START-LINE) (QUOTE 2060) (QUOTE END-LINE) (QUOTE 2070) (QUOTE REF-LIST) (QUOTE (DOC14)))) (SETQ DOC180 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Unkill Previous") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 180) (QUOTE START-LINE) (QUOTE 2071) (QUOTE END-LINE) (QUOTE 2086) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17 DOC22)))) (SETQ DOC181 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Upcase Digit") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 181) (QUOTE START-LINE) ( QUOTE 2087) (QUOTE END-LINE) (QUOTE 2098) (QUOTE REF-LIST) (QUOTE (DOC2)))) ( SETQ DOC182 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Initial") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 182) (QUOTE START-LINE) (QUOTE 2099) (QUOTE END-LINE) (QUOTE 2109) (QUOTE REF-LIST) (QUOTE (DOC2 DOC193)))) (SETQ DOC183 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 183) (QUOTE START-LINE) (QUOTE 2110) (QUOTE END-LINE) (QUOTE 2119) (QUOTE REF-LIST) (QUOTE (DOC2 DOC17)))) (SETQ DOC184 ( MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Uppercase Word") ( QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 184) (QUOTE START-LINE) ( QUOTE 2120) (QUOTE END-LINE) (QUOTE 2130) (QUOTE REF-LIST) (QUOTE (DOC2 DOC193)))) (SETQ DOC185 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) ( QUOTE "View Two Windows") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 185) (QUOTE START-LINE) (QUOTE 2131) (QUOTE END-LINE) (QUOTE 2139) (QUOTE REF-LIST) (QUOTE (DOC1)))) (SETQ DOC186 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) ( QUOTE NAME) (QUOTE "Visit File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 186) (QUOTE START-LINE) (QUOTE 2140) (QUOTE END-LINE) (QUOTE 2152) ( QUOTE REF-LIST) (QUOTE (DOC9 DOC8 DOC196)))) (SETQ DOC187 (MAKE-INSTANCE ( QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Visit In Other Window") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 187) (QUOTE START-LINE) (QUOTE 2153) (QUOTE END-LINE) (QUOTE 2166) (QUOTE REF-LIST) (QUOTE (DOC1 DOC9 DOC197 DOC196)))) (SETQ DOC188 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "What Cursor Position") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 188) (QUOTE START-LINE) (QUOTE 2167) (QUOTE END-LINE) (QUOTE 2180) (QUOTE REF-LIST) (QUOTE (DOC5)))) (SETQ DOC189 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write File") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 189) (QUOTE START-LINE) (QUOTE 2181) (QUOTE END-LINE) (QUOTE 2192) (QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) (SETQ DOC190 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write Region") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 190) (QUOTE START-LINE) ( QUOTE 2193) (QUOTE END-LINE) (QUOTE 2203) (QUOTE REF-LIST) (QUOTE (DOC10 DOC17 DOC196)))) (SETQ DOC191 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Write Screen Photo") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) ( QUOTE 191) (QUOTE START-LINE) (QUOTE 2204) (QUOTE END-LINE) (QUOTE 2213) ( QUOTE REF-LIST) (QUOTE (DOC10 DOC196)))) (SETQ DOC192 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "Yank Last Output") (QUOTE TYPE) (QUOTE COMMAND) (QUOTE INDEX) (QUOTE 192) (QUOTE START-LINE) (QUOTE 2214) (QUOTE END-LINE) (QUOTE 2223) (QUOTE REF-LIST) (QUOTE (DOC8 DOC194 DOC195)))) (SETQ DOC193 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "TEXT") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 193) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC194 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "LISP") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 194) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC195 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "LISP") ( QUOTE TYPE) (QUOTE MODE) (QUOTE INDEX) (QUOTE 195) (QUOTE START-LINE) (QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) (SETQ DOC196 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "FILES") ( QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 196) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))) ( SETQ DOC197 (MAKE-INSTANCE (QUOTE DOC-BROWSE-OBJ) (QUOTE NAME) (QUOTE "BUFFERS") (QUOTE TYPE) (QUOTE TOPIC) (QUOTE INDEX) (QUOTE 197) (QUOTE START-LINE) ( QUOTE *UNBOUND*) (QUOTE END-LINE) (QUOTE NIL) (QUOTE REF-LIST) (QUOTE NIL))))) |
Added psl-1983/doc-nmode/frames.lpt version [b4bcf79222].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ###0 Action Type Explanation: Alter Display Format This type of command alters how text is displayed without altering the contents of existing buffers. ###1 Action Type Explanation: Alter Existing Text This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. ###2 Action Type Explanation: Change Mode This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. ###3 Action Type Explanation: Escape Escape from the current level. ###4 Action Type Explanation: Inform This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). ###5 Action Type Explanation: Insert Constant This type of command inserts a character constant like tab or space or a multiple thereof. ###6 Action Type Explanation: Mark This type of command sets mark. ###7 Action Type Explanation: Move Data This command copies some data (which is not a constant wired into the program) from one place to another. ###8 Action Type Explanation: Move Point This type of command moves point. It may move it within a buffer or from buffer to buffer. ###9 Action Type Explanation: Preserve Make a copy of something current and put it somewhere else (usually disc). ###10 Action Type Explanation: Remove This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. ###11 Action Type Explanation: Select This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. ###12 Action Type Explanation: Set Global Variable This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. ###13 Action Type Explanation: Subsequent Command Modifier This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. ###14 Definition: Defun A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). ###15 Definition: Paragraph Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. ###16 Definition: Region The region is that portion of text between point, the current buffer position, and mark. ###17 Definition: Sentence A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. ###18 Global Explanation: Fill Column The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. ###19 Global Explanation: Fill Prefix The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. ###20 Global Explanation: Goal Column This is not yet correctly implemented ###21 Global Explanation: Kill Ring The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. ###22 Command: Append Next Kill Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. ###23 Command: Append To Buffer Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. ###24 Command: Append To File Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. ###25 Command: Apropos Function: apropos-command Key: M-X Apropos Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. ###26 Command: Argument Digit Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. ###27 Command: Auto Fill Mode Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. ###28 Command: Back To Indentation Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. ###29 Command: Backward Kill Sentence Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. ###30 Command: Backward Paragraph Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. ###31 Command: Backward Sentence Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. ###32 Command: Backward Up List Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). ###33 Command: Buffer Browser Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". ###34 Command: Buffer Not Modified Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. ###35 Command: C-X Prefix Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. ###36 Command: Center Line Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. ###37 Command: Copy Region Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. ###38 Command: Count Occurrences Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. ###39 Command: Delete And Expunge File Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. ###40 Command: Delete Backward Hacking Tabs Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. ###41 Command: Delete Blank Lines Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. ###42 Command: Delete File Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. ###43 Command: Delete Forward Character Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. ###44 Command: Delete Horizontal Space Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. ###45 Command: Delete Indentation Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). ###46 Command: Delete Matching Lines Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. ###47 Command: Delete Non-Matching Lines Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. ###48 Command: Dired Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. ###49 Command: Down List Function: down-list Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. Command argument sensitivity not yet implemented. ###50 Command: Edit Directory Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. ###51 Command: End Of Defun Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. ###52 Command: Esc Prefix Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. ###53 Command: Exchange Point And Mark Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. ###54 Command: Exchange Windows Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. ###55 Command: Execute Buffer Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. ###56 Command: Execute File Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. ###57 Command: Execute Form Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. ###58 Command: Exit Nmode Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. ###59 Command: Fill Comment Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. ###60 Command: Fill Paragraph Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. ###61 Command: Fill Region Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. ###62 Command: Find File Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. ###63 Command: Forward Paragraph Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. ###64 Command: Forward Sentence Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. ###65 Command: Forward Up List Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). ###66 Command: Get Register Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. ###67 Command: Grow Window Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). ###68 Command: Help Dispatch Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. ###69 Command: Incremental Search Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. ###70 Command: Indent New line Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. ###71 Command: Insert Buffer Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. ###72 Command: Insert Closing bracket Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. ###73 Command: Insert Comment Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. ###74 Command: Insert Date Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. ###75 Command: Insert File Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. ###76 Command: Insert Kill Buffer Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. ###77 Command: Insert Next Character Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. ###78 Command: Insert Parens Function: insert-parens Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point between them. Also make a space before them if appropriate. With argument, put the ) after the specified number of already existing s-expressions. Thus, with argument 1, puts extra parens around the following s-expression. ###79 Command: Kill Backward Form Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. ###80 Command: Kill Backward Word Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. ###81 Command: Kill Buffer Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. ###82 Command: Kill Forward Form Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. ###83 Command: Kill Forward Word Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. ###84 Command: Kill Line Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. ###85 Command: Kill Region Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. ###86 Command: Kill Sentence Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. ###87 Command: Kill Some Buffers Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. ###88 Command: Lisp Abort Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. ###89 Command: Lisp Backtrace Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. ###90 Command: Lisp Continue Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. ###91 Command: Lisp Help Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" ###92 Command: Lisp Indent Region Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. ###93 Command: Lisp Indent sexpr Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. ###94 Command: Lisp Mode Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. ###95 Command: Lisp Prefix Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. ###96 Command: Lisp Quit Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. ###97 Command: Lisp Retry Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. ###98 Command: Lisp Tab Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. ###99 Command: Lowercase Region Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. ###100 Command: Lowercase Word Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###101 Command: M-X Prefix Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. ###102 Command: Mark Beginning Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. ###103 Command: Mark Defun Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). ###104 Command: Mark End Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. ###105 Command: Mark Form Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. ###106 Command: Mark Paragraph Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. ###107 Command: Mark Whole Buffer Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. ###108 Command: Mark Word Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. ###109 Command: Move Backward Character Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. ###110 Command: Move Backward Defun Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. ###111 Command: Move Backward Form Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. ###112 Command: Move Backward List Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. ###113 Command: Move Backward Word Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. ###114 Command: Move Down Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. ###115 Command: Move Down Extending Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. ###116 Command: Move Forward Character Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. ###117 Command: Move Forward Form Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. ###118 Command: Move Forward List Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. ###119 Command: Move Forward Word Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. ###120 Command: Move To Buffer End Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). ###121 Command: Move To Buffer Start Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). ###122 Command: Move To End Of Line Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. ###123 Command: Move To Screen Edge Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). ###124 Command: Move To Start Of Line Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. ###125 Command: Move Up Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. ###126 Command: Negative Argument Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. ###127 Command: Next Screen Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. ###128 Command: Nmode Abort Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. ###129 Command: Nmode Exit To Superior Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. ###130 Command: Nmode Full Refresh Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. ###131 Command: Nmode Gc Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. ###132 Command: Nmode Invert Video Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. ###133 Command: Nmode Refresh Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. ###134 Command: One Window Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. ###135 Command: Open Line Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. ###136 Command: Other Window Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. ###137 Command: Prepend To File Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. ###138 Command: Previous Screen Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. ###139 Command: Put Register Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. ###140 Command: Query Replace Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. ^L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. ###141 Command: Rename Buffer Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. ###142 Command: Replace String Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. ###143 Command: Reposition Window Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. ###144 Command: Return Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. ###145 Command: Reverse Search Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. ###146 Command: Revert File Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk ###147 Command: Save All Files Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. ###148 Command: Save File Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. ###149 Command: Scroll Other Window Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. ###150 Command: Scroll Window Down Line Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###151 Command: Scroll Window Down Page Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###152 Command: Scroll Window Left Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. ###153 Command: Scroll Window Right Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. ###154 Command: Scroll Window Up Line Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###155 Command: Scroll Window Up Page Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. ###156 Command: Select Buffer Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. ###157 Command: Select Previous Buffer Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. ###158 Command: Set Fill Column Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. ###159 Command: Set Fill Prefix Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. ###160 Command: Set Goal Column Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. ###161 Command: Set Key Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. ###162 Command: Set Mark Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. ###163 Command: Set Visited Filename Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. ###164 Command: Split Line Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. ###165 Command: Start Scripting Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. ###166 Command: Start Timing Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. ###167 Command: Stop Scripting Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. ###168 Command: Stop Timing Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. ###169 Command: Tab To Tab Stop Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. ###170 Command: Text Mode Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. ###171 Command: Transpose Characters Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. ###172 Command: Transpose Forms Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". ###173 Command: Transpose Lines Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". ###174 Command: Transpose Regions Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. ###175 Command: Transpose Words Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. ###176 Command: Two Windows Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. ###177 Command: Undelete File Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. ###178 Command: Universal Argument Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. ###179 Command: Unkill Previous Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. ###180 Command: Upcase Digit Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. ###181 Command: Uppercase Initial Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###182 Command: Uppercase Region Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. ###183 Command: Uppercase Word Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. ###184 Command: View Two Windows Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. ###185 Command: Visit File Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. ###186 Command: Visit In Other Window Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. ###187 Command: What Cursor Position Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. ###188 Command: Write File Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. ###189 Command: Write Region Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. ###190 Command: Write Screen Photo Function: write-screen-photo-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. ###191 Command: Yank Last Output Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. |
Added psl-1983/doc-nmode/function-index.data version [006f7adea5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {append-next-kill-command} idx 14 .silent_index {append-to-buffer-command} idx 14 .silent_index {append-to-file-command} idx 14 .silent_index {apropos-command} idx 14 .silent_index {argument-digit} idx 15 .silent_index {auto-fill-mode-command} idx 15 .silent_index {back-to-indentation-command} idx 16 .silent_index {backward-kill-sentence-command} idx 16 .silent_index {backward-paragraph-command} idx 16 .silent_index {backward-sentence-command} idx 16 .silent_index {backward-up-list-command} idx 17 .silent_index {buffer-browser-command} idx 17 .silent_index {buffer-not-modified-command} idx 17 .silent_index {c-x-prefix} idx 17 .silent_index {center-line-command} idx 18 .silent_index {copy-region} idx 18 .silent_index {count-occurrences-command} idx 18 .silent_index {delete-and-expunge-file-command} idx 18 .silent_index {delete-backward-hacking-tabs-command} idx 19 .silent_index {delete-blank-lines-command} idx 19 .silent_index {delete-file-command} idx 19 .silent_index {delete-forward-character-command} idx 19 .silent_index {delete-horizontal-space-command} idx 20 .silent_index {delete-indentation-command} idx 20 .silent_index {delete-matching-lines-command} idx 20 .silent_index {delete-non-matching-lines-command} idx 20 .silent_index {dired-command} idx 20 .silent_index {down-list} idx 21 .silent_index {edit-directory-command} idx 21 .silent_index {end-of-defun-command} idx 21 .silent_index {esc-prefix} idx 22 .silent_index {exchange-point-and-mark} idx 22 .silent_index {exchange-windows-command} idx 22 .silent_index {execute-buffer-command} idx 22 .silent_index {execute-file-command} idx 22 .silent_index {execute-form-command} idx 23 .silent_index {exit-nmode} idx 23 .silent_index {fill-comment-command} idx 23 .silent_index {fill-paragraph-command} idx 23 .silent_index {fill-region-command} idx 24 .silent_index {find-file-command} idx 24 .silent_index {forward-paragraph-command} idx 24 .silent_index {forward-sentence-command} idx 25 .silent_index {forward-up-list-command} idx 25 .silent_index {get-register-command} idx 25 .silent_index {grow-window-command} idx 25 .silent_index {help-dispatch} idx 26 .silent_index {incremental-search-command} idx 26 .silent_index {indent-new-line-command} idx 26 .silent_index {insert-buffer-command} idx 26 .silent_index {insert-closing-bracket} idx 27 .silent_index {insert-comment-command} idx 27 .silent_index {insert-date-command} idx 27 .silent_index {insert-file-command} idx 27 .silent_index {insert-kill-buffer} idx 28 .silent_index {insert-next-character-command} idx 28 .silent_index {insert-parens} idx 28 .silent_index {kill-backward-form-command} idx 28 .silent_index {kill-backward-word-command} idx 29 .silent_index {kill-buffer-command} idx 29 .silent_index {kill-forward-form-command} idx 29 .silent_index {kill-forward-word-command} idx 29 .silent_index {kill-line} idx 30 .silent_index {kill-region} idx 30 .silent_index {kill-sentence-command} idx 30 .silent_index {kill-some-buffers-command} idx 30 .silent_index {lisp-abort-command} idx 31 .silent_index {lisp-backtrace-command} idx 31 .silent_index {lisp-continue-command} idx 31 .silent_index {lisp-help-command} idx 31 .silent_index {lisp-indent-region-command} idx 32 .silent_index {lisp-indent-sexpr} idx 32 .silent_index {lisp-mode-command} idx 32 .silent_index {lisp-prefix} idx 32 .silent_index {lisp-quit-command} idx 33 .silent_index {lisp-retry-command} idx 33 .silent_index {lisp-tab-command} idx 33 .silent_index {lowercase-region-command} idx 33 .silent_index {lowercase-word-command} idx 34 .silent_index {m-x-prefix} idx 34 .silent_index {mark-beginning-command} idx 34 .silent_index {mark-defun-command} idx 34 .silent_index {mark-end-command} idx 35 .silent_index {mark-form-command} idx 35 .silent_index {mark-paragraph-command} idx 35 .silent_index {mark-whole-buffer-command} idx 35 .silent_index {mark-word-command} idx 35 .silent_index {move-backward-character-command} idx 36 .silent_index {move-backward-defun-command} idx 36 .silent_index {move-backward-form-command} idx 36 .silent_index {move-backward-list-command} idx 36 .silent_index {move-backward-word-command} idx 37 .silent_index {move-down-command} idx 37 .silent_index {move-down-extending-command} idx 37 .silent_index {move-forward-character-command} idx 37 .silent_index {move-forward-form-command} idx 38 .silent_index {move-forward-list-command} idx 38 .silent_index {move-forward-word-command} idx 38 .silent_index {move-to-buffer-end-command} idx 38 .silent_index {move-to-buffer-start-command} idx 39 .silent_index {move-to-end-of-line-command} idx 39 .silent_index {move-to-screen-edge-command} idx 39 .silent_index {move-to-start-of-line-command} idx 39 .silent_index {move-up-command} idx 39 .silent_index {negative-argument} idx 40 .silent_index {next-screen-command} idx 40 .silent_index {nmode-abort-command} idx 40 .silent_index {nmode-exit-to-superior} idx 40 .silent_index {nmode-full-refresh} idx 40 .silent_index {nmode-gc} idx 41 .silent_index {nmode-invert-video} idx 41 .silent_index {nmode-refresh-command} idx 41 .silent_index {one-window-command} idx 41 .silent_index {open-line-command} idx 41 .silent_index {other-window-command} idx 42 .silent_index {prepend-to-file-command} idx 42 .silent_index {previous-screen-command} idx 42 .silent_index {put-register-command} idx 42 .silent_index {query-replace-command} idx 42 .silent_index {rename-buffer-command} idx 43 .silent_index {replace-string-command} idx 43 .silent_index {reposition-window-command} idx 43 .silent_index {return-command} idx 43 .silent_index {reverse-search-command} idx 44 .silent_index {revert-file-command} idx 44 .silent_index {save-all-files-command} idx 44 .silent_index {save-file-command} idx 44 .silent_index {scroll-other-window-command} idx 44 .silent_index {scroll-window-down-line-command} idx 45 .silent_index {scroll-window-down-page-command} idx 45 .silent_index {scroll-window-left-command} idx 45 .silent_index {scroll-window-right-command} idx 45 .silent_index {scroll-window-up-line-command} idx 45 .silent_index {scroll-window-up-page-command} idx 46 .silent_index {select-buffer-command} idx 46 .silent_index {select-previous-buffer-command} idx 46 .silent_index {set-fill-column-command} idx 46 .silent_index {set-fill-prefix-command} idx 47 .silent_index {set-goal-column-command} idx 47 .silent_index {set-key-command} idx 47 .silent_index {set-mark-command} idx 47 .silent_index {set-visited-filename-command} idx 48 .silent_index {split-line-command} idx 48 .silent_index {start-scripting-command} idx 48 .silent_index {start-timing-command} idx 48 .silent_index {stop-scripting-command} idx 49 .silent_index {stop-timing-command} idx 49 .silent_index {tab-to-tab-stop-command} idx 49 .silent_index {text-mode-command} idx 49 .silent_index {transpose-characters-command} idx 50 .silent_index {transpose-forms} idx 50 .silent_index {transpose-lines} idx 50 .silent_index {transpose-regions} idx 50 .silent_index {transpose-words} idx 51 .silent_index {two-windows-command} idx 51 .silent_index {undelete-file-command} idx 51 .silent_index {universal-argument} idx 51 .silent_index {unkill-previous} idx 52 .silent_index {upcase-digit-command} idx 52 .silent_index {uppercase-initial-command} idx 52 .silent_index {uppercase-region-command} idx 52 .silent_index {uppercase-word-command} idx 53 .silent_index {view-two-windows-command} idx 53 .silent_index {visit-file-command} idx 53 .silent_index {visit-in-other-window-command} idx 53 .silent_index {what-cursor-position-command} idx 54 .silent_index {write-file-command} idx 54 .silent_index {write-region-command} idx 54 .silent_index {write-screen-photo-command} idx 54 .silent_index {yank-last-output-command} idx 55 |
Added psl-1983/doc-nmode/key-index.data version [139755ca94].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {C-M-W} idx 14 .silent_index {C-X A} idx 14 .silent_index {M-X Append To File} idx 14 .silent_index {M-X Apropos} idx 14 .silent_index {C-0} idx 15 .silent_index {C-1} idx 15 .silent_index {C-2} idx 15 .silent_index {C-3} idx 15 .silent_index {C-4} idx 15 .silent_index {C-5} idx 15 .silent_index {C-6} idx 15 .silent_index {C-7} idx 15 .silent_index {C-8} idx 15 .silent_index {C-9} idx 15 .silent_index {C-M-0} idx 15 .silent_index {C-M-1} idx 15 .silent_index {C-M-2} idx 15 .silent_index {C-M-3} idx 15 .silent_index {C-M-4} idx 15 .silent_index {C-M-5} idx 15 .silent_index {C-M-6} idx 15 .silent_index {C-M-7} idx 15 .silent_index {C-M-8} idx 15 .silent_index {C-M-9} idx 15 .silent_index {M-0} idx 15 .silent_index {M-1} idx 15 .silent_index {M-2} idx 15 .silent_index {M-3} idx 15 .silent_index {M-4} idx 15 .silent_index {M-5} idx 15 .silent_index {M-6} idx 15 .silent_index {M-7} idx 15 .silent_index {M-8} idx 15 .silent_index {M-9} idx 15 .silent_index {M-X Auto Fill Mode} idx 15 .silent_index {C-M-M} idx 16 .silent_index {C-M-RETURN} idx 16 .silent_index {M-M} idx 16 .silent_index {M-RETURN} idx 16 .silent_index {C-X RUBOUT} idx 16 .silent_index {M-[} idx 16 .silent_index {M-A} idx 16 .silent_index {C-(} idx 17 .silent_index {C-M-(} idx 17 .silent_index {C-M-U} idx 17 .silent_index {C-X C-B} idx 17 .silent_index {M-X List Buffers} idx 17 .silent_index {M-~} idx 17 .silent_index {C-X} idx 17 .silent_index {M-S} idx 18 .silent_index {M-W} idx 18 .silent_index {M-X Count Occurrences} idx 18 .silent_index {M-X How Many} idx 18 .silent_index {M-X Delete And Expunge File} idx 18 .silent_index {BACKSPACE} idx 19 .silent_index {C-RUBOUT} idx 19 .silent_index {RUBOUT} idx 19 .silent_index {C-X C-O} idx 19 .silent_index {M-X Delete File} idx 19 .silent_index {M-X Kill File} idx 19 .silent_index {C-D} idx 19 .silent_index {ESC-P} idx 19 .silent_index {M-\} idx 20 .silent_index {M-^} idx 20 .silent_index {M-X Delete Matching Lines} idx 20 .silent_index {M-X Flush Lines} idx 20 .silent_index {M-X Delete Non-Matching Lines} idx 20 .silent_index {M-X Keep Lines} idx 20 .silent_index {C-X D} idx 20 .silent_index {C-M-D} idx 21 .silent_index {M-X Dired} idx 21 .silent_index {M-X Edit Directory} idx 21 .silent_index {C-M-E} idx 21 .silent_index {C-M-]} idx 21 .silent_index {ESCAPE} idx 22 .silent_index {C-X C-X} idx 22 .silent_index {C-X E} idx 22 .silent_index {M-X Execute Buffer} idx 22 .silent_index {M-X Execute File} idx 22 .silent_index {Lisp-E} idx 23 .silent_index {Lisp-L} idx 23 .silent_index {M-Z} idx 23 .silent_index {M-Q} idx 23 .silent_index {M-G} idx 24 .silent_index {C-X C-F} idx 24 .silent_index {M-X Find File} idx 24 .silent_index {M-]} idx 24 .silent_index {M-E} idx 25 .silent_index {C-)} idx 25 .silent_index {C-M-)} idx 25 .silent_index {C-X G} idx 25 .silent_index {C-X ^} idx 25 .silent_index {C-?} idx 26 .silent_index {M-/} idx 26 .silent_index {M-?} idx 26 .silent_index {C-S} idx 26 .silent_index {NEWLINE} idx 26 .silent_index {M-X Insert Buffer} idx 26 .silent_index {)} idx 27 .silent_index {]} idx 27 .silent_index {M-;} idx 27 .silent_index {M-X Insert Date} idx 27 .silent_index {M-X Insert File} idx 27 .silent_index {C-Y} idx 28 .silent_index {C-Q} idx 28 .silent_index {M-(} idx 28 .silent_index {C-M-RUBOUT} idx 28 .silent_index {M-RUBOUT} idx 29 .silent_index {C-X K} idx 29 .silent_index {M-X Kill Buffer} idx 29 .silent_index {C-M-K} idx 29 .silent_index {M-D} idx 29 .silent_index {C-K} idx 30 .silent_index {ESC-M} idx 30 .silent_index {C-W} idx 30 .silent_index {M-K} idx 30 .silent_index {M-X Kill Some Buffers} idx 30 .silent_index {Lisp-A} idx 31 .silent_index {Lisp-B} idx 31 .silent_index {Lisp-C} idx 31 .silent_index {Lisp-?} idx 31 .silent_index {C-M-\} idx 32 .silent_index {C-M-Q} idx 32 .silent_index {M-X Lisp Mode} idx 32 .silent_index {C-]} idx 32 .silent_index {Lisp-Q} idx 33 .silent_index {Lisp-R} idx 33 .silent_index {C-M-I} idx 33 .silent_index {C-M-TAB} idx 33 .silent_index {TAB} idx 33 .silent_index {C-X C-L} idx 33 .silent_index {M-L} idx 34 .silent_index {C-M-X} idx 34 .silent_index {M-X} idx 34 .silent_index {C-<} idx 34 .silent_index {C-M-BACKSPACE} idx 34 .silent_index {C-M-H} idx 34 .silent_index {M-BACKSPACE} idx 34 .silent_index {C->} idx 35 .silent_index {C-M-@} idx 35 .silent_index {M-H} idx 35 .silent_index {C-X H} idx 35 .silent_index {M-@} idx 35 .silent_index {C-B} idx 36 .silent_index {ESC-D} idx 36 .silent_index {C-M-A} idx 36 .silent_index {C-M-[} idx 36 .silent_index {C-M-B} idx 36 .silent_index {C-M-P} idx 36 .silent_index {ESC-4} idx 37 .silent_index {M-B} idx 37 .silent_index {ESC-B} idx 37 .silent_index {C-N} idx 37 .silent_index {C-F} idx 37 .silent_index {ESC-C} idx 37 .silent_index {C-M-F} idx 38 .silent_index {C-M-N} idx 38 .silent_index {ESC-5} idx 38 .silent_index {M-F} idx 38 .silent_index {ESC-F} idx 38 .silent_index {M->} idx 38 .silent_index {ESC-H} idx 39 .silent_index {M-<} idx 39 .silent_index {C-E} idx 39 .silent_index {M-R} idx 39 .silent_index {C-A} idx 39 .silent_index {C-P} idx 39 .silent_index {ESC-A} idx 39 .silent_index {C--} idx 40 .silent_index {C-M--} idx 40 .silent_index {M--} idx 40 .silent_index {C-V} idx 40 .silent_index {C-G} idx 40 .silent_index {C-X C-Z} idx 40 .silent_index {ESC-J} idx 40 .silent_index {M-X Make Space} idx 41 .silent_index {C-X V} idx 41 .silent_index {C-L} idx 41 .silent_index {C-X 1} idx 41 .silent_index {C-O} idx 41 .silent_index {ESC-L} idx 41 .silent_index {C-X O} idx 42 .silent_index {M-X Prepend To File} idx 42 .silent_index {M-V} idx 42 .silent_index {C-X X} idx 42 .silent_index {M-%} idx 42 .silent_index {M-X Query Replace} idx 42 .silent_index {M-X Rename Buffer} idx 43 .silent_index {C-%} idx 43 .silent_index {M-X Replace String} idx 43 .silent_index {C-M-R} idx 43 .silent_index {RETURN} idx 43 .silent_index {C-R} idx 44 .silent_index {M-X Revert File} idx 44 .silent_index {M-X Save All Files} idx 44 .silent_index {C-X C-S} idx 44 .silent_index {C-M-V} idx 44 .silent_index {ESC-T} idx 45 .silent_index {ESC-V} idx 45 .silent_index {C-X <} idx 45 .silent_index {C-X >} idx 45 .silent_index {ESC-S} idx 45 .silent_index {ESC-U} idx 46 .silent_index {C-X B} idx 46 .silent_index {M-X Select Buffer} idx 46 .silent_index {C-M-L} idx 46 .silent_index {C-X F} idx 46 .silent_index {C-X .} idx 47 .silent_index {C-X C-N} idx 47 .silent_index {M-X Set Key} idx 47 .silent_index {C-@} idx 47 .silent_index {C-SPACE} idx 47 .silent_index {M-X Set Visited Filename} idx 48 .silent_index {C-M-O} idx 48 .silent_index {M-X Start Scripting} idx 48 .silent_index {M-X Start Timing Nmode} idx 48 .silent_index {M-X Stop Scripting} idx 49 .silent_index {M-X Stop Timing Nmode} idx 49 .silent_index {M-I} idx 49 .silent_index {M-TAB} idx 49 .silent_index {TAB} idx 49 .silent_index {M-X Text Mode} idx 49 .silent_index {C-T} idx 50 .silent_index {C-M-T} idx 50 .silent_index {C-X C-T} idx 50 .silent_index {C-X T} idx 50 .silent_index {M-T} idx 51 .silent_index {C-X 2} idx 51 .silent_index {M-X Undelete File} idx 51 .silent_index {C-U} idx 51 .silent_index {M-Y} idx 52 .silent_index {M-'} idx 52 .silent_index {M-C} idx 52 .silent_index {C-X C-U} idx 52 .silent_index {M-U} idx 53 .silent_index {C-X 3} idx 53 .silent_index {C-X C-V} idx 53 .silent_index {M-X Visit File} idx 53 .silent_index {C-X 4} idx 53 .silent_index {C-=} idx 54 .silent_index {C-X =} idx 54 .silent_index {C-X C-W} idx 54 .silent_index {M-X Write File} idx 54 .silent_index {M-X Write Region} idx 54 .silent_index {C-X P} idx 54 .silent_index {Lisp-Y} idx 55 |
Added psl-1983/doc-nmode/manual.ibm version [ef05167e1b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>MANUAL.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/NMODE Reference Manual Preliminary Edition 11 February 1983 11:07:16 This document is a preliminary edition of the NMODE Reference Manual. Do not distribute this document! 201/- 2 - NMODE Manual 201/NMODE Manual - 5 - Introduction 202/1. Introduction 201/This document describes the NMODE text editor. NMODE is an interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified appropriately in areas where NMODE and EMACS differ. 201/Introduction - 6 - NMODE Manual 201/NMODE Manual - 7 - Action Types 202/2. Action Types 201/This section defines a number of 203/action types201/, which are used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Display Format 201/This type of command alters how text is displayed without altering the contents of existing buffers. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Alter Existing Text 201/This type of command alters some part of the existing text, generally transforming and/or moving text rather than just inserting or deleting it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Change Mode 201/This type of command turns some feature(s) of the editor on or off. This may include major modes, minor modes, timing, or scripting. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Escape 201/Escape from the current level. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Inform 201/This type of command informs the user of some property of the text being worked with, or of the state of the editor (including where point is, what the existing buffer(s) is(are), what is in the documentation, etc.). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Insert Constant 201/This type of command inserts a character constant like tab or space or a multiple thereof. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Mark 201/This type of command sets mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Action Types - 8 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Data 201/This command copies some data (which is not a constant wired into the program) from one place to another. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Move Point 201/This type of command moves point. It may move it within a buffer or from buffer to buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Preserve 201/Make a copy of something current and put it somewhere else (usually disc). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Remove 201/This type of command allows a user to get rid of data, either killing or deleting text or removing files or directory entries. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Select 201/This type of command finds particular strings in text, and may perform some action upon them, such as counting, replacement, or deletion. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Set Global Variable 201/This type of command sets some global variable which tends to remain stable for some time, such as prefix variables and key bindings. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Action Type Explanation: Subsequent Command Modifier 201/This type of command modifies the meaning of the keys that immediately follow it, as the prefix commands and the argument commands do. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 9 - Definitions 202/3. Definitions 201/This section defines a number of terms used in the descriptions of NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Defun 201/A defun is a list whose ( falls in column 0. Its end is after the CRLF following its ). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Paragraph 201/Paragraphs are delimited by blank lines and psuedo-blank lines, which are lines which don't match the existing fill prefix (when there is one), and, when in text mode, also by indentation and by text justifier command lines, which are currently defined as lines starting with a period and which are treated as another type of psuedo-blank line. Paragraphs contain the final CRLF after their last test, and contain any immediately preceding empty line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Region 201/The region is that portion of text between point, the current buffer position, and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Definition: Sentence 201/A sentence is ended by a ., ? or ! followed by two spaces or a CRLF (with optional space), with any number of "closing characters" ", ', ) and ] between. A sentence also starts at the start of a paragraph. A sentence also ends at the end of a paragraph. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Definitions - 10 - NMODE Manual 201/NMODE Manual - 11 - Globals 202/4. Globals 201/This section defines a number of conceptual 203/global variables201/, which are referred to in the descriptions of NMODE commands. These 203/globals 201/represent state information that can affect the behavior of various NMODE commands. The value of NMODE globals are set as the result of various NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Column 201/The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Prefix 201/The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Goal Column 201/This is not yet correctly implemented 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Kill Ring 201/The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Globals - 12 - NMODE Manual 201/NMODE Manual - 13 - Command Descriptions 202/5. Command Descriptions 201/This section defines the basic NMODE commands. Each command description includes the following information: 203/command 201/A descriptive name of the command. 203/function 201/The name of the Lisp function that implements the command. 203/key 201/The logical keys on the keyboard that normally have this command attached to them. A 203/logical key 201/includes ordinary keys such as Tab or Rubout, 203/shifted 201/keys using the 202/Control 201/and/or 202/Meta 201/modifiers (e.g., C-F, M-F, and C-M-F), 203/prefixed commands 201/using C-X, C-], or Escape (e.g., C-X C-F, C-] E, and Esc-L), and 203/extended commands 201/using 202/Meta-X 201/(e.g., M-X Delete Matching Lines). 203/action type 201/One of a number of descriptive terms that categorize the behavior of commands. Action types are defined in Chapter 2. 203/mode 201/Some commands are defined only in certain modes. If present, this attribute specifies the mode or modes in which the command is normally defined. 203/topic 201/A keyword that describes the command. Topics are listed in the Topic Index, Chapter 9. 201/Command Descriptions - 14 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append Next Kill 201/Function: append-next-kill-command Key: C-M-W See Global: Kill Ring Action Type: Move Data Make following kill commands append to last batch. Thus, C-K C-K, cursor motion, this command, and C-K C-K, generate one block of killed stuff, containing two lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To Buffer 201/Function: append-to-buffer-command Key: C-X A Topic: Buffers See Definition: Region Action Type: Move Data Append region to specified buffer. The buffer's name is read from the keyboard; the buffer is created if nonexistent. A numeric argument causes us to "prepend" instead. We always insert the text at that buffer's pointer, but when "prepending" we leave the pointer before the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Append To File 201/Function: append-to-file-command Key: M-X Append To File Topic: Files See Definition: Region Action Type: Move Data Append region to end of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Apropos 201/Function: apropos-command Key: M-X Apropos Action Type: Inform M-X Apropos lists functions with names containing a string for which the user is prompted. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 15 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Argument Digit 201/Function: argument-digit Key: C-0 Key: C-1 Key: C-2 Key: C-3 Key: C-4 Key: C-5 Key: C-6 Key: C-7 Key: C-8 Key: C-9 Key: C-M-0 Key: C-M-1 Key: C-M-2 Key: C-M-3 Key: C-M-4 Key: C-M-5 Key: C-M-6 Key: C-M-7 Key: C-M-8 Key: C-M-9 Key: M-0 Key: M-1 Key: M-2 Key: M-3 Key: M-4 Key: M-5 Key: M-6 Key: M-7 Key: M-8 Key: M-9 Action Type: Subsequent Command Modifier Specify numeric argument for next command. Several such digits typed in a row all accumulate. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Auto Fill Mode 201/Function: auto-fill-mode-command Key: M-X Auto Fill Mode See Command: Set Fill Column Action Type: Change Mode Break lines between words at the right margin. A positive argument turns Auto Fill mode on; zero or negative, turns it off. With no argument, the mode is toggled. When Auto Fill mode is on, lines are broken at spaces to fit the right margin (position controlled by Fill Column). You can set the Fill Column with the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 16 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Back To Indentation 201/Function: back-to-indentation-command Key: C-M-M Key: C-M-RETURN Key: M-M Key: M-RETURN Action Type: Move Point Move to end of this line's indentation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Kill Sentence 201/Function: backward-kill-sentence-command Key: C-X RUBOUT See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill back to beginning of sentence. With a command argument n kills backward (n>0) or forward (n>0) by |n| sentences. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Paragraph 201/Function: backward-paragraph-command Key: M-[ See Definition: Paragraph Action Type: Move Point Move backward to start of paragraph. When given argument moves backward (n>0) or forward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Sentence 201/Function: backward-sentence-command Key: M-A See Definition: Sentence Action Type: Move Point Move to beginning of sentence. When given argument moves backward (n>0) or forward (n<0) by |n| sentences where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 17 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Backward Up List 201/Function: backward-up-list-command Key: C-( Key: C-M-( Key: C-M-U Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, backward. Given a command argument n move up |n| levels backward (n>0) or forward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Browser 201/Function: buffer-browser-command Key: C-X C-B Key: M-X List Buffers Topic: Buffers Action Type: Inform Put up a buffer browser subsystem. If an argument is given, then include buffers whose names begin with "+". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Buffer Not Modified 201/Function: buffer-not-modified-command Key: M-~ Topic: Buffers Action Type: Set Global Variable Pretend that this buffer hasn't been altered. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: C-X Prefix 201/Function: c-x-prefix Key: C-X Action Type: Subsequent Command Modifier The command Control-X is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 18 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Center Line 201/Function: center-line-command Key: M-S Topic: Text See Global: Fill Column Action Type: Alter Existing Text Center this line's text within the line. With argument, centers that many lines and moves past. Centers current and preceding lines with negative argument. The width is Fill Column. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Copy Region 201/Function: copy-region Key: M-W See Global: Kill Ring See Definition: Region Action Type: Preserve Stick region into kill-ring without killing it. Like killing and getting back, but doesn't mark buffer modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Count Occurrences 201/Function: count-occurrences-command Key: M-X Count Occurrences Key: M-X How Many Action Type: Inform Counts occurrences of a string, after point. The user is prompted for the string. Case is ignored in the count. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete And Expunge File 201/Function: delete-and-expunge-file-command Key: M-X Delete And Expunge File Topic: Files Action Type: Remove This command prompts the user for the name of the file. NMODE will fill in defaults in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be deleted and expunged, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 19 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Backward Hacking Tabs 201/Function: delete-backward-hacking-tabs-command Key: BACKSPACE Key: C-RUBOUT Key: RUBOUT Mode: Lisp Action Type: Remove Delete character before point, turning tabs into spaces. Rather than deleting a whole tab, the tab is converted into the appropriate number of spaces and then one space is deleted. With positive arguments this operation is performed multiple times on the text before point. With negative arguments this operation is performed multiple times on the text after point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Blank Lines 201/Function: delete-blank-lines-command Key: C-X C-O Action Type: Remove Delete all blank lines around this line's end. If done on a non-blank line, deletes all spaces and tabs at the end of it, and all following blank lines (Lines are blank if they contain only spaces and tabs). If done on a blank line, deletes all preceding blank lines as well. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete File 201/Function: delete-file-command Key: M-X Delete File Key: M-X Kill File Topic: Files Action Type: Remove Delete a file. Prompts for filename. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Forward Character 201/Function: delete-forward-character-command Key: C-D Key: ESC-P See Global: Kill Ring Action Type: Remove Delete character after point. With argument, kill that many characters (saving them). Negative args kill characters backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 20 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Horizontal Space 201/Function: delete-horizontal-space-command Key: M-\ Action Type: Remove Delete all spaces and tabs around point. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Indentation 201/Function: delete-indentation-command Key: M-^ Action Type: Remove Delete CRLF and indentation at front of line. Leaves one space in place of them. With argument, moves down one line first (deleting CRLF after current line). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Matching Lines 201/Function: delete-matching-lines-command Key: M-X Delete Matching Lines Key: M-X Flush Lines Action Type: Select Action Type: Remove Delete Matching Lines: Prompts user for string. Deletes all lines containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Delete Non-Matching Lines 201/Function: delete-non-matching-lines-command Key: M-X Delete Non-Matching Lines Key: M-X Keep Lines Action Type: Select Action Type: Remove Delete Non-Matching Lines: Prompts user for string. Deletes all lines not containing specified string. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Dired 201/Function: dired-command Key: C-X D Run Dired on the directory of the current buffer file. With no argument, edits that directory. With an argument of 1, shows only the versions of the file in the buffer. With an argument of 4, asks for input, only versions of that file are shown. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 21 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Down List 201/Function: down-list Key: C-M-D Mode: Lisp Topic: Lisp Action Type: Move Point Move down one level of list structure, forward. Command argument sensitivity not yet implemented. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Edit Directory 201/Function: edit-directory-command Key: M-X Dired Key: M-X Edit Directory DIRED: Edit a directory. The string argument may contain the filespec (with wildcards of course) D deletes the file which is on the current line. (also K,^D,^K) U undeletes the current line file. Rubout undeletes the previous line file. Space is like ^N - moves down a line. E edit the file. S sorts files according to size, read or write date. R does a reverse sort. ? types a list of commands. Q lists files to be deleted and asks for confirmation: Typing YES deletes them; X aborts; N resumes DIRED. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: End Of Defun 201/Function: end-of-defun-command Key: C-M-E Key: C-M-] Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to end of this or next defun. With argument of 2, finds end of following defun. With argument of -1, finds end of previous defun, etc. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 22 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Esc Prefix 201/Function: esc-prefix Key: ESCAPE Action Type: Subsequent Command Modifier The command esc-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. Used for escape sequences sent by function keys on the keyboard. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Point And Mark 201/Function: exchange-point-and-mark Key: C-X C-X Action Type: Mark Action Type: Move Point Exchange positions of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exchange Windows 201/Function: exchange-windows-command Key: C-X E Action Type: Alter Display Format Exchanges the current window with the other window, which becomes current. In two window mode, the windows swap physical positions. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Buffer 201/Function: execute-buffer-command Key: M-X Execute Buffer Topic: Buffers This command makes NMODE take input from the specified buffer as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute File 201/Function: execute-file-command Key: M-X Execute File Topic: Files This command makes NMODE take input from the specified file as if it were typed in. This command supercedes any such previous request. Newline characters are ignored when reading from a buffer. If a command argument is given then only the last refresh of the screen triggered by the commands actually occurs, otherwise all of the updating of the screen is visible. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 23 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Execute Form 201/Function: execute-form-command Key: Lisp-E Mode: Lisp Topic: Lisp Action Type: Mark Causes the Lisp reader to read and evaluate a form starting at the beginning of the current line. We arrange for output to go to the end of the output buffer. The mark is set at the current location in the input buffer, in case user wants to go back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Exit Nmode 201/Function: exit-nmode Key: Lisp-L Mode: Lisp Topic: Lisp Action Type: Escape Leave NMODE, return to normal listen loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Comment 201/Function: fill-comment-command Key: M-Z See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This command creates a temporary fill prefix from the start of the current line. It replaces the surrounding paragraph (determined using fill-prefix) with a filled version. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Paragraph 201/Function: fill-paragraph-command Key: M-Q Topic: Text See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph Action Type: Alter Existing Text This fills (or justifies) this (or next) paragraph. It leaves point at the a position bearing the same relation to the filled text that the old point did to the old text. A numeric argument triggers justification rather than filling. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 24 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Fill Region 201/Function: fill-region-command Key: M-G Topic: Text See Command: Set Fill Column See Command: Set Fill Prefix See Global: Fill Prefix See Global: Fill Column See Definition: Paragraph See Definition: Sentence Action Type: Alter Existing Text Fill text from point to mark. Fill Column specifies the desired text width. Fill Prefix if present is a string that goes at the front of each line and is not included in the filling. See Set Fill Column and Set Fill Prefix. An explicit argument causes justification instead of filling. Each sentence which ends within a line is followed by two spaces. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Find File 201/Function: find-file-command Key: C-X C-F Key: M-X Find File Topic: Files Topic: Buffers Action Type: Move Data Action Type: Move Point Visit a file in its own buffer. If the file is already in some buffer, select that buffer. Otherwise, visit the file in a buffer named after the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Paragraph 201/Function: forward-paragraph-command Key: M-] Topic: Text See Definition: Paragraph Action Type: Move Point Move forward to end of this or the next paragraph. When given argument moves forward (n>0) or backward (n<0) by |n| paragraphs where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 25 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Sentence 201/Function: forward-sentence-command Key: M-E Topic: Text See Definition: Sentence Action Type: Move Point Move forward to end of this or the next sentence. When given argument moves forward (n>0) or backward (n<0) by |n| sentences. where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Forward Up List 201/Function: forward-up-list-command Key: C-) Key: C-M-) Mode: Lisp Topic: Lisp Action Type: Move Point Move up one level of list structure, forward. Given a command argument n move up |n| levels forward (n>0) or backward (n<0). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Get Register 201/Function: get-register-command Key: C-X G Action Type: Move Data Action Type: Mark Get contents of register (reads name from keyboard). The name is a single letter or digit. Usually leaves the pointer before, and the mark after, the text. With argument, puts point after and mark before. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Grow Window 201/Function: grow-window-command Key: C-X ^ Action Type: Alter Display Format Make this window use more lines. Argument is number of extra lines (can be negative). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 26 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Help Dispatch 201/Function: help-dispatch Key: C-? Key: M-/ Key: M-? Action Type: Inform Prints the documentation of a command (not a function). The command character is read from the terminal. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Incremental Search 201/Function: incremental-search-command Key: C-S Action Type: Move Point Action Type: Select Search for character string as you type it. C-Q quotes special characters. Rubout cancels last character. C-S repeats the search, forward, and C-R repeats it backward. C-R or C-S with search string empty changes the direction of search or brings back search string from previous search. Altmode exits the search. Other Control and Meta chars exit the search and then are executed. If not all the input string can be found, the rest is not discarded. You can rub it out, discard it all with C-G, exit, or use C-R or C-S to search the other way. Quitting a successful search aborts the search and moves point back; quitting a failing search just discards whatever input wasn't found. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Indent New line 201/Function: indent-new-line-command Key: NEWLINE Action Type: Insert Constant This function performs the following actions: Executes whatever function, if any, is associated with <CR>. Executes whatever function, if any, is associated with TAB, as if no command argument was given. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Buffer 201/Function: insert-buffer-command Key: M-X Insert Buffer Topic: Buffers Action Type: Move Data Insert contents of another buffer into existing text. The user is prompted for the buffer name. Point is left just before the inserted material, and mark is left just after it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 27 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Closing bracket 201/Function: insert-closing-bracket Key: ) Key: ] Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert the character typed, which should be a closing bracket, then display the matching opening bracket. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Comment 201/Function: insert-comment-command Key: M-; Mode: Lisp Topic: Lisp Action Type: Insert Constant Move to the end of the current line, then add a "%" and a space at its end. Leave point after the space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Date 201/Function: insert-date-command Key: M-X Insert Date Action Type: Move Data Insert the current time and date after point. The mark is put after the inserted text. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert File 201/Function: insert-file-command Key: M-X Insert File Topic: Files Action Type: Move Data Insert contents of file into existing text. File name is string argument. The pointer is left at the beginning, and the mark at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 28 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Kill Buffer 201/Function: insert-kill-buffer Key: C-Y See Global: Kill Ring Action Type: Move Data Action Type: Mark Re-insert the last stuff killed. Puts point after it and the mark before it. An argument n says un-kill the n'th most recent string of killed stuff (1 = most recent). A null argument (just C-U) means leave point before, mark after. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Next Character 201/Function: insert-next-character-command Key: C-Q Action Type: Move Data Reads a character and inserts it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Insert Parens 201/Function: insert-parens Key: M-( Mode: Lisp Topic: Lisp Action Type: Insert Constant Insert () putting point between them. Also make a space before them if appropriate. With argument, put the ) after the specified number of already existing s-expressions. Thus, with argument 1, puts extra parens around the following s-expression. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Form 201/Function: kill-backward-form-command Key: C-M-RUBOUT Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the last form. With a command argument kill the last (n>0) or next (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 29 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Backward Word 201/Function: kill-backward-word-command Key: M-RUBOUT Topic: Text See Global: Kill Ring Action Type: Remove Kill last word. With a command argument kill the last (n>0) or next (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Buffer 201/Function: kill-buffer-command Key: C-X K Key: M-X Kill Buffer Topic: Buffers Action Type: Remove Kill the buffer with specified name. The buffer name is taken from the keyboard. Name completion is performed by SPACE and RETURN. If the buffer has changes in it, the user is asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Form 201/Function: kill-forward-form-command Key: C-M-K Mode: Lisp Topic: Lisp See Global: Kill Ring Action Type: Remove Kill the next form. With a command argument kill the next (n>0) or last (n<0) |n| forms, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Forward Word 201/Function: kill-forward-word-command Key: M-D Topic: Text See Global: Kill Ring Action Type: Remove Kill the next word. With a command argument kill the next (n>0) or last (n<0) |n| words, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 30 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Line 201/Function: kill-line Key: C-K Key: ESC-M See Global: Kill Ring Action Type: Remove Kill to end of line, or kill an end of line. At the end of a line (only blanks following) kill through the CRLF. Otherwise, kill the rest of the line but not the CRLF. With argument (positive or negative), kill specified number of lines forward or backward respectively. An argument of zero means kill to the beginning of the ine, nothing if at the beginning. Killed text is pushed onto the kill ring for retrieval. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Region 201/Function: kill-region Key: C-W See Global: Kill Ring See Definition: Region Action Type: Remove Kill from point to mark. Use Control-Y and Meta-Y to get it back. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Sentence 201/Function: kill-sentence-command Key: M-K Topic: Text See Global: Kill Ring See Definition: Sentence Action Type: Remove Kill forward to end of sentence. With minus one as an argument it kills back to the beginning of the sentence. Positive or negative arguments mean to kill that many sentences forward or backward respectively. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Kill Some Buffers 201/Function: kill-some-buffers-command Key: M-X Kill Some Buffers Topic: Buffers Action Type: Remove Kill Some Buffers: Offer to kill each buffer, one by one. If the buffer contains a modified file and you say to kill it, you are asked for confirmation. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 31 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Abort 201/Function: lisp-abort-command Key: Lisp-A Mode: Lisp Topic: Lisp Action Type: Escape This command will pop out of an arbitrarily deep break loop. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Backtrace 201/Function: lisp-backtrace-command Key: Lisp-B Mode: Lisp Topic: Lisp Action Type: Inform This lists all the function calls on the stack. It is a good way to see how the offending expression got generated. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Continue 201/Function: lisp-continue-command Key: Lisp-C Mode: Lisp Topic: Lisp Action Type: Escape This causes the expression last printed to be returned as the value of the offending expression. This allows a user to recover from a low level error in an involved calculation if they know what should have been returned by the offending expression. This is also often useful as an automatic stub: If an expression containing an undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Help 201/Function: lisp-help-command Key: Lisp-? Mode: Lisp Topic: Lisp Action Type: Inform If in break print: "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" else print: "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 32 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent Region 201/Function: lisp-indent-region-command Key: C-M-\ Mode: Lisp Topic: Lisp Indent all lines between point and mark. With argument, indents each line to exactly that column. Otherwise, lisp indents each line. A line is processed if its first character is in the region. It tries to preserve the textual context of point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Indent sexpr 201/Function: lisp-indent-sexpr Key: C-M-Q Mode: Lisp Topic: Lisp Lisp Indent each line contained in the next form. This command does NOT respond to command arguments. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Mode 201/Function: lisp-mode-command Key: M-X Lisp Mode Topic: Lisp Action Type: Change Mode Set things up for editing Lisp code. Tab indents for Lisp. Rubout hacks tabs. Lisp execution commands availible. Paragraphs are delimited only by blank lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Prefix 201/Function: lisp-prefix Key: C-] Mode: Lisp Topic: Lisp Action Type: Subsequent Command Modifier The command lisp-prefix is an escape-prefix for more commands. It reads a character (subcommand) and dispatches on it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 33 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Quit 201/Function: lisp-quit-command Key: Lisp-Q Mode: Lisp Topic: Lisp Action Type: Escape This exits the current break loop. It only pops up one level, unlike abort. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Retry 201/Function: lisp-retry-command Key: Lisp-R Mode: Lisp Topic: Lisp Action Type: Escape This tries to evaluate the offending expression again, and to continue the computation. This is often useful after defining a missing function, or assigning a value to a variable. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lisp Tab 201/Function: lisp-tab-command Key: C-M-I Key: C-M-TAB Key: TAB Mode: Lisp Topic: Lisp See Command: Tab To Tab Stop Action Type: Alter Existing Text Indent this line for a Lisp-like language. With arg, moves over and indents that many lines. With negative argument, indents preceding lines. Note that the binding of TAB to this function holds only in Lisp mode. In text mode TAB is bound to the Tab To Tab Stop command and the other keys bound to this function are undefined. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Region 201/Function: lowercase-region-command Key: C-X C-L See Definition: Region Action Type: Alter Existing Text Convert region to lower case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 34 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Lowercase Word 201/Function: lowercase-word-command Key: M-L Topic: Text Action Type: Alter Existing Text Convert one word to lower case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: M-X Prefix 201/Function: m-x-prefix Key: C-M-X Key: M-X Action Type: Subsequent Command Modifier Read an extended command from the terminal with completion. Completion is performed by SPACE and RETURN. This command reads the name of an extended command, with completion, then executes that command. The command may itself prompt for input. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Beginning 201/Function: mark-beginning-command Key: C-< Action Type: Mark Set mark at beginning of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Defun 201/Function: mark-defun-command Key: C-M-BACKSPACE Key: C-M-H Key: M-BACKSPACE Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Mark Put point and mark around this defun (or next). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 35 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark End 201/Function: mark-end-command Key: C-> Action Type: Mark Set mark at end of buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Form 201/Function: mark-form-command Key: C-M-@ Mode: Lisp Topic: Lisp Action Type: Mark Set mark after (n>0) or before (n<0) |n| forms from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Paragraph 201/Function: mark-paragraph-command Key: M-H Topic: Text See Definition: Paragraph Action Type: Mark Action Type: Move Point Put point and mark around this paragraph. In between paragraphs, puts it around the next one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Whole Buffer 201/Function: mark-whole-buffer-command Key: C-X H Action Type: Mark Action Type: Move Point Set point at beginning and mark at end of buffer. Pushes the old point on the mark first, so two pops restore it. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Mark Word 201/Function: mark-word-command Key: M-@ Topic: Text Action Type: Mark Set mark after (n>0) or before (n<0) |n| words from point where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 36 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Character 201/Function: move-backward-character-command Key: C-B Key: ESC-D Action Type: Move Point Move back one character. With argument, move that many characters backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Defun 201/Function: move-backward-defun-command Key: C-M-A Key: C-M-[ Mode: Lisp Topic: Lisp See Definition: Defun Action Type: Move Point Move to beginning of this or previous defun. With a negative argument, moves forward to the beginning of a defun. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Form 201/Function: move-backward-form-command Key: C-M-B Mode: Lisp Topic: Lisp Action Type: Move Point Move back one form. With argument, move that many forms backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward List 201/Function: move-backward-list-command Key: C-M-P Mode: Lisp Topic: Lisp Action Type: Move Point Move back one list. With argument, move that many lists backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 37 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Backward Word 201/Function: move-backward-word-command Key: ESC-4 Key: M-B Topic: Text Action Type: Move Point Move back one word. With argument, move that many words backward. Negative arguments move forward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down 201/Function: move-down-command Key: ESC-B See Global: Goal Column Action Type: Move Point Move point down a line. If a command argument n is given, move point down (n>0) or up (n<0) by |n| lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Down Extending 201/Function: move-down-extending-command Key: C-N See Global: Goal Column Action Type: Move Point Move down vertically to next line. If given an argument moves down (n>0) or up (n<0) |n| lines where n is the command argument. If given without an argument after the last LF in the buffer, makes a new one at the end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Character 201/Function: move-forward-character-command Key: C-F Key: ESC-C Action Type: Move Point Move forward one character. With argument, move that many characters forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 38 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Form 201/Function: move-forward-form-command Key: C-M-F Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one form. With argument, move that many forms forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward List 201/Function: move-forward-list-command Key: C-M-N Mode: Lisp Topic: Lisp Action Type: Move Point Move forward one list. With argument, move that many lists forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Forward Word 201/Function: move-forward-word-command Key: ESC-5 Key: M-F Topic: Text Action Type: Move Point Move forward one word. With argument, move that many words forward. Negative args move backward. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer End 201/Function: move-to-buffer-end-command Key: ESC-F Key: M-> Action Type: Move Point Go to end of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 39 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Buffer Start 201/Function: move-to-buffer-start-command Key: ESC-H Key: M-< Action Type: Move Point Go to beginning of buffer (leaving mark behind). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To End Of Line 201/Function: move-to-end-of-line-command Key: C-E Action Type: Move Point Move point to end of line. With positive argument n goes down n-1 lines, then to the end of line. With zero argument goes up a line, then to line end. With negative argument n goes up |n|+1 lines, then to the end of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Screen Edge 201/Function: move-to-screen-edge-command Key: M-R Action Type: Move Point Jump to top or bottom of screen. Like Control-L except that point is changed instead of the window. With no argument, jumps to the center. An argument specifies the number of lines from the top, (negative args count from the bottom). 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move To Start Of Line 201/Function: move-to-start-of-line-command Key: C-A Action Type: Move Point Move point to beginning of line. With positive argument n goes down n-1 lines, then to the beginning of line. With zero argument goes up a line, then to line beginning. With negative argument n goes up |n|+1 lines, then to the beginning of line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Move Up 201/Function: move-up-command Key: C-P Key: ESC-A See Global: Goal Column Action Type: Move Point Move up vertically to next line. If given an argument moves up (n>0) or down (n<0) |n| lines where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 40 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Negative Argument 201/Function: negative-argument Key: C-- Key: C-M-- Key: M-- Action Type: Subsequent Command Modifier Make argument to next command negative. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Next Screen 201/Function: next-screen-command Key: C-V Action Type: Move Point Move down to display next screenful of text. With argument, moves window down <arg> lines (negative moves up). Just minus as an argument moves up a full screen. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Abort 201/Function: nmode-abort-command Key: C-G Action Type: Escape This command provides a way of aborting input requests. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Exit To Superior 201/Function: nmode-exit-to-superior Key: C-X C-Z Action Type: Escape Go back to EMACS's superior job. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Full Refresh 201/Function: nmode-full-refresh Key: ESC-J Action Type: Alter Display Format This function refreshes the screen after first clearing the display. It it used when the state of the display is in doubt. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 41 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Gc 201/Function: nmode-gc Key: M-X Make Space Reclaims any internal wasted space. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Invert Video 201/Function: nmode-invert-video Key: C-X V Action Type: Alter Display Format Toggle between normal and inverse video. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Nmode Refresh 201/Function: nmode-refresh-command Key: C-L Action Type: Alter Display Format Choose new window putting point at center, top or bottom. With no argument, chooses a window to put point at the center. An argument gives the line to put point on; negative args count from the bottom. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: One Window 201/Function: one-window-command Key: C-X 1 Action Type: Alter Display Format Display only one window. Normally, we display what used to be in the top window, but a numeric argument says to display what was in the bottom one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Open Line 201/Function: open-line-command Key: C-O Key: ESC-L Action Type: Insert Constant Insert a CRLF after point. Differs from ordinary insertion in that point remains before the inserted characters. With positive argument, inserts several CRLFs. With negative argument does nothing. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 42 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Other Window 201/Function: other-window-command Key: C-X O Action Type: Alter Display Format Action Type: Move Point Switch to the other window. In two-window mode, moves cursor to other window. In one-window mode, exchanges contents of visible window with remembered contents of (invisible) window two. An argument means switch windows but select the same buffer in the other window. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Prepend To File 201/Function: prepend-to-file-command Key: M-X Prepend To File Topic: Files See Definition: Region Action Type: Move Data Append region to start of specified file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Previous Screen 201/Function: previous-screen-command Key: M-V Action Type: Move Point Move up to display previous screenful of text. When an argument is present, move the window back (n>0) or forward (n<0) |n| lines, where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Put Register 201/Function: put-register-command Key: C-X X Action Type: Preserve Put point to mark into register (reads name from keyboard). With an argument, the text is also deleted. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Query Replace 201/Function: query-replace-command Key: M-% Key: M-X Query Replace Action Type: Alter Existing Text Action Type: Select Replace occurrences of a string from point to the end of the buffer, asking about each occurrence. Query Replace prompts for the string to be replaced and for its potential replacement. Query Replace displays each occurrence of 201/NMODE Manual - 43 - Command Descriptions the string to be replaced, you then type a character to say what to do. Space => replace it with the potential replacement and show the next copy. Rubout => don't replace, but show next copy. Comma => replace this copy and show result, waiting for next command. ^ => return to site of previous copy. ^L => redisplay screen. Exclamation mark => replace all remaining copys without asking. Period => replace this copy and exit. Escape => just exit. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Rename Buffer 201/Function: rename-buffer-command Key: M-X Rename Buffer Topic: Buffers Action Type: Set Global Variable Change the name of the current buffer. The new name is read from the keyboard. If the user provides an empty string, the buffer name will be set to a truncated version of the filename associated with the buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Replace String 201/Function: replace-string-command Key: C-% Key: M-X Replace String Action Type: Alter Existing Text Action Type: Select Replace string with another from point to buffer end. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reposition Window 201/Function: reposition-window-command Key: C-M-R Mode: Lisp Topic: Lisp Action Type: Alter Display Format Reposition screen window appropriately. Tries to get all of current defun on screen. Never moves the pointer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Return 201/Function: return-command Key: RETURN Action Type: Insert Constant Insert CRLF, or move onto empty line. Repeated by positive argument. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 44 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Reverse Search 201/Function: reverse-search-command Key: C-R See Command: Incremental Search Action Type: Move Point Action Type: Select Incremental Search Backwards. Like Control-S but in reverse. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Revert File 201/Function: revert-file-command Key: M-X Revert File Topic: Files Action Type: Remove Undo changes to a file. Reads back the file being edited from disk 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save All Files 201/Function: save-all-files-command Key: M-X Save All Files Topic: Buffers Topic: Files Action Type: Preserve Offer to write back each buffer which may need it. For each buffer which is visiting a file and which has been modified, you are asked whether to save it. A numeric arg means don't ask; save everything. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Save File 201/Function: save-file-command Key: C-X C-S Topic: Files Action Type: Preserve Save visited file on disk if modified. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Other Window 201/Function: scroll-other-window-command Key: C-M-V Action Type: Alter Display Format Scroll other window up several lines. Specify the number as a numeric argument, negative for down. The default is a whole screenful up. Just Meta-Minus as argument means scroll a whole screenful down. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 45 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Line 201/Function: scroll-window-down-line-command Key: ESC-T Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Down Page 201/Function: scroll-window-down-page-command Key: ESC-V Action Type: Alter Display Format Scroll the contents of the window down (n > 0) or up (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Left 201/Function: scroll-window-left-command Key: C-X < Action Type: Alter Display Format Scroll the contents of the specified window right (n > 0) or left (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Right 201/Function: scroll-window-right-command Key: C-X > Action Type: Alter Display Format Scroll the contents of the specified window left (n > 0) or right (n < 0) by |n| columns where n is the command argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Line 201/Function: scroll-window-up-line-command Key: ESC-S Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 46 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Scroll Window Up Page 201/Function: scroll-window-up-page-command Key: ESC-U Action Type: Alter Display Format Scroll the contents of the window up (n > 0) or down (n < 0) by |n| screenfuls where n is the command argument. The "window position" may be adjusted to keep it within the window. Ding if the window contents does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Buffer 201/Function: select-buffer-command Key: C-X B Key: M-X Select Buffer Topic: Buffers Action Type: Move Point Select or create buffer with specified name. Buffer name is read from keyboard. Name completion is performed by SPACE and RETURN. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Select Previous Buffer 201/Function: select-previous-buffer-command Key: C-M-L Topic: Buffers Action Type: Move Point Select the previous buffer of the current buffer, if it exists and is selectable. Otherwise, select the MAIN buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Column 201/Function: set-fill-column-command Key: C-X F See Global: Fill Column Action Type: Set Global Variable Set fill column to numeric arg or current column. If there is an argument, that is used. Otherwise, the current position of the cursor is used. The Fill Column variable controls where Auto Fill mode and the fill commands put the right margin. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 47 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Fill Prefix 201/Function: set-fill-prefix-command Key: C-X . See Global: Fill Prefix Action Type: Set Global Variable Defines Fill Prefix from current line. All of the current line up to point becomes the value of Fill Prefix. Auto Fill Mode inserts the prefix on each line; the Fill Paragraph command assumes that each non-blank line starts with the prefix (which is ignored for filling purposes). To stop using a Fill Prefix, do Control-X . at the front of a line. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Goal Column 201/Function: set-goal-column-command Key: C-X C-N Action Type: Set Global Variable Set (or flush) a permanent goal for vertical motion. With no argument, makes the current column the goal for vertical motion commands. They will always try to go to that column. With argument, clears out any previously set goal. Only Control-P and Control-N are affected. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Key 201/Function: set-key-command Key: M-X Set Key Action Type: Set Global Variable Put a function on a key. The function name is a string argument. The key is always read from the terminal (not a string argument). It may contain metizers and other prefix characters. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Mark 201/Function: set-mark-command Key: C-@ Key: C-SPACE Action Type: Mark Sets or pops the mark. With no ^U's, pushes point as the mark. With one ^U, pops the mark into point. With two ^U's, pops the mark and throws it away. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 48 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Set Visited Filename 201/Function: set-visited-filename-command Key: M-X Set Visited Filename Topic: Files Action Type: Set Global Variable Change visited filename, without writing file. The user is prompted for a filename. What NMODE believes to be the name of the visited file associated with the current buffer is set from the user's input. No file's name is actually changed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Split Line 201/Function: split-line-command Key: C-M-O Action Type: Insert Constant Move rest of this line vertically down. Inserts a CRLF, and then enough tabs/spaces so that what had been the rest of the current line is indented as much as it had been. Point does not move, except to skip over indentation that originally followed it. With positive argument, makes extra blank lines in between. No action with negative argument. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Scripting 201/Function: start-scripting-command Key: M-X Start Scripting Action Type: Change Mode This function prompts the user for a buffer name, into which it will copy all the user's commands (as well as executing them) until the stop-scripting-command is invoked. This command supercedes any such previous request. Note that to keep the lines of reasonable length, free Newlines will be inserted from time to time. Because of this, and because many file systems cannot represent stray Newlines, the Newline character is itself scripted as a CR followed by a TAB, since this is its normal definition. Someday, perhaps, this hack will be replaced by a better one. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Start Timing 201/Function: start-timing-command Key: M-X Start Timing Nmode Action Type: Change Mode This cleans up a number of global variables associated with timing, prompts for a file in which to put the timing data (or defaults to a file named "timing", of type "txt"), and starts the timing. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 49 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Scripting 201/Function: stop-scripting-command Key: M-X Stop Scripting Action Type: Change Mode This command stops the echoing of user commands into a script buffer. This command is itself echoed before the creation of the script stops. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Stop Timing 201/Function: stop-timing-command Key: M-X Stop Timing Nmode Action Type: Change Mode This stops the timing, formats the output data, and closes the file into which the timing information is going. Information is collected on the total time, refresh time, read time, command execution time, total number of cons cells built, and total number of garbage collections performed. In addition to these numbers, some ratios are printed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Tab To Tab Stop 201/Function: tab-to-tab-stop-command Key: M-I Key: M-TAB Key: TAB See Command: Lisp Tab Action Type: Insert Constant Insert a tab character. Note that the binding of TAB to this command only holds in text mode, not in lisp mode, where it is bound to the Lisp Tab command. In lisp mode, the other keys continue to be bound to this command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Text Mode 201/Function: text-mode-command Key: M-X Text Mode Topic: Text Action Type: Change Mode Set things up for editing English text. Tab inserts tab characters. There are no comments. Auto Fill does not indent new lines. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 50 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Characters 201/Function: transpose-characters-command Key: C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the characters before and after the cursor. For more details, see Meta-T, reading "character" for "word". However: at the end of a line, with no argument, the preceding two characters are transposed. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Forms 201/Function: transpose-forms Key: C-M-T Mode: Lisp Topic: Lisp See Command: Transpose Words Action Type: Alter Existing Text Transpose the forms before and after the cursor. For more details, see Meta-T, reading "Form" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Lines 201/Function: transpose-lines Key: C-X C-T See Command: Transpose Words Action Type: Alter Existing Text Transpose the lines before and after the cursor. For more details, see Meta-T, reading "Line" for "Word". 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Regions 201/Function: transpose-regions Key: C-X T See Definition: Region Action Type: Alter Existing Text Transpose regions defined by cursor and last 3 marks. To transpose two non-overlapping regions, set the mark successively at three of the four boundaries, put point at the fourth, and call this function. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 51 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Transpose Words 201/Function: transpose-words Key: M-T Topic: Text Action Type: Alter Existing Text Transpose the words before and after the cursor. With a positive argument it transposes the words before and after the cursor, moves right, and repeats the specified number of times, dragging the word to the left of the cursor right. With a negative argument, it transposes the two words to the left of the cursor, moves between them, and repeats the specified number of times, exactly undoing the positive argument form. With a zero argument, it transposes the words at point and mark. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Two Windows 201/Function: two-windows-command Key: C-X 2 Action Type: Alter Display Format Show two windows and select window two. An argument > 1 means give window 2 the same buffer as in Window 1. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Undelete File 201/Function: undelete-file-command Key: M-X Undelete File Topic: Files Action Type: Move Data Action Type: Preserve This command prompts the user for the name of the file. NMODE will fill in a partly specified filename (eg filetype can be defaulted). If possible, the file will then be undeleted, and a message to that effect will be displayed. If the operation fails, the bell will sound. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Universal Argument 201/Function: universal-argument Key: C-U Action Type: Subsequent Command Modifier Sets argument or multiplies it by four. Followed by digits, uses them to specify the argument for the command after the digits. If not followed by digits, multiplies the argument by four. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 52 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Unkill Previous 201/Function: unkill-previous Key: M-Y See Global: Kill Ring See Definition: Region Action Type: Alter Existing Text Delete (without saving away) the current region, and then unkill (yank) the specified entry in the kill ring. "Ding" if the current region does not contain the same text as the current entry in the kill ring. If one has just retrieved the top entry from the kill ring this has the effect of displaying the item just beneath it, then the item beneath that and so on until the original top entry rotates back into view. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Upcase Digit 201/Function: upcase-digit-command Key: M-' Action Type: Alter Existing Text Convert last digit to shifted character. Looks on current line back from point, and previous line. The first time you use this command, it asks you to type the row of digits from 1 to 9 and then 0, holding down Shift, to determine how your keyboard is set up. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Initial 201/Function: uppercase-initial-command Key: M-C Topic: Text Action Type: Alter Existing Text Put next word in lower case, but capitalize initial. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Region 201/Function: uppercase-region-command Key: C-X C-U See Definition: Region Action Type: Alter Existing Text Convert region to upper case. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 53 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Uppercase Word 201/Function: uppercase-word-command Key: M-U Topic: Text Action Type: Alter Existing Text Convert one word to upper case, moving past it. With arg, applies to that many words backward or forward. If backward, the cursor does not move. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: View Two Windows 201/Function: view-two-windows-command Key: C-X 3 Action Type: Alter Display Format Show two windows but stay in first. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit File 201/Function: visit-file-command Key: C-X C-V Key: M-X Visit File Topic: Files Action Type: Move Data Action Type: Move Point Visit new file in current buffer. The user is prompted for the filename. If the current buffer is modified, the user is asked whether to write it out. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Visit In Other Window 201/Function: visit-in-other-window-command Key: C-X 4 Topic: Files Topic: Buffers Action Type: Move Point Action Type: Alter Display Format Find buffer or file in other window. Follow this command by B and a buffer name, or by F and a file name. We find the buffer or file in the other window, creating the other window if necessary. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 54 - NMODE Manual 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: What Cursor Position 201/Function: what-cursor-position-command Key: C-= Key: C-X = Action Type: Inform Print various things about where cursor is. Print the X position, the Y position, the octal code for the following character, point absolutely and as a percentage of the total file size, and the virtual boundaries, if any. If a positive argument is given point will jump to the line number specified by the argument. A negative argument triggers a jump to the first line in the buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write File 201/Function: write-file-command Key: C-X C-W Key: M-X Write File Topic: Files Action Type: Preserve Prompts for file name. Stores the current buffer in specified file. This file becomes the one being visited. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Region 201/Function: write-region-command Key: M-X Write Region Topic: Files See Definition: Region Action Type: Preserve Write region to file. Prompts for file name. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Write Screen Photo 201/Function: write-screen-photo-command Key: C-X P Topic: Files Action Type: Preserve Ask for filename, write out the screen to the file. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/NMODE Manual - 55 - Command Descriptions 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Command: Yank Last Output 201/Function: yank-last-output-command Key: Lisp-Y Mode: Lisp Topic: Lisp Action Type: Move Data Insert "last output" typed in the OUTPUT buffer. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Command Descriptions - 56 - NMODE Manual 201/NMODE Manual - 57 - Command Index 202/6. Command Index 201/Append Next Kill . . . . . . . . . . . . . . . . . . . . 14 Append To Buffer . . . . . . . . . . . . . . . . . . . . 14 Append To File . . . . . . . . . . . . . . . . . . . . . 14 Apropos . . . . . . . . . . . . . . . . . . . . . . . . . 14 Argument Digit . . . . . . . . . . . . . . . . . . . . . 15 Auto Fill Mode . . . . . . . . . . . . . . . . . . . . . . 15 Back To Indentation . . . . . . . . . . . . . . . . . . . 16 Backward Kill Sentence . . . . . . . . . . . . . . . . . 16 Backward Paragraph . . . . . . . . . . . . . . . . . . . 16 Backward Sentence . . . . . . . . . . . . . . . . . . . . 16 Backward Up List . . . . . . . . . . . . . . . . . . . . 17 Buffer Browser . . . . . . . . . . . . . . . . . . . . . 17 Buffer Not Modified . . . . . . . . . . . . . . . . . . . 17 C-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 Center Line . . . . . . . . . . . . . . . . . . . . . . . 18 Copy Region . . . . . . . . . . . . . . . . . . . . . . . 18 Count Occurrences . . . . . . . . . . . . . . . . . . . . 18 Delete And Expunge File . . . . . . . . . . . . . . . . . 18 Delete Backward Hacking Tabs . . . . . . . . . . . . . . 19 Delete Blank Lines . . . . . . . . . . . . . . . . . . . . 19 Delete File . . . . . . . . . . . . . . . . . . . . . . . . 19 Delete Forward Character . . . . . . . . . . . . . . . . 19 Delete Horizontal Space . . . . . . . . . . . . . . . . . 20 Delete Indentation . . . . . . . . . . . . . . . . . . . . 20 Delete Matching Lines . . . . . . . . . . . . . . . . . . 20 Delete Non-Matching Lines . . . . . . . . . . . . . . . . 20 Dired . . . . . . . . . . . . . . . . . . . . . . . . . . 20 Down List . . . . . . . . . . . . . . . . . . . . . . . . 21 Edit Directory . . . . . . . . . . . . . . . . . . . . . . 21 End Of Defun . . . . . . . . . . . . . . . . . . . . . . 21 Esc Prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 Exchange Point And Mark . . . . . . . . . . . . . . . . 22 Exchange Windows . . . . . . . . . . . . . . . . . . . . 22 Execute Buffer . . . . . . . . . . . . . . . . . . . . . . 22 Execute File . . . . . . . . . . . . . . . . . . . . . . . 22 Execute Form . . . . . . . . . . . . . . . . . . . . . . 23 Exit Nmode . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Comment . . . . . . . . . . . . . . . . . . . . . . . 23 Fill Paragraph . . . . . . . . . . . . . . . . . . . . . . 23 Fill Region . . . . . . . . . . . . . . . . . . . . . . . . 24 Find File . . . . . . . . . . . . . . . . . . . . . . . . . 24 Forward Paragraph . . . . . . . . . . . . . . . . . . . . 24 Forward Sentence . . . . . . . . . . . . . . . . . . . . 25 Forward Up List . . . . . . . . . . . . . . . . . . . . . 25 201/Command Index - 58 - NMODE Manual Get Register . . . . . . . . . . . . . . . . . . . . . . . 25 Grow Window . . . . . . . . . . . . . . . . . . . . . . . 25 Help Dispatch . . . . . . . . . . . . . . . . . . . . . . 26 Incremental Search . . . . . . . . . . . . . . . . . . . . 26 Indent New line . . . . . . . . . . . . . . . . . . . . . 26 Insert Buffer . . . . . . . . . . . . . . . . . . . . . . 26 Insert Closing bracket . . . . . . . . . . . . . . . . . . 27 Insert Comment . . . . . . . . . . . . . . . . . . . . . 27 Insert Date . . . . . . . . . . . . . . . . . . . . . . . 27 Insert File . . . . . . . . . . . . . . . . . . . . . . . . 27 Insert Kill Buffer . . . . . . . . . . . . . . . . . . . . 28 Insert Next Character . . . . . . . . . . . . . . . . . . 28 Insert Parens . . . . . . . . . . . . . . . . . . . . . . 28 Kill Backward Form . . . . . . . . . . . . . . . . . . . 28 Kill Backward Word . . . . . . . . . . . . . . . . . . . 29 Kill Buffer . . . . . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Form . . . . . . . . . . . . . . . . . . . . 29 Kill Forward Word . . . . . . . . . . . . . . . . . . . . 29 Kill Line . . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Region . . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Sentence . . . . . . . . . . . . . . . . . . . . . . . 30 Kill Some Buffers . . . . . . . . . . . . . . . . . . . . 30 Lisp Abort . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Backtrace . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Continue . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Help . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp Indent Region . . . . . . . . . . . . . . . . . . . . 32 Lisp Indent sexpr . . . . . . . . . . . . . . . . . . . . 32 Lisp Mode . . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Prefix . . . . . . . . . . . . . . . . . . . . . . . 32 Lisp Quit . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Retry . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp Tab . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lowercase Region . . . . . . . . . . . . . . . . . . . . 33 Lowercase Word . . . . . . . . . . . . . . . . . . . . . 34 M-X Prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 Mark Beginning . . . . . . . . . . . . . . . . . . . . . 34 Mark Defun . . . . . . . . . . . . . . . . . . . . . . . 34 Mark End . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Form . . . . . . . . . . . . . . . . . . . . . . . . 35 Mark Paragraph . . . . . . . . . . . . . . . . . . . . . 35 Mark Whole Buffer . . . . . . . . . . . . . . . . . . . . 35 Mark Word . . . . . . . . . . . . . . . . . . . . . . . . 35 Move Backward Character . . . . . . . . . . . . . . . . 36 Move Backward Defun . . . . . . . . . . . . . . . . . . 36 Move Backward Form . . . . . . . . . . . . . . . . . . . 36 Move Backward List . . . . . . . . . . . . . . . . . . . 36 Move Backward Word . . . . . . . . . . . . . . . . . . . 37 201/NMODE Manual - 59 - Command Index Move Down . . . . . . . . . . . . . . . . . . . . . . . . 37 Move Down Extending . . . . . . . . . . . . . . . . . . 37 Move Forward Character . . . . . . . . . . . . . . . . . 37 Move Forward Form . . . . . . . . . . . . . . . . . . . 38 Move Forward List . . . . . . . . . . . . . . . . . . . . 38 Move Forward Word . . . . . . . . . . . . . . . . . . . 38 Move To Buffer End . . . . . . . . . . . . . . . . . . . 38 Move To Buffer Start . . . . . . . . . . . . . . . . . . 39 Move To End Of Line . . . . . . . . . . . . . . . . . . 39 Move To Screen Edge . . . . . . . . . . . . . . . . . . 39 Move To Start Of Line . . . . . . . . . . . . . . . . . . 39 Move Up . . . . . . . . . . . . . . . . . . . . . . . . . 39 Negative Argument . . . . . . . . . . . . . . . . . . . . 40 Next Screen . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Abort . . . . . . . . . . . . . . . . . . . . . . . 40 Nmode Exit To Superior . . . . . . . . . . . . . . . . . 40 Nmode Full Refresh . . . . . . . . . . . . . . . . . . . 40 Nmode Gc . . . . . . . . . . . . . . . . . . . . . . . . 41 Nmode Invert Video . . . . . . . . . . . . . . . . . . . 41 Nmode Refresh . . . . . . . . . . . . . . . . . . . . . . 41 One Window . . . . . . . . . . . . . . . . . . . . . . . 41 Open Line . . . . . . . . . . . . . . . . . . . . . . . . 41 Other Window . . . . . . . . . . . . . . . . . . . . . . 42 Prepend To File . . . . . . . . . . . . . . . . . . . . . 42 Previous Screen . . . . . . . . . . . . . . . . . . . . . 42 Put Register . . . . . . . . . . . . . . . . . . . . . . . 42 Query Replace . . . . . . . . . . . . . . . . . . . . . . 42 Rename Buffer . . . . . . . . . . . . . . . . . . . . . . 43 Replace String . . . . . . . . . . . . . . . . . . . . . . 43 Reposition Window . . . . . . . . . . . . . . . . . . . . 43 Return . . . . . . . . . . . . . . . . . . . . . . . . . . 43 Reverse Search . . . . . . . . . . . . . . . . . . . . . 44 Revert File . . . . . . . . . . . . . . . . . . . . . . . 44 Save All Files . . . . . . . . . . . . . . . . . . . . . . 44 Save File . . . . . . . . . . . . . . . . . . . . . . . . 44 Scroll Other Window . . . . . . . . . . . . . . . . . . . 44 Scroll Window Down Line . . . . . . . . . . . . . . . . . 45 Scroll Window Down Page . . . . . . . . . . . . . . . . . 45 Scroll Window Left . . . . . . . . . . . . . . . . . . . . 45 Scroll Window Right . . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Line . . . . . . . . . . . . . . . . . . 45 Scroll Window Up Page . . . . . . . . . . . . . . . . . . 46 Select Buffer . . . . . . . . . . . . . . . . . . . . . . 46 Select Previous Buffer . . . . . . . . . . . . . . . . . . 46 Set Fill Column . . . . . . . . . . . . . . . . . . . . . 46 Set Fill Prefix . . . . . . . . . . . . . . . . . . . . . . 47 Set Goal Column . . . . . . . . . . . . . . . . . . . . . 47 201/Command Index - 60 - NMODE Manual Set Key . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Mark . . . . . . . . . . . . . . . . . . . . . . . . . 47 Set Visited Filename . . . . . . . . . . . . . . . . . . . 48 Split Line . . . . . . . . . . . . . . . . . . . . . . . . 48 Start Scripting . . . . . . . . . . . . . . . . . . . . . . 48 Start Timing . . . . . . . . . . . . . . . . . . . . . . . 48 Stop Scripting . . . . . . . . . . . . . . . . . . . . . . 49 Stop Timing . . . . . . . . . . . . . . . . . . . . . . . 49 Tab To Tab Stop . . . . . . . . . . . . . . . . . . . . 49 Text Mode . . . . . . . . . . . . . . . . . . . . . . . . 49 Transpose Characters . . . . . . . . . . . . . . . . . . 50 Transpose Forms . . . . . . . . . . . . . . . . . . . . . 50 Transpose Lines . . . . . . . . . . . . . . . . . . . . . 50 Transpose Regions . . . . . . . . . . . . . . . . . . . . 50 Transpose Words . . . . . . . . . . . . . . . . . . . . . 51 Two Windows . . . . . . . . . . . . . . . . . . . . . . . 51 Undelete File . . . . . . . . . . . . . . . . . . . . . . . 51 Universal Argument . . . . . . . . . . . . . . . . . . . 51 Unkill Previous . . . . . . . . . . . . . . . . . . . . . 52 Upcase Digit . . . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Initial . . . . . . . . . . . . . . . . . . . . . 52 Uppercase Region . . . . . . . . . . . . . . . . . . . . 52 Uppercase Word . . . . . . . . . . . . . . . . . . . . . 53 View Two Windows . . . . . . . . . . . . . . . . . . . . 53 Visit File . . . . . . . . . . . . . . . . . . . . . . . . 53 Visit In Other Window . . . . . . . . . . . . . . . . . . 53 What Cursor Position . . . . . . . . . . . . . . . . . . . 54 Write File . . . . . . . . . . . . . . . . . . . . . . . . 54 Write Region . . . . . . . . . . . . . . . . . . . . . . . 54 Write Screen Photo . . . . . . . . . . . . . . . . . . . . 54 Yank Last Output . . . . . . . . . . . . . . . . . . . . 55 201/NMODE Manual - 61 - Function Index 202/7. Function Index 201/append-next-kill-command . . . . . . . . . . . . . . . . 14 append-to-buffer-command . . . . . . . . . . . . . . . . 14 append-to-file-command . . . . . . . . . . . . . . . . . 14 apropos-command . . . . . . . . . . . . . . . . . . . . . 14 argument-digit . . . . . . . . . . . . . . . . . . . . . . 15 auto-fill-mode-command . . . . . . . . . . . . . . . . . . 15 back-to-indentation-command . . . . . . . . . . . . . . . 16 backward-kill-sentence-command . . . . . . . . . . . . . 16 backward-paragraph-command . . . . . . . . . . . . . . 16 backward-sentence-command . . . . . . . . . . . . . . . 16 backward-up-list-command . . . . . . . . . . . . . . . . 17 buffer-browser-command . . . . . . . . . . . . . . . . . 17 buffer-not-modified-command . . . . . . . . . . . . . . . 17 c-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 17 center-line-command . . . . . . . . . . . . . . . . . . . 18 copy-region . . . . . . . . . . . . . . . . . . . . . . . 18 count-occurrences-command . . . . . . . . . . . . . . . 18 delete-and-expunge-file-command . . . . . . . . . . . . . 18 delete-backward-hacking-tabs-command . . . . . . . . . . 19 delete-blank-lines-command . . . . . . . . . . . . . . . . 19 delete-file-command . . . . . . . . . . . . . . . . . . . 19 delete-forward-character-command . . . . . . . . . . . . 19 delete-horizontal-space-command . . . . . . . . . . . . . 20 delete-indentation-command . . . . . . . . . . . . . . . . 20 delete-matching-lines-command . . . . . . . . . . . . . . 20 delete-non-matching-lines-command . . . . . . . . . . . . 20 dired-command . . . . . . . . . . . . . . . . . . . . . . 20 down-list . . . . . . . . . . . . . . . . . . . . . . . . 21 edit-directory-command . . . . . . . . . . . . . . . . . . 21 end-of-defun-command . . . . . . . . . . . . . . . . . . 21 esc-prefix . . . . . . . . . . . . . . . . . . . . . . . . 22 exchange-point-and-mark . . . . . . . . . . . . . . . . . 22 exchange-windows-command . . . . . . . . . . . . . . . 22 execute-buffer-command . . . . . . . . . . . . . . . . . 22 execute-file-command . . . . . . . . . . . . . . . . . . . 22 execute-form-command . . . . . . . . . . . . . . . . . . 23 exit-nmode . . . . . . . . . . . . . . . . . . . . . . . . 23 fill-comment-command . . . . . . . . . . . . . . . . . . . 23 fill-paragraph-command . . . . . . . . . . . . . . . . . . 23 fill-region-command . . . . . . . . . . . . . . . . . . . 24 find-file-command . . . . . . . . . . . . . . . . . . . . 24 forward-paragraph-command . . . . . . . . . . . . . . . 24 forward-sentence-command . . . . . . . . . . . . . . . . 25 forward-up-list-command . . . . . . . . . . . . . . . . . 25 201/Function Index - 62 - NMODE Manual get-register-command . . . . . . . . . . . . . . . . . . 25 grow-window-command . . . . . . . . . . . . . . . . . . 25 help-dispatch . . . . . . . . . . . . . . . . . . . . . . 26 incremental-search-command . . . . . . . . . . . . . . . 26 indent-new-line-command . . . . . . . . . . . . . . . . . 26 insert-buffer-command . . . . . . . . . . . . . . . . . . 26 insert-closing-bracket . . . . . . . . . . . . . . . . . . 27 insert-comment-command . . . . . . . . . . . . . . . . . 27 insert-date-command . . . . . . . . . . . . . . . . . . . 27 insert-file-command . . . . . . . . . . . . . . . . . . . 27 insert-kill-buffer . . . . . . . . . . . . . . . . . . . . . 28 insert-next-character-command . . . . . . . . . . . . . . 28 insert-parens . . . . . . . . . . . . . . . . . . . . . . 28 kill-backward-form-command . . . . . . . . . . . . . . . 28 kill-backward-word-command . . . . . . . . . . . . . . . 29 kill-buffer-command . . . . . . . . . . . . . . . . . . . 29 kill-forward-form-command . . . . . . . . . . . . . . . . 29 kill-forward-word-command . . . . . . . . . . . . . . . . 29 kill-line . . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-region . . . . . . . . . . . . . . . . . . . . . . . . 30 kill-sentence-command . . . . . . . . . . . . . . . . . . 30 kill-some-buffers-command . . . . . . . . . . . . . . . . 30 lisp-abort-command . . . . . . . . . . . . . . . . . . . . 31 lisp-backtrace-command . . . . . . . . . . . . . . . . . 31 lisp-continue-command . . . . . . . . . . . . . . . . . . 31 lisp-help-command . . . . . . . . . . . . . . . . . . . . 31 lisp-indent-region-command . . . . . . . . . . . . . . . . 32 lisp-indent-sexpr . . . . . . . . . . . . . . . . . . . . 32 lisp-mode-command . . . . . . . . . . . . . . . . . . . . 32 lisp-prefix . . . . . . . . . . . . . . . . . . . . . . . . 32 lisp-quit-command . . . . . . . . . . . . . . . . . . . . 33 lisp-retry-command . . . . . . . . . . . . . . . . . . . . 33 lisp-tab-command . . . . . . . . . . . . . . . . . . . . . 33 lowercase-region-command . . . . . . . . . . . . . . . . 33 lowercase-word-command . . . . . . . . . . . . . . . . . 34 m-x-prefix . . . . . . . . . . . . . . . . . . . . . . . . 34 mark-beginning-command . . . . . . . . . . . . . . . . . 34 mark-defun-command . . . . . . . . . . . . . . . . . . . 34 mark-end-command . . . . . . . . . . . . . . . . . . . . 35 mark-form-command . . . . . . . . . . . . . . . . . . . 35 mark-paragraph-command . . . . . . . . . . . . . . . . . 35 mark-whole-buffer-command . . . . . . . . . . . . . . . 35 mark-word-command . . . . . . . . . . . . . . . . . . . 35 move-backward-character-command . . . . . . . . . . . . 36 move-backward-defun-command . . . . . . . . . . . . . . 36 move-backward-form-command . . . . . . . . . . . . . . 36 move-backward-list-command . . . . . . . . . . . . . . . 36 move-backward-word-command . . . . . . . . . . . . . . 37 201/NMODE Manual - 63 - Function Index move-down-command . . . . . . . . . . . . . . . . . . . 37 move-down-extending-command . . . . . . . . . . . . . . 37 move-forward-character-command . . . . . . . . . . . . . 37 move-forward-form-command . . . . . . . . . . . . . . . 38 move-forward-list-command . . . . . . . . . . . . . . . . 38 move-forward-word-command . . . . . . . . . . . . . . . 38 move-to-buffer-end-command . . . . . . . . . . . . . . . 38 move-to-buffer-start-command . . . . . . . . . . . . . . 39 move-to-end-of-line-command . . . . . . . . . . . . . . . 39 move-to-screen-edge-command . . . . . . . . . . . . . . 39 move-to-start-of-line-command . . . . . . . . . . . . . . 39 move-up-command . . . . . . . . . . . . . . . . . . . . 39 negative-argument . . . . . . . . . . . . . . . . . . . . 40 next-screen-command . . . . . . . . . . . . . . . . . . . 40 nmode-abort-command . . . . . . . . . . . . . . . . . . 40 nmode-exit-to-superior . . . . . . . . . . . . . . . . . . 40 nmode-full-refresh . . . . . . . . . . . . . . . . . . . . 40 nmode-gc . . . . . . . . . . . . . . . . . . . . . . . . 41 nmode-invert-video . . . . . . . . . . . . . . . . . . . . 41 nmode-refresh-command . . . . . . . . . . . . . . . . . 41 one-window-command . . . . . . . . . . . . . . . . . . . 41 open-line-command . . . . . . . . . . . . . . . . . . . . 41 other-window-command . . . . . . . . . . . . . . . . . . 42 prepend-to-file-command . . . . . . . . . . . . . . . . . 42 previous-screen-command . . . . . . . . . . . . . . . . . 42 put-register-command . . . . . . . . . . . . . . . . . . 42 query-replace-command . . . . . . . . . . . . . . . . . . 42 rename-buffer-command . . . . . . . . . . . . . . . . . 43 replace-string-command . . . . . . . . . . . . . . . . . 43 reposition-window-command . . . . . . . . . . . . . . . . 43 return-command . . . . . . . . . . . . . . . . . . . . . 43 reverse-search-command . . . . . . . . . . . . . . . . . 44 revert-file-command . . . . . . . . . . . . . . . . . . . 44 save-all-files-command . . . . . . . . . . . . . . . . . . 44 save-file-command . . . . . . . . . . . . . . . . . . . . 44 scroll-other-window-command . . . . . . . . . . . . . . . 44 scroll-window-down-line-command . . . . . . . . . . . . . 45 scroll-window-down-page-command . . . . . . . . . . . . 45 scroll-window-left-command . . . . . . . . . . . . . . . . 45 scroll-window-right-command . . . . . . . . . . . . . . . 45 scroll-window-up-line-command . . . . . . . . . . . . . . 45 scroll-window-up-page-command . . . . . . . . . . . . . 46 select-buffer-command . . . . . . . . . . . . . . . . . . 46 select-previous-buffer-command . . . . . . . . . . . . . 46 set-fill-column-command . . . . . . . . . . . . . . . . . 46 set-fill-prefix-command . . . . . . . . . . . . . . . . . . 47 set-goal-column-command . . . . . . . . . . . . . . . . . 47 201/Function Index - 64 - NMODE Manual set-key-command . . . . . . . . . . . . . . . . . . . . . 47 set-mark-command . . . . . . . . . . . . . . . . . . . . 47 set-visited-filename-command . . . . . . . . . . . . . . . 48 split-line-command . . . . . . . . . . . . . . . . . . . . 48 start-scripting-command . . . . . . . . . . . . . . . . . 48 start-timing-command . . . . . . . . . . . . . . . . . . . 48 stop-scripting-command . . . . . . . . . . . . . . . . . 49 stop-timing-command . . . . . . . . . . . . . . . . . . . 49 tab-to-tab-stop-command . . . . . . . . . . . . . . . . . 49 text-mode-command . . . . . . . . . . . . . . . . . . . . 49 transpose-characters-command . . . . . . . . . . . . . . 50 transpose-forms . . . . . . . . . . . . . . . . . . . . . 50 transpose-lines . . . . . . . . . . . . . . . . . . . . . . 50 transpose-regions . . . . . . . . . . . . . . . . . . . . 50 transpose-words . . . . . . . . . . . . . . . . . . . . . 51 two-windows-command . . . . . . . . . . . . . . . . . . 51 undelete-file-command . . . . . . . . . . . . . . . . . . 51 universal-argument . . . . . . . . . . . . . . . . . . . . 51 unkill-previous . . . . . . . . . . . . . . . . . . . . . . 52 upcase-digit-command . . . . . . . . . . . . . . . . . . 52 uppercase-initial-command . . . . . . . . . . . . . . . . 52 uppercase-region-command . . . . . . . . . . . . . . . . 52 uppercase-word-command . . . . . . . . . . . . . . . . . 53 view-two-windows-command . . . . . . . . . . . . . . . . 53 visit-file-command . . . . . . . . . . . . . . . . . . . . 53 visit-in-other-window-command . . . . . . . . . . . . . . 53 what-cursor-position-command . . . . . . . . . . . . . . 54 write-file-command . . . . . . . . . . . . . . . . . . . . 54 write-region-command . . . . . . . . . . . . . . . . . . 54 write-screen-photo-command . . . . . . . . . . . . . . . 54 yank-last-output-command . . . . . . . . . . . . . . . . 55 201/NMODE Manual - 65 - Key Index 202/8. Key Index 201/) . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 BACKSPACE . . . . . . . . . . . . . . . . . . . . . . . 19 C-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-) . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-= . . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-( . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-) . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-M-- . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . 15 C-M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-M-A . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-B . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-BACKSPACE . . . . . . . . . . . . . . . . . . . . 34 C-M-D . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-M-E . . . . . . . . . . . . . . . . . . . . . . . . . . 21 201/Key Index - 66 - NMODE Manual C-M-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-H . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-I . . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-M-L . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-M-M . . . . . . . . . . . . . . . . . . . . . . . . . . 16 C-M-N . . . . . . . . . . . . . . . . . . . . . . . . . . 38 C-M-O . . . . . . . . . . . . . . . . . . . . . . . . . . 48 C-M-P . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 32 C-M-R . . . . . . . . . . . . . . . . . . . . . . . . . . 43 C-M-RETURN . . . . . . . . . . . . . . . . . . . . . . 16 C-M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . 28 C-M-T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-M-TAB . . . . . . . . . . . . . . . . . . . . . . . . 33 C-M-U . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-M-V . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-M-W . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-M-X . . . . . . . . . . . . . . . . . . . . . . . . . . 34 C-M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . 36 C-M-] . . . . . . . . . . . . . . . . . . . . . . . . . . 21 C-N . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 C-O . . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-P . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 C-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 19 C-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 C-SPACE . . . . . . . . . . . . . . . . . . . . . . . . 47 C-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X < . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X 1 . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X 2 . . . . . . . . . . . . . . . . . . . . . . . . . . 51 C-X 3 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X 4 . . . . . . . . . . . . . . . . . . . . . . . . . . 53 C-X = . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X > . . . . . . . . . . . . . . . . . . . . . . . . . . 45 C-X A . . . . . . . . . . . . . . . . . . . . . . . . . . 14 C-X B . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X C-B . . . . . . . . . . . . . . . . . . . . . . . . . 17 C-X C-F . . . . . . . . . . . . . . . . . . . . . . . . . 24 C-X C-L . . . . . . . . . . . . . . . . . . . . . . . . . 33 C-X C-N . . . . . . . . . . . . . . . . . . . . . . . . . 47 C-X C-O . . . . . . . . . . . . . . . . . . . . . . . . . 19 C-X C-S . . . . . . . . . . . . . . . . . . . . . . . . . 44 C-X C-T . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X C-U . . . . . . . . . . . . . . . . . . . . . . . . . 52 C-X C-V . . . . . . . . . . . . . . . . . . . . . . . . . 53 201/NMODE Manual - 67 - Key Index C-X C-W . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X C-X . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X C-Z . . . . . . . . . . . . . . . . . . . . . . . . . 40 C-X D . . . . . . . . . . . . . . . . . . . . . . . . . . 20 C-X E . . . . . . . . . . . . . . . . . . . . . . . . . . 22 C-X F . . . . . . . . . . . . . . . . . . . . . . . . . . 46 C-X G . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-X H . . . . . . . . . . . . . . . . . . . . . . . . . . 35 C-X K . . . . . . . . . . . . . . . . . . . . . . . . . . 29 C-X O . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X P . . . . . . . . . . . . . . . . . . . . . . . . . . 54 C-X RUBOUT . . . . . . . . . . . . . . . . . . . . . . 16 C-X T . . . . . . . . . . . . . . . . . . . . . . . . . . 50 C-X V . . . . . . . . . . . . . . . . . . . . . . . . . . 41 C-X X . . . . . . . . . . . . . . . . . . . . . . . . . . 42 C-X ^ . . . . . . . . . . . . . . . . . . . . . . . . . . 25 C-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 C-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 32 ESC-4 . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-5 . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-A . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-B . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-C . . . . . . . . . . . . . . . . . . . . . . . . . . 37 ESC-D . . . . . . . . . . . . . . . . . . . . . . . . . . 36 ESC-F . . . . . . . . . . . . . . . . . . . . . . . . . . 38 ESC-H . . . . . . . . . . . . . . . . . . . . . . . . . . 39 ESC-J . . . . . . . . . . . . . . . . . . . . . . . . . . 40 ESC-L . . . . . . . . . . . . . . . . . . . . . . . . . . 41 ESC-M . . . . . . . . . . . . . . . . . . . . . . . . . . 30 ESC-P . . . . . . . . . . . . . . . . . . . . . . . . . . 19 ESC-S . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-T . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESC-U . . . . . . . . . . . . . . . . . . . . . . . . . . 46 ESC-V . . . . . . . . . . . . . . . . . . . . . . . . . . 45 ESCAPE . . . . . . . . . . . . . . . . . . . . . . . . . 22 Lisp-? . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-A . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-B . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-C . . . . . . . . . . . . . . . . . . . . . . . . . . 31 Lisp-E . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-L . . . . . . . . . . . . . . . . . . . . . . . . . . 23 Lisp-Q . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-R . . . . . . . . . . . . . . . . . . . . . . . . . . 33 Lisp-Y . . . . . . . . . . . . . . . . . . . . . . . . . . 55 M-\ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-% . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-' . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-( . . . . . . . . . . . . . . . . . . . . . . . . . . . 28 M-- . . . . . . . . . . . . . . . . . . . . . . . . . . . 40 M-/ . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 201/Key Index - 68 - NMODE Manual M-0 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-1 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-2 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-3 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-4 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-5 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-6 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-7 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-8 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-9 . . . . . . . . . . . . . . . . . . . . . . . . . . . 15 M-; . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 M-< . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-> . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-? . . . . . . . . . . . . . . . . . . . . . . . . . . . 26 M-@ . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-A . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-B . . . . . . . . . . . . . . . . . . . . . . . . . . . 37 M-BACKSPACE . . . . . . . . . . . . . . . . . . . . . . 34 M-C . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-D . . . . . . . . . . . . . . . . . . . . . . . . . . . 29 M-E . . . . . . . . . . . . . . . . . . . . . . . . . . . 25 M-F . . . . . . . . . . . . . . . . . . . . . . . . . . . 38 M-G . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-H . . . . . . . . . . . . . . . . . . . . . . . . . . . 35 M-I . . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-K . . . . . . . . . . . . . . . . . . . . . . . . . . . 30 M-L . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-M . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-Q . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-R . . . . . . . . . . . . . . . . . . . . . . . . . . . 39 M-RETURN . . . . . . . . . . . . . . . . . . . . . . . . 16 M-RUBOUT . . . . . . . . . . . . . . . . . . . . . . . 29 M-S . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-T . . . . . . . . . . . . . . . . . . . . . . . . . . . 51 M-TAB . . . . . . . . . . . . . . . . . . . . . . . . . . 49 M-U . . . . . . . . . . . . . . . . . . . . . . . . . . . 53 M-V . . . . . . . . . . . . . . . . . . . . . . . . . . . 42 M-W . . . . . . . . . . . . . . . . . . . . . . . . . . . 18 M-X . . . . . . . . . . . . . . . . . . . . . . . . . . . 34 M-X Append To File . . . . . . . . . . . . . . . . . . . 14 M-X Apropos . . . . . . . . . . . . . . . . . . . . . . . 14 M-X Auto Fill Mode . . . . . . . . . . . . . . . . . . . 15 M-X Count Occurrences . . . . . . . . . . . . . . . . . 18 M-X Delete And Expunge File . . . . . . . . . . . . . . 18 M-X Delete File . . . . . . . . . . . . . . . . . . . . . 19 M-X Delete Matching Lines . . . . . . . . . . . . . . . . 20 M-X Delete Non-Matching Lines . . . . . . . . . . . . . . 20 M-X Dired . . . . . . . . . . . . . . . . . . . . . . . . 21 M-X Edit Directory . . . . . . . . . . . . . . . . . . . . 21 M-X Execute Buffer . . . . . . . . . . . . . . . . . . . 22 M-X Execute File . . . . . . . . . . . . . . . . . . . . . 22 M-X Find File . . . . . . . . . . . . . . . . . . . . . . 24 M-X Flush Lines . . . . . . . . . . . . . . . . . . . . . 20 201/NMODE Manual - 69 - Key Index M-X How Many . . . . . . . . . . . . . . . . . . . . . . 18 M-X Insert Buffer . . . . . . . . . . . . . . . . . . . . 26 M-X Insert Date . . . . . . . . . . . . . . . . . . . . . 27 M-X Insert File . . . . . . . . . . . . . . . . . . . . . 27 M-X Keep Lines . . . . . . . . . . . . . . . . . . . . . 20 M-X Kill Buffer . . . . . . . . . . . . . . . . . . . . . 29 M-X Kill File . . . . . . . . . . . . . . . . . . . . . . . 19 M-X Kill Some Buffers . . . . . . . . . . . . . . . . . . 30 M-X Lisp Mode . . . . . . . . . . . . . . . . . . . . . . 32 M-X List Buffers . . . . . . . . . . . . . . . . . . . . . 17 M-X Make Space . . . . . . . . . . . . . . . . . . . . . 41 M-X Prepend To File . . . . . . . . . . . . . . . . . . . 42 M-X Query Replace . . . . . . . . . . . . . . . . . . . 42 M-X Rename Buffer . . . . . . . . . . . . . . . . . . . 43 M-X Replace String . . . . . . . . . . . . . . . . . . . 43 M-X Revert File . . . . . . . . . . . . . . . . . . . . . 44 M-X Save All Files . . . . . . . . . . . . . . . . . . . . 44 M-X Select Buffer . . . . . . . . . . . . . . . . . . . . 46 M-X Set Key . . . . . . . . . . . . . . . . . . . . . . . 47 M-X Set Visited Filename . . . . . . . . . . . . . . . . . 48 M-X Start Scripting . . . . . . . . . . . . . . . . . . . 48 M-X Start Timing Nmode . . . . . . . . . . . . . . . . . 48 M-X Stop Scripting . . . . . . . . . . . . . . . . . . . 49 M-X Stop Timing Nmode . . . . . . . . . . . . . . . . . 49 M-X Text Mode . . . . . . . . . . . . . . . . . . . . . 49 M-X Undelete File . . . . . . . . . . . . . . . . . . . . 51 M-X Visit File . . . . . . . . . . . . . . . . . . . . . . 53 M-X Write File . . . . . . . . . . . . . . . . . . . . . . 54 M-X Write Region . . . . . . . . . . . . . . . . . . . . 54 M-Y . . . . . . . . . . . . . . . . . . . . . . . . . . . 52 M-Z . . . . . . . . . . . . . . . . . . . . . . . . . . . 23 M-[ . . . . . . . . . . . . . . . . . . . . . . . . . . . 16 M-] . . . . . . . . . . . . . . . . . . . . . . . . . . . 24 M-^ . . . . . . . . . . . . . . . . . . . . . . . . . . . 20 M-~ . . . . . . . . . . . . . . . . . . . . . . . . . . . 17 NEWLINE . . . . . . . . . . . . . . . . . . . . . . . . . 26 RETURN . . . . . . . . . . . . . . . . . . . . . . . . . 43 RUBOUT . . . . . . . . . . . . . . . . . . . . . . . . . 19 TAB . . . . . . . . . . . . . . . . . . . . . . . . . . . 33, 49 ] . . . . . . . . . . . . . . . . . . . . . . . . . . . . 27 201/Key Index - 70 - NMODE Manual 201/NMODE Manual - 71 - Topic Index 202/9. Topic Index 201/Alter Display Format . . . . . . . 7, 22, 25, 40, 41, 42, 43, 44, 45, 46, 51, 53 Alter Existing Text . . . . . . . 7, 18, 23, 24, 33, 34, 42, 43, 50, 51, 52, 53 Buffers . . . . . . . . . . . . . 14, 17, 22, 24, 26, 29, 30, 43, 44, 46, 53 Change Mode . . . . . . . . . . . 7, 15, 32, 48, 49 Defun . . . . . . . . . . . . . . 9, 21, 34, 36 Escape . . . . . . . . . . . . . . 7, 23, 31, 33, 40 Files . . . . . . . . . . . . . . . 14, 18, 19, 22, 24, 27, 42, 44, 48, 51, 53, 54 Fill Column . . . . . . . . . . . 11, 18, 23, 24, 46 Fill Prefix . . . . . . . . . . . . 11, 23, 24, 47 Goal Column . . . . . . . . . . . 11, 37, 39 Inform . . . . . . . . . . . . . . 7, 14, 17, 18, 26, 31, 54 Insert Constant . . . . . . . . . 7, 26, 27, 28, 41, 43, 48, 49 Kill Ring . . . . . . . . . . . . . 11, 14, 16, 18, 19, 28, 29, 30, 52 Lisp . . . . . . . . . . . . . . . 17, 21, 23, 25, 27, 28, 29, 31, 32, 33, 34, 35, 36, 38, 43, 50, 55 Mark . . . . . . . . . . . . . . . 7, 22, 23, 25, 28, 34, 35, 47 Move Data . . . . . . . . . . . . 8, 14, 24, 25, 26, 27, 28, 42, 51, 53, 55 Move Point . . . . . . . . . . . . 8, 16, 17, 21, 22, 24, 25, 26, 35, 36, 37, 38, 39, 40, 42, 44, 46, 53 Paragraph . . . . . . . . . . . . 9, 16, 23, 24, 35 Preserve . . . . . . . . . . . . . 8, 18, 42, 44, 51, 54 Region . . . . . . . . . . . . . . 9, 14, 18, 30, 33, 42, 50, 52, 54 Remove . . . . . . . . . . . . . 8, 16, 18, 19, 20, 28, 29, 30, 44 Select . . . . . . . . . . . . . . 8, 20, 26, 42, 43, 44 Sentence . . . . . . . . . . . . . 9, 16, 24, 25, 30 Set Global Variable . . . . . . . . 8, 17, 43, 46, 47, 48 Subsequent Command Modifier . . 8, 15, 17, 22, 32, 34, 40, 51 Text . . . . . . . . . . . . . . . 18, 23, 24, 25, 29, 30, 34, 35, 37, 38, 49, 51, 52, 53 201/Topic Index - 72 - NMODE Manual 201/NMODE Manual - 3 - Table of Contents 202/CONTENTS 1. Introduction ..................................................... 5 2. Action Types .................................................... 7 3. Definitions ....................................................... 9 4. Globals ......................................................... 11 5. Command Descriptions ........................................... 13 6. Command Index ................................................. 57 7. Function Index .................................................. 61 8. Key Index ...................................................... 65 9. Topic Index ..................................................... 71 |
Added psl-1983/doc-nmode/nm-contents.ibm version [a5f139418f].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ,MOD - R 44X (28 February 1983) <PSL.NMODE-DOC>NM-CONTENTS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/Contents NMODE Manual Page \i Chapter 1. Introduction |
Added psl-1983/doc-nmode/nm-globals.ibm version [ca248cc005].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (28 February 1983) <PSL.NMODE-DOC>NM-GLOBALS.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/Globals NMODE Manual Page 4-1 202/4. Globals 201/This section defines a number of conceptual 203/global variables201/, which are referred to in the descriptions of NMODE commands. These 203/globals 201/represent state information that can affect the behavior of various NMODE commands. The value of NMODE globals are set as the result of various NMODE commands. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Column 201/The fill column is the column beyond which all the fill commands: auto fill, fill paragraph, fill region, and fill comment, will try to break up lines. The fill column can be set by the Set Fill Column command. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Fill Prefix 201/The fill prefix, if present, is a string that the fill paragraph and fill region commands expect to see on the areas that they are filling. It is useful, for instance, in filling indented text. Only the indented area will be filled, and any new lines created by the filling will be properly indented. Autofill will also insert it on each new line it starts. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Goal Column 201/The goal column is set or unset using the C-X C-N command. When the goal column is defined, the commands C-N and C-P will always leave the cursor at the specified column position, if the current line is sufficiently long. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 202/Global Explanation: Kill Ring 201/The kill ring is a stack of the 16 most recently killed pieces of text. The Insert Kill Buffer command reads text on the top of the kill ring and inserts it back into the buffer. It can accept an argument, specifying an argument other than the top one. If one knows that the text one wants is on the kill ring, but is not certain how deeply it is buried, one can retrieve the top item with the Insert Kill Buffer command, then look through the other items one by one with the Unkill Previous command. This rotates the items on the kill ring, displaying them one by one in a cycle. Most kill commands push their text onto the top of the kill ring. If two kill commands are performed right after each other, the text they kill is concatenated. Commands the kill forward add onto the end of the previously killed text. Commands that kill backward add onto the beginning. That way, the text is assembled in its original order. If intervening commands have taken place one can issue an Append Next Kill command before the next kill in order to assemble the next killed text together with the text on top of the kill ring. 204/$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 201/Page 4-2 NMODE Manual Globals |
Added psl-1983/doc-nmode/nm-globals.topic version [ae2a64215c].
> > > > | 1 2 3 4 | .silent_index {Fill Column} idx 1 .silent_index {Fill Prefix} idx 1 .silent_index {Goal Column} idx 1 .silent_index {Kill Ring} idx 1 |
Added psl-1983/doc-nmode/nm-introduction.contents version [6fc63e9e44].
> | 1 | contents_entry(0 1 {Introduction} 1-1) |
Added psl-1983/doc-nmode/nm-introduction.ibm version [8ce6cff0f7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (28 February 1983) <PSL.NMODE-DOC>NM-INTRODUCTION.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 201/Introduction NMODE Manual Page 1-1 202/1. Introduction 201/This document describes the NMODE text editor. NMODE is an interactive, multiple-window, screen-oriented editor written in PSL (Portable Standard Lisp). NMODE provides a compatible subset of the EMACS text editor, developed at M.I.T. It also contains a number of extensions, most notably an interface to the underlying Lisp system for Lisp programmers. NMODE was developed at the Hewlett-Packard Laboratories Computer Research Center by Alan Snyder. A number of significant extensions have been contributed by Jeff Soreff. NMODE is based on an earlier editor, EMODE, written in PSL by William F. Galway at the University of Utah. Many of the basic ideas and the underlying structure of the NMODE editor come directly from EMODE. This document is only partially complete, but is being reprinted at this time for the benefit of new users that are not familiar with EMACS. The bulk of this document has been borrowed from EMACS documentation and modified appropriately in areas where NMODE and EMACS differ. |
Added psl-1983/doc-nmode/simple-chart.ibm version [15c7e20a19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ,MOD - R 44X (11 February 1983) <PSL.NMODE-DOC>SIMPLE-CHART.ibm PLA 97_LAS 80 0_FIR 2_INT 1 6.0_TYP 160 163 162 193_INP 12 101_MAR 2 ,END ,PRO 201 OUT 160_202 OUT 163_203 OUT 162_204 OUT 193 205 INP 12 101_206 INP 12 102 ,END ,DEFINE UNIT SPACE FUNCTION ,END 202/Simplified 9836 NMODE Command Summary 201/10 February 1983 202/Information 201/Show Function on Key M-? List Matching Commands <help> 202/Files 201/Find File C-X C-F Save File C-X C-S 202/Buffers 201/Select Buffer C-X B List Buffers C-X C-B Go to Buffer Start M-< (or) <clr-end> Go to Buffer End M-> (or) Shift-<clr-end> Kill Buffer C-X K 202/Characters 201/Move Forward Character C-F (or) <right-arrow> Move Backward Character C-B (or) <left-arrow> Forward Delete Character C-D (or) <del-chr> Backward Delete Character Rubout Quote Character C-Q 202/Lines 201/Move to Next Line C-N (or) <down-arrow> Move to Previous Line C-P (or) <up-arrow> Goto Start of Line C-A Goto End of Line C-E Kill Line C-K (or) <del-ln> Insert Blank Line C-O (or) <ins-ln> 202/Killing and Unkilling Text 201/Kill Line C-K (or) <del-ln> Yank Killed Text C-Y Yank Previous Kill M-Y 202/String Search 201/Foward Search C-S Reverse Search C-R 202/String Replacement 201/Query Replace M-% Replace String C-% 202/Indentation 201/Indent Line Tab Indent New Line Newline 202/Text Filling and Justification 201/Fill Paragraph M-Q Fill Comment M-Z Auto Fill Mode (toggle) M-X Auto Fill Mode 202/Modes 201/Enter Lisp Mode M-X Lisp Mode Enter Text Mode M-X Text Mode 202/Lisp Execution 201/Execute Form C-] E Execute Defun C-] D Quit from Break Loop C-] Q Backtrace from Break Loop C-] B Retry from Break Loop C-] R 202/Screen Management 201/Redisplay Screen C-L Scroll to Next Screenful C-V (or) <recall> Scroll to Previous Screenful M-V (or) Shift-<recall> 202/Windows 201/Two Windows C-X 2 One Window C-X 1 Go to Other Window C-X O |
Added psl-1983/doc-nmode/topic-index.data version [106b197364].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .silent_index {Alter Display Format} idx 7 .silent_index {Alter Existing Text} idx 7 .silent_index {Change Mode} idx 7 .silent_index {Escape} idx 7 .silent_index {Inform} idx 7 .silent_index {Insert Constant} idx 7 .silent_index {Mark} idx 7 .silent_index {Move Data} idx 8 .silent_index {Move Point} idx 8 .silent_index {Preserve} idx 8 .silent_index {Remove} idx 8 .silent_index {Select} idx 8 .silent_index {Set Global Variable} idx 8 .silent_index {Subsequent Command Modifier} idx 8 .silent_index {Defun} idx 9 .silent_index {Paragraph} idx 9 .silent_index {Region} idx 9 .silent_index {Sentence} idx 9 .silent_index {Fill Column} idx 11 .silent_index {Fill Prefix} idx 11 .silent_index {Goal Column} idx 11 .silent_index {Kill Ring} idx 11 .silent_index {Kill Ring} idx 14 .silent_index {Move Data} idx 14 .silent_index {Buffers} idx 14 .silent_index {Region} idx 14 .silent_index {Move Data} idx 14 .silent_index {Files} idx 14 .silent_index {Region} idx 14 .silent_index {Move Data} idx 14 .silent_index {Inform} idx 14 .silent_index {Subsequent Command Modifier} idx 15 .silent_index {Change Mode} idx 15 .silent_index {Move Point} idx 16 .silent_index {Kill Ring} idx 16 .silent_index {Sentence} idx 16 .silent_index {Remove} idx 16 .silent_index {Paragraph} idx 16 .silent_index {Move Point} idx 16 .silent_index {Sentence} idx 16 .silent_index {Move Point} idx 16 .silent_index {Lisp} idx 17 .silent_index {Move Point} idx 17 .silent_index {Buffers} idx 17 .silent_index {Inform} idx 17 .silent_index {Buffers} idx 17 .silent_index {Set Global Variable} idx 17 .silent_index {Subsequent Command Modifier} idx 17 .silent_index {Text} idx 18 .silent_index {Fill Column} idx 18 .silent_index {Alter Existing Text} idx 18 .silent_index {Kill Ring} idx 18 .silent_index {Region} idx 18 .silent_index {Preserve} idx 18 .silent_index {Inform} idx 18 .silent_index {Files} idx 18 .silent_index {Remove} idx 18 .silent_index {Remove} idx 19 .silent_index {Remove} idx 19 .silent_index {Files} idx 19 .silent_index {Remove} idx 19 .silent_index {Kill Ring} idx 19 .silent_index {Remove} idx 19 .silent_index {Remove} idx 20 .silent_index {Remove} idx 20 .silent_index {Select} idx 20 .silent_index {Remove} idx 20 .silent_index {Select} idx 20 .silent_index {Remove} idx 20 .silent_index {Lisp} idx 21 .silent_index {Move Point} idx 21 .silent_index {Lisp} idx 21 .silent_index {Defun} idx 21 .silent_index {Move Point} idx 21 .silent_index {Subsequent Command Modifier} idx 22 .silent_index {Mark} idx 22 .silent_index {Move Point} idx 22 .silent_index {Alter Display Format} idx 22 .silent_index {Buffers} idx 22 .silent_index {Files} idx 22 .silent_index {Lisp} idx 23 .silent_index {Mark} idx 23 .silent_index {Lisp} idx 23 .silent_index {Escape} idx 23 .silent_index {Fill Prefix} idx 23 .silent_index {Fill Column} idx 23 .silent_index {Paragraph} idx 23 .silent_index {Alter Existing Text} idx 23 .silent_index {Text} idx 23 .silent_index {Fill Prefix} idx 23 .silent_index {Fill Column} idx 23 .silent_index {Paragraph} idx 23 .silent_index {Alter Existing Text} idx 23 .silent_index {Text} idx 24 .silent_index {Fill Prefix} idx 24 .silent_index {Fill Column} idx 24 .silent_index {Paragraph} idx 24 .silent_index {Sentence} idx 24 .silent_index {Alter Existing Text} idx 24 .silent_index {Files} idx 24 .silent_index {Buffers} idx 24 .silent_index {Move Data} idx 24 .silent_index {Move Point} idx 24 .silent_index {Text} idx 24 .silent_index {Paragraph} idx 24 .silent_index {Move Point} idx 24 .silent_index {Text} idx 25 .silent_index {Sentence} idx 25 .silent_index {Move Point} idx 25 .silent_index {Lisp} idx 25 .silent_index {Move Point} idx 25 .silent_index {Move Data} idx 25 .silent_index {Mark} idx 25 .silent_index {Alter Display Format} idx 25 .silent_index {Inform} idx 26 .silent_index {Move Point} idx 26 .silent_index {Select} idx 26 .silent_index {Insert Constant} idx 26 .silent_index {Buffers} idx 26 .silent_index {Move Data} idx 26 .silent_index {Lisp} idx 27 .silent_index {Insert Constant} idx 27 .silent_index {Lisp} idx 27 .silent_index {Insert Constant} idx 27 .silent_index {Move Data} idx 27 .silent_index {Files} idx 27 .silent_index {Move Data} idx 27 .silent_index {Kill Ring} idx 28 .silent_index {Move Data} idx 28 .silent_index {Mark} idx 28 .silent_index {Move Data} idx 28 .silent_index {Lisp} idx 28 .silent_index {Insert Constant} idx 28 .silent_index {Lisp} idx 28 .silent_index {Kill Ring} idx 28 .silent_index {Remove} idx 28 .silent_index {Text} idx 29 .silent_index {Kill Ring} idx 29 .silent_index {Remove} idx 29 .silent_index {Buffers} idx 29 .silent_index {Remove} idx 29 .silent_index {Lisp} idx 29 .silent_index {Kill Ring} idx 29 .silent_index {Remove} idx 29 .silent_index {Text} idx 29 .silent_index {Kill Ring} idx 29 .silent_index {Remove} idx 29 .silent_index {Kill Ring} idx 30 .silent_index {Remove} idx 30 .silent_index {Kill Ring} idx 30 .silent_index {Region} idx 30 .silent_index {Remove} idx 30 .silent_index {Text} idx 30 .silent_index {Kill Ring} idx 30 .silent_index {Sentence} idx 30 .silent_index {Remove} idx 30 .silent_index {Buffers} idx 30 .silent_index {Remove} idx 30 .silent_index {Lisp} idx 31 .silent_index {Escape} idx 31 .silent_index {Lisp} idx 31 .silent_index {Inform} idx 31 .silent_index {Lisp} idx 31 .silent_index {Escape} idx 31 .silent_index {Lisp} idx 31 .silent_index {Inform} idx 31 .silent_index {Lisp} idx 32 .silent_index {Lisp} idx 32 .silent_index {Lisp} idx 32 .silent_index {Change Mode} idx 32 .silent_index {Lisp} idx 32 .silent_index {Subsequent Command Modifier} idx 32 .silent_index {Lisp} idx 33 .silent_index {Escape} idx 33 .silent_index {Lisp} idx 33 .silent_index {Escape} idx 33 .silent_index {Lisp} idx 33 .silent_index {Alter Existing Text} idx 33 .silent_index {Region} idx 33 .silent_index {Alter Existing Text} idx 33 .silent_index {Text} idx 34 .silent_index {Alter Existing Text} idx 34 .silent_index {Subsequent Command Modifier} idx 34 .silent_index {Mark} idx 34 .silent_index {Lisp} idx 34 .silent_index {Defun} idx 34 .silent_index {Mark} idx 34 .silent_index {Mark} idx 35 .silent_index {Lisp} idx 35 .silent_index {Mark} idx 35 .silent_index {Text} idx 35 .silent_index {Paragraph} idx 35 .silent_index {Mark} idx 35 .silent_index {Move Point} idx 35 .silent_index {Mark} idx 35 .silent_index {Move Point} idx 35 .silent_index {Text} idx 35 .silent_index {Mark} idx 35 .silent_index {Move Point} idx 36 .silent_index {Lisp} idx 36 .silent_index {Defun} idx 36 .silent_index {Move Point} idx 36 .silent_index {Lisp} idx 36 .silent_index {Move Point} idx 36 .silent_index {Lisp} idx 36 .silent_index {Move Point} idx 36 .silent_index {Text} idx 37 .silent_index {Move Point} idx 37 .silent_index {Goal Column} idx 37 .silent_index {Move Point} idx 37 .silent_index {Goal Column} idx 37 .silent_index {Move Point} idx 37 .silent_index {Move Point} idx 37 .silent_index {Lisp} idx 38 .silent_index {Move Point} idx 38 .silent_index {Lisp} idx 38 .silent_index {Move Point} idx 38 .silent_index {Text} idx 38 .silent_index {Move Point} idx 38 .silent_index {Move Point} idx 38 .silent_index {Move Point} idx 39 .silent_index {Move Point} idx 39 .silent_index {Move Point} idx 39 .silent_index {Move Point} idx 39 .silent_index {Goal Column} idx 39 .silent_index {Move Point} idx 39 .silent_index {Subsequent Command Modifier} idx 40 .silent_index {Move Point} idx 40 .silent_index {Escape} idx 40 .silent_index {Escape} idx 40 .silent_index {Alter Display Format} idx 40 .silent_index {Alter Display Format} idx 41 .silent_index {Alter Display Format} idx 41 .silent_index {Alter Display Format} idx 41 .silent_index {Insert Constant} idx 41 .silent_index {Alter Display Format} idx 42 .silent_index {Move Point} idx 42 .silent_index {Files} idx 42 .silent_index {Region} idx 42 .silent_index {Move Data} idx 42 .silent_index {Move Point} idx 42 .silent_index {Preserve} idx 42 .silent_index {Alter Existing Text} idx 42 .silent_index {Select} idx 42 .silent_index {Buffers} idx 43 .silent_index {Set Global Variable} idx 43 .silent_index {Alter Existing Text} idx 43 .silent_index {Select} idx 43 .silent_index {Lisp} idx 43 .silent_index {Alter Display Format} idx 43 .silent_index {Insert Constant} idx 43 .silent_index {Move Point} idx 44 .silent_index {Select} idx 44 .silent_index {Files} idx 44 .silent_index {Remove} idx 44 .silent_index {Buffers} idx 44 .silent_index {Files} idx 44 .silent_index {Preserve} idx 44 .silent_index {Files} idx 44 .silent_index {Preserve} idx 44 .silent_index {Alter Display Format} idx 44 .silent_index {Alter Display Format} idx 45 .silent_index {Alter Display Format} idx 45 .silent_index {Alter Display Format} idx 45 .silent_index {Alter Display Format} idx 45 .silent_index {Alter Display Format} idx 45 .silent_index {Alter Display Format} idx 46 .silent_index {Buffers} idx 46 .silent_index {Move Point} idx 46 .silent_index {Buffers} idx 46 .silent_index {Move Point} idx 46 .silent_index {Fill Column} idx 46 .silent_index {Set Global Variable} idx 46 .silent_index {Fill Prefix} idx 47 .silent_index {Set Global Variable} idx 47 .silent_index {Set Global Variable} idx 47 .silent_index {Set Global Variable} idx 47 .silent_index {Mark} idx 47 .silent_index {Files} idx 48 .silent_index {Set Global Variable} idx 48 .silent_index {Insert Constant} idx 48 .silent_index {Change Mode} idx 48 .silent_index {Change Mode} idx 48 .silent_index {Change Mode} idx 49 .silent_index {Change Mode} idx 49 .silent_index {Insert Constant} idx 49 .silent_index {Text} idx 49 .silent_index {Change Mode} idx 49 .silent_index {Alter Existing Text} idx 50 .silent_index {Lisp} idx 50 .silent_index {Alter Existing Text} idx 50 .silent_index {Alter Existing Text} idx 50 .silent_index {Region} idx 50 .silent_index {Alter Existing Text} idx 50 .silent_index {Text} idx 51 .silent_index {Alter Existing Text} idx 51 .silent_index {Alter Display Format} idx 51 .silent_index {Files} idx 51 .silent_index {Move Data} idx 51 .silent_index {Preserve} idx 51 .silent_index {Subsequent Command Modifier} idx 51 .silent_index {Kill Ring} idx 52 .silent_index {Region} idx 52 .silent_index {Alter Existing Text} idx 52 .silent_index {Alter Existing Text} idx 52 .silent_index {Text} idx 52 .silent_index {Alter Existing Text} idx 52 .silent_index {Region} idx 52 .silent_index {Alter Existing Text} idx 52 .silent_index {Text} idx 53 .silent_index {Alter Existing Text} idx 53 .silent_index {Alter Display Format} idx 53 .silent_index {Files} idx 53 .silent_index {Move Data} idx 53 .silent_index {Move Point} idx 53 .silent_index {Files} idx 53 .silent_index {Buffers} idx 53 .silent_index {Move Point} idx 53 .silent_index {Alter Display Format} idx 53 .silent_index {Inform} idx 54 .silent_index {Files} idx 54 .silent_index {Preserve} idx 54 .silent_index {Files} idx 54 .silent_index {Region} idx 54 .silent_index {Preserve} idx 54 .silent_index {Files} idx 54 .silent_index {Preserve} idx 54 .silent_index {Lisp} idx 55 .silent_index {Move Data} idx 55 |
Added psl-1983/doc/brief-mini.lpt version [98a998ff55].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | MINI BRIEF DEFINITION MINI BRIEF DEFINITION MINI BRIEF DEFINITION The MINI Translator Writing System was developed in two steps. The first was the enhancement of the META/REDUCE [Marti79] system with the definition of pattern matching primitives to aid in describing and performing tree-to-tree transformations. META/REDUCE is very proficient at translating an input programming language into LISP or LISP-like trees, but did not have a good method for manipulating the trees nor for direct generation of target machine code. PMETA (as it was initially called) [Kessler79], solved these problems and created a very good environment for the development of compilers. In fact, the PMETA enhancements have been fully integrated into META/REDUCE. The second step was the elimination of META/REDUCE and the development of a smaller, faster system (MINI). Since META/REDUCE was designed to provide maximum flexibility and full generality, the parsers that is creates are large and slow. One of its most significant problems is that it uses its own single character driven LISP functions for token scanning and recognition. Elimination of this overhead has produced a faster translator. MINI uses the hand coded scanner in the underlying RLISP. The other main aspect of MINI was the elimination of various META/REDUCE features to decrease the size of the system (also decreasing the flexibility, but MINI has been successful for the various purposes in COG). MINI is now small enough to run on small LISP systems (as long as a token scanner is provided). The META/REDUCE features that MINI has changed or eliminated include the following: 1. The ability to backup the parser state upon failure is supported in META/REDUCE. However, by modifying a grammar definition, the need for backup can be mostly avoided and was therefore eliminated from MINI 2. META/REDUCE has extensive mechanisms to allow arbitrary length dipthongs. MINI only supports two character dipthongs, declared prior to their use 3. The target machine language and error specification operators are not supported because they can be implemented with support routines 4. REDUCE subsyntax for specification of semantic operations is not supported (only LISP is provided) Although MINI lacks many of the features of META/REDUCE, it still has been quite sufficient for use in COG. It has been used for implementation of MIDL, pattern matching ruleblocks and the prototype parser/semantic analyzer. The following is a brief introduction to MINI, the reader is referred to [Marti79] for a more detailed discussion of the META/REDUCE operators, which are very similar to those of MINI. 2 MINI uses a stack to perform parsing. For example, FOO: ID '!- ID +(PLUS2 #2 #1) defines a rule FOO, which recognizes two identifiers separated by a minus sign (each ID pushes the recognized identifier onto the stack). The last expression replaces the top 2 elements on the stack (#2 pops the first ID pushed onto the stack, while #1 pops the other) with a LISP statement. Specification of a parser using MINI consists of defining the syntax with BNF-like rules and semantics with LISP expressions. The following is a brief list of the operators: ' Used to designate a terminal symbol (i.e. 'WHILE, 'DO, '!=) Identifier Specifies a nonterminal ( ) Used for grouping (i.e. (FOO BAR) requires rule FOO to parse followed immediately by BAR) < > Optional parse, if it fails then continue (i.e. <FOO> tries to parse FOO) / Optional rules (i.e. FOO / BAR allows either FOO or BAR to parse, with FOO tested first) STMT[ANYTOKEN]* Parse any number of STMT separated by ANYTOKEN, create a list and push onto the stack (i.e. ID[,]* will parse a number of IDentifiers separated by commas, like in an argument list) ##n Reference the nth stack location (n must be an integer) #n Pop the nth stack location (n must be an integer) +(STMT) Push the unevaluated (STMT) onto the stack .(SEXPR) Evaluate the SEXPR and ignore the result +.(SEXPR) Evaluate the SEXPR and push the result on the stack @ANYTOKEN Specifies a statement terminator, used in the error recovery mechanism to search for when an error occurs @@ANYTOKEN Grammar terminator The useful files are as follows: 3 MINI.MIN The self definition of MINI in MINI. MINI.SL A Standard LISP version of MINI.MIN, translated by MINI itself. MINI.RED The support RLISP for MINI. SENTER.RED The META/REDUCE symbol table package. MINI.BLD A runfile that builds MINI.FAP from the above 4 files. MINIME.BLD A runfile that builds the MINI.SL file by loading and translating MINI.MIN. |
Added psl-1983/doc/build-man.mss version [81c448c361].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(Article) @comment[ 9-Dec-82 20:46:50-MST,16664;000000000001 Mail-from: ARPANET site RAND-RELAY rcvd at 9-Dec-82 2044-MST Date: 9 Dec 1982 0544-PST From: GRISS.HP-HULK at Rand-Relay Subject: Draft of more BUILD To: jw-peterson at Utah-20 Via: HP-Labs; 9 Dec 82 19:36-PDT Here is a portion of manual about the next steps. Not complete, incorp@orates some of what youve seen: ] [For the moment, this note will use 68000 building as example, using DEC-20 as HOST] @section(Building the Cross Compiler) Connect to P68c: . Make sure that you have the following .b files on p68c:, or rebuild as below: a. m68k-cmac.b b. m68k-comp.b c. m68k-asm.b @subsection(How to make the .B files using the .MIC files) To rebuild a missing .B file, run the SYSBUILD .MIC file on the appropriate module: @@MIC PU:sysbuild M68k-xxx where "xxx" represents CMAC, COMP or ASM, as appropriate. @subsection(How to make the .EXE file) Now build the cross compiler onto the scratch directory, S: by running the .CTL file (using DO or SUBMIT): @@do p68c:new-m68k-cross.ctl [In the future, this should actually be changed to "do new-apollo-cross" to avoid confusion between the various 68000 based machines]. @section(Running the Cross Compiler) Now connect to p68: @subsection(Independent Compilation and the .SYM file) To build a fresh BARE-PSL or a fresh FULL-PSL you will need a fresh symbol file. The current symbol file has the name of "m68k.sym" [which should be changed to "apollo.sym" or something related in the future] First generate a fresh m68k.sym file: @@MIC fresh-kernel.ctl This will keep your last m68k.sym file as p68:previous-m68k.sym. The fresh m68k.sym file will be on S:. Make sure it is there. @subsection(Generating the Module .CTL Files) Currently fourteen modules are required to build the first phase of either the BARE-PSL build or the FULL-PSL. You will need xxx.CTL files on kapollo: for each of these. The kernel module names (xxx) are currently: <<< how's about compiler modules? have same faclity make .ctl files for those?? >>> TYPES RANDM ALLOC ARITH DEBG ERROR EVAL EXTRA FASL IO MACRO PROP SYMBL SYSIO TLOOP HEAP and MAIN [Note, order is different from older P68: version <<<how??>>>] [Note, change to generate also for BIG-KERNEL?] <<< there needs to be some clear consensous on the terminolgy, i.e., what's the differances between big/bare/full-comp/kernel/psl??? >>> Take a look to see if they are there, if they are not you will have to re-generate them. The easiest way will be to do this is via the "kernel-gen" program: @begin(verbatim) @@PSL:PSL *(dskin "apollo-kernel-gen.sl") *(quit) @end(verbatim) This will create the xxx.CTL files you need on kapollo:. @subsection(Building the Modules) <<<again, terminology. need some clear definitions as to what all encompases (in terms of functionality, not "contains xx, yy & zz") >>> Now connect to kapollo: Now you must execute all the CTL files for the first 14 modules. Do this with the following command: @@MIC kapollo:All-kernel.ctl This command will SUBMIT all these CTL files to batch. [Alternatively, single modules my be run by submitting @@SUBMIT xxxx.CTL for module xxx] <<< any order or presatance to be followed? hows about .sym file??>>> Each batch job processed will create an xxx.log file on kapollo: which you can look at to evaluate errors. Initially before running a fresh build you might want to delete all these log files just for the sake of space. @subsection(Processing the MAIN file) <<<re: "is built last" where (timewise) does the compiler fit in?>>> Note that the MAIN module is built last, and that it takes the contents of the .SYM file and builds the run-time symbol table initialization. @@submit MAIN.CTL [Why is this not in ALL-KERNEL.CTL?]<<<because all-kernel refers to building the Individual pieces. Main crunches specificly on the main-start file and builds a resulting dmain. it is separate from all-kernel (specifcly, if i remember) simply so it Can be run last>>>. @subsection(Linking the files and executing) <<<huh?>>> @section(Details on the Test series) [Absorb details from TEST GUIDE here] <<< NO! we're talking about building *re*building sources that are assumed to be complete (i.e., a new version), not developing a port to a new machine. the port process, including the use of the small tests, deserves to be in a separate document; as it works quite differntly from building the whole thing. >>> @subsection(Command Files, and Kernel Generator?) [Describe kernel generator earlier?] <<< yes, please. and while you're at it, a functional description of "a kernel", and what it must contain, would help.>>> @subsection(Basic Test Strategy) Each test will use some modules tested in previous test, and add others, mostly extracted from the full PSL sources. Occassionally some stub-files have to be added, to be replaced by more complete sets extracetd frm sources later. Early tests simply try to print informative messages about what is happening, and whether each test succeeded or not. As more of a complete LISP is built up, the tests will require a variety of manual inputs. Finally a complete MINI-PSL will result. <<< again, i'd like to see the porting manual separate from the system-rebuild description; not doing so risks confusion, and perhaps a 'missing piece syndrome'. the idea is pick up vol. one "how to design and test psl cmacros" once you think your cmacros work, you pick up vol. two "how to build a complete running psl." theoreticly, the only thing in common between the two should be one(?) i/o module and the key compiler files xxx-cmac, xxx-asm, etc. (they guys who live in .../comp) >>> @subsection(Test1) @subsection(Testn) @subsection(Testing Mini-EVAL) @subsection(Testing Character and File I/O) @subsection(Switch Over to INIT files) <<< what switch? where? magic? >>> At this point, can flip a switch in the build process, and have INITCODE be smaller, and instead have .INIT files produced, which will be read in by LAPIN or DSKIN. @subsection(Testing Binary I/O) [Write a small BINDUMP routine] <<<again, the vol.1 "how to test"/vol 2."how to build" concept. perhaps set up a testn+1 to test bin i/o?? >>> @section(Building the BARE-PSL kernel) At this point, enough basic tests have been done, and now the standard BARE-PSL should be built. This requires a few more files, <<<this is where things can get murky between "test phase" and "build phase".>> and a more stable BUILD sequence. This will result in a complete 3.1 version of BARE-PSL. <<<what about comp/faslout? build it on the resident bare-psl via the interpreter? maybe go whole-hog first time? we thought we could get away bare-psl on the apollo mainly because we thought the 3.0 could handle generating new binaries. it couldn't, so we had start from square 0. and you can't (at least if i interpeted all of chip & steve's swearing & cursing right) build the comp stuff interpetivly because you start tripping over syslisp. is that now fixed? if so, how? needs the concept as presented here needs details, and looks like it may not be fully correct...take a hard look.>>> @subsection(Use and Customization of Kernel Generator) [Should kernel-gen be used with test series?] <<<no, see above dissertation on vol1/vol2>>> @subsection(Common Files, Machine Specific Files and Dummy Files) @subsection(Init Files) <<<short section. I could use the info, what -are- they used for? when do you need to replace them?>>> @subsection(Testing BARE-PSL) @section(Bootstrapping the LAP, FASL and COMPILER) Currently, we bootstrap complete system by adding additional modules to BARE-PSL to make BIG-PSL.<<<terminology again>>> These are LAP, FASLOUT and COMPILER modules, and also RLISP parser. BIG-PSL <<<don't you mean bare?>>> is used as a bootstrap step to the production of COMPILER.B, FASLOUT.B, LAP.B etc., since once these are built, they can be loaded into the BARE-PSL when needed. Having core-save working by this time is important, since the kernel is quite large, and loading RLISP and COMPILER and INIT files takes quite a while. <<<though somewhat of a moot point on the apollo, since copying the entire image also takes plenty of time>>>. [In future, should convert critical files to .SL, avoid RLISP in kernel at ALL] <<<or how's about the host generating a .sl rlisp automaticlly? I would Much rather read .red then .sl >>> [In future, will do alternative model, with just LAP to start, test with LAP files from cross-compiled files. Then test FASLOUT and FASLIN. Should be able to load many things as .LAP files. Then finally load compiler. It should work without much problem since its essentially all common code, and mostly tested even for this target in CROSS mode.] <<<yeah. reminds me, this doc doesn't say much about lap. generation of the lap system is quite arcane, no?>>> @subsection(Building the FULL-PSL) Essentially same procedure as BARE-PSL, just have 2 more modules, RLISP and COMP, and rebuild MAIN. <<<but if you're going the cross compile route, watch out for booby traps (i.e., fasl in bare-psl stepping on fasl in comp>>> @subsection(Extra Files) For the RLISP module, need PU:RLISP.BUILD which accesses PU:RLISP-PARSER.RED and PU:RLISP-SUPPORT.RED. [We should change sources so that dont need RLISP for for BIG-BUILD]. For the COMP module, we need to access a large number of files right now: <<<huh? this is mislocated>>> @subsection(Building both BARE-PSL and FULL-PSL) Its worth building both BARE-PSL and FULL-PSL at the same time during this phase. Build up to the MAIN module of BARE-PSL. Then copy the .SYM file for use in incremental rebuilding of BARE-PSL modules and BARE-MAIN. Then continue to build the RLISP, COMP and FULL-MAIN modules. These 2 different .SYM files are then used for rebuilding modules in the BARE-PSL series or the FULL-PSL series, as appropriate. Most of the time, errors will be only in the COMP module, but occasionally errors will be found that require a full build of the BARE-PSL and FULL-PSL, or incremental rebuild of some earlier modules. <<<hmmm, what about .sym file? and cleaning it out and restoring it? and how do the .init files fit into this process. i don't like the idea of several lisps lying around (e.g., bare, big, full, etc). would be MUCH simpler just to deal with one resulting system, rather than try and keep track of several. particularly if they start getting into fights and stepping on each other. cost in dealing with one larger system may be made up in avoiding screwups caused by multpile ones. think about this!>>> To build a FULL-PSL you must submit two additional .CTL files to be cross compiled, they are COMP.CTL and MAIN.CTL. To build just BARE-PSL you submit only MAIN.CTL. Both of these CTL files should be on kapollo:, if not you will have to create them by hand. Here is COMP.CTL: @begin(verbatim) @@define DSK: DSK:, kapollo:, PI: <<<search lists are too much a form of magic. would prefer that it be dictated as to which dir the .ctl is run from, and logicals (or on unix, relative paths) be used to specify where things belong. besides, they Only work this way on the 20.>>> @@S:m68k-CROSS.EXE *ASMOut "comp"; *in "comp.build"; *ASMEnd; *quit; The COMP.BUILD file should look like this: macro procedure !* u;nil; on eolinstringok; put('bitsperword,'wconst,32); compiletime flag('(taggedlabel inump !*jumpeq !*jumpnoteq !*jumpwgreaterp !*jumpwlessp !*jumpwgeq !*link !*linke onep !*jumpwleq), 'lose); in "pc:anyreg-cmacro.sl"$ in "pc:common-cmacros.sl"$ in "pc:common-predicates.sl"$ in "pc:pass-1-lap.sl"$ in "pc:compiler.red"$ in "pc:comp-decls.red"$ in "pc:tags.red"$ compiletime remflag('(taggedlabel inump !*jumpeq !*jumpnoteq !*jumpwgreaterp !*jumpwlessp !*jumpwgeq !*link !*linke !*jumpwleq), 'lose); compiletime flag('(tagnumber), 'lose); in "kapollo:m68k-cmac.sl"$ in "kapollo:m68k-comp.red"$ in "kapollo:m68k-lap.red"$ in "p68:nsystem-faslout.red"$ <<<are these duplicated in the bare-kernel?>>> in "pc:faslout.red"$ <<<again, problems with multilpe version, maybe not a good idea>>> The MAIN.CTL file will look like this: define DSK: DSK:, PHP:, PI: S:HP-CROSS.EXE ASMOut "main"; in "main.build"; ASMEnd; quit; @end(verbatim) So send one or both of these files to batch like this "submit comp.ctl" "submit main.ctl" Each ctl file sent to batch will produce three files on the scratch directory, an xxx.ASM, an Dxxx.ASM, and a xxx.INIT file. Some of the init files are of length zero, this is ok. @subsection(Append INIT files) Connect to the scratch directory, S:. The init files can all be appended together to cut down shipping and the time it takes to startup the APOLLO PSL. Append all the init files together to create an all.init. If you also are building the BIG-PSL then you will have to append COMP.INIT to all.init by hand or ship it to the apollo seperately and edit the file on the Apollo to include the comp.init. @@DO P68:all-init.ctl @subsection(Removing Tabs) [I believe 3.1 CROSS compiler fixed to only put in 1 space (or 2 for CRAY), so tabs dont need to be stripped. EXPAND is unsafe program] The Apollo Assembler does not like tabs so the .ASM files will need to have the tabs expanded into spaces. One way to do this is to do the following. @@DO p68:allexpand.ctl <<<unix has much better facilities for doing this>>> If you are building a BIG-PSL then you will have to expand the two comp by hand by doing: @@unix:expand <comp.asm >comp.asm @@unix:expand <dcomp.asm >dcomp.asm I suggest you copy everything to rs: to keep it around. Thats all the .asm's, the .inits, and the m68k.sym. [Why not change the .CTL files to insert RS: instead of S:] <<<perhaps because disk space is guarenteed on scratch, i.e., an extra set of versions won't kill you. would be nice tohave them back the next day though....>>> @subsection(Ship via the VAX) You are now ready to ship the code to the Apollo. Login on the VAX and run regexp.csh, a copy is on lowder's directory. This will move all the files off scratch except for the two comp files. So do: [Add BIGregexp.csh] <<<what on earth does regexp stand for?>>> <<<important: you should also give the following vax commands to avoid getting screwed over by mail, system, and autologout msgs: biff n #shut off mail notifyier mesg n # sys msgs set autlogout=2000 #so it won't die while waiting for asm >>> get20 scratch comp.asm dcomp.asm @subsection(Fetch from Apollo) Get logged in on the Apollo and conect to the VAX by running ST. >From the Apollo shell type: "apollo.csh" This will ship and assemble everything from the VAX except files related to comp. If you are using them you will have to type this to the apollo: [Add BIGAPOLLO.csh] "vfv1 comp.asm asmnl comp vfv1 dcomp.asm asmnl dcomp" @subsection(Bind the Modules) Now link with shell script: PSLBIND.SH PSL [Here again you CURRENTLY have to edit pslbind.sh to add the names of COMP.BIN and DCOMP.BIN if you are going to build a BIG-PSL. Suggest doing this once, create a BIGBIND.SH] <<<again, look at the special casy-ness of having big vs. bare [vs. full], etc. worth avoiding? time savings in the long run?>>> @subsection(Notes) There are a number of ways to vary this entire prcocess to customize it to your needs. If you started by building a BARE-PSL you can go back and build just the comp module by copying the m68k.sym from rs: onto the scratch directory and submitting the comp.ctl and the the main.ctl as previously described. Also you can choose to link or not the comp module in the apollo. <<<important: you need to spell out booby traps you can run into while doing this>>> @subsection(Testing LAP) Once most of LAP has been run on the host machine (interpretively or compiled), the next step is to run it as a "resident" PSL assembler on the target machine to ensure that it correctly assembles small procedures written in TLM ("target" LAP) form. Then procedures are input in ALM (cmacro form). Usually this next step will work quite well, since the CMACRO's will have been well tested while building the TEST-SERIES and BARE-PSL. Note that until RESIDENT mode of assembly seems stable (basically checking assembler and cmacro tables), there is no point in trying to do much with faslout. Here are some simple procedures to try; others can be generated by looking at the output of the cross-compiler: <<<comments! what are these guys trying to do? what should i look for to see that they work right? >>> @begin(verbatim) (LAP '((!*ENTRY FOO EXPR 1) % can we define ANY procedure (!*ALLOC 0) (!*EXIT 0))) % or (RTS) on 68000 % when called, should return argument (LAP '((!*ENTRY FOO EXPR 0) (!*ALLOC 0) (!*MOVE (QUOTE 1) (REG 1)) (!*EXIT 0))) (LAP '((!*ENTRY FOO EXPR 1) % adds 2 to argument, prints and returns (!*ALLOC 0) (!*MOVE (QUOTE 2) (REG 2)) (!*LINK PLUS2 EXPR 2) (!*LINK PRINT EXPR 1) (!*EXIT 0))) @end(verbatim) Common problems encountered at this phase are: @begin(description) LAP Table Errors@\Most implementations of lap have procedures for common formats, and tables of numbers for the opcodes. Often the numbers are mistyped, or the instructions misclassified or missing. Trace@\If it blows up with illegal addressing, try tracing certain passes to see which is at fault; then as a quick patch, redefine these passes to be NO-OPS: @begin(verbatim) (de OptimizeBranches (U) U) or (de PASS1LAP (u) U) etc. @end(verbatim) @end(description) <<<what does alm mean?>>> [Prepare file of sample procedures, and corresponding ALM form to test important things. E.g., HALFWORD tables for LAMBIND, etc.] <<< why did chip & steve use interpretiv put/gethalfword functions? tricks worth knowing about???>>> [In future, hope to be able to run LAP interpretively on BARE-PSL, rather than having to build into kernel.] @subsection(Testing FASLOUT and FASLIN) Now that resident LAP seems to work, try some simple FASLOUT and FASLIN. Binary I/O should have been tested, so main thing is checking that RELOC stuff works, and that bytes and words are correctly assembled into the incore array for FASL, passed out to the file and correctly re-written. <<<examples of what this looks like?>>> FASLOUT and the FASLIN a few small files <<<how's about some pre-built tests?>>> to check accuracy. These files should be self-contained, and not intially contain SYSLISP code, since the SYSLISP.B module has not been built. <<< easier said than done- syslisp has had a tendenacy to creep into nearly everything for "effeciency" sake...>>> For example, try the PU:POLY.RED. An important one is PU:RLISP-PARSER.RED and PU:RLISP-SUPPORT.RED. [It is worth while to use a small BINARY-DUMP routine that reads a binary file and prints it as OCTAL or HEX numbers. This can be compared with the known FASL format<<<which is ____>>>, for a test file that has been fasled on a similar machine]. Common problems encountered at this phase are: @begin(description) ???? <<<amen>>> @end(description) @subsection(FASLOUT the critical files) In order to build most of the .B files that are needed, one needs to create the IF-SYSTEM, BUILD, RLISP, COMPILER, FASLOUT and LAP modules. First "hand-build" the IF-SYSTEM and SYSLISP and BUILD modules: @begin(verbatim) FASLOUT "IF-SYSTEM"; IN "IF-SYSTEM.RED"$ FASLEND; @End(verbatim) Building SYSLISP is tricker since it needs a version of SYSLISP to build from. First edit the PC:SYSLISP.BUILD file, to make sure that the IF_SYSTEM clauses mention your machine (as set up in the SYSTEM_LIST!* list before). Then read in the SYSLISP support interpretively, and then FASLOUT : @begin(verbatim) <<<where are we? is this with the cross compiler?>>> LOAD IF!-SYSTEM; % Needs IF-SYSTEM IN "SYSLISP.BUILD"; % To get interpreted SYSLISP in % since it needs SYSLISP to build OPTIONS!* := 'SYSLISP . OPTIONS!*; % To prevent PSL from attempting to load Syslisp; FASLOUT "SYSLISP"; IN "SYSLISP.BUILD"$ % may have to use PATHIN off PC: FASLEND; @end(verbatim) Finally, faslout the BUILD.B module, for future module building: @begin(verbatim) FASLOUT "BUILD"; IN "BUILD.BUILD"$ @end(verbatim) Now use BUILD on the other modules that are needed to produce the base system: @BEGIN(verbatim) BUILD 'RLISP; BUILD 'COMP!-DECLS; BUILD 'PASS!-1!-LAP; BUILD 'xxx!-LAP; BUILD 'xxx!-CMAC; BUILD 'xxx!-COMP; BUILD 'FASLOUT; BUILD 'COMPILER; @end(verbatim) @subsection(Test FASL'd RLISP and COMPILER) LOAD the RLISP modules into the BARE-PSL system, check that RLISP works on a number of files. Now LOAD the COMPILER, try some in-core compilation of simple procedures (ON COMP). Finally use this system to FASLOUT or BUILD a variety of modules. Ultimately try rebuilding RLISP and COMPILER and SYSLISP. <<<what are problems here? what's the roles of the resident system and the cross compiler at this point?>>> @subsection(BUILD rest of library) Now go through the PU: directory, running BUILD on each of the BUILD files. Check each build-file to see which additional modules are needed. Important shared modules are: @begin(verbatim) <<<gee, if you squint this looks like a unix makefile...>>> INUM Needs SYSLISP FAST-VECTOR Needs SYSLISP, IF-SYSTEM VECTOR-FIX Needs SYSLISP GSORT Needs SYSLISP BIGBIG Needs SYSLISP, FAST-VECTOR,VECTOR-FIX,ARITH BIGFACE Needs SYSLISP, FAST-VECTOR,VECTOR-FIX,ARITH INUM, BIGBIG,IF-SYSTEM @end(verbatim) ------- |
Added psl-1983/doc/carr_gemacs_defs.txt version [d43a6c0032].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 18-Nov-82 11:14:38-MST,2694;000000000001 Mail-From: CARR created at 18-Nov-82 11:11:12 Date: 18 Nov 1982 1111-MST From: Harold Carr <CARR at UTAH-20> Subject: psl mode for emacs To: galway at UTAH-20 cc: carter at UTAH-20, kessler at UTAH-20, psi.krOHNFELDT at UTAH-20, uscg at UTAH-20 On our version of Gosling's emacs we use a modified electric-lisp-mode along with some other functions that Jed wrote. Here are the main things that I like: paren-pause Gets bound to ')'. It flashes corresponding '(' either by temporarily moving the cursor up to the '(' and pausing, then returning, or if the matching '(' is off the current window then show the matching line in the mini-buffer. It also fixes the indentation of the ')' if it is on a line by itself to match the column of the corresponding '('. Complains if there is no match. nl-indent Gets bound to linefeed. Inserts new line and properly indents the next line. A simple "proper indent" is that if there is an open unmatched '(' then the next line should be indented 4 from the unmatched '('. re-indent-line Unbound function to repair indentation of current line. indent-lisp-function Unbound function to fix up the indentation of entire lisp function from (dX to ). electric-lisp-semi This function is bound to ';'. It takes you to the nth column when pressed so you can start a comment. We unbind this one. I like to deal personally with every ';' (or '%'). forward-sexpr Bound to ESC ')'. backward-sexpr Bound to ESC '('. Its nice to have an abbrev table for lisp. lisp-comment-mode Bound to ESC 'c'. Asks for a function name. After carriage return it does this: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; <function-name> ; ; <leaves-cursor-here> ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Now as you type its in "text mode", when it gets near the end of the line it automatically starts a new line, inserts ';' and a space. Any time you press newline it does the same. When you enter carriage-return the cursor is moved to the line below the box and you're back in lisp-mode. You can move your cursor back into a previously built box and enter ^U, ESC 'c'. This will kill-to-end of line and put you back into the "text-mode" described above. There are some others, but these are the useful ones. If you would like the mlisp files for these functions, let me know. Harold. ------- |
Added psl-1983/doc/cmacros.note version [74632234e1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Random LAP and CMACRO Notes --------------------------- In LAP-TO-ASM, LoadTime and StartupTime have ASMpreEVAL property. Assumes certain things are WCONST's, like UNBOUND, HEAPSIZE, Collect ASMPSEUDOOPs (FLOAT x) (FULLWORD x Y z ...) (BYTE x y ... z) (HALFWORD x y ...) (STRING s) Collect OPERANDPRINTFUNCTIONS (REG n) (ENTRY id) (INTERNALENTRY id) (ExtraREG n) -> A macro actually (WVAR v) (WARRAY v) (WSTRING v) (FLUID id) ($FLUID id) (GLOBAL id) ($GLOBAL id) Collect ASMExpressionFunction (INTERNALENTRY id) (WCONST x) Collect WCONSTREFORMPSEUDO (INTERNALENTRY id) (QUOTE sexp) (LOC m) (IDLOC id) BinaryASMOP and UnaryAsmOP -> For Parens/rename (Plus2 !+) (WPlus2 !+) (Difference !-) (WDifference !-) (Times2 !*) (WTimes2 !*) (Quotient !/) (WQuotient !/)), 'BinaryASMOp); (Minus !-) (WMinus !-)), 'UnaryASMOp); ASMExpressionFormat and ASMExpressionFunction ---------DEC20-------------------- LAND,LOR,LXOR,LSH known BinaryASMOP LNOT UnaryASMOP MkItem is ASMEXPRESSIONFORMAT OperandPrintFunctions: (INDIRECT exp) (INDEXED exp) (IMMEDIATE exp) -> A macro (FIELDPOINTER x y z) CERROR is AsmPseudoOP, and !*CERROR is CMACRO -------------VAX---------------------------- BINARYOP: Remainder LAND LOR LXOR LSH UNARY: Lnot ASMEXPRESSIONFormat: MkItem OPERANDPRINTFUNCTION: (DEFFERED x) (DISPLACEMENT x) (INDEXED x) (IMMEDIATE x) (AUTOINCREMENT x) (AUTODECREMENT x) (ABSOLUTE x) (FOREIGNENTRY x) Also Cerror and !*Cerror ------------------------------------------------------- Current set of ALM modes: TERMINALOPERAND, passed as is to LAP, unchanged in recrusive CMACROS (FLUID id) (!$FLUID id) (GLOBAL id) (!$GLOBAL id) (EXTRAREG r) (LABEL l) (INDEXED a) ? or TLM (INDIRECT a) ? TLM (LIT x) ? TLM (UNIMMEDIATE x) ANYREG's just for OPEN-code (CAR exp) (CDR exp) SPECIALANYREGS, can sometimes (always?) be used recursively provide the ANYREG table simplifies and re-installs same TAG, or some other TAG. (FRAME i) (FRAMESIZE) (LABLEGEN l) (LABELREF l) (MEMORY a c) (QUOTE sexp) % Not TEMINALOPERAND too; ANYREG table "clever" (REG r) (WCONST w) (WVAR v) (WARRAY v) ? only in ASM Why are InternalEntry, ForeignEntry and Entry not in the above LIST. SHould they not be TERMINALOPERAND? Note that when in doubt, WCONST evaluable adds (IMMEDIATE...); is this a good idea? What are legal ALM addressing modes in each CMACRO, remember !*JUMP is allowed MEMORY; how about !*CALL Add CERROR and !*CERROR to COMMON-CMACROS; avoid FALL-THRU, rather ALWAYs have an ERROR clause as default. Ie, Writer of CMACROs must put in (ANY.. as default). How to turn off INTERNAL function for debugging. Needs a flag, but can redefine INTERNALLYCALLABLEP to be NIL in COMPILER being used (either CROSS or RESIDENT or FASL) (de InternallyCallableP (x) NIL) What is difference between 'FASTLINK and INTERNALFUNCTION flag (see common-predicates) Check what can be loaded as .SL and .LAP to simplify BOOT. Ie how to ue MACRO's for compilation and INTERP. Perhaps change model of CMACRO to be REAL macro, seen by compiler. What is INTERP compatibility package? Need combine INTERP-SYSLISP, INUM, etc. To simplify debugging, can we make some "inessential" CMACRO's just refer to associated OPENCODE or HANDCODED routine (eg, xxxFIELD). Which CMACRO's are ESSENTIAL to COMPILER, which only appear in the COMP-DECLS, and which are "pure" optimizations? SRCCOM the various DECL files, perhaps can be made more common (for the moment). |
Added psl-1983/doc/common-cmacros.doc version [67bdd1bdee].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % COMMON-CMACROS.SL - C-macros and Anyregs common to all implementations !*Link (FunctionName FunctionType NumberOfArguments) !*Call (FunctionName) !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments) !*JCall (FunctionName) !*DeAlloc (DeAllocCount) !*Alloc (N) !*Exit (N) !*JumpWithin (Label LowerBound UpperBound) !*ProgBind (FluidsList) !*FreeRstr (FluidsList) !*Jump (Arg1) !*Lbl (Arg1) !*Push (Arg1) !*Pop (Arg1) !*Move (Source Destination) !*JumpEQ (Label Arg1 Arg2) !*JumpNotEQ (Label Arg1 Arg2) !*JumpWLessP (Label Arg1 Arg2) !*JumpWGreaterP (Label Arg1 Arg2) !*JumpWLEQ (Label Arg1 Arg2) !*JumpWGEQ (Label Arg1 Arg2) !*JumpType (Label Arg TypeTag) !*JumpNotType (Label Arg TypeTag) !*JumpInType (Label Arg TypeTag) !*JumpNotInType (Label Arg TypeTag) !*MkItem (Arg1 Arg2) !*WPlus2 (Arg1 Arg2) !*WDifference (Arg1 Arg2) !*WTimes2 (Arg1 Arg2) !*AShift (Arg1 Arg2) !*WShift (Arg1 Arg2) !*WAnd (Arg1 Arg2) !*WOr (Arg1 Arg2) !*WXOr (Arg1 Arg2) !*WMinus (Arg1 Arg2) !*WNot (Arg1 Arg2) !*Loc (Arg1 Arg2) !*Field (Arg1 Arg2 Arg3 Arg4) !*SignedField (Arg1 Arg2 Arg3 Arg4) !*PutField (Arg1 Arg2 Arg3 Arg4) AnyregCAR (Register Source) AnyregCDR (Register Source) AnyregQUOTE (Register Source) AnyregREG (Register Source) AnyregWCONST (Register Source) (DefAnyreg WCONST AnyregWCONST (SOURCE)) AnyregFRAME (Register Source) AnyregFRAMESIZE (Register) (DefAnyreg FrameSize AnyregFRAMESIZE) AnyregMEMORY (Register Source ArgTwo) AnyregLABEL (Register Source) (DefAnyreg LABEL AnyregLABEL) (flag '(FLUID !$FLUID GLOBAL !$GLOBAL WVAR) 'TerminalOperand) |
Added psl-1983/doc/common-lisp-functions.txt version [79a66838fa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Description of columns: E - Existing PSL function * means the function needs no change, X means it requires an extension C - Name conflicts with existing PSL function O - Uses &optional and/or &rest arguments N - Same as a PSL function with this name S - Simple to implement * means it should be easy to implement (given optional arguments and the feature mentioned in column F), U means it's in the USEFUL package, C means it's in the COMMON package, though perhaps as a macro when it should be a function D - Difficult to implement A hard feature or large effort is required to add it, such as multiple values F - Feature needed A feature which does not currently exist in PSL is needed Comments appear on the line FOLLOWING the function name. E C O N S D F typep * * subtypep * null * symbolp idp atom * consp pairp listp * numberp * integerp fixp rationalp * rationals floatp * complexp * complex #s characterp * stringp * vectorp X true for all vector types arrayp * arrays functionp * subrp codep closurep * closures eq * eql eqn equal * equalp * * not * and * or * quote * function X must return a lexical closure for a lambda closure * closures symeval valuecell fsymeval * boundp C fboundp C macro-p C special-form-p * setq * psetq U set * fset * makunbound * fmakunbound remd setf U swapf * exchf * apply * funcall * U funcall* * C progn * prog1 U prog2 X let U let* U progv * flet * local functions labels * local functions macrolet * local functions cond * if U when U unless U case * PSL case is much less general, using only #s typecase * type classes block * block tags return X no restriction on placement return-from * block tags do UX takes an optional block tag do* UX takes an optional block tag dolist * dotimes * mapcar X * takes more than one list maplist X * takes more than one list mapc X * takes more than one list, returns first list as value mapl * * mapcan X * takes more than one list mapcon X * takes more than one list prog X variable initialization and optional block tag prog* * go X no restriction on placement values * * multiple values values-list * " multiple-value-list * " mvcall * " mvprog1 * " multiple-value-bind * " multiple-value * " catch * * catch-all * unwind-all * unwind-protect * throw * macro * defmacro UX should parse &keywords displace * macroexpand * macroexpand-1 * declare * requires some hair in the compiler to use declarations property lists must be represented as alternating indicator/value getpr * get has optional "instead-of-nil" value putpr put rempr remprop plist prop getf * * has optional "instead-of-nil" value putf * remf * get-properties * map-properties * get-pname id2string samepnamep * make-symbol newid copysymbol * * gensym X * optional counter or prefix gentemp * * symbol-package * packages make-package * * packages package * " package-name * " begin-package * " end-package * " intern X * " takes optional package name remob X * " takes optional package name internedp * internp " takes optional package name externalp * * " export * * " unexport * * " import * * " shadow * * " use * * " provide * " require * * " package-use-conflicts * * do-symbols * pkgs, blk tags do-external-symbols * pkgs, blk tags do-internal-symbols * pkgs, blk tags do-all-symbols * pkgs, blk tags zerop X true for complex zero plusp * minusp * oddp * evenp * = * * /= * * < * * > * * <= * * >= * * max * should be function, not macro min * should be function, not macro fuzzy= * * fuzziness * + * * - * * * * * / * * 1+ add1 1- sub1 1+ and 1- can't be scanned as IDs with the current PSL scanner incf U decf U conjugate * complex #s gcd * * cplx, rationals lcm * * cplx, rationals ....exponetial, logarithmic and trigonometric functions float X * takes optional "other" floating point #, supposed to use that type rational * rationals rationalize * * rationals numerator * rationals denominator * rationals |
Added psl-1983/doc/common.hlp version [a337d06dce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | This file is an appendix to the 29 July (Colander) Edition of the Common Lisp Reference Manual. Certain chapters have not been implemented at all, but those that are largely available have only the exceptions described. Chapter 5. DEFUN DECLARE is legal but does nothing. No implicit BLOCK. DOC-STRING not put on property list. DEFSELECT Not defined. DEFCONST Conflicting PSL definition. Probably not final Common Lisp def. anyway. (Latest report is that it will be named DEFCONSTANT). Chapter 6. TYPEP, SUBTYPEP Not defined. RATIONALP Not defined (No rationals). COMPLEXP Not defined (No complex numbers). VECTORP Only true of (vector t) ARRAYP True of vectors currently. No arrays yet. CLOSUREP Not defined (no closures). EQUALP No FUZZ optional argument. Same as EQUAL. Chapter 7. CLOSURE Not defined (No closures). SWAPF, EXCHF Not defined. FLET, LABELS, MACROLET Not defined (No local function definition). CASE Incompatible PSL definition. TYPECASE Not defined. BLOCK Not defined. RETURN Restricted placement. RETURN-FROM Not defined. Section 7.8.3 Mapping. The MAP functions in Standard Lisp take a single list as the first argument and the function as the second argument. This is highly incompatible with Common Lisp. The means of dealing with this has not been determined yet. PROG No initializations. PROG* Currently the same as PROG, since no initializations. GO Restricted placement. Section 7.9 Multiple Values Multiple values do not exist in PSL. CATCH Incompatible PSL definition. *CATCH follows this definition, with a single FORM. CATCH-ALL, UNWIND-ALL, UNWIND-PROTECT Not defined. Chapter 8. DEFMACRO The PSL version has destructuring but not keywords. Chapter 9. DECLARE, LOCALLY, THE Currently defined as macros which do nothing. Chapter 10. The current PSL implementation of property lists uses an a-list instead of the Common Lisp specification of alternating indicators and values. GETPR No optional DEFAULT value. GETF, PUTF, REMF Not defined. GET-PROPERTIES, MAP-PROPERTIES Not defined. COPYSYMBOL Not defined. GENSYM No optional argument. GENTEMP Not defined. SYMBOL-PACKAGE Not defined. Chapter 11. A very simple package system is implemented in PSL which is not compatible with this specification and is not fully integrated. Functions other than those below are not defined. INTERN, REMOB, INTERNEDP No optional package. Chapter 12. Complex numbers and ratios are not implemented in PSL. The functions which are defined from this chapter are listed below. Others may be defined in the MATHLIB module. ZEROP, PLUSP, MINUSP, ODDP, EVENP Return NIL instead of error for non-numeric arguments. =, <=, >=, etc. Two arguments only. MAX, MIN Defined as described. +, -, *, / Defined as described. INCF, DECF Defined as described. EXPT POWER must be an integer. ABS Defined as described (no complex numbers, though). FLOAT No optional OTHER. MOD Two arguments required, must be integers. LOGIOR, LOGXOR, LOGAND, LOGNOT, ASH Defined as described. Chapter 13. The CHARS module defines these functions, with the following exceptions. MAKE-CHAR Not defined. DIGIT-WEIGHT Not defined. CHAR-NAME, NAME-CHAR Not defined. Chapter 14. Many of the sequence functions are defined in PSL for lists only (e.g. LENGTH), and many use keyword arguments, which are not implemented. The following are defined: ELT, SETELT Defined as described. SUBSEQ END argument is required, not optional. COPYSEQ, CATENATE Defined as described. Chapter 15. LIST-LENGTH No optional LIMIT. NTH Incompatible PSL definition. MAKE-LIST Not defined. APPEND, NCONC Takes only 2 arguments. PUSHNEW Not defined. BUTLAST, NBUTLAST No optional N (uses default value 1). SETNTH Not defined. SUBST, NSUBST EQUAL is used, not EQL. SUBSTQ, NSUBSTQ Not defined. NSUBLIS Not defined. Section 15.5 Using Lists as Sets Most of these functions require keywords. This section has not been implemented yet. Section 15.6 Association Lists. Not implemented yet. Section 15.7 Hash Tables Not yet implemented. Chapter 16. Arrays do not yet exist in PSL. Chapter 17. The string functions are obtained by LOADing the STRINGS module. CHAR Conflicting PSL definition. Not defined. STRING=, STRING-EQUAL, etc. 2 arguments only. No keyword arguments. MAKE-STRING FILL-CHARACTER is required. STRING-UPCASE, STRING-DOWNCASE, STRING-CAPITALIZE No keyword arguments. STRING Conflicting PSL definition. Called STRINGIFY in the STRINGS pkg. Chapter 18. Structures. We are currently using a version of DEFSTRUCT close to this, obtained by LOADing NSTRUCT. This isn't documented and has some bugs, but it uses the same code as the LispM DEFSTRUCT. Chapter 19. The Evaluator. This chapter is incomplete. Chapter 20. Streams. Streams are not yet implemented in PSL in this fashion. Chapter 21. Input and Output. Not yet implemented. Chapter 22. File System Interface. Not yet implemented. Chapter 23. Errors. Not yet implemented. Chapter 24. The Compiler. Not yet implemented. |
Added psl-1983/doc/data-base.mss version [b656e7d04f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 25-Nov-82 06:12:44-PST,5564;000000000001 Date: 25 Nov 1982 0557-MST From: Martin Griss <Griss@Utah-20> Subject: Database To: griss.hplabs at UDel-Relay, hplabs!griss.UTAH-CS at Utah-20 cc: griss at Utah-20 Via: Utah-20; 25 Nov 82 8:07-EST Via: Udel-Relay; 25 Nov 82 5:24-PDT Via: UDel; 25 Nov 82 6:11-PDT @pageheading[left "Database Project Proposal", right "@value[page]"] @begin[center] Project Proposal for CS638, Databases William F. Galway @value[date] @end[center] This paper proposes the development of tools for the maintenance of the PSL programming environment. Although PSL is the specific target of the tools, many of the concepts (and perhaps some of the code) could be applied to other programming environments. These tools are similar to the Source Code Control System (SCCS) of Programmer's Workbench (under Unix), and the MasterScope utility of INTERLISP. These tools are meant to solve the following problems: @begin[enumerate] Keeping a history of PSL development. Maintaining consistency of the system across multiple sites. Maintaining consistency between a function, functions which call it, and documentation which refers to it. Locating the source code and documentation for functions. @end[enumerate] To implement these tools, I intend to provide an interface to utilities already present on our Vax-unix operating systems, and to extend some utilities currently present in PSL. @Comment[Interface to RCS.] @Comment{files vs functions?} @heading[Keeping a history of development] The @i[Revision Control System] (RCS, similar to SCCS) allows the user to keep multiple versions of text files. It does this "efficiently" by only storing differences between files, while sharing their common parts. It also stores information about authorship of files and the reasons for changes to them. This information will be used by other tools in the proposed project. @begin[Comment] Maintenance on different machines. Need a "database" indicating our idea of foreign site's state. Periodically we mail changes, in the form of (last-mailed-version, current-version). last-mailed-version corresponds to "root" for "join" operation of RCS. Can easily check for any possible problems caused by foreign site, even if they don't maintain their own tree. (If they do, we could avoid mailing the last-mailed-version, but send a pointer to the last-mailed-version instead.) (Note that sites sending changes out must work harder than recieving sites?) @end[Comment] @heading[Maintaining consistency between sites] PSL is under devlopment at two sites, the University of Utah and Hewlett Packard Research labs in Palo Alto. Obviously, problems occur when changes are made to corresponding files at both sites. To deal with this problem, each site needs to "mail" changes to the other site(s). I assume that each such mailing re-establishes consistency between those two sites. I propose that each "devlopment" site keep a record of when mailings were sent. Each new mailing will involve the following: @begin[itemize] Finding all files which have changed since the last mailing. (This information can be retrieved from RCS.) The transmission (via network or mag-tape, say) of the new files. (Or of their incremental changes from the previously mailed files.) At the recieving site the recieved files (or their "last modified dates") must be compared with the most recent local version. Any local versions which have not been changed since the last receipt of mail can be superseded. Any files which have been changed locally must be "merged" with the received file. (RCS provides tools for automating this job, to some degree.) @end[itemize] (Unfortunately, this doesn't deal with the renaming of files--an area for more research!) @begin[Comment] Cross reference (tracing effects of changes). Must include .MSS support. Might implement .MSS by just giving a new reader, like READ vs XREAD (roughly speaking). Whenever it hits a function documentation line it just build a dummy function definition, which is manipulated by standard tools after that? (Might fit in well with comments as first class citizens, both the MSS reader and the other readers would return documentary commentary.) @end[Comment] @heading[Consistency between interrelated parts] PSL currently provides a cross-reference utility to find interrelationships between functions. Also, the ".MSS" sources for the PSL manual clearly mark definitions of and references to functions. I propose to use this information in the following ways: @begin[itemize] Given a list of files changed since a given date, to locate other files referring to them. (Or, perhaps it will be possible to work in units of functions rather than files.) Given a list of functions, to check that other functions and documentation referring to them agree on number of arguments, "type" of function (e.g. "macro" or "expr"), and any other information which can be easily extracted and compared. @end[itemize] @Heading[Locating things] PSL's cross-reference utility (or the EMACS tags utility, or PSL's "Inspect" utility) finds the location of function definitions (at least to the file level). A similar utility needs to be provided for ".MSS" files (also to be used for the consistency checking described above). I propose to write tools that will use this information to look up and print (or read into a screen editor running under PSL) source code and documentation for functions. ------- |
Added psl-1983/doc/debug.doc version [fca612a5b6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | THE REDUCE DEBUGGING PACKAGE A. C. Norman D. F. Morrison Last updated 19 February 1981. ABSTRACT A library of routines useful for program development and debugging in Reduce/Rlisp is described. Table of Contents 1. Introduction 1 1.1. Use 1 1.2. Functions which depend on redefining user functions 1 1.3. Special considerations for compiled functions 1 1.4. A few known deficiencies 1 2. Tracing function execution 1 2.1. Saving trace output 1 2.2. Making tracing more selective 2 2.3. Turning off tracing 2 2.4. Automatic tracing of newly defined functions 2 3. A heavy handed backtrace facility 2 4. Embeded Functions 2 5. Counting function invocations 2 6. Stubs 3 7. Functions for printing useful information 3 8. Printing circular and shared structures 3 9. Safe List Access Functions 3 10. Library of Useful Functions 3 11. Internals and cusomization 3 11.1. User Hooks 3 11.2. Functions used for printing/reading 3 11.3. Flags 3 APPENDIX A: Example 4 1. Introduction The REDUCE debugging package contains a selection of functions that can be used to aid program development and to investigate faulty programs. It contains the following facilities. - A trace package. This allows the user to see the arguments passed to and the values returned by selected functions. It is also possible to have traced interpreted functions print all the assignments they make with SETQ (see section 2). - A backtrace facility. This allows one to see which of a set of selected functions were active when an error occurred (section 3). - Embedded functions make it possible to do everything that the trace package can do, and much more besides (section 4). - Some primitive statistics gathering (section 5). - Generation of simple stubs. When invoked, procedures defined as stubs simply print their argument and read a value to return (section 6). - Some functions for printing useful information, such as property lists, in an intelligible format (section 7). - PRINTX is a function that can print circular and re-entrant lists, and so can sometimes allow debugging to proceed even in the face of severe damage caused by the wild use of RPLACA and RPLACD (section 8). - A set of functions !:CAR,...,!:CDDDDR, !:RPLACA, !:RPLACD and !:RPLACW that behave exactly as the corresponding functions with the !: removed, except that they explicitly check that they are not used improperly on atomic arguments (section 9). - A collection of utility functions, not specifically intended for examining or debugging code, but often useful (section 10). 1.1. Use To use load <REDUCE.UTAH>DEBUG.FAP FLOAD <REDUCE.UTAH>DEBUG.FAP; 1.2. Functions which depend on redefining user functions A number of facilities in Debug depend on redefining user functions, so that they may log or print behavior when called. The Debug package tries to redefine user functions once and for all, and then keep specific information about what is required at run time in a table. This allows considerable flexibility, and is used for a number different facilities, including trace/traceset (section 2), a backtrace facility (section 3), some statistics gathering (section 5)and EMB functions (section 4). Some, like trace and EMB, only take effect if further action is requested on specific user functions. Others, like backtrace and statistics are of a more global nature. Once one of these global facilities is enabled it applies to all functions which have been made "known" to Debug. To undo this, use RESTR (section 2.3). 1.3. Special considerations for compiled functions All functions in Debug which depend on redefining user functions must make some assumptions about the number of arguments. The Debug package is able to find the correct names for the arguments of interpreted functions, and also for functions loaded from FAP files and generated with an argument naming option. This option is enabled by setting the switch ON ARGNAMES; % for full names of all arguments or ON ARGCOUNT; % args will be printed with names A1,A2,... before compiling the relevant functions. If Debug can not find out for itself how many arguments a function has, it will interactively ask for assistance. In reply to the question HOW MANY ARGUMENTS DOES xxxx HAVE? it is possible to reply one of: ? ask for assistance UNKNOWN give up <number> specify the number of arguments (name ...) give the names of arguments. If you give an incorrect answer to the question, the system may misbehave in an arbitrary manner. There can be problems if the answer UNKNOWN is given and subsequently functions get redefined or recompiled - if at all possible find out how many arguments are taken by the function that you wish to trace. It is possible to suppress the argument number query with ON TRUNKNOWN This is equivalent to always answering "UNKNOWN". 1.4. A few known deficiencies - An attempt to trace certain system functions (e.g.CONS) will cause the trace package to overwrite itself. Given the names of functions that cause this sort of trouble it is fairly easy to change the trace package to deal gracefully with them - so report trouble to a system expert. - Once fast links are established trace can not work. Fast links are turned off when Debug is loaded, and even if they are restored they are turned off each time TR or a related function is called. In Standard Lisp 1.6 on the PDP10/20 the statement ON NOUUO; will also suppress fast links. Thus either load Debug or do ON NOUUO prior to any attempt to execute code that will need to be traced. - The portable Lisp compiler uses information about which registers certain system functions destroy. Tracing these functions may make the optimizations based thereon invalid. The correct way of handling this problem is currently under consideration. In the mean time you should avoid tracing any functions with the ONEREG or TWOREG flags. On the PDP10/20 these currently include UPBV FLOATP FLOAT NUMVAL LPOSN NCONS POSN FIXP GET EXAMINE SCANSET SETPCHAR EJECT TYO BINI BIGP PRINC ABS CODEP LINELENGTH STRINGP MINUS PAIRP RECLAIM TERPRI XCONS UNTYI *BOX CONS MKVECT GETD ATSOC CLOSE GCTIME MKCODE REVERSE ASCII BINO LENGTH FILEP PUTV SPEAK DELIMITER PAGELENGTH RDSLSH TIME REMD FIX CONSTANTP INUMP ATOM VECTORP GETV IDP REMPROP EXCISE NUMBERP PUT LETTER - The current implementation does not handle MACROs correctly. It is not possible to expand a MACRO and not evaluate the resulting expansion. This deficiency will be remedied shortly. In the mean time do not use any traced MACROs under the influence of ON DEFN. 2. Tracing function execution To see when a function gets called, what arguments it is given and what value it returns, do TR functionname; or if several functions are of interest, TR name1,name2,...; If the specified functions are defined (as EXPR, FEXPR or MACRO), and fast links to them have not yet been established (section 1.4), this REDUCE statement modifies the function definition to include print statements. The following example shows the style of output produced by this sort of tracing: The input... SYMBOLIC PROCEDURE XCDR A; CDR A; % A very simple function; TR XCDR; XCDR '(P Q R); gives output... XCDR entered A: (P Q R) XCDR = (Q R) Interpreted functions can also be traced at a deeper level. TRST name1,name2...; causes the body of an interpreted function to be redefined so that all assignments (made with SETQ) in its body are printed. Calling TRST on a function automatically has the effect of doing a TR on it too, and the use of UNTR automatically does an UNTRST if necessary (section 2.3), so that it is not possible to have a function subject to TRST but not TR. Trace output will often appear mixed up with output from the program being studied, and to avoid too much confusion TR arranges to preserve the column in which printing was taking place across any output that it generates. If trace output is produced when part of a line has been printed, the trace data will be enclosed in markers '<' and '>', and these symbols will be placed on the line so as to mark out the amount of printing that had occurred before trace was entered. 2.1. Saving trace output The trace facility makes it possible to discover in some detail how a function is used, but in certain cases its direct use will result in the generation of vast amounts of (mostly useless) print-out. There are several options. One is to make tracing more selective (section 2.2). The other, discussed here, is to either print only the most recent information, or dump it all to a file to be perused at leisure. Debug has a ring buffer in which it saves information to reproduce the most recent information printed by the trace facility (both TR and TRST). To see the contents of this buffer use TR without any arguments TR; To set the number of entries retained to n use NEWTRBUFF(n); It is initially set to 5. Turning off the TRACE flag OFF TRACE; will suppress the printing of any trace information at run time; it will still be saved in the ring buffer. Thus a useful technique for isolating the function in which an error occurs is to trace a large number of candidate functions, do OFF TRACE and after the failure look at the latest trace information by calling TR with no arguments. Normally trace information is directed to the standard output, rather than the currently selected output. To send it elsewhere use the statement TROUT filename; The statement STDTRACE; Will close that file and cause future trace output to be sent to the standard output. Note that output saved in the ring buffer is sent to the currently selected output, not that selected by TROUT. 2.2. Making tracing more selective The function TRACECOUNT(n) can be used to switch off trace output. If n is a positive number, after a call to TRACECOUNT(n) the next n items of trace output that are generated will not be printed. TRACECOUNT(n) with n negative or zero switches all trace output back on. TRACECOUNT(NIL) returns the residual count, i.e. the number of additional trace entries that will be suppressed. Thus to get detailed tracing in the stages of a calculation that lead up to an error, try TRACECOUNT 1000000; % or some other suitable large number TR ....; % as required % run the failing problem TRACECOUNT NIL; It is now possible to calculate how many trace entries occurred before the error, and so the problem can now be re-run with TRACECOUNT set to some number slightly less than that. An alternative to the direct of TRACECOUNT is TRIN. To use TRIN, establish tracing for a collection of functions, using TR in the normal way. Then do TRIN on some small collection of other functions. The effect is just as for TR, except that trace output will be inhibited except when control is dynamically within the TRIN functions. This makes it possible to use TR on a number of heavily used general purpose functions, and then only see the calls to them that occur within some specific sub-part of your entire program. UNTR undoes the effect of TRIN (section 2.3). The global variables TRACEMINLEVEL!* and TRACEMAXLEVEL!* (which should be non-negative integers) are the minimum and maximum depths of recursion at which to print trace information. Thus if you only want to see top level calls of a highly recursive function (like a simple-minded version of LENGTH) simply do TRACEMAXLEVEL!* := 1; 2.3. Turning off tracing When a particular function no longer needs tracing, do UNTR functionname; or UNTR name1,name2...; This merely suppresses generation of trace output. Other information, such as invocation counts, bactrace information, and the number of arguments is retained. Thus UNTR followed later by TR will not have to enquire about the number of arguments. To completely destroy information about a function use RESTR name1,name2...; This returns the function to it's original state. To suppress traceset output without suppressing normal trace output use UNTRST name1,name2...; UNTRing a TRSTed function also UNTRST's it. TRIN (section 2.2) is undone by UNTR (but not by UNTRST). 2.4. Automatic tracing of newly defined functions Under the influence of ON TRACEALL; any functions successfully defined by PUTD will be traced. Note that if PUTD fails (as might happen under the influence of the LOSE flag) no attempt will be made to trace the function. To enable those facilities (such as BTR (section 3) and TRCOUNT (section 5)) which require redefinition, but without tracing, use ON INSTALL; Thus, a common scenario might look like ON INSTALL; IN MYFNS.RED$ OFF INSTALL; which would enable the backtrace and statistics routines to work with all the functions defined in MYFNS.RED. Warning: if you intend to use ON TRACEALL or ON INSTALL, make sure that fast links are suppressed before you define ANY functions, even those you will never trace (section 1.4). 3. A heavy handed backtrace facility BTR f1,f2,...; arranges that a stack of functions entered but not left is kept - this stack records the names of functions and the arguments that they were called with. If a function returns normally the stack is unwound. If however the function fails, the stack is left alone by the normal LISP error recovery processes. To print this information call BTR without any arguments BTR; Calling BTR on new functions resets the stack. This may also be done by explicitly calling RESBTR RESBTR; The disposition of information about functions which failed within an ERRORSET is controlled by the BTRSAVE. ON BTRSAVE will cause them to be save separately, and printed when the stack is printed; OFF BTRSAVE will cause them to be thrown away. OFF BTR will suppress saving of any BTR information. Note that any traced function will have its invocations pushed and popped by the BTR maechanism. 4. Embeded Functions EMBEDDING means redefining a function in terms of its old definition, usually with the intent that the new version will do some tests or printing, use the old one, do some more printing and then return. If ff is a function of two arguments, it can be embedded using a statement of the form: SYMBOLIC EMB PROCEDURE ff(A1,A2); << PRINT A1; PRINT A2; PRINT ff(A1,A2) >>; The effect of this particular use of embed is broadly similar to a call TR ff, and arranges that whenever ff is called it prints both its arguments and its result. After a function has been embedded, the embedding can be temporarily removed by the use of UNEMBED ff; and it can be reinstated by EMBED ff; 5. Counting function invocations Whenever the flag TRCOUNT is ON the number of times user functions known to Debug are entered is counted. The statement ON TRCOUNT; also resets that count to zero. The statement OFF TRCOUNT; causes a simple histogram of function invocations to be printed. To make Debug aware of a function use TRCNT name1,name2,...; See also section 2.4. 6. Stubs The statement STUB FOO(U,V); defines an EXPR, FOO, of two arguments. When executed such a stub will print its arguments and read a value to return. FSTUB is used to define FEXPR's. This is often useful when developing programs in a top down fashion. At present the currently (i.e. when the stub is executed) selected input and output are used. This may be changed in the future. Algebraic and possibly MACRO stubs may be implemented in the future. 7. Functions for printing useful information PLIST id1,id2,...; prints the property lists of the specified id's. PPF fn1,fn2,...; prints the definitions and other useful information about the specified functions. 8. Printing circular and shared structures Some LISP programs rely on parts of their datastructures being shared, so that an EQ test can be used rather than the more expensive EQUAL one. Other programs (either deliberately or by accident) construct circular lists through the use of RPLACA or RPLACD. Such lists can be displayed by use of the function PRINTX. If given a normal list the behaviour of this function is similar to that of PRINT - if it is given a looped or re-entrant datastructure it prints it in a special format. The representation used by PRINTX for re-entrant structures is based on the idea of labels for those nodes in the structure that are referenced more than once. Consider the list created by the operations: A:=NIL . NIL; % make a node RPLACA(A,A); RPLACD(A,A); % point it at itself If PRINTX is called on the list A it will discover that the node is referenced repeatedly, and will invent the label %L1 for it. The structure will then be printed as %L1: (%L1 . %L1) where %L1: sets the label, and the other instances of %L1 refer back to it. Labelled sublists can appear anywhere within the list being printed. Thus the list B := 'X . A; could be printed as (X . %L1: (%L1 . %L1)) This use of dotted pair representation is often clumsy, and so it gets contracted to (X %L1, %L1 . %L1) where a label set with a comma (rather than a colon) is a label for part of a list, not for the sublist. 9. Safe List Access Functions The functions !:CAR, ... !:CDDDDR, !:RPLACA, !:RPLACD and !:RPLACW all contain explicit checks to ensure that they are not used improperly on atomic arguments. The user can either edit source files systematically changing CAR into !:CAR etc and recompile everything to use these, or use !:REDEFINE. The function !:REDEFINE (of no arguments) redefines CAR, CDR, etc. to be !:CAR, etc. It leaves the original, "dangerous" definitions under !%CAR, etc. A second call on !:REDEFINE undoes the process. Warning: the second technique will not normally work with compiled functions, as CAR, CDR, etc are often compiled inline. 10. Library of Useful Functions Debug contains a library of utility functions which may be useful to those debugging code. The collection is as yet very small. Suggestions for further functions to be in corporated are definitely solicited. Those currently available: REDEFINE(nam,old,new) redefines the function named <nam> to be the same as that named <new>. If <old> is non-nil, the former definition is stored under the name <old>. For example, REDEFINE('EVAL,'!%EVAL,'MYEVAL) saves the definition of EVAL as %EVAL, and redfines it to be MYEVAL. COPY U returns a freshly cons'd together copy of U, often usefull in debugging functions which use RPLACA/RPLACD. VCOPY U Like COPY, but copies vectors, non-unique numbers, and strings, too. 11. Internals and cusomization This section describes some internal details of the Debug package which may be useful in customizing it for specific applications. The reader is urged to consult the source (section <REDUCE.UTAH>DEBUG.RED) for further details. 11.1. User Hooks These are all global variables whose value is normally NIL. If non-nil they should be exprs taking the number of variables specified, and will be called as specified. PUTDHOOK!* takes one argument, the function name. It is called after the function has been defined, and any tracing under the influence of TRACEALL or INSTALL has taken place. It is not called if the function cannot be defined (as might happen under the influence of the LOSE flag). TRACENTRYHOOK!* takes two arguments, the function name and a list of the actual arguments. It is called by the trace package whenever a traced function is entered, but before it is executed. The execution of a surrounding EMB function takes place after TRACENTRYHOOK!* is called. This is useful when you need to call special user- provided print routines to display critical data structures, as are TRACEXITHOOK!* and TRACEXPANDHOOK!*. TRACEXITHOOK!* takes two arguments, the function name and the value. It is called after the function has been evaluated. TRACEXPANDHOOK!* takes two arguments, the function name and the macro expansion. It is only called for macros, and is called after the macro is expanded, but before the expansion has been evaluated. TRINSTALLHOOK!* takes one argument, a function name. It is called whenever a function is redefined by the Debug package, as for example when it is first traced. It is called before the redefinition takes place. 11.2. Functions used for printing/reading These should all contain EXPRS taking the specified number of arguments. The initial values are given in square brackets. PPFPRINTER!* [RPRINT] takes one argument. It is used by PPF to print the body of an interpreted function. PROPERTYPRINTER!* [PRETTYPRINT] takes one argument. It is used by PLIST to print the values of properties. STUBPRINTER!* [PRINTX] takes one argument. Stubs defined with STUB/FSTUB use it to print their arguments. STUBREADER!* [XREAD(NIL)] takes no arguments. Stubs defined with STUB/FSTUB use it to read their return value. TREXPRINTER!* [RPRINT] takes one argument. It is used to print the expansions of traced macros. TRPRINTER!* [PRINTX] takes one argument. It is used to print the arguments and values of traced functions. 11.3. Flags These are all flags which can be set with the Reduce/Rlisp ON/OFF statements. Their initial setting is given in square brackets. Many have been described above, but are collected here for reference. BTR [on] enables backtracing of functions which the Debug package has been told about. BTRSAVE [on] causes backtrace information leading up to an error within an errorset to be saved. INSTALL [off] causes all Debug to know about all functions defined with PUTD. SAVENAMES [off] causes names assigned to substructures by PRINTX to be retained from one use to the next. Thus substurctures common to different items will be show as the same. TRACE [on] enables runtime printing of trace information for functions which have been traced. TRACEALL [off] causes all functions defined with PUTD to be traced. TRUNKNOWN [off] instead of querying the user for the number of arguments to a compiled EXPR, just assumes the user will say "UNKNOWN". TRCOUNT [on] enables counting invocations of functions known to Debug. Note that ON TRCOUNT resets the count, and OFF TRCOUNT prints a simple histogram of the available counts. APPENDIX A: Example This contrived example demonstrates many of the available features. It is a transcript of an actual Reduce session. REDUCE 2 (Dec-1-80) ... FOR HELP, TYPE HELP<ESCAPE> 1: CORE 80; 2: FLOAD <MORRISON>NUDBUG.FAP; 3: SYMBOLIC PROCEDURE FOO N; 3: BEGIN SCALAR A; 3: IF REMAINDER(N,2) NEQ 0 AND N < 0 THEN 3: A := !:CAR N; % Should err out if N is a number 3: IF N = 0 THEN 3: RETURN 'BOTTOM; 3: N := N-2; 3: A := BAR N; 3: N := N-2; 3: RETURN LIST(A,BAR N,A) 3: END FOO; FOO 4: SYMBOLIC PROCEDURE FOOBAR N; 4: << FOO N; NIL>>; FOOBAR 5: SYMBOLIC OPERATOR FOOBAR; NIL 6: TR FOO,FOOBAR; (FOO FOOBAR) 7: PPF FOOBAR,FOO; EXPR procedure FOOBAR(N) [Traced;Invoked 0 times;Flagged: OPFN]: <<FOO N; NIL>>; EXPR procedure FOO(N) [Traced;Invoked 0 times]: BEGIN SCALAR A; IF NOT REMAINDER(N,2)=0 AND N<0 THEN A := !:CAR N; IF N=0 THEN RETURN 'BOTTOM; N := N - 2; A := BAR N; N := N - 2; RETURN LIST(A,BAR N,A) END; FOOBAR(FOO) 8: ON COMP; 9: SYMBOLIC PROCEDURE BAR N; 9: IF REMAINDER(N,2)=0 THEN FOO(2*(N/4)) ELSE FOO(2*(N/4)-1); *** BAR 164896 BASE 20 WORDS 63946 LEFT BAR 10: OFF COMP; 11: FOOBAR 8; FOOBAR being entered N: 8 FOO being entered N: 8 FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL 0 12: % Notice how in the above PRINTX printed the return values 12: % to show shared structure 12: TRST FOO; (FOO) 13: FOOBAR 8; FOOBAR being entered N: 8 FOO being entered N: 8 N := 6 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) A := (BOTTOM BOTTOM BOTTOM) N := 4 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL 0 14: TR BAR; *** How many arguments does BAR take ? 1 (BAR) 15: FOOBAR 8; FOOBAR being entered N: 8 FOO being entered N: 8 N := 6 BAR being entered A1: 6 FOO (level 2) being entered N: 2 N := 0 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM A := BOTTOM N := -2 BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) A := (BOTTOM BOTTOM BOTTOM) N := 4 BAR being entered A1: 4 FOO (level 2) being entered N: 2 N := 0 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM A := BOTTOM N := -2 BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL 0 16: OFF TRACE; 17: FOOBAR 8; 0 18: TR; *** Start of saved trace information *** BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL *** End of saved trace information *** 19: FOOBAR 13; ***** -1 illegal CAR 20: TR; *** Start of saved trace information *** BAR being entered A1: 11 FOO (level 2) being entered N: 3 N := 1 BAR (level 2) being entered A1: 1 FOO (level 3) being entered N: -1 *** End of saved trace information *** 21: BTR; *** Backtrace: *** These functions were left abnormally: FOO N: -1 BAR A1: 1 FOO N: 3 BAR A1: 11 FOO N: 13 FOOBAR N: 13 *** End of backtrace *** 22: SYMBOLIC EMB PROCEDURE FOO N; 22: IF N < 0 THEN << 22: LPRIM "FOO would have failed"; 22: NIL >> 22: ELSE 22: FOO N; FOO 23: RESBTR; 24: FOOBAR 13; *** FOO WOULD HAVE FAILED *** FOO WOULD HAVE FAILED *** FOO WOULD HAVE FAILED *** FOO WOULD HAVE FAILED 0 25: TR; *** Start of saved trace information *** BAR (level 2) = NIL FOO (level 2) = (NIL NIL NIL) BAR = (NIL NIL NIL) FOO = (%L1: (NIL NIL NIL) (NIL NIL NIL) %L1) FOOBAR = NIL *** End of saved trace information *** 26: BTR; *** No traced functions were left abnormally *** 27: UNEMBED FOO; (FOO) 28: FOOBAR 13; ***** -1 illegal CAR 29: STUB FOO N; *** FOO REDEFINED 30: FOOBAR 13; Stub FOO called N: 13 Return? : 30: BAR(N-2); Stub FOO called N: 3 Return? : 30: BAR(N-2); Stub FOO called N: -1 Return? : 30: 'ERROR; 0 31: TR; *** Start of saved trace information *** BAR being entered A1: 11 BAR (level 2) being entered A1: 1 BAR (level 2) = ERROR BAR = ERROR FOOBAR = NIL *** End of saved trace information *** 32: OFF TRCOUNT; FOOBAR(8) **************** BAR(24) ************************************************ 33: QUIT; |
Added psl-1983/doc/defstruct.doc version [623074a130].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | DEFSTRUCT - "Structure" definition facility. -------------------------------------------- Defstruct is similar to the Spice (Common) Lisp/Lisp machine/Maclisp flavor of struct definitions, and is expected to be subsumed by the Mode package. It is implemented in PSL as a function which builds access macros and fns for "typed" vectors, including constructor and alterant macros, a type predicate for the structure type, and individual selector/assignment fns for the elements. Defstruct understands a keyword-option oriented structure specification. First a few miscellaneous functions on types, before we get into the depths of defining Defstructs: DefstructP( NAME:id ): extra-boolean expr ---- -- ------------- ---- is a predicate that returns non-NIL (the Defstruct definition) if NAME is a structured type which has been defined using Defstruct, or NIL if it is not. DefstructType( S:struct ): id expr - ------ -- ---- returns the type name field of an instance of a structured type, or NIL if S cannot be a defstruct type. SubTypeP( NAME1:id, NAME2:id ): boolean expr ----- -- ----- -- ------- ---- returns true if NAME1 is a structured type which has been !:Include'd in the definition of structured type NAME2, possibly through intermediate structure definitions. (In other words, the selectors of NAME1 can be applied to NAME2.) Now the function which defines the beasties, in all its gory glory: Defstruct( name-and-options:{id,list}, [slot-descs:{id,list}] ): id fexpr ---------------- -- ---- ---------- -- ---- -- ----- Defines a record-structure data type. A general call to defstruct looks like this: (in Rlisp syntax) defstruct( struct-name( option-1, option-2, ... ), slot-description-1, slot-description-2, ... ); % (The name of the defined structure is returned.) where slot-descriptions are: slot-name( default-init, slot-option-1, slot-option-2, ... ) Struct-name and slot-name are id's. If there are no options following a name in a spec, it can be a bare id with no option argument list. The default-init form is optional and may be omitted. The default-init form is evaluated EACH TIME a structure is to be constructed and the value is used as the initial value of the slot. Options are either a keyword id, or the keyword followed by its argument list. Options are described below. A call to a Constructor macro has the form: MakeThing( slot-name-1( value-expr-1 ), slot-name-2( value-expr-2 ), ... ); where the slot-name:value lists override the default-init values which were part of the structure definition. Note that the slot-names look like unary functions of the value, so the parens can be left off. A call to MakeThing with no arguments of course takes all of the default values. The order of evaluation of the default-init forms and the list of assigned values is undefined, so code should not depend upon the ordering. Implementors Note: Common/LispMachine Lisps define it this way, but Is this necessary? It wouldn't be too tough to make the order be the same as the struct defn, or the argument order in the constructor call. Maybe they think such things should not be advertized and thus constrained in the future. Or perhaps the theory is that constucts such as this can be compiled more efficiently if the ordering is flexible?? Also, should the overridden default-init forms be evaluated or not? I think not. The Alterant macro calls have a similar form: AlterThing( thing, slot-name-1 value-expr-1, slot-name-2 value-expr-2, ... ); where the first argument evaluates to the struct to be altered. (The optional parens were left off here.) This is just a multiple-assignment form, which eventually goes through the slot depositors. Remember that the slot-names are used, not the depositor names. (See !:Prefix, below.) The altered structure instance is returned as the value of an Alterant macro. Implementators note: Common/LispMachine Lisp defines this such that all of the slots are altered in parallel AFTER the new value forms are evaluated, but still with the order of evaluation of the forms undefined. This seemed to lose more than it gained, but arguments for its worth will be entertained. Options: Structure options appear as an argument list to the struct-name. Many of the options themselves take argument lists, which are sometimes optional. Option id's all start with a colon (!:), on the theory that this distinguishes them from other things. By default, the names of the constructor, alterant and predicate macros are MakeName, AlterName and NameP, where "Name" is the struct-name. The !:Constructor, !:Alterant, and !:Predicate options can be used to override the default names. Their argument is the name to use, and a name of NIL causes the respective macro not to be defined at all. The !:Creator option causes a different form of constructor to be defined, in addition to the regular "Make" constructor (which can be suppressed.) As in the !:Constructor option above, an argument supplies the name fo the macro, but the default name in this case is CreateName. A call to a Creator macro has the form: CreateThing( slot-value-1, slot-value-2, ... ); where ALL of the slot-values of the structure MUST BE PRESENT, in the order they appear in the structure definition. No checking is done, other than assuring that the number of values is the same as the number of slots. For obvous reasons, constructors of this form ARE NOT RECOMMENDED for structures with many fields, or which may be expanded or modified. Slot selector macros may appear on either the LHS or the RHS of an assignment. They are by default named the same as the slot-names, but can be given a common prefix by the !:Prefix option. If !:Prefix does not have an argument, the structure name is the prefix. If there is an argument, it should be a string or an id whose printname is the prefix. The !:Include option allows building a new structure definition as an extension of an old one. The required argument is the name of a previously defined structure type. The access functions for the slots of the source type will also work on instances of the new type. This can be used to build hierarchies of types, where the source types contain generic information in common to the more specific subtypes which !:Include them. The !:IncludeInit option takes an argument list of "slot-name(default-init)" pairs, like slot-descriptors without slot-options, and files them away to modify the default-init values for fields inherited as part of the !:Include'd structure type. Slot Options: Slot-options include the !:Type option, which has an argument declaring the type of the slot as a type id or list of permissible type id's. This is not enforced now, but anticipates the Mode system structures. The !:UserGet and !:UserPut slot-options allow overriding the simple vector reference and assignment semantics of the generated selector macros with user-defined functions. The !:UserGet fn name is a combination of the slot-name and a !:Prefix if applicable. The !:UserPut fn name is the same, with "Put" prefixed. One application of this capability is building depositors which handle the incremental maintenance of parallel datastructures as a side effect, such as automatically maintaining display file representations of objects which are resident in a remote display processor in parallel with modifications to the Lisp structures which describe the objects. The Make and Create macros bypass the depositors, while Alter uses them. A simple example: (Input lines have a "> " prompt at the beginning.) > % (Do definitions twice to see what functions were defined.) > macro procedure TWICE u; list( 'PROGN, second u, second u ); TWICE > % A definition of Complex, structure with Real and Imaginary parts. > % Redefine to see what functions were defined. Give 0 Init values. > TWICE > Defstruct( Complex( !:Creator(Complex) ), R(0), I(0) ); *** Function `MAKECOMPLEX' has been redefined *** Function `ALTERCOMPLEX' has been redefined *** Function `COMPLEXP' has been redefined *** Function `COMPLEX' has been redefined *** Function `R' has been redefined *** Function `PUTR' has been redefined *** Function `I' has been redefined *** Function `PUTI' has been redefined *** Defstruct `COMPLEX' has been redefined COMPLEX > C0 := MakeComplex(); % Constructor with default inits. [COMPLEX 0 0] > ComplexP C0; % Predicate. T > C1:=MakeComplex( R 1, I 2 ); % Constructor with named values. [COMPLEX 1 2] > R(C1); I(C1); % Named selectors. 1 2 > C2:=Complex(3,4) % Creator with positional values. [COMPLEX 3 4] > AlterComplex( C1, R(2), I(3) ); % Alterant with named values. [COMPLEX 2 3] > C1; [COMPLEX 2 3] > R(C1):=5; I(C1):=6; % Named depositors. 5 6 > C1; [COMPLEX 5 6] > % Show use of Include Option. (Again, redef to show fns defined.) > TWICE > Defstruct( MoreComplex( !:Include(Complex) ), Z(99) ); *** Function `MAKEMORECOMPLEX' has been redefined *** Function `ALTERMORECOMPLEX' has been redefined *** Function `MORECOMPLEXP' has been redefined *** Function `Z' has been redefined *** Function `PUTZ' has been redefined *** Defstruct `MORECOMPLEX' has been redefined MORECOMPLEX > M0 := MakeMoreComplex(); [MORECOMPLEX 0 0 99] > M1 := MakeMoreComplex( R 1, I 2, Z 3 ); [MORECOMPLEX 1 2 3] > R C1; 5 > R M1; 1 > % A more complicated example: The structures which are used in the > % Defstruct facility to represent defstructs. (The EX prefix has > % been added to the names to protect the innocent...) > TWICE % Redef to show fns generated. > Defstruct( > EXDefstructDescriptor( !:Prefix(EXDsDesc), !:Creator ), > DsSize( !:Type int ), % (Upper Bound of vector.) > Prefix( !:Type string ), > SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) > ConsName( !:Type fnId ), > AltrName( !:Type fnId ), > PredName( !:Type fnId ), > CreateName( !:Type fnId ), > Include( !:Type typeid ), > InclInit( !:Type alist ) > ); *** Function `MAKEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `ALTEREXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDEFSTRUCTDESCRIPTORP' has been redefined *** Function `CREATEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDSDESCDSSIZE' has been redefined *** Function `PUTEXDSDESCDSSIZE' has been redefined *** Function `EXDSDESCPREFIX' has been redefined *** Function `PUTEXDSDESCPREFIX' has been redefined *** Function `EXDSDESCSLOTALIST' has been redefined *** Function `PUTEXDSDESCSLOTALIST' has been redefined *** Function `EXDSDESCCONSNAME' has been redefined *** Function `PUTEXDSDESCCONSNAME' has been redefined *** Function `EXDSDESCALTRNAME' has been redefined *** Function `PUTEXDSDESCALTRNAME' has been redefined *** Function `EXDSDESCPREDNAME' has been redefined *** Function `PUTEXDSDESCPREDNAME' has been redefined *** Function `EXDSDESCCREATENAME' has been redefined *** Function `PUTEXDSDESCCREATENAME' has been redefined *** Function `EXDSDESCINCLUDE' has been redefined *** Function `PUTEXDSDESCINCLUDE' has been redefined *** Function `EXDSDESCINCLINIT' has been redefined *** Function `PUTEXDSDESCINCLINIT' has been redefined *** Defstruct `EXDEFSTRUCTDESCRIPTOR' has been redefined EXDEFSTRUCTDESCRIPTOR > TWICE % Redef to show fns generated. > Defstruct( > EXSlotDescriptor( !:Prefix(EXSlotDesc), !:Creator ), > SlotNum( !:Type int ), > InitForm( !:Type form ), > SlotFn( !:Type fnId ), % Selector/Depositor id. > SlotType( !:Type type ), % Hm... > UserGet( !:Type boolean ), > UserPut( !:Type boolean ) > ); *** Function `MAKEEXSLOTDESCRIPTOR' has been redefined *** Function `ALTEREXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCRIPTORP' has been redefined *** Function `CREATEEXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCSLOTNUM' has been redefined *** Function `PUTEXSLOTDESCSLOTNUM' has been redefined *** Function `EXSLOTDESCINITFORM' has been redefined *** Function `PUTEXSLOTDESCINITFORM' has been redefined *** Function `EXSLOTDESCSLOTFN' has been redefined *** Function `PUTEXSLOTDESCSLOTFN' has been redefined *** Function `EXSLOTDESCSLOTTYPE' has been redefined *** Function `PUTEXSLOTDESCSLOTTYPE' has been redefined *** Function `EXSLOTDESCUSERGET' has been redefined *** Function `PUTEXSLOTDESCUSERGET' has been redefined *** Function `EXSLOTDESCUSERPUT' has been redefined *** Function `PUTEXSLOTDESCUSERPUT' has been redefined *** Defstruct `EXSLOTDESCRIPTOR' has been redefined EXSLOTDESCRIPTOR > END; NIL |
Added psl-1983/doc/dict.spell version [e01743f3e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ACCESIBLE ADDA ADDI ADDM ADDQ ADDRESSP ADDRESSCONSTANTP ADDRESSINGUNITSPERITEM ADDRESSINGUNITSPERFUNCTIONCELL ALLOC ANYP ANYREG ANYREGCDR ANYREGCAR ANYREGNAME ANYREGTABLE ANYREGQUOTE ANYREGFUNCTION ANYREGPATTERNTABLE ANYREGRESOLUTIONFUNCTION AOS ARG ARGI ARGN ARGS AREGP ARGTWO ARGONE ARGTHREE ARGUMENTBLOCK ASM ASHIFT ASMOUT ASMSYMBOLP AUTOINCREMENT AUTODECREMENT BACKTRACE BEM BENSON BITWISE BITSPERWORD BLDMSG BODYI BOOTSTRAPPED BPS BT CDR CHARCONST CHARACTERSPERWORD CHECKFOREIGNEXTERN CHARSININPUTBUFFER CLR CLRL CLEARIO CLOSEFUNCTION CLEARBINDINGS CMAC CMACRO CMACRONAME CMACROPATTERNTABLE COMP COLONEQ COMPFNS CONJUCTION CODEPRINTF COPYRIGHTNOTICE CODEFILENAMEFORMAT COMMENTFORMAT CODEFILEHEADER CODEDECLAREEXTERNAL CODEFILETRAILER CRAY CTL CTRL CTSS CTIME DATAPRINTF DATAFILENAMEFORMAT DATAPROCSTATE DATAFILEHEADER DATAFILETRAILER DB DECL DEST DECLS DEALLOC DEFLIST DECREMENT DEFANYREG DEFCMACRO DEALLOCATION DEALLOCATES DEALLOCCOUNT DEALLOCATING DEFINEDFUNCTIONCELLFORMAT DIR DOCS DOUBLESIDED DQ DREG DREGP DROPFILE DUMPLISP DUMPFILENAME ECB ECHOON ECHOOFF EI EMACS EMODE ENTRYPOINTS EOF EOLS EQTP EQCAR ERROUT EXE EXPR EXTZV EXTERN EXTERNS EXTRAREG EXPANDONEARGUMENTANYREG EXITOPENCODE EXPORTEDDECLARATIONFORMAT EXTERNALDECLARATIONFORMAT FAC FASL FASLIN FASLOUT FASTLINK FACECODE FASTLINKS FFFFFF FIXP FILE NAME FILEPOINTEROFCHANNEL FLAGP FLATSIZE FLUIDSLIST FN FNAME FOO FOREACH FOREIGNCALL FOREIGNLINK FOREIGNFUNCTION FOREIGNEXTERNLIST FOREIGNENTRY FREERSTR FREERUTR FRAMESIZE FTYPE FUM FULLWORD FUNCTIONTYPE FUNCTIONNAME FULLWORDFORMAT GQMJR GRISS GT GTE GTSTR HALTF HALFWORD HALFWORDFORMAT HOSTPSL HRRZI ICONST IDP IDS IDLOC IMMEDIATEP IMMEDIATEQUOTE INF INCL INIT INUMS INUMP INTERP IN-CORE INTERLISP INTERUPTS INTERNALFUNCTION INTERNALLYCALLABLEP INITIALIZEINTERRUPTS ITH JCALL JFNS JSB JSR JSYS JUMPON JUMPEQ JUMPTYPE JUMPWGEQ JUMPWLEQ JUMPNOTEQ JUMPWITHIN JUMPINTYPE JUMPWLESSP JUMPNOTINTYPE JUMPNOTTYPE JUMPWGREATERP KLUDGE LAMBIND LASTBODY LABELLIST LASTACTUALREG LABELFORMAT LBL LEA LESSP LEFTMARGIN LINKE LIVERMORE LIBRARYFILE LISPSCANTABLE LOC LOGOS LOWDER LOWERBOUND LPT LT LTE MAPOBL MAGUIRE MAJORHEADING MAINENTRYPOINTNAME MEM MEMQ MINUSP MINUSSIGN MINUSONEP MKITEM MKDUMP MM MNEGL MOVI MOVL MOVNI MOVEM MOVEA MODNAME MODULENAME MSS MTLISP NARGS NALLOC NBYTES NEGINT NEWPAGE NEGATIVEQUICKICONSTP NEGATIVEIMMEDIATEP NFRAME NONLOCALVARS NUMBERP NUMBEROFARGUMENTS NUMERICREGISTERNAMES ODTIM OMNITECH ONEP ONEOPERANDANYREG OPS OPCODE OPCODES OPENFNS OPENCODE OPENFUNCT OS PASCAL PAGEHEADING PBIN PBOUT PDP PETERSON PGM POWEROFTWO PROG PREDI PRLISP PROGBIND PROGRBIND PRINTBYTE PRINTSTRING PRINTBYTELIST PRINTHALFWORDLIST PRINTHALFWORD PRINTOPCODE PRINTNUMERICOPERAND PROGRAMEXAMPLE PROMPTSTRING PSL PSLIO PSLMACROSNAMES PUSHL PUTFIELD PUTBITTABLE PV QUICKICONSTP RAWIO REG REMPROP REGISTERP RESOLVEOPERAND RESEARCHCREDIT REGISTERNAME RESERVEDATABLOCKFORMAT RESERVEZEROBLOCKFORMAT READFUNCTION RETURNADDRESSP RI RJ RLISP RN RSB RTS RUNTM SB SETOM SETZM SIGPLAN SIGNEDFIELD SL SMACROS SPECIALCHARACTERS SPECIALACTIONFORMAINENTRYPOINT SQ SSAVE STDIO STDIN STDOUT STDERROR STACKDIRECTION STANDARDLISP SUBQ SUBA SUBI SYSLSP SYMVAL SYSOUT SYMFNC SYSLISP SYSTEMOPENFILESPECIAL SYSTEMMARKASCLOSEDCHANNEL SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT TABEXPORT TERMINALOPERAND TERMINALINPUTHANDLER THS THRU TIMC TIMR TITLEBOX TITLEPAGE TIMESTAMPS TOPLOOP TRUNCATESTRING TWOOPERANDANYREG TYPETAG UNIX UNLK UNEXEC UNDEFINEDFUNCTIONCELLINSTRUCTIONS UPPERBOUND USERMODE VAX WARRAY WCONST WDIFFERENCE WEQ WGEQ WGREATERP WICAT WIDOWACTION WLEQ WLESSP WMINUS WNOT WOR WRITEFUNCTION WSHIFT WVAR WXOR XLISP XOR XS XXXX XXXXQ XXXXX XXXXXX YY ZBOOT ZEROP ZEROAREG |
Added psl-1983/doc/examples-for-imp-guide.mss version [d0e21079d0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @section(Examples of various kinds) Recall that when compiling code, variables which are used extended in one procedure, and bound as LAMBDA or PROG variables in another, must be declared fluids. Example: @begin(verbatim) (de foo(X) (PLUS2 X 1)), compiles to: (!*entry foo expr 1) (!*alloc 0) (!*move (quote 1) (reg 2)) (!*linke 0 plus2 expr 2) (de fee(X Y) (Fum (foo X) (foo Y)), compiles to: (!*entry fee expr 2) (!*alloc 2) (!*move (reg 2) (frame 2)) (!*link foo expr 1) (!*move (reg 1) (frame 1)) (!*move (frame 2) (reg 1)) (!*link foo expr 1) (!*move (reg 1) (reg 2)) (!*move (frame 1) (reg 1)) (!*linke 2 fum expr 2) Finally, (de fac (N) (cond ((Lessp N 1) 1) (T (Times2 N (fac SUB 1 N)) compiles to: (!*entry fac expr 1) (!*alloc 1) (!*move (reg 1) (frame 1)) (!*move (quote 1) (reg 2)) (!*link LessP expr 1) (!*jumpeq (label L) (quote nil) (reg 1)) (!*move (quote 1) (reg 1)) (!*exit 1) (!*lbl (label L)) (!*move (frame 1) (reg 1)) (!*link sub1 expr 1) (!*link fac expr 1) (!*move (reg 1) (reg 2)) (!*move (frame 1) (reg 1)) (!*linke 1 times2 expr 2) @end(verbatim) @section(BUILDING the CROSS Compiler) The executable @dq[xxxx-CROSS.EXE] is built as follows: @begin(verbatim) @@psl:rlisp ! an RLISP *mapobl function lambda X; *<< RemProp(X, 'OpenCode); * RemProp(X, 'ExitOpenCode) >>; % Remove old compiler opts * % Load common modules *load(zboot, pass!-one!-lap, if!-system, syslisp, lap!-to!-asm); * % Load XXXX specific modules *load(XXXX!-comp, XXXX!-cmac, XXXX!-asm); *off UserMode; *DumpFileName!* := "filename.exe"; % Establish the executable name *Date!*:=Concat("XXXX Cross Assmbler ", Date()); % Establish greeting *DumpLisp(); % Does a Reclaim and save *Quit; @end(verbatim) @subsection(An example of the process) The following is a complete example, from @syslisp to @CMACRO@xs: @begin(verbatim,leftmargin 0) @@PSL:RLISP PSL 3.0 Rlisp, 9-May-82 syslsp procedure Test1(); % Input RLISP syntax code begin scalar x; x := 5; x := x+7; L := '(A B C D); L1 := (CAR L) . CAR(CDR L); print L1; end; @End(verbatim) @begin(verbatim,leftmargin 0) % This is the output from the Compiler/LAP system. % The lines beginning with "(!* ... " are the Abstract % machine CMACRO's output from the compiler. % The indented lines following them are the VAX @sq[LAP] % assembly code the CMACRO patterns % (in the *-CMAC.SL files) produced by the expansion process. (!*PUSH '5) (@op{PUSHL} 5) (!*WPLUS2 (FRAME 1) (WCONST 7)) % WPLUS2 is actually a % CMACRO (OpenFunct) (@op{ADDL2} 7 (DEFERRED (REG ST))) % Note how the FRAME AnyReg % is converted directly to % a machine specific % addressing mode. (!*MOVE '(A B C D) (!$FLUID L)) (@op{MOVL} '(A B C D) (!$FLUID L)) (!*MOVE (CAR (CDR (!$FLUID L))) (REG 2)) % The AnyReg patterns (@op{EXTZV} 0 27 (!$FLUID L) (REG 2)) % for CAR and CDR are used (@op{EXTZV} 0 27 (DISPLACEMENT (REG 2) 4) (REG 2)) (@op{MOVL} (DEFERRED (REG 2)) (REG 2)) (!*MOVE (CAR (!$FLUID L)) (REG 1)) (@op{EXTZV} 0 27 (!$FLUID L) (REG 1)) (@op{MOVL} (DEFERRED (REG 1)) (REG 1)) (!*LINK CONS EXPR 2) % Standard Function Cell % call. (@op{JSB} (ENTRY CONS)) (!*MOVE (REG 1) (!$FLUID L1)) (@op{MOVL} (REG 1) (!$FLUID L1)) (!*LINK PRINT EXPR 1) (@op{JSB} (ENTRY PRINT)) (!*MOVE 'NIL (REG 1)) (@op{MOVL} (REG NIL) (REG 1)) % Reg NIL evaluates to an (!*EXIT 1) % immediate constant. (@op{ADDL2} 4 (REG ST)) (@op{RSB}) TEST1 @end(verbatim) @subsection(Prologues and Epilogues) An example of Prologues and Epilogues for (@APOLLO version of) the @68000 is given below: @begin(ProgramExample,leftmargin 0) lisp procedure CodeFileHeader(); % Pure Code Segment If !*MAIN then <<CodePrintF(" program %w,m0001%n",ModName!*); CodePrintF " data%n"; DataProcState!*:='data; CodePrintF "* Start of execution of the program%n"; CodeDeclareExternal 'SYMVAL; %/ Issue EXTERN.D early CodeDeclareExternal 'SYMFNC; %/ Issue EXTERN.D early CodePrintF "m0001 EQ *%n"; CodePrintF " move.l db,-(sp) Save caller db%n"; CodePrintF " clr.l -(sp) Push reserved word%n"; CodePrintF " move.l a0,-(sp) Push address of ECB%n"; CodePrintF " move.l SYMVAL+512,d0 Init NIL Reg%n"; CodePrintF " link sb,#0 Balance unlink%n"; CodePrintF " movea.l #0,a6 Setup zeroareg%n"; CodePrintF " lea m0001,db Setup db reg%n"; CodePrintF(" jsr %w Call Main routine%n", MainEntryPointNAme!*); CodePrintF "* now return to OS%n"; CodePrintF " movea.l A_PGM_$EXIT,a6%n"; CodePrintF " jsr (a6)%n"; CodePrintF " unlk sb Reload callers SB%n"; CodePrintF " addq.w #8,sp Pop linkage%n"; CodePrintF " movea.l (sp)+,db Reload callers db%n"; CodePrintF " rts Return%n"; ForeignExternList!*:=NIL; CheckForeignExtern 'PGM!_!$EXIT; >> else <<CodePrintF (" module %w,m0000%n",ModName!*); %/ Kludge, since ModuleName set in ASMOUT CodePrintF " data%n"; DataProcState!*:='data; CodeDeclareExternal 'SYMVAL; %/ Issue EXTERN.D early CodeDeclareExternal 'SYMFNC; %/ Issue EXTERN.D early CodePrintF "* this is an Independent Module %n"; ForeignExternList!*:=NIL; >>; lisp procedure DataFileHeader(); Begin DataPrintF(" module %w_D%n",ModName!*); DataPrintF " data%n"; End; lisp procedure DataFileTrailer(); DataPrintF "end%n"; lisp procedure CodeFileTrailer(); <<Foreach Fn in Reverse ForeignExternList!* do <<CodePrintF(" extern.p %w%n",Fn); CodePrintF("A_%w ac %w%n",Fn,Fn)>>; CodePrintF " end%n">>; @end(ProgramExample) The general use of the headers given above is to declare the module name, tell the assembler that this is a data section@Foot[On the @Apollo all of the code and data were put in a data section since the operating system and assembler had a problem with mixed code and data due to expecting a pure code segment with all data references relative to the data base register.], and in the case of the main routine performing the proper operating system dependent linkage for program entry and exit. Note that CodePrintF and DataPrintF are used to direct output to either the @ei[code] segment or @ei[data] segment. This is to allow seperate segements for those machines that allow for pure code segments (on the @Apollo a pure code segment is directly maped into the address space rather than copied, which results in a large difference in start up speed). This could probably be extended to PureCode, PureData, and ImpureData. procedure WW(X); <<print LIST('WW,x); x+1>>; Now a plain resolve function. That does not argument processing best for register conversion: procedure MYREGFN(R,S); <<Print LIST('MYREG, R,S); List('REG,S+10)>>; PUT('MYREG,'ANYREGRESOLUTIONFUNCTION,'MYREGFN); procedure MYANYFN(R,S); <<Print LIST('MYANY, R,S); S:= ResolveOperand('(REG t3),S); List('Weird,S)>>; FLAG('(WEIRD),'TERMINALOPERAND); PUT('MYANY,'ANYREGRESOLUTIONFUNCTION,'MYANYFN); (!*MOVE (WW 1) (WW 2))); ARgs must be WCONSTEVALUABEL (!*MOVE (WW (WW 1)) (WW 2))); (!*MOVE (WW A) (WW 2))); % First WW shouldnt convert (!*MOVE (MYREG 1) (MYREG 2))); % OK (!*MOVE (MYREG (WW 1)) (WW (MYREG 2)))); % Fails since args not processed (!*MOVE (MYREG (MYREG 1)) (MYREG 2))); (!*MOVE (MYANY 1) (MYANY 2))); % OK (!*MOVE (MYANY (WW 1)) (MYANY (MYREG 2)))); % Args processed (!*MOVE (MYANY (MYANY 1)) (MYANY 2))); @section(Sample ANYREGs and CMACROs from various machines) The following choice pieces from the @VAX750, @DEC20 and @68000 illustrate a range of addressing modes, predicates and style. @subsection(VAX) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % ARGONE -> ARGTWO (Equal) % Don't do anything ((ZeroP AnyP) (@op{clrl} ARGTWO)) % 0 -> ARGTWO ((NegativeImmediateP AnyP) % -n -> ARGTWO (@op{mnegl} (immediate (minus ARGONE)) ARGTWO)) ((@op{movl} ARGONE ARGTWO))) % General case (DefCMacro !*WPlus2 % ARGONE+ARGTWO->ARGONE ((AnyP OneP) (@op{incl} ARGONE)) % add 1 ((AnyP MinusOneP) (@op{decl} ARGONE)) % Subtract 1 ((AnyP MinusP) (@op{subl2} (immediate (minus ARGTWO)) ARGONE)) ((@op{addl2} ARGTWO ARGONE))) The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AnyP@\Just returns T NegativeImmediateP@\Check that a negative, 32 bit constant. @end(Description) @end(verbatim) @subsection(DEC-20) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % Move ArgOne -> ArgTwo (Equal) ((ZeroP AnyP) (@op{setzm} ARGTWO)) ((MinusOneP AnyP) (@op{setom} ARGTWO)) ((RegisterP AnyP) (@op{movem} ARGONE ARGTWO)) ((NegativeImmediateP RegisterP) (@op{movni} ARGTWO (immediate (minus ARGONE)))) ((ImmediateP RegisterP) (@op{hrrzi} ARGTWO ARGONE)) ((AnyP RegisterP) (@op{move} ARGTWO ARGONE)) ((!*MOVE ARGONE (reg t1)) (@op{movem} (reg t1) ARGTWO))) (DefCMacro !*WPlus2 ((AnyP OneP) (@op{aos} ARGONE)) ((AnyP MinusOneP) (@op{sos} ARGONE)) ((AnyP RegisterP) (@op{addm} ARGTWO ARGONE)) ((RegisterP NegativeImmediateP) (@op{subi} ARGTWO (minus ARGONE))) ((RegisterP ImmediateP) (@op{addi} ARGTWO ARGONE)) ((RegisterP AnyP) (@op{add} ARGONE ARGTWO)) ((!*MOVE ARGTWO (reg t2)) (@op{addm} (reg t2) ARGONE))) The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AnyP@\Just returns T MinusOneP@\Check that argument is -1. ImmediateP@\Check that an address or 18 bit constant. Will change for extended addressing. NegativeImmediateP@\Check that a negative 18 bit constant. RegisterP@\Check that is (REG r), a register. @end(Description) @end(verbatim) @subsection(APOLLO) @begin(verbatim,leftmargin 0) (DefCMacro !*Move % (!*Move Source Destination) (Equal) % if source @Value(Eq) dest then do nothing ((ZeroP AregP)(@op{suba!.l} ARGTWO ARGTWO)) ((ZeroP AnyP) (@op{clr!.l} ARGTWO)) % if source @Value(Eq) 0 then dest := 0 ((InumP AregP) (@op{movea!.l} (Iconst ARGONE) ARGTWO)) ((AddressP AregP) (@op{lea} ARGONE ARGTWO)) ((InumP AnyP) (@op{move!.l} (Iconst ARGONE) ARGTWO)) ((AddressP AnyP) (lea ARGONE (reg a0)) (@op{move!.l} (reg a0) ARGTWO)) ((AnyP AregP) (@op{movea!.l} ARGONE ARGTWO)) ((@op{move!.l} ARGONE ARGTWO))) (DefCMacro !*WPlus2 % (!*WPlus2 dest source) ((AnyP QuickIconstP) (@op{addq!.l} (Iconst ARGTWO) ARGONE)) ((AnyP NegativeQuickIconstP) (@op{subq!.l} (Iconst (minus ARGTWO)) ARGONE)) ((AregP MinusP) (@op{suba!.l} (Iconst (Minus ARGTWO)) ARGONE)) ((AnyP MinusP) (@op{subi!.l} (Minus ARGTWO) ARGONE)) ((AregP InumP) (@op{adda!.l} (Iconst ARGTWO) ARGONE)) ((AnyP InumP) (@op{addi!.l} (Iconst ARGTWO) ARGONE)) ((AregP AddressP) (@op{lea} ARGTWO (reg a0)) (@op{adda!.l} (reg a0) ARGONE)) ((AnyP AddressP) (@op{lea} ARGTWO (reg a0)) (@op{add!.l} (reg a0) ARGONE)) ((AregP AnyP)(@op{adda!.l} ARGTWO ARGONE)) ((@op{add!.l} ARGTWO ARGONE))) % really need one a DREG The Predicates used: @begin(description,spread 0) Equal@\As an atom, rather than in (...), it check both arguments same. Zerop@\Check if argument is 0 AregP@\Check that is one of the A registers (which can not be used for arithmetic), and require modified mnemonics. DregP@\Check that is one of the D registers, used for most arithmetic. InumP@\Check that a small integer. AddressP@\Check that an address, not a constant, since we need to use different instruction for Address's, e.g@. @op{lea} vs @op{movi}. AnyP@\Just returns T. NegativeImmediateP@\Check that a negative, 32 bit constant. QuickIconstP@\Small integer in range 1 ..@. 8 for the xxxxQ instructions on 68000. NegativeQuickIconstP@\Small integer in range -8 ..@. -1 for the xxxxQ instructions on 68000. @end(Description) @end(verbatim) @begin(verbatim,leftmargin 0) For example, on the @VAX750: @begin(Group) (DefAnyreg CAR % First ITEM of pair AnyregCAR % Associated function ((@op{extzv} 0 27 SOURCE REGISTER) % Code to extract 27 bit % address, masking TAG (Deferred REGISTER))) % Finally indexed mode used @hinge (DefAnyreg CDR % Second item AnyregCDR ((@op{extzv} 0 27 SOURCE REGISTER) (Displacement REGISTER 4))) % Displace 4 bytes off Register % Both CAR and CDR use a single instruction, so do not use a % predicate to test SOURCE. @hinge (DefAnyreg QUOTE % Note a set of different choices AnyregQUOTE ((Null) (REG NIL)) ((EqTP) (FLUID T)) ((InumP) SOURCE) ((QUOTE SOURCE))) @hinge (DefCMACRO !*Move % !*MOVE Usually has the most cases (Equal) ((ZeroP AnyP) (@op{clrl} ARGTWO)) ((NegativeImmediateP AnyP) (@op{mnegl} (immediate (minus ARGONE)) ARGTWO)) ((@op{movl} ARGONE ARGTWO))) @hinge (DefCMACRO !*Alloc ((ZeroP)) % No BODY - nothing to allocate ((@op{subl2} ARGONE (REG st)))) @end(group) @end(verbatim) |
Added psl-1983/doc/fasl-file-specs.mss version [3f5afa6031].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Current FASL file format: Word: Magic number (currently 99). Word: Number of local IDs. Block: Local ID names, in order, in regular Lisp format (string size followed by block of chars). Word: Size of code segment in words. Word: Offset in addressing units of initialization procedure. Block: Code segment. Word: Size of bit table in words (redundant, could be eliminated). Block: Bit table. Bit table format: Block of 2 bit items, one for each \addressing unit/ in the code block. 0: Don't relocate at this offset. 1: Relocate the word at this offset in the code segment. 2: Relocate the (halfword on VAX, right half on 20) at this offset. 3: Relocate the info field of the Lisp item at this offset. The data referred to by relocation entries in the bit table are split into tag and info fields. The tag field specifies the type of relocation to be done: 0: Add the code base to the info part. 1: Replace the local ID number in the info part by its global ID number. 2: Replace the local ID number in the info part by the location of its value cell. 3: Replace the local ID number in the info part by the location of its function cell. Local ID numbers begin at 2048, to allow for statically allocated ID numbers (those which will be the same at compile time and load time). |
Added psl-1983/doc/fasl.mss version [d156bc18b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(article) @section(How in the hell does faslout work???) This section is a guide to the internal workings of faslout and then faslin. The user begins the faslout procedure by calling the procedure faslout with a string that does not have the extension (because it will add the appropriate binary extension for you). However, when fasling in, the file name requires the binary extension [Change this inconsistency]. Inside the procedure faslout, the file name is assigned to the fluid variable ModuleName!*. Depending upon the setting of the flag !*Quiet_Faslout, the system will either print out a greeting message or not. Next, an output binary file is opened using the argument file name. It will return the channel number to a fluid variable CodeOut!*. CodeFileHeader is called to put in a header in the output file. CodeFileHeader writes out a word consisting of the Fasl Magic Number (currently set to 99). This magic word is used to check consistency between old and current fasl format files (an error is given upon fasling in the file if there is not a 99 as the first word). Therefore, the system must consistently modify that number when a new fasl format is produced. To continue, we need to understand the allocation that takes place within the Binary Program Space (BPS). The BPS is a large, non-collected space that contains compiled code, warrays, the string assocaited with interned ID's, constant data in fasl files, etc. Space is allocated from both ends of the space. Compiled code is allocated from the bottom (using NextBPS as a pointer) and warrays are allocated from the top (using LastBPS as the pointer). When an allocation is attempted, the desired size is checked to see if it will cause LastBPS and NextBPS to cross; if it will, an error message will be printed. The next step is to allocate 2/3 or the remaining BPS from the top. @begin(verbatim) .------------------------------------. | | | WArrays | | | | | Last_BPS>|------------------------------------| <-FaslBlockEnd!* ---. | Code | | | | | | | | | | 2/3 |====================================| <-CodeBase!* | | Bit Table | | |====================================| <-BitTableBase!* ---' | | | | Next_BPS>|------------------------------------| | | | | | | `------------------------------------' Binary Program Space @end(verbatim) The procedure AllocateFaslSpaces will setup the following fluid variables. FaslBlockEnd!* will be the address to the top of the available space for this particular allocation. BitTableBase!* points to the beginning of the BitTable. CurrentOffset!* keeps a pointer into the codespace of this allocation to the next available point to add more code. BitTableOffset!* is a running pointer to the current location in the BitTable where the next entry will go. CodeBase!* is the base pointer to the beginning of the code segment for this allocation. MaxFaslOffset!* is the max size of the codespace allowed for this implementation. OrderedIDList!* keeps record of the ID's as they are added. NextIDNumber!* is a base number used just in fasl files to indicate which IDs are local and which are global. It is assumed that there will never be more than 2048 pre-allocated ID's, currently there are 129. The first 128 preallocated IDs are ASCII codes(0-127) and the last one is NIL(128). Everything is now setup to begin fasling PSL code out to the file. The remainder of the faslout procedure sets up three more fluid variables. !*DEFN is set to T which indicates that you are not going to do normal evaluation from the top loop and from files such as using the functions IN and DSKIN. DFPRINT!* signals that DFPRINT!* is now used as the printing function. The procedure used will be DFPRINTFasl!*. !*WritingFaslFile is set to T to let the system know that fasling out is goping on as opposed to compiling code directly into memory inside the PSL system. @section(What happens to code being fasled out to a file) |
Added psl-1983/doc/glossary.txt version [1a9708fb9d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 10-Dec-82 20:56:02-MST,2372;000000000011 Mail-from: ARPANET site RAND-RELAY rcvd at 10-Dec-82 2054-MST Date: 10 Dec 1982 0733-PST From: GRISS at HP-HULK Subject: Glossary To: jw-peterson at UTAH-20, Lowder at UTAH-20, utah-cs!lowder at HP-VENUS, GRISS@at@HP-labs, GRISS@RAND-RELAY@HP-labs Via: HP-Labs; 10 Dec 82 19:43-PDT Some Terminology: ----------------- ALM - Abstract LISP machine, ie, the CMACRO level, as emitted by compiler; the abstract architecture it repesents; LAP-like code that is essentially portable. TLM - Target LISP machine; opcodes and registers in terms of target machine; LAP form that directly machine specific for resident LAP on target PSL; sometime assembly-code on target machine during bootstrap. CROSS-COMPILER - Built on HOST RLISP, includes tables etc. to compile PSL source files (.SL and .RED) into TLM assembly code for target machine. Only needed when bootstrapping the PSL kernel (BARE-PSL) and the boot step for the resident compiler on the target (build of BIG-PSL) BARE-PSL - The executable PSL on the target machine that most people expect to run. On all machines to date includes a complete interpreter, and FASLIN, so that oher modules can be "loaded". This is the basic system that a stable environment keeps around. In a stable environment, RLISP.B, COMPILER.B etc can be loaded. Some stable environmenst may load commonly use modules, and core-save and announce this saved image as the standard PSL or RLISP, which does give some confusion. [It should NOT normally include RLISP, though I imagine RLISP may have been built in "for convenience"; which causes confusion] BIG-PSL (or FULL-PSL) - This is a step required in bootstrapping. After BARE=PSL seems to run well (and cant FASL yet, since no .B files should really exist), additional files (RLISP and COMP) are included in a cross compile; these augment the kernel to give a system capable of building .B files. [I repeat, this is not the desired way of maintaining a PSL with RLISP and COMPILER, but is a bootstrap step for COMPILER.B. The desired maintenance model is to keep a BARE-PSL around and LOAD RLISP, COMPILER, etc. and then core-save if space permits] ------- 11-Dec-82 20:56:20-MST,3002;000000000011 Mail-from: ARPANET site RAND-RELAY rcvd at 11-Dec-82 2055-MST Date: 11 Dec 1982 0757-PST From: GRISS.HP-HULK at Rand-Relay Subject: New Gloaasry To: jw-peterson at Utah-20 Via: HP-Labs; 11 Dec 82 19:37-PDT @section(GLOSSARY - Some Common Terminology) The following terms are defined and used in the body of the IMPLEMENTATION Guide (and the Maintenance Guide? as well). We collect a concise definition here: @begin(description) ALM@\Abstract LISP machine, ie, the CMACRO level, as emitted by compiler; the abstract architecture it repesents; LAP-like code that is essentially portable. TLM@\Target LISP machine; opcodes and registers in terms of target machine; LAP-like form that is machine specific for resident LAP on target PSL; some times used to refer to assembly-code on target machine during bootstrap. CROSS-COMPILER@\Built on HOST RLISP, includes tables etc. to compile PSL source files (.SL and .RED) into TLM assembly code for target machine. Only needed when bootstrapping the PSL kernel (BARE-PSL) and the boot step for the resident compiler on the target (build of BIG-PSL) Executable BARE-PSL@\The executable PSL kernel on the target machine produced by the first stage kernel bootstrap. On all machines to date includes a complete interpreter, and FASLIN, so that oher modules can be "loaded" and often a core-save. This is the basic system that a stable environment keeps around as well as a "executable PSL". In a stable environment, RLISP.B, COMPILER.B etc can be loaded. This should NOT normally include RLISP, though I imagine RLISP may have been built in "for convenience"; which causes confusion. Executable PSL@\Some stable environments may load commonly used modules into "executable BARE-PSL", and core-save and announce this saved image as the standard PSL. (Some people confuse this with "bare-PSL"). Executable RLISP@\In most stable environments, RLISP.B and COMPILER.B are loaded into executable PSL and core-saved. Executable BIG-PSL@\This is a target executable system required in bootstrapping. After BARE-PSL seems to run well (but of course can not FASL yet, since no .B files should really exist), additional modules (RLISP and COMP) are included in a cross compile; these augment the kernel to give a system capable of building .B files. This is used to build RLISP.B, COMPILER.B, FASLOUT.B, LAP.B etc., which can then be used with the executable BARE-PSL. This is not kept around to maintaining a stable PSL with RLISP and COMPILER, but is only a bootstrap step to build COMPILER.B. BIG-PSL is built when going to a new version. The stable maintenance model is to keep a BARE-PSL around and LOAD RLISP, COMPILER, etc. and then core-save if space permits. @end(description) ---- My suggestion is to APE HP very closely . It is PORT from 20 to 68000, and works. The HP system now runs well, maybe even better than Apollo. We must be doing something right... ------- |
Added psl-1983/doc/implementation-guide.mss version [76c94d09b0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 | @make(article) @Case(Draft, 1 <@device(Omnitech)>, else <@device(LPT)> ) @Comment{ For use with the final versions } @Style(WidowAction=warn) @Style(Hyphenation Off) @comment(on) @Style(DoubleSided no) @comment(yes) @style(Spacing 1) @comment[See G:MSS-junk.MSS] @use(Bibliography "<griss.docs>mtlisp.bib") @comment{ Font related stuff } @Define(OP,FaceCode Y,TabExport)@comment{ used for indicating opcodes in C-macros } @modify(enumerate,numbered=<@a. @,@i. >, spread 1) @modify(itemize,spread 1) @modify(description,leftmargin +2.0 inch,indent -2.0 inch) @LibraryFile(PSLMacrosNames) @LibraryFile(SpecialCharacters) @comment{ The logos and other fancy macros } @PageHeading(Left "Utah Symbolic Computation Group", Right "May 1982", Line "Operating Note No. xx" ) @set(page=1) @newpage() @Begin(TitlePage) @begin(TitleBox) @MajorHeading(@PSL Implementation Guide) @Heading(M. L. Griss, E. Benson, R. Kessler, S. Lowder, G. Q. Maguire, Jr. and J. W. Peterson) Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 Last Update: @value(date) @end(TitleBox) @begin(abstract) This note describes the steps involved in bringing PSL up on a new machine. It combines information from the previous BOOTSTRAP, LAP, CMACRO and TEST guides. @end(abstract) @center[ File: @Value(SourceFile) Printed: @value(date)] @copyrightnotice(Griss, Benson, Lowder, Maguire and Peterson) @begin(ResearchCredit) Work supported in part by the National Science Foundation under Grant No. MCS80-07034, and by Livermore Lawrence Laboratories under Subcontract No. 7752601, IBM and HP. @end(ResearchCredit) @end(TitlePage) @pageheading(Left "Implementation Guide", Center "@value(date)", Right "Page @Value(Page)" ) @comment{@pageheading(Even,Left "Page @Value(Page)", Right "Operating Note No. xx" )} @set(page=1) @newpage() @section(Introduction) This document describes the techniques used to implement PSL on a new machine. This note assumes that the reader has some familiarity with the basic strategy of @PSL implementation (see the 1982 LISP Conference Paper on PSL, UCP-83), and has also read the papers on the @PSL Portable @xlisp compiler (Griss and Hearn, "Software Practice and Experience", and Griss, Hearn and Benson, 1982 Compiler Conference). Also see the compiler chapter (19) of the @PSL manual@cite[Griss81]. Finally, a basic understanding of how to use PSL and LISP is required@cite[Griss81]. In order to explain a new PSL implementation, we will first describe the PSL compilation model, hopefully providing some insight into the various steps involved in the transformation of PSL sources into code executable on the target machine. @comment{May want to add a description of each section to follow} The initial level of transformation takes the RLISP format and translates it into LISP for those source files that are written in RLISP format; those files already in LISP may be directly input into the system (see the figure below). The LISP code is then compiled into instructions for an Abstract Lisp Machine (ALM). The ALM is a general-purpose register machine designed for its ease as a target for compilation@cite(Griss81b) in which temporary variables are allocated in a block of locations on a @ei[stack]. The ALM instructions are expressed in LAP format (LISP Assembly Program) which consists of a list whose first element is the ALM opecode followed by zero or more ALM operands which are ALM addressing modes. The ALM format is (ALMopcode ALMoperand ... ALMoperand). The ALMopcode is a macro referred to as a CMACRO and the addressing modes of the ALMoperands are referred to as ANYRegs. The ALM instructions are macro expanded into instructions for the Target Lisp Machine (TLM). TLM instructions have the same LAP format, except the operators are now TLM operators and the operands are TLM addressing modes. From here, a number of alternate routes are possible for the final code generation. So far the LISP or RLISP has transformed into into a set of TLM instructions that can take one of three paths. @begin(enumerate) Fist, the TLM instructions can be printed out as Target Machine Assembly code (ASM) for assembly on the target machine. This route is followed in the initial phases of the PSL implementation process to produce code for the target machine. Secondly, a file of the target machine code can be produced in a format that can be loaded directly into a running PSL system. This process is called FASLing, producing a FASt Load format file. Finally, the TLM code can be assembled and deposited directly into memopry of the running PSL system. This is basically analogous to the process used to load in a FASL file produced above except the code is not written to or read from a FASL file. @end(enumerate) This process is illustrated below: @begin(verbatim,leftmargin 0,group) .-----------------. Rlisp: Procedure SelectOne x; | RLISP input code| x := car x; `-----------------' v .------. | LISP | Lisp: (de selectone (x) `------' (setq x (car x))) v .----------. | Compiler | `----------' v .------------------------. ALM: (!*entry selectone expr 1) |ALM instructions in LAP | (!*alloc 0) | format | (!*move (car (reg 1)) `------------------------' (reg 1)) v (!*exit 0) .----------. | Pass1Lap | `----------' | v .---------------------. TLM: [68000 code] | TLM instructions in | (Fullword 1) Count of Args | LAP format. | (!*Entry selectone expr 1) `---------------------' (movea!.l (indirect | | (reg 1)) (reg 1)) | v (rts) | .------------. | | TLM to ASM | | | converter | | `------------' | v | .-------------------. ASM: dc.l 1 | | | movea.l (a1),a1 | | Asm code suitable | rts | | for TM assembler | | `-------------------' v .--------------. .-----------------. | LAP resident |----->| Resident binary | | assembler | | `-----------------' +--------------+ | .------------. `-->| FASL files | `------------' @end(verbatim) In summary, here is an overview of the steps necessary to implement PSLon your target machine. More details will be given in the following sections. @begin(enumerate) Prelimaries: @begin(enumerate) Believe in yourself. Choose the host machine. Test file transfer. @end(enumerate) Decide how to map the ALM architecture to the TLM. Implement the TLM to ASM. Implement the ALM to TLM. Build the Cross Compiler and test. Run Cmacro Tests. Build Bare PSL. Implement a resident TLM assembler. Implement FASL. Bootstrap the compiler. @end(enumerate) @section(Overview of the Abstract LISP Machine) The abstract machine is really a class of related machines rather than a single fixed machine (such as PASCAL P-code, or some true @xlisp machines). The exact set of @CMACRO@XS, the number of registers, etc@. are under the control of parameters, flags and compiler code-generator patterns defined for the specific machine. This flexibility permits the match between the compilation model and the target machine to be better set, producing better code. Therefore, the exact set and meaning of @CMACRO@XS are not fixed by this definition; rather, they form an adjustable @dq[convention] between the compilation and @CMACRO/Assembly phase. The compiler itself is defined in PC:COMPILER.RED@Foot[dir: represents a logical directory name, in this PC: stands for <PSL.Comp> under Tops-20 or /psl/comp under UNIX.] and is augmented by machine-specific files, described later. The ABSTRACT LISP MACHINE (ALM) used by our compiler has the following characteristics. @begin(enumerate) There are 15 general purpose registers, 1 ..@. 15; and a stack for call/return addresses. Locals and temporaries variables are allocated on the stack by allocating a frame of temporaries large enough to hold them all, not by the use of push and pop instructions. The function calling mechanism loads N args into 1 ..@. N, and then transfers to the function entry point, pushing the return address onto the stack if necessary. The functions result is returned in register 1. Each procedure is responsible to save any values it needs on stack; small procedures often do not use the stack at all. The following is a brief lisp of all the ALM opcodes (CMACROS). @begin(verbatim) (!*ALLOC nframe:integer) (!*ASHIFT dest:any-alterable source:any) (!*CALL name:id) (!*DEALLOC nframe:integer) (!*EXIT nframe:integer) (!*FIELD operand:any-alterable starting-bit:integer bit-length:integer) (!*FOREIGNLINK name:id type:id number-of-arguments:integer) (!*FREERSTR l:nonlocalvars-list) (!*JCALL name:id) (!*JUMP label:any) (!*JUMPEQ label:any source1:any source2:any) (!*JUMPINTYPE label:any source1:any type-name:id) (!*JUMPNOTEQ label:any source1:any source2:any) (!*JUMPNOTINTYPE label:any source1:any type-name:id) (!*JUMPNOTTYPE label:any source1:any type-name:id) (!*JUMPON source:any lower-bound:integer upper-bound:integer l:label-list) (!*JUMPTYPE label:any source1:any type-name:id) (!*JUMPWGEQ label:any source1:any source2:any) (!*JUMPWGREATERP label:any source1:any source2:any) (!*JUMPWITHIN label:any lower-bound:integer upper-bound:integer) (!*JUMPWLEQ label:any source1:any source2:any) (!*JUMPWLESSP label:any source1:any source2:any) (!*LAMBIND r:registers-list l:nonlocalvars-list) (!*LBL label:tagged-label) (!*LINK name:id type:id number-of-arguments:integer) (!*LINKE nframe:integer name:id type:id number-of-arguments:integer) (!*LOC dest:any-alterable source:any) (!*MKITEM inf:any-alterable tag:any) (!*MOVE source:any dest:any-alterable) (!*POP dest:any-alterable) (!*PROGBIND l:nonlocalvars-list) (!*PUSH source:any) (!*PUTFIELD source:any dest:any-alterable starting-bit:integer bit-length:integer) (!*SIGNEDFIELD operand:any-alterable starting-bit:integer bit-length:integer) (!*WAND dest:any-alterable source:any) (!*WDIFFERENCE dest:any-alterable source:any) (!*WMINUS dest:any-alterable source:any) (!*WNOT dest:any-alterable source:any) (!*WOR dest:any-alterable source:any) (!*WPLUS2 dest:any-alterable source:any) (!*WSHIFT dest:any-alterable source:any) (!*WTIMES2 dest:any-alterable source:any) (!*WXOR dest:any-alterable source:any) (LABELGEN tag:id) (LABELREF tag:id) (!*CERROR message:any) (FULLWORD [exp:wconst-expression]) (HALFWORD [exp:wconst-expression]) (BYTE [exp:wconst-expression]) (STRING s:string) (FLOAT f:float) @end(verbatim) ALM operand forms ("addressing" modes) @begin(verbatim) (FLUID name:id) (!$FLUID name:id) (GLOBAL name:id) (!$GLOBAL name:id) (WVAR name:id) (WARRAY name:id) (WSTRING name:id) (WCONST expr:wconst-expression) (IMMEDIATE wconst-expression:any) (QUOTE s-exp:s-expression) (LABEL l:id) (MEMORY base:any offset:wconst-expression) (CAR base:any) (CDR base:any) (FRAME n:integer) (REG reg-descriptor:{integer,id}) (LIT [any-instruction-or-label:{list,id}]) (LABELGEN tag:id) (LABELREF tag:id) (IDLOC symbol:id) @end(verbatim) @end(enumerate) @Section(System Overview for Bootstrapping) Currently PSL is half bootstrapped from a complete PSL system on a host machine. At the moment only the Decsystem 20 and the VAX 750 can be used as hosts; shortly we expect the Apollo and HP9836 to be also usuable. If you have a choice for your host machine, one important consideration will be the ease in shipping code between the host and target. It is worth taking the time initially to be sure this pathway is as smooth and troublefree as possible. The need for easy file transfers is derived from the half bootstrap method and the iterative nature of developing and debugging the tables used in the ALM to TLM transformation. The size of the transferred files will be in the range of 1 to 70 KBytes. Having a fast network or a tape transfer from host to target is worth considering in the beginning of a PSL implementation. The first major step in the implementation will be to modify the host PSL to become a cross compiler, turning lisp or rlisp into the target machines assembly language. @SubSection(Overview of the Cross Compiler) Three modules are created, compiled and loaded into a host PSL to transform it into a cross compiler. @begin(enumerate) The first module will be xxx-comp.red (we will use XXX to represent the name of the target machine, like DEC20, VAX, etc.); a file containing patterns used by the compiler to control which ALM instructions are emitted for certain instructions. Basically it is used in LISP to ALM transformations and initially will only require you to copy the same file used on your host machine. The second module will be xxx-cmac.sl. This file contains the tables(CMacroPatternTables) used to convert ALM opcodes to TLM opcodes, the tables used to convert ALM addressingmodes into TLM addressingmodes (ANYREGS), and some miscellaneous required opencoded functions. The last module, xxx-asm, consists of two files, xxx-asm.red and xxx-data-machine.red. The first file, xxx-asm.red, specifies the necessary formats, costants, and procedures for converting TLM instructions into the host's actual assembly language. The file, xxx-data-machine.red, provides constants for describing to the compiler some of the specific choices for what registers to use and how the lisp item will be used in the machine words. @end(enumerate) All of these modules are compiled and loaded into a host PSL to turn it into the cross compiler. The next few sections will try to describe to the reader how these three modules are actually designed and built from the bottom up. It will be worth getting a listing of these modules for your host machine and also for a machine most similar to your target machine, if available. @Section(Designing the TLM instruction format). The implementor must decide first the specifics of the TLM instruction format patterned around the form (TLMopcode TLMoperand ... TLMoperand). The TLM to ASM translation occurs in a parallel manner. (TLMopcode TLMoperand TLMoperand) TLM format. | | | ASMopcode ASMoperand ASMoperand Some ASM format. The closer the ASM format approaches the TLM format the better. However in some cases this will not be possible and the reader must devise a scheme. Take a look at the case studies for some ideas of ways to handle some of these issues. TLM opcodes are usually passed through unchanged to the ASM code. However the TLM operands will require extensive changes. [Mention terminal operands!!!]. The TLM operands are of the form (addressingmode value-expression). The addressingmode is a tag which will direct what procedures will be used to convert and print the ASM operands. The reader should pick these addressingmode names to closely match the addressingmodes of the target machine. Some examples of these would be (immediate ...), (indirect ...), (displacement ...), or (indexed ...). Here again the case studies will give you some information for proceeding. [Mention CRAY mismatch of TLM]. @Section(Implementing the TLM to ASM conversion) You can begin by creating the xxx-data-machine.red file and begin to add some definitions. First pick a name for your system, anything representative will do like the name of its operating system or its manufacturers identifier. Some examples are dec20, vax, apollo, or m68000. @begin[verbatim] fluid '(system_list!*); system_list!* := '(MC68000 Chipmunk HP9836); @end[verbatim] The next step is quite important. You must decide how you are going to implement the LISP item on the target machine. The LISP item consists of 2 or three fields; each field having a position and size in the machines item picked by the implementor. All LISP items must have a tag field and an INFormation field and some implementations have a garbage collector field. The tag field must be at least 5 bits long@Foot[Nineteen (19) different tags are presently used.] and the inf field should be large enough to hold a target machine address. Some implementations, such as the Vax, will choose an inf smaller than the largest address possible on the machine and will have to mask tag bits out when using the inf field as an address. This does cause problems and should be avoided if possible. If space allows it the INF field may be larger to allow larger numeric operands to be stored in registers. Currently PSL provides two different garbage collection methods, one of which should be chosen (or a new one developed if needed). One is a two-space copying collector, which requires no extra garbage collection bits, but is very wasteful of space and is best for a virtual memory machine (in fact, there are two copies of the heap). The other is a one space compacting collector, and requires at least one bit for marking, and ideally additional bits for relocation (sometimes, these extra bits can be stored in a separate bit table). Naturally these fields may be larger to make their accessing easier, like aligning on a byte boundary. Once you have decided upon how the LISP item will be implemented on the machine you can begin filling in the constant definitions for the xxx-data-machine.red file. When numbering bits in a machine word, we have settled upon the convention that the most significant bit is zero and counts up to the max-1 bit. The current constants are @begin(verbatim) TagStartingBit TagBitLength InfStartingBit InfBitLength AddressingUnitsPerItem CharactersPerWord BitsPerWord AddressingUnitsPerFunctionCell StackDirection and optionally GCStartingBit GCBitLength @end(verbatim) The following figure illustrates the positions of these constants: @begin(verbatim) .-----------------------------------------. | TAG | [gc] | INF | `-----------------------------------------' FILL IN LATER @end(verbatim) Some other decisions that must be made include: @begin(enumerate) Which and how many registers to dedicate as the compiler-allocated @ei[Registers]; How large an integer will be supported in the @xlisp item; How many tags are to be supported How to implement the recursion stack and check for stack overflow (either using an explicit test, or some machine-interrupt); How to pack and unpack strings; @Comment{PSL must have explicitly tagged items, and the current allocator is a simple linear model, so this is not relevant. Whether to have a heterogeneous heap, multiple heaps, a @ei[page] per type, or whatever;} @Comment{This is also not relevant. Pairs are the same on all machines. How pairs are referenced, i.e. does the pointer to a pair point to the first element, to the second element, are the pairs allocated separately in parallel areas, or is there some type of CDR coding being done.} @end(enumerate) The next step is to implement the tables that accept the ALM form and emits assembly code for the target machine. Most of the program is machine-independent (using PC:LAP-TO-ASM.RED), and an @dq[xxxx-ASM.RED] file is to be written. We have the following already written as a guide: @DEC20 @dq[MACRO], @VAX750 @UNIX @dq[as], @68000 for @apollo and WICAT, and CRAY CTSS CIVIC. The main problem is to emit the correct format, such as: placement of tabs, commas, spaces, parentheses; renaming symbols (certain legal @xlisp IDs are not legal in some assemblers); and determining how and where to place EXTERNAL, ENTRY and GLOBAL declarations, how to declare and reserve blocks of storage, and how to overcome certain problems involved with large files and restrictions on addressing modes and relocation. Finally, the ALM to ASM needs to be tested. This is usually accomplished by Hand-coding some small test routines, and then convert from ALM to machine X assembly code, assemble, and run. This checks the final details of required Prologues and Epilogues@Foot[Prologues and Epilogues contain operating system-specific standard module headers and trailers.], understanding of the instruction set, and so on. Suggested LAP tests are described @ei[generically], but will have to be translated by the implementor into machine-dependent LAP for machine X, and depending on the flavor of assembler and LAP, other tests will have to be devised by the implementor. This is a good time to investigate how Assembly coded routine can call (and be called) by the most common language used on machine X (such as FORTRAN, PASCAL, C, etc.). This "Foreign" language can be used for initial operating system support. @section(Implementing the ALM instructions) The ALM instructions consists of a set of operations and their addressing mode operands. These ALM instructions are commonly referred to as CMACRO's and the addressing modes are ANYREG's. The purpose of this part of the PSL implementation is to implement the functionality of each ALM instruction in terms of other ALM instructions and TLM instructions. The ability to recursively define the ALM instructions in terms of other ALM instructions is a benefit because it greatly decreases the amount of code required to implement a particular instruction. For example, a good technique in designing the ALM instructions is to carefully implement the !*MOVE instruction (to distinguish ALM instructions, they generally have a !* in the front of their name) to efficiently handle transfer between any possible locations (memory to register, stack frame to memory, etc.). Then when implementing another instruction, the code for moving the actual operands to locations necessary for the TLM instruction can be accomplished using a recursive call to the !*MOVE ALM instruction. The important tasks of the implementor are to @begin(enumerate) Carefully examine the instruction set and architecture of the TLM to see which instruction (instructions) correspond to each ALM CMACRO; Decide how to map the ALM registers and addressing modes onto the TLM registers and addressing modes (some will map one-to-one, others will take some thought, and a sequence of actions); Decide on a set of classifications of the TLM modes that distinguish which of a related set of TLM opcodes should be used to implement a particular ALM opcode, and write predicates that examine ALM and TLM modes to decide which class they are in; Write tables to map ALM modes into TLM modes, using these predicates, and then ALM opcodes into a (sequence of) TLM opcodes with the correct TLM modes. @end(enumerate) @subsection(Mechanics of ALM Instruction Definition) Before we get into the description of the ALM instructions, we must first define the table-driven pattern matching approach used to implement them. This approach allows definition of an ALM instruction in terms of a pattern predicate which is used to match the operands of the ALM instruction and a body that may consist of a mixture of ALM instructions (for recursive decomposition) and TLM instructions (for direct code generation). This is exactly analogous to the COND construct in LISP. Just like COND, any number of predicate/body pairs may be included in the expansion of an ALM instruction. Also, the order of the pairs is quite important (since they are compared in order from first to last). Typically, the most specific predicates are described first followed by gradually more and more general ones. The table definition for a specific ALM instruction is compiled into a single procedure. The instruction name must then be flagged with 'MC to indicate that it is a legal ALM instruction. The pattern table itself must then be stored under the indicator 'CMACROPATTERNTABLE on the ALM instruction property list. To simplify this process, the DefCmacro Macro has been defined: @begin(verbatim) (DefCMacro ALMInstructionName (pred1 body1) (pred2 body2) ... lastbody) @end(verbatim) Each ALM instruction is defined with a set number of arguments and the predicates are used to compare the types and/or values of the arguments. A predicate need not test all arguments, with non-tested arguments defaulting to T for a value. For example, one could define the following patterns: @begin(verbatim) Predicate Body (DefCMacro ALMInst ((FOOP) (Body1)) ((FEEP BARP) (Body2)) ((ANYP) (Body3)) (Body4)) @end(verbatim) Note that this looks almost exactly like the LISP operation COND. The one difference lies with the Body4 in the above example, which has no predicate and will always be evaluated if all others fail (Similar to the final 'T case in a Cond without the T). This last predicate/body pair may NOT have a predicate. If it doesn't, it will be evaluted just like the body. [!!Future change - CERROR on the default case, and make the defined use ANYP for his default case] The predicate functions are automatically passed one argument which is the ALM operand in the position of the test. So, in the above example, FOOP is passed the first operand and BARP is passed the second, after failure in the FOOP test. The body can be thought of as an implicit PROGN that contains a set of ALM and TLM instructions. These instructions then reference the various operands as ARGONE, ARGTWO, ARGTHREE, etc. using lexical ordering in the instruction. For example, if an ALM instruction mapped directly to a TLM one, it may be defined as: @begin(verbatim) ((FOOP BARP) (TLMOperator ARGONE ARGTWO)) @end(verbatim) Or, it may map into a number of ALM and TLM instructions: @begin(verbatim) ((FEEP) (ALMOperator ARGONE Something) (TLMOperator Something ARGTWO) (ALMOperator Something ARGONE)) @end(verbatim) Notice that even though the predicates only test the first operand ARGONE, the other operands may be referenced in the body. Also, "Something" can be thought of as a kind of constant operand (like a particular register, an integer constant, a memory location or whatever). In order to facilitate more complicated instructions within the body, we must now introduce a number of other features. First, suppose that you wish to include code generation time constants within the body. This can be accomplished by placing on the property of a variable name, 'WCONST with its value being the desired constant. Then when the variable is encountered in the instruction expansion, it will be replaced by the value on its property list under the 'WCONST indicator. A useful function to perform this operation would be: @begin(verbatim) (DE MakeReferencedConst (ConstName ConstValue) (Put ConstName 'WCONST ConstValue)) @end(verbatim) Therefore, if you perform a (MakeReferencedConst 'TAGPOSITION 10) then the body may reference TAGPOSITION directly: @begin(verbatim) ((FOOP) (ALMOperator ARGONE TAGPOSITION)) @end(verbatim) Now, that we have constants, it is sometimes desirable to have constant expressions. As long as all of the operands are either direct or referenced constants, the expression can be evaluated in an ALM or TLM instruction (the function may also be called if it doesn't have any operands). For example, the following could be imbedded within an instruction body: @begin(verbatim) (Plus2 (Foo 35 TagPosition) WordWidth) @end(verbatim) The system also provides for an alias mechanism, so you can map one name into another. This is accomplished by placing on the property of the alias, the name of the acutal function under the property DOFN. Thus, if you wanted to map FEE into PLUS2, you would simply: (Put 'FEE 'DOFN 'PLUS2). Therefore, another useful function would be: @begin(verbatim) (DE Alias (AliasFunction ActualFunction) (Put AliasFunction 'DOFN ActualFunction)) @end(verbatim) Sometimes in the process of generating the TLM instructions, it is necessary to make use of a temporary label (i.e. to generate a forward branch). This can be accomplished by referencing TEMPLABEL (just like a reference to ARGONE), which will create a label name consistent with a particular body. For example: @begin(verbatim) ((FOOP) (Test ARGONE) (GO (Label TEMPLABEL)) (Operate ARGONE ARGTWO) (Label TEMPLABEL)) @end(verbatim) Notice that even if the label references are separated by recursive ALM instructions, it will still create a unique reference to the label in both places. There is another mechanism to accomplish the same task in a more general fashion, that allows referencing of multiple labels. This mechanism is used with two functions: @begin(description) LabelGen@\This function takes one argument and returns a generated label. The argument and label are stored on an A-List for later reference. The argument may be any atom. LabelRef@\Look up the argument on the label's A-List and return the associated label. @end(description) An example of the use of these two functions is: @begin(verbatim) ((FOOP) (Label (LabelGen 'L1)) (Test ARGONE) (Go (LabelGen 'L2)) (Operator ARGTWO)) (Go (LabelRef 'L1)) (Label (LabelRef 'L2))) @end(verbatim) Finally, if the need arises to be able to call a function within an ALM instruction expansion. This can be accomplished by using the ANYREG mechanism. It is important to know that this technique will not work for a function call within a TLM instruction, only in the recursive expansion of an ALM instruction (there is no method for calling a function within a TLM instruction). (Note: ANYREG's will be explained in detail later, but the mechanism can be used to call a function). The technique is to first define the function that you wish to call, with one extra argument (the first one) that will be ignored. Then define an anyreg function that calls your function. For example, suppose you want a function that returns an associated register based upon a register argument (with the association stored in an A-List). The code would be implemented as follows: @begin(verbatim) (De GetOtherRegFunction (DummyArgument RegName) (Assoc RegName '((A1 S3) (A2 S2) (A3 S1)))) (DefAnyReg GetOtherReg GetOtherRegFunction) @end(verbatim) Then the pattern that may use the function would be: @begin(verbatim) ((FOOP) (ALMOperator (GetOtherReg ARGONE) (GetOtherReg ARGTWO))) @end(Verbatim) [Future Change - Implement a technique so if it is necessary for a random function to be called, all one has to do is define it and flag it as something appropriate - like 'ALMRandomFunction] @subsection(@ANYREG and @CMACRO patterns) Certain of the ALM operands are @ei[tagged] with a very special class of functions thought of as extended addressing modes; these @ANYREG@xs are essentially Pseudo instructions, indicating computations often done by the addressing hardware (such as field extract, indexing, multiple indexing, offset from certain locations, etc.). For example, the @xlisp operations CAR and CDR often are compiled in one instruction, accessing a field of a word or item. Using @ANYREG in this case, CAR and CDR are done as part of some other operations. In most cases, the @ANYREG feature is reserved for operations/addressing modes usable with most instructions. In some cases, the @ANYREG is too complicated to be done in one instruction, so its expansion emits some code to @ei[simplify] the requested addressing operation and returns a simpler addressing mode. The main thing is all desired computations are done using 1 or zero registers, hence the name @dq[@ANYREG]. The @ANYREG@xs have an associated function and possible table, with the name of the function under the property 'ANYREGRESOLUTIONFUNCTION and the pattern under 'ANYREGPATTERNTABLE. Just like the DefCMacro macro has been defined to aid ALM instruction description, the macro DefAnyReg has been provided to help set up these associations: @begin(verbatim) (DEFANYREG anyregname anyregfunction (pred1 body1) (pred2 body2) ... lastbody) @end(verbatim) As you can see, the structure of a DefAnyReg is exactly the same as DefCMacro, except an additional operand AnyRegFunction must be supplied. When an AnyReg is found in the instruction expansion, the function is called with two or more arguments: @begin(enumerate) Temp Register - Since the anyreg must perform its operation using zero or one register, this is the register that it may use to perform its task. (CAVEAT: The current implementation provides either (Reg T1) or (Reg T2) as the temporary register in all cases except one. That is when the anyreg is the source of a move and the destination is a register. In that case, the destination register is passed as the temporary. This can cause a problem if any part of the anyreg requires the destination to first be a source. [Future change - Eliminate this problem used in move and always pass in T1 or T2]). Source - This is the actual body of the anyreg. It may be referenced within the AnyRegPatternTable as SOURCE. ArgTwo - Only one anyreg (Memory) currently has more than two arguments. If they are desired, this third argument may be referenced by ARTTWO. @end(enumerate) A defect in the current system is that the pattern predicates following the anyreg function may not test the Temporary Register. This is quite inconsistent, since the function definition must consider the operand, while the pattern table must ignore it. [Future change - Fix This problem] @subsection(ALM Instruction Expansion) Now that we understand the mechanics of defining ALM instructions and anyreg tables we need to explore the order of expansion of the instructions. The compiler emits ALM instructions, with the operands being legal ALM "addressing" modes. These instructions are collected in a list and passed to the Pass1Lap function. Pass1Lap looks at each instruction and attempts to simplify it. It looks on the property of the opcode and checks to see if it has been flagged with 'MC. If so, it calls the function of the same name with the operands unchanged. Most ALM expansion functions first apply the function @begin(verbatim) ResolveOperand(Reg, Source) @end(verbatim) to each operand, passing a temporary register as the first argument, REG. This resolution process converts ALM operand forms into TLM operand forms i.e, legal addressing modes of the TLM. After each operand has been "resolved", the CMACRO pattern table is used, and the resulting LIST of CMACROS processed recursively. This is what is accomplished in the three functions: @begin(verbatim) EXPAND1OPERANDCMACRO(Arg1,Name) EXPAND2OPERANDCMACRO(Arg1,ARg2,Name) EXPAND4OPERANDCMACRO(Arg1,ARg2,Arg3,Arg4,Name) @end(verbatim) which first resolves the arguments using the available registers and then calls the routine (CMACROPATTERNEXPAND) which finds the pattern table of the Name argument (ALM instruction) stored on the property list under the indicator 'CMACROPATTERNTABLE. For example, (de !*WPlus2 (Arg1 Arg2) (Expand2OperandCMacro Arg1 Arg2 '!*WPlus2)) Only the (!*MOVE s d) ALM opcode tries to be smarter about temporary regs: d:=RESOLVEOPERAND('(Reg t2),d) If d is a register, then RESOLVEOPERAND(d,S) else RESOLVEOPERAND('(REG t1),s); [Future change - This should be changed in the future] Recall also that Processing an arugment with RESOLVEOPERAND may require other CMACRO's to be emitted first, to "simplify" the complex addressing mode; each Operand is free to destroy/modify its given register. For example, note how register t1 is reused below to resolve multiple CAR's and CDR's into MOVE's and simpler CAR's and CDR's: (!*MOVE (CAR (CAR x)) d) => (!*MOVE (CAR x) (REG t1)) (!*MOVE (CAR (REG t1)) d) (!*MOVE (CAR (CAR(reg 1))) (CDR (CDR (reg 2)))) => (!*MOVE (CDR (reg 2)) (REG t2)) (!*MOVE (CAR (REG 1)) (REG t1)) (!*MOVE (CAR (reg t1)) (CDR (reg t2))) Therefore, typically the operands are first processed before the ALM instruction table is used. AnyReg processing works the same way as with the ALM instructions. The operands are first resolved by calling the ResolveOperand function and then ExpandOneArgumentAnyReg (or TwoArgument) is called to process the pattern table. This has also been combined into a single function: OneOperandAnyReg and TwoOperandAnyReg. [[WARNING - There is an inconsistency in the naming here. For CMacro expansion the combined functions are called EXPANDxOPERANDCMACRO where for anyregs it is ONEOPERANDANYREG. BE CAREFUL!!!!!!! Another inconsistency is that CMacros are flagged with 'MC, which AnyRegs are not flagged]] @paragraph(ResolveOperand) The ResolveOperand function takes two arguments, a temporary register and the source to resolve. It performs the following resolution, in the order given: @begin(Description) an ID@\cals ResolveWConst on the ID; number or string@\returned unchanged; (OP s)@\If OP is flagged 'TerminalOperand, it is returned as is. (OP s)@\If OP is an @anyreg (has an 'AnyregResolutionFunction), it is applied to (Register s). (OP s)@\Otherwise, it is examined to see if it is a WCONST expression. @end(description) The function ResolveWConst tests its operand to see if it is a constant or constant expression, and returns its value. It performs the following resolution: @begin(description) (WCONST number)@\returns the number ID@\If WCONST indicator is on the ID's property, the associated number is returned otherwise the ID is returned. Expression@\Each operand is tested to determine if it can be resolved as a WCONST and if so, the function is applied to all of the operands (ANY FUNCTION CAN BE CALLED) @end(description) ?????Insert some SUMMARY USING THE FOLLOWING???????? Most ANYREGS use OneOperandAnyReg, ie recursively process arguments inside out (CAR anyreg), (CDR anyreg), etc % (de AnyRegCAR(R S) (OneOperandAnyReg R S 'CAR)) % (defAnyReg CAR AnyRegCar ....) Those that do not permit anyregs as args, use ExpandOneOperandAnyReg eg, (QUOTE s), (WCONST w), (WVAR v), (REG r) or flag name as TERMINALOPERAND to pass direct to ASM so here is a simple WCONST expression. As long as args are WCONSTEVALUABEL themselves, any function can be applied: @section(Predicates) Provided in the common machine independent files are a number of useful predicates. Those include: [[[[List the predicates provided in common-predicates]]]] Each of the following predicates expects one argument; call it X: @begin(Description) RegisterP@\(EqCAR X 'REG) tests for any register AnyP@\ Always T, used as filler EqTP@\ (equal X T) MinusOneP@\(equal X -1) InternallyCallableP@\Check if legal to make a fast internal call. Essentially checks the following: @begin(format) [(or !*FastLinks % all calls Fastlinks? (and !*R2I (memq X EntryPoints!*)) % or specially declared (FlagP X 'InternalFunction) (FlagP X 'FastLink)))] @end(format) AddressConstantP@\(or (NumberP X) (EqCar X 'Immediate))) @end(Description) @section(Standard ANYREGS) The following are the basic @ANYREG functions, which in many cases look for an AnyregTable: @begin(Description) @B[ID]@\@B[Flagged] CAR@\OneOperandAnyreg, 'CAR table@comment{ need to explain all of these tables - particularly the WVar table } CDR@\OneOperandAnyreg, 'CDR table QUOTE@\ExpandOneArgumentAnyreg, 'QUOTE table WVAR@\ExpandOneArgumentAnyreg, 'WVar table REG@\ExpandOneArgumentAnyreg, 'REG table WCONST@\OneOperandAnyreg, 'WConst table, default normally just SOURCE. FRAME@\ExpandOneArgumentAnyreg, computes offset from stack pointer, and passes this (in bytes) to 'FRAME table FRAMESIZE (Register)@\Computes (NAlloc!* @Value(Times) AddressingUnitsPerItem) to give size of frame to any special code needing it. MEMORY (Register Source ArgTwo)@\Used to compute indexed memory access: TwoOperandAnyreg, Look for 'MEMORY table. LABEL@\Flags a label, does no processing. @end(Description) The implementor of @PSL for any particular machine is free to add additional @ANYREG@xs (addressing modes), that are emitted as part of @CMACRO@XS by machine specific compiler patterns or COMPFNs. IMMEDIATE is a tag used to @ei[suggest] address or immediate constant. @subsection(Some AUXILLIARY Operand Modes for the TLM) Each of the following functions expects one argument; call it X: @begin(Description) UnImmediate@\If X @Value(Eq)(Immediate Y), removes tag to get Y. ExtraReg@\Converts argument X into Access to ArgumentBlock[X-LastActualReg] QUOTE@\Compiles X into a constant. If !*ImmediateQuote is T, returns an ITEM for object, else emits ITEM into a memory location, returns its address. @end(Description) Note @CMACRO@XS (flagged 'MC) are first expanded, then the PASS1PSEUDO@xs. This means the @CMACRO@XS are able to insert and manage TAGS that are removed or modified by final PASS1PSEUDO. @section(more junk) @i[Implement the Compiler Patterns and Tables]. This requires selecting certain alternative routes and parameterizations allowed by the compiler, trying to improve the match between the Abstract @PSL machine used by the compiler and the target architecture X. Mostly this phase is reserved for optimization, but the basic tables have to be installed to map @xlisp function names to corresponding @cmacro names and select the Compiler functions (COMPFNs and OPENFNs) to be used for each construct. This file, @dq[xxxx-COMP.RED], is usually copied from one of the existing machines and modified as needed. Most of the modifications relate to the legality of certain addressing combinations. These tables are briefly described in the Compiler chapter of the manual, but currently this task is still somewhat "arcane".@comment{ There needs to be some mention of what the usual modifications are! } @i[Build and Test the CROSS Compiler]. Now compile a series of LAP (mostly @CMACRO tests), @xlisp and @syslisp files to X assembly code, link and run. As the tests proceed, certain small I/O and function calling procedures are written in LAP. A common way to do I/O is to implement a @ei[Foreign Function]-calling protocol, used from @xlisp to call functions according to FORTRAN, PASCAL, C or other useful conventions. Calls in compiled @xlisp/@syslisp code to function names flagged with the 'FOREIGN-FUNCTION flag are called with a non-@xlisp protocol. This permits a standard I/O library to be called and allows simple routines to be written in another language. The purpose of this separate function-calling mechanism is to allow the @xlisp system to use the most efficient calling method possible, compatible with the needs of @syslisp and @xlisp. This method is not necessarily the most flexible, general, or safe method and need not be used by other languages. However, to allow the @xlisp/@syslisp system to call upon existing routines, particularly system-provided services, this additional function-calling mechanism should be provided. Some care needs to be taken to preserve and restore registers appropriately. @chapter(Test Series) In order to accomplish the PSL bootstrap with a minimum of fuss, a carefully graded set of tests is being developed, to help pinpoint each error as rapidly as possible. This section describes the current status of the test files. The first phase requires the coding of an initial machine dependent I/O package and its testing using a familar system language. Then the code-generator macros can be succesively tested, making calls on this I/O package as needed. Following this is a series of graded SYSLISP files, each relying on the correct working of a large set of SYSLISP constructs. At the end of this sequence, a fairly complete "mini-LISP" is obtained. At last the complete PSL interpreter is bootstrapped, and a variety of PSL functional and timing tests are run. @section(Basic I/O Support) The test suite requires a package of I/O routines to read and print characters, and print integers. These support routines are usually written in a "foreign" language (call it "F"), such as PASCAL, C or FORTRAN; they could also be coded in LAP, using CMACROs to call operating system commands, if simple enough. (E.g., JSYS's on DEC-20, Traps on 68000, etc.). These routines typically are limited to using the user's terminal/console for input and output. Later steps in the bootstraping sequence introduce a more complete stream based I/O module, with file-IO. On some systems, it is appropriate to have a main routine written in "F" which initializes various things, and then calls the "LISP" entry point; on others, it is better to have "LISP" as the main routine, and have it call the initialization routines itself. In any event, it is best to first write a MAIN routine in "F", have it call a subroutine (called, say TEST), which then calls the basic I/O routines to test them. The documentation for the operating system should be consulted to determine the subroutine calling conventions. Often, the "F" compiler has an "ASSEMBLY Listing switch", which can be turned on to see how the standard "F" to "F" calling sequence is constructed, and to give some useful guidance to writing correct assembly code. This can also be misleading, if the assembler switch only shows part of the assembly code, thus the user is cautioned to examine both the code and the documentation. On directory PT: (which stands for /psl/tests or <PSL.TESTS>), or its subdirectories, we have a number of sample I/O packages, written in various languages: PASCAL, FORTRAN, C and DEC20 assembly code. Each has been used successfully with some PSL bootstrap. The primitives provided in these files are often named XXX-yyyy, where XXX is the machine name, and yyyy is the primitive, provided that these are legal symbols. Of course, the name XXX-yyyy may have to be changed to conform to "F" and the associated linker symbol conventions. Each name XXX-yyyy will be flagged as a "ForeignFunction", and called by a non-LISP convention. The following is a brief description of each primitive, and its use. For uniformity we assume each "foreign" primitive gets a single integer argument, which it may use, ignore, or change (VAR c:integer in PASCAL). @Comment{Is this assumed to be a WORD size quantity, i.e. on the 68000 a 32 bit quantity or can it be a small integer???} The following routines ("yyyy") in LISP, will be associated with the corresponding "foreign" routine "XXX-yyyy" in an appropriate way: @begin(description) init()@\Called once to set up I/O channels, open devices, print welcome message, initialize timer. Quit()@\Called to terminate execution; may close all open files. PutC(C)@\C is the ASCII equivalent of a character, and is printed out without line termination (I/O buffering may be needed). C=EOL=10 (ASCII LF) @Comment{does this mean that the character should appear right away, or can it wait till the EOL is sent???} will be used to signal end-of-line, C=EOF=26 (ASCII SUB) will be used to signal end of file. GetC()@\Returns the ASCII equivalent of the next input character; C=EOL=10 for end of line, and C=EOF=26 for end of file. Note it is assumed that GetC does not echo the character. TimC()@\Returns the runtime since the start of this program, in milli-seconds, unless micro-seconds is more appropriate. For testing purposes this routine could also print out the time since last called. PutINT(C)@\Print C as an integer, until a SYSLISP based Integer printer that calls XXX-PutC works. This function is used to print integers in the initial tests before the full I/O implementation is ready. @comment{Err(C)@\Called in test code if an error occurs, and prints C as an error number. It should then call Quit() .} @end(description) The following functions will probably need to be defined in LAP, using either the ALM (cmacro level ) or machine specific (TLM) level: @begin(description) !%Store!-Jcall(Code-Address,Storage-Address)@\The Storage-Address is the address of the slot in the SYMFNC table where a jump instruction to the Code-Address must be stored. This implements a compiled call to a compiled function. You may have to insert padding or legal code to make the code match the call to the compiled code. The LAP for the Dec20 is: @begin(verbatim) LAP '((!*entry !%Store!-Jcall Expr 2) % CodeAddress, Storage Address (!*alloc 0) (!*WOR (reg 1) 8#254000000000) % Load a JRST in higher-bits (!*MOVE (reg 1) (memory (reg 2) (wconst 0))) (!*EXIT 0)); @end(verbatim) !%Copy!-Function!-Cell(From-Address,To-Address)@\Copies the SYMFNC cell located at the From-Address to the SYMFNC cell located at the To-Address. If your machine has the SYMFNC cell the same width as that of MEMORY, the following code used on the Dec-20 will work: @begin(verbatim) LAP '((!*entry !%copy!-function!-cell Expr 2) % from to (!*alloc 0) (!*move (memory (reg 1) (Wconst 0)) (memory (reg 2) (wconst 0))) (!*exit 0)); @end(verbatim) UndefinedFunction()@\In general, we think of the storage of the number of arguments in a register (Reg NargReg) and the index of the called function in a register (Reg LinkReg). This function must store the linkage register in the fluid UndefnCode!* and the Narg register in the fluid UndefnNarg!*. Finally, it must !*JCALL to the UndefinedFunctionAux. The following code implements this function in a manner that is portable across all machines that use the LinkReg and NargReg as real register: @begin(verbatim) FLUID '(UndefnCode!* UndefnNarg!*); LAP '((!*ENTRY UndefinedFunction expr 0) % No alloc 0 ? and no LINKE % because we don't want to % change LinkReg. (!*Move (reg LinkReg) (Fluid UndefnCode!*)) (!*Move (reg NargReg) (Fluid UndefnNarg!*)) (!*JCALL UndefinedFunctionAux) ); @end(verbatim) Flag(Dummy1,Dummy2)@\A call to this function is automatically generated by the compiler, but is never used. So, you must implement this function to call your error routine if it is actually called (This function will be redefined in a later test). The code for the Dec-20 is portable except the linkage to the Machine Dependent Error routine Err20: @begin(verbatim) LAP '((!*ENTRY FLAG expr 2) (!*alloc 0) (!*MOVE 2 (REG 1)) (!*LINKE 0 Err20 Expr 1) ); @end(verbatim) @end(description) Finally, the following three functions must be implemented to allow arithmetic operations of sufficient length. @begin(description) LongTimes(Arg1,Arg2)@\Compute the product of Arg1 and Arg2 and return: @begin(verbatim) procedure LongTimes(x,y); x*y; @end(verbatim) LongDiv(Arg1,Arg2)@\Compute the quotient of Arg1 and Arg2 and return the value: @begin(verbatim) procedure LongDiv(x,y); x/y; @end(verbatim) LongRemainder(Arg1,Arg2)@\Compute the Remainder of Arg1 with respect to Arg2: @begin(verbatim) procedure LongRemainder(x,y); Remainder(x,y); @end(verbatim) @end(description) As a simple test of these routines implement in "F" the following. Based on the "MainEntryPointName!*" set in XXX-ASM.RED, and the decision as to whether the Main routine is in "F" or in "LISP", XXX-MAIN() is the main routine or first subroutine called: @begin(verbatim) % MAIN-ROUTINE: CALL XXX-INIT(0); CALL XXX-MAIN(0); CALL XXX-QUIT(0); % XXX-MAIN(DUMMY): INTEGER DUMMY,C; CALL XXX-PUTI(1); % Print a 1 for first test CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(2); % Second test CALL XXX-PUTC(65); % A capital "A" CALL XXX-PUTC(66); % A capital "B" CALL XXX-PUTC(97); % A lowercase "a" CALL XXX-PUTC(98); % A lowercase "b" CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(3); % Third test, type "AB<cr>" CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print A65 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print B66 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTI(C); % should print 10 and EOL CALL XXX-PUTC(C); CALL XXX-PUTI(4); % Last Test CALL XXX-ERR(100); CALL XXX-PUTC(26); % EOF to flush buffer CALL XXX-QUIT(0); % END @end(verbatim) For examples, see PT20:20IO.MAC for DEC-20 version, PHP:HP.TEXT for HP9836 PASCAL version, PCR:shell for CRAY fortran version. @section(LAP-TO-ASM and CMACRO Tests) After the basic XXX-ASM.RED file has been written and the XXX-CROSS.EXE has been built, and seems to be working, an exhastive set of CMACRO tests should be run. The emitted code should be carefully examined, and the XXX-CMAC.SL adjusted as seems necessary. Part of the CMACRO tests are to ensure that !*MOVEs in and out of the registers, and the ForeignFunction calling mechanism work. The goal of this test, and the following few sections is to guide you in getting the first piece of ALM code to translate to TLM form, correctly assemble, and finally execute on the target machine. There are a large number of details to worry about, and one will have to come back and refine decisions a number of times. Some of the decisions you will have to make are based on incomplete information, and are based on an interaction of the ALM model, LISP usage statistics and unknown oddities of the target machine. In many cases, you will have to make the decision just to proceed to get the skeleton together, and then immediately come back to fix the code. The first major milestone will be to set up enough of the basic cross-compiler to be able to translate and assemble the following file, called PT:MAIN0.RED: @begin(verbatim) % MAIN0.RED - A "trivial" file of ALM level LAP to test % basic set of tools: LAP-TO-ASM mostly, % and CMACROs LAP '((!*ENTRY DummyFunctionDefinition Expr 1) (!*ALLOC 0) (!*MOVE (REG 1) (REG 2)) (!*EXIT 0)); END; @end(verbatim) It consists of a single procedure, written in LAP using only 4 CMACROs, each quite simple. Notice the procedure defined has a "long" name, which may have to be mapped to a simpler symbol (for your assembler) by a routine in your xxx-ASM.RED file. The !*ENTRY cmacro is actually handled by LAP itself, so there are 3 CMACROs to be written: @Begin(description) (!*ALLOC n)@\Issues instructions to allocate a frame of n items on the stack. May also have to issue instructions to check stack overflow if the system hardware does not. For some machines, with n=0, no code is emitted, while for others, !*ALLOC is a good place to establish certain registers for the code body. (On the CRAY, the call instruction puts the return address in a register, which get saved on the stack in the !*ALLOC). (!*MOVE source dest)@\Issue code to move the contents of source to the destination. In the MAIN0 example, a register to register move is desired. ALM (REG 1) and (REG 2) are almost always allocated to real TLM registers. An "anyreg" for the REG mapping will have to be written. (!*EXIT n)@\Issues code to clean up the stack, by removing the frame that was allocated by a corresponding (!*ALLOC n), and then returns to the caller, whose address was saved on the stack (usually) by an appropriate TLM instruction. (On CRAY, the return address is restored to the special register). @end(description) Here is an example of the processing of this file on the DEC-20. On the DEC20 we produce 2 files, the CODE-FILE and the DATA-FILE: @begin(verbatim) CODE-FILE, MAIN0.MAC DATA-FILE, DMAIN0.MAC @end(verbatim) In summary, here are the initial steps you will have to follow, with some indication of the decisions you will have to make: @begin(description) Decide on PSL Item layout@\How many bits for the tag; should there be a GC field; will the tag have to be masked out when the INF field is used as an address; should the fields be aligned to byte, word or other boundaries to make TAG and INF access faster; Decide on TLM register use@\Some registers will be used for the ALM registers (rest simulated by memory locations), some used for CMACRO temporaries, some for Target OS interface or addressibility, some for Linkage registers and some for the stack. Stack Implementation@\Should the LISP stack be same as system stack; can we use stack hardware; how about stack overflow; which way should stack grow; ALM needs to access elements inside the stack relative to the stack pointer; the stack pointer needs to be accessible so that the GC and other things can access and examine elements. @end(description) @section(More details on Arcitecture mapping) Need to explain why currently 1 tags used, expect more or less in future. Perhaps explain which tests are MOST important so at least those can be done efficiently, even if others encoded in a funny wya. Mention idea that in future may want to put (say) 3 bits of tag in lower word, force double or quadword alignment, and put rest of tag in object. Mention how some data-types are immediate, others point into memory, and some already have headers. Mention possibel user-defind extension types. Need to clarify how ALM registers are used so can be mapped to TLM or memory. Need to explain Stack registers, CMACRO temporary registers, link registers. Need to explain relative importance of certain CMACROs and order in which they should be written and debugged. Make a CMACRO test file to be examined by hand, to be assembled, and maybe even run. Need to give more detailed steps on how to get MAIN1 running; seems like a BIG step. Perhaps break down into smaller MAIN0, just to get off the ground. (Ie, might not execute, but should assemble). Give a check list of steps. Explain that at first, just get all pieces together, then can fill in details once the skeleton is correct, and flesh out stubs. Explain data-file versus code-file model. @section(SysLisp Tests) This set of tests involve the compilation to target assmbly code, the linking and execution of a series of increasingly more complex tests. The tests are organized as a set of modules, called by a main driver. Two of these files are machine dependent, associating convenient LISP names and calling conventions with the "Foreign" XXX-yyyy function, define basic data-spaces, define external definitions of them for inclusion, and also provide the appropriate MAIN routine, if needed. These files should probably be put on a separte subdirectory of PT: (e.g., PT20:, PT68:, etc.) The machine dependent files are: @begin(description) XXX-HEADER.RED@\Is a machine dependent "main" include file, read into each MAINn.RED file, to define the data-spaces needed, and perhaps define a main routine in LAP, and have the appropriate XXX-MAIN call the "FirstCall" function, used to start the body of the test. Also included are the interface routines to the "F" coded I/O package. providing a set of LISP entry-points to the XXX-yyy functions. This should be copied and edited for the new target machine as needed. Notice that in most cases, it simply defines "procedure yyyy(x); XXX-yyyy(x);", relying on "ForeignFunction" declaration of XXX-yyyy. XXX-TEST-GLOBAL-DATA.RED@\This contains a series of external declarations to correspond to the Global Data definitions in the above header file file. It is automatically included in all but the MAINn module via the "GlobalDataFileName!*" option of XXX-ASM.RED. @end(description) The machine independent test files and drivers are: @begin(description) MAIN1.RED@\Is a very simple driver, that calls Getc and Putc, does a few tests. It does an 'IN "XXX-HEADER.RED";'. The "FirstCall" procedure then calls "init", uses "putc" to print AB on one line. It should then print factorial 10, and some timings for 1000 calls on Factorial 9 and Tak(18,12,6). Build by itself, and run with IO. @Comment{This seems to hide the assumption that 10! can be done in the integer size of the test implementation.??? } SUB2.RED@\Defines a simple print function, to print ID's, Integer's, Strings and Dotted pairs in terms of repeated calls on PutC. Defines PRIN1, PRIN2, PRINT, PRIN2T, TERPRI and a few other auxilliary print functions used in other tests. Tries to print "nice" list notation. MAIN2.RED@\Tests printing and access to strings. It peforms most of the useful string operations, printing messages to verify that they function properly. Uses Prin2String to print a greeting, solicit a sequence of characters to be input, terminated by "#". Watch how end-of-line is handled. Then Print is called, to check that TAG's are correctly recognized, by printing a LISP integer, an ID and 2 dotted pairs. Requires SUB2 and IO modules. Finally, it tests the undefined function calling mechanism to verify that it does print out an error message. Therefore, the UndefinedFunction routine must be defined in xxx-header by this test 2. SUB3.RED@\Defines a mini-allocator, with the functions GtHEAP, GtSTR, GtVECT, GtCONS, Cons, XCons, NCons, MkVect and MkString. Requires primitives in SUB2 module. MAIN3.RED@\First Executes a Casetest, trying a variety of Branches and Defaults in the case staement. There are a number of calls on Ctest with an integer from -1 to 12; Ctest tries to classify its argument using a case statement. ConsTest simply calls the mini-allocator version of CONS to build up a list and then prints it. Requires SUB2, SUB3 and IO modules. SUB4.RED@\Defines a mini-reader, with InitRead, RATOM and READ. It has the facilities to convert case input, using the !*RAISE switch (and the SetRaise function). This mini-READ does not yet read vectors. Requires SUB3, SUB2, and IO modules. MAIN4.RED@\First, this test checks to see that EQSTR works. Then it tests FindId to see if it can find Identifiers known to exist. After that, it tests to see if new Id's can be found and then found in the same place. Then a test loop is created that calls RATOM, printing the internal representation of each token. Type in a series of id's, integer's, string's etc. Watch that the same ID goes to same place. When the user types a Q, it should go into a READ-PRINT loop. You should type in a variety of S-Expressions, checking that they are correctly printed. Once again, you should finally type a Q to exit. Requires SUB3, SUB2 and IO modules. SUB5.RED@\Defines a mini-EVAL. Does not permit user defined functions. Can eval ID's, numbers, and simple forms. No LAMBDA expressions can be applied. FEXPR Functions known are: QUOTE, SETQ, COND, PROGN and WHILE. The Nexpr LIST is also known. Can call any compiled EXPR, with the standard 15 arguments. Requires SUB4, SUB3, SUB2 and I/O. MAIN5.RED@\Starts a mini-READ-EVAL-PRINT loop, to which random simple forms may be input and evaluated. When ready, input (TESTSERIES) to test PUT, GET and REMPROP. Then an undefined function is called to test the UNDEFINED function mechanism. Requires SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are case raised (!*RAISE has been set to T by default) so input can be in in lowercase for built-in functions. Terminates on Q input. SUB6.RED@\Defines a more extensive set of primitives to support the EVAL, including LAMBDA expressions, and user defined EXPR, FEXPR, NEXPR and MACRO functions. This is a complete model of PSL, but has a restriced set of the PSL functions present. Can call any compiled or interpreted function. Requires SUB5, SUB4, SUB3, SUB2 and I/O. MAIN6.RED@\Tests the full PSL BINDING modules (PI:BINDING.RED and PT:P-FAST-BINDER.RED). Call the (TESTSERIES) routine to do a test of Binding, the Interpretive LAMBDA expression evaluator, and binding in compiled functions. Requires SUB6,SUB5, SUB4, SUB3, SUB2 and IO modules. !*RAISE is once again on. Terminates on Q input. SUB7.RED@\A set of routines to define a minimal file-io package, loading the machine independent files: PT:SYSTEM-IO.RED and PT:IO-DATA.RED, and a machine dependent file XXX-SYSTEM-IO.RED. The latter file defines primitives to OPEN and CLOSE files, and read and write RECORDS of some size. The following definitions are used in the routines: @begin(verbatim) FileDescriptor: A machine dependent word to references an open file. FileName: A Lisp string @end(verbatim) @begin(description) SYSCLEARIO()@\Called by Cleario to do any machine specific initialization needed, such as clearing buffers, initialization tables, setting interrupt characters, etc. SysOpenRead(Channel,FileName)@\Open FileName for input and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysOpenWrite(Channel,FileName)@\Open FileName for Output and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysReadRec(FileDescriptor,StringBuffer)@\Read from the FileDescriptor, a record into the StringBuffer. Return the length of the string read. SysWriteRec (FileDescriptor, StringToWrite, StringLength)@\ StringLength characters from StringToWrite from the first position. SysClose (FileDescriptor)@\Close FileDescriptor, allowing it to be reused. SysMaxBuffer(FileDesc)@\Return a number to allocate the file-buffer as a string; this should be maximum for this descriptor. @end(description) RDS, WRS, OPEN, CLOSE, DSKIN and TYPEFILE are defined. MAIN7.RED@\Starts the LISP READ-EVAL-PRINT loop tested before, and now permits the user to test io. Call (IOTEST). Other functions to try are (OPEN "foo" 'OUTPUT), (WRS n), (RDS n) etc. [Now the GETC and PUTC IO routines in XXX-HEADER will finally call the file-oriented IndependentReadChar and IndependentWriteChar]. Also includes the standard PSL-TIMER.RED (described below), which can be invoked by doing (DSKIN "PT:TIME-PSL.SL"). Since the garbage collector not yet present, may run out of space. FIELD.RED@\A a set of extensive tests of the Field and Shift functions. Needs a WCONST BitsPerWord defined in XXX-HEADER.RED. Build by itself, and execute with the IO support. @end(description) Test set "n" is run by using a set of command files to set up a multi-module program. These files are stored on the approriate subdirectory (PT20: for the DEC20). Note that each module usually produces 2-3 files ("code", "data" and "init") @begin(Enumerate) First Connect to the Test subdirectory for XXX: @verbatim[ @@CONN PTxxx:] Then initialize a fresh symbol table for program MAINn, MAINn.SYM: @verbatim[ @@MIC FRESH MAINn] Now successively compile each module, SUB2..SUBn @verbatim[ @@MIC MODULE SUB2,MAINn @@MIC MODULE SUB3,MAINn @@MIC MODULE SUBn,MAINn] Now compile the MAIN program itself @verbatim[ @@MIC PROGRAM MAINn] As appropriate, compile or assemble the output "F" language modules (after shipping to the remote machine, removing tabs, etc..). Then "link" the modules, with the XXX-IO support, and execute. On the DEC-20, the @verbatim[ @@EX @@MAINn.CMD] command files are provided as a guide] Rather than including output from some older test runs, we insist that you run the tests yourself on the HOST machine to be absolutley sure of what output they produce, and what input is expected. Also, if errors occur during testing, the examination of the HOST tests will help. This will also help as additonal tests are added by new implementors. @end(enumerate) @section(Mini PSL Tests) The next step is to start incorporating portions of the PSL kernel into the test series (the "full" Printer, the "full" reader, the "full" Allocator, the "full" Eval, etc.), driving each with more comprehensive tests. Most of these should just "immediately" run. There some peices of Machine specific code that have to be written (in LAP or SYSLISP), to do channel I/O, replacing the simple XXX-IO; to do fast APPLY; Fluid Binding and Arithmetic. This set of tests will help check these peices out before getting involved with large files. @section(Full PSL Tests) Now that PSL seems to be running, a spectrum of functional tests and timing tests should be run to catch any oversights, missing modules or bugs, and as a guide to optimization. The following tests exist: @Description[ PSLTEST.SL@\A fairly comprehensive test of the Standard LISP subset of PSL. Do (DSKIN "pt:psltest.sl"). There are a few tests of the error mechanism that have to be "pushed" through for a full test. MATHLIB.TST@\A series of tests of MATHLIB. First LAOD MATHLIB; into RLISP, then do IN "MATHLIB.TST"; . PSL-TIMER.SL, TIME-PSL.SL@\A standard timimg test covering PSL basics. Compile PSL-TIMER.SL into kernel, or with resident compiler, then (LAPIN "PT:TIME-PSL.TEST"). ] @section(Stabilize Basic PSL) Finally, compile the kernel modules of @PSL, link with the additional machine-dependent modules, and @PSL (hopefully) comes right up@Foot[Presently an unlikely possibility, as the system may still change arbitrarily from under the implementor!]. Additional work is underway to develop a much more comprehensive test set, that will not change while the implementor is proceeding with the bootstrap; unfortunately, @PSL is still undergoing continuous development at Utah, resulting in some "out-of-phase" communication problems. After the basic interpreter is working, additional modules can also be compiled from @xlisp to X and linked with the kernel. The most common of these might be the @RLISP parser and even the @REDUCE@cite[Hearn73] computer algebra system@Comment{???or should this be symbolic algebra system??? }. As more files are compiled to machine X and linked, the task becomes more tedious. At this point, we need to consider the bootstrap of the @ei[Resident] Compiler, LAP and fast-loader (FASL). The most common way to build and maintain large @PSL programs is to build the kernel @PSL with a resident FASLIN for loading fast-load files, and then compile required modules to FASL (xxxx.b) files. A @PSL-based system is built by loading the appropriate FASL files, and then saving the @dq[core] image as an executable file. On some machines this is easy; on others it is quite hard; see the discussions below. These additional steps are: @begin(enumerate) @i[Implement Resident LAP]. Using an existing LAP.RED as a guide, write a table-driven program that does the actual assembly of code written in LAP form for machine X, to the appropriate bit-patterns; the details of this process are discussed at length in @dq[Reading, Writing and Testing LAP]@cite[Griss82h]. @PSL provides many tools to make this task quite easy, but the process is still very machine dependent. Future work may lead to the use of an architectural description language. @i[Test LAP]. The depositing of bit-patterns into BPS@Foot[BPS is Binary Program Space. The name BPS is a remnant of @xlisp 1.6. The desire to have a separate code space is based on the desire to @ei<not> relocate compiled code.] needs to be checked. Check also that procedures can be constructed with LAP, compile LAP into the kernel, and assemble some small files. @i[Implement FASLIN]. FASLIN requires some binary I/O and other small support procedures described in a separate section below. @i[Implement FASLOUT]. Once LAP works, the FASLOUT process seems quite simple, requiring only the Binary I/O etc@. used by FASLIN. It should be possible to get xxxx-FASLOUT working on an existing @PSL, and cross-FASL for machine X. This has not yet been tested. When it works, FASLIN could be made part of the @PSL kernel very early on. @i[Test FASL files]. Check that FASL files can be easily written and read. @Comment{What kind of tests should be done??? This "easily written and read" sounds like apple pie, but it would seem that a piece of SYSLISP could be written that would give the FASL mechanism a good work out, perhaps two pieces with cross references to one another. } @i[Implement and test Core saving]. Determine how to save the image of an executing program, so that it can be restarted. We only require that it be restarted at the beginning, not where it was when it was saved. We usually change the MAIN entry function to call an appropriate TopLoop. See the more extensive discussion below. @foot[Actually, the only part which must be saved is the impure data part; the pure data section, the pure code section and the control stack need not be preserved - however, if only the impure data part is saved, the restart mechanism must map the pure data and code back in. For an example of programs which do selective dumping see EMACS MKDUMP and @interlisp SYSOUT. @Comment{We probably need to think about some way of loading the libraries similar to EMACS, such that it is easy to reload the libraries (particularly if they remain pure).}] @end(enumerate) @chapter(DETAILED REFERENCE MATERIAL) @section(Details on the ALM Operand forms) The following are references to a variety of memory locations: In the current implementation the following 4 reference the same location, the SYMVAL cell of the associated ID. This is the contents of the location SYMVAL+AddressingUnitsPerItem*IDLOC(id): @begin(verbatim) (FLUID name:id) (!$FLUID name:id) (GLOBAL name:id) (!$GLOBAL name:id) @end(verbatim) @begin(description) (WVAR name:id)@\This references the contents of the static location named by the ID. @end(description) The following are all constants, either absolute bit-patterns, or address expressions. @begin(description) (WARRAY name:id)@\Address of the base of a static array (WSTRING name:id)@\Address of the base of a static string (WCONST expr:wconst-expression)@\Any constant expression, either numeric, a declared constant, addresses of thinsg that could also be passed as WARRAY or WSTRING, or other expressions that can be handled by the TLM assembler. (IMMEDIATE wconst-expression:any)@\Really only introduced as a "tag" to make later processing easier; a constant is either an explict constant or (IMMEDIATE expression). This is default TLM mode wrapped when RESOLVEOPERAND is "unsure". We are confused about the differences between WConsts and Immediates in some cases. (QUOTE s-exp:s-expression)@\Is the constant bit-pattern representing a tagged PSL item. (LABEL l:id)@\Reference to a local location (symbol) in the current set of ALM instructions, processed in a single call to LAP, usually a single function. (MEMORY base:any offset:wconst-expression)@\This is the basic ALM "indexing" operation, and represents the contents of the location (base)+offset. (CAR base:any)@\Reference the contents of the ITEM pointed at by INF(base). It is assumed that base is actually a PAIR (not checked). In principle this is sort of like (MEMORY (INF base) (WCONST 0)). (CDR base:any)@\Refernce the contents of the ITEM pointed at by INF(base). It is assumed that base is actually a PAIR (not checked). In principle this is sort of like (MEMORY (INF base) (WCONST AddressingUnitsPerItem)). (FRAME n:integer)@\Contents of the n'th location in the current stack frame. In most versions of the ALM, there is an explicit register, (REG ST), which points at the base of the frame. The stack grows in some direction determined by features on the TLM, so that this could in principle be expressed as (MEMORY (reg ST) (WCONST (times StackDirection -1 AddressingUnitsPerItem (SUB1 n)))) (REG reg-descriptor:{integer,id})@\Reference to an ALM register. (LIT [any-instruction-or-label:{list,id}])@\Plants the instruction sequence elswhere, and leaves a reference to its start. Essetially equivalent to (label g), with g starting a block of the instructions, in "literal" space. (LABELGEN tag:id)@\A mechnism (with LABELREF) to generate and reference a label local to a particular CMACRO pattern. Meant mostly for implementing conditional jumps of various kinds. (LABELREF tag:id)@\Reference a label that was assigned to the Tag. @end(description) The following set of ALM instruction forms are used to define constant data which is intermixed with instructions. @begin(description) (FULLWORD [exp:wconst-expression])@\The expressions are deposited in successive "words" (item-sized units). (HALFWORD [exp:wconst-expression])@)\The expressions are deposited in succesive halfwords (two per item-sized unit). (BYTE [exp:wconst-expression])@\The expressions are deposited in successive "bytes" (character-sized units). (STRING s:string)@\The ASCII values of the characters of the string are deposited in successive bytes, terminated by a zero byte. (FLOAT f:float)@\The 2 word bit pattern for the floating point number is deposited. @end(description) These must be processed by the TLM to ASM translator (and later by the resident assmbler). @subsection(Standard @CMACRO@xs) The following are the basic @CMACRO@XS; additional @CMACRO@XS are of course frequently added either to aid in writing the @CMACRO@XS (a @CMACRO @ei[subroutine]), or to aid some aspect of the machine-specific details. Recall that each @CMACRO returns a list of LAP instructions (which are simpler to generate code for, although it may be a more complex list of operations) representing the appropriate expansion of this @CMACRO (these may also call other @CMACRO@XS). These instructions are then recursively processed by the @CMACRO expander (i.e@. LAP). The !*MOVE @CMACRO is very commonly used for this purpose, to get a @ei[general] operand into a register, so the particular @CMACRO can operate on it. The following @CMACRO@XS deal with function ENTRY, EXIT and function call: @begin(Description) !*Entry((FunctionName FunctionType NumberOfArguments)@\Normally the user does not code this @CMACRO, since it is processed completely by LAP itself. It is used to indicate the start of a function (or entry point within a function). Normally just plants a label corresponding to FunctionName. !*Exit (N)@\Exits (@dq[returns]) from procedure, deallocating N items, as needed. N corresponds to the N items allocated by !*Alloc, see below. !*Link (FunctionName FunctionType NumberOfArguments)@\If FunctionName is flagged 'FOREIGNFUNCTION, emit a call (!*ForeignLink FunctionName FunctionType NumberOfArguments), else emit a (!*Call FunctionName). This is the basic function call macro. It assumes the appropriate number of arguments are in the registers (previously loaded) in the registers, @w[(REG 1) ... (REG n)]. We currently do not check either NumberOfArguments or FunctionType, so a simpler @CMACRO, !*CALL is provided for basic function call. !*Call (FunctionName)@\Basic or @dq[Standard] function call. Checks to see if FunctionName has an 'OPENCODE property, and returns the stored instruction list if any. Otherwise it looks for an appropriate pattern table stored by DEFCMACRO under 'CMACROPATTERNTABLE, as described above. !*LinkE (DeAllocCount FunctionName FunctionType NumberOfArguments)@\An @dq[exit] call. Emitted when the caller does not need to examine the result, but returns it directly. The !*LinkE @CMACRO does not save the return address, so a return from the called function is not to this caller, but to the previous !*LINK. Essentially deallocates the frame (if any), does either an ordinary !*ForeignCall and then !*Exit(0), or does a !*JCALL which does no return address saving. !*JCall (FunctionName)@\First checks for an EXITOPENCODE table, then for an OPENCODE table (followed by a normal return, !*EXIT(0)) or looks for the general '!*JCALL table. The generated code is supposed to call the function without saving a return address, essentially a JUMP. !*ForeignLink (FunctionName FunctionType NumberOfArguments)@\ This is the basic linkage to a foreign function. It assumes the appropriate number of arguments are in the registers (previously loaded) in the registers, @w[(REG 1) ... (REG n)]. It then pushes the arguments on a stack, or moves them to a global location, as appropriate and transfers to the ForeignFunction in an appropriate manner (REWRITE). Some care must be taken in interfacing to the LISP world, with cleanup on return. @end(description) The following @CMACRO@XS handle the allocation and deallocation of a Frame of temporary items on the stack, used for argument saving, PROG local variables, etc. @Begin(description) !*Alloc (N)@\Allocates a frame of N @Value(Times) AddressingUnitsPerItem units by adjusting the stack (generally increasing it) by using a stack operation that invokes an overflow signal, if any. Otherwise the stack register should be compared against an appropriate UpperBound. It passes N @Value(Times) AddressingUnitsPerItem to the pattern, to be used for indexing or displacement. Note some stacks grow in the @ei[negative] direction, and this is a major source of @CMACRO errors. Currently, there is a major problem, that this MACRO may not be called recursively. FIX in the future. !*DeAlloc (N)@\Decrement stack by N @Value(Times) AddressingUnitsPerItem units, deallocating the temporary FRAME. Passes N*AddressingUnitsPerItem to the pattern. @end(Description) The following @CMACRO@XS deal with the binding and unbinding of FLUID variables used as Lambda or Prog parameters. They are usually quite complex to code. The basic idea is to follow the call on a Lambind or Progbind procedure by a compact table of Fluid addresses or offsets. The call may have to be special, and @ei[internal], so that the support code (usually hand-coded in LAP) can pick up and process each entry in the compact table. @begin(Description) !*LamBind(Registers FluidsList)@\Registers is of the form @w[(REGISTERS (REG a) (REG b) ... (REG c))], and FluidsList is of the form @w[(NONLOCALVARS (FLUID f) ...)]. The intent of this @CMACRO is to save the current value of each Fluid in the list on the Binding Stack, paired with the Fluid name. Then the value in the corresponding register is stored into the Value cell. Later unbinding by !*FreeRstr or the Catch and Throw mechanism, restores the saved value. !*ProgBind (FluidsList)@\Emitted for Fluid variables in Prog parameter lists. Idea is as above, but stores a NIL in the value cell after saving the old contents. Usually implemented as @w[(!*LamBind '(REGISTERS) FluidsList))], but may be able to use a more compact table. !*FreeRstr (FluidsList)@\Restores the old values of the fluids. Since we use a special binding stack with Fluid names stored on it, we really only need the number to unbind. [Perhaps we should use !*UnBind(N) to make this decision explicit.] @end(Description) Data-moving @CMACRO@XS. Most of the work is done by !*MOVE, with some PUSH/POP optimizations if the !*MOVE is close to an !*ALLOC or !*DEALLOC. Other data moving may be done in conjuction some of the operations, such as !*WAND, !*WOR, !*WPLUS2, !*WMINUS, etc. @begin(Description) !*Move (Source Destination)@\The major work horse. Generates code to move SOURCE to DESTINATION. Uses (REG t1) and (REG t2) as temporary registers if needed. First simplifies destination (@ei[Anyreg resolution]), using (REG t1) as a temporary if needed. It then simplifies the SOURCE, using the as temporary either the destination (if a register), or (REG t2). Finally, the !*MOVE table is used. !*Push (Arg1)@\Emitted during peep hole optimization to replace a pair !*ALLOC(1) and !*MOVE(arg1,(FRAME 1)). This is a very common optimization. !*Pop (Arg1)@\Emitted during the peep hole phase to replace the common pair !*MOVE((FRAME 1),Arg1), followed by !*DEALLOC(1). This modifies the argument ARG1. @end(Description) The JUMP @CMACRO@XS are given the label as the first operand, but they pass the label as the third (and last) argument to the pattern (usually as ARGTHREE) after resolving the other arguments. The label is tagged (LABEL Label). @begin(Description) @begin(group) !*Lbl (Label)@\This @CMACRO is emitted when a label is inserted in the generated code. Its body is usually trivial, but can be more complex if some form of short and long jump optimization is attempted. @hinge !*Jump (Label)@\Emit code to jump to Label. Label often involves memory. @hinge !*JumpEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 EQ Arg2. Used for @xlisp EQ and @syslisp WEQ. @hinge !*JumpNotEQ (Label Arg1 Arg2)@\Generate code to JUMP if not(Arg1 EQ Arg2). Used for @xlisp EQ and @syslisp WEQ. @hinge !*JumpWLessP (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(LT) Arg2. Used for @syslisp WLESSP. @hinge !*JumpWGreaterP (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(GT) Arg2. Used for @syslisp WGREATERP. @hinge !*JumpWLEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(LTE) Arg2. Used for @syslisp WLEQ. !*JumpWGEQ (Label Arg1 Arg2)@\Generate code to JUMP if Arg1 @Value(GTE) Arg2. Used for @syslisp WGEQ. !*JumpType (Label Arg TypeTag)@\Generate code to JUMP if TAG(Arg) @Value(Eq) TypeTag. The TypeTags are small integers, defined in the xxxx-Data-Machine file. This @CMACRO is emitted for opencoded Type checking, such as IDP(x), etc. It should be implemented very efficiently. Instead of extracting the TAG and comparing with the small integer, it may be easier just to mask the INF portion of Arg, and compare with a shifted version of TypeTag (previously saved, of course). @hinge !*JumpNotType (Label Arg TypeTag)@\Generate code to JUMP if not(TAG(Arg) @Value(Eq) TypeTag). See comments above. @hinge !*JumpInType (Label Arg TypeTag)@\Generate code to JUMP if Tag(Arg) is in the range @w([0 ... TypeTag,NegInt]). This is used to support the numeric Types, which are encoded as 0,...M, and -1 for negative Inums. Thus NumberP, FixP, etc@. have to test a range. Note that NegInt is tested specially. @hinge !*JumpNotInType (Label Arg TypeTag)@\Generate code to JUMP if Tag(Arg) is not in the range @w([0 ... TypeTag, NegInt]). See above comment. @hinge !*JumpOn (Register LowerBound UpperBound LabelList)@\Used to support the CASE statement. This is usually written by hand and no pattern is used. It tests if Register is in range LowerBound @value[Lte] Register @value[Lte] UpperBound; if so, it jumps to the appropriate label in labellist, using (Register @value[MinusSign] LowerBound) as the index. If not in range, it Jumps to a label planted at the end of the label table. In some implementations, the label table has to be a jump table. @hinge !*JumpWithin (Label LowerBound UpperBound)@\This is also used to support the CASE statement, in the situation where the overall label range is large, and there are many sub-ranges. This generates code to JUMP to Label if LowerBound @value(LTE) (REG 1) @value(LTE) UpperBound. A default version uses !*JumpWLessP and !*JumpWLeq tests. [Perhaps should be modified to use ANY reg]. @end(group) @end(Description) The following @CMACRO@XS perform simple computations on their arguments. Binary operations take two arguments, (Dest Source), and leave the result in DEST. @begin(description) !*MkItem (Arg1 Arg2)@\Computes Arg1 @Value(Eq) Item(Arg1,Arg2); construct an Item into Arg1 from the tag in Arg1 and Information part in ARg2. May have to shift and mask both Arg1 and Arg2. Equivalent to !*WOR(!*Wshift(Arg1,24),!*Wand(Arg2,16#FFFFFF)) on the 68000 [This may actually use a stored preshifted version of the tag]. [[[[[Check the ORDER!!!! and use parameters rather than 24 and fffff]]]]]] !*WPlus2 (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1 + Arg2. Look for special cases of 1, -1, 0, etc. Note on the 68000 it checks for a small integer, i.e. -8..8 since these are done with a @dq[QUICK] instruction. [Ignore overflow?] !*WDifference (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1-Arg2. Look for special cases of 1, -1, 0, etc. !*WTimes2 (Arg1 Arg2)@\Compute Arg1 @Value(Eq) Arg1*Arg2. It first looks to see if Arg2 is constant and a power of 2. If so, it emits a corresponding !*Ashift(Arg1,PowerOfTwo Arg2). This check for special cases is in the pattern. !*AShift (Arg1 Arg2)@\Shift Arg1 by Arg2, using Arithmetic shift. Used to support !*WTIMES2. Should do appropriate Sign Extend. !*WShift (Arg1 Arg2)@\Shift Arg1 by Arg2, logically, doing 0 fill. !*WAnd (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 AND Arg2. BitWise AND, each bit of Arg1 is 1 only if BOTH corresponding bits of Arg1 and Arg2 are 1. !*WOr (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 OR Arg2. BitWise OR. !*WXOr (Arg1 Arg2)@\Arg1 @Value(Eq) Arg1 Xor Arg2. !*WMinus (Arg1 Arg2)@\Arg1 @Value(Eq) @Value(MinusSign) Arg2. !*WNot (Arg1 Arg2)@\Arg1 @Value(Eq) Logical NOT Arg2. !*Loc (Arg1 Arg2)@\Arg1 @Value(Eq) Address (Arg2). @end(description) The following are important optimizations, that may be initially implemented as procedures: @begin(description) !*Field (Arg1 Arg2 Arg3 Arg4)@\Arg1 @Value(Eq) Extract Field of Arg2 starting at Bit Arg3, of Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. The most significant bit is numbered 0 in our model. There is an assumption that Arg3 Arg4 are constants. !*SignedField (Arg1 Arg2 Arg3 Arg4)@\Arg1 @Value(Eq) Extract Field of Arg2 starting at Bit Arg3, or Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. The field is to be sign extended into Arg1. !*PutField (Arg1 Arg2 Arg3 Arg4)@\Deposit into Arg1 a field of Arg2 starting at Bit Arg3, or Length Arg4. Bits are numbered 0...Size(Word)@Value(MinusSign)1. @end(Description) @section(Organization of the Compiler and Assembler Source Files) The code is organized as a set of common files kept on the PC: directory, augmented by machine-specific files kept on other directories@Foot[These generally have logical names of the form PxxxC: where xxx is the root name of the directories for a given machine/OS implementation.]. The @dq[skeletal] common files and machine-specific files (mostly kept as compiled FASL files) make up the CROSS compiler and assembler. The machine-specific files customize the compiler for the specific target machine and assembler (currently we compile for @DEC20, @VAX750, @Apollo, @WICAT, and Cray-1). @subsection(Common Files) The machine-independent part of compiler is kept as PL:COMPILER.B@Foot[PL: is <PSL.LAP> or ~psl/lap.], built by PC:COMPILER.CTL. It consists of the files: @begin(description) PC:COMPILER.RED@\The basic compiler PC:COMP-DECLS.RED@\Common declarations configuring the compiler: installing the compiler specific functions, such as PA1FNs, COMPFNs, OPENFNS etc. These are described in the compiler chapter. PC:PASS-1-LAP.SL@\Basic PASS1 of @CMACRO/LAP process. PC:ANYREG-CMACRO.SL@\The @CMACRO and @anyreg pattern matcher and support functions. PC:COMMON-CMACROS.SL@\Standard or default @CMACRO@xs and @anyreg@xs used by most implementations. PC:COMMON-PREDICATES.SL@\Useful predicates to aid in writing the @CMACRO@xs. @end(Description) In addition, the following file is needed: @Begin(Description) PC:LAP-TO-ASM.RED@\Standard functions to convert LAP into machine-dependent assembly code. @end(Description) @subsection(Machine-Specific Files) For machine xxxx, the files: @begin(description) xxxx-COMP.RED@\Machine-Specific Compiler Patterns and Function installations. This file may have some special @CMACRO support in it@Foot{This is the case of extending the abstract machine for a particular implementation.}. xxxx-CMAC.SL@\Machine-Specific @CMACRO@xs and @anyreg@xs. xxxx-ASM.RED@\Definition of FORMATS, and special addressing mode conversion functions, declaration Pseudos, etc. xxxx-DATA-MACHINE.RED@\Smacros and constants to define @syslisp macros needed for the implementation. This file associates @syslisp functions with @CMACRO@xs for special cases. @end(description) Finally, during the compilation of XXXX- user files, the following two files: @begin(description) xxxx:GLOBAL-DATA.Red@\Describes GLOBAL symbols used everywhere. @end(description) @subsection(Building the CROSS Compiler) [For the moment, see the distribution guide for the Host machine]. @section(Design of LAP Format) The argument to the function LAP is a list of lists and atoms. The lists are instructions, pseudo-ops and @cmacro@xs, and the atoms are labels which are used to refer to positions in the code. Note these need not be IDs, but can also be strings, saving on ID space. Instructions should be of the form @w[(@i(opcode) . @i(operands))], where @i(opcode) is a mnemonic for an opcode, and @i(operands) is a list of operands. Each operand should be either an integer, which represents an immediate integer operand, a label, or a list of the form @w[(@i(mode) . @i(suboperands))]. A @i(mode) is an addressing mode, such as INDEXED or INDIRECT on the PDP-10, and DISPLACEMENT, DEFERRED, AUTOINCREMENT, etc@. for the VAX-11. REG must exist on all machines; others will be chosen as appropriate for the system. Remember that these are mainly used for @cmacro expansions rather than for writing code, so choose names for mnemonic value rather than brevity. @i(Suboperands) may also be operands, or they may be specific to the mode, e.g@. register names.@comment(more on @xlisp specific ones, QUOTE and FLUID) See also the READING/WRITING/TESTING of LAP operating note@cite[Griss82h]. @comment[We have a LOT to write here!] @subsection(Addressing Modes) @subsection(Register Designators) @subsection(Labels) @subsection(Storage Pseudos) @section(Implement LAP-TO-ASM) @SubSection(Needed Values) Values must be given for: @begin(description) MainEntryPointName!*@\An ID which is the main procedure name. NumericRegisterNames!*@\A vector of the symbolic names for the compiler registers. @end(description) In addition, each of the registers (as IDs) must be declared, using DefList to provide the string name of the register and flagging the property list of the ID with 'RegisterName. @subsection(Tables) The list ForeignExternList!* is used to remember each of the foreign functions that has been called in the course of a module so that the proper externs can be emitted. @SubSection(Printing routines) A number of routines which are used to print the strings, constants, etc@. are listed as follows: @begin(format) PrintString(S) PrintByte!,(X) TruncateString(S,n) PrintByteList(L) PrintByte(X) PrintHalfWordList(L) PrintHalfWord(X) PrintHalfWords(X) PrintOpcode(X) SpecialActionForMainEntryPoint() PrintNumericOperand(X) @end(format) @subsection(Symbol Mapping) The function ASMSymbolP(X) must be written to check whether a @Xlisp ID is also a legal symbol for the target assembler. @Subsection(Formats) The following formats must be declared to tell the LAP-TO-ASM routines how to print objects and the format of file names to use: CodeFileNameFormat!*, DataFileNameFormat!*, LabelFormat!*, CommentFormat!*, ExportedDeclarationFormat!*, ExternalDeclarationFormat!*, FullWordFormat!*, HalfWordFormat!*, ReserveDataBlockFormat!*, ReserveZeroBlockFormat!*, DefinedFunctionCellFormat!*, UndefinedFunctionCellInstructions!*, and the description for how to construct an item (for MkItem). @section(Independent Compilation) In order to maintain the PSL kernel as a set of reasonable sized modules (about 15) a method to permit (semi-)independent translation from LISP (or RLISP) to TLM assembly format was devised. This method records information about symbols and structures defined in one module and needed in another in a file called the SYM file. When a set of modules is to be assembled into a program, a fresh SYM file is allocated (usually called XXX-PSL.SYM or "Program-name.SYM"). Then as each module, MMM.RED is translated, the SYM file is first read in to initialize various SYMBOL counters. After the translation is complete an updated SYM file is written for the next step. When all modules are tranlated, a last (MAIN) module is translated, and some of the data information gathered in the SYM file is converted into global data declarations in the assembly file. Each module, MMM.RED (perhaps described by a MMM.BUILD file), is converted into 3 files, and updates to the SYM file: @begin(description) Code-File@\Contains the actual instructions for the procedues in the MMM file. May also contain "read-only" data, such as some strings or s-expressions. Typically called something like MMM.asm Data-file@\Contains data-objects that may get changed, typically WVAR and WARRAYs. This file typically called DMMM.asm or MMMd.asm. Init-file@\Contains S-expressions that were not compilable procedures found in the MMM.red file. Typically FLUID declarations, SETQ's and PUT's dominate this sort of code. This file will be read-in by the executing PSL after basic INITCODE is executed. Typically called MMM.INIT. @end(description) The .SYM file data structures are updated. These structures are: @begin(description) Startup-Sexpressions@\Certain s-expressions must be evaluated during INITCODE, before the .INIT files can be read. These are collected into a single procedure, and compiled as INITCODE in the MAIN module. This is the (SAVEFORCOMPILATION (QUOTE ...)) expression in the SYM file. ID list@\New IDs encountered in this file are added to a list of IDs in ID# order. IDs are referred to by ID#; list is called ORDEREDIDLIST!*. NEXTIDNUMBER!*@\The next ID# that will be allocated to the next new ID. STRINGGENSYM!*@\A string representing the last generated symbol-name. Used for internal labels, and external names that are too complex. Individual ID descriptors@\Each ID is now "installed" with a set of PUT's, indicating its ID#, the assembly symbol that is its entry point, if it is a WCONST, WVAR ,WARRAY etc. for example: @begin(Verbatim) (PUT 'INFBITLENGTH 'SCOPE 'EXTERNAL) % An exported WCONST (PUT 'INFBITLENGTH 'ASMSYMBOL 'NIL) % no symbol allocated (PUT 'INFBITLENGTH 'WCONST '18) % Its compile time value (PUT 'STACKUPPERBOUND 'SCOPE 'EXTERNAL) % An exported WVAR (PUT 'STACKUPPERBOUND 'ASMSYMBOL '"L2041") % The Assembly SYMBOL (PUT 'STACKUPPERBOUND 'WVAR 'STACKUPPERBOUND) % Type of VAR (PUT 'TWOARGDISPATCH 'ENTRYPOINT '"L1319") % An internal FUNCTION % and its Assembly SYMBOL (PUT 'RELOAD 'ENTRYPOINT 'RELOAD) % A simple entry point, not renamed (PUT 'RELOAD 'IDNUMBER '552) % Its ID number. % SYMFNC(552)-> JUMP RELOAD (PUT 'CADR 'ENTRYPOINT 'CADR) % Another simple entry point (PUT 'CADR 'IDNUMBER '229) (PUT 'LIST2STRING 'ENTRYPOINT '"L0059") % Entry point, renamed because % too long % SYMFNC(147)->JUMP L0059 (PUT 'LIST2STRING 'IDNUMBER '147) (PUT 'SPECIALRDSACTION!* 'IDNUMBER '598) % A Global variable, % INITIALLY NIL (FLAG '(SPECIALRDSACTION!*) 'NILINITIALVALUE) (PUT 'GLOBALLOOKUP 'ENTRYPOINT '"L3389") (PUT 'GLOBALLOOKUP 'IDNUMBER '772) (PUT 'CLEARCOMPRESSCHANNEL 'ENTRYPOINT '"L2793") (PUT 'CLEARCOMPRESSCHANNEL 'IDNUMBER '678) @end(Verbatim) @end(description) The contents of SYMFNC are filled in during the translation of the MAIN module, and JUMPs to the entrypoints of symbols that have them are filled in. Other symbols get a JUMP to the UndefinedFunction Entry point. In general, individual modules can be retranslated, since the information they generate is initially taken from the SYM file (ensuring that ID's and SYMBOLS get the same IDNUMBER and ENTRYPOINT as before). The procedure is to translate the desired model (modules) again, replacing the CODE-FILE, DATE-FILE and INIT-FILE previously produced, and also to retranslate the MAIN module, since additonal symbols S-expressions etc may have been produced, and therefor need to be converted into INIOTCODE or HEAP or SYMBOL data. @subsection(Data Pseudos) The following are pseudo operations (from the @68000 version) which must have a procedure to implement them in xxxx-ASM.RED: HalfWord, Deferred, Displacement, Indexed, Immediate, Iconst, AutoIncrement, AutoDecrement, Absolute, and ForeignEntry. @section(Configure the Compiler) This is still somewhat arcane. Basically, the compiler tables that select the COMPFN's and OPENFN's and patterns need to be installed. The most common method of doing this is to start from the xxxx-COMP.RED file most like the target machine X@Foot[It is still the case that you need a compiler wizard to help you with this as the details are still changing and often undocumented, with a lot of "You have to do this, to do that, but ..."]. [Effort is required to describe this more clearly] @Section(Write the Additional LAP Modules) A variety of small LAP routines are required for I/O, system interface, core-saving, efficient function-linkage, variable binding, etc. Some of these are described in the following System Dependent Section. Others are: @subsection(Apply-LAP) These procedures are rather important, and unfortunately tricky to write. They are used to enable compiled-code to call interpreted code and vice versa. When they are used, the registers R1...Rn have the arguments loaded in them, so SYSLISP can't be used. The routines are CodeApply(codePtr,Arglst), CodeEvalApply(CodePtr,Arglst), BindEval(Formals,Args), CompileCallingInterpreted(IdOfFunction), FastApply(), and UndefinedFunction(). These are partially described in SYSLISP, and written in LAP with mostly @CMACRO@XS@Foot[See P20:APPLY-LAP.RED and PV:APPLY-LAP.RED.]. Need to discuss tricks in more detail, devise a set of tests. @subsection(Fast-Bind) This consists of efficient routines written in LAP (using mostly @CMACRO@xs) to BIND and UNBIND fluid variables. The specifics depend on how the !*LAMBIND, !*PROGBIND and !*FREERESTR @CMACRO@xs are implemented. In general, a machine specific "fast-call" is used, rather than the more general recursive LISP call, and a list of ID numbers and values ( NIL or register numbers) are passed in a block. The FASTBIND routine uses the ID number to find the current value of the ID, and saves the ID number and this value on the binding stack. Then NIL (for PROGBIND), or the register value (for LAMBIND) is installed in SYMVAL(ID#). Note that the compiler registers R1...Rn should not be changed, so either they have to be saved, or other "hidden" registers have to be used. Since some hidden registers may be used in the implementation of certain @CMACRO@xs, care has to be exercized. FASTUNBIND is usually simpler, since all it needs is a number of @W[(ID# . Old-value)] pairs to pop off the Binding stack, and restore @Foot[See P20:FAST-BINDER.RED or PV:FAST-BINDER.RED for some ideas.]. @SECTION(System Dependent Primitives) The following set of functions are needed to complete the system-dependent part of @PSL: @subsection(System-dependent input and output) @PSL uses a one-character-at-a-time stream model for I/O. I/O channels are just small integers in a range from 0 to 32 (32 was chosen for no particular reason and could easily be increased if desired). They are used as indices to the WArrays ReadFunction, WriteFunction and CloseFunction, which contain the names (as @xlisp items) of the functions to be called. Thus a stream is an object with a set of operations, buffer(s), and static vaiables associated with it. The current implementation of streams uses parallel vectors for each of the operations that can be associated with a stream. The Channel Number is used as an index into these vectors. For example, the standard input channel is 0@Foot[This corresponds to the @UNIX STDIO channel "stdin".] thus ReadFunction[0] contains 'TerminalInputHandler, which is a function used to get a character from the terminal. The system-dependent file input and output functions are responsible for associating these channels with @ei[file pointers] or @ei[JFNs] or whatever is appropriate to your system. These functions must also perform any buffering required. We have been lucky so far because the @UNIX and Tops-20 systems have single character primitives@Foot[Thus the operating system hides the buffering.]. The reading function is responsible for echoing characters if the flag !*ECHO is T. It may not be appropriate for a read function to echo characters. For example, the "disk" reading function does echoing, while the reader used to implement the @b[Compress] function does not. The read function should return the ASCII code for a line feed (EOL) character to indicate an end of line (or "newline"). This may require that the ASCII code for carriage return be ignored when read, not returned. The VAX UNIX version of SYSTEM-IO.RED (stored on PV:@Foot[PV: is <PSL.VAX-Interp> or ~benson/psl/vax-interp.]) is the simplest, since the UNIX STDIO library is so close to this model. This is a good starting point for a new version. It also uses the file PSLIO.C, which contains the array @w[@Value(UnderScore)FILEPOINTEROFCHANNEL], used for channel allocation. The function @b(ClearIO) is called at system-startup time and when the function RESET is called. It should do all dynamic initialization of the system, but should not close any open files. Static initialization of slots in the function arrays is done in the system-dependent file IO-DATA.RED, and the array used for channel allocation should also have initialized slots for the channels used for terminal input (STDIN!* = 0), terminal output (STDOUT!* = 1) and channels 2 thru 4, used by BLDMSG, COMPRESS/EXPLODE and FLATSIZE. The variable ERROUT!* should have a terminal output channel associated with it. This may be shared with STDOUT!* as in the @Dec20, or be associated with a separate error diagnostic stream, as on the VAX. Channel allocation is handled by the system-dependent part of I/O, so when the @Xlisp function Open calls the function @b(SystemOpenFileSpecial) for a non-file-oriented I/O stream, it should just mark a free channel as being in use and return it. @b(SystemMarkAsClosedChannel) does the opposite, returning a channel to the pool of available ones. @b(SystemOpenFileForInput) and @b(SystemOpenFileForOutput) each takes a string as an argument and should return a channel and set appropriate functions in the corresponding slots in ReadFunction, WriteFunction and CloseFunction. If a file cannot be opened, a continuable error should be generated whose error form is (OPEN @dq[file name] 'TYPE), where TYPE is either INPUT or OUTPUT. Terminal output should be unbuffered if possible. If it must be buffered, it should be flushed when terminal input is done and when EOLs are written. Terminal input should be line buffered, using line editing facilities provided by the operating system if possible. The terminal input routine is responsible for the display of the variable PromptString!*, using a @PSL channel for output if desired, as the VAX version does. The @Dec20 terminal input routine uses a line editing facility that redisplays the prompt and previously typed characters when a Control-R is typed. End of file on input is indicated by returning a character which is CHAR EOF, Control-Z (ASCII 26) on the @Dec20 and Control-D (ASCII 4) on UNIX. This can be changed to any control character. The file SCAN-TABLE.RED will contain the CharConst definition for EOF, and a copy of LispScanTable!* with an 11 (delimiter) in that position. @subsection(Terminate Execution) The function QUIT(); terminates execution. It should probably close open files, perhaps restore system state to "standard" if special I/O capabilities were enabled. On some systems, execution can continue after the QUIT() at the next instruction, using a system command such as START or CONTINUE; on others, the core-image cannot be continued or restarted (see DUMPLISP(), below). On the DEC-20, the HALTF jsys is used, and execution can be continued. On the VAX under UNIX, a Stop signal (18) is sent via the "kill(0,18)" call. This also can be continued under Berkeley 4.1 UNIX. See the file SYSTEM-EXTRAS.RED on PV: and P20: @subsection(Date and Time) The function TIMC(); is supposed to return the run-time in milliseconds. This time should be from the start of this core-image, rather than JOB or SYSTEM time. It is used to time execution of functions. Return it as a full-word, untagged integer in register 1. On the DEC-20, we use the RUNTM jsys, on the VAX the C call on "times" is used, and multipled by 17, to get 1/1020'ths of a second. While not yet required, a TIMR() to get REAL, or WALL, time may be useful@Foot[See TIMC.RED on P20: and PV:.]. The DATE(); function is supposed to return a Tagged @XLISP string containing the current date. No particular format is currently assumed, and the string is used to create welcome messages, etc. Later developments may require a standard for TIMESTAMPS on files, and may also require a CLOCK-time function. The Allocator function GtSTR(nbytes) may be useful to get a fresh string to copy the string returned by a system call into. The string should be 0-terminated. The DEC-20 uses ODTIM, and "writes" to the string in "6-jun-82" format. On the VAX, the "ctime" call is used, and the result "shuffled" into the same format as the DEC-20@Foot[See SYSTEM-EXTRAS.RED on PV: and P20:]. @subsection(ReturnAddressP) The function RETURNADDRESSP(x); supports the backtrace mechanism, and is supposed to check that the instruction before the supposed address X, is in fact a legal CALL instruction. It is used to scan the stack, looking for return addresses@Foot[Very TRICKY, see SYSTEM-EXTRAS.RED on PV: and P20:]. @subsection(Interrupt Handler) Also very crude at present; on the DEC-20, written as a loadable module, P20:20-INTERRUPT.RED, using the JSYS package. This enables CTRL-G, CTRL-T, some stack and arithmetic overflows, binding them to some sort of Throw or Error routine. On the VAX, the file PV:TRAP.RED defines some signal setup, and InitializeInterrupts routine, and is included in the kernel. It associates each trap with a STDERROR call with a given message. Not yet standardized. We really should "bind" all trappable interupts to an appropriate THROW('!$SIGNAL!$,n), and indicate whether to treat as a Fatal Error, a Continuable Error, or not an Error at all. @subsection(Core Image Saving) A way in which @PSL (and most @XLISP@xs) get used involves the ability to load @XLISP and FASL code into an executing @PSL, saving this augmented "core-image" in a named file for subsequent restart later. Some Operating Systems permit a running program to be saved into an executable file, and then restarted from the beginning; others permit the saved program to be continued at the instruction following the call to the SAVE routine. Some operating systems do not normally permit or encourage the saving of a running program into an executable file, and there is a lot of work to be done. The model currently used in @PSL is that a call on DUMPLISP(); does the following (this is based on VAX and DEC-20 experience, and could change as Apollo and CRAY are completed): @begin(enumerate) calls RECLAIM(); to compact the heap, or move the upper heap into the lower heap. @Comment{How is it told that this is a cleanup reclaim that is to put the results in the "lower" heap???} makes some system calls to free unused space, decreasing the executable image; space is returned from HEAP, BPS and STACK. the core-image is saved in a file, whose name is the string in the global variable, DumpFileName!* (this string may have to be passed to the system routine, similar to I/O, using a small peice of LAP as interface, or using the Foreign function protocol); execution continues without leaving the running program; to terminate, the QUIT(); function must be called explicitly [this may not be possible on some systems, and may require a change in the model, or a machine specific restriction]. the saved executable file will restart "from-the-top", i.e. by calling the machine specific "startup" function defined in MAIN-START.RED, which calls initialization functions CLEARBINDINGS(), CLEARIO(), INITIALIZEINTERRUPTS(), etc. Then the Startup function calls MAIN();, which can be redefined by the user before calling DUMPLISP();. MAIN() typically calls StandardLISP() or RLISP(), or some other TopLoop. This startup function also has a @XLISP accesible name, RESET. @end(Enumerate) On some machines, the core-image will automatically start "from-the-top", unless effort is expended to change the "restart-vector" (e.g@. the TOPS-20 SSAVE jsys on the DEC-20); on others, an explicit LINKE CALL (a JUMP) to RESET should be included after the core-save call, to ensure execution of RESET (e.g@. the CTSS DROPFILE call on the CRAY-1). On the VAX under UNIX, a new function UNEXEC was written in C, to convert an executing program back into "a.out" format. See the files MAIN-START.RED and DUMPLISP.RED on P20: and PV:, and the preliminary documentation on the @apollo MAP_CODE.TXT, on PD:. @section(How LAP/TLM assembler works) @Section(How the LAP works) This discription of how the resident assembler (LAP) works is taken from the 68000 implementations. Refer to the diagram below to aid the understanding of this description. ALM instructions are passed into the procedure called LAP. The first thing LAP does is to pass them through the procedure PASS1LAP to transform ALM into TLM. The TLM is handed to OptimizeBranches to check to see if long branches are needed. OptimizeBranches is responsible for computing the offset of each label from the beginning of the function. A list called BranchAndLabelAlist is created which stores the labels and their offsets from the start of the code for this function. Upon the exit from OptimizeBranches the user may turn on the flag "PGWD" and will be able to see the current state of the code. If the code is to be compiled into memory and not fasled to a file then BPS space is allocated. Now the code make take one of three parallel paths. If the code is a label then it is ignored. If the instruction is an instance of !*Entry then the instruction is passed to the procedure SaveEntry to establish the address of the entry point of the code. On all other cases the instruction is passed to the procedure deposit instruction. This is often a good procedure to trace when debugging lap so that one can see what is actually heading off to be depsoited. Once the code has passed through one of the above three paths, the function defineEntries is called which loads the new code pointer into the function cell in the SYMFNC table. Following this the code pointer is tagged as code and returned as the result value of the function LAP. The following details are provideed as a guide to writing your own assembler. Consderation should be give to @begin(enumerate) Regular vs Irregular Machines Templates to Assemble Portions of Instruction Variable Length Instructions Alignment Problems Data Psuedos @xlisp Specific Pseudos @end(enumerate) @section(How do opcodes get defined for the LAP assembly process) There are three procedures used to define the opcodes. The first is DefineOpcode which defines, sets the necessary properties on the opcode's property list, for 680000 opcodes that have no ,byte,word, or long variants. The second function is DefineOpcodes (notice it is simply the plural of the first function) which defines an opcode with variants for byte,word, and long mode. And third is the function DefineCCOpcodes which sets up the properties for all the condition codes. @Section(Description of DefineOpcode) The function DefineOpcode an have three, four, or five arguments. They are defined to be: @begin(enumerate) The opcode name or id. The base 2 value of the opcode, only the constant bits in the opcodes binary value are given initially, the varible fields of an opcode are ORed into the word later. These are all two bytes long. This is tagged on a functions property list as its OpcodeValue. The function to be used to assemble this opcode, referred to on the property list by a functions InstructionDepositFunction. The forth field if present represents the mode to be used with this instruction: either byte, word, or long mode. The default is always word mode. This value is stored on the property list under the tag of Size. The fifth field is the number of bytes that the instruction will take up in the resulting binary code. Generally, only instructions that take no arguments will have this field filled in. This value is stored on the property list under the tag of InstructionLength. @end(enumerate) DefOpcode finally calls the function EvDefopcode which puts all the properties on the property list. @Section(How the Function DefOpcodes works) This function works just like the previous function DefOpcode except that it takes one less field, the size field which tells how the opcode will be used: byte, word, or long. This procedure will define an opcode for each case. For example if an opcode name is move then an id with associated property list will be created for move.b, move.w, and move.l. @Section(How the procedure DefCCOpcodes Works) This function was written just to save typing in all the cases of opcodes that use the condition codes. It does that same thing as DefOpcode above but for each condition code variant of an opcode. @section(Ok so what happens in a functions instruction depositfunction??) The opcode and oprands are selected out of the list and if the operands are not normal then they are passed throught the function effective address which classifies then as to the 68000 convention of register and mode. Purpose: convert an operand from symbolic to numeric form. Returns: Addressing mode in the range 0..7 -------------------------------------------------- M68K addressing modes (from appendix B of the M68K User's Manual) Addressing Mode Mode Reg Valid Modes* Assembler Data MEM Cont Alter Syntax Data Register Direct 000 reg no. X - - X Dn Address Register Direct 001 reg no. - - - X An Addr Reg Indirect 010 reg no. X X X X (An) with PostIncrement 011 reg no. X X - X (An)+ with PreDecrement 100 reg no. X X - X -(An) with Displacement 101 reg no. X X X X d(An) with Index 110 reg no. X X X X d(An,Ri) Absolute Short 111 000 X X X X xxxx Absolute Long 111 001 X X X X xxxxxxxx PC with Displacement 111 010 X X X - d(PC) PC with Index 111 011 X X X - d(PC,Ri) Immediate 111 100 X X - - #xxxxxxxx * = Valid Addressing modes for each type of Addressing Category Data - used to refer to data operands Mem = Memory - used to refer to memory operands Cont = Control - used to refer to memory operands without an associated size Alter = Alterable - used to refer to alterable (writeable) operands -------------------------------------------------- Operand is of the form: case 1: numeric immediate data or (immediate x) case 2: non-numeric atom a local label, which uses PC with displacement case 3: (reg x) x is a number or symbolic register name case 4: (deferred (reg x)) address register indirect in Motorola jargon case 5: (autoincrement (reg x)) address register indirect with postincrement case 6: (autodecrement (reg x)) address register indirect with predecrement case 7: (displacement (reg x) n) if (reg x) is an A reg then if n is 0 then (deferred (reg x)) else address register indirect with displacement else if (reg x) is a D reg then address register indirect with index, using A6 (zero) case 8: (indexed (reg x) (displacement (reg y) n)) address register indirect with index case 9+: various Lisp addressing modes, all of which are absolute long addresses The value returned by this function is the mode field of the instruction for the operand. In addition, the fluid variables OperandRegisterNumber!* and OperandExtension!* will be set. If there are no words to follow, OperandExtension!* will be set to NIL. Otherwise, possible values of OperandExtension!* are: number or (immediate exp) immediate data (number) 16-bit signed displacement non-numeric atom pc relative label (displacement reg disp) index extension word other absolute long, i.e. LISP addressing mode LAP is a complete assembly form and can be used by @xlisp programmers to write any legal assembly code@Foot{There is no real guarantee that the entire set of machine opcodes is supported by the LAP. An implementor may have chosen to implement only those constructs used by the compiler-produced code or explicitly used in hand written LAP. The reason for this partial implementation is that many modern processors have included operations to facilitate @ei[high level language compilation], which often seem to be less than useful.} @section(Binary FAST Loader,FASL) [Explain FASL in general] [Explain essential problem, relocation of machine addresses and LISP ids] [Give big-picture of FASL] [Find MAGUIREs pictures of FASL blocks or regenerate ] This section is a guide to the internal workings of faslout and then faslin. The user begins the faslout procedure by calling the procedure faslout with a string that does not have the extension (because it will add the appropriate binary extension for you). However, when fasling in, the file name requires the binary extension [Change this inconsistency]. Inside the procedure faslout, the file name is assigned to the fluid variable ModuleName!*. Depending upon the setting of the flag !*Quiet_Faslout, the system will either print out a greeting message or not. Next, an output binary file is opened using the argument file name. It will return the channel number to a fluid variable CodeOut!*. CodeFileHeader is called to put in a header in the output file. CodeFileHeader writes out a word consisting of the Fasl Magic Number (currently set to 99). This magic word is used to check consistency between old and current fasl format files (an error is given upon fasling in the file if there is not a 99 as the first word). Therefore, the system must consistently modify that number when a new fasl format is produced. To continue, we need to understand the allocation that takes place within the Binary Program Space (BPS). The BPS is a large, non-collected space that contains compiled code, warrays, the string assocaited with interned ID's, constant data in fasl files, etc. Space is allocated from both ends of the space. Compiled code is allocated from the bottom (using NextBPS as a pointer) and warrays are allocated from the top (using LastBPS as the pointer). When an allocation is attempted, the desired size is checked to see if it will cause LastBPS and NextBPS to cross; if it will, an error message will be printed. The next step is to allocate 2/3 or the remaining BPS from the top. @begin(verbatim,leftmargin 0) .------------------------------------. | | | WArrays | | | | | Last_BPS>|------------------------------------| <-FaslBlockEnd!* ---. | Code | | | | | | | | | | 2/3 |====================================| <-CodeBase!* | | Bit Table | | |====================================| <-BitTableBase!* ---' | | | | Next_BPS>|------------------------------------| | | | | | | `------------------------------------' Binary Program Space @end(verbatim) The procedure AllocateFaslSpaces will setup the following fluid variables. FaslBlockEnd!* will be the address to the top of the available space for this particular allocation. BitTableBase!* points to the beginning of the BitTable. CurrentOffset!* keeps a pointer into the codespace of this allocation to the next available point to add more code. BitTableOffset!* is a running pointer to the current location in the BitTable where the next entry will go. CodeBase!* is the base pointer to the beginning of the code segment for this allocation. MaxFaslOffset!* is the max size of the codespace allowed for this implementation. OrderedIDList!* keeps record of the ID's as they are added. NextIDNumber!* is a base number used just in fasl files to indicate which IDs are local and which are global. It is assumed that there will never be more than 2048 pre-allocated ID's, currently there are 129. The first 128 preallocated IDs are ASCII codes(0-127) and the last one is NIL(128). Everything is now setup to begin fasling PSL code out to the file. The remainder of the faslout procedure sets up three more fluid variables. !*DEFN is set to T which indicates that you are not going to do normal evaluation from the top loop and from files such as using the functions IN and DSKIN. DFPRINT!* signals that DFPRINT!* is now used as the printing function. The procedure used will be DFPRINTFasl!*. !*WritingFaslFile is set to T to let the system know that fasling out is goping on as opposed to compiling code directly into memory inside the PSL system. @subsection(Binary I/O and File Format) @u[Current FASL file format:] Check accuracy, this was PC:fasl-file.Specs @begin(description) Word@\Magic number (currently 99).@comment{ Why the magic number 99??? } Word@\Number of local IDs. Block@\Local ID names, in order, in regular @xlisp format (string size followed by block of chars).@comment{ need to specify that the string size is given as a word, and the character counts is interms of bytes} Word@\Size of code segment in words. Word@\Offset in addressing units of initialization procedure. Block@\Code segment. Word@\Size of bit table in words (redundant, could be eliminated). Block@\Bit table. @end(description) @subsection(Relocation/Bit Table) Describes how to adjust addresses and ID numbers in previous Code Segment. [Should add GENSYM generator option.] This is a block of 2 bit items, one for each \addressing unit/ in the code block.@comment{ Are we committed to two bits forever? } @begin(description) 0@\Don't relocate at this offset. 1@\Relocate the word at this offset in the code segment. 2@\Relocate the (halfword on VAX, right half on 20) at this offset. @comment[Can this be generalized some more????] 3@\Relocate the info field of the @xlisp item at this offset. @end(description) The data referred to by relocation entries in the bit table are split into tag and info fields. The tag field specifies the type of relocation to be done:@comment{ Where is this data stored??? } @begin(description) 0@\Add the code base to the info part. 1@\Replace the local ID number in the info part by its global ID number. 2@\Replace the local ID number in the info part by the location of its value cell. 3@\Replace the local ID number in the info part by the location of its function cell. @end(description) Local ID numbers begin at 2048@comment{why this magic number???}, to allow for statically allocated ID numbers (those which will be the same at compile time and load time). @subsection(Internal Functions) [IS there any special handling of these, or restrictions] @subsection(Foreign Functions, Externs, etc) [Explain why cant do in FASL now. Need to do run-time look up of LOADER symbols, and use in LAP/FASL part of things. Will need to add extra RELOC types to FASL]. @subsection(Init Code) [Explain how executable -sexpressions that are not procedure definitions are gathered into a single LISP procedure, compiled, and given name, sort of !*!*FASL-INIRTCODE!*!*, or some such. Is called as last action of LOAD. Explain current restriction on FASL initcode size, suggest soluitions] @subsection(Annotated FASL file example) @begin(verbatim) *Annotated version of a dump* procedure adder(x); begin scalar y; y:=x; return y+1; end; Dump of "trythis.b" 000000: 0020 0001 E7DF FEDF 0000 0080 0000 00A0 000010: 1800 0000 0000 0000 0000 0000 0000 0000 000020: 0000 0080 0000 0063 16#63 is the magic number which indicates that is a FASL file 0000 0003 Number of local IDs 0000 0004 The first ID, in the form Length of String, String name 000030: 4144 4445 ADDER 5200 0000 0000 0003 Second ID, 3 (+1) characters "ADD1" 4144 4431 ADD1 000040: 0000 0000 0000 0007 Third ID, 7 (+1) characters of "PUTENTRY" 5055 5445 PUTENTRY 4E54 5259 000050: 0000 0000 0000 0003 Fourth ID, 3 (+1) characters "EXPR" 4558 5052 EXPR 0000 0000 000060: 0000 000A CodeSize = 10 words 0000 000A Offset of INIT function -------------------- Code Block 2649 MOVEA.L A1,A3 2449 MOVEA.L A1,A2 4EF9 C000 JMP C000 0801 ^ Relocate Function cell (ID.1 call on "ADD1") 000070: 0801 ---------- The init code 267C 0000 0000 MOVEA.L #0,A3 247A 0010 MOVEA.L 10(pc),A2 227A 0008 MOVEA.L 8(pc),A1 000080: 4EF9 C000 0802 JMP C000 0802 ^ Relocate Function cell (ID.2 = "PUTENTRY") FE40 0800 (ID.0 the procedure ^ Relocate ID number name "ADDER") FE40 0803 (ID.3 the procedure ^ Relocate ID number type "EXPR") 0000 -------------------- Bit Table Section 000090: 0000 0003 Length of Bit table in words -------------------- Bit Table 0004 0000 : 0000 0000 0000 0100 0000 0000 0000 0000 ^ = Relocate Word 0000 040C : 0000 0000 0000 0000 0000 0100 0000 1100 Relocate Word ^ ^ Relocate Inf------------' 0C00 0000 : 0000 1100 0000 0000 0000 0000 0000 0000 ^ Relocate Inf @end(verbatim) [Explain how to use a BDUMP routine to examine this] @subsection(Binary I/O) The following functions are needed for FASLIN and FASLOUT: @i(BinaryOpenRead(Filename:string):system-channel) This should take a filename and open it so that binary input can be done. The value returned is used only by the other functions in this group, and so can be whatever is appropriate on your system. @i(BinaryOpenWrite(Filename:string):system-channel) Similar to BinaryOpenRead, open a file for binary output. @i(BinaryClose(SChn:system-channel):none returned) SChn is the value returned by BinaryOpenRead or BinaryOpenWrite. The file is closed. @i(BinaryRead(SChn:system-channel):word) One word (i.e. Lisp item sized quantity) is read from the binary file. On the Dec-20 this is done using the @i(BIN) jsys with the file opened in 36-bit mode using a 36-bit byte pointer. The VAX Unix implementation uses @i(getw) from the stdio library. @i(BinaryReadBlock(SChn:system-channel, A:word-address, S:integer):none returned) S words are read from the binary file and deposited starting at the word address A. The Dec-20 version uses the @i(SIN) jsys and VAX Unix uses the @i(fread) function. @i(BinaryWrite(SChn:system-channel, W:word):none returned) One word is written to the binary file. On the Dec-20 this is done using the @i(BOUT) jsys with the file opened in 36-bit mode using a 36-bit byte pointer. The VAX Unix implementation uses @i(putw) from the stdio library. @i(BinaryWriteBlock(SChn:system-channel, A:word-address, S:integer):none returned) S words starting at the word address A are written to the binary file. The Dec-20 version uses the @i(SOUT) jsys and VAX Unix uses the @i(fwrite) function. @i(BitTable(A:word-address, B:bit-table-offset):integer) This is similar to @i(Byte) and @i(HalfWord), except that a 2-bit unit is being extracted. A is a word address, the base of a table of 2-bit entries. The one B entries from the beginning is returned. @i(PutBitTable(A:word-address, B:bit-table-offset, I:integer):) Analagous to @i(PutByte) and @i(PutHalfWord), except that a 2-bit unit is being deposited. A is a word address, the base of a table of 2-bit entries. The low-order 2 bits of the integer I are stored at offset B. [Explain how to test Binary I/O, in test N] @subsection(Miscellaneous) To use EMODE/NMODE and PRLISP on some systems, a "raw" I/O mode may be required. See the PBIN, PBOUT, CHARSININPUTBUFFER, ECHOON and ECHOOFF functions in EMOD2:RAWIO.RED and SYSTEM-EXTRAS.RED. Some sort of system-call, fork or similar primitives are useful, clearly system dependent. See the JSYS and EXEC package on P20:, the SYSTEM call in PV:SYSTEM-EXTRAS.RED (written in C as a Foreign Function), or the SYSCALL on the APOLLO. This set is not yet standardized. |
Added psl-1983/doc/prlisp.mss version [c0a8ac753a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Device(lpt) @style(justification yes) @style(linewidth 80, spacing 1,indent 5) @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 "September 1981", Line "Operating Note 59" ) @set(page=1) @newpage() @begin(titlepage) @begin(titlebox) @b(PictureRLISP) @center[A LISP-Based Graphics Language System with Flexible Syntax and Hierarchical Data Structure by Fuh-Meei Chen, Paul R. Stay and Martin L. Griss Computer Science Department University of Utah Salt Lake City, Utah 84112 Last Revision: @value(date)] @end(titlebox) @begin(abstract) This report is a description and a users manual for PictureRLISP, a LISP based interactive graphics language. PictureRLISP has an ALGOL-like syntax, with primitives to create, manipulate and apply 3D transformations to hierachical data structures called "Models". PictureRLISP is entirely written in RLISP which is a high-level interface to Standard LISP. @end(Abstract) @begin(Researchcredit) Work supported in part by the National Science Foundation under Grant No. MCS80-07034. @end(Researchcredit) @end(titlepage) @pageheading(Left "PictureRLISP",Center "@value(date)", Right "@value(Page)" ) @set(page=1) @newpage @section<Introduction> PictureRLISP is a graphic specification language in an interactive RLISP environment. PictureRLISP usage typically consists of creating, modifying, and requesting the display of graphical objects, called "Models". A model is a three dimensional representation of the spatial, topological and graphical features of an object. Models can contain any number of primitives, which can generally be in any order. The hierarchical structure and implementation of the PictureRLISP system are designed to support both the beginning and the expert user as well. The sophisticated PictureRLISP user can utilize low level primitive operations to support customized modeling, syntax or device environments; yet the beginner need not know how to use these features. PictureRLISP is a re-implementation of an earlier system, PICTUREBALM@cite[Goates80], with a number of additions. The major improvement is that the entire system is now written in RLISP, including the low-level clipping and transformation routines. RLISP is an ALGOL-like interface to LISP, found more convenient to use by many people. The extensible, table-driven RLISP parser itself is written in LISP, permitting rapid syntactice customization. The version of RLISP used for PictureRLISP is built upon PSL@cite[Griss81,Griss82b], an efficient, portable and interactive LISP system. PSL provides rich data structures, dynamic storage management, and an efficient LISP to machine code compiler@cite[Griss79b], which makes PSL-based PictureRLISP much more efficient than the previous PictureBALM system. A complete PSL currently runs on DECSystem-20, VAX-11/750 under UNIX. A preliminary PSL now runs on an Apollo DOMAIN (a Motorola MC68000-based personal machine with high-resolution graphics). PictureRLISP is capable of driving a number of different graphic output devices, and is fairly easy to extend to others. The current devices that built-in PictureRLISP drivers support include: Tektronix 4010 (and 'clones, such as ADM3a with retrographics board, Apollo Tektronix emulator,etc.); Hewlett-Packard HP2648a; Evans and Sutherland MPS-1; AED-512 color terminal; and "checkout" graphics on low-resolution devices such as 60 x 80 Ann-Arbor Ambassador, or 24 x 80 Teleray-1061 or VT100. PictureRLISP has also been extended to run under EMODE@cite[Galway82], an interactive LISP-based, full-screen editor which is similar to EMACS. EMODE runs within the PSL environment, and permits the editing of PictureRLISP commands and procedures, and then immediate execution from within the editing window. One can also define graphics windows to display the models presented. @section(Basic concepts) @subsection(Models) PictureRLISP usage typically consists of creating, modifying, and requesting the display of graphical objects, called "Models". A Model is a three dimensional representation of the spatial, topological and graphical features of an object. Models can contain any number of primitives, which can generally be in any order. PictureRLISP Model primitives include: Point Sets, which might be interpreted as polygons, connected line segments, curve control points, etc.; transformations of objects or coordinate systems in three dimensional space; color or appearance attributes; Repeat Specifications, which cause sub-sections of the Model to be replicated; named references to other Models to be displayed as if they were part of the current Model; and procedure calls. Allowing Models to contain references to other Models facilitates dynamic displays and allows the user to structure his data in Clusters in a meaningful manner. Sub-Models may be shared among a number of Models. Allowing procedure calls to be imbedded within Models provides the user with a mechanism which can easily effect arbitrary displays, transformations, parameterized models or other functions that may be required by a specific application; in some cases, it is essential to represent objects by algorithms or procedural models. @subsection<Coordinate systems, Viewport> [ *** This section needs more work ****] Currently, each device supported by has its own "screen" coordinates, and the user has to think of his model sizes in a device specific fashion. This is a defect, and we are planning to change the basic system so that each device driver will normalize coordiates so that a square of side N world-coordinates (or M inches?) will map onto the physical screen, with a square aspect ratio. Clipping of objects outside this square (cube) and exact placement of the square will be controlled by default settings of the View Port and a Global transformation matrix. Since both view port and global transformation (for perspective and scaling) are adjustable, the idea will be to provide a more natural default. Perhaps two or three sets of defualts are desirable, selectable by the user: A device independant WORLD view, a semi-device independant PHYSICAL size and a very device specific SCREEN view. @subsection<Example of PictureRLISP> As a small example of the flavor of PictureRLISP, the following commands will display a set of BOX's of different sizes, after suitable device initialization: @begin(verbatim) BOX := {0,0}_{0,10}_{10,10}_{10,0}_{0,0}; % Assigns to BOX a set of connected points for 10*10 box SHOW BOX & BOX | ZROT(45) & BOX | SCALE(2); % Display 3 boxes, the original, a rotated box, and % a 20 * 20 box. The & collects a set of unconnected models % and | attaches a transformation (matrix) @end(verbatim) @section(Specification of the PictureRLISP Language) PictureRLISP supports the creation and manipulation of Models both by means of built-in procedures for the various primitives (points, pointsets, and groups) and by means of syntactic extensions, i.e. operators which construct Models out of primitives. PictureRLISP contains five operators designed to make graphics programs easy to read and write. They are denoted by the following special characters: {, }, _, & and |, and map to an appropriate set of Lisp procedures. The following is the set of legal Model primitives: @begin(enumerate) @u(Point.) Points are constructed by using curly brackets, or by the function POINT(x,y,z,w), e.g. {x,y} [denotes the point (x, y, 0) in three dimensional space]. Points can be described by any one of four ways. A single value on the x axis, a two dimensional point, a three dimensional point or in homogeneous coordinate space. @u(Pointset.) The function POINTSET(p,q,..s) or the infix "_" operator is used to make Point Sets; e.g. it can be used to make polygons out of Points. For example, the usual graphical interpretation of the sequence A@ _@ B@ _@ C, where A, B, and C are Points, moves the display beam to the point represented by A, draws to B, and then draws to C. @u(Group) A Group is a set of Point Sets or Points and is formed by the infix operator & or the function GROUP(ps1,ps2,...psN). Thus models may be grouped together and formed into larger models for reference. @u(Point Set Modifiers.) Point Set Modifiers alter the interpretation of any Point Sets within their scope. The curved Point Set Modifier BEZIER() causes the points to be interpreted as the specification points for a BEZIER curve. The BEZIER curve has as its end points the endpoints of the control polygon. BSPLINE() does the same for a closed Bspline curve. If a control polygon is not closed then then algorithm will create a closed polygon by assuming there is a line segment between the endpoints. In order to get these curves a pointset acting as control points need to be given. Even though the control points may not be closed for a BSPLINE curve the system will close the polygon to form a closed BSPLINE curve. Another modifier is that of COLOR() where on color drawing systems different color values can be given to the model. @u(Transforms.) Transforms are the Model primitives which correspond to transformations of objects or coordinate systems in three dimensional space. PictureRLISP supports rotation, translation, scaling, perspective transformation and clipping. The Transform primitives are: @begin<enumerate> Translation: Move the specified amount along the specified axis. @*XMOVE (deltaX) ; YMOVE (deltaY) ; ZMOVE (deltaZ) @*MOVE (deltaX, deltaY, deltaZ) @blankspace(1 line) These Transforms are implemented as procedures which return a transformation matrix as their value. Scale : Scale the Model SCALE (factor) @*XSCALE (factor) ; YSCALE (factor) ; ZSCALE (factor) @*SCALE1 (x.scale.factor, y.scale.factor, z.scale.factor) @*SCALE <Scale factor>. Scale along all axes. @blankspace(1 line) These Transforms are implemented as a transformation matrix which will scale Models by the specified factors, either uniformly or along only one dimension. Rotation: Rotate the Model @*ROT (degrees) ; ROT (degrees, point.specifying.axis) @*XROT (degrees) ; YROT (degrees) ; ZROT (degrees) @blankspace(1 line) These procedures return a matrix which will rotate Models about the axis specified. Currently rotation are limited to being about the three coordinate axes, though one would like to be able to specify an arbitrary rotation axis. WINDOW (z.eye,z.screen): The WINDOW primitive assumes that the viewer is located along the z axis looking in the positive z direction, and that the viewing window is to be centered on both the x and y axis. The window function is used to show perspective for models and the default window at initialization of the device is set with the eye at -300 and with the screen at 60. If one wish to use a right handed coordinate system then the eye is in the positive direction. VWPORT(leftclip,rightclip,topclip,bottomclip): The VWPORT, which specifies the region of the screen which is used for display. This is set to a convenient default at the time a device is initialized by the device drivers. @end<enumerate> @u(Repeat Specifications.) This primitive provides the user with a means of replicating a section of a Model any number of times as modified by an arbitrary Transform, e.g. in different positions. The primitive is called REPEATED (number.of.times, my.transform), where number.of.times is an integer. The section of the Model which is contained within the scope of the Repeat Specification is replicated. Note that REPEATED is intended to duplicate a sub-image in several different places on the screen; it was not designed for animation. @u(Identifiers of other Models.) When an identifier is encountered, the Model referenced is displayed as if it were part of the current Model. Allowing Models to contain identifiers of other Models greatly facilitates dynamic displays. @u(Calls to PictureRLISP Procedures.) This Model primitive allows procedure calls to be imbedded within Models. When the Model interpreter reaches the procedure identifier it calls it, passing it the portion of the Model below the procedure as an argument. The current transformation matrix and the current pen position are available to such procedures as the values of the global identifiers GLOBAL!.TRANSFORM and HEREPOINT. This primitive provides the user with a mechanism which can be used to easily effect arbitrary displays, transformations, functions or models required by a specific application. The value of the procedure upon its return is assumed to be a legal Model and is SHOW'n; PictureRLISP uses syntax to distinguish between calling a procedure at Model-building time and imbedding the procedure in the Model to be called at SHOW time; if normal procedure call syntax, i.e. proc.name@ (parameters), is used then the procedure is called at Model-building time, but if only the procedure's identifier is used then the procedure is imbedded in the Model. @u(Global Variables) There are a number of important global variables in PictureRLISP whose meaning should be aware of, and which should be avoided by the user, unless understood: @begin<description> @u<Globals>@\@u<Meaning> HEREPOINT@\Current cursor position as a 4-vector. HERE@\Current cursor position as a '(POINT x y z) ORIGIN@\The vector [0,0,0,1]. GLOBAL!.TRANSFORM@\A global transform specified by the user, which is applied to everything as the "last" transformation. A default is set in the Device initializtion, but can be changed by user as convenient. MAT!*1@\Unit 4 x 4 transformation matrix. MAT!*0@\Zero 4 x 4 transformation matrix. DEV!.@\Name of the current device, for device dependent code. CURRENT!.TRANSFORM@\The current (cumulative) transformation matrix. All points are transformed by this before a move or draw. Initialized to GLOBAL!.TRANSFORM before each Display. CURRENT!.LINE@\The current Pointset modifier, can be 'BEZIER, 'BSPLINE or the default straight line modifier 'LINE. !*EMODE@\Tells the system and or user if PictureRlisp is in EMODE status. @end(description) @end(enumerate) @newpage The following is a BNF-like description of the set of legal Models. The meta-symbols used are ::= for "is a" and | for "or". Capitalized tokens are non-terminal symbols of the grammar of Models, a usage that is adhered to in the text of this report. Upper case tokens are PictureRLISP reserved words, which have been defined as RLISP procedures, operators and/or macros. Lower case tokens can be either numbers or identifiers, but not quoted number identifiers, except for "string" which denotes either a RLISP item of type string or a string identifier. @begin(verbatim) <Model> ::= NIL | <Simple Model> | <Model> & <Model> <Simple Model> | <Model Object> | ( <Model> ) | <Model> | <Model Modifier> | <Model Identifier> | '<Model Identifier> <Model Object> ::= NIL | <Point Set> | <Model Object Identifier> | '<Model Object Identifier> <Model Modifier> ::= NIL | <Transform> | <Point Set Modifier> <Transform> ::= XROT (degrees) | YROT (degrees) | ZROT (degrees) | XMOVE (deltaX) | YMOVE (deltaY) | ZMOVE (deltaZ) | MOVE (xdelta, ydelta, zdelta) | SCALE (factor) | XSCALE (factor) | YSCALE (factor)| ZSCALE(factor) | SCALE (x.factor, y.factor, z.factor) | WINDOW (z.eye,z.screen) | <Transform Identifier> | ' <Transform Identifier> Repeat Specification ::= REPEATED (number!.of!.times, Transform) <Point Set Modifier> ::= | BEZIER() | BSPLINE() | CIRCLE(r) | COLOR(value) <Point Set> ::= <Point> | <Point> _ <Point Set> | <Point Set Identifier> | '<Point Set Identifier> <Point> ::= {x} | {x, y} | {x, y, z} | {x,y,z,w} | Point Identifier | ' Point Identifier @end(verbatim) @section<Basic PictureRLISP Procedures> It should be emphasized that the typical user of the PictureRLISP language need never use some of these primitives directly, nor need he even know of their existence. They are called by the procedures which are written in RLISP which implement the standard PictureRLISP user functions. Nevertheless, they are available for the sophisticated user who can utilize them to implement a customized language environment. Also, they might serve as an example of the primitives that a PictureRLISP implementor would want to add to support other devices. @subsection(Common Functions) @begin<description> @b<ERASE()>@\Clears the screen and leaves the cursor at the origin. @b<SHOW (pict)>@\Takes a picture and display it on the screen @b<ESHOW (pict)>@\Erases the whole screen and display "pict" @b<HP!.INIT()>@\Initializes the operating system's (TOPS-20) view of the characteristics of HP2648A terminal. @b<TEK!.INIT()>@\Initializes the operating system's (TOPS-20) view of the characteristics of TEKTRONIX 4006-1 terminal and also ADM-3A with Retrographics board. @b<TEL!.INIT()>@\Initializes the operating system's (TOPS-20) view of the graphics characteristics of the Teleray 1061 terminal. This is rather crude graphics, on a 24*80 grid, using the character X. Nevertheless, it provides a reasonable preview. @b<MPS!.INIT()>@\Initializes the operating system's (UNIX) on the vax to handle the MPS commands. (currently on the VAX). @b<ST!.INIT()>@\Initializes the operating system's view of the characteristics of the Apollo workstation (a 68000 based system hooked up to the DEC 20 or Vax), emulating a TekTronix 4006 and VT-52 simultaneously in multiple windows. @b<AED!.INIT()>@\Initializes the operating system's view of the graphics color device AED-512 a 4006 tektronix color system. @end(Description) @subsection(Low Level Driver Functions) Most of these are "generic" names for the device specific procedures to do basic drawing, moving, erasing etc. The initialization routine for device XX, called XX!.INIT() above, copies the routines, usually called XX!.YYYY into the generic names YYYYY. @begin(description) @b<ERASES()>@\Erase the Graphics Screen @B<GRAPHON()>@\Called by SHOW, ESHOW and ERASE() to put the device into graphics mode. May have to turn off normal terminal ECHO, using ECHOOFF(), unless running under EMODE. @b<GRAPHOFF()>@\Called by SHOW, ESHOW and ERASE() to put the device back into text mode. May have to turn normal terminal ECHO back on, using ECHOON(), unless running under EMODE. @b<MOVES (x, y)>@\Moves the graphics cursor to the point (x, y) where x and y are specified in coordinates. These coordinates will be converted to absolute location on the screen allowing different devices to display the same models whether they have the same coordinate systems internaly or not. @b<DRAWS (x, y)>@\Draws a line from the current cursor position to the point specified in screen space. @end(description) @subsection(Low Level Matrix Operations) @begin(description) @b<MAT!*MAT (new!.transform, current!.transform)>@\This procedure is passed two transformation matrices. Each matrix is represented by a 16 element vector of floating point or interger numbers. They are concatenated via matrix multiplication and returned as the new value of current transform. @b<PNT!*PNT(point!.1,point!.2)>@\This procedure is passed two 4-vector matrices, a value is returned. @b<PNT!*MAT(point,transformation)>@\This is passed 4-vector and a 4 by 4 matrix, and returns a new (transformed) point. @end<description> @section<Internal Representations of PictureRLISP Graphical Objects> In the LISP-like internal form, Points and Transforms are represented by 4 vectors (homogeneous coordinates, also assuming the model has been placed on w=1.0 plane) and 16 element vectors respectively. Other Model primitives are represented as operators in LISP S-expressions of the form "(operator arg1 arg2... argN)". Points and matrices can also be represented as S-expression operators, if this is desirable for increased flexibility. It will be helpful for the PictureRLISP user to know what the meaning of the interpreted form is in terms of the PictureRLISP parsed form. The operator is some meaningful token, such as POINT, TRANSFORM, POINTSET or GROUP; e.g. GROUP is the representation of the user level operator "&". The operator is used as a software interpreter label, which makes this implementation of a PictureRLISP interpreter easy to extend. Here is the table to show the external and corresponding internal forms for some basic PictureRLISP operators. @begin <verbatim> @u[Internal Form] @u[External Form] @u[Result on Draw] (POINT x y z ) {x,y,z} [x,y,z,w] (POINTSET a b c d) a_b_c_d move to a, then connect b, c, and d. (GROUP (pointset a b a_b_c_d & e do each pointset in c d) e) turn. (TRANSFORM f g) f | g apply the transform g to the picture f. (TRANSFORM point point | draws a circle with (CIRCLE radius)) CIRCLE(radius) radius specified about the center "point". (TRANSFORM pict pict | draws Bezier curve for (BEZIER) BEZIER() "pict". (TRANSFORM pict pict | same as (pict |BEZIER()) (BSPLINE) BSPLINE() but drawing Bspline curve. (TRANSFORM pict pict | REPEATED the "pict" is replicated (REPEATED (count,trans) "count" times as modified count trans )) by the specified transform "trans". For example, the Model @end<verbatim> @begin(display) (A _ B _ C & {1,2} _ B) | XROT (30) | 'TRAN ; maps to the LISP form: (TRANSFORM (TRANSFORM (GROUP (POINTSET A B C) (POINTSET (POINT 1 2) B)) (XROT 30)) (QUOTE TRAN)) @end(display) These structures give a natural hierachical structure as well as scope rules to PictureRLISP. @section<How to run PictureRLISP> Models can be built using any number of primitives and transformations and assigned to model ID's. Once a model is defined and the device has been choosen then the object can be drawn on the graphics device by using the commands Show and Eshow, both of which will display the model or object on the graphics device and the difference being that Eshow will first erase the screen. To erase the screen one can issue the command Erase() and all models and object will be erased from the screen. Unfortunately one cannot erase individual objects from the display device. The following section will give an idea on other aspects of running PictureRLISP by example. @section<Examples of PictureRLISP Commands> In the following examples, anything following a % on the same line is a comment. Rlisp expressions (or commands) are terminated with a semicolon. It is suggested that you execute these examples while executing PictureRLISP at one of the terminals to see the correct response one would get. Most of these are located in the file <stay.pict>exp.red on the DecSystem 20 at Utah and is supplied with the release of PictureRLISP. @begin(verbatim) % % PictureRLISP Commands to SHOW lots of Cubes % % Outline is a Point Set defining the 20 by 20 % square which will be part of the Cubeface % Outline := { 10, 10} _ {-10, 10} _ {-10,-10} _ { 10,-10} _ {10, 10}; % Cubeface will also have an Arrow on it % Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}; % We are ready for the Cubeface Cubeface := (Outline & Arrow) | 'Tranz; % Note the use of static clustering to keep objects % meaningful as well as the quoted Cluster % to the as yet undefined transformation Tranz, % which will result in its evaluation being % deferred until SHOW time % and now define the Cube Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90); % In order to have a more pleasant look at % the picture shown on the screen we magnify % cube by 5 times. BigCube := Cube | SCALE 5; % Set up initial Z Transform for each cube face % Tranz := ZMOVE (10); % 10 units out % Now draw cube % SHOW BigCube; @blankspace(4 inches) % Draw it again rotated and moved left % SHOW (BigCube | XROT 20 | YROT 30 | ZROT 10); @blankspace(4 inches) % Dynamically expand the faces out % Tranz := ZMOVE 12; % SHOW (BigCube | YROT 30 | ZROT 10); @blankspace(4inches) % Now show 5 cubes, each moved further right by 80 % Tranz := ZMOVE 10; % SHOW (Cube | SCALE 2.5 | XMOVE (-240) | REPEATED(5, XMOVE 80)); @blankspace(4 inches) % % Now try pointset modifier. % Given a pointset (polygon) as control points either a BEZIER or a % BSPLINE curve can be drawn. % Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ % % Now draw Bezier curve % Show the polygon and the Bezier curve % SHOW (Cpts & Cpts | BEZIER()); @blankspace(4 inches) % Now draw Bspline curve % Show the polygon and the Bspline curve % SHOW (Cpts & Cpts | BSPLINE()); @blankspace(4inches) % Now work on the Circle % Given a center position and a radius a circle will be drawn % SHOW ( {10,10} | CIRCLE(50)); @blankspace(3inches) % Define a procedure which returns a model of % a Cube when passed the face to be used % Symbolic Procedure Buildcube; List 'Buildcube; % put the name onto the property list Put('buildcube, 'pbintrp, 'Dobuildcube); Symbolic Procedure Dobuildcube Face$ Face & Face | XROT(180) & Face | YROT(90) & Face | YROT(-90) & Face | XROT(90) & Face | XROT(-90) ; % just return the value of the one statement % Use this procedure to display 2 cubes, with and % without the Arrow - first do it by calling % Buildcube at time the Model is built % P := Cubeface | Buildcube() | XMOVE(-15) & (Outline | 'Tranz) | Buildcube() | XMOVE 15; % SHOW (P | SCALE 5); @blankspace(4inches) % Now define a procedure which returns a Model of % a cube when passed the half size parameter Symbolic Procedure CubeModel; List 'CubeModel; %put the name onto the property list Put('CubeModel,'Pbintrp, 'DoCubeModel); Symbolic Procedure DoCubeModel HSize; << if idp HSize then HSize := eval HSize$ { HSize, HSize, HSize} _ {-HSize, HSize, HSize} _ {-HSize, -HSize, HSize} _ { HSize, -HSize, HSize} _ { HSize, HSize, HSize} _ { HSize, HSize, -HSize} _ {-HSize, HSize, -HSize} _ {-HSize, -HSize, -HSize} _ { HSize, -HSize, -HSize} _ { HSize, HSize, -HSize} & {-HSize, HSize, -HSize} _ {-HSize, HSize, HSize} & {-HSize, -HSize, -HSize} _ {-HSize, -HSize, HSize} & { HSize, -HSize, -HSize} _ { HSize, -HSize, HSize} >>; % Imbed the parameterized cube in some Models % His!.cube := 'His!.size | CubeModel(); Her!.cube := 'Her!.size | CubeModel(); R := His!.cube | XMOVE (60) & Her!.cube | XMOVE (-60) ; % Set up some sizes and SHOW them His!.size := 50; Her!.size := 30; % SHOW R ; @blankspace(4inches) % % Set up some different sizes and SHOW them again % His!.size := 35; Her!.size := 60; % SHOW R; @blankspace(4inches) @end<verbatim> @section<How to run PictureRLISP on the various devices> The current version of PictureRLISP runs on a number of devices at the University of Utah. PictureRLISP source is in PU:PRLISP.RED, and the device driver library is in the file PU:PRLISP-DRIVERS.RED. These files, compiled into the binary LOAD form are PRLISP-1.B and PRLISP-2.B. Both are automatically loaded if the user invokes LOAD PRLISP; from PSL:RLISP (see PSL documentation for implementation and usage of the loader). The following contains information concerning the generic form of a device driver, and the execution of PictureRLISP under PSL. PictureRLISP is such that device drivers can be written for what ever device you are using for a graphics display device. @subsection<Generic Device Driver> The following is an example of an xxx device driver and its associated routines. The main routines of the driver may be divided into three areas: low level I/O, basic graphics primitives (eg. move, draw, viewport etc.), and the setup routine. @begin(verbatim) %*************************** % setup functions for * % terminal devices * %*************************** % FNCOPY(NewName,OldName) is used to copy equivalent a % device specific function (e.g. xxx-Draws) into the generic % procedure name % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % xxx specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % device low level routines to drive the escape sequences for % a graphics device. These output procedures will send the various % codes to the device to perform the desired generic function Procedure xxx!.OutChar x; %. RawTerminal I/o Pbout x; Procedure xxx!.EraseS(); %. EraseS screen, Returns terminal <<xxx!.OutChar Char ESC; %. to Alpha mode and places cursor. xxx!.OutChar Char FF>>; % The following procedures are used to simulate the tektronix % interface for picturerlisp and are considered the graphics % primitives to emulate the system. Procedure xxx!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << xxx!.OutChar HIGHERY NormY YDEST$ %. information to the xxx!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte xxx!.OutChar HIGHERX NormX XDEST$ %. sequences containing the xxx!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure xxx!.MoveS(XDEST,YDEST)$ <<xxx!.OutChar 29 $ %. GS: sets terminal to Graphic mode. xxx!.4BYTES (XDEST,YDEST)$ xxx!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure xxx!.DrawS (XDEST,YDEST)$ %. Same as xxx!.MoveS but << xxx!.OutChar 29$ %. draw the line. xxx!.4BYTES (CAR2 HERE, CAR3 HERE)$ xxx!.4BYTES (XDEST, YDEST)$ xxx!.OutChar 31>> $ Procedure xxx!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure xxx!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure xxx!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. the display device X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure xxx!.Delay(); %. some devices may need a NIL; %. delay to flush the buffer output Procedure xxx!.GRAPHON(); %. set the device in graph mode If not !*emode then echooff(); Procedure xxx!.GRAPHOFF(); %. Take the device out of graphics mode If not !*emode then echoon(); Procedure xxx!.INIT$ %. Initialization of device specIfic Begin %. Procedures equivalent. PRINT "XXX IS DEVICE"$ DEV!. := ' XXX; FNCOPY( 'EraseS, 'xxx!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'xxx!.NormX)$ % initialization when using FNCOPY( 'NormY, 'xxx!.NormY)$ % xxx as the device FNCOPY( 'MoveS, 'xxx!.MoveS)$ FNCOPY( 'DrawS, 'xxx!.DrawS)$ FNCOPY( 'VWPORT, 'xxx!.VWPORT)$ FNCOPY( 'Delay, 'xxx!.Delay)$ FNCOPY( 'GraphOn, 'xxx!.GraphOn)$ FNCOPY( 'GraphOff, 'xxx!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ @end(verbatim) The following is a sample session of PSL:Rlisp initializing the device xxx. @begin(verbatim) @@psl:rlisp *PSL 3.0 Rlisp, 9-May-1982 *[1] load prlisp; % The system types the [1] prompt *[2] xxx.init(); @end(verbatim) The system is now ready for pictureRlisp use, and one could then load in any other routines for their application. It should be noted that a number of devices can be loaded into the system but presently only one is the current display device at any given time. The following are specifics on each of the devices currently being used in PictureRlisp. The coordinate systems mentioned are device coordianates and should be transparent to the user. @subsection<Hp terminal 2648A> The screen of the HP terminal is 720 units long in the X direction, and 360 units high in the Y direction. The coordinate system used in HP terminal places the origin in approximately the center of the screen, and uses a domain of -360 to 360 and a range of -180 to 180. The procedure HP!.INIT() will load in the functions used for the HP terminal. @subsection<Tektronix terminal> Similarly, the screen of the TEKTRONIX 4006 and 4010 terminala are 1024 units long in the X direction, and 780 units high in the Y direction. The same origin is used but the domain is -512 to 512 in the X direction and the range is -390 to 390 in the Y direction. TEK!.INIT() will initialize the tektronix device for displayable graphics. @subsection<Apollo work station> Currently the APOLLO DOMAIN can work station is being used as a terminal to the Decsystem 20, using the ST program on the Apollo. The screen is split into 2 windows, on of 24*80 lines, emulating a Teleray 1061, and the other a 400 * 700 tektronix likes graphics terminal. ST!.INIT() is used for initializing the commands for the apollo. @subsection<Teleray Terminal> The teleray terminal can only display characters on the screen. It can be used as a "rapid-checkout" device, by drawing all lines as a sequence of x's. To initialize the teleray the command TEL!.INIT() will setup the graphics device to be the teleray terminal. This gives a 24 * 80 resolution. @subsection<Ann Arbaor Ambassador Terminal> The teleray terminal can only display characters on the screen. It can be used as a "rapid-checkout" device, by drawing all lines as a sequence of x's. To initialize the teleray the command TEL!.INIT() will setup the graphics device to be the teleray terminal. This gives a 60 * 80 resolution. @subsection<Evans and Sutherland Multi Picture System> Currently, the MPS can be driven on the gr-vax at the University of Utah and is an example of a high level graphics device being driven by PictureRLISP. Thus it may be interesting to look at the device driver for the mps to get the feel for how PictureRLISP drives high level graphics devices. The initialization is done by calling the procedure MPS!.INIT(). [???? add the other devices such as the AED, ADM3a+Retro ???] @section<Future Work> PictureRLISP currently uses a large number of vectors, regenerating points at the very lowest level. Since all Clipping and transformation is done in LISP, using vectors. This results in very frequent garbage collection, a time-consuming and expensive process. On the DEC-20, a grabage takes about 2.5 secs. On the VAX, GC is only 1 second, and happens much less frequently. It is planned to optimize this lower level. Perhaps this could be fixed by using a number of fluid point vectors as the only points which exist as vectors. Since all devices currently defined in PRLISP-DRIVERS.RED use a standard tektronix interface it becomes impossible under the current version to use some features that the devices have defined in hardware. For instance the MPS system has bult in clipping, viewport and windowing functions all defined in hardeware as well as 3-d display. At this point it is impossible for one to use the full features offered by the mps and it seems that it would be nice if one could use some of these features. @section(References) @bibliography() |
Added psl-1983/doc/psl-projects.doc version [29008314be].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Utah Symbolic Computation Group May 1981 Operating Note No. 56 Portable Standard LISP Project List by M. L. Griss University of Utah Salt Lake City, UT 84112 Last Revision: 2 November 1981 ABSTRACT This note lists "projects" that need to be done to complete or enhance the developing Portable Standard LISP System. This includes additions or modifications to the basic sources, applications of the system and tools, and primitive facility development on newer target machines. Work supported in part by the National Science Foundation under Grant No. MCS80-07034. PSL Projects 2 1. Introduction This note is a guide to the current set of Projects that need to be completed to enhance the developing versions of Portable Standard LISP (PSL); the current versions are referred to as F-STDLSP and 20-STDLSP. For convenience, F-STDLSP is referred to as FSL and 20-STDLSP is referred to as 20SL, and these are names used in files. The projects divide into 3 major areas: Basic PSL development and portability; PSL Applications and Tools; Support of PSL development on newer machines. 2. Miscellaneous Small Enhancements and "Bugs" a. We need a way of accessing LISP function with same name as SYSLISP name [eg PLUS2] from SYSLISP, or causing better SYSLISP/LISP renaming (cf SYSNAME); should use MODE-REDUCE (similar to LISPVAR usage in SYSLISP) [Morrison?]; b. Document ERRORFORM!* and BREAKRETRY, make more ERRORs use ERRORFORM!*; make ERRORFORM!* a fluid in appropriate places; c. Have allocator functions call ERROR mechanism when no heap or GC left, so that maybe unwind can release space; also maybe have %RECLAIM have user hook per type so that user can monitor individual type usage. How do we handle problem that ERROR uses some heap?; d. Tighten BUILDING sequence, isolate a SYSLISP that can be run as a stand-alone language, with a minimum number of support functions; document CLEARLY, with a more formal specification of SYSLISP; e. Isolate machine dependant code in earliest files, reorder rest of functions with an eye to having just allocator, I/O and Fast-load in base files, rest of LISP loaded onto this kernel by FASL [mostly done, needs a FAP before further effort]; f. Add BIGNUM hooks, and rework BIGNUMs to use more effective storage model; [Standard LISP source exists and has been tested interpretively and compiled in the current STDLISP environment; low- level hooks not yet in; probably should use WORD vectors in place of lists]; add some of the BIGBIT operations that were used in Minor work; g. Permit Compiled and Interp NEXPRs. Consider LEXPRs. Perhaps a macro package for N-ary functions. Perhaps examine an argument number checking technique suggested by C. Griss: each call or definition of a function with N-args, leans to use of a generated name, Foo-N; this is really of the same level as treatment of FEXPR and MACRO types in Standard Lisp: intead of FEXPRs, MACROs, and EXPRs, we have FEXPRs, MACROs, EXPR0s, EXPR1s, EXPR2s...EXPRns; h. Try to SYSLISP with primitives so that EVAL-APPLY-LAP support code can be written in SYSLISP. Probably need LEXPR or stack local PSL Projects 3 arrays. May involve "hard" compiler additons; i. Optimize ARITHMETIC package, use SMACROs in place of PROCEDUREs to get better speed on small INTs. Examine re-assigment of TAG bits to optimize arithmetic dispatch; j. Use macros to make certain calls of ARITH in system functions more efficient; interface to Type'ing of MODE-RLISP. 3. I/O a. Arbitray long input strings; b. Bignum Parse/Print; c. BINARY I/O for .FAP/.REL; d. Packages (multi-symbol tables) interfaced as tree structured HASH tables for Intern, invoked by Hook in I/O; e. Implement Multi-Window Package (FRAMER), hooks to I/O; f. Provide primitives for READ-TABLE switching; g. Implement super PARENs (see NUREAD.RED by MLG, not in current system); 3.1. Interrupts Design better Interrupt Mechanism, decide how much control user should have; perhaps only available to terminate various kinds of run-ways. Implement a semi-portable interrupt machanism. We should probably look at what's available on the most likely targets (Tops-20, Unix, VMS?, perhaps bare hardware on some micros), and try to extract some common denominator (not necessarily the LCD though -- if an OS doesn't offer anything reasonable, then just bag interrupts for that implementation and be done with it). The current implementation does not allow arbitrary lisp code to be run from an interrupt, and then resumption, as a GC will lose anything pointed at only from registers. There are two ways to rectify this "defect": a. Go to a stack model for compiled code. I believe this would be a mistake. One of the major virtues of the current model is the excellent speed of compiled code. This is in large part due to the register model used. For my applications, at least, I would prefer the availability of raw speed, when desired, over arbitrary interrupts. As noted below, I believe we still have sufficient power in the interrupts available in the current model. b. Partition the registers into tagged and untagged registers, and modify the compiler so that any tagged object WHICH LIVES ONLY IN A PSL Projects 4 REGISTER is in a tagged register. Note that the compiler may leave tagged objects in an untagged register, which is OK so long as it knows that another pointer to the same object lives on the stack or in a value cell; however, the relocating GC can have problems, and we need to go to a 2 stack model. A problem this may introduce in the SysLisp version is parameter passing -- we may need two different function linkage mechanisms -- one for tagged and one for untagged objects. It may be possible to have the number of registers of each type vary dynamically. Because of the tremendous increase in complexity introduced by register partitioning, this would be difficult, but probably should be faced. I think we can live with a restricted interrupt mechanism. A fixed set of conditions would exist, together with a collection of possible actions. The user would be able to assign one of these (limited) actions to a condition. The set of conditions would of necessity be somewhat machine dependent. Hopefully a somewhat machine-independent subset could be made common to most inplementations. This subset might include a number of terminal keys, various "standard" error conditions such as I/O errors, and an alarm clock. The set of actions would include: a. Various carefully coded SysLisp routines intended for specific sorts of conditions, such as an arithmetic overflow causing a bignum package to be entered. These would be carefully coded so as to allow resumption of the computation. This could also include things such as a Tops-20 style ^T, or a quit back to the Exec. b. Execute a given, arbitrary piece of Lisp code, and then throw to a given tag. This could be used to generate an Error, enter a breakloop to examine an infinite loop (and then return to top- level), abort a computation and return to top-level (the code run on top of the stack could set a hook to be run upon return to top-level or whatever, as well), etc. This depends on the implementation of Catch and Throw causing everything needed for the surrounding context to be saved on the stack, and will require Throw to do some of its work with interrupts disabled, before returning to CATCH. Need to consider ARMING/DISARMING. c. Set a flag for the interpreter, and then resume the computation. Then, when the interpreter is next entered, an arbitrary piece of Lisp code is run, and the interpreter can resume after this "delayed" interrupt is handled. Should be able to do this kind of delayed interrupt in general. Note that the interrupt status must be altered upon entering the GC. We cannot run Lisp code during a GC, so actions of the second sort, above, must be deferred until after the GC. A number of those in class (1), above, may also need to be deferred. Note that it is the actions which must change during a GC, not the conditions. PSL Projects 5 A possible collection of Lisp functions as user entry points to such a mechanism are: (InitializeInterrupts) I'm not sure if this is needed at the user level, or if it should just always happen as part of the Lisp startup procedure. (EnableInterrupts) (DisableInterrupts) (SetInterrupt <condition> <action>) where <condition> is some appropriate keyword (an ID) such as 'ControlT, or 'StackOverflow, and <action> is either an appropriate keyword such as 'QuitToExec, 'QuitToTopLevel, or 'PrintStatistics, or is a list such as '(InterpreterInterupt (print "This is an interpreter interupt")) or '(ThrownInterupt (print "Now we'll throw to ErrorSet") '!$Error!$). Note that the function SetInterrupt is responsible for checking its arguments. (RemoveInterrupt <condition>) 4. Storage Management a. Explore a variety of alternative Storage Management schemes: BIBOP, COPYING; b. Consider improved garbage collector/allocator, using AREAS, BIBOP or some such; at least get SYSLISP items on non-traced stack (or stack region); maybe have SYSLISP stack group; use bit-table rather than RELOC fields, to permit extended addressing code to be run, use more of word. Look at ELISP copying GC. c. Consider collecting or relocating compiled code blocks, IDs and/or GENSYMs; 5. New Machine Implementations a. Bring up an extended addressing DEC-20 Standard LISP, using essentially the same c-macros, and some additional kernel code (developed at Rutgers for an extended addressing R/UCI LISP on the DEC-20 by C. Hedrick). b. Small Pointer DEC-20 with BIBOP and/or Bit-table for 18 bit pointers; c. Implement SYSLISP and PSL on PDP-11/45, as support for some of CAGD tools - probably obselete ?; d. Implement SYSLISP and PSL on VAX-750; PSL Projects 6 e. Implement SYSLISP and PSL on M68000 [Apollo and Wicat]; f. Implement SYSLISP and PSL for Z80; g. Re-implement FORTRAN version to check validity; move to CRAY; try more "genuine" FORTRAN version; consider FORTRAN bootstrap; consider PASLSP or KISLSP as bootstrap aid; 6. PASCAL like languages ADA, C and PASCAL versions, continuing from TERAK experiments; do some LILITH experiments [MODULA]. Major effort is current PASLSP on PERQ, Apollo and Wicat. Later move PASLSP more into a SYSLISP to PASCAL. a. Continue parameterizing (using # filter) 20, Terak, PERQ and Apollo features; tighten source code, improve I/O; look at other PASCAL LISPs; b. Modularize so can be come "Library" for embedded systems (INS file on Apollo, or MODULE for PERQ); c. Extend GC for FIXNUM's, Strings and maybe vectors; 7. Support work on Apollo 7.1. Initial Experiments a. Test LTNET. b. Finish implementation of FTP (stream-IO back to 20, ratfor I/O on 20); c. Should WICAT ftp to/from DOMAIN-net for shared printer? d. Establish back-up command files, and save system on floppies. e. Print and duplicate interesting HELP, DOC and INS files. f. Test some simple assembly code; g. Try BCPL and C cross assemblers; 7.2. Graphics Idea is to explore Apollo graphics, provide library of Graphics and Window routines for other utilities, eg VT52 emulator, Tek-like graphics terminal, etc. a. Borrow Summagraphics bit-pad from Brandt, and attach to one of SIO's (via patch panel ?), and add to STROKES for test, or perhaps attach PSL Projects 7 an SIO process to it, to send commands to DM input window (how?); b. Perhaps adapt TERAK FONT and Graphics editors; c. Test primitives (why didn't Scroll work); d. try Bit-blt e. try some of illegal "bits" (ie <-> MM, interlace, etc) f. Faster Line drawing g. RasterOp h. Try Inverse Video Fonts i. Reimplement own Window package. j. Work on FONT editor: find font format's in one of INS files; Decode STD and NONIE; Try create a font (see Terak Font Editor); 7.3. PSL work a. Study ASM and architecture, develop notes on OS funnies (talk MDL, Harvard, etc); b. Modify PSL compiler (look at VAX work and Normans' 68000 stuff) c. Try some codings and Boot it. 8. Impact of Other LISPs a. Look at IMSSS additions (Utilities); b. Study FRANZ-LISP, UCI-LISP and MACLISP for new features (also some extensions and enhancements motivated by the work on InterLISP, NIL, SPICE LISP and the LISP Machine); c. Look at COMMON-LISP effort at CMU; d. Develop macro package to permit FRANZ-LISP, MACLISP and InterLISP code to be directly loaded. VERY important, see InterLISP utility; e. Implement/examine CMU-Top-Level facilities (using MACLISP/FRANZLISP sources); f. Study VLISP Portability; PSL Projects 8 9. Editor and Editor Interface a. Implement EMID/EMODE multi-window, multi-buffer EMACS-like screen editor [1]. This is planned to be the major interface to the PSL system, and will have convenient commands (MODES) to edit LISP and RLISP, examine documentation and convert LISP and RLISP to and from other convenient forms. There are "autoparen" modes in which an expression typed into a buffer automatically EVALs as soon as the expression is complete. EMID has also been used to experimentally develop a VLSI SLA editor (SLATE) [4] and will be used to do algebraic expression "surgery". The new version of EMDOE should concentrate on: i. Good window/package interface; ii. Interface to PSL (interactive editing of functions and expressions); iii. True "modes". Implement EMACS fork call, using fixed page to pass text; b. Implement the simple EDIT-like line-oriented editor based on SOS/EDIT for editing RLISP/REDUCE and some LISP input; mostly for people familiar with these editors. c. Add a simple History mechanism [Cf CMU-LISP toplevel ]; d. Implement the InterLISP-like/UCI-Lisp like structure EDITOR (using Nordtsrom source, UCI source, or IMSSS modified source); 10. Compiler and Loader a. Need to implement 2 stacks for W-arith, etc. b. Implement a FAP (fast loader); Currently, the c-macro loader (LAP), and binary loader (FAP), are based on a variety of ad-hoc loaders that have been written for the various machines and adapted for new machines. Frick [5] has written a general purpose LAP and FAP in a much more portable fashion (using a set of configuring parameters to describe the kind of target machine), and it is planned to adopt this as the basic LAP/FAP package when the STDLISP kernel is stable. c. Make FAP and dynamic code space allocation part of kernel; d. Implement DEC-20 .REL file loader; e. Enhance resident compiler to accept SYSLISP; PSL Projects 9 11. Language Extensions a. Convert SYSLISP [3] from a BCPL-like language to a C-like language; basic idea is to make use of some type information for more effective compilation; Modes, Mode analysis and structure definitions should be obtained from MODE system, but code-generation for new SPECIFIC functions must be addressed; b. Mode Analyzing RLISP/REDUCE [MODE-REDUCE] is an ALGOL-68 or PASCAL like interface to Standard LISP, which provides an additional MODE analysis pass after parsing, to rebind "generic" function names to "specific" functions, based on the declared or analysed MODEs of arguments. The system includes a variety of MODE generators (STRUCT, UNION, etc) [10, 7, 9]. We plan to reimplement this system to use SYSLISP/STDLISP more effectively. We will also make the MODE- ANALYSIS phase part of SYSLISP, so that words, bytes, items etc. can co-exist more naturally. Note that parsing from RLISP is into MODE- STDLISP or MODE-SYSLISP [which now become same language]; c. Implement better RLISP parser and top loop "generating" functions; d. Rename JUMPON to CASE or SWITCH; extend to include SELECTx constructs; e. Iteration and progs should be made more compatible. A single iteration construct, equivalent to LISPM's DoNamed should be implemented, and all other iteration and Prog contructs made macros which map into it. I propose that Iterate is a better name than Do or DoNamed. It may contain labels and Go's as a prog, and also ReturnFrom's and a Next construct. A simple Return should simply macro into a ReturnFrom the nearest Iterate, and similarly a next which does not specify an Iterate tag. Go's should be allowed to jump out to LEXICALLY surrounding Iterate's, but not across true function calls. All this will be quite simple to implement so long as all the nasty constructs such as WHILE and PROG and the like are macros into a single construct such as Iterate. Prog's should possibly also be extended to allow initial values to be specified as for example (PROG (A B (N 0) (Flg T) X) ...) which would initialize A, B, and X to nil, N to zero, and Flg to true. This is trivial to do using Iterate as the target of the Prog macro. The map functions would also be macros into an appropriate Iterate function. The FOR macro (which has basically been implemented) would allow very general sorts of loops and mapping functions, and would allow returns and the like to pass through. Another excellent function to have would be a ReturnTop or some such which returns from the lexically outermost Iterate -- thus in general will return from the function begin defined. Quite useful, I believe, though I don't think it exists in any other lisps. PSL Projects 10 12. Error Handler and Break Package a. Modifications to Error handler(s), and BREAK/TRACE/BACKTRACE to provide error "severity" level or classification so we can pick up ALL error messages(templates), and BREAK can decide if it can start a new (debugging) STDLSP or MUST strip stack. b. Add more tools to BREAKLOOP, ie walk BSTACK to see OLD fluid values; perhaps devise scheme to relate BSTACK sections with current Proc; perhaps have PROCNAME pushed on BSTACK [only if has FLUIDS] (see the DDT program by BENSON); c. Design better Error Recovery mechanism, particular for error correction and retry. An interface to EMODE would help, also an interface to the "single" stepper (CMU-TOPLEVEL). d. Examine the notion of Stack groups, and introduce an ERROR stack group, since we run SYSLISP code using initial [STKLO,STKHI,ST], in order to define a new [STKLO',STKHI',ST']; this stack group stuff may help improve error handler. e. Improve BREAK package (combine with EMBED, rename current BREAK to BREAKLOOP, let BREAK be used to instrument a function: (BREAK FOO condition action); f. Add Error Severity classification; g. Make some errors continuable: Undefined function, Unbound variable, etc; Idea is perhaps to have CERROR(n,msg,errorform) for continuable errors, FERROR(n,msg) for FATAL errors that cant use BREAK lOOP, and ERROR(n,msg) for the most common case; h. Implement the portable DEBUG package of functions for tracing, breaking and embedding functions [11]. Facilities include the (conditional) tracing of function calls and interpreted SETQs; selective backtrace; embedding functions to selectively insert pre- and post- actions, and conditions; primitive statistics gathering; generation of simple stubs (print their name and argument, and read a value to return); and, a PRINT for circular and re-entrant lists. This will replace the simple TRACE package in the current kernel, and interact more effectively with the BREAK package. i. Timing Hooks; j. Expand Macros in PUTDs (under flag control?); 13. Source Code Checking a. IMSSS "syntax" checker; b. Implement version of CREF for SYSLISP and STDLISP. CREF processes a number of source files, cross-referencing the functions and Global PSL Projects 11 variables used; gives an indication of where each function is defined or redefined, its type (EXPR, FEXPR, etc), the functions and variables it uses, various undefined functions and variables, and other statistics that can be selected or deselected under flag control [8]. 14. Manual and Help Facility a. Improve HELP, combine with other HELP mechanism. It will display short text descriptions for major functions on request; by reading a documentation data base, and should also display an activity based HELP-TEXT (e.g. in response to ? at appropriate points). b. The MANUAL is now fleshed out, but consists of a motley collection of chapters and paragraphs. Both HELP and MANUAL require a considerable amount of work in the conversion and writing of pieces of text; we also need to co-ordinate with the SCRIBE sources for the various documents already written. A model for a multi-chapter scribe document has been tested, in which an index and table of contents data-base are being built similarly to the usual AUX file; at any time, an uptodate INDEX and TABLE of CONTENTS can be produced; c. A documentation mode of EMODE (ala INFO tree in EMACS). 15. Funarg, Closures and Stack Groups Improve the binding scheme. Use a Baker-like scheme for fluid bindings, and have locals in interpreted code. To handle locals in interpreted code will require having those special forms which know about locals to have special interpreter functions which are passed an extra argument -- the lexical environment (probably as an a-list). These will be essentially those f-exprs which are open-compiled: COND, AND, OR, SETQ, PROG, various looping constructs (which I think should, together with PROG, all be macros to a single DO-like special form), CATCH, THROW (these last two are currently exprs, but I think should be made special), GO, RETURN. Note that this would allow a somewhat more general use of things like return, which I believe is all the the better. This is discussed a little bit more, below. The fluid scheme I propose is essentially that of Baker, with rerooting after EVERY binding and unbinding operation enforced. This allows us to still always look for fluid values in the value cell. For further efficiency we can still do our binding on the binding stack, which is now viewed as a binding tree cache, so long as whenever we capture an environment (as with a Closure or Catch) we write it out into the heap. This will substantially speed up binding and unbinding in those cases where there is no intervening environment capture. Also, use of STACK as cache to avoid much rebinding in list. The capturing of an environment for a closure should be done not with FUNCTION, which simply quotes its argument in such a manner that it is known to be intended for execution, and should be compiled to code, but rather with a third form of quote, probably called CLOSURE. There should also be a mechanism PSL Projects 12 for grabbing the current environment, without including a function to be run therein, though of course (CLOSURE EVAL) can always be used to give this effect. Currently we are implementing a variant of Baker's [2] re-rooting scheme to work well in the shallow binding environment; we expect that non-funarg compiled code will run essentially as fast as in LISP 1.6. Context switches will be more expensive. We may also implement some form of Stack Group, as done by the LISP machine group [6, 12], to provide faster large context switch. Perhaps implement some form of LOCAL in interpreted code; Consider ramifications of package system, funargs and stack groups as some sort of static/dynamic environment methods; 16. Applications a. Implement the REDUCE algebra system; b. Get and Implement the VOCAL CAI language; c. Bring up MINI and META, improve their use of I/O; d. Implement Picture RLISP for TekTronix, HP, APOLLO, etc. e. Implement extended SLATE on PSL and maybe combine with other VLSI projects (ABLE->RLISP...). f. FORTRAN (RATFOR?) to SYSLISP compilers for tools. 17. References [1] Armantrout, R.; Benson, E.; Galway, W.; and Griss, M. L. EMID: A Multi-Window Screen Editor Written in Standard LISP. Utah Symbolic Computation Group Opnote No. 54, University of Utah, Computer Science Department, Jan, 1981. [2] Baker, H. G. Shallow Binding in LISP 1.5. CACM 21(7):565, July, 1978. [3] 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. [4] Carter, T.; Galway, W.; Goates, G.; Griss, M. L.; and Haslam, R. SLATE: A Lisp Based EMACS Like Text Editor for SLA Design. Utah Symbolic Computation Group Opnote No. 55, University of Utah, Computer Science Department, Jan, 1981. PSL Projects 13 [5] Frick, I. B. A Portable Lap and Binary Loader. Utah Symbolic Computation Group Operating Note Opnote No. 52, University of Utah, November, 1979. [6] Greenblatt, R. The LISP Machine. Technical Report ?, MIT, August, 1975. [7] Griss, M. L. The Definition and Use of Data-Structures in Reduce. In Proceedings of SYMSAC 76, pages 53-59. SYMSAC, August, 1976. [8] Griss, M. L. RCREF: An Efficient REDUCE and LISP Cross-Reference Program. Utah Symbolic Computation Group, Operating Note Opnote No. 30, Univerisity of Utah, ??, 1977. [9] Griss, Martin L.; Hearn, A. C; and Maguire, G. Q., Jr. Using The MODE Analyzing version of REDUCE. Utah Symbolic Computation Group Opnote No. 48, Dept of CS, U of U, Jun, 1980. [10] Hearn, A. C. A Mode Analyzing Algebraic Manipulation Program. In Proceedings of ACM 74, pages 722-724. ACM, New York, New York, 1974. [11] Norman, A.C. and Morrison, D. F. The REDUCE Debugging Package. Utah Symbolic Computation Group, Operating Note Opnote No. 49, Dept of CS, U of U, Feb, 1981. [12] Weinreb, D. and Moon, D. LISP Machine Manual. Manual , M. I. T., January, 1979. second preliminary version. PSL Projects i Table of Contents 1. Introduction 2 2. Miscellaneous Small Enhancements and "Bugs" 2 3. I/O 3 3.1. Interrupts 3 4. Storage Management 5 5. New Machine Implementations 5 6. PASCAL like languages 6 7. Support work on Apollo 6 7.1. Initial Experiments 6 7.2. Graphics 6 7.3. PSL work 7 8. Impact of Other LISPs 7 9. Editor and Editor Interface 8 10. Compiler and Loader 8 11. Language Extensions 9 12. Error Handler and Break Package 10 13. Source Code Checking 10 14. Manual and Help Facility 11 15. Funarg, Closures and Stack Groups 11 16. Applications 12 17. References 12 |
Added psl-1983/doc/psl-summer-projects.mss version [5557c112ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(article) @Case(Draft, 1 <@device(Omnitech)>, else <@device(LPT)> ) @style(Spacing 1,spread 0) @modify(description, spread 0, above 0, below 0, indent -2 inches, leftmargin +2.5inches) @case(Device, LPT <@modify(HDX,below 0, above 0) @modify(HD2,below 0, Above 1, Use B) @modify(HD3,above 0, below 0,indent 3 char) > ) @MajorHeading(PSL projects for SUMMER 1982) @Heading(M. L. Griss) @begin(center) Last Update: @value(Date) @end(center) This document gives a list of the projects to be done regarding PSL during this summer. Those individual associated with each aspect of the project are listed with their activities. Missing are a list of priorities associated with each of these project, or in some cases a PERT (or whatever) chart would be appropriate as there is some precidence ordering. As the Package system probably should have a high priority than the BIGFLOAT stuff (as we will soon have major problems with names due to users wanting to add their own packages of routines and compatability packages etc. which will cause many name conflicts). The section at the end of the document is to be used to keep track of who knows what is going on about a given topic and who is working on it. There us a section for each of the people connected with PSL and what they are @dq[going to be doing]! @Section[DEC-20 and VAX] @begin(description) Polish BIGNUM@\ Implement BIGFLOAT@\ Packages and FASL@\Benson Resurrect ALTBIND@\ Polish REDUCE@\Griss, Hearn Franz-LISP and MACLISP Compatibility@\@Comment{Lanam (sp) at HP ??? for Franz} Extended-DEC-20@\Benson @end(description) @section[APOLLO] @begin(description) I/O, Floats, 32 bits@\Lowder LAP and FASL@\Maguire, Lowder Core Save/Restore@\Peterson->Lowder and Maguire SYSCALL@\Maguire, Lowder @end(description) @section[Other 68000s] @subsection[WICAT] @begin(description) Transfer PSL@\Lowder, Snelgrove @end(description) @subsection[HP9836] @begin(description) Test I/O, and build@\ ?? @end(description) @section[CRAY] @begin(description) LAP-to-ASM@\Griss, Kessler CMACROs@\ I/O and other LAP@\ Basic testing Model@\ @end(description) @section[Documentation] @subsection[MANUAL and HELP] @begin(description) Update Manual@\ New Help Files@\ Automate HELP files, Dirs@\ Add DESCRIBE@\ @end(description) @subsection[SYSTEM Documentation] @begin(description) Implementation@\ BUILD Guide@\ CMACRO Guide@\ LAP Guide@\ Testing Model@\ @end(description) @section[EMODE] @begin(Description) DOCUMENT@\Galway Optimize@\ POP-UP windows and Menus@\ Augment with Structure@\ EMODE and Graphics@\Stay, Fish EMODE and Apollo@\Move to Apollo PSL, see if Aegis window handler can be used at all, or if have to"borrow" display and do one-self (based on ST like emulator). EMODE and Algebra@\Need special structure editor, "boxes", etc. Get stuff from Don. @end(description) @section[Miscellaneous Modules] @begin(description) File Package/MasterScope@\ Improve or Replace RCREF@\ Improve PictureRLISP@\ Improve MINI, add error handler@\ Continue BETTY mode system@\ @end(description) @section[Applications] @begin(description) Algebra, Graphics and CAGD@\Griss, Knapp, Stay GPL@\Maguire, Robinson [, Lowder, Kessler]. Conversion of LISP 1.6 "engine" to PSL. CAI@\ @end(description) @Section(Activities by Individual) @Subsection(Benson) @Begin(Format) Packages and FASL Extended-DEC-20 @End(Format) @SubSection(Galway) @Begin(Format) EMODE DOCUMENT @End(Format) @Subsection(Griss) @Begin(Format) Polish REDUCE LAP-to-ASM Algebra, Graphics and CAGD @End(Format) @Subsection(Hearn) @Begin(Format) Polish REDUCE @End(Format) @SubSection(Kessler) @Begin(Format) LAP-to-ASM GPL @End(Format) @Subsection(Knapp) @Begin(Format) Algebra, Graphics and CAGD @End(Format) @SubSection(Lowder) @Begin(Format) I/O, Floats, 32 bits LAP and FASL Core Save/Restore SYSCALL WICAT Transfer PSL (With Snelgrove of WICAT) GPL @End(Format) @SubSection(Maguire) @Begin(Format) GPL (with Robison [, Kessler, Lowder]) LAP and FASL Core Save/Restore SYSCALL @End(Format) @Subsection(Stay) @Begin(Format) Algebra, Graphics and CAGD EMODE and Graphics (With Fish) @End(Format) |
Added psl-1983/doc/pslmac.lib version [7059627ea4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Marker(Library,PSLMacrosNames) @comment{ <GRISS>PSLMAC.LIB.2, by Griss, from} @comment{ <MAGUIRE>LOCALM.LIB.2, 13-May-82 05:46:06, Edit by MAGUIRE} @comment{ Started by G. Q. Maguire Jr. on 13.5.82 } @comment{ Various assorted commonly used macros for Local languages and papers, so they look consistent. } @comment{ Commonly used and abused words} @Commandstring(Dec20="DECSystem-20") @Commandstring(VAX750="VAX 11/750") @Commandstring(Apollo="Apollo DOMAIN") @Commandstring(68000="Motorola MC68000") @Commandstring(Wicat="Wicat System 100") @Commandstring(PSL="@r[PSL]") @comment{ The Short version of the names } @Commandstring(sDec20="DEC-20") @Commandstring(sVAX750="VAX 11/750") @Commandstring(sApollo="Apollo") @Commandstring(s68000="MC68000") @Commandstring(sWicat="Wicat") @comment[to be set spacially] @Commandstring(cmacro="c-macro") @Commandstring(anyreg="anyreg") @TextForm(TM="@+[TM]@Foot[Trademark of @parm(text)]") @comment{ Favorite Abbreviations and macros } @Commandstring(xs = "s") @Comment{Plural for abbrevs} @Commandstring(xlisp = "@r[L@c[isp]]") @Commandstring(xlisps = "@xlisp systems") @Commandstring(Franzlisp = "@r[F@c[ranz]]@xlisp") @Commandstring(CommonLisp = "@r[C@c[ommon ]]@xlisp") @Commandstring(lmlisp = "@r[Lisp Machine @xlisp]") @Commandstring(newlisp = "@r[N@c[il]]") @Commandstring(slisp = "@r[S@c[pice]] @xlisp") @Commandstring(maclisp = "@r[M@c[ac]]@xlisp") @Commandstring(interlisp = "@r[I@c[nter]]@xlisp") @Commandstring(rlisp = "@r[R]@xlisp") @Commandstring(picturerlisp = "@r[P@c[icture]]@rlisp") @Commandstring(emode = "@r[E@c[mode]]") @Commandstring(syslisp = "@r[S@c[ys]]@xlisp") @Commandstring(stdlisp = "@r[S@c[tandard]] @xlisp") @Commandstring(macsyma = "@r[MACSYMA]") @Commandstring(reduce = "@r[REDUCE]") @Commandstring(fortran = "@r[FORTRAN]") @Comment[ Set Alpha_1 logo properly on the Omnitech ] @Case(GenericDevice, Omnitech < @Define(FSS,Script -0.2 lines,Size 14) @CommandString(Alpha1="A@c(LPHA)@FSS(-)1") @commandstring(LTS="@value(LT)") @commandstring(EQS="@value(EQ)") @commandstring(PLS="@value(PLUSSIGN)") >, Else < @CommandString(Alpha1="Alpha_1") @commandString(PLS="+") @commandstring(EQS="=") @commandstring(LTS="<") >) @comment{ Do the Ada, UNIX, etc. TradeMark stuff } @Case(GenericDevice, Omnitech < @Define(Marks,Script +.5 lines, Size -5) @CommandString(TMS="@Marks(TM)") >, Else < @CommandString(TMS="@+(TM)") >) @CommandString(ADA="Ada@TMS") @CommandString(UNIX="UNIX@TMS") @Case(GenericDevice, Omnitech {@TextForm<EI=[@i(@Parm(text))]>}, else {@TextForm<EI=[@DQ(@Parm(Text))]>} ) |
Added psl-1983/doc/stream-io-ideas.doc version [6980efe045].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 4-Jun-82 22:09:33-MDT,0000003647;000000000001 Date: 4 Jun 1982 2209-MDT From: Chip Maguire Subject: Files Sender: MAGUIRE at UTAH-20 To: Griss cc: Benson, Lowder Reply-To: Maguire at Utah-20 Eric has provided some excellent material for the documentation. However, I think that we really have quite a lot more to consider with respect to files, stream, and filenames. Based on the early morning conversation re files and the generalization of COMPRESS, etc. to multiple incore files the following is submitted for comments and reactions. In addition it would seem that a useful funciton is to allow the user to PutSysFCN(FcnName, SysVec) i.e. put a new definiton into the IO function vectors; as an explicit operation. This should make it clear when a function is being assigned to a channel and allow the user to replace the functions associated with a channel in a very obvious manner. I would like to seem the initialization of object become an Initialization time activity rather than lost of things being stuck in vectors before hand. This should only mean a lot of time spend doing these initiallizations the first time a system is buuilt, if a SaveSytem is done, the things which have been built in stay builtin unless they are redefined later (so the execution cost is minimal). This will hopefully allow the IO-DATA.red file vectors to be idential on all machines as the binding will take place in a system dependent initialization file. Notes regarding files in PSL: 1. The model is clearly not simply a stream oriented model as there are non-stream based behaviour required. a. In a stream model the input and output streams are independent, there is no association such as streamM (an output stream) is the corresponding output to streamN (an input stream) - however, this behavior is being required by the RDTTY code on the 20 and the faked RDTTY code on the VAX - this hides the fact that the system "knows" about a primary terminal output, which is treated specially. b. The functions Flatten-size, explode, compress, etc. - a not being treated as what they really are - which is simply incore files (i.e. a stream which flows to and from a string) - they should get allocated just like other streams with the attendant properties that there can be many of them and they need to be opened as incore streams. 2. The terminal is NOT being handled as a character oriented device, it is being handled as a record oriented device - with the system providing record editing prior to the entry of the carriage return. It is unclear whether the prompting should be done the way it is on the VAX and the 20 for the Apollo, as the input buffer expands and contracts based on the number of lines entered; in hold mode the input is not send to the process until the hold is released, and then it is only sent as the lines are read; it does not seem to make sense to prompt on the basis of one prompt for each line. While it might seem reasonable to prompt for each new READ, i.e. so the user know WHO is reading and the MODE that they are reading in, it is currently not possible to know this unless the terminial handling function remembers theold string and compares it to the current one and checks if they are different. 3. The use of the Promptout!* on the VAX does not eliminate all of these problems asit does not correlate the PromptOut!* with the changes between the set StdIn . StdOut and ErrIn . ErrOut (but yet who you are prompting is clearly related to the StdIn or ErrOut streams! ------- |
Added psl-1983/doc/system-extras.mss version [776662469a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @make(article) @section(System Dependent Functions) The following set of functions are needed to complete the system dependent part of PSL: @subsection(I/O) OPEN, CLOSE, READ, WRITE, CLEARIO, ECHO control for EMODE @subsection(Terminate Execution) The function QUIT(); terminates execution. It should probably close open files, perhaps restore system state to "standard" if special I/O capabilities were enabled. On some systems, execution can continue after the QUIT(), with the next instruction; on others, the core-image can not be continued or restarted. (See DUMPLISP(), below). On the DEC-20, the HALTF jsys is used, and execution can be continued. On the VAX under UNIX, a Stop signal (18) is sent via the "kill(0,18)" call. This also can be continued under Berkely 4.1. See the file SYSTEM-EXTRAS.RED on PV: and P20: @subsection(Date and Time) The function TIMC(); is supposed to return the run-time in milliseconds. This time should be from the start of this core-image, rather than JOB or SYSTEM time. It is used to time execution of functions. Return it as a full-word, untagged integer in register 1. On the DEC-20, we use the RUNTM jsys, on the VAX the C call on "times" is used, and multipled by 17, to get 1/1020'ths of a second. While not yet required, a TIMR() to get REAL time may be useful. See TIMC.RED on P20: and PV:. The DATE(); function is supposed to return a Tagged LISP string continue the current date. No particular format is currently assumed, and the string is used to create welcome messages, etc. Later developments may require a standard (for TIMESTAMPS on files), and may also require a CLOCK-time function. The Allocator function GtSTR(nbytes) may be useful to get a fresh string into which to copy the string returned by a system call. The string should be 0 terminated. The DEC-20 uses ODTIM, and "writes" to the string in "6-jun-82" format. On the VAX, the "ctime" call is used, and the result "shuffled" into the same format as the DEC-20. See SYSTEM-EXTRAS.RED on PV: and P20: @subsection(ReturnAddressP) The function RETURNADDRESSP(x); supports the backtrace mechanism, and is supposed to check that the instruction before the supposed address X, is in fact a legal CALL instruction. It is used to scan the stack, looking for return addresses. Very TRICKY, see SYSTEM-EXTRAS.RED on PV: and P20: @subsection(Interrupt Handler) Also very crude at present; on the DEC-20, written as a loadable module, P20:20-INTERRUPT.RED, using the JSYS package. This enables CNTRL-G, CTRL-T, some stack and arithmetic overflows, bbinding them to some sortof throw or Error routine. On the VAX, the file PV:TRAP.RED defines some signal setup, and InitializeInterrupts routine, and is included in the kernel. It associates each rap with a STDERROR call with a given message. Not yet standardized. We really should to "bind" all trappable interupts to an appropriate THROW('!$SIGNAL!$,n), and indicate whether to treat as a Fatal Error, a Continuable Error, or not an Error at all. @subsection(Core Image Saving) A way in which PSL (and most LISP@xs) get used, involves the ability to load LISP and FASL code into an executing PSL, and then saving this augmented "core-image" in a named file for subsequent restart later. Some Operating Systems permit a running program to be saved into an executable file, and then restarted from the beginning; others permit the saved program to be continued at the instruction following the call to the SAVE routine. Some operating systems do not normally permit or encourage the saving of a running program into an executable file, and there is a lot of work to be done. The model currently used in PSL is that a call on DUMPLISP(); does the following: @begin(enumerate) calls RECLAIM(); to compact the heap, or move the upper heap into the lower heap. makes some system calls to free unused space, decreasing the executable image; space is returned from HEAP, BPS and STACK. the core-image is save a file, whose name is the string in the global variable, DumpFileName!*. execution continues without leaving the running program; to terminate, the QUIT(); function must be called explicitly. the saved executable file will restart "from-the-top", i.e. by calling the machine specific "startup" function defined in MAIN-START.RED, which calls initialization functions CLEARBINDINGS(), CLEARIO(), INITIALIZEINTERRUPTS(), etc.; . Then the Startup function calls MAIN();, which can be redefined by the user before calling DUMPLISP(); . MAIN() typically calls StandardLISP() or RLISP(), or some other TopLoop. This startup function also has a LISP accesible name, RESET. @end(Enumerate) On some machines, the core-image will automatically start "from-the-top", unless effort is expended to change the "restart-vector' (e.g. the TOPS-20 SSAVE jsys on the DEC-20); on others, an explicit LINKE CALL (a JUMP) to RESET should be included after the core-save call, to ensure execution of RESET (e.g., the CTSS DROPFILE call on the CRAY-1). On the VAX under UNIX, a new function UNEXEC was written in C, to convert an executing program back into "a.out" format. [What about VAX and APOLLO]. See the files MAIN-START.RED and DUMPLISP.RED on P20: and PV:. @subsection(Miscellaneous) To use EMODE and PRLISP on some systems, a "raw" I/O mode may be required. See the PBIN, PBOUT, CHARSININPUTBUFFER, ECHOON and ECHOOFF functions in EMOD2:RAWIO.RED and SYSTEM-EXTRAS.RED. Some sort of system-call, fork or smilarch primitives are useful, clearly system dependent. See the JSYS and EXEC package on P20:, or the SYSTEM call in PV:SYSTEM-EXTRAS.RED (written in C as Foreign Function). This set is not yet standardized. |
Added psl-1983/doc/zbasic.doc version [1e77be0cb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZBASIC contains 6 packages -- (1) YLSTS -- useful functions for lists. (2) YNUMS -- useful functions for numbers. (3) YSTRS -- useful functions for strings. (4) YIO -- useful functions for user io. (5) YCNTRL -- useful functions for program control. (6) YRARE -- functions we use now, but may eliminate. YLSTS -- BASIC LIST UTILITIES CCAR ( X:any ):any CCDR ( X:any ):any LAST ( X:list ):any NTH-CDR ( L:list N:number ):list NTH-ELT ( L:list N:number ):elt of list NTH-TAIL( L:list N:number ):list TAIL-P ( X:list Y:list ):extra-boolean NCONS ( X:any ): (CONS X NIL) KWOTE ( X:any ): '<eval of #X> MKQUOTE ( X:any ): '<eval of #X> RPLACW ( X:list Y:list ):list DREMOVE ( X:any L:list ):list REMOVE ( X:any L:list ):list DSUBST ( X:any Y:any Z:list ):list LSUBST ( NEW:list OLD:list X:any ):list COPY ( X:list ):list TCONC ( P:list X:any ): tconc-ptr LCONC ( P:list X:list ):list CVSET ( X:list ):set ENTER ( ELT:element SET:list ):set ABSTRACT( FN:function L:list ):list EACH ( L:list FN:function ):extra-boolean SOME ( L:list FN:function ):extra-boolean INTERSECTION ( SET1:list SET2:list ):extra-boolean SETDIFFERENCE ( SET1:list SET2:list ):extra-boolean SUBSET ( SET1:any SET2:list ):extra boolean UNION ( X:list Y:list ):list SEQUAL ( X:list Y:list ):extra boolean MAP2C ( X:list Y:list FN:function ):NIL MAP2 ( X:list Y:list FN:function ):NIL ATSOC ( ALST:list, KEY:atom ):any CCAR( X:any ):any ---- Careful Car. Returns car of x if x is a list, else NIL. CCDR( X:any ):any ---- Careful Cdr. Returns cdr of x if x is a list, else NIL. LAST( X:list ):any ---- Returns the last cell in X. E.g. (LAST '(A B C)) = (C), (LAST '(A B . C)) = C. NTH-CDR( L:list N:number ):list ------- Returns the nth cdr of list--0 is the list, 1 the cdr ... NTH-ELT( L:list N:number ):list ------- Returns the nth elt of list--1 is the car, 2 the cadr ... NTH-TAIL( L:list N:number ):list ------- Returns the nth tail of list--1 is the list, 2 the cdr ... TAIL-P( X:list Y:list ):extra-boolean ------ If X is a non-nil tail of Y (X eq cdr Y or cddr Y or...), return X. Renamed to avoid a conflict with TAILP in compiler NCONS( X:any ): (CONS X NIL) ----- Returns (CONS X NIL) KWOTE( X:any ): '<eval of #X> MKQUOTE( X:any ): '<eval of #X> ------- Returns the quoted value of its argument. RPLACW( X:list Y:list ):list ------ Destructively replace the Whole list X by Y. DREMOVE( X:any L:list ):list ------- Remove destructively all equal occurrances of X from L. REMOVE( X:any L:list ):list ------ Return copy of L with all equal occurrences of X removed. COPY( X:list ):list ---- Make a copy of X--EQUAL but not EQ (except for atoms). DSUBST( X:any Y:any Z:list ):list ------ Destructively substitute copies(??) of X for Y in Z. LSUBST( NEW:list OLD:list X:any ):list ------ Substitute elts of NEW (splicing) for the element old in X TCONC( P:list X:any ): tconc-ptr ----- Pointer consists of (CONS LIST (LAST LIST)). Returns (and alters) pointer consisting of (CONS LIST1 (LAST LIST1)), where LIST1 = (NCONC1 LIST X). Avoids searching down the list as nconc1 does, by pointing at last elt of list for nconc1. To use, setq ptr to (NCONS NIL), tconc elts, return car of ptr. LCONC( P:list X:list ):list ----- Same as TCONC, but NCONCs instead of NCONC1s. CVSET( X:list ):list -------------------- Converts list to set, i.e., removes redundant elements. ENTER( ELT:element SET:list ):list ----- Returns (ELT . SET) if ELT is not member of SET, else SET. ABSTRACT( FN:function L:list ):list -------- Returns list of elts of list satisfying FN. EACH( L:list FN:function ):extra boolean ---- Returns L if each elt satisfies FN, else NIL. SOME( L:list FN:function ):extra boolean ---- Returns the first tail of the list whose CAR satisfies function. INTERSECTION( #SET1:list #SET2:list ):extra boolean ------------ Returns list of elts in SET1 which are also members of SET2 SETDIFFERENCE( #SET1:list #SET2:list ):extra boolean ------------- Returns all elts of SET1 not members of SET2. SUBSET( #SET1:any #SET2:list ):extra boolean ------ Returns SET1 if each element of SET1 is a member of SET2. UNION( X:list Y:list ):list ----- Returns the union of lists X, Y SEQUAL( X:list Y:list ):extra boolean ------ Returns X if X and Y are set-equal: same length and X subset of Y. MAP2( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired tails of X and Y. MAP2C( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired elts of X and Y. ATSOC( ALST:list, KEY:atom ):any ----- Like ASSOC, except uses an EQ check. Returns first element of ALST whose CAR is KEY. YNUMS -- BASIC NUMBER UTILITIES ADD1 ( number ):number EXPR SUB1 ( number ):number EXPR ZEROP ( any ):boolean EXPR MINUSP ( number ):boolean EXPR PLUSP ( number ):boolean EXPR POSITIVE( X:any ):extra-boolean EXPR NEGATIVE( X:any ):extra-boolean EXPR NUMERAL ( X:number/digit/any ):boolean EXPR GREAT1 ( X:number Y:number ):extra-boolean EXPR LESS1 ( X:number Y:number ):extra-boolean EXPR GEQ ( X:number Y:number ):extra-boolean EXPR LEQ ( X:number Y:number ):extra-boolean EXPR ODD ( X:integer ):boolean EXPR SIGMA ( L:list FN:function ):integer EXPR RAND16 ( ):integer EXPR IRAND ( N:integer ):integer EXPR The DEC compiler may optimize calls to PLUS2, DIFFERENCE, EQUAL, LESSP, etc. by converting them to calls to ADD1, SUB1, ZEROP, MINUSP, etc. This will create circular defintions in the conditional defintions, about which the compiler will complain. Such complaints can be ignored. ADD1( number ):number EXPR ---- Note: DEC compiler optimizes (PLUS2 N 1) into (ADD1 N). SUB1( number ):number EXPR ---- Note: DEC compiler optimizes (DIFFERENCE N 1) into (SUB1 N). ZEROP( X:any ):boolean EXPR ----- Returns non-nil iff X equals 0. MINUSP( N:number ):boolean EXPR ------ Returns non-nil iff N is less than 0. PLUSP( N:number ):boolean EXPR ----- Returns non-nil iff N is greater than 0. ODD( X:integer ):boolean EXPR --- Returns T if x is odd, else NIL. WARNING: EVENP is used by REDUCE to test if a list has even length. ODD and EVENP are thus highly distinct. POSITIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a positive number. NEGATIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a negative number. NUMERAL( X:any ): boolean EXPR ------- Returns true for both numbers and digits. Some dialects had been treating the digits as numbers, and this fn is included as a replacement for NUMBERP where NUMBERP might really be checking for digits. N.B.: Digits are characters and thus ID's GREAT1( X:number Y:number ):extra-boolean EXPR ------ Returns X if it is strictly greater than Y, else NIL. GREATERP is simpler if only T/NIL is needed. LESS1( X:number Y:number ):extra-boolean EXPR ----- Returns X if it is strictly less than Y, else NIL LESSP is simpler if only T/NIL is needed. GEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is greater than or equal to Y, else NIL. LEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is less than or equal to Y, else NIL. SIGMA( L:list, FN:function ):integer EXPR ----- Returns sum of results of applying FN to each elt of LST. RAND16( ):integer EXPR IRAND ( N:integer ):integer EXPR ------ Linear-congruential random-number generator. To avoid dependence upon the big number package, we are forced to use 16-bit numbers, which means the generator will cycle after only 2^16. The randomness obtained should be sufficient for selecting choices in VOCAL, but not for monte-carlo experiments and other sensitive stuff. decimal 14933 = octal 35125, decimal 21749 = octal 52365 Returns a new 16-bit unsigned random integer. Leftmost bits are most random so you shouldn't use REMAINDER to scale this to range Scale new random number to range 0 to N-1 with approximately equal probability. Uses times/quotient instead of remainder to make best use of high-order bits which are most random YSTRS -- BASIC STRING UTILITIES EXPLODEC ( X:any ):char-list EXPR EXPLODE2 ( X:any ):char-list EXPR FLATSIZE ( X:str ):integer EXPR FLATSIZE2( X:str ):integer EXPR NTHCHAR ( X:str N:number ):char-id EXPR ICOMPRESS( LST:lst ):<interned id> EXPR SUBSTR ( STR:str START:num LENGTH:num ):string EXPR CAT-DE ( L: list of strings ):string EXPR CAT-ID-DE( L: list of strings ):<uninterned id> EXPR SSEXPR ( S: string ):<interned id> EXPR EXPLODE2( X:any ):char-list EXPR EXPLODEC( X:any ):char-list EXPR -------- List of characters which would appear in PRIN2 of X. If either is built into the interpreter, we will use that defintion for both. Otherwise, the definition below should work, but inefficiently. Note that this definition does not support vectors and lists. (The DEC and IBM interpreters support EXPLODE and EXPLODE2 by using the same internal algorithm that is used for PRIN1 (PRIN2), but put the chars generated into a list instead of printing them. Thus, they work on arbitrary s-expressions.) If either EXPLODEC or EXPLODE2 is defined, the CDE does nothing. Note: According to the STANDARD LISP REPORT, EXPLODE and EXPLODE2 are only defined for atoms. If your interpreter does not support extended EXPLODE and EXPLODE2, then change the second CDE's below for FLATSIZE and FLATSIZE2 to get recursive versions of them. FLATSIZE( X:any ):integer EXPR -------- Number of chars in a PRIN1 of X. Also equals length of list created by EXPLODE of X, assuming that EXPLODE extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN1, but count chars instead of printing them. If your EXPLODE only works for atoms, comment out the above CDE and turn the CDE below into DE. FLATSIZE2( X:any ):integer EXPR --------- Number of chars in a PRIN2 of X. Also equals length of list created by EXPLODE2 of X, assuming that EXPLODE2 extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN2, but count chars instead of printing them. FLATSIZE will often suffice for FLATSIZE2 If your EXPLODE2 only works for atoms, comment out the CDE above and turn the CDE below into DE. NTHCHAR( X:any, N:number ):character-id EXPR ------- Returns nth character of EXPLODE2 of X. ICOMPRESS( LST:list ):interned atom EXPR --------- Returns INTERN'ed atom made by COMPRESS. SUBSTR( STR:string START:number LENGTH:number ):string EXPR ------ Returns a substring of the given LENGTH beginning with the character at location START in the string. NB: The first location of the string is 0. If START or LENGTH is negative, 0 is assumed. If the length given would exceed the end of the string, the subtring returned quietly goes to end of string, no error. CAT-DE( L: list of expressions ):string EXPR ------- Returns a string made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT macro. CAT-ID-DE( L: list of any ):uninterned id EXPR ------- Returns an id made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT-ID macro. SSEXPR( S: string ): id EXPR ------ Returns ID `read' from string. Not very robust. YIO -- simple I/O utilities. All EXPR's. CONFIRM (#QUEST: string ):boolean EATEOL ():NIL TTY-DE (#L: list ):NIL TTY-TX-DE (#L: list ):NIL TTY-XT-DE (#L: list ):NIL TTY-TT-DE (#L: list ):NIL TTY-ELT (#X: elt ):NIL PRINA (#X: any ):NIL PRIN1SQ (#X: any ):NIL PRIN2SQ (#X: any ):NIL PRINCS (#X: single-char-id ):NIL --queue-code-- SEND ():NIL SEND-1 (#EE) ENQUEUE (#FN #ARG) Q-PRIN1 (#E: any ):NIL Q-PRINT (#E: any ):NIL Q-PRIN2 (#E: any ):NIL Q-TERPRI () ONEARG-TERPRI (#E: any ):NIL Q-TYO (#N: ascii-code ):NIL Q-PRINC (#C: single-char-id ):NIL * Q-TTY-DE (#CMDS: list ):NIL * Q-TTY-XT-DE (#CMDS: list ):NIL * Q-TTY-TX-DE (#CMDS: list ):NIL * Q-TTY-TT-DE (#CMDS: list ):NIL DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) ( SETQ !#ANS (CAR (EXPLODEC (READ)))) (COND ((EQ !#ANS (QUOTE Y)) (PROGN ( EATEOL) (RETURN T))) ((EQ !#ANS (QUOTE N)) (PROGN (EATEOL) (RETURN NIL))) (( EQ !#ANS (QUOTE !?)) (GO LP0)) (T (TTY!-XT Please type Y, N or ?.)) (GO LP1))) Eat (discard) text until $EOL$ or <ESC> seen. <ESC> meaningful only on PDP-10 systems. $EOL$ meaningful only on correctly-implemented Standard-LISP systems. An idea whose time has not yet come... DE TTY!-DE (EOLS!#BEFORE !#L EOLS!#AFTER) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) LP1 (COND ((ONEP EOLS!#BEFORE) (TTY!-ELT !$EOL!$)) (( ZEROP EOLS!#BEFORE) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#BEFORE ( SUB1 EOLS!#BEFORE)) (GO LP1)))) (MAPC !#L (FUNCTION TTY!-ELT)) LP1 (COND (( ONEP EOLS!#AFTER) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#AFTER) NIL) (T (PROGN ( TTY!-ELT !$EOL!$) (SETQ EOLS!#AFTER (SUB1 EOLS!#AFTER)) (GO LP2)))) (WRS OLD!#CHAN))) So, for now at least, ... PRINA( X:any ): any ----- Prin2s expression, after TERPRIing if it is too big for line, or spacing if it is not at the beginning of a line. Returns the value of X. Except for the space, this is just PRIN2 in the IBM interpreter. CHRCT (): <number> ----- CHaRacter CounT left in line. Also a CDE in YPP.LSP -- built into IMSSS DEC interpreter. BINARY (#X: boolean): old-value ------ Stub for non-IMSSS interpreters. In IMSSS interpreter, will put terminal into binary mode or take it out, according to argument, and return old value. PRIN1SQ (#X: any) ------- PRIN1, Safe, use apostrophe for Quoted expressions. This is essentially a PRIN1 which tries not to exceed the right margin. It exceeds it only in those cases where the pname of a single atom exceeds the entire linelength. In such cases, <big> is printed at the terminal as a warning. (QUOTE xxx) structures are printed in 'xxx form to save space. Again, this is a little superfluous for the IBM interpreter. PRIN2SQ (#X: any) ------- PRIN2, Safe, use apostrophe for Quoted expressions. Just like PRIN1SQ, but uses PRIN2 as a basis. PRINCS (#X: single-character-atom) ------- PRINC Safe. Does a PRINC, but first worries about right margin. 1980 Jul 24 -- New Queued-I/O routines. To interface other code to this new I/O method, the following changes must be made in other code: PRIN2 --> TTY TERPRI --> $EOL$ inside a TTY, which causes Q-TERPRI to be called TYO --> Q-TYO PRIN1, PRINT -- These are used only for debugging. Do a (SEND) just before starting to print things in realtime, or use Q-PRIN1 etc. TTY -- Ok, expands into TTY-DE which calls Q-PRIN2 and Q-TERPRI. SAY -- I don't know what to do with this crock. It seems to be a poor substitute for TTY. If so it can be changed to TTY with the arguments fixed to be correct. <!GRAM>LPARSE.LSP When *BATCHOUT is NIL, output is done in realtime and *BATCHQUEUE remains NIL. When *BATCHOUT is true, output is queued and SEND executes&dequeues it later. Initialize *BATCHQUEUE for TCONC operations. Initialize *BATCHMAX and *BATCHCNT These call PRIN2, so they would cause double-enqueuing. DE Q!-TTY!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-DE) !#CMDS)) ( 1 (TTY!-DE !#CMDS)))) DE Q!-TTY!-XT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-XT!-DE) !#CMDS)) (1 (TTY!-XT!-DE !#CMDS)))) DE Q!-TTY!-TX!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TX!-DE) !#CMDS)) (1 (TTY!-TX!-DE !#CMDS)))) DE Q!-TTY!-TT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TT!-DE) !#CMDS)) (1 (TTY!-TT!-DE !#CMDS)))) YCNTRL -- ROUTINES INVOLVED WITH PROGRAM CONTROL STRUCTURES CATCH ( EXP:s-expression LABELS:id or idlist ):any EXPR THROW ( VALU:any LABEL:id ): error label EXPR ERRSET-DE ( #EXP #LBL ):any EXPR APPLY# ( ARG1: function ARG2: argument:list ):any EXPR BOUND ( X:any ):boolean EXPR MKPROG ( VARS:id-lst BODY:exp ):prog EXPR BUG-STOP (): any EXPR CATCH( EXP:s-expression LABELS:id or idlist ): any EXPR ----- For use with throw. If no THROW occurs in expression, then returns value of expression. If thrown label is MEMQ or EQ to labels, then returns thrown value. OW, thrown label is passed up higher. Expression should be quoted, as in ERRORSET. THROW( VALU:any LABEL:id ): error label EXPR ----- Throws value with label up to enclosing CATCH having label. If there is no such CATCH, causes error. ERRSET-DE ( EXP LBL ):any EXPR Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. Usually called via ERRSET macro. APPLY#(ARG1: function ARG2: argument:list): any EXPR ------ Like APPLY, but can use fexpr and macro functions. BOUND( X:any ): boolean EXPR ----- Returns T if X is a bound id. MKPROG( VARS:id-lst BODY:exp ) EXPR ------ Makes a prog around the body, binding the vars. BUGSTOP ():NIL EXPR ------- Enter a read/eval/print loop, exit when OK is seen. YRARE -- ROUTINES WHICH ARE USED, BUT OF DUBIOUS USEFULNESS ?? DELETE THESE ?? LOADV ( V:vector FN:function ):vector EXPR AMONG ( ALST KEY ITEM ) EXPR INSERT ( ITEM ALST KEY ) EXPR DCONS ( X:any Y:list ):list EXPR SUBLIST ( X:list P1:integer P2:integer ):list EXPR SUBLIST1( Y ) EXPR LDIFF ( X:list Y:list ):list EXPR used in editor/copy in ZEDIT MAPCAR# ( L:list FN:function ):any EXPR MAP# ( L:list FN:function ):any EXPR INITIALP( X:list Y:list ):boolean EXPR SUBLISTP( X:list Y:list ):list EXPR INITQ ( X:any Y:list R:fn ):boolean EXPR LOADV( V:vector FN:function ):vector EXPR ----- Loads vector with values. Function should be 1-place numerical. V[I] _ FN( I ). If value of function is 'novalue, then doesn't change value. ?? AMONG(ALST:association-list KEY:atom ITEM:atom):boolean EXPR ----- Tests if item is found under key in association list. Uses EQUAL tests. INSERT (ITEM:item ALST:association:list KEY:any):association list ------ EXPR (destructive operation on ALST) Inserts item in association list under key or if key not present adds (KEY ITEM) to the ALST. DCONS( X:any Y:list ):list EXPR ----- Destructively cons x to list. SUBLIST( X:list P1:integer P2:integer ):list EXPR ------- Returns sublist from p1 to p2 positions, negatives counting from end. I.e., (SUBLIST '(A B C D E) 2 -2) = (B C D) LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X. MAPCAR#( L:list FN:function ):any EXPR ------- Extends mapcar to work on general s-expressions as well as lists. The return is of same form, i.e. (MAPCAR# 'ATOM '(A B C . D)) = (T T T . T) Also, if for any member of list the variable SPLICE is set to true by function, then for that member the return from the function is spliced into the return. MAP#( L:list FN:function ):any EXPR ---- Extends map to work on general s-expressions as well as lists. INITIALP( X:list Y:list ):boolean EXPR -------- Returns T if X is EQUAL to some ldiff of Y. SUBLISTP( X:list Y:list ):list EXPR -------- Returns a tail of Y (or T) if X is a sublist of Y. INITQ( X:any Y:list R:fn ):boolean EXPR ----- Returns T if x is an initial portion of Y under the relation R. |
Added psl-1983/doc/zfiles.doc version [914c6dc12a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZFILES contains 2 packages -- (1) YFILES -- useful functions for accessing files. (2) YTOPCOM -- useful functions for compiling files. %%%% YFILES -- BASIC FILE ACCESSING UTILITIES File descriptor is a canonical FILE name, gets converted to file string: FILE or (FILE) -> "FILE.LSP" (FILE.EXT) -> "File.Ext" (DIR FILE) -> "<Dir>File.LSP" (DIR FILE EXT) -> "<dir>File.Ext" "xxx" -> "xxx" --------------------------------------------------------------- FORM-FILE ( FILE:DSCR ): filename EXPR GRABBER ( SELECTION FILE:DSCR ): NIL EXPR DUMPER ( FILE:DSCR ): NIL EXPR DUMPFNS-DE ( SELECTION FILE:DSCR ): NIL EXPR DUMP-REMAINING ( SELECTION:list DUMPED:list ): NIL EXPR FCOPY ( IN:DSCR OUT:DSCR filedscrs ):boolean EXPR REFPRINT-FOR-GRAB-CTL( #X: any ):NIL EXPR G:CREFON Switched on by cross reference program CREF:FILE G:JUST:FNS Save only fn names in variable whose name is the first field of filename if T, O/W save all exprs in that variable G:FILES List of files read into LISP G:SHOW:TRACE Turns backtrace in ERRORSET on if T G:SHOW:ERRORS Prints ERRORSET error messages if T GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. See ZMACROS. GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER IDS <file-dscr>) Like GRAB, but only reads in specified ids. See ZMACROS. FORM-FILE( FILE:DSCR ): filename EXPR --------- Takes a file dscr, possibly NIL, and returns a file name corresponding to that dscr and suitable as an argument to OPEN. F:OLD:FILE is set to this file name for future reference. Meanwhile, F:FILE:ID is set to a lisp identifier, and the file name is put on the OPEN:FILE:NAME property of that identifier. The identifier can be used to hold info about the file. E.g. its value may be a list of objects read from the file. NB: FORM-FILE is at the lowest level of machine-independant code. MAKE-OPEN-FILE-NAME is a system dependant routine that creates file names specifically tailored to the version of SLISP in use. GRABBER( SELECTION:id-list FILE:DSCR ):T EXPR ------- Opens the specified file, applies GRAB-EVAL-CTL to each expression on it, and then closes it. Returns T. See GRAB-EVAL-CTL for important side effects. GRAB-EVAL-CTL( #SELECTION EXPR#READ FILE#ID ) EXPR ------------- Examines each expression read from file, and determines whether to EVAL that expression. Also decides whether to append the expression, or an id taken from it, or nothing at all, to the value of the file id poined at by FILE#ID. The file id is stored for use as an argument to DUMP or COMPILE, for example. Note: G:JUSTFNS suppresses the storage of comments from the file. When reading LAP files, no list of fns is made. DUMPER( FILE:DSCR : file-dscr ): NIL EXPR ------ Dumps file onto disk. Filename as in GRABBER. Prettyprints the defined functions, set variables, and evaluated expressions which are members of the value of the variable filename. (For DEC versions: If IBASE neq 10, puts (SETQ IBASE current:base) at head of file.) DUMPFNS-DE( FNS FILE:DSCR ): NIL EXPR ---------- Like DUMPER. Copies old file, putting new definitions for specified functions/variables. E.g.: (DUMPFNS-DE '(A B) '(FOO)) will first copy verbatim all the expressions on FOO.LSP which do not define A or B. Then the core definitions of A and B are dumped onto the file. DUMP-REMAINING( SELECTION:list DUMPED:list ) EXPR -------------- Taken out of DUMPFNS for ease of reading. Dumps those properties of items in selection which have not already been dumped. FCOPY( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the prettyprinter. Useful for removing angle brackets or for tightening up function format. Returns T on normal exit, NIL if error reading file. FCOPY-SQ ( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the compacting printer. Letterizes and reports via '<big>' message long strings. Returns T on normal exit, NIL if error reading file. YTOPCOM -- Compiler Control functions (DF COMPILE-FILE (FILE:NAME) (DF COMPILE-IN-CORE (FILE:NAME) Commonly used globals. Declared in this file so each individual file doesn't have to declare them. "Other globals/fluids "This flag is checked by COMPILE-FILE. PPLAP( MODE CODE ) EXPR ----- Prints the lap code in some appropriate format. Currently uses PRIN1SQ (PRIN1, Safe, use apostrophe to Quote non-numeric expressions). COMPILE-FILE( FILE:DSCR ) FEXPR ------------ Reads the given file, and creates a corresponding LAP file. Each expression on the original file is mapped into an expression on the LAP file. Comments map into NIL. Function definitions map into the corresponding LAP code. These definitions are compiled, but NOT evaluated -- hence the functions will not be loaded into this core image by this routine. All other expressions are evaluated in an errorset then copied verbatim. EXCEPTION: UNFLUID is evalutated, but converted into a comment when printed, to avoid confusing loader. COMPILE-IN-CORE( FILE:DSCR ):NIL FEXPR --------------- Compiles all EXPRS and FEXPRS on a file and loads compiled code into core. Creates a file FILE:NAME.cpl which is a compilation log consisting of the names of functions compiled and the space used in their loading. GCMSG( X:boolean ):any EXPR ----- Pre-defined in both SLISP and new IBM intpreter, so this cde shouln't do anything. GCMSG turns the garbage collection msgs on or off. |
Added psl-1983/doc/zmacro.doc version [e89fb61125].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZMACRO contains two macro packages -- (1) YMACS -- basically useful macros and fexprs. (2) YSAIMACS -- macros used to simulate many SAIL constructs. YMACS -- USEFUL MACROS AND FEXPRS (see also YSAIMAC) * ( X:any ): NIL MACRO ** ( X:list ) MACRO NEQ ( X:any Y:any ):boolean MACRO NEQN ( X:any Y:any ):boolean MACRO NEQUAL ( X:any Y:any ):boolean MACRO MAKE ( variable template ) MACRO SETQQ ( variable value ) MACRO EXTEND ( function series ) MACRO DREVERSE( list ):list MACRO APPENDL ( lists ) MACRO NCONCL ( lists ) MACRO NCONC1 ( lst exp1 ... expn ): any MACRO SELECTQ ( exp cases last-resort ) MACRO WHILE ( test body ) MACRO REPEAT ( body test ) MACRO FOREACH ( var in/of lst do/collect exp ) MACRO SAY ( test expressions ) MACRO DIVERT ( channel expressions ) MACRO CAT ( list of any ):string MACRO CAT-ID ( list of any ):<uninterned id> MACRO TTY ( L:list ):NIL MACRO TTY-TX ( L:list ):NIL MACRO TTY-XT ( L:list ):NIL MACRO TTY-TT ( L:list ):NIL MACRO ERRSET ( expression label ) MACRO GRAB ( file ) MACRO GRABFNS ( ids file-dscr ) MACRO DUMP ( file-dscr ) MACRO DUMPFNS ( ids file-dscr ) MACRO used to expand macros: XP#SELECTQ (#L#) EXPR XP#WHILE (#BOOL #BODY) EXPR XP#FOREACH (#VAR #MOD #LST #ACTION #BODY) EXPR XP#SAY1 ( expression ) EXPR *( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules. **( X:list ) MACRO ===> (PROGN <lists>) For comments--all atoms are ignored, lists evaluated as in PROGN. NEQ( X:any Y:any ):boolean MACRO ===> (NOT (EQ X Y)) Changed to CDM because NEQ in PSL means NOT EQUAL. We hope to change that situation, however. NEQN( X:any Y:any ):boolean MACRO ===> (NOT (EQN X Y)) NEQUAL( X:any Y:any ):boolean MACRO ===> (NOT (EQUAL X Y)) MAKE( variable template ) MACRO ===> (SETQ <var> <some form using var>) To change the value of a variable depending upon template. Uses similar format for template as editor MBD. There are 3 cases. 1) template is numerical: (MAKE VARIABLE 3) = (SETQ VARIABLE (PLUS VARIABLE 3)) 2) Template is a series, whose first element is an atom: (MAKE VARIABLE ASSOC ITEM) = (SETQ VARIABLE (ASSOC ITEM VARIABLE)) 3) Otherwise, variable is substituted for occurrences of * in template. (MAKE VARIABLE (ASSOC (CADR *) (CDDR *)) = (SETQ VARIABLE (ASSOC (CADR VARIABLE) (CDDR VARIABLE)) SETQQ( variable value ) MACRO ===> (SETQ VARIABLE 'VALUE) EXTEND( function series ) MACRO ===> (FN ELT1 (FN ELT2 ... (FN ELTn-1 ELTn))) Applies 2-place function to series, similarly to PLUS. E.g.: (EXTEND SETQ A B C D 5) = (SETQ A (SETQ B (SETQ C (SETQ D 5)))) DREVERSE( L: list ):list MACRO ===> (REVERSIP L) Synonym for REVERSIP. APPENDL( lists ) MACRO ===> (APPEND LIST1 (APPEND LIST2 ....)) EXPAND's APPEND to a list of arguments instead of just 2. NCONCL( lists ) MACRO ===> (NCONC LST1 (NCONC LST2 ....)) EXPAND's NCONC to a list of arguments instead of just 2. NCONC1( lst exp1 ... expn ): any MACRO ===> (NCONC LST (LIST EXP1 ... EXPn)) Destructively add exp1 ... exp-n to the end of lst. SELECTQ( exp cases last-resort ) MACRO ===> (COND ...) Exp is a lisp expression to be evaluated. Each case-i is of the form (key-i exp1 exp2...expm). Last-resort is a lisp expression to be evaluated. Generates a COND statement: If key-i is an atom, case-i becomes the cond-pair: ((EQUAL exp key-i) (PROGN exp1 exp2 ... expm)) If key-i is a list, case-i becomes the cond-pair: ((MEMBER exp key-i) (PROGN exp1 exp2 ... expm)) Last-resort becomes the final cond-pair: (T last-resort) If exp is non-atomic, it should not be re-evaluated in each clause, so a dummy variable (#SELECTQ) is set to the value of exp in the first test and that dummy variable is used in all successive tests. Note: (1) A FEXPR version of SELECTQ would forbid use of RETURN and GO. (2) The form created must NOT have a prog or lambda wrapped around the cond expression, as this would also forbid RETURN and GO. Since #SELECTQ can't be lambda-bound by any means whatsoever and remain consistent with the standard-lisp report (if GO or RETURN appears inside a consequent), there is no way we can make SELECTQ re-entrant. If you go into a break with ^B or ^H and execute another SELECTQ you will clobber the one and only incarnation of #SELECTQ, and if it happened to be in the middle of deciding which consequent to execute, then when you continue the computation it won't work correctly. Update -- IMSSS break pkg now tries to protect #SELECTQ. Update -- uses XP#SELECTQ which can be compiled to speed up macro expansion. WHILE( test body ) MACRO ===> (PROG ...) <while loop> While test is true do body. REPEAT( body test ) MACRO ===> (PROG ...) <repeat loop> Repeat body until test is true. Jim found that this fn as we had it was causing compiler errors. The BODY was (CDDR U) and the BOOL was (CADR U). Question: Does the fact that Utah was unable to reproduce our compiler errors lie in this fact. Does function until test becomes non-NIL. FOREACH( var in/of lst do/collect exp ) MACRO ===> (MAPxx LST (FUNCTION (LAMBDA (VAR) EXP))) Undocumented FOREACH supplied by Utah. Required by compiler. Update: modified to call xp#foreach which can be compiled to speed up macro expansion. SAY( test expressions ) MACRO ===> (COND (<test> (PROGN (PRIN2 ...) (PRIN2 ...) ...))) If test is true then evaluate and prin2 all expressions. Exceptions: the value of printing functions, those flaged with SAY:PRINT (including: PRINT PRIN1 PRIN2 PRINC TYO PPRINT TERPRI POSN DOHOME DORIGH DOLEFT DOUP DODOWN DPYNCH DPYCHR SETCUR MOVECUR) are just evaluated. E.g.: (In the example @ is used for quotes) (SAY T @this @ (PRIN1 '!!AND!!) @ that@) appears as: this !!AND!! that DIVERT( channel expressions ) MACRO ===> (PROG (ochan) <select given chan> <eval exps> <select ochan>) Yields PROG that selects channel for output, evaluates each expression, and then reselects prior channel. CAT( list of any ):string MACRO ===> (CAT-DE (LIST <list>)) Evaluates all arguments given and forms a string from the concatenation of their prin2 names. CAT-ID( list of any ):<uninterned id> MACRO ===> (CAT-ID-DE (LIST <list>)) Evaluates all arguments given and forms an id from the concatenation of their prin2 names. TTY ( L:list ):NIL MACRO TTY-TX( L:list ):NIL MACRO TTY-XT( L:list ):NIL MACRO TTY-TT( L:list ):NIL MACRO ===> (TTY-xx-DE (LIST <list>)) TTY is selected for output, then each elt of list is evaluated and PRIN2'ed, except for $EOL$'s, which cause a TERPRI. Then prior output channel is reselected. TTY-TX adds leading TERPRI. TTY-XT adds trailing TERPRI. TTY-TT adds leading and trailing TERPRI's. CDMs were making all of the following unloadable into existing QDRIVER.SAV core image. I flushed the 'C' July 27 TTY-DE now takes two extra arguments, for the number of TERPRIs to preceed and follow the other printed material. ERRSET (expression label) MACRO ===> (ERRSET-DE 'exp 'label) Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER FNS <file-dscr>) Like grab, but only reads in specified fns/vars. DUMP( <file description> ) MACRO ===> (DUMPER '<file-dscr>) Dumps file onto disk. Filename as in GRAB. Prettyprints. DUMPFNS( <ids> . <file dscr> ) MACRO ===> (DUMPFNS-DE <fns> '<file-dscr>) Like DUMP, but copies old file, inserting new defs for specified fns/vars We are currently defining these to be macros everywhere, but might want them to be exprs while interpreted, in which case use the following to get compile-time macros. PUT (QUOTE NEQ) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQ !#X !#Y)))) ) PUT (QUOTE NEQN) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQN !#X !#Y))))) PUT (QUOTE NEQUAL) (QUOTE CMACRO) (QUOTE (LAMBDA (!#X !#Y) (NOT (EQUAL !#X !#Y))))) YSAIMAC -- MACROS used to simulate SAIL constructs. macros: DO-UNTIL SAI-IF SAI2-IF SAI-DONE SAI-CONTINUE SAI-WHILE SAI-FOREACH SAI-FOR SAI-BEGIN PBEGIN PRETURN SAI-ASSIGN MSETQ SAI-COLLECT IFC OUTSTR SAI-SAY SAI-& SAI-LENGTH CVSEST CVSEN CVS SUBSTRING-FOR SUBSTRING-TO PUSHES PUSHVARS SLIST SAI-MAPC SAI-EQU auxiliary exprs used to expand macros: XP#SAY-IF XP#SAI-WHILE XP#SAI-FOREACH XP#SAI-FOR XP#SUBSTRING-TO SAI-IF ( sailish if-expression ) MACRO (IF test1 THEN exp1 [ ELSEIF testi THEN expi ] [ELSE expn]) ===> (COND (test1 exp1) ... (testi expi) ... (T expn)) Embedded expressions do not cause embedded COND's, (unlike ALGOL!). Examples: (IF (ATOM Y) THEN (CAR X)) (IF (ATOM Y) THEN (CAR X) ELSE (CADR X)) (IF (ATOM Y) THEN (CAR X) ELSEIF (ATOM Z) THEN (CADR X)) SAI-WHILE ( sailish while-expression ) MACRO (WHILE b DO e1 e2 ... en) does e1,..., en as long as b is non-nil. ===> (PROG NIL CONTINUE: (COND ((NULL b) (RETURN NIL))) e1 ... en (GO CONTINUE:)) N.B. (WHILE b DO ... (RETURN e)) has the RETURN relative to the PROG in the expansion. As in SAIL, (CONTINUE) and DONE work as statements. (They are also macros.) REM is planning on cleaning this up so it works in all cases... The form that (SUBSTRING-TO stringexpr low high) should expand into is ((LAMBDA (#STRING) (SUBSTR #STRING low high)) stringexpr) except that low and high have been modified to replace INF by explicit calls to (FLATSIZE2 #STRING). Thus things like (SUBSTRING-TO (READ) 2 (SUB1 INF)) should work without requiring the user to type the same string twice. Probably that inner (SUBSTR ...) should simply be ((LAMBDA (INF) (SUBSTR #STRING low high)) (FLATSIZE2 #STRING)) where we don't have to internally modify low or high at all! |
Added psl-1983/doc/zpedit.doc version [14007678b1].
cannot compute difference between binary files
Added psl-1983/emode/aaa.sl version [56125e192d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % AAA.SL - EMODE support for Ann Arbor Ambassador terminals (nearly % identical to DEC VT100). % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,47) (total % dimensions are 80 wide by 48 down). This corresponds to the values that % seem popular at the University of Utah CS Department. With a bit more % work, we might change the driver so that it set up the screen dimensions % by transmitting the appropriate character sequence to the terminal. (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 47)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#377) (DE EraseScreen () (progn % First, erase the screen (PBOUT (Char ESC)) (PBOUT (Char ![)) (PBOUT (Char 2)) (PBOUT (Char J)) % then put the cursor at "home". (SetTerminalCursor 0 0))) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char ![)) (PBOUT (char !0)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (Char ![)) % Use "quick and dirty" conversion to decimal digits. (PBOUT (plus (char 0) (quotient (add1 RowLoc) 10))) (PBOUT (plus (char 0) (remainder (add1 RowLoc) 10))) % Delimiter between row digits and column digits. (PBOUT (char !;)) (PBOUT (plus (char 0) (quotient (add1 ColLoc) 10))) (PBOUT (plus (char 0) (remainder (add1 ColLoc) 10))) (PBOUT (char H)) % Terminate the sequence )) |
Added psl-1983/emode/buffer-position.sl version [128157171b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % BUFFER-POSITION.SL - EMODE Buffer Position Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % % This file implements objects that store buffer positions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load common)) (fluid '(CurrentLineIndex point)) (de buffer-position-create (line-number column-number) (cons line-number column-number)) (de buffer-position-line (bp) (car bp)) (de buffer-position-column (bp) (cdr bp)) (de buffer-position-compare (bp1 bp2) (cond ((< (buffer-position-line bp1) (buffer-position-line bp2)) -1) ((> (buffer-position-line bp1) (buffer-position-line bp2)) 1) ((< (buffer-position-column bp1) (buffer-position-column bp2)) -1) ((> (buffer-position-column bp1) (buffer-position-column bp2)) 1) (t 0))) (de buffer-get-position () (buffer-position-create CurrentLineIndex point)) (de buffer-set-position (bp) (if bp (progn (PutLine) (setf CurrentLineIndex (buffer-position-line bp)) (setf point (buffer-position-column bp)) (GetLine CurrentLineIndex) ))) |
Added psl-1983/emode/buffer.sl version [38f6b97868].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Buffer.SL - Individual Buffer Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 July 1982 % % This file contains functions that manipulate individual buffers. % It is intended that someday EMODE will be reorganized % so that all such functions will eventually be in this file. % % This file requires COMMON. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(CurrentLine CurrentBufferSize CurrentLineIndex point)) (de char-blank? (ch) (or (= ch (char space)) (= ch (char tab)))) (de current-line-length () (length CurrentLine)) (de current-line-empty () (= (length CurrentLine) 0)) (de current-line-blank? () (for (in ch CurrentLine) (always (char-blank? ch)) )) (de at-buffer-end? () (and (current-line-is-last?) (= point (current-line-length)))) (de at-buffer-start? () (and (= CurrentLineIndex 0) (= point 0))) (de current-line-is-last? () (>= CurrentLineIndex (- CurrentBufferSize 1))) (de current-line-is-first? () (= CurrentLineIndex 0)) (de current-line-fetch (n) (car (pnth CurrentLine (+ n 1)))) (de current-line-store (n c) (setf CurrentLine (InsertListEntry (DeleteListEntry CurrentLine n) n c))) (de current-buffer-size () % Return the number of lines in the current buffer. Note that if the % buffer does not end with an incomplete line, then its last line will % be empty. (See CURRENT-BUFFER-VISIBLE-SIZE, which corrects for this % anomaly.) CurrentBufferSize) (de current-buffer-visible-size () % Return the visible number of lines in the current buffer. In other words, % don't count the last line if it is empty, since that is just an artifact of % the buffer representation. (let* ((buffer-size CurrentBufferSize) (last-line-index (- buffer-size 1)) ) (if (= CurrentLineIndex last-line-index) % CurrentLine hack! (if CurrentLine buffer-size (- buffer-size 1)) (if (>= (size (GetBufferText last-line-index)) 0) buffer-size (- buffer-size 1)) ))) (de current-buffer-goto (line-number char-number) (SelectLine line-number) (setf point char-number) ) (de move-to-next-line () (let ((next-index (+ CurrentLineIndex 1))) (cond ((< next-index CurrentBufferSize) (SelectLine next-index) (setf point 0)) (t (setf point (length CurrentLine)) (PutLine)) ))) (de move-to-previous-line () (let ((next-index (- CurrentLineIndex 1))) (cond ((>= next-index 0) (SelectLine next-index) (setf point 0)) (t (setf point 0) (PutLine)) ))) |
Added psl-1983/emode/buffers.sl version [871a247934].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Buffers.SL - Buffer Collection Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 July 1982 % % Further changes by Will Galway, University of Utah. % This file contains functions that manipulate the set of existing % buffers. It is intended that someday EMODE will be reorganized % so that all such functions will eventually be in this file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 5-Aug-82, WFG: % Some functions moved here from EMODE1.RED, changes made to % support arbitrary "data-modes". (load common) (fluid '(declared_data_modes BufferNames CurrentBufferName)) (setf declared_data_modes NIL) % Declare (or redeclare) a "data-mode" name and associated routine for % creating a buffer of that mode. % Also see "declare_file_mode", used to associate data modes with filenames % (or "file extensions"). (de declare_data_mode (name buffer-creator) (let ((old-decl (Ass (function string-equal) name declared_data_modes))) (cond (old-decl (setf (cdr old-decl) buffer-creator)) (T (setf declared_data_modes (cons (cons name buffer-creator) declared_data_modes)))))) % Create a buffer with name given by BufferName (an identifier), using % routine buffer-creator to create the buffer's environment. Puts the % (name . environment) pair into "BufferNames" alist, returns the % environment. (de CreateBuffer (BufferName buffer-creator) (cond ((atsoc BufferName BufferNames) % Complain if the buffer already exists. (EMODEError (list "Buffer" BufferName "exists"))) % Otherwise, enter the (name . environment) pair into the association % list of buffers. (T (let ((env (apply buffer-creator NIL))) (setf BufferNames (cons (cons BufferName env) BufferNames)) env)))) % Switch to a new current buffer, creating it if necessary. (But without % establishing that buffer's keyboard bindings.) Use buffer-creator to % create the buffer, or ask the user for a hint if buffer-creator is NIL. % Create a "view" of the selected buffer, "destroying" the "current view". % NEED TO contrast this with "SelectBuffer", which (in effect) gives us an % "invisible view" (or "internal view"?) of a buffer? (A "view" to be used % for internal purposes, rather than for use from the keyboard.) (de select_or_create_buffer (buffer-name buffer-creator) (cond % Don't do anything if trying to select the "current buffer". ((not (eq buffer-name CurrentBufferName)) (prog (new-env) (return (cond % Just select the buffer if it's already present. ((setf new-env (atsoc buffer-name BufferNames)) (setf new-env (cdr new-env)) % get cdr of (name . env) % Now "look into" the newly selected buffer. % Get rid of the current "view", replace it with the new % view. Go through fancy foot work to create new view in % context of current view. (let ((new-view (apply (cdr (atsoc 'buffers_view_creator new-env)) (list buffer-name)))) (remove_current_view) (SelectWindow new-view))) % Otherwise, create the new buffer if not already around. (T (while (null buffer-creator) (let ((mode-name (prompt_for_string (BldMsg "Mode for buffer %w: " buffer-name) % Default mode-name is "text", should this be % parameterized? "text" ))) % Use "generalized assoc" function to look up the % associated creator, if any. (setf buffer-creator (Ass (function string-equal) mode-name declared_data_modes)) % "Beep" if unknown mode-name (and ask again). (cond ((null buffer-creator) (ding)) % Otherwise, extract "good part" of (mode-name . % buffer-creator) pair. (T (setf buffer-creator (cdr buffer-creator)))))) (show_message (BldMsg "Creating buffer %w" buffer-name)) (setf new-env (CreateBuffer buffer-name buffer-creator)) % Get rid of the current "view", replace it with the new view. (let ((new-view (apply (cdr (atsoc 'buffers_view_creator new-env)) (list buffer-name)))) (remove_current_view) (SelectWindow new-view))))))))) % "Choose" a buffer (name taken from keyboard), make it the current buffer % and establish its mode as the current mode. (de ChooseBuffer () (let ((buffer-name (String-UpCase (prompt_for_string "Buffer Name: " last_buffername)))) % Strings with 1 character have size 0, avoid creating something with % the empty string for a name! (cond ((Geq (size buffer-name) 0) % Set up new default buffername for next ChooseBuffer. (setf last_buffername (Id2String CurrentBufferName)) (select_or_create_buffer (intern buffer-name) NIL) (EstablishCurrentMode))))) % Create a (default) "view" (or "window") into a text buffer. Details of % the window location (etc?) depend on the current window layout. (de create_text_view (buffer-name) (cond % If the current buffer also uses a "text view". ((eq buffers_view_creator (function create_text_view)) % Just modify (destructively) the current "view" (or "window") % environment to look into the new buffer, return the current % environment. (SelectBuffer buffer-name) % Let window know what buffer it's looking into (wierd)! (setf WindowsBufferName buffer-name) % Save (and return) the current "view" environment. (SaveEnv CurrentWindowDescriptor)) % Otherwise (if current view isn't into "text"), create a framed window % of an appropriate size and at an appropriate location. % (For lack of a better idea, just use a window like that used by "two % window" mode.) (T % Make sure two_window_midpoint is a reasonable value. (cond ((or (not (numberp two_window_midpoint)) (LessP two_window_midpoint 3) (GreaterP two_window_midpoint (difference (row ScreenDelta) 5))) (setf two_window_midpoint (fix (times 0.5 (difference (row ScreenDelta) 2)))))) (FramedWindowDescriptor buffer-name % Upper left corner (coords (sub1 (Column ScreenBase)) (plus (Row ScreenBase) two_window_midpoint 1)) (coords (plus 2 (Column ScreenDelta)) (plus (difference (row ScreenDelta) two_window_midpoint) -2)))))) % Declare the routine for creating "text mode" buffers. (declare_data_mode "text" 'create_text_buffer) % Return the environment for a "raw" text buffer (everything except % keyboard bindings). (de create_raw_text_buffer () % Environment bindings for this buffer. % May prefer to use backquote to do this, but current version is buggy % for lists of the form `( (a .b) ). Also, it's important not to share % any substructure with other alists built by this routine. (list % The following 4 "per buffer" variables should be defined for a buffer % of any "data mode". Also need to define ModeEstablishExpressions, % but that's left to the caller of this routine. (cons 'buffers_view_creator 'create_text_view) (cons 'buffers_file_reader 'read_channel_into_text_buffer) (cons 'buffers_file_writer 'write_text_buffer_to_channel) (cons 'buffers_file NIL) % Name of file associated with buffer. % Variables unique to "text data mode" follow. % Initial vector allows only one line. (Should really be parameterized % somehow?) (cons 'CurrentBufferText (MkVect 0)) % 0 is upper bound, one element. (cons 'CurrentBufferSize 1) % Start with one line of text (but zero % characters in the line! ) (cons 'CurrentLine NIL) (cons 'CurrentLineIndex 0) (cons 'point 0) % MarkLineIndex corresponds to CurrentLineIndex, but for "mark". (cons 'MarkLineIndex 0) (cons 'MarkPoint 0) % Corresponds to "point". )) % Create a text buffer--uses "raw text" environment "plus" keyboard % bindings appropriate for "text". (de create_text_buffer () (cons (cons 'ModeEstablishExpressions FundamentalTextMode) (create_raw_text_buffer))) (declare_data_mode "rlisp" 'create_rlisp_buffer) (declare_data_mode "lisp" 'create_lisp_buffer) % Return the environment for a new "Rlisp" buffer. (de create_rlisp_buffer () % Same as "text buffer" but with a different keyboard dispatch table. (cons (cons 'ModeEstablishExpressions RlispMode) (create_raw_text_buffer))) % Return the environment for a new "lisp" buffer. (de create_lisp_buffer () (cons (cons 'ModeEstablishExpressions LispMode) (create_raw_text_buffer))) (de buffer-create (buffer-name buffer-creator) % Create a new buffer. The name of the new buffer will be the specified name % if no buffer already exists with that name. Otherwise, a similar name will % be chosen. The actual buffer name is returned. The buffer is not % selected. (setq buffer-name (buffer-make-unique-name buffer-name)) (CreateBuffer buffer-name buffer-creator) buffer-name ) (de buffer-make-unique-name (buffer-name) % Return a buffer name not equal to the name of any existing buffer. (for* (with (root-name (string-concat (id2string buffer-name) "-"))) (for count 0 (+ count 1)) (for name buffer-name (intern (string-concat root-name (BldMsg "%d" count)))) (do (if (not (buffer-exists name)) (exit name))) )) (de buffer-exists (buffer-name) (atsoc buffer-name BufferNames)) (de buffer-kill (buffer-name) (if (and (buffer-exists buffer-name) (> (length BufferNames) 1)) (progn (setq BufferNames (DelatQ buffer-name BufferNames)) (if (eq CurrentBufferName buffer-name) (progn (setq CurrentBufferName nil) (SelectBuffer (car (car BufferNames))))) (if (eq WindowsBufferName buffer-name) (setq WindowsBufferName CurrentBufferName)) )) ) (de select-buffer-if-existing (buffer-name) % This function will select and establish the specified buffer, if it exists. % Otherwise, it will select and establish an arbitrary existing buffer. (prog (buffer-env) (if (setq buffer-env (atsoc buffer-name BufferNames)) (setq buffer-env (cdr buffer-env)) (if (setq buffer-env (atsoc 'MAIN BufferNames)) (progn (setq buffer-name 'MAIN) (setq buffer-env (cdr buffer-env))) (progn (setq buffer-name (car (car BufferNames))) (setq buffer-env (cdr (car BufferNames))) ) )) (if CurrentBufferName (DeSelectBuffer CurrentBufferName)) (RestoreEnv buffer-env) (setq CurrentBufferName buffer-name) (EstablishCurrentMode) )) |
Added psl-1983/emode/build-emode.csh version [4608c70986].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | #! /bin/csh -f # Build a compiled version of EMODE for Vax Unix. # # This builds a "COMPLETE SYSTEM"--modifying Rlisp to use the "Rlisp # interface". rlisp << 'EOF' # Portable Standard Lisp version of RLISP load Useful$ % Don Morrison's utilities. load Nstruct$ % Routines for structures. load common$ load SysLisp$ load If!-System$ % Routines for condition exectution based on machine. OFF USERMODE$ % So we can redefine things. % Cause constants and structures to be defined at both compile and runtime. flag( '(DefStruct DefConst), ' EVAL); % Build EMODE in two parts, due to size problems with FASL % builder. (May be unnecessary these days.) % emode-b-1.b and emode-b-2.b are to be loaded with emode.lap. faslout "emode-b-1"$ in "emode-files-1.r"; faslend; faslout "emode-b-2"$ in "emode-files-2.r"; !*GC := NIL$ % Turn off garbage collection messages after % EMODE is loaded, since printing messages % causes consing. faslend; quit; 'EOF' |
Added psl-1983/emode/build-emode.ctl version [a494058b2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ! Build a compiled version of EMODE for the DEC-20. ! ! Use DO or SUBMIT to "run" this file. ! ! Make sure you define the necessary logical names in your BATCH.CMD file. ! The best way is to include a line something like the following: ! @take <PSL>LOGICAL-NAMES.CMD ! @define DSK: DSK:, PE: @PSL:RLISP ! Portable Standard Lisp version of RLISP *load Useful$ % Don Morrison's utilities *load NSTRUCT$ % Routines for structures *load common$ % Common-Lisp compatibility package *load SysLisp$ *load If!-System$ % Allow conditional compilation based on machine type. *load monsym$ % Define JSYS stuff *load jsys$ % Still more JSYS stuff *OFF USERMODE$ % So we can redefine things. * * % Cause constants and structures to be defined at both compile and * % runtime???? * FLAG( '(DefStruct DefConst), ' EVAL); % Space after ' in case of MIC * * % Build EMODE in two parts, due to size problems with FASL * % builder. (May be unnecessary these days.) * % EMODE-B-1 and EMODE-B-2 are to be loaded with EMODE.LAP. *FASLOUT "EMODE-B-1"$ * IN "EMODE-FILES-1.RED"; *FASLEND; * *FASLOUT "EMODE-B-2"$ * IN "EMODE-FILES-2.RED"; * !*GC := NIL$ % Turn off garbage collection messages after * % EMODE is loaded, since printing messages * % causes consing. *FASLEND; * *QUIT$ |
Added psl-1983/emode/customize-rlisp-for-emode.sl version [09b53f9f66].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CUSTOMIZE-RLISP-FOR-EMODE.SL - "customizations" to support EMODE. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 July 1982 % Copyright (c) 1982 University of Utah % % This file makes a few changes to the "innards" of RLISP to customize it % for the building of EMODE. Also adds a few utilities that should % (perhaps) become part of the standard PSL. % Set things up so SETF knows about IGETV and IGETS. ("Fast" string and % vector accessors.) (BothTimes % BothTimes? (progn (put 'IGETV 'ASSIGN-OP 'IPUTV) (put 'IGETS 'ASSIGN-OP 'IPUTS))) % Return true is x is a "list". (I.e., a pair or NIL.) (de listp (x) (or (null x) (pairp x))) % Return lst with its first n entries dropped. (de tail (lst n) (cond ((null lst) NIL) ((eqn n 0) lst) (T (tail (cdr lst) (sub1 n))))) % Routines for reading from and printing into strings. (fluid '( string_for_read_from_string index_for_string string_input_channel string_output_channel print_dest_string print_indx flush_output)) % Set up the channels at load time. (LoadTime (progn (setf SpecialWriteFunction* 'ReadOnlyChannel) (setf SpecialReadFunction* 'channel_read_from_string) (setf SpecialCloseFunction* 'DummyClose) (setf string_input_channel (open "string_reader" 'SPECIAL)) (setf SpecialWriteFunction* 'channel_write_into_string) (setf SpecialReadFunction* 'WriteOnlyChannel) (setf string_output_channel (open "string_writer" 'SPECIAL)))) % READ from a string. Argument is a fluid. (de read_from_string (string_for_read_from_string) (prog (index_for_string value) (setf index_for_string 0) % index_for_string is also fluid. % Kludge to flush out input channel. (ChannelUnReadChar string_input_channel 0) % Read the value from the "magic" string reading channel. % Use ErrorSet to catch problems (such as trying to read an unbalanced % expression). Rebind fluid !*BREAK to prevent a break loop if the % read fails. (let ((*BREAK NIL)) (setf value (ErrorSet `(channelRead ,string_input_channel) T % Allow error messages to be printed NIL))) % but, don't print backtrace stuff. (return (cond ((pairp value) (car value)) % If there was an error in reading the string, just return NIL??? % Or, pass the error on down? (T NIL))))) % Ignore the channel argument, read next character from string in fluid % "string_for_read_from_string", if any. Return an end of file if none % left. (de channel_read_from_string (chn) (prog (val) (cond % If past end of string, return an EOF. ((GreaterP index_for_string (size string_for_read_from_string)) (return (char EOF)))) % Otherwise, return the appropriate character from the string. (setf val (indx string_for_read_from_string index_for_string)) (setf index_for_string (add1 index_for_string)) (return val))) % PrintF into the string "print_dest_string", starting at index % "print_indx". (Both of which are FLUIDS.) Return the "printed into" % string. This code should probably be made more efficient (SysLispified?) % someday. Also, the number of legal arguments is sort of flakey. Roughly % modeled after the code for BldMsg. (de PrintF_into_string (print_dest_string print_indx format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10) (prog old_outchan % Switch to special channel for printing into strings. (setf old_outchan OUT*) (setf OUT* string_output_channel) % Kludge to clear the line position counter (setf flush_output T) (WriteChar (char EOL)) (setf flush_output NIL) % Now use PrintF to the appropriate "magic" channel. (PrintF format arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10) % Select original channel (setf OUT* old_outchan) % Return the printed into string. (return print_dest_string))) (de channel_write_into_string (chn chr) % Ignore the channel argument, write character into fluid % "print_dest_string", at location print_indx. % We're careful to check bounds, since bad things could happen if we try to % print an error message during this process! (cond % If "flush" flag is clear, and everything is within bounds. ((and (null flush_output) (leq 0 print_indx) (leq print_indx (size print_dest_string))) % then print into the string (progn (setf (indx print_dest_string print_indx) chr) (setf print_indx (add1 print_indx)))))) % Dummy routine to close up channel I/O. (de DummyClose (chn) NIL) |
Added psl-1983/emode/directory.sl version [81bda1dc01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Directory.SL - File Directory and related file primitives % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 13 July 1982 % % *** THIS FILE IS TOPS-20 SPECIFIC *** % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common jsys useful)) (de find-matching-files (filename include-deleted-files) % Return a list describing all files that match the specified filename. The % filename may specify a directory and/or may contain wildcard characters. % Each element of the returned list corresponds to one matching file. The % format of each list element is: % (file-name full file name string % deleted-flag T or NIL % file-size integer count of pages in file % write-date integer representing date/time of last write % read-date integer representing date/time of last read % ) (setf filename (fixup-directory-name filename)) (let (jfn-word jfn file-name deleted-flag file-size write-date read-date) (cond ((and (stringp filename) (listp (setf jfn-word (ErrorSet (list 'jsys1 (if include-deleted-files #.(bits 2 8 11 13 17) #.(bits 2 11 13 17)) filename 0 0 (const jsGTJFN)) nil nil)))) (setf jfn-word (first jfn-word)) (for* (while (>= jfn-word 0)) (do (setf jfn (lowhalfword jfn-word)) (setf file-name (MkString 100 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 (const jsJFNS)) (setf file-name (recopystringtonull file-name)) (setf deleted-flag (jfn-deleted? jfn)) (setf file-size (jfn-page-count jfn)) (setf write-date (jfn-write-date jfn)) (setf read-date (jfn-read-date jfn)) ) (collect (list file-name deleted-flag file-size write-date read-date )) (do (if (FixP (ErrorSet (list 'jsys1 jfn-word 0 0 0 (const jsGNJFN)) NIL NIL)) (setf jfn-word -1))) )) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de file-deleted-status (file-name) % Return either: EXISTS, DELETED, NIL (let ((jfn (ErrorSet (list 'jsys1 #.(bits 2 8 17) file-name 0 0 (const jsGTJFN)) nil nil) )) (cond ((listp jfn) (setf jfn (car jfn)) (prog1 (if (jfn-deleted? jfn) 'deleted 'exists) (jsys0 jfn 0 0 0 (const jsRLJFN)) ) ) ))) (de file-delete (file-name) (let ((jfn (ErrorSet (list 'jsys1 #.(bits 2 17) file-name 0 0 (const jsGTJFN)) nil nil) )) (cond ((listp jfn) (setf jfn (car jfn)) (jsys0 jfn 0 0 0 (const jsDELF)) ) ))) (de file-undelete (file-name) (let ((jfn (ErrorSet (list 'jsys1 #.(bits 2 8 17) file-name 0 0 (const jsGTJFN)) nil nil) )) (cond ((listp jfn) (setf jfn (car jfn)) (jsys0 (xword 1 jfn) #.(bits 3) 0 0 (const jsCHFDB)) (jsys0 jfn 0 0 0 (const jsRLJFN)) ) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % JFN Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de jfn-deleted? (jfn) (not (= (LAnd (Jsys4 jfn #.(xword 1 1) 4 0 (const jsGTFDB)) (bits 3)) 0))) (de jfn-write-date (jfn) (Jsys4 jfn #.(xword 1 8#14) 4 0 (const jsGTFDB))) (de jfn-read-date (jfn) (Jsys4 jfn #.(xword 1 8#15) 4 0 (const jsGTFDB))) (de jfn-byte-count (jfn) (Jsys4 jfn #.(xword 1 8#12) 4 0 (const jsGTFDB))) (de jfn-page-count (jfn) (lowhalfword (Jsys4 jfn #.(xword 1 8#11) 4 0 (const jsGTFDB)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de file-date-to-string (fdate) % Convert a file date as returned by find-matching-files to a meaningful % string. Note that 0 is converted to the string "Never". All returned % strings are 18 characters long, right justified. (if (= fdate 0) " Never" (let ((buf (MkString 30 (char space)))) (Jsys0 buf fdate 0 0 (const jsODTIM)) (recopystringtonull buf)))) (de fixup-directory-name (name) % If NAME is an unadorned directory or device name, append wild cards to it % so that it will match all files in the specified directory or directories. (let ((n (add1 (size name)))) (cond ((or (= n 0) (= (indx name (- n 1)) (char :)) (= (indx name (- n 1)) (char >)) ) (concat name "*.*.*")) (t name)))) (de fixup-file-name (name) % Make the specified file name nice to print. % Remove any control characters (especially ^V). (for (in ch (String2List name)) (with the-list) (when (GraphicP ch)) (collect ch the-list) (returns (List2String the-list)) )) (de trim-filename-to-prefix (s) % Remove trailing characters until the string ends with % a device or directory prefix. (for* (from i (size s) 0 -1) (for ch (indx s i) (indx s i)) (until (or (= ch (char !:)) (= ch (char !>)))) (returns (sub s 0 i)) )) |
Added psl-1983/emode/dired.sl version [dc65a61f25].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DIRED.SL - Directory Editor Subsystem for EMODE % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 July 1982 % % This file implements a directory editor subsystem. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common strings directory gsort)) (fluid '(CurrentLineIndex point WindowsBufferName BufferPreviousBuffer BufferAuxiliaryInfo CurrentBufferName DefaultMode buffers_file)) (fluid '(DiredMode)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Macros %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro fi-full-name (fi) `(nth ,fi 1)) % string for file primitives (defmacro fi-deleted? (fi) `(nth ,fi 2)) % is file marked 'deleted'? (defmacro fi-size (fi) `(nth ,fi 3)) % "size" of file (defmacro fi-write-date (fi) `(nth ,fi 4)) % date/time file last written (defmacro fi-read-date (fi) `(nth ,fi 5)) % date/time file last read (defmacro fi-nice-name (fi) `(nth ,fi 6)) % string to show user %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf DiredMode '((SetKeys DiredDispatchList) (SetKeys ReadOnlyTextDispatchList) (SetKeys RlispDispatchList) (SetKeys BasicDispatchList))) (setf DiredDispatchList (list % These are the DIRED-specific commands. (cons (char ?) 'dired-help) (cons (char C) 'dired-srccom-file) (cons (char D) 'dired-delete-file) (cons (char E) 'dired-edit-file) (cons (char H) 'dired-automatic-delete) (cons (char K) 'dired-delete-file) (cons (char N) 'dired-next-hog) (cons (char Q) 'dired-exit) (cons (char R) 'dired-reverse-sort) (cons (char S) 'dired-sort) (cons (char U) 'dired-undelete) (cons (char X) 'dired-exit) (cons (char rubout) 'dired-reverse-undelete) (cons (char space) '$ForwardLine) (cons (char (cntrl D)) 'dired-delete-file) (cons (char (cntrl K)) 'dired-delete-file) )) (de dired-command () (write-prompt "") (let* ((directory-name (prompt_for_string "Directory to edit: " buffers_file)) file-list ) (write-prompt "Reading directory(ies)...") (setf file-list (find-matching-files directory-name t)) (if (null file-list) (write-prompt (BldMsg "No files match: %w" directory-name)) % ELSE (dired-fixup-file-list file-list) (SelectBuffer (buffer-create '*Dired DiredMode)) (setf BufferPreviousBuffer WindowsBufferName) (setf BufferAuxiliaryInfo file-list) (setf buffers_file directory-name) (load-dired-buffer BufferAuxiliaryInfo) (setf WindowsBufferName CurrentBufferName) (EstablishCurrentMode) (write-prompt "") ) ) ) (de dired-fixup-file-list (file-list) % Adds to each element: % A cleaned-up file name for display and sorting purposes. (for (in file-info file-list) (do (aconc file-info (fixup-file-name (fi-full-name file-info))) )) (let ((prefix (if file-list (fi-nice-name (first file-list)) "")) prefix-length name) (for (in file-info file-list) (do (setf prefix (string-largest-common-prefix prefix (fi-nice-name file-info)) )) ) (setf prefix (trim-filename-to-prefix prefix)) (setf prefix-length (+ 1 (size prefix))) (for (in file-info file-list) (do (setf name (fi-nice-name file-info)) (setf (fi-nice-name file-info) (sub name prefix-length (- (size name) prefix-length)))) )) ) (de load-dired-buffer (file-list) ($DeleteBuffer) (for* (in file-info file-list) (do (insert_string (file-info-to-string file-info)) ($CRLF)) ) (setf point 0) (SelectLine 0) ) (de file-info-to-string (file-info) (let ((first-part (if (fi-deleted? file-info) "D " " ")) (file-name (string-pad-right (fi-nice-name file-info) 34)) (file-size (string-pad-left (BldMsg "%d" (fi-size file-info)) 4)) (write-date (file-date-to-string (fi-write-date file-info))) (read-date (file-date-to-string (fi-read-date file-info)))) (string-concat first-part file-name file-size " " write-date " " read-date) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED command procedures: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-exit () (let* ((actions (dired-determine-actions BufferAuxiliaryInfo)) command ) (if (and (null (first actions)) (null (second actions))) (window-kill-buffer) % else (setf command (dired-present-actions actions)) (cond ((eq command 'exit) (window-kill-buffer)) ((eq command t) (dired-perform-actions actions) (window-kill-buffer)) ) ))) (de dired-delete-file () % Mark the current file as deleted. (cond ((current-line-empty) (Ding)) (t (if (= (current-line-fetch 0) (char space)) (current-line-store 0 (char D))) (move-to-next-line) ))) (de dired-undelete () % Unmark the current file. (cond ((current-line-empty) (Ding)) (t (if (= (current-line-fetch 0) (char D)) (current-line-store 0 (char space))) (move-to-next-line) ))) (de dired-reverse-undelete () % Unmark the previous file. (cond ((= CurrentLineIndex 0) (Ding)) (t (move-to-previous-line) (if (= (current-line-fetch 0) (char D)) (current-line-store 0 (char space))) ))) (de dired-help () (write-prompt "DIRED: D-delete, U-undelete, E-edit file, S-sort, R-reverse sort, Q-exit") ) (de dired-next-hog () (write-prompt "The DIRED NEXT HOG command is unimplemented.") (Ding) ) (de dired-automatic-delete () (write-prompt "The DIRED AUTOMATIC DELETE command is unimplemented.") (Ding) ) (de dired-edit-file () (write-prompt "") (if (not (dired-valid-line)) (Ding) (let* ((file-info (nth BufferAuxiliaryInfo (+ CurrentLineIndex 1))) (file-name (fi-full-name file-info)) (old-buffer CurrentBufferName) ) (find-file file-name) (setf BufferPreviousBuffer old-buffer) (write-prompt "C-M-L returns to DIRED; C-X K kills buffer and returns.") ) ) ) (de dired-reverse-sort () (write-prompt "Reverse Sort by ") (while t (let ((ch (RaiseChar (GetNextCommandCharacter)))) (cond ((= ch (char F)) (dired-perform-sort "Reverse Sort by Filename" 'dired-filename-reverser) (exit)) ((= ch (char S)) (dired-perform-sort "Reverse Sort by Size" 'dired-size-reverser) (exit)) ((= ch (char W)) (dired-perform-sort "Reverse Sort by Write date" 'dired-write-reverser) (exit)) ((= ch (char R)) (dired-perform-sort "Reverse Sort by Read date" 'dired-read-reverser) (exit)) ((= ch (char ?)) (write-prompt "Reverse Sort by (Filename, Size, Read date, Write date) ") (next)) (t (write-prompt "") (Ding) (exit)) )))) (de dired-sort () (write-prompt "Sort by ") (while t (let ((ch (RaiseChar (GetNextCommandCharacter)))) (cond ((= ch (char F)) (dired-perform-sort "Sort by Filename" 'dired-filename-sorter) (exit)) ((= ch (char S)) (dired-perform-sort "Sort by Size" 'dired-size-sorter) (exit)) ((= ch (char W)) (dired-perform-sort "Sort by Write date" 'dired-write-sorter) (exit)) ((= ch (char R)) (dired-perform-sort "Sort by Read date" 'dired-read-sorter) (exit)) ((= ch (char ?)) (write-prompt "Sort by (Filename, Size, Read date, Write date) ") (next)) (t (write-prompt "") (Ding) (exit)) )))) (de dired-srccom-file () (write-prompt "The DIRED SRCCOM command is unimplemented.") (Ding) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-valid-line () (and (>= CurrentLineIndex 0) (> (current-line-length) 60) (= (current-line-fetch 1) (char space)))) (de dired-determine-actions (file-list) % Return a list containing two lists: the first a list of % file names to be deleted, the second a list of file names % to be undeleted. (let ((old-line CurrentLineIndex)) (SelectLine 0) (prog1 (for* (in file-info file-list) (with delete-list undelete-list file-name file-status desired-status) (do (setf file-name (fi-full-name file-info)) (setf file-status (file-deleted-status file-name)) (setf desired-status (current-line-fetch 0)) (move-to-next-line) (if file-status (cond ((and (eq file-status 'deleted) (= desired-status (char space))) (setf undelete-list (append undelete-list (list file-name)))) ((and (neq file-status 'deleted) (= desired-status (char D))) (setf delete-list (append delete-list (list file-name)))) ))) (returns (list delete-list undelete-list)) ) (SelectLine old-line)))) (de dired-present-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ch) % This is a terrible way of outputting information, but it is % the way EMODE already does it. (SelectOldChannels) (ClearScreen) (dired-present-list delete-list "These files to be deleted:") (dired-present-list undelete-list "These files to be undeleted:") (prog1 (while t (printf "%nDo It (YES, N, X)? ") (setf ch (get-upchar)) (cond ((= ch (char Y)) (if (= (get-upchar) (char E)) (if (= (get-upchar) (char S)) (exit T) (Ding) (next)) (Ding) (next)) ) ((= ch (char N)) (exit NIL)) ((= ch (char X)) (exit 'EXIT)) ((= ch (char ?)) (printf "%n YES-Do it, N-Return to DIRED, X-Exit from DIRED.") ) (t (Ding)) )) (ClearScreen) ) )) (de get-upchar () (let ((ch (GetNextCommandCharacter))) (cond ((AlphaP ch) (setf ch (char-upcase ch)) (WriteChar ch) ch) (t ch)))) (de dired-present-list (list prompt) (if list (progn (printf "%w%n" prompt) (for (in item list) (for count 0 (if (= count 1) 0 (+ count 1))) (do (printf "%w" (string-pad-right item 38)) (if (= count 1) (printf "%n")) ) ) (printf "%n") ))) (de dired-perform-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ) (for (in file delete-list) (do (file-delete file))) (for (in file undelete-list) (do (file-undelete file))) )) (de dired-perform-sort (prompt sorter) (write-prompt prompt) (setf BufferAuxiliaryInfo (GSort BufferAuxiliaryInfo sorter)) (load-dired-buffer BufferAuxiliaryInfo) ) (de dired-filename-sorter (f1 f2) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) (de dired-filename-reverser (f1 f2) (StringSortFn (fi-nice-name f2) (fi-nice-name f1))) (de dired-size-sorter (f1 f2) (or (< (fi-size f1) (fi-size f2)) (and (= (fi-size f1) (fi-size f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) (de dired-size-reverser (f1 f2) (or (> (fi-size f1) (fi-size f2)) (and (= (fi-size f1) (fi-size f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) (de dired-write-sorter (f1 f2) (or (< (fi-write-date f1) (fi-write-date f2)) (and (= (fi-write-date f1) (fi-write-date f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) (de dired-write-reverser (f1 f2) (or (> (fi-write-date f1) (fi-write-date f2)) (and (= (fi-write-date f1) (fi-write-date f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) (de dired-read-sorter (f1 f2) (or (< (fi-read-date f1) (fi-read-date f2)) (and (= (fi-read-date f1) (fi-read-date f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) (de dired-read-reverser (f1 f2) (or (> (fi-read-date f1) (fi-read-date f2)) (and (= (fi-read-date f1) (fi-read-date f2)) (StringSortFn (fi-nice-name f1) (fi-nice-name f2))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Useful String Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de string-pad-right (s desired-length) (let ((len (string-length s))) (if (< len desired-length) (string-concat s (make-string (- desired-length len) (char space))) s))) (de string-pad-left (s desired-length) (let ((len (string-length s))) (if (< len desired-length) (string-concat (make-string (- desired-length len) (char space)) s) s))) (de string-largest-common-prefix (s1 s2) (for (from i 0 (min (size s1) (size s2)) 1) (while (= (indx s1 i) (indx s2 i))) (returns (sub s1 0 (- i 1))) )) |
Added psl-1983/emode/dispatch.doc version [0de6eabd34].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Notes on Defining Commands and Modes Cris Perdue 8/9/82 File: pe:dispatch.doc These notes should be of use to anyone wishing to customize EMODE by defining commands (keystrokes) or new modes. Most of the current mode and keystroke definitions are contained in PE:DISPCH.SL. Read it for examples and the keystroke-function associations. define_prefix_character(char, prompt) Char must be a single character, possibly with Control and/or Meta turned on. This is used for "true prefix characters" such as CTRL-X and META-X, not prefixes for obtaining control or meta through multiple keystrokes. Those are defined using AddToKeyList and EstablishCurrentMode. AddToKeyList(listname, char, opr) Adds a keystroke-operation association to a "key list", whose name, an atom, is passed in. The value of the atom must be the actual list. See the information on CharSequence, below, for the format of the chr parameter. The opr must be a function of no arguments. Its value is ignored. AddToKeyList may also be used to change an association in a keylist. Three existing lists are BasicDispatchList, ReadOnlyTextDispatchList, and TextDispatchList. BasicDispatchList includes commands that do not modify the buffer and do not have to do with manipulating text in any way. ReadOnlyTextDispatchList contains the commands that have to do with manipulating text, but that do not modify the buffer. This list is for support of read-only buffers. TextDispatchList contains commands that modify the buffer. CharSequence([char]) This is a macro analogous to "char". Where char takes a single "character specification", CharSequence takes a sequence. Both char and CharSequence forms may be used in the specification of KeyLists. At present two characters is the maximum sequence, due to the implementation of the actual dispatcher used when the user types commands to EMODE. SetKey(char opr) It is generally a mistake to use this function directly, but it is used internally be EstablishCurrentMode to activate a keylist. Takes a character as produced by "char" or a character sequence as produced by "CharSequence" and installs it in the (global) command key lookup tables. The first character of any character sequence must be defined as a prefix character. If the specified character is upper case, the corresponding lower case character is also defined. Does not add the definition to any mode, nor permanently to the buffer, so use things like AddToKeyList at user level. MODES AlterBufferEnv(BufferName, 'ModeEstablishExpressions, Exprs) Every buffer carries around an environment, which includes a list of PSL expressions that set up its current mode. To change modes, alter the ModeEstblishExpressions part of the buffer's environment as shown. The expressions will be evaluated in reverse order (first one last) immediately and then whenever the mode is "established" with EstablishCurrentMode. See PE:DISPCH.SL for examples of modes, including FundamentalTextMode. Expressions of the form (SetKeys <variable>) set up the keystroke-operation associations in a keylist. EstablishCurrentMode() Activates the current mode with its keylists. Key definitions made by AddToKeyList don't take effect until this is performed even if the keylist changed is part of the current mode. |
Added psl-1983/emode/dispch.sl version [014aa22617].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DISPCH.SL - Dispatch table utilities % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 July 1982 % Copyright (c) 1982 University of Utah % % The dispatch table (determining "keyboard bindings") is the 256 element % vector "MainDispatch", AUGMENTED by association lists for C-X % (and possibly other prefix) characters. We actually use an association % list of association lists: the top level is a list of % (prefixchar . association-list), the second level is a list of % (character_to_follow_prefix_char . procedure). Associated with every % buffer is a list of forms to evaluate which will establish that buffer's % mode(s)--namely, the keyboard bindings that are in effect for that % buffer. % csp 7/7/82 % - Put all dispatch list and mode functions together, and collected % some into this file from EMODE1. % - Modified EstablishCurrentMode to invoke DefinePrefixChars directly. % Generalized the idea of adding to a dispatch list with the function % AddToKeyList. % - Modified mode lists to EVAL entries rather than APPLYing functions % to NIL. % AS 7/12/82 % - Added C-X D (Dired), C-X K (Kill Buffer), M-C-L (Previous BUffer) % commands to Basic Dispatch list. % - Separated out read-only text commands into ReadOnlyTextDispatchList. % AS 7/21/82 % - Attached C-V and M-V to new scroll-window functions. % WFG 25 July 1982 % - Dired stuff commented back out for now. ModeEstablishProcedures % renamed to be ModeEstablishExpressions. % AS 7/15/82 % - Changed AddToKeyList to add the new definition at the end of the % list, so that it will override existing definitions. % - Added C-Q. % AS 8/2/82 % - Revised $Iterate to use delayed prompting feature. % WFG 23 August 1982 % - Changed AddToKeyList to call EstablishCurrentMode iff *EMODE is T. (FLUID '( MainDispatch % Dispatch table (vector), an entry for each key PrefixAssociationLists % Additional dispatch information for % prefixed characters. % List of declared prefix characters. PrefixCharacterList SelfInsertCharacter % Character being dispatched upon. last_operation % The "last" routine dispatched to (before the % "current operation"). % List of expressions to be evaluated. Each expression is expected to % modify (add to?) the dispatch table. ModeEstablishExpressions FundamentalTextMode % See below )) % Create MainDispatch vector, 256 entries in all. (setf MainDispatch (MkVect 255)) % List of valid prefix characters. (setf PrefixCharacterList NIL) % Add a new prefix character and associated prompt. (DE define_prefix_character (chr prompt-string) (setf PrefixCharacterList (cons (cons chr prompt-string) PrefixCharacterList))) % Set up initial list of valid prefix characters. Note that ESC (etc?) % aren't implemented as "prefix characters", (although, perhaps they should % be?) NOTE: there seems to be something wrong in that we're using this % general tool for only one prefix character. (Note that M-X is not a % prefix character.) (define_prefix_character (char (cntrl X)) "C-X ") % Generate a list of character codes, or a single character, from a list of % "character descriptors". Syntax is similar to that for the "Char" % macro. (DM CharSequence (chlist) (prog (processed-list) (setf processed-list (for (in chr-descriptor (cdr chlist)) (collect (DoChar chr-descriptor)))) % If there was a single character in the list, just return the % character code. (return (cond % Just return the character code if a single character. ((equal (length processed-list) 1) (car processed-list)) % Otherwise, return the (quoted) list of character codes. (T `(quote ,processed-list)))))) % Return T if character has meta bit set. (DS MetaP (chr) (GreaterP chr 127)) % Convert character to meta-character. (DS MakeMeta (chr) (LOR chr 8#200)) % Return character with meta bit "stripped off"--converts meta to normal char. (DS UnMeta (chr) (LAND chr 8#177)) % This version of "UpperCaseP" also handles meta-characters. (DE X-UpperCaseP (chr) (cond ((MetaP chr) (UpperCaseP (UnMeta chr))) (T (UpperCaseP chr)))) (DE X-Char-DownCase (chr) (cond ((MetaP chr) (MakeMeta (Char-DownCase (UnMeta chr)))) (T (Char-DownCase chr)))) % Set up a "clear" dispatch table. (DE ClearDispatch () (progn (for (from i 0 255 1) (do (Undefine i))) (setf PrefixAssociationLists NIL))) % Set up the keyboard dispatch table for a character or "extended character". % If the character is uppercase, define the equivalent lower case character % also. (DE SetKey (xchar op) (cond ((NumberP xchar) % Add table entry for a simple character code. (progn (setf (indx MainDispatch xchar) op) (cond ((X-UpperCaseP xchar) (setf (indx MainDispatch (X-Char-DownCase xchar)) op))))) % If a valid prefixed character. ((and (PairP xchar) (Atsoc (car xchar) PrefixCharacterList)) (prog (prefix-char assoc-entry) (setf prefix-char (car xchar)) % Look up the prefix character in the a-list of a-lists. (setf assoc-entry (Atsoc prefix-char PrefixAssociationLists)) % Add the prefix character if no entry present yet. (cond ((null assoc-entry) (setf PrefixAssociationLists (cons (setf assoc-entry (cons prefix-char NIL)) PrefixAssociationLists)))) % Now, add the prefixed character to the association list. Note % that in case of duplicate entries the last one added is the one % that counts. (Perhaps we should go to a little more work and % DelQIP any old entry?) (RPLACD assoc-entry % (cadr xchar) is the prefixed character. (cons (cons (cadr xchar) op) (cdr assoc-entry))) % Define the lower case version of the character, if relevent. (cond ((X-UpperCaseP (cadr xchar)) (RPLACD assoc-entry (cons (cons (X-Char-DownCase (cadr xchar)) op) (cdr assoc-entry))))))) % If we get here, SetKey was given a bad argument (T % (Use EMODEerror instead?) (Error 666 "Bad argument for SetKey")))) % Procedure to define a character as "self inserting". (DE MakeSelfInserting (chr) (SetKey chr 'InsertSelfCharacter)) % Define a character so that it just "dings" bell. (DE Undefine (chr) (SetKey chr 'Ding)) (FLUID '(new-oper)) % Dispatch on next command character, "remember" the associated operation. (DE Dispatcher () (progn (Dispatch (GetNextCommandCharacter)) (setf last_operation new-oper))) % Dispatch on a character, "remember" the associated dispatch routine. (DE Dispatch (chr) (prog (oper) (setf oper (indx MainDispatch chr)) (setf new-oper oper) (apply oper NIL))) % Read another character, and then perform appropriate operation from % appropriate prefix "table" (association list). (DE do-prefix () (prog (prefix-entry char-entry chr) (setf prefix-entry (atsoc SelfInsertCharacter PrefixAssociationLists)) (cond % "Complain" if no entry. ((null prefix-entry) (ding)) % Otherwise, read a character and look up its entry. (T (setf chr (prompt_for_character % Prompt string for prefix (cdr (Atsoc SelfInsertCharacter PrefixCharacterList)))) (setf char-entry (Atsoc chr prefix-entry)) (cond ((null char-entry) (progn % Make note of the fact that we ding! (setf new-oper 'ding) (ding))) (T (apply (setf new-oper (cdr char-entry)) NIL))))))) % Treat next command character" as "Meta-character". (This routine is % normally invoked by the "escape" character.) (DE EscapeAsMeta () (dispatch (LOR 8#200 (prompt_for_character "M-")))) % Treat the next character as a "control-meta-character". (This routine is % normally invoked by cntrl-Z.) (DE DoControlMeta () (dispatch (LOR 8#200 (LAND 8#37 (prompt_for_character "M-C-"))))) (FLUID '(pushed_back_characters)) % Get command character, processing keyboard macros (someday! ), etc. % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (Probably the wrong place to do this--if we % also expect to handle keyboard macros! ) (DE GetNextCommandCharacter () (cond % re-read any pushed back stuff. (pushed_back_characters (progn (setf SelfInsertCharacter (car pushed_back_characters)) (setf pushed_back_characters (cdr pushed_back_characters)))) (T (setf SelfInsertCharacter (Land parity_mask (PBIN)))))) % "Push back" a character. (DE push_back (chr) (setf pushed_back_characters (cons chr pushed_back_characters))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Manipulating mode tables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Set up dispatch table for current buffer, by evaluating the expressions % in ModeEstablishExpressions. (De EstablishCurrentMode () (progn (ClearDispatch) % Use reverse so things on front of list are evaluated last. (So that % later incremental changes are added later.) (for (in x (reverse ModeEstablishExpressions)) (do (cond ((pairp x) (eval x)) (t (error 667 (bldmsg "%r is not a valid ""mode establish expression"" (non-list)")))))) % csp 7/782 % Prefix chars are totally global anyway, so let them be % established here, and let them override regular key defns. (DefinePrefixChars))) % This list of (character-sequence . operation) defines a partial set % of bindings for text mode (and other derived modes). This list % contains only commands that don't modify the buffer. (setf ReadOnlyTextDispatchList (list % These commands are read-only commands for text mode. (cons (char (cntrl @)) 'SetMark) (cons (char (cntrl A)) '$BeginningOfLine) (cons (char (cntrl B)) '$BackwardCharacter) (cons (char (cntrl E)) '$EndOfLine) (cons (char (cntrl F)) '$ForwardCharacter) (cons (char (cntrl N)) '$ForwardLine) (cons (char (cntrl P)) '$BackwardLine) (cons (char (cntrl R)) 'reverse_string_search) (cons (char (cntrl S)) 'forward_string_search) (cons (char (cntrl V)) 'scroll-window-up-page-command) (cons (char (meta (cntrl B))) 'backward_sexpr) (cons (char (meta (cntrl F))) 'forward_sexpr) (cons (char (meta B)) 'backward_word) (cons (char (meta F)) 'forward_word) (cons (char (meta V)) 'scroll-window-down-page-command) (cons (char (meta W)) 'copy_region) (cons (char (meta <)) '$BeginningOfBuffer) (cons (char (meta >)) '$EndOfBuffer) (cons (CharSequence (cntrl X) (cntrl X)) 'ExchangePointAndMark) % Note that these two would be nice to have for other "data modes" than % text. But current versions aren't generic enough. (cons (CharSequence (cntrl X) 1) 'OneWindow) (cons (CharSequence (cntrl X) 2) 'TwoRfaceWindows) )) % This list of (character-sequence . operation) defines bindings for text mode % (and other derived modes). TextDispatchList includes the initial contents of % ReadOnlyTextDispatchList (above). Be sure to put read-only commands on that % list! (setf TextDispatchList (append (list (cons (char !)) 'insert_matching_paren) (cons (char (cntrl D)) '$DeleteForwardCharacter) (cons (char (cntrl K)) 'kill_line) (cons (char (cntrl O)) 'OpenLine) (cons (char (cntrl Q)) 'InsertNextCharacter) (cons (char (cntrl T)) 'transpose_characters) (cons (char (cntrl W)) 'kill_region) (cons (char (cntrl Y)) 'insert_kill_buffer) (cons (char (meta (cntrl K))) 'kill_forward_sexpr) (cons (char (meta (cntrl RUBOUT))) 'kill_backward_sexpr) (cons (char (meta D)) 'kill_forward_word) (cons (char (meta Y)) 'unkill_previous) (cons (char (meta RUBOUT)) 'kill_backward_word) (cons (char DELETE) '$DeleteBackwardCharacter) (cons (char LF) '$CRLF) (cons (char CR) '$CRLF) (cons (char (meta !%)) 'Query-Replace-Command) (cons (CharSequence (cntrl X) (cntrl R)) 'CntrlXread) (cons (CharSequence (cntrl X) (cntrl S)) 'save_file) (cons (CharSequence (cntrl X) (cntrl W)) 'CntrlXwrite) ) ReadOnlyTextDispatchList )) % Add the (chr opr) binding to a list with name listname. (de AddToKeyList (listname chr opr) (let* ((old-list (eval listname)) (old-binding (atsoc chr old-list)) (binding (cons chr opr))) (cond % If the binding isn't already in the a-list. ((null old-binding) % Add the new binding (Destructively to the end, so it's sure to % override any old stuff). (set listname (aconc old-list binding))) % Otherwise, replace the old operation in the binding. (T (setf (cdr old-binding) opr))) % Update the current mode if EMODE is running, in case it's affected by % the list we just modified. (cond (*EMODE (EstablishCurrentMode))))) % Add a new key binding to "text mode". (de SetTextKey (chr opr) (AddToKeyList 'TextDispatchList chr opr)) % Add a new key binding to "Lisp mode". (de SetLispKey (chr opr) (AddToKeyList 'LispDispatchList chr opr)) % Execute the expressions in this list to establish "Fundamental Text Mode". (setf FundamentalTextMode '((SetKeys TextDispatchList) (SetKeys BasicDispatchList) (NormalSelfInserts))) (de SetKeys (lis) (for (in x lis) (do (SetKey (car x) (cdr x))))) (de NormalSelfInserts () (for (from i 32 126) (do (MakeSelfInserting i)))) (setf BasicDispatchList (list (cons (char ESC) 'EscapeAsMeta) (cons (char (cntrl U)) '$Iterate) (cons (char (cntrl Z)) 'DoControlMeta) % NOT basic? (cons (CharSequence (cntrl X) (cntrl B)) 'PrintBufferNames) (cons (CharSequence (cntrl X) B) 'ChooseBuffer) %Dired stuff commented out for now. %? (cons (CharSequence (cntrl X) D) 'dired-command) % window-kill-buffer not implemented yet? %? (cons (CharSequence (cntrl X) K) 'window-kill-buffer) % "C-X N" switches to "next window" (or "other window" if in "two % window mode"). (cons (CharSequence (cntrl X) N) 'next_window) % "C-X O" does the same as "C-X N" (cons (CharSequence (cntrl X) O) 'next_window) % "C-X P" moves to "previous window". (cons (CharSequence (cntrl X) P) 'previous_window_command) % C-X C-Z causes us to exit to monitor. (cons (CharSequence (cntrl X) (cntrl Z)) 'QUIT) % M-C-Z causes us to rebind the channels for "normal" I/O, and % leave EMODE. (cons (char (meta (cntrl Z))) 'OldFace) %Dired stuff commented out for now. %? (cons (char (meta (cntrl L))) 'SelectPreviousBuffer) (cons (char (cntrl L)) 'FullRefresh) % Two ways to invoke the help function. (cons (char (meta !/ )) '$HelpDispatch) (cons (char (meta !?)) '$HelpDispatch) (cons (CharSequence (cntrl X) (cntrl F)) 'find_file) (cons (CharSequence (cntrl X) (cntrl P)) 'WriteScreenPhoto) (cons (char (meta X)) 'execute_command))) % Define the prefix characters given in PrefixCharacterList. (de DefinePrefixChars () (for (in prefix-entry PrefixCharacterList) (do % car gives character code for prefix. (SetKey (car prefix-entry) 'do-prefix)))) % IS THE FOLLOWING REALLY APPROPRIATE TO DISPATCH? % Simulate EMACS's C-U, C-U meaning 4, C-U C-U meaning 16, etc., and C-U % <integer> meaning <integer>. This command suffers from the flaw of % simply iterating the following command, instead of giving it a % parameter. Thus, for example, C-U C-A won't do what you expect. % Written by Alan Snyder, HP labs. (fluid '(prompt-immediately prompt-was-output)) % C-U handler. (de $iterate () (let ((arg 1) (ch (char (control U))) (previous-ch nil) (prompt "") (prompt-immediately nil) ) (while T (cond ((eqn ch (char (control U))) (if previous-ch (setq prompt (concat prompt " "))) (setq prompt (concat prompt "C-U")) (setq arg (times arg 4)) ) % Note check for non-meta character. (Since DigitP blows up % otherwise? Test may be obsolete??) ((and (LessP ch 128) (digitp ch)) (if (and previous-ch (digitp previous-ch)) (setq arg (plus (times arg 10) (char-digit ch))) % ELSE (setq arg (char-digit ch)) (setq prompt (concat prompt " ")) ) (setq prompt (concat prompt (string ch))) ) (t (exit))) (setq previous-ch ch) (setq ch (prompt_for_character prompt)) (setq prompt-immediately prompt-was-output) ) (for (from i 1 arg 1) (do (dispatch ch) % NOTE KLUDGE! Need to work this out better! (setf last_operation new-oper))) )) % Convert from character code to digit. (de char-digit (c) (cond ((digitp c) (difference (char-int c) (char-int (char 0)))))) |
Added psl-1983/emode/dm1520.sl version [77472ca68c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DM1520.SL - EMODE support for Datamedia 1520 terminals. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#177) (DE EraseScreen () (PBOUT (Char FF))) % Form feed to clear the screen (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (PBOUT 8#35)) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT 8#36) (PBOUT (plus (char BLANK) ColLoc)) (PBOUT (plus (char BLANK) RowLoc)))) |
Added psl-1983/emode/edc.sl version [af34495300].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % A simple desk calculator to run under EMODE. In this mode all the % numbers in the buffer are summed up, any other characters are inserted % and ignored, the total is given as the last line of the OUT_WINDOW buffer.. (load useful) % Need useful so that FOR loops work! % Insert a character, and then sum up all the lines in the buffer. (DE InsertAndTotal () (progn (InsertSelfCharacter) (FindBufferTotal))) (DE DeleteBackwardAndTotal () (progn (!$DeleteBackwardCharacter) (FindBufferTotal))) (DE DeleteForwardAndTotal () (progn (!$DeleteForwardCharacter) (FindBufferTotal))) (DE kill_line_and_total () (progn (kill_line) (FindBufferTotal))) (DE insert_kill_buffer_and_total () (progn (insert_kill_buffer) (FindBufferTotal))) (DE FindBufferTotal () (prog (total save-point save-line-index itm) % Remember our spot in the buffer. (setf save-point point) (setf save-line-index CurrentLineIndex) (setf total 0) % Move to the start of the buffer. (!$BeginningOfBuffer) % Read from, and write to, EMODE buffers. (SelectEmodeChannels) % Find the total. (while (not (EndOfBufferP (NextIndex CurrentLineIndex))) (progn % NOTE that READ would loose badly here--since it calls % MakeInputAvailable here, and thus call EMODE recursively. (setf itm (ChannelRead IN*)) (cond ((NumberP itm) (setf total (plus total itm)))))) % Now, show the total in the OUT_WINDOW buffer. (prog (old-point old-line-index old-buffer) (setf old-buffer CurrentBufferName) (SelectBuffer 'OUT_WINDOW) (!$EndOfBuffer) % Move to end of the buffer. (setf old-point point) (setf old-line-index CurrentLineIndex) % Move to beginning of previous line. (!$BackwardLine) (!$BeginningOfLine) % Delete the old text (delete_or_copy T CurrentLineIndex point old-line-index old-point) % Print the total (to the output buffer) (PRINT total) (SelectBuffer old-buffer)) % Finally, restore the original point and mark. (SelectLine save-line-index) (setf point save-point))) % Establish keyboard bindings for Desk Calculator mode. (DE SetDCmode () (progn % Make most characters insert and then find total. (for (from i 32 126 1) (do (SetKey i 'InsertAndTotal))) (SetKey (char TAB) 'InsertAndTotal) % Inherit the rest of the bindings from "text mode" (for (in itm TextDispatchList) (do (SetKey (car itm) (cdr itm)))) % Then, rebind (some of?) the folks who actually modify stuff. (SetKey (char (cntrl D)) 'DeleteForwardAndTotal) (SetKey (char (cntrl K)) 'kill_line_and_total) (SetKey (char DELETE) 'DeleteBackwardAndTotal) (SetKey (char (cntrl Y)) 'insert_kill_buffer_and_total))) (setf DCMode '(RlispInterfaceDispatch SetDCmode BasicDispatchSetup)) % This code must be run AFTER starting up EMODE. (prog (old-buffer) (setf old-buffer CurrentBufferName) (CreateBuffer 'DC DCMode) (SelectBuffer 'DC) (!$CRLF) (insert_string "0") (!$CRLF) (!$BeginningOfBuffer) (SelectBuffer old-buffer)) |
Added psl-1983/emode/emacs.table version [55e2c75c10].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | C-@ SETMARK C-A $BEGINNINGOFLINE C-B $BACKWARDCHARACTER C-D $DELETEFORWARDCHARACTER C-E $ENDOFLINE C-F $FORWARDCHARACTER Linefeed $CRLF C-K KILL_LINE C-L FULLREFRESH Return $CRLF C-N $FORWARDLINE C-O OPENLINE C-P $BACKWARDLINE C-Q INSERTNEXTCHARACTER C-R REVERSE_STRING_SEARCH C-S FORWARD_STRING_SEARCH C-T TRANSPOSE-CHARACTERS-COMMAND C-U $ITERATE C-V SCROLL-WINDOW-UP-PAGE-COMMAND C-W KILL_REGION C-X DO-PREFIX C-Y INSERT_KILL_BUFFER C-Z DOCONTROLMETA Escape ESCAPEASMETA ) INSERT_MATCHING_PAREN Rubout $DELETEBACKWARDCHARACTER M-C-@ MARK-SEXP-COMMAND M-C-B BACKWARD_SEXPR M-C-D DOWN-LIST M-C-F FORWARD_SEXPR M-C-K KILL_FORWARD_SEXPR M-Return BACK-TO-INDENTATION-COMMAND M-C-N MOVE-PAST-NEXT-LIST M-C-O FORWARD-UP-LIST M-C-P MOVE-PAST-PREVIOUS-LIST M-C-U BACKWARD-UP-LIST M-C-Z OLDFACE M-C-Rubout KILL_BACKWARD_SEXPR M-% QUERY-REPLACE-COMMAND M-( INSERT-PARENS M-) MOVE-OVER-PAREN M-/ $HELPDISPATCH M-< $BEGINNINGOFBUFFER M-> $ENDOFBUFFER M-? $HELPDISPATCH M-@ MARK-WORD-COMMAND M-B BACKWARD_WORD M-D KILL_FORWARD_WORD M-F FORWARD_WORD M-M BACK-TO-INDENTATION-COMMAND M-V SCROLL-WINDOW-DOWN-PAGE-COMMAND M-W COPY_REGION M-X EXECUTE_COMMAND M-Y UNKILL_PREVIOUS M-\ DELETE-HORIZONTAL-SPACE-COMMAND M-^ DELETE-INDENTATION-COMMAND M-b BACKWARD_WORD M-d KILL_FORWARD_WORD M-f FORWARD_WORD M-m BACK-TO-INDENTATION-COMMAND M-v SCROLL-WINDOW-DOWN-PAGE-COMMAND M-w COPY_REGION M-x EXECUTE_COMMAND M-y UNKILL_PREVIOUS M-Rubout KILL_BACKWARD_WORD C-X h MARK-WHOLE-BUFFER-COMMAND C-X H MARK-WHOLE-BUFFER-COMMAND C-X C-O DELETE-BLANK-LINES-COMMAND C-X 2 TWORFACEWINDOWS C-X 1 ONEWINDOW C-X C-X EXCHANGEPOINTANDMARK C-X C-W CNTRLXWRITE C-X C-S SAVE_FILE C-X C-R CNTRLXREAD C-X C-P WRITESCREENPHOTO C-X C-F FIND_FILE C-X C-Z QUIT C-X p PREVIOUS_WINDOW_COMMAND C-X P PREVIOUS_WINDOW_COMMAND C-X o NEXT_WINDOW C-X O NEXT_WINDOW C-X n NEXT_WINDOW C-X N NEXT_WINDOW C-X b CHOOSEBUFFER C-X B CHOOSEBUFFER C-X C-B PRINTBUFFERNAMES |
Added psl-1983/emode/emode-disphelp.red version [4570510369].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % Stolen from PI:HELP.RED--modified to run under EMODE. lisp procedure DisplayHelpFile F; %. Type help about 'F' begin scalar NewIn, C, !*Echo; (lambda(!*Lower); F := BldMsg(HelpFileFormat!*, F))(T); NewIn := ErrorSet(list('Open, MkQuote F, '(quote Input)), NIL, NIL); if not PairP NewIn then ErrorPrintF("*** Couldn't find help file %r", F) else << NewIn := car NewIn; SelectBuffer('ALTERNATE_WINDOW); read_channel_into_buffer(NewIn); % (Closes NewIn when done.) >>; end; |
Added psl-1983/emode/emode-files-1.red version [ac0b95cb36].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | % Loads "first half" of files necessary to build EMODE. % Assumes that the "default directory" contains all the necessary files. imports '(strings); % Strings library needed at runtime. in "temporary-emode-fixes.red"$ in "customize-rlisp-for-emode.sl"$ % Must be first? in "envsel.sl"$ % Support for "environments" in "dispch.sl"$ % "keyboard" dispatch support in "emode1.red"$ % Bunches of stuff in "misc-emode.sl"$ % miscellaneous utilities and commands in "sleep.sl"$ % Utility to "sleep" until time limit or character typed. in "ring-buffer.sl"$ % General "ring buffer" utilities in "buffers.sl"$ % Misc stuff for manipulating EMODE buffers. in "buffer-position.sl"$ % Utilities for handling "point" within buffer. in "query-replace.sl"$ % Implements query-replace command. in "window.sl"$ in "windows.sl"$ in "buffer.sl"$ |
Added psl-1983/emode/emode-files-2.red version [a8ca6a324b].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | % Loads "second half" of files necessary to build EMODE. % Assumes that the "default directory" contains all the necessary files. % Utilities for getting prompted input, and general management of % MODE/PROMPT/MESSAGE lines. in "prompting.sl"$ in "search.red"$ % Utilities for string search. in "move-strings.red"$ % "Fast" string utilities. in "vs-support.sl"$ % Some more "fast" support for V-SCREEN % (Virtual Screen) package. in "v-screen.sl"$ in "refresh.red"$ % Screen/windows/refresh stuff in "fileio.sl"$ % I/O routines for reading/writing EMODE % buffers. in "rface.red"$ % Special "mode" for executing Rlisp/Lisp in "hp-emodex.sl"$ % Contributions from Hewlett Packard (Alan Snyder). |
Added psl-1983/emode/emode-hlp.mss version [6cb321a9e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Comment{This file generates the help file EMODE.HLP} @device[file] @heading[EMODE - A PSL Screen Editor] Comments and questions about EMODE should be addressed to Will Galway (GALWAY@@UTAH-20). Further documentation is available in the file EMODE.LPT on logical device PE: @subheading[Running EMODE] @Comment{The following text should really be implemented as an include file? Shared with EMODE.MSS?} EMODE is available as a "loadable" file. It can be invoked as follows: @begin[example] @@PSL:RLISP [1] load emode; [2] emode(); @end[example] Of course, you may choose to invoke RLISP (or "just plain Lisp") differently, and to perform other operations before loading and running EMODE. EMODE is built to run on a site dependent "default terminal" as the default (a Teleray terminal at the University of Utah). To use some other terminal you must LOAD in a set of different driver functions after loading EMODE. For example, to run EMODE on the Hewlett Packard 2648A terminal, you could type: @begin[example] @@PSL:RLISP [1] load emode; [2] load hp2648a; [3] emode(); @end[example] The following drivers are currently available: @begin[description,spread 0] AAA@\For the Ann Arbor Ambassador. DM1520@\For the Datamedia 1520. HP2648A@\For the Hewlett Packard 2648A (and similar HP terminals). @Comment{Should we be this specific?} TELERAY@\For the Teleray 1061. VT52@\For the DEC VT52. VT100@\For the DEC VT100. @end[description] See the file PE:EMODE.LPT for information on creating new terminal drivers. When EMODE starts up, it will typically be in "two window mode". To enter "one window mode", you can type "C-X 1" (as in EMACS). Commands can be typed into a buffer shown in the top window. The result of evaluating a command is printed into the OUT_WINDOW buffer (shown in the bottom window). To evaluate the expression starting on the current line, type M-E. M-E will (normally) automatically enter two window mode if anything is "printed" to the OUT_WINDOW buffer. If you don't want to see things being printed to the output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode when something is printed to OUT_WINDOW. You must still use the "C-X 1" command to enter one window mode initially. @subheading[Commands for EMODE] @include[keybindings.mss] |
Added psl-1983/emode/emode.lpt version [1e41a42492].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Utah Symbolic Computation Group June 1982 Operating Note No. 69 A Guide to EMODE A Guide to EMODE A Guide to EMODE by William F. Galway and Martin L. Griss Department of Computer Science University of Utah Salt Lake City, Utah 84112 Last Revision: 31 January 1983 ABSTRACT ABSTRACT ABSTRACT EMODE is a LISP-based EMACS-like editor that runs on the PSL system. This document is meant to serve as a guide to using EMODE--but will only be roughly up to date, since the system is in a state of transition. Work supported in part by the National Science Foundation under Grant No. MCS80-07034. Guide to EMODE 1 1. Introduction and Acknowledgments 1. Introduction and Acknowledgments 1. Introduction and Acknowledgments This paper describes the EMODE editor being developed for PSL [Griss 81]. EMODE is an interactive, EMACS like [Stallman 81a], screen editor. EMODE provides multiple windows, can simultaneously support different "modes" of editing in different buffers, and supports a variety of CRT terminals such as the Teleray 1061 and the DEC VT-100. Several people have made contributions to EMODE. EMODE itself is based on an earlier editor EMID [Armantrout 81], written by Robert Armantrout and Martin Griss for LISP 1.6. Tony Carter has used EMODE to develop several large packages for VLSI circuitry design [Carter 81, Carter 82]. Optimizations for the Vax version, and many useful comments, have been provided by Russ Fish. Several features have been added by Alan Snyder and Cris Perdue at Hewlett Packard Research Labs. Cris implemented the current version of "mode lists", while Alan has implemented a huge number of commands and improved the efficiency of several operations. 2. Running EMODE 2. Running EMODE 2. Running EMODE EMODE is available as a "loadable" file. It can be invoked as follows: @PSL:RLISP [1] load emode; [2] emode(); Of course, you may choose to invoke RLISP (or PSL) differently, and to perform other operations before loading and running EMODE. From this point on the term "PSL" will be used to refer to this family of systems, independently of whether they use Lisp or RLISP syntax. The terminal that EMODE uses by default is determined by its LOADing the file DEFAULT-TERMINAL. At the University of Utah this is the TELERAY driver. At other sites, some other driver may be chosen as the default. To use a different terminal you must LOAD in a different "driver file" after loading EMODE. For example, to run EMODE on the Hewlett Packard 2648A terminal, you could type: @PSL:RLISP [1] load emode, hp2648a; [2] emode(); Guide to EMODE 2 The following drivers are currently available: AAA For the Ann Arbor Ambassador. DM1520 For the Datamedia 1520. HP2648A For the Hewlett Packard 2648A and similar Hewlett Packard terminals. TELERAY For the Teleray 1061. VT52 For the DEC VT52. VT100 For the DEC VT100. See section 9 for information on creating new terminal drivers. EMODE is quite similar to EMACS [Stallman 81b, Stallman 81a], although it doesn't have nearly as many commands. A detailed list of commands is given in appendix I. This information can also be obtained by typing "HELP EMODE;" to RLISP, or (equivalently) by reading the file PH:EMODE.HLP. The notation used here to describe character codes is basically the same as that used for EMACS. For example: C-Z means "control-Z", the character code produced by typing Z while holding down the control key. The ascii code for a control character is the same as the 5 low order bits of the original character--the code for Z is 132 octal, while the code for C-Z is 32 octal. M-Z means "meta-Z", the character produced by typing Z while holding down the meta key. To support those terminals without a meta key, the same result can normally be achieved by typing two characters--first the ESCAPE character, then the Z character. The ascii code for a meta character is the same as the original character with the parity bit set--the code for M-Z is 332 octal. (Some terminals use the ESCAPE character for other purposes, in which case the "META prefix" will be some other character.) Rather than using the EMACS convention, we write "control-meta" characters (such as C-M-Z) as "meta-control" characters (M-C-Z), since the latter notation better reflects the internal code (232 octal for M-C-Z). The C-Z character is used as a "meta-control" prefix, so one way to type M-C-Z is to type C-Z C-Z. (Another way to type it is to hold down the meta and control keys and type "Z".) When EMODE is started up as described above, it will immediately enter "two window mode". To enter "one window mode", you can type "C-X 1" (as in EMACS). Commands can be typed into a buffer shown in the top window. The result of evaluating a command is printed into the OUT_WINDOW buffer (shown in the bottom window). To evaluate the expression starting on the current line, type M-E. M-E will (normally) automatically enter two window mode if anything is "printed" to the OUT_WINDOW buffer. If you don't want to see things being printed to the Guide to EMODE 3 output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode when something is printed to OUT_WINDOW. You must still use the "C-X 1" command to enter one window mode initially. Figure 2-1 shows EMODE in two window mode. In this mode the top window includes everything above (and including) the first line of dashes. This is followed by a single line window, showing the current prompt from PSL. Beneath this is the "output window", the window which usually shows the OUT_WINDOW buffer. This is followed by another single line window, which EMODE uses to prompt the user for values (not the same as PSL's prompt). % Commands can be typed in the top window. % When they're executed the value is printed into % the OUT_WINDOW buffer. x := '(now is the time); y := cddr x; ----MAIN-----------------------------------------85%--- [7] ------------------------------------------------------- NIL (NOW IS THE TIME) (THE TIME) ----OUT_WINDOW-----------------------------------75%--- File for photo: s:twowindow.photo Figure 2-1: Figure 2-1: Figure 2-1: Two window mode Figure 2-2 shows EMODE in one window mode. The "top window" takes up most of the screen, followed by EMODE's prompt line, and then by PSL's prompt line. The BREAK handler has been modified by EMODE to "pop up" a "break window menu". This is illustrated in figure 2-3. The commands in the menu can be executed with the M-E command, and you can also edit the BREAK buffer just like any other buffer. If you wish to move to another window, use the C-X N command. Guide to EMODE 4 % Commands can be typed in the top window. % When they're executed the value is printed into % the OUT_WINDOW buffer. x := '(now is the time); y := cddr x; ----MAIN-----------------------------------------85%--- File for photo: s:onewindow.photo [7] Figure 2-2: Figure 2-2: Figure 2-2: One window mode This may cause the break window to disappear as it is covered by some other window, but C-X P will find it and pop it to the "top" of the screen again. EMODE is not very robust in its handling of errors. Here's a summary of known problems and suggestions on how to deal with them: Garbage collection messages "blow up": Printing messages into EMODE buffers involves CONSing, so the system blows up if it tries to print a message from inside the garbage collector. EMODE sets GC OFF at load time. Always run EMODE with GC OFF. Terminal doesn't echo: This can be caused by abnormal exits from EMODE. If PSL is still running, you can call the routine "EchoOn" to turn echoing back on. (It's the routine "EchoOff" that turns echoing off, and starts "raw output" mode.) Otherwise, as may happen on the Vax running Unix, you will have to give shell commands to turn Guide to EMODE 5 cdr 2; +------------------------------+ |A ;% To abort | |Q ;% To quit | |T ;% To traceback | |I ;% Trace interpreted stuff | |R ;% Retry | |C ;% Continue, | | % using last value | ----MAIN-----------|? ;% For more help |- 4 lisp break> +----BREAK---------------11%---+ ---------------------------------------------------- NIL ***** An attempt was made to do CDR on `2', which is not a pair {99} Break loop ----OUT_WINDOW-----------------------------------75%--- File for photo: s:breakwindow.photo Figure 2-3: Figure 2-3: Figure 2-3: A break window (doctored from the original) echoing back on. This is best done by defining the following alias in your ".login" file. alias rst 'reset; stty -litout intr ^C' (That's a "control-C", not "uparrow C".) The "rst" command must be typed as "<LF>rst<LF>" because carriage-return processing is turned off. "Garbled" printout: This is probably caused by EMODE's not running in "raw output" mode--a problem which can be caused by some other errors. A cure is to type C-Z C-Z to leave EMODE, and then to call EMODE again. This should reset the terminal mode to "raw mode" (by calling EchoOff). (The C-Z C-Z must be followed by a linefeed on the Vax, to force the C-Z C-Z to be read.) Stuck in an error: This is often caused by trying to evaluate an expression that lacks a closing parenthesis (or some other terminator)--producing a message something like: Guide to EMODE 6 ***** Unexpected EOF while reading ... If it's obvious that an additional parenthesis will cure the problem, you can use C-X N to select the input window and insert it. Then position the cursor to the left of the parenthesis and use C-X N to select the break window and "Quit". Otherwise you should use the "Abort" option of the break handler. Currently this resets the terminal mode (at least on the DEC-20), so you'll have to restart EMODE as described above. The BREAK window will still be present on the screen after restarting, even though you are no longer in the break loop. You can use the C-X 2 or C-X 1 command to get rid of the break window, and then use the C-X B command to select some buffer other than the break buffer. 3. A Guide to the Sources and Rebuilding 3. A Guide to the Sources and Rebuilding 3. A Guide to the Sources and Rebuilding The "primary" sources for EMODE reside on UTAH-20: PES: Is defined locally as <GALWAY.EMODE.V2>. This directory is for the "version 2" of EMODE--being maintained now. The corresponding "logical name" on the VAX is "$pes". PE: Is defined as <PSL.EMODE>. Holds sources and documentation which may be generally useful to the public. It includes sources for the various terminal drivers available for EMODE. (Further described in section 9.) The corresponding logical name on the VAX is "$pe". The file PES:BUILD-EMODE.CTL is the command file for building EMODE on the DEC-20. Use SUBMIT or DO to run the command file, which builds EMODE in two parts on the local directory: EMODE-B-1.B and EMODE-B-2.B. PES:BUILD-EMODE.CSH (or $pes/build-emode.csh) is the build file for the VAX. It also builds the binary files on the "local directory". On both machines the ".B" files for the terminal drivers and for RAWIO.B are built separately. The PES:EMODE.TAGS file can be used with the TAGS facility provided by EMACS on the DEC-20. (Highly recommended!) Guide to EMODE 7 4. Terminology: Buffers, Views/Windows, and Virtual Screens 4. Terminology: Buffers, Views/Windows, and Virtual Screens 4. Terminology: Buffers, Views/Windows, and Virtual Screens "Buffers", "views", and "virtual screens" are the three major data structures in EMODE. Virtual screens correspond _______ fairly closely to what are often called windows in other systems. They are rectangular regions on the screen, possibly overlapping, that characters can be written to. A virtual screen provides a sort of pseudo-hardware. The operations that can be performed on a virtual screen are modeled after what can be done with a real terminal. The use of a virtual screen provides these advantages: - Operations on a virtual screen are machine independent. (To some extent, this will be less true if we try to support "fancier" graphics.) - The "bandwidth problem" of maintaining the screen image is isolated to the virtual screen package--other programs don't have to worry about the problem. - Several virtual screens can be shown on one physical screen. Virtual screens are implemented as "Structs" using the "DefStruct" facility provided by the loadable file "NSTRUCT". Buffers hold the data to be edited, possibly something other than text, depending on the buffer's "data mode". Views are data structures used to display buffers on the screen, they may be ______ made of several virtual screens. The term "window" is often used instead of "view", when you see the one term it should be possible to substitute the other. Buffers and views are implemented as "environments". An environment is an association list of (NAME . VALUE) pairs. (These association lists are sometimes referred to as "descriptors".) The usual method for working with an environment is "restoring" (or "selecting") the environment by calling the procedure "RestoreEnv". This sets each variable name in the list to its associated value. The procedure "SaveEnv" does the inverse operation of updating the values of each variable name in the association list. (This is done "destructively", using RPLACD.) The names in an environment are sometimes called "per-environment" variables. Names in "buffer environments" are called "per-buffer variables", and similarly for "per-view variables". Buffers and views are just environments that follow certain conventions. These conventions are that they always include certain (name . value) pairs--i.e. that they always include certain "per-buffer" or "per-view" variables. For example, the required per-buffer variables include: Guide to EMODE 8 buffers_file The name (a string) of a file associated with the buffer, or NIL if no file is associated with the buffer. buffers_view_creator A routine that creates a "view" (or "window") looking into the buffer. In addition to the required per-buffer variables, text buffers include variables containing things like the text being edited in the buffer and the location of "point" in the buffer. The required per-view variables include: windows_refresher (Which should actually be called the "views_refresher") defines a routine to be the refresh algorithm for whatever data structure this view looks into. WindowsBufferName Is the name (an ID) of the buffer that the view looks into. Views into text buffers include additional information such as a virtual screen to display the text in, and "cache" information to make refreshing faster. The choice of whether variables should be per-buffer or per-view is sometimes unclear. For example, it would seem to make better sense to have "point" be part of a view, rather than a buffer. This would allow the user to have two windows looking into different parts of the same buffer. However, it would also require the selection of a window for the many functions that insert strings into the buffer, delete strings from the buffer, etc., since these routines all work around the current "point". ____ Somehow it seems unnatural to require the selection of a view for ______ these buffer operations. The current decision is to make point a per-buffer variable. Further details on buffers and views for different modes are given in section 6. A list of all the buffers in EMODE is stored in the variable "BufferNames" as a list of (name . environment) pairs . These pairs are created with the routine "CreateBuffer". Guide to EMODE 9 A list of "active" views in EMODE is stored in the variable "WindowList". This is simply a list of "environments" (association lists as described above). Unlike buffers, views are not referred to by name. Instead, specific views can be referred to by storing their environment in a variable (such as "BreakWindow"). 5. Modes and Key bindings in EMODE 5. Modes and Key bindings in EMODE 5. Modes and Key bindings in EMODE There are two aspects to "modes" in EMODE. One is the choice of the data structure to be edited within a buffer. Until recently there has only been one kind of structure: "text". As discussed in section 6 EMODE now provides tools for editing other, user defined, structures. The other aspect of "modes", discussed in this section, is the binding of "handler" routines to terminal keys (or sequences of keys for multi-key commands). A simple version of this would associate a table of handlers (indexed by character code) with each buffer (or view). The method actually used is more complicated due to a desire to divide keyboard bindings into groups that can be combined in different ways. For example, we might have a text mode and an Rlisp mode, and an optional Word Abbreviation Mode that could be combined with either of them to cause automatic expansion of abbreviations as they are typed. _______ Implementing optional keyboard bindings that can removed as _____ well as added is difficult. Consider the situation with an optional "Abbreviation Mode" and an optional "Auto Fill Mode". Turning on either mode redefines the space character to act differently. In each case, the new definition for space would be something like "do some fancy stuff for this submode, and then do whatever space used to do". Imagine the difficulties involved in turning on "Abbreviation Mode" and then "Auto Fill Mode" and then turning off "Abbreviation Mode". EMODE's solution to the problem is based on the method ______ ______ suggested in [Finseth 80]. A single, global "dispatch vector" is used, but is rebuilt when switching between buffers. The mode for each buffer is stored as a list of expressions to be evaluated. Evaluating each expression enters the bindings for an associated group of keys into the vector. Incremental modes can be added or deleted by adding or deleting expressions from the list. Although changing modes is fairly time consuming (more than a few microseconds), we assume that this is rare enough that the overhead is acceptable. NOTE that simply changing an entry in the dispatch vector will not work--since any switching between Guide to EMODE 10 buffers will cause the entry to be permanently lost. The dispatch "vector" is actually implemented as a combination of a true PSL vector "MainDispatch", indexed by character code, and an association list "PrefixAssociationLists" used to implement two character commands. Currently the only two character commands start with the "prefix character" C-X, although the mechanism is more general. Prefix characters are "declared" by calling the routine "define_prefix_character" (refer to code for details). Bindings for prefix-character commands are stored in PrefixAssociationLists as an association list of association lists. The top level of the list is "indexed" by the prefix character, the next level contains (character . handler) pairs indexed by the character following the prefix character. The list of expressions for building the dispatch vector is called the "mode list", and is stored in the per-buffer variable "ModeEstablishExpressions". See the following section for more on how ModeEstablishExpressions is used in the declaration of a mode. The procedure "EstablishCurrentMode" evaluates these expressions in reverse order (the last expression in the list is evaluated first) to establish the keyboard dispatch vector used for editing the current buffer. Reverse order is used so that ____ _____ the last expression added to the front of the list will be evaluated last. EstablishCurrentMode must be called after changing the mode list for the current buffer and when switching ___ _______ ____ ___ ________ to a different buffer for editing from the keyboard. The routine SelectBuffer switches to a buffer without "establishing" the buffer's mode. This saves the cost of setting up the dispatch vector when it isn't needed (which is the case for most "internal operations" on buffers). ___ The expressions in ModeEstablishExpressions can execute any code desired. This generality is rarely needed, the usual action is to call the routine SetKeys with a list of (character . handler) pairs. For example, the mode list for text mode is defined by this Lisp code: (setf FundamentalTextMode '((SetKeys TextDispatchList) (SetKeys BasicDispatchList) (NormalSelfInserts))) The RLISP mode is built "on top of" FundamentalTextMode as follows: Guide to EMODE 11 (setf RlispMode (cons '(SetKeys RlispDispatchList) FundamentalTextMode)) This section taken from the code that builds BasicDispatchList shows what a "key list" for the SetKeys routine should look like: (setf BasicDispatchList (list (cons (char ESC) 'EscapeAsMeta) (cons (char (cntrl U)) '$Iterate) (cons (char (cntrl Z)) 'DoControlMeta) % "C-X O" switches to "next window" (or "other % window" if in "two window mode"). (cons (CharSequence (cntrl X) O) 'next_window) (cons (CharSequence (cntrl X) (cntrl F)) 'find_file) . . . Note that the pairs in a key list can specify character sequences like "(cntrl X) O" as well as single characters. At runtime, after they're created, key lists can be most easily modified by calling the routine AddToKeyList. For example (AddToKeyList 'RlispDispatchList (char (meta (cntrl Z))) 'DeleteComment) could be executed to add a new, "delete comment" handler to RLISP mode. The routine SetTextKey is equivalent to adding to the key list TextDispatchList (see code). For example (SetTextKey (char (meta !$)) 'CheckSpelling) could be executed to add a new "spelling checker" command to text mode (and other modes such as RLISP mode that incorporate text mode). SetTextKey seems to correspond most closely to EMACS's "Set Key" command. Guide to EMODE 12 The routine "SetLispKey" is also defined for adding bindings to "Lisp mode". (There is no "SetRlispKey" routine in EMODE, although it would be easy to define for yourself if desired.) 6. Creating New Modes 6. Creating New Modes 6. Creating New Modes To define a new mode you must provide a "buffer creator" routine that returns a "buffer environment" with the required per-buffer variables along with any other state information needed for the type of data being edited. You need to "declare" the mode by calling the routine "declare_data_mode". It's also possible to associate the mode with a file extension by calling the routine "declare_file_mode". For example, the current EMODE declares the modes, "text" and "rlisp", as follows: (declare_data_mode "text" 'create_text_buffer) (declare_data_mode "rlisp" 'create_rlisp_buffer) (declare_file_mode "txt" 'create_text_buffer) (declare_file_mode "red" 'create_rlisp_buffer) The second argument to both routines is the "buffer creator" routine for that mode. The first argument to declare_data_mode is a "name" for the mode. The first argument to declare_file_mode is a file extension associated with that mode. The conventions for "buffer environments" are that they always include certain (name . value) pairs--i.e. that they always include certain "per-buffer" variables. These variables are: ModeEstablishExpressions A list of expressions to evaluate for establishing the keyboard bindings for the buffer's mode. buffers_file The name (a string) of a file associated with the buffer, or NIL if no file is associated with the buffer. buffers_file_reader A routine to APPLY to one argument--a PSL io-channel. The routine should read the channel into the current buffer. buffers_file_writer Guide to EMODE 13 A routine to APPLY to an io-channel. The routine writes the current buffer out to that channel. buffers_view_creator A routine to create a "view" (or "window") looking into the buffer. This is described in more detail below. For example, the buffer creator for "text mode" is: (de create_text_buffer () (cons (cons 'ModeEstablishExpressions FundamentalTextMode) (create_raw_text_buffer))) Most of the work is done by create_raw_text_buffer, which does everything but determine the keyboard bindings for the buffer. Here's the code with comments removed: (de create_raw_text_buffer () (list (cons 'buffers_view_creator 'create_text_view) (cons 'buffers_file_reader 'read_channel_into_text_buffer) (cons 'buffers_file_writer 'write_text_buffer_to_channel) (cons 'buffers_file NIL) (cons 'CurrentBufferText (MkVect 0)) (cons 'CurrentBufferSize 1) (cons 'CurrentLine NIL) (cons 'CurrentLineIndex 0) (cons 'point 0) (cons 'MarkLineIndex 0) (cons 'MarkPoint 0) )) Other modes based on text can be similarly defined by consing an appropriate binding for ModeEstablishExpressions to the environment returned by create_raw_text_buffer. Of course we need some way of "viewing" buffers once they've been created. The per-buffer variable "buffers_view_creator" is responsible for creating a view into a buffer. The "view creator" is typically invoked by the routine "select_or_create_buffer". Guide to EMODE 14 The required per-view variables are: windows_refresher Which should actually be called the "views_refresher", is a routine to APPLY to no arguments. This routine is the refresh algorithm for whatever data structure this view looks into. WindowsBufferName Is the name (an ID) of the buffer that the view looks into. views_cleanup_routine A routine that's called when a view is being deleted from the screen. Different views may require different kinds of cleaning up at this point. For example, they should "deselect" any "virtual screens" that make up the view. The view creator for text structures is "create_text_view". This routine typically modifies and returns the current view (which is almost certainly also looking into text in the current system) so that the current view looks into the new text buffer. Most of the real work of creating text views is done by the routine "FramedWindowDescriptor", which is typically invoked by the routines "OneWindow" and "TwoRFACEWindows". (So, although select_or_create_buffer is one way of creating views into a buffer, there's quite a bit of freedom in using other methods for creating views.) 7. Manipulating Text Buffers 7. Manipulating Text Buffers 7. Manipulating Text Buffers The text in "text buffers" is stored as a vector of strings in the per-buffer variable "CurrentBufferText"--with the exception of a "current line" (stored in the per-buffer variable "CurrentLine"), which is a linked list of character codes. The CurrentLine is the line indexed by "CurrentLineIndex". Refer to the routine create_text_buffer for details of the contents of a text buffer. It's an easy mistake to modify CurrentLine but to forget to update the CurrentBufferText when moving to a new line. For this reason, and because the representation used for text may change in the future, you should use the utilities provided (mostly) in PES:EMODE1.RED to manipulate text. The procedure "GetLine(x)" can be used to get line x as the current line. The procedure "PutLine()" is used to store the current line back into CurrentBufferText. The procedure "SelectLine(x)" first "puts away" the current line, and then "gets" line x. Guide to EMODE 15 It would seem natural to move forward a line in the text by doing something like SelectLine(CurrentLineIndex + 1); but you should resist the temptation. For one thing, SelectLine makes little attempt to check that you stay within the limits of the buffer. Furthermore, future representations of text may not use integers to index lines. For example, some future version may use a doubly linked list of "line structures" instead of a vector of strings. So, you should use the routines "NextIndex" and "PreviousIndex" to calculate new "indices" into text, and you should also check to make sure that CurrentLineIndex is within the bounds of the buffer. You can probably just use the routines "!$ForwardLine" and "!$BackwardLine", (or "!$ForwardCharacter" and "!$BackwardCharacter"). You should also read some of the code in EMODE1.RED before attempting your own modifications. (Much of the code is rather ugly, but it does seem to work!) 8. Evaluating Expressions in EMODE Buffers 8. Evaluating Expressions in EMODE Buffers 8. Evaluating Expressions in EMODE Buffers The "M-E" command for evaluating an expression in a buffer (of the appropriate mode) depends on I/O channels that read from and write to EMODE buffers. This is implemented in a fairly straightforward manner, using the general I/O hooks provided by PSL. (See the Input/Output chapter of the PSL Manual for further details.) The code for EMODE buffer I/O resides in the file RFACE.RED. The tricky part of implementing M-E is making it fit with the READ/EVAL/PRINT loop that Lisp and other front ends use. The most obvious scheme would be to have EMODE invoke one "READ/EVAL/PRINT" for each M-E typed. However, this doesn't work well when a break loop, or a user's program, unexpectedly prompts for input. Instead, the top level read functions in PSL call the "hook" function, MakeInputAvailable(), which allows the user to edit a buffer before the reader actually takes characters from the current standard input channel. Examples of top level read functions are READ (for Lisp), and XREAD (for RLISP). If you define your own read function, for example--to use with the general TopLoop mechanism, it should also call MakeInputAvailable before trying to actually read anything. Guide to EMODE 16 When EMODE dispatches on M-E, it RETURNS to the routine that called it (e.g. READ), which then reads from the selected channel (which gets characters from an EMODE buffer). After evaluating the expression, the program then PRINTs to an output channel which inserts into another EMODE buffer. EMODE is then called again by the read routine (indirectly, via MakeInputAvailable). _______ __ ___ ______ The fact that EMODE returns to the reader means that different buffers cannot use different readers. This can be a bit confusing when editing several buffers with different kinds of code. Simply switching to a buffer with Lisp code does not cause the system to return to READ instead of XREAD. Implementing this would require some sort of coroutine or process mechanism--neither of which are currently provided in PSL. (However, it may be possible to provide an acceptable approximation by having M-E normally invoke a READ/EVAL/PRINT operation, while preserving the MakeInputAvailable hook for exceptional situations.) 9. Customizing EMODE for New Terminals 9. Customizing EMODE for New Terminals 9. Customizing EMODE for New Terminals The files PE:AAA.SL, PE:DM1520.SL, PE:HP2648A.SL, PE:TELERAY.SL, PE:VT52.SL, and PE:VT100.SL define the different terminal drivers currently available. Terminal drivers define some values and functions used to emit the appropriate character strings to position the cursor, erase the screen and clear to end of line. To define a new terminal, use one of the files as a guide. A listing of TELERAY.SL follows: % % TELERAY.SL - EMODE support for Teleray terminals % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) % (total dimensions are 80 wide by 24 down). (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals % that don't have a meta key. It should be 8#177 in that case. % Should be 8#377 for terminals with a meta key. Guide to EMODE 17 (setf parity_mask 8#377) (DE EraseScreen () (progn (PBOUT (Char ESC)) (PBOUT (Char (lower J))))) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (char Y)) (PBOUT (plus (char BLANK) RowLoc)) (PBOUT (plus (char BLANK) ColLoc)))) Guide to EMODE 18 10. Bibliography 10. Bibliography 10. Bibliography [Armantrout 81] Armantrout, R.; Benson, E.; Galway, W.; and Griss, M. L. ____ _ _____ ______ ______ ______ _______ __ EMID: A Multi-Window Screen Editor Written in ________ ____ Standard LISP. Utah Symbolic Computation Group Opnote No. 54, University of Utah, Department of Computer Science, January, 1981. [Carter 81] Carter, T.; Galway, W.; Goates, G.; Griss, M. L.; and Haslam, R. _____ _ ____ _____ _____ ____ ____ ______ ___ ___ SLATE: A Lisp Based EMACS Like Text Editor for SLA ______ Design. Utah Symbolic Computation Group Opnote 55, University of Utah, Department of Computer Science, January, 1981. [Carter 82] T. M. Carter. ASSASSIN: An Assembly, Specification and Analysis System for Speed-Independent Control-Unit Design in Integrated Circuits Using PPL. Master's thesis, Department of Computer Science, University of Utah, June, 1982. [Finseth 80] Finseth, C. A. ______ ___ ________ __ ____ _______ Theory and Practice of Text Editors. MIT/LCS/TM-165, Massachusetts Institute of Technology, Laboratory for Computer Science, May, 1980. [Griss 81] Griss, M. L. and Morrison, B. ___ ________ ________ ____ _____ ______ The Portable Standard LISP Users Manual. Utah Symbolic Computation Group Technical Report TR-10, University of Utah, March, 1981. [Stallman 81a] Stallman, R. M. EMACS The Extensible, Customizable Self- Documenting Display Editor. ___________ __ ___ ___ _______ _______ In Proceedings of the ACM SIGPLAN Notices _________ __ ____ ____________ Symposium on Text Manipulation, pages 147-156. ACM, New York, New York, June, 1981. [Stallman 81b] Stallman, R. M. _____ ______ ___ ______ _____ EMACS Manual for TWENEX Users. AI Memo 555, Massachusetts Institute of Technology, Artificial Intelligence Laboratory, May, 1981. Guide to EMODE 19 APPENDIX A: Default Keyboard Bindings for EMODE APPENDIX A: Default Keyboard Bindings for EMODE APPENDIX A: Default Keyboard Bindings for EMODE The following commands are notable either for their difference from EMACS, or for their importance to getting started with EMODE: - To leave EMODE type C-X C-Z to "QUIT" to the EXEC, or C-Z C-Z to return to "normal" PSL input/output. - While in EMODE, the "M-?" (meta- question mark) character asks for a command character and prints the name of the routine attached to that character. - The function "PrintAllDispatch()" will print out the current dispatch table. You must call EMODE first, to set this table up. - M-C-Y inserts into the current buffer the text printed as a result of the last M-E. - M-X prompts for a one line string and then executes it as a Lisp expression. Of course, similar results can be achieved by using M-E in a buffer. A (fairly) complete table of keyboard bindings follows: C-@ Runs the function SETMARK. C-A Runs the function !$BEGINNINGOFLINE. C-B Runs the function !$BACKWARDCHARACTER. C-D Runs the function !$DELETEFORWARDCHARACTER. C-E Runs the function !$ENDOFLINE. C-F Runs the function !$FORWARDCHARACTER. Tab In Lisp mode, runs the function LISP-TAB-COMMAND. Indents as appropriate for Lisp. Linefeed In text mode, runs the function !$CRLF and acts like a carriage return. In Lisp mode, runs the function LISP-LINEFEED- COMMAND. Inserts a newline and indents as appropriate for Lisp. C-K Runs the function KILL_LINE. C-L Runs the function FULLREFRESH. Return Runs the function $CRLF (inserts a carriage return). C-N Runs the function !$FORWARDLINE. C-O Runs the function OPENLINE. C-P Runs the function !$BACKWARDLINE. C-Q Runs the function INSERTNEXTCHARACTER. Acts like a "quote" for the next character typed. C-R Backward search for string, type a carriage return to terminate the search string. Default (for a null string) is the last string previously Guide to EMODE 20 searched for. C-S Forward search for string. C-T Transpose the last two characters typed (if the last character typed was self inserting). Otherwise, transpose the characters to the left and right of point, or the two characters to the left of point if at the end of a line. C-U Repeat a command. Similar to EMACS's C-U. C-V Runs the function SCROLL-WINDOW-UP-PAGE-COMMAND. C-W Runs the function KILL_REGION. C-X As in EMACS, control-X is a prefix for "fancier" commands. C-Y Runs the function INSERT_KILL_BUFFER. Yanks back killed text. C-Z Runs the function DOCONTROLMETA. As in EMACS, acts like "Control-Meta" (or "Meta-Control"). ESCAPE Runs the function ESCAPEASMETA. As in EMACS, ESCAPE acts like the "Meta" key. ) Inserts a "matching" right parenthesis. Bounces back to the corresponding left parenthesis, or beeps if no matching parenthesis is found. RUBOUT Runs the function !$DELETEBACKWARDCHARACTER. M-C-@ Runs the function MARK-SEXP-COMMAND. Sets mark at the end of the s-expression following point. M-C-A In Lisp mode, runs the function BEGINNING-OF- DEFUN-COMMAND. Moves backward to the beginning of the current or previous) DEFUN. A DEFUN is heuristically defined to be a line whose first character is a left parenthesis. M-C-B Runs the function BACKWARD_SEXPR. M-C-D Runs the function DOWN-LIST. Moves "deeper" into the next contained list. M-C-E In Lisp mode, runs the function END-OF-DEFUN- COMMAND. Moves forward to the beginning of the next line following the end of a DEFUN. M-C-F Runs the function FORWARD_SEXPR. M-Backspace In Lisp mode, runs the function MARK-DEFUN- COMMAND. M-Tab In Lisp mode, runs the function LISP-TAB-COMMAND. M-C-K Runs the function KILL_FORWARD_SEXPR. M-Return Runs the function BACK-TO-INDENTATION-COMMAND. Similar to C-A, but skips past any leading blanks. M-C-N Runs the function MOVE-PAST-NEXT-LIST. Moves to _______ the right of the current or next list. M-C-O Runs the function FORWARD-UP-LIST. Moves to the _______ right of the current list. M-C-P Runs the function MOVE-PAST-PREVIOUS-LIST. Moves to the beginning of the current or previous list. M-C-Q Runs the function LISP-INDENT-SEXPR. "Lisp indents" each line in the next s-expr. M-C-U Runs the function BACKWARD-UP-LIST. Does the Guide to EMODE 21 "opposite" of FORWARD-UP-LIST. M-C-Y In Lisp and Rlisp mode runs the function INSERT_LAST_EXPRESSION. Inserts the last body of text typed as the result of a M-E. M-C-Z Runs the function OLDFACE. Leaves EMODE, goes back to "regular" PSL input/output. M-Escape In Lisp mode, runs the function BEGINNING-OF- DEFUN-COMMAND. (See M-C-A.) M-C-] In Lisp mode, runs the function END-OF-DEFUN- COMMAND. (See M-C-E.) M-C-RUBOUT Runs the function KILL_BACKWARD_SEXPR. M-% Runs the function QUERY-REPLACE-COMMAND. Similar to EMACS's query replace. M-( Runs the function INSERT-PARENS. Inserts a matching pair of parenthesis, leaving point between them. M-) Runs the function MOVE-OVER-PAREN. Moves over a ")" updating indentation (as appropriate for Lisp). M-/ Runs the function !$HELPDISPATCH, see the description of M-? below. M-; In Lisp and Rlisp mode runs the function INSERTCOMMENT. M-< Runs the function !$BEGINNINGOFBUFFER. Move to beginning of buffer. M-> Runs the function !$ENDOFBUFFER. Move to end of buffer. M-? Runs the function !$HELPDISPATCH. Asks for a character and prints the name of the routine attached to that character. M-@ Runs the function MARK-WORD-COMMAND. M-B Runs the function BACKWARD_WORD. Backs up over a word. M-D Runs the function KILL_FORWARD_WORD. M-E In Lisp and RLISP modes evaluates the expression starting at the beginning of the current line. M-F Runs the function FORWARD_WORD. Moves forward over a word. M-M Runs the function BACK-TO-INDENTATION-COMMAND. (See M-Return for more description.) M-V Runs the function SCROLL-WINDOW-DOWN-PAGE- COMMAND. Moves up a window. M-W Runs the function COPY_REGION. Like C-W only it doesn't kill the region. M-X Runs the function EXECUTE_COMMAND. Prompts for a string and then converts it to Lisp expression and evaluates it. M-Y Runs the function UNKILL_PREVIOUS. Used to cycle through the kill buffer. Deletes the last yanked back text and then proceeds to yank back the previous piece of text in the kill buffer. M-\ Runs the function DELETE-HORIZONTAL-SPACE- Guide to EMODE 22 COMMAND. Deletes all blanks (and tabs) around point. M-^ Runs the function DELETE-INDENTATION-COMMAND. Deletes CRLF and indentation at front of line, leaves one space in place of them. M-RUBOUT Runs the function KILL_BACKWARD_WORD. C-X C-B Runs the function PRINTBUFFERNAMES. Prints a list of all the buffers present. C-X C-F Runs the function FIND_FILE. Asks for a filename and then selects the buffer that that file resides in, or creates a new buffer and reads the file into it. C-X C-O Runs the function DELETE-BLANK-LINES-COMMAND. Deletes blank lines around point (leaving one left). C-X C-P Runs the function WRITESCREENPHOTO. Write a "photograph" of the screen to a file. C-X C-R Runs the function CNTRLXREAD. Read a file into the buffer. C-X C-S Runs the function SAVE_FILE. Writes the buffer to the file associated with that buffer, asks for an associated file if none defined. C-X C-W Runs the function CNTRLXWRITE. Write the buffer out to a file. C-X C-X Runs the function EXCHANGEPOINTANDMARK C-X C-Z As in EMACS, exits to the EXEC. C-X 1 Goes into one window mode. C-X 2 Goes into two window mode. C-X B Runs the function CHOOSEBUFFER. EMODE asks for a buffer name, and then selects (or creates) that buffer for editing. C-X H Runs the function MARK-WHOLE-BUFFER-COMMAND. C-X N Runs the function NEXT_WINDOW. Selects the "next" window in the list of active windows. Note that some active windows may be covered by other screens, so they will be invisible until C-X N reaches them and "pops" them to the "top" of the screen. C-X O An alternate way to invoke NEXT_WINDOW. C-X P Runs the function PREVIOUS_WINDOW. Selects the "previous" window in the list of active windows. Guide to EMODE 23 APPENDIX B: Some Important Fluid Variables APPENDIX B: Some Important Fluid Variables APPENDIX B: Some Important Fluid Variables Here is an incomplete list of the fluid ("global") variables in EMODE. *outwindow A flag for PSL's ON/OFF mechanism. When T, means that the "output" (or OUT_WINDOW) window should be "popped up" when output occurs. *EMODE T when EMODE is running. (Not quite the same as "runflag" described below. For example, runflag will be set NIL to cause EMODE to leave a "recursive edit", but *EMODE stays T.) *RAWIO T when "raw I/O" is in effect. BasicDispatchList The "key list" for "basic" operations. BreakWindow The view for the "popup" break window. BufferNames An association list of the (name . buffer-environment) pairs for all the buffers. CurrentBufferName The name of the currently selected buffer. CurrentBufferSize A per-buffer variable for text buffers, gives number of lines actually within buffer. CurrentBufferText A per-buffer variable for text buffers. A vector of lines making up the buffer. CurrentLine A per-buffer variable for text buffers. The contents (text) of current line--as a linked list of character codes. (Takes precedence over whatever is contained in the text vector.) CurrentLineIndex A per-buffer variable for text buffers. Index of the "current line" within buffer. CurrentVirtualScreen Per-view variable for text windows (views), holds the virtual screen used by the view. CurrentWindowDelta Per-view variable for text windows, gives window dimensions as (delta x . delta y). CurrentWindowDescriptor The currently selected window environment. declared_data_modes List of (mode-name . buffer-creator) pairs for all the declared modes. declared_file_extensions List of (file-extension . buffer-creator) pairs for all modes with declared file extensions. Guide to EMODE 24 EmodeBufferChannel Channel used for EMODE I/O. Perhaps this should be expanded to allow different channels for different purposes (break loops, error messages, etc.) (Or, perhaps the whole model needs more thought! ) FirstCall NIL means re-entering EMODE, T means first time. FundamentalTextMode Mode list (list of expressions) for establishing "fundamental" text mode. kill_buffer_ring Vector of vectors of strings--holds recently deleted text. kill_opers list of (names of) handler routines that kill text. NEEDS MORE DOCUMENTATION! kill_ring_index Pointer to the most recent "kill buffer". last_buffername Name (a string) of the last buffer visited. last_operation The "last" routine dispatched to (before the "current operation"). last_search_string The last string searched for by a search command--used as default for next search command. last_yank_point Vector of [buffer lineindex point], giving location where last "yank" occured. LispDispatchList The "key list" for Lisp mode. LispMode The mode list for Lisp mode. MainDispatch Dispatch table (vector), an entry for each key. minor_window_list List of windows to be ignored by the "next_window" routine. ModeEstablishExpressions List of expressions to be evaluated. Each expression is expected to modify (add to?) the dispatch table. OldErrOut The error output channel in effect before EMODE was started. OldStdIn The standard input channel in effect before EMODE was started. OldStdOut The standard output channel in effect before EMODE was started. point A per-buffer variable for text buffers. Number of chars to the left of point within CurrentLine. PrefixAssociationLists Additional dispatch information for prefixed characters. PrefixCharacterList A list of the declared prefix characters. Guide to EMODE 25 pushed_back_characters A list of characters pushed back for EMODE's command reader. This may be used when a command isn't recognized by one dispatcher, so it can push the characters back and pass control to another dispatcher. reading_from_output Kludge flag, T when input buffer is OUT_WINDOW buffer (for M-E). RlispDispatchList The "key list" for RLISP mode. RlispMode The mode list for RLISP mode. runflag EMODE continues its READ/DISPATCH/REDISPLAY until this flag is NIL. SelfInsertCharacter Character being dispatched upon. (Usually the last character typed.) ShiftDisplayColumn Amount to shift things to the left by before (re)displaying lines in a text view. TextDispatchList The "key list" for fundamental text mode. Two_window_midpoint Gives location (roughly) of dividing line for two window mode. WindowList List of active windows (views). WindowsBufferName Required per-view variable giving the name of the buffer being viewed. Windows_Refresher Required per-view variable giving the refresh algorithm to be APPLYed for this view. Window_Image Per-view variable for text views, holding information for speeding up refresh. Guide to EMODE i Table of Contents Table of Contents Table of Contents 1. Introduction and Acknowledgments 1 2. Running EMODE 1 3. A Guide to the Sources and Rebuilding 6 4. Terminology: Buffers, Views/Windows, and Virtual Screens 7 5. Modes and Key bindings in EMODE 9 6. Creating New Modes 12 7. Manipulating Text Buffers 14 8. Evaluating Expressions in EMODE Buffers 15 9. Customizing EMODE for New Terminals 16 10. Bibliography 18 APPENDIX A: Default Keyboard Bindings for EMODE 19 APPENDIX B: Some Important Fluid Variables 23 Guide to EMODE ii List of Figures List of Figures List of Figures Figure 2-1: Figure 2-1: Figure 2-1: Two window mode 3 Figure 2-2: Figure 2-2: Figure 2-2: One window mode 4 Figure 2-3: Figure 2-3: Figure 2-3: A break window (doctored from the original) 5 |
Added psl-1983/emode/emode.mss version [8791f0f36c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @use[bibliography = "<galway.scribe>biblio.bib"] @make[article] @style[references = STDalphabetic] @style[spacing 1] @style[indentation 5] @modify[enumerate, numbered=<@a. @,@i. >, spread 0, above 1, below 1] @modify[itemize,spread 0, above 1, below 1] @modify[example, above 1, below 1] @modify[description, spread 1, above 1, below 1] @modify[appendix, numbered=<APPENDIX @A: >] @pageheading[Left "Utah Symbolic Computation Group", Right "June 1982", Line "Operating Note No. 69" ] @set[page=1] @newpage[] @begin[titlepage] @begin[titlebox] @begin[center] @b[A Guide to EMODE] by William F. Galway and Martin L. Griss Department of Computer Science University of Utah Salt Lake City, Utah 84112 Last Revision: @value[date] @end[center] @end[titlebox] @begin[abstract] EMODE is a LISP-based EMACS-like editor that runs on the PSL system. This document is meant to serve as a guide to using EMODE--but will only be roughly up to date, since the system is in a state of transition. @end[abstract] @begin[Researchcredit] Work supported in part by the National Science Foundation under Grant No. MCS80-07034. @end[Researchcredit] @end[titlepage] @pageheading[Left "Guide to EMODE", Right "@value(Page)"] @set[page=1] @newpage[] @section[Introduction and Acknowledgments] @Comment{Needs more?} This paper describes the EMODE editor being developed for PSL @cite[PSL-manual]. EMODE is an interactive, EMACS like @cite[STALLMAN-ARTICLE-81], screen editor. EMODE provides multiple windows, can simultaneously support different "modes" of editing in different buffers, and supports a variety of CRT terminals such as the Teleray 1061 and the DEC VT-100. Several people have made contributions to EMODE. EMODE itself is based on an earlier editor EMID @cite[Armantrout81], written by Robert Armantrout and Martin Griss for LISP 1.6. Tony Carter has used EMODE to develop several large packages for VLSI circuitry design @cite[Carter81, Carter-THESIS]. Optimizations for the Vax version, and many useful comments, have been provided by Russ Fish. Several features have been added by Alan Snyder and Cris Perdue at Hewlett Packard Research Labs. Cris implemented the current version of "mode lists", while Alan has implemented a huge number of commands and improved the efficiency of several operations. @section[Running EMODE] EMODE is available as a "loadable" file. It can be invoked as follows: @begin[example] @@PSL:RLISP [1] load emode; [2] emode(); @end[example] Of course, you may choose to invoke RLISP (or PSL) differently, and to perform other operations before loading and running EMODE. From this point on the term "PSL" will be used to refer to this family of systems, independently of whether they use Lisp or RLISP syntax. The terminal that EMODE uses by default is determined by its LOADing the file DEFAULT-TERMINAL. At the University of Utah this is the TELERAY driver. At other sites, some other driver may be chosen as the default. To use a different terminal you must LOAD in a different "driver file" after loading EMODE. For example, to run EMODE on the Hewlett Packard 2648A terminal, you could type: @begin[example] @@PSL:RLISP [1] load emode, hp2648a; [2] emode(); @end[example] The following drivers are currently available: @begin[description,spread 0] AAA@\For the Ann Arbor Ambassador. DM1520@\For the Datamedia 1520. HP2648A@\For the Hewlett Packard 2648A and similar Hewlett Packard terminals. @Comment{Should we be this specific?} TELERAY@\For the Teleray 1061. VT52@\For the DEC VT52. VT100@\For the DEC VT100. @end[description] See section @ref[terminal-drivers] for information on creating new terminal drivers. EMODE is quite similar to EMACS @cite[EMACS-manual, STALLMAN-ARTICLE-81], although it doesn't have nearly as many commands. A detailed list of commands is given in appendix @ref[key-bindings]. This information can also be obtained by typing @w["HELP EMODE;"] to RLISP, or (equivalently) by reading the file PH:EMODE.HLP. The notation used here to describe character codes is basically the same as that used for EMACS. For example: C-Z means "control-Z", the character code produced by typing Z while holding down the control key. The ascii code for a control character is the same as the 5 low order bits of the original character--the code for Z is 132 octal, while the code for C-Z is 32 octal. M-Z means "meta-Z", the character produced by typing Z while holding down the meta key. To support those terminals without a meta key, the same result can normally be achieved by typing two characters--first the ESCAPE character, then the Z character. The ascii code for a meta character is the same as the original character with the parity bit set--the code for M-Z is 332 octal. (Some terminals use the ESCAPE character for other purposes, in which case the "META prefix" will be some other character.) Rather than using the EMACS convention, we write "control-meta" characters (such as C-M-Z) as "meta-control" characters (M-C-Z), since the latter notation better reflects the internal code (232 octal for M-C-Z). The C-Z character is used as a "meta-control" prefix, so one way to type M-C-Z is to type @w[C-Z C-Z]. (Another way to type it is to hold down the meta and control keys and type "Z".) When EMODE is started up as described above, it will immediately enter "two window mode". To enter "one window mode", you can type "C-X 1" (as in EMACS). Commands can be typed into a buffer shown in the top window. The result of evaluating a command is printed into the OUT_WINDOW buffer (shown in the bottom window). To evaluate the expression starting on the current line, type M-E. M-E will (normally) automatically enter two window mode if anything is "printed" to the OUT_WINDOW buffer. If you don't want to see things being printed to the output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode when something is printed to OUT_WINDOW. You must still use the "C-X 1" command to enter one window mode initially. Figure @ref[two-window-figure] shows EMODE in two window mode. In this mode the top window includes everything above (and including) the first line of dashes. This is followed by a single line window, showing the current prompt from PSL. Beneath this is the "output window", the window which usually shows the OUT_WINDOW buffer. This is followed by another single line window, which EMODE uses to prompt the user for values (not the same as PSL's prompt). @begin[figure] @begin[example] % Commands can be typed in the top window. % When they're executed the value is printed into % the OUT_WINDOW buffer. x := '(now is the time); y := cddr x; ----MAIN-----------------------------------------85%--- [7] ------------------------------------------------------- NIL (NOW IS THE TIME) (THE TIME) ----OUT_WINDOW-----------------------------------75%--- File for photo: s:twowindow.photo @end[example] @caption[Two window mode] @tag[two-window-figure] @end[figure] Figure @ref[one-window-figure] shows EMODE in one window mode. The "top window" takes up most of the screen, followed by EMODE's prompt line, and then by PSL's prompt line. @begin[figure] @begin[example] % Commands can be typed in the top window. % When they're executed the value is printed into % the OUT_WINDOW buffer. x := '(now is the time); y := cddr x; ----MAIN-----------------------------------------85%--- File for photo: s:onewindow.photo [7] @end[example] @caption[One window mode] @tag[one-window-figure] @end[figure] The BREAK handler has been modified by EMODE to "pop up" a "break window menu". This is illustrated in figure @ref[break-window-figure]. The commands in the menu can be executed with the M-E command, and you can also edit the BREAK buffer just like any other buffer. If you wish to move to another window, use the @w[C-X N] command. This may cause the break window to disappear as it is covered by some other window, but @w[C-X P] will find it and pop it to the "top" of the screen again. @begin[figure] @begin[example] cdr 2; +------------------------------+ |A ;% To abort | |Q ;% To quit | |T ;% To traceback | |I ;% Trace interpreted stuff | |R ;% Retry | |C ;% Continue, | | % using last value | ----MAIN-----------|? ;% For more help |- 4 lisp break> +----BREAK---------------11%---+ ---------------------------------------------------- NIL ***** An attempt was made to do CDR on `2', which is not a pair {99} Break loop ----OUT_WINDOW-----------------------------------75%--- File for photo: s:breakwindow.photo @end[example] @caption[A break window (doctored from the original)] @tag[break-window-figure] @end[figure] EMODE is not very robust in its handling of errors. Here's a summary of known problems and suggestions on how to deal with them: @begin[description] Garbage collection messages "blow up":@\Printing messages into EMODE buffers involves CONSing, so the system blows up if it tries to print a message from inside the garbage collector. EMODE sets GC OFF at load time. Always run EMODE with GC OFF. @begin[multiple] Terminal doesn't echo:@\This can be caused by abnormal exits from EMODE. If PSL is still running, you can call the routine "EchoOn" to turn echoing back on. (It's the routine "EchoOff" that turns echoing off, and starts "raw output" mode.) Otherwise, as may happen on the Vax running Unix, you will have to give shell commands to turn echoing back on. This is best done by defining the following alias in your ".login" file. @begin[example] alias rst 'reset; stty -litout intr ^C' @end[example] (That's a "control-C", not "uparrow C".) The "rst" command must be typed as "<LF>rst<LF>" because carriage-return processing is turned off. @end[multiple] "Garbled" printout:@\This is probably caused by EMODE's not running in "raw output" mode--a problem which can be caused by some other errors. A cure is to type @w[C-Z C-Z] to leave EMODE, and then to call EMODE again. This should reset the terminal mode to "raw mode" (by calling EchoOff). (The @w[C-Z C-Z] must be followed by a linefeed on the Vax, to force the @w[C-Z C-Z] to be read.) @begin[multiple] Stuck in an error:@\This is often caused by trying to evaluate an expression that lacks a closing parenthesis (or some other terminator)--producing a message something like: @begin[example] ***** Unexpected EOF while reading ... @end[example] If it's obvious that an additional parenthesis will cure the problem, you can use @w[C-X N] to select the input window and insert it. Then position the cursor to the left of the parenthesis and use @w[C-X N] to select the break window and "Quit". Otherwise you should use the "Abort" option of the break handler. Currently this resets the terminal mode (at least on the DEC-20), so you'll have to restart EMODE as described above. The BREAK window will still be present on the screen after restarting, even though you are no longer in the break loop. You can use the @w[C-X 2] or @w[C-X 1] command to get rid of the break window, and then use the @w[C-X B] command to select some buffer other than the break buffer. @end[multiple] @end[description] @section[A Guide to the Sources and Rebuilding] The "primary" sources for EMODE reside on UTAH-20: @begin[description] PES:@\Is defined locally as <GALWAY.EMODE.V2>. This directory is for the "version 2" of EMODE--being maintained now. The corresponding "logical name" on the VAX is "$pes". PE:@\Is defined as <PSL.EMODE>. Holds sources and documentation which may be generally useful to the public. It includes sources for the various terminal drivers available for EMODE. (Further described in section @ref[terminal-drivers].) The corresponding logical name on the VAX is "$pe". @end[description] The file PES:BUILD-EMODE.CTL is the command file for building EMODE on the DEC-20. Use SUBMIT or DO to run the command file, which builds EMODE in two parts on the local directory: EMODE-B-1.B and EMODE-B-2.B. PES:BUILD-EMODE.CSH (or $pes/build-emode.csh) is the build file for the VAX. It also builds the binary files on the "local directory". On both machines the ".B" files for the terminal drivers and for RAWIO.B are built separately. The PES:EMODE.TAGS file can be used with the TAGS facility provided by EMACS on the DEC-20. (Highly recommended!) @section[Terminology: Buffers, Views/Windows, and Virtual Screens] @Comment{Need to say more about NSTRUCT, refer to some manual.} "Buffers", "views", and "virtual screens" are the three major data structures in EMODE. Virtual screens correspond fairly closely to what are often called @i[windows] in other systems. They are rectangular regions on the screen, possibly overlapping, that characters can be written to. A virtual screen provides a sort of pseudo-hardware. The operations that can be performed on a virtual screen are modeled after what can be done with a real terminal. The use of a virtual screen provides these advantages: @begin[itemize] Operations on a virtual screen are machine independent. (To some extent, this will be less true if we try to support "fancier" graphics.) The "bandwidth problem" of maintaining the screen image is isolated to the virtual screen package--other programs don't have to worry about the problem. Several virtual screens can be shown on one physical screen. @end[itemize] Virtual screens are implemented as "Structs" using the "DefStruct" facility provided by the loadable file "NSTRUCT". Buffers hold the data to be edited, possibly something other than text, depending on the buffer's "data mode". Views are data structures used to display buffers on the screen, they may be made of several virtual screens. The term @i["window"] is often used instead of "view", when you see the one term it should be possible to substitute the other. Buffers and views are implemented as "environments". An environment is an association list of @w[(NAME . VALUE)] pairs. (These association lists are sometimes referred to as "descriptors".) The usual method for working with an environment is "restoring" (or "selecting") the environment by calling the procedure "RestoreEnv". This sets each variable name in the list to its associated value. The procedure "SaveEnv" does the inverse operation of updating the values of each variable name in the association list. (This is done "destructively", using RPLACD.) The names in an environment are sometimes called "per-environment" variables. Names in "buffer environments" are called "per-buffer variables", and similarly for "per-view variables". Buffers and views are just environments that follow certain conventions. These conventions are that they always include certain @w[(name . value)] pairs--i.e. that they always include certain "per-buffer" or "per-view" variables. For example, the required per-buffer variables include: @begin[description] buffers_file@\The name (a string) of a file associated with the buffer, or NIL if no file is associated with the buffer. buffers_view_creator@\A routine that creates a "view" (or "window") looking into the buffer. @end[description] In addition to the required per-buffer variables, text buffers include variables containing things like the text being edited in the buffer and the location of "point" in the buffer. The required per-view variables include: @begin[description] windows_refresher@\(Which should actually be called the "views_refresher") defines a routine to be the refresh algorithm for whatever data structure this view looks into. WindowsBufferName@\Is the name (an ID) of the buffer that the view looks into. @end[description] Views into text buffers include additional information such as a virtual screen to display the text in, and "cache" information to make refreshing faster. The choice of whether variables should be per-buffer or per-view is sometimes unclear. For example, it would seem to make better sense to have "point" be part of a view, rather than a buffer. This would allow the user to have two windows looking into different parts of the same buffer. However, it would also require the selection of a window for the many functions that insert strings into the buffer, delete strings from the buffer, etc., since these routines all work around the current "point". Somehow it seems unnatural to require the selection of a @i[view] for these @i[buffer] operations. The current decision is to make point a per-buffer variable. Further details on buffers and views for different modes are given in section @ref[creating-modes]. A list of all the buffers in EMODE is stored in the variable "BufferNames" as a list of @w[(name . environment)] pairs . These pairs are created with the routine "CreateBuffer". A list of "active" views in EMODE is stored in the variable "WindowList". This is simply a list of "environments" (association lists as described above). Unlike buffers, views are not referred to by name. Instead, specific views can be referred to by storing their environment in a variable (such as "BreakWindow"). @section[Modes and Key bindings in EMODE] @label[key-modes] There are two aspects to "modes" in EMODE. One is the choice of the data structure to be edited within a buffer. Until recently there has only been one kind of structure: "text". As discussed in section @ref[creating-modes] EMODE now provides tools for editing other, user defined, structures. @begin[Comment] Is this DISTINCTION between key bindings and the binding of other variables really VALID? @end[Comment] The other aspect of "modes", discussed in this section, is the binding of "handler" routines to terminal keys (or sequences of keys for multi-key commands). A simple version of this would associate a table of handlers (indexed by character code) with each buffer (or view). The method actually used is more complicated due to a desire to divide keyboard bindings into groups that can be combined in different ways. For example, we might have a text mode and an Rlisp mode, and an optional Word Abbreviation Mode that could be combined with either of them to cause automatic expansion of abbreviations as they are typed. Implementing optional keyboard bindings that can @i[removed] as well as @i[added] is difficult. Consider the situation with an optional "Abbreviation Mode" and an optional "Auto Fill Mode". Turning on either mode redefines the space character to act differently. In each case, the new definition for space would be something like "do some fancy stuff for this submode, and then do whatever space used to do". Imagine the difficulties involved in turning on "Abbreviation Mode" and then "Auto Fill Mode" and then turning off "Abbreviation Mode". EMODE's solution to the problem is based on the method suggested in @cite[FINSETH]. A @i[single], @i[global] "dispatch vector" is used, but is rebuilt when switching between buffers. The mode for each buffer is stored as a list of expressions to be evaluated. Evaluating each expression enters the bindings for an associated group of keys into the vector. Incremental modes can be added or deleted by adding or deleting expressions from the list. Although changing modes is fairly time consuming (more than a few microseconds), we assume that this is rare enough that the overhead is acceptable. NOTE that simply changing an entry in the dispatch vector will not work--since any switching between buffers will cause the entry to be permanently lost. The dispatch "vector" is actually implemented as a combination of a true PSL vector "MainDispatch", indexed by character code, and an association list "PrefixAssociationLists" used to implement two character commands. Currently the only two character commands start with the "prefix character" C-X, although the mechanism is more general. Prefix characters are "declared" by calling the routine "define_prefix_character" (refer to code for details). Bindings for prefix-character commands are stored in PrefixAssociationLists as an association list of association lists. The top level of the list is "indexed" by the prefix character, the next level contains @w[(character . handler)] pairs indexed by the character following the prefix character. The list of expressions for building the dispatch vector is called the "mode list", and is stored in the per-buffer variable "ModeEstablishExpressions". See the following section for more on how ModeEstablishExpressions is used in the declaration of a mode. The procedure "EstablishCurrentMode" evaluates these expressions in reverse order (the last expression in the list is evaluated first) to establish the keyboard dispatch vector used for editing the current buffer. Reverse order is used so that the @i[last] expression added to the @i[front] of the list will be evaluated last. EstablishCurrentMode must be called after changing the mode list for the current buffer and when switching to a different buffer @i[for editing from the keyboard]. The routine SelectBuffer switches to a buffer without "establishing" the buffer's mode. This saves the cost of setting up the dispatch vector when it isn't needed (which is the case for most "internal operations" on buffers). The expressions in ModeEstablishExpressions can execute @i[any] code desired. This generality is rarely needed, the usual action is to call the routine SetKeys with a list of @w[(character . handler)] pairs. For example, the mode list for text mode is defined by this Lisp code: @begin[example] (setf FundamentalTextMode '((SetKeys TextDispatchList) (SetKeys BasicDispatchList) (NormalSelfInserts))) @end[example] The RLISP mode is built "on top of" FundamentalTextMode as follows: @begin[example] (setf RlispMode (cons '(SetKeys RlispDispatchList) FundamentalTextMode)) @end[example] This section taken from the code that builds BasicDispatchList shows what a "key list" for the SetKeys routine should look like: @begin[example] (setf BasicDispatchList (list (cons (char ESC) 'EscapeAsMeta) (cons (char (cntrl U)) '$Iterate) (cons (char (cntrl Z)) 'DoControlMeta) % "C-X O" switches to "next window" (or "other % window" if in "two window mode"). (cons (CharSequence (cntrl X) O) 'next_window) (cons (CharSequence (cntrl X) (cntrl F)) 'find_file) . . . @end[example] Note that the pairs in a key list can specify character sequences like "@w[(cntrl X) O]" as well as single characters. At runtime, after they're created, key lists can be most easily modified by calling the routine AddToKeyList. For example @begin[example] (AddToKeyList 'RlispDispatchList (char (meta (cntrl Z))) 'DeleteComment) @end[example] could be executed to add a new, "delete comment" handler to RLISP mode. The routine SetTextKey is equivalent to adding to the key list TextDispatchList (see code). For example @begin[example] (SetTextKey (char (meta !$)) 'CheckSpelling) @end[example] could be executed to add a new "spelling checker" command to text mode (and other modes such as RLISP mode that incorporate text mode). SetTextKey seems to correspond most closely to EMACS's "Set Key" command. The routine "SetLispKey" is also defined for adding bindings to "Lisp mode". (There is no "SetRlispKey" routine in EMODE, although it would be easy to define for yourself if desired.) @section[Creating New Modes] @label[creating-modes] To define a new mode you must provide a "buffer creator" routine that returns a "buffer environment" with the required per-buffer variables along with any other state information needed for the type of data being edited. You need to "declare" the mode by calling the routine "declare_data_mode". It's also possible to associate the mode with a file extension by calling the routine "declare_file_mode". For example, the current EMODE declares the modes, "text" and "rlisp", as follows: @begin[example] (declare_data_mode "text" 'create_text_buffer) (declare_data_mode "rlisp" 'create_rlisp_buffer) (declare_file_mode "txt" 'create_text_buffer) (declare_file_mode "red" 'create_rlisp_buffer) @end[example] The second argument to both routines is the "buffer creator" routine for that mode. The first argument to declare_data_mode is a "name" for the mode. The first argument to declare_file_mode is a file extension associated with that mode. The conventions for "buffer environments" are that they always include certain @w[(name . value)] pairs--i.e. that they always include certain "per-buffer" variables. These variables are: @begin[description] ModeEstablishExpressions@\A list of expressions to evaluate for establishing the keyboard bindings for the buffer's mode. buffers_file@\The name (a string) of a file associated with the buffer, or NIL if no file is associated with the buffer. buffers_file_reader@\A routine to APPLY to one argument--a PSL io-channel. The routine should read the channel into the current buffer. buffers_file_writer@\A routine to APPLY to an io-channel. The routine writes the current buffer out to that channel. buffers_view_creator@\A routine to create a "view" (or "window") looking into the buffer. This is described in more detail below. @end[description] For example, the buffer creator for "text mode" is: @begin[example] (de create_text_buffer () (cons (cons 'ModeEstablishExpressions FundamentalTextMode) (create_raw_text_buffer))) @end[example] Most of the work is done by create_raw_text_buffer, which does everything but determine the keyboard bindings for the buffer. Here's the code with comments removed: @begin[example] (de create_raw_text_buffer () (list (cons 'buffers_view_creator 'create_text_view) (cons 'buffers_file_reader 'read_channel_into_text_buffer) (cons 'buffers_file_writer 'write_text_buffer_to_channel) (cons 'buffers_file NIL) (cons 'CurrentBufferText (MkVect 0)) (cons 'CurrentBufferSize 1) (cons 'CurrentLine NIL) (cons 'CurrentLineIndex 0) (cons 'point 0) (cons 'MarkLineIndex 0) (cons 'MarkPoint 0) )) @end[example] Other modes based on text can be similarly defined by consing an appropriate binding for ModeEstablishExpressions to the environment returned by create_raw_text_buffer. Of course we need some way of "viewing" buffers once they've been created. The per-buffer variable "buffers_view_creator" is responsible for creating a view into a buffer. The "view creator" is typically invoked by the routine "select_or_create_buffer". The required per-view variables are: @begin[description] @begin[group] windows_refresher@\Which should actually be called the "views_refresher", is a routine to APPLY to no arguments. This routine is the refresh algorithm for whatever data structure this view looks into. @end[group] @begin[group] WindowsBufferName@\Is the name (an ID) of the buffer that the view looks into. @end[group] @begin[group] views_cleanup_routine@\A routine that's called when a view is being deleted from the screen. Different views may require different kinds of cleaning up at this point. For example, they should "deselect" any "virtual screens" that make up the view. @end[group] @end[description] The view creator for text structures is "create_text_view". This routine typically modifies and returns the current view (which is almost certainly also looking into text in the current system) so that the current view looks into the new text buffer. Most of the real work of creating text views is done by the routine "FramedWindowDescriptor", which is typically invoked by the routines "OneWindow" and "TwoRFACEWindows". (So, although select_or_create_buffer is one way of creating views into a buffer, there's quite a bit of freedom in using other methods for creating views.) @section[Manipulating Text Buffers] The text in "text buffers" is stored as a vector of strings in the per-buffer variable "CurrentBufferText"--with the exception of a "current line" (stored in the per-buffer variable "CurrentLine"), which is a linked list of character codes. The CurrentLine is the line indexed by "CurrentLineIndex". Refer to the routine create_text_buffer for details of the contents of a text buffer. It's an easy mistake to modify CurrentLine but to forget to update the CurrentBufferText when moving to a new line. For this reason, and because the representation used for text may change in the future, you should use the utilities provided (mostly) in PES:EMODE1.RED to manipulate text. The procedure "GetLine(x)" can be used to get line x as the current line. The procedure "PutLine()" is used to store the current line back into CurrentBufferText. The procedure "SelectLine(x)" first "puts away" the current line, and then "gets" line x. It would seem natural to move forward a line in the text by doing something like @begin[example] SelectLine(CurrentLineIndex + 1); @end[example] but you should resist the temptation. For one thing, SelectLine makes little attempt to check that you stay within the limits of the buffer. Furthermore, future representations of text may not use integers to index lines. For example, some future version may use a doubly linked list of "line structures" instead of a vector of strings. So, you should use the routines "NextIndex" and "PreviousIndex" to calculate new "indices" into text, and you should also check to make sure that CurrentLineIndex is within the bounds of the buffer. You can probably just use the routines "!$ForwardLine" and "!$BackwardLine", (or "!$ForwardCharacter" and "!$BackwardCharacter"). You should also read some of the code in EMODE1.RED before attempting your own modifications. (Much of the code is rather ugly, but it does seem to work!) @section[Evaluating Expressions in EMODE Buffers] The "M-E" command for evaluating an expression in a buffer (of the appropriate mode) depends on I/O channels that read from and write to EMODE buffers. This is implemented in a fairly straightforward manner, using the general I/O hooks provided by PSL. (See the Input/Output chapter of the PSL Manual for further details.) The code for EMODE buffer I/O resides in the file RFACE.RED. The tricky part of implementing M-E is making it fit with the READ/EVAL/PRINT loop that Lisp and other front ends use. The most obvious scheme would be to have EMODE invoke one "READ/EVAL/PRINT" for each M-E typed. However, this doesn't work well when a break loop, or a user's program, unexpectedly prompts for input. Instead, the top level read functions in PSL call the "hook" function, MakeInputAvailable(), which allows the user to edit a buffer before the reader actually takes characters from the current standard input channel. Examples of top level read functions are READ (for Lisp), and XREAD (for RLISP). If you define your own read function, for example--to use with the general TopLoop mechanism, it should also call MakeInputAvailable before trying to actually read anything. When EMODE dispatches on M-E, it RETURNS to the routine that called it (e.g. READ), which then reads from the selected channel (which gets characters from an EMODE buffer). After evaluating the expression, the program then PRINTs to an output channel which inserts into another EMODE buffer. EMODE is then called again by the read routine (indirectly, via MakeInputAvailable). The fact that EMODE @i[returns to the reader] means that different buffers cannot use different readers. This can be a bit confusing when editing several buffers with different kinds of code. Simply switching to a buffer with Lisp code does not cause the system to return to READ instead of XREAD. Implementing this would require some sort of coroutine or process mechanism--neither of which are currently provided in PSL. (However, it may be possible to provide an acceptable approximation by having M-E normally invoke a READ/EVAL/PRINT operation, while preserving the MakeInputAvailable hook for exceptional situations.) @section[Customizing EMODE for New Terminals] @label[terminal-drivers] The files PE:AAA.SL, PE:DM1520.SL, PE:HP2648A.SL, PE:TELERAY.SL, PE:VT52.SL, and PE:VT100.SL define the different terminal drivers currently available. Terminal drivers define some values and functions used to emit the appropriate character strings to position the cursor, erase the screen and clear to end of line. To define a new terminal, use one of the files as a guide. A listing of TELERAY.SL follows: @begin[verbatim] % % TELERAY.SL - EMODE support for Teleray terminals % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) % (total dimensions are 80 wide by 24 down). (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals % that don't have a meta key. It should be 8#177 in that case. % Should be 8#377 for terminals with a meta key. (setf parity_mask 8#377) (DE EraseScreen () (progn (PBOUT (Char ESC)) (PBOUT (Char (lower J))))) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (char Y)) (PBOUT (plus (char BLANK) RowLoc)) (PBOUT (plus (char BLANK) ColLoc)))) @end[verbatim] @Comment{Newpage???} @newpage[] @Comment{Section???} @section[Bibliography] @Bibliography[] @newpage[] @appendix[Default Keyboard Bindings for EMODE] @label[key-bindings] @include[keybindings.mss] @newpage[] @appendix[Some Important Fluid Variables] Here is an incomplete list of the fluid ("global") variables in EMODE. @begin[description] @begin[group] *outwindow@\A flag for PSL's ON/OFF mechanism. When T, means that the "output" (or OUT_WINDOW) window should be "popped up" when output occurs. @end[group] @begin[group] *EMODE@\T when EMODE is running. (Not quite the same as "runflag" described below. For example, runflag will be set NIL to cause EMODE to leave a "recursive edit", but *EMODE stays T.) @end[group] @begin[group] *RAWIO@\T when "raw I/O" is in effect. @end[group] @begin[group] BasicDispatchList@\The "key list" for "basic" operations. @end[group] @begin[group] BreakWindow@\The view for the "popup" break window. @end[group] @begin[group] BufferNames@\An association list of the @w[(name . buffer-environment)] pairs for all the buffers. @end[group] @begin[group] CurrentBufferName@\The name of the currently selected buffer. @end[group] @begin[group] CurrentBufferSize@\A per-buffer variable for text buffers, gives number of lines actually within buffer. @end[group] @begin[group] CurrentBufferText@\A per-buffer variable for text buffers. A vector of lines making up the buffer. @end[group] @begin[group] CurrentLine@\A per-buffer variable for text buffers. The contents (text) of current line--as a linked list of character codes. (Takes precedence over whatever is contained in the text vector.) @end[group] @begin[group] CurrentLineIndex@\A per-buffer variable for text buffers. Index of the "current line" within buffer. @end[group] @begin[group] CurrentVirtualScreen@\Per-view variable for text windows (views), holds the virtual screen used by the view. @end[group] @begin[group] CurrentWindowDelta@\Per-view variable for text windows, gives window dimensions as @w[(delta x . delta y)]. @end[group] @begin[group] CurrentWindowDescriptor@\The currently selected window environment. @end[group] @begin[group] declared_data_modes@\List of @w[(mode-name . buffer-creator)] pairs for all the declared modes. @end[group] @begin[group] declared_file_extensions@\List of @w[(file-extension . buffer-creator)] pairs for all modes with declared file extensions. @end[group] @begin[group] EmodeBufferChannel@\Channel used for EMODE I/O. Perhaps this should be expanded to allow different channels for different purposes (break loops, error messages, etc.) (Or, perhaps the whole model needs more thought! ) @end[group] @begin[group] FirstCall@\NIL means re-entering EMODE, T means first time. @end[group] @begin[group] FundamentalTextMode@\Mode list (list of expressions) for establishing "fundamental" text mode. @end[group] @begin[group] kill_buffer_ring@\Vector of vectors of strings--holds recently deleted text. @end[group] @begin[group] kill_opers@\list of (names of) handler routines that kill text. NEEDS MORE DOCUMENTATION! @end[group] @begin[group] kill_ring_index@\Pointer to the most recent "kill buffer". @end[group] @begin[group] last_buffername@\Name (a string) of the last buffer visited. @end[group] @begin[group] last_operation@\The "last" routine dispatched to (before the "current operation"). @end[group] @begin[group] last_search_string@\The last string searched for by a search command--used as default for next search command. @end[group] @begin[group] last_yank_point@\Vector of [buffer lineindex point], giving location where last "yank" occured. @end[group] @begin[group] LispDispatchList@\The "key list" for Lisp mode. @end[group] @begin[group] LispMode@\The mode list for Lisp mode. @end[group] @begin[group] MainDispatch@\Dispatch table (vector), an entry for each key. @end[group] @begin[group] minor_window_list@\List of windows to be ignored by the "next_window" routine. @end[group] @begin[group] ModeEstablishExpressions@\List of expressions to be evaluated. Each expression is expected to modify (add to?) the dispatch table. @end[group] @begin[group] OldErrOut@\The error output channel in effect before EMODE was started. @end[group] @begin[group] OldStdIn@\The standard input channel in effect before EMODE was started. @end[group] @begin[group] OldStdOut@\The standard output channel in effect before EMODE was started. @end[group] @begin[group] point@\A per-buffer variable for text buffers. Number of chars to the left of point within CurrentLine. @end[group] @begin[group] PrefixAssociationLists@\Additional dispatch information for prefixed characters. @end[group] @begin[group] PrefixCharacterList@\A list of the declared prefix characters. @end[group] @begin[group] pushed_back_characters@\A list of characters pushed back for EMODE's command reader. This may be used when a command isn't recognized by one dispatcher, so it can push the characters back and pass control to another dispatcher. @end[group] @begin[group] reading_from_output@\Kludge flag, T when input buffer is OUT_WINDOW buffer (for M-E). @end[group] @begin[group] RlispDispatchList@\The "key list" for RLISP mode. @end[group] @begin[group] RlispMode@\The mode list for RLISP mode. @end[group] @begin[group] runflag@\EMODE continues its READ/DISPATCH/REDISPLAY until this flag is NIL. @end[group] @begin[group] SelfInsertCharacter@\Character being dispatched upon. (Usually the last character typed.) @end[group] @begin[group] ShiftDisplayColumn@\Amount to shift things to the left by before (re)displaying lines in a text view. @end[group] @begin[group] TextDispatchList@\The "key list" for fundamental text mode. @end[group] @begin[group] Two_window_midpoint@\Gives location (roughly) of dividing line for two window mode. @end[group] @begin[group] WindowList@\List of active windows (views). @end[group] @begin[group] WindowsBufferName@\Required per-view variable giving the name of the buffer being viewed. @end[group] @begin[group] Windows_Refresher@\Required per-view variable giving the refresh algorithm to be APPLYed for this view. @end[group] @begin[group] Window_Image@\Per-view variable for text views, holding information for speeding up refresh. @end[group] @end[description] |
Added psl-1983/emode/emode.tags version [647f35f2b4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PS:<PSL.EMODE>EMODE-DISPHELP.RED.0 00090,RLISP lisp procedure DisplayHelpFile F;92 PS:<PSL.EMODE>EMODE-FILES-1.RED.0 00051,RLISP PS:<PSL.EMODE>EMODE-FILES-2.RED.0 00051,RLISP PS:<PSL.EMODE>EMODE1.RED.0 03536,RLISP Symbolic Procedure DBG1(x);2018 Symbolic Procedure DBG2(x);2086 Symbolic Procedure EMODE();2210 Symbolic Procedure EMODEinitialize();3929 Symbolic Procedure EMODEbreak();5000 Symbolic Procedure OldFACE();5557 Symbolic Procedure SelectEmodeChannels();5835 Symbolic Procedure OldEMODE();6349 Symbolic Procedure EMODE1(msg);7259 Symbolic Procedure EMODEdispatchLoop();7516 Symbolic Procedure FreshEMODE();7997 Symbolic Procedure EMODEerror(x);8138 Symbolic Procedure SetBufferText(i,text);9613 Symbolic Procedure GetBufferText(i);9741 Symbolic Procedure NextIndex(i);9930 Symbolic Procedure PreviousIndex(i);10009 Symbolic Procedure SetupInitialBufferStructure();10074 Symbolic Procedure SelectBuffer(BufferName);11746 Symbolic Procedure DeSelectBuffer(BufferName);13274 Symbolic Procedure CountLinesFrom(P1,P2);13704 Symbolic Procedure CountAllLines;13937 Symbolic Procedure CountLinesLeft;14074 Symbolic Procedure CountLinesBefore;14209 Symbolic Procedure InsertSelfCharacter();14526 Symbolic Procedure InsertCharacter(ch);14611 Symbolic Procedure transpose_characters();14830 Symbolic Procedure AppendLine(contents, PreviousLine);15520 Symbolic Procedure Insert_string(strng);16168 Procedure append_line(s);16960 Symbolic Procedure InsertLine(linetext);17105 Symbolic Procedure insert_kill_buffer();17453 Symbolic Procedure unkill_previous();18989 Symbolic Procedure InsertListEntry(oldlist,pos,val);19591 Symbolic Procedure DeleteCharacter();19953 Symbolic Procedure DeleteListEntry(oldlist,pos);20129 Symbolic Procedure CurrentCharacter();20369 Symbolic Procedure Head(x,n);20599 Symbolic Procedure PackLine(lst);20756 Symbolic Procedure UnpackLine(str);20866 Symbolic Procedure PutLine();21065 Symbolic Procedure GetLine(x);21231 Symbolic Procedure SelectLine(x);21387 Symbolic Procedure delete_or_copy(del_flg, line1,point1, line2, point2);21718 Symbolic Procedure DeleteTextEntry(x);25622 Symbolic Procedure leave_dispatch_loop();26296 Symbolic Procedure !$DeleteBuffer();26557 Symbolic Procedure !$BeginningOfBuffer();27062 Symbolic Procedure !$EndOfBuffer();27186 Symbolic Procedure SetMark();27308 Symbolic Procedure ExchangePointAndMark();27470 Symbolic Procedure EndOfBufferP(i);28010 Symbolic Procedure BeginningOfBufferP(i);28160 Symbolic Procedure !$CRLF();28408 Symbolic Procedure !$BeginningOfLine();28919 Symbolic Procedure !$EndOfLine();29007 Symbolic Procedure !$BackwardLine();29176 Symbolic Procedure !$ForwardLine();29449 Symbolic Procedure !$BackwardCharacter();29952 Symbolic Procedure !$ForwardCharacter();30352 Symbolic Procedure !$DeleteBackwardCharacter();30773 Symbolic Procedure !$DeleteForwardCharacter();31051 Symbolic Procedure rotate_kill_index(N);31712 Symbolic Procedure update_kill_buffer(killed_text);32256 Symbolic Procedure kill_region();34177 Symbolic Procedure copy_region();34403 Symbolic Procedure kill_line();34702 Symbolic Procedure kill_forward_word();35141 Symbolic Procedure kill_backward_word();35434 Symbolic Procedure kill_forward_sexpr();35728 Symbolic Procedure kill_backward_sexpr();36023 Symbolic Procedure Print1Dispatch(ch1, ch2, fname);36405 Symbolic Procedure PrintAllDispatch;36838 Symbolic Procedure GetInternalName(ch,DispatchTable);37319 Symbolic Procedure character_name(ch);37847 Symbolic Procedure !$HelpDispatch();38980 Symbolic Procedure OpenLine();40012 PS:<PSL.EMODE>MENU.RED.0 00211,RLISP Symbolic Procedure MakeMenu();99 Procedure KillMenu();955 Procedure ExitMenu();1042 procedure MenuReader();1159 Procedure NoPrint x;1235 procedure Menu;1259 PS:<PSL.EMODE>MOVE-STRINGS.RED.0 00200,RLISP syslsp procedure MoveSubstringToFrom(DestString, SourceString,620 syslsp procedure FillSubstring(DestString, DestIndex, SubrangeLength, chr);2127 PS:<PSL.UTIL>RAWIO.RED.0 00682,RLISP lisp procedure BITS1 U;780 macro procedure BITS U;902 lap '((!*entry PBIN expr 0)1145 lap '((!*entry PBOUT expr 1)1344 lap '((!*entry CharsInInputBuffer expr 0)1524 lap '((!*entry RFMOD expr 1)1970 lap '((!*entry RFCOC expr 1)2170 lap '((!*entry RTIW expr 1)2673 lisp procedure SaveInitialTerminalModes();2972 lap '((!*entry SFMOD expr 2)3205 lap '((!*entry STPAR expr 2)3473 lap '((!*entry SFCOC expr 3)3740 lap '((!*entry STIW expr 2)4131 lisp procedure EchoOff();4396 lisp procedure EchoOn();5436 Symbolic Procedure PBIN();6267 Symbolic Procedure PBOUT(chr);6435 Symbolic Procedure rawio_break();6633 PS:<PSL.EMODE>REFRESH.RED.0 02087,RLISP Symbolic Procedure Coords(col,rw);1324 Symbolic Procedure Column pos;1375 Symbolic Procedure Row pos;1452 Symbolic Procedure FrameScreen(scrn);1750 Symbolic Procedure FramedWindowDescriptor(BufferName, upperleft, dxdy);2639 Symbolic Procedure UnframedWindowDescriptor(BufferName, upperleft, dxdy);5185 Symbolic Procedure OneWindow();7347 Symbolic Procedure MajorWindowCount();10319 Symbolic Procedure next_window();10465 Symbolic Procedure previous_window_command();10959 Symbolic Procedure next_major_window(pntr, wlist);11525 Symbolic Procedure Buffer_VisibleP(BufferName);12026 Symbolic Procedure Setup_Windows(WindowDescriptorList);12342 Symbolic Procedure SelectWindow(WindowDescriptor);12792 Symbolic Procedure SelectWindowContext(WindowDescriptor);13017 Symbolic Procedure DeselectCurrentWindow();13756 Symbolic Procedure remove_current_view();14316 Symbolic Procedure cleanup_text_view();14661 Symbolic Procedure CntrlXCscroll();14829 Symbolic Procedure SetScreen;14991 Symbolic Procedure WriteScreenPhoto();15287 Symbolic Procedure Refresh();15656 Symbolic Procedure optional_refresh();16337 Symbolic Procedure refresh_unframed_window();16512 Symbolic Procedure refresh_unframed_label();16815 Symbolic Procedure refresh_framed_window();17764 Symbolic Procedure refresh_frame_label();18037 Symbolic Procedure refresh_text();21841 Symbolic Procedure Nils(n);22673 Symbolic Procedure Nlist(n,element);22775 Symbolic Procedure Zeroes(n);22899 Symbolic Procedure ClearToEndOfWindow(x);22961 Symbolic Procedure ClearEol(x);23470 Symbolic Procedure DisplaySpaces(pos, N);23651 Symbolic Procedure RefreshLine(lineindex,image_linenumber);24299 Symbolic Procedure DisplayCharacter(pos,chr);27399 Symbolic Procedure nxt_item(strm);28010 Symbolic Procedure create_stream(gvec);28801 Symbolic Procedure MatchLength(l1,l2);28921 Symbolic Procedure LineColumn(N,line);29298 Symbolic Procedure FullRefresh();29978 Symbolic Procedure AdjustTopOfDisplayIndex();30251 PS:<PSL.EMODE>RFACE.RED.0 00835,RLISP Symbolic Procedure OpenBufferChannel(Inbuffer, Outbuffer, Outwindow);2421 Symbolic Procedure CloseBufferChannel(chn);3012 Symbolic Procedure BufferPrintChar(Chn,ch);3533 Symbolic Procedure EnsureOutputVisible(outbuffername,oldbuffername);5600 Symbolic Procedure BufferReadChar(Chn);6268 Symbolic Procedure TwoRFACEWindows();8076 Symbolic Procedure insert_last_expression();12644 Symbolic Procedure ReturnFromEmodeEdit();13322 Symbolic Procedure quit();14814 Symbolic Procedure EmodeChannelEdit(chn, PromptStr);15255 Symbolic Procedure PromptAndEdit(PromptStr);16210 Symbolic Procedure PromptAndEditOnChannel(chn, PromptStr);16373 Symbolic Procedure MakeInputAvailable();16696 Symbolic Procedure SelectOldChannels();16964 Symbolic Procedure InsertComment();17888 PS:<PSL.EMODE>SEARCH.RED.0 00753,RLISP Symbolic Procedure forward_string_search();880 Symbolic Procedure reverse_string_search();1372 Symbolic Procedure buffer_search(strng,dir);1855 Symbolic Procedure subscript(pattern,strng,start,dir);3517 Symbolic Procedure RaiseChar(ch);4027 Symbolic Procedure is_substring(substrng,strng,start);4291 Symbolic Procedure adjust_depth(ch);4736 Symbolic Procedure skip_forward_blanks();4967 Symbolic Procedure skip_backward_blanks();5371 Symbolic Procedure forward_word();5973 Symbolic Procedure backward_word();6657 Symbolic Procedure LetterP(ch);7529 Symbolic Procedure forward_sexpr();7674 Symbolic Procedure backward_sexpr();8860 Symbolic Procedure insert_matching_paren();10123 PS:<PSL.EMODE>SETWINDOW.RED.0 00224,RLISP Procedure OneWindow();23 Symbolic Procedure TwoWindows();2472 procedure ResetEmode(rows,cols,f);5853 procedure resetrows(r);6287 procedure SetEmode(rows,cols,f);6359 PS:<PSL.EMODE>TEMPORARY-EMODE-FIXES.RED.0 00191,RLISP Symbolic Procedure counting_cons(x,y);529 Symbolic Procedure start_cons_count();739 Symbolic Procedure stop_cons_count();1095 PS:<PSL.EMODE>VS-DEMO.RED.0 00045,RLISP PS:<PSL.EMODE>WIN-DEMO.RED.0 00194,RLISP procedure BufferNames;22 procedure FindWindowName N;99 procedure FindWindowField(F,N);177 procedure SelectName N;363 procedure Break;1545 PS:<PSL.EMODE>AAA.SL.0 00154,PSL (DE EraseScreen ()996 (DE Ding ()1214 (DE TerminalClearEol ()1324 (DE SetTerminalCursor (ColLoc RowLoc)1507 PS:<PSL.EMODE>BUFFER.SL.0 00637,PSL (de char-blank? (ch)553 (de current-line-length () (length CurrentLine))652 (de current-line-empty () (= (length CurrentLine) 0))709 (de current-line-blank? ()739 (de at-buffer-end? ()837 (de at-buffer-start? ()930 (de current-line-is-last? ()1007 (de current-line-is-first? ()1090 (de current-line-fetch (n) (car (pnth CurrentLine (+ n 1))))1181 (de current-line-store (n c)1211 (de current-buffer-size ()1318 (de current-buffer-visible-size ()1618 (de current-buffer-goto (line-number char-number)2165 (de move-to-next-line ()2254 (de move-to-previous-line ()2485 PS:<PSL.EMODE>BUFFER-POSITION.SL.0 00293,PSL (de buffer-position-create (line-number column-number)506 (de buffer-position-line (bp)576 (de buffer-position-column (bp)624 (de buffer-position-compare (bp1 bp2)678 (de buffer-get-position ()1001 (de buffer-set-position (bp)1085 PS:<PSL.EMODE>BUFFERS.SL.0 00634,PSL (de declare_data_mode (name buffer-creator)987 (de CreateBuffer (BufferName buffer-creator)1528 (de select_or_create_buffer (buffer-name buffer-creator)2510 (de ChooseBuffer ()5171 (de create_text_view (buffer-name)5862 (de create_raw_text_buffer ()7557 (de create_text_buffer ()9021 (de create_rlisp_buffer ()9307 (de create_lisp_buffer ()9549 (de buffer-create (buffer-name buffer-creator)9687 (de buffer-make-unique-name (buffer-name)10110 (de buffer-exists (buffer-name)10480 (de buffer-kill (buffer-name)10549 (de select-buffer-if-existing (buffer-name)10985 PS:<PSL.EMODE>CUSTOMIZE-RLISP-FOR-EMODE.SL.0 00301,PSL (de listp (x)778 (de tail (lst n)874 (de read_from_string (string_for_read_from_string)1764 (de channel_read_from_string (chn)2803 (de PrintF_into_string3548 (de channel_write_into_string (chn chr)4246 (de DummyClose (chn)4891 PS:<PSL.EMODE>DIRECTORY.SL.0 00517,PSL (de find-matching-files (filename include-deleted-files)388 (de file-deleted-status (file-name)2241 (de file-delete (file-name)2607 (de file-undelete (file-name)2857 (de jfn-deleted? (jfn)3350 (de jfn-write-date (jfn)3459 (de jfn-read-date (jfn)3539 (de jfn-byte-count (jfn)3620 (de jfn-page-count (jfn)3701 (de file-date-to-string (fdate)3991 (de fixup-directory-name (name)4400 (de fixup-file-name (name)4789 (de trim-filename-to-prefix (s)5099 PS:<PSL.EMODE>DIRED.SL.0 01704,PSL (defmacro fi-full-name (fi) `(nth ,fi 1)) % string for file primitives759 (defmacro fi-deleted? (fi) `(nth ,fi 2)) % is file marked 'deleted'?832 (defmacro fi-size (fi) `(nth ,fi 3)) % "size" of file894 (defmacro fi-write-date (fi) `(nth ,fi 4)) % date/time file last written969 (defmacro fi-read-date (fi) `(nth ,fi 5)) % date/time file last read1041 (defmacro fi-nice-name (fi) `(nth ,fi 6)) % string to show user1108 (de dired-command ()2096 (de dired-fixup-file-list (file-list)2890 (de load-dired-buffer (file-list)3701 (de file-info-to-string (file-info)3928 (de dired-exit ()4544 (de dired-delete-file ()4989 (de dired-undelete ()5221 (de dired-reverse-undelete ()5452 (de dired-help ()5685 (de dired-next-hog ()5810 (de dired-automatic-delete ()5920 (de dired-edit-file ()6031 (de dired-reverse-sort ()6456 (de dired-sort ()7203 (de dired-srccom-file ()7901 (de dired-valid-line ()8194 (de dired-determine-actions (file-list)8355 (de dired-present-actions (action-list)9357 (de get-upchar ()10306 (de dired-present-list (list prompt)10478 (de dired-perform-actions (action-list)10790 (de dired-perform-sort (prompt sorter)11071 (de dired-filename-sorter (f1 f2)11246 (de dired-filename-reverser (f1 f2)11340 (de dired-size-sorter (f1 f2)11428 (de dired-size-reverser (f1 f2)11616 (de dired-write-sorter (f1 f2)11803 (de dired-write-reverser (f1 f2)12016 (de dired-read-sorter (f1 f2)12226 (de dired-read-reverser (f1 f2)12434 (de string-pad-right (s desired-length)12841 (de string-pad-left (s desired-length)13036 (de string-largest-common-prefix (s1 s2)13233 PS:<PSL.EMODE>DISPCH.SL.0 00839,PSL (DE define_prefix_character (chr prompt-string)2893 (DM CharSequence (chlist)3538 (DS MetaP (chr)4123 (DS MakeMeta (chr)4208 (DS UnMeta (chr)4328 (DE X-UpperCaseP (chr)4437 (DE X-Char-DownCase (chr)4562 (DE ClearDispatch ()4735 (DE SetKey (xchar op)5029 (DE MakeSelfInserting (chr)6844 (DE Undefine (chr)6956 (DE Dispatcher ()7099 (DE Dispatch (chr)7283 (DE do-prefix ()7531 (DE EscapeAsMeta ()8422 (DE DoControlMeta ()8611 (DE GetNextCommandCharacter ()9094 (DE push_back (chr)9443 (De EstablishCurrentMode ()9827 (de AddToKeyList (listname chr opr)13347 (de SetTextKey (chr opr)14073 (de SetLispKey (chr opr)14187 (de SetKeys (lis)14454 (de NormalSelfInserts ()14533 (de DefinePrefixChars ()16221 (de $iterate ()16837 (de char-digit (c)17962 PS:<PSL.EMODE>DM1520.SL.0 00154,PSL (DE EraseScreen ()699 (DE Ding ()772 (DE TerminalClearEol ()882 (DE SetTerminalCursor (ColLoc RowLoc)978 PS:<PSL.EMODE>EDC.SL.0 00258,PSL (DE InsertAndTotal ()370 (DE DeleteBackwardAndTotal ()465 (DE DeleteForwardAndTotal ()565 (DE kill_line_and_total ()662 (DE insert_kill_buffer_and_total ()753 (DE FindBufferTotal ()840 (DE SetDCmode ()2341 PS:<PSL.EMODE>ENVSEL.SL.0 00090,PSL (DE SaveEnv (env)557 (DE RestoreEnv (env)868 PS:<PSL.EMODE>FILEIO.SL.0 00787,PSL (de CopyFile (filename1 filename2)674 (de WriteLine (file-descriptor lin)1148 (de read_line_from_file (file-descriptor)1734 (de read_channel_into_text_buffer (file-descriptor)2354 (de write_text_buffer_to_channel (file-descriptor)2810 (de ReadFile (filename)3353 (de WriteFile (filename)3922 (de CntrlXread ()4511 (de CntrlXwrite ()4683 (de save_file ()4871 (de find_file ()5176 (de find_file_named (filename)5478 (de filename-buffername (filename)6326 (de declare_file_mode (file-extension buffer-creator)7621 (de files_data_mode (filename)8040 (de buffer-name-field (filename) % Dec20 version.8515 (de buffer-name-field (filename) % Unix version.9206 (de file-extension-field (filename)10162 PS:<PSL.EMODE>HP-EMODEX.SL.0 01459,PSL (de scroll-window-by-lines (n)1207 (de scroll-window-by-pages (n)2122 (de scroll-window-up-line-command ()3226 (de scroll-window-down-line-command ()3303 (de scroll-window-up-page-command ()3379 (de scroll-window-down-page-command ()3456 (de current-line-indent ()3716 (de current-line-strip-indent ()3962 (de strip-previous-blanks ()4213 (de indent-current-line (n)4408 (de delete-horizontal-space-command ()5139 (de delete-blank-lines-command ()5621 (de delete-following-blank-lines ()6159 (de back-to-indentation-command ()6953 (de delete-indentation-command ()7142 (de lisp-tab-command ()7949 (de lisp-linefeed-command ()8034 (de lisp-indent-sexpr ()8126 (de lisp-current-line-indent ()8618 (de transpose-characters-command ()9555 (de mark-word-command ()10321 (de mark-sexp-command ()10555 (de mark-whole-buffer-command ()10809 (de beginning-of-defun-command ()11243 (de beginning-of-defun ()11562 (de end-of-defun-command ()12232 (de forward-defun ()12704 (de end-of-defun ()13109 (de mark-defun-command ()13412 (de move-past-previous-list ()14027 (de backward-up-list ()14506 (de reverse-scan-for-left-paren (depth)14678 (de move-past-next-list ()15408 (de forward-up-list ()15874 (de forward-scan-for-right-paren (depth)16180 (de down-list ()16879 (de move-down-list ()17138 (de insert-parens ()17597 (de move-over-paren ()17783 PS:<PSL.EMODE>HP2648A.SL.0 00233,PSL (de EraseScreen ()1458 (de Ding ()1621 (de TerminalClearEol ()1674 (de SetTerminalCursor (ColLoc RowLoc)1821 (de terminal-enter-raw-mode ()3742 (de terminal-leave-raw-mode ()3915 PS:<PSL.EMODE>INPUT-STREAM.SL.0 00799,PSL (defun open-input (file-name)749 (defflavor input-stream ((jfn NIL) % TOPS-20 file number973 (defmethod (input-stream getc) ()1609 (defmethod (input-stream fill-buffer-and-getc) ()3283 (defmethod (input-stream getc-image) ()4006 (defmethod (input-stream fill-buffer-and-getc-image) ()4380 (defmethod (input-stream empty?) ()4691 (defmethod (input-stream peekc) ()4766 (defmethod (input-stream fill-buffer-and-peekc) ()5198 (defmethod (input-stream open) (name-of-file)5514 (defmethod (input-stream close) ()6377 (de test-buffered-input (name-of-file)6782 (de time-buffered-input (name-of-file)6982 (de time-buffered-input-1 (name-of-file)7187 (de time-standard-input (name-of-file)7380 (de time-input (name-of-file)7600 PS:<PSL.EMODE>MISC-EMODE.SL.0 00225,PSL (de execute_command ()422 (de InsertNextCharacter ()745 (de PrintBufferNames ()961 (de save-important-channels ()1397 (de restore-important-channels (saved-channels)1542 PS:<PSL.EMODE>NEW-FILEIO.SL.0 00259,PSL (de readfile (file-name)837 (de read-file-into-buffer (s)1088 (de append-file-to-buffer (s)1412 (de append-line-to-buffer (contents)2203 (de WriteFile (file-name)2587 (de write-buffer-to-stream (s)3138 PS:<PSL.EMODE>OUTPUT-STREAM.SL.0 00765,PSL (defun open-output (file-name)752 (defun open-append (file-name)867 (defflavor output-stream ((jfn NIL) % TOPS-20 file number1100 (defmethod (output-stream putc) (ch)1474 (defmethod (output-stream put-newline) ()2981 (defmethod (output-stream puts) (str)3314 (defmethod (output-stream putl) (str)3662 (defmethod (output-stream open) (name-of-file)3854 (defmethod (output-stream open-append) (name-of-file)4685 (defmethod (output-stream close) ()5505 (defmethod (output-stream flush) ()5668 (de time-buffered-output (n-lines)6125 (de time-buffered-output-1 (n-lines)6507 (de time-standard-output (n-lines)6879 (de time-output (n-lines)7208 (de time-buffered-output-string (n-lines)7423 PS:<PSL.EMODE>PROMPTING.SL.0 00305,PSL (de prompt_for_character (prompt_string)909 (de prompt_for_string (prompt_string default_string)2335 (de setup_insert_single_line_mode ()3822 (de show_prompt (prompt_string)6077 (de show_message (strng)6256 (de string_in_window (strng window)6794 PS:<PSL.EMODE>QUERY-REPLACE.SL.0 00208,PSL (de query-replace-command ()508 (de do-string-replacement (pattern replacement)2859 (de advance-over-string (pattern)3330 (de write-prompt (string)3699 PS:<PSL.EMODE>RING-BUFFER.SL.0 00200,PSL (de ring-buffer-create (number-of-elements)565 (de ring-buffer-push (rb new-element)798 (de ring-buffer-top (rb)1220 (de ring-buffer-pop (rb)1417 PS:<PSL.EMODE>SLEEP.SL.0 00180,PSL (de sleep-until-timeout-or-input (n-60ths) % Dec-20 version498 (de sleep-until-timeout-or-input (n-60ths) % Unix version913 PS:<PSL.EMODE>TELERAY.SL.0 00156,PSL (DE EraseScreen ()692 (DE Ding ()773 (DE TerminalClearEol ()883 (DE SetTerminalCursor (ColLoc RowLoc)1020 PS:<PSL.EMODE>TOY-MODE.SL.0 00274,PSL (de create_toy_buffer ()647 (de create_toy_view (buffer-name)1997 (de refresh_toy_window ()3815 (de backwards-WriteToScreen (Scrn chr rw col)4517 (de quietly_copyd (dest src)4653 (de quietly_putd (fname ftype body)4758 PS:<PSL.EMODE>TTY-SIZE.SL.0 00133,PSL (DM SubField (args)302 (DE TTyWord ()464 (DE PageLength ()609 (DE PageWidth ()663 PS:<PSL.EMODE>V-SCREEN.SL.0 01206,PSL (DefConst MaxMaskNumber 127)2332 (DS index_screen (Scrn rw col)2433 (DE LeftAssociativeExpand (args Fn)2814 (DE LeftAssociativeExpand1 (Fn ProcessedArgs args)3084 (DM indexn (U)3418 (DS WithinRangeP (x rnge)3756 (DE PutValueIntoRange (x rnge)3913 (DS VirtualScreenHeight (Scrn)5365 (DS VirtualScreenWidth (Scrn)5511 (DE CreateScreenImage (chr rws cols)6650 (DE WriteScreenImage (ScrnImage chn)7003 (DE InitializeScreenPackage ()7483 (DE CreateVirtualScreen (rws cols CornerRow CornerCol)9551 (de ClearVirtualScreen (scrn)10365 (DE WithinArrayP (ScrnArray rw col)10672 (DS WriteToNewScreenImage (chr absrow abscol)11187 (DE WriteToScreen (Scrn chr rw col)11515 (DE WriteToScreenRange (Scrn chr rw LeftCol RightCol)14355 (DE WriteRange (Scrn chr rw LeftCol RightCol)15847 (DE DrawActiveList ()16079 (DE SelectScreen (Scrn)16523 (DE DeSelectScreen (Scrn)18022 (DE DrawScreenOnTop (Scrn)20290 (DE RefreshPhysicalScreen (BreakoutAllowed)23449 (DE WritePhysicalCharacter (chr rw col)25779 (DE MoveToScreenLocation (Scrn rw col)26596 (DE MoveToPhysicalLocation (rw col)26877 (DE ClearPhysicalScreen ()27777 PS:<PSL.EMODE>VS-SUPPORT.SL.0 00126,PSL (de RewriteChangedCharacters (oldline newline RowLocation LeftCol RightCol)517 PS:<PSL.EMODE>VT100.SL.0 00155,PSL (DE EraseScreen ()688 (DE Ding ()918 (DE TerminalClearEol ()1028 (DE SetTerminalCursor (ColLoc RowLoc)1188 PS:<PSL.EMODE>VT52.SL.0 00153,PSL (DE EraseScreen ()733 (DE Ding ()806 (DE TerminalClearEol ()916 (DE SetTerminalCursor (ColLoc RowLoc)1053 PS:<PSL.EMODE>WINDOW.SL.0 00163,PSL (de current-window-height ()545 (de current-window-top-line ()672 (de current-window-set-top-line (new-top-line)823 PS:<PSL.EMODE>WINDOWS.SL.0 00073,PSL (de window-kill-buffer ()611 |
Added psl-1983/emode/emode1.red version [f56eb62d7f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EMODE1.RED - Screen editor for PSL % % Authors: W. Galway, M. Griss, R. Armantrout % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % This file is the main body of code for the screen oriented editor % EMODE. This editor is patterned after EMACS from MIT and also after EM % written by Robert Armantrout for use on small Unix systems. FLUID '( Two_window_midpoint % Gives location (roughly) of dividing line for two % window mode. FirstCall % NIL means re-entering EMODE, T means first time. kill_opers % list of (names of) dispatch routines that kill % text. NEEDS MORE DOCUMENTATION! kill_buffer_ring % Vector of vectors of strings--holds recently % deleted text. kill_ring_index % Pointer to the most recent "kill buffer". last_yank_point % Vector of [buffer lineindex point], giving location % where last "yank" occured. last_operation % The "last" routine dispatched to (before the % "current operation"). runflag % EMODE continues READ/DISPATCH/REDISPLAY until NIL SelfInsertCharacter % The last character typed (dispatched on?) last_buffername % Name (a string) of the last buffer visited. !*DBG % T for debugging (not really implemented). ); FirstCall := 'T; % To force init of all structures last_buffername := "MAIN"; % Set up default, NEEDS more thought? !*DBG := NIL; % No debug % 8 entries in the kill ring. kill_buffer_ring := MkVect(7); kill_ring_index := 0; kill_opers := '( kill_line kill_region kill_forward_word kill_backward_word kill_forward_sexpr kill_backward_sexpr ); Symbolic Procedure DBG1(x); If !*DBG then Print LIST("-> ",x); Symbolic Procedure DBG2(x); If !*DBG then Print LIST("<- ",x); FLUID '(UserSetupRoutine); UserSetupRoutine := NIL; Symbolic Procedure EMODE(); % Rebind channels to use "EMODE buffers", then return. Use function % "OldFACE" to switch back to original channels. (OldFace is typically % bound to M-C-Z.) begin scalar chnl; if FirstCall then << FirstCall := NIL; % Why doesn't ALL this code go into EMODEinitialize? Sigh. EMODEinitialize(); % Any ideas where best to place the following call? % ANSWER is, GET RID OF IT, it's not a proper method to allow % customizations, since multiple users can't use it. % Current practice is for UserSetupRoutine to be a fluid--set to name % of procedure to execute inside user's initialization routine, NIL % outside of that scope. if not null UserSetupRoutine then Apply(UserSetupRoutine,NIL); % Open up special channel for buffer I/O. Arguments are % expressions to be evaluated to get name of input buffer, name of % output buffer, and a window to "pop up" for the output buffer. EmodeBufferChannel := OpenBufferChannel('CurrentBufferName, ''OUT_WINDOW, NIL ); >>; EchoOff(); !*EMODE := T; % HERE??? Set FLUID flag to show "EMODE running". % ErrorSet could be used to make sure echos get turned back on. % Use system's idea of backtrace ERRORSET('(FullRefresh), T, !*BACKTRACE); % (Need to do something if an error!) SelectEmodeChannels(); end; % Save old channels at load (compile) time? OldStdIn := STDIN!*; OldStdOut := STDOUT!*; OldErrOut := ErrOut!*; Symbolic Procedure EMODEinitialize(); % Sets up data structures for starting up EMODE. DOESN'T affect terminal % mode. begin SetScreen(); % Initialise Screen Space SetupInitialBufferStructure(); % A kludge (!?) to implement a pop-up break window. % Create the window to look into the "break" buffer. BreakWindow := FramedWindowDescriptor('BREAK, % Starts at column 39, Near top of screen Coords(39,1), % Dimensions are roughly 40 wide by 10 high. Coords(39,9)); % Very carefully (?) redefine the break handler. if FUnBoundP('pre_emode_break) then % Work with !*usermode OFF, so no objection is made as we redefine % Break. Also !*REDEFMSG OFF so that it happens "quietly". begin scalar !*USERMODE, !*REDEFMSG; CopyD('pre_emode_break,'Break); CopyD('Break, 'EMODEbreak); end; OneWindow(); % Initialize in one-window mode. end; Symbolic Procedure EMODEbreak(); % Redefined break handler for EMODE. Begin Scalar Oldwindow; Oldwindow:=CurrentWindowdescriptor; SelectWindow BreakWindow; !$BeginningOfBuffer(); % Place point at start of buffer. % Transfer control to the original break handler. Catch may be % overkill, but is more certain to catch errors and stuff. Catch(NIL, pre_emode_break() ); % When finished, "clean" our screen off. remove_current_view(); SelectWindow Oldwindow; % Back to the window we originally had. end; Symbolic Procedure OldFACE(); % Causes sytem to quit using "Rlisp Interface" mode, go back to "normal mode". << SelectOldChannels(); EchoOn(); !*EMODE := NIL; % HERE??? leave_dispatch_loop(); % Set flag to cause EMODE to exit. >>; Symbolic Procedure SelectEmodeChannels(); % Select channels that read from and write to EMODE buffers. << % Most channels just default to these? ErrOut!* is an exception, so % fix it. STDIN!* := EmodeBufferChannel; STDOUT!* := EmodeBufferChannel; ErrOut!* := EmodeBufferChannel; RDS STDIN!*; % Select the channels, "EMODE1" is called when read % routines invoke the "editor routine" for the newly % selected channels. WRS STDOUT!*; >>; Symbolic Procedure OldEMODE(); % "Old fashioned" version of invoking EMODE. "New" version invokes "Rlisp % interface" instead. This version is being kept for documentation--it's % basically obsolete. << If FirstCall then << EMODEinitialize(); FirstCall := NIL; >>; % Any ideas where best to place the following call? % Current practice is for UserSetupRoutine to be a fluid--set to name % of procedure to execute inside user's initialization routine, NIL % outside of that scope. if not null UserSetupRoutine then Apply(UserSetupRoutine,NIL); % A bit of a kludge to make sure echos get turned back on. ECHOoff(); % Do full refresh on restart, clean up junk on screen. ERRORSET('(FullRefresh), T, !*BACKTRACE); ERRORSET('(EMODE1 ""),T,!*BACKTRACE); % Use system's idea of backtrace ECHOon(); >>; Symbolic Procedure EMODE1(msg); % "msg" is an initial message to put into the "message window". begin show_message(msg); EMODEdispatchLoop(); % Execute read/dispatch/refresh loop until % "done" end; Symbolic Procedure EMODEdispatchLoop(); % Execute read/dispatch/refresh loop while fluid "runflag" is true. begin scalar runflag; runflag := T; while runflag do << % Note that it's actually a refresh/read/dispatch loop. optional_refresh(); % READ and then dispatch on character ERRORSET('(DISPATCHER),T,T); % Refresh screen (if no user input is pending). >>; PutLine(); % Make sure everything's put away! end; Symbolic Procedure FreshEMODE(); % Force Full Init << FirstCall := T; EMODE() >>; %. --------------- EMODE error handles Symbolic Procedure EMODEerror(x); Error(666," *** EMODE *** " . x); %. ---------- Buffer Management ---------- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % FLUID '( BufferNames % Buffer names are kept on the fluid association % list "BufferNames", associated with a list of % variable bindings (an "environment") for that % buffer. % Buffers are described by the following "per buffer" variables. (The % bindings of the variables depend on the current "buffer" environment.) CurrentBufferText % Vector of lines making up the buffer. % (CurrentLine is magic, see below.) CurrentBufferSize % Number of lines actually within buffer CurrentLine % The contents (text) of current line--as a linked % list of character codes. (Takes precedence over % whatever is contained in the text vector.) CurrentLineIndex % Index of "current line" within buffer. point % Number of chars to the left of point within % CurrentLine. ); % % Associated with a Buffer should be: % Its MODE (or is this WINDOW attribute?) % names of referencing windows (if any)? % Associated File (or is this WINDOW attribute?) %.------------- Basic Buffer Structure ---------------- Symbolic Procedure SetBufferText(i,text); % Store text into buffer at i. (Text is a string.) CurrentBufferText[i] := text; Symbolic Procedure GetBufferText(i); % Return the text stored in buffer at i. CurrentBufferText[i]; % Perhaps this is carrying "modularity" a bit too far? [But, I think not. % WFG] Symbolic Procedure NextIndex(i); % Put in bounds checking? i + 1; Symbolic Procedure PreviousIndex(i); i - 1; Symbolic Procedure SetupInitialBufferStructure(); % Creates initial buffers for EMODE. Should be done at loadtime? << BufferNames := NIL; % Association list of (Name . BufferDescriptor) CurrentBufferName := NIL; % Second argument does the actual work of creating the buffer. CreateBuffer('MAIN, 'create_rlisp_buffer); CreateBuffer('OUT_WINDOW, 'create_rlisp_buffer); % Not clear what the appropriate mode is, sure to change depending on % what's prompted for. CreateBuffer('PROMPT_BUFFER, 'create_rlisp_buffer); % Perhaps a "null" mode makes more sense here, but it's dangerous, % since if person edits this buffer, there's no character defined to % get out. Needs more thought (as usual)! CreateBuffer('MESSAGE_BUFFER, 'create_rlisp_buffer); % Create the BREAK (input) buffer. (I anticipate a break output % buffer one of these days.) CreateBuffer('BREAK, 'create_rlisp_buffer); % Set up the buffer text. SelectBuffer 'BREAK; % Include semicolons in the text so that both the Lisp and Rlisp % readers can handle the break buffer. Insert_string("A ;% To abort"); !$CRLF(); Insert_string("Q ;% To quit"); !$CRLF(); Insert_string("T ;% To traceback"); !$CRLF(); Insert_string("I ;% Trace interpreted stuff"); !$CRLF(); Insert_string("R ;% Retry"); !$CRLF(); Insert_string("C ;% Continue, using last value"); !$CRLF(); Insert_string("? ;% For more help"); !$CRLF(); % Start by editing in the MAIN buffer. SelectBuffer('MAIN); EstablishCurrentMode(); >>; Symbolic Procedure SelectBuffer(BufferName); % Select a buffer. (Restore its environment after saving old.) % (Some confusing subtle points have to be resolved, concerning selecting a % buffer "BufferName", where "BufferName" equals "CurrentBufferName". Current % "solution" is a kludge?) % As an example of the sort of thing that can happen--it would seem % unnecesary to restore the environment if we are selecting the % CurrentBufferName. BUT, that's not the case in the current % implementation, since (for example) the REFRESH algorithm will select a % window--which restores the "CurrentBufferName", and after selecting % window, it continues to call select the buffer. (Attempted cure for this % is to store the CurrentBufferName under some other ID in the window % environment. Ultimate cure for this is to refer to buffers, and windows, % by their values (environment association lists or whatever), rather than % by some name.) begin scalar BufferEnv; If BufferName neq CurrentBufferName then << if (BufferEnv := atsoc(BufferName,BufferNames)) then % (The environment part of (name . env) pair.) BufferEnv := cdr BufferEnv else return EMODEError list("Buffer ", BufferName, " can't be selected"); if CurrentBufferName then DeSelectBuffer CurrentBufferName; RestoreEnv BufferEnv; % Restore environment for buffer CurrentBufferName := BufferName; >>; end; Symbolic Procedure DeSelectBuffer(BufferName); begin scalar BufferEnv; if null (BufferEnv := assoc(BufferName,BufferNames)) then Return Prin2t LIST("Buffer doesn't exist to deselect:",BufferName); SaveEnv(cdr BufferEnv); % Save current buffer bindings (uses RPLACD) CurrentBufferName := NIL; end; %. ------------ Line and Char Counting ---------------- % Count lines from P1 to P2 (0 if P1 = P2). Symbolic Procedure CountLinesFrom(P1,P2); P2 - P1; % This was harder when a linked list was % used (in the past) to represent buffers. % Returns number of lines in current buffer. Symbolic Procedure CountAllLines; CurrentBufferSize; % Returns number of lines from current line (inclusive) to end of buffer. Symbolic Procedure CountLinesLeft; CurrentBufferSize - CurrentLineIndex; % Returns number of lines before the current line. Symbolic Procedure CountLinesBefore; CurrentLineIndex; % zero origin indexing % -----------CHARACTER Lines (line contents)--------- % Some lines are currently represented as a linked list of ASCII characters . % Insert SelfInsertCharacter into the current line, update point. Symbolic Procedure InsertSelfCharacter(); InsertCharacter SelfInsertCharacter; Symbolic Procedure InsertCharacter(ch); << if ch = char EOL then !$CRLF() else << CurrentLine := InsertListEntry(CurrentLine,Point,ch); Point := Point + 1; >>; >>; Symbolic Procedure transpose_characters(); % Transpose the last two characters, if we're at the end of the line, or if % a character was just inserted. Otherwise, transpose the characters on % either side of point. begin scalar ch1, ch2; if point = length CurrentLine OR last_operation eq 'InsertSelfCharacter then !$BackwardCharacter(); % Gripe if not enough to the left. (??) if point < 1 then return Ding(); ch2 := CurrentCharacter(); !$BackwardCharacter(); ch1 := CurrentCharacter(); DeleteCharacter(); DeleteCharacter(); InsertCharacter(ch2); InsertCharacter(ch1); end; Symbolic Procedure AppendLine(contents, PreviousLine); % Append line with "contents" just past "PreviousLine" begin integer putindx; CurrentBufferSize := CurrentBufferSize + 1; % Grow the buffer if necessary. if CurrentBufferSize > size(CurrentBufferText) then CurrentBufferText := concat(CurrentBufferText, MkVect(63)); putindx := CurrentBufferSize - 1; % Shuffle from the back while putindx > PreviousLine + 1 do << SetBufferText(putindx, GetBufferText(putindx - 1)); putindx := putindx - 1; >>; % Put new line just past "PreviousLine". SetBufferText(putindx, contents); end; Symbolic Procedure Insert_string(strng); % Insert a string into the buffer, starting at point, update point to be % just past string. begin scalar newline; PutLine(); % Pack the current line in (as a string) newline := GetBufferText(CurrentLineIndex); % Grab it back. newline := nary!-concat( sub(newline,0,point-1), % head of old string strng, % new string % and tail of old string. sub(newline, point, size(newline) - point) ); % Update point point := point + size(strng) + 1; % Put away the new line SetBufferText(CurrentLineIndex, newline); GetLine(CurrentLineIndex); % Get it back (I know, wierd!) end; Procedure append_line(s); % Append string as a new line in the current buffer. << !$CRLF(); insert_string(s); >>; Symbolic Procedure InsertLine(linetext); % Insert line before current line, then position past newly inserted line. % (An efficiency crock?) % "linetext" is a linked list of character codes (for now). << !$BeginningOfLine(); !$CRLF(); !$BackwardLine(); CurrentLine := linetext; PutLine(); !$ForwardLine(); >>; Symbolic Procedure insert_kill_buffer(); % Insert the "kill_buffer" into the current location (i.e. "yank"). Record % location of "point" after the yank, so that unkill_previous can avoid % doing stuff if not at the last yank point. % (This code isn't very efficient, it's an order(M*N) algorithm, when it % should really be order(N)--should be reworked.) begin scalar kill_buffer; % Avoid doing anything if kill_buffer not set up. kill_buffer := kill_buffer_ring[kill_ring_index]; if kill_buffer then << SetMark(); PutLine(); Insert_string(kill_buffer[0]); if size(kill_buffer) > 0 then << GetLine(CurrentLineIndex); !$CRLF(); !$BackwardLine(); for i := 1 : size(kill_buffer) - 1 do << AppendLine(kill_buffer[i], CurrentLineIndex); CurrentLineIndex := NextIndex(CurrentLineIndex); >>; CurrentLineIndex := NextIndex(CurrentLineIndex); GetLine(CurrentLineIndex); % KLUDGE! point := 0; % More kludge Insert_string(kill_buffer[size(kill_buffer)]); >>; GetLine(CurrentLineIndex); >>; % Note precise location of this yank, create the pointer if NIL. if null last_yank_point then last_yank_point := MkVect(2); last_yank_point[0] := CurrentBufferName; last_yank_point[1] := CurrentLineIndex; last_yank_point[2] := point; end; Symbolic Procedure unkill_previous(); % Delete (without saving away) the current region, and then unkill (yank) % the "previous" entry in the kill ring. "Ding" if not at location of last % yank. if null last_yank_point OR not(CurrentBufferName eq last_yank_point[0]) OR not(CurrentLineIndex equal last_yank_point[1]) OR not(point equal last_yank_point[2]) then Ding() else << Delete_or_copy(T, CurrentLineIndex, point, MarkLineIndex, MarkPoint); rotate_kill_index(-1); insert_kill_buffer(); >>; Symbolic Procedure InsertListEntry(oldlist,pos,val); % Insert val into oldlist at position pos (or at end of list if pos too big) if null oldlist then list(val) else if pos = 0 then cons( val , oldlist ) else cons( car oldlist , InsertListEntry( cdr oldlist , pos-1 , val )); % Delete character at point in current line Symbolic Procedure DeleteCharacter(); CurrentLine := DeleteListEntry(CurrentLine,Point); % Delete list entry at pos (or do nothing if pos past end of list) Symbolic Procedure DeleteListEntry(oldlist,pos); if null oldlist then NIL else if pos = 0 then cdr oldlist else cons(car oldlist, DeleteListEntry(cdr oldlist , pos-1 )); % Return character at point in current line. Symbolic Procedure CurrentCharacter(); begin scalar linetail; linetail := Tail(CurrentLine,point); return if null linetail then char EOL else car linetail; end; % Return first n entries at head of x. Symbolic Procedure Head(x,n); if null x then NIL else if n = 0 then NIL else cons(car x , Head(cdr x,n-1)); Symbolic Procedure PackLine(lst); % Pack a list of character codes into a string. List2String lst; Symbolic Procedure UnpackLine(str); % Unpack a string, or NIL, into a list of character codes. if null str then NIL % SPECIAL CASE else String2List str; Symbolic Procedure PutLine(); % Put away the magical current line (may want to check for necessity?) SetBufferText(CurrentLineIndex, PackLine CurrentLine); Symbolic Procedure GetLine(x); % "UNPACK" line pointed to by x << CurrentLine := UnpackLine GetBufferText(x); CurrentLineIndex := x; >>; Symbolic Procedure SelectLine(x); % Select a new current line at location x. if (x neq CurrentLineIndex) then % If a non-trivial operation << PutLine(); % Put away the old line GetLine(x); % and fetch the new one. >>; Symbolic Procedure delete_or_copy(del_flg, line1,point1, line2, point2); % Delete (if del_flg is non-NIL) or copy (otherwise) the text between % line1, point1 (column) through line2, point2, inclusive. Return the % deleted (or copied) text as a pair of ((direction_of_deletion) . % (vector_of_strings)). The "direction" is +1 if (line1, point1) <= % (line2, point2), and -1 otherwise. Update (CurrentLineIndex, point) if % it lies within the deleted region. begin scalar deleted_text,dir , text_length, indx, tmp, tmp2; PutLine(); dir := 1; % Default % Make sure that (line1, point1) comes first. if line2 < line1 then << dir := -1; tmp := line2; line2 := line1; line1 := tmp; tmp := point2; point2 := point1; point1 := tmp; >> else if (line1 = line2) and (point2 < point1) then << dir := -1; tmp := point2; point2 := point1; point1 := tmp; >>; % Update (CurrentLineIndex, point), if it lies in deleted region. if del_flg and ((line1 < CurrentLineIndex) or ((line1 = CurrentLineIndex) and (point1 < point))) and ((CurrentLineIndex < line2) or ((CurrentLineIndex = line2) and (point <= point2))) then << CurrentLineIndex := line1; point := point1; >>; % Similarly for "mark". (A kludge, this should at least be a macro.) if del_flg and ((line1 < MarkLineIndex) or ((line1 = MarkLineIndex) and (point1 < MarkPoint))) and ((MarkLineIndex < line2) or ((MarkLineIndex = line2) and (MarkPoint <= point2))) then << MarkLineIndex := line1; MarkPoint := point1; >>; % Get length of deleted text, in lines, suitable for 0 indexing (i.e. 0 % is "length" for one line of text). text_length := line2 - line1; deleted_text := MkVect(text_length); tmp := GetBufferText(line1); % Grab first line of region to delete. % Things are simple if deletion all on the same line. if text_length = 0 then << if del_flg then SetBufferText(line1, concat(sub(tmp, 0, point1-1), sub(tmp, point2, size(tmp) - point2))); % Refetch "current line". GetLine(CurrentLineIndex); deleted_text[0] := sub(tmp, point1, point2-point1-1); return dir . deleted_text; >>; % deleted_text[0] gets everything on line1 to the right of point1, and % the new line gets everything to the left (with more to be tacked on % later). deleted_text[0] := sub(tmp, point1, size(tmp) - point1); % Store away the deleted part of the last line of the region. tmp2 := GetBufferText(line2); deleted_text[text_length] := sub(tmp2, 0, point2-1); % and tack the tail onto the head of undeleted line1. if del_flg then SetBufferText(line1, concat(sub(tmp, 0, point1 - 1), sub(tmp2, point2, size(tmp2)-point2))); % Copy rest of text into deleted_text. for i := line1+1 : line2-1 do deleted_text[i-line1] := GetBufferText(i); % Shuffle all the text, deleting the lines between line1 and line2. if del_flg then << indx := 1; while not EndOfBufferP(line2+indx) do << SetBufferText(line1+indx, GetBufferText(line2 + indx)); indx := indx + 1; >>; % Note size change (but don't bother to decrease the actual size of the % vector holding the text, for now). CurrentBufferSize := CurrentBufferSize - (line2 - line1); >>; % Refetch "current line". GetLine(CurrentLineIndex); return dir . deleted_text; end; Symbolic Procedure DeleteTextEntry(x); % Delete the line at x (delete entry from vector of lines). % Depends on CurrentLine being "put away". << if not EndOfBufferP(x) then << x := x+1; % Shuffle the elements down one entry. while not EndOfBufferP(x) do << SetBufferText(x-1, GetBufferText(x)); x := x+1; >>; CurrentBufferSize := CurrentBufferSize - 1; % Note size change % (But don't bother to decrease actual size of line vector.) >>; GetLine(CurrentLineIndex); >>; %. ------------- Basic Dispatch Callable Control Procedures Symbolic Procedure leave_dispatch_loop(); % Set flag to cause exit from read/dispatch/refresh loop. << PutLine(); % Make sure current line "put away". runflag := NIL; % (Set flag to be detected by "main loop".) >>; Symbolic Procedure !$DeleteBuffer(); % Delete entire contents of buffer (similar to creating new buffer) << % Initial vector allows only one line. (Should really be parameterized.) CurrentBufferText := MkVect(1); CurrentBufferSize := 1; % Start with one line of text (but % zero characters in the line!) CurrentLine := NIL; CurrentLineIndex := 0; point := 0; >>; % Move to beginning of buffer Symbolic Procedure !$BeginningOfBuffer(); << SelectLine(0); point := 0; >>; % Move to end of buffer Symbolic Procedure !$EndOfBuffer(); << SelectLine(CurrentBufferSize - 1); point := length(CurrentLine); >>; Symbolic Procedure SetMark(); % Set "mark" pointer from "point". << MarkLineIndex := CurrentLineIndex; MarkPoint := point; >>; Symbolic Procedure ExchangePointAndMark(); begin scalar tmp; tmp := point; point := MarkPoint; MarkPoint := tmp; tmp := CurrentLineIndex; % NOTE, it doesn't work to just set % CurrentLineIndex := MarkLineIndex. SelectLine(MarkLineIndex); MarkLineIndex := tmp; end; % NOTE, there is a vague asymmetry about EndOfBufferP and % BeginningOfBufferP. These folks need more thought to avoid off by one % errors. (Should work in terms of characters, not lines?) Symbolic Procedure EndOfBufferP(i); % Return T if i is at end of buffer (past the last line in the buffer). i >= CurrentBufferSize; Symbolic Procedure BeginningOfBufferP(i); % Return T if i at beginning (first line) of buffer. i <= 0; % Use <= for robustness % Insert a CRLF at point (new line character (or end of line character % if you prefer)) Symbolic Procedure !$CRLF(); << % Store away the head of the current line (at the current line) SetBufferText(CurrentLineIndex , PackLine Head(CurrentLine,Point) ); % Append the tail end of the line just past the current line, and point % to it. CurrentLine := Tail(CurrentLine,Point); AppendLine(PackLine CurrentLine , CurrentLineIndex); CurrentLineIndex := NextIndex(CurrentLineIndex); Point := 0; >>; % Move to beginning of current line Symbolic Procedure !$BeginningOfLine(); Point := 0; % Move to end of current line Symbolic Procedure !$EndOfLine(); Point := length(CurrentLine); % Move up a line (attempting to stay in same column), dont move past; % start of buffer:= Symbolic Procedure !$BackwardLine(); if BeginningOfBufferP(CurrentLineIndex) then Ding() else << SelectLine(PreviousIndex(CurrentLineIndex)); if Point > Length CurrentLine then Point := Length(CurrentLine) >>; Symbolic Procedure !$ForwardLine(); % Move down a line (attempting to stay in same column), don't move past % end of buffer. if EndOfBufferP(NextIndex CurrentLineIndex) then Ding() else << SelectLine(NextIndex CurrentLineIndex); % DO WE REALLY want to change point? WFG If point > Length(CurrentLine) then point := Length CurrentLine >>; % Move back a character, to previous line if at start of current line. Symbolic Procedure !$BackwardCharacter(); if point = 0 then if BeginningOfBufferP(CurrentLineIndex) then Ding() else << SelectLine(PreviousIndex(CurrentLineIndex)); point := Length(CurrentLine); >> else point := point - 1; % Move forward a character, to Next line if at end of current line. Symbolic Procedure !$ForwardCharacter(); % NOTE use of "length" function, assumption of list for CurrentLine. if point = length(Currentline) then if EndOfBufferP(NextIndex CurrentLineIndex) then Ding() else << SelectLine(NextIndex(CurrentLineIndex)); Point := 0; >> else point := point+1; % Delete character before point. Symbolic Procedure !$DeleteBackwardCharacter(); << if point = 0 and BeginningOfBufferP(CurrentLineIndex) then Ding() else << !$BackwardCharacter(); !$DeleteForwardCharacter(); >>; >>; % Delete character after point Symbolic Procedure !$DeleteForwardCharacter(); if point = length(Currentline) then if EndOfBufferP(CurrentLineIndex) or % Complain if at (or near) EndOfBufferP(NextIndex CurrentLineIndex) % end of buffer. then Ding() else << % non-destructively append Next line to this line CurrentLine := Append(CurrentLine, UnpackLine GetBufferText(NextIndex(CurrentLineIndex))); PutLine(); DeleteTextEntry NextIndex CurrentLineIndex; >> else DeleteCharacter(); Symbolic Procedure rotate_kill_index(N); % Step the kill_ring_index by N, modulo the ring size. begin scalar ring_size; kill_ring_index := kill_ring_index + N; % Now do "cheap and dirty" modulus function. % Get number of entries in ring, compensate for 0 indexing. ring_size := size(kill_buffer_ring) +1; while kill_ring_index >= ring_size do kill_ring_index := kill_ring_index - ring_size; while kill_ring_index < 0 do kill_ring_index := kill_ring_index + ring_size; end; Symbolic Procedure update_kill_buffer(killed_text); % Update the "kill buffer", either appending/prepending to the current % buffer, or "pushing" the kill ring, as appropriate. killed_text is a % pair, the car of which is +1 if the text was "forward killed", and -1 if % "backwards killed". The cdr is the actual text (a vector of strings). begin scalar new_entry, tmp, tmp1, tmp2; % If last operation wasn't a kill, then "push" the new text. if not (last_operation memq kill_opers) then << rotate_kill_index(1); % Move to a new kill buffer. kill_buffer_ring[kill_ring_index] := cdr killed_text; >> else % Otherwise, append or prepend the text, as appropriate. << tmp1 := kill_buffer_ring[kill_ring_index]; % The old text. tmp2 := cdr killed_text; % The new text to tack on. % Swap the two pieces of text if deletion was "backwards". if car killed_text < 0 then << tmp := tmp1; tmp1 := tmp2; tmp2 := tmp; >>; % Allocate space for the new "kill buffer". (A bit tricky due to 0 % indexing and fact that the last line of tmp1 is concatenated with % first line of tmp2.) new_entry := MkVect(size(tmp1) + size(tmp2)); tmp := 0; % Now tmp serves as index into the new buffer. for i := 0 : size(tmp1) - 1 do << new_entry[tmp] := tmp1[i]; tmp := tmp + 1; >>; % Concatenate last line of tmp1 with first line of tmp2. new_entry[tmp] := concat(tmp1[size tmp1], tmp2[0]); tmp := tmp + 1; % Tack on the rest of tmp2. for i := 1 : size(tmp2) do << new_entry[tmp] := tmp2[i]; tmp := tmp + 1; >>; kill_buffer_ring[kill_ring_index] := new_entry; >>; end; Symbolic Procedure kill_region(); % Kill (and save in kill buffer) the region between point and mark. << update_kill_buffer delete_or_copy(T, CurrentLineIndex, point, MarkLineIndex, MarkPoint); >>; Symbolic Procedure copy_region(); % (Should this be counted as a "kill_oper"? How about previous kills?) << update_kill_buffer delete_or_copy(NIL, CurrentLineIndex, point, MarkLineIndex, MarkPoint); >>; % Kill current line from point onwards, or delete "CRLF" if at end of line. Symbolic Procedure kill_line(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. if point = length(CurrentLine) then % Delete CRLF at end of line. !$ForwardCharacter() % (Skip over CRLF.) else !$EndOfLine(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_forward_word(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. forward_word(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_backward_word(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. backward_word(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_forward_sexpr(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. forward_sexpr(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; Symbolic Procedure kill_backward_sexpr(); begin scalar cline, cpoint; cline := CurrentLineIndex; cpoint := point; % Move over region to kill, then kill it. backward_sexpr(); update_kill_buffer delete_or_copy(T, cline, cpoint, CurrentLineIndex, point); end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Symbolic Procedure Print1Dispatch(ch1, ch2, fname); % Print out the dispatch routine for a (possibly "extended") character. % (Second "character" is NIL for unextended characters.) % Don't print anything if it's a self inserting character, or "undefined". << if not(fname memq '(InsertSelfCharacter Ding)) then PrintF("%w %w %w%n", character_name ch1, character_name ch2, fname); >>; Symbolic Procedure PrintAllDispatch; % Print out the current dispatch table. % Need a "mode" that dumps stuff in a form appropriate for SCRIBE? << % First, list the routines bound to single characters. for ch := 0:255 do Print1Dispatch(ch, NIL, getv(MainDispatch, ch)); % next, list all the C-X bindings for each x in cdr atsoc(char cntrl X, PrefixAssociationLists) do Print1Dispatch(char cntrl X, car x, cdr x); >>; Symbolic Procedure GetInternalName(ch,DispatchTable); if pairp DispatchTable then if(ch := atsoc(ch,DispatchTable)) then cdr ch else 'Ding else getv(DispatchTable,ch); fluid '(character_name_table); % An association list of (character code . name), used by procedure % character_name. character_name_table := '( (8#7 . "Bell") (8#10 . "Backspace") (8#11 . "Tab") (8#12 . "Linefeed") (8#15 . "Return") (8#33 . "Escape") (8#40 . "Blank") (8#177 . "Rubout") ); Symbolic Procedure character_name(ch); % Return a string giving the name for a character code, return "" if "ch" % not a number. Names for control characters are typically "C-...", names % for meta characters are "M-...". Printing characters name themselves. begin scalar name; % Typically ch will be NIL if it isn't a number. if not numberp ch then return ""; name := MkString(0,0); % A one character string if ch > char BLANK and ch <= char '!~ then name[0] := ch % A "printing" character else if LAND(ch, 8#200) neq 0 then % Meta bit set name := concat("M-", character_name LAND(ch,8#177)) else if name := atsoc(ch, character_name_table) then name := cdr name % association list catches wild cards. else if ch < char BLANK then name := concat("C-", if ch = 8#37 then character_name(char RUBOUT) else character_name(ch + 8#100)) else EMODEerror list(ch, " is bad character code for routine `character_name'"); return name; end; Symbolic Procedure !$HelpDispatch(); % Give a little information on the routine bound to a keyboard character % (or characters, in the case of prefixed things). % We need to do a better job of merging this code with PrintAllDispatch, % AND the code that actually dispatches. begin scalar ch1, ch2, fname; ch1 := prompt_for_character("Function of character: "); if ch1 = char ESC then % Treat as meta character << ch1 := LOR( 8#200, GetNextCommandCharacter()); fname := GetInternalName(ch1, MainDispatch) >> else if ch1 = char meta X OR ch1 = char cntrl X then << ch2 := GetNextCommandCharacter(); fname := GetInternalName(ch2,atsoc(ch1, PrefixAssociationLists)) >> else fname := GetInternalName(ch1,MainDispatch); show_message BldMsg("%w %w %w", character_name ch1, character_name ch2, fname); end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Symbolic Procedure OpenLine(); % Insert a NEWLINE (or EOL) at POINT, keep POINT before newline << InsertCharacter(char EOL); !$BackwardCharacter(); >>; |
Added psl-1983/emode/envsel.sl version [3c1b57b11d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ENVSEL.SL - Utilities for switching between "environments". % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % Utilities for switching between environments in EMODE. Both buffers and % windows are examples of environments. Currently an environment is just % an association list of (name . value)'s. % Store variable bindings in association list. (DE SaveEnv (env) (progn (for (in binding-pair env) % Replace the cdr with the value of the car. (do (RPLACD binding-pair (eval (car binding-pair))))) % Return the updated environment. env)) % Establish ("restore") the bindings stored in association list "env" (DE RestoreEnv (env) (for (in binding-pair env) (do (set (car binding-pair) (cdr binding-pair))))) |
Added psl-1983/emode/example-ool.sl version [8661e409b0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EXAMPLE-OOL.SL - Examples of the usage of OOL.SL, an "object oriented % language". % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 July 1982 % Copyright (c) 1982 University of Utah % (setf generic-number (create_class (value NIL) % Local state is a "value", initially NIL. % Message table ( ((gets x) (setf value x)) % Assign argument to local state ((value) value) % Return the local value % Raise to a power ((to-power n) (let ((p 1)) (for (from i 1 n 1) % Repeatedly send a "times" message to our "value". (do (setf p (send_msg value `(times ,p)))) p)))))) (setf complex-number (create_class (real-part 0 imag-part 0) % Message dictionary ((times y) ....??? |
Added psl-1983/emode/fileio.sl version [8210275f4a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FILEIO.SL - Simple file I/O for EMODE. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 July 1982 % Copyright (c) 1982 University of Utah % %%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % WFG 23 August 1982 % - Split FIND_FILE to allow use as subroutine. (Modeled after change made % by Alan Snyder, but calls "find_file_named" instead of "find-file".) % Copy a file from filename1 to filename2 (strings). Currently this % routine is only used as a test routine. (de CopyFile (filename1 filename2) (let ((file-descriptor-1 (open filename1 'INPUT)) (file-descriptor-2 (open filename2 'OUTPUT))) % Copy characters until EOF is hit (prog (ch) (while (neq (setf ch (ChannelReadChar file-descriptor-1)) (char EOF)) (ChannelWriteChar file-descriptor-2 ch))) (close file-descriptor-1) (close file-descriptor-2))) % Write an EMODE text line to a file. (The line is a STRING.) (de WriteLine (file-descriptor lin) (let ((len (size lin))) % Number of chars in string, -1 (for (from i 0 len) (do (ChannelWriteChar file-descriptor (IGetS lin i)))) % Write an EOL (carriage return, linefeed) to end the line. (ChannelWriteChar file-descriptor (char EOL)))) % Read EMODE text line from file, return EOF if at end of FILE. % NEED to make more efficient! (But how? The few tests I've done seem to % show that reading is just as fast (well, within 50% or so) as % writing--implies that single character I/O is major cost?) (de read_line_from_file (file-descriptor) (prog (ch lin) (while (and (neq (setf ch (ChannelReadChar file-descriptor)) (char EOF)) (neq ch (char EOL))) % Suck up characters until end of line (or file). (setf lin (cons ch lin))) (return (cond % Return EOF if that was read. ((equal ch (char EOF)) ch) % Otherwise, return the line, with characters in the correct order. (T (ReversIP lin)))))) % Insert text taken from channel file-descriptor, position point at start % of inserted text. (de read_channel_into_text_buffer (file-descriptor) (prog (lin old-linepointer old-point) (setf old-linepointer CurrentLineIndex) (setf old-point point) (PutLine) (while (neq (setf lin (read_line_from_file file-descriptor)) (char EOF)) (insertline lin)) (SelectLine old-linepointer) (setf point old-point))) % Write the whole of the current (text) buffer to output channel % given by "file-descriptor". (de write_text_buffer_to_channel (file-descriptor) (prog (linepointer old-linepointer old-point) (setf old-linepointer CurrentLineIndex) (setf old-point point) (!$BeginningOfBuffer) (PutLine) (setf linepointer CurrentLineIndex) (while (not (EndOfBufferP linepointer)) (WriteLine file-descriptor (GetBufferText linepointer)) (setf linepointer (NextIndex linepointer))) % Why not SelectLine? (GetLine old-linepointer) (setf point old-point))) % Insert file into current EMODE buffer (generic version). (de ReadFile (filename) % Rebind fluid !*BREAK to prevent break loop if the file OPEN fails. (prog (file-descriptor !*BREAK) (setf file-descriptor (ErrorSet `(open ,filename 'INPUT) T NIL)) % Read the file in, if there were no problems in opening it. Treat the % file as being of the same "data mode" as the buffer. (cond ((pairp file-descriptor) (apply buffers_file_reader (list (car file-descriptor))) (close (car file-descriptor)))))) % Write whole of current EMODE buffer to file (generic version). (de WriteFile (filename) (prog (file-descriptor *BREAK) (setf file-descriptor (ErrorSet `(open ,filename 'OUTPUT) T NIL)) (cond ((pairp file-descriptor) (apply buffers_file_writer (list (car file-descriptor))) (close (car file-descriptor)) % Announce completion in the prompt window (seems more appropriate % than the "message window"). (write-prompt (concat "Written: " filename)))))) % Ask for and read a file into the current buffer. % Uses the current buffers "buffers_file" as default, updates buffers_file. (de CntrlXread () (ReadFile (setf buffers_file (prompt_for_string "Input File: " buffers_file)))) % Ask for filename, write out the buffer to the file. (de CntrlXwrite () (WriteFile (setf buffers_file (prompt_for_string "Write File: " buffers_file)))) % Save current buffer on its associated file, ask for file if unknown. (de save_file () (cond (buffers_file (WriteFile buffers_file)) (T (CntrlXwrite)))) % Ask for filename and then read it into a buffer created especially for % that file, or select already existing buffer containing the file. % Doesn't verify that the file actually exists. (de find_file () (find_file_named (prompt_for_string "Find File: " buffers_file))) % "Find" file filename. I.e. read it into a buffer created especially for % that file, or select already existing buffer containing the file. % Doesn't verify that the file actually exists. (de find_file_named (filename) (prog (buffer-name) (cond % Exit immediately if NULL string for filename. ((LessP (size filename) 0) (return NIL))) (setf buffer-name (filename-buffername filename)) (cond % Just select the buffer if it already exists. ((buffer-exists buffer-name) (progn (select_or_create_buffer buffer-name NIL) % Establish the keyboard bindings for the buffer. (EstablishCurrentMode))) % Otherwise, create the buffer and read in the file (T (select_or_create_buffer buffer-name (files_data_mode filename)) (EstablishCurrentMode) (setf buffers_file filename) (ReadFile buffers_file))))) % Convert from filename to an associated buffer name. (de filename-buffername (filename) (prog (buffer-name) % First, hunt through current buffers to see if there's already one % containing the associated file. % NOTE this test will SCREW UP if file resides in current buffer and % its associated environment list hasn't been updated. (for (in buffer BufferNames) (while (null buffer-name)) (do % If this buffer contains the filename, pick up associated % buffer-name. (cond ((equal filename (cdr (atsoc 'buffers_file (cdr buffer)))) (setf buffer-name (car buffer)))))) (return (cond % Return the buffer-name if it was found in the search. (buffer-name buffer-name) % Otherwise, create a new buffername. (T (buffer-make-unique-name (Intern % ?? (String-UpCase (buffer-name-field filename))))))))) % On the Dec-20 and Unix systems a files "data mode" is derived from the % "extension field" of it's name. This will probably require a more % general approach when more operating systems are used. (fluid '(declared_file_extensions)) (setf declared_file_extensions NIL) % Associate a buffer creator with a file extension. (de declare_file_mode (file-extension buffer-creator) (setf declared_file_extensions (cons (cons file-extension buffer-creator) declared_file_extensions))) (declare_file_mode "txt" 'create_text_buffer) (declare_file_mode "red" 'create_rlisp_buffer) (declare_file_mode "sl" 'create_lisp_buffer) % Return the "buffer creator" appropriate to a given filename, or NIL if % the appropriate buffer_creator (data mode) is unknown. (de files_data_mode (filename) (let ((buffer-creator % Use "generalized atsoc" function to look up the associated % creator, if any. (Ass (function string-equal) (file-extension-field filename) declared_file_extensions))) (cond ((pairp buffer-creator) (cdr buffer-creator))))) (if_system Dec20 % Extract the "buffer-name field" from a filename. (de buffer-name-field (filename) % Dec20 version. (prog (left-index right-index) % Bracket the subfield and then return the substring, be lazy for % now. (setf left-index 0) (setf right-index 0) % Search for a period. (while (and (leq right-index (size filename)) (neq (indx filename right-index) (char !.))) (setf right-index (add1 right-index))) % "Bump" the index back one. (setf right-index (sub1 right-index)) (return (sub filename left-index (difference right-index left-index)))))) (if_system Unix % Extract the "buffer-name field" from a filename. (de buffer-name-field (filename) % Unix version. (prog (left-index right-index) (setf right-index (size filename)) (setf left-index right-index) (while (and (geq left-index 0) (neq (indx filename left-index) (char !/))) (setf left-index (sub1 left-index))) % "Bump" the index one right. (setf left-index (add1 left-index)) % Now, search right from the left index. (setf right-index left-index) % Search for a period. (while (and (leq right-index (size filename)) (neq (indx filename right-index) (char !.))) (setf right-index (add1 right-index))) % "Bump" right-index back one. (setf right-index (sub1 right-index)) (return (sub filename left-index (difference right-index left-index)))))) % Extract the "file extension" from a filename, should work for both Dec-20 % and Unix. (de file-extension-field (filename) (prog (left-index right-index) % Scan from the right, looking for a period. (setf left-index (size filename)) (setf right-index left-index) (while (and (geq left-index 0) (neq (indx filename left-index) (char !.))) (setf left-index (sub1 left-index))) % If no period was found, return the null string. (cond ((LessP left-index 0) (return "")) % Otherwise, return appropriate substring. (T (setf left-index (add1 left-index)) % Skip past the period. (return (sub filename left-index (difference right-index left-index))))))) |
Added psl-1983/emode/hp-emode-files-1.red version [6243ba724d].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % Loads "first half" of files necessary to build EMODE. % Assumes that the "default directory" contains all the necessary files. imports '(strings jsys); % These libraries needed at runtime. in "temporary-emode-fixes.red"$ in "customize-rlisp-for-emode.sl"$ % Must be first? in "envsel.sl"$ % Support for "environments" in "dispch.sl"$ % "keyboard" dispatch support in "emode1.red"$ % Bunches of stuff in "ring-buffer.sl"$ in "buffer-position.sl"$ in "query-replace.sl"$ in "buffers.sl"$ in "window.sl"$ in "windows.sl"$ in "dired.sl"$ in "sleep.sl"$ in "buffer.sl"$ |
Added psl-1983/emode/hp-emodex.sl version [074372946e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HP-EMODEX.SL - General HP EMODE Extensions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 2 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % WFG 23 August 1982 % - Modified transpose-characters-command to behave as if at end of line if % the last command dispatched on was InsertSelfCharacter. % - Made several "lispy" commands specific to Lisp mode rather than text % mode. (BothTimes (load common)) % The following symbolic constants should be used in source code % instead of the equivalent (Char X) expression to avoid fooling % EMODE's stupid LISP parser while editing this file: (CompileTime (setf LEFT-PAREN 40)) (CompileTime (setf RIGHT-PAREN 41)) (CompileTime (setf LEFT-PAREN-ID (int2id 40))) (CompileTime (setf RIGHT-PAREN-ID (int2id 41))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(CurrentLineIndex)) (de scroll-window-by-lines (n) % Scroll the contents of the current window up (n > 0) or down (n < 0) % by |n| lines. CurrentLineIndex may be adjusted to keep it within % the desired window location. (let* ((window-height (current-window-height)) (new-top-line (+ (current-window-top-line) n)) (buffer-last-line (- (current-buffer-visible-size) 1)) ) % adjust to keep something in the window (cond ((< new-top-line 0) (setf new-top-line 0)) ((> new-top-line buffer-last-line) (setf new-top-line buffer-last-line)) ) % adjust cursor if no longer in window (cond ((< CurrentLineIndex new-top-line) (SelectLine new-top-line)) ((>= CurrentLineIndex (+ new-top-line window-height)) (SelectLine (+ new-top-line window-height -1))) ) (current-window-set-top-line new-top-line) )) (de scroll-window-by-pages (n) % Scroll the contents of the current window up (n > 0) or down (n < 0) % by |n| screen-fulls. CurrentLineIndex may be adjusted to keep it within % the desired window location. (let* ((old-top-line (current-window-top-line)) (window-height (current-window-height)) (new-top-line (+ (current-window-top-line) (* n window-height))) (buffer-last-line (- (current-buffer-visible-size) 1)) ) % don't do the scroll if no change is needed (cond ((and (> new-top-line (- window-height)) (<= new-top-line buffer-last-line)) (setf new-top-line (max new-top-line 0)) % keep the cursor at the same relative location in the window! (SelectLine (min (+ CurrentLineIndex (- new-top-line old-top-line)) (- (current-buffer-size) 1))) (current-window-set-top-line new-top-line) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de scroll-window-up-line-command () (scroll-window-by-lines 1) ) (de scroll-window-down-line-command () (scroll-window-by-lines -1) ) (de scroll-window-up-page-command () (scroll-window-by-pages 1) ) (de scroll-window-down-page-command () (scroll-window-by-pages -1) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Indenting Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-line-indent () % Return the indentation of the current line, in terms of spaces. (for (in ch CurrentLine) (while (or (= ch (char space)) (= ch (char tab)))) (sum (if (= ch (char tab)) 8 1)) )) (de current-line-strip-indent () % Strip all leading blanks and tabs from the current line. (while (and CurrentLine (char-blank? (car CurrentLine))) (setf CurrentLine (cdr CurrentLine)) (if (> point 0) (setf point (- point 1))) )) (de strip-previous-blanks () % Strip all blanks and tabs before point. (while (and (> point 0) (char-blank? (current-line-fetch (- point 1)))) ($DeleteBackwardCharacter)) ) (de indent-current-line (n) % Adjust the current line to have the specified indentation. (current-line-strip-indent) (let ((n-spaces (remainder n 8)) (n-tabs (quotient n 8))) (for (from i 1 n-spaces 1) (do (setf CurrentLine (cons (char space) CurrentLine)) (setf point (+ 1 point)))) (for (from i 1 n-tabs 1) (do (setf CurrentLine (cons (char tab) CurrentLine)) (setf point (+ 1 point)))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Indenting Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (SetTextKey (char (meta !\)) 'delete-horizontal-space-command) (de delete-horizontal-space-command () (prog (ch) (while (< point (current-line-length)) (setf ch (current-line-fetch point)) (if (not (char-blank? ch)) (exit)) (DeleteCharacter) ) (while (> point 0) (setf ch (current-line-fetch (- point 1))) (if (not (char-blank? ch)) (exit)) (setf point (- point 1)) (DeleteCharacter) ) )) (SetTextKey (CharSequence (cntrl X) (cntrl O)) 'delete-blank-lines-command) (de delete-blank-lines-command () (cond ((current-line-blank?) % We are on a blank line. % Replace multiple blank lines with one. % First, search backwards for the first blank line % and save its index. (while (> CurrentLineIndex 0) ($BackwardLine) (cond ((not (current-line-blank?)) ($ForwardLine) (exit)) ) ) (delete-following-blank-lines) ) (t % We are on a non-blank line. Delete any blank lines % that follow this one. (delete-following-blank-lines) ) )) (de delete-following-blank-lines () % Delete any blank lines that immediately follow the current one. (if (not (current-line-is-last?)) (progn (let ((old-index CurrentLineIndex) (old-point point) first-index ) % Advance past the current line until the next nonblank line. (move-to-next-line) (setf first-index CurrentLineIndex) (while T (cond ((not (current-line-blank?)) (exit)) ((current-line-is-last?) ($EndOfLine) (exit)) (t (move-to-next-line)) )) (delete_or_copy T first-index 0 CurrentLineIndex point) (current-buffer-goto old-index old-point) )))) (SetTextKey (char (meta M)) 'back-to-indentation-command) (SetTextKey (char (meta (cntrl M))) 'back-to-indentation-command) (de back-to-indentation-command () ($BeginningOfLine) (while (char-blank? (CurrentCharacter)) ($ForwardCharacter) )) (SetTextKey (char (meta ^)) 'delete-indentation-command) (de delete-indentation-command () (current-line-strip-indent) ($BeginningOfLine) (if (not (current-line-is-first?)) (progn ($DeleteBackwardCharacter) (if (and (not (= point 0)) (not (= (current-line-fetch (- point 1)) #.LEFT-PAREN)) (not (= (CurrentCharacter) #.RIGHT-PAREN)) ) (InsertCharacter (char space)) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % LISP Indenting % Note: this is a crock - need more sophisticated scanning %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (SetLispKey (char tab) 'lisp-tab-command) (SetLispKey (char (meta (cntrl tab))) 'lisp-tab-command) (SetLispKey (char LF) 'lisp-linefeed-command) (SetLispKey (char (meta (cntrl Q))) 'lisp-indent-sexpr) (de lisp-tab-command () (indent-current-line (lisp-current-line-indent))) (de lisp-linefeed-command () ($CRLF) (indent-current-line (lisp-current-line-indent))) (de lisp-indent-sexpr () (if (not (move-down-list)) (Ding) (let ((old-line CurrentLineIndex) (old-point (- point 1)) final-line) (if (not (forward-scan-for-right-paren -1)) (Ding) (setf final-line CurrentLineIndex) (for (from i (+ old-line 1) final-line 1) (do (SelectLine i) (indent-current-line (lisp-current-line-indent)) )) (current-buffer-goto old-line old-point))) )) (de lisp-current-line-indent () (let ((old-point point) (old-line CurrentLineIndex) indentation previous-line) (cond ((and (> CurrentLineIndex 0) (setf previous-line (GetBufferText (- CurrentLineIndex 1))) (>= (size previous-line) 0) (= (indx previous-line 0) #.LEFT-PAREN) ) 2) (t (setf point 0) (backward_sexpr) (setf indentation (LineColumn point (List2String CurrentLine))) (current-buffer-goto old-line old-point) indentation )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Miscellaneous Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (SetTextKey (char (cntrl T)) 'transpose-characters-command) % Transpose the last two characters, if we're at the end of the line, or if % a character was just inserted. Otherwise, transpose the characters on % either side of point. (de transpose-characters-command () (progn (if (or (= point (current-line-length)) (eq last_operation 'InsertSelfCharacter)) % We are at the end of a non-empty line, or last character was self % inserting. ($BackwardCharacter)) (cond % We are at the beginning of a line, or the line has fewer then two % characters? ((or (= point 0) (< (current-line-length) 2)) (Ding)) (t % We are in the middle of a line. (prog (ch) ($BackwardCharacter) (setf ch (CurrentCharacter)) (DeleteCharacter) ($ForwardCharacter) (InsertCharacter ch) ) )))) (SetTextKey (char (meta @)) 'mark-word-command) (de mark-word-command () (let ((old-index CurrentLineIndex) (old-point point)) (forward_word) (SetMark) (current-buffer-goto old-index old-point) )) (SetTextKey (char (meta (cntrl @))) 'mark-sexp-command) (de mark-sexp-command () (let ((old-index CurrentLineIndex) (old-point point)) (forward_sexpr) (SetMark) (current-buffer-goto old-index old-point) )) (SetTextKey (CharSequence (cntrl X) H) 'mark-whole-buffer-command) (de mark-whole-buffer-command () ($EndOfBuffer) (SetMark) ($BeginningOfBuffer) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % LISP Defun Commands and Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (SetLispKey (char (meta (cntrl A))) 'beginning-of-defun-command) (SetLispKey (char (meta (cntrl ![))) 'beginning-of-defun-command) (de beginning-of-defun-command () % Move BACKWARD (literally) to the beginning of the current % (or previous) DEFUN. If this is impossible, Ding and don't move. (if (at-buffer-start?) (Ding) ($BackwardCharacter) (if (not (beginning-of-defun)) (progn ($ForwardCharacter) (Ding))) )) (de beginning-of-defun () % Move backward to the beginning of the current DEFUN. A DEFUN is % heuristically defined to be a line whose first character is a left % parenthesis. If no DEFUN is found, point is left unchanged and % NIL is returned; otherwise T is returned. (let ((pos (buffer-get-position)) ) ($BeginningOfLine) (while T (cond ((= (CurrentCharacter) #.LEFT-PAREN) (exit T)) ((current-line-is-first?) (buffer-set-position pos) (exit NIL)) (t (move-to-previous-line)) )))) (SetLispKey (char (meta (cntrl E))) 'end-of-defun-command) (SetLispKey (char (meta (cntrl !]))) 'end-of-defun-command) (de end-of-defun-command () % Move FORWARD (literally) to the beginning of the next line following % the end of a DEFUN. (let ((old-line CurrentLineIndex) ) (if (or (not (end-of-defun)) (< CurrentLineIndex old-line)) % If there is no current defun, or we were past the end of the % previous DEFUN, then we should continue onward to look for the % next DEFUN. (if (forward-defun) (forward_sexpr) (Ding) ))) (move-to-next-line) ) (de forward-defun () % Move forward to the beginning of the next DEFUN. % If no DEFUN is found, point is left unchanged and % NIL is returned; otherwise T is returned. (let ((pos (buffer-get-position)) ) (while T (move-to-next-line) (cond ((= (CurrentCharacter) #.LEFT-PAREN) (exit T)) ((current-line-is-last?) (buffer-set-position pos) (exit NIL)) )))) (de end-of-defun () % Move forward to the end of the current DEFUN. % If there is no current DEFUN, don't move and return NIL. % Otherwise, return T. (cond ((not (beginning-of-defun)) NIL) (t (forward_sexpr) T) )) (SetLispKey (char (meta (cntrl H))) 'mark-defun-command) (de mark-defun-command () (end-of-defun-command) (SetMark) (beginning-of-defun-command) (if (> CurrentLineIndex 0) (progn (move-to-previous-line) (if (not (current-line-blank?)) (move-to-next-line)) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Lisp List Commands and Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(paren_depth)) % see Search.RED % Perhaps SetLispKey is more appropriate? (SetTextKey (char (meta (cntrl P))) 'move-past-previous-list) (de move-past-previous-list () % Move to the beginning of the current or previous list. In other words, % find the previous left paren whose matching right paren is after point % or is the first right paren before point. % If no such left paren can be found, Ding, but do not move. (if (not (reverse-scan-for-left-paren 0)) (Ding)) ) % (SetTextKey (char (meta (cntrl #.LEFT-PAREN-ID))) 'backward-up-list) (SetTextKey (char (meta (cntrl U))) 'backward-up-list) (de backward-up-list () % Move to the left of the current list. "Dual" to forward-up-list. (if (not (reverse-scan-for-left-paren 1)) (Ding)) ) (de reverse-scan-for-left-paren (depth) % Scan backwards (starting with the character before point) for % a left paren at depth >= the specified depth. If found, the % left paren will be after point and T will be returned. Otherwise, % point will not change and NIL will be returned. (let ((old-position (buffer-get-position)) ch ) (setf paren_depth 0) (while T (cond ((and (= ch #.LEFT-PAREN) (>= paren_depth depth)) (exit T)) ((at-buffer-start?) (buffer-set-position old-position) (exit NIL)) (t ($BackwardCharacter) (setf ch (CurrentCharacter)) (adjust_depth ch) ) )))) (SetTextKey (char (meta (cntrl N))) 'move-past-next-list) (de move-past-next-list () % Move to the right of the current or next list. In other words, % find the next right paren whose matching left paren is before point % or is the first left paren after point. % If no such right paren can be found, Ding, but do not move. (if (not (forward-scan-for-right-paren 0)) (Ding)) ) % (SetTextKey (char (meta (cntrl #.RIGHT-PAREN-ID))) 'forward-up-list) (SetTextKey (char (meta (cntrl O))) 'forward-up-list) (de forward-up-list () % Move to the right of the current list. In other words, % find the next right paren whose matching left paren is before point. % If no such right paren can be found, Ding, but do not move. (if (not (forward-scan-for-right-paren -1)) (Ding)) ) (de forward-scan-for-right-paren (depth) % Scan forward (starting with the character after point) for % a right paren at depth <= the specified depth. If found, the % right paren will be before point and T will be returned. Otherwise, % point will not change and NIL will be returned. (let ((old-position (buffer-get-position)) ch ) (setf paren_depth 0) (while T (cond ((at-buffer-end?) (buffer-set-position old-position) (exit NIL))) (setf ch (CurrentCharacter)) (adjust_depth ch) ($ForwardCharacter) (cond ((and (= ch #.RIGHT-PAREN) (<= paren_depth depth)) (exit T)) )))) (SetTextKey (char (meta (cntrl D))) 'down-list) (de down-list () % Move inside the next contained list. In other words, % find the next left paren without an intervening right paren. % If no such left paren can be found, Ding, but do not move. (if (not (move-down-list)) (Ding)) ) (de move-down-list () (let ((old-position (buffer-get-position)) ch ) (while T (cond ((at-buffer-end?) (buffer-set-position old-position) (exit NIL))) (setf ch (CurrentCharacter)) ($ForwardCharacter) (cond ((= ch #.LEFT-PAREN) (exit T)) ((= ch #.RIGHT-PAREN) (buffer-set-position old-position) (exit NIL)) )))) (SetTextKey (char (meta #.LEFT-PAREN-ID)) 'insert-parens) (de insert-parens () (InsertCharacter #.LEFT-PAREN) (InsertCharacter #.RIGHT-PAREN) ($BackwardCharacter) ) (SetTextKey (char (meta #.RIGHT-PAREN-ID)) 'move-over-paren) (de move-over-paren () (if (forward-scan-for-right-paren 0) (progn ($BackwardCharacter) (strip-previous-blanks) ($ForwardCharacter) (lisp-linefeed-command) ) (Ding))) |
Added psl-1983/emode/hp2648a.sl version [aa1ee7a62b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HP2648A.SL - EMODE support for HP2648A terminals. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % %%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % CSP 7/7/82 % - Changed Meta- prefix char to C-\. % - Defined ESCAPE as genuine prefix character. % - Changed parity_mask for HP terminals to 8#377. % CSP 7/8/82 % - This file now redefines quit. % AS 7/20/82 % - Added ESC-x hooks for line and page scrolling (defined in hp-emodex). % AS 8/6/82 % - Simple optimization of SetTerminalCursor to reduce number of characters % sent to the terminal. % AS 8/12/82 % - Define Terminal-Enter-Raw-Mode and Terminal-Leave-Raw-Mode to % enable and disable keypad. Removed unnecessary redefinitions of % EMODE functions that now invoke these new functions. (fluid '(*EMODE ScreenBase ScreenDelta parity_mask)) % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setq parity_mask 8#377) (de EraseScreen () % Cursor home (PBOUT (char ESC)) (PBOUT (char H)) % Now clear to end of screen (PBOUT (char ESC)) (PBOUT (char J))) (de Ding () (PBOUT (char BELL))) (de TerminalClearEol () % Clear to end of line from current position (inclusive). (PBOUT (char ESC)) (PBOUT (char K))) (de SetTerminalCursor (ColLoc RowLoc) % Move physical cursor to Column,Row (if (and (= RowLoc 0) (= ColLoc 0)) (progn (PBOUT (char ESC)) (PBOUT (char H))) % Else (PBOUT (char ESC)) (PBOUT (char '!&)) (PBOUT (char !a)) % Use "quick and dirty" conversion to decimal digits. (if (> RowLoc 9) (PBOUT (plus (char 0) (quotient RowLoc 10))) ) (PBOUT (plus (char 0) (remainder RowLoc 10))) % Delimiter between row digits and column digits. (PBOUT (char (lower R))) (if (> ColLoc 9) (PBOUT (plus (char 0) (quotient ColLoc 10))) ) (PBOUT (plus (char 0) (remainder ColLoc 10))) (PBOUT (char C)) % Terminate the sequence )) % EMODE must be loaded first! (define_prefix_character (char Escape) "Esc-") (mapc (list (list (char (cntrl !\)) 'EscapeAsMeta) (list (CharSequence escape J) 'FullRefresh) (list (CharSequence escape A) '!$BackwardLine) (list (CharSequence escape B) '!$ForwardLine) (list (CharSequence escape C) '!$ForwardCharacter) (list (CharSequence escape D) '!$BackwardCharacter) (list (CharSequence escape !h) '!$BeginningOfBuffer) (list (CharSequence escape F) '!$EndOfBuffer) (list (CharSequence escape 5) 'forward_word) (list (CharSequence escape 4) 'backward_word) (list (CharSequence escape U) 'scroll-window-up-page-command) (list (CharSequence escape V) 'scroll-window-down-page-command) (list (CharSequence escape P) '$DeleteForwardCharacter) (list (CharSequence escape M) 'kill_line) (list (CharSequence escape L) 'OpenLine) (list (CharSequence escape S) 'scroll-window-up-line-command) (list (CharSequence escape T) 'scroll-window-down-line-command) ) (function (lambda (lis) (AddToKeyList 'BasicDispatchList (car lis) (cadr lis))))) (de terminal-enter-raw-mode () % Enable Keypad (PBOUT (char escape)) (pbout (char !&)) (pbout (char !s)) (pbout (char 1)) (pbout (char A))) (de terminal-leave-raw-mode () % Disable Keypad (PBOUT (char escape)) (pbout (char !&)) (pbout (char !s)) (pbout (char 0)) (pbout (char A))) |
Added psl-1983/emode/hp9836.sl version [5dee3ff460].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HP9836.SL - EMODE support for Hp9836 as VT52 terminals. % (Same as Teleray except for % parity_mask?) % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Mods by MLG % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#377) (DE EraseScreen () (PBOUT (char ESC)) (PBOUT (char H)) (PBOUT (char ESC)) (PBOUT (char J))) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (char Y)) (PBOUT (plus (char BLANK) RowLoc)) (PBOUT (plus (char BLANK) ColLoc)))) |
Added psl-1983/emode/input-stream.sl version [272df1beb7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Input-Stream.SL (TOPS-20 Version) - File Input Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.6 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.7 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects jsys)) (defun open-input (file-name) (let ((s (make-instance 'input-stream))) (=> s open file-name) s)) %(CompileTime (setq *pgwd t)) (CompileTime (setq FILE-BUFFER-SIZE (* 5 512))) (defflavor input-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next char in buffer count % number of valid chars in buffer eof-flag % T => this bufferfull is the last file-name % full name of actual file buffer % input buffer ) () (gettable-instance-variables file-name) ) % Note: The JSYS function can't be used for the 'SIN' JSYS because the function % handles errors. The 'SIN' JSYS will report an error on end-of-file if errors % are being handled. (CompileTime (put 'sin 'OpenCode '((jsys 42) (move (reg 1) (reg 3))))) (CompileTime (put 'closf 'OpenCode '((jsys 18) (move (reg 1) (reg 1))))) (defmethod (input-stream getc) () % Return the next character from the file. Line termination % is represented by a single NEWLINE (LF) character. % Note: returns NIL on end of file. (if (WLessP ptr count) (let ((ch (prog1 (igets buffer ptr) (setf ptr (wplus2 ptr 1)) ))) % Ignore CR's (if (WNEq ch (char CR)) ch (input-stream$getc self)) ) (input-stream$fill-buffer-and-getc self) )) % The above function was coded to produce good compiled code % using the current PSL compiler. Here's the output. Note % that no stack variables are used. The main path uses 16 % instructions. There is room for improvement. % (*ENTRY INPUT-STREAM$GETC EXPR 1) % G0002 (MOVE (REG 4) (REG 1)) % (MOVE (REG T1) (INDEXED (REG 1) 6)) % (CAMG (REG T1) (INDEXED (REG 1) 5)) % (JRST G0004) % (MOVE (REG 2) (INDEXED (REG 1) 5)) % (MOVE (REG 1) (INDEXED (REG 1) 4)) % (AOS (REG 1)) % (ADJBP (REG 2) "L0010") % (LDB (REG 1) (REG 2)) % (MOVE (REG 3) (REG 1)) % (MOVE (REG 1) (INDEXED (REG 4) 5)) % (AOS (REG 1)) % (MOVEM (REG 1) (INDEXED (REG 4) 5)) % (MOVE (REG 1) (REG 3)) % (CAIE (REG 1) 13) % (JRST G0001) % (MOVE (REG 1) (REG 4)) % (JRST G0002) % G0004 (JRST (ENTRY INPUT-STREAM$FILL-BUFFER-AND-GETC)) % G0001 (POPJ (REG ST) 0) % L0010 (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) (defmethod (input-stream fill-buffer-and-getc) () % Implementation note: Removing all of this code from GETC improves the % quality of the compiled code for GETC. In particular, the compiler is able % to keep SELF in a register, instead of saving it in a stack variable and % (excessively) reloading it every time it is needed. Making this change % increased the performance of buffered input from 4X to 6.6X the standard % unbuffered input. (if eof-flag NIL (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE)))) (if (not (WEQ n 0)) (setf eof-flag T)) (setf count (WPlus2 #.FILE-BUFFER-SIZE n)) (setf ptr 0) (input-stream$getc self)))) (defmethod (input-stream getc-image) () % Return the next character from the file. Do not perform % any translation. In particular, return all <CR>s. % Returns NIL on end of file. (if (WLessP ptr count) (prog1 (igets buffer ptr) (setf ptr (wplus2 ptr 1)) ) (input-stream$fill-buffer-and-getc-image self) )) (defmethod (input-stream fill-buffer-and-getc-image) () (if eof-flag NIL (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE)))) (if (not (WEQ n 0)) (setf eof-flag T)) (setf count (WPlus2 #.FILE-BUFFER-SIZE n)) (setf ptr 0) (input-stream$getc-image self)))) (defmethod (input-stream empty?) () (null (input-stream$peekc self))) (defmethod (input-stream peekc) () % Return the next character from the file, but don't advance % to the next character. Returns NIL on end of file. (if (WLessP ptr count) (let ((ch (igets buffer ptr))) % Ignore CR's (if (WNEq ch (char CR)) ch (setf ptr (wplus2 ptr 1)) (input-stream$peekc self)) ) (input-stream$fill-buffer-and-peekc self) )) (defmethod (input-stream fill-buffer-and-peekc) () (if eof-flag NIL (let ((n (sin jfn (jconv buffer) (WDifference 0 #.FILE-BUFFER-SIZE)))) (if (not (WEQ n 0)) (setf eof-flag T)) (setf count (WPlus2 #.FILE-BUFFER-SIZE n)) (setf ptr 0) (input-stream$peekc self)))) (defmethod (input-stream open) (name-of-file) % Open the specified file for input via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (input-stream$close self)) (setf buffer (MkString #.FILE-BUFFER-SIZE (char space))) (setf ptr 0) (setf count 0) (setf eof-flag NIL) (setf jfn (Dec20Open name-of-file (int2sys 2#001000000000000001000000000000000000) (int2sys 2#000111000000000000010000000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null jfn) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Input." name-of-file) name-of-file)) (setf file-name (MkString 200 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 #.(get 'jsJFNS 'NewNam)) (setf file-name (recopystringtonull file-name)) )) (defmethod (input-stream close) () (if jfn (progn (closf jfn) (setf jfn NIL) (setf buffer NIL) (setf count 0) (setf ptr 0) (setf eof-flag T) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CommentOutCode (progn (de test-buffered-input (name-of-file) (setq s (open-input name-of-file)) (while (setq ch (input-stream$getc s)) (WriteChar ch) ) (=> s close) (Prin2 "---EOF---") NIL ) (de time-buffered-input (name-of-file) (setq start-time (time)) (setq s (open-input name-of-file)) (while (setq ch (input-stream$getc s)) ) (=> s close) (- (time) start-time) ) (de time-buffered-input-1 (name-of-file) (setq start-time (time)) (setq s (open-input name-of-file)) (while (setq ch (=> s getc)) ) (=> s close) (- (time) start-time) ) (de time-standard-input (name-of-file) (setq start-time (time)) (setq chan (open name-of-file 'INPUT)) (while (not (= (setq ch (ChannelReadChar chan)) (char EOF))) ) (close chan) (- (time) start-time) ) (de time-input (name-of-file) (list (time-buffered-input name-of-file) (time-buffered-input-1 name-of-file) (time-standard-input name-of-file) )) )) % End CommentOutCode |
Added psl-1983/emode/keybindings.mss version [2d8fe8a6e8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Comment{This file describes keyboard bindings and useful commands for EMODE--to be included in other files that need to document them.} The following commands are notable either for their difference from EMACS, or for their importance to getting started with EMODE: @begin[itemize, spread 1] To leave EMODE type @w[C-X C-Z] to "QUIT" to the EXEC, or @w[C-Z C-Z] to return to "normal" PSL input/output. While in EMODE, the "M-?" (meta- question mark) character asks for a command character and prints the name of the routine attached to that character. The function "PrintAllDispatch()" will print out the current dispatch table. You must call EMODE first, to set this table up. M-C-Y inserts into the current buffer the text printed as a result of the last M-E. M-X prompts for a one line string and then executes it as a Lisp expression. Of course, similar results can be achieved by using M-E in a buffer. @end[itemize] A (fairly) complete table of keyboard bindings follows: @begin[description, spread 0] C-@@@\Runs the function SETMARK. C-A@\Runs the function !$BEGINNINGOFLINE. C-B@\Runs the function !$BACKWARDCHARACTER. C-D@\Runs the function !$DELETEFORWARDCHARACTER. C-E@\Runs the function !$ENDOFLINE. C-F@\Runs the function !$FORWARDCHARACTER. Tab@\In Lisp mode, runs the function LISP-TAB-COMMAND. Indents as appropriate for Lisp. @begin[multiple] Linefeed@\In text mode, runs the function !$CRLF and acts like a carriage return. In Lisp mode, runs the function LISP-LINEFEED-COMMAND. Inserts a newline and indents as appropriate for Lisp. @end[multiple] C-K@\Runs the function KILL_LINE. C-L@\Runs the function FULLREFRESH. Return@\Runs the function $CRLF (inserts a carriage return). C-N@\Runs the function !$FORWARDLINE. C-O@\Runs the function OPENLINE. C-P@\Runs the function !$BACKWARDLINE. C-Q@\Runs the function INSERTNEXTCHARACTER. Acts like a "quote" for the next character typed. C-R@\Backward search for string, type a carriage return to terminate the search string. Default (for a null string) is the last string previously searched for. C-S@\Forward search for string. C-T@\Transpose the last two characters typed (if the last character typed was self inserting). Otherwise, transpose the characters to the left and right of point, or the two characters to the left of point if at the end of a line. C-U@\Repeat a command. Similar to EMACS's C-U. C-V@\Runs the function SCROLL-WINDOW-UP-PAGE-COMMAND. C-W@\Runs the function KILL_REGION. C-X@\As in EMACS, control-X is a prefix for "fancier" commands. C-Y@\Runs the function INSERT_KILL_BUFFER. Yanks back killed text. C-Z@\Runs the function DOCONTROLMETA. As in EMACS, acts like "Control-Meta" (or "Meta-Control"). ESCAPE@\Runs the function ESCAPEASMETA. As in EMACS, ESCAPE acts like the "Meta" key. )@\Inserts a "matching" right parenthesis. Bounces back to the corresponding left parenthesis, or beeps if no matching parenthesis is found. RUBOUT@\Runs the function !$DELETEBACKWARDCHARACTER. M-C-@@@\Runs the function MARK-SEXP-COMMAND. Sets mark at the end of the s-expression following point. M-C-A@\In Lisp mode, runs the function BEGINNING-OF-DEFUN-COMMAND. Moves backward to the beginning of the current or previous) DEFUN. A DEFUN is heuristically defined to be a line whose first character is a left parenthesis. M-C-B@\Runs the function BACKWARD_SEXPR. M-C-D@\Runs the function DOWN-LIST. Moves "deeper" into the next contained list. M-C-E@\In Lisp mode, runs the function END-OF-DEFUN-COMMAND. Moves forward to the beginning of the next line following the end of a DEFUN. M-C-F@\Runs the function FORWARD_SEXPR. M-Backspace@\In Lisp mode, runs the function MARK-DEFUN-COMMAND. M-Tab@\In Lisp mode, runs the function LISP-TAB-COMMAND. M-C-K@\Runs the function KILL_FORWARD_SEXPR. M-Return@\Runs the function BACK-TO-INDENTATION-COMMAND. Similar to C-A, but skips past any leading blanks. M-C-N@\Runs the function MOVE-PAST-NEXT-LIST. Moves to the right of the @i[current] or next list. M-C-O@\Runs the function FORWARD-UP-LIST. Moves to the right of the @i[current] list. M-C-P@\Runs the function MOVE-PAST-PREVIOUS-LIST. Moves to the beginning of the current or previous list. M-C-Q@\Runs the function LISP-INDENT-SEXPR. "Lisp indents" each line in the next s-expr. M-C-U@\Runs the function BACKWARD-UP-LIST. Does the "opposite" of FORWARD-UP-LIST. M-C-Y@\In Lisp and Rlisp mode runs the function INSERT_LAST_EXPRESSION. Inserts the last body of text typed as the result of a M-E. M-C-Z@\Runs the function OLDFACE. Leaves EMODE, goes back to "regular" PSL input/output. M-Escape@\In Lisp mode, runs the function BEGINNING-OF-DEFUN-COMMAND. (See M-C-A.) M-C-]@\In Lisp mode, runs the function END-OF-DEFUN-COMMAND. (See M-C-E.) M-C-RUBOUT@\Runs the function KILL_BACKWARD_SEXPR. M-%@\Runs the function QUERY-REPLACE-COMMAND. Similar to EMACS's query replace. M-(@\Runs the function INSERT-PARENS. Inserts a matching pair of parenthesis, leaving point between them. M-)@\Runs the function MOVE-OVER-PAREN. Moves over a ")" updating indentation (as appropriate for Lisp). M-/@\Runs the function !$HELPDISPATCH, see the description of M-? below. M-;@\In Lisp and Rlisp mode runs the function INSERTCOMMENT. M-<@\Runs the function !$BEGINNINGOFBUFFER. Move to beginning of buffer. M->@\Runs the function !$ENDOFBUFFER. Move to end of buffer. M-?@\Runs the function !$HELPDISPATCH. Asks for a character and prints the name of the routine attached to that character. M-@@@\Runs the function MARK-WORD-COMMAND. M-B@\Runs the function BACKWARD_WORD. Backs up over a word. M-D@\Runs the function KILL_FORWARD_WORD. M-E@\In Lisp and RLISP modes evaluates the expression starting at the beginning of the current line. M-F@\Runs the function FORWARD_WORD. Moves forward over a word. M-M@\Runs the function BACK-TO-INDENTATION-COMMAND. (See M-Return for more description.) M-V@\Runs the function SCROLL-WINDOW-DOWN-PAGE-COMMAND. Moves up a window. M-W@\Runs the function COPY_REGION. Like C-W only it doesn't kill the region. M-X@\Runs the function EXECUTE_COMMAND. Prompts for a string and then converts it to Lisp expression and evaluates it. M-Y@\Runs the function UNKILL_PREVIOUS. Used to cycle through the kill buffer. Deletes the last yanked back text and then proceeds to yank back the previous piece of text in the kill buffer. M-\@\Runs the function DELETE-HORIZONTAL-SPACE-COMMAND. Deletes all blanks (and tabs) around point. M-^@\Runs the function DELETE-INDENTATION-COMMAND. Deletes CRLF and indentation at front of line, leaves one space in place of them. M-RUBOUT@\Runs the function KILL_BACKWARD_WORD. C-X C-B@\Runs the function PRINTBUFFERNAMES. Prints a list of all the buffers present. C-X C-F@\Runs the function FIND_FILE. Asks for a filename and then selects the buffer that that file resides in, or creates a new buffer and reads the file into it. C-X C-O@\Runs the function DELETE-BLANK-LINES-COMMAND. Deletes blank lines around point (leaving one left). C-X C-P@\Runs the function WRITESCREENPHOTO. Write a "photograph" of the screen to a file. C-X C-R@\Runs the function CNTRLXREAD. Read a file into the buffer. C-X C-S@\Runs the function SAVE_FILE. Writes the buffer to the file associated with that buffer, asks for an associated file if none defined. C-X C-W@\Runs the function CNTRLXWRITE. Write the buffer out to a file. C-X C-X@\Runs the function EXCHANGEPOINTANDMARK C-X C-Z@\As in EMACS, exits to the EXEC. C-X 1@\Goes into one window mode. C-X 2@\Goes into two window mode. C-X B@\Runs the function CHOOSEBUFFER. EMODE asks for a buffer name, and then selects (or creates) that buffer for editing. C-X H@\Runs the function MARK-WHOLE-BUFFER-COMMAND. C-X N@\Runs the function NEXT_WINDOW. Selects the "next" window in the list of active windows. Note that some active windows may be covered by other screens, so they will be invisible until @w[C-X N] reaches them and "pops" them to the "top" of the screen. C-X O@\An alternate way to invoke NEXT_WINDOW. C-X P@\Runs the function PREVIOUS_WINDOW. Selects the "previous" window in the list of active windows. @end[description] |
Added psl-1983/emode/menu.build version [e3d83a3c8b].
> | 1 | in "pe:menu.red"$ |
Added psl-1983/emode/menu.red version [177b59797b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % simple demo of tools for menus and break windows % MLG and WFG Symbolic Procedure MakeMenu(); % Setup the Menu Window begin scalar oldbuffer; % Create the MENU buffer MenuBuffer:=CreateBuffer('MENU, eval DefaultMode); % Create (but don't "select") the window to look into the buffer. MenuWindow := FramedWindowDescriptor('MENU, % Starts at column 50, Row 13 Coords(50,13), Coords(25,7)); % Set up the buffer text. oldbuffer := CurrentBufferName; SelectBuffer 'MENU; append_line("ERASE(); % the screen"); append_line("ExitMenu();"); append_line("KillMenu();"); !$CRLF(); % "Pop" back to original buffer. SelectBuffer oldbuffer; % Define a new key binding (for text mode) for popping up the menu. SetTextKey(Char Cntrl H, 'Menu); end; Procedure KillMenu(); % Exit and Wipe MENU <<!*KillMenu:=T; Throw('!$MENU!$,0)>>; Procedure ExitMenu(); % Exit and LEAVE Menu <<!*KillMenu:=NIL; Throw('!$MENU!$,0)>>; Fluid '(!*KillMenu); procedure MenuReader(); TopLoop('ReformXread,'NoPrint,'EVAL,"Menu",""); Procedure NoPrint x; X; procedure Menu; Begin Scalar W; % Need to select EMODE channels, since MENU is typically invoked while % "old" channels are selected. SelectEMODEChannels(); W:=CurrentWindowdescriptor; SelectWindow MenuWindow$ !$BeginningOfBuffer(); % Place point at start of buffer. % Transfer control to the menu reader. Catch('!$MENU!$, MenuReader() ); % When finished, "pop" our screen off of the physical screen. If !*KillMenu then DeselectScreen CurrentVirtualScreen; SelectWindow W; % Back to the window we originally had. end; |
Added psl-1983/emode/misc-emode.sl version [514e6a3cc7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MISC-EMODE.SL - Miscellaneous EMODE routines % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 29 July 1982 % Copyright (c) 1982 University of Utah % % Get a "command" (lisp expression) and "execute" (evaluate) it. % This routine is meant to be bound to the M-X key. (de execute_command () (let ((old-channels (save-important-channels))) (SelectEmodeChannels) % Do we need some sort of ErrorSet here? (eval (read_from_string (prompt_for_string "M-X " NIL))) (restore-important-channels old-channels))) % Insert the next character "typed". (de InsertNextCharacter () (InsertCharacter (GetNextCommandCharacter))) % Display a list of all the buffers known to EMODE. % This needs to be redone to fit better with current window/virtual screen % package. (de PrintBufferNames () (let ((old-channels (save-important-channels))) % Make sure that output goes to "EMODE output" channel. (SelectEmodeChannels) (for (in buffer-name BufferNames) (do % car gives name of (name . environment) pair. (prin2t (car buffer-name)))) (restore-important-channels old-channels))) % Return a list of the current "important" channel bindings. (de save-important-channels () (list STDIN* STDOUT* ErrOut*)) % "Restore" the channels saved by save-important-channels. (de restore-important-channels (saved-channels) (progn (setf STDIN* (car saved-channels)) (setf STDOUT* (cadr saved-channels)) (setf ErrOut* (caddr saved-channels)) (RDS STDIN*) (WRS STDOUT*))) |
Added psl-1983/emode/move-strings.red version [db63c63dee].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MOVE-STRINGS.RED - "Fast" string copying utilities. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % Utilities for moving subranges of strings around (and other related % operations). Written in SysLisp for speed. (Modeled after % PI:STRING-OPS.RED and PI:COPIERS.RED.) % Equivalent routines for vectors should be added (one of these days). on SysLisp; syslsp procedure MoveSubstringToFrom(DestString, SourceString, DestIndex, SourceIndex, SubrangeLength); % Quite a few arguments there, but should be clear enough? Returns the % modified destination string. % WARNING--this version screws up when destination and source overlap % (movement of one subrange of a string to another subrange of the same % string.) begin scalar rawsrc, rawdst, isrc, idst, maxindx, len, i; isrc := IntInf SourceIndex; idst := IntInf DestIndex; rawsrc := StrInf SourceString; rawdst := StrInf DestString; len := IntInf SubrangeLength; % Get upper bound on how far to copy--don't go past end of destination % or source, or subrange. % We want (i + idst) <= StrLen rawdst AND (i + isrc) <= StrLen rawsrc % AND i < SubrangeLength. (Strictly less than SubrangeLength, since i % starts at 0.) maxindx is the appropriate bound on i. maxindx := (StrLen rawdst) - idst; if maxindx >= len then maxindx := len-1; if maxindx > (StrLen rawsrc) - isrc then maxindx := (StrLen rawsrc) - isrc; i := 0; loop: % if we've run out of stuff, quit. if i > maxindx then goto loopex; % Otherwise, copy the string. StrByt(rawdst, i + idst) := StrByt(rawsrc, i + isrc); i := i+1; goto loop; loopex: return DestString; end; syslsp procedure FillSubstring(DestString, DestIndex, SubrangeLength, chr); % Fill a subrange of a string with a character code. begin scalar rawdst, rawchr, idst,len, maxindx, i; idst := IntInf DestIndex; rawdst := StrInf DestString; rawchr := IntInf chr; len := IntInf SubrangeLength; maxindx := StrLen rawdst; if maxindx >= len then maxindx := len-1; i := 0; loop: % if we've run out of stuff, quit. if i > maxindx then goto loopex; % Copy the character into the destination. StrByt(rawdst, i + idst) := rawchr; i := i+1; goto loop; loopex: return DestString; end; off SysLisp; |
Added psl-1983/emode/new-fileio.sl version [3e924ab62b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % New-FileIO.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 30 July 1982 % % Revised File I/O for EMODE. % % The combination of buffered file input and string-oriented reading of the % file into the buffer makes for a 5X improvement in the speed of reading a % nontrivial file (or more, since it no longer does unnecessary consing). % In addition, the ^Z EOF bug has been fixed. % % A similar speedup has been made to file output. In addition, an extra % blank line is no longer written at the end of each file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (load input-stream output-stream fast-vector) (de readfile (file-name) (write-prompt "") (let* ((p (ErrorSet (List 'open-input file-name) NIL NIL)) ) (if (PairP p) (read-file-into-buffer (car p)) (write-prompt (BldMsg "Unable to read file: %w" file-name)) (Ding) ))) (de read-file-into-buffer (s) (write-prompt (BldMsg "Reading file: %w" (=> s file-name))) (setf CurrentBufferText (MkVect 1)) (setf CurrentBufferSize 1) (append-file-to-buffer s) (=> s close) (write-prompt (BldMsg "File read: %w (%d lines)" (=> s file-name) (current-buffer-visible-size))) ) (de append-file-to-buffer (s) (prog (line-buffer line-size ch) (setf line-buffer (MkString 200 0)) (while T (setf line-size 0) (setf ch (input-stream$getc s)) (while (not (or (null ch) (WEq ch (char EOL)))) (if (WGreaterP line-size (ISizeS line-buffer)) (setf line-buffer (concat line-buffer (Mkstring 200 0))) ) (iputs line-buffer line-size ch) (setf line-size (WPlus2 line-size 1)) (setf ch (input-stream$getc s)) ) (if (not (and (null ch) (WEq line-size 0))) (append-line-to-buffer (sub line-buffer 0 (WDifference line-size 1))) ) (cond ((null ch) (if (> line-size 0) (setf CurrentBufferSize (- CurrentBufferSize 1)) ) (exit))) ) (GetLine (setf CurrentLineIndex 0)) )) (de append-line-to-buffer (contents) % Note: GETLINE must be done after a sequence of appends (let ((indx CurrentBufferSize)) (setf CurrentBufferSize (+ CurrentBufferSize 1)) (if (> CurrentBufferSize (size CurrentBufferText)) (setf CurrentBufferText (concat CurrentBufferText (MkVect 63)))) (SetBufferText (- indx 1) contents) (SetBufferText indx "") )) (de WriteFile (file-name) % Write whole of current EMODE buffer to file. (write-prompt "") (let* ((p (ErrorSet (list 'open-output file-name) NIL NIL)) ) (if (PairP p) (let ((s (car p))) (write-prompt (BldMsg "Writing file: %w" (=> s file-name))) (write-buffer-to-stream s) (=> s close) (write-prompt (BldMsg "File written: %w (%d lines)" (=> s file-name) (current-buffer-visible-size))) ) (write-prompt (BldMsg "Unable to write file: %w" file-name)) (Ding) ))) (de write-buffer-to-stream (s) (PutLine CurrentLineIndex) (for (from i 0 (- CurrentBufferSize 2) 1) (do (output-stream$putl s (GetBufferText i))) ) (output-stream$puts s (GetBufferText (- CurrentBufferSize 1))) ) |
Added psl-1983/emode/output-stream.sl version [572420dc69].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Output-Stream.SL (TOPS-20 Version) - File Output Stream Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 29 July 1982 % % This package is 6.7 times faster than the standard unbuffered I/O. % (Using message passing, it is only 1.9 times faster.) % % Note: this code will only run COMPILED. % % See TESTING code at the end of this file for examples of use. % Be sure to include "(CompileTime (load objects))" at the beginning % of any file that uses this package. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects jsys)) (defun open-output (file-name) (let ((s (make-instance 'output-stream))) (=> s open file-name) s)) (defun open-append (file-name) (let ((s (make-instance 'output-stream))) (=> s open-append file-name) s)) %(CompileTime (setq *pgwd t)) (CompileTime (setq FILE-BUFFER-SIZE (* 5 512))) (defflavor output-stream ((jfn NIL) % TOPS-20 file number ptr % "pointer" to next free slot in buffer file-name % full name of actual file buffer % output buffer ) () (gettable-instance-variables file-name) ) (CompileTime (put 'sout 'OpenCode '((jsys 43) (move (reg 1) (reg 3))))) (CompileTime (put 'closf 'OpenCode '((jsys 18) (move (reg 1) (reg 1))))) (defmethod (output-stream putc) (ch) % Append the character CH to the file. Line termination % is indicated by writing a single NEWLINE (LF) character. (if (WEq ch (char lf)) (output-stream$put-newline self) (iputs buffer ptr ch) (if (WGEQ (setf ptr (wplus2 ptr 1)) #.FILE-BUFFER-SIZE) (output-stream$flush self)) )) % The above function was coded to produce good compiled code % using the current PSL compiler. Here's the output. Note % that no stack variables are used. The main path uses 16 % instructions. % (*ENTRY OUTPUT-STREAM$PUTC EXPR 2) % (MOVE (REG 4) (REG 1)) % (CAIE (REG 2) 10) % (JRST G0004) % (JRST (ENTRY OUTPUT-STREAM$PUT-NEWLINE)) % G0004 (MOVE (REG 3) (REG 2)) % (MOVE (REG 2) (INDEXED (REG 1) 5)) % (MOVE (REG 1) (INDEXED (REG 1) 4)) % (AOS (REG 1)) % (ADJBP (REG 2) "L0008") % (DPB (REG 3) (REG 2)) % (MOVE (REG 1) (INDEXED (REG 4) 5)) % (AOS (REG 1)) % (MOVEM (REG 1) (INDEXED (REG 4) 5)) % (CAIGE (REG 1) 2560) % (JRST G0007) % (MOVE (REG 1) (REG 4)) % (JRST (ENTRY OUTPUT-STREAM$FLUSH)) % G0007 (MOVE (REG 1) (REG NIL)) % (POPJ (REG ST) 0) % L0008 (FULLWORD (FIELDPOINTER (INDEXED (REG 1) 0) 0 7)) (defmethod (output-stream put-newline) () % Output a line terminator. (iputs buffer ptr (char cr)) (if (WGEQ (setf ptr (wplus2 ptr 1)) #.FILE-BUFFER-SIZE) (output-stream$flush self)) (iputs buffer ptr (char lf)) (if (WGEQ (setf ptr (wplus2 ptr 1)) #.FILE-BUFFER-SIZE) (output-stream$flush self)) ) (defmethod (output-stream puts) (str) % Write string to output stream (highly optimized!) (let ((i 0) (high (isizes str)) ) (while (WLEQ i high) (iputs buffer ptr (igets str i)) (if (WGEQ (setf ptr (wplus2 ptr 1)) #.FILE-BUFFER-SIZE) (output-stream$flush self)) (setq i (WPlus2 i 1)) ))) (defmethod (output-stream putl) (str) % Write string followed by line terminator to output stream. (output-stream$puts self str) (output-stream$put-newline self) ) (defmethod (output-stream open) (name-of-file) % Open the specified file for output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (output-stream$close self)) (setf buffer (MkString #.FILE-BUFFER-SIZE (char space))) (setf ptr 0) (setf jfn (Dec20Open name-of-file (int2sys 2#100000000000000001000000000000000000) (int2sys 2#000111000000000000001000000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Output" name-of-file) name-of-file)) (setf file-name (MkString 200 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 #.(get 'jsJFNS 'NewNam)) (setf file-name (recopystringtonull file-name)) )) (defmethod (output-stream open-append) (name-of-file) % Open the specified file for append output via SELF. If the file cannot % be opened, a Continuable Error is generated. (if jfn (output-stream$close self)) (setf buffer (MkString #.FILE-BUFFER-SIZE (char space))) (setf ptr 0) (setf jfn (Dec20Open name-of-file (int2sys 2#000000000000000001000000000000000000) (int2sys 2#000111000000000000000010000000000000) )) (if (= jfn 0) (setf jfn NIL)) (if (null JFN) (=> self open (ContinuableError 0 (BldMsg "Unable to Open '%w' for Append" name-of-file) name-of-file)) (setf file-name (MkString 200 (char space))) (jsys1 file-name jfn #.(bits 2 5 8 11 14 35) 0 #.(get 'jsJFNS 'NewNam)) (setf file-name (recopystringtonull file-name)) )) (defmethod (output-stream close) () (if jfn (progn (output-stream$flush self) (closf jfn) (setf jfn NIL) (setf buffer NIL) ))) (defmethod (output-stream flush) () (if (WGreaterP ptr 0) (progn (sout jfn (jconv buffer) (WDifference 0 ptr)) (setf ptr 0) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TESTING CODE %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (setq time-output-test-string "This is a line of text for testing.")) (CommentOutCode (progn (de time-buffered-output (n-lines) % This is the FAST way to do buffered output. (setq start-time (time)) (setq s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (output-stream$putc s ch)) ) (output-stream$put-newline s) )) (=> s close) (- (time) start-time) ) (de time-buffered-output-1 (n-lines) % This is the SLOW (but GENERAL) way to do buffered output. (setq start-time (time)) (setq s (open-output "test.output")) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (=> s putc ch)) ) (=> s put-newline) )) (=> s close) (- (time) start-time) ) (de time-standard-output (n-lines) (setq start-time (time)) (setq chan (open "test.output" 'OUTPUT)) (for (from i 1 n-lines 1) (do (for (in ch '#.(String2List time-output-test-string)) (do (ChannelWriteChar chan ch)) ) (ChannelWriteChar chan (char lf)) )) (close chan) (- (time) start-time) ) (de time-output (n-lines) (list (time-buffered-output-string n-lines) (time-buffered-output n-lines) (time-buffered-output-1 n-lines) (time-standard-output n-lines) )) (de time-buffered-output-string (n-lines) % This is the FAST way to do buffered output from strings. (setq start-time (time)) (setq s (open-output "test.output")) (for (from i 1 n-lines 1) (do (output-stream$putl s #.time-output-test-string)) ) (=> s close) (- (time) start-time) ) )) % End CommentOutCode |
Added psl-1983/emode/prompting.sl version [2915716e42].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROMPTING.SL - "Prompting" utilities for EMODE. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 July 1982 % Copyright (c) 1982 University of Utah % % This file provides functions for prompting the user for information, and % for general maintenance of the "MODE", "PROMPT", and "MESSAGE" windows. %%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AS 7/16/82 % - Delay prompting for single character input. (FLUID '(previous_window % This needs to be rethought! prompt-immediately % T => prompt_for_character always prompts prompt-was-output % T => prompt_for_character prompted last time )) (setq prompt-immediately NIL) (setq prompt-was-output NIL) (de prompt_for_character (prompt_string) % Prompt for (and echo) a single character. Avoid prompting if the user has % already typed a character or types a character right away. The fluid % variables PROMPT-IMMEDIATELY and PROMPT-WAS-OUTPUT are used to implement % sequences of prompts, as done by C-U (for example). Within a sequence of % related prompts, once a prompt is output, further prompting should be done % immediately. % Echo handling needs to do better job of handling control characters, etc. % First check whether a character is typed quickly. If it is, then % return it directly without echoing anything. (if (not prompt-immediately) (sleep-until-timeout-or-input 30)) (setq prompt-was-output (or prompt-immediately (= (CharsInInputBuffer) 0))) (if (not prompt-was-output) (GetNextCommandCharacter) % else (show_prompt prompt_string) % Setup & select the prompt window. (let ((ch (GetNextCommandCharacter))) (cond ((MetaP ch) (insert_string "M-") (InsertCharacter (UnMeta ch))) (T (InsertCharacter ch))) (SelectWindow previous_window) % Go back to old window. ch ))) % Prompt for a string (terminated by newline). Use default_string if an % empty string is returned, (and if default_string is non-NIL). (de prompt_for_string (prompt_string default_string) (prog (return_string old-msg-string) % Show the default, if non-NIL. (cond (default_string (setf old-msg-string (show_message (concat "Default is: " default_string))))) % Show the prompt string, and select the "prompt window" (and buffer). (show_prompt prompt_string) % Set up mode to pick up a single line of text. (setf ModeEstablishExpressions '((setup_insert_single_line_mode))) (EstablishCurrentMode) % Edit the buffer until an "exit" character is typed. (EMODEdispatchLoop) % Pick up the string that was typed. (setf return_string (GetBufferText CurrentLineIndex)) % Switch back to old window, etc. (SelectWindow previous_window) % Restore original "message window label", if it was "hammered". % Important to do this AFTER (SelectWindow previous_window) (cond (default_string (show_message old-msg-string))) (EstablishCurrentMode) % If an empty string, use default (unless it's NIL). (cond ((and default_string (equal return_string "")) (setf return_string default_string))) (return return_string))) % Define a mode for editing a single line of text. Nearly identical to text % mode. (No 100% guarantee that a single line is all that will be put into % the buffer, since it's possible to yank back text from the kill buffer, % for example.) (de setup_insert_single_line_mode () (progn (for (from i 0 31 1) (do (setf (indx MainDispatch i) 'leave_dispatch_loop))) (for (from i 127 255 1) (do (setf (indx MainDispatch i) 'leave_dispatch_loop))) % "Normal characters" insert themselves. (for (from i 32 126 1) (do (MakeSelfInserting i))) (MakeSelfInserting (char TAB)) % It would be nice to add some of these folks who are stolen from % BasicDispatchSetup. BUT, they screw up because they invoke % prompt_for_character (or some such), which typically will try to grab % the same window that this mode is invoked in causing bad confusion. % We need a better method (or philosphy) for doing this. % (SetKey (char ESC) 'EscapeAsMeta) % (SetKey (char (cntrl Z)) 'DoControlMeta) % Make right paren "bounce" to matching left paren. (SetKey (char '!) ) 'insert_matching_paren) % Other reasonable (??) commands for editing within the line. Includes % most of the features of text mode. (SetKey (char (cntrl '!@)) 'SetMark) (SetKey (char (cntrl A)) '!$BeginningOfLine) (SetKey (char (cntrl B)) '!$BackwardCharacter) (SetKey (char (cntrl D)) '!$DeleteForwardCharacter) (SetKey (char (cntrl E)) '!$EndOfLine) (SetKey (char (cntrl F)) '!$ForwardCharacter) (SetKey (char DELETE) '!$DeleteBackwardCharacter) (SetKey (char (cntrl K)) 'kill_line) (SetKey (char (cntrl T)) 'transpose_characters) (SetKey (char (cntrl Y)) 'insert_kill_buffer) (SetKey (char (meta (cntrl B))) 'backward_sexpr) (SetKey (char (meta (cntrl F))) 'forward_sexpr) (SetKey (char (meta (cntrl K))) 'kill_forward_sexpr) (SetKey (char (meta (cntrl RUBOUT))) 'kill_backward_sexpr) (SetKey (char (meta B)) 'backward_word) (SetKey (char (meta D)) 'kill_forward_word) (SetKey (char (meta F)) 'forward_word) (SetKey (char (meta W)) 'copy_region) (SetKey (char (meta Y)) 'unkill_previous) (SetKey (char (meta DELETE)) 'kill_backward_word) (SetKey (CharSequence (cntrl X) (cntrl X)) 'ExchangePointAndMark))) % Setup and select the prompt window, "remember" the old window in Fluid % "previous_window". (de show_prompt (prompt_string) (string_in_window prompt_string prompt_window)) % Display a string in the "message" window, return the previous label % string for that window. (de show_message (strng) (prog (old-label) (setf old-label (string_in_window strng message_window)) % Don't stay in message window. (SelectWindow previous_window) % Refresh in order to update the cursor position (optional_refresh) (return old-label))) % "Pop up" and select a window (typically one-line and unframed). Use % "strng" to label the window, clear out the associated buffer, return the % old label string. "Remember" the previous window in fluid previous_window. (de string_in_window (strng window) (prog (old-label) (setf previous_window CurrentWindowDescriptor) (SelectWindow window) (!$DeleteBuffer) % Kill everything in the buffer % Save the old label and then put strng into the per-(unframed)window % "label" variable. (setf old-label window_label) (setf window_label strng) (optional_refresh) % Let the user see it! (return old-label))) |
Added psl-1983/emode/query-replace.sl version [abf711c986].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % QUERY-REPLACE.SL - Query/Replace command for EMODE % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % % This file implements a query-replace command. % Modifications by William Galway: % "defun" -> "de" so TAGS can find things. % "setq" -> "setf" % This file requires COMMON, RING-BUFFER, BUFFER-POSITION. (fluid '(CurrentLineIndex point CurrentWindowDescriptor Prompt_Window last_search_string)) (de query-replace-command () (let* ((ask t) ch pattern replacement (pausing nil) (pause-message "Command?") (normal-message "Replace?") (help-message "Replace? SPACE:yes RUBOUT:no ESC:exit .:yes&exit ,:yes&show !:do all ^:back") (pause-help-message "Command? SPACE:go on ESC:exit !:do all ^:back") (message normal-message) (ring-buffer (ring-buffer-create 16)) ) % Get string to replace. Default is last search string (but don't % bother to update the default search string. (??)) (setf pattern (prompt_for_string "Query Replace (string to replace): " last_search_string )) % Clear out the "default search string" message. (show_message "") (setf replacement (prompt_for_string "Replace string with: " NIL)) (write-prompt "") (while (or pausing (buffer_search pattern 1)) (if ask (progn (if (not pausing) (ring-buffer-push ring-buffer (buffer-get-position))) (show_message message) (setf ch (GetNextCommandCharacter)) (show_message "")) (setf ch (char space))) (if pausing (selectq ch ((#.(char space) #.(char rubout) #/,) (setf pausing nil)) (#/! (setf ask nil) (setf pausing nil)) ((#.(char escape) #/.) (exit)) (#.(char ff) (FullRefresh)) (#/^ (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer))) (#/? (setf message pause-help-message) (next)) (t (ding)) ) (selectq ch (#.(char space) (do-string-replacement pattern replacement)) (#/, (do-string-replacement pattern replacement) (setf pausing t)) (#.(char rubout) (advance-over-string pattern)) (#/! (do-string-replacement pattern replacement) (setf ask nil)) (#/. (do-string-replacement pattern replacement) (exit)) (#/? (setf message help-message) (next)) (#.(char escape) (exit)) (#.(char ff) (FullRefresh)) (#/^ (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer)) (setf pausing t)) (t (ding)) ) ) (setf message (if pausing pause-message normal-message)) ) % Show we're done in the prompt window (to avoid "harming" message in % the message window). (write-prompt "Query Replace Done.") )) (de do-string-replacement (pattern replacement) % Both PATTERN and REPLACEMENT must be single line strings. % PATTERN is assumed to be in the current buffer beginning at POINT. % It is deleted and replaced with REPLACEMENT. % POINT is left pointing just past the inserted text. (let ((pattern-length (add1 (size pattern)))) (delete_or_copy T CurrentLineIndex point CurrentLineIndex (+ point pattern-length)) (insert_string replacement) )) (de advance-over-string (pattern) % PATTERN must be a single line string. % PATTERN is assumed to be in the current buffer beginning at POINT. % POINT is advanced past PATTERN. (let ((pattern-length (add1 (size pattern)))) (setf point (+ point pattern-length)) )) % "Write a string" into the prompt window (but don't select the prompt % window). (de write-prompt (string) (let ((old-window CurrentWindowDescriptor)) % Show the string and select the window. (show_prompt string) % Back to original window. (SelectWindow old-window))) |
Added psl-1983/emode/rawio.red version [45a78adf61].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % RAWIO.RED - Support routines for PSL Emode % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981, 1982 University of Utah % Modified and maintained by William F. Galway. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DEC-20 version FLUID '(!*rawio); % T if terminal is using "raw" i.o. CompileTime << load if!-system; load syslisp$ off UserMode; % csp 8/20/82 if_system(Dec20, << load monsym$ load jsys$ >>) >>; BothTimes if_system(Dec20, % CompileTime probably suffices. << FLUID '( % Global? OldCCOCWords OldTIW OldJFNModeWord ); lisp procedure BITS1 U; if not NumberP U then Error(99, "Non-numeric argument to BITS") else lsh(1, 35 - U); macro procedure BITS U; begin scalar V; V := 0; for each X in cdr U do V := lor(V, BITS1 X); return V; end; >>); LoadTime if_system(Dec20, << OldJfnModeWord := NIL; % Flag "modes not saved yet" lap '((!*entry PBIN expr 0) % Read a single character from the TTY as a Lisp integer (pbin) % Issue PBIN (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry PBOUT expr 1) % write a single charcter to the TTY, works for integers and single char IDs % Don't bother with Int2Sys? (pbout) (!*exit 0) ); lap '((!*entry CharsInInputBuffer expr 0) % Returns the number of characters in the terminal input buffer. (!*MOVE (WConst 8#101) (reg 1)) % The input file (the terminal, = % 8#101) (sibe) % skip if input buffer empty (skipa (reg 1) (reg 2)) % otherwise # chars in r2 (setz (reg 1) 0) % if skipped, then zero (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry RFMOD expr 1) % returns the JFN mode word as Lisp integer (hrrzs (reg 1)) (rfmod) (!*MOVE (reg 2) (reg 1)) % Get mode word from R2 (!*CALL Sys2Int) (!*exit 0) ); lap '((!*entry RFCOC expr 1) % returns the 2 CCOC words for JFN as dotted pair of Lisp integers (hrrzs (reg 1)) (rfcoc) (!*PUSH (reg 2)) % save the first word (!*MOVE (reg 3) (reg 1)) (!*CALL Sys2Int) % make second into number (exch (reg 1) (indexed (reg st) 0)) % grab first word, save % tagged 2nd word. (!*CALL Sys2Int) % make first into number (!*POP (reg 2)) (!*JCALL Cons) % and cons them together ); lap '((!*entry RTIW expr 1) % Returns terminal interrupt word for specified process, or -5 for entire job, % as Lisp integer (hrrzs (reg 1)) % strip tag (rtiw) (!*MOVE (reg 2) (reg 1)) % result in r2, return in r1 (!*JCALL Sys2Int) % return as Lisp integer ); lisp procedure SaveInitialTerminalModes(); % Save the terminal modes, if not already saved. if null OldJfnModeWord then << OldJFNModeWord := RFMOD(8#101); OldCCOCWords := RFCOC(8#101); OldTIW := RTIW(-5); >>; lap '((!*entry SFMOD expr 2) % SFMOD(JFN, ModeWord); % set program related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (sfmod) (!*exit 0) ); lap '((!*entry STPAR expr 2) % STPAR(JFN, ModeWord); % set device related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stpar) (!*exit 0) ); lap '((!*entry SFCOC expr 3) % SFCOC(JFN, CCOCWord1, CCOCWord2); % set control character output control for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*PUSH (reg 3)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (exch (reg 1) (indexed (reg st) 0)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (sfcoc) (!*exit 0) ); lap '((!*entry STIW expr 2) % STIW(JFN, ModeWord); % set terminal interrupt word for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stiw) (!*exit 0) ); lisp procedure EchoOff(); % A bit of a misnomer, perhaps "on_rawio" would be better. % Off echo, On formfeed, send all control characters % Allow input of 8-bit characters (meta key) if not !*rawio then % Avoid doing anything if already "raw mode" << SaveInitialTerminalModes(); % Note that 8#101, means "the terminal". % Clear bit 24 to turn echo off, % bits 28,29 turn off "translation" SFMOD(8#101, LAND(OldJFNModeWord, LNOT BITS(24, 28, 29))); % Set bit 0 to indicate "has mechanical tab" (so cntrl-L gets % through?). % Clear bit 34 to turn off cntrl-S/cntrl-Q STPAR(8#101, LAND(lor(OldJFNModeWord, BITS 1), LNOT BITS(34))); % More nonsense to turn off processing of control characters? SFCOC(8#101, LNOT(8#252525252525), LNOT(8#252525252525)); % Turn off terminal interrupts for entire job (-5), for everything % except cntrl-C (the bit number three that's one). STIW(-5,8#040000000000); !*rawio := T; % Turn on flag >>; lisp procedure EchoOn(); % Restore initial terminal echoing modes << % Avoid doing anything if OldJFNModeWord is NIL, means terminal mode % already "restored". if OldJFNModeWord then << SFMOD(8#101,OldJFNModeWord); STPAR(8#101,OldJFNModeWord); SFCOC(8#101,car OldCCOCWords,cdr OldCCOCWords); STIW(-5,OldTIW); >>; % Set to NIL so that things get saved again by % SaveInitialTerminalModes. (The terminal status may have been changed % between times.) OldJFNModeWord := NIL; !*rawio := NIL; % Indicate "cooked" i/o. >>; % Flush output buffer for stdoutput. (On theory that we're using buffered % I/O to speed things up.) Symbolic Procedure FlushStdOutputBuffer(); NIL; % Just a dummy routine for the 20. >> ); % END OF DEC-20 version. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % VAX Unix version LoadTime if_system(Unix, << % EchoOn, EchoOff, and CharsInInputBuffer are part of "kernel". Symbolic Procedure PBIN(); % Read a "raw character". NOTE--assumption that 0 gives terminal input. VaxReadChar(0); % Just call this with "raw mode" on. Symbolic Procedure PBOUT(chr); % NOTE ASSUMPTION that 1 gives terminal output. VaxWriteChar(1,chr); >>); % END OF Unix version. fluid '(!*EMODE); LoadTime << !*EMODE := NIL; Symbolic Procedure rawio_break(); % Redefined break handler to turn echoes back on after a break, unless % EMODE is running. << if !*rawio and not !*EMODE then EchoOn(); pre_rawio_break(); % May want to be paranoid and use a "catch(nil, % '(pre_rawio_break)" here. >>; % Carefully redefine the break handler. if null getd('pre_rawio_break) then << CopyD('pre_rawio_break, 'Break); CopyD('break, 'rawio_break); >>; >>; |
Added psl-1983/emode/refresh.red version [ae237d31b9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % REFRESH.RED - Screen/Window/Refresh utilities for EMODE. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % Uses the "virtual-screen" package in VIRTUAL-SCREEN.SL. FLUID '( ShiftDisplayColumn % Amount to shift things to the left by % before (re)displaying lines. WindowList % List of active windows minor_window_list % List of windows to be ignored by the % "next_window" routine. pos_for_line_refresh % Offsets into virtual screen, adjusted depending on whether screen is % framed, labled, etc. row_offset column_offset ); % pos_for_line_refresh is kept around so that we don't have to keep consing % up new coordinate pairs--an efficiency hack. '(NIL . NIL) may cause % problems on Vax (when we do RPLACA/RPLACD), since it goes to "pure % space"? pos_for_line_refresh := cons(NIL , NIL); ShiftDisplayColumn := 0; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Construct a screen coordinate pair (x,y) = (column,row) Symbolic Procedure Coords(col,rw); Cons(col,rw); Symbolic Procedure Column pos; %. X-coordinate (Column) car pos; Symbolic Procedure Row pos; %. Y-coordinate (Row) cdr pos; % Note: All regions defined in terms of Lower Corner (base) and distance % (delta values) to other corner INCLUSIVE, using 0-origin system. % Thus 0..3 has base 0, delta 3 % 1..4 has base 1, delta 3 Symbolic Procedure FrameScreen(scrn); % Generate a border for a screen. << % Dashes for top and bottom rows. for i := 0:VirtualScreenWidth(scrn) do << WriteToScreen(scrn, char !-, 0, i); WriteToScreen(scrn, char !-, VirtualScreenHeight(scrn), i); >>; % Vertical bars for the left and right sides. for i := 0:VirtualScreenHeight(scrn) do << WriteToScreen(scrn, char !|, i, 0); WriteToScreen(scrn, char !|, i, VirtualScreenWidth(scrn)); >>; % Finally, put plus signs in the corners. WriteToScreen(scrn, char !+, 0, 0); WriteToScreen(scrn, char !+, 0, VirtualScreenWidth(scrn)); WriteToScreen(scrn, char !+, VirtualScreenHeight(scrn), 0); WriteToScreen(scrn, char !+, VirtualScreenHeight(scrn), VirtualScreenWidth(scrn)); >>; Symbolic Procedure FramedWindowDescriptor(BufferName, upperleft, dxdy); % Create a "descriptor" for a "framed window" (into a text buffer), given % its associated buffer name, coord. of upper left corner, and its size as % (Delta X, Delta Y). begin scalar WindowDescriptor, newscreen; % The virtual screen includes room for a border around the edges. % (Add one to dimensions, to compensate for 0 indexing.) newscreen := CreateVirtualScreen(1 + Row dxdy, 1 + Column dxdy, Row upperleft, Column upperleft); % Generate the border. FrameScreen(newscreen); WindowDescriptor := list( % The refresh routine to use. 'windows_refresher . 'refresh_framed_window, 'WindowsBufferName . BufferName, % Associated Buffer % Routine to "throw away" the current view. 'views_cleanup_routine . 'cleanup_text_view, % Dimensions, (delta x . delta y), chop off a bit for the % frames. (Remember the 0 indexing! ) 'CurrentWindowDelta . ( (Column(dxdy) - 2) . (Row(dxdy) - 2) ), % "Window image" information for refresh. % Note that Row dxdy = number of lines minus 1 % (since it is an INCLUSIVE value). Each entry in NLIST gives % info on (Horizontal scroll . line in buffer) 'Window_Image . % ShiftdisplayColumn better than 0 here? Nlist(Row(dxdy)+1, '(0 . NIL)), % The last "buffer name" that was shown in the label, this can % change if the window starts looking into another buffer. 'LABEL_BufferName . NIL, % The filename associated with this window's buffer (at last % refresh). 'last_filename . NIL, % Value of CurrentLineIndex during last refresh. 'Last_LineIndex . 0, % Size of buffer (number of lines) during last refresh. 'Last_BufferSize . 0, 'CurrentVirtualScreen . newscreen, 'ShiftDisplayColumn . 0, % Horizontal Scroll value % Location in buffer that corresponds to top line in window. % Zero is rather implausible if "point" is somewhere in the % middle of the buffer, but that's OK since it gets adjusted to % the right value. 'TopOfDisplayIndex . 0 ); return WindowDescriptor; end; Symbolic Procedure UnframedWindowDescriptor(BufferName, upperleft, dxdy); % Create a "descriptor" for an "unframed window", given its % associated buffer name, coord. of upper left corner, and its size as % (Delta X, Delta Y). (This version is really meant for one line windows % only, results may be quite wierd otherwise.) begin scalar WindowDescriptor, newscreen; % The associated virtual screen ... % (Add one to dimensions, to compensate for 0 indexing.) newscreen := CreateVirtualScreen(1 + Row dxdy, 1 + Column dxdy, Row upperleft, Column upperleft); WindowDescriptor := list( % The refresh routine to use. 'windows_refresher . 'refresh_unframed_window, 'WindowsBufferName . BufferName, % Associated Buffer 'views_cleanup_routine . 'cleanup_text_view, % A "label" to appear at the beginning line of the window. 'window_label . "", % Value of window_label at last refresh, make it differ from % window_label to force initial refresh of label. 'old_window_label . NIL, % Window dimensions as (delta x . delta y). 'CurrentWindowDelta . ( (Column dxdy) . (Row dxdy) ), % "Window image" information for refresh. % Note that Row dxdy = number of lines minus 1 % (since it is an INCLUSIVE value). Each entry in NLIST gives % info on (Horizontal scroll . line in buffer) 'Window_Image . % ShiftdisplayColumn better than 0 here? Nlist(Row(dxdy)+1, '(0 . NIL)), 'CurrentVirtualScreen . newscreen, 'ShiftDisplayColumn . 0, % Horizontal Scroll value % Location in buffer that corresponds to top line in window. % Zero is rather implausible if "point" is somewhere in the % middle of the buffer, but that's OK since it gets adjusted to % the right value. 'TopOfDisplayIndex . 0 ); return WindowDescriptor; end; fluid '(Prompt_Window Message_Window); Symbolic Procedure OneWindow(); % Dispatch to this routine to enter one-window mode. if MajorWindowCount() neq 1 then % If not already one-window % then setup windows for one window mode. begin scalar old_prompt, old_msg, NewWindow ; % Preserve the "prompt" and "message" labels from old windows. old_prompt := if Prompt_Window then cdr atsoc('window_label, Prompt_Window); old_msg := if Message_Window then cdr atsoc('window_label, Message_Window); Setup_Windows list( % This window looks into the current buffer, other arguments % are location of upper left corner, and the size (0 % indexed). % The window is made slightly wider than the screen, so that % the left and right frame boundaries don't actually show. NewWindow := FramedWindowDescriptor(CurrentBufferName, % Upper left corner coords(Column ScreenBase - 1, Row ScreenBase - 1), % Size uses entire width, leaves room for % two one line windows at the bottom Coords(Column ScreenDelta + 2, Row(ScreenDelta) - 1)), % Looks into the "prompt line" buffer. Note this is % unframed, so we make it a bit smaller to have it all fit on % the screen. Prompt_Window := UnframedWindowDescriptor('PROMPT_BUFFER, % Base is one line above bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta - 1), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Looks into the "message buffer", used for error messages % and general stuff. Message_Window := UnframedWindowDescriptor('MESSAGE_BUFFER, % Base is at bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)) ); % Restore the labels from their old values (if any). SelectWindowContext(Prompt_Window); window_label := old_prompt; SelectWindowContext(Message_Window); window_label := old_msg; % Keep track of "minor windows". minor_window_list := list(Prompt_Window, Message_Window); SelectWindow NewWindow; % ??? needs more thought. end; Symbolic Procedure MajorWindowCount(); % Return a count of the "major windows" in WindowList; length(WindowList) - length(minor_window_list); Symbolic Procedure next_window(); % Dispatch to this routine to select "the next" (or "other") window begin scalar current_window_pointer; current_window_pointer := WindowList; % Look up the location of the current window in WindowList. while not((car current_window_pointer) eq CurrentWindowDescriptor) do current_window_pointer := cdr current_window_pointer; SelectWindow next_major_window(cdr(current_window_pointer), WindowList); end; Symbolic Procedure previous_window_command(); % Dispatch to this routine to select the "previous" window. begin scalar current_window_pointer, rev_windowlist; rev_windowlist := reverse WindowList; current_window_pointer := rev_windowlist; % Look up the location of the current window in WindowList. while not((car current_window_pointer) eq CurrentWindowDescriptor) do current_window_pointer := cdr current_window_pointer; SelectWindow next_major_window(cdr(current_window_pointer), rev_windowlist); end; Symbolic Procedure next_major_window(pntr, wlist); % Return the window descriptor for the next "major" window at or after pntr % in wlist. It's assumed that there is at least one major window. if null pntr then next_major_window(wlist,wlist) else if not MemQ(car pntr, minor_window_list) then car pntr else next_major_window(cdr pntr, wlist); % Return T if the buffer is present in some "active" window (not % necessarily visible, it may be covered up). Symbolic Procedure Buffer_VisibleP(BufferName); begin scalar result, Wlist; Wlist := WindowList; while Wlist and null(result) do << result := cdr(atsoc('WindowsBufferName, car Wlist)) eq BufferName; Wlist := cdr Wlist; >>; return result; end; Symbolic Procedure Setup_Windows(WindowDescriptorList); % (Re)build the list of currently active windows. << % Get rid of the old virtual screens first. for each WindowDescriptor in WindowList do DeselectScreen cdr atsoc('CurrentVirtualScreen, WindowDescriptor); CurrentWindowDescriptor := NIL; WindowList := NIL; for each WindowDescriptor in WindowDescriptorList do SelectWindow WindowDescriptor; >>; Symbolic Procedure SelectWindow(WindowDescriptor); % Select a window's "context", and also put it on top of the screen. << SelectWindowContext(WindowDescriptor); SelectScreen(CurrentVirtualScreen); >>; Symbolic Procedure SelectWindowContext(WindowDescriptor); % Select a new window context (environment)--add it to the list of active % windows if not already present. begin % Should this (putting onto active WindowList) be part of % "SelectWindow" instead of "SelectWindowContext"? if null( MemQ(WindowDescriptor, WindowList)) then WindowList := WindowDescriptor . WindowList; if CurrentWindowDescriptor then DeselectCurrentWindow(); RestoreEnv WindowDescriptor; % Additional cleanup after "restoring" environment. THIS IS A KLUDGE, % NEEDS MORE THOUGHT! Restore the buffer (given its name) SelectBuffer(WindowsBufferName); CurrentWindowDescriptor := WindowDescriptor; end; Symbolic Procedure DeselectCurrentWindow(); % Save current window's environment. Note that this routine does NOT % remove the current window from the list of active windows, nor does it % affect the window's "virtual screen". begin % Do this first! Save current environment. SaveEnv(CurrentWindowDescriptor); if CurrentBufferName then DeSelectBuffer(CurrentBufferName); % Important to do this after! CurrentWindowDescriptor := NIL; end; % Generic version--"clean" current view out of the list of views to be % refreshed. Symbolic Procedure remove_current_view(); << WindowList := DelQIP(CurrentWindowDescriptor, WindowList); apply(views_cleanup_routine, NIL); % Save the current window's environment, not really a "deselect", but % does set CurrentWindowDescriptor to NIL. DeselectCurrentWindow(); >>; % Cleanup a current text "view". Symbolic Procedure cleanup_text_view(); % "Throw away" the view's virtual screen, that should suffice for % cleanup. DeselectScreen CurrentVirtualScreen; Symbolic Procedure CntrlXCscroll(); Begin scalar x; x := OneLispRead("Column (left/right) Scroll by:"); if numberp x then ShiftDisplayColumn := x; End; Symbolic Procedure SetScreen; % Initialise Screen Space, obviously needs more thought, since it does so % little. << WindowList := NIL; InitializeScreenPackage(); % ??? (Experimental version! ) >>; %. ------------------- Window-Buffer-Screen Refresh --------- Symbolic Procedure WriteScreenPhoto(); % Dispatch to this routine to write a photograph of the screen. May want % to get fancy and copy the screen before prompting for the file name? begin scalar Outchannel; Outchannel := Open(prompt_for_string("File for photo: ", NIL), 'OUTPUT); WriteScreenImage(PhysicalScreenImage, Outchannel); Close Outchannel; end; Symbolic Procedure Refresh(); Begin Scalar SaveW; SaveW := CurrentWindowDescriptor; % Remember the current window. % Refresh all windows in the list for each WindowDescriptor in WindowList do << % Select the window's "context" (per-window variable bindings). SelectWindowContext WindowDescriptor; % Call the per-window refresh algorithm. apply(windows_refresher, NIL); >>; SelectWindowContext SaveW; % Back to "current window" % Refresh up to this point has been to a "physical screen image", now % actually update the physical screen. RefreshPhysicalScreen(T); End; Symbolic Procedure optional_refresh(); % If nothing's waiting in the input buffer then refresh the screen if CharsInInputBuffer() = 0 then Refresh(); Symbolic Procedure refresh_unframed_window(); << row_offset := 0; column_offset := 1 + size(window_label); % Refresh the label first (may clear to end of line). refresh_unframed_label(); % then refresh the text (probably on the same line as label). refresh_text(); >>; Symbolic Procedure refresh_unframed_label(); % Refresh the label for an "unframed window". % NOTE use of EQ test, avoid destructive operations on the label % string since they won't be detected here. if not(window_label eq old_window_label) then << for i := 0:size(window_label) do WriteToScreen(CurrentVirtualScreen, window_label[i], 0,i % Row, column ); % Then, clear to the end of the old label. (Note that old label % can be NIL, in which case the size is -1.) WriteToScreenRange(CurrentVirtualScreen, char BLANK, 0, % Row size(window_label) + 1, % Left margin size(old_window_label) % Right margin ); % "Remember" the new label. old_window_label := window_label; >>; Symbolic Procedure refresh_framed_window(); % Refresh the currently selected "framed window" (into a text buffer). << % Set up offsets to compensate for the frame. row_offset := 1; column_offset := 1; refresh_text(); refresh_frame_label(); >>; Symbolic Procedure refresh_frame_label(); % Refresh the "label line" for the current (framed) window. Note that this % is called on every refresh (typically on every character typed by the % user), so it should avoid doing too much--and should be as incremental as % possible. NOTE: should really be template driven. begin scalar strng, lastcol; % If the name of the current buffer differs from what it used to be... if not(CurrentBufferName eq LABEL_BufferName) then << strng := Id2String CurrentBufferName; for i := 0:size(strng) do % 5 is rather arbitrary point to start ... WriteToScreen(CurrentVirtualScreen, strng[i], VirtualScreenHeight(CurrentVirtualScreen), i+5); % Write dashes to erase any of the old label that might be left. % (Might be better to WriteToScreenRange?) for i := 1+size(strng) : size(Id2String LABEL_BufferName) do WriteToScreen(CurrentVirtualScreen, char '!-, VirtualScreenHeight(CurrentVirtualScreen), i+5); LABEL_BufferName := CurrentBufferName; >>; % Now, refresh the filename associated with this buffer. if not(buffers_file eq last_filename) then << % Note the first free column (roughly speaking) past the name of % the buffer. lastcol := size(Id2String CurrentBufferName)+5; % Write a dash to clear things out. WriteToScreen(CurrentVirtualScreen, char !-, VirtualScreenHeight(CurrentVirtualScreen), lastcol + 1); % Write out the new name, a bit to the right of the buffername, % within square brackets. WriteToScreen(CurrentVirtualScreen, char '![, VirtualScreenHeight(CurrentVirtualScreen), lastcol + 2); % Write out the new filename lastcol := lastcol + 3; for i := 0:size(buffers_file) do WriteToScreen(CurrentVirtualScreen, buffers_file[i], VirtualScreenHeight(CurrentVirtualScreen), i + lastcol); % Hum, rather awkward to constantly keep track of column, anyway, % now write the closing bracket. WriteToScreen(CurrentVirtualScreen, char '!], VirtualScreenHeight(CurrentVirtualScreen), 1 + size(buffers_file) + lastcol); % Finally (?) write out a bunch of dashes to clear any old stuff. % Dashes go out to point where "percentage position" starts. WriteToScreenRange(CurrentVirtualScreen, char !-, VirtualScreenHeight(CurrentVirtualScreen), 2 + size(buffers_file) + lastcol, VirtualScreenWidth(CurrentVirtualScreen) - 7); % "Remember" the filename shown in the label. last_filename := CurrentBufferName; >>; % Now, refresh our "percentage position within buffer" stuff. if Last_BufferSize neq CurrentBufferSize OR Last_LineIndex neq CurrentLineIndex then if CurrentBufferSize >= 0 then << strng := PrintF_into_string(MkString(3,char !-), 0, "%w%%", (100*CurrentLineIndex)/CurrentBufferSize); % Write it into the label line, use "-" for any digits missing. for i := 0:3 do WriteToScreen(CurrentVirtualScreen, strng[i], VirtualScreenHeight(CurrentVirtualScreen), VirtualScreenWidth(CurrentVirtualScreen) - 6 + i); Last_LineIndex := CurrentLineIndex; Last_BufferSize := CurrentBufferSize; >>; end; Symbolic Procedure refresh_text(); % Refresh for both framed and unframed windows into text buffers. begin scalar l,l1,l2; % re-center display if needed AdjustTopOfDisplayIndex(); l1 := TopOfDisplayIndex; l := 0; % start at Virtual row 0; while not EndOfBufferP(l1) and (l <= Row CurrentWindowDelta) do << RefreshLine(l1,l); l := l + 1; l1 := NextIndex(l1); >>; ClearToEndOfWindow(l); % Position the (virtual) cursor at its final location. MoveToScreenLocation( CurrentVirtualScreen, % Row row_offset + CountLinesFrom(TopOfDisplayIndex,CurrentLineIndex), % Column column_offset + LineColumn(Point,CurrentLine)-ShiftDisplayColumn ); end; % Return a list with n NIL's Symbolic Procedure Nils(n); Nlist(n,NIL); % Return a list with n copies of element. Symbolic Procedure Nlist(n,element); If n<=0 then NIL else (copy element) . Nlist(n-1,element); % Return a list of n 0's. Symbolic Procedure Zeroes(n); Nlist(n,0); Symbolic Procedure ClearToEndOfWindow(x); % Clear in the vertical direction, down the window. X gives line number to % start at. begin while x <= Row CurrentWindowDelta do << if not null cdr Window_Image[x] then << % If something is in screen image, clear it and the screen. % Store (current column . no text at all)! in image. Window_Image[x] := ShiftDisplayColumn . NIL; ClearEol(Coords(0,x)); >>; x := x+1; >>; end; Symbolic Procedure ClearEol(x); % Clear to end of line in current window, starting at coordinate x. DisplaySpaces(x, 1 + Column(CurrentWindowDelta) - Column(x)); Symbolic Procedure DisplaySpaces(pos, N); begin scalar VirtualScreenRow, VirtualScreenColumn; % Put N spaces in window, starting at pos. VirtualScreenRow := row_offset + row(pos); VirtualScreenColumn := column_offset + column(pos); WriteToScreenRange(CurrentVirtualScreen, char BLANK, % Character to write VirtualScreenRow, % Row to start at VirtualScreenColumn, % Left margin % Compensate for zero indexing to get right margin. N - 1 + VirtualScreenColumn); end; Symbolic Procedure RefreshLine(lineindex,image_linenumber); % Refresh line if it has changed begin scalar newline, old_shift, old_line, old_shift_and_line, i, tabcolumn, ch; if lineindex neq CurrentLineIndex then newline := GetBufferText(lineindex) else newline := CurrentLine; % Special case (currently a list of % character codes) % Get dotted pair of last stored (ShiftDisplayColumn . newline) old_shift_and_line := Window_Image[image_linenumber]; old_shift := car old_shift_and_line; old_line := cdr old_shift_and_line; % See if line is unchanged. NOTE "equal" test, not "eq" test--this may % be a bad decision, since "equal" without "eq" is unlikely, and should % be handled by the following code. (So, in some sense, use of equal % is redundant, and may run slower.) % ALSO NOTE that this test is WRONG if "destructive" changes were made to % the line. (Changes that preserved eq while changing the contents.) if ShiftDisplayColumn = old_shift and newline eq old_line % (Use eq after all!) then return; % The following code doesn't really handle horizontal scrolling % correctly, since matching length is the number of characters that % match in original strings, which might not correspond to what would % be displayed (due to tabs, etc.) (Need to change the "units" that % MatchLength returns?) % Get index of starting point for redisplay if ShiftDisplayColumn = old_shift then i := MatchLength(old_line,newline) else i := ShiftDisplayColumn; % Save new line and shift value in screen "image" RPLACA(old_shift_and_line,ShiftDisplayColumn); RPLACD(old_shift_and_line, newline); % Get coordinate of starting point (first mismatch, roughly speaking). pos_for_line_refresh := coords(LineColumn(i,newline) - ShiftDisplayColumn, image_linenumber); while not null newline and i <= size newline and Column pos_for_line_refresh <= Column CurrentWindowDelta do << % More kludges! ch := newline[i]; if ch eq char TAB then << % May print unnecessary characters tabcolumn := 8*(1 + Column(pos_for_line_refresh)/8); while Column pos_for_line_refresh < tabcolumn do % DESTRUCTIVELY updates pos_for_line_refresh DisplayCharacter(pos_for_line_refresh, char BLANK); >> else if ch < char BLANK % ch is a control character. then << DisplayCharacter(pos_for_line_refresh, char !^); % Convert the control character to a "normal" character. DisplayCharacter(pos_for_line_refresh, ch + 8#100); >> else % DESTRUCTIVELY updates pos_for_line_refresh DisplayCharacter(pos_for_line_refresh, ch); i := i + 1; >>; ClearEol(pos_for_line_refresh); end; Symbolic Procedure DisplayCharacter(pos,chr); % Display chr at position pos, DESTRUCTIVELY update pos to next column, % same row. (Character is written to a "virtual screen", with an offset % given by row_offset and column_offset.) begin % Map from "window coordinates" to "virtual screen coordinates" and % write out the character. WriteToScreen(CurrentVirtualScreen, chr, row_offset + Row(pos), column_offset + column(pos) ); % Destructively update pos too RPLACA(pos, 1 + Column pos); % New column return pos; end; Symbolic Procedure nxt_item(strm); % Get next item in a stream--represented as a pair of % ("generalized-vector" . last-index), see "create_stream" below. % Returns NIL if nothing left in stream--so you can't store NIL in the % middle. % A quick kludge so that we can step through lists without costly INDX % function (which always starts at the front and CDRs down). begin scalar itm, i; if PairP car strm then << if (itm := cdr strm) then << RPLACD(strm, cdr itm); itm := car itm; >> >> else << i := cdr strm; if i <= size (car strm) then itm := (car strm)[i] else itm := NIL; RPLACD(strm, i + 1); >>; return itm; end; Symbolic Procedure create_stream(gvec); if PairP gvec then (gvec . gvec) else (gvec . 0); Symbolic Procedure MatchLength(l1,l2); % Measure lengths of matching heads for l1,l2. begin scalar itm1, itm2; integer n; if null l1 or null l2 then return 0; l1 := create_stream(l1); l2 := create_stream(l2); n := 0; while (itm1 := nxt_item l1) and (itm2 := nxt_item l2) and itm1 = itm2 do n := n + 1; return n; end; Symbolic Procedure LineColumn(N,line); % Map character position N within string line into true column position. % Somewhat non-trivial if string contains tabs or other control characters. if null line or line = "" then 0 else begin scalar pos, itm; pos := 0; line := create_stream(line); while n > 0 and (itm := nxt_item line) do << n := n - 1; if itm = char TAB then pos := 8*(1 + pos/8) % Kludge else if itm < char BLANK then pos := pos + 2 else pos := pos + 1; >>; return pos; end; Symbolic Procedure FullRefresh(); % Force a complete refresh of the screen (but only work at the "virtual % screen" level, don't bother to delve more deeply into the underlying % buffers. << ClearPhysicalScreen(); RefreshPhysicalScreen(); >>; Symbolic Procedure AdjustTopOfDisplayIndex(); % Center the display around point. Modify global TopOfDisplayIndex begin scalar LinesInBuffer,LinesToPoint,LinesInScreen,MidScreen,LinesToTop; LinesInBuffer := CountAllLines(); % Size of file LinesInScreen := Row CurrentWindowDelta; %/ (MAY BE OFF BY ONE?) WFG MidScreen := LinesInScreen/2; if LinesInBuffer<=LinesInScreen then % Use top of buffer if it return(TopOfDisplayIndex := 0); % all fits on screen. % Lines from start of buffer to first line displayed (exclusive) LinesToTop := CountLinesFrom(0,TopOfDisplayIndex); % Lines from start of buffer to line where Point is. LinesToPoint := CountLinesBefore(); if LinesToTop<=LinesToPoint % Point below top and above bottom and LinesToPoint <=(LinesToTop+LinesInScreen) then return(TopOfDisplayIndex); LinesToTop := LinesToPoint-MidScreen; % Desired % TopOfDisplayIndex := 0; % While LinesToTop > 0 do % << % TopOfDisplayIndex := NextIndex TopOfDisplayIndex; % LinesToTop := LinesToTop -1 % >>; % % return TopOfDisplayIndex; %%%%%%%%%%%%%%%%%%%% above code is more general, but very inefficient % (Depends on fact that "DisplayIndexes" are integers in this % implementation.) return (TopOfDisplayIndex := max(0,LinesToTop)); end; |
Added psl-1983/emode/rface.red version [32f5975c4a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RFACE.RED - Code to support execution of text from within EMODE. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % FirstCall := T; % Force full init when calling EMODE for first time. DefConst(MaxChannels, 32); % Maximum number of channels supported by % PSL. DefConst(DISPLAYTIME, 1000); % Number of milliseconds between redisplays % (very roughly--see code) % Vector of "edit routines" associated with channels. ChannelEditRoutine := MkVect(const(MaxChannels)); % Vectors of buffers associated with channel (when appropriate). Each % entry in the vector is an expression to be evaluated (to allow extra % indirection). InputBufferForChannel := MkVect(const(MaxChannels)); OutputBufferForChannel := MkVect(const(MaxChannels)); % A window to "pop up" when the associated buffer is written into. This % probably should NOT be associated with a channel? % UNIMPLEMENTED FOR NOW. Needs MORE THOUGHT! % OutputWindowForChannel := MkVect(const(MaxChannels)); % See below for definition of RlispDispatchList and LispDispatchList. RlispMode := '(SetKeys RlispDispatchList) . FundamentalTextMode; LispMode := '(SetKeys LispDispatchList) . FundamentalTextMode; % Routines for channel I/O to & from buffers FLUID '( TimeSinceRedisplay % Used to decide if time to redisplay or not % A flag for Rlisp's ON/OFF mechanism. When T, means that the "output" % (or OUT_WINDOW) window should be "popped up" when output % occurs. !*outwindow % Holds the buffername that was selected before BufferPrintChar % switches to the output buffer. previous_to_ouput_buffer % Kludge flag, T when input buffer is OUT_WINDOW buffer (for M-E). reading_from_output EmodeBufferChannel % Channel used for EMODE I/O. Perhaps this should % be expanded to allow different channels for % different purposes (break loops, error messages, % etc.) (Or, perhaps the whole model needs more % thought! ) ); !*outwindow := T; Symbolic Procedure OpenBufferChannel(Inbuffer, Outbuffer, Outwindow); % Open channel for buffer I/O. Outwindow currently unused. begin Scalar chn; SpecialWriteFunction!* := 'BufferPrintChar; SpecialReadFunction!* := 'BufferReadChar; SpecialCloseFunction!* := 'CloseBufferChannel; TimeSinceRedisplay := time(); % Get time from system chn := Open("buffers", 'SPECIAL); % Set up "editor" for the channel. ChannelEditRoutine[chn] := 'EmodeChannelEdit; InputBufferForChannel[chn] := Inbuffer; OutputBufferForChannel[chn] := Outbuffer; return chn end; Symbolic Procedure CloseBufferChannel(chn); % Close up an EMODE buffer channel. << chn := Sys2Int chn; % Sys2Int should be temporary fix? ChannelEditRoutine[chn] := NIL; InputBufferForChannel[chn] := NIL; OutputBufferForChannel[chn] := NIL; >>; % Some history keeping stuff for debugging, we (sometimes) keep a circular % list of characters sent to BufferPrintChar in order to hunt down obscure % bugs. FLUID '(BPhist BPindx); BPhist := MkString(75, char BLANK); BPindx := 0; Symbolic Procedure BufferPrintChar(Chn,ch); % "Print" a character into the buffer corresponding to channel "Chn". % Perhaps a future version should "pop up" an associated window (or select % a "window configuration"?), if any, (and if some flag is set?) CLEARLY, % this needs more thought! begin scalar tmp, outbuffername, ErrOut!*; % ErrOut!* is a system FLUID % Keep a history of the characters, in the circular history buffer, for % debugging. % (Not needed right now.) % BPhist[BPindx] := ch; % BPindx := if BPindx >= size(BPhist) then 0 else 1 + BPindx; % Rebind to avoid calling self if there is an ERROR in this routine (?) ErrOut!* := OldErrOut; % HUM, select the appropriate buffer. if not(CurrentBufferName eq (outbuffername := eval OutputBufferForChannel[chn])) then << previous_to_ouput_buffer := CurrentBufferName; SelectBuffer(outbuffername); >>; InsertCharacter(ch); % Refresh after every character might be nice, but it's costly! The % compromise is to refresh on every line--or after a time limit is % exceeded, whichever comes first. if ch = char EOL then << % Make sure we're in two window mode, unless also reading from % OUT_WINDOW, so the user can see what we print into the buffer. % Don't pop up window if !*Outwindow is NIL. % NEEDS more thought. if !*outwindow and not(reading_from_output) then EnsureOutputVisible(outbuffername, previous_to_ouput_buffer); Refresh(); >> else if ((tmp := time()) - TimeSinceRedisplay) > const(DISPLAYTIME) then << TimeSinceRedisplay := tmp; if !*outwindow and not(reading_from_output) then EnsureOutputVisible(outbuffername, previous_to_ouput_buffer); Refresh(); >>; end; % Ensure the visibility of the outbuffername buffer, oldbuffername gives % the "context" that the call occurs from. Symbolic Procedure EnsureOutputVisible(outbuffername,oldbuffername); % Don't do anything if the buffer is already visible. % Otherwise go through a rather elaborate kludge. if not Buffer_VisibleP(outbuffername) then << SelectBuffer(oldbuffername); % Go to "two window" mode if just one "major window" on screen, and % it's a "text window". if MajorWindowCount() eq 1 AND buffers_view_creator eq 'create_text_view then TwoRFACEWindows() else % Otherwise, just "create a view" into the OUT_WINDOW buffer. select_or_create_buffer('OUT_WINDOW,NIL); SelectBuffer(outbuffername); >>; Symbolic Procedure BufferReadChar(Chn); % Read a character from at location "point" in appropriate buffer for % channel "Chn", advance point. begin scalar ch; chn := Sys2Int chn; % Sys2Int should be temporary fix? %??? if not(CurrentWindowDescriptor eq InputWindowForChannel[chn]) then SelectBuffer(eval InputBufferForChannel[chn]); % (End of buffer test needs to be cleaned up.) if point = length CurrentLine and EndOfBufferP(NextIndex CurrentLineIndex) then return char EOF; % "End Of File" if at end of buffer % ****OR, should we do something like this? (Not very popular when % tried--end of buffer was typically due to a syntax error, often very hard % to know how to correct the problem.) % % Prompt user for more input if at end of buffer, then continue as % % usual. % << % EmodeChannelEdit(chn, "END OF BUFFER: more input expected."); % % % Ultimate kludge! Get back to current buffer. (Seem to be % % mysterious problems with "CurrentLine" inconsistencies.) %% if not(CurrentWindowDescriptor eq InputWindowForChannel[chn]) then % % SelectBuffer(eval InputBufferForChannel[chn]); % >>; ch := CurrentCharacter(); % Get the character if !*ECHO then % Echo to OUT_WINDOW if ECHO flag is set. << BufferPrintChar(Int2Sys Chn, Int2Sys ch); % NOTE Int2Sys % Super kludge! Get back to current window %??? if not(CurrentWindowDescriptor eq InputWindowForChannel[chn]) then SelectBuffer(eval InputBufferForChannel[chn]); >>; !$ForwardCharacter(); % Advance to next in buffer return Int2Sys(ch); % Convert to SYSLISP integer end; Two_window_midpoint := NIL; Symbolic Procedure TwoRFACEWindows(); % Enter two window mode for RLISP interface. Puts prompt information just % below the upper window. ("Prompt" means "message window"--not EMODE's % prompt window.) if MajorWindowCount() neq 2 then % Only do something if not already in "two window mode". begin scalar old_prompt, old_msg, TopWindow; old_prompt := if Prompt_Window then cdr atsoc('window_label, Prompt_Window); old_msg := if Message_Window then cdr atsoc('window_label, Message_Window); % Two_window_midpoint is location of dividing line of dashes, wrt % ScreenBase, roughly speaking. % (3 and 5 are rather ad-hoc guesses.) if not numberp(two_window_midpoint) OR two_window_midpoint < 3 OR two_window_midpoint > (Row ScreenDelta) - 5 then two_window_midpoint := Fix (0.5 * (Row ScreenDelta - 2)); Setup_Windows list( % Looks into current buffer TopWindow := FramedWindowDescriptor(CurrentBufferName, Coords(Column ScreenBase - 1, Row ScreenBase - 1), Coords(Column ScreenDelta + 2, two_window_midpoint)), % Looks into the "message buffer", used for error messages % and general stuff. Message_Window := UnframedWindowDescriptor('MESSAGE_BUFFER, % Base is at two_window_midpoint Coords(Column ScreenBase, Row ScreenBase + two_window_midpoint), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Always looks into the 'OUT_WINDOW buffer, % until we can figure out a better way to handle the % situation?? FramedWindowDescriptor('OUT_WINDOW, Coords(Column ScreenBase - 1, Row ScreenBase + two_window_midpoint + 1), % Run down to the bottom, minus a one line % window. Coords(Column ScreenDelta + 2, Row ScreenDelta - two_window_midpoint - 2)), % Looks into the "prompt line" buffer. Prompt_Window := UnframedWindowDescriptor('PROMPT_BUFFER, % Base is at bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)) ); % Restore the labels from their old values (if any). SelectWindowContext(Prompt_Window); window_label := old_prompt; SelectWindowContext(Message_Window); window_label := old_msg; % Keep track of "minor windows". minor_window_list := list(Prompt_Window, Message_Window); SelectWindow TopWindow; % ??? should this be necessary? end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Set up bindings for Rlisp Mode. RlispDispatchList := list( % M-; inserts a comment--isn't nearly as nice as EMACS version yet. cons(char meta !;, 'InsertComment), % M-E puts us at beginning of line and then simply causes us to return % (exit) to the caller (roughly speaking). cons(char meta E, 'ReturnFromEmodeEdit), % M-C-Y deletes the last "expression" printed in OUT_WINDOW. cons(char meta cntrl Y, 'insert_last_expression) ); % Set up bindings for Lisp Mode. (See HP-EMODEX for additions to this % list.) LispDispatchList := list( % M-; inserts a comment--isn't nearly as nice as EMACS version yet. cons(char meta !;, 'InsertComment), % M-E puts us at beginning of line and then simply causes us to return % (exit) to the caller (roughly speaking). cons(char meta E, 'ReturnFromEmodeEdit), % M-C-Y deletes the last "expression" printed in OUT_WINDOW. cons(char meta cntrl Y, 'insert_last_expression) ); Symbolic Procedure insert_last_expression(); % Insert "last expression" typed in the OUT_WINDOW buffer. begin scalar cbuf; cbuf := CurrentBufferName; % Remember current buffer. SelectBuffer('OUT_WINDOW); % "Mark" points to start of expression, "Point" gives the end. % First, back up over any trailing blank lines. while not BeginningOfBufferP(CurrentLineIndex) and point = 0 do !$BackwardCharacter(); % Now, copy the text into the "kill buffer". copy_region(); % Move back to the end of the output buffer. !$EndOfBuffer(); % Select the original buffer. SelectBuffer(cbuf); insert_kill_buffer(); end; Symbolic Procedure ReturnFromEmodeEdit(); % (Typically invoked by M-E.) Causes EMODE to return to procedure that % called it (via "EmodeChannelEdit"). Arranges for output to go to end of % OUT_WINDOW buffer. begin scalar cbuf; % Set point and mark for output buffer, unless it's also the input % buffer. if CurrentBufferName neq 'OUT_WINDOW then << cbuf := CurrentBufferName; SelectBuffer('OUT_WINDOW); !$EndOfBuffer(); SetMark(); SelectBuffer(cbuf); % Switch back to original buffer. reading_from_output := NIL; >> else reading_from_output := T; % Remember current spot, in case user wants to come back here. SetMark(); % If we're at the end of the buffer, insert an EOL (gratis). if Point = Length CurrentLine and EndOfBufferP(NextIndex CurrentLineIndex) then << !$CRLF(); !$BackwardLine(); % Start out on the previous line. >>; % Start reading from the start of the line that M-E was typed at. !$BeginningOfLine(); % Set things up to read from and write to EMODE buffers. SelectEmodeChannels(); leave_dispatch_loop(); end; % Make sure *EMODE's defined (as opposed to unbound?) at load time. Hope % we don't load inside EMODE! !*EMODE := NIL; % Redefine QUIT so that it restores the terminal to echoing before exiting. if FUnboundP('original!-quit) then CopyD('original!-quit, 'quit); Symbolic Procedure quit(); << if !*EMODE then % If invoked from "inside" EMODE. << SelectOldChannels(); % Switch to original channels. EchoOn(); % Turn echoing back on. >>; original!-quit(); % Fire up EMODE, if we called quit from inside it. if !*EMODE then EMODE(); % Select RLISP-INTERFACE mode upon restart. >>; Symbolic Procedure EmodeChannelEdit(chn, PromptStr); % Invoke EMODE as the editor for a buffer channel. Display the prompt on % "message_window". << % Select "old" channels, so if an error occurs we don't get a bad % recursive situation where printing into a buffer causes more trouble! SelectOldChannels(); % But, keep echoing turned off, we need some other hook to restore % echoing if an error occurs. if null PromptStr then % Use empty string if no prompt given. PromptStr := ""; %?? if not(CurrentWindowDescriptor eq InputWindowForChannel[chn]) then SelectBuffer(eval InputBufferForChannel[chn]); % Advance to end of next line, on theory that we want to move to next % expression to evalute. if not EndOfBufferP(NextIndex CurrentLineIndex) then << !$ForwardLine(); !$EndOfLine(); >>; ERRORSET(list('EMODE1, PromptStr),T,!*BACKTRACE); >>; Symbolic Procedure PromptAndEdit(PromptStr); % Allow the user to "edit" the default input channel. PromptAndEditOnChannel(IN!*, PromptStr); Symbolic Procedure PromptAndEditOnChannel(chn, PromptStr); % If there is an editor associated with the channel, call it, passing the % channel and prompt string "PromptStr" as arguments. Always return NIL. << if not null ChannelEditRoutine[chn] then Apply(ChannelEditRoutine[chn], list(chn, PromptStr)); NIL >>; Symbolic Procedure MakeInputAvailable(); % THIS IS THE MAGIC FUNCTION invoked by READ, and other "reader functions". % PROMPTSTRING!* is a global (FLUID) variable. PromptAndEdit(PROMPTSTRING!*); FLUID '( OldStdIn OldStdOut OldErrOut ); Symbolic Procedure SelectOldChannels(); % Select channels that were in effect when "Rlisp Interface" was started % up. (But don't turn echoing on.) NOTE that the "old channels" are % normally selected while EMODE is actually running (this is somewhat % counter intuitive). This is so that any error messages created by bugs % in EMODE will not be printed into EMODE buffers. (If they were, it might % break things recursively! ) << % Postion the cursor to the bottom of the screen. SetTerminalCursor(Column ScreenBase, Row ScreenDelta); % Currently we avoid closing the channels. Unclear if this is right. If % we do decide to close channels, remember not to close a channel after % it's already closed! (In case, e.g., ErrOut!* = STDOUT!*.) STDIN!* := OldStdIn; STDOUT!* := OldStdOut; ErrOut!* := OldErrOut; RDS STDIN!*; % Select the channels. WRS STDOUT!*; >>; Symbolic Procedure InsertComment(); << !$EndOfLine(); insert_string "% "; >>; |
Added psl-1983/emode/ring-buffer.sl version [2ef2679e56].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RING-BUFFER.SL - Ring Buffers % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % % This file implements general ring buffers. % This file requires COMMON, NSTRUCT. % Modifications by William Galway: % "defun" -> "de" so TAGS can find things. % "setq" -> "setf" (defstruct (ring-buffer) ring-buffer-vector % Elements 1..N are used. ring-buffer-top-ptr % Elements 1..Top are valid. ring-buffer-pointer % Element Vector[POINTER] is current. ) (de ring-buffer-create (number-of-elements) (let ((rb (make-ring-buffer))) (setf (ring-buffer-vector rb) (mkvect number-of-elements)) (setf (ring-buffer-top-ptr rb) 0) (setf (ring-buffer-pointer rb) 0) rb )) (de ring-buffer-push (rb new-element) (let ((new-pointer (+ (ring-buffer-pointer rb) 1)) (v (ring-buffer-vector rb)) ) (if (> new-pointer (upbv v)) (setf new-pointer 1)) (if (> new-pointer (ring-buffer-top-ptr rb)) (setf (ring-buffer-top-ptr rb) new-pointer)) (setf (ring-buffer-pointer rb) new-pointer) (setf (getv (ring-buffer-vector rb) new-pointer) new-element) new-element )) (de ring-buffer-top (rb) % Returns NIL if the buffer is empty. (let* ((ptr (ring-buffer-pointer rb)) (v (ring-buffer-vector rb)) ) (cond ((= ptr 0) NIL) (t (getv v ptr))))) (de ring-buffer-pop (rb) % Returns NIL if the buffer is empty. (let* ((ptr (ring-buffer-pointer rb)) (new-ptr (- ptr 1)) (v (ring-buffer-vector rb)) ) (cond ((= ptr 0) NIL) (t (if (= new-ptr 0) (setf new-ptr (ring-buffer-top-ptr rb))) (setf (ring-buffer-pointer rb) new-ptr) (getv v ptr))))) |
Added psl-1983/emode/search.red version [bc8d4e274a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SEARCH.RED - Search utilities for EMODE % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % These routines to implement minimal string searches for EMODE. Searches % are non-incremental, limited to single line patterns, and always ignore % case. This file also includes routines for moving over other patterns % (words, etc.). %%%%% Changes: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AS 7/15/82 % - Fixed skip_backward_blanks to behave properly at the beginning % of the buffer (loop termination test was incorrect). % - Use sleep primitive for insert_matching_paren. FLUID '( last_search_string ); Symbolic Procedure forward_string_search(); % Invoked from keyboard, search forward from point for string, leave % "point" unchanged if not found. begin scalar strng; % Get search string, update default. strng := last_search_string := prompt_for_string("Forward search: ", last_search_string); if buffer_search(strng, 1) then % 1 for forward search, and if found for i := 0:size(strng) do % move to end of string. !$ForwardCharacter(); end; Symbolic Procedure reverse_string_search(); % Invoked from keyboard, search backwards from point for string, leave % "point unchanged if not found. begin scalar strng; strng := last_search_string := prompt_for_string("Reverse Search: ", last_search_string); !$Backwardcharacter(); % Back up before starting search. if not buffer_search(strng, -1) then % -1 for backward search !$ForwardCharacter(); % restore point if not found. end; Symbolic Procedure buffer_search(strng,dir); % Search in buffer for strng. "Ding" and leave point unchanged if % not found, return NIL if not found. dir is +1 for forward, -1 % for backward. begin scalar search_point, search_lineindex, found, within_buffer; PutLine(); % Make sure line is "saved" in buffer % Start at current location in the buffer. search_lineindex := CurrentLineIndex; search_point := min(point, size GetBufferText(search_lineindex)); within_buffer := not EndOfBufferP(search_lineindex); while within_buffer and not (found := subscript(strng, GetBufferText(search_lineindex), search_point, dir)) do << % Move to "beginning" of "next" line if dir > 0 then << within_buffer := not EndOfBufferP(NextIndex search_lineindex); if within_buffer then << search_lineindex := NextIndex(search_lineindex); search_point := 0; >>; >> else << within_buffer := not BeginningOfBufferP(search_lineindex); if within_buffer then << search_lineindex := PreviousIndex(search_lineindex); search_point := size GetBufferText(search_lineindex); >>; >>; >>; if found then << SelectLine(search_lineindex); point := found; >> else Ding(); return found; end; Symbolic Procedure subscript(pattern,strng,start,dir); % Locate pattern in strng, starting at "start", searching in direction % "dir" (+1 for forward search, -1 for backward search). % Return NIL if not found, otherwise return the subscript of the first % matching character. begin scalar found; while 0 <= start and start <= size strng and not (found := is_substring(pattern,strng,start)) do start := start + dir; return if found then start else NIL; end; Symbolic Procedure RaiseChar(ch); % Return character code for upper case version of character. % (ch is a character code.) if ch < char lower 'a or ch > char lower 'z then ch else ch - char lower 'a + char 'A; Symbolic Procedure is_substring(substrng,strng,start); % Return T if substrng occurs as substring of strng, starting at "start". % Ignore case differences. begin scalar i; i := 0; while i <= size(substrng) and i+start <= size(strng) and RaiseChar substrng[i] = RaiseChar strng[i+start] do i := i + 1; return i > size(substrng); % T if all chars matched, false otherwise. end; FLUID '(paren_depth); Symbolic Procedure adjust_depth(ch); % Adjust paren_depth based on the character. if ch = char !( then paren_depth := paren_depth + 1 else if ch = char !) then paren_depth := paren_depth - 1; Symbolic Procedure skip_forward_blanks(); % Skip over "blanks", return the first non-blank character seen. begin scalar ch; while not (EndOfBufferP(NextIndex CurrentLineIndex) and point = length CurrentLine) AND % 17 means "ignore". CurrentScanTable!*[ch := CurrentCharacter()] = 17 do !$ForwardCharacter(); return ch; end; Symbolic Procedure skip_backward_blanks(); % Skip backwards over "blanks", return the first non-blank character seen. begin scalar ch, flg; flg := T; while not (BeginningOfBufferP(CurrentLineIndex) and point = 0) AND flg do << !$BackwardCharacter(); % 17 means "ignore". flg := CurrentScanTable!*[ch := CurrentCharacter()] = 17 >>; % Position "cursor" to the right of the terminating character. if not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) then !$ForwardCharacter(); return ch; end; Symbolic Procedure forward_word(); % Move forward one "word", starting from point. begin scalar ch; while not (EndOfBufferP(NextIndex CurrentLineIndex) and point = length CurrentLine) AND % Scan for start of word. not(LetterP(ch := skip_forward_blanks()) OR DigitP(ch)) do !$ForwardCharacter(); % Now, scan for end of word. while not (EndOfBufferP(NextIndex CurrentLineIndex) and point = length CurrentLine) AND (LetterP(ch := CurrentCharacter()) OR DigitP(ch)) do % Can't be a paren, so don't bother to count. !$ForwardCharacter(); end; Symbolic Procedure backward_word(); % Move backward one "word", starting from point. begin scalar ch,flg; flg := T; % Scan for the start of a word (a "letter" or digit). while flg AND not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) do << !$BackwardCharacter(); flg := not (LetterP(ch := CurrentCharacter()) OR DigitP(ch)); >>; % Now, scan for "end" of identifier. flg := T; while flg AND not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) do << !$BackwardCharacter(); flg := (LetterP(ch := CurrentCharacter()) OR DigitP(ch)); >>; % Position "cursor" to the right of the terminating character. if not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) then !$ForwardCharacter(); end; Symbolic Procedure LetterP(ch); % Note that we don't use ch < 128 and CurrentScanTable!*[ch] equal 10; % 10 means "a letter". Symbolic Procedure forward_sexpr(); % Move forward over a set of balanced parenthesis (roughly speaking). begin scalar ch, cline, cpoint, paren_depth; % paren_depth is FLUID. % Remember our spot. cline := CurrentLineIndex; cpoint := point; paren_depth := 0; ch := skip_forward_blanks(); adjust_depth(ch); if paren_depth > 0 then % Skip over balanced parens, if first thing was % a paren. << while not (EndOfBufferP(NextIndex CurrentLineIndex) and point = length CurrentLine) AND paren_depth > 0 do << !$ForwardCharacter(); adjust_depth CurrentCharacter(); >>; % Complain, and avoid moving point, if match not found. if paren_depth > 0 then << ding(); PutLine(); point := cpoint; GetLine(cline); >> else !$ForwardCharacter(); % Skip over trailing right paren. >> % Otherwise (paren not first character seen), just skip a word. else forward_word() end; Symbolic Procedure backward_sexpr(); % Move backwards over a set of balanced parenthesis (roughly speaking). begin scalar ch, flg, cline, cpoint, paren_depth; % paren_depth is FLUID. % Remember our spot. cline := CurrentLineIndex; cpoint := point; paren_depth := 0; ch := skip_backward_blanks(); flg := T; if ch = char !) then % Skip over balanced parens, if first thing was % a paren. << while not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) AND flg do << !$BackwardCharacter(); adjust_depth CurrentCharacter(); flg := paren_depth < 0; % (< 0, since this is backwards search! ) >>; % Complain, and avoid moving point, if match not found. if paren_depth < 0 then << ding(); PutLine(); point := cpoint; GetLine(cline); >>; >> % if a left paren, just back up slightly (a bit of a KLUDGE). else if ch = char !( then !$BackwardCharacter() % Otherwise (paren not first character seen), just skip a word. else backward_word(); end; Symbolic Procedure insert_matching_paren(); % Insert a right parenthesis, back up to a matching left parenthesis, pause % there a "second" and then come back to current location. begin scalar cline, cpoint, flg, timer, paren_depth; InsertCharacter char !); % (Or, InsertSelfCharacter?) cline := CurrentLineIndex; cpoint := point; paren_depth := 0; flg := T; while not(BeginningOfBufferP(CurrentLineIndex) AND point = 0) AND flg do << !$BackwardCharacter(); adjust_depth CurrentCharacter(); flg := paren_depth < 0; >>; if flg then % No match found ding() else << optional_refresh(); % Show where we are, if no typeahead. % "pause" for 1/2 sec (30/60ths) or until character is typed. sleep!-until!-timeout!-or!-input(30); >>; % Go back to original spot. point := cpoint; SelectLine(cline); end; |
Added psl-1983/emode/setwindow.red version [6c03960ee9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Procedure OneWindow(); % Dispatch to this routine to enter one-window mode. if MajorWindowCount neq 1 then % If not already one-window << % Setup windows for one window mode. Setup_Windows list( % Window one looks into current buffer, other arguments are % location of upper left corner, and the size (0 indexed). WindowDescriptor(1, CurrentBufferName, ScreenBase, % Upper left corner % Size uses entire width, leaves room for % three one line windows at the bottom Coords(Column ScreenDelta, Row(ScreenDelta) - 3)), % Window 1001 looks into the "mode line" buffer. WindowDescriptor(1001, 'MODE_LINE, % Base is two lines above bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta - 2), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Window 1002 looks into the "prompt line" buffer. WindowDescriptor(1002, 'PROMPT_BUFFER, % Base is one line above bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta - 1), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Window 1003 looks into the "message buffer", used for error % messages and general stuff. WindowDescriptor(1003, 'MESSAGE_BUFFER, % Base is at bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)) ); % Wierd, the code seems to usually work without the following call. % Needs to be rethought. SelectWindow 1; FullRefresh(); % A kludge, sigh. MajorWindowCount := 1; >>; FLUID '(Fraction2); Symbolic Procedure TwoWindows(); % Dispatch to this routine to enter two-window mode. if MajorWindowCount neq 2 then begin scalar MidPoint,frac1,lines; % Use roughly half (later to be a variable) the screen, allow for a % dividing line of dashes and 3 one line windows at the bottom. % MidPoint is location of dividing line of dashes, wrt ScreenBase. frac1:=Fraction2; if not(FloatP frac1 and frac1<0.9 and frac1 >0.1) then frac1:=0.5; lines:=(Row ScreenDelta - 3); MidPoint := Fix (frac1 * lines); if Midpoint <= 2 then Midpoint:=2; Setup_Windows list( % Window one looks into current buffer WindowDescriptor(1, CurrentBufferName, ScreenBase, Coords(Column ScreenDelta, MidPoint - 1)), % Window 1000 looks into the dividing line of dashes WindowDescriptor(1000, 'DASHES, Coords(Column ScreenBase, MidPoint), Coords(Column ScreenDelta, 0)), % Window 2 always looks into the 'ALTERNATE_WINDOW buffer, % until we can figure out a better way of handling the % situation. WindowDescriptor(2, 'ALTERNATE_WINDOW, Coords(Column ScreenBase, MidPoint + 1), % Run down to the bottom, minus 3 one line % windows. Coords(Column ScreenDelta, Row ScreenDelta - MidPoint - 4)), % Window 1001 looks into the "mode line" buffer. WindowDescriptor(1001, 'MODE_LINE, % Base is two lines above bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta - 2), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Window 1002 looks into the "prompt line" buffer. WindowDescriptor(1002, 'PROMPT_BUFFER, % Base is one line above bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta - 1), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)), % Window 1003 looks into the "message buffer", used for error % messages and general stuff. WindowDescriptor(1003, 'MESSAGE_BUFFER, % Base is at bottom Coords(Column ScreenBase, Row ScreenBase + Row ScreenDelta), % a single line (so delta row = 0) Coords(Column ScreenDelta, 0)) ); % Wierd, the code seems to usually work without the following call. % Needs to be rethought. SelectWindow 1; FullRefresh(); % A kludge, sigh. MajorWindowCount := 2; end; Fraction2 :=0.5; procedure ResetEmode(rows,cols,f); if cols >=10 and cols<=79 and rows>=6 and rows <=60 then <<ScreenDelta:= Cols . Rows; If FloatP F and F>=0.1 and F <=0.9 then Fraction2:=F; if MajorWindowCount =1 then <<MajorWindowCount:=0; OneWindow()>> else if MajorWindowCount = 2 then <<MajorWindowCount:=0; TwoWindows()>> >>; procedure resetrows(r); resetScreen(car ScreenDelta,r); procedure SetEmode(rows,cols,f); Begin Scalar !*EMODE; if cols >=10 and cols<=79 and rows>=6 and rows <=60 then ScreenDelta:= Cols . Rows; If FloatP F and f>=0.1 and f<=0.9 then Fraction2:=f; !*EMODE:=T; FreshEmode(); End; |
Added psl-1983/emode/sleep.sl version [648969222c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Sleep.SL - Sleep Primitive % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 15 July 1982 % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 6-Aug-82, WFG: Modified to include an "inefficient" VAX version. (CompileTime (load if-system)) (BothTimes (progn (load common) (if_system Dec20 (load jsys)))) (if_system Dec20 (de sleep-until-timeout-or-input (n-60ths) % Dec-20 version % Return when either of two conditions are met: (1) Input is available. % (2) The specified elapsed time (in units of 1/60th second) has elapsed. % Don't waste CPU cycles! (for (from i 1 n-60ths 2) (until (> (CharsInInputBuffer) 0)) (do (Jsys0 33 0 0 0 (const jsDISMS))) )) ) (if_system Unix (de sleep-until-timeout-or-input (n-60ths) % Unix version % Should use the SELECT system call? % Return when either of two conditions are met: (1) Input is available. % (2) The specified elapsed time (in units of 1/60th second) has elapsed. (let ((timer (time)) % Get "current time" in milliseconds. % Approximate number of 1000ths to count (17 roughly equal % 16.6666...) (n-1000ths (* 17 n-60ths))) (for % Pause until time runs out, (while (< (- (time) timer) n-1000ths)) % or a character is typed. (until (> (CharsInInputBuffer) 0)))))) |
Added psl-1983/emode/tel-ann-driver.red version [b00b28347a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) % Physical Size is D.X=~8inch, D.Y=~6inch % Want square asp[ect ratio for 100*100 Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; 12 - FIX(Y); Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xhere,Yhere, X1, Y1,function TEL!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure TEL!.dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Bottom . . Top) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.DDA(X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL end; Procedure ANN!.MoveS(X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure ANN!.DrawS(X1,Y1); << ANN!.DDA(Xhere,Yhere, X1, Y1,function ANN!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(ANN!.DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); If not !*emode then echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Print "Device Now ANN60"; end; |
Added psl-1983/emode/teleray.sl version [7ecf3659e2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TELERAY.SL - EMODE support for Teleray terminals % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#377) (DE EraseScreen () (progn (PBOUT (Char ESC)) (PBOUT (Char (lower J))))) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (char Y)) (PBOUT (plus (char BLANK) RowLoc)) (PBOUT (plus (char BLANK) ColLoc)))) |
Added psl-1983/emode/temporary-emode-fixes.red version [1e0c217653].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TEMPORARY-EMODE-FIXES.RED - Tempory "fixes" to PSL to allow EMODE to run. % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % This file tends to overlap CUSTOMIZE-RLISP-FOR-EMODE.RED. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Measurement tools fluid '(cons_count); Symbolic Procedure counting_cons(x,y); % Version of cons that counts each call, old_cons_function must be set up % for this to work. << cons_count := cons_count + 1; old_cons_function(x,y) >>; Symbolic Procedure start_cons_count(); % Setup to count conses. Replaces cons with a version that counts calls to % itself. begin scalar !*RedefMSG; % !*RedefMSG is a fluid, controls printing of "redefined" messages. cons_count := 0; !*RedefMSG := NIL; CopyD('old_cons_function, 'cons); CopyD('cons, 'counting_cons); end; Symbolic Procedure stop_cons_count(); % Stop "cons counting", return the count. begin scalar !*RedefMSG; % !*RedefMSG is a fluid, controls printing of "redefined" messages. !*RedefMSG := NIL; CopyD('cons, 'old_cons_function); return cons_count; end; |
Added psl-1983/emode/time.stamp version [51edc92c0c].
> | 1 | 27-Aug-82 17:36:08 |
Added psl-1983/emode/toy-mode.sl version [67930d98c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TOY-MODE.SL - A "toy" to demonstrate a "non-text" data mode % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 August 1982 % Copyright (c) 1982 University of Utah % % In reality, this is really the same as text, but with a different refresh % algorithm. % Need to fix clear window problems at creation time, plus misc clear to % end of line problems plus onewindow/twowindow problems. (load nstruct) (declare_data_mode "toy" 'create_toy_buffer) % Taken from "create_text_buffer" (de create_toy_buffer () % Environment bindings for this buffer. % May prefer to use backquote to do this, but current version is buggy % for lists of the form `( (a .b) ). Also, it's important not to share % any substructure with other alists built by this routine. (list % The following 5 "per buffer" variables should be defined for a buffer % of any "data mode". (cons 'buffers_view_creator 'create_toy_view) (cons 'buffers_file_reader 'read_channel_into_text_buffer) (cons 'buffers_file_writer 'write_text_buffer_to_channel) (cons 'buffers_file NIL) % Name of file associated with buffer. (cons 'ModeEstablishExpressions RlispMode) % Variables unique to "text data mode" follow. % Initial vector allows only one line. (Should really be parameterized % somehow?) (cons 'CurrentBufferText (MkVect 0)) % 0 is upper bound, one element. (cons 'CurrentBufferSize 1) % Start with one line of text (but zero % characters in the line! ) (cons 'CurrentLine NIL) (cons 'CurrentLineIndex 0) (cons 'point 0) % MarkLineIndex corresponds to CurrentLineIndex, but for "mark". (cons 'MarkLineIndex 0) (cons 'MarkPoint 0) % Corresponds to "point". )) % Modified from "create_text_view" (de create_toy_view (buffer-name) (cond % If the current buffer also uses a "toy view" or "text view" (hum, % needs more work--not very modular! ) ((memq buffers_view_creator '(create_text_view create_toy_view)) % Just modify (destructively) the current "view" (or "window") % environment to look into the new buffer, use the proper refresh % algorithm, return the current environment. (SelectBuffer buffer-name) % Let window know what buffer it's looking into (wierd)! (setf WindowsBufferName buffer-name) (setf windows_refresher (function refresh_toy_window)) % Make sure the virtual screen is properly cleared and framed. (ClearVirtualScreen CurrentVirtualScreen) (FrameScreen CurrentVirtualScreen) % Save (and return) the current "view" environment. (SaveEnv CurrentWindowDescriptor)) % Otherwise (if current view isn't into "text" or "toy"), create a % framed window of an appropriate size and at an appropriate location. % (For lack of a better idea, just use a large window taking up most of % the screen--same as provided by "OneWindow".) (T (let ((new-view (FramedWindowDescriptor buffer-name % Upper left corner (coords (sub1 (Column ScreenBase)) (sub1 (Row ScreenBase))) % Size of window uses entire width of screen, leaves room for two % one line windows at bottom of screen. (coords (plus 2 (Column ScreenDelta)) (sub1 (Row ScreenDelta))) ))) (setf (cdr (atsoc 'windows_refresher new-view)) (function refresh_toy_window)) new-view)))) (fluid '(row_offset column_offset)) % Taken from refresh_framed_window. (de refresh_toy_window () (progn (setf row_offset 1) (setf column_offset 1) (quietly_copyd 'original-WriteToScreen 'WriteToScreen) (quietly_copyd 'WriteToScreen 'backwards-WriteToScreen) (refresh_text) (quietly_copyd 'WriteToScreen 'original-WriteToScreen) (refresh_frame_label) (MoveToScreenLocation CurrentVirtualScreen (plus row_offset (CountLinesFrom TopOfDisplayIndex CurrentLineIndex)) (difference (VirtualScreenWidth CurrentVirtualScreen) (plus column_offset (difference (LineColumn point CurrentLine) ShiftDisplayColumn)))))) (de backwards-WriteToScreen (Scrn chr rw col) (original-WriteToScreen Scrn chr rw (difference (VirtualScreenWidth Scrn) col))) (de quietly_copyd (dest src) (let ((*USERMODE NIL) (*REDEFMSG NIL)) (copyd dest src))) (de quietly_putd (fname ftype body) (let ((*USERMODE NIL) (*REDEFMSG NIL)) (putd fname ftype body))) |
Added psl-1983/emode/tty-size.sl version [92697489ba].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % JSYS call to get dimensions of "TTY" screen. % Written by M. L. Griss. Modifications by William Galway. % **** SubField should be included as part of the JSYS system? **** % Return a subfield from a "word". (Bit 0 is leftmost on DEC-20.) % (FieldSize might be better?) (DM SubField (args) `(Land ,(indx args 3) (LSH ,(indx args 1) (difference ,(indx args 2) 35)))) % Return JFN mode word for terminal. (DE TTyWord () (JSYS2 8#101 0 0 0 8#107)) % jsRFMOD % Return system's idea of the terminal's "page length". (DE PageLength () (SubField (TTyWord) 10 8#177)) (DE PageWidth () (SubField (TTyWord) 17 8#177)) |
Added psl-1983/emode/updated.files version [12b05d330e].
> > > > | 1 2 3 4 | PS:<PSL.EMODE> EMODE.LPT.8 VT100.SL.5 |
Added psl-1983/emode/v-screen.sl version [bb0a92adc9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % V-SCREEN.SL - Utilities to handle "virtual screens" (alias "windows"). % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 June 1982 % Copyright (c) 1982 University of Utah % % These utilities implement "virtual screens" , and do screen refresh. % (Primarily designed to serve as a support package for EMODE, but may be % more generally useful.) % Some support routines for this package reside in the file % "V-SCREEN-SUPPORT.RED". % The current implementation is tentative--needs more thought, more % formalization of how refresh should work, better handling of terminals % with line insert/delete, better handling of scrolling, more consideration % of methods used for the Lisp Machine, etc. (Should there be fewer levels % of storage?) % Virtual screens are represented as vectors of strings, one string for % each row of the "screen". (Other information, such as virtual cursor % location, is also stored in the structure.) % Virtual screens are created with the function "CreateVirtualScreen". They % aren't actually displayed until you call "SelectScreen"--which assigns a % "screen number" for the screen (for masking) if it doesn't already have % one, and "draws" the new screen "on top" of all the others. (I.e. it % "activates" the screen.) Screens can be made to disappear by covering % them with other screens, or by calling "DeSelectScreen". It IS legal to % operate on inactive screens (i.e. write to them, move the virtual cursor, % etc). To completely get rid of a screen, get rid of all references to % it, and it will go away at the next garbage collection. % The philosophy is that these arrays will serve as caches for stuff that % can't actually make it to the "true screen" because of being covered by % other "virtual screens". The routines are optimized for writing % characters onto a virtual screen--moving screens, putting a new screen on % the top, etc., are much less efficiently handled. % (Talk about fact that the two "screen images" don't really work the same % way as virtual screens?) % Maximum number of "masks" allowed. (Corresponds to the largest number we % can fit into a byte.) (DefConst MaxMaskNumber 127) % Macro for indexing into a "virtual screen" (vector of strings). (DS index_screen (Scrn rw col) (igets (igetv Scrn rw) col)) % Fast string and vector accessors % "Left associative" version of "Expand". (Expand is right associative.) % Useful for expanding macros for N-ary versions of left associative % operators. (We should really have a "robust" version of this % utility--see "RobustExpand".) (BothTimes % CompileTime? (DE LeftAssociativeExpand (args Fn) (LeftAssociativeExpand1 Fn (car args) (cdr args))) ) % Utility for implementing LeftAssociativeExpand. % Similar to tail recursive definition of "(reverse x)" as "(rev1 x nil)". (BothTimes % CompileTime? (DE LeftAssociativeExpand1 (Fn ProcessedArgs args) (cond % No arguments left to process ((null args) ProcessedArgs) (T (LeftAssociativeExpand1 Fn (list Fn ProcessedArgs (car args)) (cdr args))))) ) % N-ary version of indx. (indexn X I J) is same as (indx (indx X I) J). (BothTimes % CompileTime? (DM indexn (U) (LeftAssociativeExpand (cdr U) 'Indx)) ) % Define components for a "range". (DefStruct (range fast-vector) % Make vector accesses "fast". MinRange % Minimum of a range. MaxRange % Maximum of a range. ) % Return T if number "x" is within range "rnge". (DS WithinRangeP (x rnge) (and (LeQ (MinRange rnge) x) (LeQ x (MaxRange rnge)))) % Update a "range" so that it "brackets" a new value. (DE PutValueIntoRange (x rnge) (progn % New minimum if x < old minimum (cond ((LessP x (MinRange rnge)) (setf (MinRange rnge) x))) % New maximum if x > old maximum. (cond ((GreaterP x (MaxRange rnge)) (setf (MaxRange rnge) x))) % Return the new (destructively modified) range. rnge)) % Define components for a VirtualScreen (DefStruct (VirtualScreen fast-vector) MaskNumber % A number taken from FreeMaskList when "active", % negative when "inactive". VirtualImage % Vector of strings giving the "screen image". BlankRanges % Vector of ranges--indicating an "all blank" section of % each line of the virtual screen. % Position of virtual cursor. Not used for much except to position the % physical cursor at the topmost screen's virtual cursor. (In % particular, the virtual cursor doesn't have anything to do with where % the last character was written.) ScreensCursorRow ScreensCursorColumn % Perhaps the location of a screen shouldn't be stored with the % screen? These values may be NIL, when we don't really care? % Absolute coordinates (or, perhaps relative to "parent" screen) of upper % left hand corner. ScreensRowLocation ScreensColumnLocation ) % Return the "height" of a virtual screen. % Actually returns the maximum row number (height - 1, due to 0 indexing). (DS VirtualScreenHeight (Scrn) (size (VirtualImage Scrn))) % Return the "width" of a virtual screen. (See above note about 0 % indexing.) (DS VirtualScreenWidth (Scrn) % Return the "width" of a representative string. (size (igetv (VirtualImage Scrn) 0))) (FLUID '( MaxPhysicalRow % Dimensions of the "PhysicalScreenImage" (actual % number of rows is one plus this--due to 0 % indexing.) MaxPhysicalColumn % (That was for rows, here's for columns.) PhysicalScreenImage % Our idea of what's currently on the screen. PhysicalCursorRow % Current location of the physical cursor. PhysicalCursorColumn NewScreenImage % What should go there next. MaskInfo % Used to handle overlapping windows. ChangedRowRange % Rows on NewScreenImage will differ from those on % PhysicalScreenImage only within this range. ChangedColumnRanges % Similar information for columns on each row. FreeMaskList % Used to allocate "mask numbers". ActiveScreenList % The allocated screens go onto this list. ) ) % Create a "screen image" (a vector of strings), filled with character % "chr". (DE CreateScreenImage (chr rws cols) (prog (result) (setf result (MkVect (sub1 rws))) (for (from i 0 (sub1 rws) 1) (do (setf (indexn result i) (MkString (sub1 cols) chr)))) (return result))) % Write a "screen image" to a channel. (Not a "virtual screen", but the % actual vector of strings component of a virtual screen.) (DE WriteScreenImage (ScrnImage chn) (progn (WRS chn) % Select the channel for output. (for (from i 0 (size ScrnImage) 1) % Write out the line, followed by a "newline". (do (Prin2T (indexn ScrnImage i)))) (WRS NIL) % Switch back to standard output. )) % Initialize the screen package--allocate space for "screen image", build % "free" and "active" list, clear the screen, etc. Must be using "raw" I/O % when this routine is called. (DE InitializeScreenPackage () (progn % Numbers for "active" virtual screens are allocated from a free screen % list, which gets initialized here. (setf FreeMaskList NIL) (for (from i 1 (const MaxMaskNumber) 1) (do (setf FreeMaskList (cons i FreeMaskList)))) % List of active screens is initially NIL. (setf ActiveScreenList NIL) % Maximum row number for the physical screen. (setf MaxPhysicalRow (Row ScreenDelta)) % System's idea of width is assumed to always be good. (setf MaxPhysicalColumn (Column ScreenDelta)) (EraseScreen) % Clear the screen. % Create PhysicalScreenImage--gets a blank screen array. (setf PhysicalScreenImage (CreateScreenImage (char BLANK) (add1 MaxPhysicalRow) (add1 MaxPhysicalColumn))) % Identical sort of thing for NewScreenImage. (setf NewScreenImage (CreateScreenImage (char BLANK) (add1 MaxPhysicalRow) (add1 MaxPhysicalColumn))) % Setup "changed" information (no changes between NewScreenImage and % PhysicalScreenImage initially). % Set to an "empty range", one where minimum is >= largest possible % range, while maximum is <= smallest possible value. (setf ChangedRowRange (make-range MinRange MaxPhysicalRow MaxRange 0)) % One piece of "column change" information per row. (setf ChangedColumnRanges (MkVect MaxPhysicalRow)) (for (from i 0 MaxPhysicalRow 1) % Set up each row entry. (do (setf (indexn ChangedColumnRanges i) (make-range MinRange MaxPhysicalColumn MaxRange 0)))) % Set up the MaskInfo array, but fill with 0's (NULLS) instead of blanks. (setf MaskInfo (CreateScreenImage 0 (add1 MaxPhysicalRow) (add1 MaxPhysicalColumn))))) % Create and return (but don't show) a new screen. Use "SelectScreen" to % actually display the screen. (DE CreateVirtualScreen (rws cols CornerRow CornerCol) % Allocate and return the screen. (prog (NewVS) (setf NewVS (make-VirtualScreen % Don't assign a real (positive) mask number until screen is % activated. MaskNumber -1 VirtualImage (CreateScreenImage (char BLANK) rws cols) BlankRanges (MkVect (sub1 rws)) ScreensCursorRow 0 % Initially, cursor is at upper left corner. ScreensCursorColumn 0 ScreensRowLocation CornerRow ScreensColumnLocation CornerCol)) (for (from i 0 (sub1 rws) 1) (do (setf (indexn (BlankRanges NewVS) i) (make-range MinRange 0 MaxRange (sub1 cols))))) (return NewVS))) % Clear out (set to all blanks) a virtual screen. (de ClearVirtualScreen (scrn) (let ((right-col (VirtualScreenWidth scrn))) (for (from rw 0 (VirtualScreenHeight scrn)) (do (WriteToScreenRange scrn (char BLANK) rw 0 right-col))))) % Return T iff the coordinates are within an "array". (Vector of % "vectors".) (DE WithinArrayP (ScrnArray rw col) (and (LeQ 0 rw) (LeQ rw (size ScrnArray)) (LeQ 0 col) (LeQ col (size (igetv ScrnArray 0))))) % Write a character to "NewScreenImage" at some coordinate, or ignore it if % outside the screen. Don't check coordinates for validity, don't update % change information--let the caller do that. (For efficiency reasons, % dammit. A compiler that was smart about index calculation within loops % would make a lot of this hacking unnecessary?) (DS WriteToNewScreenImage (chr absrow abscol) % Store the character (setf (index_screen NewScreenImage absrow abscol) chr)) % "Write" a character onto a virtual screen, at location (rw, col). % Let the character "trickle" to the "NewScreenImage" if the cell isn't % covered. Ignore characters that would be off the screen. (DE WriteToScreen (Scrn chr rw col) (prog (absrow abscol) % If the new character lies on the virtual screen ... (cond % OPTIMIZE this test!!! ((WithinArrayP (VirtualImage Scrn) rw col) % Then store the new character and let it "trickle" (progn (setf (index_screen (VirtualImage Scrn) rw col) chr) % Update our idea of the "all blank" region on the screen. (cond ((not (equal chr (char BLANK))) % Character is non-blank, so shrink the range. (prog (BlnkRange LeftSize RightSize) (setf BlnkRange (igetv (BlankRanges Scrn) rw)) % If the non-blank character falls within the blank region. (cond ((WithinRangeP col BlnkRange) (progn % Find the larger of the two ranges on either side of % col. (setf LeftSize (difference col (MinRange BlnkRange))) (setf RightSize (difference (MaxRange BlnkRange) col)) (cond ((LessP LeftSize RightSize) (setf (MinRange BlnkRange) (add1 col))) % Otherwise, the left range is larger. (T (setf (MaxRange BlnkRange) (sub1 col)))))))))) % Find absolute location for character (setf absrow (plus rw (ScreensRowLocation Scrn))) (setf abscol (plus col (ScreensColumnLocation Scrn))) (cond % If the character falls on the screen, and this screen is the % one on the top, and the character differs from what's already % there ... ((and (WithinArrayP MaskInfo absrow abscol) (equal (MaskNumber Scrn) (index_screen MaskInfo absrow abscol)) (not (equal chr (index_screen NewScreenImage absrow abscol)))) % ... then do it (progn (WriteToNewScreenImage chr absrow abscol) % Update the changed "range" (region?) information. Note % that PutValueIntoRange is "destructive". (PutValueIntoRange absrow ChangedRowRange) (PutValueIntoRange abscol (igetv ChangedColumnRanges absrow) ))))))))) % Write a character to a range of a row of a virtual screen--useful for % (and optimized for) clearing to the end of a line. (Not optimized for % characters other than blank--could use some more work.) Writes into the % range from LeftCol to RightCol inclusive, lets things "trickle out". (DE WriteToScreenRange (Scrn chr rw LeftCol RightCol) (progn % Ignore the call if the row is outside the screen range. (cond ((GreaterP rw (VirtualScreenHeight scrn)) (return NIL))) % Clip the edges of the range to write to (setf LeftCol (max LeftCol 0)) % We look at the 0'th line in (VirtualImage Scrn) to find its width. (setf RightCol (min RightCol (size (igetv (VirtualImage Scrn) 0)))) (cond % Treat blanks specially ((equal chr (char BLANK)) (prog (OldLeft OldRight BlnkRange) % Get the boundaries of the previous "blank range" for this line. (setf BlnkRange (igetv (BlankRanges Scrn) rw)) (setf OldLeft (MinRange BlnkRange)) (setf OldRight (MaxRange BlnkRange)) % Write blanks out to the ranges that are not already blank (we % depend on "for" loops gracefully handling "empty" ranges). (WriteRange Scrn chr rw LeftCol (min RightCol (sub1 OldLeft))) (WriteRange Scrn chr rw (max LeftCol (add1 OldRight)) RightCol) % Update the "known blank" range. Be "pessimistic", there may be % more blank than this. (But it's to much work to make sure?) (setf (MinRange BlnkRange) LeftCol) (setf (MaxRange BlnkRange) RightCol))) % OTHERWISE (character isn't blank). (T (WriteRange Scrn chr rw LeftCol RightCol))))) % Support for WriteToScreenRange. (DE WriteRange (Scrn chr rw LeftCol RightCol) (for (from i LeftCol RightCol 1) (do (WriteToScreen Scrn chr rw i)))) % Refresh the "new screen image" from the active screen list, regenerating % the mask information and "NewScreenImage". (DE DrawActiveList () (progn % Draw from "back to front". (foreach Scrn in (reverse ActiveScreenList) do (DrawScreenOnTop Scrn)))) % Draw a screen as the topmost "active" screen. If the screen wasn't % previously on the active list, put it there. Otherwise, just put it at % the front of the list. In either case, adjust the "mask" so that the % selected screen dominates anything else--and (re)draw the screen. (DE SelectScreen (Scrn) (cond ((or % If the list is empty or the new screen on top doesn't equal the % current one on top... (null ActiveScreenList) (not (eq Scrn (car ActiveScreenList)))) % ... then actually do something. I.e. don't bother doing anything % if we're selecting the current topmost screen. (progn % If this screen hasn't yet been activated (assigned a mask number) (cond ((minusp (MaskNumber Scrn)) % ... then give it one. (progn % Complain if we've run out of mask numbers. (cond ((null FreeMaskList) (ERROR "No masks left to allocate"))) % otherwise, assign the first free number. (setf (MaskNumber Scrn) (prog1 (car FreeMaskList) (setf FreeMaskList (cdr FreeMaskList)))))) % If it's already there, then delete the screen from its current % location in the list. (T (setf ActiveScreenList (DelQIP Scrn ActiveScreenList)))) % Put the screen onto the front of the list. (setf ActiveScreenList (cons Scrn ActiveScreenList)) % (re)draw the screen itself, regenerating the mask too. (DrawScreenOnTop Scrn))))) % Remove a screen from the active list (and from the physical screen). % (Do nothing if the screen isn't on the list?) (DE DeSelectScreen (Scrn) (prog (AbsLeftCol AbsRightCol linewidth) (setf ActiveScreenList (DelQIP Scrn ActiveScreenList)) % Make the mask number available for re-use. (setf FreeMaskList (cons (MaskNumber Scrn) FreeMaskList)) % Give the screen an invalid mask number. (setf (MaskNumber Scrn) -1) (setf AbsLeftCol (max % Absolute location of left column 0 (ScreensColumnLocation Scrn))) (setf AbsRightCol (min MaxPhysicalColumn (plus (VirtualScreenWidth Scrn) (ScreensColumnLocation Scrn)))) % Line width--add one to compensate for zero indexing. (setf linewidth (add1 (difference AbsRightCol AbsLeftCol))) % Erase the virtual screen from NewScreenImage. Also, get rid of the % mask. (Being a bit sloppy and perhaps erasing stuff covering this % screen.) (for (from absrow (max 0 (ScreensRowLocation Scrn)) (min MaxPhysicalRow (plus (ScreensRowLocation Scrn) (VirtualScreenHeight Scrn))) 1) (do (progn % First, clear up the NewScreenImage. (FillSubstring (indexn NewScreenImage absrow) % Line to write to AbsLeftCol % Lefthand column of range linewidth % Number of characters to write (char BLANK)) % Character to write % Next, clear up the mask (FillSubstring (indexn MaskInfo absrow) AbsLeftCol linewidth 0) % Zero for no mask present. % Finally, fix up the "changed" information (PutValueIntoRange absrow ChangedRowRange) % Put the left margin of change into the range. (PutValueIntoRange AbsLeftCol (indexn ChangedColumnRanges absrow)) % Then put the right margin into the range. (PutValueIntoRange AbsRightCol (indexn ChangedColumnRanges absrow))))) % Redraw the active stuff. (DrawActiveList))) % "Draw" a virtual screen onto the top of the "new screen image", % regenerate mask information also. (DE DrawScreenOnTop (Scrn) (prog (MskNumber absrow abscol srccol lineimage linewidth) (setf MskNumber (MaskNumber Scrn)) % For each row of the virtual screen ... (for (from i 0 (VirtualScreenHeight Scrn) 1) % update the screen from that row (do (progn (setf lineimage (indexn (VirtualImage Scrn) i)) (setf absrow (plus i (ScreensRowLocation Scrn))) (cond % If this row is (possibly) on the physical screen ... ((and (LeQ 0 absrow) (LeQ absrow MaxPhysicalRow)) % ... then update the mask, and NewScreenImage (progn % Add1 to compensate for zero indexing. (setf linewidth (add1 (VirtualScreenWidth Scrn))) (setf abscol (ScreensColumnLocation Scrn)) % Typically source text comes starting with the leftmost part % of lineimage. (setf srccol 0) % Clip off anything to the left of the physical screen (cond ((LessP abscol 0) (progn (setf linewidth (max 0 (plus linewidth abscol))) (setf srccol (minus abscol)) (setf abscol 0)))) % Fill in the new mask information (FillSubstring % Destination string, namely MaskInfo indexed by absolute % row number of the screen line. (indexn MaskInfo absrow) abscol % Starting location within destination string. linewidth % Number of characters. MskNumber) % The character (mask number) to fill with. % Copy the row on the screen to NewScreenImage. (MoveSubstringToFrom (indexn NewScreenImage absrow) % Destination string lineimage % Source string abscol % Destination index srccol % Source index linewidth) % number of characters to transfer % Update the "change information". (PutValueIntoRange absrow ChangedRowRange) % Put the left margin of change into the range. (PutValueIntoRange abscol (indexn ChangedColumnRanges absrow)) % Then put the right margin into the range. (PutValueIntoRange (min (plus abscol linewidth -1) MaxPhysicalColumn) (indexn ChangedColumnRanges absrow)))))))))) % Redraw the physical screen so that it looks like NewScreenImage. This is % the routine that's responsible for minimizing the characters sent to the % physical terminal. % If the argument is non-NIL then it's OK to % quit refreshing if more input is pending from the terminal (checked on % each line). BUT, we don't "breakout" if we're on the "current" line? % BREAKOUT NOT IMPLEMENTED YET. (DE RefreshPhysicalScreen (BreakoutAllowed) (prog (rw) (setf rw (MinRange ChangedRowRange)) % Write the changed characters out to the physical screen. (while (and (LeQ rw (MaxRange ChangedRowRange)) % **** (ZeroP (CharsInInputBuffer)) %NEEDS MORE THOUGHT! ) % DO ... (progn % Call special routine to hunt down the changed characters, and % call WritePhysicalCharacter for each such beast. (RewriteChangedCharacters % Old line. (igetv PhysicalScreenImage rw) % New line (igetv NewScreenImage rw) % The row number rw % Leftmost change (MinRange (igetv ChangedColumnRanges rw)) % Rightmost change (MaxRange (igetv ChangedColumnRanges rw))) % Flush the output buffer after every line (even if no characters % sent out). (FlushStdOutputBuffer) % Reset the change information for this row--to indicate that there % is no difference between NewScreenImage and PhysicalScreenImage. (alter-range (igetv ChangedColumnRanges rw) MinRange MaxPhysicalColumn MaxRange 0) (incr rw) % Advance to next row. )) % Reinitialize the "change" information to indicate that NewScreenImage % and PhysicalScreenImage agree--up to whatever row we reached before % breakout. (alter-range ChangedRowRange MinRange rw) % Finally--move the cursor to the spot corresponding to the topmost % virtual screen's cursor. (cond % If there are any active screens at all ... (ActiveScreenList % ... then move to appropriate spot. (prog (Scrn) (setf Scrn (car ActiveScreenList)) (MoveToPhysicalLocation (plus (ScreensCursorRow Scrn) (ScreensRowLocation Scrn)) (plus (ScreensCursorColumn Scrn) (ScreensColumnLocation Scrn)) ) % Make sure the characters actually get sent. (FlushStdOutputBuffer)))))) % Write a character onto the physical screen, recording the fact in % PhysicalScreenImage. (May want to hack "RewriteChangedCharacters" to do % the storing into PhysicalScreenImage?) (DE WritePhysicalCharacter (chr rw col) (progn % Move to the appropriate physical location (optimizing cursor motion). (MoveToPhysicalLocation rw col) (PBOUT chr) % Write out the character % Store the new character in the image. (setf (index_screen PhysicalScreenImage rw col) chr) % Need to update our idea of the physical cursor location. % CURRENT CODE IS TERMINAL SPECIFIC (Teleray, maybe others). Needs % to be made more modular. % Step our idea of where the cursor is--unless it's already % jammed against the right margin. (cond ((LessP PhysicalCursorColumn MaxPhysicalColumn) (incr PhysicalCursorColumn))))) % Move a screen's virtual cursor to a location. (The coordinates are % assumed to be OK--this needs more thought! ) (DE MoveToScreenLocation (Scrn rw col) (progn (setf (ScreensCursorRow Scrn) rw) (setf (ScreensCursorColumn Scrn) col))) % Move the cursor to a location on the screen, while trying to minimize the % number of characters sent. (The coordinates are assumed to be OK.) (DE MoveToPhysicalLocation (rw col) (cond % Do nothing if we're already there. ((and (equal rw PhysicalCursorRow) (equal col PhysicalCursorColumn)) NIL) % If we're on the same row and just past current position, just type % over what's already on the screen. ((and (equal rw PhysicalCursorRow) (LessP PhysicalCursorColumn col) (LessP col (plus PhysicalCursorColumn 4))) % ... then ... (progn % DOES THIS WORK when jammed against right margin? (for (from i PhysicalCursorColumn (sub1 col) 1) (do (PBOUT (index_screen PhysicalScreenImage rw i)))) % Store our new location (setf PhysicalCursorColumn col))) % Finally, the most general case (T (progn (SetTerminalCursor col rw) (setf PhysicalCursorRow rw) (setf PhysicalCursorColumn col))))) (DE ClearPhysicalScreen () (progn (EraseScreen) % Erase the real live terminal's screen. % That should move the cursor to the upper left hand corner, so reflect % that fact in our image of the cursor. (setf PhysicalCursorRow 0) (setf PhysicalCursorColumn 0) % Now clear our image of what's on the screen. (for (from rw 0 MaxPhysicalRow 1) % Fill each row with blanks. (do (FillSubstring (indexn PhysicalScreenImage rw) 0 % Starting point in destination string (add1 MaxPhysicalColumn) % Number of characters (char BLANK)))) % Character code to fill with % Set "change info" to show the PhysicalScreenImage and NewScreenImage % differ, assume that the worst case holds. (alter-range ChangedRowRange MinRange 0 MaxRange MaxPhysicalRow) (for (from i 0 MaxPhysicalRow 1) (do (alter-range (indexn ChangedColumnRanges i) MinRange 0 MaxRange MaxPhysicalColumn))))) |
Added psl-1983/emode/vs-demo.red version [94f241cca1].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Create a small virtual screen, 10 by 10 characters, starting at % row 8 column 10. (Remember the upper left hand corner is Row 0, Column 0.) s1 := CreateVirtualScreen(10, 10, 8, 10); % Fill the small screen with the letter A. for i := 0:9 do for j := 0:9 do WriteToScreen(s1, char A, i, j); % In normal "two window mode" there are 4 active screens, so the length of % the list will be 4. length activescreenlist; % Selecting s1 gives us 5 active screens, and displays s1. % However, the "main" screen will partly cover s1. SelectScreen(s1); % Deselecting s1 gives us 4 active screens. DeSelectScreen(s1); % Execute this FOR loop to see how stuff on the bottom window scrolls % beneath s1. for i := 1:30 do write i, " ",i^2, " ", i^3; |
Added psl-1983/emode/vs-support.sl version [37da8a7920].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % VS-SUPPORT.SL - "Fast" routines to support the "virtual-screen" package. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 August 1982 % % This revised version takes advantage of TerminalClearEOL. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load fast-vector)) (de RewriteChangedCharacters (oldline newline RowLocation LeftCol RightCol) % A rather specialized routine to look for characters that differ between % oldline and newline, and to write those out to the screen. The search is % limited to run from LeftCol to RightCol. RowLocation is simply passed on % to WritePhysicalCharacter. (prog (last-nonblank-column) % Check to see whether a Clear-EOL is appropriate. It is appropriate if % the rightmost changed character has been changed to a BLANK, and the % remainder of the line is blank. If this is the case, we determine the % column to clear from, clear out the old line, and (after outputting prior % changed characters), do the Clear-EOL. % Find out where the rightmost changed character actually is: (while (and (WLEQ LeftCol RightCol) (WEQ (igets newline RightCol) (igets oldline RightCol))) (setf RightCol (WDifference RightCol 1)) ) (if (WGreaterP LeftCol RightCol) (return NIL)) % No change at all! % If the rightmost changed character is being changed to a space, then find % out if the rest of the line is blank. If it is, then set the variable % LAST-NONBLANK-COLUMN to the appropriate value and clear out OLDLINE in % preparation for a later ClearEOL. Otherwise, LAST-NONBLANK-COLUMN % remains NIL. (if (WEQ (igets newline RightCol) (char space)) (progn (setf last-nonblank-column (size newline)) (while (and (WGEQ last-nonblank-column 0) (WEQ (igets newline last-nonblank-column) (char space)) ) (setf last-nonblank-column (WDifference last-nonblank-column 1)) ) (if (WLessP last-nonblank-column RightCol) (while (> RightCol last-nonblank-column) (iputs oldline RightCol (char space)) (setf RightCol (WDifference RightCol 1)) ) ))) % Output all changed characters (other than those that will be taken care % of by ClearEOL): (while (WLEQ LeftCol RightCol) (let ((ch (igets newline LeftCol))) (if (WNEQ ch (igets oldline LeftCol)) (WritePhysicalCharacter ch RowLocation LeftCol) )) (setf LeftCol (wplus2 LeftCol 1)) ) % Do the ClearEOL, if that's what we decided to do. (if last-nonblank-column (progn (MoveToPhysicalLocation RowLocation (WPlus2 last-nonblank-column 1)) (TerminalClearEOL) )) )) |
Added psl-1983/emode/vt100.sl version [c7d6752b6d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % VT100.SL - EMODE support for VT100 terminals % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#177) (DE EraseScreen () (progn % First, erase the screen (PBOUT (Char ESC)) (PBOUT (Char ![)) (PBOUT (Char 2)) (PBOUT (Char J)) % Then make sure the cursor's at home. (SetTerminalCursor 0 0) )) (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char ![)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (Char ![)) % Use "quick and dirty" conversion to decimal digits. (PBOUT (plus (char 0) (quotient (add1 RowLoc) 10))) (PBOUT (plus (char 0) (remainder (add1 RowLoc) 10))) % Delimiter between row digits and column digits. (PBOUT (char !;)) (PBOUT (plus (char 0) (quotient (add1 ColLoc) 10))) (PBOUT (plus (char 0) (remainder (add1 ColLoc) 10))) (PBOUT (char H)) % Terminate the sequence )) |
Added psl-1983/emode/vt52.sl version [556904cc98].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % VT52.SL - EMODE support for VT52 terminals. (Same as Teleray except for % parity_mask?) % % Author: William F. Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 June 1982 % Copyright (c) 1982 University of Utah % % Screen starts at (0,0), and other corner is offset by (79,23) (total % dimensions are 80 wide by 24 down) (setf ScreenBase (Coords 0 0)) (setf ScreenDelta (Coords 79 23)) % Parity mask is used to clear "parity bit" for those terminals that don't % have a meta key. It should be 8#177 in that case. Should be 8#377 for % terminals with a meta key. (setf parity_mask 8#177) (DE EraseScreen () (PBOUT (Char FF))) % Form feed to clear the screen (DE Ding () (PBOUT (Char Bell))) % Clear to end of line from current position (inclusive). (DE TerminalClearEol () (progn (PBOUT (Char ESC)) (PBOUT (Char K)))) % Move physical cursor to Column,Row (DE SetTerminalCursor (ColLoc RowLoc) (progn (PBOUT (char ESC)) (PBOUT (char Y)) (PBOUT (plus (char BLANK) RowLoc)) (PBOUT (plus (char BLANK) ColLoc)))) |
Added psl-1983/emode/win-demo.red version [2764d248c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | procedure BufferNames; Mapcar(WindowList,'cdar); BufferNames(); procedure FindWindowName N; FindWindowField('WindowsBufferName,N); procedure FindWindowField(F,N); begin scalar x; x:=WindowList; l: if null x then return NIL; if Cdr atsoc(F,car x) eq N then return car x; x:=cdr x; goto l end; procedure SelectName N; Begin scalar x; x:=FindWindowName N; SelectWindow x; end; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Following stuff is used to set up a BREAK window << % Create the BREAK buffer BreakBuffer:=CreateBuffer('!B!r!e!a!k, eval DefaultMode); % Create the window to look into the buffer. BreakWindow := FramedWindowDescriptor('!B!r!e!a!k, % Starts at column 50, Near top of screen Coords(50,1), % Dimensions are roughly 29 by 10? Coords(28,9)); % Set up the buffer text. SelectBuffer '!B!r!e!a!k; !$CRLF(); Insert_string("q % To quit"); !$CRLF(); Insert_string("t % To traceback"); !$CRLF(); Insert_string("i % Trace interpreted stuff"); !$CRLF(); Insert_string("r % Retry"); !$CRLF(); Insert_string("c %Continue,"); !$CRLF(); Insert_string(" %using last value"); !$CRLF(); DeselectBuffer '!B!r!e!a!k; CopyD('Oldbreak,'Break); Flag('(Break),'User); >>; procedure Break; Begin Scalar W; W:=CurrentWindowdescriptor; SelectWindow BreakWindow$ !$BeginningOfBuffer(); % Place point at start of buffer. % Transfer control to the original break handler. Catch(NIL, OldBreak() ); % When finished, "pop" our screen off of the physical screen. DeselectScreen CurrentVirtualScreen; SelectWindow W; % Back to the window we originally had. % If !*QuitBreak then StdError "exit"; % ???? end; car 1; % Execute this to test the system. |
Added psl-1983/emode/window.sl version [0580324525].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Window.SL - Individual Window Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 July 1982 % % This file contains functions that manipulate individual windows. % It is intended that someday EMODE will be reorganized % so that all such functions will eventually be in this file. % % This file requires COMMON. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(CurrentWindowDelta TopOfDisplayIndex)) (de current-window-height () % Return the number of rows in the current window. (+ (Row CurrentWindowDelta) 1) ) (de current-window-top-line () % Return the index of the buffer line at the top of the current window. TopOfDisplayIndex ) (de current-window-set-top-line (new-top-line) % Change which buffer line displays at the top of the current window. (setf TopOfDisplayIndex new-top-line) ) |
Added psl-1983/emode/windows.sl version [f4056841ca].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Windows.SL - Window Collection Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 July 1982 % % This file contains functions that manipulate the set of existing % windows. It is intended that someday EMODE will be reorganized % so that all such functions will eventually be in this file. % % This file requires COMMON. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(WindowList CurrentWindowDescriptor CurrentBufferName BufferPreviousBuffer WindowsBufferName)) (de window-kill-buffer () % This function disassociates the current window with the buffer % currently associated with that window. If the buffer is not % associated with any other window, it is killed. A new buffer % is selected to become associated with the window. The preferred % choice is the buffer's "previous buffer". (prog (buffer-needed preferred-buffer detached-buffer) (setf detached-buffer WindowsBufferName) (SelectBuffer detached-buffer) % allow access to buffer variables (setf preferred-buffer BufferPreviousBuffer) (setf buffer-needed nil) (for (in WindowDescriptor WindowList) (when (neq WindowDescriptor CurrentWindowDescriptor)) (while (not buffer-needed)) (do (if (and (atsoc 'WindowsBufferName WindowDescriptor) (eq (cdr (atsoc 'WindowsBufferName WindowDescriptor)) detached-buffer)) (setf buffer-needed t))) ) (if (not buffer-needed) (buffer-kill detached-buffer)) (select-buffer-if-existing preferred-buffer) (setf WindowsBufferName CurrentBufferName) (EstablishCurrentMode) (if (not buffer-needed) (write-prompt (BldMsg "Buffer %w deleted." detached-buffer))) )) |
Added psl-1983/full-logical-names.cmd version [cd681c8e46].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ; Officially recognized logical names for FULL set of ; PSL subdirectories on UTAH-20 for V3 PSL distribution ; EDIT <PSL to your <name define psl: <psl> ! Executable files and miscellaneous define pc: <psl.comp> ! Compiler sources define p20c: <psl.20-comp> ! 20 Specific Compiler sources define pd: <psl.doc> ! Documentation files define pnd: <psl.doc-nmode> ! NMODE Documentation files define pe: <psl.emode> ! EMODE support and drivers define pg: <psl.glisp> ! Glisp sources define ph: <psl.help> ! Help files define pk: <psl.kernel> ! Kernel Source files define p20k: <psl.20-kernel> ! 20 Specific Kernel Sources define pl: <psl.lap> ! LAP files define plpt: <psl.lpt> ! Printer version of Documentation define pn: <psl.nmode> ! NMODE editor files define pnk: <psl.nonkernel> ! PSL Non Kernel source files define pt: <psl.tests> ! Test files define p20t: <psl.20-tests> ! 20 Specific Test files define pu: <psl.util> ! Utility program sources define p20u: <psl.20-util> ! 20 Specific Utility files define pw: <psl.windows> ! NMODE Window files take |
Added psl-1983/full-restore.ctl version [45b998604b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve ALL ssnames for FULL PSL system ; First edit FULL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories ; then mount TAPE, def X: @TERM PAGE 0 @DUMPER *tape X: *density 1600 *files *account system-default *restore <*>*.*.* PSL:*.*.* *restore <*>*.*.* PC:*.*.* *restore <*>*.*.* P20C:*.*.* *restore <*>*.*.* PD:*.*.* *restore <*>*.*.* PND:*.*.* *restore <*>*.*.* PE:*.*.* *restore <*>*.*.* PG:*.*.* *restore <*>*.*.* ph:*.*.* *restore <*>*.*.* pk:*.*.* *restore <*>*.*.* p20K:*.*.* *restore <*>*.*.* pl:*.*.* *restore <*>*.*.* plpt:*.*.* *restore <*>*.*.* pn:*.*.* *restore <*>*.*.* pnk:*.*.* *restore <*>*.*.* pT:*.*.* *restore <*>*.*.* p20T:*.*.* *restore <*>*.*.* pu:*.*.* *restore <*>*.*.* p20u:*.*.* *restore <*>*.*.* pw:*.*.* *rewind *unload *exit |
Added psl-1983/full-restore.dif version [6d3b0b093e].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | ; FULL-RESTORE.CTL.5 & FULL-RESTORE.CTL.4 3-Apr-83 1015 PAGE 1 LINE 22, PAGE 1 1) *restore <*>*.*.* p20K:*.*.* 1) *restore <*>*.*.* pl:*.*.* LINE 22, PAGE 1 2) *restore <*>*.*.* p20:*.*.* 2) *restore <*>*.*.* pl:*.*.* LINE 28, PAGE 1 1) *restore <*>*.*.* p20T:*.*.* 1) *restore <*>*.*.* pu:*.*.* LINE 28, PAGE 1 2) *restore <*>*.*.* pT20:*.*.* 2) *restore <*>*.*.* pu:*.*.* |
Added psl-1983/glisp/circle.sl version [9105140291].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % CIRCLE.SL.3 31 Jan. 83 % Test program to draw a circle on a graphics screen. % G. Novak (DG CIRCLE (XSTART:integer YSTART:integer RADIUS:INTEGER) % (* edited: "19-MAR-82 16:31") % (* Draw a circle incrementally.) (PROG (X Y YLAST DELTA NP2) (X_RADIUS) (Y_0) (DELTA_0) (WHILE Y<X DO (YLAST_Y) (DELTA _+ X + X - 1) (WHILE DELTA>0 DO (DELTA _- Y+Y+1) (Y_+1)) (NP2 _(Y - YLAST + 1)/2) (WHILE NP2>0 DO (NP2_-1) (DRAWCIRCLEPOINT X YLAST XSTART YSTART) (YLAST_+1)) (X_-1) (WHILE YLAST<Y DO (DRAWCIRCLEPOINT X YLAST XSTART YSTART) (YLAST_+1))))) % for testing: (de drawcirclepoint (x y xstart ystart) (prin1 x)(prin2 '! )(print y)) (dg oldDRAWCIRCLEPOINT (X:integer Y:integer XSTART:integer YSTART:INTEGER) % (* edited: "19-MAR-82 15:40") (BITMAPBIT XSTART+X YSTART+Y 1) (BITMAPBIT (XSTART - X) YSTART+Y 1) (BITMAPBIT (XSTART - X) (YSTART - Y) 1) (BITMAPBIT XSTART+X (YSTART - Y) 1) (BITMAPBIT XSTART+Y YSTART+X 1) (BITMAPBIT XSTART+Y (YSTART - X) 1) (BITMAPBIT (XSTART - Y) YSTART+X 1) (BITMAPBIT (XSTART - Y) (YSTART - X) 1)) |
Added psl-1983/glisp/gev.old version [4fa9ac1eb1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GEV Editor, PSL version. G. Novak 31 Jan. 1983 [GLISPGLOBALS (GEVACTIVEFLG BOOLEAN ) (GEVCHARWIDTH INTEGER ) (GEVEDITCHAIN EDITCHAIN ) (GEVEDITFLG BOOLEAN ) (GEVMENUWINDOW WINDOW ) (GEVMENUWINDOWHEIGHT INTEGER ) (GEVMOUSEAREA MOUSESTATE ) (GEVSHORTCHARS INTEGER ) (GEVWINDOW WINDOW ) (GEVWINDOWY INTEGER ) ] [GLISPOBJECTS (AREA (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T)) ) (EDITCHAIN (LISTOF EDITFRAME) PROP [(TOPFRAME ((CAR self))) (TOPITEM ((CAR TOPFRAME:PREVS] ) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) (SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM))) ) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) (SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP [(NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = 8* (NCHARS NAME) HEIGHT = 12)) VTYPE GLVTYPE4) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = 8* (NCHARS NAME) HEIGHT = 12] ) (MOUSESTATE (LIST (AREA AREA) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER)) ) (DOLPHINREGION (RECORD REGION (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER)) ) (MENU (RECORD MENU (ITEMS (LISTOF ATOM))) MSG ((SELECT MENU RESULT ATOM)) ) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP [(MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y = Y/MAGNITUDE] ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG [(PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI] ) (WINDOW ANYTHING PROP ((REGION ((DSPCLIPPINGREGION NIL self)) RESULT DOLPHINREGION) (XPOSITION ((DSPXPOSITION NIL self)) RESULT INTEGER) (YPOSITION ((DSPYPOSITION NIL self)) RESULT INTEGER) (HEIGHT (REGION:HEIGHT)) (WIDTH (REGION:WIDTH)) (LEFT ((DSPXOFFSET NIL self)) RESULT INTEGER) (BOTTOM ((DSPYOFFSET NIL self)) RESULT INTEGER)) MSG ((CLEAR CLEARW) (OPEN OPENW) (CLOSE CLOSEW)) ) ] (DEFINEQ (AREA-CONTAINS (GLAMBDA (AREA P) % edited: "26-OCT-82 11:45" % Test whether an area contains a point P. (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP))) (GEV [NLAMBDA (VAR STR) % edited: "12-OCT-82 14:19" % GLISP Edit Value function. % Edit VAL according to structure description STR. (PROG (VAL) (SETQ VAL (EVAL VAR)) (SETQ STR (EVAL STR)) (GEVA VAR VAL STR]) (GEVA (GLAMBDA (VAR VAL STR) % edited: "22-DEC-82 14:16" % GLISP Edit Value function. % Edit VAL according to structure description STR. (PROG (GLNATOM TMP HEADER) (OR (AND (BOUNDP (QUOTE GEVWINDOW)) GEVWINDOW) (GEVINITEDITWINDOW)) (OPENW GEVMENUWINDOW) (GEVACTIVEFLG_T) (GEVEDITFLG_NIL) (GLNATOM_0) (GEVSHORTCHARS_27) (GEVCHARWIDTH_7) (IF VAR IS A LIST AND (CAR VAR)='QUOTE THEN VAR_(CONCAT "'" (CADR VAR))) (IF ~STR THEN (IF VAL IS ATOMIC AND (GETPROP VAL (QUOTE GLSTRUCTURE)) THEN STR_'GLTYPE ELSEIF (GEVGLISPP) THEN STR_(GLCLASS VAL))) (HEADER_(A GSEITEM WITH NAME = VAR VALUE = VAL TYPE = STR)) (GEVEDITCHAIN_(LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) (GEVMOUSELOOP)))) (GEVBUTTONEVENTFN [GLAMBDA NIL % edited: "11-NOV-82 16:53" % Respond to a button event within the editing window. (PROG (POS SELECTION TMP TOP N) (GETMOUSESTATE) % Test the state of the left mouse button. (IF (ZEROP (LOGAND LASTMOUSEBUTTONS 4)) THEN % Button is now up. (IF GEVMOUSEAREA THEN (SELECTION_GEVMOUSEAREA) (GEVMOUSEAREA_NIL) (GEVINVERTENTRY SELECTION:AREA GEVWINDOW) % Execute action. (IF SELECTION:FLAG THEN (IF SELECTION:GROUP=1 THEN (TMP_GEVEDITCHAIN:TOPFRAME:PREVS) (N_0) (WHILE TMP AND (TOP-_TMP) <>SELECTION:ITEM DO N_+1) (GEVPOP NIL N) ELSE (GEVPUSH SELECTION:ITEM)) ELSE (PRIN1 SELECTION:ITEM:NAME) (PRIN1 " is ") (PRINTDEF SELECTION:ITEM:TYPE (POSITION T)) (TERPRI)) (RETURN) ELSE % Button is now down. (POS _(A VECTOR WITH X =(LASTMOUSEX GEVWINDOW) Y =(LASTMOUSEY GEVWINDOW))) (IF GEVMOUSEAREA THEN (IF (_ GEVMOUSEAREA:AREA CONTAINS? POS) THEN (RETURN) ELSE % Mouse has moved out of area with button down. (SELECTION_GEVMOUSEAREA) (GEVMOUSEAREA_NIL) (GEVINVERTENTRY SELECTION:AREA GEVWINDOW))) % Try to find an item at current mouse position. (IF GEVMOUSEAREA _(GEVFINDPOS POS GEVEDITCHAIN:TOPFRAME) THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW]) (GEVCOMMANDFN [GLAMBDA (COMMANDWORD:ATOM) % edited: "11-NOV-82 16:20" (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASE COMMANDWORD OF (EDIT (GEVEDIT)) (QUIT (IF GEVMOUSEAREA THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW) (GEVMOUSEAREA_NIL) ELSE (GEVQUIT))) (POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) ELSE (ERROR]) (GEVCOMMANDPROP [GLAMBDA (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) % edited: "22-DEC-82 11:30" (PROG (VAL PROPNAMES FLG) (IF PROPNAME THEN FLG_T) (IF ITEM:TYPE IS ATOMIC THEN (PROPNAMES_(GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME) )) (IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP THEN (IF COMMANDWORD='PROP THEN (IF (CDR PROPNAMES) THEN PROPNAMES+_'All) PROPNAMES+_'self) (IF ~PROPNAMES (RETURN)) [IF ~PROPNAME (PROPNAME _(MENU (create MENU ITEMS _ PROPNAMES] (IF ~PROPNAME (RETURN) ELSEIF PROPNAME='self THEN (PRIN1 PROPNAME) (PRIN1 " = ") (PRINT ITEM:VALUE) ELSEIF COMMANDWORD='PROP AND PROPNAME='All THEN (FOR X IN (OR (CDDR PROPNAMES) (CDR PROPNAMES)) DO (GEVDOPROP ITEM X COMMANDWORD FLG)) ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG)) (IF COMMANDWORD='MSG THEN (GEVREFILLWINDOW) (GEVEDITFLG_T]) (GEVCOMMANDPROPNAMES (GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) % edited: "22-DEC-82 11:09" % Get all property names of properties of type PROPTYPE for OBJ. % Properties are filtered to remove system % properties and those which are already displayed. (PROG (RESULT TYPE) (RESULT _(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN ~(PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME =(CAR P))) AND ~[PROPTYPE='PROP AND (MEMB (CAR P) (QUOTE (SHORTVALUE DISPLAYPROPS] AND ~(PROPTYPE='MSG AND (CADR P) IS ATOMIC AND (~(GETD (CADR P)) OR [LENGTH (CADR (GETD (CADR P] >1)) COLLECT P:NAME)) [FOR S IN OBJ:SUPERS DO (RESULT _(NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME] (RETURN RESULT)))) (GEVCOMPPROP [GLAMBDA (STR:GLTYPE PROPNAME,PROPTYPE:ATOM) % edited: "22-DEC-82 11:17" % Compile a property whose name is PROPNAME and whose % property type (ADJ, ISA, PROP, MSG is PROPTYPE for the % object type STR.) (PROG (PROPENT) (IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) (RETURN (QUOTE GEVERROR))) % If the property is implemented by a named function, % return the function name. (IF (PROPENT_(GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC THEN (RETURN (CADR PROPENT))) % Compile code for this property and save it. % First be sure the GLISP compiler is loaded. (RETURN (COND ((GEVGLISPP) (GLCOMPPROP STR PROPNAME PROPTYPE) OR (QUOTE GEVERROR)) (T (ERROR "GLISP compiler must be loaded for PROPs which are not specified with function name equivalents." (LIST STR PROPTYPE PROPNAME]) (GEVDATANAMES [GLAMBDA (OBJ:GLTYPE FILTER:ATOM) % edited: " 4-NOV-82 16:08" % Get a flattened list of names and types from a given % structure description. (PROG (RESULT) (GEVDATANAMESB OBJ:STRDES FILTER) (RETURN (DREVERSE RESULT]) (GEVDATANAMESB [GLAMBDA (STR:ANYTHING FILTER:ATOM) % edited: " 4-NOV-82 16:07" % Get a flattened list of names and types from a given % structure description. (GLOBAL RESULT) (PROG (TMP) (IF STR IS ATOMIC THEN (RETURN) ELSE (CASE (CAR STR) OF (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER))) (RECORD (FOR X IN (CDDR STR) DO (GEVDATANAMESB X FILTER))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) (LISTOF (RETURN)) ELSE [IF (GEVFILTER (CADR STR) FILTER) THEN (RESULT +_(LIST (CAR STR) (CADR STR] ((GEVDATANAMESB (CADR STR) FILTER]) (GEVDISPLAYNEWPROP (GLAMBDA NIL % edited: "14-OCT-82 15:35" % Display a newly added property in the window. (PROG (Y NEWONE:GSEITEM) (Y_GEVWINDOWY) (NEWONE_(CAR (LAST GEVEDITCHAIN:TOPFRAME:PROPS))) (GEVPPS NEWONE 1 GEVWINDOW Y) (GEVWINDOWY_Y)))) (GEVDOPROP [GLAMBDA (ITEM:GSEITEM PROPNAME,COMMANDWORD:ATOM FLG:BOOLEAN) % edited: "16-OCT-82 16:09" % Add the property PROPNAME of type COMMANDWORD to the % display for ITEM. (PROG (VAL) (VAL_(GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL)) (GEVEDITCHAIN:TOPFRAME:PROPS_+(A GSEITEM WITH NAME = PROPNAME TYPE =(GEVPROPTYPE ITEM:TYPE PROPNAME COMMANDWORD) VALUE = VAL NODETYPE = COMMANDWORD)) (IF ~FLG THEN (GEVDISPLAYNEWPROP]) (GEVEDIT (GLAMBDA NIL % edited: "12-OCT-82 16:34" % Edit the currently displayed item. (PROG (CHANGEDFLG GEVTOPITEM) (GEVTOPITEM_GEVEDITCHAIN:TOPITEM) (IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE (QUOTE EDIT) (QUOTE MSG) NIL) ~='GEVERROR THEN CHANGEDFLG_T ELSEIF GEVTOPITEM:VALUE IS A LIST THEN (EDITV GEVTOPITEM:VALUE) (CHANGEDFLG_T) ELSE (RETURN)) (IF CHANGEDFLG THEN (GEVREFILLWINDOW)) (GEVEDITFLG_CHANGEDFLG)))) (GEVEXPROP [GLAMBDA (OBJ STR PROPNAME,PROPTYPE:ATOM ARGS) % edited: " 4-NOV-82 15:10" % Execute a property whose name is PROPNAME and whose property % type (ADJ, ISA, PROP, MSG is PROPTYPE on the % object OBJ whose type is STR.) (PROG (FN) (IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) OR (ARGS AND PROPTYPE~='MSG) (RETURN (QUOTE GEVERROR))) (IF (FN_(GEVCOMPPROP STR PROPNAME PROPTYPE))='GEVERROR THEN (RETURN FN) ELSE (RETURN (APPLY FN (CONS OBJ ARGS]) (GEVFILLWINDOW (GLAMBDA NIL % edited: "14-OCT-82 15:23" % Fill the GEV editor window with the item which is at % the top of GEVEDITCHAIN. (PROG (Y TOP) (_ GEVWINDOW CLEAR) % Compute an initial Y value for printing titles in the % window. (Y_GEVWINDOW:HEIGHT - 20) % Print the titles from the edit chain first. (TOP_GEVEDITCHAIN:TOPFRAME) (FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 1 GEVWINDOW Y)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:SUBITEMS DO (GEVPPS X 1 GEVWINDOW Y)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:PROPS DO (GEVPPS X 1 GEVWINDOW Y)) (GEVWINDOWY_Y)))) (GEVFILTER (GLAMBDA (TYPE FILTER) % GSN "21-JAN-83 10:24" % Filter types according to a specified FILTER. (TYPE_(GEVXTRTYPE TYPE)) (CASE FILTER OF (NUMBER ~(MEMB TYPE (QUOTE (ATOM STRING BOOLEAN ANYTHING))) AND ~((LISTP TYPE) AND (CAR TYPE)='LISTOF)) (LIST (LISTP TYPE) AND (CAR TYPE)='LISTOF) ELSE T))) (GEVFINDITEMPOS [GLAMBDA (POS:VECTOR ITEM:GSEITEM N:INTEGER) % edited: "14-OCT-82 11:32" (RESULT MOUSESTATE) % Test whether ITEM contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item % and a flag which is NIL if the NAME part is identified, % T if the VALUE part is identified. (OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N) (GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N) ((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF) AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N]) (GEVFINDLISTPOS (GLAMBDA (POS:VECTOR ITEMS:(LISTOF GSEITEM) N) % edited: "13-OCT-82 12:03" (RESULT MOUSESTATE) % Find some ITEM corresponding to the mouse position POS. (IF ITEMS THEN (GEVFINDITEMPOS POS (CAR ITEMS) N) OR (GEVFINDLISTPOS POS (CDR ITEMS) N)))) (GEVFINDPOS (GLAMBDA (POS:VECTOR FRAME:EDITFRAME) % edited: "13-OCT-82 12:06" (RESULT MOUSESTATE) % Find the sub-item of FRAME corresponding to the mouse position POS. % The result is NIL if not found, else a list % of the sub-item and a flag which is NIL if the NAME part is identified, % T if the VALUE part is identified. (PROG (TMP N ITEMS:(LISTOF GSEITEM)) (N_0) (WHILE FRAME AND ~TMP DO (N_+1) ITEMS-_FRAME (TMP_(GEVFINDLISTPOS POS ITEMS N))) (RETURN TMP)))) (GEVGETNAMES [GLAMBDA (OBJ:GLTYPE FILTER:ATOM) % edited: "22-DEC-82 14:53" % Get all names of properties and stored data from a GLISP object type. (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES (GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ (QUOTE PROP) FILTER)) (RETURN (NCONC DATANAMES PROPNAMES]) (GEVGETPROP [GLAMBDA (STR PROPNAME,PROPTYPE:ATOM) % edited: "14-OCT-82 12:50" % Retrieve a GLISP property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG is PROPTYPE for the object type STR.) (PROG (PL SUBPL PROPENT) (IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) (ERROR)) (RETURN (AND (PL_(GETPROP STR (QUOTE GLSTRUCTURE))) (SUBPL_(LISTGET (CDR PL) PROPTYPE)) (PROPENT_(ASSOC PROPNAME SUBPL]) (GEVGLISPP [LAMBDA NIL % edited: "11-NOV-82 15:53" (BOUNDP (QUOTE GLBASICTYPES]) (GEVHORIZLINE (GLAMBDA (W:WINDOW) % edited: "14-OCT-82 09:42" (GLOBAL Y:INTEGER) % Draw a horizontal line across window W at Y and decrease Y. (DRAWLINE 1 Y+4 W:WIDTH Y+4 1 (QUOTE PAINT) WINDOW) (Y_-12))) (GEVINIT [LAMBDA NIL % edited: "15-OCT-82 17:16" (SETQ GLNATOM 0) (SETQ GEVWINDOW NIL]) (GEVINITEDITWINDOW [LAMBDA NIL % edited: " 6-OCT-82 16:29" % Initialize an edit window for the GLISP structure editor. (PROG (GEVMENU (LEFT 600) (BOTTOM 200) (WIDTH 300) (HEIGHT 400)) (SETQ GEVWINDOW (CREATEW (create REGION LEFT _ LEFT BOTTOM _ BOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT) "GEV Structure Editor Window")) (SETQ GEVMOUSEAREA NIL) (WINDOWPROP GEVWINDOW (QUOTE BUTTONEVENTFN) (QUOTE GEVBUTTONEVENTFN)) (WINDOWPROP GEVWINDOW (QUOTE MOVEFN) (QUOTE GEVMOVEWINDOWFN)) (SETQ GEVMENUWINDOWHEIGHT 40) (SETQ GEVMENUWINDOW (CREATEW (create REGION LEFT _ LEFT BOTTOM _(IDIFFERENCE BOTTOM GEVMENUWINDOWHEIGHT) WIDTH _ WIDTH HEIGHT _ GEVMENUWINDOWHEIGHT) NIL 0)) (SETQ GEVMENU (create MENU ITEMS _(QUOTE (QUIT POP EDIT PROGRAM PROP ADJ ISA MSG)) CENTERFLG _ T MENUROWS _ 2 MENUFONT _(FONTCREATE (QUOTE HELVETICA) 10 (QUOTE BOLD)) ITEMHEIGHT _ 15 ITEMWIDTH _(IDIFFERENCE (IQUOTIENT WIDTH 4) 2) WHENSELECTEDFN _(QUOTE GEVCOMMANDFN))) (ADDMENU GEVMENU GEVMENUWINDOW) (RETURN GEVWINDOW]) (GEVINVERTENTRY (GLAMBDA (AREA:AREA WINDOW) % edited: " 5-OCT-82 14:43" % Invert the area of WINDOW which is covered by the specified AREA. (BITBLT WINDOW AREA:LEFT AREA:BOTTOM WINDOW AREA:LEFT AREA:BOTTOM AREA:WIDTH AREA:HEIGHT (QUOTE INVERT) (QUOTE REPLACE) NIL NIL))) (GEVLENGTHBOUND [LAMBDA (VAL NCHARS) % edited: "12-OCT-82 12:12" % Bound the length of VAL to NCHARS. (COND ((IGREATERP (NCHARS VAL) NCHARS) (CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS)) "-")) (T VAL]) (GEVMAKENEWFN [GLAMBDA [OPERATION,INPUTTYPE:ATOM SET:(LIST (NAME ATOM) (TYPE GLTYPE)) PATH:(LISTOF (LIST (NAME ATOM) (TYPE GLTYPE] % edited: " 6-NOV-82 14:23" % Make a function to perform OPERATION on set SETNAME % from INPUTTYPE following PATH to get to the data. (PROG (LASTPATH) (SETQ LASTPATH (CAR (LAST PATH))) (RETURN (LIST [LIST (QUOTE GLAMBDA) (LIST (MKATOM (CONCAT (QUOTE GEVNEWFNTOP) ":" INPUTTYPE))) (LIST (QUOTE PROG) (CONS (QUOTE GEVNEWFNVALUE) (CASE OPERATION OF (COLLECT (QUOTE (GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) [TOTAL (QUOTE ((GEVNEWFNSUM 0] [AVERAGE (QUOTE ((GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0] ELSE (ERROR))) [NCONC [LIST (QUOTE FOR) (QUOTE GEVNEWFNLOOPVAR) (QUOTE IN) (MKATOM (CONCAT (QUOTE GEVNEWFNTOP) ":" SET:NAME)) (QUOTE DO) (LIST (QUOTE GEVNEWFNVALUE) (QUOTE _) (DREVERSE (CONS (QUOTE GEVNEWFNLOOPVAR) (MAPCONC PATH (FUNCTION (LAMBDA (X) (LIST (QUOTE OF) (CAR X) (QUOTE THE] (COPY (CASE OPERATION OF [COLLECT (QUOTE ((GEVNEWFNRESULT +_ GEVNEWFNVALUE] [MAXIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR] [MINIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR] [AVERAGE (QUOTE ((GEVNEWFNSUM _+ GEVNEWFNVALUE) (GEVNEWFNCOUNT _+ 1] (TOTAL (QUOTE ((GEVNEWFNSUM _+ GEVNEWFNVALUE] (LIST (QUOTE RETURN) (CASE OPERATION OF (COLLECT (QUOTE (DREVERSE GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) [AVERAGE (QUOTE (QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT] (TOTAL (QUOTE GEVNEWFNSUM] (CASE OPERATION OF (COLLECT (LIST (QUOTE LISTOF) (CADR LASTPATH))) [(MAXIMUM MINIMUM) (LIST (QUOTE LIST) (COPY LASTPATH) (LIST (QUOTE WINNER) (CADR SET:TYPE] (AVERAGE (QUOTE REAL)) (TOTAL (CADR LASTPATH]) (GEVMATCH [GLAMBDA (STR VAL FLG) % edited: " 8-OCT-82 10:43" (RESULT (LISTOF GSEITEM)) % Match a structure description, STR, and a value VAL % which matches that description, to form a structure % editor tree structure. (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) (RETURN (DREVERSE RESULT]) (GEVMATCHA [GLAMBDA (STR VAL FLG) % edited: " 8-OCT-82 10:01" % Make a single item which matches structure STR and value VAL. (PROG (RES) (RES_(GEVMATCH STR VAL FLG)) (IF ~(CDR RES) THEN (RETURN (CAR RES)) ELSE (RETURN (A GSEITEM WITH VALUE = VAL TYPE = STR SUBVALUES = RES NODETYPE =(QUOTE SUBTREE]) (GEVMATCHATOM [GLAMBDA (STR VAL NAME) % edited: " 7-OCT-82 16:38" % Match an ATOM structure to a given value. (PROG (L STRB TMP) (IF VAL IS NOT ATOMIC OR VAL IS NULL THEN (RETURN)) (STRB_(CADR STR)) (IF (CAR STRB) ~='PROPLIST THEN (RETURN)) (L_(CDR STRB)) (FOR X IN L DO (IF TMP_(GETPROP VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHALIST [GLAMBDA (STR VAL NAME) % edited: " 7-OCT-82 16:57" % Match an ALIST structure to a given value. (PROG (L TMP) (L_(CDR STR)) (FOR X IN L DO (IF TMP_(ASSOC (CAR X) VAL) THEN (GEVMATCHB X (CDR TMP) NIL NIL]) (GEVMATCHB [GLAMBDA (STR:(LISTOF ANYTHING) VAL NAME:ATOM FLG:BOOLEAN) % edited: "22-DEC-82 15:26" % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor % tree structure. If FLG is set, the match will descend inside an atomic % type name. Results are added to the free variable RESULT. (GLOBAL RESULT) (PROG (X Y STRB XSTR TOP TMP) (XSTR_(GEVXTRTYPE STR)) (IF STR IS ATOMIC THEN (IF FLG AND [STRB _(CAR (GETPROP STR (QUOTE GLSTRUCTURE] THEN (RESULT +_(A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES =( GEVMATCH STRB VAL NIL) TYPE = STR NODETYPE =(QUOTE STRUCTURE))) ELSE (RESULT +_(A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) (RETURN) ELSE (CASE (CAR STR) OF (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB (CADDR STR) (CDR VAL) NIL NIL)) [LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL) NIL NIL) (VAL_(CDR VAL] (ATOM (GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST (GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) (RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) (GEVMATCHOBJECT STR VAL NAME)) ELSE (IF NAME THEN (TMP _(GEVMATCH STR VAL NIL)) (TOP_(CAR TMP)) [RESULT +_(IF ~(CDR TMP) AND ~TOP:NAME THEN (TOP:NAME_NAME) TOP ELSE (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = TMP TYPE = XSTR NODETYPE =( QUOTE SUBTREE] ELSEIF (STRB _(GEVXTRTYPE (CADR STR))) IS ATOMIC THEN (GEVMATCHB STRB VAL (CAR STR) NIL) ELSEIF (TMP_(GEVMATCH (CADR STR) VAL NIL)) THEN (TOP_(CAR TMP)) [RESULT +_(IF ~(CDR TMP) AND ~TOP:NAME THEN (TOP:NAME_(CAR STR)) TOP ELSE (A GSEITEM WITH NAME =(CAR STR) VALUE = VAL SUBVALUES = TMP TYPE =( CADR STR) NODETYPE =(QUOTE SUBTREE] ELSE (PRINT "GEVMATCHB Failed"]) (GEVMATCHLISTOF (GLAMBDA (STR VAL NAME) % edited: " 8-OCT-82 10:15" % Match a LISTOF structure. (GLOBAL RESULT) (RESULT+_(A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR)))) (GEVMATCHOBJECT [GLAMBDA (STR VAL NAME) % edited: "22-DEC-82 10:04" % Match the OBJECT structures. (GLOBAL RESULT) (PROG ((OBJECTTYPE (CAR STR)) TMP) (RESULT _+(A GSEITEM WITH NAME =(QUOTE CLASS) VALUE =[CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (TMP-_VAL)) (ATOMOBJECT (GETPROP VAL (QUOTE CLASS] TYPE =(QUOTE GLTYPE))) (FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (IF VAL (GEVMATCHB X (TMP-_VAL) NIL NIL))) (ATOMOBJECT (IF TMP_(GETPROP VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHPROPLIST [GLAMBDA (STR VAL NAME) % edited: "24-NOV-82 16:31" % Match an PROPLIST structure to a given value. (PROG (L TMP) (L_(CDR STR)) (FOR X IN L DO (IF TMP_(LISTGET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHRECORD [GLAMBDA (STR VAL NAME) % edited: "21-DEC-82 17:32" % Match a RECORD structure. (PROG (STRNAME FIELDS) (IF (CADR STR) IS ATOMIC THEN STRNAME_(CADR STR) FIELDS_(CDDR STR) ELSE FIELDS_(CDR STR)) (FOR X IN FIELDS DO (GEVMATCHB X (RECORDACCESS (CAR X) VAL NIL NIL STRNAME) NIL NIL]) (GEVMOUSELOOP (GLAMBDA NIL % edited: "27-SEP-82 16:24" % Wait in a loop for mouse actions within the edit window. (PROG NIL))) (GEVMOVEWINDOWFN [LAMBDA (W NEWPOS) % edited: " 5-OCT-82 11:36" (PROG NIL (MOVEW GEVMENUWINDOW (CONS (CAR NEWPOS) (IDIFFERENCE (CDR NEWPOS) GEVMENUWINDOWHEIGHT]) (GEVPOP (GLAMBDA (FLG:BOOLEAN N:INTEGER) % GSN "21-JAN-83 13:50" % Pop up from the current item to the previous one. % If FLG is set, popping continues through extended LISTOF % elements. (PROG (TMP TOP:GSEITEM TMPITEM) (IF N<1 (RETURN)) LP (TMP-_GEVEDITCHAIN) (IF ~GEVEDITCHAIN THEN (RETURN (GEVQUIT))) (TOP_(CAAAR GEVEDITCHAIN)) % Test for repeated LISTOF elements. (TMPITEM_(CAR TMP:PREVS)) (IF FLG AND TMPITEM:NODETYPE='FORWARD THEN (GO LP)) (IF (N_-1) >0 THEN (GO LP)) (IF TOP:TYPE IS A LIST AND (CAR TOP:TYPE)='LISTOF AND ~(CDR TOP:VALUE) THEN (GO LP)) (IF GEVEDITFLG AND ~(MEMBER TMPITEM:SHORTVALUE (QUOTE ("(...)" "---"))) THEN (GEVREFILLWINDOW) ELSE GEVEDITFLG_NIL (GEVFILLWINDOW)) (GEVMOUSELOOP)))) (GEVPOSTEST (GLAMBDA (POS,TPOS:VECTOR NAME ITEM:GSEITEM FLG N:INTEGER) % edited: "21-OCT-82 10:54" (RESULT MOUSESTATE) % Test whether TPOS contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item % and a flag which is NIL if the NAME part is identified, T if the % VALUE part is identified. (IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+12 AND POS:X>=TPOS:X AND POS:X<TPOS:X+100 THEN (A MOUSESTATE WITH AREA = (AN AREA WITH START =(A VECTOR WITH X = TPOS:X Y = TPOS:Y - 1) SIZE =(A VECTOR WITH X = GEVCHARWIDTH*(NCHARS NAME) Y = 12)) ITEM = ITEM FLAG = FLG GROUP = N)))) (GEVPPS [GLAMBDA (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) % GSN "21-JAN-83 10:25" (GLOBAL Y:INTEGER) % Pretty-print a structure defined by ITEM in the window WINDOW, beginning % at horizontal column COL and vertical % position Y. The positions in ITEM are modified to match the positions in % the window. (PROG (NAMEX VALX TOP) % Make sure there is room in window. (IF Y<0 THEN (RETURN)) % Position in window for slot name. (NAMEX_COL*GEVCHARWIDTH) (ITEM:NAMEPOS:X_NAMEX) (ITEM:NAMEPOS:Y_Y) (MOVETO NAMEX Y WINDOW) (IF ITEM:NODETYPE='FULLVALUE THEN (PRIN1 "(expanded)" WINDOW) ELSEIF ITEM:NAME THEN (IF ITEM:NAME IS NUMERIC THEN (PRIN1 "#" WINDOW)) (PRIN1 (GEVLENGTHBOUND ITEM:NAME 11) WINDOW)) % See if there is a value to print for this name. (IF ~ITEM:NODETYPE OR (MEMB ITEM:NODETYPE (QUOTE (FORWARD BACKUP PROP ADJ MSG ISA))) THEN (VALX_NAMEX+100) (ITEM:VALUEPOS:X_VALX) (ITEM:VALUEPOS:Y_Y) (MOVETO VALX Y WINDOW) (PRIN1 [ITEM:SHORTVALUE OR (ITEM:SHORTVALUE _(GEVSHORTVALUE ITEM:VALUE ITEM:TYPE (GEVSHORTCHARS - COL] WINDOW) (IF ~(EQ ITEM:SHORTVALUE ITEM:VALUE) THEN (MOVETO (VALX - 20) Y WINDOW) (PRIN1 "~" WINDOW)) (Y_-12) ELSEIF ITEM:NODETYPE='FULLVALUE THEN (Y_-12) (MOVETO 0 Y WINDOW) (RESETLST (RESETSAVE SYSPRETTYFLG T) (SHOWPRINT ITEM:VALUE WINDOW)) (Y_WINDOW:YPOSITION - 12) ELSEIF ITEM:NODETYPE='DISPLAY THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE GEVDISPLAY) (QUOTE MSG) (LIST WINDOW Y)) ELSE % This is a subtree Y_-12 (FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW]) (GEVPROGRAM (GLAMBDA NIL % GSN "21-JAN-83 10:56" % Write an interactive program involving the current item. (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF [COMMAND_(MENU (create MENU ITEMS _(QUOTE (Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM] ='Quit OR ~ COMMAND THEN (RETURN)) (IF (SET_(GEVPROPMENU TOPITEM:TYPE (QUOTE LIST) NIL))='Quit OR SET='Pop OR ~SET THEN (RETURN)) (PATH_(LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE))) (NEXT_SET) (TYPE_(CADADR SET)) (WHILE ~DONE AND ~ABORTFLG DO (NEXT_(GEVPROPMENU TYPE (COMMAND~='COLLECT AND (QUOTE NUMBER)) COMMAND='COLLECT)) [CASE NEXT OF ((NIL Quit) (ABORTFLG_T)) [Pop (IF ~(CDDR PATH) THEN (ABORTFLG_T) ELSE (NEXT-_PATH) (NEXT_(CAR PATH)) (TYPE_(CADR NEXT)) (IF TYPE IS A LIST THEN TYPE_(CADR TYPE)) (LAST_(CAR NEXT] (Done (DONE_T)) ELSE (PROGN (PATH+_NEXT) (TYPE_(CADR NEXT)) (LAST_(CAR NEXT] (IF (MEMB TYPE (QUOTE (ATOM INTEGER STRING REAL BOOLEAN NIL))) DONE_T)) (IF ABORTFLG (RETURN)) (PATH_(DREVERSE PATH)) (NEWFN_(GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH))) (PUTD (QUOTE GEVNEWFN) (CAR NEWFN)) (RESULT_(GEVNEWFN TOPITEM:VALUE)) % Print result as well as displaying it. (PRIN1 COMMAND) (SPACES 1) (FOR X IN (CDDR PATH) DO (PRIN1 (CAR X)) (SPACES 1)) (PRIN1 "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) (PRIN1 " = ") (PRINT RESULT) (GEVEDITCHAIN:TOPFRAME:PROPS_+(A GSEITEM WITH NAME =(CONCAT COMMAND " " LAST) TYPE =(CADR NEWFN) VALUE = RESULT NODETYPE =(QUOTE MSG))) (GEVDISPLAYNEWPROP)))) (GEVPROPMENU [GLAMBDA (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) % GSN "21-JAN-83 10:32" % Make a menu to get properties of object OBJ with filter FILTER. FLG % is T if it is okay to stop before reaching a basic type. (PROG (PROPS SEL PNAMES MENU) (PROPS_(GEVGETNAMES OBJ FILTER)) (IF ~PROPS THEN (RETURN) ELSE (PNAMES_(MAPCAR PROPS (FUNCTION CAR))) (SEL_(SEND [A MENU WITH ITEMS =(CONS (QUOTE Quit) (CONS (QUOTE Pop) (IF FLG THEN (CONS (QUOTE Done) PNAMES) ELSE PNAMES] SELECT)) (RETURN (CASE SEL OF ((Quit Pop Done NIL) SEL) ELSE (ASSOC SEL PROPS]) (GEVPROPNAMES (GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) % edited: "22-DEC-82 14:52" % Get all property names and types of properties of % type PROPTYPE for OBJ when they satisfy FILTER. (PROG (RESULT TYPE) (RESULT _(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN (TYPE_(GEVPROPTYPE! OBJ P:NAME (QUOTE PROP))) AND (GEVFILTER TYPE FILTER) COLLECT (LIST P:NAME TYPE))) [FOR S IN OBJ:SUPERS DO (RESULT _(NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER] (RETURN RESULT)))) (GEVPROPTYPE [GLAMBDA (STR,PROPNAME,PROPTYPE:ATOM) % edited: "22-DEC-82 13:56" % Find the type of a computed property. (PROG (PL SUBPL PROPENT TMP) (IF STR IS NOT ATOMIC THEN (RETURN) ELSEIF (PROPENT_(GEVGETPROP STR PROPNAME PROPTYPE)) AND (TMP_(LISTGET (CDDR PROPENT) (QUOTE RESULT))) THEN (RETURN TMP) ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP_(GETPROP (CADR PROPENT) (QUOTE GLRESULTTYPE)) ) THEN (RETURN TMP) ELSEIF (AND (PL_(GETPROP STR (QUOTE GLPROPFNS))) (SUBPL_(ASSOC PROPTYPE PL)) (PROPENT_(ASSOC PROPNAME (CDR SUBPL))) (TMP_(CADDR PROPENT))) THEN (RETURN TMP) ELSEIF PROPTYPE='ADJ THEN (RETURN (QUOTE BOOLEAN]) (GEVPROPTYPE! [LAMBDA (OBJ NAME TYPE) % edited: " 4-NOV-82 15:39" (OR (GEVPROPTYPE OBJ NAME TYPE) (AND (GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE]) (GEVPUSH (GLAMBDA (ITEM:GSEITEM) % GSN "24-JAN-83 14:14" % Push down to look at an item referenced from the current item. (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (IF ITEM:NODETYPE='BACKUP THEN (GEVPOP NIL 1) (RETURN)) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF ITEM:NODETYPE='FORWARD THEN (NEWITEMS_(GEVPUSHLISTOF ITEM T)) ELSEIF ITEM:TYPE IS ATOMIC AND ~(GETPROP ITEM:TYPE (QUOTE GLSTRUCTURE)) THEN (CASE ITEM:TYPE OF [(ATOM NUMBER REAL INTEGER STRING ANYTHING) (IF ITEM:VALUE=ITEM:SHORTVALUE THEN (RETURN) ELSE (NEWITEMS_(LIST (A GSEITEM WITH NAME = ITEM:NAME VALUE = ITEM:VALUE SHORTVALUE = ITEM:SHORTVALUE TYPE = ITEM:TYPE NODETYPE =(QUOTE FULLVALUE] ELSE (RETURN)) ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF THEN (NEWITEMS_(GEVPUSHLISTOF ITEM NIL))) (GEVEDITCHAIN+_(AN EDITFRAME WITH PREVS =(CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS) SUBITEMS = NEWITEMS)) % Do another PUSH automatically for a list of only one item. (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF AND ~(CDR ITEM:VALUE) THEN (LSTITEM_(CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN)) (GEVMOUSELOOP)))) (GEVPUSHLISTOF [GLAMBDA (ITEM:GSEITEM FLG:BOOLEAN) % edited: "16-OCT-82 15:15" % Push into a datum of type LISTOF, expanding it into the individual elements. If FLG is set, ITEM is a FORWARD item to be continued. (PROG (ITEMTYPE TOPFRAME N:INTEGER NROOM LST VALS:(LISTOF ANYTHING) TMP) % Compute the vertical room available in the window. (IF ~ITEM:VALUE (RETURN)) (TOPFRAME_GEVEDITCHAIN:TOPFRAME) (NROOM _(GEVWINDOW:HEIGHT - 50)/12 -(LENGTH TOPFRAME:PREVS)) % If there was a previous display of this list, insert an ellipsis header. (IF FLG THEN (LST+_(A GSEITEM WITH SHORTVALUE = "(..." NODETYPE =(QUOTE BACKUP))) (N_ITEM:NAME) (ITEMTYPE_ITEM:TYPE) (NROOM_-1) (VALS_ITEM:SUBVALUES) ELSE (N_1) (ITEMTYPE_(CADR ITEM:TYPE)) (VALS_ITEM:VALUE)) % Now make entries for each value on the list. (WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~(CDR VALS))) DO (LST+_(A GSEITEM WITH VALUE =(TMP-_VALS) , TYPE = ITEMTYPE NAME = N)) (NROOM_-1) (N_+1)) (IF VALS THEN (LST+_(A GSEITEM WITH SHORTVALUE = "...)" NODETYPE =(QUOTE FORWARD) TYPE = ITEMTYPE NAME = N SUBVALUES = VALS))) (RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = ITEMTYPE NODETYPE =(QUOTE LISTOF) SUBVALUES =(DREVERSE LST]) (GEVQUIT (GLAMBDA NIL % edited: "13-OCT-82 10:55" (SETQ GEVACTIVEFLG NIL) (_ GEVWINDOW CLOSE) (_ GEVMENUWINDOW CLOSE))) (GEVREDOPROPS [GLAMBDA (TOP:EDITFRAME) % edited: "19-OCT-82 10:23" % Recompute property values for the item. (PROG (ITEM L) (ITEM_(CAR TOP:PREVS)) (IF ~TOP:PROPS AND (L_(GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE DISPLAYPROPS) (QUOTE PROP) NIL)) ~='GEVERROR THEN (IF L IS ATOMIC THEN (GEVCOMMANDPROP ITEM (QUOTE PROP) (QUOTE All)) ELSEIF L IS A LIST THEN (FOR X IN L (GEVCOMMANDPROP ITEM (QUOTE PROP) X))) ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG DO (X:VALUE _(GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL)) (X:SHORTVALUE _ NIL]) (GEVREFILLWINDOW (GLAMBDA NIL % edited: "14-OCT-82 12:46" % Re-expand the top item of GEVEDITCHAIN, which may have been changed due to editing. (PROG (TOP TOPITEM SUBS TOPSUB) (TOP_GEVEDITCHAIN:TOPFRAME) (TOPITEM_GEVEDITCHAIN:TOPITEM) (TOPSUB_(CAR TOP:SUBITEMS)) [IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF) THEN (IF (GEVGETPROP TOPITEM:TYPE (QUOTE GEVDISPLAY) (QUOTE MSG)) THEN [TOP:SUBITEMS_(LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE TYPE = TOPITEM:TYPE NODETYPE =(QUOTE DISPLAY] ELSE (SUBS_(GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T)) (TOPSUB_(CAR SUBS)) (TOP:SUBITEMS_(IF ~(CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE AND TOPSUB:VALUE=TOPITEM:VALUE AND TOPSUB:TYPE=TOPITEM:TYPE THEN TOPSUB:SUBVALUES ELSE SUBS] (GEVREDOPROPS TOP) (GEVFILLWINDOW)))) (GEVSHORTATOMVAL [LAMBDA (ATM NCHARS) % edited: " 8-OCT-82 15:41" (COND ((NUMBERP ATM) (COND ((IGREATERP (NCHARS ATM) NCHARS) (GEVSHORTSTRINGVAL (MKSTRING ATM) NCHARS)) (T ATM))) ((IGREATERP (NCHARS ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM]) (GEVSHORTCONSVAL [GLAMBDA (VAL STR NCHARS:INTEGER) % edited: " 8-OCT-82 15:19" % Compute a short value for printing a CONS of two items. (PROG (NLEFT RES TMP NC) (RES +_ "(") (NLEFT _ NCHARS - 5) (TMP_(GEVSHORTVALUE (CAR VAL) (CADR STR) NLEFT - 3)) (NC_(NCHARS TMP)) (IF NC>NLEFT - 3 THEN TMP_ "---" NC_3) (RES+_TMP) (RES +_ " . ") (NLEFT_-NC) (TMP_(GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) (NC_(NCHARS TMP)) (IF NC>NLEFT THEN TMP_ "---" NC_3) (RES+_TMP) (RES+_ ")") (RETURN (APPLY (FUNCTION CONCAT) (DREVERSE RES]) (GEVSHORTLISTVAL [GLAMBDA (VAL STR NCHARS:INTEGER) % edited: " 6-NOV-82 15:01" % Compute a short value for printing a list of items. (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (RES +_ "(") (REST_4) (NLEFT _ NCHARS - 2) (RSTR_(CDR STR)) [WHILE VAL AND ~QUIT AND (NCI_(IF (CDR VAL) THEN NLEFT - REST ELSE NLEFT)) >2 DO (TMP_(GEVSHORTVALUE (CAR VAL) (IF (CAR STR)='LISTOF THEN (CADR STR) ELSEIF (CAR STR)='LIST THEN (CAR RSTR)) NCI)) [QUIT _(MEMBER TMP (QUOTE (GEVERROR "(...)" "---" "???"] (NC_(NCHARS TMP)) (IF NC>NCI AND (CDR RES) THEN QUIT_T ELSE (IF NC>NCI THEN TMP_ "---" NC_3 QUIT_T) (RES+_TMP) (NLEFT_-NC) (VAL_(CDR VAL)) (RSTR_(CDR RSTR)) (IF VAL THEN (RES+_ " ") (NLEFT_-1] (IF VAL THEN (RES+_ "...")) (RES+_ ")") (RETURN (APPLY (FUNCTION CONCAT) (DREVERSE RES]) (GEVSHORTSTRINGVAL [LAMBDA (VAL NCHARS) % edited: "12-OCT-82 12:14" % Compute the short value of a string VAL. The result is a string which can be printed within NCHARS. (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"]) (GEVSHORTVALUE [LAMBDA (VAL STR NCHARS) % edited: " 6-NOV-82 14:37" % Compute the short value of a given value VAL whose type is STR. The result is an atom, string, or list structure which can be printed within NCHARS. (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) (RETURN (COND ([AND (ATOM STR) (FMEMB STR (QUOTE (ATOM INTEGER REAL] (GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR (QUOTE STRING)) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NEQ (SETQ TMP (GEVEXPROP VAL STR (QUOTE SHORTVALUE) (QUOTE PROP) NIL)) (QUOTE GEVERROR))) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) (GEVSHORTSTRINGVAL VAL NCHARS)) ((LISTP STR) (SELECTQ (CAR STR) ((LISTOF LIST) (COND ((LISTP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND ((LISTP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) "---")) ((LISTP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "---"]) (GEVXTRTYPE [LAMBDA (TYPE) % edited: "21-OCT-82 11:17" % Extract an atomic type name from a type spec which may be either <type> or (A <type>.) (COND ((ATOM TYPE) TYPE) ((NLISTP TYPE) NIL) ((AND (FMEMB (CAR TYPE) (QUOTE (A AN a an An TRANSPARENT))) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMB (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (BOUNDP GLUSERSTRNAMES) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR (QUOTE GEVXTRTYPE) (LIST TYPE "is an illegal type specification.")) NIL]) (PICTURE-GEVDISPLAY (GLAMBDA (PICTURE,WINDOW:WINDOW YMAX) % edited: "14-OCT-82 14:12" % Display PICTURE in (GLOBAL Y:INTEGER WINDOW within YMAX.) (PROG (PWD PHT NEWX NEWY) (PHT_(MIN (YMAX - 20) PICTURE:HEIGHT)) (PWD _(MIN (WINDOW:WIDTH - 20) PICTURE:WIDTH)) (NEWX _(WINDOW:WIDTH - PWD)/2) (NEWY _ YMAX - PHT - 10) (MOVEW PICTURE (CONS 0 0)) % Also copy the picture onto the current window. (BITBLT PICTURE 1 1 WINDOW NEWX NEWY PWD PHT (QUOTE INPUT) (QUOTE REPLACE) NIL NIL) (MOVEW PICTURE (CONS (WINDOW:LEFT+NEWX) (WINDOW:BOTTOM+NEWY))) (Y _ NEWY - 12)))) (VECTOR-SHORTVALUE (GLAMBDA (V:VECTOR) % edited: " 7-OCT-82 12:58" (CONCAT "(" (MKSTRING V:X) "," (MKSTRING V:Y) ")"))) ) (RPAQQ GEVTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) |
Added psl-1983/glisp/gev.sl version [4e2a8490c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GEV.PSL;9 5-FEB-83 15:29:32 (FLUID '(GLNATOM RESULT Y)) (GLOBAL '(GEVACTIVEFLG GEVCHARWIDTH GEVEDITCHAIN GEVEDITFLG GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY)) (GLISPGLOBALS (GEVACTIVEFLG BOOLEAN) (GEVCHARWIDTH INTEGER) (GEVEDITCHAIN EDITCHAIN) (GEVEDITFLG BOOLEAN) (GEVMENUWINDOW WINDOW) (GEVMENUWINDOWHEIGHT INTEGER) (GEVMOUSEAREA MOUSESTATE) (GEVSHORTCHARS INTEGER) (GEVWINDOW WINDOW) (GEVWINDOWY INTEGER) ) (GLISPOBJECTS (AREA (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T))) (EDITCHAIN (LISTOF EDITFRAME) PROP ((TOPFRAME ((CAR self))) (TOPITEM ((CAR TOPFRAME:PREVS))))) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) (SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM)))) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) (SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP ((NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = 8* (NCHARS NAME) HEIGHT = 12)) VTYPE GLVTYPE4) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = 8* (NCHARS NAME) HEIGHT = 12))))) (MOUSESTATE (LIST (AREA AREA) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER))) (DOLPHINREGION (RECORD REGION (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER))) (MENU (RECORD MENU (ITEMS (LISTOF ATOM))) MSG ((SELECT MENU RESULT ATOM))) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y = Y/MAGNITUDE)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI))))) (WINDOW ANYTHING PROP ((REGION ((DSPCLIPPINGREGION NIL self)) RESULT DOLPHINREGION) (XPOSITION ((DSPXPOSITION NIL self)) RESULT INTEGER) (YPOSITION ((DSPYPOSITION NIL self)) RESULT INTEGER) (HEIGHT (REGION:HEIGHT)) (WIDTH (REGION:WIDTH)) (LEFT ((DSPXOFFSET NIL self)) RESULT INTEGER) (BOTTOM ((DSPYOFFSET NIL self)) RESULT INTEGER)) MSG ((CLEAR CLEARW) (OPEN OPENW) (CLOSE CLOSEW))) ) % edited: 26-OCT-82 11:45 % Test whether an area contains a point P. (DG AREA-CONTAINS (AREA P) (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)) % edited: 12-OCT-82 14:19 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DF GEV (args) (PROG (VAL var str) (setq var (car args)) (setq str (cadr args)) (SETQ VAL (EVAL VAR)) (SETQ STR (EVAL STR)) (GEVA VAR VAL STR))) % edited: 22-DEC-82 14:16 % GLISP Edit Value function. Edit VAL according to structure % description STR. (DG GEVA (VAR VAL STR) (PROG (GLNATOM TMP HEADER) (OR (AND (NOT (UNBOUNDP 'GEVWINDOW)) GEVWINDOW) (GEVINITEDITWINDOW)) (OPENW GEVMENUWINDOW) (GEVACTIVEFLG_T) (GEVEDITFLG_NIL) (GLNATOM_0) (GEVSHORTCHARS_27) (GEVCHARWIDTH_7) (IF VAR IS A LIST AND (CAR VAR) ='QUOTE THEN VAR_ (CONCAT "'" (CADR VAR))) (IF ~STR THEN (IF VAL IS ATOMIC AND (GET VAL 'GLSTRUCTURE) THEN STR_'GLTYPE ELSEIF (GEVGLISPP) THEN STR_ (GLCLASS VAL))) (HEADER_ (A GSEITEM WITH NAME = VAR VALUE = VAL TYPE = STR)) (GEVEDITCHAIN_ (LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) (GEVMOUSELOOP))) % edited: 11-NOV-82 16:53 % Respond to a button event within the editing window. (DG GEVBUTTONEVENTFN NIL (PROG (POS SELECTION TMP TOP N) (GETMOUSESTATE) % Test the state of the left mouse button. (IF (ZEROP (LOGAND LASTMOUSEBUTTONS 4)) THEN % Button is now up. (IF GEVMOUSEAREA THEN (SELECTION_GEVMOUSEAREA) (GEVMOUSEAREA_NIL) (GEVINVERTENTRY SELECTION:AREA GEVWINDOW) % Execute action. (IF SELECTION:FLAG THEN (IF SELECTION:GROUP=1 THEN ( TMP_GEVEDITCHAIN:TOPFRAME:PREVS) (N_0) (WHILE TMP AND (TOP-_TMP) <>SELECTION:ITEM DO N_+1) (GEVPOP NIL N) ELSE (GEVPUSH SELECTION:ITEM)) ELSE (PRIN1 SELECTION:ITEM:NAME) (PRIN1 " is ") (PRINTDEF SELECTION:ITEM:TYPE (POSITION T)) (TERPRI)) (RETURN NIL) ELSE % Button is now down. (POS _ (A VECTOR WITH X = (LASTMOUSEX GEVWINDOW) Y = (LASTMOUSEY GEVWINDOW))) (IF GEVMOUSEAREA THEN (IF (_ GEVMOUSEAREA:AREA CONTAINS? POS) THEN (RETURN NIL) ELSE % Mouse has moved out of area with button down. (SELECTION_GEVMOUSEAREA) (GEVMOUSEAREA_NIL) (GEVINVERTENTRY SELECTION:AREA GEVWINDOW))) % Try to find an item at current mouse position. (IF GEVMOUSEAREA _ (GEVFINDPOS POS GEVEDITCHAIN:TOPFRAME) THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW)))))) % edited: 11-NOV-82 16:20 (DG GEVCOMMANDFN (COMMANDWORD:ATOM) (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASE COMMANDWORD OF (EDIT (GEVEDIT)) (QUIT (IF GEVMOUSEAREA THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW) (GEVMOUSEAREA_NIL) ELSE (GEVQUIT))) (POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) ELSE (ERROR 0 NIL)))) % edited: 22-DEC-82 11:30 (DG GEVCOMMANDPROP (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) (PROG (VAL PROPNAMES FLG) (IF PROPNAME THEN FLG_T) (IF ITEM:TYPE IS ATOMIC THEN (PROPNAMES_ (GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME))) (IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP THEN (IF COMMANDWORD='PROP THEN (IF (CDR PROPNAMES) THEN PROPNAMES+_'All) PROPNAMES+_'self) (IF ~PROPNAMES (RETURN NIL)) (IF ~PROPNAME (PROPNAME _ (MENU (create MENU ITEMS _ PROPNAMES)))) (IF ~PROPNAME (RETURN NIL) ELSEIF PROPNAME='self THEN (PRIN1 PROPNAME) (PRIN1 " = ") (PRINT ITEM:VALUE) ELSEIF COMMANDWORD='PROP AND PROPNAME='All THEN (FOR X IN (OR (CDDR PROPNAMES) (CDR PROPNAMES)) DO (GEVDOPROP ITEM X COMMANDWORD FLG)) ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG)) (IF COMMANDWORD='MSG THEN (GEVREFILLWINDOW) (GEVEDITFLG_T))))) % edited: 22-DEC-82 11:09 % Get all property names of properties of type PROPTYPE for OBJ. % Properties are filtered to remove system properties and those % which are already displayed. (DG GEVCOMMANDPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN ~ (PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME = (CAR P))) AND ~ (PROPTYPE='PROP AND (MEMQ (CAR P) '(SHORTVALUE DISPLAYPROPS) )) AND ~ (PROPTYPE='MSG AND (CADR P) IS ATOMIC AND (~ (GETD (CADR P)) OR (LENGTH (CADR (GETD (CADR P)))) >1)) COLLECT P:NAME)) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME)))) (RETURN RESULT))) % GSN 4-FEB-83 16:57 % Compile a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVCOMPPROP (STR:GLTYPE PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (RETURN 'GEVERROR)) % If the property is implemented by a named function, return the % function name. (IF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC THEN (RETURN (CADR PROPENT))) % Compile code for this property and save it. First be sure the GLISP % compiler is loaded. (RETURN (COND ((GEVGLISPP) (GLCOMPPROP STR PROPNAME PROPTYPE) OR 'GEVERROR) (T (ERROR 0 (LIST "GLISP compiler must be loaded for PROPs which are not specified with function name equivalents." (LIST STR PROPTYPE PROPNAME)))))))) % edited: 4-NOV-82 16:08 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (RESULT) (GEVDATANAMESB OBJ:STRDES FILTER) (RETURN (REVERSIP RESULT)))) % GSN 4-FEB-83 17:39 % Get a flattened list of names and types from a given structure % description. (DG GEVDATANAMESB (STR:ANYTHING FILTER:ATOM) (GLOBAL RESULT)(PROG (TMP) (IF STR IS ATOMIC THEN (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER))) (RECORD (FOR X IN (CDDR STR) DO (GEVDATANAMESB X FILTER))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) (LISTOF (RETURN NIL)) ELSE (IF (GEVFILTER (CADR STR) FILTER) THEN (RESULT +_ (LIST (CAR STR) (CADR STR)))) (GEVDATANAMESB (CADR STR) FILTER))))) % edited: 14-OCT-82 15:35 % Display a newly added property in the window. (DG GEVDISPLAYNEWPROP NIL (PROG (Y NEWONE:GSEITEM) (Y_GEVWINDOWY) (NEWONE_ (CAR (LASTPAIR GEVEDITCHAIN:TOPFRAME:PROPS))) (GEVPPS NEWONE 1 GEVWINDOW Y) (GEVWINDOWY_Y))) % GSN 4-FEB-83 16:58 % Add the property PROPNAME of type COMMANDWORD to the display for % ITEM. (DG GEVDOPROP (ITEM:GSEITEM PROPNAME:ATOM COMMANDWORD:ATOM FLG:BOOLEAN) (PROG (VAL) (VAL_ (GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL)) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = PROPNAME TYPE = (GEVPROPTYPE ITEM:TYPE PROPNAME COMMANDWORD) VALUE = VAL NODETYPE = COMMANDWORD)) (IF ~FLG THEN (GEVDISPLAYNEWPROP)))) % edited: 12-OCT-82 16:34 % Edit the currently displayed item. (DG GEVEDIT NIL (PROG (CHANGEDFLG GEVTOPITEM) (GEVTOPITEM_GEVEDITCHAIN:TOPITEM) (IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE 'EDIT 'MSG NIL) ~='GEVERROR THEN CHANGEDFLG_T ELSEIF GEVTOPITEM:VALUE IS A LIST THEN (EDITV GEVTOPITEM:VALUE) (CHANGEDFLG_T) ELSE (RETURN NIL)) (IF CHANGEDFLG THEN (GEVREFILLWINDOW)) (GEVEDITFLG_CHANGEDFLG))) % GSN 4-FEB-83 16:58 % Execute a property whose name is PROPNAME and whose property type % (ADJ, ISA, PROP, MSG) is PROPTYPE on the object OBJ whose type is % STR. (DG GEVEXPROP (OBJ STR PROPNAME:ATOM PROPTYPE:ATOM ARGS) (PROG (FN) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) OR (ARGS AND PROPTYPE~='MSG) (RETURN 'GEVERROR)) (IF (FN_ (GEVCOMPPROP STR PROPNAME PROPTYPE)) ='GEVERROR THEN (RETURN FN) ELSE (RETURN (APPLY FN (CONS OBJ ARGS)))))) % edited: 14-OCT-82 15:23 % Fill the GEV editor window with the item which is at the top of % GEVEDITCHAIN. (DG GEVFILLWINDOW NIL (PROG (Y TOP) (_ GEVWINDOW CLEAR) % Compute an initial Y value for printing titles in the window. (Y_GEVWINDOW:HEIGHT - 20) % Print the titles from the edit chain first. (TOP_GEVEDITCHAIN:TOPFRAME) (FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 1 GEVWINDOW Y)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:SUBITEMS DO (GEVPPS X 1 GEVWINDOW Y)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:PROPS DO (GEVPPS X 1 GEVWINDOW Y)) (GEVWINDOWY_Y))) % GSN 21-JAN-83 10:24 % Filter types according to a specified FILTER. (DG GEVFILTER (TYPE FILTER) (TYPE_ (GEVXTRTYPE TYPE))(CASE FILTER OF (NUMBER ~ (MEMQ TYPE '(ATOM STRING BOOLEAN ANYTHING)) AND ~ ((PAIRP TYPE) AND (CAR TYPE) ='LISTOF)) (LIST (PAIRP TYPE) AND (CAR TYPE) ='LISTOF) ELSE T)) % edited: 14-OCT-82 11:32 (DG GEVFINDITEMPOS (POS:VECTOR ITEM:GSEITEM N:INTEGER) (RESULT MOUSESTATE) % Test whether ITEM contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N) (GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N) ((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF) AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N)))) % edited: 13-OCT-82 12:03 (DG GEVFINDLISTPOS (POS:VECTOR ITEMS: (LISTOF GSEITEM) N) (RESULT MOUSESTATE) % Find some ITEM corresponding to the mouse position POS. (IF ITEMS THEN (GEVFINDITEMPOS POS (CAR ITEMS) N) OR (GEVFINDLISTPOS POS (CDR ITEMS) N))) % edited: 13-OCT-82 12:06 (DG GEVFINDPOS (POS:VECTOR FRAME:EDITFRAME) (RESULT MOUSESTATE) % Find the sub-item of FRAME corresponding to the mouse position POS. % The result is NIL if not found, else a list of the sub-item and a % flag which is NIL if the NAME part is identified, T if the VALUE % part is identified. (PROG (TMP N ITEMS: LISTOF) (N_0) (WHILE FRAME AND ~TMP DO (N_+1) ITEMS-_FRAME (TMP_ (GEVFINDLISTPOS POS ITEMS N))) (RETURN TMP))) % edited: 22-DEC-82 14:53 % Get all names of properties and stored data from a GLISP object % type. (DG GEVGETNAMES (OBJ:GLTYPE FILTER:ATOM) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES (GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ 'PROP FILTER)) (RETURN (NCONC DATANAMES PROPNAMES)))) % GSN 4-FEB-83 16:59 % Retrieve a GLISP property whose name is PROPNAME and whose property % type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DG GEVGETPROP (STR PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT) (IF ~ (MEMQ PROPTYPE '(ADJ ISA PROP MSG)) (ERROR 0 NIL)) (RETURN (AND (PL_ (GET STR 'GLSTRUCTURE)) (SUBPL_ (LISTGET (CDR PL) PROPTYPE)) (PROPENT_ (ASSOC PROPNAME SUBPL)))))) % edited: 11-NOV-82 15:53 (DE GEVGLISPP NIL (NOT (UNBOUNDP 'GLBASICTYPES))) % edited: 14-OCT-82 09:42 (DG GEVHORIZLINE (W:WINDOW) (GLOBAL Y:INTEGER) % Draw a horizontal line across window W at Y and decrease Y. (DRAWLINE 1 Y+4 W:WIDTH Y+4 1 'PAINT WINDOW)(Y_-12)) % edited: 15-OCT-82 17:16 (DE GEVINIT NIL (SETQ GLNATOM 0)(SETQ GEVWINDOW NIL)) % edited: 6-OCT-82 16:29 % Initialize an edit window for the GLISP structure editor. (DE GEVINITEDITWINDOW NIL (PROG (GEVMENU LEFT BOTTOM WIDTH HEIGHT) (SETQ GEVWINDOW (CREATEW (create REGION LEFT _ LEFT BOTTOM _ BOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT) "GEV Structure Editor Window")) (SETQ GEVMOUSEAREA NIL) (WINDOWPROP GEVWINDOW 'BUTTONEVENTFN 'GEVBUTTONEVENTFN) (WINDOWPROP GEVWINDOW 'MOVEFN 'GEVMOVEWINDOWFN) (SETQ GEVMENUWINDOWHEIGHT 40) (SETQ GEVMENUWINDOW (CREATEW (create REGION LEFT _ LEFT BOTTOM _ (DIFFERENCE BOTTOM GEVMENUWINDOWHEIGHT) WIDTH _ WIDTH HEIGHT _ GEVMENUWINDOWHEIGHT) NIL 0)) (SETQ GEVMENU (create MENU ITEMS _ '(QUIT POP EDIT PROGRAM PROP ADJ ISA MSG) CENTERFLG _ T MENUROWS _ 2 MENUFONT _ (FONTCREATE 'HELVETICA 10 'BOLD) ITEMHEIGHT _ 15 ITEMWIDTH _ (DIFFERENCE (QUOTIENT WIDTH 4) 2) WHENSELECTEDFN _ 'GEVCOMMANDFN)) (ADDMENU GEVMENU GEVMENUWINDOW) (RETURN GEVWINDOW))) % edited: 5-OCT-82 14:43 % Invert the area of WINDOW which is covered by the specified AREA. (DG GEVINVERTENTRY (AREA:AREA WINDOW) (BITBLT WINDOW AREA:LEFT AREA:BOTTOM WINDOW AREA:LEFT AREA:BOTTOM AREA:WIDTH AREA:HEIGHT 'INVERT 'REPLACE NIL NIL)) % edited: 12-OCT-82 12:12 % Bound the length of VAL to NCHARS. (DE GEVLENGTHBOUND (VAL NCHARS) (COND ((GREATERP (FlatSize2 VAL) NCHARS) (CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS)) "-")) (T VAL))) % GSN 4-FEB-83 16:59 % Make a function to perform OPERATION on set SETNAME from INPUTTYPE % following PATH to get to the data. (DG GEVMAKENEWFN (OPERATION:ATOM INPUTTYPE:ATOM SET: (LIST (NAME ATOM) (TYPE GLTYPE)) PATH: (LISTOF (LIST (NAME ATOM) (TYPE GLTYPE)))) (PROG (LASTPATH) (SETQ LASTPATH (CAR (LASTPAIR PATH))) (RETURN (LIST (LIST 'GLAMBDA (LIST (MKATOM (CONCAT 'GEVNEWFNTOP ":" INPUTTYPE))) (LIST 'PROG (CONS 'GEVNEWFNVALUE (CASE OPERATION OF (COLLECT '(GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (TOTAL '((GEVNEWFNSUM 0))) (AVERAGE '((GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0))) ELSE (ERROR 0 NIL))) (NCONC (LIST 'FOR 'GEVNEWFNLOOPVAR 'IN (MKATOM (CONCAT 'GEVNEWFNTOP ":" SET:NAME)) 'DO (LIST 'GEVNEWFNVALUE '_ (REVERSIP (CONS 'GEVNEWFNLOOPVAR (MAPCAN PATH (FUNCTION (LAMBDA (X) (LIST 'OF (CAR X) 'THE)))))))) (COPY (CASE OPERATION OF (COLLECT '((GEVNEWFNRESULT +_ GEVNEWFNVALUE))) (MAXIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR)))) (MINIMUM '((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN (GEVNEWFNTESTVAL _ GEVNEWFNVALUE) (GEVNEWFNINSTANCE _ GEVNEWFNLOOPVAR)))) (AVERAGE '((GEVNEWFNSUM _+ GEVNEWFNVALUE) (GEVNEWFNCOUNT _+ 1))) (TOTAL '((GEVNEWFNSUM _+ GEVNEWFNVALUE)))))) (LIST 'RETURN (CASE OPERATION OF (COLLECT '(DREVERSE GEVNEWFNRESULT)) ((MAXIMUM MINIMUM) '(LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE)) (AVERAGE '(QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT))) (TOTAL 'GEVNEWFNSUM))))) (CASE OPERATION OF (COLLECT (LIST 'LISTOF (CADR LASTPATH))) ((MAXIMUM MINIMUM) (LIST 'LIST (COPY LASTPATH) (LIST 'WINNER (CADR SET:TYPE)))) (AVERAGE 'REAL) (TOTAL (CADR LASTPATH))))))) % edited: 8-OCT-82 10:43 (DG GEVMATCH (STR VAL FLG) (RESULT (LISTOF GSEITEM)) % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) (RETURN (REVERSIP RESULT)))) % edited: 8-OCT-82 10:01 % Make a single item which matches structure STR and value VAL. (DG GEVMATCHA (STR VAL FLG) (PROG (RES) (RES_ (GEVMATCH STR VAL FLG)) (IF ~ (CDR RES) THEN (RETURN (CAR RES)) ELSE (RETURN (A GSEITEM WITH VALUE = VAL TYPE = STR SUBVALUES = RES NODETYPE = 'SUBTREE))))) % edited: 7-OCT-82 16:38 % Match an ATOM structure to a given value. (DG GEVMATCHATOM (STR VAL NAME) (PROG (L STRB TMP) (IF VAL IS NOT ATOMIC OR VAL IS NULL THEN (RETURN NIL)) (STRB_ (CADR STR)) (IF (CAR STRB) ~='PROPLIST THEN (RETURN NIL)) (L_ (CDR STRB)) (FOR X IN L DO (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 7-OCT-82 16:57 % Match an ALIST structure to a given value. (DG GEVMATCHALIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (ASSOC (CAR X) VAL) THEN (GEVMATCHB X (CDR TMP) NIL NIL))))) % edited: 22-DEC-82 15:26 % Match a structure description, STR, and a value VAL which matches % that description, to form a structure editor tree structure. If % FLG is set, the match will descend inside an atomic type name. % Results are added to the free variable RESULT. (DG GEVMATCHB (STR: (LISTOF ANYTHING) VAL NAME:ATOM FLG:BOOLEAN) (GLOBAL RESULT)(PROG (X Y STRB XSTR TOP TMP) (XSTR_ (GEVXTRTYPE STR)) (IF STR IS ATOMIC THEN (IF FLG AND (STRB _ (CAR (GET STR 'GLSTRUCTURE))) THEN (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = (GEVMATCH STRB VAL NIL) TYPE = STR NODETYPE = 'STRUCTURE)) ELSE (RESULT +_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) (RETURN NIL) ELSE (CASE (CAR STR) OF (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB (CADDR STR) (CDR VAL) NIL NIL)) (LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL) NIL NIL) (VAL_ (CDR VAL))))) (ATOM (GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST (GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) (RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) (GEVMATCHOBJECT STR VAL NAME)) ELSE (IF NAME THEN (TMP _ (GEVMATCH STR VAL NIL)) (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN ( TOP:NAME_NAME) TOP ELSE (A GSEITEM WITH NAME = NAME VALUE = VAL SUBVALUES = TMP TYPE = XSTR NODETYPE = 'SUBTREE))) ELSEIF (STRB _ (GEVXTRTYPE (CADR STR))) IS ATOMIC THEN (GEVMATCHB STRB VAL (CAR STR) NIL) ELSEIF (TMP_ (GEVMATCH (CADR STR) VAL NIL)) THEN (TOP_ (CAR TMP)) (RESULT +_ (IF ~ (CDR TMP) AND ~TOP:NAME THEN (TOP:NAME_ (CAR STR)) TOP ELSE (A GSEITEM WITH NAME = (CAR STR) VALUE = VAL SUBVALUES = TMP TYPE = (CADR STR) NODETYPE = 'SUBTREE))) ELSE (PRINT "GEVMATCHB Failed")))))) % edited: 8-OCT-82 10:15 % Match a LISTOF structure. (DG GEVMATCHLISTOF (STR VAL NAME) (GLOBAL RESULT)(RESULT+_ (A GSEITEM WITH NAME = NAME VALUE = VAL TYPE = STR))) % edited: 22-DEC-82 10:04 % Match the OBJECT structures. (DG GEVMATCHOBJECT (STR VAL NAME) (GLOBAL RESULT)(PROG (OBJECTTYPE TMP) (RESULT _+ (A GSEITEM WITH NAME = 'CLASS VALUE = (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (TMP-_VAL)) (ATOMOBJECT (GET VAL 'CLASS))) TYPE = 'GLTYPE)) (FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT LISTOBJECT) (IF VAL (GEVMATCHB X (TMP-_VAL) NIL NIL))) (ATOMOBJECT (IF TMP_ (GET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))))) % edited: 24-NOV-82 16:31 % Match an PROPLIST structure to a given value. (DG GEVMATCHPROPLIST (STR VAL NAME) (PROG (L TMP) (L_ (CDR STR)) (FOR X IN L DO (IF TMP_ (LISTGET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL))))) % edited: 21-DEC-82 17:32 % Match a RECORD structure. (DG GEVMATCHRECORD (STR VAL NAME) (PROG (STRNAME FIELDS) (IF (CADR STR) IS ATOMIC THEN STRNAME_ (CADR STR) FIELDS_ (CDDR STR) ELSE FIELDS_ (CDR STR)) (FOR X IN FIELDS DO (GEVMATCHB X (RECORDACCESS (CAR X) VAL NIL NIL STRNAME) NIL NIL)))) % edited: 27-SEP-82 16:24 % Wait in a loop for mouse actions within the edit window. (DG GEVMOUSELOOP NIL (PROG NIL)) % edited: 5-OCT-82 11:36 (DE GEVMOVEWINDOWFN (W NEWPOS) (PROG NIL (MOVEW GEVMENUWINDOW (CONS (CAR NEWPOS) (DIFFERENCE (CDR NEWPOS) GEVMENUWINDOWHEIGHT))))) % GSN 21-JAN-83 13:50 % Pop up from the current item to the previous one. If FLG is set, % popping continues through extended LISTOF elements. (DG GEVPOP (FLG:BOOLEAN N:INTEGER) (PROG (TMP TOP:GSEITEM TMPITEM) (IF N<1 (RETURN NIL)) LP (TMP-_GEVEDITCHAIN) (IF ~GEVEDITCHAIN THEN (RETURN (GEVQUIT))) (TOP_ (CAAAR GEVEDITCHAIN)) % Test for repeated LISTOF elements. (TMPITEM_ (CAR TMP:PREVS)) (IF FLG AND TMPITEM:NODETYPE='FORWARD THEN (GO LP)) (IF (N_-1) >0 THEN (GO LP)) (IF TOP:TYPE IS A LIST AND (CAR TOP:TYPE) ='LISTOF AND ~ (CDR TOP:VALUE) THEN (GO LP)) (IF GEVEDITFLG AND ~ (MEMBER TMPITEM:SHORTVALUE '("(...)" "---")) THEN (GEVREFILLWINDOW) ELSE GEVEDITFLG_NIL (GEVFILLWINDOW)) (GEVMOUSELOOP))) % GSN 4-FEB-83 17:00 (DG GEVPOSTEST (POS:VECTOR TPOS:VECTOR NAME ITEM:GSEITEM FLG N:INTEGER) (RESULT MOUSESTATE) % Test whether TPOS contains the mouse position POS. The result is NIL % if not found, else a list of the sub-item and a flag which is NIL % if the NAME part is identified, T if the VALUE part is identified. (IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+12 AND POS:X>=TPOS:X AND POS:X<TPOS:X+100 THEN (A MOUSESTATE WITH AREA = (AN AREA WITH START = (A VECTOR WITH X = TPOS:X Y = TPOS:Y - 1) SIZE = (A VECTOR WITH X = GEVCHARWIDTH* (FlatSize2 NAME) Y = 12)) ITEM = ITEM FLAG = FLG GROUP = N))) % GSN 21-JAN-83 10:25 (DG GEVPPS (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) (GLOBAL Y:INTEGER) % Pretty-print a structure defined by ITEM in the window WINDOW, % beginning ar horizontal column COL and vertical position Y. The % positions in ITEM are modified to match the positions in the % window. (PROG (NAMEX VALX TOP) % Make sure there is room in window. (IF Y<0 THEN (RETURN NIL)) % Position in window for slot name. (NAMEX_COL*GEVCHARWIDTH) (ITEM:NAMEPOS:X_NAMEX) (ITEM:NAMEPOS:Y_Y) (MOVETO NAMEX Y WINDOW) (IF ITEM:NODETYPE='FULLVALUE THEN (PRIN1 "(expanded)" WINDOW) ELSEIF ITEM:NAME THEN (IF ITEM:NAME IS NUMERIC THEN (PRIN1 "#" WINDOW)) (PRIN1 (GEVLENGTHBOUND ITEM:NAME 11) WINDOW)) % See if there is a value to print for this name. (IF ~ITEM:NODETYPE OR (MEMQ ITEM:NODETYPE '(FORWARD BACKUP PROP ADJ MSG ISA)) THEN (VALX_NAMEX+100) (ITEM:VALUEPOS:X_VALX) (ITEM:VALUEPOS:Y_Y) (MOVETO VALX Y WINDOW) (PRIN1 (ITEM:SHORTVALUE OR (ITEM:SHORTVALUE _ (GEVSHORTVALUE ITEM:VALUE ITEM:TYPE (GEVSHORTCHARS - COL))) ) WINDOW) (IF ~ (EQ ITEM:SHORTVALUE ITEM:VALUE) THEN (MOVETO (VALX - 20) Y WINDOW) (PRIN1 "~" WINDOW)) (Y_-12) ELSEIF ITEM:NODETYPE='FULLVALUE THEN (Y_-12) (MOVETO 0 Y WINDOW) (RESETLST (RESETSAVE SYSPRETTYFLG T) (SHOWPRINT ITEM:VALUE WINDOW)) (Y_WINDOW:YPOSITION - 12) ELSEIF ITEM:NODETYPE='DISPLAY THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE 'GEVDISPLAY 'MSG (LIST WINDOW Y)) ELSE % This is a subtree Y_-12 (FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW))))) % GSN 21-JAN-83 10:56 % Write an interactive program involving the current item. (DG GEVPROGRAM NIL (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF (COMMAND_ (MENU (create MENU ITEMS _ '(Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM) ))) ='Quit OR ~ COMMAND THEN (RETURN NIL)) (IF (SET_ (GEVPROPMENU TOPITEM:TYPE 'LIST NIL)) ='Quit OR SET='Pop OR ~SET THEN (RETURN NIL)) (PATH_ (LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE))) (NEXT_SET) (TYPE_ (CADADR SET)) (WHILE ~DONE AND ~ABORTFLG DO (NEXT_ (GEVPROPMENU TYPE (COMMAND~='COLLECT AND 'NUMBER) COMMAND='COLLECT)) (CASE NEXT OF ((NIL Quit) (ABORTFLG_T)) (Pop (IF ~ (CDDR PATH) THEN (ABORTFLG_T) ELSE (NEXT-_PATH) (NEXT_ (CAR PATH)) (TYPE_ (CADR NEXT)) (IF TYPE IS A LIST THEN TYPE_ (CADR TYPE)) (LAST_ (CAR NEXT)))) (Done (DONE_T)) ELSE (PROGN (PATH+_NEXT) (TYPE_ (CADR NEXT)) (LAST_ (CAR NEXT)))) (IF (MEMQ TYPE '(ATOM INTEGER STRING REAL BOOLEAN NIL)) DONE_T)) (IF ABORTFLG (RETURN NIL)) (PATH_ (REVERSIP PATH)) (NEWFN_ (GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH))) (PUTD 'GEVNEWFN (CAR NEWFN)) (RESULT_ (GEVNEWFN TOPITEM:VALUE)) % Print result as well as displaying it. (PRIN1 COMMAND) (SPACES 1) (FOR X IN (CDDR PATH) DO (PRIN1 (CAR X)) (SPACES 1)) (PRIN1 "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) (PRIN1 " = ") (PRINT RESULT) (GEVEDITCHAIN:TOPFRAME:PROPS_+ (A GSEITEM WITH NAME = (CONCAT COMMAND " " LAST) TYPE = (CADR NEWFN) VALUE = RESULT NODETYPE = 'MSG)) (GEVDISPLAYNEWPROP))) % GSN 21-JAN-83 10:32 % Make a menu to get properties of object OBJ with filter FILTER. FLG % is T if it is okay to stop before reaching a basic type. (DG GEVPROPMENU (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) (PROG (PROPS SEL PNAMES MENU) (PROPS_ (GEVGETNAMES OBJ FILTER)) (IF ~PROPS THEN (RETURN NIL) ELSE (PNAMES_ (MAPCAR PROPS (FUNCTION CAR))) (SEL_ (SEND (A MENU WITH ITEMS = (CONS 'Quit (CONS 'Pop (IF FLG THEN (CONS 'Done PNAMES) ELSE PNAMES)))) SELECT)) (RETURN (CASE SEL OF ((Quit Pop Done NIL) SEL) ELSE (ASSOC SEL PROPS)))))) % GSN 4-FEB-83 17:01 % Get all property names and types of properties of type PROPTYPE for % OBJ when they satisfy FILTER. (DG GEVPROPNAMES (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) (PROG (RESULT TYPE) (RESULT _ (FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN (TYPE_ (GEVPROPTYPES OBJ P:NAME 'PROP)) AND (GEVFILTER TYPE FILTER) COLLECT (LIST P:NAME TYPE))) (FOR S IN OBJ:SUPERS DO (RESULT _ (NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER)))) (RETURN RESULT))) % GSN 4-FEB-83 17:02 % Find the type of a computed property. (DG GEVPROPTYPE (STR:ATOM PROPNAME:ATOM PROPTYPE:ATOM) (PROG (PL SUBPL PROPENT TMP) (IF STR IS NOT ATOMIC THEN (RETURN NIL) ELSEIF (PROPENT_ (GEVGETPROP STR PROPNAME PROPTYPE)) AND (TMP_ (LISTGET (CDDR PROPENT) 'RESULT)) THEN (RETURN TMP) ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP_ (GET (CADR PROPENT) 'GLRESULTTYPE)) THEN (RETURN TMP) ELSEIF (AND (PL_ (GET STR 'GLPROPFNS)) (SUBPL_ (ASSOC PROPTYPE PL)) (PROPENT_ (ASSOC PROPNAME (CDR SUBPL))) (TMP_ (CADDR PROPENT))) THEN (RETURN TMP) ELSEIF PROPTYPE='ADJ THEN (RETURN 'BOOLEAN)))) % edited: 4-NOV-82 15:39 (DE GEVPROPTYPES (OBJ NAME TYPE) (OR (GEVPROPTYPE OBJ NAME TYPE) (AND (GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE)))) % GSN 24-JAN-83 14:14 % Push down to look at an item referenced from the current item. (DG GEVPUSH (ITEM:GSEITEM) (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (IF ITEM:NODETYPE='BACKUP THEN (GEVPOP NIL 1) (RETURN NIL)) (TOPITEM_GEVEDITCHAIN:TOPITEM) (IF ITEM:NODETYPE='FORWARD THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM T)) ELSEIF ITEM:TYPE IS ATOMIC AND ~ (GET ITEM:TYPE 'GLSTRUCTURE) THEN (CASE ITEM:TYPE OF ((ATOM NUMBER REAL INTEGER STRING ANYTHING) (IF ITEM:VALUE=ITEM:SHORTVALUE THEN (RETURN NIL) ELSE (NEWITEMS_ (LIST (A GSEITEM WITH NAME = ITEM:NAME VALUE = ITEM:VALUE SHORTVALUE = ITEM:SHORTVALUE TYPE = ITEM:TYPE NODETYPE = 'FULLVALUE))))) ELSE (RETURN NIL)) ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF THEN (NEWITEMS_ (GEVPUSHLISTOF ITEM NIL))) (GEVEDITCHAIN+_ (AN EDITFRAME WITH PREVS = (CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS) SUBITEMS = NEWITEMS)) % Do another PUSH automatically for a list of only one item. (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE) ='LISTOF AND ~ (CDR ITEM:VALUE) THEN (LSTITEM_ (CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN NIL)) (GEVMOUSELOOP))) % edited: 16-OCT-82 15:15 % Push into a datum of type LISTOF, expanding it into the individual % elements. If FLG is set, ITEM is a FORWARD item to be continued. (DG GEVPUSHLISTOF (ITEM:GSEITEM FLG:BOOLEAN) (PROG (ITEMTYPE TOPFRAME N:INTEGER NROOM LST VALS: LISTOF TMP) % Compute the vertical room available in the window. (IF ~ITEM:VALUE (RETURN NIL)) (TOPFRAME_GEVEDITCHAIN:TOPFRAME) (NROOM _ (GEVWINDOW:HEIGHT - 50) /12 - (LENGTH TOPFRAME:PREVS)) % If there was a previous display of this list, insert an ellipsis % header. (IF FLG THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "(..." NODETYPE = 'BACKUP)) (N_ITEM:NAME) (ITEMTYPE_ITEM:TYPE) (NROOM_-1) (VALS_ITEM:SUBVALUES) ELSE (N_1) (ITEMTYPE_ (CADR ITEM:TYPE)) (VALS_ITEM:VALUE)) % Now make entries for each value on the list. (WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~ (CDR VALS))) DO (LST+_ (A GSEITEM WITH VALUE = (TMP-_VALS) TYPE = ITEMTYPE NAME = N)) (NROOM_-1) (N_+1)) (IF VALS THEN (LST+_ (A GSEITEM WITH SHORTVALUE = "...)" NODETYPE = 'FORWARD TYPE = ITEMTYPE NAME = N SUBVALUES = VALS))) (RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = ITEMTYPE NODETYPE = 'LISTOF SUBVALUES = (REVERSIP LST)))))) % edited: 13-OCT-82 10:55 (DG GEVQUIT NIL (SETQ GEVACTIVEFLG NIL)(_ GEVWINDOW CLOSE)(_ GEVMENUWINDOW CLOSE)) % edited: 19-OCT-82 10:23 % Recompute property values for the item. (DG GEVREDOPROPS (TOP:EDITFRAME) (PROG (ITEM L) (ITEM_ (CAR TOP:PREVS)) (IF ~TOP:PROPS AND (L_ (GEVEXPROP ITEM:VALUE ITEM:TYPE 'DISPLAYPROPS 'PROP NIL)) ~='GEVERROR THEN (IF L IS ATOMIC THEN (GEVCOMMANDPROP ITEM 'PROP 'All) ELSEIF L IS A LIST THEN (FOR X IN L (GEVCOMMANDPROP ITEM 'PROP X))) ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG DO (X:VALUE _ (GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL)) (X:SHORTVALUE _ NIL))))) % edited: 14-OCT-82 12:46 % Re-expand the top item of GEVEDITCHAIN, which may have been changed % due to editing. (DG GEVREFILLWINDOW NIL (PROG (TOP TOPITEM SUBS TOPSUB) (TOP_GEVEDITCHAIN:TOPFRAME) (TOPITEM_GEVEDITCHAIN:TOPITEM) (TOPSUB_ (CAR TOP:SUBITEMS)) (IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF) THEN (IF (GEVGETPROP TOPITEM:TYPE 'GEVDISPLAY 'MSG) THEN (TOP:SUBITEMS_ (LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE TYPE = TOPITEM:TYPE NODETYPE = 'DISPLAY))) ELSE (SUBS_ (GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T)) (TOPSUB_ (CAR SUBS)) (TOP:SUBITEMS_ (IF ~ (CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE AND TOPSUB:VALUE=TOPITEM:VALUE AND TOPSUB:TYPE=TOPITEM:TYPE THEN TOPSUB:SUBVALUES ELSE SUBS)))) (GEVREDOPROPS TOP) (GEVFILLWINDOW))) % edited: 8-OCT-82 15:41 (DE GEVSHORTATOMVAL (ATM NCHARS) (COND ((NUMBERP ATM) (COND ((GREATERP (FlatSize2 ATM) NCHARS) (GEVSHORTSTRINGVAL (MKSTRING ATM) NCHARS)) (T ATM))) ((GREATERP (FlatSize2 ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM))) % edited: 8-OCT-82 15:19 % Compute a short value for printing a CONS of two items. (DG GEVSHORTCONSVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP NC) (RES +_ "(") (NLEFT _ NCHARS - 5) (TMP_ (GEVSHORTVALUE (CAR VAL) (CADR STR) NLEFT - 3)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT - 3 THEN TMP_ "---" NC_3) (RES+_TMP) (RES +_ " . ") (NLEFT_-NC) (TMP_ (GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) (NC_ (FlatSize2 TMP)) (IF NC>NLEFT THEN TMP_ "---" NC_3) (RES+_TMP) (RES+_ ")") (RETURN (APPLY (FUNCTION CONCAT) (REVERSIP RES))))) % edited: 6-NOV-82 15:01 % Compute a short value for printing a list of items. (DG GEVSHORTLISTVAL (VAL STR NCHARS:INTEGER) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (RES +_ "(") (REST_4) (NLEFT _ NCHARS - 2) (RSTR_ (CDR STR)) (WHILE VAL AND ~QUIT AND (NCI_ (IF (CDR VAL) THEN NLEFT - REST ELSE NLEFT)) >2 DO (TMP_ (GEVSHORTVALUE (CAR VAL) (IF (CAR STR) ='LISTOF THEN (CADR STR) ELSEIF (CAR STR) ='LIST THEN (CAR RSTR)) NCI)) (QUIT _ (MEMBER TMP '(GEVERROR "(...)" "---" "???"))) (NC_ (FlatSize2 TMP)) (IF NC>NCI AND (CDR RES) THEN QUIT_T ELSE (IF NC>NCI THEN TMP_ "---" NC_3 QUIT_T) (RES+_TMP) (NLEFT_-NC) (VAL_ (CDR VAL)) (RSTR_ (CDR RSTR)) (IF VAL THEN (RES+_ " ") (NLEFT_-1)))) (IF VAL THEN (RES+_ "...")) (RES+_ ")") (RETURN (APPLY (FUNCTION CONCAT) (REVERSIP RES))))) % edited: 12-OCT-82 12:14 % Compute the short value of a string VAL. The result is a string % which can be printed within NCHARS. (DE GEVSHORTSTRINGVAL (VAL NCHARS) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"))) % edited: 6-NOV-82 14:37 % Compute the short value of a given value VAL whose type is STR. The % result is an atom, string, or list structure which can be printed % within NCHARS. (DE GEVSHORTVALUE (VAL STR NCHARS) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) (RETURN (COND ((AND (ATOM STR) (MEMQ STR '(ATOM INTEGER REAL))) (GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR 'STRING) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NE (SETQ TMP (GEVEXPROP VAL STR 'SHORTVALUE 'PROP NIL)) 'GEVERROR)) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) (GEVSHORTSTRINGVAL VAL NCHARS)) ((PAIRP STR) (SELECTQ (CAR STR) ((LISTOF LIST) (COND ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND ((PAIRP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) "---")) ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "---"))))) % edited: 21-OCT-82 11:17 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GEVXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (MEMQ (CAR TYPE) '(A AN a an An TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (NOT (UNBOUNDP GLUSERSTRNAMES)) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR 0 (LIST 'GEVXTRTYPE (LIST TYPE "is an illegal type specification."))) NIL))) % GSN 4-FEB-83 17:03 % Display PICTURE in WINDOW within YMAX. (DG PICTURE-GEVDISPLAY (PICTURE:WINDOW WINDOW:WINDOW YMAX) (GLOBAL Y:INTEGER)(PROG (PWD PHT NEWX NEWY) (PHT_ (MIN (YMAX - 20) PICTURE:HEIGHT)) (PWD _ (MIN (WINDOW:WIDTH - 20) PICTURE:WIDTH)) (NEWX _ (WINDOW:WIDTH - PWD) /2) (NEWY _ YMAX - PHT - 10) (MOVEW PICTURE (CONS 0 0)) % Also copy the picture onto the current window. (BITBLT PICTURE 1 1 WINDOW NEWX NEWY PWD PHT 'INPUT 'REPLACE NIL NIL) (MOVEW PICTURE (CONS (WINDOW:LEFT+NEWX) (WINDOW:BOTTOM+NEWY))) (Y _ NEWY - 12))) % edited: 7-OCT-82 12:58 (DG VECTOR-SHORTVALUE (V:VECTOR) (CONCAT "(" (MKSTRING V:X) "," (MKSTRING V:Y) ")")) (SETQ GEVTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) |
Added psl-1983/glisp/gevdemo.old version [8e0c17e0ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED " 8-NOV-82 09:44:50" {DSK}GEVDEMO.LSP;22 10081 changes to: (FNS GEVDEMO-INIT) (VARS GEVDEMOCOMS) previous date: "26-OCT-82 16:10:02" {DSK}GEVDEMO.LSP;20) (PRETTYCOMPRINT GEVDEMOCOMS) (RPAQQ GEVDEMOCOMS ((GLISPOBJECTS PROJECT CONTRACT AGENCY PERSON BUDGET ADDRESS PHONE-NUMBER DATE PICTURE CAMPUS-ADDRESS BUILDING CIRCLE VECTOR RADIANS DEGREES RVECTOR) (FNS GEVDEMO-INIT TODAYS-DATE TOTAL-BUDGET) (PROP GLRESULTTYPE TODAYS-DATE) (P (GEVDEMO-INIT)))) [GLISPOBJECTS (PROJECT [ATOM (PROPLIST (TITLE STRING) (ABBREVIATION ATOM) (ADMINISTRATOR PERSON) (CONTRACTS (LISTOF CONTRACT)) (EXECUTIVES (LISTOF PERSON] PROP ((SHORTVALUE (ABBREVIATION)) (DISPLAYPROPS (T)) (BUDGET TOTAL-BUDGET)) ) (CONTRACT (ATOM (PROPLIST (TITLE STRING) (LEADER PERSON) (SPONSOR AGENCY) (BUDGET BUDGET))) PROP ((SHORTVALUE (TITLE))) ) (AGENCY (ATOM (PROPLIST (NAME STRING) (ABBREVIATION ATOM) (ADDRESS ADDRESS) (PHONE PHONE-NUMBER))) PROP ((SHORTVALUE (ABBREVIATION))) ) (PERSON (ATOM (PROPLIST (NAME STRING) (INITIALS ATOM) (TITLE ATOM) (PROJECT PROJECT) (SALARY REAL) (SSNO INTEGER) (BIRTHDATE DATE) (PHONE PHONE-NUMBER) (OFFICE CAMPUS-ADDRESS) (HOME-ADDRESS ADDRESS) (HOME-PHONE PHONE-NUMBER) (PICTURE PICTURE))) PROP ((SHORTVALUE (INITIALS)) (CONTRACTS ((THOSE CONTRACTS OF PROJECT WITH LEADER=self))) (AGE ((THE YEAR OF (TODAYS-DATE)) - BIRTHDATE:YEAR)) (MONTHLY-SALARY (SALARY/12)) (DISPLAYPROPS (T))) ADJ [(FACULTY ((MEMB TITLE (QUOTE (PROF ASSOC-PROF ASST-PROF] ) (BUDGET (LIST (LABOR REAL) (COMPUTER REAL)) PROP ((OVERHEAD (LABOR*0.59)) (TOTAL (LABOR+OVERHEAD+COMPUTER)) (SHORTVALUE (TOTAL)) (DISPLAYPROPS (T))) ) (ADDRESS (LIST (STREET STRING) (CITY STRING) (STATE ATOM) (ZIP INTEGER)) PROP [(SHORTVALUE ((CONCAT CITY ", " STATE] ) (PHONE-NUMBER (LIST (AREA INTEGER) (NUMBER INTEGER)) PROP [(SHORTVALUE ((CONCAT "(" AREA ") " (SUBSTRING NUMBER 1 3) "-" (SUBSTRING NUMBER 4 7] ADJ ((LOCAL (AREA=415 OR AREA=408))) ) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (SHORTYEAR INTEGER)) PROP [[MONTHNAME ((CAR (NTH (QUOTE (January February March April May June July August September October November December)) MONTH] (YEAR (SHORTYEAR + 1900)) (SHORTVALUE ((CONCAT MONTHNAME " " DAY ", " YEAR] ) (PICTURE ANYTHING MSG ((EDIT PAINTW) (GEVDISPLAY PICTURE-GEVDISPLAY)) ) (CAMPUS-ADDRESS (LIST (BUILDING BUILDING) (ROOM ATOM)) PROP [(SHORTVALUE ((CONCAT BUILDING:ABBREVIATION " " ROOM] ) (BUILDING (ATOM (PROPLIST (ABBREVIATION ATOM) (NAME STRING) (NUMBER INTEGER))) PROP ((SHORTVALUE (NAME))) ) (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP [(PI (3.141593)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) (SQUARESIDE ((SQRT AREA))) (DISPLAYPROPS ((QUOTE (DIAMETER CIRCUMFERENCE AREA] MSG ((GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) (STANDARD (AREA_100.0))) ADJ ((BIG (AREA>100)) (SMALL (AREA<80))) ) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP [(MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE , Y = Y/MAGNITUDE] ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG [(PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI] ) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T))) ) (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T))) ) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR) ) ] (DEFINEQ (GEVDEMO-INIT [GLAMBDA NIL (* edited: " 6-NOV-82 14:41") (* Initialize data structures for GEV demo.) (PROG NIL (HPP _(A PROJECT WITH TITLE = "Heuristic Programming Project" , ABBREVIATION =(QUOTE HPP))) (MJH _(A BUILDING WITH ABBREVIATION =(QUOTE MJH) , NAME = "Margaret Jacks Hall" , NUMBER = 460)) (ARPA _(AN AGENCY WITH NAME = "Defense Advanced Research Projects Agency" , ABBREVIATION =(QUOTE ARPA) , ADDRESS =(AN ADDRESS WITH STREET = "1400 Wilson Blvd." , CITY = "Arlington" , STATE =(QUOTE VA) , ZIP = 22209) , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER = 6944349))) (NSF _(AN AGENCY WITH NAME = "National Science Foundation" , ABBREVIATION =(QUOTE NSF) , ADDRESS =(AN ADDRESS WITH STREET = "1800 G STREET N.W." , CITY = "Washington" , STATE =(QUOTE DC) , ZIP = 20550) , PHONE =(A PHONE-NUMBER WITH AREA = 202 , NUMBER = 6327346))) (NIH _(AN AGENCY WITH NAME = "National Institutes of Health" , ABBREVIATION =(QUOTE NIH) , ADDRESS =(AN ADDRESS WITH STREET = "9000 Rockville Pike" , CITY = "Bethesda" , STATE =(QUOTE MD) , ZIP = 20001) , PHONE =(A PHONE-NUMBER WITH AREA = 301 , NUMBER = 4964000))) (GSN _(A PERSON WITH NAME = "Gordon S. Novak Jr." , INITIALS =(QUOTE GSN) , TITLE =(QUOTE VISITOR) , PROJECT = HPP , SALARY = 30000.0 , SSNO = 455827977 , BIRTHDATE =(A DATE WITH DAY = 21 , MONTH = 7 , SHORTYEAR = 47) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4974532) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 244) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4935807) , HOME-ADDRESS =(AN ADDRESS WITH STREET = "3857 Ross Road" , CITY = "Palo Alto" , STATE =(QUOTE CA) , ZIP = 94303))) (TCR _(A PERSON WITH NAME = "Tom C. Rindfleisch" , INITIALS =(QUOTE TCR) , TITLE =(QUOTE ADMINISTRATOR) , PROJECT = HPP , SALARY = 30000.0 , SSNO = 452123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 47) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4972780) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4324321) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 236) , HOME-ADDRESS =(AN ADDRESS))) (EAF _(A PERSON WITH NAME = "Edward A. Feigenbaum" , INITIALS =(QUOTE EAF) , TITLE =(QUOTE PROF) , PROJECT = HPP , SALARY = 99999.0 , SSNO = 123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 37) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4974878) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 226) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4931234) , HOME-ADDRESS =(AN ADDRESS WITH STREET = " " , CITY = "Stanford" , STATE =( QUOTE CA) , ZIP = 94305))) (MRG _(A PERSON WITH NAME = "Michael R. Genesereth" , INITIALS =(QUOTE MRG) , TITLE =(QUOTE ASST-PROF) , PROJECT = HPP , SALARY = 31234.0 , SSNO = 123123477 , BIRTHDATE =(A DATE WITH DAY = 2 , MONTH = 1 , SHORTYEAR = 50) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4970324) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 234) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4324321) , HOME-ADDRESS =(AN ADDRESS))) (J5 _(A CONTRACT WITH TITLE = "Advanced A.I. Architectures" , LEADER = EAF , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 50000.0 , COMPUTER = 10000.0))) (IA _(A CONTRACT WITH TITLE = "Intelligent Agents" , LEADER = MRG , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 70000.0 , COMPUTER = 50000.0))) (DART _(A CONTRACT WITH TITLE = "Diagnosis and Repair Techniques" , LEADER = MRG , SPONSOR = ARPA , BUDGET =(A BUDGET WITH LABOR = 100000.0 , COMPUTER = 150000.0))) (GLISP _(A CONTRACT WITH TITLE = "GLISP" , LEADER = GSN , SPONSOR = ARPA , BUDGET =( A BUDGET WITH LABOR = 50000.0 , COMPUTER = 20000.0))) (CMPICTURE _(CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 100 HEIGHT _ 100))) (CM _(A PERSON WITH NAME = "Cookie Monster" , INITIALS =(QUOTE CM) , TITLE =(QUOTE MONSTER) , PROJECT = HPP , SALARY = 1.0 , SSNO = 123456789 , BIRTHDATE =(A DATE WITH MONTH = 4 , DAY = 1 , SHORTYEAR = 65) , PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4971234) , OFFICE =(A CAMPUS-ADDRESS WITH BUILDING = MJH , ROOM = 252) , HOME-PHONE =(A PHONE-NUMBER WITH AREA = 415 , NUMBER = 4561234) , HOME-ADDRESS =(AN ADDRESS WITH STREET = "123 Sesame Street" , CITY = "Palo Alto" , STATE =(QUOTE CA) , ZIP = 94303) , PICTURE = CMPICTURE)) (CARBM _(A CONTRACT WITH TITLE = "Carbohydrate Metabolism in Atypical Hominids" , LEADER = CM , SPONSOR = NIH , BUDGET =(A BUDGET WITH LABOR = 1.39 , COMPUTER = 5.0))) (HPP:ADMINISTRATOR _ TCR) (HPP:CONTRACTS _(LIST J5 IA DART GLISP CARBM)) (HPP:EXECUTIVES _(LIST EAF MRG GSN TCR)) (C _(A CIRCLE WITH START =(A VECTOR WITH X = 1 , Y = 1) , RADIUS = 5.0]) (TODAYS-DATE (GLAMBDA NIL (* edited: "22-OCT-82 16:54") (A DATE WITH MONTH = 10 , DAY = 15 , SHORTYEAR = 82))) (TOTAL-BUDGET (GLAMBDA (P:PROJECT) (* edited: "22-OCT-82 17:13") (PROG (SUM) (SUM_0.0) (FOR EACH CONTRACT SUM_+BUDGET:TOTAL) (RETURN SUM)))) ) (PUTPROPS TODAYS-DATE GLRESULTTYPE DATE) (GEVDEMO-INIT) (DECLARE: DONTCOPY (FILEMAP (NIL (4061 9998 (GEVDEMO-INIT 4071 . 9592) (TODAYS-DATE 9594 . 9764) (TOTAL-BUDGET 9766 . 9996))))) STOP |
Added psl-1983/glisp/gevdemo.sl version [61b0197c02].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GEVDEMO.PSL;1 5-FEB-83 15:41:04 (GLISPOBJECTS (PROJECT (ATOM (PROPLIST (TITLE STRING) (ABBREVIATION ATOM) (ADMINISTRATOR PERSON) (CONTRACTS (LISTOF CONTRACT)) (EXECUTIVES (LISTOF PERSON)))) PROP ((SHORTVALUE (ABBREVIATION)) (DISPLAYPROPS (T)) (BUDGET TOTAL-BUDGET))) (CONTRACT (ATOM (PROPLIST (TITLE STRING) (LEADER PERSON) (SPONSOR AGENCY) (BUDGET BUDGET))) PROP ((SHORTVALUE (TITLE)))) (AGENCY (ATOM (PROPLIST (NAME STRING) (ABBREVIATION ATOM) (ADDRESS ADDRESS) (PHONE PHONE-NUMBER))) PROP ((SHORTVALUE (ABBREVIATION)))) (PERSON (ATOM (PROPLIST (NAME STRING) (INITIALS ATOM) (TITLE ATOM) (PROJECT PROJECT) (SALARY REAL) (SSNO INTEGER) (BIRTHDATE DATE) (PHONE PHONE-NUMBER) (OFFICE CAMPUS-ADDRESS) (HOME-ADDRESS ADDRESS) (HOME-PHONE PHONE-NUMBER) (PICTURE PICTURE))) PROP ((SHORTVALUE (INITIALS)) (CONTRACTS ((THOSE CONTRACTS OF PROJECT WITH LEADER=self))) (AGE ((THE YEAR OF (TODAYS-DATE)) - BIRTHDATE:YEAR)) (MONTHLY-SALARY (SALARY/12)) (DISPLAYPROPS (T))) ADJ ((FACULTY ((MEMB TITLE '(PROF ASSOC-PROF ASST-PROF)))))) (BUDGET (LIST (LABOR REAL) (COMPUTER REAL)) PROP ((OVERHEAD (LABOR * 0.59)) (TOTAL (LABOR+OVERHEAD+COMPUTER)) (SHORTVALUE (TOTAL)) (DISPLAYPROPS (T)))) (ADDRESS (LIST (STREET STRING) (CITY STRING) (STATE ATOM) (ZIP INTEGER)) PROP ((SHORTVALUE ((CONCAT CITY ", " STATE))))) (PHONE-NUMBER (LIST (AREA INTEGER) (NUMBER INTEGER)) PROP ((SHORTVALUE ((CONCAT "(" AREA ") " (SUBSTRING NUMBER 1 3) "-" (SUBSTRING NUMBER 4 7))))) ADJ ((LOCAL (AREA=415 OR AREA=408)))) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (SHORTYEAR INTEGER)) PROP ((MONTHNAME ((CAR (NTH '(January February March April May June July August September October November December) MONTH)))) (YEAR (SHORTYEAR + 1900)) (SHORTVALUE ((CONCAT MONTHNAME " " DAY ", " YEAR))))) (PICTURE ANYTHING MSG ((EDIT PAINTW) (GEVDISPLAY PICTURE-GEVDISPLAY))) (CAMPUS-ADDRESS (LIST (BUILDING BUILDING) (ROOM ATOM)) PROP ((SHORTVALUE ((CONCAT BUILDING:ABBREVIATION " " ROOM))))) (BUILDING (ATOM (PROPLIST (ABBREVIATION ATOM) (NAME STRING) (NUMBER INTEGER))) PROP ((SHORTVALUE (NAME)))) (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.141593)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) (SQUARESIDE ((SQRT AREA))) (DISPLAYPROPS ('(DIAMETER CIRCUMFERENCE AREA)))) MSG ((GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) (STANDARD (AREA_100.0))) ADJ ((BIG (AREA>100)) (SMALL (AREA<80)))) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y = Y/MAGNITUDE)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI))))) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T)))) (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T)))) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR)) ) % edited: 6-NOV-82 14:41 % Initialize data structures for GEV demo. (DG GEVDEMO-INIT NIL (PROG NIL (HPP _ (A PROJECT WITH TITLE = "Heuristic Programming Project" ABBREVIATION = 'HPP)) (MJH _ (A BUILDING WITH ABBREVIATION = 'MJH NAME = "Margaret Jacks Hall" NUMBER = 460)) (ARPA _ (AN AGENCY WITH NAME = "Defense Advanced Research Projects Agency" ABBREVIATION = 'ARPA ADDRESS = (AN ADDRESS WITH STREET = "1400 Wilson Blvd." CITY = "Arlington" STATE = 'VA ZIP = 22209) PHONE = (A PHONE-NUMBER WITH AREA = 202 NUMBER = 6944349))) (NSF _ (AN AGENCY WITH NAME = "National Science Foundation" ABBREVIATION = 'NSF ADDRESS = (AN ADDRESS WITH STREET = "1800 G STREET N.W." CITY = "Washington" STATE = 'DC ZIP = 20550) PHONE = (A PHONE-NUMBER WITH AREA = 202 NUMBER = 6327346))) (NIH _ (AN AGENCY WITH NAME = "National Institutes of Health" ABBREVIATION = 'NIH ADDRESS = (AN ADDRESS WITH STREET = "9000 Rockville Pike" CITY = "Bethesda" STATE = 'MD ZIP = 20001) PHONE = (A PHONE-NUMBER WITH AREA = 301 NUMBER = 4964000))) (GSN _ (A PERSON WITH NAME = "Gordon S. Novak Jr." INITIALS = 'GSN TITLE = 'VISITOR PROJECT = HPP SALARY = 30000.0 SSNO = 455827977 BIRTHDATE = (A DATE WITH DAY = 21 MONTH = 7 SHORTYEAR = 47) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4974532) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 244) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4935807) HOME-ADDRESS = (AN ADDRESS WITH STREET = "3857 Ross Road" CITY = "Palo Alto" STATE = 'CA ZIP = 94303))) (TCR _ (A PERSON WITH NAME = "Tom C. Rindfleisch" INITIALS = 'TCR TITLE = 'ADMINISTRATOR PROJECT = HPP SALARY = 30000.0 SSNO = 452123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 47) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4972780) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4324321) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 236) HOME-ADDRESS = (AN ADDRESS))) (EAF _ (A PERSON WITH NAME = "Edward A. Feigenbaum" INITIALS = 'EAF TITLE = 'PROF PROJECT = HPP SALARY = 99999.0 SSNO = 123123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 37) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4974878) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 226) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4931234) HOME-ADDRESS = (AN ADDRESS WITH STREET = " " CITY = "Stanford" STATE = 'CA ZIP = 94305))) (MRG _ (A PERSON WITH NAME = "Michael R. Genesereth" INITIALS = 'MRG TITLE = 'ASST-PROF PROJECT = HPP SALARY = 31234.0 SSNO = 123123477 BIRTHDATE = (A DATE WITH DAY = 2 MONTH = 1 SHORTYEAR = 50) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4970324) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 234) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4324321) HOME-ADDRESS = (AN ADDRESS))) (J5 _ (A CONTRACT WITH TITLE = "Advanced A.I. Architectures" LEADER = EAF SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 50000.0 COMPUTER = 10000.0))) (IA _ (A CONTRACT WITH TITLE = "Intelligent Agents" LEADER = MRG SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 70000.0 COMPUTER = 50000.0))) (DART _ (A CONTRACT WITH TITLE = "Diagnosis and Repair Techniques" LEADER = MRG SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 100000.0 COMPUTER = 150000.0))) (GLISP _ (A CONTRACT WITH TITLE = "GLISP" LEADER = GSN SPONSOR = ARPA BUDGET = (A BUDGET WITH LABOR = 50000.0 COMPUTER = 20000.0))) (CM _ (A PERSON WITH NAME = "Cookie Monster" INITIALS = 'CM TITLE = 'MONSTER PROJECT = HPP SALARY = 1.0 SSNO = 123456789 BIRTHDATE = (A DATE WITH MONTH = 4 DAY = 1 SHORTYEAR = 65) PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4971234) OFFICE = (A CAMPUS-ADDRESS WITH BUILDING = MJH ROOM = 252) HOME-PHONE = (A PHONE-NUMBER WITH AREA = 415 NUMBER = 4561234) HOME-ADDRESS = (AN ADDRESS WITH STREET = "123 Sesame Street" CITY = "Palo Alto" STATE = 'CA ZIP = 94303) )) (CARBM _ (A CONTRACT WITH TITLE = "Carbohydrate Metabolism in Atypical Hominids" LEADER = CM SPONSOR = NIH BUDGET = (A BUDGET WITH LABOR = 1.39 COMPUTER = 5.0))) (HPP:ADMINISTRATOR _ TCR) (HPP:CONTRACTS _ (LIST J5 IA DART GLISP CARBM)) (HPP:EXECUTIVES _ (LIST EAF MRG GSN TCR)) (C _ (A CIRCLE WITH START = (A VECTOR WITH X = 1 Y = 1) RADIUS = 5.0)))) % edited: 22-OCT-82 16:54 (DG TODAYS-DATE NIL (A DATE WITH MONTH = 10 DAY = 15 SHORTYEAR = 82)) % edited: 22-OCT-82 17:13 (DG TOTAL-BUDGET (P:PROJECT) (PROG (SUM) (SUM_0.0) (FOR EACH CONTRACT SUM_+BUDGET:TOTAL) (RETURN SUM))) (PUT 'TODAYS-DATE 'GLRESULTTYPE 'DATE) |
Added psl-1983/glisp/glhead.psl version [d93d89617a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLHEAD.PSL.13 16 FEB. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES GLTYPESUSED)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST TYPE GLNRECURSIONS GLFNSUBS GLEVALSUBS)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) |
Added psl-1983/glisp/glhead.sl version [0cf7875034].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLHEAD.PSL.9 14 Jan. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) |
Added psl-1983/glisp/glisp.b version [72d1ff09ef].
cannot compute difference between binary files
Added psl-1983/glisp/glisp.sl version [734da3398b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 | % % GLHEAD.PSL.13 16 FEB. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES GLTYPESUSED)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST TYPE GLNRECURSIONS GLFNSUBS GLEVALSUBS)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) % {DSK}GLISP.PSL;1 25-FEB-83 18:52:28 % GSN 17-FEB-83 14:23 % Transform an expression X for Portable Standard Lisp dialect. (DE GLPSLTRANSFM (X) (PROG (TMP NOTFLG) % First do argument reversals. (COND ((NOT (PAIRP X)) (RETURN X)) ((MEMQ (CAR X) '(push PUSH)) (SETQ X (LIST (CAR X) (CADDR X) (CADR X)))) ((MEMQ (CAR X) NIL) (SETQ X (LIST (CAR X) (CADR X) (CADDDR X) (CADDR X)))) ((EQ (CAR X) 'APPLY*) (SETQ X (LIST 'APPLY (CADR X) (CONS 'LIST (CDDR X)))))) % Now see if the result will be negated. (SETQ NOTFLG (MEMQ (CAR X) '(NLISTP BOUNDP GEQ LEQ IGEQ ILEQ))) (COND ((SETQ TMP (ASSOC (CAR X) '((MEMB MEMQ) (FMEMB MEMQ) (FASSOC ASSOC) (LITATOM IDP) (GETPROP GET) (GETPROPLIST PROP) (PUTPROP PUT) (LISTP PAIRP) (NLISTP PAIRP) (NEQ NE) (IGREATERP GREATERP) (IGEQ LESSP) (GEQ LESSP) (ILESSP LESSP) (ILEQ GREATERP) (LEQ GREATERP) (IPLUS PLUS) (IDIFFERENCE DIFFERENCE) (ITIMES TIMES) (IQUOTIENT QUOTIENT) (* CommentOutCode) (MAPCONC MAPCAN) (DECLARE CommentOutCode) (NCHARS FlatSize2) (NTHCHAR GLNTHCHAR) (DREVERSE REVERSIP) (STREQUAL String!=) (ALPHORDER String!<!=) (GLSTRGREATERP String!>) (GLSTRGEP String!>!=) (GLSTRLESSP String!<) (EQP EQN) (LAST LASTPAIR) (NTH PNth) (NCONC1 ACONC) (U-CASE GLUCASE) (DSUBST SUBSTIP) (BOUNDP UNBOUNDP) (KWOTE MKQUOTE) (UNPACK EXPLODE) (PACK IMPLODE) (DREMOVE DELETIP) (GETD GETDDD) (PUTD PUTDDD)))) (SETQ X (CONS (CADR TMP) (CDR X)))) ((AND (EQ (CAR X) 'RETURN) (NULL (CDR X))) (SETQ X (LIST (CAR X) NIL))) ((AND (EQ (CAR X) 'APPEND) (NULL (CDDR X))) (SETQ X (LIST (CAR X) (CADR X) NIL))) ((EQ (CAR X) 'ERROR) (SETQ X (LIST (CAR X) 0 (COND ((NULL (CDR X)) NIL) ((NULL (CDDR X)) (CADR X)) (T (CONS 'LIST (CDR X))))))) ((EQ (CAR X) 'SELECTQ) (RPLACA X 'CASEQ) (SETQ TMP (NLEFT X 2)) (COND ((NULL (CADR TMP)) (RPLACD TMP NIL)) (T (RPLACD TMP (LIST (LIST T (CADR TMP)))))))) (RETURN (COND (NOTFLG (LIST 'NOT X)) (T X))))) % edited: 18-NOV-82 11:47 (DF A (L) (GLAINTERPRETER L)) % edited: 18-NOV-82 11:47 (DF AN (L) (GLAINTERPRETER L)) % edited: 29-OCT-81 14:25 (DE GL-A-AN? (X) (MEMQ X '(A AN a an An))) % GSN 17-FEB-83 11:31 % Test whether FNNAME is an abstract function. (DE GLABSTRACTFN? (FNNAME) (PROG (DEFN) (RETURN (AND (SETQ DEFN (GLGETD FNNAME)) (PAIRP DEFN) (EQ (CAR DEFN) 'MLAMBDA))))) % GSN 16-FEB-83 12:39 % Add a PROPerty entry of type PROPTYPE to structure STRNAME. (DE GLADDPROP (STRNAME PROPTYPE LST) (PROG (PL SUBPL) (COND ((NOT (AND (ATOM STRNAME) (SETQ PL (GET STRNAME 'GLSTRUCTURE)))) (ERROR 0 (LIST STRNAME " has no structure definition."))) ((SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (NCONC SUBPL (LIST LST))) (T (NCONC PL (LIST PROPTYPE (LIST LST))))))) % edited: 25-Jan-81 18:17 % Add the type SDES to RESULTTYPE in GLCOMP (DE GLADDRESULTTYPE (SDES) (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE SDES)) ((AND (PAIRP RESULTTYPE) (EQ (CAR RESULTTYPE) 'OR)) (COND ((NOT (MEMBER SDES (CDR RESULTTYPE))) (ACONC RESULTTYPE SDES)))) ((NOT (EQUAL SDES RESULTTYPE)) (SETQ RESULTTYPE (LIST 'OR RESULTTYPE SDES))))) % edited: 2-Jan-81 13:37 % Add an entry to the current context for a variable ATM, whose NAME % in context is given, and which has structure STR. The entry is % pushed onto the front of the list at the head of the context. (DE GLADDSTR (ATM NAME STR CONTEXT) (RPLACA CONTEXT (CONS (LIST ATM NAME STR) (CAR CONTEXT)))) % GSN 10-FEB-83 12:56 % edited: 17-Sep-81 13:58 % Compile code to test if SOURCE is PROPERTY. (DE GLADJ (SOURCE PROPERTY ADJWD) (PROG (ADJL TRANS TMP FETCHCODE) (COND ((EQ ADJWD 'ISASELF) (COND ((SETQ ADJL (GLSTRPROP PROPERTY 'ISA 'self NIL)) (GO A)) (T (RETURN NIL)))) ((SETQ ADJL (GLSTRPROP (CADR SOURCE) ADJWD PROPERTY NIL)) (GO A))) % See if the adjective can be found in a TRANSPARENT substructure. (SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE))) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLADJ (LIST '*GL* (GLXTRTYPE (CAR TRANS))) PROPERTY ADJWD)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR SOURCE) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR SOURCE)) (RETURN TMP)) (T (SETQ TRANS (CDR TRANS)) (GO B))) A (COND ((AND (PAIRP (CADR ADJL)) (MEMQ (CAADR ADJL) '(NOT Not not)) (ATOM (CADADR ADJL)) (NULL (CDDADR ADJL)) (SETQ TMP (GLSTRPROP (CADR SOURCE) ADJWD (CADADR ADJL) NIL))) (SETQ ADJL TMP) (SETQ NOTFLG (NOT NOTFLG)) (GO A))) (RETURN (GLCOMPMSGL SOURCE ADJWD ADJL NIL CONTEXT)))) % GSN 10-FEB-83 15:08 (DE GLAINTERPRETER (L) (PROG (CODE GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLNRECURSIONS) (SETQ GLNATOM 0) (SETQ GLNRECURSIONS 0) (SETQ FAULTFN 'GLAINTERPRETER) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (SETQ CODE (GLDOA (CONS 'A L))) (RETURN (EVAL (CAR CODE))))) % edited: 26-DEC-82 15:40 % AND operator (DE GLANDFN (LHS RHS) (COND ((NULL LHS) RHS) ((NULL RHS) LHS) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND) (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (APPEND (CAR LHS) (CDAR RHS)) (CADR LHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND)) (LIST (APPEND (CAR LHS) (LIST (CAR RHS))) (CADR LHS))) ((AND (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (CONS 'AND (CONS (CAR LHS) (CDAR RHS))) (CADR LHS))) ((AND (PAIRP (CADR RHS)) (EQ (CAADR RHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'INTERSECTION (CAR LHS) (CAR RHS)) (CADR RHS))) ((GLDOMSG LHS 'AND (LIST RHS))) ((GLUSERSTROP LHS 'AND RHS)) (T (LIST (LIST 'AND (CAR LHS) (CAR RHS)) (CADR RHS))))) % edited: 19-MAY-82 13:54 % Test if ATM is the name of any CAR/CDR combination. If so, the value % is a list of the intervening letters in reverse order. (DE GLANYCARCDR? (ATM) (PROG (RES N NMAX TMP) (OR (AND (EQ (GLNTHCHAR ATM 1) 'C) (EQ (GLNTHCHAR ATM -1) 'R)) (RETURN NIL)) (SETQ NMAX (SUB1 (FlatSize2 ATM))) (SETQ N 2) A (COND ((GREATERP N NMAX) (RETURN RES)) ((OR (EQ (SETQ TMP (GLNTHCHAR ATM N)) 'D) (EQ TMP 'A)) (SETQ RES (CONS TMP RES)) (SETQ N (ADD1 N)) (GO A)) (T (RETURN NIL))))) % edited: 26-OCT-82 15:26 % Try to get indicator IND from an ATOM structure. (DE GLATOMSTRFN (IND DES DESLIST) (PROG (TMP) (RETURN (OR (AND (SETQ TMP (ASSOC 'PROPLIST (CDR DES))) (GLPROPSTRFN IND TMP DESLIST T)) (AND (SETQ TMP (ASSOC 'BINDING (CDR DES))) (GLSTRVALB IND (CADR TMP) '(EVAL *GL*))))))) % GSN 1-FEB-83 16:35 % edited: 14-Sep-81 12:45 % Test whether STR is a legal ATOM structure. (DE GLATMSTR? (STR) (PROG (TMP) (COND ((OR (AND (CDR STR) (OR (NOT (PAIRP (CADR STR))) (AND (CDDR STR) (OR (NOT (PAIRP (CADDR STR))) (CDDDR STR)))))) (RETURN NIL))) (COND ((SETQ TMP (ASSOC 'BINDING (CDR STR))) (COND ((OR (CDDR TMP) (NULL (GLOKSTR? (CADR TMP)))) (RETURN NIL))))) (COND ((SETQ TMP (ASSOC 'PROPLIST (CDR STR))) (RETURN (EVERY (CDR TMP) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X))))))))) (RETURN T))) % edited: 23-DEC-82 10:43 % Test whether TYPE is implemented as an ATOM structure. (DE GLATOMTYPEP (TYPE) (PROG (TYPEB) (RETURN (OR (EQ TYPE 'ATOM) (AND (PAIRP TYPE) (MEMQ (CAR TYPE) '(ATOM ATOMOBJECT))) (AND (NE (SETQ TYPEB (GLXTRTYPEB TYPE)) TYPE) (GLATOMTYPEP TYPEB)))))) % edited: 24-AUG-82 17:21 (DE GLBUILDALIST (ALIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL ALIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop ALIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (ACONC LIS (GLBUILDCONS (MKQUOTE (CAR TMP1)) TMP2 T))))) (GO A))) % edited: 9-DEC-82 17:14 % Generate code to build a CONS structure. OPTFLG is true iff the % structure does not need to be a newly created one. (DE GLBUILDCONS (X Y OPTFLG) (COND ((NULL Y) (GLBUILDLIST (LIST X) OPTFLG)) ((AND (PAIRP Y) (EQ (CAR Y) 'LIST)) (GLBUILDLIST (CONS X (CDR Y)) OPTFLG)) ((AND OPTFLG (GLCONST? X) (GLCONST? Y)) (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y)))) ((AND (GLCONSTSTR? X) (GLCONSTSTR? Y)) (LIST 'COPY (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y))))) (T (LIST 'CONS X Y)))) % edited: 9-DEC-82 17:13 % Build a LIST structure, possibly doing compile-time constant % folding. OPTFLG is true iff the structure does not need to be a % newly created copy. (DE GLBUILDLIST (LST OPTFLG) (COND ((EVERY LST (FUNCTION GLCONST?)) (COND (OPTFLG (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))) (T (GLGENCODE (LIST 'APPEND (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))))) ((EVERY LST (FUNCTION GLCONSTSTR?)) (GLGENCODE (LIST 'COPY (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))) (T (CONS 'LIST LST)))) % edited: 19-OCT-82 15:05 % Build code to do (NOT CODE) , doing compile-time folding if % possible. (DE GLBUILDNOT (CODE) (PROG (TMP) (COND ((GLCONST? CODE) (RETURN (NOT (GLCONSTVAL CODE)))) ((NOT (PAIRP CODE)) (RETURN (LIST 'NOT CODE))) ((EQ (CAR CODE) 'NOT) (RETURN (CADR CODE))) ((NOT (ATOM (CAR CODE))) (RETURN NIL)) ((SETQ TMP (ASSOC (CAR CODE) '((EQ NE) (NE EQ) (LEQ GREATERP) (GEQ LESSP)))) (RETURN (CONS (CADR TMP) (CDR CODE)))) (T (RETURN (LIST 'NOT CODE)))))) % edited: 26-OCT-82 16:02 (DE GLBUILDPROPLIST (PLIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL PLIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop PLIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (NCONC LIS (LIST (MKQUOTE (CAR TMP1)) TMP2))))) (GO A))) % edited: 12-NOV-82 11:26 % Build a RECORD structure. (DE GLBUILDRECORD (STR PAIRLIST PREVLST) (PROG (TEMP ITEMS RECORDNAME) (COND ((ATOM (CADR STR)) (SETQ RECORDNAME (CADR STR)) (SETQ ITEMS (CDDR STR))) (T (SETQ ITEMS (CDR STR)))) (COND ((EQ (CAR STR) 'OBJECT) (SETQ ITEMS (CONS '(CLASS ATOM) ITEMS)))) (RETURN (CONS 'Vector (MAPCAR ITEMS (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))) ))))) % edited: 11-NOV-82 12:01 % Generate code to build a structure according to the structure % description STR. PAIRLIST is a list of elements of the form % (SLOTNAME CODE TYPE) for each named slot to be filled in in the % structure. (DE GLBUILDSTR (STR PAIRLIST PREVLST) (PROG (PROPLIS TEMP PROGG TMPCODE ATMSTR) (SETQ ATMSTR '((ATOM) (INTEGER . 0) (REAL . 0.0) (NUMBER . 0) (BOOLEAN) (NIL) (ANYTHING))) (COND ((NULL STR) (RETURN NIL)) ((ATOM STR) (COND ((SETQ TEMP (ASSOC STR ATMSTR)) (RETURN (CDR TEMP))) ((MEMQ STR PREVLST) (RETURN NIL)) ((SETQ TEMP (GLGETSTR STR)) (RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST)))) (T (RETURN NIL)))) ((NOT (PAIRP STR)) (GLERROR 'GLBUILDSTR (LIST "Illegal structure type encountered:" STR)) (RETURN NIL))) (RETURN (CASEQ (CAR STR) (CONS (GLBUILDCONS (GLBUILDSTR (CADR STR) PAIRLIST PREVLST) (GLBUILDSTR (CADDR STR) PAIRLIST PREVLST) NIL)) (LIST (GLBUILDLIST (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST)))) NIL)) (LISTOBJECT (GLBUILDLIST (CONS (MKQUOTE (CAR PREVLST)) (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))))) NIL)) (ALIST (GLBUILDALIST (CDR STR) PREVLST)) (PROPLIST (GLBUILDPROPLIST (CDR STR) PREVLST)) (ATOM (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (COND ((SETQ TEMP (ASSOC 'BINDING STR)) (SETQ TMPCODE (GLBUILDSTR (CADR TEMP) PAIRLIST PREVLST)) (ACONC PROGG (LIST 'SET 'ATOMNAME TMPCODE)))) (COND ((SETQ TEMP (ASSOC 'PROPLIST STR)) (SETQ PROPLIS (CDR TEMP)) (GLPUTPROPS PROPLIS PREVLST))) (ACONC PROGG (COPY '(RETURN ATOMNAME))) PROGG) (ATOMOBJECT (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (LIST 'QUOTE 'CLASS) (MKQUOTE (CAR PREVLST))))) (GLPUTPROPS (CDR STR) PREVLST) (ACONC PROGG (COPY '(RETURN ATOMNAME)))) (TRANSPARENT (AND (NOT (MEMQ (CADR STR) PREVLST)) (SETQ TEMP (GLGETSTR (CADR STR))) (GLBUILDSTR TEMP PAIRLIST (CONS (CADR STR) PREVLST)))) (LISTOF NIL) (RECORD (GLBUILDRECORD STR PAIRLIST PREVLST)) (OBJECT (GLBUILDRECORD STR (CONS (LIST 'CLASS (MKQUOTE (CAR PREVLST)) 'ATOM) PAIRLIST) PREVLST)) (T (COND ((ATOM (CAR STR)) (COND ((SETQ TEMP (ASSOC (CAR STR) PAIRLIST)) (CADR TEMP)) ((AND (ATOM (CADR STR)) (NOT (ASSOC (CADR STR) ATMSTR))) (GLBUILDSTR (CADR STR) NIL PREVLST)) (T (GLBUILDSTR (CADR STR) PAIRLIST PREVLST)))) (T NIL))))))) % edited: 19-MAY-82 14:27 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPE (LST STR) (COND ((NULL LST) STR) ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST (GLGETSTR STR))) ((NOT (PAIRP STR)) (ERROR 0 NIL)) (T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR))))) % edited: 19-MAY-82 14:41 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPEB (LST STR) (COND ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST STR)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((AND (ATOM (CAR STR)) (NOT (MEMQ (CAR STR) GLTYPENAMES)) (CDR STR) (NULL (CDDR STR))) (GLCARCDRRESULTTYPE LST (CADR STR))) ((EQ (CAR LST) 'A) (COND ((OR (EQ (CAR STR) 'LISTOF) (EQ (CAR STR) 'CONS) (EQ (CAR STR) 'LIST)) (GLCARCDRRESULTTYPE (CDR LST) (CADR STR))) (T NIL))) ((EQ (CAR LST) 'D) (COND ((EQ (CAR STR) 'CONS) (GLCARCDRRESULTTYPE (CDR LST) (CADDR STR))) ((EQ (CAR STR) 'LIST) (COND ((CDDR STR) (GLCARCDRRESULTTYPE (CDR LST) (CONS 'LIST (CDDR STR)))) (T NIL))) ((EQ (CAR STR) 'LISTOF) (GLCARCDRRESULTTYPE (CDR LST) STR)))) (T (ERROR 0 NIL)))) % edited: 13-JAN-82 13:45 % Test if X is a CAR or CDR combination up to 3 long. (DE GLCARCDR? (X) (MEMQ X '(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR))) % edited: 5-OCT-82 15:24 (DE GLCC (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN)))) % GSN 18-JAN-83 15:04 % Get the Class of object OBJ. (DE GLCLASS (OBJ) (PROG (CLASS) (RETURN (AND (SETQ CLASS (COND ((VectorP OBJ) (GetV OBJ 0)) ((ATOM OBJ) (GET OBJ 'CLASS)) ((PAIRP OBJ) (CAR OBJ)) (T NIL))) (GLCLASSP CLASS) CLASS)))) % edited: 11-NOV-82 11:23 % Test whether the object OBJ is a member of class CLASS. (DE GLCLASSMEMP (OBJ CLASS) (GLDESCENDANTP (GLCLASS OBJ) CLASS)) % edited: 11-NOV-82 11:45 % See if CLASS is a Class name. (DE GLCLASSP (CLASS) (PROG (TMP) (RETURN (AND (ATOM CLASS) (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (MEMQ (CAR (GLXTRTYPE (CAR TMP))) '(OBJECT ATOMOBJECT LISTOBJECT)))))) % GSN 9-FEB-83 16:58 % Execute a message to CLASS with selector SELECTOR and arguments % ARGS. PROPNAME is one of MSG, ADJ, ISA, PROP. (DE GLCLASSSEND (CLASS SELECTOR ARGS PROPNAME) (PROG (FNCODE) (COND ((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME)) (RETURN (COND ((ATOM FNCODE) (EVAL (CONS FNCODE (MAPCAR ARGS (FUNCTION KWOTE))))) (T (APPLY FNCODE ARGS)))))) (RETURN 'GLSENDFAILURE))) % GSN 10-FEB-83 15:09 % GLISP compiler function. GLAMBDAFN is the atom whose function % definition is being compiled; GLEXPR is the GLAMBDA expression to % be compiled. The compiled function is saved on the property list % of GLAMBDAFN under the indicator GLCOMPILED. The property % GLRESULTTYPE is the RESULT declaration, if specified; GLGLOBALS is % a list of global variables referenced and their types. (DE GLCOMP (GLAMBDAFN GLEXPR GLTYPESUBS GLFNSUBS ARGTYPES) (PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX RESULTTYPE GLGLOBALVARS RESULT GLSEPATOM GLSEPPTR VALBUSY EXPRSTACK GLTU GLNRECURSIONS) (SETQ GLSEPPTR 0) (SETQ GLNRECURSIONS 0) (COND ((NOT GLQUIETFLG) (PRINT (LIST 'GLCOMP GLAMBDAFN)))) (SETQ EXPRSTACK (LIST GLEXPR)) (SETQ GLNATOM 0) (SETQ GLTOPCTX (LIST NIL)) (SETQ GLTU GLTYPESUSED) (SETQ GLTYPESUSED NIL) % Process the argument list of the GLAMBDA. (SETQ NEWARGS (GLDECL (CADR GLEXPR) '(T NIL) GLTOPCTX GLAMBDAFN ARGTYPES)) % See if there is a RESULT declaration. (SETQ GLEXPR (CDDR GLEXPR)) (GLSKIPCOMMENTS) (GLRESGLOBAL) (GLSKIPCOMMENTS) (GLRESGLOBAL) (SETQ VALBUSY (NULL (CDR GLEXPR))) (SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX))) (PUT GLAMBDAFN 'GLRESULTTYPE (OR RESULTTYPE (CADR NEWEXPR))) (PUT GLAMBDAFN 'GLTYPESUSED GLTYPESUSED) (GLSAVEFNTYPES GLAMBDAFN GLTYPESUSED) (SETQ RESULT (GLUNWRAP (CONS 'LAMBDA (CONS NEWARGS (CAR NEWEXPR))) T)) (SETQ GLTYPESUSED GLTU) (RETURN RESULT))) % GSN 2-FEB-83 14:52 % Compile an abstract function into an instance function given the % specified set of type substitutions and function substitutions. (DE GLCOMPABSTRACT (FN INSTFN TYPESUBS FNSUBS ARGTYPES) (PROG (TMP) (COND (INSTFN) ((SETQ TMP (ASSOC FN FNSUBS)) (SETQ INSTFN (CDR TMP))) (T (SETQ INSTFN (GLINSTANCEFNNAME FN)))) (SETQ FNSUBS (CONS (CONS FN INSTFN) FNSUBS)) % Now compile the abstract function with the specified type % substitutions. (PUTDDD INSTFN (GLCOMP INSTFN (GLGETD FN) TYPESUBS FNSUBS ARGTYPES)) (RETURN INSTFN))) % GSN 10-FEB-83 15:09 % Compile a GLISP expression. CODE is a GLISP expression. VARLST is a % list of lists (VAR TYPE) . The result is a list (OBJCODE TYPE) % where OBJCODE is the Lisp code corresponding to CODE and TYPE is % the type returned by OBJCODE. (DE GLCOMPEXPR (CODE VARLST) (PROG (OBJCODE GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPEXPR) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (MAPC VARLST (FUNCTION (LAMBDA (X) (GLADDSTR (CAR X) NIL (CADR X) CONTEXT)))) (COND ((SETQ OBJCODE (GLPUSHEXPR CODE T CONTEXT T)) (RETURN (LIST (GLUNWRAP (CAR OBJCODE) T) (CADR OBJCODE))))))) % edited: 27-MAY-82 12:58 % Compile the function definition stored for the atom FAULTFN using % the GLISP compiler. (DE GLCOMPILE (FAULTFN) (GLAMBDATRAN (GLGETD FAULTFN))FAULTFN) % edited: 4-MAY-82 11:13 % Compile FN if not already compiled. (DE GLCOMPILE? (FN) (OR (GET FN 'GLCOMPILED) (GLCOMPILE FN))) % GSN 10-FEB-83 15:33 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSG (OBJECT MSGLST ARGLIST CONTEXT) (PROG (RESULT) (COND ((GREATERP (SETQ GLNRECURSIONS (ADD1 GLNRECURSIONS)) 9) (RETURN (GLERROR 'GLCOMPMSG (LIST "Infinite loop detected in compiling" (CAR MSGLST) "for object of type" (CADR OBJECT)))))) (SETQ RESULT (GLCOMPMSGB OBJECT MSGLST ARGLIST CONTEXT)) (SETQ GLNRECURSIONS (SUB1 GLNRECURSIONS)) (RETURN RESULT))) % GSN 10-FEB-83 15:13 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSGB (OBJECT MSGLST ARGLIST CONTEXT) (PROG (GLPROGLST RESULTTYPE METHOD RESULT VTYPE) (SETQ RESULTTYPE (LISTGET (CDDR MSGLST) 'RESULT)) (SETQ METHOD (CADR MSGLST)) (COND ((ATOM METHOD) % Function name is specified. (COND ((LISTGET (CDDR MSGLST) 'OPEN) (RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST) (CONS (CADR OBJECT) (LISTGET (CDDR MSGLST) 'ARGTYPES)) RESULTTYPE (LISTGET (CDDR MSGLST) 'SPECVARS)))) (T (RETURN (LIST (CONS METHOD (CONS (CAR OBJECT) (MAPCAR ARGLIST (FUNCTION CAR)))) (OR (GLRESULTTYPE METHOD (CONS (CADR OBJECT) (MAPCAR ARGLIST (FUNCTION CADR)))) (LISTGET (CDDR MSGLST) 'RESULT))))))) ((NOT (PAIRP METHOD)) (RETURN (GLERROR 'GLCOMPMSG (LIST "The form of Response is illegal for message" (CAR MSGLST))))) ((AND (PAIRP (CAR METHOD)) (MEMQ (CAAR METHOD) '(virtual Virtual VIRTUAL))) (OR (SETQ VTYPE (LISTGET (CDDR MSGLST) 'VTYPE)) (PROGN (SETQ VTYPE (GLMAKEVTYPE (CADR OBJECT) (CAR METHOD))) (NCONC MSGLST (LIST 'VTYPE VTYPE)))) (RETURN (LIST (CAR OBJECT) VTYPE)))) % The Method is a list of stuff to be compiled open. (SETQ CONTEXT (LIST NIL)) (COND ((ATOM (CAR OBJECT)) (GLADDSTR (LIST 'PROG1 (CAR OBJECT)) 'self (CADR OBJECT) CONTEXT)) ((AND (PAIRP (CAR OBJECT)) (EQ (CAAR OBJECT) 'PROG1) (ATOM (CADAR OBJECT)) (NULL (CDDAR OBJECT))) (GLADDSTR (CAR OBJECT) 'self (CADR OBJECT) CONTEXT)) (T (SETQ GLPROGLST (CONS (LIST 'self (CAR OBJECT)) GLPROGLST)) (GLADDSTR 'self NIL (CADR OBJECT) CONTEXT))) (SETQ RESULT (GLPROGN METHOD CONTEXT)) % If more than one expression resulted, embed in a PROGN. (RPLACA RESULT (COND ((CDAR RESULT) (CONS 'PROGN (CAR RESULT))) (T (CAAR RESULT)))) (RETURN (LIST (COND (GLPROGLST (GLGENCODE (LIST 'PROG GLPROGLST (LIST 'RETURN (CAR RESULT))))) (T (CAR RESULT))) (OR RESULTTYPE (CADR RESULT)))))) % GSN 16-FEB-83 17:37 % Attempt to compile code for a message list for an object. OBJECT is % the destination, in the form (<code> <type>) , PROPTYPE is the % property type (ADJ etc.) , MSGLST is the message list, and ARGS is % a list of arguments of the form (<code> <type>) . The result is of % the form (<code> <type>) , or NIL if failure. (DE GLCOMPMSGL (OBJECT PROPTYPE MSGLST ARGS CONTEXT) (PROG (TYPE SELECTOR NEWFN NEWMSGLST) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (SETQ SELECTOR (CAR MSGLST)) (RETURN (COND ((LISTGET (CDDR MSGLST) 'MESSAGE) (SETQ CONTEXT (LIST NIL)) (GLADDSTR (CAR OBJECT) 'self TYPE CONTEXT) (LIST (COND ((EQ PROPTYPE 'MSG) (CONS 'SEND (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (T (CONS 'SENDPROP (CONS (CAR OBJECT) (CONS SELECTOR (CONS PROPTYPE (MAPCAR ARGS (FUNCTION CAR)))))))) (GLEVALSTR (LISTGET (CDDR MSGLST) 'RESULT) CONTEXT))) ((LISTGET (CDDR MSGLST) 'SPECIALIZE) (SETQ NEWFN (GLINSTANCEFNNAME (CADR MSGLST))) (SETQ NEWMSGLST (LIST (CAR MSGLST) NEWFN 'SPECIALIZATION T)) (GLADDPROP (CADR OBJECT) PROPTYPE NEWMSGLST) (GLCOMPABSTRACT (CADR MSGLST) NEWFN NIL NIL (CONS (CADR OBJECT) (MAPCAR ARGS (FUNCTION CADR)))) (PUT NEWFN 'GLSPECIALIZATION (CONS (LIST (CADR MSGLST) (CADR OBJECT) PROPTYPE SELECTOR) (GET NEWFN 'GLSPECIALIZATION))) (NCONC NEWMSGLST (LIST 'RESULT (GET NEWFN 'GLRESULTTYPE))) (GLCOMPMSG OBJECT NEWMSGLST ARGS CONTEXT)) (T (GLCOMPMSG OBJECT MSGLST ARGS CONTEXT)))))) % GSN 26-JAN-83 10:13 % Compile the function FN Open, given as arguments ARGS with argument % types ARGTYPES. Types may be defined in the definition of function % FN (which may be either a GLAMBDA or LAMBDA function) or by % ARGTYPES; ARGTYPES takes precedence. (DE GLCOMPOPEN (FN ARGS ARGTYPES RESULTTYPE SPCVARS) (PROG (PTR FNDEF GLPROGLST NEWEXPR CONTEXT NEWARGS) % Put a new level on top of CONTEXT. (SETQ CONTEXT (LIST NIL)) (SETQ FNDEF (GLGETD FN)) % Get the parameter declarations and add to CONTEXT. (GLDECL (CADR FNDEF) '(T NIL) CONTEXT NIL NIL) % Make the function parameters into names and put in the values, % hiding any which are simple variables. (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (COND ((EQ ARGS T) (GLADDSTR (CAAR PTR) NIL (OR (CAR ARGTYPES) (CADDAR PTR)) CONTEXT) (SETQ NEWARGS (CONS (CAAR PTR) NEWARGS))) ((AND (ATOM (CAAR ARGS)) (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS))) % Wrap the atom in a PROG1 so it won't match as a name; the PROG1 will % generally be stripped later. (GLADDSTR (LIST 'PROG1 (CAAR ARGS)) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) ((AND (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS)) (PAIRP (CAAR ARGS)) (EQ (CAAAR ARGS) 'PROG1) (ATOM (CADAAR ARGS)) (NULL (CDDAAR ARGS))) (GLADDSTR (CAAR ARGS) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) (T % Since the actual argument is not atomic, make a PROG variable for % it. (SETQ GLPROGLST (CONS (LIST (CAAR PTR) (CAAR ARGS)) GLPROGLST)) (GLADDSTR (CAAR PTR) (CADAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT))) (SETQ PTR (CDR PTR)) (COND ((PAIRP ARGS) (SETQ ARGS (CDR ARGS)))) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ FNDEF (CDDR FNDEF)) % Get rid of comments at start of function. C (COND ((AND FNDEF (PAIRP (CAR FNDEF)) (EQ (CAAR FNDEF) '*)) (SETQ FNDEF (CDR FNDEF)) (GO C))) (SETQ NEWEXPR (GLPROGN FNDEF CONTEXT)) % Get rid of atomic result if it isnt busy outside. (COND ((AND (NOT VALBUSY) (CDAR EXPR) (OR (ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR) 2)))) (AND (PAIRP (CADR PTR)) (EQ (CAADR PTR) 'PROG1) (ATOM (CADADR PTR)) (NULL (CDDADR PTR))))) (RPLACD PTR NIL))) (SETQ RESULT (LIST (COND (GLPROGLST (SETQ PTR (LASTPAIR (CAR NEWEXPR))) (RPLACA PTR (LIST 'RETURN (CAR PTR))) (GLGENCODE (CONS 'PROG (CONS (REVERSIP GLPROGLST) (CAR NEWEXPR))))) ((CDAR NEWEXPR) (CONS 'PROGN (CAR NEWEXPR))) (T (CAAR NEWEXPR))) (OR RESULTTYPE (GLRESULTTYPE FN NIL) (CADR NEWEXPR)))) (COND ((EQ ARGS T) (RPLACA RESULT (LIST 'LAMBDA (REVERSIP NEWARGS) (CAR RESULT))))) (RETURN RESULT))) % GSN 1-FEB-83 16:18 % Compile a LAMBDA expression to compute the property PROPNAME of type % PROPTYPE for structure STR. The property type STR is allowed for % structure access. (DE GLCOMPPROP (STR PROPNAME PROPTYPE) (PROG (CODE PL SUBPL PROPENT) % See if the property has already been compiled. (COND ((AND (SETQ PL (GET STR 'GLPROPFNS)) (SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL)))) (RETURN (CADR PROPENT)))) % Compile code for this property and save it. (COND ((NOT (MEMQ PROPTYPE '(STR ADJ ISA PROP MSG))) (ERROR 0 NIL))) (OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE)) (RETURN NIL)) (COND ((NOT PL) (PUT STR 'GLPROPFNS (SETQ PL (COPY '((STR) (PROP) (ADJ) (ISA) (MSG))))) (SETQ SUBPL (ASSOC PROPTYPE PL)))) (RPLACD SUBPL (CONS (CONS PROPNAME CODE) (CDR SUBPL))) (RETURN (CAR CODE)))) % GSN 16-FEB-83 11:25 % Compile a message as a closed form, i.e., function name or LAMBDA % form. (DE GLCOMPPROPL (STR PROPNAME PROPTYPE) (PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPPROPL) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (COND ((EQ PROPTYPE 'STR) (COND ((SETQ CODE (GLSTRFN PROPNAME STR NIL)) (RETURN (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (SUBSTIP 'self '*GL* (CAR CODE)) T)) (CADR CODE)))) (T (RETURN NIL)))) ((SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME NIL)) (COND ((ATOM (CADR MSGL)) (COND ((LISTGET (CDDR MSGL) 'OPEN) (SETQ CODE (GLCOMPOPEN (CADR MSGL) T (LIST STR) NIL NIL))) (T (SETQ CODE (LIST (CADR MSGL) (GLRESULTTYPE (CADR MSGL) NIL)))))) ((SETQ CODE (GLADJ (LIST 'self STR) PROPNAME PROPTYPE)) (SETQ CODE (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (CAR CODE) T)) (CADR CODE)))))) ((SETQ TRANS (GLTRANSPARENTTYPES STR)) (GO B)) (T (RETURN NIL))) (RETURN (LIST (GLUNWRAP (CAR CODE) T) (OR (CADR CODE) (LISTGET (CDDR MSGL) 'RESULT)))) % Look for the message in a contained TRANSPARENT type. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS)) PROPNAME PROPTYPE)) (COND ((ATOM (CAR TMP)) (GLERROR 'GLCOMPPROPL (LIST "GLISP cannot currently" "handle inheritance of the property" PROPNAME "which is specified as a function name" "in a TRANSPARENT subtype. Sorry.")) (RETURN NIL))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) STR NIL)) (SETQ NEWVAR (GLMKVAR)) (GLSTRVAL FETCHCODE NEWVAR) (RETURN (LIST (GLUNWRAP (LIST 'LAMBDA (CONS NEWVAR (CDADAR TMP)) (LIST 'PROG (LIST (LIST (CAADAR TMP) (CAR FETCHCODE))) (LIST 'RETURN (CADDAR TMP)))) T) (CADR TMP)))) (T (SETQ TRANS (CDR TRANS)) (GO B))))) % edited: 30-DEC-82 10:39 % Attempt to infer the type of a constant expression. (DE GLCONSTANTTYPE (EXPR) (PROG (TMP TYPES) (COND ((SETQ TMP (COND ((FIXP EXPR) 'INTEGER) ((NUMBERP EXPR) 'NUMBER) ((ATOM EXPR) 'ATOM) ((STRINGP EXPR) 'STRING) ((NOT (PAIRP EXPR)) 'ANYTHING) ((EVERY EXPR (FUNCTION FIXP)) '(LISTOF INTEGER)) ((EVERY EXPR (FUNCTION NUMBERP)) '(LISTOF NUMBER)) ((EVERY EXPR (FUNCTION ATOM)) '(LISTOF ATOM)) ((EVERY EXPR (FUNCTION STRINGP)) '(LISTOF STRING)))) (RETURN TMP))) (SETQ TYPES (MAPCAR EXPR (FUNCTION GLCONSTANTTYPE))) (COND ((EVERY (CDR TYPES) (FUNCTION (LAMBDA (Y) (EQUAL Y (CAR TYPES))))) (RETURN (LIST 'LISTOF (CAR TYPES)))) (T (RETURN (CONS 'LIST TYPES)))))) % edited: 31-AUG-82 15:38 % Test X to see if it represents a compile-time constant value. (DE GLCONST? (X) (OR (NULL X) (EQ X T) (NUMBERP X) (AND (PAIRP X) (EQ (CAR X) 'QUOTE) (ATOM (CADR X))) (AND (ATOM X) (GET X 'GLISPCONSTANTFLG)))) % edited: 9-DEC-82 17:02 % Test to see if X is a constant structure. (DE GLCONSTSTR? (X) (OR (GLCONST? X) (AND (PAIRP X) (OR (EQ (CAR X) 'QUOTE) (AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NE (CAR X) 'APPEND) (NULL (CDDR X)) (NULL (CADDR X)))) (AND (EQ (CAR X) 'LIST) (EVERY (CDR X) (FUNCTION GLCONSTSTR?))) (AND (EQ (CAR X) 'CONS) (GLCONSTSTR? (CADR X)) (GLCONSTSTR? (CADDR X))))))) % edited: 9-DEC-82 17:07 % Get the value of a compile-time constant (DE GLCONSTVAL (X) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) ((AND (PAIRP X) (EQ (CAR X) 'QUOTE)) (CADR X)) ((PAIRP X) (COND ((AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NULL (CDDR X)) (NULL (CADDR X)))) (CADADR X)) ((EQ (CAR X) 'LIST) (MAPCAR (CDR X) (FUNCTION GLCONSTVAL))) ((EQ (CAR X) 'CONS) (CONS (GLCONSTVAL (CADR X)) (GLCONSTVAL (CADDR X)))) (T (ERROR 0 NIL)))) ((AND (ATOM X) (GET X 'GLISPCONSTANTFLG)) (GET X 'GLISPCONSTANTVAL)) (T (ERROR 0 NIL)))) % edited: 5-OCT-82 15:23 (DE GLCP (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN) (GLP FN)))) % GSN 28-JAN-83 09:29 % edited: 1-Jun-81 16:02 % Process a declaration list from a GLAMBDA expression. Each element % of the list is of the form <var>, <var>:<str-descr>, :<str-descr>, % or <var>: (A <str-descr>) or (A <str-descr>) . Forms without a % variable are accepted only if NOVAROK is true. If VALOK is true, a % PROG form (variable value) is allowed. The result is a list of % variable names. (DE GLDECL (LST FLGS GLTOPCTX FN ARGTYPES) (PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR NOVAROK VALOK) (SETQ NOVAROK (CAR FLGS)) (SETQ VALOK (CADR FLGS)) (COND ((NULL GLTOPCTX) (ERROR 0 NIL))) A % Get the next variable/description from LST (COND ((NULL LST) (SETQ ARGTYPES NIL) (SETQ CONTEXT GLTOPCTX) (MAPC (CAR GLTOPCTX) (FUNCTION (LAMBDA (S) (SETQ ARGTYPES (CONS (GLEVALSTR (CADDR S) GLTOPCTX) ARGTYPES)) (RPLACA (CDDR S) (CAR ARGTYPES))))) (SETQ RESULT (REVERSIP RESULT)) (COND (FN (PUT FN 'GLARGUMENTTYPES ARGTYPES))) (RETURN RESULT))) (SETQ TOP (pop LST)) (COND ((NOT (ATOM TOP)) (GO B))) (SETQ VARS NIL) (SETQ STR NIL) (GLSEPINIT TOP) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (COND ((EQ FIRST ':) (COND ((NULL SECOND) (COND ((AND NOVAROK LST (GLOKSTR? (CAR LST))) (GLDECLDS (GLMKVAR) (pop LST)) (GO A)) (T (GO E)))) ((AND NOVAROK (GLOKSTR? SECOND) (NULL (GLSEPNXT))) (GLDECLDS (GLMKVAR) SECOND) (GO A)) (T (GO E))))) D % At least one variable name has been found. Collect other variable % names until a <type> is found. (SETQ VARS (ACONC VARS FIRST)) (COND ((NULL SECOND) (GO C)) ((EQ SECOND ':) (COND ((AND (SETQ THIRD (GLSEPNXT)) (GLOKSTR? THIRD) (NULL (GLSEPNXT))) (SETQ STR THIRD) (GO C)) ((AND (NULL THIRD) (GLOKSTR? (CAR LST))) (SETQ STR (pop LST)) (GO C)) (T (GO E)))) ((EQ SECOND '!,) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)) ((ATOM (CAR LST)) (GLSEPINIT (pop LST)) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)))) (T (GO E))) C % Define the <type> for each variable on VARS. (MAPC VARS (FUNCTION (LAMBDA (X) (GLDECLDS X STR)))) (GO A) B % The top of LST is non-atomic. Must be either (A <type>) or % (<var> <value>) . (COND ((AND (GL-A-AN? (CAR TOP)) NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) ((AND VALOK (NOT (GL-A-AN? (CAR TOP))) (ATOM (CAR TOP)) (CDR TOP)) (SETQ EXPR (CDR TOP)) (SETQ TMP (GLDOEXPR NIL GLTOPCTX T)) (COND (EXPR (GO E))) (GLADDSTR (CAR TOP) NIL (CADR TMP) GLTOPCTX) (SETQ RESULT (CONS (LIST (CAR TOP) (CAR TMP)) RESULT))) ((AND NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) (T (GO E))) (GO A) E (GLERROR 'GLDECL (LIST "Bad argument structure" LST)) (RETURN NIL))) % GSN 26-JAN-83 13:17 % edited: 2-Jan-81 13:39 % Add ATM to the RESULT list of GLDECL, and declare its structure. (DE GLDECLDS (ATM STR) (PROG NIL % If a substitution exists for this type, use it. (COND (ARGTYPES (SETQ STR (pop ARGTYPES))) (GLTYPESUBS (SETQ STR (GLSUBSTTYPE STR GLTYPESUBS)))) (SETQ RESULT (CONS ATM RESULT)) (GLADDSTR ATM NIL STR GLTOPCTX))) % GSN 26-JAN-83 10:28 % Declare variables and types in top of CONTEXT. (DE GLDECLS (VARS TYPES CONTEXT) (PROG NIL A (COND ((NULL VARS) (RETURN NIL))) (GLADDSTR (CAR VARS) NIL (CAR TYPES) CONTEXT) (SETQ VARS (CDR VARS)) (SETQ TYPES (CDR TYPES)) (GO A))) % edited: 19-MAY-82 13:33 % Define the result types for a list of functions. The format of the % argument is a list of dotted pairs, (FN . TYPE) (DE GLDEFFNRESULTTYPES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (PUT Y 'GLRESULTTYPE (CAR X))))))))) % edited: 19-MAY-82 13:05 % Define the result type functions for a list of functions. The format % of the argument is a list of dotted pairs, (FN . TYPEFN) (DE GLDEFFNRESULTTYPEFNS (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PUT (CAR X) 'GLRESULTTYPEFN (CDR X)))))) % edited: 26-OCT-82 12:18 % Define properties for an object type. Each property is of the form % (<propname> (<definition>) <properties>) (DE GLDEFPROP (OBJECT PROP LST) (PROG (LSTP) (MAPC LST (FUNCTION (LAMBDA (X) (COND ((NOT (OR (AND (EQ PROP 'SUPERS) (ATOM X)) (AND (PAIRP X) (ATOM (CAR X)) (CDR X)))) (PRIN1 "GLDEFPROP: For object ") (PRIN1 OBJECT) (PRIN1 " the ") (PRIN1 PROP) (PRIN1 " property ") (PRIN1 X) (PRIN1 " has bad form.") (TERPRI) (PRIN1 "This property was ignored.") (TERPRI)) (T (SETQ LSTP (CONS X LSTP))))))) (NCONC (GET OBJECT 'GLSTRUCTURE) (LIST PROP (REVERSIP LSTP))))) % GSN 10-FEB-83 12:31 % edited: 17-Sep-81 12:21 % Process a Structure Description. The format of the argument is the % name of the structure followed by its structure description, % followed by other optional arguments. (DE GLDEFSTR (LST SYSTEMFLG) (PROG (STRNAME STR OLDSTR) (SETQ STRNAME (pop LST)) (COND ((AND (NOT SYSTEMFLG) (MEMQ STRNAME GLBASICTYPES)) (PRIN1 "The GLISP type ") (PRIN1 STRNAME) (PRIN1 " may not be redefined by the user.") (TERPRI) (RETURN NIL)) ((SETQ OLDSTR (GET STRNAME 'GLSTRUCTURE)) (COND ((EQUAL OLDSTR LST) (RETURN NIL)) ((NOT GLQUIETFLG) (PRIN1 STRNAME) (PRIN1 " structure redefined.") (TERPRI))) (GLSTRCHANGED STRNAME)) ((NOT SYSTEMFLG) NIL)) (SETQ STR (pop LST)) (PUT STRNAME 'GLSTRUCTURE (LIST STR)) (COND ((NOT (GLOKSTR? STR)) (PRIN1 STRNAME) (PRIN1 " has faulty structure specification.") (TERPRI))) (COND ((NOT (MEMQ STRNAME GLOBJECTNAMES)) (SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES)))) % Process the remaining specifications, if any. Each additional % specification is a list beginning with a keyword. LP (COND ((NULL LST) (RETURN NIL))) (CASEQ (CAR LST) ((ADJ Adj adj) (GLDEFPROP STRNAME 'ADJ (CADR LST))) ((PROP Prop prop) (GLDEFPROP STRNAME 'PROP (CADR LST))) ((ISA Isa IsA isA isa) (GLDEFPROP STRNAME 'ISA (CADR LST))) ((MSG Msg msg) (GLDEFPROP STRNAME 'MSG (CADR LST))) (T (GLDEFPROP STRNAME (CAR LST) (CADR LST)))) (SETQ LST (CDDR LST)) (GO LP))) % edited: 27-APR-82 11:01 (DF GLDEFSTRNAMES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PROG (TMP) (COND ((SETQ TMP (ASSOC (CAR X) GLUSERSTRNAMES)) (RPLACD TMP (CDR X))) (T (SETQ GLUSERSTRNAMES (ACONC GLUSERSTRNAMES X)) ))))))) % GSN 10-FEB-83 11:50 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % GSN 10-FEB-83 12:13 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSYSSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG T))))) % edited: 27-MAY-82 13:00 % This function is called by the user to define a unit package to the % GLISP system. The argument, a unit record, is a list consisting of % the name of a function to test an entity to see if it is a unit of % the units package, the name of the unit package's runtime GET % function, and an ALIST of operations on units and the functions to % perform those operations. Operations include GET, PUT, ISA, ISADJ, % NCONC, REMOVE, PUSH, and POP. (DE GLDEFUNITPKG (UNITREC) (PROG (LST) (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (SETQ GLUNITPKGS (ACONC GLUNITPKGS UNITREC)) (RETURN NIL)) ((EQ (CAAR LST) (CAR UNITREC)) (RPLACA LST UNITREC))) (SETQ LST (CDR LST)) (GO A))) % GSN 23-JAN-83 15:39 % Remove the GLISP structure definition for NAME. (DE GLDELDEF (NAME TYPE) (PUT NAME 'GLSTRUCTURE NIL)) % edited: 28-NOV-82 15:18 (DE GLDESCENDANTP (SUBCLASS CLASS) (PROG (SUPERS) (COND ((EQ SUBCLASS CLASS) (RETURN T))) (SETQ SUPERS (GLGETSUPERS SUBCLASS)) LP (COND ((NULL SUPERS) (RETURN NIL)) ((GLDESCENDANTP (CAR SUPERS) CLASS) (RETURN T))) (SETQ SUPERS (CDR SUPERS)) (GO LP))) % GSN 25-FEB-83 16:41 % edited: 25-Jun-81 15:26 % Function to compile an expression of the form (A <type> ...) (DE GLDOA (EXPR) (PROG (TYPE UNITREC TMP) (SETQ TYPE (CADR EXPR)) (COND ((AND (PAIRP TYPE) (EQ (CAR TYPE) 'TYPEOF)) (SETQ TYPE (GLGETTYPEOF TYPE)) (GLNOTICETYPE TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((GLGETSTR TYPE) (GLNOTICETYPE TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'A (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST EXPR)))) (T (GLERROR 'GLDOA (LIST "The type" TYPE "is not defined.")))))) % GSN 10-FEB-83 12:56 % Compile code for Case statement. (DE GLDOCASE (EXPR) (PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB) (SETQ TYPEOK T) (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (CAR TMP)) (SETQ SELECTORTYPE (CADR TMP)) (SETQ EXPR (CDDR EXPR)) % Get rid of of if present (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ EXPR (CDR EXPR)))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS 'SELECTQ (CONS SELECTOR (ACONC RESULT ELSECLAUSE)))) RESULTTYPE))) ((MEMQ (CAR EXPR) '(ELSE Else else)) (SETQ TMP (GLPROGN (CDR EXPR) CONTEXT)) (SETQ ELSECLAUSE (COND ((CDAR TMP) (CONS 'PROGN (CAR TMP))) (T (CAAR TMP)))) (SETQ EXPR NIL)) (T (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (SETQ RESULT (ACONC RESULT (CONS (COND ((ATOM (CAAR EXPR)) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES (CAAR EXPR) NIL)) (CADR TMPB)) (CAAR EXPR))) (T (MAPCAR (CAAR EXPR) (FUNCTION (LAMBDA (X) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES X NIL)) (CADR TMPB)) X)))))) (CAR TMP)))))) % If all the result types are the same, then we know the result of the % Case statement. (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 23-APR-82 14:38 % Compile a COND expression. (DE GLDOCOND (CONDEXPR) (PROG (RESULT TMP TYPEOK RESULTTYPE) (SETQ TYPEOK T) A (COND ((NULL (SETQ CONDEXPR (CDR CONDEXPR))) (GO B))) (SETQ TMP (GLPROGN (CAR CONDEXPR) CONTEXT)) (COND ((NE (CAAR TMP) NIL) (SETQ RESULT (ACONC RESULT (CAR TMP))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ RESULTTYPE NIL) (SETQ TYPEOK NIL))))))) (COND ((NE (CAAR TMP) T) (GO A))) B (RETURN (LIST (COND ((AND (NULL (CDR RESULT)) (EQ (CAAR RESULT) T)) (CONS 'PROGN (CDAR RESULT))) (T (CONS 'COND RESULT))) (AND TYPEOK RESULTTYPE))))) % edited: 30-DEC-82 10:49 % Compile a single expression. START is set if EXPR is the start of a % new expression, i.e., if EXPR might be a function call. The global % variable EXPR is the expression, CONTEXT the context in which it % is compiled. VALBUSY is T if the value of the expression is needed % outside the expression. The value is a list of the new expression % and its value-description. (DE GLDOEXPR (START CONTEXT VALBUSY) (PROG (FIRST TMP RESULT) (SETQ EXPRSTACK (CONS EXPR EXPRSTACK)) (COND ((NOT (PAIRP EXPR)) (GLERROR 'GLDOEXPR (LIST "Expression is not a list.")) (GO OUT)) ((AND (NOT START) (STRINGP (CAR EXPR))) (SETQ RESULT (LIST (PROG1 (CAR EXPR) (SETQ EXPR (CDR EXPR))) 'STRING)) (GO OUT)) ((OR (NOT (IDP (CAR EXPR))) (NOT START)) (GO A))) % Test the initial atom to see if it is a function name. It is assumed % to be a function name if it doesnt contain any GLISP operators and % the following atom doesnt start with a GLISP binary operator. (COND ((AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAR EXPR) '*)) (SETQ RESULT (LIST EXPR NIL)) (GO OUT)) ((MEMQ (CAR EXPR) ''Quote) (SETQ FIRST (CAR EXPR)) (GO B))) (GLSEPINIT (CAR EXPR)) % See if the initial atom contains an expression operator. (COND ((NE (SETQ FIRST (GLSEPNXT)) (CAR EXPR)) (COND ((OR (MEMQ (CAR EXPR) '(APPLY* BLKAPPLY* PACK* PP*)) (GETDDD (CAR EXPR)) (GET (CAR EXPR) 'MACRO) (AND (NE FIRST '~) (GLOPERATOR? FIRST))) (GLSEPCLR) (SETQ FIRST (CAR EXPR)) (GO B)) (T (GLSEPCLR) (GO A)))) ((OR (EQ FIRST '~) (EQ FIRST '-)) (GLSEPCLR) (GO A)) ((OR (NOT (PAIRP (CDR EXPR))) (NOT (IDP (CADR EXPR)))) (GO B))) % See if the initial atom is followed by an expression operator. (GLSEPINIT (CADR EXPR)) (SETQ TMP (GLSEPNXT)) (GLSEPCLR) (COND ((GLOPERATOR? TMP) (GO A))) % The EXPR is a function reference. Test for system functions. B (SETQ RESULT (CASEQ FIRST ('Quote (LIST EXPR (GLCONSTANTTYPE (CADR EXPR)))) ((GO Go go) (LIST EXPR NIL)) ((PROG Prog prog) (GLDOPROG EXPR CONTEXT)) ((FUNCTION Function function) (GLDOFUNCTION EXPR NIL CONTEXT T)) ((SETQ Setq setq) (GLDOSETQ EXPR)) ((COND Cond cond) (GLDOCOND EXPR)) ((RETURN Return return) (GLDORETURN EXPR)) ((FOR For for) (GLDOFOR EXPR)) ((THE The the) (GLDOTHE EXPR)) ((THOSE Those those) (GLDOTHOSE EXPR)) ((IF If if) (GLDOIF EXPR CONTEXT)) ((A a AN An an) (GLDOA EXPR)) ((_ SEND Send send) (GLDOSEND EXPR)) ((PROGN PROG2) (GLDOPROGN EXPR)) (PROG1 (GLDOPROG1 EXPR CONTEXT)) ((SELECTQ CASEQ) (GLDOSELECTQ EXPR CONTEXT)) ((WHILE While while) (GLDOWHILE EXPR CONTEXT)) ((REPEAT Repeat repeat) (GLDOREPEAT EXPR)) ((CASE Case case) (GLDOCASE EXPR)) ((MAP MAPLIST MAPCON MAPC MAPCAR MAPCONC MAPCAN) (GLDOMAP EXPR)) (T (GLUSERFN EXPR)))) (GO OUT) A % The current EXPR is possibly a GLISP expression. Parse the next % subexpression using GLPARSEXPR. (SETQ RESULT (GLPARSEXPR)) OUT (SETQ EXPRSTACK (CDR EXPRSTACK)) (RETURN RESULT))) % GSN 9-FEB-83 17:02 % edited: 21-Apr-81 11:25 % Compile code for a FOR loop. (DE GLDOFOR (EXPR) (PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT LOOPCONTENTS SINGFLAG LOOPCOND COLLECTCODE) (SETQ ORIGEXPR EXPR) (pop EXPR) % Parse the forms (FOR EACH <set> ...) and (FOR <var> IN <set> ...) (COND ((MEMQ (CAR EXPR) '(EACH Each each)) (SETQ SINGFLAG T) (pop EXPR)) ((AND (ATOM (CAR EXPR)) (MEMQ (CADR EXPR) '(IN In in))) (SETQ LOOPVAR (pop EXPR)) (pop EXPR)) (T (GO X))) % Now get the <set> (COND ((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG))) (GO X))) (SETQ DTYPE (GLXTRTYPE (CADR DOMAIN))) (COND ((OR (NULL DTYPE) (EQ DTYPE 'ANYTHING)) (SETQ DTYPE '(LISTOF ANYTHING))) ((OR (NOT (PAIRP DTYPE)) (NE (CAR DTYPE) 'LISTOF)) (OR (AND (PAIRP (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (EQ (CAR DTYPE) 'LISTOF)) (NULL DTYPE) (RETURN (GLERROR 'GLDOFOR (LIST "The domain of a FOR loop is of type" DTYPE "which is not a LISTOF type.")))) )) % Add a level onto the context for the inside of the loop. (SETQ NEWCONTEXT (CONS NIL CONTEXT)) % If a loop variable wasnt specified, make one. (OR LOOPVAR (SETQ LOOPVAR (GLMKVAR))) (GLADDSTR LOOPVAR (AND SINGFLAG DOMAINNAME) (CADR DTYPE) NEWCONTEXT) % See if a condition is specified. If so, add it to LOOPCOND. (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT NIL NIL))) ((MEMQ (CAR EXPR) '(WHICH Which which WHO Who who THAT That that)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT T T)))) (COND ((AND EXPR (MEMQ (CAR EXPR) '(when When WHEN))) (pop EXPR) (SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT T))))) (COND ((MEMQ (CAR EXPR) '(collect Collect COLLECT)) (pop EXPR) (SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T))) (T (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) (SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT))))) (RETURN (GLMAKEFORLOOP LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)) X (RETURN (GLUSERFN ORIGEXPR)))) % GSN 26-JAN-83 10:14 % Compile a functional expression. TYPES is a list of argument types % which is sent in from outside, e.g. when a mapping function is % compiled. (DE GLDOFUNCTION (EXPR ARGTYPES CONTEXT VALBUSY) (PROG (NEWCODE RESULTTYPE PTR ARGS) (COND ((NOT (AND (PAIRP EXPR) (MEMQ (CAR EXPR) ''FUNCTION))) (RETURN (GLPUSHEXPR EXPR T CONTEXT T))) ((ATOM (CADR EXPR)) (RETURN (LIST EXPR (GLRESULTTYPE (CADR EXPR) ARGTYPES)))) ((NOT (MEMQ (CAADR EXPR) '(GLAMBDA LAMBDA))) (GLERROR 'GLDOFUNCTION (LIST "Bad functional form.")))) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ ARGS (GLDECL (CADADR EXPR) '(T NIL) CONTEXT NIL NIL)) (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (GLADDSTR (CAAR PTR) NIL (OR (CADDAR PTR) (CAR ARGTYPES)) CONTEXT) (SETQ PTR (CDR PTR)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ NEWCODE (GLPROGN (CDDADR EXPR) CONTEXT)) (RETURN (LIST (LIST 'FUNCTION (CONS 'LAMBDA (CONS ARGS (CAR NEWCODE)))) (CADR NEWCODE))))) % edited: 4-MAY-82 10:46 % Process an IF ... THEN expression. (DE GLDOIF (EXPR CONTEXT) (PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT) (SETQ OLDCONTEXT CONTEXT) (pop EXPR) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'COND CONDLIST) TYPE)))) (SETQ CONTEXT (CONS NIL OLDCONTEXT)) (SETQ PRED (GLPREDICATE NIL CONTEXT NIL T)) (COND ((MEMQ (CAR EXPR) '(THEN Then then)) (pop EXPR))) (SETQ ACTIONS (CONS (CAR PRED) NIL)) (SETQ TYPE (CADR PRED)) C (SETQ CONDLIST (ACONC CONDLIST ACTIONS)) B (COND ((NULL EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSEIF ElseIf Elseif elseIf elseif)) (pop EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSE Else else)) (pop EXPR) (SETQ ACTIONS (CONS T NIL)) (SETQ TYPE 'BOOLEAN) (GO C)) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (ACONC ACTIONS (CAR TMP)) (SETQ TYPE (CADR TMP)) (GO B)) (T (GLERROR 'GLDOIF (LIST "IF statement contains bad code.")))))) % edited: 16-DEC-81 15:47 % Compile a LAMBDA expression for which the ARGTYPES are given. (DE GLDOLAMBDA (EXPR ARGTYPES CONTEXT) (PROG (ARGS NEWEXPR VALBUSY) (SETQ ARGS (CADR EXPR)) (SETQ CONTEXT (CONS NIL CONTEXT)) LP (COND (ARGS (GLADDSTR (CAR ARGS) NIL (CAR ARGTYPES) CONTEXT) (SETQ ARGS (CDR ARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP))) (SETQ VALBUSY T) (SETQ NEWEXPR (GLPROGN (CDDR EXPR) CONTEXT)) (RETURN (LIST (CONS 'LAMBDA (CONS (CADR EXPR) (CAR NEWEXPR))) (CADR NEWEXPR))))) % edited: 30-MAY-82 16:12 % Get a domain specification from the EXPR. If SINGFLAG is set and the % top of EXPR is a simple atom, the atom is made plural and used as % a variable or field name. (DE GLDOMAIN (SINGFLAG) (PROG (NAME FIRST) (COND ((MEMQ (CAR EXPR) '(THE The the)) (SETQ FIRST (CAR EXPR)) (RETURN (GLPARSFLD NIL))) ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (SETQ NAME (GLSEPNXT)) (CAR EXPR)) (pop EXPR) (SETQ DOMAINNAME NAME) (RETURN (COND (SINGFLAG (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ FIRST 'THE) (SETQ EXPR (CONS (GLPLURAL NAME) EXPR)) (GLPARSFLD NIL)) (T (GLIDNAME (GLPLURAL NAME) NIL)))) (T (GLIDNAME NAME NIL))))) (T (GLSEPCLR) (RETURN (GLDOEXPR NIL CONTEXT T))))) (T (RETURN (GLDOEXPR NIL CONTEXT T)))))) % edited: 29-DEC-82 14:50 % Compile code for MAP functions. MAPs are treated specially so that % types can be propagated. (DE GLDOMAP (EXPR) (PROG (MAPFN MAPSET SETTYPE MAPCODE NEWCODE RESULTTYPE ITEMTYPE) (SETQ MAPFN (CAR EXPR)) (SETQ EXPR (CDR EXPR)) (PROGN (SETQ MAPSET (GLDOEXPR NIL CONTEXT T)) (COND ((OR (NULL EXPR) (CDR EXPR)) (GLERROR 'GLDOMAP (LIST "Bad form of mapping function."))) (T (SETQ MAPCODE (CAR EXPR))))) (SETQ SETTYPE (GLXTRTYPEB (CADR MAPSET))) (COND ((AND (PAIRP SETTYPE) (EQ (CAR SETTYPE) 'LISTOF)) (SETQ ITEMTYPE (CASEQ MAPFN ((MAP MAPLIST MAPCON) SETTYPE) ((MAPC MAPCAR MAPCONC MAPCAN) (CADR SETTYPE)) (T (ERROR 0 NIL)))))) (SETQ NEWCODE (GLDOFUNCTION MAPCODE (LIST ITEMTYPE) CONTEXT (MEMQ MAPFN '(MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) ))) (SETQ RESULTTYPE (CASEQ MAPFN ((MAP MAPC) NIL) ((MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) (LIST 'LISTOF (CADR NEWCODE))) (T (ERROR 0 NIL)))) (RETURN (LIST (GLGENCODE (LIST MAPFN (CAR MAPSET) (CAR NEWCODE))) RESULTTYPE)))) % GSN 10-FEB-83 12:56 % Attempt to compile code for the sending of a message to an object. % OBJECT is the destination, in the form (<code> <type>) , SELECTOR % is the message selector, and ARGS is a list of arguments of the % form (<code> <type>) . The result is of this form, or NIL if % failure. (DE GLDOMSG (OBJECT SELECTOR ARGS) (PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (COND ((SETQ METHOD (GLSTRPROP TYPE 'MSG SELECTOR ARGS)) (RETURN (GLCOMPMSGL OBJECT 'MSG METHOD ARGS CONTEXT))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'MSG (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST OBJECT SELECTOR ARGS)))) ((SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT)))) ((AND (MEMQ TYPE '(NUMBER REAL INTEGER)) (MEMQ SELECTOR '(+ - * / ^ > < >= <=)) ARGS (NULL (CDR ARGS)) (MEMQ (GLXTRTYPE (CADAR ARGS)) '(NUMBER REAL INTEGER))) (RETURN (GLREDUCEARITH SELECTOR OBJECT (CAR ARGS)))) (T (RETURN NIL))) % See if the message can be handled by a TRANSPARENT subobject. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLDOMSG (LIST '*GL* (GLXTRTYPE (CAR TRANS))) SELECTOR ARGS)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR OBJECT) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR OBJECT)) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % GSN 26-JAN-83 10:14 % edited: 17-Sep-81 14:01 % Compile a PROG expression. (DE GLDOPROG (EXPR CONTEXT) (PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE) (pop EXPR) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ PROGLST (GLDECL (pop EXPR) '(NIL T) CONTEXT NIL NIL)) (SETQ CONTEXT (CONS NIL CONTEXT)) % Compile the contents of the PROG onto NEWEXPR % Compile the next expression in a PROG. L (COND ((NULL EXPR) (GO X))) (SETQ NEXTEXPR (pop EXPR)) (COND ((ATOM NEXTEXPR) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) % ***** % Set up the context for the label we just found. (GO L)) ((NOT (PAIRP NEXTEXPR)) (GLERROR 'GLDOPROG (LIST "PROG contains bad stuff:" NEXTEXPR)) (GO L)) ((EQ (CAR NEXTEXPR) '*) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) (GO L))) (COND ((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL)) (SETQ NEWEXPR (CONS (CAR TMP) NEWEXPR)))) (GO L) X (SETQ RESULT (CONS 'PROG (CONS PROGLST (REVERSIP NEWEXPR)))) (RETURN (LIST RESULT RESULTTYPE)))) % edited: 5-NOV-81 14:31 % Compile a PROGN in the source program. (DE GLDOPROGN (EXPR) (PROG (RES) (SETQ RES (GLPROGN (CDR EXPR) CONTEXT)) (RETURN (LIST (CONS (CAR EXPR) (CAR RES)) (CADR RES))))) % edited: 25-JAN-82 17:34 % Compile a PROG1, whose result is the value of its first argument. (DE GLDOPROG1 (EXPR CONTEXT) (PROG (RESULT TMP TYPE TYPEFLG) (SETQ EXPR (CDR EXPR)) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'PROG1 (REVERSIP RESULT)) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG))) (SETQ RESULT (CONS (CAR TMP) RESULT)) % Get the result type from the first item of the PROG1. (COND ((NOT TYPEFLG) (SETQ TYPE (CADR TMP)) (SETQ TYPEFLG T))) (GO A)) (T (GLERROR 'GLDOPROG1 (LIST "PROG1 contains bad subexpression.")) (pop EXPR) (GO A))))) % edited: 26-MAY-82 15:12 (DE GLDOREPEAT (EXPR) (PROG (ACTIONS TMP LABEL) (pop EXPR) A (COND ((MEMQ (CAR EXPR) '(UNTIL Until until)) (pop EXPR)) ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (RETURN (GLERROR 'GLDOREPEAT (LIST "REPEAT contains bad subexpression."))))) (COND ((OR (NULL EXPR) (NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL))) EXPR) (GLERROR 'GLDOREPEAT (LIST "REPEAT contains no UNTIL or bad UNTIL clause")) (SETQ TMP (LIST T 'BOOLEAN)))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (CONS 'PROG (CONS NIL (CONS LABEL (ACONC ACTIONS (LIST 'COND (LIST (GLBUILDNOT (CAR TMP)) (LIST 'GO LABEL))))))) NIL)))) % edited: 7-Apr-81 11:49 % Compile a RETURN, capturing the type of the result as a type of the % function result. (DE GLDORETURN (EXPR) (PROG (TMP) (pop EXPR) (COND ((NULL EXPR) (GLADDRESULTTYPE NIL) (RETURN '((RETURN) NIL))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (GLADDRESULTTYPE (CADR TMP)) (RETURN (LIST (LIST 'RETURN (CAR TMP)) (CADR TMP))))))) % edited: 26-AUG-82 09:30 % Compile a SELECTQ. Special treatment is necessary in order to quote % the selectors implicitly. (DE GLDOSELECTQ (EXPR CONTEXT) (PROG (RESULT RESULTTYPE TYPEOK KEY TMP TMPB FN) (SETQ FN (CAR EXPR)) (SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)))) (SETQ TYPEOK T) (SETQ EXPR (CDDR EXPR)) % If the selection criterion is constant, do it directly. (COND ((OR (SETQ KEY (NUMBERP (CAR RESULT))) (AND (PAIRP (CAR RESULT)) (EQ (CAAR RESULT) 'QUOTE) (SETQ KEY (CADAR RESULT)))) (SETQ TMP (SOME EXPR (FUNCTION (LAMBDA (X) (COND ((ATOM (CAR X)) (EQUAL KEY (CAR X))) ((PAIRP (CAR X)) (MEMBER KEY (CAR X))) (T NIL)))))) (COND ((OR (NULL TMP) (NULL (CDR TMP))) (SETQ TMPB (GLPROGN (LASTPAIR EXPR) CONTEXT))) (T (SETQ TMPB (GLPROGN (CDAR TMP) CONTEXT)))) (RETURN (LIST (CONS 'PROGN (CAR TMPB)) (CADR TMPB))))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS FN RESULT)) RESULTTYPE)))) (SETQ RESULT (ACONC RESULT (COND ((OR (CDR EXPR) (EQ FN 'CASEQ)) (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (CONS (CAAR EXPR) (CAR TMP))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (CAR TMP))))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 4-JUN-82 15:35 % Compile code for the sending of a message to an object. The syntax % of the message expression is % (_ <object> <selector> <arg1>...<argn>) , where the _ may % optionally be SEND, Send, or send. (DE GLDOSEND (EXPRR) (PROG (EXPR OBJECT SELECTOR ARGS TMP FNNAME) (SETQ FNNAME (CAR EXPRR)) (SETQ EXPR (CDR EXPRR)) (SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (pop EXPR)) (COND ((OR (NULL SELECTOR) (NOT (IDP SELECTOR))) (RETURN (GLERROR 'GLDOSEND (LIST SELECTOR "is an illegal message Selector."))))) % Collect arguments of the message, if any. A (COND ((NULL EXPR) (COND ((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS)) (RETURN TMP)) (T % No message was defined, so just pass it through and hope one will be % defined by runtime. (RETURN (LIST (GLGENCODE (CONS FNNAME (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (CADR OBJECT)))))) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (SETQ ARGS (ACONC ARGS TMP)) (GO A)) (T (GLERROR 'GLDOSEND (LIST "A message argument is bad.")))))) % edited: 7-Apr-81 11:52 % Compile a SETQ expression (DE GLDOSETQ (EXPR) (PROG (VAR) (pop EXPR) (SETQ VAR (pop EXPR)) (RETURN (GLDOVARSETQ VAR (GLDOEXPR NIL CONTEXT T))))) % edited: 20-MAY-82 15:13 % Process a THE expression in a list. (DE GLDOTHE (EXPR) (PROG (RESULT) (SETQ RESULT (GLTHE NIL)) (COND (EXPR (GLERROR 'GLDOTHE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 20-MAY-82 15:16 % Process a THE expression in a list. (DE GLDOTHOSE (EXPR) (PROG (RESULT) (SETQ EXPR (CDR EXPR)) (SETQ RESULT (GLTHE T)) (COND (EXPR (GLERROR 'GLDOTHOSE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 5-MAY-82 15:51 % Compile code to do a SETQ of VAR to the RHS. If the type of VAR is % unknown, it is set to the type of RHS. (DE GLDOVARSETQ (VAR RHS) (PROG NIL (GLUPDATEVARTYPE VAR (CADR RHS)) (RETURN (LIST (LIST 'SETQ VAR (CAR RHS)) (CADR RHS))))) % edited: 4-MAY-82 10:46 (DE GLDOWHILE (EXPR CONTEXT) (PROG (ACTIONS TMP LABEL) (SETQ CONTEXT (CONS NIL CONTEXT)) (pop EXPR) (SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T)))) (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) A (COND ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (GLERROR 'GLDOWHILE (LIST "Bad stuff in While statement:" EXPR)) (pop EXPR) (GO A))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (LIST 'PROG NIL LABEL (LIST 'COND (ACONC ACTIONS (LIST 'GO LABEL)))) NIL)))) % edited: 23-DEC-82 10:47 % Produce code to test the two sides for equality. (DE GLEQUALFN (LHS RHS) (PROG (TMP LHSTP RHSTP) (RETURN (COND ((SETQ TMP (GLDOMSG LHS '= (LIST RHS))) TMP) ((SETQ TMP (GLUSERSTROP LHS '= RHS)) TMP) (T (SETQ LHSTP (CADR LHS)) (SETQ RHSTP (CADR RHS)) (LIST (COND ((NULL (CAR RHS)) (LIST 'NULL (CAR LHS))) ((NULL (CAR LHS)) (LIST 'NULL (CAR RHS))) (T (GLGENCODE (LIST (COND ((OR (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER)) 'EQP) ((OR (GLATOMTYPEP LHSTP) (GLATOMTYPEP RHSTP)) 'EQ) ((AND (EQ LHSTP 'STRING) (EQ RHSTP 'STRING)) 'STREQUAL) (T 'EQUAL)) (CAR LHS) (CAR RHS))))) 'BOOLEAN)))))) % edited: 23-SEP-82 11:52 (DF GLERR (ERREXP) (PRIN1 "Execution of GLISP error expression: ")(PRINT ERREXP)(ERROR 0 NIL)) % GSN 26-JAN-83 13:42 % Look through a structure to see if it involves evaluating other % structures to produce a concrete type. (DE GLEVALSTR (STR CONTEXT) (PROG (GLEVALSUBS) (GLEVALSTRB STR) (RETURN (COND (GLEVALSUBS (GLSUBLIS GLEVALSUBS STR)) (T STR))))) % GSN 30-JAN-83 15:34 % Find places where substructures need to be evaluated and collect % substitutions for them. (DE GLEVALSTRB (STR) (PROG (TMP EXPR) (COND ((ATOM STR) (RETURN NIL)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((EQ (CAR STR) 'TYPEOF) (SETQ EXPR (CDR STR)) (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (COND ((CADR TMP) (SETQ GLEVALSUBS (CONS (CONS STR (CADR TMP)) GLEVALSUBS))) (T (GLERROR 'GLEVALSTRB (LIST "The evaluated type" STR "was not found.") ))) (RETURN NIL)) (T (MAPC (CDR STR) (FUNCTION GLEVALSTRB)))))) % GSN 27-JAN-83 13:56 % If a PROGN occurs within a PROGN, expand it by splicing its contents % into the top-level list. (DE GLEXPANDPROGN (LST BUSY PROGFLG) (PROG (X Y) (SETQ Y LST) LP (SETQ X (CDR Y)) (COND ((NULL X) (RETURN LST)) ((NOT (PAIRP (CAR X))) % Eliminate non-busy atomic items. (COND ((AND (NOT PROGFLG) (OR (CDR X) (NOT BUSY))) (RPLACD Y (CDR X)) (GO LP)))) ((MEMQ (CAAR X) '(PROGN PROG2)) % Expand contained PROGNs in-line. (COND ((CDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDAR X)))) (RPLACA X (CADAR X))) ((AND (EQ (CAAR X) 'PROG) (NULL (CADAR X)) (EVERY (CDDAR X) (FUNCTION (LAMBDA (Y) (NOT (ATOM Y))))) (NOT (GLOCCURS 'RETURN (CDDAR X)))) % Expand contained simple PROGs. (COND ((CDDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDDAR X)))) (RPLACA X (CADDAR X)))) (SETQ Y (CDR Y)) (GO LP))) % edited: 9-JUN-82 12:55 % Test if EXPR is expensive to compute. (DE GLEXPENSIVE? (EXPR) (COND ((ATOM EXPR) NIL) ((NOT (PAIRP EXPR)) (ERROR 0 NIL)) ((MEMQ (CAR EXPR) '(CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR CADDDR)) (GLEXPENSIVE? (CADR EXPR))) ((AND (EQ (CAR EXPR) 'PROG1) (NULL (CDDR EXPR))) (GLEXPENSIVE? (CADR EXPR))) (T T))) % edited: 2-Jan-81 14:26 % Find the first entry for variable VAR in the CONTEXT structure. (DE GLFINDVARINCTX (VAR CONTEXT) (AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT)) (GLFINDVARINCTX VAR (CDR CONTEXT))))) % edited: 19-OCT-82 15:19 % Generate code of the form X. The code generated by the compiler is % transformed, if necessary, for the output dialect. (DE GLGENCODE (X) (GLPSLTRANSFM X)) % edited: 20-Mar-81 15:52 % Get the value for the entry KEY from the a-list ALST. GETASSOC is % used so that the corresponding PUTASSOC can be generated by % GLPUTFN. (DE GLGETASSOC (KEY ALST) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC KEY ALST)) (CDR TMP))))) % edited: 30-AUG-82 10:25 (DE GLGETCONSTDEF (ATM) (COND ((GET ATM 'GLISPCONSTANTFLG) (LIST (MKQUOTE (GET ATM 'GLISPCONSTANTVAL)) (GET ATM 'GLISPCONSTANTTYPE))) (T NIL))) % edited: 30-OCT-81 12:20 % Get the GLISP object description for NAME for the file package. (DE GLGETDEF (NAME TYPE) (LIST 'GLDEFSTRQ (CONS NAME (GET NAME 'GLSTRUCTURE)))) % edited: 5-OCT-82 15:06 % Find a way to retrieve the FIELD from the structure pointed to by % SOURCE (which may be a variable name, NIL, or a list (CODE DESCR)) % relative to CONTEXT. The result is a list of code to get the field % and the structure description of the resulting field. (DE GLGETFIELD (SOURCE FIELD CONTEXT) (PROG (TMP CTXENTRY CTXLIST) (COND ((NULL SOURCE) (GO B)) ((ATOM SOURCE) (COND ((SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT)) (COND ((SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY) NIL)) (RETURN TMP)) (T (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for" SOURCE "whose type is" (CADDR CTXENTRY)))))) ((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT)) (SETQ SOURCE TMP)) ((SETQ TMP (GLGETGLOBALDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) ((SETQ TMP (GLGETCONSTDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The name" SOURCE "cannot be found."))))))) (COND ((PAIRP SOURCE) (COND ((SETQ TMP (GLVALUE (CAR SOURCE) FIELD (CADR SOURCE) NIL)) (RETURN TMP)) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for type" (CADR SOURCE) "in" (CAR SOURCE)))))))) B % No source is specified. Look for a source in the context. (COND ((NULL CONTEXT) (RETURN NIL))) (SETQ CTXLIST (pop CONTEXT)) C (COND ((NULL CTXLIST) (GO B))) (SETQ CTXENTRY (pop CTXLIST)) (COND ((EQ FIELD (CADR CTXENTRY)) (RETURN (LIST (CAR CTXENTRY) (CADDR CTXENTRY)))) ((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY) FIELD (CADDR CTXENTRY) NIL))) (GO C))) (RETURN TMP))) % edited: 27-MAY-82 13:01 % Call the appropriate function to compile code to get the indicator % (QUOTE IND') from the item whose description is DES, where DES % describes a unit in a unit package whose record is UNITREC. (DE GLGETFROMUNIT (UNITREC IND DES) (PROG (TMP) (COND ((SETQ TMP (ASSOC 'GET (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST IND DES)))) (T (RETURN NIL))))) % edited: 23-APR-82 16:58 (DE GLGETGLOBALDEF (ATM) (COND ((GET ATM 'GLISPGLOBALVAR) (LIST ATM (GET ATM 'GLISPGLOBALVARTYPE))) (T NIL))) % edited: 4-JUN-82 15:36 % Get pairs of <field> = <value>, where the = and , are optional. (DE GLGETPAIRS (EXPR) (PROG (PROP VAL PAIRLIST) A (COND ((NULL EXPR) (RETURN PAIRLIST)) ((NOT (ATOM (SETQ PROP (pop EXPR)))) (GLERROR 'GLGETPAIRS (LIST PROP "is not a legal property name."))) ((EQ PROP '!,) (GO A))) (COND ((MEMQ (CAR EXPR) '(= _ :=)) (pop EXPR))) (SETQ VAL (GLDOEXPR NIL CONTEXT T)) (SETQ PAIRLIST (ACONC PAIRLIST (CONS PROP VAL))) (GO A))) % edited: 23-DEC-81 12:52 (DE GLGETSTR (DES) (PROG (TYPE TMP) (RETURN (AND (SETQ TYPE (GLXTRTYPE DES)) (ATOM TYPE) (SETQ TMP (GET TYPE 'GLSTRUCTURE)) (CAR TMP))))) % edited: 28-NOV-82 15:10 % Get the superclasses of CLASS. (DE GLGETSUPERS (CLASS) (LISTGET (CDR (GET CLASS 'GLSTRUCTURE)) 'SUPERS)) % GSN 9-FEB-83 15:28 % Get the type of an expression. (DE GLGETTYPEOF (TYPE) (PROG (TMP) (COND ((SETQ TMP (GLPUSHEXPR (CDR TYPE) NIL CONTEXT T)) (RETURN (CADR TMP)))))) % edited: 21-MAY-82 17:01 % Identify a given name as either a known variable name of as an % implicit field reference. (DE GLIDNAME (NAME DEFAULTFLG) (PROG (TMP) (RETURN (COND ((ATOM NAME) (COND ((NULL NAME) (LIST NIL NIL)) ((IDP NAME) (COND ((EQ NAME T) (LIST NAME 'BOOLEAN)) ((SETQ TMP (GLVARTYPE NAME CONTEXT)) (LIST NAME (COND ((EQ TMP '*NIL*) NIL) (T TMP)))) ((GLGETFIELD NIL NAME CONTEXT)) ((SETQ TMP (GLIDTYPE NAME CONTEXT)) (LIST (CAR TMP) (CADDR TMP))) ((GLGETCONSTDEF NAME)) ((GLGETGLOBALDEF NAME)) (T (COND ((OR (NOT DEFAULTFLG) GLCAUTIOUSFLG) (GLERROR 'GLIDNAME (LIST "The name" NAME "cannot be found in this context.")))) (LIST NAME NIL)))) ((FIXP NAME) (LIST NAME 'INTEGER)) ((FLOATP NAME) (LIST NAME 'REAL)) (T (GLERROR 'GLIDNAME (LIST NAME "is an illegal name."))))) (T NAME))))) % edited: 27-MAY-82 13:02 % Try to identify a name by either its referenced name or its type. (DE GLIDTYPE (NAME CONTEXT) (PROG (CTXLEVELS CTXLEVEL CTXENTRY) (SETQ CTXLEVELS CONTEXT) LPA (COND ((NULL CTXLEVELS) (RETURN NIL))) (SETQ CTXLEVEL (pop CTXLEVELS)) LPB (COND ((NULL CTXLEVEL) (GO LPA))) (SETQ CTXENTRY (CAR CTXLEVEL)) (SETQ CTXLEVEL (CDR CTXLEVEL)) (COND ((OR (EQ (CADR CTXENTRY) NAME) (EQ (CADDR CTXENTRY) NAME) (AND (PAIRP (CADDR CTXENTRY)) (GL-A-AN? (CAADDR CTXENTRY)) (EQ NAME (CADR (CADDR CTXENTRY))))) (RETURN CTXENTRY))) (GO LPB))) % GSN 17-FEB-83 11:52 % Initialize things for GLISP (DE GLINIT NIL (PROG NIL (SETQ GLSEPBITTBL (MAKEBITTABLE '(: _ + - !' = ~ < > * / !, ^))) (SETQ GLUNITPKGS NIL) (SETQ GLSEPMINUS NIL) (SETQ GLQUIETFLG NIL) (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0) (SETQ GLBREAKONERROR NIL) (SETQ GLUSERSTRNAMES NIL) (SETQ GLTYPESUSED NIL) (SETQ GLLASTFNCOMPILED NIL) (SETQ GLLASTSTREDITED NIL) (SETQ GLCAUTIOUSFLG NIL) (MAPC '(EQ NE EQUAL AND OR NOT MEMQ ADD1 SUB1 EQN ASSOC PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ CAR CDR CAAR CADR) (FUNCTION (LAMBDA (X) (PUT X 'GLEVALWHENCONST T)))) (MAPC '(ADD1 SUB1 EQN PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ) (FUNCTION (LAMBDA (X) (PUT X 'GLARGSNUMBERP T)))) (GLDEFFNRESULTTYPES '((NUMBER (PLUS MINUS DIFFERENCE TIMES EXPT QUOTIENT REMAINDER MIN MAX ABS)) (INTEGER (LENGTH FIX ADD1 SUB1)) (REAL (SQRT LOG EXP SIN COS ATAN ARCSIN ARCCOS ARCTAN ARCTAN2 FLOAT)) (BOOLEAN (ATOM NULL EQUAL MINUSP ZEROP GREATERP LESSP NUMBERP FIXP FLOATP STRINGP ARRAYP EQ NOT NULL BOUNDP)))) (GLDEFFNRESULTTYPES '((INTEGER (FLATSIZE FLATSIZE2)) (BOOLEAN (EQN NE PAIRP IDP UNBOUNDP)))) (GLDEFFNRESULTTYPEFNS (APPEND '((CONS . GLLISTRESULTTYPEFN) (LIST . GLLISTRESULTTYPEFN) (NCONC . GLLISTRESULTTYPEFN)) '((PNTH . GLNTHRESULTTYPEFN)))) (GLDEFSYSSTRQ (STRING STRING PROP ((LENGTH NCHARS RESULT INTEGER)) MSG ((+ CONCAT RESULT STRING))) (INTEGER INTEGER SUPERS (NUMBER)) (REAL REAL SUPERS (NUMBER))))) % edited: 26-JUL-82 17:07 % Look up an instance function of an abstract function name which % takes arguments of the specified types. (DE GLINSTANCEFN (FNNAME ARGTYPES) (PROG (INSTANCES IARGS TMP) (OR (SETQ INSTANCES (GET FNNAME 'GLINSTANCEFNS)) (RETURN NIL)) % Get ultimate data types for arguments. LP (COND ((NULL INSTANCES) (RETURN NIL))) (SETQ IARGS (GET (CAAR INSTANCES) 'GLARGUMENTTYPES)) (SETQ TMP ARGTYPES) % Match the ultimate types of each argument. LPB (COND ((NULL IARGS) (RETURN (CAR INSTANCES))) ((EQUAL (GLXTRTYPEB (CAR IARGS)) (GLXTRTYPEB (CAR TMP))) (SETQ IARGS (CDR IARGS)) (SETQ TMP (CDR TMP)) (GO LPB))) (SETQ INSTANCES (CDR INSTANCES)) (GO LP))) % GSN 3-FEB-83 14:13 % Make a new name for an instance of a generic function. (DE GLINSTANCEFNNAME (FN) (PROG (INSTFN N) (SETQ N (ADD1 (OR (GET FN 'GLINSTANCEFNNO) 0))) (PUT FN 'GLINSTANCEFNNO N) (SETQ INSTFN (IMPLODE (NCONC (EXPLODE FN) (CONS '- (EXPLODE N))))) (PUT FN 'GLINSTANCEFNS (CONS INSTFN (GET FN 'GLINSTANCEFNS))) (RETURN INSTFN))) % edited: 30-AUG-82 10:28 % Define compile-time constants. (DF GLISPCONSTANTS (ARGS) (PROG (TMP EXPR EXPRSTACK FAULTFN) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPCONSTANTFLG T) (PUT (CAR ARG) 'GLISPORIGCONSTVAL (CADR ARG)) (PUT (CAR ARG) 'GLISPCONSTANTVAL (PROGN (SETQ EXPR (LIST (CADR ARG))) (SETQ TMP (GLDOEXPR NIL NIL T)) (SET (CAR ARG) (EVAL (CAR TMP))))) (PUT (CAR ARG) 'GLISPCONSTANTTYPE (OR (CADDR ARG) (CADR TMP)))))))) % edited: 26-MAY-82 15:30 % Define compile-time constants. (DF GLISPGLOBALS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPGLOBALVAR T) (PUT (CAR ARG) 'GLISPGLOBALVARTYPE (CADR ARG)))))) % GSN 10-FEB-83 11:51 % edited: 7-Jan-81 10:48 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLISPOBJECTS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % edited: 2-NOV-82 11:24 % Test the word ADJ to see if it is a LISP adjective. If so, return % the name of the function to test it. (DE GLLISPADJ (ADJ) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ADJ) '((ATOMIC . ATOM) (NULL . NULL) (NIL . NULL) (INTEGER . FIXP) (REAL . FLOATP) (BOUND . BOUNDP) (ZERO . ZEROP) (NUMERIC . NUMBERP) (NEGATIVE . MINUSP) (MINUS . MINUSP)))) (CDR TMP))))) % edited: 2-NOV-82 11:23 % Test to see if ISAWORD is a LISP ISA word. If so, return the name of % the function to test for it. (DE GLLISPISA (ISAWORD) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ISAWORD) '((ATOM . ATOM) (LIST . LISTP) (NUMBER . NUMBERP) (INTEGER . FIXP) (SYMBOL . LITATOM) (ARRAY . ARRAYP) (STRING . STRINGP) (BIGNUM . BIGP) (LITATOM . LITATOM)))) (CDR TMP))))) % edited: 12-NOV-82 10:53 % Compute result types for Lisp functions. (DE GLLISTRESULTTYPEFN (FN ARGTYPES) (PROG (ARG1 ARG2) (SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES))) (COND ((CDR ARGTYPES) (SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES))))) (RETURN (CASEQ FN (CONS (OR (AND (PAIRP ARG2) (COND ((EQ (CAR ARG2) 'LIST) (CONS 'LIST (CONS ARG1 (CDR ARG2)))) ((AND (EQ (CAR ARG2) 'LISTOF) (EQUAL ARG1 (CADR ARG2))) ARG2))) (LIST FN ARGTYPES))) (NCONC (COND ((EQUAL ARG1 ARG2) ARG1) ((AND (PAIRP ARG1) (PAIRP ARG2) (EQ (CAR ARG1) 'LISTOF) (EQ (CAR ARG2) 'LIST) (NULL (CDDR ARG2)) (EQUAL (CADR ARG1) (CADR ARG2))) ARG1) (T (OR ARG1 ARG2)))) (LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE)))) (T (ERROR 0 NIL)))))) % GSN 11-JAN-83 14:05 % Create a function call to retrieve the field IND from a LIST % structure. (DE GLLISTSTRFN (IND DES DESLIST) (PROG (TMP N FNLST) (SETQ N 1) (SETQ FNLST '((CAR *GL*) (CADR *GL*) (CADDR *GL*) (CADDDR *GL*))) (COND ((EQ (CAR DES) 'LISTOBJECT) (SETQ N (ADD1 N)) (SETQ FNLST (CDR FNLST)))) C (pop DES) (COND ((NULL DES) (RETURN NIL)) ((NOT (PAIRP (CAR DES)))) ((SETQ TMP (GLSTRFN IND (CAR DES) DESLIST)) (RETURN (GLSTRVAL TMP (COND (FNLST (COPY (CAR FNLST))) (T (LIST 'CAR (GLGENCODE (LIST 'NTH '*GL* N))))))))) (SETQ N (ADD1 N)) (AND FNLST (SETQ FNLST (CDR FNLST))) (GO C))) % edited: 24-AUG-82 17:36 % Compile code for a FOR loop. (DE GLMAKEFORLOOP (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE) (COND ((NULL COLLECTCODE) (LIST (GLGENCODE (LIST 'MAPC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (COND (LOOPCOND (LIST 'COND (CONS (CAR LOOPCOND) LOOPCONTENTS))) ((NULL (CDR LOOPCONTENTS)) (CAR LOOPCONTENTS)) (T (CONS 'PROGN LOOPCONTENTS))))))) NIL)) (T (LIST (COND (LOOPCOND (GLGENCODE (LIST 'MAPCONC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (LIST 'AND (CAR LOOPCOND) (LIST 'CONS (CAR COLLECTCODE) NIL))))))) ((AND (PAIRP (CAR COLLECTCODE)) (ATOM (CAAR COLLECTCODE)) (CDAR COLLECTCODE) (EQ (CADAR COLLECTCODE) LOOPVAR) (NULL (CDDAR COLLECTCODE))) (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (CAAR COLLECTCODE))))) (T (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR COLLECTCODE))))))) (LIST 'LISTOF (CADR COLLECTCODE)))))) % edited: 10-NOV-82 17:14 % Compile code to create a structure in response to a statement % (A <structure> WITH <field> = <value> ...) (DE GLMAKESTR (TYPE EXPR) (PROG (PAIRLIST STRDES) (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR))) (COND ((NULL (SETQ STRDES (GLGETSTR TYPE))) (GLERROR 'GLMAKESTR (LIST "The type name" TYPE "is not defined.")))) (COND ((EQ (CAR STRDES) 'LISTOF) (RETURN (CONS 'LIST (MAPCAR EXPR (FUNCTION (LAMBDA (EXPR) (GLDOEXPR NIL CONTEXT T)))) )))) (SETQ PAIRLIST (GLGETPAIRS EXPR)) (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE)) TYPE)))) % GSN 3-FEB-83 12:12 % Make a virtual type for a view of the original type. (DE GLMAKEVTYPE (ORIGTYPE VLIST) (PROG (SUPER PL PNAME TMP VTYPE) (SETQ SUPER (CADR VLIST)) (SETQ VLIST (CDDR VLIST)) (COND ((MEMQ (CAR VLIST) '(with With WITH)) (SETQ VLIST (CDR VLIST)))) LP (COND ((NULL VLIST) (GO OUT))) (SETQ PNAME (CAR VLIST)) (SETQ VLIST (CDR VLIST)) (COND ((EQ (CAR VLIST) '=) (SETQ VLIST (CDR VLIST)))) (SETQ TMP NIL) LPB (COND ((OR (NULL VLIST) (EQ (CAR VLIST) '!,) (AND (ATOM (CAR VLIST)) (CDR VLIST) (EQ (CADR VLIST) '=))) (SETQ PL (CONS (LIST PNAME (REVERSIP TMP)) PL)) (COND ((AND VLIST (EQ (CAR VLIST) '!,)) (SETQ VLIST (CDR VLIST)))) (GO LP))) (SETQ TMP (CONS (CAR VLIST) TMP)) (SETQ VLIST (CDR VLIST)) (GO LPB) OUT (SETQ VTYPE (GLMKVTYPE)) (PUT VTYPE 'GLSTRUCTURE (LIST (LIST 'TRANSPARENT ORIGTYPE) 'PROP PL 'SUPERS (LIST SUPER))) (RETURN VTYPE))) % GSN 25-FEB-83 16:08 % Test whether an item of type TNEW could be stored into a slot of % type TINTO. (DE GLMATCH (TNEW TINTO) (PROG (TMP RES) (RETURN (COND ((OR (EQ TNEW TINTO) (NULL TINTO) (EQ TINTO 'ANYTHING) (AND (MEMQ TNEW '(INTEGER REAL NUMBER)) (MEMQ TINTO '(NUMBER ATOM))) (AND (EQ TNEW 'ATOM) (PAIRP TINTO) (EQ (CAR TINTO) 'ATOM))) TNEW) ((AND (SETQ TMP (GLXTRTYPEC TNEW)) (SETQ RES (GLMATCH TMP TINTO))) RES) ((AND (SETQ TMP (GLXTRTYPEC TINTO)) (SETQ RES (GLMATCH TNEW TMP))) RES) (T NIL))))) % GSN 25-FEB-83 16:03 % Test whether two types match as an element type and a list type. The % result is the resulting element type. (DE GLMATCHL (TELEM TLIST) (PROG (TMP RES) (RETURN (COND ((AND (PAIRP TLIST) (EQ (CAR TLIST) 'LISTOF) (GLMATCH TELEM (CADR TLIST))) TELEM) ((AND (SETQ TMP (GLXTRTYPEC TLIST)) (SETQ RES (GLMATCHL TELEM TMP)))) (T NIL))))) % edited: 26-MAY-82 15:33 % Construct the NOT of the argument LHS. (DE GLMINUSFN (LHS) (OR (GLDOMSG LHS 'MINUS NIL) (GLUSERSTROP LHS 'MINUS NIL) (LIST (GLGENCODE (COND ((NUMBERP (CAR LHS)) (MINUS (CAR LHS))) ((EQ (GLXTRTYPE (CADR LHS)) 'INTEGER) (LIST 'IMINUS (CAR LHS))) (T (LIST 'MINUS (CAR LHS))))) (CADR LHS)))) % edited: 11-NOV-82 11:54 % Make a variable name for GLCOMP functions. (DE GLMKATOM (NAME) (PROG (N NEWATOM) LP (PUT NAME 'GLISPATOMNUMBER (SETQ N (ADD1 (OR (GET NAME 'GLISPATOMNUMBER) 0)))) (SETQ NEWATOM (IMPLODE (APPEND (EXPLODE NAME) (EXPLODE N)))) % If an atom with this name has something on its proplist, try again. (COND ((PROP NEWATOM) (GO LP)) (T (RETURN NEWATOM))))) % edited: 27-MAY-82 11:02 % Make a variable name for GLCOMP functions. (DE GLMKLABEL NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L L A B E L) (EXPLODE GLNATOM)))))) % edited: 27-MAY-82 11:04 % Make a variable name for GLCOMP functions. (DE GLMKVAR NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L V A R) (EXPLODE GLNATOM)))))) % edited: 18-NOV-82 11:58 % Make a virtual type name for GLCOMP functions. (DE GLMKVTYPE NIL (GLMKATOM 'GLVIRTUALTYPE)) % GSN 25-JAN-83 16:47 % edited: 2-Jun-81 14:18 % Produce a function to implement the _+ operator. Code is produced to % append the right-hand side to the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLNCONCFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS))) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF) (NOT (EQUAL LHSDES (CADR RHS)))) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'NCONC)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_+ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLNCONCFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_+ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ LHS RHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 23-DEC-82 10:49 % Produce code to test the two sides for inequality. (DE GLNEQUALFN (LHS RHS) (PROG (TMP) (COND ((SETQ TMP (GLDOMSG LHS '~= (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '~= RHS)) (RETURN TMP)) ((OR (GLATOMTYPEP (CADR LHS)) (GLATOMTYPEP (CADR RHS))) (RETURN (LIST (GLGENCODE (LIST 'NEQ (CAR LHS) (CAR RHS))) 'BOOLEAN))) (T (RETURN (LIST (GLGENCODE (LIST 'NOT (CAR (GLEQUALFN LHS RHS)))) 'BOOLEAN)))))) % edited: 3-MAY-82 14:35 % Construct the NOT of the argument LHS. (DE GLNOTFN (LHS) (OR (GLDOMSG LHS '~ NIL) (GLUSERSTROP LHS '~ NIL) (LIST (GLBUILDNOT (CAR LHS)) 'BOOLEAN))) % GSN 28-JAN-83 09:39 % Add TYPE to the global variable GLTYPESUSED if not already there. (DE GLNOTICETYPE (TYPE) (COND ((NOT (MEMQ TYPE GLTYPESUSED)) (SETQ GLTYPESUSED (CONS TYPE GLTYPESUSED))))) % edited: 23-JUN-82 14:31 % Compute the result type for the function NTH. (DE GLNTHRESULTTYPEFN (FN ARGTYPES) (PROG (TMP) (RETURN (COND ((AND (PAIRP (SETQ TMP (GLXTRTYPE (CAR ARGTYPES)))) (EQ (CAR TMP) 'LISTOF)) (CAR ARGTYPES)) (T NIL))))) % edited: 3-JUN-82 11:02 % See if X occurs in STR, using EQ. (DE GLOCCURS (X STR) (COND ((EQ X STR) T) ((NOT (PAIRP STR)) NIL) (T (OR (GLOCCURS X (CAR STR)) (GLOCCURS X (CDR STR)))))) % GSN 30-JAN-83 15:35 % Check a structure description for legality. (DE GLOKSTR? (STR) (COND ((NULL STR) NIL) ((ATOM STR) T) ((AND (PAIRP STR) (ATOM (CAR STR))) (CASEQ (CAR STR) ((A AN a an An) (COND ((CDDR STR) NIL) ((OR (GLGETSTR (CADR STR)) (GLUNIT? (CADR STR)) (COND (GLCAUTIOUSFLG (PRIN1 "The structure ") (PRIN1 (CADR STR)) (PRIN1 " is not currently defined. Accepted.") (TERPRI) T) (T T)))))) (CONS (AND (CDR STR) (CDDR STR) (NULL (CDDDR STR)) (GLOKSTR? (CADR STR)) (GLOKSTR? (CADDR STR)))) ((LIST OBJECT ATOMOBJECT LISTOBJECT) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION GLOKSTR?)))) (RECORD (COND ((AND (CDR STR) (ATOM (CADR STR))) (pop STR))) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (LISTOF (AND (CDR STR) (NULL (CDDR STR)) (GLOKSTR? (CADR STR)))) ((ALIST PROPLIST) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (ATOM (GLATMSTR? STR)) (TYPEOF T) (T (COND ((AND (CDR STR) (NULL (CDDR STR))) (GLOKSTR? (CADR STR))) ((ASSOC (CAR STR) GLUSERSTRNAMES)) (T NIL))))) (T NIL))) % edited: 30-DEC-81 16:41 % Get the next operand from the input list, EXPR (global) . The % operand may be an atom (possibly containing operators) or a list. (DE GLOPERAND NIL (PROG NIL (COND ((SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) ((NULL EXPR) (RETURN NIL)) ((STRINGP (CAR EXPR)) (RETURN (LIST (pop EXPR) 'STRING))) ((ATOM (CAR EXPR)) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) (T (RETURN (GLPUSHEXPR (pop EXPR) T CONTEXT T)))))) % edited: 30-OCT-82 14:35 % Test if an atom is a GLISP operator (DE GLOPERATOR? (ATM) (MEMQ ATM '(_ := __ + - * / > < >= <= ^ _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __- _+_))) % edited: 26-DEC-82 15:48 % OR operator (DE GLORFN (LHS RHS) (COND ((AND (PAIRP (CADR LHS)) (EQ (CAADR LHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'UNION (CAR LHS) (CAR RHS)) (CADR LHS))) ((GLDOMSG LHS 'OR (LIST RHS))) ((GLUSERSTROP LHS 'OR RHS)) (T (LIST (LIST 'OR (CAR LHS) (CAR RHS)) (COND ((EQUAL (GLXTRTYPE (CADR LHS)) (GLXTRTYPE (CADR RHS))) (CADR LHS)) (T NIL)))))) % GSN 10-FEB-83 16:13 % Remove unwanted system properties from LST for making an output % file. (DE GLOUTPUTFILTER (PROPTYPE LST) (COND ((MEMQ PROPTYPE '(PROP ADJ ISA MSG)) (MAPCAN LST (FUNCTION (LAMBDA (L) (COND ((LISTGET (CDDR L) 'SPECIALIZATION) NIL) (T (LIST (CONS (CAR L) (CONS (CADR L) (MAPCON (CDDR L) (FUNCTION (LAMBDA (PAIR) (COND ((MEMQ (CAR PAIR) '(VTYPE)) NIL) (T (LIST (CAR PAIR) (CADR PAIR)))))) (FUNCTION CDDR))))))))))) (T LST))) % edited: 22-SEP-82 17:16 % Subroutine of GLDOEXPR to parse a GLISP expression containing field % specifications and/or operators. The global variable EXPR is used, % and is modified to reflect the amount of the expression which has % been parsed. (DE GLPARSEXPR NIL (PROG (OPNDS OPERS FIRST LHSP RHSP) % Get the initial part of the expression, i.e., variable or field % specification. L (SETQ OPNDS (CONS (GLOPERAND) OPNDS)) M (COND ((NULL FIRST) (COND ((OR (NULL EXPR) (NOT (ATOM (CAR EXPR)))) (GO B))) (GLSEPINIT (CAR EXPR)) (COND ((GLOPERATOR? (SETQ FIRST (GLSEPNXT))) (pop EXPR) (GO A)) ((MEMQ FIRST '(IS Is is HAS Has has)) (COND ((AND OPERS (GREATERP (GLPREC (CAR OPERS)) 5)) (GLREDUCE) (SETQ FIRST NIL) (GO M)) (T (SETQ OPNDS (CONS (GLPREDICATE (pop OPNDS) CONTEXT T (AND (NOT (UNBOUNDP 'ADDISATYPE)) ADDISATYPE)) OPNDS)) (SETQ FIRST NIL) (GO M)))) (T (GLSEPCLR) (GO B)))) ((GLOPERATOR? FIRST) (GO A)) (T (GLERROR 'GLPARSEXPR (LIST FIRST "appears illegally or cannot be interpreted.")))) % FIRST now contains an operator A % While top operator < top of stack in precedence, reduce. (COND ((NOT (OR (NULL OPERS) (LESSP (SETQ LHSP (GLPREC (CAR OPERS))) (SETQ RHSP (GLPREC FIRST))) (AND (EQN LHSP RHSP) (MEMQ FIRST '(_ ^ :=))))) (GLREDUCE) (GO A))) % Push new operator onto the operator stack. (SETQ OPERS (CONS FIRST OPERS)) (GO L) B (COND (OPERS (GLREDUCE) (GO B))) (RETURN (CAR OPNDS)))) % edited: 30-DEC-82 10:55 % Parse a field specification of the form var:field:field... Var may % be missing, and there may be zero or more fields. The variable % FIRST is used globally; it contains the first atom of the group on % entry, and the next atom on exit. (DE GLPARSFLD (PREV) (PROG (FIELD TMP) (COND ((NULL PREV) (COND ((EQ FIRST '!') (COND ((SETQ TMP (GLSEPNXT)) (SETQ FIRST (GLSEPNXT)) (RETURN (LIST (MKQUOTE TMP) 'ATOM))) (EXPR (SETQ FIRST NIL) (SETQ TMP (pop EXPR)) (RETURN (LIST (MKQUOTE TMP) (GLCONSTANTTYPE TMP)))) (T (RETURN NIL)))) ((MEMQ FIRST '(THE The the)) (SETQ TMP (GLTHE NIL)) (SETQ FIRST NIL) (RETURN TMP)) ((NE FIRST ':) (SETQ PREV FIRST) (SETQ FIRST (GLSEPNXT)))))) A (COND ((EQ FIRST ':) (COND ((SETQ FIELD (GLSEPNXT)) (SETQ PREV (GLGETFIELD PREV FIELD CONTEXT)) (SETQ FIRST (GLSEPNXT)) (GO A)))) (T (RETURN (COND ((EQ PREV '*NIL*) (LIST NIL NIL)) (T (GLIDNAME PREV T)))))))) % edited: 20-MAY-82 11:30 % Parse a field specification which may be preceded by a ~. (DE GLPARSNFLD NIL (PROG (TMP UOP) (COND ((OR (EQ FIRST '~) (EQ FIRST '-)) (SETQ UOP FIRST) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (ATOM (CAR EXPR))) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (PAIRP (CAR EXPR))) (SETQ TMP (GLPUSHEXPR (pop EXPR) T CONTEXT T))) (T (RETURN (LIST UOP NIL)))) (RETURN (COND ((EQ UOP '~) (GLNOTFN TMP)) (T (GLMINUSFN TMP))))) (T (RETURN (GLPARSFLD NIL)))))) % edited: 27-MAY-82 10:42 % Form the plural of a given word. (DE GLPLURAL (WORD) (PROG (TMP LST UCASE ENDING) (COND ((SETQ TMP (GET WORD 'PLURAL)) (RETURN TMP))) (SETQ LST (REVERSIP (EXPLODE WORD))) (SETQ UCASE (U-CASEP (CAR LST))) (COND ((AND (MEMQ (CAR LST) '(Y y)) (NOT (MEMQ (CADR LST) '(A a E e O o U u)))) (SETQ LST (CDR LST)) (SETQ ENDING (OR (AND UCASE '(S E I)) '(s e i)))) ((MEMQ (CAR LST) '(S s X x)) (SETQ ENDING (OR (AND UCASE '(S E)) '(s e)))) (T (SETQ ENDING (OR (AND UCASE '(S)) '(s))))) (RETURN (IMPLODE (REVERSIP (APPEND ENDING LST)))))) % edited: 29-DEC-82 12:40 % Produce a function to implement the -_ (pop) operator. Code is % produced to remove one element from the right-hand side and assign % it to the left-hand side. (DE GLPOPFN (LHS RHS) (PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR) (SETQ RHSCODE (CAR RHS)) (SETQ RHSDES (GLXTRTYPE (CADR RHS))) (COND ((AND (PAIRP RHSDES) (EQ (CAR RHSDES) 'LISTOF)) (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL))) ((EQ RHSDES 'BOOLEAN) (SETQ POPCODE (GLPUTFN RHS '(NIL NIL) NIL)) (SETQ GETCODE (GLPUTFN LHS RHS NIL))) ((SETQ TMP (GLDOMSG RHS '-_ (LIST LHS))) (RETURN TMP)) ((AND (SETQ STR (GLGETSTR RHSDES)) (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS) STR)))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP RHS '-_ LHS)) (RETURN TMP)) ((OR (GLATOMTYPEP RHSDES) (AND (NE RHSDES 'ANYTHING) (MEMQ (GLXTRTYPEB RHSDES) GLBASICTYPES))) (RETURN NIL)) (T % If all else fails, assume a list. (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL)))) (RETURN (LIST (LIST 'PROG1 (CAR GETCODE) (CAR POPCODE)) (CADR GETCODE))))) % edited: 30-OCT-82 14:36 % Precedence numbers for operators (DE GLPREC (OP) (PROG (TMP) (COND ((SETQ TMP (ASSOC OP '((_ . 1) (:= . 1) (__ . 1) (_+ . 2) (__+ . 2) (+_ . 2) (_+_ . 2) (_- . 2) (__- . 2) (-_ . 2) (= . 5) (~= . 5) (<> . 5) (AND . 4) (And . 4) (and . 4) (OR . 3) (Or . 3) (or . 3) (/ . 7) (+ . 6) (- . 6) (> . 5) (< . 5) (>= . 5) (<= . 5) (^ . 8)))) (RETURN (CDR TMP))) ((EQ OP '*) (RETURN 7)) (T (RETURN 10))))) % GSN 9-FEB-83 17:18 % Get a predicate specification from the EXPR (referenced globally) % and return code to test the SOURCE for that predicate. VERBFLG is % true if a verb is expected as the top of EXPR. (DE GLPREDICATE (SOURCE CONTEXT VERBFLG ADDISATYPE) (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG) (COND ((NULL VERBFLG) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((NULL SOURCE) (GLERROR 'GLPREDICATE (LIST "The object to be tested was not found. EXPR =" EXPR))) ((MEMQ (CAR EXPR) '(HAS Has has)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NO No no)) (SETQ NOTFLG T) (pop EXPR))) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((MEMQ (CAR EXPR) '(IS Is is ARE Are are)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NOT Not not)) (SETQ NOTFLG T) (pop EXPR))) (COND ((GL-A-AN? (CAR EXPR)) (pop EXPR) (SETQ SETNAME (pop EXPR)) % The condition is to test whether SOURCE IS A SETNAME. (COND ((SETQ NEWPRED (GLADJ SOURCE SETNAME 'ISA))) ((SETQ NEWPRED (GLADJ (LIST (CAR SOURCE) SETNAME) SETNAME 'ISASELF)) (COND (ADDISATYPE (COND ((ATOM (CAR SOURCE)) (GLADDSTR (CAR SOURCE) NIL SETNAME CONTEXT)) ((AND (PAIRP (CAR SOURCE)) (MEMQ (CAAR SOURCE) '(SETQ PROG1)) (ATOM (CADAR SOURCE))) (GLADDSTR (CADAR SOURCE) (COND ((SETQ TMP (GLFINDVARINCTX (CAR SOURCE) CONTEXT)) (CADR TMP))) SETNAME CONTEXT)))))) ((GLCLASSP SETNAME) (SETQ NEWPRED (LIST (LIST 'GLCLASSMEMP (CAR SOURCE) (MKQUOTE SETNAME)) 'BOOLEAN))) ((SETQ TMP (GLLISPISA SETNAME)) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "IS A adjective" SETNAME "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS 'A SETNAME) 'BOOLEAN))))) (T (SETQ PROPERTY (CAR EXPR)) % The condition to test is whether SOURCE is PROPERTY. (COND ((SETQ NEWPRED (GLADJ SOURCE PROPERTY 'ADJ)) (pop EXPR)) ((SETQ TMP (GLLISPADJ PROPERTY)) (pop EXPR) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "The adjective" PROPERTY "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (pop EXPR) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS PROPERTY) 'BOOLEAN)))))))) (RETURN (COND (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED)) 'BOOLEAN)) (T NEWPRED))))) % edited: 25-MAY-82 16:09 % Compile an implicit PROGN, that is, a list of items. (DE GLPROGN (EXPR CONTEXT) (PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) A (COND ((NULL EXPR) (RETURN (LIST (REVERSIP RESULT) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY)) (SETQ RESULT (CONS (CAR TMP) RESULT)) (SETQ TYPE (CADR TMP)) (GO A)) (T (GLERROR 'GLPROGN (LIST "Illegal item appears in implicit PROGN. EXPR =" EXPR)))))) % GSN 11-JAN-83 09:59 % Create a function call to retrieve the field IND from a % property-list type structure. FLG is true if a PROPLIST is inside % an ATOM structure. (DE GLPROPSTRFN (IND DES DESLIST FLG) (PROG (DESIND TMP RECNAME N) % Handle a PROPLIST by looking inside each property for IND. (COND ((AND (EQ (SETQ DESIND (pop DES)) 'RECORD) (ATOM (CAR DES))) (SETQ RECNAME (pop DES)))) (SETQ N 0) P (COND ((NULL DES) (RETURN NIL)) ((AND (PAIRP (CAR DES)) (ATOM (CAAR DES)) (CDAR DES) (SETQ TMP (GLSTRFN IND (CAR DES) DESLIST))) (SETQ TMP (GLSTRVAL TMP (CASEQ DESIND (ALIST (LIST 'GLGETASSOC (MKQUOTE (CAAR DES)) '*GL*)) ((RECORD OBJECT) (COND ((EQ DESIND 'OBJECT) (SETQ N (ADD1 N)))) (LIST 'GetV '*GL* N)) ((PROPLIST ATOMOBJECT) (LIST (COND ((OR FLG (EQ DESIND 'ATOMOBJECT)) 'GETPROP) (T 'LISTGET)) '*GL* (MKQUOTE (CAAR DES))))))) (RPLACA TMP (GLGENCODE (CAR TMP))) (RETURN TMP)) (T (pop DES) (SETQ N (ADD1 N)) (GO P))))) % edited: 4-JUN-82 13:37 % Test if the function X is a pure computation, i.e., can be % eliminated if the result is not used. (DE GLPURE (X) (MEMQ X '(CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR CADDDR))) % edited: 25-MAY-82 16:10 % This function serves to call GLDOEXPR with a new expression, % rebinding the global variable EXPR. (DE GLPUSHEXPR (EXPR START CONTEXT VALBUSY) (PROG (GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) (RETURN (GLDOEXPR START CONTEXT VALBUSY)))) % GSN 25-JAN-83 16:48 % edited: 2-Jun-81 14:19 % Produce a function to implement the +_ operator. Code is produced to % push the right-hand side onto the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLPUSHFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE)) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (MEMQ (CAR LHSDES) '(LIST CONS LISTOF))) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'PUSH)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLPUSHFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '+_ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ RHS LHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 22-JAN-83 14:44 % Process a store into a value which is computed by an arithmetic % expression. (DE GLPUTARITH (LHS RHS) (PROG (LHSC OP TMP NEWLHS NEWRHS) (SETQ LHSC (CAR LHS)) (SETQ OP (CAR LHSC)) (COND ((NOT (SETQ TMP (ASSOC OP '((PLUS DIFFERENCE) (MINUS MINUS) (DIFFERENCE PLUS) (TIMES QUOTIENT) (QUOTIENT TIMES) (IPLUS IDIFFERENCE) (IMINUS IMINUS) (IDIFFERENCE IPLUS) (ITIMES IQUOTIENT) (IQUOTIENT ITIMES) (ADD1 SUB1) (SUB1 ADD1) (EXPT SQRT) (SQRT EXPT))))) (RETURN NIL))) (SETQ NEWLHS (CADR LHSC)) (CASEQ OP ((ADD1 SUB1 MINUS IMINUS) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))) ((PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE ITIMES IQUOTIENT) (COND ((NUMBERP (CADDR LHSC)) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADDR LHSC)))) ((NUMBERP (CADR LHSC)) (SETQ NEWLHS (CADDR LHSC)) (CASEQ OP ((DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT) (SETQ NEWRHS (LIST OP (CADR LHSC) (CAR RHS)))) (T (PROGN (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADR LHSC))))))))) (EXPT (COND ((EQUAL (CADDR LHSC) 2) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))))) (SQRT (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) 2)))) (RETURN (AND NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS)) (LIST NEWRHS (CADR RHS)) NIL))))) % GSN 22-JAN-83 14:37 % edited: 2-Jun-81 14:16 % Create code to put the right-hand side datum RHS into the left-hand % side, whose access function and type are given by LHS. (DE GLPUTFN (LHS RHS OPTFLG) (PROG (LHSD LNAME TMP RESULT TMPVAR) (SETQ LHSD (CAR LHS)) (COND ((ATOM LHSD) (RETURN (OR (GLDOMSG LHS '_ (LIST RHS)) (GLUSERSTROP LHS '_ RHS) (AND (NULL (CADR LHS)) (CADR RHS) (GLUSERSTROP (LIST (CAR LHS) (CADR RHS)) '_ RHS)) (GLDOVARSETQ LHSD RHS))))) (SETQ LNAME (CAR LHSD)) (COND ((EQ LNAME 'CAR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (CADR LHSD) (CAR RHS))))))) ((EQ LNAME 'CDR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CDR (LIST 'RPLACD TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CDR (LIST 'RPLACD (CADR LHSD) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((CADR . CDR) (CADDR . CDDR) (CADDDR . CDDDR)))) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (LIST (CDR TMP) (CADR LHSD)))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST (LIST 'CAR TMPVAR) LHSD (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (LIST (CDR TMP) (CADR LHSD)) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((GetV . PutV) (IGetV . IPutV) (GET . PUTPROP) (GETPROP . PUTPROP) (LISTGET . LISTPUT)))) (SETQ RESULT (LIST (CDR TMP) (CADR LHSD) (CADDR LHSD) (CAR RHS)))) ((EQ LNAME 'CXR) (SETQ RESULT (LIST 'CXR (CADR LHSD) (LIST 'RPLACX (CADR LHSD) (CADDR LHSD) (CAR RHS))))) ((EQ LNAME 'GLGETASSOC) (SETQ RESULT (LIST 'PUTASSOC (CADR LHSD) (CAR RHS) (CADDR LHSD)))) ((EQ LNAME 'EVAL) (SETQ RESULT (LIST 'SET (CADR LHSD) (CAR RHS)))) ((EQ LNAME 'fetch) (SETQ RESULT (LIST 'replace (CADR LHSD) 'of (CADDDR LHSD) 'with (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'PUT)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_ RHS)) (RETURN TMP)) ((SETQ TMP (GLPUTARITH LHS RHS)) (RETURN TMP)) (T (RETURN (GLERROR 'GLPUTFN (LIST "Illegal assignment. LHS =" LHS "RHS =" RHS))))) X (RETURN (LIST (GLGENCODE RESULT) (OR (CADR LHS) (CADR RHS)))))) % edited: 27-MAY-82 13:07 % This function appends PUTPROP calls to the list PROGG (global) so % that ATOMNAME has its property list built. (DE GLPUTPROPS (PROPLIS PREVLST) (PROG (TMP TMPCODE) A (COND ((NULL PROPLIS) (RETURN NIL))) (SETQ TMP (pop PROPLIS)) (COND ((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST)) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (MKQUOTE (CAR TMP)) TMPCODE))))) (GO A))) % edited: 26-JAN-82 10:29 % This function implements the __ operator, which is interpreted as % assignment to the source of a variable (usually self) outside an % open-compiled function. Any other use of __ is illegal. (DE GLPUTUPFN (OP LHS RHS) (PROG (TMP TMPOP) (OR (SETQ TMPOP (ASSOC OP '((__ . _) (__+ . _+) (__- . _-) (_+_ . +_)))) (ERROR 0 (LIST (LIST 'GLPUTUPFN OP) " Illegal operator."))) (COND ((AND (ATOM (CAR LHS)) (NOT (UNBOUNDP 'GLPROGLST)) (SETQ TMP (ASSOC (CAR LHS) GLPROGLST))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADR TMP) (CADR LHS)) RHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'PROG1) (ATOM (CADAR LHS))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADAR LHS) (CADR LHS)) RHS))) (T (RETURN (GLERROR 'GLPUTUPFN (LIST "A self-assignment __ operator is used improperly. LHS =" LHS))))))) % edited: 30-OCT-82 14:38 % Reduce the operator on OPERS and the operands on OPNDS % (in GLPARSEXPR) and put the result back on OPNDS (DE GLREDUCE NIL (PROG (RHS OPER) (SETQ RHS (pop OPNDS)) (SETQ OPNDS (CONS (COND ((MEMQ (SETQ OPER (pop OPERS)) '(_ := _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __ _+_ __-)) (GLREDUCEOP OPER (pop OPNDS) RHS)) ((MEMQ OPER '(+ - * / > < >= <= ^)) (GLREDUCEARITH OPER (pop OPNDS) RHS)) ((EQ OPER 'MINUS) (GLMINUSFN RHS)) ((EQ OPER '~) (GLNOTFN RHS)) (T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS)) (CAR RHS))) NIL))) OPNDS)))) % GSN 25-FEB-83 16:32 % edited: 14-Aug-81 12:38 % Reduce an arithmetic operator in an expression. (DE GLREDUCEARITH (OP LHS RHS) (PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP) (SETQ OPLIST '((+ . PLUS) (- . DIFFERENCE) (* . TIMES) (/ . QUOTIENT) (> . GREATERP) (< . LESSP) (>= . GEQ) (<= . LEQ) (^ . EXPT))) (SETQ IOPLIST '((+ . IPLUS) (- . IDIFFERENCE) (* . ITIMES) (/ . IQUOTIENT) (> . IGREATERP) (< . ILESSP) (>= . IGEQ) (<= . ILEQ))) (SETQ PREDLIST '(GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)) (SETQ NUMBERTYPES '(INTEGER REAL NUMBER)) (SETQ LHSTP (GLXTRTYPE (CADR LHS))) (SETQ RHSTP (GLXTRTYPE (CADR RHS))) (COND ((OR (AND (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER) (SETQ TMP (ASSOC OP IOPLIST))) (AND (MEMQ LHSTP NUMBERTYPES) (MEMQ RHSTP NUMBERTYPES) (SETQ TMP (ASSOC OP OPLIST)))) (RETURN (LIST (COND ((AND (NUMBERP (CAR LHS)) (NUMBERP (CAR RHS))) (EVAL (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))))) (T (GLGENCODE (COND ((AND (EQ (CDR TMP) 'IPLUS) (EQN (CAR RHS) 1)) (LIST 'ADD1 (CAR LHS))) ((AND (EQ (CDR TMP) 'IDIFFERENCE) (EQN (CAR RHS) 1)) (LIST 'SUB1 (CAR LHS))) (T (LIST (CDR TMP) (CAR LHS) (CAR RHS))))))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T LHSTP)))))) (COND ((EQ LHSTP 'STRING) (COND ((NE RHSTP 'STRING) (RETURN (GLERROR 'GLREDUCEARITH (LIST "operation on string and non-string")))) ((SETQ TMP (ASSOC OP '((+ CONCAT STRING) (> GLSTRGREATERP BOOLEAN) (>= GLSTRGEP BOOLEAN) (< GLSTRLESSP BOOLEAN) (<= ALPHORDER BOOLEAN)))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADDR TMP)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for strings."))))) ) ((EQ LHSTP 'BOOLEAN) (COND ((NE RHSTP 'BOOLEAN) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operation on Boolean and non-Boolean")))) ((MEMQ OP '(+ * -)) (RETURN (LIST (GLGENCODE (CASEQ OP (+ (LIST 'OR (CAR LHS) (CAR RHS))) (* (LIST 'AND (CAR LHS) (CAR RHS))) (- (LIST 'AND (CAR LHS) (LIST 'NOT (CAR RHS)))))) 'BOOLEAN))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for Booleans."))))) ) ((AND (PAIRP LHSTP) (EQ (CAR LHSTP) 'LISTOF)) (COND ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF)) (COND ((NOT (EQUAL (CADR LHSTP) (CADR RHSTP))) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operations on lists of different types" (CADR LHSTP) (CADR RHSTP)))))) (COND ((SETQ TMP (ASSOC OP '((+ UNION) (- LDIFFERENCE) (* INTERSECTION) ))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation" OP "on lists.")))))) ((AND (GLMATCH RHSTP (CADR LHSTP)) (MEMQ OP '(+ - >=))) (RETURN (LIST (GLGENCODE (LIST (COND ((EQ OP '+) 'CONS) ((EQ OP '-) 'REMOVE) ((EQ OP '>=) (COND ((GLATOMTYPEP RHSTP) 'MEMB) (T 'MEMBER)))) (CAR RHS) (CAR LHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation on list.")))))) ((AND (MEMQ OP '(+ <=)) (GLMATCHL LHSTP RHSTP)) (RETURN (COND ((EQ OP '+) (LIST (GLGENCODE (LIST 'CONS (CAR LHS) (CAR RHS))) (CADR RHS))) ((EQ OP '<=) (LIST (GLGENCODE (LIST (COND ((GLATOMTYPEP LHSTP) 'MEMB) (T 'MEMBER)) (CAR LHS) (CAR RHS))) 'BOOLEAN))))) ((AND (MEMQ OP '(+ - >=)) (SETQ TMP (GLMATCHL LHSTP RHSTP))) (RETURN (GLREDUCEARITH (LIST (CAR LHS) (LIST 'LISTOF TMP)) OP (LIST (CAR RHS) TMP)))) ((SETQ TMP (GLDOMSG LHS OP (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS OP RHS)) (RETURN TMP)) ((SETQ TMP (GLXTRTYPEC LHSTP)) (SETQ TMP (GLREDUCEARITH OP (LIST (CAR LHS) TMP) (LIST (CAR RHS) (OR (GLXTRTYPEC RHSTP) RHSTP)))) (RETURN (LIST (CAR TMP) LHSTP))) ((SETQ TMP (ASSOC OP OPLIST)) (AND LHSTP RHSTP (GLERROR 'GLREDUCEARITH (LIST "Warning: Arithmetic operation on non-numeric arguments of types:" LHSTP RHSTP))) (RETURN (LIST (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T 'NUMBER))))) (T (ERROR 0 (LIST 'GLREDUCEARITH OP LHS RHS)))))) % edited: 29-DEC-82 12:20 % Reduce the operator OP with operands LHS and RHS. (DE GLREDUCEOP (OP LHS RHS) (PROG (TMP RESULT) (COND ((MEMQ OP '(_ :=)) (RETURN (GLPUTFN LHS RHS NIL))) ((SETQ TMP (ASSOC OP '((_+ . GLNCONCFN) (+_ . GLPUSHFN) (_- . GLREMOVEFN) (-_ . GLPOPFN) (= . GLEQUALFN) (~= . GLNEQUALFN) (<> . GLNEQUALFN) (AND . GLANDFN) (And . GLANDFN) (and . GLANDFN) (OR . GLORFN) (Or . GLORFN) (or . GLORFN)))) (COND ((SETQ RESULT (APPLY (CDR TMP) (LIST LHS RHS))) (RETURN RESULT)) (T (GLERROR 'GLREDUCEOP (LIST "The operator" OP "could not be interpreted for arguments" LHS "and" RHS))))) ((MEMQ OP '(__ __+ __- _+_)) (RETURN (GLPUTUPFN OP LHS RHS))) (T (ERROR 0 (LIST 'GLREDUCEOP OP LHS RHS)))))) % GSN 25-JAN-83 16:50 % edited: 2-Jun-81 14:20 % Produce a function to implement the _- operator. Code is produced to % remove the right-hand side from the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLREMOVEFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'SUB1 LHSCODE))) (T (SETQ NCCODE (LIST 'IDIFFERENCE LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'DIFFERENCE LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'AND LHSCODE (LIST 'NOT (CAR RHS))))) ((OR (NULL LHSDES) (AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF))) (SETQ NCCODE (LIST 'REMOVE (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'REMOVE)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_- (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '- (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLREMOVEFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_- RHS)) (RETURN TMP)) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 26-JAN-83 13:41 % Get GLOBAL and RESULT declarations for the GLISP compiler. The % property GLRESULTTYPE is the RESULT declaration, if specified; % GLGLOBALS is a list of global variables referenced and their % types. (DE GLRESGLOBAL NIL (COND ((PAIRP (CAR GLEXPR)) (COND ((MEMQ (CAAR GLEXPR) '(RESULT Result result)) (COND ((AND (GLOKSTR? (CADAR GLEXPR)) (NULL (CDDAR GLEXPR))) (PUT GLAMBDAFN 'GLRESULTTYPE (SETQ RESULTTYPE (GLSUBSTTYPE (GLEVALSTR (CADAR GLEXPR) GLTOPCTX) GLTYPESUBS))) (pop GLEXPR)) (T (GLERROR 'GLCOMP (LIST "Bad RESULT structure declaration:" (CAR GLEXPR))) (pop GLEXPR)))) ((MEMQ (CAAR GLEXPR) '(GLOBAL Global global)) (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR) '(NIL NIL) GLTOPCTX NIL NIL)) (PUT GLAMBDAFN 'GLGLOBALS GLGLOBALVARS) (pop GLEXPR)))))) % edited: 26-MAY-82 16:14 % Get the result type for a function which has a GLAMBDA definition. % ATM is the function name. (DE GLRESULTTYPE (ATM ARGTYPES) (PROG (TYPE FNDEF STR TMP) % See if this function has a known result type. (COND ((SETQ TYPE (GET ATM 'GLRESULTTYPE)) (RETURN TYPE))) % If there exists a function to compute the result type, let it do so. (COND ((SETQ TMP (GET ATM 'GLRESULTTYPEFN)) (RETURN (APPLY TMP (LIST ATM ARGTYPES)))) ((SETQ TMP (GLANYCARCDR? ATM)) (RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES))))) (SETQ FNDEF (GLGETDB ATM)) (COND ((OR (NOT (PAIRP FNDEF)) (NOT (MEMQ (CAR FNDEF) '(LAMBDA GLAMBDA)))) (RETURN NIL))) (SETQ FNDEF (CDDR FNDEF)) A (COND ((OR (NULL FNDEF) (NOT (PAIRP (CAR FNDEF)))) (RETURN NIL)) ((OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR FNDEF) '*)) (MEMQ (CAAR FNDEF) '(GLOBAL Global global))) (pop FNDEF) (GO A)) ((AND (MEMQ (CAAR FNDEF) '(RESULT Result result)) (GLOKSTR? (SETQ STR (CADAR FNDEF)))) (RETURN STR)) (T (RETURN NIL))))) % GSN 28-JAN-83 09:55 (DE GLSAVEFNTYPES (GLAMBDAFN TYPELST) (PROG (Y) (MAPC TYPELST (FUNCTION (LAMBDA (X) (COND ((NOT (MEMQ GLAMBDAFN (SETQ Y (GET X 'GLFNSUSEDIN)))) (PUT X 'GLFNSUSEDIN (CONS GLAMBDAFN Y))))))))) % GSN 16-FEB-83 11:30 % Send a runtime message to OBJ. (DE GLSENDB (OBJ CLASS SELECTOR PROPTYPE ARGS) (PROG (RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL) (COND (CLASS) ((SETQ CLASS (GLCLASS OBJ))) (T (ERROR 0 (LIST "Object" OBJ "has no Class.")))) (SETQ ARGLIST (CONS OBJ ARGS)) (COND ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST PROPTYPE)) 'GLSENDFAILURE) (RETURN RESULT)) ((AND (EQ SELECTOR 'CLASS) (MEMQ PROPTYPE '(PROP MSG))) (RETURN CLASS)) ((NE PROPTYPE 'MSG) (GO ERR)) ((AND ARGS (NULL (CDR ARGS)) (EQ (GLNTHCHAR SELECTOR -1) ':) (SETQ SEL (SUBATOM SELECTOR 1 -2)) (SETQ FNCODE (OR (GLCOMPPROP CLASS SEL 'STR) (GLCOMPPROP CLASS SEL 'PROP))) (SETQ PUTCODE (GLPUTFN (LIST (SUBST '*GL* (CAADR FNCODE) (CADDR FNCODE)) NIL) (LIST '*GLVAL* NIL) NIL))) (SETQ *GLVAL* (CAR ARGS)) (SETQ *GL* OBJ) (RETURN (EVAL (CAR PUTCODE)))) (ARGS (GO ERR)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'STR)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'PROP)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ADJ)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ISA)) 'GLSENDFAILURE) (RETURN RESULT))) ERR (ERROR 0 (LIST "Message" SELECTOR "to object" OBJ "of class" CLASS "not understood.")))) % edited: 30-DEC-81 16:34 (DE GLSEPCLR NIL (SETQ GLSEPPTR 0)) % GSN 9-FEB-83 17:24 % edited: 30-Dec-80 10:05 % Initialize the scanning function which breaks apart atoms containing % embedded operators. (DE GLSEPINIT (ATM) (COND ((AND (ATOM ATM) (NOT (STRINGP ATM))) (SETQ GLSEPATOM ATM) (SETQ GLSEPPTR 1)) (T (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0)))) % edited: 30-OCT-82 14:40 % Get the next sub-atom from the atom which was previously given to % GLSEPINIT. Sub-atoms are defined by splitting the given atom at % the occurrence of operators. Operators which are defined are : _ % _+ __ +_ _- -_ ' = ~= <> > < (DE GLSEPNXT NIL (PROG (END TMP) (COND ((ZEROP GLSEPPTR) (RETURN NIL)) ((NULL GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN '*NIL*)) ((NUMBERP GLSEPATOM) (SETQ TMP GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN TMP))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR)) A (COND ((NULL END) (RETURN (PROG1 (COND ((EQN GLSEPPTR 1) GLSEPATOM) ((GREATERP GLSEPPTR (FlatSize2 GLSEPATOM)) NIL) (T (GLSUBATOM GLSEPATOM GLSEPPTR (FlatSize2 GLSEPATOM)))) (SETQ GLSEPPTR 0)))) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (PLUS GLSEPPTR 2))) '(__+ __- _+_)) (SETQ GLSEPPTR (PLUS GLSEPPTR 3)) (RETURN TMP)) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (ADD1 GLSEPPTR))) '(:= __ _+ +_ _- -_ ~= <> >= <=)) (SETQ GLSEPPTR (PLUS GLSEPPTR 2)) (RETURN TMP)) ((AND (NOT GLSEPMINUS) (EQ (GLNTHCHAR GLSEPATOM END) '-) (NOT (EQ (GLNTHCHAR GLSEPATOM (ADD1 END)) '_))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END))) (GO A)) ((GREATERP END GLSEPPTR) (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR (SUB1 END)) (SETQ GLSEPPTR END)))) (T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR) (SETQ GLSEPPTR (ADD1 GLSEPPTR)))))))) % edited: 26-MAY-82 16:17 % Skip comments in GLEXPR. (DE GLSKIPCOMMENTS NIL (PROG NIL A (COND ((AND (PAIRP GLEXPR) (PAIRP (CAR GLEXPR)) (OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR GLEXPR) '*)) (EQ (CAAR GLEXPR) 'COMMENT))) (pop GLEXPR) (GO A))))) % GSN 17-FEB-83 12:36 % This function is called when the structure STR has been changed. It % uncompiles code which depends on STR. (DE GLSTRCHANGED (STR) (PROG (FNS) (COND ((NOT (GET STR 'GLSTRUCTURE)) (RETURN NIL)) ((GET STR 'GLPROPFNS) (PUT STR 'GLPROPFNS NIL))) (SETQ FNS (GET STR 'GLFNSUSEDIN)) (PUT STR 'GLFNSUSEDIN NIL) (MAPC FNS (FUNCTION GLUNCOMPILE)))) % GSN 28-JAN-83 10:19 % Create a function call to retrieve the field IND from a structure % described by the structure description DES. The value is NIL if % failure, (NIL DESCR) if DES equals IND, or (FNSTR DESCR) if IND % can be gotten from within DES. In the latter case, FNSTR is a % function to get the IND from the atom *GL*. GLSTRFN only does % retrieval from a structure, and does not get properties of an % object unless they are part of a TRANSPARENT substructure. DESLIST % is a list of structure descriptions which have been tried already; % this prevents a compiler loop in case the user specifies circular % TRANSPARENT structures. (DE GLSTRFN (IND DES DESLIST) (PROG (DESIND TMP STR UNITREC) % If this structure has already been tried, quit to avoid a loop. (COND ((MEMQ DES DESLIST) (RETURN NIL))) (SETQ DESLIST (CONS DES DESLIST)) (COND ((OR (NULL DES) (NULL IND)) (RETURN NIL)) ((OR (ATOM DES) (AND (PAIRP DES) (ATOM (CADR DES)) (GL-A-AN? (CAR DES)) (SETQ DES (CADR DES)))) (RETURN (COND ((SETQ STR (GLGETSTR DES)) (GLNOTICETYPE DES) (GLSTRFN IND STR DESLIST)) ((SETQ UNITREC (GLUNIT? DES)) (GLGETFROMUNIT UNITREC IND DES)) ((EQ IND DES) (LIST NIL (CADR DES))) (T NIL)))) ((NOT (PAIRP DES)) (GLERROR 'GLSTRFN (LIST "Bad structure specification" DES)))) (SETQ DESIND (CAR DES)) (COND ((OR (EQ IND DES) (EQ DESIND IND)) (RETURN (LIST NIL (CADR DES))))) (RETURN (CASEQ DESIND (CONS (OR (GLSTRVALB IND (CADR DES) '(CAR *GL*)) (GLSTRVALB IND (CADDR DES) '(CDR *GL*)))) ((LIST LISTOBJECT) (GLLISTSTRFN IND DES DESLIST)) ((PROPLIST ALIST RECORD ATOMOBJECT OBJECT) (GLPROPSTRFN IND DES DESLIST NIL)) (ATOM (GLATOMSTRFN IND DES DESLIST)) (TRANSPARENT (GLSTRFN IND (CADR DES) DESLIST)) (T (COND ((AND (SETQ TMP (ASSOC DESIND GLUSERSTRNAMES)) (CADR TMP)) (APPLY (CADR TMP) (LIST IND DES DESLIST))) ((OR (NULL (CDR DES)) (ATOM (CADR DES)) (AND (PAIRP (CADR DES)) (GL-A-AN? (CAADR DES)))) NIL) (T (GLSTRFN IND (CADR DES) DESLIST)))))))) % GSN 10-FEB-83 13:03 % If STR is a structured object, i.e., either a declared GLISP % structure or a Class of Units, get the property PROP from the % GLISP class of properties GLPROP. (DE GLSTRPROP (STR GLPROP PROP ARGS) (PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS) (OR (SETQ STRB (GLXTRTYPE STR)) (RETURN NIL)) (COND ((SETQ GLPROPS (GET STRB 'GLSTRUCTURE)) (GLNOTICETYPE STRB) (COND ((AND (SETQ PROPL (LISTGET (CDR GLPROPS) GLPROP)) (SETQ TMP (GLSTRPROPB PROP PROPL ARGS))) (RETURN TMP))))) (SETQ SUPERS (AND GLPROPS (LISTGET (CDR GLPROPS) 'SUPERS))) LP (COND (SUPERS (COND ((SETQ TMP (GLSTRPROP (CAR SUPERS) GLPROP PROP ARGS)) (RETURN TMP)) (T (SETQ SUPERS (CDR SUPERS)) (GO LP)))) ((AND (SETQ UNITREC (GLUNIT? STRB)) (SETQ TMP (APPLY (CADDDR UNITREC) (LIST STRB GLPROP PROP)))) (RETURN TMP))))) % GSN 10-FEB-83 13:14 % See if the property PROP can be found within the list of properties % PROPL. If ARGS is specified and ARGTYPES are specified for a % property entry, ARGS are required to match ARGTYPES. (DE GLSTRPROPB (PROP PROPL ARGS) (PROG (PROPENT ARGTYPES LARGS) LP (COND ((NULL PROPL) (RETURN NIL))) (SETQ PROPENT (CAR PROPL)) (SETQ PROPL (CDR PROPL)) (COND ((NE (CAR PROPENT) PROP) (GO LP))) (OR (AND ARGS (SETQ ARGTYPES (LISTGET (CDDR PROPENT) 'ARGTYPES))) (RETURN PROPENT)) (SETQ LARGS ARGS) LPB (COND ((AND (NULL LARGS) (NULL ARGTYPES)) (RETURN PROPENT)) ((OR (NULL LARGS) (NULL ARGTYPES)) (GO LP)) ((GLTYPEMATCH (CADAR LARGS) (CAR ARGTYPES)) (SETQ LARGS (CDR LARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LPB)) (T (GO LP))))) % edited: 11-JAN-82 14:58 % GLSTRVAL is a subroutine of GLSTRFN. Given an old partial retrieval % function, in which the item from which the retrieval is made is % specified by *GL*, and a new function to compute *GL*, a composite % function is made. (DE GLSTRVAL (OLDFN NEW) (PROG NIL (COND ((CAR OLDFN) (RPLACA OLDFN (SUBST NEW '*GL* (CAR OLDFN)))) (T (RPLACA OLDFN NEW))) (RETURN OLDFN))) % edited: 13-Aug-81 16:13 % If the indicator IND can be found within the description DES, make a % composite retrieval function using a copy of the function pattern % NEW. (DE GLSTRVALB (IND DES NEW) (PROG (TMP) (COND ((SETQ TMP (GLSTRFN IND DES DESLIST)) (RETURN (GLSTRVAL TMP (COPY NEW)))) (T (RETURN NIL))))) % edited: 30-DEC-81 16:35 (DE GLSUBATOM (X Y Z) (OR (SUBATOM X Y Z) '*NIL*)) % GSN 22-JAN-83 16:27 % Same as SUBLIS, but allows first elements in PAIRS to be non-atomic. (DE GLSUBLIS (PAIRS EXPR) (PROG (TMP) (RETURN (COND ((SETQ TMP (ASSOC EXPR PAIRS)) (CDR TMP)) ((NOT (PAIRP EXPR)) EXPR) (T (CONS (GLSUBLIS PAIRS (CAR EXPR)) (GLSUBLIS PAIRS (CDR EXPR)))))))) % edited: 30-AUG-82 10:29 % Make subtype substitutions within TYPE according to GLTYPESUBS. (DE GLSUBSTTYPE (TYPE SUBS) (SUBLIS SUBS TYPE)) % edited: 11-NOV-82 14:02 % Get the list of superclasses for CLASS. (DE GLSUPERS (CLASS) (PROG (TMP) (RETURN (AND (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (LISTGET (CDR TMP) 'SUPERS))))) % GSN 16-FEB-83 11:56 % edited: 17-Apr-81 14:23 % EXPR begins with THE. Parse the expression and return code. (DE GLTHE (PLURALFLG) (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND TMP) % Now trace the path specification. (GLTHESPECS) (SETQ QUALFLG (AND EXPR (MEMQ (CAR EXPR) '(with With WITH who Who WHO which Which WHICH that That THAT))) ) B (COND ((NULL SPECS) (COND ((MEMQ (CAR EXPR) '(IS Is is HAS Has has ARE Are are)) (RETURN (GLPREDICATE SOURCE CONTEXT T NIL))) (QUALFLG (GO C)) (T (RETURN SOURCE)))) ((AND QUALFLG (NOT PLURALFLG) (NULL (CDR SPECS))) % If this is a definite reference to a qualified entity, make the name % of the entity plural. (SETQ NAME (CAR SPECS)) (RPLACA SPECS (GLPLURAL (CAR SPECS))))) % Try to find the next name on the list of SPECS from SOURCE. (COND ((NULL SOURCE) (OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS)) NIL)) (RETURN (GLERROR 'GLTHE (LIST "The definite reference to" NAME "could not be found."))))) (SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS) CONTEXT)))) (GO B) C (COND ((ATOM (SETQ DTYPE (GLXTRTYPE (CADR SOURCE)))) (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE))))) (COND ((OR (NOT (PAIRP DTYPE)) (NE (CAR DTYPE) 'LISTOF)) (GLERROR 'GLTHE (LIST "The group name" NAME "has type" DTYPE "which is not a legal group type.")))) (SETQ NEWCONTEXT (CONS NIL CONTEXT)) (GLADDSTR (SETQ LOOPVAR (GLMKVAR)) NAME (CADR DTYPE) NEWCONTEXT) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT (MEMQ (pop EXPR) '(who Who WHO which Which WHICH that That THAT)) NIL)) (SETQ TMP (GLGENCODE (LIST (COND (PLURALFLG 'SUBSET) (T 'SOME)) (CAR SOURCE) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR LOOPCOND)))))) (RETURN (COND (PLURALFLG (LIST TMP (CADR SOURCE))) (T (LIST (LIST 'CAR TMP) (CADR DTYPE))))))) % edited: 20-MAY-82 17:19 % EXPR begins with THE. Parse the expression and return code in SOURCE % and path names in SPECS. (DE GLTHESPECS NIL (PROG NIL A (COND ((NULL EXPR) (RETURN NIL)) ((MEMQ (CAR EXPR) '(THE The the)) (pop EXPR) (COND ((NULL EXPR) (RETURN (GLERROR 'GLTHE (LIST "Nothing following THE"))))))) (COND ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (GLSEPNXT) (CAR EXPR)) (SETQ SPECS (CONS (pop EXPR) SPECS))) (T (GLSEPCLR) (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL)))) (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL))) % SPECS contains a path specification. See if there is any more. (COND ((MEMQ (CAR EXPR) '(OF Of of)) (pop EXPR) (GO A))))) % edited: 14-DEC-81 10:51 % Return a list of all transparent types defined for STR (DE GLTRANSPARENTTYPES (STR) (PROG (TTLIST) (COND ((ATOM STR) (SETQ STR (GLGETSTR STR)))) (GLTRANSPB STR) (RETURN (REVERSIP TTLIST)))) % edited: 13-NOV-81 15:37 % Look for TRANSPARENT substructures for GLTRANSPARENTTYPES. (DE GLTRANSPB (STR) (COND ((NOT (PAIRP STR))) ((EQ (CAR STR) 'TRANSPARENT) (SETQ TTLIST (CONS STR TTLIST))) ((MEMQ (CAR STR) '(LISTOF ALIST PROPLIST))) (T (MAPC (CDR STR) (FUNCTION GLTRANSPB))))) % edited: 4-JUN-82 11:18 % Translate places where a PROG variable is initialized to a value as % allowed by Interlisp. This is done by adding a SETQ to set the % value of each PROG variable which is initialized. In some cases, a % change of variable name is required to preserve the same % semantics. (DE GLTRANSPROG (X) (PROG (TMP ARGVALS SETVARS) (MAP (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP (CAR Y)) % If possible, use the same variable; otherwise, make a new one. (SETQ TMP (COND ((OR (SOME (CADR X) (FUNCTION (LAMBDA (Z) (AND (PAIRP Z) (GLOCCURS (CAR Z) (CADAR Y)))))) (SOME ARGVALS (FUNCTION (LAMBDA (Z) (GLOCCURS (CAAR Y) Z))))) (GLMKVAR)) (T (CAAR Y)))) (SETQ SETVARS (ACONC SETVARS (LIST 'SETQ TMP (CADAR Y)))) (SUBSTIP TMP (CAAR Y) (CDDR X)) (SETQ ARGVALS (CONS (CADAR Y) ARGVALS)) (RPLACA Y TMP)))))) (COND (SETVARS (RPLACD (CDR X) (NCONC SETVARS (CDDR X))))) (RETURN X))) % GSN 10-FEB-83 13:31 % See if the type SUBTYPE matches the type TYPE, either directly or % because TYPE is a SUPER of SUBTYPE. (DE GLTYPEMATCH (SUBTYPE TYPE) (PROG NIL (SETQ SUBTYPE (GLXTRTYPE SUBTYPE)) (RETURN (OR (NULL SUBTYPE) (NULL TYPE) (EQ TYPE 'ANYTHING) (EQUAL SUBTYPE TYPE) (SOME (GLSUPERS SUBTYPE) (FUNCTION (LAMBDA (Y) (GLTYPEMATCH Y TYPE)))))))) % GSN 3-FEB-83 14:41 % Remove the GLISP-compiled definition and properties of GLAMBDAFN (DE GLUNCOMPILE (GLAMBDAFN) (PROG (SPECS SPECLST STR LST TMP) (OR (GET GLAMBDAFN 'GLCOMPILED) (SETQ SPECS (GET GLAMBDAFN 'GLSPECIALIZATION)) (RETURN NIL)) (COND ((NOT GLQUIETFLG) (PRIN1 "uncompiling ") (PRIN1 GLAMBDAFN) (TERPRI))) (PUT GLAMBDAFN 'GLCOMPILED NIL) (PUT GLAMBDAFN 'GLRESULTTYPE NIL) (GLUNSAVEDEF GLAMBDAFN) (MAPC (GET GLAMBDAFN 'GLTYPESUSED) (FUNCTION (LAMBDA (Y) (PUT Y 'GLFNSUSEDIN (DELETIP GLAMBDAFN (GET Y 'GLFNSUSEDIN)))))) (PUT GLAMBDAFN 'GLTYPESUSED NIL) (OR SPECS (RETURN NIL)) % Uncompile a specialization of a generic function. % Remove the function definition so it will be garbage collected. (PUTDDD GLAMBDAFN NIL) A (COND ((NULL SPECS) (RETURN NIL))) (SETQ SPECLST (pop SPECS)) (PUT (CAR SPECLST) 'GLINSTANCEFNS (DELETIP GLAMBDAFN (GET (CAR SPECLST) 'GLINSTANCEFNS))) % Remove the specialization entry in the datatype where it was % created. (OR (SETQ STR (GET (CADR SPECLST) 'GLSTRUCTURE)) (GO A)) (SETQ LST (CDR STR)) LP (COND ((NULL LST) (GO A)) ((EQ (CAR LST) (CADDR SPECLST)) (COND ((AND (SETQ TMP (ASSOC (CADDDR SPECLST) (CADR LST))) (EQ (CADR TMP) GLAMBDAFN)) (RPLACA (CDR LST) (DELETIP TMP (CADR LST))))) (GO A)) (T (SETQ LST (CDDR LST)) (GO LP))))) % edited: 27-MAY-82 13:08 % GLUNITOP calls a function to generate code for an operation on a % unit in a units package. UNITREC is the unit record for the units % package, LHS and RHS the code for the left-hand side and % right-hand side of the operation % (in general, the (QUOTE GET') code for each side) , and OP is the % operation to be performed. (DE GLUNITOP (LHS RHS OP) (PROG (TMP LST UNITREC) % (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (RETURN NIL)) ((NOT (MEMQ (CAAR LHS) (CADAR LST))) (SETQ LST (CDR LST)) (GO A))) (SETQ UNITREC (CAR LST)) (COND ((SETQ TMP (ASSOC OP (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST LHS RHS))))) (RETURN NIL))) % edited: 27-MAY-82 13:08 % GLUNIT? tests a given structure to see if it is a unit of one of the % unit packages on GLUNITPKGS. If so, the value is the unit package % record for the unit package which matched. (DE GLUNIT? (STR) (PROG (UPS) (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (RETURN NIL)) ((APPLY (CAAR UPS) (LIST STR)) (RETURN (CAR UPS)))) (SETQ UPS (CDR UPS)) (GO LP))) % GSN 28-JAN-83 11:15 % Remove the GLISP-compiled definition of GLAMBDAFN (DE GLUNSAVEDEF (GLAMBDAFN) (GLPUTHOOK GLAMBDAFN)) % GSN 27-JAN-83 13:58 % Unwrap an expression X by removing extra stuff inserted during % compilation. (DE GLUNWRAP (X BUSY) (COND ((NOT (PAIRP X)) X) ((NOT (ATOM (CAR X))) (ERROR 0 (LIST 'GLUNWRAP X))) ((CASEQ (CAR X) ('GO X) ((PROG2 PROGN) (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN X BUSY NIL) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (PROG1 (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (EQ Y (CDR X)))))))) (COND (BUSY (GLEXPANDPROGN (CDR X) BUSY NIL)) (T (RPLACA X 'PROGN) (GLEXPANDPROGN X BUSY NIL))) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (FUNCTION (RPLACA (CDR X) (GLUNWRAP (CADR X) BUSY)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) X) ((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY) (GLUNWRAPMAP X BUSY)) (LAMBDA (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CDR X) BUSY NIL) X) (PROG (GLUNWRAPPROG X BUSY)) (COND (GLUNWRAPCOND X BUSY)) ((SELECTQ CASEQ) (GLUNWRAPSELECTQ X BUSY)) ((UNION INTERSECTION LDIFFERENCE) (GLUNWRAPINTERSECT X)) (T (COND ((AND (EQ (CAR X) '*) (EQ GLLISPDIALECT 'INTERLISP)) X) ((AND (NOT BUSY) (CDR X) (NULL (CDDR X)) (GLPURE (CAR X))) (GLUNWRAP (CADR X) NIL)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (COND ((AND (CDR X) (NULL (CDDR X)) (PAIRP (CADR X)) (GLCARCDR? (CAR X)) (GLCARCDR? (CAADR X)) (LESSP (PLUS (FlatSize2 (CAR X)) (FlatSize2 (CAADR X))) 9)) (RPLACA X (IMPLODE (CONS 'C (REVERSIP (CONS 'R (NCONC (GLANYCARCDR? (CAADR X)) (GLANYCARCDR? (CAR X)))))))) (RPLACA (CDR X) (CADADR X)) (GLUNWRAP X BUSY)) ((AND (GET (CAR X) 'GLEVALWHENCONST) (EVERY (CDR X) (FUNCTION GLCONST?)) (OR (NOT (GET (CAR X) 'GLARGSNUMBERP)) (EVERY (CDR X) (FUNCTION NUMBERP)))) (EVAL X)) ((MEMQ (CAR X) '(AND OR)) (GLUNWRAPLOG X)) (T X))))))))) % GSN 27-JAN-83 13:57 % Unwrap a COND expression. (DE GLUNWRAPCOND (X BUSY) (PROG (RESULT) (SETQ RESULT X) A (COND ((NULL (CDR RESULT)) (GO B))) (RPLACA (CADR RESULT) (GLUNWRAP (CAADR RESULT) T)) (COND ((EQ (CAADR RESULT) NIL) (RPLACD RESULT (CDDR RESULT)) (GO A)) (T (MAP (CDADR RESULT) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CADR RESULT) BUSY NIL))) (COND ((EQ (CAADR RESULT) T) (RPLACD (CDR RESULT) NIL))) (SETQ RESULT (CDR RESULT)) (GO A) B (COND ((AND (NULL (CDDR X)) (EQ (CAADR X) T)) (RETURN (CONS 'PROGN (CDADR X)))) (T (RETURN X))))) % GSN 17-FEB-83 13:40 % Optimize intersections and unions of subsets of the same set: % (INTERSECT (SUBSET S P) (SUBSET S Q)) -> (SUBSET S (AND P Q)) (DE GLUNWRAPINTERSECT (CODE) (PROG (LHS RHS P Q QQ SA SB) (SETQ LHS (GLUNWRAP (CADR CODE) T)) (SETQ RHS (GLUNWRAP (CADDR CODE) T)) (OR (AND (PAIRP LHS) (PAIRP RHS) (EQ (CAR LHS) 'SUBSET) (EQ (CAR RHS) 'SUBSET)) (GO OUT)) (PROGN (SETQ SA (GLUNWRAP (CADR LHS) T)) (SETQ SB (GLUNWRAP (CADR RHS) T))) % Make sure the sets are the same. (OR (EQUAL SA SB) (GO OUT)) (PROGN (SETQ P (GLXTRFN (CADDR LHS))) (SETQ Q (GLXTRFN (CADDR RHS)))) (SETQ QQ (SUBST (CAR P) (CAR Q) (CADR Q))) (RETURN (GLGENCODE (LIST 'SUBSET SA (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR P)) (GLUNWRAP (CASEQ (CAR CODE) (INTERSECTION (LIST 'AND (CADR P) QQ)) (UNION (LIST 'OR (CADR P) QQ)) (LDIFFERENCE (LIST 'AND (CADR P) (LIST 'NOT QQ))) (T (ERROR 0 NIL))) T)))))) OUT (MAP (CDR CODE) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (RETURN CODE))) % edited: 26-DEC-82 16:24 % Unwrap a logical expression by performing constant transformations % and splicing in sublists of the same type, e.g., (AND X (AND Y Z)) % -> (AND X Y Z) . (DE GLUNWRAPLOG (X) (PROG (Y LAST) (SETQ Y (CDR X)) (SETQ LAST X) LP (COND ((NULL Y) (GO OUT)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'AND)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'OR))) (RPLACD Y NIL)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'OR)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'AND))) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((MEMBER (CAR Y) (CDR Y)) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((AND (PAIRP (CAR Y)) (EQ (CAAR Y) (CAR X))) (RPLACD (LASTPAIR (CAR Y)) (CDR Y)) (RPLACD Y (CDDAR Y)) (RPLACA Y (CADAR Y)))) (SETQ Y (CDR Y)) (SETQ LAST (CDR LAST)) (GO LP) OUT (COND ((NULL (CDR X)) (RETURN (EQ (CAR X) 'AND))) ((NULL (CDDR X)) (RETURN (CADR X)))) (RETURN X))) % edited: 19-OCT-82 16:03 % Unwrap and optimize mapping-type functions. (DE GLUNWRAPMAP (X BUSY) (PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST) (PROGN (SETQ LST (GLUNWRAP (CADR X) T)) (SETQ FN (GLUNWRAP (CADDR X) (NOT (MEMQ (CAR X) '(MAPC MAP)))))) (COND ((OR (NOT (MEMQ (SETQ OUTFN (CAR X)) '(SUBSET MAPCAR MAPC MAPCONC))) (NOT (AND (PAIRP LST) (MEMQ (SETQ INFN (CAR LST)) '(SUBSET MAPCAR))))) (GO OUT))) % Optimize compositions of mapping functions to avoid construction of % lists of intermediate results. % These optimizations are not correct if the mapping functions have % interdependent side-effects. However, these are likely to be very % rare, so we do it anyway. (SETQ OUTSIDE (GLXTRFN FN)) (SETQ INSIDE (GLXTRFN (PROGN (SETQ NEWLST (CADR LST)) (CADDR LST)))) (CASEQ INFN (SUBSET (CASEQ OUTFN ((SUBSET MAPCONC) (SETQ NEWMAP OUTFN) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE))))) (MAPCAR (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (LIST 'CONS (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) NIL)))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) ))) (T (ERROR 0 NIL)))) (MAPCAR (SETQ NEWFN (LIST 'PROG (LIST (SETQ TMPVAR (GLMKVAR))) (LIST 'SETQ TMPVAR (CADR INSIDE)) (LIST 'RETURN '*GLCODE*))) (CASEQ OUTFN (SUBSET (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (SUBST (LIST 'AND (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) (LIST 'CONS TMPVAR NIL)) '*GLCODE* NEWFN))) (MAPCAR (SETQ NEWMAP 'MAPCAR) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (T (ERROR 0 NIL)))) (T (ERROR 0 NIL))) (RETURN (GLUNWRAP (GLGENCODE (LIST NEWMAP NEWLST (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR INSIDE)) NEWFN)))) BUSY)) OUT (RETURN (GLGENCODE (LIST OUTFN LST FN))))) % GSN 27-JAN-83 13:57 % Unwrap a PROG expression. (DE GLUNWRAPPROG (X BUSY) (PROG (LAST) (COND ((NE GLLISPDIALECT 'INTERLISP) (GLTRANSPROG X))) % First see if the PROG is not busy and ends with a RETURN. (COND ((AND (NOT BUSY) (SETQ LAST (LASTPAIR X)) (PAIRP (CAR LAST)) (EQ (CAAR LAST) 'RETURN)) % Remove the RETURN. If atomic, remove the atom also. (COND ((ATOM (CADAR LAST)) (RPLACD (NLEFT X 2) NIL)) (T (RPLACA LAST (CADAR LAST)))))) % Do any initializations of PROG variables. (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP Y) (RPLACA (CDR Y) (GLUNWRAP (CADR Y) T))))))) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) NIL))))) (GLEXPANDPROGN (CDR X) BUSY T) (RETURN X))) % GSN 27-JAN-83 13:57 % Unwrap a SELECTQ or CASEQ expression. (DE GLUNWRAPSELECTQ (X BUSY) (PROG (L SELECTOR) % First unwrap the component expressions. (RPLACA (CDR X) (GLUNWRAP (CADR X) T)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (COND ((OR (CDR Y) (EQ (CAR X) 'CASEQ)) (MAP (CDAR Y) (FUNCTION (LAMBDA (Z) (RPLACA Z (GLUNWRAP (CAR Z) (AND BUSY (NULL (CDR Z)))))))) (GLEXPANDPROGN (CAR Y) BUSY NIL)) (T (RPLACA Y (GLUNWRAP (CAR Y) BUSY))))))) % Test if the selector is a compile-time constant. (COND ((NOT (GLCONST? (CADR X))) (RETURN X))) % Evaluate the selection at compile time. (SETQ SELECTOR (GLCONSTVAL (CADR X))) (SETQ L (CDDR X)) LP (COND ((NULL L) (RETURN NIL)) ((AND (NULL (CDR L)) (EQ (CAR X) 'SELECTQ)) (RETURN (CAR L))) ((AND (EQ (CAR X) 'CASEQ) (EQ (CAAR L) T)) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY))) ((OR (EQ SELECTOR (CAAR L)) (AND (PAIRP (CAAR L)) (MEMQ SELECTOR (CAAR L)))) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY)))) (SETQ L (CDR L)) (GO LP))) % edited: 5-MAY-82 15:49 % Update the type of VAR to be TYPE. (DE GLUPDATEVARTYPE (VAR TYPE) (PROG (CTXENT) (COND ((NULL TYPE)) ((SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT)) (COND ((NULL (CADDR CTXENT)) (RPLACA (CDDR CTXENT) TYPE)))) (T (GLADDSTR VAR NIL TYPE CONTEXT))))) % GSN 23-JAN-83 15:31 % edited: 7-Apr-81 10:44 % Process a user-function, i.e., any function which is not specially % compiled by GLISP. The function is tested to see if it is one % which a unit package wants to compile specially; if not, the % function is compiled by GLUSERFNB. (DE GLUSERFN (EXPR) (PROG (FNNAME TMP UPS) (SETQ FNNAME (CAR EXPR)) % First see if a user structure-name package wants to intercept this % function call. (SETQ UPS GLUSERSTRNAMES) LPA (COND ((NULL UPS) (GO B)) ((SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LPA) B % Test the function name to see if it is a function which some unit % package would like to intercept and compile specially. (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (GO C)) ((AND (MEMQ FNNAME (CAR (CDDDDR (CAR UPS)))) (SETQ TMP (ASSOC 'UNITFN (CADDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LP) C (COND ((AND (NOT (UNBOUNDP 'GLFNSUBS)) (SETQ TMP (ASSOC FNNAME GLFNSUBS))) (RETURN (GLUSERFNB (CONS (CDR TMP) (CDR EXPR))))) (T (RETURN (GLUSERFNB EXPR)))))) % GSN 23-JAN-83 15:54 % edited: 7-Apr-81 10:44 % Parse an arbitrary function by getting the function name and then % calling GLDOEXPR to get the arguments. (DE GLUSERFNB (EXPR) (PROG (ARGS ARGTYPES FNNAME TMP) (SETQ FNNAME (pop EXPR)) A (COND ((NULL EXPR) (SETQ ARGS (REVERSIP ARGS)) (SETQ ARGTYPES (REVERSIP ARGTYPES)) (RETURN (COND ((AND (GET FNNAME 'GLEVALWHENCONST) (EVERY ARGS (FUNCTION GLCONST?))) (LIST (EVAL (CONS FNNAME ARGS)) (GLRESULTTYPE FNNAME ARGTYPES))) (T (LIST (CONS FNNAME ARGS) (GLRESULTTYPE FNNAME ARGTYPES)))))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS (CAR TMP) ARGS)) (SETQ ARGTYPES (CONS (CADR TMP) ARGTYPES)) (GO A))))) % edited: 24-AUG-82 17:40 % Get the arguments to an function call for use by a user compilation % function. (DE GLUSERGETARGS (EXPR CONTEXT) (PROG (ARGS TMP) (pop EXPR) A (COND ((NULL EXPR) (RETURN (REVERSIP ARGS))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS TMP ARGS)) (GO A))))) % GSN 10-FEB-83 16:01 % Try to perform an operation on a user-defined structure, which is % LHS. The type of LHS is looked up on GLUSERSTRNAMES, and if found, % the appropriate user function is called. (DE GLUSERSTROP (LHS OP RHS) (PROG (TMP DES TMPB) (SETQ DES (CADR LHS)) (COND ((NULL DES) (RETURN NIL)) ((ATOM DES) (COND ((NE (SETQ TMP (GLGETSTR DES)) DES) (RETURN (GLUSERSTROP (LIST (CAR LHS) TMP) OP RHS))) (T (RETURN NIL)))) ((NOT (PAIRP DES)) (RETURN NIL)) ((AND (SETQ TMP (ASSOC (CAR DES) GLUSERSTRNAMES)) (SETQ TMPB (ASSOC OP (CADDDR TMP)))) (RETURN (APPLY (CDR TMPB) (LIST LHS RHS)))) (T (RETURN NIL))))) % GSN 10-FEB-83 12:57 % Get the value of the property PROP from SOURCE, whose type is given % by TYPE. The property may be a field in the structure, or may be a % PROP virtual field. % DESLIST is a list of object types which have previously been tried, % so that a compiler loop can be prevented. (DE GLVALUE (SOURCE PROP TYPE DESLIST) (PROG (TMP PROPL TRANS FETCHCODE) (COND ((MEMQ TYPE DESLIST) (RETURN NIL)) ((SETQ TMP (GLSTRFN PROP TYPE DESLIST)) (RETURN (GLSTRVAL TMP SOURCE))) ((SETQ PROPL (GLSTRPROP TYPE 'PROP PROP NIL)) (SETQ TMP (GLCOMPMSGL (LIST SOURCE TYPE) 'PROP PROPL NIL CONTEXT)) (RETURN TMP))) % See if the value can be found in a TRANSPARENT subobject. (SETQ TRANS (GLTRANSPARENTTYPES TYPE)) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLVALUE '*GL* PROP (GLXTRTYPE (CAR TRANS)) (CONS (CAR TRANS) DESLIST))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) TYPE NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP SOURCE) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % edited: 16-DEC-81 12:00 % Get the structure-description for a variable in the specified % context. (DE GLVARTYPE (VAR CONTEXT) (PROG (TMP) (RETURN (COND ((SETQ TMP (GLFINDVARINCTX VAR CONTEXT)) (OR (CADDR TMP) '*NIL*)) (T NIL))))) % edited: 3-DEC-82 10:24 % Extract the code and variable from a FUNCTION list. If there is no % variable, a new one is created. The result is a list of the % variable and code. (DE GLXTRFN (FNLST) (PROG (TMP) % If only the function name is specified, make a LAMBDA form. (COND ((ATOM (CADR FNLST)) (RPLACA (CDR FNLST) (LIST 'LAMBDA (LIST (SETQ TMP (GLMKVAR))) (LIST (CADR FNLST) TMP))))) (COND ((CDDDR (CADR FNLST)) (RPLACD (CDADR FNLST) (LIST (CONS 'PROGN (CDDADR FNLST)))))) (RETURN (LIST (CAADR (CADR FNLST)) (CADDR (CADR FNLST)))))) % edited: 26-JUL-82 14:03 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GLXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (OR (GL-A-AN? (CAR TYPE)) (EQ (CAR TYPE) 'TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPE (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 26-JUL-82 14:02 % Extract a -real- type from a type spec. (DE GLXTRTYPEB (TYPE) (COND ((NULL TYPE) NIL) ((ATOM TYPE) (COND ((MEMQ TYPE GLBASICTYPES) TYPE) (T (GLXTRTYPEB (GLGETSTR TYPE))))) ((NOT (PAIRP TYPE)) NIL) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPEB (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 1-NOV-82 16:38 % Extract a -real- type from a type spec. (DE GLXTRTYPEC (TYPE) (AND (ATOM TYPE) (NOT (MEMQ TYPE GLBASICTYPES)) (GLXTRTYPE (GLGETSTR TYPE)))) % GSN 9-FEB-83 16:46 (DF SEND (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) NIL (CADR GLISPSENDARGS) 'MSG (MAPCAR (CDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDC (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) (CADR GLISPSENDARGS) (CADDR GLISPSENDARGS) 'MSG (MAPCAR (CDDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:46 (DF SENDPROP (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) NIL (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (MAPCAR (CDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDPROPC (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (CADDDR GLISPSENDPROPARGS) (MAPCAR (CDDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % % GLTAIL.PSL.4 18 Feb. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (COND ((PAIRP (GETD X)) (CDR (GETD X))) (T NIL))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NOT (PAIRP L)) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (glputhook (car x)) ) % Put the hook macro onto a function to cause auto compilation. (df glputhook (x) (put x 'glcompiled nil) (putd x 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (setq globjectnames nil) (GLINIT) |
Added psl-1983/glisp/glscan.sl version [12dda21ad9].
> > > > > > > > | 1 2 3 4 5 6 7 8 | (setq GLispScanTable!* ' [17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 GLispDipthong]) |
Added psl-1983/glisp/gltail.psl version [bda1458bda].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLTAIL.PSL.4 18 Feb. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (COND ((PAIRP (GETD X)) (CDR (GETD X))) (T NIL))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NOT (PAIRP L)) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (glputhook (car x)) ) % Put the hook macro onto a function to cause auto compilation. (df glputhook (x) (put x 'glcompiled nil) (putd x 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (setq globjectnames nil) (GLINIT) |
Added psl-1983/glisp/gltail.sl version [9172196497].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLTAIL.PSL.10 14 Jan. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (CDR (GETD X))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NULL L) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST) (COND ((GREATERP M (FLATSIZE2 ATM))(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (put (car x) 'glcompiled nil) (putd (car x) 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (GLINIT) |
Added psl-1983/glisp/gltest version [0822a2efe8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.PSL.2 22 OCTOBER 82 % GLISP TEST FUNCTIONS, PSL VERSION. GSN 22 OCTOBER 82 (DE GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DE CURRENTDATE () (A DATE WITH YEAR = 1981 !, MONTH = 11 !, DAY = 30)) (PUTPROP 'CURRENTDATE 'GLRESULTTYPE 'DATE) (GLISPOBJECTS (EMPLOYEE (LIST (NAME STRING) (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) (DATE (LIST (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH ' (JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) (PUTPROP 'COMPANY1 'PRESIDENT '("OSCAR THE GROUCH" (3 15 1907) 88.0 PRESIDENT NIL) ) (PUTPROP 'COMPANY1 'EMPLOYEES '(("COOKIE MONSTER" (7 21 1947) 12.5 ELECTRICIAN NIL) ("BETTY LOU" (5 14 1980) 9.0 ELECTRICIAN NIL) ("GROVER" (6 13 1978) 3.0 ELECTRICIAN T)) ) (GLISPOBJECTS (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T) (/ VECTORQUOTIENT OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ SELF PRIN1) (TERPRI))) ) ) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE PAINT))))) (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) (VELOCITY VECTOR)) MSG ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((_ SELF MOVE VELOCITY)))) ) ) (DE VECTORPLUS (V1!,V2:VECTOR) (A VECTOR WITH X = V1:X + V2:X !, Y = V1:Y + V2:Y)) (DE VECTORDIFF (V1!,V2:VECTOR) (A VECTOR WITH X = V1:X - V2:X !, Y = V1:Y - V2:Y)) (DE VECTORTIMES (V:VECTOR N:NUMBER) (A VECTOR WITH X = X*N !, Y = Y*N)) (DE VECTORQUOTIENT (V:VECTOR N:NUMBER) (A VECTOR WITH X = X/N !, Y = Y/N)) (DE VECTORMOVE (V!,DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y)) (DE GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (_ SELF ERASE) (START _+ DELTA) (_ SELF DRAW)) (DE MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) (DE TESTFN1 () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE =(QUOTE RECTANGLE) !, SIZE =(A VECTOR WITH X = 4 !, Y = 3) !, VELOCITY =(A VECTOR WITH X = 3 !, Y = 4))) (N _ 0) (WHILE (N_+1) <100 (_ MGO STEP)) (_(THE START OF MGO) PRINT))) (DE TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA )) (DE DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS)))) ) (GLISPOBJECTS (LISPTREE (CONS (CAR LISPTREE) (CDR LISPTREE)) PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) (DE TP (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (_ PSR NEXT)))) (GLISPOBJECTS (ARITHMETICOPERATOR (SELF ATOM) PROP ((PRECEDENCE OPERATORPRECEDENCEFN RESULT INTEGER) (PRINTFORM ((GET SELF (QUOTE PRINTFORM)) OR SELF))) MSG ((PRIN1 ((PRIN1 THE PRINTFORM)))) ) (INTEGERMOD7 (SELF INTEGER) PROP ((MODULUS (7)) (INVERSE ((IF SELF IS ZERO THEN 0 ELSE (MODULUS - SELF))))) ADJ ((EVEN ((ZEROP (LOGAND SELF 1)))) (ODD (NOT EVEN))) ISA ((PRIME PRIMETESTFN)) MSG ((+ IMOD7PLUS OPEN T RESULT INTEGERMOD7) (_ IMOD7STORE OPEN T RESULT INTEGERMOD7)) ) ) (DE IMOD7STORE (LHS:INTEGERMOD7 RHS:INTEGER) (LHS:SELF __(IREMAINDER RHS MODULUS))) (DE IMOD7PLUS (X!,Y:INTEGERMOD7) (IREMAINDER (X:SELF + Y:SELF) X:MODULUS)) (DE SA (:ARITHMETICOPERATOR) (IF PRECEDENCE>5 (_ (THE ARITHMETICOPERATOR) PRIN1))) (DE SB (X:INTEGERMOD7) (PROG (Y) (LIST MODULUS INVERSE) (IF X IS ODD OR X IS EVEN OR X IS A PRIME THEN (Y _ 5) (X _ 12) (X _+5)))) (GLISPOBJECTS (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2)) ) )) % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DE GROWCIRCLE (C:CIRCLE) (C:AREA_+100) (PRINT RADIUS) ) (SETQ MYCIRCLE '((0 0) 0.0)) % EXAMPLE OF ELIMINATION OF COMPILE-TIME CONSTANTS (DE SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF 6<2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) |
Added psl-1983/glisp/gltest.sl version [a4c3c38e87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.SL.2 18 February 1983 % GLISP TEST FUNCTIONS, PSL VERSION. % Object descriptions for a Company database. (GLISPOBJECTS (EMPLOYEE % Name of the object type (LIST (NAME STRING) % Actual storage structure (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) % Computed properties - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) % Computed adjectives ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) % Message definitions (Date (List (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH '(JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) % Some test data for the above functions. (setq company1 (a company with President = (An Employee with Name = "Oscar the Grouch" Salary = 88.0 Jobtitle = 'President Date-Hired = (A Date with Month = 3 Day = 15 Year = 1907)) Employees = (list (An Employee with Name = "Cookie Monster" Salary = 12.50 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 7 Day = 21 Year = 1947)) (An Employee with Name = "Betty Lou" Salary = 9.00 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 5 Day = 15 Year = 1980)) (An Employee with Name = "Grover" Salary = 3.00 Jobtitle = 'Electrician Trainee = T Date-Hired = (A Date with Month = 6 Day = 13 Year = 1978)) ))) % Program to give raises to the electricians. (DG GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DG CURRENTDATE () (Result DATE) (A DATE WITH YEAR = 1981 MONTH = 11 DAY = 30)) % The following object descriptions are used in a graphics object test % program (derived from one written by D.G. Bobrow as a LOOPS example). % The test program MGO-TEST runs on a Xerox D-machine, but won't run on % other machines. (GLISPOBJECTS % The actual stored structure for a Vector is simple, but it is overloaded % with many properties. (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (DIRECTION ((IF X IS ZERO THEN (IF Y IS NEGATIVE THEN -90.0 ELSE 90.0) ELSE (ATAN2D Y X))) RESULT DEGREES) ) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) % Defining operators as messages % causes the compiler to automatically % overload the operators. (- VECTORDIFF OPEN T) (* VECTORTIMESSCALAR ARGTYPES (NUMBER) OPEN T) (* VECTORDOTPRODUCT ARGTYPES (VECTOR) OPEN T) (/ VECTORQUOTIENTSCALAR OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((SEND SELF PRIN1) % PRINT is defined in terms of the (TERPRI))) ) ) % PRIN1 message of this object. (DEGREES REAL % Stored value is just a real number. PROP ((RADIANS (self*(3.1415926 / 180.0)) RESULT RADIANS))) (RADIANS REAL PROP ((DEGREES (self*(180.0 / 3.1415926)) RESULT DEGREES))) % A FVECTOR is a very different kind of VECTOR: it has a different % storage structure and different element types. However, it can % still inherit some vector properties, e.g., addition. (FVECTOR (CONS (Y STRING) (X BOOLEAN)) SUPERS (VECTOR)) % The definition of GraphicsObject builds on that of Vector. (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) % A property defined in terms of a % property of a substructure (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) % Vector arithmetic (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) % A way to get runtime message (List SELF % behavior without using the (QUOTE PAINT))))) % message mechanism. (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) % Includes properties of a (VELOCITY VECTOR)) % GraphicsObject due to the % TRANSPARENT declaration. Msg ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((SEND SELF MOVE VELOCITY)))) ) ) % The following functions define arithmetic operations on Vectors. % These functions are generally called OPEN (macro-expanded) rather % than being called directly. (DG VECTORPLUS (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) (DG VECTORDIFF (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) (DG VECTORTIMESSCALAR (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X*N Y = Y*N)) (DG VECTORDOTPRODUCT (V1:vector V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X * V2:X Y = V1:Y * V2:Y)) (DG VECTORQUOTIENTSCALAR (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X/N Y = Y/N)) % VectorMove, which defines the _+ operator for vectors, does a destructive % addition to the vector which is its first argument. Thus, the expression % U_+V will destructively change U, while U_U+V will make a new vector with % the value U+V and assign its value to U. (DG VECTORMOVE (V:vector DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y) V) % An object is moved by erasing it, changing its starting point, and % then redrawing it. (DG GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (SEND SELF ERASE) % Erase the object (START _+ DELTA) % Destructively move start point by delta (SEND SELF DRAW)) % Redraw the object in new location (DG MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) % Now we define some test functions which use the above definitions. % First there are some simple functions which test vector operations. (DG TVPLUS (U:VECTOR V:VECTOR) U+V) (DG TVMOVE (U:VECTOR V:VECTOR) U_+V) (DG TVTIMESV (U:VECTOR V:VECTOR) U*V) (DG TVTIMESN (U:VECTOR V:NUMBER) U*V) (DG TFVPLUS (U:FVECTOR V:FVECTOR) U+V) % This test function creates a MovingGraphicsObject and then moves it % across the screen by sending it MOVE messages. Everything in this % example is compiled open; the STEP message involves a great deal of % message inheritance. (DG MGO-TEST () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE = (QUOTE RECTANGLE) SIZE = (A VECTOR WITH X = 4 Y = 3) VELOCITY = (A VECTOR WITH X = 3 Y = 4))) (N _ 0) (WHILE (N_+1)<100 (SEND MGO STEP)) (SEND (THE START OF MGO) PRINT))) % This function tests the properties of a GraphicsObject. (DG TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA)) % Function to draw a rectangle. Computed properties of the rectangle are % used within calls to the graphics functions, making the code easy to % write and understand. (DG DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS) )) % The LispTree and PreorderSearchRecord objects illustrate how generators % can be written. (GLISPOBJECTS % In defining a LispTree, which can actually be of multiple types (atom or % dotted pair), we define it as the more complex dotted-pair type and take % care of the simpler case in the PROPerty definitions. (LISPTREE (CONS (CAR LISPTREE) % Defines a LispTree structure as the CONS (CDR LISPTREE)) % of two fields named CAR and CDR. PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) % PreorderSearchRecord is defined to be a generator. Its data structure holds % the current node and a stack of previous nodes, and its NEXT message is % defined as code to step through the preorder search. (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) % PRINTLEAVES prints the leaves of the tree, using a PreorderSearchRecord % as the generator for searching the tree. (DG PRINTLEAVES (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (SEND PSR NEXT)))) % The Circle objects illustrate the definition of a number of mathematical % properties of an object in terms of stored data and other properties. (Glispobjects (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) % A PROPerty can be a constant. (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) % Defined in terms of other prop. (AREA (PI*RADIUS^2)) ) ADJ ((BIG (AREA>120)) % BIG defined in terms of AREA (MEDIUM (AREA >= 60 AND AREA <= 120)) (SMALL (AREA<60))) MSG ((STANDARD (AREA_100)) % "Storing into" computed property (GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) ) ) % A DCIRCLE is implemented differently from a circle. % The data structure is different, and DIAMETER is stored instead of RADIUS. % By defining RADIUS as a PROPerty, all of the CIRCLE properties defined % in terms of radius can be inherited. (DCIRCLE (LISTOBJECT (START VECTOR) (DIAMETER REAL)) PROP ((RADIUS (DIAMETER/2))) SUPERS (CIRCLE) ) ) % Make a DCIRCLE for testing (setq dc (a dcircle with diameter = 10.0)) % Since DCIRCLE is an Object type, it can be used with interpreted messages, % e.g., (send dc area) to get the area property, % (send dc standard) to set the area to the standard value, % (send dc diameter) to get the stored diameter value. % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DG GROWCIRCLE (C:CIRCLE) (C:AREA_+100) C ) (SETQ MYCIRCLE (A CIRCLE)) % Since SQRT is not defined in the bare-PSL system, we redefine it here. (DG SQRT (X) (PROG (S) (S_X) (IF X < 0 THEN (ERROR) ELSE (WHILE (ABS S*S - X) > 0.000001 DO (S _ (S+X/S) * 0.5))) (RETURN S))) % Function SQUASH illustrates elimination of compile-time constants. % Of course, nobody would write such a function directly. However, such forms % can arise when inherited properties are compiled. Conditional compilation % occurs automatically when appropriate variables are defined to the GLISP % compiler as compile-time constants because the post-optimization phase of % the compiler makes the unwanted code disappear. (DG SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF (SQRT 7.2) < 2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) % The following object definitions describe a student records database. (glispobjects (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winning (average>=95)) (losing (average<60))) isa ((winner (self is winning)))) (student-group (listof student) prop ((n-students length) % This property is implemented by % the Lisp function LENGTH. (Average Student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male))) (women ((those students who are female))) (winners ((those students who are winning))) (losers ((those students who are losing))) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)) (for s in sg do sum_+s:average) (return sum/sg:n-students) )) % Print name and grade average for each student (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (print s:grade-average))) % Another version of the above function (dg test1b (:class) (for each student (prin1 name) (prin2 '! ) (print grade-average))) % Print name and average of the winners in the class (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % The average of all the male students' grades (dg test3 (c:class) c:men:average) % The name and average of the winning women (dg test4 (c:class) (for s in c:women when s is winning (prin1 s:name) (prin2 '! ) (print s:average))) % Another version of the above function. The * operator in this case % denotes the intersection of the sets of women and winners. The % GLISP compiler optimizes the code so that these intermediate sets are % not actually constructed. (dg test4b (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % Make a list of the easy professors. (dg easy-profs (classes:(listof class)) (for each class with class-average > 90.0 collect (the instructor))) % A more Pascal-like version of easy-profs: (dg easy-profs-b (classes:(listof class)) (for c in classes when c:class-average > 90.0 collect c:instructor)) % Some test data for testing the above functions. (setq class1 (a class with instructor = "A. Prof" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) % The following object definitions illustrate inheritance of properties % from multiple parent classes. The three "bottom" classes Planet, Brick, % and Bowling-Ball all inherit the same definition of the property Density, % although they are represented in very different ways. (glispobjects (physical-object anything prop ((density (mass/volume)))) (ordinary-object anything prop ((mass (weight / 9.88))) % Compute mass as weight/gravity supers (physical-object)) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (parallelepiped anything prop ((volume (length*width*height)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) % A planet is a physical-object % and a sphere. (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) % Three test functions to demonstrate inheritance of the Density property. (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) % Some objects to test the functions on. (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.10 height = 0.05 length = 0.20)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) % Since the object types Planet, Brick, and Bowling-Ball are defined as % Object types (i.e., they contain the Class name as part of their stored % data), messages can be sent to them directly from the keyboard for % interactive examination of the objects. For example, the following % messages could be used: % (send earth density) % (send brick1 weight: 25.0) % (send brick1 mass: 2.0) % (send bb1 radius) % (send bb1 type: 'child) |
Added psl-1983/glisp/gltestb.psl version [bf458d1abf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (glispobjects (circle (list (start vector) (radius real) (color atom)) prop ((pi (3.14159265)) (diameter (2*radius)) (circumference (pi*diameter)) (area (pi*radius^2))) adj ((big (area>100)) (small (area<80))) msg ((grow (area_+100)) (shrink (area_area/2)) (standard (area_100))) ) (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winner (average>=95)) (loser (average<60))) isa ((winner (self is winner)))) (student-group (listof student) prop ((n-students length) (average student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male)) result student-group) (women ((those students who are female)) result student-group) (winners ((those students who are winner)) result student-group) (losers ((those students who are loser)) result student-group) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)(n 0.0)) (for s in sg do sum_+s:average n _+ 1.0) (return sum/n) )) (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (prin1 s:grade-average) (terpri))) (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (dg test3 (c:class) c:men:average) (dg test4 (c:class) (for s in c:women when s is winner (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (dg test5 (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (prin1 s:average) (terpri))) (setq class1 (a class with instructor = "G. Novak" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) (glispobjects (physical-object anything prop ((density (mass/volume)))) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) (ordinary-object anything prop ((mass (weight / 9.88))) supers (physical-object)) (parallelepiped anything prop ((volume (length*width*height)))) (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.06 height = 0.04 length = 0.16)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) |
Added psl-1983/glisp/gluser.mss version [074026df66].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Make(Manual) @Define(PE,FaceCode U) @Begin(TitlePage) @Begin(TitleBox) @MajorHeading[GLISP User's Manual] @BlankSpace(2) @Center( Gordon S. Novak Jr. Computer Science Department Stanford University Stanford, California 94305) @BlankSpace(3) @BlankSpace(2) @Center[@B<Revised:> @Value(Date)] @End(TitleBox) @Begin(ResearchCredit) This research was supported in part by NSF grant SED-7912803 in the Joint National Science Foundation - National Institute of Education Program of Research on Cognitive Processes and the Structure of Knowledge in Science and Mathematics, and in part by the Defense Advanced Research Projects Agency under contract MDA-903-80-c-007. @End(ResearchCredit) @End(TitlePage) @Chapter(Introduction) @Section(Overview of GLISP) GLISP is a LISP-based language which provides high-level language features not found in ordinary LISP. The GLISP language is implemented by means of a compiler which accepts GLISP as input and produces ordinary LISP as output; this output can be further compiled to machine code by the LISP compiler. GLISP is available for several LISP dialects, including Interlisp, Maclisp, UCI Lisp, ELISP, Franz Lisp, and Portable Standard Lisp. The goal of GLISP is to allow structured objects to be referenced in a convenient, succinct language, and to allow the structures of objects to be changed without changing the code which references the objects. GLISP provides both PASCAL-like and English-like syntaxes; much of the power and brevity of GLISP derive from the compiler features necessary to support the relatively informal, English-like language constructs. The following example function illustrates how GLISP permits definite reference to structured objects. @Begin(ProgramExample) (HourlySalaries (GLAMBDA ( (a DEPARTMENT) ) (for each EMPLOYEE who is HOURLY (PRIN1 NAME) (SPACES 3) (PRINT SALARY) ) )) @End(ProgramExample) The features provided by GLISP include the following: @Begin(Enumerate) GLISP maintains knowledge of the "context" of the computation as the program is executed. Features of objects which are in context may be referenced directly; the compiler will determine how to reference the objects given the current context, and will add the newly referenced objects to the context. In the above example, the function's argument, an object whose class is DEPARTMENT, establishes an initial context relative to which EMPLOYEEs can be found. In the context of an EMPLOYEE, NAME and SALARY can be found. GLISP supports flexible object definition and reference with a powerful abstract datatype facility. Object classes are easily declared to the system. An object declaration includes a definition of the storage structure of the object and declarations of properties of the object; these may be declared in such a way that they compile open, resulting in efficient object code. GLISP supports object-centered programming, in which processes are invoked by means of "messages" sent to objects. Object structures may be LISP structures (for which code is automatically compiled) or Units in the user's favorite representation language (for which the user can supply compilation functions). Loop constructs, such as @ (FOR EACH <item> WITH <property> DO ...)@ , are compiled into loops of the appropriate form. Compilation of infix expressions is provided for the arithmetic operators and for additional operators which facilitate list manipulation. Operators are interpreted appropriately for Lisp datatypes as well as for numbers; operator overloading for user-defined objects is provided using the message facility. The GLISP compiler infers the types of objects when possible, and uses this knowledge to generate efficient object code. By performing @I[ compilation relative to a knowledge base ], GLISP is able to perform certain computations (e.g., inheritance of an attached procedure from a parent class of an object in a knowledge base) at compile time rather than at runtime, resulting in much faster execution. By separating object definitions from the code which references objects, GLISP permits radical changes to object structures with no changes to code. @End(Enumerate) @Section(Implementation) GLISP is implemented by means of a compiler, which produces a normal Lisp EXPR from the GLISP code; the GLISP code is saved on the function's property list, and the compiled definition replaces the GLISP definition. Use of GLISP entails the cost of a single compilation, but otherwise is about as efficient as normal LISP. The LISP code produced by GLISP can be further compiled to machine code by the LISP compiler. GLISP functions are indicated by the use of GLAMBDA instead of LAMBDA in the function definition. When the Lisp interpreter sees the GLAMBDA, it calls the GLISP compiler to incrementally compile the GLISP function. The compiled version replaces the GLISP version (which is saved on the function name's property list), and is used thereafter. This automatic compilation feature is currently implemented in Interlisp and in Franz Lisp. In other dialects, it is necessary for the user to explicitly invoke compilation of GLISP functions by calling the compiler function @PE[GLCC] for each one. To use GLISP, it is first necessary to load the compiler file into Lisp. Users' files containing structure descriptions and GLISP code are then loaded. Compilation of a GLISP function is requested by: @Tabset(1.7 inch) @Begin(Format) @PE[(GLCC 'FN)]@\Compile @PE[FN]. @PE[(GLCP 'FN)]@\Compile @PE[FN] and prettyprint the result. @PE[(GLP 'FN)]@\Print the compiled version of @PE[FN]. @End(Format) In Interlisp, all the GLISP functions (beginning with GLAMBDA) in a file can be compiled by invoking @PE[(GLCOMPCOMS@ <file>COMS)], where @PE[<file>COMS] is the list of file package commands for the file. Properties of compiled functions are stored on the property list of the function name: @Begin(Format) @PE[GLORIGINALEXPR]@\Original (GLISP) version of the function.@FOOT[The original definition is saved as EXPR in Interlisp.] @PE[GLCOMPILED]@\GLISP-compiled version of the function. @PE[GLRESULTTYPE]@\Type of the result of the function. @PE[GLARGUMENTTYPES]@\Types of the arguments of the function. @End(format) Properties of GLISP functions can be examined with the function @PE[(GLED '<name>)], which calls the Lisp editor on the property list of @PE[<name>]. @PE[(GLEDF '<name>)] calls the Lisp editor on the original (GLISP) definition of @PE[<name>]. @Section(Error Messages) GLISP provides detailed error messages when compilation errors are detected; many careless errors such as misspellings will be caught by the compiler. When the source program contains errors, the compiled code generates runtime errors upon execution of the erroneous expressions. @Section(Interactive Features of GLISP) Several features of GLISP are available interactively, as well as in compiled functions: @Enumerate{ The @PE[A] function, which creates structured objects from a readable property/value list, is available as an interactive function. Messages to objects can be executed interactively. A display editor/inspector, GEV, is available for use with bitmap graphics terminals.@Foot[GEV is currently implemented only for Xerox Lisp machines.] GEV interprets objects according to their GLISP structure descriptions; it allows the user to inspect objects, edit them, interactively construct programs which operate on them, display computed properties, send messages to objects, and "push down" to inspect data values.} @Chapter(Object Descriptions) @Section(Declaration of Object Descriptions) An @I(Object Description) in GLISP is a description of the structure of an object in terms of named substructures, together with definitions of ways of referencing the object. The latter may include @I( properties ) (i.e., data whose values are not stored, but are computed from the values of stored data), adjectival predicates, and @I(messages) which the object can receive; the messages can be used to implement operator overloading and other compilation features. Object Descriptions are obtained by GLISP in several ways: @Begin(Enumerate) The descriptions of basic datatypes (e.g., INTEGER) are automatically known to the compiler. Structure descriptions (but not full object descriptions) may be used directly as @I(types) in function definitions. The user may declare object descriptions to the system using the function GLISPOBJECTS; the names of the object types may then be used as @I[ types ] in function definitions and definitions of other structures. Object descriptions may be included as part of a knowledge representation language, and are then furnished to GLISP by the interface package written for that representation language. @End(Enumerate) LISP data structures are declared using the function GLISPOBJECTS@Foot{ Once declared, object descriptions may be included in INTERLISP program files by including in the <file>COMS a statement of the form: @PE[(GLISPOBJECTS@ <object-name@-(1)>@ ...@ <object-name@-(n)>)]}, which takes one or more object descriptions as arguments (assuming the descriptions to be quoted). Since GLISP compilation is performed relative to the knowledge base of object descriptions, the object descriptions must be declared prior to GLISP compilation of functions using those descriptions. The format of each description is as follows: @Begin(ProgramExample) (<object name> <structure description> PROP <property descriptions> ADJ <adjective descriptions> ISA <predicate descriptions> MSG <message descriptions> SUPERS <list of superclasses> VALUES <list of values> ) @End(ProgramExample) The <object name> and <structure description> are required; the other property/value pairs are optional, and may appear in any order. The following example illustrates some of the declarations which might be made to describe the object type @PE(VECTOR). @Begin(ProgramExample) (GLISPOBJECTS (VECTOR (CONS (X NUMBER) (Y NUMBER)) PROP ( (MAGNITUDE ((SQRT X*X + Y*Y))) ) ADJ ( (ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0)) ) MSG ( (+ VECTORPLUS OPEN T) (- VECTORDIFFERENCE) ) )) @End(ProgramExample) @Subsection(Property Descriptions) Each @PE[<description>] specified with PROP, ADJ, ISA, or MSG has the following format: @Begin(ProgramExample) (<name> <response> <prop@-[1]> <value@-[1]> ... <prop@-[n]> <value@-[n]>) @END(ProgramExample) where @PE[<name>] is the (atomic) name of the property, @PE[<response>] is a function name or a list of GLISP code to be compiled in place of the property, and the @PE[<prop>@ <value>] pairs are optional properties which affect compilation. All four kinds of properties are compiled in a similar fashion, as described in the section "Compilation of Messages". @Subsection(Supers Description) The SUPERS list specifies a list of @I[ superclasses ], i.e., the names of other object descriptions from which the object may inherit PROP, ADJ, ISA, and MSG properties. Inheritance from superclasses can be recursive, as described under "Compilation of Messages". @Subsection(Values Description) The VALUES list is a list of pairs, @PE[ (<name> <value>) ], which is used to associate symbolic names with constant values for an object type. If VALUES are defined for the type of the @I[ selector ] of a CASE statement, the corresponding symbolic names may be used as the selection values for the clauses of the CASE statement. @Section(Structure Descriptions) Much of the power of GLISP is derived from its use of Structure Descriptions. A Structure Description (abbreviated "<sd>") is a means of describing a LISP data structure and giving names to parts of the structure; it is similar in concept to a Record declaration in PASCAL. Structure descriptions are used by the GLISP compiler to generate code to retrieve and store parts of structures. @Subsection(Syntax of Structure Descriptions) The syntax of structure descriptions is recursively defined in terms of basic types and composite types which are built up from basic types. The syntax of structure descriptions is as follows: @Foot[The names of the basic types and the structuring operators must be all upper-case or lower-case, depending on the case which is usual for the underlying Lisp system. In general, other GLISP keywords and user program names may be in upper-case, lower-case, or mixed-case, if mixed cases are permitted by the Lisp system.] @Begin(Enumerate) The following basic types are known to the compiler: @Begin(Format) @Tabdivide(3) @B(ATOM) @B(INTEGER) @B(REAL) @B(NUMBER)@\(either INTEGER or REAL) @B(STRING) @B(BOOLEAN)@\(either T or NIL) @B(ANYTHING)@\(an arbitrary structure) @End(Format) An object type which is known to the compiler, either from a GLISPOBJECTS declaration or because it is a Class of units in the user's knowledge representation language, is a valid type for use in a structure description. The <name>@ of such an object type may be specified directly as <name> or, for readability, as @ @B[(A]@ <name>@B[)]@ or @ @B[(AN]@ <name>@B[)]. @Foot[Whenever the form @B<(A ...)> is allowed in GLISP, the form @B<(AN ...)> is also allowed.]@ Any substructure can be named by enclosing it in a list prefixed by the name: @ @B[(]<name>@ @ <sd>@B[)]@ . This allows the same substructure to have multiple names. "A", "AN", and the names used in forming composite types (given below) are treated as reserved words, and may not be used as names. Composite Structures:@ Structured data types composed of other structures are described using the following structuring operators: @Begin(Enumerate) (@B[CONS]@ @ <sd@-[1]>@ @ <sd@-[2]>) @* The CONS of two structures whose descriptions are <sd@-[1]> and <sd@-[2]>. (@B[LIST]@ @ <sd@-[1]>@ @ <sd@-[2]>@ @ ...@ @ <sd@-[n]>) @* A list of exactly the elements whose descriptions are <sd@-[1]>@ <sd@-[2]>@ ...@ <sd@-[n]>. (@B[LISTOF]@ @ <sd>) @* A list of zero or more elements, each of which has the description <sd>. (@B[ALIST]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @* An association list in which the atom <name@-[i]>, if present, is associated with a structure whose description is <sd@-[i]>. (@B[PROPLIST]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @* An association list in "property-list format" (alternating names and values) in which the atom <name@-[i]>, if present, is associated with a structure whose description is <sd@-[i]>. (@B[ATOM]@ @ @ (@B[BINDING]@ @ <sd>) @ @ @ @ (@B[PROPLIST]@ @ (<pname@-[1]>@ <sd@-[1]>)@ ...@ @~ (<pname@-[n]>@ <sd@-[n]>)@ )) @* This describes an atom with its binding and/or its property list; either the BINDING or the PROPLIST group may be omitted. Each property name <pname@-[i]> is treated as a property list indicator as well as the name of the substructure. When creation of such a structure is specified, GLISP will compile code to create a GENSYM atom. (@B[RECORD]@ @ <recordname>@ @ (<name@-[1]>@ <sd@-[1]>)@ @ ...@ @ (<name@-[n]>@ <sd@-[n]>)) @* RECORD specifies the use of contiguous records for data storage. <recordname> is the name of the record type; it is optional, and is not used in some Lisp dialects.@Foot[RECORDs are implemented using RECORDs in Interlisp, HUNKs in Maclisp and Franz Lisp, VECTORs in Portable Standard Lisp, and lists in UCI Lisp and ELISP. In Interlisp, appropriate RECORD declarations must be made to the system by the user in addition to the GLISP declarations.] (@B[TRANSPARENT]@ @ <type>) @* An object of type <type> is incorporated into the structure being defined in @I[transparent mode], which means that all fields and properties of the object of type <type> can be directly referenced as if they were properties of the object being defined. A substructure which is a named @I[ type ] and which is not declared to be TRANSPARENT is assumed to be opaque, i.e., its internal structure cannot be seen unless an access path explicitly names the subrecord.@Foot{For example, a PROFESSOR record might contain some fields which are unique to professors, plus a pointer to an EMPLOYEE record. If the declaration in the PROFESSOR record were @PE[(EMPREC@ (TRANSPARENT@ EMPLOYEE))], then a field of the employee record, say SALARY, could be referenced directly from a variable P which points to a PROFESSOR record as @PE[ P:SALARY ]; if the declaration were @PE[(EMPREC@ EMPLOYEE)], it would be necessary to say @PE[P:EMPREC:SALARY].} The object of type <type> may also contain TRANSPARENT objects; the graph of TRANSPARENT object references must of course be acyclic. (@B[OBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*(@B[ATOMOBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*(@B[LISTOBJECT]@ @ (<name@-[1]>@ <sd@-[1]>)@ ...@ (<name@-[n]>@ <sd@-[n]>)) @*These declarations describe @I[ Objects ], data structures which can receive messages at runtime. The three types of objects are implemented as records, atoms, or lists, respectively. In each case, the system adds to the object a @PE[CLASS] datum which points to the name of the type of the object. An object declaration may only appear as the top-level declaration of a named object type. @End(Enumerate) @End(Enumerate) @Subsection(Examples of Structure Descriptions) The following examples illustrate the use of Structure Descriptions. @Begin(ProgramExample) (GLISPOBJECTS (CAT (LIST (NAME ATOM) (PROPERTIES (LIST (CONS (SEX ATOM) (WEIGHT INTEGER)) (AGE INTEGER) (COLOR ATOM))) (LIKESCATNIP BOOLEAN))) (PERSON (ATOM (PROPLIST (CHILDREN (LISTOF (A PERSON))) (AGE INTEGER) (PETS (LIST (CATS (LISTOF CAT)) (DOGS (LISTOF (A DOG))) )) ))) ) @End(ProgramExample) The first structure, CAT, is entirely composed of list structure. An CAT structure might look like: @Begin(ProgramExample) (PUFF ((MALE . 10) 5 CALICO) T) @End(ProgramExample) Given a CAT object X, we could ask for its WEIGHT [equivalent to (CDAADR X)] or for a subrecord such as PROPERTIES [equivalent to (CADR X)]. Having set a variable Y to the PROPERTIES, we could also ask for the WEIGHT from Y [equivalent to (CDAR Y)]. In general, whenever a subrecord is accessed, the structure description of the subrecord is associated with it by the compiler, enabling further accesses to parts of the subrecord. Thus, the meaning of a subrecord name depends on the type of record from which the subrecord is retrieved. The subrecord AGE has two different meanings when applied to PERSONs and CATs. The second structure, PERSON, illustrates a description of an object which is a Lisp atom with properties stored on its property list. Whereas no structure names appear in an actual CAT structure, the substructures of a PROPLIST operator must be named, and the names appear in the actual structures. For example, if X is a PERSON structure, retrieval of the AGE of X is equivalent to @PE[(GETPROP@ X@ 'AGE)]. A subrecord of a PROPLIST record can be referenced directly; e.g., one can ask for the DOGS of a PERSON directly, without cognizance of the fact that DOGS is part of the PETS property. @Section(Editing of Object Descriptions) An object description can be edited by calling @PE[ (GLEDS TYPE) ], where @PE[ TYPE ] is the name of the object type. This will cause the Lisp editor to be called on the object description of @PE[ TYPE ]. @Section(Interactive Editing of Objects) An interactive structure inspector/editor, GEV, is available for the Xerox 1100-series lisp machines. GEV allows the user to inspect and edit any structures which are described by GLISP object descriptions, to "zoom in" on substructures of interest, and to display the values of computed properties automatically or on demand. GEV is described in a separate document. @Section(Global Variables) The types of free variables can be declared within the functions which reference them. Alternatively, the types of global variables can be declared to the compiler using the form:@Foot[@PE{(GLISPGLOBALS@ <name@-(1)>@ ...@ <name@-(n)>)} is defined as a file package command for Interlisp.] @Begin(ProgramExample) (GLISPGLOBALS (<name> <type>) ... ) @End(ProgramExample) Following such a declaration, the compiler will assume a free variable <name> is of the corresponding <type>. A GLOBAL object does not have to actually exist as a storage structure; for example, one could define a global object "MOUSE" or "SYSTEM" whose properties are actually implemented by calls to the operating system. @Section(Compile-Time Constants and Conditional Compilation) The values and types of compile-time constants can be declared to the compiler using the form:@Foot[@PE{(GLISPCONSTANTS@ <name@-(1)>@ ...@ <name@-(n)>)} is defined as a file package command for Interlisp.] @Programexample[ (GLISPCONSTANTS (<name> <value-expression> <type>) ... ) ] The <name> and <type> fields are assumed to be quoted. The @PE[ <value-expression> ] field is a GLISP expression which is parsed and evaluated; this allows constants to be defined by expressions involving previously defined constants. The GLISP compiler will perform many kinds of computations on constants at compile time, reducing the size of the compiled code and improving execution speed.@Foot[Ordinary Lisp functions are evaluated on constant arguments if the property @PE(GLEVALWHENCONST) is set to T on the property list of the function name. This property is set by the compiler for the basic arithmetic functions.] In particular, arithmetic, comparison, logical, conditional, and CASE function calls are optimized, with elimination of dead code. This permits conditional compilation in a clean form. Code can be written which tests the values of flags in the usual way; if the flag values are then declared to be compile-time constants using GLISPCONSTANTS, the tests will be performed at compile time, and the unneeded code will vanish. @Chapter(Reference To Objects) @Section(Accessing Objects) The problem of reference is the problem of determining what object, or feature of a structured object, is referred to by some part of a statement in a language. Most programming languages solve the problem of reference by unique naming: each distinct object in a program unit has a unique name, and is referenced by that name. Reference to a part of a structured object is done by giving the name of the variable denoting that object and a path specification which tells how to get to the desired part from the whole. GLISP permits reference by unique naming and path specification, but in addition permits @I[definite reference relative to context.] A @I[definite reference] is a reference to an object which has not been explicitly named before, but which can be understood relative to the current context of computation. If, for example, an object of type VECTOR (as defined earlier) is in context, the program statement @Begin(ProgramExample) (IF X IS NEGATIVE ... @End(ProgramExample) contains a definite reference to "X", which may be interpreted as the X substructure of the VECTOR which is in context. The definition of the computational context and the way in which definite references are resolved are covered in a later section of this manual. In the following section, which describes the syntaxes of reference to objects in GLISP, the following notation is used. "<var>" refers to a variable name in the usual LISP sense, i.e., a LAMBDA variable, PROG variable, or GLOBAL variable; the variable is assumed to point to (be bound to) an object. "<type>" refers to the type of object pointed to by a variable. "<property>" refers to a property or subrecord of an object. Two syntaxes are available for reference to objects: an English-like syntax, and a PASCAL-like syntax. The two are equivalent, and may be intermixed freely within a GLISP function. The allowable forms of references in the two syntaxes are shown in the table below. @Begin(Format) @TabDivide(3) @U("PASCAL" Syntax)@\@U("English" Syntax)@\@U(Meaning) <var>@\<var>@\The object denoted @\@\by <var> @B[:]<type>@\@B[The] <type>@\The object whose type @\@\is <type> @B[:]<property>@\@B[The] <property>@\The <property> of @I[or] <property>@\@\some object <var>@B[:]<property>@\@B[The] <property> @B[of] <var>@\The <property> of the @\@\object denoted by <var> @End(Format) These forms can be extended to specify longer paths in the obvious way, as in "The AGE of the SPOUSE of the HEAD of the DEPARTMENT" or "DEPARTMENT:HEAD:SPOUSE:AGE". Note that there is no distinction between reference to substructures and reference to properties as far as the syntax of the referencing code is concerned; this facilitates hiding the internal structures of objects. @Section(Creation of Objects) GLISP allows the creation of structures to be specified by expressions of the form: @BlankSpace(1) @B[(A] <type> @P[with] <property@-[1]> @P[=] <value@-[1]> @P[,] ... @P[,] @~ <property@-[n]> @P[=] <value@-[n]>@B[)] @BlankSpace(1) In this expression, the "@I[with]", "=", and "," are allowed for readability, but may be omitted if desired@Foot[Some Lisp dialects, e.g. Maclisp, will interpret commas as "backquote" commands and generate error messages. In such dialects, the commas must be omitted or be "slashified".]; if present, they must all be delimited on both sides by blanks. In response to such an expression, GLISP will generate code to create a new instance of the specified structure. The <property> names may be specified in any order. Unspecified properties are defaulted according to the following rules: @Begin(Enumerate) Basic types are defaulted to 0 for INTEGER and NUMBER, 0.0 for REAL, and NIL for other types. Composite structures are created from the defaults of their components, except that missing PROPLIST and ALIST items which would default to NIL are omitted. @End(Enumerate) Except for missing PROPLIST and ALIST elements, as noted above, a newly created LISP structure will contain all of the fields specified in its structure description. @Section(Interpretive Creation of Objects) The "A" function is defined for interpretive use as well as for use within GLISP functions. @Section(Predicates on Objects) Adjectives defined for structures using the @PE[ADJ] and @PE[ISA] specifications may be used in predicate expressions on objects in @B[If] and @B[For] statements. The syntax of basic predicate expressions is: @Begin(ProgramExample) <object> @b[is] <adjective> <object> @B[is a] <isa-adjective> @End(ProgramExample) Basic predicate expressions may be combined using AND, OR, NOT or ~, and grouping parentheses. The compiler automatically recognizes the LISP adjectives ATOMIC, NULL, NIL, INTEGER, REAL, ZERO, NUMERIC, NEGATIVE, MINUS, and BOUND, and the ISA-adjectives ATOM, LIST, NUMBER, INTEGER, SYMBOL, STRING, ARRAY, and BIGNUM@Foot[where applicable.]; user definitions have precedence over these pre-defined adjectives. @Subsection(Self-Recognition Adjectives) If the ISA-adjective @PE[ self ] is defined for an object type, the type name may be used as an ISA-adjective to test whether a given object is a member of that type. Given a predicate phrase of the form "@PE[@ X@ is@ a@ Y@ ]", the compiler first looks at the definition of the object type of @PE[ X ] to see if @PE[ Y ] is defined as an ISA-adjective for such objects. If no such ISA-adjective is found, and @PE[ Y ] is a type name, the compiler looks to see if @PE[ self ] is defined as an ISA-adjective for @PE[ Y ], and if so, compiles it. If a @PE[ self ] ISA-adjective predicate is compiled as the test of an @B[If], @B[While], or @B[For] statement, and the tested object is a simple variable, the variable will be known to be of that type within the scope of the test. For example, in the statement @Begin(ProgramExample) (If X is a FOO then (_ X Print) ... @End(ProgramExample) the compiler will know that X is a FOO if the test succeeds, and will compile the Print message appropriate for a FOO, even if the type of X was declared as something other than FOO earlier. This feature is useful in implementing disjunctive types, as discussed in a later section. @Subsection(Testing Object Classes) For those data types which are defined using one of the OBJECT structuring operators, the Class name is automatically defined as an ISA-adjective. The ISA test is implemented by runtime examination of the CLASS datum of the object. @Chapter(GLISP Program Syntax) @Section(Function Syntax) GLISP function syntax is essentially the same as that of LISP with the addition of type information and RESULT and GLOBAL declarations. The basic function syntax is: @Foot[The PROG is not required. In Lisp dialects other than Interlisp, LAMBDA may be used instead of GLAMBDA.] @Begin(ProgramExample) (<function-name> (@B[GLAMBDA] (<arguments>) @P[(RESULT] <result-description>@P[)] @P[(GLOBAL] <global-variable-descriptions>@P[)] (PROG (<prog-variables>) <code> ))) @End(ProgramExample) The RESULT declaration is optional; in many cases, the compiler will infer the result type automatically. The main use of the RESULT declaration is to allow the compiler to determine the result type without compiling the function, which may be useful when compiling another function which calls it. The <result-description> is a standard structure description or <type>. The GLOBAL declaration is used to inform the compiler of the types of free variables. The function GLISPGLOBALS can be used to declare the types of global variables, making GLOBAL declarations within individual functions unnecessary. The major difference between a GLISP function definition and a standard LISP definition is the presence of type declarations for variables, which are in PASCAL-like syntax of the following forms: @Begin(ProgramExample) <variable>@B[:]<type> <variable>@B[:(A] <type>@B[)] <variable>@B[,]<variable>@B[,]...@B[:]<type> <variable>@B[,]<variable>@B[,]...@B[:(A] <type>@B[)] @B[:]<type> @B[(A] <type>@B[)] @End(ProgramExample) In addition to declared <type>s, a Structure Description may be used directly as a <type> in a variable declaration. Type declarations are required only for variables whose subrecords or properties will be referenced. In general, if the value of a variable is computed in such a way that the type of the value can be inferred, the variable will receive the appropriate type automatically; in such cases, no type declaration is necessary. Since GLISP maintains a @I[context] of the computation, it is often unnecessary to name a variable which is an argument of a function; in such cases, it is only necessary to specify the <type> of the argument, as shown in the latter two syntax forms above. PROG and GLOBAL declarations must always specify variable names (with optional types); the ability to directly reference features of objects reduces the number of PROG variables needed in many cases. Initial values for PROG variables may be specified, as in Interlisp, by enclosing the variable and its initial value in a list@Foot[This feature is available in all Lisp dialects.]: @ProgramExample{ (PROG (X (N 0) Y) ...) } However, the syntax of variable declarations does not permit the type of a variable and its initial value to both be specified. @Section(Expressions) GLISP provides translation of infix expressions of the kind usually found in programming languages. In addition, it provides additional operators which facilitate list manipulation and other operations. Overloading of operators for user-defined types is provided by means of the @I[message] facility. Expressions may be written directly in-line within function references, as in @PE[ (SQRT X*X + Y*Y) ], or they may be written within parentheses; parentheses may be used for grouping in the usual way. Operators may be written with or without delimiting spaces, @I[except for the "-" operator, which @P(must) be delimited by spaces]. @Foot[The "-" operator is required to be delimited by spaces since "-" is often used as a hyphen within variable names. The "-" operator will be recognized within "atom" names if the flag GLSEPMINUS is set to T.] Expression parsing is done by an operator precedence parser, using the same precedence ordering as in FORTRAN. @Foot[The precedence of compound operators is higher than assignment but lower than that of all other operators. The operators @PE[^ _ _+ +_ _- -_] are right-associative; all others are left-associative.] The operators which are recognized are as follows:@Foot<In Maclisp, the operator @PE[/] must be written @PE[//].> @Begin(Format) @TabDivide(3) Assignment@\@PE(_) @I[ or ] @PE[:=] Arithmetic@\@PE[+ - * / ^] Comparison@\@PE[= @R<~>= <> < <= > >=] Logical@\@PE[AND OR NOT @R<~>] Compound@\@PE(_+ _- +_ -_) @End(Format) @Subsection(Interpretation of Operators) In addition to the usual interpretation of operators when used with numeric arguments, some of the operators are interpreted appropriately for other Lisp types. @Paragraph(Operations on Strings) For operands of type STRING, the operator @PE[ + ] performs concatenation. All of the comparison operators are defined for STRINGs. @Paragraph(Operations on Lists) Several operators are defined in such a way that they perform set operations on lists of the form @PE[ (LISTOF@ <type>) ], where @PE[ <type> ] is considered to be the element type. The following table shows the interpretations of the operators: @Begin(Format) @Tabdivide(3) @PE[<list> + <list>]@\Set Union @PE[<list> - <list>]@\Set Difference @PE[<list> * <list>]@\Set Intersection @PE[<list> + <element>]@\CONS @PE[<element> + <list>]@\CONS @PE[<list> - <element>]@\REMOVE @PE[<element> <= <list>]@\MEMBER or MEMB @PE[<list> >= <element>]@\MEMBER or MEMB @End(Format) @Paragraph(Compound Operators) Each compound operator performs an operation involving the arguments of the operator and assigns a value to the left-hand argument; compound operators are therefore thought of as "destructive change" operators. The meaning of a compound operator depends on the type of its left-hand argument, as shown in the following table: @Begin(Group) @Begin(Format) @TabDivide(5) @U(Operator)@\@U(Mnemonic)@\@U(NUMBER)@\@U(LISTOF)@\@U(BOOLEAN) @B[@PE(_+)]@\@I(Accumulate)@\PLUS@\NCONC1@\OR @B[@PE(_-)]@\@I(Remove)@\DIFFERENCE@\REMOVE@\AND NOT @B[@PE(+_)]@\@I(Push)@\PLUS@\PUSH@\OR @B[@PE(-_)]@\@I(Pop)@\@\POP@Foot[For the Pop operator, the arguments are in the reverse of the usual order, i.e., (TOP@ @PE(-_)@ STACK) will pop the top element off STACK and assign the element removed to TOP.] @End(Format) @End(Group) As an aid in remembering the list operators, the arrow may be thought of as representing the list, with the head of the arrow being the front of the list and the operation (+ or -) appearing where the operation occurs on the list. Thus, for example, @PE(_+) adds an element at the end of the list, while @PE(+_) adds an element at the front of the list. Each of the compound operators performs an assignment to its left-hand side; the above table shows an abbreviation of the operation which is performed prior to the assignment. The following examples show the effects of the operator "@PE(_+)" on local variables of different types: @Begin(Format) @TabDivide(3) @U(Type)@\@U(Source Code)@\@U(Compiled Code) INTEGER@\@PE(I _+ 5)@\@PE[(SETQ I (IPLUS I 5))] BOOLEAN@\@PE(P _+ Q)@\@PE[(SETQ P (OR P Q))] LISTOF@\@PE(L _+ ITEM)@\@PE[(SETQ L (NCONC1 L ITEM))] @END(Format) When the compound operators are not specifically defined for a type, they are interpreted as specifying the operation (@PE[+] or @PE[-]) on the two operands, followed by assignment of the result to the left-hand operand. @Paragraph(Assignment) Assignment of a value to the left-hand argument of an assignment operator is relatively flexible in GLISP. The following kinds of operands are allowed on the left-hand side of an assignment operator: @Begin(Enumerate) Variables. Stored substructures of a structured type. PROPerties of a structured type, whenever the interpretation of the PROPerty would be a legal left-hand side. Algebraic expressions involving numeric types, @I[ provided ] that the expression ultimately involves only one occurrence of a variable or stored value.@Foot{For example, @PE[(X^2 _ 2.0)] is acceptable, but @PE[(X*X@ _@ 2.0)] is not because the variable @PE[X] occurs twice.} @End(Enumerate) For example, consider the following Object Description for a CIRCLE: @ProgramExample{ (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) (AREA (PI*RADIUS^2))) ) } Given this description, and a CIRCLE @PE[ C ], the following are legal assignments: @Programexample{ (C:RADIUS _ 5.0) (C:AREA _ 100.0) (C:AREA _ C:AREA*2) (C:AREA _+ 100.0) } @Paragraph(Self-Assignment Operators @Foot[This section may be skipped by the casual user of GLISP.]) There are some cases where it would be desirable to let an object perform an assignment of its own value. For example, the user might want to define @I[PropertyList] as an abstract datatype, with messages such as GETPROP and PUTPROP, and use PropertyLists as substructures of other datatypes. However, a message such as PUTPROP may cause the PropertyList object to modify its own structure, perhaps even changing its structure from NIL to a non-NIL value. If the function which implements PUTPROP performs a normal assignment to its "self" variable, the assignment will affect only the local variable, and will not modify the PropertyList component of the containing structure. The purpose of the Self-Assignment Operators is to allow such modification of the value within the containing structure. The Self-Assignment Operators are @PE[__], @PE[__+], @PE[_+_], and @PE[__-], corresponding to the operators @PE[_], @PE[_+], @PE[+_], and @PE[_-], respectively. The meaning of these operators is that the assignment is performed to the object on the left-hand side of the operator, @I[as seen from the structure containing the object]. The use of these operators is highly restricted; any use of a Self-Assignment Operator must meet all of the following conditions: @Begin(Enumerate) A Self-Assignment Operator can only be used within a Message function which is compiled OPEN. The left-hand side of the assignment must be a simple variable which is an argument of the function. The left-hand-side variable must be given a unique (unusual) name to prevent accidental aliasing with a user variable name. @End(Enumerate) As an example, the PUTPROP message for a PropertyList datatype could be implemented as follows: @Begin(ProgramExample) (PropertyList.PUTPROP (GLAMBDA (PropertyListPUTPROPself prop val) (PropertyListPUTPROPself __ (LISTPUT PropertyListPUTPROPself prop val)) )) @End(ProgramExample) @Section(Control Statements) GLISP provides several PASCAL-like control statements. @Subsection(IF Statement) The syntax of the IF statement is as follows: @Begin(ProgramExample) (@B[IF] <condition@-[1]> @P[THEN] <action@-[11]>@ ...@ <action@-[1i]> @P[ELSEIF] <condition@-[2]> @P[THEN] <action@-[21]>@ ...@ <action@-[2j]> ... @P[ELSE] <action@-[m1]>@ ...@ <action@-[mk]>) @End(ProgramExample) Such a statement is translated to a COND of the obvious form. The "THEN" keyword is optional, as are the "ELSEIF" and "ELSE" clauses. @Subsection(CASE Statement) The CASE statement selects a set of actions based on an atomic selector value; its syntax is: @Begin(ProgramExample) (@B[CASE] <selector> @B[OF] (<case@-[1]> <action@-[11]>@ ...@ <action@-[1i]>) (<case@-[2]> <action@-[21]>@ ...@ <action@-[2j]>) ... @P[ELSE] <action@-[m1]>@ ...@ <action@-[mk]>) @End(ProgramExample) The @PE[<selector>] is evaluated, and is compared with the given @PE[<case>] specifications. Each @PE[<case>] specification is either a single, atomic specification, or a list of atomic specifications. All @PE[<case>] specifications are assumed to be quoted. The "ELSE" clause is optional; the "ELSE" actions are executed if @PE[<selector>] does not match any @PE[<case>]. If the @I[ type ] of the @PE[<selector>] has a VALUES specification, @PE[<case>] specifications which match the VALUES for that type will be translated into the corresponding values. @Subsection(FOR Statement) The FOR statement generates a loop through a set of elements (typically a list). Two syntaxes of the FOR statement are provided: @Begin(ProgramExample) (@B[FOR EACH] <set> @P[DO] <action@-[1]>@ ...@ <action@-[n]>) (@B[FOR] <variable> @B[IN] <set> @P[DO] <action@-[1]>@ ...@ <action@-[n]>) @End(ProgramExample) The keyword "DO" is optional. In the first form of the FOR statement, the singular form of the <set> is specified; GLISP will convert the given set name to the plural form. @Foot[For names with irregular plurals, the plural form should be put on the property list of the singular form under the property name PLURAL, e.g., @PE<(PUTPROP 'MAN 'PLURAL 'MEN)>.] The <set> may be qualified by an adjective or predicate phrase in the first form; the allowable syntaxes for such qualifying phrases are shown below: @Begin(ProgramExample) <set> @B[WITH] <predicate> <set> @B[WHICH IS] <adjective> <set> @B[WHO IS] <adjective> <set> @B[THAT IS] <adjective> @End(ProgramExample) The <predicate> and <adjective> phrases may be combined with AND, OR, NOT, and grouping parentheses. These phrases may be followed by a qualifying phrase of the form: @Begin(ProgramExample) @B[WHEN] <expression> @End(ProgramExample) The "WHEN" expression is ANDed with the other qualifying expressions to determine when the loop body will be executed. Within the FOR loop, the current member of the <set> which is being examined is automatically put into @I[context] at the highest level of priority. For example, suppose that the current context contains a substructure whose description is: @Begin(ProgramExample) (PLUMBERS (LISTOF EMPLOYEE)) @END(ProgramExample) Assuming that EMPLOYEE contains the appropriate definitions, the following FOR loop could be written: @Begin(ProgramExample) (FOR EACH PLUMBER WHO IS NOT A TRAINEE DO SALARY _+ 1.50) @End(ProgramExample) To simplify the collection of features of a group of objects, the <action>s in the FOR loop may be replaced by the CLISP-like construct: @Begin(ProgramExample) ... @B[COLLECT] <form>) @End(ProgramExample) @Subsection(WHILE Statement) The format of the WHILE statement is as follows: @Begin(ProgramExample) (@B[WHILE] <condition> @B[DO] <action@-[1]> ... <action@-[n]>) @End(ProgramExample) The actions @PE(<action@-[1]>) through @PE(<action@-[n]>) are executed repeatedly as long as @PE(<condition>) is true. The keyword @B[DO] may be omitted. The value of the expression is NIL. @Subsection(REPEAT Statement) The format of the REPEAT statement is as follows: @Begin(ProgramExample) (@B[REPEAT] <action@-[1]> ... <action@-[n]> @B[UNTIL] <condition>) @End(ProgramExample) The actions @PE(<action@-[1]>) through @PE(<action@-[n]>) are repeated (always at least once) until @PE[<condition>] is true. The value of the expression is NIL. The keyword @B[UNTIL] is required. @Section(Definite Reference to Particular Objects) In order to simplify reference to particular member(s) of a group, definite reference may be used. Such an expression is written using the word @B[THE] followed by the singular form of the group, or @B[THOSE] followed by the plural form of the group, and qualifying phrases (as described for the @B[FOR] statement). The following examples illustrate these expressions. @Begin(ProgramExample) (THE SLOT WITH SLOTNAME = NAME) (THOSE EMPLOYEES WITH JOBTITLE = 'ELECTRICIAN) @End(ProgramExample) The value of @B[THE] is a single object (or NIL if no object satisfies the specified conditions); @B[THOSE] produces a list of all objects satisfying the conditions.@Foot[In general, nested loops are optimized so that intermediate lists are not actually constructed. Therefore, use of nested THE or THOSE statements is not inefficient.] @Chapter(Messages) GLISP supports the @I[Message] metaphor, which has its roots in the languages SIMULA and SMALLTALK. These languages provide @I[Object-Centered Programming], in which objects are thought of as being active entities which communicate by sending each other @I[Messages]. The internal structures of objects are hidden; a program which wishes to access "variables" of an object does so by sending messages to the object requesting the access desired. Each object contains @Foot[typically by inheritance from some parent in a Class hierarchy] a list of @I[Selectors], which identify the messages to which the object can respond. A @I[Message] specifies the destination object, the selector, and any arguments associated with the message. When a message is executed at runtime, the selector is looked up for the destination object; associated with the selector is a procedure, which is executed with the destination object and message arguments as its arguments. GLISP treats reference to properties, adjectives, and predicates associated with an object similarly to the way it treats messages. The compiler is able to perform much of the lookup of @I[selectors] at compile time, resulting in efficient code while maintaining the flexibility of the message metaphor. Messages can be defined in such a way that they compile open, compile as function calls to the function which is associated with the selector, or compile as messages to be interpreted at runtime. Sending of a @I[message] in GLISP is specified using the following syntax: @Begin(ProgramExample) @B[(SEND] <object> <selector> <arg@-[1]>@ ...@ <arg@-[n]>@B[)] @End(ProgramExample) The keyword "SEND" may be replaced by "@B[@PE(_)]". The @PE[<selector>] is assumed to be quoted. Zero or more arguments may be specified; the arguments other than @PE[<selector>] are evaluated. @PE[<object>] is evaluated; if @PE[<object>] is a non-atomic expression, it must be enclosed in at least one set of parantheses, so that the @PE[<selector>] will always be the third element of the list. @SECTION(Compilation of Messages) When GLISP encounters a message statement, it looks up the <selector> in the MSG definition of the type of the object to which the message is sent, or in one of the SUPERS of the type. @Foot[If an appropriate representation language is provided, the <selector> and its associated <response> may be inherited from a parent class in the class hierarchy of the representation language.] Each <selector> is paired with the appropriate <response> to the message. Code is compiled depending on the form of the <response> associated with the <selector>, as follows: @Foot[If the type of the destination object is unknown, or if the <selector> cannot be found, GLISP compiles the (SEND@ ...) statement as if it is a normal function call.] @Begin(Enumerate) If the <response> is an atom, that atom is taken as the name of a function which is to be called in response to the message. The code which is compiled is a direct call to this function, @Begin(ProgramExample) (<response> <object> <arg@-[1]> ... <arg@-[n]>) @End(ProgramExample) If the <response> is a list, the contents of the list are recursively compiled in-line as GLISP code, with the name "@PE[self]" artificially "bound" to the <object> to which the message was sent. Because the compilation is recursive, a message may be defined in terms of other messages, substructures, or properties, which may themselves be defined as messages. @Foot[Such recursive definitions must of course be acyclic.] The outer pair of parentheses of the <response> serves only to bound its contents; thus, if the <response> is a function call, the function call must be enclosed in an additional set of parentheses. @End(Enumerate) The following examples illustrate the various ways of defining message responses. @Begin(ProgramExample) (EDIT EDITV) (SUCCESSOR (self + 1)) (MAGNITUDE ((SQRT X*X + Y*Y))) @End(ProgramExample) In the first example, a message with <selector> EDIT is compiled as a direct call to the function EDITV. In the second example, the SUCCESSOR message is compiled as the sum of the object receiving the message (represented by "@PE[self]") and the constant 1; if the object receiving the message is the value of the variable J and has the type INTEGER, the code generated for the SUCCESSOR would be @PE[(ADD1 J)]. The third example illustrates a call to a function, SQRT, with arguments containing definite references to X and Y (which presumably are defined as part of the object whose MAGNITUDE is sought). Note that since MAGNITUDE is defined by a function call, an "extra" pair of parentheses is required around the function call to distinguish it from in-line code. The user can determine whether a message is to be compiled open, compiled as a function call, or compiled as a message which is to be executed at runtime. When a GLISP expression is specified as a <response>, the <response> is always compiled open; open compilation can be requested by using the OPEN property when the <response> is a function name. Open compilation operates like macro expansion; since the "macro" is a GLISP expression, it is easy to define messages and properties in terms of other messages and properties. The combined capabilities of open compilation, message inheritance, conditional compilation, and flexible assignment provide a great deal of power. The ability to use definite reference in GLISP makes the definition and use of the "macros" simple and natural. @Section(Compilation of Properties and Adjectives) Properties, Adjectives, and ISA-adjectives are compiled in the same way as Messages. Since the syntax of use of properties and adjectives does not permit specification of any arguments, the only argument available to code or a function which implements the @PE[<response>] for a property or adjective is the @PE[ self ] argument, which denotes the object to which the property or adjective applies. A @PE[<response>] which is written directly as GLISP code may use the name @PE[ self ] directly @Foot[The name @PE< self > is "declared" by the compiler, and does not have to be specified in the Structure Description.], as in the SUCCESSOR example above; a function which is specified as the @PE[<response>] will be called with the @PE[self] object as its single argument. @Section(Declarations for Message Compilation) Declarations which affect compilation of Messages, Adjectives, or Properties may be specified following the <response> for a given message; such declarations are in (Interlisp) property-list format, @PE[<prop@-[1]><value@-[1]>@ ...@ <prop@-[n]><value@-[n]>]. The following declarations may be specified: @Begin(Enumerate) @B[RESULT]@PE[ <type>] @* This declaration specifies the @I[type] of the result of the message or other property. Specification of result types helps the compiler to perform type inference, thus reducing the number of type declarations needed in user programs. The RESULT type for simple GLISP expressions will be inferred by the compiler; the RESULT declaration should be used if the @PE[<response>] is a complex GLISP expression or a function name. @Foot[Alternatively, the result of a function may be specified by the RESULT declaration within the function itself.]@ @B[OPEN@ @ T] @* This declaration specifies that the function which is specified as the <response> is to be compiled open at each reference. A <response> which is a list of GLISP code is always compiled open; however, such a <response> can have only the @PE[self] argument. If it is desired to compile open a Message <response> which has arguments besides @PE[self], the <response> must be coded as a function (in order to bind the arguments) and the OPEN declaration must be used. Functions which are compiled open may not be recursive via any chain of open-compiled functions. @B[MESSAGE@ @ T] @* This declaration specifies that a runtime message should be generated for messages with this <selector> sent to objects of this Class. Typically, such a declaration would be used in a higher-level Class whose subclasses have different responses to the same message <selector>. @End(Enumerate) @Section(Operator Overloading) GLISP provides operator overloading for user-defined objects using the Message facility. If an arithmetic operator is defined as the @I[selector] of a message for a user datatype, an arithmetic subexpression using that operator will be compiled as if it were a message call with two arguments. For example, the type VECTOR might have the declaration and function definitions below: @Begin(ProgramExample) (GLISPOBJECTS (VECTOR (CONS (X INTEGER) (Y INTEGER)) MSG ((+ VECTORPLUS OPEN T) (_+ VECTORINCR OPEN T)) ) ) (DEFINEQ (VECTORPLUS (GLAMBDA (U,V:VECTOR) (A VECTOR WITH X = U:X + V:X , Y = U:Y + V:Y) )) (VECTORINCR (GLAMBDA (U,V:VECTOR) (U:X _+ V:X) (U:Y _+ V:Y) )) ) @End(ProgramExample) With these definitions, an expression involving the operators @PE[+] or @PE[_+] will be compiled by open compilation of the respective functions. The compound operators (@PE[_+ +_ _- -_]) are conventionally thought of as "destructive replacement" operators; thus, the expression @PE[(U@ _@ U@ +@ V)] will create a new VECTOR structure and assign the new structure to U, while the expression @PE[(U@ _+@ V)] will smash the existing structure U, given the definitions above. The convention of letting the compound operators specify "destructive replacement" allows the user to specify both the destructive and non-destructive cases. However, if the compound operators are not overloaded but the arithmetic operators @PE[+] and @PE[-] are overloaded, the compound operators are compiled using the definitions of @PE[+] for @PE[_+] and @PE[+_], and @PE[-] for @PE[_-] and @PE[-_]. Thus, if only the @PE[+] operator were overloaded for VECTOR, the expression @PE[(U@ _+@ V)] would be compiled as if it were @PE[(U@ _@ U@ +@ V)]. @Section(Runtime Interpretation of Messages) In some cases, the type of the object which will receive a given message is not known at compile time; in such cases, the message must be executed interpretively, at runtime. Interpretive execution is provided for all types of GLISP messages. An interpretive message call (i.e., a call to the function @PE[SEND]) is generated by the GLISP compiler in response to a message call in a GLISP program when the specified message selector cannot be found for the declared type of the object receiving the message, or when the MESSAGE flag is set for that selector. Alternatively, a call to SEND may be entered interactively by the user or may be contained in a function which has not been compiled by GLISP. Messages can be interpreted only for those objects which are represented as one of the OBJECT types, since it is necessary that the object contain a pointer to its CLASS. The <selector> of the message is looked up in the MSG declarations of the CLASS; if it is not found there, the SUPERS of the CLASS are examined (depth-first) until the selector is found. The <response> associated with the <selector> is then examined. If the <response> is a function name, that function is simply called with the specified arguments.@Foot{The object to which the message is sent is always inserted as the first argument, followed by the other arguments specified in the message call.} If the <response> is a GLISP expression, the expression is compiled as a LAMBDA form and cached for future use. Interpretive execution is available for other property types (PROP, ADJ, and ISA) using the call: @Programexample[ (SENDPROP <object> <selector> <proptype>) ] where @PE[<proptype>] is PROP, ADJ, or ISA. @PE[<proptype>] is not evaluated. @Chapter(Context Rules and Reference) The ability to use definite reference to features of objects which are in @I[Context] is the key to much of GLISP's power. At the same time, definite reference introduces the possibility of ambiguity, i.e., there could be more than one object in Context which has a feature with a specified name. In this chapter, guidelines are presented for use of definite reference to allow the user to avoid ambiguity. @Section(Organization of Context) The Context maintained by the compiler is organized in levels, each of which may have multiple entries; the sequence of levels is a stack. Searching of the Context proceeds from the top (nearest) level of the stack to the bottom (farthest) level. The bottom level of the stack is composed of the LAMBDA variables of the function being compiled. New levels are added to the Context in the following cases: @Begin(Enumerate) When a PROG is compiled. The PROG variables are added to the new level. When a @B[For] loop is compiled. The "loop index" variable (which may be either a user variable or a compiler variable) is added to the new level, so that it is in context during the loop. When a @B[While] loop is compiled. When a new clause of an @B[If] statement is compiled. @End(Enumerate) When a Message, Property, or Adjective is compiled, that compilation takes place in a @I[ new ] context consisting only of the @PE[ self ] argument and other message arguments. @Section(Rules for Using Definite Reference) The possibility of referential ambiguity is easily controlled in practice. First, it should be noted that the traditional methods of unique naming and complete path specification ("PASCAL style") are available, and should be used whenever there is any possibility of ambiguity. Second, there are several cases which are guaranteed to be unambiguous: @Begin(Enumerate) In compiling GLISP code which implements a Message, Property, or Adjective, only the @PE[@ self@ ] argument is in context initially; definite reference to any substructure or property of the object is therefore unambiguous. @Foot[Unless there are duplicated names in the object definition. However, if the same name is used as both a Property and an Adjective, for example, it is not considered a duplicate since Properties and Adjectives are specified by different source language constructs.]@ Within a @B[For] loop, the loop variable is the closest thing in context. In many cases, a function will only have a single structured argument; in such cases, definite reference is unambiguous. @End(Enumerate) If "PASCAL" syntax (or the equivalent English-like form) is used for references other than the above cases, no ambiguities will occur. @Section(Type Inference) In order to interpret definite references to features of objects, the compiler must know the @I[ types ] of the objects. However, explicit type specification can be burdensome, and makes it difficult to change types without rewriting existing type declarations. The GLISP compiler performs type inference in many cases, relieving the programmer of the burden of specifying types explicitly. The following rules enable the programmer to know when types will be inferred by the compiler. @Begin(Enumerate) Whenever a variable is set to a value whose type is known, the type of the variable is inferred to be the type of the value to which it was set. If a variable whose initial type was NIL (e.g., an untyped PROG variable) appears on the left-hand side of the @PE[@ _+@ ] operator, its type is inferred to be @PE[(LISTOF@ <type>)], where @PE[@ <type>@ ] is the type of the right-hand side of the @PE[@ _+@ ] expression. Whenever a substructure of a structured object is retrieved, the type of the substructure is retrieved also. Types of infix expressions are inferred. Types of Properties, Adjectives, and Messages are inferred if: @Begin(Enumerate) The @PE[ <response> ] is GLISP code whose type can be inferred. The @PE[ <response> ] has a RESULT declaration associated with it. The @PE[ <response> ] is a function whose definition includes a RESULT declaration, or whose property list contains a GLRESULTTYPE declaration. @End(Enumerate) The type of the "loop variable" in a @B[For] loop is inferred and is added to a new level of Context by the compiler. If an @B[If] statement tests the type of a variable using a @PE[@ self@ ] adjective, the variable is inferred to be of that type if the test is satisfied. Similar type inference is performed if the test of the type of the variable is the condition of a @B[While] statement. When possible, GLISP infers the type of the function it is compiling and adds the type of the result to the property list of the function name under the indicator GLRESULTTYPE. The types returned by many standard Lisp functions are known by the compiler. @End(Enumerate) @Chapter(GLISP and Knowledge Representation Languages) GLISP provides a convenient @I[Access Language] which allows uniform specification of access to objects, without regard to the way in which the objects are actually stored; in addition, GLISP provides a basic @I[Representation Language], in which the structures and properties of objects can be declared. The field of Artificial Intelligence has spawned a number of powerful Representation Languages, which provide power in describing large numbers of object classes by allowing hierarchies of @I[Class] descriptions, in which instances of Classes can inherit properties and procedures from parent Classes. The @I[Access Languages] provided for these Representation Languages, however, have typically been rudimentary, often being no more than variations of LISP's GETPROP and PUTPROP. In addition, by performing inheritance of procedures and data values at runtime, these Representation Languages have often been computationally costly. Facilities are provided for interfacing GLISP with representation languages of the user's choice. When this is done, GLISP provides a convenient and uniform language for accessing both objects in the Representation Language and LISP objects. In addition, GLISP can greatly improve the efficiency of programs which access the representations by performing lookup of procedures and data in the Class hierarchy @I[at compile time]. Finally, a LISP structure can be specified @I[as the way of implementing] instances of a Class in the Representation Language, so that while the objects in such a class appear the same as other objects in the Representation Language and are accessed in the same way, they are actually implemented as LISP objects which are efficient in both time and storage. A clean @Foot[Cleanliness is in the eye of the beholder and, being next to Godliness, difficult to attain. However, it's @I(relatively) clean.] interface between GLISP and a Representation Language is provided. With such an interface, each @I[Class] in the Representation Language is acceptable as a GLISP @I[type]. When the program which is being compiled specifies an access to an object which is known to be a member of some Class, the interface module for the Representation Language is called to generate code to perform the access. The interface module can perform inheritance within the Class hierarchy, and can call GLISP compiler functions to compile code for subexpressions. Properties, Adjectives, and Messages in GLISP format can be added to Class definitions, and can be inherited by subclasses at compile time. In an Object-Centered representation language or other representation language which relies heavily on procedural inheritance, substantial improvements in execution speed can be achieved by performing the inheritance lookup at compile time and compiling direct procedure calls to inherited procedures when the procedures are static and the type of the object which inherits the procedure is known at compile time. Specifications for an interface module for GLISP are contained in a separate document@Foot[to be written.]. To date, GLISP has been interfaced to our own GIRL representation language, and to LOOPS. @Foot[LOOPS, a LISP Object Oriented Programming System, is being developed at Xerox Palo Alto Research Center by Dan Bobrow and yMark Stefik.] @Chapter(Obtaining and Using GLISP) GLISP and its documentation are available free of charge over the ARPANET. The host computers involved will accept the login "ANONYMOUS GUEST" for transferring files with FTP. @Section(Documentation) This user's manual, in line-printer format, is contained in @PE([UTEXAS-20]<CS.NOVAK>GLUSER.LPT) . The SCRIBE source file is @PE([SU-SCORE]<CSD.NOVAK>GLUSER.MSS) . Printed copies of this manual can be ordered from Publications Coordinator, Computer Science Department, Stanford University, Stanford, CA 94305, as technical report STAN-CS-82-895 ($3.15 prepaid); the printed version may not be as up-to-date as the on-line version. @Section(Compiler Files) There are two files, GLISP (the compiler itself) and GLTEST (a file of examples). The files for the different Lisp dialects are: @Tabset(1.4 inch) @Begin(Format) Interlisp:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.LSP) and @PE(GLTEST.LSP) Maclisp:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.MAC) and @PE(GLTEST.MAC) UCI Lisp:@\@PE([UTEXAS-20]<CS.NOVAK>GLISP.UCI) and @PE(GLTEST.UCI) ELISP:@\the UCI version plus @PE([UTEXAS-20]<CS.NOVAK>ELISP.FIX) Franz Lisp:@\@PE([SUMEX-AIM]<NOVAK>GLISP.FRANZ) and @PE(GLTEST.FRANZ) PSL:@\@PE([SU-SCORE]<CSD.NOVAK>GLISP.PSL) and @PE(GLTEST.PSL) @End(Format) @Section(Getting Started) Useful functions for invoking GLISP are: @Begin(Format) @PE[(GLCC 'FN)]@\Compile FN. @PE[(GLCP 'FN)]@\Compile FN and prettyprint result. @PE[(GLP 'FN)]@\Prettyprint GLISP-compiled version of FN. @PE[(GLED 'NAME)]@\Edit the property list of NAME. @PE[(GLEDF 'FN)]@\Edit the original (GLISP) definition of FN. @\(The original definition is saved under the property @\"GLORIGINALEXPR" when the function is compiled, and @\the compiled version replaces the function @\definition.) @PE[(GLEDS 'STR)]@\Edit the structure declarations of STR. @End(Format) The editing functions call the "BBN/Interlisp" structure editor. To try out GLISP, load the GLTEST file and use GLCP to compile the functions CURRENTDATE, GIVE-RAISE, TESTFN1, TESTFN2, DRAWRECT, TP, GROWCIRCLE, and SQUASH. To run compiled functions on test data, do: @Begin(ProgramExample) (GIVE-RAISE 'COMPANY1) (TP '(((A (B (C D (E (G H (I J (K)))))))))) (GROWCIRCLE MYCIRCLE) @END(ProgramExample) @Section(Reserved Words and Characters) GLISP contains ordinary lisp as a sublanguage. However, in order to avoid having code which was intended as "ordinary lisp" interpreted as GLISP code, it is necessary to follow certain conventions when writing "ordinary lisp" code. @Subsection(Reserved Characters) The colon and the characters which represent the arithmetic operators should not be used within atom names, since GLISP splits apart "atoms" which contain operators. The set of characters to be avoided within atom names is: @Programexample{ + * / ^ _ ~ = < > : ' , } The character "minus" (@PE[ - ]) is permitted within atom names unless the flag @PE[GLSEPMINUS] is set. Some GLISP constructs permit (but do not require) use of the character "comma" (@PE[ , ]); since the comma is used as a "backquote" character in some Lisp dialects, the user may wish to avoid its use. When used in Lisp dialects which use comma as a backquote character, all commas must be "escaped" or "slashified"; this makes porting of GLISP code containing commas more difficult. @Subsection(Reserved Function Names) Most GLISP function, variable, and property names begin with "@PE[GL]" to avoid conflict with user names. Those "function" names which are used in GLISP constructs or in interpretive functions should be avoided. This set includes the following names: @Programexample{ A AN CASE FOR IF REPEAT SEND SENDPROP THE WHILE } @SUBSECTION(Other Reserved Names) Words which are used within GLISP constructs should be avoided as variable names. This set of names includes: @ProgramExample{ A AN DO ELSE ELSEIF IS OF THE THEN UNTIL } @SECTION(Lisp Dialect Idiosyncrasies) GLISP code passes through the Lisp reader before it is seen by GLISP. For this reason, operators in expressions may need to be set off from operands by blanks; the operator "@PE[-]" should always be surrounded by blanks, and the operator "@PE[+]" should be separated from numbers by blanks. @Subsection(Interlisp) GLISP compilation happens automatically, and usually does not need to be invoked explicitly. GLISP declarations are integrated with the file package. @Subsection(UCI Lisp) The following command is needed before loading to make room for GLISP: @ProgramExample[(REALLOC 3000 1000 1000 1000 35000)] The compiler file modifies the syntax of the character @B[~] to be "alphabetic" so it can be used as a GLISP operator. The character "@PE[/]" must be "slashified" to "@PE[//]". @Subsection(ELISP) For ELISP, the UCI Lisp version of the compiler is used, together with a small compatibility file. The above comments about UCI lisp do not apply to ELISP. The characters "@PE[/]" and "@PE[,]" must be "slashified" to "@PE[//]" and "@PE[/,]". @Subsection(Maclisp) The characters "@PE[/]" and "@PE[,]" must be "slashified" to "@PE[//]" and "@PE[/,]". @Subsection(Franz Lisp) Automatic compilation is implemented for Franz Lisp. The character "@PE[,]" and the operators "@PE[+_]" and "@PE[-_]" must be "slashified" to "@PE[\,]", "@PE[+\_]", and "@PE[-\_]", respectively. Before loading GLISP, edit something to cause the editor files to be loaded@Foot[Some versions of the "CMU editor" contain function definitions which may conflict with those of GLISP; if the editor is loaded first, the GLISP versions override.]. The Franz Lisp version of GLISP has been tested on Opus 38 Franz Lisp; users with earlier versions of Franz might encounter difficulties. @Section(Bug Reports and Mailing List) To get on the GLISP mailing list or to report bugs, send mail to CSD.NOVAK@@SU-SCORE. @Chapter(GLISP Hacks) This chapter discusses some ways of doing things in GLISP which might not be entirely obvious at first glance. @Section(Overloading Basic Types) GLISP provides the ability to define properties of structures described in the Structure Description language; since the elementary LISP types are structures in this language, objects whose storage representation is an elementary type can be "overloaded" by specifying properties and operators for them. The following examples illustrate how this can be done. @Begin(ProgramExample) (GLDEFSTRQ (ArithmeticOperator (self ATOM) PROP ((Precedence OperatorPrecedenceFn RESULT INTEGER) (PrintForm ((GETPROP self 'PRINTFORM) or self)) ) MSG ((PRIN1 ((PRIN1 the PrintForm)))) ) (IntegerMod7 (self INTEGER) PROP ((Modulus (7)) (Inverse ((If self is ZERO then 0 else (Modulus - self))) )) ADJ ((Even ((ZEROP (LOGAND self 1)))) (Odd (NOT Even))) ISA ((Prime PrimeTestFn)) MSG ((+ IMod7Plus OPEN T RESULT IntegerMod7) (_ IMod7Store OPEN T RESULT IntegerMod7)) ) ) (DEFINEQ (IMod7Store (GLAMBDA (LHS:IntegerMod7 RHS:INTEGER) (LHS:self __ (IREMAINDER RHS Modulus)) )) (IMod7Plus (GLAMBDA (X,Y:IntegerMod7) (IREMAINDER (X:self + Y:self) X:Modulus) )) ) @End(ProgramExample) A few subtleties of the function IMod7Store are worth noting. First, the left-hand-side expression used in storing the result is LHS:self rather than simply LHS. LHS and LHS:self of course refer to the same actual structure; however, the @I[type] of LHS is IntegerMod7, while the type of LHS:self is INTEGER. If LHS were used on the left-hand side, since the @PE[ _ ] operator is overloaded for IntegerMod7, the function IMod7Store would be invoked again to perform its own function; since the function is compiled OPEN, this would be an infinite loop. A second subtlety is that the assignment to LHS:self must use the self-assignment operator, @PE[@ __@ ], since it is desired to perform assignment as seen "outside" the function IMod7Store, i.e., in the environment in which the original assignment operation was specified. @Section(Disjunctive Types) LISP programming often involves objects which may in fact be of different types, but which are for some purposes treated alike. For example, LISP data structures are typically constructed of CONS cells whose fields may point to other CONS cells or to ATOMs. The GLISP Structure Description language does not permit the user to specify that a certain field of a structure is a CONS cell @P[or] an ATOM. However, it is possible to create a GLISP datatype which encompasses both. Typically, this is done by declaring the structure of the object to be the complex structure, and testing for the simpler structure explicitly. This is illustrated for the case of the LISP tree below. @Begin(ProgramExample) (LISPTREE (CONS (CAR LISPTREE) (CDR LISPTREE)) ADJ ((EMPTY (@R<~>self))) PROP ((LEFTSON ((If self is ATOMIC then NIL else CAR))) (RIGHTSON ((If self is ATOMIC then NIL else CDR))))) @End(ProgramExample) @Section(Generators) Often, one would like to define such properties of an object as the way of enumerating its parts in some order. Such things cannot be specified directly as properties of the object because they depend on the previous state of the enumeration. However, it is possible to define an object, associated with the original datatype, which contains the state of the enumeration and responds to Messages. This is illustrated below by an object which searches a tree in Preorder. @Begin(ProgramExample) (PreorderSearchRecord (CONS (Node LISPTREE) (PreviousNodes (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (If TMP_Node:LEFTSON then (If Node:RIGHTSON then PreviousNodes+_Node) Node_TMP else TMP-_PreviousNodes Node_TMP:RIGHTSON) )))) (TP (GLAMBDA ((A LISPTREE)) (PROG (PSR) (PSR _ (A PreorderSearchRecord with Node = (the LISPTREE))) (While Node (If Node is ATOMIC (PRINT Node)) (_ PSR NEXT)) ))) @End(ProgramExample) The object class PreorderSearchRecord serves two purposes: it holds the state of the enumeration, and it responds to messages to step through the enumeration. With these definitions, it is easy to write a program involving enumeration of a LISPTREE, as illustrated by the example function TP above. By being open-compiled, messages to an object can be as efficient as in-line hand coding; yet, the code for the messages only has to be written once, and can easily be changed without changing the programs which use the messages. @Chapter(Program Examples) In this chapter, examples of GLISP object declarations and programs are presented. Each example is discussed as a section of this chapter; the code for the examples and the code produced by the compiler are shown for each example at the end of the chapter. @Section(GLTST1 File) The GLTST1 file illustrates the use of several types of LISP structures, and the use of fairly complex Property definitions for objects. SENIORITY of an EMPLOYEE, for example, is defined in terms of the YEAR of DATE-HIRED, which is a substructure of EMPLOYEE, and the YEAR of the function (CURRENTDATE). @Foot[The @I<type> of (CURRENTDATE) must be known to the compiler, either by compiling it first, or by including a RESULT declaration in the function definition of CURRENTDATE, or by specifying the GLRESULTTYPE property for the function name.] @Section(GLTST2 File) The GLTST2 file illustrates the use of Messages for ordinary LISP objects. By defining the arithmetic operators as Message selectors for the object VECTOR, use of vectors in arithmetic expressions is enabled; OPEN compilation is specified for these messages. The definition of GRAPHICSOBJECT uses VECTORs as components. While the actual structure of a GRAPHICSOBJECT is simple, numerous properties are defined for user convenience. The definition of CENTER is easily stated as a VECTOR expression. The Messages of GRAPHICSOBJECT illustrate how different responses to a message for different types of objects can be achieved, even though for GLISP compilation of messages to LISP objects the code for a message must be resolved at compile time. @Foot[For objects in a Representation Language, messages may be compiled directly as LISP code or as messages to be interpreted at runtime, depending on how much is known about the object to which the message is sent and the compilation declarations in effect.] The DRAW and ERASE messages get the function to be used from the property list of the SHAPE name of the GRAPHICSOBJECT and APPLY it to draw the desired object. MOVINGGRAPHICSOBJECT contains a GRAPHICSOBJECT as a TRANSPARENT component, so that it inherits the properties of a GRAPHICSOBJECT; a MOVINGGRAPHICSOBJECT is a GRAPHICSOBJECT which has a VELOCITY, and will move itself by the amount of its velocity upon the message command STEP.@Foot[This example is adapted from the MovingPoint example written by Dan Bobrow for LOOPS.] The compilation of the message @PE[(_@ MGO@ STEP)] in the function TESTFN1 is of particular interest. This message is expanded into the sending of the message @PE[(_@ self@ MOVE@ VELOCITY)] to the MOVINGGRAPHICSOBJECT. The MOVINGGRAPHICSOBJECT cannot respond to such a message; however, since it contains a GRAPHICSOBJECT as a TRANSPARENT component, its GRAPHICSOBJECT responds to the message. @Foot[TRANSPARENT substructures thus permit procedural inheritance by LISP objects.] A GRAPHICSOBJECT responds to a MOVE message by erasing itself, increasing its START point by the (vector) distance to be moved, and then redrawing itself. All of the messages are specified as being compiled open, so that the short original message actually generates a large amount of code. A rectangle is drawn by the function DRAWRECT. Note how the use of the properties defined for a GRAPHICSOBJECT allows an easy interface to the system functions MOVETO and DRAWTO in terms of the properties LEFT, RIGHT, TOP, and BOTTOM. |
Added psl-1983/glisp/grtree.old version [4f81573f01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED "15-JAN-83 16:03:58" {DSK}GRTREE.LSP;11 7426 changes to: (FNS STRINGDATA-DRAW TREEELEMENT-DRAWIN BOXTYPE-DRAW BOXTYPE-ERASE DRAWRECTANGLE GRAPHICSBOX-DRAWIN GRAPHICSBOX-ERASEIN MATCHTREE RECTANGLESIZE BOXTYPE-SETSIZE GRAPHICSTREE-BOXTYPE GRAPHICSTREE-WIDTH) (VARS GRTREECOMS GRAPHICSBOXTYPES) (PROPS (RECTANGLE SIZEPROGRAM) (RECTANGLE DRAWPROGRAM)) previous date: "13-JAN-83 10:32:08" {DSK}GRTREE.LSP;1) (PRETTYCOMPRINT GRTREECOMS) (RPAQQ GRTREECOMS [(GLISPOBJECTS BOXTYPE GRAPHICSBOX GRAPHICSTREE LISPGRAPHICSTREE LISPNODEDISPLAY TREEELEMENT) (FNS BOXTYPE-DRAW BOXTYPE-ERASE BOXTYPE-SETSIZE DRAWRECTANGLE GRAPHICSBOX-DRAWIN GRAPHICSBOX-ERASEIN MATCHTREE RECTANGLESIZE STRINGDATA-DRAW TREEELEMENT-DRAWIN) (GLISPGLOBALS GRAPHICSBOXTYPES) (PROP DRAWPROGRAM RECTANGLE) (PROP SIZEPROGRAM RECTANGLE) (VARS GRAPHICSBOXTYPES) (GLOBALVARS GRAPHICSBOXTYPES) (P (LOAD? (QUOTE VECTOR.LSP]) [GLISPOBJECTS (BOXTYPE (ATOM (PROPLIST (DRAWPROGRAM ATOM) (SIZEPROGRAM ATOM))) MSG ((DRAW BOXTYPE-DRAW OPEN T) (ERASE BOXTYPE-ERASE OPEN T) (SETSIZE BOXTYPE-SETSIZE OPEN T)) ) (GRAPHICSBOX (LISTOBJECT (BOXTYPE BOXTYPE) (START VECTOR) (SIZE VECTOR) (CONTENTSOFFSET VECTOR) (DISPLAYCONTENTS ANYTHING) (CONTENTSSIZE VECTOR)) MSG [(DRAWIN GRAPHICSBOX-DRAWIN OPEN T) (ERASEIN GRAPHICSBOX-ERASEIN OPEN T) (SETSIZE ((SEND BOXTYPE SETSIZE self] SUPERS (REGION) ) (GRAPHICSTREE ANYTHING PROP ((BOXTYPE (BOXTYPENAME) RESULT BOXTYPE)) MSG ((MAKEGRAPHICSTREE MATCHTREE) (DRAW GRAPHICSTREE-DRAW) (TERMINAL? (self IS TERMINAL))) ) (LISPGRAPHICSTREE (LISTOBJECT (EXPR ANYTHING)) PROP ((BOXTYPENAME ((QUOTE RECTANGLE))) [BOXCONTENTS ((IF EXPR IS ATOMIC THEN EXPR ELSE (CAR EXPR] (BOXDISPLAYCONTENTS ((A LISPNODEDISPLAY WITH CONTENTS = BOXCONTENTS))) (SUCCESSORS [(IF EXPR IS ATOMIC THEN NIL ELSE (FOR X IN (CDR EXPR) COLLECT (A LISPGRAPHICSTREE WITH EXPR = X] RESULT (LISTOF LISPGRAPHICSTREE))) ADJ ((TERMINAL (EXPR IS ATOMIC))) SUPERS (GRAPHICSTREE) ) (LISPNODEDISPLAY (LISTOBJECT (CONTENTS ANYTHING)) PROP [(DISPLAYSIZE ((A VECTOR WITH X = (NCHARS CONTENTS) *8 Y = 12] MSG ((DRAW STRINGDATA-DRAW)) ) (TREEELEMENT (LISTOBJECT (BOX GRAPHICSBOX) (ORIGINALNODE ANYTHING) (SUCCESSORS (LISTOF TREEELEMENT)) (DISPLAYSIZE VECTOR)) PROP ((DISPLAYWIDTH (DISPLAYSIZE:X)) (DISPLAYHEIGHT (DISPLAYSIZE:Y))) MSG ((DRAWIN TREEELEMENT-DRAWIN)) ) ] (DEFINEQ (BOXTYPE-DRAW (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:58") (APPLY* BOXTYPE:DRAWPROGRAM BOX (QUOTE PAINT) W))) (BOXTYPE-ERASE (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:58") (APPLY* BOXTYPE:DRAWPROGRAM BOX (QUOTE ERASE) W))) (BOXTYPE-SETSIZE (GLAMBDA (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX) (* GSN "14-JAN-83 09:52") (BOX:CONTENTSSIZE _(SEND BOX:DISPLAYCONTENTS DISPLAYSIZE)) (APPLY* BOXTYPE:SIZEPROGRAM BOX))) (DRAWRECTANGLE (GLAMBDA (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (* GSN "14-JAN-83 13:01") (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (MOVETO BOX:LEFT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:TOP) (DRAWTO BOX:RIGHT BOX:TOP) (DRAWTO BOX:RIGHT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:BOTTOM) (CURRENTDISPLAYSTREAM OLDDS)))) (GRAPHICSBOX-DRAWIN (GLAMBDA (BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:55") (SEND BOX:BOXTYPE DRAW BOX W))) (GRAPHICSBOX-ERASEIN (GLAMBDA (BOX:GRAPHICSBOX W:WINDOW) (* GSN "14-JAN-83 12:55") (SEND BOX:BOXTYPE ERASE BOX W))) (MATCHTREE (GLAMBDA (TR) (* GSN "14-JAN-83 10:46") (* Build a TREEELEMENT structure to match the given tree TR.) (RESULT TREEELEMENT) (PROG (TE SUM) [TE _(A TREEELEMENT WITH ORIGINALNODE = TR BOX =(A GRAPHICSBOX WITH BOXTYPE =(SEND TR BOXTYPE) DISPLAYCONTENTS =(SEND TR BOXDISPLAYCONTENTS)) SUCCESSORS =(FOR X IN (SEND TR SUCCESSORS) COLLECT (SEND X MAKEGRAPHICSTREE] (SEND TE:BOX SETSIZE) (TE:DISPLAYWIDTH _(IF (SEND TR TERMINAL?) THEN TE:BOX:WIDTH + 10 ELSE (SUM_0) (FOR X IN TE:SUCCESSORS DO SUM_+X:DISPLAYWIDTH) (MAX (TE:BOX:WIDTH + 10) SUM))) [TE:DISPLAYHEIGHT _(IF (SEND TR TERMINAL?) THEN TE:BOX:HEIGHT ELSE TE:BOX:HEIGHT + 20 +(APPLY (FUNCTION MAX) (FOR X IN TE:SUCCESSORS COLLECT X:BOX:HEIGHT] (RETURN TE)))) (RECTANGLESIZE (GLAMBDA (BOX:GRAPHICSBOX) (* GSN "14-JAN-83 10:28") (BOX:SIZE _ BOX:CONTENTSSIZE +(A VECTOR WITH X = 10 Y = 10)) (BOX:CONTENTSOFFSET _(A VECTOR WITH X = 5 Y = 5)))) (STRINGDATA-DRAW (GLAMBDA (self:LISPNODEDISPLAY POS:VECTOR W:WINDOW) (* GSN "14-JAN-83 14:35") (SEND W PRINTAT self:CONTENTS POS))) (TREEELEMENT-DRAWIN [GLAMBDA (TREE:TREEELEMENT AREA:REGION W:WINDOW) (* GSN "14-JAN-83 14:42") (* Draw the subtree beginning with TREE inside area AREA in window W.) (PROG (NEWX NEWY SUM FSPN (TB TREE:BOX)) (IF TREE:DISPLAYSIZE>AREA:SIZE THEN (ERROR "Area is too small for tree.")) (TB:START _(A VECTOR WITH X =(AREA:LEFT + AREA:RIGHT - TB:SIZE:X)/2 Y = AREA:TOP - TB:SIZE:Y)) (SEND TB DRAWIN W) (SEND TB:DISPLAYCONTENTS DRAW TB:START+TB:CONTENTSOFFSET W) (* Now compute positions for successors of top node.) (IF TREE:SUCCESSORS THEN (NEWY _ AREA:TOP - TB:SIZE:Y - 20) (SUM_0) (FOR S IN TREE:SUCCESSORS DO SUM_+S:DISPLAYSIZE:X) (* Calculate free space for each box.) (FSPN _(AREA:SIZE:X - SUM)/(LENGTH SUCCESSORS)) (NEWX _ AREA:START:X + FSPN/2) (* Draw each subtree.) (FOR S IN TREE:SUCCESSORS DO (* Draw arc to new subtree.) (SEND W DRAWLINE TB:BOTTOMCENTER (A VECTOR WITH X = NEWX+S:DISPLAYSIZE:X/2 Y = NEWY)) (SEND S DRAWIN (AN AREA WITH START =(A VECTOR WITH X = NEWX Y = AREA:START:Y) SIZE =(A VECTOR WITH X = S:DISPLAYSIZE:X Y = NEWY - AREA:START:Y)) W) (NEWX_+S:DISPLAYSIZE:X+FSPN]) ) [GLISPGLOBALS (GRAPHICSBOXTYPES (LISTOF BOXTYPE) ) ] (PUTPROPS RECTANGLE DRAWPROGRAM DRAWRECTANGLE) (PUTPROPS RECTANGLE SIZEPROGRAM RECTANGLESIZE) (RPAQQ GRAPHICSBOXTYPES (RECTANGLE)) (DECLARE: DOEVAL@COMPILE DONTCOPY (ADDTOVAR GLOBALVARS GRAPHICSBOXTYPES) ) (LOAD? (QUOTE VECTOR.LSP)) (DECLARE: DONTCOPY (FILEMAP (NIL (2714 7091 (BOXTYPE-DRAW 2724 . 2892) (BOXTYPE-ERASE 2894 . 3063) (BOXTYPE-SETSIZE 3065 . 3278) (DRAWRECTANGLE 3280 . 3715) (GRAPHICSBOX-DRAWIN 3717 . 3867) (GRAPHICSBOX-ERASEIN 3869 . 4021 ) (MATCHTREE 4023 . 5126) (RECTANGLESIZE 5128 . 5358) (STRINGDATA-DRAW 5360 . 5512) ( TREEELEMENT-DRAWIN 5514 . 7089))))) STOP |
Added psl-1983/glisp/grtree.sl version [53fa5c06f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}GRTREE.PSL;11 4-FEB-83 16:48:01 (GLOBAL '(GRAPHICSBOXTYPES)) % Tree Drawing Package. To test, do (DLT TX WW) where WW is a window. (GLISPOBJECTS (BOXTYPE (ATOM (PROPLIST (DRAWPROGRAM ATOM) (SIZEPROGRAM ATOM))) MSG ((DRAW BOXTYPE-DRAW OPEN T) (ERASE BOXTYPE-ERASE OPEN T) (SETSIZE BOXTYPE-SETSIZE OPEN T))) (GRAPHICSBOX (LISTOBJECT (BOXTYPE BOXTYPE) (START VECTOR) (SIZE VECTOR) (CONTENTSOFFSET VECTOR) (DISPLAYCONTENTS ANYTHING) (CONTENTSSIZE VECTOR)) MSG ((DRAWIN GRAPHICSBOX-DRAWIN OPEN T) (ERASEIN GRAPHICSBOX-ERASEIN OPEN T) (SETSIZE ((SEND BOXTYPE SETSIZE self)))) SUPERS (REGION)) (GRAPHICSTREE (LISTOBJECT (TOPNODE TREE) (GRTREE TREEELEMENT) (BOXTYPE BOXTYPE) (LINESTYPE LINESTYPE) (SPACING VECTOR)) MSG ((CREATE CREATETREE SPECIALIZE T) (MATCH MATCHTREE SPECIALIZE T) (SELECTNODE GRAPHICSTREE-SELECTNODE OPEN T))) (LISPGRAPHICSTREE (LISTOBJECT (TOPNODE LISPTREE) (GRTREE TREEELEMENT)) PROP ((BOXTYPE ('RECTANGLE) RESULT BOXTYPE) (LINESTYPE ('STRAIGHT) RESULT LINESTYPE) (SPACING ('(10 20)) RESULT VECTOR)) SUPERS (GRAPHICSTREE)) (LISPNODEDISPLAY (LISTOBJECT (CONTENTS ANYTHING)) PROP ((DISPLAYSIZE ((A VECTOR WITH X = (NCHARS CONTENTS) *7 Y = 10)))) MSG ((DRAW STRINGDATA-DRAW))) (LISPTREE (EXPR ANYTHING) PROP ((CONTENTS ((A LISPNODEDISPLAY WITH CONTENTS = (IF EXPR IS ATOMIC THEN EXPR ELSE (CAR EXPR))))) (SUCCESSORS ((IF EXPR IS ATOMIC THEN NIL ELSE (CDR EXPR))) RESULT (LISTOF LISPTREE))) ADJ ((TERMINAL (EXPR IS ATOMIC)))) (TREEELEMENT (LISTOBJECT (BOX GRAPHICSBOX) (ORIGINALNODE ANYTHING) (SUCCESSORS (LISTOF TREEELEMENT)) (DISPLAYSIZE VECTOR)) PROP ((DISPLAYWIDTH (DISPLAYSIZE:X)) (DISPLAYHEIGHT (DISPLAYSIZE:Y)) (TOTALAREA ((VIRTUAL REGION WITH START = TOTALSTART SIZE = DISPLAYSIZE))) (TOTALSTART ((VIRTUAL VECTOR WITH X = BOX:START:X + (BOX:SIZE:X - DISPLAYSIZE:X) / 2 Y = BOX:START:Y + BOX:SIZE:Y - DISPLAYSIZE:Y)))) MSG ((DRAWIN TREEELEMENT-DRAWIN) (SELECTNODE TREEELEMENT-SELECTNODE))) ) % GSN 14-JAN-83 12:58 (DG BOXTYPE-DRAW (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'PAINT W))) % GSN 14-JAN-83 12:58 (DG BOXTYPE-ERASE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW) (APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'ERASE W))) % GSN 14-JAN-83 09:52 (DG BOXTYPE-SETSIZE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX) (BOX:CONTENTSSIZE _ (SEND BOX:DISPLAYCONTENTS DISPLAYSIZE))(APPLY BOXTYPE:SIZEPROGRAM (LIST BOX))) % GSN 2-FEB-83 12:58 (DG CIRCLESIZE (BOX:GRAPHICSBOX) (PROG (DIAM) (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10) (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = DIAM)) (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X) /2 Y = (DIAM - BOX:CONTENTSSIZE:Y) /2)))) % GSN 2-FEB-83 11:23 (DG CREATETREE (TR:GRAPHICSTREE) (SEND TR MATCH TOPNODE)) % GSN 2-FEB-83 14:04 % Draw a Lisp tree. (DG DLT (EXPR WW:WINDOW) (PROG (TREE) (SEND WW CLEAR) (TREE _ (SEND (A LISPGRAPHICSTREE WITH TOPNODE = EXPR) CREATE)) (IF TREE:DISPLAYSIZE > WW:SIZE THEN (ERROR 0 "Window is too small") ELSE (SEND TREE DRAWIN (AN AREA WITH SIZE = TREE:DISPLAYSIZE START = (SEND WW CENTEROFFSET TREE:DISPLAYSIZE)) WW)))) % GSN 2-FEB-83 12:16 (DG DRAWGRCIRCLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (DRAWCIRCLE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:X/2 NIL W) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 2-FEB-83 13:12 (DG DRAWGRELLIPSE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (DRAWELLIPSE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:Y/2 BOX:SIZE:X/2 0 NIL NIL W) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 14-JAN-83 13:01 (DG DRAWRECTANGLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM W)) (DSPOPERATION DSPOP) (MOVETO BOX:LEFT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:TOP) (DRAWTO BOX:RIGHT BOX:TOP) (DRAWTO BOX:RIGHT BOX:BOTTOM) (DRAWTO BOX:LEFT BOX:BOTTOM) (CURRENTDISPLAYSTREAM OLDDS))) % GSN 2-FEB-83 13:12 (DG ELLIPSESIZE (BOX:GRAPHICSBOX) (PROG (DIAM) (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10) (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = BOX:CONTENTSSIZE:Y + 10)) (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X) /2 + 1 Y = 6)))) % GSN 14-JAN-83 12:55 (DG GRAPHICSBOX-DRAWIN (BOX:GRAPHICSBOX W:WINDOW) (SEND BOX:BOXTYPE DRAW BOX W)) % GSN 14-JAN-83 12:55 (DG GRAPHICSBOX-ERASEIN (BOX:GRAPHICSBOX W:WINDOW) (SEND BOX:BOXTYPE ERASE BOX W)) % GSN 2-FEB-83 16:14 (DG GRAPHICSTREE-SELECTNODE (GT:GRAPHICSTREE V:VECTOR) (SEND GT:GRTREE SELECTNODE V)) % GSN 3-FEB-83 13:29 % Build a TREEELEMENT structure to match the given tree TR. (DG MATCHTREE (TR:GRAPHICSTREE NODE:TREE) (RESULT TREEELEMENT)(PROG (TE SUM MAXH) (TE _ (A TREEELEMENT WITH ORIGINALNODE = NODE BOX = (A GRAPHICSBOX WITH BOXTYPE = TR:BOXTYPE DISPLAYCONTENTS = NODE:CONTENTS) SUCCESSORS = (FOR X IN NODE:SUCCESSORS COLLECT (SEND TR MATCH X)))) (SEND TE:BOX SETSIZE) (TE:DISPLAYWIDTH _ (IF NODE IS TERMINAL THEN TE:BOX:WIDTH + TR:SPACING:X ELSE (SUM_0) (FOR X IN TE:SUCCESSORS DO SUM_+X:DISPLAYWIDTH) (MAX (TE:BOX:WIDTH + TR:SPACING:X) SUM))) (TE:DISPLAYHEIGHT _ (IF NODE IS TERMINAL THEN TE:BOX:HEIGHT ELSE (MAXH_0) (FOR X IN TE:SUCCESSORS DO (MAXH_ (MAX MAXH X:DISPLAYHEIGHT))) (TE:BOX:HEIGHT + TR:SPACING:Y + MAXH))) (RETURN TE))) % GSN 2-FEB-83 12:02 (DG RECTANGLESIZE (BOX:GRAPHICSBOX) (BOX:SIZE _ BOX:CONTENTSSIZE + (A VECTOR WITH X = 10 Y = 10))( BOX:CONTENTSOFFSET _ (A VECTOR WITH X = 6 Y = 6))) % GSN 14-JAN-83 14:35 (DG STRINGDATA-DRAW (self:LISPNODEDISPLAY POS:VECTOR W:WINDOW) (SEND W PRINTAT self:CONTENTS POS)) % GSN 14-JAN-83 14:42 % Draw the subtree beginning with TREE inside area AREA in window W. (DG TREEELEMENT-DRAWIN (TREE:TREEELEMENT AREA:REGION W:WINDOW) (PROG (NEWX NEWY SUM FSPN TB) (IF TREE:DISPLAYSIZE>AREA:SIZE THEN (ERROR 0 "Area is too small for tree.")) (TB:START _ (A VECTOR WITH X = (AREA:LEFT + AREA:RIGHT - TB:SIZE:X) /2 Y = AREA:TOP - TB:SIZE:Y)) (SEND TB DRAWIN W) (SEND TB:DISPLAYCONTENTS DRAW TB:START+TB:CONTENTSOFFSET W) % Now compute positions for successors of top node. (IF TREE:SUCCESSORS THEN (NEWY _ AREA:TOP - TB:SIZE:Y - 20) (SUM_0) (FOR S IN TREE:SUCCESSORS DO SUM_+S:DISPLAYSIZE:X) % Calculate free space for each box. (FSPN _ (AREA:SIZE:X - SUM) / (LENGTH SUCCESSORS)) (NEWX _ AREA:START:X + FSPN/2) % Draw each subtree. (FOR S IN TREE:SUCCESSORS DO % Draw arc to new subtree. (SEND W DRAWLINE TB:BOTTOMCENTER (A VECTOR WITH X = NEWX+S:DISPLAYSIZE:X/2 Y = NEWY)) (SEND S DRAWIN (AN AREA WITH START = (A VECTOR WITH X = NEWX Y = AREA:START:Y) SIZE = (A VECTOR WITH X = S:DISPLAYSIZE:X Y = NEWY - AREA:START:Y)) W) (NEWX_+S:DISPLAYSIZE:X+FSPN))))) % GSN 2-FEB-83 17:37 (DG TREEELEMENT-SELECTNODE (TE:TREEELEMENT V:VECTOR) (PROG (RESULT LST TMP) (IF (SEND TE:BOX CONTAINS? V) THEN (RETURN TE) ELSEIF (SEND TE:TOTALAREA CONTAINS? V) THEN (LST_TE:SUCCESSORS) (WHILE ~RESULT AND (TMP-_LST) DO (RESULT _ (SEND TMP SELECTNODE V))) (RETURN RESULT)))) (GLISPGLOBALS (GRAPHICSBOXTYPES (LISTOF BOXTYPE)) ) (PUT 'RECTANGLE 'DRAWPROGRAM 'DRAWRECTANGLE) (PUT 'CIRCLE 'DRAWPROGRAM 'DRAWGRCIRCLE) (PUT 'ELLIPSE 'DRAWPROGRAM 'DRAWGRELLIPSE) (PUT 'RECTANGLE 'SIZEPROGRAM 'RECTANGLESIZE) (PUT 'CIRCLE 'SIZEPROGRAM 'CIRCLESIZE) (PUT 'ELLIPSE 'SIZEPROGRAM 'ELLIPSESIZE) (SETQ GRAPHICSBOXTYPES '(RECTANGLE)) (SETQ TX '(/(+(- B) (SQRT (-(^ B 2) (* 4 (* A C)) ))) (* 2 A) )) |
Added psl-1983/glisp/irewrite.b version [4f56926784].
cannot compute difference between binary files
Added psl-1983/glisp/irewrite.sl version [aa5dc9b72b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}IREWRITE.PSL;2 6-JAN-83 10:08:06 (DE ADD-LEMMA (TERM) (COND ((AND (NOT (ATOM TERM)) (EQ (CAR TERM) 'EQUAL) (NOT (ATOM (CADR TERM)))) (PUT (CAR (CADR TERM)) 'LEMMAS (CONS TERM (GET (CAR (CADR TERM)) 'LEMMAS)))) (T (ERROR 0 (LIST 'ADD-LEMMA-DID-NOT-LIKE-TERM TERM))))) (DE ADD-LEMMA-LST (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST))))) % lmm 7-JUN-81 10:07 (DE APPLY-SUBST (ALIST TERM) (COND ((NOT (PAIRP TERM)) ((LAMBDA (TEM) (COND (TEM (CDR TEM)) (T TERM))) (ASSOC TERM ALIST))) (T (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION (LAMBDA (X) (APPLY-SUBST ALIST X)))))))) (DE APPLY-SUBST-LST (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST)))))) (DE FALSEP (X LST) (OR (EQUAL X '(F)) (MEMBER X LST))) (DE ONE-WAY-UNIFY (TERM1 TERM2) (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2))) % lmm 7-JUN-81 09:47 (DE ONE-WAY-UNIFY1 (TERM1 TERM2) (COND ((NOT (PAIRP TERM2)) ((LAMBDA (TEM) (COND (TEM (EQUAL TERM1 (CDR TEM))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) (ASSOC TERM2 UNIFY-SUBST))) ((NOT (PAIRP TERM1)) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL))) (DE ONE-WAY-UNIFY1-LST (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL))) (DE PTIME NIL (PROG (GCTM) (SETQ GCTM 0) (RETURN (CONS (time) GCTM)))) % lmm 7-JUN-81 10:04 (DE REWRITE (TERM) (COND ((NOT (PAIRP TERM)) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION REWRITE))) (GET (CAR TERM) 'LEMMAS))))) (DE REWRITE-WITH-LEMMAS (TERM LST) (COND ((NULL LST) TERM) ((ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST))))) (T (REWRITE-WITH-LEMMAS TERM (CDR LST))))) (DE SETUP NIL (ADD-LEMMA-LST '((EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL)))) (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) (EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F)))) (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) (EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (SUB1 X)))) (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) (EQUAL (PRIME X) (AND (NOT (ZEROP X)) (NOT (EQUAL X (ADD1 (ZERO)))) (PRIME1 X (SUB1 X)))) (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) (EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X)))) (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) (EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y)))) (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUS J K)) (TIMES (EXP I J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) (EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE)))) (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) (EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1))))) (EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y)))) (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) (EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A))))) (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) (EQUAL (TIMES X (DIFFERENCE C W)) (DIFFERENCE (TIMES C X) (TIMES W X))) (EQUAL (REMAINDER (TIMES X Z) Z) (ZERO)) (EQUAL (DIFFERENCE (PLUS B (PLUS A C)) A) (PLUS B C)) (EQUAL (DIFFERENCE (ADD1 (PLUS Y Z)) Z) (ADD1 Y)) (EQUAL (LESSP (PLUS X Y) (PLUS X Z)) (LESSP Y Z)) (EQUAL (LESSP (TIMES X Z) (TIMES Y Z)) (AND (NOT (ZEROP Z)) (LESSP X Y))) (EQUAL (LESSP Y (PLUS X Y)) (NOT (ZEROP X))) (EQUAL (GCD (TIMES X Z) (TIMES Y Z)) (TIMES Z (GCD X Y))) (EQUAL (VALUE (NORMALIZE X) A) (VALUE X A)) (EQUAL (EQUAL (FLATTEN X) (CONS Y (NIL))) (AND (NLISTP X) (EQUAL X Y))) (EQUAL (LISTP (GOPHER X)) (LISTP X)) (EQUAL (SAMEFRINGE X Y) (EQUAL (FLATTEN X) (FLATTEN Y))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) (ZERO)) (AND (OR (ZEROP Y) (EQUAL Y 1)) (EQUAL X (ZERO)))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) 1) (EQUAL X 1)) (EQUAL (NUMBERP (GREATEST-FACTOR X Y)) (NOT (AND (OR (ZEROP Y) (EQUAL Y 1)) (NOT (NUMBERP X))))) (EQUAL (TIMES-LIST (APPEND X Y)) (TIMES (TIMES-LIST X) (TIMES-LIST Y))) (EQUAL (PRIME-LIST (APPEND X Y)) (AND (PRIME-LIST X) (PRIME-LIST Y))) (EQUAL (EQUAL Z (TIMES W Z)) (AND (NUMBERP Z) (OR (EQUAL Z (ZERO)) (EQUAL W 1)))) (EQUAL (GREATEREQPR X Y) (NOT (LESSP X Y))) (EQUAL (EQUAL X (TIMES X Y)) (OR (EQUAL X (ZERO)) (AND (NUMBERP X) (EQUAL Y 1)))) (EQUAL (REMAINDER (TIMES Y X) Y) (ZERO)) (EQUAL (EQUAL (TIMES A B) 1) (AND (NOT (EQUAL A (ZERO))) (NOT (EQUAL B (ZERO))) (NUMBERP A) (NUMBERP B) (EQUAL (SUB1 A) (ZERO)) (EQUAL (SUB1 B) (ZERO)))) (EQUAL (LESSP (LENGTH (DELETE X L)) (LENGTH L)) (MEMBER X L)) (EQUAL (SORT2 (DELETE X L)) (DELETE X (SORT2 L))) (EQUAL (DSORT X) (SORT2 X)) (EQUAL (LENGTH (CONS X1 (CONS X2 (CONS X3 (CONS X4 (CONS X5 (CONS X6 X7))))))) (PLUS 6 (LENGTH X7))) (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)) (EQUAL (QUOTIENT (PLUS X (PLUS X Y)) 2) (PLUS X (QUOTIENT Y 2))) (EQUAL (SIGMA (ZERO) I) (QUOTIENT (TIMES I (ADD1 I)) 2)) (EQUAL (PLUS X (ADD1 Y)) (IF (NUMBERP Y) (ADD1 (PLUS X Y)) (ADD1 X))) (EQUAL (EQUAL (DIFFERENCE X Y) (DIFFERENCE Z Y)) (IF (LESSP X Y) (NOT (LESSP Y Z)) (IF (LESSP Z Y) (NOT (LESSP Y X)) (EQUAL (FIX X) (FIX Z))))) (EQUAL (MEANING (PLUS-TREE (DELETE X Y)) A) (IF (MEMBER X Y) (DIFFERENCE (MEANING (PLUS-TREE Y) A) (MEANING X A)) (MEANING (PLUS-TREE Y) A))) (EQUAL (TIMES X (ADD1 Y)) (IF (NUMBERP Y) (PLUS X (TIMES X Y)) (FIX X))) (EQUAL (NTH (NIL) I) (IF (ZEROP I) (NIL) (ZERO))) (EQUAL (LAST (APPEND A B)) (IF (LISTP B) (LAST B) (IF (LISTP A) (CONS (CAR (LAST A)) B) B))) (EQUAL (EQUAL (LESSP X Y) Z) (IF (LESSP X Y) (EQUAL T Z) (EQUAL F Z))) (EQUAL (ASSIGNMENT X (APPEND A B)) (IF (ASSIGNEDP X A) (ASSIGNMENT X A) (ASSIGNMENT X B))) (EQUAL (CAR (GOPHER X)) (IF (LISTP X) (CAR (FLATTEN X)) (ZERO))) (EQUAL (FLATTEN (CDR (GOPHER X))) (IF (LISTP X) (CDR (FLATTEN X)) (CONS (ZERO) (NIL)))) (EQUAL (QUOTIENT (TIMES Y X) Y) (IF (ZEROP Y) (ZERO) (FIX X))) (EQUAL (GET J (SET I VAL MEM)) (IF (EQP J I) VAL (GET J MEM)))))) % lmm 7-JUN-81 09:44 (DE TAUTOLOGYP (X TRUE-LST FALSE-LST) (COND ((TRUEP X TRUE-LST) T) ((FALSEP X FALSE-LST) NIL) ((NOT (PAIRP X)) NIL) ((EQ (CAR X) 'IF) (COND ((TRUEP (CADR X) TRUE-LST) (TAUTOLOGYP (CADDR X) TRUE-LST FALSE-LST)) ((FALSEP (CADR X) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST FALSE-LST)) (T (AND (TAUTOLOGYP (CADDR X) (CONS (CADR X) TRUE-LST) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST (CONS (CADR X) FALSE-LST)))))) (T NIL))) (DE TAUTP (X) (TAUTOLOGYP (REWRITE X) NIL NIL)) (DE TEST NIL (PROG (TM1 TM2 ANS TERM) (SETQ TM1 (PTIME)) (SETQ TERM (APPLY-SUBST '((X F (PLUS (PLUS A B) (PLUS C (ZERO)))) (Y F (TIMES (TIMES A B) (PLUS C D))) (Z F (REVERSE (APPEND (APPEND A B) (NIL)))) (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B)))) '(IMPLIES (AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W)))) (IMPLIES X W)))) (SETQ ANS (TAUTP TERM)) (SETQ TM2 (PTIME)) (RETURN (LIST ANS (DIFFERENCE (CAR TM2) (CAR TM1)) (DIFFERENCE (CDR TM2) (CDR TM1)))))) (DE TRANS-OF-IMPLIES (N) (LIST 'IMPLIES (TRANS-OF-IMPLIES1 N) (LIST 'IMPLIES 0 N))) (DE TRANS-OF-IMPLIES1 (N) (COND ((EQUAL N 1) (LIST 'IMPLIES 0 1)) (T (LIST 'AND (LIST 'IMPLIES (SUB1 N) N) (TRANS-OF-IMPLIES1 (SUB1 N)))))) (DE TRUEP (X LST) (OR (EQUAL X '(T)) (MEMBER X LST))) |
Added psl-1983/glisp/menu.sl version [051df54de0].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % MENU.SL.1 % Abstract datatype for Menu operations. % G. Novak 31 Jan. 83 (glispobjects (menu (listobject (items (listof atom))) msg ((create menu-create) (select menu-select))) ) % Initialize a menu which has been newly created. (dg menu-create (m:menu)) % Ask the user for a selection from a menu. (dg menu-select (m:menu) ) |
Added psl-1983/glisp/oldglisp.sl version [373de2aa60].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 | % % GLHEAD.PSL.9 14 Jan. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) % {DSK}GLISP.PSL;9 12-JAN-83 18:17:19 % edited: 4-JAN-83 11:35 % Transform an expression X for Portable Standard Lisp dialect. (DE GLPSLTRANSFM (X) (PROG (TMP NOTFLG) % First do argument reversals. (COND ((NOT (PAIRP X)) (RETURN X)) ((MEMQ (CAR X) '(push PUSH)) (SETQ X (LIST (CAR X) (CADDR X) (CADR X)))) ((MEMQ (CAR X) NIL) (SETQ X (LIST (CAR X) (CADR X) (CADDDR X) (CADDR X)))) ((EQ (CAR X) 'APPLY*) (SETQ X (LIST 'APPLY (CADR X) (CONS 'LIST (CDDR X)))))) % Now see if the result will be negated. (SETQ NOTFLG (MEMQ (CAR X) '(NLISTP BOUNDP GEQ LEQ IGEQ ILEQ))) (COND ((SETQ TMP (ASSOC (CAR X) '((MEMB MEMQ) (FMEMB MEMQ) (FASSOC ASSOC) (LITATOM IDP) (GETPROP GET) (GETPROPLIST PROP) (PUTPROP PUT) (LISTP PAIRP) (NLISTP PAIRP) (NEQ NE) (IGREATERP GREATERP) (IGEQ LESSP) (GEQ LESSP) (ILESSP LESSP) (ILEQ GREATERP) (LEQ GREATERP) (IPLUS PLUS) (IDIFFERENCE DIFFERENCE) (ITIMES TIMES) (IQUOTIENT QUOTIENT) (* CommentOutCode) (MAPCONC MAPCAN) (DECLARE CommentOutCode) (NCHARS FlatSize2) (NTHCHAR GLNTHCHAR) (DREVERSE REVERSIP) (STREQUAL String!=) (ALPHORDER String!<!=) (GLSTRGREATERP String!>) (GLSTRGEP String!>!=) (GLSTRLESSP String!<) (EQP EQN) (LAST LASTPAIR) (NTH PNth) (NCONC1 ACONC) (U-CASE GLUCASE) (DSUBST SUBSTIP) (BOUNDP UNBOUNDP) (KWOTE MKQUOTE) (UNPACK EXPLODE) (PACK IMPLODE)))) (SETQ X (CONS (CADR TMP) (CDR X)))) ((AND (EQ (CAR X) 'RETURN) (NULL (CDR X))) (SETQ X (LIST (CAR X) NIL))) ((AND (EQ (CAR X) 'APPEND) (NULL (CDDR X))) (SETQ X (LIST (CAR X) (CADR X) NIL))) ((EQ (CAR X) 'ERROR) (SETQ X (LIST (CAR X) 0 (COND ((NULL (CDR X)) NIL) ((NULL (CDDR X)) (CADR X)) (T (CONS 'LIST (CDR X))))))) ((EQ (CAR X) 'SELECTQ) (RPLACA X 'CASEQ) (SETQ TMP (NLEFT X 2)) (COND ((NULL (CADR TMP)) (RPLACD TMP NIL)) (T (RPLACD TMP (LIST (LIST T (CADR TMP)))))))) (RETURN (COND (NOTFLG (LIST 'NOT X)) (T X))))) % edited: 18-NOV-82 11:47 (DF A (L) (GLAINTERPRETER L)) % edited: 18-NOV-82 11:47 (DF AN (L) (GLAINTERPRETER L)) % edited: 29-OCT-81 14:25 (DE GL-A-AN? (X) (MEMQ X '(A AN a an An))) % edited: 26-JUL-82 14:15 % Test whether FNNAME is an abstract function. (DE GLABSTRACTFN? (FNNAME) (PROG (DEFN) (RETURN (AND (SETQ DEFN (GETD FNNAME)) (PAIRP DEFN) (EQ (CAR DEFN) 'MLAMBDA))))) % edited: 26-JUL-82 14:59 % Add an instance function entry for the abstract function whose name % is FN. (DE GLADDINSTANCEFN (FN ENTRY) (ADDPROP FN 'GLINSTANCEFNS ENTRY)) % edited: 25-Jan-81 18:17 % Add the type SDES to RESULTTYPE in GLCOMP (DE GLADDRESULTTYPE (SDES) (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE SDES)) ((AND (PAIRP RESULTTYPE) (EQ (CAR RESULTTYPE) 'OR)) (COND ((NOT (MEMBER SDES (CDR RESULTTYPE))) (ACONC RESULTTYPE SDES)))) ((NOT (EQUAL SDES RESULTTYPE)) (SETQ RESULTTYPE (LIST 'OR RESULTTYPE SDES))))) % edited: 2-Jan-81 13:37 % Add an entry to the current context for a variable ATM, whose NAME % in context is given, and which has structure STR. The entry is % pushed onto the front of the list at the head of the context. (DE GLADDSTR (ATM NAME STR CONTEXT) (RPLACA CONTEXT (CONS (LIST ATM NAME STR) (CAR CONTEXT)))) % edited: 24-AUG-82 17:16 % Compile code to test if SOURCE is PROPERTY. (DE GLADJ (SOURCE PROPERTY ADJWD) (PROG (ADJL TRANS TMP FETCHCODE) (COND ((EQ ADJWD 'ISASELF) (COND ((SETQ ADJL (GLSTRPROP PROPERTY 'ISA 'self)) (GO A)) (T (RETURN NIL)))) ((SETQ ADJL (GLSTRPROP (CADR SOURCE) ADJWD PROPERTY)) (GO A))) % See if the adjective can be found in a TRANSPARENT substructure. (SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE))) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLADJ (LIST '*GL* (GLXTRTYPE (CAR TRANS))) PROPERTY ADJWD)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR SOURCE) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR SOURCE)) (RETURN TMP)) (T (SETQ TRANS (CDR TRANS)) (GO B))) A (COND ((AND (PAIRP (CADR ADJL)) (MEMQ (CAADR ADJL) '(NOT Not not)) (ATOM (CADADR ADJL)) (NULL (CDDADR ADJL)) (SETQ TMP (GLSTRPROP (CADR SOURCE) ADJWD (CADADR ADJL)))) (SETQ ADJL TMP) (SETQ NOTFLG (NOT NOTFLG)) (GO A))) (RETURN (GLCOMPMSG SOURCE ADJL NIL CONTEXT)))) % edited: 18-NOV-82 11:51 (DE GLAINTERPRETER (L) (PROG (CODE GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS) (SETQ GLNATOM 0) (SETQ FAULTFN 'GLAINTERPRETER) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (SETQ CODE (GLDOA (CONS 'A L))) (RETURN (EVAL (CAR CODE))))) % edited: 26-DEC-82 15:40 % AND operator (DE GLANDFN (LHS RHS) (COND ((NULL LHS) RHS) ((NULL RHS) LHS) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND) (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (APPEND (CAR LHS) (CDAR RHS)) (CADR LHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND)) (LIST (APPEND (CAR LHS) (LIST (CAR RHS))) (CADR LHS))) ((AND (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (CONS 'AND (CONS (CAR LHS) (CDAR RHS))) (CADR LHS))) ((AND (PAIRP (CADR RHS)) (EQ (CAADR RHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'INTERSECTION (CAR LHS) (CAR RHS)) (CADR RHS))) ((GLDOMSG LHS 'AND (LIST RHS))) ((GLUSERSTROP LHS 'AND RHS)) (T (LIST (LIST 'AND (CAR LHS) (CAR RHS)) (CADR RHS))))) % edited: 19-MAY-82 13:54 % Test if ATM is the name of any CAR/CDR combination. If so, the value % is a list of the intervening letters in reverse order. (DE GLANYCARCDR? (ATM) (PROG (RES N NMAX TMP) (OR (AND (EQ (GLNTHCHAR ATM 1) 'C) (EQ (GLNTHCHAR ATM -1) 'R)) (RETURN NIL)) (SETQ NMAX (SUB1 (FlatSize2 ATM))) (SETQ N 2) A (COND ((GREATERP N NMAX) (RETURN RES)) ((OR (EQ (SETQ TMP (GLNTHCHAR ATM N)) 'D) (EQ TMP 'A)) (SETQ RES (CONS TMP RES)) (SETQ N (ADD1 N)) (GO A)) (T (RETURN NIL))))) % edited: 26-OCT-82 15:26 % Try to get indicator IND from an ATOM structure. (DE GLATOMSTRFN (IND DES DESLIST) (PROG (TMP) (RETURN (OR (AND (SETQ TMP (ASSOC 'PROPLIST (CDR DES))) (GLPROPSTRFN IND TMP DESLIST T)) (AND (SETQ TMP (ASSOC 'BINDING (CDR DES))) (GLSTRVALB IND (CADR TMP) '(EVAL *GL*))))))) % edited: 29-DEC-82 10:49 % Test whether STR is a legal ATOM structure. (DE GLATMSTR? (STR) (PROG (TMP) (COND ((OR (AND (CDR STR) (or (NOT (PAIRP (CADR STR))) (AND (CDDR STR) (or (NOT (PAIRP (CADDR STR))) (CDDDR STR)))))) (RETURN NIL))) (COND ((SETQ TMP (ASSOC 'BINDING (CDR STR))) (COND ((OR (CDDR TMP) (NULL (GLOKSTR? (CADR TMP)))) (RETURN NIL))))) (COND ((SETQ TMP (ASSOC 'PROPLIST (CDR STR))) (RETURN (EVERY (CDR TMP) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X))))))))) (RETURN T))) % edited: 23-DEC-82 10:43 % Test whether TYPE is implemented as an ATOM structure. (DE GLATOMTYPEP (TYPE) (PROG (TYPEB) (RETURN (OR (EQ TYPE 'ATOM) (AND (PAIRP TYPE) (MEMQ (CAR TYPE) '(ATOM ATOMOBJECT))) (AND (NE (SETQ TYPEB (GLXTRTYPEB TYPE)) TYPE) (GLATOMTYPEP TYPEB)))))) % edited: 24-AUG-82 17:21 (DE GLBUILDALIST (ALIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL ALIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop ALIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (ACONC LIS (GLBUILDCONS (MKQUOTE (CAR TMP1)) TMP2 T))))) (GO A))) % edited: 9-DEC-82 17:14 % Generate code to build a CONS structure. OPTFLG is true iff the % structure does not need to be a newly created one. (DE GLBUILDCONS (X Y OPTFLG) (COND ((NULL Y) (GLBUILDLIST (LIST X) OPTFLG)) ((AND (PAIRP Y) (EQ (CAR Y) 'LIST)) (GLBUILDLIST (CONS X (CDR Y)) OPTFLG)) ((AND OPTFLG (GLCONST? X) (GLCONST? Y)) (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y)))) ((AND (GLCONSTSTR? X) (GLCONSTSTR? Y)) (LIST 'COPY (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y))))) (T (LIST 'CONS X Y)))) % edited: 9-DEC-82 17:13 % Build a LIST structure, possibly doing compile-time constant % folding. OPTFLG is true iff the structure does not need to be a % newly created copy. (DE GLBUILDLIST (LST OPTFLG) (COND ((EVERY LST (FUNCTION GLCONST?)) (COND (OPTFLG (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))) (T (GLGENCODE (LIST 'APPEND (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))))) ((EVERY LST (FUNCTION GLCONSTSTR?)) (GLGENCODE (LIST 'COPY (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))) (T (CONS 'LIST LST)))) % edited: 19-OCT-82 15:05 % Build code to do (NOT CODE) , doing compile-time folding if % possible. (DE GLBUILDNOT (CODE) (PROG (TMP) (COND ((GLCONST? CODE) (RETURN (NOT (GLCONSTVAL CODE)))) ((NOT (PAIRP CODE)) (RETURN (LIST 'NOT CODE))) ((EQ (CAR CODE) 'NOT) (RETURN (CADR CODE))) ((NOT (ATOM (CAR CODE))) (RETURN NIL)) ((SETQ TMP (ASSOC (CAR CODE) '((EQ NE) (NE EQ) (LEQ GREATERP) (GEQ LESSP)))) (RETURN (CONS (CADR TMP) (CDR CODE)))) (T (RETURN (LIST 'NOT CODE)))))) % edited: 26-OCT-82 16:02 (DE GLBUILDPROPLIST (PLIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL PLIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop PLIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (NCONC LIS (LIST (MKQUOTE (CAR TMP1)) TMP2))))) (GO A))) % edited: 12-NOV-82 11:26 % Build a RECORD structure. (DE GLBUILDRECORD (STR PAIRLIST PREVLST) (PROG (TEMP ITEMS RECORDNAME) (COND ((ATOM (CADR STR)) (SETQ RECORDNAME (CADR STR)) (SETQ ITEMS (CDDR STR))) (T (SETQ ITEMS (CDR STR)))) (COND ((EQ (CAR STR) 'OBJECT) (SETQ ITEMS (CONS '(CLASS ATOM) ITEMS)))) (RETURN (CONS 'Vector (MAPCAR ITEMS (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))) ))))) % edited: 11-NOV-82 12:01 % Generate code to build a structure according to the structure % description STR. PAIRLIST is a list of elements of the form % (SLOTNAME CODE TYPE) for each named slot to be filled in in the % structure. (DE GLBUILDSTR (STR PAIRLIST PREVLST) (PROG (PROPLIS TEMP PROGG TMPCODE ATMSTR) (SETQ ATMSTR '((ATOM) (INTEGER . 0) (REAL . 0.0) (NUMBER . 0) (BOOLEAN) (NIL) (ANYTHING))) (COND ((NULL STR) (RETURN NIL)) ((ATOM STR) (COND ((SETQ TEMP (ASSOC STR ATMSTR)) (RETURN (CDR TEMP))) ((MEMQ STR PREVLST) (RETURN NIL)) ((SETQ TEMP (GLGETSTR STR)) (RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST)))) (T (RETURN NIL)))) ((NOT (PAIRP STR)) (GLERROR 'GLBUILDSTR (LIST "Illegal structure type encountered:" STR)) (RETURN NIL))) (RETURN (CASEQ (CAR STR) (CONS (GLBUILDCONS (GLBUILDSTR (CADR STR) PAIRLIST PREVLST) (GLBUILDSTR (CADDR STR) PAIRLIST PREVLST) NIL)) (LIST (GLBUILDLIST (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST)))) NIL)) (LISTOBJECT (GLBUILDLIST (CONS (MKQUOTE (CAR PREVLST)) (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))))) NIL)) (ALIST (GLBUILDALIST (CDR STR) PREVLST)) (PROPLIST (GLBUILDPROPLIST (CDR STR) PREVLST)) (ATOM (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (COND ((SETQ TEMP (ASSOC 'BINDING STR)) (SETQ TMPCODE (GLBUILDSTR (CADR TEMP) PAIRLIST PREVLST)) (ACONC PROGG (LIST 'SET 'ATOMNAME TMPCODE)))) (COND ((SETQ TEMP (ASSOC 'PROPLIST STR)) (SETQ PROPLIS (CDR TEMP)) (GLPUTPROPS PROPLIS PREVLST))) (ACONC PROGG (COPY '(RETURN ATOMNAME))) PROGG) (ATOMOBJECT (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)))) (T (LIST 'GENSYM)))))) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (LIST 'QUOTE 'CLASS) (MKQUOTE (CAR PREVLST))))) (GLPUTPROPS (CDR STR) PREVLST) (ACONC PROGG (COPY '(RETURN ATOMNAME)))) (TRANSPARENT (AND (NOT (MEMQ (CADR STR) PREVLST)) (SETQ TEMP (GLGETSTR (CADR STR))) (GLBUILDSTR TEMP PAIRLIST (CONS (CADR STR) PREVLST)))) (LISTOF NIL) (RECORD (GLBUILDRECORD STR PAIRLIST PREVLST)) (OBJECT (GLBUILDRECORD STR (CONS (LIST 'CLASS (MKQUOTE (CAR PREVLST)) 'ATOM) PAIRLIST) PREVLST)) (T (COND ((ATOM (CAR STR)) (COND ((SETQ TEMP (ASSOC (CAR STR) PAIRLIST)) (CADR TEMP)) ((AND (ATOM (CADR STR)) (NOT (ASSOC (CADR STR) ATMSTR))) (GLBUILDSTR (CADR STR) NIL PREVLST)) (T (GLBUILDSTR (CADR STR) PAIRLIST PREVLST)))) (T NIL))))))) % edited: 19-MAY-82 14:27 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPE (LST STR) (COND ((NULL LST) STR) ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST (GLGETSTR STR))) ((NOT (PAIRP STR)) (ERROR 0 NIL)) (T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR))))) % edited: 19-MAY-82 14:41 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPEB (LST STR) (COND ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST STR)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((AND (ATOM (CAR STR)) (NOT (MEMQ (CAR STR) GLTYPENAMES)) (CDR STR) (NULL (CDDR STR))) (GLCARCDRRESULTTYPE LST (CADR STR))) ((EQ (CAR LST) 'A) (COND ((OR (EQ (CAR STR) 'LISTOF) (EQ (CAR STR) 'CONS) (EQ (CAR STR) 'LIST)) (GLCARCDRRESULTTYPE (CDR LST) (CADR STR))) (T NIL))) ((EQ (CAR LST) 'D) (COND ((EQ (CAR STR) 'CONS) (GLCARCDRRESULTTYPE (CDR LST) (CADDR STR))) ((EQ (CAR STR) 'LIST) (COND ((CDDR STR) (GLCARCDRRESULTTYPE (CDR LST) (CONS 'LIST (CDDR STR)))) (T NIL))) ((EQ (CAR STR) 'LISTOF) (GLCARCDRRESULTTYPE (CDR LST) STR)))) (T (ERROR 0 NIL)))) % edited: 13-JAN-82 13:45 % Test if X is a CAR or CDR combination up to 3 long. (DE GLCARCDR? (X) (MEMQ X '(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR))) % edited: 5-OCT-82 15:24 (DE GLCC (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN)))) % GSN 11-JAN-83 10:19 % Get the Class of object OBJ. (DE GLCLASS (OBJ) (PROG (CLASS) (RETURN (AND (SETQ CLASS (COND ((VectorP OBJ) (GetV OBJ 0)) ((ATOM OBJ) (GET OBJ 'CLASS)) ((PAIRP OBJ) (CAR OBJ)) (T NIL))) (GLCLASSP CLASS) CLASS)))) % edited: 11-NOV-82 11:23 % Test whether the object OBJ is a member of class CLASS. (DE GLCLASSMEMP (OBJ CLASS) (GLDESCENDANTP (GLCLASS OBJ) CLASS)) % edited: 11-NOV-82 11:45 % See if CLASS is a Class name. (DE GLCLASSP (CLASS) (PROG (TMP) (RETURN (AND (ATOM CLASS) (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (MEMQ (CAR (GLXTRTYPE (CAR TMP))) '(OBJECT ATOMOBJECT LISTOBJECT)))))) % edited: 11-NOV-82 14:24 % Execute a message to CLASS with selector SELECTOR and arguments % ARGS. PROPNAME is one of MSG, ADJ, ISA, PROP. (DE GLCLASSSEND (CLASS SELECTOR ARGS PROPNAME) (PROG (FNCODE) (COND ((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME)) (RETURN (cond ((atom fncode) (eval (cons fncode (mapcar args (function kwote))))) (t (APPLY FNCODE ARGS)))))) (RETURN 'GLSENDFAILURE))) % edited: 24-AUG-82 17:24 % GLISP compiler function. GLAMBDAFN is the atom whose function % definition is being compiled; GLEXPR is the GLAMBDA expression to % be compiled. The compiled function is saved on the property list % of GLAMBDAFN under the indicator GLCOMPILED. The property % GLRESULTTYPE is the RESULT declaration, if specified; GLGLOBALS is % a list of global variables referenced and their types. (DE GLCOMP (GLAMBDAFN GLEXPR GLTYPESUBS) (PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX RESULTTYPE GLGLOBALVARS RESULT GLSEPATOM GLSEPPTR VALBUSY EXPRSTACK) (SETQ GLSEPPTR 0) (COND ((NOT GLQUIETFLG) (PRINT (LIST 'GLCOMP GLAMBDAFN)))) (SETQ EXPRSTACK (LIST GLEXPR)) (SETQ GLNATOM 0) (SETQ GLTOPCTX (LIST NIL)) % Process the argument list of the GLAMBDA. (SETQ NEWARGS (GLDECL (CADR GLEXPR) T NIL GLTOPCTX GLAMBDAFN)) % See if there is a RESULT declaration. (SETQ GLEXPR (CDDR GLEXPR)) (GLSKIPCOMMENTS) (GLRESGLOBAL) (GLSKIPCOMMENTS) (GLRESGLOBAL) (SETQ VALBUSY (NULL (CDR GLEXPR))) (SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX))) (PUT GLAMBDAFN 'GLRESULTTYPE (OR RESULTTYPE (CADR NEWEXPR))) (SETQ RESULT (CONS 'LAMBDA (CONS NEWARGS (CAR NEWEXPR)))) (RETURN (GLUNWRAP RESULT T)))) % edited: 29-JUL-82 11:49 % Compile an abstract function into an instance function given the % specified set of type substitutions. (DE GLCOMPABSTRACT (FN TYPESUBS) (PROG (INSTFN N INSTENT) (SETQ N (ADD1 (OR (GET FN 'GLINSTANCEFNNO) 0))) (PUT FN 'GLINSTANCEFNNO N) (SETQ INSTFN (IMPLODE (NCONC (EXPLODE FN) (CONS '- (EXPLODE N))))) (GLADDINSTANCEFN FN (SETQ INSTENT (LIST INSTFN))) % Now compile the abstract function with the specified type % substitutions. (PUTD INSTFN (GLCOMP INSTFN (GETD FN) TYPESUBS)) (RETURN INSTFN))) % edited: 27-MAY-82 12:58 % Compile the function definition stored for the atom FAULTFN using % the GLISP compiler. (DE GLCOMPILE (FAULTFN) (GLAMBDATRAN (GLGETD FAULTFN))FAULTFN) % edited: 4-MAY-82 11:13 % Compile FN if not already compiled. (DE GLCOMPILE? (FN) (OR (GET FN 'GLCOMPILED) (GLCOMPILE FN))) % edited: 18-NOV-82 11:55 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSG (OBJECT MSGLST ARGLIST CONTEXT) (PROG (GLPROGLST RESULTTYPE METHOD RESULT VTYPE) (SETQ RESULTTYPE (LISTGET (CDDR MSGLST) 'RESULT)) (SETQ METHOD (CADR MSGLST)) (COND ((ATOM METHOD) % Function name is specified. (COND ((LISTGET (CDDR MSGLST) 'OPEN) (RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST) (CONS (CADR OBJECT) (LISTGET (CDDR MSGLST) 'ARGTYPES)) RESULTTYPE (LISTGET (CDDR MSGLST) 'SPECVARS)))) (T (RETURN (LIST (CONS METHOD (CONS (CAR OBJECT) (MAPCAR ARGLIST (FUNCTION CAR)))) (OR (GLRESULTTYPE METHOD (CONS (CADR OBJECT) (MAPCAR ARGLIST (FUNCTION CADR)))) (LISTGET (CDDR MSGLST) 'RESULT))))))) ((NOT (PAIRP METHOD)) (RETURN (GLERROR 'GLCOMPMSG (LIST "The form of Response is illegal for message" (CAR MSGLST))))) ((AND (PAIRP (CAR METHOD)) (MEMQ (CAAR METHOD) '(virtual Virtual VIRTUAL))) (OR (SETQ VTYPE (LISTGET (CDDR MSGLST) 'VTYPE)) (PROGN (SETQ VTYPE (GLMAKEVTYPE (CADR OBJECT) (CAR METHOD))) (NCONC MSGLST (LIST 'VTYPE VTYPE)))) (RETURN (LIST (CAR OBJECT) VTYPE)))) % The Method is a list of stuff to be compiled open. (SETQ CONTEXT (LIST NIL)) (COND ((ATOM (CAR OBJECT)) (GLADDSTR (LIST 'PROG1 (CAR OBJECT)) 'self (CADR OBJECT) CONTEXT)) ((AND (PAIRP (CAR OBJECT)) (EQ (CAAR OBJECT) 'PROG1) (ATOM (CADAR OBJECT)) (NULL (CDDAR OBJECT))) (GLADDSTR (CAR OBJECT) 'self (CADR OBJECT) CONTEXT)) (T (SETQ GLPROGLST (CONS (LIST 'self (CAR OBJECT)) GLPROGLST)) (GLADDSTR 'self NIL (CADR OBJECT) CONTEXT))) (SETQ RESULT (GLPROGN METHOD CONTEXT)) % If more than one expression resulted, embed in a PROGN. (RPLACA RESULT (COND ((CDAR RESULT) (CONS 'PROGN (CAR RESULT))) (T (CAAR RESULT)))) (RETURN (LIST (COND (GLPROGLST (GLGENCODE (LIST 'PROG GLPROGLST (LIST 'RETURN (CAR RESULT))))) (T (CAR RESULT))) (OR RESULTTYPE (CADR RESULT)))))) % edited: 2-DEC-82 14:11 % Compile the function FN Open, given as arguments ARGS with argument % types ARGTYPES. Types may be defined in the definition of function % FN (which may be either a GLAMBDA or LAMBDA function) or by % ARGTYPES; ARGTYPES takes precedence. (DE GLCOMPOPEN (FN ARGS ARGTYPES RESULTTYPE SPCVARS) (PROG (PTR FNDEF GLPROGLST NEWEXPR CONTEXT NEWARGS) % Put a new level on top of CONTEXT. (SETQ CONTEXT (LIST NIL)) (SETQ FNDEF (GLGETD FN)) % Get the parameter declarations and add to CONTEXT. (GLDECL (CADR FNDEF) T NIL CONTEXT NIL) % Make the function parameters into names and put in the values, % hiding any which are simple variables. (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (COND ((EQ ARGS T) (GLADDSTR (CAAR PTR) NIL (OR (CAR ARGTYPES) (CADDAR PTR)) CONTEXT) (SETQ NEWARGS (CONS (CAAR PTR) NEWARGS))) ((AND (ATOM (CAAR ARGS)) (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS))) % Wrap the atom in a PROG1 so it won't match as a name; the PROG1 will % generally be stripped later. (GLADDSTR (LIST 'PROG1 (CAAR ARGS)) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) ((AND (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS)) (PAIRP (CAAR ARGS)) (EQ (CAAAR ARGS) 'PROG1) (ATOM (CADAAR ARGS)) (NULL (CDDAAR ARGS))) (GLADDSTR (CAAR ARGS) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) (T % Since the actual argument is not atomic, make a PROG variable for % it. (SETQ GLPROGLST (CONS (LIST (CAAR PTR) (CAAR ARGS)) GLPROGLST)) (GLADDSTR (CAAR PTR) (CADAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT))) (SETQ PTR (CDR PTR)) (COND ((PAIRP ARGS) (SETQ ARGS (CDR ARGS)))) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ FNDEF (CDDR FNDEF)) % Get rid of comments at start of function. C (COND ((AND FNDEF (PAIRP (CAR FNDEF)) (EQ (CAAR FNDEF) '*)) (SETQ FNDEF (CDR FNDEF)) (GO C))) (SETQ NEWEXPR (GLPROGN FNDEF CONTEXT)) % Get rid of atomic result if it isnt busy outside. (COND ((AND (NOT VALBUSY) (CDAR EXPR) (OR (ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR) 2)))) (AND (PAIRP (CADR PTR)) (EQ (CAADR PTR) 'PROG1) (ATOM (CADADR PTR)) (NULL (CDDADR PTR))))) (RPLACD PTR NIL))) (SETQ RESULT (LIST (COND (GLPROGLST (SETQ PTR (LASTPAIR (CAR NEWEXPR))) (RPLACA PTR (LIST 'RETURN (CAR PTR))) (GLGENCODE (CONS 'PROG (CONS (REVERSIP GLPROGLST) (CAR NEWEXPR))))) ((CDAR NEWEXPR) (CONS 'PROGN (CAR NEWEXPR))) (T (CAAR NEWEXPR))) (OR RESULTTYPE (GLRESULTTYPE FN NIL) (CADR NEWEXPR)))) (COND ((EQ ARGS T) (RPLACA RESULT (LIST 'LAMBDA (REVERSIP NEWARGS) (CAR RESULT))))) (RETURN RESULT))) % edited: 23-DEC-82 11:02 % Compile a LAMBDA expression to compute the property PROPNAME of type % PROPTYPE for structure STR. The property type STR is allowed for % structure access. (DE GLCOMPPROP (STR PROPNAME PROPTYPE) (PROG (CODE PL SUBPL PROPENT GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN) (SETQ FAULTFN 'GLCOMPPROP) (COND ((NOT (MEMQ PROPTYPE '(STR ADJ ISA PROP MSG))) (ERROR 0 NIL))) % If the property is implemented by a named function, return the % function name. (COND ((AND (NE PROPTYPE 'STR) (SETQ PROPENT (GLGETPROP STR PROPNAME PROPTYPE)) (ATOM (CADR PROPENT))) (RETURN (CADR PROPENT)))) % See if the property has already been compiled. (COND ((AND (SETQ PL (GET STR 'GLPROPFNS)) (SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL)))) (RETURN (CADR PROPENT)))) % Compile code for this property and save it. (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE)) (RETURN NIL)) (COND ((NOT PL) (PUT STR 'GLPROPFNS (SETQ PL (COPY '((STR) (PROP) (ADJ) (ISA) (MSG))))) (SETQ SUBPL (ASSOC PROPTYPE PL)))) (RPLACD SUBPL (CONS (CONS PROPNAME CODE) (CDR SUBPL))) (RETURN (CAR CODE)))) % edited: 30-DEC-82 12:21 % Compile a message as a closed form, i.e., function name or LAMBDA % form. (DE GLCOMPPROPL (STR PROPNAME PROPTYPE) (PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR) (COND ((EQ PROPTYPE 'STR) (COND ((SETQ CODE (GLSTRFN PROPNAME STR NIL)) (RETURN (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (SUBSTIP 'self '*GL* (CAR CODE)) T)) (CADR CODE)))) (T (RETURN NIL)))) ((SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME)) (COND ((ATOM (CADR MSGL)) (COND ((LISTGET (CDDR MSGL) 'OPEN) (SETQ CODE (GLCOMPOPEN (CADR MSGL) T (LIST STR) NIL NIL))) (T (SETQ CODE (LIST (CADR MSGL) (GLRESULTTYPE (CADR MSGL) NIL)))))) ((SETQ CODE (GLADJ (LIST 'self STR) PROPNAME PROPTYPE)) (SETQ CODE (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (CAR CODE) T)) (CADR CODE)))))) ((SETQ TRANS (GLTRANSPARENTTYPES STR)) (GO B)) (T (RETURN NIL))) (RETURN (LIST (GLUNWRAP (CAR CODE) T) (OR (CADR CODE) (LISTGET (CDDR MSGL) 'RESULT)))) % Look for the message in a contained TRANSPARENT type. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS)) PROPNAME PROPTYPE)) (COND ((ATOM (CAR TMP)) (GLERROR 'GLCOMPPROPL (LIST "GLISP cannot currently handle inheritance of the property" PROPNAME "which is specified as a function name in a TRANSPARENT subtype. Sorry.")) (RETURN NIL))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) STR NIL)) (SETQ NEWVAR (GLMKVAR)) (GLSTRVAL FETCHCODE NEWVAR) (RETURN (LIST (GLUNWRAP (LIST 'LAMBDA (CONS NEWVAR (CDADAR TMP)) (LIST 'PROG (LIST (LIST (CAADAR TMP) (CAR FETCHCODE))) (LIST 'RETURN (CADDAR TMP)))) T) (CADR TMP)))) (T (SETQ TRANS (CDR TRANS)) (GO B))))) % edited: 30-DEC-82 10:39 % Attempt to infer the type of a constant expression. (DE GLCONSTANTTYPE (EXPR) (PROG (TMP TYPES) (COND ((SETQ TMP (COND ((FIXP EXPR) 'INTEGER) ((NUMBERP EXPR) 'NUMBER) ((ATOM EXPR) 'ATOM) ((STRINGP EXPR) 'STRING) ((NOT (PAIRP EXPR)) 'ANYTHING) ((EVERY EXPR (FUNCTION FIXP)) '(LISTOF INTEGER)) ((EVERY EXPR (FUNCTION NUMBERP)) '(LISTOF NUMBER)) ((EVERY EXPR (FUNCTION ATOM)) '(LISTOF ATOM)) ((EVERY EXPR (FUNCTION STRINGP)) '(LISTOF STRING)))) (RETURN TMP))) (SETQ TYPES (MAPCAR EXPR (FUNCTION GLCONSTANTTYPE))) (COND ((EVERY (CDR TYPES) (FUNCTION (LAMBDA (Y) (EQUAL Y (CAR TYPES))))) (RETURN (LIST 'LISTOF (CAR TYPES)))) (T (RETURN (CONS 'LIST TYPES)))))) % edited: 31-AUG-82 15:38 % Test X to see if it represents a compile-time constant value. (DE GLCONST? (X) (OR (NULL X) (EQ X T) (NUMBERP X) (AND (PAIRP X) (EQ (CAR X) 'QUOTE) (ATOM (CADR X))) (AND (ATOM X) (GET X 'GLISPCONSTANTFLG)))) % edited: 9-DEC-82 17:02 % Test to see if X is a constant structure. (DE GLCONSTSTR? (X) (OR (GLCONST? X) (AND (PAIRP X) (OR (EQ (CAR X) 'QUOTE) (AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NE (CAR X) 'APPEND) (NULL (CDDR X)) (NULL (CADDR X)))) (AND (EQ (CAR X) 'LIST) (EVERY (CDR X) (FUNCTION GLCONSTSTR?))) (AND (EQ (CAR X) 'CONS) (GLCONSTSTR? (CADR X)) (GLCONSTSTR? (CADDR X))))))) % edited: 9-DEC-82 17:07 % Get the value of a compile-time constant (DE GLCONSTVAL (X) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) ((AND (PAIRP X) (EQ (CAR X) 'QUOTE)) (CADR X)) ((PAIRP X) (COND ((AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NULL (CDDR X)) (NULL (CADDR X)))) (CADADR X)) ((EQ (CAR X) 'LIST) (MAPCAR (CDR X) (FUNCTION GLCONSTVAL))) ((EQ (CAR X) 'CONS) (CONS (GLCONSTVAL (CADR X)) (GLCONSTVAL (CADDR X)))) (T (ERROR 0 NIL)))) ((AND (ATOM X) (GET X 'GLISPCONSTANTFLG)) (GET X 'GLISPCONSTANTVAL)) (T (ERROR 0 NIL)))) % edited: 5-OCT-82 15:23 (DE GLCP (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN) (GLP FN)))) % edited: 29-DEC-82 11:04 % Process a declaration list from a GLAMBDA expression. Each element % of the list is of the form <var>, <var>:<str-descr>, :<str-descr>, % or <var>: (A <str-descr>) or (A <str-descr>) . Forms without a % variable are accepted only if NOVAROK is true. If VALOK is true, a % PROG form (variable value) is allowed. The result is a list of % variable names. (DE GLDECL (LST NOVAROK VALOK GLTOPCTX FN) (PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR ARGTYPES) A % Get the next variable/description from LST (COND ((NULL LST) (COND (FN (PUT FN 'GLARGUMENTTYPES (REVERSIP ARGTYPES)))) (RETURN (REVERSIP RESULT)))) (SETQ TOP (pop LST)) (COND ((NOT (ATOM TOP)) (GO B))) (SETQ VARS NIL) (SETQ STR NIL) (GLSEPINIT TOP) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (COND ((EQ FIRST ':) (COND ((NULL SECOND) (COND ((AND NOVAROK LST (GLOKSTR? (CAR LST))) (GLDECLDS (GLMKVAR) (pop LST)) (GO A)) (T (GO E)))) ((AND NOVAROK (GLOKSTR? SECOND) (NULL (GLSEPNXT))) (GLDECLDS (GLMKVAR) SECOND) (GO A)) (T (GO E))))) D % At least one variable name has been found. Collect other variable % names until a <type> is found. (SETQ VARS (ACONC VARS FIRST)) (COND ((NULL SECOND) (GO C)) ((EQ SECOND ':) (COND ((AND (SETQ THIRD (GLSEPNXT)) (GLOKSTR? THIRD) (NULL (GLSEPNXT))) (SETQ STR THIRD) (GO C)) ((AND (NULL THIRD) (GLOKSTR? (CAR LST))) (SETQ STR (pop LST)) (GO C)) (T (GO E)))) ((EQ SECOND '!,) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)) ((ATOM (CAR LST)) (GLSEPINIT (pop LST)) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)))) (T (GO E))) C % Define the <type> for each variable on VARS. (MAPC VARS (FUNCTION (LAMBDA (X) (GLDECLDS X STR)))) (GO A) B % The top of LST is non-atomic. Must be either (A <type>) or % (<var> <value>) . (COND ((AND (GL-A-AN? (CAR TOP)) NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) ((AND VALOK (NOT (GL-A-AN? (CAR TOP))) (ATOM (CAR TOP)) (CDR TOP)) (SETQ EXPR (CDR TOP)) (SETQ TMP (GLDOEXPR NIL GLTOPCTX T)) (COND (EXPR (GO E))) (GLADDSTR (CAR TOP) NIL (CADR TMP) GLTOPCTX) (SETQ RESULT (CONS (LIST (CAR TOP) (CAR TMP)) RESULT))) ((AND NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) (T (GO E))) (GO A) E (GLERROR 'GLDECL (LIST "Bad argument structure" LST)) (RETURN NIL))) % edited: 26-JUL-82 17:25 % Add ATM to the RESULT list of GLDECL, and declare its structure. (DE GLDECLDS (ATM STR) (PROG NIL % If a substitution exists for this type, use it. (COND (GLTYPESUBS (SETQ STR (GLSUBSTTYPE STR GLTYPESUBS)))) (SETQ RESULT (CONS ATM RESULT)) (SETQ ARGTYPES (CONS STR ARGTYPES)) (GLADDSTR ATM NIL STR GLTOPCTX))) % edited: 19-MAY-82 13:33 % Define the result types for a list of functions. The format of the % argument is a list of dotted pairs, (FN . TYPE) (DE GLDEFFNRESULTTYPES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (PUT Y 'GLRESULTTYPE (CAR X))))))))) % edited: 19-MAY-82 13:05 % Define the result type functions for a list of functions. The format % of the argument is a list of dotted pairs, (FN . TYPEFN) (DE GLDEFFNRESULTTYPEFNS (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PUT (CAR X) 'GLRESULTTYPEFN (CDR X)))))) % edited: 26-OCT-82 12:18 % Define properties for an object type. Each property is of the form % (<propname> (<definition>) <properties>) (DE GLDEFPROP (OBJECT PROP LST) (PROG (LSTP) (MAPC LST (FUNCTION (LAMBDA (X) (COND ((NOT (OR (AND (EQ PROP 'SUPERS) (ATOM X)) (AND (PAIRP X) (ATOM (CAR X)) (CDR X)))) (PRIN1 "GLDEFPROP: For object ") (PRIN1 OBJECT) (PRIN1 " the ") (PRIN1 PROP) (PRIN1 " property ") (PRIN1 X) (PRIN1 " has bad form.") (TERPRI) (PRIN1 "This property was ignored.") (TERPRI)) (T (SETQ LSTP (CONS X LSTP))))))) (NCONC (GET OBJECT 'GLSTRUCTURE) (LIST PROP (REVERSIP LSTP))))) % edited: 23-DEC-82 11:19 % Process a Structure Description. The format of the argument is the % name of the structure followed by its structure description, % followed by other optional arguments. (DE GLDEFSTR (LST) (PROG (STRNAME STR) (SETQ STRNAME (pop LST)) (SETQ STR (pop LST)) (PUT STRNAME 'GLSTRUCTURE (LIST STR)) (COND ((NOT (GLOKSTR? STR)) (PRIN1 STRNAME) (PRIN1 " has faulty structure specification.") (TERPRI))) (COND ((NOT (MEMQ STRNAME GLOBJECTNAMES)) (SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES)))) % Process the remaining specifications, if any. Each additional % specification is a list beginning with a keyword. LP (COND ((NULL LST) (RETURN NIL))) (CASEQ (CAR LST) ((ADJ Adj adj) (GLDEFPROP STRNAME 'ADJ (CADR LST))) ((PROP Prop prop) (GLDEFPROP STRNAME 'PROP (CADR LST))) ((ISA Isa IsA isA isa) (GLDEFPROP STRNAME 'ISA (CADR LST))) ((MSG Msg msg) (GLDEFPROP STRNAME 'MSG (CADR LST))) (T (GLDEFPROP STRNAME (CAR LST) (CADR LST)))) (SETQ LST (CDDR LST)) (GO LP))) % edited: 27-APR-82 11:01 (DF GLDEFSTRNAMES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PROG (TMP) (COND ((SETQ TMP (ASSOC (CAR X) GLUSERSTRNAMES)) (RPLACD TMP (CDR X))) (T (SETQ GLUSERSTRNAMES (ACONC GLUSERSTRNAMES X)) ))))))) % edited: 26-MAY-82 14:53 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG))))) % edited: 27-MAY-82 13:00 % This function is called by the user to define a unit package to the % GLISP system. The argument, a unit record, is a list consisting of % the name of a function to test an entity to see if it is a unit of % the units package, the name of the unit package's runtime GET % function, and an ALIST of operations on units and the functions to % perform those operations. Operations include GET, PUT, ISA, ISADJ, % NCONC, REMOVE, PUSH, and POP. (DE GLDEFUNITPKG (UNITREC) (PROG (LST) (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (SETQ GLUNITPKGS (ACONC GLUNITPKGS UNITREC)) (RETURN NIL)) ((EQ (CAAR LST) (CAR UNITREC)) (RPLACA LST UNITREC))) (SETQ LST (CDR LST)) (GO A))) % edited: 30-OCT-81 12:23 % Remove the GLISP structure definition for NAME. (DE GLDELDEF (NAME TYPE) (REMPROP NAME 'GLSTRUCTURE)) % edited: 28-NOV-82 15:18 (DE GLDESCENDANTP (SUBCLASS CLASS) (PROG (SUPERS) (COND ((EQ SUBCLASS CLASS) (RETURN T))) (SETQ SUPERS (GLGETSUPERS SUBCLASS)) LP (COND ((NULL SUPERS) (RETURN NIL)) ((GLDESCENDANTP (CAR SUPERS) CLASS) (RETURN T))) (SETQ SUPERS (CDR SUPERS)) (GO LP))) % edited: 27-MAY-82 13:00 % Function to compile an expression of the form (A <type> ...) (DE GLDOA (EXPR) (PROG (TYPE UNITREC TMP) (SETQ TYPE (CADR EXPR)) (COND ((GLGETSTR TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'A (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST EXPR)))) (T (GLERROR 'GLDOA (LIST "The type" TYPE "is not defined.")))))) % edited: 12-NOV-82 11:10 % Compile code for Case statement. (DE GLDOCASE (EXPR) (PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB) (SETQ TYPEOK T) (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (CAR TMP)) (SETQ SELECTORTYPE (CADR TMP)) (SETQ EXPR (CDDR EXPR)) % Get rid of of if present (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ EXPR (CDR EXPR)))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS 'SELECTQ (CONS SELECTOR (ACONC RESULT ELSECLAUSE)))) RESULTTYPE))) ((MEMQ (CAR EXPR) '(ELSE Else else)) (SETQ TMP (GLPROGN (CDR EXPR) CONTEXT)) (SETQ ELSECLAUSE (COND ((CDAR TMP) (CONS 'PROGN (CAR TMP))) (T (CAAR TMP)))) (SETQ EXPR NIL)) (T (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (SETQ RESULT (ACONC RESULT (CONS (COND ((ATOM (CAAR EXPR)) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES (CAAR EXPR))) (CADR TMPB)) (CAAR EXPR))) (T (MAPCAR (CAAR EXPR) (FUNCTION (LAMBDA (X) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES X)) (CADR TMPB)) X)))))) (CAR TMP)))))) % If all the result types are the same, then we know the result of the % Case statement. (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 23-APR-82 14:38 % Compile a COND expression. (DE GLDOCOND (CONDEXPR) (PROG (RESULT TMP TYPEOK RESULTTYPE) (SETQ TYPEOK T) A (COND ((NULL (SETQ CONDEXPR (CDR CONDEXPR))) (GO B))) (SETQ TMP (GLPROGN (CAR CONDEXPR) CONTEXT)) (COND ((NE (CAAR TMP) NIL) (SETQ RESULT (ACONC RESULT (CAR TMP))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ RESULTTYPE NIL) (SETQ TYPEOK NIL))))))) (COND ((NE (CAAR TMP) T) (GO A))) B (RETURN (LIST (COND ((AND (NULL (CDR RESULT)) (EQ (CAAR RESULT) T)) (CONS 'PROGN (CDAR RESULT))) (T (CONS 'COND RESULT))) (AND TYPEOK RESULTTYPE))))) % edited: 30-DEC-82 10:49 % Compile a single expression. START is set if EXPR is the start of a % new expression, i.e., if EXPR might be a function call. The global % variable EXPR is the expression, CONTEXT the context in which it % is compiled. VALBUSY is T if the value of the expression is needed % outside the expression. The value is a list of the new expression % and its value-description. (DE GLDOEXPR (START CONTEXT VALBUSY) (PROG (FIRST TMP RESULT) (SETQ EXPRSTACK (CONS EXPR EXPRSTACK)) (COND ((NOT (PAIRP EXPR)) (GLERROR 'GLDOEXPR (LIST "Expression is not a list.")) (GO OUT)) ((AND (NOT START) (STRINGP (CAR EXPR))) (SETQ RESULT (LIST (PROG1 (CAR EXPR) (SETQ EXPR (CDR EXPR))) 'STRING)) (GO OUT)) ((OR (NOT (IDP (CAR EXPR))) (NOT START)) (GO A))) % Test the initial atom to see if it is a function name. It is assumed % to be a function name if it doesnt contain any GLISP operators and % the following atom doesnt start with a GLISP binary operator. (COND ((AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAR EXPR) '*)) (SETQ RESULT (LIST EXPR NIL)) (GO OUT)) ((MEMQ (CAR EXPR) ''Quote) (SETQ FIRST (CAR EXPR)) (GO B))) (GLSEPINIT (CAR EXPR)) % See if the initial atom contains an expression operator. (COND ((NE (SETQ FIRST (GLSEPNXT)) (CAR EXPR)) (COND ((OR (MEMQ (CAR EXPR) '(APPLY* BLKAPPLY* PACK* PP*)) (GETD (CAR EXPR)) (GET (CAR EXPR) 'MACRO) (AND (NE FIRST '~) (GLOPERATOR? FIRST))) (GLSEPCLR) (SETQ FIRST (CAR EXPR)) (GO B)) (T (GLSEPCLR) (GO A)))) ((OR (EQ FIRST '~) (EQ FIRST '-)) (GLSEPCLR) (GO A)) ((OR (NOT (PAIRP (CDR EXPR))) (NOT (IDP (CADR EXPR)))) (GO B))) % See if the initial atom is followed by an expression operator. (GLSEPINIT (CADR EXPR)) (SETQ TMP (GLSEPNXT)) (GLSEPCLR) (COND ((GLOPERATOR? TMP) (GO A))) % The EXPR is a function reference. Test for system functions. B (SETQ RESULT (CASEQ FIRST ('Quote (LIST EXPR (GLCONSTANTTYPE (CADR EXPR)))) ((GO Go go) (LIST EXPR NIL)) ((PROG Prog prog) (GLDOPROG EXPR CONTEXT)) ((FUNCTION Function function) (GLDOFUNCTION EXPR NIL CONTEXT T)) ((SETQ Setq setq) (GLDOSETQ EXPR)) ((COND Cond cond) (GLDOCOND EXPR)) ((RETURN Return return) (GLDORETURN EXPR)) ((FOR For for) (GLDOFOR EXPR)) ((THE The the) (GLDOTHE EXPR)) ((THOSE Those those) (GLDOTHOSE EXPR)) ((IF If if) (GLDOIF EXPR CONTEXT)) ((A a AN An an) (GLDOA EXPR)) ((_ SEND Send send) (GLDOSEND EXPR)) ((PROGN PROG2) (GLDOPROGN EXPR)) (PROG1 (GLDOPROG1 EXPR CONTEXT)) ((SELECTQ CASEQ) (GLDOSELECTQ EXPR CONTEXT)) ((WHILE While while) (GLDOWHILE EXPR CONTEXT)) ((REPEAT Repeat repeat) (GLDOREPEAT EXPR)) ((CASE Case case) (GLDOCASE EXPR)) ((MAP MAPLIST MAPCON MAPC MAPCAR MAPCONC MAPCAN) (GLDOMAP EXPR)) (T (GLUSERFN EXPR)))) (GO OUT) A % The current EXPR is possibly a GLISP expression. Parse the next % subexpression using GLPARSEXPR. (SETQ RESULT (GLPARSEXPR)) OUT (SETQ EXPRSTACK (CDR EXPRSTACK)) (RETURN RESULT))) % edited: 2-DEC-82 13:35 % Compile code for a FOR loop. (DE GLDOFOR (EXPR) (PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT LOOPCONTENTS SINGFLAG LOOPCOND COLLECTCODE) (SETQ ORIGEXPR EXPR) (pop EXPR) % Parse the forms (FOR EACH <set> ...) and (FOR <var> IN <set> ...) (COND ((MEMQ (CAR EXPR) '(EACH Each each)) (SETQ SINGFLAG T) (pop EXPR)) ((AND (ATOM (CAR EXPR)) (MEMQ (CADR EXPR) '(IN In in))) (SETQ LOOPVAR (pop EXPR)) (pop EXPR)) (T (GO X))) % Now get the <set> (COND ((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG))) (GO X))) (SETQ DTYPE (GLXTRTYPE (CADR DOMAIN))) (COND ((OR (NULL DTYPE) (EQ DTYPE 'ANYTHING)) (SETQ DTYPE '(LISTOF ANYTHING))) ((OR (not (pairp dtype))(NE (CAR DTYPE) 'LISTOF)) (OR (and (pairp (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (eq (car dtype) 'LISTOF)) (GO X)))) % Add a level onto the context for the inside of the loop. (SETQ NEWCONTEXT (CONS NIL CONTEXT)) % If a loop variable wasnt specified, make one. (OR LOOPVAR (SETQ LOOPVAR (GLMKVAR))) (GLADDSTR LOOPVAR (AND SINGFLAG DOMAINNAME) (CADR DTYPE) NEWCONTEXT) % See if a condition is specified. If so, add it to LOOPCOND. (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT NIL NIL))) ((MEMQ (CAR EXPR) '(WHICH Which which WHO Who who THAT That that)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT T T)))) (COND ((AND EXPR (MEMQ (CAR EXPR) '(when When WHEN))) (pop EXPR) (SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT T))))) (COND ((MEMQ (CAR EXPR) '(collect Collect COLLECT)) (pop EXPR) (SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T))) (T (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) (SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT))))) (RETURN (GLMAKEFORLOOP LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)) X (RETURN (GLUSERFN ORIGEXPR)))) % edited: 29-DEC-82 15:09 % Compile a functional expression. TYPES is a list of argument types % which is sent in from outside, e.g. when a mapping function is % compiled. (DE GLDOFUNCTION (EXPR ARGTYPES CONTEXT VALBUSY) (PROG (NEWCODE RESULTTYPE PTR ARGS) (COND ((NOT (AND (PAIRP EXPR) (MEMQ (CAR EXPR) ''FUNCTION))) (RETURN (GLPUSHEXPR EXPR T CONTEXT T))) ((ATOM (CADR EXPR)) (RETURN (LIST EXPR (GLRESULTTYPE (CADR EXPR) ARGTYPES)))) ((NOT (MEMQ (CAADR EXPR) '(GLAMBDA LAMBDA))) (GLERROR 'GLDOFUNCTION (LIST "Bad functional form.")))) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ ARGS (GLDECL (CADADR EXPR) T NIL CONTEXT NIL)) (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (GLADDSTR (CAAR PTR) NIL (OR (CADDAR PTR) (CAR ARGTYPES)) CONTEXT) (SETQ PTR (CDR PTR)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ NEWCODE (GLPROGN (CDDADR EXPR) CONTEXT)) (RETURN (LIST (LIST 'FUNCTION (CONS 'LAMBDA (CONS ARGS (CAR NEWCODE)))) (CADR NEWCODE))))) % edited: 4-MAY-82 10:46 % Process an IF ... THEN expression. (DE GLDOIF (EXPR CONTEXT) (PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT) (SETQ OLDCONTEXT CONTEXT) (pop EXPR) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'COND CONDLIST) TYPE)))) (SETQ CONTEXT (CONS NIL OLDCONTEXT)) (SETQ PRED (GLPREDICATE NIL CONTEXT NIL T)) (COND ((MEMQ (CAR EXPR) '(THEN Then then)) (pop EXPR))) (SETQ ACTIONS (CONS (CAR PRED) NIL)) (SETQ TYPE (CADR PRED)) C (SETQ CONDLIST (ACONC CONDLIST ACTIONS)) B (COND ((NULL EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSEIF ElseIf Elseif elseIf elseif)) (pop EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSE Else else)) (pop EXPR) (SETQ ACTIONS (CONS T NIL)) (SETQ TYPE 'BOOLEAN) (GO C)) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (ACONC ACTIONS (CAR TMP)) (SETQ TYPE (CADR TMP)) (GO B)) (T (GLERROR 'GLDOIF (LIST "IF statement contains bad code.")))))) % edited: 16-DEC-81 15:47 % Compile a LAMBDA expression for which the ARGTYPES are given. (DE GLDOLAMBDA (EXPR ARGTYPES CONTEXT) (PROG (ARGS NEWEXPR VALBUSY) (SETQ ARGS (CADR EXPR)) (SETQ CONTEXT (CONS NIL CONTEXT)) LP (COND (ARGS (GLADDSTR (CAR ARGS) NIL (CAR ARGTYPES) CONTEXT) (SETQ ARGS (CDR ARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP))) (SETQ VALBUSY T) (SETQ NEWEXPR (GLPROGN (CDDR EXPR) CONTEXT)) (RETURN (LIST (CONS 'LAMBDA (CONS (CADR EXPR) (CAR NEWEXPR))) (CADR NEWEXPR))))) % edited: 30-MAY-82 16:12 % Get a domain specification from the EXPR. If SINGFLAG is set and the % top of EXPR is a simple atom, the atom is made plural and used as % a variable or field name. (DE GLDOMAIN (SINGFLAG) (PROG (NAME FIRST) (COND ((MEMQ (CAR EXPR) '(THE The the)) (SETQ FIRST (CAR EXPR)) (RETURN (GLPARSFLD NIL))) ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (SETQ NAME (GLSEPNXT)) (CAR EXPR)) (pop EXPR) (SETQ DOMAINNAME NAME) (RETURN (COND (SINGFLAG (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ FIRST 'THE) (SETQ EXPR (CONS (GLPLURAL NAME) EXPR)) (GLPARSFLD NIL)) (T (GLIDNAME (GLPLURAL NAME) NIL)))) (T (GLIDNAME NAME NIL))))) (T (GLSEPCLR) (RETURN (GLDOEXPR NIL CONTEXT T))))) (T (RETURN (GLDOEXPR NIL CONTEXT T)))))) % edited: 29-DEC-82 14:50 % Compile code for MAP functions. MAPs are treated specially so that % types can be propagated. (DE GLDOMAP (EXPR) (PROG (MAPFN MAPSET SETTYPE MAPCODE NEWCODE RESULTTYPE ITEMTYPE) (SETQ MAPFN (CAR EXPR)) (SETQ EXPR (CDR EXPR)) (PROGN (SETQ MAPSET (GLDOEXPR NIL CONTEXT T)) (COND ((OR (NULL EXPR) (CDR EXPR)) (GLERROR 'GLDOMAP (LIST "Bad form of mapping function."))) (T (SETQ MAPCODE (CAR EXPR))))) (SETQ SETTYPE (GLXTRTYPEB (CADR MAPSET))) (COND ((AND (PAIRP SETTYPE) (EQ (CAR SETTYPE) 'LISTOF)) (SETQ ITEMTYPE (CASEQ MAPFN ((MAP MAPLIST MAPCON) SETTYPE) ((MAPC MAPCAR MAPCONC MAPCAN) (CADR SETTYPE)) (T (ERROR 0 NIL)))))) (SETQ NEWCODE (GLDOFUNCTION MAPCODE (LIST ITEMTYPE) CONTEXT (MEMQ MAPFN '(MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) ))) (SETQ RESULTTYPE (CASEQ MAPFN ((MAP MAPC) NIL) ((MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) (LIST 'LISTOF (CADR NEWCODE))) (T (ERROR 0 NIL)))) (RETURN (LIST (GLGENCODE (LIST MAPFN (CAR MAPSET) (CAR NEWCODE))) RESULTTYPE)))) % edited: 28-NOV-82 15:20 % Attempt to compile code for the sending of a message to an object. % OBJECT is the destination, in the form (<code> <type>) , SELECTOR % is the message selector, and ARGS is a list of arguments of the % form (<code> <type>) . The result is of this form, or NIL if % failure. (DE GLDOMSG (OBJECT SELECTOR ARGS) (PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (COND ((SETQ METHOD (GLSTRPROP TYPE 'MSG SELECTOR)) (RETURN (COND ((LISTGET (CDDR METHOD) 'MESSAGE) (LIST (CONS 'SEND (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR))))) (LISTGET (CDDR METHOD) 'RESULT))) (T (GLCOMPMSG OBJECT METHOD ARGS CONTEXT))))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'MSG (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST OBJECT SELECTOR ARGS)))) ((SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT)))) ((AND (MEMQ TYPE '(NUMBER REAL INTEGER)) (MEMQ SELECTOR '(+ - * / ^ > < >= <=)) ARGS (NULL (CDR ARGS)) (MEMQ (GLXTRTYPE (CADAR ARGS)) '(NUMBER REAL INTEGER))) (RETURN (GLREDUCEARITH SELECTOR OBJECT (CAR ARGS)))) (T (RETURN NIL))) % See if the message can be handled by a TRANSPARENT subobject. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLDOMSG (LIST '*GL* (GLXTRTYPE (CAR TRANS))) SELECTOR ARGS)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR OBJECT) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR OBJECT)) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % edited: 19-MAY-82 11:36 % Compile a PROG expression. (DE GLDOPROG (EXPR CONTEXT) (PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE) (pop EXPR) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ PROGLST (GLDECL (pop EXPR) NIL T CONTEXT NIL)) (SETQ CONTEXT (CONS NIL CONTEXT)) % Compile the contents of the PROG onto NEWEXPR % Compile the next expression in a PROG. L (COND ((NULL EXPR) (GO X))) (SETQ NEXTEXPR (pop EXPR)) (COND ((ATOM NEXTEXPR) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) % ***** % Set up the context for the label we just found. (GO L)) ((NOT (PAIRP NEXTEXPR)) (GLERROR 'GLDOPROG (LIST "PROG contains bad stuff:" NEXTEXPR)) (GO L)) ((EQ (CAR NEXTEXPR) '*) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) (GO L))) (COND ((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL)) (SETQ NEWEXPR (CONS (CAR TMP) NEWEXPR)))) (GO L) X (SETQ RESULT (CONS 'PROG (CONS PROGLST (REVERSIP NEWEXPR)))) (RETURN (LIST RESULT RESULTTYPE)))) % edited: 5-NOV-81 14:31 % Compile a PROGN in the source program. (DE GLDOPROGN (EXPR) (PROG (RES) (SETQ RES (GLPROGN (CDR EXPR) CONTEXT)) (RETURN (LIST (CONS (CAR EXPR) (CAR RES)) (CADR RES))))) % edited: 25-JAN-82 17:34 % Compile a PROG1, whose result is the value of its first argument. (DE GLDOPROG1 (EXPR CONTEXT) (PROG (RESULT TMP TYPE TYPEFLG) (SETQ EXPR (CDR EXPR)) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'PROG1 (REVERSIP RESULT)) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG))) (SETQ RESULT (CONS (CAR TMP) RESULT)) % Get the result type from the first item of the PROG1. (COND ((NOT TYPEFLG) (SETQ TYPE (CADR TMP)) (SETQ TYPEFLG T))) (GO A)) (T (GLERROR 'GLDOPROG1 (LIST "PROG1 contains bad subexpression.")) (pop EXPR) (GO A))))) % edited: 26-MAY-82 15:12 (DE GLDOREPEAT (EXPR) (PROG (ACTIONS TMP LABEL) (pop EXPR) A (COND ((MEMQ (CAR EXPR) '(UNTIL Until until)) (pop EXPR)) ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (RETURN (GLERROR 'GLDOREPEAT (LIST "REPEAT contains bad subexpression."))))) (COND ((OR (NULL EXPR) (NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL))) EXPR) (GLERROR 'GLDOREPEAT (LIST "REPEAT contains no UNTIL or bad UNTIL clause")) (SETQ TMP (LIST T 'BOOLEAN)))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (CONS 'PROG (CONS NIL (CONS LABEL (ACONC ACTIONS (LIST 'COND (LIST (GLBUILDNOT (CAR TMP)) (LIST 'GO LABEL))))))) NIL)))) % edited: 7-Apr-81 11:49 % Compile a RETURN, capturing the type of the result as a type of the % function result. (DE GLDORETURN (EXPR) (PROG (TMP) (pop EXPR) (COND ((NULL EXPR) (GLADDRESULTTYPE NIL) (RETURN '((RETURN) NIL))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (GLADDRESULTTYPE (CADR TMP)) (RETURN (LIST (LIST 'RETURN (CAR TMP)) (CADR TMP))))))) % edited: 26-AUG-82 09:30 % Compile a SELECTQ. Special treatment is necessary in order to quote % the selectors implicitly. (DE GLDOSELECTQ (EXPR CONTEXT) (PROG (RESULT RESULTTYPE TYPEOK KEY TMP TMPB FN) (SETQ FN (CAR EXPR)) (SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)))) (SETQ TYPEOK T) (SETQ EXPR (CDDR EXPR)) % If the selection criterion is constant, do it directly. (COND ((OR (SETQ KEY (NUMBERP (CAR RESULT))) (AND (PAIRP (CAR RESULT)) (EQ (CAAR RESULT) 'QUOTE) (SETQ KEY (CADAR RESULT)))) (SETQ TMP (SOME EXPR (FUNCTION (LAMBDA (X) (COND ((ATOM (CAR X)) (EQUAL KEY (CAR X))) ((PAIRP (CAR X)) (MEMBER KEY (CAR X))) (T NIL)))))) (COND ((OR (NULL TMP) (NULL (CDR TMP))) (SETQ TMPB (GLPROGN (LASTPAIR EXPR) CONTEXT))) (T (SETQ TMPB (GLPROGN (CDAR TMP) CONTEXT)))) (RETURN (LIST (CONS 'PROGN (CAR TMPB)) (CADR TMPB))))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS FN RESULT)) RESULTTYPE)))) (SETQ RESULT (ACONC RESULT (COND ((OR (CDR EXPR) (EQ FN 'CASEQ)) (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (CONS (CAAR EXPR) (CAR TMP))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (CAR TMP))))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 4-JUN-82 15:35 % Compile code for the sending of a message to an object. The syntax % of the message expression is % (_ <object> <selector> <arg1>...<argn>) , where the _ may % optionally be SEND, Send, or send. (DE GLDOSEND (EXPRR) (PROG (EXPR OBJECT SELECTOR ARGS TMP FNNAME) (SETQ FNNAME (CAR EXPRR)) (SETQ EXPR (CDR EXPRR)) (SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (pop EXPR)) (COND ((OR (NULL SELECTOR) (NOT (IDP SELECTOR))) (RETURN (GLERROR 'GLDOSEND (LIST SELECTOR "is an illegal message Selector."))))) % Collect arguments of the message, if any. A (COND ((NULL EXPR) (COND ((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS)) (RETURN TMP)) (T % No message was defined, so just pass it through and hope one will be % defined by runtime. (RETURN (LIST (GLGENCODE (CONS FNNAME (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (CADR OBJECT)))))) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (SETQ ARGS (ACONC ARGS TMP)) (GO A)) (T (GLERROR 'GLDOSEND (LIST "A message argument is bad.")))))) % edited: 7-Apr-81 11:52 % Compile a SETQ expression (DE GLDOSETQ (EXPR) (PROG (VAR) (pop EXPR) (SETQ VAR (pop EXPR)) (RETURN (GLDOVARSETQ VAR (GLDOEXPR NIL CONTEXT T))))) % edited: 20-MAY-82 15:13 % Process a THE expression in a list. (DE GLDOTHE (EXPR) (PROG (RESULT) (SETQ RESULT (GLTHE NIL)) (COND (EXPR (GLERROR 'GLDOTHE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 20-MAY-82 15:16 % Process a THE expression in a list. (DE GLDOTHOSE (EXPR) (PROG (RESULT) (SETQ EXPR (CDR EXPR)) (SETQ RESULT (GLTHE T)) (COND (EXPR (GLERROR 'GLDOTHOSE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 5-MAY-82 15:51 % Compile code to do a SETQ of VAR to the RHS. If the type of VAR is % unknown, it is set to the type of RHS. (DE GLDOVARSETQ (VAR RHS) (PROG NIL (GLUPDATEVARTYPE VAR (CADR RHS)) (RETURN (LIST (LIST 'SETQ VAR (CAR RHS)) (CADR RHS))))) % edited: 4-MAY-82 10:46 (DE GLDOWHILE (EXPR CONTEXT) (PROG (ACTIONS TMP LABEL) (SETQ CONTEXT (CONS NIL CONTEXT)) (pop EXPR) (SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T)))) (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) A (COND ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (GLERROR 'GLDOWHILE (LIST "Bad stuff in While statement:" EXPR)) (pop EXPR) (GO A))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (LIST 'PROG NIL LABEL (LIST 'COND (ACONC ACTIONS (LIST 'GO LABEL)))) NIL)))) % edited: 23-DEC-82 10:47 % Produce code to test the two sides for equality. (DE GLEQUALFN (LHS RHS) (PROG (TMP LHSTP RHSTP) (RETURN (COND ((SETQ TMP (GLDOMSG LHS '= (LIST RHS))) TMP) ((SETQ TMP (GLUSERSTROP LHS '= RHS)) TMP) (T (SETQ LHSTP (CADR LHS)) (SETQ RHSTP (CADR RHS)) (LIST (COND ((NULL (CAR RHS)) (LIST 'NULL (CAR LHS))) ((NULL (CAR LHS)) (LIST 'NULL (CAR RHS))) (T (GLGENCODE (LIST (COND ((OR (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER)) 'EQP) ((OR (GLATOMTYPEP LHSTP) (GLATOMTYPEP RHSTP)) 'EQ) ((AND (EQ LHSTP 'STRING) (EQ RHSTP 'STRING)) 'STREQUAL) (T 'EQUAL)) (CAR LHS) (CAR RHS))))) 'BOOLEAN)))))) % edited: 23-SEP-82 11:52 (DF GLERR (ERREXP) (PRIN1 "Execution of GLISP error expression: ")(PRINT ERREXP)(ERROR 0 NIL)) % GSN 7-JAN-83 17:08 % If a PROGN occurs within a PROGN, expand it by splicing its contents % into the top-level list. (DE GLEXPANDPROGN (LST) (MAP LST (FUNCTION (LAMBDA (X) (COND ((NOT (PAIRP (CAR X)))) ((MEMQ (CAAR X) '(PROGN PROG2)) (COND ((CDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDAR X)))) (RPLACA X (CADAR X))) ((AND (EQ (CAAR X) 'PROG) (NULL (CADAR X)) (EVERY (CDDAR X) (FUNCTION (LAMBDA (Y) (NOT (ATOM Y))))) (NOT (GLOCCURS 'RETURN (CDDAR X)))) (COND ((CDDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDDAR X)))) (RPLACA X (CADDAR X)))))))) % edited: 9-JUN-82 12:55 % Test if EXPR is expensive to compute. (DE GLEXPENSIVE? (EXPR) (COND ((ATOM EXPR) NIL) ((NOT (PAIRP EXPR)) (ERROR 0 NIL)) ((MEMQ (CAR EXPR) '(CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR CADDDR)) (GLEXPENSIVE? (CADR EXPR))) ((AND (EQ (CAR EXPR) 'PROG1) (NULL (CDDR EXPR))) (GLEXPENSIVE? (CADR EXPR))) (T T))) % edited: 2-Jan-81 14:26 % Find the first entry for variable VAR in the CONTEXT structure. (DE GLFINDVARINCTX (VAR CONTEXT) (AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT)) (GLFINDVARINCTX VAR (CDR CONTEXT))))) % edited: 19-OCT-82 15:19 % Generate code of the form X. The code generated by the compiler is % transformed, if necessary, for the output dialect. (DE GLGENCODE (X) (GLPSLTRANSFM X)) % edited: 20-Mar-81 15:52 % Get the value for the entry KEY from the a-list ALST. GETASSOC is % used so that the corresponding PUTASSOC can be generated by % GLPUTFN. (DE GLGETASSOC (KEY ALST) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC KEY ALST)) (CDR TMP))))) % edited: 30-AUG-82 10:25 (DE GLGETCONSTDEF (ATM) (COND ((GET ATM 'GLISPCONSTANTFLG) (LIST (MKQUOTE (GET ATM 'GLISPCONSTANTVAL)) (GET ATM 'GLISPCONSTANTTYPE))) (T NIL))) % edited: 30-OCT-81 12:20 % Get the GLISP object description for NAME for the file package. (DE GLGETDEF (NAME TYPE) (LIST 'GLDEFSTRQ (CONS NAME (GET NAME 'GLSTRUCTURE)))) % edited: 5-OCT-82 15:06 % Find a way to retrieve the FIELD from the structure pointed to by % SOURCE (which may be a variable name, NIL, or a list (CODE DESCR)) % relative to CONTEXT. The result is a list of code to get the field % and the structure description of the resulting field. (DE GLGETFIELD (SOURCE FIELD CONTEXT) (PROG (TMP CTXENTRY CTXLIST) (COND ((NULL SOURCE) (GO B)) ((ATOM SOURCE) (COND ((SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT)) (COND ((SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY) NIL)) (RETURN TMP)) (T (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for" SOURCE "whose type is" (CADDR CTXENTRY)))))) ((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT)) (SETQ SOURCE TMP)) ((SETQ TMP (GLGETGLOBALDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) ((SETQ TMP (GLGETCONSTDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The name" SOURCE "cannot be found."))))))) (COND ((PAIRP SOURCE) (COND ((SETQ TMP (GLVALUE (CAR SOURCE) FIELD (CADR SOURCE) NIL)) (RETURN TMP)) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for type" (CADR SOURCE) "in" (CAR SOURCE)))))))) B % No source is specified. Look for a source in the context. (COND ((NULL CONTEXT) (RETURN NIL))) (SETQ CTXLIST (pop CONTEXT)) C (COND ((NULL CTXLIST) (GO B))) (SETQ CTXENTRY (pop CTXLIST)) (COND ((EQ FIELD (CADR CTXENTRY)) (RETURN (LIST (CAR CTXENTRY) (CADDR CTXENTRY)))) ((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY) FIELD (CADDR CTXENTRY) NIL))) (GO C))) (RETURN TMP))) % edited: 27-MAY-82 13:01 % Call the appropriate function to compile code to get the indicator % (QUOTE IND') from the item whose description is DES, where DES % describes a unit in a unit package whose record is UNITREC. (DE GLGETFROMUNIT (UNITREC IND DES) (PROG (TMP) (COND ((SETQ TMP (ASSOC 'GET (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST IND DES)))) (T (RETURN NIL))))) % edited: 23-APR-82 16:58 (DE GLGETGLOBALDEF (ATM) (COND ((GET ATM 'GLISPGLOBALVAR) (LIST ATM (GET ATM 'GLISPGLOBALVARTYPE))) (T NIL))) % edited: 4-JUN-82 15:36 % Get pairs of <field> = <value>, where the = and , are optional. (DE GLGETPAIRS (EXPR) (PROG (PROP VAL PAIRLIST) A (COND ((NULL EXPR) (RETURN PAIRLIST)) ((NOT (ATOM (SETQ PROP (pop EXPR)))) (GLERROR 'GLGETPAIRS (LIST PROP "is not a legal property name."))) ((EQ PROP '!,) (GO A))) (COND ((MEMQ (CAR EXPR) '(= _ :=)) (pop EXPR))) (SETQ VAL (GLDOEXPR NIL CONTEXT T)) (SETQ PAIRLIST (ACONC PAIRLIST (CONS PROP VAL))) (GO A))) % edited: 10-NOV-82 10:11 % Retrieve a GLISP property whose name is PROPNAME and whose property % type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR. (DE GLGETPROP (STR PROPNAME PROPTYPE) (PROG (PL SUBPL PROPENT) (RETURN (AND (SETQ PL (GET STR 'GLSTRUCTURE)) (SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (SETQ PROPENT (ASSOC PROPNAME SUBPL)))))) % edited: 23-DEC-81 12:52 (DE GLGETSTR (DES) (PROG (TYPE TMP) (RETURN (AND (SETQ TYPE (GLXTRTYPE DES)) (ATOM TYPE) (SETQ TMP (GET TYPE 'GLSTRUCTURE)) (CAR TMP))))) % edited: 28-NOV-82 15:10 % Get the superclasses of CLASS. (DE GLGETSUPERS (CLASS) (LISTGET (CDR (GET CLASS 'GLSTRUCTURE)) 'SUPERS)) % edited: 21-MAY-82 17:01 % Identify a given name as either a known variable name of as an % implicit field reference. (DE GLIDNAME (NAME DEFAULTFLG) (PROG (TMP) (RETURN (COND ((ATOM NAME) (COND ((NULL NAME) (LIST NIL NIL)) ((IDP NAME) (COND ((EQ NAME T) (LIST NAME 'BOOLEAN)) ((SETQ TMP (GLVARTYPE NAME CONTEXT)) (LIST NAME (COND ((EQ TMP '*NIL*) NIL) (T TMP)))) ((GLGETFIELD NIL NAME CONTEXT)) ((SETQ TMP (GLIDTYPE NAME CONTEXT)) (LIST (CAR TMP) (CADDR TMP))) ((GLGETCONSTDEF NAME)) ((GLGETGLOBALDEF NAME)) (T (COND ((OR (NOT DEFAULTFLG) GLCAUTIOUSFLG) (GLERROR 'GLIDNAME (LIST "The name" NAME "cannot be found in this context.")))) (LIST NAME NIL)))) ((FIXP NAME) (LIST NAME 'INTEGER)) ((FLOATP NAME) (LIST NAME 'REAL)) (T (GLERROR 'GLIDNAME (LIST NAME "is an illegal name."))))) (T NAME))))) % edited: 27-MAY-82 13:02 % Try to identify a name by either its referenced name or its type. (DE GLIDTYPE (NAME CONTEXT) (PROG (CTXLEVELS CTXLEVEL CTXENTRY) (SETQ CTXLEVELS CONTEXT) LPA (COND ((NULL CTXLEVELS) (RETURN NIL))) (SETQ CTXLEVEL (pop CTXLEVELS)) LPB (COND ((NULL CTXLEVEL) (GO LPA))) (SETQ CTXENTRY (CAR CTXLEVEL)) (SETQ CTXLEVEL (CDR CTXLEVEL)) (COND ((OR (EQ (CADR CTXENTRY) NAME) (EQ (CADDR CTXENTRY) NAME) (AND (PAIRP (CADDR CTXENTRY)) (GL-A-AN? (CAADDR CTXENTRY)) (EQ NAME (CADR (CADDR CTXENTRY))))) (RETURN CTXENTRY))) (GO LPB))) % edited: 23-DEC-82 11:20 % Initialize things for GLISP (DE GLINIT NIL (PROG NIL (SETQ GLSEPBITTBL (MAKEBITTABLE '(: _ + - !' = ~ < > * / !, ^))) (SETQ GLUNITPKGS NIL) (SETQ GLSEPMINUS NIL) (SETQ GLQUIETFLG NIL) (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0) (SETQ GLBREAKONERROR NIL) (SETQ GLUSERSTRNAMES NIL) (SETQ GLOBJECTNAMES NIL) (SETQ GLLASTFNCOMPILED NIL) (SETQ GLLASTSTREDITED NIL) (SETQ GLCAUTIOUSFLG NIL) (MAPC '(EQ NE EQUAL AND OR NOT MEMQ ADD1 SUB1 EQN ASSOC PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ CAR CDR CAAR CADR) (FUNCTION (LAMBDA (X) (PUT X 'GLEVALWHENCONST T)))) (MAPC '(ADD1 SUB1 EQN PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ) (FUNCTION (LAMBDA (X) (PUT X 'GLARGSNUMBERP T)))) (GLDEFFNRESULTTYPES '((NUMBER (PLUS MINUS DIFFERENCE TIMES EXPT QUOTIENT REMAINDER MIN MAX ABS)) (INTEGER (LENGTH FIX ADD1 SUB1)) (REAL (SQRT LOG EXP SIN COS ATAN ARCSIN ARCCOS ARCTAN ARCTAN2 FLOAT)) (BOOLEAN (ATOM NULL EQUAL MINUSP ZEROP GREATERP LESSP NUMBERP FIXP FLOATP STRINGP ARRAYP EQ NOT NULL BOUNDP)))) (GLDEFFNRESULTTYPES '((INTEGER (FLATSIZE FLATSIZE2)) (BOOLEAN (EQN NE PAIRP IDP UNBOUNDP)))) (GLDEFFNRESULTTYPEFNS '((pNTH . GLNTHRESULTTYPEFN) (CONS . GLLISTRESULTTYPEFN) (LIST . GLLISTRESULTTYPEFN) (NCONC . GLLISTRESULTTYPEFN))))) % edited: 26-JUL-82 17:07 % Look up an instance function of an abstract function name which % takes arguments of the specified types. (DE GLINSTANCEFN (FNNAME ARGTYPES) (PROG (INSTANCES IARGS TMP) (OR (SETQ INSTANCES (GET FNNAME 'GLINSTANCEFNS)) (RETURN NIL)) % Get ultimate data types for arguments. LP (COND ((NULL INSTANCES) (RETURN NIL))) (SETQ IARGS (GET (CAAR INSTANCES) 'GLARGUMENTTYPES)) (SETQ TMP ARGTYPES) % Match the ultimate types of each argument. LPB (COND ((NULL IARGS) (RETURN (CAR INSTANCES))) ((EQUAL (GLXTRTYPEB (CAR IARGS)) (GLXTRTYPEB (CAR TMP))) (SETQ IARGS (CDR IARGS)) (SETQ TMP (CDR TMP)) (GO LPB))) (SETQ INSTANCES (CDR INSTANCES)) (GO LP))) % edited: 30-AUG-82 10:28 % Define compile-time constants. (DF GLISPCONSTANTS (ARGS) (PROG (TMP EXPR EXPRSTACK FAULTFN) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPCONSTANTFLG T) (PUT (CAR ARG) 'GLISPORIGCONSTVAL (CADR ARG)) (PUT (CAR ARG) 'GLISPCONSTANTVAL (PROGN (SETQ EXPR (LIST (CADR ARG))) (SETQ TMP (GLDOEXPR NIL NIL T)) (SET (CAR ARG) (EVAL (CAR TMP))))) (PUT (CAR ARG) 'GLISPCONSTANTTYPE (OR (CADDR ARG) (CADR TMP)))))))) % edited: 26-MAY-82 15:30 % Define compile-time constants. (DF GLISPGLOBALS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPGLOBALVAR T) (PUT (CAR ARG) 'GLISPGLOBALVARTYPE (CADR ARG)))))) % edited: 26-MAY-82 15:30 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLISPOBJECTS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG))))) % edited: 2-NOV-82 11:24 % Test the word ADJ to see if it is a LISP adjective. If so, return % the name of the function to test it. (DE GLLISPADJ (ADJ) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ADJ) '((ATOMIC . ATOM) (NULL . NULL) (NIL . NULL) (INTEGER . FIXP) (REAL . FLOATP) (BOUND . BOUNDP) (ZERO . ZEROP) (NUMERIC . NUMBERP) (NEGATIVE . MINUSP) (MINUS . MINUSP)))) (CDR TMP))))) % edited: 2-NOV-82 11:23 % Test to see if ISAWORD is a LISP ISA word. If so, return the name of % the function to test for it. (DE GLLISPISA (ISAWORD) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ISAWORD) '((ATOM . ATOM) (LIST . LISTP) (NUMBER . NUMBERP) (INTEGER . FIXP) (SYMBOL . LITATOM) (ARRAY . ARRAYP) (STRING . STRINGP) (BIGNUM . BIGP) (LITATOM . LITATOM)))) (CDR TMP))))) % edited: 12-NOV-82 10:53 % Compute result types for Lisp functions. (DE GLLISTRESULTTYPEFN (FN ARGTYPES) (PROG (ARG1 ARG2) (SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES))) (COND ((CDR ARGTYPES) (SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES))))) (RETURN (CASEQ FN (CONS (OR (AND (PAIRP ARG2) (COND ((EQ (CAR ARG2) 'LIST) (CONS 'LIST (CONS ARG1 (CDR ARG2)))) ((AND (EQ (CAR ARG2) 'LISTOF) (EQUAL ARG1 (CADR ARG2))) ARG2))) (LIST FN ARGTYPES))) (NCONC (COND ((EQUAL ARG1 ARG2) ARG1) ((AND (PAIRP ARG1) (PAIRP ARG2) (EQ (CAR ARG1) 'LISTOF) (EQ (CAR ARG2) 'LIST) (NULL (CDDR ARG2)) (EQUAL (CADR ARG1) (CADR ARG2))) ARG1) (T (OR ARG1 ARG2)))) (LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE)))) (T (ERROR 0 NIL)))))) % GSN 11-JAN-83 14:05 % Create a function call to retrieve the field IND from a LIST % structure. (DE GLLISTSTRFN (IND DES DESLIST) (PROG (TMP N FNLST) (SETQ N 1) (SETQ FNLST '((CAR *GL*) (CADR *GL*) (CADDR *GL*) (CADDDR *GL*))) (COND ((EQ (CAR DES) 'LISTOBJECT) (SETQ N (ADD1 N)) (SETQ FNLST (CDR FNLST)))) C (pop DES) (COND ((NULL DES) (RETURN NIL)) ((NOT (PAIRP (CAR DES)))) ((SETQ TMP (GLSTRFN IND (CAR DES) DESLIST)) (RETURN (GLSTRVAL TMP (COND (FNLST (COPY (CAR FNLST))) (T (LIST 'CAR (GLGENCODE (LIST 'NTH '*GL* N))))))))) (SETQ N (ADD1 N)) (AND FNLST (SETQ FNLST (CDR FNLST))) (GO C))) % edited: 24-AUG-82 17:36 % Compile code for a FOR loop. (DE GLMAKEFORLOOP (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE) (COND ((NULL COLLECTCODE) (LIST (GLGENCODE (LIST 'MAPC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (COND (LOOPCOND (LIST 'COND (CONS (CAR LOOPCOND) LOOPCONTENTS))) ((NULL (CDR LOOPCONTENTS)) (CAR LOOPCONTENTS)) (T (CONS 'PROGN LOOPCONTENTS))))))) NIL)) (T (LIST (COND (LOOPCOND (GLGENCODE (LIST 'MAPCONC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (LIST 'AND (CAR LOOPCOND) (LIST 'CONS (CAR COLLECTCODE) NIL))))))) ((AND (PAIRP (CAR COLLECTCODE)) (ATOM (CAAR COLLECTCODE)) (CDAR COLLECTCODE) (EQ (CADAR COLLECTCODE) LOOPVAR) (NULL (CDDAR COLLECTCODE))) (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (CAAR COLLECTCODE))))) (T (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR COLLECTCODE))))))) (LIST 'LISTOF (CADR COLLECTCODE)))))) % edited: 10-NOV-82 17:14 % Compile code to create a structure in response to a statement % (A <structure> WITH <field> = <value> ...) (DE GLMAKESTR (TYPE EXPR) (PROG (PAIRLIST STRDES) (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR))) (COND ((NULL (SETQ STRDES (GLGETSTR TYPE))) (GLERROR 'GLMAKESTR (LIST "The type name" TYPE "is not defined.")))) (COND ((EQ (CAR STRDES) 'LISTOF) (RETURN (CONS 'LIST (MAPCAR EXPR (FUNCTION (LAMBDA (EXPR) (GLDOEXPR NIL CONTEXT T)))) )))) (SETQ PAIRLIST (GLGETPAIRS EXPR)) (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE)) TYPE)))) % edited: 26-OCT-82 09:54 % Make a virtual type for a view of the original type. (DE GLMAKEVTYPE (ORIGTYPE VLIST) (PROG (SUPER PL PNAME TMP VTYPE) (SETQ SUPER (CADR VLIST)) (SETQ VLIST (CDDR VLIST)) (COND ((MEMQ (CAR VLIST) '(with With WITH)) (SETQ VLIST (CDR VLIST)))) LP (COND ((NULL VLIST) (GO OUT))) (SETQ PNAME (CAR VLIST)) (SETQ VLIST (CDR VLIST)) (COND ((EQ (CAR VLIST) '=) (SETQ VLIST (CDR VLIST)))) (SETQ TMP NIL) LPB (COND ((OR (NULL VLIST) (EQ (CAR VLIST) '!,)) (SETQ VLIST (CDR VLIST)) (SETQ PL (CONS (LIST PNAME (REVERSIP TMP)) PL)) (GO LP))) (SETQ TMP (CONS (CAR VLIST) TMP)) (SETQ VLIST (CDR VLIST)) (GO LPB) OUT (SETQ VTYPE (GLMKVTYPE)) (PUT VTYPE 'GLSTRUCTURE (LIST (LIST 'TRANSPARENT ORIGTYPE) 'PROP PL 'SUPERS (LIST SUPER))) (RETURN VTYPE))) % edited: 26-MAY-82 15:33 % Construct the NOT of the argument LHS. (DE GLMINUSFN (LHS) (OR (GLDOMSG LHS 'MINUS NIL) (GLUSERSTROP LHS 'MINUS NIL) (LIST (GLGENCODE (COND ((NUMBERP (CAR LHS)) (MINUS (CAR LHS))) ((EQ (GLXTRTYPE (CADR LHS)) 'INTEGER) (LIST 'IMINUS (CAR LHS))) (T (LIST 'MINUS (CAR LHS))))) (CADR LHS)))) % edited: 11-NOV-82 11:54 % Make a variable name for GLCOMP functions. (DE GLMKATOM (NAME) (PROG (N NEWATOM) LP (PUT NAME 'GLISPATOMNUMBER (SETQ N (ADD1 (OR (GET NAME 'GLISPATOMNUMBER) 0)))) (SETQ NEWATOM (IMPLODE (APPEND (EXPLODE NAME) (EXPLODE N)))) % If an atom with this name has something on its proplist, try again. (COND ((PROP NEWATOM) (GO LP)) (T (RETURN NEWATOM))))) % edited: 27-MAY-82 11:02 % Make a variable name for GLCOMP functions. (DE GLMKLABEL NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L L A B E L) (EXPLODE GLNATOM)))))) % edited: 27-MAY-82 11:04 % Make a variable name for GLCOMP functions. (DE GLMKVAR NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L V A R) (EXPLODE GLNATOM)))))) % edited: 18-NOV-82 11:58 % Make a virtual type name for GLCOMP functions. (DE GLMKVTYPE NIL (GLMKATOM 'GLVIRTUALTYPE)) % edited: 29-DEC-82 12:15 % Produce a function to implement the _+ operator. Code is produced to % append the right-hand side to the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLNCONCFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS))) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLADDSTR LHSCODE NIL (LIST 'LISTOF (CADR RHS)) CONTEXT)))) ((AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF) (NOT (EQUAL LHSDES (CADR RHS)))) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'NCONC)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_+ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLNCONCFN (LIST (CAR LHS) STR) RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_+ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ LHS RHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 23-DEC-82 10:49 % Produce code to test the two sides for inequality. (DE GLNEQUALFN (LHS RHS) (PROG (TMP) (COND ((SETQ TMP (GLDOMSG LHS '~= (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '~= RHS)) (RETURN TMP)) ((OR (GLATOMTYPEP (CADR LHS)) (GLATOMTYPEP (CADR RHS))) (RETURN (LIST (GLGENCODE (LIST 'NEQ (CAR LHS) (CAR RHS))) 'BOOLEAN))) (T (RETURN (LIST (GLGENCODE (LIST 'NOT (CAR (GLEQUALFN LHS RHS)))) 'BOOLEAN)))))) % edited: 3-MAY-82 14:35 % Construct the NOT of the argument LHS. (DE GLNOTFN (LHS) (OR (GLDOMSG LHS '~ NIL) (GLUSERSTROP LHS '~ NIL) (LIST (GLBUILDNOT (CAR LHS)) 'BOOLEAN))) % edited: 23-JUN-82 14:31 % Compute the result type for the function NTH. (DE GLNTHRESULTTYPEFN (FN ARGTYPES) (PROG (TMP) (RETURN (COND ((AND (PAIRP (SETQ TMP (GLXTRTYPE (CAR ARGTYPES)))) (EQ (CAR TMP) 'LISTOF)) (CAR ARGTYPES)) (T NIL))))) % edited: 3-JUN-82 11:02 % See if X occurs in STR, using EQ. (DE GLOCCURS (X STR) (COND ((EQ X STR) T) ((NOT (PAIRP STR)) NIL) (T (OR (GLOCCURS X (CAR STR)) (GLOCCURS X (CDR STR)))))) % edited: 10-NOV-82 11:05 % Check a structure description for legality. (DE GLOKSTR? (STR) (COND ((NULL STR) NIL) ((ATOM STR) T) ((AND (PAIRP STR) (ATOM (CAR STR))) (CASEQ (CAR STR) ((A AN a an An) (COND ((CDDR STR) NIL) ((OR (GLGETSTR (CADR STR)) (GLUNIT? (CADR STR)) (COND (GLCAUTIOUSFLG (PRIN1 "The structure ") (PRIN1 (CADR STR)) (PRIN1 " is not currently defined. Accepted.") (TERPRI) T) (T T)))))) (CONS (AND (CDR STR) (CDDR STR) (NULL (CDDDR STR)) (GLOKSTR? (CADR STR)) (GLOKSTR? (CADDR STR)))) ((LIST OBJECT ATOMOBJECT LISTOBJECT) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION GLOKSTR?)))) (RECORD (COND ((AND (CDR STR) (ATOM (CADR STR))) (pop STR))) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (LISTOF (AND (CDR STR) (NULL (CDDR STR)) (GLOKSTR? (CADR STR)))) ((ALIST PROPLIST) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (ATOM (GLATMSTR? STR)) (T (COND ((AND (CDR STR) (NULL (CDDR STR))) (GLOKSTR? (CADR STR))) ((ASSOC (CAR STR) GLUSERSTRNAMES)) (T NIL))))) (T NIL))) % edited: 30-DEC-81 16:41 % Get the next operand from the input list, EXPR (global) . The % operand may be an atom (possibly containing operators) or a list. (DE GLOPERAND NIL (PROG NIL (COND ((SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) ((NULL EXPR) (RETURN NIL)) ((STRINGP (CAR EXPR)) (RETURN (LIST (pop EXPR) 'STRING))) ((ATOM (CAR EXPR)) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) (T (RETURN (GLPUSHEXPR (pop EXPR) T CONTEXT T)))))) % edited: 30-OCT-82 14:35 % Test if an atom is a GLISP operator (DE GLOPERATOR? (ATM) (MEMQ ATM '(_ := __ + - * / > < >= <= ^ _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __- _+_))) % edited: 26-DEC-82 15:48 % OR operator (DE GLORFN (LHS RHS) (COND ((AND (PAIRP (CADR LHS)) (EQ (CAADR LHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'UNION (CAR LHS) (CAR RHS)) (CADR LHS))) ((GLDOMSG LHS 'OR (LIST RHS))) ((GLUSERSTROP LHS 'OR RHS)) (T (LIST (LIST 'OR (CAR LHS) (CAR RHS)) (COND ((EQUAL (GLXTRTYPE (CADR LHS)) (GLXTRTYPE (CADR RHS))) (CADR LHS)) (T NIL)))))) % edited: 22-SEP-82 17:16 % Subroutine of GLDOEXPR to parse a GLISP expression containing field % specifications and/or operators. The global variable EXPR is used, % and is modified to reflect the amount of the expression which has % been parsed. (DE GLPARSEXPR NIL (PROG (OPNDS OPERS FIRST LHSP RHSP) % Get the initial part of the expression, i.e., variable or field % specification. L (SETQ OPNDS (CONS (GLOPERAND) OPNDS)) M (COND ((NULL FIRST) (COND ((OR (NULL EXPR) (NOT (ATOM (CAR EXPR)))) (GO B))) (GLSEPINIT (CAR EXPR)) (COND ((GLOPERATOR? (SETQ FIRST (GLSEPNXT))) (pop EXPR) (GO A)) ((MEMQ FIRST '(IS Is is HAS Has has)) (COND ((AND OPERS (GREATERP (GLPREC (CAR OPERS)) 5)) (GLREDUCE) (SETQ FIRST NIL) (GO M)) (T (SETQ OPNDS (CONS (GLPREDICATE (pop OPNDS) CONTEXT T (AND (NOT (UNBOUNDP 'ADDISATYPE)) ADDISATYPE)) OPNDS)) (SETQ FIRST NIL) (GO M)))) (T (GLSEPCLR) (GO B)))) ((GLOPERATOR? FIRST) (GO A)) (T (GLERROR 'GLPARSEXPR (LIST FIRST "appears illegally or cannot be interpreted.")))) % FIRST now contains an operator A % While top operator < top of stack in precedence, reduce. (COND ((NOT (OR (NULL OPERS) (LESSP (SETQ LHSP (GLPREC (CAR OPERS))) (SETQ RHSP (GLPREC FIRST))) (AND (EQN LHSP RHSP) (MEMQ FIRST '(_ ^ :=))))) (GLREDUCE) (GO A))) % Push new operator onto the operator stack. (SETQ OPERS (CONS FIRST OPERS)) (GO L) B (COND (OPERS (GLREDUCE) (GO B))) (RETURN (CAR OPNDS)))) % edited: 30-DEC-82 10:55 % Parse a field specification of the form var:field:field... Var may % be missing, and there may be zero or more fields. The variable % FIRST is used globally; it contains the first atom of the group on % entry, and the next atom on exit. (DE GLPARSFLD (PREV) (PROG (FIELD TMP) (COND ((NULL PREV) (COND ((EQ FIRST '!') (COND ((SETQ TMP (GLSEPNXT)) (SETQ FIRST (GLSEPNXT)) (RETURN (LIST (MKQUOTE TMP) 'ATOM))) (EXPR (SETQ FIRST NIL) (SETQ TMP (pop EXPR)) (RETURN (LIST (MKQUOTE TMP) (GLCONSTANTTYPE TMP)))) (T (RETURN NIL)))) ((MEMQ FIRST '(THE The the)) (SETQ TMP (GLTHE NIL)) (SETQ FIRST NIL) (RETURN TMP)) ((NE FIRST ':) (SETQ PREV FIRST) (SETQ FIRST (GLSEPNXT)))))) A (COND ((EQ FIRST ':) (COND ((SETQ FIELD (GLSEPNXT)) (SETQ PREV (GLGETFIELD PREV FIELD CONTEXT)) (SETQ FIRST (GLSEPNXT)) (GO A)))) (T (RETURN (COND ((EQ PREV '*NIL*) (LIST NIL NIL)) (T (GLIDNAME PREV T)))))))) % edited: 20-MAY-82 11:30 % Parse a field specification which may be preceded by a ~. (DE GLPARSNFLD NIL (PROG (TMP UOP) (COND ((OR (EQ FIRST '~) (EQ FIRST '-)) (SETQ UOP FIRST) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (ATOM (CAR EXPR))) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (PAIRP (CAR EXPR))) (SETQ TMP (GLPUSHEXPR (pop EXPR) T CONTEXT T))) (T (RETURN (LIST UOP NIL)))) (RETURN (COND ((EQ UOP '~) (GLNOTFN TMP)) (T (GLMINUSFN TMP))))) (T (RETURN (GLPARSFLD NIL)))))) % edited: 27-MAY-82 10:42 % Form the plural of a given word. (DE GLPLURAL (WORD) (PROG (TMP LST UCASE ENDING) (COND ((SETQ TMP (GET WORD 'PLURAL)) (RETURN TMP))) (SETQ LST (REVERSIP (EXPLODE WORD))) (SETQ UCASE (U-CASEP (CAR LST))) (COND ((AND (MEMQ (CAR LST) '(Y y)) (NOT (MEMQ (CADR LST) '(A a E e O o U u)))) (SETQ LST (CDR LST)) (SETQ ENDING (OR (AND UCASE '(S E I)) '(s e i)))) ((MEMQ (CAR LST) '(S s X x)) (SETQ ENDING (OR (AND UCASE '(S E)) '(s e)))) (T (SETQ ENDING (OR (AND UCASE '(S)) '(s))))) (RETURN (IMPLODE (REVERSIP (APPEND ENDING LST)))))) % edited: 29-DEC-82 12:40 % Produce a function to implement the -_ (pop) operator. Code is % produced to remove one element from the right-hand side and assign % it to the left-hand side. (DE GLPOPFN (LHS RHS) (PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR) (SETQ RHSCODE (CAR RHS)) (SETQ RHSDES (GLXTRTYPE (CADR RHS))) (COND ((AND (PAIRP RHSDES) (EQ (CAR RHSDES) 'LISTOF)) (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL))) ((EQ RHSDES 'BOOLEAN) (SETQ POPCODE (GLPUTFN RHS '(NIL NIL) NIL)) (SETQ GETCODE (GLPUTFN LHS RHS NIL))) ((SETQ TMP (GLDOMSG RHS '-_ (LIST LHS))) (RETURN TMP)) ((AND (SETQ STR (GLGETSTR RHSDES)) (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS) STR)))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP RHS '-_ LHS)) (RETURN TMP)) ((OR (GLATOMTYPEP RHSDES) (AND (NE RHSDES 'ANYTHING) (MEMQ (GLXTRTYPEB RHSDES) GLBASICTYPES))) (RETURN NIL)) (T % If all else fails, assume a list. (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL)))) (RETURN (LIST (LIST 'PROG1 (CAR GETCODE) (CAR POPCODE)) (CADR GETCODE))))) % edited: 30-OCT-82 14:36 % Precedence numbers for operators (DE GLPREC (OP) (PROG (TMP) (COND ((SETQ TMP (ASSOC OP '((_ . 1) (:= . 1) (__ . 1) (_+ . 2) (__+ . 2) (+_ . 2) (_+_ . 2) (_- . 2) (__- . 2) (-_ . 2) (= . 5) (~= . 5) (<> . 5) (AND . 4) (And . 4) (and . 4) (OR . 3) (Or . 3) (or . 3) (/ . 7) (+ . 6) (- . 6) (> . 5) (< . 5) (>= . 5) (<= . 5) (^ . 8)))) (RETURN (CDR TMP))) ((EQ OP '*) (RETURN 7)) (T (RETURN 10))))) % edited: 2-DEC-82 14:16 % Get a predicate specification from the EXPR (referenced globally) % and return code to test the SOURCE for that predicate. VERBFLG is % true if a verb is expected as the top of EXPR. (DE GLPREDICATE (SOURCE CONTEXT VERBFLG ADDISATYPE) (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG) (COND ((NULL VERBFLG) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((NULL SOURCE) (GLERROR 'GLPREDICATE (LIST "The object to be tested was not found. EXPR =" EXPR))) ((MEMQ (CAR EXPR) '(HAS Has has)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NO No no)) (SETQ NOTFLG T) (pop EXPR))) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((MEMQ (CAR EXPR) '(IS Is is ARE Are are)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NOT Not not)) (SETQ NOTFLG T) (pop EXPR))) (COND ((GL-A-AN? (CAR EXPR)) (pop EXPR) (SETQ SETNAME (pop EXPR)) % The condition is to test whether SOURCE IS A SETNAME. (COND ((SETQ NEWPRED (GLADJ SOURCE SETNAME 'ISA))) ((SETQ NEWPRED (GLADJ SOURCE SETNAME 'ISASELF)) (COND (ADDISATYPE (COND ((ATOM (CAR SOURCE)) (GLADDSTR (CAR SOURCE) NIL SETNAME CONTEXT)) ((AND (PAIRP (CAR SOURCE)) (MEMQ (CAAR SOURCE) '(SETQ PROG1)) (ATOM (CADAR SOURCE))) (GLADDSTR (CADAR SOURCE) (COND ((SETQ TMP (GLFINDVARINCTX (CAR SOURCE) CONTEXT)) (CADR TMP))) SETNAME CONTEXT)))))) ((GLCLASSP SETNAME) (SETQ NEWPRED (LIST (LIST 'GLCLASSMEMP (CAR SOURCE) (MKQUOTE SETNAME)) 'BOOLEAN))) ((SETQ TMP (GLLISPISA SETNAME)) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "IS A adjective" SETNAME "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS 'A SETNAME) 'BOOLEAN))))) (T (SETQ PROPERTY (CAR EXPR)) % The condition to test is whether SOURCE is PROPERTY. (COND ((SETQ NEWPRED (GLADJ SOURCE PROPERTY 'ADJ)) (pop EXPR)) ((SETQ TMP (GLLISPADJ PROPERTY)) (pop EXPR) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "The adjective" PROPERTY "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (pop EXPR) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS PROPERTY) 'BOOLEAN)))))))) (RETURN (COND (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED)) 'BOOLEAN)) (T NEWPRED))))) % edited: 25-MAY-82 16:09 % Compile an implicit PROGN, that is, a list of items. (DE GLPROGN (EXPR CONTEXT) (PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) A (COND ((NULL EXPR) (RETURN (LIST (REVERSIP RESULT) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY)) (SETQ RESULT (CONS (CAR TMP) RESULT)) (SETQ TYPE (CADR TMP)) (GO A)) (T (GLERROR 'GLPROGN (LIST "Illegal item appears in implicit PROGN. EXPR =" EXPR)))))) % GSN 11-JAN-83 09:59 % Create a function call to retrieve the field IND from a % property-list type structure. FLG is true if a PROPLIST is inside % an ATOM structure. (DE GLPROPSTRFN (IND DES DESLIST FLG) (PROG (DESIND TMP RECNAME N) % Handle a PROPLIST by looking inside each property for IND. (COND ((AND (EQ (SETQ DESIND (pop DES)) 'RECORD) (ATOM (CAR DES))) (SETQ RECNAME (pop DES)))) (SETQ N 0) P (COND ((NULL DES) (RETURN NIL)) ((AND (PAIRP (CAR DES)) (ATOM (CAAR DES)) (CDAR DES) (SETQ TMP (GLSTRFN IND (CAR DES) DESLIST))) (SETQ TMP (GLSTRVAL TMP (CASEQ DESIND (ALIST (LIST 'GLGETASSOC (MKQUOTE (CAAR DES)) '*GL*)) ((RECORD OBJECT) (COND ((EQ DESIND 'OBJECT) (SETQ N (ADD1 N)))) (LIST 'GetV '*GL* N)) ((PROPLIST ATOMOBJECT) (LIST (COND ((OR FLG (EQ DESIND 'ATOMOBJECT)) 'GETPROP) (T 'LISTGET)) '*GL* (MKQUOTE (CAAR DES))))))) (RPLACA TMP (GLGENCODE (CAR TMP))) (RETURN TMP)) (T (pop DES) (SETQ N (ADD1 N)) (GO P))))) % edited: 4-JUN-82 13:37 % Test if the function X is a pure computation, i.e., can be % eliminated if the result is not used. (DE GLPURE (X) (MEMQ X '(CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR CADDDR))) % edited: 25-MAY-82 16:10 % This function serves to call GLDOEXPR with a new expression, % rebinding the global variable EXPR. (DE GLPUSHEXPR (EXPR START CONTEXT VALBUSY) (PROG (GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) (RETURN (GLDOEXPR START CONTEXT VALBUSY)))) % edited: 29-DEC-82 12:32 % Produce a function to implement the +_ operator. Code is produced to % push the right-hand side onto the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLPUSHFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE)) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLADDSTR LHSCODE NIL (LIST 'LISTOF (CADR RHS)) CONTEXT)))) ((AND (PAIRP LHSDES) (MEMQ (CAR LHSDES) '(LIST CONS LISTOF))) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'PUSH)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLPUSHFN (LIST (CAR LHS) STR) RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '+_ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ RHS LHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 18-NOV-82 11:59 % Process a store into a value which is computed by an arithmetic % expression. (DE GLPUTARITH (LHS RHS) (PROG (LHSC OP TMP NEWLHS NEWRHS) (SETQ LHSC (CAR LHS)) (SETQ OP (CAR LHSC)) (COND ((NOT (SETQ TMP (ASSOC OP '((PLUS DIFFERENCE) (MINUS MINUS) (DIFFERENCE PLUS) (TIMES QUOTIENT) (QUOTIENT TIMES) (IPLUS IDIFFERENCE) (IMINUS IMINUS) (IDIFFERENCE IPLUS) (ITIMES IQUOTIENT) (IQUOTIENT ITIMES) (ADD1 SUB1) (SUB1 ADD1) (EXPT SQRT))))) (RETURN NIL))) (CASEQ OP ((ADD1 SUB1 MINUS IMINUS) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS))) (SETQ NEWLHS (CADR LHSC))) ((PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE ITIMES IQUOTIENT) (COND ((NUMBERP (CADDR LHSC)) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADDR LHSC))) (SETQ NEWLHS (CADR LHSC))) ((NUMBERP (CADR LHSC)) (CASEQ OP ((DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT) (SETQ NEWRHS (LIST OP (CADR LHSC) (CAR RHS))) (SETQ NEWLHS (CADDR LHSC))) (T (PROGN (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADR LHSC))) (SETQ NEWLHS (CADDR LHSC)))))))) (EXPT (COND ((EQUAL (CADDR LHSC) 2) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS))) (SETQ NEWLHS (CADR LHSC)))))) (RETURN (AND NEWLHS NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS)) (LIST NEWRHS (CADR RHS)) NIL))))) % GSN 11-JAN-83 10:12 % edited: 2-Jun-81 14:16 % Create code to put the right-hand side datum RHS into the left-hand % side, whose access function and type are given by LHS. (DE GLPUTFN (LHS RHS OPTFLG) (PROG (LHSD LNAME TMP RESULT TMPVAR) (SETQ LHSD (CAR LHS)) (COND ((ATOM LHSD) (RETURN (OR (GLDOMSG LHS '_ (LIST RHS)) (GLUSERSTROP LHS '_ RHS) (AND (NULL (CADR LHS)) (CADR RHS) (GLUSERSTROP (LIST (CAR LHS) (CADR RHS)) '_ RHS)) (GLDOVARSETQ LHSD RHS))))) (SETQ LNAME (CAR LHSD)) (COND ((EQ LNAME 'CAR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (CADR LHSD) (CAR RHS))))))) ((EQ LNAME 'CDR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CDR (LIST 'RPLACD TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CDR (LIST 'RPLACD (CADR LHSD) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((CADR . CDR) (CADDR . CDDR) (CADDDR . CDDDR)))) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (LIST (CDR TMP) (CADR LHSD)))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST (LIST 'CAR TMPVAR) LHSD (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (LIST (CDR TMP) (CADR LHSD)) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((GetV . PutV) (IGetV . IPutV) (GET . PUTPROP) (GETPROP . PUTPROP) (LISTGET . LISTPUT)))) (SETQ RESULT (LIST (CDR TMP) (CADR LHSD) (CADDR LHSD) (CAR RHS)))) ((EQ LNAME 'CXR) (SETQ RESULT (LIST 'CXR (LIST 'RPLACX (CADR LHSD) (CADDR LHSD) (CAR RHS))))) ((EQ LNAME 'GLGETASSOC) (SETQ RESULT (LIST 'PUTASSOC (CADR LHSD) (CAR RHS) (CADDR LHSD)))) ((EQ LNAME 'EVAL) (SETQ RESULT (LIST 'SET (CADR LHSD) (CAR RHS)))) ((EQ LNAME 'fetch) (SETQ RESULT (LIST 'replace (CADR LHSD) 'of (CADDDR LHSD) 'with (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'PUT)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_ RHS)) (RETURN TMP)) ((SETQ TMP (GLPUTARITH LHS RHS)) (RETURN TMP)) (T (RETURN (GLERROR 'GLPUTFN (LIST "Illegal assignment. LHS =" LHS "RHS =" RHS))))) X (RETURN (LIST (GLGENCODE RESULT) (OR (CADR LHS) (CADR RHS)))))) % edited: 27-MAY-82 13:07 % This function appends PUTPROP calls to the list PROGG (global) so % that ATOMNAME has its property list built. (DE GLPUTPROPS (PROPLIS PREVLST) (PROG (TMP TMPCODE) A (COND ((NULL PROPLIS) (RETURN NIL))) (SETQ TMP (pop PROPLIS)) (COND ((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST)) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (MKQUOTE (CAR TMP)) TMPCODE))))) (GO A))) % edited: 26-JAN-82 10:29 % This function implements the __ operator, which is interpreted as % assignment to the source of a variable (usually self) outside an % open-compiled function. Any other use of __ is illegal. (DE GLPUTUPFN (OP LHS RHS) (PROG (TMP TMPOP) (OR (SETQ TMPOP (ASSOC OP '((__ . _) (__+ . _+) (__- . _-) (_+_ . +_)))) (ERROR 0 (LIST (LIST 'GLPUTUPFN OP) " Illegal operator."))) (COND ((AND (ATOM (CAR LHS)) (NOT (UNBOUNDP 'GLPROGLST)) (SETQ TMP (ASSOC (CAR LHS) GLPROGLST))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADR TMP) (CADR LHS)) RHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'PROG1) (ATOM (CADAR LHS))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADAR LHS) (CADR LHS)) RHS))) (T (RETURN (GLERROR 'GLPUTUPFN (LIST "A self-assignment __ operator is used improperly. LHS =" LHS))))))) % edited: 30-OCT-82 14:38 % Reduce the operator on OPERS and the operands on OPNDS % (in GLPARSEXPR) and put the result back on OPNDS (DE GLREDUCE NIL (PROG (RHS OPER) (SETQ RHS (pop OPNDS)) (SETQ OPNDS (CONS (COND ((MEMQ (SETQ OPER (pop OPERS)) '(_ := _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __ _+_ __-)) (GLREDUCEOP OPER (pop OPNDS) RHS)) ((MEMQ OPER '(+ - * / > < >= <= ^)) (GLREDUCEARITH OPER (pop OPNDS) RHS)) ((EQ OPER 'MINUS) (GLMINUSFN RHS)) ((EQ OPER '~) (GLNOTFN RHS)) (T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS)) (CAR RHS))) NIL))) OPNDS)))) % edited: 29-DEC-82 10:53 % Reduce an arithmetic operator in an expression. (DE GLREDUCEARITH (OP LHS RHS) (PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP) (SETQ OPLIST '((+ . PLUS) (- . DIFFERENCE) (* . TIMES) (/ . QUOTIENT) (> . GREATERP) (< . LESSP) (>= . GEQ) (<= . LEQ) (^ . EXPT))) (SETQ IOPLIST '((+ . IPLUS) (- . IDIFFERENCE) (* . ITIMES) (/ . IQUOTIENT) (> . IGREATERP) (< . ILESSP) (>= . IGEQ) (<= . ILEQ))) (SETQ PREDLIST '(GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)) (SETQ NUMBERTYPES '(INTEGER REAL NUMBER)) (SETQ LHSTP (GLXTRTYPE (CADR LHS))) (SETQ RHSTP (GLXTRTYPE (CADR RHS))) (COND ((OR (AND (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER) (SETQ TMP (ASSOC OP IOPLIST))) (AND (MEMQ LHSTP NUMBERTYPES) (MEMQ RHSTP NUMBERTYPES) (SETQ TMP (ASSOC OP OPLIST)))) (RETURN (LIST (COND ((AND (NUMBERP (CAR LHS)) (NUMBERP (CAR RHS))) (EVAL (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))))) (T (GLGENCODE (COND ((AND (EQ (CDR TMP) 'IPLUS) (EQN (CAR RHS) 1)) (LIST 'ADD1 (CAR LHS))) ((AND (EQ (CDR TMP) 'IDIFFERENCE) (EQN (CAR RHS) 1)) (LIST 'SUB1 (CAR LHS))) (T (LIST (CDR TMP) (CAR LHS) (CAR RHS))))))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T LHSTP)))))) (COND ((EQ LHSTP 'STRING) (COND ((NE RHSTP 'STRING) (RETURN (GLERROR 'GLREDUCEARITH (LIST "operation on string and non-string")))) ((SETQ TMP (ASSOC OP '((+ CONCAT STRING) (> GLSTRGREATERP BOOLEAN) (>= GLSTRGEP BOOLEAN) (< GLSTRLESSP BOOLEAN) (<= ALPHORDER BOOLEAN)))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADDR TMP)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for strings."))))) ) ((AND (PAIRP LHSTP) (EQ (CAR LHSTP) 'LISTOF)) (COND ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF)) (COND ((NOT (EQUAL (CADR LHSTP) (CADR RHSTP))) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operations on lists of different types" (CADR LHSTP) (CADR RHSTP)))))) (COND ((SETQ TMP (ASSOC OP '((+ UNION) (- LDIFFERENCE) (* INTERSECTION) ))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) LHSTP))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation" OP "on lists.")))))) ((AND (EQUAL (CADR LHSTP) RHSTP) (MEMQ OP '(+ - >=))) (RETURN (LIST (GLGENCODE (LIST (COND ((EQ OP '+) 'CONS) ((EQ OP '-) 'REMOVE) ((EQ OP '>=) (COND ((GLATOMTYPEP RHSTP) 'MEMB) (T 'MEMBER)))) (CAR RHS) (CAR LHS))) LHSTP))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation on list.")))))) ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF) (EQUAL (CADR RHSTP) LHSTP) (MEMQ OP '(+ <=))) (RETURN (LIST (GLGENCODE (LIST (COND ((EQ OP '+) 'CONS) ((EQ OP '<=) (COND ((GLATOMTYPEP LHSTP) 'MEMB) (T 'MEMBER)))) (CAR LHS) (CAR RHS))) RHSTP))) ((SETQ TMP (GLDOMSG LHS OP (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS OP RHS)) (RETURN TMP)) ((SETQ TMP (GLXTRTYPEC LHSTP)) (RETURN (GLREDUCEARITH OP (LIST (CAR LHS) TMP) (LIST (CAR RHS) (OR (GLXTRTYPEC RHSTP) RHSTP))))) ((SETQ TMP (ASSOC OP OPLIST)) (AND LHSTP RHSTP (GLERROR 'GLREDUCEARITH (LIST "Warning: Arithmetic operation on non-numeric arguments of types:" LHSTP RHSTP))) (RETURN (LIST (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T 'NUMBER))))) (T (ERROR 0 (LIST 'GLREDUCEARITH OP LHS RHS)))))) % edited: 29-DEC-82 12:20 % Reduce the operator OP with operands LHS and RHS. (DE GLREDUCEOP (OP LHS RHS) (PROG (TMP RESULT) (COND ((MEMQ OP '(_ :=)) (RETURN (GLPUTFN LHS RHS NIL))) ((SETQ TMP (ASSOC OP '((_+ . GLNCONCFN) (+_ . GLPUSHFN) (_- . GLREMOVEFN) (-_ . GLPOPFN) (= . GLEQUALFN) (~= . GLNEQUALFN) (<> . GLNEQUALFN) (AND . GLANDFN) (And . GLANDFN) (and . GLANDFN) (OR . GLORFN) (Or . GLORFN) (or . GLORFN)))) (COND ((SETQ RESULT (APPLY (CDR TMP) (LIST LHS RHS))) (RETURN RESULT)) (T (GLERROR 'GLREDUCEOP (LIST "The operator" OP "could not be interpreted for arguments" LHS "and" RHS))))) ((MEMQ OP '(__ __+ __- _+_)) (RETURN (GLPUTUPFN OP LHS RHS))) (T (ERROR 0 (LIST 'GLREDUCEOP OP LHS RHS)))))) % edited: 1-JUN-82 14:29 % Produce a function to implement the _- operator. Code is produced to % remove the right-hand side from the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLREMOVEFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'SUB1 LHSCODE))) (T (SETQ NCCODE (LIST 'IDIFFERENCE LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'DIFFERENCE LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'AND LHSCODE (LIST 'NOT (CAR RHS))))) ((OR (NULL LHSDES) (AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF))) (SETQ NCCODE (LIST 'REMOVE (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'REMOVE)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_- (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '- (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLREMOVEFN (LIST (CAR LHS) STR) RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_- RHS)) (RETURN TMP)) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 26-JUL-82 17:30 % Get GLOBAL and RESULT declarations for the GLISP compiler. The % property GLRESULTTYPE is the RESULT declaration, if specified; % GLGLOBALS is a list of global variables referenced and their % types. (DE GLRESGLOBAL NIL (COND ((PAIRP (CAR GLEXPR)) (COND ((MEMQ (CAAR GLEXPR) '(RESULT Result result)) (COND ((AND (GLOKSTR? (CADAR GLEXPR)) (NULL (CDDAR GLEXPR))) (PUT GLAMBDAFN 'GLRESULTTYPE (SETQ RESULTTYPE (GLSUBSTTYPE (CADAR GLEXPR) GLTYPESUBS))) (pop GLEXPR)) (T (GLERROR 'GLCOMP (LIST "Bad RESULT structure declaration:" (CAR GLEXPR))) (pop GLEXPR)))) ((MEMQ (CAAR GLEXPR) '(GLOBAL Global global)) (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR) NIL NIL GLTOPCTX NIL)) (PUT GLAMBDAFN 'GLGLOBALS GLGLOBALVARS) (pop GLEXPR)))))) % edited: 26-MAY-82 16:14 % Get the result type for a function which has a GLAMBDA definition. % ATM is the function name. (DE GLRESULTTYPE (ATM ARGTYPES) (PROG (TYPE FNDEF STR TMP) % See if this function has a known result type. (COND ((SETQ TYPE (GET ATM 'GLRESULTTYPE)) (RETURN TYPE))) % If there exists a function to compute the result type, let it do so. (COND ((SETQ TMP (GET ATM 'GLRESULTTYPEFN)) (RETURN (APPLY TMP (LIST ATM ARGTYPES)))) ((SETQ TMP (GLANYCARCDR? ATM)) (RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES))))) (SETQ FNDEF (GLGETDB ATM)) (COND ((OR (NOT (PAIRP FNDEF)) (NOT (MEMQ (CAR FNDEF) '(LAMBDA GLAMBDA)))) (RETURN NIL))) (SETQ FNDEF (CDDR FNDEF)) A (COND ((OR (NULL FNDEF) (NOT (PAIRP (CAR FNDEF)))) (RETURN NIL)) ((OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR FNDEF) '*)) (MEMQ (CAAR FNDEF) '(GLOBAL Global global))) (pop FNDEF) (GO A)) ((AND (MEMQ (CAAR FNDEF) '(RESULT Result result)) (GLOKSTR? (SETQ STR (CADAR FNDEF)))) (RETURN STR)) (T (RETURN NIL))))) % GSN 11-JAN-83 10:38 % Send a runtime message to OBJ. (DE GLSENDB (OBJ SELECTOR PROPTYPE ARGS) (PROG (CLASS RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL faultfn exprstack glnatom context ) (OR (SETQ CLASS (GLCLASS OBJ)) (ERROR 0 (LIST "Object" OBJ "has no Class."))) (SETQ ARGLIST (CONS OBJ ARGS)) (COND ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST PROPTYPE)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE PROPTYPE 'MSG) (GO ERR)) ((AND ARGS (NULL (CDR ARGS)) (EQ (GLNTHCHAR SELECTOR -1) ':) (SETQ SEL (SUBATOM SELECTOR 1 -2)) (SETQ FNCODE (OR (GLCOMPPROP CLASS SEL 'STR) (GLCOMPPROP CLASS SEL 'PROP))) (SETQ PUTCODE (GLPUTFN (LIST (SUBST '*GL* (CAADR FNCODE) (CADDR FNCODE)) NIL) (LIST '*GLVAL* NIL) NIL))) (SETQ *GLVAL* (CAR ARGS)) (SETQ *GL* OBJ) (RETURN (EVAL (CAR PUTCODE)))) (ARGS (GO ERR)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'STR)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'PROP)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ADJ)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ISA)) 'GLSENDFAILURE) (RETURN RESULT))) ERR (ERROR 0 (LIST "Message" SELECTOR "to object" OBJ "of class" CLASS "not understood.")))) % edited: 30-DEC-81 16:34 (DE GLSEPCLR NIL (SETQ GLSEPPTR 0)) % edited: 30-Dec-80 10:05 % Initialize the scanning function which breaks apart atoms containing % embedded operators. (DE GLSEPINIT (ATM) (PROG NIL (cond ((and (atom atm)(not (stringp atm))) (SETQ GLSEPATOM ATM) (SETQ GLSEPPTR 1)) (t (setq glsepatom nil) (setq glsepptr 0))))) % edited: 30-OCT-82 14:40 % Get the next sub-atom from the atom which was previously given to % GLSEPINIT. Sub-atoms are defined by splitting the given atom at % the occurrence of operators. Operators which are defined are : _ % _+ __ +_ _- -_ ' = ~= <> > < (DE GLSEPNXT NIL (PROG (END TMP) (COND ((ZEROP GLSEPPTR) (RETURN NIL)) ((NULL GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN '*NIL*)) ((NUMBERP GLSEPATOM) (SETQ TMP GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN TMP))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR)) A (COND ((NULL END) (RETURN (PROG1 (COND ((EQN GLSEPPTR 1) GLSEPATOM) ((GREATERP GLSEPPTR (FlatSize2 GLSEPATOM)) NIL) (T (GLSUBATOM GLSEPATOM GLSEPPTR (FlatSize2 GLSEPATOM)))) (SETQ GLSEPPTR 0)))) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (PLUS GLSEPPTR 2))) '(__+ __- _+_)) (SETQ GLSEPPTR (PLUS GLSEPPTR 3)) (RETURN TMP)) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (ADD1 GLSEPPTR))) '(:= __ _+ +_ _- -_ ~= <> >= <=)) (SETQ GLSEPPTR (PLUS GLSEPPTR 2)) (RETURN TMP)) ((AND (NOT GLSEPMINUS) (EQ (GLNTHCHAR GLSEPATOM END) '-) (NOT (EQ (GLNTHCHAR GLSEPATOM (ADD1 END)) '_))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END))) (GO A)) ((GREATERP END GLSEPPTR) (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR (SUB1 END)) (SETQ GLSEPPTR END)))) (T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR) (SETQ GLSEPPTR (ADD1 GLSEPPTR)))))))) % edited: 26-MAY-82 16:17 % Skip comments in GLEXPR. (DE GLSKIPCOMMENTS NIL (PROG NIL A (COND ((AND (PAIRP GLEXPR) (PAIRP (CAR GLEXPR)) (OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR GLEXPR) '*)) (EQ (CAAR GLEXPR) 'COMMENT))) (pop GLEXPR) (GO A))))) % edited: 10-NOV-82 11:16 % Create a function call to retrieve the field IND from a structure % described by the structure description DES. The value is NIL if % failure, (NIL DESCR) if DES equals IND, or (FNSTR DESCR) if IND % can be gotten from within DES. In the latter case, FNSTR is a % function to get the IND from the atom *GL*. GLSTRFN only does % retrieval from a structure, and does not get properties of an % object unless they are part of a TRANSPARENT substructure. DESLIST % is a list of structure descriptions which have been tried already; % this prevents a compiler loop in case the user specifies circular % TRANSPARENT structures. (DE GLSTRFN (IND DES DESLIST) (PROG (DESIND TMP STR UNITREC) % If this structure has already been tried, quit to avoid a loop. (COND ((MEMQ DES DESLIST) (RETURN NIL))) (SETQ DESLIST (CONS DES DESLIST)) (COND ((OR (NULL DES) (NULL IND)) (RETURN NIL)) ((OR (ATOM DES) (AND (PAIRP DES) (ATOM (CADR DES)) (GL-A-AN? (CAR DES)) (SETQ DES (CADR DES)))) (RETURN (COND ((SETQ STR (GLGETSTR DES)) (GLSTRFN IND STR DESLIST)) ((SETQ UNITREC (GLUNIT? DES)) (GLGETFROMUNIT UNITREC IND DES)) ((EQ IND DES) (LIST NIL (CADR DES))) (T NIL)))) ((NOT (PAIRP DES)) (GLERROR 'GLSTRFN (LIST "Bad structure specification" DES)))) (SETQ DESIND (CAR DES)) (COND ((OR (EQ IND DES) (EQ DESIND IND)) (RETURN (LIST NIL (CADR DES))))) (RETURN (CASEQ DESIND (CONS (OR (GLSTRVALB IND (CADR DES) '(CAR *GL*)) (GLSTRVALB IND (CADDR DES) '(CDR *GL*)))) ((LIST LISTOBJECT) (GLLISTSTRFN IND DES DESLIST)) ((PROPLIST ALIST RECORD ATOMOBJECT OBJECT) (GLPROPSTRFN IND DES DESLIST NIL)) (ATOM (GLATOMSTRFN IND DES DESLIST)) (TRANSPARENT (GLSTRFN IND (CADR DES) DESLIST)) (T (COND ((AND (SETQ TMP (ASSOC DESIND GLUSERSTRNAMES)) (CADR TMP)) (APPLY (CADR TMP) (LIST IND DES DESLIST))) ((OR (NULL (CDR DES)) (ATOM (CADR DES)) (AND (PAIRP (CADR DES)) (GL-A-AN? (CAADR DES)))) NIL) (T (GLSTRFN IND (CADR DES) DESLIST)))))))) % edited: 18-NOV-82 16:54 % If STR is a structured object, i.e., either a declared GLISP % structure or a Class of Units, get the property PROP from the % GLISP class of properties GLPROP. (DE GLSTRPROP (STR GLPROP PROP) (PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS) (OR (SETQ STRB (GLXTRTYPE STR)) (RETURN NIL)) (COND ((AND (SETQ GLPROPS (GET STRB 'GLSTRUCTURE)) (SETQ PROPL (LISTGET (CDR GLPROPS) GLPROP)) (SETQ TMP (ASSOC PROP PROPL))) (RETURN TMP))) (SETQ SUPERS (and glprops (pairp glprops) (LISTGET (CDR GLPROPS) 'SUPERS))) LP (COND (SUPERS (COND ((SETQ TMP (GLSTRPROP (CAR SUPERS) GLPROP PROP)) (RETURN TMP)) (T (SETQ SUPERS (CDR SUPERS)) (GO LP)))) ((AND (SETQ UNITREC (GLUNIT? STRB)) (SETQ TMP (APPLY (CADDDR UNITREC) (LIST STRB GLPROP PROP)))) (RETURN TMP))))) % edited: 11-JAN-82 14:58 % GLSTRVAL is a subroutine of GLSTRFN. Given an old partial retrieval % function, in which the item from which the retrieval is made is % specified by *GL*, and a new function to compute *GL*, a composite % function is made. (DE GLSTRVAL (OLDFN NEW) (PROG NIL (COND ((CAR OLDFN) (RPLACA OLDFN (SUBST NEW '*GL* (CAR OLDFN)))) (T (RPLACA OLDFN NEW))) (RETURN OLDFN))) % edited: 13-Aug-81 16:13 % If the indicator IND can be found within the description DES, make a % composite retrieval function using a copy of the function pattern % NEW. (DE GLSTRVALB (IND DES NEW) (PROG (TMP) (COND ((SETQ TMP (GLSTRFN IND DES DESLIST)) (RETURN (GLSTRVAL TMP (COPY NEW)))) (T (RETURN NIL))))) % edited: 30-DEC-81 16:35 (DE GLSUBATOM (X Y Z) (OR (SUBATOM X Y Z) '*NIL*)) % edited: 30-AUG-82 10:29 % Make subtype substitutions within TYPE according to GLTYPESUBS. (DE GLSUBSTTYPE (TYPE SUBS) (SUBLIS SUBS TYPE)) % edited: 11-NOV-82 14:02 % Get the list of superclasses for CLASS. (DE GLSUPERS (CLASS) (PROG (TMP) (RETURN (AND (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (LISTGET (CDR TMP) 'SUPERS))))) % edited: 2-DEC-82 14:18 % EXPR begins with THE. Parse the expression and return code. (DE GLTHE (PLURALFLG) (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND TMP) % Now trace the path specification. (GLTHESPECS) (SETQ QUALFLG (AND EXPR (MEMQ (CAR EXPR) '(with With WITH who Who WHO which Which WHICH that That THAT))) ) B (COND ((NULL SPECS) (COND ((MEMQ (CAR EXPR) '(IS Is is HAS Has has ARE Are are)) (RETURN (GLPREDICATE SOURCE CONTEXT T NIL))) (QUALFLG (GO C)) (T (RETURN SOURCE)))) ((AND QUALFLG (NOT PLURALFLG) (NULL (CDR SPECS))) % If this is a definite reference to a qualified entity, make the name % of the entity plural. (SETQ NAME (CAR SPECS)) (RPLACA SPECS (GLPLURAL (CAR SPECS))))) % Try to find the next name on the list of SPECS from SOURCE. (COND ((NULL SOURCE) (OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS)) NIL)) (RETURN (GLERROR 'GLTHE (LIST "The definite reference to" NAME "could not be found."))))) (SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS) CONTEXT)))) (GO B) C (COND ((or (not (pairp (SETQ DTYPE (GLXTRTYPE (CADR SOURCE))))) (ne (car dtype) 'LISTOF)) (OR (and (pairp (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (eq (car dtype) 'LISTOF)) (GLERROR 'GLTHE (LIST "The group name" NAME "has type" DTYPE "which is not a legal group type."))))) (SETQ NEWCONTEXT (CONS NIL CONTEXT)) (GLADDSTR (SETQ LOOPVAR (GLMKVAR)) NAME (CADR DTYPE) NEWCONTEXT) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT (MEMQ (pop EXPR) '(who Who WHO which Which WHICH that That THAT)) NIL)) (SETQ TMP (GLGENCODE (LIST (COND (PLURALFLG 'SUBSET) (T 'SOME)) (CAR SOURCE) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR LOOPCOND)))))) (RETURN (COND (PLURALFLG (LIST TMP DTYPE)) (T (LIST (LIST 'CAR TMP) (CADR DTYPE))))))) % edited: 20-MAY-82 17:19 % EXPR begins with THE. Parse the expression and return code in SOURCE % and path names in SPECS. (DE GLTHESPECS NIL (PROG NIL A (COND ((NULL EXPR) (RETURN NIL)) ((MEMQ (CAR EXPR) '(THE The the)) (pop EXPR) (COND ((NULL EXPR) (RETURN (GLERROR 'GLTHE (LIST "Nothing following THE"))))))) (COND ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (GLSEPNXT) (CAR EXPR)) (SETQ SPECS (CONS (pop EXPR) SPECS))) (T (GLSEPCLR) (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL)))) (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL))) % SPECS contains a path specification. See if there is any more. (COND ((MEMQ (CAR EXPR) '(OF Of of)) (pop EXPR) (GO A))))) % edited: 14-DEC-81 10:51 % Return a list of all transparent types defined for STR (DE GLTRANSPARENTTYPES (STR) (PROG (TTLIST) (COND ((ATOM STR) (SETQ STR (GLGETSTR STR)))) (GLTRANSPB STR) (RETURN (REVERSIP TTLIST)))) % edited: 13-NOV-81 15:37 % Look for TRANSPARENT substructures for GLTRANSPARENTTYPES. (DE GLTRANSPB (STR) (COND ((NOT (PAIRP STR))) ((EQ (CAR STR) 'TRANSPARENT) (SETQ TTLIST (CONS STR TTLIST))) ((MEMQ (CAR STR) '(LISTOF ALIST PROPLIST))) (T (MAPC (CDR STR) (FUNCTION GLTRANSPB))))) % edited: 4-JUN-82 11:18 % Translate places where a PROG variable is initialized to a value as % allowed by Interlisp. This is done by adding a SETQ to set the % value of each PROG variable which is initialized. In some cases, a % change of variable name is required to preserve the same % semantics. (DE GLTRANSPROG (X) (PROG (TMP ARGVALS SETVARS) (MAP (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP (CAR Y)) % If possible, use the same variable; otherwise, make a new one. (SETQ TMP (COND ((OR (SOME (CADR X) (FUNCTION (LAMBDA (Z) (AND (PAIRP Z) (GLOCCURS (CAR Z) (CADAR Y)))))) (SOME ARGVALS (FUNCTION (LAMBDA (Z) (GLOCCURS (CAAR Y) Z))))) (GLMKVAR)) (T (CAAR Y)))) (SETQ SETVARS (ACONC SETVARS (LIST 'SETQ TMP (CADAR Y)))) (SUBSTIP TMP (CAAR Y) (CDDR X)) (SETQ ARGVALS (CONS (CADAR Y) ARGVALS)) (RPLACA Y TMP)))))) (COND (SETVARS (RPLACD (CDR X) (NCONC SETVARS (CDDR X))))) (RETURN X))) % edited: 27-MAY-82 13:08 % GLUNITOP calls a function to generate code for an operation on a % unit in a units package. UNITREC is the unit record for the units % package, LHS and RHS the code for the left-hand side and % right-hand side of the operation % (in general, the (QUOTE GET') code for each side) , and OP is the % operation to be performed. (DE GLUNITOP (LHS RHS OP) (PROG (TMP LST UNITREC) % (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (RETURN NIL)) ((NOT (MEMQ (CAAR LHS) (CADAR LST))) (SETQ LST (CDR LST)) (GO A))) (SETQ UNITREC (CAR LST)) (COND ((SETQ TMP (ASSOC OP (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST LHS RHS))))) (RETURN NIL))) % edited: 27-MAY-82 13:08 % GLUNIT? tests a given structure to see if it is a unit of one of the % unit packages on GLUNITPKGS. If so, the value is the unit package % record for the unit package which matched. (DE GLUNIT? (STR) (PROG (UPS) (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (RETURN NIL)) ((APPLY (CAAR UPS) (LIST STR)) (RETURN (CAR UPS)))) (SETQ UPS (CDR UPS)) (GO LP))) % edited: 26-DEC-82 15:54 % Unwrap an expression X by removing extra stuff inserted during % compilation. (DE GLUNWRAP (X BUSY) (COND ((NOT (PAIRP X)) X) ((NOT (ATOM (CAR X))) (ERROR 0 (LIST 'GLUNWRAP X))) ((CASEQ (CAR X) ('GO X) ((PROG2 PROGN) (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN X) X))) (PROG1 (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (EQ Y (CDR X)))))))) (COND (BUSY (GLEXPANDPROGN (CDDR X))) (T (RPLACA X 'PROGN) (GLEXPANDPROGN X))) X))) (FUNCTION (RPLACA (CDR X) (GLUNWRAP (CADR X) BUSY)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) X) ((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY) (GLUNWRAPMAP X BUSY)) (LAMBDA (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CDDR X)) X) (PROG (GLUNWRAPPROG X BUSY)) (COND (GLUNWRAPCOND X BUSY)) ((SELECTQ CASEQ) (GLUNWRAPSELECTQ X BUSY)) ((UNION INTERSECTION LDIFFERENCE) (GLUNWRAPINTERSECT X)) (T (COND ((AND (EQ (CAR X) '*) (EQ GLLISPDIALECT 'INTERLISP)) X) ((AND (NOT BUSY) (CDR X) (NULL (CDDR X)) (GLPURE (CAR X))) (GLUNWRAP (CADR X) NIL)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (COND ((AND (CDR X) (NULL (CDDR X)) (PAIRP (CADR X)) (GLCARCDR? (CAR X)) (GLCARCDR? (CAADR X)) (LESSP (PLUS (FlatSize2 (CAR X)) (FlatSize2 (CAADR X))) 9)) (RPLACA X (IMPLODE (CONS 'C (REVERSIP (CONS 'R (NCONC (GLANYCARCDR? (CAADR X)) (GLANYCARCDR? (CAR X)))))))) (RPLACA (CDR X) (CADADR X)) (GLUNWRAP X BUSY)) ((AND (GET (CAR X) 'GLEVALWHENCONST) (EVERY (CDR X) (FUNCTION GLCONST?)) (OR (NOT (GET (CAR X) 'GLARGSNUMBERP)) (EVERY (CDR X) (FUNCTION NUMBERP)))) (EVAL X)) ((MEMQ (CAR X) '(AND OR)) (GLUNWRAPLOG X)) (T X))))))))) % edited: 23-APR-82 15:10 % Unwrap a COND expression. (DE GLUNWRAPCOND (X BUSY) (PROG (RESULT) (SETQ RESULT X) A (COND ((NULL (CDR RESULT)) (GO B))) (RPLACA (CADR RESULT) (GLUNWRAP (CAADR RESULT) T)) (COND ((EQ (CAADR RESULT) NIL) (RPLACD RESULT (CDDR RESULT)) (GO A)) (T (MAP (CDADR RESULT) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CDADR RESULT)))) (COND ((EQ (CAADR RESULT) T) (RPLACD (CDR RESULT) NIL))) (SETQ RESULT (CDR RESULT)) (GO A) B (COND ((AND (NULL (CDDR X)) (EQ (CAADR X) T)) (RETURN (CONS 'PROGN (CDADR X)))) (T (RETURN X))))) % edited: 26-DEC-82 16:30 % Optimize intersections and unions of subsets of the same set: % (INTERSECT (SUBSET S P) (SUBSET S Q)) -> (SUBSET S (AND P Q)) (DE GLUNWRAPINTERSECT (CODE) (PROG (LHS RHS P Q QQ SA SB NEWFN) (SETQ LHS (GLUNWRAP (CADR CODE) T)) (SETQ RHS (GLUNWRAP (CADDR CODE) T)) (OR (AND (PAIRP LHS) (PAIRP RHS) (EQ (CAR LHS) 'SUBSET) (EQ (CAR RHS) 'SUBSET)) (GO OUT)) (PROGN (SETQ SA (GLUNWRAP (CADR LHS) T)) (SETQ SB (GLUNWRAP (CADR RHS) T))) % Make sure the sets are the same. (OR (EQUAL SA SB) (GO OUT)) (PROGN (SETQ P (GLXTRFN (CADDR LHS))) (SETQ Q (GLXTRFN (CADDR RHS)))) (SETQ QQ (SUBST (CAR P) (CAR Q) (CADR Q))) (RETURN (GLGENCODE (LIST 'SUBSET SA (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR P)) (GLUNWRAP (CASEQ (CAR CODE) (INTERSECTION (LIST 'AND (CADR P) QQ)) (UNION (LIST 'OR (CADR P) QQ)) (LDIFFERENCE (LIST 'AND (CADR P) (LIST 'NOT QQ))) (T (ERROR 0 NIL))) T)))))) OUT (MAP (CDR CODE) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (RETURN CODE))) % edited: 26-DEC-82 16:24 % Unwrap a logical expression by performing constant transformations % and splicing in sublists of the same type, e.g., (AND X (AND Y Z)) % -> (AND X Y Z) . (DE GLUNWRAPLOG (X) (PROG (Y LAST) (SETQ Y (CDR X)) (SETQ LAST X) LP (COND ((NULL Y) (GO OUT)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'AND)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'OR))) (RPLACD Y NIL)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'OR)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'AND))) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((MEMBER (CAR Y) (CDR Y)) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((AND (PAIRP (CAR Y)) (EQ (CAAR Y) (CAR X))) (RPLACD (LASTPAIR (CAR Y)) (CDR Y)) (RPLACD Y (CDDAR Y)) (RPLACA Y (CADAR Y)))) (SETQ Y (CDR Y)) (SETQ LAST (CDR LAST)) (GO LP) OUT (COND ((NULL (CDR X)) (RETURN (EQ (CAR X) 'AND))) ((NULL (CDDR X)) (RETURN (CADR X)))) (RETURN X))) % edited: 19-OCT-82 16:03 % Unwrap and optimize mapping-type functions. (DE GLUNWRAPMAP (X BUSY) (PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST) (PROGN (SETQ LST (GLUNWRAP (CADR X) T)) (SETQ FN (GLUNWRAP (CADDR X) (NOT (MEMQ (CAR X) '(MAPC MAP)))))) (COND ((OR (NOT (MEMQ (SETQ OUTFN (CAR X)) '(SUBSET MAPCAR MAPC MAPCONC))) (NOT (AND (PAIRP LST) (MEMQ (SETQ INFN (CAR LST)) '(SUBSET MAPCAR))))) (GO OUT))) % Optimize compositions of mapping functions to avoid construction of % lists of intermediate results. % These optimizations are not correct if the mapping functions have % interdependent side-effects. However, these are likely to be very % rare, so we do it anyway. (SETQ OUTSIDE (GLXTRFN FN)) (SETQ INSIDE (GLXTRFN (PROGN (SETQ NEWLST (CADR LST)) (CADDR LST)))) (CASEQ INFN (SUBSET (CASEQ OUTFN ((SUBSET MAPCONC) (SETQ NEWMAP OUTFN) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE))))) (MAPCAR (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (LIST 'CONS (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) NIL)))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) ))) (T (ERROR 0 NIL)))) (MAPCAR (SETQ NEWFN (LIST 'PROG (LIST (SETQ TMPVAR (GLMKVAR))) (LIST 'SETQ TMPVAR (CADR INSIDE)) (LIST 'RETURN '*GLCODE*))) (CASEQ OUTFN (SUBSET (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (SUBST (LIST 'AND (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) (LIST 'CONS TMPVAR NIL)) '*GLCODE* NEWFN))) (MAPCAR (SETQ NEWMAP 'MAPCAR) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (T (ERROR 0 NIL)))) (T (ERROR 0 NIL))) (RETURN (GLUNWRAP (GLGENCODE (LIST NEWMAP NEWLST (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR INSIDE)) NEWFN)))) BUSY)) OUT (RETURN (GLGENCODE (LIST OUTFN LST FN))))) % edited: 18-NOV-82 12:18 % Unwrap a PROG expression. (DE GLUNWRAPPROG (X BUSY) (PROG (LAST) (COND ((NE GLLISPDIALECT 'INTERLISP) (GLTRANSPROG X))) % First see if the PROG is not busy and ends with a RETURN. (COND ((AND (NOT BUSY) (SETQ LAST (LASTPAIR X)) (PAIRP (CAR LAST)) (EQ (CAAR LAST) 'RETURN)) % Remove the RETURN. If atomic, remove the atom also. (COND ((ATOM (CADAR LAST)) (RPLACD (NLEFT X 2) NIL)) (T (RPLACA LAST (CADAR LAST)))))) % Do any initializations of PROG variables. (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP Y) (RPLACA (CDR Y) (GLUNWRAP (CADR Y) T))))))) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) NIL))))) (GLEXPANDPROGN (CDDR X)) (RETURN X))) % edited: 22-AUG-82 16:07 % Unwrap a SELECTQ or CASEQ expression. (DE GLUNWRAPSELECTQ (X BUSY) (PROG (L SELECTOR) % First unwrap the component expressions. (RPLACA (CDR X) (GLUNWRAP (CADR X) T)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (COND ((OR (CDR Y) (EQ (CAR X) 'CASEQ)) (MAP (CDAR Y) (FUNCTION (LAMBDA (Z) (RPLACA Z (GLUNWRAP (CAR Z) (AND BUSY (NULL (CDR Z)))))))) (GLEXPANDPROGN (CDAR Y))) (T (RPLACA Y (GLUNWRAP (CAR Y) BUSY))))))) % Test if the selector is a compile-time constant. (COND ((NOT (GLCONST? (CADR X))) (RETURN X))) % Evaluate the selection at compile time. (SETQ SELECTOR (GLCONSTVAL (CADR X))) (SETQ L (CDDR X)) LP (COND ((NULL L) (RETURN NIL)) ((AND (NULL (CDR L)) (EQ (CAR X) 'SELECTQ)) (RETURN (CAR L))) ((AND (EQ (CAR X) 'CASEQ) (EQ (CAAR L) T)) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY))) ((OR (EQ SELECTOR (CAAR L)) (AND (PAIRP (CAAR L)) (MEMQ SELECTOR (CAAR L)))) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY)))) (SETQ L (CDR L)) (GO LP))) % edited: 5-MAY-82 15:49 % Update the type of VAR to be TYPE. (DE GLUPDATEVARTYPE (VAR TYPE) (PROG (CTXENT) (COND ((NULL TYPE)) ((SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT)) (COND ((NULL (CADDR CTXENT)) (RPLACA (CDDR CTXENT) TYPE)))) (T (GLADDSTR VAR NIL TYPE CONTEXT))))) % edited: 6-MAY-82 11:17 % Process a user-function, i.e., any function which is not specially % compiled by GLISP. The function is tested to see if it is one % which a unit package wants to compile specially; if not, the % function is compiled by GLUSERFNB. (DE GLUSERFN (EXPR) (PROG (FNNAME TMP UPS) (SETQ FNNAME (CAR EXPR)) % First see if a user structure-name package wants to intercept this % function call. (SETQ UPS GLUSERSTRNAMES) LPA (COND ((NULL UPS) (GO B)) ((SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LPA) B % Test the function name to see if it is a function which some unit % package would like to intercept and compile specially. (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (RETURN (GLUSERFNB EXPR))) ((AND (MEMQ FNNAME (CAR (CDDDDR (CAR UPS)))) (SETQ TMP (ASSOC 'UNITFN (CADDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LP))) % edited: 26-JUL-82 16:01 % Parse an arbitrary function by getting the function name and then % calling GLDOEXPR to get the arguments. (DE GLUSERFNB (EXPR) (PROG (ARGS ARGTYPES FNNAME TMP) (SETQ FNNAME (pop EXPR)) A (COND ((NULL EXPR) (SETQ ARGS (REVERSIP ARGS)) (SETQ ARGTYPES (REVERSIP ARGTYPES)) (RETURN (COND ((AND (GET FNNAME 'GLEVALWHENCONST) (EVERY ARGS (FUNCTION GLCONST?))) (LIST (EVAL (CONS FNNAME ARGS)) (GLRESULTTYPE FNNAME ARGTYPES))) ((AND (GLABSTRACTFN? FNNAME) (SETQ TMP (GLINSTANCEFN FNNAME ARGTYPES))) (LIST (CONS (CAR TMP) ARGS) (GET (CAR TMP) 'GLRESULTTYPE))) (T (LIST (CONS FNNAME ARGS) (GLRESULTTYPE FNNAME ARGTYPES)))))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS (CAR TMP) ARGS)) (SETQ ARGTYPES (CONS (CADR TMP) ARGTYPES)) (GO A))))) % edited: 24-AUG-82 17:40 % Get the arguments to an function call for use by a user compilation % function. (DE GLUSERGETARGS (EXPR CONTEXT) (PROG (ARGS TMP) (pop EXPR) A (COND ((NULL EXPR) (RETURN (REVERSIP ARGS))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS TMP ARGS)) (GO A))))) % edited: 5-MAY-82 13:20 % Try to perform an operation on a user-defined structure, which is % LHS. The type of LHS is looked up on GLUSERSTRNAMES, and if found, % the appropriate user function is called. (DE GLUSERSTROP (LHS OP RHS) (PROG (TMP DES TMPB) (SETQ DES (CADR LHS)) (COND ((NULL DES) (RETURN NIL)) ((ATOM DES) (RETURN (GLUSERSTROP (LIST (CAR LHS) (GLGETSTR DES)) OP RHS))) ((NOT (PAIRP DES)) (RETURN NIL)) ((AND (SETQ TMP (ASSOC (CAR DES) GLUSERSTRNAMES)) (SETQ TMPB (ASSOC OP (CADDDR TMP)))) (RETURN (APPLY (CDR TMPB) (LIST LHS RHS)))) (T (RETURN NIL))))) % edited: 26-MAY-82 12:55 % Get the value of the property PROP from SOURCE, whose type is given % by TYPE. The property may be a field in the structure, or may be a % PROP virtual field. % DESLIST is a list of object types which have previously been tried, % so that a compiler loop can be prevented. (DE GLVALUE (SOURCE PROP TYPE DESLIST) (PROG (TMP PROPL TRANS FETCHCODE) (COND ((MEMQ TYPE DESLIST) (RETURN NIL)) ((SETQ TMP (GLSTRFN PROP TYPE DESLIST)) (RETURN (GLSTRVAL TMP SOURCE))) ((SETQ PROPL (GLSTRPROP TYPE 'PROP PROP)) (SETQ TMP (GLCOMPMSG (LIST SOURCE TYPE) PROPL NIL CONTEXT)) (RETURN TMP))) % See if the value can be found in a TRANSPARENT subobject. (SETQ TRANS (GLTRANSPARENTTYPES TYPE)) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLVALUE '*GL* PROP (GLXTRTYPE (CAR TRANS)) (CONS (CAR TRANS) DESLIST))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) TYPE NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP SOURCE) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % edited: 16-DEC-81 12:00 % Get the structure-description for a variable in the specified % context. (DE GLVARTYPE (VAR CONTEXT) (PROG (TMP) (RETURN (COND ((SETQ TMP (GLFINDVARINCTX VAR CONTEXT)) (OR (CADDR TMP) '*NIL*)) (T NIL))))) % edited: 3-DEC-82 10:24 % Extract the code and variable from a FUNCTION list. If there is no % variable, a new one is created. The result is a list of the % variable and code. (DE GLXTRFN (FNLST) (PROG (TMP) % If only the function name is specified, make a LAMBDA form. (COND ((ATOM (CADR FNLST)) (RPLACA (CDR FNLST) (LIST 'LAMBDA (LIST (SETQ TMP (GLMKVAR))) (LIST (CADR FNLST) TMP))))) (COND ((CDDDR (CADR FNLST)) (RPLACD (CDADR FNLST) (LIST (CONS 'PROGN (CDDADR FNLST)))))) (RETURN (LIST (CAADR (CADR FNLST)) (CADDR (CADR FNLST)))))) % edited: 26-JUL-82 14:03 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GLXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (OR (GL-A-AN? (CAR TYPE)) (EQ (CAR TYPE) 'TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPE (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 26-JUL-82 14:02 % Extract a -real- type from a type spec. (DE GLXTRTYPEB (TYPE) (COND ((NULL TYPE) NIL) ((ATOM TYPE) (COND ((MEMQ TYPE GLBASICTYPES) TYPE) (T (GLXTRTYPEB (GLGETSTR TYPE))))) ((NOT (PAIRP TYPE)) NIL) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPEB (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 1-NOV-82 16:38 % Extract a -real- type from a type spec. (DE GLXTRTYPEC (TYPE) (AND (ATOM TYPE) (NOT (MEMQ TYPE GLBASICTYPES)) (GLXTRTYPE (GLGETSTR TYPE)))) % edited: 17-NOV-82 11:25 (DF SEND (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) (CADR GLISPSENDARGS) 'MSG (MAPCAR (CDDR GLISPSENDARGS) (FUNCTION EVAL)))) % edited: 17-NOV-82 11:25 (DF SENDPROP (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (MAPCAR (CDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % % GLTAIL.PSL.10 14 Jan. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (CDR (GETD X))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NULL L) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (put (car x) 'glcompiled nil) (putd (car x) 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (GLINIT) |
Added psl-1983/glisp/oldglispb.sl version [0e69a2882a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 | % % GLHEAD.PSL.11 19 Jan. 1983 % % HEADER FOR GLISP FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (GLOBAL '(GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLOBJECTNAMES GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTTYPES gltypesused)) (FLUID '(TTLIST SPECS SOURCE GLGLOBALVARS DOMAINNAME ARGTYPES NOTFLG GLAMBDAFN ADDISATYPE PAIRLIST PROGG BITTBL KEY Y TYPES CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR *GL* *GLVAL* GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST TYPE GLNRECURSIONS glfnsubs glevalsubs)) % CASEQ MACRO FOR PSL (DM CASEQ (L) (PROG (CVAR CODE) (SETQ CVAR (COND ((ATOM (CADR L))(CADR L)) (T 'CASEQSELECTORVAR))) (SETQ CODE (CONS 'COND (MAPCAR (CDDR L) (FUNCTION (LAMBDA (X) (COND ((EQ (CAR X) T) X) ((ATOM (CAR X)) (CONS (LIST 'EQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))) (T (CONS (LIST 'MEMQ CVAR (LIST 'QUOTE (CAR X))) (CDR X))))))))) (RETURN (COND ((ATOM (CADR L)) CODE) (T (LIST 'PROG (LIST CVAR) (LIST 'SETQ CVAR (CADR L)) (LIST 'RETURN CODE))))))) % {DSK}GLISP.PSL;1 11-FEB-83 18:47:30 % edited: 4-JAN-83 11:35 % Transform an expression X for Portable Standard Lisp dialect. (DE GLPSLTRANSFM (X) (PROG (TMP NOTFLG) % First do argument reversals. (COND ((NOT (PAIRP X)) (RETURN X)) ((MEMQ (CAR X) '(push PUSH)) (SETQ X (LIST (CAR X) (CADDR X) (CADR X)))) ((MEMQ (CAR X) NIL) (SETQ X (LIST (CAR X) (CADR X) (CADDDR X) (CADDR X)))) ((EQ (CAR X) 'APPLY*) (SETQ X (LIST 'APPLY (CADR X) (CONS 'LIST (CDDR X)))))) % Now see if the result will be negated. (SETQ NOTFLG (MEMQ (CAR X) '(NLISTP BOUNDP GEQ LEQ IGEQ ILEQ))) (COND ((SETQ TMP (ASSOC (CAR X) '((MEMB MEMQ) (FMEMB MEMQ) (FASSOC ASSOC) (LITATOM IDP) (GETPROP GET) (GETPROPLIST PROP) (PUTPROP PUT) (LISTP PAIRP) (NLISTP PAIRP) (NEQ NE) (IGREATERP GREATERP) (IGEQ LESSP) (GEQ LESSP) (ILESSP LESSP) (ILEQ GREATERP) (LEQ GREATERP) (IPLUS PLUS) (IDIFFERENCE DIFFERENCE) (ITIMES TIMES) (IQUOTIENT QUOTIENT) (* CommentOutCode) (MAPCONC MAPCAN) (DECLARE CommentOutCode) (NCHARS FlatSize2) (NTHCHAR GLNTHCHAR) (DREVERSE REVERSIP) (STREQUAL String!=) (ALPHORDER String!<!=) (GLSTRGREATERP String!>) (GLSTRGEP String!>!=) (GLSTRLESSP String!<) (EQP EQN) (LAST LASTPAIR) (NTH PNth) (NCONC1 ACONC) (U-CASE GLUCASE) (DSUBST SUBSTIP) (BOUNDP UNBOUNDP) (KWOTE MKQUOTE) (UNPACK EXPLODE) (PACK IMPLODE)))) (SETQ X (CONS (CADR TMP) (CDR X)))) ((AND (EQ (CAR X) 'RETURN) (NULL (CDR X))) (SETQ X (LIST (CAR X) NIL))) ((AND (EQ (CAR X) 'APPEND) (NULL (CDDR X))) (SETQ X (LIST (CAR X) (CADR X) NIL))) ((EQ (CAR X) 'ERROR) (SETQ X (LIST (CAR X) 0 (COND ((NULL (CDR X)) NIL) ((NULL (CDDR X)) (CADR X)) (T (CONS 'LIST (CDR X))))))) ((EQ (CAR X) 'SELECTQ) (RPLACA X 'CASEQ) (SETQ TMP (NLEFT X 2)) (COND ((NULL (CADR TMP)) (RPLACD TMP NIL)) (T (RPLACD TMP (LIST (LIST T (CADR TMP)))))))) (RETURN (COND (NOTFLG (LIST 'NOT X)) (T X))))) % edited: 18-NOV-82 11:47 (DF A (L) (GLAINTERPRETER L)) % edited: 18-NOV-82 11:47 (DF AN (L) (GLAINTERPRETER L)) % edited: 29-OCT-81 14:25 (DE GL-A-AN? (X) (MEMQ X '(A AN a an An))) % edited: 26-JUL-82 14:15 % Test whether FNNAME is an abstract function. (DE GLABSTRACTFN? (FNNAME) (PROG (DEFN) (RETURN (AND (SETQ DEFN (GETD FNNAME)) (PAIRP DEFN) (EQ (CAR DEFN) 'MLAMBDA))))) % GSN 26-JAN-83 11:59 % Add a PROPerty entry of type PROPTYPE to structure STRNAME. (DE GLADDPROP (STRNAME PROPTYPE LST) (PROG (PL SUBPL) (OR (AND (ATOM STRNAME) (SETQ PL (GET STRNAME 'GLSTRUCTURE))) (ERROR 0 NIL)) (COND ((SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (PUTASSOC (CAR LST) (CDR LST) SUBPL)) (T (NCONC PL (LIST PROPTYPE (LIST LST))))))) % edited: 25-Jan-81 18:17 % Add the type SDES to RESULTTYPE in GLCOMP (DE GLADDRESULTTYPE (SDES) (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE SDES)) ((AND (PAIRP RESULTTYPE) (EQ (CAR RESULTTYPE) 'OR)) (COND ((NOT (MEMBER SDES (CDR RESULTTYPE))) (ACONC RESULTTYPE SDES)))) ((NOT (EQUAL SDES RESULTTYPE)) (SETQ RESULTTYPE (LIST 'OR RESULTTYPE SDES))))) % edited: 2-Jan-81 13:37 % Add an entry to the current context for a variable ATM, whose NAME % in context is given, and which has structure STR. The entry is % pushed onto the front of the list at the head of the context. (DE GLADDSTR (ATM NAME STR CONTEXT) (RPLACA CONTEXT (CONS (LIST ATM NAME STR) (CAR CONTEXT)))) % GSN 10-FEB-83 12:56 % edited: 17-Sep-81 13:58 % Compile code to test if SOURCE is PROPERTY. (DE GLADJ (SOURCE PROPERTY ADJWD) (PROG (ADJL TRANS TMP FETCHCODE) (COND ((EQ ADJWD 'ISASELF) (COND ((SETQ ADJL (GLSTRPROP PROPERTY 'ISA 'self NIL)) (GO A)) (T (RETURN NIL)))) ((SETQ ADJL (GLSTRPROP (CADR SOURCE) ADJWD PROPERTY NIL)) (GO A))) % See if the adjective can be found in a TRANSPARENT substructure. (SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE))) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLADJ (LIST '*GL* (GLXTRTYPE (CAR TRANS))) PROPERTY ADJWD)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR SOURCE) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR SOURCE)) (RETURN TMP)) (T (SETQ TRANS (CDR TRANS)) (GO B))) A (COND ((AND (PAIRP (CADR ADJL)) (MEMQ (CAADR ADJL) '(NOT Not not)) (ATOM (CADADR ADJL)) (NULL (CDDADR ADJL)) (SETQ TMP (GLSTRPROP (CADR SOURCE) ADJWD (CADADR ADJL) NIL))) (SETQ ADJL TMP) (SETQ NOTFLG (NOT NOTFLG)) (GO A))) (RETURN (GLCOMPMSGL SOURCE ADJWD ADJL NIL CONTEXT)))) % GSN 10-FEB-83 15:08 (DE GLAINTERPRETER (L) (PROG (CODE GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLNRECURSIONS) (SETQ GLNATOM 0) (SETQ GLNRECURSIONS 0) (SETQ FAULTFN 'GLAINTERPRETER) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (SETQ CODE (GLDOA (CONS 'A L))) (RETURN (EVAL (CAR CODE))))) % edited: 26-DEC-82 15:40 % AND operator (DE GLANDFN (LHS RHS) (COND ((NULL LHS) RHS) ((NULL RHS) LHS) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND) (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (APPEND (CAR LHS) (CDAR RHS)) (CADR LHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'AND)) (LIST (APPEND (CAR LHS) (LIST (CAR RHS))) (CADR LHS))) ((AND (PAIRP (CAR RHS)) (EQ (CAAR RHS) 'AND)) (LIST (CONS 'AND (CONS (CAR LHS) (CDAR RHS))) (CADR LHS))) ((AND (PAIRP (CADR RHS)) (EQ (CAADR RHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'INTERSECTION (CAR LHS) (CAR RHS)) (CADR RHS))) ((GLDOMSG LHS 'AND (LIST RHS))) ((GLUSERSTROP LHS 'AND RHS)) (T (LIST (LIST 'AND (CAR LHS) (CAR RHS)) (CADR RHS))))) % edited: 19-MAY-82 13:54 % Test if ATM is the name of any CAR/CDR combination. If so, the value % is a list of the intervening letters in reverse order. (DE GLANYCARCDR? (ATM) (PROG (RES N NMAX TMP) (OR (AND (EQ (GLNTHCHAR ATM 1) 'C) (EQ (GLNTHCHAR ATM -1) 'R)) (RETURN NIL)) (SETQ NMAX (SUB1 (FlatSize2 ATM))) (SETQ N 2) A (COND ((GREATERP N NMAX) (RETURN RES)) ((OR (EQ (SETQ TMP (GLNTHCHAR ATM N)) 'D) (EQ TMP 'A)) (SETQ RES (CONS TMP RES)) (SETQ N (ADD1 N)) (GO A)) (T (RETURN NIL))))) % edited: 26-OCT-82 15:26 % Try to get indicator IND from an ATOM structure. (DE GLATOMSTRFN (IND DES DESLIST) (PROG (TMP) (RETURN (OR (AND (SETQ TMP (ASSOC 'PROPLIST (CDR DES))) (GLPROPSTRFN IND TMP DESLIST T)) (AND (SETQ TMP (ASSOC 'BINDING (CDR DES))) (GLSTRVALB IND (CADR TMP) '(EVAL *GL*))))))) % GSN 1-FEB-83 16:35 % edited: 14-Sep-81 12:45 % Test whether STR is a legal ATOM structure. (DE GLATMSTR? (STR) (PROG (TMP) (COND ((OR (AND (CDR STR) (OR (NOT (PAIRP (CADR STR))) (AND (CDDR STR) (OR (NOT (PAIRP (CADDR STR))) (CDDDR STR)))))) (RETURN NIL))) (COND ((SETQ TMP (ASSOC 'BINDING (CDR STR))) (COND ((OR (CDDR TMP) (NULL (GLOKSTR? (CADR TMP)))) (RETURN NIL))))) (COND ((SETQ TMP (ASSOC 'PROPLIST (CDR STR))) (RETURN (EVERY (CDR TMP) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X))))))))) (RETURN T))) % edited: 23-DEC-82 10:43 % Test whether TYPE is implemented as an ATOM structure. (DE GLATOMTYPEP (TYPE) (PROG (TYPEB) (RETURN (OR (EQ TYPE 'ATOM) (AND (PAIRP TYPE) (MEMQ (CAR TYPE) '(ATOM ATOMOBJECT))) (AND (NE (SETQ TYPEB (GLXTRTYPEB TYPE)) TYPE) (GLATOMTYPEP TYPEB)))))) % edited: 24-AUG-82 17:21 (DE GLBUILDALIST (ALIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL ALIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop ALIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (ACONC LIS (GLBUILDCONS (MKQUOTE (CAR TMP1)) TMP2 T))))) (GO A))) % edited: 9-DEC-82 17:14 % Generate code to build a CONS structure. OPTFLG is true iff the % structure does not need to be a newly created one. (DE GLBUILDCONS (X Y OPTFLG) (COND ((NULL Y) (GLBUILDLIST (LIST X) OPTFLG)) ((AND (PAIRP Y) (EQ (CAR Y) 'LIST)) (GLBUILDLIST (CONS X (CDR Y)) OPTFLG)) ((AND OPTFLG (GLCONST? X) (GLCONST? Y)) (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y)))) ((AND (GLCONSTSTR? X) (GLCONSTSTR? Y)) (LIST 'COPY (LIST 'QUOTE (CONS (GLCONSTVAL X) (GLCONSTVAL Y))))) (T (LIST 'CONS X Y)))) % edited: 9-DEC-82 17:13 % Build a LIST structure, possibly doing compile-time constant % folding. OPTFLG is true iff the structure does not need to be a % newly created copy. (DE GLBUILDLIST (LST OPTFLG) (COND ((EVERY LST (FUNCTION GLCONST?)) (COND (OPTFLG (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))) (T (GLGENCODE (LIST 'APPEND (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))))) ((EVERY LST (FUNCTION GLCONSTSTR?)) (GLGENCODE (LIST 'COPY (LIST 'QUOTE (MAPCAR LST (FUNCTION GLCONSTVAL)))))) (T (CONS 'LIST LST)))) % edited: 19-OCT-82 15:05 % Build code to do (NOT CODE) , doing compile-time folding if % possible. (DE GLBUILDNOT (CODE) (PROG (TMP) (COND ((GLCONST? CODE) (RETURN (NOT (GLCONSTVAL CODE)))) ((NOT (PAIRP CODE)) (RETURN (LIST 'NOT CODE))) ((EQ (CAR CODE) 'NOT) (RETURN (CADR CODE))) ((NOT (ATOM (CAR CODE))) (RETURN NIL)) ((SETQ TMP (ASSOC (CAR CODE) '((EQ NE) (NE EQ) (LEQ GREATERP) (GEQ LESSP)))) (RETURN (CONS (CADR TMP) (CDR CODE)))) (T (RETURN (LIST 'NOT CODE)))))) % edited: 26-OCT-82 16:02 (DE GLBUILDPROPLIST (PLIST PREVLST) (PROG (LIS TMP1 TMP2) A (COND ((NULL PLIST) (RETURN (AND LIS (GLBUILDLIST LIS NIL))))) (SETQ TMP1 (pop PLIST)) (COND ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST)) (SETQ LIS (NCONC LIS (LIST (MKQUOTE (CAR TMP1)) TMP2))))) (GO A))) % edited: 12-NOV-82 11:26 % Build a RECORD structure. (DE GLBUILDRECORD (STR PAIRLIST PREVLST) (PROG (TEMP ITEMS RECORDNAME) (COND ((ATOM (CADR STR)) (SETQ RECORDNAME (CADR STR)) (SETQ ITEMS (CDDR STR))) (T (SETQ ITEMS (CDR STR)))) (COND ((EQ (CAR STR) 'OBJECT) (SETQ ITEMS (CONS '(CLASS ATOM) ITEMS)))) (RETURN (CONS 'Vector (MAPCAR ITEMS (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))) ))))) % edited: 11-NOV-82 12:01 % Generate code to build a structure according to the structure % description STR. PAIRLIST is a list of elements of the form % (SLOTNAME CODE TYPE) for each named slot to be filled in in the % structure. (DE GLBUILDSTR (STR PAIRLIST PREVLST) (PROG (PROPLIS TEMP PROGG TMPCODE ATMSTR) (SETQ ATMSTR '((ATOM) (INTEGER . 0) (REAL . 0.0) (NUMBER . 0) (BOOLEAN) (NIL) (ANYTHING))) (COND ((NULL STR) (RETURN NIL)) ((ATOM STR) (COND ((SETQ TEMP (ASSOC STR ATMSTR)) (RETURN (CDR TEMP))) ((MEMQ STR PREVLST) (RETURN NIL)) ((SETQ TEMP (GLGETSTR STR)) (RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST)))) (T (RETURN NIL)))) ((NOT (PAIRP STR)) (GLERROR 'GLBUILDSTR (LIST "Illegal structure type encountered:" STR)) (RETURN NIL))) (RETURN (CASEQ (CAR STR) (CONS (GLBUILDCONS (GLBUILDSTR (CADR STR) PAIRLIST PREVLST) (GLBUILDSTR (CADDR STR) PAIRLIST PREVLST) NIL)) (LIST (GLBUILDLIST (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST)))) NIL)) (LISTOBJECT (GLBUILDLIST (CONS (MKQUOTE (CAR PREVLST)) (MAPCAR (CDR STR) (FUNCTION (LAMBDA (X) (GLBUILDSTR X PAIRLIST PREVLST))))) NIL)) (ALIST (GLBUILDALIST (CDR STR) PREVLST)) (PROPLIST (GLBUILDPROPLIST (CDR STR) PREVLST)) (ATOM (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)) )) (T (LIST 'GENSYM)))))) (COND ((SETQ TEMP (ASSOC 'BINDING STR)) (SETQ TMPCODE (GLBUILDSTR (CADR TEMP) PAIRLIST PREVLST) ) (ACONC PROGG (LIST 'SET 'ATOMNAME TMPCODE)))) (COND ((SETQ TEMP (ASSOC 'PROPLIST STR)) (SETQ PROPLIS (CDR TEMP)) (GLPUTPROPS PROPLIS PREVLST))) (ACONC PROGG (COPY '(RETURN ATOMNAME))) PROGG) (ATOMOBJECT (SETQ PROGG (LIST 'PROG (LIST 'ATOMNAME) (LIST 'SETQ 'ATOMNAME (COND ((AND PREVLST (ATOM (CAR PREVLST))) (LIST 'GLMKATOM (MKQUOTE (CAR PREVLST)) )) (T (LIST 'GENSYM)))))) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (LIST 'QUOTE 'CLASS) (MKQUOTE (CAR PREVLST))) )) (GLPUTPROPS (CDR STR) PREVLST) (ACONC PROGG (COPY '(RETURN ATOMNAME)))) (TRANSPARENT (AND (NOT (MEMQ (CADR STR) PREVLST)) (SETQ TEMP (GLGETSTR (CADR STR))) (GLBUILDSTR TEMP PAIRLIST (CONS (CADR STR) PREVLST)))) (LISTOF NIL) (RECORD (GLBUILDRECORD STR PAIRLIST PREVLST)) (OBJECT (GLBUILDRECORD STR (CONS (LIST 'CLASS (MKQUOTE (CAR PREVLST)) 'ATOM) PAIRLIST) PREVLST)) (t (COND ((ATOM (CAR STR)) (COND ((SETQ TEMP (ASSOC (CAR STR) PAIRLIST)) (CADR TEMP)) ((AND (ATOM (CADR STR)) (NOT (ASSOC (CADR STR) ATMSTR))) (GLBUILDSTR (CADR STR) NIL PREVLST)) (T (GLBUILDSTR (CADR STR) PAIRLIST PREVLST)))) (T NIL))))))) % edited: 19-MAY-82 14:27 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPE (LST STR) (COND ((NULL LST) STR) ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST (GLGETSTR STR))) ((NOT (PAIRP STR)) (ERROR 0 NIL)) (T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR))))) % edited: 19-MAY-82 14:41 % Find the result type for a CAR/CDR function applied to a structure % whose description is STR. LST is a list of A and D in application % order. (DE GLCARCDRRESULTTYPEB (LST STR) (COND ((NULL STR) NIL) ((ATOM STR) (GLCARCDRRESULTTYPE LST STR)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((AND (ATOM (CAR STR)) (NOT (MEMQ (CAR STR) GLTYPENAMES)) (CDR STR) (NULL (CDDR STR))) (GLCARCDRRESULTTYPE LST (CADR STR))) ((EQ (CAR LST) 'A) (COND ((OR (EQ (CAR STR) 'LISTOF) (EQ (CAR STR) 'CONS) (EQ (CAR STR) 'LIST)) (GLCARCDRRESULTTYPE (CDR LST) (CADR STR))) (T NIL))) ((EQ (CAR LST) 'D) (COND ((EQ (CAR STR) 'CONS) (GLCARCDRRESULTTYPE (CDR LST) (CADDR STR))) ((EQ (CAR STR) 'LIST) (COND ((CDDR STR) (GLCARCDRRESULTTYPE (CDR LST) (CONS 'LIST (CDDR STR)))) (T NIL))) ((EQ (CAR STR) 'LISTOF) (GLCARCDRRESULTTYPE (CDR LST) STR)))) (T (ERROR 0 NIL)))) % edited: 13-JAN-82 13:45 % Test if X is a CAR or CDR combination up to 3 long. (DE GLCARCDR? (X) (MEMQ X '(CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR))) % edited: 5-OCT-82 15:24 (DE GLCC (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN)))) % GSN 18-JAN-83 15:04 % Get the Class of object OBJ. (DE GLCLASS (OBJ) (PROG (CLASS) (RETURN (AND (SETQ CLASS (COND ((VectorP OBJ) (GetV OBJ 0)) ((ATOM OBJ) (GET OBJ 'CLASS)) ((PAIRP OBJ) (CAR OBJ)) (T NIL))) (GLCLASSP CLASS) CLASS)))) % edited: 11-NOV-82 11:23 % Test whether the object OBJ is a member of class CLASS. (DE GLCLASSMEMP (OBJ CLASS) (GLDESCENDANTP (GLCLASS OBJ) CLASS)) % edited: 11-NOV-82 11:45 % See if CLASS is a Class name. (DE GLCLASSP (CLASS) (PROG (TMP) (RETURN (AND (ATOM CLASS) (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (MEMQ (CAR (GLXTRTYPE (CAR TMP))) '(OBJECT ATOMOBJECT LISTOBJECT)))))) % GSN 9-FEB-83 16:58 % Execute a message to CLASS with selector SELECTOR and arguments % ARGS. PROPNAME is one of MSG, ADJ, ISA, PROP. (DE GLCLASSSEND (CLASS SELECTOR ARGS PROPNAME) (PROG (FNCODE) (COND ((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME)) (RETURN (COND ((ATOM FNCODE) (EVAL (CONS FNCODE (MAPCAR ARGS (FUNCTION KWOTE))))) (T (APPLY FNCODE ARGS)))))) (RETURN 'GLSENDFAILURE))) % GSN 10-FEB-83 15:09 % GLISP compiler function. GLAMBDAFN is the atom whose function % definition is being compiled; GLEXPR is the GLAMBDA expression to % be compiled. The compiled function is saved on the property list % of GLAMBDAFN under the indicator GLCOMPILED. The property % GLRESULTTYPE is the RESULT declaration, if specified; GLGLOBALS is % a list of global variables referenced and their types. (DE GLCOMP (GLAMBDAFN GLEXPR GLTYPESUBS GLFNSUBS ARGTYPES) (PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX RESULTTYPE GLGLOBALVARS RESULT GLSEPATOM GLSEPPTR VALBUSY EXPRSTACK GLTU GLNRECURSIONS) (SETQ GLSEPPTR 0) (SETQ GLNRECURSIONS 0) (COND ((NOT GLQUIETFLG) (PRINT (LIST 'GLCOMP GLAMBDAFN)))) (SETQ EXPRSTACK (LIST GLEXPR)) (SETQ GLNATOM 0) (SETQ GLTOPCTX (LIST NIL)) (SETQ GLTU GLTYPESUSED) (SETQ GLTYPESUSED NIL) % Process the argument list of the GLAMBDA. (SETQ NEWARGS (GLDECL (CADR GLEXPR) '(T NIL) GLTOPCTX GLAMBDAFN ARGTYPES)) % See if there is a RESULT declaration. (SETQ GLEXPR (CDDR GLEXPR)) (GLSKIPCOMMENTS) (GLRESGLOBAL) (GLSKIPCOMMENTS) (GLRESGLOBAL) (SETQ VALBUSY (NULL (CDR GLEXPR))) (SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX))) (PUT GLAMBDAFN 'GLRESULTTYPE (OR RESULTTYPE (CADR NEWEXPR))) (PUT GLAMBDAFN 'GLTYPESUSED GLTYPESUSED) (GLSAVEFNTYPES GLAMBDAFN GLTYPESUSED) (SETQ RESULT (GLUNWRAP (CONS 'LAMBDA (CONS NEWARGS (CAR NEWEXPR))) T)) (SETQ GLTYPESUSED GLTU) (RETURN RESULT))) % GSN 2-FEB-83 14:52 % Compile an abstract function into an instance function given the % specified set of type substitutions and function substitutions. (DE GLCOMPABSTRACT (FN INSTFN TYPESUBS FNSUBS ARGTYPES) (PROG (TMP) (COND (INSTFN) ((SETQ TMP (ASSOC FN FNSUBS)) (SETQ INSTFN (CDR TMP))) (T (SETQ INSTFN (GLINSTANCEFNNAME FN)))) (SETQ FNSUBS (CONS (CONS FN INSTFN) FNSUBS)) % Now compile the abstract function with the specified type % substitutions. (PUTD INSTFN (GLCOMP INSTFN (GLGETD FN) TYPESUBS FNSUBS ARGTYPES)) (RETURN INSTFN))) % GSN 10-FEB-83 15:09 % Compile a GLISP expression. CODE is a GLISP expression. VARLST is a % list of lists (VAR TYPE) . The result is a list (OBJCODE TYPE) % where OBJCODE is the Lisp code corresponding to CODE and TYPE is % the type returned by OBJCODE. (DE GLCOMPEXPR (CODE VARLST) (PROG (OBJCODE GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPEXPR) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (MAPC VARLST (FUNCTION (LAMBDA (X) (GLADDSTR (CAR X) NIL (CADR X) CONTEXT)))) (COND ((SETQ OBJCODE (GLPUSHEXPR CODE T CONTEXT T)) (RETURN (LIST (GLUNWRAP (CAR OBJCODE) T) (CADR OBJCODE))))))) % edited: 27-MAY-82 12:58 % Compile the function definition stored for the atom FAULTFN using % the GLISP compiler. (DE GLCOMPILE (FAULTFN) (GLAMBDATRAN (GLGETD FAULTFN))FAULTFN) % edited: 4-MAY-82 11:13 % Compile FN if not already compiled. (DE GLCOMPILE? (FN) (OR (GET FN 'GLCOMPILED) (GLCOMPILE FN))) % GSN 10-FEB-83 15:33 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSG (OBJECT MSGLST ARGLIST CONTEXT) (PROG (RESULT) (COND ((GREATERP (SETQ GLNRECURSIONS (ADD1 GLNRECURSIONS)) 9) (RETURN (GLERROR 'GLCOMPMSG (LIST "Infinite loop detected in compiling" (CAR MSGLST) "for object of type" (CADR OBJECT)))))) (SETQ RESULT (GLCOMPMSGB OBJECT MSGLST ARGLIST CONTEXT)) (SETQ GLNRECURSIONS (SUB1 GLNRECURSIONS)) (RETURN RESULT))) % GSN 10-FEB-83 15:13 % Compile a Message. MSGLST is the Message list, consisting of message % selector, code, and properties defined with the message. (DE GLCOMPMSGB (OBJECT MSGLST ARGLIST CONTEXT) (PROG (GLPROGLST RESULTTYPE METHOD RESULT VTYPE) (SETQ RESULTTYPE (LISTGET (CDDR MSGLST) 'RESULT)) (SETQ METHOD (CADR MSGLST)) (COND ((ATOM METHOD) % Function name is specified. (COND ((LISTGET (CDDR MSGLST) 'OPEN) (RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST) (CONS (CADR OBJECT) (LISTGET (CDDR MSGLST) 'ARGTYPES)) RESULTTYPE (LISTGET (CDDR MSGLST) 'SPECVARS)))) (T (RETURN (LIST (CONS METHOD (CONS (CAR OBJECT) (MAPCAR ARGLIST (FUNCTION CAR)))) (OR (GLRESULTTYPE METHOD (CONS (CADR OBJECT) (MAPCAR ARGLIST (FUNCTION CADR)))) (LISTGET (CDDR MSGLST) 'RESULT))))))) ((NOT (PAIRP METHOD)) (RETURN (GLERROR 'GLCOMPMSG (LIST "The form of Response is illegal for message" (CAR MSGLST))))) ((AND (PAIRP (CAR METHOD)) (MEMQ (CAAR METHOD) '(virtual Virtual VIRTUAL))) (OR (SETQ VTYPE (LISTGET (CDDR MSGLST) 'VTYPE)) (PROGN (SETQ VTYPE (GLMAKEVTYPE (CADR OBJECT) (CAR METHOD))) (NCONC MSGLST (LIST 'VTYPE VTYPE)))) (RETURN (LIST (CAR OBJECT) VTYPE)))) % The Method is a list of stuff to be compiled open. (SETQ CONTEXT (LIST NIL)) (COND ((ATOM (CAR OBJECT)) (GLADDSTR (LIST 'PROG1 (CAR OBJECT)) 'self (CADR OBJECT) CONTEXT)) ((AND (PAIRP (CAR OBJECT)) (EQ (CAAR OBJECT) 'PROG1) (ATOM (CADAR OBJECT)) (NULL (CDDAR OBJECT))) (GLADDSTR (CAR OBJECT) 'self (CADR OBJECT) CONTEXT)) (T (SETQ GLPROGLST (CONS (LIST 'self (CAR OBJECT)) GLPROGLST)) (GLADDSTR 'self NIL (CADR OBJECT) CONTEXT))) (SETQ RESULT (GLPROGN METHOD CONTEXT)) % If more than one expression resulted, embed in a PROGN. (RPLACA RESULT (COND ((CDAR RESULT) (CONS 'PROGN (CAR RESULT))) (T (CAAR RESULT)))) (RETURN (LIST (COND (GLPROGLST (GLGENCODE (LIST 'PROG GLPROGLST (LIST 'RETURN (CAR RESULT))))) (T (CAR RESULT))) (OR RESULTTYPE (CADR RESULT)))))) % GSN 3-FEB-83 14:48 % Attempt to compile code for a message list for an object. OBJECT is % the destination, in the form (<code> <type>) , PROPTYPE is the % property type (ADJ etc.) , MSGLST is the message list, and ARGS is % a list of arguments of the form (<code> <type>) . The result is of % the form (<code> <type>) , or NIL if failure. (DE GLCOMPMSGL (OBJECT PROPTYPE MSGLST ARGS CONTEXT) (PROG (TYPE SELECTOR NEWFN NEWMSGLST) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (SETQ SELECTOR (CAR MSGLST)) (RETURN (COND ((LISTGET (CDDR MSGLST) 'MESSAGE) (SETQ CONTEXT (LIST NIL)) (GLADDSTR (CAR OBJECT) 'self TYPE CONTEXT) (LIST (COND ((EQ PROPTYPE 'MSG) (CONS 'SEND (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (T (CONS 'SENDPROP (CONS (CAR OBJECT) (CONS SELECTOR (CONS PROPTYPE (MAPCAR ARGS (FUNCTION CAR)))))))) (GLEVALSTR (LISTGET (CDDR MSGLST) 'RESULT) NIL))) ((LISTGET (CDDR MSGLST) 'SPECIALIZE) (SETQ NEWFN (GLINSTANCEFNNAME (CADR MSGLST))) (SETQ NEWMSGLST (LIST (CAR MSGLST) NEWFN 'SPECIALIZATION T)) (GLADDPROP (CADR OBJECT) PROPTYPE NEWMSGLST) (GLCOMPABSTRACT (CADR MSGLST) NEWFN NIL NIL (CONS (CADR OBJECT) (MAPCAR ARGS (FUNCTION CADR)))) (PUT NEWFN 'GLSPECIALIZATION (CONS (LIST (CADR MSGLST) (CADR OBJECT) PROPTYPE SELECTOR) (GET NEWFN 'GLSPECIALIZATION))) (NCONC NEWMSGLST (LIST 'RESULT (GET NEWFN 'GLRESULTTYPE))) (GLCOMPMSG OBJECT NEWMSGLST ARGS CONTEXT)) (T (GLCOMPMSG OBJECT MSGLST ARGS CONTEXT)))))) % GSN 26-JAN-83 10:13 % Compile the function FN Open, given as arguments ARGS with argument % types ARGTYPES. Types may be defined in the definition of function % FN (which may be either a GLAMBDA or LAMBDA function) or by % ARGTYPES; ARGTYPES takes precedence. (DE GLCOMPOPEN (FN ARGS ARGTYPES RESULTTYPE SPCVARS) (PROG (PTR FNDEF GLPROGLST NEWEXPR CONTEXT NEWARGS) % Put a new level on top of CONTEXT. (SETQ CONTEXT (LIST NIL)) (SETQ FNDEF (GLGETD FN)) % Get the parameter declarations and add to CONTEXT. (GLDECL (CADR FNDEF) '(T NIL) CONTEXT NIL NIL) % Make the function parameters into names and put in the values, % hiding any which are simple variables. (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (COND ((EQ ARGS T) (GLADDSTR (CAAR PTR) NIL (OR (CAR ARGTYPES) (CADDAR PTR)) CONTEXT) (SETQ NEWARGS (CONS (CAAR PTR) NEWARGS))) ((AND (ATOM (CAAR ARGS)) (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS))) % Wrap the atom in a PROG1 so it won't match as a name; the PROG1 will % generally be stripped later. (GLADDSTR (LIST 'PROG1 (CAAR ARGS)) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) ((AND (NE SPCVARS T) (NOT (MEMQ (CAAR PTR) SPCVARS)) (PAIRP (CAAR ARGS)) (EQ (CAAAR ARGS) 'PROG1) (ATOM (CADAAR ARGS)) (NULL (CDDAAR ARGS))) (GLADDSTR (CAAR ARGS) (CAAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT)) (T % Since the actual argument is not atomic, make a PROG variable for % it. (SETQ GLPROGLST (CONS (LIST (CAAR PTR) (CAAR ARGS)) GLPROGLST)) (GLADDSTR (CAAR PTR) (CADAR PTR) (OR (CADAR ARGS) (CAR ARGTYPES) (CADDAR PTR)) CONTEXT))) (SETQ PTR (CDR PTR)) (COND ((PAIRP ARGS) (SETQ ARGS (CDR ARGS)))) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ FNDEF (CDDR FNDEF)) % Get rid of comments at start of function. C (COND ((AND FNDEF (PAIRP (CAR FNDEF)) (EQ (CAAR FNDEF) '*)) (SETQ FNDEF (CDR FNDEF)) (GO C))) (SETQ NEWEXPR (GLPROGN FNDEF CONTEXT)) % Get rid of atomic result if it isnt busy outside. (COND ((AND (NOT VALBUSY) (CDAR EXPR) (OR (ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR) 2)))) (AND (PAIRP (CADR PTR)) (EQ (CAADR PTR) 'PROG1) (ATOM (CADADR PTR)) (NULL (CDDADR PTR))))) (RPLACD PTR NIL))) (SETQ RESULT (LIST (COND (GLPROGLST (SETQ PTR (LASTPAIR (CAR NEWEXPR))) (RPLACA PTR (LIST 'RETURN (CAR PTR))) (GLGENCODE (CONS 'PROG (CONS (REVERSIP GLPROGLST) (CAR NEWEXPR))))) ((CDAR NEWEXPR) (CONS 'PROGN (CAR NEWEXPR))) (T (CAAR NEWEXPR))) (OR RESULTTYPE (GLRESULTTYPE FN NIL) (CADR NEWEXPR)))) (COND ((EQ ARGS T) (RPLACA RESULT (LIST 'LAMBDA (REVERSIP NEWARGS) (CAR RESULT))))) (RETURN RESULT))) % GSN 1-FEB-83 16:18 % Compile a LAMBDA expression to compute the property PROPNAME of type % PROPTYPE for structure STR. The property type STR is allowed for % structure access. (DE GLCOMPPROP (STR PROPNAME PROPTYPE) (PROG (CODE PL SUBPL PROPENT) % See if the property has already been compiled. (COND ((AND (SETQ PL (GET STR 'GLPROPFNS)) (SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL)))) (RETURN (CADR PROPENT)))) % Compile code for this property and save it. (COND ((NOT (MEMQ PROPTYPE '(STR ADJ ISA PROP MSG))) (ERROR 0 NIL))) (OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE)) (RETURN NIL)) (COND ((NOT PL) (PUT STR 'GLPROPFNS (SETQ PL (COPY '((STR) (PROP) (ADJ) (ISA) (MSG))))) (SETQ SUBPL (ASSOC PROPTYPE PL)))) (RPLACD SUBPL (CONS (CONS PROPNAME CODE) (CDR SUBPL))) (RETURN (CAR CODE)))) % GSN 10-FEB-83 15:10 % Compile a message as a closed form, i.e., function name or LAMBDA % form. (DE GLCOMPPROPL (STR PROPNAME PROPTYPE) (PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN GLNRECURSIONS) (SETQ FAULTFN 'GLCOMPPROPL) (SETQ GLNRECURSIONS 0) (SETQ GLNATOM 0) (SETQ VALBUSY T) (SETQ GLSEPPTR 0) (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL))) (COND ((EQ PROPTYPE 'STR) (COND ((SETQ CODE (GLSTRFN PROPNAME STR NIL)) (RETURN (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (SUBSTIP 'self '*GL* (CAR CODE)) T)) (CADR CODE)))) (T (RETURN NIL)))) ((SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME NIL)) (COND ((ATOM (CADR MSGL)) (COND ((LISTGET (CDDR MSGL) 'OPEN) (SETQ CODE (GLCOMPOPEN (CADR MSGL) T (LIST STR) NIL NIL))) (T (SETQ CODE (LIST (CADR MSGL) (GLRESULTTYPE (CADR MSGL) NIL)))))) ((SETQ CODE (GLADJ (LIST 'self STR) PROPNAME PROPTYPE)) (SETQ CODE (LIST (LIST 'LAMBDA (LIST 'self) (GLUNWRAP (CAR CODE) T)) (CADR CODE)))))) ((SETQ TRANS (GLTRANSPARENTTYPES STR)) (GO B)) (T (RETURN NIL))) (RETURN (LIST (GLUNWRAP (CAR CODE) T) (OR (CADR CODE) (LISTGET (CDDR MSGL) 'RESULT)))) % Look for the message in a contained TRANSPARENT type. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS)) PROPNAME PROPTYPE)) (COND ((ATOM (CAR TMP)) (GLERROR 'GLCOMPPROPL (LIST "GLISP cannot currently handle inheritance of the property" PROPNAME "which is specified as a function name in a TRANSPARENT subtype. Sorry.")) (RETURN NIL))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) STR NIL)) (SETQ NEWVAR (GLMKVAR)) (GLSTRVAL FETCHCODE NEWVAR) (RETURN (LIST (GLUNWRAP (LIST 'LAMBDA (CONS NEWVAR (CDADAR TMP)) (LIST 'PROG (LIST (LIST (CAADAR TMP) (CAR FETCHCODE))) (LIST 'RETURN (CADDAR TMP)))) T) (CADR TMP)))) (T (SETQ TRANS (CDR TRANS)) (GO B))))) % edited: 30-DEC-82 10:39 % Attempt to infer the type of a constant expression. (DE GLCONSTANTTYPE (EXPR) (PROG (TMP TYPES) (COND ((SETQ TMP (COND ((FIXP EXPR) 'INTEGER) ((NUMBERP EXPR) 'NUMBER) ((ATOM EXPR) 'ATOM) ((STRINGP EXPR) 'STRING) ((NOT (PAIRP EXPR)) 'ANYTHING) ((EVERY EXPR (FUNCTION FIXP)) '(LISTOF INTEGER)) ((EVERY EXPR (FUNCTION NUMBERP)) '(LISTOF NUMBER)) ((EVERY EXPR (FUNCTION ATOM)) '(LISTOF ATOM)) ((EVERY EXPR (FUNCTION STRINGP)) '(LISTOF STRING)))) (RETURN TMP))) (SETQ TYPES (MAPCAR EXPR (FUNCTION GLCONSTANTTYPE))) (COND ((EVERY (CDR TYPES) (FUNCTION (LAMBDA (Y) (EQUAL Y (CAR TYPES))))) (RETURN (LIST 'LISTOF (CAR TYPES)))) (T (RETURN (CONS 'LIST TYPES)))))) % edited: 31-AUG-82 15:38 % Test X to see if it represents a compile-time constant value. (DE GLCONST? (X) (OR (NULL X) (EQ X T) (NUMBERP X) (AND (PAIRP X) (EQ (CAR X) 'QUOTE) (ATOM (CADR X))) (AND (ATOM X) (GET X 'GLISPCONSTANTFLG)))) % edited: 9-DEC-82 17:02 % Test to see if X is a constant structure. (DE GLCONSTSTR? (X) (OR (GLCONST? X) (AND (PAIRP X) (OR (EQ (CAR X) 'QUOTE) (AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NE (CAR X) 'APPEND) (NULL (CDDR X)) (NULL (CADDR X)))) (AND (EQ (CAR X) 'LIST) (EVERY (CDR X) (FUNCTION GLCONSTSTR?))) (AND (EQ (CAR X) 'CONS) (GLCONSTSTR? (CADR X)) (GLCONSTSTR? (CADDR X))))))) % edited: 9-DEC-82 17:07 % Get the value of a compile-time constant (DE GLCONSTVAL (X) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) ((AND (PAIRP X) (EQ (CAR X) 'QUOTE)) (CADR X)) ((PAIRP X) (COND ((AND (MEMQ (CAR X) '(COPY APPEND)) (PAIRP (CADR X)) (EQ (CAADR X) 'QUOTE) (OR (NULL (CDDR X)) (NULL (CADDR X)))) (CADADR X)) ((EQ (CAR X) 'LIST) (MAPCAR (CDR X) (FUNCTION GLCONSTVAL))) ((EQ (CAR X) 'CONS) (CONS (GLCONSTVAL (CADR X)) (GLCONSTVAL (CADDR X)))) (T (ERROR 0 NIL)))) ((AND (ATOM X) (GET X 'GLISPCONSTANTFLG)) (GET X 'GLISPCONSTANTVAL)) (T (ERROR 0 NIL)))) % edited: 5-OCT-82 15:23 (DE GLCP (FN) (SETQ FN (OR FN GLLASTFNCOMPILED))(COND ((NOT (GLGETD FN)) (PRIN1 FN) (PRIN1 " ?") (TERPRI)) (T (GLCOMPILE FN) (GLP FN)))) % GSN 28-JAN-83 09:29 % edited: 1-Jun-81 16:02 % Process a declaration list from a GLAMBDA expression. Each element % of the list is of the form <var>, <var>:<str-descr>, :<str-descr>, % or <var>: (A <str-descr>) or (A <str-descr>) . Forms without a % variable are accepted only if NOVAROK is true. If VALOK is true, a % PROG form (variable value) is allowed. The result is a list of % variable names. (DE GLDECL (LST FLGS GLTOPCTX FN ARGTYPES) (PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR NOVAROK VALOK) (SETQ NOVAROK (CAR FLGS)) (SETQ VALOK (CADR FLGS)) (COND ((NULL GLTOPCTX) (ERROR 0 NIL))) A % Get the next variable/description from LST (COND ((NULL LST) (SETQ ARGTYPES NIL) (SETQ CONTEXT GLTOPCTX) (MAPC (CAR GLTOPCTX) (FUNCTION (LAMBDA (S) (SETQ ARGTYPES (CONS (GLEVALSTR (CADDR S) GLTOPCTX) ARGTYPES)) (RPLACA (CDDR S) (CAR ARGTYPES))))) (SETQ RESULT (REVERSIP RESULT)) (COND (FN (PUT FN 'GLARGUMENTTYPES ARGTYPES))) (RETURN RESULT))) (SETQ TOP (pop LST)) (COND ((NOT (ATOM TOP)) (GO B))) (SETQ VARS NIL) (SETQ STR NIL) (GLSEPINIT TOP) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (COND ((EQ FIRST ':) (COND ((NULL SECOND) (COND ((AND NOVAROK LST (GLOKSTR? (CAR LST))) (GLDECLDS (GLMKVAR) (pop LST)) (GO A)) (T (GO E)))) ((AND NOVAROK (GLOKSTR? SECOND) (NULL (GLSEPNXT))) (GLDECLDS (GLMKVAR) SECOND) (GO A)) (T (GO E))))) D % At least one variable name has been found. Collect other variable % names until a <type> is found. (SETQ VARS (ACONC VARS FIRST)) (COND ((NULL SECOND) (GO C)) ((EQ SECOND ':) (COND ((AND (SETQ THIRD (GLSEPNXT)) (GLOKSTR? THIRD) (NULL (GLSEPNXT))) (SETQ STR THIRD) (GO C)) ((AND (NULL THIRD) (GLOKSTR? (CAR LST))) (SETQ STR (pop LST)) (GO C)) (T (GO E)))) ((EQ SECOND '!,) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)) ((ATOM (CAR LST)) (GLSEPINIT (pop LST)) (SETQ FIRST (GLSEPNXT)) (SETQ SECOND (GLSEPNXT)) (GO D)))) (T (GO E))) C % Define the <type> for each variable on VARS. (MAPC VARS (FUNCTION (LAMBDA (X) (GLDECLDS X STR)))) (GO A) B % The top of LST is non-atomic. Must be either (A <type>) or % (<var> <value>) . (COND ((AND (GL-A-AN? (CAR TOP)) NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) ((AND VALOK (NOT (GL-A-AN? (CAR TOP))) (ATOM (CAR TOP)) (CDR TOP)) (SETQ EXPR (CDR TOP)) (SETQ TMP (GLDOEXPR NIL GLTOPCTX T)) (COND (EXPR (GO E))) (GLADDSTR (CAR TOP) NIL (CADR TMP) GLTOPCTX) (SETQ RESULT (CONS (LIST (CAR TOP) (CAR TMP)) RESULT))) ((AND NOVAROK (GLOKSTR? TOP)) (GLDECLDS (GLMKVAR) TOP)) (T (GO E))) (GO A) E (GLERROR 'GLDECL (LIST "Bad argument structure" LST)) (RETURN NIL))) % GSN 26-JAN-83 13:17 % edited: 2-Jan-81 13:39 % Add ATM to the RESULT list of GLDECL, and declare its structure. (DE GLDECLDS (ATM STR) (PROG NIL % If a substitution exists for this type, use it. (COND (ARGTYPES (SETQ STR (pop ARGTYPES))) (GLTYPESUBS (SETQ STR (GLSUBSTTYPE STR GLTYPESUBS)))) (SETQ RESULT (CONS ATM RESULT)) (GLADDSTR ATM NIL STR GLTOPCTX))) % GSN 26-JAN-83 10:28 % Declare variables and types in top of CONTEXT. (DE GLDECLS (VARS TYPES CONTEXT) (PROG NIL A (COND ((NULL VARS) (RETURN NIL))) (GLADDSTR (CAR VARS) NIL (CAR TYPES) CONTEXT) (SETQ VARS (CDR VARS)) (SETQ TYPES (CDR TYPES)) (GO A))) % edited: 19-MAY-82 13:33 % Define the result types for a list of functions. The format of the % argument is a list of dotted pairs, (FN . TYPE) (DE GLDEFFNRESULTTYPES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (PUT Y 'GLRESULTTYPE (CAR X))))))))) % edited: 19-MAY-82 13:05 % Define the result type functions for a list of functions. The format % of the argument is a list of dotted pairs, (FN . TYPEFN) (DE GLDEFFNRESULTTYPEFNS (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PUT (CAR X) 'GLRESULTTYPEFN (CDR X)))))) % edited: 26-OCT-82 12:18 % Define properties for an object type. Each property is of the form % (<propname> (<definition>) <properties>) (DE GLDEFPROP (OBJECT PROP LST) (PROG (LSTP) (MAPC LST (FUNCTION (LAMBDA (X) (COND ((NOT (OR (AND (EQ PROP 'SUPERS) (ATOM X)) (AND (PAIRP X) (ATOM (CAR X)) (CDR X)))) (PRIN1 "GLDEFPROP: For object ") (PRIN1 OBJECT) (PRIN1 " the ") (PRIN1 PROP) (PRIN1 " property ") (PRIN1 X) (PRIN1 " has bad form.") (TERPRI) (PRIN1 "This property was ignored.") (TERPRI)) (T (SETQ LSTP (CONS X LSTP))))))) (NCONC (GET OBJECT 'GLSTRUCTURE) (LIST PROP (REVERSIP LSTP))))) % GSN 10-FEB-83 12:31 % edited: 17-Sep-81 12:21 % Process a Structure Description. The format of the argument is the % name of the structure followed by its structure description, % followed by other optional arguments. (DE GLDEFSTR (LST SYSTEMFLG) (PROG (STRNAME STR OLDSTR) (SETQ STRNAME (pop LST)) (COND ((AND (NOT SYSTEMFLG) (MEMQ STRNAME GLBASICTYPES)) (PRIN1 "The GLISP type ") (PRIN1 STRNAME) (PRIN1 " may not be redefined by the user.") (TERPRI) (RETURN NIL)) ((SETQ OLDSTR (GET STRNAME 'GLSTRUCTURE)) (COND ((EQUAL OLDSTR LST) (RETURN NIL)) ((NOT GLQUIETFLG) (PRIN1 STRNAME) (PRIN1 " structure redefined.") (TERPRI))) (GLSTRCHANGED STRNAME)) ((NOT SYSTEMFLG) NIL)) (SETQ STR (pop LST)) (PUT STRNAME 'GLSTRUCTURE (LIST STR)) (COND ((NOT (GLOKSTR? STR)) (PRIN1 STRNAME) (PRIN1 " has faulty structure specification.") (TERPRI))) (COND ((NOT (MEMQ STRNAME GLOBJECTNAMES)) (SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES)))) % Process the remaining specifications, if any. Each additional % specification is a list beginning with a keyword. LP (COND ((NULL LST) (RETURN NIL))) (CASEQ (CAR LST) ((ADJ Adj adj) (GLDEFPROP STRNAME 'ADJ (CADR LST))) ((PROP Prop prop) (GLDEFPROP STRNAME 'PROP (CADR LST))) ((ISA Isa IsA isA isa) (GLDEFPROP STRNAME 'ISA (CADR LST))) ((MSG Msg msg) (GLDEFPROP STRNAME 'MSG (CADR LST))) (t (GLDEFPROP STRNAME (CAR LST) (CADR LST)))) (SETQ LST (CDDR LST)) (GO LP))) % edited: 27-APR-82 11:01 (DF GLDEFSTRNAMES (LST) (MAPC LST (FUNCTION (LAMBDA (X) (PROG (TMP) (COND ((SETQ TMP (ASSOC (CAR X) GLUSERSTRNAMES)) (RPLACD TMP (CDR X))) (T (SETQ GLUSERSTRNAMES (ACONC GLUSERSTRNAMES X)) ))))))) % GSN 10-FEB-83 11:50 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % GSN 10-FEB-83 12:13 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLDEFSYSSTRQ (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG T))))) % edited: 27-MAY-82 13:00 % This function is called by the user to define a unit package to the % GLISP system. The argument, a unit record, is a list consisting of % the name of a function to test an entity to see if it is a unit of % the units package, the name of the unit package's runtime GET % function, and an ALIST of operations on units and the functions to % perform those operations. Operations include GET, PUT, ISA, ISADJ, % NCONC, REMOVE, PUSH, and POP. (DE GLDEFUNITPKG (UNITREC) (PROG (LST) (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (SETQ GLUNITPKGS (ACONC GLUNITPKGS UNITREC)) (RETURN NIL)) ((EQ (CAAR LST) (CAR UNITREC)) (RPLACA LST UNITREC))) (SETQ LST (CDR LST)) (GO A))) % GSN 23-JAN-83 15:39 % Remove the GLISP structure definition for NAME. (DE GLDELDEF (NAME TYPE) (PUT NAME 'GLSTRUCTURE NIL)) % edited: 28-NOV-82 15:18 (DE GLDESCENDANTP (SUBCLASS CLASS) (PROG (SUPERS) (COND ((EQ SUBCLASS CLASS) (RETURN T))) (SETQ SUPERS (GLGETSUPERS SUBCLASS)) LP (COND ((NULL SUPERS) (RETURN NIL)) ((GLDESCENDANTP (CAR SUPERS) CLASS) (RETURN T))) (SETQ SUPERS (CDR SUPERS)) (GO LP))) % GSN 30-JAN-83 15:32 % edited: 25-Jun-81 15:26 % Function to compile an expression of the form (A <type> ...) (DE GLDOA (EXPR) (PROG (TYPE UNITREC TMP) (SETQ TYPE (CADR EXPR)) (COND ((AND (PAIRP TYPE) (EQ (CAR TYPE) 'TYPEOF)) (RETURN (GLMAKESTR (GLGETTYPEOF TYPE) (CDDR EXPR)))) ((GLGETSTR TYPE) (RETURN (GLMAKESTR TYPE (CDDR EXPR)))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'A (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST EXPR)))) (T (GLERROR 'GLDOA (LIST "The type" TYPE "is not defined.")))))) % GSN 10-FEB-83 12:56 % Compile code for Case statement. (DE GLDOCASE (EXPR) (PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK ELSECLAUSE TMPB) (SETQ TYPEOK T) (SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (CAR TMP)) (SETQ SELECTORTYPE (CADR TMP)) (SETQ EXPR (CDDR EXPR)) % Get rid of of if present (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ EXPR (CDR EXPR)))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS 'SELECTQ (CONS SELECTOR (ACONC RESULT ELSECLAUSE)))) RESULTTYPE))) ((MEMQ (CAR EXPR) '(ELSE Else else)) (SETQ TMP (GLPROGN (CDR EXPR) CONTEXT)) (SETQ ELSECLAUSE (COND ((CDAR TMP) (CONS 'PROGN (CAR TMP))) (T (CAAR TMP)))) (SETQ EXPR NIL)) (T (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (SETQ RESULT (ACONC RESULT (CONS (COND ((ATOM (CAAR EXPR)) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES (CAAR EXPR) NIL)) (CADR TMPB)) (CAAR EXPR))) (T (MAPCAR (CAAR EXPR) (FUNCTION (LAMBDA (X) (OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE 'VALUES X NIL)) (CADR TMPB)) X)))))) (CAR TMP)))))) % If all the result types are the same, then we know the result of the % Case statement. (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 23-APR-82 14:38 % Compile a COND expression. (DE GLDOCOND (CONDEXPR) (PROG (RESULT TMP TYPEOK RESULTTYPE) (SETQ TYPEOK T) A (COND ((NULL (SETQ CONDEXPR (CDR CONDEXPR))) (GO B))) (SETQ TMP (GLPROGN (CAR CONDEXPR) CONTEXT)) (COND ((NE (CAAR TMP) NIL) (SETQ RESULT (ACONC RESULT (CAR TMP))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ RESULTTYPE NIL) (SETQ TYPEOK NIL))))))) (COND ((NE (CAAR TMP) T) (GO A))) B (RETURN (LIST (COND ((AND (NULL (CDR RESULT)) (EQ (CAAR RESULT) T)) (CONS 'PROGN (CDAR RESULT))) (T (CONS 'COND RESULT))) (AND TYPEOK RESULTTYPE))))) % edited: 30-DEC-82 10:49 % Compile a single expression. START is set if EXPR is the start of a % new expression, i.e., if EXPR might be a function call. The global % variable EXPR is the expression, CONTEXT the context in which it % is compiled. VALBUSY is T if the value of the expression is needed % outside the expression. The value is a list of the new expression % and its value-description. (DE GLDOEXPR (START CONTEXT VALBUSY) (PROG (FIRST TMP RESULT) (SETQ EXPRSTACK (CONS EXPR EXPRSTACK)) (COND ((NOT (PAIRP EXPR)) (GLERROR 'GLDOEXPR (LIST "Expression is not a list.")) (GO OUT)) ((AND (NOT START) (STRINGP (CAR EXPR))) (SETQ RESULT (LIST (PROG1 (CAR EXPR) (SETQ EXPR (CDR EXPR))) 'STRING)) (GO OUT)) ((OR (NOT (IDP (CAR EXPR))) (NOT START)) (GO A))) % Test the initial atom to see if it is a function name. It is assumed % to be a function name if it doesnt contain any GLISP operators and % the following atom doesnt start with a GLISP binary operator. (COND ((AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAR EXPR) '*)) (SETQ RESULT (LIST EXPR NIL)) (GO OUT)) ((MEMQ (CAR EXPR) ''Quote) (SETQ FIRST (CAR EXPR)) (GO B))) (GLSEPINIT (CAR EXPR)) % See if the initial atom contains an expression operator. (COND ((NE (SETQ FIRST (GLSEPNXT)) (CAR EXPR)) (COND ((OR (MEMQ (CAR EXPR) '(APPLY* BLKAPPLY* PACK* PP*)) (GETD (CAR EXPR)) (GET (CAR EXPR) 'MACRO) (AND (NE FIRST '~) (GLOPERATOR? FIRST))) (GLSEPCLR) (SETQ FIRST (CAR EXPR)) (GO B)) (T (GLSEPCLR) (GO A)))) ((OR (EQ FIRST '~) (EQ FIRST '-)) (GLSEPCLR) (GO A)) ((OR (NOT (PAIRP (CDR EXPR))) (NOT (IDP (CADR EXPR)))) (GO B))) % See if the initial atom is followed by an expression operator. (GLSEPINIT (CADR EXPR)) (SETQ TMP (GLSEPNXT)) (GLSEPCLR) (COND ((GLOPERATOR? TMP) (GO A))) % The EXPR is a function reference. Test for system functions. B (SETQ RESULT (CASEQ FIRST ('Quote (LIST EXPR (GLCONSTANTTYPE (CADR EXPR)))) ((GO Go go) (LIST EXPR NIL)) ((PROG Prog prog) (GLDOPROG EXPR CONTEXT)) ((FUNCTION Function function) (GLDOFUNCTION EXPR NIL CONTEXT T)) ((SETQ Setq setq) (GLDOSETQ EXPR)) ((COND Cond cond) (GLDOCOND EXPR)) ((RETURN Return return) (GLDORETURN EXPR)) ((FOR For for) (GLDOFOR EXPR)) ((THE The the) (GLDOTHE EXPR)) ((THOSE Those those) (GLDOTHOSE EXPR)) ((IF If if) (GLDOIF EXPR CONTEXT)) ((A a AN An an) (GLDOA EXPR)) ((_ SEND Send send) (GLDOSEND EXPR)) ((PROGN PROG2) (GLDOPROGN EXPR)) (PROG1 (GLDOPROG1 EXPR CONTEXT)) ((SELECTQ CASEQ) (GLDOSELECTQ EXPR CONTEXT)) ((WHILE While while) (GLDOWHILE EXPR CONTEXT)) ((REPEAT Repeat repeat) (GLDOREPEAT EXPR)) ((CASE Case case) (GLDOCASE EXPR)) ((MAP MAPLIST MAPCON MAPC MAPCAR MAPCONC MAPCAN) (GLDOMAP EXPR)) (t (GLUSERFN EXPR)))) (GO OUT) A % The current EXPR is possibly a GLISP expression. Parse the next % subexpression using GLPARSEXPR. (SETQ RESULT (GLPARSEXPR)) OUT (SETQ EXPRSTACK (CDR EXPRSTACK)) (RETURN RESULT))) % GSN 9-FEB-83 17:02 % edited: 21-Apr-81 11:25 % Compile code for a FOR loop. (DE GLDOFOR (EXPR) (PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT LOOPCONTENTS SINGFLAG LOOPCOND COLLECTCODE) (SETQ ORIGEXPR EXPR) (pop EXPR) % Parse the forms (FOR EACH <set> ...) and (FOR <var> IN <set> ...) (COND ((MEMQ (CAR EXPR) '(EACH Each each)) (SETQ SINGFLAG T) (pop EXPR)) ((AND (ATOM (CAR EXPR)) (MEMQ (CADR EXPR) '(IN In in))) (SETQ LOOPVAR (pop EXPR)) (pop EXPR)) (T (GO X))) % Now get the <set> (COND ((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG))) (GO X))) (SETQ DTYPE (GLXTRTYPE (CADR DOMAIN))) (COND ((OR (NULL DTYPE) (EQ DTYPE 'ANYTHING)) (SETQ DTYPE '(LISTOF ANYTHING))) ((OR (NOT (PAIRP DTYPE)) (NE (CAR DTYPE) 'LISTOF)) (OR (AND (PAIRP (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (EQ (CAR DTYPE) 'LISTOF)) (NULL DTYPE) (RETURN (GLERROR 'GLDOFOR (LIST "The domain of a FOR loop is of type" DTYPE "which is not a LISTOF type.")))) )) % Add a level onto the context for the inside of the loop. (SETQ NEWCONTEXT (CONS NIL CONTEXT)) % If a loop variable wasnt specified, make one. (OR LOOPVAR (SETQ LOOPVAR (GLMKVAR))) (GLADDSTR LOOPVAR (AND SINGFLAG DOMAINNAME) (CADR DTYPE) NEWCONTEXT) % See if a condition is specified. If so, add it to LOOPCOND. (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT NIL NIL))) ((MEMQ (CAR EXPR) '(WHICH Which which WHO Who who THAT That that)) (pop EXPR) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT T T)))) (COND ((AND EXPR (MEMQ (CAR EXPR) '(when When WHEN))) (pop EXPR) (SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT T))))) (COND ((MEMQ (CAR EXPR) '(collect Collect COLLECT)) (pop EXPR) (SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T))) (T (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) (SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT))))) (RETURN (GLMAKEFORLOOP LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)) X (RETURN (GLUSERFN ORIGEXPR)))) % GSN 26-JAN-83 10:14 % Compile a functional expression. TYPES is a list of argument types % which is sent in from outside, e.g. when a mapping function is % compiled. (DE GLDOFUNCTION (EXPR ARGTYPES CONTEXT VALBUSY) (PROG (NEWCODE RESULTTYPE PTR ARGS) (COND ((NOT (AND (PAIRP EXPR) (MEMQ (CAR EXPR) ''FUNCTION))) (RETURN (GLPUSHEXPR EXPR T CONTEXT T))) ((ATOM (CADR EXPR)) (RETURN (LIST EXPR (GLRESULTTYPE (CADR EXPR) ARGTYPES)))) ((NOT (MEMQ (CAADR EXPR) '(GLAMBDA LAMBDA))) (GLERROR 'GLDOFUNCTION (LIST "Bad functional form.")))) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ ARGS (GLDECL (CADADR EXPR) '(T NIL) CONTEXT NIL NIL)) (SETQ PTR (REVERSIP (CAR CONTEXT))) (RPLACA CONTEXT NIL) LP (COND ((NULL PTR) (GO B))) (GLADDSTR (CAAR PTR) NIL (OR (CADDAR PTR) (CAR ARGTYPES)) CONTEXT) (SETQ PTR (CDR PTR)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP) B (SETQ NEWCODE (GLPROGN (CDDADR EXPR) CONTEXT)) (RETURN (LIST (LIST 'FUNCTION (CONS 'LAMBDA (CONS ARGS (CAR NEWCODE)))) (CADR NEWCODE))))) % edited: 4-MAY-82 10:46 % Process an IF ... THEN expression. (DE GLDOIF (EXPR CONTEXT) (PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT) (SETQ OLDCONTEXT CONTEXT) (pop EXPR) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'COND CONDLIST) TYPE)))) (SETQ CONTEXT (CONS NIL OLDCONTEXT)) (SETQ PRED (GLPREDICATE NIL CONTEXT NIL T)) (COND ((MEMQ (CAR EXPR) '(THEN Then then)) (pop EXPR))) (SETQ ACTIONS (CONS (CAR PRED) NIL)) (SETQ TYPE (CADR PRED)) C (SETQ CONDLIST (ACONC CONDLIST ACTIONS)) B (COND ((NULL EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSEIF ElseIf Elseif elseIf elseif)) (pop EXPR) (GO A)) ((MEMQ (CAR EXPR) '(ELSE Else else)) (pop EXPR) (SETQ ACTIONS (CONS T NIL)) (SETQ TYPE 'BOOLEAN) (GO C)) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (ACONC ACTIONS (CAR TMP)) (SETQ TYPE (CADR TMP)) (GO B)) (T (GLERROR 'GLDOIF (LIST "IF statement contains bad code.")))))) % edited: 16-DEC-81 15:47 % Compile a LAMBDA expression for which the ARGTYPES are given. (DE GLDOLAMBDA (EXPR ARGTYPES CONTEXT) (PROG (ARGS NEWEXPR VALBUSY) (SETQ ARGS (CADR EXPR)) (SETQ CONTEXT (CONS NIL CONTEXT)) LP (COND (ARGS (GLADDSTR (CAR ARGS) NIL (CAR ARGTYPES) CONTEXT) (SETQ ARGS (CDR ARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LP))) (SETQ VALBUSY T) (SETQ NEWEXPR (GLPROGN (CDDR EXPR) CONTEXT)) (RETURN (LIST (CONS 'LAMBDA (CONS (CADR EXPR) (CAR NEWEXPR))) (CADR NEWEXPR))))) % edited: 30-MAY-82 16:12 % Get a domain specification from the EXPR. If SINGFLAG is set and the % top of EXPR is a simple atom, the atom is made plural and used as % a variable or field name. (DE GLDOMAIN (SINGFLAG) (PROG (NAME FIRST) (COND ((MEMQ (CAR EXPR) '(THE The the)) (SETQ FIRST (CAR EXPR)) (RETURN (GLPARSFLD NIL))) ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (SETQ NAME (GLSEPNXT)) (CAR EXPR)) (pop EXPR) (SETQ DOMAINNAME NAME) (RETURN (COND (SINGFLAG (COND ((MEMQ (CAR EXPR) '(OF Of of)) (SETQ FIRST 'THE) (SETQ EXPR (CONS (GLPLURAL NAME) EXPR)) (GLPARSFLD NIL)) (T (GLIDNAME (GLPLURAL NAME) NIL)))) (T (GLIDNAME NAME NIL))))) (T (GLSEPCLR) (RETURN (GLDOEXPR NIL CONTEXT T))))) (T (RETURN (GLDOEXPR NIL CONTEXT T)))))) % edited: 29-DEC-82 14:50 % Compile code for MAP functions. MAPs are treated specially so that % types can be propagated. (DE GLDOMAP (EXPR) (PROG (MAPFN MAPSET SETTYPE MAPCODE NEWCODE RESULTTYPE ITEMTYPE) (SETQ MAPFN (CAR EXPR)) (SETQ EXPR (CDR EXPR)) (PROGN (SETQ MAPSET (GLDOEXPR NIL CONTEXT T)) (COND ((OR (NULL EXPR) (CDR EXPR)) (GLERROR 'GLDOMAP (LIST "Bad form of mapping function."))) (T (SETQ MAPCODE (CAR EXPR))))) (SETQ SETTYPE (GLXTRTYPEB (CADR MAPSET))) (COND ((AND (PAIRP SETTYPE) (EQ (CAR SETTYPE) 'LISTOF)) (SETQ ITEMTYPE (CASEQ MAPFN ((MAP MAPLIST MAPCON) SETTYPE) ((MAPC MAPCAR MAPCONC MAPCAN) (CADR SETTYPE)) (t (ERROR 0 NIL)))))) (SETQ NEWCODE (GLDOFUNCTION MAPCODE (LIST ITEMTYPE) CONTEXT (MEMQ MAPFN '(MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) ))) (SETQ RESULTTYPE (CASEQ MAPFN ((MAP MAPC) NIL) ((MAPLIST MAPCON MAPCAR MAPCONC MAPCAN) (LIST 'LISTOF (CADR NEWCODE))) (t (ERROR 0 NIL)))) (RETURN (LIST (GLGENCODE (LIST MAPFN (CAR MAPSET) (CAR NEWCODE))) RESULTTYPE)))) % GSN 10-FEB-83 12:56 % Attempt to compile code for the sending of a message to an object. % OBJECT is the destination, in the form (<code> <type>) , SELECTOR % is the message selector, and ARGS is a list of arguments of the % form (<code> <type>) . The result is of this form, or NIL if % failure. (DE GLDOMSG (OBJECT SELECTOR ARGS) (PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE) (SETQ TYPE (GLXTRTYPE (CADR OBJECT))) (COND ((SETQ METHOD (GLSTRPROP TYPE 'MSG SELECTOR ARGS)) (RETURN (GLCOMPMSGL OBJECT 'MSG METHOD ARGS CONTEXT))) ((AND (SETQ UNITREC (GLUNIT? TYPE)) (SETQ TMP (ASSOC 'MSG (CADDR UNITREC)))) (RETURN (APPLY (CDR TMP) (LIST OBJECT SELECTOR ARGS)))) ((SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT)))) ((AND (MEMQ TYPE '(NUMBER REAL INTEGER)) (MEMQ SELECTOR '(+ - * / ^ > < >= <=)) ARGS (NULL (CDR ARGS)) (MEMQ (GLXTRTYPE (CADAR ARGS)) '(NUMBER REAL INTEGER))) (RETURN (GLREDUCEARITH SELECTOR OBJECT (CAR ARGS)))) (T (RETURN NIL))) % See if the message can be handled by a TRANSPARENT subobject. B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLDOMSG (LIST '*GL* (GLXTRTYPE (CAR TRANS))) SELECTOR ARGS)) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) (CADR OBJECT) NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP (CAR OBJECT)) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % GSN 26-JAN-83 10:14 % edited: 17-Sep-81 14:01 % Compile a PROG expression. (DE GLDOPROG (EXPR CONTEXT) (PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE) (pop EXPR) (SETQ CONTEXT (CONS NIL CONTEXT)) (SETQ PROGLST (GLDECL (pop EXPR) '(NIL T) CONTEXT NIL NIL)) (SETQ CONTEXT (CONS NIL CONTEXT)) % Compile the contents of the PROG onto NEWEXPR % Compile the next expression in a PROG. L (COND ((NULL EXPR) (GO X))) (SETQ NEXTEXPR (pop EXPR)) (COND ((ATOM NEXTEXPR) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) % ***** % Set up the context for the label we just found. (GO L)) ((NOT (PAIRP NEXTEXPR)) (GLERROR 'GLDOPROG (LIST "PROG contains bad stuff:" NEXTEXPR)) (GO L)) ((EQ (CAR NEXTEXPR) '*) (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR)) (GO L))) (COND ((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL)) (SETQ NEWEXPR (CONS (CAR TMP) NEWEXPR)))) (GO L) X (SETQ RESULT (CONS 'PROG (CONS PROGLST (REVERSIP NEWEXPR)))) (RETURN (LIST RESULT RESULTTYPE)))) % edited: 5-NOV-81 14:31 % Compile a PROGN in the source program. (DE GLDOPROGN (EXPR) (PROG (RES) (SETQ RES (GLPROGN (CDR EXPR) CONTEXT)) (RETURN (LIST (CONS (CAR EXPR) (CAR RES)) (CADR RES))))) % edited: 25-JAN-82 17:34 % Compile a PROG1, whose result is the value of its first argument. (DE GLDOPROG1 (EXPR CONTEXT) (PROG (RESULT TMP TYPE TYPEFLG) (SETQ EXPR (CDR EXPR)) A (COND ((NULL EXPR) (RETURN (LIST (CONS 'PROG1 (REVERSIP RESULT)) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG))) (SETQ RESULT (CONS (CAR TMP) RESULT)) % Get the result type from the first item of the PROG1. (COND ((NOT TYPEFLG) (SETQ TYPE (CADR TMP)) (SETQ TYPEFLG T))) (GO A)) (T (GLERROR 'GLDOPROG1 (LIST "PROG1 contains bad subexpression.")) (pop EXPR) (GO A))))) % edited: 26-MAY-82 15:12 (DE GLDOREPEAT (EXPR) (PROG (ACTIONS TMP LABEL) (pop EXPR) A (COND ((MEMQ (CAR EXPR) '(UNTIL Until until)) (pop EXPR)) ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (RETURN (GLERROR 'GLDOREPEAT (LIST "REPEAT contains bad subexpression."))))) (COND ((OR (NULL EXPR) (NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL))) EXPR) (GLERROR 'GLDOREPEAT (LIST "REPEAT contains no UNTIL or bad UNTIL clause")) (SETQ TMP (LIST T 'BOOLEAN)))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (CONS 'PROG (CONS NIL (CONS LABEL (ACONC ACTIONS (LIST 'COND (LIST (GLBUILDNOT (CAR TMP)) (LIST 'GO LABEL))))))) NIL)))) % edited: 7-Apr-81 11:49 % Compile a RETURN, capturing the type of the result as a type of the % function result. (DE GLDORETURN (EXPR) (PROG (TMP) (pop EXPR) (COND ((NULL EXPR) (GLADDRESULTTYPE NIL) (RETURN '((RETURN) NIL))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (GLADDRESULTTYPE (CADR TMP)) (RETURN (LIST (LIST 'RETURN (CAR TMP)) (CADR TMP))))))) % edited: 26-AUG-82 09:30 % Compile a SELECTQ. Special treatment is necessary in order to quote % the selectors implicitly. (DE GLDOSELECTQ (EXPR CONTEXT) (PROG (RESULT RESULTTYPE TYPEOK KEY TMP TMPB FN) (SETQ FN (CAR EXPR)) (SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR)) NIL CONTEXT T)))) (SETQ TYPEOK T) (SETQ EXPR (CDDR EXPR)) % If the selection criterion is constant, do it directly. (COND ((OR (SETQ KEY (NUMBERP (CAR RESULT))) (AND (PAIRP (CAR RESULT)) (EQ (CAAR RESULT) 'QUOTE) (SETQ KEY (CADAR RESULT)))) (SETQ TMP (SOME EXPR (FUNCTION (LAMBDA (X) (COND ((ATOM (CAR X)) (EQUAL KEY (CAR X))) ((PAIRP (CAR X)) (MEMBER KEY (CAR X))) (T NIL)))))) (COND ((OR (NULL TMP) (NULL (CDR TMP))) (SETQ TMPB (GLPROGN (LASTPAIR EXPR) CONTEXT))) (T (SETQ TMPB (GLPROGN (CDAR TMP) CONTEXT)))) (RETURN (LIST (CONS 'PROGN (CAR TMPB)) (CADR TMPB))))) A (COND ((NULL EXPR) (RETURN (LIST (GLGENCODE (CONS FN RESULT)) RESULTTYPE)))) (SETQ RESULT (ACONC RESULT (COND ((OR (CDR EXPR) (EQ FN 'CASEQ)) (SETQ TMP (GLPROGN (CDAR EXPR) CONTEXT)) (CONS (CAAR EXPR) (CAR TMP))) (T (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (CAR TMP))))) (COND (TYPEOK (COND ((NULL RESULTTYPE) (SETQ RESULTTYPE (CADR TMP))) ((EQUAL RESULTTYPE (CADR TMP))) (T (SETQ TYPEOK NIL) (SETQ RESULTTYPE NIL))))) (SETQ EXPR (CDR EXPR)) (GO A))) % edited: 4-JUN-82 15:35 % Compile code for the sending of a message to an object. The syntax % of the message expression is % (_ <object> <selector> <arg1>...<argn>) , where the _ may % optionally be SEND, Send, or send. (DE GLDOSEND (EXPRR) (PROG (EXPR OBJECT SELECTOR ARGS TMP FNNAME) (SETQ FNNAME (CAR EXPRR)) (SETQ EXPR (CDR EXPRR)) (SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR)) NIL CONTEXT T)) (SETQ SELECTOR (pop EXPR)) (COND ((OR (NULL SELECTOR) (NOT (IDP SELECTOR))) (RETURN (GLERROR 'GLDOSEND (LIST SELECTOR "is an illegal message Selector."))))) % Collect arguments of the message, if any. A (COND ((NULL EXPR) (COND ((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS)) (RETURN TMP)) (T % No message was defined, so just pass it through and hope one will be % defined by runtime. (RETURN (LIST (GLGENCODE (CONS FNNAME (CONS (CAR OBJECT) (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR)))))) (CADR OBJECT)))))) ((SETQ TMP (GLDOEXPR NIL CONTEXT T)) (SETQ ARGS (ACONC ARGS TMP)) (GO A)) (T (GLERROR 'GLDOSEND (LIST "A message argument is bad.")))))) % edited: 7-Apr-81 11:52 % Compile a SETQ expression (DE GLDOSETQ (EXPR) (PROG (VAR) (pop EXPR) (SETQ VAR (pop EXPR)) (RETURN (GLDOVARSETQ VAR (GLDOEXPR NIL CONTEXT T))))) % edited: 20-MAY-82 15:13 % Process a THE expression in a list. (DE GLDOTHE (EXPR) (PROG (RESULT) (SETQ RESULT (GLTHE NIL)) (COND (EXPR (GLERROR 'GLDOTHE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 20-MAY-82 15:16 % Process a THE expression in a list. (DE GLDOTHOSE (EXPR) (PROG (RESULT) (SETQ EXPR (CDR EXPR)) (SETQ RESULT (GLTHE T)) (COND (EXPR (GLERROR 'GLDOTHOSE (LIST "Stuff left over at end of The expression." EXPR)))) (RETURN RESULT))) % edited: 5-MAY-82 15:51 % Compile code to do a SETQ of VAR to the RHS. If the type of VAR is % unknown, it is set to the type of RHS. (DE GLDOVARSETQ (VAR RHS) (PROG NIL (GLUPDATEVARTYPE VAR (CADR RHS)) (RETURN (LIST (LIST 'SETQ VAR (CAR RHS)) (CADR RHS))))) % edited: 4-MAY-82 10:46 (DE GLDOWHILE (EXPR CONTEXT) (PROG (ACTIONS TMP LABEL) (SETQ CONTEXT (CONS NIL CONTEXT)) (pop EXPR) (SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T)))) (COND ((MEMQ (CAR EXPR) '(DO Do do)) (pop EXPR))) A (COND ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T))) (SETQ ACTIONS (ACONC ACTIONS (CAR TMP))) (GO A)) (EXPR (GLERROR 'GLDOWHILE (LIST "Bad stuff in While statement:" EXPR)) (pop EXPR) (GO A))) (SETQ LABEL (GLMKLABEL)) (RETURN (LIST (LIST 'PROG NIL LABEL (LIST 'COND (ACONC ACTIONS (LIST 'GO LABEL)))) NIL)))) % edited: 23-DEC-82 10:47 % Produce code to test the two sides for equality. (DE GLEQUALFN (LHS RHS) (PROG (TMP LHSTP RHSTP) (RETURN (COND ((SETQ TMP (GLDOMSG LHS '= (LIST RHS))) TMP) ((SETQ TMP (GLUSERSTROP LHS '= RHS)) TMP) (T (SETQ LHSTP (CADR LHS)) (SETQ RHSTP (CADR RHS)) (LIST (COND ((NULL (CAR RHS)) (LIST 'NULL (CAR LHS))) ((NULL (CAR LHS)) (LIST 'NULL (CAR RHS))) (T (GLGENCODE (LIST (COND ((OR (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER)) 'EQP) ((OR (GLATOMTYPEP LHSTP) (GLATOMTYPEP RHSTP)) 'EQ) ((AND (EQ LHSTP 'STRING) (EQ RHSTP 'STRING)) 'STREQUAL) (T 'EQUAL)) (CAR LHS) (CAR RHS))))) 'BOOLEAN)))))) % edited: 23-SEP-82 11:52 (DF GLERR (ERREXP) (PRIN1 "Execution of GLISP error expression: ")(PRINT ERREXP)(ERROR 0 NIL)) % GSN 26-JAN-83 13:42 % Look through a structure to see if it involves evaluating other % structures to produce a concrete type. (DE GLEVALSTR (STR CONTEXT) (PROG (GLEVALSUBS) (GLEVALSTRB STR) (RETURN (COND (GLEVALSUBS (GLSUBLIS GLEVALSUBS STR)) (T STR))))) % GSN 30-JAN-83 15:34 % Find places where substructures need to be evaluated and collect % substitutions for them. (DE GLEVALSTRB (STR) (PROG (TMP EXPR) (COND ((ATOM STR) (RETURN NIL)) ((NOT (PAIRP STR)) (ERROR 0 NIL)) ((EQ (CAR STR) 'TYPEOF) (SETQ EXPR (CDR STR)) (SETQ TMP (GLDOEXPR NIL CONTEXT T)) (COND ((CADR TMP) (SETQ GLEVALSUBS (CONS (CONS STR (CADR TMP)) GLEVALSUBS))) (T (GLERROR 'GLEVALSTRB (LIST "The evaluated type" STR "was not found.") ))) (RETURN NIL)) (T (MAPC (CDR STR) (FUNCTION GLEVALSTRB)))))) % GSN 27-JAN-83 13:56 % If a PROGN occurs within a PROGN, expand it by splicing its contents % into the top-level list. (DE GLEXPANDPROGN (LST BUSY PROGFLG) (PROG (X Y) (SETQ Y LST) LP (SETQ X (CDR Y)) (COND ((NULL X) (RETURN LST)) ((NOT (PAIRP (CAR X))) % Eliminate non-busy atomic items. (COND ((AND (NOT PROGFLG) (OR (CDR X) (NOT BUSY))) (RPLACD Y (CDR X)) (GO LP)))) ((MEMQ (CAAR X) '(PROGN PROG2)) % Expand contained PROGNs in-line. (COND ((CDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDAR X)))) (RPLACA X (CADAR X))) ((AND (EQ (CAAR X) 'PROG) (NULL (CADAR X)) (EVERY (CDDAR X) (FUNCTION (LAMBDA (Y) (NOT (ATOM Y))))) (NOT (GLOCCURS 'RETURN (CDDAR X)))) % Expand contained simple PROGs. (COND ((CDDDAR X) (RPLACD (LASTPAIR (CAR X)) (CDR X)) (RPLACD X (CDDDAR X)))) (RPLACA X (CADDAR X)))) (SETQ Y (CDR Y)) (GO LP))) % edited: 9-JUN-82 12:55 % Test if EXPR is expensive to compute. (DE GLEXPENSIVE? (EXPR) (COND ((ATOM EXPR) NIL) ((NOT (PAIRP EXPR)) (ERROR 0 NIL)) ((MEMQ (CAR EXPR) '(CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR CADDDR)) (GLEXPENSIVE? (CADR EXPR))) ((AND (EQ (CAR EXPR) 'PROG1) (NULL (CDDR EXPR))) (GLEXPENSIVE? (CADR EXPR))) (T T))) % edited: 2-Jan-81 14:26 % Find the first entry for variable VAR in the CONTEXT structure. (DE GLFINDVARINCTX (VAR CONTEXT) (AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT)) (GLFINDVARINCTX VAR (CDR CONTEXT))))) % edited: 19-OCT-82 15:19 % Generate code of the form X. The code generated by the compiler is % transformed, if necessary, for the output dialect. (DE GLGENCODE (X) (GLPSLTRANSFM X)) % edited: 20-Mar-81 15:52 % Get the value for the entry KEY from the a-list ALST. GETASSOC is % used so that the corresponding PUTASSOC can be generated by % GLPUTFN. (DE GLGETASSOC (KEY ALST) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC KEY ALST)) (CDR TMP))))) % edited: 30-AUG-82 10:25 (DE GLGETCONSTDEF (ATM) (COND ((GET ATM 'GLISPCONSTANTFLG) (LIST (MKQUOTE (GET ATM 'GLISPCONSTANTVAL)) (GET ATM 'GLISPCONSTANTTYPE))) (T NIL))) % edited: 30-OCT-81 12:20 % Get the GLISP object description for NAME for the file package. (DE GLGETDEF (NAME TYPE) (LIST 'GLDEFSTRQ (CONS NAME (GET NAME 'GLSTRUCTURE)))) % edited: 5-OCT-82 15:06 % Find a way to retrieve the FIELD from the structure pointed to by % SOURCE (which may be a variable name, NIL, or a list (CODE DESCR)) % relative to CONTEXT. The result is a list of code to get the field % and the structure description of the resulting field. (DE GLGETFIELD (SOURCE FIELD CONTEXT) (PROG (TMP CTXENTRY CTXLIST) (COND ((NULL SOURCE) (GO B)) ((ATOM SOURCE) (COND ((SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT)) (COND ((SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY) NIL)) (RETURN TMP)) (T (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for" SOURCE "whose type is" (CADDR CTXENTRY)))))) ((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT)) (SETQ SOURCE TMP)) ((SETQ TMP (GLGETGLOBALDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) ((SETQ TMP (GLGETCONSTDEF SOURCE)) (RETURN (GLGETFIELD TMP FIELD NIL))) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The name" SOURCE "cannot be found."))))))) (COND ((PAIRP SOURCE) (COND ((SETQ TMP (GLVALUE (CAR SOURCE) FIELD (CADR SOURCE) NIL)) (RETURN TMP)) (T (RETURN (GLERROR 'GLGETFIELD (LIST "The property" FIELD "cannot be found for type" (CADR SOURCE) "in" (CAR SOURCE)))))))) B % No source is specified. Look for a source in the context. (COND ((NULL CONTEXT) (RETURN NIL))) (SETQ CTXLIST (pop CONTEXT)) C (COND ((NULL CTXLIST) (GO B))) (SETQ CTXENTRY (pop CTXLIST)) (COND ((EQ FIELD (CADR CTXENTRY)) (RETURN (LIST (CAR CTXENTRY) (CADDR CTXENTRY)))) ((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY) FIELD (CADDR CTXENTRY) NIL))) (GO C))) (RETURN TMP))) % edited: 27-MAY-82 13:01 % Call the appropriate function to compile code to get the indicator % (QUOTE IND') from the item whose description is DES, where DES % describes a unit in a unit package whose record is UNITREC. (DE GLGETFROMUNIT (UNITREC IND DES) (PROG (TMP) (COND ((SETQ TMP (ASSOC 'GET (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST IND DES)))) (T (RETURN NIL))))) % edited: 23-APR-82 16:58 (DE GLGETGLOBALDEF (ATM) (COND ((GET ATM 'GLISPGLOBALVAR) (LIST ATM (GET ATM 'GLISPGLOBALVARTYPE))) (T NIL))) % edited: 4-JUN-82 15:36 % Get pairs of <field> = <value>, where the = and , are optional. (DE GLGETPAIRS (EXPR) (PROG (PROP VAL PAIRLIST) A (COND ((NULL EXPR) (RETURN PAIRLIST)) ((NOT (ATOM (SETQ PROP (pop EXPR)))) (GLERROR 'GLGETPAIRS (LIST PROP "is not a legal property name."))) ((EQ PROP '!,) (GO A))) (COND ((MEMQ (CAR EXPR) '(= _ :=)) (pop EXPR))) (SETQ VAL (GLDOEXPR NIL CONTEXT T)) (SETQ PAIRLIST (ACONC PAIRLIST (CONS PROP VAL))) (GO A))) % edited: 23-DEC-81 12:52 (DE GLGETSTR (DES) (PROG (TYPE TMP) (RETURN (AND (SETQ TYPE (GLXTRTYPE DES)) (ATOM TYPE) (SETQ TMP (GET TYPE 'GLSTRUCTURE)) (CAR TMP))))) % edited: 28-NOV-82 15:10 % Get the superclasses of CLASS. (DE GLGETSUPERS (CLASS) (LISTGET (CDR (GET CLASS 'GLSTRUCTURE)) 'SUPERS)) % GSN 9-FEB-83 15:28 % Get the type of an expression. (DE GLGETTYPEOF (TYPE) (PROG (TMP) (COND ((SETQ TMP (GLPUSHEXPR (CDR TYPE) NIL CONTEXT T)) (RETURN (CADR TMP)))))) % edited: 21-MAY-82 17:01 % Identify a given name as either a known variable name of as an % implicit field reference. (DE GLIDNAME (NAME DEFAULTFLG) (PROG (TMP) (RETURN (COND ((ATOM NAME) (COND ((NULL NAME) (LIST NIL NIL)) ((IDP NAME) (COND ((EQ NAME T) (LIST NAME 'BOOLEAN)) ((SETQ TMP (GLVARTYPE NAME CONTEXT)) (LIST NAME (COND ((EQ TMP '*NIL*) NIL) (T TMP)))) ((GLGETFIELD NIL NAME CONTEXT)) ((SETQ TMP (GLIDTYPE NAME CONTEXT)) (LIST (CAR TMP) (CADDR TMP))) ((GLGETCONSTDEF NAME)) ((GLGETGLOBALDEF NAME)) (T (COND ((OR (NOT DEFAULTFLG) GLCAUTIOUSFLG) (GLERROR 'GLIDNAME (LIST "The name" NAME "cannot be found in this context.")))) (LIST NAME NIL)))) ((FIXP NAME) (LIST NAME 'INTEGER)) ((FLOATP NAME) (LIST NAME 'REAL)) (T (GLERROR 'GLIDNAME (LIST NAME "is an illegal name."))))) (T NAME))))) % edited: 27-MAY-82 13:02 % Try to identify a name by either its referenced name or its type. (DE GLIDTYPE (NAME CONTEXT) (PROG (CTXLEVELS CTXLEVEL CTXENTRY) (SETQ CTXLEVELS CONTEXT) LPA (COND ((NULL CTXLEVELS) (RETURN NIL))) (SETQ CTXLEVEL (pop CTXLEVELS)) LPB (COND ((NULL CTXLEVEL) (GO LPA))) (SETQ CTXENTRY (CAR CTXLEVEL)) (SETQ CTXLEVEL (CDR CTXLEVEL)) (COND ((OR (EQ (CADR CTXENTRY) NAME) (EQ (CADDR CTXENTRY) NAME) (AND (PAIRP (CADDR CTXENTRY)) (GL-A-AN? (CAADDR CTXENTRY)) (EQ NAME (CADR (CADDR CTXENTRY))))) (RETURN CTXENTRY))) (GO LPB))) % GSN 10-FEB-83 13:36 % Initialize things for GLISP (DE GLINIT NIL (PROG NIL (SETQ GLSEPBITTBL (MAKEBITTABLE '(: _ + - !' = ~ < > * / !, ^))) (SETQ GLUNITPKGS NIL) (SETQ GLSEPMINUS NIL) (SETQ GLQUIETFLG NIL) (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0) (SETQ GLBREAKONERROR NIL) (SETQ GLUSERSTRNAMES NIL) (SETQ GLTYPESUSED NIL) (SETQ GLOBJECTNAMES NIL) (SETQ GLLASTFNCOMPILED NIL) (SETQ GLLASTSTREDITED NIL) (SETQ GLCAUTIOUSFLG NIL) (MAPC '(EQ NE EQUAL AND OR NOT MEMQ ADD1 SUB1 EQN ASSOC PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ CAR CDR CAAR CADR) (FUNCTION (LAMBDA (X) (PUT X 'GLEVALWHENCONST T)))) (MAPC '(ADD1 SUB1 EQN PLUS MINUS TIMES SQRT EXPT DIFFERENCE QUOTIENT GREATERP GEQ LESSP LEQ) (FUNCTION (LAMBDA (X) (PUT X 'GLARGSNUMBERP T)))) (GLDEFFNRESULTTYPES '((NUMBER (PLUS MINUS DIFFERENCE TIMES EXPT QUOTIENT REMAINDER MIN MAX ABS)) (INTEGER (LENGTH FIX ADD1 SUB1)) (REAL (SQRT LOG EXP SIN COS ATAN ARCSIN ARCCOS ARCTAN ARCTAN2 FLOAT)) (BOOLEAN (ATOM NULL EQUAL MINUSP ZEROP GREATERP LESSP NUMBERP FIXP FLOATP STRINGP ARRAYP EQ NOT NULL BOUNDP)))) (GLDEFFNRESULTTYPES '((INTEGER (FLATSIZE FLATSIZE2)) (BOOLEAN (EQN NE PAIRP IDP UNBOUNDP)))) (GLDEFFNRESULTTYPEFNS (APPEND '((CONS . GLLISTRESULTTYPEFN) (LIST . GLLISTRESULTTYPEFN) (NCONC . GLLISTRESULTTYPEFN)) '((PNTH . GLNTHRESULTTYPEFN)))) (GLDEFSYSSTRQ (STRING STRING PROP ((LENGTH NCHARS RESULT INTEGER)) MSG ((+ CONCAT RESULT STRING))) (INTEGER INTEGER SUPERS (NUMBER)) (REAL REAL SUPERS (NUMBER))))) % edited: 26-JUL-82 17:07 % Look up an instance function of an abstract function name which % takes arguments of the specified types. (DE GLINSTANCEFN (FNNAME ARGTYPES) (PROG (INSTANCES IARGS TMP) (OR (SETQ INSTANCES (GET FNNAME 'GLINSTANCEFNS)) (RETURN NIL)) % Get ultimate data types for arguments. LP (COND ((NULL INSTANCES) (RETURN NIL))) (SETQ IARGS (GET (CAAR INSTANCES) 'GLARGUMENTTYPES)) (SETQ TMP ARGTYPES) % Match the ultimate types of each argument. LPB (COND ((NULL IARGS) (RETURN (CAR INSTANCES))) ((EQUAL (GLXTRTYPEB (CAR IARGS)) (GLXTRTYPEB (CAR TMP))) (SETQ IARGS (CDR IARGS)) (SETQ TMP (CDR TMP)) (GO LPB))) (SETQ INSTANCES (CDR INSTANCES)) (GO LP))) % GSN 3-FEB-83 14:13 % Make a new name for an instance of a generic function. (DE GLINSTANCEFNNAME (FN) (PROG (INSTFN N) (SETQ N (ADD1 (OR (GET FN 'GLINSTANCEFNNO) 0))) (PUT FN 'GLINSTANCEFNNO N) (SETQ INSTFN (IMPLODE (NCONC (EXPLODE FN) (CONS '- (EXPLODE N))))) (PUT FN 'GLINSTANCEFNS (CONS INSTFN (GET FN 'GLINSTANCEFNS))) (RETURN INSTFN))) % edited: 30-AUG-82 10:28 % Define compile-time constants. (DF GLISPCONSTANTS (ARGS) (PROG (TMP EXPR EXPRSTACK FAULTFN) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPCONSTANTFLG T) (PUT (CAR ARG) 'GLISPORIGCONSTVAL (CADR ARG)) (PUT (CAR ARG) 'GLISPCONSTANTVAL (PROGN (SETQ EXPR (LIST (CADR ARG))) (SETQ TMP (GLDOEXPR NIL NIL T)) (SET (CAR ARG) (EVAL (CAR TMP))))) (PUT (CAR ARG) 'GLISPCONSTANTTYPE (OR (CADDR ARG) (CADR TMP)))))))) % edited: 26-MAY-82 15:30 % Define compile-time constants. (DF GLISPGLOBALS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (PUT (CAR ARG) 'GLISPGLOBALVAR T) (PUT (CAR ARG) 'GLISPGLOBALVARTYPE (CADR ARG)))))) % GSN 10-FEB-83 11:51 % edited: 7-Jan-81 10:48 % Define named structure descriptions. The descriptions are of the % form (<name> <description>) . Each description is put on the % property list of <name> as GLSTRUCTURE (DF GLISPOBJECTS (ARGS) (MAPC ARGS (FUNCTION (LAMBDA (ARG) (GLDEFSTR ARG NIL))))) % edited: 2-NOV-82 11:24 % Test the word ADJ to see if it is a LISP adjective. If so, return % the name of the function to test it. (DE GLLISPADJ (ADJ) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ADJ) '((ATOMIC . ATOM) (NULL . NULL) (NIL . NULL) (INTEGER . FIXP) (REAL . FLOATP) (BOUND . BOUNDP) (ZERO . ZEROP) (NUMERIC . NUMBERP) (NEGATIVE . MINUSP) (MINUS . MINUSP)))) (CDR TMP))))) % edited: 2-NOV-82 11:23 % Test to see if ISAWORD is a LISP ISA word. If so, return the name of % the function to test for it. (DE GLLISPISA (ISAWORD) (PROG (TMP) (RETURN (AND (SETQ TMP (ASSOC (GLUCASE ISAWORD) '((ATOM . ATOM) (LIST . LISTP) (NUMBER . NUMBERP) (INTEGER . FIXP) (SYMBOL . LITATOM) (ARRAY . ARRAYP) (STRING . STRINGP) (BIGNUM . BIGP) (LITATOM . LITATOM)))) (CDR TMP))))) % edited: 12-NOV-82 10:53 % Compute result types for Lisp functions. (DE GLLISTRESULTTYPEFN (FN ARGTYPES) (PROG (ARG1 ARG2) (SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES))) (COND ((CDR ARGTYPES) (SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES))))) (RETURN (CASEQ FN (CONS (OR (AND (PAIRP ARG2) (COND ((EQ (CAR ARG2) 'LIST) (CONS 'LIST (CONS ARG1 (CDR ARG2)))) ((AND (EQ (CAR ARG2) 'LISTOF) (EQUAL ARG1 (CADR ARG2))) ARG2))) (LIST FN ARGTYPES))) (NCONC (COND ((EQUAL ARG1 ARG2) ARG1) ((AND (PAIRP ARG1) (PAIRP ARG2) (EQ (CAR ARG1) 'LISTOF) (EQ (CAR ARG2) 'LIST) (NULL (CDDR ARG2)) (EQUAL (CADR ARG1) (CADR ARG2))) ARG1) (T (OR ARG1 ARG2)))) (LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE)))) (t (ERROR 0 NIL)))))) % GSN 11-JAN-83 14:05 % Create a function call to retrieve the field IND from a LIST % structure. (DE GLLISTSTRFN (IND DES DESLIST) (PROG (TMP N FNLST) (SETQ N 1) (SETQ FNLST '((CAR *GL*) (CADR *GL*) (CADDR *GL*) (CADDDR *GL*))) (COND ((EQ (CAR DES) 'LISTOBJECT) (SETQ N (ADD1 N)) (SETQ FNLST (CDR FNLST)))) C (pop DES) (COND ((NULL DES) (RETURN NIL)) ((NOT (PAIRP (CAR DES)))) ((SETQ TMP (GLSTRFN IND (CAR DES) DESLIST)) (RETURN (GLSTRVAL TMP (COND (FNLST (COPY (CAR FNLST))) (T (LIST 'CAR (GLGENCODE (LIST 'NTH '*GL* N))))))))) (SETQ N (ADD1 N)) (AND FNLST (SETQ FNLST (CDR FNLST))) (GO C))) % edited: 24-AUG-82 17:36 % Compile code for a FOR loop. (DE GLMAKEFORLOOP (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE) (COND ((NULL COLLECTCODE) (LIST (GLGENCODE (LIST 'MAPC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (COND (LOOPCOND (LIST 'COND (CONS (CAR LOOPCOND) LOOPCONTENTS))) ((NULL (CDR LOOPCONTENTS)) (CAR LOOPCONTENTS)) (T (CONS 'PROGN LOOPCONTENTS))))))) NIL)) (T (LIST (COND (LOOPCOND (GLGENCODE (LIST 'MAPCONC (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (LIST 'AND (CAR LOOPCOND) (LIST 'CONS (CAR COLLECTCODE) NIL))))))) ((AND (PAIRP (CAR COLLECTCODE)) (ATOM (CAAR COLLECTCODE)) (CDAR COLLECTCODE) (EQ (CADAR COLLECTCODE) LOOPVAR) (NULL (CDDAR COLLECTCODE))) (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (CAAR COLLECTCODE))))) (T (GLGENCODE (LIST 'MAPCAR (CAR DOMAIN) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR COLLECTCODE))))))) (LIST 'LISTOF (CADR COLLECTCODE)))))) % GSN 12-JAN-83 14:33 (DE GLMAKEGLISPVERSIONS NIL (MAPC '((MACLISP GLISP.MAC) (FRANZLISP GLISP.FRANZ) (PSL GLISP.PSL) (UCILISP GLISP.UCI)) (FUNCTION (LAMBDA (X) (GLMAKEGLISPVERSION (CAR X) (CADR X)))))) % edited: 10-NOV-82 17:14 % Compile code to create a structure in response to a statement % (A <structure> WITH <field> = <value> ...) (DE GLMAKESTR (TYPE EXPR) (PROG (PAIRLIST STRDES) (COND ((MEMQ (CAR EXPR) '(WITH With with)) (pop EXPR))) (COND ((NULL (SETQ STRDES (GLGETSTR TYPE))) (GLERROR 'GLMAKESTR (LIST "The type name" TYPE "is not defined.")))) (COND ((EQ (CAR STRDES) 'LISTOF) (RETURN (CONS 'LIST (MAPCAR EXPR (FUNCTION (LAMBDA (EXPR) (GLDOEXPR NIL CONTEXT T)))) )))) (SETQ PAIRLIST (GLGETPAIRS EXPR)) (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE)) TYPE)))) % GSN 3-FEB-83 12:12 % Make a virtual type for a view of the original type. (DE GLMAKEVTYPE (ORIGTYPE VLIST) (PROG (SUPER PL PNAME TMP VTYPE) (SETQ SUPER (CADR VLIST)) (SETQ VLIST (CDDR VLIST)) (COND ((MEMQ (CAR VLIST) '(with With WITH)) (SETQ VLIST (CDR VLIST)))) LP (COND ((NULL VLIST) (GO OUT))) (SETQ PNAME (CAR VLIST)) (SETQ VLIST (CDR VLIST)) (COND ((EQ (CAR VLIST) '=) (SETQ VLIST (CDR VLIST)))) (SETQ TMP NIL) LPB (COND ((OR (NULL VLIST) (EQ (CAR VLIST) '!,) (AND (ATOM (CAR VLIST)) (CDR VLIST) (EQ (CADR VLIST) '=))) (SETQ PL (CONS (LIST PNAME (REVERSIP TMP)) PL)) (COND ((AND VLIST (EQ (CAR VLIST) '!,)) (SETQ VLIST (CDR VLIST)))) (GO LP))) (SETQ TMP (CONS (CAR VLIST) TMP)) (SETQ VLIST (CDR VLIST)) (GO LPB) OUT (SETQ VTYPE (GLMKVTYPE)) (PUT VTYPE 'GLSTRUCTURE (LIST (LIST 'TRANSPARENT ORIGTYPE) 'PROP PL 'SUPERS (LIST SUPER))) (RETURN VTYPE))) % edited: 26-MAY-82 15:33 % Construct the NOT of the argument LHS. (DE GLMINUSFN (LHS) (OR (GLDOMSG LHS 'MINUS NIL) (GLUSERSTROP LHS 'MINUS NIL) (LIST (GLGENCODE (COND ((NUMBERP (CAR LHS)) (MINUS (CAR LHS))) ((EQ (GLXTRTYPE (CADR LHS)) 'INTEGER) (LIST 'IMINUS (CAR LHS))) (T (LIST 'MINUS (CAR LHS))))) (CADR LHS)))) % edited: 11-NOV-82 11:54 % Make a variable name for GLCOMP functions. (DE GLMKATOM (NAME) (PROG (N NEWATOM) LP (PUT NAME 'GLISPATOMNUMBER (SETQ N (ADD1 (OR (GET NAME 'GLISPATOMNUMBER) 0)))) (SETQ NEWATOM (IMPLODE (APPEND (EXPLODE NAME) (EXPLODE N)))) % If an atom with this name has something on its proplist, try again. (COND ((PROP NEWATOM) (GO LP)) (T (RETURN NEWATOM))))) % edited: 27-MAY-82 11:02 % Make a variable name for GLCOMP functions. (DE GLMKLABEL NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L L A B E L) (EXPLODE GLNATOM)))))) % edited: 27-MAY-82 11:04 % Make a variable name for GLCOMP functions. (DE GLMKVAR NIL (PROG NIL (SETQ GLNATOM (ADD1 GLNATOM)) (RETURN (IMPLODE (APPEND '(G L V A R) (EXPLODE GLNATOM)))))) % edited: 18-NOV-82 11:58 % Make a virtual type name for GLCOMP functions. (DE GLMKVTYPE NIL (GLMKATOM 'GLVIRTUALTYPE)) % GSN 25-JAN-83 16:47 % edited: 2-Jun-81 14:18 % Produce a function to implement the _+ operator. Code is produced to % append the right-hand side to the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLNCONCFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS))) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF) (NOT (EQUAL LHSDES (CADR RHS)))) (SETQ NCCODE (LIST 'NCONC1 LHSCODE (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'NCONC)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_+ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLNCONCFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_+ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ LHS RHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % edited: 23-DEC-82 10:49 % Produce code to test the two sides for inequality. (DE GLNEQUALFN (LHS RHS) (PROG (TMP) (COND ((SETQ TMP (GLDOMSG LHS '~= (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '~= RHS)) (RETURN TMP)) ((OR (GLATOMTYPEP (CADR LHS)) (GLATOMTYPEP (CADR RHS))) (RETURN (LIST (GLGENCODE (LIST 'NEQ (CAR LHS) (CAR RHS))) 'BOOLEAN))) (T (RETURN (LIST (GLGENCODE (LIST 'NOT (CAR (GLEQUALFN LHS RHS)))) 'BOOLEAN)))))) % edited: 3-MAY-82 14:35 % Construct the NOT of the argument LHS. (DE GLNOTFN (LHS) (OR (GLDOMSG LHS '~ NIL) (GLUSERSTROP LHS '~ NIL) (LIST (GLBUILDNOT (CAR LHS)) 'BOOLEAN))) % GSN 28-JAN-83 09:39 % Add TYPE to the global variable GLTYPESUSED if not already there. (DE GLNOTICETYPE (TYPE) (COND ((NOT (MEMQ TYPE GLTYPESUSED)) (SETQ GLTYPESUSED (CONS TYPE GLTYPESUSED))))) % edited: 23-JUN-82 14:31 % Compute the result type for the function NTH. (DE GLNTHRESULTTYPEFN (FN ARGTYPES) (PROG (TMP) (RETURN (COND ((AND (PAIRP (SETQ TMP (GLXTRTYPE (CAR ARGTYPES)))) (EQ (CAR TMP) 'LISTOF)) (CAR ARGTYPES)) (T NIL))))) % edited: 3-JUN-82 11:02 % See if X occurs in STR, using EQ. (DE GLOCCURS (X STR) (COND ((EQ X STR) T) ((NOT (PAIRP STR)) NIL) (T (OR (GLOCCURS X (CAR STR)) (GLOCCURS X (CDR STR)))))) % GSN 30-JAN-83 15:35 % Check a structure description for legality. (DE GLOKSTR? (STR) (COND ((NULL STR) NIL) ((ATOM STR) T) ((AND (PAIRP STR) (ATOM (CAR STR))) (CASEQ (CAR STR) ((A AN a an An) (COND ((CDDR STR) NIL) ((OR (GLGETSTR (CADR STR)) (GLUNIT? (CADR STR)) (COND (GLCAUTIOUSFLG (PRIN1 "The structure ") (PRIN1 (CADR STR)) (PRIN1 " is not currently defined. Accepted.") (TERPRI) T) (T T)))))) (CONS (AND (CDR STR) (CDDR STR) (NULL (CDDDR STR)) (GLOKSTR? (CADR STR)) (GLOKSTR? (CADDR STR)))) ((LIST OBJECT ATOMOBJECT LISTOBJECT) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION GLOKSTR?)))) (RECORD (COND ((AND (CDR STR) (ATOM (CADR STR))) (pop STR))) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (LISTOF (AND (CDR STR) (NULL (CDDR STR)) (GLOKSTR? (CADR STR)))) ((ALIST PROPLIST) (AND (CDR STR) (EVERY (CDR STR) (FUNCTION (LAMBDA (X) (AND (ATOM (CAR X)) (GLOKSTR? (CADR X)))))))) (ATOM (GLATMSTR? STR)) (TYPEOF T) (t (COND ((AND (CDR STR) (NULL (CDDR STR))) (GLOKSTR? (CADR STR))) ((ASSOC (CAR STR) GLUSERSTRNAMES)) (T NIL))))) (T NIL))) % edited: 30-DEC-81 16:41 % Get the next operand from the input list, EXPR (global) . The % operand may be an atom (possibly containing operators) or a list. (DE GLOPERAND NIL (PROG NIL (COND ((SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) ((NULL EXPR) (RETURN NIL)) ((STRINGP (CAR EXPR)) (RETURN (LIST (pop EXPR) 'STRING))) ((ATOM (CAR EXPR)) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (RETURN (GLPARSNFLD))) (T (RETURN (GLPUSHEXPR (pop EXPR) T CONTEXT T)))))) % edited: 30-OCT-82 14:35 % Test if an atom is a GLISP operator (DE GLOPERATOR? (ATM) (MEMQ ATM '(_ := __ + - * / > < >= <= ^ _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __- _+_))) % edited: 26-DEC-82 15:48 % OR operator (DE GLORFN (LHS RHS) (COND ((AND (PAIRP (CADR LHS)) (EQ (CAADR LHS) 'LISTOF) (EQUAL (CADR LHS) (CADR RHS))) (LIST (LIST 'UNION (CAR LHS) (CAR RHS)) (CADR LHS))) ((GLDOMSG LHS 'OR (LIST RHS))) ((GLUSERSTROP LHS 'OR RHS)) (T (LIST (LIST 'OR (CAR LHS) (CAR RHS)) (COND ((EQUAL (GLXTRTYPE (CADR LHS)) (GLXTRTYPE (CADR RHS))) (CADR LHS)) (T NIL)))))) % GSN 10-FEB-83 16:13 % Remove unwanted system properties from LST for making an output % file. (DE GLOUTPUTFILTER (PROPTYPE LST) (COND ((MEMQ PROPTYPE '(PROP ADJ ISA MSG)) (MAPCAN LST (FUNCTION (LAMBDA (L) (COND ((LISTGET (CDDR L) 'SPECIALIZATION) NIL) (T (LIST (CONS (CAR L) (CONS (CADR L) (MAPCON (CDDR L) (FUNCTION (LAMBDA (PAIR) (COND ((MEMQ (CAR PAIR) '(VTYPE)) NIL) (T (LIST (CAR PAIR) (CADR PAIR)))))) (FUNCTION CDDR))))))))))) (T LST))) % edited: 22-SEP-82 17:16 % Subroutine of GLDOEXPR to parse a GLISP expression containing field % specifications and/or operators. The global variable EXPR is used, % and is modified to reflect the amount of the expression which has % been parsed. (DE GLPARSEXPR NIL (PROG (OPNDS OPERS FIRST LHSP RHSP) % Get the initial part of the expression, i.e., variable or field % specification. L (SETQ OPNDS (CONS (GLOPERAND) OPNDS)) M (COND ((NULL FIRST) (COND ((OR (NULL EXPR) (NOT (ATOM (CAR EXPR)))) (GO B))) (GLSEPINIT (CAR EXPR)) (COND ((GLOPERATOR? (SETQ FIRST (GLSEPNXT))) (pop EXPR) (GO A)) ((MEMQ FIRST '(IS Is is HAS Has has)) (COND ((AND OPERS (GREATERP (GLPREC (CAR OPERS)) 5)) (GLREDUCE) (SETQ FIRST NIL) (GO M)) (T (SETQ OPNDS (CONS (GLPREDICATE (pop OPNDS) CONTEXT T (AND (NOT (UNBOUNDP 'ADDISATYPE)) ADDISATYPE)) OPNDS)) (SETQ FIRST NIL) (GO M)))) (T (GLSEPCLR) (GO B)))) ((GLOPERATOR? FIRST) (GO A)) (T (GLERROR 'GLPARSEXPR (LIST FIRST "appears illegally or cannot be interpreted.")))) % FIRST now contains an operator A % While top operator < top of stack in precedence, reduce. (COND ((NOT (OR (NULL OPERS) (LESSP (SETQ LHSP (GLPREC (CAR OPERS))) (SETQ RHSP (GLPREC FIRST))) (AND (EQN LHSP RHSP) (MEMQ FIRST '(_ ^ :=))))) (GLREDUCE) (GO A))) % Push new operator onto the operator stack. (SETQ OPERS (CONS FIRST OPERS)) (GO L) B (COND (OPERS (GLREDUCE) (GO B))) (RETURN (CAR OPNDS)))) % edited: 30-DEC-82 10:55 % Parse a field specification of the form var:field:field... Var may % be missing, and there may be zero or more fields. The variable % FIRST is used globally; it contains the first atom of the group on % entry, and the next atom on exit. (DE GLPARSFLD (PREV) (PROG (FIELD TMP) (COND ((NULL PREV) (COND ((EQ FIRST '!') (COND ((SETQ TMP (GLSEPNXT)) (SETQ FIRST (GLSEPNXT)) (RETURN (LIST (MKQUOTE TMP) 'ATOM))) (EXPR (SETQ FIRST NIL) (SETQ TMP (pop EXPR)) (RETURN (LIST (MKQUOTE TMP) (GLCONSTANTTYPE TMP)))) (T (RETURN NIL)))) ((MEMQ FIRST '(THE The the)) (SETQ TMP (GLTHE NIL)) (SETQ FIRST NIL) (RETURN TMP)) ((NE FIRST ':) (SETQ PREV FIRST) (SETQ FIRST (GLSEPNXT)))))) A (COND ((EQ FIRST ':) (COND ((SETQ FIELD (GLSEPNXT)) (SETQ PREV (GLGETFIELD PREV FIELD CONTEXT)) (SETQ FIRST (GLSEPNXT)) (GO A)))) (T (RETURN (COND ((EQ PREV '*NIL*) (LIST NIL NIL)) (T (GLIDNAME PREV T)))))))) % edited: 20-MAY-82 11:30 % Parse a field specification which may be preceded by a ~. (DE GLPARSNFLD NIL (PROG (TMP UOP) (COND ((OR (EQ FIRST '~) (EQ FIRST '-)) (SETQ UOP FIRST) (COND ((SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (ATOM (CAR EXPR))) (GLSEPINIT (pop EXPR)) (SETQ FIRST (GLSEPNXT)) (SETQ TMP (GLPARSFLD NIL))) ((AND EXPR (PAIRP (CAR EXPR))) (SETQ TMP (GLPUSHEXPR (pop EXPR) T CONTEXT T))) (T (RETURN (LIST UOP NIL)))) (RETURN (COND ((EQ UOP '~) (GLNOTFN TMP)) (T (GLMINUSFN TMP))))) (T (RETURN (GLPARSFLD NIL)))))) % edited: 27-MAY-82 10:42 % Form the plural of a given word. (DE GLPLURAL (WORD) (PROG (TMP LST UCASE ENDING) (COND ((SETQ TMP (GET WORD 'PLURAL)) (RETURN TMP))) (SETQ LST (REVERSIP (EXPLODE WORD))) (SETQ UCASE (U-CASEP (CAR LST))) (COND ((AND (MEMQ (CAR LST) '(Y y)) (NOT (MEMQ (CADR LST) '(A a E e O o U u)))) (SETQ LST (CDR LST)) (SETQ ENDING (OR (AND UCASE '(S E I)) '(s e i)))) ((MEMQ (CAR LST) '(S s X x)) (SETQ ENDING (OR (AND UCASE '(S E)) '(s e)))) (T (SETQ ENDING (OR (AND UCASE '(S)) '(s))))) (RETURN (IMPLODE (REVERSIP (APPEND ENDING LST)))))) % edited: 29-DEC-82 12:40 % Produce a function to implement the -_ (pop) operator. Code is % produced to remove one element from the right-hand side and assign % it to the left-hand side. (DE GLPOPFN (LHS RHS) (PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR) (SETQ RHSCODE (CAR RHS)) (SETQ RHSDES (GLXTRTYPE (CADR RHS))) (COND ((AND (PAIRP RHSDES) (EQ (CAR RHSDES) 'LISTOF)) (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL))) ((EQ RHSDES 'BOOLEAN) (SETQ POPCODE (GLPUTFN RHS '(NIL NIL) NIL)) (SETQ GETCODE (GLPUTFN LHS RHS NIL))) ((SETQ TMP (GLDOMSG RHS '-_ (LIST LHS))) (RETURN TMP)) ((AND (SETQ STR (GLGETSTR RHSDES)) (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS) STR)))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP RHS '-_ LHS)) (RETURN TMP)) ((OR (GLATOMTYPEP RHSDES) (AND (NE RHSDES 'ANYTHING) (MEMQ (GLXTRTYPEB RHSDES) GLBASICTYPES))) (RETURN NIL)) (T % If all else fails, assume a list. (SETQ POPCODE (GLPUTFN RHS (LIST (LIST 'CDR RHSCODE) RHSDES) T)) (SETQ GETCODE (GLPUTFN LHS (LIST (LIST 'CAR (CAR RHS)) (CADR RHSDES)) NIL)))) (RETURN (LIST (LIST 'PROG1 (CAR GETCODE) (CAR POPCODE)) (CADR GETCODE))))) % edited: 30-OCT-82 14:36 % Precedence numbers for operators (DE GLPREC (OP) (PROG (TMP) (COND ((SETQ TMP (ASSOC OP '((_ . 1) (:= . 1) (__ . 1) (_+ . 2) (__+ . 2) (+_ . 2) (_+_ . 2) (_- . 2) (__- . 2) (-_ . 2) (= . 5) (~= . 5) (<> . 5) (AND . 4) (And . 4) (and . 4) (OR . 3) (Or . 3) (or . 3) (/ . 7) (+ . 6) (- . 6) (> . 5) (< . 5) (>= . 5) (<= . 5) (^ . 8)))) (RETURN (CDR TMP))) ((EQ OP '*) (RETURN 7)) (T (RETURN 10))))) % GSN 9-FEB-83 17:18 % Get a predicate specification from the EXPR (referenced globally) % and return code to test the SOURCE for that predicate. VERBFLG is % true if a verb is expected as the top of EXPR. (DE GLPREDICATE (SOURCE CONTEXT VERBFLG ADDISATYPE) (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG) (COND ((NULL VERBFLG) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((NULL SOURCE) (GLERROR 'GLPREDICATE (LIST "The object to be tested was not found. EXPR =" EXPR))) ((MEMQ (CAR EXPR) '(HAS Has has)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NO No no)) (SETQ NOTFLG T) (pop EXPR))) (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T))) ((MEMQ (CAR EXPR) '(IS Is is ARE Are are)) (pop EXPR) (COND ((MEMQ (CAR EXPR) '(NOT Not not)) (SETQ NOTFLG T) (pop EXPR))) (COND ((GL-A-AN? (CAR EXPR)) (pop EXPR) (SETQ SETNAME (pop EXPR)) % The condition is to test whether SOURCE IS A SETNAME. (COND ((SETQ NEWPRED (GLADJ SOURCE SETNAME 'ISA))) ((SETQ NEWPRED (GLADJ (LIST (CAR SOURCE) SETNAME) SETNAME 'ISASELF)) (COND (ADDISATYPE (COND ((ATOM (CAR SOURCE)) (GLADDSTR (CAR SOURCE) NIL SETNAME CONTEXT)) ((AND (PAIRP (CAR SOURCE)) (MEMQ (CAAR SOURCE) '(SETQ PROG1)) (ATOM (CADAR SOURCE))) (GLADDSTR (CADAR SOURCE) (COND ((SETQ TMP (GLFINDVARINCTX (CAR SOURCE) CONTEXT)) (CADR TMP))) SETNAME CONTEXT)))))) ((GLCLASSP SETNAME) (SETQ NEWPRED (LIST (LIST 'GLCLASSMEMP (CAR SOURCE) (MKQUOTE SETNAME)) 'BOOLEAN))) ((SETQ TMP (GLLISPISA SETNAME)) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "IS A adjective" SETNAME "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS 'A SETNAME) 'BOOLEAN))))) (T (SETQ PROPERTY (CAR EXPR)) % The condition to test is whether SOURCE is PROPERTY. (COND ((SETQ NEWPRED (GLADJ SOURCE PROPERTY 'ADJ)) (pop EXPR)) ((SETQ TMP (GLLISPADJ PROPERTY)) (pop EXPR) (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE)) 'BOOLEAN))) (T (GLERROR 'GLPREDICATE (LIST "The adjective" PROPERTY "could not be found for" (CAR SOURCE) "whose type is" (CADR SOURCE))) (pop EXPR) (SETQ NEWPRED (LIST (LIST 'GLERR (CAR SOURCE) 'IS PROPERTY) 'BOOLEAN)))))))) (RETURN (COND (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED)) 'BOOLEAN)) (T NEWPRED))))) % edited: 25-MAY-82 16:09 % Compile an implicit PROGN, that is, a list of items. (DE GLPROGN (EXPR CONTEXT) (PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) A (COND ((NULL EXPR) (RETURN (LIST (REVERSIP RESULT) TYPE))) ((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY)) (SETQ RESULT (CONS (CAR TMP) RESULT)) (SETQ TYPE (CADR TMP)) (GO A)) (T (GLERROR 'GLPROGN (LIST "Illegal item appears in implicit PROGN. EXPR =" EXPR)))))) % GSN 11-JAN-83 09:59 % Create a function call to retrieve the field IND from a % property-list type structure. FLG is true if a PROPLIST is inside % an ATOM structure. (DE GLPROPSTRFN (IND DES DESLIST FLG) (PROG (DESIND TMP RECNAME N) % Handle a PROPLIST by looking inside each property for IND. (COND ((AND (EQ (SETQ DESIND (pop DES)) 'RECORD) (ATOM (CAR DES))) (SETQ RECNAME (pop DES)))) (SETQ N 0) P (COND ((NULL DES) (RETURN NIL)) ((AND (PAIRP (CAR DES)) (ATOM (CAAR DES)) (CDAR DES) (SETQ TMP (GLSTRFN IND (CAR DES) DESLIST))) (SETQ TMP (GLSTRVAL TMP (CASEQ DESIND (ALIST (LIST 'GLGETASSOC (MKQUOTE (CAAR DES)) '*GL*)) ((RECORD OBJECT) (COND ((EQ DESIND 'OBJECT) (SETQ N (ADD1 N)))) (LIST 'GetV '*GL* N)) ((PROPLIST ATOMOBJECT) (LIST (COND ((OR FLG (EQ DESIND 'ATOMOBJECT)) 'GETPROP) (T 'LISTGET)) '*GL* (MKQUOTE (CAAR DES)))) (t NIL)))) (RPLACA TMP (GLGENCODE (CAR TMP))) (RETURN TMP)) (T (pop DES) (SETQ N (ADD1 N)) (GO P))))) % edited: 4-JUN-82 13:37 % Test if the function X is a pure computation, i.e., can be % eliminated if the result is not used. (DE GLPURE (X) (MEMQ X '(CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR CADDDR))) % edited: 25-MAY-82 16:10 % This function serves to call GLDOEXPR with a new expression, % rebinding the global variable EXPR. (DE GLPUSHEXPR (EXPR START CONTEXT VALBUSY) (PROG (GLSEPATOM GLSEPPTR) (SETQ GLSEPPTR 0) (RETURN (GLDOEXPR START CONTEXT VALBUSY)))) % GSN 25-JAN-83 16:48 % edited: 2-Jun-81 14:19 % Produce a function to implement the +_ operator. Code is produced to % push the right-hand side onto the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLPUSHFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'ADD1 LHSCODE))) ((OR (FIXP (CAR RHS)) (EQ (CADR RHS) 'INTEGER)) (SETQ NCCODE (LIST 'IPLUS LHSCODE (CAR RHS)))) (T (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'PLUS LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'OR LHSCODE (CAR RHS)))) ((NULL LHSDES) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE)) (COND ((AND (ATOM LHSCODE) (CADR RHS)) (GLUPDATEVARTYPE LHSCODE (LIST 'LISTOF (CADR RHS)))))) ((AND (PAIRP LHSDES) (MEMQ (CAR LHSDES) '(LIST CONS LISTOF))) (SETQ NCCODE (LIST 'CONS (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'PUSH)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '+ (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLPUSHFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '+_ RHS)) (RETURN TMP)) ((SETQ TMP (GLREDUCEARITH '+ RHS LHS)) (SETQ NCCODE (CAR TMP))) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 22-JAN-83 14:44 % Process a store into a value which is computed by an arithmetic % expression. (DE GLPUTARITH (LHS RHS) (PROG (LHSC OP TMP NEWLHS NEWRHS) (SETQ LHSC (CAR LHS)) (SETQ OP (CAR LHSC)) (COND ((NOT (SETQ TMP (ASSOC OP '((PLUS DIFFERENCE) (MINUS MINUS) (DIFFERENCE PLUS) (TIMES QUOTIENT) (QUOTIENT TIMES) (IPLUS IDIFFERENCE) (IMINUS IMINUS) (IDIFFERENCE IPLUS) (ITIMES IQUOTIENT) (IQUOTIENT ITIMES) (ADD1 SUB1) (SUB1 ADD1) (EXPT SQRT) (SQRT EXPT))))) (RETURN NIL))) (SETQ NEWLHS (CADR LHSC)) (CASEQ OP ((ADD1 SUB1 MINUS IMINUS) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))) ((PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE ITIMES IQUOTIENT) (COND ((NUMBERP (CADDR LHSC)) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADDR LHSC)))) ((NUMBERP (CADR LHSC)) (SETQ NEWLHS (CADDR LHSC)) (CASEQ OP ((DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT) (SETQ NEWRHS (LIST OP (CADR LHSC) (CAR RHS)))) (t(PROGN (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) (CADR LHSC))))))))) (EXPT (COND ((EQUAL (CADDR LHSC) 2) (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS)))))) (SQRT (SETQ NEWRHS (LIST (CADR TMP) (CAR RHS) 2))) (t NIL)) (RETURN (AND NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS)) (LIST NEWRHS (CADR RHS)) NIL))))) % GSN 22-JAN-83 14:37 % edited: 2-Jun-81 14:16 % Create code to put the right-hand side datum RHS into the left-hand % side, whose access function and type are given by LHS. (DE GLPUTFN (LHS RHS OPTFLG) (PROG (LHSD LNAME TMP RESULT TMPVAR) (SETQ LHSD (CAR LHS)) (COND ((ATOM LHSD) (RETURN (OR (GLDOMSG LHS '_ (LIST RHS)) (GLUSERSTROP LHS '_ RHS) (AND (NULL (CADR LHS)) (CADR RHS) (GLUSERSTROP (LIST (CAR LHS) (CADR RHS)) '_ RHS)) (GLDOVARSETQ LHSD RHS))))) (SETQ LNAME (CAR LHSD)) (COND ((EQ LNAME 'CAR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (CADR LHSD) (CAR RHS))))))) ((EQ LNAME 'CDR) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (CADR LHSD))) (LIST 'RETURN (LIST 'CDR (LIST 'RPLACD TMPVAR (SUBST TMPVAR (CADR LHSD) (CAR RHS))))))) (T (LIST 'CDR (LIST 'RPLACD (CADR LHSD) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((CADR . CDR) (CADDR . CDDR) (CADDDR . CDDDR)))) (SETQ RESULT (COND ((AND OPTFLG (GLEXPENSIVE? (CADR LHSD))) (LIST 'PROG (LIST (LIST (SETQ TMPVAR (GLMKVAR)) (LIST (CDR TMP) (CADR LHSD)))) (LIST 'RETURN (LIST 'CAR (LIST 'RPLACA TMPVAR (SUBST (LIST 'CAR TMPVAR) LHSD (CAR RHS))))))) (T (LIST 'CAR (LIST 'RPLACA (LIST (CDR TMP) (CADR LHSD)) (CAR RHS))))))) ((SETQ TMP (ASSOC LNAME '((GetV . PutV) (IGetV . IPutV) (GET . PUTPROP) (GETPROP . PUTPROP) (LISTGET . LISTPUT)))) (SETQ RESULT (LIST (CDR TMP) (CADR LHSD) (CADDR LHSD) (CAR RHS)))) ((EQ LNAME 'CXR) (SETQ RESULT (LIST 'CXR (CADR LHSD) (LIST 'RPLACX (CADR LHSD) (CADDR LHSD) (CAR RHS))))) ((EQ LNAME 'GLGETASSOC) (SETQ RESULT (LIST 'PUTASSOC (CADR LHSD) (CAR RHS) (CADDR LHSD)))) ((EQ LNAME 'EVAL) (SETQ RESULT (LIST 'SET (CADR LHSD) (CAR RHS)))) ((EQ LNAME 'fetch) (SETQ RESULT (LIST 'replace (CADR LHSD) 'of (CADDDR LHSD) 'with (CAR RHS)))) ((SETQ TMP (GLUNITOP LHS RHS 'PUT)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_ (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS '_ RHS)) (RETURN TMP)) ((SETQ TMP (GLPUTARITH LHS RHS)) (RETURN TMP)) (T (RETURN (GLERROR 'GLPUTFN (LIST "Illegal assignment. LHS =" LHS "RHS =" RHS))))) X (RETURN (LIST (GLGENCODE RESULT) (OR (CADR LHS) (CADR RHS)))))) % edited: 27-MAY-82 13:07 % This function appends PUTPROP calls to the list PROGG (global) so % that ATOMNAME has its property list built. (DE GLPUTPROPS (PROPLIS PREVLST) (PROG (TMP TMPCODE) A (COND ((NULL PROPLIS) (RETURN NIL))) (SETQ TMP (pop PROPLIS)) (COND ((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST)) (ACONC PROGG (GLGENCODE (LIST 'PUTPROP 'ATOMNAME (MKQUOTE (CAR TMP)) TMPCODE))))) (GO A))) % edited: 26-JAN-82 10:29 % This function implements the __ operator, which is interpreted as % assignment to the source of a variable (usually self) outside an % open-compiled function. Any other use of __ is illegal. (DE GLPUTUPFN (OP LHS RHS) (PROG (TMP TMPOP) (OR (SETQ TMPOP (ASSOC OP '((__ . _) (__+ . _+) (__- . _-) (_+_ . +_)))) (ERROR 0 (LIST (LIST 'GLPUTUPFN OP) " Illegal operator."))) (COND ((AND (ATOM (CAR LHS)) (NOT (UNBOUNDP 'GLPROGLST)) (SETQ TMP (ASSOC (CAR LHS) GLPROGLST))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADR TMP) (CADR LHS)) RHS))) ((AND (PAIRP (CAR LHS)) (EQ (CAAR LHS) 'PROG1) (ATOM (CADAR LHS))) (RETURN (GLREDUCEOP (CDR TMPOP) (LIST (CADAR LHS) (CADR LHS)) RHS))) (T (RETURN (GLERROR 'GLPUTUPFN (LIST "A self-assignment __ operator is used improperly. LHS =" LHS))))))) % edited: 30-OCT-82 14:38 % Reduce the operator on OPERS and the operands on OPNDS % (in GLPARSEXPR) and put the result back on OPNDS (DE GLREDUCE NIL (PROG (RHS OPER) (SETQ RHS (pop OPNDS)) (SETQ OPNDS (CONS (COND ((MEMQ (SETQ OPER (pop OPERS)) '(_ := _+ +_ _- -_ = ~= <> AND And and OR Or or __+ __ _+_ __-)) (GLREDUCEOP OPER (pop OPNDS) RHS)) ((MEMQ OPER '(+ - * / > < >= <= ^)) (GLREDUCEARITH OPER (pop OPNDS) RHS)) ((EQ OPER 'MINUS) (GLMINUSFN RHS)) ((EQ OPER '~) (GLNOTFN RHS)) (T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS)) (CAR RHS))) NIL))) OPNDS)))) % GSN 25-JAN-83 15:09 % edited: 14-Aug-81 12:38 % Reduce an arithmetic operator in an expression. (DE GLREDUCEARITH (OP LHS RHS) (PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP) (SETQ OPLIST '((+ . PLUS) (- . DIFFERENCE) (* . TIMES) (/ . QUOTIENT) (> . GREATERP) (< . LESSP) (>= . GEQ) (<= . LEQ) (^ . EXPT))) (SETQ IOPLIST '((+ . IPLUS) (- . IDIFFERENCE) (* . ITIMES) (/ . IQUOTIENT) (> . IGREATERP) (< . ILESSP) (>= . IGEQ) (<= . ILEQ))) (SETQ PREDLIST '(GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)) (SETQ NUMBERTYPES '(INTEGER REAL NUMBER)) (SETQ LHSTP (GLXTRTYPE (CADR LHS))) (SETQ RHSTP (GLXTRTYPE (CADR RHS))) (COND ((OR (AND (EQ LHSTP 'INTEGER) (EQ RHSTP 'INTEGER) (SETQ TMP (ASSOC OP IOPLIST))) (AND (MEMQ LHSTP NUMBERTYPES) (MEMQ RHSTP NUMBERTYPES) (SETQ TMP (ASSOC OP OPLIST)))) (RETURN (LIST (COND ((AND (NUMBERP (CAR LHS)) (NUMBERP (CAR RHS))) (EVAL (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))))) (T (GLGENCODE (COND ((AND (EQ (CDR TMP) 'IPLUS) (EQN (CAR RHS) 1)) (LIST 'ADD1 (CAR LHS))) ((AND (EQ (CDR TMP) 'IDIFFERENCE) (EQN (CAR RHS) 1)) (LIST 'SUB1 (CAR LHS))) (T (LIST (CDR TMP) (CAR LHS) (CAR RHS))))))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T LHSTP)))))) (COND ((EQ LHSTP 'STRING) (COND ((NE RHSTP 'STRING) (RETURN (GLERROR 'GLREDUCEARITH (LIST "operation on string and non-string")))) ((SETQ TMP (ASSOC OP '((+ CONCAT STRING) (> GLSTRGREATERP BOOLEAN) (>= GLSTRGEP BOOLEAN) (< GLSTRLESSP BOOLEAN) (<= ALPHORDER BOOLEAN)))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADDR TMP)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST OP "is an illegal operation for strings."))))) ) ((AND (PAIRP LHSTP) (EQ (CAR LHSTP) 'LISTOF)) (COND ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF)) (COND ((NOT (EQUAL (CADR LHSTP) (CADR RHSTP))) (RETURN (GLERROR 'GLREDUCEARITH (LIST "Operations on lists of different types" (CADR LHSTP) (CADR RHSTP)))))) (COND ((SETQ TMP (ASSOC OP '((+ UNION) (- LDIFFERENCE) (* INTERSECTION) ))) (RETURN (LIST (GLGENCODE (LIST (CADR TMP) (CAR LHS) (CAR RHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation" OP "on lists.")))))) ((AND (EQUAL (CADR LHSTP) RHSTP) (MEMQ OP '(+ - >=))) (RETURN (LIST (GLGENCODE (LIST (COND ((EQ OP '+) 'CONS) ((EQ OP '-) 'REMOVE) ((EQ OP '>=) (COND ((GLATOMTYPEP RHSTP) 'MEMB) (T 'MEMBER)))) (CAR RHS) (CAR LHS))) (CADR LHS)))) (T (RETURN (GLERROR 'GLREDUCEARITH (LIST "Illegal operation on list.")))))) ((AND (PAIRP RHSTP) (EQ (CAR RHSTP) 'LISTOF) (EQUAL (CADR RHSTP) LHSTP) (MEMQ OP '(+ <=))) (RETURN (COND ((EQ OP '+) (LIST (GLGENCODE (LIST 'CONS (CAR LHS) (CAR RHS))) (CADR RHS))) ((EQ OP '<=) (LIST (GLGENCODE (LIST (COND ((GLATOMTYPEP LHSTP) 'MEMB) (T 'MEMBER)) (CAR LHS) (CAR RHS))) 'BOOLEAN))))) ((SETQ TMP (GLDOMSG LHS OP (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLUSERSTROP LHS OP RHS)) (RETURN TMP)) ((SETQ TMP (GLXTRTYPEC LHSTP)) (SETQ TMP (GLREDUCEARITH OP (LIST (CAR LHS) TMP) (LIST (CAR RHS) (OR (GLXTRTYPEC RHSTP) RHSTP)))) (RETURN (LIST (CAR TMP) LHSTP))) ((SETQ TMP (ASSOC OP OPLIST)) (AND LHSTP RHSTP (GLERROR 'GLREDUCEARITH (LIST "Warning: Arithmetic operation on non-numeric arguments of types:" LHSTP RHSTP))) (RETURN (LIST (GLGENCODE (LIST (CDR TMP) (CAR LHS) (CAR RHS))) (COND ((MEMQ (CDR TMP) PREDLIST) 'BOOLEAN) (T 'NUMBER))))) (T (ERROR 0 (LIST 'GLREDUCEARITH OP LHS RHS)))))) % edited: 29-DEC-82 12:20 % Reduce the operator OP with operands LHS and RHS. (DE GLREDUCEOP (OP LHS RHS) (PROG (TMP RESULT) (COND ((MEMQ OP '(_ :=)) (RETURN (GLPUTFN LHS RHS NIL))) ((SETQ TMP (ASSOC OP '((_+ . GLNCONCFN) (+_ . GLPUSHFN) (_- . GLREMOVEFN) (-_ . GLPOPFN) (= . GLEQUALFN) (~= . GLNEQUALFN) (<> . GLNEQUALFN) (AND . GLANDFN) (And . GLANDFN) (and . GLANDFN) (OR . GLORFN) (Or . GLORFN) (or . GLORFN)))) (COND ((SETQ RESULT (APPLY (CDR TMP) (LIST LHS RHS))) (RETURN RESULT)) (T (GLERROR 'GLREDUCEOP (LIST "The operator" OP "could not be interpreted for arguments" LHS "and" RHS))))) ((MEMQ OP '(__ __+ __- _+_)) (RETURN (GLPUTUPFN OP LHS RHS))) (T (ERROR 0 (LIST 'GLREDUCEOP OP LHS RHS)))))) % GSN 25-JAN-83 16:50 % edited: 2-Jun-81 14:20 % Produce a function to implement the _- operator. Code is produced to % remove the right-hand side from the left-hand side. Note: parts of % the structure provided are used multiple times. (DE GLREMOVEFN (LHS RHS) (PROG (LHSCODE LHSDES NCCODE TMP STR) (SETQ LHSCODE (CAR LHS)) (SETQ LHSDES (GLXTRTYPE (CADR LHS))) (COND ((EQ LHSDES 'INTEGER) (COND ((EQN (CAR RHS) 1) (SETQ NCCODE (LIST 'SUB1 LHSCODE))) (T (SETQ NCCODE (LIST 'IDIFFERENCE LHSCODE (CAR RHS)))))) ((OR (EQ LHSDES 'NUMBER) (EQ LHSDES 'REAL)) (SETQ NCCODE (LIST 'DIFFERENCE LHSCODE (CAR RHS)))) ((EQ LHSDES 'BOOLEAN) (SETQ NCCODE (LIST 'AND LHSCODE (LIST 'NOT (CAR RHS))))) ((OR (NULL LHSDES) (AND (PAIRP LHSDES) (EQ (CAR LHSDES) 'LISTOF))) (SETQ NCCODE (LIST 'REMOVE (CAR RHS) LHSCODE))) ((SETQ TMP (GLUNITOP LHS RHS 'REMOVE)) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '_- (LIST RHS))) (RETURN TMP)) ((SETQ TMP (GLDOMSG LHS '- (LIST RHS))) (SETQ NCCODE (CAR TMP))) ((AND (SETQ STR (GLGETSTR LHSDES)) (SETQ TMP (GLREMOVEFN (LIST (CAR LHS) STR) RHS))) (RETURN (LIST (CAR TMP) (CADR LHS)))) ((SETQ TMP (GLUSERSTROP LHS '_- RHS)) (RETURN TMP)) (T (RETURN NIL))) (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE) LHSDES) T)))) % GSN 26-JAN-83 13:41 % Get GLOBAL and RESULT declarations for the GLISP compiler. The % property GLRESULTTYPE is the RESULT declaration, if specified; % GLGLOBALS is a list of global variables referenced and their % types. (DE GLRESGLOBAL NIL (COND ((PAIRP (CAR GLEXPR)) (COND ((MEMQ (CAAR GLEXPR) '(RESULT Result result)) (COND ((AND (GLOKSTR? (CADAR GLEXPR)) (NULL (CDDAR GLEXPR))) (PUT GLAMBDAFN 'GLRESULTTYPE (SETQ RESULTTYPE (GLSUBSTTYPE (GLEVALSTR (CADAR GLEXPR) GLTOPCTX) GLTYPESUBS))) (pop GLEXPR)) (T (GLERROR 'GLCOMP (LIST "Bad RESULT structure declaration:" (CAR GLEXPR))) (pop GLEXPR)))) ((MEMQ (CAAR GLEXPR) '(GLOBAL Global global)) (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR) '(NIL NIL) GLTOPCTX NIL NIL)) (PUT GLAMBDAFN 'GLGLOBALS GLGLOBALVARS) (pop GLEXPR)))))) % edited: 26-MAY-82 16:14 % Get the result type for a function which has a GLAMBDA definition. % ATM is the function name. (DE GLRESULTTYPE (ATM ARGTYPES) (PROG (TYPE FNDEF STR TMP) % See if this function has a known result type. (COND ((SETQ TYPE (GET ATM 'GLRESULTTYPE)) (RETURN TYPE))) % If there exists a function to compute the result type, let it do so. (COND ((SETQ TMP (GET ATM 'GLRESULTTYPEFN)) (RETURN (APPLY TMP (LIST ATM ARGTYPES)))) ((SETQ TMP (GLANYCARCDR? ATM)) (RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES))))) (SETQ FNDEF (GLGETDB ATM)) (COND ((OR (NOT (PAIRP FNDEF)) (NOT (MEMQ (CAR FNDEF) '(LAMBDA GLAMBDA)))) (RETURN NIL))) (SETQ FNDEF (CDDR FNDEF)) A (COND ((OR (NULL FNDEF) (NOT (PAIRP (CAR FNDEF)))) (RETURN NIL)) ((OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR FNDEF) '*)) (MEMQ (CAAR FNDEF) '(GLOBAL Global global))) (pop FNDEF) (GO A)) ((AND (MEMQ (CAAR FNDEF) '(RESULT Result result)) (GLOKSTR? (SETQ STR (CADAR FNDEF)))) (RETURN STR)) (T (RETURN NIL))))) % GSN 28-JAN-83 09:55 (DE GLSAVEFNTYPES (GLAMBDAFN TYPELST) (PROG (Y) (MAPC TYPELST (FUNCTION (LAMBDA (X) (COND ((NOT (MEMQ GLAMBDAFN (SETQ Y (GET X 'GLFNSUSEDIN)))) (PUT X 'GLFNSUSEDIN (CONS GLAMBDAFN Y))))))))) % GSN 9-FEB-83 17:29 % Send a runtime message to OBJ. (DE GLSENDB (OBJ CLASS SELECTOR PROPTYPE ARGS) (PROG (RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL) (OR CLASS (SETQ CLASS (GLCLASS OBJ)) (ERROR 0 (LIST "Object" OBJ "has no Class."))) (SETQ ARGLIST (CONS OBJ ARGS)) (COND ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST PROPTYPE)) 'GLSENDFAILURE) (RETURN RESULT)) ((AND (EQ SELECTOR 'CLASS) (MEMQ PROPTYPE '(PROP MSG))) (RETURN CLASS)) ((NE PROPTYPE 'MSG) (GO ERR)) ((AND ARGS (NULL (CDR ARGS)) (EQ (GLNTHCHAR SELECTOR -1) ':) (SETQ SEL (SUBATOM SELECTOR 1 -2)) (SETQ FNCODE (OR (GLCOMPPROP CLASS SEL 'STR) (GLCOMPPROP CLASS SEL 'PROP))) (SETQ PUTCODE (GLPUTFN (LIST (SUBST '*GL* (CAADR FNCODE) (CADDR FNCODE)) NIL) (LIST '*GLVAL* NIL) NIL))) (SETQ *GLVAL* (CAR ARGS)) (SETQ *GL* OBJ) (RETURN (EVAL (CAR PUTCODE)))) (ARGS (GO ERR)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'STR)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'PROP)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ADJ)) 'GLSENDFAILURE) (RETURN RESULT)) ((NE (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 'ISA)) 'GLSENDFAILURE) (RETURN RESULT))) ERR (ERROR 0 (LIST "Message" SELECTOR "to object" OBJ "of class" CLASS "not understood.")))) % edited: 30-DEC-81 16:34 (DE GLSEPCLR NIL (SETQ GLSEPPTR 0)) % GSN 9-FEB-83 17:24 % edited: 30-Dec-80 10:05 % Initialize the scanning function which breaks apart atoms containing % embedded operators. (DE GLSEPINIT (ATM) (COND ((AND (ATOM ATM) (NOT (STRINGP ATM))) (SETQ GLSEPATOM ATM) (SETQ GLSEPPTR 1)) (T (SETQ GLSEPATOM NIL) (SETQ GLSEPPTR 0)))) % edited: 30-OCT-82 14:40 % Get the next sub-atom from the atom which was previously given to % GLSEPINIT. Sub-atoms are defined by splitting the given atom at % the occurrence of operators. Operators which are defined are : _ % _+ __ +_ _- -_ ' = ~= <> > < (DE GLSEPNXT NIL (PROG (END TMP) (COND ((ZEROP GLSEPPTR) (RETURN NIL)) ((NULL GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN '*NIL*)) ((NUMBERP GLSEPATOM) (SETQ TMP GLSEPATOM) (SETQ GLSEPPTR 0) (RETURN TMP))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR)) A (COND ((NULL END) (RETURN (PROG1 (COND ((EQN GLSEPPTR 1) GLSEPATOM) ((GREATERP GLSEPPTR (FlatSize2 GLSEPATOM)) NIL) (T (GLSUBATOM GLSEPATOM GLSEPPTR (FlatSize2 GLSEPATOM)))) (SETQ GLSEPPTR 0)))) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (PLUS GLSEPPTR 2))) '(__+ __- _+_)) (SETQ GLSEPPTR (PLUS GLSEPPTR 3)) (RETURN TMP)) ((MEMQ (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR (ADD1 GLSEPPTR))) '(:= __ _+ +_ _- -_ ~= <> >= <=)) (SETQ GLSEPPTR (PLUS GLSEPPTR 2)) (RETURN TMP)) ((AND (NOT GLSEPMINUS) (EQ (GLNTHCHAR GLSEPATOM END) '-) (NOT (EQ (GLNTHCHAR GLSEPATOM (ADD1 END)) '_))) (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END))) (GO A)) ((GREATERP END GLSEPPTR) (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR (SUB1 END)) (SETQ GLSEPPTR END)))) (T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR) (SETQ GLSEPPTR (ADD1 GLSEPPTR)))))))) % edited: 26-MAY-82 16:17 % Skip comments in GLEXPR. (DE GLSKIPCOMMENTS NIL (PROG NIL A (COND ((AND (PAIRP GLEXPR) (PAIRP (CAR GLEXPR)) (OR (AND (EQ GLLISPDIALECT 'INTERLISP) (EQ (CAAR GLEXPR) '*)) (EQ (CAAR GLEXPR) 'COMMENT))) (pop GLEXPR) (GO A))))) % GSN 3-FEB-83 14:25 % This function is called when the structure STR has been changed. It % uncompiles code which depends on STR. (DE GLSTRCHANGED (STR) (PROG (FNS) (OR (GET STR 'GLSTRUCTURE) (RETURN NIL)) (SETQ FNS (GET STR 'GLFNSUSEDIN)) (PUT STR 'GLFNSUSEDIN NIL) (MAPC FNS (FUNCTION GLUNCOMPILE)))) % GSN 28-JAN-83 10:19 % Create a function call to retrieve the field IND from a structure % described by the structure description DES. The value is NIL if % failure, (NIL DESCR) if DES equals IND, or (FNSTR DESCR) if IND % can be gotten from within DES. In the latter case, FNSTR is a % function to get the IND from the atom *GL*. GLSTRFN only does % retrieval from a structure, and does not get properties of an % object unless they are part of a TRANSPARENT substructure. DESLIST % is a list of structure descriptions which have been tried already; % this prevents a compiler loop in case the user specifies circular % TRANSPARENT structures. (DE GLSTRFN (IND DES DESLIST) (PROG (DESIND TMP STR UNITREC) % If this structure has already been tried, quit to avoid a loop. (COND ((MEMQ DES DESLIST) (RETURN NIL))) (SETQ DESLIST (CONS DES DESLIST)) (COND ((OR (NULL DES) (NULL IND)) (RETURN NIL)) ((OR (ATOM DES) (AND (PAIRP DES) (ATOM (CADR DES)) (GL-A-AN? (CAR DES)) (SETQ DES (CADR DES)))) (RETURN (COND ((SETQ STR (GLGETSTR DES)) (GLNOTICETYPE DES) (GLSTRFN IND STR DESLIST)) ((SETQ UNITREC (GLUNIT? DES)) (GLGETFROMUNIT UNITREC IND DES)) ((EQ IND DES) (LIST NIL (CADR DES))) (T NIL)))) ((NOT (PAIRP DES)) (GLERROR 'GLSTRFN (LIST "Bad structure specification" DES)))) (SETQ DESIND (CAR DES)) (COND ((OR (EQ IND DES) (EQ DESIND IND)) (RETURN (LIST NIL (CADR DES))))) (RETURN (CASEQ DESIND (CONS (OR (GLSTRVALB IND (CADR DES) '(CAR *GL*)) (GLSTRVALB IND (CADDR DES) '(CDR *GL*)))) ((LIST LISTOBJECT) (GLLISTSTRFN IND DES DESLIST)) ((PROPLIST ALIST RECORD ATOMOBJECT OBJECT) (GLPROPSTRFN IND DES DESLIST NIL)) (ATOM (GLATOMSTRFN IND DES DESLIST)) (TRANSPARENT (GLSTRFN IND (CADR DES) DESLIST)) (t (COND ((AND (SETQ TMP (ASSOC DESIND GLUSERSTRNAMES)) (CADR TMP)) (APPLY (CADR TMP) (LIST IND DES DESLIST))) ((OR (NULL (CDR DES)) (ATOM (CADR DES)) (AND (PAIRP (CADR DES)) (GL-A-AN? (CAADR DES)))) NIL) (T (GLSTRFN IND (CADR DES) DESLIST)))))))) % GSN 10-FEB-83 13:03 % If STR is a structured object, i.e., either a declared GLISP % structure or a Class of Units, get the property PROP from the % GLISP class of properties GLPROP. (DE GLSTRPROP (STR GLPROP PROP ARGS) (PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS) (OR (SETQ STRB (GLXTRTYPE STR)) (RETURN NIL)) (COND ((SETQ GLPROPS (GET STRB 'GLSTRUCTURE)) (GLNOTICETYPE STRB) (COND ((AND (SETQ PROPL (LISTGET (CDR GLPROPS) GLPROP)) (SETQ TMP (GLSTRPROPB PROP PROPL ARGS))) (RETURN TMP))))) (SETQ SUPERS (AND GLPROPS (LISTGET (CDR GLPROPS) 'SUPERS))) LP (COND (SUPERS (COND ((SETQ TMP (GLSTRPROP (CAR SUPERS) GLPROP PROP ARGS)) (RETURN TMP)) (T (SETQ SUPERS (CDR SUPERS)) (GO LP)))) ((AND (SETQ UNITREC (GLUNIT? STRB)) (SETQ TMP (APPLY (CADDDR UNITREC) (LIST STRB GLPROP PROP)))) (RETURN TMP))))) % GSN 10-FEB-83 13:14 % See if the property PROP can be found within the list of properties % PROPL. If ARGS is specified and ARGTYPES are specified for a % property entry, ARGS are required to match ARGTYPES. (DE GLSTRPROPB (PROP PROPL ARGS) (PROG (PROPENT ARGTYPES LARGS) LP (COND ((NULL PROPL) (RETURN NIL))) (SETQ PROPENT (CAR PROPL)) (SETQ PROPL (CDR PROPL)) (COND ((NE (CAR PROPENT) PROP) (GO LP))) (OR (AND ARGS (SETQ ARGTYPES (LISTGET (CDDR PROPENT) 'ARGTYPES))) (RETURN PROPENT)) (SETQ LARGS ARGS) LPB (COND ((AND (NULL LARGS) (NULL ARGTYPES)) (RETURN PROPENT)) ((OR (NULL LARGS) (NULL ARGTYPES)) (GO LP)) ((GLTYPEMATCH (CADAR LARGS) (CAR ARGTYPES)) (SETQ LARGS (CDR LARGS)) (SETQ ARGTYPES (CDR ARGTYPES)) (GO LPB)) (T (GO LP))))) % edited: 11-JAN-82 14:58 % GLSTRVAL is a subroutine of GLSTRFN. Given an old partial retrieval % function, in which the item from which the retrieval is made is % specified by *GL*, and a new function to compute *GL*, a composite % function is made. (DE GLSTRVAL (OLDFN NEW) (PROG NIL (COND ((CAR OLDFN) (RPLACA OLDFN (SUBST NEW '*GL* (CAR OLDFN)))) (T (RPLACA OLDFN NEW))) (RETURN OLDFN))) % edited: 13-Aug-81 16:13 % If the indicator IND can be found within the description DES, make a % composite retrieval function using a copy of the function pattern % NEW. (DE GLSTRVALB (IND DES NEW) (PROG (TMP) (COND ((SETQ TMP (GLSTRFN IND DES DESLIST)) (RETURN (GLSTRVAL TMP (COPY NEW)))) (T (RETURN NIL))))) % edited: 30-DEC-81 16:35 (DE GLSUBATOM (X Y Z) (OR (SUBATOM X Y Z) '*NIL*)) % GSN 22-JAN-83 16:27 % Same as SUBLIS, but allows first elements in PAIRS to be non-atomic. (DE GLSUBLIS (PAIRS EXPR) (PROG (TMP) (RETURN (COND ((SETQ TMP (ASSOC EXPR PAIRS)) (CDR TMP)) ((NOT (PAIRP EXPR)) EXPR) (T (CONS (GLSUBLIS PAIRS (CAR EXPR)) (GLSUBLIS PAIRS (CDR EXPR)))))))) % edited: 30-AUG-82 10:29 % Make subtype substitutions within TYPE according to GLTYPESUBS. (DE GLSUBSTTYPE (TYPE SUBS) (SUBLIS SUBS TYPE)) % edited: 11-NOV-82 14:02 % Get the list of superclasses for CLASS. (DE GLSUPERS (CLASS) (PROG (TMP) (RETURN (AND (SETQ TMP (GET CLASS 'GLSTRUCTURE)) (LISTGET (CDR TMP) 'SUPERS))))) % GSN 25-JAN-83 15:13 % edited: 17-Apr-81 14:23 % EXPR begins with THE. Parse the expression and return code. (DE GLTHE (PLURALFLG) (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND TMP) % Now trace the path specification. (GLTHESPECS) (SETQ QUALFLG (AND EXPR (MEMQ (CAR EXPR) '(with With WITH who Who WHO which Which WHICH that That THAT))) ) B (COND ((NULL SPECS) (COND ((MEMQ (CAR EXPR) '(IS Is is HAS Has has ARE Are are)) (RETURN (GLPREDICATE SOURCE CONTEXT T NIL))) (QUALFLG (GO C)) (T (RETURN SOURCE)))) ((AND QUALFLG (NOT PLURALFLG) (NULL (CDR SPECS))) % If this is a definite reference to a qualified entity, make the name % of the entity plural. (SETQ NAME (CAR SPECS)) (RPLACA SPECS (GLPLURAL (CAR SPECS))))) % Try to find the next name on the list of SPECS from SOURCE. (COND ((NULL SOURCE) (OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS)) NIL)) (RETURN (GLERROR 'GLTHE (LIST "The definite reference to" NAME "could not be found."))))) (SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS) CONTEXT)))) (GO B) C (COND ((or (not (pairp (SETQ DTYPE (GLXTRTYPE (CADR SOURCE))))) (ne (car dtype) 'LISTOF)) (OR (and (pairp (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE)))) (eq (car dtype) 'LISTOF)) (GLERROR 'GLTHE (LIST "The group name" NAME "has type" DTYPE "which is not a legal group type."))))) (SETQ NEWCONTEXT (CONS NIL CONTEXT)) (GLADDSTR (SETQ LOOPVAR (GLMKVAR)) NAME (CADR DTYPE) NEWCONTEXT) (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE)) NEWCONTEXT (MEMQ (pop EXPR) '(who Who WHO which Which WHICH that That THAT)) NIL)) (SETQ TMP (GLGENCODE (LIST (COND (PLURALFLG 'SUBSET) (T 'SOME)) (CAR SOURCE) (LIST 'FUNCTION (LIST 'LAMBDA (LIST LOOPVAR) (CAR LOOPCOND)))))) (RETURN (COND (PLURALFLG (LIST TMP (CADR SOURCE))) (T (LIST (LIST 'CAR TMP) (CADR DTYPE))))))) % edited: 20-MAY-82 17:19 % EXPR begins with THE. Parse the expression and return code in SOURCE % and path names in SPECS. (DE GLTHESPECS NIL (PROG NIL A (COND ((NULL EXPR) (RETURN NIL)) ((MEMQ (CAR EXPR) '(THE The the)) (pop EXPR) (COND ((NULL EXPR) (RETURN (GLERROR 'GLTHE (LIST "Nothing following THE"))))))) (COND ((ATOM (CAR EXPR)) (GLSEPINIT (CAR EXPR)) (COND ((EQ (GLSEPNXT) (CAR EXPR)) (SETQ SPECS (CONS (pop EXPR) SPECS))) (T (GLSEPCLR) (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL)))) (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T)) (RETURN NIL))) % SPECS contains a path specification. See if there is any more. (COND ((MEMQ (CAR EXPR) '(OF Of of)) (pop EXPR) (GO A))))) % edited: 14-DEC-81 10:51 % Return a list of all transparent types defined for STR (DE GLTRANSPARENTTYPES (STR) (PROG (TTLIST) (COND ((ATOM STR) (SETQ STR (GLGETSTR STR)))) (GLTRANSPB STR) (RETURN (REVERSIP TTLIST)))) % edited: 13-NOV-81 15:37 % Look for TRANSPARENT substructures for GLTRANSPARENTTYPES. (DE GLTRANSPB (STR) (COND ((NOT (PAIRP STR))) ((EQ (CAR STR) 'TRANSPARENT) (SETQ TTLIST (CONS STR TTLIST))) ((MEMQ (CAR STR) '(LISTOF ALIST PROPLIST))) (T (MAPC (CDR STR) (FUNCTION GLTRANSPB))))) % edited: 4-JUN-82 11:18 % Translate places where a PROG variable is initialized to a value as % allowed by Interlisp. This is done by adding a SETQ to set the % value of each PROG variable which is initialized. In some cases, a % change of variable name is required to preserve the same % semantics. (DE GLTRANSPROG (X) (PROG (TMP ARGVALS SETVARS) (MAP (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP (CAR Y)) % If possible, use the same variable; otherwise, make a new one. (SETQ TMP (COND ((OR (SOME (CADR X) (FUNCTION (LAMBDA (Z) (AND (PAIRP Z) (GLOCCURS (CAR Z) (CADAR Y)))))) (SOME ARGVALS (FUNCTION (LAMBDA (Z) (GLOCCURS (CAAR Y) Z))))) (GLMKVAR)) (T (CAAR Y)))) (SETQ SETVARS (ACONC SETVARS (LIST 'SETQ TMP (CADAR Y)))) (SUBSTIP TMP (CAAR Y) (CDDR X)) (SETQ ARGVALS (CONS (CADAR Y) ARGVALS)) (RPLACA Y TMP)))))) (COND (SETVARS (RPLACD (CDR X) (NCONC SETVARS (CDDR X))))) (RETURN X))) % GSN 10-FEB-83 13:31 % See if the type SUBTYPE matches the type TYPE, either directly or % because TYPE is a SUPER of SUBTYPE. (DE GLTYPEMATCH (SUBTYPE TYPE) (PROG NIL (SETQ SUBTYPE (GLXTRTYPE SUBTYPE)) (RETURN (OR (NULL SUBTYPE) (NULL TYPE) (EQ TYPE 'ANYTHING) (EQUAL SUBTYPE TYPE) (SOME (GLSUPERS SUBTYPE) (FUNCTION (LAMBDA (Y) (GLTYPEMATCH Y TYPE)))))))) % GSN 3-FEB-83 14:41 % Remove the GLISP-compiled definition and properties of GLAMBDAFN (DE GLUNCOMPILE (GLAMBDAFN) (PROG (SPECS SPECLST STR LST TMP) (OR (GET GLAMBDAFN 'GLCOMPILED) (SETQ SPECS (GET GLAMBDAFN 'GLSPECIALIZATION)) (RETURN NIL)) (COND ((NOT GLQUIETFLG) (PRIN1 "uncompiling ") (PRIN1 GLAMBDAFN) (TERPRI))) (PUT GLAMBDAFN 'GLCOMPILED NIL) (PUT GLAMBDAFN 'GLRESULTTYPE NIL) (GLUNSAVEDEF GLAMBDAFN) (MAPC (GET GLAMBDAFN 'GLTYPESUSED) (FUNCTION (LAMBDA (Y) (PUT Y 'GLFNSUSEDIN (Deletip GLAMBDAFN (GET Y 'GLFNSUSEDIN)))))) (PUT GLAMBDAFN 'GLTYPESUSED NIL) (OR SPECS (RETURN NIL)) % Uncompile a specialization of a generic function. % Remove the function definition so it will be garbage collected. (PUTD GLAMBDAFN NIL) A (COND ((NULL SPECS) (RETURN NIL))) (SETQ SPECLST (pop SPECS)) (PUT (CAR SPECLST) 'GLINSTANCEFNS (DREMOVE GLAMBDAFN (GET (CAR SPECLST) 'GLINSTANCEFNS))) % Remove the specialization entry in the datatype where it was % created. (OR (SETQ STR (GET (CADR SPECLST) 'GLSTRUCTURE)) (GO A)) (SETQ LST (CDR STR)) LP (COND ((NULL LST) (GO A)) ((EQ (CAR LST) (CADDR SPECLST)) (COND ((AND (SETQ TMP (ASSOC (CADDDR SPECLST) (CADR LST))) (EQ (CADR TMP) GLAMBDAFN)) (RPLACA (CDR LST) (DREMOVE TMP (CADR LST))))) (GO A)) (T (SETQ LST (CDDR LST)) (GO LP))))) % edited: 27-MAY-82 13:08 % GLUNITOP calls a function to generate code for an operation on a % unit in a units package. UNITREC is the unit record for the units % package, LHS and RHS the code for the left-hand side and % right-hand side of the operation % (in general, the (QUOTE GET') code for each side) , and OP is the % operation to be performed. (DE GLUNITOP (LHS RHS OP) (PROG (TMP LST UNITREC) % (SETQ LST GLUNITPKGS) A (COND ((NULL LST) (RETURN NIL)) ((NOT (MEMQ (CAAR LHS) (CADAR LST))) (SETQ LST (CDR LST)) (GO A))) (SETQ UNITREC (CAR LST)) (COND ((SETQ TMP (ASSOC OP (CADDR UNITREC))) (RETURN (APPLY (CDR TMP) (LIST LHS RHS))))) (RETURN NIL))) % edited: 27-MAY-82 13:08 % GLUNIT? tests a given structure to see if it is a unit of one of the % unit packages on GLUNITPKGS. If so, the value is the unit package % record for the unit package which matched. (DE GLUNIT? (STR) (PROG (UPS) (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (RETURN NIL)) ((APPLY (CAAR UPS) (LIST STR)) (RETURN (CAR UPS)))) (SETQ UPS (CDR UPS)) (GO LP))) % GSN 28-JAN-83 11:15 % Remove the GLISP-compiled definition of GLAMBDAFN (DE GLUNSAVEDEF (GLAMBDAFN) (GLPUTHOOK GLAMBDAFN)) % GSN 27-JAN-83 13:58 % Unwrap an expression X by removing extra stuff inserted during % compilation. (DE GLUNWRAP (X BUSY) (COND ((NOT (PAIRP X)) X) ((NOT (ATOM (CAR X))) (ERROR 0 (LIST 'GLUNWRAP X))) ((CASEQ (CAR X) ('GO X) ((PROG2 PROGN) (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN X BUSY NIL) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (PROG1 (COND ((NULL (CDDR X)) (GLUNWRAP (CADR X) BUSY)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (EQ Y (CDR X)))))))) (COND (BUSY (GLEXPANDPROGN (CDR X) BUSY NIL)) (T (RPLACA X 'PROGN) (GLEXPANDPROGN X BUSY NIL))) (COND ((NULL (CDDR X)) (CADR X)) (T X))))) (FUNCTION (RPLACA (CDR X) (GLUNWRAP (CADR X) BUSY)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) X) ((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY) (GLUNWRAPMAP X BUSY)) (LAMBDA (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CDR X) BUSY NIL) X) (PROG (GLUNWRAPPROG X BUSY)) (COND (GLUNWRAPCOND X BUSY)) ((SELECTQ CASEQ) (GLUNWRAPSELECTQ X BUSY)) ((UNION INTERSECTION LDIFFERENCE) (GLUNWRAPINTERSECT X)) (t (COND ((AND (EQ (CAR X) '*) (EQ GLLISPDIALECT 'INTERLISP)) X) ((AND (NOT BUSY) (CDR X) (NULL (CDDR X)) (GLPURE (CAR X))) (GLUNWRAP (CADR X) NIL)) (T (MAP (CDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (COND ((AND (CDR X) (NULL (CDDR X)) (PAIRP (CADR X)) (GLCARCDR? (CAR X)) (GLCARCDR? (CAADR X)) (LESSP (PLUS (FlatSize2 (CAR X)) (FlatSize2 (CAADR X))) 9)) (RPLACA X (IMPLODE (CONS 'C (REVERSIP (CONS 'R (NCONC (GLANYCARCDR? (CAADR X)) (GLANYCARCDR? (CAR X)))))))) (RPLACA (CDR X) (CADADR X)) (GLUNWRAP X BUSY)) ((AND (GET (CAR X) 'GLEVALWHENCONST) (EVERY (CDR X) (FUNCTION GLCONST?)) (OR (NOT (GET (CAR X) 'GLARGSNUMBERP)) (EVERY (CDR X) (FUNCTION NUMBERP)))) (EVAL X)) ((MEMQ (CAR X) '(AND OR)) (GLUNWRAPLOG X)) (T X))))))))) % GSN 27-JAN-83 13:57 % Unwrap a COND expression. (DE GLUNWRAPCOND (X BUSY) (PROG (RESULT) (SETQ RESULT X) A (COND ((NULL (CDR RESULT)) (GO B))) (RPLACA (CADR RESULT) (GLUNWRAP (CAADR RESULT) T)) (COND ((EQ (CAADR RESULT) NIL) (RPLACD RESULT (CDDR RESULT)) (GO A)) (T (MAP (CDADR RESULT) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) (AND BUSY (NULL (CDR Y)))))))) (GLEXPANDPROGN (CADR RESULT) BUSY NIL))) (COND ((EQ (CAADR RESULT) T) (RPLACD (CDR RESULT) NIL))) (SETQ RESULT (CDR RESULT)) (GO A) B (COND ((AND (NULL (CDDR X)) (EQ (CAADR X) T)) (RETURN (CONS 'PROGN (CDADR X)))) (T (RETURN X))))) % edited: 26-DEC-82 16:30 % Optimize intersections and unions of subsets of the same set: % (INTERSECT (SUBSET S P) (SUBSET S Q)) -> (SUBSET S (AND P Q)) (DE GLUNWRAPINTERSECT (CODE) (PROG (LHS RHS P Q QQ SA SB NEWFN) (SETQ LHS (GLUNWRAP (CADR CODE) T)) (SETQ RHS (GLUNWRAP (CADDR CODE) T)) (OR (AND (PAIRP LHS) (PAIRP RHS) (EQ (CAR LHS) 'SUBSET) (EQ (CAR RHS) 'SUBSET)) (GO OUT)) (PROGN (SETQ SA (GLUNWRAP (CADR LHS) T)) (SETQ SB (GLUNWRAP (CADR RHS) T))) % Make sure the sets are the same. (OR (EQUAL SA SB) (GO OUT)) (PROGN (SETQ P (GLXTRFN (CADDR LHS))) (SETQ Q (GLXTRFN (CADDR RHS)))) (SETQ QQ (SUBST (CAR P) (CAR Q) (CADR Q))) (RETURN (GLGENCODE (LIST 'SUBSET SA (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR P)) (GLUNWRAP (CASEQ (CAR CODE) (INTERSECTION (LIST 'AND (CADR P) QQ)) (UNION (LIST 'OR (CADR P) QQ)) (LDIFFERENCE (LIST 'AND (CADR P) (LIST 'NOT QQ))) (t (ERROR 0 NIL))) T)))))) OUT (MAP (CDR CODE) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) T))))) (RETURN CODE))) % edited: 26-DEC-82 16:24 % Unwrap a logical expression by performing constant transformations % and splicing in sublists of the same type, e.g., (AND X (AND Y Z)) % -> (AND X Y Z) . (DE GLUNWRAPLOG (X) (PROG (Y LAST) (SETQ Y (CDR X)) (SETQ LAST X) LP (COND ((NULL Y) (GO OUT)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'AND)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'OR))) (RPLACD Y NIL)) ((OR (AND (NULL (CAR Y)) (EQ (CAR X) 'OR)) (AND (EQ (CAR Y) T) (EQ (CAR X) 'AND))) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((MEMBER (CAR Y) (CDR Y)) (SETQ Y (CDR Y)) (RPLACD LAST Y) (GO LP)) ((AND (PAIRP (CAR Y)) (EQ (CAAR Y) (CAR X))) (RPLACD (LASTPAIR (CAR Y)) (CDR Y)) (RPLACD Y (CDDAR Y)) (RPLACA Y (CADAR Y)))) (SETQ Y (CDR Y)) (SETQ LAST (CDR LAST)) (GO LP) OUT (COND ((NULL (CDR X)) (RETURN (EQ (CAR X) 'AND))) ((NULL (CDDR X)) (RETURN (CADR X)))) (RETURN X))) % edited: 19-OCT-82 16:03 % Unwrap and optimize mapping-type functions. (DE GLUNWRAPMAP (X BUSY) (PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST) (PROGN (SETQ LST (GLUNWRAP (CADR X) T)) (SETQ FN (GLUNWRAP (CADDR X) (NOT (MEMQ (CAR X) '(MAPC MAP)))))) (COND ((OR (NOT (MEMQ (SETQ OUTFN (CAR X)) '(SUBSET MAPCAR MAPC MAPCONC))) (NOT (AND (PAIRP LST) (MEMQ (SETQ INFN (CAR LST)) '(SUBSET MAPCAR))))) (GO OUT))) % Optimize compositions of mapping functions to avoid construction of % lists of intermediate results. % These optimizations are not correct if the mapping functions have % interdependent side-effects. However, these are likely to be very % rare, so we do it anyway. (SETQ OUTSIDE (GLXTRFN FN)) (SETQ INSIDE (GLXTRFN (PROGN (SETQ NEWLST (CADR LST)) (CADDR LST)))) (CASEQ INFN (SUBSET (CASEQ OUTFN ((SUBSET MAPCONC) (SETQ NEWMAP OUTFN) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE))))) (MAPCAR (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (LIST 'CONS (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE)) NIL)))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (LIST 'AND (CADR INSIDE) (SUBST (CAR INSIDE) (CAR OUTSIDE) (CADR OUTSIDE))))) (t (ERROR 0 NIL)))) (MAPCAR (SETQ NEWFN (LIST 'PROG (LIST (SETQ TMPVAR (GLMKVAR))) (LIST 'SETQ TMPVAR (CADR INSIDE)) (LIST 'RETURN '*GLCODE*))) (CASEQ OUTFN (SUBSET (SETQ NEWMAP 'MAPCONC) (SETQ NEWFN (SUBST (LIST 'AND (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) (LIST 'CONS TMPVAR NIL)) '*GLCODE* NEWFN))) (MAPCAR (SETQ NEWMAP 'MAPCAR) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (MAPC (SETQ NEWMAP 'MAPC) (SETQ NEWFN (SUBST (SUBST TMPVAR (CAR OUTSIDE) (CADR OUTSIDE)) '*GLCODE* NEWFN))) (t(ERROR 0 NIL)))) (t (ERROR 0 NIL))) (RETURN (GLUNWRAP (GLGENCODE (LIST NEWMAP NEWLST (LIST 'FUNCTION (LIST 'LAMBDA (LIST (CAR INSIDE)) NEWFN)))) BUSY)) OUT (RETURN (GLGENCODE (LIST OUTFN LST FN))))) % GSN 27-JAN-83 13:57 % Unwrap a PROG expression. (DE GLUNWRAPPROG (X BUSY) (PROG (LAST) (COND ((NE GLLISPDIALECT 'INTERLISP) (GLTRANSPROG X))) % First see if the PROG is not busy and ends with a RETURN. (COND ((AND (NOT BUSY) (SETQ LAST (LASTPAIR X)) (PAIRP (CAR LAST)) (EQ (CAAR LAST) 'RETURN)) % Remove the RETURN. If atomic, remove the atom also. (COND ((ATOM (CADAR LAST)) (RPLACD (NLEFT X 2) NIL)) (T (RPLACA LAST (CADAR LAST)))))) % Do any initializations of PROG variables. (MAPC (CADR X) (FUNCTION (LAMBDA (Y) (COND ((PAIRP Y) (RPLACA (CDR Y) (GLUNWRAP (CADR Y) T))))))) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (RPLACA Y (GLUNWRAP (CAR Y) NIL))))) (GLEXPANDPROGN (CDR X) BUSY T) (RETURN X))) % GSN 27-JAN-83 13:57 % Unwrap a SELECTQ or CASEQ expression. (DE GLUNWRAPSELECTQ (X BUSY) (PROG (L SELECTOR) % First unwrap the component expressions. (RPLACA (CDR X) (GLUNWRAP (CADR X) T)) (MAP (CDDR X) (FUNCTION (LAMBDA (Y) (COND ((OR (CDR Y) (EQ (CAR X) 'CASEQ)) (MAP (CDAR Y) (FUNCTION (LAMBDA (Z) (RPLACA Z (GLUNWRAP (CAR Z) (AND BUSY (NULL (CDR Z)))))))) (GLEXPANDPROGN (CAR Y) BUSY NIL)) (T (RPLACA Y (GLUNWRAP (CAR Y) BUSY))))))) % Test if the selector is a compile-time constant. (COND ((NOT (GLCONST? (CADR X))) (RETURN X))) % Evaluate the selection at compile time. (SETQ SELECTOR (GLCONSTVAL (CADR X))) (SETQ L (CDDR X)) LP (COND ((NULL L) (RETURN NIL)) ((AND (NULL (CDR L)) (EQ (CAR X) 'SELECTQ)) (RETURN (CAR L))) ((AND (EQ (CAR X) 'CASEQ) (EQ (CAAR L) T)) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY))) ((OR (EQ SELECTOR (CAAR L)) (AND (PAIRP (CAAR L)) (MEMQ SELECTOR (CAAR L)))) (RETURN (GLUNWRAP (CONS 'PROGN (CDAR L)) BUSY)))) (SETQ L (CDR L)) (GO LP))) % edited: 5-MAY-82 15:49 % Update the type of VAR to be TYPE. (DE GLUPDATEVARTYPE (VAR TYPE) (PROG (CTXENT) (COND ((NULL TYPE)) ((SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT)) (COND ((NULL (CADDR CTXENT)) (RPLACA (CDDR CTXENT) TYPE)))) (T (GLADDSTR VAR NIL TYPE CONTEXT))))) % GSN 23-JAN-83 15:31 % edited: 7-Apr-81 10:44 % Process a user-function, i.e., any function which is not specially % compiled by GLISP. The function is tested to see if it is one % which a unit package wants to compile specially; if not, the % function is compiled by GLUSERFNB. (DE GLUSERFN (EXPR) (PROG (FNNAME TMP UPS) (SETQ FNNAME (CAR EXPR)) % First see if a user structure-name package wants to intercept this % function call. (SETQ UPS GLUSERSTRNAMES) LPA (COND ((NULL UPS) (GO B)) ((SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LPA) B % Test the function name to see if it is a function which some unit % package would like to intercept and compile specially. (SETQ UPS GLUNITPKGS) LP (COND ((NULL UPS) (GO C)) ((AND (MEMQ FNNAME (CAR (CDDDDR (CAR UPS)))) (SETQ TMP (ASSOC 'UNITFN (CADDR (CAR UPS))))) (RETURN (APPLY (CDR TMP) (LIST EXPR CONTEXT))))) (SETQ UPS (CDR UPS)) (GO LP) C (COND ((AND (NOT (UNBOUNDP 'GLFNSUBS)) (SETQ TMP (ASSOC FNNAME GLFNSUBS))) (RETURN (GLUSERFNB (CONS (CDR TMP) (CDR EXPR))))) (T (RETURN (GLUSERFNB EXPR)))))) % GSN 23-JAN-83 15:54 % edited: 7-Apr-81 10:44 % Parse an arbitrary function by getting the function name and then % calling GLDOEXPR to get the arguments. (DE GLUSERFNB (EXPR) (PROG (ARGS ARGTYPES FNNAME TMP) (SETQ FNNAME (pop EXPR)) A (COND ((NULL EXPR) (SETQ ARGS (REVERSIP ARGS)) (SETQ ARGTYPES (REVERSIP ARGTYPES)) (RETURN (COND ((AND (GET FNNAME 'GLEVALWHENCONST) (EVERY ARGS (FUNCTION GLCONST?))) (LIST (EVAL (CONS FNNAME ARGS)) (GLRESULTTYPE FNNAME ARGTYPES))) (T (LIST (CONS FNNAME ARGS) (GLRESULTTYPE FNNAME ARGTYPES)))))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS (CAR TMP) ARGS)) (SETQ ARGTYPES (CONS (CADR TMP) ARGTYPES)) (GO A))))) % edited: 24-AUG-82 17:40 % Get the arguments to an function call for use by a user compilation % function. (DE GLUSERGETARGS (EXPR CONTEXT) (PROG (ARGS TMP) (pop EXPR) A (COND ((NULL EXPR) (RETURN (REVERSIP ARGS))) ((SETQ TMP (OR (GLDOEXPR NIL CONTEXT T) (PROG1 (GLERROR 'GLUSERFNB (LIST "Function call contains illegal item. EXPR =" EXPR)) (SETQ EXPR NIL)))) (SETQ ARGS (CONS TMP ARGS)) (GO A))))) % GSN 10-FEB-83 16:01 % Try to perform an operation on a user-defined structure, which is % LHS. The type of LHS is looked up on GLUSERSTRNAMES, and if found, % the appropriate user function is called. (DE GLUSERSTROP (LHS OP RHS) (PROG (TMP DES TMPB) (SETQ DES (CADR LHS)) (COND ((NULL DES) (RETURN NIL)) ((ATOM DES) (COND ((NE (SETQ TMP (GLGETSTR DES)) DES) (RETURN (GLUSERSTROP (LIST (CAR LHS) TMP) OP RHS))) (T (RETURN NIL)))) ((NOT (PAIRP DES)) (RETURN NIL)) ((AND (SETQ TMP (ASSOC (CAR DES) GLUSERSTRNAMES)) (SETQ TMPB (ASSOC OP (CADDDR TMP)))) (RETURN (APPLY (CDR TMPB) (LIST LHS RHS)))) (T (RETURN NIL))))) % GSN 10-FEB-83 12:57 % Get the value of the property PROP from SOURCE, whose type is given % by TYPE. The property may be a field in the structure, or may be a % PROP virtual field. % DESLIST is a list of object types which have previously been tried, % so that a compiler loop can be prevented. (DE GLVALUE (SOURCE PROP TYPE DESLIST) (PROG (TMP PROPL TRANS FETCHCODE) (COND ((MEMQ TYPE DESLIST) (RETURN NIL)) ((SETQ TMP (GLSTRFN PROP TYPE DESLIST)) (RETURN (GLSTRVAL TMP SOURCE))) ((SETQ PROPL (GLSTRPROP TYPE 'PROP PROP NIL)) (SETQ TMP (GLCOMPMSGL (LIST SOURCE TYPE) 'PROP PROPL NIL CONTEXT)) (RETURN TMP))) % See if the value can be found in a TRANSPARENT subobject. (SETQ TRANS (GLTRANSPARENTTYPES TYPE)) B (COND ((NULL TRANS) (RETURN NIL)) ((SETQ TMP (GLVALUE '*GL* PROP (GLXTRTYPE (CAR TRANS)) (CONS (CAR TRANS) DESLIST))) (SETQ FETCHCODE (GLSTRFN (CAR TRANS) TYPE NIL)) (GLSTRVAL TMP (CAR FETCHCODE)) (GLSTRVAL TMP SOURCE) (RETURN TMP)) ((SETQ TMP (CDR TMP)) (GO B))))) % edited: 16-DEC-81 12:00 % Get the structure-description for a variable in the specified % context. (DE GLVARTYPE (VAR CONTEXT) (PROG (TMP) (RETURN (COND ((SETQ TMP (GLFINDVARINCTX VAR CONTEXT)) (OR (CADDR TMP) '*NIL*)) (T NIL))))) % edited: 3-DEC-82 10:24 % Extract the code and variable from a FUNCTION list. If there is no % variable, a new one is created. The result is a list of the % variable and code. (DE GLXTRFN (FNLST) (PROG (TMP) % If only the function name is specified, make a LAMBDA form. (COND ((ATOM (CADR FNLST)) (RPLACA (CDR FNLST) (LIST 'LAMBDA (LIST (SETQ TMP (GLMKVAR))) (LIST (CADR FNLST) TMP))))) (COND ((CDDDR (CADR FNLST)) (RPLACD (CDADR FNLST) (LIST (CONS 'PROGN (CDDADR FNLST)))))) (RETURN (LIST (CAADR (CADR FNLST)) (CADDR (CADR FNLST)))))) % edited: 26-JUL-82 14:03 % Extract an atomic type name from a type spec which may be either % <type> or (A <type>) . (DE GLXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) ((AND (OR (GL-A-AN? (CAR TYPE)) (EQ (CAR TYPE) 'TRANSPARENT)) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPE (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 26-JUL-82 14:02 % Extract a -real- type from a type spec. (DE GLXTRTYPEB (TYPE) (COND ((NULL TYPE) NIL) ((ATOM TYPE) (COND ((MEMQ TYPE GLBASICTYPES) TYPE) (T (GLXTRTYPEB (GLGETSTR TYPE))))) ((NOT (PAIRP TYPE)) NIL) ((MEMQ (CAR TYPE) GLTYPENAMES) TYPE) ((ASSOC (CAR TYPE) GLUSERSTRNAMES) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GLXTRTYPEB (CADR TYPE))) (T (GLERROR 'GLXTRTYPE (LIST TYPE "is an illegal type specification.")) NIL))) % edited: 1-NOV-82 16:38 % Extract a -real- type from a type spec. (DE GLXTRTYPEC (TYPE) (AND (ATOM TYPE) (NOT (MEMQ TYPE GLBASICTYPES)) (GLXTRTYPE (GLGETSTR TYPE)))) % GSN 9-FEB-83 16:46 (DF SEND (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) NIL (CADR GLISPSENDARGS) 'MSG (MAPCAR (CDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDC (GLISPSENDARGS) (GLSENDB (EVAL (CAR GLISPSENDARGS)) (CADR GLISPSENDARGS) (CADDR GLISPSENDARGS) 'MSG (MAPCAR (CDDDR GLISPSENDARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:46 (DF SENDPROP (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) NIL (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (MAPCAR (CDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % GSN 9-FEB-83 16:48 (DF SENDPROPC (GLISPSENDPROPARGS) (GLSENDB (EVAL (CAR GLISPSENDPROPARGS)) (CADR GLISPSENDPROPARGS) (CADDR GLISPSENDPROPARGS) (CADDDR GLISPSENDPROPARGS) (MAPCAR (CDDDDR GLISPSENDPROPARGS) (FUNCTION EVAL)))) % % GLTAIL.PSL.12 19 Jan. 1983 % % FILE OF FUNCTIONS FOR COMPATIBILITY WITH PORTABLE STANDARD LISP (PSL) % G. NOVAK 20 OCTOBER 1982 % (DE GETDDD (X) (CDR (GETD X))) (DE PUTDDD (FN DEF) (REMD FN) (PUTD FN 'EXPR DEF)) (DE LISTGET (L PROP) (COND ((NULL L) NIL) ((EQ (CAR L) PROP) (CADR L)) (T (LISTGET (CDDR L) PROP) )) ) % NOTE -- THIS VERSION OF NLEFT ONLY WORKS FOR N=2. (DE NLEFT (L N) (COND ((NOT (EQN N 2)) (ERROR 0 N)) ((NULL L) NIL) ((NULL (CDDR L)) L) (T (NLEFT (CDR L) N) )) ) (DE NLISTP (X) (NOT (PAIRP X))) (DF COMMENT (X) NIL) % ASSUME EVERYTHING UPPER-CASE FOR PSL. (DE U-CASEP (X) T) (de glucase (x) x) % PARTIAL IMPLEMENTATION OF SUBATOM FOR POSITIVE NUMBERS. (DE SUBATOM (ATM N M) (PROG (LST SZ) (setq sz (flatsize2 atm)) (cond ((minusp n) (setq n (add1 (plus sz n))))) (cond ((minusp m) (setq m (add1 (plus sz m))))) (COND ((GREATERP M sz)(RETURN NIL))) A (COND ((GREATERP N M)(RETURN (AND LST (IMPLODE (REVERSIP LST)))))) (SETQ LST (CONS (GLNTHCHAR ATM N) LST)) (COND ((MEMQ (CAR LST) '(!' !, !!)) (RPLACD LST (CONS (QUOTE !!) (CDR LST))) )) (SETQ N (ADD1 N)) (GO A) )) % FIND THE STRING POSITION IN ATOM ATM WHERE A CHARACTER IN THE % BIT TABLE BITTBL OCCURS, STARTING WITH CHARACTER N. (DE STRPOSL (BITTBL ATM N) (PROG (NC) (COND ((NULL N)(SETQ N 1))) (SETQ NC (FLATSIZE2 ATM)) A (COND ((GREATERP N NC)(RETURN NIL)) ((INDX GLSEPBITTBL (id2int (GLNTHCHAR ATM N)))(RETURN N))) (SETQ N (ADD1 N)) (GO A) )) % MAKE A BIT TABLE FROM A LIST OF CHARACTERS. (DE MAKEBITTABLE (L) (PROG () (SETQ GLSEPBITTBL (MkVect 255)) (MAPC L (FUNCTION (LAMBDA (X) (PutV GLSEPBITTBL (id2int X) T) ))) (RETURN GLSEPBITTBL) )) % Fexpr for defining GLISP functions. (df dg (x) (put (car x) 'gloriginalexpr (cons 'lambda (cdr x))) (put (car x) 'glcompiled nil) (putd (car x) 'macro '(lambda (gldgform)(glhook gldgform))) ) % Hook for compiling a GLISP function on its first call. (de glhook (gldgform) (glcc (car gldgform)) gldgform) (de glputhook (x) (put x 'glcompiled nil) (putd x 'macro '(lambda (gldgform) (glhook gldgform)))) % Interlisp-style NTHCHAR. (de glnthchar (x n) (prog (s l) (setq s (id2string x)) (setq l (size s)) (cond ((minusp n)(setq n (add1 (plus l n)))) (t (setq n (sub1 n)))) (cond ((or (minusp n)(greaterp n l))(return nil))) (return (int2id (indx s n))))) % FIND FIRST ELEMENT OF A LIST FOR WHICH FN IS TRUE (DE SOME (L FN) (COND ((NULL L) NIL) ((APPLY FN (LIST (CAR L))) L) (T (SOME (CDR L) FN)))) % TEST IF FN IS TRUE FOR EVERY ELEMENT OF A LIST % SOME and EVERY switched FN and L (DE EVERY (L FN) (COND ((NULL L) T) ((APPLY FN (LIST (CAR L))) (EVERY (CDR L) FN)) (T NIL))) % SUBSET OF A LIST FOR WHICH FN IS TRUE (DE SUBSET (L FN) (PROG (RESULT) A (COND ((NULL L)(RETURN (REVERSIP RESULT))) ((APPLY FN (LIST (CAR L))) (SETQ RESULT (CONS (CAR L) RESULT)))) (SETQ L (CDR L)) (GO A))) (DE REMOVE (X L) (DELETE X L)) % LIST DIFFERENCE X - Y (DE LDIFFERENCE (X Y) (MAPCAN X (FUNCTION (LAMBDA (Z) (COND ((MEMQ Z Y) NIL) (T (CONS Z NIL))))))) % FIRST A FEW FUNCTION DEFINITIONS. % GET FUNCTION DEFINITION FOR THE GLISP COMPILER. (DE GLGETD (FN) (OR (and (or (null (get fn 'glcompiled)) (eq (getddd fn) (get fn 'glcompiled))) (GET FN 'GLORIGINALEXPR)) (GETDDD FN))) (DE GLGETDB (FN) (GLGETD FN)) (DE GLAMBDATRAN (GLEXPR) (PROG (NEWEXPR) (SETQ GLLASTFNCOMPILED FAULTFN) (PUT FAULTFN 'GLORIGINALEXPR GLEXPR) (COND ((SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)) (putddd FAULTFN NEWEXPR) (put faultfn 'glcompiled newexpr) )) (RETURN NEWEXPR) )) (DE GLERROR (FN MSGLST) (PROG () (TERPRI) (PRIN2 "GLISP error detected by ") (PRIN1 FN) (PRIN2 " in function ") (PRINT FAULTFN) (MAPC MSGLST (FUNCTION (LAMBDA (X) (PRIN1 X)(SPACES 1)))) (TERPRI) (PRIN2 "in expression: ") (PRINT (CAR EXPRSTACK)) (TERPRI) (PRIN2 "within expression: ") (PRINT (CADR EXPRSTACK)) (COND (GLBREAKONERROR (ERROR 0 (CAR EXPRSTACK)))) (RETURN (LIST (LIST 'GLERR (LIST 'QUOTE (CAR EXPRSTACK))))) )) % PRINT THE RESULT OF GLISP COMPILATION. (DE GLP (FN) (PROG () (SETQ FN (OR FN GLLASTFNCOMPILED)) (TERPRI) (PRIN2 "GLRESULTTYPE: ") (PRINT (GET FN 'GLRESULTTYPE)) (PRETTYPRINT (GETDDD FN)) (RETURN FN))) % GLISP STRUCTURE EDITOR (DE GLEDS (STRNAME) (EDITV (GET STRNAME 'GLSTRUCTURE)) STRNAME) % GLISP PROPERTY-LIST EDITOR (DE GLED (ATM) (EDITV (PROP ATM))) % GLISP FUNCTION EDITOR (DE GLEDF (FNNAME) (EDITV (GLGETD FNNAME)) FNNAME) (DE KWOTE (X) (COND ((NUMBERP X) X) (T (LIST (QUOTE QUOTE) X))) ) % INITIALIZE (SETQ GLBASICTYPES '(ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING)) (SETQ GLTYPENAMES '(CONS LIST RECORD LISTOF ALIST ATOM OBJECT ATOMOBJECT LISTOBJECT)) (SETQ GLLISPDIALECT 'PSL) (GLINIT) |
Added psl-1983/glisp/oldgltest.sl version [f21dbae4af].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % GLTEST.SL.8 17 January 1983 % GLISP TEST FUNCTIONS, PSL VERSION. % Object descriptions for a Company database. (GLISPOBJECTS (EMPLOYEE % Name of the object type (LIST (NAME STRING) % Actual storage structure (DATE-HIRED (A DATE)) (SALARY REAL) (JOBTITLE ATOM) (TRAINEE BOOLEAN)) PROP ((SENIORITY ((THE YEAR OF (CURRENTDATE)) % Computed properties - (THE YEAR OF DATE-HIRED))) (MONTHLY-SALARY (SALARY * 174))) ADJ ((HIGH-PAID (MONTHLY-SALARY > 2000))) % Computed adjectives ISA ((TRAINEE (TRAINEE)) (GREENHORN (TRAINEE AND SENIORITY < 2))) MSG ((YOURE-FIRED (SALARY _ 0))) ) % Message definitions (Date (List (MONTH INTEGER) (DAY INTEGER) (YEAR INTEGER)) PROP ((MONTHNAME ((NTH '(JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER) MONTH))) (PRETTYFORM ((LIST DAY MONTHNAME YEAR))) (SHORTYEAR (YEAR - 1900))) ) (COMPANY (ATOM (PROPLIST (PRESIDENT (AN EMPLOYEE)) (EMPLOYEES (LISTOF EMPLOYEE) ))) PROP ((ELECTRICIANS ((THOSE EMPLOYEES WITH JOBTITLE='ELECTRICIAN)))) ) ) % Some test data for the above functions. (setq company1 (a company with President = (An Employee with Name = "Oscar the Grouch" Salary = 88.0 Jobtitle = 'President Date-Hired = (A Date with Month = 3 Day = 15 Year = 1907)) Employees = (list (An Employee with Name = "Cookie Monster" Salary = 12.50 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 7 Day = 21 Year = 1947)) (An Employee with Name = "Betty Lou" Salary = 9.00 Jobtitle = 'Electrician Date-Hired = (A Date with Month = 5 Day = 15 Year = 1980)) (An Employee with Name = "Grover" Salary = 3.00 Jobtitle = 'Electrician Trainee = T Date-Hired = (A Date with Month = 6 Day = 13 Year = 1978)) ))) % Program to give raises to the electricians. (DG GIVE-RAISE (:COMPANY) (FOR EACH ELECTRICIAN WHO IS NOT A TRAINEE DO (SALARY _+(IF SENIORITY > 1 THEN 2.5 ELSE 1.5)) (PRINT (THE NAME OF THE ELECTRICIAN)) (PRINT (THE PRETTYFORM OF DATE-HIRED)) (PRINT MONTHLY-SALARY) )) (DG CURRENTDATE () (Result DATE) (A DATE WITH YEAR = 1981 MONTH = 11 DAY = 30)) % The following object descriptions are used in a graphics object test % program (derived from one written by D.G. Bobrow as a LOOPS example). % The test program MGO-TEST runs on a Xerox D-machine, but won't run on % other machines. (GLISPOBJECTS % The actual stored structure for a Vector is simple, but it is overloaded % with many properties. (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (DIRECTION ((IF X IS ZERO THEN (IF Y IS NEGATIVE THEN -90.0 ELSE 90.0) ELSE (ATAN2D Y X))) RESULT DEGREES) ) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) % Defining operators as messages % causes the compiler to automatically % overload the operators. (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T ARGTYPES (NUMBER)) (* vectordotproduct open t argtypes (vector)) (/ VECTORQUOTIENT OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((SEND SELF PRIN1) % PRINT is defined in terms of the (TERPRI))) ) ) % PRIN1 message of this object. (DEGREES REAL % Stored value is just a real number. PROP ((RADIANS (self*(3.1415926 / 180.0)) RESULT RADIANS))) (RADIANS REAL PROP ((DEGREES (self*(180.0 / 3.1415926)) RESULT DEGREES))) % The definition of GraphicsObject builds on that of Vector. (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) % A property defined in terms of a % property of a substructure (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) % Vector addition. (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) % Vector arithmetic (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY (GET SHAPE 'DRAWFN) % A way to get runtime message (List SELF % behavior without using the (QUOTE PAINT))))) % message mechanism. (ERASE ((APPLY (GET SHAPE 'DRAWFN) (LIST SELF (QUOTE ERASE))))) (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (MOVINGGRAPHICSOBJECT (LIST (TRANSPARENT GRAPHICSOBJECT) % Includes properties of a (VELOCITY VECTOR)) % GraphicsObject due to the % TRANSPARENT declaration. Msg ((ACCELERATE MGO-ACCELERATE OPEN T) (STEP ((SEND SELF MOVE VELOCITY)))) ) ) % The following functions define arithmetic operations on Vectors. % These functions are generally called OPEN (macro-expanded) rather % than being called directly. (DG VECTORPLUS (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) (DG VECTORDIFF (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) (DG VECTORTIMES (V:VECTOR N:NUMBER) (A (typeof v) WITH X = X*N Y = Y*N)) (DG VECTORDOTPRODUCT (V1:vector V2:VECTOR) (A (typeof v1) WITH X = V1:X * V2:X Y = V1:Y * V2:Y)) (DG VECTORQUOTIENT (V:VECTOR N:NUMBER) (A (typeof v) WITH X = X/N Y = Y/N)) % VectorMove, which defines the _+ operator for vectors, does a destructive % addition to the vector which is its first argument. Thus, the expression % U_+V will destructively change U, while U_U+V will make a new vector with % the value U+V and assign its value to U. (DG VECTORMOVE (V:vector DELTA:VECTOR) (V:X _+ DELTA:X) (V:Y _+ DELTA:Y) V) % An object is moved by erasing it, changing its starting point, and % then redrawing it. (DG GRAPHICSOBJECTMOVE (SELF:GRAPHICSOBJECT DELTA:VECTOR) (SEND SELF ERASE) % Erase the object (START _+ DELTA) % Destructively move start point by delta (SEND SELF DRAW)) % Redraw the object in new location (DG MGO-ACCELERATE (SELF: MOVINGGRAPHICSOBJECT ACCELERATION: VECTOR) VELOCITY _+ ACCELERATION) % Now we define some test functions which use the above definitions. % First there are some simple functions which test vector operations. (DG TVPLUS (U:VECTOR V:VECTOR) U+V) (DG TVMOVE (U:VECTOR V:VECTOR) U_+V) (DG TVTIMESN (U:VECTOR N:NUMBER) U*N) (DG TVTIMESV (U:VECTOR V:VECTOR) U*V) % This test function creates a MovingGraphicsObject and then moves it % across the screen by sending it MOVE messages. Everything in this % example is compiled open; the STEP message involves a great deal of % message inheritance. (DG MGO-TEST () (PROG (MGO N) (MGO _(A MOVINGGRAPHICSOBJECT WITH SHAPE = (QUOTE RECTANGLE) SIZE = (A VECTOR WITH X = 4 Y = 3) VELOCITY = (A VECTOR WITH X = 3 Y = 4))) (N _ 0) (WHILE (N_+1)<100 (SEND MGO STEP)) (SEND (THE START OF MGO) PRINT))) % This function tests the properties of a GraphicsObject. (DG TESTFN2 (:GRAPHICSOBJECT) (LIST SHAPE START SIZE LEFT BOTTOM RIGHT TOP WIDTH HEIGHT CENTER AREA)) % Function to draw a rectangle. Computed properties of the rectangle are % used within calls to the graphics functions, making the code easy to % write and understand. (DG DRAWRECT (SELF:GRAPHICSOBJECT DSPOP:ATOM) (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS) )) % The LispTree and PreorderSearchRecord objects illustrate how generators % can be written. (GLISPOBJECTS % In defining a LispTree, which can actually be of multiple types (atom or % dotted pair), we define it as the more complex dotted-pair type and take % care of the simpler case in the PROPerty definitions. (LISPTREE (CONS (CAR LISPTREE) % Defines a LispTree structure as the CONS (CDR LISPTREE)) % of two fields named CAR and CDR. PROP ((LEFTSON ((IF SELF IS ATOMIC THEN NIL ELSE CAR))) (RIGHTSON ((IF SELF IS ATOMIC THEN NIL ELSE CDR)))) ADJ ((EMPTY (~SELF))) ) % PreorderSearchRecord is defined to be a generator. Its data structure holds % the current node and a stack of previous nodes, and its NEXT message is % defined as code to step through the preorder search. (PREORDERSEARCHRECORD (CONS (NODE LISPTREE) (PREVIOUSNODES (LISTOF LISPTREE))) MSG ((NEXT ((PROG (TMP) (IF TMP_NODE:LEFTSON THEN (IF NODE:RIGHTSON THEN PREVIOUSNODES+_NODE) NODE_TMP ELSE TMP-_PREVIOUSNODES NODE_TMP:RIGHTSON))))) ) ) % PRINTLEAVES prints the leaves of the tree, using a PreorderSearchRecord % as the generator for searching the tree. (DG PRINTLEAVES (:LISPTREE) (PROG (PSR) (PSR _(A PREORDERSEARCHRECORD WITH NODE =(THE LISPTREE))) (WHILE NODE (IF NODE IS ATOMIC (PRINT NODE)) (SEND PSR NEXT)))) % The Circle objects illustrate the definition of a number of mathematical % properties of an object in terms of stored data and other properties. (Glispobjects (CIRCLE (LIST (START VECTOR) (RADIUS REAL)) PROP ((PI (3.1415926)) % A PROPerty can be a constant. (DIAMETER (RADIUS*2)) (CIRCUMFERENCE (PI*DIAMETER)) % Defined in terms of other prop. (AREA (PI*RADIUS^2)) ) ADJ ((BIG (AREA>120)) % BIG defined in terms of AREA (MEDIUM (AREA >= 60 AND AREA <= 120)) (SMALL (AREA<60))) MSG ((STANDARD (AREA_100)) % "Storing into" computed property (GROW (AREA_+100)) (SHRINK (AREA_AREA/2)) ) ) % A DCIRCLE is implemented differently from a circle. % The data structure is different, and DIAMETER is stored instead of RADIUS. % By defining RADIUS as a PROPerty, all of the CIRCLE properties defined % in terms of radius can be inherited. (DCIRCLE (LISTOBJECT (START VECTOR) (DIAMETER REAL)) PROP ((RADIUS (DIAMETER/2))) SUPERS (CIRCLE) ) ) % Make a DCIRCLE for testing (setq dc (a dcircle with diameter = 10.0)) % Since DCIRCLE is an Object type, it can be used with interpreted messages, % e.g., (send dc area) to get the area property, % (send dc standard) to set the area to the standard value, % (send dc diameter) to get the stored diameter value. % EXAMPLE OF ASSIGNMENT TO COMPUTED PROPERTY (DG GROWCIRCLE (C:CIRCLE) (C:AREA_+100) (PRINT RADIUS) ) (SETQ MYCIRCLE (A CIRCLE)) % Since SQRT is not defined in the bare-PSL system, we redefine it here. (DG SQRT (X) (PROG (S) (S_X) (IF X < 0 THEN (ERROR) ELSE (WHILE (ABS S*S - X) > 0.000001 DO (S _ (S+X/S) * 0.5))) (RETURN S))) % Function SQUASH illustrates elimination of compile-time constants. % Of course, nobody would write such a function directly. However, such forms % can arise when inherited properties are compiled. Conditional compilation % occurs automatically when appropriate variables are defined to the GLISP % compiler as compile-time constants because the post-optimization phase of % the compiler makes the unwanted code disappear. (DG SQUASH () (IF 1>3 THEN 'AMAZING ELSEIF 6<2 THEN 'INCREDIBLE ELSEIF 2 + 2 = 4 THEN 'OKAY ELSE 'JEEZ)) % The following object definitions describe a student records database. (glispobjects (student (atom (proplist (name string) (sex atom) (major atom) (grades (listof integer)))) prop ((average student-average) (grade-average student-grade-average)) adj ((male (sex='male)) (female (sex='female)) (winning (average>=95)) (losing (average<60))) isa ((winner (self is winning)))) (student-group (listof student) prop ((n-students length) % This property is implemented by % the Lisp function LENGTH. (Average Student-group-average))) (class (atom (proplist (department atom) (number integer) (instructor string) (students student-group))) prop ((n-students (students:n-students)) (men ((those students who are male))) (women ((those students who are female))) (winners ((those students who are winning))) (losers ((those students who are losing))) (class-average (students:average)))) ) (dg student-average (s:student) (prog ((sum 0.0)(n 0.0)) (for g in grades do n _+ 1.0 sum_+g) (return sum/n) )) (dg student-grade-average (s:student) (prog ((av s:average)) (return (if av >= 90.0 then 'a elseif av >= 80.0 then 'b elseif av >= 70.0 then 'c elseif av >= 60.0 then 'd else 'f)))) (dg student-group-average (sg:student-group) (prog ((sum 0.0)) (for s in sg do sum_+s:average) (return sum/sg:n-students) )) % Print name and grade average for each student (dg test1 (c:class) (for s in c:students (prin1 s:name) (prin2 '! ) (print s:grade-average))) % Another version of the above function (dg test1b (:class) (for each student (prin1 name) (prin2 '! ) (print grade-average))) % Print name and average of the winners in the class (dg test2 (c:class) (for s in c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % The average of all the male students' grades (dg test3 (c:class) c:men:average) % The name and average of the winning women (dg test4 (c:class) (for s in c:women when s is winning (prin1 s:name) (prin2 '! ) (print s:average))) % Another version of the above function. The * operator in this case % denotes the intersection of the sets of women and winners. The % GLISP compiler optimizes the code so that these intermediate sets are % not actually constructed. (dg test5 (c:class) (for s in c:women*c:winners (prin1 s:name) (prin2 '! ) (print s:average))) % Make a list of the easy professors. (dg easy-profs (classes:(listof class)) (for each class with class-average > 90.0 collect (the instructor))) % A more Pascal-like version of easy-profs: (dg easy-profs-b (classes:(listof class)) (for c in classes when c:class-average > 90.0 collect c:instructor)) % Some test data for testing the above functions. (setq class1 (a class with instructor = "G. Novak" department = 'cs number = 102 students = (list (a student with name = "John Doe" sex = 'male major = 'cs grades = '(99 98 97 93)) (a student with name = "Fred Failure" sex = 'male major = 'cs grades = '(52 54 43 27)) (a student with name = "Mary Star" sex = 'female major = 'cs grades = '(100 100 99 98)) (a student with name = "Doris Dummy" sex = 'female major = 'cs grades = '(73 52 46 28)) (a student with name = "Jane Average" sex = 'female major = 'cs grades = '(75 82 87 78)) (a student with name = "Lois Lane" sex = 'female major = 'cs grades = '(98 95 97 96)) ))) % The following object definitions illustrate inheritance of properties % from multiple parent classes. The three "bottom" classes Planet, Brick, % and Bowling-Ball all inherit the same definition of the property Density, % although they are represented in very different ways. (glispobjects (physical-object anything prop ((density (mass/volume)))) (ordinary-object anything prop ((mass (weight / 9.88))) % Compute mass as weight/gravity supers (physical-object)) (sphere anything prop ((volume ((4.0 / 3.0) * 3.1415926 * radius ^ 3)))) (parallelepiped anything prop ((volume (length*width*height)))) (planet (listobject (mass real)(radius real)) supers (physical-object sphere)) % A planet is a physical-object % and a sphere. (brick (object (length real)(width real)(height real)(weight real)) supers (ordinary-object parallelepiped)) (bowling-ball (atomobject (type atom)(weight real)) prop ((radius ((if type='adult then 0.1 else 0.07)))) supers (ordinary-object sphere)) ) % Three test functions to demonstrate inheritance of the Density property. (dg dplanet (p:planet) density) (dg dbrick (b:brick) density) (dg dbb (b:bowling-ball) density) % Some objects to test the functions on. (setq earth (a planet with mass = 5.98e24 radius = 6.37e6)) (setq brick1 (a brick with weight = 20.0 width = 0.10 height = 0.05 length = 0.20)) (setq bb1 (a bowling-ball with type = 'adult weight = 60.0)) % Since the object types Planet, Brick, and Bowling-Ball are defined as % Object types (i.e., they contain the Class name as part of their stored % data), messages can be sent to them directly from the keyboard for % interactive examination of the objects. For example, the following % messages could be used: % (send earth density) % (send brick1 weight: 25.0) % (send brick1 mass: 2.0) % (send bb1 radius) % (send bb1 type: 'child) |
Added psl-1983/glisp/permute.old version [24a628abab].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED " 2-JAN-83 14:20:01" {DSK}PERMUTE.LSP;4 9267 changes to: (FNS HISTO-CREATE HISTO-PEAKS HISTO-ADD) (VARS PERMUTECOMS) previous date: "28-DEC-82 11:32:40" {DSK}PERMUTE.LSP;1) (PRETTYCOMPRINT PERMUTECOMS) (RPAQQ PERMUTECOMS ((GLISPOBJECTS HISTOGRAM PERMUTATION) (VARS PERM3S FOLD3S PERM4S FOLD4S) (FNS ALLPERMS BINLIST BITSHUFFLE COMPOSEBITSHUFFLES DOBITSHUFFLE GENPERMS HISTO-ADD HISTO-CREATE HISTO-PEAKS IDPERM LISTOFC LOG2 NEGINPPERM OUTPERMS PERM-INVERSE) (PROP GLRESULTTYPE BITSHUFFLE DOBITSHUFFLE))) [GLISPOBJECTS (HISTOGRAM (LISTOBJECT (MIN INTEGER) (MAX INTEGER) (TOTAL INTEGER) (COUNTS (LISTOF INTEGER))) PROP ((PEAKS HISTO-PEAKS)) MSG ((CREATE HISTO-CREATE) (+ HISTO-ADD)) ) (PERMUTATION (LISTOF INTEGER) PROP ((LENGTH LENGTH) (INVERSE PERM-INVERSE RESULT PERMUTATION)) MSG ((* COMPOSEBITSHUFFLES RESULT PERMUTATION)) ) ] (RPAQQ PERM3S ((7 3 5 1 6 2 4 0) (7 5 3 1 6 4 2 0) (7 3 6 2 5 1 4 0) (7 5 6 4 3 1 2 0) (7 6 3 2 5 4 1 0))) (RPAQQ FOLD3S ((3 2 1 0 7 6 5 4) (5 4 7 6 1 0 3 2) (6 7 4 5 2 3 0 1))) (RPAQQ PERM4S ((15 7 11 3 13 5 9 1 14 6 10 2 12 4 8 0) (15 11 7 3 13 9 5 1 14 10 6 2 12 8 4 0) (15 7 13 5 11 3 9 1 14 6 12 4 10 2 8 0) (15 11 13 9 7 3 5 1 14 10 12 8 6 2 4 0) (15 13 7 5 11 9 3 1 14 12 6 4 10 8 2 0) (15 13 11 9 7 5 3 1 14 12 10 8 6 4 2 0) (15 7 11 3 14 6 10 2 13 5 9 1 12 4 8 0) (15 11 7 3 14 10 6 2 13 9 5 1 12 8 4 0) (15 7 13 5 14 6 12 4 11 3 9 1 10 2 8 0) (15 11 13 9 14 10 12 8 7 3 5 1 6 2 4 0) (15 13 7 5 14 12 6 4 11 9 3 1 10 8 2 0) (15 13 11 9 14 12 10 8 7 5 3 1 6 4 2 0) (15 7 14 6 11 3 10 2 13 5 12 4 9 1 8 0) (15 11 14 10 7 3 6 2 13 9 12 8 5 1 4 0) (15 7 14 6 13 5 12 4 11 3 10 2 9 1 8 0) (15 11 14 10 13 9 12 8 7 3 6 2 5 1 4 0) (15 13 14 12 7 5 6 4 11 9 10 8 3 1 2 0) (15 13 14 12 11 9 10 8 7 5 6 4 3 1 2 0) (15 14 7 6 11 10 3 2 13 12 5 4 9 8 1 0) (15 14 11 10 7 6 3 2 13 12 9 8 5 4 1 0) (15 14 7 6 13 12 5 4 11 10 3 2 9 8 1 0) (15 14 11 10 13 12 9 8 7 6 3 2 5 4 1 0) (15 14 13 12 7 6 5 4 11 10 9 8 3 2 1 0))) (RPAQQ FOLD4S ((7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) (11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) (13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) (14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1))) (DEFINEQ (ALLPERMS (GLAMBDA (N:INTEGER) (* edited: "27-DEC-82 15:36") (* Generate a list of all permutations of length N. The identity permutation is always the first member of the list.) (RESULT (LISTOF PERMUTATION)) (DECLARE (SPECVARS LST)) (PROG (LST) (IF N>5 (ERROR "TOO MANY PERMUTATIONS!")) (GENPERMS NIL (IDPERM N)) (RETURN LST)))) (BINLIST (GLAMBDA (N,NBITS:INTEGER) (* edited: "28-DEC-82 11:26") (* Convert N to a list of bit values.) (RESULT (LISTOF INTEGER)) (PROG (L I BIT) (I_0) (BIT_1) (WHILE I<NBITS DO (L+_(IF (LOGAND N BIT)=0 THEN 0 ELSE 1)) (I_+1) (BIT_+BIT)) (RETURN L)))) (BITSHUFFLE [LAMBDA (INPUT LST) (* edited: " 6-MAY-82 16:33") (* Compute a bit-shuffle of the input according to the specification list LST. LST gives, for each output bit in order, the input bit from which it comes.) (PROG (RES) (SETQ RES 0) [MAPC LST (FUNCTION (LAMBDA (X) (SETQ RES (IPLUS (IPLUS RES RES) (COND ((NULL X) 0) ((NOT (NUMBERP X)) 1) ((ZEROP (LOGAND INPUT (BITPICK X))) 0) (T 1] (RETURN RES]) (COMPOSEBITSHUFFLES [LAMBDA (FIRST SECOND) (* edited: "23-JUN-82 15:17") (* Compose two bitshuffles to produce a single bitshuffle which is equivalent.) (PROG (L) (COND ((NOT (EQUAL (SETQ L (LENGTH FIRST)) (LENGTH SECOND))) (ERROR))) (RETURN (MAPCAR SECOND (FUNCTION (LAMBDA (X) (COND [(FIXP X) (CAR (NTH FIRST (IDIFFERENCE L X] (T X]) (DOBITSHUFFLE [LAMBDA (INT PERM) (* edited: "27-DEC-82 15:44") (BITSHUFFLE INT PERM]) (GENPERMS [GLAMBDA (PREV,L:(LISTOF INTEGER)) (* edited: "27-DEC-82 15:38") (* Generate all permutations consisting of the list PREV followed by all permutations of the list L. The permutations which are generated are added to the global LST. Called by ALLPERMS.) (GLOBAL LST:(LISTOF PERMUTATION)) (PROG (I TMP N) (IF ~L THEN LST+_PREV (RETURN)) (N_(LENGTH L)) (I_0) (WHILE (I_+1) <=N DO (TMP_(CAR (NTH L I))) (GENPERMS (PREV+TMP) (L - TMP]) (HISTO-ADD (GLAMBDA (H:HISTOGRAM N:INTEGER) (* edited: "30-DEC-82 13:26") (IF N>MAX OR N<MIN THEN (ERROR) ELSE TOTAL_+1 (CAR (NTH COUNTS (N - MIN + 1)))_+1) H)) (HISTO-CREATE (GLAMBDA (H:HISTOGRAM) (* edited: " 2-JAN-83 14:14") (RESULT HISTOGRAM) (* Initialize a histogram.) (TOTAL_0) (COUNTS_(LISTOFC 0 (MAX - MIN + 1))) H)) (HISTO-PEAKS [GLAMBDA (H:HISTOGRAM) (* edited: " 2-JAN-83 14:10") (PROG (THRESH L MX N) (MX_0) (FOR X IN COUNTS (IF X>MX MX_X)) (THRESH_MX/2) (N_MIN) (FOR X IN COUNTS DO (IF X>=THRESH L+_N) N_+1) (RETURN (DREVERSE L]) (IDPERM (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:23") (* Produce an identity permutation of length N.) (RESULT PERMUTATION) (PROG (L (I 0)) (WHILE I<N L+_I I_+1) (RETURN L)))) (LISTOFC (GLAMBDA (C N:INTEGER) (* edited: "28-DEC-82 11:23") (* Make a list of N copies of the constant C.) (RESULT (LISTOF ATOM)) (PROG (I L) (I_0) (WHILE (I_+1) <=N DO L+_C) (RETURN L)))) (LOG2 (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:07") (* Log to the base 2 of an integer, rounded up.) (RESULT INTEGER) (PROG ((I 0) (M 1)) (WHILE M<N DO I_+1 M_+M) (RETURN I)))) (NEGINPPERM (GLAMBDA (N,M:INTEGER) (* edited: "28-DEC-82 11:03") (* Compute the permutation to be applied to the output of a boolean function of N inputs to account for negating the Mth input.) (RESULT PERMUTATION) (PROG (TWON TWOM (I 0) L) (TWON_2^N) (TWOM_2^M) (WHILE I<TWON L+_(IF (LOGAND I TWOM) ~=0 THEN I - TWOM ELSE I+TWOM) I_+1) (RETURN L)))) (OUTPERMS (GLAMBDA (N:INTEGER) (* edited: "28-DEC-82 11:02") (* Create the set of permutations of the set of 2^N outputs corresponding to isomorphisms, i.e., renamings of the N inputs of a boolean function. The identity isomorphism is omitted.) (RESULT (LISTOF PERMUTATION)) (PROG (I TMP RES TWON) (TWON_2^N) (FOR X IN (CDR (ALLPERMS N)) DO (I_0) (TMP_NIL) (WHILE I<TWON DO (TMP+_(DOBITSHUFFLE I X)) (I_+1)) (RES+_TMP)) (RETURN RES)))) (PERM-INVERSE (GLAMBDA (P:PERMUTATION) (* edited: " 2-SEP-82 10:47") (RESULT PERMUTATION) (* edited: " 2-SEP-82 10:44") (* Compute the inverse of a permutation.) (PROG (LST N M (I 0) J PP TMP) (N_P:LENGTH) (WHILE I<N DO (J _ N - 1) (PP_P) [WHILE PP DO (IF (CAR PP)=I THEN LST+_J PP_NIL ELSE TMP-_PP J_-1 (IF ~PP (ERROR] (I_+1)) (RETURN LST)))) ) (PUTPROPS BITSHUFFLE GLRESULTTYPE INTEGER) (PUTPROPS DOBITSHUFFLE GLRESULTTYPE INTEGER) (DECLARE: DONTCOPY (FILEMAP (NIL (2528 9147 (ALLPERMS 2538 . 3071) (BINLIST 3073 . 3528) (BITSHUFFLE 3530 . 4122) ( COMPOSEBITSHUFFLES 4124 . 4654) (DOBITSHUFFLE 4656 . 4799) (GENPERMS 4801 . 5395) (HISTO-ADD 5397 . 5635) (HISTO-CREATE 5637 . 5902) (HISTO-PEAKS 5904 . 6268) (IDPERM 6270 . 6598) (LISTOFC 6600 . 6950) (LOG2 6952 . 7296) (NEGINPPERM 7298 . 7897) (OUTPERMS 7899 . 8504) (PERM-INVERSE 8506 . 9145))))) STOP |
Added psl-1983/glisp/permute.sl version [d2e84a5a6b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}PERMUTE.PSL;1 5-FEB-83 15:53:01 (GLISPOBJECTS (HISTOGRAM (LISTOBJECT (MIN INTEGER) (MAX INTEGER) (TOTAL INTEGER) (COUNTS (LISTOF INTEGER))) PROP ((PEAKS HISTO-PEAKS)) MSG ((CREATE HISTO-CREATE) (+ HISTO-ADD))) (PERMUTATION (LISTOF INTEGER) PROP ((LENGTH LENGTH) (INVERSE PERM-INVERSE RESULT PERMUTATION)) MSG ((* COMPOSEBITSHUFFLES RESULT PERMUTATION))) ) (SETQ PERM3S '((7 3 5 1 6 2 4 0) (7 5 3 1 6 4 2 0) (7 3 6 2 5 1 4 0) (7 5 6 4 3 1 2 0) (7 6 3 2 5 4 1 0))) (SETQ FOLD3S '((3 2 1 0 7 6 5 4) (5 4 7 6 1 0 3 2) (6 7 4 5 2 3 0 1))) (SETQ PERM4S '((15 7 11 3 13 5 9 1 14 6 10 2 12 4 8 0) (15 11 7 3 13 9 5 1 14 10 6 2 12 8 4 0) (15 7 13 5 11 3 9 1 14 6 12 4 10 2 8 0) (15 11 13 9 7 3 5 1 14 10 12 8 6 2 4 0) (15 13 7 5 11 9 3 1 14 12 6 4 10 8 2 0) (15 13 11 9 7 5 3 1 14 12 10 8 6 4 2 0) (15 7 11 3 14 6 10 2 13 5 9 1 12 4 8 0) (15 11 7 3 14 10 6 2 13 9 5 1 12 8 4 0) (15 7 13 5 14 6 12 4 11 3 9 1 10 2 8 0) (15 11 13 9 14 10 12 8 7 3 5 1 6 2 4 0) (15 13 7 5 14 12 6 4 11 9 3 1 10 8 2 0) (15 13 11 9 14 12 10 8 7 5 3 1 6 4 2 0) (15 7 14 6 11 3 10 2 13 5 12 4 9 1 8 0) (15 11 14 10 7 3 6 2 13 9 12 8 5 1 4 0) (15 7 14 6 13 5 12 4 11 3 10 2 9 1 8 0) (15 11 14 10 13 9 12 8 7 3 6 2 5 1 4 0) (15 13 14 12 7 5 6 4 11 9 10 8 3 1 2 0) (15 13 14 12 11 9 10 8 7 5 6 4 3 1 2 0) (15 14 7 6 11 10 3 2 13 12 5 4 9 8 1 0) (15 14 11 10 7 6 3 2 13 12 9 8 5 4 1 0) (15 14 7 6 13 12 5 4 11 10 3 2 9 8 1 0) (15 14 11 10 13 12 9 8 7 6 3 2 5 4 1 0) (15 14 13 12 7 6 5 4 11 10 9 8 3 2 1 0))) (SETQ FOLD4S '((7 6 5 4 3 2 1 0 15 14 13 12 11 10 9 8) (11 10 9 8 15 14 13 12 3 2 1 0 7 6 5 4) (13 12 15 14 9 8 11 10 5 4 7 6 1 0 3 2) (14 15 12 13 10 11 8 9 6 7 4 5 2 3 0 1))) % edited: 27-DEC-82 15:36 % Generate a list of all permutations of length N. The identity % permutation is always the first member of the list. (DG ALLPERMS (N:INTEGER) (RESULT (LISTOF PERMUTATION)) % (SPECVARS LST) (PROG (LST) (IF N>5 (ERROR 0 "TOO MANY PERMUTATIONS!")) (GENPERMS NIL (IDPERM N)) (RETURN LST))) % edited: 28-DEC-82 11:26 % Convert N to a list of bit values. (DG BINLIST (N,NBITS:INTEGER) (RESULT (LISTOF INTEGER))(PROG (L I BIT) (I_0) (BIT_1) (WHILE I<NBITS DO (L+_ (IF (LOGAND N BIT) =0 THEN 0 ELSE 1)) (I_+1) (BIT_+BIT)) (RETURN L))) % edited: 6-MAY-82 16:33 % Compute a bit-shuffle of the input according to the specification % list LST. LST gives, for each output bit in order, the input bit % from which it comes. (DE BITSHUFFLE (INPUT LST) (PROG (RES) (SETQ RES 0) (MAPC LST (FUNCTION (LAMBDA (X) (SETQ RES (PLUS (PLUS RES RES) (COND ((NULL X) 0) ((NOT (NUMBERP X)) 1) ((ZEROP (LOGAND INPUT (BITPICK X))) 0) (T 1))))))) (RETURN RES))) % edited: 23-JUN-82 15:17 % Compose two bitshuffles to produce a single bitshuffle which is % equivalent. (DE COMPOSEBITSHUFFLES (FIRST SECOND) (PROG (L) (COND ((NOT (EQUAL (SETQ L (LENGTH FIRST)) (LENGTH SECOND))) (ERROR 0 NIL))) (RETURN (MAPCAR SECOND (FUNCTION (LAMBDA (X) (COND ((FIXP X) (CAR (PNth FIRST (DIFFERENCE L X)))) (T X)))))))) % edited: 27-DEC-82 15:44 (DE DOBITSHUFFLE (INT PERM) (BITSHUFFLE INT PERM)) % edited: 27-DEC-82 15:38 % Generate all permutations consisting of the list PREV followed by % all permutations of the list L. The permutations which are % generated are added to the global LST. Called by ALLPERMS. (DG GENPERMS (PREV,L: (LISTOF INTEGER)) (GLOBAL LST: (LISTOF PERMUTATION))(PROG (I TMP N) (IF ~L THEN LST+_PREV (RETURN NIL)) (N_ (LENGTH L)) (I_0) (WHILE (I_+1) <=N DO (TMP_ (CAR (PNth L I))) (GENPERMS (PREV+TMP) (L - TMP))))) % edited: 30-DEC-82 13:26 (DG HISTO-ADD (H:HISTOGRAM N:INTEGER) (IF N>MAX OR N<MIN THEN (ERROR 0 NIL) ELSE TOTAL_+1 (CAR (PNth COUNTS (N - MIN + 1))) _+1)H) % edited: 2-JAN-83 14:14 (DG HISTO-CREATE (H:HISTOGRAM) (RESULT HISTOGRAM)% Initialize a histogram. (TOTAL_0)(COUNTS_ (LISTOFC 0 (MAX - MIN + 1)))H) % edited: 2-JAN-83 14:10 (DG HISTO-PEAKS (H:HISTOGRAM) (PROG (THRESH L MX N) (MX_0) (FOR X IN COUNTS (IF X>MX MX_X)) (THRESH_MX/2) (N_MIN) (FOR X IN COUNTS DO (IF X>=THRESH L+_N) N_+1) (RETURN (REVERSIP L)))) % edited: 28-DEC-82 11:23 % Produce an identity permutation of length N. (DG IDPERM (N:INTEGER) (RESULT PERMUTATION)(PROG (L I) (SETQ I 0) (WHILE I<N L+_I I_+1) (RETURN L))) % edited: 28-DEC-82 11:23 % Make a list of N copies of the constant C. (DG LISTOFC (C N:INTEGER) (RESULT (LISTOF ATOM))(PROG (I L) (I_0) (WHILE (I_+1) <=N DO L+_C) (RETURN L))) % edited: 28-DEC-82 11:07 % Log to the base 2 of an integer, rounded up. (DG LOG2 (N:INTEGER) (RESULT INTEGER)(PROG (I M) (SETQ I 0) (SETQ M 1) (WHILE M<N DO I_+1 M_+M) (RETURN I))) % edited: 28-DEC-82 11:03 % Compute the permutation to be applied to the output of a boolean % function of N inputs to account for negating the Mth input. (DG NEGINPPERM (N,M:INTEGER) (RESULT PERMUTATION)(PROG (TWON TWOM I L) (SETQ I 0) (TWON_2^N) (TWOM_2^M) (WHILE I<TWON L+_ (IF (LOGAND I TWOM) ~=0 THEN I - TWOM ELSE I+TWOM) I_+1) (RETURN L))) % edited: 28-DEC-82 11:02 % Create the set of permutations of the set of 2^N outputs % corresponding to isomorphisms, i.e., renamings of the N inputs of % a boolean function. The identity isomorphism is omitted. (DG OUTPERMS (N:INTEGER) (RESULT (LISTOF PERMUTATION))(PROG (I TMP RES TWON) (TWON_2^N) (FOR X IN (CDR (ALLPERMS N)) DO (I_0) (TMP_NIL) (WHILE I<TWON DO (TMP+_ (DOBITSHUFFLE I X)) (I_+1)) (RES+_TMP)) (RETURN RES))) % edited: 2-SEP-82 10:47 (DG PERM-INVERSE (P:PERMUTATION) (RESULT PERMUTATION)% edited: 2-SEP-82 10:44 % Compute the inverse of a permutation. (PROG (LST N M I J PP TMP) (SETQ I 0) (N_P:LENGTH) (WHILE I<N DO (J _ N - 1) (PP_P) (WHILE PP DO (IF (CAR PP) =I THEN LST+_J PP_NIL ELSE TMP-_PP J_-1 (IF ~PP (ERROR 0 NIL)))) (I_+1)) (RETURN LST))) (PUT 'BITSHUFFLE 'GLRESULTTYPE 'INTEGER) (PUT 'DOBITSHUFFLE 'GLRESULTTYPE 'INTEGER) |
Added psl-1983/glisp/tlg.sl version [fb43fae755].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % TLG.SL.3 31 Jan. 83 G. Novak % Program to test speed of line graphics by filling a square with lines. (de TLG (WINDOW) (PROG (XMIN XMAX DELTA XA XB) (SETQ XMIN 100) (SETQ XMAX 500) (SETQ XA XMIN) (SETQ XB XMAX) (SETQ DELTA 4) LP (COND ((IGREATERP XA XMAX) (RETURN))) (DRAWLINE XA XMIN XB XMAX 1 (QUOTE PAINT) WINDOW) (DRAWLINE XMIN XA XMAX XB 1 (QUOTE PAINT) WINDOW) (SETQ XA (IPLUS XA DELTA)) (SETQ XB (IDIFFERENCE XB DELTA)) (GO LP))) |
Added psl-1983/glisp/vector.old version [a469e8ec82].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED "23-JAN-83 16:33:50" {DSK}VECTOR.LSP;9 7836 changes to: (FNS VECTORMOVE) previous date: "14-JAN-83 12:45:52" {DSK}VECTOR.LSP;8) (PRETTYCOMPRINT VECTORCOMS) (RPAQQ VECTORCOMS ((GLISPOBJECTS DEGREES DOLPHINREGION GRAPHICSOBJECT RADIANS REGION RVECTOR SYMMETRY VECTOR) (FNS DRAWRECT GRAPHICSOBJECTMOVE NEWSTART NEWPOINT REGION-CONTAINS REGION-INTERSECT REGION-SETPOSITION REGION-UNION VECTORPLUS VECTORDIFF VECTORGREATERP VECTORLEQP VECTORTIMES VECTORQUOTIENT VECTORMOVE) (PROP DRAWFN RECTANGLE))) [GLISPOBJECTS (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T))) ) (DOLPHINREGION (LIST (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER)) PROP ((START (self) RESULT VECTOR) (SIZE CDDR RESULT VECTOR)) SUPERS (REGION) ) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ([DRAW ((APPLY* (GETPROP SHAPE 'DRAWFN) self (QUOTE PAINT] [ERASE ((APPLY* (GETPROP SHAPE 'DRAWFN) self (QUOTE ERASE] (MOVE GRAPHICSOBJECTMOVE OPEN T)) ) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T))) ) (REGION (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (TOPCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = TOP))) (BOTTOMCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = BOTTOM))) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T) (SETPOSITION REGION-SETPOSITION OPEN T)) ) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR) ) (SYMMETRY INTEGER PROP ((SWAPXY ((LOGAND self 4) <>0)) (INVERTY ((LOGAND self 2) <>0)) (INVERTX ((LOGAND self 1) <>0))) ) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP [(MAGNITUDE ((SQRT X^2 + Y^2))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y= Y/MAGNITUDE] ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG [(+ VECTORPLUS OPEN T) (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T) (/ VECTORQUOTIENT OPEN T) (> VECTORGREATERP OPEN T) (<= VECTORLEQP OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI] ) ] (DEFINEQ (DRAWRECT (GLAMBDA ((A GRAPHICSOBJECT) DSPOP:ATOM) (* edited: "11-JAN-82 12:40") (PROG (OLDDS) (OLDDS _(CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS)))) (GRAPHICSOBJECTMOVE (GLAMBDA (self:GRAPHICSOBJECT DELTA:VECTOR) (* edited: "11-JAN-82 16:07") (_ self ERASE) (START _+ DELTA) (_ self DRAW))) (NEWSTART [GLAMBDA (START:VECTOR SIZE:VECTOR SYM:SYMMETRY) (* edited: " 1-JAN-83 15:13") (* Transform the starting point of an object as appropriate for the specified symmetry transform.) (PROG (W H TMP) (W_SIZE:X) (H_SIZE:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H_0) (IF ~SYM:INVERTX THEN W_0) (RETURN (A VECTOR WITH X = START:X+W Y = START:Y+H]) (NEWPOINT [GLAMBDA (START:VECTOR POINT:VECTOR SYM:SYMMETRY) (* edited: " 1-JAN-83 15:12") (* Transform a given relative POINT for specified symmetry transform.) (PROG (W H TMP) (W_POINT:X) (H_POINT:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H _ - H) (IF ~SYM:INVERTX THEN W _ - W) (RETURN (A VECTOR WITH X = START:X+W Y = START:Y+H]) (REGION-CONTAINS (GLAMBDA (AREA P) (* edited: "26-OCT-82 11:45") (* Test whether an area contains a point P.) (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP))) (REGION-INTERSECT (GLAMBDA (P,Q:AREA) (* edited: "23-SEP-82 10:44") (RESULT AREA) (* Produce an AREA which is the intersection of two given AREAs.) (PROG (NEWBOTTOM NEWLEFT NEWAREA XSIZE YSIZE) (NEWBOTTOM _(IMAX P:BOTTOM Q:BOTTOM)) (YSIZE _(IMIN P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _(IMAX P:LEFT Q:LEFT)) (XSIZE _(IMIN P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _(AN AREA)) (IF XSIZE>0 AND YSIZE>0 THEN NEWAREA:LEFT_NEWLEFT NEWAREA:BOTTOM_NEWBOTTOM NEWAREA:WIDTH_XSIZE NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA)))) (REGION-SETPOSITION (GLAMBDA (AREA APOS:VECTOR NEWPOS:VECTOR) (* GSN "14-JAN-83 11:52") (* Change the START point of AREA so that the position APOS relative to the area will have the position NEWPOS.) (AREA:START _+ NEWPOS - APOS))) (REGION-UNION (GLAMBDA (P,Q:AREA) (* edited: "23-SEP-82 11:15") (RESULT AREA) (* Produce an AREA which is the union of two given AREAs.) (PROG (NEWBOTTOM NEWLEFT XSIZE YSIZE NEWAREA) (NEWBOTTOM _(IMIN P:BOTTOM Q:BOTTOM)) (YSIZE _(IMAX P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _(IMIN P:LEFT Q:LEFT)) (XSIZE _(IMAX P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _(AN AREA)) (NEWAREA:LEFT_NEWLEFT) (NEWAREA:BOTTOM_NEWBOTTOM) (NEWAREA:WIDTH_XSIZE) (NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA)))) (VECTORPLUS (GLAMBDA (V1,V2:VECTOR) (A VECTOR WITH X = V1:X + V2:X , Y = V1:Y + V2:Y))) (VECTORDIFF (GLAMBDA (V1,V2:VECTOR) (A VECTOR WITH X = V1:X - V2:X , Y = V1:Y - V2:Y))) (VECTORGREATERP (GLAMBDA (U:VECTOR V:VECTOR) (* GSN "14-JAN-83 12:33") (* This version of > tests whether one box will fit inside the other.) (U:X>V:X OR U:Y>V:Y))) (VECTORLEQP (GLAMBDA (U:VECTOR V:VECTOR) (* GSN "14-JAN-83 12:31") (U:X<=V:X AND U:Y<=V:Y))) (VECTORTIMES (GLAMBDA (V:VECTOR N:NUMBER) (A VECTOR WITH X = X*N , Y = Y*N))) (VECTORQUOTIENT (GLAMBDA (V:VECTOR N:NUMBER) (A VECTOR WITH X = X/N , Y = Y/N))) (VECTORMOVE (GLAMBDA (V,DELTA:VECTOR) (* GSN "23-JAN-83 16:28") (V:X _+ DELTA:X) (V:Y _+ DELTA:Y) V)) ) (PUTPROPS RECTANGLE DRAWFN DRAWRECT) (DECLARE: DONTCOPY (FILEMAP (NIL (2907 7772 (DRAWRECT 2917 . 3338) (GRAPHICSOBJECTMOVE 3340 . 3522) (NEWSTART 3524 . 4114 ) (NEWPOINT 4116 . 4688) (REGION-CONTAINS 4690 . 5005) (REGION-INTERSECT 5007 . 5734) ( REGION-SETPOSITION 5736 . 6107) (REGION-UNION 6109 . 6799) (VECTORPLUS 6801 . 6898) (VECTORDIFF 6900 . 6997) (VECTORGREATERP 6999 . 7289) (VECTORLEQP 7291 . 7427) (VECTORTIMES 7429 . 7516) ( VECTORQUOTIENT 7518 . 7608) (VECTORMOVE 7610 . 7770))))) STOP |
Added psl-1983/glisp/vector.sl version [847db88517].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % VECTOR.SL.3 28 Feb 83 % {DSK}VECTOR.PSL;1 5-FEB-83 15:48:43 (GLISPOBJECTS (DEGREES REAL PROP ((RADIANS (self* (3.1415926/180.0)) RESULT RADIANS) (DISPLAYPROPS (T)))) (DOLPHINREGION (LIST (LEFT INTEGER) (BOTTOM INTEGER) (WIDTH INTEGER) (HEIGHT INTEGER)) PROP ((START (self) RESULT VECTOR) (SIZE ((CDDR self)) RESULT VECTOR)) SUPERS (REGION)) (GRAPHICSOBJECT (LIST (SHAPE ATOM) (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (AREA (WIDTH*HEIGHT))) MSG ((DRAW ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'PAINT))) (ERASE ((APPLY* (GETPROP SHAPE 'DRAWFN) self 'ERASE))) (MOVE GRAPHICSOBJECTMOVE OPEN T))) (RADIANS REAL PROP ((DEGREES (self* (180.0/3.1415926)) RESULT DEGREES) (DISPLAYPROPS (T)))) (REGION (LIST (START VECTOR) (SIZE VECTOR)) PROP ((LEFT (START:X)) (BOTTOM (START:Y)) (RIGHT (LEFT+WIDTH)) (TOP (BOTTOM+HEIGHT)) (WIDTH (SIZE:X)) (HEIGHT (SIZE:Y)) (CENTER (START+SIZE/2)) (TOPCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = TOP))) (BOTTOMCENTER ((A VECTOR WITH X = LEFT+WIDTH/2 Y = BOTTOM))) (AREA (WIDTH*HEIGHT))) ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO)) (ZERO (self IS EMPTY))) MSG ((CONTAINS? REGION-CONTAINS OPEN T) (SETPOSITION REGION-SETPOSITION OPEN T) (CENTEROFFSET REGION-CENTEROFFSET OPEN T))) (RVECTOR (LIST (X REAL) (Y REAL)) SUPERS (VECTOR)) (SYMMETRY INTEGER PROP ((SWAPXY ((LOGAND self 4) <>0)) (INVERTY ((LOGAND self 2) <>0)) (INVERTX ((LOGAND self 1) <>0)))) (VECTOR (LIST (X INTEGER) (Y INTEGER)) PROP ((MAGNITUDE ((SQRT X^2 + Y^2))) (IMAGNITUDE ((FIX MAGNITUDE + .9999))) (ANGLE ((ARCTAN2 Y X T)) RESULT RADIANS) (UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y= Y/MAGNITUDE)))) ADJ ((ZERO (X IS ZERO AND Y IS ZERO)) (NORMALIZED (MAGNITUDE = 1.0))) MSG ((+ VECTORPLUS OPEN T) (- VECTORDIFF OPEN T) (* VECTORTIMES OPEN T) (/ VECTORQUOTIENT OPEN T) (> VECTORGREATERP OPEN T) (<= VECTORLEQP OPEN T) (_+ VECTORMOVE OPEN T) (PRIN1 ((PRIN1 "(") (PRIN1 X) (PRIN1 ",") (PRIN1 Y) (PRIN1 ")"))) (PRINT ((_ self PRIN1) (TERPRI))))) ) % edited: 11-JAN-82 12:40 (DG DRAWRECT ((A GRAPHICSOBJECT) DSPOP:ATOM) (PROG (OLDDS) (OLDDS _ (CURRENTDISPLAYSTREAM DSPS)) (DSPOPERATION DSPOP) (MOVETO LEFT BOTTOM) (DRAWTO LEFT TOP) (DRAWTO RIGHT TOP) (DRAWTO RIGHT BOTTOM) (DRAWTO LEFT BOTTOM) (CURRENTDISPLAYSTREAM OLDDS))) % edited: 11-JAN-82 16:07 (DG GRAPHICSOBJECTMOVE (self:GRAPHICSOBJECT DELTA:VECTOR) (_ self ERASE)(START _+ DELTA)(_ self DRAW)) % GSN 30-JAN-83 15:44 % Transform the starting point of an object as appropriate for the % specified symmetry transform. (DG NEWSTART (START:VECTOR SIZE:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_SIZE:X) (H_SIZE:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H_0) (IF ~SYM:INVERTX THEN W_0) (RETURN (A (TYPEOF START) WITH X = START:X+W Y = START:Y+H)))) % GSN 30-JAN-83 15:44 % Transform a given relative POINT for specified symmetry transform. (DG NEWPOINT (START:VECTOR POINT:VECTOR SYM:SYMMETRY) (PROG (W H TMP) (W_POINT:X) (H_POINT:Y) (IF SYM:SWAPXY THEN TMP_W W_H H_TMP) (IF ~SYM:INVERTY THEN H _ - H) (IF ~SYM:INVERTX THEN W _ - W) (RETURN (A (TYPEOF POINT) WITH X = START:X+W Y = START:Y+H)))) % GSN 2-FEB-83 14:00 (DG REGION-CENTEROFFSET (R:REGION V:VECTOR) (A (TYPEOF V) WITH X = (R:WIDTH - V:X) /2 Y = (R:HEIGHT - V:Y) /2)) % edited: 26-OCT-82 11:45 % Test whether an area contains a point P. (DG REGION-CONTAINS (AREA P) (P:X>=AREA:LEFT AND P:X<=AREA:RIGHT AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)) % GSN 30-JAN-83 15:45 (DG REGION-INTERSECT (P:AREA Q:AREA) (RESULT (TYPEOF P)) % Produce an AREA which is the intersection of two given AREAs. (PROG (NEWBOTTOM NEWLEFT NEWAREA XSIZE YSIZE) (NEWBOTTOM _ (IMAX P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMIN P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMAX P:LEFT Q:LEFT)) (XSIZE _ (IMIN P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (IF XSIZE>0 AND YSIZE>0 THEN NEWAREA:LEFT_NEWLEFT NEWAREA:BOTTOM_NEWBOTTOM NEWAREA:WIDTH_XSIZE NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 14-JAN-83 11:52 % Change the START point of AREA so that the position APOS relative to % the area will have the position NEWPOS. (DG REGION-SETPOSITION (AREA APOS:VECTOR NEWPOS:VECTOR) (AREA:START _+ NEWPOS - APOS)) % GSN 30-JAN-83 15:46 (DG REGION-UNION (P:AREA Q:AREA) (RESULT (TYPEOF P))% Produce an AREA which is the union of two given AREAs. (PROG (NEWBOTTOM NEWLEFT XSIZE YSIZE NEWAREA) (NEWBOTTOM _ (IMIN P:BOTTOM Q:BOTTOM)) (YSIZE _ (IMAX P:TOP Q:TOP) - NEWBOTTOM) (NEWLEFT _ (IMIN P:LEFT Q:LEFT)) (XSIZE _ (IMAX P:RIGHT Q:RIGHT) - NEWLEFT) (NEWAREA _ (A (TYPEOF P))) (NEWAREA:LEFT_NEWLEFT) (NEWAREA:BOTTOM_NEWBOTTOM) (NEWAREA:WIDTH_XSIZE) (NEWAREA:HEIGHT_YSIZE) (RETURN NEWAREA))) % GSN 30-JAN-83 15:36 (DG VECTORPLUS (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X + V2:X Y = V1:Y + V2:Y)) % GSN 30-JAN-83 15:47 (DG VECTORDIFF (V1:VECTOR V2:VECTOR) (A (TYPEOF V1) WITH X = V1:X - V2:X Y = V1:Y - V2:Y)) % GSN 14-JAN-83 12:33 % This version of > tests whether one box will fit inside the other. (DG VECTORGREATERP (U:VECTOR V:VECTOR) (U:X>V:X OR U:Y>V:Y)) % GSN 14-JAN-83 12:31 (DG VECTORLEQP (U:VECTOR V:VECTOR) (U:X<=V:X AND U:Y<=V:Y)) % GSN 30-JAN-83 15:47 (DG VECTORTIMES (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X*N Y = Y*N)) % GSN 30-JAN-83 15:47 (DG VECTORQUOTIENT (V:VECTOR N:NUMBER) (A (TYPEOF V) WITH X = X/N Y = Y/N)) % GSN 23-JAN-83 16:28 (DG VECTORMOVE (V:VECTOR DELTA:VECTOR) (V:X _+ DELTA:X)(V:Y _+ DELTA:Y)V) (PUT 'RECTANGLE 'DRAWFN 'DRAWRECT) |
Added psl-1983/glisp/window.old version [812258283d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (FILECREATED "13-JAN-83 16:31:59" {DSK}WINDOW.LSP;2 2220 changes to: (VARS WINDOWCOMS) (FNS WINDOW-DRAWLINE WINDOW-PRINTAT WINDOW-UNDRAWLINE WINDOW-UNPRINTAT WINDOW-MOVETO) previous date: "13-JAN-83 15:33:15" {DSK}WINDOW.LSP;1) (PRETTYCOMPRINT WINDOWCOMS) (RPAQQ WINDOWCOMS ((FNS WINDOW-DRAWLINE WINDOW-MOVETO WINDOW-PRINTAT WINDOW-UNDRAWLINE WINDOW-UNPRINTAT) (GLISPOBJECTS WINDOW))) (DEFINEQ (WINDOW-DRAWLINE (GLAMBDA (W:WINDOW FROM,TO:VECTOR) (* GSN "13-JAN-83 16:28") (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 (QUOTE PAINT) W))) (WINDOW-MOVETO (GLAMBDA (W:WINDOW POS:VECTOR) (* GSN "13-JAN-83 15:29") (MOVETO POS:X POS:Y W))) (WINDOW-PRINTAT (GLAMBDA (W:WINDOW S:STRING POS:VECTOR) (* GSN "13-JAN-83 16:25") (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION (QUOTE PAINT) W)) (PRIN1 S W) (DSPOPERATION LASTWOP W)))) (WINDOW-UNDRAWLINE (GLAMBDA (W:WINDOW FROM,TO:VECTOR) (* GSN "13-JAN-83 16:28") (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 (QUOTE ERASE) W))) (WINDOW-UNPRINTAT (GLAMBDA (W:WINDOW S:STRING POS:VECTOR) (* GSN "13-JAN-83 16:24") (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION (QUOTE ERASE) W)) (PRIN1 S W) (DSPOPERATION LASTWOP W)))) ) [GLISPOBJECTS (WINDOW ANYTHING PROP ((REGION ((DSPCLIPPINGREGION NIL self)) RESULT DOLPHINREGION) (XPOSITION ((DSPXPOSITION NIL self)) RESULT INTEGER) (YPOSITION ((DSPYPOSITION NIL self)) RESULT INTEGER) (HEIGHT (REGION:HEIGHT)) (WIDTH (REGION:WIDTH)) (LEFT ((DSPXOFFSET NIL self)) RESULT INTEGER) (BOTTOM ((DSPYOFFSET NIL self)) RESULT INTEGER)) MSG ((CLEAR CLEARW) (OPEN OPENW) (CLOSE CLOSEW) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T)) ) ] (DECLARE: DONTCOPY (FILEMAP (NIL (432 1520 (WINDOW-DRAWLINE 442 . 619) (WINDOW-MOVETO 621 . 759) (WINDOW-PRINTAT 761 . 1047) (WINDOW-UNDRAWLINE 1049 . 1228) (WINDOW-UNPRINTAT 1230 . 1518))))) STOP |
Added psl-1983/glisp/window.sl version [19941b3743].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WINDOW.SL 28 Feb 83 % {DSK}WINDOW.PSL;1 5-FEB-83 15:51:00 % GSN 2-FEB-83 13:57 (DG WINDOW-CENTEROFFSET (W:WINDOW V:VECTOR) (SEND W:REGION CENTEROFFSET V)) % GSN 13-JAN-83 16:28 (DG WINDOW-DRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 'PAINT W)) % GSN 13-JAN-83 15:29 (DG WINDOW-MOVETO (W:WINDOW POS:VECTOR) (MOVETO POS:X POS:Y W)) % GSN 13-JAN-83 16:25 (DG WINDOW-PRINTAT (W:WINDOW S:STRING POS:VECTOR) (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION 'PAINT W)) (PRIN1 S W) (DSPOPERATION LASTWOP W))) % GSN 13-JAN-83 16:28 (DG WINDOW-UNDRAWLINE (W:WINDOW FROM:VECTOR TO:VECTOR) (DRAWLINE FROM:X FROM:Y TO:X TO:Y 1 'ERASE W)) % GSN 13-JAN-83 16:24 (DG WINDOW-UNPRINTAT (W:WINDOW S:STRING POS:VECTOR) (PROG (LASTWOP) (SEND W MOVETO POS) (SETQ LASTWOP (DSPOPERATION 'ERASE W)) (PRIN1 S W) (DSPOPERATION LASTWOP W))) (GLISPOBJECTS (WINDOW ANYTHING PROP ((REGION ((DSPCLIPPINGREGION NIL self)) RESULT DOLPHINREGION) (XPOSITION ((DSPXPOSITION NIL self)) RESULT INTEGER) (YPOSITION ((DSPYPOSITION NIL self)) RESULT INTEGER) (HEIGHT (REGION:HEIGHT)) (WIDTH (REGION:WIDTH)) (LEFT ((DSPXOFFSET NIL self)) RESULT INTEGER) (BOTTOM ((DSPYOFFSET NIL self)) RESULT INTEGER) (START (REGION:START)) (SIZE (REGION:SIZE))) MSG ((CLEAR CLEARW) (OPEN OPENW) (CLOSE CLOSEW))) ) |
Added psl-1983/help/-notes.hlp version [9c63924d85].
> > | 1 2 | See PU:-FILES-NOTES.TXT for synopses of some of the packages not documented in the reference manual. |
Added psl-1983/help/apollo-plot.hlp version [3709c05ff2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | APOLLO Graphics Routines in PLISP JWP 12 June 1982 --------------------------------- /utah/com/plisp now has the ability to open a Window Pane in Graphics (Frame) mode; and have a 3 window dialogue with Text Input, Text Output (and the F8 and editing keys are Great!) and Graphics output. The graphics primitives are: (L_INITPLOT) % To split the 2 paned LISP window into 3 panes (L_ENDPLOT) % to return to 2 pane mode (L_ERASE) % to clear the graphics pane (L_MOVE x y) (L_DRAW x y) [0,0] is in upper left corner, range x=0..799, y=0..1023 roughly. The graphics pane is of course scrollable if you draw below visible edge. The get to RLISP mode, execute one of: (BEGIN) or (BEGINRLISP) or (RLISP), depending favorite flavor of top-loop. Then try: L_INITPLOT(); % To split screen Procedure Box(x,y,a,b); <<L_Move(x,y); L_Draw(x+a,y); L_Draw(x+a,y+b); L_Draw(x,y+a); L_Draw(x,y)>>; L_Erase(); For i:=1:10 do Box(5*i,6*i,3*I+10,4*I+20); L_ENDPLOT(); % To return to 2 pane mode. |
Added psl-1983/help/big.hlp version [50a96777ac].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Beryl Morrison, 4 June 1982 BigNum Structure and "Constants" The current PSL bignum package was written using vectors of "Big Digits" or "Bigits". The first element of each vector is either BIGPOS or BIGNEG, depending whether the number is positive or negative. A bignum of the form [BIGPOS a b c d] has a value of a + b * bbase!* + c * bbase!* ** 2 + d * bbase!* ** 3 BBase!* is a fluid variable which varies from one machine to another. For the VAX and the DEC-20, it is calculated as follows: bbits!* := (n-1)/2; bbase!* := 2 ** bbits!*; "n" is the total number of bits per word on the given machine. On the DEC-20, n is 36, so bbits!* is 17 and bbase!* is 131072. On the VAX, n is 32, so bbits!* is 15 and bbase!* is 32768. There are some other constants used in the system as well. The sources are in pu:bigbig.red on the DEC-20, /u/benson/psl-dist/util/bigbig.red on the VAX. Starting BigNums "Load Big;" will bring in the bignum package. A file called big.lap loads arith.b which provides an interface via tags for when inum functions and when bignum functions should be used; (sources are in test-arith.red) vector-fix.b which provides a means of truncating vectors without copying them; bigbig.b which provides the bignum versions of functions as required by arith.b; bigface.b which provides the final interface between bigbig.b and arith.b. The order of loading the files must remain as shown; arith and vector-fix may be swapped, but otherwise function definitions must be presented in the order given. Building the BigNum Package Each of the individual files may be rebuilt (to form a new *.b file) separately. A file XXX.red may be rebuilt as follows: [1] faslout "YYY"; [2] in "XXX.red"$ 2 [3] faslout; On the DEC-20, the resulting YYY.b file is put on the directory pl:; on the VAX, it is put on the connected directory. They should be on pl: on the DEC-20 for public access, and on /usr/local/lib/psl on the VAX. The Functions in BigBig The functions defined by BigBig for bignums are as follows: BLOr Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, PosIfZero. BLXOr Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, TrimBigNum1. BLAnd Takes two BigNum arguments, returning a bignum. Calls BSize, GtPos, TrimBigNum1. BLNot Takes one BigNum argument, returning a bignum. Calls BMinus, BSmallAdd. BLShift Takes two BigNum arguments, returning a bignum. Calls BMinusP, BQuotient, BTwoPower, BMinus, BTimes2. BMinus Takes one BigNum argument, returning a bignum. Calls BZeroP, BSize, BMinusP, GtPos, GtNeg. BMinusP Takes one BigNum argument, returning a bignum or NIL. BPlus2 Takes two BigNum arguments, returning a bignum. Calls BMinusP, BDifference2, BMinus, BPlusA2. BDifference BZeroP, BMinus, BMinusP, BPlusA2, BDifference2. BTimes2 Takes two BigNum arguments, returning a bignum. Calls BSize, BMinusP, GtPos, GtNeg, BDigitTimes2, PosIfZero, TrimBigNum1. BDivide Takes two BigNum arguments, returning a pair of bignums. Calls BSize, GtPos, BSimpleDivide, BHardDivide. BGreaterP Takes two BigNum arguments, returning a bignum or NIL. Calls BMinusP, BDifference. BLessP Takes two BigNum arguments, returning a bignum or NIL. Calls BMinusP, BDifference. BAdd1 Takes a BigNum argument, returning a bignum. Calls BSmallAdd. BSub1 Takes a BigNum argument, returning a bignum. Calls BigSmallDiff. 3 FloatFromBigNum Takes a bignum, returning a float. Calls BZeroP, BGreaterP, BLessP, BSize, BMinusP. BChannelPrin2 Calls BigNumP, NonBigNumError, BSimpleDivide, BSize, BZeroP. BRead Calls GtPos, BReadAdd, BMinus. BigFromFloat Takes a float and converts to a bignum. Calls BNum, BPlus2, BTimes2, BTwoPower, FloatFromBigNum, BMinus, PosIfZero. The following functions are support functions for those given above. SetBits Takes as an argument the total number of bits per word on a given machine; sets some fluid variables accordingly. NOTE: FloatHi!* must be changed separately from this procedure by hand when moving to a new machine both in bigbig.red and in bigface.red. Calls TwoPower, BNum, BMinus, BSub1, BTwoPower, BAdd1. BigNumP Checks if the argument is a bignum. Calls no special functions. NonBigNumError Calls no special functions. BSize Gives size of a bignum, i.e. total number of bigits (the tag "BIGPOS" or "BIGNEG" is number 0). Calls BigNumP. PosIfZero Takes a bignum; if it is a negative zero, it is converted to a positive zero. Calls BPosOrNegZeroP, BMinusP. BPosOrNegZeroP Takes a BigNum; checks if magnitude is zero. Calls BSize. GtPos Takes an inum/fixnum. Returns a vector of size of the argument; first (i.e.0th) element is BIGPOS, others are NIL. GtNeg Takes an inum/fixnum. Returns a vector of size of the argument; first (i.e.0th) element is BIGNEG, others are NIL. TrimBigNum Takes a BigNum as an argument; truncates any trailing "NIL"s. Calls BigNumP, NonBigNumError, TrimBigNum1, BSize. TrimBigNum1 Does dirty work for TrimBigNum, with second argument the size of the BigNum. Big2Sys Calls BLessP, BGreaterP, BSize, BMinusP. TwoPower Takes and returns a fix/inum. 2**n. BTwoPower Takes a fix/inum or bignum, returns a bignum of value 2**n. Calls BigNumP, Big2Sys, GtPos, TwoPower, TrimBigNum1. BZeroP Checks size of BigNum (0) and sign. Calls BSize, BMinusP. 4 BOneP Calls BMinusP, BSize. BAbs Calls BMinusP, BMinus. BGeq Calls BLessP. BLeq Calls BGreaterP. BMax Calls BGeq. BMin Calls BLeq. BExpt Takes a BigNum and a fix/inum. Calls Int2B, BTimes2, BQuotient. AddCarry Support for trapping the carry in addition. BPlusA2 Does the dirty work of addition of two BigNums with signs pre-checked and identical. Calls BSize, GtNeg, GtPos, AddCarry, PosIfZero, TrimBigNum1. SubCarry Mechanism to get carry in subtractions. BDifference2 Does the dirty work of subtraction with signs pre-checked and identical. Calls BSize, GtNeg, GtPos, SubCarry, PosIfZero, TrimBigNum1. BDigitTimes2 Multiplies the first argument (BigNum) by a single Bigit of the second BigNum argument. Returns the partially completed result. Calls no special functions. BSmallTimes2 Takes a BigNum argument and a fixnum argument, returning a bignum. Calls GtPos, BMinusP, GtNeg, PosIfZero, TrimBigNum1. BQuotient Takes two BigNum arguments, returning a bignum. Calls BDivide. BRemainder Takes two BigNum arguments, returning a bignum. Calls BDivide. BSimpleQuotient Calls BSimpleDivide. BSimpleRemainder Calls BSimpleDivide. BSimpleDivide Used to divide a BigNum by an inum. Returns a dotted pair of quotient and remainder, both being bignums. Calls BMinusP, GtPos, GtNeg, PosIfZero, TrimBigNum1. BHardDivide Used to divide two "true" BigNums. Returns a pair of bignums. Algorithm taken from Knuth. Calls BMinusP, GtPos, GtNeg, BAbs, BSmallTimes2, BSize, BDifference, BPlus2, TrimBigNum1, BSimpleQuotient, PosIfZero. 5 BReadAdd Calls BSmallTimes2, BSmallAdd. BSmallAdd Adds an inum to a BigNum, returning a bignum. Calls BZeroP, BMinusP, BMinus, BSmallDiff, BSize, GtPos, AddCarry, PosIfZero, TrimBigNum1. BNum Takes an inum and returns a BigNum of one bigit; test that the inum is less than bbase!* is assumed done. Calls GtPos, GtNeg. BSmallDiff Calls BZeroP, BMinusP, BMinus, BSmallAdd, GtPos, SubCarry, PosIfZero, TrimBigNum1. int2b Takes a fix/inum and converts to a BigNum. Calls BNum, BRead. Problems - Should the "vectors" be changed to hwords? - Should there be primitives so that each bigit uses almost the whole word instead of almost half the word? This would involve writing "overflow" functions, checking and trapping overflow in operations such as multiplication. This would allow integers to be returned as inums or fixnums if they are geq the current bbase!* and lessp 2 ** (n-1). Currently, anything bbase!* or larger is kept as a bignum once the bignum package is loaded. - Make the constants real constants instead of fluids: bbase!*, bbits!*, floathi!*, floatlow!*, logicalbits!*, wordhi!*, wordlow!*, syshi!*, syslo!*, digit2letter!*. Carry!* should be a fluid. - Try to make the whole package loaded as one *.b file. - Change arith.b so that divide is used for the interface instead of quotient and remainder. As it stands, doing a "Divide" when bignums are loaded would mean doing the quotient and then the remainder separately, although Knuth's algorithm computes them together. - Get rid of superfluous functions. - Put in more calls to NonBigNumError for greater safety? |
Added psl-1983/help/break.hlp version [414d8e8bf3].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, except that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet A Abort to top level, i.e. restart PSL C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. |
Added psl-1983/help/bug.hlp version [e4924d6ed1].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | BUG(); mlg, 31 dec 1981 ------ Runs MM in a lower fork, prompting for a Subject: A message is send to BENSON, GRISS, and appended to the file PSL:USER-BUG-REPORTS.TXT. After typing message about BUG or MIS-FEATURE, end finally with a <Ctrl-Z><return>. <Ctrl-N> will abort the message. Alternatively, one can exit PSL and send a message to PSL-BUGS@UTAH-20. These messages will be sent to more people. |
Added psl-1983/help/debug.hlp version [18b0bcff44].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The DEBUG Package: MLG/ 2 January 1982 ------------------ PSL has some built-in debugging functions, but for a more powerful set one must load a debug package (Load Debug; in RLISP, (Load Debug) in LISP). It is described in the manual. This is a brief introduction to some of the functions in the supplementary Debug package; for more information on built-in functions do Help Mini-Trace; in RLISP [(Help MiniTrace) in LISP]. [This help-file needs a LOT of work!] The following functions (all EXPRs) are defined: (they each redefine the functions, saving an old definition) (TR F1 ... Fn) Cause TRace message to be printed on entry to and exit from calls to the functions F1 ... Fn. (UNTR F1 ... Fn) Restore original definition. Does UNTRST automatically if necessary. (TRST F1 ... Fn) This traces interpreted functions to a deeper level by redeining the body of the function so that all assignments made with SETQ are printed. Calling TRST automatically also calls TR. (UNTRST F1 ... Fn) Restores the original definition. In addition, the following macros are available in the resident MiniTrace package. (BR F1 ... Fn) Cause BREAK on entry and on EXIT from function, permitting arguments and results to be examined and modified. (UNBR F1 ... Fn) Restore original definitions of the functions F1 ... Fn. Fluids: ------- TrSpace!* Controls indentation, may need to be reset to 0 in "funny" cases. !*NoTrArgs Set to T to suppress printing of arguments of traced functions. |
Added psl-1983/help/defstruct.hlp version [50179b3362].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | DEFSTRUCT - "Structure" definition facility. -------------------------------------------- A more complete description, including examples, is in Defstruct.Doc. Defstruct( name-and-options:{id,list}, [slot-descs:{id,list}] ): id fexpr ---------------- -- ---- ---------- -- ---- -- ----- Defines a record-structure data type. A general call to defstruct looks like this: (in RLISP syntax) defstruct( struct-name( option-1, option-2, ... ), slot-description-1, slot-description-2, ... ); % (The name of the defined structure is returned.) where slot-descriptions are: slot-name( default-init, slot-option-1, slot-option-2, ... ) Option lists and default-init forms are optional and may be omitted. Some options have optional argument lists. A call to a Constructor macro has the form: MakeThing( slot-name-1 value-expr-1, slot-name-2 value-expr-2, ... ); The Alterant macro calls have a similar form: AlterThing( thing, slot-name-1 value-expr-1, slot-name-2 value-expr-2, ... ); A call to a Creator macro has the form: CreateThing( slot-value-1, slot-value-2, ... ); Structure Options and arguments: Structure macro renaming, arg of NIL to suppress macro definition. !:Constructor name % Default: MakeThing !:Alterant name % Default: AlterThing !:Predicate name % Default: ThingP !:Creator name % Default: CreateThing Common prefix on selector/depositor names. !:Prefix idOrString % Dedfault: "" !:Prefix % If no arg, Struct name is prefix. Inclusion of substructures. !:Include structName % Starts with slot defns of subtype. !:IncludeInit initList % slot-name(default-init) list to merge % with default-init forms of subtype. Slot Options: !:Type typeId % Asserts the type of the slot. Override selectors/depositors with user-supplied fns. !:UserGet % fn name is [prefix]slot-name. !:UserPut % fn name is Put[prefix]slot-name. Miscellaneous functions on types: DefstructP( NAME:id ): extra-boolean expr ---- -- ------------- ---- is a predicate that returns non-NIL (the Defstruct definition) if NAME is a structured type which has been defined using Defstruct, or NIL if it is not. DefstructType( S:struct ): id expr - ------ -- ---- returns the type name field of an instance of a structured type, or NIL if S cannot be a defstruct type. SubTypeP( NAME1:id, NAME2:id ): boolean expr ----- -- ----- -- ------- ---- returns true if NAME1 is a structured type which has been !:Included in the definition of structured type NAME2, possibly through intermediate structure definitions. (In other words, the selectors of NAME1 can be applied to NAME2.) |
Added psl-1983/help/editor.hlp version [ebce970296].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | There are two possible editors to use in PSL. One, the PSL Structure Editor, can be used inside the Break Loop by typing e or called in PSL or RLISP by calling the function Edit on the structure whic requires editing; for more information do Help MiniEditor; [(Help MiniEditor) in LISP]. A more complete structure Editor is available as a loadable option (Load ZPEdit); when that is loaded, the Break Loop and the function Edit call the more powerful functions available in that option (Help ZPEdit). A more powerful EMACS-like editor is also being developed; it is called EMODE. For more information do Help Emode; [(Help Emode) in LISP]. |
Added psl-1983/help/emode.hlp version [0b78518813].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | EMODE - A PSL SCREEN EDITOR Comments and questions about EMODE should be addressed to Will Galway (GALWAY@UTAH-20). Further documentation is available in the file EMODE.LPT on logical device PE: Running EMODE EMODE is available as a "loadable" file. It can be invoked as follows: @PSL:RLISP [1] load emode; [2] emode(); Of course, you may choose to invoke RLISP (or "just plain Lisp") differently, and to perform other operations before loading and running EMODE. EMODE is built to run on a site dependent "default terminal" as the default (a Teleray terminal at the University of Utah). To use some other terminal you must LOAD in a set of different driver functions after loading EMODE. For example, to run EMODE on the Hewlett Packard 2648A terminal, you could type: @PSL:RLISP [1] load emode; [2] load hp2648a; [3] emode(); The following drivers are currently available: AAA For the Ann Arbor Ambassador. DM1520 For the Datamedia 1520. HP2648A For the Hewlett Packard 2648A (and similar HP terminals). TELERAY For the Teleray 1061. VT52 For the DEC VT52. VT100 For the DEC VT100. See the file PE:EMODE.LPT for information on creating new terminal drivers. When EMODE starts up, it will typically be in "two window mode". To enter "one window mode", you can type "C-X 1" (as in EMACS). Commands can be typed into a buffer shown in the top window. The result of evaluating a command is printed into the OUT_WINDOW buffer (shown in the bottom window). To evaluate the expression starting on the current line, type M-E. M-E will (normally) automatically enter two window mode if anything is "printed" to the OUT_WINDOW buffer. If you don't want to see things being printed to the output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode when something is printed to OUT_WINDOW. You must still use the "C-X 1" command to enter one window mode initially. Commands for EMODE The following commands are notable either for their difference from EMACS, or for their importance to getting started with EMODE: - To leave EMODE type C-X C-Z to "QUIT" to the EXEC, or C-Z C-Z to return to "normal" PSL input/output. - While in EMODE, the "M-?" (meta- question mark) character asks for a command character and prints the name of the routine attached to that character. - The function "PrintAllDispatch()" will print out the current dispatch table. You must call EMODE first, to set this table up. - M-C-Y inserts into the current buffer the text printed as a result of the last M-E. - M-X prompts for a one line string and then executes it as a Lisp expression. Of course, similar results can be achieved by using M-E in a buffer. A (fairly) complete table of keyboard bindings follows: C-@ Runs the function SETMARK. C-A Runs the function !$BEGINNINGOFLINE. C-B Runs the function !$BACKWARDCHARACTER. C-D Runs the function !$DELETEFORWARDCHARACTER. C-E Runs the function !$ENDOFLINE. C-F Runs the function !$FORWARDCHARACTER. Tab In Lisp mode, runs the function LISP-TAB-COMMAND. Indents as appropriate for Lisp. Linefeed In text mode, runs the function !$CRLF and acts like a carriage return. In Lisp mode, runs the function LISP-LINEFEED-COMMAND. Inserts a newline and indents as appropriate for Lisp. C-K Runs the function KILL_LINE. C-L Runs the function FULLREFRESH. Return Runs the function $CRLF (inserts a carriage return). C-N Runs the function !$FORWARDLINE. C-O Runs the function OPENLINE. C-P Runs the function !$BACKWARDLINE. C-Q Runs the function INSERTNEXTCHARACTER. Acts like a "quote" for the next character typed. C-R Backward search for string, type a carriage return to terminate the search string. Default (for a null string) is the last string previously searched for. C-S Forward search for string. C-T Transpose the last two characters typed (if the last character typed was self inserting). Otherwise, transpose the characters to the left and right of point, or the two characters to the left of point if at the end of a line. C-U Repeat a command. Similar to EMACS's C-U. C-V Runs the function SCROLL-WINDOW-UP-PAGE-COMMAND. C-W Runs the function KILL_REGION. C-X As in EMACS, control-X is a prefix for "fancier" commands. C-Y Runs the function INSERT_KILL_BUFFER. Yanks back killed text. C-Z Runs the function DOCONTROLMETA. As in EMACS, acts like "Control-Meta" (or "Meta-Control"). ESCAPE Runs the function ESCAPEASMETA. As in EMACS, ESCAPE acts like the "Meta" key. ) Inserts a "matching" right parenthesis. Bounces back to the corresponding left parenthesis, or beeps if no matching parenthesis is found. RUBOUT Runs the function !$DELETEBACKWARDCHARACTER. M-C-@ Runs the function MARK-SEXP-COMMAND. Sets mark at the end of the s-expression following point. M-C-A In Lisp mode, runs the function BEGINNING-OF-DEFUN-COMMAND. Moves backward to the beginning of the current or previous) DEFUN. A DEFUN is heuristically defined to be a line whose first character is a left parenthesis. M-C-B Runs the function BACKWARD_SEXPR. M-C-D Runs the function DOWN-LIST. Moves "deeper" into the next contained list. M-C-E In Lisp mode, runs the function END-OF-DEFUN-COMMAND. Moves forward to the beginning of the next line following the end of a DEFUN. M-C-F Runs the function FORWARD_SEXPR. M-Backspace In Lisp mode, runs the function MARK-DEFUN-COMMAND. M-Tab In Lisp mode, runs the function LISP-TAB-COMMAND. M-C-K Runs the function KILL_FORWARD_SEXPR. M-Return Runs the function BACK-TO-INDENTATION-COMMAND. Similar to C-A, but skips past any leading blanks. M-C-N Runs the function MOVE-PAST-NEXT-LIST. Moves to the right of the current or next list. M-C-O Runs the function FORWARD-UP-LIST. Moves to the right of the current list. M-C-P Runs the function MOVE-PAST-PREVIOUS-LIST. Moves to the beginning of the current or previous list. M-C-Q Runs the function LISP-INDENT-SEXPR. "Lisp indents" each line in the next s-expr. M-C-U Runs the function BACKWARD-UP-LIST. Does the "opposite" of FORWARD-UP-LIST. M-C-Y In Lisp and Rlisp mode runs the function INSERT_LAST_EXPRESSION. Inserts the last body of text typed as the result of a M-E. M-C-Z Runs the function OLDFACE. Leaves EMODE, goes back to "regular" PSL input/output. M-Escape In Lisp mode, runs the function BEGINNING-OF-DEFUN-COMMAND. (See M-C-A.) M-C-] In Lisp mode, runs the function END-OF-DEFUN-COMMAND. (See M-C-E.) M-C-RUBOUT Runs the function KILL_BACKWARD_SEXPR. M-% Runs the function QUERY-REPLACE-COMMAND. Similar to EMACS's query replace. M-( Runs the function INSERT-PARENS. Inserts a matching pair of parenthesis, leaving point between them. M-) Runs the function MOVE-OVER-PAREN. Moves over a ")" updating indentation (as appropriate for Lisp). M-/ Runs the function !$HELPDISPATCH, see the description of M-? below. M-; In Lisp and Rlisp mode runs the function INSERTCOMMENT. M-< Runs the function !$BEGINNINGOFBUFFER. Move to beginning of buffer. M-> Runs the function !$ENDOFBUFFER. Move to end of buffer. M-? Runs the function !$HELPDISPATCH. Asks for a character and prints the name of the routine attached to that character. M-@ Runs the function MARK-WORD-COMMAND. M-B Runs the function BACKWARD_WORD. Backs up over a word. M-D Runs the function KILL_FORWARD_WORD. M-E In Lisp and RLISP modes evaluates the expression starting at the beginning of the current line. M-F Runs the function FORWARD_WORD. Moves forward over a word. M-M Runs the function BACK-TO-INDENTATION-COMMAND. (See M-Return for more description.) M-V Runs the function SCROLL-WINDOW-DOWN-PAGE-COMMAND. Moves up a window. M-W Runs the function COPY_REGION. Like C-W only it doesn't kill the region. M-X Runs the function EXECUTE_COMMAND. Prompts for a string and then converts it to Lisp expression and evaluates it. M-Y Runs the function UNKILL_PREVIOUS. Used to cycle through the kill buffer. Deletes the last yanked back text and then proceeds to yank back the previous piece of text in the kill buffer. M-\ Runs the function DELETE-HORIZONTAL-SPACE-COMMAND. Deletes all blanks (and tabs) around point. M-^ Runs the function DELETE-INDENTATION-COMMAND. Deletes CRLF and indentation at front of line, leaves one space in place of them. M-RUBOUT Runs the function KILL_BACKWARD_WORD. C-X C-B Runs the function PRINTBUFFERNAMES. Prints a list of all the buffers present. C-X C-F Runs the function FIND_FILE. Asks for a filename and then selects the buffer that that file resides in, or creates a new buffer and reads the file into it. C-X C-O Runs the function DELETE-BLANK-LINES-COMMAND. Deletes blank lines around point (leaving one left). C-X C-P Runs the function WRITESCREENPHOTO. Write a "photograph" of the screen to a file. C-X C-R Runs the function CNTRLXREAD. Read a file into the buffer. C-X C-S Runs the function SAVE_FILE. Writes the buffer to the file associated with that buffer, asks for an associated file if none defined. C-X C-W Runs the function CNTRLXWRITE. Write the buffer out to a file. C-X C-X Runs the function EXCHANGEPOINTANDMARK C-X C-Z As in EMACS, exits to the EXEC. C-X 1 Goes into one window mode. C-X 2 Goes into two window mode. C-X B Runs the function CHOOSEBUFFER. EMODE asks for a buffer name, and then selects (or creates) that buffer for editing. C-X H Runs the function MARK-WHOLE-BUFFER-COMMAND. C-X N Runs the function NEXT_WINDOW. Selects the "next" window in the list of active windows. Note that some active windows may be covered by other screens, so they will be invisible until C-X N reaches them and "pops" them to the "top" of the screen. C-X O An alternate way to invoke NEXT_WINDOW. C-X P Runs the function PREVIOUS_WINDOW. Selects the "previous" window in the list of active windows. |
Added psl-1983/help/ewindow.hlp version [d3c2f4b1cb].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | Windows and Buffers in Emode ---------------------------- Global Variable `WindowNames' is list of (windows.info) CreateWindow(Wname,Bname,Coord(Left,Top),Coord(Right,Bottom)) [Left,Right:1..18, Top,Bottom:1..70] SelectWindow(Wname); DeselectWindow(Wname); KillWindow(Wname); |
Added psl-1983/help/exec.hlp version [aa6d880fc4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | EXEC0.RED: A Simple TOPS20 Interface 26 April 1982 ------------------------------------ This is a loadable option but currently is non-functional. Top Level Functions of Interest: RUN FileName; Run A File in sub-fork EXEC(); Run Exec EMACS(); Run EMACS MM(); Run MM FileP FileName; Test If File exists CMDS (!%L); Submit List of commands (FEXPR) DoCmds (L); Submit List of commands (EXPR) Use CRLF or BL in string VDIR (L); DoCmds LIST("VDIR ",L,CRLF,"POP"); HelpDir(); DoCmds LIST("DIR PH:*.HLP",CRLF,"POP"); Take (FileName); DoCmds LIST("Take ",FileName,CRLF,"POP"); SYS (L); DoCmds LIST("SYS ", L, CRLF, "POP"); TALK (L); DoCmds LIST("TALK ",L,CRLF); TYPE (L); DoCmds LIST("TYPE ",L,CRLF,"POP"); Fork manipulation: [return forkhandle, FH, an integer returned by system] OPENFork FileName; Get a File into a Fork RUNFork FH; Normal use, to run a Fork KILLFork FH; Kill a Fork GetFork Jfn; Create Fork, READ File on Jfn STARTFork FH; Start (Restart) a Fork WAITFork FH; Wait for completion File manipulation functions: [Mostly return JFN, as small integer] GetOLDJfn FileName; test If file OLD and return Jfn GetNEWJfn FileName; test If file NEW and return Jfn RELJfn Jfn; return Jfn to system OPENOLDJfn Jfn; OPEN to READ OPENNEWJfn Jfn; Open to WRITE GTJfn FileName; Get a Jfn NAMEFROMJfn Jfn; name of File on a Jfn Miscellaneous Functions: GetUNAME(); Get USER name GetCDIR(); Get Connected DIRECTORY |
Added psl-1983/help/find.hlp version [7ba26e222b].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | FIND.RED - Recognition and search OBLIST functions ------------------------------------------------- This is a loadable option [Load Find; in RLISP, (Load Find) in LISP]. These functions take a string or id, and map the Symbol Table to collect a list of ids with Prefix or Suffix as given: FindPrefix(Key:{Id, String}):id-list Scan Symbol Table for prefix FindSuffix(Key:{Id, String}):id-list Scan Symbol Table for suffix Find(Pattern:{Id,String}):id-list Scan Symbol Table for matching string Thus X:=FindPrefix '!*; Finds all ids starting with * The 'GSORT' package is used to sort the list. The Pattern is a string, with special characters, prefixed by %, like the format string in PrintF; StringMatch(pattern,subject) is called: %% Match a % in subject string %? Match any one character %* Match any series of characters (0..n) Thus Find "*%*"; is equivalent to FindPrefix "*"; Find "%**"; is equivalent to FindSuffix "*"; Find "A%*B"; matches any string starting with A and ending with B. |
Added psl-1983/help/for.hlp version [e358e9c75b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | FOR is a general iteration construct similar in many ways to the Lisp Machine LOOP construct, and the earlier InterLISP CLISP iteration construct. FOR, however, is considerably simpler, far more "lispy", and somewhat less powerful. FOR is loaded as part of the USEFUL package. It is hoped that eventuall the RLISP parser will be modified to emit calls on this new FOR macro instead of the old one. The arguments to FOR are clauses; each clause is itself a list of a keyword and one or more arguments. The clauses may introduce local variables, specify return values, have side-effects, when the iteration should cease, and so on. Before going further, it is probably best to give an example. The following function will zip together three lists into a list of three element lists. (de zip3 (x y z) (for (in u x) (in v y) (in w z) (collect (list u v w)))) The three IN clauses specify that their first argument should take successive elements of the respective lists, and the COLLECT clause specifies that the answer should be a list built out of its argument. For example, (zip3 '(1 2 3 4) '(a b c d) '(w x y z)) is ((1 a w)(2 b x)(3 c y)(4 d z)). Following are described all the possible clauses. The first few introduce iteration variables. Most of these also give some means of indicating when iteration should cease. For example, when a list being mapped over by an IN clause is exhausted, iteration must cease. If several such clauses are given in FOR expression, iteration will cease whenever on of the clauses indicates it should, whether or not the other clauses indicate that it should cease. (in v1 v2) assigns the variable v1 successive elements of the list v2. This may take an additional, optional argument: a function to be applied to the extracted element or sublist before it is assigned to the variable. The following returns the sum of the lengths of all the elements of L. [rather a kludge -- not sure why this is here. Perhaps it should come out again.] (de SumLengths (L) (for (in N L length) (sum N))) For example, (SumLengths '((1 2 3 4 5)(a b c)(x y))) is 10. (on v1 v2) assigns the varaible v1 successive cdrs of the list v2. (from var init final step) is a numeric clause. The variable is first assigned init, and then incremented by step until it is larger than final. Init, final, and step are optional. Init and step both default to 1, and if final is omitted the iteration will continue until stopped by some other means. To specify a step with init or final omitted, or a final with init omitted place nil (the constant -- it cannot be an expression) in the appropriate slot to be omitted. Final and step are only evaluated once. (for var init next) assigns the variable init first, and subsequently the value of the expression next. Init and next may be omitted. Note that this is identical to the behaviour of iterators in a DO. (with v1 v2 ... vN) introduces N locals, initialized to nil. In addition, each vi may also be of the form (var init), in which case it will be initialized to init. There are two clauses which allow arbitrary code to be executed before the first iteration, and after the last. (initially s1 s2 ... sN) will cause the si's to be evaluated in the new environment (i.e. with the iteration variables bound to their initial values) before the first iteration. (finally s1 s2 ... sN) causes the si's to be evaluated just before the function returns. (do s1 s2 ... sN) causes the si's to be evaluated at each iteration. The next few clauses build up return types. Except for the RETURNS/RETURNING clause, they may each take an additional argument which specifies that instead of returning the appropriate value, it is accumulated in the specified variable. For example, an unzipper might be defined as (de unzip3 (L) (for (u in L) (with X Y Z) (collect (car U) X) (collect (cadr U) Y) (collect (caddr U) Z) (returns (list X Y Z)))) This is essentially the opposite of zip3. Given a list of three element lists, it unzips them into three lists, and returns a list of those three lists. For example, (unzip '((1 a w)(2 b x)(3 c y)(4 d z))) is ((1 2 3 4)(a b c d)(w x y z)). (returns exp) causes the given expression to be the value of the FOR. Returning is synonymous with returns. It may be given additional arguments, in which case they are evaluated in order and the value of the last is returned (implicit PROGN). (collect exp) causes the succesive values of the expression to be collected into a list. (union exp) is similar, but only adds an element to the list if it is not equal to anything already there. (conc exp) causes the succesive values to be nconc'd together. (join exp) causes them to be appended. (count exp) returns the number of times exp was non-nil. (sum exp), (product exp), (maximize exp), and (minimize exp) do the obvious. Synonyms are summing, maximizing, and minimizing. (always exp) will return t if exp is non-nil on each iteration. If exp is ever nil, the loop will terminate immediately, no epilogue code, such as that introduced by finally will be run, and nil will be returned. (never exp) is equivlent to (always (not exp)). Explicit tests for the end of the loop may be given using (while exp). The loop will terminate if exp becomes nil at the beginning of an iteration. (until exp) is equivalent to (while (not exp)). Both while and until may be given additional arguments; (while e1 e2 ... eN) is equivalent to (while (and e1 e2 ... eN)) and (until e1 e2 ... eN) is equivalent to (until (or e1 e2 ... eN)). (when exp) will cause a jump to the next iteration if exp is nil. (unless exp) is equivalent to (when (not exp)). Unlike MACLISP and clones' LOOP, FOR does all variable binding/updating in parallel. There is a similar macro, FOR*, which does it sequentially. All variable binding/updating still preceeds any tests or other code. Also note that all WHEN or UNLESS clauses apply to all action clauses, not just subsequent ones. This fixed order of evaluation makes FOR less powerful than LOOP, but also keeps it considerably simpler. The basic order of evaluation is 1) bind variables to initial values (computed in the outer environment) 2) execute prologue (i.e. INITIALLY clauses) 3) while none of the termination conditions are satisfied: 4) check conditionalization clauses (WHEN and UNLESS), and start next iteration if all are not satisfied. 5) perform body, collecting into variables as necessary 6) next iteration 7) (after a termination condition is satisfied) execute the epilogue (i. e. FINALLY clauses) |
Added psl-1983/help/graph-to-tree.hlp version [103870fade].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | The function GRAPH-TO-TREE copies an arbitrary s-expression, removing cirularity. It does NOT show non-circular shared structure. Places where a substructure is EQ to one of its ancestors are replaced by non-interned id's of the form <n> where n is a small integer. The parent is replaced by a two element list of the form (<n>: u) where the n's match, and u is the (de-circularized) structure. This is most useful in adapting any printer for use with circular structures. The function CPRINT, also defined in the module GRAPH-TO-TREE, is simply (PRETTYPRINT (GRAPH-TO-TREE X)). Note that GRAPH-TO-TREE is very embryonic. It is MUCH more inefficient than it needs to be, heavily consing. A better implementation would use a stack (vector) instead of lists to hold intermediate expressions for comparison, and would not copy non-circular structure. In addition facilities should be added for optionally showing shared structure, for performing the inverse operation, and for also elliding long or deep structures. Finally, the output representation was chosen at random and can probably be improved, or at least brought in line with CL or some other standard. |
Added psl-1983/help/gsort.hlp version [a7760a0eb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | General List Sorting Utilities MLG - 22 December 1981 ------------------------------ The module Gsort (use LOAD GSORT) contains a number of general sorting functions and associated key comparison functions. The Key comparison functions are given 2 objects to compare, return NIL if they are not in correct order: BeforeFn(a:any,b:any):Extra-Boolean; % return NIL if not in order The package defines: NumberSortFn(N1:number,N2:Number) StringSortFn(S1:String,N2:string) [Sc1 and Sc2 are faster versions] IdSortFn(D1:id,D2:id) [IdC1 and IDc2 are faster] AtomSortFn(X1:atom,X2:Atom) The general sorting functions expect a SortFn (which MUST be an ID) GsortP(Lst:x-list,BeforeFn:id):Boolean % T if x-list is sorted Gsort(Lst:x-list,BeforeFn:id):x-list % Tree-sort of x-list GMergeSort(Lst:x-list,BeforeFn:id):x-list % Merge-sort of x-list Currently, Gsort is often fastest, but GMergeSort is more stable. Example: To sort a list of Ids call Gsort(Dlist,'Idsortfn) or Gsort(Dlist,'IDc2) for faster sort. To sort list of records (e.g. pairs), user must define comparison: E.g. to sort LP, a List of dotted pairs (Number . Info), define procedure NPSortFn(P1,P2); NumberSortFn(Car p1, Car P2); then execute Gsort(LP,'NPSortfn); See PU:Gsort.Red for the code. |
Added psl-1983/help/hcons.hlp version [32b11cfabc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | HCONS - Hashing (unique) CONS and associated utilities. The Hcons function creates unique dotted pairs. In other words, Hcons(A,B) eq Hcons(C,D) if and only if A eq C and B eq D. This allows very rapid tests for equality between structures, at the cost of expending more time in creating the structures. The use of Hcons may also save space in cases where lists share a large amount of common substructure, since only one copy of the substructure is stored. The system works by keeping a hash table of all pairs that have been created by Hcons. (So the space advantage of sharing substructure may be offset by the space consumed by table entries.) This hash table allows the system to store property lists for pairs--in the same way that Lisp has property lists for identifiers. Pairs created by Hcons SHOULD NOT be modified with RPLACA and RPLACD. Doing so will make the pair hash table inconsistent, as well as being very likely to modify structure shared with something that you don't wish to change. Also note that large numbers may be equal without being eq, so the Hcons of two large numbers may not be eq to the Hcons of two other numbers that appear to be the same. (Similar warnings hold for strings and vectors.) The following "user" functions are provided by HCONS: Hcons([U:any]): pair macro - --- ---- ----- The Hcons macro takes one or more arguments and returns their "hashed cons" (right associatively). Two arguments corresponds to a call of Cons. Hlist([U:any]): list nexpr - --- ---- ----- Hlist is the "Hcons version" of the List function. Hcopy(U:any): any macro - --- --- ----- Hcopy is the Hcons version of the copy function. Note that Hcopy serves a very different purpose than copy--which is usually used to copy a structure so that destructive changes can be made to the copy without changing the original. Hcopy, on the other hand, will only actually copy those parts of the structure which haven't already been "consed together" by Hcons. Happend (U:list, V:list): list expr - ---- - ---- ---- ---- Hcons version of append. Hreverse (U:list): list expr - ---- ---- ---- Hcons version of reverse. The following two functions can be used to "get" and "put" properties for pairs or identifiers. The pairs for these functions must be created by Hcons. These functions are known to the Setf macro. extended-put (U:id-or-pair, IND:id, PROP:any): any expr - ---------- --- -- ---- --- --- ---- extended-get (U:id-or-pair, IND:any): any expr - ---------- --- --- --- ---- |
Added psl-1983/help/help.tbl version [f8f134ac6b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (put 'Help 'HelpFunction 'HelpHelp) (put '!? 'HelpFunction 'HelpHelp) (put 'Br 'HelpFile 'mini!-trace) (put 'Break 'HelpFunction 'HelpBreak) (put 'Edit 'HelpFile 'Editor) (put 'EditF 'HelpFile 'ZPEdit) (put 'Flags 'HelpFunction 'ShowFlags) (put 'Globals 'HelpFunction 'ShowGlobals) (put 'LapIn 'HelpFile 'Load) (put 'Load 'HelpFile 'Load) (put 'MiniEditor 'HelpFile 'Mini!-Editor) (put 'MiniTrace 'HelpFile 'Mini!-Trace) (put 'TopLoop 'HelpFunction 'HelpTopLoop) (put 'Tr 'HelpFile 'mini!-trace) (put 'UnBr 'HelpFile 'mini!-trace) (put 'UnTr 'HelpFile 'mini!-trace) (DefineFlag 'Echo "Echo input characters if T") (DefineFlag 'Time "Print TimeCheck in TopLoop") (DefineFlag 'Defn "Output Parsed Expression, bypass EVAL") (defineGlobal 'OutputBase!* "Output base for numbers") (defineGlobal 'PromptString!* "Current input prompt") %(defineGlobal 'Module!* "Module name for help system") (defineGlobal 'TopLoopName!* "Name of current top loop") (defineGlobal 'TopLoopRead!* "Current reader in top loop") (defineGlobal 'TopLoopEval!* "Current evaluator in top loop") (defineGlobal 'TopLoopPrint!* "Current printer in top loop") |
Added psl-1983/help/history.hlp version [3647b40ca4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | How to use the history mechanism implemented in PSL/FRL: PSL/FRL allows you to take any previous input or output and substitute it in place of what you typed. Thus you can either print or redo any input you have previously done. You can also print or execute any result you have previously received. The system will work identify commands by either their history number, or by a subword in the input command. PSL/FRL also allows you to take any previously expression and do global substitutions on subwords inside words or numbers inside expressions(Thus allowing spelling corrections, and other word changes easily.) PSL/FRL is a set of read macros that insert the previous history text asked for inplace of them selves. Thus they can be put inside any lisp expression typed by the user. The system will evaluate the resulting expression the same as if the user had retyped everything in himself. ^^ : means insert last input command inplace of ^^. As an input command by itself, ^^ by itself means redo last command. ^n : where n is a number replaces itself with the result of (inp n). ^n by itself means (redo n). ^+n : same as ^n. ^-n : is replaced by the nth back command. replaced with the result of (inp (- current-history-number n)). by itself means (redo (- current-history-number n)) ^word : where word starts with 'a'-'z' or 'A'-'Z', means take the last input command that has word as a subword or pattern of what was typed (after readmacros were executed.), and replace that ^word with that entire input command. If you want a word that doesn't begin with 'a'-'z', or 'A'-'Z', use ^?word where word can be any lisp atom. (say 23, *, |"ab|, word). ex.: 1 lisp> (plus 2 3) 5 2 lisp> (* 4 5) 20 3 lisp> ^us (PLUS 2 3) 5 4 lisp> (* 3 ^lu) (PLUS 2 3) 15 Case is ignored in word. Word is read by the command read, And thus should be a normal lisp atom. Use the escape character as needed. If the first ^ in any of the above commands is replaced with ^@, then instead of (inp n) , the read macro is replaced with (ans n). Words are still matched against the input, not the answer. (Probably something should be added to allow matching of subwords against the answer also.) Thus:(if typed as commands by themselves): ^@^ = (eval (ans (last-command))) ^@3 = (eval (ans 3)) ^@plus = (eval (ans (last-command which has plus as a subword in its input))). Once the ^ readmacro is replaced with its history expression, you are allowed to do some editing of the command. The way to do this is to type a colon immediately after the ^ command as described above before any space or other delimiting character. ex.: ^plus:p ^2:s/ab/cd/ ^^:p ^@^:p Currently there are two types of editing commands allowed. :p means print only, do not insert in expression, whole read macro returns only nil. :s/word1/word2/ means take each atom in the expression found, and if word1 is a subword of that atom, replace the subword word1 with word2. Read is used to read word1 and word2, thus the system expects an atom and will ignore anything after what read sees before the /. Use escape characters as necessary. :n where n is a positive unsigned number, means take the nth element of the command(must be a list) and return it. ^string1^string2^ is equivalent to :s/string1/string2/. ex.: ^plus^plus^times^ is equivalent to ^plus:s/plus/times/ . After a :s, ^ or :<n> command you may have another :s command, ^ or a :p command. :p command may not be followed by any other command. The expression as modified by the :s commands is what is returned in place of the ^ readmacro. You need a closing / as seen in the :s command above. After the command you should type a delimiting character if you wish the next expression to begin with a :, since a : will be interpreted as another editing command. On substitution, case is ignored when matching the subword, and the replacement subword is capitalized(unless you use an escape character before typing a lowercase letter). Examples: 1 lisp> (plus 23 34) 57 2 lisp> ^^:s/plus/times/ (TIMES 23 34) 782 3 lisp> ^plus:s/3/5/ (PLUS 25 54) 79 4 lisp> |
Added psl-1983/help/inspect.hlp version [d8239ae92f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | INSPECT M.L. Griss, Monday, 31 May 1982 ------- This is a simple utility to scan the contents of a source file to tell what functions are defined in it. It will be embellished slightly to permit the on-line querying of certain attributes of files. INSPECT reads one or more files, printing and collecting information on defined functions. Usage: LOAD INSPECT; INSPECT "file-name"; % Scans the file, and prints proc names. % It also builds the lists ProcedureList!* % FileList!* and ProcFileList!* % File-Name can IN other files On the Fly printing is controlled by !*PrintInspect, default is T. Other lists built include FileList!* and ProcFileList!*, which is a list of (procedure . filename) for multi-file processing. For more complete process, do: LOAD Inspect; Off PrintInspect; InspectOut(); % Later will get a file Name IN ....; IN ...; InspectEnd; Now use Gsort etc. to process the lists |
Added psl-1983/help/jsys.hlp version [af3d115c5c].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | The Simple JSYS Interface ------------------------- This is a loadble option [Load Jsys; in RLISP, (Load Jsys) in LISP]. [Explain why it is useful.] 5 Syslisp functions: XJSYSn(R1,R2,R3,R4,Jnum) -> result of Rn in R1 5 LISP functions: JSYSn(R1,R2,R3,R4,Jnum) ->Rn in R1 Ri given as Lisp Integers or Strings. Tags removed converted to W-int or StringPointer. Jsys Names are defined as NEWNAMs, eg jsPBIN, jsPBOUT, etc. Support Functions: LowHalfWord(X), HighHalfWord(X), Xword(Hi,Lo), Bits L, where L is list of BitPos or (FieldVal . RightBitPos) (See Files JSYS0.RED and EXEC0.RED on PU:) |
Added psl-1983/help/load.hlp version [8cd5985eea].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | Loading LAP files ----------------- FASL and LAP files for useful utilities are stored on <psl.lap>=PL:. (LapIN "full-filename") will load a file from any directory (Load m1 m2 m3 ...) will load files "PL:m1.B" (or .LAP) etc. (mi's may be strings or ids) To build a FASL file xxx.b from a file yyy.red [in RLISP], do: FaslOut "xxx"; in "yyy.red"; FaslEnd; To use the resulting file xxx.b, one can use the function FaslIn: FaslIn "xxx.b"; Load xxx; uses the FaslIn function. |
Added psl-1983/help/loop.hlp version [97e85cee8a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;Loop macro blathering. ; ; This doc is totally wrong. Complete documentation (nice looking ; hardcopy) is available from GSB, or from ML:LSBDOC;LPDOC (which ; needs to be run through BOLIO). ; ;This is intended to be a cleaned-up version of PSZ's FOR package ;which is a cleaned-up version of the Interlisp CLisp FOR package. ;Note that unlike those crocks, the order of evaluation is the ;same as the textual order of the code, always. ; ;The form is introduced by the word LOOP followed by a series of clauses, ;each of which is introduced by a keyword which however need not be ;in any particular package. Certain keywords may be made "major" ;which means they are global and macros themselves, so you could put ;them at the front of the form and omit the initial "LOOP". ; ;Each clause can generate: ; ; Variables local to the loop. ; ; Prologue Code. ; ; Main Code. ; ; Epilogue Code. ; ;Within each of the three code sections, code is always executed strictly ;in the order that the clauses were written by the user. For parallel assignments ;and such there are special syntaxes within a clause. The prologue is executed ;once to set up. The main code is executed several times as the loop. The epilogue ;is executed once after the loop terminates. ; ;The term expression means any Lisp form. The term expression(s) means any number ;of Lisp forms, where only the first may be atomic. It stops at the first atom ;after the first form. ; ;The following clauses exist: ; ;Prologue: ; INITIALLY expression(s) ; This explicitly inserts code into the prologue. More commonly ; code comes from variable initializations. ; ;Epilogue: ; FINALLY expression(s) ; This is the only way to explicitly insert code into the epilogue. ; ;Side effects: ; DO expression(s) ; The expressions are evaluated. This is how you make a "body". ; DOING is synonymous with DO. ; ;Return values: ; RETURN expression(s) ; The last expression is returned immediately as the value of the form. ; This is equivalent to DO (RETURN expression) which you will ; need to use if you want to return multiple values. ; COLLECT expression(s) ; The return value of the form will be a list (unless over-ridden ; with a RETURN). The list is formed out of the values of the ; last expression. ; COLLECTING is synonymous with COLLECT. ; APPEND (or APPENDING) and NCONC (or NCONCING) can be used ; in place of COLLECT, forming the list in the appropriate ways. ; COUNT expression(s) ; The return value of the form will be the number of times the ; value of the last expression was non-NIL. ; SUM expression(s) ; The return value of the form will be the arithmetic sum of ; the values of the last expression. ; The following are a bit wierd syntactically, but Interlisp has them ; so they must be good. ; ALWAYS expression(s) ; The return value will be T if the last expression is true on ; every iteration, NIL otherwise. ; NEVER expressions(s) ; The return value will be T if the last expression is false on ; every iteration, NIL otherwise. ; THEREIS expression(s) ; This is wierd, I'm not sure what it really does. ; You probably want WHEN (NUMBERP X) RETURN X ; or maybe WHEN expression RETURN IT ; ;Conditionals: (these all affect only the main code) ; ; WHILE expression ; The loop terminates at this point if expression is false. ; UNTIL expression ; The loop terminates at this point if expression is true. ; WHEN expression clause ; Clause is performed only if expression is true. ; This affects only the main-code portion of a clause ; such as COLLECT. Use with FOR is a little unclear. ; IF is synonymous with WHEN. ; WHEN expression RETURN IT (also COLLECT IT, COUNT IT, SUM IT) ; This is a special case, the value of expression is returned if non-NIL. ; This works by generating a temporary variable to hold ; the value of the expression. ; UNLESS expression clause ; Clause is performed only if expression is false. ; ;Variables and iterations: (this is the hairy part) ; ; WITH variable = expression {AND variable = expression}... ; The variable is set to the expression in the prologue. ; If several variables are chained together with AND ; the setq's happen in parallel. Note that all variables ; are bound before any expressions are evaluated (unlike DO). ; ; FOR variable = expression {AND variable = expression}... ; At this point in the main code the variable is set to the expression. ; Equivalent to DO (PSETQ variable expression variable expression...) ; except that the variables are bound local to the loop. ; ; FOR variable FROM expression TO expression {BY expression} ; Numeric iteration. BY defaults to 1. ; BY and TO may be in either order. ; If you say DOWNTO instead of TO, BY defaults to -1 and ; the end-test is reversed. ; If you say BELOW instead of TO or ABOVE instead of DOWNTO ; the iteration stops before the end-value instead of after. ; The expressions are evaluated in the prologue then the ; variable takes on its next value at this point in the loop; ; hair is required to win the first time around if this FOR is ; not the first thing in the main code. ; FOR variable IN expression ; Iteration down members of a list. ; FOR variable ON expression ; Iteration down tails of a list. ; FOR variable IN/ON expression BY expression ; This is an Interlisp crock which looks useful. ; FOR var ON list BY expression[var] ; is the same as FOR var = list THEN expression[var] ; FOR var IN list BY expression[var] ; is similar except that var gets tails of the list ; and, kludgiferously, the internal tail-variable ; is substituted for var in expression. ; FOR variable = expression THEN expression ; General DO-type iteration. ; Note that all the different types of FOR clauses can be tied together ; with AND to achieve parallel assignment. Is this worthwhile? ; [It's only implemented for = mode.] ; AS is synonymous with FOR. ; ; FOR variable BEING expression(s) AND ITS pathname ; FOR variable BEING expression(s) AND ITS a-r ; FOR variable BEING {EACH} pathname {OF expression(s)} ; FOR variable BEING {EACH} a-r {OF expression(s)} ; Programmable iteration facility. Each pathname has a ; function associated with it, on LOOP-PATH-KEYWORD-ALIST; the ; alist has entries of the form (pathname function prep-list). ; prep-list is a list of allowed prepositions; after either of ; the above formats is parsed, then pairs of (preposition expression) ; are collected, while preposition is in prep-list. The expression ; may be a progn if there are multiple prepositions before the next ; keyword. The function is then called with arguments of: ; pathnname variable prep-phrases inclusive? prep-list ; Prep-phrases is the list of pairs collected, in order. Inclusive? ; is T for the first format, NIL otherwise; it says that the init ; value of the form takes on expression. For the first format, the ; list (OF expression) is pushed onto the fromt of the prep-phrases. ; In the above examples, a-r is a form to be evaluated to get an ; attachment-relationship. In this case, the pathname is taken as ; being ATTACHMENTS, and a-r is passed in by being treated as if it ; had been used with the preposition IN. The function should return ; a list of the form (bindings init-form step-form end-test); bindings ; are stuffed onto loop-variables, init-form is initialization code, ; step-form is step-code, and end-test tells whether or not to exit. ; ;Declarations? Not needed by Lisp machine. For Maclisp these will be done ;by a reserved word in front of the variable name as in PSZ's macro. ; ;The implementation is as a PROG. No initial values are given for the ;PROG-variables. PROG1 is used for parallel assignment. ; ;The iterating forms of FOR present a special problem. The problem is that ;you must do everything in the order that it was written by the user, but the ;FOR-variable gets its value in a different way in the first iteration than ;in the subsequent iterations. Note that the end-tests created by FOR have ;to be done in the appropriate order, since otherwise the next clause might get ;an error. ; ;The most general way is to introduce a flag, !FIRST-TIME, and compile the ;clause "FOR var = first TO last" as "INITIALLY (SETQ var first) ;WHEN (NOT !FIRST-TIME) DO (SETQ var (1+ var)) WHILE (<= var last)". ;However we try to optimize this by recognizing a special case: ;The special case is recognized where all FOR clauses are at the front of ;the main code; in this case if there is only one its stepping and ;endtest are moved to the end, and a jump to the endtest put at the ;front. If there are more than one their stepping and endtests are moved ;to the end, with duplicate endtests at the front except for the last ;which doesn't need a duplicate endtest. If FORs are embedded in the ;main code it can only be implemented by either a first-time flag or ;starting the iteration variable at a special value (initial minus step ;in the numeric iteration case). This could probably just be regarded as ;an error. The important thing is that it never does anything out of ;order. |
Added psl-1983/help/manual.hlp version [e65ba5ab83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The Manual ---------- The PSL manual is now fairly complete. It consists of 26 chapters, residing as Topic.mss on <reduce.syslisp.manual>. Each topic is described in a separate major chapter. The chapters are available as files n-Topic.xxx, where "n" is the Chapter number (used in Index), and .xxx is .LPT (on <psl.lpt>) for offline perusal. To read the chapters in Emacs, there is a function which one can use to clean up the .LPT: <Meta-X> Load Library$uem:clean-files will make the function available; the functin itself is <Meta-X> Clean LPT File$ Please do not change the version on PLPT:! Suggestions for additions and modifications should be sent to Griss@Utah-20 and B-Morrison@Utah-20. The chapters and their status is as follows: 0-TITLEPAGE [Intro] 00-PREFACE [Intro] 000-CONTENTS [Complete] 01-INTRODUCTION [Complete] 02-GETSTART [Complete] 03-RLISP [Complete] 04-DATATYPES [Complete] 05-NUMBERS [Complete] 06-IDS [Complete] 07-LISTS [Complete] 08-STRINGS [Complete] 09-FLOWOFCONTROL [Complete] 09-IDS [Complete] 10-FUNCTIONS [Complete] 11-INTERP [Complete] 12-GLOBALS [Complete] 13-IO [Complete] 14-TOPLOOP [Complete] 15-ERRORS [Complete] 16-DEBUG [Rough] 17-EDITOR [Rough] 18-UTILITIES [Rough] 19-COMPLR [Very Rough] 20-DEC20 [Rough] 21-SYSLISP [InComplete] 22-IMPLEMENTATION [InComplete] 23-PARSER [InComplete] 24-BIBLIO [Rough] 25-FUNCTION-INDEX [Complete] 26-CONCEPT-INDEX [Incomplete] |
Added psl-1983/help/mini-editor.hlp version [ea15caca89].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Structure Editor ------------------- Based on the BBN-Lisp editor, circa 1968, and its descendants. This editor can be entered from inside the break loop or by calling the functin Edit on a structure to be edited. For information on other editors do (Help Editor). Looking Commands: P Print the current level. The printout replace all sublevels deeper than 'plevel' by ***. 'plevel' is initialized to 3. PL n Change 'plevel' to n. 'Stroll around in the structure' commands n (>0) sets the new current level to the n-th element in the present current level (Walk down to the n-th sub-expression). -n (n>0) sets the current level to the n-th cdr in the present current level. UP go up to the level you were in just before T go to the top of the original expression F s Find the first occurence of s . Test is performed by equal. After executing, current level is set to the first level s was a member in. Structure changing commands: (Notice, that all these commands are parenthesis expressions.) (n) Delete the n-th element (in the current level) (n S ...S ) Replace the n-th element by S ...S . 1 n (-n S ...S ) Insert before the n-th element the elements S ...S . 1 n (R S S ) Replace all occurence (in the tree you are placed at) 1 n of S by S (Equal test). Others: B Enter a break loop. OK Leave the editor. HELP Print this text. E Eval and print the next expression. |
Added psl-1983/help/mini-trace.hlp version [0e8453799e].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The Mini-Trace Package: ----------------------- The following 4 functions (all FEXPRs) are defined: (they each redefine the functions, saving an old definition) TR ([F:id]) Cause TRACE message to be printed on entry to and exit from calls to the functions F1 ... Fn. UNTR ([F:id]) Restore original definitions BR ([F:id]) Cause BREAK on entry and on exit from functions, permitting arguments and results to be examined and modified. UNBR ([F:id]) Restore original definitions of the functions F1 ... Fn. Fluids: ------- TrSpace!* Controls indentation, may need to be reset to 0 in "funny" cases. !*NoTrArgs Set to T to suppress printing of arguments of traced functions. [See also the Full DEBUG package (do Help Debug; in RLISP, (Help Debug) in LISP).] |
Added psl-1983/help/mini.hlp version [67a7ae00b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The MINI translator writing system ---------------------------------- MINI processes a BNF-like form into a set of LISP functions, one for each production, operating on a stack and token-stream. They call each other, and a set of support routines and built-in recognizers. MINI uses a stack; the user can access sub-trees on the stack, replacing them by other trees built from these sub-trees. Primitive recognizers their recognized token on this stack. ==================== Load mini by doing LOAD MINI; in RLISP. ==================== The translator is defined by MINI 'rootname; MINI 'FOO; FOO: ID '!- ID +(SUB #2 #1) .(PRINT #1) ; FIN defines a complete one rule translator, which recognizes two identifiers separated by a minus sign (each ID pushes the recognized identifier onto the stack). The +() expression replaces the top 2 elements on the stack (#2 pops the first ID pushed onto the stack, while #1 pops the other) with a LISP statement. The .() expression POPs and prints it. See also <griss.mini> for demo0.MIN to demo3.MIN ============Run the Grammer by calling INVOKE 'FOO; % i.e. the rootname ============Built In Recognizers: ID, NUM, STR, ANYTOKEN ============Brief list of the operators ' Used to designate a terminal symbol (i.e. 'WHILE, 'DO, '!=) Identifier Specifies a nonterminal ( ) Used for grouping (i.e. (FOO BAR) requires rule FOO to parse followed immediately by BAR) < > Optional parse, if it fails then continue (i.e. <FOO> tries to parse FOO) / Optional rules (i.e. FOO / BAR allows either FOO or BAR to parse, with FOO tested first) STMT[ANYTOKEN]* Parse any number of STMT separated by ANYTOKEN, create a list and push onto the stack (i.e. ID[,]* will parse a number of IDentifiers separated by commas, like in an argument list) ##n Reference the nth stack location (n must be an integer) #n Pop the nth stack location (n must be an integer) +(STMT) Push the unevaluated (STMT) onto the stack .(SEXPR) Evaluate the SEXPR and ignore the result =(SEXPR) Evaluate the SEXPR and test if result non-NIL +.(SEXPR) Evaluate the SEXPR and push the result on the stack @ANYTOKEN Specifies a statement terminator, used in the error recovery mechanism to search for when an error occurs; like 'ANYTOKEN, but causes NEXT!-TOK to not scan ahead so .(NEXT!-TOK) may be needed @@ANYTOKEN Specifies a grammer terminator, used in the error recovery mechanism to search for when an error occurs; like @ANYTOKEN; fatal exit in Error Recovery $integer Generates a unique label ================== Pattern MATCHER In addition to BNF -like rules that define procedures on 0 arguments (which scan tokens by calls on NEXT!-TOK() and operate on the stack, MINI also includes a simple TREE pattern matcher and syntax to define PatternProcedures that accept and return a single argument, trying a series of patterns until one succeeds. E.g. template -> replacement PATTERN = (PLUS2 &1 0) -> 0, (PLUS2 &1 &1) -> (LIST 'TIMES2 2 &1), &1 -> &1; defines a pattern with 3 rules. &n is used to indicate a matched sub-tree in both the template and replacement. A repeated &n as in the second rule requires EQUAL sub-trees. |
Added psl-1983/help/objects.hlp version [c991a39bb1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The OBJECTS Module Cris Perdue Alan Snyder 11/22/82 ----------------------------- INTRODUCTION ------------ The OBJECTS module provides simple support for object-oriented programming in PSL. It is based on the "flavors" facility of the LISP machine, which is the source of its terminology. The LISP Machine Manual contains a much longer introduction to the idea of object oriented programming, generic operations, and the flavors facility in particular. This discussion goes over the basics of using flavored objects once briefly to give you an idea of what is involved, then goes into details. A datatype is known as a flavor (don't ask). The definition of a flavor can be thought of in two parts: the DEFFLAVOR form ("flavor definition"), plus a set of DEFMETHOD forms ("method definitions") for operating on objects of that flavor. With the objects package the programmer completely controls what operations are to be done on objects of each flavor, so this is a true object-oriented programming facility. Also, all operations on flavored objects are automatically "generic" operations. This means that any programs you write that USE flavored objects have an extra degree of built-in generality. What does it mean to say that operations on flavored objects are generic? This means that the operations can be done on an object of any flavor, just so long as the operations are defined for that flavor of object. The same operation can be defined for many flavors, and whenever the operation is invoked, what is actually done will depend on the flavor of the object it is being done to. We may wish to write a scanner that reads a sequence of characters out of some object and processes them. It does not need to assume that the characters are coming from a file, or even from an I/O channel. Suppose the scanner gets a character by invoking the GET-CHARACTER operation. In this case any object of a flavor with a GET-CHARACTER operation can be passed to the scanner, and the GET-CHARACTER operation defined for that object's flavor will be done to fetch the character. This means that the scanner can get characters from a string, or from a text editor's buffer, or from any object at all that provides a GET-CHARACTER operation. The scanner is automatically general. DEFFLAVOR A flavor definition looks like: (defflavor flavor-name (var1 var2 ...) () option1 option2 ...) Example: (defflavor complex-number (real-part (imaginary-part 0.0)) () gettable-instance-variables initable-instance-variables ) A flavor definition specifies the fields, components, or in our terminology, the "instance variables" that each object of that flavor is to have. The mention of the instance variable imaginary-part indicated that by default the imaginary part of a complex number will be initialized to 0.0. There is no default initialization for the real-part. Instance variables may be strictly part of the implementation of a flavor, totally invisible to users. Typically though, some of the instance variables are directly visible in some way to the user of the object. The flavor definition may specify "initable-instance-variables", "gettable-instance-variables", and "settable-instance-variables". None, some of, or all of the instance variables may be specified in each option. CREATING OBJECTS The function MAKE-INSTANCE provides a convenient way to create objects of any flavor. The flavor of the object to be created and the initializations to be done are given as parameters in a way that is fully independent of the internal representation of the object. METHODS The function "=>", whose name is intended to suggest the sending of a message to an object, is usually used to invoke a method. Examples: (=> my-object zap) (=> thing1 set-location 2.0 3.4) The first "argument" to => is the object being operated on: my-object and thing1 in the examples. The second "argument" is the name of the method to be invoked: zap and set-location. The method name IS NOT EVALUATED. Any further arguments become arguments to the method. (There is a function SEND which is just like => except that the method name argument is evaluated just like everything else.) Once an object is created, all operations on it are performed by "methods" defined for objects of its flavor. The flavor definition itself also defines some methods. For each "gettable" instance variable, a method of the same name is defined which returns the current value of that instance variable. For "settable" instance variables a method named "set-<variable name>" is defined. Given a new value for the instance variable, the method sets the instance variable to have that value. SANCTITY OF OBJECTS Most LISPs and PSL in particular leave open the possibility for the user to perform illicit operations on LISP objects. Objects defined by the objects package are represented as ordinary LISP objects (vectors at present), so in a sense it is quite easy to do illicit operations on them: just operate directly on its representation (do vector operations). On the other hand, there are major practical pitfalls in doing this. The representation of a flavor of objects is generated automatically, and there is no guarantee that a particular flavor definition will result in a particular representation of the objects. There is also no guarantee that the representation of a flavor will remain the same over time. It is likely that at some point vectors will no longer even be used as the representation. In addition, using the objects package is quite convenient, so the temptation to operate on the underlying representation is reduced. For debugging, one can even define a couple of extra methods "on the fly" if need be. REFERENCE INFORMATION --------------------- LOADING THE MODULE NOTE: THIS FILE DEFINES BOTH MACROS AND ORDINARY LISP FUNCTIONS. IT MUST BE LOADED BEFORE ANY OF THESE FUNCTIONS ARE USED. The recommended way of doing this is to put the expression: (BothTimes (load objects)) at the beginning of your source file. This will cause the package to be loaded at both compile and load time. DEFFLAVOR - Define a new flavor of Object The form is: (defflavor <name> <instance-variables> <mixin-flavors> <options>) Examples: (defflavor complex-number (real-part imaginary-part) () gettable-instance-variables initable-instance-variables ) (defflavor complex-number ((real-part 0.0) (imaginary-part 0.0) ) () gettable-instance-variables (settable-instance-variables real-part) ) The <instance-variables> form a list. Each member of the list is either a symbol (id) or a list of 2 elements. The 2-element list form consists of a symbol and a default initialization form. Note: Do not use names like "IF" or "WHILE" for instance variables: they are translated freely within method bodies (see DEFMETHOD). The translation process is not very smart about which occurrences of the symbol for an instance variable are actually uses of the variable, though it does understand the nature of QUOTE. The <mixin-flavors> list must be empty. In the LISP machine flavors facility, this may be a list of names of other flavors. Recognized options are: (GETTABLE-INSTANCE-VARIABLES var1 var2 ...) (SETTABLE-INSTANCE-VARIABLES var1 var2 ...) (INITABLE-INSTANCE-VARIABLES var1 var2 ...) GETTABLE-INSTANCE-VARIABLES [make all instance variables GETTABLE] SETTABLE-INSTANCE-VARIABLES [make all instance variables SETTABLE] INITABLE-INSTANCE-VARIABLES [make all instance variables INITABLE] An empty list of variables is taken as meaning all variables rather than none, so (GETTABLE-INSTANCE-VARIABLES) is equivalent to GETTABLE-INSTANCE-VARIABLES. For each gettable instance variable a method of the same name is generated to access the instance variable. If instance variable LOCATION is gettable, one can invoke (=> <object> LOCATION). For each settable instance variable a method with the name SET-<name> is generated. If instance variable LOCATION is settable, one can invoke (=> <object> SET-LOCATION <expression>). Settable instance variables are always also gettable and initable by implication. If this feature is not desired, define a method such as SET-LOCATION directly rather than declaring the instance variable to be settable. Initable instance variables may be initialized via options to MAKE-INSTANCE or INSTANTIATE-FLAVOR. See below. DEFMETHOD - Define a method on an existing flavor. The form is: (defmethod (<flavor-name> <method-name>) (<arg> <arg> . . . ) <expression> <expression> . . . ) The <flavor-name>, the <method-name>, and each <arg> are all identifiers. There may be zero or more <arg>s. Examples: (defmethod (complex-number real-part) () real-part) (defmethod (complex-number set-real-part) (new-real-part) (setf real-part new-real-part)) The body of a method can refer to any instance variable of the flavor by using the name just like an ordinary variable. They can set them using SETF. All occurrences of instance variables (except within vectors or quoted lists) are translated to an invocation of the form (IGETV SELF n). The body of a method can also freely use SELF much as though it were another instance variable. SELF is bound to the object that the method applies to. SELF may not be setq'ed or setf'ed. Example using SELF: (defmethod (toaster plug-into) (socket) (setf plugged-into socket) (=> socket assert-as-plugged-in self)) MAKE-INSTANCE - Create a new instance of a flavor. Examples: (make-instance 'complex-number) (make-instance 'complex-number 'real-part 0.0 'imaginary-part 1.0) MAKE-INSTANCE takes as arguments a flavor name and an optional sequence of initializations, consisting of alternating pairs of instance variable names and corresponding initial values. Note that all the arguments are evaluated. Initialization of a newly made object happens as follows: Each instance variable with initialization specified in the call to make-instance is initialized to the value given. Any instance variables not initialized in this way, but having default initializations specified in the flavor definition are initialized by the default initialization specified there. All other instance variables are initialized to the symbol *UNBOUND*. If a method named INIT is defined for this flavor of object, that method is invoked automatically after the initializations just discussed. The INIT method is passed as its one argument a list of alternating variable names and initial values. This list is the result of evaluating the initializations given to MAKE-INSTANCE. For example, if we call: (make-instance 'complex-number 'real-part (sin 30) 'imaginary-part (cos 30)) then the argument to the INIT method (if any) would be (real-part .5 imaginary-part .866). The INIT method may do anything desired to set up the desired initial state of the object. At present, this value passed to the INIT method is of virtually no use to the INIT method since the values have been stored into the instance variables already. In the future, though, the objects package may be extended to permit keywords other than names of instance variables to be in the initialization part of calls to make-instance. If this is done, INIT methods will be able to use the information by scanning the argument. INSTANTIATE-FLAVOR This is the same as MAKE-INSTANCE, except that the initialization list is provided as a single (required) argument. Example: (instantiate-flavor 'complex-number (list 'real-part (sin 30) 'imaginary-part (cos 30))) OPERATING ON OBJECTS -------------------- Operations on an object are done by the methods of the flavor of the object. We say that a method is invoked, or we may say that a message is sent to the object. The notation suggests the sending of messages. In this metaphor, the name of the method to use is part of the message sent to the object, and the arguments of the method are the rest of the message. There are several approaches to invoking a method: => - Convenient form for sending a message Examples: (=> r real-part) (=> r set-real-part 1.0) The message name is not quoted. Arguments to the method are supplied as arguments to =>. In these examples, r is the object, real-part and set-real-part are the methods, and 1.0 is the argument to the set-real-part method. SEND - Send a Message (Evaluated Message Name) Examples: (send r 'real-part) (send r 'set-real-part 1.0) The meanings of these two examples are the same as the meanings of the previous two. Only the syntax is different: the message name is quoted. FANCY FORMS OF SEND SEND-IF-HANDLES - Conditionally Send a Message (Evaluated Message Name) Examples: (send-if-handles r 'real-part) (send-if-handles r 'set-real-part 1.0) SEND-IF-HANDLES is like SEND, except that if the object defines no method to handle the message, no error is reported and NIL is returned. LEXPR-SEND - Send a Message (Explicit "Rest" Argument List) Examples: (lexpr-send foo 'bar a b c list) The last argument to LEXPR-SEND is a list of the remaining arguments. LEXPR-SEND-IF-HANDLES This is the same as LEXPR-SEND, except that no error is reported if the object fails to handle the message. LEXPR-SEND-1 - Send a Message (Explicit Argument List) Examples: (lexpr-send-1 r 'real-part nil) (lexpr-send-1 r 'set-real-part (list 1.0)) Note that the message name is quoted and that the argument list is passed as a single argument to LEXPR-SEND-1. LEXPR-SEND-1-IF-HANDLES This is the same as LEXPR-SEND-1, except that no error is reported if the object fails to handle the message. USEFUL FUNCTION(s) ON OBJECTS ----------------------------- OBJECT-TYPE The OBJECT-TYPE function returns the type (an ID) of the specified object, or NIL, if the argument is not an object. At present this function cannot be guaranteed to distinguish between objects created by the OBJECTS package and other LISP entities, but the only possible confusion is with vectors. DEBUGGING INFORMATION --------------------- Any object may be displayed symbolically by invoking the method DESCRIBE, e.g. (=> x describe). This method prints the name of each instance variable and its value, using the ordinary LISP printing routines. Flavored objects are liable to be complex and nested deeply or even circular. This makes it often a good idea to set PRINLEVEL to a small integer before printing structures containing objects to control the amount of output. When printed by the standard LISP printing routines, "flavored objects" appear as vectors whose zeroth element is the name of the flavor. For each method defined, there is a corresponding LISP function named <flavor-name>$<method-name>. Such function names show up in backtrace printouts. It is permissible to define new methods on the fly for debugging purposes. DECLARE and UNDECLARE --------------------- *** Read these warnings carefully! *** This facility can reduce the overhead of invoking methods on particular variables, but it should be used sparingly. It is not well integrated with the rest of the language. At some point a proper declaration facility is expected and then it will be possible to make declarations about objects, integers, vectors, etc., all in a uniform and clean way. The DECLARE macro allows you to declare that a specific symbol is bound to an object of a specific flavor. This allows the flavors implementation to eliminate the run-time method lookup normally associated with sending a message to that variable, which can result in an appreciable improvement in execution speed. This feature is motivated solely by efficiency considerations and should be used ONLY where the performance improvement is critical. Details: if you declare the variable X to be bound to an object of flavor FOO, then WITHIN THE CONTEXT OF THE DECLARATION (see below), expressions of the form (=> X GORP ...) or (SEND X 'GORP ...) will be replaced by function invocations of the form (FOO$GORP X ...). Note that there is no check made that the flavor FOO actually contains a method GORP. If it does not, then a run-time error "Invocation of undefined function FOO$GORP" will be reported. WARNING: The DECLARE feature is not presently well integrated with the compiler. Currently, the DECLARE macro may be used only as a top-level form, like the PSL FLUID declaration. It takes effect for all code evaluated or compiled henceforth. Thus, if you should later compile a different file in the same compiler, the declaration will still be in effect! THIS IS A DANGEROUS CROCK, SO BE CAREFUL! To avoid problems, I recommend that DECLARE be used only for uniquely-named variables. The effect of a DECLARE can be undone by an UNDECLARE, which also may be used only as a top-level form. Therefore, it is good practice to bracket your code in the source file with a DECLARE and a corresponding UNDECLARE. Here are the syntactic details: (DECLARE FLAVOR-NAME VAR1 VAR2 ...) (UNDECLARE VAR1 VAR2 ...) *** Did you read the above warnings??? *** REPRESENTATION INFORMATION -------------------------- (You don't need to know any of this to use this stuff.) A flavor-name is an ID. It has the following properties: VARIABLE-NAMES A list of the instance variables of the flavor, in order of their location in the instance vector. This property exists at compile time, dskin time, and load time. INITABLE-VARIABLES A list of the instance variables that have been declared to be INITABLE. This property exists at dskin time and at load time. METHOD-TABLE An association list mapping each method name (ID) defined for the flavor to the corresponding function name (ID) that implements the method. This property exists at dskin time and at load time. INSTANCE-VECTOR-SIZE An integer that specifies the number of elements in the vector that represents an instance of this flavor. This property exists at dskin time and at load time. It is used by MAKE-INSTANCE. The function that implements a method has a name of the form FLAVOR$METHOD. Each such function ID has the following properties: SOURCE-CODE A list of the form (LAMBDA (SELF ...) ...) which is the untransformed source code for the method. This property exists at compile time and dskin time. Implementation Note: A tricky aspect of the code that implements the objects package is making sure that the right things happen at the right time. When a source file is read and evaluated (using DSKIN), then everything must happen at once. However, when a source file is compiled to produce a FASL file, then some actions must be performed at compile-time, whereas other actions are supposed to occur when the FASL file is loaded. Actions to occur at compile time are performed by macros; actions to occur at load time are performed by the forms returned by macros. Another goal of the implementation is to avoid consing whenever possible during method invocation. The current scheme prefers to compile into (APPLY HANDLER (LIST args...)), for which the PSL compiler will produce code that performs no consing. |
Added psl-1983/help/package.hlp version [6b365538f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The Utah Package System (UPS) ---------------------------- A preliminary multi-name space capability is available for testing. This is a loadable option (Load Package). Syntactically, an id now becomes a multipart name, "PACKAGE\localId" which directs the INTERN part of token scanning to start searching a PATH in a linked Oblist structure from PACKAGE, itself an id accessible in the "CurrentPackage". The Print name is still "localId", but an additional field in each id, the Package Cell, records PACKAGE. A modified Prin1 and Prin2 access this field. The Root of the tree is GLOBAL, indicated by \. Thus \ID is guaranteed in the root (in fact the existing Oblist). PAKAGE.RED defines the following Fluids: \CurrentPackage!* %. Start of Search Path \PackageNames!* %. List of ALL package names \CurrentPackage!* is rebound in the Token Scanner on encountering a "\". The following functions should be used: \CreatePackage(Name,FatherPackage) which creates a convenient size hashtable \PackageP(name) \SetPackage(name) \PathInternP({id, string}) Searchs from CurrentPackage!* \PathIntern({id, string}) Lookup or insert \PathRemob({id, string}) Remobs, puts in NIL package \PathMapObl(function) Applies to ALL ids in path \LocalInternP({id, string}) Searchs in CurrentPackage!* \LocalIntern({id, string}) Lookup or insert in CurrentPackage!* \LocalRemob({id, string}) Remobs, puts in NIL package \LocalMapObl(function) Applies to ALL ids in CurrentPackage!* Note that if a string is used, it CANNOT include the \. Also, since most id's are "RAISED" on input, be careful. Current INTERN etc are \PathIntern, etc. |
Added psl-1983/help/pcheck.hlp version [f37df54fbf].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | PCHECK.RED MLG, 10 June 1982 ---------- PCHECK will READ a .SL file, printing some of the top-level of each S-expression. It is meant to survey the file, and if the file has unbalanced parensthesis, will show where things get confused. To use: LOAD PCHECK; PCHECK "foo.sl"; |
Added psl-1983/help/poly.hlp version [9040194d95].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | POLY.RED MLG July 82 -------- POLY is a simple (pedagogic) Rational Function Evaluator. After loading POLY.RED, run function ALGG(); or RAT(); These accept a sequence of expressions: <exp> ; | QUIT; (Semicolon terminator) <exp> ::= <term> [+ <exp> | - <exp>] <term> ::= <primary> [* <term> | / <term>] <primary> ::= <primary0> [^ <primary0> | ' <primary0> ] ^ is exponentiation, ' is derivative <primary0> ::= <number> | <variable> | ( <exp> ) It includes a simple parser (RPARSE), 2 evaluators (RSIMP x) and (PRESIMP), and 2 prettyprinters, (RATPRINT) and (PREPRINT) 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) |
Added psl-1983/help/prlisp.hlp version [40ddc84cb3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PRLISP.HLP ---------- Picture RLISP is an Algol-like graphics language, for Teleray, HP2648a and Tektronix, in which graphics Model primitives are combined into complete Models for display. It is a loadable option (Load PRLISP). Model primitives include: P:={x,y,z}; A point (y, and z may be omitted, default to 0) PS:=P1_ P2_ ... Pn; A Point Set is an ordered set of Points (Polygon) G := PS1 & PS2 & ... PSn; A Group of Polygons. Point Set Modifiers alter the interpretation of Point Sets within their scope. BEZIER() causes the point-set to be interpreted as the specification points for a BEZIER curve, open pointset. BSPLINE() does the same for a Bspline curve, closed pointset TRANSFORMS: Mostly return a transformation matrix Translation: Move the specified amount along the specified axis. XMOVE (deltaX) ; YMOVE (deltaY) ; ZMOVE (deltaZ) MOVE (deltaX, deltaY, deltaZ) Scale : Scale the Model SCALE (factor) XSCALE (factor) ; YSCALE (factor) ; ZSCALE (factor) SCALE1 (x.scale.factor, y.scale.factor, z.scale.factor) SCALE <Scale factor>. Scale along all axes. Rotation: ROT (degrees) ; ROT (degrees, point.specifying.axis) XROT (degrees) ; YROT (degrees) ; ZROT (degrees) Window (z.eye,z.screen): The WINDOW primitives assume that the viewer is located along the z axis looking in the positive z direction, and that the viewing window is to be centered on both the x and y axis. Vwport(leftclip,rightclip,topclip,bottomclip): The VWPORT, which specifies the region of the screen which is used for display. REPEATED (number.of.times, my.transform), The section of the Model which is contained within the scope of the Repeat Specification is replicated. Note that REPEATED is intended to duplicate a sub-image in several different places on the screen; it was not designed for animation. Identifiers of other Models, the Model referenced is displayed as if it were part of the current Model for dynamic display. Calls to PictureRLISP Procedures This Model primitive allows procedure calls to be imbedded within Models. When the Model interpreter reaches the procedure identifier it calls it, passing it the portion of the Model below the procedure as an argument. The current transformation matrix and the current pen position are available to such procedures as the values of the global identifiers GLOBAL!.TRANSFORM and HEREPOINT. If normal procedure call syntax, i.e. proc.name@ (parameters), is used then the procedure is called at Model-building time, but if only the procedure's identifier is used then the procedure is imbedded in the Model. ERASE() Clears the screen and leaves the cursor at the origin. SHOW (pict) Takes a picture and display it on the screen ESHOW (pict) Erases the whole screen and display "pict" HP!.INIT(), TEK!.INIT(), TEL!.INIT() Initializes the operating system's (TOPS-20) view of the characteristics of HP2648A terminal, TEKTRONIX 4006-1 (also ADM-3A with Retrographics board, and Teleray-1061 HP!.BUILDP() Picture construction on the screen For example, the Model (A _ B _ C & {1,2} _ B) | XROT (30) | 'TRAN ; % % PictureRLISP Commands to SHOW lots of Cubes % % Outline is a Point Set defining the 20 by 20 % square which will be part of the Cubeface % Outline := { 10, 10} _ {-10, 10} _ {-10,-10} _ { 10,-10} _ {10, 10}; % Cubeface will also have an Arrow on it % Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}; % We are ready for the Cubeface Cubeface := (Outline & Arrow) | 'Tranz; % Note the use of static clustering to keep objects % meaningful as well as the quoted Cluster % to the as yet undefined transformation Tranz, % which will result in its evaluation being % deferred until SHOW time % and now define the Cube Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90); % In order to have a more pleasant look at % the picture shown on the screen we magnify % cube by 5 times. BigCube := Cube | SCALE 5; % Set up initial Z Transform for each cube face % Tranz := ZMOVE (10); % 10 units out % % GLOBAL!.TRANSFORM has been treated as a global variable. % GLOBAL!.TRANSFORM should be initialized as a perspective % transformation matrix so that a viewer can have a correct % look at the picture as the viewing location changed. % For instance, it may be set as the desired perspective % with a perspective window centered at the origin and % of screen size 60, and the observer at -300 on the z axis. % Currently this has been set as default perspective transformation. % Now draw cube % SHOW BigCube; %@hinge % Draw it again rotated and moved left % SHOW (BigCube | XROT 20 | YROT 30 | ZROT 10); % Dynamically expand the faces out % Tranz := ZMOVE 12; % SHOW (BigCube | YROT 30 | ZROT 10); % Now show 5 cubes, each moved further right by 80 % Tranz := ZMOVE 10; % SHOW (Cube | SCALE 2.5 | XMOVE (-240) | REPEATED(5, XMOVE 80)); % % Now try pointset modifier. % Given a pointset (polygon) as control points either a BEZIER or a % BSPLINE curve can be drawn. % Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ % % Now draw Bezier curve % Show the polygon and the Bezier curve % SHOW (Cpts & Cpts | BEZIER()); % Now draw Bspline curve % Show the polygon and the Bspline curve % SHOW (Cpts & Cpts | BSPLINE()); % Now work on the Circle % Given a center position and a radius a circle will be drawn % SHOW ( {10,10} | CIRCLE(50)); % % Define a procedure which returns a model of % a Cube when passed the face to be used % Symbolic Procedure Buildcube; List 'Buildcube; % put the name onto the property list Put('buildcube, 'pbintrp, 'Dobuildcube); Symbolic Procedure Dobuildcube Face$ Face & Face | XROT(180) & Face | YROT(90) & Face | YROT(-90) & Face | XROT(90) & Face | XROT(-90) ; % just return the value of the one statement % Use this procedure to display 2 cubes, with and % without the Arrow - first do it by calling % Buildcube at time the Model is built % P := Cubeface | Buildcube() | XMOVE(-15) & (Outline | 'Tranz) | Buildcube() | XMOVE 15; % SHOW (P | SCALE 5); % Now define a procedure which returns a Model of % a cube when passed the half size parameter Symbolic Procedure Cubemodel; List 'Cubemodel; %put the name onto the property list Put('Cubemodel,'Pbintrp, 'Docubemodel); Symbolic Procedure Docubemodel HSize; << if idp HSize then HSize := eval HSize$ { HSize, HSize, HSize} _ {-HSize, HSize, HSize} _ {-HSize, -HSize, HSize} _ { HSize, -HSize, HSize} _ { HSize, HSize, HSize} _ { HSize, HSize, -HSize} _ {-HSize, HSize, -HSize} _ {-HSize, -HSize, -HSize} _ { HSize, -HSize, -HSize} _ { HSize, HSize, -HSize} & {-HSize, HSize, -HSize} _ {-HSize, HSize, HSize} & {-HSize, -HSize, -HSize} _ {-HSize, -HSize, HSize} & { HSize, -HSize, -HSize} _ { HSize, -HSize, HSize} >>; % Imbed the parameterized cube in some Models % His!.cube := 'His!.size | Cubemodel(); Her!.cube := 'Her!.size | Cubemodel(); R := His!.cube | XMOVE (60) & Her!.cube | XMOVE (-60) ; % Set up some sizes and SHOW them His!.size := 50; Her!.size := 30; % SHOW R ; % % Set up some different sizes and SHOW them again % His!.size := 35; Her!.size := 60; % SHOW R; % % Now show a triangle rotated 45 degree about the z axis. Rotatedtriangle := {0,0} _ {50,50} _ {100,0} _ {0,0} | Zrot (45); % SHOW Rotatedtriangle; % % Define a procedure which returns a model of a Pyramid % when passed 4 vertices of a pyramid. % Procedure Second,Third, Fourth and Fifth are primitive procedures % written in the source program which return the second, the third, % the fourth and the fifth element of a list respectively. % This procedure simply takes 4 points and connects the vertices to % show a pyramid. Symbolic Procedure Pyramid (Point4); %.point4 is a pointset Point4 & Third Point4 _ Fifth Point4 _ Second Point4 _ Fourth Point4 ; % Now give a pointset indicating 4 vertices build a pyramid % and show it % My!.vertices := {-40,0} _ {20,-40} _ {90,20} _ {70,100}; My!.pyramid := Pyramid Vertices; % SHOW ( My!.pyramid | XROT 30); % % A procedure that makes a wheel with "count" % spokes rotated around the z axis. % where "count" is the number specified. Symbolic Procedure Dowheel(spoke,count)$ begin scalar rotatedangle$ count := first count$ rotatedangle := 360.0 / count$ return (spoke | REPEATED(count, ZROT rotatedangle)) end$ % % Now draw a wheel consisting of 8 cubes % Cubeonspoke := (Outline | ZMOVE 10 | SCALE 2) | buildcube(); Eight!.cubes := Cubeonspoke | XMOVE 50 | WHEEL(8); % SHOW Eight!.cubes; % %Draw a cube where each face consists of just % a wheel of 8 Outlines % Flat!.Spoke := outline | XMOVE 25$ A!.Fancy!.Cube := Flat!.Spoke | WHEEL(8) | ZMOVE 50 | Buildcube()$ % SHOW A!.Fancy!.Cube; % % Redraw the fancy cube, after changing perspective by % moving the observer farther out along Z axis % GLOBAL!.TRANSFORM := WINDOW(-500,60); % SHOW A!.Fancy!.Cube; % % Note the flexibility resulting from the fact that % both Buildcube and Wheel simply take or return any % Model as their argument or value How to Run PictureRLISP on HP2648A and TEKTRONIX 4006-1 computer display terminal The current version of PictureRLISP runs on HP2648A graphics terminal and TEKTRONIX 4006-1 computer display terminal. The screen of the HP terminal is 720 units long in the X direction, and 360 units high in the Y direction. The coordinate system used in HP terminal places the origin in approximately the center of the screen, and uses a domain of -360 to 360 and a range of -180 to 180. Similarly, the screen of the TEKTRONIX terminal is 1024 units long in the X direction, and 780 units high in the Y direction. The same origin is used but the domain is -512 to 512 in the X direction and the range is -390 to 390 in the Y direction. Procedures HP!.INIT and TEK!.INIT were used to set the terminals to graph mode and initiate the lower level procedures on HP and TEKTRONIX terminals respectively. Basically, INIT procedures were written for different terminals depending on their specific characteristics. Using INIT procedures keeps terminal device dependence at the user's level to a mininum. |
Added psl-1983/help/prlisp2d.hlp version [1077186b83].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 2D version of PictureRLISP MLG 4 Jan 1983 ------------------------------------------------------ This is a brief guide to the 2D version of Picture RLISP. This is much faster than the full 3D version if only planar displays are required. It is the X-Y plane subset of PRLISP. PRLISP can now be run under PSL as well, though of course with no syntax. RLISP Use: LOAD PRLISP2D; % Load 2D version of PictureRLISP HP!.INIT(); % Select Driver, this is most common HP2648a version Line := {0,0} _ {10,10}; % Line from center towards upper-right Show Line; % Draw it Show Line | ZROT(25); % Draw rotated by 25 degrees Erase(); % Clear screen Show Line & (Line | scale 3 | zrot 20 ) | xmove 10; For more examples, see PU:PR2D-DEMO.RED, use IN "PU:PR2D-DEMO.RED"$ PRLISP2D can also be loaded and run from PSL, but no syntax is available: (LOAD PRLISP2D) (HP!.INIT) (setq LINE (POINTSET (ONEPOINT 0 0) (ONEPOINT 10 10))) (SHOW LINE) (SHOW (TRANSFORM LINE (ZROT 25))) (ERASE) (SHOW (GROUP LINE (TRANSFORM (TRANSFORM (TRANSFORM Line (SCALE 3)) (ZROT 20)) (XMOVE 10)))) For more examples, see PU:PR2D-DEMO.SL, run with (LAPIN "PU:PR2D-DEMO.SL") |
Added psl-1983/help/psl.hlp version [c93cadb4c9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | <PSL>PSL.EXE ------------ This is the "bare" version of <psl>PSL.EXE, and accepts essentially Standard LISP syntax and semantics. Differences and extensions are documented in the Manual (currently as xxxx.LPT on <reduce.syslisp.manual>). Some help files are xxxx.DOC on <PSL.DOC>; smaller help files are on <psl.help>. [<PSL>LOGICAL-NAMES.CMD defines convenient aliases (such as PSL:, PH: for xxx.HLP file, PD: for xxx.DOC files, etc.), and should be taken] Recall that file I/O needs string-quotes (") around file names; use (DSKIN "file") for input with echo. (LAPIN "file") for input without echo. (HELP) for general help, indication of what help available. (HELP a b c) for information on topics a,b,c. This call prints files from the PH: (<PSL.HELP>) directory: PH:TOPLOOP.HLP for information on the History mechanism. PH:BREAK.HLP for information on the BREAK loop that is called on error. PH:TRACE.HLP for information on TRACEing and BREAKing functions. PH:EDITOR.HLP for a simple structure editor. Comments/complaints/Cries-for-help to Griss@UTAH-20. |
Added psl-1983/help/rcref.hlp version [0fd9dfc103].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | RCREF MLG, 6 Jan 1982 ----- RCREF is a loadbale option (Load RCREF). RCREF is a Standard LISP program for processing a set of Standard LISP function definitions to produce: 1) A "Summary" showing: a) A list of files processed b) A list of "entry points" (functions which are not called or are called only by themselves) c) A list of undefined functions (functions called but not defined in this set of functions) d) A list of variables that were used non-locally but not declared GLOBAL or FLUID before there use e) A list of variables that were declared GLOBAL but used as FLUIDs i.e. bound in a function f) A list of FLUID variables that were not bound in a function so that one might consider declaring them GLOBALs g) A list of all GLOBAL variables present h) A list of all FLUID variables present i) A list of all functions present 2) A "global variable usage" table, showing for each non-local variable: a) Functions in which it is used as a declared FLUID or GLOBAL b) Functions in which it is used but not declared before c) Functions in which it is bound d) Functions i which it is changed by SETQ 3) A "function usage" table showing for each function: a) Where it is defined b) Functions which call this function c) Functions called by it d) Non-local variables used The output is alphabetized on the first seven characters of each function name. RCREF will also check that functions are called with the correct number of arguments. RESTRICTIONS: Algebraic procedures in REDUCE are treated as if they were symbolic, so that algebraic constructs will actually appear as calls to symbolic functions, such as AEVAL. Syslisp procedures are not correctly analyzed. USAGE: RCREF should be used in in PSL:RLISP To make file FILE.CRF that is crossreference listing for files FILE1.EX1 and FILE2.EX2 do the following in RLISP: @PSL:RLISP LOAD RCREF; OUT "file.crf"; [% later, CREFOUT ..."] ON CREF; IN "file1.ex1","file2.ex2"; OFF CREF; SHUT "file.crf"; [ later CREFEND] To process more files, more IN statements may be added, or the IN statement changed to include more files. OPTIONS: If the flag CREFSUMMARY is ON (or !*CREFSUMMARY is true in LISP), then only the summary (see 1 abowe) is produced. Functions with the flag NOLIST will not be examined or output. Initially, all Standard LISP functions are so flagged. (In fact, they are kept on a list NOLIST!*, so if you wish to see references to ALL functions, then CREF should be first loaded with the command LOAD RCREF, and this variable then set to NIL). It should also be remembered that in REDUCE (RLISP) any macros with the flag EXPAND or, if FORCE is on, without the flag NOEXPAND will be expanded before the definition is seen by the cross-reference program, so this flag can also be used to select those macros you require expanded and those not. |
Added psl-1983/help/readme version [8ccb66e7ce].
> > > > > > > | 1 2 3 4 5 6 7 | This directory contains (short) help files describing modules in Portable Standard LISP. These are accessed by the (HELP) command. Look at PSL.HLP, RLISP.HLP, and HELP.HLP to get started. (These are mostly hints to someone familiar with LISP, and slightly familiar with PSL; for more detail, see the information in <PSL.DOC>xxxx.DOC or <psl.lpt>xxxx.LPT). |
Added psl-1983/help/rlisp.hlp version [64a3a2532c].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | <PSL>RLISP.EXE ---------- This is a version of RLISP built upon <PSL>PSL.EXE. TAKE <PSL>LOGICAL-NAMES.CMD, or put in LOGIN.CMD. Execute RLISP(); to get into improved top-loop. It lacks some of the standard REDUCE/RLISP top loop features, essentially just XREAD/EVAL/PRINT, like Lisp READ/EVAL/PRINT. Use HELP(); or HELP(a,b,c); for information on topics a,b,c. [Look at PH:*.HLP] Recall that file I/O needs " ...." around file names. Recall that the Rlisp Break commands need a ; after commands. Use QUIT; to exit. Use SaveSystem "useful message"; to RECLAIM and exit to make smaller .EXE to save. |
Added psl-1983/help/showflags.hlp version [a56a17e63c].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | The Names and State of important Flags and Globals can be displayed by executing: ShowFlags(Flag-name-list) or ShowGlobals(Global-Name-List) If the List is NIL, some default set of Flags or Globals will be displayed. Each Flag or Global will have a short descriptive string associated with it, under the indicator 'FlagInfo or 'GlobalInfo. These are stored with DefineFlag(Id,Info-String) % Note that ID does NOT include the !* and DefineGlobal(Global,Info-string) |
Added psl-1983/help/slate.hlp version [d41870fe70].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SLATE help file: --------------- Slate is built upon EMODE, so behaves like a 3 window EMACS. Horizontal and vertical scrolling and positioning correctly scroll the LineNumber and ColumnNumber windows, and stepping commands move in 2 char cell positions. [Note that lowercase will always behave as Upper case] SLA symbols overwrite themselves and move to next position: 1 0 + @ # * R S P D . clears a cell location Row and Column Breaks are Toggles: M-R M-C <RUBOUT> BackwardEraseCell % C-Q GoToExec (not yet implemented) EMACS like Cursor Positioning Commands: M-< BeginningOfSLA M-> EndOfSLA C-A BeginningOfRow C-E EndOfRow C-F forwardCell <BLANK> ForwardCell C-B BackwardCell C-U Iterate C-P UpwardCell C-D DownwardCell C-N DownwardCell C-V PageDown M-V PageUp C-X > PageRight C-X < PageLeft Command to Move to a specific location C-X P CntrlXMoveToPos Command to set a mark at a given cell. C-X @ CntrlXMark Make a SLA grid of size ROWS by COLS C-X M CntrlXMakeSLA %Character Commands for Reading and Writing Files C-X R CntrlXreadSLA C-X W CntrlXwriteSLA %M-I MetaInsertSla [Not yet implemented] Commands for Defining and Retrieving Segments and Objects C-X O CntrlXDefineObject C-X S CntrlXDefineSeg C-X I CntrlXInsertObject C-X G CntrlXInsertSeg C-X X DefineRegionAsObject Commands for Querying Object and Segment Data C-X D CntrlXObjectDesc C-X F CntrlXSegDesc M-O MetaEvalObjectList M-S MetaEvalSegList Macros [currently unimplemented:] C-W ExecuteMacro C-X ( MakeMacro C-X ) EndMacro |
Added psl-1983/help/step.hlp version [ffc659f1d4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | STEP(Form:any):any EXPR -------------------------------------------------------------------------- Step is a loadable option (Load Step). Evaluates form, single-stepping. Form is printed, preceded by -> on entry, <-> for macro expansions. After evaluation, Form is printed preceded by <- and followed by the result of evaluation. A single character is read at each step to determine the action to be taken: Control-N (Next) Step to the Next thing. The stepper continues until the next thing to print out, and it accepts another command. Space Go to the next thing at this level. In other words, continue to evaluate at this level, but don't step anything at lower levels. This is a good way to skip over parts of the evaluation that don't interest you. Control-U (Up) Continue evaluating until we go up one level. This is like the space command, only more so; it skips over anything on the current level as well as lower levels. Control-X (eXit) Exit; finish evaluating without any more stepping. Control-G, Control-P (Grind) Grind (i.e. prettyprint) the current form. Control-R Grind the form in Rlisp syntax. Control-E (Editor) Invoke the structure editor on the current form. Control-B (Break) Enter a break loop from which you can examine the values of variables and other aspects of the current environment. Control-L Redisplay the last 10 pending forms. ? Display this help file. |
Added psl-1983/help/string-compare.hlp version [1148451ad5].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | STRING-COMPARE R. M. Carter -------------- Augments STRINGS with some nice comparison operators to Left Justify Strings, padded with "!*!*FillCharacter!*!*", currently '! ; procedure mystring!< (s1,s2); procedure mystring!> (s1,s2); procedure mystring!<!= (s1,s2); procedure mystring!>!= (s1,s2); procedure mystring!<!> (s1,s2); |
Added psl-1983/help/strings.hlp version [c2d29f9f32].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | A Common Lisp compatible package of string and character functions in PSL is available by LOADing STRINGS. The following functions are defined, from Chapters 13 and 14 of the Common Lisp manual. CHAR and STRING are not defined because of other functions with the same name. ;;;; STANDARD-CHARP - non-control character ;;;; GRAPHICP - printable character ;;;; STRING-CHARP - a character that can be an element of a string ;;;; ALPHAP - an alphabetic character ;;;; UPPERCASEP - an uppercase letter ;;;; LOWERCASEP - a lowercase letter ;;;; BOTHCASEP - same as ALPHAP ;;;; DIGITP - a digit character (optional radix not supported) ;;;; ALPHANUMERICP - a digit or an alphabetic ;;;; CHAR= - strict character comparison ;;;; CHAR-EQUAL - similar character objects ;;;; CHAR< - strict character comparison ;;;; CHAR> - strict character comparison ;;;; CHAR-LESSP - ignore case and bits for CHAR< ;;;; CHAR-GREATERP - ignore case and bits for CHAR> ;;;; CHAR-CODE - character to integer conversion ;;;; CHAR-BITS - bits attribute of a character ;;;; CHAR-FONT - font attribute of a character ;;;; CODE-CHAR - integer to character conversion, optional bits, font ignored ;;;; CHARACTER - character plus bits and font, which are ignored ;;;; CHAR-UPCASE - raise a character ;;;; CHAR-DOWNCASE - lower a character ;;;; DIGIT-CHAR - convert character to digit (optional radix, bits, font NYI) ;;;; CHAR-INT - convert character to integer ;;;; INT-CHAR - convert integer to character ;;;; CHAR - fetch a character in a string ;;;; RPLACHAR - store a character in a string ;;;; STRING= - compare two strings (substring options not implemented) ;;;; STRING-EQUAL - compare two strings, ignoring case, bits and font ;;;; STRING< - lexicographic comparison of strings ;;;; STRING> - lexicographic comparison of strings ;;;; STRING<= - lexicographic comparison of strings ;;;; STRING>= - lexicographic comparison of strings ;;;; STRING<> - lexicographic comparison of strings ;;;; STRING-LESSP - lexicographic comparison of strings ;;;; STRING-GREATERP - lexicographic comparison of strings ;;;; STRING-NOT-GREATERP - lexicographic comparison of strings ;;;; STRING-NOT-LESSP - lexicographic comparison of strings ;;;; STRING-NOT-EQUAL - lexicographic comparison of strings ;;;; MAKE-STRING - construct a string ;;;; STRING-TRIM - remove leading and trailing characters from a string ;;;; STRING-LEFT-TRIM - remove leading characters from string ;;;; STRING-RIGHT-TRIM - remove trailing characters from string ;;;; STRING-UPCASE - copy and raise all alphabetic characters in string ;;;; NSTRING-UPCASE - destructively raise all alphabetic characters in string ;;;; STRING-DOWNCASE - copy and lower all alphabetic characters in string ;;;; NSTRING-DOWNCASE - destructively raise all alphabetic characters in string ;;;; STRING-CAPITALIZE - copy and raise first letter of all words in string ;;;; NSTRING-CAPITALIZE - destructively raise first letter of all words ;;;; STRING - coercion to a string ;;;; STRING-TO-LIST - unpack string characters into a list ;;;; STRING-TO-VECTOR - unpack string characters into a vector ;;;; SUBSTRING - subsequence restricted to strings ;;;; STRING-LENGTH - last index of a string, plus one |
Added psl-1983/help/tag-bits.hlp version [0ade98f368].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL TAG BITS TAG TAG*2 Meaning (octal) ------------------------------------- 0 00 01 Positive Integer 1 02 03 Fixnum 2 04 05 Bignum 3 06 07 Float 4 10 11 String 5 12 13 Byte-Vector 6 14 15 Halfword-Vector 7 16 17 Word-Vector 8 20 21 Vector 9 22 23 Pair 15 36 37 Code 23 56 57 (Header) Bytes 24 60 61 (Header) Halfwords 25 62 63 (Header) Words 26 64 65 (Header) Vector 27 66 67 Forward 28 70 71 BTR 29 72 73 Unbound 30 74 75 ID 31 76 77 Negative Integer ------------------------------------- |
Added psl-1983/help/time-fnc.hlp version [d1e97c542b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Time-fnc.sl : code to time function calls. Usage: do (timef function-name-1 function-name-2 ...) Timef is a fexpr. It will redefine the functions named so that timing information is kept on these functions. This information is kept on the property list of the function name. The properties used are `time' and `number-of-calls'. (get function-name 'time) gives you the total time in the function. (not counting gc time). Note, this is the time from entrance to exit. The timef function redefines the function with an unwind-protect, so calls that are interrupted by *throws are counted. (get function-name 'number-of-calls) gives you the number of times the function is called. To stop timing do : (untimef function-name1 ..) or do (untimef) for all functions. (untimef) is a fexpr. To print timing information do (print-time-info function-name-1 function-name-2 ..) or do (print-time-info) for timing information on all function names. special variables used: *timed-functions* : list of all functions currently being timed. *all-timed-functions* : list of all functions ever timed in the current session. Comment: if tr is called on a called on a function that is already being timed, and then untimef is called on the function, the function will no longer be traced. |
Added psl-1983/help/time.stamp version [10983727eb].
> | 1 | 14-Aug-82 14:35:44 |
Added psl-1983/help/top-loop.hlp version [a3b66f9193].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | TopLoop(TopLoopRead!*, TopLoopPrint!*, TopLoopEval!*, TopLoopName!*, ---------------------------------------------------------------- WelcomeBanner):NIL ------------------ This function is called to establish a new TopLoop (currently for Standard LISP, RLISP, and BREAK). It prints the WelcomeBanner, and then invokes a "READ-EVAL-PRINT" loop, using the given functions. TopLoop provides a standard History and timing mechanism, retaining on a list (HistoryList!*) the input and output as a list of pairs. TopLoop Function Purpose (HIST) Display full history. (HIST n) Display history from n to present. (HIST -n) Display last n entries. (HIST n m) Display history from n to m. (INP n) Return N'th input at this level. (REDO n) Revaluate N'th input. (ANS n) Return N'th result. (SETQ !*Time T) Causes evaluation time to be printed for each command. |
Added psl-1983/help/trace.hlp version [62eecd97c1].
> > > > | 1 2 3 4 | There are two possible trace packages to use in PSL. The built-in functions are described as the Mini-Trace package (do Help MiniTrace;). Those in the more powerful Debug package are described separately (do Help Debug;). |
Added psl-1983/help/updated.files version [2b0718d425].
> > > | 1 2 3 | PS:<PSL.HELP> BREAK.HLP.5 |
Added psl-1983/help/useful.hlp version [a4f741270a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | A number of useful options can be defined by Loading Useful. Descriptions follow. BACKQUOTE and friends ------------------ (Note that the special symbols decribed here will only work in LISP syntax, not RLISP. In RLISP you may simply use the functions BACKQUOTE, UNQUOTE, UNQUOTEL, and UNQUOTED) The backquote symbol "`" is a read macro which introduces a quoted expression which may contain the unquote symbols comma "," and comma-atsign ",@". Any appropriate form consisting of the unquoted expression, calls to the function cons, and quoted expressions are produced so that the resulting expression looks like the quoted one except that the values of the unquote expressions are substitued in the appropriate place. ",@" splices in the value of the subsequent expression (i.e. strips off the outer layer of parentheses). Thus `(a (b ,x) c d ,@x e f) is equivalent to (cons 'a (cons (list 'b x) (append '(c d) (append x '(e f))))) In particular, if x is bound to (1 2 3) this will evaluate to (a (b (1 2 3)) c d 1 2 3 e f) ",." is like ",@", except it may use destructive operations on its argument. DESETQ ------ DESETQ is a destructuring setq. That is, the first argument is a piece of list structure whose atoms are all ids. Each is setq'd to the corresponding part of the second argument. For instance (desetq (a (b) . c) '((1) (2) (3) 4)) setq's a to (1), b to 2, and c to ((3) 4). DEFMACRO -------- DEFMACRO is a useful tool for defining macros. A DEFMACRO form looks like (defmacro <name> <pattern> <s1> <s2> ... <sN>) The <pattern> is an S-expression made of pairs and ids. It is matched against the arguments of the macro much like the first argument to desetq. All of the non-nil ids in <pattern> are local variables which may be used freely in the body (the <si>). When the macro is called the <si> are evaluated as in a progn with the local variables in <pattern> appropriately bound, and the value of <sN> is returned. DEFMACRO is often used with backquote. DEFLAMBDA --------- Another macro defining macro similar to DEFMACRO is DEFLAMBDA. The arguments to DEFLAMBDA are identical to those for DE. The resulting macro is simply application of a lambda expression. Thus a function defined with DEFLAMBDA will have semantics identical to that of a function defined with DE, modulo the ability to dynamically redefine the function. This is a convenient way to cause functions to be open compiled. For example, if (NEW-FOO X Y) should return (LIST X Y (LIST X Y)) we do not want it to be a simple substitution style macro, in case one of the actual arguments has side effects, or is expensive to compute. If we define it by (DEFLAMBDA NEW-FOO (X Y) (LIST X Y (LIST X Y))) then we will have the desired behaviour. In particular, (NEW-FOO (BAR) (SETQ BAZ (BOOZE))) will expand to ((LAMBDA (X Y) (LIST X Y (LIST X Y)) ) (BAR) (SETQ BAZ (BOOZE)) ) PROG1 ----- PROG1 evaluates its arguments in order, like PROGN, but returns the value of the first. LET and LET* ------------ LET is a macro giving a more perspicuous form for writing lambda expressions. The basic form is (let ((v1 i1) (v2 i2) ...(vN iN)) s1 s2 ... sN) The i's are evaluated (in an unspecified order), and then the v's are bound to these values, the s's evaluated, and the value of the last is returned. Note that the i's are evaluated in the outer environment before the v's are bound. LET!* is just like LET, except that it makes the assignments sequentially. That is, the first binding is made before the value for the second one is computed. MACROEXPAND ----------- MACROEXPAND is a useful tool for debugging macro definitions. If given one argument, MACROEXPAND will all expand all the macros in that form. Often we wish more control over this process. For example, if a macro expands into a let, we may not wish to see the LET itself expanded to a lambda expression. Therefor additional arguments may be given to MACROEXPAND. If these are supplied, only they should be macros, and only those specified will be expanded. PUSH and POP ------------ These are convenient macros for adding and deleting things from the head of a list. (push item stack) is equivalent to (setq stack (cons item stack)), and (pop stack) does (setq stack (cdr stack)) and returns the item popped off stack. An additional argument may be supplied to pop, in which case it is a variable which is setq'd to the popped value. INCR and DECR ------------- These are convenient macros for incrementing and decrementing numeric variables. (incr i) is equivalent to (setq i (add1 i)) and (decr i) to (setq i (sub1 i)). Additional arguments may be supplied, which are summed and used as the amounts by to increment or decrement. DO, DO*, DO-LOOP, and DO-LOOP* ------------------------------ The DO macro is a general iteration construct similar to that of LISPM and friends. However, it does differ in some details; in particular it is not compatible with the "old style DO" of MACLISP (which is a crock anyway), nor does it support the "no end test means once only" convention (which was just an ugly kludge to get an initialized prog). DO has the form (do (i1 i2 ... iN) (test r1 r2 ... rK) s1 s2 ... sM) where there may be zero or more i's, r's, and s's. In general the i's will have the form (var init step) On entry to the DO form, all the inits are evaluated, then the variables are bound to their respective inits. The test is evaluated, and if non-nil the form evaluates the r's and returns the value of the last one. If none are supplied it returns nil. If the test evaluates to nil the s's are evaluated, the variables are assigned the values of their respective steps in parallel, and the test evaluated again. This iteration continues until test evaluates to a non-nil value. Note that the inits are evaluated in the surrounding environment, while the steps are evaluated in the new environment. The body of the DO (the s's) is a prog, and may contain labels and GO's, though use of this is discouraged. It may be changed at a later date. RETURN used within a DO will return immediately without evaluating the test or exit forms (r's). There are alternative forms for the i's: If the step is omitted, the variable's value is left unchanged. If both the init and step are omitted or if the i is an id it is initialized to nil, and left unchanged. This is particularly useful for introducing dummy variables which will be setq'd inside the body. DO* is like DO, expcept the variable bindings and updatings are done sequentially instead of in parallel. DO-LOOP is like Do, except that it takes an additional argument, a prologue. The general form is (do-loop (i1 i2 ... iN) (p1 p2 ... pJ) (test r1 r2 ... rK) s1 s2 ... sM) This is executed just like the corresponding DO, except that after the bindings are established and initial values assigned, but before the test is first executed the pi's are evaluated, in order. Note that the pi's are all evaluated exactly once (assuming that none of the pi's err out, or otherwise throw to a surrounding context). DO-LOOP* does the variable bindings and undates sequentially instead of in parallel. IF, WHEN, and UNLESS for If and Only If Statements -------------------------------------------------- IF is a macro to simplify the writing of a common form of COND where there are only two clauses and the antecedent of the second is t. (if <test> <then-clause> <else1>...<elseN>) The <then-clause> is evaluated if and only if the test is non-nil, otherwise the elses are evaluated, and the last returned. There may be zero elses. Related macros for common COND forms are WHEN and UNLESS. (when <test> s1 s2 ... sN) evaluates the si and returns the value of sN if and only if <test> is non-nil. Otherwise WHEN returns nil. (unless <test> s1 s2 ... sN) <=> (when (not <test>) s1 s2 ... sN). PSETQ and PSETF --------------- (psetq var1 val1 var2 val2 ... varN valN) setq's the vars to the corresponding vals. The vals are all evaluated before any assignments are made. That is, this is a parallel setq. PSETF is to SETF as PSETQ is to SETQ. SETF ---- USEFUL contains an expanded version of the standard SETF macro. The principal difference from the default is that it always returns the the thing assigned (i.e. the right hand side). For example, (setf (cdr foo) '(x y z)) returns '(x y z). In the default SETF the return value is indeterminate. USEFUL also makes several more functions known to SETF. All the c...r functions are included. LIST and CONS are also include, and are similar to desetq. For example, (setf (list (cons a b) c (car d)) '((1 2) 3 4 5)) sets a to 1, b to (2), c to 3, and rplaca's the car of d to 4. It returns ((1 2) 3 4 5). SHARP-SIGN MACROS ------------------ USEFUL defines several MACLISP style sharp sign read macros. Note that these only work with the LISP reader, not RLISP. Those currently included are #' : this is like the quote mark ' but is for FUNCTION instead of QUOTE. #/ : this returns the numeric form of the following character read without raising it. For example #/a is 97 while #/A is 65. #\ : This is a read macro for the CHAR macro, described in the PSL manual. Not that the argument is raised, if *RAISE it non-nil. For example, #\a = #\A = 65, while #\!a = #\(lower a) = 97. Char has been redefined in USEFUL to be slightly more table driven -- users can now add new "prefixes" such as META or CONTROL: just hang the appropriate function (from integers to integers) off the char-prefix-function property of the "prefix". A LARGE number of additional alias for various characters have been added, including all the "standard" ASCII names like NAK and DC1. #. : this causes the following expression to be evaluated at read time. For example, `(1 2 #.(plus 1 2) 4) reads as (1 2 3 4) #+ : this reads two expressions, and passes them to the if_system macro. That is, the first should be a system name, and if that is the current system the second argument is returned by the reader. If not, nil is returned. #- is similar, but causes the second arg to be returned only if it is NOT the current system. Note that this does NOT use splice macros, since PSL doesn't have them (I don't really know why not -- at the very least there ought to be a way to tell the reader "ignore this", even if splice macros are thought to be a kludge). FOR --- FOR is a general iteration construct similar in many ways to the Lisp Machine LOOP construct, and the earlier InterLISP CLISP iteration construct. FOR, however, is considerably simpler, far more "lispy", and somewhat less powerful. FOR will only work in LISP syntax. In fact, loading FOR will, for the time being, "break" RLISP, as it redefines the FOR macro. It is hoped that eventually the RLISP parser will be modified to emit calls on this new FOR macro instead of the old one. The arguments to FOR are clauses; each clause is itself a list of a keyword and one or more arguments. The clauses may introduce local variables, specify return values, have side-effects, when the iteration should cease, and so on. Before going further, it is probably best to give an example. The following function will zip together three lists into a list of three element lists. (de zip3 (x y z) (for (in u x) (in v y) (in w z) (collect (list u v w)))) The three IN clauses specify that their first argument should take successive elements of the respective lists, and the COLLECT clause specifies that the answer should be a list built out of its argument. For example, (zip3 '(1 2 3 4) '(a b c d) '(w x y z)) is ((1 a w)(2 b x)(3 c y)(4 d z)). Following are described all the possible clauses. The first few introduce iteration variables. Most of these also give some means of indicating when iteration should cease. For example, when a list being mapped over by an IN clause is exhausted, iteration must cease. If several such clauses are given in FOR expression, iteration will cease whenever on of the clauses indicates it should, whether or not the other clauses indicate that it should cease. (in v1 v2) assigns the variable v1 successive elements of the list v2. This may take an additional, optional argument: a function to be applied to the extracted element or sublist before it is assigned to the variable. The following returns the sum of the lengths of all the elements of L. [rather a kludge -- not sure why this is here. Perhaps it should come out again.] (de SumLengths (L) (for (in N L length) (sum N))) For example, (SumLengths '((1 2 3 4 5)(a b c)(x y))) is 10. (on v1 v2) assigns the varaible v1 successive cdrs of the list v2. (from var init final step) is a numeric clause. The variable is first assigned init, and then incremented by step until it is larger than final. Init, final, and step are optional. Init and step both default to 1, and if final is omitted the iteration will continue until stopped by some other means. To specify a step with init or final omitted, or a final with init omitted place nil (the constant -- it cannot be an expression) in the appropriate slot to be omitted. Final and step are only evaluated once. (for var init next) assigns the variable init first, and subsequently the value of the expression next. Init and next may be omitted. Note that this is identical to the behaviour of iterators in a DO. (with v1 v2 ... vN) introduces N locals, initialized to nil. In addition, each vi may also be of the form (var init), in which case it will be initialized to init. There are two clauses which allow arbitrary code to be executed before the first iteration, and after the last. (initially s1 s2 ... sN) will cause the si's to be evaluated in the new environment (i.e. with the iteration variables bound to their initial values) before the first iteration. (finally s1 s2 ... sN) causes the si's to be evaluated just before the function returns. (do s1 s2 ... sN) causes the si's to be evaluated at each iteration. The next few clauses build up return types. Except for the RETURNS/RETURNING clause, they may each take an additional argument which specifies that instead of returning the appropriate value, it is accumulated in the specified variable. For example, an unzipper might be defined as (de unzip3 (L) (for (in u L) (with X Y Z) (collect (car U) X) (collect (cadr U) Y) (collect (caddr U) Z) (returns (list X Y Z)))) This is essentially the opposite of zip3. Given a list of three element lists, it unzips them into three lists, and returns a list of those three lists. For example, (unzip '((1 a w)(2 b x)(3 c y)(4 d z))) is ((1 2 3 4)(a b c d)(w x y z)). (returns exp) causes the given expression to be the value of the FOR. Returning is synonymous with returns. It may be given additional arguments, in which case they are evaluated in order and the value of the last is returned (implicit PROGN). (collect exp) causes the succesive values of the expression to be collected into a list. (adjoin exp) is similar, but only adds an element to the list if it is not equal to anything already there. (adjoinq exp) is like adjoin, but uses eq instead of equal. (conc exp) causes the succesive values to be nconc'd together. (join exp) causes them to be appended. (union exp) forms the union of all the exp (unionq exp), (intersection exp), (intersectionq exp) are similar, but use the specified function instead of union. (count exp) returns the number of times exp was non-nil. (sum exp), (product exp), (maximize exp), and (minimize exp) do the obvious. Synonyms are summing, maximizing, and minimizing. (always exp) will return t if exp is non-nil on each iteration. If exp is ever nil, the loop will terminate immediately, no epilogue code, such as that introduced by finally will be run, and nil will be returned. (never exp) is equivlent to (always (not exp)). Explicit tests for the end of the loop may be given using (while exp). The loop will terminate if exp becomes nil at the beginning of an iteration. (until exp) is equivalent to (while (not exp)). Both while and until may be given additional arguments; (while e1 e2 ... eN) is equivalent to (while (and e1 e2 ... eN)) and (until e1 e2 ... eN) is equivalent to (until (or e1 e2 ... eN)). (when exp) will cause a jump to the next iteration if exp is nil. (unless exp) is equivalent to (when (not exp)). Unlike MACLISP and clones' LOOP, FOR does all variable binding/updating in parallel. There is a similar macro, FOR*, which does it sequentially. All variable binding/updating still preceeds any tests or other code. Also note that all WHEN or UNLESS clauses apply to all action clauses, not just subsequent ones. This fixed order of evaluation makes FOR less powerful than LOOP, but also keeps it considerably simpler. The basic order of evaluation is 1) bind variables to initial values (computed in the outer environment) 2) execute prologue (i.e. INITIALLY clauses) 3) while none of the termination conditions are satisfied: 4) check conditionalization clauses (WHEN and UNLESS), and start next iteration if all are not satisfied. 5) perform body, collecting into variables as necessary 6) next iteration 7) (after a termination condition is satisfied) execute the epilogue (i. e. FINALLY clauses) DEFSWITCH --------- Defswitch provides a convenient machanism for declaring variables whose values need to be set in a disciplined manner. It is quite similar to T's DEFINE-SWITCH. The form of a defswitch expression is (defswitch <name> <var> [<read-action> {<set-action>}]) This declares <name> to be a function of no arguments for deterimining the value of the variable <var>. <var> is declared fluid. SETF will set the value of <var> when given a call on <name> as its first argument. When <name> is called <read-action> will be evaluated (after the value of the variable is looked up). When it is set the <set-action>s will be evaluated (before the value is set). <name> may be used as a "free" variable in the <read-action> and <set-action>s, in which case it will hold the current value and new value, respectively. If <var> is nil an uninterned id will be used for the variable. Suppose we wish to keep a list in a variable, FOO, but also want to always have it's length available in FOOLENGTH. We can do this by always accessing FOO by a function as follows: (defswitch FOO nil nil (setq FOOLENGTH (length FOO))) |
Added psl-1983/help/zbasic.hlp version [1e77be0cb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZBASIC contains 6 packages -- (1) YLSTS -- useful functions for lists. (2) YNUMS -- useful functions for numbers. (3) YSTRS -- useful functions for strings. (4) YIO -- useful functions for user io. (5) YCNTRL -- useful functions for program control. (6) YRARE -- functions we use now, but may eliminate. YLSTS -- BASIC LIST UTILITIES CCAR ( X:any ):any CCDR ( X:any ):any LAST ( X:list ):any NTH-CDR ( L:list N:number ):list NTH-ELT ( L:list N:number ):elt of list NTH-TAIL( L:list N:number ):list TAIL-P ( X:list Y:list ):extra-boolean NCONS ( X:any ): (CONS X NIL) KWOTE ( X:any ): '<eval of #X> MKQUOTE ( X:any ): '<eval of #X> RPLACW ( X:list Y:list ):list DREMOVE ( X:any L:list ):list REMOVE ( X:any L:list ):list DSUBST ( X:any Y:any Z:list ):list LSUBST ( NEW:list OLD:list X:any ):list COPY ( X:list ):list TCONC ( P:list X:any ): tconc-ptr LCONC ( P:list X:list ):list CVSET ( X:list ):set ENTER ( ELT:element SET:list ):set ABSTRACT( FN:function L:list ):list EACH ( L:list FN:function ):extra-boolean SOME ( L:list FN:function ):extra-boolean INTERSECTION ( SET1:list SET2:list ):extra-boolean SETDIFFERENCE ( SET1:list SET2:list ):extra-boolean SUBSET ( SET1:any SET2:list ):extra boolean UNION ( X:list Y:list ):list SEQUAL ( X:list Y:list ):extra boolean MAP2C ( X:list Y:list FN:function ):NIL MAP2 ( X:list Y:list FN:function ):NIL ATSOC ( ALST:list, KEY:atom ):any CCAR( X:any ):any ---- Careful Car. Returns car of x if x is a list, else NIL. CCDR( X:any ):any ---- Careful Cdr. Returns cdr of x if x is a list, else NIL. LAST( X:list ):any ---- Returns the last cell in X. E.g. (LAST '(A B C)) = (C), (LAST '(A B . C)) = C. NTH-CDR( L:list N:number ):list ------- Returns the nth cdr of list--0 is the list, 1 the cdr ... NTH-ELT( L:list N:number ):list ------- Returns the nth elt of list--1 is the car, 2 the cadr ... NTH-TAIL( L:list N:number ):list ------- Returns the nth tail of list--1 is the list, 2 the cdr ... TAIL-P( X:list Y:list ):extra-boolean ------ If X is a non-nil tail of Y (X eq cdr Y or cddr Y or...), return X. Renamed to avoid a conflict with TAILP in compiler NCONS( X:any ): (CONS X NIL) ----- Returns (CONS X NIL) KWOTE( X:any ): '<eval of #X> MKQUOTE( X:any ): '<eval of #X> ------- Returns the quoted value of its argument. RPLACW( X:list Y:list ):list ------ Destructively replace the Whole list X by Y. DREMOVE( X:any L:list ):list ------- Remove destructively all equal occurrances of X from L. REMOVE( X:any L:list ):list ------ Return copy of L with all equal occurrences of X removed. COPY( X:list ):list ---- Make a copy of X--EQUAL but not EQ (except for atoms). DSUBST( X:any Y:any Z:list ):list ------ Destructively substitute copies(??) of X for Y in Z. LSUBST( NEW:list OLD:list X:any ):list ------ Substitute elts of NEW (splicing) for the element old in X TCONC( P:list X:any ): tconc-ptr ----- Pointer consists of (CONS LIST (LAST LIST)). Returns (and alters) pointer consisting of (CONS LIST1 (LAST LIST1)), where LIST1 = (NCONC1 LIST X). Avoids searching down the list as nconc1 does, by pointing at last elt of list for nconc1. To use, setq ptr to (NCONS NIL), tconc elts, return car of ptr. LCONC( P:list X:list ):list ----- Same as TCONC, but NCONCs instead of NCONC1s. CVSET( X:list ):list -------------------- Converts list to set, i.e., removes redundant elements. ENTER( ELT:element SET:list ):list ----- Returns (ELT . SET) if ELT is not member of SET, else SET. ABSTRACT( FN:function L:list ):list -------- Returns list of elts of list satisfying FN. EACH( L:list FN:function ):extra boolean ---- Returns L if each elt satisfies FN, else NIL. SOME( L:list FN:function ):extra boolean ---- Returns the first tail of the list whose CAR satisfies function. INTERSECTION( #SET1:list #SET2:list ):extra boolean ------------ Returns list of elts in SET1 which are also members of SET2 SETDIFFERENCE( #SET1:list #SET2:list ):extra boolean ------------- Returns all elts of SET1 not members of SET2. SUBSET( #SET1:any #SET2:list ):extra boolean ------ Returns SET1 if each element of SET1 is a member of SET2. UNION( X:list Y:list ):list ----- Returns the union of lists X, Y SEQUAL( X:list Y:list ):extra boolean ------ Returns X if X and Y are set-equal: same length and X subset of Y. MAP2( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired tails of X and Y. MAP2C( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired elts of X and Y. ATSOC( ALST:list, KEY:atom ):any ----- Like ASSOC, except uses an EQ check. Returns first element of ALST whose CAR is KEY. YNUMS -- BASIC NUMBER UTILITIES ADD1 ( number ):number EXPR SUB1 ( number ):number EXPR ZEROP ( any ):boolean EXPR MINUSP ( number ):boolean EXPR PLUSP ( number ):boolean EXPR POSITIVE( X:any ):extra-boolean EXPR NEGATIVE( X:any ):extra-boolean EXPR NUMERAL ( X:number/digit/any ):boolean EXPR GREAT1 ( X:number Y:number ):extra-boolean EXPR LESS1 ( X:number Y:number ):extra-boolean EXPR GEQ ( X:number Y:number ):extra-boolean EXPR LEQ ( X:number Y:number ):extra-boolean EXPR ODD ( X:integer ):boolean EXPR SIGMA ( L:list FN:function ):integer EXPR RAND16 ( ):integer EXPR IRAND ( N:integer ):integer EXPR The DEC compiler may optimize calls to PLUS2, DIFFERENCE, EQUAL, LESSP, etc. by converting them to calls to ADD1, SUB1, ZEROP, MINUSP, etc. This will create circular defintions in the conditional defintions, about which the compiler will complain. Such complaints can be ignored. ADD1( number ):number EXPR ---- Note: DEC compiler optimizes (PLUS2 N 1) into (ADD1 N). SUB1( number ):number EXPR ---- Note: DEC compiler optimizes (DIFFERENCE N 1) into (SUB1 N). ZEROP( X:any ):boolean EXPR ----- Returns non-nil iff X equals 0. MINUSP( N:number ):boolean EXPR ------ Returns non-nil iff N is less than 0. PLUSP( N:number ):boolean EXPR ----- Returns non-nil iff N is greater than 0. ODD( X:integer ):boolean EXPR --- Returns T if x is odd, else NIL. WARNING: EVENP is used by REDUCE to test if a list has even length. ODD and EVENP are thus highly distinct. POSITIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a positive number. NEGATIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a negative number. NUMERAL( X:any ): boolean EXPR ------- Returns true for both numbers and digits. Some dialects had been treating the digits as numbers, and this fn is included as a replacement for NUMBERP where NUMBERP might really be checking for digits. N.B.: Digits are characters and thus ID's GREAT1( X:number Y:number ):extra-boolean EXPR ------ Returns X if it is strictly greater than Y, else NIL. GREATERP is simpler if only T/NIL is needed. LESS1( X:number Y:number ):extra-boolean EXPR ----- Returns X if it is strictly less than Y, else NIL LESSP is simpler if only T/NIL is needed. GEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is greater than or equal to Y, else NIL. LEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is less than or equal to Y, else NIL. SIGMA( L:list, FN:function ):integer EXPR ----- Returns sum of results of applying FN to each elt of LST. RAND16( ):integer EXPR IRAND ( N:integer ):integer EXPR ------ Linear-congruential random-number generator. To avoid dependence upon the big number package, we are forced to use 16-bit numbers, which means the generator will cycle after only 2^16. The randomness obtained should be sufficient for selecting choices in VOCAL, but not for monte-carlo experiments and other sensitive stuff. decimal 14933 = octal 35125, decimal 21749 = octal 52365 Returns a new 16-bit unsigned random integer. Leftmost bits are most random so you shouldn't use REMAINDER to scale this to range Scale new random number to range 0 to N-1 with approximately equal probability. Uses times/quotient instead of remainder to make best use of high-order bits which are most random YSTRS -- BASIC STRING UTILITIES EXPLODEC ( X:any ):char-list EXPR EXPLODE2 ( X:any ):char-list EXPR FLATSIZE ( X:str ):integer EXPR FLATSIZE2( X:str ):integer EXPR NTHCHAR ( X:str N:number ):char-id EXPR ICOMPRESS( LST:lst ):<interned id> EXPR SUBSTR ( STR:str START:num LENGTH:num ):string EXPR CAT-DE ( L: list of strings ):string EXPR CAT-ID-DE( L: list of strings ):<uninterned id> EXPR SSEXPR ( S: string ):<interned id> EXPR EXPLODE2( X:any ):char-list EXPR EXPLODEC( X:any ):char-list EXPR -------- List of characters which would appear in PRIN2 of X. If either is built into the interpreter, we will use that defintion for both. Otherwise, the definition below should work, but inefficiently. Note that this definition does not support vectors and lists. (The DEC and IBM interpreters support EXPLODE and EXPLODE2 by using the same internal algorithm that is used for PRIN1 (PRIN2), but put the chars generated into a list instead of printing them. Thus, they work on arbitrary s-expressions.) If either EXPLODEC or EXPLODE2 is defined, the CDE does nothing. Note: According to the STANDARD LISP REPORT, EXPLODE and EXPLODE2 are only defined for atoms. If your interpreter does not support extended EXPLODE and EXPLODE2, then change the second CDE's below for FLATSIZE and FLATSIZE2 to get recursive versions of them. FLATSIZE( X:any ):integer EXPR -------- Number of chars in a PRIN1 of X. Also equals length of list created by EXPLODE of X, assuming that EXPLODE extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN1, but count chars instead of printing them. If your EXPLODE only works for atoms, comment out the above CDE and turn the CDE below into DE. FLATSIZE2( X:any ):integer EXPR --------- Number of chars in a PRIN2 of X. Also equals length of list created by EXPLODE2 of X, assuming that EXPLODE2 extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN2, but count chars instead of printing them. FLATSIZE will often suffice for FLATSIZE2 If your EXPLODE2 only works for atoms, comment out the CDE above and turn the CDE below into DE. NTHCHAR( X:any, N:number ):character-id EXPR ------- Returns nth character of EXPLODE2 of X. ICOMPRESS( LST:list ):interned atom EXPR --------- Returns INTERN'ed atom made by COMPRESS. SUBSTR( STR:string START:number LENGTH:number ):string EXPR ------ Returns a substring of the given LENGTH beginning with the character at location START in the string. NB: The first location of the string is 0. If START or LENGTH is negative, 0 is assumed. If the length given would exceed the end of the string, the subtring returned quietly goes to end of string, no error. CAT-DE( L: list of expressions ):string EXPR ------- Returns a string made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT macro. CAT-ID-DE( L: list of any ):uninterned id EXPR ------- Returns an id made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT-ID macro. SSEXPR( S: string ): id EXPR ------ Returns ID `read' from string. Not very robust. YIO -- simple I/O utilities. All EXPR's. CONFIRM (#QUEST: string ):boolean EATEOL ():NIL TTY-DE (#L: list ):NIL TTY-TX-DE (#L: list ):NIL TTY-XT-DE (#L: list ):NIL TTY-TT-DE (#L: list ):NIL TTY-ELT (#X: elt ):NIL PRINA (#X: any ):NIL PRIN1SQ (#X: any ):NIL PRIN2SQ (#X: any ):NIL PRINCS (#X: single-char-id ):NIL --queue-code-- SEND ():NIL SEND-1 (#EE) ENQUEUE (#FN #ARG) Q-PRIN1 (#E: any ):NIL Q-PRINT (#E: any ):NIL Q-PRIN2 (#E: any ):NIL Q-TERPRI () ONEARG-TERPRI (#E: any ):NIL Q-TYO (#N: ascii-code ):NIL Q-PRINC (#C: single-char-id ):NIL * Q-TTY-DE (#CMDS: list ):NIL * Q-TTY-XT-DE (#CMDS: list ):NIL * Q-TTY-TX-DE (#CMDS: list ):NIL * Q-TTY-TT-DE (#CMDS: list ):NIL DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) ( SETQ !#ANS (CAR (EXPLODEC (READ)))) (COND ((EQ !#ANS (QUOTE Y)) (PROGN ( EATEOL) (RETURN T))) ((EQ !#ANS (QUOTE N)) (PROGN (EATEOL) (RETURN NIL))) (( EQ !#ANS (QUOTE !?)) (GO LP0)) (T (TTY!-XT Please type Y, N or ?.)) (GO LP1))) Eat (discard) text until $EOL$ or <ESC> seen. <ESC> meaningful only on PDP-10 systems. $EOL$ meaningful only on correctly-implemented Standard-LISP systems. An idea whose time has not yet come... DE TTY!-DE (EOLS!#BEFORE !#L EOLS!#AFTER) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) LP1 (COND ((ONEP EOLS!#BEFORE) (TTY!-ELT !$EOL!$)) (( ZEROP EOLS!#BEFORE) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#BEFORE ( SUB1 EOLS!#BEFORE)) (GO LP1)))) (MAPC !#L (FUNCTION TTY!-ELT)) LP1 (COND (( ONEP EOLS!#AFTER) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#AFTER) NIL) (T (PROGN ( TTY!-ELT !$EOL!$) (SETQ EOLS!#AFTER (SUB1 EOLS!#AFTER)) (GO LP2)))) (WRS OLD!#CHAN))) So, for now at least, ... PRINA( X:any ): any ----- Prin2s expression, after TERPRIing if it is too big for line, or spacing if it is not at the beginning of a line. Returns the value of X. Except for the space, this is just PRIN2 in the IBM interpreter. CHRCT (): <number> ----- CHaRacter CounT left in line. Also a CDE in YPP.LSP -- built into IMSSS DEC interpreter. BINARY (#X: boolean): old-value ------ Stub for non-IMSSS interpreters. In IMSSS interpreter, will put terminal into binary mode or take it out, according to argument, and return old value. PRIN1SQ (#X: any) ------- PRIN1, Safe, use apostrophe for Quoted expressions. This is essentially a PRIN1 which tries not to exceed the right margin. It exceeds it only in those cases where the pname of a single atom exceeds the entire linelength. In such cases, <big> is printed at the terminal as a warning. (QUOTE xxx) structures are printed in 'xxx form to save space. Again, this is a little superfluous for the IBM interpreter. PRIN2SQ (#X: any) ------- PRIN2, Safe, use apostrophe for Quoted expressions. Just like PRIN1SQ, but uses PRIN2 as a basis. PRINCS (#X: single-character-atom) ------- PRINC Safe. Does a PRINC, but first worries about right margin. 1980 Jul 24 -- New Queued-I/O routines. To interface other code to this new I/O method, the following changes must be made in other code: PRIN2 --> TTY TERPRI --> $EOL$ inside a TTY, which causes Q-TERPRI to be called TYO --> Q-TYO PRIN1, PRINT -- These are used only for debugging. Do a (SEND) just before starting to print things in realtime, or use Q-PRIN1 etc. TTY -- Ok, expands into TTY-DE which calls Q-PRIN2 and Q-TERPRI. SAY -- I don't know what to do with this crock. It seems to be a poor substitute for TTY. If so it can be changed to TTY with the arguments fixed to be correct. <!GRAM>LPARSE.LSP When *BATCHOUT is NIL, output is done in realtime and *BATCHQUEUE remains NIL. When *BATCHOUT is true, output is queued and SEND executes&dequeues it later. Initialize *BATCHQUEUE for TCONC operations. Initialize *BATCHMAX and *BATCHCNT These call PRIN2, so they would cause double-enqueuing. DE Q!-TTY!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-DE) !#CMDS)) ( 1 (TTY!-DE !#CMDS)))) DE Q!-TTY!-XT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-XT!-DE) !#CMDS)) (1 (TTY!-XT!-DE !#CMDS)))) DE Q!-TTY!-TX!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TX!-DE) !#CMDS)) (1 (TTY!-TX!-DE !#CMDS)))) DE Q!-TTY!-TT!-DE (!#CMDS) (COND BATCHOUT (ENQUEUE (QUOTE TTY!-TT!-DE) !#CMDS)) (1 (TTY!-TT!-DE !#CMDS)))) YCNTRL -- ROUTINES INVOLVED WITH PROGRAM CONTROL STRUCTURES CATCH ( EXP:s-expression LABELS:id or idlist ):any EXPR THROW ( VALU:any LABEL:id ): error label EXPR ERRSET-DE ( #EXP #LBL ):any EXPR APPLY# ( ARG1: function ARG2: argument:list ):any EXPR BOUND ( X:any ):boolean EXPR MKPROG ( VARS:id-lst BODY:exp ):prog EXPR BUG-STOP (): any EXPR CATCH( EXP:s-expression LABELS:id or idlist ): any EXPR ----- For use with throw. If no THROW occurs in expression, then returns value of expression. If thrown label is MEMQ or EQ to labels, then returns thrown value. OW, thrown label is passed up higher. Expression should be quoted, as in ERRORSET. THROW( VALU:any LABEL:id ): error label EXPR ----- Throws value with label up to enclosing CATCH having label. If there is no such CATCH, causes error. ERRSET-DE ( EXP LBL ):any EXPR Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. Usually called via ERRSET macro. APPLY#(ARG1: function ARG2: argument:list): any EXPR ------ Like APPLY, but can use fexpr and macro functions. BOUND( X:any ): boolean EXPR ----- Returns T if X is a bound id. MKPROG( VARS:id-lst BODY:exp ) EXPR ------ Makes a prog around the body, binding the vars. BUGSTOP ():NIL EXPR ------- Enter a read/eval/print loop, exit when OK is seen. YRARE -- ROUTINES WHICH ARE USED, BUT OF DUBIOUS USEFULNESS ?? DELETE THESE ?? LOADV ( V:vector FN:function ):vector EXPR AMONG ( ALST KEY ITEM ) EXPR INSERT ( ITEM ALST KEY ) EXPR DCONS ( X:any Y:list ):list EXPR SUBLIST ( X:list P1:integer P2:integer ):list EXPR SUBLIST1( Y ) EXPR LDIFF ( X:list Y:list ):list EXPR used in editor/copy in ZEDIT MAPCAR# ( L:list FN:function ):any EXPR MAP# ( L:list FN:function ):any EXPR INITIALP( X:list Y:list ):boolean EXPR SUBLISTP( X:list Y:list ):list EXPR INITQ ( X:any Y:list R:fn ):boolean EXPR LOADV( V:vector FN:function ):vector EXPR ----- Loads vector with values. Function should be 1-place numerical. V[I] _ FN( I ). If value of function is 'novalue, then doesn't change value. ?? AMONG(ALST:association-list KEY:atom ITEM:atom):boolean EXPR ----- Tests if item is found under key in association list. Uses EQUAL tests. INSERT (ITEM:item ALST:association:list KEY:any):association list ------ EXPR (destructive operation on ALST) Inserts item in association list under key or if key not present adds (KEY ITEM) to the ALST. DCONS( X:any Y:list ):list EXPR ----- Destructively cons x to list. SUBLIST( X:list P1:integer P2:integer ):list EXPR ------- Returns sublist from p1 to p2 positions, negatives counting from end. I.e., (SUBLIST '(A B C D E) 2 -2) = (B C D) LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X. MAPCAR#( L:list FN:function ):any EXPR ------- Extends mapcar to work on general s-expressions as well as lists. The return is of same form, i.e. (MAPCAR# 'ATOM '(A B C . D)) = (T T T . T) Also, if for any member of list the variable SPLICE is set to true by function, then for that member the return from the function is spliced into the return. MAP#( L:list FN:function ):any EXPR ---- Extends map to work on general s-expressions as well as lists. INITIALP( X:list Y:list ):boolean EXPR -------- Returns T if X is EQUAL to some ldiff of Y. SUBLISTP( X:list Y:list ):list EXPR -------- Returns a tail of Y (or T) if X is a sublist of Y. INITQ( X:any Y:list R:fn ):boolean EXPR ----- Returns T if x is an initial portion of Y under the relation R. |
Added psl-1983/help/zfiles.hlp version [018d03b902].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ZFILES.HLP 2 Jan, 1982/MLG ========== This is a loadable option (Load ZFiles). File package of IMSSS series, contains 2 packages -- (1) YFILES -- useful functions for accessing files. (2) YTOPCOM -- useful functions for compiling files. See PD:ZFILES.DOC and PU:ZFILES.LSP for more info %%%% YFILES -- BASIC FILE ACCESSING UTILITIES An IMSSS File descriptor is a canonical FILE name, gets converted to file string: FILE or (FILE) -> "FILE.LSP" (FILE.EXT) -> "File.Ext" (DIR FILE) -> "<Dir>File.LSP" (DIR FILE EXT) -> "<dir>File.Ext" "xxx" -> "xxx" --------------------------------------------------------------- FORM-FILE ( FILE:DSCR ): filename EXPR GRABBER ( SELECTION FILE:DSCR ): NIL EXPR DUMPER ( FILE:DSCR ): NIL EXPR DUMPFNS-DE ( SELECTION FILE:DSCR ): NIL EXPR DUMP-REMAINING ( SELECTION:list DUMPED:list ): NIL EXPR FCOPY ( IN:DSCR OUT:DSCR filedscrs ):boolean EXPR REFPRINT-FOR-GRAB-CTL( #X: any ):NIL EXPR G:CREFON Switched on by cross reference program CREF:FILE G:JUST:FNS Save only fn names in variable whose name is the first field of filename if T, O/W save all exprs in that variable G:FILES List of files read into LISP G:SHOW:TRACE Turns backtrace in ERRORSET on if T G:SHOW:ERRORS Prints ERRORSET error messages if T %%%% YTOPCOM -- Compiler Control functions PPLAP( MODE CODE ) EXPR COMPILE-FILE( FILE:DSCR ) FEXPR COMPILE-IN-CORE( FILE:DSCR ):NIL FEXPR GCMSG( X:boolean ):any EXPR |
Added psl-1983/help/zpedit.hlp version [1a336e27f6].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | ZPEDIT: PSL Structure Editor MLG/ 2 January 1982 ---------------------------- [This short help file needs a LOT of work] This is a loadable option (Load ZPEdit). When loaded, this will replace and extend the MiniEditor normally used in the Break Loop and by the function Edit. For information on other Editors see (Help Editor). For more information on the basic commands do (Help MiniEditor). Based on the BBN-Lisp editor, circa 1968, and its descendants. ZPEDIT was modified by IMSSS. See PD:ZPEDIT.DOC for full details. |
Added psl-1983/kernel/alloc.build version [dbcb4e1e79].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | % % ALLOC.BUILD - Files dealing with allocation of memory blocks % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "allocators.red"$ % heap, symbol and code space alloc PathIn "copiers.red"$ % copying functions PathIn "cons-mkvect.red"$ % SL constructor functions PathIn "comp-support.red"$ % optimized CONS and LIST compilation PathIn "system-gc.red"$ % system-specific GC routines PathIn "gc.red"$ % the garbage collector |
Added psl-1983/kernel/allocators.red version [afdacad2be].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ALLOCATORS.RED - Low level storage management % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 16 Feb 1983 1834-PST % Pre-GC trap, known-free-space fns % <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE % Added GtEVect on SysLisp; external WArray BPS, Heap; if_system(PDP10, << % For the compacting GC exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize], HeapTrapBound = &Heap[HeapSize]; % Value of HeapLast for trap >>, << exported WVar HeapLast = &Heap[0], % pointer to next free slot in heap HeapLowerBound = &Heap[0], % bottom of heap HeapUpperBound = &Heap[HeapSize/2], % end of active heap OldHeapLast, OldHeapLowerBound = &Heap[HeapSize/2 + 1], OldHeapUpperBound = &Heap[HeapSize], HeapTrapBound = &Heap[HeapSize/2]; % Value of HeapLast for trap >>); exported WVar HeapTrapped = NIL; % Boolean: trap since last GC? compiletime flag('(GtHeap1), 'InternalFunction); syslsp procedure Known!-Free!-Space; MkInt((HeapUpperBound - HeapLast)/AddressingUnitsPerItem); syslsp procedure GtHEAP N; %. get heap block of N words if null N then known!-free!-space() else GtHeap1(N, NIL); syslsp procedure GtHeap1(N, LastTryP); begin scalar PrevLast; PrevLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapTrapBound then if HeapLast > HeapUpperBound then << HeapLast := PrevLast; if LastTryP then FatalError "Heap space exhausted" else << !%Reclaim(); return GtHeap1(N, T) >> >> else %% From one GC to the next there can be at most 1 GC trap, %% done the first time space gets "low". %Reclaim resets %% HeapTrapped to NIL. if HeapTrapped = NIL then << HeapTrapped := T; GC!-Trap() >>; return PrevLast end; syslsp procedure GC!-Trap!-Level; MkInt (HeapUpperBound - HeapTrapBound)/AddressingUnitsPerItem; syslsp procedure Set!-GC!-Trap!-Level N; << if not IntP(N) then NonIntegerError(N, 'Set!-GC!-Trap!-Level); N := IntInf N; HeapTrapBound := HeapUpperBound - N*AddressingUnitsPerItem; T >>; syslsp procedure DelHeap(LowPointer, HighPointer); if HighPointer eq HeapLast then HeapLast := LowPointer; syslsp procedure GtSTR N; %. Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtConstSTR N; %. allocate un-collected string for print name begin scalar S, NW; % same as GtSTR, but uses BPS, not heap S := GtBPS((NW := STRPack N) + 1); @S := N; S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtHalfWords N; %. Allocate space for N halfwords begin scalar S, NW; S := GtHEAP((NW := HalfWordPack N) + 1); @S := MkItem(HHalfWords, N); return S; end; syslsp procedure GtVECT N; %. Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; Putd('GtEvect,'expr,cdr getd 'GtVect); syslsp procedure GtWRDS N; %. Allocate space for N untraced words begin scalar W; W := GtHEAP(WRDPack N + 1); @W := MkItem(HWRDS, N); return W; end; syslsp procedure GtFIXN(); %. allocate space for a fixnum begin scalar W; W := GtHEAP(WRDPack 0 + 1); @W := MkItem(HWRDS, 0); return W; end; syslsp procedure GtFLTN(); %. allocate space for a float begin scalar W; W := GtHEAP(WRDPack 1 + 1); @W := MkItem(HWRDS, 1); return W; end; % NextSymbol and SymbolTableSize are globally declared syslsp procedure GtID(); %. Allocate a new ID % % IDs are allocated as a linked free list through the SymNam cell, % with a 0 to indicate the end of the list. % begin scalar U; if NextSymbol = 0 then << Reclaim(); if NextSymbol = 0 then return FatalError "Ran out of ID space" >>; U := NextSymbol; NextSymbol := SymNam U; return U; end; exported WVar NextBPS = &BPS[0], LastBPS = &BPS[BPSSize]; syslsp procedure GtBPS N; %. Allocate N words for binary code begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GTBPS NIL returns # left B := NextBPS; NextBPS := NextBPS + N*AddressingUnitsPerItem; return if NextBPS > LastBPS then StdError '"Ran out of binary program space" else B; end; syslsp procedure DelBPS(Bottom, Top); %. Return space to BPS if NextBPS eq Top then NextBPS := Bottom; syslsp procedure GtWArray N; %. Allocate N words for WVar/WArray/WString begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GtWArray NIL returns # left B := LastBPS - N*AddressingUnitsPerItem; return if NextBPS > B then StdError '"Ran out of WArray space" else LastBPS := B; end; syslsp procedure DelWArray(Bottom, Top); %. Return space for WArray if LastBPS eq Bottom then LastBPS := Top; off SysLisp; END; |
Added psl-1983/kernel/arith.build version [48c248f65c].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % % ARITH.BUILD - Files dealing with arithmetic % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "arithmetic.red"$ % Lisp arithmetic functions |
Added psl-1983/kernel/arithmetic.red version [23d2898843].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 January 1982 % Copyright (c) 1982 University of Utah % CompileTime flag('(TwoArgDispatch TwoArgDispatch1 TwoArgError OneArgDispatch OneArgDispatch1 OneArgPredicateDispatch OneArgPredicateDispatch1 OneArgError IntAdd1 IntSub1 IntPlus2 IntTimes2 IntDifference IntQuotient IntRemainder IntLShift IntLAnd IntLOr IntLXOr IntGreaterP IntLessP IntMinus IntMinusP IntZeroP IntOneP IntLNot FloatIntArg FloatAdd1 FloatSub1 FloatPlus2 FloatTimes2 FloatQuotient FloatRemainder FloatDifference FloatGreaterP FloatLessP FloatMinus FloatMinusP FloatZeroP FloatOneP StaticIntFloat FloatFix NonInteger1Error NonInteger2Error MakeFixnum BigFloatFix), 'InternalFunction); on SysLisp; CompileTime << syslsp macro procedure IsInum U; list('(lambda (X) (eq (SignedField X (ISub1 (WConst InfStartingBit)) (IAdd1 (WConst InfBitLength))) X)), second U); >>; internal WConst IntFunctionEntry = 0, FloatFunctionEntry = 1, FunctionNameEntry = 2; syslsp procedure TwoArgDispatch(FirstArg, SecondArg); TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg); lap '((!*entry TwoArgDispatch1 expr 4) (!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 3)) NotNeg1 (!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 4)) NotNeg2 (!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN)) (!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN)) (!*WSHIFT (reg 3) (WConst 2)) (!*WPLUS2 (reg 4) (reg 3)) (!*POP (reg 3)) (!*JUMPON (reg 4) 0 15 ((Label IntInt) (Label IntFix) (Label TemporaryNonEntry) (Label IntFloat) (Label FixInt) (Label FixFix) (Label TemporaryNonEntry) (Label FixFloat) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label TemporaryNonEntry) (Label FloatInt) (Label FloatFix) (Label TemporaryNonEntry) (Label FloatFloat))) TemporaryNonEntry (!*JCALL TwoArgError) FixInt (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) FixFix (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) IntInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) FixFloat (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) FloatFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) FloatInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) FloatFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) NonNumeric (!*POP (reg 3)) (!*JCALL TwoArgError) ); syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger1Error(Arg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], Arg)); syslsp procedure OneArgDispatch FirstArg; OneArgDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label TemporaryNonEntry) (Label OneFloat))) TemporaryNonEntry (!*JCALL OneArgError) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) OneFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) ); syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg)); syslsp procedure OneArgPredicateDispatch FirstArg; OneArgPredicateDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgPredicateDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label TemporaryNonEntry) (Label OneFloat))) TemporaryNonEntry (!*MOVE (QUOTE NIL) (reg 1)) (!*EXIT 0) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*JUMP (MEMORY (MEMORY (reg 3) (WConst 0)) (WConst 0))) OneFloat (!*JUMP (MEMORY (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (WConst 0))) ); syslsp procedure MakeFixnum N; begin scalar F; F := GtFIXN(); FixVal F := N; return MkFIXN F; end; syslsp procedure BigFloatFix N; StdError '"Bignums not yet supported"; syslsp procedure ReturnNIL(); NIL; syslsp procedure ReturnFirstArg Arg; Arg; internal WArray StaticFloatBuffer = [1, 0, 0]; internal WVar StaticFloatItem = MkItem(FLTN, StaticFloatBuffer); syslsp procedure StaticIntFloat Arg; << !*WFloat(&StaticFloatBuffer[1], Arg); StaticFloatItem >>; off SysLisp; CompileTime << macro procedure DefArith2Entry U; DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U); macro procedure DefArith1Entry U; DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U); macro procedure DefArith1PredicateEntry U; DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U); lisp procedure StupidParserFix X; % Goddamn Rlisp parser won't let me just give "Difference" as the parameter % to a macro if null X then X else RemQuote car X . StupidParserFix cdr X; lisp procedure RemQuote X; if EqCar(X, 'QUOTE) then cadr X else X; lisp procedure DefArithEntry L; SublA(Pair('(NumberOfArguments DispatchRoutine NameOfFunction IntFunction BigFunction FloatFunction), L), quote(lap '((!*entry NameOfFunction expr NumberOfArguments) (!*Call DispatchRoutine) (fullword (InternalEntry IntFunction)) % (fullword (InternalEntry BigFunction)) (fullword (InternalEntry FloatFunction)) (fullword (MkItem (WConst ID) (IDLoc NameOfFunction)))))); >>; DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2); syslsp procedure IntPlus2(FirstArg, SecondArg); if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatPlus2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FPlus2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference); syslsp procedure IntDifference(FirstArg, SecondArg); if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatDifference(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2); % What about overflow? syslsp procedure IntTimes2(FirstArg, SecondArg); begin scalar Result; Result := WTimes2(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatTimes2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FTimes2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient); syslsp procedure IntQuotient(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); Result := WQuotient(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatQuotient(FirstArg, SecondArg); begin scalar F; if FloatZeroP SecondArg then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); F := GtFLTN(); !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder); syslsp procedure IntRemainder(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Remainder", Remainder(FirstArg, SecondArg)); Result := WRemainder(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatRemainder(FirstArg, SecondArg); begin scalar F; % This is pretty silly F := GtFLTN(); % might be better to signal an error !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); !*FTimes2(FloatBase F, FloatBase F, FloatBase FltInf SecondArg); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase F); return MkFLTN F; end; DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error); syslsp procedure IntLAnd(FirstArg, SecondArg); if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error); syslsp procedure IntLOr(FirstArg, SecondArg); if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error); syslsp procedure IntLXOr(FirstArg, SecondArg); if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error); PutD('LSH, 'EXPR, cdr GetD 'LShift); syslsp procedure IntLShift(FirstArg, SecondArg); begin scalar Result; Result := WShift(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP); syslsp procedure IntGreaterP(FirstArg, SecondArg); WGreaterP(FirstArg, SecondArg); syslsp procedure FloatGreaterP(FirstArg, SecondArg); !*FGreaterP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP); syslsp procedure IntLessP(FirstArg, SecondArg); WLessP(FirstArg, SecondArg); syslsp procedure FloatLessP(FirstArg, SecondArg); !*FLessP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1); syslsp procedure IntAdd1 FirstArg; if IsInum(FirstArg := WPlus2(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatAdd1 FirstArg; FloatPlus2(FirstArg, 1.0); DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1); lisp procedure IntSub1 FirstArg; if IsInum(FirstArg := WDifference(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatSub1 FirstArg; FloatDifference(FirstArg, 1.0); DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error); lisp procedure IntLNot X; if IsInum(X := WNot X) then X else MakeFixnum X; DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus); lisp procedure IntMinus FirstArg; if IsInum(FirstArg := WMinus FirstArg) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatMinus FirstArg; FloatDifference(0.0, FirstArg); DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix); syslsp procedure FloatFix Arg; begin scalar R; return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R else MakeFixnum R; end; DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg); syslsp procedure FloatIntArg Arg; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, Arg); return MkFLTN F; end; DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP); syslsp procedure IntMinusP FirstArg; WLessP(FirstArg, 0); lisp procedure FloatMinusP FirstArg; FloatLessP(FirstArg, 0.0); DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP); lisp procedure IntZeroP FirstArg; FirstArg = 0; lisp procedure FloatZeroP FirstArg; EQN(FirstArg, 0.0); DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP); lisp procedure IntOneP FirstArg; FirstArg = 1; lisp procedure FloatOneP FirstArg; EQN(FirstArg, 1.0); END; |
Added psl-1983/kernel/autoload-trace.red version [ee4aab36d8].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % % AUTOLOAD-TRACE.RED - Autoloading stubs for DEBUG % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1982 % Copyright (c) 1982 University of Utah % % This file is used instead of MINI-TRACE.RED for those systems which % can load files lisp macro procedure TR U; << load Debug; Apply('TR, list U) >>; lisp macro procedure TRST U; << load Debug; Apply('TRST, list U) >>; END; |
Added psl-1983/kernel/autoload.red version [790c53bc2d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % AUTOLOAD.RED - Autoloading entry stubs % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 March 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL>AUTOLOAD.RED.3, 17-Sep-82 16:35:02, Edit by BENSON % Changed PrettyPrint to use PrettyPrint, not Pretty CompileTime << macro procedure DefAutoload U; % % (DefAutoload name), (DefAutoload name loadname), % (DefAutoload name loadname fntype), or % (DefAutoload name loadname fntype numargs) % % Default is 1 Arg EXPR in module of same name % begin scalar Name, NumArgs, LoadName, FnType; U := rest U; Name := first U; U := rest U; if not null U then << LoadName := first U; U :=rest U >> else LoadName := Name; if EqCar(Name, 'QUOTE) then Name := second Name; if EqCar(LoadName, 'QUOTE) then LoadName := second LoadName; if not null U then << FnType := first U; U := rest U >> else FnType := 'EXPR; if not null U then NumArgs := first U else NumArgs := 1; NumArgs := MakeArgList NumArgs; return list('PutD, MkQuote Name, MkQuote FnType, list('function, list('lambda, NumArgs, list('load, LoadName), list('Apply, MkQuote Name, 'list . NumArgs)))); end; lisp procedure MakeArgList N; GetV('[() (X1) (X1 X2) (X1 X2 X3) (X1 X2 X3 X4) (X1 X2 X3 X4 X5)], N); >>; DefAutoload PrettyPrint; DefAutoload(DefStruct, DefStruct, FEXPR); DefAutoload(Step); DefAutoload Mini; DefAutoload('Help, 'Help, FEXPR); DefAutoload(Emode, Emode, EXPR, 0); DefAutoload(Invoke, Mini); PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); DefAutoload(CrefOn, RCref, EXPR, 0); put('Syslisp, 'SimpFg, '((T (load Syslisp)))); DefAutoload(CompD, Compiler, EXPR, 3); DefAutoload(FaslOUT, Compiler); if_system(Tops20, << DefAutoload(Bug, Bug, EXPR, 0); DefAutoload(MM, Exec, EXPR, 0); DefAutoload(Exec, Exec, EXPR, 0); >>); END; |
Added psl-1983/kernel/backtrace.red version [970f71f38a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.KERNEL>BACKTRACE.RED.3, 20-Sep-82 10:21:41, Edit by BENSON % Attempt to make output easier to read CompileTime flag('(Backtrace1 BacktraceRange), 'InternalFunction); fluid '(IgnoredInBacktrace!* Options!* InterpreterFunctions!*); IgnoredInBacktrace!* := '(Eval Apply FastApply CodeApply CodeEvalApply Catch ErrorSet EvProgN TopLoop BreakEval BindEval Break Main); InterpreterFunctions!* := '(Cond Prog And Or ProgN SetQ); on SysLisp; external WVar StackLowerBound, HeapUpperBound; syslsp procedure InterpBacktrace(); begin scalar Here; Here := &Here; PrintF "Backtrace, including interpreter functions, from top of stack:%n"; return BacktraceRange(Here, StackLowerBound, 1); end; syslsp procedure Backtrace(); begin scalar Here, X; Here := &Here; PrintF "Backtrace from top of stack:%n"; return BacktraceRange(Here, StackLowerBound, 0); end; syslsp procedure BacktraceRange(Starting, Ending, InterpFlag); begin scalar X; for I := Starting step -(AddressingUnitsPerItem*StackDirection) until Ending do if Tag @I eq BtrTag then Backtrace1(MkID Inf @I, InterpFlag) else if (X := ReturnAddressP @I) then Backtrace1(X, InterpFlag); return TerPri(); end; syslsp procedure VerboseBacktrace(); begin scalar Here, X; if not 'addr2id member options!* then load addr2id; Here := &Here; % start a little before here for I := Here step -(AddressingUnitsPerItem*StackDirection) until StackLowerBound do if CodeP @I and Inf @I > HeapUpperBound then << WriteChar char TAB; ChannelWriteUnknownItem(LispVar OUT!*, @I); TerPri() >> else if Tag @I eq BtrTag then PrintF(" %r%n", MkID Inf @I) else if (X := ReturnAddressP @I) then PrintF("%p -> %p:%n", code!-address!-to!-symbol Inf @I, X) else PrintF(" %p%n", @I); return TerPri(); end; off SysLisp; lisp procedure Backtrace1(Item, Code); % % Code is 1 if Interpreter functions should be printed, 0 if not. % if not (Item memq IgnoredInBacktrace!*) then if not (Code = 0 and Item memq InterpreterFunctions!*) then << Prin1 Item; WriteChar char BLANK >>; END; |
Added psl-1983/kernel/binding.red version [b1ac91bb47].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BINDING.RED - Primitives to support Lambda binding % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>BINDING.RED.2, 21-Dec-82 15:57:06, Edit by BENSON % Added call to %clear-catch-stack in ClearBindings % Support for binding in compiled code is in FAST-BINDER.RED on SysLisp; internal WConst BndStkSize = 2000; internal WArray BndStk[BndStkSize]; % Only these WVars, which contain addresses rather than indexes, will be % used to access the binding stack exported WVar BndStkLowerBound = &BndStk[0], BndStkUpperBound = &BndStk[BndStkSize-1], BndStkPtr = &BndStk[0]; % Only the macros BndStkID, BndStkVal and AdjustBndStkPtr will be used % to access or modify the binding stack and pointer. syslsp procedure BStackOverflow(); << ChannelPrin2(LispVar ErrOUT!*, "***** Binding stack overflow, restarting..."); ChannelWriteChar(LispVar ErrOUT!*, char EOL); Reset() >>; syslsp procedure BStackUnderflow(); << ChannelPrin2(LispVar ErrOUT!*, "***** Binding stack underflow, restarting..."); ChannelWriteChar(LispVar ErrOUT!*, char EOL); Reset() >>; syslsp procedure CaptureEnvironment(); %. Save bindings to be restored BndStkPtr; syslsp procedure RestoreEnvironment Ptr; %. Restore old bindings << if Ptr < BndStkLowerBound then BStackUnderflow() else while BndStkPtr > Ptr do << SymVal BndStkID BndStkPtr := BndStkVal BndStkPtr; BndStkPtr := AdjustBndStkPtr(BndStkPtr, -1) >> >>; syslsp procedure ClearBindings(); %. Restore bindings to top level << RestoreEnvironment BndStkLowerBound; !%clear!-catch!-stack() >>; syslsp procedure UnBindN N; %. Support for Lambda and Prog interp RestoreEnvironment AdjustBndStkPtr(BndStkPtr, -IntInf N); syslsp procedure LBind1(IDName, ValueToBind); %. Support for Lambda if not IDP IDName then NonIDError(IDName, "binding") else if null IDName or IDName eq 'T then StdError '"T and NIL cannot be rebound" else << BndStkPtr := AdjustBndStkPtr(BndStkPtr, 1); if BndStkPtr > BndStkUpperBound then BStackOverflow() else << IDName := IDInf IDName; BndStkID BndStkPtr := IDName; BndStkVal BndStkPtr := SymVal IDName; SymVal IDName := ValueToBind >> >>; syslsp procedure PBind1 IDName; %. Support for PROG LBind1(IDName, NIL); off SysLisp; END; |
Added psl-1983/kernel/break.red version [c93d6df10c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BREAK.RED - Break using new top loop % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>BREAK.RED.2, 11-Oct-82 17:52:13, Edit by BENSON % Changed CATCH/THROW to new definition % <PSL.INTERP>BREAK.RED.6, 28-Jul-82 14:29:59, Edit by BENSON % Added A for abort-to-top-level % <PSL.INTERP>BREAK.RED.3, 30-Apr-82 14:34:33, Edit by BENSON % Added binding of !*DEFN to NIL fluid '(!*Break !*QuitBreak BreakEval!* BreakName!* BreakValue!* ErrorForm!* BreakLevel!* MaxBreakLevel!* TopLoopName!* TopLoopEval!* TopLoopRead!* TopLoopPrint!* !*DEFN % break binds !*DEFN to NIL BreakIn!* BreakOut!*); LoadTime << BreakLevel!* := 0; MaxBreakLevel!* := 5; >>; lisp procedure Break(); %. Enter top loop within evaluation (lambda(BreakLevel!*); begin scalar OldIn, OldOut, !*QuitBreak,BreakValue!*, !*Defn; OldIn := RDS BreakIn!*; OldOut := WRS BreakOut!*; !*QuitBreak := T; if TopLoopName!* then << if TopLoopEval!* neq 'BreakEval then << BreakEval!* := TopLoopEval!*; BreakName!* := ConCat(TopLoopName!*, " break") >>; Catch('!$Break!$, TopLoop(TopLoopRead!*, TopLoopPrint!*, 'BreakEval, BreakName!*, "Break loop")) >> else << BreakEval!* := 'Eval; BreakName!* := "lisp break"; Catch('!$Break!$, TopLoop('Read, 'Print, 'BreakEval, BreakName!*, "Break loop")) >>; RDS OldIn; WRS OldOut; return if !*QuitBreak then begin scalar !*Break, !*EmsgP; return StdError "Exit to ErrorSet"; end else Eval ErrorForm!*; end)(BreakLevel!* + 1); lisp procedure BreakEval U; begin scalar F; return if IDP U and (F := get(U, 'BreakFunction)) then Apply(F, NIL) else BreakValue!*:=Apply(BreakEval!*, list U); end; lisp procedure BreakQuit(); << !*QuitBreak := T; Throw('!$Break!$, NIL) >>; lisp procedure BreakContinue(); << ErrorForm!* := MkQuote BreakValue!*; BreakRetry() >>; lisp procedure BreakRetry(); if !*ContinuableError then << !*QuitBreak := NIL; Throw('!$Break!$, NIL) >> else << Prin2T "Can only continue from a continuable error; use Q (BreakQuit) to quit"; TerPri() >>; lisp procedure HelpBreak(); << EvLoad '(HELP); DisplayHelpFile 'Break >>; lisp procedure BreakErrMsg(); PrintF("ErrorForm!* : %r %n", ErrorForm!*); lisp procedure BreakEdit(); if GetD 'Edit then ErrorForm!* := Edit ErrorForm!* else ErrorPrintF("*** Editor not loaded"); LoadTime DefList('((Q BreakQuit) (!? HelpBreak) (A Reset) % Abort to top level (M BreakErrMsg) (E BreakEdit) (C BreakContinue) (R BreakRetry) (I InterpBackTrace) (V VerboseBackTrace) (T BackTrace)), 'BreakFunction); END; |
Added psl-1983/kernel/bug-fix.template version [fbca48ba66].
> > > > > > > > | 1 2 3 4 5 6 7 8 | Bug: Fix: By: Date: Source: Module: Remarks: |
Added psl-1983/kernel/carcdr.red version [93d290a6f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CARCDR.RED - Composites of CAR and CDR, up to 4 levels % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>CARCDR.RED.3, 4-Jul-82 13:29:21, Edit by BENSON % CAR and CDR of NIL are legal == NIL CompileTime for each X in '( % remove all compiler optimizations CAAAAR CAAAR CAAR % for CAR and CDR composites CAAADR CAADR CADR CAADAR CADAR CDAR CAADDR CADDR CDDR CADAAR CDAAR CADADR CDADR CADDAR CDDAR CADDDR CDDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR ) do Put(X, 'SaveCMACRO, RemProp(X, 'CMACRO)); lisp procedure CAAAAR U; %. if null U then NIL else if PairP U then CAAAR CAR U else NonPairError(U, 'CAAAAR); lisp procedure CAAADR U; %. if null U then NIL else if PairP U then CAAAR CDR U else NonPairError(U, 'CAAADR); lisp procedure CAADAR U; %. if null U then NIL else if PairP U then CAADR CAR U else NonPairError(U, 'CAADAR); lisp procedure CAADDR U; %. if null U then NIL else if PairP U then CAADR CDR U else NonPairError(U, 'CAADDR); lisp procedure CADAAR U; %. if null U then NIL else if PairP U then CADAR CAR U else NonPairError(U, 'CADAAR); lisp procedure CADADR U; %. if null U then NIL else if PairP U then CADAR CDR U else NonPairError(U, 'CADADR); lisp procedure CADDAR U; %. if null U then NIL else if PairP U then CADDR CAR U else NonPairError(U, 'CADDAR); lisp procedure CADDDR U; %. if null U then NIL else if PairP U then CADDR CDR U else NonPairError(U, 'CADDDR); lisp procedure CDAAAR U; %. if null U then NIL else if PairP U then CDAAR CAR U else NonPairError(U, 'CDAAAR); lisp procedure CDAADR U; %. if null U then NIL else if PairP U then CDAAR CDR U else NonPairError(U, 'CDAADR); lisp procedure CDADAR U; %. if null U then NIL else if PairP U then CDADR CAR U else NonPairError(U, 'CDADAR); lisp procedure CDADDR U; %. if null U then NIL else if PairP U then CDADR CDR U else NonPairError(U, 'CDADDR); lisp procedure CDDAAR U; %. if null U then NIL else if PairP U then CDDAR CAR U else NonPairError(U, 'CDDAAR); lisp procedure CDDADR U; %. if null U then NIL else if PairP U then CDDAR CDR U else NonPairError(U, 'CDDADR); lisp procedure CDDDAR U; %. if null U then NIL else if PairP U then CDDDR CAR U else NonPairError(U, 'CDDDAR); lisp procedure CDDDDR U; %. if null U then NIL else if PairP U then CDDDR CDR U else NonPairError(U, 'CDDDDR); lisp procedure CAAAR U; %. if null U then NIL else if PairP U then CAAR CAR U else NonPairError(U, 'CAAAR); lisp procedure CAADR U; %. if null U then NIL else if PairP U then CAAR CDR U else NonPairError(U, 'CAADR); lisp procedure CADAR U; %. if null U then NIL else if PairP U then CADR CAR U else NonPairError(U, 'CADAR); lisp procedure CADDR U; %. if null U then NIL else if PairP U then CADR CDR U else NonPairError(U, 'CADDR); lisp procedure CDAAR U; %. if null U then NIL else if PairP U then CDAR CAR U else NonPairError(U, 'CDAAR); lisp procedure CDADR U; %. if null U then NIL else if PairP U then CDAR CDR U else NonPairError(U, 'CDADR); lisp procedure CDDAR U; %. if null U then NIL else if PairP U then CDDR CAR U else NonPairError(U, 'CDDAR); lisp procedure CDDDR U; %. if null U then NIL else if PairP U then CDDR CDR U else NonPairError(U, 'CDDDR); lisp procedure SafeCAR U; if null U then NIL else if PairP U then CAR U else NonPairError(U, 'CAR); lisp procedure SafeCDR U; if null U then NIL else if PairP U then CDR U else NonPairError(U, 'CDR); lisp procedure CAAR U; %. if null U then NIL else if PairP U then SafeCAR CAR U else NonPairError(U, 'CAAR); lisp procedure CADR U; %. if null U then NIL else if PairP U then SafeCAR CDR U else NonPairError(U, 'CADR); lisp procedure CDAR U; %. if null U then NIL else if PairP U then SafeCDR CAR U else NonPairError(U, 'CDAR); lisp procedure CDDR U; %. if null U then NIL else if PairP U then SafeCDR CDR U else NonPairError(U, 'CDDR); CompileTime for each X in '( % restore compiler optimizations CAAAAR CAAAR CAAR % for CAR and CDR composites CAAADR CAADR CADR CAADAR CADAR CDAR CAADDR CADDR CDDR CADAAR CDAAR CADADR CDADR CADDAR CDDAR CADDDR CDDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR ) do Put(X, 'CMACRO, RemProp(X, 'SaveCMACRO)); END; |
Added psl-1983/kernel/catch-throw.red version [01ad24d69a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CATCH-THROW.RED - Common Lisp dynamic non-local exits % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 October 1982 % Copyright (c) 1982 University of Utah % % Edit by Cris Perdue, 23 Feb 1983 1624-PST % Modified the stack overflow warning message % Edit by Cris Perdue, 16 Feb 1983 1032-PST % Changed catch stack overflow checking to give a continuable error % when stack gets low, Reset when all out. % Edit by Cris Perdue, 4 Feb 1983 1209-PST % Moved ERRSET to ERROR-ERRORSET from here. % Edit by Cris Perdue, 3 Feb 1983 1520-PST % Changed catch stack overflow to talk about the CATCH stack. (!) % Deleted definition of "errset". % <PSL.KERNEL>CATCH-THROW.RED.13, 21-Dec-82 15:55:26, Edit by BENSON % Added %clear-catch-stack % <PSL.KERNEL>CATCH-THROW.RED.13, 16-Dec-82 09:58:59, Edit by BENSON % Error not within ErrorSet now causes fatal error, not infinite loop fluid '(ThrowSignal!* EMSG!* ThrowTag!*); macro procedure catch!-all u; (lambda(fn, forms); list(list('lambda, '(!&!&Value!&!&), list('cond, list('ThrowSignal!*, list('Apply, fn, '(list ThrowTag!* !&!&Value!&!&))), '(t !&!&Value!&!&))), 'catch . nil . forms))(cadr U, cddr U); macro procedure unwind!-all u; (lambda(fn, forms); list(list('lambda, '(!&!&Value!&!&), list('Apply, fn, '(list (and ThrowSignal!* ThrowTag!*) !&!&Value!&!&))), 'catch . nil . forms))(cadr U, cddr U); macro procedure unwind!-protect u; (lambda(protected_form, cleanup_forms); list(list('lambda, '(!&!&Value!&!&), list('lambda, '(!&!&Thrown!&!& !&!&Tag!&!&), 'progn . cleanup_forms, '(cond (!&!&Thrown!&!& (!%Throw !&!&Tag!&!& !&!&Value!&!&)) (t !&!&Value!&!&))) . '(ThrowSignal!* ThrowTag!*)), list('catch, ''!$unwind!-protect!$, protected_form)))(cadr U,cddr U); off R2I; % This funny definition is due to a PA1FN for CATCH fexpr procedure Catch U; (lambda(Tag, Forms); Catch(Eval Tag, EvProgN Forms))(car U, cdr U); on R2I; % Temporary compatibility package. macro procedure !*Catch U; 'Catch . cdr U; expr procedure !*Throw(x,y); throw(x,y); on Syslisp; % Size is in terms of number of frames internal WConst CatchStackSize = 400; internal WArray CatchStack[CatchStackSize*4]; internal WVar CatchStackPtr = &CatchStack[0]; CompileTime << smacro procedure CatchPop(); CatchStackPtr := &CatchStackPtr[-4]; smacro procedure CatchStackDecrement X; &X[-4]; % Rather large for a smacro, used only from CatchSetupAux /csp % Tests structured for fast usual execution /csp % Random constant 5 for "reserve" catch stack frames /csp smacro procedure CatchPush(Tag, PC, SP, Env); << CatchStackPtr := &CatchStackPtr[4]; if CatchStackPtr >= &CatchStack[(CatchStackSize-5)*4] then << if CatchStackPtr = &CatchStack[(CatchStackSize-5)*4] then ContinuableError(99,"Catch-throw stack overflow (warning)", NIL); if CatchStackPtr >= &CatchStack[CatchStackSize*4] then << (LispVar EMSG!*) := "Catch stack overflow"; reset() >> >>; CatchStackPtr[0] := Tag; CatchStackPtr[1] := PC; CatchStackPtr[2] := SP; CatchStackPtr[3] := Env >>; smacro procedure CatchTopTag(); CatchStackPtr[0]; smacro procedure CatchTagAt X; X[0]; smacro procedure CatchTopPC(); CatchStackPtr[1]; smacro procedure CatchTopSP(); CatchStackPtr[2]; smacro procedure CatchTopEnv(); CatchStackPtr[3]; flag('(CatchSetupAux ThrowAux FindCatchMarkAndThrow), 'InternalFunction); >>; % CatchSetup puts the return address in reg 2, the stack pointer in reg 3 % and calls CatchSetupAux lap '((!*entry CatchSetup expr 1) %. CatchSetup(Tag) (!*MOVE (MEMORY (reg st) (WConst 0)) (reg 2)) (!*MOVE (reg st) (reg 3)) (!*JCALL CatchSetupAux) ); syslsp procedure CatchSetupAux(Tag, PC, SP); begin scalar Previous; Previous := CatchStackPtr; CatchPush(Tag, PC, SP, CaptureEnvironment()); LispVar ThrowSignal!* := NIL; return Previous; end; syslsp procedure !%UnCatch Previous; << CatchStackPtr := Previous; LispVar ThrowSignal!* := NIL >>; syslsp procedure !%clear!-catch!-stack(); CatchStackPtr := &CatchStack[0]; syslsp procedure !%Throw(Tag, Value); begin scalar TopTag; TopTag := CatchTopTag(); return if not (null TopTag or TopTag eq '!$unwind!-protect!$ or Tag eq TopTag) then << CatchPop(); !%Throw(Tag, Value) >> else begin scalar PC, SP; PC := CatchTopPC(); SP := CatchTopSP(); RestoreEnvironment CatchTopEnv(); CatchPop(); LispVar ThrowSignal!* := T; LispVar ThrowTag!* := Tag; return ThrowAux(Value, PC, SP); end; end; lap '((!*entry ThrowAux expr 3) (!*MOVE (reg 3) (reg st)) (!*MOVE (reg 2) (MEMORY (reg st) (WConst 0))) (!*EXIT 0) ); syslsp procedure Throw(Tag, Value); FindCatchMarkAndThrow(Tag, Value, CatchStackPtr); % Throw to $Error$ that doesn't have a catch can't cause a normal error % else an infinite loop will result. Changed to use FatalError instead. syslsp procedure FindCatchMarkAndThrow(Tag, Value, P); if P = &CatchStack[0] then if not (Tag eq '!$Error!$) then ContError(99, "Catch tag %r not found in Throw", Tag, Throw(Tag, Value)) else FatalError "Error not within ErrorSet" else if null CatchTagAt P or Tag eq CatchTagAt P then !%Throw(Tag, Value) else FindCatchMarkAndThrow(Tag, Value, CatchStackDecrement P); off Syslisp; END; |
Added psl-1983/kernel/char-io.red version [037549e210].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR-IO.RED - Bottom level character IO primitives % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1652-PST % ChannelReadChar and ChannelWriteChar now check the FileDes argument % <PERDUE.PSL>CHAR-IO.RED.2, 29-Dec-82 12:21:51, Edit by PERDUE % Added code to ChannelWriteChar to maintain PagePosition for LPOSN global '(IN!* % The current input channel OUT!*); % The current output channel on SysLisp; external WArray ReadFunction, % Indexed by channel # to read char WriteFunction, % Indexed by channel # to write char UnReadBuffer, % For input backup LinePosition, % For Posn() PagePosition; % For LPosn() syslsp procedure ChannelReadChar FileDes; %. Read one char from channel % % All channel input must pass through this function. When a channel is % open, its read function must be set up. % begin scalar Ch, FD; FD := IntInf FileDes; %/ Heuristic: don't do Int type test if not (0 <= FD and FD <= MaxChannels) then NonIOChannelError(FileDes, "ChannelReadChar"); return if (Ch := UnReadBuffer[FD]) neq char NULL then << UnReadBuffer[FD] := char NULL; Ch >> else IDApply1(FD, ReadFunction[FD]); end; syslsp procedure ReadChar(); %. Read single char from current input ChannelReadChar LispVar IN!*; syslsp procedure ChannelWriteChar(FileDes, Ch); %. Write one char to channel % % All channel output must pass through this function. When a channel is % open, its write function must be set up, and line position set to zero. % begin scalar FD; FD := IntInf FileDes; if not (0 <= FD and FD <= MaxChannels) then NonIOChannelError(FileDes, "ChannelWriteChar"); if Ch eq char EOL then << LinePosition[FD] := 0; PagePosition[FD] := PagePosition[FD] + 1 >> else if Ch eq char TAB then % LPos := (LPos + 8) - ((LPos + 8) MOD 8) LinePosition[FD] := LAND(LinePosition[FD] + 8, LNOT 7) else if Ch eq char FF then << PagePosition[FD] := 0; LinePosition[FD] := 0 >> else LinePosition[FD] := LinePosition[FD] + 1; IDApply2(FD, Ch, WriteFunction[FD]); end; syslsp procedure WriteChar Ch; %. Write single char to current output ChannelWriteChar(LispVar OUT!*, Ch); syslsp procedure ChannelUnReadChar(Channel, Ch); %. Input backup function % % Any channel input backup must pass through this function. The following % restrictions are made on input backup: % 1. Backing up without first doing input should cause an error, but % will probably cause unpredictable results. % 2. Only one character backup is supported. % UnReadBuffer[IntInf Channel] := Ch; syslsp procedure UnReadChar Ch; %. Backup on current input channel ChannelUnReadChar(LispVar IN!*, Ch); off SysLisp; END; |
Added psl-1983/kernel/char.red version [8cc674cb7b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR.RED - Character constant macro % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 August 1981 % Copyright (c) 1981 University of Utah % macro procedure Char U; %. Character constant macro DoChar cadr U; lisp procedure DoChar U; begin scalar ChDef, CharFn; return if IDP U then if (ChDef := get(U, 'CharConst)) then ChDef else if (ChDef := ID2Int U) < 128 then ChDef else CharError U else if PairP U then << CharFn := car U; U := cadr U; if CharFn eq 'QUOTE then DoChar U else if CharFn eq 'LOWER then LOr(DoChar U, 2#100000) else if CharFn memq '(CNTRL CONTROL) then LAnd(DoChar U, 2#11111) else if CharFn eq 'META then LOr(DoChar U, 2#10000000) else CharError U >> else if FixP U and U >= 0 and U <= 9 then U + char !0 else CharError U; end; lisp expr procedure CharError U; << ErrorPrintF("*** Unknown character constant: %r", U); 0 >>; DefList('((NULL 0) (BELL 7) (BACKSPACE 8) (TAB 8#11) (LF 8#12) (RETURN 8#12) % RETURN is LF because it's end-of-line (EOL 8#12) (FF 8#14) (CR 8#15) (ESC 27) (ESCAPE 27) (BLANK 32) (SPACE 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177)), 'CharConst); END; |
Added psl-1983/kernel/comp-support.red version [20da01e823].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMP-SUPPORT.RED - Run-time support for optimized Cons and List compilation % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 September 1981 % Copyright (c) 1981 University of Utah % CommentOutCode << % defined in CONS-MKVECT.RED CompileTime(SavedCompFn := RemProp('Cons, 'CompFn)); % else can't compile lisp procedure NCons U; %. U . NIL, or 1-argument EXPR for LIST U . NIL; lisp procedure XCons(U, V); %. V . U V . U; CompileTime put('Cons, 'CompFn, SavedCompFn); >>; lisp procedure List5(U, V, W, X, Y); %. 5-argument EXPR for LIST U . List4(V, W, X, Y); lisp procedure List4(U, V, W, X); %. 4-argument EXPR for LIST U . List3(V, W, X); lisp procedure List3(U, V, W); %. 3-argument EXPR for LIST U . List2(V, W); lisp procedure List2(U, V); %. 2-argument EXPR for LIST U . NCons V; END; |
Added psl-1983/kernel/compacting-gc.red version [6015e79d8d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GC.RED - Compacting garbage collector for PSL % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % All data types have either explicit header tag in first item, % or are assumed to be 1st element of pair. % Revision History: % Edit by Cris Perdue, 16 Feb 1983 1407-PST % Fixed GtHeap and collector(s) to use only HeapLast, not HeapPreviousLast % Sets HeapTrapped to NIL now. % Using known-free-space function % Added check of Heap-Warn-Level after %Reclaim % Defined and used known-free-space function % <PSL.KERNEL>COMPACTING-GC.RED.9, 4-Oct-82 17:59:55, Edit by BENSON % Added GCTime!* % <PSL.KERNEL>COMPACTING-GC.RED.3, 21-Sep-82 10:43:21, Edit by BENSON % Flagged most functions internal % (M.L. Griss, March, 1977). % (Update to speed up, July 1978) % Converted to Syslisp July 1980 % En-STRUCT-ed, Eric Benson April 1981 % Added EVECT tag, M. Griss, 3 July 1982 fluid '(!*GC % Controls printing of statistics GCTime!* % Total amount of time spent in GC GCKnt!* % count of # of GC's since system build heap!-warn!-level); % Continuable error if this much not % free after %Reclaim. LoadTime << !*GC := T; % Do print GC messages (SL Rep says no) GCTime!* := 0; GCKnt!* := 0; % Initialize to zero Heap!-Warn!-Level := 1000; >>; on Syslisp; % Predicates for whether to follow pointers external WVar HeapLowerBound, % Bottom of heap HeapUpperBound, % Top of heap HeapLast, % Last item allocated HeapTrapped; % Boolean: has trap occurred since GC? CompileTime << flag('(MarkFromAllBases BuildRelocationFields UpdateAllBases CompactHeap MarkFromOneSymbol MakeIDFreeList GCMessage MarkFromSymbols MarkFromRange MarkFromBase MarkFromVector GCError UpdateSymbols UpdateRegion UpdateItem UpdateHeap), 'InternalFunction); syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinHeapPointer X; X >= HeapLowerBound and X <= HeapLast; >>; % Marking primitives internal WConst GCMarkValue = 8#777, HSkip = Forward; CompileTime << syslsp smacro procedure Mark X; % Get GC mark bits in item X points to GCField @X; syslsp smacro procedure SetMark X; % Set GC mark bits in item X points to GCField @X := GCMarkValue; syslsp smacro procedure ClearMark X; % Clear GC mark bits in item X points to GCField @X := if NegIntP @X then -1 else 0; syslsp smacro procedure Marked X; % Is item pointed to by X marked? Mark X eq GCMarkValue; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; % Relocation primitives syslsp smacro procedure SkipLength X; % Stored in heap header Inf @X; syslsp smacro procedure PutSkipLength(X, L); % Store in heap header Inf @X := L; put('SkipLength, 'Assign!-Op, 'PutSkipLength); >>; internal WConst BitsInSegment = 13, SegmentLength = LShift(1, BitsInSegment), SegmentMask = SegmentLength - 1; internal WConst GCArraySize = LShift(HeapSize, -BitsInSegment) + 1; internal WArray GCArray[GCArraySize]; CompileTime << syslsp smacro procedure SegmentNumber X; % Get segment part of pointer LShift(X - HeapLowerBound, -BitsInSegment); syslsp smacro procedure OffsetInSegment X; % Get offset part of pointer LAnd(X - HeapLowerBound, SegmentMask); syslsp smacro procedure MovementWithinSegment X; % Reloc field in item GCField @X; syslsp smacro procedure PutMovementWithinSegment(X, M); % Store reloc field GCField @X := M; syslsp smacro procedure ClearMovementWithinSegment X; % Clear reloc field GCField @X := if NegIntP @X then -1 else 0; put('MovementWithinSegment, 'Assign!-Op, 'PutMovementWithinSegment); syslsp smacro procedure SegmentMovement X; % Segment table GCArray[X]; syslsp smacro procedure PutSegmentMovement(X, M); % Store in seg table GCArray[X] := M; put('SegmentMovement, 'Assign!-Op, 'PutSegmentMovement); syslsp smacro procedure Reloc X; % Compute pointer adjustment X - (SegmentMovement SegmentNumber X + MovementWithinSegment X); >>; external WVar ST, % stack pointer StackLowerBound; % bottom of stack % Base registers marked from by collector % SymNam, SymPrp and SymVal are declared for all external WVar NextSymbol; % next ID number to be allocated external WVar BndStkLowerBound, % Bottom of binding stack BndStkPtr; % Binding stack pointer internal WVar StackEnd, % Holds address of bottom of stack StackStart, % Holds address of top of stack MarkTag, % Used by MarkFromBase only Hole, % First location moved in heap HeapShrink, % Total amount reclaimed StartingRealTime; syslsp procedure Reclaim(); %. User call to garbage collector << !%Reclaim(); NIL >>; syslsp procedure !%Reclaim(); % Garbage collector << StackEnd := MakeAddressFromStackPointer ST - FrameSize(); StackStart := StackLowerBound; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; StartingRealTime := TimC(); LispVar GCKnt!* := LispVar GCKnt!* + 1; % must be INUM > 0, so needn't chk MarkFromAllBases(); MakeIDFreeList(); BuildRelocationFields(); UpdateAllBases(); CompactHeap(); HeapLast := HeapLast - HeapShrink; StartingRealTime := TimC() - StartingRealTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, StartingRealTime); if LispVar !*GC then GCMessage(); HeapTrapped := NIL; if IntInf known!-free!-space() < IntInf (LispVar Heap!-Warn!-Level) then ContinuableError(99, "Heap space low", NIL); >>; syslsp procedure MarkFromAllBases(); begin scalar B; MarkFromSymbols(); MarkFromRange(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do MarkFromBase @B; end; syslsp procedure MarkFromSymbols(); begin scalar B; MarkFromOneSymbol 128; % mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkFromOneSymbol I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkFromOneSymbol B >>; end; syslsp procedure MarkFromOneSymbol X; % SymNam has to be marked from before marking ID, since the mark uses its tag % No problem since it's only a string, can't reference itself. << MarkFromBase SymNam X; MarkID X; MarkFromBase SymPrp X; MarkFromBase SymVal X >>; syslsp procedure MarkFromRange(Low, High); for Ptr := Low step 1 until High do MarkFromBase @Ptr; syslsp procedure MarkFromBase Base; begin scalar MarkInfo; MarkTag := Tag Base; if not PointerTagP MarkTag then return << if MarkTag = ID and not null Base then << MarkInfo := IDInf Base; if not MarkedID MarkInfo then MarkFromOneSymbol MarkInfo >> >>; MarkInfo := Inf Base; if not WithinHeapPointer MarkInfo or Marked MarkInfo then return; SetMark MarkInfo; CommentOutCode CheckAndSetMark MarkInfo; return if MarkTag eq VECT or MarkTag eq EVECT then MarkFromVector MarkInfo else if MarkTag eq PAIR then << MarkFromBase car Base; MarkFromBase cdr Base >>; end; CommentOutCode << syslsp procedure CheckAndSetMark P; begin scalar HeadAtP; HeadAtP := Tag @P; case MarkTag of STR: if HeadAtP eq HBYTES then SetMark P; FIXN, FLTN, BIGN, WRDS: if HeadAtP eq HWRDS then SetMark P; VECT, EVECT: if HeadAtP eq HVECT then SetMark P; PAIR: SetMark P; default: GCError("Internal error in marking phase, at %o", P) end; end; >>; syslsp procedure MarkFromVector Info; begin scalar Uplim; CommentOutCode if Tag @Info neq HVECT then return; Uplim := &VecItm(Info, VecLen Info); for Ptr := &VecItm(Info, 0) step 1 until Uplim do MarkFromBase @Ptr; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure BuildRelocationFields(); % % Pass 2 - Turn off GC marks and Build SEGKNTs % begin scalar CurrentItem, SGCurrent, IGCurrent, TmpIG, DCount, SegLen; SGCurrent := IGCurrent := 0; SegmentMovement SGCurrent := 0; % Dummy Hole := HeapLowerBound - 1; % will be first hole DCount := HeapShrink := 0; % holes in current segment, total holes CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin scalar Incr; SegLen := case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: 2; % must be first of pair HBYTES: 1 + StrPack StrLen CurrentItem; HHalfwords: 1 + HalfWordPack StrLen CurrentItem; HWRDS: 1 + WrdPack WrdLen CurrentItem; HVECT: 1 + VectPack VecLen CurrentItem; HSKIP: SkipLength CurrentItem; default: GCError("Illegal item in heap at %o", CurrentItem) end; % case if Marked CurrentItem then % a hole if HeapShrink = 0 then ClearMark CurrentItem else % segment also clears mark << MovementWithinSegment CurrentItem := DCount; % incremental shift Incr := 0 >> % no shift else << @CurrentItem := MkItem(HSKIP, SegLen); % a skip mark Incr := 1; % more shift if Hole < HeapLowerBound then Hole := CurrentItem >>; TmpIG := IGCurrent + SegLen; % set SEG size CurrentItem := CurrentItem + SegLen; while TmpIG >= SegmentLength do begin scalar Tmp; Tmp := SegmentLength - IGCurrent; % Expand to next SEGMENT SegLen := SegLen - Tmp; if Incr eq 1 then HeapShrink := HeapShrink + Tmp; DCount := IGCurrent := 0; SGCurrent := SGCurrent + 1; SegmentMovement SGCurrent := HeapShrink; % Store Next Base TmpIG := TmpIG - SegmentLength; end; IGCurrent := TmpIG; if Incr eq 1 then << HeapShrink := HeapShrink + SegLen; DCount := DCount + SegLen >>; % Add in Hole Size end; SegmentMovement(SGCurrent + 1) := HeapShrink; end; syslsp procedure UpdateAllBases(); begin scalar B; UpdateSymbols(); UpdateRegion(StackStart, StackEnd); B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do UpdateItem B; UpdateHeap() >>; syslsp procedure UpdateSymbols(); for I := 0 step 1 until MaxSymbols do begin scalar NameLoc; NameLoc := &SymNam I; if StringP @NameLoc then << UpdateItem NameLoc; UpdateItem &SymVal I; UpdateItem &SymPrp I >>; end; syslsp procedure UpdateRegion(Low, High); for Ptr := Low step 1 until High do UpdateItem Ptr; syslsp procedure UpdateHeap(); begin scalar CurrentItem; CurrentItem := HeapLowerBound; while CurrentItem < HeapLast do begin case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND: CurrentItem := CurrentItem + 1; STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: << if Inf @CurrentItem >= Hole and Inf @CurrentItem <= HeapLast then Inf @CurrentItem := Reloc Inf @CurrentItem; CurrentItem := CurrentItem + 1 >>; HBYTES: CurrentItem := CurrentItem + 1 + StrPack StrLen CurrentItem; HHalfwords: CurrentItem := CurrentItem + 1 + HalfwordPack StrLen CurrentItem; HWRDS: CurrentItem := CurrentItem + 1 + WrdPack WrdLen CurrentItem; HVECT: begin scalar Tmp; Tmp := VecLen CurrentItem; CurrentItem := CurrentItem + 1; % Move over header for I := 0 step 1 until Tmp do % VecLen + 1 items begin scalar Tmp2, Tmp3; Tmp2 := @CurrentItem; Tmp3 := Tag Tmp2; if PointerTagP Tmp3 and Inf Tmp2 >= Hole and Inf Tmp2 <= HeapLast then Inf @CurrentItem := Reloc Inf Tmp2; CurrentItem := CurrentItem + 1; end; end; HSKIP: CurrentItem := CurrentItem + SkipLength CurrentItem; default: GCError("Internal error in updating phase at %o", CurrentItem) end; % case end end; syslsp procedure UpdateItem Ptr; begin scalar Tg, Info; Tg := Tag @Ptr; if not PointerTagP Tg then return; Info := INF @Ptr; if Info < Hole or Info > HeapLast then return; Inf @Ptr := Reloc Info; end; syslsp procedure CompactHeap(); begin scalar OldItemPtr, NewItemPtr, SegLen; if Hole < HeapLowerBound then return; NewItemPtr := OldItemPtr := Hole; while OldItemPtr < HeapLast do begin; case Tag @OldItemPtr of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: SegLen := PairPack OldItemPtr; HBYTES: SegLen := 1 + StrPack StrLen OldItemPtr; HHalfwords: SegLen := 1 + HalfWordPack HalfwordLen OldItemPtr; HWRDS: SegLen := 1 + WrdPack WrdLen OldItemPtr; HVECT: SegLen := 1 + VectPack VecLen OldItemPtr; HSKIP: << OldItemPtr := OldItemPtr + SkipLength OldItemPtr; goto WhileNext >>; default: GCError("Internal error in compaction at %o", OldItemPtr) end; % case ClearMovementWithinSegment OldItemPtr; for I := 1 step 1 until SegLen do << @NewItemPtr := @OldItemPtr; NewItemPtr := NewItemPtr + 1; OldItemPtr := OldItemPtr + 1 >>; WhileNext: end; end; syslsp procedure GCError(Message, P); << ErrorPrintF("***** Fatal error during garbage collection"); ErrorPrintF(Message, P); while T do Quit; >>; syslsp procedure GCMessage(); << ErrorPrintF("*** GC %w: time %d ms", LispVar GCKnt!*, StartingRealTime); ErrorPrintF("*** %d recovered, %d stable, %d active, %d free", HeapShrink, Hole - HeapLowerBound, HeapLast - Hole, intinf known!-free!-space() ) >>; off SysLisp; END; |
Added psl-1983/kernel/cons-mkvect.red version [f9e6c27c1f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CONS-MKVECT.RED - Standard Lisp constructor functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 23 Feb 1983 1045-PST % Changed occurrences of HeapUpperbound to HeapTrapBound in optimized % allocators to supported pre-GC traps. % <PSL.KERNEL>CONS-MKVECT.RED.2, 10-Jan-83 15:50:08, Edit by PERDUE % Added MkEVect % Edit by GRISS: (?) % Optimized CONS, XCONS and NCONS % <PSL.INTERP>CONS-MKVECT.RED.5, 9-Feb-82 06:25:51, Edit by GRISS % Added HardCons CompileTime flag('(HardCons), 'InternalFunction); on SysLisp; external WVar HeapLast, HeapTrapBound; syslsp procedure HardCons(U, V); % Basic CONS with car U and cdr V begin scalar P; HeapLast := HeapLast - AddressingUnitsPerItem*PairPack(); P := GtHeap PairPack(); P[0] := U; P[1] := V; return MkPAIR P; end; syslsp procedure Cons(U, V); %. Construct pair with car U and cdr V begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(U, V) else << HP[0] := U; HP[1] := V; MkPAIR HP >> >>; end; syslsp procedure XCons(U, V); %. eXchanged Cons begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(V, U) else << HP[0] := V; HP[1] := U; MkPAIR HP >> >>; end; syslsp procedure NCons U; %. U . NIL begin scalar HP; return << HP := HeapLast; if (HeapLast := HeapLast + AddressingUnitsPerItem*PairPack()) > HeapTrapBound then HardCons(U, NIL) else << HP[0] := U; HP[1] := NIL; MkPAIR HP >> >>; end; syslsp procedure MkVect N; %. Allocate vector, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"A vector with fewer than zero elements cannot be allocated" else begin scalar V; V := GtVect N; for I := 0 step 1 until N do VecItm(V, I) := NIL; return MkVEC V; % Tag it end >> else NonIntegerError(N, 'MkVect); syslsp procedure MkEVECTOR(N,ETAG); %. Allocate Evect, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"An Evect with fewer than zero elements cannot be allocated" else begin scalar V; V := GtEVect N; EVecItm(V,0):=ETAG; for I := 1 step 1 until N do VecItm(V, I) := NIL; return MkEVECT V; % Tag it end >> else NonIntegerError(N, 'MkEVECT); off SysLisp; END; |
Added psl-1983/kernel/cont-error.red version [caba0b1554].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CONT-ERROR.RED - Nice macro to set up arguments for ContinuableError % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>CONT-ERROR.RED.3, 2-Sep-82 09:10:04, Edit by BENSON % Made handling of ReEvalForm more robust % format is: % ContError(ErrorNumber, FormatString, {arguments to PrintF}, ReEvalForm) % ReEvalForm is something like % Foo(X, Y) % which becomes % list('Foo, MkQuote X, MkQuote Y) macro procedure ContError U; %. Set up for ContinuableError begin scalar ErrorNumber, Message, ReEvalForm; U := cdr U; ErrorNumber := car U; U := cdr U; if null cddr U then % if it's just a string, don't << Message := car U; % generate call to BldMsg U := cdr U >> else << while cdr U do << Message := AConc(Message, car U); U := cdr U >>; Message := 'BldMsg . Message >>; ReEvalForm := car U; ReEvalForm := if not PairP ReEvalForm then list('MkQuote, ReEvalForm) else 'list . MkQuote car ReEvalForm . for each X in cdr ReEvalForm collect list('MkQuote, X); return list('ContinuableError, ErrorNumber, Message, ReEvalForm); end; END; |
Added psl-1983/kernel/copiers.red version [fb1c324373].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % COPIERS.RED - Functions for copying various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>COPIERS.RED.2, 28-Sep-82 10:21:15, Edit by PERDUE % Made CopyStringToFrom safe and to not bother clearing the % terminating byte. on SysLisp; syslsp procedure CopyStringToFrom(New, Old); %. Copy all chars in Old to New begin scalar SLen, StripNew, StripOld; StripNew := StrInf New; StripOld := StrInf Old; SLen := StrLen StripOld; if StrLen StripNew < SLen then SLen := StrLen StripNew; for I := 0 step 1 until SLen do StrByt(StripNew, I) := StrByt(StripOld, I); return New; end; syslsp procedure CopyString S; %. copy to new heap string begin scalar S1; S1 := GtSTR StrLen StrInf S; CopyStringToFrom(S1, StrInf S); return MkSTR S1; end; syslsp procedure CopyWArray(New, Old, UpLim); %. copy UpLim + 1 words << for I := 0 step 1 until UpLim do New[I] := Old[I]; New >>; syslsp procedure CopyVectorToFrom(New, Old); %. Move elements, don't recurse begin scalar SLen, StripNew, StripOld; StripNew := VecInf New; StripOld := VecInf Old; SLen := VecLen StripOld; % assumes VecLen New has been set for I := 0 step 1 until SLen do VecItm(StripNew, I) := VecItm(StripOld, I); return New; end; syslsp procedure CopyVector S; %. Copy to new vector in heap begin scalar S1; S1 := GtVECT VecLen VecInf S; CopyVectorToFrom(S1, VecInf S); return MkVEC S1; end; syslsp procedure CopyWRDSToFrom(New, Old); %. Like CopyWArray in heap begin scalar SLen, StripNew, StripOld; StripNew := WrdInf New; StripOld := WrdInf Old; SLen := WrdLen StripOld; % assumes WrdLen New has been set for I := 0 step 1 until SLen do WrdItm(StripNew, I) := WrdItm(StripOld, I); return New; end; syslsp procedure CopyWRDS S; %. Allocate new WRDS array in heap begin scalar S1; S1 := GtWRDS WrdLen WrdInf S; CopyWRDSToFrom(S1, WrdInf S); return MkWRDS S1; end; % CopyPairToFrom is RplacW, found in EASY-NON-SL.RED % CopyPair is: car S . cdr S; % Usual Lisp definition of Copy only copies pairs, is found in EASY-NON-SL.RED syslsp procedure TotalCopy S; %. Unique copy of entire structure begin scalar Len, Ptr, StripS; % blows up on circular structures return case Tag S of PAIR: TotalCopy car S . TotalCopy cdr S; STR: CopyString S; VECT: << StripS := VecInf S; Len := VecLen StripS; Ptr := MkVEC GtVECT Len; for I := 0 step 1 until Len do VecItm(VecInf Ptr, I) := TotalCopy VecItm(VecInf S, I); Ptr >>; WRDS: CopyWRDS S; FIXN: MkFIXN Inf CopyWRDS S; FLTN: MkFLTN Inf CopyWRDS S; default: S end; end; off SysLisp; END; |
Added psl-1983/kernel/copying-gc.red version [67425a6917].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GC.RED - Copying 2-space garbage collector for PSL % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 30 November 1981 % Copyright (c) 1981 Eric Benson % % Edit by Cris Perdue, 16 Feb 1983 1409-PST % Removed external declaration of HeapPreviousLast (the only occurrence) % Now using "known-free-space" function and heap-warn-level % Sets HeapTrapped to NIL now. % Added check of Heap!-Warn!-Level after %Reclaim. % <PSL.KERNEL>COPYING-GC.RED.6, 4-Oct-82 17:56:49, Edit by BENSON % Added GCTime!* fluid '(!*GC GCKnt!* GCTime!* Heap!-Warn!-Level); LoadTime << GCKnt!* := 0; GCTime!* := 0; !*GC := T; LispVar Heap!-Warn!-Level := 1000 >>; on SysLisp; CompileTime << syslsp smacro procedure PointerTagP X; X > PosInt and X < Code; syslsp smacro procedure WithinOldHeapPointer X; X >= !%chipmunk!-kludge OldHeapLowerBound and X <= !%chipmunk!-kludge OldHeapLast; syslsp smacro procedure Mark X; MkItem(Forward, X); syslsp smacro procedure Marked X; Tag X eq Forward; syslsp smacro procedure MarkID X; Field(SymNam X, TagStartingBit, TagBitLength) := Forward; syslsp smacro procedure MarkedID X; Tag SymNam X eq Forward; syslsp smacro procedure ClearIDMark X; Field(SymNam X, TagStartingBit, TagBitLength) := STR; flag('(CopyFromAllBases CopyFromRange CopyFromBase CopyItem CopyItem1 MarkAndCopyFromID MakeIDFreeList GCStats), 'InternalFunction); >>; external WVar ST, StackLowerBound, BndStkLowerBound, BndStkPtr, HeapLast, HeapLowerBound, HeapUpperBound, OldHeapLast, OldHeapLowerBound, OldHeapUpperBound HeapTrapped; internal WVar StackLast, OldTime, OldSize; syslsp procedure Reclaim(); !%Reclaim(); syslsp procedure !%Reclaim(); begin scalar Tmp1, Tmp2; if LispVar !*GC then ErrorPrintF "*** Garbage collection starting"; BeforeGCSystemHook(); StackLast := MakeAddressFromStackPointer AdjustStackPointer(ST, -FrameSize()); OldTime := TimC(); OldSize := HeapLast - HeapLowerBound; LispVar GCKnt!* := LispVar GCKnt!* + 1; OldHeapLast := HeapLast; HeapLast := OldHeapLowerBound; Tmp1 := HeapLowerBound; Tmp2 := HeapUpperBound; HeapLowerBound := OldHeapLowerBound; HeapUpperBound := OldHeapUpperBound; OldHeapLowerBound := Tmp1; OldHeapUpperBound := Tmp2; CopyFromAllBases(); MakeIDFreeList(); AfterGCSystemHook(); OldTime := TimC() - OldTime; LispVar GCTime!* := Plus2(LispVar GCTime!*, OldTime); if LispVar !*GC then GCStats(); HeapTrapped := NIL; if IntInf Known!-Free!-Space() < IntInf (LispVar Heap!-Warning!-Level) then ContinuableError(99, "Heap space low", NIL) >>; syslsp procedure MarkAndCopyFromID X; % SymNam has to be copied before marking, since the mark destroys the tag % No problem since it's only a string, can't reference itself. << CopyFromBase &SymNam X; MarkID X; CopyFromBase &SymPrp X; CopyFromBase &SymVal X >>; syslsp procedure CopyFromAllBases(); begin scalar LastSymbol, B; MarkAndCopyFromID 128; % Mark NIL first for I := 0 step 1 until 127 do if not MarkedID I then MarkAndCopyFromID I; for I := 0 step 1 until MaxObArray do << B := ObArray I; if B > 0 and not MarkedID B then MarkAndCopyFromID B >>; B := BndStkLowerBound; while << B := AdjustBndStkPtr(B, 1); B <= BndStkPtr >> do CopyFromBase B; for I := StackLowerBound step StackDirection*AddressingUnitsPerItem until StackLast do CopyFromBase I; end; syslsp procedure CopyFromRange(Lo, Hi); begin scalar X, I; X := Lo; I := 0; while X <= Hi do << CopyFromBase X; I := I + 1; X := &Lo[I] >>; end; syslsp procedure CopyFromBase P; @P := CopyItem @P; syslsp procedure CopyItem X; begin scalar Typ, Info, Hdr; Typ := Tag X; if not PointerTagP Typ then return << if Typ = ID and not null X then % don't follow NIL, for speed << Info := IDInf X; if not MarkedID Info then MarkAndCopyFromID Info >>; X >>; Info := Inf X; if not WithinOldHeapPointer Info then return X; Hdr := @Info; if Marked Hdr then return MkItem(Typ, Inf Hdr); return CopyItem1 X; end; syslsp procedure CopyItem1 S; % Copier for GC begin scalar NewS, Len, Ptr, StripS; return case Tag S of PAIR: << Ptr := car S; Rplaca(S, Mark(NewS := GtHeap PairPack())); NewS[1] := CopyItem cdr S; NewS[0] := CopyItem Ptr; MkPAIR NewS >>; STR: << @StrInf S := Mark(NewS := CopyString S); NewS >>; VECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := CopyItem VecItm(StripS, I); MkVEC Ptr >>; EVECT: << StripS := VecInf S; Len := VecLen StripS; @StripS := Mark(Ptr := GtVECT Len); for I := 0 step 1 until Len do VecItm(Ptr, I) := CopyItem VecItm(StripS, I); MkItem(EVECT, Ptr) >>; WRDS, FIXN, FLTN, BIGN: << Ptr := Tag S; @Inf S := Mark(NewS := CopyWRDS S); MkItem(Ptr, NewS) >>; default: FatalError "Unexpected tag found during garbage collection"; end; end; syslsp procedure MakeIDFreeList(); begin scalar Previous; for I := 0 step 1 until 128 do ClearIDMark I; Previous := 129; while MarkedID Previous and Previous <= MaxSymbols do << ClearIDMark Previous; Previous := Previous + 1 >>; if Previous >= MaxSymbols then NextSymbol := 0 else NextSymbol := Previous; % free list starts here for I := Previous + 1 step 1 until MaxSymbols do if MarkedID I then ClearIDMark I else << SymNam Previous := I; Previous := I >>; SymNam Previous := 0; % end of free list end; syslsp procedure GCStats(); << ErrorPrintF("*** GC %w: time %d ms, %d recovered, %d free", LispVar GCKnt!*, OldTime, (OldSize - (HeapLast - HeapLowerBound))/AddressingUnitsPerItem, Known!-Free!-Space() ) >>; off SysLisp; END; |
Added psl-1983/kernel/debg.build version [4cd902bb16].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % DEBG.BUILD - Minor debugging tools in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "mini-trace.red"$ % simple function tracing PathIn "mini-editor.red"$ PathIn "backtrace.red"$ % Stack backtrace |
Added psl-1983/kernel/defconst.red version [734ec979d0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFCONST.RED - Definition and use of symbolic constants % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 8 January 1982 % Copyright (c) 1982 University of Utah % % DefConst is used to define a value for a name, to be used in const(Name) macro procedure DefConst Form; %. DefConst(Name, Value, ...); begin scalar ResultForm; ResultForm := list 'ProgN; Form := cdr Form; while not null Form do << ResultForm := list('EvDefConst, MkQuote car Form, MkQuote cadr Form) . ResultForm; Form := cddr Form >>; return ReversIP ResultForm; end; flag('(DefConst), 'Eval); lisp procedure EvDefConst(ConstName, ConstValue); put(ConstName, 'Const, ConstValue); macro procedure Const Form; get(cadr Form, 'Const) or StdError BldMsg("Unknown const form %r", Form); END; |
Added psl-1983/kernel/define-smacro.red version [a27a0b7bdc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFINE-SMACRO.RED - Convert SMacros to Lisp macros % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>DEFINE-SMACRO.RED.3, 21-Sep-82 10:48:10, Edit by BENSON % Flagged internal functions % The functions SafeCDR and StdError are required for run-time support % of the code generated by DS CompileTime flag('(InstantiateInForm MakeDS SetMacroReference), 'InternalFunction); lisp procedure InstantiateInForm(Formals, Form); if Atom Form then if Form memq Formals then Form else MkQuote Form else 'List . for each X in Form collect InstantiateInForm(Formals, X); lisp procedure SetMacroReference U; list('SetQ, U, '(car !#Arg)); macro procedure DS Form; %. Define Smacro % % DS(FNAME:id, PARAMS:id-list, FN:any):id % --------------------------------------- % Type: MACRO % A convenient syntax for a simple macro definition, known as an SMACRO. % The syntax of DS is similar to DE, except that a MACRO is defined instead % of an EXPR, e.g. % (DS FOO (A B) (BAR A B)) % is equivalent to: % (DM FOO (U) (LIST 'BAR (CADR U) (CADDR U))). % The "implicit ProgN" is allowed when using Lisp syntax. DS is invoked % with Rlisp syntax as the procedure type SMACRO, e.g. % SMACRO PROCEDURE FOO(A, B); BAR(A, B); % produces the above Lisp form. % MakeDS(cadr Form, caddr Form, cdddr Form); lisp procedure MakeDS(MacroName, Formals, Form); begin scalar NewForm, I; NewForm := list 'PROG; NewForm := Formals . NewForm; for each X in Formals do << NewForm := '(SetQ !#Arg (SafeCDR !#Arg)) . NewForm; NewForm := SetMacroReference X . NewForm >>; NewForm := '(cond ((PairP (cdr !#Arg)) (StdError "Argument mismatch in SMacro expansion"))) . NewForm; NewForm := list('Return, if null cdr Form then InstantiateInForm(Formals, car Form) else 'list . '(quote ProgN) . for each X in Form collect InstantiateInForm(Formals, X)) . NewForm; return 'dm . MacroName . '(!#Arg) . list ReversIP NewForm; end; %lisp procedure PutC(Name, Type, Body); % if Type eq 'SMACRO then Eval MakeDS(Name, cadr Body, cddr Body) % else % << put(Name, Type, Body); % Name >>; END; |
Added psl-1983/kernel/dskin.red version [2c7d1c7fc8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DSKIN.RED - Read/Eval/Print from files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>DSKIN.RED.2, 5-Oct-82 11:32:28, Edit by BENSON % Changed DSKIN from FEXPR to 1 argument EXPR % <PSL.INTERP>DSKIN.RED.11, 7-May-82 06:14:27, Edit by GRISS % Added XPRINT in loop to handle levels of output % <PSL.INTERP>DSKIN.RED.6, 30-Apr-82 12:49:59, Edit by BENSON % Made !*DEFN call DfPrint instead of own processing % <PSL.INTERP>DSKIN.RED.3, 29-Apr-82 04:23:49, Edit by GRISS % Added !*DEFN flag, cf TOPLOOP CompileTime << flag('(DskInDefnPrint), 'InternalFunction); >>; expr procedure DskIN F; %. Read a file (dskin "file") % % This is reasonably standard Standard Lisp, except for file name format % knowledge. % begin scalar OldIN, NewIN, TestOpen, Exp; TestOpen := ErrorSet(list('OPEN, F, '(QUOTE INPUT)), NIL, NIL); if not PairP TestOpen then return ContError(99, "Couldn't open file `%w'", F, DskIN F); NewIN := car TestOpen; OldIN := RDS NewIN; while PairP(Exp := ErrorSet(quote Read(), T, !*Backtrace)) and not (car Exp eq !$EOF!$) and PairP(Exp := ErrorSet(list('DskInEval, MkQuote car Exp), T, !*Backtrace)) do if not !*Defn then PrintF("%f%p%n", car Exp); %/ no error protection for printing, maybe should be RDS OldIN; Close NewIN; end; lisp procedure DskInEval U; if not !*DEFN then Eval U else DskInDefnPrint U; lisp procedure DskInDefnPrint U; % handle case of !*Defn:=T % % Looks for special action on a form, otherwise prettyprints it; % Adapted from DFPRINT % if PairP U and FlagP(car U,'Ignore) then Eval U else % So 'IGNORE is EVALED, not output << if DfPrint!* then Apply(DfPrint!*, list U) else PrettyPrint U; % So 'EVAL gets EVALED and Output if PairP U and FlagP(Car U,'EVAL) then Eval U >>; flag('(DskIn), 'IGNORE); fluid '(!*RedefMSG !*Echo); SYMBOLIC PROCEDURE LAPIN FIL; BEGIN SCALAR OLDIN, EXP, !*REDEFMSG, !*ECHO; OLDIN := RDS OPEN(FIL,'INPUT); WHILE (EXP := READ()) NEQ !$EOF!$ DO EVAL EXP; CLOSE RDS OLDIN; END; END; |
Added psl-1983/kernel/easy-non-sl.red version [2dab558d2c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EASY-NON-SL.RED - Commonly used Non-Standard Lisp functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EASY-NON-SL.RED.2, 17-Sep-82 16:10:18, Edit by BENSON % Added ChannelPrin2T, ChannelSpaces, ChannelTab, ChannelSpaces2 % <PSL.INTERP>EASY-NON-SL.RED.7, 9-Jul-82 12:46:43, Edit by BENSON % Changed NTH to improve error reporting, using DoPNTH % <PSL.INTERP>EASY-NON-SL.RED.2, 19-Apr-82 23:05:35, Edit by BENSON % Changed order of tests in PNTH % <PSL.INTERP>EASY-NON-SL.RED.20, 23-Feb-82 21:36:36, Edit by BENSON % Added NE (not eq) % <PSL.INTERP>EASY-NON-SL.RED.19, 16-Feb-82 22:30:33, Edit by BENSON % made NEQ GEQ and LEQ back into EXPRs % <PSL.INTERP>EASY-NON-SL.RED.16, 15-Feb-82 18:01:14, Edit by BENSON % Made NEQ GEQ and LEQ into macros % <PSL.INTERP>EASY-NON-SL.RED.12, 18-Jan-82 12:28:13, Edit by BENSON % Added NexprP CompileTime flag('(DelqIP1 DeletIP1 SubstIP1 DelAscIP1 DelAtQIP1 DoPNTH), 'InternalFunction); % predicates expr procedure NEQ(U, V); %. not EQUAL (should be changed to not EQ) not(U = V); expr procedure NE(U, V); %. not EQ not(U eq V); expr procedure GEQ(U, V); %. greater than or equal to not(U < V); expr procedure LEQ(U, V); %. less than or equal to not(U > V); lisp procedure EqCar(U, V); %. car U eq V PairP U and car U eq V; lisp procedure ExprP U; %. Is U an EXPR? EqCar(U, 'LAMBDA) or CodeP U or EqCar(GetD U, 'EXPR); lisp procedure MacroP U; %. Is U a MACRO? EqCar(GetD U, 'MACRO); lisp procedure FexprP U; %. Is U an FEXPR? EqCar(GetD U, 'FEXPR); lisp procedure NexprP U; %. Is U an NEXPR? EqCar(GetD U, 'NEXPR); % Function definition lisp procedure CopyD(New, Old); %. FunDef New := FunDef Old; % % CopyD(New:id, Old:id):id % ----------------------- % Type: EVAL, SPREAD % The function body and type for New become the same as Old. If no % definition exists for Old, the error % % ***** `Old' has no definition in CopyD % % occurs. New is returned. % begin scalar OldDef; OldDef := GetD Old; if PairP OldDef then PutD(New, car OldDef, cdr OldDef) else StdError BldMsg("%r has no definition in CopyD", Old); return New; end; % Numerical functions lisp procedure Recip N; %. Floating point reciprocal 1.0 / N; % Commonly used constructors lisp procedure MkQuote U; %. Eval MkQuote U eq U list('QUOTE, U); % Nicer names to access parts of a list macro procedure First U; %. First element of a list 'CAR . cdr U; macro procedure Second U; %. Second element of a list 'CADR . cdr U; macro procedure Third U; %. Third element of a list 'CADDR . cdr U; macro procedure Fourth U; %. Fourth element of a list 'CADDDR . cdr U; macro procedure Rest U; %. Tail of a list 'CDR . cdr U; % Destructive and EQ versions of Standard Lisp functions lisp procedure ReversIP U; %. Destructive REVERSE (REVERSe In Place) begin scalar X,Y; while PairP U do << X := cdr U; Y := RplacD(U, Y); U := X >>; return Y end; lisp procedure SubstIP1(A, X, L); % Auxiliary function for SubstIP << if X = car L then RplacA(L, A) else if PairP car L then SubstIP(A, X, car L); if PairP cdr L then SubstIP(A, X, cdr L) >>; lisp procedure SubstIP(A, X, L); %. Destructive version of Subst if null L then NIL else if X = L then A else if not PairP L then L else << SubstIP1(A, X, L); L >>; lisp procedure DeletIP1(U, V); % Auxiliary function for DeletIP if PairP cdr V then if U = cadr V then RplacD(V, cddr V) else DeletIP1(U, cdr V); lisp procedure DeletIP(U, V); %. Destructive DELETE if not PairP V then V else if U = car V then cdr V else << DeletIP1(U, V); V >>; lisp procedure DelQ(U, V); %. EQ version of DELETE if not PairP V then V else if car V eq U then cdr V else car V . DelQ(U, cdr V); lisp procedure Del(F, U, V); %. Generalized Delete, F is comparison function if not PairP V then V else if Apply(F, list(car V, U)) then cdr V else car V . Del(F, U, cdr V); lisp procedure DelqIP1(U, V); % Auxiliary function for DelqIP if PairP cdr V then if U eq cadr V then RplacD(V, cddr V) else DelqIP1(U, cdr V); lisp procedure DelqIP(U, V); %. Destructive DELQ if not PairP V then V else if U eq car V then cdr V else << DelqIP1(U, V); V >>; lisp procedure Atsoc(U, V); %. EQ version of ASSOC if not PairP V then NIL else if PairP car V and U eq caar V then car V else Atsoc(U, cdr V); lisp procedure Ass(F, U, V); %. Generalized Assoc, F is comparison function % % Not to be confused with Elbow % if not PairP V then NIL else if PairP car V and Apply(F, list(U, caar V)) then car V else Ass(F, U, cdr V); lisp procedure Mem(F, U, V); %. Generalized Member, F is comparison function if not PairP V then NIL else if Apply(F, list(U, car V)) then V else Mem(F, U, cdr V); lisp procedure RAssoc(U, V); %. Reverse Assoc, compare with cdr of entry if not PairP V then NIL else if PairP car V and U = cdar V then car V else RAssoc(U, cdr V); lisp procedure DelAsc(U, V); %. Remove first (U . xxx) from V if not PairP V then NIL else if PairP car V and U = caar V then cdr V else car V . DelAsc(U, cdr V); lisp procedure DelAscIP1(U, V); % Auxiliary function for DelAscIP if PairP cdr V then if PairP cadr V and U = caadr V then RplacD(V, cddr V) else DelAscIP1(U, cdr V); lisp procedure DelAscIP(U, V); %. Destructive DelAsc if not PairP V then NIL else if PairP car V and U = caar V then cdr V else << DelAscIP1(U, V); V >>; lisp procedure DelAtQ(U, V); %. EQ version of DELASC if not PairP V then NIL else if EqCar(car V, U) then cdr V else car V . DelAtQ(U, cdr V); lisp procedure DelAtQIP1(U, V); % Auxiliary function for DelAtQIP if PairP cdr V then if PairP cadr V and U eq caadr V then RplacD(V, cddr V) else DelAtQIP1(U, cdr V); lisp procedure DelAtQIP(U, V); %. Destructive DelAtQ if not PairP V then NIL else if PairP car V and U eq caar V then cdr V else << DelAtQIP1(U, V); V >>; lisp procedure SublA(U,V); %. EQ version of SubLis, replaces atoms only begin scalar X; return if not PairP U or null V then V else if atom V then if (X := Atsoc(V, U)) then cdr X else V else SublA(U, car V) . SublA(U, cdr V) end; lisp procedure RplacW(A, B); %. RePLACe Whole pair if PairP A then if PairP B then RplacA(RplacD(A, cdr B), car B) else NonPairError(B, 'RplacW) else NonPairError(A, 'RPlacW); lisp procedure LastCar X; %. last element of list if atom X then X else car LastPair X; lisp procedure LastPair X; %. last pair of list if atom X or atom cdr X then X else LastPair cdr X; lisp procedure Copy U; %. copy all pairs in S-Expr % % See also TotalCopy in COPIERS.RED % if PairP U then Copy car U . Copy cdr U else U; % blows up if circular lisp procedure NTH(U, N); %. N-th element of list (lambda(X); if PairP X then car X else RangeError(U, N, 'NTH))(DoPNTH(U, N)); lisp procedure DoPNTH(U, N); if N = 1 or not PairP U then U else DoPNTH(cdr U, N - 1); lisp procedure PNTH(U, N); %. Pointer to N-th element of list if N = 1 then U else if not PairP U then RangeError(U, N, 'PNTH) else PNTH(cdr U, N - 1); lisp procedure AConc(U, V); %. destructively add element V to the tail of U NConc(U, list V); lisp procedure TConc(Ptr, Elem); %. AConc maintaining pointer to end % % ACONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to (NIL . NIL) before calling the first time % << Elem := list Elem; if not PairP Ptr then % if PTR not initialized, return starting ptr Elem . Elem else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, Elem), Elem) else << RplacD(cdr Ptr, Elem); RplacD(Ptr, Elem) >> >>; lisp procedure LConc(Ptr, Lst); %. NConc maintaining pointer to end % % NCONC with pointer to end of list % Ptr is (list . last CDR of list) % returns updated Ptr % Ptr should be initialized to NIL . NIL before calling the first time % if null Lst then Ptr else if atom Ptr then % if PTR not initialized, return starting ptr Lst . LastPair Lst else if null cdr Ptr then % Nothing in the list yet RplacA(RplacD(Ptr, LastPair Lst), Lst) else << RplacD(cdr Ptr, Lst); RplacD(Ptr, LastPair Lst) >>; % MAP functions of 2 arguments lisp procedure Map2(L, M, Fn); %. for each X, Y on L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(L, M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAP2" else NIL >>; lisp procedure MapC2(L, M, Fn); %. for each X, Y in L, M do Fn(X, Y); << while PairP L and PairP M do << Apply(Fn, list(car L, car M)); L := cdr L; M := cdr M >>; if PairP L or PairP M then StdError "Different length lists in MAPC2" else NIL >>; % Printing functions lisp procedure ChannelPrin2T(C, U); %. Prin2 and TerPri << ChannelPrin2(C, U); ChannelTerPri C; U >>; lisp procedure Prin2T U; %. Prin2 and TerPri ChannelPrin2T(OUT!*, U); lisp procedure ChannelSpaces(C, N); %. Prin2 N spaces for I := 1 step 1 until N do ChannelWriteChar(C, char BLANK); lisp procedure Spaces N; %. Prin2 N spaces ChannelSpaces(OUT!*, N); lisp procedure ChannelTAB(Chn, N); %. Spaces to column N begin scalar M; M := ChannelPosn Chn; if N < M then << ChannelTerPri Chn; M := 0 >>; ChannelSpaces(Chn, N - M); end; lisp procedure TAB N; %. Spaces to column N ChannelTAB(OUT!*, N); if_system(Dec20, << lap '((!*entry FileP expr 1) (!*MOVE (REG 1) (REG 2)) (hrli 2 8#010700) % make a byte pointer (hrlzi 1 2#001000000000000001) % gj%old + gj%sht (gtjfn) (jrst NotFile) (rljfn) % release it (jfcl) (!*MOVE (QUOTE T) (REG 1)) (!*EXIT 0) NotFile (!*MOVE (QUOTE NIL) (REG 1)) (!*EXIT 0) ); >>, << lisp procedure FileP F; %. is F an existing file? % % This could be done more efficiently in a much more system-dependent way, % but efficiency probably doesn't matter too much here. % if PairP(F := ErrorSet(list('OPEN, MkQuote F, '(QUOTE INPUT)), NIL, NIL)) then << Close car F; T >> else NIL; >>); % This doesn't belong anywhere and will be eliminated soon lisp procedure PutC(Name, Ind, Exp); %. Used by RLISP to define SMACROs << put(Name, Ind, Exp); Name >>; LoadTime << PutD('Spaces2, 'EXPR, cdr GetD 'TAB); % For compatibility PutD('ChannelSpaces2, 'EXPR, cdr GetD 'ChannelTAB); >>; END; |
Added psl-1983/kernel/easy-sl.red version [642f7c1834].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EASY-SL.RED - Standard Lisp functions with easy Standard Lisp definitions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EASY-SL.RED.3, 17-Sep-82 16:16:58, Edit by BENSON % Added ChannelPrint % <PSL.INTERP>EASY-SL.RED.4, 13-Aug-82 14:14:49, Edit by BENSON % Changed nice recursive Append to ugly iterative definition % <PSL.INTERP>EASY-SL.RED.13, 8-Feb-82 17:43:07, Edit by BENSON % Made SetQ take multiple arguments % <PSL.INTERP>EASY-SL.RED.7, 18-Jan-82 17:30:14, Edit by BENSON % Added Max2 and Min2 % <PSL.INTERP>EASY-SL.RED.6, 15-Jan-82 14:54:36, Edit by BENSON % Changed DE, DF, DM, DN from Fexprs to Macros % This file contains only functions found in the Standard Lisp report which % can be easily and efficiently defined in terms of other Standard Lisp % functions. It does not include primitive functions which are handled % specially by the compiler, such as EQ. % Many NULL tests in these functions have been replaced with not PairP tests, % so that they will be safer. CompileTime flag('(EvAnd1), 'InternalFunction); % Section 3.1 -- Elementary predicates lisp procedure Atom U; %. is U a non pair? not PairP U; lisp procedure ConstantP U; %. is Eval U eq U by definition? not PairP U and not IDP U; lisp procedure Null U; %. is U eq NIL? U eq NIL; lisp procedure NumberP U; %. is U a number of any kind? FixP U or FloatP U; lisp procedure Expt(X, N); begin scalar Result; if not IntP N or not NumberP X then return ContError(99, "Illegal arguments to Expt", X ** N); Result := 1; if N > 0 then for I := 1 step 1 until N do Result := Result * X else if N < 0 then for I := -1 step -1 until N do Result := Result / X; return Result; end; % MinusP, OneP and ZeroP are in ARITHMETIC.RED % FixP is defined in OTHERS-SL.RED % Section 3.2 -- Functions on Dotted-Pairs % composites of CAR and CDR are found in CARCDR.RED fexpr procedure List U; %. construct list of arguments EvLis U; % section 3.5 -- Function definition macro procedure DE U; %. Terse syntax for PutD call for EXPR list('PutD, MkQuote cadr U, '(QUOTE EXPR), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DF U; %. Terse syntax for PutD call for FEXPR list('PutD, MkQuote cadr U, '(QUOTE FEXPR), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DM U; %. Terse syntax for PutD call for MACRO list('PutD, MkQuote cadr U, '(QUOTE MACRO), list('FUNCTION, ('LAMBDA . cddr U))); macro procedure DN U; %. Terse syntax for PutD call for NEXPR list('PutD, MkQuote cadr U, '(QUOTE NEXPR), list('FUNCTION, ('LAMBDA . cddr U))); % Section 3.6 -- Variables and bindings fexpr procedure SetQ U; %. Standard named variable assignment % % Extended from SL Report to be Common Lisp compatible % (setq foo 1 bar 2 ...) is permitted % begin scalar V, W; while U do << W := cdr U; Set(car U, V := Eval car W); U := cdr W >>; return V; end; % Section 3.7 -- Program feature functions lisp procedure Prog2(U, V); %. Return second argument V; fexpr procedure ProgN U; %. Sequential evaluation, return last EvProgN U; StartupTime put('PROGN, 'TYPE, 'FEXPR); lisp procedure EvProgN U; %. EXPR support for ProgN, Eval, Cond if PairP U then << while PairP cdr U do << Eval car U; U := cdr U >>; Eval car U >> else NIL; % Section 3.10 -- Boolean functions and conditionals fexpr procedure And U; %. Sequentially evaluate until NIL EvAnd U; lisp procedure EvAnd U; %. EXPR support for And if not PairP U then T else EvAnd1 U; lisp procedure EvAnd1 U; % Auxiliary function for EvAnd if not PairP cdr U then Eval car U else if not Eval car U then NIL else EvAnd1 cdr U; fexpr procedure OR U; %. sequentially evaluate until non-NIL EvOr U; lisp procedure EvOr U; %. EXPR support for Or PairP U and (Eval car U or EvOr cdr U); fexpr procedure Cond U; %. Conditional evaluation construct EvCond U; lisp procedure EvCond U; %. EXPR support for Cond % % Extended from Standard Lisp definition to allow no consequent (antecedent is % returned), or multiple consequent (implicit progn). % begin scalar CondForm, Antecedent, Result; return if not PairP U then NIL else << CondForm := car U; U := cdr U; Antecedent := if PairP CondForm then car CondForm else CondForm; if not (Result := Eval Antecedent) then EvCond U else if not PairP CondForm or not PairP cdr CondForm then Result else EvProgN cdr CondForm >>; end; lisp procedure Not U; %. Equivalent to NULL null U; % Section 3.11 -- Arithmetic functions lisp procedure Abs U; %. Absolute value of number if MinusP U then -U else U; lisp procedure Divide(U, V); %. dotted pair remainder and quotient if ZeroP V then ContError(99, "Attempt to divide by 0 in DIVIDE", Divide(U, V)) else Quotient(U, V) . Remainder(U, V); macro procedure Max U; %. numeric maximum of several arguments RobustExpand(cdr U, 'Max2, 0); % should probably be -infinity lisp procedure Max2(U, V); %. maximum of 2 arguments if U < V then V else U; macro procedure Min U; %. numeric minimum of several arguments RobustExpand(cdr U, 'Min2, 0); % should probably be +infinity lisp procedure Min2(U, V); %. minimum of 2 arguments if U > V then V else U; macro procedure Plus U; %. addition of several arguments RobustExpand(cdr U, 'Plus2, 0); macro procedure Times U; %. multiplication of several arguments RobustExpand(cdr U, 'Times2, 1); % Section 3.12 -- MAP Composite functions lisp procedure Map(L, Fn); %. for each X on L do Fn(X); while PairP L do << Apply(Fn, list L); L := cdr L >>; lisp procedure MapC(L, Fn); %. for each X in L do Fn(X); while PairP L do << Apply(Fn, list car L); L := cdr L >>; lisp procedure MapCan(L, Fn); %. for each X in L conc Fn(X); if not PairP L then NIL else NConc(Apply(Fn, list car L), MapCan(cdr L, Fn)); lisp procedure MapCon(L, Fn); %. for each X on L conc Fn(X); if not PairP L then NIL else NConc(Apply(Fn, list L), MapCon(cdr L, Fn)); lisp procedure MapCar(L, Fn); %. for each X in L collect Fn(X); if not PairP L then NIL else Apply(Fn, list car L) . MapCar(cdr L, Fn); lisp procedure MapList(L, Fn); %. for each X on L collect Fn(X); if not PairP L then NIL else Apply(Fn, list L) . MapList(cdr L, Fn); % Section 3.13 -- Composite functions lisp procedure Append(U, V); %. Combine 2 lists if not PairP U then V else begin scalar U1, U2; U1 := U2 := car U . NIL; U := cdr U; while PairP U do << RplacD(U2, car U . NIL); U := cdr U; U2 := cdr U2 >>; RplacD(U2, V); return U1; end; % % These A-list functions differ from the Standard Lisp Report in that % poorly formed A-lists (non-pair entries) are not signalled as an error, % rather the entries are ignored. This is because some data structures % (such as property lists) use atom entries for other purposes. % lisp procedure Assoc(U, V); %. Return first (U . xxx) in V, or NIL if not PairP V then NIL else if PairP car V and U = caar V then car V else Assoc(U, cdr V); lisp procedure Sassoc(U, V, Fn); %. Return first (U . xxx) in V, or Fn() if not PairP V then Apply(Fn, NIL) else if PairP car V and U = caar V then car V else Sassoc(U, cdr V, Fn); lisp procedure Pair(U, V); %. For each X,Y in U,V collect (X . Y) if PairP U and PairP V then (car U . car V) . Pair(cdr U, cdr V) else if PairP U or PairP V then StdError "Different length lists in PAIR" else NIL; lisp procedure SubLis(X, Y); %. Substitution in Y by A-list X if not PairP X then Y else begin scalar U; U := Assoc(Y, X); return if PairP U then cdr U else if not PairP Y then Y else SubLis(X, car Y) . SubLis(X, cdr Y); end; lisp procedure DefList(DList, Indicator); %. PUT many IDs, same indicator if not PairP DList then NIL else << put(caar DList, Indicator, cadar DList); caar DList >> . DefList(cdr DList, Indicator); lisp procedure Delete(U, V); %. Remove first top-level U in V if not PairP V then V else if car V = U then cdr V else car V . Delete(U, cdr V); % DIGIT, LENGTH and LITER are optimized, don't use SL Report version lisp procedure Member(U, V); %. Find U in V if not PairP V then NIL else if U = car V then V else U Member cdr V; lisp procedure MemQ(U, V); % EQ version of Member if not PairP V then NIL else if U eq car V then V else U MemQ cdr V; lisp procedure NConc(U, V); %. Destructive version of Append begin scalar W; if not PairP U then return V; W := U; while PairP cdr W do W := cdr W; RplacD(W, V); return U; end; lisp procedure Reverse U; %. Top-level reverse of list begin scalar V; while PairP U do << V := car U . V; U := cdr U >>; return V; end; lisp procedure Subst(A, X, L); %. Replace every X in L with A if null L then NIL else if X = L then A else if null PairP L then L else Subst(A, X, car L) . Subst(A, X, cdr L); lisp procedure EvLis U; %. For each X in U collect Eval X if not PairP U then NIL else Eval car U . EvLis cdr U; lisp procedure RobustExpand(L, Fn, EmptyCase); %. Expand + arg for empty list if null L then EmptyCase else Expand(L, Fn); lisp procedure Expand(L, Fn); %. L = (a b c) --> (Fn a (Fn b c)) if not PairP L then L else if not PairP cdr L then car L else list(Fn, car L, Expand(cdr L, Fn)); fexpr procedure Quote U; %. Return unevaluated argument car U; StartupTime put('QUOTE, 'TYPE, 'FEXPR); % needed to run from scratch fexpr procedure Function U; %. Same as Quote in this version car U; % Section 3.15 -- Input and Output lisp procedure ChannelPrint(C, U); %. Display U and terminate line << ChannelPrin1(C, U); ChannelTerPri C; U >>; lisp procedure Print U; %. Display U and terminate line ChannelPrint(OUT!*, U); End; |
Added psl-1983/kernel/equal.red version [a38fa729ea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EQUAL.RED - EQUAL, EQN and friends % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EQUAL.RED.2, 21-Sep-82 10:38:28, Edit by BENSON % Made HalfWordsEqual, etc. internal % EQ is handled by the compiler and is in KNOWN-TO-COMP-SL.RED CompileTime flag('(HalfWordsEqual VectorEqual WordsEqual), 'InternalFunction); on SysLisp; syslsp procedure Eqn(U, V); %. Eq or numeric equality U eq V or case Tag U of % add bignums later FLTN: FloatP V and FloatHighOrder FltInf U eq FloatHighOrder FltInf V and FloatLowOrder FltInf U eq FloatLowOrder FltInf V; FIXN: FixNP V and FixVal FixInf U eq FixVal FixInf V; BIGN: BigP V and WordsEqual(U, V); default: NIL end; % Called LispEqual instead of Equal, to avoid name change due to Syslisp parser syslsp procedure LispEqual(U, V); %. Structural equality U eq V or case Tag U of VECT: VectorP V and VectorEqual(U, V); STR, BYTES: StringP V and StringEqual(U, V); PAIR: PairP V and LispEqual(car U, car V) and LispEqual(cdr U, cdr V); FLTN: FloatP V and FloatHighOrder FltInf U eq FloatHighOrder FltInf V and FloatLowOrder FltInf U eq FloatLowOrder FltInf V; FIXN: FixNP V and FixVal FixInf U eq FixVal FixInf V; BIGN: BigP V and WordsEqual(U, V); WRDS: WrdsP V and WordsEqual(U, V); HalfWords: HalfWordsP V and HalfWordsEqual(U, V); default: NIL end; syslsp procedure EqStr(U, V); %. Eq or string equality U eq V or StringP U and StringP V and StringEqual(U, V); syslsp procedure StringEqual(U, V); % EqStr without typechecking or eq begin scalar Len, I; U := StrInf U; V := StrInf V; Len := StrLen U; if Len neq StrLen V then return NIL; I := 0; Loop: if I > Len then return T; if StrByt(U, I) neq StrByt(V, I) then return NIL; I := I + 1; goto Loop; end; syslsp procedure WordsEqual(U, V); begin scalar S1, I; U := WrdInf U; V := WrdInf V; if not ((S1 := WrdLen U) eq WrdLen V) then return NIL; I := 0; Loop: if I eq S1 then return T; if not (WrdItm(U, I) eq WrdItm(V, I)) then return NIL; I := I + 1; goto Loop; end; syslsp procedure HalfWordsEqual(U, V); begin scalar S1, I; U := HalfWordInf U; V := HalfWordInf V; if not ((S1 := HalfWordLen U) eq HalfWordLen V) then return NIL; I := 0; Loop: if I eq S1 then return T; if not (HalfWordItm(U, I) eq HalfWordItm(V, I)) then return NIL; I := I + 1; goto Loop; end; syslsp procedure VectorEqual(U, V); % Vector equality without type check begin scalar Len, I; U := VecInf U; V := VecInf V; Len := VecLen U; if Len neq VecLen V then return NIL; I := 0; Loop: if I > Len then return T; if not LispEqual(VecItm(U, I), VecItm(V, I)) then return NIL; I := I + 1; goto Loop; end; off SysLisp; LoadTime PutD('Equal, 'EXPR, cdr GetD 'LispEqual); END; |
Added psl-1983/kernel/error-errorset.red version [ae8f44d36a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ERROR-ERRORSET.RED - The most basic ERROR and ERRORSET % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 4 Feb 1983 1208-PST % Moved ERRSET here from CATCH-THROW.RED. % Edit by Cris Perdue, 3 Feb 1983 1526-PST % Tidied up definition of ERRORSET. % <PSL.KERNEL>ERROR-ERRORSET.RED.3, 11-Oct-82 17:57:30, Edit by BENSON % Changed CATCH/THROW to new definition % <PSL.KERNEL>ERROR-ERRORSET.RED.2, 20-Sep-82 11:31:23, Edit by BENSON % Removed printing of error number in ERROR % <PSL.INTERP>ERROR-ERRORSET.RED.7, 26-Feb-82 23:44:01, Edit by BENSON % Added BreakLevel!* check % <PSL.INTERP>ERROR-ERRORSET.RED.5, 28-Dec-81 17:07:18, Edit by BENSON % Changed 3rd formal in ErrorSet to !*Inner!*Backtrace global '(EMsg!*); % gets current error message fluid '(!*BackTrace % controls backtrace printing (actual) !*Inner!*Backtrace % controls backtrace printing (formal) !*EMsgP % controls message printing !*Break % controls breaking BreakLevel!* % nesting level of breaks MaxBreakLevel!* % maximum permitted ... !*ContinuableError); % if T, inside a continuable error LoadTime << !*EmsgP := T; !*BackTrace := NIL; !*Break := T >>; lisp procedure Error(Number, Message); %. Throw to ErrorSet begin scalar !*ContinuableError; EMsg!* := Message; if !*EMsgP then << ErrorPrintF("***** %l", Message); % Error number is not printed if !*Break and BreakLevel!* < MaxBreakLevel!* then return Break() >>; return << if !*Inner!*BackTrace then BackTrace(); Throw('!$Error!$, Number) >>; end; % More useful version of ERRORSET macro procedure errset u; (lambda(form, flag); list(list('lambda, '(!*Emsgp), list('catch, ''!$error!$, list('ncons, form))), flag))(cadr u, if null cddr u then t else caddr u); lisp procedure ErrorSet(Form, !*EMsgP, !*Inner!*BackTrace); %. Protected Eval Catch('!$Error!$, list(Eval Form)); % eval form END; |
Added psl-1983/kernel/error-handlers.red version [0da90a6bfa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ERROR-HANDLERS.RED - Low level error handlers % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PERDUE.PSL>ERROR-HANDLERS.RED.2, 9-Dec-82 18:16:42, Edit by PERDUE % Changed continuable error message; also allows for no (NIL) retry form % <PSL.KERNEL>ERROR-HANDLERS.RED.2, 20-Sep-82 14:55:56, Edit by BENSON % Error number isn't printed % <PSL.INTERP>ERROR-HANDLERS.RED.11, 26-Feb-82 23:43:16, Edit by BENSON % Added BreakLevel!* check % <PSL.INTERP>ERROR-HANDLERS.RED.8, 28-Dec-81 17:02:43, Edit by BENSON % Compressed output in ContinuableError % MLG 7:18am Tuesday, 24 November 1981 - To print ErrorForm!* on ErrorOut!* fluid '(!*ContinuableError % if true, inside continuable error ErrorForm!* BreakLevel!* % nesting level of break loops MaxBreakLevel!* % maximum permitted ... !*EMsgP); % value of 2nd arg to previous errorset global '(EMsg!*); % gets message from most recent error on SysLisp; syslsp procedure FatalError S; << ErrorPrintF("***** Fatal error: %s", S); while T do Quit; >>; off SysLisp; lisp procedure RangeError(Object, Index, Fn); StdError BldMsg("Index %r out of range for %p in %p", Index, Object, Fn); lisp procedure StdError Message; %. Error without number Error(99, Message); SYMBOLIC PROCEDURE YESP U; BEGIN SCALAR BOOL,X,Y, OLDOUT, OLDIN, PROMPTSTRING!*; OLDIN := RDS NIL; OLDOUT := WRS ERROUT!*; % TERPRI(); % PRIN2L U; % TERPRI(); % TERPRI(); if_system(Tops20, % ? in col 1, so batch jobs get killed PROMPTSTRING!* := BldMsg("?%l (Y or N) ", U), PROMPTSTRING!* := BldMsg("%l (Y or N) ", U)); A: X := READ(); IF (Y := (X MEMQ '(Y YES))) OR X MEMQ '(N NO) THEN GO TO B; % IF NULL BOOL THEN PRIN2T "TYPE Y OR N"; if X = 'B then ErrorSet('(Break), NIL, NIL); if_system(Unix, % If read EOF, croak so shell scripts terminate if X eq !$EOF!$ then return (lambda(!*Break); StdError "End-of-file read in YesP")(NIL)); BOOL := T; GO TO A; B: WRS OLDOUT; RDS OLDIN; CURSYM!* := '!*SEMICOL!*; RETURN Y END; lisp procedure ContinuableError(ErrNum, Message, ErrorForm!*); %. maybe fix begin scalar !*ContinuableError; !*ContinuableError := T; EMsg!* := Message; return if !*Break and !*EMsgP and BreakLevel!* < MaxBreakLevel!* then << ErrorPrintF("***** %l", Message); % Don't print number if null ErrorForm!* then ErrorPrintF("***** Continuable error.") else if FlatSize ErrorForm!* < 40 then ErrorPrintF("***** Continuable error: retry form is %r", ErrorForm!*) else << ErrorPrintF("***** Continuable error, retry form is:"); ErrorPrintF("%p", ErrorForm!*) >>; Break() >> else Error(ErrNum, Message); end; END; |
Added psl-1983/kernel/error.build version [216c0738f0].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % ERROR.BUILD - Files with error handling functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "error-handlers.red"$ % low level error handlers PathIn "type-errors.red"$ % type mismatch error calls PathIn "error-errorset.red"$ % most basic error handling PathIn "io-errors.red"$ % I/O error handlers |
Added psl-1983/kernel/eval-apply.red version [bf84031003].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EVAL-APPLY.RED - Function calling mechanism % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EVAL-APPLY.RED.2, 20-Sep-82 10:36:28, Edit by BENSON % CAR of a form is never evaluated % <PSL.INTERP>EVAL-APPLY.RED.5, 6-Jan-82 19:22:46, Edit by GRISS % Add NEXPR % FUnBoundP and other function cell primitives found in FUNCTION-PRIMITIVES % Eval and Apply could have been defined using only GetD rather than these % primitves. They are used instead to avoid the CONS in GETD. % ValueCell is found in SYMBOL-VALUES.RED % IDApply, CodeApply, IDEvalApply and CodeEvalApply are written in LAP % due to register usage and to make them faster. They are found in % APPLY-LAP.RED. IDApply1 is handled by the compiler % uses EvProgN, found in EASY-SL.RED, expr for PROGN % Error numbers: % 1000 - undefined function % 1100 - ill-formed function expression % 1200 - argument number mismatch % 1300 - unknown function type % +3 in LambdaEvalApply % +4 in LambdaApply % +2 in Apply % +1 in Eval CompileTime flag('(LambdaEvalApply LambdaApply), 'InternalFunction); on SysLisp; % the only reason these 2 are in Syslisp is to speed up arithmetic (N := N + 1) syslsp procedure LambdaEvalApply(Fn, Args); %. Fn is Lambda, Args to be Evaled if not (PairP Fn and car Fn = 'LAMBDA) then ContinuableError('1103, '"Ill-formed function expression", Fn . Args) else begin scalar N, Result; N := BindEval(cadr Fn, Args); % hand-coded, bind formals to evlis args if N = -1 then return ContinuableError('1203, '"Argument number mismatch", Fn . Args); Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; syslsp procedure LambdaApply(Fn, Args); %. Fn is Lambda, unevaled Args if not (PairP Fn and car Fn = 'LAMBDA) then ContinuableError('1104, '"Ill-formed function expression", Fn . for each X in Args collect MkQuote X) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals and PairP Args do << LBind1(car Formals, car Args); Formals := cdr Formals; Args := cdr Args; N := N + 1 >>; if PairP Formals or PairP Args then return ContinuableError('1204, '"Argument number mismatch", Fn . for each X in Args collect MkQuote X); Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off SysLisp; % Apply differs from the Standard Lisp Report in that functions other % than EXPRs are allowed to be applied, the effect being the same as % Apply(cdr GetD Fn, Args) lisp procedure Apply(Fn, Args); %. Indirect function call if IDP Fn then begin scalar StackMarkForBacktrace, Result; if FUnBoundP Fn then return ContinuableError(1002, BldMsg("%r is an undefined function", Fn), Fn . for each X in Args collect MkQuote X); StackMarkForBacktrace := MkBTR Inf Fn; Result := if FCodeP Fn then CodeApply(GetFCodePointer Fn, Args) else LambdaApply(get(Fn, '!*LambdaLink), Args); return Result; end else if CodeP Fn then CodeApply(Fn, Args) else if PairP Fn and car Fn = 'LAMBDA then LambdaApply(Fn, Args) else ContinuableError(1102, "Ill-formed function expression", Fn . for each X in Args collect MkQuote X); lisp procedure Eval U; %. Interpret S-Expression as program if not PairP U then if not IDP U then U else ValueCell U else begin scalar Fn; Fn := car U; return if IDP Fn then if FUnBoundP Fn then ContinuableError(1300, BldMsg("%r is an undefined function", Fn), U) else begin scalar FnType, StackMarkForBacktrace, Result; FnType := GetFnType Fn; StackMarkForBacktrace := MkBTR Inf Fn; Result := if null FnType then % must be an EXPR if FCodeP Fn then CodeEvalApply(GetFCodePointer Fn, cdr U) else LambdaEvalApply(get(Fn, '!*LambdaLink), cdr U) else if FnType = 'FEXPR then IDApply1(cdr U, Fn) else if FnType = 'NEXPR then IDApply1(EvLis cdr U, Fn) else if FnType = 'MACRO then Eval IDApply1(U, Fn) else ContinuableError(1301, BldMsg("Unknown function type %r", FnType), U); return Result; end else if CodeP Fn then CodeEvalApply(Fn, cdr U) else if PairP Fn and car Fn = 'LAMBDA then LambdaEvalApply(Fn, cdr U) else ContinuableError(1302, BldMsg("Ill-formed expression in Eval %r", U), U); end; END; |
Added psl-1983/kernel/eval-when.red version [836d273222].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EVAL-WHEN.RED - Funny business to make things happen at different times % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 30 August 1981 % Copyright (c) 1981 University of Utah % % Functions flagged IGNORE are evaluated immediately when invoked at the top % level while compiling to a file. Those flagged EVAL are evaled immediately % and also passed to the file. These functions are defined to make those % actions more visible and mnemonic. macro procedure CommentOutCode U; %. Comment out a single expression NIL; lisp procedure CompileTime U; %. Evaluate at compile time only U; % just return the already evaluated argument flag('(CommentOutCode CompileTime), 'IGNORE); % The functions above need only be present at compile time. Those below must % be present at both compile and load time to be effective. lisp procedure BothTimes U; %. Evaluate at compile and load time U; flag('(BothTimes), 'EVAL); lisp procedure LoadTime U; %. Evaluate at load time only U; PutD('StartupTime, 'EXPR, cdr GetD 'LoadTime); % StartupTime is kernel hack RemFlag('(LoadTime), 'IGNORE); % just to be sure it doesn't RemFlag('(LoadTime), 'EVAL); % happen until load time END; |
Added psl-1983/kernel/eval.build version [dd7f0a6f01].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % EVAL.BUILD - Files with Eval and Apply in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "apply-lap.red"$ % low-level function linkage, in LAP PathIn "eval-apply.red"$ % interpreter functions PathIn "catch-throw.red"$ % non-local GOTO mechanism PathIn "prog-and-friends.red"$ % Prog, Go and Return |
Added psl-1983/kernel/explode-compress.red version [bea6641f89].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % EXPLODE-COMPRESS.RED - Write to/read from a list; includes FlatSize % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 24 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>EXPLODE-COMPRESS.RED.3, 12-Oct-82 16:49:54, Edit by BENSON % Changed CompressReadChar to use Lisp2Char, so ASCII characters are OK, % but digits 0..9 as !0..!9 are not. fluid '(ExplodeEndPointer!* % pointer used to RplacD new chars onto CompressList!* % list being compressed !*Compressing); % if T, don't intern IDs when read external WArray LinePosition,UnReadBuffer; on SysLisp; syslsp procedure ExplodeWriteChar(Channel, Ch); << RplacD(LispVar ExplodeEndPointer!*, list MkID Ch); LispVar ExplodeEndPointer!* := cdr LispVar ExplodeEndPointer!* >>; syslsp procedure Explode U; %. S-expr --> char-list begin scalar Result; Result := LispVar ExplodeEndPointer!* := NIL . NIL; LinePosition[3] := 0; ChannelPrin1('3, U); return cdr Result; end; syslsp procedure Explode2 U; %. Prin2 version of Explode begin scalar Result; Result := LispVar ExplodeEndPointer!* := NIL . NIL; LinePosition[3] := 0; ChannelPrin2('3, U); return cdr Result; end; internal WVar FlatSizeAccumulator; syslsp procedure FlatSizeWriteChar(Channel, Ch); FlatSizeAccumulator := FlatSizeAccumulator + 1; syslsp procedure FlatSize U; %. character length of S-expression << FlatSizeAccumulator := 0; LinePosition[4] := 0; ChannelPrin1('4, U); MkINT FlatSizeAccumulator >>; lisp procedure FlatSize2 U; %. Prin2 version of FlatSize << FlatSizeAccumulator := 0; LinePosition[4] := 0; ChannelPrin2('4, U); MkINT FlatSizeAccumulator >>; internal WVar AtEndOfList; syslsp procedure CompressReadChar Channel; begin scalar NextEntry; if AtEndOfList then return CompressError(); if not PairP LispVar CompressList!* then << AtEndOfList := 'T; return char BLANK >>; NextEntry := car LispVar CompressList!*; LispVar CompressList!* := cdr LispVar CompressList!*; return Lisp2Char NextEntry; end; syslsp procedure ClearCompressChannel(); << UnReadBuffer[3] := char NULL; AtEndOfList := 'NIL >>; off SysLisp; lisp procedure CompressError(); StdError "Poorly formed S-expression in COMPRESS"; lisp procedure Compress CompressList!*; %. Char-list --> S-expr begin scalar !*Compressing; !*Compressing := T; ClearCompressChannel(); return ChannelRead 3; end; lisp procedure Implode CompressList!*; %. Compress with IDs interned << ClearCompressChannel(); ChannelRead 3 >>; END; |
Added psl-1983/kernel/extra.build version [1df7654350].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % EXTRA.BUILD - System-dependent extras % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "timc.red"$ % System time routine PathIn "system-extras.red"$ % Random system-specific routines PathIn "trap.red"$ % Interrupt handler PathIn "dumplisp.red"$ % Core saver |
Added psl-1983/kernel/fasl-include.red version [f5273fcef2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FASL-INCLUDE.RED - data declarations for FASL at compile time % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 20 February 1982 % Copyright (c) 1982 Eric Benson % on SysLisp; CompileTime << DefConst(FASL_MAGIC_NUMBER, 99); DefConst(RELOC_ID_NUMBER, 1, RELOC_VALUE_CELL, 2, RELOC_FUNCTION_CELL, 3); DefConst(RELOC_WORD, 1, RELOC_HALFWORD, 2, RELOC_INF, 3); smacro procedure RelocRightHalfTag X; Field(X, BitsPerWord/2, 2); smacro procedure RelocRightHalfInf X; Field(X, BitsPerWord/2+2, BitsPerWord/2-2); smacro procedure RelocInfTag X; Field(X, InfStartingBit, 2); smacro procedure RelocInfInf X; Field(X, InfStartingBit+2, InfBitLength-2); smacro procedure RelocWordTag X; Field(X, 0, 2); smacro procedure RelocWordInf X; Field(X, 2, BitsPerWord-2); >>; off Syslisp; END; |
Added psl-1983/kernel/fasl.build version [ebbe4f0040].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % % FASL.BUILD - Files used for Fasl in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "system-faslout.red"$ PathIn "system-faslin.red"$ PathIn "faslin.red"$ PathIn "load.red"$ % Standard module FASL loader PathIn "autoload.red"$ % stubs to load modules |
Added psl-1983/kernel/faslin.red version [f74410220d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | on SysLisp; external WString TokenBuffer; external WArray ArgumentBlock; internal WConst CODE_OFFSET = 0, RELOC_ID_NUMBER = 1, RELOC_VALUE_CELL = 2, RELOC_FUNCTION_CELL = 3; internal WConst RELOC_WORD = 1, RELOC_RIGHT_HALF = 2, RELOC_INF = 3; internal WConst FASLMAGIC = 99; CompileTime << smacro procedure LocalIDNumberP U; U >= 2048; smacro procedure LocalToGlobalID U; IDTable[U - 2048]; smacro procedure ExtraArgumentP U; U >= 8150; % Something enough less than 8192 smacro procedure MakeExtraArgument U; U - (8150 + (MaxRealRegs + 1)); >>; internal WVar CodeBase; syslsp procedure FaslIN File; begin scalar F, N, M, IDTable, CodeSize, OldCodeBase, E, BT, R, RT, RI, BI, Top, BTop; F := BinaryOpenRead File; N := BinaryRead F; % First word is magic number if N neq FASLMAGIC then ContError(99, "%r is not a fasl format file", File, FaslIN File); M := BinaryRead F; % Number of local IDs Top := GtWArray 0; % pointer to top of space IDTable := GtWArray(M + 1); % Allocate space for table for I := 0 step 1 until M do << TokenBuffer[0] := BinaryRead F; % word is length of ID name BinaryReadBlock(F, &TokenBuffer[1], StrPack TokenBuffer[0]); IDTable[I] := IDInf Intern MkSTR TokenBuffer >>; CodeSize := BinaryRead F; % Size of code segment in words OldCodeBase := CodeBase; % So FASLIN is reentrant CodeBase := GtBPS CodeSize; % Allocate space in BPS BTop := GTBPS 0; % pointer to top E := CodeBase + BinaryRead F; % Next word is offset of init function % Will be called after code is read BinaryReadBlock(F, CodeBase, CodeSize); % Put the next N words there N := BinaryRead F; % Next word is size of bit table in words BT := GtWArray N; % Allocate space for bit table BinaryReadBlock(F, BT, N); % read bit table BinaryClose F; % close the file CodeSize := CodeSize*AddressingUnitsPerItem - 1; for I := 0 step 1 until CodeSize do << R := BitTable(BT, I); BI := CodeBase + I; case R of RELOC_WORD: << RT := RelocWordTag @BI; RI := RelocWordInf @BI; case RT of CODE_OFFSET: @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; @BI := RI >>; end >>; RELOC_RIGHT_HALF: << RT := RelocRightHalfTag @BI; RI := RelocRightHalfInf @BI; case RT of CODE_OFFSET: RightHalf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; RightHalf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; RightHalf @BI := RI >>; end >>; RELOC_INF: << RT := RelocInfTag @BI; RI := RelocInfInf @BI; case RT of CODE_OFFSET: Inf @BI := CodeBase + RI; RELOC_VALUE_CELL: << if ExtraArgumentP RI then RI := &ArgumentBlock[MakeExtraArgument RI] else if LocalIDNumberP RI then RI := &SymVal LocalToGlobalID RI else RI := &SymVal RI; Inf @BI := RI >>; RELOC_FUNCTION_CELL: << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := SymFnc + AddressingUnitsPerFunctionCell*RI >>; RELOC_ID_NUMBER: % Must be a local ID number << if LocalIDNumberP RI then RI := LocalToGlobalID RI; Inf @BI := RI >>; end >>; end >>; DelWArray(BT, Top); % return the space used by tables AddressApply0 E; % Call the init routine CodeBase := OldCodeBase; % restore previous value for CodeBase DelBPS(E, BTop); % deallocate space of init routine end; syslsp procedure PutEntry(Name, Type, Offset); PutD(Name, Type, MkCODE(CodeBase + Offset)); off Syslisp; END; |
Added psl-1983/kernel/fast-binder.red version [76bcb81d58].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-FAST-BINDER.RED - Portable version of binding from compiled code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % % This file is for use with *LAMBIND and *PROGBIND in P-LAMBIND StartupTime << LambindArgs!* := GtWArray 15; >>; on Syslisp; syslsp procedure LamBind V; % V is vector of IDs begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do LBind1(VecItm(V, I), (LispVar LambindArgs!*)[I]); end; syslsp procedure ProgBind V; begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do PBind1 VecItm(V, I); end; off Syslisp; END; |
Added psl-1983/kernel/fluid-global.red version [c2e4a95a7d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FLUID-GLOBAL.RED - Fluid and Global declarations % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>FLUID-GLOBAL.RED.3, 10-Sep-82 09:18:04, Edit by BENSON % Uses indicator VARTYPE instead of TYPE % <PSL.INTERP>FLUID-GLOBAL.RED.3, 22-Jan-82 12:35:25, Edit by BENSON % GlobalP now only checks for variables, not functions % The functions dealing with FLUID and GLOBAL declarations use the property % list indicator TYPE, which is also used by PUTD and GETD. % Not true anymore! % Non-Standard Lisp functions used: % ErrorPrintF -- in IO.RED CompileTime flag('(DeclareFluidOrGlobal DeclareFluidOrGlobal1), 'InternalFunction); lisp procedure DeclareFluidOrGlobal(IDList, FG); for each U in IDList do DeclareFluidOrGlobal1(U, FG); lisp procedure DeclareFluidOrGlobal1(U, FG); if not IDP U then NIL else begin scalar X; X := get(U, 'VARTYPE); return if null X then << put(U, 'VARTYPE, FG); if UnBoundP U then Set(U, NIL) >> else if X eq FG then NIL else ErrorPrintF("*** %p %r cannot become %p", X, U, FG); end; lisp procedure Fluid IDList; %. Declare all in IDList as fluid vars DeclareFluidOrGlobal(IDList, 'FLUID); lisp procedure Fluid1 U; %. Declare U fluid DeclareFluidOrGlobal1(U, 'FLUID); lisp procedure FluidP U; %. Is U a fluid variable? get(U, 'VARTYPE) = 'FLUID; lisp procedure Global IDList; %. Declare all in IDList as global vars DeclareFluidOrGlobal(IDList, 'GLOBAL); lisp procedure Global1 U; %. Declare U global DeclareFluidOrGlobal1(U, 'GLOBAL); lisp procedure GlobalP U; %. Is U a global variable get(U, 'VARTYPE) = 'GLOBAL; lisp procedure UnFluid IDList; %. Undeclare all in IDList as fluid for each U in IDList do UnFluid1 U; lisp procedure UnFluid1 U; if FluidP U then RemProp(U, 'VARTYPE); END; |
Added psl-1983/kernel/io-errors.red version [40d73b7baf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-ERRORS.RED - Error handlers for input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % on SysLisp; syslsp procedure ChannelNotOpen(Chn, Ch); ChannelError(Chn, "Channel not open"); syslsp procedure WriteOnlyChannel Chn; ChannelError(Chn, "Channel open for write only"); syslsp procedure ReadOnlyChannel(Chn, Ch); ChannelError(Chn, "Channel open for read only"); syslsp procedure IllegalStandardChannelClose Chn; ChannelError(Chn, "Illegal to close standard channel"); syslsp procedure IOError(Message); StdError BldMsg("I/O Error: %s", Message); syslsp procedure ChannelError(Channel, Message); StdError BldMsg("I/O Error on channel %d: %s", IntInf Channel, Message); off SysLisp; END; |
Added psl-1983/kernel/io-extensions.red version [2f94bbdcd2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-EXTENSIONS.RED - Random, possibly useful functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 22 October 1981 % Copyright (c) 1981 University of Utah % on SysLisp; syslsp procedure ChannelTYI Chn; %. Read one char ASCII value MkINT ChannelReadChar Chn; syslsp procedure ChannelTYO(Chn, Ch); %. Write one char ASCII value ChannelWriteChar(Chn, Lisp2Char Ch); off SysLisp; global '(IN!* OUT!*); lisp procedure TYI(); %. Read ASCII value from curent input ChannelTYI IN!*; lisp procedure TYO Ch; %. Write ASCII value to current output ChannelTYO(OUT!*, Ch); END; |
Added psl-1983/kernel/io.build version [39acda9d26].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % % IO.BUILD - System-independent input and output files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "io-data.red"$ % Data structures used by IO PathIn "char-io.red"$ % bottom level IO primitives PathIn "open-close.red"$ % file primitives PathIn "rds-wrs.red"$ % IO channel switching functions PathIn "other-io.red"$ % random SL IO functions PathIn "read.red"$ % S-expression parser PathIn "token-scanner.red"$ % table-driven token scanner PathIn "printers.red"$ % Printing functions PathIn "write-float.red"$ % Floating point printer PathIn "printf.red"$ % formatted print routines PathIn "explode-compress.red"$ % Access to characters of atoms PathIn "io-extensions.red"$ % Random non-SL IO functions |
Added psl-1983/kernel/known-to-comp-sl.red version [ac3508bfb9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % KNOWN-TO-COMPILER.RED - Standard Lisp functions which are handled entirely % by the compiler % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>KNOWN-TO-COMP-SL.RED.4, 4-Jul-82 13:30:59, Edit by BENSON % CAR and CDR of NIL are legal == NIL off R2I; % can't do recursion removal, will get infinte recursion % Section 3.1 -- Elementary predicates lisp procedure CodeP U; %. Is U a code pointer? CodeP U; lisp procedure Eq(U, V); %. Are U and V identical? U eq V; lisp procedure FloatP U; %. Is U a floating point number? FloatP U; lisp procedure BigP U; %. Is U a bignum? BigP U; lisp procedure IDP U; %. Is U an ID? IDP U; lisp procedure PairP U; %. Is U a pair? PairP U; lisp procedure StringP U; %. Is U a string? StringP U; lisp procedure VectorP U; %. Is U a vector? VectorP U; % Section 3.2 -- Functions on Dotted-Pairs % NonPairError found in TYPE-ERRORS.RED lisp procedure Car U; %. left subtree of pair if null U then NIL else if PairP U then car U else NonPairError(U, 'CAR); lisp procedure Cdr U; %. right subtree of pair if null U then NIL else if PairP U then cdr U else NonPairError(U, 'CDR); lisp procedure RplacA(U, V); %. RePLAce CAr of pair if PairP U then RplacA(U, V) else NonPairError(U, 'RPLACA); lisp procedure RplacD(U, V); %. RePLACe CDr of pair if PairP U then RplacD(U, V) else NonPairError(U, 'RPLACD); on R2I; % Turn recursion removal back on END; |
Added psl-1983/kernel/lisp-macros.red version [e9e3eff7a0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LISP-MACROS.RED - Various macros to make pure Lisp more tolerable % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>LISP-MACROS.RED.4, 22-Jul-82 10:51:11, Edit by BENSON % Added CASE, removed IF % still to come: Do, Let % <PSL.INTERP>LISP-MACROS.RED.5, 28-Dec-81 14:43:39, Edit by BENSON % Added SetF CompileTime flag('(InThisCase), 'InternalFunction); % Not a macro, but it belongs with these SYMBOLIC FEXPR PROCEDURE CASE U; %U is of form (CASE <integer exp> (<case-1> <exp-1>) . . .(<case-n> <exp-n>)). % If <case-i> is NIL it is default, % else is list of INT or (RANGE int int) BEGIN SCALAR CaseExpr,DEF,CaseLst,BOD; CaseExpr:=EVAL CAR U; L: IF NOT PAIRP(U:=CDR U) THEN RETURN EVAL DEF; CaseLst:=CAAR U; BOD:=CADAR U; IF NOT PAIRP CaseLst OR CAR CaseLst MEMQ '(OTHERWISE DEFAULT) THEN <<DEF:=BOD; GOTO L>>; IF InThisCase(CaseExpr,CaseLst) THEN RETURN EVAL BOD; GOTO L END; SYMBOLIC PROCEDURE InThisCase(CaseExpr,Cases); IF NOT PAIRP Cases Then NIL ELSE IF PAIRP Car Cases and Caar Cases EQ 'RANGE and CaseExpr>=Cadar Cases and CaseExpr<=Caddar Cases then T ELSE IF CaseExpr = Car Cases then T ELSE InThisCase(CaseExpr,Cdr Cases); macro procedure SetF U; %. General assignment macro ExpandSetF(cadr U, caddr U); lisp procedure ExpandSetF(LHS, RHS); begin scalar LHSOp; return if atom LHS then list('setq, LHS, RHS) else if (LHSOp := get(car LHS, 'Assign!-Op)) then LHSOp . Append(cdr LHS, list RHS) % simple substitution case else if (LHSOp := get(car LHS, 'SetF!-Expand)) then Apply(LHSOp, list(LHS, RHS)) % more complex transformation else if (LHSOp := GetD car LHS) and car LHSOp = 'MACRO then ExpandSetF(Apply(cdr LHSOp, list LHS), RHS) else StdError BldMsg("%r is not a known form for assignment", list('SetF, LHS, RHS)); end; LoadTime DefList('((GetV PutV) (car RplacA) (cdr RplacD) (Indx SetIndx) (Sub SetSub) (Nth (lambda (L I X) (rplaca (PNTH L I) X) X)) (Eval Set) (Value Set)), 'Assign!-Op); END; |
Added psl-1983/kernel/load.red version [8cbfaec609].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LOAD.RED - New version of LOAD function, with search path % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 2 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL>LOAD.RED.15, 7-Mar-83 13:42:15, Edit by KESSLER % Change loaddirectories for Apollo to ~p/l/ % Edit by MLG, 6 March 1983. % Corrected bug in Fix to IMPORTS % Edit by Cris Perdue, 17 Feb 1983 1201-PST % Corrected use of *verboseload in top of load1 % MLG, 15 Feb 1983 % Added !*VERBOSELOAD and !*PRINTLOADNAMES % M. Griss, 9 Feb 1983 % Changed LoadDirectories!* for the VAX to refer to "$pl/" % <PSL.NEW>-SOURCE-CHANGES.LOG.15, 15-Dec-82 15:45:55, Edit by PERDUE % LOAD will now handle ".sl" extension % <PSL.KERNEL>LOAD.RED.7, 1-Dec-82 16:07:38, Edit by BENSON % Added if_system(HP9836, ...) % EDIT by GRISS 28 Oct 1982: Added EvLoad to Imports % <PSL.KERNEL>LOAD.RED.4, 4-Oct-82 09:46:54, Edit by BENSON % Moved addition of U to Options!* to avoid double load % <PSL.KERNEL>LOAD.RED.3, 30-Sep-82 11:57:03, Edit by BENSON % Removed "FOO already loaded" message % <PSL.KERNEL>LOAD.RED.2, 22-Sep-82 15:38:48, Edit by BENSON % Added ReLoad, changed VAX search path fluid '(LoadDirectories!* % list of strings to append to front LoadExtensions!* % a-list of (str . fn) to append to end % and apply PendingLoads!* % created by Imports, aux loads !*Lower % print IDs in lowercase, for building % filename for Unix !*RedefMSG % controls printing of redefined % function message !*UserMode % Controls query of user for redefining % system functions !*InsideLoad % Controls "already loaded" message !*VerboseLoad % Print REDEFs and LOAD file names !*PrintLoadNames % Print Names of files loading Options!*); % list of modules already loaded if_system(Apollo, LoadDirectories!* := '("" "~p/l/")); if_system(Tops20, LoadDirectories!* := '("" "pl:")); if_system(Unix, LoadDirectories!* := '("" "$pll/" "$pl/")); if_system(HP9836, LoadDirectories!* := '("" "pl:")); LoadExtensions!* := '((".b" . FaslIN) (".lap" . LapIN) (".sl" . LapIN)); !*VerboseLoad :=NIL; !*PrintLoadNames := NIL; macro procedure Load U; list('EvLoad, MkQuote cdr U); lisp procedure EvLoad U; for each X in U do Load1 X; macro procedure ReLoad U; list('EvReLoad, MkQuote cdr U); lisp procedure EvReLoad U; << for each X in U do Options!* := Delete(X, Options!*); EvLoad U >>; lisp procedure Load1 U; begin scalar !*RedefMSG, !*UserMode, LD, LE, F, Found; If !*VerBoseLoad then !*RedefMSG := T; return if U memq Options!* then if !*VerboseLoad then ErrorPrintF("*** %w already loaded", U) else NIL else (lambda(!*InsideLoad); << LD := LoadDirectories!*; (lambda (!*Lower); while not null LD and not Found do << LE := LoadExtensions!*; while not null LE and not Found do << if FileP(F := BldMsg("%w%w%w", first LD, U, car first LE)) then Found := cdr first LE; % Found is function to apply LE := rest LE >>; LD := rest LD >>)(T); if not Found then StdError BldMsg("%r load module not found", U) else << Options!* := U . Options!*; If !*VerboseLoad or !*PrintLoadNames then ErrorPrintf("*** loading %w%n",F); Apply(Found, list F); while not null PendingLoads!* do << Found := car PendingLoads!*; PendingLoads!* := cdr PendingLoads!*; Load1 Found >> >> >>)(T); end; lisp procedure Imports L; if !*InsideLoad then <<for each X in L do if not (X memq Options!* or X memq PendingLoads!*) then PendingLoads!* := Append(PendingLoads!*, list X)>> else EvLoad L; END; |
Added psl-1983/kernel/loop-macros.red version [a174933a90].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % LOOP-MACROS.RED - Various macros to make pure Lisp more tolerable % % Author: Eric Benson and M. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 October 1981 % Copyright (c) 1981 University of Utah % % Edit by MLG,9:35am Tuesday, 29 December 1981 % Add EXIT, NEXT, REPEAT, add 'Join, improve FOR macro procedure ForEach U; %. Macro for MAP functions % % From RLISP % % Possible forms are: % (foreach x in u do (foo x)) --> (mapc u (function (lambda (x) (foo x)))) % (foreach x in u collect (foo x)) --> (mapcar u ...) % (foreach x in u conc (foo x)) --> (mapcan u ...) % (foreach x in u join (foo x)) --> (mapcan u ...) % (foreach x on u do (foo x)) --> (map u ...) % (foreach x on u collect (foo u)) --> (maplist u ...) % (foreach x on u conc (foo x)) --> (mapcon u ...) % (foreach x on u join (foo x)) --> (mapcon u ...) % begin scalar Action, Body, Fn, Lst, Mod, Var; Var := cadr U; U := cddr U; Mod := car U; U := cdr U; Lst := car U; U := cdr U; Action := car U; Body := cdr U; Fn := if Action eq 'DO then if Mod eq 'IN then 'MAPC else 'MAP else if Action eq 'CONC or Action eq 'JOIN then if Mod eq 'IN then 'MAPCAN else 'MAPCON else if Action eq 'COLLECT then if Mod eq 'IN then 'MAPCAR else 'MAPLIST else StdError BldMsg("%r is an illegal action in ForEach", Action); return list(Fn, Lst, list('FUNCTION, 'LAMBDA . list Var . Body)) end; macro procedure Exit U; %. To leave current Iteration if null cdr U then '(return NIL) else if cddr U then list('return, 'progn . cdr U) else 'return . cdr U; macro procedure Next U; %. Continue Loop '(go !$Loop!$); % no named DO's yet (no DO at all) macro procedure While U; %. Iteration macro % % From RLISP % % Form is (while bool exp1 ... expN) % 'prog . '() . '!$Loop!$ . list('Cond, list(list('not, cadr U), '(return NIL))) . Append(cddr U, '((go !$Loop!$))); macro procedure Repeat U; % % From RLISP % Form is (repeat exp1 ... expN bool) % Repeat until bool is true, similar to Pascal, etc. % 'prog . '() . '!$Loop!$. for each X on cdr U collect if null cdr X then list('Cond, list(list('not, car X),'(go !$Loop!$))) else car X; MACRO PROCEDURE FOR U; % % From RLISP % % Form is (FOR (FROM var init final step) (key form)) %/ Limited right now to key=DO BEGIN SCALAR ACTION,BODY,EXP,INCR,RESULT,TAIL,VAR,X; VAR := second second U; INCR := cddr second U; %(init final step) ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := LIST('DIFFERENCE,first INCR,VAR); IF second INCR NEQ 1 THEN X := LIST('TIMES,second INCR,X); TAIL :='(RETURN NIL); IF NOT ACTION EQ 'DO THEN <<ACTION := GET(ACTION,'BIN); EXP := GENSYM(); BODY := LIST('SETQ,EXP, LIST(CAR ACTION,LIST('SIMP,BODY),EXP)); RESULT := LIST('SETQ,EXP,MKQUOTE CDR ACTION) . RESULT; TAIL := LIST('RETURN, LIST('MK!*SQ,EXP)); EXP := LIST EXP>>; RETURN ('PROG . (VAR . EXP) . NCONC(RESULT, '!$LOOP!$ . LIST('COND,LIST(LIST('MINUSP,X), TAIL)) . BODY . LIST('SETQ,VAR,LIST('PLUS2,VAR,second INCR)) . '((GO !$LOOP!$)) )); END; END; |
Added psl-1983/kernel/macro.build version [a6ff3d1184].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | % % MACRO.BUILD - Files of macros defined in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL>MACRO.BUILD.2, 2-Feb-83 15:36:40, Edit by PERDUE % Removed char.red. It is now pnk:char-macro.red PathIn "eval-when.red"$ % control evaluation time PathIn "cont-error.red"$ % macro for ContinuableError PathIn "lisp-macros.red"$ % Various macros for readability PathIn "onoff.red"$ % (on xxx yyy) and (off xxx yyy) PathIn "define-smacro.red"$ PathIn "defconst.red"$ PathIn "string-gensym.red"$ PathIn "loop-macros.red"$ % Various macros for readability |
Added psl-1983/kernel/main.build version [8bc80a2dee].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % % MAIN.BUILD - Definition of entry point routine and symbol table init % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 May 1982 % Copyright (c) 1982 University of Utah % PathIn "main-start.red"$ |
Added psl-1983/kernel/mini-editor.red version [7fe2597350].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.KERNEL>MINI-EDITOR.RED.3, 21-Sep-82 11:14:10, Edit by BENSON % Flagged internal functions %. PSL Structure Editor Module; %. Adapted By D. Morrison for PSL V1. %. Based on Nordstroms trimmed InterLISP editor %. Cleaned Up and commented by M. L. Griss, %. 8:57pm Monday, 2 November 1981 %. See PH:Editor.Hlp for guide CompileTime flag('(EDIT0 QEDNTH EDCOPY RPLACEALL FINDFIRST XCHANGE XINS), 'InternalFunction); FLUID '(QEDITFNS %. Keep track of which changed !*EXPERT %. Do not print "help" if NIL !*VERBOSE %. Dont do implicit "P" if NIL PROMPTSTRING!* %. For "nicer" interface EditorReader!* %. Use RLISP etc Syntax, ala Break EditorPrinter!* CL ); QEDITFNS:=NIL; !*Expert := NIL; !*Verbose := NIL; lisp procedure EDITF(FN); %. Edit a Copy of Function Body Begin scalar BRFL,X,SAVE,TRFL; %/ Capture !*BREAK, reset to NIL? X := GETD FN; If ATOM X OR CODEP CDR X then StdError BldMsg("%r is not an editable function", Fn); SAVE:=COPY CDR X; EDIT CDR X; If YESP "Change Definition?" then GO TO YES; RPLACW(CDR X,SAVE); %/ Why not Just PUTD again? RETURN NIL; YES: If NULL (FN MEMBER QEDITFNS) then QEDITFNS:=FN.QEDITFNS; RETURN FN; END; lisp procedure EDIT S; %. Edit a Structure, S begin scalar PROMPTSTRING!*; PROMPTSTRING!* := "edit> "; TERPRI(); If NOT !*EXPERT then PRIN2T "Type HELP<CR> for a list of commands."; %/ Savea copy for UNDO? RETURN EDIT0(S,EDITORREADER!* OR 'READ,EDITORPRINTER!* OR 'PRINT) END; lisp procedure EDIT0(S,READER,PRINTER); Begin scalar CL,CTLS,CTL,PLEVEL,TOP,TEMP,X,NNN; TOP:=LIST S; PLEVEL:=3; B: CTL:=TOP; CTLS:=LIST CTL; CL:=CAR TOP; NEXT: If !*VERBOSE then APPLY(PRINTER,LIST EDCOPY(CL,PLEVEL)); X:=APPLY(READER,NIL); If ATOM X then GO TO ATOMX else If NUMBERP CAR X then If CAR X = 0 then GO TO ILLG else If CAR X > 0 then XCHANGE(QEDNTH(CAR X - 1,CL),CTL,CDR X,CAR X) else XINS(QEDNTH(-(CAR X + 1),CL),CTL,CDR X,CAR X) else If CAR X = 'R then RPLACEALL(CADR X,CADDR X,CL) else GO TO ILLG; GO TO NEXT; F: TEMP:=FINDFIRST(APPLY(READER,NIL),CL,CTLS); If NULL TEMP then <<PRIN2T "NOT FOUND"; GO TO NEXT>>; CL:=CAR TEMP; CTLS:=CDR TEMP; CTL:=CAR CTLS; GO TO NEXT; ATOMX: If NUMBERP X then If X = 0 then CL:=CAR CTL else GO TO NUMBX else If X = 'P then !*VERBOSE OR APPLY(PRINTER,LIST EDCOPY(CL,PLEVEL)) else If X = 'OK then RETURN CAR TOP else If X = 'UP then GO TO UP else If X = 'B then BREAK() else If X = 'F then GO TO F else If X = 'PL then PLEVEL:=APPLY(READER,NIL) else If X MEMQ '(HELP !?) then EHELP() else If X EQ 'E then Apply(PRINTER,LIST EVAL Apply(READER,NIL)) else If X = 'T then GO TO B else GO TO ILLG; GO TO NEXT; UP: If CDR CTLS then GO TO UP1; PRIN2T "You are already at the top level"; GO TO NEXT; UP1: CTLS:=CDR CTLS; CTL:=CAR CTLS; CL:=CAR CTL; GO TO NEXT; NUMBX: NNN := X; X:=QEDNTH(ABS(X),CL); If NULL X then << PRIN2T "List empty"; GO TO NEXT >>; If NNN > 0 then CL:=CAR X; CTL:=X; CTLS:=CTL.CTLS; GO TO NEXT; ILLG: PRIN2T "Illegal command"; GO TO NEXT END; lisp procedure QEDNTH(N,L); If ATOM L then NIL else If N > 1 then QEDNTH(N-1,CDR L) else L; lisp procedure EDCOPY(L,N); If ATOM L then L else If N < 0 then "***" else EDCOPY(CAR L,N-1).EDCOPY(CDR L,N); lisp procedure RPLACEALL(A,NEW,S); If ATOM S then NIL else If CAR S = A then RPLACEALL(A,NEW,CDR RPLACA(S,NEW)) else <<RPLACEALL(A,NEW,CAR S); RPLACEALL(A,NEW,CDR S)>>; lisp procedure FINDFIRST(A,S,TRC); %. FIND Occurance of A in S Begin scalar RES; If ATOM S then RETURN NIL; If A MEMBER S then RETURN S. TRC; RETURN(FINDFIRST(A,CAR S,S.TRC) or FINDFIRST(A,CDR S,TRC)); %/ Add a PMAT here END; lisp procedure XCHANGE(S,CTL,NEW,N); If ATOM S then <<PRIN2T "List empty"; NIL>> else If N = 1 then <<RPLACA(CTL,NCONC(NEW,CDR S)); CL:=CAR CTL>> else RPLACD(S,NCONC(NEW,If CDDR S then CDDR S else NIL)); lisp procedure XINS(S,CTL,NEW,N); If ATOM S then <<PRIN2T "List empty"; NIL>> else If N = 1 then <<RPLACA(CTL,NCONC(NEW,S)); CL:=CAR CTL>> else RPLACD(S,NCONC(NEW,CDR S)); UNFLUID '(CL); lisp procedure EHELP; << EvLoad '(Help); DisplayHelpFile 'Editor >>; PUT('EDIT, 'HelpFunction, 'EHELP); PUT('EDITF, 'HelpFunction, 'EHELP); PUT('EDITOR, 'HelpFunction, 'EHELP); END; |
Added psl-1983/kernel/mini-trace.red version [354ceb5232].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MINI-TRACE.RED - Simple trace and BreakFn package % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>MINI-TRACE.RED.4, 3-May-82 11:26:12, Edit by BENSON % Bug fix in BR.PRC, changed VV to MkQuote VV % Non-Standard Lisp functions used: % PrintF, ErrorPrintF, BldMsg, EqCar, Atsoc, MkQuote, SubSeq % -------- Simple TRACE package ----------- fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure Tr!.Prc(PN, B, A); % Called in place of Traced code % % Called by TRACE for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); VV := Apply(B, A); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, VV); TrSpace!* := TrSpace!* - 1; return VV end; fluid '(!*Comp !*RedefMSG PromptString!*); lisp procedure Tr!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp, !*RedefMSG; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be traced", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Tr!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'TraceCode, cdr GetD Nam); end; lisp procedure UnTr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'TraceCode)) then << ErrorPrintF("*** %r cannot be untraced", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure TR L; %. Trace functions in L list('EvTR, MkQuote cdr L); expr procedure EvTR L; for each X in L do Tr!.1 X; macro procedure UnTr L; %. Untrace Function in L list('EvUnTr, MkQuote cdr L); expr procedure EvUnTr L; for each X in L do UnTr!.1 X; lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); lisp procedure TrClr(); %. Called to setup or fix trace << TrSpace!* := 0; !*NoTrArgs := NIL >>; LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, ErrorForm!*); TrSpace!* := TrSpace!* - 1; return ErrorForm!* end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; for each X in L do Br!.1 X; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; END; |
Added psl-1983/kernel/oblist.red version [55ca349791].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OBLIST.RED - Intern, RemOb and friends % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>OBLIST.RED.9, 15-Sep-82 09:35:25, Edit by BENSON % InternP accepts a string as well as a symbol % CopyString and CopyStringToFrom are found in COPIERS.RED CompileTime flag('(AddToObList LookupOrAddToObList InObList InitNewID GenSym1), 'InternalFunction); on SysLisp; internal WConst DeletedSlotValue = -1, EmptySlotValue = 0; CompileTime << syslsp smacro procedure DeletedSlot U; ObArray U eq DeletedSlotValue; syslsp smacro procedure EmptySlot U; ObArray U eq EmptySlotValue; syslsp smacro procedure NextSlot H; if H eq MaxObArray then 0 else H + 1; % StringEqual found in EQUAL.RED syslsp smacro procedure EqualObArrayEntry(ObArrayIndex, S); StringEqual(SymNam ObArray ObArrayIndex, S); >>; syslsp procedure AddToObList U; % % U is an ID, which is added to the oblist if an ID with the same % print name is not already there. The interned ID is returned. % begin scalar V, W, X, Y; W := IDInf U; U := StrInf SymNam W; Y := StrLen U; if Y < 0 then return StdError '"The null string cannot be interned"; if Y eq 0 then return MkID StrByt(U, 0); return if OccupiedSlot(V := InObList U) then MkID ObArray V else << ObArray V := W; X := GtConstSTR Y; CopyStringToFrom(X, U); SymNam W := MkSTR X; MkID W >>; end; syslsp procedure LookupOrAddToObList U; % % U is a String, which IS copied if it is not found on the ObList % The interned ID with U as print name is returned % begin scalar V, W, X, Y; U := StrInf U; Y := StrLen U; if Y < 0 then return StdError '"The null string cannot be interned"; if Y eq 0 then return MkID StrByt(U, 0); return if OccupiedSlot(V := InObList U) then MkID ObArray V else << W := GtID(); % allocate a new ID ObArray V := W; % plant it in the Oblist X := GtConstSTR Y; % allocate a string from uncollected CopyStringToFrom(X, StrInf U); % space InitNewID(W, MkSTR X) >>; end; syslsp procedure NewID S; %. Allocate un-interned ID with print name S InitNewID(GtID(), S); % Doesn't copy S syslsp procedure InitNewID(U, V); % Initialize cells of an ID to defaults << SymNam U := V; U := MkID U; MakeUnBound U; SetProp(U, NIL); MakeFUnBound U; U >>; syslsp procedure HashFunction S; % Compute hash function of string begin scalar Len, HashVal; % Fold together a bunch of bits S := StrInf S; HashVal := 0; % from the first BitsPerWord - 8 Len := StrLen S; % chars of the string if Len > BitsPerWord - 8 then Len := BitsPerWord - 8; for I := 0 step 1 until Len do HashVal := LXOR(HashVal, LSH(StrByt(S, I), (BitsPerWord - 8) - I)); return MOD(HashVal, MaxObArray); end; syslsp procedure InObList U; % U is a string. Returns an ObArray pointer begin scalar H, DSlot, WalkObArray; H := HashFunction U; WalkObArray := H; DSlot := -1; Loop: if EmptySlot WalkObArray then return if DSlot neq -1 then DSlot else WalkObArray else if DeletedSlot WalkObArray and DSlot eq -1 then DSlot := WalkObArray else if EqualObArrayEntry(WalkObArray, U) then return WalkObArray; WalkObArray := NextSlot WalkObArray; if WalkObArray eq H then FatalError "Oblist overflow"; goto Loop; end; syslsp procedure Intern U; %. Add U to ObList % % U is a string or uninterned ID % if IDP U then AddToObList U else if StringP U then LookupOrAddToObList U else TypeError(U, 'Intern, '"ID or string"); syslsp procedure RemOb U; %. REMove id from OBlist begin scalar V; if not IDP U then return NonIDError(U, 'RemOb); V := IDInf U; if V < 128 then return TypeError(U, 'RemOb, '"non-char"); V := SymNam V; return << if OccupiedSlot(V := InObList V) then ObArray V := DeletedSlotValue; U >> end; % Changed to allow a string as well as a symbol, EB, 15 September 1982 syslsp procedure InternP U; %. Is U an interned ID? if IDP U then << U := IDInf U; U < 128 or U eq ObArray InObList SymNam U >> else if StringP U then StrLen StrInf U eq 0 or OccupiedSlot InObList U else NIL; internal WString GenSymPName = "G0000"; syslsp procedure GenSym(); %. GENerate unique, uninterned SYMbol << GenSym1 4; NewID CopyString GenSymPName >>; syslsp procedure GenSym1 N; % Auxiliary function for GenSym begin scalar Ch; return if N > 0 then if (Ch := StrByt(GenSymPName, N)) < char !9 then StrByt(GenSymPName, N) := Ch + 1 else << StrByt(GenSymPName, N) := char !0; GenSym1(N - 1) >> else % start over << StrByt(GenSymPName, 0) := StrByt(GenSymPName, 0) + 1; GenSym1 4 >>; end; syslsp procedure InternGenSym(); %. GENerate unique, interned SYMbol << GenSym1 4; Intern MkSTR GenSymPName >>; syslsp procedure MapObl F; %. Apply F to every interned ID << for I := 0 step 1 until 127 do Apply(F, list MkID I); for I := 0 step 1 until MaxObArray do if OccupiedSlot I then Apply(F, list MkID ObArray I) >>; % These functions provide support for multiple oblists % Cf PACKAGE.RED for their use internal WVar LastObArrayPtr; syslsp procedure GlobalLookup S; % Lookup string S in global oblist if not StringP S then NonStringError(S, 'GlobalLookup) else if OccupiedSlot(LastObArrayPtr := InObList S) then MkID ObArray LastObArrayPtr else '0; syslsp procedure GlobalInstall S; % Add new ID with PName S to oblist begin scalar Ind, PN; Ind := GlobalLookup S; return if Ind neq '0 then Ind else << Ind := GtID(); ObArray LastObArrayPtr := Ind; PN := GtConstSTR StrLen StrInf S; % allocate a string from uncollected CopyStringToFrom(PN, StrInf S); % space InitNewID(Ind, MkSTR PN) >>; end; syslsp procedure GlobalRemove S; % Remove ID with PName S from oblist begin scalar Ind; Ind := GlobalLookup S; return if Ind eq '0 then '0 else << Ind := ObArray LastObArrayPtr; ObArray LastObArrayPtr := DeletedSlotValue; MkID Ind >>; end; syslsp procedure InitObList(); begin scalar Tmp; if_system(MC68000, << % 68000 systems don't clear memory statically for I := 0 step 1 until MaxObArray do ObArray I := EmptySlotValue >>); Tmp := NextSymbol - 1; for I := 128 step 1 until Tmp do ObArray InObList SymNam I := I; end; off SysLisp; StartupTime InitObList(); END; |
Added psl-1983/kernel/onoff.red version [fd2ab58daf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ONOFF.RED - Macros for setting/resetting flags, with SIMPFG hook % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 July 1982 % Copyright (c) 1982 University of Utah % % ONOFF.RED - ON and OFF for Bare PSL % MLG, from PU:RLISP-PARSER.RED lisp procedure OnOff!*(IdList, U); % % IdList is list of variables without !* prefix, U is T or NIL % begin scalar Y; for each X in IdList do if not IDP X then NonIDError(X, if null U then 'OFF else 'ON) else << Set(MkFlagVar X, U); if (Y := Atsoc(U, get(X, 'SIMPFG))) then Eval second Y >>; end; lisp procedure MkFlagVar U; % Should be redefined in PACKAGE.RED Intern Concat("*", ID2String U); % to lambda-bind current pkg to GLOBAL macro procedure ON U; list('OnOff!*, MkQuote cdr U, T); macro procedure OFF U; list('OnOff!*, MkQuote cdr U, NIL); flag('(ON OFF), 'IGNORE); END; |
Added psl-1983/kernel/open-close.red version [0662cc734a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OPEN-CLOSE.RED - File primitives % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1700-PST % Close now checks for a legitimate FileDes argument fluid '(SpecialReadFunction!* % These must be set up for special SpecialWriteFunction!* % Open call SpecialCloseFunction!*); on SysLisp; external WArray ReadFunction, % indexed by channel to read a char WriteFunction, % indexed by channel to write a char CloseFunction, % indexed by channel to close channel UnReadBuffer, % indexed by channel for input backup LinePosition, % indexed by channel for Posn() MaxLine; % when to force an end-of-line syslsp procedure Open(FileName, AccessType); %. Get access to file begin scalar FileDes; if AccessType eq 'INPUT then << FileDes := SystemOpenFileForInput FileName; UnReadBuffer[FileDes] := char NULL; WriteFunction[FileDes] := 'ReadOnlyChannel >> else if AccessType eq 'OUTPUT then << FileDes := SystemOpenFileForOutput FileName; LinePosition[FileDes] := 0; MaxLine[FileDes] := 80; ReadFunction[FileDes] := 'WriteOnlyChannel >> else if AccessType eq 'SPECIAL then if IDP LispVar SpecialReadFunction!* and IDP LispVar SpecialWriteFunction!* and IDP LispVar SpecialCloseFunction!* then << FileDes := SystemOpenFileSpecial FileName; LinePosition[FileDes] := 0; MaxLine[FileDes] := 80; UnReadBuffer[FileDes] := char NULL; ReadFunction[FileDes] := IdInf LispVar SpecialReadFunction!*; WriteFunction[FileDes] := IdInf LispVar SpecialWriteFunction!*; CloseFunction[FileDes] := IdInf LispVar SpecialCloseFunction!* >> else IOError "Improperly set-up special IO open call" else IOError "Unknown access type"; return MkINT FileDes; end; syslsp procedure Close FileDes; %. End access to file begin scalar BareFileDes; BareFileDes := IntInf FileDes; if not (0 <= BareFileDes and BareFileDes <= MaxChannels) then NonIOChannelError(FileDes, "Close"); IDApply1(BareFileDes, CloseFunction[BareFileDes]); SystemMarkAsClosedChannel FileDes; ReadFunction[BareFileDes] := 'ChannelNotOpen; WriteFunction[BareFileDes] := 'ChannelNotOpen; CloseFunction[BareFileDes] := 'ChannelNotOpen; return FileDes; end; off SysLisp; END; |
Added psl-1983/kernel/other-io.red version [87c68be2b7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OTHER-IO.RED - Miscellaneous input and output functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1428-PST % put in Kessler's change so ChannelLineLength allows Len=0 to mean that % EOL is not to be automatically written. % <PSL.KERNEL>OTHER-IO.RED.3, 29-Dec-82 12:23:52, Edit by PERDUE % added LPosn and ChannelLPosn % <PSL.KERNEL>OTHER-IO.RED.2, 17-Sep-82 15:46:38, Edit by BENSON % Added ChannelLinelength, ChannelPosn, ChannelEject, ChannelTerPri % ChannelReadCH, ChannelPrinC % <PSL.INTERP>OTHER-IO.RED.3, 21-Jul-82 00:48:35, Edit by BENSON % Made ReadCh do case conversion for *Raise % Most of the uninteresting I/O functions from the Standard Lisp report global '(OUT!*); % Current output channel fluid '(!*Raise); % controls case conversion of IDs on SysLisp; external WArray LinePosition, % Array indexed by channel MaxLine; % ditto syslsp procedure ChannelEject C; %. Skip to top of next output page << ChannelWriteChar(C, char FF); % write a formfeed NIL >>; syslsp procedure Eject(); %. Skip to top of next output page ChannelEject LispVar OUT!*; syslsp procedure ChannelLineLength(Chn, Len); %. Set maximum line length begin scalar OldLen, StripLen; OldLen := MaxLine[Chn]; if Len then if IntP Len and Len >= 0 then MaxLine[Chn] := Len else StdError BldMsg('"%r is an invalid line length", Len); return OldLen; % if Len is NIL, just return current end; syslsp procedure LineLength Len; %. Set maximum line length ChannelLineLength(LispVar OUT!*, Len); syslsp procedure ChannelPosn Chn; %. Number of characters since last EOL LinePosition[Chn]; syslsp procedure Posn(); %. Number of characters since last EOL ChannelPosn LispVar OUT!*; syslsp procedure ChannelLPosn Chn; %. Number of EOLs since last FF PagePosition[Chn]; syslsp procedure LPosn(); %. Number of EOLs since last FF ChannelLPosn LispVar OUT!*; syslsp procedure ChannelReadCH Chn; %. Read a single character ID begin scalar X; % for Standard Lisp compatibility X := ChannelReadChar Chn; % converts lower to upper when *RAISE if LispVar !*Raise and X >= char lower a and X <= char lower z then X := char A + (X - char lower a); return MkID X; end; syslsp procedure ReadCH(); %. Read a single character ID ChannelReadCH LispVar IN!*; syslsp procedure ChannelTerPri Chn; %. Terminate current output line << ChannelWriteChar(Chn, char EOL); NIL >>; syslsp procedure TerPri(); %. Terminate current output line ChannelTerPri LispVar OUT!*; off SysLisp; LoadTime PutD('PrinC, 'EXPR, cdr GetD 'Prin2); % same definition as Prin2 LoadTime PutD('ChannelPrinC, 'EXPR, cdr GetD 'ChannelPrin2); % same definition as ChannelPrin2 END; |
Added psl-1983/kernel/others-sl.red version [9f1bef2026].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % OTHERS-SL.RED - Random Standard Lisp functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % These are functions that didn't have a logical home % Most could have been defined portably, but were not for efficiency reasons on SysLisp; off R2I; syslsp procedure FixP U; %. Is U an integer? FixP U; on R2I; syslsp procedure Digit U; %. Is U an ID whose print name is a digit? IDP U and (U := IDInf U) >= char !0 and U <= char !9; syslsp procedure Liter U; %. Is U a single character alphabetic ID? IDP U and ((U := IDInf U) >= char A and U <= char Z or U >= char !a and U <= char !z); off SysLisp; CompileTime flag('(Length1), 'InternalFunction); lisp procedure Length U; %. Length of list U Length1(U, 0); lisp procedure Length1(U, N); if PairP U then Length1(cdr U, IAdd1 N) else N; END; |
Added psl-1983/kernel/p-apply-lap.red version [e5ef19329a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-APPLY-LAP.RED - Inefficient, portable version of APPLY-LAP % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 29 July 1982 % Copyright (c) 1982 University of Utah % % Functions which must be written non-portably: % CodePrimitive % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without distubing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. % CompiledCallingInterpreted % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the ID % in the fluid variable CodeForm!* without disturbing the argument % registers, then finish with % (!*JCALL CompiledCallingInterpretedAux) % (CompiledCallingInterpretedAux may be flagged 'InternalFunction). % FastApply % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). % UndefinedFunction % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. CompileTime << flag('(CompiledCallingInterpretedAuxAux BindEvalAux SaveRegisters), 'InternalFunction); fluid '(CodePtr!* % gets code pointer used by CodePrimitive CodeForm!* % gets fn to be called from code ); >>; on Syslisp; internal WArray CodeArgs[15]; syslsp procedure CodeApply(CodePtr, ArgList); begin scalar I; I := 0; LispVar CodePtr!* := CodePtr; while PairP ArgList and ILessP(I, 15) do << WPutV(CodeArgs , I, first ArgList); I := IAdd1 I; ArgList := rest ArgList >>; if IGEQ(I, 15) then return StdError "Too many arguments to function"; return case I of 0: CodePrimitive(); 1: CodePrimitive WGetV(CodeArgs, 0); 2: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1)); 3: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2)); 4: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3)); 5: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4)); 6: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5)); 7: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6)); 8: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7)); 9: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8)); 10: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9)); 11: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10)); 12: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11)); 13: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12)); 14: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13)); 15: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13), WGetV(CodeArgs, 14)); end; end; %lisp procedure CodeEvalApply(CodePtr, ArgList); % CodeApply(CodePtr, EvLis ArgList); lap '((!*entry CodeEvalApply expr 2) (!*ALLOC 15) (!*LOC (reg 3) (frame 15)) (!*CALL CodeEvalApplyAux) (!*EXIT 15) ); syslsp procedure CodeEvalApplyAux(CodePtr, ArgList, P); begin scalar N; N := 0; while PairP ArgList and ILessP(N, 15) do << WPutV(P, ITimes2(StackDirection, N), Eval first ArgList); ArgList := rest ArgList; N := IAdd1 N >>; if IGEQ(N, 15) then return StdError "Too many arguments to function"; LispVar CodePtr!* := CodePtr; return case N of 0: CodePrimitive(); 1: CodePrimitive WGetV(P, ITimes2(StackDirection, 0)); 2: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1))); 3: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2))); 4: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3))); 5: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4))); 6: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5))); 7: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6))); 8: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7))); 9: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8))); 10: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9))); 11: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10))); 12: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11))); 13: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12))); 14: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13))); 15: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13)), WGetV(P, ITimes2(StackDirection, 14))); end; end; off Syslisp; syslsp procedure BindEval(Formals, Args); BindEvalAux(Formals, Args, 0); syslsp procedure BindEvalAux(Formals, Args, N); begin scalar F, A; return if PairP Formals then if PairP Args then << F := first Formals; A := Eval first Args; N := BindEvalAux(rest Formals, rest Args, IAdd1 N); if N = -1 then -1 else << LBind1(F, A); N >> >> else -1 else if PairP Args then -1 else N; end; syslsp procedure SaveRegisters(A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14, A15); << CodeArgs[14] := A15; CodeArgs[13] := A14; CodeArgs[12] := A13; CodeArgs[11] := A12; CodeArgs[10] := A11; CodeArgs[9] := A10; CodeArgs[8] := A9; CodeArgs[7] := A8; CodeArgs[6] := A7; CodeArgs[5] := A6; CodeArgs[4] := A5; CodeArgs[3] := A4; CodeArgs[2] := A3; CodeArgs[1] := A2; CodeArgs[0] := A1 >>; syslsp procedure CompiledCallingInterpretedAux(); << SaveRegisters(); CompiledCallingInterpretedAuxAux get(LispVar CodeForm!*, '!*LambdaLink) >>; syslsp procedure FastLambdaApply(); << SaveRegisters(); CompiledCallingInterpretedAuxAux LispVar CodeForm!* >>; syslsp procedure CompiledCallingInterpretedAuxAux Fn; if not (PairP Fn and car Fn = 'LAMBDA) then StdError BldMsg("Ill-formed functional expression %r for %r", Fn, LispVar CodeForm!*) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals do << LBind1(car Formals, WGetV(CodeArgs, N)); Formals := cdr Formals; N := IAdd1 N >>; Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off Syslisp; END; |
Added psl-1983/kernel/printers.red version [c875d7313d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PRINTERS.RED - Printing functions for various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PRINTERS.RED.17, 7-Mar-83 11:53:59, Edit by KESSLER % Change Channelwriteblankoreol to check linelength = 0 also. % Edit by MLGriss, 11:31am Saturday, 5 February 1983 % Fix ChannelWriteBitstring to put out a single 0 if needed % Fixed to handle largest NEGATIVE number correctly % Used to get ------, since -(largest neg) NOT=largestPOS % <PSL.KERNEL>PRINTERS.RED.14, 31-Jan-83 15:45:30, Edit by PERDUE % Fix to printing of EVECTORs % Edit by Cris Perdue, 29 Jan 1983 1620-PST % Removed definition of EVecInf (both compile- and load-time) % Edit by Cris Perdue, 27 Jan 1983 1436-PST % Put in Kessler's change so CheckLineFit won't write EOL if LineLength = 0 % <PSL.KERNEL>PRINTERS.RED.11, 10-Jan-83 13:58:14, Edit by PERDUE % Added some code to handle EVectors, especially to represent OBJECTs % <PSL.KERNEL>PRINTERS.RED.10, 21-Dec-82 15:24:18, Edit by BENSON % Changed order of tests in WriteInteger so that -ive hex #s are done right % <PSL.KERNEL>PRINTERS.RED.9, 4-Oct-82 10:04:34, Edit by BENSON % Added PrinLength and PrinLevel % <PSL.KERNEL>PRINTERS.RED.3, 23-Sep-82 13:16:20, Edit by BENSON % Look for # of args in code pointer, changed : to space in #<...> stuff % <PSL.INTERP>PRINTERS.RED.12, 2-Sep-82 09:01:31, Edit by BENSON % (QUOTE x y) prints correctly, not as 'x % <PSL.INTERP>PRINTERS.RED.11, 4-May-82 20:31:32, Edit by BENSON % Printers keep tags on, for Emode GC % <PSL.VAX-INTERP>PRINTERS.RED.6, 18-Feb-82 16:30:12, Edit by BENSON % Added printer for unbound, changed code to #<Code:xx> % <PSL.VAX-INTERP>PRINTERS.RED.2, 20-Jan-82 02:11:16, Edit by GRISS % fixed prining of zero length vectors % <PSL.VAX-INTERP>PRINTERS.RED.1, 15-Jan-82 14:27:13, Edit by BENSON % Changed for new integer tags % <PSL.INTERP>PRINTERS.RED.13, 7-Jan-82 22:47:40, Edit by BENSON % Made (QUOTE xxx) print as 'xxx % <PSL.INTERP>PRINTERS.RED.12, 5-Jan-82 21:37:41, Edit by BENSON % Changed OBase to OutputBase!* fluid '(OutputBase!* % current output base PrinLength % length of structures to print PrinLevel % level of recursion to print CurrentScanTable!* IDEscapeChar!* !*Lower); % print IDs with uppercase chars lowered global '(LispScanTable!*); LoadTime << OutputBase!* := 10; IDEscapeChar!* := 33; % (char !!) CurrentScanTable!* := LispScanTable!* >>; % so TokenTypeOfChar works right on SysLisp; CompileTime << syslsp smacro procedure UpperCaseP Ch; Ch >= char A and Ch <= char Z; syslsp smacro procedure LowerCaseP Ch; Ch >= char !a and Ch <= char !z; syslsp smacro procedure RaiseChar Ch; (Ch - char !a) + char A; syslsp smacro procedure LowerChar Ch; (Ch - char A) + char !a; >>; CompileTime flag('(CheckLineFit WriteNumber1 ChannelWriteBitString), 'InternalFunction); %. Writes EOL first if given Len causes max line length to be exceeded syslsp procedure CheckLineFit(Len, Chn, Fn, Itm); << if (LinePosition[Chn] + Len > MaxLine[Chn]) and (MaxLine[Chn] > 0) then ChannelWriteChar(Chn, char EOL); IDApply2(Chn, Itm, Fn) >>; syslsp procedure ChannelWriteString(Channel, Strng); % % Strng may be tagged or not, but it must have a length field accesible % by StrLen. % begin scalar UpLim; UpLim := StrLen StrInf Strng; for I := 0 step 1 until UpLim do ChannelWriteChar(Channel, StrByt(StrInf Strng, I)); end; syslsp procedure WriteString S; ChannelWriteString(LispVar OUT!*, S); internal WString DigitString = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; internal WString WriteNumberBuffer[40]; syslsp procedure ChannelWriteSysInteger(Channel, Number, Radix); begin scalar Exponent,N1; return if (Exponent := SysPowerOf2P Radix) then ChannelWriteBitString(Channel, Number, Radix - 1, Exponent) else if Number < 0 then << ChannelWriteChar(Channel, char '!-); WriteNumber1(Channel,-(Number/Radix),Radix); % To catch largest NEG ChannelWriteChar(Channel, StrByt(DigitString, - MOD(Number, Radix))) >> else if Number = 0 then ChannelWriteChar(Channel, char !0) else WriteNumber1(Channel, Number, Radix); end; syslsp procedure WriteNumber1(Channel, Number, Radix); if Number = 0 then Channel else << WriteNumber1(Channel, Number / Radix, Radix); ChannelWriteChar(Channel, StrByt(DigitString, MOD(Number, Radix))) >>; syslsp procedure ChannelWriteBitString(Channel, Number, DigitMask, Exponent); if Number = 0 then ChannelWriteChar(Channel,char !0) else ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); syslsp procedure ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); if Number = 0 then Channel % Channel means nothing here else % just trying to fool the compiler << ChannelWriteBitStrAux(Channel, LSH(Number, -Exponent), DigitMask, Exponent); ChannelWriteChar(Channel, StrByt(DigitString, LAND(Number, DigitMask))) >>; syslsp procedure WriteSysInteger(Number, Radix); ChannelWriteSysInteger(LispVar OUT!*, Number, Radix); syslsp procedure ChannelWriteFixnum(Channel, Num); ChannelWriteInteger(Channel, FixVal FixInf Num); syslsp procedure ChannelWriteInteger(Channel, Num); begin scalar CurrentBase; if (CurrentBase := LispVar OutputBase!*) neq 10 then << ChannelWriteSysInteger(Channel, CurrentBase, 10); ChannelWriteChar(Channel, char !#) >>; ChannelWriteSysInteger(Channel, Num, CurrentBase); end; syslsp procedure ChannelWriteSysFloat(Channel, FloatPtr); begin scalar Ch, ChIndex; WriteFloat(WriteNumberBuffer, FloatPtr); ChannelWriteString(Channel, WriteNumberBuffer); end; syslsp procedure ChannelWriteFloat(Channel, LispFloatPtr); ChannelWriteSysFloat(Channel, FloatBase FltInf LispFloatPtr); syslsp procedure ChannelPrintString(Channel, Strng); begin scalar Len, Ch; ChannelWriteChar(Channel, char !"); Len := StrLen StrInf Strng; for I := 0 step 1 until Len do << Ch := StrByt(StrInf Strng, I); if Ch eq char !" then ChannelWriteChar(Channel, char !"); ChannelWriteChar(Channel, Ch) >>; ChannelWriteChar(Channel, char !"); end; syslsp procedure ChannelWriteID(Channel, Itm); if not LispVar !*Lower then ChannelWriteString(Channel, SymNam IDInf Itm) else begin scalar Ch, Len; Itm := StrInf SymNam IDInf Itm; Len := StrLen Itm; for I := 0 step 1 until Len do << Ch := StrByt(Itm, I); if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch) >>; end; syslsp procedure ChannelWriteUnbound(Channel, Itm); << ChannelWriteString(Channel, "#<Unbound:"); ChannelWriteID(Channel, Itm); ChannelWriteChar(Channel, char '!>) >>; syslsp procedure ChannelPrintID(Channel, Itm); begin scalar Len, Ch, TokenType; Itm := StrInf SymNam IDInf Itm; Len := StrLen Itm; Ch := StrByt(Itm, 0); if TokenTypeOfChar Ch neq 10 then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); if not LispVar !*Lower then << ChannelWriteChar(Channel, Ch); for I := 1 step 1 until Len do << Ch := StrByt(Itm, I); TokenType := TokenTypeOfChar Ch; if not (TokenType <= 10 or TokenType eq PLUSSIGN or TokenType eq MINUSSIGN) then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); ChannelWriteChar(Channel, Ch) >> >> else << if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch); for I := 1 step 1 until Len do << Ch := StrByt(Itm, I); TokenType := TokenTypeOfChar Ch; if not (TokenType <= 10 or TokenType eq PLUSSIGN or TokenType eq MINUSSIGN) then ChannelWriteChar(Channel, LispVar IDEscapeChar!*); if UpperCaseP Ch then Ch := LowerChar Ch; ChannelWriteChar(Channel, Ch) >> >> end; syslsp procedure ChannelPrintUnbound(Channel, Itm); << ChannelWriteString(Channel, "#<Unbound "); ChannelPrintID(Channel, Itm); ChannelWriteChar(Channel, char '!>) >>; syslsp procedure ChannelWriteCodePointer(Channel, CP); begin scalar N; CP := CodeInf CP; ChannelWriteString(Channel, "#<Code "); N := !%code!-number!-of!-arguments CP; if N >= 0 and N <= MaxArgs then << ChannelWriteSysInteger(Channel, N, 10); ChannelWriteChar(Channel, char BLANK) >>: ChannelWriteSysInteger(Channel, CP, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); end; syslsp procedure ChannelWriteUnknownItem(Channel, Itm); << ChannelWriteString(Channel, "#<Unknown "); ChannelWriteSysInteger(Channel, Itm, CompressedBinaryRadix); ChannelWriteChar(Channel, char !>) >>; syslsp procedure ChannelWriteBlankOrEOL Channel; << if (LinePosition[Channel] + 1 >= MaxLine[Channel]) and (MaxLine[Channel] > 0) then ChannelWriteChar(Channel, char EOL) else ChannelWriteChar(Channel, char ! ) >>; syslsp procedure ChannelWritePair(Channel, Itm, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar N; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char !( ); if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then << RecursiveChannelPrin2(Channel, car Itm, Level); N := 2; Itm := cdr Itm; while PairP Itm and (not IntP LispVar PrinLength or N <= LispVar PrinLength) do << ChannelWriteBlankOrEOL Channel; RecursiveChannelPrin2(Channel, car Itm, Level); N := N + 1; Itm := cdr Itm >>; if PairP Itm then CheckLineFit(3, Channel, 'ChannelWriteString, " ...") else if Itm then << CheckLineFit(3, Channel, 'ChannelWriteString, " . "); RecursiveChannelPrin2(Channel, Itm, Level) >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char !) ); end; syslsp procedure ChannelPrintPair(Channel, Itm, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar N; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char !( ); if not IntP LispVar PrinLength or 1 <= LispVar PrinLength then << RecursiveChannelPrin1(Channel, car Itm, Level); N := 2; Itm := cdr Itm; while PairP Itm and (not IntP LispVar PrinLength or N <= LispVar PrinLength) do << ChannelWriteBlankOrEOL Channel; RecursiveChannelPrin1(Channel, car Itm, Level); N := N + 1; Itm := cdr Itm >>; if PairP Itm then CheckLineFit(3, Channel, 'ChannelWriteString, " ...") else if Itm then << CheckLineFit(3, Channel, 'ChannelWriteString, " . "); RecursiveChannelPrin1(Channel, Itm, Level) >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char !) ); end; syslsp procedure ChannelWriteVector(Channel, Vec, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar Len, I; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ ); Len := VecLen VecInf Vec; If Len<0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << RecursiveChannelPrin2(Channel, VecItm(VecInf Vec, I), Level); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); end; syslsp procedure ChannelPrintVector(Channel, Vec, Level); if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else begin scalar Len, I; Level := Level + 1; CheckLineFit(1, Channel, 'ChannelWriteChar, char '![ ); Len := VecLen VecInf Vec; If Len<0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << RecursiveChannelPrin1(Channel, VecItm(VecInf Vec, I), Level); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!] ); end; syslsp procedure ChannelWriteEVector(Channel, EVec, Level); begin scalar handler; if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else if getd('object!-get!-handler!-quietly) and (handler := object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then apply(handler, list(EVec, Channel, Level, NIL)) else << ChannelWriteString(Channel, "#<EVector "); ChannelWriteSysInteger(Channel, EVecInf EVec, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); >>; end; syslsp procedure ChannelPrintEVector(Channel, EVec, Level); begin scalar handler; if IntP LispVar PrinLevel and Level >= LispVar PrinLevel then ChannelWriteChar(Channel, char '!#) else if getd('object!-get!-handler!-quietly) and (handler := object!-get!-handler!-quietly(EVec, 'ChannelPrin)) then apply(handler, list(EVec, Channel, Level, T)) else << ChannelWriteString(Channel, "#<EVector "); ChannelWriteSysInteger(Channel, EVecInf EVec, CompressedBinaryRadix); ChannelWriteChar(Channel, char '!>); >>; end; syslsp procedure ChannelWriteWords(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Words:"); Len := WrdLen WrdInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, WrdItm(WrdInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelWriteHalfWords(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Halfwords:"); Len := HalfWordLen HalfWordInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, HalfWordItm(HalfWordInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelWriteBytes(Channel, Itm); begin scalar Len, I; ChannelWriteString(Channel, "#<Bytes:"); Len := StrLen StrInf Itm; if Len < 0 then return CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); I := 0; LoopBegin: if not IntP LispVar PrinLength or I < LispVar PrinLength then << CheckLineFit(10, Channel, 'ChannelWriteInteger, StrByt(StrInf Itm, I)); if (I := I + 1) <= Len then << ChannelWriteBlankOrEOL Channel; goto LoopBegin >> >> else CheckLineFit(3, Channel, 'ChannelWriteString, "..."); CheckLineFit(1, Channel, 'ChannelWriteChar, char '!> ); end; syslsp procedure ChannelPrin2(Channel, Itm); %. Display Itm on Channel RecursiveChannelPrin2(Channel, Itm, 0); syslsp procedure RecursiveChannelPrin2(Channel, Itm, Level); << case Tag Itm of PosInt, NegInt: CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm); ID: CheckLineFit(StrLen StrInf SymNam IDInf Itm + 1, Channel, 'ChannelWriteID, Itm); UNBOUND: CheckLineFit(StrLen StrInf SymNam IDInf Itm + 12, Channel, 'ChannelWriteUnbound, Itm); STR: CheckLineFit(StrLen StrInf Itm + 1, Channel, 'ChannelWriteString, Itm); CODE: CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm); FIXN: CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm); FLTN: CheckLineFit(30, Channel, 'ChannelWriteFloat, Itm); WRDS: ChannelWriteWords(Channel, Itm); Halfwords: ChannelWriteHalfWords(Channel, Itm); Bytes: ChannelWriteBytes(Channel, Itm); PAIR: ChannelWritePair(Channel, Itm, Level); VECT: ChannelWriteVector(Channel, Itm, Level); EVECT: ChannelWriteEVector(Channel, Itm, Level); default: CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm) end; Itm >>; syslsp procedure Prin2 Itm; %. ChannelPrin2 to current channel ChannelPrin2(LispVar OUT!*, Itm); syslsp procedure ChannelPrin1(Channel, Itm); %. Display Itm in READable form RecursiveChannelPrin1(Channel, Itm, 0); syslsp procedure RecursiveChannelPrin1(Channel, Itm, Level); << case Tag Itm of PosInt, NegInt: CheckLineFit(10, Channel, 'ChannelWriteInteger, Itm); ID: % leave room for possible escape chars CheckLineFit(StrLen StrInf SymNam IDInf Itm + 5, Channel, 'ChannelPrintID, Itm); UNBOUND: % leave room for possible escape chars CheckLineFit(StrLen StrInf SymNam IDInf Itm + 16, Channel, 'ChannelPrintUnbound, Itm); STR: CheckLineFit(StrLen StrInf Itm + 4, Channel, 'ChannelPrintString, Itm); CODE: CheckLineFit(14, Channel, 'ChannelWriteCodePointer, Itm); FIXN: CheckLineFit(20, Channel, 'ChannelWriteFixnum, Itm); FLTN: CheckLineFit(20, Channel, 'ChannelWriteFloat, Itm); WRDS: ChannelWriteWords(Channel, Itm); Halfwords: ChannelWriteHalfWords(Channel, Itm); Bytes: ChannelWriteBytes(Channel, Itm); PAIR: ChannelPrintPair(Channel, Itm, Level); VECT: ChannelPrintVector(Channel, Itm, Level); EVECT: ChannelPrintEVector(Channel, Itm, Level); default: CheckLineFit(20, Channel, 'ChannelWriteUnknownItem, Itm) end; Itm >>; syslsp procedure Prin1 Itm; %. ChannelPrin1 to current output ChannelPrin1(LispVar OUT!*, Itm); off SysLisp; END; |
Added psl-1983/kernel/printf.red version [1825bd545c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PRINTF.RED - Formatted print routine % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PRINTF.RED.2, 17-Sep-82 16:01:01, Edit by BENSON % Added ChannelPrintF % <PSL.INTERP>PRINTF.RED.6, 3-May-82 10:45:11, Edit by BENSON % %L prints nothing for NIL % <PSL.INTERP>PRINTF.RED.9, 23-Feb-82 21:40:31, Edit by BENSON % Added %x for hex % <PSL.INTERP>PRINTF.RED.7, 1-Dec-81 16:11:11, Edit by BENSON % Changed to cause error for unknown character CompileTime flag('(PrintF1 PrintF2), 'InternalFunction); fluid '(FormatForPrintF!*); % First, lambda-bind FormatForPrintF!* lisp procedure PrintF(FormatForPrintF!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14); PrintF1(FormatForPrintF!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13, A14); % Then, push all the registers on the stack and set up a pointer to them lap '((!*entry PrintF1 expr 15) (!*PUSH (reg 2)) (!*LOC (reg 1) (frame 1)) (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*CALL PrintF2) (!*EXIT 14) ); on SysLisp; % Finally, actual printf, with 1 argument, pointer to array of parameters syslsp procedure PrintF2 PrintFArgs; %. Formatted print % % Format is a string, either in the heap or not, whose characters will be % written on the currently selected output channel. The exception to this is % that when a % is encountered, the following character is interpreted as a % format character, to decide how to print one of the other arguments. The % following format characters are currently supported: % %b - blanks; take the next argument as integer and print that many % blanks % %c - print the next argument as a single character % %d - print the next argument as a decimal integer % %e - EVALs the next argument for side-effect -- most useful if the % thing EVALed does some printing % %f - fresh-line, print end-of-line char if not at beginning of line % %l - same as %w, except lists are printed without top level parens % %n - print end-of-line character % %o - print the next argument as an octal integer % %p - print the next argument as a Lisp item, using Prin1 % %r - print the next argument as a Lisp item, using ErrPrin (`FOO') % %s - print the next argument as a string % %t - tab; take the next argument as an integer and % print spaces to that column % %w - print the next argument as a Lisp item, using Prin2 % %x - print the next argument as a hexidecimal integer % %% - print a % % % If the character is not one of these (either upper or lower case), then an % error occurs. % begin scalar UpLim, I, Ch, UpCh; UpLim := StrLen StrInf LispVar FormatForPrintF!*; I := 0; while I <= UpLim do << Ch := StrByt(StrInf LispVar FormatForPrintF!*, I); if Ch neq char !% then WriteChar Ch else begin I := I + 1; Ch := StrByt(StrInf LispVar FormatForPrintF!*, I); UpCh := if LowerCaseChar Ch then RaiseChar Ch else Ch; case UpCh of char B: << Spaces @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char C: << WriteChar @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char D: << WriteSysInteger(@PrintFArgs, 10); PrintFArgs := &PrintFArgs[StackDirection] >>; char E: << Eval @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char F: if Posn() > 0 then WriteChar char EOL; char L: << Prin2L @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char N: WriteChar char EOL; char O: << WriteSysInteger(@PrintFArgs, 8); PrintFArgs := &PrintFArgs[StackDirection] >>; char X: << WriteSysInteger(@PrintFArgs, 16); PrintFArgs := &PrintFArgs[StackDirection] >>; char P: << Prin1 @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char R: << ErrPrin @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char S: << WriteString @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char T: << Tab @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char W: << Prin2 @PrintFArgs; PrintFArgs := &PrintFArgs[StackDirection] >>; char !%: WriteChar char !%; default: StdError BldMsg('"Unknown character code for PrintF: %r", MkID Ch); end; end; I := I + 1 >>; end; syslsp procedure ErrorPrintF(Format, A1, A2, A3, A4); % also A5..A14 begin scalar SaveChannel; SaveChannel := WRS LispVar ErrOut!*; if LinePosition[IntInf LispVar ErrOut!*] > 0 then TerPri(); PrintF(Format, A1, A2, A3, A4); if LinePosition[IntInf LispVar ErrOut!*] > 0 then TerPri(); WRS SaveChannel; end; syslsp procedure ToStringWriteChar(Channel, Ch); % shares TokenBuffer << if TokenBuffer[0] >= MaxTokenSize - 1 then << TokenBuffer[0] := 80; % truncate to 80 chars StrByt(TokenBuffer, 80) := char NULL; StdError list('"Buffer overflow while constructing error message:", LispVar FormatForPrintF!*, '"The truncated result was:", CopyString MkSTR TokenBuffer) >> else << TokenBuffer[0] := TokenBuffer[0] + 1; StrByt(TokenBuffer, TokenBuffer[0]) := Ch >> >>; syslsp procedure BldMsg(Format, Arg1, Arg2, Arg3, Arg4); %. Print to string begin scalar TempChannel; % takes up to 14 args LinePosition[2] := 0; TokenBuffer[0] := -1; TempChannel := LispVar OUT!*; LispVar OUT!* := '2; PrintF(Format, Arg1, Arg2, Arg3, Arg4); StrByt(TokenBuffer, TokenBuffer[0] + 1) := char NULL; LispVar OUT!* := TempChannel; return CopyString TokenBuffer; end; syslsp procedure ErrPrin U; %. `Prin1 with quotes' << WriteChar char !`; Prin1 U; WriteChar char !' >>; off SysLisp; lisp procedure Prin2L Itm; %. Prin2 without top-level parens if null Itm then NIL % NIL is (), print nothing else if not PairP Itm then Prin2 Itm else << while << Prin2 car Itm; Itm := cdr Itm; PairP Itm >> do ChannelWriteBlankOrEOL OUT!*; if Itm then << ChannelWriteBlankOrEOL OUT!*; Prin2 Itm >> >>; syslsp procedure ChannelPrintF(OUT!*, Format, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); PrintF(Format, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); END; |
Added psl-1983/kernel/prog-and-friends.red version [df6c762d15].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROG-AND-FRIENDS.RED - PROG, GO, and RETURN % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PROG-AND-FRIENDS.RED.2, 11-Oct-82 17:55:57, Edit by BENSON % Changed CATCH/THROW to *CATCH/*THROW % Error numbers: % 3000 - Unknown label % 3100 - outside the scope of a PROG % +1 in GO % +2 in RETURN fluid '(ProgJumpTable!* % A-List of labels and expressions ProgBody!*); % Tail of the current PROG fexpr procedure Prog ProgBody!*; %. Program feature function begin scalar ProgJumpTable!*, N, Result; if not PairP ProgBody!* then return NIL; N := 0; for each X in car ProgBody!* do << PBind1 X; N := N + 1 >>; ProgBody!* := cdr ProgBody!*; for each X on ProgBody!* do if IDP car X then ProgJumpTable!* := X . ProgJumpTable!*; while << while PairP ProgBody!* and IDP car ProgBody!* do ProgBody!* := cdr ProgBody!*; % skip over labels PairP ProgBody!* >> do % eval the expression << Result := !*Catch('!$Prog!$, Eval car ProgBody!*); if not ThrowSignal!* then << Result := NIL; ProgBody!* := cdr ProgBody!* >> >>; UnBindN N; return Result; end; lisp fexpr procedure GO U; %. Goto label within PROG begin scalar NewProgBody; return if ProgBody!* then << NewProgBody := Atsoc(car U, ProgJumpTable!*); if null NewProgBody then ContinuableError(3001, BldMsg( "%r is not a label within the current scope", car U), 'GO . U) else << ProgBody!* := NewProgBody; !*Throw('!$Prog!$, NIL) >> >> else ContinuableError(3101, "GO attempted outside the scope of a PROG", 'GO . U); end; lisp procedure Return U; %. Return value from PROG if ProgBody!* then << ProgBody!* := NIL; !*Throw('!$Prog!$, U) >> else ContError(3102, "RETURN attempted outside the scope of a PROG", Return U); END; |
Added psl-1983/kernel/project-mail.txt version [ef8699f2d1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 16-Aug-82 10:32:47-PDT,430;000000000000 Date: 16 Aug 1982 1032-PDT From: Cris Perdue <Perdue> Subject: PSL project distribution list To: PSL-Project: ; There is now a PSL project distribution list, <apptech.dist>psl-project.. Mail to this list is also sent to <hp-psl.misc>project-mail.txt. I personally have a logical device definition "dist:" that refers to both <apptech.dist> and <distribution>, thus: define dist: <apptech.dist>, <distribution> ------- 16-Aug-82 12:11:29-PDT,661;000000000000 Date: 16 Aug 1982 1211-PDT From: Cris Perdue <Perdue> Subject: PSL.EXE To: PSL-Project: ; The file PSL.EXE has been moved from <unsupported> to <psl>. <unsupported> contains a small file named psl.exe which runs <psl>psl.exe. This was done for a couple of reasons: members of the group without access to <unsupported> (part of sys:) will be able to install a new PSL; also this means that one can either just run "PSL" or follow the PSL manual's advice and run psl:psl with equal results. Probably PSL should really be on <HP-PSL>, but I got extra space from Tim for PSL on <PSL>, so let's leave things be for a couple of weeks. ------- 16-Aug-82 12:13:05-PDT,197;000000000000 Date: 16 Aug 1982 1213-PDT From: Cris Perdue <Perdue> Subject: PSL.EXE To: PSL-Project: ; The arrangements with psl.exe described in the previous note apply on both HULK and THOR. ------- 16-Aug-82 12:15:50-PDT,963;000000000000 Date: 15 Aug 1982 13:31:10-PDT From: Griss@UTAH-20 at HP-Speech Via: utah-cs Date: 14 Aug 1982 1936-MDT From: Martin.Griss <Griss at UTAH-20> Subject: Imminent Departure To: psl-users at UTAH-20 cc: griss at UTAH-20 Remailed-date: 16 Aug 1982 1215-PDT Remailed-from: Cris Perdue <Perdue> Remailed-to: PSL-Project: ; Eric and I leave for LISP82 tomorrow ~10:30am; Eric returns Wednesday evening, with a plan of packing and leaving for Palo Alto over the weekend. I return Thursday evening, and will be packing over the weekend, with a paln of leaving Thursday. Please exercise the various systems, and discuss problems with Steve Lowder. Eric will be able to give a small amount of final advice ~end of the week, and I will have a few more days. After that, Steve will be in charge of local maintenance. We will not update system until we get established at HP, early September, and get reasonable network access to Utah. M ------- 30-Aug-82 16:37:52-PDT,655;000000000000 Date: 30 Aug 1982 1637-PDT From: Cris Perdue <Perdue> Subject: PSL distribution lists To: PSL-Project: ; Three PSL-related mail distribution lists are now on <APPTECH.DIST>. Some of them were previously on <HP-PSL>. They are PSL-USERS. PSL-PROJECT. PSL-NEWS. The news distribution automatically includes all users. Mail to PSL is automatically distributed according to <HP-PSL>PSL-BUGS.DIST. This is not intended for general use as a distribution list, and also is assumed by the mail transport system to be in <HP-PSL>, so leave it there. Anyone wishing to receive a copy of PSL bug reports may put him/herself on the list. ------- 14-Sep-82 13:54:08-PDT,299;000000000000 Date: 14 Sep 1982 1353-PDT From: Eric Benson <BENSON> Subject: PSL users meeting To: PSL-Users: ;, PSL-Project: ; We will have a meeting at 1:30 PM in the conference room by Ira's office to discuss changes to be made to the current PSL system in anticipation of a general release. ------- 14-Sep-82 13:58:55-PDT,190;000000000000 Date: 14 Sep 1982 1358-PDT From: Eric Benson <BENSON> Subject: PSL users meeting To: PSL-Users: ; cc: PSL-Project: ; Whoops, that meeting is tomorrow! (Wednesday the 15th). ------- 16-Sep-82 12:17:46-PDT,1407;000000000000 Date: 16 Sep 1982 1217-PDT From: Cris Perdue <Perdue> Subject: PSL disk space on SS: To: kennard cc: PSL-Project: ; It appears that SS: is ready to receive the PSL files, though Tim has not sent me personally a message saying so. Files will be organized somewhat differently on SS: than they are now on PS:. There will be no <HP-PSL> or any of its subdirectories. There will be <PSL> and subdirectories. Please allocate it 50 subdirectories and 20,000 pages of space. This family of directories is intended to include space for Alan Snyder's PSL editor, Nancy K's mailer program, and "Visicalc" files. There will be a <PSL-DISTRIBUTION> directory to contain a complete snapshot of PSL as distributed to other sites. Please allocate it 30 subdirectories and 8,000 pages. We are requesting a system logical name definition for PSL (PSL:) to be defined as SS:<PSL>, like PASCAL, SAIL, and other subsystems have. The mailer forwards mail to PSL through a distribution list file currently defined to be <PSL>PSL-BUGS.DIST. Please change this forwarding to go through PSL:PSL-BUGS.DIST (assumes the existence of the system logical name PSL:). SYS:PSL.EXE currently causes <PSL>PSL.EXE to be executed. Please change SYS:PSL.EXE to execute PSL:PSL.EXE. There is also a file named SYS:NPSL.EXE. Please replace it with a file that causes PSL:NPSL.EXE to be run. ------- |
Added psl-1983/kernel/prop.build version [a60f14ce3d].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % PROP.BUILD - Files with functions for property lists and function definition % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "function-primitives.red"$ % used by PutD, GetD and Eval PathIn "property-list.red"$ % PUT and FLAG and friends PathIn "fluid-global.red"$ % variable declarations PathIn "putd-getd.red"$ % function defining functions |
Added psl-1983/kernel/property-list.red version [7e5b9b2d7c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PROPERTY-LIST.RED - Functions dealing with property lists % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.INTERP>PROPERTY-LIST.RED.11, 1-Mar-82 14:09:20, Edit by BENSON % Changed "move-to-front" to "exchange-with-previous" % <PSL.INTERP>PROPERTY-LIST.RED.7, 27-Feb-82 12:43:27, Edit by BENSON % Optimized GET and FLAGP, rearranges property list % Every ID in the system has a property list. It is obtained by the function % PROP(ID) and updated with the function SETPROP(ID, PLIST). These functions % are not in the Standard Lisp report, and are not intended for use in user % programs. A property list (whose format should also not be known to % user programs) is a list of IDs and dotted pairs (A-List entries). The % pairs are used by PUT and GET, and the IDs are used by FLAG and FLAGP. % Non-Standard Lisp functions used: % DELQIP -- EQ, destructive version of Delete (in EASY-NON-SL.RED) % ATSOC -- EQ version of ASSOC (in EASY-NON-SL.RED) % DELATQIP -- EQ, destructive version of DELASC (in EASY-NON-SL.RED) % EQCAR(A,B) -- PairP A and car A eq B (in EASY-NON-SL.RED) % NonIDError -- in TYPE-ERRORS.RED on SysLisp; syslsp procedure Prop U; %. Access property list of U if IDP U then SymPrp IDInf U else NonIDError(U, 'Prop); syslsp procedure SetProp(U, L); %. Store L as property list of U if IDP U then SymPrp IDInf U := L else NonIDError(U, 'SetProp); syslsp procedure FlagP(U, Indicator); %. Is U marked with Indicator? if not IDP U or not IDP Indicator then NIL else begin scalar PL, PreviousPointer; PL := SymPrp IDInf U; if null PL then return NIL; if car PL eq Indicator then return T; PreviousPointer := PL; PL := cdr PL; Loop: if null PL then return NIL; if car PL eq Indicator then return << Rplaca(PL, car PreviousPointer); Rplaca(PreviousPointer, Indicator); T >>; PreviousPointer := PL; PL := cdr PL; goto Loop; end; on FastLinks; syslsp procedure GetFnType U; get(U, 'TYPE); off FastLinks; syslsp procedure Get(U, Indicator); %. Retrieve value stored for U with Ind if not IDP U or not IDP Indicator then NIL else begin scalar PL, X, PreviousPointer; PL := SymPrp IDInf U; if null PL then return NIL; X := car PL; if PairP X and car X eq Indicator then return cdr X; PreviousPointer := PL; PL := cdr PL; Loop: if null PL then return NIL; X := car PL; if PairP X and car X eq Indicator then return << Rplaca(PL, car PreviousPointer); Rplaca(PreviousPointer, X); cdr X >>; PreviousPointer := PL; PL := cdr PL; goto Loop; end; off SysLisp; lisp procedure Flag(IDList, Indicator); %. Mark all in IDList with Indicator if not IDP Indicator then NonIDError(Indicator, 'Flag) else for each U in IDList do Flag1(U, Indicator); lisp procedure Flag1(U, Indicator); if not IDP U then NonIDError(U, 'Flag) else begin scalar PL; PL := Prop U; if not (Indicator memq PL) then SetProp(U, Indicator . PL); end; lisp procedure RemFlag(IDList, Indicator); %. Remove marking of all in IDList if not IDP Indicator then NonIDError(Indicator, 'RemFlag) else for each U in IDList do RemFlag1(U, Indicator); lisp procedure RemFlag1(U, Indicator); if not IDP U then NonIDError(U, 'RemFlag) else SetProp(U, DelQIP(Indicator, Prop U)); lisp procedure Put(U, Indicator, Val); %. Store Val in U with Indicator if not IDP U then NonIDError(U, 'Put) else if not IDP Indicator then NonIDError(Indicator, 'Put) else begin scalar PL, V; PL := Prop U; if not (V := Atsoc(Indicator, PL)) then SetProp(U, (Indicator . Val) . PL) else RPlacD(V, Val); return Val; end; lisp procedure RemProp(U, Indicator); %. Remove value of U with Indicator if not IDP U or not IDP Indicator then NIL else begin scalar V; if (V := get(U, Indicator)) then SetProp(U, DelAtQIP(Indicator, Prop U)); return V; end; lisp procedure RemPropL(L, Indicator); %. RemProp for all IDs in L for each X in L do RemProp(X, Indicator); END; |
Added psl-1983/kernel/putd-getd.red version [f6a032b80f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PUTD-GETD.RED - Standard Lisp function defining functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>PUTD-GETD.RED.3, 13-Jan-83 19:09:47, Edit by PERDUE % Removed obsolete code from PUTD in response to Bobbie Othmer's bug report % <PSL.KERNEL>PUTD-GETD.RED.2, 24-Sep-82 15:01:38, Edit by BENSON % Added CODE-NUMBER-OF-ARGUMENTS % <PSL.INTERP>PUTD-GETD.RED.3, 19-Apr-82 13:10:57, Edit by BENSON % Function in PutD may be an ID % <PSL.INTERP>PUTD-GETD.RED.4, 6-Jan-82 19:18:47, Edit by GRISS % Add NEXPR % DE, DF and DM are defined in EASY-SL.RED % If the function is interpreted, the lambda form will be found by % GET(ID, '!*LambdaLink). % If the type of a function is other than EXPR (i.e. FEXPR or MACRO or NEXPR), % this will be indicated by GET(ID, 'TYPE) = 'FEXPR or 'MACRO or 'NEXPR % PutD makes use of the fact that FLUID and GLOBAL declarations use the % property list indicator TYPE % Non-Standard Lisp functions used: % function cell primitives FUnBoundP, etc. found in FUNCTION-PRIMITVES.RED % CompD -- in COMPILER.RED % ErrorPrintF, VerboseTypeError, BldMsg % Error numbers: % 1100 - ill-formed function expression % 1300 - unknown function type % +5 in GetD lisp procedure GetD U; %. Lookup function definition of U IDP U and not FUnBoundP U and ((get(U, 'TYPE) or 'EXPR) . (if FLambdaLinkP U then get(U, '!*LambdaLink) else GetFCodePointer U)); lisp procedure RemD U; %. Remove function definition of U begin scalar OldGetD; if (OldGetD := GetD U) then << MakeFUnBound U; RemProp(U, 'TYPE); RemProp(U, '!*LambdaLink) >>; return OldGetD; end; fluid '(!*RedefMSG % controls printing of redefined !*UserMode); % controls query for redefinition LoadTime << !*UserMode := NIL; % start in system mode !*RedefMSG := T >>; % message in PutD fluid '(!*Comp % controls automatic compilation PromptString!*); lisp procedure PutD(FnName, FnType, FnExp); %. Install function definition % % this differs from the SL Report in 2 ways: % - function names flagged LOSE are not defined. % - " " which are already fluid or global are defined anyway, % with a warning. % if not IDP FnName then NonIDError(FnName, 'PutD) else if not (FnType memq '(EXPR FEXPR MACRO NEXPR)) then ContError(1305, "%r is not a legal function type", FnType, PutD(FnName, FnType, FnExp)) else if FlagP(FnName, 'LOSE) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", FnName); NIL >> else begin scalar VarType, PrintRedefinedMessage, OldIN, PromptString!*, QueryResponse; if not FUnBoundP FnName then << if !*RedefMSG then PrintRedefinedMessage := T; if !*UserMode and not FlagP(FnName, 'USER) then if not YesP BldMsg( "Do you really want to redefine the system function %r?", FnName) then return NIL else Flag1(FnName, 'USER) >>; if CodeP FnExp then << MakeFCode(FnName, FnExp); RemProp(FnName, '!*LambdaLink) >> else if IDP FnExp and not FUnBoundP FnExp then return PutD(FnName, FnType, cdr GetD FnExp) else if !*Comp then return CompD(FnName, FnType, FnExp) else if EqCar(FnExp, 'LAMBDA) then << put(FnName, '!*LambdaLink, FnExp); MakeFLambdaLink FnName >> else return ContError(1105, "Ill-formed function expression in PutD", PutD(FnName, FnType, FnExp)); if FnType neq 'EXPR then put(FnName, 'TYPE, FnType) else RemProp(FnName, 'TYPE); if !*UserMode then Flag1(FnName, 'USER) else RemFlag1(FnName, 'USER); if PrintRedefinedMessage then ErrorPrintF("*** Function %r has been redefined", FnName); return FnName; end; on Syslisp; syslsp procedure code!-number!-of!-arguments cp; begin scalar n; return if codep cp then << n := !%code!-number!-of!-arguments CodeInf cp; if n >= 0 and n <= MaxArgs then n >>; end; END; |
Added psl-1983/kernel/randm.build version [2886244a8f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % % RANDM.BUILD - Miscellaneous interpreter files % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "known-to-comp-sl.red"$ % SL functions performed inline in code PathIn "others-sl.red"$ % DIGIT, LITER and LENGTH PathIn "equal.red"$ % equality predicates PathIn "carcdr.red"$ % CDDDDR, etc. PathIn "easy-sl.red"$ % highly portable SL function defns PathIn "easy-non-sl.red"$ % simple, ubiquitous SL extensions PathIn "sets.red"$ % Set manipulation functions |
Added psl-1983/kernel/rds-wrs.red version [840f5c074c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RDS-WRS.RED - Switch the current input or output channel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % global '(SpecialRDSAction!* % possibly apply to old and new channel SpecialWRSAction!* % ditto IN!* % Current input channel OUT!*); % Current output channel fluid '(StdIN!* % Standard input - may be rebound StdOUT!*); % Standard output - may be rebound on SysLisp; syslsp procedure RDS Channel; %. Switch input channels, return old begin scalar OldIN, ReadFn; if LispVar SpecialRDSAction!* then Apply(LispVar SpecialRDSAction!*, list(LispVar IN!*, Channel)); OldIN := LispVar IN!*; if null Channel then Channel := LispVar StdIN!*; ReadFn := ReadFunction[IntInf Channel]; if ReadFn eq 'ChannelNotOpen or ReadFn eq 'WriteOnlyChannel then return ChannelError(Channel, "Channel not open for input in RDS"); LispVar IN!* := Channel; return OldIN; end; syslsp procedure WRS Channel; %. Switch output channels, return old begin scalar OldOUT, WriteFn; if LispVar SpecialWRSAction!* then Apply(LispVar SpecialWRSAction!*, list(LispVar OUT!*, Channel)); OldOUT := LispVar OUT!*; if null Channel then Channel := LispVar StdOUT!*; WriteFn := WriteFunction[IntInf Channel]; if WriteFn eq 'ChannelNotOpen or WriteFn eq 'ReadOnlyChannel then return ChannelError(Channel, "Channel not open for output in WRS"); LispVar OUT!* := Channel; return OldOUT; end; off SysLisp; END; |
Added psl-1983/kernel/read.red version [c68baf406e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % READ.RED - S-expression parser % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>READ.RED.6, 20-Oct-82 11:07:28, Edit by BENSON % Extra right paren in file only prints warning, not error % <PSL.KERNEL>READ.RED.5, 6-Oct-82 11:37:33, Edit by BENSON % Took away CATCH in READ, EOF error binds *InsideStructureRead to NIL % <PSL.KERNEL>READ.RED.2, 20-Sep-82 11:24:32, Edit by BENSON % Right parens at top level cause an error in a file % <PSL.INTERP>READ.RED.6, 2-Sep-82 14:07:37, Edit by BENSON % Right parens are ignored at the top level fluid '(CurrentReadMacroIndicator!* % Get to find read macro function CurrentScanTable!* % vector of character types !*InsideStructureRead); % indicates within compound read global '(TokType!* % Set by token scanner, type of token LispScanTable!* % CurrentScanTable!* when READing IN!* % Current input channel !$EOF!$); % has value returned when EOF is read CurrentReadMacroIndicator!* := 'LispReadMacro; CompileTime flag('(DotContextError), 'InternalFunction); lisp procedure ChannelReadTokenWithHooks Channel; % Scan token w/read macros % % This is ReadToken with hooks for read macros % begin scalar Tkn, Fn; Tkn := ChannelReadToken Channel; if TokType!* eq 3 and (Fn := get(Tkn, CurrentReadMacroIndicator!*)) then return IDApply2(Channel, Tkn, Fn); return Tkn; end; lisp procedure ChannelRead Channel; %. Parse S-expression from channel begin scalar CurrentScanTable!*, CurrentReadMacroIndicator!*; CurrentScanTable!* := LispScanTable!*; CurrentReadMacroIndicator!* := 'LispReadMacro; return ChannelReadTokenWithHooks Channel; end; lisp procedure Read(); %. Parse S-expr from current input << MakeInputAvailable(); ChannelRead IN!* >>; lisp procedure ChannelReadEof(Channel, Ef); % Handle end-of-file in Read if !*InsideStructureRead then return begin scalar !*InsideStructureRead; return StdError BldMsg("Unexpected EOF while reading on channel %r", Channel); end else !$EOF!$; lisp procedure ChannelReadQuotedExpression(Channel, Qt); % read macro ' MkQuote ChannelReadTokenWithHooks Channel; lisp procedure ChannelReadListOrDottedPair(Channel, Pa); % read macro ( % % Read list or dotted pair. Collect items until closing right paren. % Check for dot context errors. % begin scalar Elem, StartPointer, EndPointer, !*InsideStructureRead; !*InsideStructureRead := T; Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 then if Elem eq '!. then return DotContextError() else if Elem eq '!) then return NIL; StartPointer := EndPointer := list Elem; LoopBegin: Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 then if Elem eq '!) then return StartPointer else if Elem eq '!. then << Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 and (Elem eq '!) or Elem eq '!.) then return DotContextError() else << RplacD(EndPointer, Elem); Elem := ChannelReadTokenWithHooks Channel; if TokType!* eq 3 and Elem eq '!) then return StartPointer else return DotContextError() >> >>; % If we had splice macros, I think they would be checked here RplacD(EndPointer, list Elem); EndPointer := cdr EndPointer; goto LoopBegin; end; lisp procedure ChannelReadRightParen(Channel, Tok); % Ignore right parens at the top if !*InsideStructureRead then Tok else << if not (Channel eq StdIN!*) then % if not reading from the terminal ErrorPrintF "*** Unmatched right parenthesis"; ChannelReadTokenWithHooks Channel >>; lisp procedure DotContextError(); % Parsing error IOError "Dot context error"; % List2Vector is found in TYPE-CONVERSIONS.RED lisp procedure ChannelReadVector Channel; % read macro [ begin scalar Elem, StartPointer, EndPointer, !*InsideStructureRead; !*InsideStructureRead := T; StartPointer := EndPointer := (NIL . NIL); while << Elem := ChannelReadTokenWithHooks Channel; TokType!* neq 3 or Elem neq '!] >> do << RplacD(EndPointer, list Elem); EndPointer := cdr EndPointer >>; return List2Vector cdr StartPointer; end; StartupTime << put('!', 'LispReadMacro, function ChannelReadQuotedExpression); put('!( , 'LispReadMacro, function ChannelReadListOrDottedPair); put('!) , 'LispReadMacro, function ChannelReadRightParen); put('![, 'LispReadMacro, function ChannelReadVector); put(MkID char EOF, 'LispReadMacro, function ChannelReadEOF); >>; END; |
Added psl-1983/kernel/readme version [1e6159affb].
> > | 1 2 | This directory contains only sources for the Portable Standard LISP interpreter. |
Added psl-1983/kernel/sequence.red version [57a28d4cb0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SEQUENCE.RED - Useful functions on strings, vectors and lists % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>SEQUENCE.RED.2, 25-Jan-83 16:11:28, Edit by PERDUE % Removed Make-String, leaving MkString. % STRINGS pkg defines Make-String (differently and Common LISP compatibly) % <PSL.INTERP>SEQUENCE.RED.2, 27-Feb-82 00:46:03, Edit by BENSON % Started adding more vector types % <PSL.INTERP>STRING-OPS.RED.11, 6-Jan-82 20:41:16, Edit by BENSON % Changed String and Vector into Nexprs on SysLisp; % Indexing operations syslsp procedure Indx(R1, R2); %. Element of sequence begin scalar Tmp1, Tmp2; if not PosIntP R2 then return IndexError(R2, 'Indx); % Subscript Tmp1 := Inf R1; Tmp2 := Tag R1; return case Tmp2 of Str, Bytes: if R2 > StrLen Tmp1 then RangeError(R1, R2, 'Indx) else StrByt(Tmp1, R2); Vect: if R2 > VecLen Tmp1 then RangeError(R1, R2, 'Indx) else VecItm(Tmp1, R2); Wrds: if R2 > WrdLen Tmp1 then RangeError(R1, R2, 'Indx) else WrdItm(Tmp1, R2); HalfWords: if R2 > HalfWordLen Tmp1 then RangeError(R1, R2, 'Indx) else HalfWordItm(Tmp1, R2); Pair: << Tmp2 := R2; while Tmp2 > 0 do << R1 := cdr R1; if atom R1 then RangeError(R1, R2, 'Indx); Tmp2 := Tmp2 - 1 >>; car R1 >>; default: NonSequenceError(R1, 'Indx); end; end; syslsp procedure SetIndx(R1, R2, R3); %. Store at index of sequence begin scalar Tmp1, Tmp2; if not PosIntP R2 then return IndexError(R2, 'SetIndx); % Subscript Tmp1 := Inf R1; Tmp2 := Tag R1; return case Tmp2 of Str, Bytes: if R2 > StrLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << StrByt(Tmp1, R2) := R3; R3 >>; Vect: if R2 > VecLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << VecItm(Tmp1, R2) := R3; R3 >>; Wrds: if R2 > WrdLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << WrdItm(Tmp1, R2) := R3; R3 >>; HalfWords: if R2 > HalfWordLen Tmp1 then RangeError(R1, R2, 'SetIndx) else << HalfWordItm(Tmp1, R2) := R3; R3 >>; Pair: << Tmp2 := R2; while Tmp2 > 0 do << R1 := cdr R1; if atom R1 then RangeError(R1, R2, 'SetIndx); Tmp2 := Tmp2 - 1 >>; Rplaca(R1, R3); R3 >>; default: NonSequenceError(R1, 'SetIndx); end; end; % String and vector sub-part operations. syslsp procedure Sub(R1, R2, R3); %. Obsolete subsequence function SubSeq(R1, R2, R2 + R3 + 1); syslsp procedure SubSeq(R1, R2, R3); % R2 is lower bound, R3 upper begin scalar NewSize, OldSize, NewItem; if not PosIntP R2 then return IndexError(R2, 'SubSeq); if not PosIntP R3 then return IndexError(R3, 'SubSeq); NewSize := R3 - R2 - 1; if NewSize < -1 then return RangeError(R1, R3, 'SubSeq); return case Tag R1 of Str, Bytes: << OldSize := StrLen StrInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtSTR NewSize; R3 := StrInf R1; for I := 0 step 1 until NewSize do StrByt(NewItem, I) := StrByt(R3, R2 + I); case Tag R1 of Str: MkSTR NewItem; Bytes: MkBYTES NewItem; end >> >>; Vect: << OldSize := VecLen VecInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtVECT NewSize; R3 := VecInf R1; for I := 0 step 1 until NewSize do VecItm(NewItem, I) := VecItm(R3, R2 + I); MkVEC NewItem >> >>; Wrds: << OldSize := WrdLen WrdInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtWRDS NewSize; R3 := WrdInf R1; for I := 0 step 1 until NewSize do WrdItm(NewItem, I) := WrdItm(R3, R2 + I); MkWRDS NewItem >> >>; HalfWords: << OldSize := HalfWordLen HalfWordInf R1; if R3 - 1 > OldSize then RangeError(R1, R3, 'SubSeq) else << NewItem := GtHalfWords NewSize; R3 := HalfWordInf R1; for I := 0 step 1 until NewSize do HalfWordItm(NewItem, I) := HalfWordItm(R3, R2 + I); MkHalfWords NewItem >> >>; Pair: << for I := 1 step 1 until R2 do if PairP R1 then R1 := rest R1 else RangeError(R1, R2, 'SubSeq); NewItem := NIL . NIL; for I := 0 step 1 until NewSize do if PairP R1 then << TConc(NewItem, first R1); R1 := rest R1 >> else RangeError(R1, R3, 'SubSeq); car NewItem >>; default: NonSequenceError(R1, 'SubSeq); end; end; syslsp procedure SetSub(R1, R2, R3, R4); %. Obsolete subsequence function SetSubSeq(R1, R2, R2 + R3 + 1, R4); syslsp procedure SetSubSeq(R1, R2, R3, R4); % R2 is lower bound, R3 upper begin scalar NewSize, OldSize, SubSize, NewItem; if not PosIntP R2 then return IndexError(R2, 'SetSubSeq); if not PosIntP R3 then return IndexError(R3, 'SetSubSeq); NewSize := R3 - R2 - 1; if NewSize < -1 then return RangeError(R1, R3, 'SetSubSeq); case Tag R1 of Str, Bytes: << if not StringP R4 and not BytesP R4 then return NonStringError(R4, 'SetSubSeq); OldSize := StrLen StrInf R1; NewItem := StrInf R4; SubSize := StrLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := StrInf R1; for I := 0 step 1 until NewSize do StrByt(R3, R2 + I) := StrByt(NewItem, I) >> >>; Vect: << if not VectorP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := VecLen VecInf R1; NewItem := VecInf R4; SubSize := VecLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := VecInf R1; for I := 0 step 1 until NewSize do VecItm(R3, R2 + I) := VecItm(NewItem, I) >> >>; Wrds: << if not WrdsP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := WrdLen WrdInf R1; NewItem := WrdInf R4; SubSize := WrdLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := WrdInf R1; for I := 0 step 1 until NewSize do WrdItm(R3, R2 + I) := WrdItm(NewItem, I) >> >>; HalfWords: << if not HalfWordsP R4 then return NonVectorError(R4, 'SetSubSeq); OldSize := HalfWordLen HalfWordInf R1; NewItem := HalfWordInf R4; SubSize := HalfWordLen NewItem; if R3 - 1 > OldSize then RangeError(R1, R3, 'SetSubSeq) else if not (NewSize eq SubSize) then RangeError(R4, NewSize, 'SetSubSeq) else << R3 := HalfWordInf R1; for I := 0 step 1 until NewSize do HalfWordItm(R3, R2 + I) := HalfWordItm(NewItem, I) >> >>; Pair: << if not PairP R4 and not null R4 then return NonPairError(R4, 'SetSubSeq); for I := 1 step 1 until R2 do if PairP R1 then R1 := rest R1 else RangeError(R1, R2, 'SetSubSeq); NewItem := R4; for I := 0 step 1 until NewSize do if PairP R1 and PairP NewItem then << RPlaca(R1, first NewItem); R1 := rest R1; NewItem := rest NewItem >> else RangeError(R1, R3, 'SetSubSeq) >>; default: NonSequenceError(R1, 'SetSubSeq); end; return R4; end; syslsp procedure Concat(R1, R2); %. Concatenate 2 sequences begin scalar I1, I2, Tmp1, Tmp2, Tmp3; return case Tag R1 of STR, BYTES: << if not (StringP R2 or BytesP R2) then return NonStringError(R2, 'Concat); Tmp1 := StrInf R1; Tmp2 := StrInf R2; I1 := StrLen Tmp1; I2 := StrLen Tmp2; Tmp3 := GtSTR(I1 + I2 + 1); % R1 and R2 can move Tmp1 := StrInf R1; Tmp2 := StrInf R2; for I := 0 step 1 until I1 do StrByt(Tmp3, I) := StrByt(Tmp1, I); for I := 0 step 1 until I2 do StrByt(Tmp3, I1 + I + 1) := StrByt(Tmp2, I); if StringP R1 then MkSTR Tmp3 else MkBYTES Tmp3 >>; VECT: << if not VectorP R2 then return NonVectorError(R2, 'Concat); Tmp1 := VecInf R1; Tmp2 := VecInf R2; I1 := VecLen Tmp1; I2 := VecLen Tmp2; Tmp3 := GtVECT(I1 + I2 + 1); % R1 and R2 can move Tmp1 := VecInf R1; Tmp2 := VecInf R2; for I := 0 step 1 until I1 do VecItm(Tmp3, I) := VecItm(Tmp1, I); for I := 0 step 1 until I2 do VecItm(Tmp3, I1 + I + 1) := VecItm(Tmp2, I); MkVEC Tmp3 >>; WRDS: << if not WrdsP R2 then return NonVectorError(R2, 'Concat); Tmp1 := WrdInf R1; Tmp2 := WrdInf R2; I1 := WrdLen Tmp1; I2 := WrdLen Tmp2; Tmp3 := GtWrds(I1 + I2 + 1); % R1 and R2 can move Tmp1 := WrdInf R1; Tmp2 := WrdInf R2; for I := 0 step 1 until I1 do WrdItm(Tmp3, I) := WrdItm(Tmp1, I); for I := 0 step 1 until I2 do WrdItm(Tmp3, I1 + I + 1) := WrdItm(Tmp2, I); MkWRDS Tmp3 >>; HALFWORDS: << if not HalfWordsP R2 then return NonVectorError(R2, 'Concat); Tmp1 := HalfWordInf R1; Tmp2 := HalfWordInf R2; I1 := HalfWordLen Tmp1; I2 := HalfWordLen Tmp2; Tmp3 := GtHalfWords(I1 + I2 + 1); % R1 and R2 can move Tmp1 := HalfWordInf R1; Tmp2 := HalfWordInf R2; for I := 0 step 1 until I1 do HalfWordItm(Tmp3, I) := HalfWordItm(Tmp1, I); for I := 0 step 1 until I2 do HalfWordItm(Tmp3, I1 + I + 1) := HalfWordItm(Tmp2, I); MkHalfWords Tmp3 >>; PAIR, ID: if null R1 or PairP R1 then Append(R1, R2); default: NonSequenceError(R1, 'Concat); end; end; syslsp procedure Size S; %. Upper bound of sequence case Tag S of STR, BYTES, WRDS, VECT, HALFWORDS: GetLen Inf S; ID: -1; PAIR: begin scalar I; I := -1; while PairP S do << I := I + 1; S := cdr S >>; return I; end; default: NonSequenceError(S, 'Size); end; syslsp procedure MkString(L, C); %. Make str with upb L, all chars C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'MkString); if L1 < -1 then return NonPositiveIntegerError(L, 'MkString); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkSTR S; end; syslsp procedure Make!-Bytes(L, C); %. Make byte vector with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Bytes); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Bytes); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkBytes S; end; syslsp procedure Make!-HalfWords(L, C); %. Make h vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-HalfWords); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-HalfWords); S := GtHalfWords L1; for I := 0 step 1 until L1 do HalfWordItm(S, I) := C; return MkHalfWords S; end; syslsp procedure Make!-Words(L, C); %. Make w vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Words); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Words); S := GtWrds L1; for I := 0 step 1 until L1 do WrdItm(S, I) := C; return MkWrds S; end; syslsp procedure Make!-Vector(L, C); %. Make vect with upb L, all items C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'Make!-Vector); if L1 < -1 then return NonPositiveIntegerError(L, 'Make!-Vector); S := GtVECT L1; for I := 0 step 1 until L1 do VecItm(S, I) := C; return MkVEC S; end; off SysLisp; % Maybe we want to support efficient compilation of these, as with LIST, % by functions String2, String3, Vector2, Vector3, etc. nexpr procedure String U; %. Analogous to LIST, string constructor List2String U; nexpr procedure Vector U; %. Analogous to LIST, vector constructor List2Vector U; END; |
Added psl-1983/kernel/sets.red version [d2e2ad5749].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SETS.RED - Functions acting on lists as sets % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 December 1981 % Copyright (c) 1981 University of Utah % lisp procedure List2Set L; %. Remove redundant elements from L if not PairP L then NIL else if car L member cdr L then List2Set cdr L else car L . List2Set cdr L; lisp procedure List2SetQ L; %. EQ version of List2Set if not PairP L then NIL % Don't confuse it with SetQ! else if car L memq cdr L then List2Set cdr L else car L . List2Set cdr L; lisp procedure Adjoin(Element, ASet); %. Add Element to Set if Element member ASet then ASet else Element . ASet; lisp procedure AdjoinQ(Element, ASet); %. EQ version of Adjoin if Element memq ASet then ASet else Element . ASet; lisp procedure Union(X, Y); %. Set union if not PairP X then Y else Union(cdr X, if car X Member Y then Y else car X . Y); lisp procedure UnionQ(X, Y); %. EQ version of UNION if not PairP X then Y else UnionQ(cdr X, if car X memq Y then Y else car X . Y); lisp procedure XN(U, V); %. Set intersection if not PairP U then NIL else if car U Member V then car U . XN(cdr U, Delete(car U, V)) else XN(cdr U, V); lisp procedure XNQ(U, V); %. EQ version of XN if null PairP U then NIL else if car U memq V then car U . XN(cdr U, DelQ(car U, V)) else XN(cdr U, V); LoadTime << PutD('Intersection, 'EXPR, cdr GetD 'XN); % for those who like to type PutD('IntersectionQ, 'EXPR, cdr GetD 'XNQ) >>; END; |
Added psl-1983/kernel/string-gensym.red version [cf2affaf91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % STRING-GENSYM.RED - Complement to GenSym, makes a string instead of ID % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 14 January 1982 % Copyright (c) 1982 University of Utah % % Edit by Cris Perdue, 9 Feb 1983 1620-PST % Modified to avoid using the CHAR macro in a top level form fluid '(StringGenSym!*); StringGenSym!* := copystring("L0000"); % Copy to force into heap /csp CompileTime flag('(StringGenSym1), 'InternalFunction); lisp procedure StringGenSym(); %. Generate unique string StringGenSym1 4; lisp procedure StringGenSym1 N; %. Auxiliary function for StringGenSym begin scalar Ch; return if N > 0 then if (Ch := Indx(StringGenSym!*, N)) < char !9 then << SetIndx(StringGenSym!*, N, Ch + 1); TotalCopy StringGenSym!* >> else << SetIndx(StringGenSym!*, N, char !0); StringGenSym1(N - 1) >> else % Increment starting letter << SetIndx(StringGenSym!*, 0, Indx(StringGenSym!*, 0) + 1); StringGenSym() >>; end; END; |
Added psl-1983/kernel/symbl.build version [b480556330].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | % % SYMBL.BUILD - Files dealing with symbols in the interpreter % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "binding.red"$ % binding from the interpreter PathIn "fast-binder.red"$ % for binding in compiled code, in LAP PathIn "symbol-values.red"$ % SET, and support for Eval PathIn "oblist.red"$ % Intern, RemOb and GenSym |
Added psl-1983/kernel/symbol-values.red version [b6fd3cd69e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYMBOL-VALUES.RED - ValueCell, UnboundP, MakeUnbound and Set % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 Eric Benson % on SysLisp; syslsp procedure UnboundP U; %. Does U not have a value? if IDP U then if Tag SymVal IDInf U eq Unbound then T else NIL else NonIDError(U, 'UnboundP); syslsp procedure MakeUnbound U; %. Make U an unbound ID if IDP U then SymVal IDInf U := MkItem(Unbound, IDInf U) else NonIDError(U, 'MakeUnbound); syslsp procedure ValueCell U; %. Safe access to SymVal entry begin scalar V; % This guy is called from Eval return if IDP U then << V := SymVal IDInf U; if Tag V eq Unbound then ContinuableError('99, BldMsg('"%r is an unbound ID", U), U) else V >> else NonIDError(U, 'ValueCell); end; % This version of SET differs from the Standard Lisp report in that Exp is % not declared fluid, in order to maintain compatibility between compiled % and interpreted code. syslsp procedure Set(Exp, Val); %. Assign Val to ID Exp if IDP Exp then if not (null Exp or Exp eq 'T) then << SymVal IDInf Exp := Val; Val >> else StdError '"T and NIL cannot be SET" else NonIDError(Exp, 'Set); off SysLisp; END; |
Added psl-1983/kernel/sysio.build version [36b02e6690].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % % SYSIO.BUILD - Files for system-dependent input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "system-io.red"$ % system dependent IO functions PathIn "scan-table.red"$ % change scan table for system |
Added psl-1983/kernel/tloop.build version [6b7b2f001d].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % TLOOP.BUILD - Files with top loop and related functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "break.red"$ % break package (uses top loop) PathIn "top-loop.red"$ % generalized top loop function PathIn "dskin.red"$ % Read/Eval/Print from files |
Added psl-1983/kernel/token-scanner.red version [5384bf4bc9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TOKEN-SCANNER.RED - Table-driven token scanner % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 29 Jan 1983 1338-PST % Occurrences of "dipthong" changed to "diphthong" % <PSL.KERNEL>TOKEN-SCANNER.RED.2, 16-Dec-82 14:55:55, Edit by BENSON % MakeBufIntoFloat uses floating point arithmetic on each digit % <PSL.INTERP>TOKEN-SCANNER.RED.6, 15-Sep-82 10:49:54, Edit by BENSON % Can now scan 1+ and 1- % <PSL.INTERP>TOKEN-SCANNER.RED.12, 10-Jan-82 21:53:28, Edit by BENSON % Fixed bug in floating point parsing % <PSL.INTERP>TOKEN-SCANNER.RED.9, 8-Jan-82 07:06:23, Edit by GRISS % MakeBufIntoLispInteger becomes procedure for BigNums % <PSL.INTERP>TOKEN-SCANNER.RED.7, 28-Dec-81 22:09:14, Edit by BENSON % Made dipthong indicator last element of scan table fluid '(CurrentScanTable!* !*Raise !*Compressing !*EOLInStringOK); LoadTime << !*Raise := T; !*Compressing := NIL; !*EOLInStringOK := NIL; >>; CompileTime flag('(ReadInBuf MakeBufIntoID MakeBufIntoString MakeBufIntoLispInteger MakeBufIntoSysNumber MakeBufIntoFloat MakeStringIntoSysInteger MakeStringIntoBitString ScannerError SysPowerOf2P ScanPossibleDiphthong), 'InternalFunction); on SysLisp; % DIGITS are 0..9 internal WConst LETTER = 10, DELIMITER = 11, COMMENTCHAR = 12, DIPHTHONGSTART = 13, IDESCAPECHAR = 14, STRINGQUOTE = 15, PACKAGEINDICATOR = 16, IGNORE = 17, MINUSSIGN = 18, PLUSSIGN = 19, DECIMALPOINT = 20, IDSURROUND = 21; internal WVar TokCh, TokChannel, ChTokenType, CurrentChar, ChangedPackages, TokRadix, TokSign, TokFloatFractionLength, TokFloatExponentSign, TokFloatExponent; CompileTime << syslsp smacro procedure TokenTypeOfChar Ch; IntInf VecItm(VecInf LispVar CurrentScanTable!*, Ch); syslsp smacro procedure CurrentDiphthongIndicator(); VecItm(VecInf LispVar CurrentScanTable!*, 128); syslsp smacro procedure ResetBuf(); CurrentChar := 0; syslsp smacro procedure BackupBuf(); CurrentChar := CurrentChar - 1; >>; syslsp procedure ReadInBuf(); << TokCh := ChannelReadChar TokChannel; StrByt(TokenBuffer, CurrentChar) := TokCh; ChTokenType := TokenTypeOfChar TokCh; if CurrentChar < MaxTokenSize then CurrentChar := CurrentChar + 1 else if CurrentChar = MaxTokenSize then << ErrorPrintF("***** READ Buffer overflow, Truncating"); CurrentChar := MaxTokenSize + 1 >> else CurrentChar := MaxTokenSize + 1 >>; CompileTime << syslsp smacro procedure UnReadLastChar(); ChannelUnReadChar(Channel, TokCh); syslsp smacro procedure LowerCaseChar Ch; Ch >= char !a and Ch <= char !z; syslsp smacro procedure RaiseChar Ch; (Ch - char !a) + char A; syslsp smacro procedure RaiseLastChar(); if LowerCaseChar TokCh then StrByt(TokenBuffer, CurrentChar - 1) := RaiseChar TokCh; >>; syslsp procedure MakeBufIntoID(); << LispVar TokType!* := '0; if CurrentChar eq 1 then MkID StrByt(TokenBuffer, 0) else << StrByt(TokenBuffer, CurrentChar) := char NULL; TokenBuffer[0] := CurrentChar - 1; if LispVar !*Compressing then NewID CopyString TokenBuffer else Intern MkSTR TokenBuffer >> >>; syslsp procedure MakeBufIntoString(); << LispVar TokType!* := '1; StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; CopyString TokenBuffer >>; syslsp procedure MakeBufIntoSysNumber(Radix, Sign); << StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; MakeStringIntoSysInteger(TokenBuffer, Radix, Sign) >>; syslsp procedure MakeBufIntoLispInteger(Radix, Sign); << LispVar TokType!* := '2; StrByt(TokenBuffer, CurrentChar) := 0; TokenBuffer[0] := CurrentChar - 1; MakeStringIntoLispInteger(MkSTR TokenBuffer, Radix, Sign) >>; internal WArray MakeFloatTemp1[1], MakeFloatTemp2[1], FloatTen[1]; % Changed to use floating point arithmetic on the characters, rather % than converting to an integer. This avoids overflow problems. syslsp procedure MakeBufIntoFloat Exponent; begin scalar F, N; !*WFloat(FloatTen, 10); !*WFloat(MakeFloatTemp1, 0); N := CurrentChar - 1; for I := 0 step 1 until N do << !*WFloat(MakeFloatTemp2, DigitToNumber StrByt(TokenBuffer, I)); !*FTimes2(MakeFloatTemp1, MakeFloatTemp1, FloatTen); !*FPlus2(MakeFloatTemp1, MakeFloatTemp1, MakeFloatTemp2) >>; if Exponent > 0 then for I := 1 step 1 until Exponent do !*FTimes2(MakeFloatTemp1, MakeFloatTemp1, FloatTen) else if Exponent < 0 then << Exponent := -Exponent; for I := 1 step 1 until Exponent do !*FQuotient(MakeFloatTemp1, MakeFloatTemp1, FloatTen) >>; LispVar TokType!* := '2; F := GtFLTN(); !*FAssign(FloatBase F, MakeFloatTemp1); return MkFLTN F; end; syslsp procedure ChannelReadToken Channel; %. Token scanner % % This is the basic Lisp token scanner. The value returned is a Lisp % item corresponding to the next token from the input stream. IDs will % be interned. The global Lisp variable TokType!* will be set to % 0 if the token is an ordinary ID, % 1 if the token is a string (delimited by double quotes), % 2 if the token is a number, or % 3 if the token is an unescaped delimiter. % In the last case, the value returned by this function will be the single % character ID corresponding to the delimiter. % begin TokChannel := Channel; ChangedPackages := 0; ResetBuf(); StartScanning: TokCh := ChannelReadChar Channel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType eq IGNORE then goto StartScanning; StrByt(TokenBuffer, CurrentChar) := TokCh; CurrentChar := CurrentChar + 1; case ChTokenType of 0 to 9: % digit << TokSign := 1; goto InsideNumber >>; 10: % Start of ID << if null LispVar !*Raise then goto InsideID else << RaiseLastChar(); goto InsideRaisedID >> >>; 11: % Delimiter, but not beginning of Diphthong << LispVar TokType!* := '3; return MkID TokCh >>; 12: % Start of comment goto InsideComment; 13: % Diphthong start - Lisp function uses P-list of starting char return ScanPossibleDiphthong(TokChannel, MkID TokCh); 14: % ID escape character << if null LispVar !*Raise then goto GotEscape else goto GotEscapeInRaisedID >>; 15: % string quote << BackupBuf(); goto InsideString >>; 16: % Package indicator - at start of token means use global package << ResetBuf(); ChangedPackages := 1; Package 'Global; if null LispVar !*Raise then goto GotPackageMustGetID else goto GotPackageMustGetIDRaised >>; 17: % Ignore - can't ever happen ScannerError("Internal error - consult a wizard"); 18: % Minus sign << TokSign := -1; goto GotSign >>; 19: % Plus sign << TokSign := 1; goto GotSign >>; 20: % decimal point << ResetBuf(); ReadInBuf(); if ChTokenType >= 10 then << UnReadLastChar(); return ScanPossibleDiphthong(TokChannel, '!.) >> else << TokSign := 1; TokFloatFractionLength := 1; goto InsideFloatFraction >> >>; 21: % IDSURROUND, i.e. vertical bars << BackupBuf(); goto InsideIDSurround >>; default: return ScannerError("Unknown token type") end; GotEscape: BackupBuf(); ReadInBuf(); goto InsideID; InsideID: ReadInBuf(); if ChTokenType <= 10 or ChTokenType eq PLUSSIGN or ChTokenType eq MINUSSIGN then goto InsideID else if ChTokenType eq IDESCAPECHAR then goto GotEscape else if ChTokenType eq PACKAGEINDICATOR then << BackupBuf(); ChangedPackages := 1; Package MakeBufIntoID(); ResetBuf(); goto GotPackageMustGetID >> else << UnReadLastChar(); BackupBuf(); if ChangedPackages neq 0 then Package LispVar CurrentPackage!*; return MakeBufIntoID() >>; GotPackageMustGetID: ReadInBuf(); if ChTokenType eq LETTER then goto InsideID else if ChTokenType eq IDESCAPECHAR then goto GotEscape else ScannerError("Illegal to follow package indicator with non ID"); GotEscapeInRaisedID: BackupBuf(); ReadInBuf(); goto InsideRaisedID; InsideRaisedID: ReadInBuf(); if ChTokenType < 10 or ChTokenType eq PLUSSIGN or ChTokenType eq MINUSSIGN then goto InsideRaisedID else if ChTokenType eq 10 then << RaiseLastChar(); goto InsideRaisedID >> else if ChTokenType eq IDESCAPECHAR then goto GotEscapeInRaisedID else if ChTokenType eq PACKAGEINDICATOR then << BackupBuf(); ChangedPackages := 1; Package MakeBufIntoID(); ResetBuf(); goto GotPackageMustGetIDRaised >> else << UnReadLastChar(); BackupBuf(); if ChangedPackages neq 0 then Package LispVar CurrentPackage!*; return MakeBufIntoID() >>; GotPackageMustGetIDRaised: ReadInBuf(); if ChTokenType eq LETTER then << RaiseLastChar(); goto InsideRaisedID >> else if ChTokenType eq IDESCAPECHAR then goto GotEscapeInRaisedID else ScannerError("Illegal to follow package indicator with non ID"); InsideString: ReadInBuf(); if ChTokenType eq STRINGQUOTE then << BackupBuf(); ReadInBuf(); if ChTokenType eq STRINGQUOTE then goto InsideString else << UnReadLastChar(); BackupBuf(); return MakeBufIntoString() >> >> else if TokCh eq char EOL and not LispVar !*EOLInStringOK then ErrorPrintF("*** String continued over end-of-line") else if TokCh eq char EOF then ScannerError("EOF encountered inside a string"); goto InsideString; InsideIDSurround: ReadInBuf(); if ChTokenType eq IDSURROUND then << BackupBuf(); return MakeBufIntoID() >> else if ChTokenType eq IDESCAPECHAR then << BackupBuf(); ReadInBuf() >> else if TokCh eq char EOF then ScannerError("EOF encountered inside an ID"); goto InsideIDSurround; GotSign: ResetBuf(); ReadInBuf(); if TokCh eq char !. then << PutStrByt(TokenBuffer, 0, char !0); CurrentChar := 2; goto InsideFloat >> else if ChTokenType eq LETTER % patch to be able to read 1+ and 1- or ChTokenType eq MINUSSIGN or ChTokenType eq PLUSSIGN then << ResetBuf(); StrByt(TokenBuffer, 0) := if TokSign < 0 then char !- else char !+; StrByt(TokenBuffer, 1) := TokCh; CurrentChar := 2; if LispVar !*Raise then << RaiseLastChar(); goto InsideRaisedID >> else goto InsideID >> else if ChTokenType eq IDESCAPECHAR then << ResetBuf(); StrByt(TokenBuffer, 0) := if TokSign < 0 then char !- else char !+; CurrentChar := 1; if LispVar !*Raise then goto GotEscapeInRaisedID else goto GotEscape >> else if ChTokenType > 9 then << UnReadLastChar(); % Allow + or - to start a Diphthong return ScanPossibleDiphthong(Channel, MkID(if TokSign < 0 then char !- else char !+)) >> else goto InsideNumber; InsideNumber: ReadInBuf(); if ChTokenType < 10 then goto InsideNumber; if TokCh eq char !# then << BackupBuf(); TokRadix := MakeBufIntoSysNumber(10, 1); ResetBuf(); if TokRadix < 2 or TokRadix > 36 then return ScannerError("Radix out of range"); if TokRadix <= 10 then goto InsideIntegerRadixUnder10 else goto InsideIntegerRadixOver10 >> else if TokCh eq char !. then goto InsideFloat else if TokCh eq char B or TokCh eq char !b then << BackupBuf(); return MakeBufIntoLispInteger(8, TokSign) >> else if TokCh eq char E or TokCh eq char !e then << TokFloatFractionLength := 0; goto InsideFloatExponent >> else if ChTokenType eq LETTER % patch to be able to read 1+ and 1- or ChTokenType eq MINUSSIGN or ChTokenType eq PLUSSIGN then if LispVar !*Raise then << RaiseLastChar(); goto InsideRaisedID >> else goto InsideID else if ChTokenType eq IDESCAPECHAR then if LispVar !*Raise then goto GotEscapeInRaisedID else goto GotEscape else << UnReadLastChar(); BackupBuf(); return MakeBufIntoLispInteger(10, TokSign) >>; InsideIntegerRadixUnder10: ReadInBuf(); if ChTokenType < TokRadix then goto InsideIntegerRadixUnder10; if ChTokenType < 10 then return ScannerError("Digit out of range"); NumReturn: UnReadLastChar(); BackupBuf(); return MakeBufIntoLispInteger(TokRadix, TokSign); InsideIntegerRadixOver10: ReadInBuf(); if ChTokenType < 10 then goto InsideIntegerRadixOver10; if ChTokenType > 10 then goto NumReturn; if LowerCaseChar TokCh then << TokCh := RaiseChar TokCh; StrByt(TokenBuffer, CurrentChar - 1) := TokCh >>; if TokCh >= char A - 10 + TokRadix then goto NumReturn; goto InsideIntegerRadixOver10; InsideFloat: % got decimal point inside number BackupBuf(); ReadInBuf(); if TokCh eq char E or TokCh eq char !e then << TokFloatFractionLength := 0; goto InsideFloatExponent >>; if ChTokenType >= 10 then % nnn. is floating point number << UnReadLastChar(); BackupBuf(); return MakeBufIntoFloat 0 >>; TokFloatFractionLength := 1; InsideFloatFraction: ReadInBuf(); if ChTokenType < 10 then << if TokFloatFractionLength < 9 then TokFloatFractionLength := TokFloatFractionLength + 1 else BackupBuf(); % don't overflow mantissa goto InsideFloatFraction >>; if TokCh eq char E or TokCh eq char lower e then goto InsideFloatExponent; UnReadLastChar(); BackupBuf(); return MakeBufIntoFloat(-TokFloatFractionLength); InsideFloatExponent: BackupBuf(); TokFloatExponentSign := 1; TokFloatExponent := 0; TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType < 10 then << TokFloatExponent := ChTokenType; goto DigitsInsideExponent >>; if TokCh eq char '!- then TokFloatExponentSign := -1 else if TokCh neq char '!+ then return ScannerError("Missing exponent in float"); TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType >= 10 then return ScannerError("Missing exponent in float"); TokFloatExponent := ChTokenType; DigitsInsideExponent: TokCh := ChannelReadChar TokChannel; ChTokenType := TokenTypeOfChar TokCh; if ChTokenType < 10 then << TokFloatExponent := TokFloatExponent * 10 + ChTokenType; goto DigitsInsideExponent >>; ChannelUnReadChar(Channel, TokCh); return MakeBufIntoFloat(TokFloatExponentSign * TokFloatExponent - TokFloatFractionLength); InsideComment: if (TokCh := ChannelReadChar Channel) eq char EOL then << ResetBuf(); goto StartScanning >> else if TokCh eq char EOF then return LispVar !$EOF!$ else goto InsideComment; end; syslsp procedure RAtom(); %. Read token from current input ChannelReadToken LispVar IN!*; syslsp procedure DigitToNumber D; % % if D is not a digit then it is assumed to be an uppercase letter % if D >= char !0 and D <= char !9 then D - char !0 else D - (char A - 10); syslsp procedure MakeStringIntoLispInteger(S, Radix, Sign); Sys2Int MakeStringIntoSysInteger(S, Radix, Sign); syslsp procedure MakeStringIntoSysInteger(Strng, Radix, Sign); % % Unsafe string to integer conversion. Strng is assumed to contain % only digits and possibly uppercase letters for radices > 10. Since it % uses multiplication, arithmetic overflow may occur. Sign is +1 or -1 % begin scalar Count, Tot, RadixExponent; if RadixExponent := SysPowerOf2P Radix then return MakeStringIntoBitString(Strng, Radix, RadixExponent, Sign); Strng := StrInf Strng; Count := StrLen Strng; Tot := 0; for I := 0 step 1 until Count do Tot := Tot * Radix + DigitToNumber StrByt(Strng, I); return if Sign < 0 then -Tot else Tot; end; syslsp procedure MakeStringIntoBitString(Strng, Radix, RadixExponent, Sign); begin scalar Count, Tot; Strng := StrInf Strng; Count := StrLen Strng; Tot := 0; for I := 0 step 1 until Count do << Tot := LSH(Tot, RadixExponent); Tot := LOR(Tot, DigitToNumber StrByt(Strng, I)) >>; if Sign < 0 then return -Tot; return Tot; end; syslsp procedure SysPowerOf2P Num; case Num of 1: 0; 2: 1; 4: 2; 8: 3; 16: 4; 32: 5; default: NIL end; syslsp procedure ScannerError Message; StdError BldMsg("***** Error in token scanner: %s", Message); syslsp procedure ScanPossibleDiphthong(Channel, StartChar); begin scalar Alst, Target, Ch; LispVar TokType!* := '3; if null (Alst := get(StartChar, CurrentDiphthongIndicator())) then return StartChar; if null (Target := Atsoc(Ch := MkID ChannelReadChar Channel, Alst)) then << ChannelUnReadChar(Channel, IDInf Ch); return StartChar >>; return cdr Target; end; syslsp procedure ReadLine(); << MakeInputAvailable(); ChannelReadLine LispVar IN!* >>; syslsp procedure ChannelReadLine Chn; begin scalar C; TokenBuffer[0] := -1; while (C := ChannelReadChar Chn) neq char EOL and C neq char EOF do << TokenBuffer[0] := TokenBuffer[0] + 1; StrByt(TokenBuffer, TokenBuffer[0]) := C >>; return if TokenBuffer[0] >= 0 then << StrByt(TokenBuffer, TokenBuffer[0] + 1) := char NULL; CopyString MkSTR TokenBuffer >> else '""; end; % Dummy definition of package conversion function syslsp procedure Package U; NIL; % Dummy definition of MakeInputAvailable, redefined by Emode syslsp procedure MakeInputAvailable(); NIL; off SysLisp; END; |
Added psl-1983/kernel/top-loop.red version [82f9ffe52a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TOP-LOOP.RED - Generalized top loop construct % % Author: Eric Benson and M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 October 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>TOP-LOOP.RED.6, 5-Oct-82 11:02:29, Edit by BENSON % Added EvalInitForms, changed SaveSystem to 3 args % <PSL.KERNEL>TOP-LOOP.RED.5, 4-Oct-82 18:09:33, Edit by BENSON % Added GCTime!* % $pi/top-loop.red, Mon Jun 28 10:54:19 1982, Edit by Fish % Conditional output: !*Output, Semic!*, !*NoNil. % <PSL.INTERP>TOP-LOOP.RED.13, 30-Apr-82 14:32:20, Edit by BENSON % Minor change to !*DEFN processing % <PSL.INTERP>TOP-LOOP.RED.5, 29-Apr-82 03:56:06, Edit by GRISS % Initial attempt to add !*DEFN processing %<PSL.INTERP>TOP-LOOP.RED.18 24-Nov-81 15:22:25, Edit by BENSON % Changed Standard!-Lisp to StandardLisp CompileTime flag('(NthEntry DefnPrint DefnPrint1 HistPrint), 'InternalFunction); fluid '(TopLoopRead!* % reading function TopLoopPrint!* % printing function TopLoopEval!* % evaluation function TopLoopName!* % short name to put in prompt TopLoopLevel!* % depth of top loop invocations HistoryCount!* % number of entries read so far HistoryList!* % list of entries read and evaluated PromptString!* % input prompt LispBanner!* % Welcome banner printed in StandardLisp !*EMsgP % whether to print error messages !*BackTrace % whether to print backtrace !*Time % whether to print timing of evaluation GCTime!* % Time spent in garbage collection !*Defn % To "output" rather than process DFPRINT!* % Alternate DEFN print function !*Output % Whether to print output. Semic!* % Input terminator when in Rlisps. !*NoNil % Whether to supress NIL value print. InitForms!* % Forms to be evaluated at startup ); LoadTime << TopLoopLevel!* := -1; HistoryCount!* := 0; LispBanner!* := "Portable Standard LISP"; !*Output := T; % Output ON by default. >>; lisp procedure TopLoop(TopLoopRead!*, %. Generalized top-loop mechanism TopLoopPrint!*, %. TopLoopEval!*, %. TopLoopName!*, %. WelcomeBanner); %. begin scalar PromptString!*, Semic!*, LevelPrompt, ThisGCTime, InputValue, OutputValue, TimeCheck; Semic!* := '!; ; % Output when semicolon terminator for rlisps. (lambda TopLoopLevel!*; begin TimeCheck := 0; ThisGCTime := GCTime!*; LevelPrompt := MkString(TopLoopLevel!*, char '!> ); Prin2T WelcomeBanner; LoopStart: HistoryCount!* := IAdd1 HistoryCount!*; HistoryList!* := (NIL . NIL) . HistoryList!*; PromptString!* := BldMsg("%w %w%w ", HistoryCount!*, TopLoopName!*, LevelPrompt); InputValue := ErrorSet(quote Apply(TopLoopRead!*, NIL), T, !*Backtrace); if InputValue eq '!$ExitTopLoop!$ then goto LoopExit; if not PairP InputValue then goto LoopStart; InputValue := car InputValue; if InputValue eq '!$ExitTopLoop!$ then goto LoopExit; if InputValue eq !$EOF!$ then goto LoopExit; Rplaca(car HistoryList!*, InputValue); if !*Time then << TimeCheck := Time(); ThisGCTime := GCTime!* >>; if !*Defn then OutputValue := DefnPrint InputValue else OutputValue := ErrorSet(list('Apply, MkQuote TopLoopEval!*, MkQuote list InputValue), T, !*Backtrace); if not PairP OutputValue then goto LoopStart; OutputValue := car OutputValue; if !*Time then << TimeCheck := Time() - TimeCheck; ThisGCTime := GCTime!* - ThisGCTime >>; Rplacd(car HistoryList!*, OutputValue); if !*Output and Semic!* eq '!; and not (!*NoNil and OutputValue eq NIL) then ErrorSet(list('Apply, MkQuote TopLoopPrint!*, MkQuote list OutputValue), T, !*Backtrace); if !*Time then if ThisGCTime = 0 then PrintF("Cpu time: %w ms%n", TimeCheck) else PrintF("Cpu time: %w ms, GC time: %w ms%n", TimeCheck - ThisGCTime, ThisGCTime); goto LoopStart; LoopExit: PrintF("Exiting %w%n", TopLoopName!*); end)(IAdd1 TopLoopLevel!*); end; lisp procedure DefnPrint U; % handle case of !*Defn:=T % % Looks for special action on a form, otherwise prettyprints it; % Adapted from DFPRINT % if PairP U and FlagP(car U, 'Ignore) then DefnPrint1 U else % So 'IGNORE is EVALED, not output << if DfPrint!* then Apply(DfPrint!*, list U) else PrettyPrint U; % So 'EVAL gets EVALED and Output if PairP U and FlagP(car U, 'Eval) then DefnPrint1 U >>; lisp procedure DefnPrint1 U; ErrorSet(list('Apply, MkQuote TopLoopEval!*, MkQuote list U), T, !*Backtrace); fluid '(!*Break); lisp procedure NthEntry N; begin scalar !*Break; return if IGEQ(N, HistoryCount!*) then StdError BldMsg("No history entry %r", N) else car PNth(cdr HistoryList!*, IDifference(HistoryCount!*, N)); end; lisp procedure Inp N; %. Return Nth input car NthEntry N; expr procedure ReDo N; %. Re-evaluate Nth input Apply(TopLoopEval!*, list car NthEntry N); lisp procedure Ans N; %. return Nth output cdr NthEntry N; nexpr procedure Hist AL; %. Print history entries begin scalar I1, I2, L; if ILessP(HistoryCount!*, 2) then return NIL; I1 := 1; I2 := ISub1 HistoryCount!*; if PairP AL then << if car AL = 'CLEAR then << HistoryCount!* := 1; HistoryList!* := NIL . NIL; return NIL >>; if IMinusP car AL then return HistPrint(cdr HistoryList!*, ISub1 HistoryCount!*, IMinus car AL); I1 := Max(I1, car AL); AL := cdr AL >>; if PairP AL then I2 := Min(I2, car AL); return HistPrint(PNTH(cdr HistoryList!*, IDifference(HistoryCount!*, I2)), I2, IAdd1 IDifference(I2, I1)); end; lisp procedure HistPrint(L, N, M); if IZeroP M then NIL else << HistPrint(cdr L, ISub1 N, ISub1 M); PrintF("%w Inp: %p%n Ans: %p%n", N, car first L, cdr first L) >>; lisp procedure Time(); %. Get run-time in milliseconds Sys2Int TimC(); % TimC is primitive runtime function lisp procedure StandardLisp(); %. Lisp top loop (lambda (CurrentReadMacroIndicator!*, CurrentScanTable!*); TopLoop('READ, 'PrintWithFreshLine, 'EVAL, "lisp", LispBanner!*) )('LispReadMacro, LispScanTable!*); lisp procedure PrintWithFreshLine X; PrintF("%f%p%n", X); lisp procedure SaveSystem(Banner, File, InitForms); begin scalar SavedHistoryList, SavedHistoryCount; SavedHistoryCount := HistoryCount!*; SavedHistoryList := HistoryList!*; HistoryList!* := NIL; HistoryCount!* := 0; LispBanner!* := BldMsg("%w, %w", Banner, Date()); !*UserMode := T; InitForms!* := InitForms; DumpLisp File; InitForms!* := NIL; HistoryCount!* := SavedHistoryCount; HistoryList!* := SavedHistoryList; end; lisp procedure EvalInitForms(); %. Evaluate and clear InitForms!* << for each X in InitForms!* do Eval X; InitForms!* := NIL >>; END; |
Added psl-1983/kernel/type-conversions.red version [b84e512eaa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TYPE-CONVERSIONS.RED - Functions for converting between various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % <PSL.VAX-INTERP>TYPE-CONVERSIONS.RED.2, 20-Jan-82 02:10:24, Edit by GRISS % Fix list2vector for NIL case % The functions in this file are named `argument-type'2`result-type'. % The number 2 is used rather than `To' only for compatibility with old % versions. Any other suggestions for a consistent naming scheme are welcomed. % Perhaps they should also be `result-type'From`argument-type'. % Float and Fix are in ARITH.RED CompileTime flag('(Sys2FIXN), 'InternalFunction); on SysLisp; syslsp procedure ID2Int U; %. Return ID index as Lisp number if IDP U then MkINT IDInf U else NonIDError(U, 'ID2Int); syslsp procedure Int2ID U; %. Return ID corresponding to index begin scalar StripU; return if IntP U then << StripU := IntInf U; if StripU >= 0 then MkID StripU else TypeError(U, 'Int2ID, '"positive integer") >> else NonIntegerError(U, 'Int2ID); end; syslsp procedure Int2Sys N; %. Convert Lisp integer to untagged if IntP N then IntInf N else if FixNP N then FixVal FixInf N else NonIntegerError(N, 'Int2Sys); syslsp procedure Lisp2Char U; %. Convert Lisp item to syslsp char begin scalar C; % integers, IDs and strings are legal return if IntP U and (C := IntInf U) >= 0 and C <= 127 then C else if IDP U then % take first char of ID print name StrByt(StrInf SymNam IDInf U, 0) else if StringP U then StrByt(StrInf U, 0) % take first character of Lisp string else NonCharacterError(U, 'Lisp2Char); end; syslsp procedure Int2Code N; %. Convert Lisp integer to code pointer MkCODE N; syslsp procedure Sys2Int N; %. Convert word to Lisp number if SignedField(N, InfStartingBit - 1, InfBitLength + 1) eq N then N else Sys2FIXN N; syslsp procedure Sys2FIXN N; begin scalar FX; FX := GtFIXN(); FixVal FX := N; return MkFIXN FX; end; syslsp procedure ID2String U; %. Return print name of U (not copy) if IDP U then SymNam IDInf U else NonIDError(U, 'ID2String); % The functions for converting strings to IDs are Intern and NewID. Intern % returns an interned ID, NewID returns an uninterned ID. They are both found % in OBLIST.RED syslsp procedure String2Vector U; %. Make vector of ASCII values in U if StringP U then begin scalar StripU, V, N; N := StrLen StrInf U; V := GtVECT N; StripU := StrInf U; % in case GC occurred for I := 0 step 1 until N do VecItm(V, I) := MkINT StrByt(StripU, I); return MkVEC V; end else NonStringError(U, 'String2Vector); syslsp procedure Vector2String V; %. Make string with ASCII values in V if VectorP V then begin scalar StripV, S, N, Ch; N := VecLen VecInf V; S := GtSTR N; StripV := VecInf V; % in case GC occurred for I := 0 step 1 until N do StrByt(S, I) := Lisp2Char VecItm(StripV, I); return MkSTR S; end else NonVectorError(V, 'Vector2String); syslsp procedure List2String P; %. Make string with ASCII values in P if null P then '"" else if PairP P then begin scalar S, N; N := IntInf Length P - 1; S := GtSTR N; for I := 0 step 1 until N do << StrByt(S, I) := Lisp2Char car P; P := cdr P >>; return MkSTR S; end else NonPairError(P, 'List2String); syslsp procedure String2List S; %. Make list with ASCII values in S if StringP S then begin scalar L, N; L := NIL; N := StrLen StrInf S; for I := N step -1 until 0 do L := MkINT StrByt(StrInf S, I) . L; % strip S each time in case GC return L; end else NonStringError(S, 'String2List); syslsp procedure List2Vector L; %. convert list to vector if PairP L or NULL L then begin scalar V, N;% this function is used by READ N := IntInf Length L - 1; V := GtVECT N; for I := 0 step 1 until N do << VecItm(V, I) := car L; L := cdr L >>; return MkVEC V; end else NonPairError(L, 'List2Vector); syslsp procedure Vector2List V; %. Convert vector to list if VectorP V then begin scalar L, N; L := NIL; N := VecLen VecInf V; for I := N step -1 until 0 do L := VecItm(VecInf V, I) . L; % strip V each time in case GC return L; end else NonVectorError(V, 'Vector2List); off SysLisp; END; |
Added psl-1983/kernel/type-errors.red version [9b4fa0d5ba].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % TYPE-ERRORS.RED - Error handlers for common type mismatches % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 September 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 27 Jan 1983 1621-PST % Added NonIOChannelError % <PSL.INTERP>TYPE-ERRORS.RED.6, 20-Jan-82 03:10:00, Edit by GRISS % Added NonWords Error lisp procedure TypeError(Offender, Fn, Typ); StdError BldMsg("An attempt was made to do %p on %r, which is not %w", Fn, Offender, Typ); lisp procedure UsageTypeError(Offender, Fn, Typ, Usage); StdError BldMsg("An attempt was made to use %r as %w in %p, where %w is needed", Offender, Usage, Fn, Typ); lisp procedure IndexError(Offender, Fn); UsageTypeError(Offender, Fn, "an integer", "an index"); lisp procedure NonPairError(Offender, Fn); TypeError(Offender, Fn, "a pair"); lisp procedure NonIDError(Offender, Fn); TypeError(Offender, Fn, "an identifier"); lisp procedure NonNumberError(Offender, Fn); TypeError(Offender, Fn, "a number"); lisp procedure NonIntegerError(Offender, Fn); TypeError(Offender, Fn, "an integer"); lisp procedure NonPositiveIntegerError(Offender, Fn); TypeError(Offender, Fn, "a non-negative integer"); lisp procedure NonCharacterError(Offender, Fn); TypeError(Offender, Fn, "a character"); lisp procedure NonStringError(Offender, Fn); TypeError(Offender, Fn, "a string"); lisp procedure NonVectorError(Offender, Fn); TypeError(Offender, Fn, "a vector"); lisp procedure NonWords(Offender, Fn); TypeError(Offender, Fn, "a words vector"); lisp procedure NonSequenceError(Offender, Fn); TypeError(Offender, Fn, "a sequence"); lisp procedure NonIOChannelError(Offender, Fn); TypeError(Offender, Fn, "a legal I/O channel"); END; |
Added psl-1983/kernel/types.build version [d1ca0404f6].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % % TYPES.BUILD - Files with type conversions and others % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 19 May 1982 % Copyright (c) 1982 University of Utah % PathIn "type-conversions.red"$ % convert from one type to another PathIn "vectors.red"$ % GetV, PutV, UpbV PathIn "sequence.red"$ % Indx, SetIndx, Sub, SetSub, Concat |
Added psl-1983/kernel/vectors.red version [e7f4aa89ad].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % VECTORS.RED - Standard Lisp Vector functions % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>VECTORS.RED.2, 10-Jan-83 15:54:19, Edit by PERDUE % Added EGetV etc. for EVectors, paralleling Vectors % MkVect and MkEVector are found in PK:CONS-MKVECT.RED on SysLisp; syslsp procedure GetV(Vec, I); %. Retrieve the I'th entry of Vec begin scalar StripV, StripI; return if VectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) else StdError BldMsg('"Subscript %r in GetV is out of range", I) >> else IndexError(I, 'GetV) else NonVectorError(Vec, 'GetV); end; syslsp procedure PutV(Vec, I, Val); %. Store Val at I'th position of Vec begin scalar StripV, StripI; return if VectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in PutV is out of range", I) >> else IndexError(I, 'PutV) else NonVectorError(Vec, 'PutV); end; syslsp procedure UpbV V; %. Upper limit of vector V if VectorP V then MkINT VecLen VecInf V else NIL; %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% EVectors %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% syslsp procedure EVECTORP V; TAG(V) EQ EVECT; syslsp procedure EGETV(Vec, I); %. Retrieve the I'th entry of Vec begin scalar StripV, StripI; return if EvectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) else StdError BldMsg('"Subscript %r in EGETV is out of range", I) >> else IndexError(I, 'EGETV) else NonVectorError(Vec, 'EGETV); end; syslsp procedure Eputv(Vec, I, Val); %. Store Val at I'th position of Vec begin scalar StripV, StripI; return if EvectorP Vec then if IntP I then % can't have vectors bigger than INUM << StripV := VecInf Vec; StripI := IntInf I; if StripI >= 0 and StripI <= VecLen StripV then VecItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in Eputv is out of range", I) >> else IndexError(I, 'Eputv) else NonVectorError(Vec, 'Eputv); end; syslsp procedure EUpbV V; %. Upper limit of vector V if EvectorP V then MkINT EVecLen EVecInf V else NIL; off SysLisp; END; |
Added psl-1983/lap/20-kernel-gen.ctl version [0fb43c4149].
> > > | 1 2 3 | @psl:psl *(lapin "p20:20-kernel-gen.sl") *(quit) |
Added psl-1983/lap/20-kernel-gen.sl version [827c70bc8a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % 20-KERNEL-GEN.SL - Generate scripts for building Dec-20 PSL kernel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.20-INTERP>20-KERNEL-GEN.SL.15, 7-Jun-82 12:48:19, Edit by BENSON % Converted kernel-file-name* to all-kernel-script... % <PSL.20-INTERP>20-KERNEL-GEN.SL.14, 6-Jun-82 05:29:21, Edit by GRISS % Add kernel-file-name* (compiletime (load kernel)) (compiletime (setq *EOLInStringOK T)) (loadtime (imports '(kernel))) (setq command-file-name* "%w.ctl") (setq command-file-format* "define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut ""%w""; in ""%w.build""; ASMEnd; quit; compile %w.mac, d%w.mac delete %w.mac, d%w.mac ") (setq init-file-name* "psl.init") (setq init-file-format* "(lapin ""%w.init"") ") (setq all-kernel-script-name* "all-kernel.ctl") (setq all-kernel-script-format* "submit %w.ctl ") (setq code-object-file-name* "%w.rel") (setq data-object-file-name* "d%w.rel") (setq link-script-name* "psl-link.ctl") (setq link-script-format* "cd S: define DSK:, DSK:, P20: LINK /nosymbol nil.rel /set:.low.:202 %e /save s:bpsl.exe /go ") (setq script-file-name-separator* " ") (kernel '(types randm alloc arith debg error eval extra fasl io macro prop symbl sysio tloop main heap)) |
Added psl-1983/lap/20.sym version [d07e412040].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (SAVEFORCOMPILATION (QUOTE (PROGN (PUT (QUOTE PROGN) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE QUOTE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !') ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADQUOTEDEXPRESSION)) (PUT (QUOTE !() ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADLISTORDOTTEDPAIR)) (PUT (QUOTE !)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADRIGHTPAREN)) (PUT (QUOTE ![) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADVECTOR)) (PUT (MKID (CHAR EOF)) ( QUOTE LISPREADMACRO) (FUNCTION CHANNELREADEOF)) (INITOBLIST) (PUT (QUOTE EOF) ( QUOTE CHARCONST) (CHAR (CNTRL Z)))))) (SETQ ORDEREDIDLIST!* (QUOTE (ID2INT NONIDERROR INT2ID TYPEERROR NONINTEGERERROR INT2SYS LISP2CHAR NONCHARACTERERROR INT2CODE SYS2INT GTFIXN ID2STRING STRING2VECTOR GTVECT NONSTRINGERROR VECTOR2STRING GTSTR NONVECTORERROR LIST2STRING LENGTH NONPAIRERROR STRING2LIST CONS LIST2VECTOR VECTOR2LIST GETV BLDMSG STDERROR INDEXERROR PUTV UPBV EVECTORP EGETV EPUTV EUPBV INDX RANGEERROR NONSEQUENCEERROR SETINDX SUB SUBSEQ GTWRDS GTHALFWORDS NCONS TCONC SETSUB SETSUBSEQ CONCAT APPEND SIZE MKSTRING NONPOSITIVEINTEGERERROR MAKE!-BYTES MAKE!-HALFWORDS MAKE!-WORDS MAKE!-VECTOR STRING VECTOR CODEP EQ FLOATP BIGP IDP PAIRP STRINGP VECTORP CAR CDR RPLACA RPLACD FIXP DIGIT LITER EQN LISPEQUAL STRINGEQUAL EQSTR EQUAL CAAAAR CAAAR CAAADR CAADAR CAADR CAADDR CADAAR CADAR CADADR CADDAR CADDR CADDDR CDAAAR CDAAR CDAADR CDADAR CDADR CDADDR CDDAAR CDDAR CDDADR CDDDAR CDDDR CDDDDR CAAR CADR CDAR CDDR SAFECAR SAFECDR ATOM CONSTANTP NULL NUMBERP EXPT MKQUOTE LIST3 CONTINUABLEERROR GREATERP DIFFERENCE MINUSP TIMES2 ADD1 QUOTIENT PLUS2 LIST EVLIS QUOTE EXPR DE LIST2 LIST4 PUTD FUNCTION LAMBDA FEXPR DF MACRO DM NEXPR DN SETQ EVAL SET PROG2 PROGN EVPROGN AND EVAND OR EVOR COND EVCOND NOT ABS MINUS DIVIDE ZEROP REMAINDER XCONS MAX ROBUSTEXPAND MAX2 LESSP MIN MIN2 PLUS TIMES MAP FASTAPPLY MAPC MAPCAN NCONC MAPCON MAPCAR MAPLIST ASSOC SASSOC PAIR SUBLIS DEFLIST PUT DELETE MEMBER MEMQ REVERSE SUBST EXPAND CHANNELPRINT CHANNELPRIN1 CHANNELTERPRI PRINT OUT!* NEQ NE GEQ LEQ EQCAR EXPRP GETD MACROP FEXPRP NEXPRP COPYD RECIP FIRST SECOND THIRD FOURTH REST REVERSIP SUBSTIP DELETIP DELQ DEL DELQIP ATSOC ASS MEM RASSOC DELASC DELASCIP DELATQ DELATQIP SUBLA RPLACW LASTCAR LASTPAIR COPY NTH SUB1 PNTH ACONC LCONC MAP2 MAPC2 CHANNELPRIN2T CHANNELPRIN2 PRIN2T CHANNELSPACES CHANNELWRITECHAR SPACES CHANNELTAB CHANNELPOSN TAB FILEP PUTC SPACES2 CHANNELSPACES2 LIST2SET LIST2SETQ ADJOIN ADJOINQ UNION UNIONQ XN XNQ INTERSECTION INTERSECTIONQ KNOWN!-FREE!-SPACE GTHEAP FATALERROR !%RECLAIM GC!-TRAP GC!-TRAP!-LEVEL SET!-GC!-TRAP!-LEVEL DELHEAP GTCONSTSTR GTBPS GTEVECT GTFLTN GTID RECLAIM DELBPS GTWARRAY DELWARRAY COPYSTRINGTOFROM COPYSTRING COPYWARRAY COPYVECTORTOFROM COPYVECTOR COPYWRDSTOFROM COPYWRDS TOTALCOPY MKVECT MKEVECTOR MKEVECT LIST5 !*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL ERRORPRINTF TIMC QUIT RETURNNIL RETURNFIRSTARG LAND LOR LXOR LSHIFT LSH LNOT FIX FLOAT ONEP DEBUG TR EVLOAD TRST QEDITFNS !*EXPERT !*VERBOSE EDITF EDIT YESP PROMPTSTRING!* FASTBIND TERPRI EDITORREADER!* EDITORPRINTER!* FASTUNBIND READ CL HELP BREAK EHELP PL UP OK DISPLAYHELPFILE EDITOR IGNOREDINBACKTRACE!* INTERPRETERFUNCTIONS!* INTERPBACKTRACE PRINTF BACKTRACE RETURNADDRESSP ADDR2ID VERBOSEBACKTRACE OPTIONS!* WRITECHAR CHANNELWRITEUNKNOWNITEM CODE!-ADDRESS!-TO!-SYMBOL PRIN1 ERROR NO YES RDS ERROUT!* WRS ERRORSET CURSYM!* !*SEMICOL!* ERRORFORM!* !*CONTINUABLEERROR EMSG!* !*BREAK !*EMSGP MAXBREAKLEVEL!* BREAKLEVEL!* FLATSIZE USAGETYPEERROR NONNUMBERERROR NONWORDS NONIOCHANNELERROR !*BACKTRACE !*INNER!*BACKTRACE THROW !$ERROR!$ ERRSET CATCH CATCHSETUP THROWSIGNAL!* !%UNCATCH CHANNELNOTOPEN CHANNELERROR WRITEONLYCHANNEL READONLYCHANNEL ILLEGALSTANDARDCHANNELCLOSE IOERROR CODEAPPLY CODEEVALAPPLY BINDEVAL LBIND1 COMPILEDCALLINGINTERPRETED BSTACKOVERFLOW RESTOREENVIRONMENT !*LAMBDALINK UNDEFINEDFUNCTION UNBINDN APPLY FUNBOUNDP FCODEP GETFCODEPOINTER GET VALUECELL GETFNTYPE !&!&VALUE!&!& THROWTAG!* CATCH!-ALL UNWIND!-ALL !&!&THROWN!&!& !$UNWIND!-PROTECT!$ !&!&TAG!&!& !%THROW UNWIND!-PROTECT !*CATCH !*THROW RESET CAPTUREENVIRONMENT !%CLEAR!-CATCH!-STACK PROGBODY!* PROGJUMPTABLE!* PROG PBIND1 !$PROG!$ GO RETURN SYSTEM_LIST!* DATE DUMPLISP BINARYOPENREAD DEC20OPEN BINARYOPENWRITE VALUECELLLOCATION !*WRITINGFASLFILE NEWBITTABLEENTRY!* FINDIDNUMBER MAKERELOCHALFWORD EXTRAREGLOCATION FUNCTIONCELLLOCATION FASLIN INTERN PUTENTRY LOADDIRECTORIES!* LOADEXTENSIONS!* !*VERBOSELOAD !*PRINTLOADNAMES LOAD LOAD1 RELOAD EVRELOAD !*USERMODE !*REDEFMSG !*INSIDELOAD !*LOWER PENDINGLOADS!* IMPORTS PRETTYPRINT DEFSTRUCT STEP MINI EMODE INVOKE RCREF CREFON COMPILER COMPD FASLOUT BUG EXEC MM TERMINALINPUTHANDLER COMPRESSREADCHAR DEC20WRITECHAR TOSTRINGWRITECHAR EXPLODEWRITECHAR FLATSIZEWRITECHAR !$EOL!$ CHANNELREADCHAR READCHAR IN!* CHANNELUNREADCHAR UNREADCHAR OPEN SYSTEMOPENFILEFORINPUT SYSTEMOPENFILEFOROUTPUT SYSTEMOPENFILESPECIAL SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!* SPECIAL OUTPUT INPUT CLOSE SYSTEMMARKASCLOSEDCHANNEL SPECIALRDSACTION!* STDIN!* SPECIALWRSACTION!* STDOUT!* CHANNELEJECT EJECT CHANNELLINELENGTH LINELENGTH POSN CHANNELLPOSN LPOSN CHANNELREADCH !*RAISE READCH PRINC CHANNELPRINC CURRENTREADMACROINDICATOR!* CHANNELREADTOKENWITHHOOKS CHANNELREADTOKEN TOKTYPE!* CURRENTSCANTABLE!* CHANNELREAD LISPSCANTABLE!* LISPREADMACRO MAKEINPUTAVAILABLE !*INSIDESTRUCTUREREAD CHANNELREADEOF !$EOF!$ CHANNELREADQUOTEDEXPRESSION CHANNELREADLISTORDOTTEDPAIR CHANNELREADRIGHTPAREN CHANNELREADVECTOR !*COMPRESSING !*EOLINSTRINGOK NEWID MAKESTRINGINTOLISPINTEGER DIGITTONUMBER PACKAGE CURRENTPACKAGE!* GLOBAL RATOM READLINE CHANNELREADLINE OUTPUTBASE!* IDESCAPECHAR!* CHANNELWRITESTRING WRITESTRING CHANNELWRITESYSINTEGER CHANNELWRITEBITSTRAUX WRITESYSINTEGER CHANNELWRITEFIXNUM CHANNELWRITEINTEGER CHANNELWRITESYSFLOAT WRITEFLOAT CHANNELWRITEFLOAT CHANNELPRINTSTRING CHANNELWRITEID CHANNELWRITEUNBOUND CHANNELPRINTID CHANNELPRINTUNBOUND CHANNELWRITECODEPOINTER CHANNELWRITEBLANKOREOL CHANNELWRITEPAIR PRINLEVEL PRINLENGTH RECURSIVECHANNELPRIN2 CHANNELPRINTPAIR RECURSIVECHANNELPRIN1 CHANNELWRITEVECTOR CHANNELPRINTVECTOR CHANNELWRITEEVECTOR OBJECT!-GET!-HANDLER!-QUIETLY CHANNELPRIN CHANNELPRINTEVECTOR CHANNELWRITEWORDS CHANNELWRITEHALFWORDS CHANNELWRITEBYTES PRIN2 FORMATFORPRINTF!* PRIN2L ERRPRIN CHANNELPRINTF EXPLODEENDPOINTER!* EXPLODE EXPLODE2 FLATSIZE2 COMPRESSERROR COMPRESSLIST!* CLEARCOMPRESSCHANNEL COMPRESS IMPLODE CHANNELTYI CHANNELTYO TYI TYO COMMENTOUTCODE COMPILETIME BOTHTIMES LOADTIME STARTUPTIME CONTERROR OTHERWISE DEFAULT CASE RANGE SETF EXPANDSETF SETF!-EXPAND ASSIGN!-OP ONOFF!* MKFLAGVAR SIMPFG ON OFF !#ARG DS DEFCONST EVDEFCONST CONST STRINGGENSYM STRINGGENSYM!* FOREACH COLLECT JOIN CONC IN DO EXIT !$LOOP!$ NEXT WHILE REPEAT FOR GENSYM MK!*SQ SIMP BIN FLAMBDALINKP MAKEFUNBOUND MAKEFLAMBDALINK MAKEFCODE PROP SETPROP FLAGP TYPE FLAG FLAG1 REMFLAG REMFLAG1 REMPROP REMPROPL UNBOUNDP VARTYPE FLUID FLUID1 FLUIDP GLOBAL1 GLOBALP UNFLUID UNFLUID1 REMD !*COMP USER LOSE CODE!-NUMBER!-OF!-ARGUMENTS BSTACKUNDERFLOW CLEARBINDINGS MAKEUNBOUND HASHFUNCTION REMOB INTERNP INTERNGENSYM MAPOBL GLOBALLOOKUP GLOBALINSTALL GLOBALREMOVE INITOBLIST DEC20READCHAR !*ECHO CLEARIO DEC20CLOSECHANNEL !*DEFN BREAKVALUE!* !*QUITBREAK BREAKIN!* BREAKOUT!* TOPLOOPNAME!* TOPLOOPEVAL!* BREAKEVAL!* BREAKNAME!* TOPLOOPPRINT!* TOPLOOPREAD!* TOPLOOP !$BREAK!$ BREAKEVAL BREAKFUNCTION BREAKQUIT BREAKCONTINUE BREAKRETRY HELPBREAK BREAKERRMSG BREAKEDIT TOPLOOPLEVEL!* HISTORYCOUNT!* LISPBANNER!* !*OUTPUT SEMIC!* HISTORYLIST!* !*TIME TIME !*NONIL !$EXITTOPLOOP!$ DFPRINT!* IGNORE INP REDO ANS HIST CLEAR STANDARDLISP PRINTWITHFRESHLINE SAVESYSTEM INITFORMS!* EVALINITFORMS DSKIN DSKINEVAL LAPIN))) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 841)) (SETQ STRINGGENSYM!* (QUOTE "L3692")) (PUT (QUOTE TWOARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1368")) (PUT (QUOTE RELOAD) (QUOTE ENTRYPOINT) (QUOTE RELOAD)) (PUT (QUOTE RELOAD) (QUOTE IDNUMBER) (QUOTE 568)) (PUT (QUOTE TWOARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1385")) (PUT (QUOTE INTLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1515")) (PUT (QUOTE CADR) (QUOTE ENTRYPOINT) (QUOTE CADR)) (PUT (QUOTE CADR) (QUOTE IDNUMBER) (QUOTE 232)) (PUT (QUOTE NEQ) (QUOTE ENTRYPOINT) (QUOTE NEQ)) (PUT (QUOTE NEQ) (QUOTE IDNUMBER) (QUOTE 320)) (PUT (QUOTE LIST2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0059")) (PUT (QUOTE LIST2STRING) (QUOTE IDNUMBER) (QUOTE 147)) (PUT (QUOTE SPECIALRDSACTION!*) (QUOTE IDNUMBER) (QUOTE 614)) (FLAG (QUOTE (SPECIALRDSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GLOBALLOOKUP) (QUOTE ENTRYPOINT) (QUOTE "L3479")) (PUT (QUOTE GLOBALLOOKUP) (QUOTE IDNUMBER) (QUOTE 787)) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L2911")) (PUT (QUOTE CLEARCOMPRESSCHANNEL) (QUOTE IDNUMBER) (QUOTE 702)) (PUT (QUOTE DEFSTRUCT) (QUOTE ENTRYPOINT) (QUOTE "L2240")) (PUT (QUOTE DEFSTRUCT) (QUOTE IDNUMBER) (QUOTE 577)) (PUT (QUOTE GTWRDS) (QUOTE ENTRYPOINT) (QUOTE GTWRDS)) (PUT (QUOTE GTWRDS) (QUOTE IDNUMBER) (QUOTE 170)) (PUT (QUOTE MAKERELOCHALFWORD) (QUOTE IDNUMBER) (QUOTE 556)) (PUT (QUOTE BACKTRACE1) (QUOTE ENTRYPOINT) (QUOTE "L1704")) (PUT (QUOTE DO) (QUOTE IDNUMBER) (QUOTE 740)) (PUT (QUOTE THROWSIGNAL!*) (QUOTE IDNUMBER) (QUOTE 500)) (FLAG (QUOTE (THROWSIGNAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE REMFLAG) (QUOTE ENTRYPOINT) (QUOTE "L3218")) (PUT (QUOTE REMFLAG) (QUOTE IDNUMBER) (QUOTE 761)) (PUT (QUOTE PRINLEVEL) (QUOTE IDNUMBER) (QUOTE 677)) (FLAG (QUOTE (PRINLEVEL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EJECT) (QUOTE ENTRYPOINT) (QUOTE EJECT)) (PUT (QUOTE EJECT) (QUOTE IDNUMBER) (QUOTE 619)) (PUT (QUOTE LISPREADMACRO) (QUOTE IDNUMBER) (QUOTE 637)) (PUT (QUOTE STRING2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0068")) (PUT (QUOTE STRING2LIST) (QUOTE IDNUMBER) (QUOTE 150)) (PUT (QUOTE GEQ) (QUOTE ENTRYPOINT) (QUOTE GEQ)) (PUT (QUOTE GEQ) (QUOTE IDNUMBER) (QUOTE 322)) (PUT (QUOTE EXIT) (QUOTE ENTRYPOINT) (QUOTE EXIT)) (PUT (QUOTE EXIT) (QUOTE IDNUMBER) (QUOTE 741)) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3527")) (PUT (QUOTE DEC20CLOSECHANNEL) (QUOTE IDNUMBER) (QUOTE 794)) (PUT (QUOTE ONEARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1397")) (PUT (QUOTE STRING2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0041")) (PUT (QUOTE STRING2VECTOR) (QUOTE IDNUMBER) (QUOTE 141)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1851")) (PUT (QUOTE BNDSTKUPPERBOUND) (QUOTE WVAR) (QUOTE BNDSTKUPPERBOUND)) (PUT (QUOTE BACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1699")) (PUT (QUOTE BACKTRACE) (QUOTE IDNUMBER) (QUOTE 463)) (PUT (QUOTE IOERROR) (QUOTE ENTRYPOINT) (QUOTE "L1847")) (PUT (QUOTE IOERROR) (QUOTE IDNUMBER) (QUOTE 507)) (PUT (QUOTE RETURNNIL) (QUOTE ENTRYPOINT) (QUOTE "L1422")) (PUT (QUOTE RETURNNIL) (QUOTE IDNUMBER) (QUOTE 422)) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2584")) (PUT (QUOTE CHANNELWRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 661)) (PUT (QUOTE DELHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1109")) (PUT (QUOTE DELHEAP) (QUOTE IDNUMBER) (QUOTE 393)) (PUT (QUOTE GENSYM) (QUOTE ENTRYPOINT) (QUOTE GENSYM)) (PUT (QUOTE GENSYM) (QUOTE IDNUMBER) (QUOTE 747)) (PUT (QUOTE ONEARGPREDICATEDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1410")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1716")) (PUT (QUOTE VERBOSEBACKTRACE) (QUOTE IDNUMBER) (QUOTE 466)) (PUT (QUOTE WRS) (QUOTE ENTRYPOINT) (QUOTE WRS)) (PUT (QUOTE WRS) (QUOTE IDNUMBER) (QUOTE 477)) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE ENTRYPOINT) (QUOTE "L3533")) (PUT (QUOTE SYSTEMOPENFILEFORINPUT) (QUOTE IDNUMBER) (QUOTE 603)) (PUT (QUOTE !*EMSGP) (QUOTE IDNUMBER) (QUOTE 485)) (PUT (QUOTE !*EMSGP) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE TYI) (QUOTE ENTRYPOINT) (QUOTE TYI)) (PUT (QUOTE TYI) (QUOTE IDNUMBER) (QUOTE 707)) (PUT (QUOTE FUNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3141")) (PUT (QUOTE FUNBOUNDP) (QUOTE IDNUMBER) (QUOTE 519)) (PUT (QUOTE FATALERROR) (QUOTE ENTRYPOINT) (QUOTE "L1732")) (PUT (QUOTE FATALERROR) (QUOTE IDNUMBER) (QUOTE 388)) (PUT (QUOTE WHILE) (QUOTE ENTRYPOINT) (QUOTE WHILE)) (PUT (QUOTE WHILE) (QUOTE IDNUMBER) (QUOTE 744)) (PUT (QUOTE STANDARDLISP) (QUOTE ENTRYPOINT) (QUOTE "L3650")) (PUT (QUOTE STANDARDLISP) (QUOTE IDNUMBER) (QUOTE 833)) (PUT (QUOTE ST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ST) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE ST) (QUOTE WVAR) (QUOTE ST)) (PUT (QUOTE !*OUTPUT) (QUOTE IDNUMBER) (QUOTE 819)) (PUT (QUOTE !*OUTPUT) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SECOND) (QUOTE ENTRYPOINT) (QUOTE SECOND)) (PUT (QUOTE SECOND) (QUOTE IDNUMBER) (QUOTE 333)) (PUT (QUOTE PRIN2L) (QUOTE ENTRYPOINT) (QUOTE PRIN2L)) (PUT (QUOTE PRIN2L) (QUOTE IDNUMBER) (QUOTE 693)) (PUT (QUOTE CURSYM!*) (QUOTE IDNUMBER) (QUOTE 479)) (PUT (QUOTE CHANNELTYI) (QUOTE ENTRYPOINT) (QUOTE "L2917")) (PUT (QUOTE CHANNELTYI) (QUOTE IDNUMBER) (QUOTE 705)) (PUT (QUOTE FLOATREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1471")) (PUT (QUOTE SASSOC) (QUOTE ENTRYPOINT) (QUOTE SASSOC)) (PUT (QUOTE SASSOC) (QUOTE IDNUMBER) (QUOTE 304)) (PUT (QUOTE ADDR2ID) (QUOTE IDNUMBER) (QUOTE 465)) (PUT (QUOTE GC!-TRAP) (QUOTE IDNUMBER) (QUOTE 390)) (PUT (QUOTE ROBUSTEXPAND) (QUOTE ENTRYPOINT) (QUOTE "L0815")) (PUT (QUOTE ROBUSTEXPAND) (QUOTE IDNUMBER) (QUOTE 288)) (PUT (QUOTE INTREMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1470")) (PUT (QUOTE SYMFNC) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMFNC) (QUOTE ASMSYMBOL) (QUOTE SYMFNC)) (PUT (QUOTE SYMFNC) (QUOTE WARRAY) (QUOTE SYMFNC)) (PUT (QUOTE TERPRI) (QUOTE ENTRYPOINT) (QUOTE TERPRI)) (PUT (QUOTE TERPRI) (QUOTE IDNUMBER) (QUOTE 445)) (PUT (QUOTE MAXOBARRAY) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXOBARRAY) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXOBARRAY) (QUOTE WCONST) (QUOTE 8209)) (PUT (QUOTE TWOARGDISPATCH1) (QUOTE ENTRYPOINT) (QUOTE "L1369")) (PUT (QUOTE NEXPR) (QUOTE IDNUMBER) (QUOTE 266)) (PUT (QUOTE DEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3609")) (PUT (QUOTE CURRENTPACKAGE!*) (QUOTE IDNUMBER) (QUOTE 652)) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE ENTRYPOINT) (QUOTE "L2048")) (PUT (QUOTE !%CLEAR!-CATCH!-STACK) (QUOTE IDNUMBER) (QUOTE 538)) (PUT (QUOTE SETSUBSEQ) (QUOTE ENTRYPOINT) (QUOTE "L0233")) (PUT (QUOTE SETSUBSEQ) (QUOTE IDNUMBER) (QUOTE 175)) (PUT (QUOTE PNTH) (QUOTE ENTRYPOINT) (QUOTE PNTH)) (PUT (QUOTE PNTH) (QUOTE IDNUMBER) (QUOTE 358)) (PUT (QUOTE PACKAGE) (QUOTE ENTRYPOINT) (QUOTE "L2572")) (PUT (QUOTE PACKAGE) (QUOTE IDNUMBER) (QUOTE 651)) (PUT (QUOTE MAKEDS) (QUOTE ENTRYPOINT) (QUOTE MAKEDS)) (PUT (QUOTE !*USERMODE) (QUOTE IDNUMBER) (QUOTE 570)) (FLAG (QUOTE (!*USERMODE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*REDEFMSG) (QUOTE IDNUMBER) (QUOTE 571)) (PUT (QUOTE !*REDEFMSG) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE SAVE!-INTO!-FILE) (QUOTE ENTRYPOINT) (QUOTE "L2114")) (PUT (QUOTE CHANNELPRINTID) (QUOTE ENTRYPOINT) (QUOTE "L2617")) (PUT (QUOTE CHANNELPRINTID) (QUOTE IDNUMBER) (QUOTE 672)) (PUT (QUOTE BUG) (QUOTE ENTRYPOINT) (QUOTE BUG)) (PUT (QUOTE BUG) (QUOTE IDNUMBER) (QUOTE 587)) (PUT (QUOTE DEFAULT) (QUOTE IDNUMBER) (QUOTE 716)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE IDNUMBER) (QUOTE 459)) (PUT (QUOTE IGNOREDINBACKTRACE!*) (QUOTE INITIALVALUE) (QUOTE (EVAL APPLY FASTAPPLY CODEAPPLY CODEEVALAPPLY CATCH ERRORSET EVPROGN TOPLOOP BREAKEVAL BINDEVAL BREAK MAIN))) (PUT (QUOTE CLEAR) (QUOTE IDNUMBER) (QUOTE 832)) (PUT (QUOTE LPOSN) (QUOTE ENTRYPOINT) (QUOTE LPOSN)) (PUT (QUOTE LPOSN) (QUOTE IDNUMBER) (QUOTE 624)) (PUT (QUOTE DOPNTH) (QUOTE ENTRYPOINT) (QUOTE DOPNTH)) (PUT (QUOTE BREAKOUT!*) (QUOTE IDNUMBER) (QUOTE 799)) (FLAG (QUOTE (BREAKOUT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETQ) (QUOTE ENTRYPOINT) (QUOTE SETQ)) (PUT (QUOTE SETQ) (QUOTE IDNUMBER) (QUOTE 268)) (PUT (QUOTE STRINGGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3050")) (PUT (QUOTE STRINGGENSYM) (QUOTE IDNUMBER) (QUOTE 733)) (PUT (QUOTE FLOATSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1531")) (PUT (QUOTE TAB) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE TAB) (QUOTE IDNUMBER) (QUOTE 371)) (PUT (QUOTE CDADR) (QUOTE ENTRYPOINT) (QUOTE CDADR)) (PUT (QUOTE CDADR) (QUOTE IDNUMBER) (QUOTE 223)) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1144")) (PUT (QUOTE COPYWRDSTOFROM) (QUOTE IDNUMBER) (QUOTE 408)) (PUT (QUOTE UNFLUID) (QUOTE ENTRYPOINT) (QUOTE "L3274")) (PUT (QUOTE UNFLUID) (QUOTE IDNUMBER) (QUOTE 772)) (PUT (QUOTE MEMBER) (QUOTE ENTRYPOINT) (QUOTE MEMBER)) (PUT (QUOTE MEMBER) (QUOTE IDNUMBER) (QUOTE 310)) (PUT (QUOTE EXPRP) (QUOTE ENTRYPOINT) (QUOTE EXPRP)) (PUT (QUOTE EXPRP) (QUOTE IDNUMBER) (QUOTE 325)) (PUT (QUOTE LNOT) (QUOTE ENTRYPOINT) (QUOTE LNOT)) (PUT (QUOTE LNOT) (QUOTE IDNUMBER) (QUOTE 429)) (PUT (QUOTE ONEARGPREDICATEDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1409")) (PUT (QUOTE ACONC) (QUOTE ENTRYPOINT) (QUOTE ACONC)) (PUT (QUOTE ACONC) (QUOTE IDNUMBER) (QUOTE 359)) (PUT (QUOTE PRETTYPRINT) (QUOTE ENTRYPOINT) (QUOTE "L2236")) (PUT (QUOTE PRETTYPRINT) (QUOTE IDNUMBER) (QUOTE 576)) (PUT (QUOTE !$PROG!$) (QUOTE IDNUMBER) (QUOTE 543)) (PUT (QUOTE ERRSET) (QUOTE ENTRYPOINT) (QUOTE ERRSET)) (PUT (QUOTE ERRSET) (QUOTE IDNUMBER) (QUOTE 497)) (PUT (QUOTE DIVIDE) (QUOTE ENTRYPOINT) (QUOTE DIVIDE)) (PUT (QUOTE DIVIDE) (QUOTE IDNUMBER) (QUOTE 283)) (PUT (QUOTE DELETE) (QUOTE ENTRYPOINT) (QUOTE DELETE)) (PUT (QUOTE DELETE) (QUOTE IDNUMBER) (QUOTE 309)) (PUT (QUOTE NONINTEGER2ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1391")) (PUT (QUOTE STRINGP) (QUOTE ENTRYPOINT) (QUOTE "L0392")) (PUT (QUOTE STRINGP) (QUOTE IDNUMBER) (QUOTE 193)) (PUT (QUOTE LIST2) (QUOTE ENTRYPOINT) (QUOTE LIST2)) (PUT (QUOTE LIST2) (QUOTE IDNUMBER) (QUOTE 257)) (PUT (QUOTE INPUT) (QUOTE IDNUMBER) (QUOTE 611)) (PUT (QUOTE PRINLENGTH) (QUOTE IDNUMBER) (QUOTE 678)) (FLAG (QUOTE (PRINLENGTH)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE XNQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE XNQ) (QUOTE IDNUMBER) (QUOTE 383)) (PUT (QUOTE TYO) (QUOTE ENTRYPOINT) (QUOTE TYO)) (PUT (QUOTE TYO) (QUOTE IDNUMBER) (QUOTE 708)) (PUT (QUOTE REMD) (QUOTE ENTRYPOINT) (QUOTE REMD)) (PUT (QUOTE REMD) (QUOTE IDNUMBER) (QUOTE 774)) (PUT (QUOTE !*THROW) (QUOTE ENTRYPOINT) (QUOTE "L2036")) (PUT (QUOTE !*THROW) (QUOTE IDNUMBER) (QUOTE 535)) (PUT (QUOTE EVPROGN) (QUOTE ENTRYPOINT) (QUOTE "L0686")) (PUT (QUOTE EVPROGN) (QUOTE IDNUMBER) (QUOTE 273)) (PUT (QUOTE ERRORFORM!*) (QUOTE IDNUMBER) (QUOTE 481)) (FLAG (QUOTE (ERRORFORM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !*INSIDELOAD) (QUOTE IDNUMBER) (QUOTE 572)) (FLAG (QUOTE (!*INSIDELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1567")) (PUT (QUOTE LBIND1) (QUOTE ENTRYPOINT) (QUOTE LBIND1)) (PUT (QUOTE LBIND1) (QUOTE IDNUMBER) (QUOTE 511)) (PUT (QUOTE CAAR) (QUOTE ENTRYPOINT) (QUOTE CAAR)) (PUT (QUOTE CAAR) (QUOTE IDNUMBER) (QUOTE 231)) (PUT (QUOTE MAP) (QUOTE ENTRYPOINT) (QUOTE MAP)) (PUT (QUOTE MAP) (QUOTE IDNUMBER) (QUOTE 295)) (PUT (QUOTE FOURTH) (QUOTE ENTRYPOINT) (QUOTE FOURTH)) (PUT (QUOTE FOURTH) (QUOTE IDNUMBER) (QUOTE 335)) (PUT (QUOTE LXOR) (QUOTE ENTRYPOINT) (QUOTE LXOR)) (PUT (QUOTE LXOR) (QUOTE IDNUMBER) (QUOTE 426)) (PUT (QUOTE COMPD) (QUOTE ENTRYPOINT) (QUOTE COMPD)) (PUT (QUOTE COMPD) (QUOTE IDNUMBER) (QUOTE 585)) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2711")) (PUT (QUOTE CHANNELPRINTVECTOR) (QUOTE IDNUMBER) (QUOTE 683)) (PUT (QUOTE UNFLUID1) (QUOTE ENTRYPOINT) (QUOTE "L3279")) (PUT (QUOTE UNFLUID1) (QUOTE IDNUMBER) (QUOTE 773)) (PUT (QUOTE BOTHTIMES) (QUOTE ENTRYPOINT) (QUOTE "L2921")) (PUT (QUOTE BOTHTIMES) (QUOTE IDNUMBER) (QUOTE 711)) (PUT (QUOTE READFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE READFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2275")) (PUT (QUOTE READFUNCTION) (QUOTE WARRAY) (QUOTE READFUNCTION)) (PUT (QUOTE GETFCODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L3172")) (PUT (QUOTE GETFCODEPOINTER) (QUOTE IDNUMBER) (QUOTE 521)) (PUT (QUOTE VALUECELL) (QUOTE ENTRYPOINT) (QUOTE "L3388")) (PUT (QUOTE VALUECELL) (QUOTE IDNUMBER) (QUOTE 523)) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2678")) (PUT (QUOTE CHANNELPRINTPAIR) (QUOTE IDNUMBER) (QUOTE 680)) (PUT (QUOTE WRITESYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2596")) (PUT (QUOTE WRITESYSINTEGER) (QUOTE IDNUMBER) (QUOTE 663)) (PUT (QUOTE BACKTRACERANGE) (QUOTE ENTRYPOINT) (QUOTE "L1696")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L1095")) (PUT (QUOTE KNOWN!-FREE!-SPACE) (QUOTE IDNUMBER) (QUOTE 386)) (PUT (QUOTE NCONS) (QUOTE ENTRYPOINT) (QUOTE NCONS)) (PUT (QUOTE NCONS) (QUOTE IDNUMBER) (QUOTE 172)) (PUT (QUOTE DIGIT) (QUOTE ENTRYPOINT) (QUOTE DIGIT)) (PUT (QUOTE DIGIT) (QUOTE IDNUMBER) (QUOTE 200)) (PUT (QUOTE FASLIN) (QUOTE ENTRYPOINT) (QUOTE FASLIN)) (PUT (QUOTE FASLIN) (QUOTE IDNUMBER) (QUOTE 559)) (PUT (QUOTE LIST2SETQ) (QUOTE ENTRYPOINT) (QUOTE "L1060")) (PUT (QUOTE LIST2SETQ) (QUOTE IDNUMBER) (QUOTE 377)) (PUT (QUOTE DSKIN) (QUOTE ENTRYPOINT) (QUOTE DSKIN)) (PUT (QUOTE DSKIN) (QUOTE IDNUMBER) (QUOTE 838)) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2598")) (PUT (QUOTE CHANNELWRITEINTEGER) (QUOTE IDNUMBER) (QUOTE 665)) (PUT (QUOTE CDDADR) (QUOTE ENTRYPOINT) (QUOTE CDDADR)) (PUT (QUOTE CDDADR) (QUOTE IDNUMBER) (QUOTE 227)) (PUT (QUOTE PUTC) (QUOTE ENTRYPOINT) (QUOTE PUTC)) (PUT (QUOTE PUTC) (QUOTE IDNUMBER) (QUOTE 373)) (PUT (QUOTE DELASC) (QUOTE ENTRYPOINT) (QUOTE DELASC)) (PUT (QUOTE DELASC) (QUOTE IDNUMBER) (QUOTE 347)) (PUT (QUOTE FOREACH) (QUOTE ENTRYPOINT) (QUOTE "L3070")) (PUT (QUOTE FOREACH) (QUOTE IDNUMBER) (QUOTE 735)) (PUT (QUOTE MARKFROMSYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1214")) (PUT (QUOTE SYMNAM) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMNAM) (QUOTE ASMSYMBOL) (QUOTE SYMNAM)) (PUT (QUOTE SYMNAM) (QUOTE WARRAY) (QUOTE SYMNAM)) (PUT (QUOTE MAPOBL) (QUOTE ENTRYPOINT) (QUOTE MAPOBL)) (PUT (QUOTE MAPOBL) (QUOTE IDNUMBER) (QUOTE 786)) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE ENTRYPOINT) (QUOTE "L1881")) (PUT (QUOTE COMPILEDCALLINGINTERPRETED) (QUOTE IDNUMBER) (QUOTE 512)) (PUT (QUOTE MM) (QUOTE ENTRYPOINT) (QUOTE MM)) (PUT (QUOTE MM) (QUOTE IDNUMBER) (QUOTE 589)) (PUT (QUOTE FLOATINTARG) (QUOTE ENTRYPOINT) (QUOTE "L1565")) (PUT (QUOTE MKEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1184")) (PUT (QUOTE MKEVECTOR) (QUOTE IDNUMBER) (QUOTE 412)) (PUT (QUOTE MAKEBUFINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2420")) (PUT (QUOTE DELASCIP) (QUOTE ENTRYPOINT) (QUOTE "L0957")) (PUT (QUOTE DELASCIP) (QUOTE IDNUMBER) (QUOTE 348)) (PUT (QUOTE ZEROP) (QUOTE ENTRYPOINT) (QUOTE ZEROP)) (PUT (QUOTE ZEROP) (QUOTE IDNUMBER) (QUOTE 284)) (PUT (QUOTE RPLACA) (QUOTE ENTRYPOINT) (QUOTE RPLACA)) (PUT (QUOTE RPLACA) (QUOTE IDNUMBER) (QUOTE 197)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE IDNUMBER) (QUOTE 816)) (PUT (QUOTE TOPLOOPLEVEL!*) (QUOTE INITIALVALUE) (QUOTE -1)) (PUT (QUOTE FLOATGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1511")) (PUT (QUOTE GLOBALREMOVE) (QUOTE ENTRYPOINT) (QUOTE "L3486")) (PUT (QUOTE GLOBALREMOVE) (QUOTE IDNUMBER) (QUOTE 789)) (PUT (QUOTE NTHENTRY) (QUOTE ENTRYPOINT) (QUOTE "L3627")) (PUT (QUOTE SUB1) (QUOTE ENTRYPOINT) (QUOTE SUB1)) (PUT (QUOTE SUB1) (QUOTE IDNUMBER) (QUOTE 357)) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2390")) (PUT (QUOTE CHANNELREADVECTOR) (QUOTE IDNUMBER) (QUOTE 645)) (PUT (QUOTE GCERROR) (QUOTE ENTRYPOINT) (QUOTE "L1281")) (PUT (QUOTE MAXREALREGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXREALREGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXREALREGS) (QUOTE WCONST) (QUOTE 5)) (PUT (QUOTE DELASCIP1) (QUOTE ENTRYPOINT) (QUOTE "L0950")) (PUT (QUOTE SET) (QUOTE ENTRYPOINT) (QUOTE SET)) (PUT (QUOTE SET) (QUOTE IDNUMBER) (QUOTE 270)) (PUT (QUOTE IN!*) (QUOTE IDNUMBER) (QUOTE 599)) (PUT (QUOTE IN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE INTLSHIFT) (QUOTE ENTRYPOINT) (QUOTE "L1502")) (PUT (QUOTE CONS) (QUOTE ENTRYPOINT) (QUOTE CONS)) (PUT (QUOTE CONS) (QUOTE IDNUMBER) (QUOTE 151)) (PUT (QUOTE CAAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAAR)) (PUT (QUOTE CAAAAR) (QUOTE IDNUMBER) (QUOTE 207)) (PUT (QUOTE MAPC2) (QUOTE ENTRYPOINT) (QUOTE MAPC2)) (PUT (QUOTE MAPC2) (QUOTE IDNUMBER) (QUOTE 362)) (PUT (QUOTE ANS) (QUOTE ENTRYPOINT) (QUOTE ANS)) (PUT (QUOTE ANS) (QUOTE IDNUMBER) (QUOTE 830)) (PUT (QUOTE HIST) (QUOTE ENTRYPOINT) (QUOTE HIST)) (PUT (QUOTE HIST) (QUOTE IDNUMBER) (QUOTE 831)) (PUT (QUOTE EVALINITFORMS) (QUOTE ENTRYPOINT) (QUOTE "L3658")) (PUT (QUOTE EVALINITFORMS) (QUOTE IDNUMBER) (QUOTE 837)) (PUT (QUOTE EDITORPRINTER!*) (QUOTE IDNUMBER) (QUOTE 447)) (FLAG (QUOTE (EDITORPRINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LOOKUPORADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3412")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1091")) (PUT (QUOTE HEAPLOWERBOUND) (QUOTE WVAR) (QUOTE HEAPLOWERBOUND)) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE ENTRYPOINT) (QUOTE "L2781")) (PUT (QUOTE CHANNELWRITEBYTES) (QUOTE IDNUMBER) (QUOTE 690)) (PUT (QUOTE EXPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2900")) (PUT (QUOTE EXPLODE) (QUOTE IDNUMBER) (QUOTE 697)) (PUT (QUOTE GTSTR) (QUOTE ENTRYPOINT) (QUOTE GTSTR)) (PUT (QUOTE GTSTR) (QUOTE IDNUMBER) (QUOTE 145)) (PUT (QUOTE SPECIAL) (QUOTE IDNUMBER) (QUOTE 609)) (PUT (QUOTE RCREF) (QUOTE IDNUMBER) (QUOTE 582)) (PUT (QUOTE EVRELOAD) (QUOTE ENTRYPOINT) (QUOTE "L2197")) (PUT (QUOTE EVRELOAD) (QUOTE IDNUMBER) (QUOTE 569)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE IDNUMBER) (QUOTE 460)) (PUT (QUOTE INTERPRETERFUNCTIONS!*) (QUOTE INITIALVALUE) (QUOTE (COND PROG AND OR PROGN SETQ))) (PUT (QUOTE TOKTYPE!*) (QUOTE IDNUMBER) (QUOTE 633)) (FLAG (QUOTE (TOKTYPE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INTSUB1) (QUOTE ENTRYPOINT) (QUOTE "L1530")) (PUT (QUOTE MIN) (QUOTE ENTRYPOINT) (QUOTE MIN)) (PUT (QUOTE MIN) (QUOTE IDNUMBER) (QUOTE 291)) (PUT (QUOTE INP) (QUOTE ENTRYPOINT) (QUOTE INP)) (PUT (QUOTE INP) (QUOTE IDNUMBER) (QUOTE 828)) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2724")) (PUT (QUOTE CHANNELWRITEEVECTOR) (QUOTE IDNUMBER) (QUOTE 684)) (PUT (QUOTE CHANNELPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2352")) (PUT (QUOTE CHANNELPOSN) (QUOTE IDNUMBER) (QUOTE 370)) (PUT (QUOTE RDS) (QUOTE ENTRYPOINT) (QUOTE RDS)) (PUT (QUOTE RDS) (QUOTE IDNUMBER) (QUOTE 475)) (PUT (QUOTE GTHEAP) (QUOTE ENTRYPOINT) (QUOTE GTHEAP)) (PUT (QUOTE GTHEAP) (QUOTE IDNUMBER) (QUOTE 387)) (PUT (QUOTE CDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDR)) (PUT (QUOTE CDDDR) (QUOTE IDNUMBER) (QUOTE 229)) (PUT (QUOTE FEXPR) (QUOTE IDNUMBER) (QUOTE 262)) (PUT (QUOTE FLAGP) (QUOTE ENTRYPOINT) (QUOTE FLAGP)) (PUT (QUOTE FLAGP) (QUOTE IDNUMBER) (QUOTE 757)) (PUT (QUOTE CODEAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1855")) (PUT (QUOTE CODEAPPLY) (QUOTE IDNUMBER) (QUOTE 508)) (PUT (QUOTE QUOTE) (QUOTE ENTRYPOINT) (QUOTE QUOTE)) (PUT (QUOTE QUOTE) (QUOTE IDNUMBER) (QUOTE 254)) (PUT (QUOTE REMAINDER) (QUOTE ENTRYPOINT) (QUOTE "L1469")) (PUT (QUOTE REMAINDER) (QUOTE IDNUMBER) (QUOTE 285)) (PUT (QUOTE !*VERBOSELOAD) (QUOTE IDNUMBER) (QUOTE 564)) (FLAG (QUOTE (!*VERBOSELOAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1131")) (PUT (QUOTE COPYSTRINGTOFROM) (QUOTE IDNUMBER) (QUOTE 403)) (PUT (QUOTE ID2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0036")) (PUT (QUOTE ID2STRING) (QUOTE IDNUMBER) (QUOTE 140)) (PUT (QUOTE REDO) (QUOTE ENTRYPOINT) (QUOTE REDO)) (PUT (QUOTE REDO) (QUOTE IDNUMBER) (QUOTE 829)) (PUT (QUOTE ERRPRIN) (QUOTE ENTRYPOINT) (QUOTE "L2890")) (PUT (QUOTE ERRPRIN) (QUOTE IDNUMBER) (QUOTE 694)) (PUT (QUOTE HEAPLAST) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPLAST) (QUOTE ASMSYMBOL) (QUOTE "L1090")) (PUT (QUOTE HEAPLAST) (QUOTE WVAR) (QUOTE HEAPLAST)) (PUT (QUOTE NEXTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1116")) (PUT (QUOTE NEXTBPS) (QUOTE WVAR) (QUOTE NEXTBPS)) (PUT (QUOTE ERRORPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2879")) (PUT (QUOTE ERRORPRINTF) (QUOTE IDNUMBER) (QUOTE 419)) (PUT (QUOTE !*VERBOSE) (QUOTE IDNUMBER) (QUOTE 439)) (FLAG (QUOTE (!*VERBOSE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CLEARBINDINGS) (QUOTE ENTRYPOINT) (QUOTE "L3356")) (PUT (QUOTE CLEARBINDINGS) (QUOTE IDNUMBER) (QUOTE 780)) (PUT (QUOTE EUPBV) (QUOTE ENTRYPOINT) (QUOTE EUPBV)) (PUT (QUOTE EUPBV) (QUOTE IDNUMBER) (QUOTE 163)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1092")) (PUT (QUOTE HEAPUPPERBOUND) (QUOTE WVAR) (QUOTE HEAPUPPERBOUND)) (PUT (QUOTE NEWBITTABLEENTRY!*) (QUOTE IDNUMBER) (QUOTE 554)) (PUT (QUOTE SYMPRP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMPRP) (QUOTE ASMSYMBOL) (QUOTE SYMPRP)) (PUT (QUOTE SYMPRP) (QUOTE WARRAY) (QUOTE SYMPRP)) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2577")) (PUT (QUOTE CHANNELWRITESTRING) (QUOTE IDNUMBER) (QUOTE 659)) (PUT (QUOTE SAFECAR) (QUOTE ENTRYPOINT) (QUOTE "L0607")) (PUT (QUOTE SAFECAR) (QUOTE IDNUMBER) (QUOTE 235)) (PUT (QUOTE GETV) (QUOTE ENTRYPOINT) (QUOTE GETV)) (PUT (QUOTE GETV) (QUOTE IDNUMBER) (QUOTE 154)) (PUT (QUOTE CDDR) (QUOTE ENTRYPOINT) (QUOTE CDDR)) (PUT (QUOTE CDDR) (QUOTE IDNUMBER) (QUOTE 234)) (PUT (QUOTE !*INSIDESTRUCTUREREAD) (QUOTE IDNUMBER) (QUOTE 639)) (FLAG (QUOTE (!*INSIDESTRUCTUREREAD)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLOATLESSP) (QUOTE ENTRYPOINT) (QUOTE "L1516")) (PUT (QUOTE MARKFROMALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1206")) (PUT (QUOTE CL) (QUOTE IDNUMBER) (QUOTE 450)) (FLAG (QUOTE (CL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MACROP) (QUOTE ENTRYPOINT) (QUOTE MACROP)) (PUT (QUOTE MACROP) (QUOTE IDNUMBER) (QUOTE 327)) (PUT (QUOTE CONTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2929")) (PUT (QUOTE CONTERROR) (QUOTE IDNUMBER) (QUOTE 714)) (PUT (QUOTE FLOATONEP) (QUOTE ENTRYPOINT) (QUOTE "L1576")) (PUT (QUOTE ONEP) (QUOTE ENTRYPOINT) (QUOTE ONEP)) (PUT (QUOTE ONEP) (QUOTE IDNUMBER) (QUOTE 432)) (PUT (QUOTE LOAD) (QUOTE ENTRYPOINT) (QUOTE LOAD)) (PUT (QUOTE LOAD) (QUOTE IDNUMBER) (QUOTE 566)) (PUT (QUOTE CDAADR) (QUOTE ENTRYPOINT) (QUOTE CDAADR)) (PUT (QUOTE CDAADR) (QUOTE IDNUMBER) (QUOTE 221)) (PUT (QUOTE VECTOR) (QUOTE ENTRYPOINT) (QUOTE VECTOR)) (PUT (QUOTE VECTOR) (QUOTE IDNUMBER) (QUOTE 186)) (PUT (QUOTE GTHEAP1) (QUOTE ENTRYPOINT) (QUOTE "L1097")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1104")) (PUT (QUOTE GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 391)) (PUT (QUOTE CODEEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1862")) (PUT (QUOTE CODEEVALAPPLY) (QUOTE IDNUMBER) (QUOTE 509)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE IDNUMBER) (QUOTE 562)) (PUT (QUOTE LOADDIRECTORIES!*) (QUOTE INITIALVALUE) (QUOTE ("" "pl:"))) (PUT (QUOTE WRITENUMBER1) (QUOTE ENTRYPOINT) (QUOTE "L2588")) (PUT (QUOTE EQSTR) (QUOTE ENTRYPOINT) (QUOTE EQSTR)) (PUT (QUOTE EQSTR) (QUOTE IDNUMBER) (QUOTE 205)) (PUT (QUOTE MEMQ) (QUOTE ENTRYPOINT) (QUOTE MEMQ)) (PUT (QUOTE MEMQ) (QUOTE IDNUMBER) (QUOTE 311)) (PUT (QUOTE THIRD) (QUOTE ENTRYPOINT) (QUOTE THIRD)) (PUT (QUOTE THIRD) (QUOTE IDNUMBER) (QUOTE 334)) (PUT (QUOTE SETF) (QUOTE ENTRYPOINT) (QUOTE SETF)) (PUT (QUOTE SETF) (QUOTE IDNUMBER) (QUOTE 719)) (PUT (QUOTE QEDNTH) (QUOTE ENTRYPOINT) (QUOTE QEDNTH)) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2132")) (PUT (QUOTE EXTRAREGLOCATION) (QUOTE IDNUMBER) (QUOTE 557)) (PUT (QUOTE PRIN2) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRIN2) (QUOTE IDNUMBER) (QUOTE 691)) (PUT (QUOTE LASTPAIR) (QUOTE ENTRYPOINT) (QUOTE "L1000")) (PUT (QUOTE LASTPAIR) (QUOTE IDNUMBER) (QUOTE 354)) (PUT (QUOTE ERRORSET) (QUOTE ENTRYPOINT) (QUOTE "L1831")) (PUT (QUOTE ERRORSET) (QUOTE IDNUMBER) (QUOTE 478)) (PUT (QUOTE COMPILER) (QUOTE IDNUMBER) (QUOTE 584)) (PUT (QUOTE UPDATEREGION) (QUOTE ENTRYPOINT) (QUOTE "L1291")) (PUT (QUOTE VECTOR2LIST) (QUOTE ENTRYPOINT) (QUOTE "L0083")) (PUT (QUOTE VECTOR2LIST) (QUOTE IDNUMBER) (QUOTE 153)) (PUT (QUOTE PUTV) (QUOTE ENTRYPOINT) (QUOTE PUTV)) (PUT (QUOTE PUTV) (QUOTE IDNUMBER) (QUOTE 158)) (PUT (QUOTE YESP) (QUOTE ENTRYPOINT) (QUOTE YESP)) (PUT (QUOTE YESP) (QUOTE IDNUMBER) (QUOTE 442)) (PUT (QUOTE NCONC) (QUOTE ENTRYPOINT) (QUOTE NCONC)) (PUT (QUOTE NCONC) (QUOTE IDNUMBER) (QUOTE 299)) (PUT (QUOTE IGNORE) (QUOTE IDNUMBER) (QUOTE 827)) (PUT (QUOTE RETURNADDRESSP) (QUOTE ENTRYPOINT) (QUOTE "L2098")) (PUT (QUOTE RETURNADDRESSP) (QUOTE IDNUMBER) (QUOTE 464)) (PUT (QUOTE GTCONSTSTR) (QUOTE ENTRYPOINT) (QUOTE "L1111")) (PUT (QUOTE GTCONSTSTR) (QUOTE IDNUMBER) (QUOTE 394)) (PUT (QUOTE HELP) (QUOTE ENTRYPOINT) (QUOTE HELP)) (PUT (QUOTE HELP) (QUOTE IDNUMBER) (QUOTE 451)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE IDNUMBER) (QUOTE 657)) (PUT (QUOTE OUTPUTBASE!*) (QUOTE INITIALVALUE) (QUOTE 10)) (PUT (QUOTE LOADTIME) (QUOTE ENTRYPOINT) (QUOTE "L2922")) (PUT (QUOTE LOADTIME) (QUOTE IDNUMBER) (QUOTE 712)) (PUT (QUOTE ID2INT) (QUOTE ENTRYPOINT) (QUOTE ID2INT)) (PUT (QUOTE ID2INT) (QUOTE IDNUMBER) (QUOTE 129)) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE ENTRYPOINT) (QUOTE "L2453")) (PUT (QUOTE CHANNELREADTOKEN) (QUOTE IDNUMBER) (QUOTE 632)) (PUT (QUOTE THROWAUX) (QUOTE ENTRYPOINT) (QUOTE "L2052")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1093")) (PUT (QUOTE HEAPTRAPBOUND) (QUOTE WVAR) (QUOTE HEAPTRAPBOUND)) (PUT (QUOTE DFPRINT!*) (QUOTE IDNUMBER) (QUOTE 826)) (FLAG (QUOTE (DFPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !%THROW) (QUOTE ENTRYPOINT) (QUOTE !%THROW)) (PUT (QUOTE !%THROW) (QUOTE IDNUMBER) (QUOTE 532)) (PUT (QUOTE SYS2INT) (QUOTE ENTRYPOINT) (QUOTE "L0031")) (PUT (QUOTE SYS2INT) (QUOTE IDNUMBER) (QUOTE 138)) (PUT (QUOTE RATOM) (QUOTE ENTRYPOINT) (QUOTE RATOM)) (PUT (QUOTE RATOM) (QUOTE IDNUMBER) (QUOTE 654)) (PUT (QUOTE !*RAISE) (QUOTE IDNUMBER) (QUOTE 626)) (PUT (QUOTE !*RAISE) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE NEXPRP) (QUOTE ENTRYPOINT) (QUOTE NEXPRP)) (PUT (QUOTE NEXPRP) (QUOTE IDNUMBER) (QUOTE 329)) (PUT (QUOTE MKFLAGVAR) (QUOTE ENTRYPOINT) (QUOTE "L2985")) (PUT (QUOTE MKFLAGVAR) (QUOTE IDNUMBER) (QUOTE 724)) (PUT (QUOTE PROMPTSTRING!*) (QUOTE IDNUMBER) (QUOTE 443)) (FLAG (QUOTE (PROMPTSTRING!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE STRINGEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0487")) (PUT (QUOTE STRINGEQUAL) (QUOTE IDNUMBER) (QUOTE 204)) (PUT (QUOTE NE) (QUOTE ENTRYPOINT) (QUOTE NE)) (PUT (QUOTE NE) (QUOTE IDNUMBER) (QUOTE 321)) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2887")) (PUT (QUOTE TOSTRINGWRITECHAR) (QUOTE IDNUMBER) (QUOTE 593)) (PUT (QUOTE CLOSE) (QUOTE ENTRYPOINT) (QUOTE CLOSE)) (PUT (QUOTE CLOSE) (QUOTE IDNUMBER) (QUOTE 612)) (PUT (QUOTE BREAKVALUE!*) (QUOTE IDNUMBER) (QUOTE 796)) (FLAG (QUOTE (BREAKVALUE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FINDIDNUMBER) (QUOTE IDNUMBER) (QUOTE 555)) (PUT (QUOTE BREAKEDIT) (QUOTE ENTRYPOINT) (QUOTE "L3586")) (PUT (QUOTE BREAKEDIT) (QUOTE IDNUMBER) (QUOTE 815)) (PUT (QUOTE TIMES) (QUOTE ENTRYPOINT) (QUOTE TIMES)) (PUT (QUOTE TIMES) (QUOTE IDNUMBER) (QUOTE 294)) (PUT (QUOTE LEQ) (QUOTE ENTRYPOINT) (QUOTE LEQ)) (PUT (QUOTE LEQ) (QUOTE IDNUMBER) (QUOTE 323)) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE ENTRYPOINT) (QUOTE "L2383")) (PUT (QUOTE CHANNELREADRIGHTPAREN) (QUOTE IDNUMBER) (QUOTE 644)) (PUT (QUOTE FLOATMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1548")) (PUT (QUOTE EXEC) (QUOTE ENTRYPOINT) (QUOTE EXEC)) (PUT (QUOTE EXEC) (QUOTE IDNUMBER) (QUOTE 588)) (PUT (QUOTE DELQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0913")) (PUT (QUOTE EMODE) (QUOTE ENTRYPOINT) (QUOTE EMODE)) (PUT (QUOTE EMODE) (QUOTE IDNUMBER) (QUOTE 580)) (PUT (QUOTE READLINE) (QUOTE ENTRYPOINT) (QUOTE "L2564")) (PUT (QUOTE READLINE) (QUOTE IDNUMBER) (QUOTE 655)) (PUT (QUOTE INTMINUS) (QUOTE ENTRYPOINT) (QUOTE "L1547")) (PUT (QUOTE DEFNPRINT1) (QUOTE ENTRYPOINT) (QUOTE "L3620")) (PUT (QUOTE GTHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1112")) (PUT (QUOTE GTHALFWORDS) (QUOTE IDNUMBER) (QUOTE 171)) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2696")) (PUT (QUOTE CHANNELWRITEVECTOR) (QUOTE IDNUMBER) (QUOTE 682)) (PUT (QUOTE EVECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0111")) (PUT (QUOTE EVECTORP) (QUOTE IDNUMBER) (QUOTE 160)) (PUT (QUOTE !$EOL!$) (QUOTE IDNUMBER) (QUOTE 596)) (PUT (QUOTE !$EOL!$) (QUOTE INITIALVALUE) (QUOTE ! )) (PUT (QUOTE OBJECT!-GET!-HANDLER!-QUIETLY) (QUOTE IDNUMBER) (QUOTE 685)) (PUT (QUOTE CAADR) (QUOTE ENTRYPOINT) (QUOTE CAADR)) (PUT (QUOTE CAADR) (QUOTE IDNUMBER) (QUOTE 211)) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2654")) (PUT (QUOTE CHANNELWRITEPAIR) (QUOTE IDNUMBER) (QUOTE 676)) (PUT (QUOTE !*LOWER) (QUOTE IDNUMBER) (QUOTE 573)) (FLAG (QUOTE (!*LOWER)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DUMPLISP) (QUOTE ENTRYPOINT) (QUOTE "L2111")) (PUT (QUOTE DUMPLISP) (QUOTE IDNUMBER) (QUOTE 548)) (PUT (QUOTE EVAND) (QUOTE ENTRYPOINT) (QUOTE EVAND)) (PUT (QUOTE EVAND) (QUOTE IDNUMBER) (QUOTE 275)) (PUT (QUOTE ASSIGN!-OP) (QUOTE IDNUMBER) (QUOTE 722)) (PUT (QUOTE PLUS) (QUOTE ENTRYPOINT) (QUOTE PLUS)) (PUT (QUOTE PLUS) (QUOTE IDNUMBER) (QUOTE 293)) (PUT (QUOTE !*ECHO) (QUOTE IDNUMBER) (QUOTE 792)) (FLAG (QUOTE (!*ECHO)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MINUS) (QUOTE ENTRYPOINT) (QUOTE MINUS)) (PUT (QUOTE MINUS) (QUOTE IDNUMBER) (QUOTE 282)) (PUT (QUOTE LIST5) (QUOTE ENTRYPOINT) (QUOTE LIST5)) (PUT (QUOTE LIST5) (QUOTE IDNUMBER) (QUOTE 414)) (PUT (QUOTE !$UNWIND!-PROTECT!$) (QUOTE IDNUMBER) (QUOTE 530)) (PUT (QUOTE COMPRESS) (QUOTE ENTRYPOINT) (QUOTE "L2915")) (PUT (QUOTE COMPRESS) (QUOTE IDNUMBER) (QUOTE 703)) (PUT (QUOTE MAPCON) (QUOTE ENTRYPOINT) (QUOTE MAPCON)) (PUT (QUOTE MAPCON) (QUOTE IDNUMBER) (QUOTE 300)) (PUT (QUOTE MAPCAR) (QUOTE ENTRYPOINT) (QUOTE MAPCAR)) (PUT (QUOTE MAPCAR) (QUOTE IDNUMBER) (QUOTE 301)) (PUT (QUOTE STDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1737")) (PUT (QUOTE STDERROR) (QUOTE IDNUMBER) (QUOTE 156)) (PUT (QUOTE SUBLIS) (QUOTE ENTRYPOINT) (QUOTE SUBLIS)) (PUT (QUOTE SUBLIS) (QUOTE IDNUMBER) (QUOTE 306)) (PUT (QUOTE MAKEBUFINTOID) (QUOTE ENTRYPOINT) (QUOTE "L2411")) (PUT (QUOTE TOPLOOPNAME!*) (QUOTE IDNUMBER) (QUOTE 800)) (FLAG (QUOTE (TOPLOOPNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKNAME!*) (QUOTE IDNUMBER) (QUOTE 803)) (FLAG (QUOTE (BREAKNAME!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3566")) (PUT (QUOTE BREAKEVAL) (QUOTE IDNUMBER) (QUOTE 808)) (PUT (QUOTE PROG) (QUOTE ENTRYPOINT) (QUOTE PROG)) (PUT (QUOTE PROG) (QUOTE IDNUMBER) (QUOTE 541)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE IDNUMBER) (QUOTE 630)) (PUT (QUOTE CURRENTREADMACROINDICATOR!*) (QUOTE INITIALVALUE) (QUOTE LISPREADMACRO)) (PUT (QUOTE CDAR) (QUOTE ENTRYPOINT) (QUOTE CDAR)) (PUT (QUOTE CDAR) (QUOTE IDNUMBER) (QUOTE 233)) (PUT (QUOTE CHANNELWRITEID) (QUOTE ENTRYPOINT) (QUOTE "L2608")) (PUT (QUOTE CHANNELWRITEID) (QUOTE IDNUMBER) (QUOTE 670)) (PUT (QUOTE CADDDR) (QUOTE ENTRYPOINT) (QUOTE CADDDR)) (PUT (QUOTE CADDDR) (QUOTE IDNUMBER) (QUOTE 218)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE JFNOFCHANNEL) (QUOTE ASMSYMBOL) (QUOTE "L2282")) (PUT (QUOTE JFNOFCHANNEL) (QUOTE WARRAY) (QUOTE JFNOFCHANNEL)) (PUT (QUOTE CHANNELLPOSN) (QUOTE ENTRYPOINT) (QUOTE "L2353")) (PUT (QUOTE CHANNELLPOSN) (QUOTE IDNUMBER) (QUOTE 623)) (PUT (QUOTE STRINGGENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3051")) (PUT (QUOTE GTFLTN) (QUOTE ENTRYPOINT) (QUOTE GTFLTN)) (PUT (QUOTE GTFLTN) (QUOTE IDNUMBER) (QUOTE 397)) (PUT (QUOTE CDDAAR) (QUOTE ENTRYPOINT) (QUOTE CDDAAR)) (PUT (QUOTE CDDAAR) (QUOTE IDNUMBER) (QUOTE 225)) (PUT (QUOTE FLOAT) (QUOTE ENTRYPOINT) (QUOTE FLOAT)) (PUT (QUOTE FLOAT) (QUOTE IDNUMBER) (QUOTE 431)) (PUT (QUOTE MAXSYMBOLS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXSYMBOLS) (QUOTE WCONST) (QUOTE 8000)) (PUT (QUOTE FLOATZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1467")) (PUT (QUOTE INDX) (QUOTE ENTRYPOINT) (QUOTE INDX)) (PUT (QUOTE INDX) (QUOTE IDNUMBER) (QUOTE 164)) (PUT (QUOTE !*LAMBDALINK) (QUOTE IDNUMBER) (QUOTE 515)) (PUT (QUOTE INTZEROP) (QUOTE ENTRYPOINT) (QUOTE "L1571")) (PUT (QUOTE FLOATADD1) (QUOTE ENTRYPOINT) (QUOTE "L1521")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1798")) (PUT (QUOTE NONCHARACTERERROR) (QUOTE IDNUMBER) (QUOTE 136)) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L2597")) (PUT (QUOTE CHANNELWRITEFIXNUM) (QUOTE IDNUMBER) (QUOTE 664)) (PUT (QUOTE EPUTV) (QUOTE ENTRYPOINT) (QUOTE EPUTV)) (PUT (QUOTE EPUTV) (QUOTE IDNUMBER) (QUOTE 162)) (PUT (QUOTE DECLAREFLUIDORGLOBAL) (QUOTE ENTRYPOINT) (QUOTE "L3247")) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 636)) (PUT (QUOTE LISPSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2303")) (PUT (QUOTE UNREADCHAR) (QUOTE IDNUMBER) (QUOTE 601)) (PUT (QUOTE MAKE!-WORDS) (QUOTE ENTRYPOINT) (QUOTE "L0364")) (PUT (QUOTE MAKE!-WORDS) (QUOTE IDNUMBER) (QUOTE 183)) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2134")) (PUT (QUOTE FUNCTIONCELLLOCATION) (QUOTE IDNUMBER) (QUOTE 558)) (PUT (QUOTE SIMPFG) (QUOTE IDNUMBER) (QUOTE 725)) (PUT (QUOTE SETPROP) (QUOTE ENTRYPOINT) (QUOTE "L3179")) (PUT (QUOTE SETPROP) (QUOTE IDNUMBER) (QUOTE 756)) (PUT (QUOTE SPECIALREADFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 606)) (FLAG (QUOTE (SPECIALREADFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CHANNELPRINTF) (QUOTE ENTRYPOINT) (QUOTE "L2898")) (PUT (QUOTE CHANNELPRINTF) (QUOTE IDNUMBER) (QUOTE 695)) (PUT (QUOTE OR) (QUOTE ENTRYPOINT) (QUOTE OR)) (PUT (QUOTE OR) (QUOTE IDNUMBER) (QUOTE 276)) (PUT (QUOTE MKQUOTE) (QUOTE ENTRYPOINT) (QUOTE "L0871")) (PUT (QUOTE MKQUOTE) (QUOTE IDNUMBER) (QUOTE 242)) (PUT (QUOTE !*PRINTLOADNAMES) (QUOTE IDNUMBER) (QUOTE 565)) (FLAG (QUOTE (!*PRINTLOADNAMES)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE ERROR) (QUOTE ENTRYPOINT) (QUOTE ERROR)) (PUT (QUOTE ERROR) (QUOTE IDNUMBER) (QUOTE 472)) (PUT (QUOTE EDITORREADER!*) (QUOTE IDNUMBER) (QUOTE 446)) (FLAG (QUOTE (EDITORREADER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SETF!-EXPAND) (QUOTE IDNUMBER) (QUOTE 721)) (PUT (QUOTE SETSUB) (QUOTE ENTRYPOINT) (QUOTE SETSUB)) (PUT (QUOTE SETSUB) (QUOTE IDNUMBER) (QUOTE 174)) (PUT (QUOTE SIZE) (QUOTE ENTRYPOINT) (QUOTE SIZE)) (PUT (QUOTE SIZE) (QUOTE IDNUMBER) (QUOTE 178)) (PUT (QUOTE CHANNELREAD) (QUOTE ENTRYPOINT) (QUOTE "L2361")) (PUT (QUOTE CHANNELREAD) (QUOTE IDNUMBER) (QUOTE 635)) (PUT (QUOTE RESET) (QUOTE IDNUMBER) (QUOTE 536)) (PUT (QUOTE !&!&VALUE!&!&) (QUOTE IDNUMBER) (QUOTE 525)) (PUT (QUOTE REMPROP) (QUOTE ENTRYPOINT) (QUOTE "L3236")) (PUT (QUOTE REMPROP) (QUOTE IDNUMBER) (QUOTE 763)) (PUT (QUOTE CHANNELSPACES) (QUOTE ENTRYPOINT) (QUOTE "L1046")) (PUT (QUOTE CHANNELSPACES) (QUOTE IDNUMBER) (QUOTE 366)) (PUT (QUOTE PRINTF2) (QUOTE ENTRYPOINT) (QUOTE "L2850")) (PUT (QUOTE INITOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3490")) (PUT (QUOTE INITOBLIST) (QUOTE IDNUMBER) (QUOTE 790)) (PUT (QUOTE LOSE) (QUOTE IDNUMBER) (QUOTE 777)) (PUT (QUOTE BINDEVAL) (QUOTE ENTRYPOINT) (QUOTE "L1870")) (PUT (QUOTE BINDEVAL) (QUOTE IDNUMBER) (QUOTE 510)) (PUT (QUOTE LISPEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0449")) (PUT (QUOTE LISPEQUAL) (QUOTE IDNUMBER) (QUOTE 203)) (PUT (QUOTE CLEARIO1) (QUOTE ENTRYPOINT) (QUOTE "L3503")) (PUT (QUOTE UNION) (QUOTE ENTRYPOINT) (QUOTE UNION)) (PUT (QUOTE UNION) (QUOTE IDNUMBER) (QUOTE 380)) (PUT (QUOTE DELQIP) (QUOTE ENTRYPOINT) (QUOTE DELQIP)) (PUT (QUOTE DELQIP) (QUOTE IDNUMBER) (QUOTE 342)) (PUT (QUOTE CHANNELTAB) (QUOTE ENTRYPOINT) (QUOTE "L1050")) (PUT (QUOTE CHANNELTAB) (QUOTE IDNUMBER) (QUOTE 369)) (PUT (QUOTE BIGFLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1421")) (PUT (QUOTE INTLNOT) (QUOTE ENTRYPOINT) (QUOTE "L1540")) (PUT (QUOTE DSKINDEFNPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3681")) (PUT (QUOTE MAX) (QUOTE ENTRYPOINT) (QUOTE MAX)) (PUT (QUOTE MAX) (QUOTE IDNUMBER) (QUOTE 287)) (PUT (QUOTE INSTANTIATEINFORM) (QUOTE ENTRYPOINT) (QUOTE "L2991")) (PUT (QUOTE COPYWRDS) (QUOTE ENTRYPOINT) (QUOTE "L1147")) (PUT (QUOTE COPYWRDS) (QUOTE IDNUMBER) (QUOTE 409)) (PUT (QUOTE CLEARIO) (QUOTE ENTRYPOINT) (QUOTE "L3504")) (PUT (QUOTE CLEARIO) (QUOTE IDNUMBER) (QUOTE 793)) (PUT (QUOTE BUILDRELOCATIONFIELDS) (QUOTE ENTRYPOINT) (QUOTE "L1208")) (PUT (QUOTE HARDCONS) (QUOTE ENTRYPOINT) (QUOTE "L1163")) (PUT (QUOTE CHANNELPRINT) (QUOTE ENTRYPOINT) (QUOTE "L0822")) (PUT (QUOTE CHANNELPRINT) (QUOTE IDNUMBER) (QUOTE 315)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE IDNUMBER) (QUOTE 563)) (PUT (QUOTE LOADEXTENSIONS!*) (QUOTE INITIALVALUE) (QUOTE ((".b" . FASLIN) ( ".lap" . LAPIN) (".sl" . LAPIN)))) (PUT (QUOTE GTBPS) (QUOTE ENTRYPOINT) (QUOTE GTBPS)) (PUT (QUOTE GTBPS) (QUOTE IDNUMBER) (QUOTE 395)) (PUT (QUOTE UPDATEITEM) (QUOTE ENTRYPOINT) (QUOTE "L1295")) (PUT (QUOTE SAVESYSTEM) (QUOTE ENTRYPOINT) (QUOTE "L3656")) (PUT (QUOTE SAVESYSTEM) (QUOTE IDNUMBER) (QUOTE 835)) (PUT (QUOTE CADDR) (QUOTE ENTRYPOINT) (QUOTE CADDR)) (PUT (QUOTE CADDR) (QUOTE IDNUMBER) (QUOTE 217)) (PUT (QUOTE FEXPRP) (QUOTE ENTRYPOINT) (QUOTE FEXPRP)) (PUT (QUOTE FEXPRP) (QUOTE IDNUMBER) (QUOTE 328)) (PUT (QUOTE CHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2357")) (PUT (QUOTE CHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 364)) (PUT (QUOTE THROW) (QUOTE ENTRYPOINT) (QUOTE THROW)) (PUT (QUOTE THROW) (QUOTE IDNUMBER) (QUOTE 495)) (PUT (QUOTE FIX) (QUOTE ENTRYPOINT) (QUOTE FIX)) (PUT (QUOTE FIX) (QUOTE IDNUMBER) (QUOTE 430)) (PUT (QUOTE VECTORP) (QUOTE ENTRYPOINT) (QUOTE "L0395")) (PUT (QUOTE VECTORP) (QUOTE IDNUMBER) (QUOTE 194)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE IDNUMBER) (QUOTE 418)) (PUT (QUOTE HEAP!-WARN!-LEVEL) (QUOTE INITIALVALUE) (QUOTE 1000)) (PUT (QUOTE TCONC) (QUOTE ENTRYPOINT) (QUOTE TCONC)) (PUT (QUOTE TCONC) (QUOTE IDNUMBER) (QUOTE 173)) (PUT (QUOTE DELWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1128")) (PUT (QUOTE DELWARRAY) (QUOTE IDNUMBER) (QUOTE 402)) (PUT (QUOTE !*QUITBREAK) (QUOTE IDNUMBER) (QUOTE 797)) (FLAG (QUOTE (!*QUITBREAK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODEP) (QUOTE ENTRYPOINT) (QUOTE CODEP)) (PUT (QUOTE CODEP) (QUOTE IDNUMBER) (QUOTE 187)) (PUT (QUOTE CONST) (QUOTE ENTRYPOINT) (QUOTE CONST)) (PUT (QUOTE CONST) (QUOTE IDNUMBER) (QUOTE 732)) (PUT (QUOTE FLUID) (QUOTE ENTRYPOINT) (QUOTE FLUID)) (PUT (QUOTE FLUID) (QUOTE IDNUMBER) (QUOTE 767)) (PUT (QUOTE EGETV) (QUOTE ENTRYPOINT) (QUOTE EGETV)) (PUT (QUOTE EGETV) (QUOTE IDNUMBER) (QUOTE 161)) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L1895")) (PUT (QUOTE UNDEFINEDFUNCTION) (QUOTE IDNUMBER) (QUOTE 516)) (PUT (QUOTE EQ) (QUOTE ENTRYPOINT) (QUOTE EQ)) (PUT (QUOTE EQ) (QUOTE IDNUMBER) (QUOTE 188)) (PUT (QUOTE PAIRP) (QUOTE ENTRYPOINT) (QUOTE PAIRP)) (PUT (QUOTE PAIRP) (QUOTE IDNUMBER) (QUOTE 192)) (PUT (QUOTE DS) (QUOTE ENTRYPOINT) (QUOTE DS)) (PUT (QUOTE DS) (QUOTE IDNUMBER) (QUOTE 729)) (PUT (QUOTE WORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0446")) (PUT (QUOTE INTERNGENSYM) (QUOTE ENTRYPOINT) (QUOTE "L3465")) (PUT (QUOTE INTERNGENSYM) (QUOTE IDNUMBER) (QUOTE 785)) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE ENTRYPOINT) (QUOTE "L1844")) (PUT (QUOTE ILLEGALSTANDARDCHANNELCLOSE) (QUOTE IDNUMBER) (QUOTE 506)) (PUT (QUOTE COMPRESSLIST!*) (QUOTE IDNUMBER) (QUOTE 701)) (FLAG (QUOTE (COMPRESSLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE ENTRYPOINT) (QUOTE "L1140")) (PUT (QUOTE COPYVECTORTOFROM) (QUOTE IDNUMBER) (QUOTE 406)) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2899")) (PUT (QUOTE EXPLODEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 594)) (PUT (QUOTE SPECIALWRSACTION!*) (QUOTE IDNUMBER) (QUOTE 616)) (FLAG (QUOTE (SPECIALWRSACTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE TOPLOOPPRINT!*) (QUOTE IDNUMBER) (QUOTE 804)) (FLAG (QUOTE (TOPLOOPPRINT!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CODE!-ADDRESS!-TO!-SYMBOL) (QUOTE IDNUMBER) (QUOTE 470)) (PUT (QUOTE MAPLIST) (QUOTE ENTRYPOINT) (QUOTE "L0747")) (PUT (QUOTE MAPLIST) (QUOTE IDNUMBER) (QUOTE 302)) (PUT (QUOTE CAADDR) (QUOTE ENTRYPOINT) (QUOTE CAADDR)) (PUT (QUOTE CAADDR) (QUOTE IDNUMBER) (QUOTE 212)) (PUT (QUOTE TYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1772")) (PUT (QUOTE TYPEERROR) (QUOTE IDNUMBER) (QUOTE 132)) (PUT (QUOTE DE) (QUOTE ENTRYPOINT) (QUOTE DE)) (PUT (QUOTE DE) (QUOTE IDNUMBER) (QUOTE 256)) (PUT (QUOTE !*EXPERT) (QUOTE IDNUMBER) (QUOTE 438)) (FLAG (QUOTE (!*EXPERT)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE CONC) (QUOTE IDNUMBER) (QUOTE 738)) (PUT (QUOTE CHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2814")) (PUT (QUOTE CHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 316)) (PUT (QUOTE PRINTF1) (QUOTE ENTRYPOINT) (QUOTE "L2849")) (PUT (QUOTE !*COMP) (QUOTE IDNUMBER) (QUOTE 775)) (FLAG (QUOTE (!*COMP)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMBASE) (QUOTE ENTRYPOINT) (QUOTE "L1219")) (PUT (QUOTE ABS) (QUOTE ENTRYPOINT) (QUOTE ABS)) (PUT (QUOTE ABS) (QUOTE IDNUMBER) (QUOTE 281)) (PUT (QUOTE NONWORDS) (QUOTE ENTRYPOINT) (QUOTE "L1807")) (PUT (QUOTE NONWORDS) (QUOTE IDNUMBER) (QUOTE 491)) (PUT (QUOTE OTHERWISE) (QUOTE IDNUMBER) (QUOTE 715)) (PUT (QUOTE FASLOUT) (QUOTE ENTRYPOINT) (QUOTE "L2265")) (PUT (QUOTE FASLOUT) (QUOTE IDNUMBER) (QUOTE 586)) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2765")) (PUT (QUOTE CHANNELWRITEHALFWORDS) (QUOTE IDNUMBER) (QUOTE 689)) (PUT (QUOTE SUBSEQ) (QUOTE ENTRYPOINT) (QUOTE SUBSEQ)) (PUT (QUOTE SUBSEQ) (QUOTE IDNUMBER) (QUOTE 169)) (PUT (QUOTE LSHIFT) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSHIFT) (QUOTE IDNUMBER) (QUOTE 427)) (PUT (QUOTE INDEXERROR) (QUOTE ENTRYPOINT) (QUOTE "L1780")) (PUT (QUOTE INDEXERROR) (QUOTE IDNUMBER) (QUOTE 157)) (PUT (QUOTE INITNEWID) (QUOTE ENTRYPOINT) (QUOTE "L3417")) (PUT (QUOTE MARKFROMRANGE) (QUOTE ENTRYPOINT) (QUOTE "L1215")) (PUT (QUOTE XCHANGE) (QUOTE ENTRYPOINT) (QUOTE "L1637")) (PUT (QUOTE COMPRESSERROR) (QUOTE ENTRYPOINT) (QUOTE "L2914")) (PUT (QUOTE COMPRESSERROR) (QUOTE IDNUMBER) (QUOTE 700)) (PUT (QUOTE READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2290")) (PUT (QUOTE READCHAR) (QUOTE IDNUMBER) (QUOTE 598)) (PUT (QUOTE FLOATDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1436")) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE IDNUMBER) (QUOTE 634)) (PUT (QUOTE CURRENTSCANTABLE!*) (QUOTE INITIALVALUE) (QUOTE [17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 LISPDIPHTHONG])) (PUT (QUOTE UPDATESYMBOLS) (QUOTE ENTRYPOINT) (QUOTE "L1290")) (PUT (QUOTE GCMESSAGE) (QUOTE ENTRYPOINT) (QUOTE "L1212")) (PUT (QUOTE ATOM) (QUOTE ENTRYPOINT) (QUOTE ATOM)) (PUT (QUOTE ATOM) (QUOTE IDNUMBER) (QUOTE 237)) (PUT (QUOTE CHANNELREADCH) (QUOTE ENTRYPOINT) (QUOTE "L2354")) (PUT (QUOTE CHANNELREADCH) (QUOTE IDNUMBER) (QUOTE 625)) (PUT (QUOTE PROGN) (QUOTE ENTRYPOINT) (QUOTE PROGN)) (PUT (QUOTE PROGN) (QUOTE IDNUMBER) (QUOTE 272)) (PUT (QUOTE COPYVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1143")) (PUT (QUOTE COPYVECTOR) (QUOTE IDNUMBER) (QUOTE 407)) (PUT (QUOTE MKVECT) (QUOTE ENTRYPOINT) (QUOTE MKVECT)) (PUT (QUOTE MKVECT) (QUOTE IDNUMBER) (QUOTE 411)) (PUT (QUOTE !$EOF!$) (QUOTE IDNUMBER) (QUOTE 641)) (FLAG (QUOTE (!$EOF!$)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DELQ) (QUOTE ENTRYPOINT) (QUOTE DELQ)) (PUT (QUOTE DELQ) (QUOTE IDNUMBER) (QUOTE 340)) (PUT (QUOTE NONINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1792")) (PUT (QUOTE NONINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 133)) (PUT (QUOTE BNDSTKPTR) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKPTR) (QUOTE ASMSYMBOL) (QUOTE "L1193")) (PUT (QUOTE BNDSTKPTR) (QUOTE WVAR) (QUOTE BNDSTKPTR)) (PUT (QUOTE CREFON) (QUOTE ENTRYPOINT) (QUOTE CREFON)) (PUT (QUOTE CREFON) (QUOTE IDNUMBER) (QUOTE 583)) (PUT (QUOTE FOR) (QUOTE ENTRYPOINT) (QUOTE FOR)) (PUT (QUOTE FOR) (QUOTE IDNUMBER) (QUOTE 746)) (PUT (QUOTE BIN) (QUOTE IDNUMBER) (QUOTE 750)) (PUT (QUOTE DSKINEVAL) (QUOTE ENTRYPOINT) (QUOTE "L3679")) (PUT (QUOTE DSKINEVAL) (QUOTE IDNUMBER) (QUOTE 839)) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE ENTRYPOINT) (QUOTE "L2358")) (PUT (QUOTE CHANNELREADTOKENWITHHOOKS) (QUOTE IDNUMBER) (QUOTE 631)) (PUT (QUOTE INT2CODE) (QUOTE ENTRYPOINT) (QUOTE "L0027")) (PUT (QUOTE INT2CODE) (QUOTE IDNUMBER) (QUOTE 137)) (PUT (QUOTE BREAK) (QUOTE ENTRYPOINT) (QUOTE BREAK)) (PUT (QUOTE BREAK) (QUOTE IDNUMBER) (QUOTE 452)) (PUT (QUOTE FASTAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1891")) (PUT (QUOTE FASTAPPLY) (QUOTE IDNUMBER) (QUOTE 296)) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3524")) (PUT (QUOTE SYSTEMMARKASCLOSEDCHANNEL) (QUOTE IDNUMBER) (QUOTE 613)) (PUT (QUOTE INTADD1) (QUOTE ENTRYPOINT) (QUOTE "L1520")) (PUT (QUOTE FLAG) (QUOTE ENTRYPOINT) (QUOTE FLAG)) (PUT (QUOTE FLAG) (QUOTE IDNUMBER) (QUOTE 759)) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2294")) (PUT (QUOTE CHANNELWRITECHAR) (QUOTE IDNUMBER) (QUOTE 367)) (PUT (QUOTE PRIN1) (QUOTE ENTRYPOINT) (QUOTE PRIN1)) (PUT (QUOTE PRIN1) (QUOTE IDNUMBER) (QUOTE 471)) (PUT (QUOTE IN) (QUOTE IDNUMBER) (QUOTE 739)) (PUT (QUOTE REMOB) (QUOTE ENTRYPOINT) (QUOTE REMOB)) (PUT (QUOTE REMOB) (QUOTE IDNUMBER) (QUOTE 783)) (PUT (QUOTE BREAKFUNCTION) (QUOTE IDNUMBER) (QUOTE 809)) (PUT (QUOTE HEAPTRAPPED) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPTRAPPED) (QUOTE ASMSYMBOL) (QUOTE "L1094")) (PUT (QUOTE HEAPTRAPPED) (QUOTE WVAR) (QUOTE HEAPTRAPPED)) (PUT (QUOTE !*EOLINSTRINGOK) (QUOTE IDNUMBER) (QUOTE 647)) (FLAG (QUOTE (!*EOLINSTRINGOK)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE INOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3406")) (PUT (QUOTE CDAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAR)) (PUT (QUOTE CDAAR) (QUOTE IDNUMBER) (QUOTE 220)) (PUT (QUOTE MIN2) (QUOTE ENTRYPOINT) (QUOTE MIN2)) (PUT (QUOTE MIN2) (QUOTE IDNUMBER) (QUOTE 292)) (PUT (QUOTE ASS) (QUOTE ENTRYPOINT) (QUOTE ASS)) (PUT (QUOTE ASS) (QUOTE IDNUMBER) (QUOTE 344)) (PUT (QUOTE VARTYPE) (QUOTE IDNUMBER) (QUOTE 766)) (PUT (QUOTE HISTPRINT) (QUOTE ENTRYPOINT) (QUOTE "L3638")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2302")) (PUT (QUOTE CHANNELUNREADCHAR) (QUOTE IDNUMBER) (QUOTE 600)) (PUT (QUOTE PUTD) (QUOTE ENTRYPOINT) (QUOTE PUTD)) (PUT (QUOTE PUTD) (QUOTE IDNUMBER) (QUOTE 259)) (PUT (QUOTE DF) (QUOTE ENTRYPOINT) (QUOTE DF)) (PUT (QUOTE DF) (QUOTE IDNUMBER) (QUOTE 263)) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE ENTRYPOINT) (QUOTE "L2636")) (PUT (QUOTE CHANNELWRITEUNKNOWNITEM) (QUOTE IDNUMBER) (QUOTE 469)) (PUT (QUOTE FLUID1) (QUOTE ENTRYPOINT) (QUOTE FLUID1)) (PUT (QUOTE FLUID1) (QUOTE IDNUMBER) (QUOTE 768)) (PUT (QUOTE EVDEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3045")) (PUT (QUOTE EVDEFCONST) (QUOTE IDNUMBER) (QUOTE 731)) (PUT (QUOTE CDAAAR) (QUOTE ENTRYPOINT) (QUOTE CDAAAR)) (PUT (QUOTE CDAAAR) (QUOTE IDNUMBER) (QUOTE 219)) (PUT (QUOTE COPYD) (QUOTE ENTRYPOINT) (QUOTE COPYD)) (PUT (QUOTE COPYD) (QUOTE IDNUMBER) (QUOTE 330)) (PUT (QUOTE CASE) (QUOTE ENTRYPOINT) (QUOTE CASE)) (PUT (QUOTE CASE) (QUOTE IDNUMBER) (QUOTE 717)) (PUT (QUOTE SCANNERERROR) (QUOTE ENTRYPOINT) (QUOTE "L2482")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE ENTRYPOINT) (QUOTE "L1423")) (PUT (QUOTE RETURNFIRSTARG) (QUOTE IDNUMBER) (QUOTE 423)) (PUT (QUOTE !*DEFN) (QUOTE IDNUMBER) (QUOTE 795)) (FLAG (QUOTE (!*DEFN)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LENGTH1) (QUOTE ENTRYPOINT) (QUOTE "L0427")) (PUT (QUOTE LAPIN) (QUOTE ENTRYPOINT) (QUOTE LAPIN)) (PUT (QUOTE LAPIN) (QUOTE IDNUMBER) (QUOTE 840)) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE ENTRYPOINT) (QUOTE "L0354")) (PUT (QUOTE MAKE!-HALFWORDS) (QUOTE IDNUMBER) (QUOTE 182)) (PUT (QUOTE STRINGGENSYM!*) (QUOTE IDNUMBER) (QUOTE 734)) (FLAG (QUOTE (STRINGGENSYM!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE HELPBREAK) (QUOTE ENTRYPOINT) (QUOTE "L3579")) (PUT (QUOTE HELPBREAK) (QUOTE IDNUMBER) (QUOTE 813)) (PUT (QUOTE UNMAP!-SPACE) (QUOTE ENTRYPOINT) (QUOTE "L2113")) (PUT (QUOTE !*CATCH) (QUOTE ENTRYPOINT) (QUOTE "L2035")) (PUT (QUOTE !*CATCH) (QUOTE IDNUMBER) (QUOTE 534)) (PUT (QUOTE MINUSP) (QUOTE ENTRYPOINT) (QUOTE MINUSP)) (PUT (QUOTE MINUSP) (QUOTE IDNUMBER) (QUOTE 247)) (PUT (QUOTE BPSSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPSSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE BPSSIZE) (QUOTE WCONST) (QUOTE 100000)) (PUT (QUOTE IMPLODE) (QUOTE ENTRYPOINT) (QUOTE "L2916")) (PUT (QUOTE IMPLODE) (QUOTE IDNUMBER) (QUOTE 704)) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1795")) (PUT (QUOTE NONPOSITIVEINTEGERERROR) (QUOTE IDNUMBER) (QUOTE 180)) (PUT (QUOTE FASTBIND) (QUOTE ENTRYPOINT) (QUOTE "L3367")) (PUT (QUOTE FASTBIND) (QUOTE IDNUMBER) (QUOTE 444)) (PUT (QUOTE LAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1918")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2601")) (PUT (QUOTE CHANNELWRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 668)) (PUT (QUOTE CHECKLINEFIT) (QUOTE ENTRYPOINT) (QUOTE "L2574")) (PUT (QUOTE !%UNCATCH) (QUOTE ENTRYPOINT) (QUOTE "L2047")) (PUT (QUOTE !%UNCATCH) (QUOTE IDNUMBER) (QUOTE 501)) (PUT (QUOTE NONVECTORERROR) (QUOTE ENTRYPOINT) (QUOTE "L1804")) (PUT (QUOTE NONVECTORERROR) (QUOTE IDNUMBER) (QUOTE 146)) (PUT (QUOTE CADDAR) (QUOTE ENTRYPOINT) (QUOTE CADDAR)) (PUT (QUOTE CADDAR) (QUOTE IDNUMBER) (QUOTE 216)) (PUT (QUOTE NOT) (QUOTE ENTRYPOINT) (QUOTE NOT)) (PUT (QUOTE NOT) (QUOTE IDNUMBER) (QUOTE 280)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE COMPRESSEDBINARYRADIX) (QUOTE WCONST) (QUOTE 8)) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2629")) (PUT (QUOTE CHANNELPRINTUNBOUND) (QUOTE IDNUMBER) (QUOTE 673)) (PUT (QUOTE HASHFUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L3419")) (PUT (QUOTE HASHFUNCTION) (QUOTE IDNUMBER) (QUOTE 782)) (PUT (QUOTE GREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1509")) (PUT (QUOTE GREATERP) (QUOTE IDNUMBER) (QUOTE 245)) (PUT (QUOTE EVCOND) (QUOTE ENTRYPOINT) (QUOTE EVCOND)) (PUT (QUOTE EVCOND) (QUOTE IDNUMBER) (QUOTE 279)) (PUT (QUOTE MAPC) (QUOTE ENTRYPOINT) (QUOTE MAPC)) (PUT (QUOTE MAPC) (QUOTE IDNUMBER) (QUOTE 297)) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1838")) (PUT (QUOTE WRITEONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 504)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE IDNUMBER) (QUOTE 546)) (PUT (QUOTE SYSTEM_LIST!*) (QUOTE INITIALVALUE) (QUOTE (DEC20 PDP10 TOPS20 KL10))) (PUT (QUOTE CDDDDR) (QUOTE ENTRYPOINT) (QUOTE CDDDDR)) (PUT (QUOTE CDDDDR) (QUOTE IDNUMBER) (QUOTE 230)) (PUT (QUOTE MAKESTRINGINTOBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2540")) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE IDNUMBER) (QUOTE 817)) (PUT (QUOTE HISTORYCOUNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE UPBV) (QUOTE ENTRYPOINT) (QUOTE UPBV)) (PUT (QUOTE UPBV) (QUOTE IDNUMBER) (QUOTE 159)) (PUT (QUOTE LCONC) (QUOTE ENTRYPOINT) (QUOTE LCONC)) (PUT (QUOTE LCONC) (QUOTE IDNUMBER) (QUOTE 360)) (PUT (QUOTE EDCOPY) (QUOTE ENTRYPOINT) (QUOTE EDCOPY)) (PUT (QUOTE FLOATFIX) (QUOTE ENTRYPOINT) (QUOTE "L1557")) (PUT (QUOTE USAGETYPEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1775")) (PUT (QUOTE USAGETYPEERROR) (QUOTE IDNUMBER) (QUOTE 489)) (PUT (QUOTE PBIND1) (QUOTE ENTRYPOINT) (QUOTE PBIND1)) (PUT (QUOTE PBIND1) (QUOTE IDNUMBER) (QUOTE 542)) (PUT (QUOTE CDR) (QUOTE ENTRYPOINT) (QUOTE CDR)) (PUT (QUOTE CDR) (QUOTE IDNUMBER) (QUOTE 196)) (PUT (QUOTE LIST4) (QUOTE ENTRYPOINT) (QUOTE LIST4)) (PUT (QUOTE LIST4) (QUOTE IDNUMBER) (QUOTE 258)) (PUT (QUOTE DEL) (QUOTE ENTRYPOINT) (QUOTE DEL)) (PUT (QUOTE DEL) (QUOTE IDNUMBER) (QUOTE 341)) (PUT (QUOTE MAKE!-BYTES) (QUOTE ENTRYPOINT) (QUOTE "L0343")) (PUT (QUOTE MAKE!-BYTES) (QUOTE IDNUMBER) (QUOTE 181)) (PUT (QUOTE !*GC) (QUOTE IDNUMBER) (QUOTE 415)) (PUT (QUOTE !*GC) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE FIRST) (QUOTE ENTRYPOINT) (QUOTE FIRST)) (PUT (QUOTE FIRST) (QUOTE IDNUMBER) (QUOTE 332)) (PUT (QUOTE DATE) (QUOTE ENTRYPOINT) (QUOTE DATE)) (PUT (QUOTE DATE) (QUOTE IDNUMBER) (QUOTE 547)) (PUT (QUOTE SEMIC!*) (QUOTE IDNUMBER) (QUOTE 820)) (FLAG (QUOTE (SEMIC!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DOTCONTEXTERROR) (QUOTE ENTRYPOINT) (QUOTE "L2373")) (PUT (QUOTE SYSPOWEROF2P) (QUOTE ENTRYPOINT) (QUOTE "L2538")) (PUT (QUOTE LOAD1) (QUOTE ENTRYPOINT) (QUOTE LOAD1)) (PUT (QUOTE LOAD1) (QUOTE IDNUMBER) (QUOTE 567)) (PUT (QUOTE LISP2CHAR) (QUOTE ENTRYPOINT) (QUOTE "L0023")) (PUT (QUOTE LISP2CHAR) (QUOTE IDNUMBER) (QUOTE 135)) (PUT (QUOTE MEM) (QUOTE ENTRYPOINT) (QUOTE MEM)) (PUT (QUOTE MEM) (QUOTE IDNUMBER) (QUOTE 345)) (PUT (QUOTE EHELP) (QUOTE ENTRYPOINT) (QUOTE EHELP)) (PUT (QUOTE EHELP) (QUOTE IDNUMBER) (QUOTE 453)) (PUT (QUOTE EDIT0) (QUOTE ENTRYPOINT) (QUOTE EDIT0)) (PUT (QUOTE MAXCHANNELS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXCHANNELS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXCHANNELS) (QUOTE WCONST) (QUOTE 31)) (PUT (QUOTE MAKEBUFINTOSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2415")) (PUT (QUOTE INTMINUSP) (QUOTE ENTRYPOINT) (QUOTE "L1566")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE ENTRYPOINT) (QUOTE "L3529")) (PUT (QUOTE SYSTEMOPENFILESPECIAL) (QUOTE IDNUMBER) (QUOTE 605)) (PUT (QUOTE NONSTRINGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1801")) (PUT (QUOTE NONSTRINGERROR) (QUOTE IDNUMBER) (QUOTE 143)) (PUT (QUOTE INTERPBACKTRACE) (QUOTE ENTRYPOINT) (QUOTE "L1695")) (PUT (QUOTE INTERPBACKTRACE) (QUOTE IDNUMBER) (QUOTE 461)) (PUT (QUOTE !$ERROR!$) (QUOTE IDNUMBER) (QUOTE 496)) (PUT (QUOTE INTGREATERP) (QUOTE ENTRYPOINT) (QUOTE "L1510")) (PUT (QUOTE UNMAP!-PAGES) (QUOTE ENTRYPOINT) (QUOTE "L2116")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2348")) (PUT (QUOTE CHANNELLINELENGTH) (QUOTE IDNUMBER) (QUOTE 620)) (PUT (QUOTE TOPLOOPEVAL!*) (QUOTE IDNUMBER) (QUOTE 801)) (FLAG (QUOTE (TOPLOOPEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE USER) (QUOTE IDNUMBER) (QUOTE 776)) (PUT (QUOTE MACRO) (QUOTE IDNUMBER) (QUOTE 264)) (PUT (QUOTE SCANPOSSIBLEDIPHTHONG) (QUOTE ENTRYPOINT) (QUOTE "L2476")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE ENTRYPOINT) (QUOTE "L3512")) (PUT (QUOTE TERMINALINPUTHANDLER) (QUOTE IDNUMBER) (QUOTE 590)) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE ENTRYPOINT) (QUOTE "L2367")) (PUT (QUOTE CHANNELREADQUOTEDEXPRESSION) (QUOTE IDNUMBER) (QUOTE 642)) (PUT (QUOTE OUT!*) (QUOTE IDNUMBER) (QUOTE 319)) (PUT (QUOTE OUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE EXPANDSETF) (QUOTE ENTRYPOINT) (QUOTE "L2965")) (PUT (QUOTE EXPANDSETF) (QUOTE IDNUMBER) (QUOTE 720)) (PUT (QUOTE GO) (QUOTE ENTRYPOINT) (QUOTE GO)) (PUT (QUOTE GO) (QUOTE IDNUMBER) (QUOTE 544)) (PUT (QUOTE STDOUT!*) (QUOTE IDNUMBER) (QUOTE 617)) (PUT (QUOTE STDOUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE FINDFREECHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L3520")) (PUT (QUOTE REST) (QUOTE ENTRYPOINT) (QUOTE REST)) (PUT (QUOTE REST) (QUOTE IDNUMBER) (QUOTE 336)) (PUT (QUOTE SIMP) (QUOTE IDNUMBER) (QUOTE 749)) (PUT (QUOTE INVOKE) (QUOTE ENTRYPOINT) (QUOTE INVOKE)) (PUT (QUOTE INVOKE) (QUOTE IDNUMBER) (QUOTE 581)) (PUT (QUOTE !*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 493)) (FLAG (QUOTE (!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE !&!&TAG!&!&) (QUOTE IDNUMBER) (QUOTE 531)) (PUT (QUOTE TYPE) (QUOTE IDNUMBER) (QUOTE 758)) (PUT (QUOTE CDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDAR)) (PUT (QUOTE CDDAR) (QUOTE IDNUMBER) (QUOTE 226)) (PUT (QUOTE TR) (QUOTE ENTRYPOINT) (QUOTE TR)) (PUT (QUOTE TR) (QUOTE IDNUMBER) (QUOTE 434)) (PUT (QUOTE UP) (QUOTE IDNUMBER) (QUOTE 455)) (PUT (QUOTE EMSG!*) (QUOTE IDNUMBER) (QUOTE 483)) (FLAG (QUOTE (EMSG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKE!-VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0374")) (PUT (QUOTE MAKE!-VECTOR) (QUOTE IDNUMBER) (QUOTE 184)) (PUT (QUOTE PRINTF) (QUOTE ENTRYPOINT) (QUOTE PRINTF)) (PUT (QUOTE PRINTF) (QUOTE IDNUMBER) (QUOTE 462)) (PUT (QUOTE FLATSIZE) (QUOTE ENTRYPOINT) (QUOTE "L2904")) (PUT (QUOTE FLATSIZE) (QUOTE IDNUMBER) (QUOTE 488)) (PUT (QUOTE PROGBODY!*) (QUOTE IDNUMBER) (QUOTE 539)) (FLAG (QUOTE (PROGBODY!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE SPECIALWRITEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 607)) (FLAG (QUOTE (SPECIALWRITEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE READINBUF) (QUOTE ENTRYPOINT) (QUOTE "L2407")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE ENTRYPOINT) (QUOTE "L2032")) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE IDNUMBER) (QUOTE 533)) (PUT (QUOTE SUBSTIP1) (QUOTE ENTRYPOINT) (QUOTE "L0883")) (PUT (QUOTE PRINT) (QUOTE ENTRYPOINT) (QUOTE PRINT)) (PUT (QUOTE PRINT) (QUOTE IDNUMBER) (QUOTE 318)) (PUT (QUOTE SAFECDR) (QUOTE ENTRYPOINT) (QUOTE "L0612")) (PUT (QUOTE SAFECDR) (QUOTE IDNUMBER) (QUOTE 236)) (PUT (QUOTE INTLXOR) (QUOTE ENTRYPOINT) (QUOTE "L1495")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3157")) (PUT (QUOTE MAKEFUNBOUND) (QUOTE IDNUMBER) (QUOTE 752)) (PUT (QUOTE DELATQ) (QUOTE ENTRYPOINT) (QUOTE DELATQ)) (PUT (QUOTE DELATQ) (QUOTE IDNUMBER) (QUOTE 349)) (PUT (QUOTE HASHTABLE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HASHTABLE) (QUOTE ASMSYMBOL) (QUOTE "L0003")) (PUT (QUOTE HASHTABLE) (QUOTE WARRAY) (QUOTE HASHTABLE)) (PUT (QUOTE HISTORYLIST!*) (QUOTE IDNUMBER) (QUOTE 821)) (FLAG (QUOTE (HISTORYLIST!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNIONQ) (QUOTE ENTRYPOINT) (QUOTE UNIONQ)) (PUT (QUOTE UNIONQ) (QUOTE IDNUMBER) (QUOTE 381)) (PUT (QUOTE MAKESTRINGINTOSYSINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2418")) (PUT (QUOTE NTH) (QUOTE ENTRYPOINT) (QUOTE NTH)) (PUT (QUOTE NTH) (QUOTE IDNUMBER) (QUOTE 356)) (PUT (QUOTE PL) (QUOTE IDNUMBER) (QUOTE 454)) (PUT (QUOTE JOIN) (QUOTE IDNUMBER) (QUOTE 737)) (PUT (QUOTE SUBSTIP) (QUOTE ENTRYPOINT) (QUOTE "L0888")) (PUT (QUOTE SUBSTIP) (QUOTE IDNUMBER) (QUOTE 338)) (PUT (QUOTE TIME) (QUOTE ENTRYPOINT) (QUOTE TIME)) (PUT (QUOTE TIME) (QUOTE IDNUMBER) (QUOTE 823)) (PUT (QUOTE GTEVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTEVECT) (QUOTE IDNUMBER) (QUOTE 396)) (PUT (QUOTE SPECIALCLOSEFUNCTION!*) (QUOTE IDNUMBER) (QUOTE 608)) (FLAG (QUOTE (SPECIALCLOSEFUNCTION!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE PROP) (QUOTE ENTRYPOINT) (QUOTE PROP)) (PUT (QUOTE PROP) (QUOTE IDNUMBER) (QUOTE 755)) (PUT (QUOTE STARTUPTIME) (QUOTE ENTRYPOINT) (QUOTE "L2922")) (PUT (QUOTE STARTUPTIME) (QUOTE IDNUMBER) (QUOTE 713)) (PUT (QUOTE INTERSECTIONQ) (QUOTE ENTRYPOINT) (QUOTE XNQ)) (PUT (QUOTE INTERSECTIONQ) (QUOTE IDNUMBER) (QUOTE 385)) (PUT (QUOTE !$BREAK!$) (QUOTE IDNUMBER) (QUOTE 807)) (PUT (QUOTE EDITOR) (QUOTE IDNUMBER) (QUOTE 458)) (PUT (QUOTE FLOATQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1453")) (PUT (QUOTE BREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 487)) (PUT (QUOTE BREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE CONTINUABLEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1763")) (PUT (QUOTE CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 244)) (PUT (QUOTE MAKEBUFINTOSYSNUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2417")) (PUT (QUOTE BIGP) (QUOTE ENTRYPOINT) (QUOTE BIGP)) (PUT (QUOTE BIGP) (QUOTE IDNUMBER) (QUOTE 190)) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE ENTRYPOINT) (QUOTE "L2632")) (PUT (QUOTE CHANNELWRITECODEPOINTER) (QUOTE IDNUMBER) (QUOTE 674)) (PUT (QUOTE BINARYOPENREAD) (QUOTE ENTRYPOINT) (QUOTE "L2123")) (PUT (QUOTE BINARYOPENREAD) (QUOTE IDNUMBER) (QUOTE 549)) (PUT (QUOTE WRITEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE WRITEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2276")) (PUT (QUOTE WRITEFUNCTION) (QUOTE WARRAY) (QUOTE WRITEFUNCTION)) (PUT (QUOTE INT2SYS) (QUOTE ENTRYPOINT) (QUOTE "L0016")) (PUT (QUOTE INT2SYS) (QUOTE IDNUMBER) (QUOTE 134)) (PUT (QUOTE CDADDR) (QUOTE ENTRYPOINT) (QUOTE CDADDR)) (PUT (QUOTE CDADDR) (QUOTE IDNUMBER) (QUOTE 224)) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE ENTRYPOINT) (QUOTE "L3343")) (PUT (QUOTE CODE!-NUMBER!-OF!-ARGUMENTS) (QUOTE IDNUMBER) (QUOTE 778)) (PUT (QUOTE ON) (QUOTE ENTRYPOINT) (QUOTE ON)) (PUT (QUOTE ON) (QUOTE IDNUMBER) (QUOTE 726)) (PUT (QUOTE GTWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1125")) (PUT (QUOTE GTWARRAY) (QUOTE IDNUMBER) (QUOTE 401)) (PUT (QUOTE INTPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1426")) (PUT (QUOTE TIMC) (QUOTE ENTRYPOINT) (QUOTE TIMC)) (PUT (QUOTE TIMC) (QUOTE IDNUMBER) (QUOTE 420)) (PUT (QUOTE DEC20WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L3499")) (PUT (QUOTE DEC20WRITECHAR) (QUOTE IDNUMBER) (QUOTE 592)) (PUT (QUOTE INTQUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1452")) (PUT (QUOTE PROG2) (QUOTE ENTRYPOINT) (QUOTE PROG2)) (PUT (QUOTE PROG2) (QUOTE IDNUMBER) (QUOTE 271)) (PUT (QUOTE MK!*SQ) (QUOTE IDNUMBER) (QUOTE 748)) (PUT (QUOTE LIST2SET) (QUOTE ENTRYPOINT) (QUOTE "L1054")) (PUT (QUOTE LIST2SET) (QUOTE IDNUMBER) (QUOTE 376)) (PUT (QUOTE YES) (QUOTE IDNUMBER) (QUOTE 474)) (PUT (QUOTE REMPROPL) (QUOTE ENTRYPOINT) (QUOTE "L3242")) (PUT (QUOTE REMPROPL) (QUOTE IDNUMBER) (QUOTE 764)) (PUT (QUOTE FLAG1) (QUOTE ENTRYPOINT) (QUOTE FLAG1)) (PUT (QUOTE FLAG1) (QUOTE IDNUMBER) (QUOTE 760)) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3353")) (PUT (QUOTE RESTOREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 514)) (PUT (QUOTE !*WRITINGFASLFILE) (QUOTE IDNUMBER) (QUOTE 553)) (PUT (QUOTE DELETIP1) (QUOTE ENTRYPOINT) (QUOTE "L0894")) (PUT (QUOTE EVLIS) (QUOTE ENTRYPOINT) (QUOTE EVLIS)) (PUT (QUOTE EVLIS) (QUOTE IDNUMBER) (QUOTE 253)) (PUT (QUOTE NONNUMBERERROR) (QUOTE ENTRYPOINT) (QUOTE "L1789")) (PUT (QUOTE NONNUMBERERROR) (QUOTE IDNUMBER) (QUOTE 490)) (PUT (QUOTE APPLY) (QUOTE ENTRYPOINT) (QUOTE APPLY)) (PUT (QUOTE APPLY) (QUOTE IDNUMBER) (QUOTE 518)) (PUT (QUOTE OFF) (QUOTE ENTRYPOINT) (QUOTE OFF)) (PUT (QUOTE OFF) (QUOTE IDNUMBER) (QUOTE 727)) (PUT (QUOTE QEDITFNS) (QUOTE IDNUMBER) (QUOTE 437)) (FLAG (QUOTE (QEDITFNS)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MARKFROMVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L1247")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE ENTRYPOINT) (QUOTE "L1045")) (PUT (QUOTE CHANNELPRIN2T) (QUOTE IDNUMBER) (QUOTE 363)) (PUT (QUOTE LENGTH) (QUOTE ENTRYPOINT) (QUOTE LENGTH)) (PUT (QUOTE LENGTH) (QUOTE IDNUMBER) (QUOTE 148)) (PUT (QUOTE COLLECT) (QUOTE IDNUMBER) (QUOTE 736)) (PUT (QUOTE GLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3268")) (PUT (QUOTE GLOBAL1) (QUOTE IDNUMBER) (QUOTE 770)) (PUT (QUOTE READ) (QUOTE ENTRYPOINT) (QUOTE READ)) (PUT (QUOTE READ) (QUOTE IDNUMBER) (QUOTE 449)) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE ENTRYPOINT) (QUOTE "L2637")) (PUT (QUOTE CHANNELWRITEBLANKOREOL) (QUOTE IDNUMBER) (QUOTE 675)) (PUT (QUOTE !*INNER!*BACKTRACE) (QUOTE IDNUMBER) (QUOTE 494)) (FLAG (QUOTE (!*INNER!*BACKTRACE)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COPYSTRING) (QUOTE ENTRYPOINT) (QUOTE "L1135")) (PUT (QUOTE COPYSTRING) (QUOTE IDNUMBER) (QUOTE 404)) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE ENTRYPOINT) (QUOTE "L3352")) (PUT (QUOTE CAPTUREENVIRONMENT) (QUOTE IDNUMBER) (QUOTE 537)) (PUT (QUOTE RDTTY) (QUOTE ENTRYPOINT) (QUOTE RDTTY)) (PUT (QUOTE TOTALCOPY) (QUOTE ENTRYPOINT) (QUOTE "L1149")) (PUT (QUOTE TOTALCOPY) (QUOTE IDNUMBER) (QUOTE 410)) (PUT (QUOTE OPTIONS!*) (QUOTE IDNUMBER) (QUOTE 467)) (FLAG (QUOTE (OPTIONS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE GETFNTYPE) (QUOTE ENTRYPOINT) (QUOTE "L3192")) (PUT (QUOTE GETFNTYPE) (QUOTE IDNUMBER) (QUOTE 524)) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE ENTRYPOINT) (QUOTE "L1107")) (PUT (QUOTE SET!-GC!-TRAP!-LEVEL) (QUOTE IDNUMBER) (QUOTE 392)) (PUT (QUOTE LINELENGTH) (QUOTE ENTRYPOINT) (QUOTE "L2351")) (PUT (QUOTE LINELENGTH) (QUOTE IDNUMBER) (QUOTE 621)) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE ENTRYPOINT) (QUOTE "L2594")) (PUT (QUOTE CHANNELWRITEBITSTRAUX) (QUOTE IDNUMBER) (QUOTE 662)) (PUT (QUOTE RANGE) (QUOTE IDNUMBER) (QUOTE 718)) (PUT (QUOTE PUTENTRY) (QUOTE ENTRYPOINT) (QUOTE "L2189")) (PUT (QUOTE PUTENTRY) (QUOTE IDNUMBER) (QUOTE 561)) (PUT (QUOTE BREAKERRMSG) (QUOTE ENTRYPOINT) (QUOTE "L3582")) (PUT (QUOTE BREAKERRMSG) (QUOTE IDNUMBER) (QUOTE 814)) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2603")) (PUT (QUOTE CHANNELPRINTSTRING) (QUOTE IDNUMBER) (QUOTE 669)) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2903")) (PUT (QUOTE FLATSIZEWRITECHAR) (QUOTE IDNUMBER) (QUOTE 595)) (PUT (QUOTE PUT) (QUOTE ENTRYPOINT) (QUOTE PUT)) (PUT (QUOTE PUT) (QUOTE IDNUMBER) (QUOTE 308)) (PUT (QUOTE INT2ID) (QUOTE ENTRYPOINT) (QUOTE INT2ID)) (PUT (QUOTE INT2ID) (QUOTE IDNUMBER) (QUOTE 131)) (PUT (QUOTE INTDIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1435")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3348")) (PUT (QUOTE BSTACKOVERFLOW) (QUOTE IDNUMBER) (QUOTE 513)) (PUT (QUOTE CAADAR) (QUOTE ENTRYPOINT) (QUOTE CAADAR)) (PUT (QUOTE CAADAR) (QUOTE IDNUMBER) (QUOTE 210)) (PUT (QUOTE MAX2) (QUOTE ENTRYPOINT) (QUOTE MAX2)) (PUT (QUOTE MAX2) (QUOTE IDNUMBER) (QUOTE 289)) (PUT (QUOTE VALUECELLLOCATION) (QUOTE ENTRYPOINT) (QUOTE "L2130")) (PUT (QUOTE VALUECELLLOCATION) (QUOTE IDNUMBER) (QUOTE 552)) (PUT (QUOTE XCONS) (QUOTE ENTRYPOINT) (QUOTE XCONS)) (PUT (QUOTE XCONS) (QUOTE IDNUMBER) (QUOTE 286)) (PUT (QUOTE PRINC) (QUOTE ENTRYPOINT) (QUOTE PRIN2)) (PUT (QUOTE PRINC) (QUOTE IDNUMBER) (QUOTE 628)) (PUT (QUOTE UNREADBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE UNREADBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2278")) (PUT (QUOTE UNREADBUFFER) (QUOTE WARRAY) (QUOTE UNREADBUFFER)) (PUT (QUOTE MINI) (QUOTE ENTRYPOINT) (QUOTE MINI)) (PUT (QUOTE MINI) (QUOTE IDNUMBER) (QUOTE 579)) (PUT (QUOTE EXPLODE2) (QUOTE ENTRYPOINT) (QUOTE "L2901")) (PUT (QUOTE EXPLODE2) (QUOTE IDNUMBER) (QUOTE 698)) (PUT (QUOTE !*TIME) (QUOTE IDNUMBER) (QUOTE 822)) (FLAG (QUOTE (!*TIME)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE LINEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LINEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2279")) (PUT (QUOTE LINEPOSITION) (QUOTE WARRAY) (QUOTE LINEPOSITION)) (PUT (QUOTE PAIR) (QUOTE ENTRYPOINT) (QUOTE PAIR)) (PUT (QUOTE PAIR) (QUOTE IDNUMBER) (QUOTE 305)) (PUT (QUOTE REVERSIP) (QUOTE ENTRYPOINT) (QUOTE "L0878")) (PUT (QUOTE REVERSIP) (QUOTE IDNUMBER) (QUOTE 337)) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L2615")) (PUT (QUOTE CHANNELWRITEUNBOUND) (QUOTE IDNUMBER) (QUOTE 671)) (PUT (QUOTE TOKENBUFFER) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE TOKENBUFFER) (QUOTE ASMSYMBOL) (QUOTE "L2136")) (PUT (QUOTE TOKENBUFFER) (QUOTE WSTRING) (QUOTE TOKENBUFFER)) (PUT (QUOTE INTERN) (QUOTE ENTRYPOINT) (QUOTE INTERN)) (PUT (QUOTE INTERN) (QUOTE IDNUMBER) (QUOTE 560)) (PUT (QUOTE LISPBANNER!*) (QUOTE IDNUMBER) (QUOTE 818)) (PUT (QUOTE LISPBANNER!*) (QUOTE INITIALVALUE) (QUOTE "Portable Standard LISP")) (PUT (QUOTE RANGEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1736")) (PUT (QUOTE RANGEERROR) (QUOTE IDNUMBER) (QUOTE 165)) (PUT (QUOTE LIST) (QUOTE ENTRYPOINT) (QUOTE LIST)) (PUT (QUOTE LIST) (QUOTE IDNUMBER) (QUOTE 252)) (PUT (QUOTE PENDINGLOADS!*) (QUOTE IDNUMBER) (QUOTE 574)) (FLAG (QUOTE (PENDINGLOADS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE QUOTIENT) (QUOTE ENTRYPOINT) (QUOTE "L1451")) (PUT (QUOTE QUOTIENT) (QUOTE IDNUMBER) (QUOTE 250)) (PUT (QUOTE SPACES) (QUOTE ENTRYPOINT) (QUOTE SPACES)) (PUT (QUOTE SPACES) (QUOTE IDNUMBER) (QUOTE 368)) (PUT (QUOTE SYS2FIXN) (QUOTE ENTRYPOINT) (QUOTE "L0033")) (PUT (QUOTE UNBOUNDP) (QUOTE ENTRYPOINT) (QUOTE "L3376")) (PUT (QUOTE UNBOUNDP) (QUOTE IDNUMBER) (QUOTE 765)) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE ENTRYPOINT) (QUOTE "L2735")) (PUT (QUOTE CHANNELPRINTEVECTOR) (QUOTE IDNUMBER) (QUOTE 687)) (PUT (QUOTE CATCH) (QUOTE ENTRYPOINT) (QUOTE CATCH)) (PUT (QUOTE CATCH) (QUOTE IDNUMBER) (QUOTE 498)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE IDNUMBER) (QUOTE 658)) (PUT (QUOTE IDESCAPECHAR!*) (QUOTE INITIALVALUE) (QUOTE 33)) (PUT (QUOTE CHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1850")) (PUT (QUOTE CHANNELERROR) (QUOTE IDNUMBER) (QUOTE 503)) (PUT (QUOTE WRITESTRING) (QUOTE ENTRYPOINT) (QUOTE "L2580")) (PUT (QUOTE WRITESTRING) (QUOTE IDNUMBER) (QUOTE 660)) (PUT (QUOTE TIMES2) (QUOTE ENTRYPOINT) (QUOTE TIMES2)) (PUT (QUOTE TIMES2) (QUOTE IDNUMBER) (QUOTE 248)) (PUT (QUOTE !%RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1204")) (PUT (QUOTE !%RECLAIM) (QUOTE IDNUMBER) (QUOTE 389)) (PUT (QUOTE CHANNELREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2285")) (PUT (QUOTE CHANNELREADCHAR) (QUOTE IDNUMBER) (QUOTE 597)) (PUT (QUOTE DELATQIP1) (QUOTE ENTRYPOINT) (QUOTE "L0972")) (PUT (QUOTE SPACES2) (QUOTE ENTRYPOINT) (QUOTE TAB)) (PUT (QUOTE SPACES2) (QUOTE IDNUMBER) (QUOTE 374)) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE ENTRYPOINT) (QUOTE "L3351")) (PUT (QUOTE BSTACKUNDERFLOW) (QUOTE IDNUMBER) (QUOTE 779)) (PUT (QUOTE ASSOC) (QUOTE ENTRYPOINT) (QUOTE ASSOC)) (PUT (QUOTE ASSOC) (QUOTE IDNUMBER) (QUOTE 303)) (PUT (QUOTE IMPORTS) (QUOTE ENTRYPOINT) (QUOTE "L2227")) (PUT (QUOTE IMPORTS) (QUOTE IDNUMBER) (QUOTE 575)) (PUT (QUOTE EQN) (QUOTE ENTRYPOINT) (QUOTE EQN)) (PUT (QUOTE EQN) (QUOTE IDNUMBER) (QUOTE 202)) (PUT (QUOTE CDDDAR) (QUOTE ENTRYPOINT) (QUOTE CDDDAR)) (PUT (QUOTE CDDDAR) (QUOTE IDNUMBER) (QUOTE 228)) (PUT (QUOTE NULL) (QUOTE ENTRYPOINT) (QUOTE NULL)) (PUT (QUOTE NULL) (QUOTE IDNUMBER) (QUOTE 239)) (PUT (QUOTE APPEND) (QUOTE ENTRYPOINT) (QUOTE APPEND)) (PUT (QUOTE APPEND) (QUOTE IDNUMBER) (QUOTE 177)) (PUT (QUOTE DELETIP) (QUOTE ENTRYPOINT) (QUOTE "L0900")) (PUT (QUOTE DELETIP) (QUOTE IDNUMBER) (QUOTE 339)) (PUT (QUOTE FLOATTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1444")) (PUT (QUOTE REPEAT) (QUOTE ENTRYPOINT) (QUOTE REPEAT)) (PUT (QUOTE REPEAT) (QUOTE IDNUMBER) (QUOTE 745)) (PUT (QUOTE CAR) (QUOTE ENTRYPOINT) (QUOTE CAR)) (PUT (QUOTE CAR) (QUOTE IDNUMBER) (QUOTE 195)) (PUT (QUOTE AND) (QUOTE ENTRYPOINT) (QUOTE AND)) (PUT (QUOTE AND) (QUOTE IDNUMBER) (QUOTE 274)) (PUT (QUOTE EXPLODEENDPOINTER!*) (QUOTE IDNUMBER) (QUOTE 696)) (FLAG (QUOTE (EXPLODEENDPOINTER!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE ENTRYPOINT) (QUOTE "L3161")) (PUT (QUOTE MAKEFLAMBDALINK) (QUOTE IDNUMBER) (QUOTE 753)) (PUT (QUOTE HEAPSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAPSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE HEAPSIZE) (QUOTE WCONST) (QUOTE 90000)) (PUT (QUOTE !&!&THROWN!&!&) (QUOTE IDNUMBER) (QUOTE 529)) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE ENTRYPOINT) (QUOTE "L2908")) (PUT (QUOTE COMPRESSREADCHAR) (QUOTE IDNUMBER) (QUOTE 591)) (PUT (QUOTE RECIP) (QUOTE ENTRYPOINT) (QUOTE RECIP)) (PUT (QUOTE RECIP) (QUOTE IDNUMBER) (QUOTE 331)) (PUT (QUOTE DEBUG) (QUOTE IDNUMBER) (QUOTE 433)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE IDNUMBER) (QUOTE 486)) (PUT (QUOTE MAXBREAKLEVEL!*) (QUOTE INITIALVALUE) (QUOTE 5)) (PUT (QUOTE DELATQIP) (QUOTE ENTRYPOINT) (QUOTE "L0978")) (PUT (QUOTE DELATQIP) (QUOTE IDNUMBER) (QUOTE 350)) (PUT (QUOTE READCH) (QUOTE ENTRYPOINT) (QUOTE READCH)) (PUT (QUOTE READCH) (QUOTE IDNUMBER) (QUOTE 627)) (PUT (QUOTE INITFORMS!*) (QUOTE IDNUMBER) (QUOTE 836)) (FLAG (QUOTE (INITFORMS!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE FLUIDP) (QUOTE ENTRYPOINT) (QUOTE FLUIDP)) (PUT (QUOTE FLUIDP) (QUOTE IDNUMBER) (QUOTE 769)) (PUT (QUOTE DEC20READCHAR) (QUOTE ENTRYPOINT) (QUOTE "L3495")) (PUT (QUOTE DEC20READCHAR) (QUOTE IDNUMBER) (QUOTE 791)) (PUT (QUOTE TOPLOOP) (QUOTE ENTRYPOINT) (QUOTE "L3604")) (PUT (QUOTE TOPLOOP) (QUOTE IDNUMBER) (QUOTE 806)) (PUT (QUOTE LITER) (QUOTE ENTRYPOINT) (QUOTE LITER)) (PUT (QUOTE LITER) (QUOTE IDNUMBER) (QUOTE 201)) (PUT (QUOTE NEXT) (QUOTE ENTRYPOINT) (QUOTE NEXT)) (PUT (QUOTE NEXT) (QUOTE IDNUMBER) (QUOTE 743)) (PUT (QUOTE !$EXITTOPLOOP!$) (QUOTE IDNUMBER) (QUOTE 825)) (PUT (QUOTE ERROUT!*) (QUOTE IDNUMBER) (QUOTE 476)) (PUT (QUOTE ERROUT!*) (QUOTE INITIALVALUE) (QUOTE 1)) (PUT (QUOTE CADADR) (QUOTE ENTRYPOINT) (QUOTE CADADR)) (PUT (QUOTE CADADR) (QUOTE IDNUMBER) (QUOTE 215)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1191")) (PUT (QUOTE STACKLOWERBOUND) (QUOTE WVAR) (QUOTE STACKLOWERBOUND)) (PUT (QUOTE !*NONIL) (QUOTE IDNUMBER) (QUOTE 824)) (FLAG (QUOTE (!*NONIL)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE UNWIND!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L2008")) (PUT (QUOTE UNWIND!-ALL) (QUOTE IDNUMBER) (QUOTE 528)) (PUT (QUOTE XINS) (QUOTE ENTRYPOINT) (QUOTE XINS)) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE ENTRYPOINT) (QUOTE "L1813")) (PUT (QUOTE NONIOCHANNELERROR) (QUOTE IDNUMBER) (QUOTE 492)) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE ENTRYPOINT) (QUOTE "L2749")) (PUT (QUOTE CHANNELWRITEWORDS) (QUOTE IDNUMBER) (QUOTE 688)) (PUT (QUOTE RPLACD) (QUOTE ENTRYPOINT) (QUOTE RPLACD)) (PUT (QUOTE RPLACD) (QUOTE IDNUMBER) (QUOTE 198)) (PUT (QUOTE STACKSIZE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKSIZE) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE STACKSIZE) (QUOTE WCONST) (QUOTE 10000)) (PUT (QUOTE DEFLIST) (QUOTE ENTRYPOINT) (QUOTE "L0782")) (PUT (QUOTE DEFLIST) (QUOTE IDNUMBER) (QUOTE 307)) (PUT (QUOTE CHANNELTYO) (QUOTE ENTRYPOINT) (QUOTE "L2918")) (PUT (QUOTE CHANNELTYO) (QUOTE IDNUMBER) (QUOTE 706)) (PUT (QUOTE CHANNELREADLINE) (QUOTE ENTRYPOINT) (QUOTE "L2568")) (PUT (QUOTE CHANNELREADLINE) (QUOTE IDNUMBER) (QUOTE 656)) (PUT (QUOTE LAMBDAEVALAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1903")) (PUT (QUOTE SUB) (QUOTE ENTRYPOINT) (QUOTE SUB)) (PUT (QUOTE SUB) (QUOTE IDNUMBER) (QUOTE 168)) (PUT (QUOTE FASTLAMBDAAPPLY) (QUOTE ENTRYPOINT) (QUOTE "L1884")) (PUT (QUOTE BLDMSG) (QUOTE ENTRYPOINT) (QUOTE BLDMSG)) (PUT (QUOTE BLDMSG) (QUOTE IDNUMBER) (QUOTE 155)) (PUT (QUOTE CHANNELSPACES2) (QUOTE ENTRYPOINT) (QUOTE "L1050")) (PUT (QUOTE CHANNELSPACES2) (QUOTE IDNUMBER) (QUOTE 375)) (PUT (QUOTE EXPR) (QUOTE IDNUMBER) (QUOTE 255)) (PUT (QUOTE BREAKIN!*) (QUOTE IDNUMBER) (QUOTE 798)) (FLAG (QUOTE (BREAKIN!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE MAXARGS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXARGS) (QUOTE ASMSYMBOL) (QUOTE NIL)) (PUT (QUOTE MAXARGS) (QUOTE WCONST) (QUOTE 15)) (PUT (QUOTE MAXLINE) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE MAXLINE) (QUOTE ASMSYMBOL) (QUOTE "L2281")) (PUT (QUOTE MAXLINE) (QUOTE WARRAY) (QUOTE MAXLINE)) (PUT (QUOTE VECTOR2STRING) (QUOTE ENTRYPOINT) (QUOTE "L0049")) (PUT (QUOTE VECTOR2STRING) (QUOTE IDNUMBER) (QUOTE 144)) (PUT (QUOTE CHANNELREADEOF) (QUOTE ENTRYPOINT) (QUOTE "L2364")) (PUT (QUOTE CHANNELREADEOF) (QUOTE IDNUMBER) (QUOTE 640)) (PUT (QUOTE EQCAR) (QUOTE ENTRYPOINT) (QUOTE EQCAR)) (PUT (QUOTE EQCAR) (QUOTE IDNUMBER) (QUOTE 324)) (PUT (QUOTE ATSOC) (QUOTE ENTRYPOINT) (QUOTE ATSOC)) (PUT (QUOTE ATSOC) (QUOTE IDNUMBER) (QUOTE 343)) (PUT (QUOTE LASTBPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE LASTBPS) (QUOTE ASMSYMBOL) (QUOTE "L1117")) (PUT (QUOTE LASTBPS) (QUOTE WVAR) (QUOTE LASTBPS)) (PUT (QUOTE FIXP) (QUOTE ENTRYPOINT) (QUOTE FIXP)) (PUT (QUOTE FIXP) (QUOTE IDNUMBER) (QUOTE 199)) (PUT (QUOTE ADJOIN) (QUOTE ENTRYPOINT) (QUOTE ADJOIN)) (PUT (QUOTE ADJOIN) (QUOTE IDNUMBER) (QUOTE 378)) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE ENTRYPOINT) (QUOTE "L2370")) (PUT (QUOTE CHANNELREADLISTORDOTTEDPAIR) (QUOTE IDNUMBER) (QUOTE 643)) (PUT (QUOTE EXPAND) (QUOTE ENTRYPOINT) (QUOTE EXPAND)) (PUT (QUOTE EXPAND) (QUOTE IDNUMBER) (QUOTE 314)) (PUT (QUOTE HALFWORDSEQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0478")) (PUT (QUOTE MAKEFIXNUM) (QUOTE ENTRYPOINT) (QUOTE "L1418")) (PUT (QUOTE MKSTRING) (QUOTE ENTRYPOINT) (QUOTE "L0332")) (PUT (QUOTE MKSTRING) (QUOTE IDNUMBER) (QUOTE 179)) (PUT (QUOTE CHANNELTERPRI) (QUOTE ENTRYPOINT) (QUOTE "L2356")) (PUT (QUOTE CHANNELTERPRI) (QUOTE IDNUMBER) (QUOTE 317)) (PUT (QUOTE LASTCAR) (QUOTE ENTRYPOINT) (QUOTE "L0996")) (PUT (QUOTE LASTCAR) (QUOTE IDNUMBER) (QUOTE 353)) (PUT (QUOTE INTERNP) (QUOTE ENTRYPOINT) (QUOTE "L3451")) (PUT (QUOTE INTERNP) (QUOTE IDNUMBER) (QUOTE 784)) (PUT (QUOTE UPDATEALLBASES) (QUOTE ENTRYPOINT) (QUOTE "L1209")) (PUT (QUOTE CONSTANTP) (QUOTE ENTRYPOINT) (QUOTE "L0635")) (PUT (QUOTE CONSTANTP) (QUOTE IDNUMBER) (QUOTE 238)) (PUT (QUOTE !*BREAK) (QUOTE IDNUMBER) (QUOTE 484)) (PUT (QUOTE !*BREAK) (QUOTE INITIALVALUE) (QUOTE T)) (PUT (QUOTE THROWTAG!*) (QUOTE IDNUMBER) (QUOTE 526)) (FLAG (QUOTE (THROWTAG!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE EXPT) (QUOTE ENTRYPOINT) (QUOTE EXPT)) (PUT (QUOTE EXPT) (QUOTE IDNUMBER) (QUOTE 241)) (PUT (QUOTE EVOR) (QUOTE ENTRYPOINT) (QUOTE EVOR)) (PUT (QUOTE EVOR) (QUOTE IDNUMBER) (QUOTE 277)) (PUT (QUOTE MAPCAN) (QUOTE ENTRYPOINT) (QUOTE MAPCAN)) (PUT (QUOTE MAPCAN) (QUOTE IDNUMBER) (QUOTE 298)) (PUT (QUOTE LAND) (QUOTE ENTRYPOINT) (QUOTE LAND)) (PUT (QUOTE LAND) (QUOTE IDNUMBER) (QUOTE 424)) (PUT (QUOTE LSH) (QUOTE ENTRYPOINT) (QUOTE LSHIFT)) (PUT (QUOTE LSH) (QUOTE IDNUMBER) (QUOTE 428)) (PUT (QUOTE SYMVAL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE SYMVAL) (QUOTE ASMSYMBOL) (QUOTE SYMVAL)) (PUT (QUOTE SYMVAL) (QUOTE WARRAY) (QUOTE SYMVAL)) (PUT (QUOTE COMPILETIME) (QUOTE ENTRYPOINT) (QUOTE "L2920")) (PUT (QUOTE COMPILETIME) (QUOTE IDNUMBER) (QUOTE 710)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE ASMSYMBOL) (QUOTE "L0002")) (PUT (QUOTE ARGUMENTBLOCK) (QUOTE WARRAY) (QUOTE ARGUMENTBLOCK)) (PUT (QUOTE PAGEPOSITION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE PAGEPOSITION) (QUOTE ASMSYMBOL) (QUOTE "L2280")) (PUT (QUOTE PAGEPOSITION) (QUOTE WARRAY) (QUOTE PAGEPOSITION)) (PUT (QUOTE STEP) (QUOTE ENTRYPOINT) (QUOTE STEP)) (PUT (QUOTE STEP) (QUOTE IDNUMBER) (QUOTE 578)) (PUT (QUOTE DEFCONST) (QUOTE ENTRYPOINT) (QUOTE "L3041")) (PUT (QUOTE DEFCONST) (QUOTE IDNUMBER) (QUOTE 730)) (PUT (QUOTE GET) (QUOTE ENTRYPOINT) (QUOTE GET)) (PUT (QUOTE GET) (QUOTE IDNUMBER) (QUOTE 522)) (PUT (QUOTE GCTIME!*) (QUOTE IDNUMBER) (QUOTE 416)) (PUT (QUOTE GCTIME!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE GLOBAL) (QUOTE ENTRYPOINT) (QUOTE GLOBAL)) (PUT (QUOTE GLOBAL) (QUOTE IDNUMBER) (QUOTE 653)) (PUT (QUOTE GTFIXN) (QUOTE ENTRYPOINT) (QUOTE GTFIXN)) (PUT (QUOTE GTFIXN) (QUOTE IDNUMBER) (QUOTE 139)) (PUT (QUOTE DIFFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L1434")) (PUT (QUOTE DIFFERENCE) (QUOTE IDNUMBER) (QUOTE 246)) (PUT (QUOTE CAAAR) (QUOTE ENTRYPOINT) (QUOTE CAAAR)) (PUT (QUOTE CAAAR) (QUOTE IDNUMBER) (QUOTE 208)) (PUT (QUOTE BPS) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BPS) (QUOTE ASMSYMBOL) (QUOTE BPS)) (PUT (QUOTE BPS) (QUOTE WARRAY) (QUOTE BPS)) (PUT (QUOTE WRITECHAR) (QUOTE ENTRYPOINT) (QUOTE "L2301")) (PUT (QUOTE WRITECHAR) (QUOTE IDNUMBER) (QUOTE 468)) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE ENTRYPOINT) (QUOTE "L1810")) (PUT (QUOTE NONSEQUENCEERROR) (QUOTE IDNUMBER) (QUOTE 166)) (PUT (QUOTE EQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0449")) (PUT (QUOTE EQUAL) (QUOTE IDNUMBER) (QUOTE 206)) (PUT (QUOTE ADD1) (QUOTE ENTRYPOINT) (QUOTE ADD1)) (PUT (QUOTE ADD1) (QUOTE IDNUMBER) (QUOTE 249)) (PUT (QUOTE NEWID) (QUOTE ENTRYPOINT) (QUOTE NEWID)) (PUT (QUOTE NEWID) (QUOTE IDNUMBER) (QUOTE 648)) (PUT (QUOTE DELBPS) (QUOTE ENTRYPOINT) (QUOTE DELBPS)) (PUT (QUOTE DELBPS) (QUOTE IDNUMBER) (QUOTE 400)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE CLOSEFUNCTION) (QUOTE ASMSYMBOL) (QUOTE "L2277")) (PUT (QUOTE CLOSEFUNCTION) (QUOTE WARRAY) (QUOTE CLOSEFUNCTION)) (PUT (QUOTE FINDCATCHMARKANDTHROW) (QUOTE ENTRYPOINT) (QUOTE "L2053")) (PUT (QUOTE NO) (QUOTE IDNUMBER) (QUOTE 473)) (PUT (QUOTE LIST3) (QUOTE ENTRYPOINT) (QUOTE LIST3)) (PUT (QUOTE LIST3) (QUOTE IDNUMBER) (QUOTE 243)) (PUT (QUOTE INTLAND) (QUOTE ENTRYPOINT) (QUOTE "L1482")) (PUT (QUOTE EVAL) (QUOTE ENTRYPOINT) (QUOTE EVAL)) (PUT (QUOTE EVAL) (QUOTE IDNUMBER) (QUOTE 269)) (PUT (QUOTE GTID) (QUOTE ENTRYPOINT) (QUOTE GTID)) (PUT (QUOTE GTID) (QUOTE IDNUMBER) (QUOTE 398)) (PUT (QUOTE MAKEUNBOUND) (QUOTE ENTRYPOINT) (QUOTE "L3381")) (PUT (QUOTE MAKEUNBOUND) (QUOTE IDNUMBER) (QUOTE 781)) (PUT (QUOTE RPLACEALL) (QUOTE ENTRYPOINT) (QUOTE "L1638")) (PUT (QUOTE READONLYCHANNEL) (QUOTE ENTRYPOINT) (QUOTE "L1841")) (PUT (QUOTE READONLYCHANNEL) (QUOTE IDNUMBER) (QUOTE 505)) (PUT (QUOTE CATCHSETUPAUX) (QUOTE ENTRYPOINT) (QUOTE "L2040")) (PUT (QUOTE GCKNT!*) (QUOTE IDNUMBER) (QUOTE 417)) (PUT (QUOTE GCKNT!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE NEXTSYMBOL) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE NEXTSYMBOL) (QUOTE ASMSYMBOL) (QUOTE "L0001")) (PUT (QUOTE NEXTSYMBOL) (QUOTE WVAR) (QUOTE NEXTSYMBOL)) (PUT (QUOTE INTHISCASE) (QUOTE ENTRYPOINT) (QUOTE "L2948")) (PUT (QUOTE DM) (QUOTE ENTRYPOINT) (QUOTE DM)) (PUT (QUOTE DM) (QUOTE IDNUMBER) (QUOTE 265)) (PUT (QUOTE BREAKEVAL!*) (QUOTE IDNUMBER) (QUOTE 802)) (FLAG (QUOTE (BREAKEVAL!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE COMMENTOUTCODE) (QUOTE ENTRYPOINT) (QUOTE "L2919")) (PUT (QUOTE COMMENTOUTCODE) (QUOTE IDNUMBER) (QUOTE 709)) (PUT (QUOTE HEAP) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE HEAP) (QUOTE ASMSYMBOL) (QUOTE HEAP)) (PUT (QUOTE HEAP) (QUOTE WARRAY) (QUOTE HEAP)) (PUT (QUOTE COPYWARRAY) (QUOTE ENTRYPOINT) (QUOTE "L1136")) (PUT (QUOTE COPYWARRAY) (QUOTE IDNUMBER) (QUOTE 405)) (PUT (QUOTE INTTIMES2) (QUOTE ENTRYPOINT) (QUOTE "L1443")) (PUT (QUOTE CAAADR) (QUOTE ENTRYPOINT) (QUOTE CAAADR)) (PUT (QUOTE CAAADR) (QUOTE IDNUMBER) (QUOTE 209)) (PUT (QUOTE LIST2VECTOR) (QUOTE ENTRYPOINT) (QUOTE "L0075")) (PUT (QUOTE LIST2VECTOR) (QUOTE IDNUMBER) (QUOTE 152)) (PUT (QUOTE SUBST) (QUOTE ENTRYPOINT) (QUOTE SUBST)) (PUT (QUOTE SUBST) (QUOTE IDNUMBER) (QUOTE 313)) (PUT (QUOTE DECLAREFLUIDORGLOBAL1) (QUOTE ENTRYPOINT) (QUOTE "L3251")) (PUT (QUOTE UNBINDN) (QUOTE ENTRYPOINT) (QUOTE "L3357")) (PUT (QUOTE UNBINDN) (QUOTE IDNUMBER) (QUOTE 517)) (PUT (QUOTE BREAKRETRY) (QUOTE ENTRYPOINT) (QUOTE "L3574")) (PUT (QUOTE BREAKRETRY) (QUOTE IDNUMBER) (QUOTE 812)) (PUT (QUOTE !*COMPRESSING) (QUOTE IDNUMBER) (QUOTE 646)) (FLAG (QUOTE (!*COMPRESSING)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE IDP) (QUOTE ENTRYPOINT) (QUOTE IDP)) (PUT (QUOTE IDP) (QUOTE IDNUMBER) (QUOTE 191)) (PUT (QUOTE XN) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE XN) (QUOTE IDNUMBER) (QUOTE 382)) (PUT (QUOTE LOR) (QUOTE ENTRYPOINT) (QUOTE LOR)) (PUT (QUOTE LOR) (QUOTE IDNUMBER) (QUOTE 425)) (PUT (QUOTE NONPAIRERROR) (QUOTE ENTRYPOINT) (QUOTE "L1783")) (PUT (QUOTE NONPAIRERROR) (QUOTE IDNUMBER) (QUOTE 149)) (PUT (QUOTE REVERSE) (QUOTE ENTRYPOINT) (QUOTE "L0804")) (PUT (QUOTE REVERSE) (QUOTE IDNUMBER) (QUOTE 312)) (PUT (QUOTE WRITEFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2845")) (PUT (QUOTE WRITEFLOAT) (QUOTE IDNUMBER) (QUOTE 667)) (PUT (QUOTE ONOFF!*) (QUOTE ENTRYPOINT) (QUOTE "L2976")) (PUT (QUOTE ONOFF!*) (QUOTE IDNUMBER) (QUOTE 723)) (PUT (QUOTE FLAMBDALINKP) (QUOTE ENTRYPOINT) (QUOTE "L3146")) (PUT (QUOTE FLAMBDALINKP) (QUOTE IDNUMBER) (QUOTE 751)) (PUT (QUOTE FLATSIZE2) (QUOTE ENTRYPOINT) (QUOTE "L2905")) (PUT (QUOTE FLATSIZE2) (QUOTE IDNUMBER) (QUOTE 699)) (PUT (QUOTE PROGJUMPTABLE!*) (QUOTE IDNUMBER) (QUOTE 540)) (FLAG (QUOTE (PROGJUMPTABLE!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE NONINTEGER1ERROR) (QUOTE ENTRYPOINT) (QUOTE "L1394")) (PUT (QUOTE RECLAIM) (QUOTE ENTRYPOINT) (QUOTE "L1199")) (PUT (QUOTE RECLAIM) (QUOTE IDNUMBER) (QUOTE 399)) (PUT (QUOTE FUNCTION) (QUOTE ENTRYPOINT) (QUOTE "L0821")) (PUT (QUOTE FUNCTION) (QUOTE IDNUMBER) (QUOTE 260)) (PUT (QUOTE LAMBDA) (QUOTE IDNUMBER) (QUOTE 261)) (PUT (QUOTE NUMBERP) (QUOTE ENTRYPOINT) (QUOTE "L0642")) (PUT (QUOTE NUMBERP) (QUOTE IDNUMBER) (QUOTE 240)) (PUT (QUOTE GETD) (QUOTE ENTRYPOINT) (QUOTE GETD)) (PUT (QUOTE GETD) (QUOTE IDNUMBER) (QUOTE 326)) (PUT (QUOTE TOPLOOPREAD!*) (QUOTE IDNUMBER) (QUOTE 805)) (FLAG (QUOTE (TOPLOOPREAD!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE BREAKCONTINUE) (QUOTE ENTRYPOINT) (QUOTE "L3570")) (PUT (QUOTE BREAKCONTINUE) (QUOTE IDNUMBER) (QUOTE 811)) (PUT (QUOTE CONCAT) (QUOTE ENTRYPOINT) (QUOTE CONCAT)) (PUT (QUOTE CONCAT) (QUOTE IDNUMBER) (QUOTE 176)) (PUT (QUOTE SETMACROREFERENCE) (QUOTE ENTRYPOINT) (QUOTE "L3003")) (PUT (QUOTE !*SEMICOL!*) (QUOTE IDNUMBER) (QUOTE 480)) (PUT (QUOTE INTONEP) (QUOTE ENTRYPOINT) (QUOTE "L1575")) (PUT (QUOTE COPY) (QUOTE ENTRYPOINT) (QUOTE COPY)) (PUT (QUOTE COPY) (QUOTE IDNUMBER) (QUOTE 355)) (PUT (QUOTE EDITF) (QUOTE ENTRYPOINT) (QUOTE EDITF)) (PUT (QUOTE EDITF) (QUOTE IDNUMBER) (QUOTE 440)) (PUT (QUOTE NONIDERROR) (QUOTE ENTRYPOINT) (QUOTE "L1786")) (PUT (QUOTE NONIDERROR) (QUOTE IDNUMBER) (QUOTE 130)) (PUT (QUOTE CHANNELEJECT) (QUOTE ENTRYPOINT) (QUOTE "L2343")) (PUT (QUOTE CHANNELEJECT) (QUOTE IDNUMBER) (QUOTE 618)) (PUT (QUOTE SUBLA) (QUOTE ENTRYPOINT) (QUOTE SUBLA)) (PUT (QUOTE SUBLA) (QUOTE IDNUMBER) (QUOTE 351)) (PUT (QUOTE STDIN!*) (QUOTE IDNUMBER) (QUOTE 615)) (PUT (QUOTE STDIN!*) (QUOTE INITIALVALUE) (QUOTE 0)) (PUT (QUOTE FASTUNBIND) (QUOTE ENTRYPOINT) (QUOTE "L3370")) (PUT (QUOTE FASTUNBIND) (QUOTE IDNUMBER) (QUOTE 448)) (PUT (QUOTE RASSOC) (QUOTE ENTRYPOINT) (QUOTE RASSOC)) (PUT (QUOTE RASSOC) (QUOTE IDNUMBER) (QUOTE 346)) (PUT (QUOTE STATICINTFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L1386")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE ENTRYPOINT) (QUOTE "L3653")) (PUT (QUOTE PRINTWITHFRESHLINE) (QUOTE IDNUMBER) (QUOTE 834)) (PUT (QUOTE OUTPUT) (QUOTE IDNUMBER) (QUOTE 610)) (PUT (QUOTE EVLOAD) (QUOTE ENTRYPOINT) (QUOTE EVLOAD)) (PUT (QUOTE EVLOAD) (QUOTE IDNUMBER) (QUOTE 435)) (PUT (QUOTE CDADAR) (QUOTE ENTRYPOINT) (QUOTE CDADAR)) (PUT (QUOTE CDADAR) (QUOTE IDNUMBER) (QUOTE 222)) (PUT (QUOTE CATCH!-ALL) (QUOTE ENTRYPOINT) (QUOTE "L1996")) (PUT (QUOTE CATCH!-ALL) (QUOTE IDNUMBER) (QUOTE 527)) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE ENTRYPOINT) (QUOTE "L1835")) (PUT (QUOTE CHANNELNOTOPEN) (QUOTE IDNUMBER) (QUOTE 502)) (PUT (QUOTE SETINDX) (QUOTE ENTRYPOINT) (QUOTE "L0159")) (PUT (QUOTE SETINDX) (QUOTE IDNUMBER) (QUOTE 167)) (PUT (QUOTE PLUS2) (QUOTE ENTRYPOINT) (QUOTE PLUS2)) (PUT (QUOTE PLUS2) (QUOTE IDNUMBER) (QUOTE 251)) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE ENTRYPOINT) (QUOTE "L3540")) (PUT (QUOTE SYSTEMOPENFILEFOROUTPUT) (QUOTE IDNUMBER) (QUOTE 604)) (PUT (QUOTE ADDTOOBLIST) (QUOTE ENTRYPOINT) (QUOTE "L3402")) (PUT (QUOTE ADJOINQ) (QUOTE ENTRYPOINT) (QUOTE "L1066")) (PUT (QUOTE ADJOINQ) (QUOTE IDNUMBER) (QUOTE 379)) (PUT (QUOTE MAKEBUFINTOFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2425")) (PUT (QUOTE CATCHSETUP) (QUOTE ENTRYPOINT) (QUOTE "L2039")) (PUT (QUOTE CATCHSETUP) (QUOTE IDNUMBER) (QUOTE 499)) (PUT (QUOTE BREAKQUIT) (QUOTE ENTRYPOINT) (QUOTE "L3569")) (PUT (QUOTE BREAKQUIT) (QUOTE IDNUMBER) (QUOTE 810)) (PUT (QUOTE CONTOPENERROR) (QUOTE ENTRYPOINT) (QUOTE "L3536")) (PUT (QUOTE GENSYM1) (QUOTE ENTRYPOINT) (QUOTE "L3460")) (PUT (QUOTE FORMATFORPRINTF!*) (QUOTE IDNUMBER) (QUOTE 692)) (FLAG (QUOTE (FORMATFORPRINTF!*)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE DIGITTONUMBER) (QUOTE ENTRYPOINT) (QUOTE "L2534")) (PUT (QUOTE DIGITTONUMBER) (QUOTE IDNUMBER) (QUOTE 650)) (PUT (QUOTE FCODEP) (QUOTE ENTRYPOINT) (QUOTE FCODEP)) (PUT (QUOTE FCODEP) (QUOTE IDNUMBER) (QUOTE 520)) (PUT (QUOTE MAKEFCODE) (QUOTE ENTRYPOINT) (QUOTE "L3167")) (PUT (QUOTE MAKEFCODE) (QUOTE IDNUMBER) (QUOTE 754)) (PUT (QUOTE GLOBALINSTALL) (QUOTE ENTRYPOINT) (QUOTE "L3483")) (PUT (QUOTE GLOBALINSTALL) (QUOTE IDNUMBER) (QUOTE 788)) (PUT (QUOTE CHANNELPRIN) (QUOTE IDNUMBER) (QUOTE 686)) (PUT (QUOTE DN) (QUOTE ENTRYPOINT) (QUOTE DN)) (PUT (QUOTE DN) (QUOTE IDNUMBER) (QUOTE 267)) (PUT (QUOTE PRIN2T) (QUOTE ENTRYPOINT) (QUOTE PRIN2T)) (PUT (QUOTE PRIN2T) (QUOTE IDNUMBER) (QUOTE 365)) (PUT (QUOTE DISPLAYHELPFILE) (QUOTE IDNUMBER) (QUOTE 457)) (PUT (QUOTE !$LOOP!$) (QUOTE IDNUMBER) (QUOTE 742)) (PUT (QUOTE GLOBALP) (QUOTE ENTRYPOINT) (QUOTE "L3271")) (PUT (QUOTE GLOBALP) (QUOTE IDNUMBER) (QUOTE 771)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L1192")) (PUT (QUOTE BNDSTKLOWERBOUND) (QUOTE WVAR) (QUOTE BNDSTKLOWERBOUND)) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE ENTRYPOINT) (QUOTE "L2536")) (PUT (QUOTE MAKESTRINGINTOLISPINTEGER) (QUOTE IDNUMBER) (QUOTE 649)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE SCOPE) (QUOTE EXTERNAL)) (PUT (QUOTE STACKUPPERBOUND) (QUOTE ASMSYMBOL) (QUOTE "L2107")) (PUT (QUOTE STACKUPPERBOUND) (QUOTE WVAR) (QUOTE STACKUPPERBOUND)) (PUT (QUOTE CADAR) (QUOTE ENTRYPOINT) (QUOTE CADAR)) (PUT (QUOTE CADAR) (QUOTE IDNUMBER) (QUOTE 214)) (PUT (QUOTE COND) (QUOTE ENTRYPOINT) (QUOTE COND)) (PUT (QUOTE COND) (QUOTE IDNUMBER) (QUOTE 278)) (PUT (QUOTE OPEN) (QUOTE ENTRYPOINT) (QUOTE OPEN)) (PUT (QUOTE OPEN) (QUOTE IDNUMBER) (QUOTE 602)) (PUT (QUOTE UPDATEHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1296")) (PUT (QUOTE RETURN) (QUOTE ENTRYPOINT) (QUOTE RETURN)) (PUT (QUOTE RETURN) (QUOTE IDNUMBER) (QUOTE 545)) (PUT (QUOTE BINARYOPENWRITE) (QUOTE ENTRYPOINT) (QUOTE "L2128")) (PUT (QUOTE BINARYOPENWRITE) (QUOTE IDNUMBER) (QUOTE 551)) (PUT (QUOTE ONEARGDISPATCH) (QUOTE ENTRYPOINT) (QUOTE "L1396")) (PUT (QUOTE INTLOR) (QUOTE ENTRYPOINT) (QUOTE INTLOR)) (PUT (QUOTE ONEARGERROR) (QUOTE ENTRYPOINT) (QUOTE "L1405")) (PUT (QUOTE MAKEIDFREELIST) (QUOTE ENTRYPOINT) (QUOTE "L1207")) (PUT (QUOTE CHANNELPRINC) (QUOTE ENTRYPOINT) (QUOTE "L2357")) (PUT (QUOTE CHANNELPRINC) (QUOTE IDNUMBER) (QUOTE 629)) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE ENTRYPOINT) (QUOTE "L2824")) (PUT (QUOTE RECURSIVECHANNELPRIN1) (QUOTE IDNUMBER) (QUOTE 681)) (PUT (QUOTE GTVECT) (QUOTE ENTRYPOINT) (QUOTE GTVECT)) (PUT (QUOTE GTVECT) (QUOTE IDNUMBER) (QUOTE 142)) (PUT (QUOTE REMFLAG1) (QUOTE ENTRYPOINT) (QUOTE "L3225")) (PUT (QUOTE REMFLAG1) (QUOTE IDNUMBER) (QUOTE 762)) (PUT (QUOTE !*CONTINUABLEERROR) (QUOTE IDNUMBER) (QUOTE 482)) (FLAG (QUOTE (!*CONTINUABLEERROR)) (QUOTE NILINITIALVALUE)) (PUT (QUOTE VECTOREQUAL) (QUOTE ENTRYPOINT) (QUOTE "L0466")) (PUT (QUOTE INTERSECTION) (QUOTE ENTRYPOINT) (QUOTE XN)) (PUT (QUOTE INTERSECTION) (QUOTE IDNUMBER) (QUOTE 384)) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE ENTRYPOINT) (QUOTE "L2573")) (PUT (QUOTE MAKEINPUTAVAILABLE) (QUOTE IDNUMBER) (QUOTE 638)) (PUT (QUOTE EVAND1) (QUOTE ENTRYPOINT) (QUOTE EVAND1)) (PUT (QUOTE RPLACW) (QUOTE ENTRYPOINT) (QUOTE RPLACW)) (PUT (QUOTE RPLACW) (QUOTE IDNUMBER) (QUOTE 352)) (PUT (QUOTE FINDFIRST) (QUOTE ENTRYPOINT) (QUOTE "L1640")) (PUT (QUOTE DEC20OPEN) (QUOTE ENTRYPOINT) (QUOTE "L3534")) (PUT (QUOTE DEC20OPEN) (QUOTE IDNUMBER) (QUOTE 550)) (PUT (QUOTE MKEVECT) (QUOTE IDNUMBER) (QUOTE 413)) (PUT (QUOTE COMPACTHEAP) (QUOTE ENTRYPOINT) (QUOTE "L1210")) (PUT (QUOTE CHANNELWRITEBITSTRING) (QUOTE ENTRYPOINT) (QUOTE "L2586")) (PUT (QUOTE QUIT) (QUOTE ENTRYPOINT) (QUOTE QUIT)) (PUT (QUOTE QUIT) (QUOTE IDNUMBER) (QUOTE 421)) (PUT (QUOTE TRST) (QUOTE ENTRYPOINT) (QUOTE TRST)) (PUT (QUOTE TRST) (QUOTE IDNUMBER) (QUOTE 436)) (PUT (QUOTE FLOATP) (QUOTE ENTRYPOINT) (QUOTE FLOATP)) (PUT (QUOTE FLOATP) (QUOTE IDNUMBER) (QUOTE 189)) (PUT (QUOTE CADAAR) (QUOTE ENTRYPOINT) (QUOTE CADAAR)) (PUT (QUOTE CADAAR) (QUOTE IDNUMBER) (QUOTE 213)) (PUT (QUOTE FILEP) (QUOTE ENTRYPOINT) (QUOTE FILEP)) (PUT (QUOTE FILEP) (QUOTE IDNUMBER) (QUOTE 372)) (PUT (QUOTE FLOATPLUS2) (QUOTE ENTRYPOINT) (QUOTE "L1427")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE ENTRYPOINT) (QUOTE "L2600")) (PUT (QUOTE CHANNELWRITESYSFLOAT) (QUOTE IDNUMBER) (QUOTE 666)) (PUT (QUOTE !#ARG) (QUOTE IDNUMBER) (QUOTE 728)) (PUT (QUOTE MAP2) (QUOTE ENTRYPOINT) (QUOTE MAP2)) (PUT (QUOTE MAP2) (QUOTE IDNUMBER) (QUOTE 361)) (PUT (QUOTE EDIT) (QUOTE ENTRYPOINT) (QUOTE EDIT)) (PUT (QUOTE EDIT) (QUOTE IDNUMBER) (QUOTE 441)) (PUT (QUOTE STRING) (QUOTE ENTRYPOINT) (QUOTE STRING)) (PUT (QUOTE STRING) (QUOTE IDNUMBER) (QUOTE 185)) (PUT (QUOTE LESSP) (QUOTE ENTRYPOINT) (QUOTE LESSP)) (PUT (QUOTE LESSP) (QUOTE IDNUMBER) (QUOTE 290)) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE ENTRYPOINT) (QUOTE "L2796")) (PUT (QUOTE RECURSIVECHANNELPRIN2) (QUOTE IDNUMBER) (QUOTE 679)) (PUT (QUOTE MARKFROMONESYMBOL) (QUOTE ENTRYPOINT) (QUOTE "L1223")) (PUT (QUOTE OK) (QUOTE IDNUMBER) (QUOTE 456)) (PUT (QUOTE POSN) (QUOTE ENTRYPOINT) (QUOTE POSN)) (PUT (QUOTE POSN) (QUOTE IDNUMBER) (QUOTE 622)) |
Added psl-1983/lap/aaa.b version [424818e622].
cannot compute difference between binary files
Added psl-1983/lap/addr2id.b version [665d680d7e].
cannot compute difference between binary files
Added psl-1983/lap/aed.lap version [30bf9cf4d3].
> > | 1 2 | (load emode ann60 prlisp aedio) |
Added psl-1983/lap/aedio.b version [33354cdca3].
cannot compute difference between binary files
Added psl-1983/lap/all-kernel.ctl version [2150df11e6].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | submit types.ctl submit randm.ctl submit alloc.ctl submit arith.ctl submit debg.ctl submit error.ctl submit eval.ctl submit extra.ctl submit fasl.ctl submit io.ctl submit macro.ctl submit prop.ctl submit symbl.ctl submit sysio.ctl submit tloop.ctl submit heap.ctl |
Added psl-1983/lap/all-kernel.log version [8d03c73254].
cannot compute difference between binary files
Added psl-1983/lap/alloc.ctl version [e3dc70fdc8].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "alloc"; in "alloc.build"; ASMEnd; quit; compile alloc.mac, dalloc.mac delete alloc.mac, dalloc.mac |
Added psl-1983/lap/alloc.init version [90df9184c9].
> | 1 | (FLUID (QUOTE (!*GC GCTIME!* GCKNT!* HEAP!-WARN!-LEVEL))) |
Added psl-1983/lap/alloc.log version [6ded50773a].
cannot compute difference between binary files
Added psl-1983/lap/alloc.rel version [ad2d7bec83].
cannot compute difference between binary files
Added psl-1983/lap/ann.lap version [ac322b6541].
> | 1 | (load emode ann60 prlisp ann60!-g) |
Added psl-1983/lap/ann24.b version [9363ae40ba].
cannot compute difference between binary files
Added psl-1983/lap/ann48.b version [d34d7fc97d].
cannot compute difference between binary files
Added psl-1983/lap/ann60-g.b version [3ed809c078].
cannot compute difference between binary files
Added psl-1983/lap/ann60.b version [c292fb1b48].
cannot compute difference between binary files
Added psl-1983/lap/apply-lap.red version [9d186bbfb2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % APPLY-LAP.RED - LAP support for EVAL and APPLY % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 20 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.NEW>APPLY-LAP.RED.2, 9-Dec-82 18:13:02, Edit by PERDUE % Modified UndefinedFunction to make it continuable CompileTime flag('(FastLambdaApply), 'InternalFunction); on SysLisp; external WVar BndStkPtr, BndStkUpperBound; % TAG( CodeApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeApply expr 2) %. CodeApply(CodePointer, ArgList) % % r1 is code pointer, r2 is list of arguments % (!*MOVE (reg 1) (reg t1)) (!*MOVE (reg 2) (reg t2)) (!*MOVE (WConst 1) (reg t3)) Loop (!*JUMPNOTTYPE (MEMORY (REG T1) (WConst 0)) (reg t2) PAIR) % jump to code if list is exhauseted (!*MOVE (CAR (reg t2)) (reg t4)) (!*MOVE (reg t4) (MEMORY (reg t3) 0)) % load argument register (!*MOVE (CDR (reg t2)) (reg t2)) (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % skip if neq MaxRegs+1 (!*MOVE (WConst ArgumentBlock) (reg t3)) % else switch to extra args (!*JUMPWLEQ (Label Loop) (reg t3) (WConst (plus2 9 (WConst ArgumentBlock)))) (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( CodeEvalApply ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure CodeEvalApply(CodePtr, ArgList); % begin scalar N; % N := 0; % while PairP ArgList do % << N := N + 1; % ArgumentRegister[N] := Eval car ArgList; % ArgList := cdr ArgList >>; % (jump to address of code pointer) % end; lap '((!*entry CodeEvalApply expr 2) %. CodeApply(CodePointer, EvLis Args) % % r1 is code pointer, r2 is list of arguments to be evaled % (!*PUSH (reg 1)) % code pointer goes on the bottom (!*PUSH (WConst 0)) % then arg count Loop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label Done) (reg 2) PAIR) (!*JUMPWLESSP (Label ArgOverflow) (frame 1) (WConst -15)) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 2)) % save the cdr (!*CALL Eval) % eval the car (!*POP (reg 2)) % grab the list in r2 again (!*POP (reg 3)) % get count in r3 (!*WDIFFERENCE (reg 3) (WConst 1)) % decrement count (!*PUSH (reg 1)) % push the evaled arg (!*PUSH (reg 3)) % and the decremented count (!*JUMP (Label Loop)) Done (!*POP (reg 3)) % count in r3, == -no. of args to pop (!*JUMP (MEMORY (reg 3) (Label ZeroArgs))) % indexed jump (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 9)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 8)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 7)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 6)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 5)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 4)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 3)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 2)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 1)) (WConst 0))) (!*POP (MEMORY (WConst (plus2 (WArray ArgumentBlock) 0)) (WConst 0))) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) ZeroArgs (!*POP (reg t1)) % code pointer in (reg t1) (!*JUMP (MEMORY (reg t1) (WConst 0))) % jump to address ArgOverflow (!*MOVE (QUOTE "Too many arguments to function") (reg 1)) (!*JCALL StdError) ); % TAG( BindEval ) % if this could be written in Syslisp, it would look something like this: % syslsp procedure BindEval(Formals, Args); % begin scalar N; % N := 0; % while PairP Args and PairP Formals do % << N := N + 1; % Push Eval car ArgList; % Push car Formals; % ArgList := cdr ArgList >>; % if PairP Args or PairP Formals then return -1; % for I := 1 step 1 until N do % LBind1(Pop(), Pop()); % return N; % end; lap '((!*entry BindEval expr 2) %. BindEval(FormalsList, ArgsToBeEvaledList); % % r1 is list of formals, r2 is list of arguments to be evaled % (!*PUSH (WConst 0)) % count on the bottom (!*MOVE (WConst 0) (reg 4)) (!*MOVE (reg 1) (reg 3)) % shift arg1 to r3 EvalLoop % if it's not a pair, then we're done (!*JUMPNOTTYPE (Label DoneEval) (reg 2) PAIR) (!*MOVE (CAR (reg 2)) (reg 1)) (!*MOVE (CDR (reg 2)) (reg 2)) (!*PUSH (reg 3)) % save the formals (!*PUSH (reg 2)) % save the rest of args (!*CALL Eval) % eval the car (!*POP (reg 2)) % save then rest of arglist (!*POP (reg 3)) % and the rest of formals (!*POP (reg 4)) % and the count (!*JUMPNOTTYPE (Label ReturnError) (reg 3) PAIR) % if it's not a pair, then error (!*WPLUS2 (reg 4) (WConst 1)) % increment the count (!*MOVE (CAR (reg 3)) (reg 5)) (!*MOVE (CDR (reg 3)) (reg 3)) (!*PUSH (reg 1)) % push the evaluated argument (!*PUSH (reg 5)) % and next formal (!*PUSH (reg 4)) % and new count (!*JUMP (Label EvalLoop)) ReturnError (!*WSHIFT (reg 4) (WConst 1)) % multiply count by 2 (hrl (reg 4) (reg 4)) % in both halves (sub (reg st) (reg 4)) % move the stack ptr back (!*MOVE (WConst -1) (reg 1)) % return -1 as error indicator (!*EXIT 0) DoneEval (!*DEALLOC 1) % removed saved values at top of stack (!*JUMPTYPE (Label ReturnError) (reg 3) PAIR) % if more formals, error (!*MOVE (reg 4) (reg 3)) % r3 gets decremented, r4 saved for return BindLoop (!*JUMPEQ (Label NormalReturn) (reg 3) (WConst 0)) % if count is zero, then return (!*POP (reg 1)) % pop ID to bind (!*POP (reg 2)) % and value (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*CALL LBind1) (!*POP (reg 4)) (!*POP (reg 3)) (soja (reg 3) BindLoop) NormalReturn (!*MOVE (reg 4) (reg 1)) % return count (!*EXIT 0) ); % TAG( CompiledCallingInterpreted ) % This is pretty gross, but it is essentially the same as LambdaApply, taking % values from the argument registers instead of a list. % if this could be written in Syslisp, it would look something like this: % syslsp procedure CompiledCallingInterpreted IDOfFunction; % begin scalar LForm, LArgs, N, Result; % LForm := get(IDOfFunction, '!*LambdaLink); % LArgs := cadr LForm; % LForm := cddr LForm; % N := 1; % while PairP LArgs do % << LBind1(car LArgs, ArgumentRegister[N]; % LArgs := cdr LArgs; % N := N + 1 >>; % Result := EvProgN LForm; % UnBindN(N - 1); % return Result; % end; lap '((!*entry CompiledCallingInterpreted expr 0) %. link for lambda % % called by JSP T5, from function cell % (!*MOVE (reg t5) (reg t1)) (!*WDIFFERENCE (reg t1) (WConst (plus2 (WConst SymFnc) 1))) (!*MKITEM (reg t1) (WConst BtrTag)) (!*PUSH (reg t1)) % make stack mark for btrace (!*MOVE (MEMORY (reg t1) (WConst SymPrp)) (reg t1)) % load prop list LoopFindProp (!*JUMPNOTTYPE (Label PropNotFound) (reg t1) PAIR) (!*MOVE (CAR (reg t1)) (reg t2)) % get car of prop list (!*MOVE (CDR (reg t1)) (reg t1)) % cdr down (!*JUMPNOTTYPE (Label LoopFindProp) (reg t2) PAIR) (!*MOVE (CAR (reg t2)) (reg t3)) % its a pair, look at car (!*JUMPNOTEQ (Label LoopFindProp) (reg t3) '!*LambdaLink) (!*MOVE (CDR (reg t2)) (reg t2)) % yes, get lambda form (!*entry FastLambdaApply expr 0) % called from FastApply (!*MOVE (CDR (reg t2)) (reg t2)) % get cdr of lambda form (!*MOVE (CDR (reg t2)) (reg t1)) % save cddr in (reg t1) (!*MOVE (CAR (reg t2)) (reg t2)) % cadr of lambda == arg list (!*MOVE (WConst 1) (reg t3)) % pointer to arg register in t3 (!*MOVE (WVar BndStkPtr) (reg t4)) % binding stack pointer in t4 (!*PUSH (reg t4)) % save it on the stack LoopBindingFormals (!*JUMPNOTTYPE (Label DoneBindingFormals) (reg t2) PAIR) (!*WPLUS2 (reg t4) (WConst 2)) % adjust binding stack pointer up 2 (caml (reg t4) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (!*MOVE (CAR (reg t2)) (reg t5)) % get formal in t5 (hrrzm (reg t5) (Indexed (reg t4) -1)) % store ID number in BndStk (!*MOVE (MEMORY (reg t5) (WArray SymVal)) (reg t6)) % get old value (!*MOVE (reg t6) (MEMORY (reg t4) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t6)) % get reg value in t6 (!*MOVE (reg t6) (MEMORY (reg t5) (WConst SymVal))) % put in value cell (!*MOVE (CDR (reg t2)) (reg t2)) % cdr down argument list (!*WPLUS2 (reg t3) (WConst 1)) % increment register pointer (cain (reg t3) (plus2 (WConst MaxRealRegs) 1)) % Go to extra args? (movei (reg t3) (WArray ArgumentBlock)) % Yes (!*JUMP (Label LoopBindingFormals)) % No DoneBindingFormals (!*MOVE (reg t4) (WVar BndStkPtr)) % store binding stack (!*MOVE (reg t1) (reg 1)) % get cddr of lambda form to eval (!*CALL EvProgN) % implicit progn (exch (reg 1) (Indexed (reg st) 0)) % save result, get old bind stk ptr (!*CALL RestoreEnvironment) (!*POP (reg 1)) % restore old bindings and pickup value (!*EXIT 1) % throw away backtrace mark and return PropNotFound (!*MOVE (QUOTE "Internal error in function calling mechanism; consult a wizard") (reg 1)) (!*JCALL StdError) ); % TAG( FastApply ) lap '((!*entry FastApply expr 0) %. Apply with arguments loaded % % Called with arguments in the registers and functional form in (reg t1) % (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*JUMPEQ (MEMORY (reg t1) (WConst SymFnc)) (reg t2) (WConst ID)) (!*JUMPEQ (MEMORY (reg t1) (WConst 0)) (reg t2) (WConst CODE)) (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR)) (!*MOVE (CAR (reg t1)) (reg t2)) (!*JUMPNOTEQ IllegalFunctionalForm (reg t2) (QUOTE LAMBDA)) (!*MOVE (reg t1) (reg t2)) % put lambda form in (reg t2) (!*PUSH '()) % align stack (!*JCALL FastLambdaApply) IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form %r in Apply") (reg 1)) (!*MOVE (reg t1) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); % TAG( UndefinedFunction ) lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code % % also called by JSP T5, % (!*WDIFFERENCE (reg t5) (wconst 1)) % T5 now points to the function entry slot of the atom that % is undefined as a function. % We will push the entry address onto the stack and transfer % to it by a POPJ at the end of this routine. (!*PUSH (reg t5)) (!*PUSH (reg 1)) % Save all the regs (including fakes) (args) (!*PUSH (reg 2)) (!*PUSH (reg 3)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*WDIFFERENCE (reg t5) (WConst SymFnc)) (!*MKITEM (reg t5) (WConst ID)) (!*MOVE (reg t5) (reg 2)) (!*MOVE (QUOTE "Undefined function %r called from compiled code") (reg 1)) (!*CALL BldMsg) (!*MOVE (reg 1) (reg 2)) (!*MOVE (WConst 0) (reg 1)) (!*MOVE (reg NIL) (reg 3)) (!*CALL ContinuableError) (!*POP (reg 15)) % Restore all those possible arguments (!*POP (reg 14)) (!*POP (reg 13)) (!*POP (reg 12)) (!*POP (reg 11)) (!*POP (reg 10)) (!*POP (reg 9)) (!*POP (reg 8)) (!*POP (reg 7)) (!*POP (reg 6)) (!*POP (reg 5)) (!*POP (reg 4)) (!*POP (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (!*EXIT 0) ); off SysLisp; END; |
Added psl-1983/lap/arith.b version [bf0c14b07d].
cannot compute difference between binary files
Added psl-1983/lap/arith.ctl version [c16d352751].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "arith"; in "arith.build"; ASMEnd; quit; compile arith.mac, darith.mac delete arith.mac, darith.mac |
Added psl-1983/lap/arith.init version [a7ffc6f8bf].
Added psl-1983/lap/arith.log version [7d541a60ba].
cannot compute difference between binary files
Added psl-1983/lap/arith.rel version [092003b6d1].
cannot compute difference between binary files
Added psl-1983/lap/association.b version [9d6748af8d].
cannot compute difference between binary files
Added psl-1983/lap/bare-psl.sym version [14527ad530].
> > > > | 1 2 3 4 | (setq OrderedIDList!* (NCons NIL)) (setq UncompiledExpressions!* (NCons NIL)) (setq ToBeCompiledExpressions!* (NCons NIL)) (setq NextIDNumber!* 129) |
Added psl-1983/lap/big-faslend.b version [facb3ba389].
cannot compute difference between binary files
Added psl-1983/lap/big.lap version [653e638d63].
> | 1 | (load arith vector-fix bigbig bigface) |
Added psl-1983/lap/bigbig.b version [94db9088c2].
cannot compute difference between binary files
Added psl-1983/lap/bigface.b version [8a418e831d].
cannot compute difference between binary files
Added psl-1983/lap/br-unbr.b version [e549998c81].
cannot compute difference between binary files
Added psl-1983/lap/bug.b version [fc9b82c9cd].
cannot compute difference between binary files
Added psl-1983/lap/buggy-prlisp-2.b version [ac553da577].
cannot compute difference between binary files
Added psl-1983/lap/build.b version [5980485bc3].
cannot compute difference between binary files
Added psl-1983/lap/chars.b version [f34fdde413].
cannot compute difference between binary files
Added psl-1983/lap/clcomp.lap version [1b321e3ada].
> | 1 | (LOAD USEFUL CLCOMP1) |
Added psl-1983/lap/clcomp1.b version [1c12efa998].
cannot compute difference between binary files
Added psl-1983/lap/cntrl.b version [aa3ee58e99].
cannot compute difference between binary files
Added psl-1983/lap/common.b version [ef6c589801].
cannot compute difference between binary files
Added psl-1983/lap/comp-decls.b version [88f7436253].
cannot compute difference between binary files
Added psl-1983/lap/compiler.b version [c77ddaad09].
cannot compute difference between binary files
Added psl-1983/lap/cvtmail.:ej version [d6ecc2a559].
cannot compute difference between binary files
Added psl-1983/lap/cvtmail.emacs version [ceef4a190e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | !~Filename~:! !For dealing with PSL bug reports.! CVTMAIL !Cut Header:! !C Removes unwanted fields from a mail header. One must already be positioned at the start of a mail header. Cursor is left at the beginning of the next mail header.! [1 [2 k .u1 -l .,.+9:fb------- !* Kill preceding mail trailer, if any! "L -l ki '"# q1j' MM&_Fix_Mail-From l !* Skip initial date line! !loop! !* Kill uninteresting header lines! .u1 l .-q1-2"E Odone' q1j .,.+6:fbFrom:_ "LOmatch' .,.+9:fbSubject:_ "LOmatch' .,.+7:fbClass:_ "LOmatch' k Oloop !match! l Oloop !done! MM^R_Set/Pop_Mark <MM&_Header? !* Find a mail header line! q0"E l'"# 1;' !* Exit loop if found! > -l 2MM^R_Indent_Rigidly !* Indent the body of the message! l !& Header?:! !C -1 if current line is header line else 0.! .u0 0l z-.-24 :"G Onomatch' 3a-- "N Onomatch' 7a-- "N Onomatch' 13a-: "N Onomatch' 16a-: "N Onomatch' 19a-- "N Onomatch' 23a-, "N Onomatch' q0j -1u0 !nomatch! q0j 0u0 !& Fix Mail-From:! !C Fixes up any initial "Mail-from:" line. Some "date" lines actually begin with "Mail-from" and contain additional information not wanted here. Cursor is left at the beginning of the same line it started on.! .,.+10:FBMail-from: :"L Oend' 0l iDate: 1MM^R_Kill_Word 1MM^R_Kill_Word 1MM^R_Kill_Word 1MM^R_Kill_Word !end! 0l !Reverse Mail List:! !C Reverses a bufferful of mail messages. The idea is to move forward through the file putting messages found later in front of all found sooner.! [0 [1 [2 [3 .u2 !* q2 has loc of last header found! < .-z "E ' !* Stop reversing if at end of buffer! < !* Find "end of message"! l !* Go to next line! .-z @; !* Exit if at end of buffer! MM&_Header? q0 :@; !* Exit if header line (q0 nonzero)! > !* End of message now found! q2u1 !* Now q1 has prev. header! .u2 !* q2 has next header loc! q1,q2x3 !* Save message in q3! q1,q2k !* Kill message! bj g3 !* Put at front of buffer! q2j !* Go to where left off! > |
Added psl-1983/lap/dalloc.rel version [ecbbc32e10].
cannot compute difference between binary files
Added psl-1983/lap/darith.rel version [208207b6ff].
cannot compute difference between binary files
Added psl-1983/lap/datetime.b version [80666d44c3].
cannot compute difference between binary files
Added psl-1983/lap/ddebg.rel version [7cb75599b6].
cannot compute difference between binary files
Added psl-1983/lap/debg.ctl version [1049f624a3].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "debg"; in "debg.build"; ASMEnd; quit; compile debg.mac, ddebg.mac delete debg.mac, ddebg.mac |
Added psl-1983/lap/debg.init version [b3fc2d6e9f].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (PUT (QUOTE TR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE TRST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (QEDITFNS !*EXPERT !*VERBOSE PROMPTSTRING!* EDITORREADER!* EDITORPRINTER!* CL))) (UNFLUID (QUOTE (CL))) (PUT (QUOTE EDIT) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITF) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (PUT (QUOTE EDITOR) (QUOTE HELPFUNCTION) (QUOTE EHELP)) (FLUID (QUOTE (IGNOREDINBACKTRACE!* OPTIONS!* INTERPRETERFUNCTIONS!*))) |
Added psl-1983/lap/debg.log version [23605f3cf8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 15:32:02 BATCON Version 104(4133) GLXLIB Version 1(527) Job DEBG Req #258 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 796 Input from => PS:<PSL.KERNEL.20>DEBG.CTL.2 Output to => PS:<PSL.KERNEL.20>DEBG.LOG 15:32:03 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 15:32:03 MONTR @SET TIME-LIMIT 1200 15:32:03 MONTR @LOGIN KESSLER SMALL 15:32:07 MONTR Job 12 on TTY225 7-Mar-83 15:32:07 15:32:07 MONTR Previous login at 7-Mar-83 15:29:04 15:32:08 MONTR There is 1 other job logged in as user KESSLER 15:32:31 MONTR @ 15:32:31 MONTR [PS Mounted] 15:32:31 MONTR 15:32:31 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 15:32:31 MONTR define DSK: DSK:, P20:, PI: 15:32:32 MONTR @S:DEC20-CROSS.EXE 15:32:35 USER Dec 20 cross compiler 15:32:36 USER [8] ASMOut "debg"; 15:32:38 USER ASMOUT: IN files; or type in expressions 15:32:38 USER When all done execute ASMEND; 15:33:11 USER [9] in "debg.build"; 15:33:11 USER % 15:33:11 USER % DEBG.BUILD - Minor debugging tools in the interpreter 15:33:11 USER % 15:33:11 USER % Author: Eric Benson 15:33:11 USER % Symbolic Computation Group 15:33:11 USER % Computer Science Dept. 15:33:11 USER % University of Utah 15:33:11 USER % Date: 19 May 1982 15:33:11 USER % Copyright (c) 1982 University of Utah 15:33:12 USER % 15:33:12 USER 15:33:12 USER PathIn "mini-trace.red"$ 15:33:13 USER *** Function `TR' has been redefined 15:33:14 USER *** Function `TRST' has been redefined 15:33:15 USER % simple function tracing 15:33:15 USER PathIn "mini-editor.red"$ 15:33:46 USER *** Garbage collection starting 15:34:08 USER *** GC 4: time 3081 ms 15:34:08 USER *** 76422 recovered, 564 stable, 13013 active, 76423 free 15:34:12 USER 15:34:12 USER PathIn "backtrace.red"$ % Stack backtrace 15:34:21 USER [10] ASMEnd; 15:34:50 USER NIL 15:34:51 USER [11] quit; 15:34:52 MONTR @compile debg.mac, ddebg.mac 15:34:58 USER MACRO: .MAIN 15:35:08 USER MACRO: .MAIN 15:35:09 USER 15:35:09 USER EXIT 15:35:09 MONTR @delete debg.mac, ddebg.mac 15:35:09 MONTR DEBG.MAC.1 [OK] 15:35:09 MONTR DDEBG.MAC.1 [OK] 15:35:09 MONTR @ 15:35:15 MONTR Killed by OPERATOR, TTY 221 15:35:15 MONTR Killed Job 12, User KESSLER, Account SMALL, TTY 225, 15:35:15 MONTR at 7-Mar-83 15:35:14, Used 0:00:55 in 0:03:07 |
Added psl-1983/lap/debg.rel version [722f00949b].
cannot compute difference between binary files
Added psl-1983/lap/debug.b version [09861b3094].
cannot compute difference between binary files
Added psl-1983/lap/dec20-asm.b version [d3bc2f72c7].
cannot compute difference between binary files
Added psl-1983/lap/dec20-cmac.b version [a9549fed97].
cannot compute difference between binary files
Added psl-1983/lap/dec20-comp.b version [67e63bc909].
cannot compute difference between binary files
Added psl-1983/lap/dec20-lap.b version [c5dc891618].
cannot compute difference between binary files
Added psl-1983/lap/default-terminal.b version [83ff82d758].
cannot compute difference between binary files
Added psl-1983/lap/defstruct.b version [b0ae653430].
cannot compute difference between binary files
Added psl-1983/lap/derror.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/lap/deval.rel version [d97d731af5].
cannot compute difference between binary files
Added psl-1983/lap/dextra.rel version [f67a44f637].
cannot compute difference between binary files
Added psl-1983/lap/dfasl.rel version [ab260c6efd].
cannot compute difference between binary files
Added psl-1983/lap/dheap.rel version [554e89886d].
cannot compute difference between binary files
Added psl-1983/lap/dio.rel version [9b32eea120].
cannot compute difference between binary files
Added psl-1983/lap/dir-stuff.b version [52bddf12d4].
cannot compute difference between binary files
Added psl-1983/lap/directory.b version [58718aa179].
cannot compute difference between binary files
Added psl-1983/lap/display-char.b version [3124ab63cb].
cannot compute difference between binary files
Added psl-1983/lap/dm1520.b version [8f5dd369fa].
cannot compute difference between binary files
Added psl-1983/lap/dmacro.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/lap/dmain.mac version [baa1191025].
more than 10,000 changes
Added psl-1983/lap/dmain.rel version [6ea8cdee1f].
cannot compute difference between binary files
Added psl-1983/lap/dprop.rel version [421cbc9ea7].
cannot compute difference between binary files
Added psl-1983/lap/drandm.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/lap/dsymbl.rel version [0075d86440].
cannot compute difference between binary files
Added psl-1983/lap/dsysio.rel version [b991baa3d8].
cannot compute difference between binary files
Added psl-1983/lap/dtloop.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/lap/dtypes.rel version [6b68bba2e6].
cannot compute difference between binary files
Added psl-1983/lap/dumplisp.red version [0a95f0bce4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DUMPLISP.RED - Dump running Lisp into a file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 25 April 1982 % Copyright (c) 1982 University of Utah % % <PSL.KERNEL-20>DUMPLISP.RED.2, 5-Oct-82 10:57:34, Edit by BENSON % Removed DumpFileName!* added filename arg to Dumplisp % <PSL.20-INTERP>DUMPLISP.RED.7, 3-Sep-82 10:22:46, Edit by BENSON % Fixed page boundary bug when unmapping stack CompileTime << flag('(unmap!-space unmap!-pages save!-into!-file), 'InternalFunction); >>; on Syslisp; external WVar HeapLast, HeapUpperBound, NextBPS, LastBPS, StackUpperBound; syslsp procedure DumpLisp Filename; << if not StringP Filename then StdError "Dumplisp requires a filename argument"; Reclaim; unmap!-space(HeapLast, HeapUpperBound); unmap!-space(NextBPS, LastBPS); %% Add some slack to the end of the stack fo the call to unmap-space! unmap!-space(MakeAddressFromStackPointer ST + 10, StackUpperBound); save!-into!-file Filename >>; syslsp procedure unmap!-space(Lo, Hi); begin scalar LoPage, HiPage; LoPage := LSH(Lo + 8#777, -9); HiPage := LSH(Hi - 8#1000, -9); return if not (LoPage >= HiPage) then unmap!-pages(LoPage, HiPage - LoPage); end; lap '((!*entry unmap!-pages expr 2) (hrlzi 3 2#100000000000000000) % pm%cnt in AC3 (hrr 3 2) % page count in rh AC3 (hrlzi 2 8#400000) % .fhslf in lh AC2 (hrr 2 1) % starting page in rh AC2 (!*MOVE (WConst -1) (REG 1)) % -1 in AC1 (pmap) % do it (!*EXIT 0) ); lap '((!*entry save!-into!-file expr 1) (!*MOVE (reg 1) (reg 5)) % save in 5 (move 2 1) % file name in 2 (hrli 2 8#10700) % make a byte pointer (hrlzi 1 2#100000000000000001) % gj%fou + gj%sht (gtjfn) (jrst CouldntOpen) (hrli 1 8#400000) % .fhslf (hrrzi 2 2#101010000000000000) % ss%cpy, ss%rd, ss%exe, all pages (hrli 2 -8#1000) % for Release 4 and before, 1000 pages %/ Change previous line to following line for extended addressing % (tlo 2 8#400000) % large negative number (!*MOVE (WConst 0) (REG 3)) (ssave) (!*MOVE (WConst 0) (REG 1)) (!*EXIT 0) CouldntOpen (!*MOVE '"Couldn't GTJFN `%w' for Dumplisp" (reg 1)) (!*MOVE (reg 5) (reg 2)) (!*CALL BldMsg) (!*JCALL StdError) ); off Syslisp; END; |
Added psl-1983/lap/duseful.b version [c6e8a0a9f8].
cannot compute difference between binary files
Added psl-1983/lap/edc.b version [032a4b3546].
cannot compute difference between binary files
Added psl-1983/lap/emode-b-1.b version [f2e1cb6ecb].
cannot compute difference between binary files
Added psl-1983/lap/emode-b-2.b version [347308c70a].
cannot compute difference between binary files
Added psl-1983/lap/emode.lap version [c13d11bbee].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | (LOAD RAWIO) (LOAD EMODE-B-1) (LOAD EMODE-B-2) % "Fast" file I/O, not available on all machines. (LOAD NEW-FILEIO) % Directory support, not available on all machines. (LOAD DIRECTORY) (LOAD DEFAULT-TERMINAL) |
Added psl-1983/lap/error.ctl version [4360224b98].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "error"; in "error.build"; ASMEnd; quit; compile error.mac, derror.mac delete error.mac, derror.mac |
Added psl-1983/lap/error.init version [83b8b0a3d6].
> > > > > > > | 1 2 3 4 5 6 7 | (FLUID (QUOTE (!*CONTINUABLEERROR ERRORFORM!* BREAKLEVEL!* MAXBREAKLEVEL!* !*EMSGP))) (GLOBAL (QUOTE (EMSG!*))) (GLOBAL (QUOTE (EMSG!*))) (FLUID (QUOTE (!*BACKTRACE !*INNER!*BACKTRACE !*EMSGP !*BREAK BREAKLEVEL!* MAXBREAKLEVEL!* !*CONTINUABLEERROR))) (PUT (QUOTE ERRSET) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/lap/error.log version [ff134c8350].
cannot compute difference between binary files
Added psl-1983/lap/error.rel version [9aef48dada].
cannot compute difference between binary files
Added psl-1983/lap/eval.ctl version [d15fef9f1d].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "eval"; in "eval.build"; ASMEnd; quit; compile eval.mac, deval.mac delete eval.mac, deval.mac |
Added psl-1983/lap/eval.init version [bb976ec1cc].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (FLUID (QUOTE (THROWSIGNAL!* EMSG!* THROWTAG!*))) (PUT (QUOTE CATCH!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-ALL) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE UNWIND!-PROTECT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CATCH) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE !*CATCH) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (PROGJUMPTABLE!* PROGBODY!*))) (PUT (QUOTE PROG) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE GO) (QUOTE TYPE) (QUOTE FEXPR)) |
Added psl-1983/lap/eval.log version [5b58c88d85].
cannot compute difference between binary files
Added psl-1983/lap/eval.rel version [95584f7484].
cannot compute difference between binary files
Added psl-1983/lap/evalhook.b version [9602181bbf].
cannot compute difference between binary files
Added psl-1983/lap/exec.b version [d8f95fb8dc].
cannot compute difference between binary files
Added psl-1983/lap/ext/addr2id.b version [bf88e8deed].
cannot compute difference between binary files
Added psl-1983/lap/ext/association.b version [a78ddbae53].
cannot compute difference between binary files
Added psl-1983/lap/ext/br-undr.b version [e93a0538bd].
cannot compute difference between binary files
Added psl-1983/lap/ext/build.b version [45684475bd].
cannot compute difference between binary files
Added psl-1983/lap/ext/char-macro.b version [6ce081b906].
cannot compute difference between binary files
Added psl-1983/lap/ext/chars.b version [2182653d9c].
cannot compute difference between binary files
Added psl-1983/lap/ext/clcomp.lap version [1b321e3ada].
> | 1 | (LOAD USEFUL CLCOMP1) |
Added psl-1983/lap/ext/clcomp1.b version [ebdcf6d010].
cannot compute difference between binary files
Added psl-1983/lap/ext/common.b version [2008099007].
cannot compute difference between binary files
Added psl-1983/lap/ext/comp-decls.b version [97ed47d714].
cannot compute difference between binary files
Added psl-1983/lap/ext/compiler.b version [7d9f549276].
cannot compute difference between binary files
Added psl-1983/lap/ext/data-machine.b version [23d0e16305].
cannot compute difference between binary files
Added psl-1983/lap/ext/debug.b version [6420b649b4].
cannot compute difference between binary files
Added psl-1983/lap/ext/dec20-asm.b version [549f0b33f5].
cannot compute difference between binary files
Added psl-1983/lap/ext/dec20-cmac.b version [70499d762c].
cannot compute difference between binary files
Added psl-1983/lap/ext/dec20-comp.b version [bae9589070].
cannot compute difference between binary files
Added psl-1983/lap/ext/dec20-lap.b version [69ebc4fa6b].
cannot compute difference between binary files
Added psl-1983/lap/ext/defstruct.b version [efb55bfac0].
cannot compute difference between binary files
Added psl-1983/lap/ext/directory.b version [db5e55f86b].
cannot compute difference between binary files
Added psl-1983/lap/ext/evalhook.b version [b4602b9591].
cannot compute difference between binary files
Added psl-1983/lap/ext/exec.b version [cc6b67f751].
cannot compute difference between binary files
Added psl-1983/lap/ext/extended-char.b version [296a6e0088].
cannot compute difference between binary files
Added psl-1983/lap/ext/f-dstruct.b version [fdb5c49298].
cannot compute difference between binary files
Added psl-1983/lap/ext/faslout.b version [a5019d9b2a].
cannot compute difference between binary files
Added psl-1983/lap/ext/fast-arith.b version [20fe062c4d].
cannot compute difference between binary files
Added psl-1983/lap/ext/fast-defstruct.lap version [f0a97bdde2].
> | 1 | (LOAD DEFSTRUCT SYSLISP INUM FAST!-VECTOR F-DSTRUCT) |
Added psl-1983/lap/ext/fast-int.b version [bea8a2ce02].
cannot compute difference between binary files
Added psl-1983/lap/ext/fast-strings.b version [b1a054aeb7].
cannot compute difference between binary files
Added psl-1983/lap/ext/fast-vector.b version [add420ae88].
cannot compute difference between binary files
Added psl-1983/lap/ext/fast-vectors.b version [3e447ba341].
cannot compute difference between binary files
Added psl-1983/lap/ext/file-primitives.b version [c3ee53b700].
cannot compute difference between binary files
Added psl-1983/lap/ext/file-support.b version [b44738ac6e].
cannot compute difference between binary files
Added psl-1983/lap/ext/find.b version [a7b2467c0e].
cannot compute difference between binary files
Added psl-1983/lap/ext/format.b version [3fd45b67e0].
cannot compute difference between binary files
Added psl-1983/lap/ext/get-command-string.b version [b80cb779f4].
cannot compute difference between binary files
Added psl-1983/lap/ext/graph-tree.b version [6d61ad5053].
cannot compute difference between binary files
Added psl-1983/lap/ext/gsort.b version [e9c928cbff].
cannot compute difference between binary files
Added psl-1983/lap/ext/hash.b version [b5d83c0405].
cannot compute difference between binary files
Added psl-1983/lap/ext/hcons.b version [3f2f50b525].
cannot compute difference between binary files
Added psl-1983/lap/ext/help.b version [8c5b1afa6a].
cannot compute difference between binary files
Added psl-1983/lap/ext/history.b version [3cd10be769].
cannot compute difference between binary files
Added psl-1983/lap/ext/homedir.b version [6c430d65d9].
cannot compute difference between binary files
Added psl-1983/lap/ext/if-system.b version [f13ad6119e].
cannot compute difference between binary files
Added psl-1983/lap/ext/if.b version [07f68b21f5].
cannot compute difference between binary files
Added psl-1983/lap/ext/init-file.b version [0a6a4dd40f].
cannot compute difference between binary files
Added psl-1983/lap/ext/input-stream.b version [2fb7c51f21].
cannot compute difference between binary files
Added psl-1983/lap/ext/inspect.b version [faa4bce18b].
cannot compute difference between binary files
Added psl-1983/lap/ext/inum.b version [cfb176e431].
cannot compute difference between binary files
Added psl-1983/lap/ext/jsys.b version [08159c3702].
cannot compute difference between binary files
Added psl-1983/lap/ext/kernel.b version [a3bbe3812e].
cannot compute difference between binary files
Added psl-1983/lap/ext/lap-to-asm.b version [efde660f8b].
cannot compute difference between binary files
Added psl-1983/lap/ext/loop.b version [1c4cf31a3b].
cannot compute difference between binary files
Added psl-1983/lap/ext/mathlib.b version [e52bbc2055].
cannot compute difference between binary files
Added psl-1983/lap/ext/mini.b version [d66b6d30ef].
cannot compute difference between binary files
Added psl-1983/lap/ext/monsym.b version [38de717c06].
cannot compute difference between binary files
Added psl-1983/lap/ext/nbarith.b version [bcde51d72c].
cannot compute difference between binary files
Added psl-1983/lap/ext/nbig.lap version [072abfcdff].
> | 1 | (load nbarith vector!-fix nbig0) |
Added psl-1983/lap/ext/nbig0.b version [a205dc8326].
cannot compute difference between binary files
Added psl-1983/lap/ext/nmode-20.b version [23d9034aba].
cannot compute difference between binary files
Added psl-1983/lap/ext/nmode-parsing.b version [346add12c7].
cannot compute difference between binary files
Added psl-1983/lap/ext/nstruct.b version [1ccbe48600].
cannot compute difference between binary files
Added psl-1983/lap/ext/numeric-operators.b version [a88056e656].
cannot compute difference between binary files
Added psl-1983/lap/ext/objects.b version [6b6f5b8604].
cannot compute difference between binary files
Added psl-1983/lap/ext/output-stream.b version [77171b378a].
cannot compute difference between binary files
Added psl-1983/lap/ext/package.b version [f70aa3317d].
cannot compute difference between binary files
Added psl-1983/lap/ext/parse-command-string.b version [22720ae852].
cannot compute difference between binary files
Added psl-1983/lap/ext/pass-1-lap.b version [8470707e9d].
cannot compute difference between binary files
Added psl-1983/lap/ext/pathin.b version [d067b38901].
cannot compute difference between binary files
Added psl-1983/lap/ext/pathnames.b version [1c13a8ce69].
cannot compute difference between binary files
Added psl-1983/lap/ext/pathnamex.b version [86d3e52454].
cannot compute difference between binary files
Added psl-1983/lap/ext/pcheck.b version [9c61b365f0].
cannot compute difference between binary files
Added psl-1983/lap/ext/poly.b version [e710c9a052].
cannot compute difference between binary files
Added psl-1983/lap/ext/pp.b version [c94daf63aa].
cannot compute difference between binary files
Added psl-1983/lap/ext/pretty.b version [26948e71ef].
cannot compute difference between binary files
Added psl-1983/lap/ext/process.b version [710d514e97].
cannot compute difference between binary files
Added psl-1983/lap/ext/processor-time.b version [e2b9d7356d].
cannot compute difference between binary files
Added psl-1983/lap/ext/pslcomp-main.b version [1773b46e90].
cannot compute difference between binary files
Added psl-1983/lap/ext/ring-buffer.b version [81df12c16f].
cannot compute difference between binary files
Added psl-1983/lap/ext/rlisp.b version [09eb627d9d].
cannot compute difference between binary files
Added psl-1983/lap/ext/slow-strings.b version [9cf85c25ee].
cannot compute difference between binary files
Added psl-1983/lap/ext/slow-vectors.b version [9e8e1794c6].
cannot compute difference between binary files
Added psl-1983/lap/ext/string-input.b version [1b650fc053].
cannot compute difference between binary files
Added psl-1983/lap/ext/string-search.b version [8f8877246f].
cannot compute difference between binary files
Added psl-1983/lap/ext/strings.b version [31d24befec].
cannot compute difference between binary files
Added psl-1983/lap/ext/stringx.b version [5ab499705b].
cannot compute difference between binary files
Added psl-1983/lap/ext/syslisp-syntax.b version [adde92fb28].
cannot compute difference between binary files
Added psl-1983/lap/ext/syslisp.bee version [bd56830f56].
cannot compute difference between binary files
Added psl-1983/lap/ext/syslisp.lap version [3b53b3cd99].
> | 1 | (load syslisp-syntax data-machine) |
Added psl-1983/lap/ext/useful.b version [10fa847508].
cannot compute difference between binary files
Added psl-1983/lap/ext/util.b version [f3fb08df29].
cannot compute difference between binary files
Added psl-1983/lap/ext/vector-fix.b version [c3b313dff0].
cannot compute difference between binary files
Added psl-1983/lap/ext/wait.b version [5f67bf4d26].
cannot compute difference between binary files
Added psl-1983/lap/ext/zbasic.b version [dc24c4c6e4].
cannot compute difference between binary files
Added psl-1983/lap/ext/zboot.b version [b4ba470132].
cannot compute difference between binary files
Added psl-1983/lap/ext/zfiles.b version [24250affaa].
cannot compute difference between binary files
Added psl-1983/lap/ext/zmacro.b version [f0239d471f].
cannot compute difference between binary files
Added psl-1983/lap/ext/zpedit.b version [f8c995eecd].
cannot compute difference between binary files
Added psl-1983/lap/extended-char.b version [99d5a59578].
cannot compute difference between binary files
Added psl-1983/lap/extra.ctl version [fe2d6a05a0].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "extra"; in "extra.build"; ASMEnd; quit; compile extra.mac, dextra.mac delete extra.mac, dextra.mac |
Added psl-1983/lap/extra.init version [f580ab836a].
> > | 1 2 | (FLUID (QUOTE (SYSTEM_LIST!*))) (COPYD (QUOTE EXITLISP) (QUOTE QUIT)) |
Added psl-1983/lap/extra.log version [8c9788500e].
cannot compute difference between binary files
Added psl-1983/lap/extra.rel version [d492a38145].
cannot compute difference between binary files
Added psl-1983/lap/f-dstruct.b version [ca58e61e14].
cannot compute difference between binary files
Added psl-1983/lap/fasl.ctl version [13a33350de].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "fasl"; in "fasl.build"; ASMEnd; quit; compile fasl.mac, dfasl.mac delete fasl.mac, dfasl.mac |
Added psl-1983/lap/fasl.init version [98e5ba2983].
> > > > > > > > | 1 2 3 4 5 6 7 8 | (FLUID (QUOTE (LOADDIRECTORIES!* LOADEXTENSIONS!* PENDINGLOADS!* !*LOWER !*REDEFMSG !*USERMODE !*INSIDELOAD !*VERBOSELOAD !*PRINTLOADNAMES OPTIONS!*))) (PUT (QUOTE LOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE RELOAD) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DEFSTRUCT) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE HELP) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE CREF) (QUOTE SIMPFG) (QUOTE ((T (CREFON)) (NIL (CREFOFF))))) (PUT (QUOTE SYSLISP) (QUOTE SIMPFG) (QUOTE ((T (LOAD SYSLISP))))) |
Added psl-1983/lap/fasl.log version [3498d4d4fd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 15:48:41 BATCON Version 104(4133) GLXLIB Version 1(527) Job FASL Req #262 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 800 Input from => PS:<PSL.KERNEL.20>FASL.CTL.2 Output to => PS:<PSL.KERNEL.20>FASL.LOG 15:48:42 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 15:48:42 MONTR @SET TIME-LIMIT 1200 15:48:42 MONTR @LOGIN KESSLER SMALL 15:48:46 MONTR Job 13 on TTY225 7-Mar-83 15:48:46 15:48:46 MONTR Previous login at 7-Mar-83 15:44:26 15:48:46 MONTR There is 1 other job logged in as user KESSLER 15:48:59 MONTR @ 15:48:59 MONTR [PS Mounted] 15:48:59 MONTR 15:48:59 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 15:48:59 MONTR define DSK: DSK:, P20:, PI: 15:49:03 MONTR @S:DEC20-CROSS.EXE 15:49:05 USER Dec 20 cross compiler 15:49:07 USER [8] ASMOut "fasl"; 15:49:08 USER ASMOUT: IN files; or type in expressions 15:49:09 USER When all done execute ASMEND; 15:50:57 USER [9] in "fasl.build"; 15:50:59 USER % 15:50:59 USER % FASL.BUILD - Files used for Fasl in the interpreter 15:50:59 USER % 15:50:59 USER % Author: Eric Benson 15:50:59 USER % Symbolic Computation Group 15:50:59 USER % Computer Science Dept. 15:50:59 USER % University of Utah 15:50:59 USER % Date: 19 May 1982 15:50:59 USER % Copyright (c) 1982 University of Utah 15:50:59 USER % 15:50:59 USER 15:50:59 USER PathIn "system-faslout.red"$ 15:51:02 USER PathIn "system-faslin.red"$ 15:51:12 USER PathIn "faslin.red"$ 15:51:42 USER *** Garbage collection starting 15:52:01 USER *** GC 4: time 3388 ms 15:52:01 USER *** 68004 recovered, 564 stable, 21432 active, 68004 free 15:52:15 USER 15:52:15 USER PathIn "load.red"$ 15:52:18 USER *** Function `LOAD' has been redefined 15:52:21 USER *** Function `RELOAD' has been redefined 15:52:35 USER % Standard module FASL loader 15:52:35 USER PathIn "autoload.red"$ % stubs to load modules 15:52:53 USER [10] ASMEnd; 15:53:51 USER *** Garbage collection starting 15:54:19 USER *** GC 5: time 3087 ms 15:54:19 USER *** 73806 recovered, 13587 stable, 2607 active, 73806 free 15:54:51 USER NIL 15:54:52 USER [11] quit; 15:54:55 MONTR @compile fasl.mac, dfasl.mac 15:55:01 USER MACRO: .MAIN 15:55:09 USER MACRO: .MAIN 15:55:10 USER 15:55:10 USER EXIT 15:55:13 MONTR @delete fasl.mac, dfasl.mac 15:55:13 MONTR FASL.MAC.1 [OK] 15:55:14 MONTR DFASL.MAC.1 [OK] 15:55:20 MONTR @ 15:55:27 MONTR Killed by OPERATOR, TTY 221 15:55:27 MONTR Killed Job 13, User KESSLER, Account SMALL, TTY 225, 15:55:27 MONTR at 7-Mar-83 15:55:26, Used 0:01:14 in 0:06:40 |
Added psl-1983/lap/fasl.rel version [d6ff155aea].
cannot compute difference between binary files
Added psl-1983/lap/faslout.b version [30830bbfb1].
cannot compute difference between binary files
Added psl-1983/lap/fast-arith.b version [6ceceed999].
cannot compute difference between binary files
Added psl-1983/lap/fast-binder.red version [65b143359d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FAST-BINDER.RED - Fast binding and unbinding routines in LAP for Dec-20 PSL % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 July 1981 % Copyright (c) 1981 University of Utah % on SysLisp; external WVar BndStkPtr, % The binding stack pointer BndStkLowerBound, % Bottom of the binding stack BndStkUpperBound; % Top of the binding stack % TAG( FastBind ) lap '((!*Entry FastBind expr 0) % Bind IDs to values in registers % % FastBind is called with JSP T5, followed by % regnum,,idnum % ... % (!*MOVE (WVar BndStkPtr) (reg t2)) % load binding stack pointer Loop (!*MOVE (Indexed (reg t5) (WConst 0)) (reg t1)) % get next entry (tlnn (reg t1) 8#777000) % if it's not an instruction (!*JUMP (Label MoreLeft)) % keep binding (!*MOVE (reg t2) (WVar BndStkPtr)) % Otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 0))) % and return MoreLeft (!*WPLUS2 (reg t2) (WConst 2)) % add 2 to binding stack pointer (caml (reg t2) (WVar BndStkUpperBound)) % if overflow occured (!*JCALL BStackOverflow) % then error (hlrz (reg t3) (reg t1)) % stick register number in t3 (caile (reg t3) (WConst MaxRealRegs)) % is it a real register? (!*WPLUS2 (reg t3) % no, move to arg block (WConst (difference (WArray ArgumentBlock) (plus (WConst MaxRealRegs) 1)))) (hrrzm (reg t1) (Indexed (reg t2) (WConst -1))) % store ID number in BndStk (!*MOVE (MEMORY (reg t1) (WConst SymVal)) (reg t4)) % get old value for ID in t4 (!*MOVE (reg t4) (MEMORY (reg t2) (WConst 0))) % store value in BndStk (!*MOVE (MEMORY (reg t3) (WConst 0)) (reg t3)) % get reg value in t3 (!*MOVE (reg t3) (MEMORY (reg t1) (WConst SymVal))) % store in ID value cell (aoja (reg t5) Loop) % try again ); % TAG( FastUnBind ) lap '((!*Entry FastUnBind expr 0) % Unbind last N entries in bind stack % % FastUnBind is called with JSP T5, followed by word containing count to % unbind. % (!*MOVE (WVar BndStkPtr) (reg t1)) % get binding stack pointer in t1 (!*MOVE (MEMORY (reg t5) (WConst 0)) (reg t2)) % count in t2 Loop (!*JUMPWGREATERP (Label MoreLeft) (reg t2) (WConst 0)) % continue if count is > zero (!*MOVE (reg t1) (WVar BndStkPtr)) % otherwise store bind stack pointer (!*JUMP (MEMORY (reg t5) (WConst 1))) % and return MoreLeft (camge (reg t1) (WVar BndStkLowerBound)) % check for underflow (!*JCALL BStackUnderflow) (dmove (reg t3) (Indexed (reg t1) -1)) % get ID # in t3, value in t4 (!*MOVE (reg t4) (MEMORY (reg t3) (WConst SymVal))) % restore to value cell (!*WDIFFERENCE (reg t1) (WConst 2)) % adjust binding stack pointer -2 (soja (reg t2) Loop) % and count down by 1, then try again ); off SysLisp; END; |
Added psl-1983/lap/fast-defstruct.lap version [f0a97bdde2].
> | 1 | (LOAD DEFSTRUCT SYSLISP INUM FAST!-VECTOR F-DSTRUCT) |
Added psl-1983/lap/fast-int.b version [4ca43655e3].
cannot compute difference between binary files
Added psl-1983/lap/fast-strings.b version [ebe9287f5e].
cannot compute difference between binary files
Added psl-1983/lap/fast-vector.b version [c1871038e0].
cannot compute difference between binary files
Added psl-1983/lap/fast-vectors.b version [13961590b7].
cannot compute difference between binary files
Added psl-1983/lap/file-primitives.b version [ef91d6cbac].
cannot compute difference between binary files
Added psl-1983/lap/file-support.b version [71af819841].
cannot compute difference between binary files
Added psl-1983/lap/fileupdate.b version [08ab94307b].
cannot compute difference between binary files
Added psl-1983/lap/find.b version [f8dd9ac3e4].
cannot compute difference between binary files
Added psl-1983/lap/findfiles.b version [8378726125].
cannot compute difference between binary files
Added psl-1983/lap/format.b version [5efc3f36a8].
cannot compute difference between binary files
Added psl-1983/lap/fresh-kernel.ctl version [c603c0893f].
> > > > > | 1 2 3 4 5 | rename 20.SYM PREVIOUS-20.SYM copy PC:BARE-PSL.SYM 20.SYM ; To regenerate the .CTL files: ; PSL:PSL ; (dskin "20-kernel-gen.sl") |
Added psl-1983/lap/fresh-kernel.log version [d228261f26].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | LINK FROM KESSLER, TTY 101 [DO: Execution of PS:<PSL.KERNEL.20>FRESH-KERNEL.CTL.3 started at 7-Mar-83 15:11:40] TOPS-20 Command processor 5(712)-1 @rename 20.SYM PREVIOUS-20.SYM %No such filename - 20.SYM @copy PC:BARE-PSL.SYM 20.SYM <PSL.COMP>BARE-PSL.SYM.1 => 20.SYM.27 [OK] @; To regenerate the .CTL files: ; PSL:PSL ; (dskin "20-kernel-gen.sl") [DO: Execution finished at 7-Mar-83 15:11:56] |
Added psl-1983/lap/fresh.mic version [941abc70a4].
> > > > > > > > | 1 2 3 4 5 6 7 8 | ;; Independant compilation of a DEC20 program ; ; MIC FRESH modulename ; ; Initialize for new sequence of builds ; @delete 'a.SYM @copy P20:bare-20.sym 'A.sym |
Added psl-1983/lap/function-primitives.red version [22e70d1d8c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % FUNCTION-PRIMITIVES.RED - primitives used by PUTD/GETD and EVAL/APPLY % P20: version % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 August 1981 % Copyright (c) 1981 University of Utah % % Every ID has a "function cell". It does not necessarily contain a legal % Lisp item, and therefore should not be accessed directly by Lisp functions. % In this implementation the function cell contains an instruction to be % executed. There are 3 possibilites for this instruction, for which the % following predicates and updating functions exist: % % FUnBoundP(ID) -- the function is not defined % FLambdaLinkP(ID) -- the function is interpreted % FCodeP(ID) -- the function is compiled % % MakeFUnBound(ID) -- undefine the function % MakeFLambdaLink(ID) -- specify that the function is interpreted % MakeFCode(ID, CodePtr) -- specify that the function is compiled, % and that the code resides at the address % associated with CodePtr % % GetFCodePointer(ID) -- returns the contents of the function cell as a % code pointer % These functions currently check that they have proper arguments, but this may % change since they are only used by functions that have checked them already. % Note that MakeFCode is necessarily machine-dependent -- this file currently % contains the PDP-10 version. This function should be moved to a file of % system-dependent routines. Of course, other things in this file will % probably have to change for a different machine as well. on SysLisp; internal WVar UnDefn = 8#265500000000 + &SymFnc IDLoc UndefinedFunction; internal WVar LamLnk = 8#265500000000 % JSP T5,xxx + &SymFnc IDLoc CompiledCallingInterpreted; % currently the WVars UnDefn and LamLnk contain the instructions which will % be found in the function cells of undefined and interpreted functions. syslsp procedure FUnBoundP U; %. does U not have a function defn? if IDP U then SymFnc U eq UnDefn else NonIDError(U, 'FUnBoundP); syslsp procedure FLambdaLinkP U; %. is U an interpreted function? if IDP U then SymFnc U eq LamLnk else NonIDError(U, 'FLambdaLinkP); syslsp procedure FCodeP U; %. is U a compiled function? if IDP U then SymFnc U neq UnDefn and SymFnc U neq LamLnk else NonIDError(U, 'FCodeP); syslsp procedure MakeFUnBound U; %. Make U an undefined function if IDP U then << SymFnc U := UnDefn; NIL >> else NonIDError(U, 'MakeFUnBound); syslsp procedure MakeFLambdaLink U; %. Make U an interpreted function if IDP U then << SymFnc U := LamLnk; NIL >> else NonIDError(U, 'MakeFLambdaLink); syslsp procedure MakeFCode(U, CodePtr); %. Make U a compiled function if IDP U then if CodeP CodePtr then << SymFnc U := CodePtr; PutField(SymFnc U, 0, 9, 8#254); % JRST NIL >> else NonIDError(U, 'MakeFCode); syslsp procedure GetFCodePointer U; %. Get code pointer for U if IDP U then MkCODE SymFnc U else NonIDError(U, 'GetFCodePointer); off SysLisp; END; |
Added psl-1983/lap/gc.red version [08b9a25308].
> | 1 | in "compacting-gc.red"$ |
Added psl-1983/lap/get-command-string.b version [9db11c2f52].
cannot compute difference between binary files
Added psl-1983/lap/getftp.b version [a29e3f6246].
cannot compute difference between binary files
Added psl-1983/lap/glisp.b version [a20a7f0288].
cannot compute difference between binary files
Added psl-1983/lap/global-data.red version [0a173e0d61].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % GLOBAL-DATA.RED - Data used by everyone % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 1 September 1981 % Revised: 31 January 1983 % Copyright (c) 1981 University of Utah % % 31-Jan-83 Nancy Kendzierski % Increased BPSSize to 100000 from 90000; decreased HeapSize to 90000 % from 100000. on SysLisp; exported WConst MaxSymbols = 8000, HeapSize = 90000, MaxObArray = 8209, % first prime above 8192 StackSize = 10000, BPSSize = 100000; exported WConst CompressedBinaryRadix = 8; external WArray SymNam, SymVal, SymFnc, SymPrp; external WVar NextSymbol; exported WConst MaxRealRegs = 5, MaxArgs = 15; external WArray ArgumentBlock; external WArray HashTable; off SysLisp; END; |
Added psl-1983/lap/graph-to-tree.b version [ea7a6e54b6].
cannot compute difference between binary files
Added psl-1983/lap/graph-tree.b version [a580490179].
cannot compute difference between binary files
Added psl-1983/lap/gsort.b version [e49ff3b05d].
cannot compute difference between binary files
Added psl-1983/lap/h-stats-1.b version [a1c11a1c8a].
cannot compute difference between binary files
Added psl-1983/lap/hash.b version [cb6497b505].
cannot compute difference between binary files
Added psl-1983/lap/hcons.b version [5eb03ae7fc].
cannot compute difference between binary files
Added psl-1983/lap/heap-stats.b version [ada996052b].
cannot compute difference between binary files
Added psl-1983/lap/heap.build version [3923a49f69].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % % HEAP.BUILD - Declaration of the heap and BPS % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 May 1982 % Copyright (c) 1982 University of Utah % on Syslisp; exported WArray BPS[BPSSize], Heap[HeapSize]; off Syslisp; END; |
Added psl-1983/lap/heap.ctl version [e189dba0dc].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "heap"; in "heap.build"; ASMEnd; quit; compile heap.mac, dheap.mac delete heap.mac, dheap.mac |
Added psl-1983/lap/heap.init version [a7ffc6f8bf].
Added psl-1983/lap/heap.log version [8cee160820].
cannot compute difference between binary files
Added psl-1983/lap/heap.rel version [be8f5b533e].
cannot compute difference between binary files
Added psl-1983/lap/help.b version [a1a45c560a].
cannot compute difference between binary files
Added psl-1983/lap/history.b version [6fba4c0c7f].
cannot compute difference between binary files
Added psl-1983/lap/homedir.b version [acf3271815].
cannot compute difference between binary files
Added psl-1983/lap/hp-emodex.b version [c0940b18fd].
cannot compute difference between binary files
Added psl-1983/lap/hp2648a.b version [fef3ab5c68].
cannot compute difference between binary files
Added psl-1983/lap/hp9836.b version [16d4827a0c].
cannot compute difference between binary files
Added psl-1983/lap/ibmize.clu version [84b94746fb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IBMIZE -- Extract underline and boldface info. from a % lineprinter file (and convert for the IBM) % % Control chararacters handled: TAB, NL, FF, CR % Other control characters assumed to be printing. % Tab stops assumed every 8 columns. % 9/14/82 Added handling of empty lines at end of page. % Somewhat ugly change. % The pgstream represents the state of output. Pgline % is the current line within the page, beginning at 1. % Emptycount keeps track of saved up lines with no visible % contents. These will be output if a nonempty line arrives % before end of page. pgstream = record[pgline: int, s: stream, emptycount: int] ac = array[char] % Line with possible underscore and/or boldface u_b_line = record[line: array[char], underscore: array[bool], bold: array[bool]] LINE_LENGTH = 150 % maximum printing length of output line main = proc () sin: stream := get_io("read", "Input file: ", "lpt") except others: return end sout: stream := get_io("write", "Output file: ", "ibm") except others: return end process_file(sin, pgstream${s: sout, pgline: 1, emptycount: 0}) stream$close(sin) stream$close(sout) end main % process_file(sin: stream, lout: pgstream) % Reads from sin until end of file, process each line to make % overstriking work, and keeps track of the position on the current % page, inserting form feeds as it deems necessary. process_file = proc (sin: stream, lout: pgstream) oline: u_b_line := u_b_line${line: ac$fill(0, LINE_LENGTH, ' '), underscore: array[bool]$fill(0, LINE_LENGTH, false), bold: array[bool]$fill(0, LINE_LENGTH, false)} sout: stream := lout.s while true do process_line(sin, lout, oline) end except others: end %% stream$putc(sout,'\p') end process_file process_line = proc (sin: stream, lout: pgstream, oline: u_b_line) signals (done) sout: stream := lout.s line: string := get_line(sin) except others: signal done end %% Insert FF if needed. %% if lout.pgline > 60 cand ~ char$equal(string$fetch(line,1),'\p') %% then %% stream$putc (sout, '\p') %% lout.pgline := 1 %% lout.emptycount := 0 %% end for i: int in int$from_to(0,LINE_LENGTH - 1) do oline.line[i] := ' ' oline.underscore[i] := false oline.bold[i] := false end col: int := 0 for c: char in string$chars (line) do %% Special handling for non-printing chars and '_' if c = ' ' then col := col + 1 elseif c = '\r' then col := 0 elseif c = '\n' then lout.pgline := lout.pgline + 1 elseif c = '\b' then col := col - 1 elseif c = '\t' then col := col + 8 - (col // 8) elseif c = '\p' then col := 0 lout.pgline := 1 elseif c = '_' then oline.underscore[col] := true col := col + 1 else oc: char := oline.line[col] if oc = ' ' then oline.line[col] := c elseif oc = c then oline.bold[col] := true end col := col + 1 end end emptyp: bool := true for i: int in int$from_to(0,LINE_LENGTH - 1) do if oline.line[i] ~= ' ' cor oline.underscore[i] then emptyp := false break; end end if emptyp then lout.emptycount := lout.emptycount + 1 else %% Put out any saved-up empty lines first for i:int in int$from_to(1,lout.emptycount) do stream$putc(sout,'\n') end lout.emptycount := 0 %% Print out everything involved in the line. output_line(oline, sout) end %% Print the formfeed that came with (terminating) the line. if char$equal('\p',string$fetch(line,string$size(line))) then stream$putc(sout,'\p') %% Throw away any empty lines just preceding \p lout.emptycount := 0 elseif ~emptyp then stream$putc(sout,'\n') end end process_line % output_line(oline, sout: stream) output_line = proc(oline: u_b_line, sout: stream) high: int := line_high(oline) for i: int in int$from_to (0, high) do stream$putc(sout, oline.line[i]) if oline.underscore[i] then stream$putc(sout, '\b') stream$putc(sout, '_') end end %% stream$putc (sout, '\n') end output_line % line_high (line: u_b_line) returns (int) % Returns the index in the line of the last printing character. % If none exists, returns the minimum index minus 1. line_high = proc(oline: u_b_line) returns (int) for i: int in int$from_to_by(ac$high(oline.line), ac$low(oline.line), -1) do if oline.line[i] ~= ' ' cor oline.underscore[i] then return(i) end end return(ac$low(oline.line) - 1) end line_high % get_line (sin: stream) returns (string) signals (end_of_file) % Reads from the stream characters through the first \n or \p. % If end of file is reached before any characters are entered, % end of file is signalled, otherwise not. % All characters read are returned. get_line = proc (sin: stream) returns (string) signals (end_of_file) a: ac := ac$new () while true do c: char := stream$getc_image (sin) except others: if ac$size (a) = 0 then signal end_of_file end break end ac$addh (a, c) if c = '\n' cor c = '\p' then break end end %% if ac$top (a) = '\r' then ac$remh (a) end except when bounds: end return (string$ac2s (a)) end get_line %%% Defines: get_line line_high main output_line process_file process_line %%% Edited: 14 September 1982 10:41:36 %%% Uses: get_io %%% Written: 14 September 1982 10:45:04 |
Added psl-1983/lap/ibmize.cluprog version [3c26af48ff].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | %%% DebugFile: ps:<hp-psl.misc>ibmize.debug %%% ExecutableFile: ps:<hp-psl.misc>ibmize.exe %%% MainProcedure: main %%% MakeFile: ps:<hp-psl.misc>ibmize.cmd %%% Optimize: F %%% ProgramFile: ps:<hp-psl.misc>ibmize.cluprog %%% SourceFiles: ps:<hp-psl.misc>ibmize.clu ps:<clu.tlib>msg.clu %%% ps:<perdue.utils>get_io.clu %%% XloadFile: ps:<hp-psl.misc>ibmize.xload |
Added psl-1983/lap/ibmize.cmd version [8f3cf0ef6b].
> | 1 | tlink &ps:<hp-psl.misc>ibmize.xload \search:<clu.tlib> \main:main ^ps:<hp-psl.misc>ibmize.exe |
Added psl-1983/lap/ibmize.debug version [6e92fe65d2].
> | 1 | tlink &ps:<hp-psl.misc>ibmize.xload \search:<clu.tlib> \debug |
Added psl-1983/lap/ibmize.exe version [00938c60b2].
cannot compute difference between binary files
Added psl-1983/lap/ibmize.tbin version [5e18c9147d].
cannot compute difference between binary files
Added psl-1983/lap/ibmize.xload version [ece3362003].
> > > | 1 2 3 | ps:<hp-psl.misc>ibmize ps:<clu.tlib>msg ps:<perdue.utils>get_io |
Added psl-1983/lap/if-system.b version [3393cd2370].
cannot compute difference between binary files
Added psl-1983/lap/if.b version [f62d00cea0].
cannot compute difference between binary files
Added psl-1983/lap/init-file.b version [58a8b3e85a].
cannot compute difference between binary files
Added psl-1983/lap/input-stream.b version [be7fc89be5].
cannot compute difference between binary files
Added psl-1983/lap/inspect.b version [0405f3e69d].
cannot compute difference between binary files
Added psl-1983/lap/interrupt.b version [07c8d6769d].
cannot compute difference between binary files
Added psl-1983/lap/inum.b version [9ccc18b9b8].
cannot compute difference between binary files
Added psl-1983/lap/io-data.red version [60828e281d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-DATA.RED - Data structures used by input and output % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>IO-DATA.RED.2, 29-Dec-82 12:19:36, Edit by PERDUE % Added PagePosition array to support LPOSN on SysLisp; internal WConst MaxTokenSize = 5000; exported WString TokenBuffer[MaxTokenSize]; exported WConst MaxChannels = 31; exported WArray ReadFunction = ['TerminalInputHandler, 'WriteOnlyChannel, 'WriteOnlyChannel, 'CompressReadChar, 'WriteOnlyChannel, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], WriteFunction = ['ReadOnlyChannel, 'Dec20WriteChar, 'ToStringWriteChar, 'ExplodeWriteChar, 'FlatSizeWriteChar, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], CloseFunction = ['IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], UnReadBuffer[MaxChannels], LinePosition[MaxChannels], PagePosition[MaxChannels], MaxLine = [0, 80,80, 10000, 10000, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], JFNOfChannel = [8#100,8#101,-1,-1,-1, 0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]; off SysLisp; global '(!$EOL!$); LoadTime(!$EOL!$ := '! ); END; |
Added psl-1983/lap/io.ctl version [465e3ae11a].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "io"; in "io.build"; ASMEnd; quit; compile io.mac, dio.mac delete io.mac, dio.mac |
Added psl-1983/lap/io.init version [01052781df].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | (GLOBAL (QUOTE (!$EOL!$))) (GLOBAL (QUOTE (IN!* OUT!*))) (FLUID (QUOTE (SPECIALREADFUNCTION!* SPECIALWRITEFUNCTION!* SPECIALCLOSEFUNCTION!*))) (GLOBAL (QUOTE (SPECIALRDSACTION!* SPECIALWRSACTION!* IN!* OUT!*))) (FLUID (QUOTE (STDIN!* STDOUT!*))) (GLOBAL (QUOTE (OUT!*))) (FLUID (QUOTE (!*RAISE))) (FLUID (QUOTE (CURRENTREADMACROINDICATOR!* CURRENTSCANTABLE!* !*INSIDESTRUCTUREREAD))) (GLOBAL (QUOTE (TOKTYPE!* LISPSCANTABLE!* IN!* !$EOF!$))) (FLUID (QUOTE (CURRENTSCANTABLE!* !*RAISE !*COMPRESSING !*EOLINSTRINGOK))) (FLUID (QUOTE (OUTPUTBASE!* PRINLENGTH PRINLEVEL CURRENTSCANTABLE!* IDESCAPECHAR!* !*LOWER))) (GLOBAL (QUOTE (LISPSCANTABLE!*))) (FLUID (QUOTE (FORMATFORPRINTF!*))) (FLUID (QUOTE (EXPLODEENDPOINTER!* COMPRESSLIST!* !*COMPRESSING))) (GLOBAL (QUOTE (IN!* OUT!*))) |
Added psl-1983/lap/io.log version [1aa560e0c6].
cannot compute difference between binary files
Added psl-1983/lap/io.rel version [ab35d4e5de].
cannot compute difference between binary files
Added psl-1983/lap/jsys.b version [fd6d447bfd].
cannot compute difference between binary files
Added psl-1983/lap/kernel.b version [bc715c881c].
cannot compute difference between binary files
Added psl-1983/lap/killdir.mic version [297e7de366].
> > > > | 1 2 3 4 | build ss:<psl.'A> kill |
Added psl-1983/lap/lap-to-asm.b version [62b8a322df].
cannot compute difference between binary files
Added psl-1983/lap/lcalc.b version [f3e94eb0bc].
cannot compute difference between binary files
Added psl-1983/lap/loop.b version [89693ca272].
cannot compute difference between binary files
Added psl-1983/lap/macro.ctl version [44fcd1710b].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "macro"; in "macro.build"; ASMEnd; quit; compile macro.mac, dmacro.mac delete macro.mac, dmacro.mac |
Added psl-1983/lap/macro.init version [86d5c6a27d].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (PUT (QUOTE COMMENTOUTCODE) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (COMMENTOUTCODE COMPILETIME)) (QUOTE IGNORE)) (FLAG (QUOTE (BOTHTIMES)) (QUOTE EVAL)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE IGNORE)) (REMFLAG (QUOTE (LOADTIME)) (QUOTE EVAL)) (PUT (QUOTE CONTERROR) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE CASE) (QUOTE TYPE) (QUOTE FEXPR)) (PUT (QUOTE SETF) (QUOTE TYPE) (QUOTE MACRO)) (DEFLIST (QUOTE ((GETV PUTV) (CAR RPLACA) (CDR RPLACD) (INDX SETINDX) (SUB SETSUB) (NTH (LAMBDA (L I X) (RPLACA (PNTH L I) X) X)) (EVAL SET) (VALUE SET))) (QUOTE ASSIGN!-OP)) (PUT (QUOTE ON) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE OFF) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (ON OFF)) (QUOTE IGNORE)) (PUT (QUOTE DS) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE DEFCONST) (QUOTE TYPE) (QUOTE MACRO)) (FLAG (QUOTE (DEFCONST)) (QUOTE EVAL)) (PUT (QUOTE CONST) (QUOTE TYPE) (QUOTE MACRO)) (FLUID (QUOTE (STRINGGENSYM!*))) (SETQ STRINGGENSYM!* (COPYSTRING "L0000")) (PUT (QUOTE FOREACH) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE EXIT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE NEXT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE WHILE) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE REPEAT) (QUOTE TYPE) (QUOTE MACRO)) (PUT (QUOTE FOR) (QUOTE TYPE) (QUOTE MACRO)) |
Added psl-1983/lap/macro.log version [fab66ab8b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 7-Mar-83 16:04:44 BATCON Version 104(4133) GLXLIB Version 1(527) Job MACRO Req #264 for KESSLER in Stream 0 OUTPUT: Nolog TIME-LIMIT: 0:20:00 UNIQUE: Yes BATCH-LOG: Supersede RESTART: No ASSISTANCE: Yes SEQUENCE: 802 Input from => PS:<PSL.KERNEL.20>MACRO.CTL.2 Output to => PS:<PSL.KERNEL.20>MACRO.LOG 16:04:44 MONTR Univ of Utah Computer Science KL-20, TOPS-20AN Monitor 5.3(1500) 16:04:44 MONTR @SET TIME-LIMIT 1200 16:04:45 MONTR @LOGIN KESSLER SMALL 16:04:48 MONTR Job 13 on TTY225 7-Mar-83 16:04:48 16:04:48 MONTR Previous login at 7-Mar-83 15:55:36 16:04:48 MONTR There is 1 other job logged in as user KESSLER 16:04:57 MONTR @ 16:04:57 MONTR [PS Mounted] 16:04:57 MONTR 16:04:57 MONTR [CONNECTED TO PS:<PSL.KERNEL.20>] 16:04:57 MONTR define DSK: DSK:, P20:, PI: 16:04:58 MONTR @S:DEC20-CROSS.EXE 16:05:00 USER Dec 20 cross compiler 16:05:03 USER [8] ASMOut "macro"; 16:05:07 USER ASMOUT: IN files; or type in expressions 16:05:07 USER When all done execute ASMEND; 16:06:20 USER [9] in "macro.build"; 16:06:21 USER % 16:06:21 USER % MACRO.BUILD - Files of macros defined in the interpreter 16:06:21 USER % 16:06:21 USER % Author: Eric Benson 16:06:21 USER % Symbolic Computation Group 16:06:21 USER % Computer Science Dept. 16:06:21 USER % University of Utah 16:06:21 USER % Date: 19 May 1982 16:06:21 USER % Copyright (c) 1982 University of Utah 16:06:21 USER % 16:06:21 USER 16:06:21 USER % <PSL.KERNEL>MACRO.BUILD.2, 2-Feb-83 15:36:40, Edit by PERDUE 16:06:21 USER % Removed char.red. It is now pnk:char-macro.red 16:06:21 USER 16:06:21 USER PathIn "eval-when.red"$ 16:06:22 USER *** Function `COMMENTOUTCODE' has been redefined 16:06:26 USER % control evaluation time 16:06:26 USER PathIn "cont-error.red"$ 16:06:31 USER *** Function `CONTERROR' has been redefined 16:06:44 USER % macro for ContinuableError 16:06:44 USER PathIn "lisp-macros.red"$ 16:06:56 USER *** Function `SETF' has been redefined 16:06:57 USER % Various macros for readability 16:06:58 USER PathIn "onoff.red"$ 16:07:01 USER *** Function `ON' has been redefined 16:07:02 USER *** Function `OFF' has been redefined 16:07:02 USER *** Garbage collection starting 16:07:27 USER *** GC 4: time 3242 ms 16:07:27 USER *** 73050 recovered, 564 stable, 16385 active, 73051 free 16:07:37 USER % (on xxx yyy) and (off xxx yyy) 16:07:37 USER PathIn "define-smacro.red"$ 16:07:57 USER *** Function `DS' has been redefined 16:08:15 USER 16:08:15 USER PathIn "defconst.red"$ 16:08:16 USER *** Function `DEFCONST' has been redefined 16:08:18 USER *** Function `CONST' has been redefined 16:08:19 USER 16:08:19 USER PathIn "string-gensym.red"$ 16:08:23 USER PathIn "loop-macros.red"$ 16:08:25 USER *** Function `FOREACH' has been redefined 16:08:31 USER *** Function `EXIT' has been redefined 16:08:32 USER *** Function `NEXT' has been redefined 16:08:32 USER *** Function `WHILE' has been redefined 16:08:34 USER *** Function `REPEAT' has been redefined 16:08:43 USER *** Function `FOR' has been redefined 16:08:44 USER *** Garbage collection starting 16:09:04 USER *** GC 5: time 2950 ms 16:09:04 USER *** 70120 recovered, 16605 stable, 3275 active, 70120 free 16:09:13 USER % Various macros for readability 16:09:14 USER [10] ASMEnd; 16:10:31 USER NIL 16:10:32 USER [11] quit; 16:10:33 MONTR @compile macro.mac, dmacro.mac 16:10:37 USER MACRO: .MAIN 16:10:51 USER MACRO: .MAIN 16:10:52 USER 16:10:52 USER EXIT 16:10:52 MONTR @delete macro.mac, dmacro.mac 16:10:56 MONTR MACRO.MAC.1 [OK] 16:10:56 MONTR DMACRO.MAC.1 [OK] 16:10:56 MONTR @ 16:10:58 MONTR Killed by OPERATOR, TTY 221 16:10:58 MONTR Killed Job 13, User KESSLER, Account SMALL, TTY 225, 16:10:58 MONTR at 7-Mar-83 16:10:58, Used 0:01:27 in 0:06:10 |
Added psl-1983/lap/macro.rel version [5eb374c75c].
cannot compute difference between binary files
Added psl-1983/lap/mail-test.lap version [0da1180d13].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | (load nmode) (faslin "ps:<kendzierski.psl>output-stream-aux.b") (faslin "ps:<kendzierski.psl>file-support-aux.b") (faslin "ps:<kendzierski.psl>util.b") (faslin "ps:<kendzierski.psl>date.b") % Subsystems: load last! (This is a subsystem of NMODE) (faslin "ss:<nmail>mail-base.b") (faslin "ss:<nmail>mail-file.b") (faslin "ss:<nmail>mail-message.b") (faslin "ss:<nmail>mail-support.b") (faslin "ss:<nmail>mail-filter.b") (faslin "ss:<nmail>mail-filter-base.b") (prog () (add-to-command-list 'Basic-Command-List (x-chars (control X) M) 'mail-command) (add-to-command-list 'Basic-Command-List (x-chars (control X) S) 'mail-set-up-send-buffer) (nmode-establish-current-mode) (return "Mail subsystem defined")) |
Added psl-1983/lap/mail.lap version [4c2133cad9].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | (load nmode) (faslin "ps:<kendzierski.psl>output-stream-aux.b") (faslin "ps:<kendzierski.psl>file-support-aux.b") (faslin "ps:<kendzierski.psl>util.b") (faslin "ps:<kendzierski.psl>date.b") % Subsystems: load last! (This is a subsystem of NMODE) (faslin "ps:<kendzierski.mail>mail-base.b") (faslin "ps:<kendzierski.mail>mail-file.b") (faslin "ps:<kendzierski.mail>mail-message.b") (faslin "ps:<kendzierski.mail>mail-support.b") (faslin "ps:<kendzierski.mail>mail-filter.b") (faslin "ps:<kendzierski.mail>mail-filter-base.b") (prog () (add-to-command-list 'Basic-Command-List (x-chars (control X) M) 'mail-command) (add-to-command-list 'Basic-Command-List (x-chars (control X) S) 'mail-set-up-send-buffer) (nmode-establish-current-mode) (return "Mail subsystem defined")) |
Added psl-1983/lap/main.ctl version [1d9c233eeb].
> > > > > > > > | 1 2 3 4 5 6 7 8 | define DSK: DSK:, P20:, PI: S:DEC20-CROSS.EXE ASMOut "main"; in "main.build"; ASMEnd; quit; compile main.mac, dmain.mac delete main.mac, dmain.mac |
Added psl-1983/lap/main.init version [a7ffc6f8bf].
Added psl-1983/lap/main.log version [d6f8b30d25].
cannot compute difference between binary files
Added psl-1983/lap/main.mac version [ae9021b687].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 | search monsym radix 10 extern SYMNAM extern SYMVAL extern SYMFNC extern SYMPRP extern L0001 extern L0002 extern L0003 extern STACK extern L1191 extern L2107 0 ; (!*ENTRY MAIN!. EXPR 0) intern MAIN. MAIN.:L3694: MOVE 15,L3693 MOVE 0,SYMVAL+128 PUSHJ 15,SYMFNC+842 JRST L3694 L3693: byte(18)-4000,STACK-1 0 ; (!*ENTRY RESET EXPR 0) RESET: intern RESET MOVE 2,L3695 MOVE 1,L3695 JRST SYMFNC+495 L3695: <30_31>+536 0 ; (!*ENTRY PRE!-MAIN EXPR 0) L3697: intern L3697 ADJSP 15,2 L3698: PUSHJ 15,SYMFNC+780 PUSHJ 15,SYMFNC+793 PUSHJ 15,SYMFNC+837 MOVE 1,L3696 PUSHJ 15,SYMFNC+499 MOVEM 1,0(15) CAME 0,SYMVAL+500 JRST L3699 PUSHJ 15,SYMFNC+843 MOVEM 1,-1(15) MOVE 1,0(15) PUSHJ 15,SYMFNC+501 MOVE 1,-1(15) L3699: CAMN 1,L3696 JRST L3698 MOVE 1,0 ADJSP 15,-2 POPJ 15,0 L3696: <30_31>+536 0 ; (!*ENTRY MAIN EXPR 0) MAIN: intern MAIN PUSHJ 15,SYMFNC+844 MOVE 6,833+SYMFNC MOVEM 6,843+SYMFNC JRST SYMFNC+833 0 ; (!*ENTRY INITCODE EXPR 0) L3716: intern L3716 MOVE 3,L3700 MOVE 2,L3701 MOVE 1,L3702 PUSHJ 15,SYMFNC+308 MOVE 3,L3700 MOVE 2,L3701 MOVE 1,L3703 PUSHJ 15,SYMFNC+308 MOVE 3,L3704 MOVE 2,L3705 MOVE 1,L3706 PUSHJ 15,SYMFNC+308 MOVE 3,L3707 MOVE 2,L3705 MOVE 1,L3708 PUSHJ 15,SYMFNC+308 MOVE 3,L3709 MOVE 2,L3705 MOVE 1,L3710 PUSHJ 15,SYMFNC+308 MOVE 3,L3711 MOVE 2,L3705 MOVE 1,L3712 PUSHJ 15,SYMFNC+308 MOVE 3,L3713 MOVE 2,L3705 HRRZI 1,26 TLZ 1,253952 TLO 1,245760 PUSHJ 15,SYMFNC+308 PUSHJ 15,SYMFNC+790 HRRZI 3,26 MOVE 2,L3714 MOVE 1,L3715 JRST SYMFNC+308 L3715: <30_31>+845 L3714: <30_31>+846 L3713: <30_31>+640 L3712: <30_31>+91 L3711: <30_31>+645 L3710: <30_31>+41 L3709: <30_31>+644 L3708: <30_31>+40 L3707: <30_31>+643 L3706: <30_31>+39 L3705: <30_31>+637 L3704: <30_31>+642 L3703: <30_31>+254 L3702: <30_31>+272 L3701: <30_31>+758 L3700: <30_31>+262 L3717: <30_31>+269 <9_31>+L3718 L3718: <30_31>+518 <9_31>+L3719 L3719: <30_31>+296 <9_31>+L3720 L3720: <30_31>+508 <9_31>+L3721 L3721: <30_31>+509 <9_31>+L3722 L3722: <30_31>+498 <9_31>+L3723 L3723: <30_31>+478 <9_31>+L3724 L3724: <30_31>+273 <9_31>+L3725 L3725: <30_31>+806 <9_31>+L3726 L3726: <30_31>+808 <9_31>+L3727 L3727: <30_31>+510 <9_31>+L3728 L3728: <30_31>+452 <9_31>+L3729 L3729: <30_31>+843 <30_31>+128 intern L3717 L3730: <30_31>+278 <9_31>+L3731 L3731: <30_31>+541 <9_31>+L3732 L3732: <30_31>+274 <9_31>+L3733 L3733: <30_31>+276 <9_31>+L3734 L3734: <30_31>+272 <9_31>+L3735 L3735: <30_31>+268 <30_31>+128 intern L3730 L3736: <30_31>+847 <9_31>+L3737 L3737: <30_31>+848 <9_31>+L3738 L3738: <30_31>+849 <9_31>+L3739 L3739: <30_31>+850 <30_31>+128 intern L3736 L3740: <4_31>+L3741 <9_31>+L3742 L3741: -1 byte(7)0 L3742: <4_31>+L3743 <30_31>+128 L3743: 2 byte(7)112,108,58,0 intern L3740 L3744: <9_31>+L3745 <9_31>+L3746 L3745: <4_31>+L3747 <30_31>+559 L3746: <9_31>+L3748 <9_31>+L3749 L3747: 1 byte(7)46,98,0 L3748: <4_31>+L3750 <30_31>+840 L3749: <9_31>+L3751 <30_31>+128 L3750: 3 byte(7)46,108,97,112,0 L3751: <4_31>+L3752 <30_31>+840 L3752: 2 byte(7)46,115,108,0 intern L3744 L3753: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_31>+851 intern L3753 L3754: 128 17 10 10 10 10 10 10 10 10 17 17 10 17 17 10 10 10 10 10 10 10 10 10 10 10 10 11 10 10 10 10 10 17 14 15 10 10 12 10 11 11 11 10 19 10 18 20 10 0 1 2 3 4 5 6 7 8 9 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 <30_31>+851 intern L3754 L3755: 21 byte(7)80,111,114,116,97,98,108,101,32,83,116,97,110,100,97,114,100,32,76,73,83,80,0 intern L3755 L3756: 0 byte(7)0,0 intern L3756 L3757: 0 byte(7)1,0 intern L3757 L3758: 0 byte(7)2,0 intern L3758 L3759: 0 byte(7)3,0 intern L3759 L3760: 0 byte(7)4,0 intern L3760 L3761: 0 byte(7)5,0 intern L3761 L3762: 0 byte(7)6,0 intern L3762 L3763: 0 byte(7)7,0 intern L3763 L3764: 0 byte(7)8,0 intern L3764 L3765: 0 byte(7)9,0 intern L3765 L3766: 0 byte(7)10,0 intern L3766 L3767: 0 byte(7)11,0 intern L3767 L3768: 0 byte(7)12,0 intern L3768 L3769: 0 byte(7)13,0 intern L3769 L3770: 0 byte(7)14,0 intern L3770 L3771: 0 byte(7)15,0 intern L3771 L3772: 0 byte(7)16,0 intern L3772 L3773: 0 byte(7)17,0 intern L3773 L3774: 0 byte(7)18,0 intern L3774 L3775: 0 byte(7)19,0 intern L3775 L3776: 0 byte(7)20,0 intern L3776 L3777: 0 byte(7)21,0 intern L3777 L3778: 0 byte(7)22,0 intern L3778 L3779: 0 byte(7)23,0 intern L3779 L3780: 0 byte(7)24,0 intern L3780 L3781: 0 byte(7)25,0 intern L3781 L3782: 0 byte(7)26,0 intern L3782 L3783: 0 byte(7)27,0 intern L3783 L3784: 0 byte(7)28,0 intern L3784 L3785: 0 byte(7)29,0 intern L3785 L3786: 0 byte(7)30,0 intern L3786 L3787: 0 byte(7)31,0 intern L3787 L3788: 0 byte(7)32,0 intern L3788 L3789: 0 byte(7)33,0 intern L3789 L3790: 0 byte(7)34,0 intern L3790 L3791: 0 byte(7)35,0 intern L3791 L3792: 0 byte(7)36,0 intern L3792 L3793: 0 byte(7)37,0 intern L3793 L3794: 0 byte(7)38,0 intern L3794 L3795: 0 byte(7)39,0 intern L3795 L3796: 0 byte(7)40,0 intern L3796 L3797: 0 byte(7)41,0 intern L3797 L3798: 0 byte(7)42,0 intern L3798 L3799: 0 byte(7)43,0 intern L3799 L3800: 0 byte(7)44,0 intern L3800 L3801: 0 byte(7)45,0 intern L3801 L3802: 0 byte(7)46,0 intern L3802 L3803: 0 byte(7)47,0 intern L3803 L3804: 0 byte(7)48,0 intern L3804 L3805: 0 byte(7)49,0 intern L3805 L3806: 0 byte(7)50,0 intern L3806 L3807: 0 byte(7)51,0 intern L3807 L3808: 0 byte(7)52,0 intern L3808 L3809: 0 byte(7)53,0 intern L3809 L3810: 0 byte(7)54,0 intern L3810 L3811: 0 byte(7)55,0 intern L3811 L3812: 0 byte(7)56,0 intern L3812 L3813: 0 byte(7)57,0 intern L3813 L3814: 0 byte(7)58,0 intern L3814 L3815: 0 byte(7)59,0 intern L3815 L3816: 0 byte(7)60,0 intern L3816 L3817: 0 byte(7)61,0 intern L3817 L3818: 0 byte(7)62,0 intern L3818 L3819: 0 byte(7)63,0 intern L3819 L3820: 0 byte(7)64,0 intern L3820 L3821: 0 byte(7)65,0 intern L3821 L3822: 0 byte(7)66,0 intern L3822 L3823: 0 byte(7)67,0 intern L3823 L3824: 0 byte(7)68,0 intern L3824 L3825: 0 byte(7)69,0 intern L3825 L3826: 0 byte(7)70,0 intern L3826 L3827: 0 byte(7)71,0 intern L3827 L3828: 0 byte(7)72,0 intern L3828 L3829: 0 byte(7)73,0 intern L3829 L3830: 0 byte(7)74,0 intern L3830 L3831: 0 byte(7)75,0 intern L3831 L3832: 0 byte(7)76,0 intern L3832 L3833: 0 byte(7)77,0 intern L3833 L3834: 0 byte(7)78,0 intern L3834 L3835: 0 byte(7)79,0 intern L3835 L3836: 0 byte(7)80,0 intern L3836 L3837: 0 byte(7)81,0 intern L3837 L3838: 0 byte(7)82,0 intern L3838 L3839: 0 byte(7)83,0 intern L3839 L3840: 0 byte(7)84,0 intern L3840 L3841: 0 byte(7)85,0 intern L3841 L3842: 0 byte(7)86,0 intern L3842 L3843: 0 byte(7)87,0 intern L3843 L3844: 0 byte(7)88,0 intern L3844 L3845: 0 byte(7)89,0 intern L3845 L3846: 0 byte(7)90,0 intern L3846 L3847: 0 byte(7)91,0 intern L3847 L3848: 0 byte(7)92,0 intern L3848 L3849: 0 byte(7)93,0 intern L3849 L3850: 0 byte(7)94,0 intern L3850 L3851: 0 byte(7)95,0 intern L3851 L3852: 0 byte(7)96,0 intern L3852 L3853: 0 byte(7)97,0 intern L3853 L3854: 0 byte(7)98,0 intern L3854 L3855: 0 byte(7)99,0 intern L3855 L3856: 0 byte(7)100,0 intern L3856 L3857: 0 byte(7)101,0 intern L3857 L3858: 0 byte(7)102,0 intern L3858 L3859: 0 byte(7)103,0 intern L3859 L3860: 0 byte(7)104,0 intern L3860 L3861: 0 byte(7)105,0 intern L3861 L3862: 0 byte(7)106,0 intern L3862 L3863: 0 byte(7)107,0 intern L3863 L3864: 0 byte(7)108,0 intern L3864 L3865: 0 byte(7)109,0 intern L3865 L3866: 0 byte(7)110,0 intern L3866 L3867: 0 byte(7)111,0 intern L3867 L3868: 0 byte(7)112,0 intern L3868 L3869: 0 byte(7)113,0 intern L3869 L3870: 0 byte(7)114,0 intern L3870 L3871: 0 byte(7)115,0 intern L3871 L3872: 0 byte(7)116,0 intern L3872 L3873: 0 byte(7)117,0 intern L3873 L3874: 0 byte(7)118,0 intern L3874 L3875: 0 byte(7)119,0 intern L3875 L3876: 0 byte(7)120,0 intern L3876 L3877: 0 byte(7)121,0 intern L3877 L3878: 0 byte(7)122,0 intern L3878 L3879: 0 byte(7)123,0 intern L3879 L3880: 0 byte(7)124,0 intern L3880 L3881: 0 byte(7)125,0 intern L3881 L3882: 0 byte(7)126,0 intern L3882 L3883: 0 byte(7)127,0 intern L3883 L3884: 2 byte(7)78,73,76,0 intern L3884 L3885: 5 byte(7)73,68,50,73,78,84,0 intern L3885 L3886: 9 byte(7)78,79,78,73,68,69,82,82,79,82,0 intern L3886 L3887: 5 byte(7)73,78,84,50,73,68,0 intern L3887 L3888: 8 byte(7)84,89,80,69,69,82,82,79,82,0 intern L3888 L3889: 14 byte(7)78,79,78,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L3889 L3890: 6 byte(7)73,78,84,50,83,89,83,0 intern L3890 L3891: 8 byte(7)76,73,83,80,50,67,72,65,82,0 intern L3891 L3892: 16 byte(7)78,79,78,67,72,65,82,65,67,84,69,82,69,82,82,79,82,0 intern L3892 L3893: 7 byte(7)73,78,84,50,67,79,68,69,0 intern L3893 L3894: 6 byte(7)83,89,83,50,73,78,84,0 intern L3894 L3895: 5 byte(7)71,84,70,73,88,78,0 intern L3895 L3896: 8 byte(7)73,68,50,83,84,82,73,78,71,0 intern L3896 L3897: 12 byte(7)83,84,82,73,78,71,50,86,69,67,84,79,82,0 intern L3897 L3898: 5 byte(7)71,84,86,69,67,84,0 intern L3898 L3899: 13 byte(7)78,79,78,83,84,82,73,78,71,69,82,82,79,82,0 intern L3899 L3900: 12 byte(7)86,69,67,84,79,82,50,83,84,82,73,78,71,0 intern L3900 L3901: 4 byte(7)71,84,83,84,82,0 intern L3901 L3902: 13 byte(7)78,79,78,86,69,67,84,79,82,69,82,82,79,82,0 intern L3902 L3903: 10 byte(7)76,73,83,84,50,83,84,82,73,78,71,0 intern L3903 L3904: 5 byte(7)76,69,78,71,84,72,0 intern L3904 L3905: 11 byte(7)78,79,78,80,65,73,82,69,82,82,79,82,0 intern L3905 L3906: 10 byte(7)83,84,82,73,78,71,50,76,73,83,84,0 intern L3906 L3907: 3 byte(7)67,79,78,83,0 intern L3907 L3908: 10 byte(7)76,73,83,84,50,86,69,67,84,79,82,0 intern L3908 L3909: 10 byte(7)86,69,67,84,79,82,50,76,73,83,84,0 intern L3909 L3910: 3 byte(7)71,69,84,86,0 intern L3910 L3911: 5 byte(7)66,76,68,77,83,71,0 intern L3911 L3912: 7 byte(7)83,84,68,69,82,82,79,82,0 intern L3912 L3913: 9 byte(7)73,78,68,69,88,69,82,82,79,82,0 intern L3913 L3914: 3 byte(7)80,85,84,86,0 intern L3914 L3915: 3 byte(7)85,80,66,86,0 intern L3915 L3916: 7 byte(7)69,86,69,67,84,79,82,80,0 intern L3916 L3917: 4 byte(7)69,71,69,84,86,0 intern L3917 L3918: 4 byte(7)69,80,85,84,86,0 intern L3918 L3919: 4 byte(7)69,85,80,66,86,0 intern L3919 L3920: 3 byte(7)73,78,68,88,0 intern L3920 L3921: 9 byte(7)82,65,78,71,69,69,82,82,79,82,0 intern L3921 L3922: 15 byte(7)78,79,78,83,69,81,85,69,78,67,69,69,82,82,79,82,0 intern L3922 L3923: 6 byte(7)83,69,84,73,78,68,88,0 intern L3923 L3924: 2 byte(7)83,85,66,0 intern L3924 L3925: 5 byte(7)83,85,66,83,69,81,0 intern L3925 L3926: 5 byte(7)71,84,87,82,68,83,0 intern L3926 L3927: 10 byte(7)71,84,72,65,76,70,87,79,82,68,83,0 intern L3927 L3928: 4 byte(7)78,67,79,78,83,0 intern L3928 L3929: 4 byte(7)84,67,79,78,67,0 intern L3929 L3930: 5 byte(7)83,69,84,83,85,66,0 intern L3930 L3931: 8 byte(7)83,69,84,83,85,66,83,69,81,0 intern L3931 L3932: 5 byte(7)67,79,78,67,65,84,0 intern L3932 L3933: 5 byte(7)65,80,80,69,78,68,0 intern L3933 L3934: 3 byte(7)83,73,90,69,0 intern L3934 L3935: 7 byte(7)77,75,83,84,82,73,78,71,0 intern L3935 L3936: 22 byte(7)78,79,78,80,79,83,73,84,73,86,69,73,78,84,69,71,69,82,69,82,82,79,82,0 intern L3936 L3937: 9 byte(7)77,65,75,69,45,66,89,84,69,83,0 intern L3937 L3938: 13 byte(7)77,65,75,69,45,72,65,76,70,87,79,82,68,83,0 intern L3938 L3939: 9 byte(7)77,65,75,69,45,87,79,82,68,83,0 intern L3939 L3940: 10 byte(7)77,65,75,69,45,86,69,67,84,79,82,0 intern L3940 L3941: 5 byte(7)83,84,82,73,78,71,0 intern L3941 L3942: 5 byte(7)86,69,67,84,79,82,0 intern L3942 L3943: 4 byte(7)67,79,68,69,80,0 intern L3943 L3944: 1 byte(7)69,81,0 intern L3944 L3945: 5 byte(7)70,76,79,65,84,80,0 intern L3945 L3946: 3 byte(7)66,73,71,80,0 intern L3946 L3947: 2 byte(7)73,68,80,0 intern L3947 L3948: 4 byte(7)80,65,73,82,80,0 intern L3948 L3949: 6 byte(7)83,84,82,73,78,71,80,0 intern L3949 L3950: 6 byte(7)86,69,67,84,79,82,80,0 intern L3950 L3951: 2 byte(7)67,65,82,0 intern L3951 L3952: 2 byte(7)67,68,82,0 intern L3952 L3953: 5 byte(7)82,80,76,65,67,65,0 intern L3953 L3954: 5 byte(7)82,80,76,65,67,68,0 intern L3954 L3955: 3 byte(7)70,73,88,80,0 intern L3955 L3956: 4 byte(7)68,73,71,73,84,0 intern L3956 L3957: 4 byte(7)76,73,84,69,82,0 intern L3957 L3958: 2 byte(7)69,81,78,0 intern L3958 L3959: 8 byte(7)76,73,83,80,69,81,85,65,76,0 intern L3959 L3960: 10 byte(7)83,84,82,73,78,71,69,81,85,65,76,0 intern L3960 L3961: 4 byte(7)69,81,83,84,82,0 intern L3961 L3962: 4 byte(7)69,81,85,65,76,0 intern L3962 L3963: 5 byte(7)67,65,65,65,65,82,0 intern L3963 L3964: 4 byte(7)67,65,65,65,82,0 intern L3964 L3965: 5 byte(7)67,65,65,65,68,82,0 intern L3965 L3966: 5 byte(7)67,65,65,68,65,82,0 intern L3966 L3967: 4 byte(7)67,65,65,68,82,0 intern L3967 L3968: 5 byte(7)67,65,65,68,68,82,0 intern L3968 L3969: 5 byte(7)67,65,68,65,65,82,0 intern L3969 L3970: 4 byte(7)67,65,68,65,82,0 intern L3970 L3971: 5 byte(7)67,65,68,65,68,82,0 intern L3971 L3972: 5 byte(7)67,65,68,68,65,82,0 intern L3972 L3973: 4 byte(7)67,65,68,68,82,0 intern L3973 L3974: 5 byte(7)67,65,68,68,68,82,0 intern L3974 L3975: 5 byte(7)67,68,65,65,65,82,0 intern L3975 L3976: 4 byte(7)67,68,65,65,82,0 intern L3976 L3977: 5 byte(7)67,68,65,65,68,82,0 intern L3977 L3978: 5 byte(7)67,68,65,68,65,82,0 intern L3978 L3979: 4 byte(7)67,68,65,68,82,0 intern L3979 L3980: 5 byte(7)67,68,65,68,68,82,0 intern L3980 L3981: 5 byte(7)67,68,68,65,65,82,0 intern L3981 L3982: 4 byte(7)67,68,68,65,82,0 intern L3982 L3983: 5 byte(7)67,68,68,65,68,82,0 intern L3983 L3984: 5 byte(7)67,68,68,68,65,82,0 intern L3984 L3985: 4 byte(7)67,68,68,68,82,0 intern L3985 L3986: 5 byte(7)67,68,68,68,68,82,0 intern L3986 L3987: 3 byte(7)67,65,65,82,0 intern L3987 L3988: 3 byte(7)67,65,68,82,0 intern L3988 L3989: 3 byte(7)67,68,65,82,0 intern L3989 L3990: 3 byte(7)67,68,68,82,0 intern L3990 L3991: 6 byte(7)83,65,70,69,67,65,82,0 intern L3991 L3992: 6 byte(7)83,65,70,69,67,68,82,0 intern L3992 L3993: 3 byte(7)65,84,79,77,0 intern L3993 L3994: 8 byte(7)67,79,78,83,84,65,78,84,80,0 intern L3994 L3995: 3 byte(7)78,85,76,76,0 intern L3995 L3996: 6 byte(7)78,85,77,66,69,82,80,0 intern L3996 L3997: 3 byte(7)69,88,80,84,0 intern L3997 L3998: 6 byte(7)77,75,81,85,79,84,69,0 intern L3998 L3999: 4 byte(7)76,73,83,84,51,0 intern L3999 L4000: 15 byte(7)67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L4000 L4001: 7 byte(7)71,82,69,65,84,69,82,80,0 intern L4001 L4002: 9 byte(7)68,73,70,70,69,82,69,78,67,69,0 intern L4002 L4003: 5 byte(7)77,73,78,85,83,80,0 intern L4003 L4004: 5 byte(7)84,73,77,69,83,50,0 intern L4004 L4005: 3 byte(7)65,68,68,49,0 intern L4005 L4006: 7 byte(7)81,85,79,84,73,69,78,84,0 intern L4006 L4007: 4 byte(7)80,76,85,83,50,0 intern L4007 L4008: 3 byte(7)76,73,83,84,0 intern L4008 L4009: 4 byte(7)69,86,76,73,83,0 intern L4009 L4010: 4 byte(7)81,85,79,84,69,0 intern L4010 L4011: 3 byte(7)69,88,80,82,0 intern L4011 L4012: 1 byte(7)68,69,0 intern L4012 L4013: 4 byte(7)76,73,83,84,50,0 intern L4013 L4014: 4 byte(7)76,73,83,84,52,0 intern L4014 L4015: 3 byte(7)80,85,84,68,0 intern L4015 L4016: 7 byte(7)70,85,78,67,84,73,79,78,0 intern L4016 L4017: 5 byte(7)76,65,77,66,68,65,0 intern L4017 L4018: 4 byte(7)70,69,88,80,82,0 intern L4018 L4019: 1 byte(7)68,70,0 intern L4019 L4020: 4 byte(7)77,65,67,82,79,0 intern L4020 L4021: 1 byte(7)68,77,0 intern L4021 L4022: 4 byte(7)78,69,88,80,82,0 intern L4022 L4023: 1 byte(7)68,78,0 intern L4023 L4024: 3 byte(7)83,69,84,81,0 intern L4024 L4025: 3 byte(7)69,86,65,76,0 intern L4025 L4026: 2 byte(7)83,69,84,0 intern L4026 L4027: 4 byte(7)80,82,79,71,50,0 intern L4027 L4028: 4 byte(7)80,82,79,71,78,0 intern L4028 L4029: 6 byte(7)69,86,80,82,79,71,78,0 intern L4029 L4030: 2 byte(7)65,78,68,0 intern L4030 L4031: 4 byte(7)69,86,65,78,68,0 intern L4031 L4032: 1 byte(7)79,82,0 intern L4032 L4033: 3 byte(7)69,86,79,82,0 intern L4033 L4034: 3 byte(7)67,79,78,68,0 intern L4034 L4035: 5 byte(7)69,86,67,79,78,68,0 intern L4035 L4036: 2 byte(7)78,79,84,0 intern L4036 L4037: 2 byte(7)65,66,83,0 intern L4037 L4038: 4 byte(7)77,73,78,85,83,0 intern L4038 L4039: 5 byte(7)68,73,86,73,68,69,0 intern L4039 L4040: 4 byte(7)90,69,82,79,80,0 intern L4040 L4041: 8 byte(7)82,69,77,65,73,78,68,69,82,0 intern L4041 L4042: 4 byte(7)88,67,79,78,83,0 intern L4042 L4043: 2 byte(7)77,65,88,0 intern L4043 L4044: 11 byte(7)82,79,66,85,83,84,69,88,80,65,78,68,0 intern L4044 L4045: 3 byte(7)77,65,88,50,0 intern L4045 L4046: 4 byte(7)76,69,83,83,80,0 intern L4046 L4047: 2 byte(7)77,73,78,0 intern L4047 L4048: 3 byte(7)77,73,78,50,0 intern L4048 L4049: 3 byte(7)80,76,85,83,0 intern L4049 L4050: 4 byte(7)84,73,77,69,83,0 intern L4050 L4051: 2 byte(7)77,65,80,0 intern L4051 L4052: 8 byte(7)70,65,83,84,65,80,80,76,89,0 intern L4052 L4053: 3 byte(7)77,65,80,67,0 intern L4053 L4054: 5 byte(7)77,65,80,67,65,78,0 intern L4054 L4055: 4 byte(7)78,67,79,78,67,0 intern L4055 L4056: 5 byte(7)77,65,80,67,79,78,0 intern L4056 L4057: 5 byte(7)77,65,80,67,65,82,0 intern L4057 L4058: 6 byte(7)77,65,80,76,73,83,84,0 intern L4058 L4059: 4 byte(7)65,83,83,79,67,0 intern L4059 L4060: 5 byte(7)83,65,83,83,79,67,0 intern L4060 L4061: 3 byte(7)80,65,73,82,0 intern L4061 L4062: 5 byte(7)83,85,66,76,73,83,0 intern L4062 L4063: 6 byte(7)68,69,70,76,73,83,84,0 intern L4063 L4064: 2 byte(7)80,85,84,0 intern L4064 L4065: 5 byte(7)68,69,76,69,84,69,0 intern L4065 L4066: 5 byte(7)77,69,77,66,69,82,0 intern L4066 L4067: 3 byte(7)77,69,77,81,0 intern L4067 L4068: 6 byte(7)82,69,86,69,82,83,69,0 intern L4068 L4069: 4 byte(7)83,85,66,83,84,0 intern L4069 L4070: 5 byte(7)69,88,80,65,78,68,0 intern L4070 L4071: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,0 intern L4071 L4072: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4072 L4073: 12 byte(7)67,72,65,78,78,69,76,84,69,82,80,82,73,0 intern L4073 L4074: 4 byte(7)80,82,73,78,84,0 intern L4074 L4075: 3 byte(7)79,85,84,42,0 intern L4075 L4076: 2 byte(7)78,69,81,0 intern L4076 L4077: 1 byte(7)78,69,0 intern L4077 L4078: 2 byte(7)71,69,81,0 intern L4078 L4079: 2 byte(7)76,69,81,0 intern L4079 L4080: 4 byte(7)69,81,67,65,82,0 intern L4080 L4081: 4 byte(7)69,88,80,82,80,0 intern L4081 L4082: 3 byte(7)71,69,84,68,0 intern L4082 L4083: 5 byte(7)77,65,67,82,79,80,0 intern L4083 L4084: 5 byte(7)70,69,88,80,82,80,0 intern L4084 L4085: 5 byte(7)78,69,88,80,82,80,0 intern L4085 L4086: 4 byte(7)67,79,80,89,68,0 intern L4086 L4087: 4 byte(7)82,69,67,73,80,0 intern L4087 L4088: 4 byte(7)70,73,82,83,84,0 intern L4088 L4089: 5 byte(7)83,69,67,79,78,68,0 intern L4089 L4090: 4 byte(7)84,72,73,82,68,0 intern L4090 L4091: 5 byte(7)70,79,85,82,84,72,0 intern L4091 L4092: 3 byte(7)82,69,83,84,0 intern L4092 L4093: 7 byte(7)82,69,86,69,82,83,73,80,0 intern L4093 L4094: 6 byte(7)83,85,66,83,84,73,80,0 intern L4094 L4095: 6 byte(7)68,69,76,69,84,73,80,0 intern L4095 L4096: 3 byte(7)68,69,76,81,0 intern L4096 L4097: 2 byte(7)68,69,76,0 intern L4097 L4098: 5 byte(7)68,69,76,81,73,80,0 intern L4098 L4099: 4 byte(7)65,84,83,79,67,0 intern L4099 L4100: 2 byte(7)65,83,83,0 intern L4100 L4101: 2 byte(7)77,69,77,0 intern L4101 L4102: 5 byte(7)82,65,83,83,79,67,0 intern L4102 L4103: 5 byte(7)68,69,76,65,83,67,0 intern L4103 L4104: 7 byte(7)68,69,76,65,83,67,73,80,0 intern L4104 L4105: 5 byte(7)68,69,76,65,84,81,0 intern L4105 L4106: 7 byte(7)68,69,76,65,84,81,73,80,0 intern L4106 L4107: 4 byte(7)83,85,66,76,65,0 intern L4107 L4108: 5 byte(7)82,80,76,65,67,87,0 intern L4108 L4109: 6 byte(7)76,65,83,84,67,65,82,0 intern L4109 L4110: 7 byte(7)76,65,83,84,80,65,73,82,0 intern L4110 L4111: 3 byte(7)67,79,80,89,0 intern L4111 L4112: 2 byte(7)78,84,72,0 intern L4112 L4113: 3 byte(7)83,85,66,49,0 intern L4113 L4114: 3 byte(7)80,78,84,72,0 intern L4114 L4115: 4 byte(7)65,67,79,78,67,0 intern L4115 L4116: 4 byte(7)76,67,79,78,67,0 intern L4116 L4117: 3 byte(7)77,65,80,50,0 intern L4117 L4118: 4 byte(7)77,65,80,67,50,0 intern L4118 L4119: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,84,0 intern L4119 L4120: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4120 L4121: 5 byte(7)80,82,73,78,50,84,0 intern L4121 L4122: 12 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,0 intern L4122 L4123: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,72,65,82,0 intern L4123 L4124: 5 byte(7)83,80,65,67,69,83,0 intern L4124 L4125: 9 byte(7)67,72,65,78,78,69,76,84,65,66,0 intern L4125 L4126: 10 byte(7)67,72,65,78,78,69,76,80,79,83,78,0 intern L4126 L4127: 2 byte(7)84,65,66,0 intern L4127 L4128: 4 byte(7)70,73,76,69,80,0 intern L4128 L4129: 3 byte(7)80,85,84,67,0 intern L4129 L4130: 6 byte(7)83,80,65,67,69,83,50,0 intern L4130 L4131: 13 byte(7)67,72,65,78,78,69,76,83,80,65,67,69,83,50,0 intern L4131 L4132: 7 byte(7)76,73,83,84,50,83,69,84,0 intern L4132 L4133: 8 byte(7)76,73,83,84,50,83,69,84,81,0 intern L4133 L4134: 5 byte(7)65,68,74,79,73,78,0 intern L4134 L4135: 6 byte(7)65,68,74,79,73,78,81,0 intern L4135 L4136: 4 byte(7)85,78,73,79,78,0 intern L4136 L4137: 5 byte(7)85,78,73,79,78,81,0 intern L4137 L4138: 1 byte(7)88,78,0 intern L4138 L4139: 2 byte(7)88,78,81,0 intern L4139 L4140: 11 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,0 intern L4140 L4141: 12 byte(7)73,78,84,69,82,83,69,67,84,73,79,78,81,0 intern L4141 L4142: 15 byte(7)75,78,79,87,78,45,70,82,69,69,45,83,80,65,67,69,0 intern L4142 L4143: 5 byte(7)71,84,72,69,65,80,0 intern L4143 L4144: 9 byte(7)70,65,84,65,76,69,82,82,79,82,0 intern L4144 L4145: 7 byte(7)37,82,69,67,76,65,73,77,0 intern L4145 L4146: 6 byte(7)71,67,45,84,82,65,80,0 intern L4146 L4147: 12 byte(7)71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4147 L4148: 16 byte(7)83,69,84,45,71,67,45,84,82,65,80,45,76,69,86,69,76,0 intern L4148 L4149: 6 byte(7)68,69,76,72,69,65,80,0 intern L4149 L4150: 9 byte(7)71,84,67,79,78,83,84,83,84,82,0 intern L4150 L4151: 4 byte(7)71,84,66,80,83,0 intern L4151 L4152: 6 byte(7)71,84,69,86,69,67,84,0 intern L4152 L4153: 5 byte(7)71,84,70,76,84,78,0 intern L4153 L4154: 3 byte(7)71,84,73,68,0 intern L4154 L4155: 6 byte(7)82,69,67,76,65,73,77,0 intern L4155 L4156: 5 byte(7)68,69,76,66,80,83,0 intern L4156 L4157: 7 byte(7)71,84,87,65,82,82,65,89,0 intern L4157 L4158: 8 byte(7)68,69,76,87,65,82,82,65,89,0 intern L4158 L4159: 15 byte(7)67,79,80,89,83,84,82,73,78,71,84,79,70,82,79,77,0 intern L4159 L4160: 9 byte(7)67,79,80,89,83,84,82,73,78,71,0 intern L4160 L4161: 9 byte(7)67,79,80,89,87,65,82,82,65,89,0 intern L4161 L4162: 15 byte(7)67,79,80,89,86,69,67,84,79,82,84,79,70,82,79,77,0 intern L4162 L4163: 9 byte(7)67,79,80,89,86,69,67,84,79,82,0 intern L4163 L4164: 13 byte(7)67,79,80,89,87,82,68,83,84,79,70,82,79,77,0 intern L4164 L4165: 7 byte(7)67,79,80,89,87,82,68,83,0 intern L4165 L4166: 8 byte(7)84,79,84,65,76,67,79,80,89,0 intern L4166 L4167: 5 byte(7)77,75,86,69,67,84,0 intern L4167 L4168: 8 byte(7)77,75,69,86,69,67,84,79,82,0 intern L4168 L4169: 6 byte(7)77,75,69,86,69,67,84,0 intern L4169 L4170: 4 byte(7)76,73,83,84,53,0 intern L4170 L4171: 2 byte(7)42,71,67,0 intern L4171 L4172: 6 byte(7)71,67,84,73,77,69,42,0 intern L4172 L4173: 5 byte(7)71,67,75,78,84,42,0 intern L4173 L4174: 14 byte(7)72,69,65,80,45,87,65,82,78,45,76,69,86,69,76,0 intern L4174 L4175: 10 byte(7)69,82,82,79,82,80,82,73,78,84,70,0 intern L4175 L4176: 3 byte(7)84,73,77,67,0 intern L4176 L4177: 3 byte(7)81,85,73,84,0 intern L4177 L4178: 8 byte(7)82,69,84,85,82,78,78,73,76,0 intern L4178 L4179: 13 byte(7)82,69,84,85,82,78,70,73,82,83,84,65,82,71,0 intern L4179 L4180: 3 byte(7)76,65,78,68,0 intern L4180 L4181: 2 byte(7)76,79,82,0 intern L4181 L4182: 3 byte(7)76,88,79,82,0 intern L4182 L4183: 5 byte(7)76,83,72,73,70,84,0 intern L4183 L4184: 2 byte(7)76,83,72,0 intern L4184 L4185: 3 byte(7)76,78,79,84,0 intern L4185 L4186: 2 byte(7)70,73,88,0 intern L4186 L4187: 4 byte(7)70,76,79,65,84,0 intern L4187 L4188: 3 byte(7)79,78,69,80,0 intern L4188 L4189: 4 byte(7)68,69,66,85,71,0 intern L4189 L4190: 1 byte(7)84,82,0 intern L4190 L4191: 5 byte(7)69,86,76,79,65,68,0 intern L4191 L4192: 3 byte(7)84,82,83,84,0 intern L4192 L4193: 7 byte(7)81,69,68,73,84,70,78,83,0 intern L4193 L4194: 6 byte(7)42,69,88,80,69,82,84,0 intern L4194 L4195: 7 byte(7)42,86,69,82,66,79,83,69,0 intern L4195 L4196: 4 byte(7)69,68,73,84,70,0 intern L4196 L4197: 3 byte(7)69,68,73,84,0 intern L4197 L4198: 3 byte(7)89,69,83,80,0 intern L4198 L4199: 12 byte(7)80,82,79,77,80,84,83,84,82,73,78,71,42,0 intern L4199 L4200: 7 byte(7)70,65,83,84,66,73,78,68,0 intern L4200 L4201: 5 byte(7)84,69,82,80,82,73,0 intern L4201 L4202: 12 byte(7)69,68,73,84,79,82,82,69,65,68,69,82,42,0 intern L4202 L4203: 13 byte(7)69,68,73,84,79,82,80,82,73,78,84,69,82,42,0 intern L4203 L4204: 9 byte(7)70,65,83,84,85,78,66,73,78,68,0 intern L4204 L4205: 3 byte(7)82,69,65,68,0 intern L4205 L4206: 1 byte(7)67,76,0 intern L4206 L4207: 3 byte(7)72,69,76,80,0 intern L4207 L4208: 4 byte(7)66,82,69,65,75,0 intern L4208 L4209: 4 byte(7)69,72,69,76,80,0 intern L4209 L4210: 1 byte(7)80,76,0 intern L4210 L4211: 1 byte(7)85,80,0 intern L4211 L4212: 1 byte(7)79,75,0 intern L4212 L4213: 14 byte(7)68,73,83,80,76,65,89,72,69,76,80,70,73,76,69,0 intern L4213 L4214: 5 byte(7)69,68,73,84,79,82,0 intern L4214 L4215: 18 byte(7)73,71,78,79,82,69,68,73,78,66,65,67,75,84,82,65,67,69,42,0 intern L4215 L4216: 20 byte(7)73,78,84,69,82,80,82,69,84,69,82,70,85,78,67,84,73,79,78,83,42,0 intern L4216 L4217: 14 byte(7)73,78,84,69,82,80,66,65,67,75,84,82,65,67,69,0 intern L4217 L4218: 5 byte(7)80,82,73,78,84,70,0 intern L4218 L4219: 8 byte(7)66,65,67,75,84,82,65,67,69,0 intern L4219 L4220: 13 byte(7)82,69,84,85,82,78,65,68,68,82,69,83,83,80,0 intern L4220 L4221: 6 byte(7)65,68,68,82,50,73,68,0 intern L4221 L4222: 15 byte(7)86,69,82,66,79,83,69,66,65,67,75,84,82,65,67,69,0 intern L4222 L4223: 7 byte(7)79,80,84,73,79,78,83,42,0 intern L4223 L4224: 8 byte(7)87,82,73,84,69,67,72,65,82,0 intern L4224 L4225: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,75,78,79,87,78,73,84,69,77,0 intern L4225 L4226: 21 byte(7)67,79,68,69,45,65,68,68,82,69,83,83,45,84,79,45,83,89,77,66,79,76,0 intern L4226 L4227: 4 byte(7)80,82,73,78,49,0 intern L4227 L4228: 4 byte(7)69,82,82,79,82,0 intern L4228 L4229: 1 byte(7)78,79,0 intern L4229 L4230: 2 byte(7)89,69,83,0 intern L4230 L4231: 2 byte(7)82,68,83,0 intern L4231 L4232: 6 byte(7)69,82,82,79,85,84,42,0 intern L4232 L4233: 2 byte(7)87,82,83,0 intern L4233 L4234: 7 byte(7)69,82,82,79,82,83,69,84,0 intern L4234 L4235: 6 byte(7)67,85,82,83,89,77,42,0 intern L4235 L4236: 8 byte(7)42,83,69,77,73,67,79,76,42,0 intern L4236 L4237: 9 byte(7)69,82,82,79,82,70,79,82,77,42,0 intern L4237 L4238: 16 byte(7)42,67,79,78,84,73,78,85,65,66,76,69,69,82,82,79,82,0 intern L4238 L4239: 4 byte(7)69,77,83,71,42,0 intern L4239 L4240: 5 byte(7)42,66,82,69,65,75,0 intern L4240 L4241: 5 byte(7)42,69,77,83,71,80,0 intern L4241 L4242: 13 byte(7)77,65,88,66,82,69,65,75,76,69,86,69,76,42,0 intern L4242 L4243: 10 byte(7)66,82,69,65,75,76,69,86,69,76,42,0 intern L4243 L4244: 7 byte(7)70,76,65,84,83,73,90,69,0 intern L4244 L4245: 13 byte(7)85,83,65,71,69,84,89,80,69,69,82,82,79,82,0 intern L4245 L4246: 13 byte(7)78,79,78,78,85,77,66,69,82,69,82,82,79,82,0 intern L4246 L4247: 7 byte(7)78,79,78,87,79,82,68,83,0 intern L4247 L4248: 16 byte(7)78,79,78,73,79,67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4248 L4249: 9 byte(7)42,66,65,67,75,84,82,65,67,69,0 intern L4249 L4250: 15 byte(7)42,73,78,78,69,82,42,66,65,67,75,84,82,65,67,69,0 intern L4250 L4251: 4 byte(7)84,72,82,79,87,0 intern L4251 L4252: 6 byte(7)36,69,82,82,79,82,36,0 intern L4252 L4253: 5 byte(7)69,82,82,83,69,84,0 intern L4253 L4254: 4 byte(7)67,65,84,67,72,0 intern L4254 L4255: 9 byte(7)67,65,84,67,72,83,69,84,85,80,0 intern L4255 L4256: 11 byte(7)84,72,82,79,87,83,73,71,78,65,76,42,0 intern L4256 L4257: 7 byte(7)37,85,78,67,65,84,67,72,0 intern L4257 L4258: 13 byte(7)67,72,65,78,78,69,76,78,79,84,79,80,69,78,0 intern L4258 L4259: 11 byte(7)67,72,65,78,78,69,76,69,82,82,79,82,0 intern L4259 L4260: 15 byte(7)87,82,73,84,69,79,78,76,89,67,72,65,78,78,69,76,0 intern L4260 L4261: 14 byte(7)82,69,65,68,79,78,76,89,67,72,65,78,78,69,76,0 intern L4261 L4262: 26 byte(7)73,76,76,69,71,65,76,83,84,65,78,68,65,82,68,67,72,65,78,78,69,76,67,76,79,83,69,0 intern L4262 L4263: 6 byte(7)73,79,69,82,82,79,82,0 intern L4263 L4264: 8 byte(7)67,79,68,69,65,80,80,76,89,0 intern L4264 L4265: 12 byte(7)67,79,68,69,69,86,65,76,65,80,80,76,89,0 intern L4265 L4266: 7 byte(7)66,73,78,68,69,86,65,76,0 intern L4266 L4267: 5 byte(7)76,66,73,78,68,49,0 intern L4267 L4268: 25 byte(7)67,79,77,80,73,76,69,68,67,65,76,76,73,78,71,73,78,84,69,82,80,82,69,84,69,68,0 intern L4268 L4269: 13 byte(7)66,83,84,65,67,75,79,86,69,82,70,76,79,87,0 intern L4269 L4270: 17 byte(7)82,69,83,84,79,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4270 L4271: 10 byte(7)42,76,65,77,66,68,65,76,73,78,75,0 intern L4271 L4272: 16 byte(7)85,78,68,69,70,73,78,69,68,70,85,78,67,84,73,79,78,0 intern L4272 L4273: 6 byte(7)85,78,66,73,78,68,78,0 intern L4273 L4274: 4 byte(7)65,80,80,76,89,0 intern L4274 L4275: 8 byte(7)70,85,78,66,79,85,78,68,80,0 intern L4275 L4276: 5 byte(7)70,67,79,68,69,80,0 intern L4276 L4277: 14 byte(7)71,69,84,70,67,79,68,69,80,79,73,78,84,69,82,0 intern L4277 L4278: 2 byte(7)71,69,84,0 intern L4278 L4279: 8 byte(7)86,65,76,85,69,67,69,76,76,0 intern L4279 L4280: 8 byte(7)71,69,84,70,78,84,89,80,69,0 intern L4280 L4281: 8 byte(7)38,38,86,65,76,85,69,38,38,0 intern L4281 L4282: 8 byte(7)84,72,82,79,87,84,65,71,42,0 intern L4282 L4283: 8 byte(7)67,65,84,67,72,45,65,76,76,0 intern L4283 L4284: 9 byte(7)85,78,87,73,78,68,45,65,76,76,0 intern L4284 L4285: 9 byte(7)38,38,84,72,82,79,87,78,38,38,0 intern L4285 L4286: 15 byte(7)36,85,78,87,73,78,68,45,80,82,79,84,69,67,84,36,0 intern L4286 L4287: 6 byte(7)38,38,84,65,71,38,38,0 intern L4287 L4288: 5 byte(7)37,84,72,82,79,87,0 intern L4288 L4289: 13 byte(7)85,78,87,73,78,68,45,80,82,79,84,69,67,84,0 intern L4289 L4290: 5 byte(7)42,67,65,84,67,72,0 intern L4290 L4291: 5 byte(7)42,84,72,82,79,87,0 intern L4291 L4292: 4 byte(7)82,69,83,69,84,0 intern L4292 L4293: 17 byte(7)67,65,80,84,85,82,69,69,78,86,73,82,79,78,77,69,78,84,0 intern L4293 L4294: 17 byte(7)37,67,76,69,65,82,45,67,65,84,67,72,45,83,84,65,67,75,0 intern L4294 L4295: 8 byte(7)80,82,79,71,66,79,68,89,42,0 intern L4295 L4296: 13 byte(7)80,82,79,71,74,85,77,80,84,65,66,76,69,42,0 intern L4296 L4297: 3 byte(7)80,82,79,71,0 intern L4297 L4298: 5 byte(7)80,66,73,78,68,49,0 intern L4298 L4299: 5 byte(7)36,80,82,79,71,36,0 intern L4299 L4300: 1 byte(7)71,79,0 intern L4300 L4301: 5 byte(7)82,69,84,85,82,78,0 intern L4301 L4302: 11 byte(7)83,89,83,84,69,77,95,76,73,83,84,42,0 intern L4302 L4303: 3 byte(7)68,65,84,69,0 intern L4303 L4304: 7 byte(7)68,85,77,80,76,73,83,80,0 intern L4304 L4305: 13 byte(7)66,73,78,65,82,89,79,80,69,78,82,69,65,68,0 intern L4305 L4306: 8 byte(7)68,69,67,50,48,79,80,69,78,0 intern L4306 L4307: 14 byte(7)66,73,78,65,82,89,79,80,69,78,87,82,73,84,69,0 intern L4307 L4308: 16 byte(7)86,65,76,85,69,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4308 L4309: 15 byte(7)42,87,82,73,84,73,78,71,70,65,83,76,70,73,76,69,0 intern L4309 L4310: 16 byte(7)78,69,87,66,73,84,84,65,66,76,69,69,78,84,82,89,42,0 intern L4310 L4311: 11 byte(7)70,73,78,68,73,68,78,85,77,66,69,82,0 intern L4311 L4312: 16 byte(7)77,65,75,69,82,69,76,79,67,72,65,76,70,87,79,82,68,0 intern L4312 L4313: 15 byte(7)69,88,84,82,65,82,69,71,76,79,67,65,84,73,79,78,0 intern L4313 L4314: 19 byte(7)70,85,78,67,84,73,79,78,67,69,76,76,76,79,67,65,84,73,79,78,0 intern L4314 L4315: 5 byte(7)70,65,83,76,73,78,0 intern L4315 L4316: 5 byte(7)73,78,84,69,82,78,0 intern L4316 L4317: 7 byte(7)80,85,84,69,78,84,82,89,0 intern L4317 L4318: 15 byte(7)76,79,65,68,68,73,82,69,67,84,79,82,73,69,83,42,0 intern L4318 L4319: 14 byte(7)76,79,65,68,69,88,84,69,78,83,73,79,78,83,42,0 intern L4319 L4320: 11 byte(7)42,86,69,82,66,79,83,69,76,79,65,68,0 intern L4320 L4321: 14 byte(7)42,80,82,73,78,84,76,79,65,68,78,65,77,69,83,0 intern L4321 L4322: 3 byte(7)76,79,65,68,0 intern L4322 L4323: 4 byte(7)76,79,65,68,49,0 intern L4323 L4324: 5 byte(7)82,69,76,79,65,68,0 intern L4324 L4325: 7 byte(7)69,86,82,69,76,79,65,68,0 intern L4325 L4326: 8 byte(7)42,85,83,69,82,77,79,68,69,0 intern L4326 L4327: 8 byte(7)42,82,69,68,69,70,77,83,71,0 intern L4327 L4328: 10 byte(7)42,73,78,83,73,68,69,76,79,65,68,0 intern L4328 L4329: 5 byte(7)42,76,79,87,69,82,0 intern L4329 L4330: 12 byte(7)80,69,78,68,73,78,71,76,79,65,68,83,42,0 intern L4330 L4331: 6 byte(7)73,77,80,79,82,84,83,0 intern L4331 L4332: 10 byte(7)80,82,69,84,84,89,80,82,73,78,84,0 intern L4332 L4333: 8 byte(7)68,69,70,83,84,82,85,67,84,0 intern L4333 L4334: 3 byte(7)83,84,69,80,0 intern L4334 L4335: 3 byte(7)77,73,78,73,0 intern L4335 L4336: 4 byte(7)69,77,79,68,69,0 intern L4336 L4337: 5 byte(7)73,78,86,79,75,69,0 intern L4337 L4338: 4 byte(7)82,67,82,69,70,0 intern L4338 L4339: 5 byte(7)67,82,69,70,79,78,0 intern L4339 L4340: 7 byte(7)67,79,77,80,73,76,69,82,0 intern L4340 L4341: 4 byte(7)67,79,77,80,68,0 intern L4341 L4342: 6 byte(7)70,65,83,76,79,85,84,0 intern L4342 L4343: 2 byte(7)66,85,71,0 intern L4343 L4344: 3 byte(7)69,88,69,67,0 intern L4344 L4345: 1 byte(7)77,77,0 intern L4345 L4346: 19 byte(7)84,69,82,77,73,78,65,76,73,78,80,85,84,72,65,78,68,76,69,82,0 intern L4346 L4347: 15 byte(7)67,79,77,80,82,69,83,83,82,69,65,68,67,72,65,82,0 intern L4347 L4348: 13 byte(7)68,69,67,50,48,87,82,73,84,69,67,72,65,82,0 intern L4348 L4349: 16 byte(7)84,79,83,84,82,73,78,71,87,82,73,84,69,67,72,65,82,0 intern L4349 L4350: 15 byte(7)69,88,80,76,79,68,69,87,82,73,84,69,67,72,65,82,0 intern L4350 L4351: 16 byte(7)70,76,65,84,83,73,90,69,87,82,73,84,69,67,72,65,82,0 intern L4351 L4352: 4 byte(7)36,69,79,76,36,0 intern L4352 L4353: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,65,82,0 intern L4353 L4354: 7 byte(7)82,69,65,68,67,72,65,82,0 intern L4354 L4355: 2 byte(7)73,78,42,0 intern L4355 L4356: 16 byte(7)67,72,65,78,78,69,76,85,78,82,69,65,68,67,72,65,82,0 intern L4356 L4357: 9 byte(7)85,78,82,69,65,68,67,72,65,82,0 intern L4357 L4358: 3 byte(7)79,80,69,78,0 intern L4358 L4359: 21 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,73,78,80,85,84,0 intern L4359 L4360: 22 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,70,79,82,79,85,84,80,85,84,0 intern L4360 L4361: 20 byte(7)83,89,83,84,69,77,79,80,69,78,70,73,76,69,83,80,69,67,73,65,76,0 intern L4361 L4362: 19 byte(7)83,80,69,67,73,65,76,82,69,65,68,70,85,78,67,84,73,79,78,42,0 intern L4362 L4363: 20 byte(7)83,80,69,67,73,65,76,87,82,73,84,69,70,85,78,67,84,73,79,78,42,0 intern L4363 L4364: 20 byte(7)83,80,69,67,73,65,76,67,76,79,83,69,70,85,78,67,84,73,79,78,42,0 intern L4364 L4365: 6 byte(7)83,80,69,67,73,65,76,0 intern L4365 L4366: 5 byte(7)79,85,84,80,85,84,0 intern L4366 L4367: 4 byte(7)73,78,80,85,84,0 intern L4367 L4368: 4 byte(7)67,76,79,83,69,0 intern L4368 L4369: 24 byte(7)83,89,83,84,69,77,77,65,82,75,65,83,67,76,79,83,69,68,67,72,65,78,78,69,76,0 intern L4369 L4370: 16 byte(7)83,80,69,67,73,65,76,82,68,83,65,67,84,73,79,78,42,0 intern L4370 L4371: 5 byte(7)83,84,68,73,78,42,0 intern L4371 L4372: 16 byte(7)83,80,69,67,73,65,76,87,82,83,65,67,84,73,79,78,42,0 intern L4372 L4373: 6 byte(7)83,84,68,79,85,84,42,0 intern L4373 L4374: 11 byte(7)67,72,65,78,78,69,76,69,74,69,67,84,0 intern L4374 L4375: 4 byte(7)69,74,69,67,84,0 intern L4375 L4376: 16 byte(7)67,72,65,78,78,69,76,76,73,78,69,76,69,78,71,84,72,0 intern L4376 L4377: 9 byte(7)76,73,78,69,76,69,78,71,84,72,0 intern L4377 L4378: 3 byte(7)80,79,83,78,0 intern L4378 L4379: 11 byte(7)67,72,65,78,78,69,76,76,80,79,83,78,0 intern L4379 L4380: 4 byte(7)76,80,79,83,78,0 intern L4380 L4381: 12 byte(7)67,72,65,78,78,69,76,82,69,65,68,67,72,0 intern L4381 L4382: 5 byte(7)42,82,65,73,83,69,0 intern L4382 L4383: 5 byte(7)82,69,65,68,67,72,0 intern L4383 L4384: 4 byte(7)80,82,73,78,67,0 intern L4384 L4385: 11 byte(7)67,72,65,78,78,69,76,80,82,73,78,67,0 intern L4385 L4386: 25 byte(7)67,85,82,82,69,78,84,82,69,65,68,77,65,67,82,79,73,78,68,73,67,65,84,79,82,42,0 intern L4386 L4387: 24 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,87,73,84,72,72,79,79,75,83,0 intern L4387 L4388: 15 byte(7)67,72,65,78,78,69,76,82,69,65,68,84,79,75,69,78,0 intern L4388 L4389: 7 byte(7)84,79,75,84,89,80,69,42,0 intern L4389 L4390: 16 byte(7)67,85,82,82,69,78,84,83,67,65,78,84,65,66,76,69,42,0 intern L4390 L4391: 10 byte(7)67,72,65,78,78,69,76,82,69,65,68,0 intern L4391 L4392: 13 byte(7)76,73,83,80,83,67,65,78,84,65,66,76,69,42,0 intern L4392 L4393: 12 byte(7)76,73,83,80,82,69,65,68,77,65,67,82,79,0 intern L4393 L4394: 17 byte(7)77,65,75,69,73,78,80,85,84,65,86,65,73,76,65,66,76,69,0 intern L4394 L4395: 19 byte(7)42,73,78,83,73,68,69,83,84,82,85,67,84,85,82,69,82,69,65,68,0 intern L4395 L4396: 13 byte(7)67,72,65,78,78,69,76,82,69,65,68,69,79,70,0 intern L4396 L4397: 4 byte(7)36,69,79,70,36,0 intern L4397 L4398: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,81,85,79,84,69,68,69,88,80,82,69,83,83,73,79,78,0 intern L4398 L4399: 26 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,83,84,79,82,68,79,84,84,69,68,80,65,73,82,0 intern L4399 L4400: 20 byte(7)67,72,65,78,78,69,76,82,69,65,68,82,73,71,72,84,80,65,82,69,78,0 intern L4400 L4401: 16 byte(7)67,72,65,78,78,69,76,82,69,65,68,86,69,67,84,79,82,0 intern L4401 L4402: 11 byte(7)42,67,79,77,80,82,69,83,83,73,78,71,0 intern L4402 L4403: 13 byte(7)42,69,79,76,73,78,83,84,82,73,78,71,79,75,0 intern L4403 L4404: 4 byte(7)78,69,87,73,68,0 intern L4404 L4405: 24 byte(7)77,65,75,69,83,84,82,73,78,71,73,78,84,79,76,73,83,80,73,78,84,69,71,69,82,0 intern L4405 L4406: 12 byte(7)68,73,71,73,84,84,79,78,85,77,66,69,82,0 intern L4406 L4407: 6 byte(7)80,65,67,75,65,71,69,0 intern L4407 L4408: 14 byte(7)67,85,82,82,69,78,84,80,65,67,75,65,71,69,42,0 intern L4408 L4409: 5 byte(7)71,76,79,66,65,76,0 intern L4409 L4410: 4 byte(7)82,65,84,79,77,0 intern L4410 L4411: 7 byte(7)82,69,65,68,76,73,78,69,0 intern L4411 L4412: 14 byte(7)67,72,65,78,78,69,76,82,69,65,68,76,73,78,69,0 intern L4412 L4413: 10 byte(7)79,85,84,80,85,84,66,65,83,69,42,0 intern L4413 L4414: 12 byte(7)73,68,69,83,67,65,80,69,67,72,65,82,42,0 intern L4414 L4415: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,84,82,73,78,71,0 intern L4415 L4416: 10 byte(7)87,82,73,84,69,83,84,82,73,78,71,0 intern L4416 L4417: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4417 L4418: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,73,84,83,84,82,65,85,88,0 intern L4418 L4419: 14 byte(7)87,82,73,84,69,83,89,83,73,78,84,69,71,69,82,0 intern L4419 L4420: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,73,88,78,85,77,0 intern L4420 L4421: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,78,84,69,71,69,82,0 intern L4421 L4422: 19 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,83,89,83,70,76,79,65,84,0 intern L4422 L4423: 9 byte(7)87,82,73,84,69,70,76,79,65,84,0 intern L4423 L4424: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,70,76,79,65,84,0 intern L4424 L4425: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,83,84,82,73,78,71,0 intern L4425 L4426: 13 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,73,68,0 intern L4426 L4427: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,85,78,66,79,85,78,68,0 intern L4427 L4428: 13 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,73,68,0 intern L4428 L4429: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,85,78,66,79,85,78,68,0 intern L4429 L4430: 22 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,67,79,68,69,80,79,73,78,84,69,82,0 intern L4430 L4431: 21 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,76,65,78,75,79,82,69,79,76,0 intern L4431 L4432: 15 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,80,65,73,82,0 intern L4432 L4433: 8 byte(7)80,82,73,78,76,69,86,69,76,0 intern L4433 L4434: 9 byte(7)80,82,73,78,76,69,78,71,84,72,0 intern L4434 L4435: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,50,0 intern L4435 L4436: 15 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,80,65,73,82,0 intern L4436 L4437: 20 byte(7)82,69,67,85,82,83,73,86,69,67,72,65,78,78,69,76,80,82,73,78,49,0 intern L4437 L4438: 17 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,86,69,67,84,79,82,0 intern L4438 L4439: 17 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,86,69,67,84,79,82,0 intern L4439 L4440: 18 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,69,86,69,67,84,79,82,0 intern L4440 L4441: 25 byte(7)79,66,74,69,67,84,45,71,69,84,45,72,65,78,68,76,69,82,45,81,85,73,69,84,76,89,0 intern L4441 L4442: 10 byte(7)67,72,65,78,78,69,76,80,82,73,78,0 intern L4442 L4443: 18 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,69,86,69,67,84,79,82,0 intern L4443 L4444: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,87,79,82,68,83,0 intern L4444 L4445: 20 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,72,65,76,70,87,79,82,68,83,0 intern L4445 L4446: 16 byte(7)67,72,65,78,78,69,76,87,82,73,84,69,66,89,84,69,83,0 intern L4446 L4447: 4 byte(7)80,82,73,78,50,0 intern L4447 L4448: 15 byte(7)70,79,82,77,65,84,70,79,82,80,82,73,78,84,70,42,0 intern L4448 L4449: 5 byte(7)80,82,73,78,50,76,0 intern L4449 L4450: 6 byte(7)69,82,82,80,82,73,78,0 intern L4450 L4451: 12 byte(7)67,72,65,78,78,69,76,80,82,73,78,84,70,0 intern L4451 L4452: 17 byte(7)69,88,80,76,79,68,69,69,78,68,80,79,73,78,84,69,82,42,0 intern L4452 L4453: 6 byte(7)69,88,80,76,79,68,69,0 intern L4453 L4454: 7 byte(7)69,88,80,76,79,68,69,50,0 intern L4454 L4455: 8 byte(7)70,76,65,84,83,73,90,69,50,0 intern L4455 L4456: 12 byte(7)67,79,77,80,82,69,83,83,69,82,82,79,82,0 intern L4456 L4457: 12 byte(7)67,79,77,80,82,69,83,83,76,73,83,84,42,0 intern L4457 L4458: 19 byte(7)67,76,69,65,82,67,79,77,80,82,69,83,83,67,72,65,78,78,69,76,0 intern L4458 L4459: 7 byte(7)67,79,77,80,82,69,83,83,0 intern L4459 L4460: 6 byte(7)73,77,80,76,79,68,69,0 intern L4460 L4461: 9 byte(7)67,72,65,78,78,69,76,84,89,73,0 intern L4461 L4462: 9 byte(7)67,72,65,78,78,69,76,84,89,79,0 intern L4462 L4463: 2 byte(7)84,89,73,0 intern L4463 L4464: 2 byte(7)84,89,79,0 intern L4464 L4465: 13 byte(7)67,79,77,77,69,78,84,79,85,84,67,79,68,69,0 intern L4465 L4466: 10 byte(7)67,79,77,80,73,76,69,84,73,77,69,0 intern L4466 L4467: 8 byte(7)66,79,84,72,84,73,77,69,83,0 intern L4467 L4468: 7 byte(7)76,79,65,68,84,73,77,69,0 intern L4468 L4469: 10 byte(7)83,84,65,82,84,85,80,84,73,77,69,0 intern L4469 L4470: 8 byte(7)67,79,78,84,69,82,82,79,82,0 intern L4470 L4471: 8 byte(7)79,84,72,69,82,87,73,83,69,0 intern L4471 L4472: 6 byte(7)68,69,70,65,85,76,84,0 intern L4472 L4473: 3 byte(7)67,65,83,69,0 intern L4473 L4474: 4 byte(7)82,65,78,71,69,0 intern L4474 L4475: 3 byte(7)83,69,84,70,0 intern L4475 L4476: 9 byte(7)69,88,80,65,78,68,83,69,84,70,0 intern L4476 L4477: 10 byte(7)83,69,84,70,45,69,88,80,65,78,68,0 intern L4477 L4478: 8 byte(7)65,83,83,73,71,78,45,79,80,0 intern L4478 L4479: 5 byte(7)79,78,79,70,70,42,0 intern L4479 L4480: 8 byte(7)77,75,70,76,65,71,86,65,82,0 intern L4480 L4481: 5 byte(7)83,73,77,80,70,71,0 intern L4481 L4482: 1 byte(7)79,78,0 intern L4482 L4483: 2 byte(7)79,70,70,0 intern L4483 L4484: 3 byte(7)35,65,82,71,0 intern L4484 L4485: 1 byte(7)68,83,0 intern L4485 L4486: 7 byte(7)68,69,70,67,79,78,83,84,0 intern L4486 L4487: 9 byte(7)69,86,68,69,70,67,79,78,83,84,0 intern L4487 L4488: 4 byte(7)67,79,78,83,84,0 intern L4488 L4489: 11 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,0 intern L4489 L4490: 12 byte(7)83,84,82,73,78,71,71,69,78,83,89,77,42,0 intern L4490 L4491: 6 byte(7)70,79,82,69,65,67,72,0 intern L4491 L4492: 6 byte(7)67,79,76,76,69,67,84,0 intern L4492 L4493: 3 byte(7)74,79,73,78,0 intern L4493 L4494: 3 byte(7)67,79,78,67,0 intern L4494 L4495: 1 byte(7)73,78,0 intern L4495 L4496: 1 byte(7)68,79,0 intern L4496 L4497: 3 byte(7)69,88,73,84,0 intern L4497 L4498: 5 byte(7)36,76,79,79,80,36,0 intern L4498 L4499: 3 byte(7)78,69,88,84,0 intern L4499 L4500: 4 byte(7)87,72,73,76,69,0 intern L4500 L4501: 5 byte(7)82,69,80,69,65,84,0 intern L4501 L4502: 2 byte(7)70,79,82,0 intern L4502 L4503: 5 byte(7)71,69,78,83,89,77,0 intern L4503 L4504: 4 byte(7)77,75,42,83,81,0 intern L4504 L4505: 3 byte(7)83,73,77,80,0 intern L4505 L4506: 2 byte(7)66,73,78,0 intern L4506 L4507: 11 byte(7)70,76,65,77,66,68,65,76,73,78,75,80,0 intern L4507 L4508: 11 byte(7)77,65,75,69,70,85,78,66,79,85,78,68,0 intern L4508 L4509: 14 byte(7)77,65,75,69,70,76,65,77,66,68,65,76,73,78,75,0 intern L4509 L4510: 8 byte(7)77,65,75,69,70,67,79,68,69,0 intern L4510 L4511: 3 byte(7)80,82,79,80,0 intern L4511 L4512: 6 byte(7)83,69,84,80,82,79,80,0 intern L4512 L4513: 4 byte(7)70,76,65,71,80,0 intern L4513 L4514: 3 byte(7)84,89,80,69,0 intern L4514 L4515: 3 byte(7)70,76,65,71,0 intern L4515 L4516: 4 byte(7)70,76,65,71,49,0 intern L4516 L4517: 6 byte(7)82,69,77,70,76,65,71,0 intern L4517 L4518: 7 byte(7)82,69,77,70,76,65,71,49,0 intern L4518 L4519: 6 byte(7)82,69,77,80,82,79,80,0 intern L4519 L4520: 7 byte(7)82,69,77,80,82,79,80,76,0 intern L4520 L4521: 7 byte(7)85,78,66,79,85,78,68,80,0 intern L4521 L4522: 6 byte(7)86,65,82,84,89,80,69,0 intern L4522 L4523: 4 byte(7)70,76,85,73,68,0 intern L4523 L4524: 5 byte(7)70,76,85,73,68,49,0 intern L4524 L4525: 5 byte(7)70,76,85,73,68,80,0 intern L4525 L4526: 6 byte(7)71,76,79,66,65,76,49,0 intern L4526 L4527: 6 byte(7)71,76,79,66,65,76,80,0 intern L4527 L4528: 6 byte(7)85,78,70,76,85,73,68,0 intern L4528 L4529: 7 byte(7)85,78,70,76,85,73,68,49,0 intern L4529 L4530: 3 byte(7)82,69,77,68,0 intern L4530 L4531: 4 byte(7)42,67,79,77,80,0 intern L4531 L4532: 3 byte(7)85,83,69,82,0 intern L4532 L4533: 3 byte(7)76,79,83,69,0 intern L4533 L4534: 23 byte(7)67,79,68,69,45,78,85,77,66,69,82,45,79,70,45,65,82,71,85,77,69,78,84,83,0 intern L4534 L4535: 14 byte(7)66,83,84,65,67,75,85,78,68,69,82,70,76,79,87,0 intern L4535 L4536: 12 byte(7)67,76,69,65,82,66,73,78,68,73,78,71,83,0 intern L4536 L4537: 10 byte(7)77,65,75,69,85,78,66,79,85,78,68,0 intern L4537 L4538: 11 byte(7)72,65,83,72,70,85,78,67,84,73,79,78,0 intern L4538 L4539: 4 byte(7)82,69,77,79,66,0 intern L4539 L4540: 6 byte(7)73,78,84,69,82,78,80,0 intern L4540 L4541: 11 byte(7)73,78,84,69,82,78,71,69,78,83,89,77,0 intern L4541 L4542: 5 byte(7)77,65,80,79,66,76,0 intern L4542 L4543: 11 byte(7)71,76,79,66,65,76,76,79,79,75,85,80,0 intern L4543 L4544: 12 byte(7)71,76,79,66,65,76,73,78,83,84,65,76,76,0 intern L4544 L4545: 11 byte(7)71,76,79,66,65,76,82,69,77,79,86,69,0 intern L4545 L4546: 9 byte(7)73,78,73,84,79,66,76,73,83,84,0 intern L4546 L4547: 12 byte(7)68,69,67,50,48,82,69,65,68,67,72,65,82,0 intern L4547 L4548: 4 byte(7)42,69,67,72,79,0 intern L4548 L4549: 6 byte(7)67,76,69,65,82,73,79,0 intern L4549 L4550: 16 byte(7)68,69,67,50,48,67,76,79,83,69,67,72,65,78,78,69,76,0 intern L4550 L4551: 4 byte(7)42,68,69,70,78,0 intern L4551 L4552: 10 byte(7)66,82,69,65,75,86,65,76,85,69,42,0 intern L4552 L4553: 9 byte(7)42,81,85,73,84,66,82,69,65,75,0 intern L4553 L4554: 7 byte(7)66,82,69,65,75,73,78,42,0 intern L4554 L4555: 8 byte(7)66,82,69,65,75,79,85,84,42,0 intern L4555 L4556: 11 byte(7)84,79,80,76,79,79,80,78,65,77,69,42,0 intern L4556 L4557: 11 byte(7)84,79,80,76,79,79,80,69,86,65,76,42,0 intern L4557 L4558: 9 byte(7)66,82,69,65,75,69,86,65,76,42,0 intern L4558 L4559: 9 byte(7)66,82,69,65,75,78,65,77,69,42,0 intern L4559 L4560: 12 byte(7)84,79,80,76,79,79,80,80,82,73,78,84,42,0 intern L4560 L4561: 11 byte(7)84,79,80,76,79,79,80,82,69,65,68,42,0 intern L4561 L4562: 6 byte(7)84,79,80,76,79,79,80,0 intern L4562 L4563: 6 byte(7)36,66,82,69,65,75,36,0 intern L4563 L4564: 8 byte(7)66,82,69,65,75,69,86,65,76,0 intern L4564 L4565: 12 byte(7)66,82,69,65,75,70,85,78,67,84,73,79,78,0 intern L4565 L4566: 8 byte(7)66,82,69,65,75,81,85,73,84,0 intern L4566 L4567: 12 byte(7)66,82,69,65,75,67,79,78,84,73,78,85,69,0 intern L4567 L4568: 9 byte(7)66,82,69,65,75,82,69,84,82,89,0 intern L4568 L4569: 8 byte(7)72,69,76,80,66,82,69,65,75,0 intern L4569 L4570: 10 byte(7)66,82,69,65,75,69,82,82,77,83,71,0 intern L4570 L4571: 8 byte(7)66,82,69,65,75,69,68,73,84,0 intern L4571 L4572: 12 byte(7)84,79,80,76,79,79,80,76,69,86,69,76,42,0 intern L4572 L4573: 12 byte(7)72,73,83,84,79,82,89,67,79,85,78,84,42,0 intern L4573 L4574: 10 byte(7)76,73,83,80,66,65,78,78,69,82,42,0 intern L4574 L4575: 6 byte(7)42,79,85,84,80,85,84,0 intern L4575 L4576: 5 byte(7)83,69,77,73,67,42,0 intern L4576 L4577: 11 byte(7)72,73,83,84,79,82,89,76,73,83,84,42,0 intern L4577 L4578: 4 byte(7)42,84,73,77,69,0 intern L4578 L4579: 3 byte(7)84,73,77,69,0 intern L4579 L4580: 5 byte(7)42,78,79,78,73,76,0 intern L4580 L4581: 12 byte(7)36,69,88,73,84,84,79,80,76,79,79,80,36,0 intern L4581 L4582: 7 byte(7)68,70,80,82,73,78,84,42,0 intern L4582 L4583: 5 byte(7)73,71,78,79,82,69,0 intern L4583 L4584: 2 byte(7)73,78,80,0 intern L4584 L4585: 3 byte(7)82,69,68,79,0 intern L4585 L4586: 2 byte(7)65,78,83,0 intern L4586 L4587: 3 byte(7)72,73,83,84,0 intern L4587 L4588: 4 byte(7)67,76,69,65,82,0 intern L4588 L4589: 11 byte(7)83,84,65,78,68,65,82,68,76,73,83,80,0 intern L4589 L4590: 17 byte(7)80,82,73,78,84,87,73,84,72,70,82,69,83,72,76,73,78,69,0 intern L4590 L4591: 9 byte(7)83,65,86,69,83,89,83,84,69,77,0 intern L4591 L4592: 9 byte(7)73,78,73,84,70,79,82,77,83,42,0 intern L4592 L4593: 12 byte(7)69,86,65,76,73,78,73,84,70,79,82,77,83,0 intern L4593 L4594: 4 byte(7)68,83,75,73,78,0 intern L4594 L4595: 8 byte(7)68,83,75,73,78,69,86,65,76,0 intern L4595 L4596: 4 byte(7)76,65,80,73,78,0 intern L4596 L4597: 4 byte(7)77,65,73,78,46,0 intern L4597 L4598: 7 byte(7)80,82,69,45,77,65,73,78,0 intern L4598 L4599: 3 byte(7)77,65,73,78,0 intern L4599 L4600: 7 byte(7)73,78,73,84,67,79,68,69,0 intern L4600 L4601: 2 byte(7)69,79,70,0 intern L4601 L4602: 8 byte(7)67,72,65,82,67,79,78,83,84,0 intern L4602 L4603: 4 byte(7)68,69,67,50,48,0 intern L4603 L4604: 4 byte(7)80,68,80,49,48,0 intern L4604 L4605: 5 byte(7)84,79,80,83,50,48,0 intern L4605 L4606: 3 byte(7)75,76,49,48,0 intern L4606 L4607: 12 byte(7)76,73,83,80,68,73,80,72,84,72,79,78,71,0 intern L4607 end MAIN. |
Added psl-1983/lap/main.mic version [279c8b6a77].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;; Independent compilation a program for the 20 ;; MAIN module and data_segement, do last ; MIC MAIN modulename ; modulename=symboltablename @define DSK:, DSK:, P20:, PV:, PI: @delete 'A.mac @delete D'A.mac ;avoid obnoixous ^Q halts... @terminal length 0 @s:DEC20-CROSS.EXE off break; % avoid obnoxios breaks InputSymFile!* := "'A.sym"$ OutputSymFile!* := "'A.sym"$ GlobalDataFileName!* := "20-test-global-data.red"$ ON PCMAC, PGWD$ % see macro expansion !*MAIN := ''T; ModName!*:='' 'A; ASMOUT "'A"$ off StandAlone$ % Should emit SYMFNC inits IN "'A.red"$ off pcmac,pgwd; % Suppress echo before INIT ASMEnd$ quit$ @terminal length 24 @macro *'A.rel='A.mac *D'A.rel=D'A.mac |
Added psl-1983/lap/man.b version [ca516e0bc7].
cannot compute difference between binary files
Added psl-1983/lap/mathlib.b version [8b5a8768b4].
cannot compute difference between binary files
Added psl-1983/lap/menu.b version [ed4752e3d2].
cannot compute difference between binary files
Added psl-1983/lap/mini.b version [d0b1b52378].
cannot compute difference between binary files
Added psl-1983/lap/monsym.b version [5fd4f199ab].
cannot compute difference between binary files
Added psl-1983/lap/narith.b version [8d4a8d53c8].
cannot compute difference between binary files
Added psl-1983/lap/nbarith.b version [78db1b22b2].
cannot compute difference between binary files
Added psl-1983/lap/nbig.lap version [072abfcdff].
> | 1 | (load nbarith vector!-fix nbig0) |
Added psl-1983/lap/nbig0.b version [9f54bc0643].
cannot compute difference between binary files
Added psl-1983/lap/nbig1.b version [e6d08f0145].
cannot compute difference between binary files
Added psl-1983/lap/nbigbig.b version [98644849eb].
cannot compute difference between binary files
Added psl-1983/lap/nbigface.b version [53802979b9].
cannot compute difference between binary files
Added psl-1983/lap/new-fileio.b version [0fc492f860].
cannot compute difference between binary files
Added psl-1983/lap/nmode-attributes.b version [dc2782e8fa].
cannot compute difference between binary files
Added psl-1983/lap/nmode-parsing.b version [388fd5a7dd].
cannot compute difference between binary files
Added psl-1983/lap/nmode.lap version [f6657c5a06].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (load directory) (load extended-char) (load input-stream) (load objects) (load output-stream) (load nmode-parsing) (load pathnames) (load processor-time) (load rawio) (load ring-buffer) (load vector-fix) % for TruncateVector (load windows) (faslin "pn:browser.b") (faslin "pn:browser-support.b") (faslin "pn:buffer-io.b") (faslin "pn:buffer-position.b") (faslin "pn:buffer-window.b") (faslin "pn:buffer.b") (faslin "pn:buffers.b") (faslin "pn:case-commands.b") (faslin "pn:command-input.b") (faslin "pn:commands.b") (faslin "pn:defun-commands.b") (faslin "pn:dispatch.b") (faslin "pn:extended-input.b") (faslin "pn:fileio.b") (faslin "pn:incr.b") (faslin "pn:indent-commands.b") (faslin "pn:kill-commands.b") (faslin "pn:lisp-commands.b") (faslin "pn:lisp-indenting.b") (faslin "pn:lisp-interface.b") (faslin "pn:lisp-parser.b") (faslin "pn:m-x.b") (faslin "pn:m-xcmd.b") (faslin "pn:mode-defs.b") (faslin "pn:modes.b") (faslin "pn:move-commands.b") (faslin "pn:nmode-20.b") (faslin "pn:nmode-break.b") (faslin "pn:nmode-init.b") (faslin "pn:prompting.b") (faslin "pn:query-replace.b") (faslin "pn:reader.b") (faslin "pn:rec.b") (faslin "pn:screen-layout.b") (faslin "pn:search.b") (faslin "pn:set-terminal.b") % compiled from set-terminal-20, etc. (faslin "pn:softkeys.b") (faslin "pn:structure-functions.b") (faslin "pn:terminal-input.b") (faslin "pn:text-buffer.b") (faslin "pn:text-commands.b") (faslin "pn:window.b") (faslin "pn:window-label.b") % Subsystems: load last! (they define modes at load-time) (faslin "pn:autofill.b") (faslin "pn:buffer-browser.b") (faslin "pn:dired.b") (faslin "pn:doc.b") |
Added psl-1983/lap/non-kl-comp.b version [2e810e4b99].
cannot compute difference between binary files
Added psl-1983/lap/nstruct.b version [0012b6046a].
cannot compute difference between binary files
Added psl-1983/lap/numeric-operators.b version [3da14d1d81].
cannot compute difference between binary files
Added psl-1983/lap/objects.b version [d6f7864fec].
cannot compute difference between binary files
Added psl-1983/lap/output-stream.b version [916aebd2c6].
cannot compute difference between binary files
Added psl-1983/lap/package.b version [2bc4da3049].
cannot compute difference between binary files
Added psl-1983/lap/parse-command-string.b version [b2e3be648c].
cannot compute difference between binary files
Added psl-1983/lap/pass-1-lap.b version [cc7227de3c].
cannot compute difference between binary files
Added psl-1983/lap/pass-one-lap.b version [c3da6922bb].
cannot compute difference between binary files
Added psl-1983/lap/pathin.b version [d2b238cb89].
cannot compute difference between binary files
Added psl-1983/lap/pathnames.b version [bd9a3486f0].
cannot compute difference between binary files
Added psl-1983/lap/pathnamex.b version [79dbbcd96c].
cannot compute difference between binary files
Added psl-1983/lap/pcheck.b version [80eb668d40].
cannot compute difference between binary files
Added psl-1983/lap/poly.b version [349da57893].
cannot compute difference between binary files
Added psl-1983/lap/pr-driv.b version [a1c26ef44a].
cannot compute difference between binary files
Added psl-1983/lap/pr-main.b version [0637d1ffbb].
cannot compute difference between binary files
Added psl-1983/lap/pr-text.b version [5b43311110].
cannot compute difference between binary files
Added psl-1983/lap/pr2d-driv.b version [8f1ffcaab6].
cannot compute difference between binary files
Added psl-1983/lap/pr2d-main.b version [42d73dcba0].
cannot compute difference between binary files
Added psl-1983/lap/pr2d-text.b version [5a2dc746f4].
cannot compute difference between binary files
Added psl-1983/lap/pretty.b version [330d0c3878].
cannot compute difference between binary files
Added psl-1983/lap/prettyprint.b version [cc5ac92e65].
cannot compute difference between binary files
Added psl-1983/lap/printer-fix.b version [5aefbabb7e].
cannot compute difference between binary files
Added psl-1983/lap/prlisp.lap version [2ba556a99f].
> | 1 | (load rawio mathlib pr-main pr-text pr-driv) |
Added psl-1983/lap/prlisp2d.lap version [83e49b92a4].
> | 1 | (load rawio mathlib pr2d-main pr2d-text pr2d-driv) |
Added psl-1983/lap/processor-time.b version [4d305c6349].
cannot compute difference between binary files
Added psl-1983/lap/program-command-interpreter.b version [98820d2f0d].
cannot compute difference between binary files
Added psl-1983/lap/pslcomp-main.b version [d0ad338f36].
cannot compute difference between binary files
Added psl-1983/lap/rawbreak.b version [56b2fe00b6].
cannot compute difference between binary files
Added psl-1983/lap/rawio.b version [9502faccd3].
cannot compute difference between binary files
Added psl-1983/lap/rcref.b version [3637d6a7d7].
cannot compute difference between binary files
Added psl-1983/lap/read-init-file.b version [114d35254f].
cannot compute difference between binary files
Added psl-1983/lap/read-utils.b version [6a9e9831e7].
cannot compute difference between binary files
Added psl-1983/lap/readme version [1adbe29d87].
> | 1 | This directory contain only LAP files used by Portable Standard LISP. |
Added psl-1983/lap/ring-buffer.b version [68a7da3060].
cannot compute difference between binary files
Added psl-1983/lap/rlisp.b version [55df96b9aa].
cannot compute difference between binary files
Added psl-1983/lap/rlispcomp.b version [914ffd5678].
cannot compute difference between binary files
Added psl-1983/lap/rprint.b version [6a8951d6d9].
cannot compute difference between binary files
Added psl-1983/lap/signal.b version [91fa756300].
cannot compute difference between binary files
Added psl-1983/lap/slow-strings.b version [058d70e847].
cannot compute difference between binary files
Added psl-1983/lap/slow-vectors.b version [c32248ee57].
cannot compute difference between binary files
Added psl-1983/lap/sm.b version [60a4a4976b].
cannot compute difference between binary files
Added psl-1983/lap/step.b version [ce1e330331].
cannot compute difference between binary files
Added psl-1983/lap/string-input.b version [137dfa51f7].
cannot compute difference between binary files
Added psl-1983/lap/string-search.b version [509e370c3c].
cannot compute difference between binary files
Added psl-1983/lap/strings.b version [1ed3e5ff66].
cannot compute difference between binary files
Added psl-1983/lap/stringx.b version [b8aa0e1849].
cannot compute difference between binary files
Added psl-1983/lap/syslisp.b version [5324c94a8f].
cannot compute difference between binary files
Added psl-1983/lap/teleray.b version [33326ccb3c].
cannot compute difference between binary files
Added psl-1983/lap/tenex-asm.b version [bb332a8f24].
cannot compute difference between binary files
Added psl-1983/lap/useful.b version [af30457f93].
cannot compute difference between binary files
Added psl-1983/lap/util.b version [479683780b].
cannot compute difference between binary files
Added psl-1983/lap/vector-fix.b version [cf0d9a00c9].
cannot compute difference between binary files
Added psl-1983/lap/vs-support.b version [524109cbb4].
cannot compute difference between binary files
Added psl-1983/lap/vt100.b version [aa33880a9e].
cannot compute difference between binary files
Added psl-1983/lap/vt52.b version [087a9ffb4e].
cannot compute difference between binary files
Added psl-1983/lap/wait.b version [5082960630].
cannot compute difference between binary files
Added psl-1983/lap/windows.lap version [900262c232].
> > > > > | 1 2 3 4 5 | (faslin "pw:hp2648a.b") (faslin "pw:physical-screen.b") (faslin "pw:shared-physical-screen.b") (faslin "pw:virtual-screen.b") (faslin "pw:vt52x.b") |
Added psl-1983/lap/zbasic.b version [49233ba8b5].
cannot compute difference between binary files
Added psl-1983/lap/zboot.b version [2b3dc4474e].
cannot compute difference between binary files
Added psl-1983/lap/zfiles.b version [bebbca4be2].
cannot compute difference between binary files
Added psl-1983/lap/zmacro.b version [81dd1c0dc3].
cannot compute difference between binary files
Added psl-1983/lap/zpedit.b version [cec0cd92e9].
cannot compute difference between binary files
Added psl-1983/lpt/0-titlepage.lpt version [10d3f09334].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | TR-10 March 1981 THE PORTABLE STANDARD LISP USERS MANUAL THE PORTABLE STANDARD LISP USERS MANUAL THE PORTABLE STANDARD LISP USERS MANUAL BY BY BY THE UTAH SYMBOLIC COMPUTATION GROUP THE UTAH SYMBOLIC COMPUTATION GROUP THE UTAH SYMBOLIC COMPUTATION GROUP Department of Computer Science University of Utah Salt Lake City, Utah 84112 Version 3.1: 7 February 1983 ABSTRACT ABSTRACT ABSTRACT This manual describes the primitive data structures, facilities and functions present in the Portable Standard LISP (PSL) system. It describes the implementation details and functions of interest to a PSL programmer. Except for a small number of hand-coded routines for I/O and efficient function calling, PSL is written entirely in itself, using a machine-oriented mode of PSL, called SYSLISP, to perform word, byte, and efficient integer and string operations. PSL is compiled by an enhanced version of the Portable LISP Compiler, and currently runs on the DEC-20, VAX, and MC68000. Copyright (c) 1982 W. Galway, M. L. Griss, B. Morrison, and B. Othmer Work supported in part by the National Science Foundation under Grant Numbers MCS80-07034 and MCS82-04247. |
Added psl-1983/lpt/00-preface.lpt version [0e09c5f676].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Preface Preface Preface This Portable LISP implementation would not have been started without the effort and inspiration of the original STANDARD LISP reporters (A. C. Hearn, J. Marti, M. L. Griss and C. Griss) and the many people who gave freely of their advice (often unsolicited!). We especially appreciate the comments of A. Norman, M. Rothstein, H. Stoyan and T. Ager. It would not have been completed without the efforts of the many people who have worked arduously on SYSLISP and PSL at various levels: Eric Benson, Will Galway, Ellen Gibson, Martin Griss, Bob Kessler, Steve Lowder, Chip Maguire, Beryl Morrison, Don Morrison, Bobbie Othmer, Bob Pendleton, and John Peterson. We are also grateful for the many comments and significant contributions by the LISP users at the Hewlett-Packard Computer Research Center in Palo Alto. This document has been worked on by most members of the current Utah Symbolic Computation Group. The primary editorial function has been in the hands of B. Morrison, M. L. Griss, B. Othmer, and W. Galway; major sections have been contributed by E. Benson, W. Galway, and D. Morrison. This is a preliminary version of the manual, and so may suffer from a number of errors and omissions. Please let us know of problems you may detect. We have also made some stylistic decisions regarding Font to indicate semantic classification and Case to make symbols more readable. Based on feedback from users of the earlier 3.0 PSL release and manual, we have decided to use LISP syntax as the primary description language; where appropriate RLISP syntax also appears. We would appreciate comments on these and other decisions. Based on feedback from numerous users, this issue of the manual uses LISP syntax rather than RLISP as the primary description language; where appropriate, RLISP syntax also appears. Report bugs, errors and mis-features by sending MAIL to PSL-BUGS@Utah-20; Bug Bug alternatively, send a message to Griss from within PSL by calling the Bug function, BUG(); in RLISP. Permission is given to copy this manual for internal use with the PSL system. |
Added psl-1983/lpt/000-contents.lpt version [46ecf5d04d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 page i Table of Contents TABLE OF CONTENTS TABLE OF CONTENTS TABLE OF CONTENTS CHAPTER 1. INTRODUCTION CHAPTER 1. INTRODUCTION CHAPTER 1. INTRODUCTION 1.1. Opening Remarks . . . . . . . . . . . . . . 1.1 1.2. Scope of the Manual . . . . . . . . . . . . . 1.2 1.2.1. Typographic Conventions within the Manual . . . 1.2 1.2.2. The Organization of the Manual . . . . . . . 1.3 CHAPTER 2. GETTING STARTED WITH PSL CHAPTER 2. GETTING STARTED WITH PSL CHAPTER 2. GETTING STARTED WITH PSL 2.1. Purpose of This Chapter. . . . . . . . . . . . 2.1 2.2. Defining Logical Device Names for PSL . . . . . . . 2.1 2.2.1. DEC-20 . . . . . . . . . . . . . . . 2.2 2.2.2. VAX . . . . . . . . . . . . . . . . 2.2 2.3. Starting PSL . . . . . . . . . . . . . . . 2.3 2.3.1. DEC-20 . . . . . . . . . . . . . . . 2.3 2.3.2. VAX . . . . . . . . . . . . . . . . 2.3 2.4. Running the PSL System . . . . . . . . . . . . 2.4 2.4.1. Loading Optional Modules . . . . . . . . . 2.4 2.4.2. Notes on Running PSL and RLISP . . . . . . . 2.4 2.4.3. Transcript of a Short Session with PSL . . . . 2.5 2.5. Error and Warning Messages. . . . . . . . . . . 2.8 2.6. Compilation Versus Interpretation . . . . . . . . 2.8 2.7. Function Types. . . . . . . . . . . . . . . 2.9 2.8. Switches and Globals. . . . . . . . . . . . . 2.10 2.9. Reporting Errors and Misfeatures. . . . . . . . . 2.10 CHAPTER 3. RLISP SYNTAX CHAPTER 3. RLISP SYNTAX CHAPTER 3. RLISP SYNTAX 3.1. Motivation for RLISP Interface to PSL . . . . . . . 3.1 3.2. An Introduction to RLISP . . . . . . . . . . . 3.2 3.2.1. LISP equivalents of some RLISP constructs . . . 3.2 3.3. An Overview of RLISP and LISP Syntax Correspondence . . 3.3 3.3.1. Function Call Syntax in RLISP and LISP . . . . 3.3 ... 3.3.2. RLISP Infix Operators and Associated LISP Functions....3.4 3.3.3. Differences between Parse and Read. . . . . . 3.6 3.3.4. Procedure Definition . . . . . . . . . . 3.6 3.3.5. Compound Statement Grouping . . . . . . . . 3.7 3.3.6. Blocks with Local Variables . . . . . . . . 3.7 PSL Manual 7 February 1983 page ii Table of Contents 3.3.7. The If Then Else Statement . . . . . . . . 3.8 3.4. Looping Statements . . . . . . . . . . . . . 3.8 3.4.1. While Loop. . . . . . . . . . . . . . 3.8 3.4.2. Repeat Loop . . . . . . . . . . . . . 3.8 3.4.3. For Each Loop. . . . . . . . . . . . . 3.8 3.4.4. For Loop . . . . . . . . . . . . . . 3.9 3.4.5. Loop Examples. . . . . . . . . . . . . 3.9 3.5. Switch Syntax . . . . . . . . . . . . . . . 3.10 3.6. RLISP I/O Syntax . . . . . . . . . . . . . . 3.10 3.7. Transcript of a Short Session with RLISP . . . . . . 3.10 CHAPTER 4. DATA TYPES CHAPTER 4. DATA TYPES CHAPTER 4. DATA TYPES 4.1. Data Types and Structures Supported in PSL . . . . . 4.1 4.1.1. Data Types. . . . . . . . . . . . . . 4.1 4.1.2. Other Notational Conventions. . . . . . . . 4.3 4.1.3. Structures. . . . . . . . . . . . . . 4.4 4.2. Predicates Useful with Data Types . . . . . . . . 4.5 4.2.1. Functions for Testing Equality . . . . . . . 4.5 4.2.2. Predicates for Testing the Type of an Object . . 4.7 4.2.3. Boolean Functions . . . . . . . . . . . 4.8 4.3. Converting Data Types . . . . . . . . . . . . 4.9 CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS CHAPTER 5. NUMBERS AND ARITHMETIC FUNCTIONS 5.1. Big Integers . . . . . . . . . . . . . . . 5.1 5.2. Conversion Between Integers and Floats. . . . . . . 5.1 5.3. Arithmetic Functions. . . . . . . . . . . . . 5.2 5.4. Functions for Numeric Comparison. . . . . . . . . 5.5 5.5. Bit Operations. . . . . . . . . . . . . . . 5.7 5.6. Various Mathematical Functions . . . . . . . . . 5.8 CHAPTER 6. IDENTIFIERS CHAPTER 6. IDENTIFIERS CHAPTER 6. IDENTIFIERS 6.1. Introduction . . . . . . . . . . . . . . . 6.1 6.2. Fields of Ids . . . . . . . . . . . . . . . 6.2 6.3. Identifiers and the Id hash table . . . . . . . . 6.2 6.3.1. Identifier Functions . . . . . . . . . . 6.3 6.3.2. Find. . . . . . . . . . . . . . . . 6.4 6.4. Property List Functions. . . . . . . . . . . . 6.4 6.4.1. Functions for Flagging Ids . . . . . . . . 6.6 6.4.2. Direct Access to the Property Cell. . . . . . 6.7 6.5. Value Cell Functions. . . . . . . . . . . . . 6.7 6.6. Package System Functions . . . . . . . . . . . 6.10 6.7. System Global Variables, Switches and Other "Hooks" . . 6.13 6.7.1. Introduction . . . . . . . . . . . . . 6.13 PSL Manual 7 February 1983 page iii Table of Contents 6.7.2. Setting Switches. . . . . . . . . . . . 6.14 6.7.3. Special Global Variables . . . . . . . . . 6.15 6.7.4. Special Put Indicators. . . . . . . . . . 6.15 6.7.5. Special Flag Indicators . . . . . . . . . 6.16 6.7.6. Displaying Information About Globals . . . . . 6.16 CHAPTER 7. LIST STRUCTURE CHAPTER 7. LIST STRUCTURE CHAPTER 7. LIST STRUCTURE 7.1. Introduction to Lists and Pairs . . . . . . . . . 7.1 7.2. Basic Functions on Pairs . . . . . . . . . . . 7.2 7.3. Functions for Manipulating Lists. . . . . . . . . 7.4 7.3.1. Selecting List Elements . . . . . . . . . 7.4 7.3.2. Membership and Length of Lists . . . . . . . 7.6 7.3.3. Constructing, Appending, and Concatenating Lists . 7.6 7.3.4. Lists as Sets. . . . . . . . . . . . . 7.7 7.3.5. Deleting Elements of Lists . . . . . . . . 7.8 7.3.6. List Reversal. . . . . . . . . . . . . 7.9 7.4. Functions for Building and Searching A-Lists. . . . . 7.10 7.5. Substitutions . . . . . . . . . . . . . . . 7.11 CHAPTER 8. STRINGS AND VECTORS CHAPTER 8. STRINGS AND VECTORS CHAPTER 8. STRINGS AND VECTORS 8.1. Vector-Like Objects . . . . . . . . . . . . . 8.1 8.2. Strings . . . . . . . . . . . . . . . . . 8.1 8.3. Vectors . . . . . . . . . . . . . . . . . 8.3 8.4. Word Vectors . . . . . . . . . . . . . . . 8.5 8.5. General X-Vector Operations . . . . . . . . . . 8.5 8.6. Arrays . . . . . . . . . . . . . . . . . 8.7 8.7. Common LISP String Functions . . . . . . . . . . 8.7 CHAPTER 9. FLOW OF CONTROL CHAPTER 9. FLOW OF CONTROL CHAPTER 9. FLOW OF CONTROL 9.1. Introduction . . . . . . . . . . . . . . . 9.1 9.2. Conditionals . . . . . . . . . . . . . . . 9.1 9.2.1. Conds and Ifs. . . . . . . . . . . . . 9.1 9.2.2. The Case Statement . . . . . . . . . . . 9.3 9.3. Sequencing Evaluation . . . . . . . . . . . . 9.4 9.4. Iteration . . . . . . . . . . . . . . . . 9.6 9.4.1. For . . . . . . . . . . . . . . . . 9.8 9.4.2. Mapping Functions . . . . . . . . . . . 9.13 9.4.3. Do . . . . . . . . . . . . . . . . 9.15 9.5. Non-Local Exits . . . . . . . . . . . . . . 9.17 PSL Manual 7 February 1983 page iv Table of Contents CHAPTER 10. FUNCTION DEFINITION AND BINDING CHAPTER 10. FUNCTION DEFINITION AND BINDING CHAPTER 10. FUNCTION DEFINITION AND BINDING 10.1. Function Definition in PSL . . . . . . . . . . 10.1 10.1.1. Notes on Code Pointers . . . . . . . . . 10.1 10.1.2. Functions Useful in Function Definition. . . . 10.2 10.1.3. Function Definition in LISP Syntax . . . . . 10.4 10.1.4. Function Definition in RLISP Syntax . . . . . 10.5 10.1.5. Low Level Function Definition Primitives . . . 10.6 10.1.6. Function Type Predicates. . . . . . . . . 10.7 10.2. Variables and Bindings. . . . . . . . . . . . 10.7 10.2.1. Binding Type Declaration. . . . . . . . . 10.8 10.2.2. Binding Type Predicates . . . . . . . . . 10.9 10.3. User Binding Functions. . . . . . . . . . . . 10.9 10.3.1. Funargs, Closures and Environments . . . . . 10.10 CHAPTER 11. THE INTERPRETER CHAPTER 11. THE INTERPRETER CHAPTER 11. THE INTERPRETER 11.1. Evaluator Functions Eval and Apply. . . . . . . . 11.1 11.2. Support Functions for Eval and Apply . . . . . . . 11.5 11.3. Special Evaluator Functions, Quote, and Function . . . 11.6 11.4. Support Functions for Macro Evaluation . . . . . . 11.7 CHAPTER 12. INPUT AND OUTPUT CHAPTER 12. INPUT AND OUTPUT CHAPTER 12. INPUT AND OUTPUT 12.1. Introduction . . . . . . . . . . . . . . . 12.1 12.2. The Underlying Primitives for Input and Output. . . . 12.1 12.3. Opening, Closing, and Selecting Channels. . . . . . 12.4 12.4. Functions for Printing. . . . . . . . . . . . 12.6 12.5. Functions for Reading . . . . . . . . . . . . 12.13 12.5.1. Reading S-Expression . . . . . . . . . . 12.13 12.5.2. Reading Files into PSL . . . . . . . . . 12.14 12.5.3. Reading Single Characters . . . . . . . . 12.15 12.5.4. Reading Tokens . . . . . . . . . . . . 12.16 12.5.5. Read Macros . . . . . . . . . . . . . 12.24 12.6. Scan Table Utility Functions. . . . . . . . . . 12.25 12.7. I/O to and from Lists and Strings . . . . . . . . 12.25 12.8. Example of Simple I/O in PSL. . . . . . . . . . 12.27 CHAPTER 13. USER INTERFACE CHAPTER 13. USER INTERFACE CHAPTER 13. USER INTERFACE 13.1. Introduction . . . . . . . . . . . . . . . 13.1 13.2. Stopping PSL and Saving a New Executable Core Image . . 13.1 13.3. Init Files. . . . . . . . . . . . . . . . 13.3 13.4. Changing the Default Top Level Function . . . . . . 13.3 13.5. The General Purpose Top Loop Function. . . . . . . 13.4 PSL Manual 7 February 1983 page v Table of Contents 13.6. The HELP Mechanism . . . . . . . . . . . . . 13.7 13.7. The Break Loop . . . . . . . . . . . . . . 13.8 13.8. Terminal Interaction Commands in RLISP . . . . . . 13.8 CHAPTER 14. ERROR HANDLING CHAPTER 14. ERROR HANDLING CHAPTER 14. ERROR HANDLING 14.1. Introduction . . . . . . . . . . . . . . . 14.1 14.2. The Basic Error Functions. . . . . . . . . . . 14.1 14.3. Break Loop. . . . . . . . . . . . . . . . 14.4 14.4. Interrupt Keys . . . . . . . . . . . . . . 14.8 14.5. Details on the Break Loop. . . . . . . . . . . 14.8 14.6. Some Convenient Error Calls . . . . . . . . . . 14.8 14.7. Special Purpose Error Handlers . . . . . . . . . 14.10 CHAPTER 15. DEBUGGING TOOLS CHAPTER 15. DEBUGGING TOOLS CHAPTER 15. DEBUGGING TOOLS 15.1. Introduction . . . . . . . . . . . . . . . 15.1 15.1.1. Brief Summary of Full Debug Package . . . . . 15.1 15.1.2. Mini-Trace Facility . . . . . . . . . . 15.2 15.1.3. Step . . . . . . . . . . . . . . . 15.3 .... 15.1.4. Functions Which Depend on Redefining User Functions..15.4 15.1.5. A Few Known Deficiencies. . . . . . . . . 15.4 15.2. Tracing Function Execution . . . . . . . . . . 15.5 15.2.1. Tracing Functions . . . . . . . . . . . 15.5 15.2.2. Saving Trace Output . . . . . . . . . . 15.6 15.2.3. Making Tracing More Selective . . . . . . . 15.7 15.2.4. Turning Off Tracing . . . . . . . . . . 15.8 15.2.5. Enabling Debug Facilities and Automatic Tracing . 15.9 15.3. A Heavy Handed Backtrace Facility . . . . . . . . 15.10 15.4. Embedded Functions . . . . . . . . . . . . . 15.11 15.5. Counting Function Invocations . . . . . . . . . 15.11 15.6. Stubs . . . . . . . . . . . . . . . . . 15.12 15.7. Functions for Printing Useful Information . . . . . 15.12 15.8. Printing Circular and Shared Structures . . . . . . 15.13 15.9. Internals and Customization . . . . . . . . . . 15.14 15.9.1. User Hooks . . . . . . . . . . . . . 15.14 15.9.2. Functions Used for Printing/Reading . . . . . 15.15 15.10. Example . . . . . . . . . . . . . . . . 15.16 CHAPTER 16. EDITORS CHAPTER 16. EDITORS CHAPTER 16. EDITORS 16.1. A Mini Structure-Editor . . . . . . . . . . . 16.1 16.2. The EMODE Screen Editor . . . . . . . . . . . 16.3 16.2.1. Windows and Buffers in Emode . . . . . . . 16.5 16.3. Introduction to the Full Structure Editor . . . . . 16.5 PSL Manual 7 February 1983 page vi Table of Contents 16.3.1. Starting the Structure Editor . . . . . . . 16.6 16.3.2. Structure Editor Commands . . . . . . . . 16.7 CHAPTER 17. MISCELLANEOUS UTILITIES CHAPTER 17. MISCELLANEOUS UTILITIES CHAPTER 17. MISCELLANEOUS UTILITIES 17.1. Introduction . . . . . . . . . . . . . . . 17.1 17.2. RCREF - Cross Reference Generator for PSL Files . . . 17.1 17.2.1. Restrictions. . . . . . . . . . . . . 17.2 17.2.2. Usage . . . . . . . . . . . . . . . 17.3 17.2.3. Options . . . . . . . . . . . . . . 17.3 17.3. Picture RLISP. . . . . . . . . . . . . . . 17.4 17.4. Tools for Defining Macros. . . . . . . . . . . 17.11 17.4.1. DefMacro . . . . . . . . . . . . . . 17.12 17.4.2. BackQuote. . . . . . . . . . . . . . 17.12 17.4.3. Sharp-Sign Macros . . . . . . . . . . . 17.13 17.4.4. MacroExpand . . . . . . . . . . . . . 17.14 17.4.5. DefLambda. . . . . . . . . . . . . . 17.14 17.5. Simulating a Stack . . . . . . . . . . . . . 17.14 17.6. DefStruct . . . . . . . . . . . . . . . . 17.15 17.6.1. Options . . . . . . . . . . . . . . 17.17 17.6.2. Slot Options. . . . . . . . . . . . . 17.18 17.6.3. A Simple Example . . . . . . . . . . . 17.18 17.7. DefConst . . . . . . . . . . . . . . . . 17.22 17.8. Functions for Sorting . . . . . . . . . . . . 17.22 17.9. Hashing Cons . . . . . . . . . . . . . . . 17.24 17.10. Graph-to-Tree . . . . . . . . . . . . . . 17.25 17.11. Inspect Utility. . . . . . . . . . . . . . 17.26 CHAPTER 18. LOADER AND COMPILER CHAPTER 18. LOADER AND COMPILER CHAPTER 18. LOADER AND COMPILER 18.1. Introduction . . . . . . . . . . . . . . . 18.1 18.2. The Compiler . . . . . . . . . . . . . . . 18.1 18.2.1. Compiling Functions into Memory . . . . . . 18.2 18.2.2. Compiling Functions into FASL Files . . . . . 18.2 18.2.3. Loading FASL Files. . . . . . . . . . . 18.3 18.2.4. Functions to Control the Time When Something is Done 18.4 . 18.2.5. Order of Functions for Compilation . . . . . 18.5 18.2.6. Fluid and Global Declarations . . . . . . . 18.5 18.2.7. Switches Controlling Compiler . . . . . . . 18.6 18.2.8. Differences between Compiled and Interpreted Code 18.7 18.2.9. Compiler Errors. . . . . . . . . . . . 18.8 18.3. The Loader. . . . . . . . . . . . . . . . 18.9 18.3.1. Legal LAP Format and Pseudos . . . . . . . 18.10 18.3.2. Examples of LAP for DEC-20, VAX and Apollo. . . 18.10 18.3.3. Lap Switches. . . . . . . . . . . . . 18.13 18.4. Structure and Customization of the Compiler. . . . . 18.14 18.5. First PASS of Compiler. . . . . . . . . . . . 18.14 PSL Manual 7 February 1983 page vii Table of Contents 18.5.1. Tagging Information . . . . . . . . . . 18.15 18.5.2. Source to Source Transformations . . . . . . 18.15 18.6. Second PASS - Basic Code Generation . . . . . . . 18.15 18.6.1. The Cmacros . . . . . . . . . . . . . 18.15 18.6.2. Classes of Functions . . . . . . . . . . 18.18 18.6.3. Open Functions . . . . . . . . . . . . 18.18 18.7. Third PASS - Optimizations . . . . . . . . . . 18.22 18.8. Some Structural Notes on the Compiler. . . . . . . 18.23 CHAPTER 19. OPERATING SYSTEM INTERFACE CHAPTER 19. OPERATING SYSTEM INTERFACE CHAPTER 19. OPERATING SYSTEM INTERFACE 19.1. Introduction . . . . . . . . . . . . . . . 19.1 19.2. System Dependent Functions . . . . . . . . . . 19.1 19.3. TOPS-20 Interface . . . . . . . . . . . . . 19.2 19.3.1. User Level Interface . . . . . . . . . . 19.2 19.3.2. The Basic Fork Manipulation Functions . . . . 19.4 19.3.3. File Manipulation Functions. . . . . . . . 19.5 19.3.4. Miscellaneous Functions . . . . . . . . . 19.6 19.3.5. Jsys Interface . . . . . . . . . . . . 19.6 19.3.6. Bit, Word and Address Operations for Jsys Calls . 19.8 19.3.7. Examples . . . . . . . . . . . . . . 19.9 19.4. New Vax Specific Interface . . . . . . . . . . 19.10 19.4.1. Setting Your .LOGIN and .CSHRC files. . . . . 19.10 19.4.2. Important PSL executables . . . . . . . . 19.11 19.4.3. Creating the Init Files . . . . . . . . . 19.11 19.4.4. Directories and Symbols . . . . . . . . 19.11 19.4.5. Miscellaneous Unix Interface Functions . . . 19.14 19.4.6. Oload . . . . . . . . . . . . . . 19.14 19.4.7. Calling oloaded functions . . . . . . . . 19.15 19.4.8. OLOAD Internals. . . . . . . . . . . . 19.16 19.4.9. I/O Control functions . . . . . . . . . 19.17 19.5. Apollo System Calls. . . . . . . . . . . . . 19.18 CHAPTER 20. SYSLISP CHAPTER 20. SYSLISP CHAPTER 20. SYSLISP 20.1. Introduction to the SYSLISP level of PSL. . . . . . 20.1 20.2. The Relationship of SYSLISP to RLISP . . . . . . . 20.2 20.2.1. SYSLISP Declarations . . . . . . . . . . 20.2 20.2.2. SYSLISP Mode Analysis. . . . . . . . . . 20.3 20.2.3. Defining Special Functions for Mode Analysis . . 20.3 20.2.4. Modified FOR Loop . . . . . . . . . . . 20.4 20.2.5. Char and IDLOC Macros. . . . . . . . . . 20.4 20.2.6. The Case Statement. . . . . . . . . . . 20.5 20.2.7. Memory Access and Address Operations. . . . . 20.7 20.2.8. Bit-Field Operation . . . . . . . . . . 20.7 20.3. Using SYSLISP. . . . . . . . . . . . . . . 20.9 20.3.1. To Compile SYSLISP Code . . . . . . . . . 20.9 20.4. SYSLISP Functions . . . . . . . . . . . . . 20.10 PSL Manual 7 February 1983 page viii Table of Contents 20.4.1. W-Arrays . . . . . . . . . . . . . . 20.11 20.5. Remaining SYSLISP Issues . . . . . . . . . . . 20.11 20.5.1. Stand Alone SYSLISP Programs . . . . . . . 20.11 20.5.2. Need for Two Stacks . . . . . . . . . . 20.12 20.5.3. New Mode System. . . . . . . . . . . . 20.12 20.5.4. Extend CREF for SYSLISP . . . . . . . . . 20.12 CHAPTER 21. IMPLEMENTATION CHAPTER 21. IMPLEMENTATION CHAPTER 21. IMPLEMENTATION 21.1. Overview of the Implementation . . . . . . . . . 21.1 21.2. Files of Interest . . . . . . . . . . . . . 21.1 21.3. Building PSL on the DEC-20 . . . . . . . . . . 21.2 21.4. Building the LAP to Assembly Translator . . . . . . 21.5 21.5. The Garbage Collectors and Allocators. . . . . . . 21.5 21.5.1. Compacting Garbage Collector on DEC-20 . . . . 21.5 21.5.2. Two-Space Stop and Copy Collector on VAX . . . 21.6 21.6. The HEAPs . . . . . . . . . . . . . . . . 21.6 21.7. Allocation Functions . . . . . . . . . . . . 21.8 CHAPTER 22. PARSER TOOLS CHAPTER 22. PARSER TOOLS CHAPTER 22. PARSER TOOLS 22.1. Introduction . . . . . . . . . . . . . . . 22.1 22.2. The Table Driven Parser . . . . . . . . . . . 22.2 22.2.1. Flow Diagram for the Parser. . . . . . . . 22.2 22.2.2. Associating the Infix Operator with a Function . 22.4 22.2.3. Precedences . . . . . . . . . . . . . 22.5 22.2.4. Special Cases of 0 <-0 and 0 0. . . . . . . 22.5 22.2.5. Parenthesized Expressions . . . . . . . . 22.5 22.2.6. Binary Operators in General. . . . . . . . 22.6 22.2.7. Assigning Precedences to Key Words . . . . . 22.7 22.2.8. Error Handling . . . . . . . . . . . . 22.7 22.2.9. The Parser Program for the RLISP Language . . . 22.7 22.2.10. Defining Operators . . . . . . . . . . 22.8 22.3. The MINI Translator Writing System. . . . . . . . 22.10 22.3.1. A Brief Guide to MINI. . . . . . . . . . 22.10 22.3.2. Pattern Matching Rules . . . . . . . . . 22.12 22.3.3. A Small Example. . . . . . . . . . . . 22.12 22.3.4. Loading Mini. . . . . . . . . . . . . 22.12 22.3.5. Running Mini. . . . . . . . . . . . . 22.13 22.3.6. MINI Error messages and Error Recovery . . . . 22.13 22.3.7. MINI Self-Definition . . . . . . . . . . 22.13 22.3.8. The Construction of MINI. . . . . . . . . 22.15 22.3.9. History of MINI Development. . . . . . . . 22.16 22.4. BNF Description of RLISP Using MINI . . . . . . . 22.17 PSL Manual 7 February 1983 page ix Table of Contents CHAPTER 23. BIBLIOGRAPHY CHAPTER 23. BIBLIOGRAPHY CHAPTER 23. BIBLIOGRAPHY CHAPTER 24. INDEX OF CONCEPTS CHAPTER 24. INDEX OF CONCEPTS CHAPTER 24. INDEX OF CONCEPTS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 25. INDEX OF FUNCTIONS CHAPTER 26. INDEX OF GLOBALS AND SWITCHES CHAPTER 26. INDEX OF GLOBALS AND SWITCHES CHAPTER 26. INDEX OF GLOBALS AND SWITCHES |
Added psl-1983/lpt/01-introduction.lpt version [6b5717432d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Introduction section 1.0 page 1.1 CHAPTER 1 CHAPTER 1 CHAPTER 1 INTRODUCTION INTRODUCTION INTRODUCTION 1.1. Opening Remarks . . . . . . . . . . . . . . 1.1 1.2. Scope of the Manual . . . . . . . . . . . . . 1.2 1.2.1. Typographic Conventions within the Manual . . . 1.2 1.2.2. The Organization of the Manual . . . . . . . 1.3 1.1. Opening Remarks 1.1. Opening Remarks 1.1. Opening Remarks 1 This document describes PSL (PORTABLE STANDARD LISP ), a portable, "modern" LISP developed at the University of Utah for a variety of machines. PSL is upward-compatible with STANDARD LISP [Marti 79]. In most cases, STANDARD LISP did not commit itself to specific implementation details (since it was to be compatible with a portion of "most" LISPs). PSL is more specific and provides many more functions than described in that report. The goals of PSL include: - Providing implementation tools for LISP that can be used to ____ implement a variety of LISP-like systems, including mini-lisps embedded in other language systems (such as existing PASCAL or ADA applications). - Effectively supporting the REDUCE algebra system on a number of machines, and providing algebra modules extracted from (or modeled upon) REDUCE to be included in applications such as CAI and CAGD. - Providing a uniform, modern LISP programming environment on all of the machines that we use (DEC-20, VAX, and 68000 based personal machines)--of the power of FRANZ LISP, UCI LISP or MACLISP. - Studying the utility of a LISP-based systems language for other applications (such as CAGD or VLSI design) in which SYSLISP code provides efficiency comparable to that of C or BCPL, yet enjoys _______________ 1 "LSP" backwards! Introduction 7 February 1983 PSL Manual page 1.2 section 1.1 the interactive program development and debugging environment of LISP. 1.2. Scope of the Manual 1.2. Scope of the Manual 1.2. Scope of the Manual This manual is intended to describe the syntax, semantics, and implementation of PSL. While we have attempted to make it comprehensive, it is not intended for use as a primer. Some prior exposure to LISP will prove very helpful. A selection of LISP primers is listed in the bibliography in Chapter 23; see for example [Allen 79, Charniak 80, Weissman 67, Winston 81]. 1.2.1. Typographic Conventions within the Manual 1.2.1. Typographic Conventions within the Manual 1.2.1. Typographic Conventions within the Manual A large proportion of this manual is devoted to descriptions of the functions that make up PSL. Each function is provided with a prototypical header line. Each argument is given a name and followed by its allowed type. If an argument type is not commonly used, it may be a specific set PutD PutD enclosed in brackets {...}. For example, this header shows that PutD (which defines other functions) takes three arguments: ____ ____ ____ PutD expr PutD _____ __ ____ _____ ____ ______ ____ _______ _____ __ expr (PutD FNAME:id TYPE:ftype BODY:{lambda, code-pointer}): FNAME:id expr _____ __ 1. FNAME, which is an id (identifier). ____ 2. TYPE, which is the "function type" of the function being defined. ____ ______ ____ _______ 3. BODY, which is a lambda expression or a code-pointer. _____ and returns FNAME, the name of the function being defined. Some functions are compiled open; these have a note saying "open-compiled" next to the function type. Some functions accept an arbitrary number of arguments. The header for these functions shows a single argument enclosed in square brackets-- indicating that zero or more occurrences of that argument are allowed. For example: And And _ ____ _____ _______ (And [U:form]): extra-boolean And And And is a function which accepts zero or more arguments each of which may ____ be any form. In some cases, LISP or RLISP code is given in the function documentation as the function's definition. As far as possible, the code is extracted from the the current PSL sources (perhaps converted from one syntax to the other); however, this code is not always necessarily actually used in PSL, and may be given only to clarify the semantics of the function. Please _____ check carefully if you depend on the exact definition. PSL Manual 7 February 1983 Introduction section 1.2 page 1.3 Some features of PSL are anticipated but not yet fully implemented. When these are documented in this manual they are indicated with the words: ___ ___________ ___ ___ ___________ ___ ___ ___________ ___ [not implemented yet] [not implemented yet] [not implemented yet]. 1.2.2. The Organization of the Manual 1.2.2. The Organization of the Manual 1.2.2. The Organization of the Manual This manual is arranged in separate chapters, which are meant to be self-contained units. Each begins with a small table of contents serving as a summary of constructs and as an aid in skimming. Here is a brief overview of the following chapters: Chapter 2 is particularly useful for those using PSL for the first time. It begins with directions for starting PSL and getting help. It also briefly discusses the handling of errors; some of the consequences of PSL being both a compiled and an interpreted language; function types; switches and globals. PSL treats the parameters for various function types rather differently from a number of other dialects, and the serious user should definitely become familiar with this information. While most LISP implementations use only a fully parenthesized syntax, PSL gives the user the option of using an ALGOL-like (or PASCAL-like) syntax (RLISP), which many users prefer. Chapter 3 describes the syntax of RLISP. Chapter 4 describes the data types used in PSL. It includes functions useful for testing equality and for changing data types, and predicates useful with data types. The next seven chapters describe in detail the basic functions provided by PSL. Chapters 5, 6, 7, and 8 describe functions for manipulating the basic ______ __ ____ ______ ______ data structures of LISP: numbers, ids, lists, and strings and vectors. As _______ __________ ____ virtually every LISP program uses integers, identifiers, and lists extensively, these three chapters (5, 6 and 7) should be included in an ______ ______ overview. As vectors and strings are used less extensively, Chapter 8 may be skipped on a first reading. Chapter 9 and, to some extent, Chapter 4 describe the basic functions used to drive a computation. The reader wanting an overview of PSL should certainly read these two. Chapter 10 describes functions useful in function definition and the idea of variable binding. The novice LISP user should definitely read this information before proceeding to the rest of the manual. Also described here is a proposed scheme for context-switching in the form of the funarg and closures. Chapter 11 describes functions associated with the interpreter. It Eval Apply Eval Apply includes functions having to do with evaluation (Eval and Apply.) Introduction 7 February 1983 PSL Manual page 1.4 section 1.2 Chapter 12 describes the I/O facilities. Most LISP programs do not require sophisticated I/O, so this may be skimmed on a first reading. The section dealing with input deals extensively with customizing the scanner and reader, which is only of interest to the sophisticated user. Chapter 13 presents information about the user interface for PSL. It includes some generally useful information on running the system. Chapter 14 discusses error handling. Much of the information is of interest primarily to the sophisticated user. However, LISP provides a convenient interactive facility for correcting certain errors which may be of interest to all, so a first reading should include parts of this chapter. Chapter 15 discusses some tools for debugging and statistics gathering based on the concept of embedding function definitions. Chapter 16 describes the structure editor, which permits the user to construct and modify list structure, including the bodies of interpreted functions, and erroneous expressions within the BREAK loop. It also describes EMODE, an EMACS-like screen editor. Chapter 17 briefly describes modules of useful tools. This includes the PSL cross-reference generator, and various tools for defining macros. The rest of the manual may be skipped on first reading. Chapter 18 describes functions associated with the compiler. Chapter 19 describes some functions for communicating with the TOPS-20 and UNIX operating systems. Chapter 20 describes SYSLISP, a language incorporating features from both BCPL and LISP and which is used as an implementation language for PSL. Chapter 21 presents details of the portable implementation which may be of interest to sophisticated users, including a description of the garbage collector. Chapter 22 describes the extensible parser. Section 22.4 provides BNF descriptions of the input accepted by the token scanner, standard reader, and syntactic (RLISP) reader. Chapter 23 contains the bibliography. Chapter 24 is an alphabetical index of concepts. Chapter 25 is an alphabetical index of all functions defined in the manual. Chapter 26 contains an alphabetical index of all global variables and switches defined in the manual. |
Added psl-1983/lpt/02-getstart.lpt version [03db65fd31].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Getting Started section 2.0 page 2.1 CHAPTER 2 CHAPTER 2 CHAPTER 2 GETTING STARTED WITH PSL GETTING STARTED WITH PSL GETTING STARTED WITH PSL 2.1. Purpose of This Chapter. . . . . . . . . . . . 2.1 2.2. Defining Logical Device Names for PSL . . . . . . . 2.1 2.2.1. DEC-20 . . . . . . . . . . . . . . . 2.2 2.2.2. VAX . . . . . . . . . . . . . . . . 2.2 2.3. Starting PSL . . . . . . . . . . . . . . . 2.3 2.3.1. DEC-20 . . . . . . . . . . . . . . . 2.3 2.3.2. VAX . . . . . . . . . . . . . . . . 2.3 2.4. Running the PSL System . . . . . . . . . . . . 2.4 2.4.1. Loading Optional Modules . . . . . . . . . 2.4 2.4.2. Notes on Running PSL and RLISP . . . . . . . 2.4 2.4.3. Transcript of a Short Session with PSL . . . . 2.5 2.5. Error and Warning Messages. . . . . . . . . . . 2.8 2.6. Compilation Versus Interpretation . . . . . . . . 2.8 2.7. Function Types. . . . . . . . . . . . . . . 2.9 2.8. Switches and Globals. . . . . . . . . . . . . 2.10 2.9. Reporting Errors and Misfeatures. . . . . . . . . 2.10 2.1. Purpose of This Chapter 2.1. Purpose of This Chapter 2.1. Purpose of This Chapter This chapter is for beginning users of PSL on the DEC-20 and the VAX 750 and 780 at Utah. It also is meant to be a guide to those familiar with LISP, and particularly STANDARD LISP, who would like to use PSL as they read the manual. It begins with descriptions of how to set up various logical device definitions required by PSL and how to run PSL. A number of miscellaneous hints and reminders are given in the remainder of the chapter. 2.2. Defining Logical Device Names for PSL 2.2. Defining Logical Device Names for PSL 2.2. Defining Logical Device Names for PSL When PSL is installed on your system, the person doing the installation has the option of using a number of different directory structures and names, depending on local conventions and available space. There are also options to select a small system (without all source-code online) or a full system. Also, as each release of PSL is prepared, we may find it convenient to change the names and number of sub-directories. In order to minimize the inconvenience, an attempt has been made to refer to such directories through some form of logical name ("logical device name" on DEC-20, shell-variable or link on VAX-UNIX, etc.). In some cases these can be used as if they were directory names (DEC-20), and in some cases not (VAX). These definitions are edited at installation time to reflect local Getting Started 7 February 1983 PSL Manual page 2.2 section 2.2 usage, and stored in a file whose name is something like "logical-names.xxx". This file will be placed on an appropriate directory (often <PSL> on the DEC-20, ~psl on the VAX, etc.). A message should be sent out by your installer to indicate where the file is, and its name. It is suggested that a use of this file be placed in your LOGIN.CMD , .cshrc or equivalent file. 2.2.1. DEC-20 2.2.1. DEC-20 2.2.1. DEC-20 It is absolutely essential that TAKE <PSL>LOGICAL-NAMES.CMD be inserted in your LOGIN.CMD file, or executed at EXEC level before using PSL. PSL is written to rely on these logical device definitions in place of "hard-coded" directory names. PSL also uses TOPS-20 search paths, so that for example, "PH:" is defined as the directory (or search list) on which PSL looks for help files, "PL:" is the directory (or search list) on which Lap Fasl Lap Fasl PSL looks for Lap and Fasl files of the form "xxxx.b", etc. The logical name "PSL:" is defined to be the directory on which the PSL executables reside. Thus "PSL:PSL.EXE" should start PSL executing. There should usually be a PSL:BARE-PSL.EXE, PSL:PSL.EXE and PSL:RLISP.EXE. BARE-PSL is the minimum system that is constructed during the PSL build sequence. PSL and RLISP usually contain additional modules selected by the installer, felt to be most commonly used by your community. 2.2.2. VAX 2.2.2. VAX 2.2.2. VAX In the current version of UNIX (4.1) there is no equivalent of logical device definitions that can be used to access files on other directories from within PSL or many UNIX utilities. We have defined a set of shell variables ($ variables) that may be used outside of an executing PSL to refer to the appropriate directories, and a series of PSL global variables for use inside PSL that contain the equivalent of search paths. In a future release of PSL for the VAX, we may be able to look up such shell or environment variables during the attempt to OPEN a file. These variables are defined in the file "psl-names", usually on the directory "~psl" (actually /u/local/psl at UTAH). Insert a "source ~psl/psl-names" or equivalent in your .cshrc file. Variables such as "$psl", "$pl", and "$pu" (on which many utility sources are stored) are defined. There should usually be a "$psl/bare-psl", "$psl/psl" and "$psl/rlisp". Bare-psl is the minimum system that is constructed during the PSL build sequence. PSL and RLISP usually contain additional modules selected by the installer, felt to be most commonly used by your community. PSL Manual 7 February 1983 Getting Started section 2.3 page 2.3 2.3. Starting PSL 2.3. Starting PSL 2.3. Starting PSL 2.3.1. DEC-20 2.3.1. DEC-20 2.3.1. DEC-20 After defining the device names, type either PSL:RLISP or PSL:PSL to the at-sign prompt, @. A welcome message indicates the nature of the system running, usually with a date and version number. This information may be useful in describing problems. [Messages concerning bugs or misfeatures should be directed to PSL-BUGS@UTAH-20; see Section 2.9.] BARE-PSL.EXE is a "bare" PSL using LISP (i.e. parenthesis) syntax. This is a small core-image and is ideal for simple LISP execution. It also Fasl Fasl includes a resident Fasl, so additional modules can be loaded. In particular, the compiler is not normally part of PSL.EXE. RLISP.EXE is PSL with additional modules loaded, corresponding to the most common system run at Utah. It contains the compiler and an RLISP parser. For more information about RLISP see Chapter 3. It is assumed by PSL and RLISP that file names be of the form "*.sl" or Fasl Fasl "*.lsp" for LISP files, "*.red" for RLISP files, "*.b" for Fasl files, and Lap Lap "*.lap" for Lap files. 2.3.2. VAX 2.3.2. VAX 2.3.2. VAX The executable files are $psl/psl and $psl/rlisp. Loadable modules are on $pl/*.b or $pl/*.lap. Help files are on $ph/*.hlp. $psl/rlisp has the RLISP parser and compiler. Additional modules can be Load Error Load Error loaded from $pl using the Load function. <Ctrl-C> causes a call to Error, and may be used to stop a runaway computation. <Ctrl-Z> or the function Quit Quit Quit cause the process to be stopped, and control returned to the shell; the process may be continued. A sequence of <Ctrl-D>'s (EOF) causes the process to be terminated. This is to allow the use of I/O redirection from the shell. [??? Add Cntrl-B for BREAK loop call ???] [??? Add Cntrl-B for BREAK loop call ???] [??? Add Cntrl-B for BREAK loop call ???] Unix 4.1 and 4.1a allow only 14 characters for file names, and case is significant. The use of ".r" instead of ".red" is recommended as the extension for RLISP files to save on meaningful characters; other extensions are as on the DEC-20. Getting Started 7 February 1983 PSL Manual page 2.4 section 2.4 2.4. Running the PSL System 2.4. Running the PSL System 2.4. Running the PSL System The following sub-sections collect a few miscellaneous notes that are further expanded on elsewhere. They are provided here simply to get you started. 2.4.1. Loading Optional Modules 2.4.1. Loading Optional Modules 2.4.1. Loading Optional Modules Certain modules are not present in the "kernel" or "bare-psl" system, but can be loaded as options. Some of these optional modules will "auto-load" when first referenced; others may be explicitly loaded by the user, or included by the installer when building the "PSL" and "RLISP" core images. Optional modules can be loaded by executing LOAD modulename; % in RLISP syntax or (LOAD modulename) % in LISP syntax. The global variable OPTIONS!* contains a list of modules currently loaded; it does not mention those in the "bare-psl" kernel. Do not reset this variable; it is used by LOAD to avoid loading already present modules. RELOAD RELOAD [See RELOAD in Chapter 18]. 2.4.2. Notes on Running PSL and RLISP 2.4.2. Notes on Running PSL and RLISP 2.4.2. Notes on Running PSL and RLISP Help Help Help Help a. Use Help(); [(Help) in LISP] for general help or an indication Help Help Help Help of what help is available; use Help (a, b, c); [(Help a b c) in LISP] for information on topics a, b, and c. This call prints Help Help files from the PH: (i.e. <PSL.HELP>) directory. Try Help x; Help Help [(Help x) in LISP] on: ? Exec Mini Step Br Find MiniEditor Strings Break Switches MiniTrace TopLoop Bug For Package Tr Debug Globals PRLISP Trace Defstruct GSort PSL UnBr Edit Help RCREF UnTr EditF JSYS RLISP Useful Editor Load ShowSwitches ZFiles Emode Manual Slate ZPEdit EWindow [??? Help() does not work in RLISP ???] [??? Help() does not work in RLISP ???] [??? Help() does not work in RLISP ???] b. File I/O needs string-quotes (") around file names. File names may use full TOPS-20 or UNIX conventions, including directories, PSL Manual 7 February 1983 Getting Started section 2.4 page 2.5 sub-directories, etc. IN IN Input in RLISP mode is done using the 'IN "File-Name";' command. Dskin Dskin Use (Dskin "File-Name") for input from LISP mode. For information on similar I/O functions see Chapter 12. Quit Quit Quit Quit c. Use Quit; [(Quit) in LISP] or <Ctrl-C> on the DEC-20 (<Ctrl-Z> on the VAX) to exit. <Ctrl-C> (<Ctrl-Z> on the VAX) is useful for stopping run-away computations. On the DEC-20, typing START or CONTINUE to the @ prompt from the EXEC usually restarts in a reasonable way. 2.4.3. Transcript of a Short Session with PSL 2.4.3. Transcript of a Short Session with PSL 2.4.3. Transcript of a Short Session with PSL The following is a transcript of running PSL on the DEC-20. Getting Started 7 February 1983 PSL Manual page 2.6 section 2.4 @psl:psl PSL 3.1, 11-Oct-82 1 Lisp> % Notice the numbered prompt. 1 Lisp> % Comments begin with "%" and do not change the prompt 1 Lisp> % number. 1 Lisp> (Setq Z '(1 2 3)) % Make an assignment for Z. (1 2 3) 2 Lisp> (Cdr Z) % Notice the change in prompt number. (2 3) 3 Lisp> (De Count (L) % Count counts the number or elements 3 Lisp> (Cond ((Null L) 0) % in a list L. 3 Lisp> (T (Add1 (Count (Cdr L)))))) COUNT 4 Lisp> (Count Z) % Call Count on Z. 3 5 Lisp> (Tr Count) % Trace the recursive execution of "Count". (COUNT) 6 Lisp> % A call on "Count" now shows the value of 6 Lisp> % "Count" and of its arguments each time 6 Lisp> (Count Z) % it is called. COUNT being entered L: (1 2 3) COUNT (level 2) being entered L: (2 3) COUNT (level 3) being entered L: (3) COUNT (level 4) being entered L: NIL COUNT (level 4) = 0 COUNT (level 3) = 1 COUNT (level 2) = 2 COUNT = 3 3 7 Lisp> (De Factorial (X) 7 Lisp> (Cond ((Eq 1) 7 Lisp> (T (Times X (Factorial (Sub1 X)))))) FACTORIAL 8 Lisp> (Tr Factorial) (FACTORIAL) 9 Lisp> (Factorial 4) % Trace execution of "Factorial". FACTORIAL being entered X: 4 FACTORIAL (level 2) being entered X: 3 FACTORIAL (level 3) being entered X: 2 % Notice values being returned. FACTORIAL (level 4) being entered X: 1 FACTORIAL (level 4) = 1 FACTORIAL (level 3) = 2 FACTORIAL (level 2) = 6 PSL Manual 7 February 1983 Getting Started section 2.4 page 2.7 FACTORIAL = 24 24 10 Lisp> (Untr Count Factorial) NIL 11 Lisp> (Count 'A) % This generates an error causing the break % loop to be entered. ***** An attempt was made to do CDR on `A', which is not a pair Break loop 12 Lisp break>> ? BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, except that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet A Abort to top level, i.e. restart PSL C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. NIL 13 Lisp break>> % Get a Trace-Back of the 13 Lisp break>> I % interpreted functions. Backtrace, including interpreter functions, from top of stack: LIST2 CDR COUNT ADD1 COND COUNT LIST2 NIL 14 Lisp break>> Q % To exit the Break Loop. 15 Lisp> % Load in a file, showing its execution. 15 Lisp> % The file contains the following: 15 Lisp> % (Setq X (Cons 'A (Cons 'B Nil))) 15 Lisp> % (Count X) 15 Lisp> % (Reverse X) 15 Lisp> (Dskin "small-file.sl") (A B) 2 (B A) NIL 16 Lisp> (Quit) @continue "Continued" 17 Lisp> ^C @start 18 Lisp> (Quit) Getting Started 7 February 1983 PSL Manual page 2.8 section 2.5 2.5. Error and Warning Messages 2.5. Error and Warning Messages 2.5. Error and Warning Messages Many functions detect and signal appropriate errors (see Chapter 14 for details); in many cases, an error message is printed. The error conditions are given as part of a function's definition in the manual. An error message is preceded by five stars (*); a warning message is preceded by three. For example, most primitive functions check the type of their arguments and display an error message if an argument is incorrect. The type mismatch error mentions the function in which the error was detected, gives the expected type, and prints the actual value passed. Sometimes one sees a prompt of the form: Do you really want to redefine the system function `FOO'? This means you have tried to define a function with the same name as a function used by the PSL system. A Y, N, YES, NO, or B response is required. B starts a break loop. After quitting the break loop, answer Y, YesP YesP N, Yes, or No to the query. See the definition of YesP in Chapter 13. An affirmative response is extremely dangerous and should be given only if you are a system expert. Usually this means that your function must be given a different name. A common warning message is *** Function "FOO" has been redefined If this occurs without the query above, you are redefining your own function. This happens normally if you read a file, edit it, and read it in again. ________ The switch !*USERMODE controls whether redefinition of functions is "dangerous". When NIL, no query is generated. User functions entered when ________ !*USERMODE is on are flagged with the 'USER indicator, used by this ________ mechanism. The switch !*REDEFMSG, described in section 10.1.2, can be set to suppress these warning messages. There is also a property 'LOSE that will prevent redefinition; the new definition will be ignored, and a warning given. 2.6. Compilation Versus Interpretation 2.6. Compilation Versus Interpretation 2.6. Compilation Versus Interpretation PSL uses both compiled and interpreted code. If compiled, a function usually executes faster and is smaller. However, there are some semantic differences of which the user should be aware. For example, some recursive functions are made non-recursive, and certain functions are open-compiled. A call to an open-compiled function is replaced, on compilation, by a series of online instructions instead of just being a reference to another function. Functions compiled open may not do as much type checking. The user may have to supply some declarations to control this behavior. PSL Manual 7 February 1983 Getting Started section 2.6 page 2.9 The exact semantic differences between compiled and interpreted functions are more fully discussed in Chapter 18 and in the Portable LISP Compiler paper [Griss 81]. [??? We intend to consider the modification of the LISP semantics so as [??? We intend to consider the modification of the LISP semantics so as [??? We intend to consider the modification of the LISP semantics so as to ensure that these differences are minimized. If a conflict occurs, to ensure that these differences are minimized. If a conflict occurs, to ensure that these differences are minimized. If a conflict occurs, we will restrict the interpreter, rather than extending (and slowing we will restrict the interpreter, rather than extending (and slowing we will restrict the interpreter, rather than extending (and slowing down) the capabilities of the compiled code. ???] down) the capabilities of the compiled code. ???] down) the capabilities of the compiled code. ???] We indicate on the function definition line if it is typically compiled OPEN; this information helps in debugging code that uses these functions. These functions do not appear in backtraces and cannot be redefined, traced or broken in compiled code. [??? Should we make open-compiled functions totally un-redefinable [??? Should we make open-compiled functions totally un-redefinable [??? Should we make open-compiled functions totally un-redefinable without special action, even for interpreted code. Consistency! E.g. without special action, even for interpreted code. Consistency! E.g. without special action, even for interpreted code. Consistency! E.g. flag 'COND LOSE. ???] flag 'COND LOSE. ???] flag 'COND LOSE. ???] 2.7. Function Types 2.7. Function Types 2.7. Function Types Eval NoEval Eval NoEval Eval-type functions are those called with evaluated arguments. NoEval Spread Spread functions are called with unevaluated arguments. Spread-type functions have their arguments passed in a one-to-one correspondence with their NoSpread NoSpread formal parameters. NoSpread functions receive their arguments as a single ____ list. There are four function types implemented in PSL: ____ ____ ____ expr Eval Spread expr Eval Spread expr An Eval, Spread function, with a maximum of 15 arguments. In referring to the formal parameters we mean their values. Each function of this type should always be called with the expected number of parameters, as indicated in the function definition. Future versions of PSL will check this consistency. _____ _____ _____ fexpr NoEval NoSpread fexpr NoEval NoSpread fexpr A NoEval, NoSpread function. There is no limit on the number of arguments. In referring to the formal parameters we mean the unevaluated arguments, collected as a single List, and passed as a single formal parameter to the function body. _____ _____ _____ nexpr Eval NoSpread nexpr Eval NoSpread nexpr An Eval, NoSpread function. Each call on this kind of function may present a different number of arguments, which are evaluated, collected into a list, and passed in to the function body as a single formal parameter. _____ _____ _____ _____ _____ _____ macro macro macro macro macro The macro is a function which creates a new S-expression for subsequent evaluation or compilation. There is no limit to the _____ _____ _____ macro macro number of arguments a macro may have. The descriptions of the Eval Expand Eval Expand Eval and Expand functions in Chapter 11 provide precise details. Getting Started 7 February 1983 PSL Manual page 2.10 section 2.8 2.8. Switches and Globals 2.8. Switches and Globals 2.8. Switches and Globals Generally, switch names begin with !* and global names end with !*, where "!" is an escape character. One can set a switch !*xxx to T by using On xxx; in RLISP [(on xxx) in LISP]; one can set it to NIL by using Off xxx; in RLISP [(off xxx) in LISP]. For example) !*ECHO, !*PVAL and !*PECHO are switches that control Input Echo, Value Echo and Parse Echo. These switches are described more fully in Chapters 12 and 13. For more information, type "HELP SWITCHES;" or "HELP GLOBALS;", or see Section 6.7. 2.9. Reporting Errors and Misfeatures 2.9. Reporting Errors and Misfeatures 2.9. Reporting Errors and Misfeatures Send bug MAIL to PSL-BUGS@UTAH-20. The message will be distributed to a list of users concerned with bugs and maintenance, and a copy will be kept in <PSL>BUGS-MISSFEATURES.TXT at UTAH-20. Bug Bug _________ ___ __ ____ ____ (Bug ): undefined DEC-20 only, expr Bug Bug The function Bug(); can be called from within PSL:RLISP. This starts MAIL (actually MM) in a lower fork, with the To: line set up to Griss. Simply type the subject of the complaint, and then the message. After typing message about a bug or a misfeature end finally with a <Ctrl-Z>. <Ctrl-N> aborts the message. [??? needs switches ???] [??? needs switches ???] [??? needs switches ???] |
Added psl-1983/lpt/03-rlisp.lpt version [4788bbfe3c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 RLISP section 3.0 page 3.1 CHAPTER 3 CHAPTER 3 CHAPTER 3 RLISP SYNTAX RLISP SYNTAX RLISP SYNTAX 3.1. Motivation for RLISP Interface to PSL . . . . . . . 3.1 3.2. An Introduction to RLISP . . . . . . . . . . . 3.2 3.2.1. LISP equivalents of some RLISP constructs . . . 3.2 3.3. An Overview of RLISP and LISP Syntax Correspondence . . 3.3 3.3.1. Function Call Syntax in RLISP and LISP . . . . 3.4 ... 3.3.2. RLISP Infix Operators and Associated LISP Functions....3.4 3.3.3. Differences between Parse and Read. . . . . . 3.6 3.3.4. Procedure Definition . . . . . . . . . . 3.6 3.3.5. Compound Statement Grouping . . . . . . . . 3.7 3.3.6. Blocks with Local Variables . . . . . . . . 3.7 3.3.7. The If Then Else Statement . . . . . . . . 3.8 3.4. Looping Statements . . . . . . . . . . . . . 3.8 3.4.1. While Loop. . . . . . . . . . . . . . 3.8 3.4.2. Repeat Loop . . . . . . . . . . . . . 3.8 3.4.3. For Each Loop. . . . . . . . . . . . . 3.9 3.4.4. For Loop . . . . . . . . . . . . . . 3.9 3.4.5. Loop Examples. . . . . . . . . . . . . 3.9 3.5. Switch Syntax . . . . . . . . . . . . . . . 3.10 3.6. RLISP I/O Syntax . . . . . . . . . . . . . . 3.10 3.7. Transcript of a Short Session with RLISP . . . . . . 3.11 3.1. Motivation for RLISP Interface to PSL 3.1. Motivation for RLISP Interface to PSL 3.1. Motivation for RLISP Interface to PSL Most of the PSL users at Utah prefer to write LISP code using an ALGOL-like (or PASCAL-like) preprocessor language, RLISP, because of its similarity to the heavily used PASCAL and C languages. RLISP was developed as part of the REDUCE Computer Algebra project [Hearn 73], and is the ALGOL-like user language as well as the implementation language. RLISP provides a number of syntactic niceties which we find convenient, such as If-Then-Else If-Then-Else vector subscripts, case statement, If-Then-Else, etc. We usually do not distinguish LISP from RLISP, and can mechanically translate from one to the other in either direction using a parser and pretty-printer written in PSL. That is, RLISP is a convenience, but it is not necessary to use RLISP syntax rather than LISP. A complete BNF-like definition of RLISP and its translation to LISP using the MINI system is given in Section 22.4. Also discussed in Chapter 22 is an extensible table driven parser which is used for the current RLISP parser. There we give explicit tables which define RLISP syntax. In this chapter we provide enough of an introduction to make the examples and sources readable, and to assist the user in writing RLISP code. RLISP 7 February 1983 PSL Manual page 3.2 section 3.2 3.2. An Introduction to RLISP 3.2. An Introduction to RLISP 3.2. An Introduction to RLISP An RLISP program consists of a set of functional commands which are evaluated sequentially. RLISP expressions are built up from declarations, statements and expressions. Such entities are composed of sequences of numbers, variables, operators, strings, reserved words and delimiters (such as commas and parentheses), which in turn are sequences of characters. The evaluation proceeds by a parser first converting the ALGOL-like RLISP source language into LISP S-expressions, and evaluating and printing the Parse-Eval-Print Parse-Eval-Print result. The basic cycle is thus Parse-Eval-Print, although the specific functions, and additional processing, are under the control of a variety of switches, described in appropriate sections. 3.2.1. LISP equivalents of some RLISP constructs 3.2.1. LISP equivalents of some RLISP constructs 3.2.1. LISP equivalents of some RLISP constructs The following gives a few examples of RLISP statements and functions and their corresponding LISP forms. To see the exact LISP equivalent of RLISP code, set the switch !*PECHO to T [On PECHO; in RLISP, (On PECHO) in LISP]. Assignment statements in RLISP and LISP: X := 1; (setq x 1) A procedure to take a factorial, in RLISP: LISP PROCEDURE FACTORIAL N; IF N <= 1 THEN 1 ELSE N * FACTORIAL (N-1); in LISP: (de factorial (n) (cond ((leq n 1) 1) (T (times n (factorial (difference n 1)))))) Take the Factorial of 5 in RLISP and in LISP: FACTORIAL 5; (factorial 5) Build a list X as a series of "Cons"es in RLISP: X := 'A . 'B . 'C . NIL; in LISP: (setq x (cons 'a (cons 'b (cons 'c nil)))) PSL Manual 7 February 1983 RLISP section 3.3 page 3.3 3.3. An Overview of RLISP and LISP Syntax Correspondence 3.3. An Overview of RLISP and LISP Syntax Correspondence 3.3. An Overview of RLISP and LISP Syntax Correspondence The RLISP parser converts RLISP expressions, typed in at the terminal or read from a file, into directly executable LISP expressions. For convenience in the following examples, the "==>" arrow is used to indicate the LISP actually produced from the input RLISP. To see the LISP equivalents of RLISP code on the machine, set the switch !*PECHO to T [On Pecho; in RLISP, (On Pecho) in LISP]. As far as possible, upper and lower cases are used as follows: a. Upper case tokens and punctuation represent items which must appear as is in the source RLISP or output LISP. b. Lower case tokens represent other legal RLISP constructs or corresponding LISP translations. We typically use "e" for ____ expression, "s" for statement, and "v" for variable; "-list" is tacked on for lists of these objects. For example, the following rule describes the syntax of assignment in RLISP: VAR := number; ==> (SETQ VAR number) Another example: __________ ______ _ ______ _ IF expression THEN action_1 ELSE action_2 __________ ______ _ ______ _ ==> (COND ((expression action_1) (T action_2))) In RLISP, a function is recognized as an "ftype" (one of the tokens EXPR, FEXPR, etc. or none) followed by the keyword PROCEDURE, followed by an "id" (the name of the function), followed by a "v-list" (the formal parameter names) enclosed in parentheses. A semicolon terminates the title line. The body of the function is a <statement> followed by a semicolon. In LISP syntax, a function is defined using one of the "Dx" functions, i.e. one of De Df Dm Dn De Df Dm Dn De, Df, Dm, or Dn, depending on "ftype". For example: EXPR PROCEDURE NULL(X); EQ(X, NIL); ==> (DE NULL (X) (EQ X NIL)) 3.3.1. Function Call Syntax in RLISP and LISP 3.3.1. Function Call Syntax in RLISP and LISP 3.3.1. Function Call Syntax in RLISP and LISP A function call with N arguments (called an N-ary function) is most commonly represented as "FN(X1, X2, ... Xn)" in RLISP and as "(FN X1 X2 ... Xn)" in LISP. Commas are required to separate the arguments in RLISP but not in LISP. A zero argument function call is "FN()" in RLISP and "(FN)" in LISP. An unary function call is "FN(a)" or "FN a" in RLISP and "(FN a)" in LISP; i.e. the parentheses may be omitted around the single RLISP 7 February 1983 PSL Manual page 3.4 section 3.3 argument of any unary function in RLISP. 3.3.2. RLISP Infix Operators and Associated LISP Functions 3.3.2. RLISP Infix Operators and Associated LISP Functions 3.3.2. RLISP Infix Operators and Associated LISP Functions Many important PSL binary functions, particularly those for arithmetic operations, have associated infix operators, consisting of one or two special characters. The conversion of an RLISP expression "A op B" to its corresponding LISP form is easy: "(fn A B)", in which "fn" is the associated function. The function name fn may also be used as an ordinary RLISP function call, "fn(A, B)". Refer to Chapter 22 for details on how the association of "op" and "fn" is installed. Parentheses may be used to specify the order of combination. "((A op_a B) op_b C)" in RLISP becomes "(fn_b (fn_a A B) C)" in LISP. If two or more different operators appear in a sequence, such as "A op_a B op_b C", grouping (similar to the insertion of parentheses) is done based on relative precedence of the operators, with the highest precedence operator getting the first argument pair: "(A op_a B) op_b C" if Precedence(op_a) >= Precedence(op_b); "A op_a (B op_b C)" if Precedence(op_a) < Precedence(op_b). If two or more of the same operator appear in a sequence, such as "A op B op C", grouping is normally to the left (Left Associative; i.e. "(fn (fn A B) C)"), unless the operator is explicitly Right Associative Cons SetQ Cons SetQ (such as . for Cons and := for SetQ; i.e. "(fn A (fn B C))"). The operators + and * are N-ary; i.e. "A nop B nop C nop B" parses into "(nfn A B C D)" rather than into "(nfn (nfn (nfn A B) C) D)". The current binary operator-function correspondence is as follows: PSL Manual 7 February 1983 RLISP section 3.3 page 3.5 ________ ________ __________ Operator Function Precedence Cons Cons . Cons 23 Right Associative Expt Expt ** Expt 23 Quotient Quotient / Quotient 19 Times Times * Times 19 N-ary Difference Difference - Difference 17 Plus Plus + Plus 17 N-ary Eq Eq Eq Eq Eq Eq 15 Equal Equal = Equal 15 Geq Geq >= Geq 15 GreaterP GreaterP > GreaterP 15 Leq Leq <= Leq 15 LessP LessP < LessP 15 Member Member Member Member Member Member 15 Memq MemQ Memq MemQ Memq MemQ 15 Neq Neq Neq Neq Neq Neq 15 And And And And And And 11 N-ary Or Or Or Or Or Or 9 N-ary SetQ SetQ := SetQ 7 Right Associative Note: There are other INFIX operators, mostly used as key-words within Then Else If Do Then Else If Do other syntactic constructs (such as Then or Else in the If-..., or Do in While While the While-..., etc.). They have lower precedences than those given above. These key-words include: the parentheses "()", the brackets "[]", the colon ":", the comma ",", the semi-colon ";", the dollar sign "$", and the ids: Collect Conc Do Else End Of Procedure Product Step Such Sum Collect Conc Do Else End Of Procedure Product Step Such Sum Collect, Conc, Do, Else, End, Of, Procedure, Product, Step, Such, Sum, Then To Until Then To Until Then, To, and Until. As pointed out above, an unary function FN can be used with or without parentheses: FN(a); or FN a;. In the latter case, FN is assumed to behave as a prefix operator with highest precedence (99) so that "FOO 1 ** 2" parses as "FOO(1) ** 2;". The operators +, -, and / can also be used as Plus Minus Recip Plus Minus Recip unary prefix operators, mapping to Plus, Minus and Recip, respectively, with precedence 26. Certain other unary operators (RLISP key-words) have low precedences or explicit special purpose parsing functions. These include: BEGIN, CASE, CONT, EXIT, FOR, FOREACH, GO, GOTO, IF, IN, LAMBDA, NOOP, NOT, OFF, ON, OUT, PAUSE, QUIT, RECLAIM, REPEAT, RETRY, RETURN, SCALAR, SHOWTIME, SHUT, WHILE and WRITE. RLISP 7 February 1983 PSL Manual page 3.6 section 3.3 3.3.3. Differences between Parse and Read 3.3.3. Differences between Parse and Read 3.3.3. Differences between Parse and Read A single character can be interpreted in different ways depending on context and on whether it is used in a LISP or in an RLISP expression. Such differences are not immediately apparent to a novice user of RLISP, but an example is given below. The RLISP infix operator "." may appear in an RLISP expression and is Parse Cons Parse Cons converted by the Parse function to the LISP function Cons, as in the expression x := 'y . 'z;. A dot may also occur in a quoted expression in Read Read RLISP mode, in which case it is interpreted by Read as part of the notation Read Read for pairs, as in (SETQ X '(Y . Z)). Note that Read called from LISP or from RLISP uses slightly different scan tables (see Chapter 12). In order Cons Cons Cons Cons to use the function Cons in LISP one must use the word Cons in a prefix position. 3.3.4. Procedure Definition 3.3.4. Procedure Definition 3.3.4. Procedure Definition Procedure definitions in PSL (both RLISP and LISP) are not nested as in ALGOL; all appear at the same top level as in C. The basic function for PutD PutD defining procedures is PutD (see Chapter 10). Special syntactic forms are provided in both RLISP and LISP: mode ftype PROCEDURE name(v_1,...,v_n); body; ==> (Dx name (v_1 ... v_N) body) Examples: PROCEDURE ADD1 N; N+1; ==> (DE ADD1 (N) (PLUS N 1)) MACRO PROCEDURE FOO X; LIST('FUM, CDR X, CDR X); ==> (DM FOO (X) (LIST 'FUM (CDR X) (CDR X)) The value returned by the procedure is the value of the body; no assignment to the function name (as in ALGOL or PASCAL) is needed. In the general definition given above "mode" is usually optional; it can be LISP or SYMBOLIC (which mean the same thing) or SYSLISP [only of ____ _____ ____ _____ ____ _____ expr fexpr expr fexpr importance if SYSLISP and LISP are inter-mixed]. "Ftype" is expr, fexpr, _____ _____ ______ _____ _____ ______ _____ _____ ______ macro nexpr smacro macro nexpr smacro macro, nexpr, or smacro (or can be omitted, in which case it defaults to ____ ____ ____ expr expr expr). Name(v_1,...,v_N) is any legal form of call, including infix. Dx ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ De expr Df fexpr Dm macro Dn nexpr Ds De expr Df fexpr Dm macro Dn nexpr Ds is De for expr, Df for fexpr, Dm for macro, Dn for nexpr, and Ds for ______ ______ ______ smacro smacro smacro. ______ _____ ______ _____ ______ _____ smacro macro smacro macro The smacro is a simple substitution macro. PSL Manual 7 February 1983 RLISP section 3.3 page 3.7 SMACRO PROCEDURE ELEMENT X; % Defines ELEMENT(x) to substitute CAR CDR (X); % as Car Cdr x; ==> (DS ELEMENT (X) (CAR (CDR X))) In code which calls ELEMENT after it was defined, ELEMENT(foo); behaves exactly like CAR CDR foo;. 3.3.5. Compound Statement Grouping 3.3.5. Compound Statement Grouping 3.3.5. Compound Statement Grouping A group of RLISP expressions may be used in any position in which a single expression is expected by enclosing the group of expressions in double angle brackets, << and >>, and separating them by the ; delimiter. The RLISP <<A; B; C; ... Z>> becomes (PROGN A B C ... Z) in LISP. The value of the group is the value of the last expression, Z. Example: X:=<<PRINT X; X+1>>; % prints old X then increments X ==> (SETQ X (PROGN (PRINT X) (PLUS X 1))) 3.3.6. Blocks with Local Variables 3.3.6. Blocks with Local Variables 3.3.6. Blocks with Local Variables A more powerful construct, sometimes used for the same purpose as the Begin-End Prog Begin-End Prog << >> group, is the Begin-End block in RLISP or Prog in LISP. This construct also permits the allocation of 0 or more local variables, initialized to NIL. The normal value of a block is NIL, but it may be Return Return exited at a number of points, using the Return statement, and each can GoTo GoTo return a different value. The block also permits labels and a GoTo construct. Example: BEGIN SCALAR X,Y; % SCALAR declares locals X and Y X:='(1 2 3); L1: IF NULL X THEN RETURN Y; Y:=CAR X; X:=CDR X; GOTO L1; END; ==> (PROG (X Y) (SETQ X '(1 2 3)) L1 (COND ((NULL X) (RETURN Y))) (SETQ Y (CAR X)) (SETQ X (CDR X)) (GO L1)) RLISP 7 February 1983 PSL Manual page 3.8 section 3.3 3.3.7. The If Then Else Statement 3.3.7. The If Then Else Statement 3.3.7. The If Then Else Statement If Cond If Cond RLISP provides an If statement, which maps into the LISP Cond statement. See Chapter 9 for full details. For example: IF e THEN s; ==> (COND (e s)) IF e THEN s1 ELSE s2; ==> (COND (e s1) (T s2)) IF e1 THEN s1 ELSE IF e2 THEN s2 ELSE s3; ==> (COND (e1 s1) (e2 s2) (T s3)) 3.4. Looping Statements 3.4. Looping Statements 3.4. Looping Statements While Repeat For For Each While Repeat For For Each RLISP provides While, Repeat, For and For Each loops. These are discussed in greater detail in Chapter 9. Some examples follow: 3.4.1. While Loop 3.4.1. While Loop 3.4.1. While Loop WHILE e DO s; % As long as e NEQ NIL, do s ==> (WHILE e s) 3.4.2. Repeat Loop 3.4.2. Repeat Loop 3.4.2. Repeat Loop REPEAT s UNTIL e; % repeat doing s until "e" is not NIL ==> (REPEAT s e) 3.4.3. For Each Loop 3.4.3. For Each Loop 3.4.3. For Each Loop For Each For Each The For Each loops provide various mapping options, processing elements of a list in some way and sometimes constructing a new list. FOR EACH x IN y DO s; % y is a list, x traverses list bound to eac % element in turn. ==> (FOREACH x IN y DO s) FOR EACH x ON y DO s; % y is a list, x traverses list Bound to suc % Cdr's of y. ==> (FOREACH x ON y DO s) Other options can return modified lists, etc. See chapter 9. PSL Manual 7 February 1983 RLISP section 3.4 page 3.9 3.4.4. For Loop 3.4.4. For Loop 3.4.4. For Loop For For The For loop permits an iterative form with a compacted control variable. Other options can compute sums and products. FOR i := a:b DO s; % step i successively from a to b in % steps of 1. ==> (FOR (FROM I a b 1) DO s) FOR i := a STEP b UNTIL c DO s; % More general stepping ==> (FOR (FROM I a c b) DO s) 3.4.5. Loop Examples 3.4.5. Loop Examples 3.4.5. Loop Examples LISP PROCEDURE count lst; % Count elements in lst BEGIN SCALAR k; k:=0; WHILE PAIRP lst DO <<k:=k+1; lst:=CDR lst>>; RETURN k; END; ==> (DE COUNT (LST) (PROG (K) (SETQ K 0) (WHILE (PAIRP LST) (PROGN (SETQ K (PLUS K 1)) (SETQ LST (CDR LST)))) (RETURN K))) or LISP PROCEDURE CountNil lst; % Count NIL elements in lst BEGIN SCALAR k; k:=0; FOR EACH x IN lst DO If Null x then k:=k+1; RETURN k; END; ==> (DE COUNTNIL (LST) (PROG (K) (SETQ K 0) (FOREACH X IN LST DO (COND ((NULL X) (SETQ K (PLUS K 1))))) (RETURN K))) RLISP 7 February 1983 PSL Manual page 3.10 section 3.5 3.5. Switch Syntax 3.5. Switch Syntax 3.5. Switch Syntax Two declarations are offered to the user for turning on or off a variety of switches in the system. Switches are global variables that have only the values T or NIL. By convention, the switch name is XXXX, but the associated global variable is !*XXXX. The RLISP commands ON and OFF take a list of switch names as argument and turn them on and off respectively (i.e. set the corresponding !* variable to T or NIL). Example: ON ECHO, FEE, FUM; % Sets !*ECHO, !*FEE, !*FUM to T; ==> (ON ECHO FEE FUM) OFF INT,SYSLISP; % Sets !*INT and !*SYSLISP to NIL ==> (OFF INT SYSLISP) [??? Mention SIMPFG property ???] [??? Mention SIMPFG property ???] [??? Mention SIMPFG property ???] See Section 6.7 for a complete set of switches and global variables. 3.6. RLISP I/O Syntax 3.6. RLISP I/O Syntax 3.6. RLISP I/O Syntax RLISP provides special commands to OPEN and SELECT files for input or for output and to CLOSE files. File names must be enclosed in "....". Files In In with the extension ".sl" or ".lsp" are read by In in LISP mode rather than RLISP mode. IN "<griss.stuff>fff.red","ggg.lsp"; % First reads fff.red % Then reads ggg.lsp OUT "keep-it.output"; % Diverts output to "keep-it.ou OUT "fum"; % now to fum, keeping the other SHUT "fum"; % to close fum and flush the bu File names can use the full system conventions. See Chapter 12 for more detail on I/O. 3.7. Transcript of a Short Session with RLISP 3.7. Transcript of a Short Session with RLISP 3.7. Transcript of a Short Session with RLISP The following is a transcript of RLISP running on the DEC-20. PSL Manual 7 February 1983 RLISP section 3.7 page 3.11 @psl:rlisp PSL 3.1 Rlisp, 27-Oct-82 [1] % Notice the numbered prompt. [1] % Comments begin with "%" and do not change the prompt number. [1] Z := '(1 2 3); % Make an assignment for Z. (1 2 3) [2] Cdr Z; % Notice the change in the prompt nu (2 3) [3] Lisp Procedure Count L; % "Count" counts the number of eleme [3] If Null L Then 0 % in a list L. [3] Else 1 + Count Cdr L; COUNT [4] Count Z; % Try out "Count" on Z. 3 [5] Tr Count; % Trace the recursive execution of "Count". (COUNT) [6] % A call on "Count" now shows the value of [6] % "Count" and of its argument each time it [6] Count Z; % is called. COUNT being entered L: (1 2 3) COUNT (level 2) being entered L: (2 3) COUNT (level 3) being entered L: (3) COUNT (level 4) being entered L: NIL COUNT (level 4) = 0 COUNT (level 3) = 1 COUNT (level 2) = 2 COUNT = 3 3 [7] Lisp Procedure Factorial X; [7] If X <= 1 Then 1 [7] Else X * Factorial (X-1); FACTORIAL [8] Tr Factorial; (FACTORIAL) [9] Factorial 4; % Trace execution of "Factorial". FACTORIAL being entered X: 4 FACTORIAL (level 2) being entered X: 3 FACTORIAL (level 3) being entered X: 2 FACTORIAL (level 4) being entered X: 1 FACTORIAL (level 4) = 1 FACTORIAL (level 3) = 2 FACTORIAL (level 2) = 6 FACTORIAL = 24 24 RLISP 7 February 1983 PSL Manual page 3.12 section 3.7 [10] UnTr Count,Factorial; NIL [11] Count 'A; ***** An attempt was made to do CDR on `A', which is not a pair Break loop 1 lisp break> ? BREAK():{Error,return-value} ---------------------------- This is a Read-Eval-Print loop, similar to the top level loop, excep that the following IDs at the top level cause functions to be called rather than being evaluated: ? Print this message, listing active Break IDs T Print stack backtrace Q Exit break loop back to ErrorSet C Return last value to the ContinuableError call R Reevaluate ErrorForm!* and return M Display ErrorForm!* as the "message" E Invoke a simple structure editor on ErrorForm!* (For more information do Help Editor.) I Show a trace of any interpreted functions See the manual for details on the Backtrace, and how ErrorForm!* is set. The Break Loop attempts to use the same TopLoopRead!* etc, as the calling top loop, just expanding the PromptString!*. NIL 2 lisp break> % Get a Trace-Back of the 2 lisp break> I % interpreted functions. Backtrace, including interpreter functions, from top of stack: LIST2 CDR COUNT PLUS2 PLUS COND COUNT NIL 3 lisp break> Q % To exit the Break Loop. [12] % Load in a file, showing the file [12] In "small-file.red"; % and its execution. X := 'A . 'B . NIL;(A B) % Construct a list with "." for Cons. Count X;2 % Call "Count" on X. Reverse X;(B A) % Call "Reverse" on X. NIL [13] % This leaves RLISP and enters [13] End; % LISP mode. Entering LISP... PSL, 27-Oct-82 6 lisp> (SETQ X 3) % A LISP assignment statement. 3 7 lisp> (FACTORIAL 3) % Call "Factorial" on 3. 6 8 lisp> (BEGINRLISP) % This function returns us to RLISP. Entering RLISP... [14] Quit; % To exit call "Quit". @continue PSL Manual 7 February 1983 RLISP section 3.7 page 3.13 "Continued" [15] X; % Notice the prompt number. 3 [16] ^C % One can also quit with <Ctrl-C>. @start % Alternative immediate re-entry. [17] Quit; @ |
Added psl-1983/lpt/04-datatypes.lpt version [56ac0d85bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Data Types section 4.0 page 4.1 CHAPTER 4 CHAPTER 4 CHAPTER 4 DATA TYPES DATA TYPES DATA TYPES 4.1. Data Types and Structures Supported in PSL . . . . . 4.1 4.1.1. Data Types. . . . . . . . . . . . . . 4.1 4.1.2. Other Notational Conventions. . . . . . . . 4.4 4.1.3. Structures. . . . . . . . . . . . . . 4.4 4.2. Predicates Useful with Data Types . . . . . . . . 4.5 4.2.1. Functions for Testing Equality . . . . . . . 4.6 4.2.2. Predicates for Testing the Type of an Object . . 4.7 4.2.3. Boolean Functions . . . . . . . . . . . 4.8 4.3. Converting Data Types . . . . . . . . . . . . 4.9 4.1. Data Types and Structures Supported in PSL 4.1. Data Types and Structures Supported in PSL 4.1. Data Types and Structures Supported in PSL 4.1.1. Data Types 4.1.1. Data Types 4.1.1. Data Types Data objects in PSL are tagged with their type. This means that the type declarations required in many programming languages are not needed. Some functions are "generic" in that the result they return depends on the types ____ ___ of the arguments. A tagged PSL object is called an item, and has a tag ____ field (9 bits on the DEC-20, 5 bits on the VAX), an info field (18 bits on the DEC-20, 27 bits on the VAX), and possibly some bits for garbage ____ collection. The info field is either immediate data or an index or address __ into some other structure (such as the heap or id space). For the purposes ____ of input and output of items, an appropriate notation is used (see Chapter 12 for full details on syntax, restrictions, etc.). More explicit implementation details can be found in Chapters 20 and 21. The basic data types supported in PSL and a brief indication of their representations are described below. _______ _______ integer The integers are also called "fixed" numbers. The magnitude _______ of integers is essentially unrestricted if the "big number" _______ module, BIG, is loaded (LOAD BIG). The notation for integers is a sequence of digits in an appropriate radix (radix 10 is the default, which can be overridden by a radix prefix, such as 2#, 8#, 16# etc). There are three internal _______ representations of integers, chosen to suit the implementation: ____ ______ ____ ____ inum A signed number fitting into info. Inums do not require dynamic storage and are represented in the Data Types 7 February 1983 PSL Manual page 4.2 section 4.1 same form as machine integers. (19 bit [-2^18 ... 2^18 - 1] on the DEC-20, 28 bit on the VAX.) ______ ____ _______ fixnum A full-word signed integer, allocated in the heap. (36 bit on the DEC-20, fitting into a register; 32 bit on the VAX.) [??? Do we need fixnums, and if yes how large [??? Do we need fixnums, and if yes how large [??? Do we need fixnums, and if yes how large ???] ???] ???] ______ _______ bignum A signed integer of arbitrary precision, allocated _______ ______ as a vector of integers. Bignums are currently not installed by default; to use them, do (LOAD BIG). _____ ________ _____ float A floating point number, allocated in the heap. The _____ precision of floats is determined solely by the implementation, and is 72-bit double precision on the DEC-20, _____ 64-bit on the VAX. The notation for a float is a sequence of digits with the addition of a single floating point ( . ) and optional exponent (E <integer>). (No spaces may occur between the point and the digits). Radix 10 is used for representing the mantissa and the exponent of dty(floating point) numbers. __ __________ __ ____ id An identifier (or id) is an item whose info field points to a five-item structure containing the print name, property cell, value cell, function cell, and package cell. This structure __ is contained in the id space. The notation for an id is its print name, an alphanumeric character sequence starting with __ a letter. One always refers to a particular id by giving its print name. When presented with an appropriate print name, __ the PSL reader will find a unique id to associate with it. __ See Chapters 6 and 12 for more information on ids and their __ syntax. NIL and T are treated as special ids in PSL. ____ ____ pair A primitive two-item structure which has a left and right ___ ________ part. A notation called dot-notation is used, with the form: (<left-part> . <right-part>). The <left-part> is known as Car Cdr Car Cdr the Car portion and the <right-part> as the Cdr portion. The ____ parts may be any item. (Spaces are used to resolve ambiguity _____ with floats; see Chapter 12). ______ ____ _______ vector A primitive uniform structure of items; an integer index is used to access random values in the structure. The ______ ___ ____ individual elements of a vector may be any item. Access to ______ vectors is by means of functions for indexing, sub-vector extraction and concatenation, defined in Section 8.3. In the ______ ______ notation for vectors, the elements of a vector are surrounded ____ ____ ____ by square brackets: [item-0 item-1 ... item-n]. ______ ______ ______ string A packed vector (or byte vector) of characters; the elements _______ are small integers representing the ASCII codes for the PSL Manual 7 February 1983 Data Types section 4.1 page 4.3 ____ characters (usually inums). The elements may be accessed by indexing, substring and concatenation functions, defined in ______ Chapter 8. String notation consists of a series of characters enclosed in double quotes, as in "THIS IS A STRING". A quote is included by doubling it, as in "HE SAID, ______ ""LISP""". (Input strings may cross the end-of-line boundary, but a warning is given.) See !*EOLINSTRINGOK in chapter 12. ____ ______ ______ ____ word-vector A vector of machine-sized words, used to implement such ______ ______ things as fixnums, bignums, etc. The elements are not ____ considered to be items, and are not examined by the garbage collector. ____ ______ ____ ______ ____ ______ [??? The word-vector could be used to implement [??? The word-vector could be used to implement [??? The word-vector could be used to implement machine-code blocks on some machines. ???] machine-code blocks on some machines. ???] machine-code blocks on some machines. ???] ____ ______ ______ ____ ______ Byte-Vector A vector of bytes. Internally a byte-vector is the same as a ______ string, but it is printed differently as a vector of integers instead of characters. ________ ______ Halfword-Vector ______ A vector of machine-sized halfwords. ____ _______ ____ code-pointer This item is used to refer to the entry point of compiled _____ ______ ______ _____ ______ ______ _____ ______ ______ exprs fexprs macros exprs fexprs macros functions (exprs, fexprs, macros, etc.), permitting compiled functions to be renamed, passed around anonymously, etc. New Lap Fasl ____ _______ Lap Fasl code-pointers are created by the loader (Lap,Fasl) and associated functions. They can be printed; the printing function prints the number of arguments expected as well as the entry point. The value appears in the convention of the implementation (#<Code a nnnn> on the DEC-20 and VAX, where a is the number of arguments and nnnn is the entry point). ___ ___ ___ [not ___ _______ [not env-pointer A data type used to support a funarg capability. [not ___________ ___ ___________ ___ ___________ ___ implemented yet] implemented yet] implemented yet] 4.1.2. Other Notational Conventions 4.1.2. Other Notational Conventions 4.1.2. Other Notational Conventions Certain functional arguments can be any of a number of types. For convenience, we give these commonly used sets a name. We refer to these sets as "classes" of primitive data types. In addition to the types described above and the names for classes of types given below, we use the following conventions in the manual. {XXX, YYY} indicates that either data type XXX or data type YYY will do. {XXX}-{YYY} indicates that any object of type XXX can be used except those of type YYY; in this case, YYY is a _______ _____ subset of XXX. For example, {integer, float} indicates that either an _______ _____ ___ ______ integer or a float is acceptable; {any}-{vector} means any type except a ______ vector. Data Types 7 February 1983 PSL Manual page 4.4 section 4.1 ___ _ __________ any Any of the types given above. S-expression is another term ___ for any. All PSL entities have some value unless an error occurs during evaluation. ____ ___ ____ atom The class {any}-{pair}. _______ boolean The class of global variables {T, NIL}, or their respective values, {T, NIL}. (See Chapter 6.7). _________ _______ character Integers in the range of 0 to 127 representing ASCII character codes. These are distinct from single-character __ ids. ________ _______ _____ ______ ______ ____ _______ constant The class of {integer, float, string, vector, code-pointer}. Eval ________ Eval A constant evaluates to itself (see the definition of Eval in Chapter 11). _____ _______ extra-boolean Any value in the system. Anything that is not NIL has the _______ boolean interpretation T. _____ __ ftype The class of definable function types. The set of ids ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr fexpr macro nexpr expr fexpr macro nexpr {expr, fexpr, macro, nexpr}. _____ __________ The ftype is ONLY an attribute of identifiers, and is not ____ _______ associated with either executable code (code-pointers) or ______ lambda expressions. __ _______ _______ io-channel A small integer representing an io channel. ______ _______ _____ number The class of {integer, float}. _ ______ ______ ______ ______ ____ ______ x-vector Any kind of vector; i.e. a string, vector, word-vector, or ____ word. _________ Undefined An implementation-dependent value returned by some low-level functions; i.e. the user should not depend on this value. ____ ________ None Returned A notational convenience used to indicate control functions that do not return directly to the calling point, and hence Go Go do not return a value. (e.g. Go) 4.1.3. Structures 4.1.3. Structures 4.1.3. Structures ____ ____ Structures are entities created using pairs. Lists are structures very ____ commonly required as parameters to functions. If a list of homogeneous ____ entities is required by a function, this class is denoted by xxx-list, in ____ which xxx is the name of a class of primitives or structures. Thus a list __ __ ____ ____ _______ _______ ____ of ids is an id-list, a list of integers is an integer-list, and so on. ____ ____ ____ ___ ____ list A list is recursively defined as NIL or the pair (any . list). A ____ ________ ____ special notation called list-notation is used to represent lists. List-notation eliminates the extra parentheses and dots required by dot-notation, as illustrated below. List-notation and dot-notation may be mixed, as shown in the second and third examples. (See section 3.3.3.) ____________ _____________ dot-notation list-notation (a . (b . (c . NIL))) (a b c) (a . (b . c)) (a b . c) (a . ((b . c) . (d . NIL))) PSL Manual 7 February 1983 Data Types section 4.1 page 4.5 Note: () is an alternate input representation of NIL. _ ____ _ ____ ___________ ____ a-list An a-list, or association list, is a list in which each element Car ____ Car is a pair, the Car part being a key associated with the value in Cdr Cdr the Cdr part. ____ ____ form A form is an S-expression (any) which is legally acceptable to Eval Eval Eval; that is, it is syntactically and semantically accepted by the interpreter or the compiler. (See Chapter 11 for more details.) ______ lambda A lambda expression must have the form (in list-notation): __ ____ (LAMBDA parameters . body). "Parameters" is an id-list of ____ formal parameters for "body", which is a form to be evaluated ProgN ProgN (note the implicit ProgN). The semantics of the evaluation are Eval Eval defined by the Eval function (see chapter 11). ________ ______ ____ _______ function A lambda, or a code-pointer. A function is always evaluated as Eval Spread Eval Spread Eval, Spread. 4.2. Predicates Useful with Data Types 4.2. Predicates Useful with Data Types 4.2. Predicates Useful with Data Types Most functions in this Section return T if the condition defined is met and NIL if it is not. Exceptions are noted. Defined are type-checking functions and elementary comparisons. 4.2.1. Functions for Testing Equality 4.2.1. Functions for Testing Equality 4.2.1. Functions for Testing Equality Functions for testing equality are listed below. For other functions comparing arithmetic values see Chapter 5. Eq Eq _ ___ _ ___ _______ ____ ________ ____ (Eq U:any V:any): boolean open-compiled, expr _ _ Returns T if U points to the same object as V, i.e. if they are Eq ____ Eq ___ identical items. Eq is not a reliable comparison between numeric arguments. This function should only be used in special Equal Equal circumstances. Normally, equality should be tested with Equal, described below. EqN EqN _ ___ _ ___ _______ ____ (EqN U:any V:any): boolean expr Eq _ _ Eq _ _ Returns T if U and V are Eq or if U and V are numbers and have the same value and type. [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 [??? Should numbers of different type be EqN? e.g. 0 vs. 0.0 ???] ???] ???] Data Types 7 February 1983 PSL Manual page 4.6 section 4.2 Equal Equal _ ___ _ ___ _______ ____ (Equal U:any V:any): boolean expr _ _ ____ Returns T if U and V are the same. Pairs are compared ______ recursively to the bottom levels of their trees. Vectors must Equal Equal have identical dimensions and Equal values in all positions. ______ Strings must have identical characters, i.e. all characters must Eq ____ _______ Eq be of the same case. Code-pointers must have Eq values. Other Eqn ____ Eqn atoms must be Eqn equal. A usually valid heuristic is that if Print Print two objects look the same if printed with the function Print, Equal Equal Equal ____ Equal they are Equal. If one argument is known to be an atom, Equal is Eq Eq open-compiled as Eq. For example, if (Setq X '(A B C)) and (Setq Y X) have been executed, then (EQ X Y) is T (EQ X '(A B C)) is NIL (EQUAL X '(A B C)) is T (EQ 1 1) is T (EQ 1.0 1.0) is NIL (EQN 1.0 1.0) is T (EQN 1 1.0) is NIL (EQUAL 0 0.0) is NIL Neq Neq _ ___ _ ___ _______ _____ (Neq U:any V:any): boolean macro Not Equal Not Equal _ _ (Not (Equal U V)). Ne Ne _ ___ _ ___ _______ ____ ________ ____ (Ne U:any V:any): boolean open-compiled, expr Not Eq Not Eq _ _ (Not (Eq U V)). EqStr EqStr _ ___ _ ___ _______ ____ (EqStr U:any V:any): boolean expr ______ Compare two strings, for exact (Case sensitive) equality. For case-INsensitive equality one must load the STRINGS module (see EqStr Eq EqStr _ _ Eq _ _ Section 8.7). EqStr returns T if U and V are Eq or if U and V are equal strings. EqCar EqCar _ ___ _ ___ _______ ____ (EqCar U:any V:any): boolean expr Eq Car Eq Car _ _ Tests whether (Eq (Car U) V)). If the first argument is not a EqCar EqCar pair, EqCar returns NIL. PSL Manual 7 February 1983 Data Types section 4.2 page 4.7 4.2.2. Predicates for Testing the Type of an Object 4.2.2. Predicates for Testing the Type of an Object 4.2.2. Predicates for Testing the Type of an Object Atom Atom _ ___ _______ ____ ________ ____ (Atom U:any): boolean open-compiled, expr _ ____ Returns T if U is not a pair. CodeP CodeP _ ___ _______ ____ ________ ____ (CodeP U:any): boolean open-compiled, expr _ ____ _______ Returns T if U is a code-pointer. ConstantP ConstantP _ ___ _______ ____ (ConstantP U:any): boolean expr _ ________ ____ __ Returns T if U is a constant (that is, neither a pair nor an id). ______ ________ Note that vectors are considered constants. [??? Should Eval U Eq U if U is a constant? ???] [??? Should Eval U Eq U if U is a constant? ???] [??? Should Eval U Eq U if U is a constant? ???] FixP FixP _ ___ _______ ____ ________ ____ (FixP U:any): boolean open-compiled, expr _ _______ Returns T if U is an integer. If BIG is loaded, this function also returns T for bignums. FloatP FloatP _ ___ _______ ____ ________ ____ (FloatP U:any): boolean open-compiled, expr _ _____ Returns T if U is a float. IdP IdP _ ___ _______ ____ ________ ____ (IdP U:any): boolean open-compiled, expr _ __ Returns T if U is an id. Null Null _ ___ _______ ____ ________ ____ (Null U:any): boolean open-compiled, expr Not _ Not Returns T if U is NIL. This is exactly the same function as Not, defined in Section 4.2.3. Both are available solely to increase readability. NumberP NumberP _ ___ _______ ____ ________ ____ (NumberP U:any): boolean open-compiled, expr _ ______ _______ _____ Returns T if U is a number (integer or float). Data Types 7 February 1983 PSL Manual page 4.8 section 4.2 PairP PairP _ ___ _______ ____ ________ ____ (PairP U:any): boolean open-compiled, expr _ ____ Returns T if U is a pair. StringP StringP _ ___ _______ ____ ________ ____ (StringP U:any): boolean open-compiled, expr _ ______ Returns T if U is a string. VectorP VectorP _ ___ _______ ____ ________ ____ (VectorP U:any): boolean open-compiled, expr _ ______ Returns T if U is a vector. 4.2.3. Boolean Functions 4.2.3. Boolean Functions 4.2.3. Boolean Functions Boolean functions return NIL for "false"; anything non-NIL is taken to be true, although a conventional way of representing truth is as T. Note that T always evaluates to itself. NIL may also be represented as '(). The And Or Not And Or Not Boolean functions And, Or, and Not can be applied to any LISP type, and are And Or And Or not bitwise functions. And and Or are frequently used in LISP as control structures as well as Boolean connectives (see Section 9.2). For example, the following two constructs will give the same result: (COND ((AND A B C) D)) (AND A B C D) Since there is no specific Boolean type in LISP and since every LISP expression has a value which may be used freely in conditionals, there is no hard and fast distinction between an arbitrary function and a Boolean function. However, the three functions presented here are by far the most useful in constructing more complex tests from simple predicates. Not Not _ ___ _______ ____ ________ ____ (Not U:any): boolean open-compiled, expr _ Returns T if U is NIL. This is exactly the same function as Null Null Null, defined in Section 4.2.2. Both are available solely to increase readability. And And _ ____ _____ _______ ____ ________ _____ (And [U:form]): extra-boolean open-compiled, fexpr And And _ And evaluates each U until a value of NIL is found or the end of ____ the list is encountered. If a non-NIL value is the last value, And And it is returned; otherwise NIL is returned. Note that And called with zero arguments returns T. PSL Manual 7 February 1983 Data Types section 4.2 page 4.9 Or Or _ ____ _____ _______ ____ ________ _____ (Or [U:form]): extra-boolean open-compiled, fexpr _ U is any number of expressions which are evaluated in order of their appearance. If one is found to be non-NIL, it is returned Or Or as the value of Or. If all are NIL, NIL is returned. Note that Or Or if Or is called with zero arguments, it returns NIL. 4.3. Converting Data Types 4.3. Converting Data Types 4.3. Converting Data Types The following functions are used in converting data items from one type to another. They are grouped according to the type returned. Numeric Fix Float Fix Float types may be converted using functions such as Fix and Float, described in Section 5.2. Intern Intern _ __ ______ __ ____ (Intern U:{id,string}): id expr Intern ______ __ Intern __ ____ _____ Converts string to id. Intern searches the id-hash-table (or __ ____ _____ __ current id-hash-table if the package system is loaded) for an id _ __ with the same print name as U and returns the id on the __ ____ _____ id-hash-table if a match is found. (See Chapter 6 for a __ ____ _____ discussion of the id-hash-table. Any properties and GLOBAL values _ _ associated with the uninterned U are lost. If U does not match _ any entry, a new one is created and returned. If U has more than the maximum number of characters permitted by the implementation (???), an error is signalled: ***** Too many characters to INTERN [??? Rewrite for package system; include search path, global, [??? Rewrite for package system; include search path, global, [??? Rewrite for package system; include search path, global, local, intern, etc. See Chapter 6. ???] local, intern, etc. See Chapter 6. ???] local, intern, etc. See Chapter 6. ???] The maximum number of characters in any token is 5000. NewId NewId _ ______ __ ____ (NewId S:string): id expr __ _____ ____ Allocates a new uninterned id, and sets its print-name to the ______ _ ______ ___ string S. The string is not copied. (Setq New (NewId "NEWONE")) returns NEWONE __ Note that if one refers directly to the id NEWONE, it will become interned and a new position in the id space will be allocated to __ __ it. One has to refer to the new id indirectly through the id New. Data Types 7 February 1983 PSL Manual page 4.10 section 4.3 Int2Id Int2Id _ _______ __ ____ (Int2Id I:integer): id expr _______ __ _ __ Converts an integer to an id; this refers to the I'th id in the Int2Id __ Int2Id id space. Since 0 ... 127 correspond to ASCII characters, Int2Id with an argument in this range converts an ASCII code to the __ corresponding single character id. (Int2Id 250) returns QUOTIENT Id2Int Id2Int _ __ _______ ____ (Id2Int D:id): integer expr __ _ _______ Returns the id space position of D as a LISP integer. (Id2Int 'String) returns 182 Id2String Id2String _ __ ______ ____ (Id2String D:id): string expr Id2String Print __ Id2String Print Get name from id space. Id2String returns the Print name of its ______ argument as a string. This is not a copy, so destructive CopyString CopyString operations should not be performed on the result. See CopyString in Chapter 8. [??? Should it be a copy? ???] [??? Should it be a copy? ???] [??? Should it be a copy? ???] (Id2String 'String) returns "STRING" String2List String2List _ ______ ____ ____ ____ (String2List S:string): inum-list expr Length Add1 Size ____ Length Add1 Size _ Creates a list of Length (Add1 (Size S)), converting the ASCII _______ characters into small integers. [??? What of 0/1 base for length vs length -1. What of the [??? What of 0/1 base for length vs length -1. What of the [??? What of 0/1 base for length vs length -1. What of the NUL char added ???] NUL char added ???] NUL char added ???] (String2List "STRING") returns (83 84 82 73 78 71) List2String List2String _ ____ ____ ______ ____ (List2String L:inum-list): string expr Size ______ Size _ ____ Allocates a string of the same Size as L, and converts inums to ____ characters according to their ASCII code. The inums must be in the range 0 ... 127. [??? Check if 0 ... 127, and signal error ???] [??? Check if 0 ... 127, and signal error ???] [??? Check if 0 ... 127, and signal error ???] (List2String '(83 84 82 73 78 71)) returns "STRING" PSL Manual 7 February 1983 Data Types section 4.3 page 4.11 String String _ ____ ______ _____ (String [I:inum]): string nexpr ______ ____ Creates and returns a string containing all the inums given. (String 83 84 82 73 78 71) returns "STRING" Vector Vector _ ___ ______ _____ (Vector [U:any]): vector nexpr ______ _ Creates and returns a vector containing all the Us given. (Setq X (Vector 83 84 82 73 78 71)) returns [83 84 82 73 78 71] Vector2String Vector2String _ ______ ______ ____ (Vector2String V:vector): string expr _______ ______ ______ Pack the small integers in the vector into a string of the same Size Size _______ Size, using the integers as ASCII values. [??? check for integer in range 0 ... 127 ???] [??? check for integer in range 0 ... 127 ???] [??? check for integer in range 0 ... 127 ???] (Vector2String X) where X is defined as above returns "STRING" String2Vector String2Vector _ ______ ______ ____ (String2Vector S:string): vector expr Size ______ ______ Size Unpack the string into a vector of the same Size. The elements ______ of the vector are small integers, representing the ASCII values _ of the characters in S. (String2Vector "VECTOR") returns [V E C T O R] Vector2List Vector2List _ ______ ____ ____ (Vector2List V:vector): list expr Size Length Upbv ____ Size _ Length Upbv _ Create a list of the same Size as V (i.e. of Length Upbv(V)+1), Upbv Upbv _ copying the elements in order 0, 1, ..., Upbv(V). (Vector2List [L I S T]) returns (L I S T) List2Vector List2Vector _ ____ ______ ____ (List2Vector L:list): vector expr Size ____ ______ Size Copy the elements of the list into a vector of the same Size. (List2Vector '(V E C T O R)) returns [V E C T O R] |
Added psl-1983/lpt/05-numbers.lpt version [e52f5c1245].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Arithmetic Functions section 5.0 page 5.1 CHAPTER 5 CHAPTER 5 CHAPTER 5 NUMBERS AND ARITHMETIC FUNCTIONS NUMBERS AND ARITHMETIC FUNCTIONS NUMBERS AND ARITHMETIC FUNCTIONS 5.1. Big Integers . . . . . . . . . . . . . . . 5.1 5.2. Conversion Between Integers and Floats. . . . . . . 5.2 5.3. Arithmetic Functions. . . . . . . . . . . . . 5.2 5.4. Functions for Numeric Comparison. . . . . . . . . 5.5 5.5. Bit Operations. . . . . . . . . . . . . . . 5.7 5.6. Various Mathematical Functions . . . . . . . . . 5.8 ______ Most of the arithmetic functions in PSL expect numbers as arguments. In all cases an error occurs if the parameter to an arithmetic function is not ______ a number: ***** Non-numeric argument in arithmetic Exceptions to the rule are noted. The underlying machine arithmetic requires parameters to be either all _______ _____ integers or all floats. If a function receives mixed types of arguments, _______ _____ integers are converted to floats before arithmetic operations are ______ _______ performed. The range of numbers which can be represented by an integer is _____ different than that represented by a float. Because of this difference, a conversion is not always possible; an unsuccessful attempt to convert may cause an error to be signalled. The MATHLIB package contains some useful mathematical functions. See Section 5.6 for documentation for these functions. 5.1. Big Integers 5.1. Big Integers 5.1. Big Integers Loading the BIG module redefines the basic arithmetic operations, including the logical operations, to permit arbitrary precision (or "bignum") integer operations. Note that fixnums which are present before loading BIG can cause problems, because loading BIG restricts the legal range of fixnums. 5.2. Conversion Between Integers and Floats 5.2. Conversion Between Integers and Floats 5.2. Conversion Between Integers and Floats The conversions mentioned above can be done explicitly by the following functions. Other functions which alter types can be found in Section 4.3. Arithmetic Functions 7 February 1983 PSL Manual page 5.2 section 5.2 Fix Fix _ ______ _______ ____ (Fix U:number): integer expr _______ Returns the integer which corresponds to the truncated value of _ U. The result of conversion must retain all significant portions _ _ _______ of U. If U is an integer it is returned unchanged. _____ _____ _____ [??? Note that unless big is loaded, a float with value [??? Note that unless big is loaded, a float with value [??? Note that unless big is loaded, a float with value larger than 2**35-1 on the DEC-20 is converted into something larger than 2**35-1 on the DEC-20 is converted into something larger than 2**35-1 on the DEC-20 is converted into something strange but without any error message. Note how truncation strange but without any error message. Note how truncation strange but without any error message. Note how truncation works on negative numbers (always towards zero). ???] works on negative numbers (always towards zero). ???] works on negative numbers (always towards zero). ???] (Fix 2.1) % returns 2 (Fix -2.1) % returns -2 Float Float _ ______ _____ ____ (Float U:number): float expr _____ _ The float corresponding to the value of the argument U is _______ returned. Some of the least significant digits of an integer may Float Float Float Float _____ be lost due to the implementation of Float. Float of a float ______ _ returns the number unchanged. If U is too large to represent in _____ float, an error occurs: ***** Argument to FLOAT is too large _______ _______ _______ [??? Only if big is loaded can one make an integer of value [??? Only if big is loaded can one make an integer of value [??? Only if big is loaded can one make an integer of value greater than 2**35-1, so without big you won't get this error greater than 2**35-1, so without big you won't get this error greater than 2**35-1, so without big you won't get this error message. The largest representable float is message. The largest representable float is message. The largest representable float is (2**62-1)*(2**65) on the DEC-20. ???] (2**62-1)*(2**65) on the DEC-20. ???] (2**62-1)*(2**65) on the DEC-20. ???] 5.3. Arithmetic Functions 5.3. Arithmetic Functions 5.3. Arithmetic Functions The functions described below handle arithmetic operations. Please note the remarks at the beginning of this Chapter regarding the mixing of argument types. Abs Abs _ ______ ______ ____ (Abs U:number): number expr Returns the absolute value of its argument. Add1 Add1 _ ______ ______ ____ (Add1 U:number): number expr _ Returns the value of U plus 1; the returned value is of the same _ _______ _____ type as U (integer or float). PSL Manual 7 February 1983 Arithmetic Functions section 5.3 page 5.3 Decr Decr _ ____ __ ______ ______ _____ (Decr U:form [Xi:number]): number macro Part of the USEFUL package (LOAD USEFUL). With only one argument, this is equivalent to (SETF U (SUB1 U)) With multiple arguments, it is equivalent to (SETF U (DIFFERENCE U (PLUS X1 ... Xn))) 1 lisp> (Load Useful) NIL 2 lisp> (Setq Y '(1 5 7)) (1 5 7) 3 lisp> (Decr (Car Y)) 0 4 lisp> Y (0 5 7) 5 lisp> (Decr (Cadr Y) 3 4) -2 6 lisp> Y (0 -2 7) Difference Difference _ ______ _ ______ ______ ____ (Difference U:number V:number): number expr _ _ The value of U - V is returned. Divide Divide _ ______ _ ______ ____ ____ (Divide U:number V:number): pair expr ____ ________ _________ The pair (quotient . remainder) is returned, as if the quotient Quotient Quotient part was computed by the Quotient function and the remainder by Remainder Remainder the Remainder function. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in Divide Expt Expt _ ______ _ _______ ______ ____ (Expt U:number V:integer): number expr _ _ _____ _ _______ _ Returns U raised to the V power. A float U to an integer power V ___ _ _____ does not have V changed to a float before exponentiation. Incr Incr _ ____ __ ______ ______ _____ (Incr U:form [Xi:number]): number macro Part of the USEFUL package (LOAD USEFUL). With only one argument, this is equivalent to Arithmetic Functions 7 February 1983 PSL Manual page 5.4 section 5.3 (SETF U (ADD1 U)) With multiple arguments it is equivalent to (SETF U (PLUS U X1 ... Xn)) Minus Minus _ ______ ______ ____ (Minus U:number): number expr _ Returns -U. Plus Plus _ ______ ______ _____ (Plus [U:number]): number macro Plus Plus Forms the sum of all its arguments. Plus may be called with only Plus Plus one argument. In this case it returns its argument. If Plus is called with no arguments, it returns zero. Plus2 Plus2 _ ______ _ ______ ______ ____ (Plus2 U:number V:number): number expr _ _ Returns the sum of U and V. Quotient Quotient _ ______ _ ______ ______ ____ (Quotient U:number V:number): number expr Quotient Quotient _ _ The Quotient of U divided by V is returned. Division of two _______ _ positive or two negative integers is conventional. If both U and _ _______ V are integers and exactly one of them is negative, the value Quotient Abs Quotient Abs _ returned is the negative truncation of the Quotient of Abs U and Abs Abs _ _____ _____ Abs V. If either argument is a float, a float is returned which _____ is exact within the implemented precision of floats. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in QUOTIENT Recip Recip _ ______ _____ ____ (Recip U:number): float expr Recip Recip _ _____ Recip converts U to a float if necessary, and then finds the Quotient Quotient inverse using the function Quotient. Remainder Remainder _ ______ _ ______ ______ ____ (Remainder U:number V:number): number expr _ _ _______ _______ If both U and V are integers the result is the integer remainder _ _ _____ of U divided by V. If either parameter is a float, the result is _ _ _ _ _____ the difference between U and V*(U/V), all in float (probably ______ 0.0). If either number is negative the remainder is negative. If both are positive or both are negative the remainder is _ positive. An error occurs if V is zero: PSL Manual 7 February 1983 Arithmetic Functions section 5.3 page 5.5 ***** Attempt to divide by 0 in REMAINDER Remainder Mod Remainder Mod Note that the Remainder function differs from the Mod function in Remainder Remainder _ _ that Remainder returns a negative number when U is negative and V is positive. Sub1 Sub1 _ ______ ______ ____ (Sub1 U:number): number expr _ _ _____ Returns the value of U minus 1. If U is a float, the value _ returned is U minus 1.0. Times Times _ ______ ______ _____ (Times [U:number]): number macro Times Times Returns the product of all its arguments. Times may be called with only one argument. In this case it returns the value of its Times Times argument. If Times is called with no arguments, it returns 1. Times2 Times2 _ ______ _ ______ ______ ____ (Times2 U:number V:number): number expr _ _ Returns the product of U and V. 5.4. Functions for Numeric Comparison 5.4. Functions for Numeric Comparison 5.4. Functions for Numeric Comparison The following functions compare the values of their arguments. For functions testing equality (or non-equality) see Section 4.2.1. Geq Geq _ ___ _ ___ _______ ____ (Geq U:any V:any): boolean expr _ _ Returns T if U >= V, otherwise returns NIL. In RLISP, the symbol ">=" can be used. GreaterP GreaterP _ ______ _ ______ _______ ____ (GreaterP U:number V:number): boolean expr _ _ Returns T if U is strictly greater than V, otherwise returns NIL. In RLISP, the symbol ">" can be used. Leq Leq _ ______ _ ______ _______ ____ (Leq U:number V:number): boolean expr _ _ Returns T if U <= V, otherwise returns NIL. In RLISP, the symbol "<=" can be used. Arithmetic Functions 7 February 1983 PSL Manual page 5.6 section 5.4 LessP LessP _ ______ _ ______ _______ ____ (LessP U:number V:number): boolean expr _ _ Returns T if U is strictly less than V, otherwise returns NIL. In RLISP, the symbol "<" can be used. Max Max _ ______ ______ _____ (Max [U:number]): number macro _ Returns the largest of the values in U (numeric maximum). If two or more values are the same, the first is returned. Max2 Max2 _ ______ _ ______ ______ ____ (Max2 U:number V:number): number expr _ _ _ _ Returns the larger of U and V. If U and V are of the same value _ _ _ U is returned (U and V might be of different types). Min Min _ ______ ______ _____ (Min [U:number]): number macro _ Returns the smallest (numeric minimum) of the values in U. If two or more values are the same, the first of these is returned. Min2 Min2 _ ______ _ ______ ______ ____ (Min2 U:number V:number): number expr _ _ Returns the smaller of its arguments. If U and V are the same _ _ _ value, U is returned (U and V might be of different types). MinusP MinusP _ ___ _______ ____ (MinusP U:any): boolean expr _ ______ _ ______ Returns T if U is a number and less than 0. If U is not a number ______ or is a positive number, NIL is returned. OneP OneP _ ___ _______ ____ (OneP U:any): boolean expr _ ______ Returns T if U is a number and has the value 1 or 1.0. Returns NIL otherwise. ZeroP ZeroP _ ___ _______ ____ (ZeroP U:any): boolean expr _ ______ Returns T if U is a number and has the value 0 or 0.0. Returns NIL otherwise. PSL Manual 7 February 1983 Arithmetic Functions section 5.5 page 5.7 5.5. Bit Operations 5.5. Bit Operations 5.5. Bit Operations The functions described in this section operate on the binary _______ representation of the integers given as arguments. The returned value is _______ an integer. LAnd LAnd _ _______ _ _______ _______ ____ (LAnd U:integer V:integer): integer expr And And Bitwise or logical And. Each bit of the result is independently determined from the corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 0 0 1 LOr LOr _ _______ _ _______ _______ ____ (LOr U:integer V:integer): integer expr Or Or Bitwise or logical Or. Each bit of the result is independently determined from corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 1 1 1 LNot LNot _ _______ _______ ____ (LNot U:integer): integer expr Not Not _ ______ Logical Not. Defined as (-U + 1) so that it works for bignums as if they were 2's complement. [??? need to clarify a bit more ???] [??? need to clarify a bit more ???] [??? need to clarify a bit more ???] LXOr LXOr _ _______ _ _______ _______ ____ (LXOr U:integer V:integer): integer expr Or Or Bitwise or logical exclusive Or. Each bit of the result is independently determined from the corresponding bits of the operands according to the following table. _ U 0 0 1 1 _ V 0 1 0 1 Returned Value 0 1 1 0 LShift LShift _ _______ _ _______ _______ ____ (LShift N:integer K:integer): integer expr _ _ Shifts N to the left by K bits. The effect is similar to Arithmetic Functions 7 February 1983 PSL Manual page 5.8 section 5.5 _ K _ multiplying by 2 . It is an arithmetic shift. Negative values _ are acceptable for K, and cause a right shift (in the usual manner). 5.6. Various Mathematical Functions 5.6. Various Mathematical Functions 5.6. Various Mathematical Functions The optionally loadable MATHLIB module defines several commonly used mathematical functions. Some effort has been made to be compatible with Common Lisp, but this implementation tends to support fewer features. The examples used here should be taken with a grain of salt, since the precision of the results will depend on the machine being used, and may change in later implementations of the module. Ceiling Ceiling _ ______ _______ ____ (Ceiling X:number): integer expr _______ _ Returns the smallest integer greater than or equal to X. For example: 1 lisp> (ceiling 2.1) 3 2 lisp> (ceiling -2.1) -2 Floor Floor _ ______ _______ ____ (Floor X:number): integer expr _ Returns the largest integer less than or equal to X. (Note that Fix Fix this differs from the Fix function.) 1 lisp> (floor 2.1) 2 2 lisp> (floor -2.1) -3 3 lisp> (fix -2.1) -2 Round Round _ ______ _______ ____ (Round X:number): integer expr 1 _ Returns the nearest integer to X. _______________ 1 Round Round The behavior of Round is ambiguous when its argument ends in ".5"--needs more work. PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.9 TransferSign TransferSign _ ______ ___ ______ ______ ____ (TransferSign S:number Val:number): number expr abs _ ___ abs ___ _ Transfers the sign of S to VAL by returning abs(VAL) if S >= 0, abs sign abs ___ sign and -abs(VAL) otherwise. (The same as FORTRANs sign function.) Mod Mod _ _______ _ _______ _______ ____ (Mod M:integer N:integer): integer expr remainder _ _ remainder Returns M modulo N. Unlike the remainder function, it returns a _ _ _ _ _ positive number in the range 0..N-1 when N is positive, even if M is negative. 1 lisp> (mod -7 5) 3 2 lisp> (remainder -7 5) -2 [??? Allow to "number" arguments instead of just "integers"? [??? Allow to "number" arguments instead of just "integers"? [??? Allow to "number" arguments instead of just "integers"? ???] ???] ???] DegreesToRadians DegreesToRadians _ ______ ______ ____ (DegreesToRadians X:number): number expr Returns an angle in radians given an angle in degrees. 1 lisp> (DegreesToRadians 180) 3.1415926 RadiansToDegrees RadiansToDegrees _ ______ ______ ____ (RadiansToDegrees X:number): number expr Returns an angle in degrees given an angle in radians. 1 lisp> (RadiansToDegrees 3.1415926) 180.0 RadiansToDMS RadiansToDMS _ ______ ____ ____ (RadiansToDMS X:number): list expr _ _______ Given an angle X in radians, returns a list of three integers giving the angle in (Degrees Minutes Seconds) . 1 lisp> (RadiansToDMS 1.0) (57 17 45) Arithmetic Functions 7 February 1983 PSL Manual page 5.10 section 5.6 DMStoRadians DMStoRadians ____ ______ ____ ______ ____ ______ ______ ____ (DMStoRadians Degs:number Mins:number Secs:number): number expr Returns an angle in radians, given three arguments representing an angle in degrees minutes and seconds. 1 lisp> (DMStoRadians 57 17 45) 1.0000009 2 lisp> (DMStoRadians 180 0 0) 3.1415926 DegreesToDMS DegreesToDMS _ ______ ____ ____ (DegreesToDMS X:number): list expr _ _______ Given an angle X in degrees, returns a list of three integers giving the angle in (Degrees Minutes Seconds). DMStoDegrees DMStoDegrees ____ ______ ____ ______ ____ ______ ______ ____ (DMStoDegrees Degs:number Mins:number Secs:number): number expr Returns an angle in degrees, given three arguments representing an angle in degrees minutes and seconds. Sin Sin _ ______ ______ ____ (Sin X:number): number expr sine sine _ Returns the sine of X, an angle in radians. SinD SinD _ ______ ______ ____ (SinD X:number): number expr sine sine _ Returns the sine of X, an angle in degrees. Cos Cos _ ______ ______ ____ (Cos X:number): number expr cosine cosine _ Returns the cosine of X, an angle in radians. CosD CosD _ ______ ______ ____ (CosD X:number): number expr cosine cosine _ Returns the cosine of X, an angle in degrees. Tan Tan _ ______ ______ ____ (Tan X:number): number expr tangent tangent _ Returns the tangent of X, an angle in radians. TanD TanD _ ______ ______ ____ (TanD X:number): number expr tangent tangent _ Returns the tangent of X, an angle in degrees. PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.11 Cot Cot _ ______ ______ ____ (Cot X:number): number expr cotangent cotangent _ Returns the cotangent of X, an angle in radians. CotD CotD _ ______ ______ ____ (CotD X:number): number expr cotangent cotangent _ Returns the cotangent of X, an angle in degrees. Sec Sec _ ______ ______ ____ (Sec X:number): number expr secant secant _ Returns the secant of X, an angle in radians. secant(X) = 1/cos(X) SecD SecD _ ______ ______ ____ (SecD X:number): number expr secant secant _ Returns the secant of X, an angle in degrees. Csc Csc _ ______ ______ ____ (Csc X:number): number expr cosecant cosecant _ Returns the cosecant of X, an angle in radians. secant(X) = 1/sin(X) CscD CscD _ ______ ______ ____ (CscD X:number): number expr cosecant cosecant _ Returns the cosecant of X, an angle in degrees. Asin Asin _ ______ ______ ____ (Asin X:number): number expr arc sine arc sine _ Returns the arc sine, as an angle in radians, of X. sin(asin(X)) = X AsinD AsinD _ ______ ______ ____ (AsinD X:number): number expr arc sine arc sine _ Returns the arc sine, as an angle in degrees, of X. Arithmetic Functions 7 February 1983 PSL Manual page 5.12 section 5.6 Acos Acos _ ______ ______ ____ (Acos X:number): number expr arc cosine arc cosine _ Returns the arc cosine, as an angle in radians, of X. cos(acos(X)) = X AcosD AcosD _ ______ ______ ____ (AcosD X:number): number expr arc cosine arc cosine _ Returns the arc cosine, as an angle in degrees, of X. Atan Atan _ ______ ______ ____ (Atan X:number): number expr arc tangent arc tangent _ Returns the arc tangent, as an angle in radians, of X. tan(atan(X)) = X AtanD AtanD _ ______ ______ ____ (AtanD X:number): number expr arc tangent arc tangent _ Returns the arc tangent, as an angle in degrees, of X. Atan2 Atan2 _ ______ _ ______ ______ ____ (Atan2 Y:number X:number): number expr Returns an angle in radians corresponding to the angle between _ _ _ the X axis and the vector (X,Y). (Note that Y is the first argument.) 1 lisp> (atan2 0 -1) 3.1415927 Atan2D Atan2D _ ______ _ ______ ______ ____ (Atan2D Y:number X:number): number expr Returns an angle in degrees corresponding to the angle between _ _ the X axis and the vector (X,Y). 1 lisp> (atan2D -1 1) 315.0 Acot Acot _ ______ ______ ____ (Acot X:number): number expr arc cotangent arc cotangent _ Returns the arc cotangent, as an angle in radians, of X. cot(acot(X)) = X PSL Manual 7 February 1983 Arithmetic Functions section 5.6 page 5.13 AcotD AcotD _ ______ ______ ____ (AcotD X:number): number expr arc cotangent arc cotangent _ Returns the arc cotangent, as an angle in degrees, of X. Asec Asec _ ______ ______ ____ (Asec X:number): number expr arc secant arc secant _ Returns the arc secant, as an angle in radians, of X. sec(asec(X)) = X AsecD AsecD _ ______ ______ ____ (AsecD X:number): number expr arc secant arc secant _ Returns the arc secant, as an angle in degrees, of X. Acsc Acsc _ ______ ______ ____ (Acsc X:number): number expr arc cosecant arc cosecant _ Returns the arc cosecant, as an angle in radians, of X. csc(acsc(X)) = X AcscD AcscD _ ______ ______ ____ (AcscD X:number): number expr arc cosecant arc cosecant _ Returns the arc cosecant, as an angle in degrees, of X. Sqrt Sqrt _ ______ ______ ____ (Sqrt X:number): number expr _ Returns the square root of X. Exp Exp _ ______ ______ ____ (Exp X:number): number expr _ X _ _ Returns the exponential of X, i.e. e . Log Log _ ______ ______ ____ (Log X:number): number expr _ _ Returns the natural (base e) logarithm of X. log(exp(X)) = X Arithmetic Functions 7 February 1983 PSL Manual page 5.14 section 5.6 Log2 Log2 _ ______ ______ ____ (Log2 X:number): number expr _ Returns the base two logarithm of X. Log10 Log10 _ ______ ______ ____ (Log10 X:number): number expr _ Returns the base ten logarithm of X. Random Random _ _______ _______ ____ (Random N:integer): integer expr Returns a pseudo-random number uniformly selected from the range _ 0..N-1. The random number generator uses a linear congruential method. To get a reproducible sequence of random numbers you should assign one (or some other small number) to the FLUID variable RANDOMSEED. __________ ______ RANDOMSEED [Initially: set from time] global Factorial Factorial _ _______ _______ ____ (Factorial N:integer): integer expr _ Returns the factorial of N. factorial(0) = 1 factorial(N) = N*factorial(N-1) |
Added psl-1983/lpt/06-ids.lpt version [7fc7d2f684].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Identifiers section 6.0 page 6.1 CHAPTER 6 CHAPTER 6 CHAPTER 6 IDENTIFIERS IDENTIFIERS IDENTIFIERS 6.1. Introduction . . . . . . . . . . . . . . . 6.1 6.2. Fields of Ids . . . . . . . . . . . . . . . 6.2 6.3. Identifiers and the Id-Hash-Table . . . . . . . . 6.2 6.3.1. Identifier Functions . . . . . . . . . . 6.3 6.3.2. Find. . . . . . . . . . . . . . . . 6.4 6.4. Property List Functions. . . . . . . . . . . . 6.5 6.4.1. Functions for Flagging Ids . . . . . . . . 6.6 6.4.2. Direct Access to the Property Cell. . . . . . 6.7 6.5. Value Cell Functions. . . . . . . . . . . . . 6.7 6.6. Package System Functions . . . . . . . . . . . 6.10 6.7. System Global Variables, Switches and Other "Hooks" . . 6.13 6.7.1. Introduction . . . . . . . . . . . . . 6.13 6.7.2. Setting Switches. . . . . . . . . . . . 6.14 6.7.3. Special Global Variables . . . . . . . . . 6.15 6.7.4. Special Put Indicators. . . . . . . . . . 6.15 6.7.5. Special Flag Indicators . . . . . . . . . 6.16 6.7.6. Displaying Information About Globals . . . . . 6.16 6.1. Introduction 6.1. Introduction 6.1. Introduction __________ __ __________ In PSL variables are called identifiers or ids. An identifier is implemented as a tagged data object (described in Chapter 4) containing a __ _____ pointer or offset into a five item structure - the id space. One item in this structure is called the print name, which is the external __ representation of the id. __ ____ _____ The interpreter uses an id hash table to get from the print name of an __________ __ _____ __ _____ __ ____ identifier to its entry in the id space. The id space and the id hash _____ table are described below. Sometimes there is a need for more than one name space when one is building a large system. For example, one may wish to allow several programmers to each produce a part of a system without having to worry about name conflicts. PSL provides a package system for this purpose, __ ____ _____ giving the user a tree-structured id hash table. Identifiers 7 February 1983 PSL Manual page 6.2 section 6.2 6.2. Fields of Ids 6.2. Fields of Ids 6.2. Fields of Ids __ ____ ____ ____ An id is an item with an info field; the info field is an offset into a __ _____ ____ special id space consisting of structures of 5 fields. The fields (items) are: _____ ____ ______ print-name The print name points at a string of characters which is the __________ external representation of the identifier. The syntax for __________ identifiers is described in Section 12.5 on reading functions. ________ ____ property-cell One may want to associate various flags and properties with __________ an identifier. These can be stored on a property-list for __ an id, flags by name and properties by an (indicator . __ value) pair. The property cell of an id contains a pointer to this list. Access is by means of functions defined in Section 6.4. _____ ____ __________ value-cell The value of the identifier or a pointer to the value in the heap is stored in this field. If no value exists, this cell __________ contains an unbound identifier indicator. These cells can be accessed by functions defined in this chapter. _____ _____ _____ macro ________ ____ ________ macro function-cell An id may have a function or macro associated with it. PutD GetD RemD PutD GetD RemD Access is by means of the PutD, GetD, and RemD functions defined in Section 10.1.2. _______ ____ package-cell PSL permits the use of a multiple package facility (multiple __ ____ _____ id hash table). The package cell refers to the appropriate __ ____ _____ id hash table. 6.3. Identifiers and the Id hash table 6.3. Identifiers and the Id hash table 6.3. Identifiers and the Id hash table __________ The method used by PSL to retrieve information about an identifier makes __ ____ _____ use of the id hash table (corresponding to the Oblist, or Object list, in __________ some versions of LISP). A hash function is applied to the identifier name __ ____ _____ giving a position in the id hash table. The contents of the hash table at __ _____ __________ that point contain an offset into the id space. For a new identifier, the __ _____ next free position in the id space is found and a pointer to it is placed in the hash table entry. __ The process of putting an id into the hash table is called interning. __ This is done automatically by the LISP reader, so any id typed in at the terminal is interned. Interning can also be done by the programmer using Intern Intern ______ __ __ the function Intern to convert a string to an id. An id may have an entry __ _____ in the id space without being interned. In fact it is possible to have __ several ids with the same print name, one interned and the others not. __ (The use of the package system allows one to have several interned ids with the same print name.) __ _____ Note that when one starts PSL, the id space already contains __ approximately 2000 ids. These include all of the ASCII characters, the functions and globals described in this manual, plus system functions and PSL Manual 7 February 1983 Identifiers section 6.3 page 6.3 globals. If a user uses any of these names for his own functions or globals, there can be a conflict. This is another reason for having a package system. A warning message appears if a user tries to redefine a system function. ? Do you really want to redefine the system function 'name? (Y or N) If the user answers "Y", his definition replaces the current definition. ________ (See Chapter 10 for a description of the switch !*USERMODE which controls the printing of this message.) __ ____ _____ Basic PSL currently provides a single id hash table. PSL provides all the "hooks" to permit a package system to be loaded as an option; certain functions are redefined in this process. If the package system is loaded, __ ____ _____ a tree-structured id hash table can be created in which each level can be __ ____ _____ __ ______ thought of as a smaller id hash table. If a new id or string is to be interned, it is searched for in the tree according to a specified rule. For more information see Section 6.6. __ Information on converting ids to other types can be found in Chapter 12 and Section 4.3. 6.3.1. Identifier Functions 6.3.1. Identifier Functions 6.3.1. Identifier Functions __________ __ ____ _____ The following functions deal with identifiers and the id hash table. GenSym GenSym __ ____ (GenSym ): id expr __________ Creates an identifier which is not interned on the id hash table Eq Eq __ and consequently not Eq to anything else. The id is derived from a string of the form "G0000", which is incremented upon each call GenSym GenSym to GenSym. [??? Is this interned or recorded on the NIL package ???] [??? Is this interned or recorded on the NIL package ???] [??? Is this interned or recorded on the NIL package ???] [??? Can we change the GenSym string ???] [??? Can we change the GenSym string ???] [??? Can we change the GenSym string ???] InternGenSym InternGenSym __ ____ (InternGenSym ): id expr GenSym GenSym __ Similar to GenSym but returns an interned id. StringGenSym StringGenSym ______ ____ (StringGenSym ): string expr GenSym GenSym ______ Similar to GenSym but returns a string of the form "L0000" __ instead of an id. Identifiers 7 February 1983 PSL Manual page 6.4 section 6.3 RemOb RemOb _ __ _ __ ____ (RemOb U:id): U:id expr _ If U is present on the current package search path it is removed. _ This does not affect U having properties, flags, functions and _ the like. U is returned. InternP InternP _ __ ______ _______ ____ (InternP U:{id,string}): boolean expr _ Returns T if U is interned in the current search path. MapObl MapObl _____ ________ _________ ____ (MapObl FNAME:function): Undefined expr MapObl MapObl _____ __ MapObl applies function FNAME to each id interned in the current hash table. 6.3.2. Find 6.3.2. Find 6.3.2. Find ______ __ __ ____ These functions take a string or id as an argument, and scan the id hash _____ __ table to collect a list of ids with prefix or suffix matching the argument. This is a loadable option (LOAD FIND). FindPrefix FindPrefix ___ __ ______ __ ____ ____ (FindPrefix KEY:{id, string}): id-list expr __ ____ _____ __ ___ Scans current id hash table for all ids whose prefix matches KEY. Returns all the identifiers found as an alphabetically sorted list. FindSuffix FindSuffix ___ __ ______ __ ____ ____ (FindSuffix KEY:{id, string}): id-list expr __ ____ _____ __ ___ Scans current id hash table for all ids whose suffix matches KEY. Returns all the identifiers found as an alphabetically sorted list. (Setq X (FindPrefix '!*) % Finds all identifiers starting with * (Setq Y (FindSuffix "STRING")) % Finds all identifiers ending with S 6.4. Property List Functions 6.4. Property List Functions 6.4. Property List Functions __________ ____ ____ The property cell of an identifier points to a "property list". The list __ is used to quickly associate an id name with a set of entities; those __ entities are called "flags" if their use gives the id a boolean value, and __ "properties" if the id is to have an arbitrary attribute (an indicator with a property). PSL Manual 7 February 1983 Identifiers section 6.4 page 6.5 Put Put _ __ ___ __ ____ ___ ___ ____ (Put U:id IND:id PROP:any): any expr ___ ____ The indicator IND with the property PROP is placed on the Put ____ __ _ Put property list of the id U. If the action of Put occurs, the ____ _ ___ __ value of PROP is returned. If either of U and IND are not ids the type mismatch error occurs and no property is placed. (Put 'Jim 'Height 68) The above returns 68 and places (Height . 68) on the property __ list of the id Jim. Get Get _ __ ___ __ ___ ____ (Get U:id IND:id): any expr ___ Returns the property associated with indicator IND from the ____ _ _ ___ property list of U. If U does not have indicator IND, NIL is Get Get Get Get returned. (In older LISPs, Get could access functions.) Get _ __ returns NIL if U is not an id. (Get 'Jim 'Height) returns 68 DefList DefList _ ____ ___ __ ____ ____ (DefList U:list IND:id): list expr _ U is a list in which each element is a two-element list: __ __ ____ ___ __ _ ___ (ID:ID PROP:ANY). Each id in U has the indicator IND with Put Put property PROP placed on its property list by the Put function. DefList DefList ____ The value of DefList is a list of the first elements of each Put DefList Put DefList two-element list. Like Put, DefList may not be used to define functions. (DE DEFLIST (U IND) (COND ((NULL U) NIL) (T (CONS(PROGN(PUT (CAAR U) IND (CADAR U)) (CAAR U)) (DEFLIST (CDR U) IND))))) RemProp RemProp _ __ ___ __ ___ ____ (RemProp U:id IND:id): any expr ___ ____ Removes the property with indicator IND from the property list of _ U. Returns the removed property or NIL if there was no such indicator. RemPropL RemPropL _ __ ____ ___ __ ___ ____ (RemPropL U:id-list IND:id): NIL expr ___ __ _ Remove property IND from all ids in U. Identifiers 7 February 1983 PSL Manual page 6.6 section 6.4 6.4.1. Functions for Flagging Ids 6.4.1. Functions for Flagging Ids 6.4.1. Functions for Flagging Ids __ In some LISPs, flags and indicators may clash. In PSL, flags are ids and ____ properties are pairs on the prop-list, so no clash occurs. Flag Flag _ __ ____ _ __ ___ ____ (Flag U:id-list V:id): NIL expr Flag Flag Flag __ _ _ Flag Flag flags each id in U with V; that is, the effect of Flag is FlagP __ _ _ FlagP _ that for each id X in U, FlagP(X, V) has the value T. Both V and _ __________ all the elements of U must be identifiers or the type mismatch Flag Flag __ _ error occurs. After Flagging, the id V appears on the property __ _ list of each id X in U. However, flags cannot be accessed, placed on, or removed from property lists using normal property Get Put RemProp Get Put RemProp list functions Get, Put, and RemProp. Note that if an error Flag Flag __ _ occurs during execution of Flag, then some of the ids on U may be _ flagged with V, and others may not be. The statement below causes the flag "Lose" to be placed on the property lists of the __ ids X and Y. (Flag '(X Y) 'Lose) FlagP FlagP _ __ _ __ _______ ____ (FlagP U:id V:id): boolean expr _ _ Returns T if U has been flagged with V; otherwise returns NIL. _ _ __ Returns NIL if either U or V is not an id. RemFlag RemFlag _ __ ____ _ __ ___ ____ (RemFlag U:id-list V:id): NIL expr _ ____ Removes the flag V from the property list of each member of the ____ _ _ _ __ list U. Both V and all the elements of U must be ids or the type mismatch error occurs. Flag1 Flag1 _ __ _ ___ _________ ____ (Flag1 U:id V:any): Undefined expr _ __ _ Puts flag V on the property list of id U. RemFlag1 RemFlag1 _ __ _ ___ _________ ____ (RemFlag1 U:id V:any): Undefined expr _ __ _ Removes the flag V from the property list of id U. [??? Make Flag1 and RemFlag1 return single value. ???] [??? Make Flag1 and RemFlag1 return single value. ???] [??? Make Flag1 and RemFlag1 return single value. ???] PSL Manual 7 February 1983 Identifiers section 6.4 page 6.7 6.4.2. Direct Access to the Property Cell 6.4.2. Direct Access to the Property Cell 6.4.2. Direct Access to the Property Cell Use of the following functions can destroy the integrity of the property ____ list. Since PSL uses properties at a low level, care should be taken in the use of these functions. Prop Prop _ __ ___ ____ (Prop U:id): any expr ____ _ Returns the property list of U. SetProp SetProp _ __ _ ___ _ ___ ____ (SetProp U:id L:any): L:any expr _ ____ _ Store item L as the property list of U. 6.5. Value Cell Functions 6.5. Value Cell Functions 6.5. Value Cell Functions Eval Eval The contents of the value cell are usually accessed by Eval (Chapter 11) ValueCell Set SetQ ValueCell Set SetQ or ValueCell (below) and changed by Set or SetQ. Set Set ___ __ _____ ___ ___ ____ (Set EXP:id VALUE:any): any expr ___ __________ EXP must be an identifier or a type mismatch error occurs. The Set Set effect of Set is replacement of the item bound to the identifier _____ by VALUE. If the identifier is not a LOCAL variable or has not been declared GLOBAL, it is automatically declared FLUID with the resulting warning message: *** EXP declared FLUID ___ EXP must not evaluate to T or NIL or an error occurs: ***** Cannot change T or NIL SetQ SetQ ________ __ _____ ___ ___ _____ (SetQ VARIABLE:id VALUE:any): any fexpr ________ The value of the current binding of VARIABLE is replaced by the _____ value of VALUE. (SETQ X 1) is equivalent to (SET 'X 1) SetQ SetQ SetQ now conforms to the Common LISP standard, allowing sequential assignment: Identifiers 7 February 1983 PSL Manual page 6.8 section 6.5 (SETQ A 1 B 2) ==> (SETQ A 1) (SETQ B 2) DeSetQ DeSetQ _ ___ _ ___ _ ___ _____ (DeSetQ U:any V:any): V:any macro DeSetQ DeSetQ This is a function in "USEFUL" (Load USEFUL; in RLISP). DeSetQ SetQ SetQ is a destructuring SetQ. That is, the first argument is a piece SetQ ____ ____ __ SetQ of list structure whose atoms are all ids. Each is SetQ'd to the corresponding part of the second argument. For instance (DeSetQ (a (b) . c) '((1) (2) (3) 4)) SetQ SetQ SetQ's a to (1), b to 2, and c to ((3) 4). PSetQ PSetQ ________ __ _____ ___ _________ _____ (PSetQ [VARIABLE:id VALUE:any]): Undefined macro Part of the USEFUL package (LOAD USEFUL). (PSETQ VAR1 VAL1 VAR2 VAL2 ... VARn VALn) SetQ SetQ SetQ's the VAR's to the corresponding VAL's. The VAL's are all evaluated before any assignments are made. That is, this is a SetQ SetQ parallel SetQ. SetF SetF ___ ____ ___ ___ ___ ___ _____ (SetF [LHS:form RHS:any]): RHS:any macro SetF SetF SetF SetF There are two versions of SetF. SetF is redefined on loading SetF SetF SetF SetF USEFUL. The description below is for the resident SetF. SetF provides a method for assigning values to expressions more __ general than simple ids. For example: (SETF (CAR X) 2) ==> CAR X := 2; is equivalent to (RPLACA X 2) SetF SetF In general, SetF has the form (SetF LHS RHS) ___ ___ in which LHS is the "left hand side" to be assigned to and RHS is ___ evaluated to the value to be assigned. LHS can be one of the following: SetQ __ SetQ id SetQ is used to assign a value to the PSL Manual 7 February 1983 Identifiers section 6.5 page 6.9 __ id. Eval Set SetQ Eval Set SetQ (Eval expression) Set is used instead of SetQ. In Eval Eval effect, the "Eval" cancels out the Quote Quote "Quote" which would normally be used. Value Eval Value Eval (Value expression) Is treated the same as Eval. Car RplacA Car ____ RplacA (Car pair) RplacA is used to store into the Car "field". Cdr RplacD Cdr ____ RplacD (Cdr pair) RplacD is used to store into the Cdr "field". GetV PutV GetV ______ PutV (GetV vector) PutV is used to store into the appropriate location. Indx SetIndx Indx SetIndx (Indx "indexable object") SetIndx is used to store into the object. Sub SetSub Sub ______ SetSub (Sub vector) SetSub is used to store into the appropriate subrange of the vector. Car Cdr SetF ___ Car ____ Cdr ____ SetF Note that if the LHS is (Car pair) or (Cdr pair), SetF returns SetF RplacA ___ SetF RplacA the modified pair instead of the RHS, because SetF uses RplacA RplacD RplacD and RplacD in these cases. SetF Caar Cadr SetF Caar Cadr Loading USEFUL brings in declarations to SetF about Caar, Cadr, Cddddr Cddddr ... Cddddr. This is rather handy with constructor/selector Cadadr Cadadr macros. For instance, if FOO is a selector which maps to Cadadr, (SETF (FOO X) Y) works; that is, it maps to something which does a (RPLACA (CDADR X) Y) and then returns X. PSetF PSetF ___ ____ ___ ___ _________ _____ (PSetF [LHS:form RHS:any]): Undefined macro PSetF SetF PSetF SetF Part of the USEFUL package (LOAD USEFUL). PSetF does a SetF in ___ parallel: i.e. it evaluates all the right hand sides (RHS) before ___ assigning any to the left hand sides (LHS). MakeUnBound MakeUnBound _ __ _________ ____ (MakeUnBound U:id): Undefined expr _ __ Make U an unbound id by storing a "magic" number in the value cell. ValueCell ValueCell _ __ ___ ____ (ValueCell U:id): any expr __ _ Safe access to the value cell of an id. If U is not an id a type _ mismatch error is signalled; if U is an unbound id, an unbound id Identifiers 7 February 1983 PSL Manual page 6.10 section 6.5 _ error is signalled. Otherwise the current value of U is Value LispVar Value LispVar returned. [See also the Value and LispVar functions, described in Chapter 20, for more direct access]. UnBoundP UnBoundP _ __ _______ ____ (UnBoundP U:id): boolean expr _ Tests whether U has no value. [??? Define and describe General Property LISTs or hash-tables. See [??? Define and describe General Property LISTs or hash-tables. See [??? Define and describe General Property LISTs or hash-tables. See Hcons. ???] Hcons. ???] Hcons. ???] 6.6. Package System Functions 6.6. Package System Functions 6.6. Package System Functions To get the package system (Load Package). An example of the use of this system is at the end of this section. The character "\" is normally reserved in the basic Read-Table (see Chapter 12) to make up multi-part names of the form "PackageName\LocalId". If the package system is loaded, the Intern process starts searching a path in a linked structure from "PackageName", itself an id accessible in the "CurrentPackage". The print-name is still "LocalId", but the additional Prin1 Prin2 Prin1 Prin2 package field in each id records "PackageName". Prin1 and Prin2 are modified to access this field in loading the package system. The root of the tree is the GLOBAL package, indicated by \. If the package system is loaded, the basic id hash table is made into the GLOBAL package. Thus \ID is guaranteed in the root (in fact the pre-existing id hash table). [??? Explain further or at least more clearly. ???] [??? Explain further or at least more clearly. ???] [??? Explain further or at least more clearly. ???] The following fluid variables are managed by the package system. __________ ______ \CURRENTPACKAGE!* [Initially: Global] global This is the start of the search path if interning. \CurrentPackage!* \CurrentPackage!* \CurrentPackage!* is rebound in the token scanner on encountering a "\". __________ ______ \PACKAGENAMES!* [Initially: (Global)] global List of ALL package names currently created. Our current package model uses a set of general path functions that access functions specific to each level of the id hash table tree to do various things: "Localxxxx(s)" and "Pathxxxx(s)" in which "xxxx" is one of InternP, Intern, RemOb, MapObl InternP, Intern, RemOb, MapObl the set (InternP, Intern, RemOb, MapObl). By storing different functions, each package may have a different structure and associated functions. The ______ current implementation of a package uses a vector PSL Manual 7 February 1983 Identifiers section 6.6 page 6.11 [Name Father GetFn PutFn RemFn MapFn] __ stored under the indicator 'Package on the PackageName id. A simple bucket id hash table can also be used for experiments, or the user can build his own. As far as possible, each function checks that a legal package is given before performing the operation. [??? Should we have a package Tag ???] [??? Should we have a package Tag ???] [??? Should we have a package Tag ???] The following functions should be used. \CreatePackage \CreatePackage ____ __ _____________ __ __ ____ (\CreatePackage NAME:id FATHERPACKAGE:id): id expr This creates a convenient size id hash table, generates the functions to manage it for this package, and links the new _____________ package to the FATHERPACKAGE so that path searches for ids are required. \SetPackage \SetPackage ____ __ __ ____ (\SetPackage NAME:id): id expr ______ Selects another package such as GLOBAL\. \PathInternP \PathInternP _ __ ______ _______ ____ (\PathInternP S:{id string}): boolean expr _ Searches from CurrentPackage!* to see if S is interned. \PathIntern \PathIntern _ __ ______ __ ____ (\PathIntern S:{id string}): id expr __ Look up or insert an id. \PathRemob \PathRemob _ __ ______ __ ____ (\PathRemob S:{id string}): id expr Remobs, puts in NIL package. \PathMapObl \PathMapObl _ ________ ___ ____ (\PathMapObl F:function): NIL expr _ __ Applies F to ALL ids in path. \LocalInternP \LocalInternP _ __ ______ _______ ____ (\LocalInternP S:{id string}): boolean expr Searches in CURRENTPACKAGE!*. Identifiers 7 February 1983 PSL Manual page 6.12 section 6.6 \LocalIntern \LocalIntern _ __ ______ __ ____ (\LocalIntern S:{id string}): id expr __ Look up or insert in CURRENTPACKAGE!* (forces ids uninterned in CURRENTPACKAGE!* into CURRENTPACKAGE!*) . \LocalRemob \LocalRemob _ __ ______ __ ____ (\LocalRemob S:{id string}): id expr Remobs, puts in NIL package. \LocalMapObl \LocalMapObl _ ________ ___ ____ (\LocalMapObl F:function): NIL expr _ __ Applies F to ALL ids in (CurrentPackage!*). ______ Note that if a string is used, it CANNOT include the \. Also, since most __ ids are "RAISED" on input, be careful. \PathIntern \PathIntern Current intern, etc. are \PathIntern, etc. Several restrictions are placed on the use of packages when compiled. Since it is a loaded module and not integrated with the basic PSL system, all ids in the compiled package are Interned in Global\ before they are defined. This requires a slightly more complex loading system for packages. Names and function ids which conflict with names in Global\ (or other packages in the path) must be forced into the id hash table of the desired package. The package is compiled WITHOUT the package module loaded. In addition, if a function call must be issued for a function which has been redefined in the package the function name must be changed. When Fasl Fasl PACKAGE has been integrated with Fasl and PSL, it will be sufficient to prefix the function name with the package name (e.g. Global\Print). Currently, one must actually change the function name (e.g. Global!.Print). Other problems in the package system include: a. Single character identifiers are handled specially (i.e. not interned) and therefore may not be used in any packages without doing an explicit intern b. By leaving the the package identifier and '\' off the identifier will place it in the Global\ package instead of the current package c. If an identifier is installed in the Global\ package, then reference to it with another package identifier will return the Global\ value instead of issuing an error Print Print As an example, a small package which redefines the system function Print PSL Manual 7 February 1983 Identifiers section 6.6 page 6.13 is shown. The assumed file name is PrintPack.SL. (De GetFieldFn (Relation Field) (Slotdescslotfn (Cdr (Assoc Field (Dsdescslotalist Getdefstruct Relation))))) (Df Print (Args) (Prog (Fields) (Setq Fields (Get (Car Args) 'Fields)) (Foreach Elem In (Eval (Car Args)) Do (Cons Global!.Print (Foreach Field In Fields Collect (Apply (GetFieldFn (Car Args) Field) ('List Elem))))) (Return (Car Args)))) This package would be compiled as follows (immediately after entering PSL): (Faslout "PrintPackage") (Dskin "PrintPack.SL"$) (Faslend) (Quit) This package would be loaded as follows (immediately after entering PSL): (Load '(Defstruct Package)) (CopyD 'Global!.Print Print) (Progn (\CreatePackage 'PrintPack 'Global) (\SetPAckage 'PrintPack) (LocalIntern 'Print)) (Faslin "PrintPack.B") 6.7. System Global Variables, Switches and Other "Hooks" 6.7. System Global Variables, Switches and Other "Hooks" 6.7. System Global Variables, Switches and Other "Hooks" 6.7.1. Introduction 6.7.1. Introduction 6.7.1. Introduction A number of global variables provide global control of the LISP system, or implement values which are constant throughout execution. Certain options are controlled by switches, with T or NIL properties (e.g. ECHOing as a file is read in); others require a value, such as an integer for the current output base. PSL has the convention (following the REDUCE/RLISP convention) of using a "!*" in the name of the variable: !*XXXXX for GLOBAL variables expecting a T/NIL value (called "switches"), and XXXXX!* for other GLOBALs. Chapter 26 is an index of switches and global variables used in PSL. Identifiers 7 February 1983 PSL Manual page 6.14 section 6.7 [??? These should all be FLUIDs, so that ANY one of these variables may [??? These should all be FLUIDs, so that ANY one of these variables may [??? These should all be FLUIDs, so that ANY one of these variables may be rebound, as appropriate ???] be rebound, as appropriate ???] be rebound, as appropriate ???] 6.7.2. Setting Switches 6.7.2. Setting Switches 6.7.2. Setting Switches Strictly speaking, XXXX is a switch and !*XXXX is a corresponding global variable that assumes the T/NIL value; both are loosely referred to as switches elsewhere in the manual. On Off On Off The On and Off functions are used to change the values of the variables associated with switches. Some switches contain an s-expression on their 1 property lists under the indicator 'SIMPFG . The s-expression has the form Cond Cond of a Cond list: ((T (action-for-ON)) (NIL (action-for-OFF))) On Off On Off If the 'SIMPFG indicator is present, then the On and Off functions also evaluate the appropriate action in the s-expression. On On _ __ ____ _____ (On [U:id]): None macro _ For each U, the associated !*U variable is set to T. If a "(T GET GET _ (action-for-ON))" clause is found by (GET U 'SIMPFG), the "action" is EVAL'ed. Off Off _ __ ____ _____ (Off [U:id]): None macro _ For each U, the associated !*U variable is set to NIL. If a GET GET _ "(NIL (action-for-OFF)" clause is found by (GET U 'SIMPFG), the "action" is EVAL'ed. (On Comp Ord Usermode) will set !*Comp, !*Ord, and !*Usermode to T. Note that _______________ 1 The name SIMPFG comes from its introduction in the REDUCE algebra system, where it was used as a "simp flag" to specify various simplifications to be performed as various switches were turned on or off. PSL Manual 7 February 1983 Identifiers section 6.7 page 6.15 (Get 'Cref 'Simpfg) returns ((T (Crefon)) (Nil (Crefoff))) ____ ____ Setting CREF on will result in !*CREF being set to T and the function Crefon Crefon Crefon being evaluated. 6.7.3. Special Global Variables 6.7.3. Special Global Variables 6.7.3. Special Global Variables __________ ______ NIL [Initially: NIL] global NIL is a special GLOBAL variable. It is protected from being Set SetQ Set SetQ modified by Set or SetQ. __________ ______ T [Initially: T] global T is a special GLOBAL variable. It is protected from being Set SetQ Set SetQ modified by Set or SetQ. 6.7.4. Special Put Indicators 6.7.4. Special Put Indicators 6.7.4. Special Put Indicators __ Some actions search the property list of relevant ids for these indicators: __ 'HELPFUNCTION An id, a function to be executed to give help about the topic; ideally for a complex topic, a clever function is used. 'HELPSTRING A help string, kept in core for important or short topics. 'HELPFILE The most common case, the name of a file to print; later we hope to load this file into an EMODE buffer for perusal in a window. 'SWITCHINFO A string describing the purpose of the SWITCH, see ShowSwitches ShowSwitches ShowSwitches below. 'GLOBALINFO A string describing the purpose of the GLOBAL, see ShowGlobals ShowGlobals ShowGlobals below. __ 'BREAKFUNCTION Associates a function to be run with an Id typed at Break Loop, see Chapter 14. 'TYPE PSL uses the property TYPE to indicate whether a function is a FEXPR, MACRO, or NEXPR; if no property is present, EXPR is Identifiers 7 February 1983 PSL Manual page 6.16 section 6.7 assumed. 'VARTYPE PSL uses the property VARTYPE to indicate whether an __________ identifier is of type GLOBAL or FLUID. '!*LAMBDALINK The interpreter also looks under '!*LAMBDALINK for a Lambda expression, if a procedure is not compiled. 6.7.5. Special Flag Indicators 6.7.5. Special Flag Indicators 6.7.5. Special Flag Indicators __ 'EVAL If the id is flagged EVAL, the RLISP top-loop evaluates and On Defn __ On Defn outputs any expression (id ...) in On Defn (!*DEFN := T) mode. __ 'IGNORE If the id is flagged IGNORE, the RLISP top-loop evaluates but On Defn __ On Defn does NOT output any expression (id ...) in On Defn (!*DEFN := T) mode. PutD __ PutD 'LOSE If an id has the 'LOSE flag, it will not be defined by PutD when it is read in. 'USER 'USER is put on all functions defined when in !*USERMODE, to distinguish them from "system" functions. See Chapter 10. LoadTime CompileTime LoadTime CompileTime See also the functions LoadTime and CompileTime in Chapter 18. [??? Mention Parser properties ???] [??? Mention Parser properties ???] [??? Mention Parser properties ???] 6.7.6. Displaying Information About Globals 6.7.6. Displaying Information About Globals 6.7.6. Displaying Information About Globals Help Help The Help function has two options, (HELP SWITCHES) and (HELP GLOBALS), which should display the current state of a variety of switches and globals respectively. These calls have the same effect as using the functions below, using an initial table of Switches and Globals. ShowSwitches ShowSwitches The function (ShowSwitches switch-list) may be used to print names, current settings and purpose of some switches. Use NIL as the switch-list ShowSwitches ShowSwitches to get information on ALL switches of interest; ShowSwitches in this case MapObl MapObl does a MapObl (Section 6.3.1) looking for 'SwitchInfo property. ShowGlobals ShowGlobals Similarly, (ShowGlobals global-list) may be used to print names, values and purposes of important GLOBALs. Again, NIL used as the global-list ShowGlobals MapObl ShowGlobals MapObl causes ShowGlobals to do a MapObl looking for a 'GlobalInfo property; the result is some information about all globals of interest. |
Added psl-1983/lpt/07-lists.lpt version [4db5c0a124].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 List Structure section 7.0 page 7.1 CHAPTER 7 CHAPTER 7 CHAPTER 7 LIST STRUCTURE LIST STRUCTURE LIST STRUCTURE 7.1. Introduction to Lists and Pairs . . . . . . . . . 7.1 7.2. Basic Functions on Pairs . . . . . . . . . . . 7.2 7.3. Functions for Manipulating Lists. . . . . . . . . 7.4 7.3.1. Selecting List Elements . . . . . . . . . 7.4 7.3.2. Membership and Length of Lists . . . . . . . 7.6 7.3.3. Constructing, Appending, and Concatenating Lists . 7.6 7.3.4. Lists as Sets. . . . . . . . . . . . . 7.7 7.3.5. Deleting Elements of Lists . . . . . . . . 7.8 7.3.6. List Reversal. . . . . . . . . . . . . 7.9 7.4. Functions for Building and Searching A-Lists. . . . . 7.10 7.5. Substitutions . . . . . . . . . . . . . . . 7.11 7.1. Introduction to Lists and Pairs 7.1. Introduction to Lists and Pairs 7.1. Introduction to Lists and Pairs ____ The pair is a fundamental PSL data type, and is one of the major ____ ____ attractions of LISP programming. A pair consists of a two-item structure. Car Cdr Car Cdr In PSL the first element is called the Car and the second the Cdr; in other LISPs, the physical relationship of the parts may be different. An Car Car illustration of the tree structure is given below as a box diagram; the Car Cdr Cdr and the Cdr are each represented as a portion of the box. ----------------- || Car | Cdr || ----------------- As an example, a tree written as ((A . B) . (C . D)) in dot-notation is drawn below as a box diagram. ----------------- || / | \ || ----/-------\---- / \ ----------------- ----------------- || A | B || || C | D || ----------------- ----------------- The box diagrams are tedious to draw, so dot-notation is normally used. ____ Note that a space is left on each side of the . to ensure that pairs are _____ not confused with floats. Note also that in RLISP a dot may be used as the List Structure 7 February 1983 PSL Manual page 7.2 section 7.1 Cons Cons infix operator for the function Cons, as in the expression x := 'y . 'z;, ____ or as part of the notation for pairs, as in the expression x := '(y . z); (see Section 3.3.3). An important special case occurs frequently enough that it has a special ____ notation. This is a list of items, terminated by convention with the id NIL. The dot and surrounding parentheses are omitted, as well as the trailing NIL. Thus (A . (B . (C . NIL))) can be represented in list-notation as (A B C) 7.2. Basic Functions on Pairs 7.2. Basic Functions on Pairs 7.2. Basic Functions on Pairs ____ The following are elementary functions on pairs. All functions in this Chapter which require pairs as parameters signal a type mismatch error if the parameter given is not a pair. Cons Cons _ ___ _ ___ ____ ____ (Cons U:any V:any): pair expr Eq ____ Eq _ Returns a pair which is not Eq to anything else and has U as its Car Cdr Car _ Cdr Car part and V as its Cdr part. In RLISP syntax the dot, ".", is Cons Cons an infix operator meaning Cons. Thus (A . (B . fn C) . D) is Cons Cons Cons Cons Cons Cons equivalent to Cons (A, Cons (Cons (B, fn C), D)). See Section 3.3.3 for more discussion of how dot is read. Car Car _ ____ ___ ____ ________ ____ (Car U:pair): any open-compiled, expr _ The left part of U is returned. A type mismatch error occurs if _ ____ _ U is not a pair, except when U is NIL. Then NIL is returned. Car Cons Car Cons (Car (Cons a b)) ==> a. Cdr Cdr _ ____ ___ ____ ________ ____ (Cdr U:pair): any open-compiled, expr _ The right part of U is returned. A type mismatch error occurs if _ ____ _ U is not a pair, except when U is NIL. Then NIL is returned. Cdr Cons Cdr Cons (Cdr (Cons a b)) ==> b. Car Cdr Car Cdr The composites of Car and Cdr are supported up to four levels. PSL Manual 7 February 1983 List Structure section 7.2 page 7.3 Car Cdr Car Cdr Car Cdr Caar Cdar Cadr Cddr Caar Cdar Cadr Cddr Caar Cdar Cadr Cddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaar Cdaar Cadar Cddar Caadr Cdadr Caddr Cdddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Caaaar Cadaar Caadar Caddar Caaadr Cadadr Caaddr Cadddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr Cdaaar Cddaar Cdadar Cdddar Cdaadr Cddadr Cdaddr Cddddr ____ ____ ____ expr expr These are all exprs of one argument. They may return any type and are generally open-compiled. An example of their use is that Cddar Cdr Cdr Car Car Cdr Cddar Cdr Cdr Car Car Cdr Cddar p is equivalent to Cdr Cdr Car p. As with Car and Cdr, a type mismatch error occurs if the argument does not possess the specified component. As an alternative to employing chains of CxxxxR to obscure depths, ____ particularly in extracting elements of a list, consider the use of the First Second Third Fourth Nth First Second Third Fourth Nth functions First, Second, Third, Fourth, or Nth (Section 7.3.1), or possibly even the Defstruct package (Section 17.6). NCons NCons _ ___ ____ ____ ________ ____ (NCons U:any): pair open-compiled, expr Cons Cons _ Equivalent to Cons (U, NIL). XCons XCons _ ___ _ ___ ____ ____ ________ ____ (XCons U:any V:any): pair open-compiled, expr Cons Cons _ _ Equivalent to Cons (V, U). Copy Copy _ ___ ___ ____ (Copy X:any): any expr ____ _ Copies all pairs in X, but does not make copies of atoms (including vectors and strings). For example, if A is ([2 5] "ATOM") and B is the result of (Copy A), then (Eq A B) is NIL but (Eq (Car A) (Car B)) is T and (Eq (Cadr A) (Cadr B)) is T TotalCopy Copy TotalCopy Copy See TotalCopy in Section 8.5. Note that Copy is recursive and will not terminate if its argument is a circular list. See Chapter 8 for other relevant functions. The following functions are known as "destructive" functions, because they change the structure of the pair given as their argument, and consequently change the structure of the object containing the pair. They are most frequently used for various "efficient" functions (e.g. the List Structure 7 February 1983 PSL Manual page 7.4 section 7.2 ReverseIP NConc DeleteIP ReverseIP NConc DeleteIP non-copying ReverseIP and NConc functions, and destructive DeleteIP) and to build structures that have deliberately shared sub-structure. They are also capable of creating circular structures, which create havoc with careful careful normal printing and list traversal functions. Be careful using them. RplacA RplacA _ ____ _ ___ ____ ____ ________ ____ (RplacA U:pair V:any): pair open-compiled, expr Car Car _ _ _ The Car of the pair U is replaced by V, and the modified U is _ _ returned. (If U is (a . b) then (V .b) is returned). A type _ mismatch error occurs if U is not a pair. RplacD RplacD _ ____ _ ___ ____ ____ ________ ____ (RplacD U:pair V:any): pair open-compiled, expr Cdr Cdr _ _ _ The Cdr of the pair U is replaced by V, and the modified U is _ _ returned. (If U is (a . b) then (a . V) is returned). A type _ mismatch error occurs if U is not a pair. RplacW RplacW _ ____ _ ____ ____ ____ (RplacW A:pair B:pair): pair expr Car Car Car _ Car Replaces the whole pair: the Car of A is replaced with the Car Cdr Cdr _ Cdr _ Cdr _ _ of B, and the Cdr of A with the Cdr of B. The modified A is returned. [??? Should we add some more functions here someday? Probably the [??? Should we add some more functions here someday? Probably the [??? Should we add some more functions here someday? Probably the RLISP guys that do arbitrary depth member type stuff. ???] RLISP guys that do arbitrary depth member type stuff. ???] RLISP guys that do arbitrary depth member type stuff. ???] 7.3. Functions for Manipulating Lists 7.3. Functions for Manipulating Lists 7.3. Functions for Manipulating Lists ____ ____ The following functions are meant for the special pairs which are lists, as described in Section 7.1. Note that the functions described in Chapter 8 can also be used on lists. [??? Make some mention of mapping with FOR...COLLECT and such like. [??? Make some mention of mapping with FOR...COLLECT and such like. [??? Make some mention of mapping with FOR...COLLECT and such like. ???] ???] ???] 7.3.1. Selecting List Elements 7.3.1. Selecting List Elements 7.3.1. Selecting List Elements First First _ ____ ___ _____ (First L:pair): any macro Car Car _ A synonym for Car L. PSL Manual 7 February 1983 List Structure section 7.3 page 7.5 Second Second _ ____ ___ _____ (Second L:pair): any macro Cadr Cadr _ A synonym for Cadr L. Third Third _ ____ ___ _____ (Third L:pair): any macro Caddr Caddr _ A synonym for Caddr L. Fourth Fourth _ ____ ___ _____ (Fourth L:pair): any macro Cadddr Cadddr _ A synonym for Cadddr L. Rest Rest _ ____ ___ _____ (Rest L:pair): any macro Cdr Cdr _ A synonym for Cdr L. LastPair LastPair _ ____ ___ ____ (LastPair L:pair): any expr ____ ____ Last pair of a list. It is often useful to think of this as a pointer to the last element for use with destructive functions RplacA RplacA _ such as RplacA. Note that if L is atomic a type mismatch error occurs. (De LastPair (L) (Cond ((Null (Rest L)) L) (T (LastPair (Rest L))))) LastCar LastCar _ ___ ___ ____ (LastCar L:any): any expr ____ _ Returns the last element of the list L. A type mismatch error First LastPair _ First LastPair _ results if L is not a list. Equivalent to First LastPair L. Nth Nth _ ____ _ _______ ___ ____ (Nth L:pair N:integer): any expr ____ _ _ Returns the Nth element of the list L. If L is atomic or _ contains fewer than N elements, an out of range error occurs. First PNth First PNth Equivalent to (First (PNth L N)). PNth PNth _ ____ _ _______ ___ ____ (PNth L:list N:integer): any expr ____ ____ _ Returns list starting with the Nth element of a list L. Note that it is often useful to view this as a pointer to the Nth RplacA _ RplacA element of L for use with destructive functions such as RplacA. _ _ If L is atomic or contains fewer than N elements, an out of range error occurs. List Structure 7 February 1983 PSL Manual page 7.6 section 7.3 (De PNth (L N) (Cond ((Leq N 1) L) (T (PNth (Cdr L) (Sub1 N))))) 7.3.2. Membership and Length of Lists 7.3.2. Membership and Length of Lists 7.3.2. Membership and Length of Lists Member Member _ ___ _ ____ _____ _______ ____ (Member A:any L:list): extra-boolean expr Equal _ Equal ____ Returns NIL if A is not Equal to some top level element of list _ _ L; otherwise it returns the remainder of L whose first element is _ A. (De Member (A L) (Cond((Null L) Nil) ((Equal A (First L)) L) (T (Member A (Rest L))))) MemQ MemQ _ ___ _ ____ _____ _______ ____ (MemQ A:any B:list): extra-boolean expr Member Eq Member Eq Same as Member, but an Eq check is used for comparison. (De Memq (A L) (Cond((Null L) Nil) ((Eq A (First L)) L) (T (Memq A (Rest L))))) Length Length _ ___ _______ ____ (Length X:any): integer expr ____ _ The top level length of the list X is returned. (De Length (X) (Cond((Atom X) 0) (T (Plus (Length X) 1)))) 7.3.3. Constructing, Appending, and Concatenating Lists 7.3.3. Constructing, Appending, and Concatenating Lists 7.3.3. Constructing, Appending, and Concatenating Lists List List _ ___ ____ _____ (List [U:any]): list fexpr ____ ____ Construct a list of the evaluated arguments. A list of the _ evaluation of each element of U is returned. Append Append _ ____ _ ____ ____ ____ (Append U:list V:list): list expr ____ _ Returns a constructed list in which the last element of U is _ ____ _ _ followed by the first element of V. The list U is copied, but V PSL Manual 7 February 1983 List Structure section 7.3 page 7.7 is not. (De Append (U V) (Cond ((Null U) V) (T (Cons (Car U) (Append (Cdr U) V))))) NConc NConc _ ____ _ ____ ____ ____ (NConc U:list V:list): list expr Append Append _ _ Destructive version of Append. Concatenates V to U without Cdr _ Cdr _ _ copying U. The last Cdr of U is modified to point to V. See the warning on page 7.3 about the use of destructive functions. (De Nconc (U V) (Cond ((Null U) V) (T (Rplacd (Lastcdr U V))))) AConc AConc _ ____ _ ___ ____ ____ (AConc U:list V:any): list expr _ ____ _ Destructively adds element V to the tail of list U. LConc LConc ___ ____ ____ ____ ____ ____ (LConc PTR:list ELEM:list): list expr NConc NConc Effectively NConc, but avoids scanning from the front to the end RPLACD ___ RPLACD ___ ____ of PTR for the RPLACD(PTR, ELEM) by maintaining a pointer to end LastPair ____ ___ ___ ____ LastPair ____ of the list PTR. PTR is (list . LastPair list). Returns updated ___ ___ PTR. PTR should be initialized to NIL . NIL before calling the ____ first time. Used to build lists from left to right. TConc TConc ___ ____ ____ ___ ____ ____ (TConc PTR:list ELEM:any): list expr AConc AConc Effectively AConc, but avoids scanning from the front to the end RPLACD List ___ RPLACD ___ List ____ of PTR for the RPLACD(PTR, List(ELEM)) by maintaining a pointer LastPair ____ ___ ___ ____ LastPair ____ to end of the list PTR. PTR is (list . LastPair list). Returns ___ ___ updated PTR. PTR should be initialized to NIL . NIL before ____ calling the first time. Used to build lists from left to right. 7.3.4. Lists as Sets 7.3.4. Lists as Sets 7.3.4. Lists as Sets ____ A set is a list in which each element occurs only once. Order of elements does not matter, so these functions may not preserve order. Adjoin Adjoin _______ ___ ___ ____ ____ ____ (Adjoin ELEMENT:any SET:list): list expr Equal _______ ___ Equal Add ELEMENT to SET if it is not already on the top level. Equal is used to test for equality. List Structure 7 February 1983 PSL Manual page 7.8 section 7.3 AdjoinQ AdjoinQ _______ ___ ___ ____ ____ ____ (AdjoinQ ELEMENT:any SET:list): list expr Adjoin Eq Adjoin Eq _______ ___ Adjoin using Eq for the test whether ELEMENT is already in SET. Union Union _ ____ _ ____ ____ ____ (Union X:list Y:list): list expr Set union. UnionQ UnionQ _ ____ _ ____ ____ ____ (UnionQ X:list Y:list): list expr Eq Union Eq Union Eq version of Union. InterSection InterSection _ ____ _ ____ ____ ____ (InterSection U:list V:list): list expr Set intersection. InterSectionQ InterSectionQ _ ____ _ ____ ____ ____ (InterSectionQ U:list V:list): list expr Eq InterSection Eq InterSection Eq version of InterSection. List2Set List2Set ___ ____ ____ ____ (List2Set SET:list): list expr Equal ___ Equal Remove redundant elements from the top level of SET using Equal. List2SetQ List2SetQ ___ ____ ____ ____ (List2SetQ SET:list): list expr Eq ___ Eq Remove redundant elements from the top level of SET using Eq. 7.3.5. Deleting Elements of Lists 7.3.5. Deleting Elements of Lists 7.3.5. Deleting Elements of Lists xxxIP xxx xxxIP xxx Note that functions with names of the form xxxIP indicate that xxx is done InPlace. Delete Delete _ ___ _ ____ ____ ____ (Delete U:any V:list): list expr _ _ Returns V with the first top level occurrence of U removed from _ _ it. That portion of V before the first occurrence of U is copied. (De Delete (U V) (Cond((Null V) Nil) ((Equal (First V) U) (Rest V)) (T (Cons (First V) (Delete U (Rest V)))))) PSL Manual 7 February 1983 List Structure section 7.3 page 7.9 Del Del _ ________ _ ___ _ ____ ____ ____ (Del F:function U:any V:list): list expr Delete Delete _ Generalized Delete function with F as the comparison function. DeletIP DeletIP _ ___ _ ____ ____ ____ (DeletIP U:any V:list): list expr Delete RplacD Delete _ RplacD _ Destructive Delete; modifies V using RplacD. Do not depend on V ____ itself correctly referring to list. DelQ DelQ _ ___ _ ____ ____ ____ (DelQ U:any V:list): list expr Eq _ _ Eq Delete U from V, using Eq for comparison. DelQIP DelQIP _ ___ _ ____ ____ ____ (DelQIP U:any V:list): list expr DelQ DeletIP DelQ DeletIP Destructive version of DelQ; see DeletIP. DelAsc DelAsc _ ___ _ _ ____ _ ____ ____ (DelAsc U:any V:a-list): a-list expr _ _ Remove first (U . xxx) from V. DelAscIP DelAscIP _ ___ _ _ ____ _ ____ ____ (DelAscIP U:any V:a-list): a-list expr DelAsc DelAsc Destructive DelAsc. DelatQ DelatQ _ ___ _ _ ____ _ ____ ____ (DelatQ U:any V:a-list): a-list expr Eq _ _ Eq _ Delete first (U . xxx) from V, using Eq to check equality with U. DelatQIP DelatQIP _ ___ _ _ ____ _ ____ ____ (DelatQIP U:any V:a-list): a-list expr DelatQ DelatQ Destructive DelatQ. 7.3.6. List Reversal 7.3.6. List Reversal 7.3.6. List Reversal Reverse Reverse _ ____ ____ ____ (Reverse U:list): list expr _ Returns a copy of the top level of U in reverse order. List Structure 7 February 1983 PSL Manual page 7.10 section 7.3 (De Reverse (U) (Prog (W) (While U (ProgN (Setq W (Cons (Car U) W)) (Setq U (Cdr U)))) (Return W))) ReversIP ReversIP _ ____ ____ ____ (ReversIP U:list): list expr Reverse Reverse Destructive Reverse. 7.4. Functions for Building and Searching A-Lists 7.4. Functions for Building and Searching A-Lists 7.4. Functions for Building and Searching A-Lists Assoc Assoc _ ___ _ _ ____ ____ ___ ____ (Assoc U:any V:a-list): {pair, NIL} expr Car _ Car _ ____ _ If U occurs as the Car portion of an element of the a-list V, the ____ _ pair in which U occurred is returned, else NIL is returned. Assoc Assoc _ ____ Assoc might not detect a poorly formed a-list so an invalid Car Cdr Car Cdr construction may be detected by Car or Cdr. (De Assoc (U V) (Cond ((Null V) Nil) ((Atom (Car V)) (Error 000 (List V "is a poorly formed alis ((Equal U (Caar V)) (Car V)) (T (Assoc U (Cdr V))))) Atsoc Atsoc __ ___ __ ___ ___ ____ (Atsoc R1:any R2:any): any expr Car Eq Eq Assoc __ ____ Car Eq __ Eq Assoc Scan R2 for pair with Car Eq R1. Eq version of Assoc. Ass Ass _ ________ _ ___ _ _ ____ ____ ___ ____ (Ass F:function U:any V:a-list): {pair, NIL} expr Ass Assoc Ass Assoc _ Ass is a generalized Assoc function. F is the comparison function. SAssoc SAssoc _ ___ _ _ ____ __ ________ ___ ____ (SAssoc U:any V:a-list FN:function): any expr _ ____ _ _ _ Searches the a-list V for an occurrence of U. If U is not in the _ ____ __ a-list, the evaluation of function FN is returned. PSL Manual 7 February 1983 List Structure section 7.4 page 7.11 (De SAssoc (U V FN) (Cond ((Null V) (FN)) ((Equal U (Caar V)) (Car V)) (T (SAssoc U (Cdr V) FN)))) Pair Pair _ ____ _ ____ _ ____ ____ (Pair U:list V:list): a-list expr _ _ ____ U and V are lists which must have an identical number of ____ elements. If not, an error occurs. Returned is a list in which Car ____ Car ____ _ each element is a pair, the Car of the pair being from U and the Cdr Cdr _ Cdr being the corresponding element from V. (De Pair (U V) (Cond ((And U V)(Cons (Cons (Car U)(Car V)) (Pair (Cdr U)(Cdr V)))) ((Or U V)(Error 000 "Different length lists i (T Nil))) 7.5. Substitutions 7.5. Substitutions 7.5. Substitutions Subst Subst _ ___ _ ___ _ ___ ___ ____ (Subst U:any V:any W:any): any expr _ _ Returns the result of substituting U for all occurrences of V in _ _ _ W. Copies all of W which is not replaced by U. The test used is Equal Equal Equal. (De Subst (U V W) (Cond ((Null W) Nil) ((Equal V W) U) ((Atom W) W) (T (Cons (Subst U V (Car W))(Subst U V (Cdr SubstIP SubstIP _ ___ _ ___ _ ___ ___ ____ (SubstIP U:any V:any W:any): any expr Subst Subst Destructive Subst. SubLis SubLis _ _ ____ _ ___ ___ ____ (SubLis X:a-list Y:any): any expr Subst Subst This performs a series of Substs in parallel. The value returned Cdr Cdr is the result of substituting the Cdr of each element of the Car _ ____ _ Car a-list X for every occurrence of the Car part of that element in _ Y. List Structure 7 February 1983 PSL Manual page 7.12 section 7.5 (De SubLis (X Y) (Cond ((Null X) Y) (T (Prog (U) (Setq U (Assoc Y X)) (Return (Cond (U (Cdr U)) ((Atom Y) Y) (T (Cons (SubLis X (Car Y)) (SubLis X (Cdr Y)) SublA SublA _ _ ____ _ ___ ___ ____ (SublA U:a-list V:any): any expr Eq SubLis Eq SubLis Eq version of SubLis; replaces atoms only. |
Added psl-1983/lpt/08-strings.lpt version [2e547e9c39].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Strings and Vectors section 8.0 page 8.1 CHAPTER 8 CHAPTER 8 CHAPTER 8 STRINGS AND VECTORS STRINGS AND VECTORS STRINGS AND VECTORS 8.1. Vector-Like Objects . . . . . . . . . . . . . 8.1 8.2. Strings . . . . . . . . . . . . . . . . . 8.1 8.3. Vectors . . . . . . . . . . . . . . . . . 8.3 8.4. Word Vectors . . . . . . . . . . . . . . . 8.5 8.5. General X-Vector Operations . . . . . . . . . . 8.5 8.6. Arrays . . . . . . . . . . . . . . . . . 8.7 8.7. Common LISP String Functions . . . . . . . . . . 8.7 8.1. Vector-Like Objects 8.1. Vector-Like Objects 8.1. Vector-Like Objects ______ ______ ____ ______ ________ ______ In this Chapter, LISP strings, vectors, word-vectors, halfword-vectors, ____ ______ and byte-vectors are described. Each may have several elements, accessed _______ by an integer index. For convenience, members of this set are referred to _ ______ _ ______ ____ as x-vectors. X-vector functions also apply to lists. Currently, the Size UpB _ ______ Size UpB index for x-vectors ranges from 0 to an upper limit, called the Size or UpB Size _ ______ Size ______ (upper bound). Thus an x-vector X has 1 + Size(X) elements. Strings index ______ from 0 because they are considered to be packed vectors of bytes. Bytes are 7 bits on the DEC-20 and 8 bits on the VAX. ______ ____ ______ ____ ______ ____ [??? Note that with new integer tagging, strings are "packed" words, [??? Note that with new integer tagging, strings are "packed" words, [??? Note that with new integer tagging, strings are "packed" words, ______ ______ ______ which are special cases of vectors. Should we add byte-vectors too, so which are special cases of vectors. Should we add byte-vectors too, so which are special cases of vectors. Should we add byte-vectors too, so ______ ______ ______ that strings are different print mode of byte vector ???] that strings are different print mode of byte vector ???] that strings are different print mode of byte vector ???] [??? Size should probably be replaced by UPLIM or UPB. ???] [??? Size should probably be replaced by UPLIM or UPB. ???] [??? Size should probably be replaced by UPLIM or UPB. ???] In RLISP syntax, X[i]; may be used to access the i'th element of an _ ______ x-vector, and X[i]:=y; is used to change the i'th element to y. These Indx SetIndx Indx SetIndx functions correspond to the LISP functions Indx and SetIndx. [??? Change names to GetIndex, PutIndex ???] [??? Change names to GetIndex, PutIndex ???] [??? Change names to GetIndex, PutIndex ???] For functions which change an object from one data type to another, see Section 4.3. 8.2. Strings 8.2. Strings 8.2. Strings ______ ______ A string is currently thought of as a Byte vector, or a packed integer ______ ______ vector, with elements that are ASCII characters. A string has a header containing its length and perhaps a tag. The next M words contain the 0 ... Size characters, packed as appropriate, terminated with at least 1 ______ ______ NULL. On the DEC-20, this means that strings have an ASCIZ string starting Strings and Vectors 7 February 1983 PSL Manual page 8.2 section 8.2 in the second word. (ASCIZ strings are NULL terminated.) Make!-String Make!-String ____ _______ _______ _______ ______ ____ (Make!-String SIZE:integer INITVAL:integer): string expr ______ ____ Constructs and returns a string with SIZE characters, each _______ initialized to the ASCII code INITVAL. MkString MkString _____ _______ _______ _______ ______ ____ (MkString UPLIM:integer INITVAL:integer): string expr Make!-String Make!-String An old form of Make!-String. Returns a string of characters all _______ _____ initialized to INITVAL, with upper bound UPLIM. So, the returned _____ _ string contains a total of UPLIM + 1 characters. String String ____ _______ ______ _____ (String [ARGS:integer]): string nexpr ______ ____ Create string of elements from a list of ARGS. [??? Should we check each arg in 0 ... 127. What about 128 [??? Should we check each arg in 0 ... 127. What about 128 [??? Should we check each arg in 0 ... 127. What about 128 - 255 with 8 bit vectors? ???] - 255 with 8 bit vectors? ???] - 255 with 8 bit vectors? ???] (String 65 66 67) returns "ABC" CopyStringToFrom CopyStringToFrom ___ ______ ___ ______ ___ ______ ____ (CopyStringToFrom NEW:string OLD:string): NEW:string expr ___ ___ Copy all characters from OLD into NEW. This function is destructive. CopyString CopyString _ ______ ______ ____ (CopyString S:string): string expr ______ Copy to new heap string, allocating space. [??? Should we add GetS, PutS, UpbS, etc ???] [??? Should we add GetS, PutS, UpbS, etc ???] [??? Should we add GetS, PutS, UpbS, etc ???] When processing strings it is frequently necessary to be able to specify a particular character. In PSL a character is just its ASCII code representation, but it is difficult to remember the code, and the use of Char Char codes does not add to the readability of programs. One can use the Char __ macro, defined in Chapter 20. It expects a single character id as argument and returns the ASCII code of that character. For example (Char A) returns 65 (Char !a) returns 97 (Char !@) returns 64 PSL Manual 7 February 1983 Strings and Vectors section 8.2 page 8.3 Note that to get lower-case a one must precede the a by "!", otherwise the a will be raised. See also the sharp-sign macros in Chapter 17. 8.3. Vectors 8.3. Vectors 8.3. Vectors ______ ____ A vector is a structured entity in which random item elements may be _______ ______ accessed with an integer index. A vector has a single dimension. Its maximum size is determined by the implementation and available space. A ______ suggested input/output "vector notation" is defined (see Chapter 12). GetV GetV _ ______ _____ _______ ___ ____ (GetV V:vector INDEX:integer): any expr _____ ______ _ Returns the value stored at position INDEX of the vector V. The _____ type mismatch error may occur. An error occurs if the INDEX does UPBV UPBV _ not lie within 0 ... (UPBV V) inclusive: ***** INDEX subscript is out of range _ _____ A similar effect may be obtained in RLISP by using V[INDEX];. MkVect MkVect _____ _______ ______ ____ (MkVect UPLIM:integer): vector expr ______ _____ Defines and allocates space for a vector with UPLIM + 1 elements _____ accessed as 0 ... UPLIM. Each element is initialized to NIL. If _____ UPLIM is -1, an empty vector is returned. An error occurs if _____ ______ UPLIM is < -1 or if there is not enough space for a vector of this size: ***** A vector of size UPLIM cannot be allocated Make!-Vector Make!-Vector _____ _______ _______ ___ ______ ____ (Make!-Vector UPLIM:integer INITVAL:any): vector expr MkVect MkVect _______ Like MkVect but each element is initialized to INITVAL. PutV PutV _ ______ _____ _______ _____ ___ ___ ____ (PutV V:vector INDEX:integer VALUE:any): any expr _____ ______ _ _____ _____ Stores VALUE in the vector V at position INDEX. VALUE is _____ returned. The type mismatch error may occur. If INDEX does not UPBV UPBV _ lie in 0 ... UPBV(V), an error occurs: ***** INDEX subscript is out of range A similar effect can be obtained in RLISP by typing in _ _____ _____ V[INDEX]:=VALUE;. It is important to use square brackets, i.e. "[]". Strings and Vectors 7 February 1983 PSL Manual page 8.4 section 8.3 UpbV UpbV _ ___ ___ _______ ____ (UpbV U:any): {NIL, integer} expr _ _ ______ Returns the upper limit of U if U is a vector, or NIL if it is not. Vector Vector ____ ___ ______ _____ (Vector [ARGS:any]): vector nexpr ______ ____ ____ ______ Create vector of elements from list of ARGS. The vector has N Size Size ____ elements, i.e. Size = N - 1, in which N is the number of ARGS. CopyVectorToFrom CopyVectorToFrom ___ ______ ___ ______ ___ ______ ____ (CopyVectorToFrom NEW:vector OLD:vector): NEW:vector expr Move elements, don't recurse. [ ???Check size compatibility? ] [ ???Check size compatibility? ] [ ???Check size compatibility? ] CopyVector CopyVector _ ______ ______ ____ (CopyVector V:vector): vector expr ______ Copy to new vector in heap. The following functions can be used after the FAST!-VECTOR module has been loaded (LOAD FAST!-VECTOR). IGetV IGetV _ ______ _____ _______ ___ ____ ________ ____ (IGetV V:vector INDEX:integer): any open-compiled, expr GetV GetV Used the same way as GetV. IPutV IPutV _ ______ _____ _______ _____ ___ ___ ____ ________ ____ (IPutV V:vector INDEX:integer VALUE:any): any open-compiled, expr PutV PutV Fast version of PutV. ISizeV ISizeV _ ___ ___ _______ ____ ________ ____ (ISizeV U:any): {NIL,integer} open-compiled, expr UpbV UpbV Fast version of UpbV. ISizeS ISizeS _ _ ______ _______ ____ ________ ____ (ISizeS X:x-vector): integer open-compiled, expr Size Size Fast version of Size. IGetS IGetS _ _ ______ _ _______ ___ ____ ________ ____ (IGetS X:x-vector I:integer): any open-compiled, expr Indx Indx Fast version of Indx. PSL Manual 7 February 1983 Strings and Vectors section 8.3 page 8.5 IPutS IPutS _ _ ______ _ _______ _ ___ ___ ____ ________ ____ (IPutS X:x-vector I:integer A:any): any open-compiled, expr SetIndx SetIndx Fast version of SetIndx. 8.4. Word Vectors 8.4. Word Vectors 8.4. Word Vectors ____ ______ _ _______ Word-vectors or w-vectors are vector-like structures, in which each element is a "word" sized, untagged entity. This can be thought of as a ______ ______ special case of fixnum vector, in which the tags have been removed. Make!-Words Make!-Words _____ _______ _______ _______ ____ ______ ____ (Make!-Words UPLIM:integer INITVAL:integer): Word-Vector expr ____ ______ _____ Defines and allocates space for a Word-Vector with UPLIM + 1 _______ elements, each initialized to INITVAL. Make!-Halfwords Make!-Halfwords _____ _______ _______ _______ ________ ______ ____ (Make!-Halfwords UPLIM:integer INITVAL:integer): Halfword-Vector expr ________ ______ _____ Defines and allocates space for a Halfword-vector with UPLIM + 1 _______ elements, each initialized to INITVAL. Make!-Bytes Make!-Bytes _____ _______ _______ _______ ____ ______ ____ (Make!-Bytes UPLIM:integer INITVAL:integer): Byte-vector expr ____ ______ _____ Defines and allocates space for a Byte-Vector with UPLIM + 1 _______ elements, each initialized to INITVAL. [??? Should we convert elements to true integers when accessing ???] [??? Should we convert elements to true integers when accessing ???] [??? Should we convert elements to true integers when accessing ???] [??? Should we add GetW, PutW, UpbW, etc ???] [??? Should we add GetW, PutW, UpbW, etc ???] [??? Should we add GetW, PutW, UpbW, etc ???] 8.5. General X-Vector Operations 8.5. General X-Vector Operations 8.5. General X-Vector Operations Size Size _ _ ______ _______ ____ (Size X:x-vector): integer expr _ ______ Size (upper bound) of x-vector. Indx Indx _ _ ______ _ _______ ___ ____ (Indx X:x-vector I:integer): any expr _ ______ Access the I'th element of an x-vector. [??? Rename to GetIndex, or some such ???] [??? Rename to GetIndex, or some such ???] [??? Rename to GetIndex, or some such ???] Size _ Size _ Generates a range error if I is outside the range 0 ... Size(X): Strings and Vectors 7 February 1983 PSL Manual page 8.6 section 8.5 ***** Index is out of range SetIndx SetIndx _ _ ______ _ _______ _ ___ ___ ____ (SetIndx X:x-vector I:integer A:any): any expr _ Store an appropriate value, A, as the I'th element of an _ ______ _ x-vector. Generates a range error if I is outside the range Size Size _ 0...Size(X): ***** Index is out of range Sub Sub _ _ ______ __ _______ _ _______ _ ______ ____ (Sub X:x-vector I1:integer S:integer): x-vector expr _ ______ __ Extract a subrange of an x-vector, starting at I1, producing a Size Size _ ______ Size _ ____ _ ______ Size ___ new x-vector of Size S. Note that an x-vector of Size 0 has one entry. SetSub SetSub _ _ ______ __ _______ _ _______ _ _ ______ _ ______ ____ (SetSub X:x-vector I1:integer S:integer Y:x-vector): x-vector expr _ _ _ __ _ Store subrange of Y of size S into X starting at I1. Returns Y. SubSeq SubSeq _ _ ______ __ _______ __ _______ _ ______ ____ (SubSeq X:x-vector LO:integer HI:integer): x-vector expr Size _ ______ Size __ __ Returns an x-vector of Size HI-LO-1, beginning with the element _ __ _ of X with index LO. In other words, returns the subsequence of X __ ____ ______ __ starting at LO and ending just before HI. For example, (Setq A '[0 1 2 3 4 5 6]) (SubSeq A 4 6) returns [4 5]. SetSubSeq SetSubSeq _ _ ______ __ _______ __ _______ _ _ ______ _ _ ______ ____ (SetSubSeq X:x-vector LO:integer HI:integer Y:x-vector): Y:x-vector expr Size _ Size __ __ Y must be of Size HI-LO-1; it must also be of the same type of _ ______ _ __ __ _ x-vector as X. Elements LO through HI-1 in X are replaced by Size Size _ _ _ _ elements 0 through Size(Y) of Y. Y is returned and X is changed destructively. If A is "0123456" and B is "abcd", then (SetSubSeq A 3 7 B) returns "abcd". A is "012abcd" and B is unchanged. Concat Concat _ _ ______ _ _ ______ _ ______ ____ (Concat X:x-vector Y:x-vector): x-vector expr _ ______ Concatenate 2 x-vectors. Currently they must be of same type. PSL Manual 7 February 1983 Strings and Vectors section 8.5 page 8.7 [??? Should we do conversion to common type ???] [??? Should we do conversion to common type ???] [??? Should we do conversion to common type ???] TotalCopy TotalCopy _ ___ ___ ____ (TotalCopy S:any): any expr Returns a unique copy of entire structure, i.e., it copies everything for which storage is allocated - everything but inums Copy TotalCopy Copy TotalCopy and ids. Like Copy (Chapter 7)TotalCopy will not terminate when applied to circular structures. 8.6. Arrays 8.6. Arrays 8.6. Arrays _____ _____ _____ macro macro Arrays do not exist in PSL as distinct data-types; rather an array macro package is anticipated for declaring and managing multi-dimensional arrays ____ _________ ____ of items, characters and words, by mapping them onto one dimensional vectors. [??? What operations, how to map, and what sort of checking ???] [??? What operations, how to map, and what sort of checking ???] [??? What operations, how to map, and what sort of checking ???] 8.7. Common LISP String Functions 8.7. Common LISP String Functions 8.7. Common LISP String Functions A Common LISP compatible package of string and character functions has been implemented in PSL, obtained by LOADing the STRINGS module. The following functions are defined from Chapters 13 and 14 of the Common LISP Char String Char String manual [Steele 81]. Char and String are not defined because of PSL functions with the same name. Common LISP provides a character data type in which every character object has three attributes: code, bits, and font. The bits attribute allows extra flags to be associated with a character. The font attribute permits a specification of the style of the glyphs (such as italics). PSL does not support nonzero bit and font attributes. Because of this some of the Common LISP character functions described below have no affect or are not very useful as implemented in PSL. They are present for compatibility. Recall that in PSL a character is represented as its code, a number in the range 0...127. For an argument to the following character functions Char Char give the code or use the Char function or the sharp-sign macros in Chapter 17. Standard!-CharP Standard!-CharP _ _________ _______ ____ (Standard!-CharP C:character): boolean expr Returns T if the argument is a "standard character", that is, one of the ninety-five ASCII printing characters or <return>. Strings and Vectors 7 February 1983 PSL Manual page 8.8 section 8.7 (Standard-CharP (Char A)) returns T (Standard-CharP (Char !^A)) returns NIL GraphicP GraphicP _ _________ _______ ____ (GraphicP C:character): boolean expr _ Returns T if C is a printable character and NIL if it is a non-printable (formatting or control) character. The space character is assumed to be graphic. String!-CharP String!-CharP _ _________ _______ ____ (String!-CharP C:character): boolean expr _ Returns T if C is a character that can be an element of a string. Standard-Charp Graphicp Standard-Charp Graphicp Any character that satisfies Standard-Charp and Graphicp also String-Charp String-Charp satisfies String-Charp. AlphaP AlphaP _ _________ _______ ____ (AlphaP C:character): boolean expr _ Returns T if C is an alphabetic character. UpperCaseP UpperCaseP _ _________ _______ ____ (UpperCaseP C:character): boolean expr _ Returns T if C is an upper case letter. LowerCaseP LowerCaseP _ _________ _______ ____ (LowerCaseP C:character): boolean expr _ Returns T if C is a lower case letter. BothCaseP BothCaseP _ _________ _______ ____ (BothCaseP C:character): boolean expr AlphaP AlphaP In PSL this function is the same as AlphaP. DigitP DigitP _ _________ _______ ____ (DigitP C:character): boolean expr _ Returns T if C is a digit character (optional radix not supported). AlphaNumericP AlphaNumericP _ _________ _______ ____ (AlphaNumericP C:character): boolean expr _ Returns T if C is a digit or an alphabetic. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.9 Char!= Char!= __ _________ __ _________ _______ ____ (Char!= C1:character C2:character): boolean expr __ __ Returns T if C1 and C2 are the same in all three attributes. Char!-Equal Char!-Equal __ _________ __ _________ _______ ____ (Char!-Equal C1:character C2:character): boolean expr __ __ Returns T if C1 and C2 are similar. Differences in case, bits, or font are ignored by this function. Char!< Char!< __ _________ __ _________ _______ ____ (Char!< C1:character C2:character): boolean expr __ __ Returns T if C1 is strictly less than C2. Char!> Char!> __ _________ __ _________ _______ ____ (Char!> C1:character C2:character): boolean expr __ __ Returns T if C1 is strictly greater than C2. Char!-LessP Char!-LessP __ _________ __ _________ _______ ____ (Char!-LessP C1:character C2:character): boolean expr Char!< Char!< Like Char!< but ignores differences in case, fonts, and bits. Char!-GreaterP Char!-GreaterP __ _________ __ _________ _______ ____ (Char!-GreaterP C1:character C2:character): boolean expr Char!> Char!> Like Char!> but ignores differences in case, fonts, and bits. Char!-Code Char!-Code _ _________ _________ ____ (Char!-Code C:character): character expr _ Returns the code attribute of C. In PSL this function is an identity function. Char!-Bits Char!-Bits _ _________ _______ ____ (Char!-Bits C:character): integer expr _ Returns the bits attribute of C, which is always 0 in PSL. Char!-Font Char!-Font _ _________ _______ ____ (Char!-Font C:character): integer expr _ Returns the font attribute of C, which is always 0 in PSL. Code!-Char Code!-Char _ _______ _________ ___ ____ (Code!-Char I:integer): {character,nil} expr The purpose of this function is to be able to construct a character by specifying the code, bits, and font. Because bits Code!-Char Code!-Char and font attributes are not used in PSL, Code!-Char is an Strings and Vectors 7 February 1983 PSL Manual page 8.10 section 8.7 identity function. Character Character _ _________ ______ __ _________ ____ (Character C:{character, string, id}): character expr _ _ _ Attempts to coerce C to be a character. If C is a character, C _ is returned. If C is a string, then the first character of the _ string is returned. If C is a symbol, the first character of the symbol is returned. Otherwise an error occurs. Char!-UpCase Char!-UpCase _ _________ _________ ____ (Char!-UpCase C:character): character expr LowerCaseP Char-UpCase LowerCaseP _ Char-UpCase If LowerCaseP(C) is true, then Char-UpCase returns the code of _ _ the upper case of C. Otherwise it returns the code of C. Char!-DownCase Char!-DownCase _ _________ _________ ____ (Char!-DownCase C:character): character expr UpperCaseP Char-DownCase UpperCaseP _ Char-DownCase If UpperCaseP(C) is true, then Char-DownCase returns the code of _ _ the lower case of C. Otherwise it returns the code of C. Digit!-Char Digit!-Char _ _________ _______ ____ (Digit!-Char C:character): integer expr _ _ Converts character to its code if C is a one-digit number. If C _ is larger than one digit, NIL is returned. If C is not numeric, an error message is caused. Char!-Int Char!-Int _ _________ _______ ____ (Char!-Int C:character): integer expr Converts character to integer. This is the identity operation in PSL. Int!-Char Int!-Char _ _______ _________ ____ (Int!-Char I:integer): character expr Converts integer to character. This is the identity operation in PSL. The string functions follow. RplaChar RplaChar _ ______ _ _______ _ _________ _________ ____ (RplaChar S:string I:integer C:character): character expr _ _ _ Store a character C in a string S at position I. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.11 String!= String!= __ ______ __ ______ _______ ____ (String!= S1:string S2:string): boolean expr __ __ Compares two strings S1 and S2, case sensitive. (Substring options not implemented). String!-Equal String!-Equal __ ______ __ ______ _______ ____ (String!-Equal S1:string S2:string): boolean expr __ __ Compare two strings S1 and S2, ignoring case, bits and font. _____ _______ The following string comparison functions are extra-boolean. If the comparison results in a value of T, the first position of inequality in the strings is returned. String!< String!< __ ______ __ ______ _____ _______ ____ (String!< S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!> String!> __ ______ __ ______ _____ _______ ____ (String!> S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!<!= String!<!= __ ______ __ ______ _____ _______ ____ (String!<!= S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!>!= String!>!= __ ______ __ ______ _____ _______ ____ (String!>!= S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!<!> String!<!> __ ______ __ ______ _____ _______ ____ (String!<!> S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case sensitive. String!-LessP String!-LessP __ ______ __ ______ _____ _______ ____ (String!-LessP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-GreaterP String!-GreaterP __ ______ __ ______ _____ _______ ____ (String!-GreaterP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. Strings and Vectors 7 February 1983 PSL Manual page 8.12 section 8.7 String!-Not!-GreaterP String!-Not!-GreaterP __ ______ __ ______ _____ _______ ____ (String!-Not!-GreaterP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Not!-LessP String!-Not!-LessP __ ______ __ ______ _____ _______ ____ (String!-Not!-LessP S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Not!-Equal String!-Not!-Equal __ ______ __ ______ _____ _______ ____ (String!-Not!-Equal S1:string S2:string): extra-boolean expr Lexicographic comparison of strings. Case differences are ignored. String!-Repeat String!-Repeat _ ______ _ _______ ______ ____ (String!-Repeat S:string I:integer): string expr _ _ Appends copy of S to itself total of I-1 times. String!-Trim String!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Trim BAG:{list, string} S:string): string expr ___ _ Remove leading and trailing characters in BAG from a string S. (String-Trim "ABC" "AABAXYZCB") returns "XYZ" (String-Trim (List (Char A) (Char B) (Char C)) "AABAXYZCB") returns "XYZ" (String-Trim '(65 66 67) "ABCBAVXZCC") returns "VXZ" String!-Left!-Trim String!-Left!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Left!-Trim BAG:{list, string} S:string): string expr Remove leading characters from string. String!-Right!-Trim String!-Right!-Trim ___ ____ ______ _ ______ ______ ____ (String!-Right!-Trim BAG:{list, string} S:string): string expr Remove trailing characters from string. String!-UpCase String!-UpCase _ ______ ______ ____ (String!-UpCase S:string): string expr Copy and raise all alphabetic characters in string. PSL Manual 7 February 1983 Strings and Vectors section 8.7 page 8.13 NString!-UpCase NString!-UpCase _ ______ ______ ____ (NString!-UpCase S:string): string expr Destructively raise all alphabetic characters in string. String!-DownCase String!-DownCase _ ______ ______ ____ (String!-DownCase S:string): string expr Copy and lower all alphabetic characters in string. NString!-DownCase NString!-DownCase _ ______ ______ ____ (NString!-DownCase S:string): string expr Destructively lower all alphabetic characters in string. String!-Capitalize String!-Capitalize _ ______ ______ ____ (String!-Capitalize S:string): string expr Copy and raise first letter of all words in string; other letters in lower case. NString!-Capitalize NString!-Capitalize _ ______ ______ ____ (NString!-Capitalize S:string): string expr Destructively raise first letter of all words; other letters in lower case. String!-to!-List String!-to!-List _ ______ ____ ____ (String!-to!-List S:string): list expr Unpack string characters into a list. String!-to!-Vector String!-to!-Vector _ ______ ______ ____ (String!-to!-Vector S:string): vector expr Unpack string characters into a vector. SubString SubString _ ______ __ _______ __ _______ ______ ____ (SubString S:string LO:integer HI:integer): string expr SubSeq SubSeq ______ Same as SubSeq, but the first argument must be a string. Returns Size _ Size __ __ a substring of S of Size HI - LO - 1, beginning with the element __ with index LO. String!-Length String!-Length _ ______ _______ ____ (String!-Length S:string): integer expr Last index of a string, plus one. |
Added psl-1983/lpt/09-flowofcontrol.lpt version [42d9810f23].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Flow Of Control section 9.0 page 9.1 CHAPTER 9 CHAPTER 9 CHAPTER 9 FLOW OF CONTROL FLOW OF CONTROL FLOW OF CONTROL 9.1. Introduction . . . . . . . . . . . . . . . 9.1 9.2. Conditionals . . . . . . . . . . . . . . . 9.1 9.2.1. Conds and Ifs. . . . . . . . . . . . . 9.1 9.2.2. The Case Statement . . . . . . . . . . . 9.3 9.3. Sequencing Evaluation . . . . . . . . . . . . 9.4 9.4. Iteration . . . . . . . . . . . . . . . . 9.7 9.4.1. For . . . . . . . . . . . . . . . . 9.8 9.4.2. Mapping Functions . . . . . . . . . . . 9.13 9.4.3. Do . . . . . . . . . . . . . . . . 9.16 9.5. Non-Local Exits . . . . . . . . . . . . . . 9.18 9.1. Introduction 9.1. Introduction 9.1. Introduction Most of the constructs presented in this Chapter have a special syntax in RLISP. This syntax is presented along with the definitions of the underlying functions. Many of the examples are presented using this special RLISP syntax as well as LISP. 9.2. Conditionals 9.2. Conditionals 9.2. Conditionals 9.2.1. Conds and Ifs 9.2.1. Conds and Ifs 9.2.1. Conds and Ifs Cond Cond _ ____ ____ ___ ____ ________ _____ (Cond [U:form-list]): any open-compiled, fexpr Cond If Cond If The LISP function Cond corresponds to the If statement of most If If programming languages. In RLISP this is simply the familiar If Then Else Then Else ... Then ... Else construct. For example: _________ ______ IF predicate THEN action1 ______ ELSE action2 _________ ______ ==> (COND (predicate action1) ______ (T action2)) ______ _________ Action1 is evaluated if the predicate has a non-NIL evaluation; Else ______ Else otherwise, action2 is evaluated. Dangling Elses are resolved in Then Then the ALGOL manner by pairing them with the nearest preceding Then. For example: Flow Of Control 7 February 1983 PSL Manual page 9.2 section 9.2 IF F(X) THEN IF G(Y) THEN PRINT(X) ELSE PRINT(Y); is equivalent to IF F(X) THEN << IF G(Y) THEN PRINT(X) ELSE PRINT(Y) >>; Note that if F(X) is NIL, nothing is printed. Taken simply as a function, without RLISP syntax, the arguments Cond Cond to Cond have the form: _________ ______ ______ (COND (predicate action action ...) _________ ______ ______ (predicate action action ...) ... _________ ______ ______ (predicate action action ...) ) The predicates are evaluated in the order of their appearance until a non-NIL value is encountered. The corresponding actions are evaluated and the value of the last becomes the value of the Cond Else Cond Else Cond. The dangling Else example above is: (COND ((F X) (COND ((G X) (PRINT X)) ( T (PRINT Y)) ) )) Go Return Go Return The actions may also contain the special functions Go, Return, Exit Next Exit Next Exit, and Next, subject to the constraints on placement of these Cond Cond functions given in Section 9.3. In these cases, Cond does not have a defined value, but rather an effect. If no predicate is Cond Cond non-NIL, the value of Cond is NIL. The following MACROs are defined in the USEFUL module for convenience, and are mostly used from LISP syntax: If If _ ____ __ ____ _ ____ ___ _____ (If E:form S0:form [S:form]): any macro If Cond If Cond If is a macro to simplify the writing of a common form of Cond in which there are only two clauses and the antecedent of the second is T. It cannot be used in RLISP syntax. (IF E S0 S1...Sn) __ _ The then-clause S0 is evaluated if and only if the test E is _ non-NIL, otherwise the else-clauses Si are evaluated, and the last returned. There may be no else-clauses. Related macros for common COND forms are WHEN and UNLESS. PSL Manual 7 February 1983 Flow Of Control section 9.2 page 9.3 When When _ ____ _ ____ ___ _____ (When E:form [S:form]): any macro (WHEN E S1 S2 ... Sn) evaluates the Si and returns the value of Sn if and only if the When _ When test E is non-NIL. Otherwise When returns NIL. Unless Unless _ ____ _ ____ ___ _____ (Unless E:form [U:form]): any macro (UNLESS E S1 S2 ... Sn) _ Evaluates the Si if and only if the test E is NIL. It is equivalent to (WHEN (NOT E) S1 S2 ... Sn) And Or And Or While And and Or are primarily of interest as Boolean connectives, they are often used in LISP as conditionals. For example, (AND (FOO) (BAR) (BAZ)) has the same result as (COND ((FOO) (COND ((BAR) (BAZ))))) See Section 4.2.3. 9.2.2. The Case Statement 9.2.2. The Case Statement 9.2.2. The Case Statement PSL provides a numeric case statement, that is compiled quite efficiently; some effort is made to examine special cases (compact vs. non compact sets of cases, short vs. long sets of cases, etc.). It has mostly been used in SYSLISP mode, but can also be used from LISP mode provided that case-tags are numeric. There is also an FEXPR, CASE, for the interpreter. The RLISP syntax is: Case-Statement ::= CASE expr OF case-list END Case-list ::= Case-expr [; Case-list ] Case-expr ::= Tag-expr : expr tag-expr ::= DEFAULT | OTHERWISE | tag | tag, tag ... tag | tag TO tag Tag ::= Integer | Wconst-Integer Flow Of Control 7 February 1983 PSL Manual page 9.4 section 9.2 For example: CASE i OF 1: Print("First"); 2,3: Print("Second"); 4 to 10: Print("Third"); Default: Print("Fourth"); END The RLISP syntax parses into the following LISP form: Case Case _ ____ _ ____ ____ ___ ____ ________ _____ (Case I:form [U:case-list]): any open-compiled, fexpr _ _______ I is meant to evaluate to an integer, and is used as a selector _ amongst the various Us. Each case-list has the form (case-expr form) where case-expr has the form: NIL -> default case (I1 I2 ... In) -> where each Ik is an integer or (RANGE low high) The above example becomes: (CASE i ((1) (Print "First")) ((2 3) (Print "Second")) (((Range 4 10)) (Print "Third")) ( NIL (Print "Fourth"))) [??? Perhaps we should move SELECTQ (and define a SELECT) from the [??? Perhaps we should move SELECTQ (and define a SELECT) from the [??? Perhaps we should move SELECTQ (and define a SELECT) from the COMMON module to the basic system ???] COMMON module to the basic system ???] COMMON module to the basic system ???] . 9.3. Sequencing Evaluation 9.3. Sequencing Evaluation 9.3. Sequencing Evaluation These functions provide for explicit control sequencing, and the definition of blocks altering the scope of local variables. ProgN ProgN _ ____ ___ ____ ________ _____ (ProgN [U:form]): any open-compiled, fexpr _ U is a set of expressions which are executed sequentially. The value returned is the value of the last expression. PSL Manual 7 February 1983 Flow Of Control section 9.3 page 9.5 Prog2 Prog2 _ ____ _ ____ ___ ____ ________ ____ (Prog2 A:form B:form): any open-compiled, expr _ Returns the value of B (the second argument). [??? Redefine prog2 to take N arguments, return second. ???] [??? Redefine prog2 to take N arguments, return second. ???] [??? Redefine prog2 to take N arguments, return second. ???] Prog1 Prog1 _ ____ ___ _____ (Prog1 [U:form]): any macro Prog1 Prog1 Prog1 is a function defined in the USEFUL package; to use it, Prog1 Prog1 type (LOAD USEFUL). Prog1 evaluates its arguments in order, like ProgN ProgN ProgN, but returns the value of the first. Prog Prog ____ __ ____ _______ __ ____ ___ ____ ________ _____ (Prog VARS:id-list [PROGRAM:{id,form}]): any open-compiled, fexpr Prog ____ ____ __ Prog VARS is a list of ids which are considered FLUID if the Prog is interpreted and LOCAL if compiled (see the "Variables and Prog Prog Bindings" Section, 10.2). The Prog's variables are allocated Prog Prog space if the Prog form is applied, and are deallocated if the Prog Prog Prog Prog Prog is exited. Prog variables are initialized to NIL. The _______ PROGRAM is a set of expressions to be evaluated in order of their Prog Prog __________ appearance in the Prog function. identifiers appearing in the _______ top level of the PROGRAM are labels which can be referred to by Go Prog Go Prog Go. The value returned by the Prog function is determined by a Return Prog Return Prog Return function or NIL if the Prog "falls through". There are restrictions as to where a number of control functions, such as Go Return Go Return Go and Return, may be placed. This is so that they may have only locally determinable effects. Unlike most LISPs, which make this restriction only in compiled code, PSL enforces this restriction uniformly in both compiled and interpreted code. Not only does this help keep the semantics of compiled and interpreted code the same, but we believe it leads to more readable programs. For cases in which a non-local exit is truly required, Catch Throw Catch Throw there are the functions Catch and Throw, described in Section 9.5. Go Return Exit Next Go Return Exit Next The functions so restricted are Go, Return, Exit, and Next. They must be placed at top-level within the surrounding control structure to which they Prog Return Prog Return refer (e.g. the Prog which Return causes to be terminated), or nested within only selected functions. The functions in which they may be nested (to arbitrary depth) are: ProgN ProgN - ProgN (compound statement) Cond Cond - actions of Conds (if then else) Case Case - actions in Cases Go Go _____ __ ____ ________ ____ ________ _____ (Go LABEL:id): None Returned open-compiled, fexpr Go Prog Go Prog Go alters the normal flow of control within a Prog function. The Prog Prog next statement of a Prog function to be evaluated is immediately Go _____ Go preceded by LABEL. A Go may appear only in the following situations: Flow Of Control 7 February 1983 PSL Manual page 9.6 section 9.3 Prog Prog _____ a. At the top level of a Prog referring to a LABEL that also Prog Prog appears at the top level of the same Prog. Cond Cond b. As the action of a Cond item Prog Prog i. appearing on the top level of a Prog. Cond Cond ii. which appears as the action of a Cond item to any level. ProgN ProgN c. As the last statement of a ProgN Prog Prog i. which appears at the top level of a Prog or in a ProgN Cond ProgN Cond ProgN appearing in the action of a Cond to any level subject to the restrictions of b.i, or b.ii. ProgN Cond ProgN ProgN Cond ProgN ii. within a ProgN or as the action of a Cond in a ProgN to any level subject to the restrictions of b.i, b.ii, and c.i. Prog _____ Prog If LABEL does not appear at the top level of the Prog in which Go Go the Go appears, an error occurs: ***** LABEL is not a label within the current scope Go Go If the Go has been placed in a position not defined by rules a-c, another error is detected: ***** Illegal use of GO To LABEL Return Return _ ____ ____ ________ ____ ________ ____ (Return U:form): None Returned open-compiled, expr Prog Return Prog Prog Return Prog Within a Prog, Return terminates the evaluation of a Prog and Prog _ Prog returns U as the value of the Prog. The restrictions on the Return Go Return Go placement of Return are exactly those of Go. Improper placement Return Return of Return results in the error: ***** Illegal use of RETURN 9.4. Iteration 9.4. Iteration 9.4. Iteration While While _ ____ _ ____ ___ _____ (While E:form [S:form]): NIL macro This is the most commonly used construct for indefinite iteration _ _ in LISP. E is evaluated; if non-NIL, the S's are evaluated from _ left to right and then the process is repeated. If E evaluates While Exit While Exit to NIL the While returns NIL. Exit may be used to terminate the PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.7 While Next While Next While from within the body and to return a value. Next may be used to terminate the current iteration. In RLISP syntax this is While Do While Do While ... Do ... . Note that in RLISP syntax there may be only a Do ProgN Do ProgN single expression after the Do; however, it may be a ProgN delimited by <<...>>. That is, (While E S1 S2) should be written in RLISP as While E do <<S1; S2>>; Repeat Repeat _ ____ _ ____ ___ _____ (Repeat E:form [S:form]): NIL macro _ _ The S's are evaluated left to right, and then E is evaluated. Repeat _ Repeat This is repeated until the value of E is NIL, if Repeat returns Next Exit Next Exit _ NIL. Next and Exit may be used in the S's branch to the next Repeat Repeat iteration of a Repeat or to terminate one and possibly return a Go Return Go Return _ value. Go, and Return may appear in the S's. The RLISP syntax Repeat Repeat Until While Repeat Repeat Until While for Repeat is Repeat Until. Like While, RLISP syntax only allows _ a single S, so (REPEAT E S1 S2) should be written in RLISP as REPEAT << S1; S2 >> UNTIL E; [??? maybe do REPEAT S1 ... Sn E ???] [??? maybe do REPEAT S1 ... Sn E ???] [??? maybe do REPEAT S1 ... Sn E ???] Next Next ____ ________ ____ ________ __________ _____ (Next ): None Returned open-compiled, restricted, macro This terminates the current iteration of the most closely While Repeat While Repeat surrounding While or Repeat, and causes the next to commence. See the note in Section 9.3 about the lexical restrictions on GO GO placement of this construct, which is essentially a GO to a special label placed at the front of a loop construct. Exit Exit _ ____ ____ ________ ____ ________ __________ _____ (Exit [U:form]): None Returned open-compiled,restricted, macro _ The U's are evaluated left to right, the most closely surrounding While Repeat While Repeat _ While or Repeat is terminated, and the value of the last U is returned. With no arguments, NIL is returned. See the note in Section 9.3 about the lexical restrictions on placement of this Return Return construct, which is essentially a Return. While Repeat Prog Next Exit While Repeat Prog Next Exit While and Repeat each macro expand into a Prog; Next and Exit are macro Go Return Prog Go Return Prog expanded into a Go and a Return respectively to this Prog. Thus using a Next Exit Prog While Repeat Next Exit Prog While Repeat Next or an Exit within a Prog within a While or Repeat will result only in Flow Of Control 7 February 1983 PSL Manual page 9.8 section 9.4 Prog Prog an exit of the internal Prog. In RLISP be careful to use WHILE E DO << S1;...;EXIT(1);...;Sn>> not WHILE E DO BEGIN S1;...;EXIT(1);...;Sn;END; 9.4.1. For 9.4.1. For 9.4.1. For For For A simple For construct is available in the basic PSL system and RLISP; an extended form can obtained by loading USEFUL. It is planned to make the extended form the version available in the basic system, combining all the FOR ForEach For FOR ForEach For features of FOR and ForEach. The basic PSL For provides only the (FROM ..) ForEach ForEach iterator, and (DO ...) action clause, and uses the ForEach construct for some of the (IN ...) and (ON ...) iterators. Most PSL syntax users should For For use the full For construct. For For _ ____ ___ _____ (For [S:form]): any macro For For The arguments to For are clauses; each clause is itself a list of a keyword and one or more arguments. The clauses may introduce local variables, specify return values and when the iteration should cease, have side-effects, and so on. Before going further, it is probably best to give some examples. (FOR (FROM I 1 10 2) (DO (PRINT I))) Prints the numbers 1 3 5 7 9 (FOR (IN U '(A B C)) (DO (PRINT U))) Prints the letters A B C (FOR (ON U '(A B C)) (DO (PRINT U))) Prints the lists (A B C) (B C) and (C) Finally, the function (DE ZIP (X Y) (FOR (IN U X) (IN V Y) (COLLECT (LIST U V)))) produces a list of 2 element lists, each consisting of the the corresponding elements of the three lists X, Y and Z. For example, (ZIP '(1 2 3 4) '(A B C) ) produces PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.9 ((1 a)(2 b)(3 c)) The iteration terminates as soon as one of the (IN ..) clauses is exhausted. Note that the (IN ... ), (ON ...) and (FROM ...) clauses introduce local variables U, V or I, that are referred to in the action clause. All the possible clauses are described below. The first few introduce iteration variables. Most of these also give some means of indicating when iteration should cease. For example, if In ____ In a list being mapped over by an In clause is exhausted, iteration For For must cease. If several such clauses are given in For expression, iteration ceases when one of the clauses indicates it should, whether or not the other clauses indicate that it should cease. (IN V1 V2) ____ assigns the variable V1 successive elements of the list V2. This may take an additional, optional argument: a function to be applied to the extracted element or sublist before it is assigned to the variable. The following returns the sum of the lengths of all the elements of L. [??? Rather a kludge -- not sure why this is here. [??? Rather a kludge -- not sure why this is here. [??? Rather a kludge -- not sure why this is here. Perhaps it should come out again. ???] Perhaps it should come out again. ???] Perhaps it should come out again. ???] (DE LENGTHS (L) (FOR (IN N L LENGTH) (COLLECT (LIST N N))) is the same as (DE LENGTHS (L) (FOR (IN N L) (COLLECT (LIST (LENGTH N) (LENGTH N)))) ) but only calls LENGTH once. Using the (WITH ..) form to introduce a local LN may be clearer. For example, (SUMLENGTHS '((1 2 3 4 5)(a b c)(x y))) is ((5 5) (3 3) (2 2)) Flow Of Control 7 February 1983 PSL Manual page 9.10 section 9.4 (ON V1 V2) Cdr Cdr ____ assigns the variable V1 successive Cdrs of the list V2. (FROM VAR INIT FINAL STEP) is a numeric iteration clause. The variable is first assigned INIT, and then incremented by step until it is larger than FINAL. INIT, FINAL, and STEP are optional. INIT and STEP both default to 1, and if FINAL is omitted the iteration continues until stopped by some other means. To specify a STEP with INIT or FINAL omitted, or a FINAL with INIT omitted, place NIL (the constant -- it cannot be an expression) in the appropriate slot to be omitted. FINAL and STEP are only evaluated once. (FOR VAR INIT NEXT) assigns the variable INIT first, and subsequently the value of the expression NEXT. INIT and NEXT may be omitted. Note that this is identical to the behavior Do Do of iterators in a Do. (WITH V1 V2 ... Vn) introduces N locals, initialized to NIL. In addition, each Vi may also be of the form (VAR INIT), in which case it is initialized to INIT. (DO S1 S2 ... Sn) causes the Si's to be evaluated at each iteration. There are two clauses which allow arbitrary code to be executed before the first iteration, and after the last. (INITIALLY S1 S2 ... Sn) causes the Si's to be evaluated in the new environment (i.e. with the iteration variables bound to their initial values) before the first iteration. (FINALLY S1 S2 ... Sn) causes the Si's to be evaluated just before the function returns. The next few clauses build up return types. Except for the RETURNS/RETURNING clause, they may each take an additional argument which specifies that instead of returning the appropriate value, it is accumulated in the specified variable. For example, an unzipper might be defined as PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.11 (DE UNZIP (L) (FOR (IN U L) (WITH X Y) (COLLECT (FIRST U) X) (COLLECT (SECOND U) Y) (RETURNS (LIST X Y)))) Zip Zip ____ This is essentially the opposite of Zip. Given a list of 2 ____ ____ ____ element lists, it unzips them into 2 lists, and returns a list of ____ those 2 lists. For example, (unzip '((1 a)(2 b)(3 c))) returns is ((1 2 3)(a b c)). (RETURNS EXP) For For causes the given expression to be the value of the For. Returning is synonymous with returns. It may be given additional arguments, in which case they are evaluated in order and the value of the last is returned ProgN ProgN (implicit ProgN). (COLLECT EXP) causes the successive values of the expression to be Append ____ Append collected into a list. Each value is Appended to the ____ end of the list. (UNION EXP) ____ is similar, but only adds an element to the list if it is not equal to anything already there. (CONC EXP) NConc NConc causes the successive values to be NConc'd together. (JOIN EXP) causes them to be appended. (COUNT EXP) returns the number of times EXP was non-NIL. (SUM EXP), (PRODUCT EXP), (MAXIMIZE EXP), and (MINIMIZE EXP) do the obvious. Synonyms are summing, maximizing, and minimizing. (ALWAYS EXP) returns T if EXP is non-NIL on each iteration. If EXP is ever NIL, the loop terminates immediately, no epilogue code, such as that introduced by finally is run, and NIL is returned. (NEVER EXP) is equivalent to (ALWAYS (NOT EXP)). (WHILE EXP) and (UNTIL EXP) Explicit tests for the end of the loop may be given Flow Of Control 7 February 1983 PSL Manual page 9.12 section 9.4 using (WHILE EXP). The loop terminates if EXP becomes NIL at the beginning of an iteration. (UNTIL EXP) is While Until While Until equivalent to (WHILE (NOT EXP)). Both While and Until may be given additional arguments; (WHILE E1 E2 ... En) is equivalent to (WHILE (AND E1 E2 ... En)) and (UNTIL E1 E2 ... En) is equivalent to (UNTIL (OR E1 E2 ... En)). (WHEN EXP) causes a jump to the next iteration if EXP is NIL. (UNLESS EXP) is equivalent to (WHEN (NOT EXP)). For For For is a general iteration construct similar in many ways to the LISP Loop Loop Machine and MACLISP Loop construct, and the earlier Interlisp CLISP For For iteration construct. For, however, is considerably simpler, far more For For "lispy", and somewhat less powerful. For only works in LISP syntax. All variable binding/updating still precedes any tests or other code. When Unless When Unless Also note that all When or Unless clauses apply to all action clauses, not For For just subsequent ones. This fixed order of evaluation makes For less Loop Loop powerful than Loop, but also keeps it considerably simpler. The basic order of evaluation is a. bind variables to initial values (computed in the outer environment) Initially Initially b. execute prologue (i.e. Initially clauses) c. while none of the termination conditions are satisfied: When Unless When Unless i. check conditionalization clauses (When and Unless), and start next iteration if all are not satisfied. ii. perform body, collecting into variables as necessary iii. next iteration d. (after a termination condition is satisfied) execute the Finally Finally epilogue (i.e. Finally clauses) For For For does all variable binding/updating in parallel. There is a similar For* For* macro, For*, which does it sequentially. PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.13 For!* For!* _ ____ ___ _____ (For!* [S:form]): any macro 9.4.2. Mapping Functions 9.4.2. Mapping Functions 9.4.2. Mapping Functions ) The mapping functions long familiar to LISP programmers are present in For For PSL. However, we believe that the For construct described above or the ForEach ForEach simpler ForEach described below is generally more useful, since it obviates the usual necessity of constructing a lambda expression, and is often more transparent. Mapping functions with more than two arguments are not ____ currently supported. Note however that several lists may be iterated along For For with For, and with considerably more generality. For example: (Prog (I) (Setq I 0) (Return (Mapcar L (Function (Lambda (X) (Progn (Setq I (Plus I 1)) (Cons I X))))))) may be expressed more transparently as (For (IN X L) (FROM I 1) (COLLECT (CONS I X))) Note that there is currently no RLISP syntax for this, but we are contemplating something like: FOR X IN L AS I FROM 1 COLLECT I . X; For For To augment the simpler For loop present in basic PSL and support the For Each For Each RLISP For Each construct, the following list iterator has been provided: ForEach ForEach _ ___ ___ _____ (ForEach U:any): any macro _____ _____ _____ macro macro This macro is essentially equivalent to the the map functions as follows: Possible forms are: Setting X to successive elements (CARs) of U: (FOREACH X IN U DO (FOO X)) --> (MAPC U 'FOO) (FOREACH X IN U COLLECT (FOO X))--> (MAPCAR U 'FOO) (FOREACH X IN U CONC (FOO X)) --> (MAPCAN U 'FOO) (FOREACH X IN U JOIN (FOO X)) --> (MAPCAN U 'FOO) Setting X to successive CDRs of U: (FOREACH X ON U DO (FOO X)) --> (MAP U 'FOO) Flow Of Control 7 February 1983 PSL Manual page 9.14 section 9.4 (FOREACH X ON U COLLECT (FOO X))--> (MAPLIST U 'FOO) (FOREACH X ON U CONC (FOO X)) --> (MAPCON U 'FOO) (FOREACH X ON U JOIN (FOO X)) --> (MAPCON U 'FOO) The RLISP syntax is quite simple: FOR EACH x IN y DO z; FOR EACH x ON y COLLECT z; etc. Note that FOR EACH may be written as FOREACH Map Map _ ____ __ ________ ___ ____ (Map X:list FN:function): NIL expr Cdr __ Cdr _ Applies FN to successive Cdr segments of X. NIL is returned. This is equivalent to: (FOREACH u ON x DO (FN u)) MapC MapC _ ____ __ ________ ___ ____ (MapC X:list FN:function): NIL expr Car __ Car ____ _ FN is applied to successive Car segments of list X. NIL is returned. This is equivalent to: (FOREACH u IN x DO (FN u)) MapCan MapCan _ ____ __ ________ ____ ____ (MapCan X:list FN:function): list expr Car ____ __ Car _ A concatenated list of FN applied to successive Car elements of X is returned. This is equivalent to: (FOREACH u IN x CONC (FN u)) MapCar MapCar _ ____ __ ________ ____ ____ (MapCar X:list FN:function): list expr ____ __ Returned is a constructed list, the elements of which are FN Car Car ____ _ applied to each Car of list X. This is equivalent to: (FOREACH u IN x COLLECT (FN u)) MapCon MapCon _ ____ __ ________ ____ ____ (MapCon X:list FN:function): list expr Cdr ____ __ Cdr Returned is a concatenated list of FN applied to successive Cdr _ segments of X. This is equivalent to: PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.15 (FOREACH u ON x CONC (FN u)) MapList MapList _ ____ __ ________ ____ ____ (MapList X:list FN:function): list expr ____ __ Returns a constructed list, the elements of which are FN applied Cdr Cdr _ to successive Cdr segments of X. This is equivalent to: (FOREACH u ON x COLLECT (FN u)) 9.4.3. Do 9.4.3. Do 9.4.3. Do Do Let Do Let The MACLISP style Do and Let are now partially implemented in the USEFUL module. Do Do _ ____ _ ____ _ ____ ___ _____ (Do A:list B:list [S:form]): any macro Do Do The Do macro is a general iteration construct similar to that of LISPM and friends. However, it does differ in some details; in Do Do particular it is not compatible with the "old style Do" of MACLISP, nor does it support the "no end test means once only" Do Do convention. Do has the form (DO (I1 I2 ... In) (TEST R1 R2 ... Rk) S1 S2 ... Sm) in which there may be zero or more I's, R's, and S's. In general the I's have the form (var init step) Do Do On entry to the Do form, all the inits are evaluated, then the variables are bound to their respective inits. The test is evaluated, and if non-NIL the form evaluates the R's and returns the value of the last one. If none are supplied it returns NIL. If the test evaluates to NIL the S's are evaluated, the variables are assigned the values of their respective steps in parallel, and the test evaluated again. This iteration continues until test evaluates to a non-NIL value. Note that the inits are evaluated in the surrounding environment, while the steps are Do Do evaluated in the new environment. The body of the Do (the S's) Prog Go Prog Go is a Prog, and may contain labels and Go's, though use of this is Return Return discouraged. It may be changed at a later date. Return used Do Do within a Do returns immediately without evaluating the test or exit forms (R's). Flow Of Control 7 February 1983 PSL Manual page 9.16 section 9.4 There are alternative forms for the I's: If the step is omitted, the variable's value is left unchanged. If both the init and __ step are omitted or if the I is an id, it is initialized to NIL and left unchanged. This is particularly useful for introducing SetQ SetQ dummy variables which are SetQ'd inside the body. Do!* Do!* _ ____ _ ____ _ ____ ___ _____ (Do!* A:list B:list [C:form]): any macro Do!* Do Do!* Do Do!* is like Do, except the variable bindings and updatings are done sequentially instead of in parallel. Do-Loop Do-Loop _ ____ _ ____ _ ____ _ ____ ___ _____ (Do-Loop A:list B:list C:list [S:form]): any macro Do-Loop Do Do-Loop Do Do-Loop is like Do, except that it takes an additional argument, a prologue. The general form is (DO-LOOP (I1 I2 ... In) (P1 P2 ... Pj) (TEST R1 R2 ... Rk) S1 S2 ... Sm) Do Do This is executed just like the corresponding Do, except that after the bindings are established and initial values assigned, but before the test is first executed the P's are evaluated, in order. Note that the P's are all evaluated exactly once (assuming that none of the P's err out, or otherwise throw to a surrounding context). Do-Loop!* Do-Loop!* _ ____ _ ____ _ ____ _ ____ ___ _____ (Do-Loop!* A:list B:list C:list [S:form_]): any macro Do-Loop!* Do-Loop!* Do-Loop!* does the variable bindings and undates sequentially instead of in parallel. Let Let _ ____ _ ____ ___ _____ (Let A:list [B:form]): any macro Let Let Let is a macro giving a more perspicuous form for writing lambda expressions. The basic form is (LET ((V1 I1) (V2 I2) ...(Vn In)) S1 S2 ... Sn) The I's are evaluated (in an unspecified order), and then the V's are bound to these values, the S's evaluated, and the value of the last is returned. Note that the I's are evaluated in the outer environment before the V's are bound. PSL Manual 7 February 1983 Flow Of Control section 9.4 page 9.17 __ Note: the id LET conflicts with a similar construct in RLISP and REDUCE Let!* Let!* _ ____ _ ____ ___ _____ (Let!* A:list [B:form]): any macro Let!* Let Let!* Let Let!* is just like Let except that it makes the assignments sequentially. That is, the first binding is made before the value for the second one is computed. 9.5. Non-Local Exits 9.5. Non-Local Exits 9.5. Non-Local Exits One occasionally wishes to discontinue a computation in which the lexical Return Return restrictions on placement of Return are too restrictive. The non-local Catch Throw Catch Throw exit constructs Catch and Throw exist for these cases. They should not, however, be used indiscriminately. The lexical restrictions on their more local counterparts ensure that the flow of control can be ascertained by Catch Throw Catch Throw looking at a single piece of code. With Catch and Throw, control may be passed to and from totally unrelated pieces of code. Under some conditions, these functions are invaluable. Under others, they can wreak havoc. Catch Catch ___ __ ____ ____ ___ ____ ________ _____ (Catch TAG:id [FORM:form]): any Open-Compiled, fexpr Catch Eval Catch ___ Eval ____ Catch evaluates the TAG and then calls Eval on the FORMs in a Throw Throw ___ ___ protected environment. If during this evaluation (Throw TAG VAL) Catch Throw Catch ___ Throw occurs, Catch immediately returns VAL. If no Throw occurs, the ____ value of the last FORM is returned. Note that in general only Throw Throw Eq Throw ___ Throw ___ Eq Throws with the same TAG are caught. Throws whose TAG is not Eq Catch Catch Catch Catch ___ to that of Catch are passed on out to surrounding Catches. A TAG Catch Catch of NIL, however, is special. (Catch NIL @var[form)] catches any Throw Throw Throw. __________ ______ THROWSIGNAL!* [Initially: NIL] global __________ ______ THROWTAG!* [Initially: NIL] global The FLUID variables THROWSIGNAL!* and THROWTAG!* may be Catch Catch interrogated to find out if the most recently evaluated Catch was Throw Throw Throw Throw Thrown to, and what tag was passed to the Throw. THROWSIGNAL!* Set Catch Set Catch is Set to NIL upon normal exit from a Catch, and to T upon normal Throw Set Throw Set exit from Throw. THROWTAG!* is Set to the first argument passed Throw Throw Eval Throw Throw Eval ____ to the Throw. (Mark a place to Throw to, Eval FORM.) Flow Of Control 7 February 1983 PSL Manual page 9.18 section 9.5 Throw Throw ___ __ ___ ___ ____ ________ ____ (Throw TAG:id VAL:any): None Returned expr Catch Eq Catch Eq This passes control to the closest surrounding Catch with an Eq Catch ___ Catch or null TAG. If there is no such surrounding Catch it is an _____ _____ _____ Throw __ ___ _______ __ ___ Throw error in the context of the Throw. That is, control is not Throw Error Throw Error Thrown to the top level before the call on Error. (Non-local Goto Goto Goto.) Some examples: In LISP syntax, with (DE DOIT (x) (COND ((EQN x 1) 100) (T (THROW 'FOO 200)))) (CATCH 'FOO (DOIT 1) (PRINT "NOPE") 0) will continue and execute the PRINT statement and return 0 while (CATCH 'FOO (DOIT 2) (PRINT "NOPE") 0) will of course THROW, returning 200 and not executing the last forms. A common problem people encounter is how to pass arguments and/or CATCH CATCH computed functions or tags into CATCH for protected evaluation. The following examples should illustrate. Note that TAG is quoted, since it is evaluated before use in CATCH and THROW. In LISP syntax: (DE PASS-ARGS(X1 X2) (CATCH 'FOO (FEE (PLUS2 X1 X2) (DIFFERENCE X1 X2)))) This is simple, because CATCH compiles open. No FLUID declarations or Apply Apply LIST building is needed, as in previous versions of PSL. An explicit Apply must be used for a function argument; usually, the APPLY will compile open, with no overhead: In LISP syntax: (DE PASS-FN(X1 FN) (CATCH 'FOO (APPLY FN (LIST X1)))) Catch Throw Catch Throw The following MACROs are provided to aid in the use of Catch and Throw with a NIL tag, by examining the THROWSIGNAL!* and THROWTAG!*: PSL Manual 7 February 1983 Flow Of Control section 9.5 page 9.19 Catch!-All Catch!-All __ ________ ____ ____ ___ _____ (Catch!-All FN:function [FORM:form]): any macro Catch Catch This issues a (Catch NIL ...); if a Throw was actually done, the __ function FN is applied to the two arguments THROWTAG!* and the throw Throw throw Throw value returned by the throw. Thus FN is applied only if a Throw was executed. Unwind!-All Unwind!-All __ ________ ____ ____ ___ _____ (Unwind!-All FN:function [FORM:form]): any macro Catch Catch __ This issues a (Catch NIL ...). The function FN is always called, and applied to the two arguments THROWTAG!* and the value throw Throw throw Throw __ returned by the throw. If no Throw was done then FN is called on NIL and the value returned. Unwind!-Protect Unwind!-Protect _ ____ _ ____ ___ _____ (Unwind!-Protect F:form [C:form]): any macro _ The idea is to execute the "protected" form, F, and then run some _ "clean-up" forms C even if a Throw (or Error) occurred during the Catch _ Catch evaluation of F. This issues a (Catch NIL ...), the cleanup forms are then run, and finally either the value is returned if no Throw occurred, or the Throw is "re-thrown" to the same tag. A common example is to ensure a file be closed after processing, even if an error or throw occurred: (SETQ chan (OPEN file ....)) (UNWIND-PROTECT (process-file) (CLOSE chan)) Note: Certain special tags are used in the PSL system, and should not be interfered with casually: Error ErrorSet Error ErrorSet !$ERROR!$ Used by Error and ErrorSet which are implemented in terms of Catch Throw Catch Throw Catch and Throw, see Chapter 14). !$UNWIND!-PROTECT!$ A special TAG placed to ensure that ALL throws pause at the UNWIND-PROTECT "mark". PROG GO RETURN PROG GO RETURN !$PROG!$ Used to communicate between interpreted PROGs, GOs and RETURNs. |
Added psl-1983/lpt/10-functions.lpt version [118390306b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Function Definition section 10.0 page 10.1 CHAPTER 10 CHAPTER 10 CHAPTER 10 FUNCTION DEFINITION AND BINDING FUNCTION DEFINITION AND BINDING FUNCTION DEFINITION AND BINDING 10.1. Function Definition in PSL . . . . . . . . . . 10.1 10.1.1. Notes on Code Pointers . . . . . . . . . 10.1 10.1.2. Functions Useful in Function Definition. . . . 10.2 10.1.3. Function Definition in LISP Syntax . . . . . 10.4 10.1.4. Function Definition in RLISP Syntax . . . . . 10.6 10.1.5. Low Level Function Definition Primitives . . . 10.6 10.1.6. Function Type Predicates. . . . . . . . . 10.7 10.2. Variables and Bindings. . . . . . . . . . . . 10.8 10.2.1. Binding Type Declaration. . . . . . . . . 10.8 10.2.2. Binding Type Predicates . . . . . . . . . 10.9 10.3. User Binding Functions. . . . . . . . . . . . 10.10 10.3.1. Funargs, Closures and Environments . . . . . 10.10 10.1. Function Definition in PSL 10.1. Function Definition in PSL 10.1. Function Definition in PSL Functions in PSL are GLOBAL entities. To avoid function-variable naming clashes, the Standard LISP Report required that no variable have the same name as a function. There is no conflict in PSL, as separate function cells and value cells are used. A warning message is given for compatibility. The first major section in this chapter describes how to define new functions; the second describes the binding of variables in PSL. The final section presents binding functions useful in building new interpreter functions. 10.1.1. Notes on Code Pointers 10.1.1. Notes on Code Pointers 10.1.1. Notes on Code Pointers Print ____ _______ Print A code-pointer may be displayed by the Print functions or expanded by Explode Explode Explode. The value appears in the convention of the implementation (#<Code:a nnnn>, where a is the number of arguments of the function, and ____ _______ nnnn is the function's entry point, on the DEC-20 and VAX). A code-pointer Compress Compress may not be created by Compress. (See Chapter 12 for descriptions of Explode Compress Explode Compress ____ _______ Explode and Compress.) The code-pointer associated with a compiled GetD GetD function may be retrieved by GetD and is valid as long as PSL is in execution (on the DEC-20 and VAX, compiled code is not relocated, so PutD ____ _______ ____ _______ PutD code-pointers do not change). A code-pointer may be stored using PutD, Put SetQ Put SetQ Put, SetQ and the like or by being bound to a variable. It may be checked Eq Eq ____ _______ for equivalence by Eq. The value may be checked for being a code-pointer CodeP CodeP by the CodeP function. Function Definition 7 February 1983 PSL Manual page 10.2 section 10.1 10.1.2. Functions Useful in Function Definition 10.1.2. Functions Useful in Function Definition 10.1.2. Functions Useful in Function Definition __ In PSL, ids have a function cell that usually contains an executable instruction which either JUMPs directly to the entry point of a compiled function or executes a CALL to an auxiliary routine that handles interpreted functions, undefined functions, or other special services (such ________ as auto-loading functions, etc). The user can pass anonymous function ____ _______ objects around either as a code-pointer, which is a tagged object referring ______ to a compiled code block, or a lambda expression, representing an interpreted function. PutD PutD _____ __ ____ _____ ____ ______ ____ _______ __ ____ (PutD FNAME:id TYPE:ftype BODY:{lambda,code-pointer}): id expr _____ ____ ____ Creates a function with name FNAME and type TYPE, with BODY as PutD PutD the function definition. If successful, PutD returns the name of the defined function. ____ _______ If the body is a code-pointer or is compiled (i.e. !*COMP=T as the function was defined), a special instruction to jump to the start of the code is placed in the function cell. If it is a ______ lambda, the lambda expression is saved on the property list under the indicator !*LAMBDALINK and a call to an interpreter function LambdaLink LambdaLink (LambdaLink) is placed in the function cell. ____ ____ _____ The TYPE is recorded on the property list of FNAME if it is not ____ ____ ____ expr expr an expr. [??? We need to add code to check that the the arglist has no [??? We need to add code to check that the the arglist has no [??? We need to add code to check that the the arglist has no more than 15 arguments for exprs, 1 argument for fexprs and more than 15 arguments for exprs, 1 argument for fexprs and more than 15 arguments for exprs, 1 argument for fexprs and macros, and ??? for nexprs. Declaration mechanisms to avoid macros, and ??? for nexprs. Declaration mechanisms to avoid macros, and ??? for nexprs. Declaration mechanisms to avoid overhead also need to be available. (In fact are available overhead also need to be available. (In fact are available overhead also need to be available. (In fact are available for the compiler, although still poorly documented.) When for the compiler, although still poorly documented.) When for the compiler, although still poorly documented.) When should we expand macros? ???] should we expand macros? ???] should we expand macros? ???] PutD GetD PutD _____ GetD ____ _____ After using PutD on FNAME, GetD returns a pair of the the FNAME's ____ ____ (TYPE . BODY). GlobalP GlobalP The GlobalP predicate returns T if queried with the defined _____ function's name. If the function FNAME has already been declared as a GLOBAL or FLUID variable the warning: *** FNAME is a non-local variable _____ occurs, but the function is defined. If function FNAME is already defined, a warning message appears: *** Function FNAME has been redefined ____ Note: All function types may be compiled. The following switches are useful when defining functions. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.3 __________ ______ !*REDEFMSG [Initially: T] switch If !*REDEFMSG is not NIL, the message *** Function `FOO' has been redefined is printed whenever a function is redefined. __________ ______ !*USERMODE [Initially: T] switch Controls action on redefinition of a function. All functions defined if !*USERMODE is T are flagged USER. Functions which are flagged USER can be redefined freely. If an attempt is made to redefine a function which is not flagged USER, the query Do you really want to redefine the system function `FOO'? is made, requiring a Y, N, YES, NO, or B response. B starts the break loop, so that one can change the setting of !*USERMODE. After exiting the break loop, one must answer Y, Yes, N, or No. YesP YesP See YesP in Chapter 13. If !*UserMode is NIL, all functions can be redefined freely, and all functions defined have the USER flag removed. This provides some protection from redefining system functions. __________ ______ !*COMP [Initially: NIL] switch PutD PutD The value of !*COMP controls whether or not PutD compiles the function defined in its arguments before defining it. If !*COMP is NIL the function is defined as a lambda expression. If !*COMP is non-NIL, the function is first compiled. Compilation produces certain changes in the semantics of functions, particularly FLUID type access. GetD GetD _ ___ ___ ____ ____ (GetD U:any): {NIL, pair} expr _ If U is not the name of a defined function, NIL is returned. If _ ____ U is a defined function then the pair ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr, fexpr, macro, nexpr expr, fexpr, macro, nexpr ____ _______ ______ ({expr, fexpr, macro, nexpr} . {code-pointer, lambda}) is returned. CopyD CopyD ___ __ ___ __ ___ __ ____ (CopyD NEW:id OLD:id): NEW:id expr ___ ___ The function body and type for NEW become the same as OLD. If no ___ definition exists for OLD an error: ***** OLD has no definition in COPYD Function Definition 7 February 1983 PSL Manual page 10.4 section 10.1 ___ is given. NEW is returned. RemD RemD _ __ ___ ____ ____ (RemD U:id): {NIL, pair} expr _ Removes the function named U from the set of defined functions. GetD ____ GetD Returns the (ftype . function) pair or NIL, as does GetD. The ________ _ function type attribute of U is removed from the property list of _ U. 10.1.3. Function Definition in LISP Syntax 10.1.3. Function Definition in LISP Syntax 10.1.3. Function Definition in LISP Syntax De Df Dn Dm Ds De Df Dn Dm Ds The functions De, Df, Dn, Dm, and Ds are most commonly used in the LISP syntax form of PSL. They are difficult to use from RLISP as there is not a convenient way to represent the argument list. The functions are compiled if the compiler is loaded and the GLOBAL !*COMP is T. De De _____ __ ______ __ ____ __ ____ __ _____ (De FNAME:id PARAMS:id-list [FN:form]): id macro ____ ____ ____ expr _____ expr ____ __ Defines the function named FNAME, of type expr. The forms FN are made into a lambda expression with the formal parameter list 1 ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Df Df _____ __ _____ __ ____ __ ___ __ _____ (Df FNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ fexpr _____ fexpr ____ __ Defines the function named FNAME, of type fexpr. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Dn Dn _____ __ _____ __ ____ __ ___ __ _____ (Dn FNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ nexpr _____ nexpr ____ __ Defines the function named FNAME, of type nexpr. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. _______________ 1 Or the compiled code pointer for the lambda expression if the compiler is on. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.5 Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Dm Dm _____ __ _____ __ ____ __ ___ __ _____ (Dm MNAME:id PARAM:id-list FN:any): id macro _____ _____ _____ macro _____ macro ____ __ Defines the function named FNAME, of type macro. The forms FN are made into a lambda expression with the formal parameter list ______ PARAMS, and this is used as the body of the function. Previous definitions of the function are lost. The name of the _____ defined function, FNAME, is returned. Ds Ds _____ __ _____ __ ____ __ ___ __ _____ (Ds SNAME:id PARAM:id-list FN:any): id macro ______ _______ ______ _______ ______ _______ smacro Smacros smacro _____ Smacros Defines the smacro SNAME. Smacros are actually a syntactic _____ _____ _____ macro macro notation for a special class of macros, those that essentially treat the macro's argument as a list of arguments to be substituted into the body of the expression and then expanded in _____ _____ _____ macro macro line, rather than using the computational power of the macro to defmacro defmacro customize code. Thus they are a special case of defmacro. See also the BackQuote facility. For example: Lisp syntax: To make a substitution macro for FIRST ->CAR we could say (DM FIRST(X) (LIST 'CAR (CADR X))) Instead the following is clearer (DS FIRST(X) (CAR X)) 10.1.4. Function Definition in RLISP Syntax 10.1.4. Function Definition in RLISP Syntax 10.1.4. Function Definition in RLISP Syntax [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to [??? THIS IS NOT SUFFICIENT DOCUMENTATION! Either move it all to chapter 3 or do a better job here. ???] chapter 3 or do a better job here. ???] chapter 3 or do a better job here. ???] In RLISP syntax, procedures are defined by using the Procedure construct, as discussed in Chapter 3. mode type PROCEDURE name(args); body; where mode is SYSLISP or LISP or SYMBOLIC and defaults to LISP, and type defaults to EXPR. Function Definition 7 February 1983 PSL Manual page 10.6 section 10.1 10.1.5. Low Level Function Definition Primitives 10.1.5. Low Level Function Definition Primitives 10.1.5. Low Level Function Definition Primitives PutD GetD PutD GetD The following functions are used especially by PutD and GetD, defined Eval Apply Eval Apply above in Section 10.1.2, and by Eval and Apply, defined in Chapter 11. FUnBoundP FUnBoundP _ __ _______ ____ (FUnBoundP U:id): boolean expr ________ _ Tests whether there is a definition in the function cell of U; returns NIL if so, T if not. Note: Undefined functions actually call a special function, UndefinedFunction Error FUnBoundP UndefinedFunction Error FUnBoundP UndefinedFunction, that invokes Error. FUnBoundP defines UndefinedFunction UndefinedFunction "unbound" to mean "calls UndefinedFunction". FLambdaLinkP FLambdaLinkP _ __ _______ ____ (FLambdaLinkP U:id): boolean expr _ Tests whether U is an interpreted function; return T if so, NIL if not. This is done by checking for the special code-address of lambdaLink lambdaLink the lambdaLink function, which calls the interpreter. FCodeP FCodeP _ __ _______ ____ (FCodeP U:id): boolean expr _ Tests whether U is a compiled function; returns T if so, NIL if not. MakeFUnBound MakeFUnBound _ __ ___ ____ (MakeFUnBound U:id): NIL expr _ Makes U an undefined function by planting a special call to an UndefinedFunction UndefinedFunction ________ _ error function, UndefinedFunction, in the function cell of U. MakeFLambdaLink MakeFLambdaLink _ __ ___ ____ (MakeFLambdaLink U:id): NIL expr _ Makes U an interpreted function by planting a special call to an lambdaLink lambdaLink interpreter support function (lambdaLink) function in the ________ _ function cell of U.} MakeFCode MakeFCode _ __ _ ____ _______ ___ ____ (MakeFCode U:id C:code-pointer): NIL expr _ Makes U a compiled function by planting a special JUMP to the _ code-address associated with C. GetFCodePointer GetFCodePointer _ __ ____ _______ ____ (GetFCodePointer U:id): code-pointer expr ____ _______ _ Gets the code-pointer for U. PSL Manual 7 February 1983 Function Definition section 10.1 page 10.7 Code!-Number!-Of!-Arguments Code!-Number!-Of!-Arguments _ ____ _______ ___ _______ ____ (Code!-Number!-Of!-Arguments C:code-pointer): {NIL,integer} expr Some compiled functions have the argument number they expect _ stored in association with the codepointer C. This integer, or NIL is returned. _____ ____ _____ ____ _____ ____ [??? Should be extended for nexprs and declared exprs. ???] [??? Should be extended for nexprs and declared exprs. ???] [??? Should be extended for nexprs and declared exprs. ???] 10.1.6. Function Type Predicates 10.1.6. Function Type Predicates 10.1.6. Function Type Predicates See Section 2.7 for a discussion of the function types available in PSL. ExprP ExprP _ ___ _______ ____ (ExprP U:any): boolean expr ____ ____ ____ expr _ ____ _______ ______ __ expr Test if U is a code-pointer, lambda form, or an id with expr definition. FExprP FExprP _ ___ _______ ____ (FExprP U:any): boolean expr _____ _____ _____ fexpr _ __ fexpr Test if U is an id with fexpr definition. NExprP NExprP _ ___ _______ ____ (NExprP U:any): boolean expr _____ _____ _____ nexpr _ __ nexpr Test if U is an id with nexpr definition. MacroP MacroP _ ___ _______ ____ (MacroP U:any): boolean expr _____ _____ _____ macro _ __ macro Test if U is an id with macro definition. 10.2. Variables and Bindings 10.2. Variables and Bindings 10.2. Variables and Bindings __ Variables in PSL are ids, and associated values are usually stored in and __ retrieved from the value cell of this id. If variables appear as Prog Prog parameters in lambda expressions or in Prog's, the contents of the value cell are saved on a binding stack. A new value or NIL is stored in the Prog Prog value cell and the computation proceeds. On exit from the lambda or Prog the old value is restored. This is called the "shallow binding" model of LISP. It is chosen to permit compiled code to do binding efficiently. For even more efficiency, compiled code may eliminate the variable names and simply keep values in registers or a stack. The scope of a variable is the range over which the variable has a defined value. There are three different binding mechanisms in PSL. LOCAL BINDING Only compiled functions bind variables locally. Local Function Definition 7 February 1983 PSL Manual page 10.8 section 10.2 variables occur as formal parameters in lambda expressions Prog Prog and as LOCAL variables in Prog's. The binding occurs as a Prog Prog lambda expression is evaluated or as a Prog form is executed. The scope of a local variable is the body of the function in which it is defined. FLUID BINDING FLUID variables are GLOBAL in scope but may occur as formal Prog Prog parameters or Prog form variables. In interpreted functions, all formal parameters and LOCAL variables are considered to have FLUID binding until changed to LOCAL binding by compilation. A variable can be treated as a FLUID only by declaration. If FLUID variables are used as parameters or LOCALs they are rebound in such a way that the previous binding may be restored. All references to FLUID variables are to the currently active binding. Access to the values is by name, going to the value cell. GLOBAL BINDING GLOBAL variables may never be rebound. Access is to the value bound to the variable. The scope of a GLOBAL variable is universal. Variables declared GLOBAL may not appear as Prog Prog parameters in lambda expressions or as Prog form variables. A variable must be declared GLOBAL prior to its use as a GLOBAL variable since the default type for undeclared variables is FLUID. Note that the interpreter does not stop one from rebinding a global variable. The compiler will issue a warning in this situation. 10.2.1. Binding Type Declaration 10.2.1. Binding Type Declaration 10.2.1. Binding Type Declaration Fluid Fluid ______ __ ____ ___ ____ (Fluid IDLIST:id-list): NIL expr __ ______ __ The ids in IDLIST are declared as FLUID type variables (ids not ______ previously declared are initialized to NIL). Variables in IDLIST already declared FLUID are ignored. Changing a variable's type from GLOBAL to FLUID is not permissible and results in the error: ***** ID cannot be changed to FLUID Global Global ______ __ ____ ___ ____ (Global IDLIST:id-list): NIL expr __ ______ __ The ids of IDLIST are declared GLOBAL type variables. If an id has not been previously declared, it is initialized to NIL. Variables already declared GLOBAL are ignored. Changing a variable's type from FLUID to GLOBAL is not permissible and results in the error: ***** ID cannot be changed to GLOBAL PSL Manual 7 February 1983 Function Definition section 10.2 page 10.9 UnFluid UnFluid ______ __ ____ ___ ____ (UnFluid IDLIST:id-list): NIL expr ______ The variables in IDLIST which have been declared as FLUID variables are no longer considered as FLUID variables. Others are ignored. This affects only compiled functions, as free variables in interpreted functions are automatically considered FLUID (see [Griss 81]). 10.2.2. Binding Type Predicates 10.2.2. Binding Type Predicates 10.2.2. Binding Type Predicates FluidP FluidP _ ___ _______ ____ (FluidP U:any): boolean expr _ If U is FLUID (by declaration only), T is returned; otherwise, NIL is returned. GlobalP GlobalP _ ___ _______ ____ (GlobalP U:any): boolean expr _ If U has been declared GLOBAL or is the name of a defined function, T is returned; else NIL is returned. UnBoundP UnBoundP _ __ _______ ____ (UnBoundP U:id): boolean expr _ Tests whether U has no value. 10.3. User Binding Functions 10.3. User Binding Functions 10.3. User Binding Functions The following functions are available to build one's own interpreter functions that use the built-in FLUID binding mechanism, and interact well with the automatic unbinding that takes place during Throw and Error calls. [??? Are these correct when Environments are managed correctly ???] [??? Are these correct when Environments are managed correctly ???] [??? Are these correct when Environments are managed correctly ???] UnBindN UnBindN _ _______ _________ ____ (UnBindN N:integer): Undefined expr Prog Prog Used in user-defined interpreter functions (like Prog) to restore _ previous bindings to the last N values bound. LBind1 LBind1 ______ __ ___________ ___ _________ ____ (LBind1 IDNAME:id VALUETOBIND:any): Undefined expr ______ Support for LAMBDA-like binding. The current value of IDNAME is ___________ saved on the binding stack; the value of VALUETOBIND is then ______ bound to IDNAME. Function Definition 7 February 1983 PSL Manual page 10.10 section 10.3 PBind1 PBind1 ______ __ _________ ____ (PBind1 IDNAME:id): Undefined expr Prog Prog ______ Support for Prog. Binds NIL to IDNAME after saving value on the LBind1 LBind1 ______ binding stack. Essentially LBind1(IDNAME, NIL) 10.3.1. Funargs, Closures and Environments 10.3.1. Funargs, Closures and Environments 10.3.1. Funargs, Closures and Environments [??? Not yet connected to V3 ???] [??? Not yet connected to V3 ???] [??? Not yet connected to V3 ???] We have an experimental implementation of Baker's re-rooting funarg scheme [Baker 78], in which we always re-root upon binding; this permits efficient use of a GLOBAL value cell in the compiler. We are also considering implementing a restricted FUNARG or CLOSURE mechanism. The implementation we have does not work with the current version of PSL. This currently uses a module (ALTBIND) to redefine the fluid binding _ ____ mechanism of PSL to be functionally equivalent to an a-list binding scheme. However, it retains the principal advantage of the usual shallow binding scheme: variable lookup is extremely cheap -- just look in a value cell. Typical LISP programs currently run about 8% slower if using ALTBIND than with the initial shallow binding mechanism. It is expected that this 8% difference will go away presently. This mechanism will also probably become a standard part of PSL, rather than an add on module. To use ALTBIND simply do "load altbind;" ["(load altbind)" in LISP]. Existing code, both interpreted and compiled, should then commence using the new binding mechanism. The following functions are of most interest to the user: Closure Closure _ ____ ____ _____ (Closure U:form): form macro Function Function This is similar to Function, but returns a function closure Function Function including environment information, similar to Function in LISP Function* Eval Apply Function* Eval Apply 1.5 and Function* in LISP 1.6 and MACLISP. Eval and Apply are redefined to handle closures correctly. Currently only closures ____ ____ ____ expr expr of exprs are supported. EvalInEnvironment EvalInEnvironment _ ____ ___ ___ _______ ___ ____ (EvalInEnvironment F:form ENV:env-pointer): any expr ApplyInEnvironment ApplyInEnvironment __ ________ ____ ____ ____ ___ ___ _______ ___ ____ (ApplyInEnvironment FN:function ARGS:form-list ENV:env-pointer): any expr Eval Apply Eval Apply These are like Eval and Apply, but take an extra, last argument, and environment pointer. They perform their work in this environment instead of the current one. The following functions should be used with care: PSL Manual 7 February 1983 Function Definition section 10.3 page 10.11 CaptureEnvironment CaptureEnvironment ___ _______ ____ (CaptureEnvironment ): env-pointer expr Save the current bindings to be restored at some later point. CaptureEnvironment CaptureEnvironment This is best used inside a closure. CaptureEnvironment returns ____ an environment pointer. This object is normally a circular list structure, and so should not be printed. The same warning applies to closures, which contain environment pointers. It is hoped that environment pointers will be made a new LISP data type soon, and will be made to print safely, relaxing this restriction. [??? add true envpointer ???] [??? add true envpointer ???] [??? add true envpointer ???] RestoreEnvironment RestoreEnvironment ___ ___ _______ _________ ____ (RestoreEnvironment PTR:env-pointer): Undefined expr Restore old bindings to what they were in the captured ___ environment, PTR. ClearBindings ClearBindings _________ ____ (ClearBindings ): Undefined expr Restore bindings to top level, i.e strip the entire stack. For a demonstration of closures, do (in RLISP) `in "PU:altbind-tests.red";'. [??? Give a practical example ???] [??? Give a practical example ???] [??? Give a practical example ???] |
Added psl-1983/lpt/11-interp.lpt version [ad2f6c4498].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 The Interpreter section 11.0 page 11.1 CHAPTER 11 CHAPTER 11 CHAPTER 11 THE INTERPRETER THE INTERPRETER THE INTERPRETER 11.1. Evaluator Functions Eval and Apply. . . . . . . . 11.1 11.2. Support Functions for Eval and Apply . . . . . . . 11.5 11.3. Special Evaluator Functions, Quote, and Function . . . 11.6 11.4. Support Functions for Macro Evaluation . . . . . . 11.6 11.1. Evaluator Functions Eval and Apply 11.1. Evaluator Functions Eval and Apply 11.1. Evaluator Functions Eval and Apply The PSL evaluator uses an identifier's function cell (SYMFNC(id#) which is directly accessible from kernel functions only) to access the address of the code for executing the identifier's function definition, as described in chapter 10. The function cell contains either the entry address of a compiled function, or the address of a support routine that either signals an undefined function or calls the lambda interpreter. The PSL model of a function call is to place the arguments (after treatment appropriate to function type) in "registers", and then to jump to or call the code in the function cell. ____ Expressions which can be legally evaluated are called forms. They are restricted S-expressions: ____ __ form ::= id ________ | constant __ ____ ____ | (id form ... form) ___ | (special . any) % Special cases: COND, PROG, etc. _____ _____ _____ _____ _____ _____ fexpr macro fexpr macro % usually fexprs or macros. Eval Apply Eval Apply ____ The definitions of Eval and Apply may clarify which expressions are forms. Eval Apply ContinuableError Eval Apply ContinuableError In Eval, Apply, and the support functions below, ContinuableError is used ______ to indicate malformed lambda expressions, undefined functions or mismatched argument numbers; the user is permitted to correct the offending expression Break Break or to define a missing function inside a Break loop. Eval Apply Eval Apply The functions Eval and Apply are central to the PSL interpreter. Since their efficiency is important, some of the support functions they use are LambdaApply LambdaEvalApply CodeApply LambdaApply LambdaEvalApply CodeApply hand-coded in LAP. The functions LambdaApply, LambdaEvalApply, CodeApply, CodeEvalApply IDApply1 Eval Apply CodeEvalApply IDApply1 Eval Apply CodeEvalApply, and IDApply1 are support functions for Eval and Apply. CodeApply CodeEvalApply IDApply1 CodeApply CodeEvalApply IDApply1 CodeApply and CodeEvalApply are coded in LAP. IDApply1 is handled by the compiler. The Interpreter 7 February 1983 PSL Manual page 11.2 section 11.1 Eval Eval _ ____ ___ ____ (Eval U:form): any expr _ The value of the form U is computed. The following is an approximation of the real code, leaving out some implementation details. PSL Manual 7 February 1983 The Interpreter section 11.1 page 11.3 (DE EVAL (U) (PROG (FN) (COND ((IDP U) (RETURN (VALUECELL U)))) % ValueCell returns the contents of Value Cell if ID % BoundP, else signals unbound error. (COND ((NOT (PAIRP U)) (RETURN U))) % This is a "constant" which EVAL's to itself (COND ((EQCAR (CAR U) 'LAMBDA) (RETURN (LAMBDAEVALAPPLY (CAR U) (CDR U))))) % LambdaEvalApply applies the lambda- expression Car U % list containing the evaluation of each argument in C (COND ((CODEP (CAR U)) (RETURN (CODEEVALAPPLY (CAR U) (CDR U))))) % CodeEvalApply applies the function with code-pointer % to the list containing the evaluation of each argume % Cdr U. (COND ((NOT (IDP (CAR U))) (RETURN % permit user to correct U, and reevaluate. (CONTINUABLEERROR 1101 "Ill-formed expression in EVAL" U)))) (SETQ FN (GETD (CAR U))) (COND ((NULL FN) % user might define missing function and retry (RETURN (CONTINUABLEERROR 1001 "Undefined function EVAL (COND ((EQ (CAR FN) 'EXPR) (RETURN (COND ((CODEP (CDR FN)) % CodeEvalApply applies the function with % codepointer Cdr FN to the list containing % evaluation of each argument in Cdr U. (CODEEVALAPPLY (CDR FN) (CDR U))) (T (LAMBDAEVALAPPLY (CDR FN) (CDR U))))))) % LambdaEvalApply applies the lambda-expression Cdr FN The Interpreter 7 February 1983 PSL Manual page 11.4 section 11.1 % list containing the evaluation of each argument in C (COND ((EQ (CAR FN) 'FEXPR) % IDApply1 applies the fexpr Car U to the list of % unevaluated arguments. (RETURN (IDAPPLY1 (CDR U) (CAR U)))) ((EQ (CAR FN) 'MACRO) % IDApply1 first expands the macro call U and then % evaluates the result. (RETURN (EVAL (IDAPPLY1 U (CAR U))))) ((EQ (CAR FN) 'NEXPR) % IDApply1 applies the nexpr Car U to the list obt % by evaluating the arguments in Cdr U. (RETURN (IDAPPLY1 (EVLIS (CDR U)) (CAR U))))))) Apply Apply __ __ ________ ____ ____ ____ ___ ____ (Apply FN:{id,function} ARGS:form-list): any expr Apply Apply Apply allows one to make an indirect function call. It returns __ ____ the value of FN with actual parameters ARGS. The actual ____ parameters in ARGS are already in the form required for binding __ to the formal parameters of FN. PSL permits the application of _____ ______ _____ _____ ______ _____ _____ ______ _____ macro nexprs fexpr Apply Cdr macro nexprs fexpr Apply Cdr macros, nexprs and fexprs; the effect is the same as (Apply (Cdr GetD GetD __ ____ (GetD FN)) ARGS); i.e. no fix-up is done to quote arguments, etc. Apply List Apply List as in some LISPs. A call to Apply using List on the second Apply List Apply List argument [e.g. (Apply F (List X Y))] is compiled so that the ____ list is not actually constructed. The following is an approximation of the real code, leaving out implementation details. PSL Manual 7 February 1983 The Interpreter section 11.1 page 11.5 (DE APPLY (FN ARGS) (PROG (DEFN) (COND ((CODEP FN) % Spread the ARGS into the registers and transfer % entry point of the function. (RETURN (CODEAPPLY FN ARGS))) ((EQCAR FN 'LAMBDA) % Bind the actual parameters in ARGS to the formal % parameters of the lambda expression If the two l % are not of equal length then signal % (CONTINUABLEERROR 1204 % "Number of parameters do not match" % (CONS FN ARGS)) (RETURN (LAMBDAAPPLY FN ARGS))) ((NOT (IDP FN)) (RETURN (CONTINUABLEERROR 1104 "Ill-formed function in APPLY" (CONS FN ARG)))) ((NULL (SETQ DEFN (GETD FN))) (RETURN (CONTINUABLEERROR 1004 "Undefined function in Apply" (CONS FN ARGS)))) (T % Do EXPR's, NEXPR's, FEXPR's and MACRO's alike, a % EXPR's (RETURN (APPLY (CDR DEFN) ARGS)))))) [??? Instead, could check for specific function types in Apply ???] [??? Instead, could check for specific function types in Apply ???] [??? Instead, could check for specific function types in Apply ???] 11.2. Support Functions for Eval and Apply 11.2. Support Functions for Eval and Apply 11.2. Support Functions for Eval and Apply EvLis EvLis _ ___ ____ ___ ____ ____ (EvLis U:any-list): any-list expr EvLis EvLis ____ _ EvLis returns a list of the evaluation of each element of U. LambdaApply LambdaApply __ ______ _ ___ ____ ___ ____ (LambdaApply FN:lambda, U:any-list): any expr __ ______ ______ Checks that FN is a legal lambda, binds the formals of the lambda LBind1 EvProgN LBind1 _ EvProgN using LBind1 to the arguments in U, and then uses EvProgN to ______ evaluate the forms in the lambda body. Finally the formals are UnBindN UnBindN unbound, using UnBindN, and the result returned. The Interpreter 7 February 1983 PSL Manual page 11.6 section 11.2 LambdaEvalApply LambdaEvalApply __ ______ _ ____ ____ ___ ____ (LambdaEvalApply FN:lambda, U:form-list): any expr LambdaApply EvLis LambdaApply __ EvLis _ Essentially LambdaApply(FN,EvLis(U)), though done more efficiently. CodeApply CodeApply __ ____ _______ _ ___ ____ ___ ____ (CodeApply FN:code-pointer, U:any-list): any expr _ Efficiently spreads the arguments in U into the "registers", and __ then transfers to the starting address referred to by FN CodeEvalApply CodeEvalApply __ ____ _______ _ ___ ____ ___ ____ (CodeEvalApply FN:code-pointer, U:any-list): any expr CodeApply EvLis CodeApply __ EvLis _ Essentially CodeApply(FN,EvLis(U)), though more efficient. The following entry points are used to get efficient calls on named functions, and are open compiled. IdApply0 IdApply0 __ __ ___ ____ (IdApply0 FN:id): any expr IdApply1 IdApply1 __ ____ __ __ ___ ____ (IdApply1 A1:form, FN:id): any expr IdApply2 IdApply2 __ ____ __ ____ __ __ ___ ____ (IdApply2 A1:form, A2:form, FN:id): any expr IdApply3 IdApply3 __ ____ __ ____ __ ____ __ __ ___ ____ (IdApply3 A1:form, A2:form, A3:form, FN:id): any expr IdApply4 IdApply4 __ ____ __ ____ __ ____ __ ____ __ __ ___ ____ (IdApply4 A1:form, A2:form, A3:form, A4:form, FN:id): any expr EvProgN EvProgN _ ____ ____ ___ ____ (EvProgN U:form-list): any expr _ Evaluates each form in U in turn, returning the value of the ProgN ProgN last. Used for various implied ProgNs. 11.3. Special Evaluator Functions, Quote, and Function 11.3. Special Evaluator Functions, Quote, and Function 11.3. Special Evaluator Functions, Quote, and Function Quote Quote _ ___ ___ _____ (Quote U:any): any fexpr Eval _ Eval Returns U. Thus the argument is not evaluated by Eval. PSL Manual 7 February 1983 The Interpreter section 11.3 page 11.7 MkQuote MkQuote _ ___ ____ ____ (MkQuote U:any): list expr MkQuote List MkQuote _ List (MkQuote U) returns (List 'QUOTE U) Function Function __ ________ ________ _____ (Function FN:function): function fexpr __ __ The function FN is to be passed to another function. If FN is to have side effects its free variables must be FLUID or GLOBAL. Function Quote Function Quote Function is like Quote but its argument may be affected by compilation. [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] [??? Add FQUOTE, and make FUNCTION become CLOSURE ???] Closure Closure See also the discussion of Closure and related functions in Section 10.3. 11.4. Support Functions for Macro Evaluation 11.4. Support Functions for Macro Evaluation 11.4. Support Functions for Macro Evaluation Expand Expand _ ____ __ ________ ____ ____ (Expand L:list, FN:function): list expr __ FN is a defined function of two arguments to be used in the _____ _____ _____ macro Expand macro Expand ____ expansion of a macro. Expand returns a list in the form: (FN L[0] (FN L[1] ... (FN L[n-1] L[n]) ... )) _ "n" is the number of elements in L, L[i] is the i'th element of _ L. (DE EXPAND (L FN) (COND ((NULL (CDR L)) (CAR L)) (T (LIST FN (CAR L) (EXPAND (CDR L) FN))))) [??? Add RobustExpand (sure!) (document) ???] [??? Add RobustExpand (sure!) (document) ???] [??? Add RobustExpand (sure!) (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] [??? Add an Evalhook and Apply hook for CMU toplevel (document) ???] |
Added psl-1983/lpt/12-io.lpt version [e7b26fbeea].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Input and Output section 12.0 page 12.1 CHAPTER 12 CHAPTER 12 CHAPTER 12 INPUT AND OUTPUT INPUT AND OUTPUT INPUT AND OUTPUT 12.1. Introduction . . . . . . . . . . . . . . . 12.1 12.2. The Underlying Primitives for Input and Output. . . . 12.1 12.3. Opening, Closing, and Selecting Channels. . . . . . 12.5 12.4. Functions for Printing. . . . . . . . . . . . 12.8 12.5. Functions for Reading . . . . . . . . . . . . 12.16 12.5.1. Reading S-Expression . . . . . . . . . . 12.16 12.5.2. Reading Files into PSL . . . . . . . . . 12.17 12.5.3. Reading Single Characters . . . . . . . . 12.20 12.5.4. Reading Tokens . . . . . . . . . . . . 12.21 12.5.5. Read Macros . . . . . . . . . . . . . 12.30 12.6. Scan Table Utility Functions. . . . . . . . . . 12.31 12.7. I/O to and from Lists and Strings . . . . . . . . 12.32 12.8. Example of Simple I/O in PSL. . . . . . . . . . 12.34 12.1. Introduction 12.1. Introduction 12.1. Introduction Most LISP programs are written with no sophisticated I/O, so this chapter may be skimmed by those with simple I/O requirements. Section 12.8 contains an example showing the use of some I/O functions. This should help the beginning PSL user get started. Sections 12.5 and 12.6 deal extensively with customizing the scanner and reader, which is of interest only to the sophisticated user. 12.2. The Underlying Primitives for Input and Output 12.2. The Underlying Primitives for Input and Output 12.2. The Underlying Primitives for Input and Output All input and output functions are implemented in terms of operations on 1 _______ "channels". A channel is just a small integer which has 3 functions and some other information associated with it. The three functions are: a. A reading function, which is called with the channel as its _______ argument and returns the integer ASCII value of the next _______________ 1 The range of channel numbers is from 0 to MaxChannels, where MaxChannels is a system-dependent constant, currently 31, defined in IO-DATA.RED. MaxChannels is a WCONST, and is not available for use at runtime. Input and Output 7 February 1983 PSL Manual page 12.2 section 12.2 character of the input stream. If the channel is for writing WriteOnlyChannel WriteOnlyChannel only, this function is WriteOnlyChannel. If the channel has not ChannelNotOpen ChannelNotOpen been opened, this function is ChannelNotOpen. The reading function is responsible for echoing characters if the flag WriteChar WriteChar !*ECHO is T. It should use the function WriteChar to echo the character. It may not be appropriate for a read function to echo characters. For example, the "disk" reading function does Compress Compress echoing, while the reader used to implement the Compress function does not. The read function must also be concerned with the handling of ends of "files" (actually, ends of channels) and ends of lines. It should return the ASCII code for an end of file character (system dependent) when reaching the end of a channel. It should return the ASCII code for a line feed character to indicate an end of line (or "newline"). This may require that the ASCII code for carriage return be ignored when read, not returned. b. A writing function, which is called with the channel as its _______ first argument and the integer ASCII value of the character to write as its second argument. If the channel is for reading ReadOnlyChannel ReadOnlyChannel only, this function is ReadOnlyChannel. If the channel has not ChannelNotOpen ChannelNotOpen been opened, this function is ChannelNotOpen. c. A closing function, which is called with the channel as its argument and performs any action necessary for the graceful termination of input and/or output operations to that channel. ChannelNotOpen ChannelNotOpen If the channel is not open, this function is ChannelNotOpen. The other information associated with a channel includes the current Posn Posn position in the output line (used by Posn), the maximum line length allowed LineLength LineLength (used by LineLength and the printing functions), the single character input backup buffer (used by the token scanner), and other system-dependent information. Ordinarily, the user need not be aware of the existence of this mechanism. However, because of its generality, it is possible to implement operations other than just reading from and writing to files using it. In Explode Compress Explode Compress particular, the LISP functions Explode and Compress are performed by ____ ____ writing to a list and reading from a list, respectively (on channels 3 and 4 respectively). Ordinarily, user interaction with the system is done by reading from the standard input channel and writing to the standard output channel. These are 0 and 1 respectively, to which the GLOBAL variables STDIN!* and STDOUT!* are bound. These channels usually refer to the user's terminal, and cannot be closed. Other files are accessed by calling the function Open Open Open, which returns a channel. Most functions which perform input and output come in two forms, one which takes a channel as its first argument, Rds Rds and one which uses the "currently selected channel". The functions Rds and PSL Manual 7 February 1983 Input and Output section 12.2 page 12.3 Wrs Wrs Wrs are used to change the currently selected input and output channels. The GLOBAL variables IN!* and OUT!* are bound to these channels. GLOBAL variables containing information about channels are listed below. __________ ______ IN!* [Initially: 0] global Contains the currently selected input channel. This is changed Rds Rds by the function Rds. __________ ______ OUT!* [Initially: 1] global Contains the currently selected output channel. This is changed Wrs Wrs by the function Wrs. __________ ______ STDIN!* [Initially: 0] global The standard input channel. __________ ______ STDOUT!* [Initially: 1] global The standard output channel. __________ ______ BREAKIN!* [Initially: NIL] global BREAK BREAK The channel from which the BREAK loop gets its input. It has been set to default to STDIN!*, but may have to be changed on some systems with buffered-IO. __________ ______ BREAKOUT!* [Initially: NIL] global BREAK BREAK The channel to which the BREAK loop sends its output. It has been set to default to STDOUT!*, but may have to be changed on some systems with buffered-IO. __________ ______ HELPIN!* [Initially: NIL] global Help Help The channel used for input by the Help mechanism. __________ ______ HELPOUT!* [Initially: NIL] global Help Help The channel used for output by the Help mechanism. Input and Output 7 February 1983 PSL Manual page 12.4 section 12.2 __________ ______ ERROUT!* [Initially: 1] global ErrorPrintF ErrorPrintF The channel used by the ErrorPrintF. __________ ______ PROMPTSTRING!* [Initially: "lisp>"] global Displayed as a prompt when any input is taken from TTY. Thus prompts should not be directly printed. Instead the value should be bound to PROMPTSTRING!*. 12.3. Opening, Closing, and Selecting Channels 12.3. Opening, Closing, and Selecting Channels 12.3. Opening, Closing, and Selecting Channels Open Open ________ ______ __________ __ _______ __ _______ ____ (Open FILENAME:string ACCESSTYPE:id): CHANNEL:io-channel expr Eq __________ Eq If ACCESSTYPE is Eq to INPUT or OUTPUT, an attempt is made to ________ access the system-dependent FILENAME for reading or writing. If the attempt is unsuccessful, an error is generated; otherwise a free channel is returned and initialized to the default conditions for ordinary file input or output. Eq __________ Eq If ACCESSTYPE is Eq to SPECIAL and the GLOBAL variables SPECIALREADFUNCTION!*, SPECIALWRITEFUNCTION!*, and __ SPECIALCLOSEFUNCTION!* are bound to ids, then a free channel is returned and its associated functions are set to the values of these variables. Other non system-dependent status is set to default conditions, which can later be overridden. The functions ReadOnlyChannel WriteOnlyChannel ReadOnlyChannel WriteOnlyChannel ReadOnlyChannel and WriteOnlyChannel are available as error ________ handlers. The parameter FILENAME is used only if an error occurs. [??? We should replace these globals and SPECIAL option by a [??? We should replace these globals and SPECIAL option by a [??? We should replace these globals and SPECIAL option by a (SPECIALOPEN Readfunction writefunction closefunction) call (SPECIALOPEN Readfunction writefunction closefunction) call (SPECIALOPEN Readfunction writefunction closefunction) call ???] ???] ???] If none of these conditions hold, a file is not available, or there are no free channels, an error is generated. ***** Unknown access type ***** Improperly set-up special IO open call ***** File not found ***** No free channels FileP FileP One can use FileP to find out whether a file exists. PSL Manual 7 February 1983 Input and Output section 12.3 page 12.5 FileP FileP ____ ______ _______ ____ (FileP NAME:string): boolean expr ____ This function will return T if file NAME can be opened, and NIL if not, e.g. if it does not exist. Close Close _______ __ _______ __ _______ ____ (Close CHANNEL:io-channel): io-channel expr _______ The closing function associated with CHANNEL is called, with _______ _______ CHANNEL as its argument. If it is illegal to close CHANNEL, if _______ _______ CHANNEL is not open, or if CHANNEL is associated with a file and the file cannot be closed by the operating system, this function _______ generates an error. Otherwise, CHANNEL is marked as free and is returned. Shut Shut _ ______ ____ ________ _____ (Shut [L:string]): None Returned macro Shut _ Shut Closes the output files in the list L. Note that Shut takes file Close Close __ _______ names as arguments, while Close takes an io-channel. The RLISP IN IN IN function maintains a stack of file-name . io-channel shut shut associations for this purpose. Thus a shut will also correctly select the previous file for further output. EvShut EvShut _ ______ ____ ____ ________ ____ (EvShut L:string-list): none Returned expr Shut Shut Does the same as Shut but evaluates its arguments. Rds Rds _______ __ _______ ___ __ _______ ____ (Rds {CHANNEL:io-channel, NIL}): io-channel expr Rds Rds Rds sets IN!* to the value of its argument, and returns the previous value of IN!*. In addition, if SPECIALRDSACTION!* is non-NIL, it should be a function of 2 arguments, which is called _______ _______ with the old CHANNEL as its first argument and the new CHANNEL as Rds Rds Rds Rds its second argument. Rds(NIL) does the same as Rds(STDIN!*). Wrs Wrs _______ __ _______ ___ __ _______ ____ (Wrs {CHANNEL:io-channel, NIL}): io-channel expr Wrs Wrs Wrs sets OUT!* to the value of its argument and returns the previous value of OUT!*. In addition, if SPECIALWRSACTION!* is non-NIL, it should be a function of 2 arguments, which is called _______ _______ with the old CHANNEL as its first argument and the new CHANNEL as Wrs Wrs Wrs Wrs its second argument. Wrs(NIL) does the same as Wrs(STDOUT!*). Out Out _ ______ ____ ________ _____ (Out U:string): None Returned macro _ Opens file U for output, redirecting standard output. Note that Out Wrs Out ______ Wrs __ _______ Out takes a string as an argument, while Wrs takes an io-channel. Input and Output 7 February 1983 PSL Manual page 12.6 section 12.3 EvOut EvOut _ ______ ____ ____ ________ ____ (EvOut L:string-list): None Returned expr _ L is a list containing one file name which must be a string. EvOut Out EvOut Out EvOut is the called by Out after evaluating its argument. The reading and writing functions come in two flavors: those that read or RDS WRS RDS WRS write to the current channel, as set by a previous RDS or WRS into IN!* or OUT!*, and those that explicitly designate the desired input or output Channel Channel channel. The latter typically have a Channel as part of their name. ________ The following GLOBALs are used by the functions in this section. __________ ______ SPECIALCLOSEFUNCTION!* [Initially: NIL] global __________ ______ SPECIALRDSACTION!* [Initially: NIL] global __________ ______ SPECIALREADFUNCTION!* [Initially: NIL] global __________ ______ SPECIALWRITEFUNCTION!* [Initially: NIL] global __________ ______ SPECIALWRSACTION!* [Initially: NIL] global 12.4. Functions for Printing 12.4. Functions for Printing 12.4. Functions for Printing ChannelWriteChar ChannelWriteChar _______ __ _______ __ _________ _________ ____ (ChannelWriteChar CHANNEL:io-channel CH:character): character expr _______ Write one character to CHANNEL. All output is defined in terms __ of this function. If CH is equal to char EOL (ASCII LF, 8#12) _______ the line counter POSN associated with CHANNEL is set to zero. Otherwise, it is increased by one. The writing function _______ _______ __ associated with CHANNEL is called with CHANNEL and CH as its arguments. WriteChar WriteChar __ _________ _________ ____ (WriteChar CH:character): character expr Write single character to current output. (de WRITECHAR (CH) (CHANNELWRITECHAR OUT!* CH)) PSL Manual 7 February 1983 Input and Output section 12.4 page 12.7 ChannelPrin1 ChannelPrin1 ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrin1 CHAN:io-channel ITM:any): ITM:any expr ChannelPrin1 ChannelPrin1 ChannelPrin1 is the basic LISP printing function. For well-formed, non-circular (non-self-referential) structures, the Read Read result can be parsed by the function Read. ______ - Strings are printed surrounded by double quotes ("). __ - Delimiters inside ids are preceded by the escape character (!). _____ - Floats are printed as {-}nnn.nnn{E{-}nn}. _______ - Integers are printed as {-}nnn, unless the value of OUTPUTBASE!* is not 10, in which case they are printed as {-}r#nnn; r is the value of OutPutBase!*. ____ - Pairs are printed in list-notation. For example, (a . (b . c)) is printed as (a b . c) while (a . (b . (c . NIL))) is printed as (a b c) ______ ______ - Vectors are printed in vector-notation; a vector of three elements a, b, and c is printed as [a b c]. Read Read The following items can be printed, but cannot be parsed by Read. ____ _______ - code-pointers are printed as ________ _____ _____ _______ _____ _______ #<Code argument-count octal-address>. where octal-address is the octal machine address of the entry point of the code Input and Output 7 February 1983 PSL Manual page 12.8 section 12.4 ______ ________ _____ vector, and argument-count is the number of arguments that the code takes. The argument count cannot always be determined, in which case nothing is printed for the ________ _____ argument-count. - Anything else is printed as #<Unknown:nnnn>, where nnnn is the octal value found in the argument register. Such items are not legal LISP entities and may cause garbage collector errors if they are found in the heap. Prin1 Prin1 ___ ___ ___ ___ ____ (Prin1 ITM:any): ITM:any expr ErrPrin ErrPrin _ ___ ____ ________ ____ (ErrPrin U:any): None Returned expr Prin1 Prin1 _ Prin1 with special quotes to highlight U. ChannelPrin2 ChannelPrin2 ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrin2 CHAN:io-channel ITM:any): ITM:any expr ChannelPrin2 ChannelPrin1 ChannelPrin2 ChannelPrin1 ______ ChannelPrin2 is similar to ChannelPrin1, except that strings are printed without the surrounding double quotes, and delimiters __ within ids are not preceded by the escape character. Prin2 Prin2 ___ ___ ___ ___ ____ (Prin2 ITM:any): ITM:any expr ChannelPrinC ChannelPrinC ____ __ _______ ___ ___ ___ ___ ____ (ChannelPrinC CHAN:io-channel ITM:any): ITM:any expr ChannelPrint2 ChannelPrint2 Same function as ChannelPrint2. PrinC PrinC ___ ___ ___ ___ ____ (PrinC ITM:any): ITM:any expr Prin2 Prin2 Same function as Prin2. ChannelPrint ChannelPrint ____ __ _______ _ ___ _ ___ ____ (ChannelPrint CHAN:io-channel U:any): U:any expr ChannelPrin1 _ ChannelPrin1 Display U using ChannelPrin1 and terminate line using ChannelTerpri ChannelTerpri ChannelTerpri. Print Print _ ___ _ ___ ____ (Print U:any): U:any expr ChannelPrint ChannelPrint _ ChannelPrint U to current output channel, OUT!*. PSL Manual 7 February 1983 Input and Output section 12.4 page 12.9 ChannelPrintF ChannelPrintF ____ __ _______ ______ ______ ____ ___ ___ ____ (ChannelPrintF CHAN:io-channel FORMAT:string [ARGS:any]): NIL expr ChannelPrintF ChannelPrintF ChannelPrintF is a simple routine for formatted printing, similar ______ to the function with the same name in the C language[22]. FORMAT ______ is either a LISP or SYSLISP string, which is printed on the currently selected output channel. However, if a % is ______ encountered in the string, the character following it is a formatting directive, used to interpret and print the other ChannelPrintF ChannelPrintF arguments to ChannelPrintF in order. The following format characters are currently supported: - For SYSLISP arguments, use: _______ %d print the next argument as a decimal integer _______ %o print the next argument as an octal integer _______ %x print the next argument as a hexadecimal integer %c print the next argument as a single character ______ %s print the next argument as a string - For LISP tagged items, use: %p print the next argument as a LISP item, using Prin1 Prin1 Prin1 %w print the next argument as a LISP item, using Prin2 Prin2 Prin2 %r print the next argument as a LISP item, using ErrPrin Prin2 Prin1 Prin2 ErrPrin Prin2 Prin1 Prin2 ErrPrin (Ordinarily Prin2 "`"; Prin1 Arg; Prin2 "'" ) %l same as %w, except lists are printed without top level parens; NIL is printed as a blank %e eval the next argument for side-effect -- most eval eval useful if the thing evaled does some printing - Control formats: %b take next argument as an integer and print that many blanks %f "fresh-line", print an end-of-line character if not at the beginning of the output line (does not use a matching argument) %n print end-of-line character (does not use a matching argument) %t take the next argument as an integer, and ChannelTab ChannelTab ChannelTab to that position Input and Output 7 February 1983 PSL Manual page 12.10 section 12.4 If the character following % is not either one of the above or another %, it causes an error. Thus, to include a % in the format to be printed, use %%. There is no checking for correspondence between the number of ______ arguments the FORMAT expects and the number given. If the number ______ given is less than the number in the FORMAT string, then garbage will be inserted for the missing arguments. If the number given ______ is greater than the number in the FORMAT string, then the extra ones are ignored. PrintF PrintF ______ ______ ____ ___ ___ ____ (PrintF FORMAT:string [ARGS:any]): NIL expr ChannelPrintF ChannelPrintF ChannelPrintF to the current output channel, OUT!*. ErrorPrintF ErrorPrintF ______ ______ ____ ___ ___ ____ (ErrorPrintF FORMAT:string [ARGS:any]): NIL expr ErrorPrintF PrintF ErrorPrintF PrintF ErrorPrintF is similar to PrintF, except that instead of using the currently selected output channel, ERROUT!* is used. Also, an end-of-line character is always printed after the message, and an end-of-line character is printed before the message if the line position of ERROUT!* is greater than zero. ChannelTerPri ChannelTerPri ____ __ _______ ___ ____ (ChannelTerPri CHAN:io-channel): NIL expr ____ Terminate OUTPUT line on channel CHAN, and reset the POSN counter to 0. TerPri TerPri ___ ____ (TerPri ): NIL expr Terminate current OUTPUT line, and reset the POSN counter to 0. ChannelEject ChannelEject ____ __ _______ ___ ____ (ChannelEject CHAN:io-channel): NIL expr ____ Skip to top of next output page on channel CHAN. Eject Eject ___ ____ (Eject ): NIL expr Skip to top of next output page on current output channel. ChannelPosn ChannelPosn ____ __ _______ _______ ____ (ChannelPosn CHAN:io-channel): integer expr Returns number of characters output on this line (i.e. POSN counter since last Terpri) on this channel. PSL Manual 7 February 1983 Input and Output section 12.4 page 12.11 Posn Posn _______ ____ (Posn ): integer expr Returns number of characters output on this line (i.e. POSN counter since last Terpri) ChannelLPosn ChannelLPosn ____ __ _______ _______ ____ (ChannelLPosn CHAN:io-channel): integer expr LPosn LPosn Returns number of lines output on this page (i.e. LPosn counter since last Eject) on this channel. LPosn LPosn _______ ____ (LPosn ): integer expr LPosn LPosn Returns number of lines output on this page (i.e. LPosn counter since last Eject). ChannelLineLength ChannelLineLength ____ __ _______ ___ _______ ___ _______ ____ (ChannelLineLength CHAN:io-channel LEN:{integer, NIL}): integer expr ____ _______ Set maximum output line length on CHAN if a positive integer, returning previous value. If NIL just return previous value. Terpri Terpri Controls the insertion of automatic Terpri's. LineLength LineLength ___ _______ ___ _______ ____ (LineLength LEN:{integer, NIL}): integer expr Set maximum output line length on current channel OUT!* if a _______ positive integer, returning previous value. If NIL just return Terpri Terpri previous value. Controls the insertion of automatic Terpri's. RPrint RPrint _ ____ ___ ____ (RPrint U:form): NIL expr Print in RLISP format. Autoloading. PrettyPrint PrettyPrint _ ____ _ ____ (PrettyPrint U:form): U expr _ Prettyprints U. Autoloading. Prin2L Prin2L _ ___ _ ____ (Prin2L L:any): L expr Prin2 Prin2 ____ Prin2, except that a list is printed without the top level parens. ChannelSpaces ChannelSpaces ____ __ _______ _ _______ ___ ____ (ChannelSpaces CHAN:io-channel N:integer): NIL expr ChannelPrin2 ChannelPrin2 _ _ ChannelPrin2 N spaces. Will continue across multiple lines if N is greater than the number of positions in the output buffer. Input and Output 7 February 1983 PSL Manual page 12.12 section 12.4 POSN LINELENGTH POSN LINELENGTH (See POSN and LINELENGTH) Spaces Spaces _ _______ ___ ____ (Spaces N:integer): NIL expr Prin2 Prin2 _ Prin2 N spaces. ChannelPrin2T ChannelPrin2T ____ __ _______ _ ___ ___ ____ (ChannelPrin2T CHAN:io-channel X:any): any expr ChannelPrin2 _ ChannelPrin2 Output X using ChannelPrin2 and terminate line with ChannelTerpri ChannelTerpri ChannelTerpri. Prin2T Prin2T _ ___ ___ ____ (Prin2T X:any): any expr ChannelPrin2T ChannelPrin2T _ ChannelPrin2T X to the current output channel, OUT!*. ChannelTab ChannelTab ____ __ _______ _ _______ ___ ____ (ChannelTab CHAN:io-channel N:integer): NIL expr _ ____ Move to position N on channel CHAN, emitting spaces as needed. ChannelTerPri ChannelTerPri _ Calls ChannelTerPri if past column N. Tab Tab _ _______ ___ ____ (Tab N:integer): NIL expr TerPri _ TerPri Move to position N, emitting spaces as needed. TerPri() if past _ column N. _________ __________ The fluid variables PRINLEVEL and PRINLENGTH allow the user to control how deep the printer will print and how many elements at a given level the printer will print. This is useful for debugging or dealing large or deep Prin1 Prin2 PrinC Print Prin1 Prin2 PrinC Print objects. These variables affect the functions Prin1, Prin2, PrinC, Print, PrintF PrintF and PrintF (and the corresponding Channel functions). The documentation of these variables is from the Common Lisp Manual. __________ ______ PRINLEVEL [Initially: Nil] global Controls how many levels deep a nested data object will print. _________ If PRINLEVEL is NIL, then no control is exercised. Otherwise the value should be an integer, indicating the maximum level to be printed. An object to be printed is at level 0. __________ ______ PRINLENGTH [Initially: Nil] global Controls how many elements at a given level are printed. A value of NIL indicates that there be no limit to the number of __________ components printed. Otherwise the value of PRINLENGTH should be an integer. PSL Manual 7 February 1983 Input and Output section 12.5 page 12.13 12.5. Functions for Reading 12.5. Functions for Reading 12.5. Functions for Reading 12.5.1. Reading S-Expression 12.5.1. Reading S-Expression 12.5.1. Reading S-Expression ChannelRead ChannelRead ____ __ _______ ___ ____ (ChannelRead CHAN:io-channel): any expr ____ Reads and returns the next S-expression from input channel CHAN. Valid input forms are: vector-notation, pair-notation, list- ______ ____ _______ ______ __________ notation, numbers, code-pointers, strings, and identifiers. Intern __________ Intern Identifiers are interned (see the Intern function in Chapter 6), ChannelRead ChannelRead unless the FLUID variable !*COMPRESSING is non-NIL. ChannelRead returns the value of the global variable !$EOF!$ when the end of the currently selected input channel is reached. ChannelRead ChannelReadToken ChannelRead ChannelReadToken ChannelRead uses the ChannelReadToken function, with tokens scanned according to the "Lisp scan table". The user can define similar read functions for use with other scan tables. ____ _____ ____ _____ ____ _____ ChannelRead Read macro ChannelRead Read macro ChannelRead uses the Read macro mechanism to do S-expression parsing. See section 12.5.5 for more information on read macros and how to add extensions. The following read macros are defined initially: ( Starts a scan collecting S-expressions according to ____ ____ list or dot notation until terminated by a ). A pair ____ or list is returned. [ Starts a scan collecting S-expressions according to ______ vector notation until terminated by a ]. A vector is returned. Read Read ' Calls Read to get an S-expression, x, and then returns Quote Quote the list (Quote x). !$EOF!$ Generates an error when still inside an S-expression: ***** Unexpected EOF while reading on channel . Otherwise !$EOF!$ is returned. Read Read ___ ____ (Read ): any expr Reads and returns an S-expression from the current input channel. ChannelRead ChannelRead That is, it does a ChannelRead(IN!*). Input and Output 7 February 1983 PSL Manual page 12.14 section 12.5 12.5.2. Reading Files into PSL 12.5.2. Reading Files into PSL 12.5.2. Reading Files into PSL The following procedures are used to read complete files into PSL, by Open Open first calling Open, and then looping until end of file. The effect is similar to what would happen if the file were typed into PSL. Recall that file names are strings, and therefore one needs string-quotes (") around file names. File names may be given using full system dependent file name conventions, including directories and sub-directories, "links" and "logical-device-names", as appropriate on the specific system. __________ ______ !*ECHO [Initially: Nil] switch ____ The switch !*ECHO is used to control the echoing of input. When (On Echo) is placed in an input file, the contents of the file Dskin Dskin are echoed on the standard output device. Dskin does not change ____ the value of !*ECHO, so one may say (On Echo) before calling Dskin Dskin Dskin, and the input will be echoed. DskIn DskIn _ ______ ____ ________ ____ (DskIn F:string): None Returned expr Read Eval Print Read Eval Print _ Enters a Read-Eval-Print loop on the contents of the file F. DskIn DskIn _ DskIn expects LISP syntax in the file F. Use the following format: (DskIn "File"). LapIn LapIn _ ______ ____ ________ ____ (LapIn U:string): None Returned expr Reads a single LISP file as "quietly" as possible, i.e., it does LapIn LapIn not echo or return values. Note that LapIn can be used only for LISP files. By convention, files with the extension ".LAP" are LapIn LapIn intended to be read by LapIn. These files are typically used to load modules made up of several binary (also known as FASL) Load Load files. The use of the Load function is normally preferable to LapIn LapIn using LapIn. For information about fast loading of files of Load FaslIn Load FaslIn compiled functions (FASL files) see FASL and the Load and FaslIn functions in Chapter 18. The following functions are present in RLISP, they can be used from Bare-PSL by loading RLISP. In In _ ______ ____ ________ _____ (In [L:string]): None Returned macro DskIn DskIn Similar to DskIn but expects RLISP syntax in the files it reads unless it can determine that the files are not in RLISP syntax. In In Also In can take more than one file name as an argument. On most In In systems the function In expects files with extension .LSP and .SL to be written in LISP syntax, not in RLISP. This is convenient when using both LISP and RLISP files. It is conventional to use the extension .RED (or .R) for RLISP files and use .LSP or .SL PSL Manual 7 February 1983 Input and Output section 12.5 page 12.15 only for fully parenthesized LISP files. There are some system programs, such as TAGS on the DEC-20, which expect RLISP files to have the extension .RED. If it is not desired to have the contents of the file echoed as In In it is read, either end the In command with a "$" in RLISP, as In "FILE1.RED","FILE2.SL"$ Off Off ____ or include the statement "Off ECHO;" in your file. PathIn PathIn ________ ____ ______ ____ ________ ____ (PathIn FileName-Tail:string): None Returned expr IN IN Allows the use of a directory search path with the Rlisp IN function. It finds a list of search paths in the fluid variable PATHIN!*. These are successively concatenated onto the front of PathIn PathIn the string argument to PathIn until an existing file is found FileP In FileP In (using FileP. If one is found, In will be invoked on this file. If not, a continuable error occurs. For example on the VAX, (Setq PathIn!* '( "" "/u/psl/" "/u/smith/")) (PathIn "foo.red") will attempt to open "foo.red", then "/u/psl/foo.red", and finally "/u/smith/foo.red" until a successful open is achieved. Pathin Pathin To use Pathin in Bare-PSL, load PATHIN as well as RLISP. EvIn EvIn _ ______ ____ ____ ________ ____ (EvIn L:string-list): None Returned expr EvIn _ EvIn L must be a list of strings that are filenames. EvIn is the In In In In function called by In after evaluating its arguments. In is EvIn EvIn useful only at the top-level, while EvIn can be used inside functions with file names passed as parameters. 12.5.3. Reading Single Characters 12.5.3. Reading Single Characters 12.5.3. Reading Single Characters ChannelReadChar ChannelReadChar _______ __ _______ _________ ____ (ChannelReadChar CHANNEL:io-channel): character expr _______ _______ Reads one character (an integer) from CHANNEL. All input is _______ defined in terms of this function. If CHANNEL is not open or is open for writing only, an error is generated. If there is a _______ non-zero value in the backup buffer associated with CHANNEL, the buffer is emptied (set to zero) and the value returned. _______ Otherwise, the reading function associated with CHANNEL is called _______ with CHANNEL as argument, and the value it returns is returned by ChannelReadChar ChannelReadChar ChannelReadChar. Input and Output 7 February 1983 PSL Manual page 12.16 section 12.5 ***** Channel not open ***** Channel open for write only ReadChar ReadChar _________ ____ (ReadChar ): character expr Reads one character from the current input channel. ChannelReadCH ChannelReadCH ____ __ _______ __ ____ (ChannelReadCH CHAN:io-channel): id expr ChannelReadChar ChannelReadChar __ Like ChannelReadChar, but returns the id for the character rather than its ASCII code. ReadCH ReadCH __ ____ (ReadCH ): id expr ChannelReadCH ChannelReadCH ChannelReadCH from the current input channel. ChannelUnReadChar ChannelUnReadChar ____ __ _______ __ _________ _________ ____ (ChannelUnReadChar CHAN:io-channel CH:character): Undefined expr __ The input backup function. CH is deposited in the backup buffer ____ associated with CHAN. This function should be only called after ChannelReadChar ChannelReadChar ChannelReadChar is called, before any intervening input operations, since it is used by the token scanner. UnReadChar UnReadChar __ _________ _________ ____ (UnReadChar CH:character): Undefined expr Backup on the current input channel. 12.5.4. Reading Tokens 12.5.4. Reading Tokens 12.5.4. Reading Tokens The functions described here pertain to the token scanner and reader. Globals and switches used by these functions are defined at the end of this section. ChannelReadToken ChannelReadToken _______ __ _______ __ ______ ______ ____ (ChannelReadToken CHANNEL:io-channel): {id, number, string} expr This is the basic LISP token scanner. The value returned is a LISP item corresponding to the next token from the input stream. __ Ids are interned, unless the FLUID variable !*COMPRESSING is non-NIL. The GLOBAL variable TOKTYPE!* is set to: __ 0 if the token is an ordinary id, ______ 1 if the token is a string, ______ 2 if the token is a number, or PSL Manual 7 February 1983 Input and Output section 12.5 page 12.17 3 if the token is an unescaped delimiter. __ In the last case, the value returned is the id whose print name is the same as the delimiter. The precise behavior of this function depends on two FLUID variables: CURRENTSCANTABLE!* ______ Is bound to a vector known as a scan table. Described below. CURRENTREADMACROINDICATOR!* __ Bound to an id known as a read macro indicator. Described below. Scan tables have 129 entries, indexed by 0 through 128. 0 _______ through 127 are indexed by ASCII character code to get an integer code determining the treatment of the corresponding character. _______ __ The last entry is not an integer, but rather an id which _________ _________ specifies a Diphthong Indicator for the token scanner. [??? A future implementation may replace the FLUID [??? A future implementation may replace the FLUID [??? A future implementation may replace the FLUID CURRENTREADMACROINDICATOR!* with another entry in the scan CURRENTREADMACROINDICATOR!* with another entry in the scan CURRENTREADMACROINDICATOR!* with another entry in the scan table. ???] table. ???] table. ???] The following encoding for characters is used. 0 ... 9 DIGIT: indicates the character is a digit, and gives the corresponding numeric value. 10 LETTER: indicates that the character is a letter. 11 DELIMITER: indicates that the character is a delimiter which is not the starting character of a diphthong. 12 COMMENT: indicates that the character begins a comment terminated by an end of line. 13 DIPHTHONG: indicates that the character is a delimiter which may be the starting character of a diphthong. (A diphthong is a two character sequence read as one token, i.e., "<<" or ":=".) 14 IDESCAPE: indicates that the character is an escape character, to cause the following character to be taken __ as part of an id. (Ordinarily an exclamation point, i.e. "!".) 15 STRINGQUOTE: indicates that the character is a string quote. (Ordinarily a double quote, i.e. '"'.) 16 PACKAGE: indicates that the character is used to introduce explicit package names. (Ordinarily "\".) 17 IGNORE: indicates that the character is to be ignored. Input and Output 7 February 1983 PSL Manual page 12.18 section 12.5 (Ordinarily BLANK, TAB, EOL and NULL.) 18 MINUS: indicates that the character is a minus sign. 19 PLUS: indicates that the character is a plus sign. 20 DECIMAL: indicates that the character is a decimal point. 21 IDSURROUND: indicates that the character is to act for identifiers as a string quote acts for strings. Although this is not used in the default scan table, the intended character for this function is a vertical bar, |.) System builders who wish to define their own parsers can bind an appropriate scan table to CURRENTSCANTABLE!* and then call ChannelReadToken ChannelReadTokenWithHooks ChannelReadToken ChannelReadTokenWithHooks ChannelReadToken or ChannelReadTokenWithHooks for lexical scanning. Utility functions for building scan tables are described in the next section. The following standards for scanning tokens are used. __ - Ids begin with a letter or any character preceded by an escape character. They may contain letters, digits and __ escaped characters. Ids may also start with a digit, if the first non-digit following is a plus sign, minus sign, or letter other than "b" or "e". This is to allow identifiers such as "1+" which occur in some LISPs. Finally, a string of characters bounded by the IDSURROUND character is treated __ as an id. If !*RAISE is non-NIL, unescaped lower case letters are __ folded to upper case. The maximum size of an id (or any other token) is currently 5000 characters. __________ Note: Using lower case letters in identifiers may cause portability problems. Lower case letters are automatically converted to upper case if the !*RAISE switch is T. This __ case conversion is done only for id input, not for single character or string input. [??? Can we retain input Case, but Compare RAISEd ???] [??? Can we retain input Case, but Compare RAISEd ???] [??? Can we retain input Case, but Compare RAISEd ???] Here are some examples, using the RLISP scan table. Note that the first and second examples are read as the same identifier if !*RAISE is T. The fourth and fifth examples are read as the same identifier. * ThisIsALongIdentifier * THISISALONGIDENTIFIER * ThisIsALongIdentifierAndDifferentFromTheOther * this_is_a_long_identifier_with_underscores PSL Manual 7 February 1983 Input and Output section 12.5 page 12.19 * this!_is!_a!_long!_identifier!_with!_underscores * an!-identifier!-with!-dashes * !*RAISE * !2222 The following examples show the same identifiers in a form accepted by the LISP scan table. Note that most characters are treated as letters by the LISP scan table, while they are treated as delimiters by the RLISP scan table. * ThisIsALongIdentifier * THISISALONGIDENTIFIER * ThisIsALongIdentifierAndDifferentFromTheOther * this_is_a_long_identifier_with_underscores * this!_is!_a!_long!_identifier!_with!_underscores * an-identifier-with-dashes * *RAISE * !2222 ______ - Strings begin with a double quote (") and include all characters up to a closing double quote. A double quote can ______ ______ be included in a string by doubling it. An empty string, consisting of only the enclosing quote marks, is allowed. ______ The characters of a string are not affected by the value of the !*RAISE. Examples: * "This is a string" * "This is a ""string""" * "" ____ _______ - Code-pointers cannot be read directly, but can be printed and constructed. Currently printed as ________ _____ _____ _______ #<Code argument-count octal-address>. _______ - Integers begin with a digit, optionally preceded by a + or - sign, and consist only of digits. The GLOBAL input radix is 10; there is no way to change this. However, numbers of different radices may be read by the following convention. A decimal number from 2 to 36 followed by a sharp sign (#), causes the digits (and possibly letters) that follow to be 2 read in the radix of the number preceding the #. Thus 63 _______________ 2 Octal numbers can also be written as a string of digits followed by the letter "B". This "feature" may be removed in the future. Input and Output 7 February 1983 PSL Manual page 12.20 section 12.5 may be entered as 8#77, or 255 as 16#ff or 16#FF. The output radix can be changed, by setting OUTPUTBASE!*. If _______ OutPutBase!* is not 10, the printed integer appears with appropriate radix. Leading zeros are suppressed and a minus _______ sign precedes the digits if the integer is negative. Examples: * 100 * +5234 * -8#44 (equal to -36) [??? Should we permit trailing . in integers for [??? Should we permit trailing . in integers for [??? Should we permit trailing . in integers for compatibility with some LISPs and require digits on each compatibility with some LISPs and require digits on each compatibility with some LISPs and require digits on each side of . for floats ???] side of . for floats ???] side of . for floats ???] _____ - Floats have a period and/or a letter "e" or "E" in them. _____ Any of the following are read as floats. The value appears in the format [-]n.nn...nnE[-]mm if the magnitude of the number is too large or small to display in [-]nnnn.nnnn format. The crossover point is determined by the _____ implementation. In BNF, floats are recognized by the grammar: <base> ::= <unsigned-integer>.| .<unsigned-integer>| <unsigned-integer>.<unsigned-integer> <ebase> ::= <base>|<unsigned-integer> <unsigned-float> ::= <base>| <ebase>e<unsigned-integer>| <ebase>e-<unsigned-integer>| <ebase>e+<unsigned-integer>| <ebase>E<unsigned-integer>| <ebase>E-<unsigned-integer>| <ebase>E+<unsigned-integer> <float> ::= <unsigned-float>| +<unsigned-float>| -<unsigned-float> That is: * [+|-][nnn][.]nnn{e|E}[+|-]nnn * nnn. * .nnn * nnn.nnn Examples: PSL Manual 7 February 1983 Input and Output section 12.5 page 12.21 * 1e6 * .2 * 2. * 2.0 * -1.25E-9 RAtom RAtom __ ______ ______ ____ (RAtom ): {id, number, string} expr Reads a token from the current input channel. (Not called ReadToken ReadToken ReadToken for historical reasons.) [??? Should we bind CurrentScanTable!* for this function too [??? Should we bind CurrentScanTable!* for this function too [??? Should we bind CurrentScanTable!* for this function too ???] ???] ???] __________ ______ !*COMPRESSING [Initially: NIL] switch ChannelReadToken ChannelReadToken If !*COMPRESSING is non-NIL, ChannelReadToken does not intern __ ids. __________ ______ !*EOLINSTRINGOK [Initially: NIL] switch If !*EOLINSTRINGOK is non-NIL, the warning message *** STRING CONTINUED OVER END-OF-LINE is suppressed. __________ ______ !*RAISE [Initially: T] switch __ If !*RAISE is non-NIL, all characters input for ids through PSL input functions are raised to upper case. If !*RAISE is NIL, ______ characters are input as is. A string is unaffected by !*RAISE. __________ ______ CURRENTSCANTABLE!* [Initially: ] global Read Read This variable is set to LISPSCANTABLE!* by the Read function (the "Lisp syntax" reader). The RLISP reader sets it to RLISPSCANTABLE!* or LISPSCANTABLE!* depending on the syntax it expects. Input and Output 7 February 1983 PSL Manual page 12.22 section 12.5 __________ ______ LISPSCANTABLE!* [Initially: as shown in following table] global 0 ^@ IGNORE 32 IGNORE 64 @ LETTER 96 ` DELIMITER 1 ^A LETTER 33 ! IDESCAPECHAR 65 A LETTER 97 a LETTER 2 ^B LETTER 34 " STRINGQUOTE 66 B LETTER 98 b LETTER 3 ^C LETTER 35 # LETTER 67 C LETTER 99 c LETTER 4 ^D LETTER 36 $ LETTER 68 D LETTER 100 d LETTER 5 ^E LETTER 37 % COMMENTCHAR 69 E LETTER 101 e LETTER 6 ^F LETTER 38 & LETTER 70 F LETTER 102 f LETTER 7 ^G LETTER 39 ' DELIMITER 71 G LETTER 103 g LETTER 8 ^H LETTER 40 ( DELIMITER 72 H LETTER 104 h LETTER 9 <tab> IGNORE 41 ) DELIMITER 73 I LETTER 105 i LETTER 10 <lf> IGNORE 42 * LETTER 74 J LETTER 106 j LETTER 11 ^K LETTER 43 + PLUSSIGN 75 K LETTER 107 k LETTER 12 ^L IGNORE 44 , DIPHTHONGSTART 76 L LETTER 108 l LETTER 13 <cr> IGNORE 45 - MINUSSIGN 77 M LETTER 109 m LETTER 14 ^N LETTER 46 . DECIMALPOINT 78 N LETTER 110 n LETTER 15 ^O LETTER 47 / LETTER 79 O LETTER 111 o LETTER 16 ^P LETTER 48 0 DIGIT 80 P LETTER 112 p LETTER 17 ^Q LETTER 49 1 DIGIT 81 Q LETTER 113 q LETTER 18 ^R LETTER 50 2 DIGIT 82 R LETTER 114 r LETTER 19 ^S LETTER 51 3 DIGIT 83 S LETTER 115 s LETTER 20 ^T LETTER 52 4 DIGIT 84 T LETTER 116 t LETTER 21 ^U LETTER 53 5 DIGIT 85 U LETTER 117 u LETTER 22 ^V LETTER 54 6 DIGIT 86 V LETTER 118 v LETTER 23 ^W LETTER 55 7 DIGIT 87 W LETTER 119 w LETTER 24 ^X LETTER 56 8 DIGIT 88 X LETTER 120 x LETTER 25 ^Y LETTER 57 9 DIGIT 89 Y LETTER 121 y LETTER 26 ^Z DELIMITER 58 : LETTER 90 Z LETTER 122 z LETTER 27 $ LETTER 59 ; LETTER 91 [ DELIMITER 123 { LETTER 28 ^\ LETTER 60 < LETTER 92 \ PACKAGE 124 | LETTER 29 ^] LETTER 61 = LETTER 93 ] DELIMITER 125 } LETTER 30 ^^ LETTER 62 > LETTER 94 ^ LETTER 126 ~ LETTER 31 ^_ LETTER 63 ? LETTER 95 _ LETTER 127 <rubout> LETTER _________ _________ The Diphthong Indicator in the 128th entry is the identifier LISPDIPTHONG. [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will [??? Note that LISPDIPTHONG should be spelled LISPDIPHTHONG, this will probably be corrected in the future. ???] probably be corrected in the future. ???] probably be corrected in the future. ???] PSL Manual 7 February 1983 Input and Output section 12.5 page 12.23 __________ ______ RLISPSCANTABLE!* [Initially: as shown in following table] global 0 ^@ IGNORE 32 IGNORE 64 @ DELIMITER 96 ` DELIMITER 1 ^A DELIMITER 33 ! IDESCAPECHAR 65 A LETTER 97 a LETTER 2 ^B DELIMITER 34 " STRINGQUOTE 66 B LETTER 98 b LETTER 3 ^C DELIMITER 35 # DELIMITER 67 C LETTER 99 c LETTER 4 ^D DELIMITER 36 $ DELIMITER 68 D LETTER 100 d LETTER 5 ^E DELIMITER 37 % COMMENTCHAR 69 E LETTER 101 e LETTER 6 ^F DELIMITER 38 & DELIMITER 70 F LETTER 102 f LETTER 7 ^G DELIMITER 39 ' DELIMITER 71 G LETTER 103 g LETTER 8 ^H DELIMITER 40 ( DELIMITER 72 H LETTER 104 h LETTER 9 <tab> IGNORE 41 ) DELIMITER 73 I LETTER 105 i LETTER 10 <lf> IGNORE 42 * DIPHTHONGSTART 74 J LETTER 106 j LETTER 11 ^K DELIMITER 43 + DELIMITER 75 K LETTER 107 k LETTER 12 ^L IGNORE 44 , DELIMITER 76 L LETTER 108 l LETTER 13 <cr> IGNORE 45 - DELIMITER 77 M LETTER 109 m LETTER 14 ^N DELIMITER 46 . DECIMALPOINT 78 N LETTER 110 n LETTER 15 ^O DELIMITER 47 / DELIMITER 79 O LETTER 111 o LETTER 16 ^P DELIMITER 48 0 DIGIT 80 P LETTER 112 p LETTER 17 ^Q DELIMITER 49 1 DIGIT 81 Q LETTER 113 q LETTER 18 ^R DELIMITER 50 2 DIGIT 82 R LETTER 114 r LETTER 19 ^S DELIMITER 51 3 DIGIT 83 S LETTER 115 s LETTER 20 ^T DELIMITER 52 4 DIGIT 84 T LETTER 116 t LETTER 21 ^U DELIMITER 53 5 DIGIT 85 U LETTER 117 u LETTER 22 ^V DELIMITER 54 6 DIGIT 86 V LETTER 118 v LETTER 23 ^W DELIMITER 55 7 DIGIT 87 W LETTER 119 w LETTER 24 ^X DELIMITER 56 8 DIGIT 88 X LETTER 120 x LETTER 25 ^Y DELIMITER 57 9 DIGIT 89 Y LETTER 121 y LETTER 26 ^Z DELIMITER 58 : DIPHTHONGSTART 90 Z LETTER 122 z LETTER 27 $ DELIMITER 59 ; DELIMITER 91 [ DELIMITER 123 { DELIMITER 28 ^\ DELIMITER 60 < DIPHTHONGSTART 92 \ PACKAGE 124 | DELIMITER 29 ^] DELIMITER 61 = DELIMITER 93 ] DELIMITER 125 } DELIMITER 30 ^^ DELIMITER 62 > DIPHTHONGSTART 94 ^ DELIMITER 126 ~ DELIMITER 31 ^_ DELIMITER 63 ? DELIMITER 95 _ LETTER 127 <rubout> DELIMITER _________ _________ The Diphthong Indicator in the 128th entry is the identifier RLISPDIPTHONG. [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this [??? Note that RLISPDIPTHONG should be spelled RLISPDIPHTHONG, this will probably be corrected in the future. ???] will probably be corrected in the future. ???] will probably be corrected in the future. ???] [??? What about the RlispRead scantable ???] [??? What about the RlispRead scantable ???] [??? What about the RlispRead scantable ???] [??? Perhaps describe one basic table, and changes from one to other, [??? Perhaps describe one basic table, and changes from one to other, [??? Perhaps describe one basic table, and changes from one to other, since mostly the same ???] since mostly the same ???] since mostly the same ???] Input and Output 7 February 1983 PSL Manual page 12.24 section 12.5 __________ ______ OUTPUTBASE!* [Initially: 10] global This global can be set to control the radix in which integers are printed out. If the radix is not 10, the radix is given before a sharp sign, e.g. 8#20 is"20" in base 8, or 16. __________ ______ TOKTYPE!* [Initially: 3] global ChannelReadToken ChannelReadToken ChannelReadToken sets TOKTYPE!* to: __ 0 if the token is an ordinary id, ______ 1 if the token is a string, ______ 2 if the token is a number, or 3 if the token is an unescaped delimiter. __ In the last case, the value returned is the id whose print name is the same as the delimiter. 12.5.5. Read Macros 12.5.5. Read Macros 12.5.5. Read Macros Channel Token Channel Token A function of two arguments (Channel, Token) can be associated with any DELIMITER or DIPHTHONG token (i.e. those that have TOKTYPE!*=3) by calling PutReadMacro ChannelReadTokenWithHooks PutReadMacro _________ ChannelReadTokenWithHooks PutReadMacro. A ReadMacro function is called by ChannelReadTokenWithHooks ChannelReadToken ChannelReadToken if the appropriate token with TOKTYPE!*=3 is returned by ChannelReadToken. This function can then take over the reading (or scanning) process, finally returning a token (actually an S-expression) to be returned in place of the token itself. Quote Quote Example: The quote mark, 'x converting to (Quote x), is done by the PutReadMacro PutReadMacro following example which makes use of the function PutReadMacro which is defined in Section 12.6. In LISP: (de DOQUOTE (CHANNEL TOKEN)) (LIST 'QUOTE (CHANNELREAD CHANNEL)) (PUTREADMACRO LISPSCANTABLE!* '!' (FUNCTION DOQUOTE)) _________ A ReadMacro is installed on the property list of the macro-character as a function under the indicators 'LISPREADMACRO, 'RLISPREADMACRO, etc. A _________ Diphthong is installed on the property list of the first character as (second-character . diphthong) under the indicators 'LISPDIPHTHONG, 'RLISPDIPHTHONG, etc. PSL Manual 7 February 1983 Input and Output section 12.6 page 12.25 12.6. Scan Table Utility Functions 12.6. Scan Table Utility Functions 12.6. Scan Table Utility Functions The following functions are provided to manage scan tables, in the READ-UTILS module (use via LOAD READ-UTILS): PrintScanTable PrintScanTable _____ ______ ___ ____ (PrintScanTable TABLE:vector): NIL expr Prints the entire scantable, gives the 0 ... 127 entries with the name of the character class. Also prints the indicator used for diphthongs. [??? Make smarter, reduce output, use nice names for control [??? Make smarter, reduce output, use nice names for control [??? Make smarter, reduce output, use nice names for control characters, ala EMODE. ???] characters, ala EMODE. ???] characters, ala EMODE. ???] CopyScanTable CopyScanTable ________ ______ ___ ______ ____ (CopyScanTable OLDTABLE:{vector, NIL}): vector expr Copies the existing scantable (or CURRENTSCANTABLE!* if given GenSym GenSym NIL). Currently GenSym()'s the indicators used for diphthongs. [??? Change when we use Property Lists in extra slots of the [??? Change when we use Property Lists in extra slots of the [??? Change when we use Property Lists in extra slots of the Scan-Table ???] Scan-Table ???] Scan-Table ???] PutDipthong PutDipthong _____ ______ __ __ ___ __ ___ __ ___ ____ (PutDipthong TABLE:vector, D1:id ID2:id DIP:id): NIL expr ___ ___ ___ Installs DIP as the name of the diphthong ID1 followed by ID2 in the given scan table. [??? Note that PutDipthong should be spelled PutDiphthong, [??? Note that PutDipthong should be spelled PutDiphthong, [??? Note that PutDipthong should be spelled PutDiphthong, this will probably be corrected in the future. ???] this will probably be corrected in the future. ???] this will probably be corrected in the future. ???] PutReadMacro PutReadMacro _____ ______ ___ __ _____ __ ___ ____ (PutReadMacro TABLE:vector ID1:id FNAME:id): NIL expr ____ _____ ____ _____ ____ _____ Read macro _____ Read macro Installs FNAME as the name of the Read macro function for the ___ ___ ___ [not ___ [not delimiter or diphthong ID1 in the given scan table. [not ___________ ___ ___________ ___ ___________ ___ implemented yet] implemented yet] implemented yet] 12.7. I/O to and from Lists and Strings 12.7. I/O to and from Lists and Strings 12.7. I/O to and from Lists and Strings Digit Digit _ ___ _______ ____ (Digit U:any): boolean expr _ Returns T if U is a digit, otherwise NIL. Effectively this is: (de DIGIT (U) (IF (MEMQ U '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) T NIL)) Input and Output 7 February 1983 PSL Manual page 12.26 section 12.7 Liter Liter _ ___ _______ ____ (Liter U:any): boolean expr _ Returns T if U is a character of the alphabet, NIL otherwise. This is effectively: (de LITER(U) (IF (MEMQ U '(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 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)) T NIL)) Explode Explode _ ___ __ ____ ____ (Explode U:any): id-list expr Explode Explode Explode takes the constituent characters of an S-expression and ____ __ forms a list of single character ids. It is implemented via the ChannelPrin1 ChannelPrin1 ____ function ChannelPrin1, with a list rather than a file or terminal ____ as destination. Returned is a list of interned characters _ representing the characters required to print the value of U. Example: - Explode 'FOO; => (F O O) - Explode '(A . B); => (!( A ! !. ! B !)) [??? add print macros. cf. UCI lisp ???] [??? add print macros. cf. UCI lisp ???] [??? add print macros. cf. UCI lisp ???] Explode2 Explode2 _ ____ ______ __ ____ ____ (Explode2 U:{atom}-{vector}): id-list expr Prin2 Explode Prin2 Explode Prin2 version of Explode. Compress Compress _ __ ____ ____ ______ ____ (Compress U:id-list): {atom}-{vector} expr _ ____ U is a list of single character identifiers which is built into a ______ ______ PSL entity and returned. Recognized are numbers, strings, and __________ identifiers with the escape character prefixing special characters. The formats of these items appear in the "Primitive __________ ___ Data Types" Section, Section 4.1.2. Identifiers are not interned ________ _______ on the ID-HASH-TABLE. Function pointers may not be compressed. _ If an entity cannot be parsed out of U or characters are left over after parsing an error occurs: ***** Poorly formed atom in COMPRESS PSL Manual 7 February 1983 Input and Output section 12.7 page 12.27 Implode Implode _ __ ____ ____ ____ (Implode U:id-list): atom expr Compress Compress __ Compress with ids interned. FlatSize FlatSize _ ___ _______ ____ (FlatSize U:any): integer expr Prin1 Prin1 Character length of Prin1 S-expression. FlatSize2 FlatSize2 _ ___ _______ ____ (FlatSize2 U:any): integer expr Prin2 flatsize Prin2 flatsize Prin2 version of flatsize. BldMsg BldMsg ______ ______ ____ ___ ______ ____ (BldMsg FORMAT:string, [ARGS:any]): string expr PrintF BldMsg PrintF ______ BldMsg ______ PrintF to string. BldMsg returns a string stating that the ______ string could not be constructed if overflow occurs. 12.8. Example of Simple I/O in PSL 12.8. Example of Simple I/O in PSL 12.8. Example of Simple I/O in PSL In the following example a list of S-expressions is read, one expression at a time, from a file STUFF.IN and is written to a file STUFF.OUT. Following is the contents of STUFF.IN: (r e d) (a b c) (1 2 3 4) "ho ho ho" 6.78 5000 xyz The following shows the execution of the function TRYIO. Input and Output 7 February 1983 PSL Manual page 12.28 section 12.8 @psl:psl PSL 3.1, 15-Nov-82 1 lisp> (On Echo) NIL 2 lisp> (Dskin "Exampio.Sl") (De Tryio (Fil1 Fil2) (Prog (Oldin Oldout Exp) (Setq Oldin (Rds (Open Fil1 'input))) (Setq Oldout (Wrs (Open Fil2 'output))) (While (Neq (Setq Exp (Read)) !$EOF!$) (Print Exp)) (Close (Rds Oldin)) (Close (Wrs Oldout)))) TRYIO NIL 3 lisp> (Off Echo) NIL 4 lisp> (Tryio "Stuff.In" "Stuff.Out") NIL The output file STUFF.OUT contains the following. (R E D) (A B C) (1 2 3 4) "ho ho ho" 6.78 5000 XYZ |
Added psl-1983/lpt/13-toploop.lpt version [649c266976].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 User Interface section 13.0 page 13.1 CHAPTER 13 CHAPTER 13 CHAPTER 13 USER INTERFACE USER INTERFACE USER INTERFACE 13.1. Introduction . . . . . . . . . . . . . . . 13.1 13.2. Stopping PSL and Saving a New Executable Core Image . . 13.1 13.3. Init Files. . . . . . . . . . . . . . . . 13.3 13.4. Changing the Default Top Level Function . . . . . . 13.3 13.5. The General Purpose Top Loop Function. . . . . . . 13.4 13.6. The HELP Mechanism . . . . . . . . . . . . . 13.7 13.7. The Break Loop . . . . . . . . . . . . . . 13.8 13.8. Terminal Interaction Commands in RLISP . . . . . . 13.8 13.1. Introduction 13.1. Introduction 13.1. Introduction In this chapter those functions are presented relating directly to the user interface; for example, the general purpose Top Loop function, the History mechanism, and changing the default Top Level function. 13.2. Stopping PSL and Saving a New Executable Core Image 13.2. Stopping PSL and Saving a New Executable Core Image 13.2. Stopping PSL and Saving a New Executable Core Image Quit Quit The normal way to stop PSL execution is to call the Quit function or to strike <Ctrl-C> on the DEC-20 or <Ctrl-Z> on the VAX. Quit Quit _________ ____ (Quit ): Undefined expr Return from LISP to superior process. After either of these actions, PSL may be re-entered by typing START or CONTINUE to the EXEC on the DEC-20. After exiting, the core image may also be saved using the Tops-20 monitor command "SAVE filename". On the VAX, Quit Quit Quit causes a stop signal to be sent, so that PSL may be continued from the shell. If you desire that the process be killed, use the function ExitLisp ExitLisp ExitLisp. ExitLisp ExitLisp _________ ____ (ExitLisp ): Undefined expr Quit Quit To be used on the VAX. Like Quit except that the process is ExitLisp ExitLisp killed. ExitLisp calls the Unix library routine exit(). A better way to exit and save the core image is to call the function SaveSystem SaveSystem SaveSystem. User Interface 7 February 1983 PSL Manual page 13.2 section 13.2 SaveSystem SaveSystem ___ ______ ____ ______ _____ ____ ____ _________ ____ (SaveSystem MSG:string FILE:string FORMS:form-list): Undefined expr This records the welcome message (after attaching a date) in the StandardLisp StandardLisp global variable LISPBANNER!* used by StandardLisp's call on TopLoop DumpLisp TopLoop DumpLisp TopLoop, and then calls DumpLisp to compact the core image and write it out as a machine dependent executable file with the name ____ ____ FILE. FILE should have the appropriate extension for an SaveSystem SaveSystem executable file. SaveSystem also sets USERMODE!* to T. _____ The forms in the list FORMS will be evaluated when the new core image is started. For example (SaveSystem "PSL 3.1" "PSL.EXE" '((Read-Init-File "PSL") (InitializeInterrupts))) SaveSystem SaveSystem If RLISP has been loaded, SaveSystem will have been redefined to Main Main save the message in the global variable DATE!*, and redefine Main RlispMain Begin1 RlispMain Begin1 to call RlispMain, which uses DATE!* in Begin1. The older SaveSystem LispSaveSystem SaveSystem LispSaveSystem SaveSystem will be saved as the function LispSaveSystem. DumpLisp DumpLisp ____ ______ _________ ____ (DumpLisp FILE:string): Undefined expr Reclaim Reclaim This calls Reclaim to compact the heap, and unmaps the unused pages (DEC-20) or moves various segment pointers (VAX) to decrease the core image. The core image is then written as an ____ executable file, with the name FILE. Reset Reset _________ ____ (Reset ): Undefined expr Return to top level of LISP. Equivalent to <Ctrl-C> and Start on DEC-20. Time Time _______ ____ (Time ): integer expr CPU time in milliseconds since login time. Date Date ______ ____ (Date ): string expr The date in the form 16-Dec-82. __________ ______ LISPBANNER!* [Initially: ] global SaveSystem SaveSystem Records the welcome message given by a call to SaveSystem from Date Date PSL. Also contains the date, given by the function Date. PSL Manual 7 February 1983 User Interface section 13.2 page 13.3 __________ ______ DATE!* [Initially: Nil] global SaveSystem SaveSystem Records the welcome message given by a call to SaveSystem from RLISP. 13.3. Init Files 13.3. Init Files 13.3. Init Files Init files are available to make it easier for the user to customize PSL to his/her own needs. When PSL, RLISP, or PSLCOMP is executed, if a file PSL.INIT, RLISP.INIT, or PSLCOMP.INIT (.pslrc, rlisprc, or .pslcomprc on the VAX) is on the home directory, it will be read and evaluated. Currently all init files must be written in LISP syntax. They may use FASLIN LOAD FASLIN LOAD FASLIN or LOAD as needed. The following functions are used to implement init files, and can be accessed by LOADing the INIT-FILE module. User-HomeDir-String User-HomeDir-String ______ ____ (User-HomeDir-String ): string expr Returns a full pathname for the user's home directory. Init-File-String Init-File-String ___________ ______ ______ ____ (Init-File-String PROGRAMNAME:string): string expr Returns the full pathname of the user's init file for the program ___________ PROGRAMNAME. (Init-File-String "PSL") Read-Init-File Read-Init-File ___________ ______ ___ ____ (Read-Init-File PROGRAMNAME:string): Nil expr ___________ Reads and evaluates the init file with name PROGRAMNAME. Read-Init-File Init-File-String Read-Init-File Init-File-String ___________ Read-Init-File calls Init-File-String with argument PROGRAMNAME. (Read-Init-File "PSL") 13.4. Changing the Default Top Level Function 13.4. Changing the Default Top Level Function 13.4. Changing the Default Top Level Function As PSL starts up, it first sets the stack pointer and various other Main While Main While variables, and then calls the function Main inside a While loop, protected Catch Main StandardLisp Catch Main StandardLisp by a Catch. By default, Main calls a StandardLisp top loop, defined using TopLoop TopLoop the general TopLoop function, described in the next Section. In order to Main Main have a saved PSL come up in a different top loop, the function Main should be appropriately redefined by the user (e.g. as is done to create RLISP). User Interface 7 February 1983 PSL Manual page 13.4 section 13.4 Main Main _________ ____ (Main ): Undefined expr Initialization function, called after setting the stack. Should TopLoop TopLoop be redefined by the user to change the default TopLoop. 13.5. The General Purpose Top Loop Function 13.5. The General Purpose Top Loop Function 13.5. The General Purpose Top Loop Function PSL provides a general purpose Top Loop that allows the user to specify Read Eval Print Read Eval Print his own Read, Eval and Print functions and otherwise obtain a standard set of services, such as Timing, History, Break Loop interface, and Interface to Help system. __________ ______ TOPLOOPEVAL!* [Initially: NIL] global Eval Eval The Eval used in the current Top Loop. __________ ______ TOPLOOPPRINT!* [Initially: NIL] global Print Print The Print used in the current Top Loop. __________ ______ TOPLOOPREAD!* [Initially: NIL] global Read Read The Read used in the current Top Loop. TopLoop TopLoop ___________ ________ ____________ ________ (TopLoop TOPLOOPREAD!*:function TOPLOOPPRINT!*:function ___________ ________ ___________ __ _____________ ______ ___ ____ TOPLOOPEVAL!*:function TOPLOOPNAME!*:id WELCOMEBANNER:string): NIL expr This function is called to establish a new Top Loop (currently Standard LISP Break Standard LISP Break used for Standard LISP, RLISP, and Break). It prints the Read-Eval-Print _____________ Read-Eval-Print WELCOMEBANNER and then invokes a "Read-Eval-Print" loop, using ___________ the given functions. Note that TOPLOOPREAD!*, etc. are FLUID variables, and so may be examined (and changed) within the TopLoop TopLoop executing Top Loop. TopLoop provides a standard History and ____ ___________ timing mechanism, retaining on a list (HISTORYLIST!*) the input ____ ____ and output as a list of pairs. A prompt is constructed from ___________ TOPLOOPNAME!* and is printed out, prefixed by the History count. As a convention, the name is followed by a number of ">"'s, indicating the loop depth. __________ ______ TOPLOOPNAME!* [Initially: ] global Short name to put in prompt. PSL Manual 7 February 1983 User Interface section 13.5 page 13.5 __________ ______ TOPLOOPLEVEL!* [Initially: ] global Depth of top loop invocations. __________ ______ !*EMSGP [Initially: ] switch Whether to print error messages. __________ ______ GCTIME!* [Initially: ] global Time spent in garbage collection. __________ ______ INITFORMS!* [Initially: ] global Forms to be evaluated at startup. __________ ______ !*PECHO [Initially: NIL] switch StandardLisp StandardLisp Causes parsed form read in top-loop StandardLisp to be printed, if T. __________ ______ !*PVAL [Initially: T] switch StandardLisp StandardLisp Causes values computed in top-loop StandardLisp to be printed, if T. __________ ______ !*TIME [Initially: NIL] switch If on, causes a step evaluation time to be printed after each command. Hist Hist _ _______ ___ _____ (Hist [N:integer]): NIL nexpr This function does not work with the Top Loop used by PSL:RLISP or by (beginrlisp); it does work with LISP and with RLISP if it Hist Hist is started from LISP using the RLISP function. Hist is called with 0, 1 or 2 integers, which control how much history is to be printed out: (HIST) Display full history. (HIST n m) Display history from n to m. (HIST n) Display history from n to present. (HIST -n) Display last n entries. User Interface 7 February 1983 PSL Manual page 13.6 section 13.5 [??? Add more info about what a history is. ???] [??? Add more info about what a history is. ???] [??? Add more info about what a history is. ???] The following functions permit the user to access and resubmit previous expressions, and to re-examine previous results. Inp Inp _ _______ ___ ____ (Inp N:integer): any expr Return N'th input at this level. ReDo ReDo _ _______ ___ ____ (ReDo N:integer): any expr Reevaluate N'th input. Ans Ans _ _______ ___ ____ (Ans N:integer): any expr Return N'th result. __________ ______ HISTORYCOUNT!* [Initially: 0] global Number of entries read so far. __________ ______ HISTORYLIST!* [Initially: Nil] global List of entries read and evaluated. TopLoop StandardLisp TopLoop StandardLisp TopLoop has been used to define the following StandardLisp and RLISP top loops. StandardLisp StandardLisp ___ ____ (StandardLisp ): NIL expr Interpreter LISP syntax top loop, defined as: (De StandardLisp Nil (Prog (CurrentReadMacroIndicator!* CurrentScanTable!*) (Setq CurrentReadMacroIndicator!* 'LispReadMacro) (Setq CurrentScanTable!* LispScanTable!*) (Toploop 'Read 'Print 'Eval "LISP" "PORTABLE STANDARD LISP"))) Note that the scan tables are modified. RLisp RLisp ___ ____ (RLisp ): NIL expr Alternative interpreter RLISP syntax top loop, defined as: PSL Manual 7 February 1983 User Interface section 13.5 page 13.7 [??? xread described in RLISP Section ???] [??? xread described in RLISP Section ???] [??? xread described in RLISP Section ???] (De RLisp Nil (Toploop 'XRead 'Print 'Eval "RLISP" "PSL RLISP")) Note that for the moment, the default RLISP loop is not this (though this may be used experimentally); instead a similar BeginRlisp BeginRlisp (special purpose hand coded) function, BeginRlisp, based on the Begin1 Begin1 older Begin1 is used. It is hoped to change the RLISP top-level to use the general purpose capability. BeginRLisp BeginRLisp ____ ________ ____ (BeginRLisp ): None Returned expr Starts RLISP from PSL:PSL only if RLISP is loaded. The module RLISP is present if you started in RLISP and then entered PSL. 13.6. The HELP Mechanism 13.6. The HELP Mechanism 13.6. The HELP Mechanism PSL provides a general purpose Help mechanism, that is called in the TopLoop Help TopLoop Help TopLoop by invoking Help sometimes a ? may be used, as for example in the break loop. Help Help ______ __ ___ _____ (Help [TOPICS:id]): NIL fexpr If no arguments are given, a message describing Help itself and __ known topics is printed. Otherwise, each of the id arguments is checked to see if any help information is available. If it has a value under the property list indicator HelpFunction, that function is called. If it has a value under the indicator HelpString, the value is printed. If it has a value under the indicator HelpFile, the file is displayed on the terminal. By default, a file called "topic.HLP" on the Logical device, "PH:" is looked for, and printed if found. Help Help Help also prints out the values of the TopLoop fluids, and finally searches the current Id-Hash-Table for loaded modules. __________ ______ HELPIN!* [Initially: NIL] global Help Help The channel used for input by the Help mechanism. __________ ______ HELPOUT!* [Initially: NIL] global Help Help The channel used for output by the Help mechanism. User Interface 7 February 1983 PSL Manual page 13.8 section 13.7 13.7. The Break Loop 13.7. The Break Loop 13.7. The Break Loop The Break Loop is described in detail in Chapter 14. For information, look there. 13.8. Terminal Interaction Commands in RLISP 13.8. Terminal Interaction Commands in RLISP 13.8. Terminal Interaction Commands in RLISP Two commands are available in RLISP for use in interactive computing. Pause Pause ___ ____ (Pause ): Nil expr The command PAUSE; may be inserted at any point in an input file. If this command is encountered on input, the system prints the YesP YesP message CONT? on the user's terminal and halts by calling YesP. YesP YesP _______ ______ _______ ____ (YesP MESSAGE:string): boolean expr YesP YesP If the user responds Y or Yes, YesP returns T and the calculation continues from that point in the file. If the user responds N or YesP YesP No, YesP returns NIL and control is returned to the terminal, and the user can type in further commands. However, later on he can use the command CONT; and control is then transferred back to the point in the file after the last PAUSE was encountered. If the user responds B, one enters a break loop. After quitting the break loop, one still must respond Y, N, Yes, or No. |
Added psl-1983/lpt/14-errors.lpt version [babb18e01e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Error Handling and Recovery section 14.0 page 14.1 CHAPTER 14 CHAPTER 14 CHAPTER 14 ERROR HANDLING ERROR HANDLING ERROR HANDLING 14.1. Introduction . . . . . . . . . . . . . . . 14.1 14.2. The Basic Error Functions. . . . . . . . . . . 14.1 14.3. Break Loop. . . . . . . . . . . . . . . . 14.4 14.4. Interrupt Keys . . . . . . . . . . . . . . 14.7 14.5. Details on the Break Loop. . . . . . . . . . . 14.7 14.6. Some Convenient Error Calls . . . . . . . . . . 14.7 14.7. Special Purpose Error Handlers . . . . . . . . . 14.9 14.1. Introduction 14.1. Introduction 14.1. Introduction In PSL, as in most LISP systems, various kinds of errors are detected by functions in the process of checking the validity of their argument types and other conditions. Errors are then "signalled" to a currently active ErrorSet Error ErrorSet Error error handler (called ErrorSet) by a call on an Error function. In PSL, Break Break the error handler typically calls an interactive Break loop, which permits the user to examine the context of the error and optionally make some corrections and continue the computation, or to abort the computation. Break Break While in the Break loop, the user remains in the binding context of the function that detected the error; the user sees the value of FLUID variables as they are in the function itself. If the user aborts the Throw Throw computation, a call on Throw with a tag of !$ERROR!$ is done, and fluids are unbound. [??? What about errors signalled to the Interrupt Handler ???] [??? What about errors signalled to the Interrupt Handler ???] [??? What about errors signalled to the Interrupt Handler ???] 14.2. The Basic Error Functions 14.2. The Basic Error Functions 14.2. The Basic Error Functions The following two switches and one global variable are used by the functions in this section. __________ ______ !*BACKTRACE [Initially: T] switch ErrorSet ErrorSet Set in ErrorSet. Controls whether an unwind backtrace is requested. Error Handling and Recovery 7 February 1983 PSL Manual page 14.2 section 14.2 __________ ______ !*MSGP [Initially: T] switch ErrorSet ErrorSet Set in ErrorSet. Controls error message printing during call on error. __________ ______ EMSG!* [Initially: NIL] global Contains the message generated by the last error call. ErrorSet ErrorSet _ ___ ____ _______ _________ _______ ___ ____ (ErrorSet U:any !*MSGP:boolean !*BACKTRACE:boolean): any expr _ If an uncorrected error occurs during the evaluation of U, the ______ value of NUMBER from the associated error call is returned as the ____ ____ ____ ErrorSet ErrorSet expr ErrorSet ErrorSet expr _ value of ErrorSet. Note that ErrorSet is an expr, so U gets evaluated twice, once as the parameter is passed and once inside ErrorSet ErrorSet Catch ErrorSet ErrorSet Catch ErrorSet. [Actually, ErrorSet executes a Catch with tag Throw Throw !$ERROR!$, and so intercepts any Throw with this tag.] In addition, if the value of !*MSGP is non-NIL, the message from the error call is displayed upon both the standard output device and the currently selected output device unless the standard output device is not open. The message appears prefixed with 5 asterisks. The message list is displayed without top level parentheses. The message from the error call is available in the GLOBAL variable EMSG!*. The exact format of error messages generated by PSL functions described in this document may not be exactly as given and should not be relied upon to be in any particular form. Likewise, error numbers generated by PSL functions are not fixed. Currently, a number of different calls Error Error on Error result in the same error message, since the cause of the error is the same and the information to the user is the same. The error number is then used to indicate which function actually detected the error. [??? Describe Error # ranges here, or have in a file on [??? Describe Error # ranges here, or have in a file on [??? Describe Error # ranges here, or have in a file on machine ???] machine ???] machine ???] _ If no error occurs during the evaluation of U, the value of List Eval List Eval _ (List (Eval U)) is returned. If an error has been signalled and the value of !*BACKTRACE is non-NIL, a traceback sequence is initiated on the selected output device. The traceback displays information such as unbindings of FLUID variables, argument lists and so on in an implementation-- dependent format. Error Error ______ _______ _______ ___ ____ ________ ____ (Error NUMBER:integer MESSAGE:any): None Returned expr _______ MESSAGE is placed in the GLOBAL variable EMSG!* and the error ErrorSet ErrorSet number becomes the value of the surrounding ErrorSet (if any PSL Manual 7 February 1983 Error Handling and Recovery section 14.2 page 14.3 Break Break intervening Break loop is exited). FLUID variables and LOCAL bindings are unbound to return to the environment of the ErrorSet ErrorSet ErrorSet. GLOBAL variables are not affected by the process. Error Break Error Break Error actually signals a non-continuable error to the Break loop, and it subsequently does a throw with tag !$ERROR!$. ContinuableError ContinuableError ______ _______ _______ ___ ____ ____ ___ ____ (ContinuableError NUMBER:integer MESSAGE:any FORM:form): any expr _______ MESSAGE is placed in the GLOBAL variable EMSG!* and the error ErrorSet ErrorSet number becomes the value of the surrounding ErrorSet if the Break Break intervening Break loop is "QUIT" rather than "Continued" or "Retried". FLUID variables and LOCAL bindings are unbound to ErrorSet ErrorSet return to the environment of the ErrorSet. GLOBAL variables are Error Error not affected by the process. Error actually signals a Break Break continuable error to the Break loop, and it subsequently does a throw with tag !$ERROR!$. The FORM is stored in the GLOBAL variable ERRORFORM!*, for examination, editing or possible reevaluation after defining missing functions, etc. Setting up the ERRORFORM!* can get a bit MkQuote MkQuote tricky, often involving MkQuoteing of already evaluated arguments. The following MACRO may be useful. ContError ContError ____ ___ ___ _____ (ContError [ARGS:any]): any macro ____ The format of ARGS is (ErrorNumber, FormatString, {arguments to ____________ PrintF}, ReEvalForm). The FORMATSTRING is used with the BldMsg BldMsg following arguments in a call on BldMsg to build an error PrintF PrintF message. If the only argument to PrintF is a string, the BldMsg ____________ BldMsg FORMATSTRING may be omitted, and no call to BldMsg is made. The ReEvalForm is something like Foo(X, Y) which becomes list('Foo, MkQuote X, MkQuote Y) to be passed to the function ContinuableError ContinuableError ContinuableError. (DE DIVIDE (U, V) (COND((ZEROP V) (CONTERROR 99 "Attempt to divide by 0 in DIVIDE (DIVIDE U V (T (CONS (QUOTIENT U V) (REMAINDER U V))))) __________ ______ !*CONTINUABLEERROR [Initially: NIL] switch ________________ If !*CONTINUABLEERROR is T, then one is inside a continuable error. Error Handling and Recovery 7 February 1983 PSL Manual page 14.4 section 14.3 14.3. Break Loop 14.3. Break Loop 14.3. Break Loop Read/Eval/Print Read/Eval/Print On detecting an error, PSL normally enters a Read/Eval/Print loop called Break Break a Break loop. Here the user can examine the state of his computation, change the values of FLUIDs, or define missing functions. He can then ErrorSet ErrorSet dismiss the error call to the normal error handling mechanism (the ErrorSet above) or (in some situations) continue the computation. By setting the Break Break switch !*BREAK to NIL, all Break loops can be suppressed, and just an error message is displayed. __________ ______ !*BREAK [Initially: T] switch Break Break Controls whether the Break package is called before unwinding the stack on error. __________ ______ BREAKLEVEL!* [Initially: 0] global The current number of nesting level of breaks. __________ ______ MAXBREAKLEVEL!* [Initially: 5] global The maximum number of nesting levels of breaks permitted. Break Break The prompt "Break>" indicates that PSL has entered a Break loop. A message of the form "Continuation requires a value for ..." may also be printed, in which case the user is able to continue his computation by Break Break repairing the offending expression. By default, a Break loop uses the Read Eval Print Read Eval Print functions Read, Eval, and Print. This may be changed by setting BREAKREADER!*, BREAKEVALUATOR!*, or BREAKPRINTER!* to the appropriate function name. __________ ______ ERRORFORM!* [Initially: NIL] global Break Break Contains an expression to reevaluate inside a Break loop for continuable errors. [Not enough errors set this yet]. Used as a tag for various Error functions. Break __ Break Several ids, if typed at top-level, are special in a Break loop. These are used as commands, and are currently E, M, R, T, Q, A, I, and C. They call functions stored on their property lists under the indicator __ 'BreakFunction. These ids are special only at top-level, and do not cause any difficulty if used as variables inside expressions. However, they may not be simply typed at top-level to see their values. This is not expected to cause any difficulty. If it does, an escape command will be provided for examining the relevant variables. The meanings of these commands are: PSL Manual 7 February 1983 Error Handling and Recovery section 14.3 page 14.5 E Edit the value of ERRORFORM!*. This is the object printed in the "Continuation requires a value for ..." message. The function BreakEdit BreakEdit BreakEdit is the associated function called by this command. The Retry Retry Retry command (below) uses the corrected version of ERRORFORM!*. The currently available editors are described in Chapter 16. BreakErrmsg BreakErrmsg M Show the modified ERRORFORM!*. Calls the function BreakErrmsg. R Retry. This tries to evaluate the offending expression again, and continue the computation. It evaluates the value of ERRORFORM!*. This is often useful after defining a missing Edit Edit function, assigning a value to a variable, or using the Edit BreakRetry BreakRetry command, above. This command calls the function BreakRetry. Break Break C This causes the expression last printed by the Break loop to be returned as the value of the offending expression. This is often useful as an automatic stub. If an expression containing an Break Break undefined function is evaluated, a Break loop is entered, and this may be used to return the value of the function call. This BreakContinue BreakContinue command calls the function BreakContinue. Break Break Q Quit. This exits the Break loop by throwing to the closest ErrorSet BreakQuit ErrorSet BreakQuit surrounding ErrorSet. It calls the function BreakQuit. A Abort. This aborts to the top level, i.e., restarts PSL. It Reset Reset calls the function Reset. T Trace. This prints a backtrace of function calls on the stack except for those on the lists IGNOREDINBACKTRACE!* and BackTrace BackTrace INTERPRETERFUNCTIONS!*. It calls the function BackTrace. I Interpreter Trace. This prints a backtrace of only interpreted functions call on the stack except for those on the list InterpBackTrace InterpBackTrace INTERPRETERFUNCTIONS!*. It calls the function InterpBackTrace. An attempt to continue a non-continuable error with R or C prints a message and behaves as Q. __________ IGNOREDINBACKTRACE!* [Initially: '(Eval Apply FastApply CodeApply CodeEvalApply Catch ErrorSet EvProgN TopLoop BreakEval ______ BindEval Break Main)] global A list of function names that will not be printed by the commands Break Break I and T given within a Break loop. __________ ______ INTERPRETERFUNCTIONS!* [Initially: '(Cond Prog And Or ProgN SetQ)] global A list of function names that will not be printed by the command Break Break I given within a Break loop. Error Handling and Recovery 7 February 1983 PSL Manual page 14.6 section 14.3 The above two globals can be reset in an init file if the programmer desires to do so. The following is a slightly edited transcript, showing some of the BREAK options: PSL Manual 7 February 1983 Error Handling and Recovery section 14.3 page 14.7 % foo is an undefined function, so the following has two errors % in it 1> (Plus2 (foo 1)(foo 2)) ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 1)' Break loop 1 lisp break> (plus2 1 1) % We simply compute a value 2 % prints as 2 2 lisp break> c % continue with this value % it returns to compute "(foo 2)" ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 2)' Break loop 1 lisp break> 3 % again compute a value 3 2 lisp break> c % and return 5 % finally complete % Pretend that we had really meant to call "fee": 2> (de fee (x) (add1 x)) FEE 3> (plus2 (foo 1)(foo 2)) % now the bad expression ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 1)' Break loop 1 lisp break> e % lets edit it Type HELP<CR> for a list of commands. edit> p % print form (FOO 1) edit> (1 fee) % replace 1'st by "fee" edit> p % print again (FEE 1) edit> ok % we like it (FEE 1) 2 lisp break> m % show modified ErrorForm!* ErrorForm!* : `(FEE 1)' NIL 3 lisp break> r % Retry EVAL ErrorForm!* ***** `FOO' is an undefined function {1001} ***** Continuation requires a value for `(FOO 2)' Break loop 1 lisp break> (de foo(x) (plus2 x 1)) % define foo FOO 2 lisp break> r % and retry 5 Error Handling and Recovery 7 February 1983 PSL Manual page 14.8 section 14.4 14.4. Interrupt Keys 14.4. Interrupt Keys 14.4. Interrupt Keys Need to "LOAD INTERRUPT;" to enable. This applies only to the DEC20. <Ctrl-T> indicates routine currently executing, gives the load average, and gives the location counter in octal; <Ctrl-G> returns you to the Top-Loop; <Ctrl-B> takes you into a lower-level Break loop. 14.5. Details on the Break Loop 14.5. Details on the Break Loop 14.5. Details on the Break Loop Break Error Break Error If the SWITCH !*BREAK is T, the function Break() is called by Error or ContinuableError ContinuableError ContinuableError before unwinding the stacks, or printing a backtrace. Break Break Input and output to/from Break loops is done from/to the values (channels) of BREAKIN!* and BREAKOUT!*. The channels selected on entrance to the Break Break Break loop are restored upon exit. __________ ______ BREAKIN!* [Initially: NIL] global Rds Rds So Rds chooses STDIN!*. __________ ______ BREAKOUT!* [Initially: NIL] global Similar to BREAKIN!*. Break Read-Eval-Print Break Read-Eval-Print Break is essentially a Read-Eval-Print function, called in the error context. Any FLUID may be printed or changed, function definitions Break TopLoop Break TopLoop changed, etc. The Break uses the normal TopLoop mechanism (including Catch TopLoop Catch TopLoop History), embedded in a Catch with tag !$BREAK!$. The TopLoop attempts to use the parent loop's TOPLOOPREAD!*, TOPLOOPPRINT!* and TOPLOOPEVAL!*; the BreakEval BreakEval __ BreakEval function first checks top-level ids to see if they have a special BREAKFUNCTION on their property lists, stored under 'BREAKFUNCTION. This is expected to be a function of no arguments, and is applied instead of Eval Eval Eval. 14.6. Some Convenient Error Calls 14.6. Some Convenient Error Calls 14.6. Some Convenient Error Calls The following functions may be useful in user packages: FatalError FatalError _ ___ ____ ________ ____ (FatalError S:any): None Returned expr PSL Manual 7 February 1983 Error Handling and Recovery section 14.6 page 14.9 (ProgN (ErrorPrintF "***** Fatal error: %s" S) (While T Quit)) RangeError RangeError ______ ___ _____ _______ __ ________ ____ ________ ____ (RangeError Object:any Index:integer Fn:function): None Returned expr (StdError (BldMsg "Index %r out of range for %p in %p" Index Object Fn)) StdError StdError _______ ______ ____ ________ ____ (StdError Message:string): None Returned expr (Error 99 Message) TypeError TypeError ________ ___ __ ________ ___ ___ ____ ________ ____ (TypeError Offender:any Fn:function Typ:any): None Returned expr (StdError (BldMsg "An attempt was made to do %p on %r, which is not %w" Fn Offender Typ)) UsageTypeError UsageTypeError ___ ___ __ ________ ___ ___ _____ ___ ____ ________ ____ (UsageTypeError Off:any Fn:function Typ:any Usage:any): None Returned expr (StdError (BldMsg "An attempt was made to use %r as %w in %p, where %w is needed" Offender Usage Fn Typ)) IndexError IndexError ________ ___ __ ________ ____ ________ ____ (IndexError Offender:any Fn:function): None Returned expr (UsageTypeError Offender Fn "an integer" "an index") NonPairError NonPairError ________ ___ __ ________ ____ ________ ____ (NonPairError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a pair") NonIDError NonIDError ________ ___ __ ________ ____ ________ ____ (NonIDError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "an identifier") NonNumberError NonNumberError ________ ___ __ ________ ____ ________ ____ (NonNumberError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a number") NonIntegerError NonIntegerError ________ ___ __ ________ ____ ________ ____ (NonIntegerError Offender:any Fn:function): None Returned expr Error Handling and Recovery 7 February 1983 PSL Manual page 14.10 section 14.6 (TypeError Offender Fn "an integer") NonPositiveIntegerError NonPositiveIntegerError ________ ___ __ ________ ____ ________ ____ (NonPositiveIntegerError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a non-negative integer") NonCharacterError NonCharacterError ________ ___ __ ________ ____ ________ ____ (NonCharacterError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a character") NonStringError NonStringError ________ ___ __ ________ ____ ________ ____ (NonStringError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a string") NonVectorError NonVectorError ________ ___ __ ________ ____ ________ ____ (NonVectorError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a vector") NonSequenceError NonSequenceError ________ ___ __ ________ ____ ________ ____ (NonSequenceError Offender:any Fn:function): None Returned expr (TypeError Offender Fn "a sequence") 14.7. Special Purpose Error Handlers 14.7. Special Purpose Error Handlers 14.7. Special Purpose Error Handlers [??? This needs to be rethought and reimplemented. Currently not [??? This needs to be rethought and reimplemented. Currently not [??? This needs to be rethought and reimplemented. Currently not installed. ???] installed. ???] installed. ???] It is possible to handle errors specially. The value of Error _ ____ ____ Error ERRORHANDLERS!* is an a-list of error number/handler pairs. If Error is Car Car called with a number which appears as the Car of an element of Cdr Cdr ERRORHANDLERS!*, its Cdr is taken to be a function of two variables, the error number and the error message, which is called instead. If called ContinuableError ContinuableError from ContinuableError with a non-NIL third argument, any value returned by the error handler is returned as the value of the function call. Throw Throw Otherwise, normal termination of the handler Throws to the closest ErrorSet ErrorSet surrounding ErrorSet. |
Added psl-1983/lpt/15-debug.lpt version [47126e95b6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Debugging Tools section 15.0 page 15.1 CHAPTER 15 CHAPTER 15 CHAPTER 15 DEBUGGING TOOLS DEBUGGING TOOLS DEBUGGING TOOLS 15.1. Introduction . . . . . . . . . . . . . . . 15.1 15.1.1. Brief Summary of Full Debug Package . . . . . 15.1 15.1.2. Mini-Trace Facility . . . . . . . . . . 15.2 15.1.3. Step . . . . . . . . . . . . . . . 15.3 .... 15.1.4. Functions Which Depend on Redefining User Functions..15.4 15.1.5. A Few Known Deficiencies. . . . . . . . . 15.5 15.2. Tracing Function Execution . . . . . . . . . . 15.5 15.2.1. Tracing Functions . . . . . . . . . . . 15.5 15.2.2. Saving Trace Output . . . . . . . . . . 15.6 15.2.3. Making Tracing More Selective . . . . . . . 15.7 15.2.4. Turning Off Tracing . . . . . . . . . . 15.9 15.2.5. Enabling Debug Facilities and Automatic Tracing of 15.9 Newly Defined Functions . . . . . . . . . 15.3. A Heavy Handed Backtrace Facility . . . . . . . . 15.10 15.4. Embedded Functions . . . . . . . . . . . . . 15.11 15.5. Counting Function Invocations . . . . . . . . . 15.12 15.6. Stubs . . . . . . . . . . . . . . . . . 15.12 15.7. Functions for Printing Useful Information . . . . . 15.13 15.8. Printing Circular and Shared Structures . . . . . . 15.13 15.9. Internals and Customization . . . . . . . . . . 15.14 15.9.1. User Hooks . . . . . . . . . . . . . 15.14 15.9.2. Functions Used for Printing/Reading . . . . . 15.15 15.10. Example . . . . . . . . . . . . . . . . 15.16 15.1. Introduction 15.1. Introduction 15.1. Introduction PSL offers a small group of debugging functions in a mini-trace package described in Section MINITRACE; in addition, there is a separate debugging package which is the subject of the bulk of this Chapter. To use the debugging package (LOAD DEBUG). An extensive example showing the use of the facilities in the debugging package can be found in Section 15.10. 15.1.1. Brief Summary of Full Debug Package 15.1.1. Brief Summary of Full Debug Package 15.1.1. Brief Summary of Full Debug Package The PSL debugging package contains a selection of functions that can be 1 used to aid program development and to investigate faulty programs. _______________ 1 Much of this Chapter was adapted from a paper by Norman and Morrison. Debugging Tools 7 February 1983 PSL Manual page 15.2 section 15.1 It contains the following facilities. - A trace package. This allows the user to see the arguments passed to and the values returned by selected functions. It is also possible to have traced interpreted functions print all the SetQ SetQ assignments they make with SetQ (see Section 15.2). - A backtrace facility. This allows one to see which of a set of selected functions were active as an error occurred (see Section 15.3). - Embedded functions make it possible to do everything that the trace package can do, and much more besides (see Section 15.4). This facility is available only in RLISP. - Some primitive statistics gathering (see Section 15.5). - Generation of simple stubs. If invoked, procedures defined as stubs simply print their argument and read a value to return (see Section 15.6). - Some functions for printing useful information, such as property lists, in an intelligible format (see Section 15.7). PrintX PrintX - PrintX is a function that can print circular and re-entrant lists and vectors, and so can sometimes allow debugging to proceed even RplacA RplacA in the face of severe damage caused by the wild use of RplacA and RplacD RplacD RplacD (see Section 15.8). [??? Install a feature BR and UNBR to wrap a break around functions. [??? Install a feature BR and UNBR to wrap a break around functions. [??? Install a feature BR and UNBR to wrap a break around functions. See the old mini-trace (PK:MINI-TRACE.RED). ???] See the old mini-trace (PK:MINI-TRACE.RED). ???] See the old mini-trace (PK:MINI-TRACE.RED). ???] 15.1.2. Mini-Trace Facility 15.1.2. Mini-Trace Facility 15.1.2. Mini-Trace Facility A small trace package is provided in the bare PSL and RLISP. This Tr Tr provides a command Tr for tracing LISP function calls, as does the full UnTr UnTr Debug package. This command and the associated command UnTr are used in the form: Tr Tr Tr <function name>, <function name>,..., <function name>; or Tr Tr Tr( <function name>, <function name>,..., <function name>); from RLISP, and Tr Tr (Tr <function name> <function name> ... <function name>) from LISP. PSL Manual 7 February 1983 Debugging Tools section 15.1 page 15.3 Tr Tr _____ __ _________ _____ (Tr [FNAME:id]): Undefined macro UnTr UnTr _____ __ _________ _____ (UnTr [FNAME:id]): Undefined macro Mini-Trace also contains the capability for tracing interpreted functions Trst Trst at a deeper level. Trst causes the body of an interpreted function to be Trst Trst redefined so that all assignments in its body are printed. Calling Trst on Tr UnTrst Tr UnTrst a function has the effect of doing a Tr on it too. The function UnTrst is Trst Trst used to turn off the effects of Trst. These functions are used in the same Tr UnTr Tr UnTr way as Tr and UnTr. Trst Trst _____ __ _________ _____ (Trst [FNAME:id]): Undefined macro UnTrst UnTrst _____ __ _________ _____ (UnTrst [FNAME:id]): Undefined macro Tr Trst Tr Trst Note that only the functions Tr and Trst are in Mini-Trace. However invoking either of them causes the debug package to be loaded, making the rest of the functions in Debug available. Do (HELP TRACE) for more information, or see Section 15.2. 15.1.3. Step 15.1.3. Step 15.1.3. Step Step Step _ ____ ___ ____ (Step F:form): any expr Step Step _ Step is a loadable option (LOAD STEP). It evaluates the form F, _ single-stepping. F is printed, preceded by -> on entry, <-> for _ macro expansions. After evaluation, F is printed preceded by <- and followed by the result of evaluation. A single character is read at each step to determine the action to be taken: <Ctrl-N> (Next) Step to the Next thing. The stepper continues until the next thing to print out, and it accepts another command. Space Go to the next thing at this level. In other words, continue to evaluate at this level, but don't step anything at lower levels. This is a good way to skip over parts of the evaluation that don't interest you. <Ctrl-U> (Up) Continue evaluating until we go up one level. This is like the space command, only more so; it skips over anything on the current level as well as lower levels. Debugging Tools 7 February 1983 PSL Manual page 15.4 section 15.1 <Ctrl-X> (eXit) Exit; finish evaluating without any more stepping. <Ctrl-G> or <Ctrl-P> (Grind) Grind (i.e. prettyprint) the current form. <Ctrl-R> Grind the form in Rlisp syntax. <Ctrl-E> (Editor) Invoke the structure editor on the current form. <Ctrl-B> (Break) Enter a break loop from which you can examine the values of variables and other aspects of the current environment. <Ctrl-L> Redisplay the last 10 pending forms. ? Display the help file. H H _ To step through the evaluation of function H on argument X do (Step '(H X)) 15.1.4. Functions Which Depend on Redefining User Functions 15.1.4. Functions Which Depend on Redefining User Functions 15.1.4. Functions Which Depend on Redefining User Functions A number of facilities in Debug depend on redefining user functions, so that they may log or print behavior if called. The Debug package tries to redefine user functions once and for all, and then keep specific information about what is required at run time in a table. This allows considerable flexibility, and is used for a number of different facilities, including trace/traceset in Section 15.2, a backtrace facility in Section 15.3, some statistics gathering in Section 15.5 and embedding functions in Section 15.4. Some facilities, like trace and EMB (the embedding function), only take effect if further action is requested on specific user functions. Others, like backtrace and statistics, are of a more global nature. Once one of these global facilities is enabled it applies to all functions which have Restr Restr been made "known" to Debug. To undo this, use Restr defined in Section 15.2.4. 15.1.5. A Few Known Deficiencies 15.1.5. A Few Known Deficiencies 15.1.5. A Few Known Deficiencies Cons Cons - An attempt to trace certain system functions (e.g. Cons) causes the trace package to overwrite itself. Given the names of functions that cause this sort of trouble it is fairly easy to change the trace package to deal gracefully with them - so report PSL Manual 7 February 1983 Debugging Tools section 15.1 page 15.5 trouble to a system expert. - The Portable LISP Compiler uses information about registers which certain system functions destroy. Tracing these functions may make the optimizations based thereon invalid. The correct way of handling this problem is currently under consideration. In the mean time you should avoid tracing any functions with the ONEREG or TWOREG flags. 15.2. Tracing Function Execution 15.2. Tracing Function Execution 15.2. Tracing Function Execution 15.2.1. Tracing Functions 15.2.1. Tracing Functions 15.2.1. Tracing Functions To see when a function gets called, what arguments it is given and what value it returns, do (TR functionname) or if several functions are of interest, (TR name1 name2 ...) Tr Tr _____ __ _________ _____ (Tr [FNAME:id]): Undefined macro ____ _____ _____ ____ _____ _____ ____ _____ _____ expr fexpr nexpr expr fexpr nexpr If the specified functions are defined (as expr, fexpr, nexpr or _____ _____ _____ macro Tr macro Tr macro), Tr modifies the function definition to include print statements. The following example shows the style of output produced by this sort of tracing: The input... (DE XCDR (A) (CDR A) %A very simple function) (TR XCDR) (XCDR '(P Q R)) gives output... XCDR entered A: (P Q R) XCDR = (Q R) Interpreted functions can also be traced at a deeper level. Debugging Tools 7 February 1983 PSL Manual page 15.6 section 15.2 Trst Trst _____ __ _________ _____ (Trst [FNAME:id]): Undefined macro (TRST name1 name2 ...) causes the body of an interpreted function to be redefined so SetQ SetQ that all assignments (made with SetQ) in its body are printed. Trst Trst Calling Trst on a function automatically has the effect of doing Tr Tr a Tr on it too, so that it is not possible to have a function Trst Tr Trst Tr subject to Trst but not Tr. Trace output often appears mixed up with output from the program being Tr Tr studied, and to avoid too much confusion Tr arranges to preserve the column in which printing was taking place across any output that it generates. If trace output is produced as part of a line has been printed, the trace data are enclosed in markers '<' and '>', and these symbols are placed on the line so as to mark out the amount of printing that had occurred before trace was entered. __________ ______ !*NOTRARGS [Initially: NIL] switch If !*NOTRARGS is T, printing of the arguments of traced functions is suppressed. 15.2.2. Saving Trace Output 15.2.2. Saving Trace Output 15.2.2. Saving Trace Output The trace facility makes it possible to discover in some detail how a function is used, but in certain cases its direct use results in the generation of vast amounts of (mostly useless) print-out. There are several options. One is to make tracing more selective (see Section 15.2.3). The other, discussed here, is to either print only the most recent information, or dump it all to a file to be perused at leisure. Debug has a ring buffer in which it saves information to reproduce the Tr Trst Tr Trst most recent information printed by the trace facility (both Tr and Trst). Tr Tr To see the contents of this buffer use Tr without any arguments (TR) NewTrBuff NewTrBuff _ _______ _________ ____ (NewTrBuff N:integer): Undefined expr To set the number of entries retained to n use (NEWTRBUFF n) Initially the number of entries in the ring buffer is 5. PSL Manual 7 February 1983 Debugging Tools section 15.2 page 15.7 __________ ______ !*TRACE [Initially: T] switch Enables runtime printing of trace information for functions which have been traced. Turning off the TRACE switch (OFF TRACE) suppresses the printing of any trace information at run time; it is still saved in the ring buffer. Thus a useful technique for isolating the function in which an error occurs is to trace a large number of candidate functions, do OFF TRACE and after the failure look at the latest trace Tr Tr information by calling Tr with no arguments. TrOut TrOut _____ __ _________ ____ (TrOut [FNAME:id]): Undefined expr StdTrace StdTrace _________ ____ (StdTrace ): Undefined expr Normally trace information is directed to the standard output, rather than the currently selected output. To send it elsewhere use the statement (TROUT filename) The statement (STDTRACE) closes that file and cause future trace output to be sent to the standard output. Note that output saved in the ring buffer is sent to the currently selected output, not that selected by TrOut TrOut TrOut. 15.2.3. Making Tracing More Selective 15.2.3. Making Tracing More Selective 15.2.3. Making Tracing More Selective TraceCount TraceCount _ _______ _________ ____ (TraceCount N:integer): Undefined expr TraceCount TraceCount The function (TraceCount n) can be used to switch off trace TraceCount TraceCount output. If n is a positive number, after a call to (TraceCount n) the next n items of trace output that are generated are not TraceCount TraceCount printed. (TraceCount n) with n negative or zero switches all TraceCount TraceCount trace output back on. (TraceCount NIL) returns the residual count, i.e. the number of additional trace entries that are suppressed. To get detailed tracing in the stages of a calculation that lead up to an error, try Debugging Tools 7 February 1983 PSL Manual page 15.8 section 15.2 (TRACECOUNT 1000000) % or some other suitable large number (TR ...) % as required %run the failing problem (TRACECOUNT NIL) It is now possible to calculate how many trace entries occurred before the TraceCount TraceCount error, and so the problem can now be re-run with TraceCount set to some number slightly less than that. TraceCount TraceCount An alternative to the use of TraceCount for getting more selective trace TrIn TrIn output is TrIn. TrIn TrIn _____ __ _________ _____ (TrIn [FNAME:id]): Undefined macro TrIn TrIn To use TrIn, establish tracing for a collection of functions, Tr TrIn Tr TrIn using Tr in the normal way. Then do TrIn on some small Tr Tr collection of other functions. The effect is just as for Tr, except that trace output is inhibited except if control is TrIn TrIn dynamically within the TrIn functions. This makes it possible to Tr Tr use Tr on a number of heavily used general purpose functions, and then only see the calls to them that occur within some specific subpart of your entire program. __________ ______ TRACEMINLEVEL!* [Initially: 0] global __________ ______ TRACEMAXLEVEL!* [Initially: 1000] global The global variables TRACEMINLEVEL!* and TRACEMAXLEVEL!* (whose values should be non-negative integers) are the minimum and maximum depths of recursion at which to print trace information. Thus if you only want to see top level calls of a highly Length Length recursive function (like a simple-minded version of Length) simply do (SETQ TRACEMAXLEVEL!* 1) 15.2.4. Turning Off Tracing 15.2.4. Turning Off Tracing 15.2.4. Turning Off Tracing If a particular function no longer needs tracing, do (UNTR functionname) or (UNTR name1 name2 ...) PSL Manual 7 February 1983 Debugging Tools section 15.2 page 15.9 UnTr UnTr _____ __ _________ _____ (UnTr [FNAME:id]): Undefined macro This merely suppresses generation of trace output. Other information, such as invocation counts, backtrace information, and the number of arguments is retained. To completely destroy information about a function use (RESTR name1 name2 ...) Restr Restr _____ __ _________ ____ (Restr [FNAME:id]): Undefined expr This returns the function to it's original state. To suppress traceset output without suppressing normal trace output use (UNTRST name1 name2 ...) UnTrst UnTrst _____ __ _________ _____ (UnTrst [FNAME:id]): Undefined macro UnTr Trst UnTrst UnTr Trst UnTrst UnTring a Trsted function also UnTrst's it. TrIn UnTr UnTrst TrIn UnTr UnTrst TrIn in Section 15.2.3 is undone by UnTr (but not by UnTrst). 15.2.5. Enabling Debug Facilities and Automatic Tracing 15.2.5. Enabling Debug Facilities and Automatic Tracing 15.2.5. Enabling Debug Facilities and Automatic Tracing Under the influence of (ON TRACEALL) PutD PutD PutD PutD any functions successfully defined by PutD are traced. Note that if PutD fails (as might happen under the influence of the LOSE flag) no attempt is made to trace the function. Btr TrCount Btr TrCount To enable those facilities (such as Btr in Section 15.3 and TrCount in Section 15.5) which require redefinition, but without tracing, use (ON INSTALL) Thus, a common scenario might look like (ON INSTALL) (DSKIN "MYFNS.SL") (OFF INSTALL) which would enable the backtrace and statistics routines to work with all the functions defined in the MYFNS file. Debugging Tools 7 February 1983 PSL Manual page 15.10 section 15.2 __________ ______ !*INSTALL [Initially: NIL] switch PutD PutD Causes DEBUG to know about all functions defined with PutD. __________ ______ !*TRACEALL [Initially: NIL] switch PutD PutD Causes all functions defined with PutD to be traced. 15.3. A Heavy Handed Backtrace Facility 15.3. A Heavy Handed Backtrace Facility 15.3. A Heavy Handed Backtrace Facility The backtrace facility allows one to see which of a set of selected Btr Btr functions were active as an error occurred. The function Btr gives the backtrace information. The information kept is controlled by two switches: !*BTR and !*BTRSAVE. When backtracing is enabled (BTR is on), a stack is kept of functions entered but not left. This stack records the names of functions and the arguments that they were called with. If a function returns normally the stack is unwound. If however the function fails, the stack is left alone by the normal LISP error recovery processes. Btr Btr _____ __ _________ _____ (Btr [FNAME:id]): Undefined macro Btr Btr When called with no arguments, Btr prints the backtrace information available. When called with arguments (which should be function names), the stack is reset to NIL, and the functions named are added to the list of functions Debug knows about. ResBtr ResBtr _____ __ _________ ____ (ResBtr [FNAME:id]): Undefined expr ResBtr ResBtr ResBtr resets the backtrace stack to NIL. __________ ______ !*BTR [Initially: T] switch If !*BTR is T, it enables backtracing of functions which the Debug package has been told about. If it is NIL, backtrace information is not saved. __________ ______ !*BTRSAVE [Initially: T] switch Controls the disposition of information about functions which ErrorSet ErrorSet failed within an ErrorSet. If it is on, the information is saved separately and printed when the stack is printed. If it is off, the information is thrown away. PSL Manual 7 February 1983 Debugging Tools section 15.4 page 15.11 15.4. Embedded Functions 15.4. Embedded Functions 15.4. Embedded Functions Embedding means redefining a function in terms of its old definition, usually with the intent that the new version does some tests or printing, uses the old one, does some more printing and then returns. If ff is a function of two arguments, it can be embedded using a statement of the form: SYMBOLIC EMB PROCEDURE ff(A1,A2); << PRINT A1; PRINT A2; PRINT ff(A1,A2) >>; Tr Tr The effect of this particular use of embed is broadly similar to a call Tr ff, and arranges that whenever ff is called it prints both its arguments and its result. After a function has been embedded, the embedding can be temporarily removed by the use of UNEMBED ff; and it can be reinstated by EMBED ff; This facility is available only to RLISP users. 15.5. Counting Function Invocations 15.5. Counting Function Invocations 15.5. Counting Function Invocations __________ ______ !*TRCOUNT [Initially: T] switch Enables counting invocations of functions known to Debug. If the switch TRCOUNT is ON, the number of times user functions known to Debug are entered is counted. The statement (ON TRCOUNT) also resets that count to zero. The statement (OFF TRCOUNT) causes a simple histogram of function invocations to be printed. Tr Tr If regular tracing (provided by Tr) is not desired, but you wish to count the function invocations, use (TRCNT name1 name2 ...) Debugging Tools 7 February 1983 PSL Manual page 15.12 section 15.5 TrCnt TrCnt _____ __ _________ _____ (TrCnt [FNAME:id]): Undefined macro See also Section 15.2.5. 15.6. Stubs 15.6. Stubs 15.6. Stubs Stubs are useful in top-down program development. If a stub is invoked, it prints its arguments and asks for a value to return. Stub Stub __________ ____ _____ (Stub [FuncInvoke:form]): macro __________ Each FUNCINVOKE must be of the form (id arg1 arg2 ...), where ____ ____ ____ Stub expr Stub expr there may be zero arguments. Stub defines an expr for each form with name id and formal arguments arg1, arg2, etc. If executed such a stub prints its arguments and reads a value to return. The statement (STUB (FOO U V)) ____ ____ ____ expr Foo expr Foo defines an expr, Foo, of two arguments. FStub FStub __________ ____ ___ _____ (FStub [FuncInvoke:form]): Nil macro _____ _____ _____ FStub Stub fexpr FStub Stub fexpr FStub does the same as Stub but defines fexprs. At present the currently (i.e. when the stub is executed) selected input and output are used. This may be changed in the future. Algebraic and _____ _____ _____ macro macro possibly macro stubs may be implemented in the future. 15.7. Functions for Printing Useful Information 15.7. Functions for Printing Useful Information 15.7. Functions for Printing Useful Information PList PList _ __ _____ (PList [X:id]): macro (PLIST id1 id2 ...) __ prints the property lists of the specified ids in an easily readable form. Ppf Ppf _____ __ _____ (Ppf [FNAME:id]): macro (PPF fn1 fn2 ...) prints the definitions and other useful information about the PSL Manual 7 February 1983 Debugging Tools section 15.7 page 15.13 specified functions. 15.8. Printing Circular and Shared Structures 15.8. Printing Circular and Shared Structures 15.8. Printing Circular and Shared Structures Some LISP programs rely on parts of their data structures being shared, Eq Equal Eq Equal so that an Eq test can be used rather than the more expensive Equal one. Other programs (either deliberately or by accident) construct circular RplacA RplacD RplacA RplacD lists through the use of RplacA or RplacD. Such lists can be displayed by PrintX PrintX use of the function PrintX. This function also prints circular vectors. PrintX PrintX _ ___ ___ ____ (PrintX A:any): NIL expr If given a normal list the behavior of this function is similar Print Print to that of Print; if it is given a looped or re-entrant data structures it prints it in a special format. The representation PrintX PrintX used by PrintX for re-entrant structures is based on the idea of labels for those nodes in the structure that are referred to more than once. Consider the list created by the operations: (SETQ R '(S W)) (RPLACA R (CDR R)) Print Print _ The function Print called on the list R gives ((W) W) PrintX PrintX _ _ If PrintX is called on the list R, it discovers that the list (W) is referred to twice, and invents the label %L1 for it. The structure is then printed as (%L1: (W) . %L1) %L1: sets the label, and the other instance of %L1 refers back to it. Labeled sublists can appear anywhere within the list being printed. Thus the list created by the following statements (SETQ L '(A B C)) (SETQ K (CDR L)) (SETQ X (CONS L K)) which is printed as ((A B C) B C) Print PrintX Print PrintX by Print could be printed by PrintX as Debugging Tools 7 February 1983 PSL Manual page 15.14 section 15.8 ((A %L1, B C) . %L1) A label set with a comma (rather than a colon) is a label for part of a list, not for the sublist. __________ ______ !*SAVENAMES [Initially: NIL] switch PrintX PrintX If on, names assigned to substructures by PrintX are retained from one use to the next. Thus substructures common to different items will be shown as the same. 15.9. Internals and Customization 15.9. Internals and Customization 15.9. Internals and Customization This Section describes some internal details of the Debug package which may be useful in customizing it for specific applications. The reader is urged to consult the source for further details. 15.9.1. User Hooks 15.9.1. User Hooks 15.9.1. User Hooks These are all global variables whose values are normally NIL. If ____ ____ ____ expr expr non-NIL, they should be exprs taking the number of variables specified, and are called as specified. __________ ______ PUTDHOOK!* [Initially: NIL] global Takes one argument, the function name. It is called after the function has been defined, and any tracing under the influence of !*TRACEALL or !*INSTALL has taken place. It is not called if the function cannot be defined (as might happen if the function has been flagged LOSE). __________ ______ TRACENTRYHOOK!* [Initially: NIL] global Takes two arguments, the function name and a list of the actual arguments. It is called by the trace package if a traced function is entered, but before it is executed. The execution of a surrounding EMB function takes place after TRACENTRYHOOK!* is called. This is useful if you need to call special user-provided print routines to display critical data structures, as are TRACEXITHOOK!* and TRACEXPANDHOOK!*. __________ ______ TRACEXITHOOK!* [Initially: NIL] global Takes two arguments, the function name and the value. It is called after the function has been evaluated. PSL Manual 7 February 1983 Debugging Tools section 15.9 page 15.15 __________ ______ TRACEXPANDHOOK!* [Initially: NIL] global _____ _____ _____ macro macro Takes two arguments, the function name and the macro expansion. _____ _____ _____ _____ _____ _____ macro macro macro macro It is only called for macros, and is called after the macro is expanded, but before the expansion has been evaluated. __________ ______ TRINSTALLHOOK!* [Initially: NIL] global Takes one argument, a function name. It is called if a function is redefined by the Debug package, as for example when it is first traced. It is called before the redefinition takes place. 15.9.2. Functions Used for Printing/Reading 15.9.2. Functions Used for Printing/Reading 15.9.2. Functions Used for Printing/Reading _____ _____ _____ EXPRS EXPRS These should all contain EXPRS taking the specified number of arguments. The initial values are given in square brackets. __________ ______ PPFPRINTER!* [Initially: PRINT] global Ppf Ppf Takes one argument. It is used by Ppf to print the body of an interpreted function. __________ ______ PROPERTYPRINTER!* [Initially: PRETTYPRINT] global PList PList Takes one argument. It is used by PList to print the values of properties. __________ ______ STUBPRINTER!* [Initially: PRINTX] global Stub/FStub Stub/FStub Takes one argument. Stubs defined with Stub/FStub use it to print their arguments. __________ ______ STUBREADER!* [Initially: !-REDREADER] global Stub/FStub Stub/FStub Takes no arguments. Stubs defined with Stub/FStub use it to read their return value. __________ ______ TREXPRINTER!* [Initially: PRINT] global Takes one argument. It is used to print the expansions of traced _____ _____ _____ macro macro macros. Debugging Tools 7 February 1983 PSL Manual page 15.16 section 15.9 __________ ______ TRPRINTER!* [Initially: PRINTX] global Takes one argument. It is used to print the arguments and values of traced functions. __________ ______ TRSPACE!* [Initially: 0] global Controls indentation. 15.10. Example 15.10. Example 15.10. Example This contrived example demonstrates many of the available features. It is a transcript of an actual PSL session. PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.17 @PSL PSL 3.1, 15-Nov-82 1 lisp> (LOAD DEBUG) NIL 2 lisp> (DE FOO (N) 2 lisp> (PROG (A) 2 lisp> (COND ((AND (NEQ (REMAINDER N 2) 0) (LESSP N 0)) 2 lisp> (SETQ A (CAR N)))) %Should err out if N is a n 2 lisp> (COND ((EQUAL N 0) (RETURN 'BOTTOM))) 2 lisp> (SETQ N (DIFFERENCE N 2)) 2 lisp> (SETQ A (BAR N)) 2 lisp> (SETQ N (DIFFERENCE N 2)) 2 lisp> (RETURN (LIST A (BAR N) A)))) FOO 3 lisp> (DE FOOBAR (N) 3 lisp> (PROGN (FOO N) NIL)) FOOBAR 4 lisp> (TR FOO FOOBAR) (FOO FOOBAR) 5 lisp> (PPF FOOBAR FOO) EXPR procedure FOOBAR(N) [TRACED;Invoked 0 times]: PROGN (FOO N) NIL EXPR procedure FOO(N) [TRACED;Invoked 0 times]: PROG (A) (COND ((AND (NEQ (REMAINDER N 2) 0) (LESSP N 0)) (SETQ A (CAR N)))) (COND ((EQUAL N 0) (RETURN 'BOTTOM))) (SETQ N (DIFFERENCE N 2)) (SETQ A (BAR N)) (SETQ N (DIFFERENCE N 2)) (RETURN (LIST A (BAR N) A)) (FOOBAR FOO) 6 lisp> (ON COMP) NIL 7 lisp> (DE BAR (N) 7 lisp> (COND ((EQUAL (REMAINDER N 2) 0) (FOO (TIMES 2 (QUOTIENT N 7 lisp> (T (FOO (SUB1 (TIMES 2 (QUOTIENT N 4))))))) *** (BAR): base 275266, length 21 words BAR 8 lisp> (OFF COMP) NIL 9 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered Debugging Tools 7 February 1983 PSL Manual page 15.18 section 15.10 N: 8 FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO (level 2) being entered N: 2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 10 lisp> % Notice how in the above PRINTX printed the return values 10 lisp> % to show shared structure 10 lisp> (TRST FOO) (FOO) 11 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered N: 8 N := 6 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) A := (BOTTOM BOTTOM BOTTOM) N := 4 FOO (level 2) being entered N: 2 N := 0 FOO (level 3) being entered N: 0 PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.19 FOO (level 3) = BOTTOM A := BOTTOM N := -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 12 lisp> (TR BAR) (BAR) 13 lisp> (FOOBAR 8) FOOBAR being entered N: 8 FOO being entered N: 8 BAR being entered A1: 6 FOO (level 2) being entered N: 2 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) BAR being entered A1: 4 FOO (level 2) being entered N: 2 BAR (level 2) being entered A1: 0 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM BAR (level 2) being entered A1: -2 FOO (level 3) being entered N: 0 FOO (level 3) = BOTTOM BAR (level 2) = BOTTOM Debugging Tools 7 February 1983 PSL Manual page 15.20 section 15.10 FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL NIL 14 lisp> (OFF TRACE) NIL 15 lisp> (FOOBAR 8) NIL 16 lisp> (TR) *** Start of saved trace information *** BAR (level 2) = BOTTOM FOO (level 2) = (BOTTOM BOTTOM BOTTOM) BAR = (BOTTOM BOTTOM BOTTOM) FOO = (%L1: (BOTTOM BOTTOM BOTTOM) (BOTTOM BOTTOM BOTTOM) %L1) FOOBAR = NIL *** End of saved trace information *** NIL 17 lisp> (FOOBAR 13) ***** An attempt was made to do CAR on `-1', which is not a pair Break loop 18 lisp break>> Q 19 lisp> (TR) *** Start of saved trace information *** FOO being entered N: 13 BAR being entered A1: 11 FOO (level 2) being entered N: 3 BAR (level 2) being entered A1: 1 FOO (level 3) being entered N: -1 *** End of saved trace information *** NIL 20 lisp> (BTR) *** Backtrace: *** These functions were left abnormally: FOO N: -1 BAR A1: 1 FOO N: 3 BAR A1: 11 FOO N: 13 FOOBAR PSL Manual 7 February 1983 Debugging Tools section 15.10 page 15.21 N: 13 *** End of backtrace *** NIL 21 lisp> (STUB (FOO N)) *** Function `FOO' has been redefined NIL 22 lisp> (FOOBAR 13) Stub FOO called N: 13 Return? : 22 lisp> (BAR (DIFFERENCE N 2)) Stub FOO called N: 3 Return? : 22 lisp> (BAR (DIFFERENCE N 2)) Stub FOO called N: -1 Return? : 22 lisp> 'ERROR NIL 23 lisp> (TR) *** Start of saved trace information *** BAR being entered A1: 11 BAR (level 2) being entered A1: 1 BAR (level 2) = ERROR BAR = ERROR FOOBAR = NIL *** End of saved trace information *** NIL 24 lisp> (OFF TRCOUNT) FOOBAR(6) ****************** BAR(16) ************************************************ NIL 22 lisp> (QUIT) |
Added psl-1983/lpt/16-editor.lpt version [78cbe45cb5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 EDITOR section 16.0 page 16.1 CHAPTER 16 CHAPTER 16 CHAPTER 16 EDITORS EDITORS EDITORS 16.1. A Mini-Structure Editor . . . . . . . . . . . 16.1 16.2. The EMODE Screen Editor . . . . . . . . . . . 16.3 16.2.1. Windows and Buffers in Emode . . . . . . . 16.5 16.3. Introduction to the Full Structure Editor . . . . . 16.6 16.4. User Entry to Editor . . . . . . . . . . . . 16.6 16.5. Editor Command Reference . . . . . . . . . . . 16.8 16.1. A Mini Structure-Editor 16.1. A Mini Structure-Editor 16.1. A Mini Structure-Editor PSL and RLISP provide a fairly simple structure editor, essentially a subset of the structure editor described below in section FULL-STRUCTURE-EDITOR. This mini editor is usually resident in PSL and RLISP, or can be LOADed. It is useful for correcting errors in input, often via the E option in the BREAK loop. Do HELP(EDITOR) for more information. Edit Edit To edit an expression, call the function Edit with the expression as an argument. The edited copy is returned. To edit the definition of a EditF EditF function, call EditF with the function name as an argument. In the editor, the following commands are available (N indicates a _______ non-negative integer): P P ____ P edit Prints the subexpression under consideration. On entry, this is the entire expression. This only prints down PLEVEL levels, replacing all edited subexpressions by ***. PLEVEL is initially 3. PL PL _ ____ PL (N) edit _ Changes PLEVEL to N. ____ _______ ____ _______ ____ _______ N edit-command N _______ edit-command N:integer edit-command Sets the subexpression under consideration to be the nth subexpression of the current one. That is, walk down to the nth subexpression. EDITOR 7 February 1983 PSL Manual page 16.2 section 16.1 ____ _______ ____ _______ ____ _______ -N edit-command -N _______ edit-command -N:integer edit-command Cdr Cdr Sets the current subexpression to be the nth Cdr of the current one. UP UP ____ UP edit Go to the subexpression you were in just before this one. T T ____ T edit Go to the top of the original expression. F F _ ____ F (S) edit _ Find the first occurrence of the S-expression S. The test is Equal Eq Equal Eq performed by Equal, not Eq. The current level is set to the _ first level in which S was found. ____ _______ ____ _______ ____ _______ N edit-command N _______ edit-command (N:integer) edit-command Delete the Nth element of the current expression. ____ _______ ____ _______ ____ _______ N edit-command N _______ ___ edit-command (N:integer [ARG]) edit-command ___ Replace the Nth element by ARGs. ____ _______ ____ _______ ____ _______ -N edit-command -N _______ ___ edit-command (-N:integer [ARG]) edit-command ___ Insert the elements ARGs before the nth element. R R __ __ ____ (R S1 S2) edit Replace all occurrences of S1 (in the tree you are placed at) by S2. B B ____ B edit Break Break Enter a Break loop under the editor. PSL Manual 7 February 1983 EDITOR section 16.1 page 16.3 OK OK ____ OK edit Leave the editor, returning the edited expression. HELP HELP ____ HELP edit Print an explanatory message. Break Break If the editor is called from a Break loop, the edited value is assigned back to ERRORFORM!*. 16.2. The EMODE Screen Editor 16.2. The EMODE Screen Editor 16.2. The EMODE Screen Editor EMODE is an EMACS-like screen editor, written entirely in PSL. To invoke EMODE, call the function EMODE after LOADing the EMODE module. EMODE is modeled after EMACS, so use that fact as a guide. After starting up EMODE, you can use one of the following commands to exit. <Ctrl-X Ctrl-Z> "quits" to the EXEC (you can continue or start again). <Ctrl-Z Ctrl-Z> goes back into "normal" I/O mode. EMODE is built to run on a Teleray terminal as the default. To use some other terminal you must LOAD in a set of different driver functions after loading EMODE. The following drivers are currently available: - HP2648A - TELERAY - VT100 - VT52 - AAA [Ann Arbor Ambassador] The sources for these files are on <PSL.EMODE> (logical name PE:). It should be quite easy to modify one of these files for other terminals. See the file PE:TERMINAL-DRIVERS.TXT for some more information on how this works. An important (but currently somewhat bug-ridden) feature of EMODE is the ability to evaluate expressions that are in your buffer. Use <Meta-E> to evaluate the expression starting on the current line. <Meta-E> (normally) automatically enters two window mode if anything is "printed" to the OUT_WINDOW buffer, which is shown in the lower window. If you don't want EDITOR 7 February 1983 PSL Manual page 16.4 section 16.2 to see things being printed to the output window, you can set the variable !*OUTWINDOW to NIL. (Or use the RLISP command "OFF OUTWINDOW;".) This prevents EMODE from automatically going into two window mode if something is printed to OUT_WINDOW. You must still use the "<Ctrl-X> 1" command to enter one window mode initially. You may also find the <Ctrl-Meta-Y> command useful. This inserts into the current buffer the text printed as a result of the last <Meta-E>. The function "PrintAllDispatch" prints out the current dispatch table. You must call EMODE before this table is set up. While in EMODE, the <Meta-?> (meta-question mark) character asks for a command character and tries to print information about it. The basic dispatch table is (roughly) as follows: Character Function Comments <Ctrl-@> SETMARK <Ctrl-A> !$BEGINNINGOFLINE <Ctrl-B> !$BACKWARDCHARACTER <Ctrl-D> !$DELETEFORWARDCHARACTER <Ctrl-E> !$ENDOFLINE <Ctrl-F> !$FORWARDCHARACTER Linefeed !$CRLF Acts like carriage return <Ctrl-K> KILL_LINE <Ctrl-L> FULLREFRESH Return !$CRLF <Ctrl-N> !$FORWARDLINE <Ctrl-O> OPENLINE <Ctrl-P> !$BACKWARDLINE <Ctrl-R> Backward search for string, type a carriage return to terminate the string <Ctrl-S> Forward search for string <Ctrl-U> Repeat a command. Asks for count (terminate with a carriage return), then it asks for the command character <Ctrl-V> DOWNWINDOW <Ctrl-W> KILL_REGION <Ctrl-X> !$DOCNTRLX As in EMACS, <Ctrl-X> is a prefix for "fancier" commands <Ctrl-Y> INSERT_KILL_BUFFER Yanks back killed text <Ctrl-Z> DOCONTROLMETA As in EMACS, acts like <Ctrl-Meta-> escape ESCAPEASMETA As in EMACS, escape acts like the <Meta-> key rubout !$DELETEBACKWARDCHARACTER <Ctrl-Meta-B> BACKWARD_SEXPR PSL Manual 7 February 1983 EDITOR section 16.2 page 16.5 <Ctrl-Meta-F> FORWARD_SEXPR <Ctrl-Meta-K> KILL_FORWARD_SEXPR <Ctrl-Meta-Y> INSERT_LAST_EXPRESSION Insert the last "expression" typed as the result of a <Meta-E> <Ctrl-Meta-Z> OLDFACE Leave EMODE, go back to "regular" RLISP <Meta-Ctrl-rubout> KILL_BACKWARD_SEXPR <Meta-<> !$BEGINNINGOFBUFFER As in EMACS, move to beginning of buffer <Meta->> !$ENDOFBUFFER As in EMACS, move to end of buffer <Meta-?> !$HELPDISPATCH Asks for a character, tries to print information about it <Meta-B> BACKWARD_WORD <Meta-D> KILL_FORWARD_WORD <Meta-E> Evaluate an expression <Meta-V> UPWINDOW As in EMACS, move up a window <Meta-W> COPY_REGION <Meta-X> !$DOMETAX As in EMACS, <Meta-X> is another prefix for "fancy" stuff <Meta-Y> UNKILL_PREVIOUS As in EMACS <Meta-Rubout> KILL_BACKWARD_WORD <Ctrl-X> <Ctrl-B> PRINTBUFFERNAMES Prints a list of buffers <Ctrl-X> <Ctrl-R> CNTRLXREAD Read a file into the buffer <Ctrl-X> <Ctrl-W> CNTRLXWRITE Write the buffer out to a file <Ctrl-X> <Ctrl-X> EXCHANGEPOINTANDMARK <Ctrl-X> <Ctrl-Z> As in EMACS, exits to the EXEC <Ctrl-X> 1 ONEWINDOW Go into one window mode <Ctrl-X> 2 TWOWINDOWS Go into two window mode <Ctrl-X> B CHOOSEBUFFER EMODE asks for a buffer name, and then puts you in that buffer <Ctrl-X> O OTHERWINDOW Select other window <Ctrl-X> P WRITESCREENPHOTO Write a "photograph" of the screen to a file 16.2.1. Windows and Buffers in Emode 16.2.1. Windows and Buffers in Emode 16.2.1. Windows and Buffers in Emode [??? This section to be completed at a later date. ???] [??? This section to be completed at a later date. ???] [??? This section to be completed at a later date. ???] 16.3. Introduction to the Full Structure Editor 16.3. Introduction to the Full Structure Editor 16.3. Introduction to the Full Structure Editor 1 PSL also provides an extremely powerful form-oriented editor . This _______________ 1 This version of the UCI LISP editor was translated to to Standard LISP by Tryg Ager and Jim MacDonald of IMSSS, Stanford, and adapted to PSL by E. Benson. The UCI LISP editor is derived from the INTERLISP editor. EDITOR 7 February 1983 PSL Manual page 16.6 section 16.3 facility allows the user to easily alter function definitions, variable values and property list entries. It thereby makes it entirely unnecessary for the user to employ a conventional text editor in the maintenance of programs. This document is a guide to using the editor. Certain features of the UCI LISP editor have not been incorporated in the translated editor, and we have tried to mark all such differences. 16.3.1. Starting the Structure Editor 16.3.1. Starting the Structure Editor 16.3.1. Starting the Structure Editor EditF EditF This section describes normal user entry to the editor (with the EditF, EditP EditV EditP EditV EditP and EditV fuunctions) and the editing commands which are available. This section is by no means complete. In particular, material covering programmed calls to the editor routines is not treated. Consult the UCI LISP manual for further details. To edit a function named FOO do *(EDITF FOO) To edit the value of an atom named BAZ do *(EDITV BAZ) To edit the property list of an atom named FOOBAZ do *(EDITP FOOBAZ) These functions are described later in the chapter. Warning: Editing the property list of an atom may position pointers at unprintable structures. It is best to use the F (find) command before trying to print property lists. This editor capability is variable from implementation to implementation. The editor prompts with -E- * You can then input any editor command. The input scanner is not very smart. It terminates its scan and begins processing when it sees a printable character immediately followed by a carriage return. Do not use escape to terminate an editor command. If the editor seems to be PSL Manual 7 February 1983 EDITOR section 16.3 page 16.7 repeatedly requesting input type P<ret> (print the current expression) or some other command that ordinarily does no damage, but terminates the input solicitation. The following set of topics makes a good "first glance" at the editor. Entering the editor: EDITF, EDITV. Leaving the editor: OK. Editor's attention: CURRENT-EXP. Changing attention: POS-INTEGER, NEG-INTEGER, 0, ^, NX, BK. Printing: P, PP. Modification: POS-INTEGER, NEG-INTEGER, A, B, :, N. Changing parens: BI, BO. Undoing changes: UNDO. For the more discriminating user, the next topics might be some of the following. Searches: PATTERN, F, BF. Complex commands: R, SW, XTR, MBD, MOVE. Changing parens: LI, LO, RI, RO. Undoing changes: TEST, UNBLOCK, !UNDO. Other features should be skimmed but not studied until it appears that they may be useful. 16.3.2. Structure Editor Commands 16.3.2. Structure Editor Commands 16.3.2. Structure Editor Commands Note that arguments contained in angle brackets <> are optional. A A ___ ____ A ([ARG]) edit ___ _ This command inserts the ARGs (arbitrary LISP expressions) After UP UP the current expression. This is accomplished by doing an UP and a (-2 exp1 exp2 ... expn) or an (N exp1 exp2 ... expn), as appropriate. Note the way in which the current expression is UP UP changed by the UP. B B ___ ____ B ([ARG]) edit ___ _ This command inserts the ARGs (arbitrary LISP forms) Before the UP UP current expression. This is accomplished by doing an UP followed by a (-1 exp1 exp2 ... expn). Note the way in which the current UP UP expression is changed by the UP. EDITOR 7 February 1983 PSL Manual page 16.8 section 16.3 BELOW BELOW ___ _ ____ BELOW (COM, <N>) edit This command changes the current expression in the following ___ ___ manner. The edit command COM is executed. If COM is not a ___ recognized command, then (_ COM) is executed instead. Note that ___ COM should cause ascent in the edit chain (i.e. should be BELOW BELOW equivalent to some number of zeros). BELOW then evaluates (note!) N and descends N links in the resulting edit chain. That BELOW BELOW is, BELOW ascends the edit chain (does repeated 0s) looking for ___ the link specified by COM and stops N links below that (backs off N 0s). If N is not given, 1 is assumed. BF BF ___ ___ ____ BF (PAT, <FLG>) edit Also can be used as: BF PAT _ _ ___ This command performs a Backwards Find, searching for PAT (an edit pattern). Search begins with the expression immediately before the current expression and proceeds in reverse print order. (If the current expression is the top level expression, the entire expression is searched in reverse print order.) Search begins at the end of each list, and descends into each element before attempting to match that element. If the match fails, proceed to the previous element, etc. until the front of BF BF the list is reached. At that point, BF ascends and backs up, etc. The search algorithm may be slightly modified by use of a second ___ argument. Possible FLGs and their meanings are as follows. T begins search with the current expression rather than with the preceding expression at this level. BF BF ___ NIL or missing - same as BF PAT. NOTE: if the variable UPFINDFLG is non-NIL, the editor does an UP UP ___ UP after the expression matching PAT is located. Thus, doing a BF BF BF for a function name yields a current expression which is the entire function call. If this is not desired, UPFINDFLG may be set to NIL. UPFINDFLG is initially T. BF BF BF is protected from circular searches by the variable MAXLEVEL. Car Cdr Car Cdr If the total number of Cars and Cdrs descended into reaches MAXLEVEL (initially 300), search of that tail or element is abandoned exactly as though a complete search had failed. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.9 BI BI __ __ ____ BI (N1, N2) edit This command inserts a pair of parentheses in the current _ _ expression; i.e. it is a Balanced Insert. (Note that parentheses are ALWAYS balanced, and hence must be added or removed in pairs.) A left parenthesis is inserted before element N1 of the current expression. A right parenthesis is inserted after element N2 of the current expression. Both N1 and N2 are usually integers, and element N2 must be to the right of element N1. (BI n1) is equivalent to (BI n1 n1). NTH NTH The NTH command is used in the search, so that N1 and N2 may be any location specifications. The expressions used are the first element of the current expression in which the specified form is found at any level. BIND BIND ___ ____ BIND ([COM]) edit This command provides the user with temporary variables for use during the execution of the sequence of edit commands coms. There are three variables available: #1, #2 and #3. The binding BIND BIND is recursive and BIND may be executed recursively if necessary. All variables are initialized to NIL. This feature is useful chiefly in defining edit macros. BK BK ____ BK edit The current expression becomes the expression immediately _ _ preceding the present current expression; i.e. Back Up. This command generates an error if the current expression is the first expression in the list. BO BO _ ____ BO (N) edit BO BO The BO command removes a pair of parentheses from the Nth element _ _ of the current expression; i.e. it is a Balanced Remove. The NTH NTH parameter N is usually an integer. The NTH command is used in the search, however, so that any location specification may be used. The expression referred to is the first element of the current expression in which the specified form is found at any level. CHANGE CHANGE ___ __ ___ ____ (CHANGE LOC To [ARG]) edit This command replaces the current expression after executing the ___ ___ location specification LOC by ARGs. EDITOR 7 February 1983 PSL Manual page 16.10 section 16.3 COMS COMS ___ ____ (COMS [ARG]) edit ___ This command evaluates its ARGs and executes them as edit commands. COMSQ COMSQ ___ ____ (COMSQ [ARG]) edit ___ This command executes each ARG as an edit command. At any given time, the attention of the editor is focused on a single expression or form. We call that form the current expression. Editor commands may be divided into two broad classes. Those commands which change the current expression are called attention- changing commands. Those commands which modify structure are called structure modification commands. DELETE DELETE ____ DELETE edit This command deletes the current expression. If the current expression is a tail, only the first element is deleted. This command is equivalent to (:). E E ____ _ ____ (E FORM <T>) edit ____ This command evaluates FORM. This may also be typed in as: E FORM but is valid only if typed in from the TTY. (E FORM) evaluates ____ FORM and prints the value on the terminal. The form (E FORM T) ____ evaluates FORM but does not print the result. EditF EditF __ __ ___ ____ (EditF FN:id): any expr __ This function initiates editing of the function whose name is FN. EditFns EditFns __ ____ __ ____ ____ ____ ___ _____ (EditFns FN-LIST:id-list, COMS:form): NIL fexpr ____ This function applies the sequence of editor commands, COMS, to __ ____ each of several functions. The argument FN-LIST is evaluated, ____ and should evaluate to a list of function names. COMS is applied __ ____ to each function in FN-LIST, in turn. Errors in editing one function do not affect editing of others. The editor call is via EditF EditF EditF, so that values may also be edited in this way. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.11 EditP EditP __ __ ____ ____ ____ ___ _____ (EditP AT:id, COMS:form-list): any fexpr This function initiates editing of the property list of the atom ____ whose name is at. The argument COMS is a possibly null sequence of edit commands which is executed before calling for input from the terminal. EditV EditV __ __ ____ _____ ____ ___ _____ (EditV AT:id, COMS:forms-list): NIL fexpr This function initiates editing of the value of the atom whose __ ____ name is AT. The argument COMS is a possibly null sequence of edit commands which is executed before calling for input from the terminal. EMBED EMBED ___ __ ___ ____ (EMBED LOC In ARG) edit This command replaces the expression which would be current after ___ executing the location specification LOC by another expression which has that expression as a sub-expression. The manner in which the transformation is carried out depends on the form of ___ ___ ____ ARG. If ARG is a list, then each occurrence of the atom '*' in ___ ARG is replaced by the expression which would be current after ___ doing LOC. (NOTE: a fresh copy is used for each substitution.) ___ If ARG is atomic, the result is equivalent to: (EMBED loc IN (arg *)) A call of the form (EMBED loc IN exp1 exp2 ... expn) is equivalent to: (EMBED loc IN (exp1 exp2 ... expn *)) EMBED ___ EMBED If the expression after doing LOC is a tail, EMBED behaves as though the expression were the first element of that tail. EXTRACT EXTRACT ____ ____ ____ ____ (EXTRACT LOC1 From LOC2) edit This command replaces the expression which would be current after ____ doing the location specification LOC2 by the expression which ____ would be current after doing LOC1. The expression specified by EDITOR 7 February 1983 PSL Manual page 16.12 section 16.3 ____ ____ LOC1 must be a sub-expression of that specified by LOC2. F F ___ ___ ____ (F PAT <FLG>) edit Also can be used as: F PAT ___ This command causes the next command, PAT, to be interpreted as a pattern. The current expression is searched for the next ___ _ ___ occurrence of PAT; i.e. Find. If PAT is a top level element of ___ the current expression, then PAT matches that top level occurrence and a full recursive search is not attempted. Otherwise, the search proceeds in print order. Recursion is done Car Cdr Car Cdr first in the Car and then in the Cdr direction. The form (F PAT FLG) of the command may be used to modify the ___ search algorithm according to the value of FLG. Possible values and their actions are: N suppresses the top-level check. That is, finds the ___ next print order occurrence of PAT regardless of any top level occurrences. T like N, but may succeed without changing the current expression. That is, succeeds even if the current ___ expression itself is the only occurrence of PAT. positive integer ___ finds the nth place at which PAT is matched. This is equivalent to (F PAT T) followed by n-1 (F PAT N)s. If n occurrences are not found, the current expression is unchanged. NIL or missing Only searches top level elements of the current expression. May succeed without changing the current expression. NOTE: If the variable UPFINDFLG is non-NIL, F does an UP after locating a match. This ensures that F fn, in which fn is a function name, results in a current expression which is the entire function call. If this is undesirable, set UPFINDFLG to NIL. Its initial value is T. As protection against searching circular lists, the search is Car-Cdr Car-Cdr abandoned if the total number of Car-Cdr descents exceeds the PSL Manual 7 February 1983 EDITOR section 16.3 page 16.13 value of the variable MAXLEVEL. (The initial value is 300.) The search fails just as if the entire element had been unsuccessfully searched. FS FS ___ ____ (FS [PAT]) edit FS FS _ _ The FS command does sequential finds; i.e. Find Sequential. That ___ is, it searches (in print order) first for the first PAT, then ___ for the second PAT, etc. If any search fails, the current expression is left at that form which matched in the last successful search. This command is, therefore, equivalent to a F F sequence of F commands. F= F= ___ ___ ____ (F= EXP FLG) edit Eq _ Eq This command is equivalent to (F (== exp) flg); i.e. Find Eq. ___ That is, it searches, in the manner specified by FLG, for a form Eq Eq ___ which is Eq to EXP. Note that for keyboard type-ins, this always ___ fails unless EXP is atomic. HELP HELP ____ HELP edit This command provides an easy way of invoking the HELP system from the editor. I I ___ ___ ____ (I COM [ARG]) edit ___ ___ This command evaluates the ARGs and executes COM on the resulting values. This command is thus equivalent to: (com val1 val2 ... valn), Each vali is equal to (EVAL argi). IF IF ___ ____ (IF ARG) edit This command, useful in edit macros, conditionally causes an editor error. If (EVAL arg) is NIL (or if evaluation of arg IF IF causes a LISP error), then IF generates an editor error. INSERT INSERT ___ ____ (INSERT [EXP ARG LOC]) edit INSERT A B : INSERT A B : The INSERT command provides equivalents of the A, B and : ___ ___ commands incorporating a location specification, LOC. ARG can be ___ AFTER, BEFORE, or FOR. This command inserts EXPs AFTER, BEFORE or FOR (in place of) the expression which is current after ___ executing LOC. Note, however, that the current expression is not changed. EDITOR 7 February 1983 PSL Manual page 16.14 section 16.3 LC LC ___ ____ (LC LOC) edit This command, which takes as an argument a location specification, explicitly invokes the location specification _ _ search; i.e. Locate. The current expression is changed to that ___ which is current after executing LOC. ___ See LOC-SPEC for details on the definition of LOC and the search method in question. LCL LCL ___ ____ (LCL LOC) edit This command, which takes as an argument a location specification, explicitly invokes the location specification search. However, the search is limited to the current expression _ _ _ itself; i.e. Locate Limited. The current expression is changed ___ to that which is current after executing LOC. LI LI _ ____ (LI N) edit This command inserts a left parenthesis (and, of course, a _ _ matching right parenthesis); i.e. Left Parenthesis Insert. The left parenthesis is inserted before the Nth element of the current expression and the right parenthesis at the end of the current expression. Thus, this command is equivalent to (BI n -1). NTH NTH The NTH command is used in the search, so that N, which is usually an integer, may be any location specification. The expression referred to is the first element of the current expression which contains the form specified at any level. LO LO _ ____ (LO N) edit This command removes a left parenthesis (and a matching right parenthesis, of course) from the Nth element of the current _ _ expression; i.e. Left Parenthesis Remove. All elements after the Nth are deleted. NTH NTH The command uses the NTH command for the search. The parameter N, which is usually an integer, may be any location specification. The expression actually referred to is the first element of the current expression which contains the specified form at any depth. Many of the more complex edit commands take as an argument a location ___ specification (abbreviated LOC throughout this document). A location specification is a list of edit commands, which are, with two exceptions, executed in the normal way. Any command not recognized by the editor is PSL Manual 7 February 1983 EDITOR section 16.3 page 16.15 F F treated as though it were preceded by F. Furthermore, if one of the commands causes an error and the current expression has been changed by prior commands, the location operation continues rather than aborting. This is a sort of back-up operation. For example, suppose the location Cond Cond specification is (COND 2 3), and the first clause of the first Cond has only 2 forms. The location operation proceeds by searching for the next Cond Cond Cond and trying again. If a point were reached in which there were no more Cond Cond Conds, the location operation would then fail. LP LP ____ ____ (LP COMS) edit ____ This command, useful in macros, repeatedly executes COMS (a sequence of edit commands) until an editor error occurs; i.e. LP _ _ LP Loop. As LP exits, it prints the number of OCCURRENCES; that is, ____ the number of times COMS was successfully executed. After execution of the command, the current expression is left at what ____ it was after the last complete successful execution of COMS. The command terminates if the number of iterations exceeds the value of the variable MAXLOOP (initially 30). LPQ LPQ ____ ____ (LPQ COMS) edit ____ This command, useful in macros, repeatedly executes COMS (a sequence of edit commands) until an editor error occurs; i.e. _ _ _ Loop Quietly. After execution of the command, the current expression is left at what it was after the last complete ____ successful execution of COMS. The command terminates if the number of iterations exceeds the value of the variable MAXLOOP (initially 30). LP LP This command is equivalent to LP, except that OCCURRENCES is not printed. M M ___ ___ ____ (M (NAM) ([EXP) COMS)]) edit This can also be used as: (M NAM COMS) or as: (M (NAM) ARG COMS) EDITOR 7 February 1983 PSL Manual page 16.16 section 16.3 _ The editor provides the user with a macro facility; i.e. M. The user may define frequently used command sequences to be edit macros, which may then be invoked simply by giving the macro name M M as an edit command. The M command provides the user with a method of defining edit macros. The first alternate form of the command defines an atomic command ___ which takes no arguments. The argument NAM is the atomic name of ___ the macro. This defines NAM to be an edit macro equivalent to ____ ___ the sequence of edit commands COMS. If NAM previously had a definition as an edit macro, the new definition replaces the old. NOTE: Edit command names take precedence over macros. It is not possible to redefine edit command names. The main form of the M command as given above defines a list command, which takes a fixed number of arguments. In this case, ___ NAM is defined to be an edit macro equivalent to the sequence of ____ edit commands COMS. However, as (nam exp1 exp2 ... expn) is executed, the expi are substituted for the corresponding argi in ____ ____ COMS before COMS are executed. The second alternate form of the M command defines a list command which may take an arbitrary number of arguments. Execution of ___ the macro NAM is accomplished by substituting (exp1 exp2 ... Cdr Cdr expn) (that is, the Cdr of the macro call (nam exp1 exp2 ... ___ ____ expn)) for all occurrences of the atom ARG in COMS, and then ____ executing COMS. MAKEFN MAKEFN ___ ____ ____ __ __ ____ (MAKEFN (NAM VARS) ARGS N1 <N2>) edit This command defines a portion of the current expression as a function and replaces that portion of the expression by a call to ____ _ _ ___ ____ the function; i.e. Make Function. The form (NAM VARS) is the __ __ call which replaces the N1st through N2nd elements of the current ___ expression. Thus, NAM is the name of the function to be defined. ____ VARS is a sequence of local variables (in the current ____ expression), and ARGS is a list of dummy variables. The function definition is formed by replacing each occurrence of an element Cdr Cdr ___ ____ in vars (the Cdr of (NAM VARS)) by the corresponding element of ____ ____ ARGS. Thus, ARGS are the names of the formal parameters in the newly defined function. __ __ If N2 is omitted, it is assumed to be equal to N1. MARK MARK ____ MARK edit This command saves the current position within the form in such a way that it can later be returned to. The return is accomplished via _ or __. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.17 MBD MBD ___ ____ MBD (ARG) edit This command replaces the current expression by some form which ___ has the current expression as a sub-expression. If ARG is a MBD ____ MBD list, MBD substitutes a fresh copy of the current expression for ___ ___ each occurrence of the atom '*' in ARG. If ARG is a sequence of expressions, as: (MBD exp1 exp2 ... expn) then the call is equivalent to one of the form: (MBD (exp1 exp2 ... expn *)) The same is true if arg is atomic: (MBD atom) = (MBD (atom *)) MOVE MOVE ____ __ ___ ____ ____ (MOVE <LOC1> To COM <LOC2>) edit MOVE MOVE ____ The MOVE command allows the user to Move a structure from one point to another. The user may specify the form to be moved (via ____ LOC1, the first location specification), the position to which it ____ is to be moved (via LOC2, the second location specification) and ___ ___ the action to be performed there (via COM). The argument COM may be BEFORE, AFTER or the name of a list command (e.g. :, N, etc.). This command performs in the following manner. Take the current ____ expression after executing LOC1 (or its first element, if it is a ____ tail); call it expr. Execute LOC2 (beginning at the current expression AS OF ENTRY TO MOVE -- NOT the expression which would ____ ___ be current after execution of LOC1), and then execute (COM expr). Now go back and delete expr from its original position. The current expression is not changed by this command. ____ If LOC1 is NIL (that is, missing), the current expression is moved. In this case, the current expression becomes the result ___ of the execution of (COM expr). ____ If LOC2 is NIL (that is missing) or HERE, then the current ____ expression specifies the point to which the form given by LOC2 is to be moved. EDITOR 7 February 1983 PSL Manual page 16.18 section 16.3 N N ___ ____ (N [EXP]) edit ___ This command adds the EXPs to the end of the current expression; _ i.e. Add at End. This compensates for the fact that the negative integer command does not allow insertion after the last element. ____ _______ ____ _______ ____ _______ -N:integer edit-command -N:integer ___ edit-command (-N:integer [EXP]) edit-command Also can be used as: -N This is really two separate commands. The atomic form is an attention changing command. The current expression becomes the nth form from the end of the old current expression; i.e. Add _ Before End. That is, -1 specifies the last element, -2 the second from last, etc. The list form of the command is a structure modification command. This command inserts exp1 through expn (at least one expi must be present) before the nth element (counting from the BEGINNING) of the current expression. That is, -1 inserts before the first element, -2 before the second, etc. NEX NEX ___ ____ (NEX COM) edit Also can be used as: NEX BELOW NX BELOW ___ NX This command is equivalent to (BELOW COM) followed by NX. That is, it does repeated 0s until a current expression matching com NX NX is found. It then backs off by one 0 and does a NX. The atomic form of the command is equivalent to (NEX _). This is MARK MARK useful if the user is doing repeated (NEX x)s. He can MARK at x and then use the atomic form. NTH NTH ___ ____ (NTH LOC) edit LCL BELOW UP LCL ___ BELOW UP This command effectively performs (LCL LOC), (BELOW <), UP. The net effect is to search the current expression only for the form ___ specified by the location specification LOC. From there, return to the initial level and set the current expression to be the PSL Manual 7 February 1983 EDITOR section 16.3 page 16.19 ___ tail whose first element contains the form specified by LOC at any level. NX NX _ ____ (NX N) edit Also can be used as: NX The atomic form of this command makes the current expression the expression following the present current expression (at the same _ _ level); i.e. Next. The list form of the command is equivalent to n (an integer NX NX number) repetitions of NX. If an error occurs (e.g. if there are _ not N expressions following the current expression), the current expression is unchanged. OK OK ____ OK edit This command causes normal exit from the editor. The state of the edit is saved on property LASTVALUE of the atom EDIT. If the next form edited is the same, the edit is restored. That is, it is (with the exception of a BLOCK on the undo-list) as though the editor had never been exited. It is possible to save edit states for more than one form by SAVE SAVE exiting from the editor via the SAVE command. ORF ORF ___ ____ (ORF [PAT]) edit This command searches the current expression, in print order, for ___ the first occurrence of any form which matches one of the PATs; UP __ _ UP i.e. Print Order Final. If found, an UP is executed, and the current expression becomes the expression so specified. This command is equivalent to (F (*ANY* pat1 pat2 ... patn) N). Note that the top level check is not performed. ORR ORR ____ ____ (ORR [COMS]) edit ____ This command operates in the following manner. Each COMS is a ORR ORR ____ list of edit commands. ORR first executes the first COMS. If no ORR ORR error occurs, ORR terminates, leaving the current expression as ____ it was at the end of executing COMS. Otherwise, it restores the current expression to what it was on entry and repeats this EDITOR 7 February 1983 PSL Manual page 16.20 section 16.3 ____ ____ operation on the second COMS, etc. If no COMS is successfully ORR ORR executed without error, ORR generates an error and the current expression is unchanged. P P __ __ ____ (P N1 <N2>) edit Also can be used as: P _ This command prints the current expression; i.e. Print. The atomic form of the command prints the current expression to a depth of 2. More deeply nested forms are printed as &. __ The form (P N1) prints the N1st element of the current expression __ to a depth of 2. The argument N1 need not be an integer. It may NTH NTH be a general location specification. The NTH command is used in the search, so that the expression printed is the first element of the current expression which contains the desired form at any level. __ The third form of the command prints the N1st element of the __ __ current expression to a depth of N2. Again, N1 may be a general location specification. __ If N1 is 0, the current expression is printed. Many of the editor commands, particularly those which search, ___ take as an argument a pattern (abbreviated PAT). A pattern may be any combination of literal list structure and special pattern elements. The special elements are as follows. & this matches any single element. *ANY* if (CAR pat) is the atom *ANY*, then (CDR pat) must be ___ a list of patterns. PAT matches any form which matches Cdr Cdr ___ any of the patterns in (Cdr PAT). @ if an element of pat is a literal atom whose last character is @, then that element matches any literal atom whose initial characters match the initial characters of the element. That is, VER matches VERYLONGATOM. -- this matches any tail of a list or any interior segment of a list. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.21 Car Cdr Car ___ ___ Cdr ___ == if (Car PAT) is ==, then PAT matches X iff (Cdr PAT) is Eq Eq Eq to X. Cdr ___ Cdr ___ ::: if PAT begins with :::, the Cdr of PAT is matched against tails of the expression. ____ _______ ____ _______ ____ _______ N:integer edit-command N:integer ___ edit-command (N:integer [EXP]) edit-command Also can be used as: N:integer This command, a strictly positive integer N, is really two commands. The atomic form of the command is an attention-changing command. The current expression becomes the nth element of the current expression. The list form of the command is a structure modification command. It replaces the Nth element of the current expression by the ___ forms EXP. If no forms are given, then the Nth element of the current expression is deleted. PP PP ____ PP edit _ _ This command Pretty-Prints the current expression. R R ____ ____ ____ (R EXP1 EXP2) edit _ ____ ____ This command Replaces all occurrences of EXP1 by EXP2 in the current expression. ____ Note that EXP1 may be either the literal s-expression to be replaced, or it may be an edit pattern. If a pattern is given, the form which first matches that pattern is replaced throughout. All forms which match the pattern are NOT replaced. REPACK REPACK ___ ____ (REPACK LOC) edit Also can be used as: REPACK This command allows the editing of long strings (or atom names) EDITOR 7 February 1983 PSL Manual page 16.22 section 16.3 REPACK REPACK one character at a time. REPACK calls the editor recursively on UNPACK UNPACK UNPACK of the specified atom. (In the atomic form of the command, the current expression is used unless it is a list; then, the first element is used. In the list form of the command, the form specified by the location specification is OK OK treated in the same way.) If the lower editor is exited via OK, STOP STOP the result is repacked and replaces the original atom. If STOP is used, no replacement is done. The new atom is always printed. RI RI __ __ ____ (RI N1 N2) edit This command moves a right parenthesis. The parenthesis is moved __ from the end of the the N1st element of the current expression to __ __ _ after the N2nd element of the N1st element; i.e. Right _ __ Parenthesis Insert. Remaining elements of the N1st element are raised to the top level of the current expression. __ __ The arguments, N1 and N2, are normally integers. However, NTH NTH because the NTH command is used in the search, they may be any location specifications. The expressions referred to are the first element of the current expression in which the specified form is found at any level, and the first element of that __ expression in which the form specified by N2 is found at any level. RO RO _ ____ (RO N) edit This command moves the right parenthesis from the end of the nth element of the current expression to the end of the current _ _ expression; i.e. Right Parenthesis Remove. All elements following the Nth are moved inside the nth element. NTH NTH _ Because the NTH command is used for the search, the argument N, which is normally an integer, may be any location specification. The expression referred to is the first element of the current expression in which the specified form is found at any depth. S S ___ ___ ____ (S VAR LOC) edit SetQ _ SetQ ___ This command Sets (via SetQ) the variable whose name is VAR to the current expression after executing the location specification ___ LOC. The current expression is not changed. SAVE SAVE ____ SAVE edit This command exits normally from the editor. The state of the edit is saved on the property EDIT-SAVE of the atom being edited. When the same atom is next edited, the state of the edit is PSL Manual 7 February 1983 EDITOR section 16.3 page 16.23 restored and (with the exception of a BLOCK on the undo-list) it is as if the editor had never been exited. It is not necessary SAVE SAVE to use the SAVE command if only a single atom is being edited. OK OK See the OK command. SECOND SECOND ___ ____ (SECOND LOC) edit This command changes the current expression to what it would be ___ after the location specification LOC is executed twice. The ___ current expression is unchanged if either execution of LOC fails. STOP STOP ____ STOP edit ____ This command exits abnormally from the editor; i.e. Stop Editing. TTY: TTY: This command is useful mainly in conjunction with TTY: commands which the user wishes to abort. For example, if the user is executing (MOVE 3 TO AFTER COND TTY:) OK MOVE OK MOVE and he exits from the lower editor via OK, the MOVE command completes its operation. If, on the other hand, the user exits STOP TTY: MOVE STOP TTY: MOVE via STOP, TTY: produces an error and MOVE aborts. SW SW __ __ ____ (SW N1 N2) edit __ __ __ This command Swaps the N1st and N2nd elements of the current expression. The arguments are normally but not necessarily SW NTH SW NTH integers. SW uses NTH to perform the search, so that any location specifications may be used. In each case, the first element of the current expression which contains the specified form at any depth is used. TEST TEST ____ TEST edit This command adds an undo-block to the undo-list. This block UNDO !UNDO UNDO !UNDO limits the scope of UNDO and !UNDO commands to changes made after UNBLOCK UNBLOCK the block was inserted. The block may be removed via UNBLOCK. THIRD THIRD ___ ____ (THIRD LOC) edit This command executes the location specification loc three times. LC LC ___ It is equivalent to three repetitions of (LC LOC). Note, however, that if any of the executions causes an editor error, the current expression remains unchanged. EDITOR 7 February 1983 PSL Manual page 16.24 section 16.3 THROUGH ____ THROUGH ____ ____ (LOC1 THROUGH LOC2) edit This command makes the current expression the segment from the ____ form specified by LOC1 through (including) the form specified by LC UP BI ____ LC ____ UP BI ____ LOC2. It is equivalent to (LC LOC1), UP, (BI 1 LOC2), 1. Thus, it makes a single element of the specified elements and makes that the current expression. This command is meant for use in the location specifications DELETE, EMBED, EXTRACT REPLACE DELETE, EMBED, EXTRACT REPLACE given to the DELETE, EMBED, EXTRACT and REPLACE commands, and is THROUGH THROUGH not particularly useful by itself. Use of THROUGH with these commands sets a special flag so that the editor removes the extra THROUGH THROUGH set of parens added by THROUGH. TO ____ TO ____ ____ (LOC1 TO LOC2) edit This command makes the current expression the segment from the ____ form specified by LOC1 up to (but not including) the form LC UP BI ____ LC ____ UP BI specified by LOC2. It is equivalent to (LC LOC1), UP, (BI 1 RI RI loc), (RI 1 -2), 1. Thus, it makes a single element of the specified elements and makes that the current expression. This command is meant for use in the location specifications DELETE, EMBED, EXTRACT REPLACE DELETE, EMBED, EXTRACT REPLACE given to the DELETE, EMBED, EXTRACT and REPLACE commands, and is TO TO not particularly useful by itself. Use of TO with these commands sets a special flag so that the editor removes the extra set of TO TO parens added by TO. TTY: TTY: ____ TTY: edit This command calls the editor recursively, invoking a 'lower editor.' The user may execute any and all edit commands in this TTY: TTY: lower editor. The TTY: command terminates when the lower editor OK STOP OK STOP is exited via OK or STOP. The form being edited in the lower editor is the same as that being edited in the upper editor. Upon entry, the current expression in the lower is the same as that in the upper editor. UNBLOCK UNBLOCK ____ UNBLOCK edit This command removes an undo-block from the undo-list, allowing UNDO !UNDO UNDO !UNDO UNDO and !UNDO to operate on changes which were made before the block was inserted. TEST TEST Blocks may be inserted by exiting from the editor and by the TEST command. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.25 UNDO UNDO ___ ____ UNDO (COM) edit Also can use as: UNDO This command undoes editing changes. All editing changes are undoable, provided that the information is available to the editor. (The necessary information is always available unless SAVE SAVE several forms are being edited and the SAVE command is not used.) Changes made in the current editing session are ALWAYS undoable. The short form of the command undoes the most recent change. UNDO !UNDO UNDO !UNDO Note, however, that UNDO and !UNDO changes are skipped, even though they are themselves undoable. The long form of the command allows the user to undo an arbitrary UNDO !UNDO UNDO !UNDO command, not necessarily the most recent. UNDO and !UNDO may also be undone in this manner. UP UP ____ UP edit If the current expression is a tail of the next higher UP UP expression, UP has no effect. Otherwise the current expression becomes the form whose first element is the old current expression. XTR XTR ___ ____ (XTR LOC) edit This command replaces the current expression by one of its ___ subexpressions. The location specification, LOC, gives the form to be used. Note that only the current expression is searched. If the current expression is a tail, the command operates on the first element of the tail. ____ _______ ____ _______ ____ _______ edit-command edit-command 0 edit-command This command makes the current expression the next higher expression. This usually, but not always, corresponds to returning to the next higher left parenthesis. This command is, in some sense, the inverse of the POS-INTEGER and NEG- INTEGER atomic commands. _____ ____ _______ _____ ____ _______ _____ ____ _______ ## fexpr, edit-command ## ___ ____ ___ fexpr, edit-command ## ([COM:form]): any fexpr, edit-command EDITOR 7 February 1983 PSL Manual page 16.26 section 16.3 The value of this fexpr, useful mainly in macros, is the ___ expression which would be current after executing all of the COMs in sequence. The current expression is not changed. CHANGE INSERT CHANGE INSERT Commands in which this fexpr might be used (e.g. CHANGE, INSERT, and REPLACE REPLACE REPLACE) make special checks and use a copy of the expression returned. ____ _______ ____ _______ ____ _______ ^ edit-command ^ edit-command ^ edit-command This command makes the top level expression the current expression. ____ _______ ____ _______ ____ _______ ? edit-command ? edit-command ? edit-command This command prints the current expression to a level of 100. It is equivalent to (P 0 100). ____ _______ ____ _______ ____ _______ ?? edit-command ?? edit-command ?? edit-command This command displays the entries on the undo-list. ____ _______ ____ _______ ____ _______ _ edit-command _ edit-command _ edit-command This command returns to the position indicated by the most recent MARK MARK MARK MARK MARK command. The MARK is not removed. ____ _______ ____ _______ ____ _______ _ edit-command _ ___ edit-command (_ PAT) edit-command This command ascends (does repeated 0s), testing the current ___ expression at each ascent for a match with PAT. The current expression becomes the first form to match. If pattern is atomic, it is matched with the first element of each expression; otherwise, it is matched against the entire form. ____ _______ ____ _______ ____ _______ __ edit-command __ edit-command __ edit-command This command returns to the position indicated by the most recent MARK MARK MARK MARK MARK command and removes the MARK. PSL Manual 7 February 1983 EDITOR section 16.3 page 16.27 ____ _______ ____ _______ ____ _______ : edit-command : ___ edit-command (: [EXP]) edit-command Also can be used as: (:) ___ This command replaces the current expression by the forms EXP. If no forms are given (as in the second form of the command), the current expression is deleted. ____ _______ ____ _______ ____ _______ :: edit-command ___ :: ___ edit-command (PAT :: LOC) edit-command This command sets the current expression to the first form (in ___ print order) which matches PAT and contains the form specified by ___ the location specification LOC at any level. The command is F LCL F ___ LCL ___ ___ equivalent to (F PAT N), (LCL LOC), (_ PAT). ____ _______ ____ _______ ____ _______ \ edit-command \ edit-command \ edit-command This command returns to the expression which was current before the last 'big jump.' Big jumps are caused by these commands: ^, _, __, !NX, all commands which perform a search or use a location specification, \ itself, and \P. NOTE: \ is shift-L on a teletype. ____ _______ ____ _______ ____ _______ \P edit-command \P edit-command \P edit-command This command returns to the expression which was current before the last print operation (P, PP or ?). Only the two most recent locations are saved. NOTE: \ is shift-L on a teletype. ____ _______ ____ _______ ____ _______ !NX edit-command !NX edit-command !NX edit-command This command makes the next expression at a higher level the current expression. That is, it goes through any number of right parentheses to get to the next expression. ____ _______ ____ _______ ____ _______ !UNDO edit-command !UNDO edit-command !UNDO edit-command EDITOR 7 February 1983 PSL Manual page 16.28 section 16.3 This command undoes all changes made in the current editing session (back to the most recent block). All changes are undoable. TEST TEST Blocks may be inserted by exiting the editor or by the TEST UNBLOCK UNBLOCK command. They may be removed with the UNBLOCK command. ____ _______ ____ _______ ____ _______ !0 edit-command !0 edit-command !0 edit-command This command does repeated 0s until it reaches an expression which is not a tail of the next higher expression. That expression becomes the new current expression. That is, this command returns to the next higher left parenthesis, regardless of intervening tails. |
Added psl-1983/lpt/17-utilities.lpt version [475c5d270b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Utilities section 17.0 page 17.1 CHAPTER 17 CHAPTER 17 CHAPTER 17 MISCELLANEOUS UTILITIES MISCELLANEOUS UTILITIES MISCELLANEOUS UTILITIES 17.1. Introduction . . . . . . . . . . . . . . . 17.1 17.2. RCREF - Cross Reference Generator for PSL Files . . . 17.1 17.2.1. Restrictions. . . . . . . . . . . . . 17.2 17.2.2. Usage . . . . . . . . . . . . . . . 17.3 17.2.3. Options . . . . . . . . . . . . . . 17.3 17.3. Picture RLISP. . . . . . . . . . . . . . . 17.4 17.3.1. Running PictureRLISP on HP2648A and on TEKTRONIX 17.10 4006-1 Terminals . . . . . . . . . . . 17.4. Tools for Defining Macros. . . . . . . . . . . 17.11 17.4.1. DefMacro . . . . . . . . . . . . . . 17.11 17.4.2. BackQuote. . . . . . . . . . . . . . 17.12 17.4.3. Sharp-Sign Macros . . . . . . . . . . . 17.12 17.4.4. MacroExpand . . . . . . . . . . . . . 17.13 17.4.5. DefLambda. . . . . . . . . . . . . . 17.13 17.5. Simulating a Stack . . . . . . . . . . . . . 17.14 17.6. DefStruct . . . . . . . . . . . . . . . . 17.14 17.6.1. Options . . . . . . . . . . . . . . 17.17 17.6.2. Slot Options. . . . . . . . . . . . . 17.18 17.6.3. A Simple Example . . . . . . . . . . . 17.18 17.7. DefConst . . . . . . . . . . . . . . . . 17.21 17.8. Functions for Sorting . . . . . . . . . . . . 17.22 17.9. Hashing Cons . . . . . . . . . . . . . . . 17.23 17.10. Graph-to-Tree . . . . . . . . . . . . . . 17.25 17.11. Inspect Utility. . . . . . . . . . . . . . 17.25 17.1. Introduction 17.1. Introduction 17.1. Introduction This chapter describes an assortment of utility packages. Its purpose is to record the existence and capabilities of a number of tools. More information on existing packages can be found by looking at the current set of HELP files (DIR PH:*.* on the DEC-20). 17.2. RCREF - Cross Reference Generator for PSL Files 17.2. RCREF - Cross Reference Generator for PSL Files 17.2. RCREF - Cross Reference Generator for PSL Files RCREF is a Standard LISP program for processing a set of Standard LISP function definitions to produce: a. A "Summary" showing: Utilities 7 February 1983 PSL Manual page 17.2 section 17.2 i. A list of files processed. ii. A list of "entry points" (functions which are not called or are called only by themselves). iii. A list of undefined functions (functions called but not defined in this set of functions). iv. A list of variables that were used non-locally but not declared GLOBAL or FLUID before their use. v. A list of variables that were declared GLOBAL but used as FLUIDs (i.e. bound in a function). vi. A list of FLUID variables that were not bound in a function so that one might consider declaring them GLOBALs. vii. A list of all GLOBAL variables present. viii. A list of all FLUID variables present. ix. A list of all functions present. b. A "global variable usage" table, showing for each non-local variable: i. Functions in which it is used as a declared FLUID or GLOBAL. ii. Functions in which it is used but not declared before. iii. Functions in which it is bound. SetQ SetQ iv. Functions in which it is changed by SetQ. c. A "function usage" table showing for each function: i. Where it is defined. ii. Functions which call this function. iii. Functions called by it. iv. Non-local variables used. The output is alphabetized on the first seven characters of each function name. RCREF also checks that functions are called with the correct number of arguments. 17.2.1. Restrictions 17.2.1. Restrictions 17.2.1. Restrictions Algebraic procedures in REDUCE are treated as if they were symbolic, so that algebraic constructs actually appear as calls to symbolic functions, AEval AEval such as AEval. SYSLISP procedures are not correctly analyzed. PSL Manual 7 February 1983 Utilities section 17.2 page 17.3 17.2.2. Usage 17.2.2. Usage 17.2.2. Usage RCREF should be used in PSL:RLISP. To make a file FILE.CRF which is a cross reference listing for files FILE1.EX1 and FILE2.EX2 do the following in RLISP: @PSL:RLISP LOAD RCREF; % RCREF is now autoloading, so this may be omitted OUT "file.crf"; % later, CREFOUT ... ON CREF; IN "file1.ex1","file2.ex2"; OFF CREF; SHUT "file.crf"; % later CREFEND To process more files, more IN statements may be added, or the IN statement may be changed to include more files. 17.2.3. Options 17.2.3. Options 17.2.3. Options __________ ______ !*CREFSUMMARY [Initially: NIL] switch If the switch CREFSUMMARY is ON then only the summary (see 1 above) is produced. Functions with the flag NOLIST are not examined or output. Initially, all Standard LISP functions are so flagged. (In fact, they are kept on a list NOLIST!*, so if you wish to see references to ALL functions, then CREF should be first loaded with the command LOAD RCREF, and this variable then set to NIL). (RCREF is now autoloading.) __________ ______ NOLIST!* [Initially: the following list] global (AND COND LIST MAX MIN OR PLUS PROG PROG2 PROGN TIMES LAMB ADD1 APPEND APPLY ASSOC ATOM CAR CDR CAAR CADR CDAR CDDR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR CAAAAR CAAADR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDDAAR CDDADR CDDDAR CDDDDR CLOSE CODEP COMPRESS CONS CO DE DEFLIST DELETE DF DIFFERENCE DIGIT DIVIDE DM EJECT EQUAL ERROR ERRORSET EVAL EVLIS EXPAND EXPLODE EXPT FIX FI FLAGP FLOAT FLOATP FLUID FLUIDP FUNCTION GENSYM GET GET GLOBAL GLOBALP GO GREATERP IDP INTERN LENGTH LESSP LIN LITER LPOSN MAP MAPC MAPCAN MAPCAR MAPCON MAPLIST MAX2 MEMQ MINUS MINUSP MIN2 MKVECT NCONC NOT NULL NUMBERP ONE PAGELENGTH PAIR PAIRP PLUS2 POSN PRINC PRINT PRIN1 PRIN2 PUT PUTD PUTV QUOTE QUOTIENT RDS READ READCH REMAINDE REMFLAG REMOB REMPROP RETURN REVERSE RPLACA RPLACD SASS SETQ STRINGP SUBLIS SUBST SUB1 TERPRI TIMES2 UNFLUID UPBV WRS ZEROP) Utilities 7 February 1983 PSL Manual page 17.4 section 17.2 It should also be remembered that in RLISP any macros with the flag EXPAND or, if FORCE is on, without the flag NOEXPAND are expanded before the definition is seen by the cross-reference program, so this flag can also be used to select those macros you require expanded and those you do not. The use of ON FORCE; is highly recommended for CREF. 17.3. Picture RLISP 17.3. Picture RLISP 17.3. Picture RLISP [??? ReWrite ???] [??? ReWrite ???] [??? ReWrite ???] Picture RLISP is an ALGOL-like graphics language for Teleray, HP2648a and Tektronix, in which graphics Model primitives are combined into complete Models for display. PRLISP is a 3D version; PRLISP2D is a faster, smaller 2D version which also drives more terminals. Two demonstration files, PR-DEMO.RED and PR-DEMO.Sl, are available on PU. See the help files PH:PRLISP.HLP and PRLISP2D.HLP. Model primitives include: P:={x,y,z}; A point (y, and z may be omitted, default to 0). PS:=P1_ P2_ ... Pn; A Point Set is an ordered set of Points (Polygon). G := PS1 & PS2 & ... PSn; A Group of Polygons. Point Set Modifiers alter the interpretation of Point Sets within their scope. BEZIER() causes the point-set to be interpreted as the specification points for a BEZIER curve, open pointset. BSPLINE() does the same for a Bspline curve, closed pointset. TRANSFORMS: Mostly return a transformation matrix. Translation: Move the specified amount along the specified axis. XMOVE(deltaX); YMOVE(deltaY); ZMOVE(deltaZ); MOVE(deltaX, deltaY, deltaZ); Scale: Scale the Model SCALE (factor) XSCALE(factor); YSCALE(factor); ZSCALE(factor); SCALE1(x.scale.factor, y.scale.factor, z.scale.factor); SCALE<Scale factor>;. Scale along all axes. PSL Manual 7 February 1983 Utilities section 17.3 page 17.5 Rotation: ROT(degrees); ROT(degrees, point.specifying.axis); XROT(degrees); YROT(degrees); ZROT(degrees); Window (z.eye,z.screen): The WINDOW primitives assume that the viewer is located along the z axis looking in the positive z direction, and that the viewing window is to be centered on both the x and y axis. Vwport(leftclip,rightclip,topclip,bottomclip): The VWPORT, which specifies the region of the screen which is used for display. REPEATED (number.of.times, my.transform): The Section of the Model which is contained within the scope of the Repeat Specification is replicated. Note that REPEATED is intended to duplicate a sub-image in several different places on the screen; it was not designed for animation. Identifiers of other Models the Model referred to is displayed as if it were part of the current Model for dynamic display. Calls to PictureRLISP Procedures This Model primitive allows procedure calls to be imbedded within Models. When the Model interpreter reaches the procedure identifier it calls it, passing it the portion of the Model below the procedure as an argument. The current transformation matrix and the current pen position are available to such procedures as the values of the global identifiers GLOBAL!.TRANSFORM and HEREPOINT. If normal procedure call syntax, i.e. proc.name (parameters), is used then the procedure is called at Model-building time, but if only the procedure's identifier is used then the procedure is imbedded in the Model. ERASE() Clears the screen and leaves the cursor at the origin. SHOW(pict) Takes a picture and displays it on the screen. ESHOW (pict) Erases the whole screen and display "pict". HP!.INIT(), TEK!.INIT(), TEL!.INIT() Initializes the operating system's view of the characteristics of HP2648A terminal, TEKTRONIX 4006-1 (also ADM-3A with Retrographics board, and Teleray-1061). For example, the Model Utilities 7 February 1983 PSL Manual page 17.6 section 17.3 (A _ B _ C & {1,2} _ B) | XROT (30) | 'TRAN ; % % PictureRLISP Commands to SHOW lots of Cubes % % Outline is a Point Set defining the 20 by 20 % square which is part of the Cubeface % Outline := { 10, 10} _ {-10, 10} _ {-10,-10} _ { 10,-10} _ {10, 10}; % Cubeface also has an Arrow on it % Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}; % We are ready for the Cubeface Cubeface := (Outline & Arrow) | 'Tranz; % Note the use of static clustering to keep objects % meaningful as well as the quoted Cluster % to the as yet undefined transformation Tranz, % which results in its evaluation being % deferred until SHOW time % and now define the Cube Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90); % In order to have a more pleasant look at % the picture shown on the screen we magnify % cube by 5 times. BigCube := Cube | SCALE 5; % Set up initial Z Transform for each cube face % Tranz := ZMOVE (10); % 10 units out % % GLOBAL!.TRANSFORM has been treated as a global variable. % GLOBAL!.TRANSFORM should be initialized as a perspective % transformation matrix so that a viewer can have a correct % look at the picture as the viewing location changed. % For instance, it may be set as the desired perspective % with a perspective window centered at the origin and % of screen size 60, and the observer at -300 on the z axis. % Currently this has been set as default perspective transformation. PSL Manual 7 February 1983 Utilities section 17.3 page 17.7 % Now draw cube % SHOW BigCube; % Utilities 7 February 1983 PSL Manual page 17.8 section 17.3 % Draw it again rotated and moved left % SHOW (BigCube | XROT 20 | YROT 30 | ZROT 10); % Dynamically expand the faces out % Tranz := ZMOVE 12; % SHOW (BigCube | YROT 30 | ZROT 10); % Now show 5 cubes, each moved further right by 80 % Tranz := ZMOVE 10; % SHOW (Cube | SCALE 2.5 | XMOVE (-240) | REPEATED(5, XMOVE 80)); % % Now try pointset modifier. % Given a pointset (polygon) as control points either a BEZIER or a % BSPLINE curve can be drawn. % Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,13 _ {0,84} $ % % Now draw Bezier curve % Show the polygon and the Bezier curve % SHOW (Cpts & Cpts | BEZIER()); % Now draw Bspline curve % Show the polygon and the Bspline curve % SHOW (Cpts & Cpts | BSPLINE()); % Now work on the Circle % Given a center position and a radius a circle is drawn % SHOW ( {10,10} | CIRCLE(50)); % % Define a procedure which returns a model of % a Cube when passed the face to be used % Symbolic Procedure Buildcube; List 'Buildcube; % put the name onto the property list Put('buildcube, 'pbintrp, 'Dobuildcube); Symbolic Procedure Dobuildcube Face$ Face & Face | XROT(180) & Face | YROT(90) & Face | YROT(-90) PSL Manual 7 February 1983 Utilities section 17.3 page 17.9 & Face | XROT(90) & Face | XROT(-90) ; % just return the value of the one statement % Use this procedure to display 2 cubes, with and % without the Arrow - first do it by calling % Buildcube at time the Model is built % P := Cubeface | Buildcube() | XMOVE(-15) & (Outline | 'Tranz) | Buildcube() | XMOVE 15; % SHOW (P | SCALE 5); % Now define a procedure which returns a Model of % a cube when passed the half size parameter Symbolic Procedure Cubemodel; List 'Cubemodel; %put the name onto the property list Put('Cubemodel,'Pbintrp, 'Docubemodel); Symbolic Procedure Docubemodel HSize; << if idp HSize then HSize := eval HSize$ { HSize, HSize, HSize} _ {-HSize, HSize, HSize} _ {-HSize, -HSize, HSize} _ { HSize, -HSize, HSize} _ { HSize, HSize, HSize} _ { HSize, HSize, -HSize} _ {-HSize, HSize, -HSize} _ {-HSize, -HSize, -HSize} _ { HSize, -HSize, -HSize} _ { HSize, HSize, -HSize} & {-HSize, HSize, -HSize} _ {-HSize, HSize, HSize} & {-HSize, -HSize, -HSize} _ {-HSize, -HSize, HSize} & { HSize, -HSize, -HSize} _ { HSize, -HSize, HSize} >>; % Imbed the parameterized cube in some Models % His!.cube := 'His!.size | Cubemodel(); Her!.cube := 'Her!.size | Cubemodel(); R := His!.cube | XMOVE (60) & Her!.cube | XMOVE (-60) ; % Set up some sizes and SHOW them His!.size := 50; Her!.size := 30; % SHOW R ; Utilities 7 February 1983 PSL Manual page 17.10 section 17.3 % % Set up some different sizes and SHOW them again % His!.size := 35; Her!.size := 60; % SHOW R; % % Now show a triangle rotated 45 degree about the z axis. Rotatedtriangle := {0,0} _ {50,50} _ {100,0} _ {0,0} | Zrot (45); % SHOW Rotatedtriangle; % % Define a procedure which returns a model of a Pyramid % when passed 4 vertices of a pyramid. % Procedure Second,Third, Fourth and Fifth are primitive procedures % written in the source program which return the second, the third, % the fourth and the fifth element of a list respectively. % This procedure simply takes 4 points and connects the vertices to % show a pyramid. Symbolic Procedure Pyramid (Point4); %.point4 is a pointset Point4 & Third Point4 _ Fifth Point4 _ Second Point4 _ Fourth Point4 ; % Now give a pointset indicating 4 vertices build a pyramid % and show it % My!.vertices := {-40,0} _ {20,-40} _ {90,20} _ {70,100}; My!.pyramid := Pyramid Vertices; % SHOW ( My!.pyramid | XROT 30); % % A procedure that makes a wheel with "count" % spokes rotated around the z axis. % in which "count" is the number specified. Symbolic Procedure Dowheel(spoke,count)$ begin scalar rotatedangle$ count := first count$ rotatedangle := 360.0 / count$ return (spoke | REPEATED(count, ZROT rotatedangle)) end$ % % Now draw a wheel consisting of 8 cubes % PSL Manual 7 February 1983 Utilities section 17.3 page 17.11 Cubeonspoke := (Outline | ZMOVE 10 | SCALE 2) | buildcube(); Eight!.cubes := Cubeonspoke | XMOVE 50 | WHEEL(8); % SHOW Eight!.cubes; % %Draw a cube in which each face consists of just % a wheel of 8 Outlines % Flat!.Spoke := outline | XMOVE 25$ A!.Fancy!.Cube := Flat!.Spoke | WHEEL(8) | ZMOVE 50 | Buildcube()$ % SHOW A!.Fancy!.Cube; % % Redraw the fancy cube, after changing perspective by % moving the observer farther out along Z axis % GLOBAL!.TRANSFORM := WINDOW(-500,60); % SHOW A!.Fancy!.Cube; % % Note the flexibility resulting from the fact that % both Buildcube and Wheel simply take or return any % Model as their argument or value The current version of PictureRLISP runs on HP2648A graphics terminal and TEKTRONIX 4006-1 computer display terminal. The screen of the HP terminal is 720 units long in the X direction, and 360 units high in the Y direction. The coordinate system used in HP terminal places the origin in approximately the center of the screen, and uses a domain of -360 to 360 and a range of -180 to 180. Similarly, the screen of the TEKTRONIX terminal is 1024 units long in the X direction, and 780 units high in the Y direction. The same origin is used but the domain is -512 to 512 in the X direction and the range is -390 to 390 in the Y direction. Procedures HP!.INIT and TEK!.INIT are used to set the terminals to graphics mode and initiate the lower level procedures on HP and TEKTRONIX terminals respectively. Basically, INIT procedures are written for different terminals depending on their specific characteristics. Using INIT procedures keeps terminal device dependence at the user's level to a minimum. 17.4. Tools for Defining Macros 17.4. Tools for Defining Macros 17.4. Tools for Defining Macros The following (and other) macro utilities are in the file PU:USEFUL.SL; Utilities 7 February 1983 PSL Manual page 17.12 section 17.4 1 use (LOAD USEFUL) to access. See PH:USEFUL.HLP for more information. 17.4.1. DefMacro 17.4.1. DefMacro 17.4.1. DefMacro DefMacro DefMacro _ __ _ ____ _ ____ __ _____ (DefMacro A:id B:form [C:form]): id macro _____ _____ _____ DefMacro macro DefMacro DefMacro macro DefMacro DefMacro is a useful tool for defining macros. A DefMacro form looks like (DEFMACRO <NAME> <PATTERN> <S1> <S2> ... <Sn>) ____ __ The <PATTERN> is an S-expression made of pairs and ids. It is _____ _____ _____ macro macro matched against the arguments of the macro much like the first DeSetQ DeSetQ __ argument to DeSetQ. All of the non-NIL ids in <pattern> are local variables which may be used freely in the body (the <Si>). _____ _____ _____ macro ProgN macro ProgN If the macro is called the <Si> are evaluated as in a ProgN with the local variables in <pattern> appropriately bound, and the DefMacro DefMacro value of <Sn> is returned. DefMacro is often used with BackQuote. 17.4.2. BackQuote 17.4.2. BackQuote 17.4.2. BackQuote Note that the special symbols described below only work in LISP syntax, BackQuote UnQuote BackQuote UnQuote not RLISP. In RLISP you may simply use the functions BackQuote, UnQuote, UnQuoteL BackQuote UnQuoteL BackQuote and UnQuoteL. Load USEFUL to get the BackQuote function. _____ _____ _____ Read macro Read macro The backquote symbol "`" is a Read macro which introduces a quoted expression which may contain the unquote symbols comma "," and comma-atsign ",@". An appropriate form consisting of the unquoted expression calls to Cons Cons the function Cons and quoted expressions are produced so that the resulting expression looks like the quoted one except that the values of the unquoted expressions are substituted in the appropriate place. ",@" splices in the value of the subsequent expression (i.e. strips off the outer layer of parentheses). Thus `(a (b ,x) c d ,@x e f) is equivalent to (cons 'a (cons (list 'b x) (append '(c d) (append x '(e f))))) In particular, if x is bound to (1 2 3) this evaluates to _______________ 1 Useful was written by D. Morrison. PSL Manual 7 February 1983 Utilities section 17.4 page 17.13 (a (b (1 2 3)) c d 1 2 3 e f) BackQuote BackQuote _ ____ ____ _____ (BackQuote A:form): form macro Function name for back quote `. UnQuote UnQuote _ ___ _________ _____ (UnQuote A:any): Undefined fexpr Eval Eval Function name for comma ,. It is an error to Eval this function; BackQuote BackQuote it should occur only inside a BackQuote. UnQuoteL UnQuoteL _ ___ _________ _____ (UnQuoteL A:any): Undefined fexpr Eval Eval Function name for comma-atsign ,@. It is an error to Eval this BackQuote BackQuote function; it should only occur inside a BackQuote. 17.4.3. Sharp-Sign Macros 17.4.3. Sharp-Sign Macros 17.4.3. Sharp-Sign Macros USEFUL defines several MACLISP style sharp sign read macros. Note that these only work with the LISP reader, not RLISP. Those currently included are #' : this is like the quote mark ' but is for FUNCTION instead of QUOTE. #/ : this returns the numeric form of the following character read without raising it. For example #/a is 97 while #/A is 65. #\ : This is a read macro for the CHAR macro, described in the PSL manual. Not that the argument is raised, if *RAISE is non-nil. For Char Char example, #\a = #\A = 65, while #\!a = #\(lower a) = 97. Char has been redefined in USEFUL to be slightly more table driven -- users can now add new "prefixes" such as META or CONTROL: just hang the appropriate function (from integers to integers) off the char-prefix-function property of the "prefix". A LARGE number of additional alias for various characters have been added, including all the "standard" ASCII names like NAK and DC1. #. : this causes the following expression to be evaluated at read time. For example, `(1 2 #.(plus 1 2) 4) reads as (1 2 3 4) #+ : this reads two expressions, and passes them to the if_system macro. That is, the first should be a system name, and if that is the current system the second argument is returned by the reader. If not, the next expression is returned. #-: #- is similar, but causes the second arg to be returned only if it is NOT the current system. Utilities 7 February 1983 PSL Manual page 17.14 section 17.4 17.4.4. MacroExpand 17.4.4. MacroExpand 17.4.4. MacroExpand MacroExpand MacroExpand _ ____ _ __ ____ _____ (MacroExpand A:form [B:id]): form macro _____ _____ _____ MacroExpand macro MacroExpand macro MacroExpand is a useful tool for debugging macro definitions. If MacroExpand macro MacroExpand macro given one argument, MacroExpand expands all the macros in that form. Often one wishes for more control over this process. For _____ _____ _____ macro Let macro Let example, if a macro expands into a Let, we may not wish to see Let Let the Let itself expanded to a lambda expression. Therefore MacroExpand MacroExpand additional arguments may be given to MacroExpand. If these are _____ _____ _____ macro macro supplied, they should be macros, and only those specified are expanded. 17.4.5. DefLambda 17.4.5. DefLambda 17.4.5. DefLambda DefLambda DefLambda _____ (DefLambda ): macro Yet another little (two line) macro has been added to USEFUL: DefLambda DefLambda DefLambda. This defines a macro much like a substitution macro ______ ______ ______ smacro smacro (smacro) except that it is a lambda expression. Thus, modulo ____ ____ ____ expr expr redefinability, it has the same semantics as the equivalent expr. It is mostly intended as an easy way to open compile things. For example, we would not normally want to define a substitution macro for a constructor (NEW-FOO X) which maps into (CONS X X), in case X is expensive to compute or, far worse, has side effects. (DEFLAMBDA NEW-FOO (X) (CONS X X)) defines it as a macro which maps (NEW-FOO (SETQ BAR (BAZ))) to ((LAMBDA (X) (CONS X X)) (SETQ BAR (BAZ))). 17.5. Simulating a Stack 17.5. Simulating a Stack 17.5. Simulating a Stack The following macros are in the USEFUL package. They are convenient for ____ adding and deleting things from the head of a list. Push Push ___ ___ ___ ____ ___ _____ (Push ITM:any STK:list): any macro (PUSH ITEM STACK) is equivalent to (SETF STACK (CONS ITEM STACK)) PSL Manual 7 February 1983 Utilities section 17.5 page 17.15 Pop Pop ___ ____ ___ _____ (Pop STK:list): any macro (POP STACK) does (SETF STACK (CDR STACK)) _____ and returns the item popped off STACK. An additional argument Pop Pop may be supplied to Pop, in which case it is a variable which is SetQ SetQ SetQ'd to the popped value. 17.6. DefStruct 17.6. DefStruct 17.6. DefStruct (LOAD DEFSTRUCT) to use the functions described below, or FAST!-DEFSTRUCT to use those functions but with fast vector operations used. DefStruct is similar to the Spice (Common) LISP/LISP machine/MacLISP flavor of struct definitions, and is expected to be subsumed by the Mode package. It is 2 implemented in PSL as a function which builds access macros and fns for "typed" vectors, including constructor and alterant macros, a type predicate for the structure type, and individual selector/assignment fns for the elements. DefStruct understands a keyword-option oriented structure specification. DefStruct is now autoloading. First a few miscellaneous functions on types, before getting into the depths of defining DefStructs: DefstructP DefstructP ____ __ _____ _______ ____ (DefstructP NAME:id): extra-boolean expr This is a predicate that returns non-NIL (the Defstruct ____ definition) if NAME is a structured type which has been defined using Defstruct, or NIL if it is not. DefstructType DefstructType _ ______ __ ____ (DefstructType S:struct): id expr This returns the type name field of an instance of a structured _ type, or NIL if S cannot be a Defstruct type. _______________ 2 Defstruct was implemented by Russ Fish. Utilities 7 February 1983 PSL Manual page 17.16 section 17.6 SubTypeP SubTypeP _____ __ _____ __ _______ ____ (SubTypeP NAME1:id NAME2:id): boolean expr _____ This returns true if NAME1 is a structured type which has been _____ !:Included in the definition of structured type NAME2, possibly through intermediate structure definitions. (In other words, the _____ _____ selectors of NAME1 can be applied to NAME2.) Now the function which defines the beasties, in all its gory glory: Defstruct Defstruct ____ ___ _______ __ ____ ____ _____ __ ____ __ _____ (Defstruct NAME-AND-OPTIONS:{id,list} [SLOT-DESCS:{id,list}]): id fexpr Defines a record-structure data type. A general call to Defstruct Defstruct Defstruct looks like this: (in RLISP syntax) defstruct( struct-name( option-1, option-2, ... ), slot-description-1, slot-description-2, ... ); The name of the defined structure is returned. Slot-descriptions are: slot-name( default-init, slot-option-1, slot-option-2, ... ) __ Struct-name and slot-name are ids. If there are no options following a name in a spec, it can be a bare id with no option argument list. The default-init form is optional and may be omitted. The default-init form is evaluated EACH TIME a structure is to be constructed and the value is used as the initial value of the slot. Options are either a keyword id, or the keyword followed by its argument list. Options are described below. _____ _____ _____ macro macro A call to a constructor macro has the form: MakeThing( slot-name-1( value-expr-1 ), slot-name-2( value-expr-2 ), ... ); The slot-name:value lists override the default-init values which were part of the structure definition. Note that the slot-names look like unary functions of the value, so the parens can be left off. A call to MakeThing with no arguments of course takes all of the default values. The order of evaluation of the default-init forms and the list of assigned values is undefined, so code should not depend upon the ordering. ____________ ____ Implementors Note: Common/LispMachine Lisps define it this way, but Is this necessary? It wouldn't be too tough to make the order be the same as the struct defn, or the argument order in the constructor call. Maybe they PSL Manual 7 February 1983 Utilities section 17.6 page 17.17 think such things should not be advertised and thus constrained in the future. Or perhaps the theory is that constructs such as this can be compiled more efficiently if the ordering is flexible?? Also, should the overridden default-init forms be evaluated or not? I think not. _____ _____ _____ macro macro The alterant macro calls have a similar form: AlterThing( thing, slot-name-1 value-expr-1, slot-name-2 value-expr-2, ... ); The first argument evaluates to the struct to be altered. (The optional parens were left off here.) This is just a multiple-assignment form, which eventually goes through the slot depositors. Remember that the slot-names are used, not the depositor names. (See !:Prefix, below.) The altered structure instance is returned as the value of an Alterant macro. Implementators note: Common/LispMachine Lisp defines this such that all of the slots are altered in parallel AFTER the new value forms are evaluated, but still with the order of evaluation of the forms undefined. This seemed to lose more than it gained, but arguments for its worth will be entertained. 17.6.1. Options 17.6.1. Options 17.6.1. Options Structure options appear as an argument list to the struct-name. Many of the options themselves take argument lists, which are sometimes optional. Option ids all start with a colon (!:), on the theory that this distinguishes them from other things. By default, the names of the constructor, alterant and predicate macros are MakeName, AlterName and NameP. "Name" is the struct-name. The !:Constructor, !:Alterant, and !:Predicate options can be used to override the default names. Their argument is the name to use, and a name of NIL causes the respective macro not to be defined at all. The !:Creator option causes a different form of constructor to be defined, in addition to the regular "Make" constructor (which can be suppressed.) As in the !:Constructor option above, an argument supplies the name of the macro, but the default name in this case is CreateName. A call to a Creator macro has the form: CreateThing( slot-value-1, slot-value-2, ... ); ___ ____ __ _______ All of the slot-values of the structure must be present, in the order they appear in the structure definition. No checking is done, other than assuring that the number of values is the same as the number of slots. For ___ ___ ___________ obvious reasons, constructors of this form are not recommended for Utilities 7 February 1983 PSL Manual page 17.18 section 17.6 structures with many fields, or which may be expanded or modified. Slot selector macros may appear on either the left side or the right side of an assignment. They are by default named the same as the slot-names, but can be given a common prefix by the !:Prefix option. If !:Prefix does not have an argument, the structure name is the prefix. If there is an argument, it should be a string or an id whose print name is the prefix. The !:Include option allows building a new structure definition as an extension of an old one. The required argument is the name of a previously defined structure type. The access functions for the slots of the source type also works on instances of the new type. This can be used to build hierarchies of types. The source types contain generic information in common to the more specific subtypes which !:Include them. The !:IncludeInit option takes an argument list of "slot-name(default- init)" pairs, like slot-descriptors without slot-options, and files them away to modify the default-init values for fields inherited as part of the !:Included structure type. 17.6.2. Slot Options 17.6.2. Slot Options 17.6.2. Slot Options Slot-options include the !:Type option, which has an argument declaring the type of the slot as a type id or list of permissible type ids. This is not enforced now, but anticipates the Mode system structures. The !:UserGet and !:UserPut slot-options allow overriding the simple vector reference and assignment semantics of the generated selector macros with user-defined functions. The !:UserGet FNAME is a combination of the slot-name and a !:Prefix if applicable. The !:UserPut FNAME is the same, with "Put" prefixed. One application of this capability is building depositors which handle the incremental maintenance of parallel data structures as a side effect, such as automatically maintaining display file representations of objects which are resident in a remote display processor in parallel with modifications to the LISP structures which describe the objects. The Make and Create macros bypass the depositors, while Alter uses them. 17.6.3. A Simple Example 17.6.3. A Simple Example 17.6.3. A Simple Example (Input lines have a "> " prompt at the beginning.) PSL Manual 7 February 1983 Utilities section 17.6 page 17.19 > % (Do definitions twice to see what functions were defined.) > macro procedure TWICE u; list( 'PROGN, second u, second u ); TWICE > % A definition of Complex, structure with Real and Imaginary parts > % Redefine to see what functions were defined. Give 0 Init values > TWICE > Defstruct( Complex( !:Creator(Complex) ), R(0), I(0) ); *** Function `MAKECOMPLEX' has been redefined *** Function `ALTERCOMPLEX' has been redefined *** Function `COMPLEXP' has been redefined *** Function `COMPLEX' has been redefined *** Function `R' has been redefined *** Function `PUTR' has been redefined *** Function `I' has been redefined *** Function `PUTI' has been redefined *** Defstruct `COMPLEX' has been redefined COMPLEX > C0 := MakeComplex(); % Constructor with default inits. [COMPLEX 0 0] > ComplexP C0;% Predicate. T > C1:=MakeComplex( R 1, I 2 ); % Constructor with named values. [COMPLEX 1 2] > R(C1); I(C1);% Named selectors. 1 2 > C2:=Complex(3,4) % Creator with positional values. [COMPLEX 3 4] > AlterComplex( C1, R(2), I(3) ); % Alterant with named values. [COMPLEX 2 3] > C1; [COMPLEX 2 3] > R(C1):=5; I(C1):=6; % Named depositors. 5 6 > C1; [COMPLEX 5 6] > % Show use of Include Option. (Again, redef to show fns defined.) > TWICE Utilities 7 February 1983 PSL Manual page 17.20 section 17.6 > Defstruct( MoreComplex( !:Include(Complex) ), Z(99) ); *** Function `MAKEMORECOMPLEX' has been redefined *** Function `ALTERMORECOMPLEX' has been redefined *** Function `MORECOMPLEXP' has been redefined *** Function `Z' has been redefined *** Function `PUTZ' has been redefined *** Defstruct `MORECOMPLEX' has been redefined MORECOMPLEX > M0 := MakeMoreComplex(); [MORECOMPLEX 0 0 99] > M1 := MakeMoreComplex( R 1, I 2, Z 3 ); [MORECOMPLEX 1 2 3] > R C1; 5 > R M1; 1 > % A more complicated example: The structures which are used in the > % Defstruct facility to represent defstructs. (The EX prefix has > % been added to the names to protect the innocent...) > TWICE% Redef to show fns generated. > Defstruct( > EXDefstructDescriptor( !:Prefix(EXDsDesc), !:Creator ), >DsSize(!:Type int ), % (Upper Bound of vector.) >Prefix(!:Type string ), >SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) >ConsName( !:Type fnId ), >AltrName( !:Type fnId ), >PredName( !:Type fnId ), >CreateName( !:Type fnId ), >Include( !:Type typeid ), >InclInit( !:Type alist ) > ); *** Function `MAKEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `ALTEREXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDEFSTRUCTDESCRIPTORP' has been redefined *** Function `CREATEEXDEFSTRUCTDESCRIPTOR' has been redefined *** Function `EXDSDESCDSSIZE' has been redefined *** Function `PUTEXDSDESCDSSIZE' has been redefined *** Function `EXDSDESCPREFIX' has been redefined *** Function `PUTEXDSDESCPREFIX' has been redefined *** Function `EXDSDESCSLOTALIST' has been redefined *** Function `PUTEXDSDESCSLOTALIST' has been redefined *** Function `EXDSDESCCONSNAME' has been redefined *** Function `PUTEXDSDESCCONSNAME' has been redefined *** Function `EXDSDESCALTRNAME' has been redefined *** Function `PUTEXDSDESCALTRNAME' has been redefined PSL Manual 7 February 1983 Utilities section 17.6 page 17.21 *** Function `EXDSDESCPREDNAME' has been redefined *** Function `PUTEXDSDESCPREDNAME' has been redefined *** Function `EXDSDESCCREATENAME' has been redefined *** Function `PUTEXDSDESCCREATENAME' has been redefined *** Function `EXDSDESCINCLUDE' has been redefined *** Function `PUTEXDSDESCINCLUDE' has been redefined *** Function `EXDSDESCINCLINIT' has been redefined *** Function `PUTEXDSDESCINCLINIT' has been redefined *** Defstruct `EXDEFSTRUCTDESCRIPTOR' has been redefined EXDEFSTRUCTDESCRIPTOR > TWICE% Redef to show fns generated. > Defstruct( > EXSlotDescriptor( !:Prefix(EXSlotDesc), !:Creator ), >SlotNum( !:Type int ), >InitForm( !:Type form ), >SlotFn(!:Type fnId ), % Selector/Depositor id. >SlotType( !:Type type ), % Hm... >UserGet( !:Type boolean ), >UserPut( !:Type boolean ) > ); *** Function `MAKEEXSLOTDESCRIPTOR' has been redefined *** Function `ALTEREXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCRIPTORP' has been redefined *** Function `CREATEEXSLOTDESCRIPTOR' has been redefined *** Function `EXSLOTDESCSLOTNUM' has been redefined *** Function `PUTEXSLOTDESCSLOTNUM' has been redefined *** Function `EXSLOTDESCINITFORM' has been redefined *** Function `PUTEXSLOTDESCINITFORM' has been redefined *** Function `EXSLOTDESCSLOTFN' has been redefined *** Function `PUTEXSLOTDESCSLOTFN' has been redefined *** Function `EXSLOTDESCSLOTTYPE' has been redefined *** Function `PUTEXSLOTDESCSLOTTYPE' has been redefined *** Function `EXSLOTDESCUSERGET' has been redefined *** Function `PUTEXSLOTDESCUSERGET' has been redefined *** Function `EXSLOTDESCUSERPUT' has been redefined *** Function `PUTEXSLOTDESCUSERPUT' has been redefined *** Defstruct `EXSLOTDESCRIPTOR' has been redefined EXSLOTDESCRIPTOR > END; NIL Utilities 7 February 1983 PSL Manual page 17.22 section 17.7 17.7. DefConst 17.7. DefConst 17.7. DefConst DefConst DefConst _ __ _ ______ _________ _____ (DefConst [U:id V:number]): Undefined macro DefConst DefConst DefConst is a simple means for defining and using symbolic constants, as an alternative to the heavy-handed NEWNAM or DEFINE facility in REDUCE/RLISP. Constants are defined thus: DefConst(FooSize, 3); or as sequential pairs: DEFCONST(FOOSIZE, 3, BARSIZE, 4); Const Const _ __ ______ _____ (Const U:id): number macro Const Const They are referred to by the macro Const, so CONST(FOOSIZE) would be replaced by 3. 17.8. Functions for Sorting 17.8. Functions for Sorting 17.8. Functions for Sorting The Gsort module provides functions for sorting lists and vectors. Some __________ ________ of the functions take a comparison function as an argument. The comparison function takes two arguments and returns NIL if they are out of order, i.e. if the second argument should come before the first in the sorted result. Lambda expressions are acceptable as comparison functions. Gsort Gsort _____ ____ ______ ___ __ __ ________ ____ ______ ____ (Gsort TABLE:{list,vector} leq-fn:{id,function}): {list,vector} expr ____ ______ ___ __ Returns a sorted list or vector. LEQ-FN is the comparison _____ function used to determine the sorting order. The original TABLE Gsort Gsort is unchanged. Gsort uses a stable sorting algorithm. In other _ _ _ words, if X appears before Y in the original table then X will _ _ _ appear before Y in the final table unless X and Y are out of _ _ order. (An unstable sort, on the other hand, might swap X and Y _ _ even if they're in order. This could happen when X and Y have the same "key field", so either one could come first without making a difference to the comparison function.) GmergeSort GmergeSort _____ ____ ______ ___ __ __ ________ ____ ______ ____ (GmergeSort TABLE:{list,vector} leq-fn:{id,function}): {list,vector} expr Gsort Gsort _____ The same as Gsort, but destructively modifies the TABLE argument. GmergeSort Gsort GmergeSort Gsort GmergeSort has the advantage of being somewhat faster than Gsort. Note that you should use the value returned by the function-- PSL Manual 7 February 1983 Utilities section 17.8 page 17.23 don't depend on the modified argument to give the right answer. IdSort IdSort _____ ____ ______ ____ ______ ____ (IdSort TABLE:{list,vector}): {list,vector} expr __ Returns a table of ids sorted into alphabetical order. The original table is unchanged. Case is not significant in determining the alphabetical order. The table may contain ______ __ strings as well as ids. The following example illustrates the use of Gsort. 1 lisp> (load gsort) NIL 2 lisp> (setq X '(3 8 -7 2 1 5)) (3 8 -7 2 1 5) 3 lisp> % Sort from smallest to largest. 3 lisp> (Gsort X 'leq) (-7 1 2 3 5 8) 4 lisp> % Sort from largest to smallest. 4 lisp> (GmergeSort X 'geq) (8 5 3 2 1 -7) 5 lisp> % Note that X was "destroyed" by GmergeSort. 5 lisp> X (3 2 1 -7) 6 lisp> 6 lisp> % Here's IdSort, taking a vector as its argument. 6 lisp> (IdSort '[the quick brown fox jumped over the lazy dog]) [BROWN DOG FOX JUMPED LAZY OVER QUICK THE THE] 7 lisp> 7 lisp> % Some examples of user defined comparison functions... 7 lisp> (setq X '(("Joe" . 20000) ("Moe" . 21000) ("Larry" . 7000))) (("Joe" . 20000) ("Moe" . 21000) ("Larry" . 7000)) 8 lisp> 8 lisp> % First, sort the list alphabetically according to name, 8 lisp> % using a lambda expression as the comparison function. 8 lisp> (Gsort X 8 lisp> '(lambda (X Y) (string-not-greaterp (car X) (car Y)))) (("Joe" . 20000) ("Larry" . 7000) ("Moe" . 21000)) 9 lisp> 9 lisp> % Now, define a comparison function that compares cdrs of 9 lisp> % pairs, and returns T if the first is less than or equal 9 lisp> % to the second. 9 lisp> (de cdr_leq (pair1 pair2) 9 lisp> (leq (cdr pair1) (cdr pair2))) CDR_LEQ 10 lisp> 10 lisp> % Use the cdr_leq function to sort X. 10 lisp> (Gsort X 'cdr_leq) (("Larry" . 7000) ("Joe" . 20000) ("Moe" . 21000)) Utilities 7 February 1983 PSL Manual page 17.24 section 17.9 17.9. Hashing Cons 17.9. Hashing Cons 17.9. Hashing Cons HCons HCons HCONS is a loadable module. The HCons function creates unique dotted HCons Eq HCons Eq HCons _ _ Eq HCons _ _ _ Eq _ pairs. In other words, HCons(A, B) Eq HCons(C, D) if and only if A Eq C Eq _ Eq _ and B Eq D. This allows rapid tests for equality between structures, at the cost of expending more time in creating the structures. The use of HCons HCons HCons may also save space in cases where lists share common substructure, since only one copy of the substructure is stored. Hcons Hcons ____ ____ _____ Hcons works by keeping a pair hash table of all pairs that have been HCons HCons created by HCons. (So the space advantage of sharing substructure may be offset by the space consumed by table entries.) This hash table also allows the system to store property lists for pairs--in the same way that LISP has property lists for identifiers. HCons RplacA RplacD HCons ______ ___ RplacA RplacD Pairs created by HCons should not be modified with RplacA and RplacD. Doing so will make the pair hash table inconsistent, as well as being very likely to modify structure shared with something that you don't wish to change. Also note that large numbers may be equal without being eq, so the HCons Eq HCons HCons Eq HCons HCons of two large numbers may not be Eq to the HCons of two other numbers that appear to be the same. (Similar warnings hold for strings and vectors.) The following "user" functions are provided by HCONS: HCons HCons _ ___ ____ _____ (HCons [U:any]): pair macro HCons HCons The HCons macro takes one or more arguments and returns their "hashed cons" (right associatively). With two arguments this Cons Cons corresponds to a call of Cons. HList HList _ ___ ____ _____ (HList [U:any]): list nexpr HList List HList List HList is the "HCONS version" of the List function. HCopy HCopy _ ___ ___ _____ (HCopy U:any): any macro HCopy Copy HCopy HCopy Copy HCopy HCopy is the HCONS version of the Copy function. Note that HCopy Copy Copy serves a very different purpose than Copy, which is usually used to copy a structure so that destructive changes can be made to HCopy HCopy the copy without changing the original. HCopy only copies those Cons Cons parts of the structure which haven't already been "Consed HCons HCons together" by HCons. HAppend HAppend _ ____ _ ____ ____ ____ (HAppend U:list V:list): list expr HCons Append HCons Append The HCons version of Append. PSL Manual 7 February 1983 Utilities section 17.9 page 17.25 HReverse HReverse _ ____ ____ ____ (HReverse U:list): list expr HCons Reverse HCons Reverse The HCons version of Reverse. Get Put Get Put The following two functions can be used to "Get" and "Put" properties for pairs or identifiers. The pairs for these functions must be created by HCons SetF HCons SetF HCons. These functions are known to the SetF macro. Extended-Put Extended-Put _ __ ____ ___ __ ____ ___ ___ ____ (Extended-Put U:{id,pair} IND:id PROP:any): any expr Extended-Get Extended-Get _ __ ____ ___ ___ ___ ____ (Extended-Get U:{id,pair} IND:any): any expr 17.10. Graph-to-Tree 17.10. Graph-to-Tree 17.10. Graph-to-Tree GRAPH-TO-TREE is a loadable module. For resident functions printing circular lists see Section 15.8. Graph-to-Tree Graph-to-Tree _ ____ ____ ____ (Graph-to-Tree A:form): form expr Graph-to-Tree Graph-to-Tree The function Graph-to-Tree copies an arbitrary s-expression, removing circularity. It does NOT show non-circular shared Eq Eq structure. Places where a substructure is Eq to one of its ancestors are replaced by non-interned ids of the form <n> where n is a small integer. The parent is replaced by a two element list of the form (<n>: u) where the n's match, and u is the (de-circularized) structure. This is most useful in adapting any printer for use with circular structures. CPrint CPrint _ ___ ___ ____ (CPrint A:any): NIL expr CPrint CPrint The function CPrint, also defined in the module GRAPH-TO-TREE, is PrettyPrint Graph-to-Tree PrettyPrint Graph-to-Tree simply (PrettyPrint (Graph-to-Tree X)). Note that GRAPH-TO-TREE is very embryonic. It is MUCH more inefficient than it needs to be, heavily consing. A better implementation would use a stack (vector) instead of lists to hold intermediate expressions for comparison, and would not copy non-circular structure. In addition facilities should be added for optionally showing shared structure, for performing the inverse operation, and for also editing long or deep structures. Finally, the output representation was chosen at random and can probably be improved, or at least brought in line with CL or some other standard. Utilities 7 February 1983 PSL Manual page 17.26 section 17.11 17.11. Inspect Utility 17.11. Inspect Utility 17.11. Inspect Utility INSPECT is a loadable module. Inspect Inspect ________ ______ ____ (Inspect FILENAME:string): expr This is a simple utility which scans the contents of a source file to tell what functions are defined in it. It will be embellished slightly to permit the on-line querying of certain Inspect Inspect attributes of files. Inspect reads one or more files, printing and collecting information on defined functions. Usage: (LOAD INSPECT) (INSPECT "file-name") % Scans the file, and prints proc % names. It also % builds the lists ProcedureList!* % FileList!* and ProcFileList!* % File-Name can DSKIN other files On the Fly printing is controlled by !*PrintInspect, default is T. Other lists built include FileList!* and ProcFileList!*, which is a list of (procedure . filename) for multi-file processing. For more complete process, do: (LOAD INSPECT) (OFF PRINTINSPECT) (INSPECTOUT) (DSKIN ...) (DSKIN ...) (INSPECTEND) |
Added psl-1983/lpt/18-complr.lpt version [276c7cbd14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Compiler and Loader section 18.0 page 18.1 CHAPTER 18 CHAPTER 18 CHAPTER 18 LOADER AND COMPILER LOADER AND COMPILER LOADER AND COMPILER 18.1. Introduction . . . . . . . . . . . . . . . 18.1 18.2. The Compiler . . . . . . . . . . . . . . . 18.2 18.2.1. Compiling Functions into Memory . . . . . . 18.2 18.2.2. Compiling Functions into FASL Files . . . . . 18.3 18.2.3. Loading FASL Files. . . . . . . . . . . 18.3 18.2.4. Functions to Control the Time When Something is Done 18.5 . 18.2.5. Order of Functions for Compilation . . . . . 18.6 18.2.6. Fluid and Global Declarations . . . . . . . 18.6 18.2.7. Switches Controlling Compiler . . . . . . . 18.8 18.2.8. Differences between Compiled and Interpreted Code 18.10 18.2.9. Compiler Errors. . . . . . . . . . . . 18.11 18.3. The Loader. . . . . . . . . . . . . . . . 18.13 18.3.1. Legal LAP Format and Pseudos . . . . . . . 18.14 18.3.2. Examples of LAP for DEC-20, VAX and Apollo. . . 18.14 18.3.3. Lap Switches. . . . . . . . . . . . . 18.17 18.4. Structure and Customization of the Compiler. . . . . 18.18 18.5. First PASS of Compiler. . . . . . . . . . . . 18.19 18.5.1. Tagging Information . . . . . . . . . . 18.19 18.5.2. Source to Source Transformations . . . . . . 18.20 18.6. Second PASS - Basic Code Generation . . . . . . . 18.20 18.6.1. The Cmacros . . . . . . . . . . . . . 18.20 18.6.2. Classes of Functions . . . . . . . . . . 18.23 18.6.3. Open Functions . . . . . . . . . . . . 18.24 18.7. Third PASS - Optimizations . . . . . . . . . . 18.29 18.8. Some Structural Notes on the Compiler. . . . . . . 18.30 18.1. Introduction 18.1. Introduction 18.1. Introduction The functions and facilities in the PSL LISP/SYSLISP compiler and supporting loaders (LAP and FASL) are described in this chapter. [??? This chapter is out of date and will be rewritten soon. ???] [??? This chapter is out of date and will be rewritten soon. ???] [??? This chapter is out of date and will be rewritten soon. ???] 18.2. The Compiler 18.2. The Compiler 18.2. The Compiler The compiler is a version of the Portable LISP Compiler [Griss 81], Compiler and Loader 7 February 1983 PSL Manual page 18.2 section 18.2 1 modified and extended to more efficiently support both LISP and SYSLISP compilation. See the later sections in this chapter and references [Griss 81] and [Benson 81] for more details. 18.2.1. Compiling Functions into Memory 18.2.1. Compiling Functions into Memory 18.2.1. Compiling Functions into Memory __________ ______ !*COMP [Initially: NIL] switch If the compiler is loaded (which is usually the case, otherwise on on execute LOAD COMPILER;), turning on the switch !*COMP (via on comp; in RLISP) causes all subsequent procedure definitions of appropriate type to be compiled automatically and a message of the form <function-name> COMPILED, <words> WORDS, <words> LEFT to be printed. The first number is the number of words of binary program space the compiled function took, and the second number the number of words left unused in binary program space. See !*PWRDS in Section 18.2.7. ____ _____ _____ _____ ____ _____ _____ _____ ____ _____ _____ _____ expr fexpr nexpr macro expr fexpr nexpr macro Currently, exprs, fexprs, nexprs and macros may be compiled. This is controlled by a flag ('COMPILE) on the property list of the procedure type. If desired, uncompiled functions already resident may be compiled by using Compile Compile _____ __ ____ ___ ____ (Compile NAMES:id-list): any expr 18.2.2. Compiling Functions into FASL Files 18.2.2. Compiling Functions into FASL Files 18.2.2. Compiling Functions into FASL Files Load FaslIn Load FaslIn In order to produce files that may be input using Load or FaslIn, the FaslOut FaslEnd FaslOut FaslEnd FaslOut and FaslEnd pair may be used in RLISP mode: FaslOut FaslOut ____ ______ ___ ____ (FaslOut FILE:string): NIL expr _______________ 1 Many of the recent extensions to the PLC were implemented by John Peterson. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.3 FaslEnd FaslEnd ___ ____ (FaslEnd ): NIL expr FaslOut FaslOut After the command FaslOut has been given, all subsequent S-expressions and function definitions typed in or input from files are processed by the Compiler, LAP and FASL as needed, and ____ output to FILE. Functions are compiled and partially assembled, and output as in a compressed binary form, involving blocks of code and relocation bits. This activity continues until the FaslEnd FaslEnd function FaslEnd terminates this process. FaslOut FaslEnd FaslOut FaslEnd The FaslOut and FaslEnd pair also use the DFPRINT!* mechanism, turning on the switch !*DEFN, and redefining DFPRINT!* to trap the parsed input in the RLISP top-loop. Currently this is not useable from pure LISP level. [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] [??? Fix, by adding !*DEFN mechanism to basic top-loop. ???] 18.2.3. Loading FASL Files 18.2.3. Loading FASL Files 18.2.3. Loading FASL Files Two convenient procedures are available for loading FASL files (.b files on the VAX); see Section 18.2.2 for information on producing FASL files. Load Load ____ ______ __ ___ _____ (Load [FILE:{string, id}]): NIL macro ____ Each FILE is converted into a file name of the form "/u/local/lib/psl/file.b" on the VAX, "pl:file.b" on the DEC-20. FaslIn FaslIn An attempt is made to execute the function FaslIn on it. Once ____ loaded, the symbol FILE is added to the GLOBAL variable OPTIONS!*. FaslIn FaslIn ________ ______ ___ ____ (FaslIn FILENAME:string): NIL expr This is an efficient binary read loop, which fetches blocks of __ code, constants and compactly stored ids. It uses a bit-table to relocate code and to identify special LISP-oriented constructs. ________ FILENAME must be a complete file name. ReLoad ReLoad ____ ______ __ ___ _____ (ReLoad [FILE:{string,id}]): NIL macro Removes the filename from the list OPTIONS!* and executes the Load Load function Load. Imports Imports ___________ ____ ___ ____ (Imports MODULENAMES:list): NIL expr LOAD ___________ __ LOAD MODULENAMES is a list of ids representing modules to be LOAD'ed after the module containing this function has been loaded. Imports Imports Imports works only in compiled code. Compiler and Loader 7 February 1983 PSL Manual page 18.4 section 18.2 __________ ______ LOADDIRECTORIES!* [Initially: A list of strings] global Contains a list of strings to append to the front of file names Load Load given in Load commands. This list may be one of the following, if your system is an Apollo, Dec-20, or Vax: ("" "/utah/psl/lap/") ("" "pl:") ("" "/usr/local/src/cmd/psl/dist/lap/") __________ ______ LOADEXTENSIONS!* [Initially: An a-list] global Contains an a-list of (str . fn) in which the str is an extension to append to the end of the filename and fn is a function to apply. The a-list contains ((".b" . FaslIn)(".lap" . LapIn)(".sl" . LapIN)) [??? Describe FASL format in more detail ???] [??? Describe FASL format in more detail ???] [??? Describe FASL format in more detail ???] 18.2.4. Functions to Control the Time When Something is Done 18.2.4. Functions to Control the Time When Something is Done 18.2.4. Functions to Control the Time When Something is Done Which expressions are evaluated during compilation ONLY, which output to the file for LOAD TIME evaluation, and which do both (such as macro definitions) can be controlled by the properties 'EVAL and 'IGNORE on certain function names, or the following functions. CommentOutCode CommentOutCode _ ____ ___ _____ (CommentOutCode U:form): NIL macro _ Comment out a single expression; use <<U>> to comment out a block of code. CompileTime CompileTime _ ____ ___ ____ (CompileTime U:form): NIL expr _ Evaluate the expression U at compile time only, such as defining auxiliary smacros and macros that should not go into the file. Certain functions have the FLAG 'IGNORE on their property lists to achieve the same effect. E.g. FLAG('(LAPOUT LAPEND),'IGNORE) has been done. BothTimes BothTimes _ ____ _ ____ ____ (BothTimes U:form): U:form expr Evaluate at compile and load time. This is equivalent in effect Flag Flag to executing Flag('(f1 f2),'EVAL) for certain functions. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.5 LoadTime LoadTime _ ____ _ ____ ____ (LoadTime U:form): U:form expr Evaluate at load time only. Should not even compile code, just pass direct to file. [??? EVAL and IGNORE are for compatibility, and enable the above sort [??? EVAL and IGNORE are for compatibility, and enable the above sort [??? EVAL and IGNORE are for compatibility, and enable the above sort of functions to be easily written. The user should AVOID EVAL and of functions to be easily written. The user should AVOID EVAL and of functions to be easily written. The user should AVOID EVAL and IGNORE flags, if Possible ???] IGNORE flags, if Possible ???] IGNORE flags, if Possible ???] 18.2.5. Order of Functions for Compilation 18.2.5. Order of Functions for Compilation 18.2.5. Order of Functions for Compilation ____ ____ ____ expr expr Non-expr procedures must be defined before their use in a compiled function, since the compiler treats the various function types differently. _____ _____ _____ _____ _____ _____ Macro fexpr Macro fexpr Macros are expanded and then compiled; the argument list fexprs quoted; the _____ _____ _____ nexpr nexpr arguments of nexprs are collected into a single list. Sometimes it is convenient to define a Dummy version of the function of appropriate type, to be redefined later. This acts as an "External or Forward" declaration of the function. [??? Add such a declaration. ???] [??? Add such a declaration. ???] [??? Add such a declaration. ???] 18.2.6. Fluid and Global Declarations 18.2.6. Fluid and Global Declarations 18.2.6. Fluid and Global Declarations The FLUID and GLOBAL declarations must be used to indicate variables that are to be used as non-LOCALs in compiled code. Currently, the compiler defaults variables bound in a particular procedure to LOCAL. The effect of this is that the variable only exists as an "anonymous" stack location; its name is compiled away and called routines cannot see it (i.e. they would have to use the name). Undeclared non-LOCAL variables are automatically declared FLUID by the compiler with a warning. In many cases, this means that a previous procedure that bound this variable should have known about this as a FLUID. Declare it with FLUID, below, and recompile, since the caller cannot be automatically fixed. [??? Should we provide an !*AllFluid switch to make the default Fluid, [??? Should we provide an !*AllFluid switch to make the default Fluid, [??? Should we provide an !*AllFluid switch to make the default Fluid, or should we make Interpreter have a LOCAL variable as default, or both or should we make Interpreter have a LOCAL variable as default, or both or should we make Interpreter have a LOCAL variable as default, or both ???] ???] ???] Fluid Fluid _____ __ ____ ___ ____ (Fluid NAMES:id-list): any expr Declares each variable FLUID (if not previously declared); this Prog Prog means that it can be used as a Prog LOCAL, or as a parameter. On entry to the procedure, its current value is saved on the Binding Stack (BSTACK), and all access is always to the VALUE cell Throw Error Throw Error (SYMVAL) of the variable; on exit (or Throw or Error), the old values are restored. Compiler and Loader 7 February 1983 PSL Manual page 18.6 section 18.2 Global Global _____ __ ____ ___ ____ (Global NAMES:id-list): any expr Declares each variable GLOBAL (if not previously declared); this means that it cannot be used as a LOCAL, or as a parameter. Access is always to the VALUE cell (SYMVAL) of the variable. [??? Should we eliminate GLOBALs ???] [??? Should we eliminate GLOBALs ???] [??? Should we eliminate GLOBALs ???] 18.2.7. Switches Controlling Compiler 18.2.7. Switches Controlling Compiler 18.2.7. Switches Controlling Compiler The compilation process is controlled by a number of switches, as well as the above declarations and the !*COMP switch, of course. __________ ______ !*R2I [Initially: T] switch T T If T, causes recursion removal if possible, converting recursive calls on a function into a jump to its start. If this is not possible, it uses a faster call to its own "internal" entry, rather than going via the Symbol Table function cell. The effect in both cases is that tracing this function does not show the internal or eliminated recursive calls, nor the backtrace information. __________ ______ !*NOLINKE [Initially: NIL] switch T NIL T NIL If T, inhibits use of !*LINKE cmacro. If NIL, "exit" calls on functions that would then immediately return. For example, the calls on FOO(x) and FEE(X) in PROCEDURE DUM(X,Y); IF X=Y THEN FOO(X) ELSE FEE(X+Y); can be converted into direct JUMP's to FEE or FOO's entry point. This is known as a "tail-recursive" call being converted to a jump. If this happens, there is no indication of the call of DUM on the backtrace stack if FEE or FOO cause an error. __________ ______ !*ORD [Initially: NIL] switch T T If T, forces the compiler to compile arguments in Left-Right Order, even though more optimal code can be generated. [??? !*ORD currently has a bug, and may not be fixed for some [??? !*ORD currently has a bug, and may not be fixed for some [??? !*ORD currently has a bug, and may not be fixed for some time. Thus do NOT depend on evaluation order in argument time. Thus do NOT depend on evaluation order in argument time. Thus do NOT depend on evaluation order in argument lists ???] lists ???] lists ???] PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.7 __________ ______ !*MODULE [Initially: NIL] switch Indicates block compilation (a future extension of this compiler). When implemented, even more function and variable names are "compiled away". The following switches control the printing of information during the compilation process: __________ ______ !*PWRDS [Initially: NIL] switch T T If T, causes the compiled size to be printed in the form *** NAME: base NNN, length MMM The base is in octal, the length is in current Radix. [??? more mnemonic name ???] [??? more mnemonic name ???] [??? more mnemonic name ???] __________ ______ !*PLAP [Initially: NIL] switch T T If T, causes the printing of the portable cmacros produced by the the compiler. Most of this information is printed by the resident LAP, and controlled by its switches, described below. 18.2.8. Differences between Compiled and Interpreted Code 18.2.8. Differences between Compiled and Interpreted Code 18.2.8. Differences between Compiled and Interpreted Code The following just re-iterates some of the points made above and in other Sections of the manual regarding the "obscure" differences that compilation introduces. [??? This needs some careful work, and perhaps some effort to reduce [??? This needs some careful work, and perhaps some effort to reduce [??? This needs some careful work, and perhaps some effort to reduce the list of differences ???] the list of differences ???] the list of differences ???] In the process of compilation, many functions are open-coded, and hence cannot be redefined or traced in the compiled code. Such functions are noted to be OPEN-CODED in the manual. If called from compiled code, the call on an open-compiled function is replaced by a series of online instructions. Most of these functions have some sort of indicator on their property lists: 'OPEN, 'ANYREG, 'CMACRO, 'COMPFN, etc. For example: SETQ, CAR, CDR, COND, WPLUS2, MAP functions, PROG, PROGN, etc. Also note that _____ _____ _____ macro macro some functions are defined as macros, which convert to some other form (such as PROG), which itself might compile open. Some optimizations are performed that cause inaccessible or redundant code to be removed, e.g. 0*foo(x) could cause foo(x) not to be called. Compiler and Loader 7 February 1983 PSL Manual page 18.8 section 18.2 _____ ______ _____ ______ _____ ______ Fluid global Fluid global Unless variables are declared (or detected) to be Fluid or global, they _____ _____ _____ local local are compiled as local variables. This causes their names to disappear, and so are not visible on the Binding Stack. Further more, these variables are NOT available to functions called in the dynamic scope of the function containing their binding. _____ _____ _____ _____ _____ _____ _____ _____ _____ macro fexpr nexpr macro fexpr nexpr Since compiled calls on macros, fexprs and nexprs are different from the ____ ____ ____ expr expr default exprs, these functions must be declared (or defined) before _____ _____ _____ _____ _____ _____ fexpr nexpr fexpr nexpr compiling the code that uses them. While fexprs and nexprs may _____ _____ _____ macro macro subsequently be redefined (as new functions of same type), macros are executed by the compiler to get the replacement form, which is then compiled. The interpreter of course picks up the most recent definition of ANY function, and so functions can switch type as well as body. [??? If we expand macros at PUTD time, then this difference will go [??? If we expand macros at PUTD time, then this difference will go [??? If we expand macros at PUTD time, then this difference will go away. ???] away. ???] away. ???] As noted above, the !*R2I, !*NOLINKE and !*MODULE switches cause certain functions to call other functions (or themselves usually) by a faster route (JUMP or internal call). This means that the recursion or call may not be visible during tracing or backtrace. 18.2.9. Compiler Errors 18.2.9. Compiler Errors 18.2.9. Compiler Errors A number of compiler errors are listed below with possible explanations of the error. *** Function form converted to APPLY Car Car This message indicates that the Car of a form is either a. Non-atomic, b. a local variable, or c. a global or fluid variable. The compiler converts (F X1 X2 ...), where F is one of the above, to (APPLY F (LIST X1 X2 ...)). *** NAME already SYSLISP non-local This indicates that NAME is either a WVAR or WARRAY in SYSLISP mode, but is being used as a local variable in LISP mode. No special action is taken. *** WVAR NAME used as local This indicates that NAME is a WVAR, but is being used as a bound variable in SYSLISP mode. The variable is treated as an an anonymous local variable within the scope of its binding. PSL Manual 7 February 1983 Compiler and Loader section 18.2 page 18.9 *** NAME already SYSLISP non-local This indicates that a variable was previously declared as a SYSLISP WVAR or WARRAY and is now being used as a LISP fluid or global. No special action is taken. *** NAME already LISP non-local This indicates that a variable was previously declared as a LISP fluid or global and is now being used as a SYSLISP WVAR or WARRAY. No special action is taken. *** Undefined symbol NAME in Syslisp, treated as WVAR A variable was encountered in SYSLISP mode which is not local nor a WVAR or WARRAY. The compiler declares it a WVAR. This is an error, all WVARs should be explicitly declared. *** NAME declared fluid A variable was encountered in LISP mode which is not local nor a previously declared fluid or global. The compiler declares it fluid. This is sometimes an error, if the variable was used strictly locally in an earlier function definition, but was intended to be bound non-locally. All fluids should be declared before being used. 18.3. The Loader 18.3. The Loader 18.3. The Loader [??? update ???] [??? update ???] [??? update ???] Currently, PSL on the DEC-20 provides a simple LISP assembler, LAP. This is modeled after the original LISP 1.6 LAP, although completely reimplemented to take advantage of PSL constructs, and to support the additional requirements of SYSLISP. In the process of implementing the VAX LAP and developing the LAP-to-ASM translator required to bootstrap PSL onto the next machine (Apollo MC68000), a much more table-driven form of LAP was designed to make all LAP's, LAP-to-ASM's and FASL's (fast loaders, sometimes called FAP) easier to maintain. This is now in use on the VAX and being used to implement Apollo PSL. [??? FASL now works ???] [??? FASL now works ???] [??? FASL now works ???] Until that is complete, we will briefly describe the available functions, and give a sample of current and future LAP; this Section will be completely rewritten in the next revision. LAP is currently a full two pass assembler; on the VAX and Apollo it also includes a pass to optimize long and short jumps. Compiler and Loader 7 February 1983 PSL Manual page 18.10 section 18.3 LAP LAP ____ ____ ____ _______ ____ (LAP CODE:list): code-pointer expr ____ CODE is a list of legal LAP forms, including: a. Machine specific Mnemonics (using opcode-names from the assembler on the DEC-20, VAX or Apollo). b. Compiler cmacros (which expand in a machine specific way). These can be thought of as "generic" or LISP-oriented instructions. See the next Section on the Compiler details, and list of legal cmacros. c. LAP pseudo instructions, to declare entry points, indicate data and constants, etc. The first pass of LAP converts mnemonics into LISP integers, doing as much of the assembly as possible, allocating labels and constants. The second (and third?) pass fills in labels and completes the assembly, depositing code into the next available locations in BPS, or creating FASL or LAP files. [??? What is BPS (binary program space) ???] [??? What is BPS (binary program space) ???] [??? What is BPS (binary program space) ???] 18.3.1. Legal LAP Format and Pseudos 18.3.1. Legal LAP Format and Pseudos 18.3.1. Legal LAP Format and Pseudos [??? Describe LAP format in detail ???] [??? Describe LAP format in detail ???] [??? Describe LAP format in detail ???] 18.3.2. Examples of LAP for DEC-20, VAX and Apollo 18.3.2. Examples of LAP for DEC-20, VAX and Apollo 18.3.2. Examples of LAP for DEC-20, VAX and Apollo The following is a piece of VAX specific LAP, using the current "new" format. Apart from the VAX mnemonics, notice the extra tags around the register names, and the symbols to indicate addressing modes (essentially PREFIX syntax rather then INFIX @ etc.). This is from PV:APPLY-LAP.RED. Note they are almost ENTIRELY written in cmacros, to aid in re-coding for the next machine. PSL Manual 7 February 1983 Compiler and Loader section 18.3 page 18.11 lap '((!*entry FastApply expr 0) %. Apply with arguments loaded % Called with arguments in the registers and functional form in t1 (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*FIELD (reg t1) (reg t1) (WConst InfStartingBit) (WConst InfBitLength)) (!*JUMPNOTEQ (Label NotAnID) (reg t2) (WConst ID)) (!*WTIMES2 (reg t1) (WConst AddressingUnitsPerFunctionCell)) (!*JUMP (MEMORY (reg t1) (WArray SymFnc))) NotAnID (!*JUMPNOTEQ (Label NotACodePointer) (reg t2) (WConst CODE)) (!*JUMP (MEMORY (reg t1) (WConst 0))) NotACodePointer (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst (!*MOVE (MEMORY (reg t1) (WConst 0)) (reg t2)) % CAR with pair already unta (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (QUOTE L (!*MOVE (reg t1) (reg t2)) % put lambda form in t2 (!*PUSH (QUOTE NIL)) % align stack (!*JCALL FastLambdaApply) IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form in Apply") (reg 1)) (!*MOVE (reg t1) (reg 2)) (!*CALL List2) (!*JCALL StdError) ); lap '((!*entry UndefinedFunction expr 0) %. Error Handler for non code % Called by JSB % (subl3 (immediate (plus2 (WArray SymFnc) 6)) (autoincrement (reg st)) (reg t1)) (divl2 6 (reg t1)) (!*MKITEM (reg t1) (WConst ID)) (!*MOVE (reg t1) (reg 2)) (!*MOVE (QUOTE "Undefined function %r called from compiled c (reg 1)) (!*CALL BldMsg) (!*JCALL StdError) ); The following is a piece of Apollo specific LAP, using the current NEW format. Apart from the MC68000 mnemonics, notice the extra tags around the register names, and the symbols to indicate addressing modes (essentially PREFIX syntax rather then INFIX @ etc.). This is from P68:M68K-USEFUL- LAP.RED. Compiler and Loader 7 February 1983 PSL Manual page 18.12 section 18.3 % Signed multiply of 32 bits numbers in A1 and A2, % returns 64 bits in A1 and A2, low in A1 high in A2 % Clobbers D1,D2,D3,D4,D5,D6,D7, no saving % [Can insert MOVEM!.L D1-D7,-(SP) % and MOVEM!.L (SP)+,D1-D7] LAP '((!*entry Mult32 expr 2) % Arguments in A1 and A2 (move!.l (reg a1) (reg d1)) (move!.l (reg a1) (reg d6)) (move!.l (reg a2) (reg d2)) (move!.l (reg a2) (reg d7)) % Need copies % Now do Unsigned Multiply (move!.l (reg d1) (reg d3)) (move!.l (reg d1) (reg d4)) (swap (reg d4)) (move!.l (reg d2) (reg d5)) (swap (reg d5)) % Swapped for partial products (mulu!.w (reg d2) (reg d1)) % partial products (pp1) (mulu!.w (reg d4) (reg d2)) % pp2 (mulu!.w (reg d5) (reg d3)) % pp3 (mulu!.w (reg d5) (reg d4)) % pp4 (swap (reg d1)) % sum1=pp#2low+pp#1hi (add (reg d2) (reg d1)) (clr!.l (reg d5)) (addx!.l (reg d5) (reg d4)) % propagate carry (add (reg d3) (reg d1)) % sum2=sum1+pp#3low (addx!.l (reg d5) (reg d4)) % carry inot pp#4 (swap (reg d1)) % low order product (clr (reg d2)) (swap (reg d2)) (clr (reg d3)) (swap (reg d3)) (add!.l (reg d3) (reg d2)) % Sum3=pp2low+pp3Hi (add!.l (reg d4) (reg d2)) % Sum4=Sum3+pp4 % Now do adjustment (tst!.l (reg d7)) % Negative (bpl!.s chkd6) % nope (sub!.l (reg d6) (reg d2)) % Flip chkd6 (tst!.l (reg d6)) % Negative (bpl!.s done) % nope (sub!.l (reg d7) (reg d2)) % Flip done (movea!.l (reg d1) (reg a1)) % low part (movea!.l (reg d2) (reg a2)) % high part (rts)); PSL Manual 7 February 1983 Compiler and Loader section 18.3 page 18.13 18.3.3. Lap Switches 18.3.3. Lap Switches 18.3.3. Lap Switches The following switches control the printing of information from LAP and other optional behavior of LAP: __________ ______ !*PLAP [Initially: NIL] switch Causes LAP forms to printed before expansion. Used mainly to see output of compiler before assembly. __________ ______ !*PGWD [Initially: NIL] switch Causes LAP to print the actual DEC-20 mnemonics and corresponding assembled instruction in octal, displaying OPCODE, REGISTER, INDIRECT, INDEX and ADDRESS fields. __________ ______ !*PWRDS [Initially: T] switch Prints a LAP message of the form *** NAME: base NNN, length MMM The base is in octal, the length is in current Radix. __________ ______ !*SAVECOM [Initially: T] switch If T, the LAP is deposited in BPS, and the returned Code-Pointer used to (re)define the procedure associated with the (!*entry name type n). __________ ______ !*SAVEDEF [Initially: NIL] switch If T, and if !*SAVECOM is T, saves any preexisting procedure definition under '!*SAVEDEF on the property list of the procedure name, "just in case". LAP also uses the following indicators on property lists: 'MC Cmacros and some mnemonics have associated PASS1 expansions in terms of simpler instructions or operations. The form (mc a1 ... an) has its associated function applied to (a1 ... an). For more details, see "P20:LAP.RED". Compiler and Loader 7 February 1983 PSL Manual page 18.14 section 18.4 18.4. Structure and Customization of the Compiler 18.4. Structure and Customization of the Compiler 18.4. Structure and Customization of the Compiler The following is a brief summary of the compiler structure and model. The purpose of this Section is to aid the user to add new compilation forms, and to understand the task of bootstrapping a new version of PSL. The original paper on the Portable LISP Compiler [Griss 81] has complete details on the original version of the compiler, and should be read in conjunction with this Section. It might be useful to also examine the paper on recent work on the compiler [Griss 82]. [??? This needs a LOT of work ???] [??? This needs a LOT of work ???] [??? This needs a LOT of work ???] The compiler is basically three-pass: ______ ______ ______ macros macros a. The first pass expands ordinary macros, and compiler specific cmacros. It also uses some special purpose 'PA1REFORM and 'PA1FN functions on the property lists of certain functions to produce a simpler and more explicit LISP for the next pass. Variables and constants, x, are explicitly tagged as (FLUID x), (GLOBAL x), (QUOTE x), (WCONST x), etc. b. The second pass recursively compiles the code, using 'COMPFN's to handle special cases, and the recursive function !&COMPILE for the general case. In general, code is compiled to cause function arguments to be loaded into R1...Rn in order, a CALL to the function to be made, and the returned value to appear in R1. Temporaries and function arguments to be reused later are saved on the stack. The compiler allocates a single FRAME for the maximum stack space that might be needed, and then trims it down in the third pass. PSL requires registers R1 ... R15, though not all need be "REAL registers"; the extra are simulated as memory locations. Special cases avoid a lot of LOAD/STORES to move arguments around. The compiled code is emitted as a sequence of abstract LISP machine cmacros. The current set of cmacros is described below. c. The third pass scans the list of cmacros for patterns, removing LOADs and STOREs, redundant JUMP's and LABEL's, compressings the stack frame, and possibly mapping temporaries stored on the stack into any of the REAL registers that would otherwise be unused. This optimized cmacro list is then passed to LAP. 18.5. First PASS of Compiler 18.5. First PASS of Compiler 18.5. First PASS of Compiler PSL Manual 7 February 1983 Compiler and Loader section 18.5 page 18.15 18.5.1. Tagging Information 18.5.1. Tagging Information 18.5.1. Tagging Information This affects many parts of the compiler. The basic idea is that all information is to be tagged. These tags fit in three categories: variable tags, location (register and frame) tags, and constant tags. Tags used for variables must be flagged 'VAR; tags for constants must be flagged 'CONST. Currently, the register tag is REG and the frame tag is FRAME. Frame locations are always positive integers. These tags are used everywhere; thus, register 1 is always described by (REG 1) in both emitted cmacros and internally in the register list REGS. Pass 1 tags all variable references with a source to source transformation of the variables (suitably obscure names must be used for these tags to prevent conflicts with named functions). The purpose behind this tagging is to make the compiler easier to work with in adding new features; new notions of registers, constants, and variables can all be accommodated through new tags. Also, the components of the cmacros are more clearly identified for pass 3. 18.5.2. Source to Source Transformations 18.5.2. Source to Source Transformations 18.5.2. Source to Source Transformations A PA1REFORMFN has been provided to augment PA1FN's. The only difference between these functions is that the PA1REFORM function is passed code which has already been through PASS1. This was previously done by calling pass 1 within a PA1FN. 18.6. Second PASS - Basic Code Generation 18.6. Second PASS - Basic Code Generation 18.6. Second PASS - Basic Code Generation 18.6.1. The Cmacros 18.6.1. The Cmacros 18.6.1. The Cmacros The compiler second pass compiles the input LISP into a series of abstract machine instructions, called cmacros. These are instructions for a LISP-oriented Register machine. ___ _______ ______ _______ The current DEC-20 cmacros Definitions of arguments reg: (REG n) n = 1,2,... MAXNARGS var: frame | (GLOBAL name) | (FLUID name) frame: (FRAME n) n = 0,1,2, .. const: (QUOTE value) | (WCONST value) label: (LABEL symbol) regn: reg | NIL | frame regf: reg | frame loc: reg | var | const Compiler and Loader 7 February 1983 PSL Manual page 18.16 section 18.6 anyreg: (CAR anyreg) | (CDR anyreg) | loc Basic Cmacros for LISP and SYSLISP (!*ALLOC nframe) (!*DEALLOC nframe) (!*ENTRY fname ftype nargs) (!*EXIT nframe) (!*FREERSTR (NONLOCALVARS f1 f2 ...)) (!*JUMP label) (!*JUMPxx label loc loc') where xx = ATOM, EQ, NOTEQ, NOTTYPE, PAIRP, TYPE (!*JUMPON lower upper (label-1 ... Label-n)) (!*LINK fname ftype nargs) (!*LINKE nframe fn type nargs) (!*LINKF nargs reg) where reg contains the function name, nargs an integer (!*LINKEF nframe nargs reg) %/ ? (!*LBL label) (!*LAMBIND (REGISTERS reg1 reg2 ...) (NONLOCALVARS f1 f2 ...)) where f1, f2, ... = (FLUID name ) No frame location will be allocated (depends on switch) (!*LOAD reg anyreg) (!*PROGBIND (NONLOCALVARS f1 f2 ...)) (!*PUSH reg) (!*RPLACA regf loc) (!*RPLACD regf loc) (!*STORE regn var) | (!*STORE regn reg) SYSLISP oriented Cmacros (!*ADDMEM loc) (!*ADJSP ?) (!*DECMEM loc) (!*INCMEM loc) (!*INTINF loc) (!*JUMPWGEQ label loc loc') (!*JUMPWGREATERP label loc loc') (!*JUMPWITHIN label loc loc') (!*JUMPWLEQ label loc loc') (!*JUMPWLESSP label loc loc') (!*MKITEM loc loc') (!*MPYMEM loc loc') (!*NEGMEM loc) (!*SUBMEM loc loc') (!*WAND loc loc') (!*WDIFFERENCE loc loc') (!*WMINUS loc) (!*WNOT loc) (!*WOR loc loc') (!*WPLUS2 loc loc') (!*WSHIFT loc loc') (!*WTIMES2 loc loc') PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.17 (!*WXOR loc loc') _____ _______ 68000 Cmacros Basic LISP and SYSLISP Cmacros (!*ALLOC nframe) (!*CALL fname) (!*DEALLOC nframe) (!*ENTRY fname ftype nargs) (!*EXIT nframe) (!*JCALL fname) (!*JUMP label) (!*JUMPEQ label loc loc') (!*JUMPINTYPE label type) (!*JUMPNOTEQ label loc loc') (!*JUMPNOTINTYPE label loc type) (!*JUMPNOTTYPE label loc type) (!*JUMPTYPE label loc type) (!*LAMBIND label loc loc') (!*LBL label) (!*LINK fname ftype nargs) (!*LINKE fname ftype nargs nframe) (!*MOVE loc loc') (!*PROGBIND label loc loc') (!*PUSH loc) SYSLISP specific Cmacros (!*APOLLOCALL label loc loc') (!*ASHIFT loc loc') (!*FIELD loc loc') (!*FOREIGNLINK loc loc') (!*INF loc loc') (!*JUMPON loc loc') (!*JUMPWGEQ loc loc') (!*JUMPWGREATERP loc loc') (!*JUMPWITHIN loc loc') (!*JUMPWLEQ loc loc') (!*JUMPWLESSP loc loc') (!*LOC loc loc') (!*MKITEM loc loc') (!*PUTFIELD loc loc') (!*PUTINF loc loc') (!*PUTTAG loc loc') (!*SIGNEDFIELD loc loc') (!*TAG loc loc') (!*WAND loc loc') (!*WDIFFERENCE loc loc') (!*WMINUS loc loc') (!*WNOT loc loc') (!*WOR loc loc') Compiler and Loader 7 February 1983 PSL Manual page 18.18 section 18.6 (!*WPLUS2 loc loc') (!*WSHIFT loc loc') (!*WTIMES2 loc loc') (!*WXOR loc loc') 18.6.2. Classes of Functions 18.6.2. Classes of Functions 18.6.2. Classes of Functions The compiler groups functions into four basic classes: a. ANYREG functions. No side effects and can be done in a single register. Passed directly to CMACROs. Viewed as a form of "extended addressing" mode. b. Specially compiled or "OPEN" functions. These are functions have a special compiling function stored under a 'COMPFN indicator. While many of these functions are specially coded, many are written with the aid of supporting patterns; these are called 'OPENFN or 'OPENTST patterns. Some OPEN functions alter registers which are in use, allocate new frames or obtain unused registers. These open functions also include open compilation of tests. c. Built-in or 'stable' functions. These functions are called in the standard fashion by the compiler, but they have properties which are useful to the compiler and are assumed to always hold. Currently, a function may be flagged as NOSIDEEFFECT and have the property DESTROYS, which contains a list of registers destroyed by the function. d. All other functions are assumed to be totally random, destroying every register and causing side effects. [??? Mark non-random functions of various levels elsewhere ???] [??? Mark non-random functions of various levels elsewhere ???] [??? Mark non-random functions of various levels elsewhere ???] The most important of these categories is the OPEN function. It is hoped that improved OPEN functions will eliminate the need for temporary registers to be allocated by the assembler. Most OPEN functions emit cmacros especially tailored for each function. 18.6.3. Open Functions 18.6.3. Open Functions 18.6.3. Open Functions [??? Explain how to CODE them ???] [??? Explain how to CODE them ???] [??? Explain how to CODE them ???] There are 3 basic kinds of open function: a. Test: the destination is a LABEL. PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.19 b. Value: the result is to be placed in a particular register. c. Effect: the result is a side effect, and no destination is needed. Note that an EFFECT open function does not have a destination. It is not really a separate class of function, just a separate usage. Example: (PROGN (SETQ X 0) ... ) - the SETQ is for effect only - could be implemented with a "clear" instruction. (FOO (SETQ X 0) ... ) - here the 0 is also placed in a register (the destination register). The use of OPENTST is also derived from context: in (COND ((EQ A B) ...)) - EQ is interpreted as a test. (RETURN (EQ A B)) , though, must have a value. It should be noted that a pseudo source-source transformation occurs if an OPENTST is called for value: (RETURN (EQ A B)) -> (RETURN (COND ((EQ A B) T) (T NIL))) An OPENTST function always returns T/NIL if called for value. No separate handling for non test cases is needed (as opposed to the effect/value cases for normal OPEN funs in which two separate expansions can be supplied) Also, there are 3 basic issues encountered in generating the code: a. Bringing arguments into registers as needed. b. Emitting the actual code. c. Updating the final register contents. Initially, the arguments to an open function are removed of all but ANYREG functions. Thus, these arguments fall into four classes: a. Registers b. Memory locations (FLUID, GLOBAL, FRAME, !*MEMORY) c. Constants d. ANYREG functions (viewed as extended addressing modes) Compiler and Loader 7 February 1983 PSL Manual page 18.20 section 18.6 Also, along with the arguments coming in is the destination (register or label). The first step is to replace some arguments by registers by emitting LOAD's. This step can be controlled by a function, called the adjust function, which emits LOAD's and replaces the corresponding arguments by registers. Next, cmacros are emitted. These cmacros are selected through a pattern which defines the format of the particular OPEN function call. Note that the pattern is matching the locations of the arguments to the open function. For example, assume that FOO is OPEN, and the call (FOO 'A (CDR B) C D) is encountered. Assume also that B is frame 1, C is frame 2, and D was found in reg 1. The argument list being matched is thus ('A (CDR (FRAME 1)) (FRAME 2) (REG 1)) For most purposes, this would be interpreted as (const anyreg mem reg). Of course, a pattern can use the value of a constant (you might recognize (!*WPLUS2 1 X) as an increment). Also, the actual register may be important for register args, especially if one of the args is also the destination. You would probably emit different code for (REG 1) := (!*WPLUS2 (REG 2) (REG 3)) than (REG 1) := (!*WPLUS2 (REG 1) (REG 2)) To avoid a profusion of properties which would be associated with an OPEN function, two properties of the function name are used to hold all information associated with OPEN compiling. These properties are OPENFN and OPENTST. The OPENFN and OPENTST properties have the following format: (PATTERN MACRONAME PARAMETERS) or function name. The PATTERN field contains either the pattern itself or a pattern name. __ A pattern name is an id having the PATTERN property. In the following material, DEST refers to the destination label in an OPENTST and to the destination register in an OPENFN. If the function is being evaluated for effect only, DEST is a temporary register which need not be used. A pattern has the following format: PSL Manual 7 February 1983 Compiler and Loader section 18.6 page 18.21 (ADJUST_FN REG_FN (P1 M11 M12 M13 ..) (P2 M21 M22 M23 ..) ...) The Pi are patterns and Mij are cmacros or pseudo cmacros. ADJUST_FN is a register adjustment function used to place things in registers as required, and to factor out basic properties of the function from the pattern. For example, you almost never could do anything with ANYREG stuff except load it somewhere (emitting (!*WPLUS2 X (CDR (CAR Y))) directly probably won't work - you must bring (CDR (CAR Y)) into a reg before further progress can be made). The most common adjust function is NOANYREG, which replaces ANYREG stuff with registers. This eliminates the problem of having to test for ANYREG stuff in the patterns. Some pattern elements currently supported are: ANY matches anything DEST matches the destination register or label NOTDEST matches any register except the destination REG matches any register REGN Any register or 'NIL or a frame location VAR A LOCAL, GLOBAL, or FLUID variable MEM A memory address, currently constants + vars (NOT REGS) ANYREGFN matches an ANYREG function 'literal matches the literal (p1 p2 ... pn) matches a field whose components match p1 ... pn NOVAL matches only if STATUS > 1; must be the first component of a pattern, consumes no part of the subject. The cmacros associated with the patterns fall into two classes: actual cmacros to be emitted and pseudo cmacros which are interpreted by the compiler. In either case, the components of the cmacros are handled in the same fashion. The cmacros contain: Ai replaced by the ith argument to the OPEN function (after adjustment) Ti replaced by a temporary register Li replaced by a temporary label Pi replaced by corresponding parameter from OPENFN DEST replaced by the destination register or label (depending on OPENFN or OPENTST). FN replaced by the name of the OPEN function MAC synonym for P1, by convention a cmacro name 'literal (x1 x2 ... ) xi as above, forms a list Compiler and Loader 7 February 1983 PSL Manual page 18.22 section 18.6 The pseudo cmacros currently supported are: !*DESTROY !*DESTROY __ __ ____ ______ (!*DESTROY R1, R2, ...): list cmacro __ __ Remove any register values from R1 ... RN. !*DO !*DO ________ ____ ____ ____ ______ (!*DO FUNCTION ARG1 ARG2 ...): list cmacro ________ Call the FUNCTION. !*SET !*SET ___ ___ ____ ______ (!*SET REG VAL): list cmacro ___ ___ Set the value in REG to VAL. The cmacros which are known to the compiler are !*LOAD !*LOAD ____ ______ (!*LOAD ): list cmacro !*STORE !*STORE ____ ______ (!*STORE ): list cmacro !*JUMP !*JUMP ____ ______ (!*JUMP ): list cmacro !*LBL !*LBL ____ ______ (!*LBL ): list cmacro These cmacros have special emit functions which are called as they are emitted; otherwise the cmacro is directly attached to CODELIST. 18.7. Third PASS - Optimizations 18.7. Third PASS - Optimizations 18.7. Third PASS - Optimizations The third pass of the compiler is responsible for doing optimizations, getting rid of extra labels and jumps, removing redundant code, adjusting the stack frame to squeeze out "holes" or even reallocating temporaries to excess registers if no "random" functions are called by this function. This pass also does "peephole" optimizations (controlled by patterns that examine the Output CMACRO list for cmacros that can be merged). These tables can be adjusted by the user. This pass also gathers information on register usage that may be accumulated to aid block compilation or recompilation of a set of functions that are NOT redefined, and so can use information about each other (i.e. become "stable"). The 'OPTFN property is used to associate an optimization function with a particular CMACRO name. This function looks at the CMACRO arguments and PSL Manual 7 February 1983 Compiler and Loader section 18.7 page 18.23 some subsequent CMACROs in the code-list, to see if a transformation is possible. The OPTFN takes a single argument, the code-list in reverse order starting at the associated CMACRO. The OPTFN can also examine certain parameters. Currently !*LBL, !*MOVE and !*JUMP have 'OPTFNS. For example, !&STOPT, associated with !*MOVE, checks if previous CMACRO was !*ALLOC, and that this !*MOVE moves a register to the slot just allocated. If so, it converts the !*ALLOC and !*MOVE into a single !*PUSH. Likewise, !&LBLOPT removes duplicate labels defined at one place, aliasing one with the other, and so permitting certain JUMP optimizations to take place. Tags in the cmacros are processed in a final pass through the code. At this time the compiler can do substitutions using functions attached to these tags. Currently, (!*FRAMESIZE) is converted to the frame size and holes are squeezed out (using the FRAME tag) by !&REFORMMACROS. Transformation functions are attached to tags (or any function) through the TRANFN property currently. 18.8. Some Structural Notes on the Compiler 18.8. Some Structural Notes on the Compiler 18.8. Some Structural Notes on the Compiler [??? This Section is very ROUGH, just to give some additional [??? This Section is very ROUGH, just to give some additional [??? This Section is very ROUGH, just to give some additional information in interim ???] information in interim ???] information in interim ???] External variables and properties used by the compiler: _________ ___ ________ Variables and Switches __________ ______ !*ERFG [Initially: ] switch __________ ______ !*INSTALLDESTROY [Initially: NIL] switch If true, causes the compiler to install the DESTROYS property on any function compiled which leaves one or more registers unchanged __________ ______ !*INT [Initially: T] switch __________ ______ !*NOFRAMEFLUID [Initially: T] switch If true, inhibits allocation of frame locations for FLUIDS __________ ______ !*SHOWDEST [Initially: NIL] switch If true, compiler prints out which registers a function destroys unless all are destroyed Compiler and Loader 7 February 1983 PSL Manual page 18.24 section 18.8 __________ ______ !*SYSLISP [Initially: NIL] switch Switch compilation mode from default of LISP to SYSLISP. This affects constant tagging, and in RLISP also causes LISP functions to be replaced by SYSLISP equivalents. Also, non-locals default to WVAR's rather than FLUIDs. See Chapter 20. __________ ______ !*UNSAFEBINDER [Initially: NIL] switch for Don's BAKER problem...GC may be called in Binder, so regs cannot be preserved, and Binder called as regular function. __________ ______ !*USEREGFLUID [Initially: NIL] switch If true, LAMBIND and PROGBIND cmacros may contain registers as well as frame locations (through FIXFRM). _______ Globals: __________ ______ LASTACTUALREG [Initially: 5] global The number of the last real register; FIXFRM does not map stack locations into registers > LASTACTUALREG. Also, temporary registers are actual registers if possible. __________ ______ MAXNARGS [Initially: 15] global Number of registers __________ ___ _____ Properties and Flags: CONST A tag property, indicates tags for constants (WCONST and QUOTE) EXTVAR A tag property, indicates a variable type whose name is externally known (!$FLUID, !$GLOBAL, !$WVAR) MEMMOD A cmacro property, indicates in place memory operations. The first argument to the cmacro is assumed to be the memory location (var or !*MEMORY) NOSIDEEFFECT A function property, used both in dealing with !*ORD and to determine if the result should be placed in register status REG A tag property, indicates a register (REG) TERMINAL A tag property, indicates terminals (leaves) whose arguments are not tagged items (!$FLUID !$GLOBAL !$WVAR REG LABEL QUOTE WCONST FRAME !*FRAMESIZE IREG) TRANSFER A property of cmacros and functions, indicates cmacros & functions which cause unconditional transfers (!*JUMP !*EXIT !*LINKE !*LINKEF ERROR) PSL Manual 7 February 1983 Compiler and Loader section 18.8 page 18.25 VAR A tag property, indicates a variable type (!$LOCAL !$FLUID !$GLOBAL !$WVAR) __________ Properties: ANYREG A function property, non-NIL indicates an ANYREG function CFNTYPE Used in compiler to relate to Recursion-to-iteration conversion. DESTROYS A function property, contains a (tagged) list of registers destroyed by the function DOFN A function property, contains the name of a compile time evaluation function for numeric arguments. EMITFN A cmacro or pseudo cmacro property, contains the name of a special function for emitting (or executing) the cmacro, such as !&ATTJMP for !*JUMP. EXITING A cmacro property, used in FIXLINKS. Contains the name of an associated exiting cmacro (!*LINK : !*LINKE, !*LINKF : !*LINKEF) FLIPTST A function property, contains the name of the opposite of a test function. All open compiled test functions must have one. (EQ : NOTEQ, ATOM : PAIRP) GROUPOPS A function property, used in constant folding. Attached to the three functions of a group, always a list of the three functions in the order +, -, MINUS. (!*WPLUS2, !*WDIFFERENCE, !*WMINUS : (!*WPLUS2 !*WDIFFERENCE !*WMINUS)) MATCHFN A property attached to an atom in a pattern. Contains the name of a boolean function for use in pattern matching. NEGJMP A cmacro property, contains the inverted test jump cmacro name. (!*JUMPEQ : !*JUMPNOTEQ, !*JUMPNOTEQ : !*JUMPEQ ...) ONE A function property, contains the (numeric) value of an identity associated with the function (!*WPLUS2 : 0, !*WTIMES2 : 1, ...) PATTERN A property associated with atoms appearing in OPENFN or OPENTST properties, contains a pattern for open coding of functions. SUBSTFN A property of atoms found in cmacros which are inside patterns. Contains a function name; the function value is substituted into the cmacro as emitted. ZERO Like ONE, designates a value which acts as a 0 in a ring over *. (!*WTIMES2 : 0 , !*LOGAND : 0) |
Added psl-1983/lpt/19-dec20.lpt version [19a3ed3bd3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 System Interface section 19.0 page 19.1 CHAPTER 19 CHAPTER 19 CHAPTER 19 OPERATING SYSTEM INTERFACE OPERATING SYSTEM INTERFACE OPERATING SYSTEM INTERFACE 19.1. Introduction . . . . . . . . . . . . . . . 19.1 19.2. System Dependent Functions . . . . . . . . . . 19.2 19.3. TOPS-20 Interface . . . . . . . . . . . . . 19.2 19.3.1. User Level Interface . . . . . . . . . . 19.2 19.3.2. The Basic Fork Manipulation Functions . . . . 19.5 19.3.3. File Manipulation Functions. . . . . . . . 19.6 19.3.4. Miscellaneous Functions . . . . . . . . . 19.7 19.3.5. Jsys Interface . . . . . . . . . . . . 19.8 19.3.6. Bit, Word and Address Operations for Jsys Calls . 19.10 19.3.7. Examples . . . . . . . . . . . . . . 19.12 19.4. New Vax Specific Interface . . . . . . . . . . 19.13 19.4.1. Setting Your .LOGIN and .CSHRC files. . . . . 19.13 19.4.2. Important PSL executables . . . . . . . . 19.14 19.4.3. Creating the Init Files . . . . . . . . . 19.14 19.4.4. Directories and Symbols . . . . . . . . 19.15 19.4.5. Miscellaneous Unix Interface Functions . . . 19.18 19.4.6. Oload . . . . . . . . . . . . . . 19.18 19.4.7. Calling oloaded functions . . . . . . . . 19.20 19.4.8. OLOAD Internals. . . . . . . . . . . . 19.21 19.4.9. I/O Control functions . . . . . . . . . 19.24 19.1. Introduction 19.1. Introduction 19.1. Introduction From within each PSL implementation, there will be a set of functions that permit the user to access specific operating system services. On the DEC-20 and VAX these include the ability to submit commands to be run in a "lower fork", such as starting an editor, submitting a system print command, listing directories, and so on. We will attempt to provide such EXEC CMDS EXEC CMDS calls (EXEC and CMDS) in all PSL implementations. We also will provide as clean an interface to Low-level services as possible. On the DEC-20, this Jsys Jsys is the Jsys function. Appropriate support functions (such as bit operations, byte-pointers, etc.) are also used by the assembler. On the SYSCALL SYSCALL VAX we will provide the SYSCALL capability. 19.2. System Dependent Functions 19.2. System Dependent Functions 19.2. System Dependent Functions If_System If_System ___ ____ __ ____ ____ ___ _____ ____ ___ ___ ______ (If_System SYS-NAME:id, TRUE-CASE:any, FALSE-CASE:any): any cmacro This is a compile-time conditional macro for system-dependent _____ ____ ___ ____ code. FALSE-CASE can be omitted and defaults to NIL. SYS-NAME System Interface 7 February 1983 PSL Manual page 19.2 section 19.2 must be a member of the fluid variable System_List!*. For the Dec-20, System_List!* is (Dec20 PDP10 Tops20 KL10). For the VAX it is (VAX Unix VMUnix). An example of its use follows. PROCEDURE MAIL(); IF_SYSTEM(TOPS20, RUNFORK "SYS:MM.EXE", IF_SYSTEM(UNIX, SYSTEM "/BIN/MAIL", STDERROR "MAIL COMMAND NOT IMPLEMENTED")); 19.3. TOPS-20 Interface 19.3. TOPS-20 Interface 19.3. TOPS-20 Interface 19.3.1. User Level Interface 19.3.1. User Level Interface 19.3.1. User Level Interface DoCmds DoCmds The basic function of interest is DoCmds, which takes a list of strings as arguments, concatenates them together, starts a lower fork, and submits this string (via the Rescan buffer). The string should include appropriate <CR><LF>, "POP" etc. A global variable, CRLF, is provided with the <CR><LF> string. Some additional entry points, and common calls have been defined to simplify the task of submitting these commands. DoCmds DoCmds _ ______ ____ ___ ____ (DoCmds L:string-list): any expr Concatenate strings into a single string (using ConcatS), place into the rescan buffer using PutRescan, and then run a lower EXEC, trying to use an existing Exec fork if possible. __________ ______ CRLF [Initially: "<cr><lf>"] global This variable is "CR-LF", to be appended to or inserted in Command strings for fnc(DoCmds). It is STRING(Char CR,Char LF). ConcatS ConcatS _ ______ ____ ______ ____ (ConcatS L:string-list): string expr Concatenate string-list into a single string, ending with CRLF. [??? Probably ConcatS should be in STRING, we add final CRLF in PutRescan ???] Cmds Cmds _ ______ ___ _____ (Cmds [L:string]): any fexpr Submit a set of commands to lower EXEC E.g. CMDS("VDIR *.RED ", CRLF, "DEL *.LPT", CRLF, "POP");. The following useful commands are defined: PSL Manual 7 February 1983 System Interface section 19.3 page 19.3 VDir VDir _ ______ ___ ____ (VDir L:string): any expr Display a directory and return to PSL, e.g. (VDIR "R.*"). Defined as DoCmds LIST("VDIR ",L,CRLF,"POP"); HelpDir HelpDir ___ ____ (HelpDir ): any expr Display PSL help directory. Defined as DoCmds LIST("DIR PH:*.HLP",CRLF,"POP"). Sys Sys _ ______ ___ ____ (Sys L:string): any expr Defined as DoCmds LIST("SYS ", L, CRLF, "POP"); Take Take _ ____ ___ ____ (Take L:list): any expr Defined as DoCmds LIST("Take ",FileName,CRLF,"POP"); Type Type _ ______ ___ ____ (Type L:string): any expr Type out files. Defined as DoCmds LIST("TYPE ",L,CRLF,"POP"); While definable in terms of the above DoCmds via a string, more direct execution of files and fork manipulation is provided by the following functions. Recall that file names are simply Strings, e.g. "<psl>foo.exe", and that ForkHandles are allocated by TOPS-20 as large integers. Run Run ________ ______ ___ ____ (Run FILENAME:string): any expr Create a fork, into which file name will be loaded, then run it, waiting for completion. Finally Kill the fork. Exec Exec ___ ____ (Exec ): any expr Continue a lower EXEC, return with POP. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable ExecFork. Emacs Emacs ___ ____ (Emacs ): any expr Continue a lower EMACS fork. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable EmacsFork. [??? Figure out how to pass a buffer to from Emacs ???] System Interface 7 February 1983 PSL Manual page 19.4 section 19.3 MM MM ___ ____ (MM ): any expr Continue a lower MM fork. The Fork will be created the first time this is run, and the ForkHandle preserved in the global variable MMFork. [??? MM looks in the rescan buffer for commands, so fairly [??? MM looks in the rescan buffer for commands, so fairly [??? MM looks in the rescan buffer for commands, so fairly useful mailers (e.g. for BUG reports) can be created. useful mailers (e.g. for BUG reports) can be created. useful mailers (e.g. for BUG reports) can be created. Perhaps make MM(s:string) for this purpose. ???] Perhaps make MM(s:string) for this purpose. ???] Perhaps make MM(s:string) for this purpose. ???] Reset Reset ____ ________ ____ (Reset ): None Returned expr This function causes the system to be restarted. 19.3.2. The Basic Fork Manipulation Functions 19.3.2. The Basic Fork Manipulation Functions 19.3.2. The Basic Fork Manipulation Functions GetFork GetFork ___ _______ _______ ____ (GetFork JFN:integer): integer expr Create a fork handle for a file; a GET on the file is done. StartFork StartFork __ _______ ____ ________ ____ (StartFork FH:integer): None Returned expr Start a fork running, don't wait, do something else. Can also be used to Restart a fork, after a WaitFork. WaitFork WaitFork __ _______ _______ ____ (WaitFork FH:integer): Unknown expr Wait for a running fork to terminate. RunFork RunFork __ _______ _______ ____ (RunFork FH:integer): Unknown expr Start and Wait for a FORK to terminate. KillFork KillFork __ _______ _______ ____ (KillFork FH:integer): Unknown expr Kill a fork (may not be restarted). OpenFork OpenFork ________ ______ _______ ____ (OpenFork FILENAME:string): integer expr Get a file into a Fork, ready to be run. PSL Manual 7 February 1983 System Interface section 19.3 page 19.5 PutRescan PutRescan _ ______ _______ ____ (PutRescan S:string): Unknown expr Copy a string into the rescan buffer, and announce to system, so that next PBIN will get this characters. Used to pass command strings to lower forks. GetRescan GetRescan ___ ______ ____ (GetRescan ): {NIL,string} expr See if there is a string in the rescan buffer. If not, Return NIL, else extract that string and return it. This is useful for getting command line arguments in PSL, if MAIN() is rewritten by the user. This will also include the program name, under which this is called. 19.3.3. File Manipulation Functions 19.3.3. File Manipulation Functions 19.3.3. File Manipulation Functions These mostly return a JFN, as a small integer. GetOldJfn GetOldJfn ________ ______ _______ ____ (GetOldJfn FILENAME:string): integer expr Get a Jfn on an existing file. GetNewJfn GetNewJfn ________ ______ _______ ____ (GetNewJfn FILENAME:string): integer expr Get a Jfn for an new (non-existing) file. RelJfn RelJfn ___ _______ _______ ____ (RelJfn JFN:integer): integer expr Return Jfn to TOPS-20 for re-use. FileP FileP ________ ______ _______ ____ (FileP FILENAME:string): boolean expr Check if FILENAME is existing file; this is a more efficient method than the kernel version that uses ErrorSet. OpenOldJfn OpenOldJfn ___ _______ _______ ____ (OpenOldJfn JFN:integer): integer expr Open file on Jfn to READ 7-bit bytes. OpenNewJfn OpenNewJfn ___ _______ _______ ____ (OpenNewJfn JFN:integer): Unknown expr Open file on Jfn to write 7 bit bytes. System Interface 7 February 1983 PSL Manual page 19.6 section 19.3 GtJfn GtJfn ________ ______ ____ _______ _______ ____ (GtJfn FILENAME:string,BITS:integer): integer expr Get a Jfn for a file, with standard Tops-20 Access bits set. NameFromJfn NameFromJfn ___ _______ ______ ____ (NameFromJfn JFN:integer): string expr Find the name of the File attached to the Jfn. 19.3.4. Miscellaneous Functions 19.3.4. Miscellaneous Functions 19.3.4. Miscellaneous Functions GetUName GetUName ______ ____ (GetUName ): string expr Get USER name as a string GetCDir GetCDir ______ ____ (GetCDir ): string expr Get Connected DIRECTORY InFile InFile ____ __ ____ _______ _____ (InFile [FILS:id-list]): Unknown fexpr Either solicit user for file name (InFile), and then open that file, else open specified file, for input. 19.3.5. Jsys Interface 19.3.5. Jsys Interface 19.3.5. Jsys Interface Jsys Jsys The Jsys interface and jsys-names (as symbols of the form jsXXX) are defined in the source file PU:JSYS0.RED. The access to the Jsys call is modeled after IDapply to avoid CONS, register reloads. These could easily be done Open coded The following SYSLISP calls, XJsys'n', expect W-values in the registers, R1...R4, a W-value for the Jsys number, Jnum and the contents of the 'nth' register. Unused registers should be given 0. Any errors detected will JsysError JsysError result in the JsysError being called, which will use the system ErStr JSYS StdError StdError to find the error string, and issue a StdError. XJsys0 XJsys0 __ _ _______ __ _ _______ __ _ _______ (XJsys0 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr Used if no result register is needed. PSL Manual 7 February 1983 System Interface section 19.3 page 19.7 XJsys1 XJsys1 __ _ _______ __ _ _______ __ _ _______ (XJsys1 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys2 XJsys2 __ _ _______ __ _ _______ __ _ _______ (XJsys2 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys3 XJsys3 __ _ _______ __ _ _______ __ _ _______ (XJsys3 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr XJsys4 XJsys4 __ _ _______ __ _ _______ __ _ _______ (XJsys4 R1:s-integer, R2:s-integer, R3:s-integer, __ _ _______ ____ _ _______ _ _______ ____ R4:s-integer, Jnum:s-integer): s-integer expr The following functions are the LISP level calls, and expect integers or strings for the arguments, which are converted into s-integers by the JConv JConv function JConv, below. We will use JS to indicate the argument type. The _______ result returned is an integer, which should be converted to appropriate type by the user, depending on the nature of the Jsys. See the examples below for clarification. Jsys0 Jsys0 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys0 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Used is no result register is needed. Jsys1 Jsys1 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys1 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys2 Jsys2 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys2 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys3 Jsys3 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys3 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr Jsys4 Jsys4 __ __ __ __ __ __ __ __ ____ _ _______ _______ ____ (Jsys4 R1:JS, R2:JS, R3:JS, R4:JS, Jnum:s-integer): integer expr JConv JConv The JConv converts the argument type, JS, to an appropriate s-integer, representing either an integer, or string pointer, or address. JConv JConv _ _______ ______ _ _______ ____ (JConv J:{integer,string}): s-integer expr _______ An integer J is directly converted to a s-integer, by Int2Sys(J). ______ A string J is converted to a byte pointer by the call Lor(8#10700000000,Strinf(J)). Otherwise a StdError, "'J' not known in Jconv" is produced. Additional convertions of interest may be performed by the functions Int2Sys Sys2Int Int2Sys Sys2Int Int2Sys, Sys2Int, and the following functions: System Interface 7 February 1983 PSL Manual page 19.8 section 19.3 Str2Int Str2Int _ ______ _______ ____ (Str2Int S:string): integer expr Returns the physical address of the string start as an integer; this can CHANGE if a GC takes place, so should be done just before calling the jsys. Int2Str Int2Str _ _______ ______ ____ (Int2Str J:integer): string expr J is assumed to be the address of a string, and a legal, tagged string is created. 19.3.6. Bit, Word and Address Operations for Jsys Calls 19.3.6. Bit, Word and Address Operations for Jsys Calls 19.3.6. Bit, Word and Address Operations for Jsys Calls RecopyStringToNULL RecopyStringToNULL _ _ ______ ______ ____ (RecopyStringToNULL S:w-string): string expr S is assumed to be the address of a string, and a legal, tagged string is created, by searching for the terminating NULL, allocating a HEAP string, and copying the characters into it. This is used to ensure that addresses not in the LISP heap are not passed around "cavalierly" (although PSL is designed to permit this quite safely). Swap Swap _ _______ _______ ____ (Swap X:integer): integer expr Swap half words of X; actually Xword(LowHalfWord X,HighHalfWord X). LowHalfWord LowHalfWord _ _______ _______ ____ (LowHalfWord X:integer): integer expr Return the low-half word of the machine representation of X. Actually Land(X,8#777777). HighHalfWord HighHalfWord _ _______ _______ ____ (HighHalfWord X:integer): integer expr Return the Upper half word as a small integer, of the machine word representation of X. Actually Lsh(Land(X,8#777777000000),-18). Xword Xword _ _______ _ _______ _______ ____ (Xword X:integer,Y:integer): integer expr Build a Word from Half-Words, actually Lor(Lsh(LowHalfWord(X),18),LowHalfWord Y). PSL Manual 7 February 1983 System Interface section 19.3 page 19.9 JBits JBits _ ____ _______ ____ (JBits L:list): integer expr Construct a word-image by OR'ing together selected bits or byte-fields. L is list of integers or integer pairs. A single integer in the range 0...35, BitPos, represents a single bit to be turned on. A pair of integers, (FieldValue . RightBitPos), causes the integer FieldValue to be shifted so its least significant bit (LSB) will fall in the position, RightBitPos. This value is then OR'ed into the result. Recall that on the DEC-20, the most significant bit (MSB), is bit 0 and that the LSB is bit 35. Bits Bits _ ____ _______ _____ (Bits L:list): integer macro A convenient access to Jbits: JBits cdr L. 19.3.7. Examples 19.3.7. Examples 19.3.7. Examples The following range of examples illustrate the use of the above functions. More examples can be found in PU:exec0.red. Jsys1 Jsys1 Jsys1(0,0,0,0,jsPBIN); % Reads a character, returns the ASCII code. Jsys0 Jsys0 Jsys0(ch,0,0,0,jsPBOUT); % Takes ch as Ascii code, and prints it out. Procedure OPENOLDJfn Jfn; %. OPEN to READ JSYS0(Jfn,Bits( (7 . 5),19),0,0,jsOPENF); Lisp procedure GetFork Jfn; %. Create Fork, READ File on Jfn Begin scalar FH; FH := JSYS1(Bits(1),0,0,0,jsCFork); JSYS0(Xword(FH ,Jfn),0,0,0,jsGet); return FH END; Procedure GetOLDJfn FileName; %. test If file OLD and return Jfn Begin scalar Jfn; If NULL StringP FileName then return NIL; Jfn := JSYS1(Bits(2,3,17),FileName,0,0,jsGTJfn); % OLD!MSG!SHORT If Jfn<0 then return NIL; return Jfn END; Procedure GetUNAME; %. USER name Begin Scalar S; System Interface 7 February 1983 PSL Manual page 19.10 section 19.3 S:=Mkstring 80; % Allocate a 80 char buffer JSYS0(s,JSYS1(0,0,0,0,jsGJINF),0,0,jsDIRST); Return RecopyStringToNULL S; % Since a NULL may be appear before end End; Procedure ReadTTY; Begin Scalar S; S:=MkString(30); % Allocate a String Buffer Jsys0 Jsys0 Jsys0(S,BITS(10,(30 . 35),"Retype it!",0,jsRDTTY); % Sets a length halt (Bit 10), % and length 30 (field at 35) in R2 % Gives a Prompt string in R3 % The input is RAISE'd to upper case. % The Prompt will be typed if <Ctrl-R> is input Return RecopyStringToNULL S; % Since S will now possibly have a shorter % string returned end; 19.4. New Vax Specific Interface 19.4. New Vax Specific Interface 19.4. New Vax Specific Interface Most of this information depends on the use of the Berkeley c-shell (csh) and will need modification (or might not work) if the Bourne shell (sh) is your command shell of choice. Extensive use is made of csh variables to 1 describe path-names to the various PSL subdirectories. 19.4.1. Setting Your .LOGIN and .CSHRC files 19.4.1. Setting Your .LOGIN and .CSHRC files 19.4.1. Setting Your .LOGIN and .CSHRC files During installation of PSL, a file "psl-names" defining these path-names will have been edited and tested by the installer. The message announcing the location of PSL on your system should indicate where this file is. It is often placed on "~psl" or "~psl/dist". It is absolutely essential that you place the line source ~psl/psl-names in your .login and .cshrc files. If you do not have either of these, they _______________ 1 This section was contributed by Russ Fish. The source for most of the functions mentioned is "$pv/system-extras.red". PSL Manual 7 February 1983 System Interface section 19.4 page 19.11 should be created. After execution of this statement, a set of "$ variables" will be available to refer to files of interest in the PSL system from the c-shell, from editors, and from within PSL. You may have to add another directory to the search path of your shell, in the definition of path in your .login file, which gives the location of the PSL executable files. This should be done after the line "source ~psl/psl-names", and is a line of the form set path=(. $psys /bin /usr/bin) $psys is the c-cshell variable defined in psl-names to point at the psl "executables". 19.4.2. Important PSL executables 19.4.2. Important PSL executables 19.4.2. Important PSL executables "psl" is the PSL executable with a LISP syntax toploop. "rlisp" runs an RLISP (Algol-like) toploop syntax. At some installations, "bare-psl" and "pslcomp" also exist, particularly if "psl" has had many modules preloaded for local customization. There are also a set of c-shell scripts that can be run as if they were exectable programs. These include a "build" utility to recompile utility modules, "oload" to permit dynamic loading of non-LISP code into PSL, and "cmds.csh" to define some useful PSL related aliases. 19.4.3. Creating the Init Files 19.4.3. Creating the Init Files 19.4.3. Creating the Init Files On startup PSL, RLISP, and PSLCOMP look for LISP syntax init files on your home (login) directory, respectively named ".pslrc", ".rlisprc" and ".pslcomprc", which are executed in the PSL before it prompts for user SaveSystem SaveSystem input. Other PSL based programs that are saved by SaveSystem can also be made to look for .xxxrc files of their own. These files typically contain code to load modules of interest, set various switches, such as !*BREAK, etc. 19.4.4. Directories and Symbols 19.4.4. Directories and Symbols 19.4.4. Directories and Symbols The specific locations of subtrees of PSL files is left up to the installer, to reflect the conventions of local usage and file system layout. This section discusses the use of c-shell variables ($ variables) for system-invariant navigation. To use these, the lines source ~psl/psl-names source $pvsup/cmds.csh System Interface 7 February 1983 PSL Manual page 19.12 section 19.4 source lisp-psl-names should be placed in your login.cmd file The root of the PSL distribution tree is (usually) located in the home directory of a pseudo-user named "psl", and hence may be accessed as "~psl/dist". During installation, links in ~psl are often also made to startup files in the vax support directory, "$pvsup". (These should be SYMBOLIC links in Berkeley 4.1a VmUnix and above.) Note - the c-shell expands "~user" and "$variable" in filenames. The current version of PSL 3.1 will also permit these constructions in filenames, though in a somewhat limited form. Future PSL releases will integrate this more fully. Currently, a file of psl-names in LISP systax is generated by the "source lisp-psl-names", and it must be read into PSL, etc via the .xxxrc files. File "~psl/psl-names" defines c-shell symbols for the whole hierarchy of distributed PSL directories. File $pvsup/cmds.csh contains c-shell commands useful in conjunction with PSL. As of this writing, there are only two commands (c-shell alias) defined there: a. "lisp-psl-names". When run from the .login file, it creates a file "psl-names.sl" on your home directory. This file contains a series of PUT statements to associate the full Unix path names with ids that have the same name as the C-shell aliases created by various set commands in your .login. Each entry has the form (PUT (quote ID) (quote pslname) "pathname") It is suggested that the line lisp-psl-names be placed at the end of your .login if you wish to use this feature. The file "psl-names.sl" should then be read into the various PSL, RLISP, etc by placing a line (load vax!-path) into your .pslrc, .rlisprc, etc. This loads the VAX-PATH module, and reads the file "psl-names.sl" which was created by the PSL Manual 7 February 1983 System Interface section 19.4 page 19.13 "lisp-psl-names" command on your "home" directory, which can also be loaded to give a procedure PATH that builds files names using a "$ID/.." syntax, and also a modified OPEN. b. "lisp-csh-vars". An older form of lisp-psl-names.It returns LISP syntax assignments for all of the directory variables defined in the c-shell in which it is executed. Its output may be directly put into files ".pslrc" and ".rlisprc" in your home directory by placing this command in your .login file: lisp-csh-vars | tee .pslrc .rlisprc > after which any directory variables set in your c-shell startup will be known in your PSL as arguments for "cd". There are innumerable variations on this, of course. cd cd ___ ______ _______ ____ (cd DIR:string): boolean expr Like the shell "cd" command, sets the current directory (".") of cd cd the running PSL. Unless cd is executed, the current directory __ ___ will remain the same as the current directory of the shell at the ____ ___ ___ ___ _______ time the PSL was started. (Unix filenames are paths relative to Cd Cd the current directory unless they begin with a slash.) Cd returns T if it successfully found the directory given in the argument as a path, NIL otherwise. pwd pwd ______ ____ (pwd ): string expr Like the "pwd" unix command, meaning "print working directory". Returns the current directory of the PSL as a string, terminated with a slash so filenames may be direcly "concat"ed to it. The cd cd trailing slash is ignored by cd. path path _ ______ ______ ____ (path S:string): string expr Examines the argument string; if it starts with $, extracts the next string up to the / (if any), converts it to (an upper-case) __ id. Then an associated string is looked for under the indicator 'pslnames. If an associated string is not found, an Error is _ generated. If S does not start with $, it is returned unchanged. Thus CD PATH "$PU"; will work. When VAX-PATH is loaded, OPEN is redefined to apply PATH to the file-name. Thus OPEN, IN, DSKIN, OUT, FILEP and and LAPIN can use $vars in file names without calling PATH explicitly. LOAD-PATH also reads the "psl-names.sl" files from the user's System Interface 7 February 1983 PSL Manual page 19.14 section 19.4 home-directory. 19.4.5. Miscellaneous Unix Interface Functions 19.4.5. Miscellaneous Unix Interface Functions 19.4.5. Miscellaneous Unix Interface Functions ExitLisp ExitLisp _________ ____ (ExitLisp ): undefined expr Since "quit" uses the Berkeley job-control facility to the PSL (like a ^Z at the keyboard), a separate function is needed when ExitLisp ExitLisp you really want the PSL to terminate. ExitLisp does it. (A "^\" from the keyboard has the same effect, assuming you have your core-dump limit set low.) GetEnv GetEnv __________ ______ ______ ____ (GetEnv ENVVARNAME:string): string expr Returns value of the specified Unix environment variable as a string, or NIL if the argument is not a string or the environment variable is not set. System System _______ ______ _________ ____ (System UNIXCMD:string): undefined expr Starts up a sub-shell and passes the Unix command to it via the Unix "system" command. The working directory of the command will be the same as the PSL. 19.4.6. Oload 19.4.6. Oload 19.4.6. Oload oload( LdSpec:String ) c-shell-script ---------------------- -------------- Oload is a means of linking Unix .o and .a files into a running Vax PSL. It was developed to get access to existing C code driver libraries for graphics devices, but should work for any Unix compiled code with C calling conventions. The single argument to the oload function is a string containing arguments to the Unix "ld" loader, separated by blanks. File names ending in ".o" are compiled relocatable code files. ".a" files are "ar" load libraries, which are assumed to contain a set of ".o" files, all of which are to be loaded. Other loader arguments should follow, specifying whatever libraries are necessary to satisfy all external references from the ".o" and ".a" files mentioned. Library specs are in the form "-lfoo" to search the "libfoo.a" library on /lib, /usr/lib, or /usr/local/lib, e.g. "-lc" for the C library. PSL Manual 7 February 1983 System Interface section 19.4 page 19.15 This is an "incremental" (-A flag) load. Symbols which are already known in the running PSL will be linked to the existing addresses. If the load string argument is NIL, an attempt is made to re-oload from an existing .oload.out file. This can only be done if the BPS and WARRAY base addresses are EXACTLY the same as they were on the previously done, full oload. An error message results if the BPS locations are different. This is meant to facilitate rapidly repeating an oload at startup time. Alternately, a customized version of PSL may be saved by the function SaveSystem SaveSystem SaveSystem, after first performing oloads and loading or compiling in PSL code including functions which interface to the oloaded code. Oload returns a status code of T if it succeded, or NIL if not. 19.4.7. Calling oloaded functions 19.4.7. Calling oloaded functions 19.4.7. Calling oloaded functions All entry points and global data objects in ".o" and ".a" files mentioned are made known to the PSL system. C functions may be called from compiled code ONLY, and are flagged 'ForeignFunction by oload. Data areas are flagged 'ForeignData, with a property containing a pair of the data location and size in bytes for use by SYSLISP interface code. Currently, foreign function calls may not be compiled into Fasl files, so Compile Compile the compilation must be done incrementally, via "on Comp" or Compile. C C The names of oloaded C functions within PSL are the "true" names, which have an underscore ("_") prefixed to the C name. This makes it easy to make a compiled "pass through" interface function which gives the same name within PSL as the C names. e.g. "procedure foo(); _foo();" Functions which take integer arguments can be called directly, due to the invisible tagging of integers up to +-2^^27 in Vax PSL. Similarly, integer return values will be passed back from the C functions. String or structured arguments will require a bit of conversion code in the interface functions, using SYSLISP functions to remove tags on arguments and add them ImportForeignString ImportForeignString to return values. The function ImportForeignString constructs a LISP string, given a C string (char *). Warning: currently, foreign function calls may have no more than 5 arguments and floating point and struct arguments and return values are not supported. This will be remedied in the compiler eventually. In the mean time, both of these restrictions may be easily circumvented by putting arguments in work areas and passing the address of the work area as an argument to an intermediate C "kluge function" which unpacks the real arguments and passes them on to the target C function. If work areas are needed in SYSLISP interface code, as when arrays must be passed to the C code, use a LispVar to hold the address of a word block GtWArray GtWrds GtWArray GtWrds acquired via GtWArray (for static arrays) or GtWrds (for dynamic blocks in C C the heap). Pass the array address to the C function as the pointer System Interface 7 February 1983 PSL Manual page 19.16 section 19.4 argument. 19.4.8. OLOAD Internals 19.4.8. OLOAD Internals 19.4.8. OLOAD Internals Oload invokes the Unix "ld" loader through a c-shell script to convert the relocatable code in .o files inwto absolute form, then reads it into space allocated within the BPS area of the PSL. The text segment goes at the low end of BPS, and the data and bss segments go at the high end, following the BPS storage allocation conventions of the LISP compiler. Since an incremental (-A) load is done, oload needs a filename path to the executable file containing the loader symbol table of the previous load. The variable SymbolFileName!* tells both Oload and SaveSystem/DumpLisp the file name string to use (for this reason, the executable files should be publicly readable.) When PSL is started, SymbolFileName!* is automatically set to the name of the executed PSL file. This is done by importing the Unix argument string to variable UnixArgs!*. UnixArgs!*[0] is the (possibly partial) path to the PSL file which was executed. The unix environment variable PATH contains a set of path prefixes to which partial paths are appended, until a valid filename results. "." refers to the path to the current directory, which is returned by pwd(). [ Unix system interface functions are contained in file $pv/system-extras.red. ] SymbolFileName!* is set to ".oload.out" by oload, so that succesive oloads will accumulate a loader symbol table, and so that unexec, called by DumpSystem DumpSystem DumpSystem, will get the right symbol table in the saved PSL. (It may be useful to know that the initial value of SymbolFileName!* is saved in StartupName!*.) A number of work files are created on the current directory by the oload script, with file names that begin ".oload". The .oload.out file in particular is quite large because it spans the gap of unused space in BPS. It is a good idea to remove those files if you do not intend to repeat the oload exactly. This can be done from your rlisp, via the command '' system( "rm .oload.*" ); ''. ImportForeignString ImportForeignString _ ______ ____ ______ ____ (ImportForeignString C_STRING:word): string expr Constructs and returns a LISP string, given a C string (char *) returned from a C ForeignFunction. A NULL (0) string pointer is returned as NIL. __________ ______ SYMBOLFILENAME!* [Initially: ] global Gives the name of the PSL executable file to be examined by both Oload and SaveSystem/DumpLisp to find the Unix symbol table of the PSL. Set to the executed PSL file at startup, changed to PSL Manual 7 February 1983 System Interface section 19.4 page 19.17 ".oload.out" by Oload. __________ ______ STARTUPNAME!* [Initially: ] global The path to the originally executed PSL file, as returned by GetStartupName GetStartupName function GetStartupName, based on UnixArgs!*[0]. __________ ______ UNIXARGS!* [Initially: ] global A vector of strings, passed to the PSL on startup by the Unix shell. Imported by function "getUnixArgs". 19.4.9. I/O Control functions 19.4.9. I/O Control functions 19.4.9. I/O Control functions EchoOff EchoOff _________ ____ (EchoOff ): undefined expr EchoOn EchoOn _________ ____ (EchoOn ): undefined expr EchoOff EchoOff EchoOff enters raw, character-at-a-time input mode for Emode, EchoOn EchoOn Nmode, and similar keystroke oriented environments. EchoOn returns to normal, line oriented input mode. CharsInInputBuffer CharsInInputBuffer _______ ____ (CharsInInputBuffer ): integer expr Returns the number of characters waiting for input from the TTY, including those still in the Stdio buffer and those not yet read from Unix. FlushStdOutputBuffer FlushStdOutputBuffer ____ ________ ____ (FlushStdOutputBuffer ): None Returned expr The standard output from PSL is in Stdio line-buffered mode, and is normally flushed to the TTY whenever an end-of-line is printed or before waiting for input. In screen-oriented output environements like Emode/Nmode which use screen cursor positioning, it is necessary to explictly flush the buffer at appropriate times. It may also be desireable to see partial lines of output at other times. ChannelFlush ChannelFlush ____ __ _______ ____ ________ ____ (ChannelFlush Chnl:io-channel): None Returned expr Flushes any channel, as FlushStdOutputBuffer does for StdOut!*. System Interface 7 February 1983 PSL Manual page 19.18 section 19.5 19.5. Apollo System Calls 19.5. Apollo System Calls 19.5. Apollo System Calls PSL contains a syscall package for use on the Apollo PSL. See the USCG operating note "Apollo Syscall Package for PSL", by S. Lowder, G. Maguire, and J. W. Peterson. |
Added psl-1983/lpt/20-syslisp.lpt version [db8843aa04].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 SYSLISP section 20.0 page 20.1 CHAPTER 20 CHAPTER 20 CHAPTER 20 SYSLISP SYSLISP SYSLISP 20.1. Introduction to the SYSLISP level of PSL. . . . . . 20.1 20.2. The Relationship of SYSLISP to RLISP . . . . . . . 20.2 20.2.1. SYSLISP Declarations . . . . . . . . . . 20.2 20.2.2. SYSLISP Mode Analysis. . . . . . . . . . 20.3 20.2.3. Defining Special Functions for Mode Analysis . . 20.4 20.2.4. Modified FOR Loop . . . . . . . . . . . 20.4 20.2.5. Char and IDLOC Macros. . . . . . . . . . 20.5 20.2.6. The Case Statement. . . . . . . . . . . 20.6 20.2.7. Memory Access and Address Operations. . . . . 20.7 20.2.8. Bit-Field Operation . . . . . . . . . . 20.8 20.3. Using SYSLISP. . . . . . . . . . . . . . . 20.9 20.3.1. To Compile SYSLISP Code . . . . . . . . . 20.9 20.4. SYSLISP Functions . . . . . . . . . . . . . 20.10 20.4.1. W-Arrays . . . . . . . . . . . . . . 20.11 20.5. Remaining SYSLISP Issues . . . . . . . . . . . 20.12 20.5.1. Stand Alone SYSLISP Programs . . . . . . . 20.12 20.5.2. Need for Two Stacks . . . . . . . . . . 20.12 20.5.3. New Mode System. . . . . . . . . . . . 20.13 20.5.4. Extend CREF for SYSLISP . . . . . . . . . 20.13 This chapter is very out of date and will be replaced as soon as possible. 20.1. Introduction to the SYSLISP level of PSL 20.1. Introduction to the SYSLISP level of PSL 20.1. Introduction to the SYSLISP level of PSL SYSLISP [Benson 81] is a BCPL-like language, couched in LISP form, providing operations on machine words, machine bytes and LISP ITEMs (tagged objects, packed into one or more words). We actually think of SYSLISP as a lower level of PSL, dealing with words, bytes, bit-fields, machine operations, and compile-time storage allocation, enabling us to write essentially all of the kernel in PSL. The control structures and definition language are those of LISP, but the Plus2 Times2 WPlus2 WTimes2 Plus2 Times2 WPlus2 WTimes2 familiar Plus2, Times2, etc. are mapped to word operations WPlus2, WTimes2, etc. SYSLISP handles static allocation of SYSLISP variables and arrays and initial LISP symbols, permitting the easy definition of higher level Standard LISP functions and storage areas. SYSLISP provides convenient ______ compile-time constants for handling strings, LISP symbols, etc. The SYSLISP compiler is based on the PORTABLE STANDARD LISP Compiler, with extensions to handle word level objects and efficient, open-coded, word-level operations. The SYSLISP mode of the compiler does efficient compile-time folding of constants and more comprehensive register allocation than in the distributed version of the PLC. Currently, SYSLISP handles bytes through the explicit packing and unpacking operations SYSLISP 7 February 1983 PSL Manual page 20.2 section 20.1 GetByte GetByte GetByte(word-address,byte-number) / PutByte PutByte PutByte(word-address,byte-number,byte-value) without the notion of byte- pointer; it is planned to extend SYSLISP to a C-like language by adding the appropriate declarations and analysis of word/byte/structure operations. SYSLISP is a collection of functions and their corresponding data types which are used to implement low level primitives in PSL, such as storage allocation, garbage collection and input and output. The basic data object ____ in SYSLISP is the "word", a unit of storage large enough to contain a LISP ____ ____ ____ item. On the PDP-10, a SYSLISP word is just a 36-bit PDP-10 word. On the ____ VAX and most other byte addressed machines, a word is 4 bytes, or 32 bits. Conceptually, SYSLISP functions manipulate the actual bit patterns found in words, unlike normal LISP functions which manipulate higher-level objects, ____ ______ _____ ______ such as pairs, vectors, and floats or arbitrary-precision numbers. Arithmetic in SYSLISP is comparable to the corresponding operations in FORTRAN or PASCAL. In fact, SYSLISP is most closely modeled after BCPL, in that operations are essentially "typeless". 20.2. The Relationship of SYSLISP to RLISP 20.2. The Relationship of SYSLISP to RLISP 20.2. The Relationship of SYSLISP to RLISP ______ ______ ______ smacro smacro RLISP was extended with a CASE statement, SYSLISP declarations, smacros _____ _____ _____ macro macro and macros to provide convenient infix syntax (+, *, / etc.) for calling the SYSLISP primitives. Even though SYSLISP is semantically somewhat different from LISP (RLISP), we have tried to keep the syntax as similar as possible so that SYSLISP code is "familiar" to RLISP users, and easy to use. RLISP functions can be easily converted and interfaced to functions at the SYSLISP level, gaining considerable efficiency by declaring and directly using words and bytes instead of tagged LISP objects. 20.2.1. SYSLISP Declarations 20.2.1. SYSLISP Declarations 20.2.1. SYSLISP Declarations SYSLISP variables are either GLOBAL, memory locations (allocated by the compiler), or local stack locations. Locals are declared by SCALAR, as usual. Globals come in the following flavors: WCONST id = wconstexp {,id = wconstexp} ; Wconstexp is an expression involving constants and wconsts. WVAR wvardecl {, wvardecl} ; wvardecl ::= id | id = wconstexp WARRAY warraydecl {, warraydecl} ; warraydecl ::= id[wconstexp] | id[] = [ wconstexp {,wconstexp} ] | id[] = string PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.3 WSTRING warraydecl {, warraydecl} ; Each of these declarations can also be prefixed with the keywords: INTERNAL or EXTERNAL. If nothing appears, then a DEFAULT is used. (Notice there are no metasyntactic square brackets here, only curly brackets.) For example, the following GLOBAL-DATA is used in PSL: on SysLisp; exported WConst MaxSymbols = 8000, MaxConstants = 500, HeapSize = 100000; external WArray SymNam, SymVal, SymFnc, SymPrp, ConstantVector; external WVar NextSymbol, NextConstant; exported WConst MaxRealRegs = 5, MaxArgs = 15; external WArray ArgumentBlock; off SysLisp; END; 20.2.2. SYSLISP Mode Analysis 20.2.2. SYSLISP Mode Analysis 20.2.2. SYSLISP Mode Analysis ____ In SYSLISP mode, the basic operators +, *, -, /, etc., are bound to word WPlus2 WTimes2 WMinus WPlus2 WTimes2 WMinus operators (WPlus2, WTimes2, WMinus, etc.), which compile OPEN as ____ conventional machine operations on machine words. Thus most SYSLISP expressions, loops, etc. look exactly like their RLISP equivalents. 20.2.3. Defining Special Functions for Mode Analysis 20.2.3. Defining Special Functions for Mode Analysis 20.2.3. Defining Special Functions for Mode Analysis To have the Mode analyzer (currently a REFORM function) replace LISP function names by SYSLISP ones, do: PUT('LispName,'SYSNAME,'SysLispName); SYSLISP 7 February 1983 PSL Manual page 20.4 section 20.2 The Following have been done: DefList('((Plus WPlus2) (Plus2 WPlus2) (Minus WMinus) (Difference WDifference) (Times WTimes2) (Times2 WTimes2) (Quotient WQuotient) (Remainder WRemainder) (Mod WRemainder) (Land WAnd) (Lor WOr) (Lxor WXor) (Lnot WNot) (LShift WShift) (LSH WShift)), 'SysName); DefList('((Neq WNeq) (Equal WEq) (Eqn WEq) (Eq WEq) (Greaterp WGreaterp) (Lessp WLessp) (Geq WGeq) (Leq WLeq) (Getv WGetv) (Indx WGetv) (Putv WPutv) (SetIndx WPutv)), 'SysName); 20.2.4. Modified FOR Loop 20.2.4. Modified FOR Loop 20.2.4. Modified FOR Loop Wxxxx Wxxxx The FOR loop is modified in SYSLISP mode to use the Wxxxx functions to do loop incrementation and testing. [??? Should pick up via SysReform ???] [??? Should pick up via SysReform ???] [??? Should pick up via SysReform ???] 20.2.5. Char and IDLOC Macros 20.2.5. Char and IDLOC Macros 20.2.5. Char and IDLOC Macros ____ In SYSLISP mode, '<id> refers to the tagged item, just as in LISP mode, IdLoc LispVar IdLoc __ LispVar IdLoc <id> refers to the id space offset of the <id>, and LispVar <id> ____ refers to the GLOBAL value cell of a GLOBAL or FLUID variable. Note: LispVar LispVar LispVar can be used on the left hand side of an argument sentence. For __ example, to store a NIL in the value cell of id FOO, we do any one of the following. PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.5 SYMVAL IDLOC FOO := 'NIL; LISPVAR FOO := MKITEM(ID,IDLOC NIL); Char Char _ __ _______ _____ (Char U:id): integer macro Char Char The Char macro returns the ASCII code corresponding to its single character-id argument. CHAR also can handle alias's for certain special characters, remove QUOTE marks that may be needed to pass special characters through the parser, and can accept a prefixes to compute LOWER case, <Ctrl> characters, and <Meta> characters. For example: Little_a:= Char LOWER A; % In case we think RAISE will occur Little_a:= Char '!a; % !a should not be raised Meta_X := Char META X; Weird := Char META Lower X; Dinger := Char <Ctrl-G>; Dinger := Char BELL; PUT PUT The following Aliases are defined by PUTing the association under the indicator 'CharConst: DefList('((NULL 8#0) (BELL 8#7) (BACKSPACE 8#10) (TAB 8#11) (LF 8#12) (EOL 8#12) (FF 8#14) (CR 8#15) (EOF 26) (ESC 27) (ESCAPE 27) (BLANK 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177)), 'CharConst); 20.2.6. The Case Statement 20.2.6. The Case Statement 20.2.6. The Case Statement RLISP in SYSLISP mode provides a Numeric case statement, that is implemented quite efficiently; some effort is made to examine special cases (compact vs. non compact sets of cases, short vs. long sets of cases, etc.). [??? Note, CASE can also be used from LISP mode, provided tags are [??? Note, CASE can also be used from LISP mode, provided tags are [??? Note, CASE can also be used from LISP mode, provided tags are numeric. There is also an FEXPR, CASE ???] numeric. There is also an FEXPR, CASE ???] numeric. There is also an FEXPR, CASE ???] The syntax is: SYSLISP 7 February 1983 PSL Manual page 20.6 section 20.2 Case-Statement ::= CASE expr OF case-list END Case-list ::= Case-expr [; Case-list ] Case-expr ::= Tag-expr : expr tag-expr ::= DEFAULT | OTHERWISE | tag | tag, tag ... tag | tag TO tag Tag ::= Integer | Wconst-Integer % This is a piece of code from the Token Scanner, % in file "PI:token-Scanner.red" ..... case ChTokenType of 0 to 9: % digit << TokSign := 1; goto InsideNumber >>; 10: % Start of ID << if null LispVar !*Raise then goto InsideID else << RaiseLastChar(); goto InsideRaisedID >> >>; 11: % Delimiter, but not beginning of diphthong << LispVar TokType!* := '3; return MkID TokCh >>; 12: % Start of comment goto InsideComment; 13: % Diphthong start-Lisp function uses P-list of starting char return ScanPossibleDipthong(TokChannel, MkID TokCh); 14: % ID escape character << if null LispVar !*Raise then goto GotEscape else goto GotEscapeInRaisedID >>; 15: % string quote << BackupBuf(); goto InsideString >>; 16: % Package indicator - % at start of token means use global package << ResetBuf(); ChangedPackages := 1; Package 'Global; if null LispVar !*Raise then goto GotPackageMustGetID else goto GotPackageMustGetIDRaised >>; 17: % Ignore - can't ever happen ScannerError("Internal error - consult a wizard"); 18: % Minus sign << TokSign := -1; PSL Manual 7 February 1983 SYSLISP section 20.2 page 20.7 goto GotSign >>; 19: % Plus sign << TokSign := 1; goto GotSign >>; 20: % decimal point << ResetBuf(); ReadInBuf(); if ChTokenType >= 10 then << UnReadLastChar(); return ScanPossibleDipthong(TokChannel, '!.) >> else << TokSign := 1; TokFloatFractionLength := 1; goto InsideFloatFraction >> >>; default: return ScannerError("Unknown token type") end; ..... 20.2.7. Memory Access and Address Operations 20.2.7. Memory Access and Address Operations 20.2.7. Memory Access and Address Operations The operators @ and & (corresponding to GetMem and Loc) may be used to do direct memory operations, similar to * and & in C. @ may also be used on the LHS of an assignment. Example: WARRAY FOO[10]; WVAR FEE=&FOO[0]; ... @(fee+2) := @(fee+4) + & foo(5); ... 20.2.8. Bit-Field Operation 20.2.8. Bit-Field Operation 20.2.8. Bit-Field Operation The Field and PutField operations are used for accessing fields smaller than whole words: PUTFIELD(LOC, BITOFFSET, BITLENGTH, VALUE); and GETFIELD(LOC,BITOFFSET, BITLENGTH); Special cases such as bytes, halfwords, single bits are optimized if possible. For example, the following definitions on the DEC-20 are used to define SYSLISP 7 February 1983 PSL Manual page 20.8 section 20.2 the fields of an item (in file p20c:data-machine.red): % Divide up the 36 bit DEC-20 word: WConst TagStartingBit = 0, TagBitLength = 18, StrictTagStartingBit = 9, StrictTagBitLength = 9, InfStartingBit = 18, InfBitLength = 18, GCStartingBit = 0, GCBitLength = 9; % Access to tag (type indicator) of Lisp item in ordinary code syslsp macro procedure Tag U; list('Field, cadr U, '(wconst TagStartingBit), '(wconst TagBitLe syslsp macro procedure PutTag U; list('PutField, cadr U, '(wconst TagStartingBit), '(wconst TagBitLength), caddr U); % Access to tag of Lisp item in garbage collector, % if GC bits may be in use syslsp macro procedure StrictTag U; list('Field, cadr U, '(wconst StrictTagStartingBit), '(wconst StrictTagBitLength)); syslsp macro procedure PutStrictTag U; list('PutField, cadr U, '(wconst StrictTagStartingBit), '(wconst StrictTagBitLength), caddr U); % Access to info field of item (pointer or immediate operand) syslsp macro procedure Inf U; list('Field, cadr U, '(wconst InfStartingBit), '(wconst InfBitLe syslsp macro procedure PutInf U; list('PutField, cadr U, '(wconst InfStartingBit), '(wconst InfBitLength), caddr U); PSL Manual 7 February 1983 SYSLISP section 20.3 page 20.9 20.3. Using SYSLISP 20.3. Using SYSLISP 20.3. Using SYSLISP ___________ Restriction: SYSLISP code is currently ONLY compiled, since it is converted into machine level operations, most of which are dangerous or tricky to use in an interpreted environment. Note: In SYSLISP mode, we currently execute some commands in the above PARSE/EVAL/PRINT mode, either to load files or select options, but most SYSLISP code is compiled to a file, rather than being immediately interpreted or compiled in-core. 20.3.1. To Compile SYSLISP Code 20.3.1. To Compile SYSLISP Code 20.3.1. To Compile SYSLISP Code Use PSL:RLISP, which usually has the Compiler, with SYSLISP extensions, loaded. Alternatively, one may use <psl>syscmp.exe. This is a version of RLISP built upon <PSL>psl.exe with the SYSLISP compiler and data-machine macros loaded. % Turn on SYSLISP mode: ON SYSLISP; % This is causes the "mode-analysis" to be done % Converting some LISP names to SYSLISP names. % Use SYSLSP as the procedure type. Example: % Small file to access BPS origin and end. % Starts in LISP mode Fluid '(NextBP0 LastBP0); NextBP0:=NIL; LastBP0:=NIL; On SYSLISP,COMP; % Switch to SYSLISP mode syslsp procedure BPSize(); Begin scalar N1,L1; If Null LispVar NextBP0 then LispVar NextBP0:=GtBPS 0; If Null LispVar LastBP0 then LispVar LastBP0:=GtWarray 0; N1 :=GtBPS(0); L1:= GtWarray(0); PrintF('" NextBPS=8#%o, used %d, LastBPS=8#%o, used %d%n", N1, N1-LispVar(NextBP0), L1,LispVar(LastBP0)-L1) LispVar NextBP0:=N1; LispVar LastBP0:=L1; End; BPSize(); % Call the function SYSLISP 7 February 1983 PSL Manual page 20.10 section 20.4 20.4. SYSLISP Functions 20.4. SYSLISP Functions 20.4. SYSLISP Functions [??? What about overflow in Syslisp arithmetic? ???] [??? What about overflow in Syslisp arithmetic? ???] [??? What about overflow in Syslisp arithmetic? ???] WPlus2 WPlus2 _ ____ _ ____ ____ ____ ________ ____ (WPlus2 U:word, V:word): word open-compiled, expr WDifference WDifference _ ____ _ ____ ____ ____ ________ ____ (WDifference U:word, V:word): word open-compiled, expr WTimes2 WTimes2 _ ____ _ ____ ____ ____ ________ ____ (WTimes2 U:word, V:word): word open-compiled, expr WQuotient WQuotient _ ____ _ ____ ____ ____ ________ ____ (WQuotient U:word, V:word): word open-compiled, expr WRemainder WRemainder _ ____ _ ____ ____ ____ ________ ____ (WRemainder U:word, V:word): word open-compiled, expr WShift WShift _ ____ _ ____ ____ ____ ________ ____ (WShift U:word, V:word): word open-compiled, expr WAnd WAnd _ ____ _ ____ ____ ____ ________ ____ (WAnd U:word, V:word): word open-compiled, expr WOr WOr _ ____ _ ____ ____ ____ ________ ____ (WOr U:word, V:word): word open-compiled, expr WXor WXor _ ____ _ ____ ____ ____ ________ ____ (WXor U:word, V:word): word open-compiled, expr WNot WNot _ ____ ____ ____ ________ ____ (WNot U:word): word open-compiled, expr WEQ WEQ _ ____ _ ____ _______ ____ ________ ____ (WEQ U:word, V:word): boolean open-compiled, expr WNEQ WNEQ _ ____ _ ____ _______ ____ ________ ____ (WNEQ U:word, V:word): boolean open-compiled, expr WGreaterP WGreaterP _ ____ _ ____ _______ ____ ________ ____ (WGreaterP U:word, V:word): boolean open-compiled, expr WLessP WLessP _ ____ _ ____ _______ ____ ________ ____ (WLessP U:word, V:word): boolean open-compiled, expr WGEQ WGEQ _ ____ _ ____ _______ ____ ________ ____ (WGEQ U:word, V:word): boolean open-compiled, expr PSL Manual 7 February 1983 SYSLISP section 20.4 page 20.11 WLEQ WLEQ _ ____ _ ____ _______ ____ ________ ____ (WLEQ U:word, V:word): boolean open-compiled, expr WGetV WGetV _ ____ _ ____ ____ ____ ________ _____ (WGetV U:word, V:word): word open-compiled, macro WPutV WPutV _ ____ _ ____ _ ____ ____ ____ ________ _____ (WPutV U:word, V:word, W:word): word open-compiled, macro Byte Byte _ ____ _ ____ ____ ____ ________ ____ (Byte U:word, V:word): word open-compiled, expr PutByte PutByte _ ____ _ ____ _ ____ ____ ____ ________ ____ (PutByte U:word, V:word, W:word): word open-compiled, expr 20.4.1. W-Arrays 20.4.1. W-Arrays 20.4.1. W-Arrays CopyWArray CopyWArray ___ _ ______ ___ _ ______ _____ ___ ___ _ ______ ____ (CopyWArray NEW:w-vector, OLD:w-vector, UPLIM:any): NEW:w-vector expr _____ Copy UPLIM + 1 words. CopyWRDSToFrom CopyWRDSToFrom ___ _ ______ ___ ___ ___ ____ (CopyWRDSToFrom NEW:w-vector, OLD:any): any expr CopyWArray CopyWArray Like CopyWArray in heap. CopyWRDS CopyWRDS _ ___ ___ ____ (CopyWRDS S:any): any expr Allocate new WRDS array in heap. 20.5. Remaining SYSLISP Issues 20.5. Remaining SYSLISP Issues 20.5. Remaining SYSLISP Issues The system should be made less dependent on the assemblers, compilers and loaders of the particular machine it is implemented on. One way to do this is to bring up a very small kernel including a fast loader to load in the rest. 20.5.1. Stand Alone SYSLISP Programs 20.5.1. Stand Alone SYSLISP Programs 20.5.1. Stand Alone SYSLISP Programs In principle it works, but we need to clearly define a small set of support functions. Also, need to implement EXTERNAL properly, so that a normal LINKING loader can be used. In PSL, we currently produce a single kernel module, with resident LAP (or later FAP), and it serves as dynamic linking loader for SYSLISP (ala MAIN SAIL). SYSLISP 7 February 1983 PSL Manual page 20.12 section 20.5 20.5.2. Need for Two Stacks 20.5.2. Need for Two Stacks 20.5.2. Need for Two Stacks We must distinguish between true LISP items and untagged SYSLISP items on the stack for the garbage collector to work properly. Two of the options for this are 1. Put a mark on the stack indicating a region containing untagged items. 2. Use a separate stack for untagged items. Either of these involves a change in the compiler, since it currently only allocates one frame for temporaries on the stack and does not distinguish where they get put. The garbage collector should probably be recoded more modularly and at a higher level, short of redesigning the entire storage management scheme. This in itself would probably require the existence of a separate stack which is not traced through for return addresses and SYSLISP temporaries. 20.5.3. New Mode System 20.5.3. New Mode System 20.5.3. New Mode System A better scheme for intermixing SYSLISP and LISP within a package is needed. Mode Reduce will probably take care of this. 20.5.4. Extend CREF for SYSLISP 20.5.4. Extend CREF for SYSLISP 20.5.4. Extend CREF for SYSLISP The usual range of LISP tools should be available, such as profiling, a break package, tracing, etc. |
Added psl-1983/lpt/21-implementation.lpt version [8909ccf588].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Implementation section 21.0 page 21.1 CHAPTER 21 CHAPTER 21 CHAPTER 21 IMPLEMENTATION IMPLEMENTATION IMPLEMENTATION 21.1. Overview of the Implementation . . . . . . . . . 21.1 21.2. Files of Interest . . . . . . . . . . . . . 21.1 21.3. Building PSL on the DEC-20 . . . . . . . . . . 21.2 21.4. Building the LAP to Assembly Translator . . . . . . 21.5 21.5. The Garbage Collectors and Allocators. . . . . . . 21.5 21.5.1. Compacting Garbage Collector on DEC-20 . . . . 21.5 21.5.2. Two-Space Stop and Copy Collector on VAX . . . 21.6 21.6. The HEAPs . . . . . . . . . . . . . . . . 21.6 21.7. Allocation Functions . . . . . . . . . . . . 21.8 This chapter is very out of date and will be replaced as soon as possible. Refer to the release notes for your machine and the forthcoming implementation guide. 21.1. Overview of the Implementation 21.1. Overview of the Implementation 21.1. Overview of the Implementation In this Chapter we give a guide to the sources, although they are still rapidly changing. With these notes in mind, and an understanding of SYSLISP and the compiler at the level of Chapters 18 and 20, it is hoped the user will be able to understand and change most of the system. Much of the current information is contained in comments in the source files, and cannot be reproduced here. [??? This Section needs a LOT of work ???] [??? This Section needs a LOT of work ???] [??? This Section needs a LOT of work ???] 21.2. Files of Interest 21.2. Files of Interest 21.2. Files of Interest The complete sources are divided up into a fairly large number of files, spread over a number of sub-directories of <PSL>. This is so that files representing a common machine-independent kernel are in a single directory, and additional machine specific files in others. Furthermore, we have separated the compiler and LAP files from the rest of the files, since they are looked at first when doing a new implementation, but are not actually important to understanding the working of PSL. Some convenient logical device names are defined in <psl>logical- names.cmd. This file should have been TAKEn in your LOGIN.CMD. Current definitions are: ;Officially recognized logical names for PSL subdirectories on UTAH-20 define psl: <psl> ! Executable files and miscellaneous Implementation 7 February 1983 PSL Manual page 21.2 section 21.2 define ploc: <psl.local> ! Non-distributed miscellaneous define pi: <psl.interp> ! Interpreter sources define pc: <psl.comp> ! Compiler sources define pu: <psl.util> ! Utility program sources define plocu: <psl.local.util> ! Non-distributed utility sources define pd: <psl.doc> ! Documentation to TYPE define pe: <psl.emode> ! Emode sources and build files define plpt: <psl.lpt> ! Printer version of Documentation define ph: <psl.help> ! Help files define plap: <psl.lap> ! LAP and B files define ploclap: <psl.local.lap> ! Non-distributed LAP and B files define pred: <reduce.psl-reduce>! Temporary home of Reduce built upon ! PSL define p20: <psl.20-interp> ! Dec-20 specific interpreter sources define p20c: <psl.20-comp> ! Dec-20 specific compiler sources define p20d: <psl.20-dist> ! Dec-20 distribution files define pv: <psl.vax-interp> ! Vax specific interpreter sources define pvc: <psl.vax-comp> ! Vax specific compiler sources define pvd: <psl.vax-dist> ! Vax distribution files define p68: <psl.68000-interp> ! M68000 specific interpreter sources define p68c: <psl.68000-comp> ! M68000 specific compiler sources define pcr: <psl.cray-interp> ! Cray-1 interpreter sources define pcrc: <psl.cray-comp> ! Cray-1 compiler sources define pcrd: <psl.cray-dist> ! Cray-1 distribution files define pl: plap:,ploclap: ! Search list for LOAD Sources mostly live on PI:. DEC-20 build files and very machine specific files live on P20:. 21.3. Building PSL on the DEC-20 21.3. Building PSL on the DEC-20 21.3. Building PSL on the DEC-20 [??? fix as FASL works ???] [??? fix as FASL works ???] [??? fix as FASL works ???] Building proceeds in number of steps. First the kernel files are compiled to MIDAS, using a LAP-to-MIDAS translator, which follows the normal LISP/SYSLISP compilation to LAP. This phase also includes the conversion of constants (atoms names, strings, etc) into structures in the heap, and initialization code into an INIT procedure. The resulting module is assembled, linked, and saved as BARE-PSL.EXE. If executed, it reads in a batch of LAP files, previously compiled, representing those functions that should be in a minimal PSL, but in fact are not needed to implement LAP. [??? When FAP is implemented, these LAP files will become FAP files, [??? When FAP is implemented, these LAP files will become FAP files, [??? When FAP is implemented, these LAP files will become FAP files, and the kernel will get smaller ???] and the kernel will get smaller ???] and the kernel will get smaller ???] . The BARE-PSL kernel build file is P20:PSL-KERNEL.CTL, and is reproduced PSL Manual 7 February 1983 Implementation section 21.3 page 21.3 here, slightly edited: ; This requires PL:PSL-NON-KERNEL.LAP and P20C:PSLDEF.MID copy BARE-PSL.SYM PSL.SYM PSL:MIDASCMP ! previously saved with LAPtoMIDAS in "PSL-KERNEL.RED"; % Files for kernel quit; MIDAS ! assemble kernel data dpsl MIDAS ! assemble kernel init code spsl MIDAS ! assemble kernel code psl load DPSL.REL, SPSL.REL, PSL.REL ! link into one module save BARE-PSL.EXE ! save executable The kernel files mentioned in PSL-KERNEL.RED are: MIDASOUT "PSL"; IN "BINDING.RED"$ % binding from the interpreter IN "FAST-BINDER.RED"$ % for binding in compiled code, % in LAP IN "SYMBOL-VALUES.RED"$ % SET, and support for Eval IN "FUNCTION-PRIMITIVES.RED"$ % used by PutD, GetD and Eval IN "OBLIST.RED"$ % Intern, RemOb and GenSym IN "CATCH-THROW.RED"$ % non-local GOTO mechanism IN "ALLOCATORS.RED"$ % heap, symbol and code space alloc IN "COPIERS.RED"$ % copying functions IN "CONS-MKVECT.RED"$ % SL constructor functions IN "GC.RED"$ % the garbage collector IN "APPLY-LAP.RED"$ % low-level function linkage, in LAP IN "EQUAL.RED"$ % equality predicates IN "EVAL-APPLY.RED"$ % interpreter functions IN "PROPERTY-LIST.RED"$ % PUT and FLAG and friends IN "FLUID-GLOBAL.RED"$ % variable declarations IN "PUTD-GETD.RED"$ % function defining functions IN "KNOWN-TO-COMP-SL.RED"$ % SL functions performed online % in code IN "OTHERS-SL.RED"$ % DIGIT, LITER and LENGTH IN "CARCDR.RED"$ % CDDDDR, etc. IN "EASY-SL.RED"$ % highly portable SL function defns IN "EASY-NON-SL.RED"$ % simple, ubiquitous SL extensions IN "COMP-SUPPORT.RED"$ % optimized CONS and LIST compilation IN "ERROR-HANDLERS.RED"$ % low level error handlers IN "TYPE-CONVERSIONS.RED"$ % convert from one type to another IN "ARITH.RED"$ % Lisp arithmetic functions IN "IO-DATA.RED"$ % Data structures used by IO Implementation 7 February 1983 PSL Manual page 21.4 section 21.3 IN "SYSTEM-IO.RED"$ % system dependent IO functions IN "CHAR-IO.RED"$ % bottom level IO primitives IN "OPEN-CLOSE.RED"$ % file primitives IN "RDS-WRS.RED"$ % IO channel switching functions IN "OTHER-IO.RED"$ % random SL IO functions IN "READ.RED"$ % S-expression parser IN "TOKEN-SCANNER.RED"$ % table-driven token scanner IN "PRINTERS.RED"$ % Printing functions IN "WRITE-FLOAT.RED"$ % Floating point printer IN "PRINTF.RED"$ % formatted print routines IN "IO-ERRORS.RED"$ % I/O error handlers IN "IO-EXTENSIONS.RED"$ % Random non-SL IO functions IN "VECTORS.RED"$ % GetV, PutV, UpbV IN "STRING-OPS.RED"$ % Indx, SetIndx, Sub, SetSub, Concat IN "EXPLODE-COMPRESS.RED"$ % Access to characters of atoms IN "BACKTRACE.RED"$ % Stack backtrace IN "DEC-20-EXTRAS.RED"$ % Dec-20 specific routines IN "LAP.RED"$ % Compiled code loader IN "INTERESTING-SYMBOLS.RED"$ % to access important WCONSTs IN "MAIN-START.RED"$ % first routine called MIDASEND; InitSymTab(); END; The current non-kernel files are defined in PSL-NON-KERNEL.RED: LapOut "PL:PSL-NON-KERNEL.LAP"; in "EVAL-WHEN.RED"$ % control evaluation time(load first) in "CONT-ERROR.RED"$ % macro for ContinuableError in "MINI-TRACE.RED"$ % simple function tracing in "TOP-LOOP.RED"$ % generalized top loop function in "PROG-AND-FRIENDS.RED"$ % Prog, Go and Return in "ERROR-ERRORSET.RED"$ % most basic error handling in "TYPE-ERRORS.RED"$ % type mismatch error calls in "SETS.RED"$ % Set manipulation functions in "DSKIN.RED"$ % Read/Eval/Print from files in "LISP-MACROS.RED"$ % If, SetF in "LOOP-MACROS.RED"$ % While, Repeat, ForEach in "CHAR.RED"$ % Character constant macro in "LOAD.RED"$ % Standard module LAP loader in "PSL-MAIN.RED"$ % SaveSystem and Version stuff LapEnd; The model on the VAX is similar. The file GLOBAL-DATA.RED is automatically loaded by the compiler in the LAP-to-Assembly phase. It defines most important external symbols. PSL Manual 7 February 1983 Implementation section 21.3 page 21.5 A symbol table file, PSL.SYM is produced, and is meant to be used to aid in independent recompilation of modules. It records assigned ID numbers, locations of WVARS, WARRAYS, and WSTRINGs, etc. It is not currently used. The file P20C:DATA-MACHINE.RED defines important macros and constants, allocating fields within a DEC-20 word (the TAGs, etc). It is used only with compiled code, and is so associated with the P20C: (20 compiler specific code); other files on this directory include the code-generator tables and compiler customization files. More information on the compiler and its support can be found in Chapter 18. 21.4. Building the LAP to Assembly Translator 21.4. Building the LAP to Assembly Translator 21.4. Building the LAP to Assembly Translator [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] [??? Write after new table-driven LAP and LAP-to-ASM is stable ???] 21.5. The Garbage Collectors and Allocators 21.5. The Garbage Collectors and Allocators 21.5. The Garbage Collectors and Allocators 21.5.1. Compacting Garbage Collector on DEC-20 21.5.1. Compacting Garbage Collector on DEC-20 21.5.1. Compacting Garbage Collector on DEC-20 DEC-20 PSL uses essentially the same compacting garbage collector developed for the previous MTLISP systems: a single heap with all objects tagged in the heap in such a way that a linear scan from the low end permits objects to be identified; they are either tagged as normal objects, and are thus in a PAIR, or are tagged with a "pseudo-tag", indicating a header item for some sort of BYTE, WORD or ITEM array. Tracing of objects is done using a small stack, and relocation via a segment table and extra bits in the item. The extra bits in the item can be replaced by a bit-table, and this may become the default method. During compaction, objects are "tamped" to the low end of the heap, permitting "genetic" ordering for algebraic operations, and rapid stack-like allocation. Since the MTLISP systems included a number of variable sized data-types ______ ______ (e.g. vectors and strings), we had to reduce the working set, and ease the addition of new data-types, by using a single heap with explicitly tagged objects, and compacting garbage collector. In some versions, a bit-table was used both for marking and for compaction. To preserve locality, structures are "tamped" to one end of the heap, maintaining relative (creation time or "Genetic" [Terashima 78]) ordering. The order preservation was rather useful for an inexpensive canonical ordering required in the REDUCE algebra system (simply compare heap positions, which are "naturally" related to object creation). The single heap, with explicit tags made the addition of new data-types rather easy. The virtual memory was implemented as a low level "memory" extension, invisible to the allocator and garbage collector. Implementation 7 February 1983 PSL Manual page 21.6 section 21.5 This garbage collector has been rewritten a number of times; it is fairly easy to extend, but does waste lot of space in each DEC-20 word. Among possible alternative allocators/GC is a bit-table version, which is semantically equivalent to that described above but has the Dmov field replaced by a procedure to count ones in a segment of the bit-table. At some point, the separate heap model (tried on Z-80 and PDP-11 MTLISP's) may be implemented, but the separate page-per-type method (BIBOP:="big bag of pages") might also be tried; this permits user definition of new types. Allocation proceeds as from a stack, permitting rapid allocation, and preserving creation time ordering. The current implementation uses a recursive mark phase with a small stack (G stack) of about 500 entries. Relocation is accomplished with aid the of the SEGMENT table (overlays G stack), and a small field (Dmov) in each item (header) that gives additional motion of this item relative to the relocation of its segment. 21.5.2. Two-Space Stop and Copy Collector on VAX 21.5.2. Two-Space Stop and Copy Collector on VAX 21.5.2. Two-Space Stop and Copy Collector on VAX Another alternative is a copying, 2-space GC, which is fast and good for large address space (e.g. extended addressing DEC-20 or VAX). 21.6. The HEAPs 21.6. The HEAPs 21.6. The HEAPs The HEAP is used to store variable sized objects. Since one of the possible implementations is to have a separate heap for each of the data types PAIR, STR, CODE, and VECT (or for the groupings PAIR, CODE+STR, VECT), the heap is accessed in type specific fashion only. The current implementation of the allocator and garbage collector maps these type-specific operations onto a single array of item sized blocks, the first of which is a normal tagged item (CAR of a PAIR), or a pseudo-item (header of CODE, STR or VECT). The following blocks are either tagged items or packed bytes. The header item contains a "length" in items, or bytes, as appropriate. Using item sized blocks results in a slight wastage at the end of strings and code-vectors. Reclamation: h:=INF(x) For garbage collection, compaction and relocation. The heap is viewed as a set of ITEM sized blocks PUTINF(x,h) PUTTYPE(x,t) MARK(h) UNMARK(h) Modify the garbage collector mark MARKED(h) Test the mark (in a bit-table, ITEM header, or ITEM itself). Other Garbage collector primitives include: PSL Manual 7 February 1983 Implementation section 21.6 page 21.7 GCPUSH(x) Push an ITEM onto GCSTACK for later trace x:=GCPOP() Retrieve ITEM for tracing x:=GCTOP() Examine top of GCSTACK The Garbage collector uses a GCSTACK for saving pointers still to be traced. The compaction and relocation takes place by "tamping", without structure reorganization, so that any structure is relocated by the same or more than a neighboring structure, lower in the heap. This "monotonicity" means that the heap can be divided into "segments", and the relocation of any structure computed as the relocation of its segment, plus an additional movement within the segment. The segment table is an additional structure, while the "offset" is computed from the bits in the bit-table, or from a small field (if available) in the ITEM. This garbage collector is similar to that described in [Terashima 78]. RELOC(h):=SEGKNT(SEG(h))+DMOV(h) SEGKNT(SEG(h)) is the segment relocation of the segment in which h is, and DMOV is the incremental move within this segment. i:=SEG(h) Computes the segment number i:=DSEG(h) The "offset" in the segment Note that DMOV may actually be a small field in an ITEM header, if there is space, or can be computed from the bits in a segment of the BIT-table, or may map to some other construct. The segment table may actually overlay the GCSTACK space, since these are active in different passes of the garbage collection. The garbage collector used in the MTLISP system is an extension of that attributed to S. Brown in [Harrison 73, Harrison 74]. See also [Terashima 78]. __________ ______ !*GC [Initially: NIL] switch !*GC controls the printing of garbage collector messages. If NIL no indication of garbage collection occurs. If non-NIL various system dependent messages may be displayed. __________ ______ GCKNT!* [Initially: 0] global Reclaim Reclaim Records the number of times that Reclaim has been called to this point. GCKNT!* may be reset to another value to record counts incrementally, as desired. Implementation 7 February 1983 PSL Manual page 21.8 section 21.6 Reclaim Reclaim _______ ____ (Reclaim ): integer expr User call on GC; does a mark-trace and compaction of HEAP. Returns size of current Heap top. If !*GC is T, prints some Reclaim Reclaim statistics. Increments GCKNT!*. Reclaim(); is the user level call to the garbage collector. !%Reclaim !%Reclaim ___ _______ ____ (!%Reclaim ): Not Defined expr !%Reclaim !%Reclaim !%Reclaim(); is the system level call to the garbage collector. Active data in the heap is made contiguous and all tagged pointers into the heap from active local stack frames, the binding stack and the symbol table are relocated. 21.7. Allocation Functions 21.7. Allocation Functions 21.7. Allocation Functions GtHEAP GtHEAP _____ ____ ____ ____ (GtHEAP NWRDS:word): word expr _____ Return address in HEAP of a block of NWRDS item sized pieces. GtHeap GtHeap Generates HeapOverflow Message if can't satisfy. GtHeap NIL; returns the number of words (Lisp items) left in the heap. GtHeap GtHeap GtHeap 0; returns a pointer to the top of the active heap. GtHeap GtHeap GtHeap N; returns a pointer to N words (items). GtStr GtStr _____ ____ ____ ____ (GtStr UPLIM:word): word expr ______ _____ Address of string, 0..UPLIM bytes. (Allocate space for a string _____ UPLIM characters.) GtConstStr GtConstStr _ ______ ____ (GtConstStr N:string): expr GtStr GtStr (Allocate un-collected string for print name. Same as GtStr, but uses BPS, not heap.) GtWrds GtWrds _____ ____ ____ ____ (GtWrds UPLIM:word): word expr _____ _____ Address of WRD, 0..UPLIM WORDS. (Allocate space for UPLIM untraced words.) GtVect GtVect _____ ____ ____ ____ (GtVect UPLIM:word): word expr ______ _____ Address of vector, UPLIM items. (Allocate space for a vector _____ UPLIM items.) PSL Manual 7 February 1983 Implementation section 21.7 page 21.9 GtFixN GtFixN _ _______ ____ (GtFixN ): s-integer expr Allocate space for a fixnum. GtFltN GtFltN _ _______ ____ (GtFltN ): s-integer expr _____ Allocate space for a float. GtID GtID __ ____ (GtID ): id expr __ Allocate a new id. GtBps GtBps _ _ _______ _ _______ ____ (GtBps N:s-integer): s-integer expr _ Allocate N words for binary code. GtWArray GtWArray _ _ _______ _ _______ ____ (GtWArray N:s-integer): s-integer expr _ Allocate N words for WVar/WArray/WString. DelBps DelBps ____ (DelBps ): expr DelWArray DelWArray ____ (DelWArray ): expr GtBps GtWArray GtBps GtWArray GtBps NIL; returns the number of words left in BPS. GtWArray NIL returns the same quantity. GtBps GtBps GtBps 0; returns a pointer to the bottom of BPS, that is, the current GtWArray GtWArray value of NextBPS. GtWArray 0; returns a pointer to the top of BPS, the DelBps DelBps current value of LastBPS. This is sometimes convenient for use with DelBps DelWArray DelWArray and DelWArray. GtBps GtBps GtBps N; returns a pointer to N words in BPS, moving NextBPS up by that GtWArray GtWArray amount. GtWArray returns a pointer to (the bottom of) N words at the top of BPS, pushing LastBPS down by that amount. Remember that the arguments are number of WORDS to allocate, that is, 1/4 the number of bytes on the VAX or 68000. DelBps DelBps DelBps(Lo, Hi) returns a block to BPS, if it is contiguous with the current free space. In other words, if Hi is equal to NextBPS, then NextBPS is set to Lo. Otherwise, NIL is returned and no space is added to DelHeap DelBps DelHeap DelBps BPS. DelHeap(Lo, Hi) is similar in action to DelBps. DelWArray DelWArray DelWArray(Lo, Hi) returns a block to the top of BPS, if it is contiguous with the current free space. In other words, if Lo is equal to LastBPS, then LastBPS is set to Hi. Otherwise, NIL is returned and no space is Implementation 7 February 1983 PSL Manual page 21.10 section 21.7 added to BPS. The storage management routines above are intended for either very long term or very short term use. BPS is not examined by the garbage collector at all. The routines below should be used with great care, as they deal with the heap which must be kept in a consistent state for the garbage collector. All blocks of memory allocated in the heap must have header words describing the size and type of data contained, and all pointers into the heap must have type tags consistent with the data they refer to. |
Added psl-1983/lpt/22-parser.lpt version [5482c246b1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Parser Tools section 22.0 page 22.1 CHAPTER 22 CHAPTER 22 CHAPTER 22 PARSER TOOLS PARSER TOOLS PARSER TOOLS 22.1. Introduction . . . . . . . . . . . . . . . 22.1 22.2. The Table Driven Parser . . . . . . . . . . . 22.2 22.2.1. Flow Diagram for the Parser. . . . . . . . 22.2 22.2.2. Associating the Infix Operator with a Function . 22.4 22.2.3. Precedences . . . . . . . . . . . . . 22.5 22.2.4. Special Cases of 0 <-0 and 0 0. . . . . . . 22.5 22.2.5. Parenthesized Expressions . . . . . . . . 22.5 22.2.6. Binary Operators in General. . . . . . . . 22.6 22.2.7. Assigning Precedences to Key Words . . . . . 22.7 22.2.8. Error Handling . . . . . . . . . . . . 22.7 22.2.9. The Parser Program for the RLISP Language . . . 22.7 22.2.10. Defining Operators . . . . . . . . . . 22.8 22.3. The MINI Translator Writing System. . . . . . . . 22.10 22.3.1. A Brief Guide to MINI. . . . . . . . . . 22.10 22.3.2. Pattern Matching Rules . . . . . . . . . 22.12 22.3.3. A Small Example. . . . . . . . . . . . 22.12 22.3.4. Loading Mini. . . . . . . . . . . . . 22.13 22.3.5. Running Mini. . . . . . . . . . . . . 22.13 22.3.6. MINI Error messages and Error Recovery . . . . 22.13 22.3.7. MINI Self-Definition . . . . . . . . . . 22.13 22.3.8. The Construction of MINI. . . . . . . . . 22.15 22.3.9. History of MINI Development. . . . . . . . 22.16 22.4. BNF Description of RLISP Using MINI . . . . . . . 22.17 22.1. Introduction 22.1. Introduction 22.1. Introduction In many applications, it is convenient to define a special "problem-oriented" language, tailored to provide a natural input format. Examples include the RLISP ALGOL-like surface language for algebraic work, graphics languages, boolean query languages for data-base, etc. Another ________ important case is the requirement to accept existing programs in some language, either to translate them to another language, to compile to machine language, to be able to adapt existing code into the PSL environment (e.g. mathematical libraries, etc.), or because we wish to use PSL based tools to analyze a program written in another language. One approach is to hand-code a program in PSL (called a "parser") that translates the input language to the desired form; this is tedious and error prone, and it is more convenient to use a "parser-writing-tool". In this Chapter we describe in detail two important parser writing tools available to the PSL programmer: an extensible table-driven parser that is used for the RLISP parser (described in Chapter 3), and the MINI parser generator. The table-driven parser is most useful for languages that are Parser Tools 7 February 1983 PSL Manual page 22.2 section 22.1 simple extensions of RLISP, or in fact for rapidly adding new syntactic constructs to RLISP. The MINI system is used for the development of more complete user languages. 22.2. The Table Driven Parser 22.2. The Table Driven Parser 22.2. The Table Driven Parser The parser is a top-down recursive descent parser, which uses a table of ___________ Precedences to control the parse; if numeric precedence is not adequate, LISP functions may be inserted into the table to provide more control. The parser described here was developed by Nordstrom [Nordstrom 73], and is very similar to parser described by Pratt [Pratt 73], and apparently used for the CGOL language, another LISP surface language. Scan Scan Scan Scan The parser reads tokens from an input stream using a function Scan. Scan ChannelReadToken ChannelReadToken calls the ChannelReadToken function described in Chapter 12, and performs some additional checks, described below. Each token is defined to be one of the following: non-operator O right operator O-> binary operator <-O-> All combinations of . . .O-> O. . . and O <-O->. . . are supposed to be legal, while the combinations . . .O-> <-O->. . ., . . .<-O-> <-O->. . . and O O. . . are normally illegal (error ARG MISSING and error OP MISSING, respectively). __ With each operator (which must be an id) is associated a construction function, a right precedence, and for binary operators, a left precedence. The Unary Prefix operators have this information stored under the indicator 'RLISPPREFIX and Binary operators have it stored under 'RLISPINFIX. (Actually, the indicator used at any time during parsing is the VALUE of GRAMPREFIX or GRAMINFIX, which may be changed by the user). 22.2.1. Flow Diagram for the Parser 22.2.1. Flow Diagram for the Parser 22.2.1. Flow Diagram for the Parser In this diagram RP stands for Right Precedence, LP for Left Precedence and CF for Construction Function. OP is a global variable which holds the current token. PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.3 procedure PARSE(RP); RDRIGHT(RP,SCAN()); % SCAN reads next token RDRIGHT(RP,Y) | \|/ | ------------------------ | |yes | Y is Right OP |-----> Y:=APPLY(Y.CF, | | RDRIGHT(Y.RP)); ------------------------ . | . \|/ no . | . ------------------------ . ERROR yes| | no . ARG <----| Y is Binary OP |----> OP:= . MISSING | | SCAN(); . ------------------------ . . |--------<------------<------* RDLEFT: \|/ ^ | ^ ------------------------ ^ ERROR no| | ^ OP <----| OP is Binary | ^ MISSING | | ^ ------------------------ ^ | ^ \|/ yes ^ | ^ ------------------------ ^ RETURN yes| |no ^ (Y) <----| RP > OP.lp |---> Y:=APPLY(OP.cf,Y, ------------------------ PARSE(OP.lp,SCAN()); Parser Tools 7 February 1983 PSL Manual page 22.4 section 22.2 This diagram reflects the major behavior, though some trivial additions are included in the RLISP case to handle cases such as OP-> <-OP, '!;, etc. [See PU:RLISP-PARSER.RED for full details.] The technique involved may also be described by the following figure: . . . 0-> Y <-0 . . . rp lp Y is a token or an already parsed expression between two operators (as indicated). If 0->'s RP is greater than <-0's LP, then 0-> is the winner and Y goes to 0->'s construction function (and vice versa). The result from the construction function is a "new Y" in another parse situation. By associating precedences and construction functions with the operators, we are now able to parse arithmetic expressions (except for function calls) and a large number of syntactical constructions such as IF - THEN - ELSE - ; etc. The following discussion of how to expand the parser to cover a language such as RLISP (or ALGOL) may also be seen as general tools for handling the parser and defining construction functions and precedences. 22.2.2. Associating the Infix Operator with a Function 22.2.2. Associating the Infix Operator with a Function 22.2.2. Associating the Infix Operator with a Function Scan RAtomHook Scan RAtomHook __ __ The Scan, after calling RAtomHook, checks ids and special ids (those with TOKTYPE!* = 3) to see if they should be renamed from external form to Plus2 Plus2 internal form (e.g. '!+ to Plus2). This is done by checking for a NEWNAM __ __ or NEWNAM!-OP property on the id. For special ids, the NEWNAM!-OP property is first checked. The value of the property is a replacement token, i.e. PUT('!+,'NEWNAM!-OP,'PLUS2) has been done. Scan RlispRead Scan RlispRead Scan also handles the ' mark, calling RlispRead to get the S-expression. RlispRead Read RlispRead Read RlispRead is a version of Read, using a special SCANTABLE, RLISPREADSCANTABLE!*. Scan Scan The function Scan also sets SEMIC!* to '!; or '!$ if CURSYM!* is detected to be '!*SEMICOL!* (the internal name for '!; and "!$). This controls the RLISP echo/no-echo capability. Finally, if the renamed token is 'COMMENT ReadCh ReadCh then characters are ReadCh'd until a '!; or '!$ . PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.5 22.2.3. Precedences 22.2.3. Precedences 22.2.3. Precedences To set up precedences, it is often helpful to set up a precedence matrix of the operators involved. If any operator has one "precedence" with respect to one particular operator and another "precedence" with respect to some other, it is sometimes not possible to run the parser with just numbered precedences for the operators without introducing ambiguities. If this is the case, replace the number RP by the operator RP and test with something like: IF RP *GREATER* OP . . . *GREATER* may check in the precedence matrix. An example in which such a scheme might be used is the case for which ALGOL uses ":" both as a label marker and as an index separator (although in this case there is no need for the change above). It is also a good policy to have even numbers for right precedences and odd numbers for left precedences (or vice versa). 22.2.4. Special Cases of 0 <-0 and 0 0 22.2.4. Special Cases of 0 <-0 and 0 0 22.2.4. Special Cases of 0 <-0 and 0 0 If . . .0 0. . . is a legal case (i.e. F A may translate to (F A)), ERROR OP MISSING is replaced by: Y:=REPCOM(Y,RDRIGHT(99,OP)); GO TO RDLEFT; The value 99 is chosen in order to have the first object (F) behave as a right operator with maximum precedence. If . . .0 <-0. . . is legal for some combinations of operators, replace ERROR ARG MISSING by something equivalent to the illegal RLISP statement: IF ISOPOP(OP,RP,Y) THEN <<OP:=Y; Y:=(something else, i.e. NIL); GOTO RDLEFT>> ELSE ERROR ARG MISSING; ISOPOP is supposed to return T if the present situation is legal. 22.2.5. Parenthesized Expressions 22.2.5. Parenthesized Expressions 22.2.5. Parenthesized Expressions (a) is to be translated to a. E.g. Parser Tools 7 February 1983 PSL Manual page 22.6 section 22.2 BEGIN a END translates to (PROG a). Define "(" and BEGIN as right operators with low precedences (2 and -2 respectively). Also define ")" and END as binary operators with matching left precedences (1 and -3 respectively). The construction functions for "(" and BEGIN are then something like: [See pu:RLISP-PARSER.RED for exact details on ParseBEGIN] BEGIN (X);PROG2(OP:=SCAN();MAKEPROG(X)); "(" (X);PROG2(IF OP=') THEN OP:=SCAN() ELSE ERROR, x); Note that the construction functions in these cases have to read the next token; that is the effect of ")" closing the last "(" and not all earlier "("'s. This is also an example of binary operators declared only for the purpose of having a left precedence. 22.2.6. Binary Operators in General 22.2.6. Binary Operators in General 22.2.6. Binary Operators in General As almost all binary operators have a construction function like LIST(OP,X,Y); it is assumed to be of that kind if no other is given. If OP is a binary operator, then "a OP b OP c" is interpreted as "(a OP b) OP c" only if OP's LP is less than OP's RP. Example: A + B + C translates to (A + B) + C because +'RP = 20 and +'LP = 19 A ^ B ^ C translates to A ^ (B ^ C) because ^'RP = 20 and ^'LP = 21 If you want some operators to translate to n-ary expressions, you have to define a proper construction function for that operator. Example: PLUS (X,Y); IF CAR(X) = 'PLUS THEN NCONC(X,LIST(Y)) ELSE LIST('PLUS,X,Y); PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.7 By defining "," and ";" as ordinary binary operators, the parser automatically takes care of constructions like . . .e,e,e,e,e. . . and . . . stm;stm;stm;stm;. . . It is then up to some other operators to remove the "," or the ";" from the parsed result. 22.2.7. Assigning Precedences to Key Words 22.2.7. Assigning Precedences to Key Words 22.2.7. Assigning Precedences to Key Words If you want some operators to have control immediately, insert IF RP = NIL THEN RETURN Y ELSE as the very first test in RDRIGHT and set the right precedence of those to NIL. This is sometimes useful for key-word expressions. If entering a construction function of such an operator, X is the token immediately after the operator. E.g.: We want to parse PROCEDURE EQ(X,Y); . . . Define PROCEDURE as a right operator with NIL as precedence. The construction function for PROCEDURE can always call the parser and set the rest of the expression. Note that if PROCEDURE was not defined as above, the parser would misunderstand the expression in the case of EQ as declared as a binary operator. 22.2.8. Error Handling 22.2.8. Error Handling 22.2.8. Error Handling For the present, if an error occurs a message is printed but no attempt is made to correct or handle the error. Mostly the parser goes wild for a while (until a left precedence less than current right precedence is found) and then goes on as usual. 22.2.9. The Parser Program for the RLISP Language 22.2.9. The Parser Program for the RLISP Language 22.2.9. The Parser Program for the RLISP Language SCAN(); The purpose of this function is to read the next token from the input stream. It uses the general purpose table driven token scanner described in Chapter 12, with a specially set up ReadTable, RLISPSCANTABLE!*. As Scan __________ Scan RLISP has multiple identifiers for the same operators, Scan uses the following translation table: = EQUAL >= GEQ + PLUS > GREATERP - DIFFERENCE <= LEQ / QUOTIENT < LESSP . CONS * TIMES := SETQ ** EXPT Scan Scan In these cases, Scan returns the right hand side of the table values. Scan Scan Also, two special cases are taken care of in Scan: Parser Tools 7 February 1983 PSL Manual page 22.8 section 22.2 a. ' is the QUOTE mark. If a parenthesized expression follows ' then the syntax within the parenthesis is that of LISP, using a special scan table, RLISPREADSCANTABLE!*. The only major difference from ordinary LISP is that ! is required for all special characters. b. ! in RLISP means actually two things: i. the following symbol is not treated as a special symbol (but belongs to the print name of the atom in process); ii. the atom created cannot be an operator. Example: !( in the text behaves as the atom "(". To signal to the parser that this is the case, the flag variable ESCAPEFL must be set to T if this situation occurs. 22.2.10. Defining Operators 22.2.10. Defining Operators 22.2.10. Defining Operators To define operators use: DEFINEROP(op,p{,stm}); For right or prefix operators. DEFINEBOP(op,lp,rp{,stm}); For binary operators. These use the VALUE of DEFPREFIX and DEFINFIX to store the precedences and construction functions. The default is set for RLISP, to be __________ 'RLISPPREFIX and 'RLISPINFIX. The same identifier can be defined both as the right and binary operator. The context defines which one applies. Stm is the construction function. If stm is omitted, the common defaults are used: LIST(OP,x) prefix case, x is parsed expression following, x=RDRIGHT(p,SCAN()). LIST(OP,x,y) binary case, x is previously parsed expression, y is expression following, y=RDRIGHT(rp,SCAN()). __ If stm is an id, it is assumed to be a procedure of one or two arguments, PSL Manual 7 February 1983 Parser Tools section 22.2 page 22.9 for "x" or "x,y". If it is an expression, it is embedded as (LAMBDA(X) stm) or (LAMBDA(X Y) stm), and should refer to X and Y, as needed. Also remember that the free variable OP holds the last token (normally the binary operator which stopped the parser). If "p" or "rp" is NIL, RDRIGHT is not called by default, so that only SCAN() (the next token) is passed. For example, DEFINEBOP('DIFFERENCE,17,18); % Most common case, left associative, stm=LIST(OP,x,y); DEFINEBOP('CONS,23,21); % Right Associative, default stm=LIST(OP,x,y) DEFINEBOP('AND,11,12,ParseAND); % Left Associative, special function PROCEDURE ParseAND(X,Y); NARY('AND,X,Y); DEFINEBOP('SETQ,7,6,ParseSETQ); % Right Associative, Special Function PROCEDURE ParseSETQ(LHS,RHS); LIST(IF ATOM LHS THEN 'SETQ ELSE 'SETF, LHS, RHS); DEFINEROP('MINUS,26); % default C-fn, just (list OP arg) DEFINEROP('PLUS,26,ParsePLUS1); % DEFINEROP('GO,NIL,ParseGO ); % Special Function, DO NOT use default PARSE ahead PROCEDURE ParseGO X; X is now JUST next-token IF X EQ 'TO THEN LIST('GO,PARSE0(6,T)) % Explicit Parse ahead ELSE <<OP := SCAN(); % get Next Token LIST('GO,X)>>; DEFINEROP('GOTO,NIL,ParseGOTO ); % Suppress Parse Ahead, just pass NextToken PROCEDURE ParseGOTO X; <<OP := SCAN(); LIST('GO,X)>>; Parser Tools 7 February 1983 PSL Manual page 22.10 section 22.3 22.3. The MINI Translator Writing System 22.3. The MINI Translator Writing System 22.3. The MINI Translator Writing System Note that MINI is now autoloading. 22.3.1. A Brief Guide to MINI 22.3.1. A Brief Guide to MINI 22.3.1. A Brief Guide to MINI The following is a brief introduction to MINI, the reader is referred to [Marti 79] for a more detailed discussion of the META/RLISP operators, which are very similar to those of MINI. The MINI system reads in a definition of a translator, using a BNF-like form. This is processed by MINI into a set of LISP functions, one for each production, which make calls on each other, and a set of support routines that recognize a variety of simple constructs. MINI uses a stack to perform parsing, and the user can access sub-trees already on the stack, replacing them by other trees built from these sub-trees. The primitive __ _______ functions that recognize ids, integers, etc. each place their recognized token on this stack. For example, FOO: ID '!- ID +(PLUS2 #2 #1) ; defines a rule FOO, which recognizes two identifiers separated by a minus __________ sign (each ID pushes the recognized identifier onto the stack). The last expression replaces the top 2 elements on the stack (#2 pops the first ID pushed onto the stack, while #1 pops the other) with a LISP statement. Id Id _______ ____ (Id ): boolean expr __________ See if current token is an identifier and not a keyword. If it is, then push onto the stack and fetch the next token. AnyId AnyId _______ ____ (AnyId ): boolean expr __ See if current token is an id whether or not it is a key word. AnyTok AnyTok _______ ____ (AnyTok ): boolean expr Always succeeds by pushing the current token onto the stack. Num Num _______ ____ (Num ): boolean expr ______ Tests to see if the current token is a number, if so it pushes ______ the number onto the stack and fetches the next token. PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.11 Str Str _______ ____ (Str ): boolean expr Num Num ______ Same as Num, except for strings. Specification of a parser using MINI consists of defining the syntax with BNF-like rules and semantics with LISP expressions. The following is a brief list of the operators: ' Used to designate a terminal symbol (i.e. 'WHILE, 'DO, '!=). Identifier Specifies a nonterminal. ( ) Used for grouping (i.e. (FOO BAR) requires rule FOO to parse followed immediately by BAR). < > Optional parse, if it fails then continue (i.e. <FOO> tries to parse FOO). / Optional rules (i.e. FOO / BAR allows either FOO or BAR to parse, with FOO tested first). STMT* Parse any number of STMT. STMT[ANYTOKEN]* Parse any number of STMT separated by ANYTOKEN, create a list and __________ push onto the stack (i.e. ID[,]* parses a number of identifiers separated by commas, like in an argument list). _______ ##n Refer to the nth stack location (n must be an integer). _______ #n Pop the nth stack location (n must be an integer). +(STMT) Push the unevaluated (STMT) onto the stack. .(SEXPR) Evaluate the SEXPR and ignore the result. =(SEXPR) Evaluate the SEXPR and test if result non-NIL. +.(SEXPR) Evaluate the SEXPR and push the result on the stack. @ANYTOKEN Specifies a statement terminator; used in the error recovery mechanism to search for the occurrence of errors. @@ANYTOKEN Grammar terminator; also stops scan, but if encountered in error-recovery, terminates grammar. Parser Tools 7 February 1983 PSL Manual page 22.12 section 22.3 22.3.2. Pattern Matching Rules 22.3.2. Pattern Matching Rules 22.3.2. Pattern Matching Rules In addition to the BNF-like rules that define procedures with 0 arguments and which scan tokens by calls on NEXT!-TOK() and operate on the stack, MINI also includes a simple TREE pattern matcher and syntax to define PatternProcedures that accept and return a single argument, trying a series of patterns until one succeeds. E.g. template -> replacement PATTERN = (PLUS2 &1 0) -> &1, (PLUS2 &1 &1) -> (LIST 'TIMES2 2 &1), &1 -> &1; defines a pattern with 3 rules. &n is used to indicate a matched sub-tree in both the template and replacement. A repeated &n, as in the second Equal Equal rule, requires Equal sub-trees. 22.3.3. A Small Example 22.3.3. A Small Example 22.3.3. A Small Example % A simple demo of MINI, to produce a LIST-NOTATION reader. % INVOKE 'LSPLOOP reads S-expressions, separated by ; mini 'lsploop; % Invoke MINI, give name of ROOT % Comments can appear anywhere, % prefix by % to end-of-line lsploop:lsp* @@# ; % @@# is GRAMMAR terminator % like '# but stops TOKEN SCAN lsp: sexp @; % @; is RULE terminator, like '; .(print #1) % but stops SCAN, to print .(next!-tok) ; % so call NEXT!-TOK() explicitly sexp: id / num / str / '( dotexp ') ; dotexp: sexp* < '. sexp +.(attach #2 #1) > ; fin symbolic procedure attach(x,y); <<for each z in reverse x do y:=z . y; y>>; 22.3.4. Loading Mini 22.3.4. Loading Mini 22.3.4. Loading Mini MINI is loaded from PH: using LOAD MINI;. PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.13 22.3.5. Running Mini 22.3.5. Running Mini 22.3.5. Running Mini Invoke Invoke A MINI grammar is run by calling Invoke rootname;. This installs appropriate Key Words (stored on the property list of rootname), and start the grammar by calling the Rootname as first procedure. 22.3.6. MINI Error messages and Error Recovery 22.3.6. MINI Error messages and Error Recovery 22.3.6. MINI Error messages and Error Recovery If MINI detects a non-fatal error, a message be printed, and the current token and stack is shown. MINI then calls NEXT!-TOK() repeatedly until either a statement terminator (@ANYTOKEN) or grammar terminator (@ANYTOKEN) is seen. If a grammar terminator, the grammar is exited; otherwise parsing resumes from the ROOT. [??? Interaction with BREAK loop rather poor at the moment ???] [??? Interaction with BREAK loop rather poor at the moment ???] [??? Interaction with BREAK loop rather poor at the moment ???] 22.3.7. MINI Self-Definition 22.3.7. MINI Self-Definition 22.3.7. MINI Self-Definition % The following is the definition of the MINI meta system in terms of % itself. Some support procedures are needed, and exist in a % separate file. % To define a grammar, call the procedure MINI with the argument % being the root rule name. Then when the grammar is defined it may % be called by using INVOKE root rule name. % The following is the MINI Meta self definition. MINI 'RUL; % Define the diphthongs to be used in the grammar. DIP: !#!#, !-!>, !+!., !@!@ ; % The root rule is called RUL. RUL: ('DIP ': ANYTOK[,]* .(DIPBLD #1) '; / (ID .(SETQ !#LABLIST!# NIL) ( ': ALT +(DE #2 NIL #1) @; / '= PRUL[,]* @; .(RULE!-DEFINE '(PUT(QUOTE ##2)(QUOTE RB) (QUOTE #1))) +(DE ##1 (A) (RBMATCH A (GET (QUOTE #1) (QUOTE RB)) NIL))) .(RULE!-DEFINE #1) .(NEXT!-TOK) ))* @@FIN ; % An alternative is a sequence of statements separated by /'s; ALT: SEQ < '/ ALT +(OR #2 #1) >; % A sequence is a list of items that must be matched. SEQ: REP < SEQ +(AND #2 (FAIL!-NOT #1)) >; Parser Tools 7 February 1983 PSL Manual page 22.14 section 22.3 % A repetition may be 0 or more single items (*) or 0 or more items % separated by any token (ID[,]* parses a list of ID's separated % by ,'s. REP: ONE <'[ (ID +(#1) / '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / ANYKEY +(EQTOK!-NEXT (QUOTE #1))) '] +(AND #2 #1) '* BLD!-EXPR / '* BLD!-EXPR>; % Create an sexpression to build a repetition. BLD!-EXPR: +(PROG (X) (SETQ X (STK!-LENGTH)) $1 (COND (#1 (GO $1))) (BUILD!-REPEAT X) (RETURN T)); ANYKEY: ANYTOK .(ADDKEY ##1) ; % Add a new KEY % One defines a single item. ONE: '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / '@ ANYKEY .(ADDRTERM ##1) +(EQTOK (QUOTE #1)) / '@@ ANYKEY .(ADDGTERM ##1) +(EQTOK (QUOTE #1)) / '+ UNLBLD +(PUSH #1) / '. EVLBLD +(PROGN #1 T) / '= EVLBLD / '< ALT '> +(PROGN #1 T) / '( ALT ') / '+. EVLBLD +(PUSH #1) / ID +(#1) ; % This rule defines an un evaled list. It builds a list with % everything quoted. UNLBLD: '( UNLBLD ('. UNLBLD ') +(CONS #2 #1) / UNLBLD* ') +(LIST . (#2 . #1)) / ') +(LIST . #1)) / LBLD / ID +(QUOTE #1) ; % EVLBLD builds a list of evaled items. EVLBLD: '( EVLBLD ('. EVLBLD ') +(CONS #2 #1) / EVLBLD* ') +(#2 . #1) / ') ) / LBLD / ID ; LBLD: '# NUM +(EXTRACT #1) / '## NUM +(REF #1) / '$ NUM +(GENLAB #1) / '& NUM +(CADR (ASSOC #1 (CAR VARLIST))) / NUM / STR / '' ('( UNLBLD* ') +(LIST . #1) / ANYTOK +(QUOTE #1)); PSL Manual 7 February 1983 Parser Tools section 22.3 page 22.15 % Defines the pattern matching rules (PATTERN -> BODY). PRUL: .(SETQ INDEXLIST!* NIL) PAT '-> (EVLBLD)* +(LAMBDA (VARLIST T1 T2 T3) (AND . #1)) .(SETQ PNAM (GENSYM)) .(RULE!-DEFINE (LIST 'PUTD (LIST 'QUOTE PNAM) '(QUOTE EXPR) (LIST 'QUOTE #1))) +.(CONS #1 PNAM); % Defines a pattern. % We now allow the . operator to be the next to last in a (). PAT: '& ('< PSIMP[/]* '> NUM +.(PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #2 #1) ) / NUM +.(COND ((MEMQ ##1 INDEXLIST!*) (LIST '!& '!& #1)) (T (PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #1)))) ) / ID / '!( PAT* <'. PAT +.(APPEND #2 #1)> '!) / '' ANYTOK / STR / NUM ; % Defines the primitives in a pattern. PSIMP: ID / NUM / '( PSIMP* ') / '' ANYTOK; % The grammar terminator. FIN 22.3.8. The Construction of MINI 22.3.8. The Construction of MINI 22.3.8. The Construction of MINI MINI is actually described in terms of a support package for any MINI-generated parser and a self-description of MINI. The useful files (on PU: and PL:) are as follows: MINI.MIN The self definition of MINI in MINI. MINI.SL A Standard LISP version of MINI.MIN, translated by MINI itself. MINI.RED The support RLISP for MINI. MINI-PATCH.RED and MINI.FIX Some additions being tested. MINI.LAP The precompiled LAP file. Use LOAD MINI. MINI-LAP-BUILD.CTL A batch file that builds PL:MINI.LAP from the above files. MINI-SELF-BUILD.CTL A batch file that builds the MINI.SL file by loading and translating MINI.MIN. Parser Tools 7 February 1983 PSL Manual page 22.16 section 22.3 22.3.9. History of MINI Development 22.3.9. History of MINI Development 22.3.9. History of MINI Development The MINI Translator Writing System was developed in two steps. The first was the enhancement of the META/RLISP [Marti 79] system with the definition of pattern matching primitives to aid in describing and performing tree-to-tree transformations. META/RLISP is very proficient at translating an input programming language into LISP or LISP-like trees, but did not have a good method for manipulating the trees nor for direct generation of target machine code. PMETA (as it was initially called) [Kessler 79] solved these problems and created a very good environment for the development of compilers. In fact, the PMETA enhancements have been fully integrated into META/RLISP. The second step was the elimination of META/RLISP and the development of a smaller, faster system (MINI). Since META/RLISP was designed to provide maximum flexibility and full generality, the parsers that is creates are large and slow. One of its most significant problems is that it uses its own single character driven LISP functions for token scanning and recognition. Elimination of this overhead has produced a faster translator. MINI uses the hand coded scanner in the underlying RLISP. The other main aspect of MINI was the elimination of various META/RLISP features to decrease the size of the system (also decreasing the flexibility, but MINI has been successful for the various purposes in COG). MINI is now small enough to run on small LISP systems (as long as a token scanner is provided). The META/RLISP features that MINI has changed or eliminated include the following: a. The ability to backup the parser state upon failure is supported in META/RLISP. However, by modifying a grammar definition, the need for backup can be mostly avoided and was therefore eliminated from MINI. b. META/RLISP has extensive mechanisms to allow arbitrary length diphthongs. MINI only supports two character diphthongs, declared prior to their use. c. The target machine language and error specification operators are not supported because they can be implemented with support routines. d. RLISP subsyntax for specification of semantic operations is not supported (only LISP is provided). Although MINI lacks many of the features of META/RLISP, it still has been quite sufficient for a variety of languages. PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.17 22.4. BNF Description of RLISP Using MINI 22.4. BNF Description of RLISP Using MINI 22.4. BNF Description of RLISP Using MINI The following formal scheme for the translation of RLISP syntax to LISP syntax is presented to eliminate misinterpretation of the definitions. We have used the above MINI syntactic form since it is close enough to BNF and has also been checked mechanically. Recall that the transformation scheme produces an S-expression corresponding to the input RLISP expression. A rule has a name by which it is known and is defined by what follows the meta symbol :. Each rule of the set consists of one or more "alternatives" separated by the meta symbol /, being the different ways in which the rule is matched by source text. Each rule ends with a ;. Each alternative is composed of a "recognizer" and a "generator". The "generator" is a MINI + expression which builds an S-expression from constants and elements loaded on the stack. The result is then loaded on the stack. The #n and ##n refer to elements loaded by MINI primitives or other rules. The "generator" is thus a template into which previously generated items are substituted. Recall that terminals in both recognizer and generator are quoted with a ' mark. This RLISP/SYSLISP syntax is based on a series of META and MINI definitions, started by R. Loos in 1970, continued by M. Griss, R. Kessler and A. Wang. [??? This MINI.RLISP grammar is a bit out of date ???] [??? This MINI.RLISP grammar is a bit out of date ???] [??? This MINI.RLISP grammar is a bit out of date ???] [??? Need to confirm for latest RLISP ???] [??? Need to confirm for latest RLISP ???] [??? Need to confirm for latest RLISP ???] mini 'rlisp; dip: !: , !<!< , !>!> , !:!= , !*!* , !<!= , !>!= , !' , !#!# ; termin: '; / '$ ; % $ used to not echo result rtermin: @; / @$ ; rlisp: ( cmds rtermin .(next!-tok) )* ; % Note explicit Scan cmds: procdef / rexpr ; %------ Procedure definition: procdef: emodeproc (ftype procs/ procs) / ftype procs / procs ; ftype: 'fexpr .(setq FTYPE!* 'fexpr) / % function type 'macro .(setq FTYPE!* 'macro) / 'smacro .(setq FTYPE!* 'smacro) / 'nmacro .(setq FTYPE!* 'nmacro) / ('expr / =T) .(setq FTYPE!* 'expr) ; Parser Tools 7 February 1983 PSL Manual page 22.18 section 22.4 emodeproc: 'syslsp .(setq EMODE!* 'syslsp)/ ('lisp/'symbolic/=T) .(setq EMODE!* 'symbolic) ; procs: 'procedure id proctail +(putd (quote #2) (quote FTYPE!* ) #1) ; proctail: '( id[,]* ') termin rexpr +(quote (lambda #2 #1)) / termin rexpr +(quote (lambda nil #1)) / id termin rexpr +(quote (lambda (#2) #1)) ; %------ Rexpr definition: rexpr: disjunction ; disjunction: conjunction (disjunctail / =T) ; disjunctail: ('or conjunction ('or conjunction)*) +.(cons 'or (cons #3 (cons #2 #1))) ; conjunction: negation (conjunctail / =T) ; conjunctail: ('and negation ('and negation)*) +.(cons (quote and) (cons #3 (cons #2 #1))) ; negation: 'not negation +(null #1) / 'null negation +(null #1) / relation ; relation: term reltail ; reltail: relop term +(#2 #2 #1) / =T ; term: ('- factor +(minus #1) / factor) termtail ; termtail: (plusop factor +(#2 #2 #1) termtail) / =T ; factor: powerexpr factortail ; factortail: (timop powerexpr +(#2 #2 #1) factortail) / =T ; powerexpr: dotexpr powtail ; powtail: ('** dotexpr +(expt #2 #1) powtail) / =T ; dotexpr: primary dottail ; dottail: ('. primary +(cons #2 #1) dottail) / =T ; primary: ifstate / groupstate / beginstate / PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.19 whilestate / repeatstate / forstmts / definestate / onoffstate / lambdastate / ('( rexpr ') ) / ('' (lists / id / num) +(quote #1)) / id primtail / num ; primtail:(':= rexpr +(setq #2 #1)) / (': labstmts ) / '( actualst / (primary +(#2 #1)) / =T ; lists: '( (elements)* ') ; elements: lists / id / num ; %------ If statement: ifstate: 'if rexpr 'then rexpr elserexpr +(cond (#3 #2) (T #1)) ; elserexpr: 'else rexpr / =T +nil ; %------ While statement: whilestate: 'while rexpr 'do rexpr +(while #2 #1) ; %----- Repeat statement: repeatstate: 'repeat rexpr 'until rexpr +(repeat #2 #1) ; %---- For statement: forstmts: 'for fortail ; fortail: ('each foreachstate) / forstate ; foreachstate: id inoron rexpr actchoice rexpr +(foreach #5 #4 #3 #2 #1) ; inoron: ('in +in / 'on +on) ; actchoice: ('do +do / 'collect +collect / 'conc +conc) ; forstate: id ':= rexpr loops ; loops: (': rexpr types rexpr +(for #5 (#4 1 #3) #2 #1) ) / ('step rexpr 'until rexpr types rexpr +(for #6 (#5 #4 #3) #2 #1) ) ; types: ('do +do / 'sum +sum / 'product +product) ; Parser Tools 7 February 1983 PSL Manual page 22.20 section 22.4 %----- Function call parameter list: actualst: ') +(#1) / rexpr[,]* ') +.(cons #2 #1) ; %------ Compound group statement: groupstate: '<< rexprlist '>> +.(cons (quote progn) #1) ; %------ Compound begin-end statement: beginstate: 'begin blockbody 'end ; blockbody: decllist blockstates +.(cons (quote prog) (cons #2 #1)) ; decllist: (decls[;]* +.(flatten #1)) / (=T +nil) ; decls: ('integer / 'scalar) id[,]* ; blockstates: labstmts[;]* ; labstmts: ('return rexpr +(return #1)) / (('goto / 'go 'to) id +(go #1)) / ('if rexpr 'then labstmts blkelse +(cond (#3 #2) (T #1))) / rexpr ; blkelse: 'else labstmts / =T +nil ; rexprlist: rexpr [;]* ; lambdastate: 'lambda lamtail ; lamtail: '( id[,]* ') termin rexpr +(lambda #2 #1) / termin rexpr +(lambda nil #1) / id termin rexpr +(lambda (#2) #1) ; %------ Define statement: (id and value are put onto table % named DEFNTAB: definestate: 'define delist +.(cons (quote progn) #1) ; delist: (id '= rexpr +(put (quote #2) (quote defntab) (quote #1)))[,]* ; %------ On or off statement: onoffstate: ('on +T / 'off +nil) switchlists ; switchlists: 'defn +(set '!*defn #1) ; PSL Manual 7 February 1983 Parser Tools section 22.4 page 22.21 timop: ('* +times / '/ +quotient) ; plusop: ('+ +plus2 / '- +difference) ; relop: ('< +lessp / '<= +lep / '= +equal / '>= +gep / '> +greaterp) ; FIN |
Added psl-1983/lpt/23-biblio.lpt version [443b521db0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 14 January 1983 Bibliography section 23.0 page 23.1 CHAPTER 23 CHAPTER 23 CHAPTER 23 BIBLIOGRAPHY BIBLIOGRAPHY BIBLIOGRAPHY The following books and articles either are directly referred to in the manual text, or will be helpful for supplementary reading. [Allen 79] Allen, J. R. ___ _______ __ ____ The Anatomy of LISP. McGraw-Hill, New York, New York, 1979. [Baker 78] Baker, H. G. Shallow Binding in LISP 1.5. ____ CACM 21(7):565, July, 1978. [Benson 81] Benson, E. and Griss, M. L. _______ _ ________ ____ _____ _______ ______________ SYSLISP: A Portable LISP Based Systems Implementation ________ Language. Utah Symbolic Computation Group Report UCP-81, University of Utah, Department of Computer Science, February, 1981. [Bobrow 76] Bobrow, R. J.; Burton, R. R.; Jacobs, J. M.; and Lewis, D. ___ ____ ______ _______ UCI LISP MANUAL (revised). Online Manual RS:UCLSP.MAN, University of California, Irvine, ??, 1976. [Charniak 80] Charniak, E.; Riesbeck, C. K.; and McDermott, D. V. __________ ____________ ___________ Artificial Intelligence Programming. Lawrence Erlbaum Associates, Hillsdale, New Jersey, 1980. [Fitch 77] Fitch, J. and Norman, A. Implementing LISP in a High Level Language. ________ ________ ___ __________ Software: Practise and Experience 7:713-xx, 1977. [Foderaro 81] Foderaro, J. K. and Sklower, K. L. ___ _____ ____ ______ The Franz LISP Manual 1981. [Frick 78] Frick, I. B. ______ ___ ________ ____ __ ___ _________ __ ___ __ Manual for Standard LISP on the DECSYSTEM 10 and 20. Utah Symbolic Computation Group Technical Report TR-2, University of Utah, Department of Computer Science, July, 1978. [Griss 77a] Griss, M. L. ___ _ ________ ______________ ________ ___ ____ ____ BIL: A Portable Implementation Language for LISP-Like _______ Systems. Utah Symbolic Computation Group Opnote No. 36, University of Utah, Department of Computer Science, 1977. Bibliography 14 January 1983 PSL Manual page 23.2 section 23.0 [Griss 77b] Griss, M. L. and Swanson, M. R. MBALM/1700 : A Micro-coded LISP Machine for the Burroughs B1726. ___________ __ _____ __ ___ In Proceedings of Micro-10 ACM, pages 15. ACM, 1977. [Griss 78a] Griss, M. L. and Kessler, R. R. REDUCE 1700: A Micro-coded Algebra System. ___________ __ ___ ____ ______ ________________ In Proceedings of The 11th Annual Microprogramming ________ Workshop, pages 130-138. IEEE, November, 1978. [Griss 78b] Griss, M. L. _____ ___ _ ________ ____ ___________ MBALM/BIL: A Portable LISP Interpreter. Utah Symbolic Computation Group Opnote No. 38, University of Utah, Department of Computer Science, 1978. [Griss 79a] 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. [Griss 79b] Griss, M. L. and Kessler, R. R. _ _______________ ______________ __ ____ ___ ______ __ ___ A Microprogrammed Implementation of LISP and REDUCE on the _________ _____ _____ ________ Burroughs B1700/B1800 Computer. Utah Symbolic Computation Group Report UCP 70, University of Utah, Department of Computer Science, 1979. [Griss 81] Griss, M. L. and Hearn, A. C. A Portable LISP Compiler. ________ ________ ___ __________ Software - Practice and Experience 11:541-605, June, 1981. [Griss 82] Griss, M. L.; Benson. E.; and Hearn, A. C. Current Status of a Portable LISP Compiler. ___________ __ ___ _______ ____ _________ __ ________ In Proceedings of the SIGPLAN 1982 Symposium on Compiler ____________ Construction, pages 276-283. ACM SIGPLAN, June, 1982. Also: Utah Symbolic Computation Group, Report UCP-82. [Harrison 73] Harrison, M. C. ____ __________ ___ ___________ Data structures and Programming. Scott, Foresman and Company, Glenview, Illinois, 1973. [Harrison 74] Harrison, M. C. A Language Oriented Instruction Set for BALM. ___________ __ _______ ________ _ In Proceedings of SIGPLAN/SIGMICRO 9, pages 161. ACM, 1974. [Hearn 66] Hearn, A. C. Standard LISP. _______ _______ _______ SIGPLAN Notices Notices 4(9):xx, September, 1966. Also Published in SIGSAM Bulletin, ACM Vol. 13, 1969, p. 28-49. . PSL Manual 14 January 1983 Bibliography section 23.0 page 23.3 [Hearn 73] Hearn, A. C. ______ _ _____ ______ REDUCE 2 Users Manual. Utah Symbolic Computation Group Report UCP-19, University of Utah, Department of Computer Science, 1973. [Kessler 79] Kessler, R. R. _____ _______ ________ ____ ______ PMETA - Pattern Matching META/REDUCE. Utah Symbolic Computation Group Opnote No. 40, University of Utah, Department of Computer Science, January, 1979. [Lefaivre 78] Lefaivre, R. _______ ___ ____ ______ RUTGERS/UCI LISP MANUAL. Online Manual, RS:RUTLSP.MAN, Rutgers University, Computer Science Department, May, 1978. [LISP360 xx] xx. ____ ___ _________ ______ LISP/360 Reference Manual. Technical Report, Stanford Centre for Information Processing, Stanford University, xx. [MACLISP 76] xx. _______ _________ ______ MACLISP Reference Manual. Technical Report, MIT, March, 1976. [Marti 79] Marti, J. B., et al. Standard LISP Report. _______ _______ SIGPLAN Notices 14(10):48-68, October, 1979. [McCarthy 73] McCarthy, J. C. et al. ____ _ _ __________ _ ______ LISP 1.5 Programmer's Manual. M.I.T. Press, 1973. 7th Printing January 1973. [Moore 76] J. Strother Moore II. ___ _________ _______ _______ _____________ The INTERLISP Virtual Machine Specification. CSL 76-5, Xerox, Palo Alto Research Center, 3333 Coyote Road,etc, September, 1976. [Nordstrom 73] Nordstrom, M. _ _______ _________ A Parsing Technique. Utah Computational Physics Group Opnote No. 12, University of Utah, Department of Computer Science, November, 1973. [Nordstrom 78] Nordstrom, M.; Sandewall, E.; and Breslaw, D. ____ __ _ _______ ______________ __ _________ LISP F3 : A FORTRAN Implementation of InterLISP. Manual, Datalogilaboratoriet, Sturegatan 2 B, S 752 23, Uppsala, SWEDEN, 1978. Mentioned by M. Nordstrom in 'Short Announcement of LISP F3', a handout at LISP80. Bibliography 14 January 1983 PSL Manual page 23.4 section 23.0 [Norman 81] Norman, A.C. and Morrison, D. F. ___ ______ _________ _______ The REDUCE Debugging Package. Utah Symbolic Computation Group Opnote No. 49, University of Utah, Department of Computer Science, February, 1981. [Pratt 73] Pratt, V. Top Down Operator Precedence. ___________ __ ____ _ In Proceedings of POPL-1, pages ??-??. ACM, 1973. [Quam 69] Quam, L. H. and Diffie, W. ________ ____ _ _ ______ Stanford LISP 1.6 Manual. Operating Note 28.7, Stanford Artificial Intelligence Laboratory, 1969. [Sandewall 78] Sandewall, E. Programming in an Interactive Environment : The LISP Experience. _________ _______ Computing Surveys 10(1):35-72, March, 1978. [Steele 81] Steele, G. L. and Fahlman, S. E. _____ ____ _________ ______ Spice LISP Reference Manual. Manual , Carnegie-Mellon University, Pittsburgh, September, 1981. (Preliminary Common LISP Report). [Teitelman 78] Teitelman, W.; et al. _________ _________ ______ ___ ________ Interlisp Reference Manual, (3rd Revision). Xerox Palo Alto Research Center, 3333 Coyote Hill Road, Palo Alto,Calif. 94304, 1978. [Teitelman 81] Teitleman, W. and Masinter, L. The InterLISP Programming Environment. ____ ________ IEEE Computer 14(4):25-34, 1981. [Terashima 78] Terashima, M. and Goto, E. Genetic Order and Compactifying Garbage Collectors. ___________ __________ _______ Information Processing Letters 7(1):27-32, 1978. [Weinreb 81] Weinreb, D. and Moon, D. ____ _______ ______ LISP Machine Manual 1981. Fourth edition. [Weissman 67] Weissman. ____ _ _ ______ LISP 1.5 Primer. Dickenson Publishing Company, Inc., 1967. [Winston 81] Winston, P. H., and Horn, B. K. P. ____ LISP. Addison-Wesley Publishing Company, Reading, Mass., 1981. |
Added psl-1983/lpt/24-top-index.lpt version [d1ee5e9ee0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Concept Index section 24.0 page 24.1 CHAPTER 24 CHAPTER 24 CHAPTER 24 INDEX OF CONCEPTS INDEX OF CONCEPTS INDEX OF CONCEPTS The following is an alphabetical list of concepts, with the page on which they are discussed. << >> . . . . . . . . . . . . 3.4 A-Lists . . . . . . . . . . . 4.4, 7.8, 7.10 Absolute Value. . . . . . . . 5.2 Abstract Machines . . . . . . 18.15 Access to Value Cell. . . . . 18.5 Addition. . . . . . . . . . . 5.2 Addressing Modes. . . . . . . 18.10 Allocation Functions. . . . . 21.8 Allocation. . . . . . . . . . 18.22 Always. . . . . . . . . . . . 9.8 And function. . . . . . . . . 4.8 And . . . . . . . . . . . . . 9.8 Any -catchall data type . . . 4.3 ANYREG Functions. . . . . . . 18.18 Apollo LAP. . . . . . . . . . 18.10 Appending Lists . . . . . . . 7.6 Arc cosecant function . . . . 5.13 Arc cosine function . . . . . 5.12 Arc cotangent function. . . . 5.12 Arc secant function . . . . . 5.13 Arc sine function . . . . . . 5.11 Arc tangent function. . . . . 5.12 Arguments . . . . . . . . . . 2.9, 10.7 Arithmetic. . . . . . . . . . 5.2 Arrays. . . . . . . . . . . . 8.7 As, (proposed iteration construct . . . . . . . . . . . . . . . . . 9.13 ASCII . . . . . . . . . . . . 12.1, 12.6, 12.13 Assigning Precedence. . . . . 22.7 Assignment. . . . . . . . . . 6.7 Association list. . . . . . . 4.5 Association lists . . . . . . 7.8, 7.10 Atom. . . . . . . . . . . . . 4.7 Atoms . . . . . . . . . . . . 4.3 Auto-load . . . . . . . . . . 2.4 Automatic Tracing . . . . . . 15.9 Back Quote. . . . . . . . . . 17.12 Back Trace Functions. . . . . 15.4 Backtrace . . . . . . . . . . 15.10 Backup Buffer . . . . . . . . 12.13 Big Integers. . . . . . . . . 5.1 BigNum. . . . . . . . . . . . 4.1, 5.1 Binary Infix Operators. . . . 22.2 Concept Index 7 February 1983 PSL Manual page 24.2 section 24.0 Binary Operators. . . . . . . 22.6 Binary Trees. . . . . . . . . 7.1 Binary. . . . . . . . . . . . 12.14 Binding Type. . . . . . . . . 10.8, 10.9 Binding . . . . . . . . . . . 6.7, 10.7, 10.10 Bit Field Operation . . . . . 20.7 Bit Operations. . . . . . . . 5.7 BNF . . . . . . . . . . . . . 22.10, 22.17 Boolean Functions . . . . . . 4.8 Boolean . . . . . . . . . . . 4.7, 5.5 Booleans. . . . . . . . . . . 4.3 Box Diagrams. . . . . . . . . 7.1 Break Commands. . . . . . . . 14.4 Break Loop. . . . . . . . . . 13.8, 14.1, 14.4, 14.8 Buffers in EMODE. . . . . . . 16.5 Bugs. . . . . . . . . . . . . 2.3, 2.10 Building A-Lists. . . . . . . 7.10 Building LAP. . . . . . . . . 21.5 Building PSL. . . . . . . . . 21.2 Built-In Functions. . . . . . 18.18 Byte-Vector . . . . . . . . . 4.1, 8.5 Car Manipulation. . . . . . . 7.2 Case Statement. . . . . . . . 9.3, 20.5 Catch . . . . . . . . . . . . 14.1, 14.8 Cdr Manipulation. . . . . . . 7.2 CGOL. . . . . . . . . . . . . 22.2 Channels. . . . . . . . . . . 12.1, 12.6 Char and IDLOC Macros . . . . 20.4 Characters. . . . . . . . . . 4.3 Circular Functions. . . . . . 5.8 Circular Structures . . . . . 15.13, 17.25 Classes of Data Types . . . . 4.3 Classes of Functions. . . . . 18.18 Closing Functions . . . . . . 12.1 Closure . . . . . . . . . . . 10.10 Cmacros . . . . . . . . . . . 18.15 Code Generation . . . . . . . 18.15 Code-Pointer. . . . . . . . . 4.1, 4.7, 10.1, 10.6, 12.13 Collect . . . . . . . . . . . 9.8 Comments. . . . . . . . . . . 22.4 Common Lisp . . . . . . . . . 8.7 Compacting G. C.. . . . . . . 21.5 Comparison. . . . . . . . . . 17.22 Compilation . . . . . . . . . 2.8, 10.7, 18.7 Compiled Functions. . . . . . 10.6 Compiled vs. Interpreted. . . 18.7 Compiler Second Pass. . . . . 18.15 Compiler Third Pass . . . . . 18.22 Compiler. . . . . . . . . . . 18.1 Compiling Functions . . . . . 18.2 Compiling SYSLISP Code. . . . 20.9 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.3 Compiling to FASL Files . . . 18.2 Compiling to Memory . . . . . 18.2 Composites of Car and Cdr . . 7.2 Compound Statements . . . . . 3.7 Conc. . . . . . . . . . . . . 9.8 Concatenating Lists . . . . . 7.6 Cond. . . . . . . . . . . . . 9.4 Conditional Statements. . . . 3.8 Conditionals. . . . . . . . . 9.1 Constant. . . . . . . . . . . 4.7 Constants . . . . . . . . . . 4.3 Construction Function . . . . 22.2 Construction of MINI. . . . . 22.15 Continuing After Errors . . . 14.1 Control Time of Execution . . 18.4 Converting Data Types . . . . 4.9, 5.1 Copying Functions . . . . . . 10.2 Copying Strings . . . . . . . 8.1 Copying Vectors . . . . . . . 8.3 Copying X-Vectors . . . . . . 8.5 Copying . . . . . . . . . . . 7.2 Cosecant function . . . . . . 5.11 Cosine function . . . . . . . 5.10 Cotangent function. . . . . . 5.11 Count . . . . . . . . . . . . 9.8 Counting Function Calls . . . 15.11 CREF. . . . . . . . . . . . . 17.1 Cross Reference Generator . . 17.1 Customizing Debug . . . . . . 15.14 Data Type Conversion. . . . . 4.9, 5.1 Data Types. . . . . . . . . . 4.1, 12.6, 12.13 Debug and Redefinition. . . . 15.4 Debug Deficiencies. . . . . . 15.4 Debug Example . . . . . . . . 15.16 Debug Printing Functions. . . 15.15 Debug Reading Functions . . . 15.15 Debugging Tools . . . . . . . 15.1 Dec-20 LAP. . . . . . . . . . 18.10 DEC-20 PSL. . . . . . . . . . 21.2, 21.5 Decimal Output. . . . . . . . 12.6 Declaration . . . . . . . . . 10.7, 10.8 Default Top Level . . . . . . 13.3 DefConst. . . . . . . . . . . 17.22 Deficiencies in Debug . . . . 15.4 DefMacro. . . . . . . . . . . 17.12 Deletion from lists . . . . . 7.8 Delimiters. . . . . . . . . . 12.6, 12.13 Details of the Compiler . . . 18.14 Digits. . . . . . . . . . . . 12.13 Diphthong Indicator . . . . . 12.17 Diphthong . . . . . . . . . . 12.25 Concept Index 7 February 1983 PSL Manual page 24.4 section 24.0 Division. . . . . . . . . . . 5.2 Do. . . . . . . . . . . . . . 9.8 Dot Notation. . . . . . . . . 3.6, 7.1 Dot-notation. . . . . . . . . 4.2 Each. . . . . . . . . . . . . 9.13 Edit Commands . . . . . . . . 16.1, 16.7 Editing in the Break Loop . . 14.4, 16.1 Editing with EMODE. . . . . . 16.3 Editor. . . . . . . . . . . . 16.1 Elementary Functions. . . . . 5.8 EMB Functions . . . . . . . . 15.4 Embedded Functions. . . . . . 15.11 EMODE . . . . . . . . . . . . 16.3 Enabling debug facilities . . 15.9 End of file . . . . . . . . . 12.2 End of line . . . . . . . . . 12.2 Environment . . . . . . . . . 10.10 EOF . . . . . . . . . . . . . 12.2 EOL . . . . . . . . . . . . . 12.2 Equality testing functions. . 4.5 Error Calls . . . . . . . . . 14.8 Error Functions . . . . . . . 14.1 Error Handling in MINI. . . . 22.13 Error Handling. . . . . . . . 14.1, 22.7 Error Messages. . . . . . . . 2.8, 12.6 Error Number. . . . . . . . . 14.1 Error Recovery in MINI. . . . 22.13 Errors. . . . . . . . . . . . 2.8, 2.10, 10.9 Escaped Characters. . . . . . 22.7 Eval flag . . . . . . . . . . 6.16 Eval Type Functions . . . . . 2.9 Evaluation. . . . . . . . . . 11.1 Example of MINI . . . . . . . 22.12 Examples. . . . . . . . . . . 2.5, 3.2, 3.3, 14.4, 15.16, 17.18, 18.10, 20.9, 22.6, 22.8 Exclamation Point in RLISP. . 22.7 Executable. . . . . . . . . . 13.1 Exit. . . . . . . . . . . . . 9.1, 9.17 Explicit Sequence Control . . 9.4 Exponent. . . . . . . . . . . 4.1 Exponential Functions . . . . 5.8 Exponentiation. . . . . . . . 5.2 Expr. . . . . . . . . . . . . 2.9, 10.7 Extend CREF for SYSLISP . . . 20.12 Extensible Parser . . . . . . 22.1 External Form . . . . . . . . 22.4 Extra-Booleans. . . . . . . . 4.3 Factorial function. . . . . . 5.14 FASL. . . . . . . . . . . . . 12.14 Fexpr . . . . . . . . . . . . 2.9, 10.7 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.5 Field . . . . . . . . . . . . 4.1 File Input. . . . . . . . . . 12.14 File Names. . . . . . . . . . 12.4, 12.14 File Output . . . . . . . . . 12.14 Filename Conventions. . . . . 12.14 Files about MINI. . . . . . . 22.15 Finally . . . . . . . . . . . 9.8 Find. . . . . . . . . . . . . 6.4 FixNum. . . . . . . . . . . . 4.1 Flag indicators . . . . . . . 6.16 Flagging Ids. . . . . . . . . 6.6 Flags . . . . . . . . . . . . 6.4, 6.6 Float . . . . . . . . . . . . 4.1, 4.7, 12.13 Floats. . . . . . . . . . . . 5.1 Fluid Binding . . . . . . . . 10.7, 10.10 Fluid Declarations. . . . . . 18.5 For . . . . . . . . . . . . . 9.8 Form Oriented Editor. . . . . 16.5 Form. . . . . . . . . . . . . 4.4 Format. . . . . . . . . . . . 12.6, 12.13, 12.25 Formatted Printing. . . . . . 12.6 From. . . . . . . . . . . . . 9.8 FType . . . . . . . . . . . . 4.3 Funarg. . . . . . . . . . . . 10.10 Function Calls. . . . . . . . 22.4 Function Cell . . . . . . . . 6.2, 11.1 Function definition . . . . . 3.3, 3.6, 10.1 Function Execution Tracing. . 15.5 Function Order. . . . . . . . 18.5 Function Redefinition . . . . 2.8, 15.4 Function types. . . . . . . . 2.9, 10.7 Function. . . . . . . . . . . 4.4 Garbage Collector . . . . . . 21.5 GC. . . . . . . . . . . . . . 21.5 Generator . . . . . . . . . . 22.17 Global Binding. . . . . . . . 10.7 Global Declarations . . . . . 18.5 Global Variables. . . . . . . 3.10 Globals . . . . . . . . . . . 2.10, 6.10, 6.16 Go. . . . . . . . . . . . . . 9.1 Graph-to-Tree . . . . . . . . 17.25 Halfword-Vector . . . . . . . 4.1, 8.5 Handlers. . . . . . . . . . . 12.4 Hash table. . . . . . . . . . 17.24 Hashing Cons. . . . . . . . . 17.24 Heap. . . . . . . . . . . . . 4.1, 21.6 Help. . . . . . . . . . . . . 2.4, 6.16, 13.7 Hexadecimal Output. . . . . . 12.6 History Mechanism . . . . . . 2.4, 13.4 History of MINI . . . . . . . 22.16 Concept Index 7 February 1983 PSL Manual page 24.6 section 24.0 Hook. . . . . . . . . . . . . 6.2 I/O Buffer. . . . . . . . . . 12.13 I/O . . . . . . . . . . . . . 12.25 Id hash table . . . . . . . . 6.2, 6.4, 6.10 Id Space. . . . . . . . . . . 4.1, 6.2 Id-Hash-Table . . . . . . . . 13.7 Id. . . . . . . . . . . . . . 4.1, 4.7, 4.9, 6.1, 12.13 Identifier. . . . . . . . . . 4.1, 4.7, 4.9, 6.1, 12.13 If Then Construct . . . . . . 9.1 If Then Statements. . . . . . 3.8 Ignore flag . . . . . . . . . 6.16 Implementation. . . . . . . . 21.1 In. . . . . . . . . . . . . . 9.8 Indexing vectors and strings . . . . . . . . . . . . . . . . . . . 8.1 Indicator, on property list . 6.4 Infix Operators . . . . . . . 3.4, 22.4 Init Files. . . . . . . . . . 13.3 Initially . . . . . . . . . . 9.8 Input Functions . . . . . . . 12.13 Input in Files. . . . . . . . 12.14 Input . . . . . . . . . . . . 3.10, 12.1, 22.2 Integer . . . . . . . . . . . 4.1, 4.7, 4.9, 12.13 Integers. . . . . . . . . . . 5.1 INTERLISP . . . . . . . . . . 16.5 Intern. . . . . . . . . . . . 4.9, 6.2, 6.10 InternalForm. . . . . . . . . 22.4 Internals in Debug. . . . . . 15.14 Interpretation. . . . . . . . 2.8, 18.7 Interpreted Functions . . . . 10.6, 10.9 Interpreter . . . . . . . . . 11.1 Interrupt Keys. . . . . . . . 14.8 Inum. . . . . . . . . . . . . 4.1, 4.9 Inverse Circular Functions. . 5.11 Inverse Trigonometric Functions . . . . . . . . . . . . . . . . . . 5.11 Item. . . . . . . . . . . . . 4.1 Iteration . . . . . . . . . . 9.6 Join. . . . . . . . . . . . . 9.8 Key Words . . . . . . . . . . 22.7 Lambda. . . . . . . . . . . . 4.4, 10.7, 10.9, 11.5 LAP Format. . . . . . . . . . 18.10 Lap Switches. . . . . . . . . 18.13 LAP-to-ASM for Apollo . . . . 18.9 LAP . . . . . . . . . . . . . 21.5 Length. . . . . . . . . . . . 7.6 Letter as Token Type. . . . . 12.13 Line feed . . . . . . . . . . 12.2 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.7 LISP Surface Language . . . . 22.2 Lisp syntax . . . . . . . . . 12.18, 12.21 LISP, compared with RLISP . . 3.3 List Concatenation. . . . . . 7.6 List Element Deletion . . . . 7.8 List Element Selection. . . . 7.4 List IO . . . . . . . . . . . 12.25 List Length . . . . . . . . . 7.6 List Manipulation . . . . . . 7.4 List Membership Functions . . 7.6 List Notation Reader. . . . . 22.12 List Notation . . . . . . . . 7.1 List Reversal . . . . . . . . 7.9 List Substitutions. . . . . . 7.11 List-notation . . . . . . . . 4.4 List. . . . . . . . . . . . . 4.4, 4.9, 6.4, 7.1 Loader. . . . . . . . . . . . 18.9 Loading FASL Files. . . . . . 18.3 Local Binding . . . . . . . . 10.7 Local Variables . . . . . . . 3.7 Logarithms. . . . . . . . . . 5.8 Logical And . . . . . . . . . 5.7 Logical Devices for PSL . . . 2.1, 21.1 Logical Exclusive Or. . . . . 5.7 Logical Not . . . . . . . . . 5.7 Logical Or. . . . . . . . . . 5.7 Looping Constructs. . . . . . 9.6 Loops . . . . . . . . . . . . 3.8, 3.9 Lose flag . . . . . . . . . . 6.16 Machine Instructions. . . . . 18.15 Macro Defining Tools. . . . . 17.11 Macro Expand. . . . . . . . . 17.14 Macro . . . . . . . . . . . . 2.9, 10.7, 11.7 Mapping Functions . . . . . . 9.13 Mathematical Functions. . . . 5.8 MaxChannels . . . . . . . . . 12.1 Maximize. . . . . . . . . . . 9.8 Memory Access Operations. . . 20.7 Memory Address Operations . . 20.7 Messages. . . . . . . . . . . 2.8 Meta Compiler . . . . . . . . 22.1 MINI Development. . . . . . . 22.16 MINI Error Handling . . . . . 22.13 MINI Error Recovery . . . . . 22.13 MINI Example. . . . . . . . . 22.12 MINI Operators. . . . . . . . 22.10 MINI Self-Definition. . . . . 22.13 Mini Trace. . . . . . . . . . 15.2 MINI. . . . . . . . . . . . . 22.10 Minimize. . . . . . . . . . . 9.8 Minus as Token Type . . . . . 12.13 Concept Index 7 February 1983 PSL Manual page 24.8 section 24.0 Mode Analysis Functions . . . 20.3 Modified FOR Loop . . . . . . 20.4 Modules . . . . . . . . . . . 2.4 Modulo function . . . . . . . 5.9 Multiplication. . . . . . . . 5.2 N-ary Expressions . . . . . . 22.6 N-ary Functions . . . . . . . 3.3 Need for Two Stacks . . . . . 20.12 Never . . . . . . . . . . . . 9.8 New Mode System . . . . . . . 20.12 Newline . . . . . . . . . . . 12.2 Nexpr . . . . . . . . . . . . 2.9, 10.7 Next. . . . . . . . . . . . . 9.1 NIL . . . . . . . . . . . . . 4.7, 4.8, 6.15 NoEval Type Functions . . . . 2.9 Non-Local Exit. . . . . . . . 9.17 None Returned . . . . . . . . 4.3 NoSpread Type Functions . . . 2.9 Not function. . . . . . . . . 4.8 Not . . . . . . . . . . . . . 9.8 Notation. . . . . . . . . . . 4.1 Number. . . . . . . . . . . . 4.7, 4.9, 12.13 Numbers . . . . . . . . . . . 4.3, 5.1 Numeric Comparison. . . . . . 5.5 Object list . . . . . . . . . 6.2 Oblist. . . . . . . . . . . . 6.2, 6.4 Octal Output. . . . . . . . . 12.6 OFF command . . . . . . . . . 3.10, 6.14 Oload . . . . . . . . . . . . 19.14 ON command. . . . . . . . . . 3.10, 6.14 On. . . . . . . . . . . . . . 9.8 Open Coding . . . . . . . . . 18.7 OPEN Functions. . . . . . . . 18.18 Operator Definition . . . . . 22.8 Operator Precedence . . . . . 3.4 Operators . . . . . . . . . . 22.2 Optimizations . . . . . . . . 18.22 Optional Modules. . . . . . . 2.4 Or function . . . . . . . . . 4.8 Or. . . . . . . . . . . . . . 9.8 Order of Functions. . . . . . 18.5 Output Base . . . . . . . . . 12.6 Output. . . . . . . . . . . . 3.10, 12.1 OutPutBase!*. . . . . . . . . 12.6 Overflow. . . . . . . . . . . 12.25 Package Cell. . . . . . . . . 6.2 Package . . . . . . . . . . . 6.2, 6.10 Pair Construction . . . . . . 7.2 Pair hash table . . . . . . . 17.24 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.9 Pair Manipulation . . . . . . 7.2 Pair. . . . . . . . . . . . . 4.1, 4.4, 4.7, 7.1 Pairs . . . . . . . . . . . . 7.1 Parameters. . . . . . . . . . 2.9, 10.7 Parentheses . . . . . . . . . 22.5 Parse function. . . . . . . . 3.6 Parser Flow Diagram . . . . . 22.2 Parser Generator. . . . . . . 22.1 Parser. . . . . . . . . . . . 12.13 Parsers . . . . . . . . . . . 22.1 Parsing Precedence. . . . . . 22.2 PASS1 of Compiler . . . . . . 18.14 Pattern Matcher . . . . . . . 22.12 Pattern Matching in MINI. . . 22.12 Picture RLISP . . . . . . . . 17.4 Plus as Token Type. . . . . . 12.13 Precedence Table. . . . . . . 22.2 Precedence. . . . . . . . . . 3.4, 22.5 Predicates. . . . . . . . . . 4.5, 5.5, 7.6, 10.6, 10.7, 10.9 Print Name. . . . . . . . . . 6.2, 22.7 Printing Circular Lists . . . 15.13, 17.25 Printing Circular Vectors . . 17.25 Printing Functions. . . . . . 15.12 Printing Property Lists . . . 15.12 Printing Registers. . . . . . 12.6 Printing. . . . . . . . . . . 12.6 PRLISP. . . . . . . . . . . . 17.4 Procedure definition. . . . . 3.3, 3.6 Product . . . . . . . . . . . 9.8 Productions . . . . . . . . . 22.10 Prog. . . . . . . . . . . . . 3.7, 9.4, 10.7, 10.9 Progn . . . . . . . . . . . . 3.7, 9.4 Properties. . . . . . . . . . 6.4 Property Cell Access. . . . . 6.7 Property Cell . . . . . . . . 6.2, 6.4 Property List . . . . . . . . 6.2, 6.4, 6.15, 22.4 Pseudos . . . . . . . . . . . 18.10 PSL Files . . . . . . . . . . 21.1 PSL Sample Session. . . . . . 2.5 Put Indicators. . . . . . . . 6.15 Quote Mark in RLISP . . . . . 22.7 Quote Mark. . . . . . . . . . 22.4 Radix for I/O . . . . . . . . 12.13 Random Functions. . . . . . . 18.18 Random Numbers. . . . . . . . 5.8 RCREF . . . . . . . . . . . . 17.1 Read function . . . . . . . . 3.6 Read macro indicator. . . . . 12.17 Read Macros . . . . . . . . . 12.24, 12.25 Read. . . . . . . . . . . . . 22.2 Concept Index 7 February 1983 PSL Manual page 24.10 section 24.0 Reading Functions . . . . . . 12.1, 12.13 Recognizer. . . . . . . . . . 22.17 Reduce. . . . . . . . . . . . 3.1 Register and Tracing. . . . . 15.4 Registers . . . . . . . . . . 12.6 Remainder function. . . . . . 5.2 Remaining SYSLISP Issues. . . 20.11 Removing Functions. . . . . . 10.2 Return. . . . . . . . . . . . 9.1 Returns . . . . . . . . . . . 9.8 Reversal of lists . . . . . . 7.9 Right Precedence. . . . . . . 22.2 RLISP Commands. . . . . . . . 13.8 RLISP Input . . . . . . . . . 3.10 RLISP Output. . . . . . . . . 3.10 RLISP Parser. . . . . . . . . 22.7 RLISP Syntax. . . . . . . . . 3.2, 12.18 RLISP to LISP Translation . . 22.17 RLISP to LISP Using MINI. . . 22.17 RLISP, compared with LISP . . 3.3 RLISP, compared with SYSLISP. . . . . . . . . . . . . . . . . . . . 20.2 RLISP . . . . . . . . . . . . 3.1 Running MINI. . . . . . . . . 22.13 S-expression. . . . . . . . . 12.13 S-Expressions . . . . . . . . 4.3 S-Integer . . . . . . . . . . 4.9 Saving Executable PSL . . . . 13.1 Saving Trace Output . . . . . 15.6 Scalar. . . . . . . . . . . . 3.4, 3.7, 3.9 Scan Table. . . . . . . . . . 12.13, 12.17, 12.25, 13.4, 22.4 Scope of Variables. . . . . . 10.7 Screen Editor . . . . . . . . 16.3 Searching A-Lists . . . . . . 7.10 Secant function . . . . . . . 5.11 Selective Trace . . . . . . . 15.7 Sequence of Evaluation. . . . 9.4 Set Functions . . . . . . . . 7.7 Sharp-Sign Macros . . . . . . 17.13 Side Effects. . . . . . . . . 18.18 Sine function . . . . . . . . 5.10 Skip to Top of Page . . . . . 12.6 Sorting . . . . . . . . . . . 17.22 Special Error Handlers. . . . 14.10 Special I/O Functions . . . . 12.4 Spread Type Functions . . . . 2.9 Square Root function. . . . . 5.13 Stable Functions. . . . . . . 18.18 Stack . . . . . . . . . . . . 17.14 Stand Alone SYSLISP . . . . . 20.11 Starting MINI . . . . . . . . 22.12 PSL Manual 7 February 1983 Concept Index section 24.0 page 24.11 Starting PSL. . . . . . . . . 2.1, 2.3, 26.i Statistics Functions. . . . . 15.4 Stop and Copy on VAX. . . . . 21.6 Stopping PSL. . . . . . . . . 13.1 String IO . . . . . . . . . . 12.25 String Operations . . . . . . 8.1 String Quotes . . . . . . . . 12.13 String. . . . . . . . . . . . 4.1, 4.7, 4.9, 12.13 Structural Notes: Compiler. . 18.23 Structure Definition. . . . . 17.15 Structure Editor. . . . . . . 16.5 Structure . . . . . . . . . . 4.4 Stubs . . . . . . . . . . . . 15.12 Substitutions . . . . . . . . 7.11 Substring Matching. . . . . . 6.4 Subtraction . . . . . . . . . 5.2 Sum . . . . . . . . . . . . . 9.8 Switches Controlling Compiler . . . . . . . . . . . . . . . . . . . 18.6 Switches. . . . . . . . . . . 2.10, 3.10, 6.14, 6.16 SYSLISP Arguments . . . . . . 12.6 SYSLISP Declarations. . . . . 20.2 SYSLISP Functions . . . . . . 20.10 SYSLISP Level of PSL. . . . . 20.1 SYSLISP Mode Analysis . . . . 20.3 SYSLISP Programs. . . . . . . 20.11 SYSLISP, compared with RLISP. . . . . . . . . . . . . . . . . . . . 20.2 System Dependent Functions. . 19.1 T . . . . . . . . . . . . . . 6.15 Table Driven Parser . . . . . 22.2 Tag Field . . . . . . . . . . 4.1 Tagging Information . . . . . 18.15 Tangent function. . . . . . . 5.10 Template and Replacement. . . 22.12 Terminal Interaction. . . . . 13.8 Throw . . . . . . . . . . . . 14.1, 14.10 Time Control Functions. . . . 18.4 Token scanner . . . . . . . . 12.13 Tokens. . . . . . . . . . . . 22.2 Top Level Function. . . . . . 13.3 Top Loop Mechanism. . . . . . 14.8 Top Loop. . . . . . . . . . . 13.4 Trace Output. . . . . . . . . 15.6 Trace ring buffer . . . . . . 15.6 Trace . . . . . . . . . . . . 15.4 Tracing Functions . . . . . . 2.4, 15.2, 15.5 Tracing Macros. . . . . . . . 15.4 Tracing New Functions . . . . 15.9 Transcendental Functions. . . 5.8 Trees . . . . . . . . . . . . 22.10 Concept Index 7 February 1983 PSL Manual page 24.12 section 24.0 Trigonometric Functions . . . 5.8 Truth and falsity . . . . . . 4.8 Turning Off Trace . . . . . . 15.8 Type Checking Functions . . . 4.7 Type Conversion . . . . . . . 4.9, 5.1 Type Declarations . . . . . . 4.1 Type Field. . . . . . . . . . 4.1 Type Mismatch . . . . . . . . 12.25 UCI LISP. . . . . . . . . . . 16.5 Unary Functions . . . . . . . 3.3, 5.2 Unary Prefix Operators. . . . 22.2 Undefined . . . . . . . . . . 4.3 Union . . . . . . . . . . . . 9.8 Unix interface functions. . . 19.14 Unless. . . . . . . . . . . . 9.8 Until . . . . . . . . . . . . 9.8 Untraceable Functions . . . . 15.4 User flag . . . . . . . . . . 6.16 User Function Redefinition. . 15.4 User Hooks in Debug . . . . . 15.14 User Interface. . . . . . . . 13.1 Using SYSLISP . . . . . . . . 20.9 Utility modules . . . . . . . 17.1 Value Cell. . . . . . . . . . 6.2, 6.7, 10.7 Variable Binding. . . . . . . 6.7, 10.7 Vax init files. . . . . . . . 19.11 VAX LAP . . . . . . . . . . . 18.9, 18.10 Vax login files . . . . . . . 19.10 Vax PSL directories . . . . . 19.11 VAX PSL . . . . . . . . . . . 21.6 Vax system interface. . . . . 19.10 Vector Indexing . . . . . . . 8.1 Vector Operations . . . . . . 8.3 Vector. . . . . . . . . . . . 4.1, 4.7, 4.9 Warning Messages. . . . . . . 2.8 When. . . . . . . . . . . . . 9.8 While . . . . . . . . . . . . 9.8 Windows in EMODE. . . . . . . 16.5 With. . . . . . . . . . . . . 9.8 Word Operations . . . . . . . 8.5 Word-Vector . . . . . . . . . 4.1, 8.5 Word. . . . . . . . . . . . . 4.1 Writing Functions . . . . . . 12.1 X-Vector Operations . . . . . 8.5 X-Vector. . . . . . . . . . . 8.1 X-Vectors . . . . . . . . . . 4.3 |
Added psl-1983/lpt/25-fun-index.lpt version [f1e5362f8f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Function Index section 25.0 page 25.1 CHAPTER 25 CHAPTER 25 CHAPTER 25 INDEX OF FUNCTIONS INDEX OF FUNCTIONS INDEX OF FUNCTIONS The following is an alphabetical list of the PSL functions, with the page on which they are defined. !%Reclaim . . . . . . . . . . expr 21.8 !*DESTROY . . . . . . . . . . cmacro 18.22 !*DO. . . . . . . . . . . . . cmacro 18.22 !*JUMP. . . . . . . . . . . . cmacro 18.22 !*LBL . . . . . . . . . . . . cmacro 18.22 !*LOAD. . . . . . . . . . . . cmacro 18.22 !*SET . . . . . . . . . . . . cmacro 18.22 !*STORE . . . . . . . . . . . cmacro 18.22 \CreatePackage. . . . . . . . expr 6.11 \LocalIntern. . . . . . . . . expr 6.12 \LocalInternP . . . . . . . . expr 6.11 \LocalMapObl. . . . . . . . . expr 6.12 \LocalRemob . . . . . . . . . expr 6.12 \PathIntern . . . . . . . . . expr 6.11 \PathInternP. . . . . . . . . expr 6.11 \PathMapObl . . . . . . . . . expr 6.11 \PathRemob. . . . . . . . . . expr 6.11 \SetPackage . . . . . . . . . expr 6.11 A . . . . . . . . . . . . . . edit 16.7 Abs . . . . . . . . . . . . . expr 5.2 AConc . . . . . . . . . . . . expr 7.7 Acos. . . . . . . . . . . . . expr 5.12 AcosD . . . . . . . . . . . . expr 5.12 Acot. . . . . . . . . . . . . expr 5.12 AcotD . . . . . . . . . . . . expr 5.13 Acsc. . . . . . . . . . . . . expr 5.13 AcscD . . . . . . . . . . . . expr 5.13 Add1. . . . . . . . . . . . . expr 5.2 Adjoin. . . . . . . . . . . . expr 7.7 AdjoinQ . . . . . . . . . . . expr 7.8 AlphaNumericP . . . . . . . . expr 8.8 AlphaP. . . . . . . . . . . . expr 8.8 And . . . . . . . . . . . . . fexpr 4.8 Ans . . . . . . . . . . . . . expr 13.6 AnyId . . . . . . . . . . . . expr 22.10 AnyTok. . . . . . . . . . . . expr 22.10 Append. . . . . . . . . . . . expr 7.6 Apply . . . . . . . . . . . . expr 11.4 ApplyInEnvironment. . . . . . expr 10.10 Asec. . . . . . . . . . . . . expr 5.13 AsecD . . . . . . . . . . . . expr 5.13 Asin. . . . . . . . . . . . . expr 5.11 AsinD . . . . . . . . . . . . expr 5.11 Function Index 7 February 1983 PSL Manual page 25.2 section 25.0 Ass . . . . . . . . . . . . . expr 7.10 Assoc . . . . . . . . . . . . expr 7.10 Atan2 . . . . . . . . . . . . expr 5.12 Atan2D. . . . . . . . . . . . expr 5.12 Atan. . . . . . . . . . . . . expr 5.12 AtanD . . . . . . . . . . . . expr 5.12 Atom. . . . . . . . . . . . . expr 4.7 Atsoc . . . . . . . . . . . . expr 7.10 B . . . . . . . . . . . . . . edit 16.2, 16.7 BackQuote . . . . . . . . . . macro 17.13 BeginRLisp. . . . . . . . . . expr 13.7 BELOW . . . . . . . . . . . . edit 16.8 BF. . . . . . . . . . . . . . edit 16.8 BI. . . . . . . . . . . . . . edit 16.9 BIND. . . . . . . . . . . . . edit 16.9 Bits. . . . . . . . . . . . . macro 19.9 BK. . . . . . . . . . . . . . edit 16.9 BldMsg. . . . . . . . . . . . expr 12.27 BO. . . . . . . . . . . . . . edit 16.9 BothCaseP . . . . . . . . . . expr 8.8 BothTimes . . . . . . . . . . expr 18.4 Btr . . . . . . . . . . . . . macro 15.10 Bug . . . . . . . . . . . . . expr 2.10 Byte. . . . . . . . . . . . . expr 20.11 CaptureEnvironment. . . . . . expr 10.11 Car . . . . . . . . . . . . . expr 7.2 Case. . . . . . . . . . . . . fexpr 9.4 Catch!-All. . . . . . . . . . macro 9.19 Catch . . . . . . . . . . . . fexpr 9.17 Cd. . . . . . . . . . . . . . expr 19.13 Cdr . . . . . . . . . . . . . expr 7.2 Ceiling . . . . . . . . . . . expr 5.8 CHANGE. . . . . . . . . . . . edit 16.9 ChannelEject. . . . . . . . . expr 12.10 ChannelFlush. . . . . . . . . expr 19.17 ChannelLineLength . . . . . . expr 12.11 ChannelLPosn. . . . . . . . . expr 12.11 ChannelPosn . . . . . . . . . expr 12.10 ChannelPrin1. . . . . . . . . expr 12.7 ChannelPrin2. . . . . . . . . expr 12.8 ChannelPrin2T . . . . . . . . expr 12.12 ChannelPrinC. . . . . . . . . expr 12.8 ChannelPrint. . . . . . . . . expr 12.8 ChannelPrintF . . . . . . . . expr 12.9 ChannelRead . . . . . . . . . expr 12.13 ChannelReadCH . . . . . . . . expr 12.16 ChannelReadChar . . . . . . . expr 12.15 ChannelReadToken. . . . . . . expr 12.16 ChannelSpaces . . . . . . . . expr 12.11 ChannelTab. . . . . . . . . . expr 12.12 PSL Manual 7 February 1983 Function Index section 25.0 page 25.3 ChannelTerPri . . . . . . . . expr 12.10 ChannelUnReadChar . . . . . . expr 12.16 ChannelWriteChar. . . . . . . expr 12.6 Char!-Bits. . . . . . . . . . expr 8.9 Char!-Code. . . . . . . . . . expr 8.9 Char!-DownCase. . . . . . . . expr 8.10 Char!-Equal . . . . . . . . . expr 8.9 Char!-Font. . . . . . . . . . expr 8.9 Char!-GreaterP. . . . . . . . expr 8.9 Char!-Int . . . . . . . . . . expr 8.10 Char!-LessP . . . . . . . . . expr 8.9 Char!-UpCase. . . . . . . . . expr 8.10 Char!<. . . . . . . . . . . . expr 8.9 Char!=. . . . . . . . . . . . expr 8.9 Char!>. . . . . . . . . . . . expr 8.9 Char. . . . . . . . . . . . . macro 20.5 Character . . . . . . . . . . expr 8.10 CharsInInputBuffer. . . . . . expr 19.17 ClearBindings . . . . . . . . expr 10.11 Close . . . . . . . . . . . . expr 12.5 Closure . . . . . . . . . . . macro 10.10 Cmds. . . . . . . . . . . . . fexpr 19.2 Code!-Char. . . . . . . . . . expr 8.9 Code!-Number!-Of!-Arguments . expr 10.7 CodeApply . . . . . . . . . . expr 11.6 CodeEvalApply . . . . . . . . expr 11.6 CodeP . . . . . . . . . . . . expr 4.7 CommentOutCode. . . . . . . . macro 18.4 Compile . . . . . . . . . . . expr 18.2 CompileTime . . . . . . . . . expr 18.4 Compress. . . . . . . . . . . expr 12.26 COMS. . . . . . . . . . . . . edit 16.10 COMSQ . . . . . . . . . . . . edit 16.10 Concat. . . . . . . . . . . . expr 8.6 ConcatS . . . . . . . . . . . expr 19.2 Cond. . . . . . . . . . . . . fexpr 9.1 Cons. . . . . . . . . . . . . expr 7.2 Const . . . . . . . . . . . . macro 17.22 ConstantP . . . . . . . . . . expr 4.7 ContError . . . . . . . . . . macro 14.3 ContinuableError. . . . . . . expr 14.3 Copy. . . . . . . . . . . . . expr 7.3 CopyD . . . . . . . . . . . . expr 10.3 CopyScanTable . . . . . . . . expr 12.25 CopyString. . . . . . . . . . expr 8.2 CopyStringToFrom. . . . . . . expr 8.2 CopyVector. . . . . . . . . . expr 8.4 CopyVectorToFrom. . . . . . . expr 8.4 CopyWArray. . . . . . . . . . expr 20.11 CopyWRDS. . . . . . . . . . . expr 20.11 CopyWRDSToFrom. . . . . . . . expr 20.11 Cos . . . . . . . . . . . . . expr 5.10 Function Index 7 February 1983 PSL Manual page 25.4 section 25.0 CosD. . . . . . . . . . . . . expr 5.10 Cot . . . . . . . . . . . . . expr 5.11 CotD. . . . . . . . . . . . . expr 5.11 CPrint. . . . . . . . . . . . expr 17.25 Csc . . . . . . . . . . . . . expr 5.11 CscD. . . . . . . . . . . . . expr 5.11 Date. . . . . . . . . . . . . expr 13.2 De. . . . . . . . . . . . . . macro 10.4 Decr. . . . . . . . . . . . . macro 5.3 DefConst. . . . . . . . . . . macro 17.22 DefLambda . . . . . . . . . . macro 17.14 DefList . . . . . . . . . . . expr 6.5 DefMacro. . . . . . . . . . . macro 17.12 Defstruct . . . . . . . . . . fexpr 17.16 DefstructP. . . . . . . . . . expr 17.15 DefstructType . . . . . . . . expr 17.15 DegreesToDMS. . . . . . . . . expr 5.10 DegreesToRadians. . . . . . . expr 5.9 Del . . . . . . . . . . . . . expr 7.9 DelAsc. . . . . . . . . . . . expr 7.9 DelAscIP. . . . . . . . . . . expr 7.9 DelatQ. . . . . . . . . . . . expr 7.9 DelatQIP. . . . . . . . . . . expr 7.9 DelBps. . . . . . . . . . . . expr 21.9 DELETE. . . . . . . . . . . . edit 16.10 Delete. . . . . . . . . . . . expr 7.8 DeletIP . . . . . . . . . . . expr 7.9 DelQ. . . . . . . . . . . . . expr 7.9 DelQIP. . . . . . . . . . . . expr 7.9 DelWArray . . . . . . . . . . expr 21.9 DeSetQ. . . . . . . . . . . . macro 6.8 Df. . . . . . . . . . . . . . macro 10.4 Difference. . . . . . . . . . expr 5.3 Digit!-Char . . . . . . . . . expr 8.10 Digit . . . . . . . . . . . . expr 12.25 DigitP. . . . . . . . . . . . expr 8.8 Divide. . . . . . . . . . . . expr 5.3 Dm. . . . . . . . . . . . . . macro 10.5 DMStoDegrees. . . . . . . . . expr 5.10 DMStoRadians. . . . . . . . . expr 5.10 Dn. . . . . . . . . . . . . . macro 10.4 Do!*. . . . . . . . . . . . . macro 9.16 Do-Loop!* . . . . . . . . . . macro 9.16 Do-Loop . . . . . . . . . . . macro 9.16 Do. . . . . . . . . . . . . . macro 9.15 DoCmds. . . . . . . . . . . . expr 19.2 Ds. . . . . . . . . . . . . . macro 10.5 DskIn . . . . . . . . . . . . expr 12.14 DumpLisp. . . . . . . . . . . expr 13.2 E . . . . . . . . . . . . . . edit 16.10 PSL Manual 7 February 1983 Function Index section 25.0 page 25.5 EchoOff . . . . . . . . . . . expr 19.17 EchoOn. . . . . . . . . . . . expr 19.17 EditF . . . . . . . . . . . . expr 16.10 EditFns . . . . . . . . . . . fexpr 16.10 EditP . . . . . . . . . . . . fexpr 16.11 EditV . . . . . . . . . . . . fexpr 16.11 Eject . . . . . . . . . . . . expr 12.10 Emacs . . . . . . . . . . . . expr 19.3 EMBED . . . . . . . . . . . . edit 16.11 Eq. . . . . . . . . . . . . . expr 4.5 EqCar . . . . . . . . . . . . expr 4.6 EqN . . . . . . . . . . . . . expr 4.5 EqStr . . . . . . . . . . . . expr 4.6 Equal . . . . . . . . . . . . expr 4.6 Error . . . . . . . . . . . . expr 14.2 ErrorPrintF . . . . . . . . . expr 12.10 ErrorSet. . . . . . . . . . . expr 14.2 ErrPrin . . . . . . . . . . . expr 12.8 Eval. . . . . . . . . . . . . expr 11.2 EvalInEnvironment . . . . . . expr 10.10 EvIn. . . . . . . . . . . . . expr 12.15 EvLis . . . . . . . . . . . . expr 11.5 EvOut . . . . . . . . . . . . expr 12.6 EvProgN . . . . . . . . . . . expr 11.6 EvShut. . . . . . . . . . . . expr 12.5 Exec. . . . . . . . . . . . . expr 19.3 Exit. . . . . . . . . . . . . macro 9.7 ExitLisp. . . . . . . . . . . expr 13.1, 19.14 Exp . . . . . . . . . . . . . expr 5.13 Expand. . . . . . . . . . . . expr 11.7 Explode2. . . . . . . . . . . expr 12.26 Explode . . . . . . . . . . . expr 12.26 ExprP . . . . . . . . . . . . expr 10.7 Expt. . . . . . . . . . . . . expr 5.3 Extended-Get. . . . . . . . . expr 17.25 Extended-Put. . . . . . . . . expr 17.25 EXTRACT . . . . . . . . . . . edit 16.11 F=. . . . . . . . . . . . . . edit 16.13 F . . . . . . . . . . . . . . edit 16.2, 16.12 Factorial . . . . . . . . . . expr 5.14 FaslEnd . . . . . . . . . . . expr 18.3 FaslIn. . . . . . . . . . . . expr 18.3 FaslOut . . . . . . . . . . . expr 18.2 FatalError. . . . . . . . . . expr 14.8 FCodeP. . . . . . . . . . . . expr 10.6 FExprP. . . . . . . . . . . . expr 10.7 FileP . . . . . . . . . . . . expr 12.5, 19.5 FindPrefix. . . . . . . . . . expr 6.4 FindSuffix. . . . . . . . . . expr 6.4 First . . . . . . . . . . . . macro 7.4 Fix . . . . . . . . . . . . . expr 5.2 Function Index 7 February 1983 PSL Manual page 25.6 section 25.0 FixP. . . . . . . . . . . . . expr 4.7 Flag1 . . . . . . . . . . . . expr 6.6 Flag. . . . . . . . . . . . . expr 6.6 FlagP . . . . . . . . . . . . expr 6.6 FLambdaLinkP. . . . . . . . . expr 10.6 FlatSize2 . . . . . . . . . . expr 12.27 FlatSize. . . . . . . . . . . expr 12.27 Float . . . . . . . . . . . . expr 5.2 FloatP. . . . . . . . . . . . expr 4.7 Floor . . . . . . . . . . . . expr 5.8 Fluid . . . . . . . . . . . . expr 10.8, 18.5 FluidP. . . . . . . . . . . . expr 10.9 FlushStdOutputBuffer. . . . . expr 19.17 For!* . . . . . . . . . . . . macro 9.13 For . . . . . . . . . . . . . macro 9.8 ForEach . . . . . . . . . . . macro 9.13 Fourth. . . . . . . . . . . . macro 7.5 FS. . . . . . . . . . . . . . edit 16.13 FStub . . . . . . . . . . . . macro 15.12 FUnBoundP . . . . . . . . . . expr 10.6 Function. . . . . . . . . . . fexpr 11.7 GenSym. . . . . . . . . . . . expr 6.3 Geq . . . . . . . . . . . . . expr 5.5 Get . . . . . . . . . . . . . expr 6.5 GetCDir . . . . . . . . . . . expr 19.6 GetD. . . . . . . . . . . . . expr 10.3 GetEnv. . . . . . . . . . . . expr 19.14 GetFCodePointer . . . . . . . expr 10.6 GetFork . . . . . . . . . . . expr 19.4 GetNewJfn . . . . . . . . . . expr 19.5 GetOldJfn . . . . . . . . . . expr 19.5 GetRescan . . . . . . . . . . expr 19.5 GetUName. . . . . . . . . . . expr 19.6 GetV. . . . . . . . . . . . . expr 8.3 Global. . . . . . . . . . . . expr 10.8, 18.6 GlobalP . . . . . . . . . . . expr 10.9 GmergeSort. . . . . . . . . . expr 17.22 Go. . . . . . . . . . . . . . fexpr 9.5 Graph-to-Tree . . . . . . . . expr 17.25 GraphicP. . . . . . . . . . . expr 8.8 GreaterP. . . . . . . . . . . expr 5.5 Gsort . . . . . . . . . . . . expr 17.22 GtBps . . . . . . . . . . . . expr 21.9 GtConstStr. . . . . . . . . . expr 21.8 GtFixN. . . . . . . . . . . . expr 21.9 GtFltN. . . . . . . . . . . . expr 21.9 GtHEAP. . . . . . . . . . . . expr 21.8 GtID. . . . . . . . . . . . . expr 21.9 GtJfn . . . . . . . . . . . . expr 19.6 GtStr . . . . . . . . . . . . expr 21.8 GtVect. . . . . . . . . . . . expr 21.8 PSL Manual 7 February 1983 Function Index section 25.0 page 25.7 GtWArray. . . . . . . . . . . expr 21.9 GtWrds. . . . . . . . . . . . expr 21.8 HAppend . . . . . . . . . . . expr 17.24 HCons . . . . . . . . . . . . macro 17.24 HCopy . . . . . . . . . . . . macro 17.24 HELP. . . . . . . . . . . . . edit 16.3, 16.13 Help. . . . . . . . . . . . . fexpr 13.7 HelpDir . . . . . . . . . . . expr 19.3 HighHalfWord. . . . . . . . . expr 19.8 Hist. . . . . . . . . . . . . nexpr 13.5 HList . . . . . . . . . . . . nexpr 17.24 HReverse. . . . . . . . . . . expr 17.25 I . . . . . . . . . . . . . . edit 16.13 Id2Int. . . . . . . . . . . . expr 4.10 Id2String . . . . . . . . . . expr 4.10 Id. . . . . . . . . . . . . . expr 22.10 IdApply0. . . . . . . . . . . expr 11.6 IdApply1. . . . . . . . . . . expr 11.6 IdApply2. . . . . . . . . . . expr 11.6 IdApply3. . . . . . . . . . . expr 11.6 IdApply4. . . . . . . . . . . expr 11.6 IdP . . . . . . . . . . . . . expr 4.7 IdSort. . . . . . . . . . . . expr 17.23 IF. . . . . . . . . . . . . . edit 16.13 If. . . . . . . . . . . . . . macro 9.2 If_System . . . . . . . . . . cmacro 19.1 IGetS . . . . . . . . . . . . expr 8.4 IGetV . . . . . . . . . . . . expr 8.4 Implode . . . . . . . . . . . expr 12.27 ImportForeignString . . . . . expr 19.16 Imports . . . . . . . . . . . expr 18.3 In. . . . . . . . . . . . . . macro 12.14 Incr. . . . . . . . . . . . . macro 5.3 IndexError. . . . . . . . . . expr 14.9 Indx. . . . . . . . . . . . . expr 8.5 InFile. . . . . . . . . . . . fexpr 19.6 Init-File-String. . . . . . . expr 13.3 Inp . . . . . . . . . . . . . expr 13.6 INSERT. . . . . . . . . . . . edit 16.13 Inspect . . . . . . . . . . . expr 17.26 Int!-Char . . . . . . . . . . expr 8.10 Int2Id. . . . . . . . . . . . expr 4.10 Int2Str . . . . . . . . . . . expr 19.8 Intern. . . . . . . . . . . . expr 4.9 InternGenSym. . . . . . . . . expr 6.3 InternP . . . . . . . . . . . expr 6.4 InterSection. . . . . . . . . expr 7.8 InterSectionQ . . . . . . . . expr 7.8 IPutS . . . . . . . . . . . . expr 8.5 IPutV . . . . . . . . . . . . expr 8.4 Function Index 7 February 1983 PSL Manual page 25.8 section 25.0 ISizeS. . . . . . . . . . . . expr 8.4 ISizeV. . . . . . . . . . . . expr 8.4 JBits . . . . . . . . . . . . expr 19.9 JConv . . . . . . . . . . . . expr 19.7 Jsys0 . . . . . . . . . . . . expr 19.7 Jsys1 . . . . . . . . . . . . expr 19.7 Jsys2 . . . . . . . . . . . . expr 19.7 Jsys3 . . . . . . . . . . . . expr 19.7 Jsys4 . . . . . . . . . . . . expr 19.7 KillFork. . . . . . . . . . . expr 19.4 LambdaApply . . . . . . . . . expr 11.5 LambdaEvalApply . . . . . . . expr 11.6 LAnd. . . . . . . . . . . . . expr 5.7 LAP . . . . . . . . . . . . . expr 18.10 LapIn . . . . . . . . . . . . expr 12.14 LastCar . . . . . . . . . . . expr 7.5 LastPair. . . . . . . . . . . expr 7.5 LBind1. . . . . . . . . . . . expr 10.9 LC. . . . . . . . . . . . . . edit 16.14 LCL . . . . . . . . . . . . . edit 16.14 LConc . . . . . . . . . . . . expr 7.7 Length. . . . . . . . . . . . expr 7.6 Leq . . . . . . . . . . . . . expr 5.5 LessP . . . . . . . . . . . . expr 5.6 Let!* . . . . . . . . . . . . macro 9.17 Let . . . . . . . . . . . . . macro 9.16 LI. . . . . . . . . . . . . . edit 16.14 LineLength. . . . . . . . . . expr 12.11 List2Set. . . . . . . . . . . expr 7.8 List2SetQ . . . . . . . . . . expr 7.8 List2String . . . . . . . . . expr 4.10 List2Vector . . . . . . . . . expr 4.11 List. . . . . . . . . . . . . fexpr 7.6 Liter . . . . . . . . . . . . expr 12.26 LNot. . . . . . . . . . . . . expr 5.7 LO. . . . . . . . . . . . . . edit 16.14 Load. . . . . . . . . . . . . macro 18.3 LoadTime. . . . . . . . . . . expr 18.5 Log10 . . . . . . . . . . . . expr 5.14 Log2. . . . . . . . . . . . . expr 5.14 Log . . . . . . . . . . . . . expr 5.13 LOr . . . . . . . . . . . . . expr 5.7 LowerCaseP. . . . . . . . . . expr 8.8 LowHalfWord . . . . . . . . . expr 19.8 LP. . . . . . . . . . . . . . edit 16.15 LPosn . . . . . . . . . . . . expr 12.11 LPQ . . . . . . . . . . . . . edit 16.15 LShift. . . . . . . . . . . . expr 5.7 LXOr. . . . . . . . . . . . . expr 5.7 PSL Manual 7 February 1983 Function Index section 25.0 page 25.9 M . . . . . . . . . . . . . . edit 16.15 MacroExpand . . . . . . . . . macro 17.14 MacroP. . . . . . . . . . . . expr 10.7 Main. . . . . . . . . . . . . expr 13.4 Make!-Bytes . . . . . . . . . expr 8.5 Make!-Halfwords . . . . . . . expr 8.5 Make!-String. . . . . . . . . expr 8.2 Make!-Vector. . . . . . . . . expr 8.3 Make!-Words . . . . . . . . . expr 8.5 MakeFCode . . . . . . . . . . expr 10.6 MakeFLambdaLink . . . . . . . expr 10.6 MAKEFN. . . . . . . . . . . . edit 16.16 MakeFUnBound. . . . . . . . . expr 10.6 MakeUnBound . . . . . . . . . expr 6.9 Map . . . . . . . . . . . . . expr 9.14 MapC. . . . . . . . . . . . . expr 9.14 MapCan. . . . . . . . . . . . expr 9.14 MapCar. . . . . . . . . . . . expr 9.14 MapCon. . . . . . . . . . . . expr 9.14 MapList . . . . . . . . . . . expr 9.15 MapObl. . . . . . . . . . . . expr 6.4 MARK. . . . . . . . . . . . . edit 16.16 Max2. . . . . . . . . . . . . expr 5.6 Max . . . . . . . . . . . . . macro 5.6 MBD . . . . . . . . . . . . . edit 16.17 Member. . . . . . . . . . . . expr 7.6 MemQ. . . . . . . . . . . . . expr 7.6 Min2. . . . . . . . . . . . . expr 5.6 Min . . . . . . . . . . . . . macro 5.6 Minus . . . . . . . . . . . . expr 5.4 MinusP. . . . . . . . . . . . expr 5.6 MkQuote . . . . . . . . . . . expr 11.7 MkString. . . . . . . . . . . expr 8.2 MkVect. . . . . . . . . . . . expr 8.3 MM. . . . . . . . . . . . . . expr 19.4 Mod . . . . . . . . . . . . . expr 5.9 MOVE. . . . . . . . . . . . . edit 16.17 N . . . . . . . . . . . . . . edit 16.18 NameFromJfn . . . . . . . . . expr 19.6 NConc . . . . . . . . . . . . expr 7.7 NCons . . . . . . . . . . . . expr 7.3 Ne. . . . . . . . . . . . . . expr 4.6 Neq . . . . . . . . . . . . . macro 4.6 NewId . . . . . . . . . . . . expr 4.9 NewTrBuff . . . . . . . . . . expr 15.6 NEX . . . . . . . . . . . . . edit 16.18 NExprP. . . . . . . . . . . . expr 10.7 Next. . . . . . . . . . . . . macro 9.7 NonCharacterError . . . . . . expr 14.10 NonIDError. . . . . . . . . . expr 14.9 Function Index 7 February 1983 PSL Manual page 25.10 section 25.0 NonIntegerError . . . . . . . expr 14.9 NonNumberError. . . . . . . . expr 14.9 NonPairError. . . . . . . . . expr 14.9 NonPositiveIntegerError . . . expr 14.10 NonSequenceError. . . . . . . expr 14.10 NonStringError. . . . . . . . expr 14.10 NonVectorError. . . . . . . . expr 14.10 Not . . . . . . . . . . . . . expr 4.8 NString!-Capitalize . . . . . expr 8.13 NString!-DownCase . . . . . . expr 8.13 NString!-UpCase . . . . . . . expr 8.13 NTH . . . . . . . . . . . . . edit 16.18 Nth . . . . . . . . . . . . . expr 7.5 Null. . . . . . . . . . . . . expr 4.7 Num . . . . . . . . . . . . . expr 22.10 NumberP . . . . . . . . . . . expr 4.7 NX. . . . . . . . . . . . . . edit 16.19 Off . . . . . . . . . . . . . macro 6.14 OK. . . . . . . . . . . . . . edit 16.3, 16.19 On. . . . . . . . . . . . . . macro 6.14 OneP. . . . . . . . . . . . . expr 5.6 Open. . . . . . . . . . . . . expr 12.4 OpenFork. . . . . . . . . . . expr 19.4 OpenNewJfn. . . . . . . . . . expr 19.5 OpenOldJfn. . . . . . . . . . expr 19.5 Or. . . . . . . . . . . . . . fexpr 4.9 ORF . . . . . . . . . . . . . edit 16.19 ORR . . . . . . . . . . . . . edit 16.19 Out . . . . . . . . . . . . . macro 12.5 P . . . . . . . . . . . . . . edit 16.1, 16.20 Pair. . . . . . . . . . . . . expr 7.11 PairP . . . . . . . . . . . . expr 4.8 Path. . . . . . . . . . . . . expr 19.13 PathIn. . . . . . . . . . . . expr 12.15 Pause . . . . . . . . . . . . expr 13.8 PBind1. . . . . . . . . . . . expr 10.10 PL. . . . . . . . . . . . . . edit 16.1 PList . . . . . . . . . . . . macro 15.12 Plus2 . . . . . . . . . . . . expr 5.4 Plus. . . . . . . . . . . . . macro 5.4 PNth. . . . . . . . . . . . . expr 7.5 Pop . . . . . . . . . . . . . macro 17.15 Posn. . . . . . . . . . . . . expr 12.11 PP. . . . . . . . . . . . . . edit 16.21 Ppf . . . . . . . . . . . . . macro 15.12 PrettyPrint . . . . . . . . . expr 12.11 Prin1 . . . . . . . . . . . . expr 12.8 Prin2 . . . . . . . . . . . . expr 12.8 Prin2L. . . . . . . . . . . . expr 12.11 Prin2T. . . . . . . . . . . . expr 12.12 PSL Manual 7 February 1983 Function Index section 25.0 page 25.11 PrinC . . . . . . . . . . . . expr 12.8 Print . . . . . . . . . . . . expr 12.8 PrintF. . . . . . . . . . . . expr 12.10 PrintScanTable. . . . . . . . expr 12.25 PrintX. . . . . . . . . . . . expr 15.13 Prog1 . . . . . . . . . . . . macro 9.5 Prog2 . . . . . . . . . . . . expr 9.5 Prog. . . . . . . . . . . . . fexpr 9.5 ProgN . . . . . . . . . . . . fexpr 9.4 Prop. . . . . . . . . . . . . expr 6.7 PSetF . . . . . . . . . . . . macro 6.9 PSetQ . . . . . . . . . . . . macro 6.8 Push. . . . . . . . . . . . . macro 17.14 Put . . . . . . . . . . . . . expr 6.5 PutByte . . . . . . . . . . . expr 20.11 PutD. . . . . . . . . . . . . expr 10.2 PutDipthong . . . . . . . . . expr 12.25 PutReadMacro. . . . . . . . . expr 12.25 PutRescan . . . . . . . . . . expr 19.5 PutV. . . . . . . . . . . . . expr 8.3 Pwd . . . . . . . . . . . . . expr 19.13 Quit. . . . . . . . . . . . . expr 13.1 Quote . . . . . . . . . . . . fexpr 11.6 Quotient. . . . . . . . . . . expr 5.4 R . . . . . . . . . . . . . . edit 16.2, 16.21 RadiansToDegrees. . . . . . . expr 5.9 RadiansToDMS. . . . . . . . . expr 5.9 Random. . . . . . . . . . . . expr 5.14 RangeError. . . . . . . . . . expr 14.9 RAtom . . . . . . . . . . . . expr 12.21 Rds . . . . . . . . . . . . . expr 12.5 Read-Init-File. . . . . . . . expr 13.3 Read. . . . . . . . . . . . . expr 12.13 ReadCH. . . . . . . . . . . . expr 12.16 ReadChar. . . . . . . . . . . expr 12.16 Recip . . . . . . . . . . . . expr 5.4 Reclaim . . . . . . . . . . . expr 21.8 RecopyStringToNULL. . . . . . expr 19.8 ReDo. . . . . . . . . . . . . expr 13.6 RelJfn. . . . . . . . . . . . expr 19.5 ReLoad. . . . . . . . . . . . macro 18.3 Remainder . . . . . . . . . . expr 5.4 RemD. . . . . . . . . . . . . expr 10.4 RemFlag1. . . . . . . . . . . expr 6.6 RemFlag . . . . . . . . . . . expr 6.6 RemOb . . . . . . . . . . . . expr 6.4 RemProp . . . . . . . . . . . expr 6.5 RemPropL. . . . . . . . . . . expr 6.5 REPACK. . . . . . . . . . . . edit 16.21 Repeat. . . . . . . . . . . . macro 9.7 Function Index 7 February 1983 PSL Manual page 25.12 section 25.0 ResBtr. . . . . . . . . . . . expr 15.10 Reset . . . . . . . . . . . . expr 13.2, 19.4 Rest. . . . . . . . . . . . . macro 7.5 RestoreEnvironment. . . . . . expr 10.11 Restr . . . . . . . . . . . . expr 15.9 Return. . . . . . . . . . . . expr 9.6 Reverse . . . . . . . . . . . expr 7.9 ReversIP. . . . . . . . . . . expr 7.10 RI. . . . . . . . . . . . . . edit 16.22 RLisp . . . . . . . . . . . . expr 13.6 RO. . . . . . . . . . . . . . edit 16.22 Round . . . . . . . . . . . . expr 5.8 RplacA. . . . . . . . . . . . expr 7.4 RplacD. . . . . . . . . . . . expr 7.4 RplaChar. . . . . . . . . . . expr 8.10 RplacW. . . . . . . . . . . . expr 7.4 RPrint. . . . . . . . . . . . expr 12.11 Run . . . . . . . . . . . . . expr 19.3 RunFork . . . . . . . . . . . expr 19.4 S . . . . . . . . . . . . . . edit 16.22 SAssoc. . . . . . . . . . . . expr 7.10 SAVE. . . . . . . . . . . . . edit 16.22 SaveSystem. . . . . . . . . . expr 13.2 Sec . . . . . . . . . . . . . expr 5.11 SecD. . . . . . . . . . . . . expr 5.11 SECOND. . . . . . . . . . . . edit 16.23 Second. . . . . . . . . . . . macro 7.5 Set . . . . . . . . . . . . . expr 6.7 SetF. . . . . . . . . . . . . macro 6.8 SetIndx . . . . . . . . . . . expr 8.6 SetProp . . . . . . . . . . . expr 6.7 SetQ. . . . . . . . . . . . . fexpr 6.7 SetSub. . . . . . . . . . . . expr 8.6 SetSubSeq . . . . . . . . . . expr 8.6 Shut. . . . . . . . . . . . . macro 12.5 Sin . . . . . . . . . . . . . expr 5.10 SinD. . . . . . . . . . . . . expr 5.10 Size. . . . . . . . . . . . . expr 8.5 Spaces. . . . . . . . . . . . expr 12.12 Sqrt. . . . . . . . . . . . . expr 5.13 Standard!-CharP . . . . . . . expr 8.7 StandardLisp. . . . . . . . . expr 13.6 StartFork . . . . . . . . . . expr 19.4 StdError. . . . . . . . . . . expr 14.9 StdTrace. . . . . . . . . . . expr 15.7 Step. . . . . . . . . . . . . expr 15.3 STOP. . . . . . . . . . . . . edit 16.23 Str2Int . . . . . . . . . . . expr 19.8 Str . . . . . . . . . . . . . expr 22.11 String!-Capitalize. . . . . . expr 8.13 String!-CharP . . . . . . . . expr 8.8 PSL Manual 7 February 1983 Function Index section 25.0 page 25.13 String!-DownCase. . . . . . . expr 8.13 String!-Equal . . . . . . . . expr 8.11 String!-GreaterP. . . . . . . expr 8.11 String!-Left!-Trim. . . . . . expr 8.12 String!-Length. . . . . . . . expr 8.13 String!-LessP . . . . . . . . expr 8.11 String!-Not!-Equal. . . . . . expr 8.12 String!-Not!-GreaterP . . . . expr 8.12 String!-Not!-LessP. . . . . . expr 8.12 String!-Repeat. . . . . . . . expr 8.12 String!-Right!-Trim . . . . . expr 8.12 String!-to!-List. . . . . . . expr 8.13 String!-to!-Vector. . . . . . expr 8.13 String!-Trim. . . . . . . . . expr 8.12 String!-UpCase. . . . . . . . expr 8.12 String!<!=. . . . . . . . . . expr 8.11 String!<!>. . . . . . . . . . expr 8.11 String!<. . . . . . . . . . . expr 8.11 String!=. . . . . . . . . . . expr 8.11 String!>!=. . . . . . . . . . expr 8.11 String!>. . . . . . . . . . . expr 8.11 String2List . . . . . . . . . expr 4.10 String2Vector . . . . . . . . expr 4.11 String. . . . . . . . . . . . nexpr 4.11, 8.2 StringGenSym. . . . . . . . . expr 6.3 StringP . . . . . . . . . . . expr 4.8 Stub. . . . . . . . . . . . . macro 15.12 Sub1. . . . . . . . . . . . . expr 5.5 Sub . . . . . . . . . . . . . expr 8.6 SublA . . . . . . . . . . . . expr 7.12 SubLis. . . . . . . . . . . . expr 7.11 SubSeq. . . . . . . . . . . . expr 8.6 Subst . . . . . . . . . . . . expr 7.11 SubstIP . . . . . . . . . . . expr 7.11 SubString . . . . . . . . . . expr 8.13 SubTypeP. . . . . . . . . . . expr 17.16 SW. . . . . . . . . . . . . . edit 16.23 Swap. . . . . . . . . . . . . expr 19.8 Sys . . . . . . . . . . . . . expr 19.3 System. . . . . . . . . . . . expr 19.14 T . . . . . . . . . . . . . . edit 16.2 Tab . . . . . . . . . . . . . expr 12.12 Take. . . . . . . . . . . . . expr 19.3 Tan . . . . . . . . . . . . . expr 5.10 TanD. . . . . . . . . . . . . expr 5.10 TConc . . . . . . . . . . . . expr 7.7 TerPri. . . . . . . . . . . . expr 12.10 TEST. . . . . . . . . . . . . edit 16.23 THIRD . . . . . . . . . . . . edit 16.23 Third . . . . . . . . . . . . macro 7.5 THROUGH . . . . . . . . . . . edit 16.24 Function Index 7 February 1983 PSL Manual page 25.14 section 25.0 Throw . . . . . . . . . . . . expr 9.18 Time. . . . . . . . . . . . . expr 13.2 Times2. . . . . . . . . . . . expr 5.5 Times . . . . . . . . . . . . macro 5.5 TO. . . . . . . . . . . . . . edit 16.24 TopLoop . . . . . . . . . . . expr 13.4 TotalCopy . . . . . . . . . . expr 8.7 Tr. . . . . . . . . . . . . . macro 15.3, 15.5 TraceCount. . . . . . . . . . expr 15.7 TransferSign. . . . . . . . . expr 5.9 TrCnt . . . . . . . . . . . . macro 15.12 TrIn. . . . . . . . . . . . . macro 15.8 TrOut . . . . . . . . . . . . expr 15.7 Trst. . . . . . . . . . . . . macro 15.3, 15.6 TTY:. . . . . . . . . . . . . edit 16.24 Type. . . . . . . . . . . . . expr 19.3 TypeError . . . . . . . . . . expr 14.9 UnBindN . . . . . . . . . . . expr 10.9 UNBLOCK . . . . . . . . . . . edit 16.24 UnBoundP. . . . . . . . . . . expr 6.10, 10.9 UNDO. . . . . . . . . . . . . edit 16.25 UnFluid . . . . . . . . . . . expr 10.9 Union . . . . . . . . . . . . expr 7.8 UnionQ. . . . . . . . . . . . expr 7.8 Unless. . . . . . . . . . . . macro 9.3 UnQuote . . . . . . . . . . . fexpr 17.13 UnQuoteL. . . . . . . . . . . fexpr 17.13 UnReadChar. . . . . . . . . . expr 12.16 UnTr. . . . . . . . . . . . . macro 15.3, 15.9 UnTrst. . . . . . . . . . . . macro 15.3, 15.9 Unwind!-All . . . . . . . . . macro 9.19 Unwind!-Protect . . . . . . . macro 9.19 UP. . . . . . . . . . . . . . edit 16.2, 16.25 UpbV. . . . . . . . . . . . . expr 8.4 UpperCaseP. . . . . . . . . . expr 8.8 UsageTypeError. . . . . . . . expr 14.9 User-HomeDir-String . . . . . expr 13.3 ValueCell . . . . . . . . . . expr 6.9 VDir. . . . . . . . . . . . . expr 19.3 Vector2List . . . . . . . . . expr 4.11 Vector2String . . . . . . . . expr 4.11 Vector. . . . . . . . . . . . nexpr 4.11, 8.4 VectorP . . . . . . . . . . . expr 4.8 WaitFork. . . . . . . . . . . expr 19.4 WAnd. . . . . . . . . . . . . expr 20.10 WDifference . . . . . . . . . expr 20.10 WEQ . . . . . . . . . . . . . expr 20.10 WGEQ. . . . . . . . . . . . . expr 20.10 WGetV . . . . . . . . . . . . macro 20.11 PSL Manual 7 February 1983 Function Index section 25.0 page 25.15 WGreaterP . . . . . . . . . . expr 20.10 When. . . . . . . . . . . . . macro 9.3 While . . . . . . . . . . . . macro 9.6 WLEQ. . . . . . . . . . . . . expr 20.11 WLessP. . . . . . . . . . . . expr 20.10 WNEQ. . . . . . . . . . . . . expr 20.10 WNot. . . . . . . . . . . . . expr 20.10 WOr . . . . . . . . . . . . . expr 20.10 WPlus2. . . . . . . . . . . . expr 20.10 WPutV . . . . . . . . . . . . macro 20.11 WQuotient . . . . . . . . . . expr 20.10 WRemainder. . . . . . . . . . expr 20.10 WriteChar . . . . . . . . . . expr 12.6 Wrs . . . . . . . . . . . . . expr 12.5 WShift. . . . . . . . . . . . expr 20.10 WTimes2 . . . . . . . . . . . expr 20.10 WXor. . . . . . . . . . . . . expr 20.10 XCons . . . . . . . . . . . . expr 7.3 XJsys0. . . . . . . . . . . . expr 19.6 XJsys1. . . . . . . . . . . . expr 19.7 XJsys2. . . . . . . . . . . . expr 19.7 XJsys3. . . . . . . . . . . . expr 19.7 XJsys4. . . . . . . . . . . . expr 19.7 XTR . . . . . . . . . . . . . edit 16.25 Xword . . . . . . . . . . . . expr 19.8 YesP. . . . . . . . . . . . . expr 13.8 ZeroP . . . . . . . . . . . . expr 5.6 |
Added psl-1983/lpt/26-glo-index.lpt version [34d649eab5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL Manual 7 February 1983 Global Index section 26.0 page 26.1 CHAPTER 26 CHAPTER 26 CHAPTER 26 INDEX OF GLOBALS AND SWITCHES INDEX OF GLOBALS AND SWITCHES INDEX OF GLOBALS AND SWITCHES The following is an alphabetical list of the PSL global variables, with the page on which they are defined. !$BREAK!$ . . . . . . . . . . global 14.8 !$ERROR!$ . . . . . . . . . . global 14.1, 14.2 !*BACKTRACE . . . . . . . . . switch 14.1, 14.2 !*BREAK . . . . . . . . . . . switch 14.4, 14.8 !*BTR . . . . . . . . . . . . switch 15.10 !*BTRSAVE . . . . . . . . . . switch 15.10 !*COMP. . . . . . . . . . . . switch 10.3, 18.2 !*COMPRESSING . . . . . . . . switch 12.13, 12.16, 12.21 !*ContinuableError. . . . . . switch 14.3 !*CREFSUMMARY . . . . . . . . switch 17.3 !*DEFN. . . . . . . . . . . . switch 18.3 !*ECHO. . . . . . . . . . . . switch 12.2, 12.14 !*EMsgP . . . . . . . . . . . switch 13.5 !*EOLINSTRINGOK . . . . . . . switch 12.21 !*ERFG. . . . . . . . . . . . switch 18.23 !*GC. . . . . . . . . . . . . switch 21.7 !*INSTALL . . . . . . . . . . switch 15.10, 15.14 !*INSTALLDESTROY. . . . . . . switch 18.23 !*INT . . . . . . . . . . . . switch 18.23 !*MODULE. . . . . . . . . . . switch 18.7 !*MSGP. . . . . . . . . . . . switch 14.2 !*NOFRAMEFLUID. . . . . . . . switch 18.23 !*NOLINKE . . . . . . . . . . switch 18.6 !*NOTRARGS. . . . . . . . . . switch 15.6 !*ORD . . . . . . . . . . . . switch 18.6 !*PECHO . . . . . . . . . . . switch 13.5 !*PGWD. . . . . . . . . . . . switch 18.13 !*PLAP. . . . . . . . . . . . switch 18.7, 18.13 !*PVAL. . . . . . . . . . . . switch 13.5 !*PWRDS . . . . . . . . . . . switch 18.7, 18.13 !*R2I . . . . . . . . . . . . switch 18.6 !*RAISE . . . . . . . . . . . switch 12.19, 12.21 !*REDEFMSG. . . . . . . . . . switch 10.3 !*SAVECOM . . . . . . . . . . switch 18.13 !*SAVEDEF . . . . . . . . . . switch 18.13 !*SAVENAMES . . . . . . . . . switch 15.14 !*SHOWDEST. . . . . . . . . . switch 18.23 !*SYSLISP . . . . . . . . . . switch 18.24 !*TIME. . . . . . . . . . . . switch 13.5 !*TRACE . . . . . . . . . . . switch 15.7 !*TRACEALL. . . . . . . . . . switch 15.10, 15.14 !*TRCOUNT . . . . . . . . . . switch 15.11 !*UNSAFEBINDER. . . . . . . . switch 18.24 !*USEREGFLUID . . . . . . . . switch 18.24 !*USERMODE. . . . . . . . . . switch 10.3 Global Index 7 February 1983 PSL Manual page 26.2 section 26.0 \CURRENTPACKAGE!* . . . . . . global 6.10 \PACKAGENAMES!* . . . . . . . global 6.10 BREAKEVALUATOR!*. . . . . . . global 14.4 BreakIn!* . . . . . . . . . . global 12.3, 14.8 BreakLevel!*. . . . . . . . . global 14.4 BreakOut!*. . . . . . . . . . global 12.3, 14.8 BREAKPRINTER!*. . . . . . . . global 14.4 BREAKREADER!* . . . . . . . . global 14.4 CRLF. . . . . . . . . . . . . global 19.2 CurrentReadMacroIndicator!* . global 12.17 CurrentScanTable!*. . . . . . global 12.17, 12.18, 12.21, 12.25 Date!*. . . . . . . . . . . . global 13.3 DFPRINT!* . . . . . . . . . . global 18.3 EMSG!*. . . . . . . . . . . . global 14.2 ERRORFORM!* . . . . . . . . . global 14.3, 14.4, 14.5 ERRORHANDLERS!* . . . . . . . global 14.10 ERROUT!*. . . . . . . . . . . global 12.4, 12.10 GCKNT!* . . . . . . . . . . . global 21.7 GCTime!*. . . . . . . . . . . global 13.5 HelpIn!*. . . . . . . . . . . global 12.3, 13.7 HelpOut!* . . . . . . . . . . global 12.3, 13.7 HistoryCount!*. . . . . . . . global 13.6 HistoryList!* . . . . . . . . global 13.6 IgnoredInBacktrace!*. . . . . global 14.5 IN!*. . . . . . . . . . . . . global 12.3, 12.5, 12.13 InitForms!* . . . . . . . . . global 13.5 InterpreterFunctions!*. . . . global 14.5 LASTACTUALREG . . . . . . . . global 18.24 LispBanner!*. . . . . . . . . global 13.2 LISPSCANTABLE!* . . . . . . . global 12.21 LoadDirectories!* . . . . . . global 18.4 LoadExtensions!*. . . . . . . global 18.4 MaxBreakLevel!* . . . . . . . global 14.4 MAXLEVEL. . . . . . . . . . . global 16.12 MAXNARGS. . . . . . . . . . . global 18.24 NIL . . . . . . . . . . . . . global 6.15 NOLIST!*. . . . . . . . . . . global 17.3 OPTIONS!* . . . . . . . . . . global 18.3 OUT!* . . . . . . . . . . . . global 12.3, 12.5 OUTPUTBASE!*. . . . . . . . . global 12.20, 12.24 PSL Manual 7 February 1983 Global Index section 26.0 page 26.3 PATHIN!*. . . . . . . . . . . global 12.15 PLEVEL. . . . . . . . . . . . global 16.1 PPFPRINTER!*. . . . . . . . . global 15.15 PrinLength. . . . . . . . . . global 12.12 PrinLevel . . . . . . . . . . global 12.12 PROMPTSTRING!*. . . . . . . . global 12.4 PROPERTYPRINTER!* . . . . . . global 15.15 PUTDHOOK!*. . . . . . . . . . global 15.14 RandomSeed. . . . . . . . . . global 5.14 RLISPSCANTABLE!*. . . . . . . global 12.21, 12.22 SPECIALCLOSEFUNCTION!*. . . . global 12.4, 12.6 SPECIALRDSACTION!*. . . . . . global 12.5, 12.6 SPECIALREADFUNCTION!* . . . . global 12.4, 12.6 SPECIALWRITEFUNCTION!*. . . . global 12.4, 12.6 SPECIALWRSACTION!*. . . . . . global 12.5, 12.6 StartupName!* . . . . . . . . global 19.17 STDIN!* . . . . . . . . . . . global 12.2, 12.3, 12.5 STDOUT!*. . . . . . . . . . . global 12.2, 12.3, 12.5 STUBPRINTER!* . . . . . . . . global 15.15 STUBREADER!*. . . . . . . . . global 15.15 SymbolFileName!*. . . . . . . global 19.16 T . . . . . . . . . . . . . . global 6.15 ThrowSignal!* . . . . . . . . global 9.17 ThrowTag!*. . . . . . . . . . global 9.17 TOKTYPE!* . . . . . . . . . . global 12.16, 12.24 TopLoopEval!* . . . . . . . . global 13.4, 14.8 TopLoopLevel!*. . . . . . . . global 13.5 TopLoopName!* . . . . . . . . global 13.4 TopLoopPrint!*. . . . . . . . global 13.4, 14.8 TopLoopRead!* . . . . . . . . global 13.4, 14.8 TRACEMAXLEVEL!* . . . . . . . global 15.8 TRACEMINLEVEL!* . . . . . . . global 15.8 TRACENTRYHOOK!* . . . . . . . global 15.14 TRACEXITHOOK!*. . . . . . . . global 15.14 TRACEXPANDHOOK!*. . . . . . . global 15.15 TREXPRINTER!* . . . . . . . . global 15.15 TRINSTALLHOOK!* . . . . . . . global 15.15 TRPRINTER!* . . . . . . . . . global 15.16 TRSPACE!* . . . . . . . . . . global 15.16 UnixArgs!*. . . . . . . . . . global 19.17 UPFINDFLG . . . . . . . . . . global 16.12 |
Added psl-1983/lpt/main-start.red version [afac7fb3ce].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % MAIN-START.RED - First routine called on startup % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 15 September 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL-20>MAIN-START.RED.4, 5-Oct-82 10:42:14, Edit by BENSON % Added call to EvalInitForms in MAIN!. on SysLisp; internal WConst StackSize = 4000; internal WArray Stack[StackSize]; exported WVar StackLowerBound = &Stack[0], StackUpperBound = &Stack[StackSize]; external WVar ST; internal WConst MaxArgBlock = (MaxArgs - MaxRealRegs) - 1; % 0..MaxArgBlock are arguments (MaxRealRegs + 1)..MaxArgs exported WArray ArgumentBlock[MaxArgBlock]; exported WArray HashTable[MaxObArray/2]; lap '((!*entry Main!. expr 0) Forever (move (reg st) (lit (halfword (minus (WConst StackSize)) (difference (WConst Stack) 1)))) (move (reg nil) (fluid nil)) (!*CALL pre!-main) (jrst Forever) ); syslsp procedure Reset(); Throw('Reset, 'Reset); syslsp procedure pre!-main(); << ClearBindings(); ClearIO(); EvalInitForms(); if Catch('Reset, Main()) = 'Reset then pre!-main() >>; syslsp procedure Main(); %. initialization function % % A new system can be created by redefining this function to call whatever % top loop is desired. % << InitCode(); % special code accumulated in compiler SymFnc IDLoc Main := SymFnc IDLoc StandardLisp; % don't do it again StandardLisp() >>; off SysLisp; END; |
Added psl-1983/minimal-logical-names.cmd version [41ea521b48].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | ; Officially recognized logical names for MINIMAL ; PSL system, in single directory ; EDIT <psl> into <name> as appropriate define psl: <psl> ! Executable files and miscellaneous define pc: <psl> ! Compiler sources define p20c: <psl> ! 20 Specific Compiler sources define pd: <psl> ! Documentation files define pnd: <psl> ! NMODE Documentation files define pe: <psl> ! EMODE support and drivers define pg: <psl> ! GLISP source define ph: <psl> ! Help files define pk: <psl> ! Kernel Source files define p20k: <psl> ! 20 Specific Kernel Sources define pl: <psl> ! LAP files define plpt: <psl> ! Printer version of Documentation define pn: <psl> ! NMODE editor files define pnk: <psl> ! PSL Non Kernel source files define pt: <psl> ! PSL Test files define p20t: <psl> ! PSL 20 Specific Test files define pu: <psl> ! Utility program sources define p20u: <psl> ! 20 specific Utility files define pw: <psl> ! NMODE Window files take |
Added psl-1983/minimal-restore.ctl version [b35c78836e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; Used to retrieve subset of ssnames for MINIMAL PSL system ; First edit MINIMAL-LOGICAL-NAMES.CMD to reflect <name> ; then TAKE to install names ; then BUILD sub-directories or single directory ; then mount TAPE, def X: @DUMPER *tape X: *density 1600 *files *account system-default *restore <*>*.* PSL:*.* *skip 4 *restore <*>*.* PE:*.* *skip 1 *restore <*>*.* PH:*.* *skip 2 *restore <*>*.* PL:*.* *skip 1 *restore <*>*.* PN:*.* *skip 3 *restore <*>*.* PU:*.* *skip 1 *restore <*>*.* PW:*.* *rewind *unload *exit |
Added psl-1983/news-28-aug-82.txt version [01c69b30f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 30-Jul-82 17:06:17-PDT,2293;000000000001 Date: 30 Jul 1982 1706-PDT From: Alan Snyder <AS> Subject: NEW EMODE To: PSL-News: ;, PSL-Users: ; cc: AS ------------------------------ EMODE Changes ------------------------------ A new PSL has been installed with the following changes made to EMODE: 1. C-X C-R (Read File) now replaces the contents of the current buffer with the contents of the file, instead of inserting the contents of the file at the current location in the buffer. This is an INCOMPATIBLE change. (If you want to insert a file, you can first read it into an auxiliary buffer.) 2. File INPUT and OUTPUT have been speeded up greatly (by a factor of 5). Still noticably slower than EMACS, however. 3. Three bugs in file I/O have been fixed: (a) EMODE no longer treats a ^Z in a file as an end-of-file mark; (b) EMODE will no longer lose the last line of a file should it lack a terminating CRLF; (c) EMODE no longer appends a spurious blank line when writing to a file. 4. Many more EMACS commands have been implemented (see list below). Please note that Lisp Indentation (available using TAB, LineFeed, and C-M-Q) makes many bad choices. These deficiencies are known, but it was decided that in this case something was better than nothing. Complaints about indentation are considered redundant. Send bug reports to "PSL@Hulk". New EMODE commands: C-Q (Quoted Insert) M-\ (Delete Horizontal Space) C-X C-O (Delete Blank Lines) M-M and C-M-M (Back to Indentation) M-^ (Delete Indentation) M-@ (Mark Word) C-X H (Mark Whole Buffer) C-M-@ (Mark Sexp) Tab (Indent for Lisp) LineFeed (Indent New Line) C-M-U (Backward Up List) [ should also be C-M-( ] C-M-O (Forward Up List) [ should be C-M-) ] C-M-A and C-M-[ (Beginning of Defun) C-M-D (Down List) C-M-E and C-M-] (End of Defun) C-M-H (Mark Defun) C-M-N (Next List) C-M-P (Previous List) C-M-Q (Indent Sexp) M-( (Insert Parens) M-) (Move over Paren) ------------------------------------------------------------------------------- ------- 10-Aug-82 17:02:41-PDT,1652;000000000001 Date: 10 Aug 1982 1702-PDT From: Cris Perdue <Perdue> Subject: Latest, hottest PSL news To: PSL-News: ;, PSL-Users: ; PSL NEWS FLASH!! -- August 10, 1982 CATCH An implementation of CATCH with "correct" semantics is on its way. Eric Benson has an implementation that allows code for the body of the CATCH to be compiled in line. Variables used free inside the body will not have to be declared fluid. Unhandled exceptions will, unfortunately, continue to result in abort to the top level. BUG FIXES Be sure to peruse PSL:BUGS.TXT. In addition to an invaluable compilation of commentary, bug reports and just plain flaming, this file contains reports of some fixes to bugs! TOKEN SCANNER FOUND WANTING The current PSL token scanner has been tried in the balance and found wanting. Eric Benson says it was ripped off from some other token scanner in rather a hurry and needs to be replaced. PACKAGE SYSTEM ALSO FOUND WANTING Sources close to Doug Lanam report that the PSL "package system" is not adequate. We asked Martin Griss, "What about the package system?". He admitted the inadequacy, calling the package system "experimental" and saying that the fasloader needs to know about packages. EMODE IMPROVED AND DOCUMENTED Some improvements to EMODE are described in the key documentation file PSL:HP-PSL.IBM (and .LPT). Enhancements continue at a rapid pace, leading one experienced observer to comment, "Looks like Alan has really been tearing into EMODE -- impressive!". The file PE:DISPATCH.DOC contains some key information on customization of EMODE. More reports to come. ------- 16-Aug-82 09:59:32-PDT,520;000000000001 Date: 16 Aug 1982 0959-PDT From: Alan Snyder <AS> Subject: New PSL To: PSL-News: ;, PSL-Users: ; cc: AS A new version of "NPSL" has been installed with the following changes: * EMODE now uses clear-EOL for faster redisplay. * EMODE's start-up glitches have been removed. EMODE will now start up in 1-window mode. * A "compile" command has been added; you can now say "PSL compile foo" to EXEC to compile the file "foo.sl". (This feature has been added to both PSL and NPSL.) ------- |
Added psl-1983/news-8-nov-82.txt version [a43320fd44].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | New PSL Changes (8 November 1982) ---- PSL Changes ------------------------------------------------------------- * The major change in PSL is that CATCH/THROW has been reimplemented to conform to the Common Lisp definition (see Section 7.10 of the Common Lisp manual). In particular, CATCH has been changed to a special form so that its second argument is evaluated only once, instead of twice. THIS IS AN INCOMPATIBLE CHANGE: if you use CATCH, you must change your programs. For example, if you wrote: (catch 'foo (list 'frobnicate x y z)) you should change it to: (catch 'foo (frobnicate x y z)) One aspect of this change is that an "unhandled" throw is now reported as an error in the context of the throw, rather than (as before) aborting to top-level and restarting the job. Also implemented are UNWIND-PROTECT, CATCH-ALL, and UNWIND-ALL, as described in the Common Lisp manual, with the exception that the catch-function in CATCH-ALL and UNWIND-ALL should expect exactly 2 arguments. Note that in Common Lisp, the proper way to catch any throw is to use CATCH-ALL, not CATCH with a tag of NIL. * A related change is that the RESET function is now implemented by THROWing 'RESET, which is caught at the top-level. Thus, UNWIND-PROTECTs cannot be circumvented by RESET. ---- NMODE Changes ----------------------------------------------------------- New Features: * C-X C-B now enters a DIRED-like "Buffer Browser" that allows you to select a buffer, delete buffers, etc. * DIRED and the Buffer Browser can now operate in a split-screen mode, where the upper window is used for displaying the buffer/file list and the bottom window is used to examine a particular buffer/file. This mode is enabled by setting the variable BROWSER-SPLIT-SCREEN to T. If this variable is NIL, then DIRED and the Buffer Browser will automatically start up in one window mode. * M-X Apropos has been implemented. It will show you all commands whose corresponding function names contain a given string. Thus, if you enter "window", you will see all commands whose names include the string "window", such as "ONE-WINDOW-COMMAND". * M-X Auto Fill Mode has been implemented by Jeff Soreff, along with C-X . (Set Fill Prefix) and C-X F (Set Fill Column). If you want NMODE to start up in Auto Fill mode, put the following in your NMODE.INIT file: (activate-minor-mode auto-fill-mode) * NMODE now attempts to display a message whenever PSL is garbage-collecting. This feature is not 100% reliable: sometimes a garbage collect will happen and no message will be displayed. Minor Improvements: * C-N now extends the buffer (like EMACS) if typed without a command argument while on the last line of the buffer. * Lisp break handling has been made more robust. In particular, NMODE now ensures that IN* and OUT* are set to reasonable values. * The OUTPUT buffer now starts out with the "modified" attribute ("*") off. * The implementation of command prefix characters (i.e., C-X, M-X, C-], and Escape) and command arguments (i.e., C-U, etc.) has changed. The most visible changes are that C-U, etc. echo differently, and that Escape can now be followed by bit-prefix characters. (In other words, NMODE will recognize "Escape ^\ E" as Esc-M-E, rather than "Esc-C-\ E"; the 9836 terminal emulator has been modified to generate such escape sequences under some circumstances.) NMODE customizers may be interested to know that all of these previously-magic characters can now be redefined (on a per-mode basis, even), just like any other character. * If you are at or near the end of the buffer, NMODE will put the current line closer to the bottom of the screen when it adjusts the window. * C-X C-F (Find File) and the Dired 'E' command will no longer "find" an incorrect version of the specified file, should one happen to already be in a buffer. * The 'C' (continue) command to the PSL break loop now works again. * The "NMODE" indicator on the current window's mode line no longer disappears when the user is entering string input. * The command C-X 4 F (Find File in Other Window) now sets the buffer's file name properly. |
Added psl-1983/news-8-oct-82.txt version [a43320fd44].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | New PSL Changes (8 November 1982) ---- PSL Changes ------------------------------------------------------------- * The major change in PSL is that CATCH/THROW has been reimplemented to conform to the Common Lisp definition (see Section 7.10 of the Common Lisp manual). In particular, CATCH has been changed to a special form so that its second argument is evaluated only once, instead of twice. THIS IS AN INCOMPATIBLE CHANGE: if you use CATCH, you must change your programs. For example, if you wrote: (catch 'foo (list 'frobnicate x y z)) you should change it to: (catch 'foo (frobnicate x y z)) One aspect of this change is that an "unhandled" throw is now reported as an error in the context of the throw, rather than (as before) aborting to top-level and restarting the job. Also implemented are UNWIND-PROTECT, CATCH-ALL, and UNWIND-ALL, as described in the Common Lisp manual, with the exception that the catch-function in CATCH-ALL and UNWIND-ALL should expect exactly 2 arguments. Note that in Common Lisp, the proper way to catch any throw is to use CATCH-ALL, not CATCH with a tag of NIL. * A related change is that the RESET function is now implemented by THROWing 'RESET, which is caught at the top-level. Thus, UNWIND-PROTECTs cannot be circumvented by RESET. ---- NMODE Changes ----------------------------------------------------------- New Features: * C-X C-B now enters a DIRED-like "Buffer Browser" that allows you to select a buffer, delete buffers, etc. * DIRED and the Buffer Browser can now operate in a split-screen mode, where the upper window is used for displaying the buffer/file list and the bottom window is used to examine a particular buffer/file. This mode is enabled by setting the variable BROWSER-SPLIT-SCREEN to T. If this variable is NIL, then DIRED and the Buffer Browser will automatically start up in one window mode. * M-X Apropos has been implemented. It will show you all commands whose corresponding function names contain a given string. Thus, if you enter "window", you will see all commands whose names include the string "window", such as "ONE-WINDOW-COMMAND". * M-X Auto Fill Mode has been implemented by Jeff Soreff, along with C-X . (Set Fill Prefix) and C-X F (Set Fill Column). If you want NMODE to start up in Auto Fill mode, put the following in your NMODE.INIT file: (activate-minor-mode auto-fill-mode) * NMODE now attempts to display a message whenever PSL is garbage-collecting. This feature is not 100% reliable: sometimes a garbage collect will happen and no message will be displayed. Minor Improvements: * C-N now extends the buffer (like EMACS) if typed without a command argument while on the last line of the buffer. * Lisp break handling has been made more robust. In particular, NMODE now ensures that IN* and OUT* are set to reasonable values. * The OUTPUT buffer now starts out with the "modified" attribute ("*") off. * The implementation of command prefix characters (i.e., C-X, M-X, C-], and Escape) and command arguments (i.e., C-U, etc.) has changed. The most visible changes are that C-U, etc. echo differently, and that Escape can now be followed by bit-prefix characters. (In other words, NMODE will recognize "Escape ^\ E" as Esc-M-E, rather than "Esc-C-\ E"; the 9836 terminal emulator has been modified to generate such escape sequences under some circumstances.) NMODE customizers may be interested to know that all of these previously-magic characters can now be redefined (on a per-mode basis, even), just like any other character. * If you are at or near the end of the buffer, NMODE will put the current line closer to the bottom of the screen when it adjusts the window. * C-X C-F (Find File) and the Dired 'E' command will no longer "find" an incorrect version of the specified file, should one happen to already be in a buffer. * The 'C' (continue) command to the PSL break loop now works again. * The "NMODE" indicator on the current window's mode line no longer disappears when the user is entering string input. * The command C-X 4 F (Find File in Other Window) now sets the buffer's file name properly. |
Added psl-1983/news.txt version [fd57abd0f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 28-Sep-82 17:50:20-PDT,3097;000000000000 Date: 28 Sep 1982 1750-PDT From: Alan Snyder <AS> Subject: new PSL!!!! To: PSL-News: ;, PSL-Users: ; cc: AS Important Change to PSL! We have installed a new version of PSL on HULK. It contains a number of significant changes which are described here. In addition, you must change your LOGIN.CMD file to TAKE PSL:LOGICAL-NAMES.CMD instead of <PSL>LOGICAL-NAMES.CMD. The <PSL> directory will disappear soon, so make this change right away! [These changes, except for NMODE, will appear on THOR and HEWEY shortly. There are no immediate plans to move NMODE to the Vax.] Summary of changes: * If you run "PSL", you will now get a PSL that contains the NMODE editor, which is a replacement for EMODE. PSL will start up in the editor, instead of the PSL listen loop. You can easily get back to the PSL listen loop from NMODE by typing C-] L. NMODE is a decent subset of EMACS, so if you are familiar with EMACS you should be able to use NMODE without too much difficulty. If you are familiar with EMODE, you should read the file PSL:NMODE-GUIDE.TXT, which explains the differences between NMODE and EMODE. A printed copy of this memo, including the NMODE command chart, is available in the documentation area next to Helen Asakawa's office. * The "PSL" program (what you get when you say "PSL" to EXEC) no longer contains the PSL compiler. Instead, there is a separate program for compiling (Lisp) files. To compile a file "FOO.SL", give the command "PSLCOMP FOO" to EXEC. PSLCOMP will produce a binary file "FOO.B" that can then be LOADed or FASLINed. To run the compiler interactively, just say "PSLCOMP" to EXEC. * The PSL directories that contain the source and binaries for all PSL modules have been moved to a private structure called SS: (the directories are now SS:<PSL*>). The old PSL directories (PS:<PSL*>) will disappear soon. In addition, the new directories have been reorganized somewhat to better reflect the structure of the implementation. The file PSL:-THIS-.DIRECTORY contains a brief description of the new structure. If you have used logical names to refer to PSL directories, then this change should not cause too many problems. * A number of small bug fixes and improvements have been made. The most notable improvements are (1) a more readable backtrace, (2) a better prettyprinter, and (3) the definition of a "complete" set of I/O functions taking an explicit channel argument (these functions all have names like ChannelTerpri, where Terpri is an example of an I/O function that uses the default I/O channels). The file PSL:BUG-FIX.LOG contains an exhaustive listing of the recent changes. The documentation has been updated to reflect these changes. The following new or revised documents are available in the documentation area next to Helen Asakawa's office: Notes on PSL at HP DEC-20 PSL New Users' Guide NMODE for EMODE Users How to customize NMODE We have made "documentation packets" containing copies of these documents. Users are encouraged to pick up a copy! ------- 11-Oct-82 15:55:41-PDT,5771;000000000000 Date: 11 Oct 1982 1555-PDT From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; cc: AS PSL NEWS - 11 October 1982 A new PSL has been installed on Hulk and Hewey. There are a number of improvements, plus some INCOMPATIBLE changes (see below). A most noticable change (on Hulk) is that PSL no longer automatically starts up in the NMODE editor. However, if you want PSL to start up in the editor, you can still make this happen using another new feature, INIT files (see below). Otherwise, you can explicitly enter NMODE by invoking the function NMODE, with no arguments. In addtion, NMODE now supports the extended VT52 emulator on the 9836 (get the latest version from Tracy). (No, NMODE is not yet installed on Hewey.) ------------------------------------------------------------------------------- INCOMPATIBLE CHANGES TO PSL: ------------------------------------------------------------------------------- This latest version of PSL has 3 changes which may require some application programs to be changed: 1. SAVESYSTEM SaveSystem now takes 3 arguments. The first argument is the banner, the second is the file to be written, and the third is a list of forms to evaluated when the new core image is started. For example: (SaveSystem "PSL 3.1" "PSL.EXE" '((InitializeInterrupts))) 2. DUMPLISP Dumplisp now takes 1 argument, the file to be written. For example: (Dumplisp "PSL.EXE") 3. DSKIN Dskin has been changed from a FEXPR to a single-argument EXPR. This should only affect calls to DSKIN with multiple arguments. They will have to be changed to several calls, each with one argument. 4. BR and UNBR The functions BR and UNBR are no longer part of PSL. These functions provided a facility for breaking on entry and exit to specific functions. However, they didn't work very well and no one has figured out how to make them work, so they have been removed. Send complaints to PSL. ------------------------------------------------------------------------------- MAJOR IMPROVEMENTS TO PSL: ------------------------------------------------------------------------------- The following features have been added to PSL: 1. Init files When PSL, RLISP, or PSLCOMP (note: not BARE-PSL) is executed, if a file PSL.INIT, RLISP.INIT, or PSLCOMP.INIT, respectively, is in your home (login) directory, it will be read and evaluated. This allows you to automatically customize your Lisp environment. (The init files are .pslrc, .rlisprc, and .pslcomprc on the Vax.) If you want PSL to come up in NMODE, include the statement (setf nmode-auto-start T) in your PSL.INIT file. 2. Prinlevel and Prinlength The variables PRINLEVEL and PRINLENGTH now exist, as described in the Common Lisp Reference Manual. These variables allow you to limit the depth of printing of nested structures and the number of elements of structured objects printed. These variables affect Prin1 and Prin2 (Princ) and those functions that use them (Printf, Print). They do not currently affect Prettyprint, although this may be done in the future. The Printx function now properly handles circular vectors. ------------------------------------------------------------------------------- CHANGES TO NMODE: ------------------------------------------------------------------------------- * NMODE also supports init files (this isn't new, but wasn't stressed in previous documentation). When NMODE starts up, it will read and execute the file NMODE.INIT in the user's home (login) directory. This file should contain PSL (Lisp) forms. * NMODE now reads a default init file if the user has no personal init file. The name of this default init file is "PSL:NMODE.INIT". If you make your own NMODE.INIT file, you should consider including in it the statement "(nmode-read-and-evaluate-file nmode-default-init-file-name)", which will execute the default init file. * NMODE now supports the 9836 VT52 emulator (which has recently been extended to accept commands to change the display enhancement). The default NMODE init file will set up the NMODE VT52 driver if the system terminal type is VT52. * NMODE no longer always starts up in the editor after it is RESET, ABORTed, or ^C'ed and STARTed. It will only restart in the editor if it was in the editor beforehand. * NMODE will now read and write files containing stray CRs. * M-X command completion is more like EMACS. * Typing an undefined command now tells you what command you typed. * New commands: C-X C-L (Lowercase Region) C-X C-U (Uppercase Region) C-X E (Exchange Windows) C-X ^ (Grow Window) M-' (Upcase Digit) M-C (Uppercase Initial) M-L (Lowercase Word) M-U (Uppercase Word) M-X Append to File M-X DIRED M-X Delete File M-X Delete and Expunge File M-X Edit Directory M-X Find File M-X Insert Buffer M-X Insert File M-X Kill Buffer M-X Kill File M-X List Buffers M-X Prepend to File M-X Query Replace M-X Replace String M-X Save All Files M-X Select Buffer M-X Undelete File M-X Visit File M-X Write File M-X Write Region (Case conversion commands contributed by Jeff Soreff) * Some bugs relating to improper window adjustment have been fixed. For example, when the bottom window "pops up", the top window will now be adjusted. Also, C-X O now works properly in 1-window mode when the two windows refer to the same buffer (i.e., it switches between two independent buffer positions). * Bug fix: It should no longer be possible to find a "killed" buffer in a previously unexposed window. ------- 9-Nov-82 08:17:56-PST,4505;000000000000 Date: 9 Nov 1982 0817-PST From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; A new version of PSL has been installed on Hulk. Here are the details: New PSL Changes (9 November 1982) ---- PSL Changes ------------------------------------------------------------- * The major change in PSL is that CATCH/THROW has been reimplemented to conform to the Common Lisp definition (see Section 7.10 of the Common Lisp manual). In particular, CATCH has been changed to a special form so that its second argument is evaluated only once, instead of twice. THIS IS AN INCOMPATIBLE CHANGE: if you use CATCH, you must change your programs. For example, if you wrote: (catch 'foo (list 'frobnicate x y z)) you should change it to: (catch 'foo (frobnicate x y z)) One aspect of this change is that an "unhandled" throw is now reported as an error in the context of the throw, rather than (as before) aborting to top-level and restarting the job. Also implemented are UNWIND-PROTECT, CATCH-ALL, and UNWIND-ALL, as described in the Common Lisp manual, with the exception that the catch-function in CATCH-ALL and UNWIND-ALL should expect exactly 2 arguments. Note that in Common Lisp, the proper way to catch any throw is to use CATCH-ALL, not CATCH with a tag of NIL. * A related change is that the RESET function is now implemented by THROWing 'RESET, which is caught at the top-level. Thus, UNWIND-PROTECTs cannot be circumvented by RESET. ---- NMODE Changes ----------------------------------------------------------- New Features: * C-X C-B now enters a DIRED-like "Buffer Browser" that allows you to select a buffer, delete buffers, etc. * DIRED and the Buffer Browser can now operate in a split-screen mode, where the upper window is used for displaying the buffer/file list and the bottom window is used to examine a particular buffer/file. This mode is enabled by setting the variable BROWSER-SPLIT-SCREEN to T. If this variable is NIL, then DIRED and the Buffer Browser will automatically start up in one window mode. * M-X Apropos has been implemented. It will show you all commands whose corresponding function names contain a given string. Thus, if you enter "window", you will see all commands whose names include the string "window", such as "ONE-WINDOW-COMMAND". * M-X Auto Fill Mode has been implemented by Jeff Soreff, along with C-X . (Set Fill Prefix) and C-X F (Set Fill Column). If you want NMODE to start up in Auto Fill mode, put the following in your NMODE.INIT file: (activate-minor-mode auto-fill-mode) * NMODE now attempts to display a message whenever PSL is garbage-collecting. This feature is not 100% reliable: sometimes a garbage collect will happen and no message will be displayed. Minor Improvements: * C-N now extends the buffer (like EMACS) if typed without a command argument while on the last line of the buffer. * Lisp break handling has been made more robust. In particular, NMODE now ensures that IN* and OUT* are set to reasonable values. * The OUTPUT buffer now starts out with the "modified" attribute ("*") off. * The implementation of command prefix characters (i.e., C-X, M-X, C-], and Escape) and command arguments (i.e., C-U, etc.) has changed. The most visible changes are that C-U, etc. echo differently, and that Escape can now be followed by bit-prefix characters. (In other words, NMODE will recognize "Escape ^\ E" as Esc-M-E, rather than "Esc-C-\ E"; the 9836 terminal emulator has been modified to generate such escape sequences under some circumstances.) NMODE customizers may be interested to know that all of these previously-magic characters can now be redefined (on a per-mode basis, even), just like any other character. * If you are at or near the end of the buffer, NMODE will put the current line closer to the bottom of the screen when it adjusts the window. * C-X C-F (Find File) and the Dired 'E' command will no longer "find" an incorrect version of the specified file, should one happen to already be in a buffer. * The 'C' (continue) command to the PSL break loop now works again. * The "NMODE" indicator on the current window's mode line no longer disappears when the user is entering string input. * The command C-X 4 F (Find File in Other Window) now sets the buffer's file name properly. ------- 6-Dec-82 18:41:19-PST,1969;000000000000 Date: 6 Dec 1982 1841-PST From: Cris Perdue <Perdue> Subject: LOADable modules, and HELP for them To: PSL-News: ;, PSL-Users: ; NEW PACKAGES: Some relatively new packages have been made available by various people here. These belong in PU: (loadable utilities) at some point, but for now they are all on PNEW:, both the source code and the object code. See below for an explanation of PNEW:. Documentation for each of these is either in the source file or in PH:<file>.DOC, which has been greatly cleaned up. HASH.SL HISTORY.SL IF.SL MAN.SL NEWPP.SL STRING-INPUT.SL STRING-SEARCH.SL TIME-FNC.SL DOCUMENTATION ON PH: (the HELP directory): PH: has been greatly cleaned up. It should now be reasonable to browse through PH: for information on packages not described in the PSL reference manual. TO THE USERS: These files are intended to be IMPORTed or LOADed. If you wish to use modules from PNEW:, you must put PNEW: into your definition of the "logical device" PL:. The command "INFO LOGICAL PL:" to the EXEC will tell you what the current definition of PL: is. Put a line of the form: "DEFINE PL: <directory>,<directory>, ..., PNEW:" into your LOGIN.CMD file, including the same directories that are given when you ask the EXEC, with PNEW: added at the end as shown. GETTING MOST RECENT VERSIONS OF MODULES: PNEW: also contains the object files for new versions of existing modules where the latest version is more recent than the latest "release" of PSL. In particular, where PSL.EXE includes the module preloaded in it, PSL.EXE will not include the version in PNEW:. If you want the latest version when you LOAD or IMPORT, put PNEW: at the front of the list defining PL:. TO THE IMPLEMENTORS: If one of these is your product and you feel it is well tried and no longer experimental, please send a note to Nancy K. asking her to move the source to PU: and the object file to PL:. ------- 4-Jan-83 14:37:11-PST,1577;000000000000 Date: 4 Jan 1983 1437-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; FILES THAT DESCRIBE OTHER FILES If you need to look at the PSL directories on HULK or find something in those directories, look for files with names that start with "-", such as -THIS-.DIRECTORY or -FILE-NOTES.TXT. These files appear at the beginning of an ordinary directory listing and they describe the directory they are in, plus the files and/or subdirectories of that directory. PSL directories likely to be of interest to users are: PSL: (PSL root directory), PU: (source code for libraries), PNEW: (place to keep revisions of source files), PH: (help files and documentation for libraries). LIBRARY MODULES NOW LISTED PU: is the repository for the source code of library modules, generally contributed by users. The file PU:-FILE-NOTES.TXT contains a listing of available library modules, in most cases with a one-line description of each module. Please look here for interesting utilities. If no documentation appears to exist, bug the author of the module, also listed. (Documentation may appear in PH: or in the source file itself on PU:.) SAVESYSTEM The function SAVESYSTEM, which used to take one argument, now takes three arguments. The first is the banner, the second is the file to be written, and the third is a list of forms to be evaluated when the new core image is started. PSL.TAGS For those of you who browse through PSL source code, the file PSL.TAGS moved to p20sup: from psl:. ------- 11-Jan-83 13:09:13-PST,1516;000000000000 Date: 11 Jan 1983 1309-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; When compiled code calls a function that is undefined, the error is now continuable. If the error is continued, the function call is repeated. The function EXITLISP is now available in DEC-20 PSL, where it is currently a synonym for QUIT. Both functions cause PSL to return to a command interpreter. If the operating system permits a choice, QUIT is a continuable exit, and EXITLISP is a permanent exit (that terminates the PSL process). The functions LPOSN and CHANNELLPOSN now exist. These return a meaningful value for channels that are open for output, giving the number of the current line within the current output page. To be precise, the value is the number of newlines output since the most recent formfeed. People have been using the undocumented STRING-CONCAT function. This function is NOT actually compatible with Common LISP. It should be used as a function that applies only to string arguments, and is otherwise like CONCAT. Various bugs have been fixed, notably in the compiler and debugging facilities. A new directory of possible interest is PSYS:. This contains executable files. Executables already documented as being on PSL: will stay there for some time, but new ones are on PSYS:. DOCUMENTATION The reference manual has been significantly revised and a new version will be made available to all PSL users within a week or two. ------- 11-Jan-83 13:20:09-PST,4950;000000000000 Date: 11 Jan 1983 1319-PST From: Alan Snyder <AS> Subject: NMODE news To: PSL-News: ;, PSL-Users: ; cc: AS NMODE changes (10-Nov-1982 through 5-Jan-1983): * Bug fix: In the previous version of NMODE, digits and hyphen would insert themselves in the buffer even in "read-only" modes like Dired. They now act to specify command arguments in those modes. * Bug fix: control characters are now displayed properly in the message lines at the bottom of the screen. * Some bugs in auto fill mode have been fixed. * C-S and C-R now get you an incremental search, very much like that in EMACS. [Incremental search was implemented by Jeff Soreff.] * The window scrolling commands have been changed to ring the bell if no actual scrolling takes place (because you are already at the end of the buffer, etc.). In addition, some bugs in the scroll-by-pages commands have been fixed: (1) Previously, a request to scroll by too many pages was ignored; now it will scroll by as many pages as possible. (2) Previously, a backwards scroll near the beginning of the buffer could fail to leave the cursor in the same relative position on the screen. * A number of changes have been made that improve the efficiency of refresh, input completion (on buffer names and M-X command names), and Lisp I/O to and from buffers (Lisp-E). * Jeff Soreff has implemented the following commands: M-A (Backward Sentence) M-E (Forward Sentence) M-K (Kill Sentence) C-X Rubout (Backward Kill Sentence) M-[ (Backward Paragraph) M-] (Forward Paragraph) M-H (Mark Paragraph) M-Q (Fill Paragraph) M-G (Fill Region) M-Z (Fill Comment) M-S (Center Line) C-X = and C-= (What Cursor Position) These are basically the same as EMACS, except for M-Z, which is new. M-Z (Fill Comment) is like M-Q (Fill Paragraph), except that it first scans the beginning of the current line for a likely prefix and temporarily sets the fill prefix to that string. The prefix is determined to be any string of indentation, followed by zero or more non-alphanumeric, non-blank characters, followed by any indentation. The Fill Prefix works somewhat better than EMACS: lines not containing the fill prefix delimit paragraphs. * New EMACS commands implemented: C-M-\ (Indent Region) (for both Text and Lisp modes) C-M-C (inserts a ^C) * Defined C-? same as M-?, C-( same as C-M-(, C-) same as C-M-), for the convenience of 9836 users. * The following commands have been enhanced to obey the C-U argument as in EMACS: C-Y (Insert Kill Buffer) M-Y (Unkill Previous) M-^ (Delete Indentation) C-M-(, C-M-U, and C-( (Backward Up List) C-M-) and C-) (Forward Up List) C-M-N (Move Forward List) C-M-P (Move Backward List) C-M-A and C-M-[ (Move Backward Defun) C-M-E and C-M-] (End of Defun) * The C-X = command has been extended: if you give it a numeric argument, it will go to the specified line number. * NMODE's Lisp parsing has been vastly improved. It now recognizes the following: lists, vectors, comments, #/ character constants, string literals, ! as the escape character, and prefixes (including quote, backquote, comma, comma-atsign, and #-quote). The only restriction is that parsing is always done from the beginning of the line; thus newline cannot appear in string literals or be quoted in any way. * NMODE's Lisp indenting has also been improved. It now recognizes special cases of indenting under functional forms, and indents to match the leftmost (rather than the rightmost) of a sequence of forms on a line. It also knows about prefixes, like quote. * Inserting a right bracket in Lisp mode now displays the matching bracket, just as inserting a right paren does. * Inserting a right paren (or right bracket) now will avoid trying to display the "matching" left paren (or left bracket) when inside a comment, etc. * Changed multi-line Lisp indenting commands to avoid indenting (in fact, remove any indentation from) blank lines. * The indenting commands now avoid modifying the buffer if the indentation remains unchanged. * When a command (such as C-X K) asks for the name of an existing buffer, CR will now complete the name, if possible, and terminate if the name uniquely specifies one existing buffer. This behavior is more similar to EMACS than the previous behavior, where CR did no completion. * String input is now confirmed by moving the cursor to the beginning of the input line. ------- 11-Jan-83 17:19:31-PST,1032;000000000001 Date: 11 Jan 1983 1719-PST From: Cris Perdue <Perdue> Subject: More PSL News To: PSL-News: ;, PSL-Users: ; The behavior of LOAD has been modified so it is possible to use LOAD to load in ".SL" files. As in the past, LOAD searches in two places for a file to load: first in the connected directory (DSK: for the DEC-20 cognoscenti), then on PL: (or the equivalent on other machines). On each of these directories it searches through a list of file extensions (.b, .lap, and .sl) for a file with the right name and that extension. Thus LOAD looks first for <file>.b, then <file>.lap, then <file>.sl, then pl:<file>.b, then pl:<file>.lap, finally pl:<file>.sl. Until the latest version of PSL, LOAD would only search for .b and .lap files. The extended behavior should help people who often do not compile files. The main thing to remember is to either keep any .b file in the same directory with the .sl, or else make sure that the .b file's directory is searched before the .sl file's directory. ------- 19-Jan-83 18:28:27-PST,1437;000000000003 Date: 19 Jan 1983 1826-PST From: PERDUE at HP-HULK Subject: PSL News Update To: psl-news LOADing files The LOAD function uses two lists in searching for a file to actually load. The lists are: loaddirectories* This initially has the value: ("" "pl:"). It is a list of strings which indicate the directory to look in. Directories are searched in order of the list. loadextensions* This initially has the value: ((".b" . FASLIN) (".lap" . LAPIN) (".sl" . LAPIN)). It is an association list. Each element is a pair whose CAR is a string representing a file extension and whose CDR is a function to apply to LOAD a file of this extension. Within each directory of loaddirectories*, the members of loadextensions* are used in order in searching for a file to load. NOTES: The value of loadextensions* has recently changed. Removal of the last element of loadextensions* will restore the old behavior. Do not expect the exact strings that appear in these lists to remain identical across machines or across time, but it is reasonable to believe that the lists and their use will be stable for some time. DEBUGGING: BR and UNBR BR and UNBR were removed from the PSL system some time ago. To satisfy their devotees, they have been resurrected in a library named BR-UNBR. A bug has also been fixed and very soon the system library file will have the fix (if in a hurry see pnew:). ------- 24-Jan-83 09:42:10-PST,703;000000000000 Date: 21 Jan 1983 1909-PST From: PERDUE at HP-HULK Subject: Documentation directories To: psl-news The PSL documentation directory "pd:" has been cleaned up and there are now also machine-dependent directories p20d:, pvd:, phpd:, and pad: (Apollo). No great news of yet concerning the contents of these directories, though they do contain some rather new documents in source and final form. Note that some of these logical names are new, and there are some other new logical names as well: the group based on the root name "pdist" has been filled out, and the group based on the name "psup:" has also been filled out with a couple of new directories and their logical names. ------- 9-Feb-83 13:22:20-PST,4442;000000000000 Date: 9 Feb 1983 1317-PST From: AS at HP-HULK Subject: NMODE changes To: psl-news The following recent changes are available in PSL:NMODE.EXE on Hulk, and on the 9836 (except for Dired). Recent NMODE changes (20-Jan-1983 through 9-Feb-1983): Changes: * The Buffer Browser (C-X C-B) has changed in a number of ways. It has three new commands: F Saves the buffer in a file, if there are unsaved changes. M-~ Turns off the buffer-modified flag. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,F,N, and M-~ all obey a numeric argument of either sign. The Buffer Browser now starts up pointing at the previously-current buffer. After performing a sort command, the cursor now continues to point at the same buffer. * DIRED (the File browser) has been changed in a number of ways. One SIGNIFICANT INCOMPATIBLE change is that the K and C-K commands now delete the file immediately and remove the file from the display (instead of just marking them for later deletion). In addition, there are two new commands: I (Ignore File) Removes the file from the display list, without any effect on the actual file. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,and N all obey a numeric argument of either sign. The sort-by-filename procedure has been changed to sort version numbers in numerical, rather than lexicographic order. When Dired starts, the files are sorted using this procedure, instead of leaving them in the order returned by the file system. After performing a sort command, the cursor now continues to point at the same file. Dired will now automatically kill any buffer it had created for viewing a file as soon as you view a new file or exit Dired, unless the buffer contains unsaved changes. * M-X Insert File now takes as its default the file name used in the previous M-X Insert File command. This behavior matches EMACS. * Lisp-E (and Lisp-D, a new command) now insert a free EOL at the end of the buffer, if needed, whenever the buffer-modified flag is set. Previously the free EOL was inserted only when the current position was at the end of the buffer, regardless of the state of the buffer-modified flag. New commands: M-X Count Occurrences (aka M-X How Many) M-X Delete Matching Lines (aka M-X Flush Lines) M-X Delete Non-Matching Lines (aka M-X Keep Lines) M-X Insert Date (not on 9836 yet) M-X Kill Some Buffers M-X Rename Buffer M-X Revert File M-X Set Key M-X Set Visited Filename Lisp-D (in Lisp mode) executes the current defun (if the current position is within a defun) or executes from the current position (otherwise). Improvements: * NMODE now checks the system's terminal type every time it is restarted. This change allows you to use an NMODE that was detached from one kind of terminal and later attached on another kind of terminal. * Fixed bug in Dec-20 version: Find File could leave around an empty file if you tried to find a nonexistent file in a directory that allows you to create new files but whose default file protection does not allow you to delete them. (On the Dec-20, Find File determines the name of a new file by writing an empty file and immediately deleting it.) * A soft-key feature has been added, intended primarily for use on the 9836. The command Esc-/ will read a soft-key designator (a single character in the range '0' to 'W') and execute the definition of the corresponding softkey (numbered 0 through 39). Softkeys are defined using the function (nmode-define-softkey n fcn label-string), where n is the softkey number and fcn is either NIL (for undefined), a function ID (which will be invoked), or a string (which will be executed as if typed at the keyboard). NMODE on the 9836 sets up the keyboard so that the function keys K0 through K9 send an appropriate Esc-/ sequence (using shift and control as modifiers). * The two message/prompt lines at the bottom of the screen are now sometimes updated independently of the rest of the screen. This change makes writing messages and prompts more efficient. ------- 25-Feb-83 11:03:02-PST,2247;000000000000 Date: 25 Feb 1983 1059-PST From: AS at HP-HULK Subject: recent NMODE changes To: psl-news Recent NMODE changes (14-Feb-1983 through 24-Feb-1983): Bugs fixed: * Dired wasn't garbage collecting old buffers used to view files, as had been intended. * M-Z would enter an infinite loop on a paragraph at the end of the buffer whose last line had no terminating Newline character. * When filling with a fill prefix, the cursor would sometimes be placed improperly. * M-X Rename Buffer didn't convert the new buffer name to upper case. * The Permanent Goal Column feature (Set by C-X C-N) didn't work. * The incremental search commands did not handle bit-prefix characters (e.g., the Meta prefix) properly. Typing a bit-prefix character would terminate the search, but then the bit-prefix character would not be recognized as such. * When executing Lisp from the OUTPUT buffer in one-window mode, the window would not be adjusted if the other (unexposed) window also was attached to the OUTPUT buffer. * The cursor was being positioned improperly when the window was scrolled horizontally. Performance Improvements: * The efficiency of Lisp printing to the OUTPUT buffer has been improved significantly through the use of internal buffering. One visible change is that the screen is updated only after an entire line is written. * Insertion into text buffers has been speeded up by eliminating some unnecessary string consing that occurred when inserting at the beginning or end of a line (which is very common). EMACS Compatibility Enhancements: * M-X Set Visited Filename now converts the new name to the true name of the file, if possible. * M-X Rename Buffer now checks for attempts to use the name of an existing buffer. * Query-Replace now terminates when you type a character that is not a query-replace command and rereads that character. * C-M-D has been extended to obey the command argument (either positive or negative). It still differs from the EMACS C-M-D command in that it always stays within the current enclosing list. * M-( has been extended to obey the command argument. * The M-) command (Move Over Paren) has been implemented. ------- |
Added psl-1983/nmode-chart.txt version [eea7c24a86].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE command list (Lisp mode) - 25 January 1983 -------------------------------------------------------- ) INSERT-CLOSING-BRACKET Backspace DELETE-BACKWARD-HACKING-TABS-COMMAND C-% REPLACE-STRING-COMMAND C-( BACKWARD-UP-LIST-COMMAND C-) FORWARD-UP-LIST-COMMAND C-- NEGATIVE-ARGUMENT C-0 ARGUMENT-DIGIT C-1 ARGUMENT-DIGIT C-2 ARGUMENT-DIGIT C-3 ARGUMENT-DIGIT C-4 ARGUMENT-DIGIT C-5 ARGUMENT-DIGIT C-6 ARGUMENT-DIGIT C-7 ARGUMENT-DIGIT C-8 ARGUMENT-DIGIT C-9 ARGUMENT-DIGIT C-< MARK-BEGINNING-COMMAND C-= WHAT-CURSOR-POSITION-COMMAND C-> MARK-END-COMMAND C-? HELP-DISPATCH C-@ SET-MARK-COMMAND C-A MOVE-TO-START-OF-LINE-COMMAND C-B MOVE-BACKWARD-CHARACTER-COMMAND C-D DELETE-FORWARD-CHARACTER-COMMAND C-E MOVE-TO-END-OF-LINE-COMMAND C-F MOVE-FORWARD-CHARACTER-COMMAND C-G NMODE-ABORT-COMMAND C-K KILL-LINE C-L NMODE-REFRESH-COMMAND C-M-( BACKWARD-UP-LIST-COMMAND C-M-) FORWARD-UP-LIST-COMMAND C-M-- NEGATIVE-ARGUMENT C-M-0 ARGUMENT-DIGIT C-M-1 ARGUMENT-DIGIT C-M-2 ARGUMENT-DIGIT C-M-3 ARGUMENT-DIGIT C-M-4 ARGUMENT-DIGIT C-M-5 ARGUMENT-DIGIT C-M-6 ARGUMENT-DIGIT C-M-7 ARGUMENT-DIGIT C-M-8 ARGUMENT-DIGIT C-M-9 ARGUMENT-DIGIT C-M-@ MARK-FORM-COMMAND C-M-A MOVE-BACKWARD-DEFUN-COMMAND C-M-B MOVE-BACKWARD-FORM-COMMAND C-M-Backspace MARK-DEFUN-COMMAND C-M-D DOWN-LIST C-M-E END-OF-DEFUN-COMMAND C-M-F MOVE-FORWARD-FORM-COMMAND C-M-H MARK-DEFUN-COMMAND C-M-I LISP-TAB-COMMAND C-M-K KILL-FORWARD-FORM-COMMAND C-M-L SELECT-PREVIOUS-BUFFER-COMMAND C-M-M BACK-TO-INDENTATION-COMMAND C-M-N MOVE-FORWARD-LIST-COMMAND C-M-O SPLIT-LINE-COMMAND C-M-P MOVE-BACKWARD-LIST-COMMAND C-M-Q LISP-INDENT-SEXPR C-M-R REPOSITION-WINDOW-COMMAND C-M-Return BACK-TO-INDENTATION-COMMAND C-M-Rubout KILL-BACKWARD-FORM-COMMAND C-M-T TRANSPOSE-FORMS C-M-Tab LISP-TAB-COMMAND C-M-U BACKWARD-UP-LIST-COMMAND C-M-V SCROLL-OTHER-WINDOW-COMMAND C-M-W APPEND-NEXT-KILL-COMMAND C-M-X M-X-PREFIX C-M-[ MOVE-BACKWARD-DEFUN-COMMAND C-M-\ LISP-INDENT-REGION-COMMAND C-M-] END-OF-DEFUN-COMMAND C-N MOVE-DOWN-EXTENDING-COMMAND C-O OPEN-LINE-COMMAND C-P MOVE-UP-COMMAND C-Q INSERT-NEXT-CHARACTER-COMMAND C-R REVERSE-SEARCH-COMMAND C-Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND C-S INCREMENTAL-SEARCH-COMMAND C-Space SET-MARK-COMMAND C-T TRANSPOSE-CHARACTERS-COMMAND C-U UNIVERSAL-ARGUMENT C-V NEXT-SCREEN-COMMAND C-W KILL-REGION C-X C-X-PREFIX C-X . SET-FILL-PREFIX-COMMAND C-X 1 ONE-WINDOW-COMMAND C-X 2 TWO-WINDOWS-COMMAND C-X 3 VIEW-TWO-WINDOWS-COMMAND C-X 4 VISIT-IN-OTHER-WINDOW-COMMAND C-X < SCROLL-WINDOW-LEFT-COMMAND C-X = WHAT-CURSOR-POSITION-COMMAND C-X > SCROLL-WINDOW-RIGHT-COMMAND C-X A APPEND-TO-BUFFER-COMMAND C-X B SELECT-BUFFER-COMMAND C-X C-B BUFFER-BROWSER-COMMAND C-X C-F FIND-FILE-COMMAND C-X C-L LOWERCASE-REGION-COMMAND C-X C-N SET-GOAL-COLUMN-COMMAND C-X C-O DELETE-BLANK-LINES-COMMAND C-X C-S SAVE-FILE-COMMAND C-X C-T TRANSPOSE-LINES C-X C-U UPPERCASE-REGION-COMMAND C-X C-V VISIT-FILE-COMMAND C-X C-W WRITE-FILE-COMMAND C-X C-X EXCHANGE-POINT-AND-MARK C-X C-Z NMODE-EXIT-TO-SUPERIOR C-X D DIRED-COMMAND C-X E EXCHANGE-WINDOWS-COMMAND C-X F SET-FILL-COLUMN-COMMAND C-X G GET-REGISTER-COMMAND C-X H MARK-WHOLE-BUFFER-COMMAND C-X K KILL-BUFFER-COMMAND C-X O OTHER-WINDOW-COMMAND C-X P WRITE-SCREEN-PHOTO-COMMAND C-X Rubout BACKWARD-KILL-SENTENCE-COMMAND C-X T TRANSPOSE-REGIONS C-X V NMODE-INVERT-VIDEO C-X X PUT-REGISTER-COMMAND C-X ^ GROW-WINDOW-COMMAND C-Y INSERT-KILL-BUFFER C-] LISP-PREFIX Esc-4 MOVE-BACKWARD-WORD-COMMAND Esc-5 MOVE-FORWARD-WORD-COMMAND Esc-A MOVE-UP-COMMAND Esc-B MOVE-DOWN-COMMAND Esc-C MOVE-FORWARD-CHARACTER-COMMAND Esc-D MOVE-BACKWARD-CHARACTER-COMMAND Esc-F MOVE-TO-BUFFER-END-COMMAND Esc-J NMODE-FULL-REFRESH Esc-L OPEN-LINE-COMMAND Esc-M KILL-LINE Esc-P DELETE-FORWARD-CHARACTER-COMMAND Esc-S SCROLL-WINDOW-UP-LINE-COMMAND Esc-T SCROLL-WINDOW-DOWN-LINE-COMMAND Esc-U SCROLL-WINDOW-UP-PAGE-COMMAND Esc-V SCROLL-WINDOW-DOWN-PAGE-COMMAND Esc-h MOVE-TO-BUFFER-START-COMMAND Escape ESC-PREFIX Lisp-? LISP-HELP-COMMAND Lisp-A LISP-ABORT-COMMAND Lisp-B LISP-BACKTRACE-COMMAND Lisp-C LISP-CONTINUE-COMMAND Lisp-E EXECUTE-FORM-COMMAND Lisp-L EXIT-NMODE Lisp-Q LISP-QUIT-COMMAND Lisp-R LISP-RETRY-COMMAND Lisp-Y YANK-LAST-OUTPUT-COMMAND M-% QUERY-REPLACE-COMMAND M-' UPCASE-DIGIT-COMMAND M-( INSERT-PARENS M-- NEGATIVE-ARGUMENT M-/ HELP-DISPATCH M-0 ARGUMENT-DIGIT M-1 ARGUMENT-DIGIT M-2 ARGUMENT-DIGIT M-3 ARGUMENT-DIGIT M-4 ARGUMENT-DIGIT M-5 ARGUMENT-DIGIT M-6 ARGUMENT-DIGIT M-7 ARGUMENT-DIGIT M-8 ARGUMENT-DIGIT M-9 ARGUMENT-DIGIT M-; INSERT-COMMENT-COMMAND M-< MOVE-TO-BUFFER-START-COMMAND M-> MOVE-TO-BUFFER-END-COMMAND M-? HELP-DISPATCH M-@ MARK-WORD-COMMAND M-A BACKWARD-SENTENCE-COMMAND M-B MOVE-BACKWARD-WORD-COMMAND M-Backspace MARK-DEFUN-COMMAND M-C UPPERCASE-INITIAL-COMMAND M-D KILL-FORWARD-WORD-COMMAND M-E FORWARD-SENTENCE-COMMAND M-F MOVE-FORWARD-WORD-COMMAND M-G FILL-REGION-COMMAND M-H MARK-PARAGRAPH-COMMAND M-I TAB-TO-TAB-STOP-COMMAND M-K KILL-SENTENCE-COMMAND M-L LOWERCASE-WORD-COMMAND M-M BACK-TO-INDENTATION-COMMAND M-Q FILL-PARAGRAPH-COMMAND M-R MOVE-TO-SCREEN-EDGE-COMMAND M-Return BACK-TO-INDENTATION-COMMAND M-Rubout KILL-BACKWARD-WORD-COMMAND M-S CENTER-LINE-COMMAND M-T TRANSPOSE-WORDS M-Tab TAB-TO-TAB-STOP-COMMAND M-U UPPERCASE-WORD-COMMAND M-V PREVIOUS-SCREEN-COMMAND M-W COPY-REGION M-X M-X-PREFIX M-X Append to File APPEND-TO-FILE-COMMAND M-X Apropos APROPOS-COMMAND M-X Auto Fill Mode AUTO-FILL-MODE-COMMAND M-X Count Occurrences COUNT-OCCURRENCES-COMMAND M-X DIRED EDIT-DIRECTORY-COMMAND M-X Delete File DELETE-FILE-COMMAND M-X Delete Matching Lines DELETE-MATCHING-LINES-COMMAND M-X Delete Non-Matching Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Delete and Expunge File DELETE-AND-EXPUNGE-FILE-COMMAND M-X Edit Directory EDIT-DIRECTORY-COMMAND M-X Execute Buffer EXECUTE-BUFFER-COMMAND M-X Execute File EXECUTE-FILE-COMMAND M-X Find File FIND-FILE-COMMAND M-X Flush Lines DELETE-MATCHING-LINES-COMMAND M-X How Many COUNT-OCCURRENCES-COMMAND M-X Insert Buffer INSERT-BUFFER-COMMAND M-X Insert Date INSERT-DATE-COMMAND M-X Insert File INSERT-FILE-COMMAND M-X Keep Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Kill Buffer KILL-BUFFER-COMMAND M-X Kill File DELETE-FILE-COMMAND M-X Kill Some Buffers KILL-SOME-BUFFERS-COMMAND M-X Lisp Mode LISP-MODE-COMMAND M-X List Buffers BUFFER-BROWSER-COMMAND M-X Make Space NMODE-GC M-X Prepend to File PREPEND-TO-FILE-COMMAND M-X Query Replace QUERY-REPLACE-COMMAND M-X Rename Buffer RENAME-BUFFER-COMMAND M-X Replace String REPLACE-STRING-COMMAND M-X Revert File REVERT-FILE-COMMAND M-X Save All Files SAVE-ALL-FILES-COMMAND M-X Select Buffer SELECT-BUFFER-COMMAND M-X Set Key SET-KEY-COMMAND M-X Set Visited Filename SET-VISITED-FILENAME-COMMAND M-X Start Scripting START-SCRIPTING-COMMAND M-X Start Timing NMODE START-TIMING-COMMAND M-X Stop Scripting STOP-SCRIPTING-COMMAND M-X Stop Timing NMODE STOP-TIMING-COMMAND M-X Text Mode TEXT-MODE-COMMAND M-X Undelete File UNDELETE-FILE-COMMAND M-X Visit File VISIT-FILE-COMMAND M-X Write File WRITE-FILE-COMMAND M-X Write Region WRITE-REGION-COMMAND M-Y UNKILL-PREVIOUS M-Z FILL-COMMENT-COMMAND M-[ BACKWARD-PARAGRAPH-COMMAND M-\ DELETE-HORIZONTAL-SPACE-COMMAND M-] FORWARD-PARAGRAPH-COMMAND M-^ DELETE-INDENTATION-COMMAND M-~ BUFFER-NOT-MODIFIED-COMMAND Newline INDENT-NEW-LINE-COMMAND Return RETURN-COMMAND Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND Tab LISP-TAB-COMMAND ] INSERT-CLOSING-BRACKET C-\ "Meta" prefix on Dec-20 C-[ (Escape) "Meta" prefix on 9836 C-^ "Control" prefix C-Z "Control-Meta" prefix |
Added psl-1983/nmode-customizing.txt version [caf7643a39].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | How to customize NMODE Alan Snyder 24 September 1982 ------------------------------------------------------------------------------- This memo explains how to customize NMODE by redefining the effect of input keystrokes. NMODE is customized by executing Lisp forms. These forms may be executed directly within NMODE (using Lisp-E), or may be stored in an INIT file, which is read by NMODE when it first starts up. The name of the INIT file read by NMODE is "NMODE.INIT" in the user's home directory. There are three concepts that must be understood to customize NMODE: Commands, Functions, and Modes. 1) Commands. The effect of given keystroke or sequence of keystrokes in NMODE is based on a mapping between "commands" and "functions". A "command" may be either a single "extended character" or a sequence of characters. An extended character is a 9-bit character with distinct "Control" and "Meta" bits. Thus "C-M-A" is a single "extended character", even though on many terminals you have to use two keystrokes to enter it. Extended characters are specified using the macro X-CHAR, for example: (x-char A) the letter "A" (upper case) (x-char C-F) Control-F (x-char C-M-Z) Control-Meta-Z (x-char CR) Carriage-Return (x-char TAB) Tab (x-char BACKSPACE) Backspace (x-char NEWLINE) Newline (x-char RUBOUT) Rubout (x-char C-M-RUBOUT) Control-Meta-Rubout (The macros described in this section are defined in the load module EXTENDED-CHAR.) It is important to note that on most terminals, some Ascii control characters are mapped to extended "Control" characters and some aren't. Those that aren't are: Backspace, CR, Newline, Tab, and Escape. Even if you type "CNTL-I" on the keyboard, you will get "Tab" and not "Control-I". The remaining Ascii control characters are mapped to extended "Control" characters, thus typing "CNTL-A" on the keyboard gives "Control-A". As mentioned above, a command can be a sequence of characters. There are two forms: Prefix commands and Extended commands. Prefix commands: A prefix command consists of two characters, the first of which is a defined "prefix character". In NMODE, there are 3 predefined prefix characters: C-X, ESC, and C-]. Prefix commands are specified using the X-CHARS macro, for example: (x-chars C-X C-F) (x-chars ESC A) (x-chars C-] E) Extended commands: An extended command consists of the character M-X and a string. Extended commands are defined using the M-X macro, for example: (M-X "Lisp Mode") (M-X "Revert File") The case of the letters in the string is irrelevant, except to specify how the command name will be displayed when "completion" is used by the user. By convention, the first letter of each word in an extended command name is capitalized. 2) Functions. NMODE commands are implemented by PSL functions. By convention, most (but not all) PSL functions that implement NMODE commands have names ending with "-COMMAND", for example, MOVE-FORWARD-CHARACTER-COMMAND. An NMODE command function should take no arguments. The function can perform its task using a large number of existing support functions; see PN:BUFFER.SL and PN:MOVE-COMMANDS.SL for examples. A command function can determine the command argument (given by C-U) by inspecting global variables: nmode-command-argument: the numeric value (default: 1) nmode-command-argument-given: T if the user specified an argument nmode-command-number-given: T if the user typed digits in the argument See the files PN:MOVE-COMMANDS.SL, PN:LISP-COMMANDS.SL, and PN:COMMANDS.SL for many examples of NMODE command functions. 3) Modes. The mapping between commands and functions is dependent on the current "mode". Examples of existing modes are "Text Mode", which is the basic mode for text editing, "Lisp Mode", which is an extension of "Text Mode" for editing and executing Lisp code, and "Dired Mode", which is a specialized mode for the Directory Editor Subsystem. A mode is defined by a list of Lisp forms which are evaluated to determine the state of a Dispatch Table. The Dispatch Table is what is actually used to map from commands to functions. Every time the user selects a new buffer, the Dispatch Table is cleared and the Lisp forms defining the mode for the new buffer are evaluated to fill the Dispatch Table. The forms are evaluated in reverse order, so that the first form is evaluated last. Thus, any command definitions made by one form supercede those made by forms appearing after it in the list. Two functions are commonly invoked by mode-defining forms: NMODE-ESTABLISH-MODE and NMODE-DEFINE-COMMANDS. NMODE-ESTABLISH-MODE takes one argument, a list of mode defining forms, and evaluates those forms. Thus, NMODE-ESTABLISH-MODE can be used to define one mode in terms of (as an extension of or a modification to) another mode. NMODE-DEFINE-COMMANDS takes one argument, a list of pairs, where each pair consists of a COMMAND and a FUNCTION. This form of list is called a "command list". Command lists are not used directly to map from commands to functions. Instead, NMODE-DEFINE-COMMANDS reads the command list it is given and for each COMMAND-FUNCTION pair in the command list (in order), it alters the Dispatch Table to map the specified COMMAND to the corresponding FUNCTION. Note that as a convenience, whenever you define an "upper case" command, the corresponding "lower case" command is also defined to map to the same function. Thus, if you define C-M-A, you automatically define C-M-a to map to the same function. If you want the lower case command to map to a different function, you must define the lower case command "after" defining the upper case command. The usual technique for modifying one or more existing modes is to modify one of the command lists given to NMODE-DEFINE-COMMANDS. The file PN:MODE-DEFS.SL contains the definition of most predefined NMODE command lists, as well as the definition of most predefined modes. To modify a mode or modes, you must alter one or more command lists by adding (or perhaps removing) entries. Command lists are manipulated using two functions: (add-to-command-list list-name command func) (remove-from-command-list list-name command) Here are some examples: (add-to-command-list 'text-command-list (x-char BACKSPACE) 'delete-backward-character-command) (add-to-command-list 'lisp-command-list (x-char BACKSPACE) 'delete-backward-hacking-tabs-command) (remove-from-command-list 'read-only-text-command-list (x-char BACKSPACE)) [The above forms change BACKSPACE from being the same as C-B to being the same as RUBOUT.] (add-to-command-list 'read-only-text-command-list (x-char M-@) 'set-mark-command) [The above form makes M-@ set the mark.] (add-to-command-list 'read-only-terminal-command-list (x-chars ESC Y) 'print-buffer-names-command) [The above form makes Esc-Y print a list of all buffer names. Esc-Y is sent by HP264X terminals when the "Display Functions" key is hit.] Note that these functions change only the command lists, not the Dispatch Table which is actually used to map from commands to functions. To cause the Dispatch Table to be updated to reflect any changes in the command lists, you must invoke the function NMODE-ESTABLISH-CURRENT-MODE. |
Added psl-1983/nmode-emacs.txt version [4eebcfbf6a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMACS users - A quick comparison Alan Snyder (2 February 1983) -------------------------------------------------------------------------------- Introduction If you are familiar with EMACS on the Dec-20, then you should have little trouble using NMODE, since NMODE is largely compatible with EMACS. If you are using an HP terminal or the 9836 VT52 emulator, then you can use the cursor keys and other special function keys with NMODE. There are some differences between NMODE and EMACS, and these are described below. What you are most likely to find is that there are some EMACS commands that have not (yet) been implemented in NMODE; section I below lists the most significant of these. (We are not promising to implement all EMACS commands, but if there is some command you just can't live without, let us know, or volunteer to implement it yourself!) Section II describes areas of inconsistency between NMODE and EMACS; some of these are deficiencies in NMODE that may someday be fixed, others are regarded as features of NMODE, and others are just plain differences which are not likely to go away. Section III lists other known deficiencies in NMODE, many of which we hope to fix. Section IV summarizes those features of NMODE that EMACS doesn't have. -------------------------------------------------------------------------------- I. Things that EMACS has that NMODE doesn't (an incomplete list) * Auto Save * Help Character (C-_) * Many 'options' variables (NMODE has almost none) * Most Minor Modes, including: Word Abbrev Mode Auto Arg Mode Atom Word Mode Overwrite Mode Indent Tabs Mode * The Tags Package M-. (find tag) M-X Visit Tag Table M-X Tags Search * Local Modes specification in files * Syntax Table * Miscellaneous commands: C-M-G (grind form) M-= (count lines region) C-M-Z (exit recursive edit) M-Esc (Execute Minibuffer) C-X Esc (ReExecute Minibuffer) * Mail Commands: C-X M (Send Mail) C-X R (Read Mail) M-X Check Mail * Comment commands: C-; (indent for comment) C-M-; (kill comment) Return (skip trailing comment terminator) C-X ; (set comment column) M-N (down comment line) M-P (up comment line) M-J or M-Linefeed (indent new comment line) * Indentation commands: C-X Tab (indent rigidly) * Text-Processor commands: M-# (change font word) M-_ (underline word) C-X # (change font region) C-X _ (underline region) * File commands: C-X C-D (directory display) C-X C-Q (set file read only) M-X Clean Directory M-X Copy File M-X List Files M-X Reap File M-X Rename File M-X View Directory M-X View File * Page commands: C-X [ (previous page) C-X ] (next page) C-X L (count lines page) C-X C-P (mark page) M-X What Page * Many M-X commands, including: M-X Compare Windows M-X List Matching Lines M-X Occur M-X Tabify M-X Untabify M-X View Buffer * Keyboard macros C-X ( C-X ) C-X E C-X Q M-X Name Kbd Macro M-X Write Kbd Macro * Command Libraries M-X Kill Libraries M-X List Library M-X List Loaded Libraries M-X Load Library M-X Run Library * Spelling Correction (M-$) * Narrowing: C-X N (Narrow Bounds to Region) C-X P (Narrow Bounds to Page) C-X W (Widen Bounds) -------------------------------------------------------------------------------- II. Inconsistencies between NMODE and EMACS A. NMODE Features * NMODE DIRED 'E' and 'V' commands allow editing of the file. These commands do not use "recursive editing": arbitrary switching between buffers and windows is allowed; C-M-L returns to the previous buffer (not C-M-Z). * NMODE has a separate ring of marks for each buffer. * NMODE C-X C-B brings up a buffer browser, instead of just listing the buffers. * NMODE's Lisp parsing commands recognize comments, string literals, character literals, etc. For this reason, the commands C-M-N (Forward List) and C-M-P (Backward List) are not really needed, although they are presently still provided. * When the fill prefix is non-null, NMODE treats lines not beginning with the fill prefix as delimiting a paragraph (ZMACS does this, too). EMACS will treat a single preceding line without the fill prefix as the first line of the paragraph and will insert the prefix onto that line when you do M-Q. * NMODE's incremental search allows you to rubout the old search string (inserted by an immediate C-S or C-R) one character at a time, instead of all at once (like EMACS). B. NMODE Deficiencies (may be fixed someday) * NMODE Query-Replace does not alter the case of the replacement string, does not support word search, does not support recursive edit. * NMODE does not have a ring buffer of buffers; the default buffer for C-X B may be different than in EMACS. * NMODE's incremental search does not escape to a non-incremental search, does not do word searches, always ignores case. * No completion on File Name input. * NMODE doesn't set the Mode from the first line of a file. * In NMODE, M-digit does not enter autoarg mode (i.e., if you then type a digit (without Meta), the digit is inserted. * NMODE search commands never set the Mark. * NMODE lacks true read-only buffers. * NMODE's Dired does not support C, H, or N. Dired commands do not take a command argument. * NMODE's Kill Buffer commands ask for confirmation rather than offering to write out the buffer. * NMODE's C-M-Q command does not use the command argument. * NMODE's C-X H command does not use the command argument. * NMODE's M-< command does not use the command argument. * NMODE's M-> command does not use the command argument. * NMODE's C-X C-Z command does not save any files. * NMODE's M-X Make Space command does not offer to delete buffers, kill rings, etc. * NMODE's C-M-R command works only in Lisp mode (it doesn't do paragraphs). * NMODE's Return command doesn't delete blanks and tabs when moving onto a new line. * NMODE's Return command is not changed in Auto Fill mode. * NMODDE's LineFeed command is quite a bit different: (1) it doesn't delete spaces before the inserted CRLF; (2) it doesn't use the fill prefix to indent; (3) it passes the command argument to the Return command, rather than to the Tab command. * NMODE's C-X T command doesn't try to readjust the marks. * NMODE's C-X 4 command recognizes only B and F as options (not C-B or C-F). C. Just Plain Differences * NMODE customization is completely different than EMACS customization. * NMODE M-X commands always prompt for their arguments; Escape is not a terminator for the command name. * Find File in NMODE creates a buffer whose name is of the form "foo.bar", rather than "foo". * In NMODE, the various Lisp-related commands (C-M-B, etc.) are defined only in Lisp mode. * NMODE's "defun" commands don't set the mark. * C-M-L means "return to previous buffer" instead of "insert formfeed". * C-] is a prefix character (in Lisp mode) instead of meaning "abort". * C-X P means "write screen photo" instead of "narrow bounds to page". * NMODEs text filling commands compress non-leading tabs into spaces; EMACS leaves them alone. -------------------------------------------------------------------------------- III. Known deficiencies of NMODE * During prompted character input, the cursor remains in the edit window. * Printing to the OUTPUT buffer is slow. * Quitting out of NMODE to the standard break handler won't restore echoing. * NMODE does not provide a good way to interrupt a Lisp-E execution or printout. (The only way is to ^C NMODE and then START it.) * "Typeout" is clumsy. * If you type ^^x to get C-X, the prompt string is sort of strange. -------------------------------------------------------------------------------- IV. Things that NMODE has that EMACS doesn't * Miscellaneous Commands: M-Z - format comment (automatically sets the fill prefix) C-X V - toggle between normal and inverse-video C-X < - scroll window left C-X > - scroll window right C-X P - write screen photograph to file C-X E - exchange windows * Lisp Interface Commands * Buffer Browser * Split Screen option for Dired (and the Buffer Browser) * Two-Screen option (on 9836 with auxiliary color monitor) ------------------------------------------------------------------------------- |
Added psl-1983/nmode-guide.txt version [d9690c387b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMODE users Alan Snyder 28 October 1982 ------------------------------------------------------------------------------- NMODE is a new PSL text editor installed at HP. This note describes the NMODE editor in terms of its differences from EMODE, the previous PSL text editor. NMODE is a new editor that retains much of the basic structure and algorithms of EMODE. However, there are many differences between NMODE and EMODE, of interest to both users and experts. For experts, the differences can be summed up very easily: NMODE is a complete rewrite of EMODE. Virtually no EMODE function or fluid variable is present in NMODE. Thus, any code that interacts with the insides of EMODE must be rewritten to run in NMODE. Even code to define new function keys must be changed. In many cases, it is only necessary to change function names. However, code that accesses EMODE fluid variables probably requires greater revision, since many EMODE fluid variables have no counterparts in NMODE. In particular, there are no fluid variables containing information about the current buffer or the current window. Information describing how to customize NMODE by redefining keys or defining new commands may be found in the file "PSL:NMODE-CUSTOMIZING.TXT". For users, the differences between NMODE and EMODE can be divided into a number of categories: * New Lisp Interaction * Incompatible Changes * Limitations * Extension of existing commands to conform to EMACS * New EMACS commands implemented * Bug Fixes * Miscellaneous Improvements These categories are described below: ------------------------------------------------------------------------------- * New Lisp Interaction NMODE provides a new set of editor commands for executing forms from a buffer and interacting with the Break Handler. These commands use a new prefix character, C-], which echoes as "Lisp-". In the remainder of this document, the notation "Lisp-X" will be used to refer to the command sequence C-] X (where X is an arbitrary character). The "Lisp-" commands are available only in Lisp Mode. Three "Lisp-" commands are always available in Lisp mode: Lisp-E executes a form in the current buffer beginning at the start of the current line. (This command was invoked as M-E in EMODE.) Output produced by the execution of a Lisp form is written to an output buffer (called "OUTPUT" in NMODE), which will pop up automatically in the "other" window if it is not exposed when output occurs. As in EMODE, this automatic pop-up can be suppressed by setting the global variable *OutWindow to NIL; however, in NMODE, this flag will be ignored when a Break occurs. In NMODE, output is always written at the END of the output buffer, even if the input is coming from the same buffer. Thus, when you execute a form from the output buffer, the cursor will jump to the end of the buffer when the output is printed. However, the mark is set at the point where you did the Lisp-E, so you can get back using C-X C-X. Lisp-Y will yank the output from the previous Lisp-E into the current buffer. (This command was invoked as C-M-Y in EMODE.) The output is obtained from the output buffer. Only the starting and ending positions of the last output text are saved, so that if the output buffer has been modified, Lisp-Y may get the wrong text. Lisp-L will transfer to a "normal" PSL Lisp Listener. (This command was invoked as C-M-Z in EMODE.) To return to NMODE, evaluate the form (NMODE). In NMODE, the Lisp prompt is displayed as part of the window label when the OUTPUT buffer is displayed, as opposed to permanently reserving a separate line on the screen for the Lisp prompt as EMODE does. NMODE does not use a break menu. However, NMODE does provide a set of special commands that can be used when a Lisp evaluation has entered a break loop. These commands are: Lisp-B: print a backtrace Lisp-Q: quit out of current break loop Lisp-A: abort to top-level (restarts NMODE) Lisp-R: retry (from a continuable error) (existing ErrorForm is re-evaluated) Lisp-C: continue (from a continuable error) (value of the last form executed is used for the value) Lisp-?: Brief help on above commands. Lisp-C is used to return a new value as the result value of the offending form (in the case of a continuable error). The value is specified by executing a form using Lisp-E; Lisp-C then "returns" the most recent result of execution. Lisp-B by itself prints the normal backtrace. C-U Lisp-B will in addition print the names of "interpreter" functions, such as COND and PROG. C-U C-U Lisp-B will print a verbose backtrace that displays the entire contents of the stack. The PSL function YesP has been redefined in NMODE to use NMODE prompted string input. It requires that the user type "Yes" or "No". ------------------------------------------------------------------------------- * Incompatible Changes A number of existing EMODE functions are performed using different commands in NMODE, leaving their original commands either undefined or doing something different. These are: C-X C-R (Visit File): now C-X C-V (to conform with EMACS) M-E (Execute Form): now Lisp-E (typed as: C-] E) C-M-Y (Yank Last Output): now Lisp-Y (typed as: C-] Y) C-M-Z (Exit NMode): now Lisp-L (typed as: C-] L) C-X 2 (View Two Windows): now C-X 3 (to conform with EMACS) C-M-O (Forward Up List): now C-M-) (same as EMACS) ------------------------------------------------------------------------------- * Limitations There are limitations imposed by NMODE that are not present in EMODE: * Currently, NMODE can be used only with HP terminals and with the 9836 running an extended VT52 emulator (the extensions are to support display enhancements). * Currently, NMODE runs only on TOPS-20. ------------------------------------------------------------------------------- * Extension of existing commands to conform to EMACS A large number of existing EMODE commands have been extended in NMODE to conform either exactly or more closely to the EMACS definitions. Many of these changes relate to the use of command arguments (specified by C-U). In EMODE, C-U simply defines a positive repetition count and repetitively executes the definition of the following command character. In NMODE, C-U works as in EMACS: it can accept either a positive or negative argument, which is interpreted in arbitrary ways by the following command. The following EMODE commands have been extended in notable ways: C-@ With an argument, pops a ring of marks (which is per-buffer). C-K Is unaffected by trailing white space at the end of the line. C-L Now repositions the current window. Accepts C-U argument. C-N and C-P Now remember the "goal column". C-V and M-V Scroll by lines or screenfuls, according to C-U argument. C-X 1 With an argument, expands the bottom window instead of the top. C-X 2 Now makes the bottom window current (use C-X 3 for top window). C-X C-S Now won't save an unmodified buffer. C-X C-V Now offers to save a modified buffer. C-X D Obeys command argument (without arg, uses current directory). C-X K Now asks for the name of the buffer to kill. C-X O Now works even in 1-window mode. M-< and M-> Now set the mark. Return Now will move "into" a region of blank lines. ------------------------------------------------------------------------------- * New EMACS commands implemented The following EMACS commands are newly implemented in NMODE: BackSpace Move Backward Character C-% Replace String C-< Mark Beginning C-> Mark End C-G Aborts commands that request string input C-M-( Backward Up List C-M-) Forward Up List C-M-O Split Line C-M-R Reposition Window (for Lisp DEFUNs only) C-M-Return Same as M-M C-M-T Transpose Forms C-M-Tab Lisp Tab (also C-M-I) C-M-V Scroll other window C-M-W Append Next Kill C-Rubout Delete Backward Hacking Tabs C-Space Same as C-@ C-X 3 View Two Windows C-X 4 Visit in Other Window (Find File or Select Buffer) C-X A Append to Buffer C-X C-N Set Goal Column C-X C-T Transpose Lines C-X G Get Register C-X T Transpose Regions C-X X Put Register C-^ The "control prefix" (used to type things like C-%) M-0 thru M-9 Define a numeric argument (also C-0, C-M-0, etc.) M-Hyphen Defines a numeric argument (also C-Hyphen, C-M-Hyphen, etc.) M-R Move to Screen Edge M-Return Same as M-M M-T Transpose Words M-Tab inserts a "Tab" (also M-I) M-~ Buffer Not Modified ------------------------------------------------------------------------------- * Bug Fixes In the process of writing NMODE, a number of bugs in EMODE were fixed. These include: * M-Y has been made "safe". It checks that the contents of the region equal the contents of the current kill buffer before killing the region. * Dired SORT commands no longer throw away all user-specified changes. * The interaction between NMODE and the Lisp Environment is much more robust. It is much more difficult to get NMODE "screwed up". In NMODE, it is possible to Quit out of an "Unexpected EOF" error. * NMODE does not allow the user to select one of its internal buffers. * In NMODE, string input can be terminated only by Return or C-G (C-G aborts the command). * The M-? command now accepts any syntactically valid command, including character sequences using prefix characters. * NMODE will not screw up if the cursor is moved into a part of a line that does not show on the display. * The window position indicator ("--68%--") now works reasonably. * EMODE always advances to the next line after a M-E; NMODE suppresses this action in two cases where it is spurious: (1) when NMODE is starting up, (2) when the buffer pointer is at the beginning of the line, such as after "executing" a number. ------------------------------------------------------------------------------- * Miscellaneous Improvements * NMODE supports INIT files. When first started up, NMODE will execute the file "NMODE.INIT" on the user's home directory, if the file exists. The file should contain a sequence of Lisp forms. * Completion of buffer names is implemented in NMODE. Completion is requested using the Space character. * File names now always expand to the full "true" file name (as in EMACS). As a result, Find File will always find a file in an existing buffer if possible, regardless of the exact string typed by the user. In addition, file names specified by the user now MERGE with the default file name. * Find File now creates a reasonable buffer name, instead of using the exact string typed by the user. The buffer name will not be displayed on the mode line, if it is completely redundant. * "Lisp" and "Text" modes are now available; the choice is based on file name. In "Text" mode, the Lisp related commands (both C-M-* and Lisp-*) are undefined, Tab is self-inserting, and Rubout does not "hack tabs". * The M-X extended command interface has been implemented. The following M-X commands are defined: "M-X Lisp Mode" and "M-X Text Mode", which set the mode of the current buffer. * Display Refresh is interruptible, allowing faster type-ahead. Parenthesis matching is also interruptible, which is especially important in the case of inserting an unmatched parenthesis. * Prompting has been improved. * Horizontal scrolling is supported. Two new commands, C-X < and C-X >, are provided to scroll the window horizontally. They accept a C-U argument. * The buffer display now shows a '!' at the end of any line that extends past the right edge of the screen. * Displaying one buffer in two windows now works reasonably. * Each buffer has a modified flag which indicates whether the contents of the buffer have been changed since the buffer was last read or written. * The "mode line" now uses inverse video and is much more like EMACS. * Display enhancements are supported in a general fashion. A new command C-X V has been implemented to switch between normal and inverse video. * When entering string input, C-R will yank the default string into the input buffer. ------------------------------------------------------------------------------- |
Added psl-1983/nmode.exe version [360d0c81df].
cannot compute difference between binary files
Added psl-1983/nmode/-file.list version [5f30b1dd5b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE Source Files Summary - 15 February 1983 ------------------------------------------------------------------------------- AUTOFILL.SL - auto fill mode BROWSER.SL - browser object definition BROWSER-SUPPORT.SL - general support functions for browsers BUFFER-BROWSER.SL - the buffer browser (C-X C-B) BUFFER-IO.SL - support for PSL I/O to and from text buffers BUFFER-POSITION.SL - type representing (line,char) pairs BUFFER-WINDOW.SL - abstract data type mapping text buffer to virtual screen BUFFER.SL - auxiliary functions for operating on the current buffer BUFFERS.SL - functions managing set of existing buffers CASE-COMMANDS.SL - commands for changing the case of text COMMAND-INPUT.SL - functions for command input COMMANDS.SL - miscellaneous editor commands DEFUN-COMMANDS.SL - editor commands related to top-level definitions in code DIRED.SL - directory edit subsystem DISPATCH.SL - command dispatch table manager DOC.SL - online documentation facility EXTENDED-INPUT.SL - functions for reading extended characters FILEIO.SL - functions for I/O to and from files INCR.SL - incremental search command INDENT-COMMANDS.SL - editor commands relating to indentation KILL-COMMANDS.SL - editor commands relating to killing text LISP-COMMANDS.SL - miscellaneous editor commands relating to lisp code LISP-INDENTING.SL - commands and functions for indenting lisp code LISP-INTERFACE.SL - interaction between NMODE and Lisp (including MAIN) LISP-PARSER.SL - basic parser for Lisp code M-X.SL - the M-X command reader M-XCMD.SL - miscellaneous extended commands MODE-DEFS.SL - definitions of standard modes MODES.SL - mode definition functions MOVE-COMMANDS.SL - editor commands relating to cursor motion NMODE-20.SL - system dependent functions for Dec-20 NMODE-9836.SL - system dependent functions for HP9836 NMODE-ATTRIBUTES.SL - macros for constructing parsing attributes NMODE-BREAK.SL - NMODE's break handler NMODE-INIT.SL - initialization code NMODE-PARSING.SL - primitive functions for parsing source code PROMPTING.SL - string input and basic prompt line functions QUERY-REPLACE.SL - query-replace subsystem READER.SL - NMODE command reader REC.SL - recursive editing functions SCREEN-LAYOUT.SL - functions managing overall NMODE screen layout SEARCH.SL. - searching functions SET-TERMINAL-20.SL - Dec-20 terminal driver selection SET-TERMINAL-9836.SL - HP9836 terminal driver selection SOFTKEYS.SL - NMode softkeys (Esc-/) STRUCTURE-FUNCTIONS.SL - functions for moving about structured text TERMINAL-INPUT.SL - terminal input functions, including prompted input TEXT-BUFFER.SL - text buffer abstract data type TEXT-COMMANDS.SL - sentence, paragraph, and formatting stuff WINDOW.SL - auxiliary functions for manipulating the current window WINDOW-LABEL.SL - manages label area of a window |
Added psl-1983/nmode/-this-.directory version [182b213b12].
> > | 1 2 | This directory contains the sources and non-loadable binaries for the NMODE editor. |
Added psl-1983/nmode/autofill.b version [140ae67098].
cannot compute difference between binary files
Added psl-1983/nmode/autofill.sl version [df81b90130].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % AUTOFILL.SL - NMODE Auto-Fill Mode % % Author: Jeff Soreff % Hewlett-Packard/CRC % Date: 3 November 1982 % Revised: 18 January 1983 % % 16-Nov-82 Jeff Soreff % Fixed bugs (handling very long lines, breaking at punctuation) % and improved efficiency. % 29-Nov-82 Jeff Soreff % Fixed bug with too-long word. % 18-Jan-83 Jeff Soreff % Made autofill preserve textual context of buffer position. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int fast-strings fast-vectors)) % Externals used here: (fluid '(nmode-command-argument nmode-command-argument-given)) % Globals defined here: (fluid '(fill-prefix fill-column auto-fill-mode)) (setf fill-prefix nil) (setf fill-column 70) (setf auto-fill-mode (nmode-define-mode "Fill" '((auto-fill-setup)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de auto-fill-mode-command () (toggle-minor-mode auto-fill-mode)) (de auto-fill-setup () (if (eq (dispatch-table-lookup (x-char SPACE)) 'insert-self-command) (nmode-define-command (x-char SPACE) 'auto-fill-space) )) (de set-fill-column-command () (if nmode-command-argument-given (setq fill-column nmode-command-argument) (setq fill-column (current-display-column))) (write-message (bldmsg "%w%p" "Fill Column = " fill-column))) (de set-fill-prefix-command () (let ((temp (buffer-get-position))) (cond ((at-line-start?) (setq fill-prefix nil) (write-message "Fill Prefix now empty")) (t (move-to-start-of-line) (setq fill-prefix (extract-text nil (buffer-get-position) temp)) (buffer-set-position temp) (write-message (bldmsg "%w%p" "Fill Prefix now " (vector-fetch fill-prefix 0))))))) (de blank-char (char) (or (= char #\tab) (= char #\blank))) (de skip-forward-blanks-in-line () (while (and (not (at-line-end?)) (blank-char (next-character))) (move-forward))) (de skip-backward-blanks-in-line () (while (and (not (at-line-start?)) (blank-char (previous-character))) (move-backward))) (de skip-forward-nonblanks-in-line () (while (and (not (at-line-end?)) (not (blank-char (next-character)))) (move-forward))) (de auto-fill-space () (for (from i 1 nmode-command-argument 1) (do (insert-character #\blank))) (when (> (current-display-column) fill-column) (let ((word-too-long nil) (current-place (buffer-get-position))) (set-display-column fill-column) (while (or (not (at-line-end?)) word-too-long) (let ((start nil)(end nil)) (while (not (or (at-line-start?) (and (blank-char % start natural break (next-character)) (not (blank-char (previous-character)))))) (move-backward)) (unless (setf word-too-long (and (at-line-start?) (not (blank-char (next-character))))) (setf start (buffer-get-position)) (skip-forward-blanks-in-line) (setf end (buffer-get-position)) (when (buffer-position-lessp start current-place) % Correct for (if (buffer-position-lessp current-place end) % the extraction. (setf current-place start) % Within extracted interval (setf current-place % After extracted interval (buffer-position-create (buffer-position-line current-place) (- (buffer-position-column current-place) (- (buffer-position-column end) (buffer-position-column start))))))) (extract-text t start end) (when (buffer-position-lessp (buffer-get-position) current-place) (setf current-place % Correct for new line break being added (buffer-position-create (+ (buffer-position-line current-place) 1) (- (buffer-position-column current-place) (current-char-pos))))) (insert-eol) (when fill-prefix (insert-text fill-prefix) (setf current-place % Correct for prefix length (buffer-position-create (buffer-position-line current-place) (+ (buffer-position-column current-place) (string-length (vector-fetch fill-prefix 0)))))))) (if word-too-long (move-to-end-of-line) (set-display-column fill-column))) (buffer-set-position current-place)))) |
Added psl-1983/nmode/browser-support.b version [103dee6178].
cannot compute difference between binary files
Added psl-1983/nmode/browser-support.sl version [4241de960f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Browser-Support.SL - General Browser Support % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 October 1982 % Revised: 3 February 1983 % % 3-Feb-83 Alan Snyder % Revised to use Browser objects. % % This file contains support functions for browsers, such as the Buffer % Browser and DIRED. A browser is a buffer that displays a set of items, % one item per line, and allows the individual items to be manipulated. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load numeric-operators)) (on fast-integers) % External variables: (fluid '( nmode-current-buffer nmode-current-window nmode-command-argument nmode-command-argument-given )) % Global options: (fluid '( browser-split-screen )) (setf browser-split-screen NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % General Browser Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-enter (b) % Start up a browser using the buffer B. (=> b set-previous-buffer nmode-current-buffer) (let ((wp (nmode-window-position))) (=> b put 'window-status wp) (if browser-split-screen (if (eq wp 'bottom) (nmode-switch-windows)) (nmode-1-window) )) (buffer-select b) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Browser commands: attach these to keys in your browser mode %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-kill-and-exit-command () (browser-kill-deleted-items-command) (browser-exit-command) ) (de browser-exit-command () (let ((ws (=> nmode-current-buffer get 'window-status)) (browser (=> nmode-current-buffer get 'browser)) ) (window-kill-buffer) (nmode-set-window-position ws) (=> browser exit) )) (de browser-delete-command () % Mark items as 'deleted'. (browser-do-repeated-command 'delete-item () nil) ) (de browser-undelete-command () % Mark items as not 'deleted'. (browser-do-repeated-command 'undelete-item () nil) ) (de browser-undelete-backwards-command () % Mark items as not 'deleted'. (setf nmode-command-argument (- nmode-command-argument)) (browser-do-repeated-command 'undelete-item () nil) ) (de browser-kill-command () % Kill items. (browser-do-repeated-command 'kill-item () t) ) (de browser-ignore-command () % Ignore items: filter them out. (browser-do-repeated-command 'ignore-item () t) ) (de browser-view-command () % View the current item. (let* ((use-other (xor browser-split-screen nmode-command-argument-given)) (w (if use-other (nmode-other-window) nmode-current-window)) ) (if (browser-view-item w) (if use-other (nmode-2-windows) % display the other window (set-message "C-M-L returns to browser.") ) (Ding) ))) (de browser-edit-command () % Edit the current item. (let* ((use-other (xor browser-split-screen nmode-command-argument-given)) (w (if use-other (nmode-other-window) nmode-current-window)) ) (if (browser-view-item w) (cond (use-other (nmode-2-windows) % display the other window (nmode-select-window w) (set-message "C-X O returns to browser.") ) (t (set-message "C-M-L returns to browser.") )) (Ding) ))) (de browser-kill-deleted-items-command () (let ((browser (=> nmode-current-buffer get 'browser))) (=> browser kill-deleted-items) )) (de browser-undo-filter-command () (let* ((browser (=> nmode-current-buffer get 'browser)) (filter (=> browser undo-filter)) ) (if filter (set-prompt (bldmsg "Application of %w undone." filter)) (nmode-error "No filters have been applied to create this list.") ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Browser functions: use these in browser commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de browser-sort (prompt sorter) (let ((browser (=> nmode-current-buffer get 'browser))) (=> browser sort sorter) (write-prompt prompt) )) (de browser-view-item (w) % View the current item in the specified window. Return T if successful, % NIL otherwise. (let* ((browser (=> nmode-current-buffer get 'browser)) (buffer (=> browser view-item)) ) (when buffer (=> buffer set-previous-buffer nmode-current-buffer) (window-select-buffer w buffer) T ))) (de browser-do-repeated-command (msg args removes?) % Perform a browser command that takes a signed numeric argument to mean % a repetition count. On each iteration, the browser is sent % the specified message with the specified arguments. If REMOVES? is % true, then the browser operation may remove the current item and % it will return true if it does. (let ((browser (=> nmode-current-buffer get 'browser))) (if (> nmode-command-argument 0) (for (from i 1 nmode-command-argument) (do (when (not (=> browser current-item)) (Ding) (exit)) (if (not (and (lexpr-send browser msg args) removes?)) (move-to-next-line) ))) (for (from i 1 (- nmode-command-argument)) (do (when (current-line-is-first?) (Ding) (exit)) (move-to-previous-line) (when (not (=> browser current-item)) (move-to-next-line) (Ding) (exit)) (lexpr-send browser msg args) )) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (off fast-integers) |
Added psl-1983/nmode/browser.b version [9125a4822d].
cannot compute difference between binary files
Added psl-1983/nmode/browser.sl version [61489b62fd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Browser.SL - Browser object definition % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 4 February 1983 % Revised: 14 February 1983 % % This file implements browser objects. These objects form the basis of % a general browser support mechanism. See Browser-Support.SL for additional % support functions and Buffer-Browser.SL for an example of a browser % using this mechanism. % % 14-Feb-83 Alan Snyder % Fix bug in filter application (was trying to apply a macro). % 11-Feb-83 Alan Snyder % Fix &remove-current-item to reset the display buffer's modified flag. % Improve comments. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-vectors fast-int)) (load gsort) (de create-browser (display-buffer view-buffer header-text items current-sorter) % Create a brower. DISPLAY-BUFFER is the buffer to use for displaying the % items. VIEW-BUFFER is the buffer to use for viewing an item; if NIL, the % item is expected to provide its own buffer. HEADER-TEXT is a vector of % strings to display at the top of the display buffer; it may be NIL. ITEMS % is a list or vector containing the set of items to display (this data % structure will not be modified). CURRENT-SORTER may be NIL or a function % ID. If non-NIL, the function will be used to sort the initial set of % items. (make-instance 'browser 'display-buffer display-buffer 'view-buffer view-buffer 'header-text header-text 'items items 'current-sorter current-sorter )) (defflavor browser ( (display-buffer NIL) % buffer used to display items (view-buffer NIL) % buffer used to view items (NIL => ask item) (viewed-item NIL) % the item most recently viewed (header-text NIL) % text displayed at top of buffer items % vector of visible items (may have junk at end) first-item-linepos % line number of first item in display last-item-index % index of last item in ITEMS vector (filtered-items ()) % list of lists of items removed by filtering (current-sorter NIL) % sorter used if items are un-filtered ) () (initable-instance-variables display-buffer view-buffer header-text items current-sorter) ) % Methods provided by items: % % (=> item display-text) % Return string used to display the item. % % (=> item delete) % Mark the item as deleted. May do nothing if deletion is not supported. % May change the display-text. This method need not be provided if no % delete commands are provided in the particular browser. % % (=> item undelete) % Mark the item as not deleted. May do nothing if deletion is not % supported. May change the display-text. This method need not be provided % if no delete commands are provided in the particular browser. % % (=> item deleted?) % Return T if the item has been marked for deletion. This method need not % be provided if no delete commands are provided in the particular browser. % % (=> item kill) % Kill the real item. (Instead of just marking the item for deletion, this % should actually dispose of the item, if that action is supported.) May do % nothing if killing is not supported. Return T if the item is actually % killed, NIL otherwise. This method need not be provided if no delete % commands are provided in the particular browser. % % (=> item view-buffer buffer) % Return a buffer containing the item for viewing. If the buffer argument % is non-NIL, then that buffer should be used for viewing. Otherwise, the % item must provide its own buffer. % % (=> item cleanup) % Throw away any unneeded stuff, such as a buffer created for viewing. This % method is invoked when an item is no longer being viewed, or when the item % is being filtered out, or when the browser is being exited. % % (=> item apply-filter filter) % The item should apply the filter to itself and return T if the filter % matches the item and NIL otherwise. (defmethod (browser current-item) () % Return the current item, which is the item that is displayed on the % display-buffer's current line, or NIL, if there is no such item. (let ((index (- (=> display-buffer line-pos) first-item-linepos))) (when (and (>= index 0) (<= index last-item-index)) (vector-fetch items index) ))) (defmethod (browser current-item-index) () % Return the index of the current item, which is the item that is displayed % on the display-buffer's current line, or NIL, if there is no such item. (let ((index (- (=> display-buffer line-pos) first-item-linepos))) (when (and (>= index 0) (<= index last-item-index)) index ))) (defmethod (browser kill-item) () % Kill the current item, if any. Return T if the item is killed, % NIL otherwise. (let ((item (=> self current-item))) (when (=> item kill) (=> self &remove-current-item) ))) (defmethod (browser kill-deleted-items) () % Attempts to KILL all items that have been marked for deletion. % Returns a list of the items actually killed. (=> self &keep-items '&browser-item-not-killed ()) ) (defmethod (browser delete-item) () % Mark the current item as deleted, if any. Return T if the item exists, % NIL otherwise. (let ((item (=> self current-item))) (when item (=> item delete) (=> self &update-current-item) T ))) (defmethod (browser undelete-item) () % Mark the current item as not deleted, if any. Return T if the item exists, % NIL otherwise. (let ((item (=> self current-item))) (when item (=> item undelete) (=> self &update-current-item) T ))) (defmethod (browser view-item) () % View the current item, if any, in a separate buffer. % Return the buffer if the item exists, NIL otherwise. (let ((item (=> self current-item))) (when item (when viewed-item (=> viewed-item cleanup)) (setf viewed-item item) (=> item view-buffer view-buffer) % return the buffer ))) (defmethod (browser ignore-item) () % Ignore the current item, if any. Return T if the item exists. % Ignoring an item is like running a filter that accepts every item % except the current one, except that multiple successive ignores % coalesce into one filtered-item-set for undoing purposes. (let ((item (=> self &remove-current-item))) (when item (cond ((and filtered-items (eqcar (car filtered-items) 'IGNORE-COMMAND)) % add this item to the previous list of ignored items (let ((filter-set (car filtered-items))) (setf (cdr filter-set) (cons item (cdr filter-set))) )) (t (setf filtered-items (cons (list 'IGNORE-COMMAND item) filtered-items)) ))))) (defmethod (browser filter-items) (filter) % Remove those items that do not match the specified filter. % If some items are removed, then they are added as a set to the % list of filtered items, so that this step can be undone, and T % is returned. Otherwise, no new set is created, and NIL is returned. (let ((filtered-list (=> self &keep-items 'ev-send (list 'apply-filter (list filter))))) (when filtered-list (setf filtered-list (cons filter filtered-list)) (setf filtered-items (cons filtered-list filtered-items)) T ))) (defmethod (browser undo-filter) () % Undo the effect of the most recent active filtering step. % Return the filter or NIL if there are no active filtering steps. (when filtered-items (let ((filter (car (car filtered-items))) (the-items (cdr (car filtered-items))) (current-item (=> self current-item)) ) (setf filtered-items (cdr filtered-items)) (while the-items (let ((item (car the-items))) (setf the-items (cdr the-items)) (setf last-item-index (+ last-item-index 1)) (vector-store items last-item-index item) )) (=> self &sort-items) (=> self &update-display) (=> self select-item current-item) filter ))) (defmethod (browser exit) () (setf viewed-item NIL) (for (from i 0 last-item-index) (do (=> (vector-fetch items i) cleanup))) ) (defmethod (browser items) () % Return a list of the items. (for (from i 0 last-item-index) (collect (vector-fetch items i))) ) (defmethod (browser sort) (sorter) (let ((current-item (=> self current-item))) (setf current-sorter sorter) (=> self &sort-items) (=> self &update-display) (=> self select-item current-item) )) (defmethod (browser send-item) (msg args) % Send the current item, if any, the specified message with the specified % arguments. Return NIL if there is no current item; otherwise, return % the result of sending the message to the item. (let ((item (=> self current-item))) (when item (prog1 (lexpr-send item msg args) (=> self &update-current-item) )))) (defmethod (browser select-item) (item) % If ITEM is not NIL, then adjust the buffer pointer to point to % that item. (for (from i 0 last-item-index) (do (when (eq item (vector-fetch items i)) (=> display-buffer goto (+ i first-item-linepos) 0) (exit) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (browser init) (init-plist) (=> display-buffer put 'browser self) (setf items (cond ((ListP items) (List2Vector items)) ((VectorP items) (CopyVector items)) (t (List2Vector ())) )) (setf last-item-index (vector-upper-bound items)) (=> self &sort-items) (=> self &update-display) ) (defmethod (browser &update-display) () % Update the display. The cursor is moved to the first item. (=> display-buffer reset) (when header-text (=> display-buffer insert-text header-text) (=> display-buffer insert-eol) ) (setf first-item-linepos (=> display-buffer line-pos)) (for (from i 0 last-item-index) (do (let ((item (vector-fetch items i))) (=> display-buffer insert-line (=> item display-text)) ))) (=> display-buffer set-modified? NIL) (=> display-buffer goto first-item-linepos 0) ) (defmethod (browser &sort-items) () % Sort the items according to the current sorter, if any. % Do not update the display buffer. (when current-sorter (let ((list ())) (for (from i 0 last-item-index) (do (setf list (cons (vector-fetch items i) list))) ) (setf list (GSort list current-sorter)) (for (from i 0 last-item-index) (do (vector-store items i (car list)) (setf list (cdr list)) )) ))) (defmethod (browser &remove-current-item) () % Remove the current item from ITEMS and the display. % Return the item or NIL if there is no current item. (let ((index (=> self current-item-index))) (when index (let ((item (vector-fetch items index))) (for (from i (+ index 1) last-item-index) (do (vector-store items (- i 1) (vector-fetch items i)) )) (vector-store items last-item-index NIL) (setf last-item-index (- last-item-index 1)) (=> display-buffer move-to-start-of-line) (let ((start-pos (=> display-buffer position))) (=> display-buffer move-to-next-line) (=> display-buffer extract-region T start-pos (=> display-buffer position)) (=> display-buffer set-modified? NIL) ) item )))) (defmethod (browser &update-current-item) () % Update the display for the current item. (let ((index (=> self current-item-index))) (when index (let ((item (vector-fetch items index))) (=> display-buffer store-line (+ index first-item-linepos) (=> item display-text)) (=> display-buffer set-modified? NIL) )))) (defmethod (browser &keep-items) (fcn args) % Apply the function FCN once for each item. The first argument to FCN % is the item; the remaining items are ARGS (a list). % Remove those items for which FCN returns NIL and return them % in a list of items. (let ((removed-items ()) (ptr 0) (current-item-index (=> self current-item-index)) (new-current-item-index 0) ) (for (from i 0 last-item-index) (do (let ((item (vector-fetch items i)) (this-ptr ptr) ) (cond ((apply fcn (cons item args)) % keep it (vector-store items ptr item) (setf ptr (+ ptr 1)) ) (t % remove it (setf removed-items (cons item removed-items)) (=> item cleanup) )) (when (and current-item-index (= i current-item-index)) (setf new-current-item-index this-ptr)) ))) (setf last-item-index (- ptr 1)) (=> self &update-display) (=> display-buffer goto (+ new-current-item-index first-item-linepos) 0) removed-items )) (de &browser-item-not-killed (item) (or (not (=> item deleted?)) (not (=> item kill)) )) |
Added psl-1983/nmode/buffer-browser.b version [09304b0260].
cannot compute difference between binary files
Added psl-1983/nmode/buffer-browser.sl version [fa42fe7a77].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-Browser.SL - Buffer Browser Subsystem % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 October 1982 % Revised: 16 February 1983 % % This file implements a buffer browser subsystem. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 4-Feb-83 Alan Snyder % Rewritten using new browser support. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load extended-char fast-vectors fast-strings stringx)) % External variables: (fluid '( nmode-current-buffer nmode-current-window nmode-command-argument-given nmode-selectable-buffers )) % Internal static variables: (fluid '(Buffer-Browser-Mode Buffer-Browser-Command-List)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf Buffer-Browser-Mode (nmode-define-mode "Buffer-Browser" '( (nmode-define-commands Buffer-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf Buffer-Browser-Command-List (list (cons (x-char ?) 'buffer-browser-help) (cons (x-char D) 'browser-delete-command) (cons (x-char E) 'browser-edit-command) (cons (x-char F) 'buffer-browser-save-file-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char K) 'browser-kill-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char Q) 'browser-kill-and-exit-command) (cons (x-char R) 'buffer-browser-reverse-sort) (cons (x-char S) 'buffer-browser-sort) (cons (x-char U) 'browser-undelete-command) (cons (x-char V) 'browser-view-command) (cons (x-char X) 'browser-exit-command) (cons (x-char BACKSPACE) 'browser-undelete-backwards-command) (cons (x-char RUBOUT) 'browser-undelete-backwards-command) (cons (x-char SPACE) 'move-down-command) (cons (x-char M-~) 'buffer-browser-not-modified-command) )) (de buffer-browser-command () (buffer-browser nmode-command-argument-given) ) (de buffer-browser (all-buffers?) % Put up a buffer browser subsystem. If ALL-BUFFERS? is non-NIL, then include % buffers whose names begin with "+". (let* ((b (buffer-find-or-create "+BUFFERS")) (buffers (find-buffers all-buffers?)) (width (=> nmode-current-window width)) (current-item NIL) (header-text (vector (string-concat " " (string-pad-right "Buffer Name" 24) (string-pad-left "Size" 6) " " "File Name" ) "" )) (items (for (in b buffers) (collect (let ((item (create-buffer-browser-item b width))) (if (eq b nmode-current-buffer) (setf current-item item)) item)) )) ) (buffer-set-mode b Buffer-Browser-Mode) (let ((browser (create-browser b NIL header-text items #'buffer-browser-name-sorter) )) (=> browser select-item current-item) ) (browser-enter b) (buffer-browser-help) )) (de find-buffers (all-buffers?) % Return a list of buffers. (if all-buffers? nmode-selectable-buffers (nmode-user-buffers) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Special Buffer Browser commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-browser-help () (write-message "View Edit File-it Un/Delete Kill-now Ignore uN-ignore Sort Reverse-sort Quit" )) (de buffer-browser-save-file-command () (browser-do-repeated-command 'send-item '(save-file ()) NIL) ) (de buffer-browser-not-modified-command () (browser-do-repeated-command 'send-item '(set-unmodified ()) NIL) ) (de buffer-browser-reverse-sort () (nmode-set-immediate-prompt "Reverse Sort by ") (buffer-browser-reverse-sort-dispatch) ) (de buffer-browser-reverse-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/N (browser-sort "Reverse Sort by Name" 'buffer-browser-name-reverser)) (#/S (browser-sort "Reverse Sort by Size" 'buffer-browser-size-reverser)) (#/F (browser-sort "Reverse Sort by File" 'buffer-browser-file-reverser)) (#/M (browser-sort "Reverse Sort by Modified" 'buffer-browser-modified-reverser)) (#/? (nmode-set-immediate-prompt "Reverse Sort by (Name, Size, File, Modified) ") (buffer-browser-reverse-sort-dispatch) ) (t (write-prompt "") (Ding)) )) (de buffer-browser-sort () (nmode-set-immediate-prompt "Sort by ") (buffer-browser-sort-dispatch) ) (de buffer-browser-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/N (browser-sort "Sort by Name" 'buffer-browser-name-sorter)) (#/S (browser-sort "Sort by Size" 'buffer-browser-size-sorter)) (#/F (browser-sort "Sort by File" 'buffer-browser-file-sorter)) (#/M (browser-sort "Sort by Modified" 'buffer-browser-modified-sorter)) (#/? (nmode-set-immediate-prompt "Sort by (Name, Size, File, Modified) ") (buffer-browser-sort-dispatch) ) (t (write-prompt "") (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Sorting Predicates %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor buffer-browser-item b1 b2) (de buffer-browser-name-sorter (b1 b2) (let ((name1 (=> (=> b1 buffer) name)) (name2 (=> (=> b2 buffer) name)) ) (StringSortFn name1 name2) )) (de buffer-browser-name-reverser (b1 b2) (not (buffer-browser-name-sorter))) (de buffer-browser-size-sorter (b1 b2) (let ((s1 (=> (=> b1 buffer) visible-size)) (s2 (=> (=> b2 buffer) visible-size)) ) (or (< s1 s2) (and (= s1 s2) (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-size-reverser (b1 b2) (let ((s1 (=> (=> b1 buffer) visible-size)) (s2 (=> (=> b2 buffer) visible-size)) ) (or (> s1 s2) (and (= s1 s2) (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-file-sorter (b1 b2) (let ((f1 (or (=> (=> b1 buffer) file-name) "")) (f2 (or (=> (=> b2 buffer) file-name) "")) ) (StringSortFn f1 f2) )) (de buffer-browser-file-reverser (b1 b2) (not (buffer-browser-file-sorter b1 b2))) (de buffer-browser-modified-sorter (b1 b2) (let ((m1 (=> (=> b1 buffer) modified?)) (m2 (=> (=> b2 buffer) modified?)) ) (cond ((not (eq m1 m2)) (=> (=> b1 buffer) modified?)) % saying 'M1' results in compiler bug (t (buffer-browser-name-sorter b1 b2)) ))) (de buffer-browser-modified-reverser (b1 b2) (let ((m1 (=> (=> b1 buffer) modified?)) (m2 (=> (=> b2 buffer) modified?)) ) (cond ((not (eq m1 m2)) (=> (=> b2 buffer) modified?)) % saying 'M2' results in compiler bug (t (buffer-browser-name-sorter b1 b2)) ))) (undeclare-flavor b1 b2) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The buffer-browser-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-buffer-browser-item (b width) (make-instance 'buffer-browser-item 'buffer b 'display-width width )) (defflavor buffer-browser-item ( display-text display-width buffer (delete-flag NIL) ) () (gettable-instance-variables display-text buffer) (initable-instance-variables) ) (defmethod (buffer-browser-item init) (init-plist) (setf display-text (string-concat " " (if (=> buffer modified?) "*" " ") " " (string-pad-right (=> buffer name) 24) (string-pad-left (bldmsg "%d" (=> buffer visible-size)) 6) " " (or (=> buffer file-name) "") ) )) (defmethod (buffer-browser-item delete) () (when (not delete-flag) (cond ((not (buffer-killable? buffer)) (nmode-error (BldMsg "Buffer %w may not be deleted!" (=> buffer name))) ) (t (setf display-text (copystring display-text)) (string-store display-text 0 #/D) (setf delete-flag T) )))) (defmethod (buffer-browser-item undelete) () (when delete-flag (setf display-text (copystring display-text)) (string-store display-text 0 #\space) (setf delete-flag NIL) )) (defmethod (buffer-browser-item deleted?) () delete-flag ) (defmethod (buffer-browser-item kill) () (cond ((not (buffer-killable? buffer)) (nmode-error (BldMsg "Buffer %w may not be killed!" (=> buffer name))) NIL ) ((or (not (=> buffer modified?)) (YesP (BldMsg "Kill unsaved buffer %w?" (=> buffer name)))) (buffer-kill-and-detach buffer) T ))) (defmethod (buffer-browser-item view-buffer) (x) (if (buffer-is-selectable? buffer) buffer) ) (defmethod (buffer-browser-item cleanup) () ) (defmethod (buffer-browser-item apply-filter) (filter) (apply filter (list buffer)) ) (defmethod (buffer-browser-item save-file) () (when (=> buffer modified?) (save-file buffer) (when (not (=> buffer modified?)) (setf display-text (copystring display-text)) (string-store display-text 1 #\space) ))) (defmethod (buffer-browser-item set-unmodified) () (when (=> buffer modified?) (=> buffer set-modified? NIL) (when (not (=> buffer modified?)) (setf display-text (copystring display-text)) (string-store display-text 1 #\space) ))) |
Added psl-1983/nmode/buffer-io.b version [31af9df622].
cannot compute difference between binary files
Added psl-1983/nmode/buffer-io.sl version [43cb2f493f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-IO.SL - PSL I/O to and from NMODE buffers % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 26 August 1982 % Revised: 18 February 1983 % % Adapted from Will Galway's EMODE % % 18-Feb-83 Alan Snyder % Fix to adjust an exposed window when displaying output. % 16-Feb-83 Alan Snyder % Recode using objects; add output cache for efficiency. % Remove time-since-last-redisplay check (it causes a 2X slowdown); % now display output only after Newline or cache full. % Declare -> Declare-Flavor. % 30-Dec-82 Alan Snyder % Add declarations for buffers and windows; use fast-vectors (for efficiency). % 27-Dec-82 Alan Snyder % Use generic arithmetic for Time (for portability); reformat. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-vectors)) (fluid '(nmode-current-window *nmode-init-running)) (DefConst MaxChannels 32) % Maximum number of channels supported by PSL. (defflavor buffer-channel ( (editor-function NIL) % NIL or a function to obtain new input (input-buffer NIL) % NIL or a buffer to obtain input from (input-position NIL) % the current read pointer (output-buffer NIL) % NIL or a buffer to send output to (output-cache NIL) % cache of output (for efficiency) output-cache-pos % pointer into output cache ) () (settable-instance-variables) ) (fluid '(buffer-channel-vector)) (when (or (not (BoundP 'buffer-channel-vector)) (null buffer-channel-vector)) (setf buffer-channel-vector (MkVect (const MaxChannels))) ) (fluid '(*outwindow % T => expose output window on output )) (setf *outwindow T) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor text-buffer input-buffer output-buffer) (declare-flavor buffer-window w) (declare-flavor buffer-channel bc) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de OpenBufferChannel (input-buffer output-buffer Editor) % Open a channel for buffer I/O. Input-Buffer and Output-Buffer may be buffer % objects or NIL. Input will be read from the current location in the Input % Buffer. Output will be inserted at the current location in the Output % Buffer. Editor may be a function object (ID) or NIL. The Editor function % can be used if you want something to "happen" every time a reader begins to % read from the channel. If Editor is NIL, then the reader will simply % continue reading from the current location in the input buffer. (setf SpecialWriteFunction* 'buffer-print-character) (setf SpecialReadFunction* 'buffer-read-character) (setf SpecialCloseFunction* 'buffer-channel-close) (let ((chn (open "buffers" 'SPECIAL)) (bc (make-instance 'buffer-channel)) ) (vector-store buffer-channel-vector chn bc) (=> bc set-input-buffer input-buffer) (=> bc set-input-position (and input-buffer (=> input-buffer position))) (=> bc set-output-buffer output-buffer) (=> bc set-editor-function Editor) chn )) (de buffer-channel-close (chn) % Close up an NMODE buffer channel. (vector-store buffer-channel-vector chn NIL) ) (de buffer-channel-set-input-buffer (chn input-buffer) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-input-buffer input-buffer) (=> bc set-input-position (=> input-buffer position)) ))) (de buffer-channel-set-input-position (chn bp) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-input-position bp) ))) (de buffer-channel-set-output-buffer (chn output-buffer) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc set-output-buffer output-buffer) ))) (de buffer-print-character (chn ch) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc putc ch) ))) (de buffer-channel-flush (chn) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc flush) ))) (defmethod (buffer-channel flush) () % If there is output lingering in the output cache, then append it to the % output buffer and return T. Otherwise return NIL. (when (and output-buffer output-cache (> output-cache-pos 0)) (let ((old-pos (=> output-buffer position))) (=> output-buffer move-to-buffer-end) (=> output-buffer insert-string (substring output-cache 0 output-cache-pos)) (=> output-buffer set-position old-pos) (setf output-cache-pos 0) T ))) (defmethod (buffer-channel refresh) () % If this channel is being used for output, then refresh the display of that % output. The buffer will automatically be exposed in a window (if % requested by the *OutWindow flag), the output cache will be flushed, the % display window will be adjusted, and the screen refreshed. (when output-buffer (if (and *OutWindow (not *nmode-init-running) (not (buffer-is-displayed? output-buffer))) (nmode-expose-output-buffer output-buffer)) (let ((window-list (find-buffer-in-exposed-windows output-buffer))) (when window-list (=> self flush) (nmode-adjust-output-window (car window-list)) )))) (defmethod (buffer-channel put-newline) () (=> self flush) (let ((old-pos (=> output-buffer position))) (=> output-buffer move-to-buffer-end) (=> output-buffer insert-eol) (=> output-buffer set-position old-pos) ) (=> self refresh) ) (defmethod (buffer-channel putc) (ch) % "Print" character CH by appending it to the output buffer. (if (= ch #\EOL) (=> self put-newline) (when output-buffer (when (null output-cache) (setf output-cache (make-string 200 #\space)) (setf output-cache-pos 0) ) (string-store output-cache output-cache-pos ch) (setf output-cache-pos (+ output-cache-pos 1)) (when (>= output-cache-pos 200) (=> self flush) (=> self refresh) )))) (de nmode-adjust-output-window (w) (let ((output-buffer (=> w buffer))) (=> w set-position (=> output-buffer buffer-end-position)) (nmode-adjust-window w) (if (=> w exposed?) (nmode-refresh)) )) (de buffer-read-character (chn) (let ((bc (vector-fetch buffer-channel-vector chn))) (when bc (=> bc getc) ))) (defmethod (buffer-channel getc) () % Read a character from the input buffer; advance over that character. % Return End Of File if at end of buffer or if no buffer. If the "read % point" equals the "buffer cursor", then the "buffer cursor" will be % advanced also. (if (not input-buffer) #\EOF % Otherwise (there is an input buffer) (let* ((old-position (=> input-buffer position)) (was-at-cursor (buffer-position-equal input-position old-position)) result ) (=> input-buffer set-position input-position) (if (=> input-buffer at-buffer-end?) (setf result #\EOF) % Otherwise (not at end of buffer) (setf result (=> input-buffer next-character)) (=> input-buffer move-forward) (setf input-position (=> input-buffer position)) ) (if (not was-at-cursor) (=> input-buffer set-position old-position)) (if *ECHO (=> self putc result)) result ))) (de MakeInputAvailable () % THIS IS THE MAGIC FUNCTION invoked by READ, and other "reader functions". % IN* is a FLUID (actually GLOBAL) variable. (let ((bc (vector-fetch buffer-channel-vector IN*))) (when bc (=> bc run-editor) ))) (defmethod (buffer-channel run-editor) () (if editor-function (apply editor-function (list IN*))) NIL ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor input-buffer output-buffer) (undeclare-flavor w) (undeclare-flavor bc) |
Added psl-1983/nmode/buffer-position.b version [78b3235b4b].
cannot compute difference between binary files
Added psl-1983/nmode/buffer-position.sl version [65f46544e7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % BUFFER-POSITION.SL - Buffer Position Objects % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % % This file implements objects that store buffer positions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (de buffer-position-create (line-number column-number) (cons line-number column-number)) (de buffer-position-line (bp) (car bp)) (de buffer-position-column (bp) (cdr bp)) (de buffer-position-equal (bp1 bp2) (and (= (car bp1) (car bp2)) (= (cdr bp1) (cdr bp2)))) (de buffer-position-compare (bp1 bp2) (cond ((< (buffer-position-line bp1) (buffer-position-line bp2)) -1) ((> (buffer-position-line bp1) (buffer-position-line bp2)) 1) ((< (buffer-position-column bp1) (buffer-position-column bp2)) -1) ((> (buffer-position-column bp1) (buffer-position-column bp2)) 1) (t 0))) (de buffer-position-lessp (bp1 bp2) (<= (buffer-position-compare bp1 bp2) 0)) |
Added psl-1983/nmode/buffer-window.b version [0182bbe226].
cannot compute difference between binary files
Added psl-1983/nmode/buffer-window.sl version [6be72667c7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer-Window.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 August 1982 % Revised: 24 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A Buffer-Window object maintains an attachment between an editor buffer and a % virtual screen. This module is responsible for mapping the contents of the % editor buffer to an image on the virtual screen. A "window label" object % may be specified to maintain a descriptive label at the bottom of the % virtual screen (see comment for the SET-LABEL method). % % 24-Feb-83 Alan Snyder % Fixed bug: cursor positioning didn't take buffer-left into account. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Refresh now returns a flag indicating completion (no breakout). % Add cached method for label refresh. % 31-Jan-83 Alan Snyder % Modified to use separate window-label object to write the label area. % Note: SET-SIZE height argument is now interpreted as the screen height! % 20-Jan-83 Alan Snyder % Bug fix: adjust window after changing screen size. % 28-Dec-82 Alan Snyder % Replaced call to current-display-column in REFRESH, which was incorrect % because it assumes the buffer is current. Changed to display position of % window, rather than position of buffer (meaningful only when the window % package can display multiple cursors). Added methods: CHAR-POSITION, % SET-SCREEN, and &NEW-SCREEN. Changed EXPOSE to refresh first, for more % graceful screen update when using direct writing. Change label writing to % clear-eol after writing the label, not before, also for more graceful % screen update. Changed &WRITE-LINE-TO-SCREEN to buffer its changes in a % string, for efficiency. General cleanup. % 20-Dec-82 Alan Snyder % Added declarations for buffer and screen instance variables, for % efficiency. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors fast-strings display-char)) (de create-unlabeled-buffer-window (buffer virtual-screen) % Create a buffer window object that presents the specified buffer onto % the specified virtual-screen. There will be no label area. (make-instance 'buffer-window 'buffer buffer 'screen virtual-screen) ) (de create-buffer-window (buffer virtual-screen) % Create a buffer window object that presents the specified buffer onto % the specified virtual-screen. There will be a one-line label. (let ((w (create-unlabeled-buffer-window buffer virtual-screen))) (=> w set-label (create-window-label w)) w )) (defflavor buffer-window (height % number of rows of text (rows are 0 indexed) maxrow % highest numbered row width % number of columns of text (cols are 0 indexed) maxcol % highest numbered column (buffer-left 0) % leftmost buffer column displayed (buffer-top 0) % topmost buffer line displayed (overflow-marker #/!) % display character used to mark overlong lines (saved-position NIL) % buffer position saved here while not selected (label NIL) % the optional label-maintaining object (label-height 0) % number of lines occupied by the label (label-refresh-method NIL) % cached method for refreshing the label (text-enhancement (dc-make-enhancement-mask)) % display enhancement used in text area line-buffer % string of characters used to write line buffer % the buffer being displayed screen % the virtual screen used for display buffer-lines % vector of buffer lines currently displayed % % NIL used for EQable empty string ) () (gettable-instance-variables height width screen buffer buffer-left buffer-top text-enhancement ) (initable-instance-variables screen buffer text-enhancement ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor text-buffer buffer) (declare-flavor virtual-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (buffer-window select) () % This method is invoked when the window is selected. It restores the saved % buffer pointer, if any. It will not scroll the window: instead, it will % adjust the buffer position, if necessary, to keep the buffer pointer within % the window. (when saved-position (=> buffer set-position saved-position) (setf saved-position NIL) ) (=> self adjust-buffer) ) (defmethod (buffer-window deselect) () % This method is invoked when the window is deselected. It saves the current % buffer pointer, which will be restored when the window is again selected. % It adjusts the window to ensure that the window shows the saved position. (setf saved-position (=> buffer position)) (=> self adjust-window) ) (defmethod (buffer-window expose) () % Expose the window, putting it "on top" (expose the attached virtual screen). (=> self refresh nil) (=> screen expose) ) (defmethod (buffer-window deexpose) () % De-expose the window (de-expose the attached virtual screen). (=> screen deexpose) ) (defmethod (buffer-window exposed?) () (=> screen exposed?) ) (defmethod (buffer-window set-screen) (new-screen) (when (not (eq screen new-screen)) (let ((exposed? (=> screen exposed?)) (old-screen screen) ) (setf screen new-screen) (=> self &new-screen) (when exposed? (=> self expose) (=> old-screen deexpose)) ))) (defmethod (buffer-window set-label) (new-label) % Specify a "label" object to write a label at the bottom of the screen. NIL % implies that no label area is wanted. If an object is specified, it % must support the following operations: % (=> label height) % Return the number of lines occupied by the label area at the bottom % of the buffer-window's virtual screen. % (=> label resize) % Tell the label that the window has changed size. This may cause % the label to change its height, but should not cause a refresh. % (=> label refresh) % This instructs the label object to refresh the label area. The label % area is assumed to be the bottom-most <height> lines on the % buffer-window's virtual screen, although it could be on a totally % different virtual screen, if desired (in which case the "height" % operation should return 0). % This operation may change the number of lines available for text, which % may require adjusting the window position. A refresh is not done % immediately. (setf label new-label) (setf label-refresh-method (if label (object-get-handler label 'refresh))) (=> self &new-size) ) (defmethod (buffer-window position) () % If the window is selected, return the position of the buffer. Otherwise, % return the "saved position". (or saved-position (=> buffer position))) (defmethod (buffer-window line-position) () (if saved-position (buffer-position-line saved-position) (=> buffer line-pos) )) (defmethod (buffer-window char-position) () (if saved-position (buffer-position-column saved-position) (=> buffer char-pos) )) (defmethod (buffer-window set-position) (bp) % If the window is selected, set the buffer position. Otherwise, set the % "saved position". (if saved-position (setf saved-position bp) (=> buffer set-position bp) )) (defmethod (buffer-window set-line-position) (line) % If the window is selected, set the buffer position. % Otherwise, set the "saved position". (if saved-position (setf saved-position (buffer-position-create line 0)) (=> buffer set-line-pos line) )) (defmethod (buffer-window adjust-window) () % Adjust the window position, if necessary, to ensure that the current % buffer location (if the window is selected) or the saved buffer location % (if the window is not selected) is within the window. (let ((line (=> self line-position))) (if (or (< line buffer-top) (>= line (+ buffer-top height))) % The desired line doesn't show in the window. (=> self readjust-window) ))) (defmethod (buffer-window readjust-window) () % Adjust the window position to nicely show the current location. (let ((line (=> self line-position)) (one-third-screen (/ height 3)) ) (=> self set-buffer-top (if (>= line (- (=> buffer size) one-third-screen)) (- line (* 2 one-third-screen)) (- line one-third-screen) )))) (defmethod (buffer-window adjust-buffer) () % Adjust the buffer position, if necessary, to ensure that the current % buffer location is visible on the screen. If the window position is % past the end of the buffer, it will be changed. (let ((size (=> buffer size))) (cond ((>= buffer-top size) % The window is past the end of the buffer. (=> self set-buffer-top (- size (/ height 3))) ))) (let ((line (=> buffer line-pos))) (cond ((or (< line buffer-top) (>= line (+ buffer-top height))) % The current line doesn't show in the window. (=> buffer set-line-pos (+ buffer-top (/ height 3))) )))) (defmethod (buffer-window set-buffer) (new-buffer) (setf buffer new-buffer) (setf buffer-left 0) (setf buffer-top 0) (if saved-position (setf saved-position (=> buffer position))) (=> self adjust-window) (=> self &reset) ) (defmethod (buffer-window set-buffer-top) (new-top) (cond ((<= new-top 0) (setf new-top 0)) ((>= new-top (=> buffer visible-size)) (setf new-top (- (=> buffer visible-size) 1))) ) (setf buffer-top new-top) ) (defmethod (buffer-window set-buffer-left) (new-left) (when (~= new-left buffer-left) (if (< new-left 0) (setf new-left 0)) (when (~= new-left buffer-left) (setf buffer-left new-left) (=> self &reset) ))) (defmethod (buffer-window set-size) (new-height new-width) % Change the size of the screen to have the specified height and width. % The size is adjusted to ensure that there is at least one row of text. (setf new-height (max new-height (+ label-height 1))) (setf new-width (max new-width 1)) (when (or (~= new-height (=> screen height)) (~= new-width (=> screen width))) (=> screen set-size new-height new-width) (=> self &new-size) )) (defmethod (buffer-window set-text-enhancement) (e-mask) (when (~= text-enhancement e-mask) (setf text-enhancement e-mask) (=> screen set-default-enhancement e-mask) (=> self &reset) )) (defmethod (buffer-window refresh) (breakout-allowed) % Update the virtual screen (including the label) to correspond to the % current state of the attached buffer. Return true if the refresh % was completed (no breakout occurred). (if (not (and breakout-allowed (input-available?))) (let ((buffer-end (=> buffer visible-size))) (for (from row 0 maxrow) (for line-number buffer-top (+ line-number 1)) (do % NIL is used to represent all EMPTY lines, so that EQ will work. (let ((line (and (< line-number buffer-end) (=> buffer fetch-line line-number)))) (if (and line (string-empty? line)) (setf line NIL)) (when (not (eq line (vector-fetch buffer-lines row))) (vector-store buffer-lines row line) (=> self &write-line-to-screen line row) ))) ) (if (and label label-refresh-method) (apply label-refresh-method (list label))) (let* ((linepos (=> self line-position)) (charpos (=> self char-position)) (row (- linepos buffer-top)) (line (vector-fetch buffer-lines row)) (column (- (map-char-to-column line charpos) buffer-left)) ) (=> screen set-cursor-position row column) ) T % refresh completed ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (buffer-window init) (init-plist) (=> self &new-screen) ) (defmethod (buffer-window &new-screen) () (=> screen set-default-enhancement text-enhancement) (=> self &new-size) ) (defmethod (buffer-window &new-size) () % The size of the screen and/or label may have changed. Adjust % the internal state of the buffer-window accordingly. (if label (=> label resize)) % may change label height (setf label-height (if label (max 0 (=> label height)) 0)) (setf height (- (=> screen height) label-height)) (setf width (=> screen width)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf buffer-lines (make-vector maxrow 'UNKNOWN)) (setf line-buffer (make-string (+ maxcol 10) #\space)) (=> self adjust-window) % ensure that cursor is still visible ) (defmethod (buffer-window &reset) () % "Forget" information about displayed lines. (for (from i 0 maxrow) (do (vector-store buffer-lines i 'UNKNOWN)))) (defmethod (buffer-window &write-line-to-screen) (line row) (if (null line) (=> screen clear-to-eol row 0) % else (let ((count (=> self &compute-screen-line line))) (cond ((> count width) (=> screen write-string row 0 line-buffer maxcol) (=> screen write overflow-marker row maxcol) ) (t (=> screen write-string row 0 line-buffer count) (=> screen clear-to-eol row count) ))))) (defmacro &write-char (ch) % Used by &COMPUTE-SCREEN-LINE. `(progn (if (>= line-index 0) (string-store line-buf line-index ,ch)) (setf line-index (+ line-index 1)) (setf line-column (+ line-column 1)) )) (defmethod (buffer-window &compute-screen-line) (line) % Internal method used by &WRITE-LINE-TO-SCREEN. It fills the line buffer % with the appropriate characters and returns the number of characters in % the line buffer. (let ((line-buf line-buffer) % local variables are more efficient (line-column 0) (line-index (- buffer-left)) (the-width width) % local variables are more efficient ) (for (from i 0 (string-upper-bound line)) (until (> line-index the-width)) % have written past the right edge (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to spaces. (let ((tabcol (& (+ line-column 8) (~ 7)))) (while (< line-column tabcol) (&write-char #\space) ))) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (&write-char #/^) (&write-char (^ ch 8#100)) ) (t (&write-char ch)) )))) line-index )) (de map-char-to-column (line n) % Map character position N to the corresponding display column index with % respect to the specified LINE. Handle funny mapping of TABs and control % characters. (setf n (- n 1)) (let ((upper-bound (string-upper-bound line))) (if (> n upper-bound) (setf n upper-bound))) (for* (from i 0 n) (with (col 0)) (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to an appropriate number of spaces. (setf col (& (+ col 8) (~ 7))) ) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (setf col (+ col 2)) ) (t (setf col (+ col 1)) )))) (returns col))) (de map-column-to-char (line n) % Map display column index N to the corresponding character position with % respect to the specified LINE. Handle funny mapping of TABs and control % characters. (for* (from i 0 (string-upper-bound line)) (with (col 0)) (until (>= col n)) (do (let ((ch (string-fetch line i))) (cond ((= ch #\TAB) % TABs are converted to an appropriate number of spaces. (setf col (& (+ col 8) (~ 7))) ) ((or (< ch #\space) (= ch #\rubout)) % Control characters are converted to "uparrow" form. (setf col (+ col 2)) ) (t (setf col (+ col 1)) )))) (returns i) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor buffer screen) |
Added psl-1983/nmode/buffer.b version [ec347307ad].
cannot compute difference between binary files
Added psl-1983/nmode/buffer.sl version [9287c0e41d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffer.SL - Auxiliary Functions for manipulating the current buffer. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 August 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(nmode-current-buffer)) (declare-flavor text-buffer nmode-current-buffer) (de buffer-get-position () % Return the "current position" in the current buffer as a BUFFER-POSITION % object. (=> nmode-current-buffer position)) (de buffer-set-position (bp) % Set the "current position" in the current buffer from the specified % BUFFER-POSITION object. Clips the line-position and char-position. (if bp (=> nmode-current-buffer set-position bp))) (de current-buffer-goto (line-number char-number) % Set the "current position" in the current buffer. % Clips the line-position and char-position. (=> nmode-current-buffer goto line-number char-number)) (de current-line-pos () % Return the "current line position" in the current buffer. (=> nmode-current-buffer line-pos)) (de set-line-pos (n) % Set the "current line position" in the current buffer. % Clips the line-position and char-position. (=> nmode-current-buffer set-line-pos n)) (de current-char-pos () % Return the "current character position" in the current buffer. (=> nmode-current-buffer char-pos)) (de set-char-pos (n) % Set the "current character position" in the current buffer. % Clips the specified position to lie in the range 0..line-length. (=> nmode-current-buffer set-char-pos n)) (de current-display-column () % Return the column index corresponding to the current character position % in the display of the current line. In other words, what screen column % should the cursor be in (ignoring horizontal scrolling)? (map-char-to-column (current-line) (current-char-pos))) (de set-display-column (n) % Adjust the character position within the current buffer so that % the current display column will be the smallest possible value % not less than N. (The display column may differ than N because % certain characters display in multiple columns.) (set-char-pos (map-column-to-char (current-line) n))) (de current-buffer-size () % Return the number of lines in the current buffer. % This count may include a fake empty line at the end of the buffer. (=> nmode-current-buffer size)) (de current-buffer-visible-size () % Return the apparent number of lines in the current buffer. % The fake empty line that may be present at the end of the % buffer is not counted. (=> nmode-current-buffer visible-size)) (de current-line () % Return the current line in the current buffer (as a string). (=> nmode-current-buffer fetch-line (current-line-pos))) (de current-line-replace (s) % Replace the current line of the current buffer with the specified string. (=> nmode-current-buffer store-line (current-line-pos) s)) (de current-buffer-fetch (n) % Return the line at line position N within the current buffer. (=> nmode-current-buffer fetch-line n)) (de current-buffer-store (n l) % Store the line L at line position N within the current buffer. (=> nmode-current-buffer store-line n l)) (de set-mark (bp) % PUSH the specified position onto the ring buffer of marks associated with % the current buffer. The specified position thus becomes the current "mark". (=> nmode-current-buffer set-mark bp)) (de set-mark-from-point () % PUSH the current position onto the ring buffer of marks associated with % the current buffer. The current position thus becomes the current "mark". (=> nmode-current-buffer set-mark-from-point)) (de current-mark () % Return the current mark associated with the current buffer. (=> nmode-current-buffer mark)) (de previous-mark () % POP the current mark off the ring buffer of marks associated with the % current buffer. Return the new current mark. (=> nmode-current-buffer previous-mark)) (de reset-buffer () % Reset the contents of the current buffer to empty and "not modified". (=> nmode-current-buffer reset)) (de extract-region (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % pair (CONS direction-of-deletion vector-of-strings). The returned % direction is +1 if BP1 <= BP2, and -1 otherwise. The current position is % set to the beginning of the region if deletion is performed. (=> nmode-current-buffer extract-region delete-it bp1 bp2)) (de extract-text (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % vector-of-strings. The current position is set to the beginning of the % region if deletion is performed. (cdr (=> nmode-current-buffer extract-region delete-it bp1 bp2))) (de current-line-length () % Return the number of characters in the current line. (=> nmode-current-buffer current-line-length)) (de current-line-empty? () % Return T if the current line contains no characters. (=> nmode-current-buffer current-line-empty?)) (de current-line-blank? () % Return T if the current line contains no non-blank characters. (=> nmode-current-buffer current-line-blank?)) (de at-line-start? () % Return T if we are positioned at the start of the current line. (=> nmode-current-buffer at-line-start?)) (de at-line-end? () % Return T if we are positioned at the end of the current line. (=> nmode-current-buffer at-line-end?)) (de at-buffer-start? () % Return T if we are positioned at the start of the buffer. (=> nmode-current-buffer at-buffer-start?)) (de at-buffer-end? () % Return T if we are positioned at the end of the buffer. (=> nmode-current-buffer at-buffer-end?)) (de current-line-is-first? () % Return T if the current line is the first line in the buffer. (=> nmode-current-buffer current-line-is-first?)) (de current-line-is-last? () % Return T if the current line is the last line in the buffer. (=> nmode-current-buffer current-line-is-last?)) (de current-line-fetch (n) % Return the character at character position N within the current line. % An error is signalled if N is out of range. (=> nmode-current-buffer current-line-fetch n)) (de current-line-store (n c) % Store the character C at char position N within the current line. % An error is signalled if N is out of range. (=> nmode-current-buffer current-line-store n c)) (de move-to-buffer-start () % Move to the beginning of the current buffer. (=> nmode-current-buffer move-to-buffer-start)) (de move-to-buffer-end () % Move to the end of the current buffer. (=> nmode-current-buffer move-to-buffer-end)) (de move-to-start-of-line () % Move to the beginning of the current line. (=> nmode-current-buffer move-to-start-of-line)) (de move-to-end-of-line () % Move to the end of the current line. (=> nmode-current-buffer move-to-end-of-line)) (de move-to-next-line () % Move to the beginning of the next line. % If already at the last line, move to the end of the line. (=> nmode-current-buffer move-to-next-line)) (de move-to-previous-line () % Move to the beginning of the previous line. % If already at the first line, move to the beginning of the line. (=> nmode-current-buffer move-to-previous-line)) (de move-forward () % Move to the next character in the current buffer. % Do nothing if already at the end of the buffer. (=> nmode-current-buffer move-forward)) (de move-backward () % Move to the previous character in the current buffer. % Do nothing if already at the start of the buffer. (=> nmode-current-buffer move-backward)) (de next-character () % Return the character to the right of the current position. % Return NIL if at the end of the buffer. (=> nmode-current-buffer next-character)) (de previous-character () % Return the character to the left of the current position. % Return NIL if at the beginning of the buffer. (=> nmode-current-buffer previous-character)) (de insert-character (c) % Insert character C at the current position in the buffer and advance past % that character. (=> nmode-current-buffer insert-character c)) (de insert-eol () % Insert a line-break at the current position in the buffer and advance to % the beginning of the newly-formed line. (=> nmode-current-buffer insert-eol)) (de insert-line (l) % Insert the specified string as a new line in front of the % current line. Advance past the newly inserted line. (=> nmode-current-buffer insert-line l)) (de insert-string (s) % Insert the string S at the current position. Advance past the % newly-inserted string. Note: S must not contain EOL characters! (=> nmode-current-buffer insert-string s)) (de insert-text (v) % V is a vector of strings similar to LINES (e.g., the last string in V is % considered to be an unterminated line). Thus, V must have at least one % element. Insert this stuff at the current position and advance past it. (=> nmode-current-buffer insert-text v)) (de delete-next-character () % Delete the next character. % Do nothing if at the end of the buffer. (=> nmode-current-buffer delete-next-character)) (de delete-previous-character () % Delete the previous character. % Do nothing if at the beginning of the buffer. (=> nmode-current-buffer delete-previous-character)) (undeclare-flavor nmode-current-buffer) |
Added psl-1983/nmode/buffers.b version [0c953dfcc3].
cannot compute difference between binary files
Added psl-1983/nmode/buffers.sl version [812211d95b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Buffers.SL - Buffer Collection Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 25 January 1983 % % This file contains functions that manipulate the set of existing buffers. % % 25-Jan-83 Alan Snyder % Fix bug in buffer name completion: now accepts the name of an existing buffer % even when the name is a prefix of the name of some other buffer. % 29-Dec-82 Alan Snyder % Revise prompt-for-buffer code to use new prompted input. % PROMPT-FOR-EXISTING-BUFFER now completes on CR and LF, as well as SPACE. % 3-Dec-82 Alan Snyder % Added CLEANUP-BUFFERS. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-strings)) (load stringx) (fluid '(nmode-current-buffer nmode-current-window nmode-main-buffer nmode-output-buffer nmode-default-mode nmode-input-default )) (fluid '(nmode-selectable-buffers)) (if (not (boundp 'nmode-selectable-buffers)) (setf nmode-selectable-buffers NIL)) % Internals: (fluid '(prompt-for-buffer-command-list prompt-for-existing-buffer-command-list)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Creating buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-create-default (buffer-name) % Create a new buffer with the default mode. The name of the new buffer will % be the specified name if no buffer already exists with that name. % Otherwise, a similar name will be chosen. The buffer becomes selectable, % but is not selected. (buffer-create buffer-name nmode-default-mode)) (de buffer-create (buffer-name initial-mode) % Create a new buffer. The name of the new buffer will be the specified name % if no buffer already exists with that name. Otherwise, a similar name will % be chosen. The buffer becomes selectable, but is not selected. (setf buffer-name (buffer-make-unique-name buffer-name)) (let ((b (buffer-create-unselectable buffer-name initial-mode))) (setq nmode-selectable-buffers (cons b nmode-selectable-buffers)) b)) (de buffer-create-unselectable (buffer-name initial-mode) % Create a new buffer. The name of the new buffer will be the specified % name. The buffer will not be selectable. (let ((b (create-text-buffer buffer-name))) (=> b set-mode initial-mode) (=> b set-previous-buffer nmode-current-buffer) b)) (de buffer-make-unique-name (buffer-name) % Return a buffer name not equal to the name of any existing buffer. (setf buffer-name (string-upcase buffer-name)) (for* (with (root-name (string-concat buffer-name "-"))) (for count 0 (+ count 1)) (for name buffer-name (string-concat root-name (BldMsg "%d" count))) (do (if (not (buffer-exists? name)) (exit name))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Finding buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-find (buffer-name) % If a selectable buffer exists with the specified name (case does % not matter), then return it. Otherwise, return NIL. (for (in b nmode-selectable-buffers) (do (if (string-equal buffer-name (=> b name)) (exit b))) (returns nil) )) (de buffer-find-or-create (buffer-name) % Return the specified buffer, if it exists and is selectable. % Otherwise, create a buffer of that name and return it. (or (buffer-find buffer-name) (buffer-create-default buffer-name) )) (de buffer-exists? (buffer-name) % Return T if a selectable buffer exists with the specified name % (case does not matter), NIL otherwise. (if (buffer-find buffer-name) T NIL)) (de nmode-user-buffers () % Return a list of those selectable buffers whose names do not begin % with a '+'. (for (in b nmode-selectable-buffers) (when (~= (string-fetch (=> b name) 0) #/+)) (collect b) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Manipulating buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-is-selectable? (b) % Return T if the specified buffer is selectable. (MemQ b nmode-selectable-buffers)) (de buffer-set-mode (b mode) % Set the "mode" of the buffer B. If B is the current buffer, then the % mode is "established". (=> b set-mode mode) (when (eq b nmode-current-buffer) (nmode-establish-current-mode) (set-message "") )) (de cleanup-buffers () % Ask each buffer to "clean up" any unneeded storage. (for (in b nmode-selectable-buffers) (do (=> b cleanup)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Selecting Buffers: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-select (b) % If B is not NIL and B is a selectable buffer, then make it the current % buffer, attach it to the current window, and return it. Otherwise, do % nothing and return NIL. (window-select-buffer nmode-current-window b)) (de buffer-select-previous (b) % Select the previous buffer of B, if it exists and is selectable. % Otherwise, select the MAIN buffer. (if (not (buffer-select (=> b previous-buffer))) (buffer-select nmode-main-buffer)) ) (de buffer-select-by-name (buffer-name) % If the specified buffer exists and is selectable, select it and return it. % Otherwise, return NIL. (buffer-select (buffer-find buffer-name))) (de buffer-select-or-create (buffer-name) % Select the specified buffer, if it exists and is selectable. % Otherwise, create a buffer of that name and select it. (or (buffer-select-by-name buffer-name) (buffer-select (buffer-create-default buffer-name)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prompting for buffer names: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf prompt-for-buffer-command-list (list (cons (x-char SPACE) 'complete-input-buffer-name) (cons (x-char CR) 'check-input-buffer-name) (cons (x-char LF) 'check-input-buffer-name) )) (setf prompt-for-existing-buffer-command-list (list (cons (x-char SPACE) 'complete-input-buffer-name) (cons (x-char CR) 'complete-input-existing-buffer-name) (cons (x-char LF) 'complete-input-existing-buffer-name) )) (de prompt-for-buffer (prompt default-b) % Ask the user for the name of a buffer. If the user gives a name that does % not name an existing buffer, a new buffer with that name will be created % (but NOT selected), and the prompt "(New Buffer)" will be displayed. % Return the buffer. DEFAULT-B is the buffer to return as default (it may % be NIL). A valid buffer will always be returned (the user may ABORT). (let* ((default-name (and default-b (=> default-b name))) (name (prompt-for-string-special prompt default-name prompt-for-buffer-command-list )) ) (or (buffer-find name) (prog1 (buffer-create-default (string-upcase name)) (write-prompt "(New Buffer)") )))) (de prompt-for-existing-buffer (prompt default-b) % Ask the user for the name of an existing buffer. Return the buffer. % DEFAULT-B is the buffer to return as default (it may be NIL). A valid % buffer will always be returned, unless the user aborts (throw 'ABORT). (let* ((default-name (and default-b (=> default-b name))) (name (prompt-for-string-special prompt default-name prompt-for-existing-buffer-command-list )) ) (buffer-find name) )) % Internal functions: (de complete-input-buffer-name () % Extend the string in the input buffer as far as possible to match the set of % existing buffers. Return T if the resulting string names an existing % buffer; otherwise Beep and return NIL. (let* ((name (nmode-get-input-string)) (names (buffer-names-that-match name)) ) (when (not (null names)) (setf name (strings-largest-common-prefix names)) (nmode-replace-input-string name) ) (if (member name names) T (progn (Ding) NIL) ))) (de check-input-buffer-name () % Check the string in the input buffer to ensure that it is non-empty, or if % it is empty, that the default string exists and is not empty. Beep if this % condition fails, otherwise terminate the input. (if (or (not (string-empty? (nmode-get-input-string))) (and nmode-input-default (not (string-empty? nmode-input-default)))) (nmode-terminate-input) (Ding) )) (de complete-input-existing-buffer-name () % If the input buffer is empty and there is a default string, substitute the % default string. Then, extend the string in the input buffer as far as % possible to match the set of existing buffers. If the resulting string % names an existing buffer, refresh and terminate input. Otherwise, beep. (nmode-substitute-default-input) (when (complete-input-buffer-name) (nmode-refresh) (nmode-terminate-input) )) (de buffer-names-that-match (name) (for (in b nmode-selectable-buffers) (when (buffer-name-matches b name)) (collect (=> b name)))) (de buffer-name-matches (b name2) (let* ((len2 (string-length name2)) (name1 (=> b name)) (len1 (string-length name1)) ) (and (>= len1 len2) (string-equal (substring name1 0 len2) name2) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Attaching buffers to windows %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-select-buffer (w b) % If B is not NIL and B is a selectable buffer, then attach B to the window % W and return B. Otherwise, do nothing and return NIL. (cond ((and b (buffer-is-selectable? b)) (=> w set-buffer b) (nmode-adjust-window w) (cond ((eq w nmode-current-window) (setf nmode-current-buffer b) (nmode-establish-current-mode) (reset-message) )) b ))) (de window-select-previous-buffer (w) % Replace window W's current buffer with that buffer's previous % buffer, if it exists and is selectable. Otherwise, replace % it with the MAIN buffer. (if (not (window-select-buffer w (=> (=> w buffer) previous-buffer))) (window-select-buffer w nmode-main-buffer))) (de window-copy-buffer (w-source w-dest) % Attach to window W-DEST the buffer belonging to window W-SOURCE. % Duplicate the window's BUFFER-TOP and BUFFER-LEFT as well. % If W is the current window, then the buffer becomes the current buffer. (let ((b (=> w-source buffer))) (=> w-dest set-buffer b) (=> w-dest set-buffer-top (=> w-source buffer-top)) (=> w-dest set-buffer-left (=> w-source buffer-left)) (cond ((eq w-dest nmode-current-window) (setf nmode-current-buffer b) (nmode-establish-current-mode) (reset-message) )) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Killing Buffers %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de window-kill-buffer () % This function kills the buffer associated with the current window and % detaches it from that window or any other window (replacing it with % another buffer, preferrably the buffer's "previous buffer"). % Do not kill the MAIN or OUTPUT buffer. (buffer-kill-and-detach (=> nmode-current-window buffer))) (de buffer-kill-and-detach (b) % Kill the specified buffer and detach it from any existing windows % (replacing with another buffer, preferrably the buffer's previous buffer). % Do not kill the MAIN or OUTPUT buffer. (if (buffer-kill b) (for (in w (find-buffer-in-windows b)) (do (window-select-previous-buffer w))))) (de buffer-killable? (b) (not (or (eq b nmode-main-buffer) (eq b nmode-output-buffer) ))) % Internal function: (de buffer-kill (b) % Remove the specified buffer from the list of selectable buffers and return % T, unless the buffer is the MAIN or OUTPUT buffer, in which case do % nothing and return NIL. (let ((kill? (buffer-killable? b))) (if kill? (setf nmode-selectable-buffers (DelQ b nmode-selectable-buffers)) ) kill? )) |
Added psl-1983/nmode/case-commands.b version [e6433effe8].
cannot compute difference between binary files
Added psl-1983/nmode/case-commands.sl version [88b3316c73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Case-Commands.SL - NMODE Case Conversion commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 October 1982 % % The original code was contributed by Jeff Soreff. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-vectors fast-strings)) (fluid '( nmode-command-argument nmode-current-buffer )) % Global variables: (fluid '(shifted-digits-association-list)) (setf shifted-digits-association-list NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Case Conversion Commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de uppercase-word-command () (transform-region-with-next-word-or-fragment #'string-upcase)) (de lowercase-word-command () (transform-region-with-next-word-or-fragment #'string-downcase)) (de uppercase-initial-command () (transform-region-with-next-word-or-fragment #'string-capitalize)) (de uppercase-region-command () (transform-marked-region #'string-upcase)) (de lowercase-region-command () (transform-marked-region #'string-downcase)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Upcase Digit Command: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de upcase-digit-command () % Convert the previous digit to the corresponding "shifted character" % on the keyboard. Search only within the current line or the previous % line. Ding if no digit found. (let ((point (buffer-get-position)) (limit-line-pos (- (current-line-pos) 1)) (ok NIL) ) (while (and (>= (current-line-pos) limit-line-pos) (not (at-buffer-start?)) (not (setf ok (digitp (previous-character)))) ) (move-backward) ) (cond ((and ok (set-up-shifted-digits-association-list)) (let* ((old (previous-character)) (new (cdr (assoc old shifted-digits-association-list))) ) (delete-previous-character) (insert-character new) )) (t (Ding)) ) (buffer-set-position point) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % General Transformation Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de transform-region (string-conversion-function bp1 bp2) % Transform the region in the current buffer between the positions % BP1 and BP2 by applying the specified function to each partial or % complete line. The function should accept a single string argument % and return the transformed string. Return 1 if BP2 > BP1; % return -1 if BP2 < BP1. The buffer pointer is left at the "end" % of the transformed region (the greater of BP1 and BP2). (let* ((modified-flag (=> nmode-current-buffer modified?)) (extracted-pair (extract-region t bp1 bp2)) (newregion (cdr extracted-pair)) (oldregion (if (not modified-flag) (copyvector newregion))) ) (for (from index 0 (vector-upper-bound newregion) 1) (do (vector-store newregion index (apply string-conversion-function (list (vector-fetch newregion index)))))) (insert-text newregion) (if (and (not modified-flag) (text-equal newregion oldregion)) (=> nmode-current-buffer set-modified? nil) ) (car extracted-pair) )) (de transform-region-with-next-word-or-fragment (string-conversion-function) % Transform the region consisting of the following N words, where N is % the command argument. N may be negative, meaning previous words. (let ((start (buffer-get-position))) (move-over-words nmode-command-argument) (transform-region string-conversion-function start (buffer-get-position)) )) (de transform-marked-region (string-conversion-function) % Transform the region defined by point and mark. (let ((point (buffer-get-position)) (mark (current-mark)) ) (when (= (transform-region string-conversion-function point mark) 1) % The mark was at the end of the region. If the transformation changed % the length of the region, the mark may need to be updated. (previous-mark) % pop off old mark (set-mark-from-point) % set the mark to the end of the transformed region (buffer-set-position point) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary Function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de set-up-shifted-digits-association-list () % Ensure that the "shifted digits association list" is set up properly. % If necessary, ask the user for the required information. Returns the % association list if properly set up, NIL if an error occurred. (if (not shifted-digits-association-list) (let ((shifted-digits (prompt-for-string "Type the digits 1, 2, ... 9, 0, holding down Shift:" nil))) (cond ((= (string-length shifted-digits) 10) (setq shifted-digits-association-list (pair (string-to-list "1234567890") (string-to-list shifted-digits)))) ((> (string-length shifted-digits) 10) (nmode-error "Typed too many shifted digits!")) (t (nmode-error "Typed too few shifted digits!")) ))) shifted-digits-association-list ) |
Added psl-1983/nmode/command-input.b version [5cbc34ae5f].
cannot compute difference between binary files
Added psl-1983/nmode/command-input.sl version [f19b6ee3f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command-Input.SL - NMODE Command Input Routines % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command Prefix Character Functions: % % A command prefix character function must be tagged with the property % 'COMMAND-PREFIX. It should also define the property 'COMMAND-PREFIX-NAME % to be a string that will be used to print the command name of commands % that include a prefix character that is mapped to that function. (The % function DEFINE-COMMAND-PREFIX is used to set these properties.) The % function itself should return a command (see dispatch.sl for a description). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de define-command-prefix (function-name name-string) (put function-name 'command-prefix T) (put function-name 'command-prefix-name name-string) ) (de prefix-name (ch) % Return the string to be used in printing a command with this prefix char. (let ((func (dispatch-table-lookup ch))) (or (and func (get func 'command-prefix-name)) (string-concat (x-char-name ch) " ") ))) % Here we define some prefix command functions: (define-command-prefix 'c-x-prefix "C-X ") (define-command-prefix 'Esc-prefix "Esc-") (define-command-prefix 'Lisp-prefix "Lisp-") (define-command-prefix 'm-x-prefix "M-X ") (de c-x-prefix () (nmode-append-separated-prompt "C-X ") (let ((ch (input-terminal-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char C-X) ch) )) (de Esc-prefix () (nmode-append-separated-prompt "Esc-") (let ((ch (input-extended-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char ESC) ch) )) (de Lisp-prefix () (nmode-append-separated-prompt "Lisp-") (let ((ch (input-terminal-character))) (nmode-complete-prompt (x-char-name ch)) (list (x-char C-!]) ch) )) (de m-x-prefix () (list (x-char M-X) (prompt-for-extended-command "Extended Command:"))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Command Input Functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de input-base-character () (X-Base (input-terminal-character)) ) (de input-command () % Return either a single (extended) character or a list containing a valid % prefix character plus its argument (character or string). (let* ((ch (input-extended-character)) (func (dispatch-table-lookup ch)) ) (if (and func (get func 'command-prefix)) (apply func ()) ch ))) |
Added psl-1983/nmode/commands.b version [d48e408a96].
cannot compute difference between binary files
Added psl-1983/nmode/commands.sl version [d8079889cd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Commands.SL - Miscellaneous NMODE commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 3 December 1982 % % 3-Dec-82 Alan Snyder % Changed Insert-Self-Command to handle control- and meta- characters. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int)) % External variables used: (fluid '(nmode-current-buffer nmode-command-argument nmode-current-window nmode-command-argument-given nmode-current-command nmode-terminal nmode-allow-refresh-breakout Text-Mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de insert-self-command () (if (FixP nmode-current-command) (let ((ch (x-base nmode-current-command))) (if (x-control? nmode-current-command) (let ((nch (char-upcase ch))) (if (and (>= nch #/@) (<= nch #/_)) (setf ch (^ nch #/@)) ))) (for (from i 1 nmode-command-argument) (do (insert-character ch))) ) % otherwise (Ding) )) (de insert-next-character-command () (nmode-append-separated-prompt "C-Q") (let ((ch (x-base (input-direct-terminal-character)))) (nmode-complete-prompt (string-concat " " (x-char-name ch))) (for (from i 1 nmode-command-argument) (do (insert-character ch))))) (de return-command () % Insert an EOL, unless we are at the end of thee current line and the % next line is empty. Repeat as directed. (for (from i 1 nmode-command-argument) (do (cond ((and (at-line-end?) (not (at-buffer-end?))) (move-to-next-line) (cond ((not (current-line-empty?)) (insert-eol) (move-to-previous-line) ))) (t (insert-eol)))))) (de select-buffer-command () (buffer-select (prompt-for-selectable-buffer))) (de prompt-for-selectable-buffer () (let ((default-b (=> nmode-current-buffer previous-buffer))) (if (and default-b (not (buffer-is-selectable? default-b))) (setf default-b NIL)) (prompt-for-buffer "Select Buffer: " default-b))) (de kill-buffer-command () (let ((b (prompt-for-existing-buffer "Kill buffer: " nmode-current-buffer))) (if (or (not (=> b modified?)) (YesP "Kill unsaved buffer?")) (buffer-kill-and-detach b)))) (de insert-buffer-command () (let ((b (prompt-for-existing-buffer "Insert Buffer:" nmode-current-buffer))) (insert-buffer-into-buffer b nmode-current-buffer) )) (de select-previous-buffer-command () (let ((old-buffer nmode-current-buffer)) (buffer-select-previous nmode-current-buffer) (if (eq old-buffer nmode-current-buffer) (Ding)) % nothing visible happened )) (de visit-in-other-window-command () (nmode-2-windows) (selectq (char-upcase (input-base-character)) (#/B (let ((b (prompt-for-selectable-buffer))) (window-select-buffer (nmode-other-window) b))) (#/F (find-file-in-window (nmode-other-window) (prompt-for-file-name "Find file: " NIL) )) (t (Ding)) )) (de nmode-refresh-command () (if nmode-command-argument-given (let* ((arg nmode-command-argument) (w nmode-current-window) (height (=> w height)) (line (current-line-pos)) ) (if (>= arg 0) (=> w set-buffer-top (- line arg)) (=> w set-buffer-top (- (- line height) arg))) (nmode-refresh) ) % Otherwise (=> nmode-current-window readjust-window) (nmode-full-refresh) )) (de open-line-command () (for (from i 1 nmode-command-argument) (do (insert-eol) (move-backward) ))) (de Ding () (=> nmode-terminal ring-bell)) (de buffer-not-modified-command () (=> nmode-current-buffer set-modified? NIL) ) (de set-mark-command () (cond (nmode-command-argument-given (buffer-set-position (current-mark)) (previous-mark) ) (t (set-mark-from-point) ))) (de mark-beginning-command () (let ((old-pos (buffer-get-position))) (move-to-buffer-start) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-end-command () (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (set-mark-from-point) (buffer-set-position old-pos) )) (de transpose-characters-command () (cond ((or (at-line-start?) (< (current-line-length) 2)) (Ding) ) (t (if (at-line-end?) % We are at the end of a non-empty line. (move-backward) ) % We are in the middle of a line. (let ((ch (previous-character))) (delete-previous-character) (move-forward) (insert-character ch) ) ))) (de mark-word-command () (let ((old-pos (buffer-get-position))) (move-forward-word-command) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-form-command () (let ((old-pos (buffer-get-position))) (move-forward-form-command) (set-mark-from-point) (buffer-set-position old-pos) )) (de mark-whole-buffer-command () (move-to-buffer-end) (set-mark-from-point) (move-to-buffer-start) ) (de nmode-abort-command () (throw 'abort NIL) ) (de start-scripting-command () (let ((b (prompt-for-buffer "Script Input to Buffer:" NIL))) (nmode-script-terminal-input b) )) (de stop-scripting-command () (nmode-script-terminal-input nil) ) (de execute-buffer-command () (let ((b (prompt-for-buffer "Execute from Buffer:" NIL))) (setf nmode-allow-refresh-breakout nmode-command-argument-given) (nmode-execute-buffer b) )) (de execute-file-command () (nmode-execute-file (prompt-for-file-name "Execute File:" NIL))) (de nmode-execute-file (fn) (let ((b (buffer-create-unselectable "FOO" Text-Mode))) (read-file-into-buffer b fn) (setf nmode-allow-refresh-breakout nmode-command-argument-given) (nmode-execute-buffer b) )) (de apropos-command () (let ((s (prompt-for-string "Show commands whose names contain the string:" NIL ))) (nmode-begin-typeout) (print-matching-dispatch s) (printf "-----") (nmode-end-typeout) )) |
Added psl-1983/nmode/defun-commands.b version [8e7db99afe].
cannot compute difference between binary files
Added psl-1983/nmode/defun-commands.sl version [21ed3c9979].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Defun-Commands.SL - NMODE DEFUN commands and functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-command-argument nmode-command-argument-given nmode-current-command )) % Global variables: (fluid '(nmode-defun-predicate nmode-defun-scanner )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Defun Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de reposition-window-command () % Adjust the current window so that the beginning of the % current DEFUN is on the top line of the screen. If this change % would push the current line off the screen, do nothing but ring % the bell. (let ((old-pos (buffer-get-position))) (when (move-to-start-of-current-defun) % if search for defun succeeds (let ((old-line (buffer-position-line old-pos)) (defun-line (current-line-pos)) ) (if (or (< old-line defun-line) % Impossible? (>= old-line (+ defun-line (current-window-height))) ) (Ding) % Old Line wouldn't show on the screen % otherwise (current-window-set-top-line defun-line) )) (buffer-set-position old-pos) ))) (de end-of-defun-command () % This command has a very strange definition in EMACS. I don't even % want to try to explain it! It is probably a kludge in EMACS since % it generates very strange error messages! (if (< nmode-command-argument 0) (move-backward)) % First, we must get positioned up at the beginning of the proper defun. % If we are within a defun, we want to start at the beginning of that % defun. If we are between defuns, then we want to start at the beginning % of the next defun. (if (not (move-to-start-of-current-defun)) (move-forward-defun)) % Next, we move to the requested defun, and complain if we can't find it. (unless (cond ((> nmode-command-argument 1) (move-over-defuns (- nmode-command-argument 1))) ((< nmode-command-argument 0) (move-over-defuns nmode-command-argument)) (t t) ) (Ding) ) % Finally, we move to the end of whatever defun we wound up at. (if (not (move-to-end-of-current-defun)) (Ding)) ) (de mark-defun-command () (cond ((or (move-to-end-of-current-defun) (and (move-forward-defun) (move-to-end-of-current-defun)) ) (set-mark-from-point) (move-backward-defun) (when (not (current-line-is-first?)) (move-to-previous-line) (if (not (current-line-blank?)) (move-to-next-line)) )) (t (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Defun Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-backward-defun () % Move backward at least one character to the previous beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (when (move-backward-character) (or (beginning-of-defun) (progn (move-forward-character) NIL) % return NIL ))) (de beginning-of-defun () % Move backward, if necessary, to the beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) (move-to-start-of-line) (while T (when (current-line-is-defun?) (exit T)) (when (current-line-is-first?) (buffer-set-position old-pos) (exit NIL)) (move-to-previous-line) ))) (de move-forward-defun () % Move forward at least one character to the next beginning of a % "defun". If no defun is found, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) (while T (when (current-line-is-last?) (buffer-set-position old-pos) (exit NIL)) (move-to-next-line) (when (current-line-is-defun?) (exit T)) ))) (de move-to-start-of-current-defun () % If point lies within the text of a (possibly incomplete) defun, or on % the last line of a complete defun, then move to the beginning of the % defun. Otherwise, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) % save original position (if (beginning-of-defun) % find previous defun start (let ((start-pos (buffer-get-position))) % save defun starting position % We succeed if the current defun has no end, or if the end is % beyond the old position in the buffer. (if (or (not (scan-past-defun)) (<= (buffer-position-line old-pos) (current-line-pos)) ) (progn (buffer-set-position start-pos) T) (progn (buffer-set-position old-pos) NIL) ))))) (de move-to-end-of-current-defun () % If point lies within the text of a complete defun, or on the last line % of the defun, then move to the next line following the end of the defun. % Otherwise, return NIL and leave point unchanged. (let ((old-pos (buffer-get-position))) % save original position (if (and (beginning-of-defun) % find previous defun start (scan-past-defun) % find end of that defun (<= (buffer-position-line old-pos) (current-line-pos)) ) (progn (move-to-next-line) T) (progn (buffer-set-position old-pos) NIL) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Defun Scanning Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-line-is-defun? () (if nmode-defun-predicate (apply nmode-defun-predicate ()) )) (de scan-past-defun () % This function should be called with point at the start of a defun. % It will scan past the end of the defun (not to the beginning of the % next line, however). If the end of the defun is not found, it returns % NIL and leaves point unchanged. (if nmode-defun-scanner (apply nmode-defun-scanner ()) )) |
Added psl-1983/nmode/dired.b version [350b323cb0].
cannot compute difference between binary files
Added psl-1983/nmode/dired.sl version [04bd61424f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DIRED.SL - Directory Editor Subsystem % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 July 1982 % Revised: 16 February 1983 % % This file implements a directory editor subsystem. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % Fix cleanup method to NIL out the buffer variable to allow the buffer object % to be garbage collected. % 11-Feb-83 Alan Snyder % Fix bug in previous change. % 8-Feb-83 Alan Snyder % Enlarge width of size field in display. % 4-Feb-83 Alan Snyder % Rewritten to use new browser support. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load extended-char fast-strings)) (load directory stringx) % External variables: (fluid '( nmode-current-buffer nmode-current-window nmode-terminal nmode-command-argument nmode-command-argument-given )) % Internal static variables: (fluid '(File-Browser-Mode File-Browser-Command-List)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf File-Browser-Mode (nmode-define-mode "File-Browser" '( (nmode-define-commands File-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf File-Browser-Command-List (list (cons (x-char ?) 'dired-help) (cons (x-char D) 'browser-delete-command) (cons (x-char E) 'browser-edit-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char K) 'browser-kill-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char Q) 'dired-exit) (cons (x-char R) 'dired-reverse-sort) (cons (x-char S) 'dired-sort) (cons (x-char U) 'browser-undelete-command) (cons (x-char V) 'browser-view-command) (cons (x-char X) 'dired-exit) (cons (x-char BACKSPACE) 'browser-undelete-backwards-command) (cons (x-char RUBOUT) 'browser-undelete-backwards-command) (cons (x-char SPACE) 'move-down-command) (cons (x-char control D) 'browser-delete-command) (cons (x-char control K) 'browser-kill-command) )) (de dired-command () (let ((fn (=> nmode-current-buffer file-name)) directory-name ) (cond ((or (not fn) (>= nmode-command-argument 4)) (setf directory-name (prompt-for-string "Edit Directory: " NIL)) ) (nmode-command-argument-given (setf directory-name (namestring (pathname-without-version fn))) ) (t (setf directory-name (directory-namestring fn)) )) (directory-editor directory-name) )) (de edit-directory-command () (let* ((fn (=> nmode-current-buffer file-name)) (directory-name (prompt-for-string "Edit Directory:" (and fn (directory-namestring fn)) ))) (directory-editor directory-name) )) (de directory-editor (directory-name) % Put up a directory editor subsystem, containing all files that match the % specified string. If the string specifies a directory, then all files in % that directory are used. (setf directory-name (fixup-directory-name directory-name)) (write-prompt "Reading directory or directories...") (let ((items (dired-create-items (find-matching-files directory-name t)))) (if (null items) (write-prompt (BldMsg "No files match: %w" directory-name)) % ELSE (let* ((b (buffer-create "+FILES" File-Browser-Mode)) (header-text (vector (string-concat "Directory List of " directory-name) "" )) ) (=> b put 'directory-name directory-name) (create-browser b NIL header-text items #'dired-filename-sorter) (browser-enter b) (dired-help) )))) (de dired-create-items (file-list) % Accepts a list containing one element per file, where each element is % a list. Returns a list of file-browser-items. (when file-list (let* ((display-width (=> nmode-current-window width)) (names (for (in f file-list) (collect (fixup-file-name (nth f 1))) )) (prefix (trim-filename-to-prefix (strings-largest-common-prefix names))) (prefix-length (string-length prefix)) ) (for (in f file-list) (collect (create-file-browser-item display-width (nth f 1) % full-name (string-rest (fixup-file-name (nth f 1)) prefix-length) % nice-name (nth f 2) % deleted? (nth f 3) % size (nth f 4) % write-date (nth f 5) % read-date )))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED command procedures: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-exit () (let ((actions (dired-determine-actions nmode-current-buffer))) (if (and (null (first actions)) (null (second actions))) (browser-exit-command) % else (let ((command (dired-present-actions actions))) (cond ((eq command 'exit) (browser-exit-command) ) ((eq command t) (dired-perform-actions actions) (browser-exit-command) ) )) ))) (de dired-help () (write-message "View Edit Un/Delete Kill-now Ignore uN-ignore Sort Reverse-sort Quit" )) (de dired-reverse-sort () (nmode-set-immediate-prompt "Reverse Sort by ") (dired-reverse-sort-dispatch) ) (de dired-reverse-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/F (browser-sort "Reverse Sort by Filename" 'dired-filename-reverser)) (#/S (browser-sort "Reverse Sort by Size" 'dired-size-reverser)) (#/W (browser-sort "Reverse Sort by Write date" 'dired-write-reverser)) (#/R (browser-sort "Reverse Sort by Read date" 'dired-read-reverser)) (#/? (nmode-set-immediate-prompt "Reverse Sort by (Filename, Size, Read date, Write date) ") (dired-reverse-sort-dispatch) ) (t (write-prompt "") (Ding)) )) (de dired-sort () (nmode-set-immediate-prompt "Sort by ") (dired-sort-dispatch) ) (de dired-sort-dispatch () (selectq (char-upcase (input-base-character)) (#/F (browser-sort "Sort by Filename" 'dired-filename-sorter)) (#/S (browser-sort "Sort by Size" 'dired-size-sorter)) (#/W (browser-sort "Sort by Write date" 'dired-write-sorter)) (#/R (browser-sort "Sort by Read date" 'dired-read-sorter)) (#/? (nmode-set-immediate-prompt "Sort by (Filename, Size, Read date, Write date) ") (dired-sort-dispatch) ) (t (write-prompt "") (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DIRED Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dired-determine-actions (b) % Return a list containing two lists: the first a list of file names to be % deleted, the second a list of file names to be undeleted. (let ((items (=> (=> b get 'browser) items)) (delete-list ()) (undelete-list ()) ) (for (in item items) (do (selectq (=> item action-wanted) (delete (setf delete-list (aconc delete-list (=> item full-name)))) (undelete (setf undelete-list (aconc undelete-list (=> item full-name)))) ))) (list delete-list undelete-list) )) (de dired-present-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ) (nmode-begin-typeout) (dired-present-list delete-list "These files to be deleted:") (dired-present-list undelete-list "These files to be undeleted:") (while t (printf "%nDo It (YES, N, X)? ") (selectq (get-upchar) (#/Y (if (= (get-upchar) #/E) (if (= (get-upchar) #/S) (exit T) (Ding) (next)) (Ding) (next)) ) (#/N (exit NIL)) (#/X (exit 'EXIT)) (#/? (printf "%n YES-Do it, N-Return to DIRED, X-Exit from DIRED.")) (t (Ding)) )))) (de get-upchar () % This function is used during "normal PSL" typeout, so we cannot use % the NMODE input functions, for they will refresh the NMODE windows. (let ((ch (X-Base (=> nmode-terminal get-character)))) (when (AlphaP ch) (setf ch (char-upcase ch)) (WriteChar ch)) ch)) (de dired-present-list (list prompt) (when list (printf "%w%n" prompt) (for (in item list) (for count 0 (if (= count 1) 0 (+ count 1))) (do (printf "%w" (string-pad-right item 38)) (if (= count 1) (printf "%n")) ) ) (printf "%n") )) (de dired-perform-actions (action-list) (let ((delete-list (first action-list)) (undelete-list (second action-list)) ) (for (in file delete-list) (do (file-delete file))) (for (in file undelete-list) (do (file-undelete file))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Sorting predicates: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (declare-flavor file-browser-item f1 f2) (de dired-filename-sorter (f1 f2) (let ((n1 (=> f1 sort-name)) (n2 (=> f2 sort-name)) ) (if (string= n1 n2) (<= (=> f1 version-number) (=> f2 version-number)) (string<= n1 n2) ))) (de dired-filename-reverser (f1 f2) (not (dired-filename-sorter f1 f2))) (de dired-size-sorter (f1 f2) (let ((size1 (=> f1 size)) (size2 (=> f2 size)) ) (or (< size1 size2) (and (= size1 size2) (dired-filename-sorter f1 f2)) ))) (de dired-size-reverser (f1 f2) (let ((size1 (=> f1 size)) (size2 (=> f2 size)) ) (or (> size1 size2) (and (= size1 size2) (dired-filename-sorter f1 f2)) ))) (de dired-write-sorter (f1 f2) (let ((d1 (=> f1 write-date)) (d2 (=> f2 write-date)) ) (or (LessP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-write-reverser (f1 f2) (let ((d1 (=> f1 write-date)) (d2 (=> f2 write-date)) ) (or (GreaterP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-read-sorter (f1 f2) (let ((d1 (=> f1 read-date)) (d2 (=> f2 read-date)) ) (or (LessP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (de dired-read-reverser (f1 f2) (let ((d1 (=> f1 read-date)) (d2 (=> f2 read-date)) ) (or (GreaterP d1 d2) (and (EqN d1 d2) (dired-filename-sorter f1 f2)) ))) (undeclare-flavor f1 f2) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The file-browser-item flavor: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de create-file-browser-item (width full-name nice-name deleted? size write-date read-date) (make-instance 'file-browser-item 'full-name full-name 'nice-name nice-name 'deleted? deleted? 'size size 'write-date write-date 'read-date read-date 'display-width width )) (defflavor file-browser-item ( display-text display-width full-name % full name of file nice-name % file name as displayed sort-name % name without version (for sorting purposes) version-number % version number (or 0) (for sorting purposes) size % size of file (arbitrary units) write-date % write date of file (or NIL) read-date % read date of file (or NIL) deleted? % file is actually deleted delete-flag % user wants file deleted (buffer NIL) % buffer created to view file ) () (gettable-instance-variables display-text full-name nice-name sort-name version-number size write-date read-date) (initable-instance-variables) ) (defmethod (file-browser-item init) (init-plist) (let ((pn (pathname full-name))) (setf sort-name (namestring (pathname-without-version pn))) (setf version-number (pathname-version pn)) (if (not (fixp version-number)) (setf version-number 0)) ) (setf display-text (string-concat (if deleted? "D " " ") (string-pad-right nice-name (- display-width 48)) (string-pad-left (BldMsg "%d" size) 8) (string-pad-left (if write-date (file-date-to-string write-date) "") 19) (string-pad-left (if read-date (file-date-to-string read-date) "") 19) )) (setf delete-flag deleted?) ) (defmethod (file-browser-item delete) () (when (not delete-flag) (setf display-text (copystring display-text)) (string-store display-text 0 #/D) (setf delete-flag T) )) (defmethod (file-browser-item undelete) () (when delete-flag (setf display-text (copystring display-text)) (string-store display-text 0 #\space) (setf delete-flag NIL) )) (defmethod (file-browser-item deleted?) () delete-flag ) (defmethod (file-browser-item kill) () (nmode-delete-file full-name) ) (defmethod (file-browser-item view-buffer) (x) (or (find-file-in-existing-buffer full-name) (setf buffer (find-file-in-buffer full-name T)) )) (defmethod (file-browser-item cleanup) () (when (and buffer (not (=> buffer modified?))) (if (buffer-is-selectable? buffer) (buffer-kill-and-detach buffer)) (setf buffer NIL) )) (defmethod (file-browser-item apply-filter) (filter) (apply filter (list self)) ) (defmethod (file-browser-item action-wanted) () % Return 'DELETE, 'UNDELETE, or NIL. (if (not (eq deleted? delete-flag)) % user wants some action taken (let ((file-status (file-deleted-status full-name))) (if file-status % File currently exists (otherwise, forget it) (let ((actually-deleted? (eq file-status 'deleted))) (if (not (eq delete-flag actually-deleted?)) (if delete-flag 'DELETE 'UNDELETE) )))))) |
Added psl-1983/nmode/dispatch.b version [09e22fa1c1].
cannot compute difference between binary files
Added psl-1983/nmode/dispatch.sl version [aa5db0efa5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DISPATCH.SL - NMODE Dispatch table utilities % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int fast-vectors)) (fluid '(nmode-current-buffer nmode-minor-modes)) % A command is represented either as a single extended character (i.e., a % character including Meta and Control bits) or as a list whose first element % is an extended character (a command prefix character, e.g. C-X or M-X) and % whose second element is the "argument", either an extended character or a % string (for M-X). % The dispatch table maps commands (as defined above) to functions (of no % arguments). There is a single command table that defines the "keyboard % bindings" for the current mode. Associated with every buffer is a list of % forms to evaluate which will establish the keyboard bindings for that % buffer. % The dispatch table is represented by a 512-element vector % NMODE-DISPATCH-TABLE which maps extended characters to functions, augmented % by an association list for each prefix character (e.g., C-X and M-X) that % maps extended characters to functions. The prefix character assocation lists % are themselves stored in an association list that maps from prefix % characters. This master association list is bound to the variable % NMODE-PREFIX-DISPATCH-LIST. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following are INTERNAL static variables: (fluid '(nmode-dispatch-table nmode-prefix-dispatch-list)) (if (null nmode-dispatch-table) (setf nmode-dispatch-table (MkVect 511))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Dispatch table lookup functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de dispatch-table-lookup (command) % Return the dispatch table entry for the specified character or character % sequence. NIL is returned for undefined commands. (cond % Single character: ((FixP command) (getv nmode-dispatch-table command) ) % Character sequence: ((PairP command) (let* ((prefix-char (car command)) (argument (cadr command)) (prefix-entry (lookup-prefix-character prefix-char)) ) (and prefix-entry % Look up the entry for the prefixed character. (let ((char-entry (Atsoc argument prefix-entry))) (and char-entry (cdr char-entry)) )))) % If we get here, we were given a bad argument (t (StdError (BldMsg "Bad argument %p for Dispatch-Table-Lookup" command)) ))) (de lookup-prefix-character (ch) % Return the pair (PREFIX-CHAR . ASSOCIATION-LIST) for the specified prefix % character. This pair may be modified using RPLACD. (let ((assoc-entry (atsoc ch nmode-prefix-dispatch-list))) (when (null assoc-entry) % Create an entry for this prefix character. (setf assoc-entry (cons ch NIL)) (setf nmode-prefix-dispatch-list (cons assoc-entry nmode-prefix-dispatch-list)) ) assoc-entry )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Manipulating the dispatch table: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-make-self-inserting (chr) % Define the specified character to be "self inserting". (nmode-define-command chr 'insert-self-command)) (de nmode-undefine-command (chr) % Remove the command definition of the specified command. % If the command is entered, the bell will be rung. (nmode-define-command chr NIL)) (de nmode-define-commands (lis) (for (in x lis) (do (nmode-define-command (car x) (cdr x))))) (de nmode-define-normal-self-inserts () (nmode-make-self-inserting (char TAB)) (for (from i 32 126) (do (nmode-make-self-inserting i)))) (de nmode-define-command (command op) % Set up the keyboard dispatch table for a character or a character sequence. % If the character is uppercase, define the equivalent lower case character % also. (cond % Single character: ((FixP command) (vector-store nmode-dispatch-table command op) (cond ((X-UpperCaseP command) (vector-store nmode-dispatch-table (X-Char-DownCase command) op)))) % Character Sequence: ((PairP command) (let* ((prefix-char (car command)) (argument (cadr command)) (prefix-entry (lookup-prefix-character prefix-char)) ) (if (null prefix-entry) (StdError (BldMsg "Undefined prefix-character in command %p" command)) % else % Add the prefixed character to the association list. Note that in % case of duplicate entries the last one added is the one that counts. (rplacd prefix-entry (cons (cons argument op) (cdr prefix-entry))) % Define the lower case version of the character, if relevent. (cond ((and (FixP argument) (X-UpperCaseP argument)) (rplacd prefix-entry (cons (cons (X-Char-DownCase argument) op) (cdr prefix-entry))) ))))) % If we get here, we were given a bad argument (t (StdError (BldMsg "Impossible command %p" command)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Mode Establishing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-establish-current-mode () (when nmode-current-buffer (nmode-clear-dispatch-table) (nmode-establish-mode (=> nmode-current-buffer mode)) (for (in minor-mode nmode-minor-modes) (do (nmode-establish-mode minor-mode))) )) (de nmode-establish-mode (mode) % "Establish" the specified MODE: evaluate its "establish expressions" to set % up the dispatch table. Use reverse so things on front of list are % evaluated last. (So that later incremental changes are added later.) (for (in x (reverse (=> mode establish-expressions))) (do (if (pairp x) (eval x) (StdError (BldMsg "Invalid mode expression: %r" x)) )) )) (de nmode-clear-dispatch-table () % Set up a "clear" dispatch table. (for (from i 0 511) (do (nmode-undefine-command i))) (setf nmode-prefix-dispatch-list NIL)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Help for Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de help-dispatch () % Give a little information on the routine bound to a keyboard character (or % characters, in the case of prefixed things). (nmode-set-delayed-prompt "Show function of command: ") (let* ((command (input-command)) (func (dispatch-table-lookup command)) (prompt (BldMsg "%w %w" (command-name command) (or func "Undefined"))) ) (write-prompt prompt) )) (de print-all-dispatch () % Print out the current dispatch table. (print-matching-dispatch NIL)) (fluid '(function-name-match-string)) (de function-name-matcher (f) (string-indexs (id2string f) function-name-match-string)) (de string-indexs (s pattern) % Search in the string S for the specified pattern. If we find it, we return % the position of the first matching character. Otherwise, we return NIL. (let* ((pattern-length (string-length pattern)) (limit (- (string-length s) pattern-length)) ) (for (from pos 0 limit) (do (if (pattern-in-string pattern s pos) (exit pos))) ) )) (de pattern-in-string (pattern s pos) % Return T if PATTERN occurs as substring of S, starting at POS. % No bounds checking is performed on S. (let ((i 0) (patlimit (string-upper-bound pattern))) (while (and (<= i patlimit) (= (string-fetch pattern i) (string-fetch s (+ i pos))) ) (setf i (+ i 1)) ) (> i patlimit) % T if all chars matched, NIL otherwise )) (de print-matching-dispatch (s) % Print out the current dispatch table, showing only those function % whose names contain the string S (if S is NIL, show all functions). (let (f) (when s (setf function-name-match-string (string-upcase s)) (setf f #'function-name-matcher) ) % List the routines bound to single characters: (for (from ch 0 511) (do (print-dispatch-entry ch f))) % List the routines bound to prefix characters: (for (in prefix-entry nmode-prefix-dispatch-list) (do (for (in char-entry (cdr prefix-entry)) (do (print-dispatch-entry (list (car prefix-entry) (car char-entry)) f ) )))) )) (de print-dispatch-entry (command f) % Print out the dispatch routine for a character or character sequence. % Don't print anything if F is non-nill and (F fname) returns NIL, the % command is a self inserting character, "undefined", or a lower-case % character whose upper-case equivalent has the same definition. (let ((fname (dispatch-table-lookup command))) (if (not (or (null fname) (memq fname '(insert-self-command argument-or-insert-command Ding)) (and f (null (apply f (list fname)))) (is-redundant-command? command) )) (PrintF "%w %w%n" (string-pad-right (command-name command) 22) fname) ))) (de is-redundant-command? (command) (let ((ch (if (FixP command) command (cadr command)))) (and (FixP ch) (X-LowerCaseP ch) (eq (dispatch-table-lookup command) (dispatch-table-lookup (if (FixP command) (X-Char-UpCase command) (list (car command) (X-Char-Upcase (cadr command))) )))))) (de command-name (command) % Return a string giving the name for a character or character sequence. (if (PairP command) (string-concat (prefix-name (car command)) (let ((argument (cadr command))) (cond ((FixP argument) (x-char-name argument)) (t argument) ))) (x-char-name command) )) |
Added psl-1983/nmode/doc.b version [34d741ca8c].
cannot compute difference between binary files
Added psl-1983/nmode/doc.sl version [17d94ca41d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Doc.SL - NMODE On-line Documentation % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 15 February 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects extended-char fast-vectors fast-strings fast-int stringx)) % External variables: (fluid '( nmode-current-buffer nmode-current-window doc-obj-list )) (setf doc-obj-list nil) % Internal static variables: (fluid '(view-mode doc-browser-mode doc-browser-command-list doc-filter-argument-list doc-text-file reference-text-file doc-text-buffer)) (setf doc-text-file "SS:<PSL.NMODE-DOC>FRAMES.LPT") (setf reference-text-file "SS:<PSL.NMODE-DOC>COSTLY.SL") (de set-up-documentation () (setf doc-text-buffer (buffer-create-default "+DOCTEXT")) (insert-file-into-buffer doc-text-buffer doc-text-file) (let ((ref-chan (open reference-text-file 'input))) (eval (channelread ref-chan)) (close ref-chan))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Documentation Browser Commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (setf view-mode (nmode-define-mode "View" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-commands Basic-Command-List) (nmode-define-commands (list (cons (x-char Q) 'select-previous-buffer-command))) ))) (setf Doc-Browser-Mode (nmode-define-mode "Doc-Browser" '( (nmode-define-commands Doc-Browser-Command-List) (nmode-establish-mode Read-Only-Text-Mode) ))) (setf Doc-Browser-Command-List (list (cons (x-char ?) 'doc-browser-help) (cons (x-char F) 'doc-filter-command) (cons (x-char E) 'browser-edit-command) (cons (x-char I) 'browser-ignore-command) (cons (x-char N) 'browser-undo-filter-command) (cons (x-char V) 'browser-view-command) (cons (x-char Q) 'browser-exit-command) (cons (x-char SPACE) 'move-down-command) )) (de doc-obj-compare (obj1 obj2) (let ((indx1 (doc-browse-obj$index obj1)) (indx2 (doc-browse-obj$index obj2))) (< indx1 indx2))) (de doc-browser-help () (write-message "Quit Edit Filter uNdo-filter Ignore View")) (de doc-filter-command () (let ((browser (=> nmode-current-buffer get 'browser)) (doc-filter-argument-list (list (prompt-for-string "Search for what string in a command's name or references?" "")))) (=> browser filter-items #'doc-filter-predicate))) (de doc-filter-predicate (old-name ref-list) (let* ((pattern (string-upcase (first doc-filter-argument-list))) (pattern-length (string-length pattern)) (name-list (cons old-name (for (in ref ref-list) (with name-list) (collect (=> (eval ref) name) name-list) (returns name-list))))) (for (in name name-list) (with found) (do (when (let ((limit (- (string-length name) pattern-length)) (char-pos 0)) (while (<= char-pos limit) (if (pattern-matches-in-line pattern name char-pos) (exit char-pos)) (incr char-pos))) (setf found t))) (returns found)))) (de apropos-command () (let* ((doc-filter-argument-list (list (prompt-for-string "Search for what string in a command's name or references?" ""))) (blist (buffer-create "+DOCLIST" doc-browser-mode)) (bitem (buffer-create "+DOCITEM" view-mode)) (jnk (if (null doc-obj-list) (set-up-documentation))) (browser (create-browser blist bitem ["Documentation Browser Subsystem" ""] doc-obj-list #'doc-obj-compare))) (=> browser select-item (car doc-obj-list)) (=> browser filter-items #'doc-filter-predicate) (browser-enter blist) (doc-browser-help))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % The doc-browse-obj (documentation-browser-object) flavor: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor doc-browse-obj ( name type index (start-line NIL) (end-line NIL) (ref-list ()) ) () initable-instance-variables gettable-instance-variables ) (defmethod (doc-browse-obj display-text) () (string-concat (id2string type) ": " name)) (defmethod (doc-browse-obj view-buffer) (buffer) (unless buffer (setf buffer (buffer-create-default "+DOCITEM"))) (=> buffer reset) (if (not (and start-line end-line)) (=> buffer insert-string "Sorry, no documentation is availible on this topic.") (=> buffer insert-text (cdr (=> doc-text-buffer extract-region NIL (cons start-line 0) (cons end-line 0))))) (=> buffer move-to-buffer-start) (=> buffer set-modified? nil) buffer) (defmethod (doc-browse-obj cleanup) () NIL) (defmethod (doc-browse-obj apply-filter) (filter) (apply filter (list name ref-list))) |
Added psl-1983/nmode/extended-input.b version [1972103158].
cannot compute difference between binary files
Added psl-1983/nmode/extended-input.sl version [547e6f26e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Extended-Input.SL - 9-bit terminal input (for 7 or 8 bit terminals) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 August 1982 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Added PUSH-BACK-INPUT-CHARACTER function. Revise mapping so that % bit prefix characters are recognized after mapping. % 22-Dec-82 Jeffrey Soreff % Added PUSH-BACK-EXTENDED-CHARACTER function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-int fast-vectors)) % Global variables: (fluid '(nmode-meta-bit-prefix-character nmode-control-bit-prefix-character nmode-control-meta-bit-prefix-character)) (setf nmode-meta-bit-prefix-character (x-char C-!\)) (setf nmode-control-bit-prefix-character (x-char C-^)) (setf nmode-control-meta-bit-prefix-character (x-char C-Z)) % Internal static variables: (fluid '(nmode-terminal-map nmode-lookahead-extended-char nmode-lookahead-char)) (setf nmode-lookahead-extended-char nil) (setf nmode-lookahead-char nil) (de nmode-initialize-extended-input () (setf nmode-terminal-map (MkVect 255)) % Most input characters map to themselves. (for (from i 0 255) (do (vector-store nmode-terminal-map i i))) % Some ASCII control character map to Extended Control characters. % Exceptions: BACKSPACE, TAB, RETURN, LINEFEED, ESCAPE (for (from i 0 31) (unless (member i '#.(list (char BS) (char tab) (char CR) (char LF) (char ESC)))) (do (let ((mch (X-Set-Control (+ i 64)))) (vector-store nmode-terminal-map i mch) (vector-store nmode-terminal-map (+ i 128) (+ mch 128)) ))) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de input-extended-character () (if nmode-lookahead-extended-char (prog1 nmode-lookahead-extended-char (setf nmode-lookahead-extended-char nil)) (input-direct-extended-character))) (de push-back-extended-character (ch) (setf nmode-lookahead-extended-char ch)) (de input-direct-extended-character () % Read an extended character from the terminal. % Recognize and interpret bit-prefix characters. (let* ((ch (input-terminal-character))) (cond ((= ch nmode-meta-bit-prefix-character) (nmode-append-separated-prompt "M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-unmeta ch))) (x-set-meta ch) ) ((= ch nmode-control-bit-prefix-character) (nmode-append-separated-prompt "C-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-uncontrol ch))) (x-set-control ch) ) ((= ch nmode-control-meta-bit-prefix-character) (nmode-append-separated-prompt "C-M-") (setf ch (input-terminal-character)) (nmode-complete-prompt (x-char-name (x-base ch))) (x-set-meta (x-set-control ch)) ) (t ch) ))) (de push-back-input-character (ch) (setf nmode-lookahead-char ch) ) (de input-terminal-character () % Read an extended character from the terminal. Perform mapping from 8-bit % to 9-bit characters. Do not interpret bit prefix characters. (if nmode-lookahead-char (prog1 nmode-lookahead-char (setf nmode-lookahead-char nil)) (vector-fetch nmode-terminal-map (input-direct-terminal-character)) )) |
Added psl-1983/nmode/fileio.b version [2c9eb2d96c].
cannot compute difference between binary files
Added psl-1983/nmode/fileio.sl version [1f4b9911a1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FileIO.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % Revised: 4 February 1983 % % File I/O for NMODE. % % 4-Feb-83 Alan Snyder % Added functions for deleting/undeleting files and writing a message. % Find-file-in-buffer changed incompatibly to make it more useful. % Use nmode-error to report errors. % 1-Feb-83 Alan Snyder % Added separate default string for Insert File command. % 27-Dec-82 Alan Snyder % Removed runtime LOAD statements, for portability. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-strings pathnames)) % External Variables: (fluid '(nmode-selectable-buffers nmode-current-buffer nmode-screen nmode-command-argument-given nmode-current-window Text-Mode )) % Internal static variables: (fluid '(text-io-default-fn insert-file-default-fn)) (setf text-io-default-fn NIL) (setf insert-file-default-fn NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de visit-file-command () % Ask for and read in a file. (let ((fn (prompt-for-defaulted-filename "Visit File: " NIL))) (visit-file nmode-current-buffer fn) )) (de insert-file-command () % Ask for and read a file, inserting it into the current buffer. (setf insert-file-default-fn (prompt-for-file-name "Insert File: " insert-file-default-fn)) (insert-file-into-buffer nmode-current-buffer insert-file-default-fn) ) (de write-file-command () % Ask for filename, write out the buffer to the file. (write-buffer-to-file nmode-current-buffer (prompt-for-defaulted-filename "Write File:" NIL))) (de save-file-command () % Save current buffer on its associated file, ask for file if unknown. (cond ((not (=> nmode-current-buffer modified?)) (write-prompt "(No changes need to be written)")) (t (save-file nmode-current-buffer)))) (de save-file-version-command () % Save current buffer on its associated file, ask for file if unknown. % The file is written using the current version number. (cond ((not (=> nmode-current-buffer modified?)) (write-prompt "(No changes need to be written)")) (t (save-file-version nmode-current-buffer)))) (de find-file-command () % Ask for filename and then read it into a buffer created especially for that % file, or select already existing buffer containing the file. (find-file (prompt-for-defaulted-filename "Find file: " NIL)) ) (de write-screen-photo-command () % Ask for filename, write out the screen to the file. (write-screen-photo (prompt-for-file-name "Write Photo to File: " NIL))) (de write-region-command () % Ask for filename, write out the region to the file. (write-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Write Region to File:" text-io-default-fn)))) (de prepend-to-file-command () % Ask for filename, prepend the region to the file. (prepend-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Prepend Region to File:" text-io-default-fn)))) (de append-to-file-command () % Ask for filename, append the region to the file. (append-text-to-file (cdr (extract-region NIL (buffer-get-position) (current-mark))) (setf text-io-default-fn (prompt-for-file-name "Append Region to File:" text-io-default-fn)))) (de delete-file-command () (nmode-delete-file (prompt-for-defaulted-filename "Delete File:" NIL))) (de delete-and-expunge-file-command () (nmode-delete-and-expunge-file (prompt-for-defaulted-filename "Delete and Expunge File:" NIL))) (de undelete-file-command () (nmode-undelete-file (prompt-for-defaulted-filename "Undelete File:" NIL))) (de save-all-files-command () % Save all files. Ask first, unless arg given. (for (in b nmode-selectable-buffers) (do (cond ((and (=> b file-name) (=> b modified?) (or nmode-command-argument-given (nmode-y-or-n? (bldmsg "Save %w in %w (Y or N)?" (=> b name) (=> b file-name))) )) (save-file b)) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % File functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-defaulted-filename (prompt b) % The default name is the name associated with the specified buffer (without % Version number). Will throw 'ABORT if a bad file name is given. % If B is NIL, the "current" buffer is used. (let ((fn (=> (or b nmode-current-buffer) file-name))) (prompt-for-file-name prompt (and fn (namestring (pathname-without-version fn))) ))) (de prompt-for-file-name (prompt default-name) % Default-Name may be NIL. % Will throw 'ABORT if a bad file name is given. (let ((pn (pathname (prompt-for-string prompt default-name)))) (if default-name (setf pn (attempt-to-merge-pathname-defaults pn default-name (pathname-type default-name) NIL))) (namestring pn) )) (de attempt-to-merge-pathname-defaults (pn dn type version) (let ((result (errset (merge-pathname-defaults pn dn type version) NIL))) (cond ((listp result) (car result)) (t (write-prompt EMSG*) (throw 'ABORT))))) (de read-file-into-buffer (b file-name) (=> b set-file-name file-name) (buffer-set-mode b (pathname-default-mode file-name)) (let ((s (attempt-to-open-input file-name))) (if s (read-stream-into-buffer b s) % else (=> b reset) (=> b set-modified? NIL) (write-prompt "(New File)") ))) (de read-stream-into-buffer (b s) (let ((fn (=> s file-name))) (write-prompt (bldmsg "Reading file: %w" fn)) (=> b read-from-stream s) (=> s close) (write-prompt (bldmsg "File read: %w (%d lines)" fn (=> b visible-size))) )) (de insert-file-into-buffer (buf pn) (let ((b (buffer-create-unselectable "FOO" Text-Mode))) (read-file-into-buffer b pn) (insert-buffer-into-buffer b buf) )) (de insert-buffer-into-buffer (source destination) (let ((old-pos (=> destination position))) (=> destination insert-text (=> source contents)) (=> destination set-mark-from-point) (=> destination set-position old-pos) )) (de save-file (b) % Save the specified buffer on its associated file, ask for file if unknown. (let ((fn (=> b file-name))) (cond ((not (=> b modified?)) nil) (fn (write-buffer-to-file b (pathname-without-version fn))) (T (write-file b))))) (de save-file-version (b) % Save the specified buffer on its associated file, ask for file if unknown. % The file is written to the current version number. (let ((fn (=> b file-name))) (cond ((not (=> b modified?)) nil) (fn (write-buffer-to-file b fn)) (T (write-file b))))) (de write-file (b) % Ask for filename, write out the buffer to the file. (let ((msg (bldmsg "Write Buffer %w to File: " (=> b name)))) (write-buffer-to-file b (prompt-for-defaulted-filename msg b)))) (de write-buffer-to-file (b pn) % Write the specified buffer to a file. (write-prompt "") (let* ((file-name (namestring pn)) (s (attempt-to-open-output file-name)) ) (if s (let ((fn (=> s file-name))) (write-prompt (bldmsg "Writing file: %w" fn)) (=> b write-to-stream s) (=> s close) (write-prompt (bldmsg "File written: %w (%d lines)" fn (=> b visible-size))) (=> b set-modified? NIL) (=> b set-file-name fn) ) (nmode-error (bldmsg "Unable to write file: %w" file-name)) ))) (de write-text-to-file (text pn) (let ((b (buffer-create-unselectable "FOO" Text-Mode))) (=> b insert-text text) (write-buffer-to-file b pn) )) (de prepend-text-to-file (text pn) (let ((b (buffer-create-unselectable "FOO" Text-Mode))) (read-file-into-buffer b pn) (=> b move-to-buffer-start) (=> b insert-text text) (write-buffer-to-file b pn) )) (de append-text-to-file (text pn) (let ((b (buffer-create-unselectable "FOO" Text-Mode))) (read-file-into-buffer b pn) (=> b move-to-buffer-end) (=> b insert-text text) (write-buffer-to-file b pn) )) (de visit-file (b file-name) % If the specified file exists, read it into the specified buffer. % Otherwise, clear the buffer for a new file. % If the buffer contains precious data, offer to save it first. (if (=> b modified?) (let* ((fn (=> b file-name)) (msg (if fn (bldmsg "file %w" fn) (bldmsg "buffer %w" (=> b name)))) ) (if (nmode-yes-or-no? (bldmsg "Write out changes in %w?" msg)) (save-file b) ))) (let ((fn (actualize-file-name file-name))) (if fn (read-file-into-buffer b fn) (nmode-error (bldmsg "Unable to read or create file: %w" file-name)) ))) (de find-file (file-name) % Select a buffer containing the specified file. If the file exists in a % buffer already, then that buffer is selected. Otherwise, a new buffer is % created and the file read into it (if the file exists). (find-file-in-window nmode-current-window file-name)) (de find-file-in-window (w file-name) % Attach a buffer to the specified window that contains the specified file. % If the file exists in a buffer already, then that buffer is used. % Otherwise, a new buffer is created and the file read into it (if the file % exists). (let ((b (find-file-in-buffer file-name nil))) (if b (window-select-buffer w b) % otherwise (nmode-error (bldmsg "Unable to read or create file: %w" file-name)) ))) (de find-file-in-buffer (file-name existing-file-only?) % Return a buffer containing the specified file. The buffer is not % selected. If the file exists in a buffer already, then that buffer is % returned. Otherwise, if the file exists and can be read, a new buffer is % created and the file read into it. Otherwise, if EXISTING-FILE-ONLY? is % NIL and the file is potentially creatable, a new buffer is created and % returned. Otherwise, NIL is returned. (setf file-name (actualize-file-name file-name)) (if (and file-name (not (string-empty? file-name))) (or (find-file-in-existing-buffer file-name) % look for existing buffer (let ((s (attempt-to-open-input file-name))) (when (or s (not existing-file-only?)) % create a buffer (let ((b (buffer-create-default (buffer-make-unique-name (filename-to-buffername file-name))))) (=> b set-file-name file-name) (buffer-set-mode b (pathname-default-mode file-name)) (if s (read-stream-into-buffer b s) (write-prompt "(New File)") ) b )))))) (de find-file-in-existing-buffer (file-name) % Look for the specified file in an existing buffer. If found, return % that buffer, otherwise return NIL. The filename should be complete. (let ((pn (pathname file-name))) (for (in b nmode-selectable-buffers) (do (if (pathnames-match pn (=> b file-name)) (exit b))) (returns nil)) )) (de nmode-delete-file (fn) (let ((del-fn (file-delete fn))) (if del-fn (write-prompt (bldmsg "File deleted: %w" del-fn)) (nmode-error (bldmsg "Unable to delete file: %w" fn)) ) del-fn )) (de nmode-delete-and-expunge-file (fn) (let ((del-fn (file-delete-and-expunge fn))) (if del-fn (write-prompt (bldmsg "File deleted and expunged: %w" del-fn)) (nmode-error (bldmsg "Unable to delete file: %w" fn)) ) del-fn )) (de nmode-undelete-file (fn) (let ((del-fn (file-undelete fn))) (if del-fn (write-prompt (bldmsg "File undeleted: %w" del-fn)) (nmode-error (bldmsg "Unable to undelete file: %w" fn)) ) del-fn )) (de write-screen-photo (file-name) % Write the current screen to file. (let ((s (attempt-to-open-output file-name))) (cond (s (nmode-refresh) (=> nmode-screen write-to-stream s) (=> s close) (write-prompt (bldmsg "File written: %w" (=> s file-name))) ) (t (nmode-error (bldmsg "Unable to write file: %w" file-name)) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Auxiliary functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output file-name)) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) (de filename-to-buffername (pn) % Convert from a pathname to the "default" corresponding buffer name. (setf pn (pathname pn)) (string-upcase (file-namestring (pathname-without-version pn))) ) (de pathnames-match (pn1 pn2) (setf pn1 (pathname pn1)) (setf pn2 (pathname pn2)) (and (equal (pathname-device pn1) (pathname-device pn2)) (equal (pathname-directory pn1) (pathname-directory pn2)) (equal (pathname-name pn1) (pathname-name pn2)) (equal (pathname-type pn1) (pathname-type pn2)) (or (null (pathname-version pn1)) (null (pathname-version pn2)) (equal (pathname-version pn1) (pathname-version pn2))) )) (de pathname-without-version (pn) (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type (pathname-type pn) )) |
Added psl-1983/nmode/hp9836-dev.sl version [43072dbce9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % HP9836-DEV.SL - HP9836 NMODE Development Support (not normally loaded) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 January 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int extended-char)) (bothtimes (load strings common)) (fluid '(nmode-source-prefix window-source-prefix)) (setf nmode-source-prefix "n:") (setf window-source-prefix "w:") (setf prinlevel 3) (setf prinlength 10) (de nmode-compile (s) (setf s (nmode-fixup-name s)) (let ((object-name (string-concat nmode-source-prefix s)) (source-name (string-concat nmode-source-prefix (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de window-compile (s) (setf s (nmode-fixup-name s)) (let ((object-name (string-concat window-source-prefix s)) (source-name (string-concat window-source-prefix (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de pu-compile (s) (let ((object-name (string-concat "pl:" s)) (source-name (string-concat "pu:" (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de phpu-compile (s) (let ((object-name (string-concat "pl:" s)) (source-name (string-concat "phpu:" (string-concat s ".sl"))) ) (compile-lisp-file source-name object-name) )) (de nmode-compile-all () (for (in s nmode-file-list) (do (nmode-compile s)) )) (de window-compile-all () (for (in s window-file-list) (do (window-compile s)) )) |
Added psl-1983/nmode/incr.b version [54cbfcb716].
cannot compute difference between binary files
Added psl-1983/nmode/incr.sl version [a05271a7af].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Incremental-Search.SL - Incremental Search Routines for NMODE % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 21 December 1982 % Revised: 17 February 1982 % % 17-Feb-83 Alan Snyder % Fixed to allow pushback of bit-prefix characters. % 7-Feb-83 Alan Snyder % Revised to refresh all windows when writing message (write-message no % longer does this). % 18 January 1982 Jeffrey Soreff % This was revised to preserve the message existing before a search. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-strings fast-vectors fast-int extended-char)) (BothTimes (load objects)) % Global Variables (fluid '(text-last-searched-for)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Actual Command Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de incremental-search-command () (incr-search 1)) (de reverse-search-command () (incr-search -1)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Support Objects and Methods % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defflavor search-state ((state-list nil) (halt nil) % Halt means that the search should halt on this iteration. direct % This is the direction of the search: +1 for forward, -1 for back. (repeat-flag nil) % When repeating a search for the same text as before. (found-flag t) % This flag indicates that the current text was found. (place (buffer-get-position)) % This is set to the start of text found. (apparent-place (buffer-get-position)) % Apparent-place is put where the user should see the cursor: after the % text for forward searching, and before it for backward searching. (text [""])) % The text being searched for. () (gettable-instance-variables halt) (initable-instance-variables direct) ) (defmethod (search-state push) () % This method stores the information needed when one deletes a % character from the search string. It affects only state-list. (setf state-list (cons (vector direct repeat-flag found-flag place apparent-place) state-list))) (defmethod (search-state pop) () % This method restores the last state of the search. The text is % recomputed on the fly, while most of the other elements of the % state are explicitly retrieved from the list. "Halt" is not % retrieved, since the search should never pass a state where halt % is true. In addition to altering local variables, % text-last-searched-for is set equal to the truncated text, and % point is moved to its last location. (unless repeat-flag (setf text (trim-text text))) (when (cdr state-list) (setf state-list (cdr state-list)) (setf text-last-searched-for text)) % see next line. % Don't destroy information from previous search if one is in the % first state of a search and a deletion is attempted. (let ((state (car state-list))) (setf direct (vector-fetch state 0)) (setf repeat-flag (vector-fetch state 1)) (setf found-flag (vector-fetch state 2)) (setf place (vector-fetch state 3)) (setf apparent-place (vector-fetch state 4))) (buffer-set-position apparent-place)) (defmethod (search-state do-search) (next-command) % This method sets up searches. It analyses the current command to % determine if a search for old text is being repeated, or if a new % character is being added on to the existing text. It updates the % text being searched for, the record of the last text searched for, % the direction of the search, and it sets up point before searches. (let ((char-add-list nil)) (cond ((setf repeat-flag (=> next-command repeat-flag)) (setf direct (=> next-command direct)) (when (and (= direct (vector-fetch (car state-list) 0)) % The direction hasn't changed since the last search. (equal text [""])) (setf repeat-flag nil) % This is not a search for the text last searched for. (setf char-add-list (text2list text-last-searched-for)))) (t (setf char-add-list (list (=> next-command char))))) (if repeat-flag (=> self actual-search) % else (for (in current-char char-add-list) (do (setf text (new-text text current-char)) (buffer-set-position place) (=> self actual-search))))) (unless (equal text [""]) (setf text-last-searched-for text))) (defmethod (search-state actual-search) () % This method does the actual searching for text. It first checks to % see if the search could possibly succeed, which it couldn't if the % search just extends a previously unsuccessful search in the old % direction. This method also stores the location of the start of % the new text and the location at which the user should see the % cursor after the search. (when (or found-flag (~= direct (vector-fetch (car state-list) 0))) % One should search if the last text was found or the direction has changed. (let ((backed-up (when (and repeat-flag (< direct 0)) (move-backward-character)))) % Avoid jamming at the current string in repeated backward search. (setf found-flag (buffer-text-search? text direct)) (when (not found-flag) (ding)) (when (and backed-up (not found-flag)) (move-forward-character)))) (when found-flag (setf place (buffer-get-position)) (if (> direct 0) (move-over-text text)) (setf apparent-place (buffer-get-position))) % end of text if forward (buffer-set-position apparent-place) (=> self push)) (defmethod (search-state super-pop) () % This method pops off all unsuccessful searches or, if the last % search was successful, undoes all the searching. (cond (found-flag (setf state-list (lastpair state-list)) % first state (setf text [""]) (setf halt t) (=> self pop)) (t (while (not found-flag) (=> self pop)) (ding)))) (defmethod (search-state init) () (=> self prompt) (=> self push)) (defmethod (search-state prompt) () (update-message text found-flag direct)) (defflavor parsed-char (char halt pop-flag repeat-flag direct) % Char is the next character returned after processing. Halt is a % flag indicating if the searching should halt unconditionally. % Pop-flag indicates whether a delete is being done. Repeat-flag % indicates whether one of the commands (^R and ^S) which trigger % searching for the same text as before (but possibly in a new % direction) has occured. Direct indicates the direction that the % search should take. () gettable-instance-variables) (defmethod (parsed-char parse-next-character) () % This function inputs and parses new characters or commands. (setf char (input-terminal-character)) (setf halt nil) (setf pop-flag nil) (setf repeat-flag nil) (let ((up-char (X-Char-Upcase char))) (cond ((= up-char (x-char C-Q)) (setf char (input-direct-terminal-character))) ((or (= up-char (x-char Rubout))(= up-char (x-char Backspace))) (setf repeat-flag nil) (setf pop-flag t)) ((= up-char (x-char C-G)) (setf repeat-flag t) (setf pop-flag t)) ((or (= up-char (x-char C-S))(= up-char (x-char C-R))) (setf repeat-flag t) (if (= up-char (x-char C-S)) (setf direct +1) (setf direct -1))) ((= up-char (x-char Escape)) (setf halt t)) ((or (= up-char (x-char Return))(not (X-Control? up-char)))) % The last line detects normal characters. (t % normal control character (push-back-input-character char) (setf halt t))))) (de incr-search (direct) % The main function for the search (let* ((old-msg (write-message "")) (search-at (make-instance 'search-state 'direct direct)) (next-command (make-instance 'parsed-char))) (while (continue search-at next-command) % gets and parses next char % The main loop for the search (if (=> next-command pop-flag) (if (=> next-command repeat-flag) (=> search-at super-pop) (=> search-at pop)) (=> search-at do-search next-command)) (=> search-at prompt)) (write-message old-msg))) % This restores the message after the search. (de continue (search-state parsed-char) % This function parses the next input character, if that is called % for, and determines if the search should continue or be halted. It % returns a boolean value which is true if the search should % continue. (unless (=> search-state halt) (=> parsed-char parse-next-character) (not (=> parsed-char halt)))) (de update-message (text found direct) % This function displays the last line of the search string, whether % it was found, and in what direction the search proceeded. (let* ((line-count (vector-upper-bound text)) (last-line (vector-fetch text line-count))) (write-message (string-concat (if found "" "Failing ") (if (> direct 0) "" "Reverse ") "I-search: " last-line)) (nmode-refresh) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Start of text handling functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-text (text) % This function moves point to the end of a chunk of text, assuming % that point is started at the beginning of the text. (let ((line-count (vector-upper-bound text))) (set-line-pos (+ (current-line-pos) line-count)) (if (> line-count 0)(move-to-start-of-line)) (move-over-characters (string-length (vector-fetch text line-count))))) (de trim-text (old-text) % This is a pure function, without side effects. It trims one % character or empty line return off the old text. It will not, % however, delete the last null string from a text vector. In that % case it dings and returns the old text. (let* ((line-count (vector-upper-bound old-text)) (short-text (sub old-text 0 (- line-count 1))) (last-line (vector-fetch old-text line-count)) (last-count (string-length last-line))) (if (> last-count 0) (concat short-text (vector (sub last-line 0 (- last-count 2)))) (if (> line-count 0) short-text (Ding) old-text)))) (de new-text (old-text char) % This is a pure function, without side effects. It returns an % updated version of the text vector. It updates the text vector by % adding a new character or a new line. (let* ((line-count (vector-upper-bound old-text)) (short-text (sub old-text 0 (- line-count 1))) (last-line (vector-fetch old-text line-count))) (if (= char (x-char Return)) (concat old-text [""]) (concat short-text (vector (string-concat last-line (string char))))))) (de text2list (text) % This function converts text into a list of characters, with cursor % returns where the breaks between strings used to be. (append (string2list (vector-fetch text 0)) (for (from indx 1 (vector-upper-bound text) 1) (join (cons (x-char return) (string2list (vector-fetch text indx))))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Start of text searching functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de buffer-text-search? (text direct) % This function searches in the buffer for the specified text. The % direct is +1 for forward searching and -1 for backward % searching. This function leaves point at the start of the text, % if it is found, and at the old point if the text is not found. % This function returns a boolean, true if it found the text. (let ((current-place (buffer-get-position)) (match-rest nil)) (while (and (not match-rest) (buffer-search (vector-fetch text 0) direct)) (setf match-rest (match-rest-of-text? text)) (unless match-rest (if (> direct 0)(move-forward)(move-backward)))) (unless match-rest (buffer-set-position current-place)) match-rest)) (de match-rest-of-text? (text) % This function determines if two conditions are satified: First, % that all lines in text except the last fill out their respective % lines. Second, that all lines except the first match their % respective lines. This function assumes that point is initially % at the start of a string which matches the first string in text. % It also assumes that text is in upper case. This function returns % a boolean value. It does not move point. (let ((temp nil) % This avoids a compiler bug. (indx 0) (match-rest t) (line (current-line-pos)) (char-pos (current-char-pos))) (while (and match-rest (< indx (vector-upper-bound text))) (setf temp (+ char-pos (string-length (vector-fetch text indx)))) (setf match-rest (and match-rest % Check filling out of lines. (= temp (string-length (current-buffer-fetch (+ line indx)))))) (setf char-pos 0) % Only the first string is set back on its line. (incr indx) (setf match-rest (and match-rest % Check matching of lines. (pattern-matches-in-line (string-upcase (vector-fetch text indx)) (current-buffer-fetch (+ line indx)) 0)))) (and match-rest (= indx (vector-upper-bound text))))) |
Added psl-1983/nmode/indent-commands.b version [2660e23fc9].
cannot compute difference between binary files
Added psl-1983/nmode/indent-commands.sl version [0fef30baae].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Indent-commands.SL - NMODE indenting commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 18 February 1983 % % 18-Feb-83 Alan Snyder % Removed use of "obsolete" #\ names. % 11-Nov-82 Alan Snyder % DELETE-INDENTATION-COMMAND (M-^) now obeys command argument. % INDENT-CURRENT-LINE now avoids modifying buffer if indentation unchanged. % Added INDENT-REGION stuff. % General clean-up. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings extended-char common)) (load stringx) (fluid '(nmode-command-argument nmode-command-argument-given nmode-command-number-given )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Indenting Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de indent-new-line-command () (let ((func (dispatch-table-lookup (x-char CR)))) (if func (apply func NIL))) (setf nmode-command-argument 1) (setf nmode-command-argument-given NIL) (setf nmode-command-number-given NIL) (let ((func (dispatch-table-lookup (x-char TAB)))) (if func (apply func NIL)))) (de tab-to-tab-stop-command () (for (from i 1 nmode-command-argument) (do (insert-character #\TAB)) )) (de delete-horizontal-space-command () (while (and (not (at-line-end?)) (char-blank? (next-character))) (delete-next-character) ) (while (and (not (at-line-start?)) (char-blank? (previous-character))) (delete-previous-character) ) ) (de delete-blank-lines-command () (cond ((current-line-blank?) % We are on a blank line. % Replace multiple blank lines with one. % First, search backwards for the first blank line % and save its index. (while (not (current-line-is-first?)) (move-to-previous-line) (cond ((not (current-line-blank?)) (move-to-next-line) (exit)) )) (delete-following-blank-lines) ) (t % We are on a non-blank line. Delete any blank lines % that follow this one. (delete-following-blank-lines) ) )) (de back-to-indentation-command () (move-to-start-of-line) (while (char-blank? (next-character)) (move-forward) )) (de delete-indentation-command () (if nmode-command-argument-given (move-to-next-line)) (current-line-strip-indent) (move-to-start-of-line) (when (not (current-line-is-first?)) (delete-previous-character) (if (and (not (at-line-start?)) (not (= (previous-character) #/( )) (not (= (next-character) #/) )) ) (insert-character #\SPACE) ))) (de split-line-command () (while (char-blank? (next-character)) (move-forward)) (if (> nmode-command-argument 0) (let ((pos (current-display-column))) (for (from i 1 nmode-command-argument) (do (insert-eol))) (indent-current-line pos) ))) (de indent-region-command () (if nmode-command-argument-given (indent-region #'indent-to-argument) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Indenting Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de char-blank? (ch) (or (= ch #\SPACE) (= ch #\TAB))) (de current-line-indent () % Return the indentation of the current line, in terms of spaces. (let ((line (current-line))) (for* (from i 0 (string-upper-bound line)) (with ch) (while (char-blank? (setf ch (string-fetch line i)))) (sum (if (= ch #\TAB) 8 1)) ))) (de current-line-strip-indent () % Strip all leading blanks and tabs from the current line. (let ((line (current-line))) (for* (from i 0 (string-upper-bound line)) (while (char-blank? (string-fetch line i))) (finally (when (> i 0) (set-char-pos (- (current-char-pos) i)) (current-line-replace (string-rest line i)) )) ))) (de strip-previous-blanks () % Strip all blanks and tabs before point. (while (and (not (at-buffer-start?)) (char-blank? (previous-character))) (delete-previous-character) )) (de indent-current-line (n) % Adjust the current line to have the specified indentation. (when (and (~= n (current-line-indent)) (>= n 0)) (current-line-strip-indent) (let ((n-spaces (remainder n 8)) (n-tabs (quotient n 8)) (line (current-line)) (cp (current-char-pos)) ) (for (from i 1 n-spaces) (do (setf line (string-concat #.(string #\SPACE) line)) (setf cp (+ 1 cp)))) (for (from i 1 n-tabs) (do (setf line (string-concat #.(string #\TAB) line)) (setf cp (+ 1 cp)))) (current-line-replace line) (set-char-pos cp) ))) (de delete-following-blank-lines () % Delete any blank lines that immediately follow the current one. (if (not (current-line-is-last?)) (let ((old-pos (buffer-get-position)) first-pos ) % Advance past the current line until the next nonblank line. (move-to-next-line) (setf first-pos (buffer-get-position)) (while (and (not (at-buffer-end?)) (current-line-blank?)) (move-to-next-line)) (extract-region T first-pos (buffer-get-position)) (buffer-set-position old-pos) ))) (de indent-to-argument () % Indent the current line to the position specified by nmode-command-argument. (indent-current-line nmode-command-argument) ) (de indent-region (indenting-function) % Indent the lines whose first characters are between point and mark. % Attempt to adjust point and mark appropriately should their lines % be re-indented. The function INDENTING-FUNCTION is called to indent % the current line. (let* ((point (buffer-get-position)) (mark (current-mark)) (bp1 point) (bp2 mark) ) (if (< 0 (buffer-position-compare bp1 bp2)) (psetf bp1 mark bp2 point)) (let ((first-line (buffer-position-line bp1)) (last-line (buffer-position-line bp2)) ) (if (> (buffer-position-column bp1) 0) (setf first-line (+ first-line 1))) (for (from i first-line last-line) (do (set-line-pos i) (cond ((= i (buffer-position-line point)) (set-char-pos (buffer-position-column point))) ((= i (buffer-position-line mark)) (set-char-pos (buffer-position-column mark))) ) (apply indenting-function ()) (cond ((= i (buffer-position-line point)) (setf point (buffer-position-create i (current-char-pos)))) ((= i (buffer-position-line mark)) (setf mark (buffer-position-create i (current-char-pos)))) )))) (previous-mark) % pop off old mark (set-mark mark) % push (possibly adjusted) mark (buffer-set-position point) )) |
Added psl-1983/nmode/kill-commands.b version [e27aec93f3].
cannot compute difference between binary files
Added psl-1983/nmode/kill-commands.sl version [4b1878a1de].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Kill-Commands.SL - NMODE Kill and Delete commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 16 November 1982 % % 16-Nov-82 Alan Snyder % Modified C-Y and M-Y to obey comamnd argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-vectors fast-int)) (load gsort) (fluid '(nmode-current-buffer nmode-command-argument nmode-command-argument-given nmode-command-number-given nmode-previous-command-killed nmode-command-killed )) % Internal static variables: (fluid '(nmode-kill-ring)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-initialize-kill-ring () (setf nmode-kill-ring (ring-buffer-create 16)) (setf nmode-command-killed NIL) ) (de insert-kill-buffer () % Insert the specified "kill buffer" into the buffer at the current location. (cond ((<= nmode-command-argument 0) (Ding)) (nmode-command-number-given (insert-from-kill-ring (+ (- nmode-command-argument) 1) NIL)) (nmode-command-argument-given (insert-from-kill-ring 0 T)) (t (insert-from-kill-ring 0 NIL)) )) (de insert-from-kill-ring (index flip-positions) (insert-text-safely (=> nmode-kill-ring fetch index) flip-positions) ) (de insert-text-safely (text flip-positions) (cond (text (=> nmode-current-buffer set-mark-from-point) (insert-text text) (when flip-positions (exchange-point-and-mark)) ) (t (Ding)) )) (de safe-to-unkill () % Return T if the current region contains the same text as the current % kill buffer. (let ((killed-text (ring-buffer-top nmode-kill-ring)) (region (extract-text NIL (buffer-get-position) (current-mark))) ) (and killed-text (text-equal killed-text region)) )) (de unkill-previous () % Delete (without saving away) the current region, and then unkill (yank) the % specified entry in the kill ring. "Ding" if the current region does not % contain the same text as the current entry in the kill ring. (cond ((not (safe-to-unkill)) (Ding)) ((= nmode-command-argument 0) (extract-region T (buffer-get-position) (current-mark))) (t (extract-region T (buffer-get-position) (current-mark)) (=> nmode-kill-ring rotate (- nmode-command-argument)) (insert-from-kill-ring 0 NIL) ) )) (de update-kill-buffer (kill-info) % Update the "kill buffer", either appending/prepending to the current % buffer, or "pushing" the kill ring, as appropriate. kill-info is a pair, % the car of which is +1 if the text was "forward killed", and -1 if % "backwards killed". The cdr is the actual text (a vector of strings). (let ((killed-text (cdr kill-info)) (dir (car kill-info)) ) (if (not nmode-previous-command-killed) % If previous command wasn't a kill, then "push" the new text. (ring-buffer-push nmode-kill-ring killed-text) % Otherwise, append or prepend the text, as appropriate. (let ((text (ring-buffer-top nmode-kill-ring))) % Swap the two pieces of text if deletion was "backwards". (if (< dir 0) (psetf text killed-text killed-text text)) % Replace text with the concatenation of the two. (ring-buffer-pop nmode-kill-ring) (ring-buffer-push nmode-kill-ring (text-append text killed-text)) )))) (de text-append (t1 t2) % Append two text-vectors. % The last line of T1 is concatenated with the first line of T2. (let ((text (MkVect (+ (vector-upper-bound t1) (vector-upper-bound t2)))) (ti 0) % index into TEXT ) (for (from i 0 (- (vector-upper-bound t1) 1)) (do (vector-store text ti (vector-fetch t1 i)) (setf ti (+ ti 1)) )) (vector-store text ti (string-concat (vector-fetch t1 (vector-upper-bound t1)) (vector-fetch t2 0))) (setf ti (+ ti 1)) (for (from i 1 (vector-upper-bound t2)) (do (vector-store text ti (vector-fetch t2 i)) (setf ti (+ ti 1)) )) text)) (de text-equal (t1 t2) % Compare two text vectors for equality. (let ((limit (vector-upper-bound t1))) (and (= limit (vector-upper-bound t2)) (for (from i 0 limit) (always (string= (vector-fetch t1 i) (vector-fetch t2 i))) )))) (de kill-region () % Kill (and save in kill buffer) the region between point and mark. (update-kill-buffer (extract-region T (buffer-get-position) (current-mark))) (setf nmode-command-killed T) ) (de copy-region () (update-kill-buffer (extract-region NIL (buffer-get-position) (current-mark))) ) (de append-to-buffer-command () (let* ((text (cdr (extract-region NIL (buffer-get-position) (current-mark)))) (b (prompt-for-buffer "Append Region to Buffer: " NIL)) ) (=> b insert-text text) )) (de prompt-for-register-name (prompt) % Prompt for the name of a "Register", which must be a letter % or a digit. Return the corresponding Lisp Symbol. Return NIL % if an invalid name is given. (nmode-set-delayed-prompt prompt) (let ((ch (input-base-character))) (cond ((AlphaNumericP ch) (intern (string-concat "nmode-register-" (string ch)))) (t (Ding) NIL)))) (de put-register-command () (let ((register (prompt-for-register-name (if nmode-command-argument-given "Withdraw Region to Register: " "Copy Region to Register: ")))) (cond (register (set register (cdr (extract-region nmode-command-argument-given (buffer-get-position) (current-mark)))) )))) (de get-register-command () (let ((register (prompt-for-register-name "Insert from Register: ")) (old-pos (buffer-get-position)) ) (cond (register (cond ((BoundP register) (insert-text (ValueCell register)) (set-mark-from-point) (buffer-set-position old-pos) (if nmode-command-argument-given (exchange-point-and-mark)) ) (t (Ding)) ))))) (de append-next-kill-command () (if (ring-buffer-top nmode-kill-ring) % If there is a kill buffer... (setf nmode-command-killed T) )) (de kill-line () (let ((old-pos (buffer-get-position))) (if nmode-command-argument-given (cond ((> nmode-command-argument 0) % Kill through that many line terminators (for (from i 1 nmode-command-argument) (do (move-to-next-line))) ) ((= nmode-command-argument 0) % Kill preceding text on this line (move-to-start-of-line) ) (t % Kill through that many previous line starts % This line counts only if we are not at the beginning of it. (if (not (at-line-start?)) (progn (move-to-start-of-line) (setf nmode-command-argument (+ nmode-command-argument 1)) )) (for (from i 1 (- nmode-command-argument)) (do (move-to-previous-line))) )) % else (no argument given) (while (char-blank? (next-character)) (move-forward)) (if (at-line-end?) (move-to-next-line) (move-to-end-of-line) ) ) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) (setf nmode-command-killed T) )) (de kill-forward-word-command () (delete-words nmode-command-argument) (setf nmode-command-killed T) ) (de kill-backward-word-command () (delete-words (- nmode-command-argument)) (setf nmode-command-killed T) ) (de kill-forward-form-command () (delete-forms nmode-command-argument) (setf nmode-command-killed T) ) (de kill-backward-form-command () (delete-forms (- nmode-command-argument)) (setf nmode-command-killed T) ) (de delete-backward-character-command () (cond (nmode-command-argument-given (delete-characters (- nmode-command-argument)) (setf nmode-command-killed T)) (t (if (at-buffer-start?) (Ding) (delete-previous-character) )))) (de delete-forward-character-command () (cond (nmode-command-argument-given (delete-characters nmode-command-argument) (setf nmode-command-killed T)) (t (if (at-buffer-end?) (Ding) (delete-next-character) )))) (de delete-backward-hacking-tabs-command () (cond (nmode-command-argument-given (delete-characters-hacking-tabs (- nmode-command-argument)) (setf nmode-command-killed T)) (t (if (at-buffer-start?) (Ding) (move-backward-character-hacking-tabs) (delete-next-character) )))) (de transpose-words () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-words nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-words (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 word1 word2) (cond ((= n 0) (setf bp1 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp2 (buffer-get-position)) (buffer-set-position (current-mark)) (setf bp3 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp4 (buffer-get-position)) (exchange-regions bp3 bp4 bp1 bp2) (move-backward-word) ) (t (if (not (move-backward-word)) (return NIL)) (setf bp1 (buffer-get-position)) (if (not (move-forward-word)) (return NIL)) (setf bp2 (buffer-get-position)) (if (not (move-over-words (if (< n 0) (- n 1) n))) (return NIL)) (setf bp4 (buffer-get-position)) (if (not (move-over-words (- 0 n))) (return NIL)) (setf bp3 (buffer-get-position)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-lines () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-lines nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-lines (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 line1 line2 current marked last) (setf current (current-line-pos)) (setf last (- (current-buffer-size) 1)) % The last line doesn't count, because it is unterminated. (setf marked (buffer-position-line (current-mark))) (cond ((= n 0) (if (or (>= current last) (>= marked last)) (return NIL)) (setf bp1 (buffer-position-create current 0)) (setf bp2 (buffer-position-create (+ current 1) 0)) (setf bp3 (buffer-position-create marked 0)) (setf bp4 (buffer-position-create (+ marked 1) 0)) (exchange-regions bp3 bp4 bp1 bp2) (move-to-previous-line) ) (t % Dragged line is the previous one. (if (= current 0) (return NIL)) (setf bp1 (buffer-position-create (- current 1) 0)) (setf bp2 (buffer-position-create current 0)) (setf marked (- (+ current n) 1)) (if (or (< marked 0) (>= marked last)) (return NIL)) (setf bp3 (buffer-position-create marked 0)) (setf bp4 (buffer-position-create (+ marked 1) 0)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-forms () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-forms nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-forms (n) % Returns non-NIL if successful. (prog (bp1 bp2 bp3 bp4 form1 form2) (cond ((= n 0) (setf bp1 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp2 (buffer-get-position)) (buffer-set-position (current-mark)) (setf bp3 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp4 (buffer-get-position)) (exchange-regions bp3 bp4 bp1 bp2) (move-backward-form) ) (t (if (not (move-backward-form)) (return NIL)) (setf bp1 (buffer-get-position)) (if (not (move-forward-form)) (return NIL)) (setf bp2 (buffer-get-position)) (if (not (move-over-forms (if (< n 0) (- n 1) n))) (return NIL)) (setf bp4 (buffer-get-position)) (if (not (move-over-forms (- 0 n))) (return NIL)) (setf bp3 (buffer-get-position)) (exchange-regions bp1 bp2 bp3 bp4) )) (return T) )) (de transpose-regions () (let ((old-pos (buffer-get-position))) (cond ((not (attempt-to-transpose-regions nmode-command-argument)) (Ding) (buffer-set-position old-pos) )))) (de attempt-to-transpose-regions (n) % Returns non-NIL if successful. % Transpose regions defined by cursor and three most recent marks. % EMACS resets all of the marks; we just reset the cursor to the % end of the higher region. (prog (bp1 bp2 bp3 bp4 bp-list) (setf bp1 (buffer-get-position)) (setf bp2 (current-mark)) (setf bp3 (previous-mark)) (setf bp4 (previous-mark)) (previous-mark) (setf bp-list (list bp1 bp2 bp3 bp4)) (gsort bp-list (function buffer-position-lessp)) (exchange-regions (first bp-list) (second bp-list) (third bp-list) (fourth bp-list)) (buffer-set-position (fourth bp-list)) (return T) )) % Support functions: (de delete-characters (n) (let ((old-pos (buffer-get-position))) (move-over-characters n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-characters-hacking-tabs (n) % Note: EMACS doesn't try to hack tabs when deleting forward. % We do, but it's a crock. What should really happen is that all % consecutive tabs are converted to spaces. (cond ((< n 0) % Deleting backwards is tricky because the conversion of tabs to % spaces may change the numeric value of the original "position". % Our solution is to first move backwards the proper number of % characters (converting tabs to spaces), and then move back over them. (let ((count (- n))) (setf n 0) (while (and (> count 0) (move-backward-character-hacking-tabs)) (setf count (- count 1)) (setf n (- n 1)) ) (move-over-characters (- n)) ))) (let ((old-pos (buffer-get-position))) (move-over-characters-hacking-tabs n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-words (n) (let ((old-pos (buffer-get-position))) (move-over-words n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de delete-forms (n) (let ((old-pos (buffer-get-position))) (move-over-forms n) (update-kill-buffer (extract-region T old-pos (buffer-get-position))) )) (de exchange-regions (bp1 bp2 bp3 bp4) % The specified positions define two regions: R1=<BP1,BP2> and % R2=<BP3,BP4>. These regions should not overlap, unless they % are identical. The contents of the two regions will be exchanged. % The cursor will be moved to the right of the region R1 (in its new % position). (let ((dir (buffer-position-compare bp1 bp3)) (r1 (cdr (extract-region NIL bp1 bp2))) (r2 (cdr (extract-region NIL bp3 bp4))) ) (cond ((< dir 0) % R1 is before R2 (extract-region T bp3 bp4) (insert-text r1) (extract-region T bp1 bp2) (insert-text r2) (buffer-set-position bp4) ) ((> dir 0) % R2 is before R1 (extract-region T bp1 bp2) (insert-text r2) (extract-region T bp3 bp4) (insert-text r1) )) )) |
Added psl-1983/nmode/lisp-commands.b version [d0c7f4669e].
cannot compute difference between binary files
Added psl-1983/nmode/lisp-commands.sl version [7730680804].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Commands.SL - Miscellaneous NMODE Lisp-related commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % Revised: 18 February 1983 % % 18-Feb-83 Alan Snyder % Rename down-list to down-list-command; extend to obey the command argument. % Rename insert-parens to make-parens-command; extend to obey the command % argument and to insert a space if needed (like EMACS). Rename % move-over-paren to move-over-paren-command; revise to follow EMACS more % closely. Remove use of "obsolete" #\ names. % 12-Nov-82 Alan Snyder % This file is the result of a complete rewrite of the Lisp stuff. The only % things that remain in this file are those things that don't fit in elsewhere. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-command-argument nmode-command-argument-given nmode-current-command )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de insert-closing-bracket () % Insert a closing bracket, then display the matching opening bracket. (if (not (fixp nmode-current-command)) (Ding) % otherwise (for (from i 1 nmode-command-argument) (do (insert-character nmode-current-command))) (display-matching-opener) )) (de down-list-command () % Move inside the next or previous contained list. If the command argument % is positive, move forward past the next open bracket without an % intervening close bracket. If the command argument is negative, move % backward to the next previous close bracket without an intervening open % bracket. If the specified bracket cannot be found, Ding, but do not move. % Note: this command differs from the EMACS Down-List command in that it % always stays within the current list. The EMACS command moves forward % as far as needed to find a list at the next lower level. (if (> nmode-command-argument 0) (for (from i 1 nmode-command-argument) (do (when (not (move-forward-down-list)) (Ding) (exit)))) (for (from i 1 (- nmode-command-argument)) (do (when (not (move-backward-down-list)) (Ding) (exit)))) )) (de make-parens-command () % Insert a space if it looks like we need one. Insert an open paren. Skip % forward over the requested number of forms, if any. Insert a close paren. % Move back to the open paren. (when (not (at-line-start?)) (let ((ch (previous-character))) (when (and (not (char-blank? ch)) (not (= ch #/( ))) (insert-character #\Space) ))) (insert-character #/( ) (let ((old-pos (buffer-get-position))) (when nmode-command-argument-given (if (or (<= nmode-command-argument 0) (not (move-over-forms nmode-command-argument))) (Ding))) (insert-character #/) ) (buffer-set-position old-pos) )) (de move-over-paren-command () % Move forward past N closing brackets at any level. Delete any indentation % before the first closing bracket found. Insert an end of line after the % last closing bracket found and indent the new line. Aside: This % definition follows EMACS. I don't understand the motivation for this way % of interpreting the command argument. (if (<= nmode-command-argument 0) (Ding) (for (from i 1 nmode-command-argument) (do (when (not (forward-scan-for-right-paren 10000)) (when (> i 1) (insert-eol) (lisp-indent-current-line) ) (Ding) (exit) ) (when (= i 1) (move-backward-item) (strip-previous-blanks) (move-forward-item) ) (when (= i nmode-command-argument) (insert-eol) (lisp-indent-current-line) ) )))) (de insert-comment-command () (move-to-end-of-line) (insert-string "% ") ) |
Added psl-1983/nmode/lisp-indenting.b version [5622fc239e].
cannot compute difference between binary files
Added psl-1983/nmode/lisp-indenting.sl version [35eba00629].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Indenting.SL - NMODE Lisp Indenting commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 25 August 1982 % Revised: 12 November 1982 % % 25-Feb-83 Alan Snyder % Move-down-list renamed to Move-forward-down-list. % 12-Nov-82 Alan Snyder % Improved indenting using new structure-movement primitives. % Changed multi-line indenting commands to clear any blank lines. % Added LISP-INDENT-REGION-COMMAND. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-vectors)) (fluid '(nmode-command-argument nmode-command-argument-given)) (de lisp-tab-command () (cond (nmode-command-argument-given (let ((n nmode-command-argument)) (cond ((< n 0) (let ((last-line (- (current-line-pos) 1))) (set-line-pos (+ (current-line-pos) n)) (let ((first-line (current-line-pos))) (while (<= (current-line-pos) last-line) (lisp-indent-or-clear-current-line) (move-to-next-line) ) (current-buffer-goto first-line 0) ))) ((> n 0) (while (> n 0) (lisp-indent-or-clear-current-line) (move-to-next-line) (if (at-buffer-end?) (exit)) (setf n (- n 1)) )) (t (lisp-indent-current-line) (move-to-start-of-line) )))) (t (lisp-indent-current-line)))) (de lisp-indent-current-line () (indent-current-line (lisp-current-line-indent))) (de lisp-indent-or-clear-current-line () (indent-current-line (if (current-line-blank?) 0 (lisp-current-line-indent)))) (de lisp-indent-sexpr () (if (not (move-forward-down-list)) % Find next open bracket (Ding) % None found % otherwise (move-backward-item) % Move back to the open bracket (let ((old-line (current-line-pos)) (old-point (current-char-pos)) ) (if (not (move-forward-form)) % Find end of form (Ding) % No matching close bracket found % otherwise (for (from i (+ old-line 1) (current-line-pos)) (do (set-line-pos i) (lisp-indent-or-clear-current-line) )) (current-buffer-goto old-line old-point) )))) (de lisp-indent-region-command () (if nmode-command-argument-given (indent-region #'indent-to-argument) (indent-region #'lisp-indent-or-clear-current-line) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Basic Indenting Primitive % % This function determines what indentation the current line should receive. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-current-line-indent () % Return the desired indentation for the current line. % Point is unchanged. (let ((old-pos (buffer-get-position))) (unwind-protect (unsafe-lisp-current-line-indent) (buffer-set-position old-pos) ))) (de unsafe-lisp-current-line-indent () % Return the desired indentation for the current line. % Point may change. (move-to-start-of-line) (let ((item (move-backward-form)) (number-of-forms 0) (leftmost-form-type NIL) ) % If there are multiple forms at the same level of nesting % on the same line, we want to find the left-most one. (while (or (eq item 'ATOM) (eq item 'STRUCTURE)) (setf number-of-forms (+ number-of-forms 1)) (setf leftmost-form-type item) (let ((next-item (move-backward-form-within-line))) (if (not next-item) (exit)) % We have the first item on the line. (setf item next-item) )) (selectq item ((ATOM STRUCTURE) (current-display-column)) % Line up with form. (OPENER (lisp-indent-under-paren leftmost-form-type number-of-forms)) (t 0) % There is no previous form. ))) (de lisp-indent-under-paren (leftmost-form-type number-of-forms) % This function is called to determine the indentation for a line % that immediately follows (i.e., there is no intervening line % containing a form) the line containing the open paren that % begins the nesting level for the line being indented. This % function is called with the current position being at the open % paren. NUMBER-OF-FORMS specifies the number of forms that % follow the open paren on its line. LEFTMOST-FORM-TYPE specifies % the type of the first such form (either ATOM, STRUCTURE, or NIL). (skip-prefixes) % Skip over any "prefix characters" (like ' in Lisp). (let ((paren-column (current-display-column)) the-atom pos1 pos2 atom-text atom-string second-column ) (if (not (eq leftmost-form-type 'ATOM)) (+ paren-column 1) % Otherwise (move-forward-item) % Move past the paren. (setf pos1 (buffer-get-position)) (move-forward-form) % Move past the first form. (setf pos2 (buffer-get-position)) (setf atom-text (extract-text NIL pos1 pos2)) (setf atom-string (string-upcase (vector-fetch atom-text 0))) (if (internp atom-string) (setf the-atom (intern atom-string))) (when (> number-of-forms 1) (move-forward-form) (move-backward-form) (setf second-column (current-display-column)) ) (lisp-indent-under-atom the-atom paren-column second-column number-of-forms) ))) (de lisp-indent-under-atom (the-id paren-column second-column number-of-forms) % This function is called to determine the indentation for a line % that immediately follows (i.e., there is no intervening line % containing a form) the line containing the open paren that % begins the nesting level for the line being indented. % The open paren is followed on the same line by at least one form % that is not a structure. % NUMBER-OF-FORMS specifies the number of forms that % follow the open paren on its line. If there are two or more forms, % then SECOND-COLUMN is the display column of the second form; % otherwise, SECOND-COLUMN is NIL. If the first % form is recognized as being an % interned ID, then THE-ID is that ID; otherwise, THE-ID is NIL. % PAREN-COLUMN is the display column of the open paren. (or (if the-id (id-specific-indent the-id paren-column second-column)) second-column (+ paren-column 1) )) (put 'prog 'indentation 2) (put 'lambda 'indentation 2) (put 'lambdaq 'indentation 2) (put 'while 'indentation 2) (put 'de 'indentation 2) (put 'defun 'indentation 2) (put 'defmacro 'indentation 2) (put 'df 'indentation 2) (put 'dm 'indentation 2) (put 'dn 'indentation 2) (put 'ds 'indentation 2) (put 'let 'indentation 2) (put 'let* 'indentation 2) (put 'if 'indentation 2) (put 'when 'indentation 2) (put 'unless 'indentation 2) (put 'defmethod 'indentation 2) (put 'defflavor 'indentation 2) (put 'selectq 'indentation 2) (put 'catch 'indentation 2) (put 'catch-all 'indentation 2) (put 'setf 'indentation 2) (put 'setq 'indentation 2) (de id-specific-indent (id paren-column second-column) % The default indentation for a pattern like this: % .... (foo bar ... % bletch ... % is to line up bletch with bar. This pattern applies when FOO % is an atom (not a structure) and there is at least one % form (e.g. BAR) following it on the same line. This function % is used to specify exceptions to this rule. It is invoked % only when FOO is an INTERNed ID, since the exceptions are % defined by putting a property on the ID. (let ((indent (get id 'indentation))) (if indent (+ paren-column indent)) )) |
Added psl-1983/nmode/lisp-interface.b version [ca121ffac5].
cannot compute difference between binary files
Added psl-1983/nmode/lisp-interface.sl version [5b35f816f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LISP-Interface.SL - NMODE Lisp Text Execution Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 14 February 1983 % % Adapted from Will Galway's EMODE % % 14-Feb-83 Alan Snyder % Added statement to flush output buffer cache. % 2-Feb-83 Alan Snyder % Added Execute-Defun-Command. Change to supply the free EOL at the end of % the input buffer whenever the buffer-modified flag is set, instead of only % when currently at the end of the buffer. % 25-Jan-83 Alan Snyder % Check terminal type after resuming. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(nmode-current-buffer nmode-output-buffer nmode-terminal nmode-initialized *NMODE-RUNNING *GC LispBanner* *RAWIO *nmode-init-running *nmode-init-has-run nmode-terminal-input-buffer nmode-default-init-file-name nmode-auto-start nmode-first-start )) (setf *NMODE-RUNNING NIL) (setf *nmode-init-running NIL) (setf *nmode-init-has-run NIL) (setf nmode-default-init-file-name "PSL:NMODE.INIT") (setf nmode-auto-start NIL) (setf nmode-first-start T) (fluid '( nmode-buffer-channel % Channel used for NMODE I/O. nmode-output-start-position % Where most recent "output" started in buffer. nmode-output-end-position % Where most recent "output" ended in buffer. OldStdIn OldStdOut OldErrOut )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de yank-last-output-command () % Insert "last output" typed in the OUTPUT buffer. Output is demarked by % NMODE-OUTPUT-START-POSITION and NMODE-OUTPUT-END-POSITION. (if (not nmode-output-start-position) (Ding) % Otherwise (let ((text (=> nmode-output-buffer extract-region NIL nmode-output-start-position (or nmode-output-end-position (buffer-position-create (=> nmode-output-buffer size) 0) ) ))) (=> nmode-current-buffer insert-text (cdr text)) ))) (de execute-form-command () % Execute starting at the beginning of the current line. (set-mark-from-point) % in case the user wants to come back (move-to-start-of-line) (execute-from-buffer) ) (de execute-defun-command () % Execute starting at the beginning of the current defun (if the current % position is within a defun) or from the current position (otherwise). (set-mark-from-point) % in case the user wants to come back (move-to-start-of-current-defun) (execute-from-buffer) ) (de make-buffer-terminated () % If the current buffer ends with an "unterminated" line, add an EOL to % terminate it. (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (when (not (current-line-empty?)) (insert-eol)) (buffer-set-position old-pos) )) (de execute-from-buffer () % Causes NMODE to return to the procedure that called it (via % nmode-channel-editor) with input redirected to come from the (now) current % buffer. We arrange for output to go to the end of the output buffer. (if (=> nmode-current-buffer modified?) (make-buffer-terminated)) (buffer-channel-set-input-buffer nmode-buffer-channel nmode-current-buffer) % Output will go to end of the output buffer. Supply a free EOL if the last % line is unterminated. Record the current end-of-buffer for later use by % Lisp-Y. (let ((old-pos (=> nmode-output-buffer position))) (=> nmode-output-buffer move-to-buffer-end) (if (not (=> nmode-output-buffer current-line-empty?)) (=> nmode-output-buffer insert-eol)) (setf nmode-output-start-position (=> nmode-output-buffer position)) (=> nmode-output-buffer set-position old-pos) ) % Set things up to read from and write to NMODE buffers. (nmode-select-buffer-channel) (exit-nmode-reader) ) (de nmode-exit-to-superior () (if (not *NMODE-RUNNING) (original-quit) % else (leave-raw-mode) % Turn echoing back on. Next refresh is FULL. (original-quit) (enter-raw-mode) % Turn echoing off. (nmode-set-terminal) % Ensure proper terminal driver is loaded. )) % Redefine QUIT so that it restores the terminal to echoing before exiting. (when (FUnboundP 'original!-quit) (CopyD 'original!-quit 'quit) (CopyD 'quit 'nmode-exit-to-superior) ) (de emode () (nmode)) % for user convenience (de nmode () % Rebind the PSL input channel to the NMODE buffer channel and return. This % will cause the next READ to invoke Nmode-Channel-Editor and start running % NMODE. Use the function "exit-nmode" to switch back to original channels. (nmode-initialize) % does nothing if already initialized (when (neq STDIN* nmode-buffer-channel) (setf OldStdIn STDIN*) (setf OldStdOut STDOUT*) (setf OldErrOut ErrOut*) ) (nmode-select-buffer-input-channel) ) (de nmode-run-init-file () (setf *nmode-init-has-run T) (let ((fn (namestring (init-file-pathname "NMODE")))) (cond ((FileP fn) (nmode-execute-init-file fn)) ((FileP (setf fn nmode-default-init-file-name)) (nmode-execute-init-file fn)) ))) (de nmode-execute-init-file (fn) (let ((*nmode-init-running T)) (nmode-read-and-evaluate-file fn) )) (de nmode-read-and-evaluate-file (fn) (let ((chn (open fn 'INPUT)) exp ) (while (not (eq (setf exp (ChannelRead chn)) $Eof$)) (eval exp) ) (close chn) ) ) (de exit-nmode () % Leave NMODE, return to normal listen loop. (nmode-select-old-channels) (=> nmode-terminal move-cursor (=> nmode-terminal maxrow) 0) (leave-raw-mode) (setf *NMODE-RUNNING NIL) (setf *GC T) (exit-nmode-reader) % Set flag to cause NMODE to exit. ) % The following function is not currently used. (de nmode-invoke-lisp-listener () % Invoke a normal listen loop. (let* ((*NMODE-RUNNING NIL) (OldIN* IN*) (OldOUT* OUT*) (ERROUT* 1) (StdIn* 0) (StdOut* 1) (old-raw-mode (=> nmode-terminal raw-mode)) ) (leave-raw-mode) (RDS 0) (WRS 1) (unwind-protect (TopLoop 'Read 'Print 'Eval "Lisp" "Return to NMODE with ^Z") (RDS OldIN*) (WRS OldOUT*) (if old-raw-mode (enter-raw-mode)) ))) % (de emode () (throw '$read$ $eof$)) % use with above function % (de nmode () (throw '$read$ $eof$)) % use with above function (de nmode-select-old-channels () % Select channels that were in effect when "Lisp Interface" was started up. % (But don't turn echoing on.) NOTE that the "old channels" are normally % selected while NMODE is actually running (this is somewhat counter % intuitive). This is so that any error messages created by bugs in NMODE % will not be printed into NMODE buffers. (If they were, it might break % things recursively!) (setf STDIN* OldStdIn) (setf STDOUT* OldStdOut) (setf ErrOut* OldErrOut) (RDS STDIN*) % Select the channels. (WRS STDOUT*) ) (de nmode-select-buffer-channel () % Select channels that read from and write to NMODE buffers. (nmode-select-buffer-input-channel) (setf STDOUT* nmode-buffer-channel) (setf ErrOut* nmode-buffer-channel) (WRS STDOUT*) ) (de nmode-select-buffer-input-channel () % Select channel that reads from NMODE buffer. "NMODE-Channel-Editor" is % called when read routines invoke the "editor routine" for the newly selected % channel. (if (null nmode-buffer-channel) (setf nmode-buffer-channel (OpenBufferChannel NIL nmode-output-buffer 'nmode-channel-editor))) (setf STDIN* nmode-buffer-channel) (RDS STDIN*) ) (de nmode-channel-editor (chn) % This procedure is called every time that input is requested from an NMODE % buffer. It starts up NMODE (if not already running) and resumes NMODE % execution. When the user has decided on what input to give to the channel % (by performing Lisp-E), the NMODE-reader will return with I/O bound to the % "buffer channel". The reader will also return if the user performs Lisp-L, % in which case I/O will remain bound to the "standard" channels. % Select "old" channels, so if an error occurs we don't get a bad recursive % situation where printing into a buffer causes more trouble! (nmode-select-old-channels) (cond ((not *NMODE-RUNNING) (setf *NMODE-RUNNING T) (setf *GC NIL) (if (not *nmode-init-has-run) (nmode-run-init-file) ) ) (t (buffer-channel-flush nmode-buffer-channel) (setf nmode-output-end-position (=> nmode-output-buffer position)) % compensate for moving to line start on next Lisp-E: (if (not (at-line-start?)) (move-to-next-line)) ) ) (enter-raw-mode) (nmode-select-major-window) % just in case (NMODE-reader NIL) % NIL => don't exit when a command aborts ) (de nmode-main () (setf CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (setf CurrentScanTable* LispScanTable*) (when (not toploopread*) (setf toploopread* 'read) (setf toploopprint* 'print) (setf toploopeval* 'eval) (setf toploopname* "NMODE Lisp") ) (nmode-initialize) % does nothing if already initialized (nmode-set-terminal) % ensure proper terminal driver is loaded % Note: RESET may cause echoing to be turned on without clearing *RawIO. (when *RawIO (setf *RawIO NIL) (EchoOff) ) (when nmode-first-start (setf nmode-first-start NIL) % never again (cond (nmode-auto-start (setf *NMODE-RUNNING T) % see below (let ((was-modified? (=> nmode-output-buffer modified?))) (=> nmode-output-buffer insert-line LispBanner*) (if (not was-modified?) (=> nmode-output-buffer set-modified? NIL) ))) (t (printf "%w%n" LispBanner*) )) ) (while T (setf nmode-terminal-input-buffer NIL) % flush execution from buffers (cond (*NMODE-RUNNING (setf *NMODE-RUNNING NIL) % force full start-up (nmode) % cause next READ to start up NMODE ) (t (RDS 0) (WRS 1) )) (nmode-top-loop) )) (copyd 'main 'nmode-main) (de nmode-top-loop () (TopLoop toploopread* toploopprint* toploopeval* toploopname* "") (Printf "End of File read!") ) |
Added psl-1983/nmode/lisp-parser.b version [80987754e7].
cannot compute difference between binary files
Added psl-1983/nmode/lisp-parser.sl version [d413e919c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Lisp-Parser.SL - NMODE's Lisp parser % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % Revised: 18 February 1983 % % See the document NMODE-PARSING.TXT for a description of the parsing strategy. % % 18-Feb-1983 Alan Snyder % Removed use of "obsolete" #\ names. % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings fast-vectors nmode-attributes)) % Imported variables: (fluid '(nmode-defun-predicate nmode-defun-scanner nmode-current-parser )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de establish-lisp-parser () (setf nmode-defun-predicate #'lisp-current-line-is-defun?) (setf nmode-defun-scanner #'lisp-scan-past-defun) (setf nmode-current-parser #'lisp-parse-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % This file defines the basic primitive used by NMODE to % analyze Lisp source code. It currently recognizes: % % ( and ) as list brackets % [ and ] as vector brackets % comments beginning with % % #/x as character constants % " ... " as string literals % !x as a quoted character % ' ` #' #. , ,@ as prefixes to ( and [ (de lisp-parse-line (str vec) % Fill Vec[i] to be the attributes of Str[i]. (let* ((previous-attributes -1) attributes ch is-first (high (string-upper-bound str)) (in-comment NIL) (in-string NIL) (last-was-sharp NIL) (last-was-sharp-slash NIL) (last-was-sharp-quote NIL) (last-was-sharp-dot NIL) (last-was-quoter NIL) (last-was-comma NIL) (last-was-comma-atsign NIL) (last-prefix-ending-index NIL) (last-prefix-length NIL) ) (for (from i 0 high) (do (setf ch (string-fetch str i)) % Determine the type attributes of the current character and update % the parsing state for the next character. (cond (in-comment (setf attributes (attributes COMMENT))) (in-string (setf attributes (attributes ATOM)) (setf in-string (not (= ch #/"))) ) (last-was-sharp-slash (setf attributes (attributes ATOM)) (setf last-was-sharp-slash NIL) ) (last-was-quoter (setf attributes (attributes ATOM)) (setf last-was-quoter NIL) ) (t (setf attributes (lisp-character-attributes ch)) (setf in-comment (= ch #/%)) (setf in-string (= ch #/")) (setf last-was-sharp-slash (and last-was-sharp (= ch #//))) (setf last-was-sharp-quote (and last-was-sharp (= ch #/'))) (setf last-was-sharp-dot (and last-was-sharp (= ch #/.))) (setf last-was-sharp (= ch #/#)) (setf last-was-quoter (= ch #/!)) (setf last-was-comma-atsign (and last-was-comma (= ch #/@))) (setf last-was-comma (= ch #/,)) (let ((prefix-length (cond (last-was-sharp-quote 2) (last-was-sharp-dot 2) ((= ch #/') 1) ((= ch #/`) 1) (last-was-comma 1) (last-was-comma-atsign 1) % is 1 because comma is a prefix (t 0) ))) (when (> prefix-length 0) % We just passed a prefix. % Does it merge with the previous prefix? (if (and last-prefix-ending-index (= last-prefix-ending-index (- i prefix-length)) ) (setf last-prefix-length (+ last-prefix-length prefix-length)) % Otherwise (setf last-prefix-length prefix-length) ) (setf last-prefix-ending-index i) )) )) % Determine the position attributes: % LISP is simple: brackets are single characters (except for % prefixes, which are handled below), atoms are maximal % contiguous strings of atomic-characters. (setf is-first (or (= attributes (attributes OPENER)) (= attributes (attributes CLOSER)) (~= attributes previous-attributes))) (setf previous-attributes attributes) (cond % First we test for an open bracket immediately preceded % by one or more prefixes. ((and (= attributes (attributes OPENER)) last-prefix-ending-index (= last-prefix-ending-index (- i 1)) ) (let ((prefix-start (- i last-prefix-length))) (vector-store vec prefix-start (attributes FIRST PREFIX OPENER)) (lp-set-last vec (- prefix-start 1)) (for (from j (+ prefix-start 1) (- i 1)) (do (vector-store vec j (attributes MIDDLE PREFIX OPENER)))) )) (is-first (setf attributes (| attributes (attributes FIRST))) (lp-set-last vec (- i 1)) ) (t (setf attributes (| attributes (attributes MIDDLE))) )) (vector-store vec i attributes) )) (lp-set-last vec high) )) (de lisp-character-attributes (ch) (selectq ch (NIL (attributes)) ((#/( #/[) (attributes OPENER)) ((#/) #/]) (attributes CLOSER)) ((#\SPACE #\TAB #\LF #\CR) (attributes BLANKS)) (#/% (attributes COMMENT)) (t (attributes ATOM)) )) (de lp-set-last (vec i) (if (>= i 0) (vector-store vec i (& (| (attributes LAST) (vector-fetch vec i)) (~ (attributes MIDDLE)))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Lisp Defun Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-current-line-is-defun? () (and (not (current-line-empty?)) (= (current-line-fetch 0) #/() )) (de lisp-scan-past-defun () % This function should be called with point at the start of a defun. % It will scan past the end of the defun (not to the beginning of the % next line, however). If the end of the defun is not found, it returns % NIL and leaves point unchanged. (move-forward-form) ) |
Added psl-1983/nmode/m-x.b version [767342c3ac].
cannot compute difference between binary files
Added psl-1983/nmode/m-x.sl version [8b4757015f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % M-X.SL - NMODE Extended Command Support % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 September 1982 % Revised: 29 December 1982 % % 29-Dec-82 Alan Snyder % Revise PROMPT-FOR-EXTENDED-COMMAND to use new prompted input. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings extended-char)) (fluid '(nmode-input-buffer)) % Internal variables: (fluid '(prompt-for-extended-command-command-list current-extended-command-list )) (setf prompt-for-extended-command-command-list (list (cons (x-char SPACE) 'complete-input-command-name) (cons (x-char CR) 'complete-and-terminate-input-command-name) (cons (x-char LF) 'complete-and-terminate-input-command-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-extended-command (prompt) % Ask the user for the name of an extended command. Return the full command % name from the dispatch table (so that EQ can be used to compare). (setf current-extended-command-list (lookup-prefix-character (x-char M-X))) (let* ((input-name (prompt-for-string-special prompt nil prompt-for-extended-command-command-list)) (matching-names (extended-command-names-that-match input-name)) ) (first matching-names) )) % Internal functions: (de complete-input-command-name () % Extend the string in the input buffer by at most one word to match % the existing extended command names. Ring the bell if the string % is not extended. (let ((original-length (string-length (nmode-get-input-string)))) (complete-input-extended-command-name NIL) (if (= original-length (string-length (nmode-get-input-string))) (Ding) ))) (de complete-and-terminate-input-command-name () % Extend the string in the input buffer as far as possible to match the % existing extended command names. If the resulting string uniquely % identifies a single command name, refresh and terminate input. Otherwise, % if the string was not extended, ring the bell. (let* ((original-length (string-length (nmode-get-input-string))) (name (complete-input-extended-command-name T)) ) (if name (progn (nmode-refresh) (nmode-terminate-input)) (if (= original-length (string-length (nmode-get-input-string))) (Ding) )))) (de complete-input-extended-command-name (many-ok) % Extend the string in the input buffer BY WORDS. If MANY-OK is non-nil, then % extend by as many words as possible; otherwise, by only one word. If the % extended name matches exactly one command name, return that command name. % Otherwise, return NIL. (let* ((name (nmode-get-input-string)) (names (extended-command-names-that-match name)) ) (cond ((string-equal name "E") (nmode-replace-input-string "Edit ") NIL ) ((string-equal name "L") (nmode-replace-input-string "List ") NIL ) ((string-equal name "K") (nmode-replace-input-string "Kill ") NIL ) ((string-equal name "V") (nmode-replace-input-string "View ") NIL ) ((string-equal name "W") (nmode-replace-input-string "What ") NIL ) ((null names) % The name matches no command. NIL ) ((null (cdr names)) % The name matches exactly one command. (nmode-replace-input-string (extend-name-by-words name names many-ok)) (car names) ) (t % The name matches more than one command. (nmode-replace-input-string (extend-name-by-words name names many-ok)) NIL )) )) (de extend-name-by-words (name names many-ok) % NAME is the current contents of the input buffer. Extend it "by words" as % long as it matches all of the specified NAMES. NAMES must be a list % containing one or more strings. If MANY-OK is non-NIL, then extend it by as % many words as possible. Otherwise, extend it by at most one word. % Extending by words means that you do not append a new partial word, although % you may partially complete a word already started. Return the extended % string. (let* ((match-prefix (strings-largest-common-prefix names)) (partial-word (not (or (string-empty? name) (= (string-fetch name (string-upper-bound name)) #\space) ))) (bound (string-length name)) ) % Try to increase the "bound": (for (from i bound (string-upper-bound match-prefix)) (do (when (= (string-fetch match-prefix i) #\space) (setf bound (+ i 1)) % this far is OK (setf partial-word NIL) % further words will extend only in full (if (not many-ok) (exit)) )) (finally (if (or partial-word (null (cdr names))) (setf bound (string-length match-prefix)) ))) (substring match-prefix 0 bound) )) (de extended-command-names-that-match (name) (for (in pair (cdr current-extended-command-list)) (when (name-matches-prefix name (car pair))) (collect (car pair)) )) (de name-matches-prefix (test-name name) (let ((test-len (string-length test-name)) (name-len (string-length name)) ) (and (>= name-len test-len) (string-equal (substring name 0 test-len) test-name) ))) |
Added psl-1983/nmode/m-xcmd.b version [726080cd73].
cannot compute difference between binary files
Added psl-1983/nmode/m-xcmd.sl version [75bd72d1a4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % M-XCMD.SL - Miscellaneous Extended Commands % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Revise M-X Set Visited Filename to actualize the new file name (i.e., % convert it to the true name of the file). Revise M-X Rename Buffer to % convert buffer name to upper case and to check for use of an existing % buffer name. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-int)) (fluid '(nmode-current-buffer)) (de delete-matching-lines-command () (delete-possibly-matching-lines nil)) (de delete-non-matching-lines-command () (delete-possibly-matching-lines t)) (de delete-possibly-matching-lines (retain-if-match) % This function prompts for a string which it searches for in all % lines including and after the current one. The search is % insensitive to case. If retain-if-match is true then all lines % with the string will be retained and all lines lacking it will be % deleted, otherwise all lines with the string will be deleted. % Point is left at the start of the line that it was originally on. % This function does not return a useful value. (move-to-start-of-line) (let ((modified-flag (=> nmode-current-buffer modified?)) (starting-line (current-line-pos)) (next-unfilled-line (current-line-pos)) (match-string (string-upcase (prompt-for-string "Comparison String: " "")))) (for (from test-line starting-line (- (current-buffer-size) 1) 1) (do (when (if retain-if-match % This sets the sign of the selections. (forward-search-on-line test-line 0 match-string) (not (forward-search-on-line test-line 0 match-string))) (current-buffer-store next-unfilled-line (current-buffer-fetch test-line)) (incr next-unfilled-line)))) (if (= next-unfilled-line (current-buffer-size)) % No lines were tossed. (=> nmode-current-buffer set-modified? modified-flag) % Else (extract-region t (buffer-position-create next-unfilled-line 0) (progn (move-to-buffer-end) (buffer-get-position)))) (set-line-pos starting-line))) (de count-occurrences-command () % This function counts the number of instances of a string after the % current buffer position. The counting is insensitive to case. % The user is prompted for the string. If the user supplies an % empty string, they are told that it can't be counted. This avoids % an infinite loop. The count obtained is displayed in the prompt % line. This function does not return a useful value. (let ((count 0) (initial-place (buffer-get-position)) (match-string (string-upcase (prompt-for-string "Count Occurrences: " "")))) (if (equal match-string "") (write-prompt "One can't count instances of the empty string.") (while (forward-search match-string) (incr count) (move-forward)) (buffer-set-position initial-place) (write-prompt (bldmsg "%d occurrences" count))))) (de set-key-command () % This binds a user-selected function to a command. The user is % prompted for the function name and the key sequence of the % command. This function then tests to see if the user's function % exists, then asks for confirmation just before doing the binding. % This function does not return a useful value. (let ((function (intern (string-upcase (prompt-for-string "Function Name: " ""))))) (if (funboundp function) (write-prompt (bldmsg "No function %w was found." function)) (let* ((junk (write-message (bldmsg "Put %p on key:" function))) (command (input-command))) (when (nmode-y-or-n? (bldmsg "Load %w with %w" (command-name command) function)) (set-text-command command function)))))) (de set-visited-filename-command () % This command allows a user to alter the filename associated with the % current buffer. Prompt-for-defaulted-filename is used to set default % characteristics. This function does not return a useful value. (let* ((new-name (prompt-for-defaulted-filename "Set Visited Filename: " NIL))) (=> nmode-current-buffer set-file-name (or (actualize-file-name new-name) new-name) ))) (de rename-buffer-command () % This function allows the user to rename the current buffer if it is not a % system buffer like main or output. It prompts the user for a new buffer % name. If the user inputs an empty string, the buffer name is set to a % converted version of the filename associated with the buffer. Buffer % names are converted to upper case. An error is reported if the user % chooses the name of another existing buffer. This function does not % return a useful value. (if (not (buffer-killable? nmode-current-buffer)) % tests for main and output (nmode-error (bldmsg "Buffer %w cannot be renamed." (=> nmode-current-buffer name))) (let* ((old-name (=> nmode-current-buffer name)) (new-name (string-upcase (prompt-for-string "Rename Buffer: " (let ((filename (=> nmode-current-buffer file-name))) % Default (if filename (filename-to-buffername filename) % Else, if there is no filename (=> nmode-current-buffer name))))))) (when (not (string= new-name old-name)) (if (buffer-exists? new-name) (nmode-error (bldmsg "Name %w already in use." new-name)) (=> nmode-current-buffer set-name new-name) ))))) (de kill-some-buffers-command () % This functions lists the killable buffers one by one, letting the % user kill, retain, or examine each one as it is named. This % function does not return a useful value. (let ((buffer-list (nmode-user-buffers))) (while buffer-list (let ((buffer-to-die (car buffer-list))) (setf buffer-list (cdr buffer-list)) (when (and (buffer-killable? buffer-to-die) (let ((name (=> buffer-to-die name)) (mod-warn (if (=> buffer-to-die modified?) "HAS BEEN EDITED" "is unmodified"))) (recursive-edit-y-or-n buffer-to-die (bldmsg "Buffer %w %w. Kill it? Type Y or N or ^R to edit" name mod-warn) (bldmsg "Type Y to kill or N to save buffer %w" name)))) (buffer-kill-and-detach buffer-to-die)))))) (de insert-date-command () % This inserts the current date into the text, after point, and % moves point past it. It does not return a useful value. (insert-string (current-date-time))) (de revert-file-command () % This function allows the user to replace the current buffer's % contents with the contents of the file associated with the current % buffer, if there is one. It asks for confirmation before actually % performing the replacement. This function does not return a % useful value. (let ((fn (=> nmode-current-buffer file-name)) (bn (=> nmode-current-buffer name))) (if (and (if fn T (write-prompt "No file to read old copy from") NIL) (nmode-y-or-n? (BldMsg "Want to replace buffer %w with %w from disk?" bn fn))) (read-file-into-buffer nmode-current-buffer fn)))) |
Added psl-1983/nmode/mode-defs.b version [4e9c640af0].
cannot compute difference between binary files
Added psl-1983/nmode/mode-defs.sl version [864590a380].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MODE-DEFS.SL - NMODE Command Table and Mode Definitions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % Revised: 18 February 1983 % % 18-Feb-83 Alan Snyder % Rename down-list and insert-parens. Add M-) command. % 9-Feb-83 Alan Snyder % Add Esc-_ (Help), temporarily attached to M-X Apropos. % Move some M-X commands into text-command-list. % 2-Feb-83 Alan Snyder % Add Lisp-D. % 26-Jan-83 Alan Snyder % Add Esc-/. % 25-Jan-83 Alan Snyder % Created Window-Command-List to allow scrolling in Recurse mode. % Removed modifying text commands from Recurse mode. % 24-Jan-83 Jeffrey Soreff % Added definition of Recurse-Mode % Defined M-X commands: Delete Matching Lines, Flush Lines, % Delete Non-Matching Lines, Keep Lines, How Many, Count Occurrences, % Set Key, Set Visited Filename, Rename Buffer, Kill Some Buffers, % Insert Date, Revert File % 5-Jan-83 Alan Snyder % Revised definition of input mode, C-S, and C-R. % 3-Dec-82 Alan Snyder % New definitions for ) and ] in Lisp mode. % New definitions for C-M-(, C-M-), C-M-U, C-M-N, and C-M-P. % New definitions for C-M-A, C-M-[, and C-M-R. % Define C-M-\ (Indent Region) in Lisp mode and Text mode. % Define C-? same as M-?, C-( same as C-M-(, C-) same as C-M-). % Lisp Mode establishes Lisp Parser. % Define C-M-C. % Define the text commands: C-=, C-X =, M-A, M-E, M-K, C-X Rubout, M-Z, M-Q, % M-G, M-H, M-], M-[, M-S. % Fix definitions of digits and hyphen: inserting definition goes on % text-command-list (where insertion commands go). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % (CompileTime (load objects)) (CompileTime (load extended-char)) % External variables: (fluid '(nmode-default-mode nmode-current-buffer nmode-input-special-command-list )) % Mode definitions: (fluid '(Lisp-Interface-Mode Text-Mode Basic-Mode Read-Only-Text-Mode Input-Mode Recurse-Mode )) % Command lists: (fluid '(Input-Command-List Read-Only-Text-Command-List Text-Command-List Rlisp-Command-List Lisp-Command-List Read-Only-Terminal-Command-List Modifying-Terminal-Command-List Window-Command-List Basic-Command-List Essential-Command-List Recurse-Command-List )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Mode Definitions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-initialize-modes () (setf Basic-Mode (nmode-define-mode "Basic" '((nmode-define-commands Basic-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) ))) (setf Read-Only-Text-Mode (nmode-define-mode "Read-Only-Text" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-establish-mode Basic-Mode) ))) (setf Text-Mode (nmode-define-mode "Text" '((nmode-define-commands Text-Command-List) (nmode-define-commands Modifying-Terminal-Command-List) (nmode-establish-mode Read-Only-Text-Mode) (nmode-define-normal-self-inserts) ))) (setf Lisp-Interface-Mode (nmode-define-mode "Lisp" '((nmode-define-commands Rlisp-Command-List) (establish-lisp-parser) (nmode-define-commands Lisp-Command-List) (nmode-establish-mode Text-Mode) ))) (setf Input-Mode (nmode-define-mode "Input" '((nmode-define-commands nmode-input-special-command-list) (nmode-define-command (x-char CR) 'nmode-terminate-input) (nmode-define-command (x-char LF) 'nmode-terminate-input) (nmode-define-commands Input-Command-List) (nmode-define-commands Text-Command-List) (nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-normal-self-inserts) ))) (setf Recurse-Mode (nmode-define-mode "Recurse" '((nmode-define-commands Read-Only-Text-Command-List) (nmode-define-commands Read-Only-Terminal-Command-List) (nmode-define-commands Window-Command-List) (nmode-define-commands Essential-Command-List) (nmode-define-commands Recurse-Command-List) ))) (setf nmode-default-mode Text-Mode) % Define initial set of file modes. (nmode-declare-file-mode "txt" Text-Mode) (nmode-declare-file-mode "red" Lisp-Interface-Mode) (nmode-declare-file-mode "sl" Lisp-Interface-Mode) (nmode-declare-file-mode "lsp" Lisp-Interface-Mode) (nmode-declare-file-mode "lap" Lisp-Interface-Mode) (nmode-declare-file-mode "build" Lisp-Interface-Mode) ) (de lisp-mode-command () (buffer-set-mode nmode-current-buffer Lisp-Interface-Mode) ) (de text-mode-command () (buffer-set-mode nmode-current-buffer Text-Mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Command Lists: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Rlisp-Command-List - commands related to the LISP interface (setf Rlisp-Command-List (list (cons (x-char C-!]) 'Lisp-prefix) (cons (x-chars C-!] !?) 'lisp-help-command) (cons (x-chars C-!] A) 'lisp-abort-command) (cons (x-chars C-!] B) 'lisp-backtrace-command) (cons (x-chars C-!] C) 'lisp-continue-command) (cons (x-chars C-!] D) 'execute-defun-command) (cons (x-chars C-!] E) 'execute-form-command) (cons (x-chars C-!] L) 'exit-nmode) (cons (x-chars C-!] Q) 'lisp-quit-command) (cons (x-chars C-!] R) 'lisp-retry-command) (cons (x-chars C-!] Y) 'yank-last-output-command) )) % Lisp-Command-List - commands related to editing LISP text (setf Lisp-Command-List (list (cons (x-char !)) 'insert-closing-bracket) (cons (x-char !]) 'insert-closing-bracket) (cons (x-char C-!() 'backward-up-list-command) (cons (x-char C-!)) 'forward-up-list-command) (cons (x-char C-M-!() 'backward-up-list-command) (cons (x-char C-M-!)) 'forward-up-list-command) (cons (x-char C-M-![) 'move-backward-defun-command) (cons (x-char C-M-!]) 'end-of-defun-command) (cons (x-char C-M-!\) 'lisp-indent-region-command) (cons (x-char C-M-@) 'mark-form-command) (cons (x-char C-M-A) 'move-backward-defun-command) (cons (x-char C-M-B) 'move-backward-form-command) (cons (x-char C-M-BACKSPACE) 'mark-defun-command) (cons (x-char C-M-D) 'down-list-command) (cons (x-char C-M-E) 'end-of-defun-command) (cons (x-char C-M-F) 'move-forward-form-command) (cons (x-char C-M-H) 'mark-defun-command) (cons (x-char C-M-I) 'lisp-tab-command) (cons (x-char C-M-K) 'kill-forward-form-command) (cons (x-char C-M-N) 'move-forward-list-command) (cons (x-char C-M-P) 'move-backward-list-command) (cons (x-char C-M-Q) 'lisp-indent-sexpr) (cons (x-char C-M-R) 'reposition-window-command) (cons (x-char C-M-RUBOUT) 'kill-backward-form-command) (cons (x-char C-M-T) 'transpose-forms) (cons (x-char C-M-TAB) 'lisp-tab-command) (cons (x-char C-M-U) 'backward-up-list-command) (cons (x-char M-!;) 'insert-comment-command) (cons (x-char M-BACKSPACE) 'mark-defun-command) (cons (x-char M-!() 'make-parens-command) (cons (x-char M-!)) 'move-over-paren-command) (cons (x-char RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char TAB) 'lisp-tab-command) )) % Essential-Command-List: the most essential commands (setf Essential-Command-List (list (cons (x-char C-X) 'c-x-prefix) (cons (x-char ESC) 'Esc-prefix) (cons (x-char M-X) 'm-x-prefix) (cons (x-char C-M-X) 'm-x-prefix) (cons (x-char C-G) 'nmode-abort-command) (cons (x-char C-L) 'nmode-refresh-command) (cons (x-char C-U) 'universal-argument) (cons (x-char 0) 'argument-digit) (cons (x-char 1) 'argument-digit) (cons (x-char 2) 'argument-digit) (cons (x-char 3) 'argument-digit) (cons (x-char 4) 'argument-digit) (cons (x-char 5) 'argument-digit) (cons (x-char 6) 'argument-digit) (cons (x-char 7) 'argument-digit) (cons (x-char 8) 'argument-digit) (cons (x-char 9) 'argument-digit) (cons (x-char -) 'negative-argument) (cons (x-char C-0) 'argument-digit) (cons (x-char C-1) 'argument-digit) (cons (x-char C-2) 'argument-digit) (cons (x-char C-3) 'argument-digit) (cons (x-char C-4) 'argument-digit) (cons (x-char C-5) 'argument-digit) (cons (x-char C-6) 'argument-digit) (cons (x-char C-7) 'argument-digit) (cons (x-char C-8) 'argument-digit) (cons (x-char C-9) 'argument-digit) (cons (x-char C--) 'negative-argument) (cons (x-char M-0) 'argument-digit) (cons (x-char M-1) 'argument-digit) (cons (x-char M-2) 'argument-digit) (cons (x-char M-3) 'argument-digit) (cons (x-char M-4) 'argument-digit) (cons (x-char M-5) 'argument-digit) (cons (x-char M-6) 'argument-digit) (cons (x-char M-7) 'argument-digit) (cons (x-char M-8) 'argument-digit) (cons (x-char M-9) 'argument-digit) (cons (x-char M--) 'negative-argument) (cons (x-char C-M-0) 'argument-digit) (cons (x-char C-M-1) 'argument-digit) (cons (x-char C-M-2) 'argument-digit) (cons (x-char C-M-3) 'argument-digit) (cons (x-char C-M-4) 'argument-digit) (cons (x-char C-M-5) 'argument-digit) (cons (x-char C-M-6) 'argument-digit) (cons (x-char C-M-7) 'argument-digit) (cons (x-char C-M-8) 'argument-digit) (cons (x-char C-M-9) 'argument-digit) (cons (x-char C-M--) 'negative-argument) (cons (x-chars C-X C-Z) 'nmode-exit-to-superior) (cons (x-chars C-X V) 'nmode-invert-video) (cons (x-chars Esc !/) 'execute-softkey-command) )) % Window-Command-List: commands for scrolling, etc. % These commands do not allow selecting a new window, buffer, mode, etc. (setf Window-Command-List (list (cons (x-char C-M-V) 'scroll-other-window-command) (cons (x-char C-V) 'next-screen-command) (cons (x-char M-R) 'move-to-screen-edge-command) (cons (x-char M-V) 'previous-screen-command) (cons (x-chars C-X <) 'scroll-window-left-command) (cons (x-chars C-X >) 'scroll-window-right-command) (cons (x-chars C-X P) 'write-screen-photo-command) (cons (x-chars C-X ^) 'grow-window-command) )) % Basic-Command-List: contains commands desirable in almost any mode. (setf Basic-Command-List (list (cons (x-char C-!?) 'help-dispatch) (cons (x-char C-M-L) 'select-previous-buffer-command) (cons (x-char M-!/) 'help-dispatch) (cons (x-char M-!?) 'help-dispatch) (cons (x-char M-!~) 'buffer-not-modified-command) (cons (x-chars C-X !.) 'set-fill-prefix-command) (cons (x-chars C-X 1) 'one-window-command) (cons (x-chars C-X 2) 'two-windows-command) (cons (x-chars C-X 3) 'view-two-windows-command) (cons (x-chars C-X 4) 'visit-in-other-window-command) (cons (x-chars C-X B) 'select-buffer-command) (cons (x-chars C-X C-B) 'buffer-browser-command) (cons (x-chars C-X C-F) 'find-file-command) (cons (x-chars C-X C-S) 'save-file-command) (cons (x-chars C-X C-W) 'write-file-command) % here??? (cons (x-chars C-X D) 'dired-command) (cons (x-chars C-X E) 'exchange-windows-command) (cons (x-chars C-X F) 'set-fill-column-command) (cons (x-chars C-X K) 'kill-buffer-command) (cons (x-chars C-X O) 'other-window-command) (cons (x-chars Esc _) 'apropos-command) (cons (m-x "Append to File") 'append-to-file-command) (cons (m-x "Apropos") 'apropos-command) (cons (m-x "Auto Fill Mode") 'auto-fill-mode-command) (cons (m-x "Count Occurrences") 'Count-Occurrences-command) (cons (m-x "Delete and Expunge File") 'delete-and-expunge-file-command) (cons (m-x "Delete File") 'delete-file-command) (cons (m-x "DIRED") 'edit-directory-command) (cons (m-x "Edit Directory") 'edit-directory-command) (cons (m-x "Execute Buffer") 'execute-buffer-command) (cons (m-x "Execute File") 'execute-file-command) (cons (m-x "Find File") 'find-file-command) (cons (m-x "How Many") 'Count-Occurrences-command) (cons (m-x "Kill Buffer") 'kill-buffer-command) (cons (m-x "Kill File") 'delete-file-command) (cons (m-x "Kill Some Buffers") 'kill-some-buffers-command) (cons (m-x "List Buffers") 'buffer-browser-command) (cons (m-x "Make Space") 'nmode-gc) (cons (m-x "Prepend to File") 'prepend-to-file-command) (cons (m-x "Rename Buffer") 'rename-buffer-command) (cons (m-x "Save All Files") 'save-all-files-command) (cons (m-x "Select Buffer") 'select-buffer-command) (cons (m-x "Set Key") 'set-key-command) (cons (m-x "Set Visited Filename") 'set-visited-filename-command) (cons (m-x "Start Scripting") 'start-scripting-command) (cons (m-x "Start Timing NMODE") 'start-timing-command) (cons (m-x "Stop Scripting") 'stop-scripting-command) (cons (m-x "Stop Timing NMODE") 'stop-timing-command) (cons (m-x "Undelete File") 'undelete-file-command) (cons (m-x "Write File") 'write-file-command) % here??? (cons (m-x "Write Region") 'write-region-command) )) % Read-Only-Text-Command-List: Commands for editing text buffers that % do not modify the buffer. (setf Read-Only-Text-Command-List (list % These commands are read-only commands for text mode. (cons (x-char BACKSPACE) 'move-backward-character-command) (cons (x-char C-<) 'mark-beginning-command) (cons (x-char C->) 'mark-end-command) (cons (x-char C-=) 'what-cursor-position-command) (cons (x-char C-@) 'set-mark-command) (cons (x-char C-A) 'move-to-start-of-line-command) (cons (x-char C-B) 'move-backward-character-command) (cons (x-char C-E) 'move-to-end-of-line-command) (cons (x-char C-F) 'move-forward-character-command) (cons (x-char C-M-M) 'back-to-indentation-command) (cons (x-char C-M-RETURN) 'back-to-indentation-command) (cons (x-char C-M-W) 'append-next-kill-command) (cons (x-char C-N) 'move-down-command) (cons (x-char C-P) 'move-up-command) (cons (x-char C-R) 'reverse-search-command) (cons (x-char C-S) 'incremental-search-command) (cons (x-char C-SPACE) 'set-mark-command) (cons (x-char M-<) 'move-to-buffer-start-command) (cons (x-char M->) 'move-to-buffer-end-command) (cons (x-char M-![) 'backward-paragraph-command) (cons (x-char M-!]) 'forward-paragraph-command) (cons (x-char M-@) 'mark-word-command) (cons (x-char M-A) 'backward-sentence-command) (cons (x-char M-B) 'move-backward-word-command) (cons (x-char M-E) 'forward-sentence-command) (cons (x-char M-F) 'move-forward-word-command) (cons (x-char M-H) 'mark-paragraph-command) (cons (x-char M-M) 'back-to-indentation-command) (cons (x-char M-RETURN) 'back-to-indentation-command) (cons (x-char M-W) 'copy-region) (cons (x-chars C-X A) 'append-to-buffer-command) (cons (x-chars C-X C-N) 'set-goal-column-command) (cons (x-chars C-X C-X) 'exchange-point-and-mark) (cons (x-chars C-X H) 'mark-whole-buffer-command) (cons (x-chars C-X =) 'what-cursor-position-command) )) % Text-Command-List: Commands for editing text buffers that might modify % the buffer. Note: put read-only commands on % Read-Only-Text-Command-List (above). (setf Text-Command-List (list (cons (x-char 0) 'argument-or-insert-command) (cons (x-char 1) 'argument-or-insert-command) (cons (x-char 2) 'argument-or-insert-command) (cons (x-char 3) 'argument-or-insert-command) (cons (x-char 4) 'argument-or-insert-command) (cons (x-char 5) 'argument-or-insert-command) (cons (x-char 6) 'argument-or-insert-command) (cons (x-char 7) 'argument-or-insert-command) (cons (x-char 8) 'argument-or-insert-command) (cons (x-char 9) 'argument-or-insert-command) (cons (x-char -) 'argument-or-insert-command) (cons (x-char C-!%) 'replace-string-command) (cons (x-char C-D) 'delete-forward-character-command) (cons (x-char C-K) 'kill-line) (cons (x-char C-M-C) 'insert-self-command) (cons (x-char C-M-O) 'split-line-command) (cons (x-char C-M-!\) 'indent-region-command) (cons (x-char C-N) 'move-down-extending-command) (cons (x-char C-O) 'open-line-command) (cons (x-char C-Q) 'insert-next-character-command) (cons (x-char C-RUBOUT) 'delete-backward-hacking-tabs-command) (cons (x-char C-T) 'transpose-characters-command) (cons (x-char C-W) 'kill-region) (cons (x-char C-Y) 'insert-kill-buffer) (cons (x-char LF) 'indent-new-line-command) (cons (x-char M-!') 'upcase-digit-command) (cons (x-char M-!%) 'query-replace-command) (cons (x-char M-!\) 'delete-horizontal-space-command) (cons (x-char M-C) 'uppercase-initial-command) (cons (x-char M-D) 'kill-forward-word-command) (cons (x-char M-G) 'fill-region-command) (cons (x-char M-I) 'tab-to-tab-stop-command) (cons (x-char M-K) 'kill-sentence-command) (cons (x-char M-L) 'lowercase-word-command) (cons (x-char M-Q) 'fill-paragraph-command) (cons (x-char M-RUBOUT) 'kill-backward-word-command) (cons (x-char M-S) 'center-line-command) (cons (x-char M-T) 'transpose-words) (cons (x-char M-TAB) 'tab-to-tab-stop-command) (cons (x-char M-U) 'uppercase-word-command) (cons (x-char M-Y) 'unkill-previous) (cons (x-char M-Z) 'fill-comment-command) (cons (x-char M-^) 'delete-indentation-command) (cons (x-char RETURN) 'return-command) (cons (x-char RUBOUT) 'delete-backward-character-command) (cons (x-char TAB) 'tab-to-tab-stop-command) (cons (x-chars C-X C-L) 'lowercase-region-command) (cons (x-chars C-X C-O) 'delete-blank-lines-command) (cons (x-chars C-X C-T) 'transpose-lines) (cons (x-chars C-X C-U) 'uppercase-region-command) (cons (x-chars C-X C-V) 'visit-file-command) (cons (x-chars C-X G) 'get-register-command) (cons (x-chars C-X Rubout) 'backward-kill-sentence-command) (cons (x-chars C-X T) 'transpose-regions) (cons (x-chars C-X X) 'put-register-command) (cons (m-x "Delete Matching Lines") 'delete-matching-lines-command) (cons (m-x "Delete Non-Matching Lines") 'delete-non-matching-lines-command) (cons (m-x "Flush Lines") 'delete-matching-lines-command) (cons (m-x "Insert Buffer") 'insert-buffer-command) (cons (m-x "Insert Date") 'insert-date-command) (cons (m-x "Insert File") 'insert-file-command) (cons (m-x "Keep Lines") 'delete-non-matching-lines-command) (cons (m-x "Lisp Mode") 'lisp-mode-command) (cons (m-x "Replace String") 'replace-string-command) (cons (m-x "Query Replace") 'query-replace-command) (cons (m-x "Revert File") 'revert-file-command) (cons (m-x "Text Mode") 'text-mode-command) (cons (m-x "Visit File") 'visit-file-command) )) (setf Read-Only-Terminal-Command-List (list (cons (x-chars ESC !h) 'move-to-buffer-start-command) (cons (x-chars ESC 4) 'move-backward-word-command) (cons (x-chars ESC 5) 'move-forward-word-command) (cons (x-chars ESC A) 'move-up-command) (cons (x-chars ESC B) 'move-down-command) (cons (x-chars ESC C) 'move-forward-character-command) (cons (x-chars ESC D) 'move-backward-character-command) (cons (x-chars ESC F) 'move-to-buffer-end-command) (cons (x-chars ESC J) 'nmode-full-refresh) (cons (x-chars ESC S) 'scroll-window-up-line-command) (cons (x-chars ESC T) 'scroll-window-down-line-command) (cons (x-chars ESC U) 'scroll-window-up-page-command) (cons (x-chars ESC V) 'scroll-window-down-page-command) )) (setf Modifying-Terminal-Command-List (list (cons (x-chars ESC L) 'open-line-command) (cons (x-chars ESC M) 'kill-line) (cons (x-chars ESC P) 'delete-forward-character-command) )) (setf Input-Command-List (list (cons (x-char C-R) 'nmode-yank-default-input) )) (setf Recurse-Command-List (list (cons (x-char y) 'affirmative-exit) (cons (x-char n) 'negative-exit) )) |
Added psl-1983/nmode/modes.b version [c91195b111].
cannot compute difference between binary files
Added psl-1983/nmode/modes.sl version [8ffcd36908].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MODES.SL - NMODE Mode Manipulation Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 14 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char)) % Global variables: (fluid '(nmode-default-mode nmode-minor-modes % list of active minor modes (don't modify inplace!) )) % Internal static variables: (fluid '(nmode-defined-modes nmode-file-modes )) (setf nmode-default-mode NIL) (setf nmode-defined-modes ()) (setf nmode-file-modes ()) (setf nmode-minor-modes ()) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Mode Definition: % % The following function is used to define a mode (either major or minor): % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-define-mode (name establish-expressions) (let* ((mode (make-instance 'mode 'name name 'establish-expressions establish-expressions )) (pair (Ass (function string-equal) name nmode-defined-modes ))) (if pair (rplacd pair mode) (setf nmode-defined-modes (cons (cons name mode) nmode-defined-modes) )) mode )) (defflavor mode ( name establish-expressions ) () gettable-instance-variables initable-instance-variables ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % File Modes % % The following functions associate a default mode with certain % filename extensions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-declare-file-mode (file-type mode) (let ((pair (Ass (function string-equal) file-type nmode-file-modes ))) (if pair (rplacd pair mode) (setf nmode-file-modes (cons (cons file-type mode) nmode-file-modes) )) )) (de pathname-default-mode (pn) (setf pn (pathname pn)) (let ((pair (Ass (function string-equal) (pathname-type pn) nmode-file-modes ))) (if pair (cdr pair) nmode-default-mode) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Minor Modes % % A minor mode is a mode that can be turned on or off independently of the % current buffer or the current major mode. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de minor-mode-active? (m) % M is a mode object. Return T if it is an active minor mode. (memq m nmode-minor-modes) ) (de activate-minor-mode (m) % M is a mode object. Make it active (if it isn't already). (when (not (minor-mode-active? m)) (setf nmode-minor-modes (cons m nmode-minor-modes)) (nmode-establish-current-mode) )) (de deactivate-minor-mode (m) % M is a mode object. If it is active, deactivate it. (when (minor-mode-active? m) (setf nmode-minor-modes (delq m nmode-minor-modes)) (nmode-establish-current-mode) )) (de toggle-minor-mode (m) % M is a mode object. If it is active, deactivate it and return T; % otherwise, activate it and return NIL. (let ((is-active? (minor-mode-active? m))) (if is-active? (deactivate-minor-mode m) (activate-minor-mode m) ) is-active? )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Manipulating mode lists: % % The following functions are provided for use in user init files. They are % not used in NMODE. See the file -CUSTOMIZING.TXT for information on how to % customize NMODE. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de add-to-command-list (listname command func) (let* ((old-list (eval listname)) (old-binding (assoc command old-list)) (binding (cons command func)) ) (cond % If the binding isn't already in the a-list. ((null old-binding) % Add the new binding (set listname (aconc old-list binding))) % Otherwise, replace the old operation in the binding. (T (setf (cdr old-binding) func))) NIL )) (de remove-from-command-list (listname command) (let* ((old-list (eval listname)) (old-binding (assoc command old-list)) ) (cond (old-binding (set listname (DelQ old-binding old-list)) NIL )))) (de set-text-command (command func) % This function is a shorthand for modifying text mode. The arguments are as % for ADD-TO-COMMAND-LIST. The change takes effect immediately. (add-to-command-list 'Text-Command-List command func) (nmode-establish-current-mode)) |
Added psl-1983/nmode/move-commands.b version [bf203a9261].
cannot compute difference between binary files
Added psl-1983/nmode/move-commands.sl version [13996e70db].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Move-Commands.SL - NMODE Move commands % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Bug fix: permanent goal column wasn't permanent. % 18-Nov-82 Alan Snyder % Added move-up-list, move-over-list, and move-over-defun commands. % Changed skip-forward-blanks and skip-backward-blanks. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-current-buffer nmode-command-argument nmode-command-argument-given nmode-previous-command-function)) % Internal static variables: (fluid '(nmode-goal-column % permanent goal (set by user) nmode-temporary-goal-column % temporary goal within cmd sequence nmode-goal-column-functions % cmds that don't reset temp goal )) (setf nmode-goal-column nil) (setf nmode-temporary-goal-column nil) (setf nmode-goal-column-functions (list (function move-down-command) (function move-down-extending-command) (function move-up-command) (function set-goal-column-command) )) (de move-to-buffer-start-command () (set-mark-from-point) (move-to-buffer-start) ) (de move-to-buffer-end-command () (set-mark-from-point) (move-to-buffer-end) ) (de move-to-start-of-line-command () (current-buffer-goto (+ (current-line-pos) (- nmode-command-argument 1)) 0) ) (de move-to-end-of-line-command () (move-to-start-of-line-command) (move-to-end-of-line)) (de set-goal-column-command () (cond ((= nmode-command-argument 1) (setf nmode-goal-column (current-display-column)) (write-prompt (BldMsg "Goal Column = %p" nmode-goal-column)) ) (t (setf nmode-goal-column NIL) (write-prompt "No Goal Column") ))) (de setup-goal-column () % If this is the first in a new (potential) sequence of up/down commands, % then set the temporary goal column for that sequence of commands. (if (not (memq nmode-previous-command-function nmode-goal-column-functions)) (setf nmode-temporary-goal-column (current-display-column))) ) (de goto-goal-column () % Move the cursor to the current goal column, which is the permanent goal % column (if set by the user) or the temporary goal column (otherwise). (cond (nmode-goal-column (set-display-column nmode-goal-column)) (nmode-temporary-goal-column (set-display-column nmode-temporary-goal-column)) )) (de move-up-command () (setup-goal-column) (set-line-pos (- (current-line-pos) nmode-command-argument)) (goto-goal-column) ) (de move-down-extending-command () (when (and (not nmode-command-argument-given) (current-line-is-last?)) (let ((old-pos (buffer-get-position))) (move-to-buffer-end) (insert-eol) (buffer-set-position old-pos) )) (move-down-command) ) (de move-down-command () (setup-goal-column) (set-line-pos (+ (current-line-pos) nmode-command-argument)) (goto-goal-column) ) (de exchange-point-and-mark () (let ((old-mark (current-mark))) (previous-mark) % pop off the old mark (set-mark-from-point) % push the new one (buffer-set-position old-mark) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Skipping Blanks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de char-blank-or-newline? (ch) (or (char-blank? ch) (= ch #\LF))) (de skip-forward-blanks () % Skip over "blanks", return the first non-blank character seen. % Cursor is positioned to the left of that character. (while (and (not (at-buffer-end?)) (char-blank-or-newline? (next-character)) ) (move-forward)) (next-character)) (de skip-backward-blanks () % Skip backwards over "blanks", return the first non-blank character seen. % Cursor is positioned to the right of that character. (while (and (not (at-buffer-start?)) (char-blank-or-newline? (previous-character)) ) (move-backward)) (previous-character)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Characters commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-character-command () (if (not (move-over-characters nmode-command-argument)) (Ding))) (de move-backward-character-command () (if (not (move-over-characters (- nmode-command-argument))) (Ding))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Word commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-word-command () (if (not (move-over-words nmode-command-argument)) (Ding))) (de move-backward-word-command () (if (not (move-over-words (- nmode-command-argument))) (Ding))) (de move-over-words (n) % Move forward (n>0) or backwards (n<0) over |n| words. Return T if the % specified number of words were found, NIL otherwise. The cursor remains at % the last word found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-word))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-word))) (setf n (+ n 1))) flag)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Form commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-form-command () (if (not (move-over-forms nmode-command-argument)) (Ding))) (de move-backward-form-command () (if (not (move-over-forms (- nmode-command-argument))) (Ding))) (de move-over-forms (n) % Move forward (n>0) or backwards (n<0) over |n| forms. Return T if the % specified number of forms were found, NIL otherwise. The cursor remains at % the last form found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-form))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-form))) (setf n (+ n 1))) flag)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Up-List commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de forward-up-list-command () (if (not (move-up-lists nmode-command-argument)) (Ding))) (de backward-up-list-command () (if (not (move-up-lists (- nmode-command-argument))) (Ding))) (de move-up-lists (n) % Move forward (n>0) or backwards (n<0) out of |n| lists (structures). % Return T if the specified number of brackets were found, NIL otherwise. % The cursor remains at the last bracket found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-up-list))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-up-list))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-List commands % % Note: In EMACS, these commands were motivated by the fact that EMACS did % not understand Lisp comments. Thus, in EMACS, move-forward-list could be % used as a move-forward-form that ignored comments. Since NMODE does % understand comments, it is not clear that these commands have any use. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-list-command () (if (not (move-over-lists nmode-command-argument)) (Ding))) (de move-backward-list-command () (if (not (move-over-lists (- nmode-command-argument))) (Ding))) (de move-over-lists (n) % Move forward (n>0) or backwards (n<0) over |n| lists (structures). % Return T if the specified number of lists were found, NIL otherwise. % The cursor remains at the last list found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-list))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-list))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Over-Defun commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-defun-command () (if (not (move-over-defuns nmode-command-argument)) (Ding))) (de move-backward-defun-command () (if (not (move-over-defuns (- nmode-command-argument))) (Ding))) (de move-over-defuns (n) % Move forward (n>0) or backwards (n<0) over |n| defuns. % Return T if the specified number of defuns were found, NIL otherwise. % The cursor remains at the last defun found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-defun))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-defun))) (setf n (+ n 1))) flag )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Character Movement Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-characters (n) % Move forward (n>0) or backwards (n<0) over |n| characters. Return T if the % specified number of characters were found, NIL otherwise. The cursor % remains at the last character found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-character))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-character))) (setf n (+ n 1))) flag)) (de move-forward-character () % Move forward one character. If there is no next character, leave cursor % unchanged and return NIL; otherwise, return T. (if (at-buffer-end?) NIL (move-forward) T )) (de move-backward-character () % Move backward one character. If there is no previous character, leave % cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-start?) NIL (move-backward) T )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Character Movement Primitives (Hacking Tabs Version) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-over-characters-hacking-tabs (n) % Move forward (n>0) or backwards (n<0) over |n| characters. Return T if the % specified number of characters were found, NIL otherwise. The cursor % remains at the last character found. (let ((flag T)) (while (and (> n 0) (setf flag (move-forward-character-hacking-tabs))) (setf n (- n 1))) (while (and (< n 0) (setf flag (move-backward-character-hacking-tabs))) (setf n (+ n 1))) flag)) (de move-forward-character-hacking-tabs () % Move forward one character. If the next character is a tab, first % replace it with the appropriate number of spaces. If there is no next % character, leave cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-end?) NIL (cond ((= (next-character) (char TAB)) (delete-next-character) (let ((n (- 8 (& (current-display-column) 7)))) (insert-string (substring " " 0 n)) (set-char-pos (- (current-char-pos) n)) ))) (move-forward) T )) (de move-backward-character-hacking-tabs () % Move backward one character. If the previous character is a tab, first % replace it with the appropriate number of spaces. If there is no previous % character, leave cursor unchanged and return NIL; otherwise, return T. (if (at-buffer-start?) NIL (cond ((= (previous-character) (char TAB)) (delete-previous-character) (let ((n (- 8 (& (current-display-column) 7)))) (insert-string (substring " " 0 n)) ))) (move-backward) T )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Word Movement Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de word-char? (ch) (or (AlphanumericP ch) (= ch (char -)))) (de move-forward-word () % Move forward one "word", starting from point. Leave cursor to the % right of the "word". If there is no next word, leave cursor unchanged % and return NIL; otherwise, return T. (let ((old-pos (buffer-get-position))) (while (and (not (at-buffer-end?)) % scan for start of word (not (word-char? (next-character))) ) (move-forward)) (cond ((at-buffer-end?) (buffer-set-position old-pos) NIL ) (t (while (and (not (at-buffer-end?)) % scan for end of word (word-char? (next-character)) ) (move-forward)) T )))) (de move-backward-word () % Move backward one "word", starting from point. Leave cursor to the left of % the "word". If there is no previous word, leave cursor unchanged and % return NIL; otherwise, return T. (let ((old-pos (buffer-get-position))) (while (and (not (at-buffer-start?)) % scan for end of word (not (word-char? (previous-character))) ) (move-backward)) (cond ((at-buffer-start?) (buffer-set-position old-pos) NIL ) (t (while (and (not (at-buffer-start?)) % scan for start of word (word-char? (previous-character)) ) (move-backward)) T )))) |
Added psl-1983/nmode/nmode-20.b version [e3f341c5b7].
cannot compute difference between binary files
Added psl-1983/nmode/nmode-20.sl version [316cb2913f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-20.SL - DEC-20 NMODE Stuff (intended for DEC-20 Version Only) % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 January 1983 % Revised: 25 January 1983 % % 25-Jan-83 Alan Snyder % Add version of actualize-file-name that ensures that transiently-created % file has delete access. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () % Stolen directly from Nancy Kendzierski % Date/time in appropriate format for the network mail header (let ((date-time (MkString 80))) (jsys1 date-time -1 #.(bits 5 7 10 12 13) 0 (const jsODTIM)) (recopystringtonull date-time))) (de actualize-file-name (file-name) % If the specified file exists, return its "true" (and complete) name. % Otherwise, return the "true" name of the file that would be created if one % were to do so. (Unfortunately, we have no way to do this except by actually % creating the file and then deleting it!) Return NIL if the file cannot be % read or created. (let ((s (attempt-to-open-input file-name))) (cond ((not s) (setf s (attempt-to-open-output (string-concat file-name ";P777777") % so we can delete it! )) (when s (setf file-name (=> s file-name)) (=> s close) (file-delete-and-expunge file-name) file-name ) ) (t (setf file-name (=> s file-name)) (=> s close) file-name )))) |
Added psl-1983/nmode/nmode-9836.lap version [80df683ed2].
> > | 1 2 | (faslin "PN:NMODE-9836.B") (load-nmode) |
Added psl-1983/nmode/nmode-9836.sl version [b493aa8ef3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-9836.SL - HP9836 Nmode Stuff (intended only for HP9836 version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 January 1983 % Revised: 15 February 1983 % % 15-Feb-83 Alan Snyder % No longer sets NMODE-AUTO-START (inconsistent with other systems). % Add new online documentation stuff. % 7-Feb-83 Alan Snyder % Load browser. % 31-Jan-83 Alan Snyder % Add softkey stuff, keyboard mapping stuff, load window-label. % Redefine PasFiler and PasEditor to refresh the screen upon exit, if NMODE % was running. % 25-Jan-83 Alan Snyder % Added dummy version of current-date-time function; load M-XCMD and REC. % 21-Jan-83 Alan Snyder % Load more stuff. Change INIT to return NIL. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load fast-strings fast-int extended-char)) (bothtimes (load strings common)) (fluid '(alpha-terminal color-terminal nmode-file-list nmode-source-prefix *quiet_faslout *usermode *redefmsg installkeys-address uninstallkeys-address nmode-softkey-label-screen-height nmode-softkey-label-screen-width doc-text-file reference-text-file )) (if (or (unboundp 'nmode-source-prefix) (null nmode-source-prefix)) (setf nmode-source-prefix "pn:")) (if (funboundp 'pre-nmode-main) (copyd 'pre-nmode-main 'main)) (if (funboundp 'pre-nmode-pasfiler) (copyd 'pre-nmode-pasfiler 'pasfiler)) (if (funboundp 'pre-nmode-paseditor) (copyd 'pre-nmode-paseditor 'paseditor)) (setf installkeys-address (system-address "NMODEKEYS_INSTALL_KEYMAP")) (setf uninstallkeys-address (system-address "NMODEKEYS_UNINSTALL_KEYMAP")) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 9836 Customization: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-9836-init () % This function modifies "standard" NMODE for use on the 9836. (let ((*usermode nil) (*redefmsg nil)) (copyd 'nmode-initialize 'original-nmode-initialize) (copyd 'actualize-file-name '9836-actualize-file-name) ) (original-nmode-initialize) (add-to-command-list 'basic-command-list (x-chars C-X C-Z) 'exit-nmode) (nmode-establish-current-mode) (setf alpha-terminal nmode-terminal) (setf color-terminal (make-instance '9836-color)) nil % for looks ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Useful Functions for Compiling: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de load-nmode () % Load NMODE. % Any system-dependent customization is done here so that it can % be overrided by the user before nmode is initialized. (nmode-load-required-modules) (nmode-load-all) (setf nmode-softkey-label-screen-height 2) % two rows (setf nmode-softkey-label-screen-width 5) % of five keys each (setf doc-text-file "psl:nmode.frames") (setf reference-text-file "psl:nmode.xref") (let ((*usermode nil) (*redefmsg nil)) (if (funboundp 'original-nmode-initialize) (copyd 'original-nmode-initialize 'nmode-initialize)) (copyd 'nmode-initialize 'nmode-9836-init) )) (de compile-lisp-file (source-name object-name) (let ((*quiet_faslout T)) (if (not (filep source-name)) (printf "Unable to open source file: %w%n" source-name) % else (printf "%n----- Compiling %w to %w%n" source-name (string-concat object-name ".b")) (faslout object-name) (unwind-protect (dskin source-name) (faslend) ) (printf "%n----------------------------------------------------------%n") ))) (de file-compile (s) (let ((object-name s) (source-name (string-concat s ".sl")) ) (compile-lisp-file source-name object-name) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % System-Dependent Stuff: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-date-time () "") % dummy version (de 9836-actualize-file-name (fn) fn) (de nmode-use-color () % Use the COLOR screen (only). (setf nmode-terminal color-terminal) (nmode-new-terminal) ) (de nmode-use-alpha () % Use the ALPHA screen as the primary screen. (setf nmode-terminal alpha-terminal) (nmode-new-terminal) ) (de install-nmode-keymap () (setf nmode-meta-bit-prefix-character (x-char ^!\)) (lpcall0 installkeys-address) ) (de uninstall-nmode-keymap () (setf nmode-meta-bit-prefix-character (x-char ^![)) (lpcall0 uninstallkeys-address) ) (de pasfiler () (pre-nmode-pasfiler) (if *NMODE-RUNNING (nmode-full-refresh)) ) (de paseditor () (pre-nmode-paseditor) (if *NMODE-RUNNING (nmode-full-refresh)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stuff for Building NMODE: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-load-required-modules () (load addr2id) (load objects) (load common) (load useful) (load strings) (load pathnames) (load ring-buffer) (load extended-char) (load directory) (load input-stream) (load output-stream) (load processor-time) (load wait) (load vector-fix) (load nmode-parsing) (load windows) (lapin "PHP:DEFPCALL.SL") (lapin "PHP:NMODE-AIDS.SL") ) (de nmode-fixup-name (s) (if (> (string-length s) 12) (substring s 0 12) s )) (de nmode-load-all () (for (in s nmode-file-list) (do (nmode-load s)) )) (de nmode-load (s) (nmode-faslin nmode-source-prefix s) ) (de nmode-faslin (directory-name module-name) (setf module-name (nmode-fixup-name module-name)) (setf module-name (string-concat module-name ".b")) (let ((object-name (string-concat directory-name module-name))) (if (filep object-name) (faslin object-name) (continuableerror 99 (bldmsg "Unable to FASLIN %w" object-name) (list 'faslin object-name) )))) (setf nmode-file-list (list "browser" "browser-support" "buffer" "buffer-io" "buffer-position" "buffer-window" "buffers" "case-commands" "command-input" "commands" "defun-commands" "dispatch" "extended-input" "fileio" "incr" "indent-commands" "kill-commands" "lisp-commands" "lisp-indenting" "lisp-interface" "lisp-parser" "m-x" "m-xcmd" "modes" "mode-defs" "move-commands" "nmode-break" "nmode-init" "prompting" "query-replace" "reader" "rec" "screen-layout" "search" "set-terminal" "softkeys" "structure-functions" "terminal-input" "text-buffer" "text-commands" "window" "window-label" % These must be last: "autofill" "buffer-browser" "dired" "doc" )) |
Added psl-1983/nmode/nmode-attributes.sl version [9c373b007f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Nmode-Attributes.SL - macros for NMODE parsing primitives % [This file used to be Parsing-Attributes.SL] % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 November 1982 % % This file defines Macros! Load it at compile-time! % % See the document NMODE-PARSING.TXT for a description of the parsing strategy. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) % Internal Constants: % Type attributes: % Exactly one of these should always be on. (defconst OPENER-BITS 2#000000001) % part of an opening "bracket" (defconst CLOSER-BITS 2#000000010) % part of a closing "bracket" (defconst ATOM-BITS 2#000000100) % part of an "atom" (defconst BLANKS-BITS 2#000001000) % part of a "blank region" (defconst COMMENT-BITS 2#000010000) % part of a comment % Secondary attributes: % Zero or more of these may be on. (defconst PREFIX-BITS 2#000100000) % a subclass of opening bracket % Position attributes: % One or two of these should always be on. (defconst FIRST-BITS 2#001000000) % the first character of an item (defconst MIDDLE-BITS 2#010000000) % neither first nor last (defconst LAST-BITS 2#100000000) % the last character of an item % Masks: (defconst POSITION-BITS #.(| (const FIRST-BITS) (| (const MIDDLE-BITS) (const LAST-BITS)))) (defconst BRACKET-BITS #.(| (const OPENER-BITS) (const CLOSER-BITS))) (defconst WHITESPACE-BITS #.(| (const BLANKS-BITS) (const COMMENT-BITS))) (defconst NOT-SPACE-BITS #.(| (const BRACKET-BITS) (const ATOM-BITS))) (defconst PRIMARY-TYPE-BITS #.(| (const NOT-SPACE-BITS) (const WHITESPACE-BITS))) (defconst SECONDARY-TYPE-BITS #.(const PREFIX-BITS)) (defconst TYPE-BITS #.(| (const PRIMARY-TYPE-BITS) (const SECONDARY-TYPE-BITS))) (de parse-character-attributes (attribute-list) % Given a list of attribute names, return an integer containing % all of their bits. (let ((bits 0)) (for (in attribute-name attribute-list) (do (selectq attribute-name (OPENER (setf bits (| bits (const OPENER-BITS)))) (CLOSER (setf bits (| bits (const CLOSER-BITS)))) (BRACKET (setf bits (| bits (const BRACKET-BITS)))) (ATOM (setf bits (| bits (const ATOM-BITS)))) (BLANKS (setf bits (| bits (const BLANKS-BITS)))) (COMMENT (setf bits (| bits (const COMMENT-BITS)))) (WHITESPACE (setf bits (| bits (const WHITESPACE-BITS)))) (NOT-SPACE (setf bits (| bits (const NOT-SPACE-BITS)))) (PREFIX (setf bits (| bits (const PREFIX-BITS)))) (FIRST (setf bits (| bits (const FIRST-BITS)))) (MIDDLE (setf bits (| bits (const MIDDLE-BITS)))) (LAST (setf bits (| bits (const LAST-BITS)))) (t (StdError (BldMsg "Invalid character attribute: %p" attribute-name))) ))) bits )) (de unparse-character-attributes (bits) % Return a list of attribute names. (let ((l ())) (if (~= 0 (& bits (const OPENER-BITS))) (setf l (cons 'OPENER l))) (if (~= 0 (& bits (const CLOSER-BITS))) (setf l (cons 'CLOSER l))) (if (~= 0 (& bits (const ATOM-BITS))) (setf l (cons 'ATOM l))) (if (~= 0 (& bits (const BLANKS-BITS))) (setf l (cons 'BLANKS l))) (if (~= 0 (& bits (const COMMENT-BITS))) (setf l (cons 'COMMENT l))) (if (~= 0 (& bits (const PREFIX-BITS))) (setf l (cons 'PREFIX l))) (if (~= 0 (& bits (const LAST-BITS))) (setf l (cons 'LAST l))) (if (~= 0 (& bits (const MIDDLE-BITS))) (setf l (cons 'MIDDLE l))) (if (~= 0 (& bits (const FIRST-BITS))) (setf l (cons 'FIRST l))) l )) (de decode-character-attribute-type (bits) % Return a primary type attribute name or NIL. (cond ((~= 0 (& bits (const OPENER-BITS))) 'OPENER) ((~= 0 (& bits (const CLOSER-BITS))) 'CLOSER) ((~= 0 (& bits (const ATOM-BITS))) 'ATOM) ((~= 0 (& bits (const BLANKS-BITS))) 'BLANKS) ((~= 0 (& bits (const COMMENT-BITS))) 'COMMENT) (t NIL) )) (de fix-attribute-bits (bits) (if (= (& bits (const POSITION-BITS)) 0) % No position specified? Then any position will do. (setf bits (| bits (const POSITION-BITS)))) (if (= (& bits (const TYPE-BITS)) 0) % No type specified? Then any type will do. (setf bits (| bits (const TYPE-BITS)))) bits ) (defmacro attributes attributes-list (parse-character-attributes attributes-list) ) (defmacro test-attributes attributes-list (fix-attribute-bits (parse-character-attributes attributes-list)) ) |
Added psl-1983/nmode/nmode-break.b version [b266d78918].
cannot compute difference between binary files
Added psl-1983/nmode/nmode-break.sl version [8eea19dd9a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-BREAK.SL - NMODE Break Handler % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 26 August 1982 % % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(*NMODE-RUNNING *nmode-init-running *OutWindow nmode-terminal nmode-command-argument nmode-buffer-channel)) (fluid '(BreakLevel* *QuitBreak BreakEval* BreakName* ERROUT* ErrorForm*)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % We redefine BREAK (the break handler) and YESP. % Grab the original versions (if we can find them!). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (if (FUnboundP 'pre-nmode-break) (CopyD 'pre-nmode-break (if (FUnboundP 'pre_rawio_break) 'break 'pre_rawio_break ))) (if (FUnboundP 'pre-nmode-yesp) (CopyD 'pre-nmode-yesp 'yesp)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Initialization: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de enable-nmode-break () (let ((*usermode NIL) (*redefmsg NIL) ) (CopyD 'break 'nmode-break) (CopyD 'yesp 'nmode-yesp) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Break handler: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-break () (cond (*NMODE-RUNNING (nmode-break-handler)) (t (let ((old-raw-mode (=> nmode-terminal raw-mode))) (leave-raw-mode) (prog1 (pre-nmode-break) (if old-raw-mode (enter-raw-mode)) ))))) (de nmode-break-handler () (let* ((BreakLevel* (+ BreakLevel* 1)) (*QuitBreak T) (BreakEval* 'Eval) (BreakName* "NMODE Break") (OldIN* IN*) (OldOUT* OUT*) (nmode-error? (eq in* 0)) (nmode-channel? (eq in* nmode-buffer-channel)) (init-error? *nmode-init-running) (old-raw-mode (=> nmode-terminal raw-mode)) (*OutWindow T) % always pop up on a break (*nmode-init-running NIL) % ditto (*NMODE-RUNNING (not nmode-error?)) ) (cond (nmode-error? (leave-raw-mode) (RDS 0) (WRS 1) ) (t (RDS nmode-buffer-channel) (WRS nmode-buffer-channel) (enter-raw-mode) )) (when init-error? (Printf "Error occurred while executing your NMODE INIT file!%n") (Ding) ) (unwind-protect (Catch '$Break$ (TopLoop 'Read 'Print 'BreakEval BreakName* "NMODE Break loop") ) (RDS OldIN*) (WRS OldOUT*) (if old-raw-mode (enter-raw-mode)) ) (if *QuitBreak (let ((*Break NIL) (*EmsgP NIL) ) (StdError "Exit to ErrorSet"))) ) (Eval ErrorForm*) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Break command functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de lisp-quit-command () (cond ((ensure-in-break) (setf *QuitBreak T) (throw '$Break$ NIL) ))) (de lisp-retry-command () (cond ((ensure-in-break) (cond (*ContinuableError (setf *QuitBreak NIL) (throw '$Break$ NIL) ) (t (write-prompt "Cannot retry: error is not continuable.") (Ding))) ))) (de lisp-continue-command () (cond ((ensure-in-break) (cond (*ContinuableError (setf ErrorForm* (MkQuote BreakValue*)) (setf *QuitBreak NIL) (throw '$Break$ NIL) ) (t (write-prompt "Cannot continue: error is not continuable.") (Ding))) ))) (de lisp-abort-command () (cond ((ensure-in-break) (reset)))) (de lisp-backtrace-command () (cond ((ensure-in-break) (nmode-select-buffer-channel) (cond ((>= nmode-command-argument 16) (VerboseBackTrace)) ((>= nmode-command-argument 4) (InterpBackTrace)) (t (BackTrace))) (nmode-select-old-channels) ))) (de lisp-help-command () (write-message (if (> BreakLevel* 0) "Lisp break commands: Q-quit;A-abort;R-retry;C-continue;B-backtrace" "Lisp commands: E-execute form;Y-yank last output;L-invoke Lisp Listener" ))) (de ensure-in-break () (if (> BreakLevel* 0) T (write-prompt "Not in a break loop!") (Ding) NIL )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Query functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-yesp (message) (cond ((and *NMODE-RUNNING (=> nmode-terminal raw-mode)) (nmode-yes-or-no? message)) (t (pre-nmode-yesp message)) )) (de nmode-yes-or-no? (message) (let ((response (prompt-for-string message NIL))) (while T (cond ((string-equal response "Yes") (exit T)) ((string-equal response "No") (exit NIL)) (t (Ding) (write-prompt "Please answer YES or NO.") (sleep-until-timeout-or-input 60) (setf response (prompt-for-string message NIL)) ))))) (de nmode-y-or-n? (message) (write-message message) (nmode-set-immediate-prompt "Y or N: ") (let ((answer (while T (let ((ch (char-upcase (input-direct-terminal-character)))) (when (= ch #/Y) (nmode-complete-prompt "Y") (exit T)) (when (= ch #/N) (nmode-complete-prompt "N") (exit NIL)) (when (= ch #\BELL) (exit 'ABORT)) (Ding) )))) (set-prompt "") (write-message "") (if (eq answer 'ABORT) (throw 'ABORT NIL)) answer )) |
Added psl-1983/nmode/nmode-init.b version [3d4ff29dbb].
cannot compute difference between binary files
Added psl-1983/nmode/nmode-init.sl version [895b9e402b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-INIT.SL - NMODE Initialization % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects)) (fluid '(lisp-interface-mode input-mode nmode-main-buffer nmode-output-buffer nmode-input-buffer nmode-initialized )) (setf nmode-initialized NIL) (de nmode-initialize () (cond ((not nmode-initialized) (nmode-initialize-extended-input) (nmode-initialize-modes) (nmode-initialize-buffers) % modes must be initialized previously (nmode-initialize-screen-layout) % buffers must be init previously (nmode-initialize-kill-ring) (enable-nmode-break) (setf nmode-initialized T) ))) (de nmode-initialize-buffers () (if (null nmode-main-buffer) (setf nmode-main-buffer (buffer-create "MAIN" lisp-interface-mode))) (if (null nmode-output-buffer) (setf nmode-output-buffer (buffer-create "OUTPUT" lisp-interface-mode))) (if (null nmode-input-buffer) (setf nmode-input-buffer (buffer-create-unselectable "PROMPT-BUFFER" input-mode))) ) |
Added psl-1983/nmode/nmode-parsing.sl version [71e3c6ee46].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % NMODE-Parsing.SL - NMODE parsing primitives % [This file used to be Parsing-Functions.SL] % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % Revised: 6 January 1983 % % This file defines Macros! Load it at compile-time! % % This file defines the basic primitives used by NMODE functions to analyze % source code. See the document NMODE-PARSING.TXT for a description of the % parsing strategy. % % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings fast-vectors)) (BothTimes (load nmode-attributes)) % Global Variables: (fluid '(nmode-current-parser)) (setf nmode-current-parser 'lisp-parse-line) % Internal Static Variables: (fluid '(nmode-parsed-line nmode-parsed-line-info )) (setf nmode-parsed-line NIL) (setf nmode-parsed-line-info (make-vector 200 0)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % These are the exported functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro test-current-attributes attributes-list `(test-current-attributes-bits (test-attributes ,@attributes-list)) ) (defmacro move-forward-to attributes-list `(move-forward-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-backward-to attributes-list `(move-backward-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-forward-within-line-to attributes-list `(move-forward-within-line-to-bits (test-attributes ,@attributes-list)) ) (defmacro move-backward-within-line-to attributes-list `(move-backward-within-line-to-bits (test-attributes ,@attributes-list)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % These are internal, non-primitive functions: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de test-current-attributes-bits (bits) (let* ((x (current-attributes)) (match-bits (& x bits)) ) (and (~= 0 (& match-bits (const POSITION-BITS))) (~= 0 (& match-bits (const TYPE-BITS))) ))) (de move-forward-to-bits (bits) (move-forward-to-bits-until bits #'at-buffer-end?)) (de move-backward-to-bits (bits) (move-backward-to-bits-until bits #'at-buffer-start?)) (de move-forward-within-line-to-bits (bits) (move-forward-to-bits-until bits #'at-line-end?)) (de move-backward-within-line-to-bits (bits) (move-backward-to-bits-until bits #'at-line-start?)) (de move-forward-to-bits-until (bits stop-predicate) (let ((old-pos (buffer-get-position))) (while T (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL)) (when (test-current-attributes-bits bits) (exit (decode-character-attribute-type (current-attributes)))) (move-forward-character) ))) (de move-backward-to-bits-until (bits stop-predicate) (let ((old-pos (buffer-get-position))) (while T (when (test-current-attributes-bits bits) (exit (decode-character-attribute-type (current-attributes)))) (when (apply stop-predicate ()) (buffer-set-position old-pos) (exit NIL)) (move-backward-character) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % The (internal) primitive parsing function: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-attributes () (let* ((str (current-line)) (len (string-length str)) (pos (current-char-pos)) ) (if (>= pos len) (attributes FIRST LAST BLANKS) % Otherwise (when (not (eq nmode-parsed-line str)) (setf nmode-parsed-line str) (if (< (vector-size nmode-parsed-line-info) len) (setf nmode-parsed-line-info (make-vector len 0))) (apply nmode-current-parser (list nmode-parsed-line nmode-parsed-line-info)) ) (vector-fetch nmode-parsed-line-info pos) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Testing code: % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char)) (de show-current-character () (write-prompt (bldmsg "%l" (unparse-character-attributes (current-attributes))))) %(set-text-command (x-char C-=) 'show-current-character) |
Added psl-1983/nmode/nmode.lap version [f6657c5a06].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (load directory) (load extended-char) (load input-stream) (load objects) (load output-stream) (load nmode-parsing) (load pathnames) (load processor-time) (load rawio) (load ring-buffer) (load vector-fix) % for TruncateVector (load windows) (faslin "pn:browser.b") (faslin "pn:browser-support.b") (faslin "pn:buffer-io.b") (faslin "pn:buffer-position.b") (faslin "pn:buffer-window.b") (faslin "pn:buffer.b") (faslin "pn:buffers.b") (faslin "pn:case-commands.b") (faslin "pn:command-input.b") (faslin "pn:commands.b") (faslin "pn:defun-commands.b") (faslin "pn:dispatch.b") (faslin "pn:extended-input.b") (faslin "pn:fileio.b") (faslin "pn:incr.b") (faslin "pn:indent-commands.b") (faslin "pn:kill-commands.b") (faslin "pn:lisp-commands.b") (faslin "pn:lisp-indenting.b") (faslin "pn:lisp-interface.b") (faslin "pn:lisp-parser.b") (faslin "pn:m-x.b") (faslin "pn:m-xcmd.b") (faslin "pn:mode-defs.b") (faslin "pn:modes.b") (faslin "pn:move-commands.b") (faslin "pn:nmode-20.b") (faslin "pn:nmode-break.b") (faslin "pn:nmode-init.b") (faslin "pn:prompting.b") (faslin "pn:query-replace.b") (faslin "pn:reader.b") (faslin "pn:rec.b") (faslin "pn:screen-layout.b") (faslin "pn:search.b") (faslin "pn:set-terminal.b") % compiled from set-terminal-20, etc. (faslin "pn:softkeys.b") (faslin "pn:structure-functions.b") (faslin "pn:terminal-input.b") (faslin "pn:text-buffer.b") (faslin "pn:text-commands.b") (faslin "pn:window.b") (faslin "pn:window-label.b") % Subsystems: load last! (they define modes at load-time) (faslin "pn:autofill.b") (faslin "pn:buffer-browser.b") (faslin "pn:dired.b") (faslin "pn:doc.b") |
Added psl-1983/nmode/prompting.b version [1c862d03d9].
cannot compute difference between binary files
Added psl-1983/nmode/prompting.sl version [229ca14e88].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prompting.SL - NMODE Prompt Line Manager % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 19 August 1982 % Revised: 16 February 1983 % % Adapted from Will Galway's EMODE. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Use one-window or one-screen refresh. % 29-Dec-82 Alan Snyder % Revised input completion support to run completion characters as commands % rather than terminating and resuming. Added new functions to manipulate the % input buffer. % 22-Dec-82 Jeffrey Soreff % Revised to handle control characters on prompt and message lines. % 21-Dec-82 Alan Snyder % Efficiency improvement: Added declarations for virtual screens and buffer % windows. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-strings fast-int)) % External variables used: (fluid '(nmode-prompt-screen nmode-message-screen nmode-input-window nmode-current-window )) % Global variables defined here: (fluid '(nmode-input-default )) % Internal static variables: (fluid '(nmode-prompt-cursor nmode-message-cursor nmode-message-string nmode-input-level nmode-input-special-command-list )) (setf nmode-prompt-cursor 0) (setf nmode-message-cursor 0) (setf nmode-message-string "") (setf nmode-input-level 0) (setf nmode-input-default NIL) (declare-flavor virtual-screen nmode-prompt-screen nmode-message-screen) (declare-flavor buffer-window nmode-input-window nmode-current-window) (declare-flavor text-buffer input-buffer) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % String input: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-for-string (prompt-string default-string) % Prompt for a string (terminated by CR or NL). Use default-string if an % empty string is returned (and default-string is non-NIL). The original % message line is restored, but not refreshed. Note: if you attempt to use % this function recursively, it will automatically throw '$ERROR$. The effect % of this action is that in string-input mode, commands that request string % input appear to be undefined. (This assumes that all such commands do % nothing visible before they first request string input.) (prompt-for-string-special prompt-string default-string NIL)) (de prompt-for-string-special (prompt-string default-string command-list) % This function is similar to PROMPT-FOR-STRING, except that it accepts a % command list that specifies a set of additional commands to be defined % while the user is typing at the input window. (if (> nmode-input-level 0) (throw '$error$ NIL) % else (setf nmode-input-special-command-list command-list) (setf nmode-input-default default-string) (let ((old-msg nmode-message-string) (old-window nmode-current-window) (nmode-input-level (+ nmode-input-level 1)) % FLUID ) (if default-string (setf prompt-string (string-concat prompt-string " (Default is: '" default-string "')"))) (=> (=> nmode-input-window buffer) reset) (nmode-select-window nmode-input-window) (set-message prompt-string) (set-prompt "") % avoid old prompt popping back up when we're done % Edit the buffer until an "exit" character is typed or the user aborts. (cond ((eq (NMODE-reader T) 'abort) (=> nmode-input-window deexpose) (nmode-select-window old-window) (set-message old-msg) (throw 'abort NIL) )) % Show the user that his input has been accepted. (move-to-start-of-line) (nmode-refresh-one-window nmode-input-window) % Pick up the string that was typed. (let ((return-string (current-line))) % Switch back to old window, etc. (=> nmode-input-window deexpose) (nmode-select-window old-window) % Restore original "message window". (set-message old-msg) % If an empty string, use default (unless it's NIL). (if (and default-string (equal return-string "")) default-string return-string ))))) (de nmode-substitute-default-input () % If the input buffer is empty and there is a default string, then stuff the % default string into the input buffer. (let ((input-buffer (=> nmode-input-window buffer))) (if (and (=> input-buffer at-buffer-start?) (=> input-buffer at-buffer-end?) nmode-input-default (stringp nmode-input-default) ) (=> input-buffer insert-string nmode-input-default) ))) (de nmode-get-input-string () % Return the contents of the input buffer as a string. If the buffer contains % more than one line, only the current line is returned. (let ((input-buffer (=> nmode-input-window buffer))) (=> input-buffer current-line) )) (de nmode-replace-input-string (s) % Replace the contents of the input buffer with the specified string. (let ((input-buffer (=> nmode-input-window buffer))) (=> input-buffer reset) (=> input-buffer insert-string s) )) (de nmode-terminate-input () % A command bound to this function will act to terminate string input. (exit-nmode-reader) ) (de nmode-yank-default-input () % A command bound to this function will act to insert the default string into % the input buffer. (if nmode-input-default (insert-string nmode-input-default) (Ding) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prompt line functions: % % NOTE: if your intent is to display a prompt string for user input, you should % use a function defined in TERMINAL-INPUT rather than one of these. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de write-prompt (msg) % Write the specified string to the prompt line and refresh the prompt % line. Note: the major windows are not refreshed. (set-prompt msg) (nmode-refresh-virtual-screen nmode-prompt-screen) ) (de set-prompt (msg) % Write the specified string to the prompt window, but do not refresh. (setf nmode-prompt-cursor 0) (=> nmode-prompt-screen clear) (prompt-append-string msg) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Message line functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de write-message (msg) % Display a string to the message window and refresh the message window. % Note: the major windows are not refreshed. % Return the previous message string. (prog1 (set-message msg) (nmode-refresh-virtual-screen nmode-message-screen) )) (de rewrite-message () % Rewrite the existing message (used when the default enhancement changes). (set-message nmode-message-string) ) (de set-message (msg) % Display a string in the "message" window, do not refresh. % Message will not appear until a refresh is done. % Return the previous message string. (let ((old-message nmode-message-string)) (setf nmode-message-string msg) (setf nmode-message-cursor 0) (=> nmode-message-screen clear) (message-append-string msg) old-message )) (de reset-message () % Clear the "message" window, but do not refresh. (setf nmode-message-string "") (setf nmode-message-cursor 0) (=> nmode-message-screen clear) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de prompt-append-string (s) (for (from i 0 (string-upper-bound s)) (do (prompt-append-character (string-fetch s i))))) (de prompt-append-character (ch) (cond ((or (< ch #\space) (= ch #\rubout)) % Control Characters (=> nmode-prompt-screen write #/^ 0 nmode-prompt-cursor) (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1)) (=> nmode-prompt-screen write (^ ch 8#100) 0 nmode-prompt-cursor) (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1))) (t (=> nmode-prompt-screen write ch 0 nmode-prompt-cursor) % Normal Char (setf nmode-prompt-cursor (+ nmode-prompt-cursor 1))))) (de message-append-string (s) (for (from i 0 (string-upper-bound s)) (do (message-append-character (string-fetch s i))))) (de message-append-character (ch) (cond ((or (< ch #\space) (= ch #\rubout)) % Control Characters (=> nmode-message-screen write #/^ 0 nmode-message-cursor) (setf nmode-message-cursor (+ nmode-message-cursor 1)) (=> nmode-message-screen write (^ ch 8#100) 0 nmode-message-cursor) (setf nmode-message-cursor (+ nmode-message-cursor 1))) (t (=> nmode-message-screen write ch 0 nmode-message-cursor) % Normal Char (setf nmode-message-cursor (+ nmode-message-cursor 1))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-prompt-screen nmode-message-screen) (undeclare-flavor nmode-input-window nmode-current-window) (undeclare-flavor input-buffer) |
Added psl-1983/nmode/query-replace.b version [8387ff5797].
cannot compute difference between binary files
Added psl-1983/nmode/query-replace.sl version [da81804f19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % QUERY-REPLACE.SL - Query/Replace command % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % Revised: 17 February 1983 % % 17-Feb-83 Alan Snyder % Define backspace to be a synonym for rubout. Terminate when a non-command % character is read and push back the character (like EMACS). % 9-Feb-83 Alan Snyder % Must now refresh since write-message no longer does. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int fast-strings)) % Externals used here: (fluid '(last-search-string nmode-current-buffer)) % Internal static variables: (fluid '(query-replace-message query-replace-help query-replace-pause-help)) (setf query-replace-message "Query-Replace") (setf query-replace-help (string-concat query-replace-message " SPACE:yes RUBOUT:no ESC:exit .:yes&exit ,:yes&show !:do all ^:back" )) (setf query-replace-pause-help (string-concat query-replace-message " SPACE:go on ESC:exit !:do all ^:back" )) (de replace-string-command () (let* ((pattern (setf last-search-string (prompt-for-string "Replace string: " last-search-string))) (replacement (prompt-for-string "Replace string with: " NIL)) (count 0) (old-pos (buffer-get-position)) ) (while (buffer-search pattern 1) (do-string-replacement pattern replacement) (setf count (+ count 1)) ) (buffer-set-position old-pos) (write-prompt (BldMsg "Number of replacements: %d" count)) )) (de query-replace-command () (let* ((ask t) ch pattern replacement (pausing nil) (ring-buffer (ring-buffer-create 16)) ) (setf pattern (setf last-search-string (prompt-for-string "Query Replace (string to replace): " last-search-string ))) (setf replacement (prompt-for-string "Replace string with: " NIL)) (set-message query-replace-message) (while (or pausing (buffer-search pattern 1)) (if ask (progn (cond (pausing (nmode-set-immediate-prompt "Command? ") ) (t (ring-buffer-push ring-buffer (buffer-get-position)) (nmode-set-immediate-prompt "Replace? ") )) (nmode-refresh) (setf ch (input-terminal-character)) (write-prompt "") ) (setf ch (x-char space)) % if not asking ) (if pausing (selectq ch ((#.(x-char space) #.(x-char rubout) #.(x-char backspace) #.(x-char !,)) (write-message query-replace-message) (setf pausing nil)) (#.(x-char !!) (setf ask nil) (setf pausing nil)) ((#.(x-char escape) #.(x-char !.)) (exit)) (#.(x-char C-L) (nmode-full-refresh)) (#.(x-char ^) (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer))) (#.(x-char ?) (write-message query-replace-pause-help) (next)) (t (push-back-input-character ch) (exit)) ) (selectq ch (#.(x-char space) (do-string-replacement pattern replacement)) (#.(x-char !,) (do-string-replacement pattern replacement) (write-message query-replace-message) (setf pausing t)) ((#.(x-char rubout) #.(x-char backspace)) (advance-over-string pattern)) (#.(x-char !!) (do-string-replacement pattern replacement) (setf ask nil)) (#.(x-char !.) (do-string-replacement pattern replacement) (exit)) (#.(x-char ?) (write-message query-replace-help) (next)) (#.(x-char escape) (exit)) (#.(x-char C-L) (nmode-full-refresh)) (#.(x-char ^) (ring-buffer-pop ring-buffer) (buffer-set-position (ring-buffer-top ring-buffer)) (setf pausing t)) (t (push-back-input-character ch) (exit)) ) ) ) (reset-message) (write-prompt "Query Replace Done.") )) (de do-string-replacement (pattern replacement) % Both PATTERN and REPLACEMENT must be single line strings. PATTERN is % assumed to be in the current buffer beginning at POINT. It is deleted and % replaced with REPLACEMENT. POINT is left pointing just past the inserted % text. (let ((old-pos (buffer-get-position))) (advance-over-string pattern) (extract-region T old-pos (buffer-get-position)) (insert-string replacement) )) (de advance-over-string (pattern) % PATTERN must be a single line string. PATTERN is assumed to be in the % current buffer beginning at POINT. POINT is advanced past PATTERN. (let ((pattern-length (string-length pattern))) (set-char-pos (+ (current-char-pos) pattern-length)) )) |
Added psl-1983/nmode/reader.b version [2bf4b2068f].
cannot compute difference between binary files
Added psl-1983/nmode/reader.sl version [3262adc69b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Reader.SL - NMODE Command Reader % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 3-Dec-82 Alan Snyder % GC calls cleanup-buffers before reclaiming. % 21-Dec-82 Alan Snyder % Use generic arithmetic on processor times (overflowed on 9836). % Add declaration for NMODE-TIMER-OUTPUT-STREAM. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects extended-char fast-int pathnames)) % External variables used here: (fluid '(nmode-allow-refresh-breakout)) % Global variables defined here: (fluid '( nmode-command-argument % Numeric C-U argument (default: 1) nmode-command-argument-given % T if C-U used for this command nmode-command-number-given % T if an explicit number given nmode-previous-command-killed % T if previous command KILLED text nmode-current-command % Current command (char or list) nmode-previous-command % Previous command (char or list) nmode-current-command-function % Function for current command nmode-previous-command-function% Function for previous command nmode-autoarg-mode % T => digits start command argument nmode-temporary-autoarg % T while reading command argument nmode-command-killed % Commands set this if they KILL text nmode-command-set-argument % Commands like C-U set this nmode-reader-exit-flag % Internal flag: causes reader to exit nmode-gc-check-level % number of free words causing GC nmode-timing? % T => time command execution nmode-display-times? % T => display times after each command nmode-timer-output-stream % optional stream to write times to % The following variables are set when timing is on: nmode-timed-step-count % number of reader steps timed nmode-refresh-time % time used for last refresh nmode-read-time % time used for last read command nmode-command-execution-time % time to execute last command nmode-total-refresh-time % sum of nmode-refresh-time nmode-total-read-time % sum of nmode-read-time nmode-total-command-execution-time% sum of nmode-command-execution-time nmode-gc-start-count % GCKnt when timing starts nmode-gc-reported-count % GCKnt when last reported nmode-total-cons-count % total words allocated (except GC) )) (setf nmode-timing? NIL) (setf nmode-display-times? NIL) (declare-flavor output-stream nmode-timer-output-stream) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(nmode-exit-on-abort)) (de nmode-reader (nmode-exit-on-abort) % Execute refresh/read/dispatch loop. The loop can terminate in the following % ways: (1) A command can cause the reader to exit by either calling % EXIT-NMODE-READER or by throwing 'EXIT-NMODE. In this case, the reader % terminates and returns NIL. (2) A command can throw 'ABORT. If % NMODE-EXIT-ON-ABORT is non-NIL, then the reader will terminate and return % 'ABORT; otherwise, it will ring the bell and continue. (3) A command can % throw '$BREAK$ or 'RESET; this throw is relayed. Other errors and throws % within a command are caught, messages are printed, and execution resumes. (let* ((nmode-reader-exit-flag NIL) % FLUID variable (nmode-previous-command-killed NIL) % FLUID variable (nmode-command-killed NIL) % FLUID variable (nmode-command-argument 1) % FLUID variable (nmode-command-argument-given NIL) % FLUID variable (nmode-command-number-given NIL) % FLUID variable (nmode-current-command NIL) % FLUID variable (nmode-previous-command NIL) % FLUID variable (nmode-current-command-function NIL) % FLUID variable (nmode-previous-command-function NIL) % FLUID variable (nmode-command-set-argument NIL) % FLUID variable (nmode-timing? NIL) % FLUID variable (*MsgP T) % FLUID variable (*BackTrace T) % FLUID variable ) (while (not nmode-reader-exit-flag) (catch-all #'(lambda (tag result) (cond ((eq tag 'abort) (if nmode-exit-on-abort (exit 'abort) (Ding))) ((or (eq tag '$Break$) (eq tag 'RESET)) (nmode-select-buffer-channel) (throw tag NIL)) ((eq tag '$error$) (Ding)) ((eq tag 'exit-nmode) (exit NIL)) (t (Printf "*****Unhandled THROW of %p" tag) (Ding)) )) (nmode-reader-step) )))) (de nmode-reader-step () (cond ((not nmode-timing?) (nmode-refresh) (nmode-gc-check) (nmode-read-command) (nmode-execute-current-command) ) (t (nmode-timed-reader-step)) )) (de nmode-read-command () % Read one command and set the appropriate global variables. (when (not nmode-command-set-argument) % starting a new command (setf nmode-previous-command-killed nmode-command-killed) (setf nmode-previous-command nmode-current-command) (setf nmode-previous-command-function nmode-current-command-function) (setf nmode-command-argument 1) (setf nmode-command-argument-given NIL) (setf nmode-command-number-given NIL) (setf nmode-command-killed NIL) (setf nmode-temporary-autoarg NIL) (nmode-set-delayed-prompt "") ) (setf nmode-current-command (input-command)) (setf nmode-current-command-function (dispatch-table-lookup nmode-current-command)) ) (de nmode-execute-current-command () (setf nmode-command-set-argument NIL) (if nmode-current-command-function (apply nmode-current-command-function NIL) (nmode-undefined-command nmode-current-command) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Timing Support %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de start-timing-command () (let ((fn (prompt-for-file-name "Timing output to file:" (namestring (make-pathname 'name "timing" 'type "txt")) ))) (cond ((not (setf nmode-timer-output-stream (attempt-to-open-output fn))) (write-prompt "Unable to open file.") (Ding) ) (t (reclaim) (nmode-start-timing)) ))) (de stop-timing-command () (cond (nmode-timing? (nmode-stop-timing) (if nmode-timer-output-stream (=> nmode-timer-output-stream close)) (setf nmode-timer-output-stream nil) ))) (de nmode-start-timing () (setf nmode-timing? T) (setf nmode-total-refresh-time 0) (setf nmode-total-read-time 0) (setf nmode-total-command-execution-time 0) (setf nmode-timed-step-count 0) (setf nmode-gc-start-count GCknt*) (setf nmode-gc-reported-count nmode-gc-start-count) (setf nmode-total-cons-count 0) ) (de nmode-stop-timing () (cond (nmode-timing? (setf nmode-timing? NIL) (nmode-timing-message (BldMsg "Total times: Refresh=%d Read=%d Execute=%d Cons=%d #GC=%d" nmode-total-refresh-time nmode-total-read-time nmode-total-command-execution-time nmode-total-cons-count (- GCknt* nmode-gc-start-count) )) (nmode-timing-message (BldMsg "Number of reader steps: %d" nmode-timed-step-count)) (if (> nmode-timed-step-count 0) (nmode-timing-message (BldMsg "Averages: Refresh=%d Read=%d Execute=%d Cons=%d" (/ nmode-total-refresh-time nmode-timed-step-count) (/ nmode-total-read-time nmode-timed-step-count) (/ nmode-total-command-execution-time nmode-timed-step-count) (/ nmode-total-cons-count nmode-timed-step-count) )))))) (de nmode-timed-reader-step () (let ((heapx (GtHeap NIL)) gc-happened ) (nmode-timed-refresh) (nmode-gc-check) (nmode-timed-read-command) (nmode-timed-execute-current-command) (setf heapx (- heapx (GtHeap NIL))) (setf gc-happened (> GCknt* nmode-gc-reported-count)) (setf nmode-gc-reported-count GCknt*) (cond ((not gc-happened) (setf nmode-timed-step-count (+ nmode-timed-step-count 1)) (setf nmode-total-refresh-time (+ nmode-total-refresh-time nmode-refresh-time)) (setf nmode-total-read-time (+ nmode-total-read-time nmode-read-time)) (setf nmode-total-command-execution-time (+ nmode-total-command-execution-time nmode-command-execution-time)) (setf nmode-total-cons-count (+ nmode-total-cons-count heapx)) )) (nmode-timing-message (BldMsg "%w Refresh=%d Read=%d Execute=%d %w" (string-pad-left (command-name nmode-current-command) 20) nmode-refresh-time nmode-read-time nmode-command-execution-time (if gc-happened (BldMsg "#GC=%d" nmode-gc-reported-count) (BldMsg "Cons=%d" heapx) ) )))) (de nmode-timed-refresh () (let ((ptime (processor-time))) (nmode-refresh) (setf nmode-refresh-time (difference (processor-time) ptime)) )) (de nmode-timed-read-command () (let ((ptime (processor-time))) (nmode-read-command) (setf nmode-read-time (difference (processor-time) ptime)) )) (de nmode-timed-execute-current-command () (let ((ptime (processor-time))) (nmode-execute-current-command) (setf nmode-command-execution-time (difference (processor-time) ptime)) )) (de nmode-timing-message (s) (cond (nmode-display-times? (write-message s)) (nmode-timer-output-stream (=> nmode-timer-output-stream putl s)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Garbage Collection %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-gc-check () % Check to see if a garbage collection is needed (because we are low on % space). If so, display a message and invoke the garbage collector. (If a % garbage collection happens "by itself", no message will be displayed.) (if (not nmode-gc-check-level) (setf nmode-gc-check-level 1000)) (when (< (GtHeap NIL) nmode-gc-check-level) (nmode-gc) )) (de nmode-gc () % Perform garbage collection while displaying a message. (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable (write-prompt "Garbage Collecting!") (cleanup-buffers) (reclaim) (write-prompt (BldMsg "Garbage Collection Done: Free Space = %d words" (GtHeap NIL))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Miscellaneous Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de exit-nmode-reader () % Set flag to cause exit from NMODE reader loop. (setf nmode-reader-exit-flag T) ) (de nmode-undefined-command (command) (nmode-error (BldMsg "Undefined command: %w" (command-name command))) ) (de nmode-error (s) (let ((nmode-allow-refresh-breakout NIL)) % FLUID variable (write-prompt s) (Ding) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Numeric Argument Command Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de argument-digit () % This procedure must be attached only to extended characters whose base % characters are digits. (let* ((command nmode-current-command) (base-ch (if (FixP command) (X-base command))) (n (if (and base-ch (digitp base-ch)) (char-digit base-ch))) ) (if (null n) (Ding) (argument-digit-number n) ))) (de negative-argument () (if (not nmode-command-number-given) % make "C-U -" do the right thing (cond ((> nmode-command-argument 0) (setf nmode-command-argument 1)) ((< nmode-command-argument 0) (setf nmode-command-argument -1)) )) (setf nmode-command-argument (- nmode-command-argument)) (setf nmode-command-argument-given T) (setf nmode-command-set-argument T) (nmode-set-delayed-prompt (cond ((= nmode-command-argument 1) "C-U ") ((= nmode-command-argument -1) "C-U -") (t (BldMsg "C-U %d" nmode-command-argument)) ))) (de universal-argument () (setf nmode-command-argument (* nmode-command-argument 4)) (setf nmode-command-argument-given T) (setf nmode-command-set-argument T) (setf nmode-temporary-autoarg T) (cond (nmode-command-number-given (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument)) ) (t (nmode-append-separated-prompt "C-U")) )) (de argument-or-insert-command () % This command interprets digits and leading hyphens as argument % prefix characters if NMODE-AUTOARG-MODE or NMODE-TEMPORARY-AUTOARG % is non-NIL; otherwise, it self-inserts. (let ((base-ch (if (FixP nmode-current-command) (X-base nmode-current-command))) ) (cond ((and (digitp base-ch) (or nmode-temporary-autoarg nmode-autoarg-mode)) (argument-digit (char-digit base-ch))) ((and (= base-ch #/-) (or nmode-temporary-autoarg nmode-autoarg-mode) (not nmode-command-number-given)) (negative-argument)) (t (insert-self-command)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Numeric Argument Support Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de argument-digit-number (n) (cond (nmode-command-number-given % this is not the first digit (setf nmode-command-argument (+ (* nmode-command-argument 10) (if (>= nmode-command-argument 0) n (- n)))) ) (t % this is the first digit (if (> nmode-command-argument 0) (setf nmode-command-argument n) (setf nmode-command-argument (- n)) ))) (nmode-set-delayed-prompt (BldMsg "C-U %d" nmode-command-argument)) (setf nmode-command-argument-given T) (setf nmode-command-number-given T) (setf nmode-command-set-argument T) ) % Convert from character code to digit. (de char-digit (c) (cond ((digitp c) (difference (char-int c) (char-int #/0))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-timer-output-stream) |
Added psl-1983/nmode/rec.b version [b38df1e37d].
cannot compute difference between binary files
Added psl-1983/nmode/rec.sl version [c2bf6f8680].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % REC.SL - Recursive Editing Functioons % % Author: Jeffrey Soreff % Hewlett-Packard/CRC % Date: 24 Jan 1983 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load extended-char fast-int objects)) % External variables used here: (fluid '(recurse-mode nmode-current-buffer)) % Global variables defined here: (fluid '(recurse-query recurse-query-answered)) % Recurse-Query will be T if the user leaves a recursive editing level % with a "Y". It will be nil if the user leaves with an "N". In either % of those cases recurse-query-answered will be set to T. If the user % leaves the recursive editing level by some other means then % recurse-query-answered will be NIL. (de recursive-edit-y-or-n (buffer outer-message inner-message) % This function allows a user to make a yes or no decision about % some buffer, either before looking at it with the editor or while % editing within it. Before starting to edit the user is prompted % with the outer message. This function takes care of interpreting a % Y or N prior to editing and of providing a prompt (the outer % message) before editing. The call to recursive-edit takes care of % the prompt during editing and of interpreting a Y or N during % editing. This function returns a boolean value. (prog1 (while t (write-message outer-message) (let ((ch (x-char-upcase (input-extended-character)))) (when (= ch (x-char Y)) (exit T)) (when (= ch (x-char N)) (exit NIL)) (when (= ch (x-char C-R)) (recursive-edit buffer recurse-mode inner-message)) (when recurse-query-answered (exit recurse-query)))) (write-message ""))) (de recursive-edit (new-buffer mode inner-message) % This function triggers the recursive editing loop, switching % buffers, setting the new buffer temporarily into a user selected % mode, and returning the buffer and mode to their old values after % the editing. This function returns a value only through global % variables, particularly recurse-query and recurse-query-answered. (let ((old-buffer nmode-current-buffer) (old-mode (=> new-buffer mode))) (=> new-buffer set-mode mode) (buffer-select new-buffer) (let ((old-message (write-message inner-message))) (setf recurse-query-answered NIL) (nmode-reader NIL) (write-message old-message)) (=> new-buffer set-mode old-mode) (buffer-select old-buffer))) % Note: resets nmode-current-buffer (de affirmative-exit () % Returns T from a recursive editing mode, usually bound to Y. (setf recurse-query T) (setf recurse-query-answered T) (exit-nmode-reader)) (de negative-exit () % Returns NIL from a recursive editing mode, usually bound to N. (setf recurse-query NIL) (setf recurse-query-answered T) (exit-nmode-reader)) |
Added psl-1983/nmode/screen-layout.b version [73fd1b0150].
cannot compute difference between binary files
Added psl-1983/nmode/screen-layout.sl version [5a6e9e4fc5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Screen-Layout.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 19 August 1982 % Revised: 18 February 1983 % % This file contains functions that manage the screen layout for NMODE. % % 18-Feb-83 Alan Snyder % Add new function: find-buffer-in-exposed-windows. % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 7-Feb-83 Alan Snyder % Revise handling of refresh breakout to allow refresh-one-window to work. % 31-Jan-83 Alan Snyder % Revise for new interpretation of argument to buffer-window$set-size. % Make input window an unlabeled buffer-window. % 27-Jan-83 Alan Snyder % Added (optional) softkey label screen. % 7-Jan-83 Alan Snyder % Change ENTER-RAW-MODE to not touch the other screen unless we are in % two-screen mode. % 6-Jan-83 Alan Snyder % Change NMODE-SELECT-MAJOR-WINDOW to also deexpose input window. % 30-Dec-82 Alan Snyder % Added two-screen mode. Minor change to NMODE-SELECT-WINDOW to make % things more graceful when using direct writing. % 20-Dec-82 Alan Snyder % Added declarations and made other small changes to improve efficiency by % reducing the amount of run-time method lookup. Fixed efficiency bug in % NMODE-NEW-TERMINAL: it failed to de-expose old screens and windows. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char)) % External variables used here: (fluid '( nmode-command-argument-given nmode-command-argument browser-split-screen )) % Options: (fluid '( nmode-allow-refresh-breakout % Abort refresh if user types something nmode-normal-enhancement % Display enhancement for normal text nmode-inverse-enhancement % Display enhancement for "inverse video" text )) % Global variables defined here: (fluid '( nmode-current-buffer % buffer that commands operate on nmode-current-window % window displaying current buffer nmode-major-window % the user's idea of nmode-current-window nmode-layout-mode % either 1 or 2 nmode-two-screens? % T => each window has its own screen nmode-input-window % window used for string input nmode-message-screen % screen displaying NMODE "message" nmode-prompt-screen % screen displaying NMODE "prompt" nmode-main-buffer % buffer "MAIN" nmode-output-buffer % buffer "OUTPUT" (used for PSL output) nmode-input-buffer % internal buffer used for string input nmode-softkey-label-screen % screen displaying softkey labels (or NIL) nmode-terminal % the terminal object nmode-physical-screen % the physical screen object nmode-screen % the shared screen object nmode-other-terminal % the other terminal object (two-screen mode) nmode-other-physical-screen % the other physical screen object nmode-other-screen % the other shared screen object )) % Internal static variables: (fluid '( nmode-top-window % the top or full major window nmode-bottom-window % the bottom major window full-refresh-needed % next refresh should clear the screen first nmode-breakout-occurred? % last refresh was interrupted nmode-total-lines % total number of screen lines for window(s) nmode-top-lines % number of screen lines for top window nmode-inverse-video? % Display using "inverse video" nmode-blank-screen % blank screen used to clear the display )) (declare-flavor buffer-window nmode-current-window nmode-top-window nmode-bottom-window nmode-input-window) (declare-flavor virtual-screen nmode-blank-screen) (declare-flavor shared-physical-screen nmode-screen nmode-other-screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Initialization Function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-initialize-screen-layout () % This function is called as part of NMODE initialization, which occurs % before NMODE is saved. (setf nmode-allow-refresh-breakout T) (setf nmode-normal-enhancement (dc-make-enhancement-mask)) (setf nmode-inverse-enhancement (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY)) (setf nmode-inverse-video? NIL) (nmode-default-terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions for changing the screen layout: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-1-window () (nmode-expand-top-window) ) (de nmode-expand-top-window () % This function does nothing if already in 1-window mode. % Otherwise: expands the top window to fill the screen; the top window % becomes current. (when (not (= nmode-layout-mode 1)) (nmode-select-window nmode-top-window) (=> nmode-bottom-window deexpose) (setf nmode-layout-mode 1) (nmode-set-window-sizes) )) (de nmode-expand-bottom-window () % This function does nothing if already in 1-window mode. % Otherwise: expands the bottom window to fill the screen; the bottom % window becomes current. (when (not (= nmode-layout-mode 1)) (psetf nmode-top-window nmode-bottom-window nmode-bottom-window nmode-top-window) (nmode-expand-top-window) )) (de nmode-2-windows () % This function does nothing if already in 2-window mode. % Otherwise: shrinks the top window and exposes the bottom window. (cond ((not (= nmode-layout-mode 2)) (setf nmode-layout-mode 2) (nmode-set-window-sizes) ))) (de nmode-set-window-position (p) (selectq p (FULL (nmode-1-window)) (TOP (nmode-2-windows) (nmode-select-window nmode-top-window)) (BOTTOM (nmode-2-windows) (nmode-select-window nmode-bottom-window)) )) (de nmode-exchange-windows () % Exchanges the current window with the other window, which becomes current. % In two window mode, the windows swap physical positions. (let ((w (nmode-other-window))) (psetf nmode-top-window nmode-bottom-window nmode-bottom-window nmode-top-window) (nmode-set-window-sizes) (nmode-select-window w) )) (de nmode-grow-window (n) % Increase (decrease if n<0) the size of the current window by N lines. % Does nothing and returns NIL if not in 2-window mode. (selectq (nmode-window-position) (FULL NIL ) (TOP (setf nmode-top-lines (+ nmode-top-lines n)) (nmode-set-window-sizes) T ) (BOTTOM (setf nmode-top-lines (- nmode-top-lines n)) (nmode-set-window-sizes) T ))) (de nmode-expose-output-buffer (b) % Buffer B is being used as an output channel. It is not currently being % displayed. Cause it to be displayed (in the "other window", if we % are already in 2-window mode, in the bottom window otherwise). (nmode-2-windows) (window-select-buffer (nmode-other-window) b) ) (de nmode-normal-video () % Cause the display to use "normal" video polarity. (when nmode-inverse-video? (setf nmode-inverse-video? NIL) (nmode-establish-video-polarity) )) (de nmode-inverse-video () % Cause the display to use "inverse" video polarity. (when (not nmode-inverse-video?) (setf nmode-inverse-video? T) (nmode-establish-video-polarity) )) (de nmode-invert-video () % Toggle between normal and inverse video. (setf nmode-inverse-video? (not nmode-inverse-video?)) (nmode-establish-video-polarity) ) (de nmode-use-two-screens () % If two screens are available, use them both. (when (and nmode-other-screen (not nmode-two-screens?)) (when (not (=> nmode-other-terminal raw-mode)) (=> nmode-other-terminal enter-raw-mode) (setf full-refresh-needed t) ) (setf nmode-two-screens? T) (setf browser-split-screen T) (setf nmode-layout-mode 2) (nmode-set-window-sizes) )) (de nmode-use-one-screen () % Use only the main screen. (when nmode-two-screens? (setf nmode-two-screens? NIL) (nmode-set-window-sizes) (if nmode-other-screen (=> nmode-other-screen refresh)) % clear it )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Screen Layout Commands: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de one-window-command () % The "C-X 1" command. Return to one window mode. (when (not (= nmode-layout-mode 1)) (if nmode-command-argument-given (nmode-expand-bottom-window) (nmode-expand-top-window) ))) (de two-windows-command () % The "C-X 2" command. The bottom window is selected. (when (not (= nmode-layout-mode 2)) (nmode-2-windows) (if nmode-command-argument-given (window-copy-buffer nmode-top-window nmode-bottom-window)) (nmode-switch-windows) )) (de view-two-windows-command () % The "C-X 3" command. The top window remains selected. (when (not (= nmode-layout-mode 2)) (nmode-2-windows) (if nmode-command-argument-given (window-copy-buffer nmode-top-window nmode-bottom-window)) )) (de grow-window-command () (if (not (nmode-grow-window nmode-command-argument)) (nmode-error "Not in 2-window mode!") )) (de other-window-command () (let ((old-buffer nmode-current-buffer)) (nmode-switch-windows) (if nmode-command-argument-given (buffer-select old-buffer)) )) (de exchange-windows-command () (selectq nmode-layout-mode (1 (Ding)) (2 (nmode-exchange-windows)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-select-window (window) % Expose the specified window and make it the "current" window. % Its buffer becomes the "current" buffer. This is the only function that % should set the variable "NMODE-CURRENT-WINDOW". (when (not (eq window nmode-current-window)) (if nmode-current-window (=> nmode-current-window deselect)) (when (not (eq window nmode-input-window)) (setf nmode-major-window window) (when (not (eq nmode-current-window nmode-input-window)) (reset-message) )) (setf nmode-current-window window) (=> window expose) (=> window select) (setf nmode-current-buffer (=> window buffer)) (nmode-establish-current-mode) )) (de nmode-switch-windows () % Select the "other" window. (selectq nmode-layout-mode (2 (nmode-select-window (nmode-other-window))) (1 (nmode-exchange-windows)) )) (de nmode-select-major-window () % This function is used for possible error recovery. It ensures that the % current window is one of the exposed major windows (not, for example, the % INPUT window) and that the INPUT window is deexposed. (if (not (or (eq nmode-current-window nmode-top-window) (eq nmode-current-window nmode-bottom-window) )) (nmode-select-window nmode-top-window) ) (=> nmode-input-window deexpose) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Screen Information Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-window-position () (cond ((= nmode-layout-mode 1) 'FULL) ((eq nmode-current-window nmode-top-window) 'TOP) (t 'BOTTOM) )) (de nmode-other-window () % Return the "other" window. (if (eq nmode-current-window nmode-top-window) nmode-bottom-window nmode-top-window )) (de find-buffer-in-windows (b) % Return a list containing the windows displaying the specified buffer. % The windows may or may not be displayed. (for (in w (list nmode-bottom-window nmode-top-window)) % Put bottom window first in this list so that it will be % the one that is automatically adjusted on output if the % output buffer is being displayed by both windows. (when (eq b (=> w buffer))) (collect w)) ) (de find-buffer-in-exposed-windows (b) % Return a list containing the exposed windows displaying the specified % buffer. (for (in w (find-buffer-in-windows b)) (when (=> w exposed?)) (collect w)) ) (de buffer-is-displayed? (b) % Return T if the specified buffer is being displayed by an active window. (not (for (in w (nmode-active-windows)) (never (eq b (=> w buffer))) ))) (de nmode-active-windows () (selectq nmode-layout-mode (1 (list nmode-top-window)) (2 (list nmode-top-window nmode-bottom-window)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Typeout Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-begin-typeout () % Call this function before doing typeout using the standard output channel. % Someday this will do something clever, but for now it merely clears the % screen. (nmode-clear-screen) ) (de nmode-end-typeout () % Call this function after doing typeout using the standard output channel. % Someday this will do something clever, but for now it merely waits for % the user to type a character. (pause-until-terminal-input) ) (de nmode-clear-screen () % This is somewhat of a hack to clear the screen for normal typeout. The % next time a refresh is done, a full refresh will be done automatically. (=> nmode-blank-screen expose) (=> nmode-screen full-refresh NIL) (setf full-refresh-needed t) ) (de Enter-Raw-Mode () % Use this function to enter "raw mode", in which terminal input is not % echoed and special terminal keys are enabled. The next REFRESH will % automatically be a "full" refresh. (when (not (=> nmode-terminal raw-mode)) (=> nmode-terminal enter-raw-mode) (setf full-refresh-needed t) ) (when (and nmode-two-screens? nmode-other-terminal (not (=> nmode-other-terminal raw-mode))) (=> nmode-other-terminal enter-raw-mode) (setf full-refresh-needed t) ) ) (de leave-raw-mode () % Use this function to leave "raw mode", i.e. turn on echoing of terminal % input and disable any special terminal keys. The cursor is positioned % on the last line of the screen, which is cleared. (when (=> nmode-terminal raw-mode) (=> nmode-terminal move-cursor (=> nmode-terminal maxrow) 0) (=> nmode-terminal clear-line) (=> nmode-terminal leave-raw-mode) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Refresh functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-refresh () % This function refreshes the screen. It first ensures that all exposed % NMODE windows update their corresponding virtual screens. Then, it % asks the window package to update the display. A "full refresh" will % be done if some prior operation has indicated the need for one. (cond (full-refresh-needed (nmode-full-refresh)) (t (nmode-refresh-windows) (when (not nmode-breakout-occurred?) (=> nmode-screen refresh nmode-allow-refresh-breakout) (if (and nmode-other-screen nmode-two-screens?) (=> nmode-other-screen refresh nmode-allow-refresh-breakout)) )))) (de nmode-full-refresh () % This function refreshes the screen after first clearing the terminal % display. It it used when the state of the terminal display is in doubt. (nmode-refresh-windows) (when (not (setf full-refresh-needed nmode-breakout-occurred?)) (=> nmode-screen full-refresh nil) (if (and nmode-other-screen nmode-two-screens?) (=> nmode-other-screen full-refresh nil)) )) (de nmode-refresh-one-window (w) % This function refreshes the display, but only updates the virtual screen % corresponding to the specified window. (cond (full-refresh-needed (nmode-full-refresh)) (nmode-breakout-occurred? (nmode-refresh)) (t (if (eq (=> nmode-screen owner 0 0) nmode-blank-screen) % hack! (=> nmode-blank-screen deexpose)) (nmode-adjust-window w) (nmode-refresh-window w) (nmode-refresh-screen (=> (=> w screen) screen)) ))) (de nmode-refresh-virtual-screen (s) % This function refreshes the shared screen containing the specified % virtual screen. (cond (full-refresh-needed (nmode-full-refresh)) (nmode-breakout-occurred? (nmode-refresh)) (t (if (eq (=> nmode-screen owner 0 0) nmode-blank-screen) % hack! (=> nmode-blank-screen deexpose)) (nmode-refresh-screen (=> s screen)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-refresh-windows () % Cause all windows to update their corresponding virtual screens. The % variable nmode-breakout-occurred? is set to T if the refresh is % interrupted by user input. (setf nmode-breakout-occurred? NIL) (=> nmode-blank-screen deexpose) % hack! (=> nmode-current-window adjust-window) (nmode-refresh-window nmode-top-window) (nmode-refresh-window nmode-bottom-window) (nmode-refresh-window nmode-input-window) ) (de nmode-refresh-window (w) % Refresh only if window is exposed and no breakout has occurred. % Update the flag nmode-breakout-occurred? (if (not nmode-breakout-occurred?) (if (eq (object-type w) 'buffer-window) % hack for efficiency (if (buffer-window$exposed? w) (setf nmode-breakout-occurred? (not (buffer-window$refresh w nmode-allow-refresh-breakout)))) (if (=> w exposed?) (setf nmode-breakout-occurred? (not (=> w refresh nmode-allow-refresh-breakout)))) ))) (de nmode-refresh-screen (s) % Refresh the specified shared-screen. (if (eq (object-type s) 'shared-physical-screen) % hack for efficiency (shared-physical-screen$refresh s nmode-allow-refresh-breakout) (=> s refresh nmode-allow-refresh-breakout) )) (de nmode-establish-video-polarity () (let ((mask (if nmode-inverse-video? nmode-inverse-enhancement nmode-normal-enhancement ))) (=> nmode-top-window set-text-enhancement mask) (=> nmode-bottom-window set-text-enhancement mask) (=> nmode-input-window set-text-enhancement mask) (=> nmode-prompt-screen set-default-enhancement mask) (=> nmode-message-screen set-default-enhancement mask) (=> nmode-blank-screen set-default-enhancement mask) (=> nmode-prompt-screen clear) (rewrite-message) (=> nmode-blank-screen clear) )) (de nmode-new-terminal () % This function should be called when either NMODE-TERMINAL or % NMODE-OTHER-TERMINAL changes. (setf full-refresh-needed T) (setf nmode-physical-screen (create-physical-screen nmode-terminal)) (setf nmode-other-physical-screen (if nmode-other-terminal (create-physical-screen nmode-other-terminal))) (if nmode-screen (=> nmode-screen set-screen nmode-physical-screen) (setf nmode-screen (create-shared-physical-screen nmode-physical-screen)) ) (nmode-setup-softkey-label-screen nmode-screen) (if nmode-other-terminal (if nmode-other-screen (=> nmode-other-screen set-screen nmode-other-physical-screen) (setf nmode-other-screen (create-shared-physical-screen nmode-other-physical-screen)) ) (setf nmode-other-screen nil) ) (let ((height (=> nmode-screen height)) (width (=> nmode-screen width)) ) (when nmode-softkey-label-screen (setf height (- height (=> nmode-softkey-label-screen height))) ) (setf nmode-total-lines (- height 2)) % all but message and prompt lines (setf nmode-top-lines (/ nmode-total-lines 2)) % half for the top window % Throw away the old windows and screens! (if nmode-blank-screen (=> nmode-blank-screen deexpose)) (if nmode-message-screen (=> nmode-message-screen deexpose)) (if nmode-prompt-screen (=> nmode-prompt-screen deexpose)) (if nmode-input-window (=> nmode-input-window deexpose)) % Create new windows and screens: (setf nmode-blank-screen % hack to implement clear screen (nmode-create-screen height width 0 0)) (setf nmode-message-screen (nmode-create-screen 1 width (- height 2) 0)) (setf nmode-prompt-screen (nmode-create-screen 1 width (- height 1) 0)) (setf nmode-input-window (create-unlabeled-buffer-window nmode-input-buffer (nmode-create-screen 1 width (- height 1) 0))) (nmode-fixup-windows) (setf nmode-layout-mode (if nmode-two-screens? 2 1)) (=> nmode-message-screen expose) (=> nmode-prompt-screen expose) (nmode-select-window nmode-top-window) (nmode-establish-video-polarity) (nmode-set-window-sizes) )) (de nmode-create-screen (height width row-origin column-origin) (make-instance 'virtual-screen 'screen nmode-screen 'height height 'width width 'row-origin row-origin 'column-origin column-origin) ) (de nmode-set-window-sizes () % This function ensures that the top and bottom windows are properly % set up and exposed. (cond ((< nmode-top-lines 2) (setf nmode-top-lines 2)) ((> nmode-top-lines (- nmode-total-lines 2)) (setf nmode-top-lines (- nmode-total-lines 2))) ) (nmode-fixup-windows) (cond (nmode-two-screens? (nmode-position-window nmode-top-window nmode-total-lines 0) (nmode-position-window nmode-bottom-window nmode-total-lines 0) (nmode-expose-both-windows) ) ((= nmode-layout-mode 1) (nmode-position-window nmode-top-window nmode-total-lines 0) (nmode-position-window nmode-bottom-window nmode-total-lines 0) (=> nmode-top-window expose) ) ((= nmode-layout-mode 2) (nmode-position-window nmode-top-window nmode-top-lines 0) (nmode-position-window nmode-bottom-window (- nmode-total-lines nmode-top-lines) nmode-top-lines ) (nmode-expose-both-windows) ))) (de nmode-position-window (w height origin) (if (eq (=> (=> w screen) screen) nmode-other-screen) (setf height (=> nmode-other-screen height))) (=> w set-size height (=> w width)) (let ((s (=> w screen))) (=> s set-origin origin 0)) ) (de nmode-expose-both-windows () (cond ((eq nmode-top-window nmode-current-window) (=> nmode-bottom-window expose) (=> nmode-top-window expose) ) (t (=> nmode-top-window expose) (=> nmode-bottom-window expose) ))) (de nmode-fixup-windows () % Ensure that the two buffer-windows exist and are attached to the proper % shared-screens. (let ((top-screen (if (and nmode-two-screens? nmode-other-screen) nmode-other-screen nmode-screen )) (bottom-screen nmode-screen) ) (if (or (not nmode-top-window) (neq (=> (=> nmode-top-window screen) screen) top-screen) ) (nmode-create-top-window) ) (if (or (not nmode-bottom-window) (neq (=> (=> nmode-bottom-window screen) screen) bottom-screen) ) (nmode-create-bottom-window) ) )) (de nmode-create-top-window () (let ((vs (if (and nmode-two-screens? nmode-other-screen) (make-instance 'virtual-screen 'screen nmode-other-screen 'height (=> nmode-other-screen height) 'width (=> nmode-other-screen width) 'row-origin 0 ) (make-instance 'virtual-screen 'screen nmode-screen 'height nmode-total-lines 'width (=> nmode-screen width) 'row-origin 0 ))) ) (if nmode-top-window (=> nmode-top-window set-screen vs) (setf nmode-top-window (create-buffer-window nmode-main-buffer vs)) ))) (de nmode-create-bottom-window () (let ((vs (make-instance 'virtual-screen 'screen nmode-screen 'height nmode-total-lines 'width (=> nmode-screen width) 'row-origin 0 )) ) (if nmode-bottom-window (=> nmode-bottom-window set-screen vs) (setf nmode-bottom-window (create-buffer-window nmode-output-buffer vs)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-top-window nmode-bottom-window nmode-input-window nmode-current-window nmode-blank-screen nmode-screen) |
Added psl-1983/nmode/search.b version [ce88a29484].
cannot compute difference between binary files
Added psl-1983/nmode/search.sl version [31ef3e2d33].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Search.SL - Search utilities % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 23 August 1982 % % Adapted from Will Galway's EMODE % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % These routines to implement minimal string searches for EMODE. Searches % are non-incremental, limited to single line patterns, and always ignore % case. (CompileTime (load objects fast-strings fast-int)) (fluid '(last-search-string)) (setf last-search-string NIL) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de forward-string-search () % Invoked from keyboard, search forward from point for string, leave % "point" unchanged if not found. (let ((strng (prompt-for-string "Forward search: " last-search-string))) (setf last-search-string strng) (if (buffer-search strng 1) (for (from i 0 (string-upper-bound strng)) (do (move-forward)) ) % else (write-prompt "Search failed.") (Ding) ))) (de reverse-string-search () % Invoked from keyboard, search backwards from point for string, leave % "point unchanged if not found. (let ((strng (prompt-for-string "Reverse search: " last-search-string))) (setf last-search-string strng) (move-backward) (if (not (buffer-search strng -1)) (progn (move-forward) (write-prompt "Search failed.") (Ding))) )) (de buffer-search (pattern dir) % Search in buffer for the specified pattern. Dir should be +1 for forward, % -1 for backward. If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (setf pattern (string-upcase pattern)) (if (> dir 0) (forward-search pattern) (reverse-search pattern) )) (de forward-search (pattern) % Search forward in the current buffer for the specified pattern. % If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (let ((line-pos (current-line-pos)) (char-pos (current-char-pos)) (limit (current-buffer-size)) found-pos ) (while (and (< line-pos limit) (not (setf found-pos (forward-search-on-line line-pos char-pos pattern))) ) (setf line-pos (+ line-pos 1)) (setf char-pos NIL) ) (if found-pos (progn (current-buffer-goto line-pos found-pos) T))) )) (de forward-search-on-line (line-pos char-pos pattern) % Search on the current line for the specified string. If CHAR-POS is % non-NIL, then begin at that location, otherwise begin at the beginning of % the line. We look to see if the string lies to the right of the current % search location. If we find it, we return the CHAR-POS of the first % matching character. Otherwise, we return NIL. (let* ((line (current-buffer-fetch line-pos)) (pattern-length (string-length pattern)) (limit (- (string-length line) pattern-length)) ) (if (null char-pos) (setf char-pos 0)) (while (<= char-pos limit) (if (pattern-matches-in-line pattern line char-pos) (exit char-pos) ) (setf char-pos (+ char-pos 1)) ))) (de reverse-search (pattern) % Search backward in the current buffer for the specified pattern. % If the pattern is found, the buffer cursor will be set to % the beginning of the matching string and T will be returned. Otherwise, % the buffer cursor will remain unchanged and NIL will be returned. (let ((line-pos (current-line-pos)) (char-pos (current-char-pos)) found-pos ) (while (and (>= line-pos 0) (not (setf found-pos (reverse-search-on-line line-pos char-pos pattern))) ) (setf line-pos (- line-pos 1)) (setf char-pos NIL) ) (if found-pos (progn (current-buffer-goto line-pos found-pos) T))) )) (de reverse-search-on-line (line-pos char-pos pattern) % Search on the current line for the specified string. If CHAR-POS is % non-NIL, then begin at that location, otherwise begin at the end of % the line. We look to see if the string lies to the right of the current % search location. If we find it, we return the CHAR-POS of the first % matching character. Otherwise, we return NIL. (let* ((line (current-buffer-fetch line-pos)) (pattern-length (string-length pattern)) (limit (- (string-length line) pattern-length)) ) (if (or (null char-pos) (> char-pos limit)) (setf char-pos limit)) (while (>= char-pos 0) (if (pattern-matches-in-line pattern line char-pos) (exit char-pos) ) (setf char-pos (- char-pos 1)) ))) (de pattern-matches-in-line (pattern line pos) % Return T if PATTERN occurs as substring of LINE, starting at POS. % Ignore case differences. No bounds checking is performed on LINE. (let ((i 0) (patlimit (string-upper-bound pattern))) (while (and (<= i patlimit) (= (string-fetch pattern i) (char-upcase (string-fetch line (+ i pos)))) ) (setf i (+ i 1)) ) (> i patlimit) % T if all chars matched, NIL otherwise )) |
Added psl-1983/nmode/set-terminal-20.b version [98f67dfb48].
cannot compute difference between binary files
Added psl-1983/nmode/set-terminal-20.sl version [27da7709e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Set-Terminal-20.SL (Tops-20 Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 1 November 1982 % % This file contains functions that set NMODE's terminal. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) % External variables used here: (fluid '(nmode-terminal)) % Global variables defined here: (fluid '(terminal-type)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Terminal Selection Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-default-terminal () (nmode-set-terminal) ) (de nmode-set-terminal () (setf terminal-type (jsys2 65 0 0 0 (const jsgttyp))) (selectq terminal-type (21 % HP2621 (ensure-terminal-type 'hp2648a) ) (6 % HP264X (ensure-terminal-type 'hp2648a) ) (15 % VT52 (ensure-terminal-type 'vt52x) ) (t (or nmode-terminal (ensure-terminal-type 'hp2648a)) ) )) (de ensure-terminal-type (type) (cond ((or (null nmode-terminal) (not (eq type (object-type nmode-terminal)))) (setf nmode-terminal (make-instance type)) (nmode-new-terminal) ))) % These functions defined for compatibility: (de hp2648a () (ensure-terminal-type 'hp2648a)) (de vt52x () (ensure-terminal-type 'vt52x)) |
Added psl-1983/nmode/set-terminal.b version [98f67dfb48].
cannot compute difference between binary files
Added psl-1983/nmode/shared-physical-screen.b version [aeca92324f].
cannot compute difference between binary files
Added psl-1983/nmode/shared-physical-screen.sl version [2e9b50072a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Shared-Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 16 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A shared-physical-screen is a rectangular character display whose display % area is shared by a number of different owners. An owner can be any object % that supports the following operations: % % Assert-Ownership () - assert ownership of all desired screen locations % Send-Changes (break-ok) - send all changed contents to the shared screen % Send-Contents (break-ok) - send entire contents to the shared screen % Screen-Cursor-Position () - return desired cursor position on screen % % Each character position on the physical screen is owned by a single owner. % Each owner is responsible for asserting ownership of those character % positions it wishes to be able to write on. The actual ownership of each % character position is determined by a prioritized list of owners. Owners % assert ownership in reverse order of priority; the highest priority owner % therefore appears to "overlap" all other owners. % % A shared physical screen object provides an opaque interface: no access to % the underlying physical screen object should be required. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 27-Dec-82 Alan Snyder % Changed SELECT-PRIMARY-OWNER and REMOVE-OWNER to avoid redundant % recomputation (and screen rewriting). % 21-Dec-82 Alan Snyder % Efficiency hacks: Special tests for owners that are virtual-screens. % Added methods: &GET-OWNER-CHANGES, &GET-OWNER-CONTENTS, and % &ASSERT-OWNERSHIP. % 16-Dec-82 Alan Snyder % Bug fix: SET-SCREEN failed to update size (invoked the wrong method). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors)) (de create-shared-physical-screen (physical-screen) (make-instance 'shared-physical-screen 'screen physical-screen)) (defflavor shared-physical-screen ( height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column (owner-list NIL) % prioritized list of owners (lowest priority first) (recalculate T) % T => must recalculate ownership owner-map % maps screen location to owner (or NIL) screen % the physical-screen ) () (gettable-instance-variables height width) (initable-instance-variables screen) ) (declare-flavor physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro map-fetch (map row col) `(vector-fetch (vector-fetch ,map ,row) ,col)) (defmacro map-store (map row col value) `(vector-store (vector-fetch ,map ,row) ,col ,value)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (shared-physical-screen ring-bell) () (=> screen ring-bell)) (defmethod (shared-physical-screen enter-raw-mode) () (=> screen enter-raw-mode)) (defmethod (shared-physical-screen leave-raw-mode) () (=> screen leave-raw-mode)) (defmethod (shared-physical-screen get-character) () (=> screen get-character)) (defmethod (shared-physical-screen convert-character) (ch) (=> screen convert-character ch)) (defmethod (shared-physical-screen normal-enhancement) () (=> screen normal-enhancement)) (defmethod (shared-physical-screen highlighted-enhancement) () (=> screen highlighted-enhancement)) (defmethod (shared-physical-screen supported-enhancements) () (=> screen supported-enhancements)) (defmethod (shared-physical-screen write-to-stream) (s) (=> screen write-to-stream s)) (defmethod (shared-physical-screen set-screen) (new-screen) (setf screen new-screen) (=> self &new-screen) ) (defmethod (shared-physical-screen owner) (row col) % Return the current owner of the specified screen location. (if recalculate (=> self &recalculate-ownership)) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-fetch owner-map row col))) (defmethod (shared-physical-screen select-primary-owner) (owner) % Make the specified OWNER the primary owner (adding it to the list of owners, % if not already there). (when (not (eq (lastcar owner-list) owner)) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf owner-list (aconc owner-list owner)) (when (not recalculate) (=> self &assert-ownership owner) (=> self &get-owner-contents owner nil) (=> self &update-cursor owner) ))) (defmethod (shared-physical-screen remove-owner) (owner) % Remove the specified owner from the list of owners. The owner will lose % ownership of his screen area. Screen ownership will be recalculated in its % entirety when necessary (to determine the new ownership of the screen area). (when (memq owner owner-list) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf recalculate T) )) (defmethod (shared-physical-screen refresh) (breakout-allowed) % Update the screen: obtain changed contents from the owners, % send it to the screen, refresh the screen. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen refresh breakout-allowed)) (defmethod (shared-physical-screen full-refresh) (breakout-allowed) % Just like REFRESH, except that the screen is cleared first. This operation % should be used to initialize the state of the screen when the program % starts or when uncontrolled output may have occured. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen full-refresh breakout-allowed)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods % The following methods are for use only by owners to perform the % AssertOwnership operation when invoked by this object: (defmethod (shared-physical-screen set-owner) (row col owner) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-store owner-map row col owner))) (defmethod (shared-physical-screen set-owner-region) (row col h w owner) % This method provided for convenience and efficiency. (let ((last-row (+ row (- h 1))) (last-col (+ col (- w 1))) (map owner-map) ) (cond ((and (<= row maxrow) (<= col maxcol) (>= last-row 0) (>= last-col 0)) (if (< row 0) (setf row 0)) (if (< col 0) (setf col 0)) (if (> last-row maxrow) (setf last-row maxrow)) (if (> last-col maxcol) (setf last-col maxcol)) (for (from r row last-row) (do (for (from c col last-col) (do (map-store map r c owner)) ))))))) % The following method is for use only by owners: (defmethod (shared-physical-screen write) (ch row col owner) % Conditional write: write the specified character to the specified location % only if that location is owned by the specified owner. The actual display % will not be updated until REFRESH or FULL-REFRESH is performed. (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (progn (if recalculate (=> self &recalculate-ownership)) (if (eq owner (map-fetch owner-map row col)) (=> screen write ch row col))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (shared-physical-screen init) (init-plist) (=> self &new-screen) ) (defmethod (shared-physical-screen &new-screen) () (setf height (=> screen height)) (setf width (=> screen width)) (=> self &new-size) ) (defmethod (shared-physical-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf owner-map (mkvect maxrow)) (for (from row 0 maxrow) (do (iputv owner-map row (mkvect maxcol)))) (setf recalculate t)) (defmethod (shared-physical-screen &recalculate-ownership) () % Reset ownership to NIL, then ask all OWNERS to assert ownership. % Then ask all OWNERS to send all contents. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (map-store map r c NIL)))))) (for (in owner owner-list) (do (=> self &assert-ownership owner))) (setf recalculate NIL) (=> self &get-owners-contents)) (defmethod (shared-physical-screen &get-owners-changes) (breakout-allowed) % Ask all OWNERS to send any changed contents. (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-changes owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-changes) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-changes owner breakout-allowed) (=> owner send-changes breakout-allowed) )) (defmethod (shared-physical-screen &get-owners-contents) (breakout-allowed) % Ask all OWNERS to send all of their contents; unowned screen area % is blanked. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (if (null (map-fetch map r c)) (=> screen write #\space r c))))))) (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-contents owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-contents) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-contents owner breakout-allowed) (=> owner send-contents breakout-allowed) )) (defmethod (shared-physical-screen &assert-ownership) (owner) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$assert-ownership owner) (=> owner assert-ownership) )) (defmethod (shared-physical-screen &update-cursor) (owner) (let ((pair (if (eq (object-type owner) 'virtual-screen) (virtual-screen$screen-cursor-position owner) (=> owner screen-cursor-position) ))) (if (PairP pair) (=> screen set-cursor-position (car pair) (cdr pair))))) (undeclare-flavor screen) |
Added psl-1983/nmode/softkeys.b version [8eb7e63490].
cannot compute difference between binary files
Added psl-1983/nmode/softkeys.sl version [f1fe54e021].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SoftKeys.SL - NMODE SoftKeys % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 28 January 1983 % % This implementation of softkeys is intended primarily for the HP9836 % implementation. It recognizes the escape-sequence Esc-/, followed by % a single character, as instructing NMODE to execute the softkey % corresponding to that character. In the HP9836 implementation, % we can cause the keys K0-K9 to send the appropriate escape sequence. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings fast-vectors display-char)) % Global variables defined here: (fluid '(nmode-softkey-label-screen nmode-softkey-label-screen-height % number of rows of keys nmode-softkey-label-screen-width % number of keys per row )) % Internal static variables (don't use elsewhere!): (fluid '(nmode-softkey-defs % vector of softkey definitions (see below) nmode-softkey-labels % vector of softkey label strings nmode-softkey-label-width % number of characters wide nmode-softkey-label-count % number of displayed labels )) (when (or (unboundp 'nmode-softkey-defs) (null nmode-softkey-defs)) (setf nmode-softkey-label-screen NIL) (setf nmode-softkey-label-screen-height 0) (setf nmode-softkey-label-screen-width 0) (setf nmode-softkey-defs (make-vector 40 NIL)) (setf nmode-softkey-labels (make-vector 40 NIL)) (setf nmode-softkey-label-width 0) (setf nmode-softkey-label-count 0) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-define-softkey (n fcn label-string) % N should be a softkey number. FCN should be a function ID, a string, % or NIL. Define softkey #n to run the specified function, execute the % specified string (as if typed), or be undefined, respectively. % LABEL-STRING should be a string or NIL. The string will be centered. (if (and (valid-softkey-number? n) (or (null fcn) (idp fcn) (stringp fcn)) (or (null label-string) (stringp label-string)) ) (progn (vector-store nmode-softkey-defs n fcn) (vector-store nmode-softkey-labels n label-string) (nmode-write-softkey-label n) ) (nmode-error "Invalid arguments to Define Softkey") )) (de valid-softkey-number? (n) (and (fixp n) (>= n 0) (<= n (vector-upper-bound nmode-softkey-defs))) ) (de softkey-char-to-number (ch) (- (char-code ch) #/0)) (de softkey-number-to-char (n) (+ n #/0)) (de nmode-execute-softkey (n) % Execute softkey #n. (if (valid-softkey-number? n) (let ((fcn (vector-fetch nmode-softkey-defs n))) (cond ((null fcn) (nmode-error (bldmsg "Softkey %w is undefined." n))) ((stringp fcn) (nmode-execute-string fcn)) ((idp fcn) (apply fcn ())) (t (nmode-error (bldmsg "Softkey %w has a bad definition." n))) )) (nmode-error (bldmsg "Invalid Softkey specified.")) )) (de execute-softkey-command (n) (nmode-set-delayed-prompt "Execute Softkey: ") (let ((ch (input-direct-terminal-character))) (nmode-execute-softkey (softkey-char-to-number ch)) )) (de nmode-setup-softkey-label-screen (sps) % If the requested size of the softkey label screen is nonzero, then % create a virtual screen of that size on the given shared screen. % The requested size is obtained from global variables. (setf nmode-softkey-label-width 0) (setf nmode-softkey-label-count 0) (let ((height nmode-softkey-label-screen-height) (width nmode-softkey-label-screen-width) (screen-height (=> sps height)) (screen-width (=> sps width)) ) (setf nmode-softkey-label-screen (when (and (> height 0) (> width 0) (> screen-width (* 2 width)) (>= screen-height height) ) (let ((s (make-instance 'virtual-screen 'screen sps 'height height 'width screen-width 'row-origin (- screen-height height) 'column-origin 0 ))) (setf nmode-softkey-label-width (/ screen-width width)) (setf nmode-softkey-label-count (* width height)) (=> s set-default-enhancement (=> sps highlighted-enhancement)) s ))) (when nmode-softkey-label-screen (for (from i 0 (- nmode-softkey-label-count 1)) (do (nmode-write-softkey-label i))) (=> nmode-softkey-label-screen expose) ) )) (de nmode-write-softkey-label (n) (when (and nmode-softkey-label-screen (>= n 0) (< n nmode-softkey-label-count) ) (let* ((row (/ n nmode-softkey-label-screen-width)) (lcol (// n nmode-softkey-label-screen-width)) (col (* lcol nmode-softkey-label-width)) (enhancement (if (xor (= (// row 2) 0) (= (// lcol 2) 0)) (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY) (dc-make-enhancement-mask INVERSE-VIDEO) )) (label (vector-fetch nmode-softkey-labels n)) (bound (if label (string-upper-bound label) -1)) (padding (/ (- nmode-softkey-label-width (+ bound 1)) 2)) ) (=> nmode-softkey-label-screen set-default-enhancement enhancement) (if (< padding 0) (setf padding 0)) (for (from i 1 padding) (do (=> nmode-softkey-label-screen write #\space row col) (setf col (+ col 1)) )) (for (from i 0 (- (- nmode-softkey-label-width padding) 1)) (do (let ((ch (if (<= i bound) (string-fetch label i) #\space ))) (=> nmode-softkey-label-screen write ch row (+ col i)) ))) ))) |
Added psl-1983/nmode/structure-functions.b version [f56c2809e8].
cannot compute difference between binary files
Added psl-1983/nmode/structure-functions.sl version [dc9918369d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Structure-Functions.SL - NMODE functions for moving about structured text % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 12 November 1982 % Revised: 18 February 1983 % % This file contains functions for moving about structured text, such as Lisp % source code. The functions are based on the primitives in the module % NMODE-Parsing; the variable NMODE-CURRENT-PARSER determines the actual syntax % (e.g., Lisp, RLISP, etc.). See the document NMODE-PARSING.TXT for a % description of the parsing strategy. % % 18-Feb-83 Alan Snyder % Replaced move-down-list with move-forward-down-list and % move-backward-down-list. % 6-Jan-83 Alan Snyder % Use LOAD instead of FASLIN to get macros (for portability); reformat source. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int nmode-parsing)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Form Movement Functions % % A form is an ATOM or a nested structure. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-form () % Move to the end (just past the last character) of the current (if any) or % the next (otherwise) complete form or unmatched closing bracket. Returns % either NIL (no complete form found), 'ATOM, 'CLOSER (unmatched closing % bracket), or 'STRUCTURE (complete structure). If NIL is returned, then % point is unchanged. (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-forward-item)) % find next item (see below) ) (if (eq first-item 'OPENER) % it is an opening bracket (while T % scan past complete forms until an unmatched closing bracket (selectq (move-forward-form) (NIL (buffer-set-position old-pos) (exit NIL)) % end of text (CLOSER (exit 'STRUCTURE)) % found the matching closing bracket )) first-item % Otherwise, just return the information. ))) (de move-backward-form () % Move backward at least one character to the preceding character that is not % part of whitespace; then move to the beginning of the smallest form that % contains that character. If no form is found, return NIL and leave point % unchanged. Otherwise, return either 'ATOM, 'STRUCTURE (passed over complete % structure), or 'OPENER (passed over unmatched open bracket). (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-backward-item)) % find previous item (see below) ) (if (eq first-item 'CLOSER) % it is a closing bracket (while T % scan past complete forms until an unmatched opening bracket (selectq (move-backward-form) (NIL (buffer-set-position old-pos) (exit NIL)) % beginning of text (OPENER (exit 'STRUCTURE)) % found the matching opening bracket )) first-item % Otherwise, just return the information. ))) (de move-backward-form-interruptible () % This function is like move-backward-form, except it can be interrupted by % user type-ahead. If it is interrupted, it returns 'INTERRUPT and restores % the old position. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (when (input-available?) (buffer-set-position old-pos) (exit 'INTERRUPT)) (let ((item (move-backward-item))) (selectq item (NIL (buffer-set-position old-pos) (exit NIL)) (OPENER (setf paren-depth (- paren-depth 1)) (if (= paren-depth 0) (exit 'STRUCTURE)) ) (CLOSER (setf paren-depth (+ paren-depth 1))) ) (if (<= paren-depth 0) (exit item)) )))) (de move-backward-form-within-line () % This is the same as MOVE-BACKWARD-FORM, except that it looks only within the % current line. (let* ((old-pos (buffer-get-position)) % save current position (first-item (move-backward-item-within-line)) % find previous item ) (if (eq first-item 'CLOSER) % it is a closing bracket (while T % scan past complete forms until an unmatched opening bracket (selectq (move-backward-form-within-line) (NIL (buffer-set-position old-pos) (exit NIL)) % beginning of text (OPENER (exit 'STRUCTURE)) % found the matching opening bracket )) first-item % Otherwise, just return the information. ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Item Movement Functions % % An item is an ATOM or a structure bracket. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-item () % Move to the end (just past the last character) of the current (if any) or % the next (otherwise) atom or bracket. Returns either NIL (no item found), % 'ATOM, 'OPENER, or 'CLOSER. If NIL is returned, then point is unchanged. (let ((item-type (move-forward-to LAST NOT-SPACE))) (if item-type (move-forward-character)) item-type )) (de move-backward-item () % Move backward at least one character to the preceding character that is not % part of whitespace; then move to the beginning of the atom or bracket that % contains that character. Returns either NIL (no item found), 'ATOM, % 'OPENER, or 'CLOSER. If NIL is returned, then point is unchanged. (let ((old-pos (buffer-get-position)) (item-type nil) ) (if (move-backward-character) (setf item-type (move-backward-to FIRST NOT-SPACE))) (if (not item-type) (buffer-set-position old-pos)) item-type )) (de move-backward-item-within-line () % This is the same as MOVE-BACKWARD-ITEM, except that it looks only within the % current line. (if (not (at-line-start?)) (let ((old-pos (buffer-get-position)) (item-type nil) ) (move-backward-character) (setf item-type (move-backward-within-line-to FIRST NOT-SPACE)) (if (not item-type) (buffer-set-position old-pos)) item-type ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Move-Up-Forms Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-up-list () % Move to the right of the current structure (e.g. list). In other words, % find the next closing structure bracket whose matching opening structure % bracket is before point. If no such bracket can be found, return NIL and % leave point unchanged. (forward-scan-for-right-paren -1) ) (de move-backward-up-list () % Move to the beginning of the current structure (e.g. list). In other words, % find the previous opening structure bracket whose matching closing structure % bracket is after point. If no such bracket can be found, return NIL and % leave point unchanged. (reverse-scan-for-left-paren 1) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % List Movement Functions % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-list () % Move to the right of the current or next structure (e.g. list). In other % words, find the next closing structure bracket whose matching opening % structure bracket is before point or is the first opening structure bracket % after point. If no such bracket can be found, return NIL and leave point % unchanged. (forward-scan-for-right-paren 0) ) (de move-backward-list () % Move to the beginning of the current or previous structure (e.g. list). In % other words, find the previous opening structure bracket whose matching % closing structure bracket is after point or is the first closing structure % bracket before point. If no such bracket can be found, return NIL and leave % point unchanged. (reverse-scan-for-left-paren 0) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Display Commands % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de display-matching-opener () % If the previous character is the last character of a closing bracket, then % move backward to the beginning of the form, wait a while so that the user % can see where it is, then return to the previous position. (let ((old-pos (buffer-get-position))) (unwind-protect (unsafe-display-matching-opener) (buffer-set-position old-pos) ))) (de unsafe-display-matching-opener () (move-backward-character) (when (test-current-attributes LAST CLOSER) (move-forward-character) (selectq (move-backward-form-interruptible) (STRUCTURE (nmode-refresh) % Show the user where we are. (sleep-until-timeout-or-input 30) % wait a while ) (INTERRUPT) (t (Ding)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal List Scanning Primitives %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de reverse-scan-for-left-paren (depth) % Scan backwards (starting with the character before point) for a left paren % at depth >= the specified depth. If found, the left paren will be after % point and T will be returned. Otherwise, point will not change and NIL will % be returned. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (selectq (move-backward-item) (NIL (buffer-set-position old-pos) (exit NIL)) (CLOSER (setf paren-depth (- paren-depth 1))) (OPENER (setf paren-depth (+ paren-depth 1)) (if (>= paren-depth depth) (exit T)) ) )))) (de forward-scan-for-right-paren (depth) % Scan forward (starting with the character after point) for a right paren at % depth <= the specified depth. If found, the right paren will be before % point and T will be returned. Otherwise, point will not change and NIL will % be returned. (let ((old-pos (buffer-get-position)) (paren-depth 0) ) (while T (selectq (move-forward-item) (NIL (buffer-set-position old-pos) (exit NIL)) (CLOSER (setf paren-depth (- paren-depth 1)) (if (<= paren-depth depth) (exit T)) ) (OPENER (setf paren-depth (+ paren-depth 1))) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Move-Down-List functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de move-forward-down-list () % Move forward past the next open bracket at the current level. (let ((old-pos (buffer-get-position))) (while T (selectq (move-forward-item) ((NIL CLOSER) (buffer-set-position old-pos) (exit NIL)) (OPENER (exit T)) )))) (de move-backward-down-list () % Move backward past the previous close bracket at the current level. (let ((old-pos (buffer-get-position))) (while T (selectq (move-backward-item) ((NIL OPENER) (buffer-set-position old-pos) (exit NIL)) (CLOSER (exit T)) )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de skip-prefixes () % Skip over any "prefix characters" (like ' in Lisp). (while (test-current-attributes PREFIX) (move-forward)) ) |
Added psl-1983/nmode/terminal-input.b version [11b8164694].
cannot compute difference between binary files
Added psl-1983/nmode/terminal-input.sl version [28c43d4a53].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Terminal-Input.SL - NMODE Terminal Input Routines % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 August 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 26-Jan-83 Alan Snyder % Add ability to read from string. % 21-Dec-82 Alan Snyder % Efficiency improvement: Added declarations for text buffers. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int fast-strings)) (load wait) % External variables used: (fluid '(nmode-terminal nmode-allow-refresh-breakout )) % Internal static variables (don't use elsewhere!): (fluid '(nmode-prompt-string % current prompt for character input nmode-prompt-immediately % true => show prompt immediately nmode-terminal-script-buffer % if non-NIL, is a buffer to script to nmode-terminal-input-buffer % if non-NIL, is a buffer to read from nmode-terminal-input-string % if non-NIL, is a string to read from nmode-terminal-input-string-pos % index of next character in string )) (setf nmode-prompt-string "") (setf nmode-prompt-immediately NIL) (setf nmode-terminal-script-buffer NIL) (setf nmode-terminal-input-buffer NIL) (setf nmode-terminal-input-string NIL) (declare-flavor text-buffer nmode-terminal-input-buffer nmode-terminal-script-buffer) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Functions: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % A primary goal of this module is to support delayed prompting. Prompting can % mean both echoing (some kind of confirmation) of the previous input and % information relating to expected input. The basic idea behind delayed % prompting is that as long as the user is rapidly typing input characters, % there is no need for the system to display any prompts, since the user % probably knows what he is doing. However, should the user ever pause for a % "sufficiently long" time, then the current prompt should be displayed to % inform the user of the current state. % An important notion is that some command interactions form a logical sequence. % In the case of a logical sequence of prompted inputs, each additional prompt % string should be appended to the existing prompt string, without first erasing % the prompt line. Furthermore, once the prompt line for this sequence is % displayed, any further prompts within the same sequence should be output % immediately. A command sequence is started using the function % NMODE-SET-DELAYED-PROMPT. Additional prompting within the same sequence is % specified using either NMODE-APPEND-DELAYED-PROMPT or % NMODE-APPEND-SEPARATED-PROMPT. (de nmode-set-immediate-prompt (prompt-string) % This function is used to specify the beginning of a command sequence. It % causes the existing prompt string to be discarded and replaced by the % specified string. The specified string may be empty to indicate that the % new command sequence has no initial prompt. The prompt string will be % output immediately upon the next request for terminal input. (setf nmode-prompt-string prompt-string) (setf nmode-prompt-immediately T) ) (de nmode-set-delayed-prompt (prompt-string) % This function is used to specify the beginning of a command sequence. It % causes the existing prompt string to be discarded and replaced by the % specified string. The specified string may be empty to indicate that the % new command sequence has no initial prompt. The prompt string will be % output when terminal input is next requested, provided that the user has % paused. (setf nmode-prompt-string prompt-string) (setf nmode-prompt-immediately NIL) ) (de nmode-append-delayed-prompt (prompt-string) % This function is used to specify an additional prompt for the current % command sequence. The prompt string will be appended to the existing prompt % string. The prompt string will be output when terminal input is next % requested, provided that the user has paused within the current command % sequence. If the prompt string is currently empty, then the user must pause % at some future input request to cause the prompt to be displayed. (setf nmode-prompt-string (string-concat nmode-prompt-string prompt-string)) ) (de nmode-append-separated-prompt (prompt-string) % This function is the same as NMODE-APPEND-DELAYED-PROMPT, except that if the % existing prompt string is non-null, an extra space is appended before the % new prompt-string is appended. (nmode-append-delayed-prompt (if (not (string-empty? nmode-prompt-string)) (string-concat " " prompt-string) prompt-string ))) (de nmode-complete-prompt (prompt-string) % This function is used to specify an additional prompt for the current % command sequence. The prompt string will be appended to the existing prompt % string. The prompt string will be output immediately, if the current prompt % has already been output. This function is to be used for "completion" or % "echoing" of previously read input. (setf nmode-prompt-string (string-concat nmode-prompt-string prompt-string)) (if nmode-prompt-immediately (write-prompt nmode-prompt-string)) ) (de input-available? () % Return Non-NIL if and only if new terminal input is available. Note: this % function might be somewhat expensive. (or (and nmode-terminal-input-buffer (not (=> nmode-terminal-input-buffer at-buffer-end?))) nmode-terminal-input-string (~= (CharsInInputBuffer) 0))) (de input-direct-terminal-character () % Prompt for (but do not echo) a single character from the terminal. The % above functions are used to specify the prompt string. Avoid displaying the % prompt string if the user has already typed a character or types a character % right away. Within a sequence of related prompts, once a non-empty prompt % is output, further prompting is done immediately. (cond (nmode-terminal-input-buffer (&input-character-from-buffer)) (nmode-terminal-input-string (&input-character-from-string)) (t (&input-character-from-terminal)) )) (de &input-character-from-buffer () % Internal function for reading from a buffer. (cond ((=> nmode-terminal-input-buffer at-buffer-end?) (setf nmode-terminal-input-buffer NIL) (setf nmode-allow-refresh-breakout T) (input-direct-terminal-character) ) ((=> nmode-terminal-input-buffer at-line-end?) (=> nmode-terminal-input-buffer move-to-next-line) (input-direct-terminal-character) ) (t (prog1 (=> nmode-terminal-input-buffer next-character) (=> nmode-terminal-input-buffer move-forward) )) )) (de &input-character-from-string () % Internal function for reading from a string. (let ((upper-bound (string-upper-bound nmode-terminal-input-string)) (pos nmode-terminal-input-string-pos) ) (cond ((= pos upper-bound) (let ((ch (string-fetch nmode-terminal-input-string pos))) (setf nmode-terminal-input-string NIL) (setf nmode-allow-refresh-breakout T) ch )) (t (let ((ch (string-fetch nmode-terminal-input-string pos))) (setf nmode-terminal-input-string-pos (+ pos 1)) ch )) ))) (de &input-character-from-terminal () % Internal function for reading from the terminal. (let ((prompt-is-empty (string-empty? nmode-prompt-string))) (if (not nmode-prompt-immediately) (sleep-until-timeout-or-input (if prompt-is-empty 120 30) % don't rush to erase the prompt line )) (if (or nmode-prompt-immediately (not (input-available?))) (progn (write-prompt nmode-prompt-string) (setf nmode-prompt-immediately (not prompt-is-empty)) )) (let ((ch (=> nmode-terminal get-character))) (if nmode-terminal-script-buffer (nmode-script-character ch)) ch ))) (de pause-until-terminal-input () % Return when the user has typed a character. The character is eaten. % No refresh is performed. (=> nmode-terminal get-character) ) (de sleep-until-timeout-or-input (n-60ths) (wait-timeout 'input-available? n-60ths) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-script-terminal-input (b) % Make a script of all terminal (command) input by appending characters to the % specified buffer. Supercedes any previous such request. If B is NIL, then % no scripting is performed. Note: to keep the lines of reasonable length, % free Newlines will be inserted from time to time. Because of this, and % because many file systems cannot represent stray Newlines, the Newline % character is itself scripted as a CR followed by a TAB, since this is its % normal definition. Someday, perhaps, this hack will be replaced by a better % one. (setf nmode-terminal-script-buffer b) ) (de nmode-execute-buffer (b) % Take input from the specified buffer. Supercedes any previous such request. % If B is NIL, then input is taken from the terminal. Newline characters are % ignored when reading from a buffer! (setf nmode-terminal-input-buffer b) (if b (=> b move-to-buffer-start)) ) (de nmode-execute-string (s) % Take input from the specified string. Supercedes any previous such request. % If S is NIL or empty, then input is taken from the terminal. (if (string-empty? s) (setf s NIL)) (setf nmode-terminal-input-string s) (setf nmode-terminal-input-string-pos 0) ) (de nmode-script-character (ch) % Write CH to the script buffer. (let* ((b nmode-terminal-script-buffer) (old-pos (=> b position)) ) (=> b move-to-buffer-end) (cond ((= ch #\LF) (=> b insert-character #\CR) (=> b insert-character #\TAB) ) (t (=> b insert-character ch)) ) (if (>= (=> b current-line-length) 60) (=> b insert-eol) ) (=> b set-position old-pos) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor nmode-terminal-input-buffer nmode-terminal-script-buffer) |
Added psl-1983/nmode/text-buffer.b version [f0a4f00bb7].
cannot compute difference between binary files
Added psl-1983/nmode/text-buffer.sl version [7b2543ce59].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Text-Buffer.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 20 August 1982 % Revised: 23 February 1983 % % A text buffer. Supports the primitive editing functions. The strings in a % text buffer are never modified. This allows EQ to be used to minimize % redisplay. % % 23-Feb-83 Alan Snyder % Revise stream operations to work with any type of object. % 15-Feb-83 Alan Snyder % Revise insertion code to reduce unnecessary consing. % Remove char-blank? macro (NMODE has a function char-blank?). % 19-Jan-83 Jeff Soreff % Name made settable in text buffer. % 3-Dec-82 Alan Snyder % Added cleanup method. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors fast-strings)) (de create-text-buffer (name) % not for direct use in NMODE (let ((buffer (make-instance 'text-buffer 'name name))) buffer)) (defflavor text-buffer ( (last-line 0) % index of last line in buffer (n >= 0) (line-pos 0) % index of "current" line (0 <= n <= last-line) (char-pos 0) % index of "current" character in current line % (0 <= n <= linelength) lines % vector of strings name % string name of buffer (file-name NIL) % string name of attached file (or NIL) (modified? NIL) % T => buffer is different than file marks % ring buffer of marks (mode NIL) % the buffer's Mode (previous-buffer NIL) % (optional) previous buffer (p-list NIL) % association list of properties ) () (gettable-instance-variables line-pos char-pos) (settable-instance-variables file-name modified? mode previous-buffer name) (initable-instance-variables name) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (CompileTime (progn (defmacro with-current-line ((var) . forms) `(let ((,var (vector-fetch lines line-pos))) ,@forms )) (defmacro with-current-line ((var) . forms) % avoid compiler bug! `(let ((**LINES** lines)) (let ((,var (vector-fetch **LINES** line-pos))) ,@forms ))) (defmacro with-current-line-copied ((var) . forms) `(let ((**LINES** lines) (**LINE-POS** line-pos)) (let ((,var (copystring (vector-fetch **LINES** **line-pos**)))) (vector-store **LINES** **line-pos** ,var) ,@forms ))) )) % End of CompileTime %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (text-buffer position) () % Return the "current position" in the buffer as a BUFFER-POSITION object. (buffer-position-create line-pos char-pos) ) (defmethod (text-buffer set-position) (bp) % Set the "current position" in the buffer from the specified % BUFFER-POSITION object. Clips the line-position and char-position. (=> self goto (buffer-position-line bp) (buffer-position-column bp)) ) (defmethod (text-buffer buffer-end-position) () % Return the BUFFER-POSITION object corresponding to the end of the buffer. (buffer-position-create last-line (string-length (vector-fetch lines last-line)) )) (defmethod (text-buffer goto) (lpos cpos) % Set the "current position" in the buffer. Clips the line-position and % char-position. (if (< lpos 0) (setf lpos 0)) (if (> lpos last-line) (setf lpos last-line)) (setf line-pos lpos) (=> self set-char-pos cpos) ) (defmethod (text-buffer set-line-pos) (lpos) % Set the "current line position" in the buffer. Clips the line-position % and char-position. (when (~= lpos line-pos) (if (< lpos 0) (setf lpos 0)) (if (> lpos last-line) (setf lpos last-line)) (setf line-pos lpos) (with-current-line (l) (if (> char-pos (string-length l)) (setf char-pos (string-length l)) )) )) (defmethod (text-buffer set-char-pos) (cpos) % Set the "current character position" in the buffer. Clips the specified % position to lie in the range 0..line-length. (if (< cpos 0) (setf cpos 0)) (with-current-line (l) (if (> cpos (string-length l)) (setf cpos (string-length l)) )) (setf char-pos cpos) ) (defmethod (text-buffer clip-position) (bp) % Return BP if BP is a valid position for this buffer, otherwise return a new % buffer-position with clipped values. (let ((lpos (buffer-position-line bp)) (cpos (buffer-position-column bp)) (clipped NIL) ) (cond ((< lpos 0) (setf lpos 0) (setf clipped T)) ((> lpos last-line) (setf lpos last-line) (setf clipped T)) ) (cond ((< cpos 0) (setf cpos 0) (setf clipped T)) ((> cpos (string-length (vector-fetch lines lpos))) (setf cpos (string-length (vector-fetch lines lpos))) (setf clipped T) )) (if clipped (buffer-position-create lpos cpos) bp ))) (defmethod (text-buffer size) () % Return the actual size of the buffer (number of lines). This number will % include the "fake" empty line at the end of the buffer, should it exist. (+ last-line 1) ) (defmethod (text-buffer visible-size) () % Return the apparent size of the buffer (number of lines). This number % will NOT include the "fake" empty line at the end of the buffer, should it % exist. (if (>= (string-upper-bound (vector-fetch lines last-line)) 0) (+ last-line 1) % The last line is real! last-line % The last line is fake! )) (defmethod (text-buffer contents) () % Return the text contents of the buffer (a copy thereof) as a vector of % strings (the last string is implicitly without a terminating NewLine). (sub lines 0 last-line) ) (defmethod (text-buffer current-line) () % Return the current line (as a string). (with-current-line (l) l)) (defmethod (text-buffer fetch-line) (n) % Fetch the specified line (as a string). Lines are indexed from 0. (if (or (< n 0) (> n last-line)) (ContinuableError 0 (BldMsg "Line index %w out of range." n) "") (vector-fetch lines n) )) (defmethod (text-buffer store-line) (n new-line) % Replace the specified line with a new string. (if (or (< n 0) (> n last-line)) (ContinuableError 0 (BldMsg "Line index %w out of range." n) "") % else (setf modified? T) (vector-store lines n new-line) (if (= line-pos n) (let ((len (string-length new-line))) (if (> char-pos len) (setf char-pos len) ))) )) (defmethod (text-buffer select) () % Attach the buffer to the current window, making it the current buffer. (buffer-select self) ) (defmethod (text-buffer set-mark) (bp) % PUSH the specified position onto the ring buffer of marks. % The specified position thus becomes the current "mark". (ring-buffer-push marks bp) ) (defmethod (text-buffer set-mark-from-point) () % PUSH the current position onto the ring buffer of marks. % The current position thus becomes the current "mark". (ring-buffer-push marks (buffer-position-create line-pos char-pos)) ) (defmethod (text-buffer mark) () % Return the current "mark". (ring-buffer-top marks) ) (defmethod (text-buffer previous-mark) () % POP the current mark off the ring buffer of marks. % Return the new current mark. (ring-buffer-pop marks) (ring-buffer-top marks) ) (defmethod (text-buffer get) (property-name) % Return the object associated with the specified property name (ID). % Returns NIL if named property has not been defined. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (cdr pair)))) (defmethod (text-buffer put) (property-name property) % Associate the specified object with the specified property name (ID). % GET on that property-name will henceforth return the object. (let ((pair (atsoc property-name p-list))) (if (PairP pair) (rplacd pair property) (setf p-list (cons (cons property-name property) p-list)) ))) (defmethod (text-buffer reset) () % Reset the contents of the buffer to empty and "not modified". (setf lines (MkVect 1)) (vector-store lines 0 "") (setf last-line 0) (setf line-pos 0) (setf char-pos 0) (setf modified? NIL) ) (defmethod (text-buffer extract-region) (delete-it bp1 bp2) % Delete (if delete-it is non-NIL) or copy (otherwise) the text between % position BP1 and position BP2. Return the deleted (or copied) text as a % pair (CONS direction-of-deletion vector-of-strings). The returned % direction is +1 if BP1 <= BP2, and -1 otherwise. The current position is % set to the beginning of the region if deletion is performed. (setf bp1 (=> self clip-position bp1)) (setf bp2 (=> self clip-position bp2)) (prog (dir text text-last l1 c1 l2 c2 line1 line2) (setf dir 1) % the default case % ensure that BP1 is not beyond BP2 (let ((comparison (buffer-position-compare bp1 bp2))) (if (> comparison 0) (psetq dir -1 bp1 bp2 bp2 bp1)) (if (and delete-it (~= comparison 0)) (setf modified? T)) ) (setf l1 (buffer-position-line bp1)) (setf c1 (buffer-position-column bp1)) (setf l2 (buffer-position-line bp2)) (setf c2 (buffer-position-column bp2)) % Ensure the continued validity of the current position. (if delete-it (=> self set-position bp1)) % Create a vector for the extracted text. (setf text-last (- l2 l1)) % highest index in TEXT vector (setf text (MkVect text-last)) (setf line1 (vector-fetch lines l1)) % first line (partially) in region (cond ((= l1 l2) % region lies within a single line (easy!) (vector-store text 0 (substring line1 c1 c2)) (if delete-it (vector-store lines l1 (string-concat (substring line1 0 c1) (string-rest line1 c2) ))) (return (cons dir text)))) % Here if region spans multiple lines. (setf line2 (vector-fetch lines l2)) % last line (partially) in region (vector-store text 0 (string-rest line1 c1)) (vector-store text text-last (substring line2 0 c2)) % Copy remaining text from region. (for (from i 1 (- text-last 1)) (do (vector-store text i (vector-fetch lines (+ l1 i))))) (when delete-it (vector-store lines l1 (string-concat (substring line1 0 c1) (string-rest line2 c2))) (=> self &delete-lines (+ l1 1) text-last) ) (return (cons dir text)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following methods are not really primitive, but are provided as % a public service. (defmethod (text-buffer current-line-length) () % Return the number of characters in the current line. (with-current-line (l) (string-length l))) (defmethod (text-buffer current-line-empty?) () % Return T if the current line contains no characters. (with-current-line (l) (string-empty? l))) (defmethod (text-buffer current-line-blank?) () % Return T if the current line contains no non-blank characters. (with-current-line (l) (for (from i 0 (string-upper-bound l)) (always (char-blank? (string-fetch l i))) ))) (defmethod (text-buffer at-line-start?) () % Return T if we are positioned at the start of the current line. (= char-pos 0)) (defmethod (text-buffer at-line-end?) () % Return T if we are positioned at the end of the current line. (with-current-line (l) (> char-pos (string-upper-bound l)))) (defmethod (text-buffer at-buffer-start?) () % Return T if we are positioned at the start of the buffer. (and (= line-pos 0) (= char-pos 0))) (defmethod (text-buffer at-buffer-end?) () % Return T if we are positioned at the end of the buffer. (and (>= line-pos last-line) (> char-pos (string-upper-bound (vector-fetch lines last-line))))) (defmethod (text-buffer current-line-is-first?) () % Return T if the current line is the first line in the buffer. (= line-pos 0)) (defmethod (text-buffer current-line-is-last?) () % Return T if the current line is the last line in the buffer. (>= line-pos last-line)) (defmethod (text-buffer current-line-fetch) (n) % Return the character at character position N within the current line. % An error is generated if N is out of range. (with-current-line (l) (if (and (>= n 0) (<= n (string-upper-bound l))) (string-fetch l n) (ContinuableError 0 (BldMsg "Character index %w out of range." n) "") ))) (defmethod (text-buffer current-line-store) (n c) % Store the character C at char position N within the current line. % An error is generated if N is out of range. (with-current-line-copied (l) (if (and (>= n 0) (<= n (string-upper-bound l))) (progn (string-store l n c) (vector-store lines line-pos l) (setf modified? T) ) (ContinuableError 0 (BldMsg "Character index %w out of range." n) "") ))) (defmethod (text-buffer move-to-buffer-start) () % Move to the beginning of the buffer. (setf line-pos 0) (setf char-pos 0) ) (defmethod (text-buffer move-to-buffer-end) () % Move to the end of the buffer. (setf line-pos last-line) (with-current-line (l) (setf char-pos (string-length l))) ) (defmethod (text-buffer move-to-start-of-line) () % Move to the beginning of the current line. (setf char-pos 0)) (defmethod (text-buffer move-to-end-of-line) () % Move to the end of the current line. (with-current-line (l) (setf char-pos (string-length l)))) (defmethod (text-buffer move-to-next-line) () % Move to the beginning of the next line. % If already at the last line, move to the end of the line. (cond ((< line-pos last-line) (setf line-pos (+ line-pos 1)) (setf char-pos 0)) (t (=> self move-to-end-of-line)))) (defmethod (text-buffer move-to-previous-line) () % Move to the beginning of the previous line. % If already at the first line, move to the beginning of the line. (if (> line-pos 0) (setf line-pos (- line-pos 1))) (setf char-pos 0)) (defmethod (text-buffer move-forward) () % Move to the next character in the current buffer. % Do nothing if already at the end of the buffer. (if (=> self at-line-end?) (=> self move-to-next-line) (setf char-pos (+ char-pos 1)) )) (defmethod (text-buffer move-backward) () % Move to the previous character in the current buffer. % Do nothing if already at the start of the buffer. (if (> char-pos 0) (setf char-pos (- char-pos 1)) (when (> line-pos 0) (setf line-pos (- line-pos 1)) (=> self move-to-end-of-line) ))) (defmethod (text-buffer next-character) () % Return the character to the right of the current position. % Return NIL if at the end of the buffer. (with-current-line (l) (if (>= char-pos (string-length l)) (if (= line-pos last-line) NIL (char EOL) ) (string-fetch l char-pos) ))) (defmethod (text-buffer previous-character) () % Return the character to the left of the current position. % Return NIL if at the beginning of the buffer. (if (= char-pos 0) (if (= line-pos 0) NIL #\EOL) (with-current-line (l) (string-fetch l (- char-pos 1))) )) (defmethod (text-buffer insert-character) (c) % Insert character C at the current position in the buffer and advance past % that character. Implementation note: some effort is made here to avoid % unnecessary consing. (if (= c #\EOL) (=> self insert-eol) % else (with-current-line (l) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) (s (string c)) ) (when head-string (setf s (string-concat head-string s))) (when tail-string (setf s (string-concat s tail-string))) (vector-store lines line-pos s) (setf char-pos (+ char-pos 1)) (setf modified? T) )))) (defmethod (text-buffer insert-eol) () % Insert a line-break at the current position in the buffer and advance to % the beginning of the newly-formed line. Implementation note: some effort % is made here to avoid unnecessary consing. (with-current-line (l) (=> self &insert-gap line-pos 1) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) ) (vector-store lines line-pos (or head-string "")) (setf line-pos (+ line-pos 1)) (vector-store lines line-pos (or tail-string "")) (setf char-pos 0) (setf modified? T) ))) (defmethod (text-buffer insert-line) (l) % Insert the specified string as a new line in front of the current line. % Advance past the newly inserted line. Note: L henceforth must never be % modified. (=> self &insert-gap line-pos 1) (vector-store lines line-pos l) (setf line-pos (+ line-pos 1)) (setf modified? T) ) (defmethod (text-buffer insert-string) (s) % Insert the string S at the current position. Advance past the % newly-inserted string. Note: S must not contain EOL characters! Note: S % henceforth must never be modified. Implementation note: some effort is % made here to avoid unnecessary consing. (let ((insert-length (string-length s))) (when (> insert-length 0) (with-current-line (l) (let* ((current-length (string-length l)) (head-string (when (> char-pos 0) (if (= char-pos current-length) l (substring l 0 char-pos)))) (tail-string (when (< char-pos current-length) (if (= char-pos 0) l (substring l char-pos current-length)))) ) (when head-string (setf s (string-concat head-string s))) (when tail-string (setf s (string-concat s tail-string))) (vector-store lines line-pos s) (setf char-pos (+ char-pos insert-length)) (setf modified? T) ))))) (defmethod (text-buffer insert-text) (v) % V is a vector of strings similar to LINES (e.g., the last string in V is % considered to be an unterminated line). Thus, V must have at least one % element. Insert this stuff at the current position and advance past it. (with-current-line (l) (let ((v-last (vector-upper-bound v))) (=> self &insert-gap line-pos v-last) (let ((vec lines) (prefix-text (substring l 0 char-pos)) (suffix-text (string-rest l char-pos)) ) (vector-store vec line-pos (string-concat prefix-text (vector-fetch v 0))) (for (from i 1 v-last) (do (setf line-pos (+ line-pos 1)) (vector-store vec line-pos (vector-fetch v i)))) (setf char-pos (string-length (vector-fetch vec line-pos))) (vector-store vec line-pos (string-concat (vector-fetch vec line-pos) suffix-text)) (setf modified? T) )))) (defmethod (text-buffer delete-next-character) () % Delete the next character. % Do nothing if at the end of the buffer. (with-current-line (l) (if (= char-pos (string-length l)) (if (= line-pos last-line) NIL % else (at end of line other than last) (vector-store lines line-pos (string-concat l (vector-fetch lines (+ line-pos 1)))) (=> self &delete-lines (+ line-pos 1) 1) (setf modified? T) ) % else (not at the end of a line) (vector-store lines line-pos (string-concat (substring l 0 char-pos) (string-rest l (+ char-pos 1)) )) (setf modified? T) ))) (defmethod (text-buffer delete-previous-character) () % Delete the previous character. % Do nothing if at the beginning of the buffer. (if (not (=> self at-buffer-start?)) (progn (=> self move-backward) (=> self delete-next-character) (setf modified? T) ))) % Implementation note: On the 9836, the following implementation of the % read-from-stream method using GETC is slightly slower than a much simpler % implementation of read-from-stream using GETL (although the GETL method is % highly optimized). For a file with 874 lines, using GETC took 7480 ms vs. % 7130 ms. when using GETL. The problem with GETL, however, is that it does % not report whether the last line of the file is terminated with a Newline or % not. This functional difference could conceivably be important. Luckily, % the improvement in speed is sufficiently small to be irrelevant. (defmethod (text-buffer read-from-stream) (s) (=> self reset) (let* ((line-buffer (make-string 200 0)) (buffer-top 200) (getc-method (object-get-handler s 'getc)) line-size ch ) (while T (setf line-size 0) (setf ch (apply getc-method (list s))) (while (not (or (null ch) (= ch #\LF))) (cond ((>= line-size buffer-top) (setf line-buffer (concat line-buffer (make-string 200 0))) (setf buffer-top (+ buffer-top 200)) )) (string-store line-buffer line-size ch) (setf line-size (+ line-size 1)) (setf ch (apply getc-method (list s))) ) (if (not (and (null ch) (= line-size 0))) (=> self insert-line (sub line-buffer 0 (- line-size 1))) ) (when (null ch) (if (> line-size 0) (=> self delete-previous-character)) (exit) )) (=> self move-to-buffer-start) (=> self set-modified? NIL) )) (defmethod (text-buffer write-to-stream) (s) (let* ((vec lines) (putl-method (object-get-handler s 'putl)) ) (for (from i 0 (- last-line 1)) (do (apply putl-method (list s (vector-fetch vec i))))) (=> s puts (vector-fetch vec last-line)) )) (defmethod (text-buffer cleanup) () % Discard any unused storage. (if (and previous-buffer (not (buffer-is-selectable? previous-buffer))) (setf previous-buffer NIL)) (TruncateVector lines last-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (text-buffer init) (init-plist) (setf lines (MkVect 0)) (vector-store lines 0 "") (setf marks (ring-buffer-create 16)) (ring-buffer-push marks (buffer-position-create 0 0)) ) (defmethod (text-buffer &insert-gap) (lpos n-lines) % Insert N-LINES lines at position LPOS, moving the remaining lines upward % (if any). LPOS may range from 0 (insert at beginning of buffer) to % LAST-LINE + 1 (insert at end of buffer). The new lines are not % specifically initialized (they retain their old values). (when (> n-lines 0) (=> self &ensure-room n-lines) (let ((vec lines)) (for (from i last-line lpos -1) (do (vector-store vec (+ i n-lines) (vector-fetch vec i))) ) (setf last-line (+ last-line n-lines)) ))) (defmethod (text-buffer &ensure-room) (lines-needed) % Ensure that the LINES vector is large enough to add the specified number % of additional lines. (let* ((current-bound (vector-upper-bound lines)) (lines-available (- current-bound last-line)) (lines-to-add (- lines-needed lines-available)) ) (when (> lines-to-add 0) (let ((minimum-incr (>> current-bound 2))) % Increase by at least 25% (if (< minimum-incr 64) (setf minimum-incr 64)) (if (< lines-to-add minimum-incr) (setf lines-to-add minimum-incr)) ) (let ((new-lines (make-vector (+ current-bound lines-to-add) NIL))) (for (from i 0 current-bound) (do (vector-store new-lines i (vector-fetch lines i)))) (setf lines new-lines) )))) (defmethod (text-buffer &delete-lines) (lpos n-lines) % Remove N-LINES lines starting at position LPOS, moving the remaining lines % downward (if any) and NILing out the obsoleted lines at the end of the % LINES vector (to allow the strings to be reclaimed). LPOS may range from % 0 to LAST-LINE. (when (> n-lines 0) (let ((vec lines)) (for (from i (+ lpos n-lines) last-line) (do (vector-store vec (- i n-lines) (vector-fetch vec i))) ) (setf last-line (- last-line n-lines)) (for (from i 1 n-lines) (do (vector-store vec (+ last-line i) NIL)) ) ))) |
Added psl-1983/nmode/text-commands.b version [586fd2ca83].
cannot compute difference between binary files
Added psl-1983/nmode/text-commands.sl version [90430be7cb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TEXT-COMMANDS.SL - NMODE Sentence, Paragraph, Filling, and Formatting % % Author: Jeff Soreff % Hewlett-Packard/CRC % Date: 8 December 1982 % Revised: 1 February 1983 % Revised: 15 February 1983 % % 15-Feb-83 Jeff Soreff % Bugs were removed from fill-comment-command and from next-char-list. % A test for arriving at a line end was added to fill-comment-command % in the while loop which locates the fill prefix to be used. It fixed an % infinite loop in this while which occurred when one did a % fill-comment-command while on the last line in the buffer, if the % prefix-finding loop got to the buffer's end. An at-line-end? test was used % instead of an at-buffer-end? test since the fill prefix found should never % go over a line. % In next-char-list the initialization of final-char-pos was changed % from 0 to char-count. This removed a bug that led to setting the point % at the start of a prefixed line after a fill which moved point to the first % availible position on that new line. Point should have been left AFTER the % prefix. Changing the initialization of final-char-position allows % next-char-list to accurately account for the spaces taken up by the prefix, % since this count is passed to its char-count argument. % 1-Feb-83 Alan Snyder % Changed literal ^L in source to #\FF. % 30-Dec-82 Alan Snyder % Extended C-X = to set the current line number if a command number is % given. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load extended-char fast-strings fast-int)) (fluid '(nmode-current-buffer text-mode fill-prefix fill-column nmode-command-argument nmode-command-argument-given nmode-command-number-given nmode-command-killed sentence-terminators sentence-extenders)) (setf sentence-terminators '(#/! #/. #/?)) (setf sentence-extenders '(#/' #/" #/) #/])) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % User/Enhancer option sensitive function: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The text-justifier function may be altered if one wishes to have the % same flexibility as EMACS'S TECO search strings provide. (de text-justifier-command? () % This function checks to see if the rest of the line is a text % justifier command. It returns a boolean and leaves point alone. (= (next-character) #/.)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Sentence Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de valid-sentence-end? () % This function checks that a sentence is followed by two blanks, a % newline or a blank and a newline. It advances point one space. % It returns a boolean value. (if (at-line-end?) t (move-forward) (and (= (previous-character) #\blank) (or (at-line-end?)(= (next-character) #\blank))))) (de move-to-end-of-last-sentence () % This function moves point to the end of the preceding sentence, % after extenders. This function does not return a useful value (while (not (or (at-buffer-start?) (when % This when returns true if it hits a valid sentence end. (member (previous-character) sentence-terminators) (let ((scan-place (buffer-get-position))) (while (member (next-character) sentence-extenders) (move-forward)) (let* ((tentative-sentence-end (buffer-get-position)) (true-end (valid-sentence-end?))) (buffer-set-position (if true-end tentative-sentence-end scan-place)) true-end))))) (move-backward))) (de start-of-last-sentence () % This function restores point to its former place. It returns the % location of the start of the preceding sentence. (let ((place (buffer-get-position))(start nil)(end nil)) (move-to-end-of-last-sentence) (setf end (buffer-get-position)) (skip-forward-blanks) % possibly past starting position this time (setf start (buffer-get-position)) (when (buffer-position-lessp place start) (buffer-set-position end) % end of last sentence, after extenders (while % push back past extenders (member (previous-character) sentence-extenders) (move-backward)) (move-backward) % push back past sentence terminator character (move-to-end-of-last-sentence) (skip-forward-blanks) (setf start (buffer-get-position))) (buffer-set-position place) start)) (de end-of-next-sentence () % This function restores point to its former place. It returns the % location of the end of the next sentence. (let ((place (buffer-get-position))) (while (not % the next sexp detects sentence ends and moves point to them (or (at-buffer-end?) (when % note that this returns (valid-sentence-end?)'s value (member (next-character) sentence-terminators) (move-forward) (while (member (next-character) sentence-extenders) (move-forward)) (let ((tentative-sentence-end (buffer-get-position))) (if (valid-sentence-end?) (buffer-set-position tentative-sentence-end)))))) (move-forward)) (prog1 (buffer-get-position) (buffer-set-position place)))) (de forward-one-sentence () % This function moves point to the end of the next sentence or % paragraph, whichever one is closer, and does not return a useful % value. (let ((sentence-end (end-of-next-sentence))) (if (at-line-end?)(move-forward)) % kludge to get around xtra newline (forward-one-paragraph) (if (at-line-start?)(move-backward)) % kludge to get around xtra newline (let ((paragraph-end (buffer-get-position))) (buffer-set-position (if (buffer-position-lessp sentence-end paragraph-end) % "closer" is "earlier" or "before", in this case sentence-end paragraph-end))))) (de backward-one-sentence () % This function moves point to the start of the preceding sentence % or paragraph, whichever one is closer. It does not return a useful % value (let ((sentence-start (start-of-last-sentence))) (skip-backward-blanks) (backward-one-paragraph) (skip-forward-blanks) (let ((paragraph-start (buffer-get-position))) (buffer-set-position (if (buffer-position-lessp sentence-start paragraph-start) % "closer" is "later" or "after", in this case paragraph-start sentence-start))))) (de forward-sentence-command () % If nmode-command-argument is positive this function moves point % forward by nmode-command-argument sentences , leaving it at the % end of a sentence. If nmode-command-argument is negative it moves % backwards by abs(nmode-command-argument) sentences, leaving it at % the start of a sentence. This function does not return a useful % value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (backward-one-sentence))) (for (from i 1 nmode-command-argument 1) (do (forward-one-sentence))))) (de backward-sentence-command () % If nmode-command-argument is positive this function moves point % backward by nmode-command-argument sentences , leaving it at the % start of a sentence. If nmode-command-argument is negative it % moves forwards by abs(nmode-command-argument) sentences, leaving % it at the end of a sentence. This function does not return a % useful value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (forward-one-sentence))) (for (from i 1 nmode-command-argument 1) (do (backward-one-sentence))))) (de kill-sentence-command () % This function kills whatever forward-sentence-command jumps over. % It leaves point after the killed text. This function is sensitive % to the nmode command argument through forward-sentence-command. (let ((place (buffer-get-position))) (forward-sentence-command) (update-kill-buffer (extract-region t place (buffer-get-position))) (setf nmode-command-killed t))) (de backward-kill-sentence-command () % This function kills whatever backward-sentence-command jumps over. % It leaves point after the killed text. This function is sensitive % to the nmode command argument through forward-sentence-command. (let ((place (buffer-get-position))) (backward-sentence-command) (update-kill-buffer (extract-region t place (buffer-get-position))) (setf nmode-command-killed t))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Paragraph Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de rest-of-current-line-blank? () % This function detects if the rest of the line is blank. It % returns a boolean value. It restores point. (let ((last-position (buffer-get-position))) (while (and (not (at-line-end?)) (char-blank? (next-character))) (move-forward)) (prog1 (at-line-end?) (buffer-get-position last-position)))) (de mismatched-prefix? () % This function checks to see if there is a fill prefix which % doesn't match the start of the current line. It leaves point at % the start of the current line if there is a mismatch, or just % after the prefix if matched. It returns t if there is a fill % prefix which does NOT match the line's start. (move-to-start-of-line) (when fill-prefix (let ((start-line (buffer-get-position))) (move-over-characters (string-length % count of characters in fill-prefix (getv fill-prefix 0))) (when (not (text-equal (extract-text nil start-line (buffer-get-position)) fill-prefix)) (buffer-set-position start-line) t)))) (de pseudo-blank-line? () % This function tests to see if the current line should be kept out % of paragraphs. It tests for: lines which don't match an existing % fill prefix, blank lines, lines with only the fill prefix present, % text justifier commands, and properly prefixed text justifier % commands. It only checks for the text justifier commands in text % mode. It leaves point at the start of the current line and % returns a boolean value. (or (mismatched-prefix?) (prog1 (or (and (text-justifier-command?) (eq text-mode (=> nmode-current-buffer mode))) (rest-of-current-line-blank?)) (move-to-start-of-line)))) (de pseudo-indented-line? () % This function looks for page break characters or (in text mode) % indentation (after a fill prefix, if present) which signal the % start of a real paragraph. It always leaves point at the start of % the current line and returns a boolean. (prog1 (or (= #\FF (next-character)) % page break character (progn (mismatched-prefix?) (and (char-blank? (next-character)) (eq text-mode (=> nmode-current-buffer mode))))) (move-to-start-of-line))) (de start-line-paragraph? () % This function tests the current line to see if it is the first % line (not counting an empty line) in a paragraph. It leaves point % at the start of line and returns a boolean value. (and (not (pseudo-blank-line?)) (or (pseudo-indented-line?) % next sexp checks for a previous blank line (if (current-line-is-first?) t (move-to-previous-line) (prog1 (pseudo-blank-line?) (move-to-next-line)))))) (de end-line-paragraph? () % This function tests the current line to see if it is the last line % in a paragraph. It leaves point at the start of line and returns % a boolean value. (and (not (pseudo-blank-line?)) % The next sexp checks for the two things on the next line of % text that can end a paragraph: a blank line or an indented % line which would start a new paragraph. (if (current-line-is-last?) t (move-to-next-line) (prog1 (or (pseudo-indented-line?) (pseudo-blank-line?)) (move-to-previous-line))))) (de forward-one-paragraph () % This function moves point to the end of the next or current % paragraph, as EMACS defines it. This is either start of the line % after the last line with any characters or, if the paragraph % extends to the end of the buffer, then the end of the last line % with characters. This function returns a boolean which is true if % the function was stopped by a real paragraph end, rather than by % the buffer's end. (let ((true-end nil)) (while (not (or (setf true-end (end-line-paragraph?)) (current-line-is-last?))) (move-to-next-line)) (move-to-next-line) true-end)) (de forward-paragraph-command () % If nmode-command-argument is positive this function moves point % forward by nmode-command-argument paragraphs , leaving it at the % end of a paragraph. If nmode-command-argument is negative it moves % backwards by abs(nmode-command-argument) paragraphs, leaving it at % the start of a paragraph. This function does not return a useful % value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (backward-one-paragraph))) (for (from i 1 nmode-command-argument 1) (do (forward-one-paragraph))))) (de backward-one-paragraph () % This function moves point backward to the start of the previous % paragraph. It returns a boolean which is true if the function was % stopped by a real paragraph's start, instead of by the buffer's % start. (if (and (at-line-start?) % if past start of start line, don't miss (start-line-paragraph?)) % start of current paragraph (move-to-previous-line)) (let ((real-start nil)) (while (not (or (setf real-start (start-line-paragraph?)) (current-line-is-first?))) (move-to-previous-line)) (unless (current-line-is-first?) % this sexp gets previous empty line on (move-to-previous-line) (unless (current-line-empty?) (move-to-next-line))) real-start)) (de backward-paragraph-command () % If nmode-command-argument is positive this function moves point % backward by nmode-command-argument paragraphs , leaving it at the % start of a paragraph. If nmode-command-argument is negative it % moves forwards by abs(nmode-command-argument) paragraphs, leaving % it at the end of a paragraph. This function does not return a % useful value. (if (minusp nmode-command-argument) (for (from i 1 (- nmode-command-argument) 1) (do (forward-one-paragraph))) (for (from i 1 nmode-command-argument 1) (do (backward-one-paragraph))))) (de paragraph-limits () % This function returns a list of positions marking the next % paragraph. Only real paragraph limits are returned. If there is % only stuff that should be excluded from a paragraph between point % and the end or the start of the buffer, then the appropriate limit % of the paragraph is filled with the current buffer position. This % function restores point. (let* ((temp (buffer-get-position))(top temp)(bottom temp)) (when (forward-one-paragraph) (setf bottom (buffer-get-position))) (when (backward-one-paragraph) (setf top (buffer-get-position))) (buffer-set-position temp) (list top bottom))) (de mark-paragraph-command () % This function sets the mark to the end of the next paragraph, and % moves point to its start. It returns nothing useful. (let ((pair (paragraph-limits))) (buffer-set-position (first pair)) (set-mark (second pair)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Fill Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de next-char-list (end char-count init-pos) % This function returns a list, the first element of which is a list % of characters, with their order the reverse of that in the % original text, spaces squeezed to a single space between words, % and with two spaces between sentences. The second element on the % list returned is how far along the new line the position % corresponding to "init-pos" wound up. Point is left after the % last character packed in but before "end" or the next nonblank % character. (let* ((from-end-last-blanks 0) (from-start-last-blanks 0) (final-char-pos char-count) (line-not-full (lessp char-count fill-column)) (first-end (buffer-get-position)) (next-sentence-wont-exhaust-region (not (buffer-position-lessp end first-end))) (new-char (next-character)) (line-list ())) % start of loop for successive sentences (while (and next-sentence-wont-exhaust-region line-not-full) % The next sexp checks to see if the next sentence fits within % the main region (from initial "point" to "end") with a % character to spare for the next sentence iteration. (let* ((next-sentence-end (end-of-next-sentence))) (setf next-sentence-wont-exhaust-region (not (buffer-position-lessp end next-sentence-end))) (setf first-end (if next-sentence-wont-exhaust-region next-sentence-end end))) (skip-forward-blanks) % ignore blanks just before next sentence % start of loop for successive characters (while (and (setf line-not-full (or (lessp char-count fill-column) % next sexp allows oversize words (eq char-count from-end-last-blanks))) (not (buffer-position-lessp first-end (buffer-get-position)))) (setf new-char % character compression sexp (let ((next (next-character))) (if (not (= (skip-forward-blanks) next)) #\blank (move-forward) next))) (setq line-list (cons new-char line-list)) (incr char-count) (when (buffer-position-lessp (buffer-get-position) init-pos) (setf final-char-pos char-count)) (cond ((= new-char #\blank) (setf from-end-last-blanks 0) (setf from-start-last-blanks 1)) (t % normal character (incr from-end-last-blanks) (incr from-start-last-blanks)))) % The next sexp terminates sentences properly. (when (and line-not-full next-sentence-wont-exhaust-region) (setf line-list (append '(#\blank #\blank) line-list)) (incr char-count 2) (setf from-end-last-blanks 0) (setf from-start-last-blanks 2))) % The next sexp trims off the last partial word or extra blank(s). (when (or (char-blank? (car line-list)) % extra blank(s) (not (or line-not-full % last partial word (at-line-end?) (char-blank? (next-character))))) (for (from i 1 from-start-last-blanks 1) (do (setf line-list (cdr line-list)))) (move-over-characters (- from-end-last-blanks))) % guarantee that buffer-position is left at or before end (if (buffer-position-lessp end (buffer-get-position)) (buffer-set-position end)) (list line-list final-char-pos))) (de justify (input desired-length) % This function pads its input with blanks and reverses it. It % leaves point alone. (let* ((input-length (length input)) (output ()) (needed-blanks (- desired-length input-length)) % total number needed to fill out line (input-blanks % count preexisting blanks in input (for (in char input) (with blanks) (count (= char #\blank) blanks) (returns blanks)))) (for (in char input) (with (added-blanks 0) % number of new blanks added so far (handled-blanks 0)) % number of input blanks considered so far (do (setf output (cons char output)) (when (= char #\blank) (incr handled-blanks) % calculate number of new blanks needed here % fraction of original blanks passed=handled-blanks/input-blanks % blanks needed here~fraction*[needed-blanks(for whole line)]-(added-blanks) (let ((new-blanks (- (/ (* needed-blanks handled-blanks) input-blanks) added-blanks))) (when (> new-blanks 0) (for (from new 1 new-blanks 1) (do (setf output (cons #\blank output)))) (incr added-blanks new-blanks)))))) output)) (de position-adjusted-for-prefix (position) % This is a pure function which returns a position, corrected for % the length of the prefix on the position's line. (let ((current-place (buffer-get-position))) (buffer-set-position position) (mismatched-prefix?) (let ((prefix-length-or-zero (current-char-pos))) (buffer-set-position current-place) (let ((adjusted-char-pos (- (buffer-position-column position) prefix-length-or-zero))) (if (< adjusted-char-pos 0)(setf adjusted-char-pos 0)) (buffer-position-create (buffer-position-line position) adjusted-char-pos))))) (de remove-prefix-from-region (start end) % The main effect of this function is to strip the fill prefix off a % region in the buffer. this function does not return a useful value % or move point. (let ((current-place (buffer-get-position))) (buffer-set-position start) (if (current-line-empty?)(move-to-next-line)) (while (not (buffer-position-lessp end (buffer-get-position))) (setf start (buffer-get-position)) (unless (or (mismatched-prefix?) (buffer-position-lessp end (buffer-get-position))) (extract-text t start (buffer-get-position))) (move-to-next-line)) (buffer-set-position current-place))) (de fill-directed-region (start end init-pos) % The main effect of this function is to replace text with filled or % justified text. This function returns a list. The first element % is the increase in the number of lines in the text due to filling. % The second element is the filled position equivalent to "init-pos" % in the original text. The point is left at the end of the new % text (let ((modified-flag (=> nmode-current-buffer modified?)) (old-text (extract-text nil start end)) (final-pos init-pos) (adj-end (position-adjusted-for-prefix end)) (adj-init-pos (position-adjusted-for-prefix init-pos))) (when fill-prefix (remove-prefix-from-region start end)) (setf end adj-end) (buffer-set-position start) (let* ((list-of-new-lines (when % handles first blank line (current-line-empty?) (move-to-next-line) '(""))) (new-packed-line '(nil 0)) (prefix-list (if fill-prefix (string-to-list (getv fill-prefix 0)))) (prefix-column (map-char-to-column (list2string prefix-list) (length prefix-list))) (new-line nil) (place (buffer-get-position)) % handles indentation (junk (skip-forward-blanks)) % handles indentation (start-char-pos (+ (current-display-column) % handles indentation prefix-column)) % and first time switch (indent-list (string-to-list % handles indentation (getv (extract-text nil place (buffer-get-position)) 0)))) (while (let* ((after-line-start (buffer-position-lessp (buffer-get-position) adj-init-pos)) (new-packed-line (next-char-list end start-char-pos adj-init-pos)) (before-line-end (buffer-position-lessp adj-init-pos (buffer-get-position)))) (when (and after-line-start before-line-end) (setf final-pos (buffer-position-create (+ (buffer-position-line start) (length list-of-new-lines)) (second new-packed-line)))) % test that anything is left in the region, as well as getting line (setf new-line (first new-packed-line))) (setf new-line (list2string (append % add in fill prefix and indentation (append prefix-list (unless (= start-char-pos prefix-column) indent-list)) (if (and nmode-command-argument-given % triggers justification (not (or % don't justify the last line in a paragraph (buffer-position-lessp end (buffer-get-position)) (at-buffer-end?)))) (justify new-line (- fill-column start-char-pos)) (reverse new-line))))) (setf list-of-new-lines (cons new-line list-of-new-lines)) % only the first line in a paragraph is indented (setf start-char-pos prefix-column)) (setf list-of-new-lines (cons (list2string nil) list-of-new-lines)) % The last line in the new paragraph is added in last setf. (let ((line-change 0) (new-text (list2vector (reverse list-of-new-lines)))) (when list-of-new-lines (extract-text t start end) (setf line-change (- (size new-text) (size old-text))) (insert-text new-text) (if (and (not modified-flag) (text-equal new-text old-text)) (=> nmode-current-buffer set-modified? nil))) (list line-change final-pos))))) (de clip-region (limits region) % This is a pure function with no side effects. It returns the % "region" position pair, sorted so that first buffer position is % the first element, and clipped so that the region returned is % between the buffer-positions in "limits". (let ((limit-pair (if (buffer-position-lessp (cadr limits) (car limits)) (reverse limits) limits)) (region-pair (copy (if (buffer-position-lessp (cadr region) (car region)) (reverse region) region)))) (if (buffer-position-lessp (car region-pair) (car limit-pair)) (setf (car region-pair) (car limit-pair))) (if (buffer-position-lessp (cadr region-pair) (car limit-pair)) (setf (cadr region-pair) (car limit-pair))) (if (buffer-position-lessp (cadr limit-pair) (car region-pair)) (setf (car region-pair) (cadr limit-pair))) (if (buffer-position-lessp (cadr limit-pair) (cadr region-pair)) (setf (cadr region-pair) (cadr limit-pair))) region-pair)) (de fill-region-command () % This function replaces the text between point and the current mark % with a filled version of the same text. It leaves the % buffer-position at the end of the new text. It does not return % anything useful. (let* ((current-place (buffer-get-position)) (limits (list (current-mark) current-place))) (setf limits (if (buffer-position-lessp (car limits) (cadr limits)) limits (reverse limits))) (buffer-set-position (car limits)) (let ((at-limits nil)(new-region nil)(lines-advance 0)) (while (not at-limits) % paragraph loop (setf new-region (paragraph-limits)) (setf new-region (clip-region limits new-region)) (setf at-limits (= (car new-region) (cadr new-region))) (unless at-limits (setf lines-advance (first (fill-directed-region % expansion-of-text-information used (car new-region) (cadr new-region) current-place))) (setf limits % compensate for expansion of filled text (list (first limits) (let ((bottom (second limits))) (buffer-position-create (+ lines-advance (buffer-position-line bottom)) (buffer-position-column bottom)))))) (setf limits % guarantee that no text is filled twice (list (buffer-get-position)(second limits))))))) (de fill-paragraph-command () % This function replaces the next paragraph with filled version. It % leaves point at the a point bearing the same relation to the % filled text that the old point did to the old text. It does not % return a useful value. (let* ((current-place (buffer-get-position)) (pos-list (paragraph-limits))) (buffer-set-position (second (fill-directed-region (first pos-list) (second pos-list) current-place))))) (de fill-comment-command () % This function creates a temporary fill prefix from the start of % the current line. It replaces the surrounding paragraph % (determined using fill-prefix) with a filled version. It leaves % point at the a position bearing the same relation to the filled % text that the old point did to the old text. It does not return a % useful value. (let ((current-place (buffer-get-position))) (move-to-start-of-line) (let ((place (buffer-get-position))) % get fill prefix ends set up (skip-forward-blanks-in-line) (while (not (or (alphanumericp (next-character)) (at-line-end?) (char-blank? (next-character)))) (move-forward)) (skip-forward-blanks-in-line) (let* ((fill-prefix (extract-text nil place (buffer-get-position))) (pos-list (paragraph-limits))) (if (buffer-position-lessp (first pos-list) current-place) (buffer-set-position (second (fill-directed-region (first pos-list) (second pos-list) current-place))) (buffer-set-position current-place)))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Start of Misc Functions and Associated Support Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de center-current-line () % This function trims and centers the current line. It does not % return a useful value. It leaves point at a point in the text % equivalent to that before centering. (current-line-strip-indent) (let ((current-place (buffer-get-position))) (move-to-end-of-line) (strip-previous-blanks) (buffer-set-position current-place)) (let ((needed-blanks (/ (- fill-column (current-display-column)) 2))) (unless (minusp needed-blanks) (indent-current-line needed-blanks)))) (de center-line-command () % This function centers a number of lines, depending on the % argument. It leaves point at the end of the last line centered. % It does not return a useful value. (center-current-line) (when (> (abs nmode-command-argument) 1) (if (minusp nmode-command-argument) (for (from i 2 (- nmode-command-argument) 1) (do (move-to-previous-line) (center-current-line))) (for (from i 2 nmode-command-argument 1) (do (move-to-next-line) (center-current-line)))))) (de what-cursor-position-command () % This function tells the user where they are in the buffer or sets % point to the specified line number. It does not return a useful % value. (cond (nmode-command-number-given (set-line-pos nmode-command-argument) ) (t (write-message (if (at-buffer-end?) (bldmsg "X=%w Y=%w line=%w (%w percent of %w lines)" (current-display-column) (- (current-line-pos)(current-window-top-line)) (current-line-pos) (/ (* 100 (current-line-pos)) (current-buffer-visible-size)) (current-buffer-visible-size)) (bldmsg "X=%w Y=%w CH=%w line=%w (%w percent of %w lines)" (current-display-column) (- (current-line-pos)(current-window-top-line)) (next-character) % omitted at end of buffer (current-line-pos) (/ (* 100 (current-line-pos)) (current-buffer-visible-size)) (current-buffer-visible-size)))) ))) |
Added psl-1983/nmode/virtual-screen.b version [ceedd7cd2e].
cannot compute difference between binary files
Added psl-1983/nmode/virtual-screen.sl version [477b2e96b7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Virtual-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 August 1982 % Revised: 16 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A virtual screen is an object that can be used as independent rectangular % character display, but in fact shares a physical screen with other objects. A % virtual screen object maintains a stored representation of the image on the % virtual screen, which is used to update the physical screen when new areas of % the virtual screen become "exposed". A virtual screen does not itself % maintain any information about changes to its contents. It sends all changes % directly to the physical screen as they are made, and sends the entire screen % contents to the physical screen upon its request. % % A virtual screen is a legitimate "owner" for a shared physical screen, in that % it satisfies the required interface. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 28-Dec-82 Alan Snyder % Avoid writing to shared screen when virtual screen is not exposed. Add % WRITE-STRING and WRITE-VECTOR methods. Improve efficiency of CLEAR-TO-EOL % method. Remove patch that avoided old compiler bug. Reformat. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-virtual-screen (shared-physical-screen) (make-instance 'virtual-screen 'screen shared-physical-screen)) (defflavor virtual-screen ((height (=> screen height)) % number of rows (0 indexed) maxrow % highest numbered row (width (=> screen width)) % number of columns (0 indexed) maxcol % highest numbered column (row-origin 0) % position of upper left on the shared screen (column-origin 0) % position of upper left on the shared screen (default-enhancement (=> screen normal-enhancement)) (cursor-row 0) % the virtual cursor position (cursor-column 0) % the virtual cursor position (exposed? NIL) image % the virtual image screen % the shared-physical-screen ) () (gettable-instance-variables height width row-origin column-origin screen exposed?) (settable-instance-variables default-enhancement) (initable-instance-variables height width row-origin column-origin screen default-enhancement) ) (declare-flavor shared-physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (dm for-all-positions (form) % Executes the body repeatedly with the following variables % bound: ROW, COL, SCREEN-ROW, SCREEN-COL. `(for (from row 0 maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))))) (dm for-all-columns (form) % Executes the body repeatedly with the following variables % bound: COL, SCREEN-COL. `(for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen set-size) (new-height new-width) % Change the size of the screen. The screen is first DeExposed. The contents % are cleared. You must Expose the screen yourself if you want it to be % displayed. (=> self deexpose) (setf height new-height) (setf width new-width) (=> self &new-size) ) (defmethod (virtual-screen set-origin) (new-row new-column) % Change the location of the screen. The screen is first DeExposed. You must % Expose the screen yourself if you want it to be displayed. (=> self deexpose) (setf row-origin new-row) (setf column-origin new-column) ) (defmethod (virtual-screen set-cursor-position) (row column) (cond ((< row 0) (setf row 0)) ((> row maxrow) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((> column maxcol) (setf column maxcol))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (virtual-screen write) (ch row column) % Write one character using the default enhancement. (if (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc screen-row (+ column column-origin) self)) ))) (defmethod (virtual-screen write-range) (ch row left-column right-column) % Write repeatedly. (when (and (>= row 0) (<= row maxrow) (<= left-column maxcol) (>= right-column 0) ) (if (< left-column 0) (setf left-column 0)) (if (> right-column maxcol) (setf right-column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (for (from col left-column right-column) (do (image-store image row col dc) (if exposed? (=> screen write dc screen-row (+ col column-origin) self)) ))))) (defmethod (virtual-screen write-display-character) (dc row column) % Write one character (explicit enhancement) (when (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc (+ row row-origin) (+ column column-origin) self)) )) (defmethod (virtual-screen write-string) (row left-column s count) % S is a string of characters. Write S[0..COUNT-1] using the default % enhancement to the specified row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((smax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column smax) maxcol) (setf smax (- maxcol left-column))) (for (from i 0 smax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (string-fetch s i))) (setf ch (display-character-cons default-enhancement 0 ch)) (setf ch (=> screen convert-character ch)) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen write-vector) (row left-column v count) % V is a vector of display-characters. Write V[0..COUNT-1] to the specified % row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((vmax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column vmax) maxcol) (setf vmax (- maxcol left-column))) (for (from i 0 vmax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (vector-fetch v i))) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen clear) () (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for-all-positions (image-store image row col dc) ) (if exposed? (for-all-positions (=> screen write dc screen-row screen-col self) )) )) (defmethod (virtual-screen clear-to-end) (first-row) (if (< first-row 0) (setf first-row 0)) (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for (from row first-row maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for-all-columns (image-store image row col dc) ) (if exposed? (for-all-columns (=> screen write dc screen-row screen-col self) )) )))) (defmethod (virtual-screen clear-to-eol) (row first-column) (when (and (>= row 0) (<= row maxrow)) (if (< first-column 0) (setf first-column 0)) (let ((dc (display-character-cons default-enhancement 0 #\space)) (image-row (vector-fetch image row)) ) (setq dc (=> screen convert-character dc)) (for (from col first-column maxcol) (do (vector-store image-row col dc))) (if exposed? (let ((screen-row (+ row row-origin))) (for (from col (+ first-column column-origin) (+ maxcol column-origin)) (do (=> screen write dc screen-row col self))))) ))) (defmethod (virtual-screen expose) () % Expose the screen. Make it overlap all other screens. (=> screen select-primary-owner self) (setf exposed? T) ) (defmethod (virtual-screen deexpose) () % Remove the screen from the display. (when exposed? (=> screen remove-owner self) (setf exposed? NIL) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods: % The following methods are for use ONLY by the shared physical screen. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen send-changes) (breakout-allowed) % This method is invoked by the shared physical screen to obtain any buffered % changes to the virtual screen image. Since the virtual screen does not % buffer any changes, this method does nothing. ) (defmethod (virtual-screen send-contents) (breakout-allowed) % This method is invoked by the shared physical screen to obtain the entire % virtual screen image. (for-all-positions (let ((ch (image-fetch image row col))) (=> screen write ch screen-row screen-col self) ))) (defmethod (virtual-screen assert-ownership) () % This method is invoked by the shared physical screen to obtain the desired % area for the virtual screen. (=> screen set-owner-region row-origin column-origin height width self) ) (defmethod (virtual-screen screen-cursor-position) () % This method is invoked by the shared physical screen to obtain the desired % cursor position for the virtual screen. (cons (+ cursor-row row-origin) (+ cursor-column column-origin) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen init) (init-plist) (=> self &new-size) ) (defmethod (virtual-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf image (make-vector maxrow NIL)) (let ((line (make-vector maxcol #\space))) (for (from row 0 maxrow) (do (vector-store image row (copyvector line)))) ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor screen) |
Added psl-1983/nmode/window-label.b version [8f8efbdbee].
cannot compute difference between binary files
Added psl-1983/nmode/window-label.sl version [db48d3a328].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Window-Label.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 January 1983 % Revised: 16 February 1983 % % A Window-Label object maintains the "label" portion of a buffer-window. % This always occupies the lowermost "n" lines of the virtual screen, % where "n" is 1 by default in this implementation. % % 16-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 10-Feb-83 Alan Snyder % Fix bug: minor modes did not display. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors fast-strings display-char)) (de create-window-label (w) % Create a window-label object that will maintain the label portion % of the specified buffer-window. (make-instance 'window-label 'window w)) (defflavor window-label (window % the buffer-window object (height 1) % number of screen rows occupied by the label minrow % location of top row of the label maxrow % location of the bottom row of the label width % width of the screen maxcol % highest numbered screen column pos % current position while writing label screen % output screen while writing label (label-enhancement (dc-make-enhancement-mask INVERSE-VIDEO)) (prompt-enhancement (dc-make-enhancement-mask INVERSE-VIDEO INTENSIFY)) % The following instance variables store the various information used % in the construction of the label as currently displayed. This information % is saved so that it can be compared against the current information % to determine whether the displayed label needs to be recomputed. (buffer-name NIL) % name of buffer (as displayed) (buffer-mode NIL) % buffer's mode (as displayed) (minor-modes NIL) % minor mode list (as displayed) (buffer-file NIL) % buffer's filename (as displayed) (buffer-top NIL) % buffer-top (as used in label) (buffer-left NIL) % buffer-left (as used in label) (buffer-size NIL) % current buffer size (as used in label) (buffer-modified NIL) % buffer-modified flag (as used in label) (current-window NIL) % current-window (at time label was written) (prompt-string NIL) % PromptString* (at time label was written) ) () (gettable-instance-variables height ) (settable-instance-variables label-enhancement prompt-enhancement ) (initable-instance-variables window height ) ) (fluid '(nmode-major-window nmode-output-buffer nmode-minor-modes)) (declare-flavor text-buffer buffer) (declare-flavor buffer-window window) (declare-flavor virtual-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (window-label refresh) () % Update the label are to correspond to the % current state of the attached buffer window. % Conditionally rewrite the entire label, if any relevant % information has changed. (let ((buffer (=> window buffer))) (if (not (and (eq buffer-name (=> buffer name)) (eq buffer-mode (=> buffer mode)) (eq minor-modes nmode-minor-modes) (eq buffer-file (=> buffer file-name)) (= buffer-top (=> window buffer-top)) (= buffer-left (=> window buffer-left)) (= buffer-size (=> buffer visible-size)) (eq buffer-modified (=> buffer modified?)) (eq current-window nmode-major-window) (eq prompt-string PromptString*) )) (=> self &rewrite) ))) (defmethod (window-label resize) () % This method must be invoked whenever the window's size may have changed. (setf screen (=> window screen)) (setf width (=> screen width)) (setf maxrow (- (=> screen height) 1)) (setf minrow (- maxrow (- height 1))) (setf maxcol (- width 1)) (setf buffer-name NIL) % force complete rewrite ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (window-label init) (init-plist) (=> self resize) ) (defmethod (window-label &rewrite) () % Unconditionally rewrite the entire label. (let ((buffer (=> window buffer))) (setf screen (=> window screen)) (setf buffer-name (=> buffer name)) (setf buffer-mode (=> buffer mode)) (setf minor-modes nmode-minor-modes) (setf buffer-file (=> buffer file-name)) (setf buffer-top (=> window buffer-top)) (setf buffer-left (=> window buffer-left)) (setf buffer-size (=> buffer visible-size)) (setf buffer-modified (=> buffer modified?)) (setf current-window nmode-major-window) (if PromptString* (setf prompt-string PromptString*)) (let ((old-enhancement (=> screen default-enhancement))) (=> screen set-default-enhancement label-enhancement) (setf pos 0) (if (eq window current-window) (=> self &write-string "NMODE ") (=> self &write-string " ")) (=> self &write-string (=> buffer-mode name)) (if (and minor-modes (eq window current-window)) (let ((leader-string " (")) (for (in minor-mode minor-modes) (do (=> self &write-string leader-string) (setf leader-string " ") (=> self &write-string (=> minor-mode name)) )) (=> self &write-string ")") )) % Omit the buffer name if it is directly derived from the file name. (cond ((or (not buffer-file) (not (string= buffer-name (filename-to-buffername buffer-file)))) (=> self &write-string " [") (=> self &write-string buffer-name) (=> self &write-string "]") )) (when buffer-file (=> self &write-string " ") (=> self &write-string buffer-file) ) (when (> buffer-left 0) (=> self &write-string " >") (=> self &write-string (BldMsg "%d" buffer-left)) ) (cond ((and (= buffer-top 0) (<= buffer-size (=> window height))) % The entire buffer is showing on the screen. % Do nothing. ) ((= buffer-top 0) % The window is showing the top end of the buffer. (=> self &write-string " --TOP--") ) ((>= buffer-top (- buffer-size (=> window height))) % The window is showing the bottom end of the buffer. (=> self &write-string " --BOT--") ) (t % Otherwise... (let ((percentage (/ (* buffer-top 100) buffer-size))) (=> self &write-string " --") (=> self &write-char (+ #/0 (/ percentage 10))) (=> self &write-char (+ #/0 (// percentage 10))) (=> self &write-string "%--") ))) (if buffer-modified (=> self &write-string " *")) (when (and (StringP prompt-string) (eq buffer nmode-output-buffer)) (=> self &write-string " ") (=> self &advance-pos (- width (string-length prompt-string))) (=> screen set-default-enhancement prompt-enhancement) (=> self &write-string prompt-string) ) (=> screen clear-to-eol maxrow pos) (=> screen set-default-enhancement old-enhancement) ))) (defmethod (window-label &write-string) (string) (for (from i 0 (string-upper-bound string)) (do (=> screen write (string-fetch string i) maxrow pos) (setf pos (+ pos 1)) ))) (defmethod (window-label &write-char) (ch) (=> screen write ch maxrow pos) (setf pos (+ pos 1)) ) (defmethod (window-label &advance-pos) (col) (while (< pos col) (=> self &write-char #\space)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor buffer screen window) |
Added psl-1983/nmode/window.b version [ed484d20d2].
cannot compute difference between binary files
Added psl-1983/nmode/window.sl version [64e36497fa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Window.SL - Commands and Functions for manipulating windows. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 August 1982 % Revised: 30 December 1982 % % 30-Dec-82 Alan Snyder % Change scrolling commands to Ding if no scrolling is actually done. Fix bug % in backwards scroll by pages that failed to preserve relative cursor % position. Change behavior of scroll-by-pages upon excessive request. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load objects fast-int)) (fluid '(nmode-current-window nmode-command-argument nmode-command-number-given nmode-command-argument-given nmode-layout-mode )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de current-window-height () % Return the number of text lines displayable on the current window. (=> nmode-current-window height)) (de current-window-top-line () % Return the index of the buffer line at the top of the current window. (=> nmode-current-window buffer-top) ) (de current-window-set-top-line (new-top-line) % Change which buffer line displays at the top of the current window. (=> nmode-current-window set-buffer-top new-top-line) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de scroll-window-according-to-command (w) % Scroll the contents of the specified window according to the command % argument. If the command argument was set by C-U or C-U -, then scroll the % contents of the window up or down one page. Otherwise, scroll the window up % or down the specified number of lines. (if (and (or (= nmode-command-argument 1) (= nmode-command-argument -1)) (not nmode-command-number-given)) (scroll-window-by-pages w nmode-command-argument) (scroll-window-by-lines w nmode-command-argument) )) (de scroll-window-by-lines (w n) % Scroll the contents of the window up (n > 0) or down (n < 0) by |n| lines. % The "window position" may be adjusted to keep it within the window. Ding if % the window contents does not move. (let* ((old-top-line (=> w buffer-top)) (new-top-line (+ old-top-line n)) ) % adjust to keep something in the window (let ((buffer-last-line (- (=> (=> w buffer) visible-size) 1))) (cond ((< new-top-line 0) (setf new-top-line 0)) ((> new-top-line buffer-last-line) (setf new-top-line buffer-last-line)) )) % adjust "window position" if no longer in window (let ((line (=> w line-position)) (max (+ new-top-line (- (=> w height) 1))) ) (cond ((< line new-top-line) (=> w set-line-position new-top-line)) ((> line max) (=> w set-line-position max)) )) (if (~= old-top-line new-top-line) (=> w set-buffer-top new-top-line) (Ding) ))) (de scroll-window-by-pages (w n) % Scroll the contents of the window up (n > 0) or down (n < 0) by |n| % screenfuls. The "window position" may be adjusted to keep it within the % window. Ding if the window contents does not move. (let* ((old-top-line (=> w buffer-top)) (window-height (=> w height)) (buffer-last-line (- (=> (=> w buffer) visible-size) 1)) (new-top-line old-top-line) ) (if (>= n 0) % moving towards the end of the buffer (for (from i 1 n) % do as many complete screenfuls as possible (do (let ((next-top-line (+ new-top-line window-height))) (if (<= next-top-line buffer-last-line) (setf new-top-line next-top-line) (exit) )))) % moving towards the beginning of the buffer (setf new-top-line (max 0 (+ new-top-line (* n window-height)))) ) (if (~= new-top-line old-top-line) % keep the cursor at the same relative location in the window! (let ((delta (- new-top-line old-top-line))) (=> w set-line-position (min (+ (=> w line-position) delta) (+ buffer-last-line 1))) (=> w set-buffer-top new-top-line) ) % otherwise (no change) (Ding) ))) (de scroll-window-horizontally (w n) % Scroll the contents of the specified window left (n > 0) or right (n < 0) % by |n| columns. (let ((old-buffer-left (=> w buffer-left))) (=> w set-buffer-left (+ old-buffer-left n)) (if (= old-buffer-left (=> w buffer-left)) (Ding)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Scrolling Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de next-screen-command () (scroll-window-according-to-command nmode-current-window) ) (de previous-screen-command () (setf nmode-command-argument (- 0 nmode-command-argument)) (scroll-window-according-to-command nmode-current-window) ) (de scroll-other-window-command () (selectq nmode-layout-mode (1 (Ding)) (2 (scroll-window-according-to-command (nmode-other-window))) )) (de scroll-window-up-line-command () (scroll-window-by-lines nmode-current-window nmode-command-argument) ) (de scroll-window-down-line-command () (scroll-window-by-lines nmode-current-window (- nmode-command-argument)) ) (de scroll-window-up-page-command () (scroll-window-by-pages nmode-current-window nmode-command-argument) ) (de scroll-window-down-page-command () (scroll-window-by-pages nmode-current-window (- nmode-command-argument)) ) (de scroll-window-right-command () (scroll-window-horizontally nmode-current-window nmode-command-argument) ) (de scroll-window-left-command () (scroll-window-horizontally nmode-current-window (- nmode-command-argument)) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window Adjusting Commands %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de nmode-adjust-window (w) % Adjust BUFFER-TOP to show current position. (=> w adjust-window) ) (de move-to-screen-edge-command () (let* ((n nmode-command-argument) (line (current-line-pos)) (top (current-window-top-line)) (height (current-window-height)) ) (set-line-pos (+ top (cond ((not nmode-command-argument-given) (/ height 2)) ((>= n 0) n) (t (+ height n)) ))))) |
Added psl-1983/nonkernel/char-macro.b version [fc75584e97].
cannot compute difference between binary files
Added psl-1983/nonkernel/char-macro.sl version [6490dac554].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CHAR-MACRO.SL - Character constant macro % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 August 1981 % Copyright (c) 1981 University of Utah % % Edit by Cris Perdue, 1 Feb 1983 1355-PST % pk:char.red merged with the version in USEFUL. Some symbolic names % for characters removed (not needed, I hope). (dm Char (U) %. Character constant macro (DoChar (cadr U))) % Table driven char macro expander (de DoChar (u) (cond ((idp u) (or (get u 'CharConst) ((lambda (n) (cond ((lessp n 128) n))) (id2int u)) (CharError u))) ((pairp u) % Here's the real change -- let users add "functions" ((lambda (fn) (cond (fn (apply fn (list (dochar (cadr u))))) (t (CharError u)))) (cond ((idp (car u)) (get (car u) 'char-prefix-function))))) ((and (fixp u) (geq u 0) (leq u 9)) (plus u #\!0)) (t (CharError u)))) (deflist `((lower ,(function (lambda(x) (lor x 2#100000)))) (quote ,(function (lambda(x) x))) (control ,(function (lambda(x) (land x 2#11111)))) (cntrl ,(function (lambda(x) (land x 2#11111)))) (meta ,(function (lambda(x) (lor x 2#10000000))))) 'char-prefix-function) (de CharError (u) (ErrorPrintF "*** Unknown character constant: %r" u) 0) (DefList '((NULL 0) (BELL 7) (BACKSPACE 8) (TAB 8#11) (LF 8#12) % (RETURN 8#12) % RETURN is LF: it's end-of-line. Out! /csp (EOL 8#12) (FF 8#14) (CR 8#15) (ESC 27) (ESCAPE 27) (BLANK 32) (SPACE 32) (RUB 8#177) (RUBOUT 8#177) (DEL 8#177) (DELETE 8#177) ) 'CharConst) |
Added psl-1983/psl.exe version [f9ed4b1dda].
cannot compute difference between binary files
Added psl-1983/pslcomp.exe version [b3f5d9ad1e].
cannot compute difference between binary files
Added psl-1983/rlisp.exe version [6699edf929].
cannot compute difference between binary files
Added psl-1983/tests/all-test.headers version [9ebd94532a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | "XXX-HEADER.RED"$ MAIN2 6/1 FIRSTCALL; MAIN2 14/2 UNDEFINEDFUNCTIONAUX; MAIN2 77/3 "PT:MINI-CHAR-IO.RED"$ SUB2 3/1 "PT:MINI-PRINTERS.RED"$ SUB2 4/2 "PT:MINI-ERROR-ERRORSET.RED"$ SUB2 5/3 "PT:MINI-ERROR-HANDLERS.RED"$ SUB2 6/4 "PT:MINI-TYPE-ERRORS.RED"$ SUB2 7/5 "XXX-HEADER.RED"$ MAIN3 6/1 "PT:STUBS3.RED"$ MAIN3 7/2 FIRSTCALL; MAIN3 12/3 CASETEST; MAIN3 23/4 CTEST N; MAIN3 41/5 SHOW(N,S); MAIN3 49/6 CONSTEST(); MAIN3 56/7 UNDEFINEDFUNCTIONAUX; MAIN3 68/8 "PT:MINI-ALLOCATORS.RED"$ SUB3 3/1 "PT:MINI-CONS-MKVECT.RED"$ SUB3 4/2 "PT:MINI-COMP-SUPPORT.RED"$ SUB3 5/3 "PT:MINI-SEQUENCE.RED"$ SUB3 7/4 "PT:MINI-GC.RED"$ STUBS3 4/1 "XXX-HEADER.RED"$ MAIN4 5/1 "PT:P-FUNCTION-PRIMITIVES.RED"$ MAIN4 6/2 "PT:STUBS4.RED"$ MAIN4 7/3 "PT:STUBS3.RED"$ MAIN4 8/4 FIRSTCALL; MAIN4 15/5 MORESTUFF; MAIN4 68/6 FUNCTIONTEST(); MAIN4 74/7 COMPILED1; MAIN4 124/8 COMPILED2; MAIN4 128/9 COMPILED3(A1,A2,A3,A4); MAIN4 132/10 UNDEFINEDFUNCTIONAUXAUX ; MAIN4 142/11 COMPILEDCALLINGINTERPRETEDAUX(); MAIN4 155/12 "PT:MINI-EQUAL.RED"$ SUB4 6/1 "PT:MINI-TOKEN.RED"$ SUB4 7/2 "PT:MINI-READ.RED"$ SUB4 8/3 SPACED(M); STUBS4 3/1 DASHED(M); STUBS4 7/2 DOTTED(M); STUBS4 12/3 SHOULDBE(M,V,E); STUBS4 18/4 "XXX-HEADER.RED"$ MAIN5 4/1 "PT:STUBS3.RED"$ MAIN5 5/2 "PT:STUBS4.RED"$ MAIN5 6/3 "PT:STUBS5.RED"$ MAIN5 7/4 FIRSTCALL; MAIN5 13/5 TESTSERIES(); MAIN5 45/6 TESTGET(); MAIN5 49/7 TESTUNDEFINED; MAIN5 59/8 UNBINDN N; MAIN5 64/9 LBIND1(X,Y); MAIN5 67/10 "PT:P-FUNCTION-PRIMITIVES.RED"$ SUB5 5/1 "PT:P-APPLY-LAP.RED"$ SUB5 6/2 "PT:MINI-ARITHMETIC.RED"$ SUB5 8/3 "PT:MINI-CARCDR.RED"$ SUB5 9/4 "PT:MINI-EASY-SL.RED"$ SUB5 10/5 "PT:MINI-EASY-NON-SL.RED"$ SUB5 11/6 "PT:MINI-EVAL-APPLY.RED"$ SUB5 12/7 "PT:MINI-KNOWN-TO-COMP.RED"$ SUB5 13/8 "PT:MINI-LOOP-MACROS.RED"$ SUB5 14/9 "PT:MINI-OTHERS-SL.RED"$ SUB5 15/10 "PT:MINI-OBLIST.RED"$ SUB5 16/11 "PT:MINI-PROPERTY-LIST.RED"$ SUB5 17/12 "PT:MINI-SYMBOL-VALUES.RED"$ SUB5 18/13 UNDEFINEDFUNCTIONAUXAUX; STUBS5 6/1 INF X; STUBS5 22/2 TAG X; STUBS5 25/3 MKITEM(X,Y); STUBS5 28/4 "XXX-HEADER.RED"$ MAIN6 5/1 "PT:STUBS3.RED"$ MAIN6 6/2 "PT:STUBS4.RED"$ MAIN6 7/3 "PT:STUBS5.RED"$ MAIN6 8/4 "PT:STUBS6.RED"$ MAIN6 9/5 FIRSTCALL; MAIN6 15/6 TESTSERIES(); MAIN6 48/7 BINDINGTEST; MAIN6 55/8 INTERPTEST(); MAIN6 71/9 TESTFASTAPPLY EXPR 0) MAIN6 102/10 TESTAPPLY(MSG,FN,ANSWER); MAIN6 107/11 COMPILED1(XXX,YYY); MAIN6 117/12 COMPILED2(XXX,YYY); MAIN6 122/13 COMPBINDTEST(); MAIN6 129/14 CBIND1(X,CFL1,CFL2); MAIN6 139/15 CBIND2(); MAIN6 149/16 "PK:BINDING.RED"$ SUB6 3/1 "PT:P-FAST-BINDER.RED"$ SUB6 4/2 "PT:MINI-PUTD-GETD.RED"$ SUB6 6/3 RESET(); SUB6 8/4 "PT:MINI-PRINTF.RED"$ STUBS6 3/1 "PT:MINI-TOP-LOOP.RED"$ STUBS6 4/2 FUNCALL(FN,I); STUBS6 8/3 "XXX-HEADER.RED"$ MAIN7 5/1 "PT:STUBS3.RED"$ MAIN7 6/2 "PT:STUBS4.RED"$ MAIN7 7/3 "PT:STUBS5.RED"$ MAIN7 8/4 "PT:STUBS6.RED"$ MAIN7 9/5 "PT:STUBS7.RED"$ MAIN7 10/6 "PT:PSL-TIMER.SL"$ MAIN7 11/7 FIRSTCALL; MAIN7 17/8 IOTEST; MAIN7 61/9 "XXX-SYSTEM-IO.RED"$ SUB7 5/1 "PT:IO-DATA.RED"$ SUB7 6/2 "PT:MINI-IO-ERRORS.RED"$ SUB7 7/3 "PT:MINI-DSKIN.RED"$ SUB7 8/4 "PT:MINI-OPEN-CLOSE.RED"$ SUB7 9/5 "PT:MINI-RDS-WRS.RED"$ SUB7 10/6 "PT:SYSTEM-IO.RED"$ SUB7 11/7 GTHEAP N; MINI-ALLOCATOR 14/1 GTSTR N; MINI-ALLOCATOR 27/2 GTVECT N; MINI-ALLOCATOR 36/3 GTWARRAY N; MINI-ALLOCATOR 44/4 GTID(); MINI-ALLOCATOR 48/5 PLUS2(X,Y); MINI-ARITHMETI 5/1 MINUS(X); MINI-ARITHMETI 9/2 ADD1 N; MINI-ARITHMETI 13/3 SUB1 N; MINI-ARITHMETI 17/4 GREATERP(N1,N2); MINI-ARITHMETI 21/5 LESSP(N1,N2); MINI-ARITHMETI 24/6 DIFFERENCE(N1,N2); MINI-ARITHMETI 28/7 CAR X; MINI-CARCDR 5/1 CDR X; MINI-CARCDR 8/2 CAAR X; MINI-CARCDR 13/3 CADR X; MINI-CARCDR 16/4 CDAR X; MINI-CARCDR 19/5 CDDR X; MINI-CARCDR 22/6 CHANNELWRITECHAR(CHN,X); MINI-CHAR-IO 3/1 WRITECHAR CH; MINI-CHAR-IO 6/2 LIST2(A1,A2); MINI-COMP-SUPP 4/1 LIST3(A1,A2,A3); MINI-COMP-SUPP 7/2 LIST4(A1,A2,A3,A4); MINI-COMP-SUPP 10/3 LIST5(A1,A2,A3,A4,A5); MINI-COMP-SUPP 13/4 HARDCONS(X,Y); MINI-CONS-MKVE 6/1 CONS(X,Y); MINI-CONS-MKVE 14/2 XCONS(X,Y); MINI-CONS-MKVE 17/3 NCONS X; MINI-CONS-MKVE 20/4 MKVECT N; MINI-CONS-MKVE 23/5 TYPEFILE F; MINI-DSKIN 3/1 DSKIN F; MINI-DSKIN 12/2 LAPIN F; MINI-DSKIN 25/3 ATSOC(X,Y); MINI-EASY-NON- 3/1 GEQ(N1,N2); MINI-EASY-NON- 9/2 LEQ(N1,N2); MINI-EASY-NON- 12/3 EQCAR(X,Y); MINI-EASY-NON- 15/4 COPYD(NEWID,OLDID); MINI-EASY-NON- 18/5 DELATQ(X,Y); MINI-EASY-NON- 28/6 ATOM X; MINI-EASY-SL 8/1 APPEND(U,V); MINI-EASY-SL 13/2 MEMQ(X,Y); MINI-EASY-SL 17/3 REVERSE U; MINI-EASY-SL 22/4 EVLIS X; MINI-EASY-SL 31/5 EVPROGN FL; MINI-EASY-SL 35/6 PROGN X; MINI-EASY-SL 42/7 EVCOND FL; MINI-EASY-SL 45/8 COND X; MINI-EASY-SL 51/9 QUOTE A; MINI-EASY-SL 54/10 SETQ A; MINI-EASY-SL 57/11 DE(X); MINI-EASY-SL 60/12 DF(X); MINI-EASY-SL 63/13 DN(X); MINI-EASY-SL 66/14 DM(X); MINI-EASY-SL 69/15 LIST X; MINI-EASY-SL 73/16 EQSTR(S1,S2); MINI-EQUAL 5/1 ERRORHEADER; MINI-ERROR-ERR 4/1 ERROR S; MINI-ERROR-ERR 7/2 ERRORTRAILER S; MINI-ERROR-ERR 11/3 FATALERROR S; MINI-ERROR-HAN 5/1 STDERROR M; MINI-ERROR-HAN 8/2 INITEVAL; MINI-EVAL-APPL 5/1 EVAL X; MINI-EVAL-APPL 19/2 APPLY(FN,A); MINI-EVAL-APPL 43/3 LAMBDAAPPLY(X,A); MINI-EVAL-APPL 60/4 LAMBDAEVALAPPLY(X,Y); MINI-EVAL-APPL 68/5 DOLAMBDA(VARS,BODY,ARGS); MINI-EVAL-APPL 71/6 LAMBDAP(X); MINI-EVAL-APPL 86/7 GETLAMBDA(FN); MINI-EVAL-APPL 89/8 !%RECLAIM(); MINI-GC 9/1 RECLAIM(); MINI-GC 13/2 HEAPINFO(); MINI-GC 17/3 IOERROR M; MINI-IO-ERRORS 3/1 CODEP X; MINI-KNOWN-TO- 3/1 PAIRP X; MINI-KNOWN-TO- 6/2 IDP X; MINI-KNOWN-TO- 9/3 EQ(X,Y); MINI-KNOWN-TO- 12/4 NULL X; MINI-KNOWN-TO- 15/5 NOT X; MINI-KNOWN-TO- 18/6 WHILE FL; MINI-LOOP-MACR 3/1 MAPOBL(FN); MINI-OBLIST 6/1 PRINTFEXPRS; MINI-OBLIST 9/2 PRINT1FEXPR(X); MINI-OBLIST 12/3 PRINTFUNCTIONS; MINI-OBLIST 15/4 PRINT1FUNCTION(X); MINI-OBLIST 18/5 OPEN(FILENAME,HOW); MINI-OPEN-CLOS 3/1 CLOSE N; MINI-OPEN-CLOS 8/2 LENGTH U; MINI-OTHERS-SL 4/1 LENGTH1(U, N); MINI-OTHERS-SL 8/2 PRIN1 X; MINI-PRINTERS 8/1 PRIN2 X; MINI-PRINTERS 15/2 PRINT X; MINI-PRINTERS 22/3 PRIN2T X; MINI-PRINTERS 25/4 PBLANK; MINI-PRINTERS 30/5 PRIN1INT X; MINI-PRINTERS 33/6 PRIN1INTX X; MINI-PRINTERS 40/7 PRIN1ID X; MINI-PRINTERS 45/8 PRIN2ID X; MINI-PRINTERS 50/9 PRIN1STRING X; MINI-PRINTERS 53/10 PRIN2STRING X; MINI-PRINTERS 60/11 PRIN1PAIR X; MINI-PRINTERS 67/12 PRIN2PAIR X; MINI-PRINTERS 78/13 TERPRI(); MINI-PRINTERS 89/14 PRTITM X; MINI-PRINTERS 92/15 CHANNELPRIN2(CHN,X); MINI-PRINTERS 102/16 BLDMSG(FMT,A1,A2,A3,A4,A5,A6); MINI-PRINTF 3/1 PROP X; MINI-PROPERTY- 5/1 GET(X,Y); MINI-PROPERTY- 9/2 PUT(X,Y,Z); MINI-PROPERTY- 17/3 REMPROP(X,Y); MINI-PROPERTY- 28/4 GETFNTYPE X; MINI-PROPERTY- 38/5 GETD(FN); MINI-PUTD-GETD 6/1 PUTD(FN,TYPE,BODY); MINI-PUTD-GETD 21/2 RDS N; MINI-RDS-WRS 5/1 WRS N; MINI-RDS-WRS 13/2 READ; MINI-READ 6/1 READ1(X); MINI-READ 10/2 READLIST(X); MINI-READ 15/3 MKSTRING(L, C); MINI-SEQUENCE 5/1 SET(X,Y); MINI-SYMBOL-VA 3/1 INITREAD; MINI-TOKEN 11/1 SETRAISE X; MINI-TOKEN 21/2 RATOM; MINI-TOKEN 24/3 CLEARWHITE(); MINI-TOKEN 41/4 CLEARCOMMENT(); MINI-TOKEN 45/5 READINT; MINI-TOKEN 50/6 BUFFERTOSTRING N; MINI-TOKEN 59/7 READSTR; MINI-TOKEN 67/8 READID; MINI-TOKEN 77/9 RAISECHAR C; MINI-TOKEN 88/10 INTERN S; MINI-TOKEN 95/11 INITNEWID(D,S); MINI-TOKEN 105/12 LOOKUPID(S); MINI-TOKEN 115/13 WHITEP X; MINI-TOKEN 131/14 DIGITP X; MINI-TOKEN 135/15 ALPHAP(X); MINI-TOKEN 138/16 UPPERCASEP X; MINI-TOKEN 141/17 LOWERCASEP X; MINI-TOKEN 144/18 ESCAPEP X; MINI-TOKEN 147/19 ALPHAESCP X; MINI-TOKEN 150/20 ALPHANUMP X; MINI-TOKEN 153/21 ALPHANUMESCP X; MINI-TOKEN 156/22 TIME(); MINI-TOP-LOOP 3/1 TYPEERROR(OFFENDER, FN, TYP); MINI-TYPE-ERRO 3/1 USAGETYPEERROR(OFFENDER, FN, TYP, USAGE); MINI-TYPE-ERRO 15/2 NONIDERROR(X,Y); MINI-TYPE-ERRO 29/3 NONNUMBERERROR(OFFENDER, FN); MINI-TYPE-ERRO 32/4 NONINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 35/5 NONPOSITIVEINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 38/6 CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 CODEEVALAPPLYAUX(CODEPTR, ARGLIST, P); P-APPLY-LAP 213/3 BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 COMPILEDCALLINGINTERPRETEDAUXAUX FN; P-APPLY-LAP 391/8 LAMBIND V; P-FAST-BINDER 23/1 PROGBIND V; P-FAST-BINDER 32/2 SYMFNCBASE D; % THE ADDRESS OF CELL, P-FUNCTION-PRI 57/1 FUNBOUNDP FN; P-FUNCTION-PRI 65/2 MAKEFUNBOUND(D); P-FUNCTION-PRI 73/3 FLAMBDALINKP FN; P-FUNCTION-PRI 79/4 MAKEFLAMBDALINK D; P-FUNCTION-PRI 85/5 FCODEP FN; P-FUNCTION-PRI 91/6 MAKEFCODE(U, CODEPTR); P-FUNCTION-PRI 96/7 GETFCODEPOINTER U; P-FUNCTION-PRI 106/8 CODEPRIMITIVE EXPR 15) P-FUNCTION-PRI 121/9 COMPILEDCALLINGINTERPRETED EXPR 15) P-FUNCTION-PRI 136/10 FASTAPPLY EXPR 0) P-FUNCTION-PRI 153/11 SAVEREGISTERS(A1, A2, A3, A4, A5, P-FUNCTION-PRI 193/12 UNDEFINEDFUNCTIONAUX EXPR 0) P-FUNCTION-PRI 214/13 ERNAL WCONST STACKSIZE = 5000; P20T:XXX-HEADE 11/1 ERNAL WARRAY STACK[STACKSIZE]; P20T:XXX-HEADE 12/2 ERNAL WCONST HEAPSIZE = 150000; % ENOUGH FOR PSL-TIM P20T:XXX-HEADE 21/3 ERNAL WARRAY HEAP[HEAPSIZE]; % COULD DO A DYNAMIC A P20T:XXX-HEADE 22/4 ERNAL WARRAY OTHERHEAP[HEAPSIZE]; P20T:XXX-HEADE 30/5 ERNAL WCONST BPSSIZE = 500; P20T:XXX-HEADE 36/6 ERNAL WARRAY BPS[BPSSIZE]; % COULD DO A DYNAMIC ALL P20T:XXX-HEADE 37/7 INITHEAP(); P20T:XXX-HEADE 44/8 ERNAL WCONST MAXARGBLOCK = (MAXARGS - MAXREALREGS) - P20T:XXX-HEADE 53/9 MAIN!. EXPR 0) P20T:XXX-HEADE 64/10 INIT(); P20T:XXX-HEADE 88/11 GETC(); P20T:XXX-HEADE 94/12 TIMC(); P20T:XXX-HEADE 98/13 PUTC X; P20T:XXX-HEADE 101/14 QUIT; P20T:XXX-HEADE 105/15 DATE; P20T:XXX-HEADE 108/16 VERSIONNAME; P20T:XXX-HEADE 111/17 PUTINT I; P20T:XXX-HEADE 114/18 !%STORE!-JCALL EXPR 2) % CODEADDRESS, STORAGE ADDRESS P20T:XXX-HEADE 118/19 !%COPY!-FUNCTION!-CELL EXPR 2) % FROM TO P20T:XXX-HEADE 124/20 UNDEFINEDFUNCTION EXPR 0) % FOR MISSING FUNCTION P20T:XXX-HEADE 131/21 FLAG EXPR 2) % DUMMY FOR INIT P20T:XXX-HEADE 138/22 LONGTIMES(X,Y); P20T:XXX-HEADE 144/23 LONGDIV(X,Y); P20T:XXX-HEADE 147/24 LONGREMAINDER(X,Y); P20T:XXX-HEADE 150/25 SYSCLEARIO EXPR 0) P20T:XXX-SYSTE 30/1 SYSOPENREAD(CHANNEL,FILENAME); P20T:XXX-SYSTE 44/2 SYSOPENWRITE(CHANNEL,FILENAME); P20T:XXX-SYSTE 56/3 DEC20OPEN EXPR 3) P20T:XXX-SYSTE 64/4 SYSREADREC(FILEDESCRIPTOR,STRINGBUFFER); P20T:XXX-SYSTE 83/5 DEC20READCHAR EXPR 1) P20T:XXX-SYSTE 98/6 SYSWRITEREC (FILEDESCRIPTOR, STRINGTOWRITE, STRINGLE P20T:XXX-SYSTE 123/7 DEC20WRITECHAR EXPR 2) P20T:XXX-SYSTE 130/8 SYSCLOSE EXPR 1) P20T:XXX-SYSTE 145/9 SYSMAXBUFFER(FILEDESC); P20T:XXX-SYSTE 154/10 2945 lines, 312 procedures found |
Added psl-1983/tests/all-test.sorted version [2dd3297367].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 2945 lines, 312 procedures found SYSWRITEREC (FILEDESCRIPTOR, STRINGTOWRITE, STRINGLE P20T:XXX-SYSTE 123/7 !%COPY!-FUNCTION!-CELL EXPR 2) % FROM TO P20T:XXX-HEADE 124/20 !%RECLAIM(); MINI-GC 9/1 !%STORE!-JCALL EXPR 2) % CODEADDRESS, STORAGE ADDRESS P20T:XXX-HEADE 118/19 "PK:BINDING.RED"$ SUB6 3/1 "PT:IO-DATA.RED"$ SUB7 6/2 "PT:MINI-ALLOCATORS.RED"$ SUB3 3/1 "PT:MINI-ARITHMETIC.RED"$ SUB5 8/3 "PT:MINI-CARCDR.RED"$ SUB5 9/4 "PT:MINI-CHAR-IO.RED"$ SUB2 3/1 "PT:MINI-COMP-SUPPORT.RED"$ SUB3 5/3 "PT:MINI-CONS-MKVECT.RED"$ SUB3 4/2 "PT:MINI-DSKIN.RED"$ SUB7 8/4 "PT:MINI-EASY-NON-SL.RED"$ SUB5 11/6 "PT:MINI-EASY-SL.RED"$ SUB5 10/5 "PT:MINI-EQUAL.RED"$ SUB4 6/1 "PT:MINI-ERROR-ERRORSET.RED"$ SUB2 5/3 "PT:MINI-ERROR-HANDLERS.RED"$ SUB2 6/4 "PT:MINI-EVAL-APPLY.RED"$ SUB5 12/7 "PT:MINI-GC.RED"$ STUBS3 4/1 "PT:MINI-IO-ERRORS.RED"$ SUB7 7/3 "PT:MINI-KNOWN-TO-COMP.RED"$ SUB5 13/8 "PT:MINI-LOOP-MACROS.RED"$ SUB5 14/9 "PT:MINI-OBLIST.RED"$ SUB5 16/11 "PT:MINI-OPEN-CLOSE.RED"$ SUB7 9/5 "PT:MINI-OTHERS-SL.RED"$ SUB5 15/10 "PT:MINI-PRINTERS.RED"$ SUB2 4/2 "PT:MINI-PRINTF.RED"$ STUBS6 3/1 "PT:MINI-PROPERTY-LIST.RED"$ SUB5 17/12 "PT:MINI-PUTD-GETD.RED"$ SUB6 6/3 "PT:MINI-RDS-WRS.RED"$ SUB7 10/6 "PT:MINI-READ.RED"$ SUB4 8/3 "PT:MINI-SEQUENCE.RED"$ SUB3 7/4 "PT:MINI-SYMBOL-VALUES.RED"$ SUB5 18/13 "PT:MINI-TOKEN.RED"$ SUB4 7/2 "PT:MINI-TOP-LOOP.RED"$ STUBS6 4/2 "PT:MINI-TYPE-ERRORS.RED"$ SUB2 7/5 "PT:P-APPLY-LAP.RED"$ SUB5 6/2 "PT:P-FAST-BINDER.RED"$ SUB6 4/2 "PT:P-FUNCTION-PRIMITIVES.RED"$ MAIN4 6/2 "PT:P-FUNCTION-PRIMITIVES.RED"$ SUB5 5/1 "PT:PSL-TIMER.SL"$ MAIN7 11/7 "PT:STUBS3.RED"$ MAIN3 7/2 "PT:STUBS3.RED"$ MAIN4 8/4 "PT:STUBS3.RED"$ MAIN5 5/2 "PT:STUBS3.RED"$ MAIN6 6/2 "PT:STUBS3.RED"$ MAIN7 6/2 "PT:STUBS4.RED"$ MAIN4 7/3 "PT:STUBS4.RED"$ MAIN5 6/3 "PT:STUBS4.RED"$ MAIN6 7/3 "PT:STUBS4.RED"$ MAIN7 7/3 "PT:STUBS5.RED"$ MAIN5 7/4 "PT:STUBS5.RED"$ MAIN6 8/4 "PT:STUBS5.RED"$ MAIN7 8/4 "PT:STUBS6.RED"$ MAIN6 9/5 "PT:STUBS6.RED"$ MAIN7 9/5 "PT:STUBS7.RED"$ MAIN7 10/6 "PT:SYSTEM-IO.RED"$ SUB7 11/7 "XXX-HEADER.RED"$ MAIN2 6/1 "XXX-HEADER.RED"$ MAIN3 6/1 "XXX-HEADER.RED"$ MAIN4 5/1 "XXX-HEADER.RED"$ MAIN5 4/1 "XXX-HEADER.RED"$ MAIN6 5/1 "XXX-HEADER.RED"$ MAIN7 5/1 "XXX-SYSTEM-IO.RED"$ SUB7 5/1 ADD1 N; MINI-ARITHMETI 13/3 ALPHAESCP X; MINI-TOKEN 150/20 ALPHANUMESCP X; MINI-TOKEN 156/22 ALPHANUMP X; MINI-TOKEN 153/21 ALPHAP(X); MINI-TOKEN 138/16 APPEND(U,V); MINI-EASY-SL 13/2 APPLY(FN,A); MINI-EVAL-APPL 43/3 ATOM X; MINI-EASY-SL 8/1 ATSOC(X,Y); MINI-EASY-NON- 3/1 BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 BINDINGTEST; MAIN6 55/8 BLDMSG(FMT,A1,A2,A3,A4,A5,A6); MINI-PRINTF 3/1 BUFFERTOSTRING N; MINI-TOKEN 59/7 CAAR X; MINI-CARCDR 13/3 CADR X; MINI-CARCDR 16/4 CAR X; MINI-CARCDR 5/1 CASETEST; MAIN3 23/4 CBIND1(X,CFL1,CFL2); MAIN6 139/15 CBIND2(); MAIN6 149/16 CDAR X; MINI-CARCDR 19/5 CDDR X; MINI-CARCDR 22/6 CDR X; MINI-CARCDR 8/2 CHANNELPRIN2(CHN,X); MINI-PRINTERS 102/16 CHANNELWRITECHAR(CHN,X); MINI-CHAR-IO 3/1 CLEARCOMMENT(); MINI-TOKEN 45/5 CLEARWHITE(); MINI-TOKEN 41/4 CLOSE N; MINI-OPEN-CLOS 8/2 CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 CODEEVALAPPLYAUX(CODEPTR, ARGLIST, P); P-APPLY-LAP 213/3 CODEP X; MINI-KNOWN-TO- 3/1 CODEPRIMITIVE EXPR 15) P-FUNCTION-PRI 121/9 COMPBINDTEST(); MAIN6 129/14 COMPILED1(XXX,YYY); MAIN6 117/12 COMPILED1; MAIN4 124/8 COMPILED2(XXX,YYY); MAIN6 122/13 COMPILED2; MAIN4 128/9 COMPILED3(A1,A2,A3,A4); MAIN4 132/10 COMPILEDCALLINGINTERPRETED EXPR 15) P-FUNCTION-PRI 136/10 COMPILEDCALLINGINTERPRETEDAUX(); MAIN4 155/12 COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 COMPILEDCALLINGINTERPRETEDAUXAUX FN; P-APPLY-LAP 391/8 COND X; MINI-EASY-SL 51/9 CONS(X,Y); MINI-CONS-MKVE 14/2 CONSTEST(); MAIN3 56/7 COPYD(NEWID,OLDID); MINI-EASY-NON- 18/5 CTEST N; MAIN3 41/5 DASHED(M); STUBS4 7/2 DATE; P20T:XXX-HEADE 108/16 DE(X); MINI-EASY-SL 60/12 DEC20OPEN EXPR 3) P20T:XXX-SYSTE 64/4 DEC20READCHAR EXPR 1) P20T:XXX-SYSTE 98/6 DEC20WRITECHAR EXPR 2) P20T:XXX-SYSTE 130/8 DELATQ(X,Y); MINI-EASY-NON- 28/6 DF(X); MINI-EASY-SL 63/13 DIFFERENCE(N1,N2); MINI-ARITHMETI 28/7 DIGITP X; MINI-TOKEN 135/15 DM(X); MINI-EASY-SL 69/15 DN(X); MINI-EASY-SL 66/14 DOLAMBDA(VARS,BODY,ARGS); MINI-EVAL-APPL 71/6 DOTTED(M); STUBS4 12/3 DSKIN F; MINI-DSKIN 12/2 EQ(X,Y); MINI-KNOWN-TO- 12/4 EQCAR(X,Y); MINI-EASY-NON- 15/4 EQSTR(S1,S2); MINI-EQUAL 5/1 ERNAL WARRAY BPS[BPSSIZE]; % COULD DO A DYNAMIC ALL P20T:XXX-HEADE 37/7 ERNAL WARRAY HEAP[HEAPSIZE]; % COULD DO A DYNAMIC A P20T:XXX-HEADE 22/4 ERNAL WARRAY OTHERHEAP[HEAPSIZE]; P20T:XXX-HEADE 30/5 ERNAL WARRAY STACK[STACKSIZE]; P20T:XXX-HEADE 12/2 ERNAL WCONST BPSSIZE = 500; P20T:XXX-HEADE 36/6 ERNAL WCONST HEAPSIZE = 150000; % ENOUGH FOR PSL-TIM P20T:XXX-HEADE 21/3 ERNAL WCONST MAXARGBLOCK = (MAXARGS - MAXREALREGS) - P20T:XXX-HEADE 53/9 ERNAL WCONST STACKSIZE = 5000; P20T:XXX-HEADE 11/1 ERROR S; MINI-ERROR-ERR 7/2 ERRORHEADER; MINI-ERROR-ERR 4/1 ERRORTRAILER S; MINI-ERROR-ERR 11/3 ESCAPEP X; MINI-TOKEN 147/19 EVAL X; MINI-EVAL-APPL 19/2 EVCOND FL; MINI-EASY-SL 45/8 EVLIS X; MINI-EASY-SL 31/5 EVPROGN FL; MINI-EASY-SL 35/6 FASTAPPLY EXPR 0) P-FUNCTION-PRI 153/11 FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 FATALERROR S; MINI-ERROR-HAN 5/1 FCODEP FN; P-FUNCTION-PRI 91/6 FIRSTCALL; MAIN2 14/2 FIRSTCALL; MAIN3 12/3 FIRSTCALL; MAIN4 15/5 FIRSTCALL; MAIN5 13/5 FIRSTCALL; MAIN6 15/6 FIRSTCALL; MAIN7 17/8 FLAG EXPR 2) % DUMMY FOR INIT P20T:XXX-HEADE 138/22 FLAMBDALINKP FN; P-FUNCTION-PRI 79/4 FUNBOUNDP FN; P-FUNCTION-PRI 65/2 FUNCALL(FN,I); STUBS6 8/3 FUNCTIONTEST(); MAIN4 74/7 GEQ(N1,N2); MINI-EASY-NON- 9/2 GET(X,Y); MINI-PROPERTY- 9/2 GETC(); P20T:XXX-HEADE 94/12 GETD(FN); MINI-PUTD-GETD 6/1 GETFCODEPOINTER U; P-FUNCTION-PRI 106/8 GETFNTYPE X; MINI-PROPERTY- 38/5 GETLAMBDA(FN); MINI-EVAL-APPL 89/8 GREATERP(N1,N2); MINI-ARITHMETI 21/5 GTHEAP N; MINI-ALLOCATOR 14/1 GTID(); MINI-ALLOCATOR 48/5 GTSTR N; MINI-ALLOCATOR 27/2 GTVECT N; MINI-ALLOCATOR 36/3 GTWARRAY N; MINI-ALLOCATOR 44/4 HARDCONS(X,Y); MINI-CONS-MKVE 6/1 HEAPINFO(); MINI-GC 17/3 IDP X; MINI-KNOWN-TO- 9/3 INF X; STUBS5 22/2 INIT(); P20T:XXX-HEADE 88/11 INITEVAL; MINI-EVAL-APPL 5/1 INITHEAP(); P20T:XXX-HEADE 44/8 INITNEWID(D,S); MINI-TOKEN 105/12 INITREAD; MINI-TOKEN 11/1 INTERN S; MINI-TOKEN 95/11 INTERPTEST(); MAIN6 71/9 IOERROR M; MINI-IO-ERRORS 3/1 IOTEST; MAIN7 61/9 LAMBDAAPPLY(X,A); MINI-EVAL-APPL 60/4 LAMBDAEVALAPPLY(X,Y); MINI-EVAL-APPL 68/5 LAMBDAP(X); MINI-EVAL-APPL 86/7 LAMBIND V; P-FAST-BINDER 23/1 LAPIN F; MINI-DSKIN 25/3 LBIND1(X,Y); MAIN5 67/10 LENGTH U; MINI-OTHERS-SL 4/1 LENGTH1(U, N); MINI-OTHERS-SL 8/2 LEQ(N1,N2); MINI-EASY-NON- 12/3 LESSP(N1,N2); MINI-ARITHMETI 24/6 LIST X; MINI-EASY-SL 73/16 LIST2(A1,A2); MINI-COMP-SUPP 4/1 LIST3(A1,A2,A3); MINI-COMP-SUPP 7/2 LIST4(A1,A2,A3,A4); MINI-COMP-SUPP 10/3 LIST5(A1,A2,A3,A4,A5); MINI-COMP-SUPP 13/4 LONGDIV(X,Y); P20T:XXX-HEADE 147/24 LONGREMAINDER(X,Y); P20T:XXX-HEADE 150/25 LONGTIMES(X,Y); P20T:XXX-HEADE 144/23 LOOKUPID(S); MINI-TOKEN 115/13 LOWERCASEP X; MINI-TOKEN 144/18 MAIN!. EXPR 0) P20T:XXX-HEADE 64/10 MAKEFCODE(U, CODEPTR); P-FUNCTION-PRI 96/7 MAKEFLAMBDALINK D; P-FUNCTION-PRI 85/5 MAKEFUNBOUND(D); P-FUNCTION-PRI 73/3 MAPOBL(FN); MINI-OBLIST 6/1 MEMQ(X,Y); MINI-EASY-SL 17/3 MINUS(X); MINI-ARITHMETI 9/2 MKITEM(X,Y); STUBS5 28/4 MKSTRING(L, C); MINI-SEQUENCE 5/1 MKVECT N; MINI-CONS-MKVE 23/5 MORESTUFF; MAIN4 68/6 NCONS X; MINI-CONS-MKVE 20/4 NONIDERROR(X,Y); MINI-TYPE-ERRO 29/3 NONINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 35/5 NONNUMBERERROR(OFFENDER, FN); MINI-TYPE-ERRO 32/4 NONPOSITIVEINTEGERERROR(OFFENDER, FN); MINI-TYPE-ERRO 38/6 NOT X; MINI-KNOWN-TO- 18/6 NULL X; MINI-KNOWN-TO- 15/5 OPEN(FILENAME,HOW); MINI-OPEN-CLOS 3/1 PAIRP X; MINI-KNOWN-TO- 6/2 PBLANK; MINI-PRINTERS 30/5 PLUS2(X,Y); MINI-ARITHMETI 5/1 PRIN1 X; MINI-PRINTERS 8/1 PRIN1ID X; MINI-PRINTERS 45/8 PRIN1INT X; MINI-PRINTERS 33/6 PRIN1INTX X; MINI-PRINTERS 40/7 PRIN1PAIR X; MINI-PRINTERS 67/12 PRIN1STRING X; MINI-PRINTERS 53/10 PRIN2 X; MINI-PRINTERS 15/2 PRIN2ID X; MINI-PRINTERS 50/9 PRIN2PAIR X; MINI-PRINTERS 78/13 PRIN2STRING X; MINI-PRINTERS 60/11 PRIN2T X; MINI-PRINTERS 25/4 PRINT X; MINI-PRINTERS 22/3 PRINT1FEXPR(X); MINI-OBLIST 12/3 PRINT1FUNCTION(X); MINI-OBLIST 18/5 PRINTFEXPRS; MINI-OBLIST 9/2 PRINTFUNCTIONS; MINI-OBLIST 15/4 PROGBIND V; P-FAST-BINDER 32/2 PROGN X; MINI-EASY-SL 42/7 PROP X; MINI-PROPERTY- 5/1 PRTITM X; MINI-PRINTERS 92/15 PUT(X,Y,Z); MINI-PROPERTY- 17/3 PUTC X; P20T:XXX-HEADE 101/14 PUTD(FN,TYPE,BODY); MINI-PUTD-GETD 21/2 PUTINT I; P20T:XXX-HEADE 114/18 QUIT; P20T:XXX-HEADE 105/15 QUOTE A; MINI-EASY-SL 54/10 RAISECHAR C; MINI-TOKEN 88/10 RATOM; MINI-TOKEN 24/3 RDS N; MINI-RDS-WRS 5/1 READ1(X); MINI-READ 10/2 READ; MINI-READ 6/1 READID; MINI-TOKEN 77/9 READINT; MINI-TOKEN 50/6 READLIST(X); MINI-READ 15/3 READSTR; MINI-TOKEN 67/8 RECLAIM(); MINI-GC 13/2 REMPROP(X,Y); MINI-PROPERTY- 28/4 RESET(); SUB6 8/4 REVERSE U; MINI-EASY-SL 22/4 SAVEREGISTERS(A1, A2, A3, A4, A5, P-FUNCTION-PRI 193/12 SET(X,Y); MINI-SYMBOL-VA 3/1 SETQ A; MINI-EASY-SL 57/11 SETRAISE X; MINI-TOKEN 21/2 SHOULDBE(M,V,E); STUBS4 18/4 SHOW(N,S); MAIN3 49/6 SPACED(M); STUBS4 3/1 STDERROR M; MINI-ERROR-HAN 8/2 SUB1 N; MINI-ARITHMETI 17/4 SYMFNCBASE D; % THE ADDRESS OF CELL, P-FUNCTION-PRI 57/1 SYSCLEARIO EXPR 0) P20T:XXX-SYSTE 30/1 SYSCLOSE EXPR 1) P20T:XXX-SYSTE 145/9 SYSMAXBUFFER(FILEDESC); P20T:XXX-SYSTE 154/10 SYSOPENREAD(CHANNEL,FILENAME); P20T:XXX-SYSTE 44/2 SYSOPENWRITE(CHANNEL,FILENAME); P20T:XXX-SYSTE 56/3 SYSREADREC(FILEDESCRIPTOR,STRINGBUFFER); P20T:XXX-SYSTE 83/5 TAG X; STUBS5 25/3 TERPRI(); MINI-PRINTERS 89/14 TESTAPPLY(MSG,FN,ANSWER); MAIN6 107/11 TESTFASTAPPLY EXPR 0) MAIN6 102/10 TESTGET(); MAIN5 49/7 TESTSERIES(); MAIN5 45/6 TESTSERIES(); MAIN6 48/7 TESTUNDEFINED; MAIN5 59/8 TIMC(); P20T:XXX-HEADE 98/13 TIME(); MINI-TOP-LOOP 3/1 TYPEERROR(OFFENDER, FN, TYP); MINI-TYPE-ERRO 3/1 TYPEFILE F; MINI-DSKIN 3/1 UNBINDN N; MAIN5 64/9 UNDEFINEDFUNCTION EXPR 0) % FOR MISSING FUNCTION P20T:XXX-HEADE 131/21 UNDEFINEDFUNCTIONAUX EXPR 0) P-FUNCTION-PRI 214/13 UNDEFINEDFUNCTIONAUX; MAIN2 77/3 UNDEFINEDFUNCTIONAUX; MAIN3 68/8 UNDEFINEDFUNCTIONAUXAUX ; MAIN4 142/11 UNDEFINEDFUNCTIONAUXAUX; STUBS5 6/1 UPPERCASEP X; MINI-TOKEN 141/17 USAGETYPEERROR(OFFENDER, FN, TYP, USAGE); MINI-TYPE-ERRO 15/2 VERSIONNAME; P20T:XXX-HEADE 111/17 WHILE FL; MINI-LOOP-MACR 3/1 WHITEP X; MINI-TOKEN 131/14 WRITECHAR CH; MINI-CHAR-IO 6/2 WRS N; MINI-RDS-WRS 13/2 XCONS(X,Y); MINI-CONS-MKVE 17/3 |
Added psl-1983/tests/boot-list version [312b5a9541].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PK: modules/files PT: status ALLOC Allocators m-allocators sub3 almost same Copiers Cons-mkvect m-cons-mkvect sub3 almost same Comp-support m-comp-support sub3 same P20:System-gc P20:Gc m-gc stubs3 STUB ARITH Arithmetic m-arith sub5 simpler DEBG p20:Mini-trace Mini-editor Backtrace ERROR Error-handlers m-error-handlers sub2 simple subset Type-errors m-type-errors sub2 simple subset Error-errorset m-error-errorset sub2 trivial subset Io-errors m-io-errors sub2 simple subset EVAL P20:Apply-lap p-apply-lap sub5 less efficient Eval-apply m-eval-apply sub5 simpler Catch-throw Prog-and-friends EXTRA p20:Timc xxx-header p20:System-extras xxx-header p20:Trap P20:Dumplisp FASL p20:System-faslout p20:System-faslin Faslin Load Autoload P20:HEAP [Declare HEAP,BPS] xxx-header IO P20:Io-data io-data sub7 same? Char-io m-char-io sub7 simple subset Open-close m-open-close sub7 simpler Rds-wrs m-rds-wrs sub7 simpler Other-io Read m-read sub4 simpler Token-scanner m-token sub4 simpler Printers m-printers sub2 simpler p20:Write-float Printf m-printf sub2 trivial subset Explode-compress Io-extensions MACRO Eval-when Cont-error Lisp-macros Onoff Define-smacro Defconst String-gensym Loop-macros m-loop-macros sub5 simpler MAIN P20:Main-start xxx-header simpler PROP P20:Function-primitives p-function-primitives sub5 less efficient Property-list m-property-list sub5 simpler? Fluid-global Putd-getd m-putd-getd sub6 simpler? RANDM Known-to-comp-sl m-known-to-comp sub5 trivial subset Others-sl M-others-sl sub5 subset Equal m-equal sub5 subset Carcdr M-car-cdr sub5 subset Easy-sl M-easy-sl sub5 subset Easy-non-sl M-easy-non-sl sub5 subset Sets SYMBL Binding PK:binding sub6 same P20:Fast-binder P-fast-binder sub6 less-efficient Symbol-values m-symbol-values sub5 subset Oblist m-oblist sub5 subset SYSIO p20:System-io system-io,xxx-system-io sub7 same? P20:Scan-table TLOOP Break Top-loop m-top-loop sub7 trivial subset Dskin m-dskin sub7 simpler TYPES Type-conversions Vectors Sequence m-sequence sub3 simpler |
Added psl-1983/tests/cray-time.red version [68d277913e].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | % A small timing test to compare DEC-20, VAX and Cray % in syslisp and FORTRAN and C % An iterative FACTORIAL on comp; on syslisp; syslsp procedure IFAC n; begin scalar m; m:=1; while n >0 do <<m:=m*n; n := n-1>>; return m; end; procedure NCALL(N,M); begin scalar tim1,tim2,i; tim1:=time(); while N>0 do <<i:=Ifac(m);n:=n-1>>; tim2:=time()-tim1; %/had bug if same tim printf(" took %p ms%n",tim2); end; off syslisp; |
Added psl-1983/tests/field.red version [267f04a61f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % FIELD.RED - Exhaustively Test the Field Operator On SYSLISP; In "XXX-Header.red"$ Procedure FirstCall; Begin Scalar X,BPW; Msg5(Char M, Char S, Char G, Char '! ,Char EOL); TestOK Char '!?; %/ Confirm the test message TestErr Char '!?; % Set up test pattern %0001122233444556 % Bit Number T %0482604826048260 U BPW:=BitsPerWord; % For bug in !*JUMPxx If BPW eq 64 then X:=16#0123456789ABCDEF % 16 nibbles=8 bytes else if BPW eq 32 then X:=16#01234567 % 8 nibbles=4 bytes else if BPW eq 36 then X:=16#012345678 % 9 nibbles=4.5 bytes else ERR 99; AShiftTest(X); %/ Arithmetic Test FieldTest(X); %/ FieldExtract LshiftTest(X); %/ Shift and Masks with Field Quit; End; % Ashift can only be tested by a multiply of a 2 to a power. Therefore % it is only used in the left shift case. Procedure AShiftTest TestVal; Begin Scalar X, Y; Msg5(Char A,Char S,Char H,Char I,Char F); Msg5(Char T,Char '! ,Char '! ,Char '! , Char EOL); Y := 10; Y := Y*4; If Y NEQ 40 Then TestErr Char 1 Else TestOk Char 1; Y := -5; Y := Y*16; If Y NEQ -80 Then TestErr Char 2 Else TestOk Char 2; Y := 6; X := 4; Y := Y * 4; If Y NEQ 6*X Then TestErr Char 3 Else TestOk Char 3; End; Procedure FieldTest(x); % Extract a field from a variable and see if it works. Begin scalar Y; Msg5(Char F,Char I,Char E,Char L,Char D); PutC Char EOL; Y:=Field(X, 0, BitsPerWord);% FullWord If Y NEQ X Then TestErr Char 1 Else TestOk Char 1; Y:=Field(X, 0, 8); % First Byte If Y NEQ 16#01 Then TestErr Char 2 Else TestOk Char 2; Y:=Field(X, 8, 8); % Second Byte If Y NEQ 16#23 Then TestErr Char 3 Else TestOk Char 3; Y:=Field(X, 16, 8); % Third Byte If Y NEQ 16#45 Then TestErr Char 4 Else TestOk Char 4; Y:=Field(X, 24, 8 ); % Fourth Byte If Y NEQ 16#67 Then TestErr Char 5 Else TestOk Char 5; Y:=Field(X, 0, 16); % First 16 bit If Y NEQ 16#0123 Then TestErr Char 6 Else TestOk Char 6; Y:=Field(X, 16, 16); % Second 16 bit If Y NEQ 16#4567 Then TestErr Char 7 Else TestOk Char 7; End; Procedure LshiftTest x; Begin Scalar Y; Msg5(Char L,Char S,Char H,Char I,Char F); Msg5(Char T ,Char '! ,Char '! ,Char '! , Char EOL); Y:=Extract(X, 0, BitsPerWord); % FullWord If Y NEQ X Then TestErr Char 1 Else TestOk Char 1; Y:=Extract(X, 0, 8); % First Byte If Y NEQ 16#01 Then TestErr Char 2 Else TestOk Char 2; Y:=Extract(X, 8, 8); % Second Byte If Y NEQ 16#23 Then TestErr Char 3 Else TestOk Char 3; Y:=Extract(X, 16, 8); % Third Byte If Y NEQ 16#45 Then TestErr Char 4 Else TestOk Char 4; Y:=Extract(X, 24, 8 ); % Fourth Byte If Y NEQ 16#67 Then TestErr Char 5 Else TestOk Char 5; Y:=Extract(X, 0, 16); % First 16 bit If Y NEQ 16#0123 Then TestErr Char 6 Else TestOk Char 6; Y:=Extract(X, 16, 16); % Second 16 bit If Y NEQ 16#4567 Then TestErr Char 7 Else TestOk Char 7; End; %%% Signals that Test OK or Error %%%%% Procedure Msg5(C1,C2,C3,C4,C5); <<PutC C1; PutC C2; PutC C3; PutC C4; PutC C5>>; Procedure TestNum X; <<Msg5(Char T,Char Lower e,Char Lower s,Char lower t, Char '! ); PutC X; PutC Char '! ;>>; Procedure TestErr X; <<TestNum X; Msg5(Char E, Char lower r,Char Lower r,Char '! , Char Eol)>>; Procedure TestOk X; <<TestNum X; Msg5(Char O, Char lower k,Char '! ,Char '! , Char Eol)>>; %%% Dynamic Field Extracts %%%%% Procedure MakeMask(N); % Make a mask of N 1's LSH(1,N)-1; Procedure Extract(Z,sbit,lfld); % Dynamic Field Extract Begin scalar m,s; m:=MakeMask(Lfld); s:=Sbit+Lfld-BitsPerWord; Return LAnd(m,Lsh(Z,s)); end; End; |
Added psl-1983/tests/foo.headers version [abefd6e542].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | SYSLSP PROCEDURE CODEAPPLY(CODEPTR, ARGLIST); P-APPLY-LAP 53/1 LAP '((!*ENTRY CODEEVALAPPLY EXPR 2) P-APPLY-LAP 206/2 SYSLSP PROCEDURE CODEEVALAPPLYAUX(CODEPTR, ARGLIST, PP-APPLY-LAP 213/3 SYSLSP PROCEDURE BINDEVAL(FORMALS, ARGS); P-APPLY-LAP 363/4 SYSLSP PROCEDURE BINDEVALAUX(FORMALS, ARGS, N); P-APPLY-LAP 366/5 SYSLSP PROCEDURE COMPILEDCALLINGINTERPRETEDAUX(); P-APPLY-LAP 381/6 SYSLSP PROCEDURE FASTLAMBDAAPPLY(); P-APPLY-LAP 387/7 SYSLSP PROCEDURE COMPILEDCALLINGINTERPRETEDAUXAUX FN;P-APPLY-LAP 391/8 409 lines, 8 procedures found |
Added psl-1983/tests/io-data.red version [7c724c47fb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % IO-DATA.RED - Data structures used by input and output % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 21 September 1981 % Copyright (c) 1981 Eric Benson % on SysLisp; WConst ChannelClosed = 0, ChannelOpenRead = 1, ChannelOpenWrite = 2, ChannelOpenSpecial = 3; internal WConst MaxTokenSize = 5000; exported WString TokenBuffer[MaxTokenSize]; exported WConst MaxChannels = 31; exported WArray ReadFunction = ['TerminalInputHandler, 'WriteOnlyChannel, 'WriteOnlyChannel, 'CompressReadChar, 'WriteOnlyChannel, 'WriteOnlyChannel, 'WriteOnlyChannel, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], WriteFunction = ['ReadOnlyChannel, 'IndependentWriteChar, 'ToStringWriteChar, 'ExplodeWriteChar, 'FlatSizeWriteChar, 'IndependentWriteChar, 'IndependentWriteChar, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], CloseFunction = ['IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'IllegalStandardChannelClose, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen, 'ChannelNotOpen], UnReadBuffer[MaxChannels], LinePosition[MaxChannels], MaxLine = [0, 80,80, 10000, 10000, 80, 80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0], ChannelStatus = [ChannelOpenRead, ChannelOpenWrite, ChannelOpenSpecial, ChannelOpenSpecial, ChannelOpenSpecial, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed, ChannelClosed], MaxBuffer [MaxChannels], ChannelTable [MaxChannels], NextPosition [MaxChannels], BufferLength [MaxChannels]; off SysLisp; global '(!$EOL!$); LoadTime(!$EOL!$ := '! ); END; |
Added psl-1983/tests/irewrite.sl version [492e3d8e51].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % {DSK}IREWRITE.PSL;2 6-JAN-83 10:08:06 (FLUID '(unify-subst)) (FLAG '( ADD-LEMMA ADD-LEMMA-LST Apply-subst Apply-subst-lst false one-way-unify one-way-unify1 one-way-unify1-lst ptime rewrite rewrite-with-lemmas tautologyP tautp trans-of-implies trans-of-implies1 truep ) 'InternalFunction) (DE ADD-LEMMA (TERM) (COND ((AND (NOT (ATOM TERM)) (EQ (CAR TERM) 'EQUAL) (NOT (ATOM (CADR TERM)))) (PUT (CAR (CADR TERM)) 'LEMMAS (CONS TERM (GET (CAR (CADR TERM)) 'LEMMAS)))) (T (ERROR 0 (LIST 'ADD-LEMMA-DID-NOT-LIKE-TERM TERM))))) (DE ADD-LEMMA-LST (LST) (COND ((NULL LST) T) (T (ADD-LEMMA (CAR LST)) (ADD-LEMMA-LST (CDR LST))))) % lmm 7-JUN-81 10:07 (DE APPLY-SUBST (ALIST TERM) (COND ((NOT (PAIRP TERM)) ((LAMBDA (TEM) (COND (TEM (CDR TEM)) (T TERM))) (ASSOC TERM ALIST))) (T (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION (LAMBDA (X) (APPLY-SUBST ALIST X)))))))) (DE APPLY-SUBST-LST (ALIST LST) (COND ((NULL LST) NIL) (T (CONS (APPLY-SUBST ALIST (CAR LST)) (APPLY-SUBST-LST ALIST (CDR LST)))))) (DE FALSEP (X LST) (OR (EQUAL X '(F)) (MEMBER X LST))) (DE ONE-WAY-UNIFY (TERM1 TERM2) (PROGN (SETQ UNIFY-SUBST NIL) (ONE-WAY-UNIFY1 TERM1 TERM2))) % lmm 7-JUN-81 09:47 (DE ONE-WAY-UNIFY1 (TERM1 TERM2) (COND ((NOT (PAIRP TERM2)) ((LAMBDA (TEM) (COND (TEM (EQUAL TERM1 (CDR TEM))) (T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1) UNIFY-SUBST)) T))) (ASSOC TERM2 UNIFY-SUBST))) ((NOT (PAIRP TERM1)) NIL) ((EQ (CAR TERM1) (CAR TERM2)) (ONE-WAY-UNIFY1-LST (CDR TERM1) (CDR TERM2))) (T NIL))) (DE ONE-WAY-UNIFY1-LST (LST1 LST2) (COND ((NULL LST1) T) ((ONE-WAY-UNIFY1 (CAR LST1) (CAR LST2)) (ONE-WAY-UNIFY1-LST (CDR LST1) (CDR LST2))) (T NIL))) (DE PTIME NIL (PROG (GCTM) (SETQ GCTM 0) (RETURN (CONS (time) GCTM)))) % lmm 7-JUN-81 10:04 (DE REWRITE (TERM) (COND ((NOT (PAIRP TERM)) TERM) (T (REWRITE-WITH-LEMMAS (CONS (CAR TERM) (MAPCAR (CDR TERM) (FUNCTION REWRITE))) (GET (CAR TERM) 'LEMMAS))))) (DE REWRITE-WITH-LEMMAS (TERM LST) (COND ((NULL LST) TERM) ((ONE-WAY-UNIFY TERM (CADR (CAR LST))) (REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST))))) (T (REWRITE-WITH-LEMMAS TERM (CDR LST))))) (DE SETUP NIL (ADD-LEMMA-LST '((EQUAL (COMPILE FORM) (REVERSE (CODEGEN (OPTIMIZE FORM) (NIL)))) (EQUAL (EQP X Y) (EQUAL (FIX X) (FIX Y))) (EQUAL (GREATERP X Y) (LESSP Y X)) (EQUAL (LESSEQP X Y) (NOT (LESSP Y X))) (EQUAL (GREATEREQP X Y) (NOT (LESSP X Y))) (EQUAL (BOOLEAN X) (OR (EQUAL X (T)) (EQUAL X (F)))) (EQUAL (IFF X Y) (AND (IMPLIES X Y) (IMPLIES Y X))) (EQUAL (EVEN1 X) (IF (ZEROP X) (T) (ODD (SUB1 X)))) (EQUAL (COUNTPS- L PRED) (COUNTPS-LOOP L PRED (ZERO))) (EQUAL (FACT- I) (FACT-LOOP I 1)) (EQUAL (REVERSE- X) (REVERSE-LOOP X (NIL))) (EQUAL (DIVIDES X Y) (ZEROP (REMAINDER Y X))) (EQUAL (ASSUME-TRUE VAR ALIST) (CONS (CONS VAR (T)) ALIST)) (EQUAL (ASSUME-FALSE VAR ALIST) (CONS (CONS VAR (F)) ALIST)) (EQUAL (TAUTOLOGY-CHECKER X) (TAUTOLOGYP (NORMALIZE X) (NIL))) (EQUAL (FALSIFY X) (FALSIFY1 (NORMALIZE X) (NIL))) (EQUAL (PRIME X) (AND (NOT (ZEROP X)) (NOT (EQUAL X (ADD1 (ZERO)))) (PRIME1 X (SUB1 X)))) (EQUAL (AND P Q) (IF P (IF Q (T) (F)) (F))) (EQUAL (OR P Q) (IF P (T) (IF Q (T) (F)) (F))) (EQUAL (NOT P) (IF P (F) (T))) (EQUAL (IMPLIES P Q) (IF P (IF Q (T) (F)) (T))) (EQUAL (FIX X) (IF (NUMBERP X) X (ZERO))) (EQUAL (IF (IF A B C) D E) (IF A (IF B D E) (IF C D E))) (EQUAL (ZEROP X) (OR (EQUAL X (ZERO)) (NOT (NUMBERP X)))) (EQUAL (PLUS (PLUS X Y) Z) (PLUS X (PLUS Y Z))) (EQUAL (EQUAL (PLUS A B) (ZERO)) (AND (ZEROP A) (ZEROP B))) (EQUAL (DIFFERENCE X X) (ZERO)) (EQUAL (EQUAL (PLUS A B) (PLUS A C)) (EQUAL (FIX B) (FIX C))) (EQUAL (EQUAL (ZERO) (DIFFERENCE X Y)) (NOT (LESSP Y X))) (EQUAL (EQUAL X (DIFFERENCE X Y)) (AND (NUMBERP X) (OR (EQUAL X (ZERO)) (ZEROP Y)))) (EQUAL (MEANING (PLUS-TREE (APPEND X Y)) A) (PLUS (MEANING (PLUS-TREE X) A) (MEANING (PLUS-TREE Y) A))) (EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X)) A) (FIX (MEANING X A))) (EQUAL (APPEND (APPEND X Y) Z) (APPEND X (APPEND Y Z))) (EQUAL (REVERSE (APPEND A B)) (APPEND (REVERSE B) (REVERSE A))) (EQUAL (TIMES X (PLUS Y Z)) (PLUS (TIMES X Y) (TIMES X Z))) (EQUAL (TIMES (TIMES X Y) Z) (TIMES X (TIMES Y Z))) (EQUAL (EQUAL (TIMES X Y) (ZERO)) (OR (ZEROP X) (ZEROP Y))) (EQUAL (EXEC (APPEND X Y) PDS ENVRN) (EXEC Y (EXEC X PDS ENVRN) ENVRN)) (EQUAL (MC-FLATTEN X Y) (APPEND (FLATTEN X) Y)) (EQUAL (MEMBER X (APPEND A B)) (OR (MEMBER X A) (MEMBER X B))) (EQUAL (MEMBER X (REVERSE Y)) (MEMBER X Y)) (EQUAL (LENGTH (REVERSE X)) (LENGTH X)) (EQUAL (MEMBER A (INTERSECT B C)) (AND (MEMBER A B) (MEMBER A C))) (EQUAL (NTH (ZERO) I) (ZERO)) (EQUAL (EXP I (PLUS J K)) (TIMES (EXP I J) (EXP I K))) (EQUAL (EXP I (TIMES J K)) (EXP (EXP I J) K)) (EQUAL (REVERSE-LOOP X Y) (APPEND (REVERSE X) Y)) (EQUAL (REVERSE-LOOP X (NIL)) (REVERSE X)) (EQUAL (COUNT-LIST Z (SORT-LP X Y)) (PLUS (COUNT-LIST Z X) (COUNT-LIST Z Y))) (EQUAL (EQUAL (APPEND A B) (APPEND A C)) (EQUAL B C)) (EQUAL (PLUS (REMAINDER X Y) (TIMES Y (QUOTIENT X Y))) (FIX X)) (EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE) BASE) (PLUS (POWER-EVAL L BASE) I)) (EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE) BASE) (PLUS I (PLUS (POWER-EVAL X BASE) (POWER-EVAL Y BASE)))) (EQUAL (REMAINDER Y 1) (ZERO)) (EQUAL (LESSP (REMAINDER X Y) Y) (NOT (ZEROP Y))) (EQUAL (REMAINDER X X) (ZERO)) (EQUAL (LESSP (QUOTIENT I J) I) (AND (NOT (ZEROP I)) (OR (ZEROP J) (NOT (EQUAL J 1))))) (EQUAL (LESSP (REMAINDER X Y) X) (AND (NOT (ZEROP Y)) (NOT (ZEROP X)) (NOT (LESSP X Y)))) (EQUAL (POWER-EVAL (POWER-REP I BASE) BASE) (FIX I)) (EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE) (POWER-REP J BASE) (ZERO) BASE) BASE) (PLUS I J)) (EQUAL (GCD X Y) (GCD Y X)) (EQUAL (NTH (APPEND A B) I) (APPEND (NTH A I) (NTH B (DIFFERENCE I (LENGTH A))))) (EQUAL (DIFFERENCE (PLUS X Y) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS Y X) X) (FIX Y)) (EQUAL (DIFFERENCE (PLUS X Y) (PLUS X Z)) (DIFFERENCE Y Z)) (EQUAL (TIMES X (DIFFERENCE C W)) (DIFFERENCE (TIMES C X) (TIMES W X))) (EQUAL (REMAINDER (TIMES X Z) Z) (ZERO)) (EQUAL (DIFFERENCE (PLUS B (PLUS A C)) A) (PLUS B C)) (EQUAL (DIFFERENCE (ADD1 (PLUS Y Z)) Z) (ADD1 Y)) (EQUAL (LESSP (PLUS X Y) (PLUS X Z)) (LESSP Y Z)) (EQUAL (LESSP (TIMES X Z) (TIMES Y Z)) (AND (NOT (ZEROP Z)) (LESSP X Y))) (EQUAL (LESSP Y (PLUS X Y)) (NOT (ZEROP X))) (EQUAL (GCD (TIMES X Z) (TIMES Y Z)) (TIMES Z (GCD X Y))) (EQUAL (VALUE (NORMALIZE X) A) (VALUE X A)) (EQUAL (EQUAL (FLATTEN X) (CONS Y (NIL))) (AND (NLISTP X) (EQUAL X Y))) (EQUAL (LISTP (GOPHER X)) (LISTP X)) (EQUAL (SAMEFRINGE X Y) (EQUAL (FLATTEN X) (FLATTEN Y))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) (ZERO)) (AND (OR (ZEROP Y) (EQUAL Y 1)) (EQUAL X (ZERO)))) (EQUAL (EQUAL (GREATEST-FACTOR X Y) 1) (EQUAL X 1)) (EQUAL (NUMBERP (GREATEST-FACTOR X Y)) (NOT (AND (OR (ZEROP Y) (EQUAL Y 1)) (NOT (NUMBERP X))))) (EQUAL (TIMES-LIST (APPEND X Y)) (TIMES (TIMES-LIST X) (TIMES-LIST Y))) (EQUAL (PRIME-LIST (APPEND X Y)) (AND (PRIME-LIST X) (PRIME-LIST Y))) (EQUAL (EQUAL Z (TIMES W Z)) (AND (NUMBERP Z) (OR (EQUAL Z (ZERO)) (EQUAL W 1)))) (EQUAL (GREATEREQPR X Y) (NOT (LESSP X Y))) (EQUAL (EQUAL X (TIMES X Y)) (OR (EQUAL X (ZERO)) (AND (NUMBERP X) (EQUAL Y 1)))) (EQUAL (REMAINDER (TIMES Y X) Y) (ZERO)) (EQUAL (EQUAL (TIMES A B) 1) (AND (NOT (EQUAL A (ZERO))) (NOT (EQUAL B (ZERO))) (NUMBERP A) (NUMBERP B) (EQUAL (SUB1 A) (ZERO)) (EQUAL (SUB1 B) (ZERO)))) (EQUAL (LESSP (LENGTH (DELETE X L)) (LENGTH L)) (MEMBER X L)) (EQUAL (SORT2 (DELETE X L)) (DELETE X (SORT2 L))) (EQUAL (DSORT X) (SORT2 X)) (EQUAL (LENGTH (CONS X1 (CONS X2 (CONS X3 (CONS X4 (CONS X5 (CONS X6 X7))))))) (PLUS 6 (LENGTH X7))) (EQUAL (DIFFERENCE (ADD1 (ADD1 X)) 2) (FIX X)) (EQUAL (QUOTIENT (PLUS X (PLUS X Y)) 2) (PLUS X (QUOTIENT Y 2))) (EQUAL (SIGMA (ZERO) I) (QUOTIENT (TIMES I (ADD1 I)) 2)) (EQUAL (PLUS X (ADD1 Y)) (IF (NUMBERP Y) (ADD1 (PLUS X Y)) (ADD1 X))) (EQUAL (EQUAL (DIFFERENCE X Y) (DIFFERENCE Z Y)) (IF (LESSP X Y) (NOT (LESSP Y Z)) (IF (LESSP Z Y) (NOT (LESSP Y X)) (EQUAL (FIX X) (FIX Z))))) (EQUAL (MEANING (PLUS-TREE (DELETE X Y)) A) (IF (MEMBER X Y) (DIFFERENCE (MEANING (PLUS-TREE Y) A) (MEANING X A)) (MEANING (PLUS-TREE Y) A))) (EQUAL (TIMES X (ADD1 Y)) (IF (NUMBERP Y) (PLUS X (TIMES X Y)) (FIX X))) (EQUAL (NTH (NIL) I) (IF (ZEROP I) (NIL) (ZERO))) (EQUAL (LAST (APPEND A B)) (IF (LISTP B) (LAST B) (IF (LISTP A) (CONS (CAR (LAST A)) B) B))) (EQUAL (EQUAL (LESSP X Y) Z) (IF (LESSP X Y) (EQUAL T Z) (EQUAL F Z))) (EQUAL (ASSIGNMENT X (APPEND A B)) (IF (ASSIGNEDP X A) (ASSIGNMENT X A) (ASSIGNMENT X B))) (EQUAL (CAR (GOPHER X)) (IF (LISTP X) (CAR (FLATTEN X)) (ZERO))) (EQUAL (FLATTEN (CDR (GOPHER X))) (IF (LISTP X) (CDR (FLATTEN X)) (CONS (ZERO) (NIL)))) (EQUAL (QUOTIENT (TIMES Y X) Y) (IF (ZEROP Y) (ZERO) (FIX X))) (EQUAL (GET J (SET I VAL MEM)) (IF (EQP J I) VAL (GET J MEM)))))) % lmm 7-JUN-81 09:44 (DE TAUTOLOGYP (X TRUE-LST FALSE-LST) (COND ((TRUEP X TRUE-LST) T) ((FALSEP X FALSE-LST) NIL) ((NOT (PAIRP X)) NIL) ((EQ (CAR X) 'IF) (COND ((TRUEP (CADR X) TRUE-LST) (TAUTOLOGYP (CADDR X) TRUE-LST FALSE-LST)) ((FALSEP (CADR X) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST FALSE-LST)) (T (AND (TAUTOLOGYP (CADDR X) (CONS (CADR X) TRUE-LST) FALSE-LST) (TAUTOLOGYP (CADDDR X) TRUE-LST (CONS (CADR X) FALSE-LST)))))) (T NIL))) (DE TAUTP (X) (TAUTOLOGYP (REWRITE X) NIL NIL)) (DE TEST NIL (PROG (TM1 TM2 ANS TERM) (SETQ TM1 (PTIME)) (SETQ TERM (APPLY-SUBST '((X F (PLUS (PLUS A B) (PLUS C (ZERO)))) (Y F (TIMES (TIMES A B) (PLUS C D))) (Z F (REVERSE (APPEND (APPEND A B) (NIL)))) (U EQUAL (PLUS A B) (DIFFERENCE X Y)) (W LESSP (REMAINDER A B) (MEMBER A (LENGTH B)))) '(IMPLIES (AND (IMPLIES X Y) (AND (IMPLIES Y Z) (AND (IMPLIES Z U) (IMPLIES U W)))) (IMPLIES X W)))) (SETQ ANS (TAUTP TERM)) (SETQ TM2 (PTIME)) (RETURN (LIST ANS (DIFFERENCE (CAR TM2) (CAR TM1)) (DIFFERENCE (CDR TM2) (CDR TM1)))))) (DE TRANS-OF-IMPLIES (N) (LIST 'IMPLIES (TRANS-OF-IMPLIES1 N) (LIST 'IMPLIES 0 N))) (DE TRANS-OF-IMPLIES1 (N) (COND ((EQUAL N 1) (LIST 'IMPLIES 0 1)) (T (LIST 'AND (LIST 'IMPLIES (SUB1 N) N) (TRANS-OF-IMPLIES1 (SUB1 N)))))) (DE TRUEP (X LST) (OR (EQUAL X '(T)) (MEMBER X LST))) |
Added psl-1983/tests/laptest-alm.lap version [4ad534b790].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (LAP '( (*ENTRY FOO1 EXPR 1) (*ALLOC 0) (*EXIT 0) )) (LAP '( (*ENTRY FOO2 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 1) (REG 1)) (*EXIT 0) )) (LAP '( (*ENTRY FOO3 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 3) (REG 2)) (*LINKE 0 PLUS2 EXPR 2) )) (LAP '( (*ENTRY FOO4 EXPR 1) (*ALLOC 0) (*MOVE (QUOTE 4) (REG 2)) (*LINK PLUS2 EXPR 2) (*LINKE 0 PRINT EXPR 1) )) (LAP '( (*ENTRY FOO5 EXPR 1) (*ALLOC 0) (*JUMPNOTEQ (LABEL G0004) (REG 1) (QUOTE 1)) (*MOVE (QUOTE ONE) (REG 1)) (*EXIT 0) (*LBL (LABEL G0004)) (*MOVE (QUOTE NOT-ONE) (REG 1)) (*EXIT 0) )) (FLUID (QUOTE (FLU1 FLU2))) (LAP '( (*ENTRY FOO6A EXPR 2) (*ALLOC 0) (*LAMBIND (REGISTERS (REG 2) (REG 1)) (NONLOCALVARS ($FLUID FLU2) ($FLUID FLU1)) ) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE BEFORE) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE 10) ($FLUID FLU1)) (*MOVE (QUOTE 20) ($FLUID FLU2)) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE AFTER) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE NIL) (REG 1)) (*FREERSTR (NONLOCALVARS ($FLUID FLU2) ($FLUID FLU1))) (*EXIT 0) )) (LAP '( (*ENTRY FOO6 EXPR 0) (*ALLOC 0) (*MOVE (QUOTE 1) ($FLUID FLU1)) (*MOVE (QUOTE 2) ($FLUID FLU2)) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE BEFORE) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE B) (REG 2)) (*MOVE (QUOTE A) (REG 1)) (*LINK FOO6A EXPR 2) (*MOVE ($FLUID FLU2) (REG 3)) (*MOVE ($FLUID FLU1) (REG 2)) (*MOVE (QUOTE AFTER) (REG 1)) (*LINK LIST3 EXPR 3) (*LINK PRINT EXPR 1) (*MOVE (QUOTE NIL) (REG 1)) (*EXIT 0) )) |
Added psl-1983/tests/laptest-tlm-20.lap version [21ce522e87].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (LAP '( (FULLWORD 1) (*ENTRY FOO1 EXPR 1) (POPJ (REG ST) 0) )) (LAP '( (FULLWORD 1) (*ENTRY FOO2 EXPR 1) (HRRZI (REG 1) 1) (POPJ (REG ST) 0) )) (LAP '( (FULLWORD 1) (*ENTRY FOO3 EXPR 1) (HRRZI (REG 2) 3) (JRST (ENTRY PLUS2)) )) (LAP '( (FULLWORD 1) (*ENTRY FOO4 EXPR 1) (HRRZI (REG 2) 4) (PUSHJ (REG ST) (ENTRY PLUS2)) (JRST (ENTRY PRINT)) )) (LAP '( (FULLWORD 1) (*ENTRY FOO5 EXPR 1) (CAIE (REG 1) 1) (JRST G0004) (MOVE (REG 1) L0001) (POPJ (REG ST) 0) G0004 (MOVE (REG 1) L0002) (POPJ (REG ST) 0) L0002 (FULLWORD (MKITEM 30 (IDLOC NOT-ONE))) L0001 (FULLWORD (MKITEM 30 (IDLOC ONE))) )) (FLUID (QUOTE (FLU1 FLU2))) (LAP '( (FULLWORD 2) (*ENTRY FOO6A EXPR 2) (JSP (REG T5) (ENTRY FASTBIND)) (HALFWORD 2 (IDLOC FLU2)) (HALFWORD 1 (IDLOC FLU1)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0003) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (HRRZI (REG T1) 10) (MOVEM (REG T1) ($FLUID FLU1)) (HRRZI (REG T1) 20) (MOVEM (REG T1) ($FLUID FLU2)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0004) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 1) (REG NIL)) (JSP (REG T5) (ENTRY FASTUNBIND)) (FULLWORD 2) (POPJ (REG ST) 0) L0004 (FULLWORD (MKITEM 30 (IDLOC AFTER))) L0003 (FULLWORD (MKITEM 30 (IDLOC BEFORE))) )) (LAP '( (FULLWORD 0) (*ENTRY FOO6 EXPR 0) (HRRZI (REG T1) 1) (MOVEM (REG T1) ($FLUID FLU1)) (HRRZI (REG T1) 2) (MOVEM (REG T1) ($FLUID FLU2)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0005) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 2) L0006) (MOVE (REG 1) L0007) (PUSHJ (REG ST) (ENTRY FOO6A)) (MOVE (REG 3) ($FLUID FLU2)) (MOVE (REG 2) ($FLUID FLU1)) (MOVE (REG 1) L0008) (PUSHJ (REG ST) (ENTRY LIST3)) (PUSHJ (REG ST) (ENTRY PRINT)) (MOVE (REG 1) (REG NIL)) (POPJ (REG ST) 0) L0008 (FULLWORD (MKITEM 30 (IDLOC AFTER))) L0007 (FULLWORD (MKITEM 30 (IDLOC A))) L0006 (FULLWORD (MKITEM 30 (IDLOC B))) L0005 (FULLWORD (MKITEM 30 (IDLOC BEFORE))) )) |
Added psl-1983/tests/laptest.red version [eb02f4cb86].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % LAPTEST.RED - A selection of small procedures for testing LAP % MLG % Run through LAPOUT for CMACRO (ALM) level, % and turn on DOPASS1LAP for TLM level. procedure foo1 x; x; procedure foo2 x; 1; procedure foo3 x; x+3; procedure foo4 x; print(x+4); procedure foo5 x; if x=1 then 'one else 'not!-one; FLUID '(FLU1 FLU2); procedure foo6a(Flu1,Flu2); begin Print List('before,FLU1,Flu2); Flu1:=10; Flu2:=20; Print List('after,FLU1,Flu2); end; procedure foo6(); <<Flu1:=1; Flu2 :=2; Print List('before,FLU1,Flu2); Foo6a('a,'b); Print List('after,FLU1,Flu2); >>; End; |
Added psl-1983/tests/main0.red version [95addc9ce7].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MAIN0.RED - A "trivial" file of ALM level LAP to test basic set of % tools: LAP-TO-ASM mostly, and CMACROs LAP '((!*ENTRY DummyFunctionDefinition Expr 1) (!*ALLOC 0) (!*MOVE (REG 1) (REG 2)) (!*EXIT 0)); END; |
Added psl-1983/tests/main1.red version [ef20174d27].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Simple 1 file test % This is program MAIN1.RED On SYSLISP; IN "XXX-HEADER.RED"$ Procedure FirstCall; <<Init(); PutC Char A; PutC Char B; Terpri(); PutInt Ifact 10; Terpri(); TestFact(); Terpri(); TestTak(); Quit;>>; procedure terpri(); PutC Char EOL; Procedure TestFact(); << Timc(); Terpri(); ArithmeticTest 10000; Timc();>>; Procedure ArithmeticTest (N); begin scalar I; I:= 0; loop: if Igreaterp(I,N) then return NIL; Fact 9; I := iadd1 I; goto loop end; procedure TestTak(); <<Timc(); PutInt TopLevelTak (18,12,6); Terpri(); Timc();>>; in "pt:tak.sl"; syslsp procedure Fact (N); If ilessp(N,2) then 1 else LongTimes(N,Fact isub1 N); syslsp procedure Ifact u; Begin scalar m; m:=1; L1: if u eq 1 then return M; M:=LongTimes(U,M); u:=u-1; PutInt(u); Terpri(); PutInt(M); Terpri(); goto L1; end; end; |
Added psl-1983/tests/main2.red version [7009645941].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN2.RED - Test Byte and String I/O, some PRINT ing % Need: SUB2.RED simple print routines IN "XXX-HEADER.RED"$ on SysLisp; % some strings to work with WString TestString = "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUnVvWwXxYyZz"; Wstring Buffer[100]; syslsp Procedure FirstCall; begin scalar X, Y; init(); % test STRINF Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char I; Putc Char Lower n ; Putc Char Lower f; Putc Char Eol; X:=TestString; Y:=StrInf(X); PutInt X; PutC Char '! ; PutInt Y;PutC Char EOL; % test STrlen Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char Lower l; Putc Char Lower e; Putc Char Lower n; Putc Char Eol; X:=StrLen(testString); PutInt X;PutC Char '! ;PutInt 51;PutC Char EOL; % test Byte access. X:=TestString+AddressingUnitsPerItem; Putc Char B; PutC Char Lower y; PutC Char Lower t; Putc Char Lower e; Putc Char Eol; For i:=0:10 do <<Y:=Byte(X,i); PutInt i; PutC Char '! ; PutInt Y; PutC Char '! ; PutC Y; PutC Char EOL>>; % Now a string: Putc Char S; PutC Char Lower t; PutC Char Lower r; Putc Char Lower i; Putc Char Lower n; Putc Char Lower g; Putc Char Eol; Prin2String TestString; Terpri(); Prin1String "----- Now input characters until #"; Terpri(); while (X := GetC X) neq char !# do PutC X; Print '"----- First Print Called"; Print '1; Print 'ANATOM; Print '( 1 . 2 ); Print '(AA (B1 . B2) . B3); Print '(AA (B1 . NIL) . NIL); Prin2T "Expect UNDEFINED FUNCTION MESSAGE for a function of 3 arguments"; ShouldNotBeThere(1,2,3); quit; end; Fluid '(UndefnCode!* UndefnNarg!*); syslsp procedure UndefinedFunctionAux; % Should preserve all regs <<Terpri(); Prin2String "**** Undefined Function: "; Prin1ID LispVar UndefnCode!*; Prin2String " , called with "; Prin2 LispVar UndefnNarg!*; Prin2T " arguments"; Quit;>>; Off syslisp; End; |
Added psl-1983/tests/main3.red version [886cec5eb1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN3.RED - Test CASE and CONS % Need: SUB2.RED simple print routines % SUB3.RED simple allocator IN "XXX-HEADER.RED"$ IN "PT:STUBS3.RED"$ on syslisp; syslsp Procedure FirstCall; begin scalar X, Y; Init(); Print '"MAIN3: Casetest"$ CaseTest(); Print '"MAIN3: test CONS"$ InitHeap(); ConsTest(); quit; end; syslsp procedure CaseTest; <<Prin2t '"Test case from -1 to 11"; Prin2t '"Will classify argument"; Ctest (-1); Ctest 0; Ctest 1; Ctest 2; Ctest 3; Ctest 4; Ctest 5; Ctest 6; Ctest 7; Ctest 8; Ctest 9; Ctest 10; Ctest 11; Ctest 12>>; syslsp procedure CTest N; Case N of 0: Show(N,"0 case"); 1,2,3: Show(N,"1,2,3 case"); 6 to 10:Show(N,"6 ... 10 case"); default:Show(N,"default case"); end; syslsp procedure Show(N,S); <<Prin2String "Show for N="; Prin1Int N; Prin2String ", expect "; Prin2String S; Terpri()>>; Procedure CONStest(); Begin scalar Z,N; Z:='1; N:='2; While N<10 do <<z:=cons(N,z); Print z; N:=N+1>>; End; FLUID '(UndefnCode!* UndefnNarg!*); syslsp procedure UndefinedFunctionAux; % Should preserve all regs <<Terpri(); Prin2String "**** Undefined Function: "; Prin1ID LispVar UndefnCode!*; Prin2String " , called with "; Prin2 LispVar UndefnNarg!*; Prin2T " arguments"; Quit;>>; Off syslisp; End; |
Added psl-1983/tests/main4.red version [fd6df7791e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN4.RED : Test Mini reader and function primitives, % needs IO, SUB2, SUB3 and SUB4 IN "xxx-header.red"$ In "PT:P-function-primitives.red"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS3.RED"$ on syslisp; Compiletime GLOBAL '(DEBUG); Procedure FirstCall; Begin scalar x,s1,s2,s3, Done,D1,D2; Init(); InitHeap(); LispVar(DEBUG) := 'T; % To get ID stuff out Dashed "Test EQSTR"; s1:='"AB"; s2:='"Ab"; s3:='"ABC"; ShouldBe("EqStr(AB,AB)",EqStr(s1,s1),'T); ShouldBe("EqStr(AB,AB)",EqStr(s1,"AB"),'T); ShouldBe("EqStr(AB,Ab)",EqStr(s1,s2),'NIL); ShouldBe("EqStr(AB,ABC)",EqStr(s1,s3),'NIL); Dashed "Test Intern on existing ID's"; ShouldBe("Intern(A)",Intern "A", 'A); ShouldBe("Intern(AB)",Intern S1, 'AB); Dashed "Test Intern on new ID, make sure same place"; D1:=Intern S3; ShouldBe("Intern(ABC)",Intern("ABC"),D1); D2:=Intern "FOO"; ShouldBe("Intern(ABC) again",Intern("ABC"),D1); Dashed "Test RATOM loop. Type various ID's, STRING's and INTEGER's"; MoreStuff(); InitRead(); While Not Done do <<x:=Ratom(); prin2 "Item read="; Prtitm x; Print x; if x eq 'Q then Done := 'T;>>; LispVar(DEBUG) := 'NIL; % Turn off PRINT Dashed "Test READ loop. Type various S-expressions"; MoreStuff(); Done:= 'NIL; While Not Done do <<x:=READ(); Prin2 '" Item read="; Prtitm x; Print x; if x eq 'Q then Done := 'T;>>; Functiontest(); Quit; End; Procedure MoreStuff; <<Spaced "Move to next part of test by typing the id Q"; Spaced "Inspect printout carefully">>; Fluid '(CodePtr!* CodeForm!* CodeNarg!*); procedure FunctionTest(); Begin scalar c1,c2,ID1,x; Dashed "Tests of FUNCTION PRIMITIVES "; ShouldBe("FunBoundP(Compiled1)",FunBoundP 'Compiled1,NIL); ShouldBe("FunBoundP(ShouldBeUnbound)",FunBoundP 'ShouldBeUnBound,T); ShouldBe("FCodeP(Compiled1)",FCodeP 'Compiled1,T); ShouldBe("FCodeP(ShouldBeUnbound)",FcodeP 'ShouldBeUnBound,NIL); ShouldBe("FCodeP(Compiled2)",FCodeP 'Compiled2,T); Dashed "Now MakeFunBound"; MakeFunBound('Compiled2); ShouldBe("FCodeP(Compiled2)",FCodeP 'Compiled2,NIL); ShouldBe("FUnBoundP(Compiled2)",FUnBoundP 'Compiled2,T); Dashed "Now copy CODEPTR of Compiled1 to Compiled2 "; C1:=GetFCodePointer('Compiled1); C2:=GetFCodePointer('Compiled2); ShouldBe("CodeP(C1)",CodeP C1,T); ShouldBe("CodeP(C2)",CodeP C2,NIL); MakeFcode('Compiled2,C1); ShouldBe("C1=GetFcodePointer 'Compiled2", C1=GetFCodePointer 'Compiled2,T); ShouldBe("Compiled2()",Compiled2(),12345); Dashed "Now test CodePrimitive"; CodePtr!* := GetFCodePointer 'Compiled3; X:= CodePrimitive(10,20,30,40); Shouldbe(" X=1000",1000,X); Dashed "Test CompiledCallingInterpreted hook"; CompiledCallingInterpreted(); Dashed "Now Create PRETENDINTERPRETIVE"; MakeFlambdaLink 'PretendInterpretive; Shouldbe("FlambdaLinkP",FlambdaLinkP 'PretendInterpretive,T); Shouldbe("Fcodep",FCodeP 'PretendInterpretive,NIL); Shouldbe("FUnBoundP",FUnBoundP 'PretendInterpretive,NIL); Dashed "Now call PRETENDINTERPRETIVE"; x:=PretendInterpretive(500,600); ShouldBe("PretendInterpretive",x,1100); End; % Auxilliary Compiled routines for CodeTests: Procedure Compiled1; << Dotted "Compiled1 called"; 12345>>; Procedure Compiled2; << Dotted"Compiled2 called"; 67890>>; Procedure Compiled3(A1,A2,A3,A4); <<Dotted "Compiled3 called with 4 arguments , expect 10,20,30,40"; Prin2 " A1=";Prin2T A1; Prin2 " A2=";Prin2T A2; Prin2 " A3=";Prin2T A3; Prin2 " A4=";Prin2T A4; Prin2t "Now return 1000 to caller"; 1000>>; syslsp procedure UndefinedFunctionAuxAux ; Begin scalar FnId; FnId := MkID UndefnCode!*; Prin2 "Undefined Function "; Prin1 FnId; Prin2 " called with "; Prin2 LispVar UndefnNarg!*; prin2T " args from compiled code"; Quit; End; % some primitives use by FastApply syslsp procedure CompiledCallingInterpretedAux(); Begin scalar FnId,Nargs; Prin2t "COMPILED Calling INTERPRETED"; Prin2 "CODEFORM!*= "; Print LispVar CodeForm!*; Nargs:=LispVar CodeNarg!*; FnId := MkID LispVar CodeForm!*; Prin2 "Function: "; Prin1 FnId; Prin2 " called with "; Prin2 Nargs; prin2T " args from compiled code"; Return 1100; End; Off syslisp; End; |
Added psl-1983/tests/main4.sym version [de0ae8e130].
> > > > > | 1 2 3 4 5 | (SAVEFORCOMPILATION (QUOTE (PROGN))) (SETQ ORDEREDIDLIST!* (QUOTE NIL)) (SETQ ORDEREDIDLIST!* (CONS ORDEREDIDLIST!* (LASTPAIR ORDEREDIDLIST!*))) (SETQ NEXTIDNUMBER!* (QUOTE 129)) (SETQ STRINGGENSYM!* (QUOTE "L0000")) |
Added psl-1983/tests/main5.red version [3d12d610cd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN5.RED : Small READ-EVAL-PRINT Loop % Needs IO, SUB2, SUB3, SUB4, SUB5 IN "xxx-header.red"$ IN "PT:STUBS3.RED"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS5.RED"$ on syslisp; Compiletime FLUID '(DEBUG FnTypeList !*RAISE !$EOF!$ !*PVAL !*ECHO); Procedure FirstCall; Begin scalar x, Done, Hcount; Init(); InitHeap(); TestGet(); InitEval(); Prin2t '"(very) MINI-PSL: A Read-Eval-Print Loop, terminate with Q"; Prin2T '" !*RAISE and !*PVAL have been set T"; Prin2T '" Should be able to execute any COMPILED expressions"; Prin2T '" typed in. Run (TESTSERIES) when ready"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!$EOF!$) := MkID Char EOF$ Hcount :=0; LispVar(!*RAISE) := 'T; % Upcase input IDs While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x eq 'Q then Done := 'T else if x eq !$EOF!$ then <<terpri(); Prin2T " **** Top Level EOF ****">> else <<Terpri(); x:=EVAL x; If LISPVAR(!*PVAL) then Print x>>; >>; Quit; End; % ---- Test Routines: syslsp procedure TestSeries(); <<Dashed "TESTs called by TESTSERIES"; TestUndefined()>>; syslsp procedure TestGet(); Begin Dashed "Tests of GET and PUT"; Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),NIL); Shouldbe("PUT('FOO,'FEE,'FUM)",PUT('FOO,'FEE,'FUM),'FUM); Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),'FUM); Shouldbe("REMPROP('FOO,'FEE)",REMPROP('FOO,'FEE),'FUM); Shouldbe("GET('FOO,'FEE)",GET('FOO,'FEE),NIL); end; syslsp procedure TestUndefined; <<Print "Calling SHOULDBEUNDEFINED"; ShouldBeUndefined(1)>>; % Some dummies: procedure UnbindN N; Stderror '"UNBIND only added at MAIN6"; procedure Lbind1(x,y); StdError '"LBIND1 only added at MAIN6"; Off syslisp; End; |
Added psl-1983/tests/main6.red version [73db7cf664].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAIN6.RED : Small READ-EVAL-PRINT Loop % Needs IO, SUB2, SUB3, SUB4, SUB5, SUB6 IN "xxx-header.red"$ IN "PT:STUBS3.RED"$ IN "PT:STUBS4.RED"$ IN "PT:STUBS5.RED"$ IN "PT:STUBS6.RED"$ on syslisp; Compiletime GLOBAL '(DEBUG !*RAISE !$EOF!$); Procedure FirstCall; Begin scalar x, Done, Hcount; Init(); InitHeap(); InitEval(); Prin2t '"MINI-PSL: A Read-Eval-Print Loop, terminate with Q"; Prin2T '" !*RAISE has been set T"; Prin2T '" Run (TESTSERIES) to check BINDING etc"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t " .... Now Call INITCODE"; InitCode(); Prin2t " .... Return from INITCode, Now toploop"; While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x eq 'Q then Done := 'T else if x = !$EOF!$ then <<Terpri(); Prin2T " **** Top Level EOF **** ">> else <<Terpri(); x:=EVAL x; Print x>>; >>; Quit; End; CompileTime FLUID '(AA); Procedure TESTSERIES(); Begin BindingTest(); InterpTest(); CompBindTest(); End; Procedure BindingTest; Begin Dashed "Test BINDING Primitives"$ LispVar(AA):=1; PBIND1('AA); % Save the 1, insert a NIL LBIND1('AA,3); % save the NIL, insert a 3 ShouldBe('"3rd bound AA",LispVar(AA),3); UnBindN 1; ShouldBe('"2rd bound AA",LispVar(AA),NIL); UnBindN 1; ShouldBe('"Original AA",LispVar(AA),1); End; Global '(Lambda1 Lambda2 CodeForm!*); Procedure InterpTest(); Begin Dashed "TEST of Interpreter Primitives for LAMBDA's "; Lambda1:='(LAMBDA (X1 X2) (PRINT (LIST 'LAMBDA1 X1 X2)) 'L1); Lambda2:='(LAMBDA (Y1 Y2) (PRINT (LIST 'LAMBDA2 Y1 Y2)) 'L2); Spaced "LAMBDA1: "; Print Lambda1; Dashed "FastLambdaApply on Lambda1"; CodeForm!*:=Lambda1; ShouldBe("FastLambdaApply", FastLambdaApply(10,20),'L1); Dashed "Now Test FASTAPPLY"; TestApply(" Compiled ID 1 ", 'Compiled1,'C1); TestApply(" CodePointer 2 ", GetFcodePointer 'Compiled2,'C2); TestApply(" Lambda Expression 1 ", Lambda1,'L1); Dashed "Test a compiled call on Interpreted code "; PutD('Interpreted3,'Expr, '(LAMBDA (ag1 ag2 ag3) (Print (list 'Interpreted3 Ag1 Ag2 Ag3)) 'L3)); ShouldBe(" FlambdaLinkP",FlambdaLinkP 'Interpreted3,T); ShouldBe(" Interp3", Interpreted3(300,310,320),'L3); PutD('Interpreted2,'Expr,Lambda2); TestApply(" Interpreted ID 2 ", 'Interpreted2,'L2); End; LAP '((!*entry TestFastApply expr 0) % Args loaded so move to fluid and go (!*Move (FLUID TestCode!*) (reg t1)) (!*JCALL FastApply)); Procedure TestApply(Msg,Fn,Answer); Begin scalar x; Prin2 " Testapply case "; prin2 Msg; Prin2 " given "; Print Fn; TestCode!* := Fn; x:=TestFastApply('A,'B); Return ShouldBe(" answer",x,Answer); End; Procedure Compiled1(xxx,yyy); <<Prin2 " Compiled1("; Prin1 xxx; Prin2 " "; Prin1 yyy; Prin2T ")"; 'C1>>; Procedure Compiled2(xxx,yyy); <<Prin2 " Compiled2("; Prin1 xxx; Prin2 " "; Prin1 yyy; Prin2T ")"; 'C2>>; CompileTime Fluid '(CFL1 CFL2 CFL3); Procedure CompBindTest(); Begin Dashed "Test LAMBIND and PROGBIND in compiled code"; CFL1:='TOP1; CFL2:='TOP2; Cbind1('Mid0,'Mid1,'Mid2); Shouldbe("CFL1",CFL1,'Top1); Shouldbe("CFL2",CFL2,'Top2); End; procedure Cbind1(x,CFL1,CFL2); Begin Shouldbe("x ",x ,'Mid0); Shouldbe("CFL1",CFL1,'Mid1); Shouldbe("CFL2",CFL2,'Mid2); Cbind2(); Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Mid2); End; Procedure Cbind2(); Begin Shouldbe("CFL1",CFL1,'Mid1); Shouldbe("CFL2",CFL2,'Mid2); Begin scalar x,CFL2; CFL1:='Bot1; CFL2:='Bot2; Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Bot2); End; Shouldbe("CFL1",CFL1,'Bot1); Shouldbe("CFL2",CFL2,'Mid2); End; End; |
Added psl-1983/tests/main7.red version [39170dbd1e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % main7.red : Small READ-EVAL-PRINT Loop WITH IO % Needs IO, SUB2, SUB3, SUB4, SUB5, SUB6,SUB7 IN "xxx-header.red"$ in "pt:stubs3.red"$ in "pt:stubs4.red"$ in "pt:stubs5.red"$ in "pt:stubs6.red"$ in "pt:stubs7.red"$ in "pt:psl-timer.sl"$ on syslisp; Compiletime GLOBAL '(DEBUG IN!* OUT!* !$EOF!$ !*PVAL); Procedure FirstCall; Begin scalar x, Done, Hcount; INIT(); InitHeap(); InitEval(); Prin2t '"MINI-PSL with File I/O"; Prin2T '" Type (IOTEST) to test basic file I/O"; Prin2T '" Future tests will be READ in this way"; Prin2T '" !*RAISE and !*PVAL set T"; LispVar(DEBUG) := 'NIL; % For nice I/O InitRead(); LispVar(!*RAISE) := 'T; % Upcase Input IDs LispVar(!*PVAL) := 'T; % Print VALUEs LispVar(!$EOF!$) := MKID Char EOF; % Check for EOF Hcount :=0; Prin2t " .... Now we test INITCODE"; InitCode(); LISPVAR(IN!*):=0; LISPVAR(OUT!*):=1; Hcount :=0; ClearIo(); While Not Done do <<Hcount:=Hcount+1; Prin2 Hcount; Prin2 '" lisp> "; x:=READ(); if x EQ !$EOF!$ then <<Terpri(); Prin2T " *** Top Level EOF *** ">> else if x eq 'QUIT then Done := 'T else <<Terpri(); x:=EVAL x; if Lispvar(!*PVAL) then Print x>>; >>; Quit; End; %---- File Io tests ---- Off syslisp; Procedure Iotest; Begin scalar InFile, OutFile,Ch,S,InString,OutString; Prin2T "---- Test of File IO"; IN!*:=0; Out!*:=1; Prin2T " Test CLEARIO"; A: Prin2T " Input String for Input File"; Instring:=Read(); Terpri(); If not StringP Instring then goto A; B: Prin2T " Input String for OutPut File"; OutString:=Read(); Terpri(); If not StringP Outstring then goto B; Infile:=Open(InString,'Input); prin2 " Input File Opened on "; Prin2 Infile; PRIN2T ", copy to TTY "; While Not ((ch:=IndependentReadChar(InFILE)) eq 26) do PutC Ch; Close Infile; Prin2T " File Closed, Input test done"; Infile:=Open(InString,'Input); OutFile:=Open(OutString,'OutPut); prin2 " Input File on "; Prin2 Infile; PRIN2 ", copy to Output File on"; Prin2T OutFile; While Not ((ch:=IndependentReadChar(InFILE)) eq 26) do IndependentWriteChar(outFile,Ch); Close Infile; Close OutFile; Prin2 "Both Files Closed, Inspect File:"; Prin2T OutString; End; End; |
Added psl-1983/tests/make-headers.mic version [4b357c6884].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @conn pt: @get psl:rlisp @st *load "g:proc-headers"; *on nocomment, noprefix; % Set up for smallest output *remd ''ImportantLine; *copyd(''ImportantLine,''ImportantLine2); *Manyheaders(''(main2 sub2 stubs2 main3 sub3 stubs3 main4 sub4 stubs4 main5 sub5 stubs5 main6 sub6 stubs6 main7 sub7 stubs7 mini!-allocators mini!-arithmetic mini!-carcdr mini!-char!-io mini!-comp!-support mini!-cons!-mkvect mini!-dskin mini!-easy!-non!-sl mini!-easy!-sl mini!-equal mini!-error!-errorset mini!-error!-handlers mini!-eval!-apply mini!-gc mini!-io!-errors mini!-known!-to!-comp mini!-loop!-macros mini!-oblist mini!-open!-close mini!-others!-sl mini!-printers mini!-printf mini!-property-list mini!-putd!-getd mini!-rds!-wrs mini!-read mini!-sequence mini!-symbol!-values mini!-token mini!-top!-loop mini!-type!-conversions mini!-type!-errors p!-apply!-lap p!-fast!-binder p!-function!-primitives p20t!:xxx!-header p20t!:xxx!-system!-io p20t!:20!-test!-global!-data ), ''all!-test); *load "g:sort-file"; *sort!-file("all-test.headers","all-test.sorted"); *quit; @reset . |
Added psl-1983/tests/mathlib.tst version [98678d1b91].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. MATHLIB.TST % A simple set of tests for MAthLIB LOAD MATHLIB$ Global '(EPS); EPS:=1.0/(1.0E6); Fexpr procedure TS L$ % (Function,Arg,Expected Value) Begin scalar Fn,Arg,Val,x,y; Fn:=car L$ Arg:=EVAL cadr L$ Val:=EVAL Caddr L$ x:=Apply(fn, list arg)$ PrintF(" %r(%p) = %p, expect %p%n",Fn,arg,x,val)$ y:=abs(x-val); if y>=EPS then PrintF(" ***** %p exceeds EPS%n",y); End$ TS(Ceiling,3,3); TS(Ceiling,3.1,4); TS(Ceiling,3.7,4); TS(Ceiling,-3,-3); TS(Ceiling,-3.5,-2); TS(Round,3,3); TS(Round,3.1,3); TS(Round,3.5,4); TS(Round,3.7,4); TS(Round,-3,-3); TS(Round,-3.4,-2); TS(Round,-3.7,-3); TwoPI := 6.2831853; PI:=TwoPI/2; PI2:=PI/2; PI4:=PI/4; PI8:=PI/8; Root2:=1.4142136; Root2**2 - 2.0; TS(sin, 0.0, 0.0)$ TS(cos, 0.0, 1.0)$ TS(sin, PI4, Root2/2)$ TS(cos, PI4, Root2/2)$ TS(sin, PI2, 1.0)$ TS(cos, PI2, 0.0)$ TS(sin, 3*PI4, Root2/2)$ TS(cos, 3*PI4, -Root2/2)$ TS(sin, PI, 0.0)$ TS(cos, PI, -1.0)$ procedure SC2 x; sin(x)**2+cos(x)**2; TS(SC2,0.0,1)$ TS(SC2,0.25,1)$ TS(SC2,0.5,1)$ TS(SC2,0.75,1)$ TS(SC2,1.0,1)$ TS(SC2,1.25,1)$ TS(SC2,1.5,1)$ TS(SC2,1.75,1)$ TS(SC2,2.0,1)$ TS(SC2,2.25,1)$ TS(SC2,2.5,1)$ TS(SC2,2.75,1)$ TS(SC2,3.0,1)$ TS(TAN,0.0,0.0)$ TS(TAN,PI8,SIN(PI8)/COS(PI8))$ TS(TAN,PI4,1.0)$ TS(COT,PI8,COS(pi8)/SIN(pi8))$ TS(COT,PI4,1.0)$ TS(SIND,30.0,0.5)$ TS(ASIND,0.5,30.0)$ TS(SQRT,2.0,Root2)$ TS(SQRT,9.0,3.0)$ TS(SQRT,100.0,10.0)$ NaturalE:=2.718281828$ TS(EXP,1.0,NaturalE)$ TS(LOG,SQRT(NaturalE),0.5)$ TS(LOG,NaturalE,1.0)$ TS(LOG,NaturalE**2,2.0)$ TS(LOG,1.0/NaturalE**2, -2.0)$ TS(LOG2,Root2,0.5)$ TS(LOG2,2.0,1.0)$ TS(LOG2,4.0,2.0)$ TS(LOG2,0.5, -1.0)$ TS(LOG10,SQRT(10.0),0.5)$ TS(LOG10,10.0,1.0)$ TS(LOG10,100.0,2.0)$ TS(LOG10, 1.0E30, 30.0)$ TS(LOG10, 1.0E-30, -30.0)$ End$ |
Added psl-1983/tests/mini-allocators.red version [d919fb0fd6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-ALLOC.RED : Crude Mini Allocator and support % See PT:P-ALLOCATORS.RED % Revisions: MLG, 18 Feb,1983 % Moved HEAP declaration to XXX-HEADER % Had to provide an InitHeap routine % (or will be LoadTime :=) on syslisp; external Wvar HeapLowerBound, HeapUpperBound; external WVar HeapLast, % next free slot in heap HeapPreviousLast; % save start of new block syslsp procedure GtHEAP N; % get heap block of N words if null N then (HeapUpperBound - HeapLast) / AddressingUnitsPerItem else << HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then << !%Reclaim(); HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then FatalError "Heap space exhausted" >>; HeapPreviousLast >>; syslsp procedure GtSTR N; % Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtVECT N; % Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; Procedure GtWarray N; % Dummy for Now, since no GC GtVect N; Procedure GtID(); % Simple ID Allocator Begin scalar D; D:=NextSymbol; NextSymbol:=NextSymbol+1; return D; End; Off syslisp; End; |
Added psl-1983/tests/mini-arithmetic.red version [4ae92b191a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-ARITHMETIC.RED simple ARITHmetic functions Procedure Plus2(x,y); if numberp x and numberp y then sys2int(wplus2(intinf x,intinf y)) else NonNumberError(cons(x,y),'Plus2); Procedure Minus(x); if numberp x then sys2int wminus intinf x else NonNumberError(x,'Minus); Procedure Add1 N; If Numberp N then sys2int wplus2(N,1) else else NonNumberError(N,'Add1); Procedure SUB1 N; If Numberp N then sys2int wdifference(N,1) else NonNumberError(N,'SUB1); Procedure GreaterP(N1,N2); If NumberP N1 and NumberP N2 then wGreaterp(intinf N1,intinf N2) else NIL; Procedure LessP(N1,N2); If NumberP N1 and NumberP N2 then Wlessp(intinf N1,intinf N2) else NIL; Procedure DIFFERENCE(N1,N2); If NumberP N1 and NumberP N2 then sys2int wdifference(intinf N1,intinf N2) else NonNumberError(cons(N1,N2),'Difference); Procedure TIMES2(N1,N2); If NumberP N1 and NumberP N2 then sys2int Wtimes2(intinf N1,intinf N2) else NonNumberError(cons(N1,N2),'TIMES2); End; |
Added psl-1983/tests/mini-carcdr.red version [933e8bfeb2].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-CAR-CDR.RED % ---- Some Basic LIST support Functions Procedure Car x; if Pairp x then car x else <<Print "*** Cant take CAR of NON PAIR";NIL>>; Procedure Cdr x; if Pairp x then cdr x else <<Print "*** Cant take CDR of NON PAIR";NIL>>; % -- CxxR -- may need in EVAL if not open coded Procedure Caar x; Car Car x; Procedure Cadr x; Car Cdr x; Procedure Cdar x; Cdr Car x; Procedure Cddr x; Cdr Cdr x; end; |
Added psl-1983/tests/mini-char-io.red version [9a224f7efa].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MINI-CHAR-IO.RED Procedure ChannelWriteChar(chn,x); PutC x; Procedure WriteChar Ch; IndependentWriteChar(Out!*,Ch); End; |
Added psl-1983/tests/mini-comp-support.red version [a200588768].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % MINI-COMP-SUPPORT.RED - Support for LIST etc %/ Identical to PK:COMP-SUPPORT? procedure List2(A1,A2); Cons(A1,Ncons A2); procedure List3(A1,A2,A3); Cons(A1,List2(A2,A3)); procedure List4(A1,A2,A3,A4); Cons(A1,List3(A2,A3,A4)); procedure List5(A1,A2,A3,A4,A5); Cons(A1,List4(A2,A3,A4,A5)); end; |
Added psl-1983/tests/mini-cons-mkvect.red version [498e774757].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-CONS.RED : Cons, MkVect etc for testing %/Almost identical to PK:CONS-MKVECT on syslisp; procedure HardCons(x,y); Begin scalar c; c:=GtHeap PairPack(); c[0]:=x; c[1]:=y; Return MkPAIR(c); End; procedure Cons(x,y); HardCons(x,y); procedure Xcons(x,y); HardCons(y,x); procedure Ncons x; HardCons(x,'NIL); syslsp procedure MkVect N; % Allocate vector, init all to NIL if IntP N then << N := IntInf N; if N < (-1) then StdError '"A vector with fewer than zero elements cannot be allocated" else begin scalar V; V := GtVect N; for I := 0 step 1 until N do VecItm(V, I) := NIL; return MkVEC V; % Tag it end >> else NonIntegerError(N, 'MkVect); off syslisp; End; |
Added psl-1983/tests/mini-copiers.red version [fb1c324373].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % COPIERS.RED - Functions for copying various data types % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % % <PSL.KERNEL>COPIERS.RED.2, 28-Sep-82 10:21:15, Edit by PERDUE % Made CopyStringToFrom safe and to not bother clearing the % terminating byte. on SysLisp; syslsp procedure CopyStringToFrom(New, Old); %. Copy all chars in Old to New begin scalar SLen, StripNew, StripOld; StripNew := StrInf New; StripOld := StrInf Old; SLen := StrLen StripOld; if StrLen StripNew < SLen then SLen := StrLen StripNew; for I := 0 step 1 until SLen do StrByt(StripNew, I) := StrByt(StripOld, I); return New; end; syslsp procedure CopyString S; %. copy to new heap string begin scalar S1; S1 := GtSTR StrLen StrInf S; CopyStringToFrom(S1, StrInf S); return MkSTR S1; end; syslsp procedure CopyWArray(New, Old, UpLim); %. copy UpLim + 1 words << for I := 0 step 1 until UpLim do New[I] := Old[I]; New >>; syslsp procedure CopyVectorToFrom(New, Old); %. Move elements, don't recurse begin scalar SLen, StripNew, StripOld; StripNew := VecInf New; StripOld := VecInf Old; SLen := VecLen StripOld; % assumes VecLen New has been set for I := 0 step 1 until SLen do VecItm(StripNew, I) := VecItm(StripOld, I); return New; end; syslsp procedure CopyVector S; %. Copy to new vector in heap begin scalar S1; S1 := GtVECT VecLen VecInf S; CopyVectorToFrom(S1, VecInf S); return MkVEC S1; end; syslsp procedure CopyWRDSToFrom(New, Old); %. Like CopyWArray in heap begin scalar SLen, StripNew, StripOld; StripNew := WrdInf New; StripOld := WrdInf Old; SLen := WrdLen StripOld; % assumes WrdLen New has been set for I := 0 step 1 until SLen do WrdItm(StripNew, I) := WrdItm(StripOld, I); return New; end; syslsp procedure CopyWRDS S; %. Allocate new WRDS array in heap begin scalar S1; S1 := GtWRDS WrdLen WrdInf S; CopyWRDSToFrom(S1, WrdInf S); return MkWRDS S1; end; % CopyPairToFrom is RplacW, found in EASY-NON-SL.RED % CopyPair is: car S . cdr S; % Usual Lisp definition of Copy only copies pairs, is found in EASY-NON-SL.RED syslsp procedure TotalCopy S; %. Unique copy of entire structure begin scalar Len, Ptr, StripS; % blows up on circular structures return case Tag S of PAIR: TotalCopy car S . TotalCopy cdr S; STR: CopyString S; VECT: << StripS := VecInf S; Len := VecLen StripS; Ptr := MkVEC GtVECT Len; for I := 0 step 1 until Len do VecItm(VecInf Ptr, I) := TotalCopy VecItm(VecInf S, I); Ptr >>; WRDS: CopyWRDS S; FIXN: MkFIXN Inf CopyWRDS S; FLTN: MkFLTN Inf CopyWRDS S; default: S end; end; off SysLisp; END; |
Added psl-1983/tests/mini-dskin.red version [947b931a4b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-DSKIN.RED Procedure TypeFile F; Begin Scalar InChan,OldChan,c; InChan:=Open(F,'Input); OldChan:=Rds InChan; While Not ((c:=Getc()) eq 26) do PutC(c); rds OldChan; close InChan; end; Procedure DskIn F; Begin scalar Infile, OldFile,x; Infile:=Open(F,'Input); OldFile:=RDS Infile; While not ((x:=Read()) eq !$eof!$) do << x:=Eval x; If !*Pval then Print x>>; RDS OldFile; Close InFile; End; FLUID '(!*Echo !*PVAL); procedure Lapin F; Begin scalar !*echo, !*pval; Return Dskin F; End; End; |
Added psl-1983/tests/mini-easy-non-sl.red version [a3089b8949].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-NON-SL.RED Simple non sl functions Procedure Atsoc(x,y); If Not PAIRP y then NIL else if Not PAIRP car y then Atsoc(x,cdr y) else if x EQ car car y then car y else Atsoc(x, cdr y); Procedure GEQ(N1,N2); not(N1< N2); Procedure LEQ(N1,N2); not(N1 > N2); Procedure EqCar(x,y); PairP x and (Car(x) eq y); procedure COPYD(newId,OldId); Begin scalar x; x:=Getd OldId; If not Pairp x then return <<Print List(OLDID, " has no definition in COPYD "); NIL>>; Return PUTD(newId,car x,cdr x); End; Procedure Delatq(x,y); If not Pairp y then NIL else if not Pairp car y then CONS(car y,Delatq(x,cdr y)) else if x eq caar y then cdr y else CONS(car y,Delatq(x,cdr y)); End; |
Added psl-1983/tests/mini-easy-sl.red version [5c170ce9c8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-EASY-SL.RED --- Simple functions % --- Some basic predicates % Note that the bodies open copile, so this is just for % interpreter entries Procedure Atom x; Atom x; % Simple LIST stuff Procedure append(U,V); if not PairP U then V else Cons(Car U,Append(Cdr U,V)); Procedure MemQ(x,y); If Not PAIRP y then NIL else if x EQ car y then T else MemQ(x, cdr y); Procedure REVERSE U; Begin Scalar V; While PairP U do <<V:=CONS(Car U,V); U:=CDR U>>; Return V; End; % Simple EVAL support procedure Evlis x; if Not Pairp x then x else Eval(car x) . Evlis(cdr x); procedure EvProgn fl; Begin scalar x; While PairP fl do <<x:=Eval Car fl; fl:=Cdr fl>>; Return x; End; fexpr procedure Progn x; EvProgn x; procedure EvCond fl; if not PairP fl then 'NIL else if not PairP car fl then EvCond cdr fl else if Eval car car fl then EvProgn cdr car fl else EvCond cdr fl; fexpr procedure Cond x; EvCond x; Fexpr Procedure Quote a; Car a; Fexpr Procedure SETQ a; Set(car a,Eval Cadr a); fexpr Procedure De(x); PutD(car x,'Expr,'LAMBDA . cdr x); fexpr Procedure Df(x); PutD(car x,'Fexpr,'LAMBDA . Cdr x); fexpr Procedure Dn(x); PutD(car x,'NExpr,'LAMBDA . cdr x); fexpr Procedure Dm(x); PutD(car x,'Macro,'LAMBDA . Cdr x); nexpr procedure List x; x; End; |
Added psl-1983/tests/mini-equal.red version [1182cc7bed].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % MINI-EQUAL.RED on syslisp; Procedure EqStr(s1,S2); Begin scalar n; s1:=strinf(s1); s2:=strinf(s2); n:=strlen(s1); if n neq strlen(s2) then return 'NIL; L:if n<0 then return 'T; if strbyt(s1,n) neq strbyt(s2,n) then return 'NIL; n:=n-1; goto L; End; off syslisp; end; |
Added psl-1983/tests/mini-error-errorset.red version [a48d27fb23].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % MINI-ERROR-ERRORSET on syslisp; syslsp procedure ErrorHeader; Prin2String "*** ERROR *** "; syslsp procedure Error s; <<ErrorHeader(); ErrorTrailer s>>; syslsp procedure ErrorTrailer s; <<Prin2T s; Quit;>>; off syslisp; End; |
Added psl-1983/tests/mini-error-handlers.red version [0c96c2ba29].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % MINI-ERROR-HANDLERS.RED - Error Handler stubs on syslisp; syslsp procedure FatalError s; <<ErrorHeader(); Prin2 " FATAL "; ErrorTrailer s>>; syslsp procedure StdError m; Error m; off syslisp; end; |
Added psl-1983/tests/mini-eval-apply.red version [65bbcb14f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-EVAL-APPLY.RED - A small EVAL, uses P-APPLY-LAP On syslisp; Procedure InitEval; Begin Put('Quote,'Ftype,'FEXPR); Put('Setq,'Ftype,'FEXPR); Put('Cond,'Ftype,'FEXPR); Put('Progn,'Ftype,'FEXPR); Put('While,'Ftype,'FEXPR); Put('List,'Ftype,'NEXPR); Put('De,'Ftype,'FEXPR); Put('Df,'Ftype,'FEXPR); Put('Dn,'Ftype,'FEXPR); Put('Dm,'Ftype,'FEXPR); End; syslsp procedure Eval x; If IDP x then SYMVAL(IdInf x) else if not PairP x then x else begin scalar fn,a,FnType; fn:=car x; a:=cdr x; if LambdaP fn then Return LambdaEvalApply(GetLambda fn, a); if CodeP fn then Return CodeEvalApply(fn,a); if not Idp fn then Return <<Prin2('"**** Non-ID function in EVAL: "); Print fn; NIL>>; if FunBoundP fn then Return <<Prin2('"**** UnBound Function in EVAL: "); Print fn; NIL>>; FnType :=GetFnType Fn; if FnType = 'FEXPR then return IDApply1(a, Fn); if FnType = 'NEXPR then return IDApply1(Evlis a, Fn); if FnType = 'MACRO then return Eval IDApply1(x, Fn); if FLambdaLinkP fn then return LambdaEvalApply(GetLambda fn,a); return CodeEvalApply(GetFcodePointer fn, a); end; procedure Apply(fn,a); Begin scalar N; If LambdaP fn then return LambdaApply(fn,a); If CodeP fn then CodeApply(fn,a); If Not Idp Fn then return <<prin2 '" **** Non-ID function in APPLY: "; prin1 fn; prin2 " "; Print a; NIL>>; if FLambdaLinkP fn then return LambdaApply(GetLambda fn,a); If FunBoundP Fn then return <<prin2 '" **** Unbound function in APPLY: "; prin1 fn; prin2 " "; Print a; NIL>>; Return CodeApply(GetFcodePointer Fn,a); End; % -- User Function Hooks --- Procedure LambdaApply(x,a); Begin scalar v,b; x:=cdr x; v:=car x; b:=cdr x; Return DoLambda(v,b,a) End; Procedure LambdaEvalApply(x,y); LambdaApply(x,Evlis y); Procedure DoLambda(vars,body,args); % Args already EVAL'd as appropriate Begin scalar N,x,a; N:=Length vars; For each v in VARS do <<if pairp args then <<a:=car args; args:=cdr args>> else a:=Nil; LBIND1(v,a)>>; %/ Should try BindEVAL here x:=EvProgn Body; UnBindN N; Return x; End; Procedure LambdaP(x); EqCar(x,'LAMBDA); Procedure GetLambda(fn); Get(fn,'!*LambdaLink); off syslisp; End; |
Added psl-1983/tests/mini-gc.red version [47687fbb7b].
> > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-RECLAIM.RED - RECLAIM stubs for TEST series on syslisp; External Wvar HeapLowerBound, HeapUpperBound, HeapLast; Procedure !%Reclaim(); <<Prin2 '" *** Dummy !%RECLAIM: "; HeapInfo()>>; Procedure Reclaim(); <<Prin2 '"*** Dummy RECLAIM: "; HeapInfo()>>; Procedure HeapInfo(); << Prin1 ((HeapLast-HeapLowerBound)/AddressingUnitsPerItem); Prin2 '" Items used, "; Prin1 ((HeapUpperBound -HeapLast)/AddressingUnitsPerItem); Prin2t '" Items left."; 0>>; off syslisp; End; |
Added psl-1983/tests/mini-io-errors.red version [415be574f2].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | % MINI-IO-ERRORS.RED Procedure IoError M; <<terpri(); ErrorHeader(); Prin2t M; RDS 0; WRS 1; NIL>>; End; |
Added psl-1983/tests/mini-known-to-comp.red version [ef895863f1].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % MINI-KNOWN-TO-COMP.RED syslsp procedure CodeP x; CodeP x; Procedure Pairp x; Pairp x; Procedure Idp x; Idp x; procedure Eq(x,y); eq(x,y); procedure Null x; x eq 'NIL; procedure Not x; x eq 'NIL; End; |
Added psl-1983/tests/mini-loop-macros.red version [002d731364].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MINI-LOOP-MACROS.RED fexpr procedure While fl; Begin if not PairP fl then return 'NIL; While Eval Car fl do EvProgn cdr fl; End; End; |
Added psl-1983/tests/mini-oblist.red version [5252dfb626].
> > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | % MINI-OBLIST.RED on syslisp; % ---- Small MAPOBL and printers Procedure MapObl(Fn); For i:=0:NextSymbol-1 do IdApply1(MkItem(ID,I),Fn); Procedure PrintFexprs; MapObl 'Print1Fexpr; Procedure Print1Fexpr(x); If FexprP x then Print x; Procedure PrintFunctions; MapObl 'Print1Function; Procedure Print1Function(x); If Not FUnboundP x then Print x; off syslisp; End; |
Added psl-1983/tests/mini-open-close.red version [7fe51b852a].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | % MINI-OPEN-CLOSE.RED Some minimal User Level I/O routines: Procedure Open(FileName,How); If how eq 'Input then SystemOpenFileForInput FileName else if how eq 'OutPut then SystemOpenFileForOutPut FileName else IoError "Cant Open"; Procedure Close N; IndependentCloseChannel N; end; |
Added psl-1983/tests/mini-others-sl.red version [34ea1acd25].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % MINI-OTHERS-SL.RED on syslisp; procedure Length U; % Length of list U, fast version Length1(U, 0); procedure Length1(U, N); if PairP U then Length1(cdr U, N+1) else N; off syslisp; end; |
Added psl-1983/tests/mini-printers.red version [4df1d986c0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PRINT.RED - More comprehensive Mini I/O % A mini Print routine % uses PutC and PutInt On syslisp; syslsp procedure Prin1 x; if IDP x then Prin1ID x else if IntP x then Prin1Int x else if StringP x then Prin1String x else if PairP x then Prin1Pair x else PrtItm x; syslsp procedure Prin2 x; if IDP x then Prin2ID x else if IntP x then Prin1Int x else if StringP x then Prin2String x else if PairP x then Prin2Pair x else PrtItm x; syslsp procedure Print x; <<Prin1 X; Terpri(); x>>; syslsp procedure Prin2t x; <<Prin2 X; Terpri(); x>>; % Support syslsp procedure Pblank; PutC Char '! ; syslsp procedure Prin1Int x; <<if x=0 then PutC Char 0 else if x<0 then <<PutC Char '!-; Prin1Int (-x)>> else Prin1IntX x; x>>; Procedure Prin1IntX x; If x=0 then NIL else <<Prin1IntX LongDiv(x,10); PutC (LongRemainder(x,10)+Char 0)>>; syslsp procedure Prin1ID x; <<Prin2String Symnam IdInf x; PBlank(); x>>; syslsp procedure Prin2Id x; prin1Id x; syslsp procedure Prin1String x; <<PutC Char '!"; Prin2String x; PutC Char '!"; Pblank(); x>>; syslsp procedure Prin2String x; Begin scalar s; s:=StrInf x; For i:=0:StrLen(s) do PutC StrByt(S,I); return x End; syslsp procedure Prin1Pair x; <<PutC Char '!(; Prin1 Car x; x:=Cdr X; While Pairp X do <<Pblank(); Prin1 Car X; X:=Cdr x>>; If Not NULL X then <<Prin2String " . "; Prin1 x>>; PutC Char '!) ; Pblank(); x>>; syslsp procedure Prin2Pair x; <<PutC Char '!(; Prin2 Car x; x:=Cdr X; While Pairp X do <<Pblank(); Prin2 Car X; X:=Cdr x>>; If Not NULL X then <<Prin2String " . "; Prin2 x>>; PutC Char '!) ; Pblank(); x>>; syslsp procedure terpri(); Putc Char EOL; syslsp procedure PrtItm x; <<Prin2String " <"; Prin1Int Tag x; PutC Char '!:; Prin1Int Inf x; Prin2String "> "; x>>; % Some stubs for later stuff Procedure ChannelPrin2(chn,x); Prin2 x; Off syslisp; End; |
Added psl-1983/tests/mini-printf.red version [c5dc63fe8e].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % MINI-PRINTF.RED Procedure BLDMSG(FMT,A1,A2,A3,A4,A5,A6); Begin Prin2t "BldMsg called"; Return Print LIST (FMT,A1,A2,A3); End; End; |
Added psl-1983/tests/mini-property-list.red version [e26d592cd6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PROPERTY-LIST.RED - Small GET and PUT on syslisp; Procedure Prop x; If not IDP x then NIL else SYMPRP IDINF x; Procedure Get(x,y); Begin scalar z,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If (Z:=Atsoc(y,L)) then return CDR Z; Return NIL; End; Procedure Put(x,y,z); Begin scalar P,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If (P:=Atsoc(y,L)) then return % <<CDR(PairInf P):=z; z>>; L:=CONS(CONS(y,z),L); SYMPRP(IDINF x):=L; Return z; End; Procedure RemProp(x,y); Begin scalar P,L; If Not IDP x then return NIL; L:=SYMPRP IDINF x; If not(P:=Atsoc(y,L)) then return NIL; L:=Delatq(y,L); SYMPRP(IDINF x):=L; Return CDR P; End; Procedure GetFnType x; Get(x,'Ftype); off syslisp; end; |
Added psl-1983/tests/mini-putd-getd.red version [912833a5f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-PUTD-GETD.RED Small COPYD, GETD, PUTD on syslisp; Procedure Getd(fn); Begin scalar type; if Not IDP fn then return <<Prin2 "*** Can only GETD off ID's: "; Print fn; NIL>>; if FunBoundP fn then return NIL; if null(type:=Get(fn,'Ftype)) then type:='Expr; if FCodeP fn then return ( type . GetFcodePointer fn); If FLambdaLinkP fn then return (type .Get(fn,'!*LambdaLink)); Prin2 "*** GETD should find a LAMBDA or CODE"; print fn; return NIL; End; Procedure PutD(fn,type,body); Begin if Not IDP fn then return <<Prin2 "*** Can only define ID's as functions: "; Print fn; NIL>>; if FCodeP fn then <<Prin2 "*** Redefining a COMPILED function: "; Print fn>> else if not FunBoundP fn then <<prin2 " Redefining function "; print fn>>; Remprop(fn,'!*LambdaLink); Remprop(fn,'Ftype); MakeFUnBound fn; If LambdaP body then << Put(fn,'!*LambdaLink,body); MakeFlambdaLink fn>> else if CodeP body then MakeFcode(fn,body) else return <<Prin2 "*** Body must be a LAMBDA or CODE"; prin1 fn; prin2 " "; print body; NIL>>; If not(type eq 'expr) then Put(fn,'Ftype,type); return fn; End; off syslisp; End; |
Added psl-1983/tests/mini-rds-wrs.red version [a0f0f6c58f].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % MINI-RDS-WRS.RED Fluid '(IN!* Out!*); Procedure RDS N; If NULL N then RDS 0 else begin scalar K; K:=IN!*; IN!*:=N; Return K end; Procedure WRS N; If NULL N then WRS 1 else begin scalar K; K:=Out!*; Out!*:=N; Return K end; End; |
Added psl-1983/tests/mini-read.red version [e65e25c076].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-READ.RED - A small reader CompileTime <<GLOBAL '(DEBUG); FLUID '(TOK!* TOKTYPE!* CH!* !*RAISE);>>; Procedure READ; % start RATOM, get first fresh token Read1(Ratom()); Procedure READ1(x); If x eq '!( then READLIST(RATOM()) % Skip the ( else if x eq '!' then CONS('QUOTE, NCONS READ()) else x; Procedure ReadList(x); % read LIST, starting at token x Begin scalar y; If x eq '!) then Return NIL; y:=Read1(x); % Finish read CAR of pair x:=Ratom(); % Check dot If x eq '!. then return CONS(y,car READLIST(RATOM())); Return CONS(y , READLIST(x)) End; End; |
Added psl-1983/tests/mini-sequence.red version [0621b1393a].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | % MINI-SEQUENCE.RED: Susbet of Strings, sequence etc for testing on syslisp; syslsp procedure MkString(L, C); % Make str with upb L, all chars C begin scalar L1, S; if IntP L then L1 := IntInf L else return NonIntegerError(L, 'MkString); if L1 < -1 then return NonPositiveIntegerError(L, 'MkString); S := GtStr L1; for I := 0 step 1 until L1 do StrByt(S, I) := C; return MkSTR S; end; off syslisp; End; |
Added psl-1983/tests/mini-symbol-values.red version [2f5df62185].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | % MINI-SYMBOL-VALUES.RED Procedure Set(x,y); Begin If IDP x then SYMVAL(IDINF x):=y else <<prin2 '"**** Non-ID in SET: ";Print x>>; return y; End; End; |
Added psl-1983/tests/mini-token.red version [74c56c32a0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-TOKEN.RED - Small Token scanner for testing CompileTime <<GLOBAL '(DEBUG); FLUID '(TOK!* TOKTYPE!* CH!* !*RAISE);>>; ON SYSLISP; Wstring Buffer[100]; % Will hold characters as they are parsed for ID, INT and string Procedure InitRead; % Initialize various RATOM and READ properties Begin LISPVAR(!*RAISE) := 'NIL; LISPVAR(CH!*) := Char '! ; LispVar(Tok!*):= 'NIL; LispVar(TokType!*) := 2; If LispVar(DEBUG) then <<Prin2 '"NextSymbol ="; Print Nextsymbol>>; End; Procedure SetRaise x; LISPVAR(!*RAISE) := x; Procedure Ratom; % Read a single ATOM: ID, POSINT, STRING or SPECIAL Begin ClearWhite(); If LispVar(CH!*) eq Char '!% then ClearComment(); If LISPVAR(CH!*) eq Char '!" then Return <<LispVar(TokType!*):=0;LispVar(Tok!*):=ReadStr()>>; If DigitP LISPVAR(CH!*) then Return <<LispVar(TokType!*):=1;LispVar(Tok!*):=ReadInt()>>; If AlphaEscP LISPVAR(CH!*) then Return <<LispVar(TokType!*):=2;LispVar(Tok!*):=ReadId()>>; LispVar(TokType!*):=3; LispVar(Tok!*):=MkItem(ID,LISPVAR(CH!*)); LISPVAR(CH!*):=Char '! ; % For read Ahead Return LispVar(Tok!*) End; Procedure ClearWhite(); % Clear out white space While WhiteP LISPVAR(CH!*) do LISPVAR(CH!*):=GetC(); Procedure ClearComment(); % Scan for Comment EOL << While LispVar(CH!*) neq char EOL do LISPVAR(CH!*):=GetC(); ClearWhite()>>; Procedure ReadInt; % Parse NUMERIC characters into a POSITIVE integer Begin scalar N; N:=LISPVAR(CH!*)-Char 0; While DigitP(LISPVAR(CH!*):=GetC()) do N:=LongTimes(10,N)+(LISPVAR(CH!*)-Char 0); Return Mkitem(POSINT,N); End; Procedure BufferToString n; % Convert first n chars of Buffer into a heap string Begin scalar s; s:=GtStr(n); for i:=0:n do strbyt(s,i):=strbyt(Buffer,i); return MkStr s; End; Procedure ReadStr; % Parse "...." into a heap string Begin scalar n; n:=-1; While ((LISPVAR(CH!*):=Getc())neq Char '!") do <<N:=N+1;Strbyt(Buffer,n):=LISPVAR(CH!*)>>; LISPVAR(CH!*):=char '! ; Return BufferToString(n); End; Procedure ReadID; % Parse Characters into Buffer, Make into an ID Begin scalar n,s,D; n:=0; StrByt(Buffer,0):=RaiseChar LISPVAR(CH!*); While AlphaNumEscP(LISPVAR(CH!*):=Getc()) do <<N:=N+1;Strbyt(Buffer,n):=RaiseChar LISPVAR(CH!*)>>; Return Intern BufferToString(n); End; Procedure RaiseChar c; If EscapeP c then Getc() else if not LispVar !*Raise then c else if not AlphaP c then c else if LowerCaseP c then Char A +(c-Char Lower a) else c; Procedure Intern s; % Lookup string, find old ID or return a new one Begin scalar D; If IDP s then s :=SymNam IdInf s; If (D:=LookupId( s)) then return MkItem(ID,D); D:=GtId(); If LispVar(DEBUG) then <<Prin2 '"New ID# "; Print D>>; Return InitNewId(D,s); End; Procedure InitNewId(D,s); Begin Symval(D):=NIL; SymPrp(D):=NIL; SymNam(D):=MkItem(Str,s); D:=MkItem(ID,D); MakeFUnBound(D); % Machine dependent, in XXX-HEADER Return D; End; Procedure LookupId(s); % Linear scan of SYMNAM field to find string s Begin scalar D; D:=NextSymbol; If LispVar(DEBUG) then <<Prin2 '"Lookup string=";Prin1String s; Terpri()>>; L: If D<=0 then return <<If LispVar(DEBUG) then Prin2T '"Not Found in LookupId"; NIL>>; D:=D-1; If EqStr(SymNam(D),s) then return <<If LispVar(DEBUG) then <<Prin2 '"Found In LookUpId="; print D>>; D>>; goto L End; Procedure WhiteP x; x=CHAR(BLANK) or x=CHAR(EOL) or x=CHAR(TAB) or x=CHAR(LF) or x=CHAR(FF) or x =CHAR(CR); Procedure DigitP x; Char(0) <=x and x <=Char(9); Procedure AlphaP(x); UpperCaseP x or LowerCaseP x; Procedure UpperCaseP x; Char(A)<=x and x<=Char(Z); Procedure LowerCaseP x; Char(Lower A)<=x and x<=Char(Lower Z); Procedure EscapeP x; x eq Char '!!; Procedure AlphaEscP x; EscapeP x or AlphaP x; Procedure AlphaNumP x; DigitP(x) or AlphaP(x); Procedure AlphaNumEscP x; EscapeP x or AlphaNumP x; Off syslisp; End; |
Added psl-1983/tests/mini-top-loop.red version [1107bd3591].
> > > > > > | 1 2 3 4 5 6 | % MINI-TOP-LOOP.RED Procedure Time(); Timc(); End; |
Added psl-1983/tests/mini-type-conversions.red version [e9e4ac7195].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | % MINI-TYPE-CONVERSIONS.RED on syslisp; syslsp procedure Sys2Int N; %. Convert word to Lisp number if SignedField(N, InfStartingBit - 1, InfBitLength + 1) eq N then N else Sys2FIXN N; syslsp procedure SYS2FIXN N; STDerror LIST(N, "too big for mini arith"); off syslisp; End; |
Added psl-1983/tests/mini-type-errors.red version [84b491caf5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MINI-TYPE-ERRORS.RED procedure TypeError(Offender, Fn, Typ); <<Errorheader(); Prin2 "An attempt was made to do"; prin1 Fn; prin2 " on `"; prin1 Offender; prin2 "', which is not "; print Typ; quit; >>; procedure UsageTypeError(Offender, Fn, Typ, Usage); <<Errorheader(); Prin2 "An attempt was made to use"; prin1 Offender; Prin2 " as "; Prin1 Usage; prin2 " in `"; prin1 Fn; prin2 "`, where "; prin1 Typ; prin2t " is needed"; quit; >>; procedure NonIdError(Offender, Fn); TypeError(Offender, Fn, "an identifier"); procedure NonNumberError(Offender, Fn); TypeError(Offender, Fn, "a number"); procedure NonIntegerError(Offender, Fn); TypeError(Offender, Fn, "an integer"); procedure NonPositiveIntegerError(Offender, Fn); TypeError(Offender, Fn, "a non-negative integer"); End; |
Added psl-1983/tests/nbtest.b version [b9c33d0d05].
cannot compute difference between binary files
Added psl-1983/tests/nbtest.build version [1d20393237].
> > | 1 2 | in "nbtest.red"$ |
Added psl-1983/tests/nbtest.red version [8466147f16].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBTEST.RED - Test Bignum Numeric transition points % And other numeric tests % M. L. Griss, 6 Feb 1983 procedure fact N; Begin scalar m; m:=1; while n>0 do <<m:=m*n; n:=n-1>>; return m; End; on syslisp; syslsp procedure Ifact N; Begin scalar m; m:=1; while n>0 do <<m:=m*n; n:=n-1>>; return m; End; syslsp procedure ftest(n,m); for i:=1:n do fact m; syslsp procedure Iftest(n,m); for i:=1:n do ifact m; off syslisp; procedure Ntest0; Begin scalar n; N:=36; pos:=mkvect n; neg:=mkvect n; pos[0]:=1; neg[0]:=-1; for i:=1:N do <<pos[i]:=2*pos[i-1]; neg[i]:=(-pos[i])>>; end; procedure show0 n; <<show(n,pos,'ntype0); show(n,neg,'ntype0)>>; procedure Ntest1; Begin scalar n; N:=40; newpos:=mkvect n; newneg:=mkvect n; newpos[0]:=1; newneg[0]:=-1; for i:=1:n do <<newpos[i]:=2*newpos[i-1]; newneg[i]:=(-newpos[i])>>; end; procedure show1 n; <<show(n,newpos,'ntype1); show(n,newneg,'ntype1)>>; on syslisp; procedure NType0 x; case tag x of posint: 'POSINT; negint: 'negint; fixn: 'FIXN; bign: 'BIGN; fltn: 'fltn; default: 'NIL; end; procedure NType1 x; if Betap x and x>=0 then 'POSBETA else if Betap x and x<0 then 'NEGBETA else case tag x of posint: 'POSINT; negint: 'negint; fixn: 'FIXN; bign: 'BIGN; fltn: 'fltn; default: 'NIL; end; off syslisp; procedure show(N,v,pred); for i:=0:N do printf("%p%t%p%t%p%t%p%n",i,5,apply(pred,list(v[i])),20,v[i],40,float v[i]); end; |
Added psl-1983/tests/new-sym.red version [ee18a475fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Replacements for functions in usual xxx-CROSS.EXE which only read/write % xxx.SYM if flags !*symread/!*symwrite are T; otherwise symbols are % assumed to be already loaded (read case) or the cross-compiler is to % be saved intact with symbols (write case). lisp procedure ASMEnd; << off SysLisp; if !*MainFound then << CompileUncompiledExpressions(); % WriteInitFile(); InitializeSymbolTable() >> else WriteSymFile(); CodeFileTrailer(); Close CodeOut!*; DataFileTrailer(); Close DataOut!*; Close InitOut!*; RemD 'Lap; PutD('Lap, 'EXPR, cdr GetD 'OldLap); DFPRINT!* := NIL; !*DEFN := NIL; WriteSaveFile() >>; lisp procedure ReadSymFile(); if !*symread then LapIN InputSymFile!* else off usermode; lisp procedure WriteSymFile(); begin scalar NewOut, OldOut; if !*symwrite then << OldOut := WRS(NewOut := Open(OutputSymFile!*, 'OUTPUT)); print list('SaveForCompilation, MkQuote('progn . car ToBeCompiledExpressions!*)); SaveIDList(); SetqPrint 'NextIDNumber!*; SetqPrint 'StringGenSym!*; MapObl function PutPrintEntryAndSym; WRS OldOut; Close NewOut; >>; end; lisp procedure WriteSaveFile(); if !*symsave and (null !*mainfound) then % restore some initial conditions <<!*usermode := nil; DataExporteds!* := DataExternals!* := nil; CodeExporteds!* := CodeExternals!* := nil; !*MainFound:= nil; % save the cross-compiler with symbol tables intact dumplisp(cross!-compiler!-name) >>; !*symwrite := !*symread := nil; !*symsave := T; |
Added psl-1983/tests/old-time-psl.sl version [22a7cbd9f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % TIME-PSL.SL Driver of PSL "spectral" tests % After loading psl-timer.b, LAPIN this file (TestSetup) (progn (reclaim) (prin2 "EmptyTest 10000 ") (print (TimeEval '(EmptyTest 10000))) 0) (progn (prin2 "SlowEmptyTest 10000 ") (print (TimeEval '(SlowEmptyTest 10000))) 0) (progn (prin2 "Cdr1Test 100 ") (print (TimeEval '(Cdr1Test 100))) 0) (progn (prin2 "Cdr2Test 100 ") (print (TimeEval '(Cdr2Test 100))) 0) (progn (prin2 "CddrTest 100 ") (print (TimeEval '(CddrTest 100))) 0) (progn (prin2 "ListOnlyCdrTest1 ") (print (TimeEval '(ListOnlyCdrTest1))) 0) (progn (prin2 "ListOnlyCddrTest1 ") (print (TimeEval '(ListOnlyCddrTest1))) 0) (progn (prin2 "ListOnlyCdrTest2 ") (print (TimeEval '(ListOnlyCdrTest2))) 0) (progn (prin2 "ListOnlyCddrTest2 ") (print (TimeEval '(ListOnlyCddrTest2))) 0) (progn (prin2 "ReverseTest 10 ") (print (TimeEval '(ReverseTest 10))) 0) (progn (reclaim) (prin2 "MyReverse1Test 10 ") (print (TimeEval '(MyReverse1Test 10))) 0) (progn (reclaim) (prin2 "MyReverse2Test 10 ") (print (TimeEval '(MyReverse2Test 10))) 0) (progn (reclaim) (prin2 "LengthTest 100 ") (print (TimeEval '(LengthTest 100))) 0) (progn (prin2 "ArithmeticTest 10000 ") (print (TimeEval '(ArithmeticTest 10000))) 0) (progn (prin2 "EvalTest 10000 ") (print (TimeEval '(EvalTest 10000))) 0) (progn (prin2 "tak 18 12 6 ") (print (TimeEval '(topleveltak 18 12 6))) 0) (progn (prin2 "gtak 18 12 6 ") (print (TimeEval '(toplevelgtak 18 12 6))) 0) (progn (prin2 "gtsta g0 ") (print (TimeEval '(gtsta 'g0))) 0) (progn (prin2 "gtsta g1 ") (print (TimeEval '(gtsta 'g1))) 0) |
Added psl-1983/tests/p-allocators.red version [ba8756dcc0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ALLOCATORS.RED - Low level storage management % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % Revisions, MLG, 20 Feb 1983 % Moved space declarations to XXX-HEADER.RED % <PSL.KERNEL>ALLOCATORS.RED.4, 10-Jan-83 15:50:50, Edit by PERDUE % Added GtEVect on SysLisp; external Wvar HeapLowerBound, HeapUpperBound, HeapLast, HeapPreviousLast, NextBPS, LastBPS; % NextSymbol is in GLOBAL-DATA.RED syslsp procedure GtHEAP N; % get heap block of N words if null N then (HeapUpperBound - HeapLast) / AddressingUnitsPerItem else << HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then << !%Reclaim(); HeapPreviousLast := HeapLast; HeapLast := HeapLast + N*AddressingUnitsPerItem; if HeapLast > HeapUpperBound then FatalError "Heap space exhausted" >>; HeapPreviousLast >>; syslsp procedure DelHeap(LowPointer, HighPointer); if HighPointer eq HeapLast then HeapLast := LowPointer; syslsp procedure GtSTR N; % Allocate space for a string N chars begin scalar S, NW; S := GtHEAP((NW := STRPack N) + 1); @S := MkItem(HBytes, N); S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtConstSTR N; % allocate un-collected string for print name begin scalar S, NW; % same as GtSTR, but uses BPS, not heap S := GtBPS((NW := STRPack N) + 1); @S := N; S[NW] := 0; % clear last word, including last byte return S; end; syslsp procedure GtHalfWords N; % Allocate space for N halfwords begin scalar S, NW; S := GtHEAP((NW := HalfWordPack N) + 1); @S := MkItem(HHalfWords, N); return S; end; syslsp procedure GtVECT N; % Allocate space for a vector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; syslsp procedure GtEVECT N; % Allocate space for a Evector N items begin scalar V; V := GtHEAP(VECTPack N + 1); @V := MkItem(HVECT, N); return V; end; syslsp procedure GtWRDS N; % Allocate space for N untraced words begin scalar W; W := GtHEAP(WRDPack N + 1); @W := MkItem(HWRDS, N); return W; end; syslsp procedure GtFIXN(); % allocate space for a fixnum begin scalar W; W := GtHEAP(WRDPack 0 + 1); @W := MkItem(HWRDS, 0); return W; end; syslsp procedure GtFLTN(); % allocate space for a float begin scalar W; W := GtHEAP(WRDPack 1 + 1); @W := MkItem(HWRDS, 1); return W; end; syslsp procedure GtID(); % Allocate a new ID % % IDs are allocated as a linked free list through the SymNam cell, % with a 0 to indicate the end of the list. % begin scalar U; if NextSymbol = 0 then << Reclaim(); if NextSymbol = 0 then return FatalError "Ran out of ID space" >>; U := NextSymbol; NextSymbol := SymNam U; return U; end; syslsp procedure GtBPS N; % Allocate N words for binary code begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GTBPS NIL returns # left B := NextBPS; NextBPS := NextBPS + N*AddressingUnitsPerItem; return if NextBPS > LastBPS then StdError '"Ran out of binary program space" else B; end; syslsp procedure DelBPS(Bottom, Top); % Return space to BPS if NextBPS eq Top then NextBPS := Bottom; syslsp procedure GtWArray N; % Allocate N words for WVar/WArray/WString begin scalar B; if null N then return((LastBPS - NextBPS)/AddressingUnitsPerItem); % GtWArray NIL returns # left B := LastBPS - N*AddressingUnitsPerItem; return if NextBPS > B then StdError '"Ran out of WArray space" else LastBPS := B; end; syslsp procedure DelWArray(Bottom, Top); % Return space for WArray if LastBPS eq Bottom then LastBPS := Top; off SysLisp; END; |
Added psl-1983/tests/p-apply-lap.red version [46f65dd598].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % P-APPLY-LAP.RED - Inefficient, portable version of APPLY-LAP % % Author: Eric Benson and M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 29 July 1982 % Copyright (c) 1982 University of Utah % % Modifications by M.L. Griss 25 October, 1982. % Functions which must be written non-portably, % "portable" versions defined in PT:TEST-FUNCTION-PRIMITIVES.RED % CodePrimitive % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without distubing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. % CompiledCallingInterpreted % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the ID % in the fluid variable CodeForm!* without disturbing the argument % registers, then finish with % (!*JCALL CompiledCallingInterpretedAux) % (CompiledCallingInterpretedAux may be flagged 'InternalFunction). % FastApply % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). % UndefinedFunction % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. Compiletime << fluid '(CodePtr!* % gets code pointer used by CodePrimitive CodeForm!* % gets fn to be called from code ); >>; on Syslisp; external WArray CodeArgs; syslsp procedure CodeApply(CodePtr, ArgList); begin scalar I; I := 0; LispVar CodePtr!* := CodePtr; while PairP ArgList and ILessP(I, 15) do << WPutV(CodeArgs , I, first ArgList); I := IAdd1 I; ArgList := rest ArgList >>; if IGEQ(I, 15) then return StdError "Too many arguments to function"; return case I of 0: CodePrimitive(); 1: CodePrimitive WGetV(CodeArgs, 0); 2: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1)); 3: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2)); 4: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3)); 5: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4)); 6: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5)); 7: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6)); 8: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7)); 9: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8)); 10: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9)); 11: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10)); 12: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11)); 13: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12)); 14: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13)); 15: CodePrimitive(WGetV(CodeArgs, 0), WGetV(CodeArgs, 1), WGetV(CodeArgs, 2), WGetV(CodeArgs, 3), WGetV(CodeArgs, 4), WGetV(CodeArgs, 5), WGetV(CodeArgs, 6), WGetV(CodeArgs, 7), WGetV(CodeArgs, 8), WGetV(CodeArgs, 9), WGetV(CodeArgs, 10), WGetV(CodeArgs, 11), WGetV(CodeArgs, 12), WGetV(CodeArgs, 13), WGetV(CodeArgs, 14)); end; end; %lisp procedure CodeEvalApply(CodePtr, ArgList); % CodeApply(CodePtr, EvLis ArgList); lap '((!*entry CodeEvalApply expr 2) (!*ALLOC 15) (!*LOC (reg 3) (frame 15)) (!*CALL CodeEvalApplyAux) (!*EXIT 15) ); syslsp procedure CodeEvalApplyAux(CodePtr, ArgList, P); begin scalar N; N := 0; while PairP ArgList and ILessP(N, 15) do << WPutV(P, ITimes2(StackDirection, N), Eval first ArgList); ArgList := rest ArgList; N := IAdd1 N >>; if IGEQ(N, 15) then return StdError "Too many arguments to function"; LispVar CodePtr!* := CodePtr; return case N of 0: CodePrimitive(); 1: CodePrimitive WGetV(P, ITimes2(StackDirection, 0)); 2: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1))); 3: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2))); 4: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3))); 5: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4))); 6: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5))); 7: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6))); 8: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7))); 9: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8))); 10: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9))); 11: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10))); 12: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11))); 13: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12))); 14: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13))); 15: CodePrimitive(WGetV(P, ITimes2(StackDirection, 0)), WGetV(P, ITimes2(StackDirection, 1)), WGetV(P, ITimes2(StackDirection, 2)), WGetV(P, ITimes2(StackDirection, 3)), WGetV(P, ITimes2(StackDirection, 4)), WGetV(P, ITimes2(StackDirection, 5)), WGetV(P, ITimes2(StackDirection, 6)), WGetV(P, ITimes2(StackDirection, 7)), WGetV(P, ITimes2(StackDirection, 8)), WGetV(P, ITimes2(StackDirection, 9)), WGetV(P, ITimes2(StackDirection, 10)), WGetV(P, ITimes2(StackDirection, 11)), WGetV(P, ITimes2(StackDirection, 12)), WGetV(P, ITimes2(StackDirection, 13)), WGetV(P, ITimes2(StackDirection, 14))); end; end; syslsp procedure BindEval(Formals, Args); BindEvalAux(Formals, Args, 0); syslsp procedure BindEvalAux(Formals, Args, N); begin scalar F, A; return if PairP Formals then if PairP Args then << F := first Formals; A := Eval first Args; N := BindEvalAux(rest Formals, rest Args, IAdd1 N); if N = -1 then -1 else << LBind1(F, A); N >> >> else -1 else if PairP Args then -1 else N; end; syslsp procedure CompiledCallingInterpretedAux(); << %Later Use NARGS also % Recall that ID# in CODEFORM CompiledCallingInterpretedAuxAux get(MkID(LispVar CodeForm!*), '!*LambdaLink)>>; syslsp procedure FastLambdaApply(); << SaveRegisters(); CompiledCallingInterpretedAuxAux LispVar CodeForm!* >>; syslsp procedure CompiledCallingInterpretedAuxAux Fn; if not (PairP Fn and car Fn = 'LAMBDA) then StdError BldMsg("Ill-formed functional expression %r for %r", Fn, LispVar CodeForm!*) else begin scalar Formals, N, Result; Formals := cadr Fn; N := 0; while PairP Formals do << LBind1(car Formals, WGetV(CodeArgs, N)); Formals := cdr Formals; N := IAdd1 N >>; Result := EvProgN cddr Fn; if N neq 0 then UnBindN N; return Result; end; off Syslisp; END; |
Added psl-1983/tests/p-fast-binder.red version [f13cb3baa8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % P-FAST-BINDER.RED - Portable version of binding from compiled code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 6 August 1982 % Copyright (c) 1982 University of Utah % % This file is for use with *LAMBIND and *PROGBIND in % PC:P-LAMBIND.SL StartupTime << LambindArgs!* := GtWArray 15; >>; on Syslisp; syslsp procedure LamBind V; % V is vector of IDs begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do LBind1(VecItm(V, I), (LispVar LambindArgs!*)[I]); end; syslsp procedure ProgBind V; begin scalar N; V := VecInf V; N := VecLen V; for I := 0 step 1 until N do PBind1 VecItm(V, I); end; off Syslisp; END; |
Added psl-1983/tests/p-function-primitives.red version [7c2e0f61ee].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % TEST-FUNCTION-PRIMITIVES Machine Independent for Test 5 and 6 % % Author: M. L. Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 October 1982 % Copyright (c) 1982 University of Utah % % Based on P20:Function-Primitives.Red % <PSL.TESTS>P-FUNCTION-PRIMITIVES.RED.4, 2-Mar-83 11:46:30, Edit by KESSLER % Put in Dealloc's before jump and jcall (search rrk) % Every ID has a "function cell". It does not necessarily contain a legal % Lisp item, and therefore should not be accessed directly by Lisp functions. % In this implementation the function cell contains an instruction to be % executed. There are 3 possibilites for this instruction, for which the % following predicates and updating functions exist: % % FUnBoundP(ID) -- the function is not defined % FLambdaLinkP(ID) -- the function is interpreted % FCodeP(ID) -- the function is compiled % % MakeFUnBound(ID) -- undefine the function % MakeFLambdaLink(ID) -- specify that the function is interpreted % MakeFCode(ID, CodePtr) -- specify that the function is compiled, % and that the code resides at the address % associated with CodePtr % % GetFCodePointer(ID) -- returns the contents of the function cell as a % code pointer % % See the templates in XXX-ASM.RED: % % DefinedFunctionCellFormat!* % UndefinedFunctionCellFormat!* % These functions currently check that they have proper arguments, % but this may change since they are only used by functions that % have checked them already. % Note that on some machines, SYMFNC(x) is entire SYMFNC cell. % on others it points into the cell, at the "address" part. % % Fairly Portable versions, based on assumption that % Starts with OPCODE, probably !*JCALL % !*Jcall SymfncBase UndefinedFunction in ShouldBeUndefined cell % Needs the machine-dependent procedures in XXX-HEADER: % !%Store!-JCALL(CodeAddress,StoreAddress) % to Create a !*Jcall(CodeAddress) at StoreAddress % !%Copy!-Function!-Cell(From,to) % to copy appropriate # words or bytes of Function cell on syslisp; smacro procedure SymFncBase D; % The Address of CELL, % to which !*JCALL and !*CALL jump Symfnc + AddressingUnitsPerFunctionCell*D; % Unbound Functions have a JCALL UndefinedFunction: % in the function cell, installed by the template syslsp procedure FUnBoundP Fn; % Check If undefn or Not If not IDP Fn then NonIdError(Fn,'FunboundP) else if (SymFnc IdLoc ShouldBeUndefined eq SymFnc IdInf Fn) % Instead of SYMFNCBASE Idloc UndefinedFunction, since its % of course DEFINED, and has to agree with the KernelTime template then 'T else 'NIL; syslsp procedure MakeFUnBound(D); % Install the correct Bit Pattern in SYMFNC cell If not IDP D then NonIdError(D,'MakeFUnbound) else !%copy!-function!-cell(symfncbase Idloc ShouldBeUndefined, symfncbase IdInf D); syslsp procedure FLambdaLinkP fn; If not IDP Fn then NonIdError(Fn,'FunboundP) else if (SymFnc IdLoc CompiledCallingInterpreted eq SymFnc(IdInf Fn)) % This installed by MakeFlambdaLink then 'T else 'NIL; syslsp procedure MakeFlambdaLink D; % Install the correct Bit Pattern in SYMFNC cell If not IDP D then NonIdError(D,'MakeFUnbound) else !%store!-JCALL(symfnc Idloc CompiledCallingInterpreted, Symfncbase IdInf D); % SetUp as above syslsp procedure FcodeP Fn; % Check if Code or Interp If not IDP Fn then NonIdError(Fn,'FcodeP) else if FUnboundP Fn or FLambdaLinkP Fn then NIL else T; syslsp procedure MakeFCode(U, CodePtr); % Make U a compiled function if IDP U then if CodeP CodePtr then <<!%Store!-JCALL(CodeInf Codeptr, SymfncBase IdInf U); NIL >> else NonIDError(U, 'MakeFCode); syslsp procedure GetFCodePointer U; % Get code pointer for U if IDP U then if FCodeP U then MkCODE SymFnc U % do we want Fcodep check else NIL else NonIDError(U, 'GetFCodePointer); %/Check that IS codeP? % Code Calling Primitives % See PI: P-APPLY-LAP.RED by BENSON % See also Pxxx:APPLY-LAP.RED Fluid '(CodePtr!* CodeForm!* CodeNarg!*); LAP '((!*entry CodePrimitive expr 15) % Takes the code pointer stored in the fluid variable CodePtr!* % and jumps to its address, without disturbing any of the argument % registers. This can be flagged 'InternalFunction for compilation % before this file is compiled or done as an 'OpenCode and 'ExitOpenCode % property for the compiler. (!*ALLOC 0) (!*MOVE (Fluid CodePtr!*) (reg t1)) (!*FIELD (reg t1) (reg t1) % get CodeINF (WConst InfStartingBit) (WConst InfBitLength)) % rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump (!*Dealloc 0) (!*JUMP (memory (reg t1) (Wconst 0))) (!*EXIT 0) ); LAP '((!*entry CompiledCallingInterpreted expr 15) % Called by some convention from the function cell of an ID which % has an interpreted function definition. It should store the % Linkreg into % the fluid variable CodeForm!* without disturbing the argument % registers % % (!*ALLOC 0) (!*CALL SaveRegisters) % !*CALL to avoid resetting LinkInfo (!*Move (reg LinkReg) (fluid CodeForm!*)) (!*Move (reg NargReg) (fluid CodeNarg!*)) % rrk - 03/02/83 If alloc did anything we need to get rid of it before the jump (!*Dealloc 0) (!*JCALL CompiledCallingInterpretedAux) (!*Exit 0) ); LAP '((!*entry FastApply expr 0) % Called with a functional form in (reg t1) and argument registers % loaded. If it is a code pointer or an ID, the function address % associated with either should be jumped to. If it is anything else % except a lambda form, an error should be signaled. If it is a lambda % form, store (reg t1) in the fluid variable CodeForm!* and % (!*JCALL FastLambdaApply) % (FastLambdaApply may be flagged 'InternalFunction). (!*ALLOC 0) (!*MOVE (reg t1) (FLUID CodeForm!*)) % save input form (!*FIELD (reg t2) (reg t1) (WConst TagStartingBit) (WConst TagBitLength)) (!*FIELD (reg t1) (reg t1) (WConst InfStartingBit) (WConst InfBitLength)) (!*JUMPNOTEQ (Label NotAnID) (reg t2) (WConst ID)) (!*MOVE (reg t1) (reg LinkReg)) % Reset IDLOC name % NargReg is OK (!*WTIMES2 (reg t1) (WConst AddressingUnitsPerFunctionCell)) % rrk 03/03/83 (!*Dealloc 0) (!*JUMP (MEMORY (reg t1) (WArray SymFnc))) NotAnID (!*JUMPNOTEQ (Label NotACodePointer) (reg t2) (WConst CODE)) % rrk 03/03/83 (!*Dealloc 0) (!*JUMP (MEMORY (reg t1) (WConst 0))) NotACodePointer (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (WConst PAIR)) (!*MOVE (MEMORY (reg t1) (WConst 0)) (reg t2)) % CAR with pair already untagged (!*JUMPNOTEQ (Label IllegalFunctionalForm) (reg t2) (QUOTE LAMBDA)) % rrk 03/03/83 (!*Dealloc 0) % Note that t1 is INF of the PAIR (!*JCALL FastLambdaApply) % CodeForm!* % Already Loaded IllegalFunctionalForm (!*MOVE (QUOTE "Illegal functional form in Apply") (reg 1)) (!*MOVE (FLUID CodeForm!*) (reg 2)) (!*CALL List2) % rrk 03/03/83 (!*Dealloc 0) (!*JCALL StdError) % (!*EXIT 0) --> what is this! ); Exported Warray CodeArgs[15]; syslsp procedure SaveRegisters(A1, A2, A3, A4, A5, % Duplicate in P-APPLY A6, A7, A8, A9, A10, A11, A12, A13, A14, A15); << CodeArgs[14] := A15; CodeArgs[13] := A14; CodeArgs[12] := A13; CodeArgs[11] := A12; CodeArgs[10] := A11; CodeArgs[9] := A10; CodeArgs[8] := A9; CodeArgs[7] := A8; CodeArgs[6] := A7; CodeArgs[5] := A6; CodeArgs[4] := A5; CodeArgs[3] := A4; CodeArgs[2] := A3; CodeArgs[1] := A2; CodeArgs[0] := A1 >>; LAP '((!*ENTRY UndefinedFunctionAux expr 0) % Called by some convention from the function cell of an ID (probably % the same as CompiledCallingInterpreted) for an undefined function. % Should call Error with the ID as part of the error message. (!*ALLOC 0) (!*CALL SaveRegisters) % !*CALL so as not to change LinkInfo % Was stored in UndefnCode!* UndefnNarg!* % rrk 03/03/83 (!*Dealloc 0) (!*JCALL UndefinedFunctionAuxAux) % (!*EXIT 0) ); off syslisp; End; |
Added psl-1983/tests/pascal-support.red version [619838df2e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | { XXX Support Routines, Test Version M. L. Griss, and S. Lowder 9 July 1982 } Var Ctime:Integer; { For CPU Time } Procedure XXX_Init(var c:integer); begin WriteLn(Output, ' Init the XXX package ',c); Ctime :=10*SysClock; { First Call on Timer } end; Procedure XXX_PutC(var c:integer); begin Write(Output,chr(c)); end; Procedure XXX_GetC(var c:integer); var ch:char; begin read(keyboard,ch); c := ord(ch); end; Procedure XXX_TimC(var c:integer); var i:integer; begin i:=10* SysClock; {Call timer again} c := i-Ctime; Writeln(Output,' Ctime ', i, c); Ctime := i; end; Procedure XXX_Quit(var c:integer); { close files, cleanup and exit } begin Writeln(Output,' Quitting '); ESCAPE(0); { "normal" exit, ie HALT} end; Procedure XXX_Err(var c:integer); begin Writeln(Output,' XXX Error call Number: ', c); ESCAPE(c); end; Procedure XXX_PutI(var c:integer); { Print an Integer } begin Writeln(Output,' PutI: ', c); end; end. |
Added psl-1983/tests/pk-headers.txt version [5e0219ddcf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 21-Feb-83 10:59:57-MST,50099;000000000001 Return-path: <hplabs!GRISS@HP-HULK> Received: from UTAH-CS by UTAH-20; Mon 21 Feb 83 10:57:48-MST Date: 20 Feb 1983 1725-PST From: hplabs!GRISS@HP-HULK Subject: PK headers To: kessler@hp-venus cc: swanson@hp-venus The following may be of interest, in converting TEST series to bootstrap; Im still working on the program: 8333 lines, 655 procedures found !%CLEAR!-CATCH!-STACK(); PK:CATCH-THROW 151/18 !%RECLAIM(); PK:COPYING-GC 61/2 !%RECLAIM(); % GARBAGE COLLECTOR PK:COMPACTING- 164/2 !%THROW(TAG, VALUE); PK:CATCH-THROW 154/19 !%UNCATCH PREVIOUS; PK:CATCH-THROW 147/17 !*CATCH U; PK:CATCH-THROW 72/5 !*THROW(X,Y); PK:CATCH-THROW 75/6 ABS U; %. ABSOLUTE VALUE OF NUMBER PK:EASY-SL 173/23 ACONC(U, V); %. DESTRUCTIVELY ADD ELEMENT V TO THE TA PK:EASY-NON-SL 275/45 ADDTOOBLIST U; PK:OBLIST 43/1 ADJOIN(ELEMENT, ASET); %. ADD ELEMENT TO SET PK:SETS 22/3 ADJOINQ(ELEMENT, ASET); %. EQ VERSION OF ADJOIN PK:SETS 25/4 AND U; %. SEQUENTIALLY EVALUATE UNTIL NIL PK:EASY-SL 128/15 ANS N; %. RETURN NTH OUTPUT PK:TOP-LOOP 151/7 APPEND(U, V); %. COMBINE 2 LISTS PK:EASY-SL 232/37 APPLY(FN, ARGS); %. INDIRECT FUNCTION CALL PK:EVAL-APPLY 89/3 ASS(F, U, V); %. GENERALIZED ASSOC, F IS COMPARISON F PK:EASY-NON-SL 174/28 ASSOC(U, V); %. RETURN FIRST (U . XXX) IN V, OR NIL PK:EASY-SL 251/38 ATOM U; %. IS U A NON PAIR? PK:EASY-SL 35/1 ATSOC(U, V); %. EQ VERSION OF ASSOC PK:EASY-NON-SL 169/27 BACKTRACE(); PK:BACKTRACE 26/2 BACKTRACE1(ITEM, CODE); PK:BACKTRACE 64/5 BACKTRACERANGE(STARTING, ENDING, INTERPFLAG); PK:BACKTRACE 33/3 BIGFLOATFIX N; PK:ARITHMETIC 220/12 BIGP U; %. IS U A BIGNUM? PK:KNOWN-TO-CO 29/4 BLDMSG(FORMAT, ARG1, ARG2, ARG3, ARG4); %. PRINT TO S PK:PRINTF 174/6 BOTHTIMES U; %. EVALUATE AT COMPILE AND LOAD TIME PK:EVAL-WHEN 28/3 BR L; %. BREAK FUNCTIONS IN L PK:MINI-TRACE 197/13 BR!.1 NAM; % CALLED TO TRACE A SINGLE FUNCTION PK:MINI-TRACE 162/11 BR!.PRC(PN, B, A); % CALLED IN PLACE OF "BROKEN" COD PK:MINI-TRACE 128/10 BREAK(); %. ENTER TOP LOOP WITHIN EVALUATION PK:BREAK 31/1 BREAKCONTINUE(); PK:BREAK 73/4 BREAKEDIT(); PK:BREAK 93/8 BREAKERRMSG(); PK:BREAK 90/7 BREAKEVAL U; PK:BREAK 62/2 BREAKQUIT(); PK:BREAK 69/3 BREAKRETRY(); PK:BREAK 77/5 BSTACKOVERFLOW(); PK:BINDING 33/1 BSTACKUNDERFLOW(); PK:BINDING 40/2 BUILDRELOCATIONFIELDS(); PK:COMPACTING- 278/11 CAAAAR U; %. PK:CARCDR 34/1 CAAADR U; %. PK:CARCDR 38/2 CAAAR U; %. PK:CARCDR 99/17 CAADAR U; %. PK:CARCDR 42/3 CAADDR U; %. PK:CARCDR 46/4 CAADR U; %. PK:CARCDR 103/18 CAAR U; %. PK:CARCDR 141/27 CADAAR U; %. PK:CARCDR 50/5 CADADR U; %. PK:CARCDR 54/6 CADAR U; %. PK:CARCDR 107/19 CADDAR U; %. PK:CARCDR 58/7 CADDDR U; %. PK:CARCDR 62/8 CADDR U; %. PK:CARCDR 111/20 CADR U; %. PK:CARCDR 145/28 CAPTUREENVIRONMENT(); %. SAVE BINDINGS TO BE RESTORE PK:BINDING 47/3 CAR U; %. LEFT SUBTREE OF PAIR PK:KNOWN-TO-CO 49/9 CATCH U; PK:CATCH-THROW 64/4 CATCH!-ALL U; PK:CATCH-THROW 30/1 CATCHPOP(); PK:CATCH-THROW 89/7 CATCHPUSH(TAG, PC, SP, ENV); PK:CATCH-THROW 98/9 CATCHSETUP EXPR 1) %. CATCHSETUP(TAG) PK:CATCH-THROW 133/15 CATCHSETUPAUX(TAG, PC, SP); PK:CATCH-THROW 139/16 CATCHSTACKDECREMENT X; PK:CATCH-THROW 92/8 CATCHTAGAT X; PK:CATCH-THROW 114/11 CATCHTOPENV(); PK:CATCH-THROW 123/14 CATCHTOPPC(); PK:CATCH-THROW 117/12 CATCHTOPSP(); PK:CATCH-THROW 120/13 CATCHTOPTAG(); PK:CATCH-THROW 111/10 CDAAAR U; %. PK:CARCDR 66/9 CDAADR U; %. PK:CARCDR 70/10 CDAAR U; %. PK:CARCDR 115/21 CDADAR U; %. PK:CARCDR 74/11 CDADDR U; %. PK:CARCDR 78/12 CDADR U; %. PK:CARCDR 119/22 CDAR U; %. PK:CARCDR 149/29 CDDAAR U; %. PK:CARCDR 82/13 CDDADR U; %. PK:CARCDR 86/14 CDDAR U; %. PK:CARCDR 123/23 CDDDAR U; %. PK:CARCDR 90/15 CDDDDR U; %. PK:CARCDR 94/16 CDDDR U; %. PK:CARCDR 127/24 CDDR U; %. PK:CARCDR 153/30 CDR U; %. RIGHT SUBTREE OF PAIR PK:KNOWN-TO-CO 53/10 CHANNELEJECT C; %. SKIP TO TOP OF NEXT OUTPUT PAGE PK:OTHER-IO 34/1 CHANNELERROR(CHANNEL, MESSAGE); PK:IO-ERRORS 29/6 CHANNELLINELENGTH(CHN, LEN); %. SET MAXIMUM LINE LENG PK:OTHER-IO 41/3 CHANNELLPOSN CHN; %. NUMBER OF EOLS SINCE LAST FF PK:OTHER-IO 61/7 CHANNELNOTOPEN(CHN, CH); PK:IO-ERRORS 14/1 CHANNELPOSN CHN; %. NUMBER OF CHARACTERS SINCE LAST E PK:OTHER-IO 55/5 CHANNELPRIN1(CHANNEL, ITM); %. DISPLAY ITM IN READABL PK:PRINTERS 477/33 CHANNELPRIN2(CHANNEL, ITM); %. DISPLAY ITM ON CHANNEL PK:PRINTERS 435/30 CHANNELPRIN2T(C, U); %. PRIN2 AND TERPRI PK:EASY-NON-SL 333/50 CHANNELPRINT(C, U); %. DISPLAY U AND TERMINATE LINE PK:EASY-SL 345/54 CHANNELPRINTEVECTOR(CHANNEL, EVEC, LEVEL); PK:PRINTERS 363/26 CHANNELPRINTF(OUT!*, FORMAT, A1, A2, A3, A4, A5, A6, PK:PRINTF 205/9 CHANNELPRINTID(CHANNEL, ITM); PK:PRINTERS 187/16 CHANNELPRINTPAIR(CHANNEL, ITM, LEVEL); PK:PRINTERS 274/22 CHANNELPRINTSTRING(CHANNEL, STRNG); PK:PRINTERS 159/13 CHANNELPRINTUNBOUND(CHANNEL, ITM); PK:PRINTERS 218/17 CHANNELPRINTVECTOR(CHANNEL, VEC, LEVEL); PK:PRINTERS 324/24 CHANNELREAD CHANNEL; %. PARSE S-EXPRESSION FROM CHANN PK:READ 45/2 CHANNELREADCH CHN; %. READ A SINGLE CHARACTER ID PK:OTHER-IO 67/9 CHANNELREADCHAR FILEDES; %. READ ONE CHAR FROM CHANNE PK:CHAR-IO 28/1 CHANNELREADEOF(CHANNEL, EF); % HANDLE END-OF-FILE IN PK:READ 56/4 CHANNELREADLINE CHN; PK:TOKEN-SCANN 529/17 CHANNELREADLISTORDOTTEDPAIR(CHANNEL, PA); % READ MACR PK:READ 67/6 CHANNELREADQUOTEDEXPRESSION(CHANNEL, QT); % READ MACR PK:READ 64/5 CHANNELREADRIGHTPAREN(CHANNEL, TOK); PK:READ 98/7 CHANNELREADTOKEN CHANNEL; %. TOKEN SCANNER PK:TOKEN-SCANN 162/7 CHANNELREADTOKENWITHHOOKS CHANNEL; % SCAN TOKEN W/RE PK:READ 34/1 CHANNELREADVECTOR CHANNEL; % READ MACRO [ PK:READ 111/9 CHANNELSPACES(C, N); %. PRIN2 N SPACES PK:EASY-NON-SL 341/52 CHANNELTAB(CHN, N); %. SPACES TO COLUMN N PK:EASY-NON-SL 347/54 CHANNELTERPRI CHN; %. TERMINATE CURRENT OUTPUT LINE PK:OTHER-IO 78/11 CHANNELTYI CHN; %. READ ONE CHAR ASCII VALUE PK:IO-EXTENSIO 14/1 CHANNELTYO(CHN, CH); %. WRITE ONE CHAR ASCII VALUE PK:IO-EXTENSIO 17/2 CHANNELUNREADCHAR(CHANNEL, CH); %. INPUT BACKUP FU PK:CHAR-IO 72/5 CHANNELWRITEBITSTRAUX(CHANNEL, NUMBER, DIGITMASK, EXP PK:PRINTERS 123/7 CHANNELWRITEBITSTRING(CHANNEL, NUMBER, DIGITMASK, EXP PK:PRINTERS 119/6 CHANNELWRITEBLANKOREOL CHANNEL; PK:PRINTERS 240/20 CHANNELWRITEBYTES(CHANNEL, ITM); PK:PRINTERS 417/29 CHANNELWRITECHAR(FILEDES, CH); %. WRITE ONE CHAR TO C PK:CHAR-IO 47/3 CHANNELWRITECODEPOINTER(CHANNEL, CP); PK:PRINTERS 223/18 CHANNELWRITEEVECTOR(CHANNEL, EVEC, LEVEL); PK:PRINTERS 346/25 CHANNELWRITEFIXNUM(CHANNEL, NUM); PK:PRINTERS 137/9 CHANNELWRITEFLOAT(CHANNEL, LISPFLOATPTR); PK:PRINTERS 156/12 CHANNELWRITEHALFWORDS(CHANNEL, ITM); PK:PRINTERS 398/28 CHANNELWRITEID(CHANNEL, ITM); PK:PRINTERS 170/14 CHANNELWRITEINTEGER(CHANNEL, NUM); PK:PRINTERS 140/10 CHANNELWRITEPAIR(CHANNEL, ITM, LEVEL); PK:PRINTERS 246/21 CHANNELWRITESTRING(CHANNEL, STRNG); PK:PRINTERS 82/2 CHANNELWRITESYSFLOAT(CHANNEL, FLOATPTR); PK:PRINTERS 150/11 CHANNELWRITESYSINTEGER(CHANNEL, NUMBER, RADIX); PK:PRINTERS 99/4 CHANNELWRITEUNBOUND(CHANNEL, ITM); PK:PRINTERS 182/15 CHANNELWRITEUNKNOWNITEM(CHANNEL, ITM); PK:PRINTERS 235/19 CHANNELWRITEVECTOR(CHANNEL, VEC, LEVEL); PK:PRINTERS 302/23 CHANNELWRITEWORDS(CHANNEL, ITM); PK:PRINTERS 380/27 CHECKANDSETMARK P; PK:COMPACTING- 232/8 CHECKLINEFIT(LEN, CHN, FN, ITM); PK:PRINTERS 77/1 CLEARBINDINGS(); %. RESTORE BINDINGS TO TOP LEVEL PK:BINDING 56/5 CLEARCOMPRESSCHANNEL(); PK:EXPLODE-COM 74/8 CLOSE FILEDES; %. END ACCESS TO FILE PK:OPEN-CLOSE 55/2 CODE!-NUMBER!-OF!-ARGUMENTS CP; PK:PUTD-GETD 115/4 CODEP U; %. IS U A CODE POINTER? PK:KNOWN-TO-CO 20/1 COMMENTOUTCODE U; %. COMMENT OUT A SINGLE EXPRESSION PK:EVAL-WHEN 17/1 COMPACTHEAP(); PK:COMPACTING- 409/17 COMPILETIME U; %. EVALUATE AT COMPILE TIME ONLY PK:EVAL-WHEN 20/2 COMPRESS COMPRESSLIST!*; %. CHAR-LIST --> S-EXPR PK:EXPLODE-COM 83/10 COMPRESSERROR(); PK:EXPLODE-COM 80/9 COMPRESSREADCHAR CHANNEL; PK:EXPLODE-COM 63/7 CONCAT(R1, R2); %. CONCATENATE 2 SEQUENCES PK:SEQUENCE 251/7 COND U; %. CONDITIONAL EVALUATION CONSTRUCT PK:EASY-SL 145/20 CONS(U, V); %. CONSTRUCT PAIR WITH CAR U AND CDR V PK:CONS-MKVECT 33/2 CONST FORM; PK:DEFCONST 30/3 CONSTANTP U; %. IS EVAL U EQ U BY DEFINITION? PK:EASY-SL 38/2 CONTERROR U; %. SET UP FOR CONTINUABLEERROR PK:CONT-ERROR 23/1 CONTINUABLEERROR(ERRNUM, MESSAGE, ERRORFORM!*); %. MA PK:ERROR-HANDL 69/5 COPY U; %. COPY ALL PAIRS IN S-EXPR PK:EASY-NON-SL 254/41 COPYD(NEW, OLD); %. FUNDEF NEW := FUNDEF OLD; PK:EASY-NON-SL 61/10 COPYFROMALLBASES(); PK:COPYING-GC 93/4 COPYFROMBASE P; PK:COPYING-GC 120/6 COPYFROMRANGE(LO, HI); PK:COPYING-GC 110/5 COPYITEM X; PK:COPYING-GC 123/7 COPYITEM1 S; % COPIER FOR GC PK:COPYING-GC 138/8 COPYSTRING S; %. COPY TO NEW HEAP STRING PK:COPIERS 28/2 COPYSTRINGTOFROM(NEW, OLD); %. COPY ALL CHARS IN OLD PK:COPIERS 17/1 COPYVECTOR S; %. COPY TO NEW VECTOR IN HEAP PK:COPIERS 50/5 COPYVECTORTOFROM(NEW, OLD); %. MOVE ELEMENTS, DON'T R PK:COPIERS 40/4 COPYWARRAY(NEW, OLD, UPLIM); %. COPY UPLIM + 1 WORDS PK:COPIERS 35/3 COPYWRDS S; %. ALLOCATE NEW WRDS ARRAY IN HEAP PK:COPIERS 67/7 COPYWRDSTOFROM(NEW, OLD); %. LIKE COPYWARRAY IN HEAP PK:COPIERS 57/6 DE U; %. TERSE SYNTAX FOR PUTD CALL FOR EXPR PK:EASY-SL 72/7 DECLAREFLUIDORGLOBAL(IDLIST, FG); PK:FLUID-GLOBA 28/1 DECLAREFLUIDORGLOBAL1(U, FG); PK:FLUID-GLOBA 31/2 DEFARITH1ENTRY U; PK:ARITHMETIC 243/17 DEFARITH1PREDICATEENTRY U; PK:ARITHMETIC 246/18 DEFARITH2ENTRY U; PK:ARITHMETIC 240/16 DEFARITHENTRY L; PK:ARITHMETIC 258/21 DEFAUTOLOAD U; PK:AUTOLOAD 17/1 DEFCONST FORM; %. DEFCONST(NAME, VALUE, ...); PK:DEFCONST 14/1 DEFLIST(DLIST, INDICATOR); %. PUT MANY IDS, SAME INDI PK:EASY-SL 277/42 DEFNPRINT U; % HANDLE CASE OF !*DEFN:=T PK:TOP-LOOP 119/2 DEFNPRINT1 U; PK:TOP-LOOP 130/3 DEL(F, U, V); %. GENERALIZED DELETE, F IS COMPARISON PK:EASY-NON-SL 152/24 DELASC(U, V); %. REMOVE FIRST (U . XXX) FROM V PK:EASY-NON-SL 192/31 DELASCIP(U, V); %. DESTRUCTIVE DELASC PK:EASY-NON-SL 203/33 DELASCIP1(U, V); % AUXILIARY FUNCTION FOR DELASCIP PK:EASY-NON-SL 197/32 DELATQ(U, V); %. EQ VERSION OF DELASC PK:EASY-NON-SL 210/34 DELATQIP(U, V); %. DESTRUCTIVE DELATQ PK:EASY-NON-SL 221/36 DELATQIP1(U, V); % AUXILIARY FUNCTION FOR DELATQIP PK:EASY-NON-SL 215/35 DELBPS(BOTTOM, TOP); %. RETURN SPACE TO BPS PK:ALLOCATORS 133/12 DELETE(U, V); %. REMOVE FIRST TOP-LEVEL U IN V PK:EASY-SL 282/43 DELETIP(U, V); %. DESTRUCTIVE DELETE PK:EASY-NON-SL 140/22 DELETIP1(U, V); % AUXILIARY FUNCTION FOR DELETIP PK:EASY-NON-SL 135/21 DELHEAP(LOWPOINTER, HIGHPOINTER); PK:ALLOCATORS 45/2 DELQ(U, V); %. EQ VERSION OF DELETE PK:EASY-NON-SL 147/23 DELQIP(U, V); %. DESTRUCTIVE DELQ PK:EASY-NON-SL 162/26 DELQIP1(U, V); % AUXILIARY FUNCTION FOR DELQIP PK:EASY-NON-SL 157/25 DELWARRAY(BOTTOM, TOP); %. RETURN SPACE FOR WARRAY PK:ALLOCATORS 147/14 DF U; %. TERSE SYNTAX FOR PUTD CALL FOR FEXPR PK:EASY-SL 77/8 DIGIT U; %. IS U AN ID WHOSE PRINT NAME IS A DIGIT? PK:OTHERS-SL 24/2 DIGITTONUMBER D; PK:TOKEN-SCANN 462/9 DIVIDE(U, V); %. DOTTED PAIR REMAINDER AND QUOTIENT PK:EASY-SL 176/24 DM U; %. TERSE SYNTAX FOR PUTD CALL FOR MACRO PK:EASY-SL 82/9 DN U; %. TERSE SYNTAX FOR PUTD CALL FOR NEXPR PK:EASY-SL 87/10 DOPNTH(U, N); PK:EASY-NON-SL 265/43 DOTCONTEXTERROR(); % PARSING ERROR PK:READ 106/8 DS FORM; %. DEFINE SMACRO PK:DEFINE-SMAC 29/3 DSKIN F; %. READ A FILE (DSKIN "FILE") PK:DSKIN 27/1 DSKINDEFNPRINT U; % HANDLE CASE OF !*DEFN:=T PK:DSKIN 52/3 DSKINEVAL U; PK:DSKIN 49/2 EDCOPY(L,N); PK:MINI-EDITOR 111/5 EDIT S; %. EDIT A STRUCTURE, S PK:MINI-EDITOR 44/2 EDIT0(S,READER,PRINTER); PK:MINI-EDITOR 54/3 EDITF(FN); %. EDIT A COPY OF FUNCTION BODY PK:MINI-EDITOR 28/1 EGETV(VEC, I); %. RETRIEVE THE I'TH ENTRY OF PK:VECTORS 63/5 EHELP; PK:MINI-EDITOR 140/10 EJECT(); %. SKIP TO TOP OF NEXT OUTPUT PAGE PK:OTHER-IO 38/2 EPUTV(VEC, I, VAL); %. STORE VAL AT I'TH POSITION PK:VECTORS 80/6 EQ(U, V); %. ARE U AND V IDENTICAL? PK:KNOWN-TO-CO 23/2 EQCAR(U, V); %. CAR U EQ V PK:EASY-NON-SL 44/5 EQN(U, V); %. EQ OR NUMERIC EQUALITY PK:EQUAL 21/1 EQSTR(U, V); %. EQ OR STRING EQUALITY PK:EQUAL 62/3 ERROR(NUMBER, MESSAGE); %. THROW TO ERRORSET PK:ERROR-ERROR 39/1 ERRORPRINTF(FORMAT, A1, A2, A3, A4); % ALSO A5..A14 PK:PRINTF 153/4 ERRORSET(FORM, !*EMSGP, !*INNER!*BACKTRACE); %. PROTE PK:ERROR-ERROR 58/3 ERRPRIN U; %. `PRIN1 WITH QUOTES' PK:PRINTF 186/7 ERRSET U; PK:ERROR-ERROR 52/2 EUPBV V; %. UPPER LIMIT OF VECTOR V PK:VECTORS 97/7 EVAL U; %. INTERPRET S-EXPRESSION AS PROGRAM PK:EVAL-APPLY 108/4 EVALINITFORMS(); %. EVALUATE AND CLEAR INITFORMS!* PK:TOP-LOOP 209/14 EVAND U; %. EXPR SUPPORT FOR AND PK:EASY-SL 131/16 EVAND1 U; % AUXILIARY FUNCTION FOR EVAND PK:EASY-SL 134/17 EVBR L; PK:MINI-TRACE 200/14 EVCOND U; %. EXPR SUPPORT FOR COND PK:EASY-SL 148/21 EVDEFCONST(CONSTNAME, CONSTVALUE); PK:DEFCONST 27/2 EVECTORP V; PK:VECTORS 60/4 EVLIS U; %. FOR EACH X IN U COLLECT EVAL X PK:EASY-SL 322/49 EVLOAD U; PK:LOAD 60/2 EVOR U; %. EXPR SUPPORT FOR OR PK:EASY-SL 142/19 EVPROGN U; %. EXPR SUPPORT FOR PROGN, EVAL, COND PK:EASY-SL 118/14 EVRELOAD U; PK:LOAD 66/4 EVTR L; PK:MINI-TRACE 90/5 EVUNBR L; PK:MINI-TRACE 206/16 EVUNTR L; PK:MINI-TRACE 96/7 EXIT U; %. TO LEAVE CURRENT ITERATION PK:LOOP-MACROS 49/2 EXPAND(L, FN); %. L = (A B C) --> (FN A (FN B C)) PK:EASY-SL 329/51 EXPANDSETF(LHS, RHS); PK:LISP-MACROS 48/3 EXPLODE U; %. S-EXPR --> CHAR-LIST PK:EXPLODE-COM 28/2 EXPLODE2 U; %. PRIN2 VERSION OF EXPLODE PK:EXPLODE-COM 36/3 EXPLODEWRITECHAR(CHANNEL, CH); PK:EXPLODE-COM 24/1 EXPRP U; %. IS U AN EXPR? PK:EASY-NON-SL 47/6 EXPT(X, N); PK:EASY-SL 47/5 EXTRAARGUMENTP U; PK:FASLIN 25/3 FASLIN FILE; PK:FASLIN 34/5 FATALERROR S; PK:ERROR-HANDL 31/1 FEXPRP U; %. IS U AN FEXPR? PK:EASY-NON-SL 53/8 FILEP EXPR 1) PK:EASY-NON-SL 360/56 FILEP F; %. IS F AN EXISTING FILE? PK:EASY-NON-SL 374/57 FINDCATCHMARKANDTHROW(TAG, VALUE, P); PK:CATCH-THROW 185/22 FINDFIRST(A,S,TRC); %. FIND OCCURANCE OF A IN S PK:MINI-EDITOR 120/7 FIRST U; %. FIRST ELEMENT OF A LIST PK:EASY-NON-SL 95/13 FIXP U; %. IS U AN INTEGER? PK:OTHERS-SL 19/1 FLAG(IDLIST, INDICATOR); %. MARK ALL IN IDLIST WITH I PK:PROPERTY-LI 92/6 FLAG1(U, INDICATOR); PK:PROPERTY-LI 98/7 FLAGP(U, INDICATOR); %. IS U MARKED WITH INDICATOR? PK:PROPERTY-LI 43/3 FLATSIZE U; %. CHARACTER LENGTH OF S-EXPRESSION PK:EXPLODE-COM 49/5 FLATSIZE2 U; %. PRIN2 VERSION OF FLATSIZE PK:EXPLODE-COM 55/6 FLATSIZEWRITECHAR(CHANNEL, CH); PK:EXPLODE-COM 46/4 FLOATADD1 FIRSTARG; PK:ARITHMETIC 432/41 FLOATDIFFERENCE(FIRSTARG, SECONDARG); PK:ARITHMETIC 300/25 FLOATFIX ARG; PK:ARITHMETIC 464/47 FLOATGREATERP(FIRSTARG, SECONDARG); PK:ARITHMETIC 411/37 FLOATINTARG ARG; PK:ARITHMETIC 472/48 FLOATLESSP(FIRSTARG, SECONDARG); PK:ARITHMETIC 420/39 FLOATMINUS FIRSTARG; PK:ARITHMETIC 459/46 FLOATMINUSP FIRSTARG; PK:ARITHMETIC 485/50 FLOATONEP FIRSTARG; PK:ARITHMETIC 501/54 FLOATP U; %. IS U A FLOATING POINT NUMBER? PK:KNOWN-TO-CO 26/3 FLOATPLUS2(FIRSTARG, SECONDARG); PK:ARITHMETIC 283/23 FLOATQUOTIENT(FIRSTARG, SECONDARG); PK:ARITHMETIC 340/29 FLOATREMAINDER(FIRSTARG, SECONDARG); PK:ARITHMETIC 365/31 FLOATSUB1 FIRSTARG; PK:ARITHMETIC 443/43 FLOATTIMES2(FIRSTARG, SECONDARG); PK:ARITHMETIC 319/27 FLOATZEROP FIRSTARG; PK:ARITHMETIC 493/52 FLUID IDLIST; %. DECLARE ALL IN IDLIST AS FLUID VARS PK:FLUID-GLOBA 43/3 FLUID1 U; %. DECLARE U FLUID PK:FLUID-GLOBA 46/4 FLUIDP U; %. IS U A FLUID VARIABLE? PK:FLUID-GLOBA 49/5 FOR U; PK:LOOP-MACROS 85/6 FOREACH U; %. MACRO FOR MAP FUNCTIONS PK:LOOP-MACROS 15/1 FOURTH U; %. FOURTH ELEMENT OF A LIST PK:EASY-NON-SL 104/16 FUNCTION U; %. SAME AS QUOTE IN THIS VERSION PK:EASY-SL 339/53 GCERROR(MESSAGE, P); PK:COMPACTING- 442/18 GCMESSAGE(); PK:COMPACTING- 447/19 GCSTATS(); PK:COPYING-GC 193/10 GENSYM(); %. GENERATE UNIQUE, UNINTERNED SYMBOL PK:OBLIST 160/10 GENSYM1 N; % AUXILIARY FUNCTION FOR GENSYM PK:OBLIST 164/11 GEQ(U, V); %. GREATER THAN OR EQUAL TO PK:EASY-NON-SL 38/3 GET(U, INDICATOR); %. RETRIEVE VALUE STORED FOR U WIT PK:PROPERTY-LI 69/5 GETD U; %. LOOKUP FUNCTION DEFINITION OF U PK:PUTD-GETD 42/1 GETFNTYPE U; PK:PROPERTY-LI 64/4 GETV(VEC, I); %. RETRIEVE THE I'TH ENTRY OF VEC PK:VECTORS 19/1 GLOBAL IDLIST; %. DECLARE ALL IN IDLIST AS GLOBAL VA PK:FLUID-GLOBA 52/6 GLOBAL1 U; %. DECLARE U GLOBAL PK:FLUID-GLOBA 55/7 GLOBALINSTALL S; % ADD NEW ID WITH PNAME S TO OBLIST PK:OBLIST 197/15 GLOBALLOOKUP S; % LOOKUP STRING S IN GLOBAL OBLIST PK:OBLIST 191/14 GLOBALP U; %. IS U A GLOBAL VARIABLE PK:FLUID-GLOBA 58/8 GLOBALREMOVE S; % REMOVE ID WITH PNAME S FROM OBLIST PK:OBLIST 209/16 GO U; %. GOTO LABEL WITHIN PROG PK:PROG-AND-FR 46/2 GTBPS N; %. ALLOCATE N WORDS FOR BINARY CODE PK:ALLOCATORS 122/11 GTCONSTSTR N; %. ALLOCATE UN-COLLECTED STRING FOR PR PK:ALLOCATORS 56/4 GTFIXN(); %. ALLOCATE SPACE FOR A FIXNUM PK:ALLOCATORS 88/8 GTFLTN(); %. ALLOCATE SPACE FOR A FLOAT PK:ALLOCATORS 95/9 GTHALFWORDS N; %. ALLOCATE SPACE FOR N HALFWORDS PK:ALLOCATORS 64/5 GTHEAP N; %. GET HEAP BLOCK OF N WORDS PK:ALLOCATORS 33/1 GTID(); %. ALLOCATE A NEW ID PK:ALLOCATORS 104/10 GTSTR N; %. ALLOCATE SPACE FOR A STRING N CHARS PK:ALLOCATORS 48/3 GTVECT N; %. ALLOCATE SPACE FOR A VECTOR N ITEMS PK:ALLOCATORS 71/6 GTWARRAY N; %. ALLOCATE N WORDS FOR WVAR/WARRAY/WSTRI PK:ALLOCATORS 136/13 GTWRDS N; %. ALLOCATE SPACE FOR N UNTRACED WORDS PK:ALLOCATORS 80/7 HALFWORDSEQUAL(U, V); PK:EQUAL 92/6 HARDCONS(U, V); % BASIC CONS WITH CAR U AND CDR V PK:CONS-MKVECT 24/1 HASHFUNCTION S; % COMPUTE HASH FUNCTION OF STRING PK:OBLIST 93/5 HELPBREAK(); PK:BREAK 86/6 HIST AL; %. PRINT HISTORY ENTRIES PK:TOP-LOOP 154/8 HISTPRINT(L, N, M); PK:TOP-LOOP 177/9 ID2INT U; %. RETURN ID INDEX AS LISP NUMBER PK:TYPE-CONVER 25/1 ID2STRING U; %. RETURN PRINT NAME OF U (NOT COPY) PK:TYPE-CONVER 67/8 IDP U; %. IS U AN ID? PK:KNOWN-TO-CO 32/5 ILLEGALSTANDARDCHANNELCLOSE CHN; PK:IO-ERRORS 23/4 IMPLODE COMPRESSLIST!*; %. COMPRESS WITH IDS INTERNED PK:EXPLODE-COM 90/11 IMPORTS L; PK:LOAD 101/6 INDEXERROR(OFFENDER, FN); PK:TYPE-ERRORS 26/3 INDX(R1, R2); %. ELEMENT OF SEQUENCE PK:SEQUENCE 24/1 INITNEWID(U, V); % INITIALIZE CELLS OF AN ID TO DEFAU PK:OBLIST 85/4 INITOBLIST(); PK:OBLIST 219/17 INOBLIST U; % U IS A STRING. RETURNS AN OBARRAY POIN PK:OBLIST 104/6 INP N; %. RETURN NTH INPUT PK:TOP-LOOP 145/5 INSTANTIATEINFORM(FORMALS, FORM); PK:DEFINE-SMAC 21/1 INT2CODE N; %. CONVERT LISP INTEGER TO CODE POINTER PK:TYPE-CONVER 53/5 INT2ID U; %. RETURN ID CORRESPONDING TO INDEX PK:TYPE-CONVER 29/2 INT2SYS N; %. CONVERT LISP INTEGER TO UNTAGGED PK:TYPE-CONVER 38/3 INTADD1 FIRSTARG; PK:ARITHMETIC 426/40 INTDIFFERENCE(FIRSTARG, SECONDARG); PK:ARITHMETIC 294/24 INTERN U; %. ADD U TO OBLIST PK:OBLIST 124/7 INTERNGENSYM(); %. GENERATE UNIQUE, INTERNED SYMBOL PK:OBLIST 177/12 INTERNP U; %. IS U AN INTERNED ID? PK:OBLIST 150/9 INTERPBACKTRACE(); PK:BACKTRACE 19/1 INTGREATERP(FIRSTARG, SECONDARG); PK:ARITHMETIC 408/36 INTHISCASE(CASEEXPR,CASES); PK:LISP-MACROS 37/1 INTLAND(FIRSTARG, SECONDARG); PK:ARITHMETIC 377/32 INTLESSP(FIRSTARG, SECONDARG); PK:ARITHMETIC 417/38 INTLNOT X; PK:ARITHMETIC 448/44 INTLOR(FIRSTARG, SECONDARG); PK:ARITHMETIC 384/33 INTLSHIFT(FIRSTARG, SECONDARG); PK:ARITHMETIC 400/35 INTLXOR(FIRSTARG, SECONDARG); PK:ARITHMETIC 391/34 INTMINUS FIRSTARG; PK:ARITHMETIC 453/45 INTMINUSP FIRSTARG; PK:ARITHMETIC 482/49 INTONEP FIRSTARG; PK:ARITHMETIC 498/53 INTPLUS2(FIRSTARG, SECONDARG); PK:ARITHMETIC 277/22 INTQUOTIENT(FIRSTARG, SECONDARG); PK:ARITHMETIC 330/28 INTREMAINDER(FIRSTARG, SECONDARG); PK:ARITHMETIC 355/30 INTSUB1 FIRSTARG; PK:ARITHMETIC 437/42 INTTIMES2(FIRSTARG, SECONDARG); PK:ARITHMETIC 313/26 INTZEROP FIRSTARG; PK:ARITHMETIC 490/51 IOERROR(MESSAGE); PK:IO-ERRORS 26/5 LAMBDAAPPLY(FN, ARGS); %. FN IS LAMBDA, UNEVALED ARGS PK:EVAL-APPLY 61/2 LAMBDAEVALAPPLY(FN, ARGS); %. FN IS LAMBDA, ARGS TO B PK:EVAL-APPLY 45/1 LAMBIND V; % V IS VECTOR OF IDS PK:FAST-BINDER 22/1 LAPIN FIL; PK:DSKIN 67/4 LASTCAR X; %. LAST ELEMENT OF LIST PK:EASY-NON-SL 248/39 LASTPAIR X; %. LAST PAIR OF LIST PK:EASY-NON-SL 251/40 LBIND1(IDNAME, VALUETOBIND); %. SUPPORT FOR LAMBDA PK:BINDING 63/7 LCONC(PTR, LST); %. NCONC MAINTAINING POINTER TO END PK:EASY-NON-SL 294/47 LENGTH U; %. LENGTH OF LIST U PK:OTHERS-SL 35/4 LENGTH1(U, N); PK:OTHERS-SL 38/5 LEQ(U, V); %. LESS THAN OR EQUAL TO PK:EASY-NON-SL 41/4 LINELENGTH LEN; %. SET MAXIMUM LINE LENGTH PK:OTHER-IO 52/4 LISP2CHAR U; %. CONVERT LISP ITEM TO SYSLSP CHAR PK:TYPE-CONVER 43/4 LISPEQUAL(U, V); %. STRUCTURAL EQUALITY PK:EQUAL 37/2 LIST U; %. CONSTRUCT LIST OF ARGUMENTS PK:EASY-SL 66/6 LIST2(U, V); %. 2-ARGUMENT EXPR FOR LIST PK:COMP-SUPPOR 33/6 LIST2SET L; %. REMOVE REDUNDANT ELEMENTS FROM L PK:SETS 12/1 LIST2SETQ L; %. EQ VERSION OF LIST2SET PK:SETS 17/2 LIST2STRING P; %. MAKE STRING WITH ASCII VALUES IN P PK:TYPE-CONVER 95/11 LIST2VECTOR L; %. CONVERT LIST TO VECTOR PK:TYPE-CONVER 115/13 LIST3(U, V, W); %. 3-ARGUMENT EXPR FOR LIST PK:COMP-SUPPOR 30/5 LIST4(U, V, W, X); %. 4-ARGUMENT EXPR FOR LIST PK:COMP-SUPPOR 27/4 LIST5(U, V, W, X, Y); %. 5-ARGUMENT EXPR FOR LIST PK:COMP-SUPPOR 24/3 LITER U; %. IS U A SINGLE CHARACTER ALPHABETIC ID? PK:OTHERS-SL 27/3 LOAD U; PK:LOAD 57/1 LOAD1 U; PK:LOAD 70/5 LOADTIME U; %. EVALUATE AT LOAD TIME ONLY PK:EVAL-WHEN 33/4 LOCALIDNUMBERP U; PK:FASLIN 19/1 LOCALTOGLOBALID U; PK:FASLIN 22/2 LOOKUPORADDTOOBLIST U; PK:OBLIST 63/2 LPOSN(); %. NUMBER OF EOLS SINCE LAST FF PK:OTHER-IO 64/8 MACROP U; %. IS U A MACRO? PK:EASY-NON-SL 50/7 MAKE!-BYTES(L, C); %. MAKE BYTE VECTOR WITH UPB L, AL PK:SEQUENCE 349/10 MAKE!-HALFWORDS(L, C); %. MAKE H VECT WITH UPB L, ALL PK:SEQUENCE 359/11 MAKE!-VECTOR(L, C); %. MAKE VECT WITH UPB L, ALL ITEM PK:SEQUENCE 380/13 MAKE!-WORDS(L, C); %. MAKE W VECT WITH UPB L, ALL ITE PK:SEQUENCE 370/12 MAKEARGLIST N; PK:AUTOLOAD 51/2 MAKEBUFINTOFLOAT EXPONENT; PK:TOKEN-SCANN 139/6 MAKEBUFINTOID(); PK:TOKEN-SCANN 106/2 MAKEBUFINTOLISPINTEGER(RADIX, SIGN); PK:TOKEN-SCANN 126/5 MAKEBUFINTOSTRING(); PK:TOKEN-SCANN 115/3 MAKEBUFINTOSYSNUMBER(RADIX, SIGN); PK:TOKEN-SCANN 121/4 MAKEDS(MACRONAME, FORMALS, FORM); PK:DEFINE-SMAC 47/4 MAKEEXTRAARGUMENT U; PK:FASLIN 28/4 MAKEFIXNUM N; PK:ARITHMETIC 213/11 MAKEIDFREELIST(); PK:COMPACTING- 258/10 MAKEIDFREELIST(); PK:COPYING-GC 173/9 MAKEINPUTAVAILABLE(); PK:TOKEN-SCANN 548/19 MAKESTRINGINTOBITSTRING(STRNG, RADIX, RADIXEXPONENT, PK:TOKEN-SCANN 488/12 MAKESTRINGINTOLISPINTEGER(S, RADIX, SIGN); PK:TOKEN-SCANN 468/10 MAKESTRINGINTOSYSINTEGER(STRNG, RADIX, SIGN); PK:TOKEN-SCANN 471/11 MAKEUNBOUND U; %. MAKE U AN UNBOUND ID PK:SYMBOL-VALU 19/2 MAP(L, FN); %. FOR EACH X ON L DO FN(X); PK:EASY-SL 203/31 MAP2(L, M, FN); %. FOR EACH X, Y ON L, M DO FN(X, Y) PK:EASY-NON-SL 313/48 MAPC(L, FN); %. FOR EACH X IN L DO FN(X); PK:EASY-SL 208/32 MAPC2(L, M, FN); %. FOR EACH X, Y IN L, M DO FN(X, Y PK:EASY-NON-SL 322/49 MAPCAN(L, FN); %. FOR EACH X IN L CONC FN(X); PK:EASY-SL 213/33 MAPCAR(L, FN); %. FOR EACH X IN L COLLECT FN(X); PK:EASY-SL 221/35 MAPCON(L, FN); %. FOR EACH X ON L CONC FN(X); PK:EASY-SL 217/34 MAPLIST(L, FN); %. FOR EACH X ON L COLLECT FN(X); PK:EASY-SL 225/36 MAPOBL F; %. APPLY F TO EVERY INTERNED ID PK:OBLIST 181/13 MARKANDCOPYFROMID X; PK:COPYING-GC 85/3 MARKFROMALLBASES(); PK:COMPACTING- 181/3 MARKFROMBASE BASE; PK:COMPACTING- 212/7 MARKFROMONESYMBOL X; PK:COMPACTING- 201/5 MARKFROMRANGE(LOW, HIGH); PK:COMPACTING- 209/6 MARKFROMSYMBOLS(); PK:COMPACTING- 191/4 MARKFROMVECTOR INFO; PK:COMPACTING- 250/9 MAX U; %. NUMERIC MAXIMUM OF SEVERAL ARGUMENTS PK:EASY-SL 182/25 MAX2(U, V); %. MAXIMUM OF 2 ARGUMENTS PK:EASY-SL 185/26 MEM(F, U, V); %. GENERALIZED MEMBER, F IS COMPARISON PK:EASY-NON-SL 182/29 MEMBER(U, V); %. FIND U IN V PK:EASY-SL 289/44 MEMQ(U, V); % EQ VERSION OF MEMBER PK:EASY-SL 294/45 MIN U; %. NUMERIC MINIMUM OF SEVERAL ARGUMENTS PK:EASY-SL 188/27 MIN2(U, V); %. MINIMUM OF 2 ARGUMENTS PK:EASY-SL 191/28 MKEVECTOR(N,ETAG); %. ALLOCATE EVECT, INIT ALL T PK:CONS-MKVECT 85/6 MKFLAGVAR U; % SHOULD BE REDEFINED IN PACKAGE.RED PK:ONOFF 27/2 MKQUOTE U; %. EVAL MKQUOTE U EQ U PK:EASY-NON-SL 89/12 MKSTRING(L, C); %. MAKE STR WITH UPB L, ALL CHARS C PK:SEQUENCE 339/9 MKVECT N; %. ALLOCATE VECTOR, INIT ALL TO NIL PK:CONS-MKVECT 72/5 NCONC(U, V); %. DESTRUCTIVE VERSION OF APPEND PK:EASY-SL 299/46 NCONS U; %. U . NIL, OR 1-ARGUMENT EXPR FOR LIST PK:COMP-SUPPOR 15/1 NCONS U; %. U . NIL PK:CONS-MKVECT 59/4 NE(U, V); %. NOT EQ PK:EASY-NON-SL 35/2 NEQ(U, V); %. NOT EQUAL (SHOULD BE CHANGED TO NOT EQ) PK:EASY-NON-SL 32/1 NEWID S; %. ALLOCATE UN-INTERNED ID WITH PRINT NAME PK:OBLIST 82/3 NEXPRP U; %. IS U AN NEXPR? PK:EASY-NON-SL 56/9 NEXT U; %. CONTINUE LOOP PK:LOOP-MACROS 57/3 NONCHARACTERERROR(OFFENDER, FN); PK:TYPE-ERRORS 44/9 NONIDERROR(OFFENDER, FN); PK:TYPE-ERRORS 32/5 NONINTEGER1ERROR(ARG, DISPATCHTABLE); PK:ARITHMETIC 146/5 NONINTEGER2ERROR(FIRSTARG, SECONDARG, DISPATCHTABLE); PK:ARITHMETIC 139/4 NONINTEGERERROR(OFFENDER, FN); PK:TYPE-ERRORS 38/7 NONIOCHANNELERROR(OFFENDER, FN); PK:TYPE-ERRORS 59/14 NONNUMBERERROR(OFFENDER, FN); PK:TYPE-ERRORS 35/6 NONPAIRERROR(OFFENDER, FN); PK:TYPE-ERRORS 29/4 NONPOSITIVEINTEGERERROR(OFFENDER, FN); PK:TYPE-ERRORS 41/8 NONSEQUENCEERROR(OFFENDER, FN); PK:TYPE-ERRORS 56/13 NONSTRINGERROR(OFFENDER, FN); PK:TYPE-ERRORS 47/10 NONVECTORERROR(OFFENDER, FN); PK:TYPE-ERRORS 50/11 NONWORDS(OFFENDER, FN); PK:TYPE-ERRORS 53/12 NOT U; %. EQUIVALENT TO NULL PK:EASY-SL 167/22 NTH(U, N); %. N-TH ELEMENT OF LIST PK:EASY-NON-SL 261/42 NTHENTRY N; PK:TOP-LOOP 138/4 NULL U; %. IS U EQ NIL? PK:EASY-SL 41/3 NUMBERP U; %. IS U A NUMBER OF ANY KIND? PK:EASY-SL 44/4 OFF U; PK:ONOFF 33/4 ON U; PK:ONOFF 30/3 ONEARGDISPATCH FIRSTARG; PK:ARITHMETIC 152/6 ONEARGDISPATCH1 EXPR 2) PK:ARITHMETIC 155/7 ONEARGERROR(FIRSTARG, DUMMY, DISPATCHTABLE); PK:ARITHMETIC 179/8 ONEARGPREDICATEDISPATCH FIRSTARG; PK:ARITHMETIC 185/9 ONEARGPREDICATEDISPATCH1 EXPR 2) PK:ARITHMETIC 188/10 ONOFF!*(IDLIST, U); PK:ONOFF 15/1 OPEN(FILENAME, ACCESSTYPE); %. GET ACCESS TO FILE PK:OPEN-CLOSE 28/1 OR U; %. SEQUENTIALLY EVALUATE UNTIL NON-NIL PK:EASY-SL 139/18 PACKAGE U; PK:TOKEN-SCANN 543/18 PAIR(U, V); %. FOR EACH X,Y IN U,V COLLECT (X . Y) PK:EASY-SL 261/40 PAIRP U; %. IS U A PAIR? PK:KNOWN-TO-CO 35/6 PBIND1 IDNAME; %. SUPPORT FOR PROG PK:BINDING 77/8 PLUS U; %. ADDITION OF SEVERAL ARGUMENTS PK:EASY-SL 194/29 PNTH(U, N); %. POINTER TO N-TH ELEMENT OF LIST PK:EASY-NON-SL 269/44 POSN(); %. NUMBER OF CHARACTERS SINCE LAST EOL PK:OTHER-IO 58/6 PRIN1 ITM; %. CHANNELPRIN1 TO CURRENT OUTPUT PK:PRINTERS 516/35 PRIN2 ITM; %. CHANNELPRIN2 TO CURRENT CHANNEL PK:PRINTERS 474/32 PRIN2L ITM; %. PRIN2 WITHOUT TOP-LEVEL PARENS PK:PRINTF 193/8 PRIN2T U; %. PRIN2 AND TERPRI PK:EASY-NON-SL 338/51 PRINT U; %. DISPLAY U AND TERMINATE LINE PK:EASY-SL 350/55 PRINTF(FORMATFORPRINTF!*, A1, A2, A3, A4, A5, PK:PRINTF 27/1 PRINTF1 EXPR 15) PK:PRINTF 37/2 PRINTF2 PRINTFARGS; %. FORMATTED PRINT PK:PRINTF 61/3 PRINTWITHFRESHLINE X; PK:TOP-LOOP 191/12 PROG PROGBODY!*; %. PROGRAM FEATURE FUNCTION PK:PROG-AND-FR 24/1 PROG2(U, V); %. RETURN SECOND ARGUMENT PK:EASY-SL 110/12 PROGBIND V; PK:FAST-BINDER 30/2 PROGN U; %. SEQUENTIAL EVALUATION, RETURN LAST PK:EASY-SL 113/13 PROP U; %. ACCESS PROPERTY LIST OF U PK:PROPERTY-LI 33/1 PUT(U, INDICATOR, VAL); %. STORE VAL IN U WITH INDICA PK:PROPERTY-LI 118/10 PUTC(NAME, IND, EXP); %. USED BY RLISP TO DEFINE SMAC PK:EASY-NON-SL 387/58 PUTD(FNNAME, FNTYPE, FNEXP); %. INSTALL FUNCTION DEFI PK:PUTD-GETD 64/3 PUTENTRY(NAME, TYPE, OFFSET); PK:FASLIN 137/6 PUTV(VEC, I, VAL); %. STORE VAL AT I'TH POSITION OF V PK:VECTORS 36/2 QEDNTH(N,L); PK:MINI-EDITOR 108/4 QUOTE U; %. RETURN UNEVALUATED ARGUMENT PK:EASY-SL 334/52 RANGEERROR(OBJECT, INDEX, FN); PK:ERROR-HANDL 37/2 RASSOC(U, V); %. REVERSE ASSOC, COMPARE WITH CDR OF E PK:EASY-NON-SL 187/30 RATOM(); %. READ TOKEN FROM CURRENT INPUT PK:TOKEN-SCANN 459/8 RDS CHANNEL; %. SWITCH INPUT CHANNELS, RETURN OLD PK:RDS-WRS 22/1 READ(); %. PARSE S-EXPR FROM CURRENT INPUT PK:READ 52/3 READCH(); %. READ A SINGLE CHARACTER ID PK:OTHER-IO 75/10 READCHAR(); %. READ SINGLE CHAR FROM CURRENT INPUT PK:CHAR-IO 44/2 READINBUF(); PK:TOKEN-SCANN 80/1 READLINE(); PK:TOKEN-SCANN 525/16 READONLYCHANNEL(CHN, CH); PK:IO-ERRORS 20/3 RECIP N; %. FLOATING POINT RECIPROCAL PK:EASY-NON-SL 84/11 RECLAIM(); PK:COPYING-GC 58/1 RECLAIM(); %. USER CALL TO GARBAGE COLLECTOR PK:COMPACTING- 159/1 RECURSIVECHANNELPRIN1(CHANNEL, ITM, LEVEL); PK:PRINTERS 480/34 RECURSIVECHANNELPRIN2(CHANNEL, ITM, LEVEL); PK:PRINTERS 438/31 REDO N; %. RE-EVALUATE NTH INPUT PK:TOP-LOOP 148/6 RELOAD U; PK:LOAD 63/3 RELOCINFINF X; PK:FASL-INCLUD 34/4 RELOCINFTAG X; PK:FASL-INCLUD 31/3 RELOCRIGHTHALFINF X; PK:FASL-INCLUD 28/2 RELOCRIGHTHALFTAG X; PK:FASL-INCLUD 25/1 RELOCWORDINF X; PK:FASL-INCLUD 40/6 RELOCWORDTAG X; PK:FASL-INCLUD 37/5 REMD U; %. REMOVE FUNCTION DEFINITION OF U PK:PUTD-GETD 46/2 REMFLAG(IDLIST, INDICATOR); %. REMOVE MARKING OF ALL PK:PROPERTY-LI 106/8 REMFLAG1(U, INDICATOR); PK:PROPERTY-LI 112/9 REMOB U; %. REMOVE ID FROM OBLIST PK:OBLIST 135/8 REMPROP(U, INDICATOR); %. REMOVE VALUE OF U WITH INDI PK:PROPERTY-LI 132/11 REMPROPL(L, INDICATOR); %. REMPROP FOR ALL IDS IN L PK:PROPERTY-LI 141/12 REMQUOTE X; PK:ARITHMETIC 255/20 REPEAT U; PK:LOOP-MACROS 72/5 REST U; %. TAIL OF A LIST PK:EASY-NON-SL 107/17 RESTOREENVIRONMENT PTR; %. RESTORE OLD BINDINGS PK:BINDING 50/4 RETURN U; %. RETURN VALUE FROM PROG PK:PROG-AND-FR 63/3 RETURNFIRSTARG ARG; PK:ARITHMETIC 226/14 RETURNNIL(); PK:ARITHMETIC 223/13 REVERSE U; %. TOP-LEVEL REVERSE OF LIST PK:EASY-SL 308/47 REVERSIP U; %. DESTRUCTIVE REVERSE (REVERSE IN PLACE) PK:EASY-NON-SL 113/18 ROBUSTEXPAND(L, FN, EMPTYCASE); %. EXPAND + ARG FOR E PK:EASY-SL 326/50 RPLACA(U, V); %. REPLACE CAR OF PAIR PK:KNOWN-TO-CO 57/11 RPLACD(U, V); %. REPLACE CDR OF PAIR PK:KNOWN-TO-CO 60/12 RPLACEALL(A,NEW,S); PK:MINI-EDITOR 115/6 RPLACW(A, B); %. REPLACE WHOLE PAIR PK:EASY-NON-SL 237/38 SAFECAR U; PK:CARCDR 132/25 SAFECDR U; PK:CARCDR 136/26 SASSOC(U, V, FN); %. RETURN FIRST (U . XXX) IN V, OR PK:EASY-SL 256/39 SAVESYSTEM(BANNER, FILE, INITFORMS); PK:TOP-LOOP 194/13 SCANNERERROR MESSAGE; PK:TOKEN-SCANN 511/14 SCANPOSSIBLEDIPHTHONG(CHANNEL, STARTCHAR); PK:TOKEN-SCANN 514/15 SECOND U; %. SECOND ELEMENT OF A LIST PK:EASY-NON-SL 98/14 SET(EXP, VAL); %. ASSIGN VAL TO ID EXP PK:SYMBOL-VALU 40/4 SETF U; %. GENERAL ASSIGNMENT MACRO PK:LISP-MACROS 45/2 SETINDX(R1, R2, R3); %. STORE AT INDEX OF SEQUENCE PK:SEQUENCE 58/2 SETMACROREFERENCE U; PK:DEFINE-SMAC 26/2 SETPROP(U, L); %. STORE L AS PROPERTY LIST OF U PK:PROPERTY-LI 37/2 SETQ U; %. STANDARD NAMED VARIABLE ASSIGNMENT PK:EASY-SL 95/11 SETSUB(R1, R2, R3, R4); %. OBSOLETE SUBSEQUENCE FUNCT PK:SEQUENCE 170/5 SETSUBSEQ(R1, R2, R3, R4); % R2 IS LOWER BOUND, R3 UP PK:SEQUENCE 173/6 SIZE S; %. UPPER BOUND OF SEQUENCE PK:SEQUENCE 321/8 SPACES N; %. PRIN2 N SPACES PK:EASY-NON-SL 344/53 STANDARDLISP(); %. LISP TOP LOOP PK:TOP-LOOP 186/11 STATICINTFLOAT ARG; PK:ARITHMETIC 233/15 STDERROR MESSAGE; %. ERROR WITHOUT NUMBER PK:ERROR-HANDL 40/3 STRING U; %. ANALOGOUS TO LIST, STRING CONSTRUCTOR PK:SEQUENCE 396/14 STRING2LIST S; %. MAKE LIST WITH ASCII VALUES IN S PK:TYPE-CONVER 106/12 STRING2VECTOR U; %. MAKE VECTOR OF ASCII VALUES IN U PK:TYPE-CONVER 75/9 STRINGEQUAL(U, V); % EQSTR WITHOUT TYPECHECKING OR EQ PK:EQUAL 65/4 STRINGGENSYM(); %. GENERATE UNIQUE STRING PK:STRING-GENS 20/1 STRINGGENSYM1 N; %. AUXILIARY FUNCTION FOR STRINGGEN PK:STRING-GENS 23/2 STRINGP U; %. IS U A STRING? PK:KNOWN-TO-CO 38/7 STUPIDPARSERFIX X; PK:ARITHMETIC 249/19 SUB(R1, R2, R3); %. OBSOLETE SUBSEQUENCE FUNCTION PK:SEQUENCE 103/3 SUBLA(U,V); %. EQ VERSION OF SUBLIS, REPLACES ATOMS O PK:EASY-NON-SL 228/37 SUBLIS(X, Y); %. SUBSTITUTION IN Y BY A-LIST X PK:EASY-SL 267/41 SUBSEQ(R1, R2, R3); % R2 IS LOWER BOUND, R3 UPPER PK:SEQUENCE 106/4 SUBST(A, X, L); %. REPLACE EVERY X IN L WITH A PK:EASY-SL 316/48 SUBSTIP(A, X, L); %. DESTRUCTIVE VERSION OF SUBST PK:EASY-NON-SL 127/20 SUBSTIP1(A, X, L); % AUXILIARY FUNCTION FOR SUBSTIP PK:EASY-NON-SL 122/19 SYS2FIXN N; PK:TYPE-CONVER 60/7 SYS2INT N; %. CONVERT WORD TO LISP NUMBER PK:TYPE-CONVER 56/6 SYSPOWEROF2P NUM; PK:TOKEN-SCANN 500/13 TAB N; %. SPACES TO COLUMN N PK:EASY-NON-SL 356/55 TCONC(PTR, ELEM); %. ACONC MAINTAINING POINTER TO END PK:EASY-NON-SL 278/46 TERPRI(); %. TERMINATE CURRENT OUTPUT LINE PK:OTHER-IO 82/12 THIRD U; %. THIRD ELEMENT OF A LIST PK:EASY-NON-SL 101/15 THROW(TAG, VALUE); PK:CATCH-THROW 179/21 THROWAUX EXPR 3) PK:CATCH-THROW 173/20 TIME(); %. GET RUN-TIME IN MILLISECONDS PK:TOP-LOOP 183/10 TIMES U; %. MULTIPLICATION OF SEVERAL ARGUMENTS PK:EASY-SL 197/30 TOPLOOP(TOPLOOPREAD!*, %. GENERALIZED TOP-LOOP MECHAN PK:TOP-LOOP 56/1 TOSTRINGWRITECHAR(CHANNEL, CH); % SHARES TOKENBUFFER PK:PRINTF 162/5 TOTALCOPY S; %. UNIQUE COPY OF ENTIRE STRUCTURE PK:COPIERS 79/8 TR L; %. TRACE FUNCTIONS IN L PK:MINI-TRACE 87/4 TR!.1 NAM; % CALLED TO TRACE A SINGLE FUNCTION PK:MINI-TRACE 52/2 TR!.PRC(PN, B, A); % CALLED IN PLACE OF TRACED CODE PK:MINI-TRACE 26/1 TRCLR(); %. CALLED TO SETUP OR FIX TRACE PK:MINI-TRACE 102/9 TRMAKEARGLIST N; % GET ARGLIST FOR N ARGS PK:MINI-TRACE 99/8 TWOARGDISPATCH(FIRSTARG, SECONDARG); PK:ARITHMETIC 44/1 TWOARGDISPATCH1 EXPR 4) PK:ARITHMETIC 47/2 TWOARGERROR(FIRSTARG, SECONDARG, DISPATCHTABLE); PK:ARITHMETIC 132/3 TYI(); %. READ ASCII VALUE FROM CURENT INPUT PK:IO-EXTENSIO 24/3 TYO CH; %. WRITE ASCII VALUE TO CURRENT OUTPUT PK:IO-EXTENSIO 27/4 TYPEERROR(OFFENDER, FN, TYP); PK:TYPE-ERRORS 17/1 UNBINDN N; %. SUPPORT FOR LAMBDA AND PROG INTERP PK:BINDING 60/6 UNBOUNDP U; %. DOES U NOT HAVE A VALUE? PK:SYMBOL-VALU 13/1 UNBR L; %. UNBREAK FUNCTIONS IN L PK:MINI-TRACE 203/15 UNBR!.1 NAM; PK:MINI-TRACE 186/12 UNFLUID IDLIST; %. UNDECLARE ALL IN IDLIST AS FLUID PK:FLUID-GLOBA 61/9 UNFLUID1 U; PK:FLUID-GLOBA 64/10 UNION(X, Y); %. SET UNION PK:SETS 28/5 UNIONQ(X, Y); %. EQ VERSION OF UNION PK:SETS 32/6 UNREADCHAR CH; %. BACKUP ON CURRENT INPUT CHANNEL PK:CHAR-IO 82/6 UNTR L; %. UNTRACE FUNCTION IN L PK:MINI-TRACE 93/6 UNTR!.1 NAM; PK:MINI-TRACE 76/3 UNWIND!-ALL U; PK:CATCH-THROW 40/2 UNWIND!-PROTECT U; PK:CATCH-THROW 49/3 UPBV V; %. UPPER LIMIT OF VECTOR V PK:VECTORS 53/3 UPDATEALLBASES(); PK:COMPACTING- 337/12 UPDATEHEAP(); PK:COMPACTING- 360/15 UPDATEITEM PTR; PK:COMPACTING- 400/16 UPDATEREGION(LOW, HIGH); PK:COMPACTING- 357/14 UPDATESYMBOLS(); PK:COMPACTING- 347/13 USAGETYPEERROR(OFFENDER, FN, TYP, USAGE); PK:TYPE-ERRORS 21/2 VALUECELL U; %. SAFE ACCESS TO SYMVAL ENTRY PK:SYMBOL-VALU 25/3 VECTOR U; %. ANALOGOUS TO LIST, VECTOR CONSTRUCTOR PK:SEQUENCE 399/15 VECTOR2LIST V; %. CONVERT VECTOR TO LIST PK:TYPE-CONVER 125/14 VECTOR2STRING V; %. MAKE STRING WITH ASCII VALUES IN PK:TYPE-CONVER 85/10 VECTOREQUAL(U, V); % VECTOR EQUALITY WITHOUT TYPE CHE PK:EQUAL 105/7 VECTORP U; %. IS U A VECTOR? PK:KNOWN-TO-CO 41/8 VERBOSEBACKTRACE(); PK:BACKTRACE 44/4 WHILE U; %. ITERATION MACRO PK:LOOP-MACROS 60/4 WORDSEQUAL(U, V); PK:EQUAL 79/5 WRITECHAR CH; %. WRITE SINGLE CHAR TO CURRENT OUTPUT PK:CHAR-IO 69/4 WRITENUMBER1(CHANNEL, NUMBER, RADIX); PK:PRINTERS 112/5 WRITEONLYCHANNEL CHN; PK:IO-ERRORS 17/2 WRITESTRING S; PK:PRINTERS 93/3 WRITESYSINTEGER(NUMBER, RADIX); PK:PRINTERS 134/8 WRS CHANNEL; %. SWITCH OUTPUT CHANNELS, RETURN OLD PK:RDS-WRS 35/2 XCHANGE(S,CTL,NEW,N); PK:MINI-EDITOR 128/8 XCONS(U, V); %. EXCHANGED CONS PK:CONS-MKVECT 46/3 XCONS(U, V); %. V . U PK:COMP-SUPPOR 18/2 XINS(S,CTL,NEW,N); PK:MINI-EDITOR 133/9 XN(U, V); %. SET INTERSECTION PK:SETS 36/7 XNQ(U, V); %. EQ VERSION OF XN PK:SETS 41/8 YESP U; PK:ERROR-HANDL 43/4 ------- |
Added psl-1983/tests/pk-modules.list version [071ea82c04].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PK: modules/files ALLOC Allocators Copiers Cons-mkvect Comp-support System-gc Gc ARITH Arithmetic DEBG Mini-trace Mini-editor Backtrace ERROR Error-handlers Type-errors Error-errorset Io-errors EVAL Apply-lap Eval-apply Catch-throw Prog-and-friends EXTRA Timc System-extras Trap Dumplisp FASL System-faslout System-faslin Faslin Load Autoload P20:HEAP [Declare HEAP,BPS] IO Io-data Char-io Open-close Rds-wrs Other-io Read Token-scanner Printers Write-float Printf Explode-compress Io-extensions MACRO Eval-when Cont-error Lisp-macros Onoff Define-smacro Defconst String-gensym Loop-macros MAIN Main-start PROP Function-primitives Property-list Fluid-global Putd-getd RANDM Known-to-comp-sl Others-sl Equal Carcdr Easy-sl Easy-non-sl Sets SYMBL Binding Fast-binder Symbol-values Oblist SYSIO System-io Scan-table TLOOP Break Top-loop Dskin TYPES Type-conversions Vectors Sequence |
Added psl-1983/tests/psl-timer.b version [a08a50216b].
cannot compute difference between binary files
Added psl-1983/tests/psl-timer.sl version [3ea6fad721].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PSL-TIMER.SL Source of PSL "spectral" tests % Compile this file to produce psl-timer.b % then LAPIN the file "time-psl.sl" '( (sstatus translink t) (declare (localf tak gtak)) (def de (macro (x) (cons 'defun (cdr x)))) (def igreaterp (macro (x) (cons '> (cdr x)))) (def ilessp (macro (x) (cons '< (cdr x)))) (def iadd1 (macro (x) (cons '1+ (cdr x)))) (def isub1 (macro (x) (cons '1- (cdr x)))) (def itimes2 (macro (x) (cons '* (cdr x)))) (allocate 'fixnum 2000) (allocate 'list 500) (setq $gcprint t) (defun time () (* (car (ptime)) 17)) (defun reclaim () (gc)) ) (de TestSetup () (progn (setq TestList (PrepareTest 1000)) (setq TestList2 (PrepareTest 2000)) (MakeLongList) (setq EvalForm '(setq Foo (cadr '(1 2 3)))))) (de MakeLongList () (prog (I) (setq LongList '(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 I 0) loop (cond ((igreaterp I 5) (return nil))) (setq LongList (append LongList LongList)) (setq I (iadd1 I)) (go loop))) (de PrepareTest (n) (prog (l i) (setq i -1 l nil) top (cond ((ilessp n i) (return l))) (setq i (iadd1 i) l (cons nil l)) (go top))) (de Cdr1Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((atom (setq L (cdr L))) (go loop))) (go loop1))) (de Cdr2Test (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cdr L))) (go loop))) (go loop1))) (de CddrTest (N) (prog (I L) (setq I -1) loop (setq I (iadd1 I)) (setq L LongList) (cond ((igreaterp I N) (return nil))) loop1 (cond ((null (setq L (cddr L))) (go loop))) (go loop1))) (de ListOnlyCdrTest1 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((null (setq l2 (cdr l2))) (cond ((null (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest1 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((null (setq l2 (cddr l2))) (cond ((null (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCdrTest2 () (prog (l1 l2) (setq l1 TestList) top (setq l2 TestList) again (cond ((atom (setq l2 (cdr l2))) (cond ((atom (setq l1 (cdr l1))) (return nil)) (t (go top)))) (t (go again))))) (de ListOnlyCddrTest2 () (prog (l1 l2) (setq l1 TestList2) top (setq l2 TestList2) again (cond ((atom (setq l2 (cddr l2))) (cond ((atom (setq l1 (cddr l1))) (return nil)) (t (go top)))) (t (go again))))) (de EmptyTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (setq I (iadd1 I)) (go loop))) (de SlowEmptyTest (N) (prog (I) (setq I 0) loop (cond ((greaterp I N) (return nil))) (setq I (add1 I)) (go loop))) (de ReverseTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (reverse LongList) (setq I (iadd1 I)) (go loop))) (de MyReverse1Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse1 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse1 (L) (prog (M) loop (cond ((atom L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de MyReverse2Test (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (myreverse2 LongList) (setq I (iadd1 I)) (go loop))) (de myreverse2 (L) (prog (M) loop (cond ((null L) (return M))) (setq M (cons (car L) M)) (setq L (cdr L)) (go loop))) (de LengthTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (length LongList) (setq I (iadd1 I)) (go loop))) (de Fact (N) (cond ((ilessp N 2) 1) (t (itimes2 N (Fact (isub1 N)))))) (de ArithmeticTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (Fact 9) (setq I (iadd1 I)) (go loop))) (de EvalTest (N) (prog (I) (setq I 0) loop (cond ((igreaterp I N) (return nil))) (eval EvalForm) (setq I (iadd1 I)) (go loop))) (de TimeEval (Form) (prog (I) (setq I (time)) (eval Form) (return (difference (time) I)))) (de topleveltak (x y z) (tak x y z)) (de tak (x y z) (cond ((null (ilessp y x)) z) (t (tak (tak (isub1 x) y z) (tak (isub1 y) z x) (tak (isub1 z) x y))))) (de toplevelgtak (x y z) (gtak x y z)) (de gtak (x y z) (cond ((null (lessp y x)) z) (t (gtak (gtak (sub1 x) y z) (gtak (sub1 y) z x) (gtak (sub1 z) x y))))) (de gtsta (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (apply F (list I)) (setq I (iadd1 I)) (go Loop))) (de gtstb (F) (prog (I) (setq I 1) Loop (cond ((igreaterp I 100000) (return nil))) (funcall F I) (setq I (iadd1 I)) (go Loop))) (de g0 (X) X) (de g1 (X) (iadd1 X)) (de nreverse (x) (nreconc x nil)) (de nreconc (x y) (prog (z) L (cond ((atom x) (return y))) (setq z x) (setq x (cdr x)) (setq y (rplacd z y)) (go L))) (de nnils (N) (prog (LST i) (setq i 0) loop (cond ((igreaterp i N) (return LST))) (setq LST (cons nil LST)) (setq i (iadd1 i)) (go loop))) (global '(TestGlobalVar)) (de nils (N) (setq TESTGLOBALVAR (nnils N)) N) (de nr () (setq TESTGLOBALVAR (nreverse TESTGLOBALVAR)) nil) |
Added psl-1983/tests/psl-times.lpt version [e02bbb62d8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PSL 3.1 times in ms, taken at HP Computer Research Center, 5 Dec 1982 --------------------------------------------------------------------- DEC-20 VAX-780 HP9836 Empty 20 34 70 SlowEmpty 284 612 1930 Cdr1 531 1632 2660 Cdr2 385 1241 1120 Cddr 304 986 850 ListOnlyCdr1 1806 5695 6700 ListOnlyCddr1 3703 11832 10090 ListOnlyCdr2 2804 8806 15960 ListOnlyCddr2 4599 14875 19270 Reverse 273 646 1480 MyReverse1 270 629 1470 MyReverse2 253 680 1310 Length 567 1632 3080 Arithmetic 605 833 6560 Eval 1901 5865 17650 tak(18,12,6) 446 697 2770 gtak(18,12,6) 1882 4029 13130 gtsta g0 727 2363 5810 gtsta g1 789 2397 5980 PSL 3.0 Times in ms taken at Utah and RAND, July-Aug 1982 or earlier -------------------------------------------------------------------- PSL PSL PSL FRANZ APOLLO APOLLO TEST 20 750 780 OPUS 38 8 Mhz 10 Mhz Empty 25 68 0 391 105 56 SlowEmpty 344 1139 663 3587 2330 1289 Cdr1 576 2023 1632 3791 3281 1886 Cdr2 367 1581 1224 1326 1449 648 Cddr 293 1275 1071 867 1068 851 ListOnlyCdr1 1754 9367 7208 6902 8658 4975 ListOnlyCddr1 3487 15232 12410 9027 12761 7734 ListOnlyCdr2 2864 12206 9418 21590 19611 11159 ListOnlyCddr2 4644 18003 15164 24106 23696 13933 Reverse 335 1037 748 663 3102 1806 MyReverse1 269 1071 697 867 3094 1826 MyReverse2 249 1020 629 697 2746 984 Length 585 2142 1700 4811 3847 2203 Arithmetic 589 1887 867 7667 3007 1852 Eval 1857 9384 5083 10098 15759 9509 tak(18,12,6) 442 1292 765 1887 2644 1627 gtak(18,12,6) 1902 7344 4267 18479 15140 8433 gtsta g0 829 4675 2533 13617 7720 4284 gtsta g1 890 4709 2465 25143 7888 4371 [The initial HP9836 times are uniformly between those of the small 8Mz and large 10Mz Apollo, Wicat was slightly slower] |
Added psl-1983/tests/psltest.sl version [291f15bb73].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%% Standard - LISP Verification file. %%%%%%%%%%%%%%%%%%%%%%% % % Copyright (C) M. Griss and J. Marti, February 1981 % Adapted to test PSL by M. L. Griss and E. Benson % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Set ECHO In caller, as desired (SETQ !*RAISE NIL) % Checks in ID tests (SETQ !*BREAK NIL) % So error messages proceed (DE MSG(X) % Prints general message (COND (!*ECHO NIL) (T (PROGN (PRIN2T X) NIL)))) (DE EXPECT(X) % Prints message about values (COND (!*ECHO NIL) (T (PROGN (PRIN2 " ----- Expect the following to Return: ") (PRIN2T X) NIL)))) (EXPECT "T T T T") T (NULL NIL) (COND (T T)) (COND (NIL NIL) (T T)) (EXPECT "NIL NIL NIL NIL") NIL (NULL T) (COND (T NIL)) (COND (NIL T) (T NIL)) (EXPECT "0 0") 0 (QUOTE 0) (MSG "Test the following minimum set of functions:") (MSG "PUTD, PROG, SET, QUOTE, COND, NULL, RETURN, LIST, CAR, CDR,") (MSG "EVAL, PRINT, PRIN1, TERPRI, PROGN, GO.") (MSG "Check PUTD, GETD, LAMBDA ") (PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) 3))) (EXPECT "(EXPR LAMBDA (X) 3)") (GETD (QUOTE FOO)) (EXPECT "3 3") (FOO 1) (FOO 2) (EXPECT "1 1") (SET (QUOTE A) 1) A (EXPECT "2 2") (SET (QUOTE B) 2) B (MSG "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) (MSG "Test REDEFINITION in PUTD, PROGN, PRIN1, TERPRI") (PUTD (QUOTE FOO) (QUOTE EXPR) (QUOTE (LAMBDA (X) (PROGN (PRIN1 X) (TERPRI))))) (EXPECT "1 2 NIL") (FOO 1) (FOO 2) (EXPECT "Test simple PROG, GO, RETURN: expect 1 2 NIL 1") (PROG NIL (PRINT 1) (PRINT 2)) (PROG (A) (PRINT A) (PRINT 1)) (MSG "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) ) (MSG "Test that A,B correctly rebound, expect AA and BB") A B (MSG "Redefine FOO as simple FEXPR") (PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (X) (PRINT X)))) (EXPECT "(FEXPR LAMBDA (X) (PRINT X))") (GETD (QUOTE FOO)) (EXPECT "FOO calls to return (1) (1 2) and (1 2 3)") (FOO 1) (FOO 1 2) (FOO 1 2 3) (MSG "Finally, TEST EVAL inside an FEXPR") (PUTD (QUOTE FOO) (QUOTE FEXPR) (QUOTE (LAMBDA (XX) (PRINT (EVAL (CAR XX)))))) (EXPECT "1 T") (FOO 1) (FOO (NULL NIL)) %---- The main tester ----- % PUTD is being used here to define a function !$TEST. (PUTD (QUOTE !$TEST) (QUOTE FEXPR) (QUOTE (LAMBDA (!$X) (PROG (A B) (SETQ A (CDR !$X)) % Space for test set (TERPRI) (PRIN2 "------ Beginning ") (PRIN1 (CAR !$X)) (PRIN2T " tests -----") LOOP (COND ((NULL (PAIRP A)) (RETURN (PROGN (PRIN2 "------ Finished ") (PRIN1 (CAR !$X)) (PRIN2T " tests -----") 0)))) (PRIN2 " try: ") (PRINT (CAR A)) (SETQ B (EVAL (CAR A))) (COND ( (NULL (EQ B 'T)) (PROGN (PRIN2 "****** ") (PRINT A) (PRIN2 " -> ") (PRINT B)))) (SETQ A (CDR A)) (GO LOOP) )))) (EXPECT "T and T if $TEST correctly defined") (PAIRP (GETD (QUOTE !$TEST))) (EQCAR (GETD (QUOTE !$TEST)) (QUOTE FEXPR)) % 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 1.0 1.0) (EQN 0.0 0.0) (NULL (EQN 1.0 0.0)) (NULL (EQN 0.0 1.0)) (NULL (EQN 1 1.0)) (NULL (EQN 0 0.0)) (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-----% (!$TEST ABS (EQN 0 (ABS 0)) (EQN 1 (ABS 1)) (EQN 1 (ABS -1)) (EQN 0.0 (ABS 0.0)) (EQN 1.0 (ABS 1.0)) (EQN 1.0 (ABS (MINUS 1.0))) ) (!$TEST ADD1 (EQN 1 (ADD1 0)) (EQN 0 (ADD1 -1)) (EQN 2 (ADD1 1)) (EQN 1.0 (ADD1 0.0)) (EQN 2.0 (ADD1 1.0)) ) (!$TEST DIFFERENCE (EQN 0 (DIFFERENCE 1 1)) (EQN 0.0 (DIFFERENCE 1.0 1.0)) (EQN 0.0 (DIFFERENCE 1 1.0)) (EQN 0.0 (DIFFERENCE 1.0 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 1.0)) (FIXP (FIX 1.0)) (NULL (FLOATP (FIX 1.0))) (EQN (FIX 1.0 ) 1) (NUMBERP (FIX 1)) (FIXP (FIX 1)) ) (!$TEST FLOAT (NUMBERP (FLOAT 1)) (FLOATP (FLOAT 1)) (NULL (FIXP (FLOAT 1))) (EQN 1.0 (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) ; (MAX) (!$TEST MAX2 (EQN (MAX2 1 2) 2) (EQN (MAX2 2 1) 2) (EQN 1 (MAX2 1 0)) (EQN 1 (MAX2 0 1)) (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) ; (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) ; (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) ; (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))))) ) (SETQ DIGITLST (QUOTE (!0 !1 !2 !3 !4 !5 !6 !7 !8 !9))) (DE TESTEACH (LST FN) (PROG (X) L1 (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 ; |
Added psl-1983/tests/simpler-time.sl version [4a87e8ec06].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | (TESTSETUP) % USE after each fresh start (TIMEEVAL '(EMPTYTEST 10000)) (TIMEEVAL '(SLOWEMPTYTEST 10000)) (TIMEEVAL '(CDR1TEST 100)) (TIMEEVAL '(CDR2TEST 100)) (TIMEEVAL '(CDDRTEST 100)) (TIMEEVAL '(LISTONLYCDRTEST1)) (TIMEEVAL '(LISTONLYCDDRTEST1)) (TIMEEVAL '(LISTONLYCDRTEST2)) (TIMEEVAL '(LISTONLYCDDRTEST2)) (TIMEEVAL '(REVERSETEST 10)) (TIMEEVAL '(MYREVERSE1TEST 10)) (TIMEEVAL '(MYREVERSE2TEST 10)) (TIMEEVAL '(LENGTHTEST 100)) (TIMEEVAL '(ARITHMETICTEST 10000)) (TIMEEVAL '(EVALTEST 10000)) (TIMEEVAL '(TOPLEVELTAK 18 12 6)) (TIMEEVAL '(TOPLEVELGTAK 18 12 6)) (TIMEEVAL '(GTSTB 'G0)) (TIMEEVAL '(GTSTB 'G1)) |
Added psl-1983/tests/stubs2.red version [1c605dcf4b].
> > > | 1 2 3 | % STUBS2.RED % just a dummy for now END; |
Added psl-1983/tests/stubs3.red version [4ed3308e7a].
> > > > > > | 1 2 3 4 5 6 | % STUBS3.RED - Mini RECLAIM called % MLG, 18 Feb 1983 in "pt:mini-gc.red"$ End; |
Added psl-1983/tests/stubs4.red version [21f08977b0].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % STUBS4.RED - Stubs to support more automatic testing from TEST4 and on procedure SpaceD(M); <<Prin2 " "; Prin2t M>>; procedure DasheD(M); <<Terpri(); Prin2 "---------- "; Prin2T M>>; procedure DotteD(M); <<Terpri(); Prin2 " ....... "; Prin2T M>>; Procedure ShouldBe(M,v,e); % test if V eq e; <<Prin2 " ....... For ";Prin2 M; Prin2 '" "; Prin1 v; Prin2 '" should be "; Prin1 e; if v eq e then Prin2T '" [OK ]" else Prin2T '" [BAD] *******">>; End; |
Added psl-1983/tests/stubs5.red version [92bb121325].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % STUBS5.RED - Stubs for TEST5 and Above Fluid '(UndefnCode!* UndefnNarg!*); on syslisp; syslsp procedure UndefinedFunctionAuxAux; % Interim version of UndefinedFunctionAux; Begin scalar FnId,Nargs; Nargs:=LispVar UndefnNarg!*; FnId := MkID (LispVar UndefnCode!*); Prin2 "Undefined Function "; Prin1 FnId; Prin2 " called with "; Prin2 Nargs; prin2T " args from compiled code"; Quit; End; % Some SYSLISP tools for debugging: syslsp procedure INF x; Inf x; syslsp procedure TAG x; TAG x; syslsp procedure MKITEM(x,y); MkItem(X,y); off syslisp; End; |
Added psl-1983/tests/stubs6.red version [fa43cad3ca].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % STUBS6.RED -Stubs introduced for TEST6 and up in "PT:mini-printf.red"$ in "PT:mini-top-loop.red"$ On syslisp; Procedure FUNCALL(FN,I); IDApply1(I,FN); off syslisp; procedure fluid u; print list ('nofluid, u); procedure global u; print list ('noglobal, u); END; |
Added psl-1983/tests/stubs7.red version [6b98bac22d].
> > > > > | 1 2 3 4 5 | % STUBS7.RED % none yet End; |
Added psl-1983/tests/stubs8.red version [1bbb597439].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % SYSTEM-GC.RED - System dependent before and after GC hooks % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 5 March 1982 % Copyright (c) 1982 University of Utah % % Do nothing on the Dec-20 on Syslisp; syslsp smacro procedure BeforeGCSystemHook(); NIL; syslsp smacro procedure AfterGCSystemHook(); NIL; off Syslisp; END; |
Added psl-1983/tests/stubs9.red version [6b98bac22d].
> > > > > | 1 2 3 4 5 | % STUBS7.RED % none yet End; |
Added psl-1983/tests/sub2.red version [a1446cce41].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % SUB2.RED - More comprehensive Mini I/O in "pt:mini-char-io.red"$ In "pt:mini-printers.red"$ In "pt:mini-error-errorset.red"$ In "pt:mini-error-handlers.red"$ In "pt:mini-type-errors.red"$ End; |
Added psl-1983/tests/sub3.red version [6972d0aa71].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | % SUB3.RED : Crude Mini Allocator and CONS In "pt:mini-allocators.red"$ In "pt:mini-cons-mkvect.red"$ in "pt:mini-comp-support.red"$ In "pt:mini-sequence.red"$ End; |
Added psl-1983/tests/sub4.init version [a7ffc6f8bf].
Added psl-1983/tests/sub4.red version [93b4af4c83].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % SUB4.RED - Mini RATOM and READ. Requires SUB3, SUB2 and IO % Note setting of DEBUG to get diagnostic output % Revisions: MLG, 18 Feb 1983 % ADD %..EOL as comment for test files in "pt:mini-equal.red"$ in "pt:mini-token.red"$ in "pt:mini-read.red"$ End; |
Added psl-1983/tests/sub5.red version [04e9a20127].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % SUB5.RED : EVAL and support functions % Needs SUB4, SUB3, SUB2, IO modules in "pt:p-function-primitives.red"$ in "pt:p-apply-lap.red"$ in "pt:mini-arithmetic.red"$ in "pt:mini-carcdr.red"$ in "pt:mini-easy-sl.red"$ in "pt:mini-easy-non-sl.red"$ in "pt:mini-eval-apply.red"$ in "pt:mini-known-to-comp.red"$ in "pt:mini-loop-macros.red"$ in "pt:mini-others-sl.red"$ in "pt:mini-oblist.red"$ in "pt:mini-property-list.red"$ in "pt:mini-symbol-values.red"$ in "pt:mini-type-conversions.red"$ off syslisp; end; |
Added psl-1983/tests/sub6.red version [2ad2b40c5f].
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 | % SUB6.RED - User defined LAMBDAs and BINDING, etc. in "pk:binding.red"$ in "pt:p-fast-binder.red"$ in "pt:mini-putd-getd.red"$ Procedure Reset(); <<Prin2T "Should RESET here, but will QUIT"; Quit;>>; End; |
Added psl-1983/tests/sub7.red version [a0d62b1bce].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | % SUB7.RED - Support and tests of File I/O % Will Also test BINARY I/O for FASL in "xxx-system-io.red"$ in "pt:io-data.red"$ In "pt:mini-io-errors.red"$ in "pt:mini-dskin.red"$ in "pt:mini-open-close.red"$ in "pt:mini-rds-wrs.red"$ in "pt:system-io.red"$ End; |
Added psl-1983/tests/system-io.red version [9529278456].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %============================================================================== % % SYSTEM-IO.RED - System independent IO routines for PSL % % Author: Modified by Robert R. Kessler % From System-io.red for the VAX by Eric Benson % Computer Science Dept. % University of Utah % Date: Modified 16 August 1982 % Original Date 16 September 1981 % % Copyright (c) 1982 University of Utah % %============================================================================== % Each individual system must have the following routines defined. % % The following definitions are used in the routines: % FileDescriptor - A machine dependent word that references a file once % opened; generated by the Open % FileName - A Lisp string of the file name. % % FileDescriptor := SysOpenRead (Channel,FileName); % % Open FileName for input and % % return a file descriptor used % % in later references to the % % file. Channel used only % % if needed to generate FileDesc % FileDescriptor := SysOpenWrite (Channel,FileName); % % Open FileName for output and % % return a file descriptor used % % in later references to the % % file. Channel used only % % if needed to generate FileDesc % SysWriteRec (FileDescriptor, StringToWrite, StringLength); % % Write StringLength characters % % from StringToWrite from the % % first position. % LengthRead := SysReadRec (FileDescriptor, StringBuffer); % % Read from the FileDescriptor, a % % record into the StringBuffer. % % Return the length of the % % string read. % SysClose (FileDescriptor); % Close FileDescriptor, allowing % % it to be reused. % TerminalInputHandler (FileDescriptor); % Input from the terminal, on % % FileDescriptor. This routine % % is expected to use the prompt % % in PromptString!*. % %============================================================================== CompileTime Load Fast!-Vector; global '(IN!* OUT!*); LoadTime << IN!* := 0; OUT!* := 1; >>; fluid '(StdIN!* StdOUT!* ErrOUT!* PromptOUT!* !*Echo); LoadTime << StdIN!* := 0; StdOUT!* := 1; ErrOUT!* := 5; PromptOUT!* := 6; >>; %============================================================================== % on SysLisp; % The channel table contains the actual file descriptor as returned from % the open routines. Since the file descriptor may be any value, it % may not be used in finding a free channel. Therefore, we now have a % warray ChannelStatus that is the current status of the channel. % NOTE: ChannelStatus must be initialized to all closed. % The following constants are used to indicate the status of the Channel. WConst ChannelClosed = 0, ChannelOpenRead = 1, ChannelOpenWrite = 2, ChannelOpenSpecial = 3; % Look into the ChannelStatus array for a free channel. syslsp procedure FindFreeChannel(); begin scalar Channel; Channel := 0; while ChannelStatus [Channel] neq ChannelClosed do << if Channel >= MaxChannels then IOError "No free channels left"; Channel := Channel + 1 >>; return Channel; end; CompileTime fluid '(IOBuffer); % Open the argument filename as a read only file. syslsp procedure SystemOpenFileForInput FileName; begin scalar Channel; Channel := FindFreeChannel(); ChannelTable [Channel] := SysOpenRead (Channel,FileName); ChannelStatus[Channel] := ChannelOpenRead; MaxBuffer [Channel] := SysMaxBuffer (ChannelTable [Channel]); ReadFunction [Channel] := 'IndependentReadChar; WriteFunction [Channel] := 'ReadOnlyChannel; CloseFunction [Channel] := 'IndependentCloseChannel; IGetV (LispVar IOBuffer, Channel) := MkString (MaxBuffer [Channel], 32); NextPosition [Channel] := 0; % Will be post Incremented BufferLength [Channel] := -1; return Channel; end; syslsp procedure SystemOpenFileForOutput FileName; begin scalar Channel; Channel := FindFreeChannel(); ChannelTable [Channel] := SysOpenWrite (Channel,FileName); ChannelStatus[Channel] := ChannelOpenWrite; MaxBuffer [Channel] := SysMaxBuffer (ChannelTable [Channel]); ReadFunction [Channel] := 'WriteOnlyChannel; WriteFunction [Channel] := 'IndependentWriteChar; CloseFunction [Channel] := 'IndependentCloseChannel; Igetv(LispVar IOBuffer,Channel) := MkString (MaxBuffer [Channel], 32); NextPosition [Channel] := -1; % Will be set pre-incremented BufferLength [Channel] := MaxBuffer [Channel]; return Channel; end; % Mark a channel as open for a special purpose. syslsp procedure SystemOpenFileSpecial FileName; begin scalar Channel; ChannelStatus [Channel] := ChannelOpenSpecial; return Channel end; syslsp procedure TestLegalChannel Channel; If not( PosIntP Channel and Channel <=MaxChannels) then IoError List(Channel," is not a legal channel "); % This function will read in a character from the buffer. It will read % the record on buffer length overflow only. Thus when an EOL character % is read, it is processed as any other character, except, if it is the last % one, in the record, it will do the read automatically. % Note, this will not read the next record until after the final character % has been processed. syslsp procedure IndependentReadChar Channel; begin scalar Chr; TestLegalChannel Channel; if NextPosition [Channel] > BufferLength [Channel] then << BufferLength [Channel] := SysReadRec (ChannelTable[Channel], IGetV(LispVar IOBuffer, Channel)); NextPosition [Channel] := 0 >>; Chr := StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition [Channel] := NextPosition [Channel] + 1; if LispVar !*Echo then WriteChar Chr; return Chr; end; % Write a character into the buffer. Actually dump the buffer when the % EOL character is found, or when the buffer is full. This happens % immediately upon meeting this condition, not waiting for the % next character. Note, that this places the EOL character into the % buffer for machine dependent treatment as CR/LF etc syslsp procedure IndependentWriteChar (Channel, Chr); Begin TestLegalChannel Channel; NextPosition [Channel] := NextPosition [Channel] + 1; StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]) := Chr; if (Chr eq char EOL) or (NextPosition [Channel] >= BufferLength [Channel]) then % 12/13/82 - rrk Placed code in FlushBuffer and added a call. FlushBuffer Channel; End; % 12/13/82 - rrk Added FlushBuffer procedure. % Flush out the buffer whether or not we have an EOL character. Procedure FlushBuffer Channel; << SysWriteRec (ChannelTable[Channel], IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition[Channel] :=-1 >>; % Start Fresh Buffer % Mark the argument channel as closed and update the read, write and % close functions likewise. Careful, if the caller does this first % and then trys to access a read, write or close function we are % in big trouble. Is it correct to do this????? Or is a marking of % the channel status table sufficient. syslsp procedure SystemMarkAsClosedChannel Channel; << TestLegalChannel Channel; ChannelStatus [Channel] := ChannelClosed; ReadFunction [Channel] := WriteFunction [Channel] := CloseFunction [Channel] := 'ChannelNotOpen >>; % Actually close the argument channel. syslsp procedure IndependentCloseChannel Channel; << TestLegalChannel Channel; SysClose ChannelTable [Channel]>>; % Initialize Channel Tables etc Syslsp procedure ClearOneChannel(Chn,Bufflen,How); << MaxBuffer [Chn] := Bufflen; NextPosition [Chn] := 0; % SAL - Next two not properly initialized. LinePosition [Chn] := 0; UnreadBuffer [Chn] := 0; If how eq 'Input then BufferLength [Chn] := -1 else BufferLength [Chn] := 0; IGetV (LispVar IOBuffer, Chn) := MkString(Bufflen,32)>>; syslsp procedure ClearIO(); << SysClearIo(); If not VectorP LispVar Iobuffer then <<LispVar IOBuffer := MkVect (MaxChannels); ClearOneChannel(LispVar StdIn!*,200,'Input); ClearOneChannel(LispVar StdOut!*,200,'Output); ClearOneChannel(LispVar ErrOut!*,200,'OutPut); ClearOneChannel(LispVar PromptOut!*,200,'Output)>>; LispVar IN!* := LispVar StdIN!*; LispVar OUT!* := LispVar StdOUT!* >>; syslsp procedure TerminalInputHandler Channel; begin scalar Chr; TestLegalChannel Channel; if NextPosition [Channel] > BufferLength [Channel] then << ChannelWriteString(LispVar PromptOUT!*, if StringP LispVar PromptString!* then LispVar PromptString!* else ">"); % 12/13/82 - rrk Flush out the Prompt character. FlushBuffer LispVar PromptOut!*; BufferLength [Channel] := SysReadRec (ChannelTable[Channel], IGetV (LispVar IOBuffer, Channel)); NextPosition [Channel] := 0 >>; Chr := StrByt (IGetV (LispVar IOBuffer, Channel), NextPosition [Channel]); NextPosition [Channel] := NextPosition [Channel] + 1; if LispVar !*Echo then WriteChar Chr; return Chr; end; off SysLisp; END; |
Added psl-1983/tests/test version [e713e948aa].
> > > | 1 2 3 | Line 1 Line 2 Line 3 (last) |
Added psl-1983/tests/test-guide.mss version [b05210375a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @Make(article) @device(LPT) @style(Spacing 1) @use(Bibliography "<griss.docs>mtlisp.bib") @modify(enumerate,numbered=<@a. @,@i. >, spread 1) @modify(itemize,spread 1) @modify(description,leftmargin +2.0 inch,indent -2.0 inch) @LibraryFile(PSLMacrosNames) @comment{ The logos and other fancy macros } @pageheading(Left "Utah Symbolic Computation Group", Right "July 1982", Line "Operating Note No. 71" ) @set(page=1) @newpage() @Begin(TitlePage) @begin(TitleBox) @center[ @b(The PSL Bootstrap Test Files) M. L. Griss, S. Lowder, E. Gibson, E. Benson, R. R. Kessler, and G. Q. Maguire Jr. Utah Symbolic Computation Group Computer Science Department University of Utah Salt Lake City, Utah 84112 (801)-581-5017 @value(date)] @end(TitleBox) @begin(abstract) This note describes how use a suite of tests designed to exhaustively exercise all facets of the PSL bootstrap sequence. Each test is a step towards boostrapping a complete mini-LISP and then complete PSL. @end(abstract) @begin(ResearchCredit) Work supported in part by the National Science Foundation under Grant No. MCS-8204247, and by Lawrence Livermore Laboratories under Subcontract No. 7752601. @end(ResearchCredit) @end(TitlePage) @pageheading(Left "PSL Testing", Right "Page @Value(Page)" ) @set(Page=1) @newpage() @section(Introduction) In order to accomplish the PSL bootstrap with a minimum of fuss, a carefully graded set of tests is being developed, to help pinpoint each error as rapidly as possible. This preliminary note describes the current status of the test files. The first phase requires the coding of an initial machine dependent I/O package and its testing using a familar system language. Then the code-generator macros can be succesively tested, making calls on this I/O package as needed. Following this is a series of graded SYSLISP files, each relying on the correct working of a large set of SYSLISP constructs. At the end of this sequence, a fairly complete "mini-LISP" is obtained. At last the complete PSL interpreter is bootstrapped, and a variety of PSL functional and timing tests are run. @section(Basic I/O Support) The test suite requires a package of I/O routines to read and print characters, and print integers. These support routines are usually written in a "foreign" language (call it "F"), such as PASCAL, C or FORTRAN; they could also be coded in LAP, using CMACROs to call operating system commands, if simple enough. (E.g., JSYS's on DEC-20, Traps on 68000, etc.). These routines typically are limited to using the user's terminal/console for input and output. Later steps in the bootstraping sequence introduce a more complete stream based I/O module, with file-IO. On some systems, it is appropriate to have a main routine written in "F" which initializes various things, and then calls the "LISP" entry point; on others, it is better to have "LISP" as the main routine, and have it call the initialization routines itself. In any event, it is best to first write a MAIN routine in "F", have it call a subroutine (called, say TEST), which then calls the basic I/O routines to test them. The documentation for the operating system should be consulted to determine the subroutine calling conventions. Often, the "F" compiler has an "ASSEMBLY Listing switch", which can be turned on to see how the standard "F" to "F" calling sequence is constructed, and to give some useful guidance to writing correct assembly code. This can also be misleading, if the assembler switch only shows part of the assembly code, thus the user is cautioned to examine both the code and the documentation. On directory PT: (which stands for /psl/tests or <PSL.TESTS>), or its subdirectories, we have a number of sample I/O packages, written in various languages: PASCAL, FORTRAN, C and DEC20 assembly code. Each has been used successfully with some PSL bootstrap. The primitives provided in these files are often named XXX-yyyy, where XXX is the machine name, and yyyy is the primitive, provided that these are legal symbols. Of course, the name XXX-yyyy may have to be changed to conform to "F" and the associated linker symbol conventions. Each name XXX-yyyy will be flagged as a "ForeignFunction", and called by a non-LISP convention. The following is a brief description of each primitive, and its use. For uniformity we assume each "foreign" primitive gets a single integer argument, which it may use, ignore, or change (VAR c:integer in PASCAL). @Comment{Is this assumed to be a WORD size quantity, i.e. on the 68000 a 32 bit quantity or can it be a small integer???} The following routines ("yyyy") in LISP, will be associated with the corresponding "foreign" routine "XXX-yyyy" in an appropriate way: @begin(description) init(C)@\Called once to set up I/O channels, open devices, print welcome message, initialize timer. Ignores the argument C. Quit()@\Called to terminate execution; may close all open files. C is ignored. PutC(C)@\C is the ASCII equivalent of a character, and is printed out without line termination (I/O buffering may be needed). C=EOL=10 (ASCII LF) @Comment{does this mean that the character should appear right away, or can it wait till the EOL is sent???} will be used to signal end-of-line, C=EOF=26 (ASCII SUB) will be used to signal end of file. GetC()@\Returns the ASCII equivalent of the next input character; C=EOL=10 for end of line, and C=EOF=26 for end of file. Note it is assumed that GetC does not echo the character. TimC()@\Returns the runtime since the start of this program, in milli-seconds, unless micro-seconds is more appropriate. For testing purposes this routine could also print out the time since last called. PutI(C)@\Print C as an integer, until a SYSLISP based Integer printer that calls XXX-PutC works. This function is used to print integers in the initial tests before the full I/O implementation is ready. Err(C)@\Called in test code if an error occurs, and prints C as an error number. It should then call Quit() . @end(description) As a simple test of these routines implement in "F" the following. Based on the "MainEntryPointName!*" set in XXX-ASM.RED, and the decision as to whether the Main toutine is in "F" or in "LISP", XXX-MAIN() is the main routine or first subroutine called: @begin(verbatim) % MAIN-ROUTINE: CALL XXX-INIT(0); CALL XXX-MAIN(0); CALL XXX-QUIT(0); % XXX-MAIN(DUMMY): INTEGER DUMMY,C; CALL XXX-PUTI(1); % Print a 1 for first test CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(2); % Second test CALL XXX-PUTC(65); % A capital "A" CALL XXX-PUTC(66); % A capital "B" CALL XXX-PUTC(97); % A lowercase "a" CALL XXX-PUTC(98); % A lowercase "b" CALL XXX-PUTC(10); % EOL to flush line CALL XXX-PUTI(3); % Third test, type in "AB<cr>" CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print A65 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTC(C); % Should print B66 CALL XXX-PUTI(C); CALL XXX-GETC(C); CALL XXX-PUTI(C); % should print 10 and EOL CALL XXX-PUTC(C); CALL XXX-PUTI(4); % Last Test CALL XXX-ERR(100); CALL XXX-PUTC(26); % EOF to flush buffer CALL XXX-QUIT(0); % END @end(verbatim) For examples, see PT20:20IO.MAC for DEC-20 version, PHP:HP.TEXT for HP9836 PASCAL version, PCR:shell for CRAY fortran version. @section(LAP and CMACRO Tests) After the basic XXX-ASM.RED file has been written and the XXX-CROSS.EXE has been built, and seems to be working, an exhastive set of CMACRO tests should be run. The emitted code should be carefully examined, and the XXX-CMAC.SL adjusted as seems necessary. Part of the CMACRO tests are to ensure that !*MOVEs in and out of the registers, and the ForeignFunction calling mechanism work. @section(SysLisp Tests) This set of tests involve the compilation to target assmbly code, the linking and execution of a series of increasingly more complex tests. The tests are organized as a set of modules, called by a main driver. Two of these files are machine dependent, associating convenient LISP names and calling conventions with the "Foreign" XXX-yyyy function, define basic data-spaces, define external definitions of them for inclusion, and also provide the appropriate MAIN routine, if needed. These files should probably be put on a separte subdirectory of PT: (e.g., PT20:, PT68:, etc.) The machine dependent files are: @begin(description) XXX-HEADER.RED@\Is a machine dependent "main" include file, read into each MAINn.RED file, to define the data-spaces needed, and perhaps define a main routine in LAP, and have the appropriate XXX-MAIN call the "FirstCall" function, used to start the body of the test. Also included are the interface routines to the "F" coded I/O package. providing a set of LISP entry-points to the XXX-yyy functions. This should be copied and edited for the new target machine as needed. Notice that in most cases, it simply defines "procedure yyyy(x); XXX-yyyy(x);", relying on "ForeignFunction" declaration of XXX-yyyy. Notice that "UndefinedFunction" is defined in LAP, to call Err, as appropriate. This will trap some erroneous calls, since a call to it is planted in all "unused" SYMFNC cells. Some effort to make it pick up the ID number of the offending undefined function (by carefully choosing the instructions to be planted in the function cell), will be a great help. Once coded and tested by running MAIN1, it need not be changed for the subsequent MAINn/SUBn combinations to work. XXX-TEST-GLOBAL-DATA.RED@\This contains a series of external declarations to correspond to the Global Data definitions in the above header file file. It is automatically included in all but the MAINn module via the "GlobalDataFileName!*" option of XXX-ASM.RED. @end(description) The machine independent test files and drivers are: @begin(description) MAIN1.RED@\Is a very simple driver, that calls Getc and Putc, does a few tests. It does an 'IN "XXX-HEADER.RED";'. The "FirstCall" procedure then calls "init", uses "putc" to print AB on one line. It should then print factorial 10, and some timings for 1000 calls on Factorial 9 and Tak(18,12,6). Build by iteself, and run with IO. @Comment{This seems to hide the assumption that 10! can be done in the integer size of the test implementation.??? } SUB2.RED@\Defines a simple print function, to print ID's, Integer's, Strings and Dotted pairs in terms of repeated calls on PutC. Defines TERPRI, PRIN1, PRIN2, PRINT, PRIN2T and a few other auxilliary print functions used in other tests. Tries to print "nice" list notation. MAIN2.RED@\Uses Prin2String to print a welcome message, solicit a sequence of characters to be input, terminated by "#". Watch how end-of-line is handled. Then Print is called, to check that TAG's are correctly recognized, by printing a LISP integer, an ID and 2 dotted pairs. Requires SUB2 and IO modules. SUB3.RED@\Defines a mini-allocator, with the functions CONS, XCONS and NCONS, GTHEAP, GTSTR. Requires primitives in SUB2 module. MAIN3.RED@\First Executes a Casetest, trying a variety of Branches and Defaults in the case staement. There a number of calls on Ctest with an integer from -1 to 12; Ctest tries to classify its argument using a case statement. ConsTest simply calls the mini-allocator version of CONS to build up a list and then prints it. Requires SUB2, SUB3 and IO modules. SUB4.RED@\Defines a mini-reader, with RATOM and READ. This mini-READ does not read vectors, and does not know about the escape character, ! . Requires SUB3, SUB2, and IO modules. MAIN4.RED@\The test loop calls RATOM, printing the internal representation of each token. Type in a series of id's, integer's, string'ss etc. Watch that same ID goes to same place. After typing a Q, goes into a READ-PRINT loop, until Q is again input. Requires SUB3, SUB2 and IO modules. SUB5.RED@\Defines a mini-EVAL. Does not permit user define functions. Can eval ID's, numbers, and simple forms. No LAMBDA expressions. FEXPR Functions known are: QUOTE, SETQ and LIST. Can call any compiled EXPR, with upto 4 arguments. Rather inefficient, but could be used for quick bootstrap. Requires SUB4, SUB3, SUB2 and I/O. MAIN5.RED@\Tests the IDAPPLY constructs, and FUNBOUNDP. Then starts a mini-READ-EVAL-PRINT loop. Requires SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are not case raised, so input should be in UPPERCASE for builtin functions. Terminates on Q input. SUB6.RED@\Defines a more extensive set of primitives to support the mini-EVAL, including LAMBDA expressions, and user defined EXPR and FEXPR functions. Can call any compiled EXPR, with up to 4 arguments. COND, WHILE, etc. are defined. Requires SUB5, SUB4, SUB3, SUB2 and I/O. MAIN6.RED@\Tests the full PSL BINDING module (PI:BINDING.RED). Also includes the standard PSL-TIMER.RED (describd below), which must be driven by hand, since file I/O is not yet present. Requires SUB6,SUB5, SUB4, SUB3, SUB2 and IO modules. Note that input ID's are not case raised, so input should be in UPPERCASE for builtin functions. Terminates on Q input. SUB7.RED@\A set of routines to define a minimal file-io package, loading the machine independent files: PT:SYSTEM-IO.RED and PT:IO-DATA.RED, and a machine dependent file XXX-SYSTEM-IO.RED. The latter file defines primitives to OPEN and CLOSE files, and read and write RECORDS of some size. The following definitions are used in the routines: @begin(verbatim) FileDescriptor: A machine dependent word to references an open file. FileName: A Lisp string @end(verbatim) @begin(description) SYSCLEARIO()@\Called by Cleario to do any machine specific initialization needed, such as clearing buffers, initialization tables, setting interrupt characters, etc. SysOpenRead(Channel,FileName)@\Open FileName for input and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysOpenWrite(Channel,FileName)@\Open FileName for Output and return a file descriptor used in later references to the file. Channel may be used to index a table of "unit" numbers in FORTRAN-like systems. SysReadRec(FileDescriptor,StringBuffer)@\Read from the FileDescriptor, a record into the StringBuffer. Return the length of the string read. SysWriteRec (FileDescriptor, StringToWrite, StringLength)@\ StringLength characters from StringToWrite from the first position. SysClose (FileDescriptor)@\Close FileDescriptor, allowing it to be reused. SysMaxBuffer(FileDesc)@\Return a number to allocate the file-buffer as a string; this should be maximum for this descriptor. @end(description) MAIN7.RED@\Is an interface to the Mini-Eval in SUB5.RED and SUB6.RED and defines an (IOTEST) function that should be called. Other functions to try are (OPEN "foo" 'OUTPUT), (WRS n), (RDS n) etc. Note also that XXX-HEADER will have to be changed at this point to have GETC and PUTC use the IndependentReadChar and IndependentWriteChar. FIELD.RED@\A a set of extensive tests of the Field and Shift functions. Needs a WCONST BitsPerWord defined in XXX-HEADER.RED. Build by itself, and execute with the IO support. @end(description) Test set "n" is run by using a set of command files to set up a multi-module program. These files are stored on the approriate subdirectory (PT20: for the DEC20). Note that each module usually produces 2-3 files ("code", "data" and "init") @begin(Enumerate) First Connect to the Test subdirectory for XXX: @verbatim[ @@CONN PTxxx:] Then initialize a fresh symbol table for program MAINn, MAINn.SYM: @verbatim[ @@MIC FRESH MAINn] Now successively compile each module, SUB2..SUBn @verbatim[ @@MIC MODULE SUB2,MAINn @@MIC MODULE SUB3,MAINn @@MIC MODULE SUBn,MAINn] Now compile the MAIN program itself @verbatim[ @@MIC MAIN MAINn] As appropriate, compile or assemble the output "F" language modules (after shipping to the remote machine, removing tabs, etc..). Then "link" the modules, with the XXX-IO support, and execute. On the DEC-20, the @verbatim[ @@EX @@MAINn.CMD command files are provided as a guide] See the Appendix (file PT20:20-TEST.OUTPUT) for an example of the output on the DEC-20. @end(enumerate) @section(Mini PSL Tests) The next step is to start incorporating portions of the PSL kernel into the test series (the "full" Printer, the "full" reader, the "full" Allocator, the "full" Eval, etc.), driving each with more comprehensive tests. Most of these should just "immediately" run. There some peices of Machine specific code that have to be written (in LAP or SYSLISP), to do channel I/O, replacing the simple XXX-IO; to do fast APPLY; Fluid Binding and Arithmetic. This set of tests will help check these peices out before getting involved with large files. @section(Full PSL Tests) Now that PSL seems to be running, a spectrum of functional tests and timing tests should be run to catch any oversights, missing modules or bugs, and as a guide to optimization. The following tests exist: @Description[ PSLTEST.SL@\A fairly comprehensive test of the Standard LISP subset of PSL. Do (DSKIN "pt:psltest.sl"). There are a few tests of the error mechanism that have to be "pushed" through for a full test. MATHLIB.TST@\A series of tests of MATHLIB. First LAOD MATHLIB; into RLISP, then do IN "MATHLIB.TST"; . PSL-TIMER.SL, TIME-PSL.SL@\A standard timimg test covering PSL basics. Compile PSL-TIMER.SL into kernel, or with resident compiler, then (LAPIN "PT:TIME-PSL.TEST"). ] @section(References) @bibliography @NewPage() @appendix(Sample DEC-20 Output) @begin(verbatim) @include(PT20:20-TEST.OUTPUT) @end(verbatim) |
Added psl-1983/tests/test-guide.otl version [19f5403831].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | @Comment{OUTLINE of TEST-GUIDE.MSS.32 by Scribe 3C(1254) on 22 August 1982 at 08:54} 1. Introduction 1 TEST-GUIDE.MSS.32 line 54 2. Basic I/O Support 1 TEST-GUIDE.MSS.32 line 67 3. LAP and CMACRO Tests 4 TEST-GUIDE.MSS.32 line 184 4. SysLisp Tests 4 TEST-GUIDE.MSS.32 line 192 5. Mini PSL Tests 10 TEST-GUIDE.MSS.32 line 375 6. Full PSL Tests 10 TEST-GUIDE.MSS.32 line 386 7. References 10 TEST-GUIDE.MSS.32 line 402 I. Sample DEC-20 Output 11 TEST-GUIDE.MSS.32 line 405 Table of Contents 1 -SCRIBE-SCRATCH-.15-5-1.100015 line 3 |
Added psl-1983/tests/time-psl.sl version [06e9ed4ee1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % TIME-PSL.SL Driver of PSL "spectral" tests % After loading psl-timer.b, LAPIN this file (wrs (open "time-psl.out" 'output)) (prin2 "PSL Spectral Tests, ") (prin2 (versionname)) (prin2 ", ") (prin2T (date)) (prin2t "---------------------------------------------------------------") (TestSetup) (progn (reclaim) (prin2 "EmptyTest 10000 ") (print (TimeEval '(EmptyTest 10000))) 0) (progn (prin2 "SlowEmptyTest 10000 ") (print (TimeEval '(SlowEmptyTest 10000))) 0) (progn (prin2 "Cdr1Test 100 ") (print (TimeEval '(Cdr1Test 100))) 0) (progn (prin2 "Cdr2Test 100 ") (print (TimeEval '(Cdr2Test 100))) 0) (progn (prin2 "CddrTest 100 ") (print (TimeEval '(CddrTest 100))) 0) (progn (prin2 "ListOnlyCdrTest1 ") (print (TimeEval '(ListOnlyCdrTest1))) 0) (progn (prin2 "ListOnlyCddrTest1 ") (print (TimeEval '(ListOnlyCddrTest1))) 0) (progn (prin2 "ListOnlyCdrTest2 ") (print (TimeEval '(ListOnlyCdrTest2))) 0) (progn (prin2 "ListOnlyCddrTest2 ") (print (TimeEval '(ListOnlyCddrTest2))) 0) (progn (prin2 "ReverseTest 10 ") (print (TimeEval '(ReverseTest 10))) 0) (progn (reclaim) (prin2 "MyReverse1Test 10 ") (print (TimeEval '(MyReverse1Test 10))) 0) (progn (reclaim) (prin2 "MyReverse2Test 10 ") (print (TimeEval '(MyReverse2Test 10))) 0) (progn (reclaim) (prin2 "LengthTest 100 ") (print (TimeEval '(LengthTest 100))) 0) (progn (prin2 "ArithmeticTest 10000 ") (print (TimeEval '(ArithmeticTest 10000))) 0) (progn (prin2 "EvalTest 10000 ") (print (TimeEval '(EvalTest 10000))) 0) (progn (prin2 "tak 18 12 6 ") (print (TimeEval '(topleveltak 18 12 6))) 0) (progn (prin2 "gtak 18 12 6 ") (print (TimeEval '(toplevelgtak 18 12 6))) 0) (progn (prin2 "gtsta g0 ") (print (TimeEval '(gtsta 'g0))) 0) (progn (prin2 "gtsta g1 ") (print (TimeEval '(gtsta 'g1))) 0) (close (wrs NIL)) |
Added psl-1983/tests/timer.notes version [64ea57788d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Some notes on the PSL "spectral" timing Tests Martin L. Griss March 17 1982 The tests in the file PT:PSL-TIMER.SL (which is compiled and then driven by calls in PT:TIME-PSL.SL) have been gathered by us, with assistance/requests/suggestions from Fateman and Foderaro at Berkeley, JONL White and George Charrette at MIT, and Gabriel at Stanford as part of hist tests for the analysis of different LISP systems. They range over a number of LISP fundamentals, such as function calling speed, compiler quality, simple EVAL speed, INUM/FIXNUM arithmetic, CAR/CDR speeds, CONS speed, Type-testing predicates, etc. In most cases, the times quoted are for N iterations of some basic loop, with N fixed at some convenient quantity; the current N is given. The tests first set up some lists, which are then used for CDR'ing and counting loops. These are: LONGLIST 1664 elements TESTLIST 1002 elements TESTLIST2 2002 elements TEST N Description and comments Empty 10k Fastest Empty loop, using INUM or FIXNUM arithmetic as measure of overhead. SlowEmpty 10k Empty loop using generic arithmetic, usually much slower than Empty because of subroutine call. The loop indices are still in INUM range, and some implementations may opencode part of the arithmetic. Cdr1 100 Cdr down LONGLIST N times, using ATOM to terminate. The loop is done using INUM arithmetic If there is no INUM/FIXNUM arithmetic, this time is swamped by arithmetic time. In PSL, ATOM test requires TAG extraction, while NULL test is just an EQ with NIL. In some implementations CAR and CDR require the TAG to be masked off with an extra instruction, while in others the hardware ignores the tag field in addressing operations, speed this up. Cdr2 100 Cdr down LONGLIST N times, using NULL to terminate. Compare with CDR1 tests. Cddr 100 Cddr down LONGLIST N times, using NULL to terminate Note that some time CDDR is done better than just CDR since addressing modes may help. ListOnlyCdr1 Cdr down TESTLIST, length TESTLIST times, using NULL These LISTONLY... tests do not use arithmetic to loop. ListOnlyCddr Cddr down TESTLIST, length TESTLIST times, using NULL ListOnlyCdr2 Cdr down TESTLIST, length TESTLIST, using ATOM This does not use arithmetic to loop. ListOnlyCddr Cddr down TESTLIST2, length TESTLIST times, using ATOM. Reverse 10 Call system reverse on LONGLIST, N times. This CONS's a lot, also some SYSTEM reverse's handcoded, e.g. LISP 1.6. MyReverse1 10 Reverse compiled, using ATOM to terminate MyReverse2 10 Reverse compiled, using NULL to terminate Length 100 Built-in length, on LONGLIST. Arithmetic 10k Call FACTORIAL 9, N times, generic arithmetic. Looping as in EMPTYtest. Eval 10k EVAL EvalForm N times. EvalForm is (SETQ FOO (CADR '(1 2 3))) . tak 18 12 6 Gabriel's test function that has been used on MANY LISP systems. Using INUM/FIXNUM arithmetic. gtak 18 12 6 As above, using Generic arithmetic. gtsta g0 Charrete's FUNCALL/APPLY test. 100000 loops on (APPLY F (list I)) or (FUNCALL F I), whichever exists and is fastest in system. [PSL converts (APPLY F (list I)) into a fast-apply]. g0 is a NOOP. gtsta g1 g1 calls ADD1 |
Added psl-1983/tests/todo.txt version [84cd6de33f].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | Improvement to Test Series and Boot Sequence Start using the LinkReg in Link, LinkE [See PT20:dec20-patches.sl] Improve portability of FUNCTION-PRIMITIVES.RED [See TEST-FUNCTION-PRIMITIVES, using *JCALL for all. Maybe go to SYMFNC=ADDRESS table ?] May need to add a new CMACRO or two, or expand CMACRO's, to permit indirect JUMP via a register/location, to define CodePrimitive(). Modify TEST5 and TEST6 to use the various portable APPLY etc. Add BINARY IO tests to I/O. Perhaps as a file of LAP to read in? Define a FASLIN/FASLOUT tester. |
Added psl-1983/tests/write-real-in-psl.red version [a0d04daf63].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % WRITE-REAL.RED - Procedure to write a floating point number % Author: Martin Griss % Date: ~July 1982. % Notes by Maguire on 27.7.82: % Original version will use ~18K bytes for it's tables on the Apollo % due to the large exponent allowed. % See the common lisp manual, for names for base-B operations; % and constants for a re-write of this, to handle rounding etc. % Algorithm: By searching a table of powers of 10, previously % set up in a vector, determine % the Exponent and Mantissa of the given Float. % Then convert the mantissa to a pair of integers % and finally assembly the printed form as a string Fluid '(FltZero!* % Representation of 0.0 FltTen!* % 10.0 FltExponents % vector of (10^n) MinFltExponent % range of Exponents in table MaxFltExponent MaxFlt MinFlt MaxFltDigits % Maximum number of digits of precision FltDigits % Digits 0.0 ... 9.0 ); Procedure InitWriteFloats(MinEx,MaxEx,NDig); % Declare Maximum Number of Exponents and Digits Begin scalar Flt1,Flt!.1; FltZero!* := Float(0); Flt1 := Float(1); FltTen!* :=Float(10); Flt!.1 := Flt1/FltTen!*; MinFltExponent :=MinEx; MaxFltExponent:=MaxEx; NumberOfExponents := MaxEx-MinEx; % For UpLim on vector. MaxFltDigits:=Ndig; FltDigits:=MkVect 9; For I:=0:9 do FltDigits[I]:=Float I; FltExponents:=MkVect(NumberOfExponents); FltExponents[-MinEx]:=Flt1; FltExponents[1-Minex]:=FltTen!*; FltExponents[-1-Minex]:=Flt!.1; For i:=2-Minex:NumberOfExponents do FltExponents[i] := FltTen!* * FltExponents[i-1]; For i:=-2-MinEx Step -1 Until 0 do FltExponents[i] := Flt!.1 * FltExponents[i+1]; MinFlt := FltExponents[0]; MaxFlt := FltExponents[NumberOfExponents]; end; InitWriteFloats(-10,10,10); Procedure FindExponent(Flt); % return Exponent as Integer % First reduce Flt to table range then search. % Should Be Primitive, and done in Appropriate Float Base (2, or 16?) If Flt=FltZero!* then 0 else if Flt <FltZero!* then FindExponent(-Flt) else Begin scalar N; If Flt >= MaxFlt then return(MaxFltExponent+FindExponent(Flt/MaxFlt)); If Flt <= MinFlt then return(MinFltExponent+FindExponent(Flt/MinFlt)); N:=0; While N < NumberOfExponents and FltExponents[N] < Flt do N:=N+1; Return (N+MinFltExponent); End; Procedure FindMantissa(Flt); % return Mantissa as a (signed)float in [0.0 ..1.0) Flt/FloatPower10(FindExponent(Flt)); Procedure FloatPower10(n); % Returns 1FltZero!*^n, using table If N>MaxFltExponent then MaxFlt*FloatPower10(n-MaxFltExponent) else if N<MinFltExponent then MinFlt*FloatPower10(n-MinFltExponent) else FltExponents[n-MinFltExponent]; Procedure Flt2String(Flt); ScaledFloat2String(Flt,MaxFltDigits,0,-3,3); Procedure ScaledFloat2String(Flt,Ndigits,Scale, MinNice,MaxNice); % "print" a float, either in IIII.FFFF format, or SS.FFFFFeN % First format, if MinNice <=N<=MaxNice % ss controlled by Scale if second chosen % Begin Scalar Fsign,Fex,Fdigits,K,N,Flist,Ilist; If Flt = FltZero!* then return "0.0"; If Flt < FltZero!* then <<Fsign:='T; Flt:=-Flt>>; Fex:=FindExponent(Flt); Flt:=Flt/FloatPower10(Fex); % Ie, FindMantissa % At this point, % FEX is an integer % and 0.0 =< Flt <1.0 % Now we can move the Point and adjust the Exponent by a scale % factor for "nicety", or to eliminate En If Fex>=MinNice and Fex<=maxNice then <<Flt:=Flt*FloatPower10(Fex); Fex:=0>> else if scale neq 0 then <<Flt:=Flt*FloatPower10(Scale); Fex:=Fex-Scale>>; % Remove and convert the Integer Part (0 if scale=0 and not-nice). Ilist:=Fix(Flt); Flt:=Flt-Float(Ilist); If Fsign then Ilist:=-Ilist; Ilist:=Char('!.) . Reverse Int2List Ilist; % Reverse % Start shifting off digits in fraction by multiplying by 10 % Also Round here. % Should we adjust Ndigits if "nice/scale" ?? Flist:=Ilist; % Add in fraction digits, remember point for trailing % Zero Removal For K:=1:NDigits do << Flt := Flt * FltTen!*; N:=Fix(Flt); Flt:=Flt-FltDigits[N]; Flist := (N + Char '0) . Flist; >>; % Truncate excess trailing 0's While PairP Flist and Not (Cdr Flist eq Ilist) and Car(Flist)=Char '0 do Flist:=cdr Flist; % Now Optimize format, omitting En if 0 If Fex=0 then Return List2String Reverse Flist; % Now convert the Exponent and Insert Fex:=Int2List Fex; Flist := Char('E) . Flist; % The "E" For each x in Fex do Flist:= x . Flist; Return List2String Reverse Flist; end; procedure Int2String N; % Convert signed integer into a string List2String Int2List N; Procedure Int2List N; % Return "exploded" number, forward order Begin scalar L,Nsign; If N=0 then return List Char '0; If N<0 then <<N := -N; Nsign :=T>>; While N>0 do <<L := (Remainder(N,10) + Char '!0 ) . L; N := N / 10>>; If Nsign then L := Char('!-) . L; Return L; End; %Syslsp Procedure WriteFloat(Buffer,Fbase); % Buffer is Wstring[0..40], % Fbase is FloatBase FltInf Flt % Begin Scalar s,flt,i,ss; % flt := MKFLTN (Fbase-4); %/4 or 1 % s:=Flt2String flt; % ss:=strinf(s); % i:=strlen(ss); % strlen(Buffer):=i; % i:=i+1; % while i>=0 do <<strbyt(Buffer,i) := StrByt(ss,i); % i:=i-1>>; % end; End; |
Added psl-1983/util/-file-notes.txt version [1600b42639].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NOTES ON THE FILES IN PU: Cris Perdue 12/17/82 ------------------- PACKAGES BY LOCAL AUTHORS File Author Synopsis ---------------------------------------------------------------------------- extended-char.sl AS 9-bit characters, notably "x-char" fast-int.sl AS In lieu of declarations fast-strings.sl AS In lieu of declarations fast-vectors.sl AS In lieu of declarations format.red Benson Subset of Common LISP "format" hash.sl Perdue General hash table pkg. history.sl Lanam Fancy user-level history pkg. if.sl Perdue Fancy if-then-else compatible w. "if" man.sl Perdue Experimental ref. manual browser objects.sl AS Subset of "flavors" program-command-interpreter.sl AS pslcomp-main.sl AS ring-buffer.sl AS slow-strings.sl AS In lieu of declarations slow-vectors.sl AS In lieu of declarations string-input.sl Perdue Fns. for input from strings, e.g. READ string-search.sl Perdue Functions for searching in strings stringx.sl AS Miscellaneous string functions util.sl Nancy K Miscellaneous useful functions "WELL-KNOWN" FILES The following files implement facilities described in the reference manual, except for a few exceptions. BUILD.MIC is a support file to aid building of modules in PU:. It is in PU: for the system maintainer's convenience. Other exceptions are cryptically noted by mention of the logical name of the directory they appear to belong in. addr2id.sl pnk (autoload) backquote.sl In the USEFUL library bigbig.red bigface.red bind-macros.sl In the USEFUL library build.mic support for rebuilding modules build.red chars.lsp part of strings clcomp1.sl incompatible common lisp fns + reader common.sl cond-macros.sl In the USEFUL library debug.red defstruct.examples-red defstruct defstruct.red demo-defstruct.red defstruct destructure.sl evalhook.lsp used by step fast-struct.lsp ??? fast-vector.red filedate.mic p20sup find.red for-macro.sl graph-tree.sl gsort.red hcons.sl help.red pnk? if-system.red pnk? init-file.sl pnk? => bare-psl iter-macros.sl kernel.sl psup macroexpand.sl mathlib.red mini.demo mini.fix mini.min mini.red mini.sl mini-patch.red misc-macros.sl nstruct.ctl nstruct.lsp package.red pathin.sl pc? pr-driv.red pr-main.red pr2d-driv.red pr2d-main.red pr2d-text.red prettyprint.sl prlisp.demo prlisp-driver.red psl-cref.red psl-crefio.red read-macros.sl read-utils.red change to read-table-utils? rlisp-parser.red rlisp-support.red rprint.red set-macros.sl step.lsp strings.lsp struct.initial bootstrap for nstruct sysbuild.mic like build, but to connected directory test-arith.red generates pl:arith.b for use in big. useful.ctl vector-fix.red pnk -- document this! zbasic.lsp used by zpedit zboot.lsp used by zpedit zmacro.lsp used by zpedit zpedit.lsp "LESS WELL-KNOWN FILES" The following files are also in PU:, but without documentation that appears in the reference manual. Some have documentation in a file on PH:, some have documentation included in the source file, some have no documentation. association.sl f-dstruct.red inspect.red inum.red loop.lsp parse-command-string.sl pathnamex.sl pcheck.red poly.red zfiles.lsp Obsolete zsys.lsp Obsolete "MARTIN GRISS'S FILES" The following are thought to be creations of Martin Griss and we need to talk with him about whether or not they belong in PU:. datetime.red parser-fix.red sm.red |
Added psl-1983/util/addr2id.build version [1211fa62ca].
> | 1 | in "addr2id.sl"$ |
Added psl-1983/util/addr2id.sl version [c51be0ad85].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ADDR2ID.RED - Attempt to find out what function an address is in % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 May 1982 % Copyright (c) 1982 University of Utah % (compiletime (load syslisp useful)) (compiletime (fluid '(code-address* closest-address* closest-symbol*))) (de code-address-to-symbol (code-address*) (let ((closest-symbol* ()) (closest-address* 0)) (mapobl #'(lambda (symbol) (when (fcodep symbol) (let ((address (inf (getfcodepointer symbol)))) (when (and (ileq address code-address*) (igreaterp address closest-address*)) (setq closest-address* address) (setq closest-symbol* symbol)))))) closest-symbol*)) |
Added psl-1983/util/arith.build version [4c37efbac7].
> > | 1 2 | CompileTime load Syslisp; in "test-arith.red"$ |
Added psl-1983/util/association.sl version [086f16caf9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Association.SL - Mutable Association Lists % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 21 July 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common)) (defun association-create () % Create an empty association list (that is mutable!). (list (cons '*DUMMY* '*DUMMY*))) (defun association-bind (alist indicator value) % Change or extend the ALIST to map INDICATOR to VALUE. (let ((pair (atsoc indicator alist))) (if pair (rplacd pair value) % ELSE (aconc alist (cons indicator value)) (setq pair (car alist)) (if (and (eq (car pair) '*DUMMY*) (eq (cdr pair) '*DUMMY*)) (progn (rplacw pair (cadr alist)) (rplacd alist (cddr alist))) ) ))) (defun association-lookup (alist indicator) % Return the value attached to the given indicator (using EQ for % comparing indicators). If there is no attached value, return NIL. (let ((pair (atsoc indicator alist))) (if pair (cdr pair) NIL))) (defmacro map-over-association ((alist indicator-var value-var) . body) % Execute the body once for each indicator in the alist, binding % the specified indicator-var to the indicator and the specified % value-var to the attached value. Return the result of the body % (implicit PROGN). `(for (in ***PAIR*** ,alist) (with ***RESULT***) (do (let ((,indicator-var (car ***PAIR***)) (,value-var (cdr ***PAIR***)) ) (cond ((not (eq ,indicator-var '*DUMMY*)) (setf ***RESULT*** (progn ,@body)) )))) (returns ***RESULT***) )) |
Added psl-1983/util/backquote.sl version [34bbc4e7f6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BACKQUOTE.SL - tool for building partially quoted lists % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % Backquote is similar to MACLISP's ` (that's backwards!) mechanism. In % essence the body of the backquote is quoted, except for those things % surrounded by unquote, which are evaluated at macro expansion time. UNQUOTEL % splices in a list, and unquoted splices in a list destructively. Mostly % useful for defining macro's. (dm backquote (u) (backquote-form (cadr u))) (de backquote-form (u) (cond ((vectorp u) (backquote-vector u)) ((atom u) (cond ((and (idp u) (not (memq u '(t nil)))) (mkquote u)) (t u))) ((eq (car u) 'unquote) (cadr u)) ((eq (car u) 'backquote) (backquote-form (backquote-form (cadr u)))) ((memq (car u) '(unquotel unquoted)) (ContinuableError 99 (BldMsg "%r can't be spliced in here." u)) u) ((eqcar (car u) 'unquotel) (cond ((cdr u) (list 'append (cadar u) (backquote-form (cdr u)))) (t (cadar u)))) ((eqcar (car u) 'unquoted) (cond ((cdr u) (list 'nconc (cadar u) (backquote-form (cdr u)))) (t (cadar u)))) (t (backquote-list u)))) (de backquote-vector (u) ((lambda (n rslt all-quoted) % can't use LET 'cause it ain't defined yet ((lambda (i) (while (not (minusp i)) % can't use FOR or DO for the same reason ((lambda (x) (setq all-quoted (and all-quoted (backquote-constantp x))) (setq rslt (cons x rslt))) (backquote-form (getv u i))) (setq i (sub1 i)))) n) (cond (all-quoted ((lambda (i vec) (while (not (greaterp i n)) (putv vec i (backquote-constant-value (car rslt))) (setq rslt (cdr rslt)) (setq i (add1 i))) vec) 0 (mkvect n))) (t (cons 'vector rslt)))) (upbv u) nil t)) (de backquote-list (u) ((lambda (car-u cdr-u) % can't use LET 'cause it ain't defined yet (cond ((null cdr-u) (cond ((backquote-constantp car-u) (list 'quoted-list (backquote-constant-value car-u))) (t (list 'list car-u)))) ((constantp cdr-u) (cond ((backquote-constantp car-u) (list 'quoted-list* (backquote-constant-value car-u) cdr-u)) (t (list 'list* car-u cdr-u)))) ((and (pairp cdr-u) (memq (car cdr-u) '(list list*))) (cons (car cdr-u) (cons car-u (cdr cdr-u)))) ((and (pairp cdr-u) (memq (car cdr-u) '(quoted-list quoted-list*))) (cond ((backquote-constantp car-u) (cons (car cdr-u) (cons (backquote-constant-value car-u) (cdr cdr-u)))) (t (list 'list* car-u (mkquote (backquote-constant-value cdr-u)))))) ((eqcar cdr-u 'quote) (cond ((backquote-constantp car-u) (list 'quoted-list* (backquote-constant-value car-u) (cadr cdr-u))) (t (list 'list* car-u cdr-u)))) (t (list 'list* car-u cdr-u)))) (backquote-form (car u)) (backquote-form (cdr u)))) (de backquote-constantp (u) (cond ((pairp u) (memq (car u) '(quote quoted-list quoted-list*))) (t (not (idp u))))) (de backquote-constant-value (x) (cond ((eqcar x 'quote) (cadr x)) ((eqcar x 'quoted-list) (cdr x)) ((eqcar x 'quoted-list*) (cadr (apply 'quoted-list* (list x)))) (t x))) % The following, while possibly useful in themselves, are mostly included % for use by backquote and friends. (dm quoted-list (u) (mkquote (cdr u))) (dm list* (u) (expand (cdr u) 'cons)) (dm quoted-list* (u) (cond ((pairp (cdr u)) (setq u (reverse (cdr u))) ((lambda (a) (foreach elem in (cdr u) do (setq a (cons elem a))) (mkquote a)) (car u))))) % (t (error ... ? % Since unquote and friends should be completely stripped out by backquote, % make it an error to try and evaluate them. These could be much better... (dm unquote (u) (ContinuableError 99 (BldMsg "%r is not within backquote." u) u)) (copyd 'unquotel 'unquote) (copyd 'unquoted 'unquote) |
Added psl-1983/util/bigbig.build version [604e1ff956].
> > > > > > > > | 1 2 3 4 5 6 7 8 | % MLG, move BUILD info imports '(vector!-fix arith); Compiletime<<load syslisp; Load Fast!-Vector; load inum; load if!-system>>; in "bigbig.red"$ |
Added psl-1983/util/bigbig.red version [bb94f11108].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % BIGBIG.RED - Vector based BIGNUM package with INUM operations % M. L. Griss & B Morrison % 25 June 1982. % % Revision log: % 20 Dec: % MLG, changed TrimBigNUM to TrimBigNum1 in BhardDivide % 14 Dec: % Changed by MLG to put LOAD and IMPORTS in BUILD file % A. C . Norman - adjstments to many routines! % in particular corrections to BHardDivide (case D6 utterly wrong), % and adjustments to BExpt (for performance) and all logical % operators (for treatment of negative inputs); % 31 August 1982: % Copyright (C) 1982, A. C. Norman, B. Morrison, M. Griss % --------------------------------------------------------------- % ----------------------- % A bignum will be a VECTOR of Bigits: (digits in base BigBase): % [BIGPOS b1 ... bn] or [BIGNEG b1 ... bn]. BigZero is thus [BIGPOS] % All numbers are positive, with BIGNEG as 0 element to indicate negatives. Fluid '(BBase!* BBits!* LogicalBits!* WordHi!* WordLow!* Digit2Letter!* FloatHi!* FloatLow!* SysHi!* SysLo!* Carry!* OutputBase!*); % -------------------------------------------------------------------------- % -------------------------------------------------------------------------- % Support functions: % % U, V, V1, V2 for arguments are Bignums. Other arguments are usually % fix/i-nums. lisp procedure setbits x; % % This function sets the globals for big bignum package. % "x" should be total # of bits per word. <<BBits!*:=iquotient(isub1 x,2); % Total number of bits per word used. BBase!*:=TwoPower BBits!*; % "Beta", where n=A0 + A1*beta + A2*(beta^2)... WordHi!*:=BNum Isub1 BBase!*; % Highest value of Ai WordLow!*:=BMinus WordHi!*; % Lowest value of Ai LogicalBits!*:=ISub1 BBase!*; % Used in LAnd,Lor, etc. SysHi!*:=bsub1 btwopower isub1 x; % Largest representable Syslisp integer. SysLo!*:=BMinus BAdd1 SysHi!*; % Smallest representable Syslisp integer. BBase!*>>; lisp procedure BignumP (V); VectorP V and ((V[0] eq 'BIGPOS) or (V[0] eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and UpbV V) or 0; lisp procedure GtPOS N; % Creates a positive Bignum with N "Bigits". Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return B; End; lisp procedure GtNeg N; % Creates a negative Bignum with N "Bigits". Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return B; End; lisp procedure TrimBigNum V3; % Truncate trailing 0. If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(V3,L3); % V3 is a bignum and L3 is the position in it of the highest % possible non-zero digit. Truncate V3 to remove leading zeros, % and if this leaves V3 totally zero make its sign positive; Begin While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop Bsize TruncateVector(V3,L3) then IPutV(V3,0,'BIGPOS); return V3; end; lisp procedure big2sys U; if BLessP(U, SysLo!*) or BGreaterP(U, SysHi!*) then Error(99,list(U," is too large to be a Syslisp integer for BIG2SYS")) else begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while not IZeroP I do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; lisp procedure TwoPower N; %fix/i-num 2**n 2**n; lisp procedure BTwoPower N; % gives 2**n; n is fix/i-num; result BigNum if not (fixp N or BignumP N) then NonIntegerError(N, 'BTwoPower) else begin scalar quot, rem, V; if bignump N then n:=big2sys n; quot:=Quotient(N,Bbits!*); rem:=Remainder(N,Bbits!*); V:=GtPOS(IAdd1 quot); IFor i:=1:quot do IPutV(v,i,0); IPutV(V,IAdd1 quot,twopower rem); return TrimBigNum1(V,IAdd1 quot); end; lisp procedure BZeroP V1; IZerop BSize V1 and not BMinusP V1; lisp procedure BOneP V1; Not BMinusP V1 and IOneP (BSize V1) and IOneP IGetV(V1,1); lisp procedure BAbs V1; if BMinusP V1 then BMinus V1 else V1; lisp procedure BMax(V1,V2); if BGreaterP(V2,V1) then V2 else V1; lisp procedure BMin(V1,V2); if BLessP(V2,V1) then V2 else V1; lisp procedure BExpt(V1,N); % V1 is Bignum, N is fix/i-num if not fixp N then NonIntegerError(N,'BEXPT) else if IZeroP N then int2B 1 else if IOneP N then V1 else if IMinusP N then BQuotient(int2B 1,BExpt(V1,IMinus N)) else begin scalar V2; V2 := BExpt(V1,IQuotient(N,2)); if IZeroP IRemainder(N,2) then return BTimes2(V2,V2) else return BTimes2(BTimes2(V2,V1),V2) end; % --------------------------------------- % Logical Operations % % All take Bignum arguments lisp procedure BLOr(V1,V2); % The main body of the OR code is only obeyed when both arguments % are positive, and so the result will be positive; if BMinusp V1 or BMinusp V2 then BLnot BLand(BLnot V1,BLnot V2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); Return V3 end; lisp procedure BLXor(V1,V2); % negative arguments are coped with using the identity % LXor(a,b) = LNot LXor(Lnot a,b) = LNor LXor(a,Lnot b); begin scalar L1,L2,L3,V3,S; if BMinusp V1 then << V1 := BLnot V1; S := t >>; if BMinusp V2 then << V2 := BLnot V2; S := not S >>; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILXor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); V1:=TrimBigNum1(V3,L1); if S then V1:=BLnot V1; return V1 end; % Not Used Currently: % % lisp Procedure BLDiff(V1,V2); % ***** STILL NEEDS ADJUSTING WRT -VE ARGS ***** % begin scalar V3,L1,L2; % L1:=BSize V1; % L2:=BSize V2; % V3:=GtPOS(max(L1,L2)); % IFor i:=1:min(L1,L2) do % IPutV(V3,i,ILAnd(IGetV(V1,i),ILXor(LogicalBits!*,IGetV(V2,i)))); % if IGreaterP(L1,L2) then IFor i:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,i)); % if IGreaterP(L2,L1) then IFor i:=(IAdd1 L1):L2 do IPutV(V3,i,0); % return TrimBigNum1(V3,max(L1,L2)); % end; lisp procedure BLAnd(V1,V2); % If both args are -ve the result will be too. Otherwise result will % be positive; if BMinusp V1 and BMinusp V2 then BLnot BLor(BLnot V1,BLnot v2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; L3:=Min(L1,L2); V3:=GtPOS L3; if BMinusp V1 then IFor I:=1:L3 do IPutV(V3,I,ILand(ILXor(Logicalbits!*,IGetV(V1,I)), IGetV(V2,I))) else if BMinusp V2 then IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I), ILXor(Logicalbits!*,IGetV(V2,I)))) else IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I),IGetV(V2,I))); return TrimBigNum1(V3,L3); End; lisp procedure BLNot(V1); BMinus BSmallAdd(V1,1); lisp procedure BLShift(V1,V2); % This seems a grimly inefficient way of doing things given that % the representation of big numbers uses a base that is a power of 2. % However it will do for now; if BMinusP V2 then BQuotient(V1, BTwoPower BMinus V2) else BTimes2(V1, BTwoPower V2); % ----------------------------------------- % Arithmetic Functions: % % U, V, V1, V2 are Bignum arguments. lisp procedure BMinus V1; % Negates V1. if BZeroP V1 then V1 else begin scalar L1,V2; L1:=BSize V1; if BMinusP V1 then V2 := GtPOS L1 else V2 := GtNEG L1; IFor I:=1:L1 do IPutV(V2,I,IGetV(V1,I)); return V2; end; % Returns V1 if V1 is strictly less than 0, NIL otherwise. % lisp procedure BMinusP V1; if (IGetV(V1,0) eq 'BIGNEG) then V1 else NIL; % To provide a conveninent ADD with CARRY. lisp procedure AddCarry A; begin scalar S; S:=IPlus2(A,Carry!*); if IGeq(S,BBase!*) then <<Carry!*:= 1; S:=IDifference(S,BBase!*)>> else Carry!*:=0; return S; end; lisp procedure BPlus2(V1,V2); begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if Sn1 and Not Sn2 then return BDifference2(V2,BMinus V1,Nil); if Sn2 and Not Sn1 then return BDifference2(V1,BMinus V2,Nil); return BPlusA2(V1,V2,Sn1); end; lisp procedure BPlusA2(V1,V2,Sn1); % Plus with signs pre-checked and begin scalar L1,L2,L3,V3,temp; % identical. L1:=BSize V1; L2:=BSize V2; If IGreaterP(L2,L1) then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; L3:=IAdd1 L1; If Sn1 then V3:=GtNeg L3 else V3:=GtPOS L3; Carry!*:=0; IFor I:=1:L2 do <<temp:=IPlus2(IGetV(V1,I),IGetV(V2,I)); IPutV(V3,I,AddCarry temp)>>; temp:=IAdd1 L2; IFor I:=temp:L1 do IPutV(V3,I,AddCarry IGetV(V1,I)); IPutV(V3,L3,Carry!*); % Carry Out Return TrimBigNum1(V3,L3); end; lisp procedure BDifference(V1,V2); if BZeroP V2 then V1 else if BZeroP V1 then BMinus V2 else begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if (Sn1 and Not Sn2) or (Sn2 and Not Sn1) then return BPlusA2(V1,BMinus V2,Sn1); return BDifference2(V1,V2,Sn1); end; lisp procedure SubCarry A; begin scalar S; S:=IDifference(A,Carry!*); if ILessP(S,0) then <<Carry!*:=1; S:=IPlus2(BBase!*,S)>> else Carry!*:=0; return S; end; Lisp procedure BDifference2(V1,V2,Sn1); % Signs pre-checked and identical. begin scalar i,L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3; Sn1:=not Sn1>> else if L1 Eq L2 then <<i:=L1; while (IGetV(V2,i) Eq IGetV(V1,i) and IGreaterP(i,1)) do i:=ISub1 i; if IGreaterP(IGetV(V2,i),IGetV(V1,i)) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3;Sn1:=not Sn1>> >>; if Sn1 then V3:=GtNEG L1 else V3:=GtPOS L1; carry!*:=0; IFor I:=1:L2 do IPutV(V3,I,SubCarry IDifference(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,I,SubCarry IGetV(V1,I)); return TrimBigNum1(V3,L1); end; lisp procedure BTimes2(V1,V2); begin scalar L1,L2,L3,Sn1,Sn2,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<V3:=V1; V1:=V2; V2:=V3; % If V1 is larger, will be fewer L3:=L1; L1:=L2; L2:=L3>>; % iterations of BDigitTimes2. L3:=IPlus2(L1,L2); Sn1:=BMinusP V1; Sn2:=BMinusP V2; If (Sn1 and Sn2) or not(Sn1 or Sn2) then V3:=GtPOS L3 else V3:=GtNEG L3; IFor I:=1:L3 do IPutV(V3,I,0); IFor I:=1:L2 do BDigitTimes2(V1,IGetV(V2,I),L1,I,V3); return TrimBigNum1(V3,L3); end; Lisp procedure BDigitTimes2(V1,V2,L1,I,V3); % V1 is a bignum, V2 a fixnum, L1=BSize L1, I=position of V2 in a bignum, % and V3 is bignum receiving result. I affects where in V3 the result of % a calculation goes; the relationship is that positions I:I+(L1-1) % of V3 receive the products of V2 and positions 1:L1 of V1. % V3 is changed as a side effect here. begin scalar J,carry,temp1,temp2; if zerop V2 then return V3 else << carry:=0; IFor H:=1:L1 do << temp1:=ITimes2(IGetV(V1,H),V2); temp2:=IPlus2(H,ISub1 I); J:=IPlus2(IPlus2(temp1,IGetV(V3,temp2)),carry); IPutV(V3,temp2,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IPutV(V3,IPlus2(L1,I),carry)>>; % carry should be < BBase!* here return V3; end; Lisp procedure BSmallTimes2(V1,C); % V1 is a BigNum, C a fixnum. % Assume C positive, ignore sign(V1) % also assume V1 neq 0. if ZeroP C then return GtPOS 0 % Only used from BHardDivide, BReadAdd. else begin scalar J,carry,L1,L2,L3,V3; L1:=BSize V1; L2:=IPlus2(IQuotient(C,BBase!*),L1); L3:=IAdd1 L2; V3:=GtPOS L3; carry:=0; IFor H:=1:L1 do << J:=IPlus2(ITimes2(IGetV(V1,H),C),carry); IPutV(V3,H,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IFor H:=(IAdd1 L1):L3 do << IPutV(V3,H,IRemainder(J:=carry,BBase!*)); carry:=IQuotient(J,BBase!*)>>; return TrimBigNum1(V3,L3); end; lisp procedure BQuotient(V1,V2); car BDivide(V1,V2); lisp procedure BRemainder(V1,V2); cdr BDivide(V1,V2); % BDivide returns a dotted pair, (Q . R). Q is the quotient and R is % the remainder. Both are bignums. R is of the same sign as V1. %; smacro procedure BSimpleQuotient(V1,L1,C,SnC); car BSimpleDivide(V1,L1,C,SnC); smacro procedure BSimpleRemainder(V1,L1,C,SnC); cdr BSimpleDivide(V1,L1,C,SnC); lisp procedure BDivide(V1,V2); begin scalar L1,L2,Q,R,V3; L2:=BSize V2; If IZerop L2 then error(99, "Attempt to divide by 0 in BDIVIDE"); L1:=BSize V1; If ILessP(L1,L2) or (L1 Eq L2 and ILessP(IGetV(V1,L1),IGetV(V2,L2))) % This also takes care of case then return (GtPOS 0 . V1); % when V1=0. if IOnep L2 then return BSimpleDivide(V1,L1,IGetV(V2,1),BMinusP V2); return BHardDivide(V1,L1,V2,L2); end; % C is a fixnum (inum?); V1 is a bignum and L1 is its length. % SnC is T if C (which is positive) should be considered negative. % Returns quotient . remainder; each is a bignum. % lisp procedure BSimpleDivide(V1,L1,C,SnC); begin scalar I,P,R,RR,Sn1,V2; Sn1:=BMinusP V1; if (Sn1 and SnC) or not(Sn1 or SnC) then V2:=GtPOS L1 else V2:=GtNEG L1; R:=0; I:=L1; While not IZeroP I do <<P:=IPlus2(ITimes2(R,BBase!*),IGetV(V1,I)); % Overflow. IPutV(V2,I,IQuotient(P, C)); R:=IRemainder(P, C); I:=ISub1 I>>; If Sn1 then RR:=GtNeg 1 else RR:=GtPOS 1; IPutV(RR,1,R); return (TrimBigNum1(V2,L1) . TrimBigNum1(RR,1)); end; lisp procedure BHardDivide(U,Lu,V,Lv); % This is an algorithm taken from Knuth. begin scalar U1,V1,A,D,LCV,LCV1,f,f2,J,K,Lq,carry,temp, LL,M,N,N1,P,Q,QBar,SnU,SnV,U2; N:=Lv; N1:=IAdd1 N; M:=IDifference(Lu,Lv); Lq:=IAdd1 M; % Deal with signs of inputs; SnU:=BMinusP U; SnV:=BMinusp V; % Note that these are not extra-boolean, i.e. % for positive numbers MBinusP returns nil, for % negative it returns its argument. Thus the % test (SnU=SnV) does not reliably compare the signs of % U and V; if SnU then if SnV then Q := GtPOS Lq else Q := GtNEG Lq else if SnV then Q := GtNEG Lq else Q := GtPOS Lq; U1 := GtPOS IAdd1 Lu; % U is ALWAYS stored as if one digit longer; % Compute a scale factor to normalize the long division; D:=IQuotient(BBase!*,IAdd1 IGetV(V,Lv)); % Now, at the same time, I remove the sign information from U and V % and scale them so that the leading coefficeint in V is fairly large; carry := 0; IFor i:=1:Lu do << temp := IPlus2(ITimes2(IGetV(U,I),D),carry); IPutV(U1,I,IRemainder(temp,BBase!*)); carry := IQuotient(temp,BBase!*) >>; Lu := IAdd1 Lu; IPutV(U1,Lu,carry); V1:=BSmallTimes2(V,D); % So far all variables contain safe values, % i.e. numbers < BBase!*; IPutV(V1,0,'BIGPOS); if ILessp(Lv,2) then NonBigNumError(V,'BHARDDIVIDE); % To be safe; LCV := IGetV(V1,Lv); LCV1 := IGetv(V1,ISub1 Lv); % Top two digits of the scaled V accessed once % here outside the main loop; % Now perform the main long division loop; IFor I:=0:M do << J:=IDifference(Lu,I); % J>K; working on U1[K:J] K:=IDifference(J,N1); % in this loop. A:=IGetV(U1,J); P := IPlus2(ITimes2(A,BBase!*),IGetv(U1,Isub1 J)); % N.B. P is up to 30 bits long. Take care! ; if A Eq LCV then QBar := ISub1 BBase!* else QBar := Iquotient(P,LCV); % approximate next digit; f:=ITimes2(QBar,LCV1); f2:=IPlus2(ITimes2(IDifference(P,ITimes2(QBar,LCV)),BBase!*), IGetV(U1,IDifference(J,2))); while IGreaterP(f,f2) do << % Correct most overshoots in Qbar; QBar:=ISub1 QBar; f:=IDifference(f,LCV1);; f2:=IPlus2(f2,ITimes2(LCV,BBase!*)) >>; carry := 0; % Ready to subtract QBar*V1 from U1; IFor L:=1:N do << temp := IPlus2( Idifference( IGetV(U1,IPlus2(K,L)), ITimes2(QBar,IGetV(V1,L))), carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusp temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,IPlus2(K,L),temp) >>; % Now propagate borrows up as far as they go; LL := IPlus2(K,N); while (not IZeroP carry) and ILessp(LL,J) do << LL := IAdd1 LL; temp := IPlus2(IGetV(U1,LL),carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusP temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,LL,temp) >>; if not IZerop carry then << % QBar was still wrong - correction step needed. % This should not happen very often; QBar := ISub1 QBar; % Add V1 back into U1; carry := 0; IFor L := 1:N do << carry := IPlus2( IPlus2(IGetV(U1,Iplus2(K,L)), IGetV(V1,L)), carry); IPutV(U1,IPlus2(K,L),IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >>; LL := IPlus2(K,N); while ILessp(LL,J) do << LL := IAdd1 LL; carry := IPlus2(IGetv(U1,LL),carry); IPutV(U1,LL,IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >> >>; IPutV(Q,IDifference(Lq,I),QBar) >>; % End of main loop; U1 := TrimBigNum1(U1,IDifference(Lu,M)); f := 0; f2 := 0; % Clean up potentially wild values; if not BZeroP U1 then << % Unnormalize the remainder by dividing by D if SnU then IPutV(U1,0,'BIGNEG); if not IOnep D then << Lu := BSize U1; carry := 0; IFor L:=Lu step -1 until 1 do << P := IPlus2(ITimes2(carry,BBase!*),IGetV(U1,L)); IPutv(U1,L,IQuotient(P,D)); carry := IRemainder(P,D) >>; P := 0; if not IZeroP carry then BHardBug("remainder when unscaling", U,V,TrimBigNum1(U1,Lu),TrimBigNum1(Q,Lq)); U1 := TrimBigNum1(U1,Lu) >> >>; Q := TrimBigNum1(Q,Lq); % In case leading digit happened to be zero; P := 0; % flush out a 30 bit number; % Here, for debugging purposes, I will try to validate the results I % have obtained by testing if Q*V+U1=U and 0<=U1<V. I Know this slows things % down, but I will remove it when my confidence has improved somewhat; % if not BZerop U1 then << % if (BMinusP U and not BMinusP U1) or % (BMinusP U1 and not BMinusP U) then % BHardBug("remainder has wrong sign",U,V,U1,Q) >>; % if not BAbs U1<BAbs V then BHardBug("remainder out of range",U,V,U1,Q) % else if not BZerop(BDifference(BPlus2(BTimes2(Q,V),U1),U)) then % BHardBug("quotient or remainder incorrect",U,V,U1,Q); return (Q . U1) end; lisp procedure BHardBug(msg,U,V,R,Q); % Because the inputs to BHardDivide are probably rather large, I am not % going to rely on BldMsg to display them; << Prin2T "***** Internal error in BHardDivide"; Prin2 "arg1="; Prin2T U; Prin2 "arg2="; Prin2T V; Prin2 "computed quotient="; Prin2T Q; Prin2 "computed remainder="; Prin2T R; StdError msg >>; lisp procedure BGreaterP(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(V,U) else nil else if BMinusP V then U else BUnsignedGreaterP(U,V); lisp procedure BLessp(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(U,V) else U else if BMinusP V then nil else BUnsignedGreaterP(V,U); lisp procedure BGeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(V,U) else nil else if BMinusP V then U else BUnsignedGeq(U,V); lisp procedure BLeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(U,V) else U else if BMinusP V then nil else BUnsignedGeq(V,U); lisp procedure BUnsignedGreaterP(U,V); % Compare magnitudes of two bignums; begin scalar Lu,Lv,I; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; if IGreaterP(IGetV(U,Lv),IGetV(V,Lv)) then return U else return nil end; symbolic procedure BUnsignedGeq(U,V); % Compare magnitudes of two unsigned bignums; begin scalar Lu,Lv; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; If IGreaterP(IGetV(V,Lv),IGetV(U,Lv)) then return nil else return U end; lisp procedure BAdd1 V; BSmallAdd(V,1); lisp procedure BSub1 U; BSmallDiff(U,1); % ------------------------------------------------ % Conversion to Float: lisp procedure FloatFromBigNum V; if BZeroP V then 0.0 else if BGreaterP(V, FloatHi!*) or BLessp(V, FloatLow!*) then Error(99,list("Argument, ",V," to FLOAT is too large")) else begin scalar L,Res,Sn,I; L:=BSize V; Sn:=BMinusP V; Res:=float IGetv(V,L); I:=ISub1 L; While not IZeroP I do << Res:=res*BBase!*; Res:=Res +IGetV(V,I); I:=ISub1 I>>; if Sn then Res:=minus res; return res; end; % ------------------------------------------------ % Input and Output: Digit2Letter!* := % Ascii values of digits and characters. '[48 49 50 51 52 53 54 55 56 57 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]; % OutputBase!* is assumed to be positive and less than 37. lisp procedure BChannelPrin2(Channel,V); If not BignumP V then NonBigNumError(V, 'BPrin) %need? else begin scalar quot, rem, div, result, resultsign, myobase; myobase:=OutputBase!*; resultsign:=BMinusP V; div:=BSimpleDivide(V,Bsize V,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result; while Not BZeroP quot do <<div:=BSimpleDivide(quot,Bsize quot,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result>>; if resultsign then channelwritechar(Channel,char !-); if myobase neq 10 then <<ChannelWriteSysInteger(channel,myobase,10); ChannelWriteChar(Channel, char !#)>>; For each u in result do ChannelWriteChar(Channel, IGetV(digit2letter!*,u)); OutputBase!*:=myobase; return; end; lisp procedure BRead(s,radix,sn); % radix is < Bbase!* %s=string of digits, radix=base, sn=1 or -1 begin scalar sz, res, ch; sz:=size s; res:=GtPOS 1; ch:=indx(s,0); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IPlus2(IDifference(ch,char A),10); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); IPutV(res,1,ch); IFor i:=1:sz do <<ch:=indx(s,i); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IDifference(ch,IDifference(char A,10)); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); res:=BReadAdd(res, radix, ch)>>; if iminusp sn then res:=BMinus res; return res; end; lisp procedure BReadAdd(V, radix, ch); << V:=BSmallTimes2(V, radix); V:=BSmallAdd(V,ch)>>; lisp procedure BSmallAdd(V,C); %V big, C fix. if IZerop C then return V else if Bzerop V then return int2B C else if BMinusp V then BMinus BSmallDiff(BMinus V, C) else if IMinusP C then BSmallDiff(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS(IAdd1 L1); IFor i:=1:L1 do IPutV(V1,i,addcarry IGetV(V,i)); if IOneP carry!* then IPutV(V1,IAdd1 L1,1) else return TrimBigNum1(V1,L1); return V1 end; lisp procedure BNum N; % temporary? Creates a Bignum of one digit, value N. begin scalar B; if IZerop n then return GtPOS 0 else if IMinusp N then <<b:=GtNEG 1; n:= IMinus n>> else b:=GtPos 1; IPutV(b,1,N); Return b; end; lisp procedure BSmallDiff(V,C); %V big, C fix if IZerop C then V else if BZeroP V then int2B IMinus C else if BMinusP V then BMinus BSmallAdd(BMinus V, C) else if IMinusP C then BSmallAdd(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS L1; IFor i:=1:L1 do IPuTV(V1,i,subcarry IGetV(V,i)); if not IZeroP carry!* then StdError BldMsg(" BSmallDiff V<C %p %p%n",V,C); return TrimBigNum1(V1,L1); end; lisp procedure int2B n; % Temporary? Creates BigNum of value N. if not fixp n then NonIntegerError(n, 'int2B) else if ILessP(n,Bbase!*) then BNum n else begin scalar Str,ind,rad,Sn,r; Str:=bldmsg("%w",n); % like an "int2string" if indx(str,0)=char '!- then <<Sn:=-1; str:=sub(str,1,ISub1 (size str))>> else Sn:=1; IFor i:=0:size str do if indx(str,i)=char '!# then ind:=i; if ind then <<r:=sub(str,0,ISub1 ind); rad:=0; IFor i:=0:size r do rad:=IPlus2(ITimes2(rad,10),IDifference(indx(r,i),char 0)); str:=sub(str,IAdd1 ind,IDifference(size str,IAdd1 ind))>> else rad:=10; return Bread(str,rad,sn); end; %----------------------------------------------------- % "Fix" for Bignums lisp procedure bigfromfloat X; if fixp x or bigp x then x else begin scalar bigpart,floatpart,power,sign,thispart; if minusp X then <<sign:=-1; X:=minus X>> else sign:=1; bigpart:=bnum 0; while neq(X, 0) and neq(x,0.0) do << if X < bbase!* then << bigpart:=bplus2(bigpart, bnum fix x); X:=0 >> else <<floatpart:=x; power:=0; while floatpart>=bbase!* do % get high end of number. <<floatpart:=floatpart/bbase!*; power:=power + bbits!* >>; thispart:=btimes2(btwopower power, bnum fix floatpart); X:=X- floatfrombignum thispart; bigpart:=bplus2(bigpart, thispart) >> >>; if minusp sign then bigpart := bminus bigpart; return bigpart; end; if_system(VAX, <<setbits 32; FloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. FloatLow!*:=BMinus FloatHi!*>>); if_system(PDP10, <<setbits 36; FloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); FloatLow!*:=BMinus FloatHi!*>>); % End of BIGBIG.RED ; |
Added psl-1983/util/bigface.build version [eea09281f5].
> | 1 | in "bigface.red"$ |
Added psl-1983/util/bigface.red version [429cbd5313].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. BIGFACE.RED - Bignum Interfacing % M.L. Griss and B Morrison % 25 June 1982 % -------------------------------------------------------------------------- % Revision History: % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman off usermode; % Use the BIGN tag for better Interface imports '(vector!-fix arith bigbig); compiletime<<load syslisp; load fast!-vector; load inum; load if!-system>>; on comp; fluid '(WordHi!* WordLow!* BBase!* FloatHi!* FloatLow!*); smacro procedure PutBig(b,i,val); IputV(b,i,val); smacro procedure GetBig(b,i); IgetV(B,i); % on syslisp; % % procedure BigP x; % Tag(x) eq BIGN; % % off syslisp; lisp procedure BignumP (V); BigP V and ((GetBig(V,0) eq 'BIGPOS) or (GetBig(V,0) eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and VecLen VecInf V) or 0; lisp procedure GtPOS N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return MkBigN Vecinf B; End; lisp procedure GtNeg N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return MkBigN VecInf B; End; lisp procedure TrimBigNum V3; % truncate trailing 0 If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; lisp procedure BigAsVec B; MkVec Inf B; lisp procedure VecAsBig V; MkBig Inf V; % -- Output--- if_system(VAX, <<setbits 32; FloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. FloatLow!*:=BMinus FloatHi!*>>); if_system(PDP10, <<setbits 36; FloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); FloatLow!*:=BMinus FloatHi!*>>); % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Lisp Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigNumP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Lisp Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigNumP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; lisp procedure big2sys U; begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while I neq 0 do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; smacro procedure checkifreallybig U; (lambda UU; % This construction needed to avoid repeated evaluation; if BLessP(UU, WordLow!*) or BGreaterp(UU,WordHi!*) then UU else sys2int big2sys UU)(U); smacro procedure checkifreallybigpair U; (lambda VV; checkifreallybig car VV . checkifreallybig cdr VV)(U); smacro procedure checkifreallybigornil U; (lambda UU; if Null UU or BLessp(UU, WordLow!*) or BGreaterP(UU,WordHi!*) then UU else sys2int big2sys UU)(U); lisp procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); lisp procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); lisp procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); lisp procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); lisp procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); lisp procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); lisp procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); lisp procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); lisp procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); lisp procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); lisp procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); lisp procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); lisp procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; lisp procedure BigSub1 U; CheckIfReallyBig BSub1 U; lisp procedure BigLNot U; CheckIfReallyBig BLNot U; lisp procedure BigMinus U; CheckIfReallyBig BMinus U; lisp procedure FloatBigArg U; FloatFromBigNum U; lisp procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; % ---- Input ---- lisp procedure MakeStringIntoLispInteger(Str,Radix,Sn); CheckIfReallyBig BRead(Str,Radix,Sn); % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure floatfix U; if U < BBase!* then OldFloatFix U else bigfromfloat U; copyd('oldMakeFixNum, 'MakeFixNum); procedure MakeFixNum N; % temporary; check range? Begin; n:=oldMakeFixNum N; return int2b N; end; syslsp procedure StaticIntBig Arg; % Convert an INT to a BIG int2b Arg; syslsp procedure StaticBigFloat Arg; % Convert a BigNum to a FLOAT; FloatFromBignum Arg; copyd('oldInt2Sys, 'Int2Sys); procedure Int2Sys N; if BigP N then Big2Sys N else OldInt2Sys n; on syslisp; syslsp procedure IsInum U; U < lispvar bbase!* and U > minus lispvar bbase!*; off syslisp; on usermode; |
Added psl-1983/util/bind-macros.sl version [124e1f6a59].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BIND-MACROS.SL - convenient macros for binding variables % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>BIND-MACROS.SL.2, 18-Oct-82 14:31:17, Edit by BENSON % Reversed vars and vals after collecting them in LET, so that the order % of things in the LAMBDA is the same as the LET. Not necessary, % but it makes it easier to follow macroexpanded things. (defmacro prog1 (first . body) (if (null body) first `((lambda (***PROG1-VAR***) ,@body ***PROG1-VAR***) ,first))) (defmacro let (specs . body) (if (null specs) (cond ((null body) nil) ((and (pairp body) (null (cdr body))) (car body)) (t `(progn ,@body))) (prog (vars vals) (foreach U in specs do (cond ((atom U) (setq vars (cons U vars)) (setq vals (cons nil vals))) (t (setq vars (cons (car U) vars)) (setq vals (cons (and (cdr U) (cadr U)) vals))))) (return `((lambda ,(reversip vars) ,@body ) ,@(reversip vals)))))) (defmacro let* (specs . body) (if (null specs) (cond ((null body) nil) ((and (pairp body) (null (cdr body))) (car body)) (t `(progn ,@body))) (let*1 specs body))) (de let*1 (specs body) (let ((s (car specs))(specs (cdr specs))) `((lambda (,(if (atom s) s (car s))) ,@(if specs (list (let*1 specs body)) body)) ,(if (and (pairp s) (cdr s)) (cadr s) nil)))) |
Added psl-1983/util/br-unbr.red version [0cb6fae3c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Just stuff for BR and UNBR from MINI-TRACE.RED %%% This code also appears in MINI-TRACE.RED %%% Cris Perdue %%% 1/6/83 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % <PSL.UTIL>BR-UNBR.RED.2, 19-Jan-83 13:29:43, Edit by PERDUE % Fixed problem with the value returned from a broken function fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb, Ans; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Ans := Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, Ans); TrSpace!* := TrSpace!* - 1; return Ans end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Trace a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; PN := GenSym(); PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; PutD(Nam, caar X, cdar X); put(Nam, 'OldCod, cdr X) end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; for each X in L do Br!.1 X; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; END; |
Added psl-1983/util/build version [024721a3c0].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | #! /bin/csh -f # build module-name ... foreach i ($argv) if (-e $pl/$i.b) mv $pl/$i.b . rlisp << EOF load build; build '$i; EOF if (-e $i.b) rm $i.b end |
Added psl-1983/util/build.build version [a161cd3bd8].
> > | 1 2 | CompileTime load(If!-System, Syslisp); in "build.red"$ |
Added psl-1983/util/build.mic version [d09ab69281].
> > > > > > > | 1 2 3 4 5 6 7 | get PSL:RLISP.EXE START load Build; BuildFileFormat!* := "%w"; Build '''A; quit; RESET . |
Added psl-1983/util/build.red version [f158c3ea25].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % BUILD.RED - Compile a load module % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 March 1982 % Copyright (c) 1982 University of Utah % % Edit by MLG, 9 Feb, chchanged Buildformat to use $pl/ % <PSL.UTIL>BUILD.RED.3, 1-Dec-82 16:12:33, Edit by BENSON % Added if_system(HP9836, ... ) fluid '(!*quiet_faslout % turns off welcome message in faslout !*Lower % lowercase ids on output !*UserMode % query on redefinition BuildFileFormat!* ); if_system(Tops20, BuildFileFormat!* := "pl:%w"); if_system(Unix, BuildFileFormat!* := "$pl/%w"); if_system(HP9836, BuildFileFormat!* := "pl:%w"); lisp procedure Build X; begin scalar !*UserMode, !*quiet_faslout; !*quiet_faslout := T; (lambda (!*Lower); << FaslOut BldMsg(BuildFileFormat!*, X); X := BldMsg("%w.build", X) >>)(T); EvIn list X; FaslEnd; end; END; |
Added psl-1983/util/chars.build version [8522132837].
> > > > > | 1 2 3 4 5 | CompileTime << load(Useful, CLComp); put('Space, 'CharConst, 32); % temporary patch >>; in "chars.lsp"$ |
Added psl-1983/util/chars.lsp version [d50a4c91f4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; CHARS.LSP - Common Lisp operations on characters ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 7 April 1982 ;;; Copyright (c) 1982 University of Utah ;;; ; <PSL.UTIL>CHARS.LSP.4, 2-Sep-82 14:22:45, Edit by BENSON ; Fixed bug in CHAR-UPCASE and CHAR-DOWNCASE (defvar char-code-limit 128 "Upper bound of character code values") (defvar char-font-limit 1 "Upper bound on supported fonts") (defvar char-bits-limit 1 "Upper bound on values produces by char-bits") ;;;; STANDARD-CHARP - ASCII definition (defun standard-charp (c) (and (characterp c) (or (not (or (char< c #\Space) (char> c #\Rubout))) (eq c #\Eol) (eq c #\Tab) (eq c #\FF)))) ;;;; GRAPHICP - printable character (defun graphicp (c) (and (characterp c) (not (char< c #\Space)) (char< c #\Rubout))) ;;;; STRING-CHARP - a character that can be an element of a string (defun string-charp (c) (and (characterp c) (>= (char-int c) 0) (<= (char-int c) #\Rubout))) ;;;; ALPHAP - an alphabetic character (defun alphap (c) (or (uppercasep c) (lowercasep c))) ;;;; UPPERCASEP - an uppercase letter (defun uppercasep (c) (and (characterp c) (not (char< c #\A)) (not (char> c #\Z)))) ;;;; LOWERCASEP - a lowercase letter (defun lowercasep (c) (and (characterp c) (not (char< c #\\a)) (not (char> c #\\z)))) ;;;; BOTHCASEP - same as ALPHAP (fset 'bothcasep (fsymeval 'alphap)) ;;;; DIGITP - a digit character (optional radix not supported) (defun digitp (c) (when (and (characterp c) (not (char< c #\0)) (not (char> c #\9))) (- (char-int c) (char-int #\0)))) ;;;; ALPHANUMERICP - a digit or an alphabetic (defun alphanumericp (c) (or (alphap c) (digitp c))) ;;;; CHAR= - strict character comparison (defun char= (c1 c2) (eql (char-int c1) (char-int c2))) ;;;; CHAR-EQUAL - similar character objects (defun char-equal (c1 c2) (or (char= c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (eql (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR< - strict character comparison (defun char< (c1 c2) (< (char-int c1) (char-int c2))) ;;;; CHAR> - strict character comparison (defun char> (c1 c2) (> (char-int c1) (char-int c2))) ;;;; CHAR-LESSP - ignore case and bits for CHAR< (defun char-lessp (c1 c2) (or (char< c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (< (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR-GREATERP - ignore case and bits for CHAR> (defun char-greaterp (c1 c2) (or (char> c1 c2) (and (string-charp c1) (string-charp c2) (or (char< c1 #\Space) (char> c1 #\?)) (or (char< c2 #\Space) (char> c2 #\?)) (> (logand (char-int c1) (char-int #\)) (logand (char-int c2) (char-int #\)))))) ;;;; CHAR-CODE - character to integer conversion (defmacro char-code (c) c) ;;;; CHAR-BITS - bits attribute of a character (defmacro char-bits (c) 0) ;;;; CHAR-FONT - font attribute of a character (defmacro char-font (c) 0) ;;;; CODE-CHAR - integer to character conversion, optional bits, font ignored (defmacro code-char (c) c) ;;;; CHARACTER - character plus bits and font, which are ignored (defun character (c) (cond ((characterp c) c) ((stringp c) (char c 0)) ((symbolp c) (char (get-pname c) 0)) (t (stderror (bldmsg "%r cannot be coerced to a character" c))))) ;;;; CHAR-UPCASE - raise a character (defun char-upcase (c) (if (not (or (char< c #\\a) (char> c #\\z))) (int-char (+ (char-int #\A) (- (char-int c) (char-int #\\a)))) c)) ;;;; CHAR-DOWNCASE - lower a character (defun char-downcase (c) (if (not (or (char< c #\A) (char> c #\Z))) (int-char (+ (char-int #\\a) (- (char-int c) (char-int #\A)))) c)) ;;;; DIGIT-CHAR - convert character to digit (optional radix, bits, font NYI) (defun digit-char (i) (when (and (>= i 0) (<= i 10)) (int-char (+ (char-int #\0) i)))) ;;;; CHAR-INT - convert character to integer (defmacro char-int (c) ;; Identity operation in PSL c) ;;;; INT-CHAR - convert integer to character (defmacro int-char (c) ;; Identity operation in PSL c) |
Added psl-1983/util/clcomp1.build version [8772d10010].
> > > > > | 1 2 3 4 5 | CompileTime << load Useful, Common; off UserMode; >>; in "clcomp1.sl"$ |
Added psl-1983/util/clcomp1.sl version [a24dac532a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % CLCOMP.SL - Incompatible Common Lisp compatibility % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 12 April 1982 % Copyright (c) 1982 University of Utah % % These are Common Lisp compatiblity definitions that cause Standard Lisp % to break. Changes character definitions and redefines functions. (imports '(useful common fast-vector)) (defmacro prog2 (first second . others) `(progn ,first (prog1 ,second ,@others))) (remprop 'prog2 'compfn) (defun char (s i) (igets s i)) (put 'char 'cmacro '(lambda (s i) (igets s i))) % NTH is a problem, hasn't been dealt with yet % Also MAP functions... (comment "make backslash the escape character") (setf IDEscapeChar* #\!\) (setf (elt lispscantable* #\!\) 14) (comment "Make percent a letter") (setf (elt lispscantable* #\!%) 10) (comment "Make semicolon start comments") (setf (elt lispscantable* #\;) 12) (comment "make bang a letter") (setf (elt lispscantable* #\!!) 10) (comment "Make colon the package character") (setf PackageCharacter* #\:) (setf (elt lispscantable* #\:) 16) (comment "Add vertical bars for reading IDs") (setf (elt lispscantable* #\|) 21) (comment "#M and #Q mean if_maclisp and if_lispm") (defun throw-away-next-form (channel qt) (ChannelReadTokenWithHooks channel) (ChannelReadTokenWithHooks channel)) (put '!#M 'LispReadMacro 'throw-away-next-form) (put '!#Q 'LispReadMacro 'throw-away-next-form) (push '(M . !#M) (get '!# (getv LispScanTable* 128))) (push '(Q . !#Q) (get '!# (getv LispScanTable* 128))) (comment "So we can add #+psl to maclisp code") (push 'psl system_list*) |
Added psl-1983/util/co.doc version [a85f84acb5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 01/11/82 Kessler Working on the PSL sources When you desire to work on any of the PSL sources and will want to place them back into the PSL system you must use the check-out/in procedure outlined here. As a preliminary, you must place in your Comand.cmd file the following line: dec/noc env <psl.util>co This will define the 3 commands used to check files (co, unco and ci). Check Out When you want to check out a file or files, issue the CO command followed by the name(s) of the file(s). This will record in a data base file the fact that you have them checked out and will inhibit anyone else from checking them out. Then it will send a mail message to the Czar's at HP and here. For example, CO pc:compiler.red CO pc:compiler.* CO pu:rlisp-support.red, pu:rlisp-parser.red The CO command will accept wildcards and the escape key functions in the normal manner. If someone has already checked out a file, you will be so informed, including the person who checked it out and the date and time it was done. Un Check Out If you decide later that you really didn't want to check the file out, you may cancel your check out by issuing the UNCO command, followed by the file(s) that you want to cancel. You may only UNCO files that you have checked out, you may not UNCO anyone else's files. It has the same format as CO above. Check In Finally, when you are finished making changes and are satisfied that the changes are complete and well documented, you may check the files back in using the CI command, followed by the file(s) that you want to check back in. This will send a message to the Local Czar. It is your responsibility to copy the file from your local directory to the newversions directory. Note: These do not perform any automatic file copy. Should we add this?? That is, upon CO, it copies the files to your currently connected directory and when you CI it copies from your connected directory to the newversions?? |
Added psl-1983/util/co.env version [0171612a48].
cannot compute difference between binary files
Added psl-1983/util/common.build version [82e48c324b].
> > > > > | 1 2 3 4 5 | CompileTime << load Useful; off UserMode; >>; in "common.sl"$ |
Added psl-1983/util/common.sl version [f49b28673e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % COMMON.SL - Compile- and read-time support for Common Lisp compatibility. % In a few cases, actually LISP Machine Lisp compatibility? % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 31 March 1982 % Copyright (c) 1982 University of Utah % % Edit by Cris Perdue, 4 Feb 1983 1047-PST % Removed ERRSET (redundant and not COMMON Lisp) and MOD (incorrect). % <PSL.UTIL.NEWVERSIONS>COMMON.SL.2, 13-Dec-82 21:30:58, Edit by GALWAY % Fixed bugs in copylist and copyalist that copied the first element % twice. Also fixed bug in copyalist where it failed to copy first pair % in the list. % Also started commenting the functions defined here. % These are only the Common Lisp definitions that do not conflict with % Standard Lisp or other PSL functions. Currently growing on a daily basis (imports '(useful fast-vector)) (compiletime (defmacro cl-alias (sl-name cl-name) `(defmacro ,cl-name form `(,',sl-name . ,form))) (flag '(expand-funcall* butlast-aux nbutlast-aux left-expand left-expand-aux) 'internalfunction) ) (cl-alias de defun) (defmacro defvar (name . other) (if *defn (fluid (list name))) (if (atom other) `(fluid `(,',name)) `(progn (fluid `(,',name)) (setq ,name ,(car other))))) (cl-alias idp symbolp) (cl-alias pairp consp) (defun listp (x) (or (null x) (consp x))) (put 'listp 'cmacro '(lambda (x) ((lambda (y) (or (null y) (consp y))) x))) (cl-alias fixp integerp) (cl-alias fixp characterp) (put 'characterp 'cmacro '(lambda (x) (posintp x))) (cl-alias vectorp arrayp) (cl-alias codep subrp) (defun functionp (x) (or (symbolp x) (codep x) (and (consp x) (eq (car x) 'lambda)))) (cl-alias eqn eql) (cl-alias equal equalp) (cl-alias valuecell symeval) (defmacro fsymeval (symbol) `((lambda (***fsymeval***) (or (cdr (getd ***fsymeval***)) (stderror (bldmsg "%r has no function definition" ***fsymeval***)))) ,symbol)) (defmacro boundp (name) `(not (unboundp ,name))) (defmacro fboundp (name) `(not (funboundp ,name))) (defmacro macro-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'macro)) (cdr y) nil))) (defmacro special-form-p (x) `(let ((y (getd ,x))) (if (and (consp y) (equal (car y) 'fexpr)) (cdr y) nil))) (defmacro fset (symbol value) `(putd ,symbol 'expr ,value)) (defmacro makunbound (x) `(let ((y ,x) (makunbound y) y))) (defmacro fmakunbound (x) `(let ((y ,x) (remd y) y))) (defmacro funcall* (fn . args) `(apply ,fn ,(expand-funcall* args))) (defun expand-funcall* (args) (if (null (cdr args)) (car args) `(cons ,(car args) ,(expand-funcall* (cdr args))))) (cl-alias funcall* lexpr-funcall) % only works when calls are compiled right now % need to make a separate special form and compiler macro prop. (defmacro progv (symbols values . body) `(let ((***bindmark*** (captureenvironment))) (do ((symbols ,symbols (cdr symbols)) (values ,values (cdr values))) ((null symbols) nil) (lbind1 (car symbols) (car values))) (prog1 (progn ,@body) (restoreenvironment ***bindmark***)))) (defmacro dolist (bindspec . progbody) `(prog (***do-list*** ,(first bindspec)) (setq ***do-list*** ,(second bindspec)) $loop$ (if (null ***do-list***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (car ***do-list***)) ,@progbody (setq ***do-list*** (cdr ***do-list***)) (go $loop$))) (defmacro dotimes (bindspec . progbody) `(prog (***do-times*** ,(first bindspec)) (setq ,(first bindspec) 0) (setq ***do-times*** ,(second bindspec)) $loop$ (if (= ,(first bindspec) ***do-times***) (return ,(if (not (null (cddr bindspec))) (third bindspec) ()))) (setq ,(first bindspec) (+ ,(first bindspec) 1)) ,@progbody (go $loop$))) (cl-alias map mapl) % neither PROG or PROG* supports initialization yet (cl-alias prog prog*) (cl-alias dm macro) % DECLARE, LOCALLY ignored now (defmacro declare forms ()) (defmacro locally forms `(let () ,forms)) % version of THE which does nothing (defmacro the (type form) form) (cl-alias get getpr) (cl-alias put putpr) (cl-alias remprop rempr) (cl-alias prop plist) (cl-alias id2string get-pname) (defun samepnamep (x y) (equal (get-pname x) (get-pname y))) (cl-alias newid make-symbol) (cl-alias internp internedp) (defun plusp (x) (and (not (minusp x)) (not (zerop x)))) (defun oddp (x) (and (integerp x) (equal (remainder x 2) 1))) (defun evenp (x) (and (integerp x) (equal (remainder x 2) 0))) (cl-alias eqn =) (cl-alias lessp <) (cl-alias greaterp >) (cl-alias leq <=) (cl-alias geq >=) (cl-alias neq /=) (cl-alias plus +) (defmacro - args (cond ((null (cdr args)) `(minus ,@args)) ((null (cddr args)) `(difference ,@args)) (t (left-expand args 'difference)))) (cl-alias times *) (defmacro / args (cond ((null (cdr args)) `(recip ,(car args))) ((null (cddr args)) `(quotient ,@args)) (t (left-expand args 'quotient)))) (defun left-expand (arglist op) (left-expand-aux `(,op ,(first arglist) ,(second arglist)) (rest (rest arglist)) op)) (defun left-expand-aux (newform arglist op) (if (null arglist) newform (left-expand-aux `(,op ,newform ,(first arglist)) (rest arglist) op))) (cl-alias add1 !1+) (cl-alias sub1 !1-) (cl-alias incr incf) (cl-alias decr decf) (defmacro logior args (robustexpand args 'lor 0)) (defmacro logxor args (robustexpand args 'lxor 0)) (defmacro logand args (robustexpand args 'land -1)) (cl-alias lnot lognot) (cl-alias lshift ash) (put 'ldb 'assign-op 'dpb) % Not defined, but used in NSTRUCT (put 'rplachar 'cmacro '(lambda (s i x) (iputs s i x))) (put 'char-int 'cmacro '(lambda (x) x)) (put 'int-char 'cmacro '(lambda (x) x)) (put 'char= 'cmacro '(lambda (x y) (eq x y))) (put 'char< 'cmacro '(lambda (x y) (ilessp x y))) (put 'char> 'cmacro '(lambda (x y) (igreaterp x y))) (cl-alias indx elt) (cl-alias setindx setelt) (defun copyseq (seq) (subseq seq 0 (+ (size seq) 1))) (defun endp (x) (cond ((consp x) ()) ((null x) t) (t (stderror (bldmsg "%r is not null at end of list" x))))) (cl-alias length list-length) (cl-alias reversip nreverse) (cl-alias getv vref) (cl-alias putv vset) (put 'string= 'cmacro '(lambda (x y) (eqstr x y))) (put 'string-length 'cmacro '(lambda (x) (iadd1 (isizes x)))) (put 'string-to-list 'cmacro '(lambda (x) (string2list x))) (put 'list-to-string 'cmacro '(lambda (x) (list2string x))) (put 'string-to-vector 'cmacro '(lambda (x) (string2vector x))) (put 'vector-to-string 'cmacro '(lambda (x) (vector2string x))) (put 'substring 'cmacro '(lambda (s low high) (sub s low (idifference high (iadd1 low))))) (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (cl-alias copy copytree) (cl-alias pair pairlis) (put 'make-string 'cmacro '(lambda (i c) (mkstring (isub1 i) c))) (defmacro putprop (symbol value indicator) `(put ,symbol ,indicator ,value)) (defmacro defprop (symbol value indicator) `(putprop `,',symbol `,',value `,',indicator)) (defmacro eval-when (time . forms) (if *defn (progn (when (memq 'compile time) (evprogn forms)) (when (memq 'load time) `(progn ,@forms))) (when (memq 'eval time) `(progn ,@forms)))) % This name is already used by PSL /csp % (defmacro case tail % (cons 'selectq tail) % Selectq is actually a LISP Machine LISP name /csp (defmacro selectq (on . s-forms) (if (atom on) `(cond ,@(expand-select s-forms on)) `((lambda (***selectq-arg***) (cond ,@(expand-select s-forms '***selectq-arg***))) ,on))) (defun expand-select (s-forms formal) (cond ((null s-forms) ()) (t `((,(let ((selector (first (first s-forms)))) (cond ((consp selector) `(memq ,formal `,',selector)) ((memq selector '(otherwise t)) t) (t `(eq ,formal `,',selector)))) ,@(rest (first s-forms))) ,@(expand-select (rest s-forms) formal))))) (defmacro comment form ()) (defmacro special args `(fluid `,',args)) (defmacro unspecial args `(unfluid `,',args)) (cl-alias atsoc assq) (cl-alias lastpair last) (cl-alias flatsize2 flatc) (cl-alias explode2 explodec) % swapf, exchf ...? (defun nthcdr (n l) (do ((n n (isub1 n)) (l l (cdr l))) ((izerop n) l))) (defun tree-equal (x y) (if (atom x) (eql x y) (and (tree-equal (car x) (car y)) (tree-equal (cdr x) (cdr y))))) % Return a "top level copy" of a list. (defun copylist (x) (if (atom x) x (let* ((x1 (cons (car x) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (car x) ())) (setq x (cdr x)))))) % Return a copy of an a-list (copy down to the pairs but no deeper). (defun copyalist (x) (if (atom x) x (let* ((x1 (cons (cons (caar x) (cdar x)) ())) (x (cdr x))) (do ((x2 x1 (cdr x2))) ((atom x) (rplacd x2 x) x1) (rplacd x2 (cons (cons (caar x) (cdar x)) ())) (setq x (cdr x)))))) (defun revappend (x y) (if (atom x) y (revappend (cdr x) (cons (car x) y)))) (defun nreconc (x y) (if (atom x) y (let ((z (cdr x))) (rplacd x y) (nreconc z x)))) (defun butlast (x) (if (or (atom x) (atom (cdr x))) x (butlast-aux x ()))) (defun butlast-aux (x y) (let ((z (cons (car x) y))) (if (atom (cddr x)) z (butlast-aux (cdr x) z)))) (defun nbutlast (x) (if (or (atom x) (atom (cdr x))) x (do ((y x (cdr y))) ((atom (cddr y)) (rplacd y ()))) x)) (defun buttail (list sublist) (if (atom list) list (let ((list1 (cons (car list) ()))) (setq list (cdr list)) (do ((list2 list1 (cdr list2))) ((or (atom list) (eq list sublist)) list1) (rplacd list2 (cons (car list) ())) (setq list (cdr list)))))) (cl-alias substip nsubst) (defmacro ouch (char . maybe-channel) (if maybe-channel `(channelwritechar ,(car maybe-channel) ,char) `(writechar ,char))) (defmacro inch maybe-channel (if maybe-channel `(channelreadchar ,(car maybe-channel)) `(readchar))) (defmacro uninch (char . maybe-channel) (if maybe-channel `(channelunreadchar ,(car maybe-channel) ,char) `(unreadchar ,char))) |
Added psl-1983/util/cond-macros.sl version [a955a45f26].
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | % COND-MACROS.SL - convenient macros for conditional expressions % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (defmacro if (predicate then . else) (cond ((null else) `(cond (,predicate ,then))) (t `(cond (,predicate ,then) (t . ,else))))) (defmacro xor (u v) % done this way to both "semi-open-code" but not repeat the code for either % arg; also evaluates args in the correct (left to right) order. `((lambda (***XOR-ARG***) (if ,v (not ***XOR-ARG***) ***XOR-ARG***)) ,u)) (defmacro when (p . c) `(cond (,p . ,c))) (defmacro unless (p . c) `(cond ((not ,p) . ,c))) |
Added psl-1983/util/datetime.build version [af688151a7].
> | 1 | in "datetime.red"$ |
Added psl-1983/util/datetime.red version [f082c98868].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MAKE.RED % Will read in two directories and compare them for DATE and TIME % Segment a string into fields: Procedure SegmentString(S,ch); % "parse" string in pieces at CH Begin scalar s0,sN,sN1, Parts, sa,sb; s0:=0; sn:=Size(S); sN1:=sN+1; L1:If s0>sn then goto L2; sa:=NextNonCh(Ch,S,s0,sN); if sa>sN then goto L2; sb:=NextCh(Ch,S,sa+1,sN); if sb>SN1 then goto L2; Parts:=SubSeq(S,sa,sb) . Parts; s0:=sb; goto L1; L2:Return Reverse Parts; End; Procedure NextCh(Ch,S,s1,s2); <<While (S1<=S2) and not(S[S1] eq Ch) do s1:=s1+1; S1>>; Procedure NextNonCh(Ch,S,s1,s2); <<While (S1<=S2) and (S[S1] eq Ch) do s1:=s1+1; S1>>; Fluid '(Months!*); Months!*:='( ("JAN" . 1) ("FEB" . 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6) ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10) ("NOV" . 11) ("DEC" . 12) ("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12) ); Procedure Month2Integer m; cdr assoc(m,Months!*); Procedure DateTime2IntegerList(wdate,wtime); Begin Scalar V; V:=0; wdate:=SegmentString(wdate,char '!-); wtime:=SegmentString(wtime,char '!:); Rplaca(cdr WDate,Month2Integer Cadr Wdate); wdate:=MakeNumeric(wdate); wtime:=MakeNumeric(wtime); return append(wdate , wtime); end; procedure MakeNumeric(L); If null L then NIL else String2Integer(car L) . MakeNumeric(cdr L); procedure String2Integer S; if numberP s then s else if stringp s then MakeStringIntoLispInteger(s,10,1) else StdError "Non-string in String2Integer"; procedure CompareIntegerLists(L1,L2); % L1 <= L2 If Null L1 then T else if Null L2 then Nil else if Car L1 < Car L2 then T else if Car L1 > Car L2 then NIL else CompareIntegerLists(cdr L1, cdr L2); end; |
Added psl-1983/util/debug.build version [4bbf5ee989].
> | 1 | in "debug.red"$ |
Added psl-1983/util/debug.red version [5020e3ca8e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DEBUG.RED - General tracing capabilities % Norman and Morisson %--------- % Revision History: % <PSL.UTIL>DEBUG.RED.21, 4-Feb-83 13:01:05, Edit by OTHMER % Added Br - UnBr from Mini-Trace.Red % Added functions UnBrAll, UnTrAll % Added globals TracedFns!*, BrokenFns!* % Changed Restr to be a macro that can take a list of file names % as argument % Removed many lines of code that had been commented out % <PSL.UTIL>DEBUG.RED.20, 3-Feb-83 11:00:06, Edit by KESSLER % Remove fluid defintion of !*mode % Edit by Griss, 25 January 1983, fix !*MODE and DEFINEROP % for REDUCE % <PSL.NEW>DEBUG.RED.2, 29-Dec-82 15:28:13, Edit by PERDUE % In the fix of 12-december, changed > to !-greaterp % Also added a << >> pair to !-findentries % <PSL.UTIL>DEBUG.RED.16, 28-Dec-82 13:50:19, Edit by PERDUE % Added !-TRSTCOND to handle COND correctly % <PSL.UTIL>DEBUG.RED, 12-Dec-82 15:59:45, Edit by GRISS % Fixed printx to handle 0 SIZE (i.e. one-element) vectors CompileTime flag('(!-LPRIE !-LPRIM !-PAD !-IDLISTP !-CIRLIST !-FIRSTN !-LISTOFATOMS !-!-PUTD !-LABELNAME !-FINDENTRIES !-PRINTPASS !-PRINS !-TRGET !-TRGETX !-TRFLAGP !-TRPUT !-TRPUTX !-TRPUTX1 !-TRFLAG !-TRFLAG1 !-TRREMPROP !-TRREMPROPX !-TRREMFLAG !-TRREMFLAG1 !-TRINSTALL !-ARGNAMES !-TRRESTORE !-OUTRACE1 !-DUMPTRACEBUFF !-ERRAPPLY !-ENTERPRI !-EXITPRI !-TRINDENT !-TRACEPRI1 !-TRACENTRYPRI1 !-TRACEXPANDPRI !-MKTRST !-MKTRST1 !-BTRPUSH !-BTRPOP !-BTRDUMP !-EMBSUBST !-TR1 !-MKSTUB !-PLIST1 !-PPF1 !-GETC), 'InternalFunction); %********************* Implementation dependent procedures *********** fluid '(IgnoredInBacktrace!*); IgnoredInBacktrace!* := Append('(!-TRACEDCALL !-APPLY !-GET), IgnoredInBacktrace!*); %ON NOUUO; % Slow links PUTD('!-!%PROP,'EXPR,CDR GETD 'PROP); SYMBOLIC PROCEDURE !-GETPROPERTYLIST U; % U is an id. Returns a list of all the flags (id's) and property-values % (dotted pairs) of U. !-!%PROP U; %DEFINE !-GETPROPERTYLIST=!-!%CDR; % %PUTD('!-ATOM,'EXPR,CDR GETD 'ATOM); % % SYMBOLIC PROCEDURE !-ATOM U; % A safe version of ATOM. % !-!%PATOM U; % %DEFINE !-ATOM=!-!%PATOM; % %GLOBAL '(!*NOUUO); % CompileTime << SYMBOLIC SMACRO PROCEDURE !-SLOWLINKS; % Suppresses creation of fast-links % No-op in PSL NIL; >>; %****************************************************************** % Needs REDIO for sorting routine. If compiled without it only % the printing under the influence of COUNT will be affected. % I systematically use names starting with a '-' within this % package for internal routines that must not interfere with the % user. This means that the debug package may behave incorrectly % if user functions or variables have names starting with a '-'; %******************** Globals declarations ************************ GLOBAL '( % Boolean valued flags !*BTR % T -> stack traced function calls for backtrace !*BTRSAVE % T -> bactrace things which fail in errorsets !*INSTALL % T -> "install" trace info on all PUTD'd functions !*SAVENAMES % controlls saving of substructure names in PRINTX !*TRACE % T -> print trace information at run time !*TRACEALL % T -> trace all functions defined with PUTD !*TRSTEXPANDMACROS % T -> expand macros before embedding SETQs to print !*TRUNKNOWN % T -> never ask for the number of args !*TRCOUNT % T -> count # of invocations of traced functions % Other globals intended to be accessed outside of DEBUG !*MSG % BROKENFNS!* % List of functions that have been broken TRACEDFNS!* % List of functions that have been traced EMSG!* % ERFG!* % Reduce flag MSGCHNL!* % Channel to output trace information PPFPRINTER!* % Used by PPF to print function bodies PROPERTYPRINTER!* % Used by PLIST to print property values PUTDHOOK!* % User hook run after a successful PUTD STUBPRINTER!* % For printing arguments in calls on stubs STUBREADER!* % For reading the return value in calls on stubs TRACEMINLEVEL!* % Minimum recursive depth at which to trace TRACEMAXLEVEL!* % Maximum " " " " " " TRACENTRYHOOK!* % User hook into traced functions TRACEXITHOOK!* % " " " " " TRACEXPANDHOOK!* % " " " " " TREXPRINTER!* % Function used to print args/values in traced fns TRINSTALLHOOK!* % User hook called when a function is first traced TRPRINTER!* % Function used to print macro expansions % Globals principally for internal use !-ARBARGNAMES!* % List of ids to be used for unspecified names !-ARGINDENT!* % Number of spaces to indent when printing args !-BTRSAVEDINTERVALS!* % Saved BTR frames from within errorsets !-BTRSTK!* % Stack for bactrace info % !-COLONERRNUM!* % Error number used by failing :CAR,:CDR, etc. !-FUNCTIONFLAGS!* % Flags which PPF considers printing !-GLOBALNAMES!* % Used by PRINTX to store common substructure names !-INDENTCUTOFF!* % Furthest right to indent trace output !-INDENTDEPTH!* % Number of spaces to indent each level trace output !-INVISIBLEPROPS!* % Properties which PLIST should ignore !-INVISIBLEFLAGS!* % Flags which PLIST should ignore !-INSTALLEDFNS!* % Functions which have had information installed !-NONSTANDARDFNS!* % Properties under which special MACRO's are stored % !-SAFEFNSINSTALLED!* % T -> :CAR, etc have replaced CAR, etc !-TRACEBUFF!* % Ringbuffer to save recent trace output !-TRACECOUNT!* % Decremented -- if >0 it may suppresses tracing !-TRACEFLAG!* % Enables tracing ); FLUID '( !*COMP % Standard Lisp flag !*BACKTRACE % Reduce flag !*DEFN % Reduce flag !-ENTRYPOINTS!* % for PRINTX !-ORIGINALFN!* % fluid argument in EMBed function calls !-PRINTXCOUNT!* % Used by PRINTX for making up names for EQ structures !-TRINDENT!* % Current level of indentation of trace output !-VISITED!* % for PRINTX ); !*BTR := T; !*BTRSAVE := T; !*TRACE := T; !*TRCOUNT := T; !*TRSTEXPANDMACROS := T; !-ARBARGNAMES!* := '(A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15); !-ARGINDENT!* := 3; %!-COLONERRNUM!* := 993; % Any ideas of anything particularly appropriate? !-FUNCTIONFLAGS!* := '(EVAL IGNORE LOSE NOCHANGE EXPAND NOEXPAND OPFN DIRECT); !-INDENTCUTOFF!* := 12; !-INDENTDEPTH!* := 2; !-INVISIBLEPROPS!*:= '(TYPE !*LAMBDALINK); !-NONSTANDARDFNS!*:= '(SMACRO NMACRO CMACRO); !-TRACECOUNT!* := 0; !-TRINDENT!* := -1; % It's always incremented BEFORE use !-TRACEFLAG!* := T; !*MSG := T; PPFPRINTER!* := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT; PROPERTYPRINTER!* := IF GETD 'PRETTYPRINT THEN 'PRETTYPRINT ELSE 'PRINT; STUBPRINTER!* := 'PRINTX; STUBREADER!* := IF GETD 'XREAD THEN '!-REDREADER ELSE '!-READ; TRACEMAXLEVEL!* := 10000; % Essentially no limit TRACEMINLEVEL!* := 0; TREXPRINTER!* := IF GETD 'RPRINT THEN 'RPRINT ELSE 'PRETTYPRINT; TRPRINTER!* := 'PRINTX; BrokenFns!* := Nil; TracedFns!* := Nil; % Let TRST know about the behaviour of some common FEXPRs FLAG('( % common FEXPRs which never pass back an unEVALed argument AND LIST MAX MIN OR PLUS PROGN REPEAT TIMES WHILE ),'TRSTINSIDE); DEFLIST ('( % special sorts of FEXPRs (LAMBDA !-TRSTPROG) % Not really a function, but handled by TRST as such (PROG !-TRSTPROG) (SETQ !-TRSTSETQ) (COND !-TRSTCOND) ),'TRSTINSIDEFN); %****************** Utility functions ******************************** % Copy the entrypoints of various key functions so that % nobody gets muddled by trying to trace or redefine them; PUTD('!-APPEND,'EXPR,CDR GETD 'APPEND); PUTD('!-APPLY,'EXPR,CDR GETD 'APPLY); PUTD('!-ATSOC,'EXPR,CDR GETD 'ATSOC); %PUTD('!-CAR,'EXPR,CDR GETD 'CAR); %PUTD('!-CDR,'EXPR,CDR GETD 'CDR); %PUTD('!-CODEP,'EXPR,CDR GETD 'CODEP); PUTD('!-COMPRESS,'EXPR,CDR GETD 'COMPRESS); %PUTD('!-CONS,'EXPR,CDR GETD 'CONS); PUTD('!-EQUAL,'EXPR,CDR GETD 'EQUAL); PUTD('!-ERRORSET,'EXPR,CDR GETD 'ERRORSET); PUTD('!-EVAL,'EXPR,CDR GETD 'EVAL); %PUTD('!-EVLIS,'EXPR,CDR GETD 'EVLIS); PUTD('!-EXPLODE,'EXPR,CDR GETD 'EXPLODE); PUTD('!-FLAG,'EXPR,CDR GETD 'FLAG); PUTD('!-FLAGP,'EXPR,CDR GETD 'FLAGP); PUTD('!-FLUID,'EXPR,CDR GETD 'FLUID); PUTD('!-GET,'EXPR,CDR GETD 'GET); PUTD('!-GETD,'EXPR,CDR GETD 'GETD); %PUTD('!-IDP,'EXPR,CDR GETD 'IDP); PUTD('!-INTERN,'EXPR,CDR GETD 'INTERN); PUTD('!-LENGTH,'EXPR,CDR GETD 'LENGTH); PUTD('!-MAX2,'EXPR,CDR GETD 'MAX2); PUTD('!-MEMQ,'EXPR,CDR GETD 'MEMQ); PUTD('!-MIN2,'EXPR,CDR GETD 'MIN2); PUTD('!-OPEN,'EXPR,CDR GETD 'OPEN); %PUTD('!-PATOM,'EXPR,CDR GETD 'PATOM); PUTD('!-PLUS2,'EXPR,CDR GETD 'PLUS2); PUTD('!-POSN,'EXPR,CDR GETD 'POSN); PUTD('!-PRIN1,'EXPR,CDR GETD 'PRIN1); PUTD('!-PRIN2,'EXPR,CDR GETD 'PRIN2); PUTD('!-PRINC,'EXPR,CDR GETD 'PRINC); PUTD('!-PRINT,'EXPR,CDR GETD 'PRINT); %PUTD('!-PROG,'FEXPR,CDR GETD 'PROG); PUTD('!-PUT,'EXPR,CDR GETD 'PUT); PUTD('!-PUTD,'EXPR,CDR GETD 'PUTD); PUTD('!-READ,'EXPR,CDR GETD 'READ); PUTD('!-REMD,'EXPR,CDR GETD 'REMD); PUTD('!-REMPROP,'EXPR,CDR GETD 'REMPROP); %PUTD('!-RETURN,'EXPR,CDR GETD 'RETURN); PUTD('!-REVERSE,'EXPR,CDR GETD 'REVERSE); %PUTD('!-RPLACA,'EXPR,CDR GETD 'RPLACA); %PUTD('!-RPLACD,'EXPR,CDR GETD 'RPLACD); PUTD('!-SET,'EXPR,CDR GETD 'SET); PUTD('!-TERPRI,'EXPR,CDR GETD 'TERPRI); PUTD('!-WRS,'EXPR,CDR GETD 'WRS); %PUTD('!-ZEROP,'EXPR,CDR GETD 'ZEROP); CompileTime << smacro procedure alias(x, y); macro procedure x u; 'y . cdr u; alias(!-DIFFERENCE, IDifference); alias(!-GREATERP, IGreaterP); alias(!-LESSP, ILessP); alias(!-SUB1, ISub1); alias(!-TIMES2, ITimes2); load Fast!-Vector; alias(!-GETV, IGetV); alias(!-UPBV, ISizeV); %alias(!-ADD1, IAdd1); put('!-add1, 'cmacro , '(lambda (x) (iadd1 x))); >>; lisp procedure !-ADD1 X; % because it gets called from EVAL IAdd1 X; SYMBOLIC PROCEDURE !-LPRIE U; << ERRORPRINTF("***** %L", U); ERFG!* := T >>; SYMBOLIC PROCEDURE !-LPRIM U; !*MSG AND ERRORPRINTF("*** %L", U); PUTD('!-REVERSIP, 'EXPR, CDR GETD 'REVERSIP); PUTD('!-MKQUOTE, 'EXPR, CDR GETD 'MKQUOTE); PUTD('!-EQCAR, 'EXPR, CDR GETD 'EQCAR); PUTD('!-SPACES, 'EXPR, CDR GETD 'SPACES); PUTD('!-SPACES2, 'EXPR, CDR GETD 'SPACES2); PUTD('!-PRIN2T, 'EXPR, CDR GETD 'PRIN2T); SYMBOLIC PROCEDURE !-PAD(L, N); IF FIXP N THEN IF N < !-LENGTH L THEN !-PAD(!-REVERSIP CDR !-REVERSE L, N) ELSE IF N > !-LENGTH L THEN !-PAD(!-APPEND(L, LIST NIL), N) ELSE L ELSE REDERR "!-PAD given nonintegral second arg"; SYMBOLIC PROCEDURE !-IDLISTP L; NULL L OR IDP CAR L AND !-IDLISTP CDR L; SYMBOLIC PROCEDURE !-CIRLIST(U,N); % Returns a circular list consisting of N U's. BEGIN SCALAR A,B; IF NOT !-GREATERP(N,0) THEN RETURN NIL; B := A := U . NIL; FOR I := 2:N DO B := U . B; RETURN RPLACD(A,B) END !-CIRCLIST; SYMBOLIC PROCEDURE !-FIRSTN(N,L); IF N=0 THEN NIL ELSE IF NULL L THEN !-FIRSTN(N,LIST GENSYM()) ELSE CAR L . !-FIRSTN(!-DIFFERENCE(N,1),CDR L); SYMBOLIC PROCEDURE !-LISTOFATOMS L; IF NULL L THEN T ELSE IF IDP CAR L THEN !-LISTOFATOMS CDR L ELSE NIL; SYMBOLIC PROCEDURE !-!-PUTD(NAME,TYPE,BODY); % as PUTD but never compiles, and preserves TRACE property; BEGIN SCALAR COMP,SAVER,BOL; COMP:=!*COMP; % REMEMBER STATE OF !*COMP FLAG; !*COMP:=NIL; % TURN OFF COMPILATION; SAVER:=!-GET(NAME,'TRACE); BOL:=FLAGP(NAME,'LOSE); REMFLAG(LIST NAME,'LOSE); % IGNORE LOSE FLAG; !-REMD NAME; % TO MAKE THE NEXT PUTD QUIET EVEN IF I AM REDEFINING; BODY:=!-PUTD(NAME,TYPE,BODY); IF NOT NULL SAVER THEN !-PUT(NAME,'TRACE,SAVER); !*COMP:=COMP; % RESTORE COMPILATION FLAG; IF BOL THEN FLAG(LIST NAME,'LOSE); RETURN BODY END; %******* Routines for printing looped and shared structures ****** % % MAIN ENTRYPOINT: % % PRINTX (A) % % !-PRINTS THE LIST A. IF !*SAVENAMES IS TRUE CYCLES ARE PRESERVED % BETWEEN CALLS TO !-PRINTS; % PRINTX RETURNS NIL; %VARIABLES USED - % % !-ENTRYPOINTS!* ASSOCIATION LIST OF POINTS WHERE THE LIST % RE-ENTERS ITSELF. VALUE PART OF A-LIST ENTRY % IS NIL IF NODE HAS NOT YET BEEN GIVEN A NAME, % OTHERWISE IT IS THE NAME USED. % % !-VISITED!* LIST OF NODES THAT HAVE BEEN ENCOUNTERED DURING % CURRENT SCAN OF LIST % % !-GLOBALNAMES!* LIKE !-ENTRYPOINTS!*, BUT STAYS ACTIVE BETWEEN CALLS % TO PRINTX % % !-PRINTXCOUNT!* USED TO DECIDE ON A NAME FOR THE NEXT NODE; SYMBOLIC PROCEDURE !-LABELNAME(); BldMsg("%%L%W", !-PRINTXCOUNT!* := !-PLUS2(!-PRINTXCOUNT!*,1)); SYMBOLIC PROCEDURE !-FINDENTRIES A; IF NOT (PAIRP A OR VECTORP A) THEN NIL ELSE IF !-ATSOC(A,!-ENTRYPOINTS!*) THEN NIL ELSE IF !-MEMQ(A,!-VISITED!*) THEN !-ENTRYPOINTS!*:=(A . NIL) . !-ENTRYPOINTS!* ELSE << !-VISITED!*:=A . !-VISITED!*; IF VECTORP A THEN BEGIN SCALAR N, I; I := 0; N := !-UPBV A; WHILE NOT !-GREATERP(I, N) DO << !-FINDENTRIES !-GETV(A,I); I := !-ADD1 I >>; END ELSE << !-FINDENTRIES CAR A; !-FINDENTRIES CDR A >> >>; SYMBOLIC PROCEDURE !-PRINTPASS A; IF NOT (PAIRP A OR VECTORP A) THEN !-PRIN1 A ELSE BEGIN SCALAR W, N, I; IF !-GREATERP(!-POSN(),50) THEN !-TERPRI(); W:=!-ATSOC(A,!-ENTRYPOINTS!*); IF NULL W THEN GO TO ORDINARY; IF CDR W THEN RETURN !-PRIN2 CDR W; RPLACD(W,!-PRIN2 !-LABELNAME()); !-PRIN2 ": "; ORDINARY: IF VECTORP A THEN RETURN << N := !-UPBV A; !-PRINC '![; IF !-GREATERP(N,-1) THEN % perdue fix << !-PRINTPASS !-GETV(A, 0); I := 1; WHILE NOT !-GREATERP(I, N) DO << !-PRINC '! ; !-PRINTPASS !-GETV(A, I); I := !-ADD1 I >> >>; !-PRINC '!] >>; !-PRINC '!(; LOOP: !-PRINTPASS CAR A; A:=CDR A; IF NULL A THEN GOTO NILEND ELSE IF ATOM A THEN GO TO ATOMEND ELSE IF (W:=!-ATSOC(A,!-ENTRYPOINTS!*)) THEN GOTO LABELED; BLANKIT: !-PRINC '! ; GO TO LOOP; LABELED: IF CDR W THEN GOTO REFER; !-PRINC '! ; RPLACD(W,!-PRIN2 !-LABELNAME()); !-PRIN2 ", "; GO TO LOOP; REFER: !-PRIN2 " . "; !-PRIN2 CDR W; GO TO NILEND; ATOMEND: !-PRIN2 " . "; !-PRIN1 A; NILEND: !-PRINC '!); RETURN NIL END; SYMBOLIC PROCEDURE !-PRINS(A,L); BEGIN SCALAR !-VISITED!*,!-ENTRYPOINTS!*,!-PRINTXCOUNT!*; IF ATOM L THEN !-PRINTXCOUNT!*:=0 ELSE << !-PRINTXCOUNT!*:=CAR L; !-ENTRYPOINTS!*:=CDR L >>; !-FINDENTRIES A; !-PRINTPASS A; RETURN (!-PRINTXCOUNT!* . !-ENTRYPOINTS!*) END; SYMBOLIC PROCEDURE PRINTX A; <<IF !*SAVENAMES THEN !-GLOBALNAMES!*:=!-PRINS(A,!-GLOBALNAMES!*) ELSE !-PRINS(A,NIL); !-TERPRI(); NIL >>; %****************** Trace sub-property-list functions ****************** % The property TRACE is removed from any function that is subject % to definition or redefinition by PUTD, and so it represents % a good place to hide information about the function. The following % set of functions run a sub-property-list stored under this % indicator; SYMBOLIC PROCEDURE !-TRGET(ID,IND); !-TRGETX(!-GET(ID,'TRACE),IND); SYMBOLIC PROCEDURE !-TRGETX(L,IND); % L IS A 'PROPERTY LIST' AND IND IS AN INDICATOR; IF NULL L THEN NIL ELSE IF !-EQCAR(CAR L,IND) THEN CDAR L ELSE !-TRGETX(CDR L,IND); SYMBOLIC PROCEDURE !-TRFLAGP(ID,IND); !-MEMQ(IND,!-GET(ID,'TRACE)); SYMBOLIC PROCEDURE !-TRPUT(ID,IND,VAL); !-PUT(ID,'TRACE,!-TRPUTX(!-GET(ID,'TRACE),IND,VAL)); SYMBOLIC PROCEDURE !-TRPUTX(L,IND,VAL); IF !-TRPUTX1(L,IND,VAL) THEN L ELSE (IND . VAL) . L; SYMBOLIC PROCEDURE !-TRPUTX1(L,IND,VAL); BEGIN L: IF NULL L THEN RETURN NIL; IF !-EQCAR(CAR L,IND) THEN << RPLACD(CAR L,VAL); RETURN T >>; L := CDR L; GO TO L END; SYMBOLIC PROCEDURE !-TRFLAG(L,IND); FOR EACH ID IN L DO !-TRFLAG1(ID,IND); SYMBOLIC PROCEDURE !-TRFLAG1(ID,IND); BEGIN SCALAR A; A:=!-GET(ID,'TRACE); IF NOT !-MEMQ(IND,A) THEN !-PUT(ID,'TRACE,IND . A) END; SYMBOLIC PROCEDURE !-TRREMPROP(ID,IND); << IND:=!-TRREMPROPX(!-GET(ID,'TRACE),IND); IF NULL IND THEN !-REMPROP(ID,'TRACE) ELSE !-PUT(ID,'TRACE,IND) >>; SYMBOLIC PROCEDURE !-TRREMPROPX(L,IND); IF NULL L THEN NIL ELSE IF !-EQCAR(CAR L,IND) THEN CDR L ELSE CAR L . !-TRREMPROPX(CDR L,IND); SYMBOLIC PROCEDURE !-TRREMFLAG(L,IND); FOR EACH ID IN L DO !-TRREMFLAG1(ID,IND); SYMBOLIC PROCEDURE !-TRREMFLAG1(ID,IND); << IND:=DELETE(IND,!-GET(ID,'TRACE)); IF NULL IND THEN !-REMPROP(ID,'TRACE) ELSE !-PUT(ID,'TRACE,IND) >>; %******************* Basic functions for TRACE and friends *********** SYMBOLIC PROCEDURE !-TRINSTALL(NAM,ARGNUM); % Sets up TRACE properties for function NAM. This is common to all TRACE-like % actions. Function NAM is redefined to dispatch through !-TRACEDCALL which % takes various actions (which may simply be to run the original function). % Important items stored under the TRACE property include ORIGINALFN, which is % the original definition, FNTYPE, the original function "type" (e.g. EXPR, % MACRO ...), and ARGNAMES, a list of the names of the arguments to NAM. % arguments to the function. Runs TRINSTALLHOOK!* if non-nil. Returns non-nil % if it succeeds, nil if for some reason it fails. BEGIN SCALAR DEFN,CNTR,ARGS,TYP; if Memq (Nam,BrokenFns!*) then << EvUnBr List Nam; BrokenFns!* := DelQ(Nam,BrokenFns!*) >>; DEFN := !-GETD NAM; IF NULL DEFN THEN << !-LPRIM LIST("Function",NAM,"is not defined."); RETURN NIL >>; TYP := CAR DEFN; DEFN := CDR DEFN; IF !-GET(NAM,'TRACE) THEN IF NUMBERP ARGNUM AND TYP EQ 'FEXPR AND !-TRGET(NAM,'FNTYPE) EQ 'EXPR THEN << TYP := 'EXPR; !-TRREMFLAG(LIST NAM,'UNKNOWNARGS); DEFN := !-TRGET(NAM,'ORIGINALFN) >> ELSE RETURN T ELSE IF TRINSTALLHOOK!* AND NOT !-ERRAPPLY(TRINSTALLHOOK!*,LIST NAM,'TRINSTALLHOOK) THEN RETURN NIL; !-TRPUT(NAM,'ORIGINALFN,DEFN); !-TRPUT(NAM,'FNTYPE,TYP); ARGS := !-ARGNAMES(NAM,DEFN,TYP,ARGNUM); IF ARGS EQ 'UNKNOWN THEN << !-TRPUT(NAM,'ARGNAMES,!-ARBARGNAMES!*); !-TRFLAG(LIST NAM,'UNKNOWNARGS) >> ELSE !-TRPUT(NAM,'ARGNAMES,ARGS); CNTR := GENSYM(); !-FLUID LIST CNTR; !-TRPUT(NAM,'LEVELVAR,CNTR); !-SET(CNTR,0); !-TRPUT(NAM,'COUNTER,0); IF ARGS EQ 'UNKNOWN THEN !-!-PUTD(NAM, 'FEXPR, LIST('LAMBDA, '(!-L), LIST(LIST('LAMBDA, LIST(CNTR,'!-TRINDENT!*), LIST('!-TRACEDCALL, !-MKQUOTE NAM, '(!-EVLIS !-L) ) ), LIST('!-ADD1,CNTR), '!-TRINDENT!*) ) ) ELSE !-!-PUTD(NAM, TYP, LIST('LAMBDA, ARGS, LIST(LIST('LAMBDA, LIST(CNTR,'!-TRINDENT!*), LIST('!-TRACEDCALL, !-MKQUOTE NAM, 'LIST . ARGS) ), LIST('!-ADD1,CNTR), '!-TRINDENT!*) ) ); IF NOT !-MEMQ(NAM,!-INSTALLEDFNS!*) THEN !-INSTALLEDFNS!* := NAM . !-INSTALLEDFNS!*; RETURN T END !-TRINSTALL; SYMBOLIC PROCEDURE !-TRINSTALLIST U; FOR EACH V IN U DO !-TRINSTALL(V,NIL); SYMBOLIC PROCEDURE !-ARGNAMES(FN,DEFN,TYPE,NM); % Tries to discover the names of the arguments of FN. NM is a good guess, as % for instance based on the arguments to an EMB procedure. Returns UNKNOWN if % it can't find out. ON TRUNKNOWN will cause it to return UNKNOWN rather than % asking the user. IF !-EQCAR(DEFN,'LAMBDA) THEN % otherwise it must be a code pointer CADR DEFN ELSE IF NOT TYPE EQ 'EXPR THEN LIST CAR !-ARBARGNAMES!* ELSE IF (TYPE:=!-GET(FN,'ARGUMENTS!*)) or (TYPE := code!-number!-of!-arguments DEFN) THEN IF NUMBERP TYPE THEN !-FIRSTN(TYPE,!-ARBARGNAMES!*) ELSE CAR TYPE ELSE IF NUMBERP NM THEN !-FIRSTN(NM,!-ARBARGNAMES!*) ELSE IF !*TRUNKNOWN THEN 'UNKNOWN ELSE !-ARGNAMES1 FN; % BEGIN SCALAR RESULT; % RESULT := ERRORSET(LIST('!-ARGNAMES1,!-MKQUOTE FN),NIL,NIL); % IF PAIRP RESULT THEN % RETURN CAR RESULT % ELSE % ERROR(RESULT,EMSG!*) % END; FLUID '(PROMPTSTRING!*); SYMBOLIC PROCEDURE !-ARGNAMES1 FN; BEGIN SCALAR N, PROMPTSTRING!*; PROMPTSTRING!* := BLDMSG("How many arguments does %r take? ", FN); AGAIN: N:=READ(); IF N='!? THEN << !-TERPRI(); %EXPLAIN OPTIONS; !-PRIN2 "Give a number, a list of atoms (for the names of"; !-TERPRI(); !-PRIN2 "the arguments) or the word 'UNKNOWN'. System security"; !-TERPRI(); !-PRIN2 "will not be good if you say UNKNOWN, but LISP will"; !-TERPRI(); !-PRIN2 "at least try to help you"; !-TERPRI(); % !-PRIN2 "Number of arguments"; GO TO AGAIN >> ELSE IF N='UNKNOWN THEN RETURN N ELSE IF FIXP N AND NOT !-LESSP(N,0) THEN RETURN !-FIRSTN(N,!-ARBARGNAMES!*) ELSE IF !-LISTOFATOMS N THEN RETURN N; !-TERPRI(); !-PRIN2 "*** Please try again, ? will explain options "; GO TO AGAIN END !-ARGNAMES1; SYMBOLIC PROCEDURE !-TRRESTORE U; BEGIN SCALAR BOD,TYP; IF NOT !-GET(U,'TRACE) THEN RETURN; BOD := !-TRGET(U,'ORIGINALFN); TYP := !-TRGET(U,'FNTYPE); IF NULL BOD OR NULL TYP THEN << !-LPRIM LIST("Can't restore",U); RETURN >>; !-REMD U; !-PUTD(U,TYP,BOD); !-REMPROP(U,'TRACE) END !-TRRESTORE; SYMBOLIC PROCEDURE REDEFINED!-PUTD(NAM,TYP,BOD); BEGIN SCALAR ANSWER; REMPROP(NAM,'TRACE); ANSWER := !-PUTD(NAM,TYP,BOD); IF NULL ANSWER THEN RETURN NIL; IF !*TRACEALL OR !*INSTALL THEN !-TRINSTALL(NAM,NIL); IF !*TRACEALL THEN << !-TRFLAG(LIST NAM,'TRPRINT); If Not Memq (NAM, TracedFns!*) then TracedFns!* := NAM . TracedFns!*>>; IF PUTDHOOK!* THEN APPLY(PUTDHOOK!*,LIST NAM); RETURN ANSWER END; PUTD('PUTD, 'EXPR, CDR GETD 'REDEFINED!-PUTD); %FEXPR PROCEDURE DE U; %PUTD(CAR U,'EXPR,'LAMBDA . CADR U . CDDR U); % %FEXPR PROCEDURE DF U; %PUTD(CAR U,'FEXPR,'LAMBDA . CADR U . CDDR U); % %FEXPR PROCEDURE DM U; %PUTD(CAR U,'MACRO,'LAMBDA . CADR U . CDDR U); PUT('TRACEALL,'SIMPFG,'((T (SETQ !*INSTALL T))(NIL (SETQ !*INSTALL NIL)))); PUT('INSTALL,'SIMPFG,'((NIL (SETQ !*TRACEALL NIL)))); %********************************************************************* SYMBOLIC PROCEDURE TROUT U; % U is a filename. Redirects trace output there. << IF MSGCHNL!* THEN CLOSE MSGCHNL!*; MSGCHNL!* := !-OPEN(U,'OUTPUT) >>; SYMBOLIC PROCEDURE STDTRACE; << IF MSGCHNL!* THEN CLOSE MSGCHNL!*; MSGCHNL!* := NIL >>; CompileTime << SYMBOLIC MACRO PROCEDURE !-OUTRACE U; % Main trace output handler. !-OUTRACE(fn,arg1,...argn) calls fn(arg1,...argn) % as appropriate to print trace information. LIST('!-OUTRACE1, 'LIST . MKQUOTE CADR U . FOR EACH V IN CDDR U COLLECT LIST('!-MKQUOTE,V) ); >>; SYMBOLIC PROCEDURE !-OUTRACE1 !-U; BEGIN SCALAR !-STATE; IF !-TRACEBUFF!* THEN << RPLACA(!-TRACEBUFF!*,!-U); !-TRACEBUFF!* := CDR !-TRACEBUFF!* >>; IF !*TRACE THEN << !-STATE := !-ENTERPRI(); !-EVAL !-U; !-EXITPRI !-STATE >> END !-OUTRACE; SYMBOLIC PROCEDURE !-DUMPTRACEBUFF DELFLG; % Prints the ring buffer of saved trace output stored by OUTRACE. % DELFLG non-nil wipes it clean as well. BEGIN SCALAR PTR; IF NOT !-EQUAL(!-POSN(),0) THEN !-TERPRI(); IF NULL !-TRACEBUFF!* THEN << !-PRIN2T "*** No trace information has been saved ***"; RETURN >>; !-PRIN2T "*** Start of saved trace information ***"; PTR := !-TRACEBUFF!*; REPEAT << !-EVAL CAR PTR; IF DELFLG THEN RPLACA(PTR,NIL); PTR := CDR PTR >> UNTIL PTR EQ !-TRACEBUFF!*; !-PRIN2T "*** End of saved trace information ***"; END !-DUMPTRACEBUFF; SYMBOLIC PROCEDURE NEWTRBUFF N; % Makes a new ring buffer for trace output with N entries. << !-TRACEBUFF!* := !-CIRLIST(NIL,N); NIL >>; !-FLAG('(NEWTRBUFF),'OPFN); NEWTRBUFF 5; SYMBOLIC PROCEDURE !-TRACEDCALL(!-NAM,!-ARGS); % Main routine for handling traced functions. Currently saves the number of % invocations of the function, prints trace information, causes EMB and TRST % functions to be handled correctly, calls several hooks, and stacks and % unstacks information in the BTR stack, if appropriate. Examines several % state variables and a number of function specific flags to determine what % must be done. BEGIN SCALAR !-A,!-BOD,!-VAL,!-FLG,!-LOCAL,!-STATE,!-BTRTOP,!-TYP,!-LEV,!-EMB; IF !*TRCOUNT THEN IF !-A := !-TRGET(!-NAM,'COUNTER) THEN !-TRPUT(!-NAM,'COUNTER,!-ADD1 !-A); !-TRACECOUNT!* := !-SUB1 !-TRACECOUNT!*; IF !-LESSP(!-TRACECOUNT!*,1) THEN << !-TRACEFLAG!* := T; IF !-EQUAL(!-TRACECOUNT!*,0) THEN << !-STATE := !-ENTERPRI(); !-PRIN2 "*** TRACECOUNT reached ***"; !-EXITPRI !-STATE >> >>; IF NOT !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRACEWITHIN) THEN << !-TRACEFLAG!* := !-LOCAL := T; !-STATE := !-ENTERPRI(); !-LPRIM LIST("TRACECOUNT =",!-TRACECOUNT!*); !-EXITPRI !-STATE >>; IF TRACENTRYHOOK!* THEN !-FLG := !-ERRAPPLY(TRACENTRYHOOK!*, LIST(!-NAM,!-ARGS), 'TRACENTRYHOOK) ELSE !-FLG := T; !-LEV := !-EVAL !-TRGET(!-NAM,'LEVELVAR); !-FLG := !-FLG AND !-TRACEFLAG!* AND !-TRFLAGP(!-NAM,'TRPRINT) AND NOT(!-LESSP(!-LEV,TRACEMINLEVEL!*) OR !-GREATERP(!-LEV,TRACEMAXLEVEL!*) ); IF !-FLG AND !-TRFLAGP(!-NAM,'TRST) THEN !-BOD := !-TRGET(!-NAM,'TRSTFN) OR !-TRGET(!-NAM,'ORIGINALFN) ELSE !-BOD := !-TRGET(!-NAM,'ORIGINALFN); IF !-FLG THEN << !-TRINDENT!* := !-ADD1 !-TRINDENT!*; !-OUTRACE(!-TRACENTRYPRI,!-NAM,!-ARGS,!-LEV,!-TRINDENT!*) >>; IF !*BTR THEN !-BTRTOP := !-BTRPUSH(!-NAM,!-ARGS); !-TYP := !-TRGET(!-NAM,'FNTYPE); IF NOT(!-TYP EQ 'EXPR) THEN !-ARGS := LIST CAR !-ARGS; IF !-TRFLAGP(!-NAM,'EMB) AND (!-EMB := !-TRGET(!-NAM,'EMBFN)) THEN !-VAL := !-APPLY(!-EMB,!-BOD . !-ARGS) ELSE !-VAL := !-APPLY(!-BOD,!-ARGS); IF !-TYP EQ 'MACRO THEN << IF TRACEXPANDHOOK!* THEN !-ERRAPPLY(TRACEXPANDHOOK!*, LIST(!-NAM,!-VAL), 'TRACEXPANDHOOK); % IF !-FLG THEN % !-OUTRACE(!-TRACEXPANDPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*); % !-VAL := !-EVAL !-VAL >>; IF !*BTR THEN !-BTRPOP !-BTRTOP; IF !-FLG THEN !-OUTRACE(!-TRACEXITPRI,!-NAM,!-VAL,!-LEV,!-TRINDENT!*); IF !-LOCAL AND !-GREATERP(!-TRACECOUNT!*,0) THEN !-TRACEFLAG!* := NIL; IF TRACEXITHOOK!* THEN !-ERRAPPLY(TRACEXITHOOK!*,LIST(!-NAM,!-VAL),'TRACEXITHOOK); RETURN !-VAL END !-TRACEDCALL; SYMBOLIC PROCEDURE !-ERRAPPLY(!-FN,!-ARGS,!-NAM); BEGIN SCALAR !-ANS,!-CHN; !-ANS := !-ERRORSET(LIST('!-APPLY,!-FN,!-ARGS),T,!*BACKTRACE); IF ATOM !-ANS THEN << !-CHN := !-WRS MSGCHNL!*; !-PRIN2 "***** Error occured evaluating "; !-PRIN2 !-NAM; !-PRIN2 " *****"; !-TERPRI(); !-WRS !-CHN; RETURN !-ANS >> ELSE RETURN CAR !-ANS END !-ERRAPPLY; %************ Routines for printing trace information *************** SYMBOLIC PROCEDURE TRACECOUNT N; % Suppresses TRACE output until N traced function invocations have passed. BEGIN SCALAR OLD; OLD:=!-TRACECOUNT!*; IF NUMBERP N THEN << !-TRACECOUNT!*:=N; IF !-GREATERP(N,0) THEN !-TRACEFLAG!*:=NIL ELSE !-TRACEFLAG!*:=T >>; RETURN OLD END; !-FLAG('(TRACECOUNT),'OPFN); SYMBOLIC PROCEDURE TRACEWITHIN L; % L is a list of function names. Forces tracing to be enabled within them. << !-TRFLAG(L,'TRACEWITHIN); IF NOT !-GREATERP(!-TRACECOUNT!*,0) THEN << !-TRACECOUNT!*:=100000; !-TRACEFLAG!*:=NIL; !-LPRIM "TRACECOUNT set to 100000" >>; FOR EACH U IN L CONC IF !-TRINSTALL(U,NIL) THEN LIST U >>; SYMBOLIC PROCEDURE TRACE L; % Enables tracing on each function in the list L. FOR EACH FN IN L CONC IF !-TRINSTALL(FN,NIL) THEN << !-TRFLAG(LIST FN,'TRPRINT); If Not Memq (FN, TracedFns!*) then TracedFns!* := FN . TracedFns!*; LIST FN >>; SYMBOLIC PROCEDURE UNTRACE L; % Disables tracing for each function in the list L. FOR EACH FN IN L CONC << !-TRREMFLAG(LIST FN,'TRACEWITHIN); !-TRREMFLAG(LIST FN,'TRST); IF !-TRFLAGP(FN,'TRPRINT) THEN << !-TRREMFLAG(LIST FN,'TRPRINT); FN >> ELSE << !-LPRIM LIST("Function",FN,"was not traced."); NIL >> >>; SYMBOLIC PROCEDURE !-ENTERPRI; BEGIN SCALAR !-CHN,!-PSN; !-CHN := !-WRS MSGCHNL!*; !-PSN := !-POSN(); IF !-GREATERP(!-PSN,0) THEN << !-PRIN2 '!< ; !-TERPRI() >>; RETURN !-CHN . !-PSN END !-ENTERPRI; SYMBOLIC PROCEDURE !-EXITPRI !-STATE; BEGIN SCALAR !-PSN; !-PSN := CDR !-STATE; IF !-GREATERP(!-PSN,0) THEN << IF NOT !-LESSP(!-POSN(),!-PSN) THEN !-TERPRI(); !-SPACES2 !-SUB1 !-PSN; !-PRIN2 '!> >> ELSE IF !-GREATERP(!-POSN(),0) THEN !-TERPRI(); !-WRS CAR !-STATE END; SYMBOLIC PROCEDURE !-TRINDENT !-INDNT; BEGIN SCALAR !-N; !-N := !-TIMES2(!-INDNT,!-INDENTDEPTH!*); IF NOT !-GREATERP(!-N,!-INDENTCUTOFF!*) THEN !-SPACES2 !-N ELSE << !-SPACES2 !-INDENTCUTOFF!*; !-PRIN2 '!* >> END !-TRINDENT; SYMBOLIC PROCEDURE !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); << !-TRINDENT !-INDNT; !-PRIN1 !-NAM; IF !-GREATERP(!-LEV,1) THEN << !-PRIN2 " (level "; !-PRIN2 !-LEV; !-PRIN2 '!) >> >>; SYMBOLIC PROCEDURE !-TRACENTRYPRI(!-NAM,!-ARGS,!-LEV,!-INDNT); % Handles printing trace information at entry to a function. !-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT," being entered"); SYMBOLIC PROCEDURE !-TRACENTRYPRI1(!-NAM,!-ARGS,!-LEV,!-INDNT,!-S); BEGIN SCALAR !-ARGNAMS; !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 !-S; !-TERPRI(); !-ARGNAMS := !-TRGET(!-NAM,'ARGNAMES); WHILE !-ARGS DO << !-TRINDENT !-INDNT; !-SPACES !-ARGINDENT!*; IF !-ARGNAMS THEN << !-PRIN2 CAR !-ARGNAMS; !-ARGNAMS := CDR !-ARGNAMS >> ELSE !-PRIN2 '!?!?!?!? ; !-PRIN2 ": "; APPLY(TRPRINTER!*,LIST CAR !-ARGS); !-ARGS := CDR !-ARGS; IF !-ARGS AND NOT !-POSN() = 0 THEN !-TERPRI() >>; END !-TRACENTRYPRI; SYMBOLIC PROCEDURE !-TRACEXPANDPRI(!-NAM,!-EXP,!-LEV,!-INDNT); % Prints macro expansions. << !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 " MACRO expansion = "; APPLY(TREXPRINTER!*,LIST !-EXP) >>; SYMBOLIC PROCEDURE !-TRACEXITPRI(!-NAM,!-VAL,!-LEV,!-INDNT); % Prints information upon exiting a function. << !-TRACEPRI1(!-NAM,!-LEV,!-INDNT); !-PRIN2 " = "; APPLY(TRPRINTER!*,LIST !-VAL) >>; %*************** TRST functions *********************************** SYMBOLIC PROCEDURE TRACESET L; BEGIN SCALAR DFN; RETURN FOR EACH FN IN L CONC IF !-TRINSTALL(FN,NIL) THEN << !-TRFLAG(LIST FN,'TRPRINT); If Not Memq (FN, TracedFns!*) then TracedFns!* := FN . TracedFns!*; DFN := !-TRGET(FN,'ORIGINALFN); IF CODEP DFN THEN << !-LPRIM LIST("Function",FN,"is compiled. It cannot be traceset."); NIL >> ELSE << !-TRFLAG(LIST FN,'TRST); IF NOT !-TRGET(FN,'TRSTFN) THEN !-TRPUT(FN,'TRSTFN,!-MKTRST DFN); LIST FN >> >> END TRACESET; SYMBOLIC PROCEDURE UNTRACESET L; FOR EACH FN IN L CONC IF !-TRFLAGP(FN,'TRST) THEN << !-TRREMFLAG(LIST FN,'TRST); LIST FN >> ELSE << !-LPRIM LIST("Function",FN,"was not traceset."); NIL >>; SYMBOLIC PROCEDURE !-TRSTPRI(!-NAM,!-VAL); << !-OUTRACE(!-TRSTPRI1,!-NAM,!-VAL,!-TRINDENT!*); !-VAL >>; SYMBOLIC PROCEDURE !-TRSTPRI1(!-NAM,!-VAL,!-INDNT); BEGIN SCALAR !-STATE; !-STATE := !-ENTERPRI(); !-TRINDENT !-INDNT; !-PRIN2 !-NAM; !-PRIN2 " := "; APPLY(TRPRINTER!*,LIST !-VAL); !-EXITPRI !-STATE; END !-TRSTPRI; SYMBOLIC PROCEDURE !-MKTRST U; BEGIN SCALAR V; IF ATOM U THEN RETURN U; IF !-FLAGP(CAR U,'TRSTINSIDE) THEN RETURN !-MKTRST1 U; IF V := !-GET(CAR U,'TRSTINSIDEFN) THEN RETURN APPLY(V,LIST U); IF IDP CAR U AND (V := !-GETD CAR U) THEN << V := CAR V; IF V EQ 'FEXPR THEN RETURN U; IF V EQ 'MACRO THEN IF !*TRSTEXPANDMACROS THEN RETURN !-MKTRST APPLY(CAR U,LIST U) ELSE RETURN U >>; RETURN !-MKTRST1 U END; SYMBOLIC PROCEDURE !-MKTRST1 U; FOR EACH V IN U COLLECT !-MKTRST V; % Functions for TRSTing certain special functions SYMBOLIC PROCEDURE !-TRSTSETQ U; IF ATOM CDR U OR ATOM CDDR U THEN !-LPRIE LIST("Malformed expression",U) ELSE LIST(CAR U,CADR U,LIST('!-TRSTPRI,!-MKQUOTE CADR U,!-MKTRST CADDR U)); symbolic procedure !-TrstCond u; cons(car u, for each v in cdr u collect !-MkTrST1 v); SYMBOLIC PROCEDURE !-TRSTPROG U; IF ATOM CDR U THEN !-LPRIE LIST("Malformed expression",U) ELSE CAR U . CADR U . !-MKTRST1 CDDR U; %****************** Heavy handed backtrace routines ******************* SYMBOLIC PROCEDURE !-BTRPUSH(!-NAM,!-ARGS); BEGIN SCALAR !-OSTK; !-OSTK := !-BTRSTK!*; !-BTRSTK!* := (!-NAM . !-ARGS) . !-OSTK; RETURN !-OSTK END !-BTRPUSH; SYMBOLIC PROCEDURE !-BTRPOP !-PTR; BEGIN SCALAR !-A; IF !*BTRSAVE AND NOT(!-PTR EQ CDR !-BTRSTK!*) THEN << WHILE !-BTRSTK!* AND NOT(!-PTR EQ !-BTRSTK!*) DO << !-A := CAR !-BTRSTK!* . !-A; !-BTRSTK!* := CDR !-BTRSTK!* >>; IF NOT(!-PTR EQ !-BTRSTK!*) THEN << !-TERPRI(); !-PRIN2 "***** Internal error in DEBUG: BTR stack underflow *****"; !-TERPRI() >>; !-BTRSAVEDINTERVALS!* := !-A . !-BTRSAVEDINTERVALS!* >> ELSE !-BTRSTK!* := !-PTR END !-BTRPOP; SYMBOLIC PROCEDURE !-BTRDUMP; BEGIN SCALAR STK; STK := !-BTRSTK!*; IF NOT (!-POSN() = 0) THEN !-TERPRI(); IF NULL STK AND NOT(!*BTRSAVE AND !-BTRSAVEDINTERVALS!*) THEN << !-PRIN2T "*** No traced functions were left abnormally ***"; RETURN >>; !-PRIN2T "*** Backtrace: ***"; IF STK THEN << !-PRIN2T "These functions were left abnormally:"; REPEAT << !-TRACENTRYPRI1(CAAR STK,CDAR STK,1,1,""); STK := CDR STK >> UNTIL NULL STK >>; IF !*BTRSAVE THEN FOR EACH U IN !-BTRSAVEDINTERVALS!* DO << !-PRIN2T "These functions were left abnormally, but without"; !-PRIN2T "returning to top level:"; FOR EACH V IN U DO !-TRACENTRYPRI1(CAR V,CDR V,1,1,"") >>; !-PRIN2T "*** End of backtrace ***" END !-BTRDUMP; SYMBOLIC PROCEDURE BTRACE L; << !*BTR := T; !-BTRNEWSTK(); FOR EACH U IN L CONC IF !-TRINSTALL(U,NIL) THEN LIST U >>; SYMBOLIC PROCEDURE !-BTRNEWSTK; !-BTRSTK!* := !-BTRSAVEDINTERVALS!* := NIL; !-BTRNEWSTK(); PUT('BTR,'SIMPFG,'((NIL (!-BTRNEWSTK))(T (!-BTRNEWSTK)))); %********************* Embed functions **************************** SYMBOLIC PROCEDURE !-EMBSUBST(NAM,FN,NEW); IF ATOM FN OR CAR FN EQ 'QUOTE THEN FN ELSE IF CAR FN EQ NAM THEN NEW . '!-ORIGINALFN!* . CDR FN ELSE FOR EACH U IN FN COLLECT !-EMBSUBST(NAM,U,NEW); SYMBOLIC MACRO PROCEDURE !-EMBCALL !-U; LIST('!-APPLY,CADR !-U,'LIST . CDDR !-U); SYMBOLIC PROCEDURE EMBFN(NAM,VARS,BOD); BEGIN SCALAR EMBF; IF !*DEFN THEN << % For REDUCE; OUTDEF LIST('EMBFN,!-MKQUOTE NAM,!-MKQUOTE VARS,!-MKQUOTE BOD); RETURN >>; IF !-TRINSTALL(NAM,!-LENGTH VARS) THEN << EMBF := !-TRGET(NAM,'EMBFN); EMBF := LIST('LAMBDA, '!-ORIGINALFN!* . VARS, !-EMBSUBST(NAM,BOD,IF EMBF THEN EMBF ELSE '!-EMBCALL) ); !-TRPUT(NAM,'EMBFN,EMBF); !-TRFLAG(LIST NAM,'EMB); RETURN !-MKQUOTE NAM >> END; SYMBOLIC PROCEDURE EMBEDFNS U; FOR EACH X IN U CONC IF !-TRGET(X,'EMBFN) THEN << X := LIST X; !-TRFLAG(X,'EMB); X >> ELSE << !-LPRIM LIST("Procedure",X,"has no EMB definition"); NIL >>; SYMBOLIC PROCEDURE UNEMBEDFNS U; FOR EACH X IN U CONC IF !-TRFLAGP(X,'EMB) THEN << X := LIST X; !-TRREMFLAG(X,'EMB); X >>; %***************** Function call histogram routines ************* SYMBOLIC PROCEDURE !-HISTOGRAM; % Simplistic histogram routine for number of function calls. BEGIN INTEGER M,N,NM; SCALAR NAM,NMS,NEW; IF !-GETD 'TREESORT THEN % If REDIO is available !-INSTALLEDFNS!* := MSORT !-INSTALLEDFNS!*; !-TERPRI(); !-TERPRI(); N := 0; FOR EACH U IN !-INSTALLEDFNS!* DO IF !-GET(U,'TRACE) THEN << N := !-MAX2(!-TRGET(U,'COUNTER),N); NEW := U . NEW >>; !-INSTALLEDFNS!* := NEW; N := FLOAT(LINELENGTH NIL - 21) / FLOAT N; FOR EACH U IN !-INSTALLEDFNS!* DO << NAM := !-EXPLODE U; NM := !-TRGET(U,'COUNTER); NMS := !-EXPLODE NM; M := !-MIN2(LENGTH NAM,17-LENGTH NMS); FOR I := 1:M DO << !-PRINC CAR NAM; NAM := CDR NAM >>; !-PRINC '!( ; WHILE NMS DO << !-PRINC CAR NMS; NMS := CDR NMS >>; !-PRINC '!) ; !-SPACES2 20; FOR I := FIX(NM*N) STEP -1 UNTIL 1 DO !-PRINC '!* ; !-TERPRI() >>; !-TERPRI(); !-TERPRI() END !-HISTOGRAM; SYMBOLIC PROCEDURE !-CLEARCOUNT; BEGIN SCALAR NEWVAL; FOR EACH U IN !-INSTALLEDFNS!* DO IF !-GET(U,'TRACE) THEN << !-TRPUT(U,'COUNTER,0); NEWVAL := U . NEWVAL >>; !-INSTALLEDFNS!* := NEWVAL END !-CLEARCOUNT; % SIMPFG so ON/OFF TRCOUNT will do a histogram PUT('TRCOUNT,'SIMPFG,'((T (!-CLEARCOUNT)) (NIL (!-HISTOGRAM)))); %************************ TRACE related statements ********************* %SYMBOLIC PROCEDURE TRSTAT; %% Nearly the same as RLIS2, but allows zero or more args rather than one or %% more. %BEGIN SCALAR NAM,ARGS; % NAM := CURSYM!*; % IF FLAGP!*!*(SCAN(),'DELIM) THEN % RETURN LIST(NAM,NIL); % RETURN LOOP << % ARGS := MKQUOTE CURSYM!* . ARGS; % IF FLAGP!*!*(SCAN(),'DELIM) THEN % EXIT LIST(NAM,'LIST . REVERSIP ARGS) % ELSE IF CURSYM!* NEQ '!*COMMA!* THEN % SYMERR("Syntax Error",NIL); % SCAN() >> %END TRSTAT; SYMBOLIC PROCEDURE !-TR1(L,FN); BEGIN SCALAR X; !-SLOWLINKS(); X := APPLY(FN,LIST L); IF !*MODE EQ 'ALGEBRAIC THEN << % For REDUCE; !-TERPRI(); !-PRINT X >> ELSE RETURN X END; MACRO PROCEDURE TR U; LIST('EVTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTR U; IF U THEN !-TR1(U,'TRACE) ELSE !-DUMPTRACEBUFF NIL; MACRO PROCEDURE UNTR U; LIST('EVUNTR, MKQUOTE CDR U); procedure UnTrAll(); <<EvUnTr TracedFns!*; TracedFns!* := Nil>>; SYMBOLIC PROCEDURE EVUNTR U; BEGIN SCALAR L; IF U THEN <<!-TR1(U,'UNTRACE); Foreach L in U do TracedFns!*:=DelQ(L,TracedFns!*)>> ELSE << !-TRACEFLAG!* := NIL; !-LPRIM "TRACECOUNT set to 10000"; !-TRACECOUNT!* := 10000 >>; END; MACRO PROCEDURE RESTR U; LIST ('EVRESTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVRESTR U; BEGIN SCALAR L; IF U THEN <<FOR EACH L IN U DO !-TRRESTORE L; !-INSTALLEDFNS!* := DELQ (L,!-INSTALLEDFNS!*); TRACEDFNS!* := DELQ (L,TRACEDFNS!*)>> ELSE << FOR EACH U IN !-INSTALLEDFNS!* DO !-TRRESTORE U; !-INSTALLEDFNS!* := NIL; TRACEDFNS!* := NIL>>; END; MACRO PROCEDURE TRIN U; LIST('EVTRIN, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRIN U; !-TR1(U,'TRACEWITHIN); MACRO PROCEDURE TRST U; LIST('EVTRST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRST U; !-TR1(U,'TRACESET); MACRO PROCEDURE UNTRST U; LIST('EVUNTRST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVUNTRST U; !-TR1(U,'UNTRACESET); MACRO PROCEDURE BTR U; LIST('EVBTR, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVBTR U; IF U THEN !-TR1(U,'BTRACE) ELSE !-BTRDUMP(); SYMBOLIC PROCEDURE RESBTR; !-BTRNEWSTK(); MACRO PROCEDURE EMBED U; LIST('EVEMBED, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVEMBED U; !-TR1(U,'EMBEDFNS); MACRO PROCEDURE UNEMBED U; LIST('EVUNEMBED, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVUNEMBED U; !-TR1(U,'UNEMBEDFNS); MACRO PROCEDURE TRCNT U; LIST('EVTRCNT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVTRCNT U; !-TR1(U,'!-TRINSTALLIST); IF NOT FUNBOUNDP 'DEFINEROP THEN << RLISTAT('(TR UNTR TRIN TRST UNTRST BTR EMBED UNEMBED TRCNT RESTR FSTUB STUB PLIST PPF), 'NOQUOTE); RLISTAT('(TROUT), 'NOQUOTE); DEFINEROP('RESBTR,NIL,ESTAT('RESBTR)); DEFINEROP('STDTRACE,NIL,ESTAT('STDTRACE)); >>; %DEFLIST('( % (TR TRSTAT) % (UNTR RLIS2) % (TRIN RLIS2) % (TRST RLIS2) % (UNTRST RLIS2) % (BTR TRSTAT) % (EMBED RLIS2) % (UNEMBED RLIS2) % (TRCNT RLIS2) % (RESBTR ENDSTAT) % (RESTR RLIS2) % (STDTRACE ENDSTAT) % (TROUT IOSTAT) % ), 'STAT); FLAG('(TR UNTR BTR),'GO); FLAG('(TR TRIN UNTR TRST UNTRST BTR EMBED UNEMBED RESBTR RESTR TRCNT TROUT STDTRACE), 'IGNORE); %******************Break Functions*********************************** fluid '(ArgLst!* % Default names for args in traced code TrSpace!* % Number spaces to indent !*NoTrArgs % Control arg-trace ); CompileTime flag('(TrMakeArgList), 'InternalFunction); lisp procedure TrMakeArgList N; % Get Arglist for N args cdr Assoc(N, ArgLst!*); LoadTime << ArgLst!* := '((0 . ()) (1 . (X1)) (2 . (X1 X2)) (3 . (X1 X2 X3)) (4 . (X1 X2 X3 X4)) (5 . (X1 X2 X3 X4 X5)) (6 . (X1 X2 X3 X4 X5 X6)) (7 . (X1 X2 X3 X4 X5 X6 X7)) (8 . (X1 X2 X3 X4 X5 X6 X7 X8)) (9 . (X1 X2 X3 X4 X5 X6 X7 X8 X9)) (10 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10)) (11 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11)) (12 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12)) (13 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13)) (14 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14)) (15 . (X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15))); TrSpace!* := 0; !*NoTrArgs := NIL >>; Fluid '(ErrorForm!* !*ContinuableError); lisp procedure Br!.Prc(PN, B, A); % Called in place of "Broken" code % % Called by BREAKFN for proc nam PN, body B, args A; % begin scalar K, SvArgs, VV, Numb, Result; TrSpace!* := TrSpace!* + 1; Numb := Min(TrSpace!*, 15); Tab Numb; PrintF("%p %w:", PN, TrSpace!*); if not !*NoTrArgs then << SvArgs := A; K := 1; while SvArgs do << PrintF(" Arg%w:=%p, ", K, car SvArgs); SvArgs := cdr SvArgs; K := K + 1 >> >>; TerPri(); ErrorForm!* := NIL; PrintF(" BREAK before entering %r%n",PN); !*ContinuableError:=T; Break(); VV := Apply(B, A); PrintF(" BREAK after call %r, value %r%n",PN,VV); ErrorForm!* := MkQuote VV; !*ContinuableError:=T; Result:=Break(); Tab Numb; PrintF("%p %w:=%p%n", PN, TrSpace!*, Result); TrSpace!* := TrSpace!* - 1; return Result end; fluid '(!*Comp PromptString!*); lisp procedure Br!.1 Nam; % Called To Break a single function begin scalar PN, X, Y, Bod, Args, N, OldIn, OldPrompt, !*Comp; if not (Y:=GetD Nam) then << ErrorPrintF("*** %r is not a defined function and cannot be BROKEN", Nam); return >>; if Memq (Nam,TracedFns!*) or Memq (Nam,!-InstalledFns!*) then <<!-TrRestore Nam; Y:=GetD Nam; !-InstalledFns!*:=DelQ(Nam,!-InstalledFns!*); TracedFns!*:=DelQ(Nam,TracedFns!*)>>; if Not Memq (Nam,BrokenFns!*) then BrokenFns!*:=Cons(Nam, BrokenFns!*); PN := GenSym(); !-!-PutD(PN, car Y, cdr Y); put(Nam, 'OldCod, Y . get(Nam, 'OldCod)); if EqCar(cdr Y, 'LAMBDA) then Args := cadr cdr Y else if (N:=Code!-Number!-Of!-Arguments Cdr Y) then Args := TrMakeArgList N else << OldPrompt := PromptString!*; PromptString!* := BldMsg("How many arguments for %r?", Nam); OldIn := RDS NIL; while not NumberP(N := Read()) or N < 0 or N > 15 do ; PromptString!* := OldPrompt; RDS OldIn; Args := TrMakeArgList N >>; Bod:= list('LAMBDA, Args, list('Br!.prc, MkQuote Nam, MkQuote PN, 'LIST . Args)); !-!-PutD(Nam, car Y, Bod); put(Nam, 'BreakCode, cdr GetD Nam); end; lisp procedure UnBr!.1 Nam; begin scalar X, Y, !*Comp; if not IDP Nam or not PairP(X := get(Nam, 'OldCod)) or not PairP(Y := GetD Nam) or not (cdr Y eq get(Nam, 'BreakCode)) then << ErrorPrintF("*** %r cannot be unbroken", Nam); return >>; !-!-PutD(Nam, caar X, cdar X); RemProp(Nam, 'OldCod); RemProp(Nam, 'Breakcode); BrokenFns!*:=DelQ(Nam,BrokenFns!*); end; macro procedure Br L; %. Break functions in L list('EvBr, MkQuote cdr L); expr procedure EvBr L; Begin; for each X in L do Br!.1 X; Return L end; macro procedure UnBr L; %. Unbreak functions in L list('EvUnBr, MkQuote cdr L); expr procedure EvUnBr L; for each X in L do UnBr!.1 X; expr procedure UnBrAll(); <<EvUnBr BrokenFns!*; BrokenFns!* := Nil>>; %************************ Stubs ************************************* % These procedures implement stubs for Rlisp/Reduce. Usage is "STUB % <model function invocation> [,<model function invocation>]* % <semicol>". For example, to declare function FOO, BAR, and BLETCH % with formal parameters X,Y,Z for FOO, U for BAR, and none for BLETCH % do "STUB FOO(X,Y,Z),BAR U, BLETCH();". When a stub is executed it % announces its invocation, prettyprints its arguments, and asks for % the value to return. Fexpr stubs may be declared with the analogous % statement FSTUB. MACRO PROCEDURE STUB U; LIST('EVSTUB, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVSTUB FNLIS; FOR EACH Y IN FNLIS DO IF NOT PAIRP Y THEN IF NOT IDP Y THEN !-LPRIE "Function name must be an ID" ELSE << !-LPRIM LIST("Stub",Y,"declared as a function of zero arguments"); !-MKSTUB(Y,NIL,'EXPR) >> ELSE IF NOT IDP CAR Y THEN !-LPRIE "Function name must be an ID" ELSE IF NOT !-IDLISTP CDR Y THEN !-LPRIE "Formal parameter must be an ID" ELSE !-MKSTUB(CAR Y,CDR Y,'EXPR); MACRO PROCEDURE FSTUB U; LIST('EVFSTUB, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVFSTUB FNLIS; FOR EACH Y IN FNLIS DO IF NOT PAIRP Y THEN !-LPRIE "Arguments to FSTUB must be model function calls" ELSE IF NOT IDP CAR Y THEN !-LPRIE "Function name must be an ID" ELSE IF NOT !-IDLISTP CDR Y THEN !-LPRIE "Formal parameter must be an ID" ELSE IF !-LENGTH CDR Y NEQ 1 THEN !-LPRIE "An FEXPR must have exactly one formal parameter" ELSE !-MKSTUB(CAR Y, CDR Y, 'FEXPR); SYMBOLIC PROCEDURE !-MKSTUB(NAME, VARLIS, TYPE); PUTD(NAME, TYPE, LIST('LAMBDA, VARLIS, LIST('!-STUB1, !-MKQUOTE NAME, !-MKQUOTE VARLIS, 'LIST . VARLIS, !-MKQUOTE TYPE) ) ); SYMBOLIC PROCEDURE !-STUB1(!-PNAME, !-ANAMES, !-AVALS, !-TYPE); % Weird variable names because of call to EVAL. BEGIN INTEGER !-I; IF !-TYPE NEQ 'EXPR THEN !-PRIN2 !-TYPE; !-PRIN2 " Stub "; !-PRIN2 !-PNAME; !-PRIN2 " called"; !-TERPRI(); !-TERPRI(); !-I := 1; FOR EACH !-U IN PAIR(!-PAD(!-ANAMES,!-LENGTH !-AVALS),!-AVALS) DO << IF CAR !-U THEN !-PRIN2 CAR !-U ELSE << !-SET(!-INTERN !-COMPRESS !-APPEND('(A R G),!-EXPLODE !-I), CDR !-U); !-PRIN2 "Arg #"; !-PRIN2 !-I >>; !-PRIN2 ": "; APPLY(STUBPRINTER!*, LIST CDR !-U); !-I := !-I + 1 >>; !-PRIN2T "Return? :"; RETURN !-EVAL APPLY(STUBREADER!*,NIL) END; SYMBOLIC PROCEDURE !-REDREADER; XREAD NIL; %*************** Functions for printing useful information ************* MACRO PROCEDURE PLIST U; LIST('EVPLIST, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVPLIST U; % Prints the property list and flags of U in a descent format, % prettyprinting nasty things. Does not print properties in the % global list !-INVISIBLEPROPS!* or flags in !-INVISIBLEFLAGS!*. Usage is % "PLIST <id> [,<id>]* <semicol>". << !-TERPRI(); FOR EACH V IN U CONC IF V := !-PLIST1 V THEN LIST V >>; SYMBOLIC PROCEDURE !-PLIST1 U; BEGIN SCALAR PLST,FLGS,HASPROPS; !-TERPRI(); IF NOT IDP U THEN << !-LPRIE LIST(U,"is not an ID"); RETURN NIL >>; PLST := !-GETPROPERTYLIST U; % System dependent kludge FOR EACH V IN PLST DO IF ATOM V AND NOT !-MEMQ(V,!-INVISIBLEFLAGS!*) THEN FLGS := V . FLGS ELSE IF NOT !-MEMQ(CAR V,!-INVISIBLEPROPS!*) THEN << IF NOT HASPROPS THEN << HASPROPS := T; !-PRIN2 "Properties for "; !-PRIN1 U; !-PRIN2T ":"; !-TERPRI() >>; !-SPACES 4; !-PRIN1 CAR V; !-PRIN2 ":"; !-SPACES 2; !-SPACES2 15; APPLY(PROPERTYPRINTER!*,LIST CDR V) >>; IF FLGS THEN << IF HASPROPS THEN !-PRIN2 "Flags: " ELSE << !-PRIN2 "Flags for "; !-PRIN1 U; !-PRIN2 ": " >>; FOR EACH V IN FLGS DO << !-PRIN1 V; !-SPACES 1 >>; !-TERPRI(); !-TERPRI() >> ELSE IF NOT HASPROPS THEN << !-PRIN2 "No Flags or Properties for "; !-PRINT U; !-TERPRI() >>; IF HASPROPS OR FLGS THEN RETURN U END !-PLIST1; MACRO PROCEDURE PPF U; LIST('EVPPF, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVPPF FLIS; % Pretty prints one or more function definitions, from their % names. Usage is "PPF <name> [,<name>]* <semicol>". << !-TERPRI(); FOR EACH FN IN FLIS CONC IF FN := !-PPF1 FN THEN LIST FN >>; SYMBOLIC PROCEDURE !-PPF1 FN; BEGIN SCALAR BOD,TYP,ARGS,TRC,FLGS; IF !-GET(FN,'TRACE) THEN << BOD := !-TRGET(FN,'ORIGINALFN); IF NOT CODEP BOD THEN BOD := CADDR BOD; TYP := !-TRGET(FN,'FNTYPE); IF NOT !-TRFLAGP(FN,'UNKNOWNARGS) THEN ARGS := !-TRGET(FN,'ARGNAMES); IF !-TRFLAGP(FN,'TRST) THEN TRC := 'TraceSet . TRC ELSE IF !-TRFLAGP(FN,'TRPRINT) THEN TRC := 'Traced . TRC; IF !-TRFLAGP(FN,'TRACEWITHIN) THEN TRC := 'TracedWithin . TRC; IF !-TRFLAGP(FN,'EMB) THEN TRC := 'Embeded . TRC; IF NULL TRC THEN TRC := '(Installed) >> ELSE IF BOD := !-GETC FN THEN << TYP := CAR BOD; BOD := CDR BOD; IF NOT CODEP BOD THEN << ARGS := CADR BOD; BOD := CDDR BOD >> >> ELSE << !-LPRIE LIST("Procedure",FN,"is not defined."); RETURN NIL >>; FOR EACH U IN !-FUNCTIONFLAGS!* DO IF !-FLAGP(FN,U) THEN FLGS := U . FLGS; IF NOT (!-POSN() = 0) THEN !-TERPRI(); !-TERPRI(); !-PRIN2 TYP; !-PRIN2 " procedure "; !-PRIN1 FN; IF ARGS THEN << !-PRIN2 '!( ; FOR EACH U ON ARGS DO << !-PRIN1 CAR U; IF CDR U THEN !-PRIN2 '!, >>; !-PRIN2 '!) >>; IF TRC OR FLGS THEN << !-PRIN2 " ["; FOR EACH U IN !-REVERSIP TRC DO << !-PRIN2 U; !-PRIN2 '!; >>; IF TRC THEN << !-PRIN2 "Invoked "; !-PRIN2 !-TRGET(FN,'COUNTER); !-PRIN2 " times"; IF FLGS THEN !-PRIN2 '!; >>; IF FLGS THEN << !-PRIN2 "Flagged: "; FOR EACH U ON FLGS DO << !-PRIN1 CAR U; IF CDR U THEN !-PRIN2 '!, >> >>; !-PRIN2 '!] >>; IF CODEP BOD THEN << !-PRIN2 " is compiled ("; !-PRIN2 BOD; !-PRIN2T ")." >> ELSE << !-PRIN2T '!: ; FOR EACH FORM IN BOD DO APPLY(PPFPRINTER!*,LIST FORM); !-TERPRI() >>; RETURN FN END !-PPF1; SYMBOLIC PROCEDURE !-GETC U; % Like GETD, but also looks for non-standard functions, such as % SMACROs. The only non-standard functions looked for are those whose % tags appear in the list NONSTANDARDFNS!*. BEGIN SCALAR X,Y; X := !-NONSTANDARDFNS!*; Y := !-GETD U; WHILE X AND NOT Y DO << Y := !-GET(U,CAR X); IF Y THEN Y := CAR X . Y; X := CDR X >>; RETURN Y END !-GETC; FLAG('(PPF PLIST), 'IGNORE); END; |
Added psl-1983/util/defstruct.build version [335ac41f39].
> > > > > | 1 2 3 4 5 | CompileTime << load Defstruct; off UserMode; >>; in "defstruct.red"$ |
Added psl-1983/util/defstruct.examples-red version [fdcfbef5c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % (Do definitions twice to see what functions were defined.) macro procedure TWICE u; list( 'PROGN, second u, second u ); % A definition of Complex, structure with Real and Imaginary parts. % Give 0 Init values. TWICE Defstruct( Complex( !:Creator(Complex) ), R(0), I(0) ); C0 := MakeComplex(); % Constructor with default inits. ComplexP C0; % Predicate. C1:=MakeComplex( R 1, I 2 ); % Constructor with named values. R(C1); I(C1); % Named selectors. C2:=Complex(3,4); % Creator with positional values. AlterComplex( C1, R(2), I(3) ); % Alterant with named values. C1; R(C1):=5; I(C1):=6; % Named depositors. C1; % Show use of Include Option. (Again, redef to show fns defined.) TWICE Defstruct( MoreComplex( !:Include(Complex) ), Z(99) ); M0 := MakeMoreComplex(); M1 := MakeMoreComplex( R 1, I 2, Z 3 ); R C1; R M1; % A more complicated example: The structures which are used in the % Defstruct facility to represent defstructs. (The EX prefix has % been added to the names to protect the innocent...) TWICE % Redef to show fns generated. Defstruct( EXDefstructDescriptor( !:Prefix(EXDsDesc), !:Creator ), DsSize( !:Type int ), % (Upper Bound of vector.) Prefix( !:Type string ), SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) ConsName( !:Type fnId ), AltrName( !:Type fnId ), PredName( !:Type fnId ), CreateName( !:Type fnId ), Include( !:Type typeid ), InclInit( !:Type alist ) ); TWICE % Redef to show fns generated. Defstruct( EXSlotDescriptor( !:Prefix(EXSlotDesc), !:Creator ), SlotNum( !:Type int ), InitForm( !:Type form ), SlotFn( !:Type fnId ), % Selector/Depositor id. SlotType( !:Type type ), % Hm... UserGet( !:Type boolean ), UserPut( !:Type boolean ) ); END; |
Added psl-1983/util/defstruct.red version [5659f6c5cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % DEFSTRUCT.RED - Interim structure definition facility. % % Author: Russ Fish % Computer Science Dept. % University of Utah % Date: 18 December 1981 % Copyright (c) 1981 University of Utah % % See files Defstruct.{Hlp,Doc} for description of usage. %%%% To compile this code, it must first be loaded interpretively. %%%% %%%% Bootstrap is necessary because defstructs are used internally %%%% %%%% to record the descriptions of structures, including the %%%% %%%% descriptions of the defstruct descriptors themselves. %%%% % First, an aside to the compiler. CompileTime % Compiler needs to know about LHS forms which will be used. put( 'SlotDescInitForm, 'Assign!-Op, 'PUTSlotDescInitForm ); BothTimes % Declare lists of fluids used for binding options. << fluid '( DefstructOptions SlotOptions ); fluid ( DefstructOptions := '( !:Constructor !:Alterant !:Predicate !:Creator !:Prefix !:Include !:IncludeInit ) ); fluid ( SlotOptions := '( !:Type !:UserGet !:UserPut ) ); flag('(defstruct), 'Eval); >>; % ////////////// Externally known fns ////////////////////////// % Struct type predicate. lisp procedure DefstructP( Name ); get( Name, 'Defstruct ); % Access to "struct type name" field of structure. lisp procedure DefstructType( Struct ); if VectorP Struct then % Minimal checking. getv( Struct, 0 ) else NIL; % Type inclusion predicate. lisp procedure SubTypeP( I1, I2 ); % T if I1 is a subtype of I2. begin scalar Incl; return I1 eq I2 % Type is subtype of itself. (LEQ.) or (Incl := DsDescInclude GetDefstruct I2) % Done if no subtype. and ( I1 eq Incl % Proper subtype. or SubTypeP( I1, Incl ) ) % Or a subsubtype, or... end; % ////////////// Defstruct ///////////////////////////////////// fexpr procedure Defstruct( Spec ); begin scalar StructName, Init, NameValue, Desc, DsSize, SlotSpec, SlotAlist; if atom Spec then % Spec must be a list. TypeError( Spec, 'Defstruct, "a spec list" ); StructName := if atom first Spec then first Spec % Grab the struct id. else first first Spec; if not idp StructName then % Struct id better be one. UsageTypeError( StructName, 'Defstruct, "an id", "a StructName" ); % Defaults for options. !:Constructor := !:Alterant := !:Predicate := T; !:Creator := !:Include := !:IncludeInit := NIL; !:Prefix := ""; % Process option list if present. if pairp first Spec then ProcessOptions( rest first Spec, DefstructOptions ); if !:Prefix = T then % Default prefix is StructName. !:Prefix := id2string StructName; if idp !:Prefix then % Convert id to printname string. !:Prefix := id2string !:Prefix else if not stringp !:Prefix then % Error if not id or string. UsageTypeError( !:Prefix, 'Defstruct, "an id or a string", "a SlotName prefix" ); % Construct macro names in default pattern if necessary. if !:Constructor eq T then !:Constructor := IdConcat( 'MAKE, StructName ); if !:Alterant eq T then !:Alterant := IdConcat( 'ALTER, StructName ); if !:Predicate eq T then !:Predicate := IdConcat( StructName, 'P ); if !:Creator eq T then !:Creator := IdConcat( 'CREATE, StructName ); % Define the constructor, alterant, predicate, and creator, if desired. MkStructMac( !:Constructor, 'Make, StructName ); MkStructMac( !:Alterant, 'Alter, StructName ); MkStructPred( !:Predicate, StructName ); MkStructMac( !:Creator, 'Create, StructName ); DsSize := 0; % Accumulate size, starting with the DefstructType. SlotAlist := NIL; if !:Include then % If including another struct, start after it. if Desc := GetDefstruct( !:Include ) then << DsSize := DsDescDsSize( Desc ); % Get slots of included type, modified by !:IncludeInit. SlotAlist := for each Init in DsDescSlotAlist( Desc ) collect << if !:IncludeInit and (NameValue := atsoc( car Init, !:IncludeInit )) then << Init := TotalCopy Init; SlotDescInitForm cdr Init := second NameValue >>; Init >> >> else TypeError( !:Include, "Defstruct !:Include", "a type id" ); % Define the Selector macros, and build the alist of slot ids. SlotAlist := append( SlotAlist, for each SlotSpec in rest Spec collect ProcessSlot( SlotSpec, !:Prefix, DsSize := DsSize+1 ) ); if Defstructp Structname then ErrorPrintF("*** Defstruct %r has been redefined", StructName); Put( StructName, 'Defstruct, % Stash the Structure Descriptor. CreateDefstructDescriptor( DsSize, !:Prefix, SlotAlist, !:Constructor, !:Alterant, !:Predicate, !:Creator, !:Include, !:IncludeInit ) ); return StructName end; % Turn slot secifications into (SlotName . SlotDescriptor) pairs. lisp procedure ProcessSlot( SlotSpec, Prefix, SlotNum ); begin scalar SlotName, SlotFn, It, OptList, InitForm; % Got a few possibilities to unravel. InitForm := OptList := NIL; % Only slot-name required. if atom SlotSpec then SlotName := SlotSpec % Bare slot-name, no default-init or options. else << SlotName := first SlotSpec; if It := rest SlotSpec then % Default-init and/or options provided. << % See if option immediately after name. while pairp It do It := first It; % Down to first atom. if idp It and memq( It, SlotOptions ) then % Option keyword? OptList := rest SlotSpec % Yes, no init-form. else << InitForm := second SlotSpec; % Init-form after keyword. OptList := rest rest SlotSpec % Options or NIL. >> >> >>; if not idp SlotName then % Slot id better be one. UsageTypeError( SlotName, 'Defstruct, "an id", "a SlotName" ); SlotFn := if Prefix eq "" then % Slot fns may have a prefix. SlotName else IdConcat( Prefix, Slotname ); % Defaults for options. !:Type := !:UserGet := !:UserPut := NIL; if OptList then % Process option list ProcessOptions( OptList, SlotOptions ); % Make Selector and Depositor unless overridden. if not !:UserGet then MkSelector( SlotFn, SlotNum ); if not !:UserPut then MkDepositor( SlotFn, SlotNum ); % Return the ( SlotName . SlotDescriptor ) pair. return SlotName . CreateSlotDescriptor( SlotNum, InitForm, SlotFn, !:Type, !:UserGet, !:UserPut ) end; % ////////////// Internal fns ////////////////////////////////// % Process defstruct and slot options, binding values of valid options. lisp procedure ProcessOptions( OptList, OptVarList ); begin scalar OptSpec, Option, OptArg; for each OptSpec in OptList do << if atom OptSpec then % Bare option id. << Option := OptSpec; OptArg := T >> else << Option := first OptSpec; OptArg := rest OptSpec; % List of args to option. if not rest OptArg then % Single arg, unlist it. OptArg := first OptArg >>; if memq( Option, OptVarList ) then set( Option, OptArg ) else UsageTypeError( Option, 'ProcessOptions, ("one of" . OptVarList . "is needed"), "an option id" ) >> end; lisp procedure GetDefstruct( StructId ); % Yank struct defn from id. begin scalar Desc; if Desc := get( StructId, 'Defstruct ) then return Desc % Return Struct defn. else TypeError( StructId, 'GetDefstruct, "a defstruct id" ) end; lisp procedure IdConcat( I1, I2 ); % Make two-part names. << if idp I1 then I1 := id2String I1; if idp I2 then I2 := id2String I2; intern concat( I1, I2 ) >>; % ////////////// Fn building fns /////////////////////////////// % Fn to build specific Structure Fns as macros which use generic macros. % The generic macro is called with the StructName and the original % list of arguments. % MacName( arg1, arg2, ... ) % => GenericMac( StructName, arg1, arg2, ... ) lisp procedure MkStructMac( MacName, GenericMac, StructName ); if MacName then % No macro if NIL name. putd( MacName, 'macro, list( 'lambda, '(MacroArgs), list( 'append, list( 'quote, list( GenericMac, StructName ) ), '(rest MacroArgs) ) ) ); % Fn to build specific Structure Predicates. lisp procedure MkStructPred( FnName, StructName ); putd( FnName, 'expr, list( 'lambda, '(PredArg), list( 'and, '(vectorp PredArg), list( 'eq, list('quote,StructName), '(DefstructType PredArg) ) ) ) ); % RHS selector (get fn) constructor. lisp procedure MkSelector( Name, Slotnum ); putd( Name, 'expr, list( 'lambda, '(Struct), List( 'getV, 'Struct, SlotNum ) ) ); % LHS depositor (put fn) constructor. lisp procedure MkDepositor( Name, Slotnum ); begin scalar PutName; PutName := intern concat( "PUT", id2string Name ); putd( PutName, 'expr, list( 'lambda, '(Struct Val), List( 'putV, 'Struct, SlotNum, 'Val ) ) ); put( Name, 'Assign!-Op, PutName ); return PutName end; % ////////////// Fns used by macros. /////////////////////////// % Generic macro for constructors, called with structure name and list % of slot-name:value-form pairs to merge with default-inits. % Returns vector constructor. macro procedure Make( ArgList ); begin scalar StructName, OverrideAlist, Slot, NameValue; StructName := second ArgList; OverrideAlist := rest rest ArgList; return append( % Return vector constructor. list( 'vector, list('quote,StructName) ), % Mark struct type as first element. % Build list of init forms for vector constructor. for each Slot in DsDescSlotAlist GetDefstruct StructName collect if NameValue := atsoc( car Slot, OverrideAlist ) then second NameValue else SlotDescInitForm cdr Slot ) end; % Generic Alterant macro, called with structure name, struct instance and % slot name:value alist. A list of depositor calls is returned, with a % PROGN wrapped around it and the struct instance at the end for a return % value. macro procedure Alter( ArgList ); begin scalar StructName, StructInstance, SlotValueDlist, SlotAlist, NameValue, Slot; StructName := second ArgList; StructInstance := third ArgList; SlotValueDlist := rest rest rest ArgList; SlotAlist := DsDescSlotAList GetDefstruct StructName; return append( append( '(PROGN), % wraparound PROGN. % List of depositor calls. for each NameValue in SlotValueDlist collect if Slot := atsoc( first NameValue, SlotAlist) then list( % Use depositors, which may be user fns, rather than PutV. IdConCat( 'PUT, SlotDescSlotFn cdr Slot ), StructInstance, second NameValue ) else TypeError( car NameValue, 'Alter, concat( "a slot of ", id2string StructName ) ) ), list( StructInstance ) ) % Value of PROGN is altered instance. end; % Generic Create macro, called with struct name and list of positional args % which are slot value forms. Returns struct vector constructor. macro procedure Create( ArgList ); begin scalar StructName, SlotValues, DsSize; StructName := second ArgList; SlotValues := rest rest ArgList; DsSize := DsDescDsSize GetDefstruct StructName; if DsSize = Length SlotValues then return append( list( 'VECTOR, list( 'quote, StructName ) ), % Mark with struct id. SlotValues ) else UsageTypeError( SlotValues, 'Create, BldMsg( "a list of length %p", DsSize ), concat( "an initializer for ", id2string StructName) ) end; % ////////////// Boot Defstruct structs. /////////////////////// % Chicken-and-egg problem, need some knowledge of Defstruct descriptor % structures before they are defined, in order to define them. CompileTime << MkSelector( 'DsDescDsSize, 1 ); MkStructMac( 'CreateDefstructDescriptor, 'Create, 'DefstructDescriptor ); MkStructMac( 'CreateSlotDescriptor, 'Create, 'SlotDescriptor ); put( 'DefstructDescriptor, 'Defstruct, % Abbreviated struct defns for boot. '[ DefstructDescriptor 9 ] ); % Just DsSize, for Create Fns. put( 'SlotDescriptor, 'Defstruct, '[ SlotDescriptor 6 ] ); >>; % Now really declare the Defstruct Descriptor structs. Defstruct( DefstructDescriptor( !:Prefix(DsDesc), !:Creator ), DsSize( !:Type int ), % (Upper Bound of vector.) Prefix( !:Type string ), SlotAlist( !:Type alist ), % (Cdrs are SlotDescriptors.) ConsName( !:Type fnId ), AltrName( !:Type fnId ), PredName( !:Type fnId ), CreateName( !:Type fnId ), Include( !:Type typeid ), InclInit( !:Type alist ) ); Defstruct( SlotDescriptor( !:Prefix(SlotDesc), !:Creator ), SlotNum( !:Type int ), InitForm( !:Type form ), SlotFn( !:Type fnId ), % Selector/Depositor id. SlotType( !:Type type ), % Hm... UserGet( !:Type boolean ), UserPut( !:Type boolean ) ); END; |
Added psl-1983/util/demo-defstruct.red version [d44c2e9a48].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Sample of use of <Fish.iact>DefStruct.RED % See <fish.iact>Defstruct.HLP Defstruct(Complex, R, I); Defstruct(Complex, R(0), I(0)); % Redefine to see what functions defined % Give 0 Inits C0:=MakeComplex(); ComplexP C0; C1:=MakeComplex(('R . 1), ('I . 2)); AlterComplex(C1,'(R . 2), '(I . 3)); Put('R,'Assign!-op,'PutR); % for LHS. R(C1):=3; I(C1):=4; C1; % Show use of Include Option. Defstruct(MoreComplex(!:Include(Complex)),Z(99)); Defstruct(MoreComplex(!:Include(Complex)),Z(99)); M0 := MakeMoreComplex(); M1:=MakeMoreComplex('R . 1, 'I . 2, ' Z . 3); R C1; R M1; |
Added psl-1983/util/destructure.sl version [eac54f3f17].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % DESTRUCTURE.SL - Tools for destructuring and macro definition % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (de destructure-form (target path) (cond ((null target) nil) ((idp target) `((setq ,target ,path))) ((atom target) (destructure-form (ContinuableError 99 (BldMsg "Can't assign to %r" target) target) path)) (t (nconc (destructure-form (car target) `(car ,path)) (destructure-form (cdr target) `(cdr ,path)))))) (de flatten (U) (cond ((null U) nil) ((atom U) (list U)) ((null (car U)) (cons nil (flatten (cdr U)))) (t (append (flatten (car U)) (flatten (cdr U)))))) (fluid '(*defmacro-displaces)) ((lambda (ub-flg) (fluid '(*macro-displace)) (cond (ub-flg (setq *macro-displace t)))) % Only do if not already set (unboundp '*macro-displace)) (de defmacro-1 (U) % This, too, can be made more efficient if desired. Seems unnecessary, though. `(dm ,(cadr U) (***DEFMACRO-ARG***) (prog ,(flatten (caddr U)) ,.(destructure-form (caddr U) '(cdr ***DEFMACRO-ARG***)) (return ,(cond (*defmacro-displaces `(macro-displace ***DEFMACRO-ARG*** (progn ,@(cdddr U)))) (t `(progn ,@(cdddr U)))))))) (de macro-displace (u v) (cond (*macro-displace (rplacw u `(!%displaced-macro ',(cons (car u) (cdr u)) ,(macroexpand v)))) (t v))) (dm defmacro (u) (defmacro-1 u)) (dm defmacro-displace (u) ((lambda (*defmacro-displaces) (defmacro-1 u)) t)) (dm defmacro-no-displace (u) ((lambda (*defmacro-displaces) (defmacro-1 u)) nil)) (copyd '!%displaced-macro 'prog2) (setf (get '!%displaced-macro 'compfn) #'&comprogn) (defmacro desetq (U V) % a destructuring setq - should be made more efficient and robust `((lambda (***DESETQ-VAR***) ,.(destructure-form U '***DESETQ-VAR***) ***DESETQ-VAR***) ,V)) (fluid '(*macro-debug)) (defmacro-no-displace deflambda (nam vars . bod) (if *macro-debug % T => deflambdas are functions and can be traced, etc. `(de ,nam ,vars ,@bod) `(defmacro ,nam ,vars `((lambda ,',vars ,.',bod) ,.(list ,@vars))))) |
Added psl-1983/util/duseful.ctl version [c1429f00eb].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | @cd pu: @psl:rlisp load useful; off redefmsg,usermode,macro!-displace; on defmacro!-displaces; faslout "pl:duseful"; in "backquote.sl"$ in "read-macros.sl"$ in "destructure.sl"$ in "cond-macros.sl"$ in "bind-macros.sl"$ in "set-macros.sl"$ in "iter-macros.sl"$ in "for-macro.sl"$ in "misc-macros.sl"$ in "macroexpand.sl"$ push('useful,options!*)$ faslend; quit; |
Added psl-1983/util/evalhook.build version [3b3d2082ab].
> > | 1 2 | CompileTime load(Useful, CLComp); in "evalhook.lsp"$ |
Added psl-1983/util/evalhook.lsp version [cca6c59ce9].
> > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; EVALHOOK.LSP - Support for special evaluation ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 30 March 1982 ;;; Copyright (c) 1982 University of Utah ;;; (defvar evalhook () "Variable to be funcalled if not () when Eval is called") (fset 'old-eval (fsymeval 'eval)) ; Redefine Eval (defun eval (form) (if evalhook (let ((outer-evalhook evalhook)) ; Bind evalhook to (), then funcall it (let ((evalhook ())) (funcall outer-evalhook form))) (old-eval form))) ;;;; EVALHOOKFN - outer evaluation uses old-eval, inner evaluations use hook (defun evalhookfn (form hook) (let ((evalhook hook)) (old-eval form))) |
Added psl-1983/util/extended-char.sl version [ada4791f0f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Extender-Char.SL - 9-bit terminal input characters % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 31 August 1982 % % Changes: % 10/15/82: added M-X macro, for convenience % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Note: this file defines MACROS, so you may need to load it at compile-time. % Note: this file loads FAST-INT. (load fast-int common strings) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Extended Character Manipulation Functions (or Macros) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (ds X-Base (chr) % Return the base character corresponding to CHR. In other words, clear the % Meta and Control bits. (& chr 2#001111111)) (ds X-Zero-Base (chr) % Return the given character with its base code set to 0. (& chr 2#110000000)) (ds X-UnMeta (chr) % Turn off the Meta bit in the given character. (& chr 2#101111111)) (ds X-UnControl (chr) % Turn off the Control bit in the given character. (& chr 2#011111111)) (ds X-Meta? (chr) % Does CHR have the Meta bit set? (not (= (& chr 2#010000000) 0))) (ds X-Control? (chr) % Does CHR have the Control bit set? (not (= (& chr 2#100000000) 0))) (ds X-Set-Meta (chr) % Set the Meta bit in CHR. (| chr 2#010000000)) (ds X-Set-Control (chr) % Set the Control bit in CHR. (| chr 2#100000000)) % This version of "UpperCaseP" handles extended characters. (de X-UpperCaseP (chr) (UpperCaseP (X-Base chr))) % This version of "LowerCaseP" handles extended characters. (de X-LowerCaseP (chr) (LowerCaseP (X-Base chr))) (de X-Char-DownCase (chr) (let ((bits (X-Zero-Base chr)) (base (X-Base chr)) ) (| bits (Char-DownCase base)))) (de X-Char-UpCase (chr) (let ((bits (X-Zero-Base chr)) (base (X-Base chr)) ) (| bits (Char-UpCase base)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Extended Character Creation Macro % % Examples of legal uses: % (x-char a) => A % (x-char lower a) => a % (x-char control a) => C-A % (x-char c-a) => C-A % (x-char ^A) => (ascii control A - code 1) % (x-char meta control TAB) => C-M-Tab % (x-char control ^A) => C-^A (^A is ASCII code 1) % (x-char C-M-^A) => C-M-^A (^A is ASCII code 1) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (dm X-Char (form) (Create-Extended-Character (cdr form))) (de Create-Extended-Character (L) (let ((plist (gensym))) (for (in x L) (do (cond ((IdP x) (X-Char-process-id x plist)) ((FixP x) (X-Char-process-fix x plist)) (t (put plist 'error T)) ))) (let ((base (get plist 'base))) (if (or (get plist 'error) (null base)) (StdError (BldMsg "Invalid X-CHAR: %p" (cons 'X-CHAR L)))) (if (and (get plist 'Lower) (>= base #\A) (<= base #\Z)) (setf base (+ base 2#100000))) (if (get plist 'Control) (setf base (X-Set-Control base))) (if (get plist 'Meta) (setf base (X-Set-Meta base))) base ))) (de X-char-process-id (id plist) (prog (temp id2) (cond ((eq id 'Meta) (put plist 'Meta T)) ((eq id 'Control) (put plist 'Control T)) ((eq id 'Lower) (put plist 'Lower T)) ((eq id 'Return) (put plist 'base 13)) ((< (setf temp (ID2Int id)) 128) (put plist 'base temp)) ((setf temp (get id 'CharConst)) (put plist 'base temp)) ((and (>= (size (setf temp (id2string id))) 2) (= (indx temp 1) #\-)) (setf id2 (intern (substring temp 2 (+ 1 (size temp))))) (selectq (indx temp 0) (#\M (put plist 'Meta T) (X-char-process-id id2 plist)) (#\C (put plist 'Control T) (X-char-process-id id2 plist)) (t (put plist 'error T)) )) ((and (= (size temp) 1) (= (indx temp 0) #\^)) (put plist 'Ascii-Control T) (put plist 'base (& (indx temp 1) 2#11111)) ) (t (put plist 'error T)) ))) (de X-Char-process-fix (x plist) (cond ((and (>= x 0) (<= x 9)) (put plist 'base (+ x #\0))) (t (put plist 'error T)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % X-Chars %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generate a list of character codes from a list of "character descriptors", % which are argument lists to the X-CHAR macro. (dm x-chars (chlist) (cons 'list (for (in x (cdr chlist)) (collect (cons 'x-char (if (pairp x) x (list x))))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Printable names for extended characters: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(character-name-table)) % An association list of (character code . name), used by x-char-name. (setf character-name-table '( (8#0 . "Null") (8#7 . "Bell") (8#10 . "Backspace") (8#11 . "Tab") (8#12 . "Newline") (8#15 . "Return") (8#33 . "Escape") (8#40 . "Space") (8#177 . "Rubout") )) (de x-char-name (ch) % Return a string giving the name for an extended character. (cond ((not (FixP ch)) (BldMsg "<%o>" ch)) ((atsoc ch character-name-table) (cdr (atsoc ch character-name-table))) ((X-Control? ch) (string-concat "C-" (x-char-name (X-UnControl ch)))) ((X-Meta? ch) (string-concat "M-" (x-char-name (X-UnMeta ch)))) ((GraphicP ch) (string ch)) ((and (>= ch 0) (< ch (char space))) (string-concat "^" (x-char-name (LXor ch 8#100)))) (t (BldMsg "<%o>" ch)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % M-X Macro %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro m-x (command-string) `(list (x-char M-X) ,command-string)) |
Added psl-1983/util/f-dstruct.build version [3ea6ea7499].
> > | 1 2 | CompileTime LOAD(DEFSTRUCT,SYSLISP,INUM,FAST!-VECTOR); in "f-dstruct.red"$ |
Added psl-1983/util/f-dstruct.red version [6a29e1ffaf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Fast Defstruct Improvements; % M.L. Griss % Load after Defstruct to redefine basic Selectors FLUID '(DefGetFn!* DefPutFn!* !*DefFnAsExpr); LoadTime << DefGetFn!*:='IGetv; DefPutFn!*:='IPutv; !*DefFnAsExpr:=NIL;>>; % RHS selector (get fn) constructor. lisp procedure MkSelector( Name, Slotnum ); If !*DefFnAsExpr then putd( Name, 'expr, list( 'lambda, '(Struct), List( DefGetFn!*, 'Struct, SlotNum ) ) ) else Putd(name,'macro, list('lambda,'(struct), List('LIST,MkQuote DefGetFn!*,'(Cadr Struct),MkQuote SlotNum))); % LHS depositor (put fn) constructor. lisp procedure MkDepositor( Name, Slotnum ); begin scalar PutName; PutName := intern concat( "PUT", id2string Name ); If !*DefFnAsExpr then putd( PutName, 'expr, list( 'lambda, '(Struct Val), List( DefPutFn!*, 'Struct, SlotNum, 'Val ) ) ) else Putd(PutName,'macro, list('lambda,'(struct), List('List,MkQuote DefPutFn!*, '(Cadr Struct), MkQuote SlotNum, '(Caddr Struct) )) ); put( Name, 'Assign!-Op, PutName ); return PutName end; END; |
Added psl-1983/util/fast-arith.build version [f58190493c].
> > | 1 2 | CompileTime load Syslisp; in "fast-arith.red"$ |
Added psl-1983/util/fast-arith.red version [bbb5809064].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % speed up generic arith for V3 % MLG, 9:25pm Friday, 21 May 1982 ON SYSLISP; SYSLSP PROCEDURE FASTPLUS2(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:= WPLUS2(I1,I2)) EQ X THEN RETURN X; Return Oldplus2(I1,I2); End; SYSLSP PROCEDURE FASTTIMES2(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:= WTIMES2(I1,I2)) EQ X Then return X; RETURN OLDTimes2(I1,I2); END; SYSLSP PROCEDURE FASTDIFFERENCE(I1,I2); Begin Scalar x; IF INTP(I1) AND INTP(I2) AND (X:=WDIFFERENCE(I1,I2)) EQ X Then return x; RETURN OldDifference(I1,I2); END; SYSLSP PROCEDURE FASTADD1 I1; Begin Scalar x; IF INTP(I1) AND (x:= IADD1 I1) EQ x then Return x; RETURN OldAdd1 I1; END; SYSLSP PROCEDURE FASTSUB1 I1; Begin Scalar x; IF INTP(I1) AND (X:= ISUB1 I1) EQ X then Return x; RETURN OldSub1 I1; end; SYSLSP PROCEDURE FASTZerop I1; IF INTP(I1) THEN WEQ(I1, 0) else OldZerop I1; SYSLSP PROCEDURE FASTMinusp I1; IF INTP(I1) THEN WLESSP(I1, 0) ELSE OldMinusp I1; SYSLSP PROCEDURE FASTGreaterp(I1,I2); IF INTP(I1) AND INTP(I2) THEN WGREATERP(I1,I2) ELSE OldGreaterp I1; SYSLSP PROCEDURE FASTlessP(I1,I2); IF INTP(I1) AND INTP(I2) THEN WLESSP(I1,I2) ELSE OldLessP I1; off syslisp; lisp procedure Faster; Begin !*usermode:=NIL; COPYD('OLDPlus2,'Plus2); COPYD('OLDTimes2,'Times2); COPYD('OLDDifference,'Difference); COPYD('OLDZeroP,'Zerop); COPYD('OLDLessP,'LessP); COPYD('OLDGreaterP,'GreaterP); COPYD('OLDAdd1,'Add1); COPYD('OLDSub1,'Sub1); COPYD('Plus2,'FastPlus2); COPYD('Times2,'FastTimes2); COPYD('Difference,'FastDifference); COPYD('ZeroP,'FastZerop); COPYD('LessP,'FastLessP); COPYD('GreaterP,'FastGreaterP); COPYD('Add1,'FastAdd1); COPYD('Sub1,'FastSub1); end; END; |
Added psl-1983/util/fast-int.sl version [0882fca332].
> > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Fast-Int.SL - Integer Operators (Compiled "Open") % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 24 September 1982 % Revised: 11 January 1983 % % This file survives only for backward compatibility. % It has been replaced by NUMERIC-OPERATORS. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load numeric-operators) (bothtimes (on fast-integers)) |
Added psl-1983/util/fast-strings.sl version [33111c7fc8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FAST-STRINGS - Fast (unchecked) version of String Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Load this at compile-time to make compiled invocations of the following % functions fast (and unchecked): % % (string-fetch s i) % (string-store s i ch) % (string-length s) % (string-upper-bound s) % (string-empty? s) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load slow-strings) % for the interpreted versions (CompileTime (load fast-vector)) % for machine-dependent primitives (put 'string-fetch 'cmacro '(lambda (s i) (igets s i))) (put 'string-store 'cmacro '(lambda (s i c) (iputs s i c))) (put 'string-length 'cmacro '(lambda (s) (Wplus2 (isizes s) 1))) (put 'string-upper-bound 'cmacro '(lambda (s) (isizes s))) (put 'string-empty? 'cmacro '(lambda (s) (WLessP (isizes s) 0))) |
Added psl-1983/util/fast-struct.lsp version [71cbe0b1b5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (defstruct-define-type :fast-vector (:named :named-fast-vector) ; but probably not much point (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ,@arg)) (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil)) (:ref (n description arg) description ;ignored `(igetv ,arg ,n))) ;added for PSL (defstruct-define-type :named-fast-vector (:keywords :make-vector) :named (:overhead 1) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ',(defstruct-description-name) ,@arg)) (:defstruct (x) (let ((*insideload t)) (load fast-vector) nil)) (:ref (n description arg) description ;ignored `(igetv ,arg ,(add1 n)))) (defstruct-define-type hashed-list (:named :named-hashed-list) (:cons (arg description etc) :list description ;ignored etc ;ignored `(hlist . ,arg)) (:ref (n description arg) description ;ignored #+Multics `(,(let ((i (\ n 4))) (cond ((= i 0) 'car) ((= i 1) 'cadr) ((= i 2) 'caddr) (t 'cadddr))) ,(do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(add1 n)))) ; #-Multics `(nth ,n ,arg))) (defstruct-define-type :named-hashed-list :named (:overhead 1) (:cons (arg description etc) :list etc ;ignored `(hlist ',(defstruct-description-name) . ,arg)) (:ref (n description arg) description ;ignored ; #+Multics `(,(let ((i (\ (1+ n) 4))) ; (cond ((= i 0) 'car) ; ((= i 1) 'cadr) ; ((= i 2) 'caddr) ; (t 'cadddr))) ; ,(do ((a arg `(cddddr ,a)) ; (i (// (1+ n) 4) (1- i))) ; ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(+ n 2)))) ; #-Multics `(nth ,(1+ n) ,arg))) (defstruct-define-type :hashed-list* (:cons (arg description etc) :list description ;ignored etc ;ignored `(hcons . ,arg)) (:ref (n description arg) ; PSL change 1- ==> sub1 (let ((size (sub1 (defstruct-description-size)))) ; (let ((size (1- (defstruct-description-size)))) #+Multics (do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) (let* ((i (\ n 4)) (a (cond ((= i 0) a) ((= i 1) `(cdr ,a)) ((= i 2) `(cddr ,a)) (t `(cdddr ,a))))) (if (< n size) `(car ,a) a)))) #-Multics (if (< n size) ; PSL change incompatible NTH `(nth ,arg ,(add1 n)) `(pnth ,arg ,(add1 n))))) ; `(nth ,n ,arg) ; `(nthcdr ,n ,arg)))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type hashed-list* cannot include another" (defstruct-description-name))) nil)) (defstruct-define-type :hashed-tree (:cons (arg description etc) :list etc ;ignored (if (null arg) (defstruct-error "defstruct cannot make an empty tree" (defstruct-description-name))) (make-hashed-tree-for-defstruct arg (defstruct-description-size))) (:ref (n description arg) (do ((size (defstruct-description-size)) (a arg) (tem)) (()) (cond ((= size 1) (return a)) ; PSL change // ==> / ((< n (setq tem (/ size 2))) ; ((< n (setq tem (// size 2))) (setq a `(car ,a)) (setq size tem)) (t (setq a `(cdr ,a)) (setq size (- size tem)) (setq n (- n tem)))))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type tree cannot include another" (defstruct-description-name))) nil)) (defun make-hashed-tree-for-defstruct (arg size) (cond ((= size 1) (car arg)) ((= size 2) `(hcons ,(car arg) ,(cadr arg))) (t (do ((a (cdr arg) (cdr a)) ; PSL change // ==> /, 1- ==> sub1 (m (/ size 2)) (n (sub1 (/ size 2)) (sub1 n))) ; (m (// size 2)) ; (n (1- (// size 2)) (1- n))) ((zerop n) `(hcons ,(make-hashed-tree-for-defstruct arg m) ,(make-hashed-tree-for-defstruct a (- size m)))))))) |
Added psl-1983/util/fast-vector.build version [5a4073d5af].
> > > > > | 1 2 3 4 5 | CompileTime << load If!-System; load Syslisp; >>; in "fast-vector.red"$ |
Added psl-1983/util/fast-vector.red version [21e4030132].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>FAST-VECTOR.RED.1, 18-Mar-82 21:26:35, Edit by GRISS % Fast Vector operations imports '(Syslisp); % Uses syslisp macros CopyD('IGetV, 'GetV); CopyD('IPutV, 'PutV); CopyD('ISizeV, 'Size); Put('IGetV, 'Assign!-Op, 'IPutV); CopyD('IGetS, 'Indx); CopyD('IPutS, 'SetIndx); CopyD('ISizeS, 'Size); Put('IGetS, 'Assign!-Op, 'IPutS); if_system(VAX, DefList('((IGetV (lambda (V I) (VecItm (VecInf V) I))) (IPutV (lambda (V I X) (PutVecItm (VecInf V) I X))) (IGetS (lambda (S I) (StrByt (StrInf S) I))) (IPutS (lambda (S I X) (PutStrByt (StrInf S) I X))) (ISizeV (lambda (V) (VecLen (VecInf V)))) (ISizeS (lambda (V) (StrLen (StrInf V))))), 'CMacro)); if_system(PDP10, % tags don't need to be stripped on the PDP10 DefList('((IGetV (lambda (V I) (VecItm V I))) (IPutV (lambda (V I X) (PutVecItm V I X))) (IGetS (lambda (S I) (StrByt S I))) (IPutS (lambda (S I X) (PutStrByt S I X))) (ISizeV (lambda (V) (VecLen V))) (ISizeS (lambda (S) (StrLen S)))), 'CMacro)); if_system(MC68000, % tags don't need to be stripped on the 68000 DefList('((IGetV (lambda (V I) (VecItm V I))) (IPutV (lambda (V I X) (PutVecItm V I X))) (IGetS (lambda (S I) (StrByt S I))) (IPutS (lambda (S I X) (PutStrByt S I X))) (ISizeV (lambda (V) (VecLen V))) (ISizeS (lambda (S) (StrLen S)))), 'CMacro)); END; |
Added psl-1983/util/fast-vectors.sl version [a0c0336965].
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % FAST-VECTORS - Fast (unchecked) version of Vector Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Load this at compile-time to make compiled invocations of the following % functions fast (and unchecked): % % (vector-fetch v i) % (vector-store v i x) % (vector-size v) % (vector-upper-bound v) % (vector-empty? v) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load slow-vectors) % for the interpreted versions (CompileTime (load fast-vector)) % for machine-dependent primitives (put 'vector-fetch 'cmacro '(lambda (v i) (igetv v i))) (put 'vector-store 'cmacro '(lambda (v i x) (iputv v i x))) (put 'vector-size 'cmacro '(lambda (v) (Wplus2 (isizev v) 1))) (put 'vector-upper-bound 'cmacro '(lambda (v) (isizev v))) (put 'vector-empty? 'cmacro '(lambda (v) (WLessP (isizev v) 0))) |
Added psl-1983/util/filedate.mic version [2b7513ce02].
> > > > > > > > | 1 2 3 4 5 6 7 8 | ; get file names, and write date to a file @dir 'a, no heading time write no summary separate output file.dates |
Added psl-1983/util/find.build version [6cc7123ca2].
> > > | 1 2 3 | % Build the FIND utility Imports '(Gsort); in "find.red"$ |
Added psl-1983/util/find.red version [7e91df4da4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. FIND.RED - Start of recognition and search OBLIST functions %. M. L. Griss % 30 Dec 1982, Mlg % Move IMPORTS etc to BUILD file Fluid '(CollectID!* TestString!*); Lisp Procedure FindPrefix(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindPrefix1; Return IDSort CollectId!* end; Lisp procedure FindPrefix1 x; If IsPrefixString(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; Lisp Procedure FindSuffix(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindSuffix1; Return IDSort CollectId!* end; Lisp procedure FindSuffix1 x; If IsSuffixString(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; Lisp procedure IsPrefixString(s1,s2); %. test if exact string prefix begin scalar l1,l2,L; l1:=size s1; l2:=size s2; L:=0; if l1> l2 then return NIL; Loop: if not( s1[L] eq s2[L] ) then return NIL; if (L:=add1 L)> L1 then return T; goto loop; end; Lisp procedure IsSuffixString(s1,s2); %. test if exact string prefix begin scalar l1,l2,L; l1:=size s1; l2:=size s2; if l1> l2 then return NIL; Loop: if not( s1[L1] eq s2[L2] ) then return NIL; if L1<=0 then return T; l1:=L1-1; L2:=L2-1; goto loop; end; % More extensive String matcher procedure StringMatch(p,s); StringMatch1(p,0,size(p),s,0,size(s)); procedure StringMatch1(p,p1,p2,s,s1,s2); Begin scalar c; L1: % test Range if p1>p2 then return (if s1>s2 then T else NIL) else if s1>s2 then return NIL; % test if % something if (c:=p[p1]) eq char !% then goto L3; L2: % exact match if c eq s[s1] then <<p1:=p1+1; s1:=s1+1; goto L1>>; return NIL; L3: % special cases p1:=p1+1; if p1>p2 then return stderror "pattern ran out in % case of StringMatch"; c:=p[p1]; if c eq char !% then goto L2; if c eq char !? then <<p1:=p1+1; s1:=s1+1; goto L1>>; if c eq char !* then % 0 or more vs 1 or more return <<while not(c:=StringMatch1(p,p1+1,p2,s,s1,s2)) and s1<=s2 do s1:=s1+1; c>>; Return Stderror Bldmsg(" %% %r not known in StringMatch",int2id c); end; Lisp Procedure Find(TestString!*); %. Scan ObLIST for prefix Begin CollectId!*:=NIL; If IDp TestString!* then TestString!*:=ID2String TestString!*; If Not StringP TestString!* then StdError "Expect String or ID in FindPrefix"; MapObl Function FindStringMatch; Return IDSort CollectId!* end; Lisp procedure FindStringMatch x; If StringMatch(TestString!*,ID2String x) then CollectId!* := x . CollectId!*; End; |
Added psl-1983/util/for-macro.sl version [0dffff4e6f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % FOR-MACRO.SL - fancy FOR loop % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>FOR-MACRO.SL.3, 7-Oct-82 15:46:11, Edit by BENSON % Changed NULL tests to ATOM tests % Fancy for loop. Similar to MACLISP and clones' loop function, but with % LISPier "syntax" and slightly reduced functionality and concommitant hair. (fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions* for-body* for-epilogue* for-result*)) (dm for (U) (for-build-loop (cdr U) 'do-loop 'let)) (defmacro for* U (for-build-loop U 'do-loop* 'let*)) (de for-build-loop (U loop-fn let-fn) % Simply calls the function stored under the for-function property of the % keyword at the begining of each clause, and then builds the DO form from % the fluids below. These are in TCONC format. The clause specific % functions should do their stuff by TCONC/LCONCing onto these variables. % The clause specific functions take one argument, the list of arguments to % the clause keyword. (let ((for-outside-vars* (list nil)) (for-vars* (list nil)) (for-tests* (list nil)) (for-prologue* (list nil)) (for-conditions* (list nil)) (for-body* (list nil)) (for-epilogue* (list nil)) (for-result* (list nil))) (foreach clause in U do (process-for-clause clause)) % "UnTCONCify" everybody (setf for-outside-vars* (car for-outside-vars*) for-vars* (car for-vars*) for-tests* (car for-tests*) for-prologue* (car for-prologue*) for-conditions* (car for-conditions*) for-body* (car for-body*) for-epilogue* (car for-epilogue*) for-result* (car for-result*)) % Now, back to work... (if for-tests* (setf for-tests* (if (cdr for-tests*) (cons 'or for-tests*) (car for-tests*)))) (when for-conditions* (setf for-conditions* (if (cdr for-conditions*) (cons 'and for-conditions*) (car for-conditions*))) (setf for-body* `((when ,for-conditions* ,.for-body*)))) (if (and for-result* (cdr for-result*)) (StdError "For loops may only return one value")) % msg needs improving % Finally build up the form to return (let ((form `(,loop-fn ,for-vars* ,for-prologue* (,for-tests* ,.for-epilogue* ,.for-result*) ,.for-body*))) (if for-outside-vars* `(,let-fn ,for-outside-vars* ,form) form)))) (de process-for-clause (clause) (let ((op (car clause)) fn) (cond ((atom clause) (process-for-clause (ContinuableError 99 (BldMsg "For clauses may not be atomic: %r." clause) clause))) ((setf fn (get op 'for-function)) (call fn (cdr clause))) (t (ContinuableError 99 (BldMsg "Unknown for clause operator: %r." op) op))))) (de for-in-function (clause) (let ((var (car clause)) (lst (cadr clause)) (fn (and (cddr clause) (caddr clause))) (dummy (gensym))) (tconc for-outside-vars* dummy) (tconc for-vars* `(,var (progn (setf ,dummy ,lst) (if (pairp ,dummy) ,(if fn `(,fn (car ,dummy)) `(car ,dummy)) ())) (progn (setf ,dummy (cdr ,dummy)) (if (pairp ,dummy) ,(if fn `(,fn (car ,dummy)) `(car ,dummy)) ())))) (tconc for-tests* `(atom ,dummy)))) (de for-on-function (clause) (let ((var (car clause)) (lst (cadr clause))) (tconc for-vars* `(,var ,lst (cdr ,var))) (tconc for-tests* `(atom ,var)))) (de for-from-function (clause) (let* ((var (car clause)) (var1 (if (pairp var) (car var) var)) (clause (cdr clause)) (init (if (pairp clause) (or (pop clause) 1) 1)) (fin (if (pairp clause) (pop clause) nil)) (fin-var (if (and fin (not (numberp fin))) (gensym) nil)) (step (if (pairp clause) (car clause) 1)) (step-var (if (and step (not (numberp step))) (gensym) nil))) (tconc for-vars* (list* var init (cond (step-var `((plus2 ,var1 ,step-var))) ((zerop step) nil) ((onep step) `((add1 ,var1))) ((eqn step -1) `((sub1 ,var1))) (t `((plus ,var1 ,step)))))) (if fin-var (tconc for-vars* `(,fin-var ,fin))) (if step-var (tconc for-vars* `(,step-var ,step))) (cond (step-var (tconc for-tests* `(if (minusp ,step-var) (lessp ,var1 ,(or fin-var fin)) (greaterp ,var1 ,(or fin-var fin))))) ((null fin)) ((minusp step) (tconc for-tests* `(lessp ,var1 ,(or fin-var fin)))) (t (tconc for-tests* `(greaterp ,var1 ,(or fin-var fin))))))) (de for-for-function (clause) (tconc for-vars* clause)) (de for-with-function (clause) (lconc for-vars* (append clause nil))) % copy it for safety (de for-initially-function (clause) (lconc for-prologue* (append clause nil))) % copy it for safety (de for-finally-function (clause) (lconc for-epilogue* (append clause nil))) % copy it for safety (de for-do-function (clause) (lconc for-body* (append clause nil))) % copy it for safety (de for-collect-function (clause) (let ((tail (gensym))(reslt)) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (cdr (rplacd ,tail (ncons ,(car clause))))) (setf ,reslt (setf ,tail (ncons ,(car clause)))))))) (de for-conc-function (clause) (let ((reslt)(tail (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (LastPair (rplacd ,tail ,(car clause)))) (setf ,reslt ,(car clause)) (setf ,tail (LastPair ,reslt)))))) (de for-join-function (clause) (let ((reslt)(tail (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* tail) (tconc for-body* `(if ,tail (setf ,tail (LastPair (rplacd ,tail (append ,(car clause) nil)))) (setf ,reslt (append ,(car clause) nil)) (setf ,tail (LastPair ,reslt)))))) (defmacro-no-displace def-for-basic-return-function (name var init exp bod) `(de ,name (clause) (let ((reslt)) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt ,,init))) (setf reslt (gensym)) (tconc for-vars* `(,reslt ,,init)) (tconc for-result* reslt)) (tconc for-body* ,(subst 'reslt var (subst '(car clause) exp bod)))))) (def-for-basic-return-function for-union-function reslt nil exp `(setf ,reslt (union ,reslt ,exp))) (def-for-basic-return-function for-unionq-function reslt nil exp `(setf ,reslt (unionq ,reslt ,exp))) (de for-intersection-function (clause) (let ((reslt)(flg (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* flg) (tconc for-body* `(setf ,reslt (if ,flg (intersection ,reslt ,(car clause)) (setf ,flg t) ,(car clause)))))) (de for-intersectionq-function (clause) (let ((reslt)(flg (gensym))) (if (cdr clause) (progn (setf reslt (cadr clause)) (tconc for-prologue* `(setf ,reslt nil))) (setf reslt (gensym)) (tconc for-vars* reslt) (tconc for-result* reslt)) (tconc for-vars* flg) (tconc for-body* `(setf ,reslt (if ,flg (intersectionq ,reslt ,(car clause)) (setf ,flg t) ,(car clause)))))) (def-for-basic-return-function for-adjoin-function reslt nil exp `(setf ,reslt (adjoin ,exp ,reslt))) (def-for-basic-return-function for-adjoinq-function reslt nil exp `(setf ,reslt (adjoinq ,exp ,reslt))) (def-for-basic-return-function for-count-function reslt 0 exp `(if ,exp (incr ,reslt))) (def-for-basic-return-function for-sum-function reslt 0 exp `(incr ,reslt ,exp)) (def-for-basic-return-function for-product-function reslt 1 exp `(setf ,reslt (times ,reslt ,exp))) (def-for-basic-return-function for-maximize-function reslt nil exp `(setf ,reslt (if ,reslt (max ,reslt ,(car clause)) ,(car clause)))) (def-for-basic-return-function for-minimize-function reslt nil exp `(setf ,reslt (if ,reslt (min ,reslt ,(car clause)) ,(car clause)))) (de for-always-function (clause) (tconc for-body* `(if (null ,(if (cdr clause) `(and ,@clause) (car clause))) (return nil))) (tconc for-result* t)) (de for-never-function (clause) (tconc for-body* `(if ,(if (cdr clause) `(or ,@clause) (car clause)) (return nil))) (tconc for-result* t)) (de for-thereis-function (clause) (let ((temp (gensym))) (tconc for-result* nil) (tconc for-vars* temp) (tconc for-body* `(if (setf ,temp ,(car clause)) (return ,temp))))) (de for-returns-function (clause) (tconc for-result* (if (cdr clause) (cons 'progn clause) (car clause)))) (de for-while-function (clause) (lconc for-tests* (foreach u in clause collect `(null ,u)))) (de for-until-function (clause) (lconc for-tests* (append clause nil))) % copy for safety (de for-when-function (clause) (lconc for-conditions* (append clause nil))) % copy for safety (de for-unless-function (clause) (lconc for-conditions* (foreach u in clause collect `(not ,u)))) (deflist `( (in ,#'for-in-function) (on ,#'for-on-function) (from ,#'for-from-function) (for ,#'for-for-function) (as ,#'for-for-function) (with ,#'for-with-function) (initially ,#'for-initially-function) (finally ,#'for-finally-function) (do ,#'for-do-function) (doing ,#'for-do-function) (collect ,#'for-collect-function) (collecting ,#'for-collect-function) (conc ,#'for-conc-function) (concing ,#'for-conc-function) (join ,#'for-join-function) (joining ,#'for-join-function) (count ,#'for-count-function) (counting ,#'for-count-function) (sum ,#'for-sum-function) (summing ,#'for-sum-function) (product ,#'for-product-function) (maximize ,#'for-maximize-function) (maximizing ,#'for-maximize-function) (minimize ,#'for-minimize-function) (minimizing ,#'for-minimize-function) (union ,#'for-union-function) (unionq ,#'for-unionq-function) (intersection ,#'for-intersection-function) (intersectionq ,#'for-intersectionq-function) (adjoin ,#'for-adjoin-function) (adjoinq ,#'for-adjoinq-function) (always ,#'for-always-function) (never ,#'for-never-function) (thereis ,#'for-thereis-function) (returns ,#'for-returns-function) (returning ,#'for-returns-function) (while ,#'for-while-function) (until ,#'for-until-function) (when ,#'for-when-function) (unless ,#'for-unless-function) ) 'for-function) |
Added psl-1983/util/format.red version [2984850046].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % Format.RED - Formatted print routine % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 27 August 1981 % Copyright (c) 1981 University of Utah % CompileTime << load(Syslisp, Fast!-Vector); flag('(format!-freshline format1 format2 clear!-string!-write return!-string!-write), 'internalfunction); fluid '(FormatForFormat!* string!-write!-channel next!-string!-write!-char string!-write!-buffer); >>; % First, lambda-bind FormatForFormat!* lisp procedure Format(Stream, FormatForFormat!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); Format1(Stream, FormatForFormat!*, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); % Then, push all the registers on the stack and set up a pointer to them lap '((!*entry Format1 expr 15) (!*PUSH (reg 3)) (!*LOC (reg 2) (frame 1)) (!*PUSH (reg 4)) (!*PUSH (reg 5)) (!*PUSH (reg 6)) (!*PUSH (reg 7)) (!*PUSH (reg 8)) (!*PUSH (reg 9)) (!*PUSH (reg 10)) (!*PUSH (reg 11)) (!*PUSH (reg 12)) (!*PUSH (reg 13)) (!*PUSH (reg 14)) (!*PUSH (reg 15)) (!*CALL Format2) (!*EXIT 14) ); on SysLisp; % Finally, actual Format, with 2 arguments, stream and % pointer to array of parameters syslsp procedure Format2(Stream, FormatArgs); %. Formatted print % % If the character is not one of these (either upper or lower case), then an % error occurs. % begin scalar UpLim, I, Ch, UpCh; if Stream eq NIL then << Stream := lispvar string!-write!-channel; clear!-string!-write() >> else if Stream eq T then Stream := LispVar OUT!*; UpLim := StrLen StrInf LispVar FormatForFormat!*; I := 0; while I <= UpLim do << Ch := StrByt(StrInf LispVar FormatForFormat!*, I); if Ch neq char !~ then ChannelWriteChar(Stream, Ch) else begin I := I + 1; Ch := StrByt(StrInf LispVar FormatForFormat!*, I); UpCh := if Ch >= char lower A and Ch <= char lower Z then IPlus2(IDifference(Ch, char lower A), char A) else Ch; case UpCh of char A: << ChannelPrin2(Stream, FormatArgs[0]); FormatArgs := &FormatArgs[StackDirection] >>; char S: << ChannelPrin1(Stream, FormatArgs[0]); FormatArgs := &FormatArgs[StackDirection] >>; char D: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 10); FormatArgs := &FormatArgs[StackDirection] >>; char B: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 2); FormatArgs := &FormatArgs[StackDirection] >>; char O: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 8); FormatArgs := &FormatArgs[StackDirection] >>; char X: << ChannelWriteSysInteger(Stream, Int2Sys FormatArgs[0], 16); FormatArgs := &FormatArgs[StackDirection] >>; char !~: ChannelWriteChar(Stream, char !~); char !%: ChannelWriteChar(Stream, char EOL); char '!&: format!-freshline Stream; default: StdError BldMsg('"Unknown character code for Format: %r", MkID Ch); end; end; I := I + 1 >>; if Stream eq LispVar string!-write!-channel then return return!-string!-write(); end; off SysLisp; lisp procedure format!-freshline Stream; (lambda out!*; if IGreaterP(Posn(), 0) then ChannelWriteChar(Stream, char EOL))(Stream); lisp procedure Ferror(Condition, FMT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13); Error(Condition, Format(NIL, FMT, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, A11, A12, A13)); lisp procedure string!-write!-char(stream, ch); if IGEQ(next!-string!-write!-char, 5000) then StdError "String overflow in FORMAT" else << next!-string!-write!-char := iadd1 next!-string!-write!-char; iputs(string!-write!-buffer, next!-string!-write!-char, ch) >>; lisp procedure clear!-string!-write(); << channelwritechar(string!-write!-channel, char EOL); next!-string!-write!-char := -1 >>; lisp procedure return!-string!-write(); begin scalar x, y; y := 0; next!-string!-write!-char := iadd1 next!-string!-write!-char; x := make!-string(next!-string!-write!-char, char NULL); while ILEQ(y, next!-string!-write!-char) do << iputs(x, y, igets(string!-write!-buffer, y)); y := iadd1 y >>; return x; end; string!-write!-buffer := make!-string(5000, char NULL); specialreadfunction!* := 'WriteOnlyChannel; specialwritefunction!* := 'string!-write!-char; specialclosefunction!* := 'IllegalStandardChannelClose; string!-write!-channel := open("", 'special); (lambda (x); << LineLength 10000; WRS x >> )(WRS string!-write!-channel); END; |
Added psl-1983/util/graph-tree.build version [3abf483c84].
> > | 1 2 | compiletime <<load useful>>; in "graph-tree.sl"$ |
Added psl-1983/util/graph-tree.sl version [61511a059b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Needs USEFUL at compile time (fluid '(graph-nodes* node-index*)) (de graph-to-tree (u) (let ((graph-nodes* nil)(node-index* 0)) (graph-to-tree-1 u))) (de graph-to-tree-1 (u) (let ((x)) (cond ((not (or (pairp u) (vectorp u))) u) ((setf x (atsoc u graph-nodes*)) (when (null (cdr x)) (setf (cdr x) (incr node-index*))) (newid (bldmsg "<%w>" (cdr x)))) (t (let* ((p (ncons u)) (graph-nodes* (cons p graph-nodes*)) (v (if (vectorp u) (for (from i 0 (upbv u)) (with (v (mkvect (upbv u)))) (do (setf (getv v i) (graph-to-tree-1 (getv u i)))) (returns v)) (cons (graph-to-tree-1 (car u)) (graph-to-tree-1 (cdr u)))))) (if (cdr p) (list (newid (bldmsg "<%w>:" (cdr p))) v) v)))))) (de cprint (u) (let ((currentscantable* lispscantable*)) (prettyprint (graph-to-tree u)) nil)) |
Added psl-1983/util/gsort.build version [bb407f4173].
> > | 1 2 | CompileTime load Syslisp; in "gsort.red"$ |
Added psl-1983/util/gsort.red version [4d18fbc016].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %=================================================================== % Simple sorting functions for PSL strings and Ids % use with FindPrefix and FindSuffix % MLG, 8:16pm Monday, 14 December 1981 %=================================================================== % Revision History % % Edit by Cris Perdue, 26 Jan 1983 1343-PST % Fixed the order of arguments in one call to make GMergeSort stable. % MLG, 2 Jan 1983 % Changed IDSORT form Macro to procedure, so that % it could be redefined for experiments with alternate GSORT % Affected RCREF and FIND lisp procedure StringCompare(S1,S2); % Returns 1,0,-1 for S1<S2,S1=S2,S1>S2 % String Comparison Begin scalar L1,L2,I,L; L1:=Size(S1); L2:=Size(S2); L:=MIN2(L1,L2); I:=0; loop: If I>L then return(If L1 <L2 then 1 else if L1 > L2 then -1 else 0); if S1[I] < S2[I] then return 1; if S1[I] > S2[I] then return (-1); I:=I+1; goto loop; End; lisp procedure IdCompare(D1,D2); % Compare IDs via print names %/ What of case StringCompare(Id2String D1,Id2String D2); lisp procedure SlowIdSort DList; % Worst Possible Sort; If Null DList then NIL else InsertId(car Dlist, SlowIdSort Cdr Dlist); lisp procedure InsertId(D,DL); If Null DL then D . Nil else if IdCompare(D,Car DL)>=0 then D . DL else Car Dl . InsertId(D,Cdr Dl); % ======= Tree based ALPHA-SORT package, derived from CREF % routines modified from FUNSTR for alphabetic sorting % % Tree Sort of list of ELEM % % Tree is NIL or STRUCT(VAL:value,SONS:Node-pair) % Node-pair=STRUCT(LNode:tree,RNode:tree); lisp smacro procedure NewNode(Elem); %/ use A vector? LIST(Elem,NIL); lisp smacro procedure VAL Node; % Access the VAL in node CAR Node; lisp smacro procedure LNode Node; CADR Node; lisp smacro procedure RNode Node; CDDR Node; lisp smacro procedure NewLeftNode(Node,Elem); RPLACA(CDR Node,NewNode Elem); lisp smacro procedure NewRightNode(Node,Elem); RPLACD(CDR Node,NewNode Elem); lisp procedure IdSort LST; % Sort a LIST of ID's. Do not remove Dups % Build Tree then collapse; Tree2LST(IdTreeSort(LST),NIL); lisp procedure IdTreeSort LST; % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO IdPutTree(CAR LST,Tree); Return Tree; END; lisp smacro procedure IdPlaceToLeft (Elem1,Elem2); % ReturnS T If Elem to go to left of Node IdCompare(Elem1,Elem2)>=0; lisp procedure IdPutTree(Elem,Node); % Insert Elements into Tree Begin DWN: If Not IdPlaceToLeft(Elem,VAL Node) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; lisp procedure Tree2LST(Tree,LST); % Collapse Tree to LIST Begin While Tree DO <<LST:=VAL(Tree) .Tree2LST(RNode Tree,LST); Tree:=LNode Tree>>; Return LST; END; % More General Sorting, given Fn=PlaceToRight(a,b); lisp procedure GenSort(LST,Fn); % Sort a LIST of elems % Build Tree then collapse; Tree2LST(GenTreeSort(LST,Fn),NIL); lisp procedure GenTreeSort(LST,Fn); % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO GenPutTree(CAR LST,Tree,Fn); Return Tree; END; lisp procedure GenPutTree(Elem,Node,SortFn); % Insert Elements into Tree Begin DWN: If Not Apply(SortFn,list(Elem,VAL Node)) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; % More General Sorting, given SortFn=PlaceToLeft(a,b); lisp procedure GSort(LST,SortFn); % Sort a LIST of elems % Build Tree then collapse; Begin CopyD('GsortFn!*,SortFn); LST:= Tree2LST(GTreeSort LST,NIL); RemD('GsortFn!*); Return LST; End; lisp procedure GTreeSort LST; % Uses insert of Element to Tree; Begin scalar Tree; If NULL LST then Return NIL; Tree:=NewNode CAR LST; % First Element While PAIRP(LST:=CDR LST) DO GPutTree(CAR LST,Tree); Return Tree; END; lisp procedure GPutTree(Elem,Node); % Insert Elements into Tree Begin DWN: If Not GSortFn!*(Elem,VAL Node) then GOTO RGT; If LNode Node then <<Node:=LNode Node;GO TO DWN>>; NewLeftNode(Node,Elem); Return; RGT: If RNode Node then <<Node:=RNode Node;GO TO DWN>>; NewRightNode(Node,Elem); Return; END; % Standard Comparison Functions: lisp procedure IdSortFn(Elem1,Elem2); % ReturnS T If Elem1 to go to right of Elem 2; IdCompare(Elem1,Elem2)>=0; lisp procedure NumberSortFn(Elem1,Elem2); Elem1 <= Elem2; lisp procedure NumberSort Lst; Gsort(Lst,'NumberSortFn); lisp procedure StringSortFn(Elem1,Elem2); StringCompare(Elem1,Elem2)>=0; lisp procedure StringSort Lst; Gsort(Lst,'StringSortFn); lisp procedure NoSortFn(Elem1,Elem2); NIL; lisp procedure AtomSortFn(E1,E2); % Ids, Numbers, then strings; If IdP E1 then If IdP E2 then IdSortFn(E1,E2) else NIL else if Numberp E1 then if IdP E2 then T else if NumberP E2 then NumberSortFn (E1,E2) else NIL else if StringP(E1) then if IDP(E2) then T else if Numberp E2 then T else StringSortFn(E1,E2) else NIL; lisp procedure AtomSort Lst; Gsort(Lst,'AtomSortFn); lisp procedure StringLengthFn(S1,S2); % For string length % String Length Comparison Size(S1)<=Size(S2); procedure IdLengthFn(e1,e2); StringLengthFn(Id2string e1,Id2string e2); On syslisp; syslsp procedure SC1(S1,S2); % Returns T if S1<=S2 % String Comparison Begin scalar L1,L2,I,L; S1:=Strinf s1; S2:=Strinf S2; L1:=StrLen(S1); L2:=StrLen(S2); If L1>L2 then L:=L2 else L:=L1; I:=0; loop: If I>L then return(If L1 <=L2 then T else NIL); if StrByt(S1,I) < StrByt(S2,I) then return T; if StrByt(S1,I) > StrByt(S2,I) then return NIL; I:=I+1; goto loop; End; syslsp procedure IdC1(e1,e2); Sc1(ID2String e1, ID2String e2); syslsp procedure SC2(S1,S2); % Returns T if S1<=S2 % String Comparison done via packed word compare, may glitch Begin scalar L1,L2,I,L; S1:=Strinf s1; S2:=Strinf S2; L1:=Strpack StrLen(S1); L2:=strpack StrLen(S2); S1:=S1+1; S2:=S2+1; If L1>L2 then L:=L2 else L:=L1; I:=0; %/ May be off by one? loop: If I>L then return(If L1 <=L2 then T else NIL); if S1[I] < S2[I] then return T; if S1[I] > S2[I] then return NIL; I:=I+1; goto loop; End; syslsp procedure IdC2(e1,e2); Sc2(ID2String e1,ID2String e2); Off syslisp; Lisp procedure GsortP(Lst,SortFn); Begin If Not PairP Lst then return T; L: If Not PairP Cdr Lst then Return T; If Not Apply(SortFn,list(Car Lst, Cadr Lst)) then return NIL; Lst :=Cdr Lst; goto L; END; Lisp procedure GMergeLists(L1,L2,SortFn); If Not PairP L1 then L2 else if Not PairP L2 then L1 else if Apply(SortFn,list(Car L1, Car L2)) then Car(L1) . GMergeLists(cdr L1, L2,SortFn) else car(L2) . GmergeLists(L1, cdr L2,SortFn); Lisp procedure MidPoint(Lst1,Lst2,M); % Set MidPointer List at M Begin While Not (Lst1 eq Lst2) and M>0 do <<Lst1 := cdr Lst1; M:=M-1>>; return Lst1; End; Lisp procedure GMergeSort(Lst,SortFn); GMergeSort1(Lst,NIL,Length Lst,SortFn); Lisp procedure GMergeSort1(Lst1,Lst2,M,SortFn); If M<=0 then NIL else if M =1 then if null cdr Lst1 then Lst1 else List Car lst1 else if M=2 then (if Apply(SortFn,list(Car Lst1,Cadr Lst1)) then List(Car Lst1, Cadr Lst1) else List(Cadr Lst1,Car lst1)) else begin scalar Mid,M1; M1:=M/2; Mid :=MidPoint(Lst1,Lst2,M1); Lst1 :=GMergeSort1(Lst1,Mid, M1,SortFn); Lst2 :=GmergeSort1(Mid,Lst2, M-M1,SortFn); Return GmergeLists(Lst1,Lst2,SortFn); end; end; |
Added psl-1983/util/h-stats-1.red version [e3f3b5815c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% "SysLisp" part of the HEAP-STATS package. %%% %%% Author: Cris Perdue %%% December 1982 %%% Documented January 1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% on SysLisp; compiletime << put('igetv,'assign!-op,'iputv); >>; %%% Magic constants defining the layout of a "heap-stats" object. compiletime << Internal WConst TemplateX = 2, StringTabX = 3, StringSpaceX = 4, VectTabX = 5, VectSpaceX = 6, WordTabX = 7, WordSpaceX = 8, Pairs = 9, Strings = 10, HalfWords = 11, WordVecs = 12, Vectors = 13; >>; %%% This procedure sweeps the heap and collects statistics into %%% its argument, which is a heap-stats object. This routine may %%% be called as part of a garbage collection, so it may not do %%% any allocation whatsoever from the heap. Moderate size %%% integers are assumed to have in effect no tag. syslsp procedure HeapStats(Results); begin scalar CurrentItem, ObjLen, Last, HistoSize, StdTemplate, StringHTab, StringSpaceTab, VectHTab, VectSpaceTab, WordHTab, WordSpaceTab, Len; %% Check that the argument looks reasonable. if neq(isizev(Results), 13) then return nil; StdTemplate := igetv(Results,TemplateX); StringHTab := igetv(Results,StringTabX); StringSpaceTab := igetv(Results,StringSpaceX); VectHTab := igetv(Results,VectTabX); VectSpaceTab := igetv(Results,VectSpaceX); WordHTab := igetv(Results,WordTabX); WordSpaceTab := igetv(Results,WordSpaceX); %% Check the various subobjects of the argument to see that %% they look reasonable. The returns are all errors effectively. HistoSize := isizev(StdTemplate) + 1; if neq(isizev(StringHTab),HistoSize) then return 1; if neq(isizev(StringSpaceTab),HistoSize) then return 2; if neq(isizev(VectHTab),HistoSize) then return 3; if neq(isizev(VectSpaceTab),HistoSize) then return 4; if neq(isizev(WordHTab),HistoSize) then return 5; if neq(isizev(WordSpaceTab),HistoSize) then return 6; igetv(Results,Pairs) := 0; igetv(Results,Strings) := 0; igetv(Results,HalfWords) := 0; igetv(Results,WordVecs) := 0; igetv(Results,Vectors) := 0; FillVector(StringHTab,0); FillVector(StringSpaceTab,0); FillVector(VectHTab,0); FillVector(VectSpaceTab,0); FillVector(WordHTab,0); FillVector(WordSpaceTab,0); Last := HeapLast(); CurrentItem := HeapLowerBound(); while CurrentItem < Last do begin case Tag @CurrentItem of BTRTAG, CODE, NEGINT, POSINT, ID, UNBOUND, STR, BYTES, FIXN, FLTN, BIGN, WRDS, Halfwords, PAIR, VECT, EVECT: << ObjLen := 2; % must be first of pair igetv(Results,Pairs) := igetv(Results,Pairs) + 1; >>; HBYTES: << Len := StrLen CurrentItem; ObjLen := 1 + StrPack Len; igetv(Results,Strings) := igetv(Results,Strings) + 1; Histo(StdTemplate,StringHTab,Len+1,StringSpaceTab,ObjLen); >>; HHalfwords: << ObjLen := 1 + HalfWordPack HalfWordLen CurrentItem; igetv(Results,HalfWords) := igetv(Results,HalfWords) + 1; >>; HWRDS: << Len := WrdLen CurrentItem; ObjLen := 1 + WrdPack Len; igetv(Results,WordVecs) := igetv(Results,WordVecs) + 1; Histo(StdTemplate,WordHTab,Len+1,WordSpaceTab,ObjLen); >>; HVECT: << Len := VecLen CurrentItem; ObjLen := 1 + VectPack Len; igetv(Results,Vectors) := igetv(Results,Vectors) + 1; Histo(StdTemplate,VectHTab,Len+1,VectSpaceTab,ObjLen); >>; default: Error(0,"Illegal item in heap at %o", CurrentItem); end; % case CurrentItem := CurrentItem + ObjLen; end; Results; end; %%% Internal utility routine used by heapstats to accumulate %%% values into the statistics tables. The template is a %%% histogram template. The table is a histogram table. The %%% "value" is tallied into the appropriate bucket of the table %%% based on the template. Spacetab is similar to "table", but %%% the value of "space" will be added rather than tallied into %%% spacetab. Syslsp procedure Histo(Template,Table,Value,SpaceTab,Space); begin for i := 0 step 1 until isizev(Template) do if igetv(Template,i) >= Value then << igetv(Table,i) := igetv(Table,i) + 1; igetv(SpaceTab,i) := igetv(SpaceTab,i) + Space; return; >>; if Value > igetv(Template,isizev(Template)) then << igetv(Table,isizev(Template)+1) := igetv(Table,isizev(Template)+1) + 1; igetv(SpaceTab,isizev(Template)+1) := igetv(SpaceTab,isizev(Template)+1) + Space; >>; end; SysLsp procedure FillVector(v,k); for i := 0 step 1 until isizev(v) do igetv(v,i) := k; |
Added psl-1983/util/hash.sl version [108d9bea5b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Hash table package, rather general purpose. %%% Author: Cris Perdue 8/25/82 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Edit by Cris Perdue, 25 Feb 1983 1408-PST % Cleaned up code and documentation for demo. % Added NBuckets as an INITable variable. (compiletime (load if)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Hash table flavor. %%% %%% This is an external chaining hash table. Thus the table can never %%% overflow and collision path length grows slowly, though search time %%% can theoretically grow large. The implementation includes ability %%% to delete an association plus several other bells and whistles. %%% %%% Hash table instantiation can be as simple as: %%% (make-instance 'hash). %%% %%% Options to make-instance are: %%% NBuckets: Number of hash buckets to create initially. Defaults %%% to 100. %%% HashFn: Given a key, must return a fairly large pseudo-random %%% integer. Defaults to StrHash, for string keys. %%% NullValue: A value for Lookup to return if no association is found. %%% Defaults to NIL. %%% MaxFillRatio: A floating point number which is the maximum ratio of %%% the number of associations to the number of buckets. %%% If this ratio is reached, the table will be enlarged %%% to make the ratio about .5. Defaults to 2.0. %%% KeyCopyFn: Used by PutAssn. In some cases when a new association %%% is created one may want to copy the key so that it %%% will be guaranteed not to be modified. Defaults to %%% a function that returns its argument without any copying. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Gettable state: %%% %%% Usage: Number of associations currently in the table. %%% NullValue: Value for Lookup to return if no association found. %%% %%% The following relate specifically to associations made via %%% hash table: %%% MaxFillRatio %%% NBuckets %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Operations: %%% %%% Present?(key) %%% %%% Returns T or NIL depending on whether there is an association with %%% the given key. %%% %%% Lookup(key) %%% %%% Returns the value associated with the key, or the NullValue for the %%% table if no association exists. %%% %%% PutAssn(key value) %%% %%% Makes an association between the key and value, replacing any old %%% association. The key may be copied if a new association is created, %%% otherwise the copy of the key already stored continues to be used. %%% Returns the value. %%% %%% DeleteAssn(key) %%% %%% Deletes any association that may exist for the key. Returns a value %%% in the manner of Lookup. %%% %%% ReSize(size) %%% %%% Rehashes the table into "size" buckets. This operation is specific %%% to associations made with hash tables. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Preliminaries: definitions, etc. (setq bitsperword 32) % Hack to use from LISP. % Available as constant in SYSLISP. % In this package need only be no % greater than actual bits per word. (defmacro funcall (fn . args) `(apply ,fn (list ,@args))) %%% Hash flavor definition. (defflavor Hash (Table (NBuckets 100) (Usage 0) OverFlowLevel (MaxFillRatio 2.0) (HashFn 'StrHash) (NullValue NIL) (CompareFn 'String=) (KeyCopyFn 'no-op)) () (gettable-instance-variables NBuckets Usage NullValue MaxFillRatio) (initable-instance-variables NBuckets MaxFillRatio HashFn NullValue KeyCopyFn) ) (defmethod (Hash init) (init-plist) %% Perhaps the table size should be prime . . . (setf Table (MkVect (- NBuckets 1))) (while (<= MaxFillRatio .5) (ContinuableError 0 "Set MaxFillRatio greater than .5 before continuing" t)) (setf OverFlowLevel (Fix (* NBuckets MaxFillRatio)))) (defmethod (Hash Present?) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (if (Ass CompareFn Key (indx Table i)) then t else nil))) (defmethod (Hash Lookup) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (indx Table i)))) (if Entry then (cdr Entry) else NullValue)))) (defmethod (Hash PutAssn) (key value) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (indx Table i)))) (if Entry then (RplacD Entry value) else (setf (indx Table i) (cons (cons (funcall KeyCopyfn key) value) (indx Table i))) (setf Usage (add1 Usage)) (if (not (< Usage OverFlowLevel)) then (=> Self resize (* 2 Usage)))))) value) (defmethod (Hash DeleteAssn) (key) (let ((i (Hash$HashBucket Table (funcall HashFn Key)))) (let ((Entry (Ass CompareFn Key (indx Table i))) (Value)) (if Entry then (setq Value (cdr Entry)) (setf (indx Table i) (DelQIP Entry (indx Table i))) (setf Usage (- Usage 1)) Value else NullValue)))) (defmethod (Hash MapAssn) (fn) (for (from i 0 (Size Table)) (do (for (in a (indx Table i)) (do (funcall fn (car a))))))) % Operations that are not basic (defmethod (Hash ReSize) (new-size) (if (< new-size 1) (StdError (BldMsg "Hash table size of %p too small" new-size))) (let ((newtable (mkvect (- new-size 1))) (oldtable table)) (setf NBuckets new-size) (setf Table newtable) (setf OverFlowLevel (Fix (* NBuckets MaxFillRatio))) (setf Usage 0) (for (from i 0 (Size oldtable)) (do (for (in a (indx oldtable i)) (do (=> Self PutAssn (car a) (cdr a)))))) Self)) %%% Internal functions (defun Hash$HashBucket (table hashed-key) % Returns index of bucket (remainder hashed-key (size table))) (defun no-op (x) x) %%% Useful related function (defun StrHash (S) % Compute hash function of string (let ((len (Size S)) % (StrLen S) (AvailableBits (Difference BitsPerWord 8)) (HashVal 0)) (if (GreaterP Len AvailableBits) then (setq Len AvailableBits)) % (setq s (StrInf s)) (for (from I 0 Len) (do (setq HashVal (LXOR HashVal (LShift (Indx S I) % (StrByt S I) (Difference AvailableBits I)))))) HashVal)) |
Added psl-1983/util/hcons.sl version [ee0ba306b8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % HCONS.SL - Hashing (unique) CONS and associated utilities. % % Author: William Galway % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 2 June 1982 % Copyright (c) 1982 University of Utah % (BothTimes % ?? Compile time may suffice. (load useful) (load fast-vector)) % Summary of "user level" functions provided: % (DM Hcons (X) ...) % Nary hashed cons, right associative. % (DN Hlist (X) ...) % Hcons version of "list" function. % Hcons version of "copy" function. Note that unlike copy, this is not % guaranteed to create a new copy of a structure. (In fact, rather the % opposite.) % (DE Hcopy (lst) ...) % (DE Happend (U V) ...) % Hcons version of "append" function. % (DE Hreverse (U) ...) % Hcons version of "reverse" function. % Pairs for property list functions must be created by Hcons. % Get property of id or pair. % (DE extended-get (id-or-pair indicator) ...) % Put property of id or pair. Known to setf. % (DE extended-put (id-or-pair indicator val) ...) % Number of hash "slots" in table, should be a prime number to get an even % spread of hits (??). This package has been written so that it should be % possible to modify this size at runtime (I hope). So if the hash-tables % get too heavily loaded they can be copied to larger ones. (DefConst hcons-table-size 103) % Build the two tables (we switch from one to the other on each garbage % collection. Note that (MkVect 1) gives TWO locations. (setf hash-cons-tables (MkVect 1)) (setf (IGetV hash-cons-tables 0) (MkVect (sub1 (const hcons-table-size)))) (setf (IGetV hash-cons-tables 1) (MkVect (sub1 (const hcons-table-size)))) % current-table-number switches between 0 and one at each garbage % collection--selecting the current table to use. (setf current-table-number 0) (DE next-table-number (table-number) (cond ((equal table-number 0) 1) (T 0))) % Should really use structs for this, but I'm unsure on the exact details % of how structs work, and it's very important to understand how much free % space will be demanded by any routines that are called. % Anyway, each location in a "hash table" is either NIL, or an "entry", % where an entry is implemented as a vector of % [ <dotted-pair> <property-list-for-pair> <next-entry-in-chain> ] % This should be done differently too. (DefConst entry-size 4) % The size of an entry in "heap units"?? (DefConst pair-size 2) % Similarly for pairs. (DS create-hash-entry () % Create a 3 element vector. (MkVect 2)) (DS pair-info (ent) (IGetV ent 0)) (DS prop-list-info (ent) (IGetV ent 1)) (DS next-entry (ent) (IGetV ent 2)) % Finds a location within a "hash table", for a pair (X,Y). % This version is very simpleminded! (DS hcons-hash-function (htable X Y) (remainder % Take absolute value to avoid sign problems with remainder. (abs (plus (Sys2Int X) (Sys2Int Y))) (add1 (ISizeV htable)))) % Copy entries from one "hash cons table" to another, setting the source % table to all NILs. Return the dst-table, as well as copying into it. % This routine is used to place entries in their new locations after a % garbage collection. This routine MUST NOT allocate anything on the heap. (DE move-hcons-table (src-table dst-table) (prog (dst-index src-entry src-pair nxt-entry) (for (from src-index 0 (ISizeV src-table) 1) (do (progn (setf src-entry (IGetV src-table src-index)) % Use GetV here, until "the bug" in IGetV gets fixed. (setf (GetV src-table src-index) NIL) (while src-entry (progn (setf src-pair (pair-info src-entry)) (setf dst-index (hcons-hash-function dst-table (car src-pair) (cdr src-pair))) % Save the next entry in the the chain, and then relink the % current entry into its new location. (setf nxt-entry (next-entry src-entry)) (setf (next-entry src-entry) (IGetV dst-table dst-index)) (setf (IGetV dst-table dst-index) src-entry) % Move to next thing in chain. (setf src-entry nxt-entry)))))) (return dst-table))) % Nary version of hashed cons. (DM Hcons (X) (RobustExpand (cdr X) 'hcons2 NIL)) % Binary "hashed" cons of X and Y, returns pointer to previously % constructed pair if it can be found in the hash table. (DE Hcons2 (X Y) (prog (hashloc hitchain tmpchain newpair newentry) (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) X Y)) % Get chain of entries at the appropriate hash location in the % appropriate table. (setf hitchain (IGetV (IGetV hash-cons-tables current-table-number) hashloc)) % Search for a previously constructed pair, if any, with car and cdr % equal to X and Y respectively. % Note that tmpchain is not a list, but a "chain" of "entries". (setf tmpchain hitchain) (while (and tmpchain % Keep searching unless an exact match is found. (not (and % EqN test might be better, so that we handle numbers % intelligently? Probably have to worry about hash % code also. (eq X (car (setf newpair (pair-info tmpchain)))) (eq Y (cdr newpair))))) % do (setf tmpchain (next-entry tmpchain))) (cond % If no entry was found, create a new one. ((null tmpchain) (progn % We need enough room for one new pair, plus one new entry. If % there isn't enough room on the heap then collect garbage (and % in the process move EVERYTHING around, switch hash tables, % etc.) (cond ((LessP (GtHeap NIL) % Returns free space in heap. (plus (const pair-size) (const entry-size))) (progn (reclaim) % Recalculate locations of everything. (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) X Y)) % Get chain of entries at the appropriate hash location in % the appropriate table. (setf hitchain (IGetV (IGetV hash-cons-tables current-table-number) hashloc))))) % Allocate the new pair, store information into the appropriate % spot in appropriate table. (setf newpair (cons X Y)) (setf newentry (create-hash-entry)) (setf (pair-info newentry) newpair) (setf (prop-list-info newentry) NIL) (setf (next-entry newentry) hitchain) % Link the new entry into the front of the table. (setf (IGetV (IGetV hash-cons-tables current-table-number) hashloc) newentry)))) % Return the pair (either newly constructed, or old). (return newpair))) % "hcons" version of "list" function. (DN Hlist (X) (do-hlist X)) (DE do-hlist (X) (cond ((null X) NIL) (T (hcons (car X) (do-hlist (cdr X)))))) % "hcons" version of copy. Note that unlike copy, this is not guaranteed % to create a new copy of a structure. (In fact, rather the opposite.) (DE Hcopy (lst) (cond ((not (pairp lst)) lst) (T (hcons (hcopy (car lst)) (hcopy (cdr lst)))))) % "hcons" version of Append function. (DE Happend (U V) (cond % First arg is NIL, or some other non-pair. ((not (PairP U)) V) % else ... (T (hcons (car U) (Happend (cdr U) V))))) % Hcons version of Reverse. (DE Hreverse (U) (prog (V) (while (PairP U) (progn (setf V (hcons (car U) V)) (setf U (cdr U)))) (return V))) % Look up and return the entry for a pair, if any. Return NIL if argument % is not a pair. (DE entry-for-pair (p) (cond ((PairP p) (prog (hashloc ent) (setf hashloc (hcons-hash-function (IGetV hash-cons-tables current-table-number) (car p) (cdr p))) % Look at appropriate spot in hash table. (setf ent (IGetV (IGetV hash-cons-tables current-table-number) hashloc)) % Search through chain for p. (while (and ent (not (eq (pair-info ent) p))) (setf ent (next-entry ent))) % Return the entry, or NIL if none found. (return ent))))) % Get a property for a pair or identifier. Only pairs stored in the hash % table have properties. (DE extended-get (id-or-pair indicator) (cond ((IdP id-or-pair) (get id-or-pair indicator)) ((PairP id-or-pair) (prog (proplist prop-pair) (setf proplist (pair-property-list id-or-pair)) (setf prop-pair (atsoc indicator proplist)) (return (cond ((PairP prop-pair) (cdr prop-pair)))))))) % Put function for pairs and identifiers. Only pairs in the hash table can % be given properties. (We are very sloppy about case when pair isn't in % table, but hopefully the code won't blow up.) "val" is returned in all % cases. (DE extended-put (id-or-pair indicator val) (cond ((IdP id-or-pair) (put id-or-pair indicator val)) ((PairP id-or-pair) (prog (proplist prop-pair) (setf proplist (pair-property-list id-or-pair)) % Get the information (if any) stored under the indicator. (setf prop-pair (Atsoc indicator proplist)) (cond % Modify the information under the indicator, if any. ((PairP prop-pair) (setf (cdr prop-pair) val)) % Otherwise (nothing found under indicator), create new % (indicator . value) pair. (T (progn % Note use of cons, not Hcons, WHICH IS RIGHT? (I think cons.) (setf prop-pair (cons indicator val)) % Tack new (indicator . value) pair onto property list, and % store in entry for the pair who's property list is being % hacked. (set-pair-property-list id-or-pair (cons prop-pair proplist))))) % We return the value even if the pair isn't in the hash table. (return val))))) (PUT 'extended-get 'assign-op 'extended-put) (FLAG '(extended-get) 'SETF-SAFE) % Return the "property list" associated with a pair. (DE pair-property-list (p) (prog (ent) (setf ent (entry-for-pair p)) (return (cond (ent (prop-list-info ent)) (T NIL))))) % Set the "property list" cell for a pair, return the new "property list". (DE set-pair-property-list (p val) (prog (ent) (setf ent (entry-for-pair p)) (return (cond (ent (setf (prop-list-info ent) val)) (T NIL))))) % We redefine the garbage collector so that it rebuilds the hash table % after garbage collection has moved everything. (putd 'original-!%Reclaim (car (getd '!%Reclaim)) (cdr (getd '!%Reclaim))) % New version of !%reclaim--shuffles stuff in cons tables after collecting % garbage. (DE !%Reclaim () (prog1 (original-!%Reclaim) % Move the old table to the new one, shuffling everything into its % correct position. (move-hcons-table % Would use IGetV, but there appears to be a bug preventing it from % working. % Source (GetV hash-cons-tables current-table-number) % Destination (GetV hash-cons-tables (next-table-number current-table-number))) % Point to new "current-table". (setf current-table-number (next-table-number current-table-number)))) |
Added psl-1983/util/heap-stats.sl version [5b1d9328b0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Ordinary LISP part of the heap statistics gathering package, HEAP-STATS. %%% Load this file to get the package. %%% The top-level function is collect-stats. See its description. %%% %%% Author: Cris Perdue %%% December 1982 %%% Documented and cleaned up a litte, January 1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load if)) (load h-stats-1 get-heap-bounds) %%% An object that holds a complete set of statistics for the heap %%% at some moment in time. When one of these is created, the %%% instance variable "template" must be initialized, and the %%% template must be a "histogram template" as discussed below. %%% Maintainer note: the code that actually gathers statistics assumes %%% that the heap-stats object is a vector (or evector) with a header, %%% 2 items of data allocated by the objects package, then the data shown %%% here, in order. (defflavor heap-stats (template string-count string-space vector-count vector-space wordvec-count wordvec-space (pairs 0) (strings 0) (halfwords 0) (wordvecs 0) (vectors 0)) () (initable-instance-variables template) gettable-instance-variables) (defmethod (heap-stats init) (init-plist) (if (not (vectorp template)) then (error 0 "The TEMPLATE of a HEAP-STATS object must be initialized.")) (let ((s (+ (size template) 1))) (setf string-count (make-vector s 0)) (setf string-space (make-vector s 0)) (setf vector-count (make-vector s 0)) (setf vector-space (make-vector s 0)) (setf wordvec-count (make-vector s 0)) (setf wordvec-space (make-vector s 0)))) (global '(old-!%reclaim stats-channel)) %%% This method prints statistics on a particular snapshot of the heap %%% onto the given channel. (defmethod (heap-stats print-stats) (channel) (channelprintf channel "%w pairs, %w strings, %w vectors, %w wordvecs, %w halfwordvecs%n%n" pairs strings vectors wordvecs halfwords) (for (in table (list string-count vector-count)) (in spacetable (list string-space vector-space)) (in title '("STRINGS" "VECTORS")) (do (channelprintf channel "%w%n%n" title) (print-histo template table spacetable channel) (channelterpri channel) (channelterpri channel)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Internal functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Prints a single histogram onto the given channel. Arguments %%% are the template from which the histogram was generated, a %%% corresponding table with a count of the number of objects of %%% each size range, and another corresponding table with the %%% total space occupied by the objects within each size range. (defun print-histo (template table spacetable channel) (channelprintf channel "Size <= n%tHow many%tStorage items used%n" 12 24) (channelprintf channel "------------------------------------------%n") (for (from i 0 (size template)) (do (channelprintf channel "%w%t%w%t%w%n" (indx template i) 12 (indx table i) 24 (indx spacetable i)))) (channelprintf channel "> %w%t%w%t%w%n" (indx template (size template)) 12 (indx table (+ (size template) 1)) 24 (indx spacetable (+ (size template) 1)))) (fluid '(before-stats after-stats print-stats? stdtemplate)) %%% This function initializes the collecting of statistics and %%% printing them to a file. The name of the file is the %%% argument to collect-stats. NIL rather than a string for the file %%% name turns statistics collection off. In statistics collection mode %%% statistics are gathered just before and after each garbage collection. (defun collect-stats (file) (if (and file (not old-!%reclaim)) then (if (not (and (eq (object-type before-stats) 'heap-stats) (eq (object-type after-stats) 'heap-stats))) then (printf "Caution: before- and after-stats are not both bound.%n")) (setq old-!%reclaim (cdr (getd '!%reclaim))) (setq stats-channel (open file 'output)) (putd '!%reclaim 'expr '(lambda () (heapstats before-stats) (apply old-!%reclaim nil) (heapstats after-stats) (channelprintf stats-channel "BEFORE RECLAIMING%n%n") (=> before-stats print-stats stats-channel) (channelterpri stats-channel) (channelprintf stats-channel "AFTER RECLAIMING%n%n") (=> after-stats print-stats stats-channel))) elseif (and (not file) old-!%reclaim) then (close stats-channel) (putd '!%reclaim 'expr old-!%reclaim) (setq old-!%reclaim nil) elseif old-!%reclaim then (printf "Statistics collecting is apparently already turned on.%n") else (printf "Statistics collecting is apparently already off.%n") (printf "Trying to close the channel anyway.%n") (close stats-channel))) %%% This is initialized here to be a reasonable histogram template for %%% statistics on heap usage. A histogram template is a vector of %%% integers that define the buckets to be used in collecting the %%% histogram data. All values less than or equal to template[0] %%% go into data[0]. Of those values that do not go into data[0], %%% all less than or equal to template[1] go into data[1], etc.. %%% The vector of data must have at least one more element that %%% the template does. All values greater than the last value in %%% the template go into the following element of the data vector. (setq StdTemplate (make-vector 27 0)) (for (from i 0 16) (do (setf (indx StdTemplate i) i))) (for (from i 17 27) (for k 32 (* k 2)) (do (setf (indx StdTemplate i) k))) (setq before-stats (make-instance 'heap-stats 'template StdTemplate)) (setq after-stats (make-instance 'heap-stats 'template StdTemplate)) |
Added psl-1983/util/help.build version [97448822dd].
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | % Build file for HELP.RED module % MLG, 9 Feb, 1983 % Changed Unix paths to use $ vars CompileTime load If!-System; if_system(Tops20, << HelpFileFormat!* := "ph:%w.hlp"; HelpTable!* := "ph:help.tbl"; >>); if_system(Unix, << HelpFileFormat!* := "$ph/%w.hlp"; HelpTable!* := "$ph/help.tbl"; >>); if_system(HP9836, << HelpFileFormat!* := "ph:%w.hlp"; HelpTable!* := "ph:help.tbl"; >>); in "help.red"$ |
Added psl-1983/util/help.red version [e584a129fc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % HELP.RED - User assistance and documentation % % Author: Eric Benson and Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 23 October 1981 % Copyright (c) 1981 University of Utah % % 30 Dec, 1982, MLG % Move IF_SYSTEM to the Build file % <PSL.UTIL.NEWVERSIONS>HELP.RED, 30-Nov-82 16:31, Edit by GALWAY % Changed "FLAG" to "SWITCH" to avoid confusion with flags on property % lists and to bring terminology in line with PSL manual. % <PSL.UTIL>HELP.RED.3, 1-Dec-82 16:16:39, Edit by BENSON % Added if_system(HP9836, ... ) % <PSL.UTIL>HELP.RED.4, 10-Aug-82 00:54:26, Edit by BENSON % Changed ReadCh to ReadChar in DisplayHelpFile % <PSL.INTERP>HELP.RED.5, 31-May-82 11:50:48, Edit by GRISS % Make it LAPIN Help.Tbl % Changed: to use PH: % Display help texts, invoke interactive HELPs or print default values % Place a HELP function on topic name under 'HelpFunction % Or HELP file on topic name under 'HelpFile % Or even a short string under 'HelpString (this may be removed) fluid '(TopLoopRead!* TopLoopPrint!* TopLoopEval!* TopLoopName!* HelpFileFormat!* Options!* !*Echo HelpIn!* HelpOut!* !*Lower !*ReloadHelpTable HelpTable!* ); !*ReloadHelpTable := T; lisp procedure ReloadHelpTable(); % Set !*ReloadHelpTable to T to cause a fresh help table to be loaded if !*ReloadHelpTable then << LapIn HelpTable!*; !*ReloadHelpTable := NIL >>; lisp procedure DisplayHelpFile F; % Type help file about 'F' begin scalar NewIn, C, !*Echo; (lambda(!*Lower); F := BldMsg(HelpFileFormat!*, F))(T); NewIn := ErrorSet(list('Open, MkQuote F, '(quote Input)), NIL, NIL); if not PairP NewIn then ErrorPrintF("*** Couldn't find help file %r", F) else << NewIn := car NewIn; while not ((C := ChannelReadChar NewIn) = char EOF) do WriteChar C; Close NewIn >>; end; fexpr procedure Help U; % Look for Help on topics U begin scalar OldOut; OldOut := WRS HelpOut!*; ReloadHelpTable(); % Conditional Reload HelpTopicList U; WRS OldOut; end; lisp procedure HelpTopicList U; % Auxilliary function to prind help for each topic in list U if null U then HelpHelp() else for each X in U do begin scalar F; if F := get(X, 'HelpFunction) then Apply(F, NIL) else if F := get(X, 'HelpFile) then DisplayHelpFile F else if F := get(X, 'HelpString) then Prin2T F else DisplayHelpFile X; % Perhaps a File Exists. end; lisp procedure HelpHelp(); % HELPFUNCTION: for help itself << DisplayHelpFile 'Help; FindHelpTopics(); PrintF("%nOptional modules now loaded:%n%l%n",Options!*); >>; lisp procedure FindHelpTopics(); % Scan the ID HAST TABLE for loaded HELP info << PrintF("Help is available on the following topics:%n"); MapObl Function TestHelpTopic; TerPri(); PrintF("The files in the help directory can be read using Help.%n") >>; lisp procedure TestHelpTopic X; % auxilliary function applied to each ID to see if % some help info exists if get(X, 'HelpFunction) or get(X, 'HelpFile) or get(X, 'HelpString) then << Prin2 '! ; Prin1 X >>; lisp procedure HelpTopLoop(); % HELPFUNCTION: for TopLoop, show READER/WRITERS << DisplayHelpFile 'Top!-Loop; if TopLoopName!* then << PrintF("%nCurrently inside %w top loop%n", TopLoopName!*); PrintF("Reader: %p, Evaluator: %p, Printer: %p%n", TopLoopRead!*, TopLoopEval!*, TopLoopPrint!*) >> else PrintF("%nNot currently inside top loop%n") >>; % Switch and global help - record and display all switches and globals. lisp procedure DefineSwitch(Name, Info); % Define important switch % Name does Not have the !*, Info should be a string. % << put(Name, 'SwitchInfo, Info); Name >>; lisp procedure Show1Switch(Name); % Display a single switch begin scalar X; Prin1 Name; Tab 15; Prin1 Eval Intern Concat("*", ID2String Name); If (X := Get(Name, 'SwitchInfo)) then << Tab 25; Prin2 X >>; TerPri(); end; lisp procedure ShowSwitches L; % Display all switches in a list << if not PairP L then MapObl function TestShowSwitch; for each X in L do Show1Switch X >>; lisp procedure TestShowSwitch X; % Support function for 1 switch display if get(X, 'SwitchInfo) then Show1Switch X; lisp procedure DefineGlobal(Name, Info); % Define important global % Name is an ID, Info should be a string. % << put(Name, 'GlobalInfo, Info); Name >>; lisp procedure Show1Global Name; % Display a Single Global begin scalar X; Prin1 Name; Tab 15; Prin1 Eval Name; If (X := get(Name, 'GlobalInfo)) then << Tab 25; Prin2 X >>; TerPri(); end; lisp procedure TestShowGlobal X; % Support for GLOBAL info if get(X, 'GlobalInfo) then Show1Global X; lisp procedure Show1State Name; % Display a single switch or global << if get(Name, 'GlobalInfo) then Show1Global Name; if get(Name, 'SwitchInfo) then Show1Switch Name >>; lisp procedure ShowGlobals L; % Display all globals in a list << if not PairP L then MapObl Function TestShowGlobal; for each X in L do Show1Global X >>; lisp procedure ShowState L; % Display all globals in a list << if not PairP L then MapObl function TestShowState; for each X in L do Show1State X >>; lisp procedure TestShowState X; % Support for a Global if get(X, 'SwitchInfo) or get(X, 'GlobalInfo) then Show1State X; END; |
Added psl-1983/util/history.build version [9c96341fae].
> > | 1 2 | CompileTime load Clcomp; in "history.sl"$ |
Added psl-1983/util/history.sl version [5d255989c1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; File containing functions to create a history mechanism. ;; (exploited what is there with (inp n) (ans n) and historylist*). ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; This file depends upon : init.lisp (basic lisp functions and syntax). ;; (in <lanam.dhl>). ;; ;; This file written by Douglas H. Lanam. September 1982. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; How to use the history mechanism implemented in this file: ;; ;; This file allows you to take any previous input or output and substitute ;; it in place of what you typed. Thus you can either print or redo ;; any input you have previously done. You can also print or ;; execute any result you have previously received. ;; The system will work identify commands by either their history number, ;; or by a subword in the input command. ;; ;; This file also allows you to take any previously expression and do ;; global substitutions on subwords inside words or numbers inside ;; expressions(Thus allowing spelling corrections, and other word ;; changes easily.) ;; ;; This file has a set of read macros that insert the previous history ;; text asked for inplace of them selves. Thus they can be put inside ;; any lisp expression typed by the user. The system will evaluate ;; the resulting expression the same as if the user had retyped everything ;; in himself. ;; ;; ^^ : means insert last input command inplace of ^^. ;; As an input command by itself, ;; ^^ by itself means redo last command. ;; ;; ^n : where n is a number replaces itself with the result of ;; (inp n). ^n by itself means (redo n). ;; ^+n : same as ^n. ;; ^-n : is replaced by the nth back command. ;; replaced with the result of ;; (inp (- current-history-number n)). ;; by itself means (redo (- current-history-number n)) ;; ;; ^word : where word starts with 'a'-'z' or 'A'-'Z', means ;; take the last input command that has word as a subword ;; or pattern of what was typed (after readmacros were ;; executed.), and replace that ^word with that entire input ;; command. ;; If you want a word that doesn't begin with 'a'-'z', or 'A'-'Z', ;; use ^?word where word can be any lisp atom. ;; (say 23, *, |"ab|, word). ;; ex.: 1 lisp> (plus 2 3) ;; 5 ;; 2 lisp> (* 4 5) ;; 20 ;; 3 lisp> ^us ;; (PLUS 2 3) ;; 5 ;; 4 lisp> (* 3 ^lu) ;; (PLUS 2 3) ;; 15 ;; ;; Case is ignored in word. Word is read by the command read, ;; And thus should be a normal lisp atom. Use the escape ;; character as needed. ;; ;; If the first ^ in any of the above commands is replaced with ;; ^@, then instead of (inp n) , the read macro is replaced with ;; (ans n). Words are still matched against the input, not the ;; answer. (Probably something should be added to allow matching ;; of subwords against the answer also.) ;; ;; Thus:(if typed as commands by themselves): ;; ;; ^@^ = (eval (ans (last-command))) ;; ^@3 = (eval (ans 3)) ;; ;; ^@plus = (eval (ans (last-command which has plus as a subword in ;; its input))). ;; ;; ;; Once the ^ readmacro is replaced with its history expression, you are ;; allowed to do some editing of the command. The way to do this ;; is to type a colon immediately after the ^ command as described ;; above before any space or other delimiting character. ;; ex.: ^plus:p ;; ^2:s/ab/cd/ ;; ^^:p ;; ^@^:p ;; ;; Currently there are two types of editing commands allowed. ;; ;; :p means print only, do not insert in expression, whole ;; read macro returns only nil. ;; ;; :s/word1/word2/ means take each atom in the expression found, ;; and if word1 is a subword of that atom, replace the ;; subword word1 with word2. Read is used to read word1 ;; and word2, thus the system expects an atom and will ;; ignore anything after what read sees before the /. ;; Use escape characters as necessary. ;; ;; :n where n is a positive unsigned number, means take the nth ;; element of the command(must be a list) and return it. ;; ;; ^string1^string2^ is equivalent to ^string1:s/string1/string2/ ;; ex.: ^plus^times^ is equivalent to ^plus:s/plus/times/ . ;; ;; After a :s, ^ or :<n> command you may have another :s command, ^ ;; or a :p ;; command. :p command may not be followed by any other command. ;; ;; The expression as modified by the :s commands is what is ;; returned in place of the ^ readmacro. ;; You need a closing / as seen in the :s command above. ;; After the command you should type a delimiting character if ;; you wish the next expression to begin with a :, since a : ;; will be interpreted as another editing command. ;; ;; On substitution, case is ignored when matching the subword, ;; and the replacement subword ;; is capitalized(unless you use an escape character before ;; typing a lowercase letter). ;; ;; Examples: ;; 1 lisp> (plus 23 34) ;; 57 ;; 2 lisp> ^^:s/plus/times/ ;; (TIMES 23 34) ;; 782 ;; 3 lisp> ^plus:s/3/5/ ;; (PLUS 25 54) ;; 79 ;; 4 lisp> ;; ;; (defmacro unreadch (x) `(unreadchar (id2int ,x))) (defmacro last-command () `(caadr historylist*)) (defmacro last-answer () `(cdadr historylist*)) (defun nth-command (n part) (cond ((eq part 'input) (inp n)) (t (ans n)))) (defun my-nthcdr (l n) (cond ((<= n 0) l) ((null l) nil) ((my-nthcdr (cdr l) (- n 1))))) (defvar *print-history-command-expansion t) (de skip-if (stop-char) (let ((x (readch))) (or (eq x stop-char) (unreadch x)))) (defun return-command (command) (and *print-history-command-expansion command ($prpr command) (terpri)) command) (defun do-history-command-and-return-command (string1 c) (let ((command (do-history-command string1 c))) (and *print-history-command-expansion command ($prpr command) (terpri)) command)) (defun nth-back-command (n) (do ((i n (+ 1 i)) (command-list historylist* (cdr command-list))) ((eq i 0) (caar command-list)))) (defvar *flink (*makhunk 80)) (defun kmp-flowchart-construction (p m) (rplacx 0 *flink -1) (do ((i 1 (+ 1 i))) ((> i m)) (do ((j (cxr (- i 1) *flink) (cxr j *flink))) ((or (= j -1) (= (cxr j p) (cxr (- i 1) p))) (rplacx i *flink (+ j 1)))))) (defun kmp-scan (p m s) (and s (prog (j) (setq j 0) loop (cond ((and (<> j -1) (<> (uppercassify (cxr j p)) (uppercassify (car s)))) (setq j (cxr j *flink)) (go loop))) (and (= j m) (return t)) (or (setq j (+ 1 j) s (cdr s)) (return nil)) (go loop)))) (defun match-list-beginnings (starting-list list) (do ((x starting-list (cdr x)) (y list (cdr y))) ((null x) t) (or (eq (car x) (car y)) (return nil)))) (defun uppercassify (y) (cond ((and (>= y '|a|) (<= y '|z|)) (+ y (- '|A| '|a|))) (t y))) (defun read-till-and-raise (stop-char) (let ((s (my-syntax stop-char)) (d)) (my-set-syntax stop-char 17) (setq d (read)) (skip-if stop-char) (my-set-syntax stop-char s) d)) (defun do-history-command (string1 command) (let ((b)) ;; colon after word indicates history command. ;; (cond ((eq (setq b (readch)) '|:|) ;; read key command (selectq (setq b (readch)) (p ;; only print result - dont execute ;; return nil so that a quoted version doesn't confuse the ;; history mechanism later. ( i would like to change this ;; to enter command in the history list but not execute). ($prpr command) (terpri) (rplaca (car historylist*) command) (*throw '$error$ nil)) (s ; change all subwords of string1 with string2. (do-history-command string1 (let ((delimiter (readch))) (match-and-substitute (read-till-and-raise delimiter) command (read-till-and-raise delimiter))))) ;; ;; number indicates get that element of the command out of ;; the list. ;; ((|0| |1| |2| |3| |4| |5| |6| |7| |8| |9|) (unreadch b) (let ((s (my-syntax '|:|)) (s1 (my-syntax '|^|)) (n)) (my-set-syntax '|:| 17) (my-set-syntax '|^| 17) (setq n (read)) (my-set-syntax '|:| s) (my-set-syntax '|^| s1) (cond ((null (dtpr command)) (princ "Error: not a list : ") ($prpr command) (terpri) nil) ((null (numberp n)) (princ "Error: expected number. ") (princ n) (princ " is not a number.") (terpri) nil) ((> n (length command)) (princ "Error: ") (princ n) (princ " is out of range for ") ($prpr command) (terpri) nil) (t (do-history-command string1 (nth command n)))))) (t (princ "Error: unknown command key : \|") (princ b) (princ "|") (terpri) ;; return original command command))) ((eq b '|^|) ;; equivalent to :s/string1/string2/ ;; is ^string1^string2^ (cond (string1 (match-and-substitute string1 command (read-till-and-raise '|^|))) (t (terpri) (princ "illegal option to history command.") (terpri) nil))) (t (unreadch b) ;; return original command command)))) (defun match-back-command (partial-match /&optional (part-to-return 'input)) (let ((p (list2vector (explode partial-match)))) (let ((m (upbv p))) (kmp-flowchart-construction p m) (do ((x (cdr historylist*) (cdr x))) ((null x) nil) (and (kmp-scan p m (explode (caar x))) (cond ((eq part-to-return 'input) (return (caar x))) (t (return (cdar x))))))))) (defun match-and-substitute (partial-match command replacement) (let ((p (list2vector (explode partial-match)))) (let ((m (upbv p))) (kmp-flowchart-construction p m) (let ((l (flatsize partial-match))) (match-and-substitute1 p m (explode partial-match) command (explode replacement) l))))) (defun match-and-substitute1 (p m s command replacement l) (cond ((or (atom command) (numberp command)) (kmp-scan-and-replace p m (explode command) replacement l command)) (t (cons (match-and-substitute1 p m s (car command) replacement l) (match-and-substitute1 p m s (cdr command) replacement l))))) (defun kmp-scan-and-replace (p m s replacement l command) (and s (prog (j k flag) (setq flag (stringp command)) (setq j 0) (setq k nil) loop (cond ((and (<> j -1) (<> (uppercassify (cxr j p)) (uppercassify (car s)))) (setq j (cxr j *flink)) (go loop))) (setq k (cons (car s) k)) (and (= j m) (return (cond ((stringp command) (list2string (cdr (append (append (nreverse (my-nthcdr k l)) replacement) (cdr (nreverse (cdr (nreverse s)))))))) (t (let ((x (append (append (nreverse (my-nthcdr k l)) replacement) (cdr s)))) (and (= (my-syntax (car x)) 14) (<= (my-syntax (cadr x)) 10) (setq x (cdr x))) (let ((y (implode x))) (cond ((eq (flatsize y) (length x)) y) (t (intern (list2string x)))))))))) (or (setq j (+ 1 j) s (cdr s)) (return command)) (go loop)))) (defun read-sub-word () (let ((c (my-syntax '|:|)) (d)) ;; dont read : since it is the special command character. (my-set-syntax '|:| 17) (setq d (read)) (my-set-syntax '|:| c) d)) (defun re-execute-command (/&optional (part 'input)) (let ((y (readch))) (cond ((eq y '\^) (do-history-command-and-return-command nil (last-command))) ((eq y '\*) (do-history-command-and-return-command nil (last-answer))) ((eq y '\@) (re-execute-command 'answer)) ((eq y '\?) (let ((yy (read-sub-word))) (do-history-command-and-return-command yy (match-back-command yy part)))) ((or (digit y) (memq y '(|+| |-|))) (unreadch y) (let ((y (read-sub-word))) (cond ((numberp y) (cond ((> y 0) (do-history-command-and-return-command nil (nth-command y part))) ((< y 0) (do-history-command-and-return-command nil (nth-back-command y)))))))) ((liter y) (unreadch y) (let ((yy (read-sub-word))) (do-history-command-and-return-command yy (match-back-command yy)))) ))) (my-set-readmacro '\^ (function re-execute-command)) |
Added psl-1983/util/if-system.build version [811abf5c2c].
> | 1 | in "if-system.red"$ |
Added psl-1983/util/if-system.red version [2715c12271].
> > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | % % IF-SYSTEM.RED - Conditional compilation for system-dependent code % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 10 March 1982 % Copyright (c) 1982 University of Utah % fluid '(system_list!*); macro procedure if_system U; do_if_system(cadr U, caddr U, if cdddr U then cadddr U else NIL); expr procedure do_if_system(system_name, true_case, false_case); if system_name memq system_list!* then true_case else false_case; END; |
Added psl-1983/util/if.sl version [21a0e15e4d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % IF macro % Cris Perdue 8/19/82 (setq *usermode nil) % Syntax of new IF is: % (if <expr> [then <expr> ... ] [<elseif-part> ... ] [else <expr> ... ]) % <elseif-part> = elseif <expr> [then <expr> ... ] % This syntax allows construction of arbitrary CONDs. (defun construct-new-if (form) (let ( (clause) (next-clause) (stmt (list 'cond)) (e form)) (while e (cond ((or (sym= (first e) 'if) (sym= (first e) 'elseif)) (cond ((or (null (rest e)) (not (or (null (rest (rest e))) (sym= (third e) 'then) (sym= (third e) 'else) (sym= (third e) 'elseif)))) (error 0 "Can't expand IF."))) (setq next-clause (next-if-clause e)) (setq clause (cond ((and (rest (rest e)) (sym= (third e) 'then)) (cons (second e) (ldiff (pnth e 4) next-clause))) (t (list (second e))))) (nconc stmt (list clause)) (setq e next-clause) (next)) ((sym= (first e) 'else) (cond ((or (null (rest e)) (next-if-clause e)) (error 0 "Can't expand IF."))) (nconc stmt (list (cons t (rest e)))) (exit)))) stmt)) (defun next-if-clause (tail) (for (on x (rest tail)) (do (cond ((or (sym= (first x) 'else) (sym= (first x) 'elseif)) (return x)))) (returns nil))) (defun sym= (a b) (eq a b)) (defun ldiff (x y) (cond ((null x) nil) ((eq x y) nil) (t (cons (first x) (ldiff (rest x) y))))) % Checks for (IF <expr> <KEYWORD> . . . ) form. If keyword form, % does fancy expansion, otherwise expands compatibly with MacLISP % IF expression. <KEYWORD> ::= THEN | ELSE | ELSEIF (dm if (form) (let ((b (rest (rest form))) (test (second form))) (cond ((or (sym= (first b) 'then) (sym= (first b) 'else) (sym= (first b) 'elseif)) (construct-new-if form)) ((eq (length b) 1) `(cond (,test ,(nth b 1)))) (t `(cond (,test ,(nth b 1)) (t ,@(pnth b 2))))))) |
Added psl-1983/util/init-file.build version [5422138ff3].
> > | 1 2 | CompileTime load If!-System; in "init-file.sl"$ |
Added psl-1983/util/init-file.sl version [7397a215bc].
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | % % READ-INIT-FILE.SL - Function which reads an init file % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 21 September 1982 % Copyright (c) 1982 University of Utah % (if_system Tops20 (imports '(homedir))) (de read-init-file (program-name) ((lambda (f) (cond ((filep f) (lapin f)))) (init-file-string program-name))) |
Added psl-1983/util/inspect.build version [690245ece4].
> > | 1 2 | Compiletime Load Gsort; % Need a macro In "inspect.red"$ |
Added psl-1983/util/inspect.red version [c565938fe4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % INSPECT.RED - Scan files for defined functions % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 31 May 1982 % Copyright (c) 1982 University of Utah % % adapted from CREF and BUILD Imports '(Gsort Dir!-Stuff); FLUID '(!*UserMode % To control USER Redef message !*ECHO !*RedefMsg % To suppress REDEF messages CurrentFile!* % To keep tack of this file FileList!* % Files seen so far ProcedureList!* % procedures seen so far ProcFileList!* % (PROC . FILE) so far !*PrintInspect % Print each proc !*QuietInspect % Suppress INSPECTOUT messages ); !*PrintInspect:=T; !*QuietInspect:=NIL; Procedure Inspect X; begin scalar !*UserMode,!*Redefmsg,!*QuietInspect; !*QuietInspect:=T; INSPECTOut(); !*ECHO:=NIL; If Not FunboundP 'Begin1 then EvIn list X else EVAL LIST('Dskin, x); INSPECTEnd(); end; Procedure InspectOut; % Scan Files for Definitions Begin !*DEFN:=T; !*ECHO:=NIL; SEMIC!*:= '!$ ; DFPRINT!* := 'InspectPrint; ProcedureList!*:=FileList!* :=ProcFileList!*:=NIL; CurrentFile!* := NIL; if not !*QuietInspect then << if not FUnBoundP 'Begin1 then << Prin2T "INSPECTOUT: IN files; or type in expressions"; Prin2T "When all done execute INSPECTEND;" >> else << Prin2T "INSPECTOUT: (DSKIN files) or type in expressions"; Prin2T "When all done execute (INSPECTEND)" >> >>; End; Procedure InspectEnd; Begin If !*PrintInspect then PrintF "%n%% --- Done with INSPECTION ---%n"; Dfprint!*:=NIL; !*Defn:=NIL; ProcedureList!* := IdSort ProcedureList!*; If !*PrintInspect then <<Prin2T "% --- PROCS: --- "; Print ProcedureList!*>>; End; Procedure InspectPrint U; BEGIN scalar x; !*ECHO:=NIL; SEMIC!*:='!$; x:=IF PairP CLOC!* THEN CAR CLOC!* ELSE "*TTYInput*"; If x NEQ CurrentFile!* and !*PrintInspect then PrintF("%n%% --- Inspecting File : %r --- %n",x); CurrentFile!* := x; % Find current FILE name, see if new IF Not MEMBER(CurrentFile!*,FileList!*) THEN FileList!*:=CurrentFile!* . FileList!*; InspectForm U; END; FLAG('(INSPECTEND),'IGNORE); PUT('InspectEnd,'RlispPrefix,'(NIL LAMBDA(X) (ESTAT 'Inspectend))); procedure InspectForm U; %. Called by TOP-loop, DFPRINT!* begin scalar Nam, Ty, Fn; if not PairP U then return NIL; Fn := car U; IF FN = 'PUTD THEN GOTO DB2; IF NOT (FN MEMQ '(DE DF DM DN)) THEN GOTO DB1; NAM:=CADR U; U:='LAMBDA . CDDR U; TY:=CDR ASSOC(FN, '((DE . EXPR) (DF . FEXPR) (DM . MACRO) (DN . NEXPR))); DB3: if Ty = 'MACRO then begin scalar !*Comp; PutD(Nam, Ty, U); % Macros get defined now end; if FlagP(Nam, 'Lose) then << ErrorPrintF("*** %r has not been defined, because it is flagged LOSE", Nam); return NIL >>; InspectProc(Nam,Ty); RETURN NIL; DB1: % Simple S-EXPRESSION look for LAP etc. IF EQCAR(U,'LAP) Then Return InspectLap U; IF EQCAR(U,'Imports) then Return PrintF("%% --- Imports: %w in %w%n",Cadr U, CurrentFile!*); % Maybe indicate IMPORTS etc. RETURN NIL; DB2: % analyse PUTD NAM:=CADR U; TY:=CADDR U; FN:=CADDDR U; IF EQCAR(NAM,'QUOTE) THEN << NAM:=CADR NAM; IF EQCAR(TY,'QUOTE) THEN << TY:=CADR TY; IF PAIRP FN AND CAR FN MEMBER '(FUNCTION QUOTE) THEN << FN:=CADR FN; IF TY MEMQ '(EXPR FEXPR MACRO NEXPR) THEN << U:=FN; GOTO DB3 >> >> >> >>; GOTO DB1; END; Procedure InspectProc(Nam,Ty); <<If !*PrintInspect then <<Prin1 NAM; Prin2 " ">>; ProcedureList!*:=NAM . ProcedureList!*; ProcFileList!*:=(NAM . CurrentFile!*) . ProcFileList!*>>; Procedure InspectLap U; For each x in U do if EQcar(x,'!*ENTRY) then InspectProc(Cadr U,Caddr U); % -- Handle LISTs of files and dirs --- Fluid '(!*PrintInspect !*QuietInspect); Nexpr procedure GetFileList L; GetFiles1 L; Procedure GetFiles1 L; If null L then Nil else append(Vector2List GetCleandir Car L, GetFiles1 Cdr L); procedure InspectToFile F; Begin scalar f1,c; f1:=Bldmsg("%s-%s.ins",GetFileName(f),GetExtension(f)); Printf(" Inspecting %r to %r%n",F,F1); c:=open(f1,'output); WRS c; !*PrintInspect:=NIL; Inspect F$ Prin2 "(ProcList '"$ Print ProcedureList!*; Prin2T ")"; WRS NIL; close c; End; procedure InspectAllFiles Files; For each x in files do <<PrintF("Doing file: %w%n",x); InspectToFile x>>; Procedure InspectAllPU(); InspectAllFiles getFileList("pu:*.red","PU:*.sl"); END; |
Added psl-1983/util/inum.build version [6105c2df6b].
> > | 1 2 | CompileTime load Syslisp; in "inum.red"$ |
Added psl-1983/util/inum.red version [ef4b74fbb6].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % INUM.RED - Interpreter entries for open-compiled integer arithmetic % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 18 March 1982 % Copyright (c) 1982 University of Utah % off R2I; CompileTime << smacro procedure InumTwoArg IName; lisp procedure IName(Arg1, Arg2); begin scalar Result; return if IntP Arg1 and IntP Arg2 and IntP(Result := IName(Arg1, Arg2)) then Result else Inum2Error(Arg1, Arg2, quote IName); end; smacro procedure InumTwoArgBool IName; lisp procedure IName(Arg1, Arg2); if IntP Arg1 and IntP Arg2 then IName(Arg1, Arg2) else Inum2Error(Arg1, Arg2, quote IName); smacro procedure InumOneArg IName; lisp procedure IName Arg; begin scalar Result; return if IntP Arg and IntP(Result := IName Arg) then Result else Inum1Error(Arg, quote IName); end; smacro procedure InumOneArgBool IName; lisp procedure IName Arg; if IntP Arg then IName Arg else Inum1Error(Arg, quote IName); >>; lisp procedure Inum2Error(Arg1, Arg2, Name); ContinuableError(99, "Inum out of range", list(Name, Arg1, Arg2)); lisp procedure Inum1Error(Arg, Name); ContinuableError(99, "Inum out of range", list(Name, Arg)); InumTwoArg IPlus2; InumTwoArg IDifference; InumTwoArg ITimes2; InumTwoArg IQuotient; InumTwoArg IRemainder; InumTwoArgBool ILessP; InumTwoArgBool IGreaterP; InumTwoArgBool ILEQ; InumTwoArgBool IGEQ; InumTwoArg ILOR; InumTwoArg ILAND; InumTwoArg ILXOR; InumTwoArg ILSH; InumOneArg IAdd1; InumOneArg ISub1; InumOneArg IMinus; InumOneArgBool IZeroP; InumOneArgBool IOneP; InumOneArgBool IMinusP; on R2I; macro procedure IFor U; MkSysFor U; if not FUnBoundP 'Begin1 then << DEFINEROP('IFOR,NIL,ParseIFOR); SYMBOLIC PROCEDURE ParseIFOR X; BEGIN SCALAR INIT,STP,UNTL,ACTION,ACTEXPR; IF (OP := SCAN()) EQ 'SETQ THEN INIT := PARSE0(6,T) ELSE PARERR("FOR missing loop VAR assignment",T); IF OP EQ '!*COLON!* THEN <<STP := 1; OP := 'UNTIL>> ELSE IF OP EQ 'STEP THEN STP := PARSE0(6,T) ELSE PARERR("FOR missing : or STEP clause",T); IF OP EQ 'UNTIL THEN UNTL := PARSE0(6,T) ELSE PARERR("FOR missing UNTIL clause",T); ACTION := OP; IF ACTION MEMQ '(DO SUM PRODUCT) THEN ACTEXPR := PARSE0(6,T) ELSE PARERR("FOR missing action keyword",T); RETURN LIST('IFOR, LIST('FROM,X,INIT,UNTL,STP), LIST(ACTION,ACTEXPR)) END; >>; END; |
Added psl-1983/util/iter-macros.sl version [e477afa829].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % ITER-MACROS.SL - macros for generalized iteration % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>ITER-MACROS.SL.9, 15-Sep-82 17:06:49, Edit by BENSON % Fixed typo, ((null (cdr result) nil)) ==> ((null (cdr result)) nil) (defmacro do (iterators result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (setq steps (cons (if (atom (car U)) (car U) (caar U)) (cons (caddr U) steps))) (list (car U) (cadr U))) U))) (let ((form `(prog () ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body (psetq ,.steps) (go ***DO-LABEL***)))) (if vars `(let ,vars ,form) form)))) (defmacro do* (iterators result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (push `(setq ,(if (atom (car U)) (car U) (caar U)) ,(caddr U)) steps) (list (car U) (cadr U))) U))) (let ((form `(prog () ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body ,.(reversip steps) (go ***DO-LABEL***)))) (if vars `(let* ,vars ,form) form)))) (defmacro do-loop (iterators prologue result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (setq steps (cons (if (atom (car U)) (car U) (caar U)) (cons (caddr U) steps))) (list (car U) (cadr U))) U))) (let ((form `(prog () ,@prologue ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body (psetq ,.steps) (go ***DO-LABEL***)))) (if vars `(let ,vars ,form) form)))) (defmacro do-loop* (iterators prologue result . body) (let (vars steps) (setq vars (foreach U in iterators collect (if (and (pairp U) (cdr U) (cddr U)) (progn (push `(setq ,(if (atom (car U)) (car U) (caar U)) ,(caddr U)) steps) (list (car U) (cadr U))) U))) (let ((form `(prog () ,@prologue ***DO-LABEL*** (cond (,(car result) (return ,(cond ((null (cdr result)) nil) ((and (pairp (cdr result)) (null (cddr result))) (cadr result)) (t `(progn ,@(cdr result))))))) ,@body ,.(reversip steps) (go ***DO-LABEL***)))) (if vars `(let* ,vars ,form) form)))) |
Added psl-1983/util/kernel.build version [9817537c18].
> | 1 | in "kernel.sl"$ |
Added psl-1983/util/kernel.sl version [76849483bc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % KERNEL.SL - Generate scripts for building PSL kernel % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 May 1982 % Copyright (c) 1982 University of Utah % % <PSL.UTIL>KERNEL.SL.2, 20-Dec-82 11:21:03, Edit by BENSON % Added kernel-header and kernel-trailer % <PSL.UTIL>KERNEL.SL.9, 7-Jun-82 12:22:48, Edit by BENSON % Changed kernel-file to all-kernel-script-name* and all-kernel-script-format* % <PSL.UTIL>KERNEL.SL.8, 6-Jun-82 05:23:40, Edit by GRISS % Added kernel-file (compiletime (load useful)) (compiletime (flag '(build-link-script build-kernel-file build-init-file build-file-aux insert-file-names insert-file-names-aux) 'InternalFunction)) (fluid '(kernel-name-list* command-file-name* command-file-format* init-file-name* init-file-format* all-kernel-script-name* all-kernel-script-header* all-kernel-script-format* all-kernel-script-trailer* code-object-file-name* data-object-file-name* link-script-name* link-script-format* script-file-name-separator*)) (de kernel (kernel-name-list*) (let ((*lower t)) % For the benefit of Unix (build-command-files kernel-name-list*) % MAIN is not included in all-kernel-script (build-kernel-file (delete 'main kernel-name-list*)) (build-link-script) (build-init-file))) (de build-command-files (k-list) (unless (null k-list) (let ((name-stem (first k-list))) (let ((f (wrs (open (bldmsg command-file-name* name-stem) 'output)))) (printf command-file-format* name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem name-stem) (close (wrs f)))) (build-command-files (rest k-list)))) (de build-link-script () (let ((f (wrs (open link-script-name* 'output)))) (linelength 1000) (printf link-script-format* '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names) '(insert-link-file-names)) (close (wrs f)))) (de build-kernel-file (n-list) (let ((f (wrs (open all-kernel-script-name* 'output)))) (linelength 1000) (unless (null all-kernel-script-header*) (prin2 all-kernel-script-header*)) (build-file-aux n-list all-kernel-script-format*) (unless (null all-kernel-script-trailer*) (prin2 all-kernel-script-trailer*)) (close (wrs f)))) (de insert-link-file-names () (insert-file-names kernel-name-list* code-object-file-name*) (prin2 script-file-name-separator*) (insert-file-names kernel-name-list* data-object-file-name*)) (de insert-file-names (n-list format) (printf format (first n-list)) (insert-file-names-aux (rest n-list) format)) (de insert-file-names-aux (n-list format) (unless (null n-list) (prin2 script-file-name-separator*) (printf format (first n-list)) (insert-file-names-aux (rest n-list) format))) (de build-init-file () (let ((f (wrs (open init-file-name* 'output)))) (build-file-aux kernel-name-list* init-file-format*) (close (wrs f)))) (de build-file-aux (n-list format) (unless (null n-list) (printf format (first n-list)) (build-file-aux (rest n-list) format))) |
Added psl-1983/util/loop.build version [f0e11f1f37].
> > > | 1 2 3 | CompileTime load Clcomp; off Usermode; in "loop.lsp"$ |
Added psl-1983/util/loop.lsp version [81c163669c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;(setq |SCCS-loop| "@(#)loop.l 1.2 7/9/81") ;-*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*- ;The master copy of this file is on ML:LSB1;LOOP > ;The current Lisp machine copy is on AI:LISPM2;LOOP > ;The FASL and QFASL should also be accessible from LIBLSP; on all machines. ; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP ; at any ITS site. ;; the file was franzified by JKF. ; ;; PSLified by Eric Benson, October 1982 ;;;; LOOP Iteration Macro ; Hack up the stuff for data-types. DATA-TYPE? will always be a macro ; so that it will not require the data-type package at run time if ; all uses of the other routines are conditionalized upon that value. (defmacro data-type? (x) `(get ,x ':data-type)) ;(declare ; (*lexpr variable-declarations) ; (*expr initial-value form-wrapper)) (eval-when (eval compile) (macro status (x) (errorprintf "***** %p" x) ()) (copyd 'sstatus 'status) (copyd 'variable-declarations 'status) (defmacro c-mapc (x y) `(mapc ,y ,x)) (defmacro c-mapcar (x y) `(mapcar ,y ,x)) (defmacro loop-error (x y) `(stderror (list ,x ,y))) ) ;Loop macro ;(eval-when (eval compile) ; (defun lexpr-funcall macro (x) ; `(apply ,(cadr x) (list* . ,(cddr x))))) (defun loop-displace (x y) ((lambda (val) (rplaca x (car val)) (rplacd x (cdr val)) x) (cond ((atom y) (list 'progn y)) (t y)))) (defmacro loop-finish () '(go end-loop)) (macro neq (x) `(not (eq . ,(cdr x)))) (defun loop-make-psetq (frobs) (loop-make-setq (car frobs) (cond ((null (cddr frobs)) (cadr frobs)) (t `(prog1 ,(cadr frobs) ,(loop-make-psetq (cddr frobs))))))) (defmacro loop-psetq frobs (loop-make-psetq frobs)) (defvar loop-keyword-alist ;clause introducers '( (initially loop-do-initially) (finally loop-do-finally) (do loop-do-do) (doing loop-do-do) (return loop-do-return) (collect loop-do-collect list) (collecting loop-do-collect list) (append loop-do-collect append) (appending loop-do-collect append) (nconc loop-do-collect nconc) (nconcing loop-do-collect nconc) (count loop-do-collect count) (counting loop-do-collect count) (sum loop-do-collect sum) (summing loop-do-collect sum) (maximize loop-do-collect max) (minimize loop-do-collect min) (always loop-do-always t) (never loop-do-always nil) (thereis loop-do-thereis) (while loop-do-while or) (until loop-do-while and) (when loop-do-when nil) (unless loop-do-when t) (with loop-do-with) (for loop-do-for) (as loop-do-for))) (defvar loop-for-keyword-alist ;Types of FOR '( (= loop-for-equals) (in loop-for-in) (on loop-for-on) (from loop-for-arithmetic nil) (downfrom loop-for-arithmetic down) (upfrom loop-for-arithmetic up) (being loop-for-being))) (defvar loop-path-keyword-alist nil) ; PATH functions (defvar loop-variables) ;Variables local to the loop (defvar loop-declarations) ; Local dcls for above (defvar loop-variable-stack) (defvar loop-declaration-stack) (defvar loop-prologue) ;List of forms in reverse order (defvar loop-body) ;.. (defvar loop-after-body) ;.. for FOR steppers (defvar loop-epilogue) ;.. (defvar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY (defvar loop-conditionals) ;If non-NIL, condition for next form in body ;The above is actually a list of entries of the form ;(condition forms...) ;When it is output, each successive condition will get ;nested inside the previous one, but it is not built up ;that way because you wouldn't be able to tell a WHEN-generated ;COND from a user-generated COND. (defvar loop-when-it-variable) ;See LOOP-DO-WHEN (defvar loop-collect-cruft) ; for multiple COLLECTs (etc) (defvar loop-source-code) (defvar loop-attachment-transformer ; see attachment definition (cond ((status feature lms) 'progn) (t nil))) (macro loop-lookup-keyword (x) `(assq . ,(cdr x))) (defun loop-add-keyword (cruft alist-name) (let ((val (symeval alist-name)) (known?)) (and (setq known? (loop-lookup-keyword (car cruft) val)) (set alist-name (delqip known? val))) (set alist-name (cons cruft val)))) (defmacro define-loop-macro (keyword) (or (eq keyword 'loop) (loop-lookup-keyword keyword loop-keyword-alist) (loop-error "lisp: Not a loop keyword -- " keyword)) `(eval-when (compile load eval) (putd ',keyword 'macro #'(lambda (macroarg) (loop-translate macroarg))))) (define-loop-macro loop) (defun loop-translate (x) (loop-displace x (loop-translate-1 x))) (defun loop-translate-1 (loop-source-code) (and (eq (car loop-source-code) 'loop) (setq loop-source-code (cdr loop-source-code))) (do ((loop-variables nil) (loop-declarations nil) (loop-variable-stack nil) (loop-declaration-stack nil) (loop-prologue nil) (loop-body nil) (loop-after-body nil) (loop-epilogue nil) (loop-after-epilogue nil) (loop-conditionals nil) (loop-when-it-variable nil) (loop-collect-cruft nil) (keyword) (tem)) ((null loop-source-code) (and loop-conditionals (loop-error "lisp: hanging conditional in loop macro -- " (caar loop-conditionals))) (cond (loop-variables (push loop-variables loop-variable-stack) (push loop-declarations loop-declaration-stack))) (setq tem `(prog () ,@(nreverse loop-prologue) next-loop ,@(nreverse loop-body) ,@(nreverse loop-after-body) (go next-loop) end-loop ,@(nreverse loop-epilogue) ,@(nreverse loop-after-epilogue))) (do ((vars) (dcls)) ((null loop-variable-stack)) (setq vars (pop loop-variable-stack) dcls (pop loop-declaration-stack)) (and dcls (setq dcls `((declare . ,(nreverse dcls))))) (setq tem `(,@dcls ,tem)) (cond ((do ((l vars (cdr l))) ((null l) nil) (and (not (atom (car l))) (not (atom (caar l))) (return t))) (setq tem `(let ,(nreverse vars) ,.tem))) (t (let ((lambda-vars nil) (lambda-vals nil)) (do ((l vars (cdr l)) (v)) ((null l)) (cond ((atom (setq v (car l))) (push v lambda-vars) (push nil lambda-vals)) (t (push (car v) lambda-vars) (push (cadr v) lambda-vals)))) (setq tem `((lambda ,(nreverse lambda-vars) ,.tem) ,.(nreverse lambda-vals)))))) ) tem) (if (symbolp (setq keyword (pop loop-source-code))) (if (setq tem (loop-lookup-keyword keyword loop-keyword-alist)) (apply (cadr tem) (cddr tem)) (loop-error "lisp: unknown keyword in loop macro -- " keyword)) (loop-error "lisp: loop found object where keyword expected -- " keyword)))) (defun loop-bind-block () (cond ((not (null loop-variables)) (push loop-variables loop-variable-stack) (push loop-declarations loop-declaration-stack) (setq loop-variables nil loop-declarations nil)) (loop-declarations (break)))) ;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary. (defun loop-get-form () (do ((forms (list (pop loop-source-code)) (cons (pop loop-source-code) forms)) (nextform (car loop-source-code) (car loop-source-code))) ((atom nextform) (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) (defun loop-make-setq (var-or-pattern value) (list (if (atom var-or-pattern) 'setq 'desetq) var-or-pattern value)) (defun loop-imply-type (expression type) (let ((frob (and (data-type? type) (form-wrapper type expression)))) (cond ((not (null frob)) frob) (t expression)))) (defun loop-make-variable (name initialization dtype) (cond ((null name) (and initialization (push (list nil initialization) loop-variables))) ((atom name) (cond ((data-type? dtype) (setq loop-declarations (append (variable-declarations dtype name) loop-declarations)) (or initialization (setq initialization (initial-value dtype)))) ((memq dtype '(fixnum flonum number)) (or initialization (setq initialization (if (eq dtype 'flonum) 0.0 0))))) (push (if initialization (list name initialization) name) loop-variables)) (initialization (push (list name initialization) loop-variables) (loop-declare-variable name dtype)) (t (let ((tcar) (tcdr)) (cond ((atom dtype) (setq tcar (setq tcdr dtype))) (t (setq tcar (car dtype) tcdr (cdr dtype)))) (loop-make-variable (car name) nil tcar) (loop-make-variable (cdr name) nil tcdr)))) name) (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype)) nil) ((atom name) (cond ((data-type? dtype) (setq loop-declarations (append (variable-declarations dtype name) loop-declarations))) )) ((atom dtype) (loop-declare-variable (car name) dtype) (loop-declare-variable (cdr name) dtype)) (t (loop-declare-variable (car name) (car dtype)) (loop-declare-variable (cdr name) (cdr dtype))))) (defun loop-maybe-bind-form (form data-type?) (cond ((or (numberp form) (memq form '(t nil)) (and (not (atom form)) (eq (car form) 'quote))) form) (t (loop-make-variable (gensym) form data-type?)))) (defun loop-optional-type () (let ((token (car loop-source-code))) (and (not (null token)) (or (not (atom token)) (data-type? token) (memq token '(fixnum flonum number))) (pop loop-source-code)))) ;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE, ;the second a string (lispm) or symbol (maclisp) to check against. (defmacro loop-tequal (x1 x2) `(eq ,x1 ,x2)) ;Incorporates conditional if necessary (defun loop-emit-body (form) (cond (loop-conditionals (rplacd (last (car (last loop-conditionals))) (cond ((and (not (atom form)) ;Make into list of forms (eq (car form) 'progn)) (append (cdr form) nil)) (t (list form)))) (cond ((loop-tequal (car loop-source-code) "and") (pop loop-source-code)) (t ;Nest up the conditionals and output them (do ((prev (car loop-conditionals) (car l)) (l (cdr loop-conditionals) (cdr l))) ((null l)) (rplacd (last prev) `((cond ,(car l))))) (push `(cond ,(car loop-conditionals)) loop-body) (setq loop-conditionals nil)))) (t (push form loop-body)))) (defun loop-do-initially () (push (loop-get-form) loop-prologue)) (defun loop-do-finally () (push (loop-get-form) loop-epilogue)) (defun loop-do-do () (loop-emit-body (loop-get-form))) (defun loop-do-return () (loop-emit-body `(return ,(loop-get-form)))) (defun loop-do-collect (type) (let ((var) (form) (tem) (tail) (dtype) (cruft) (rvar) (ctype (cond ((memq type '(max min)) 'maxmin) ((memq type '(nconc list append)) 'list) ((memq type '(count sum)) 'sum) (t (loop-error "lisp: unrecognized loop collecting keyword -- " type))))) (setq form (loop-get-form) dtype (loop-optional-type)) (cond ((loop-tequal (car loop-source-code) 'into) (pop loop-source-code) (setq rvar (setq var (pop loop-source-code))))) ; CRUFT will be (varname ctype dtype var tail (optional tem)) (cond ((setq cruft (assq var loop-collect-cruft)) (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) (loop-error "lisp: incompatible loop collections -- " (list ctype (car cruft)))) ((and dtype (not (eq dtype (cadr cruft)))) (loop-error "lisp: loop found unequal types in collector -- " (list type (list dtype (cadr cruft)))))) (setq dtype (car (setq cruft (cdr cruft))) var (car (setq cruft (cdr cruft))) tail (car (setq cruft (cdr cruft))) tem (cadr cruft)) (and (eq ctype 'maxmin) (not (atom form)) (null tem) (rplaca (cdr cruft) (setq tem (loop-make-variable (gensym) nil dtype))))) (t (and (null dtype) (setq dtype (cond ((eq type 'count) 'fixnum) ((memq type '(min max sum)) 'number)))) (or var (push `(return ,(setq var (gensym))) loop-after-epilogue)) (loop-make-variable var nil dtype) (setq tail (cond ((eq ctype 'list) (setq tem (loop-make-variable (gensym) nil nil)) (loop-make-variable (gensym) nil nil)) ((eq ctype 'maxmin) (or (atom form) (setq tem (loop-make-variable (gensym) nil dtype))) (loop-make-variable (gensym) nil nil)))) (push (list rvar ctype dtype var tail tem) loop-collect-cruft))) (loop-emit-body (selectq type (count (setq tem `(setq ,var (1+ ,var))) (cond ((eq form t) tem) (t `(and ,form ,tem)))) (sum `(setq ,var (plus ,(loop-imply-type form dtype) ,var))) ((max min) `(setq ,@(and tem (prog1 `(,tem ,form) (setq form tem))) ,var (cond (,tail (,type ,(loop-imply-type form dtype) ,var)) (t (setq ,tail t) ,form)))) (list `(setq ,tem (ncons ,form) ,tail (cond (,tail (cdr (rplacd ,tail ,tem))) ((setq ,var ,tem)))) ) (nconc `(setq ,tem ,form ,tail (last (cond (,tail (rplacd ,tail ,tem)) ((setq ,var ,tem)))))) (append `(setq ,tem (append ,form nil) ,tail (last (cond (,tail (rplacd ,tail ,tem)) ((setq ,var ,tem)))))))))) (defun loop-do-while (cond) (loop-emit-body `(,cond ,(loop-get-form) (go end-loop)))) (defun loop-do-when (negate?) (let ((form (loop-get-form)) (cond)) (cond ((loop-tequal (cadr loop-source-code) 'it) ;WHEN foo RETURN IT and the like (or loop-when-it-variable (setq loop-when-it-variable (loop-make-variable (gensym) nil nil))) (setq cond `(setq ,loop-when-it-variable ,form)) (setq loop-source-code ;Plug in variable for IT (list* (car loop-source-code) loop-when-it-variable (cddr loop-source-code)))) (t (setq cond form))) (and negate? (setq cond `(not ,cond))) (setq loop-conditionals (nconc loop-conditionals (ncons (list cond)))))) (defun loop-do-with () (do ((var) (equals) (val) (dtype)) (nil) (setq var (pop loop-source-code) equals (car loop-source-code)) (cond ((loop-tequal equals '=) (pop loop-source-code) (setq val (pop loop-source-code) dtype nil)) ((or (loop-tequal equals 'and) (loop-lookup-keyword equals loop-keyword-alist)) (setq val nil dtype nil)) (t (setq dtype (pop loop-source-code) equals (car loop-source-code)) (cond ((loop-tequal equals '=) (pop loop-source-code) (setq val (pop loop-source-code))) ((and (not (null loop-source-code)) (not (loop-lookup-keyword equals loop-keyword-alist)) (not (loop-tequal equals 'and))) (loop-error "lisp: loop was expecting = but found " equals)) (t (setq val nil))))) (loop-make-variable var val dtype) (cond ((not (loop-tequal (car loop-source-code) 'and)) (return nil)) ((pop loop-source-code)))) (loop-bind-block)) (defun loop-do-always (true) (let ((form (loop-get-form))) (or true (setq form `(not ,form))) (loop-emit-body `(or ,form (return nil))) (push '(return t) loop-after-epilogue))) ;THEREIS expression ;If expression evaluates non-nil, return that value. (defun loop-do-thereis () (let ((var (loop-make-variable (gensym) nil nil)) (expr (loop-get-form))) (loop-emit-body `(and (setq ,var ,expr) (return ,var))))) ;FOR variable keyword ..args.. {AND more-clauses} ;For now AND only allowed with the = keyword (defun loop-do-for () (and loop-conditionals (loop-error "lisp: loop for or as starting inside of conditional")) (do ((var) (data-type?) (keyword) (first-arg) (tem) (pretests) (posttests) (inits) (steps)) (nil) (setq var (pop loop-source-code) data-type? (loop-optional-type) keyword (pop loop-source-code) first-arg (pop loop-source-code)) (and (or (not (symbolp keyword)) (null (setq tem (loop-lookup-keyword keyword loop-for-keyword-alist)))) (loop-error "lisp: unknown keyword in for or as loop clause -- " keyword)) (setq tem (lexpr-funcall (cadr tem) var first-arg data-type? (cddr tem))) (and (car tem) (push (car tem) pretests)) (setq inits (nconc inits (append (car (setq tem (cdr tem))) nil))) (and (car (setq tem (cdr tem))) (push (car tem) posttests)) (setq steps (nconc steps (append (car (setq tem (cdr tem))) nil))) (cond ((not (loop-tequal (car loop-source-code) 'and)) (cond ((cdr (setq pretests (nreverse pretests))) (push 'or pretests)) (t (setq pretests (car pretests)))) (cond ((cdr (setq posttests (nreverse posttests))) (push 'or posttests)) (t (setq posttests (car posttests)))) (and pretests (push `(and ,pretests (go end-loop)) loop-body)) (and inits (push (loop-make-psetq inits) loop-body)) (and posttests (push `(and ,posttests (go end-loop)) loop-after-body)) (and steps (push (loop-make-psetq steps) loop-after-body)) (loop-bind-block) (return nil)) (t (pop loop-source-code))))) (defun loop-for-equals (var val data-type?) (cond ((loop-tequal (car loop-source-code) 'then) ;FOR var = first THEN next (pop loop-source-code) (loop-make-variable var val data-type?) (list nil nil nil `(,var ,(loop-get-form)))) (t (loop-make-variable var nil data-type?) (list nil `(,var ,val) nil nil)))) (defun loop-for-on (var val data-type?) (let ((step (if (loop-tequal (car loop-source-code) 'by) (progn (pop loop-source-code) (pop loop-source-code)) '(function cdr))) (var1 (cond ((not (atom var)) ; Destructuring? Then we can't use VAR as the ; iteration variable. (loop-make-variable var nil nil) (loop-make-variable (gensym) val nil)) (t (loop-make-variable var val nil) var)))) (setq step (cond ((or (atom step) (not (memq (car step) '(quote function)))) `(funcall ,(loop-make-variable (gensym) step nil) ,var1)) (t (list (cadr step) var1)))) (list `(null ,var1) (and (not (eq var var1)) `(,var ,var1)) nil `(,var1 ,step)))) (defun loop-for-in (var val data-type?) (let ((var1 (gensym)) ;VAR1 is list, VAR is element (step (if (loop-tequal (car loop-source-code) 'by) (progn (pop loop-source-code) (pop loop-source-code)) '(function cdr)))) (loop-make-variable var1 val nil) (loop-make-variable var nil data-type?) (setq step (cond ((or (atom step) (not (memq (car step) '(quote function)))) `(funcall (loop-make-variable (gensym) step nil) var1)) (t (list (cadr step) var1)))) (list `(null ,var1) `(,var (car ,var1)) nil `(,var1 ,step)))) (defun loop-for-arithmetic (var val data-type? forced-direction) (let ((limit) (step 1) (test) (direction) (eval-to-first t) (inclusive)) (do () (nil) (cond ((not (symbolp (car loop-source-code))) (return nil)) ((loop-tequal (car loop-source-code) 'by) (pop loop-source-code) (setq step (loop-get-form) eval-to-first t)) ((loop-tequal (car loop-source-code) 'to) (pop loop-source-code) (setq limit (loop-get-form) inclusive t eval-to-first nil)) ((loop-tequal (car loop-source-code) 'downto) (pop loop-source-code) (setq limit (loop-get-form) inclusive t eval-to-first nil direction 'down)) ((loop-tequal (car loop-source-code) 'below) (pop loop-source-code) (setq limit (loop-get-form) direction 'up eval-to-first nil)) ((loop-tequal (car loop-source-code) 'above) (pop loop-source-code) (setq limit (loop-get-form) direction 'down eval-to-first nil)) (t (return nil)))) (cond ((null direction) (setq direction (or forced-direction 'up))) ((and forced-direction (not (eq forced-direction direction))) (loop-error "lisp: loop variable stepping lossage with " var))) (or data-type? (setq data-type? 'fixnum)) (and (eq data-type? 'flonum) (fixp step) (setq step (float step))) (loop-make-variable var val data-type?) (cond ((and limit eval-to-first) (setq limit (loop-maybe-bind-form limit data-type?)))) (setq step (loop-maybe-bind-form step data-type?)) (cond ((and limit (not eval-to-first)) (setq limit (loop-maybe-bind-form limit data-type?)))) (cond ((not (null limit)) (let ((z (list var limit))) (setq test (cond ((eq direction 'up) (cond (inclusive `(greaterp . ,z)) (t `(not (lessp . ,z))))) (t (cond (inclusive `(lessp . ,z)) (t `(not (greaterp . ,z)))))))))) (setq step (cond ((eq direction 'up) (cond ((equal step 1) `(add1 ,var)) (t `(plus ,var ,step)))) ((equal step 1) `(sub1 ,var)) (t `(difference ,var ,step)))) ;; The object of the following crock is to get the INTERPRETER to ;; do error checking. This is only correct for data-type of FIXNUM, ;; since floating-point arithmetic is contagious. #+Maclisp (and (eq data-type? 'fixnum) (rplaca step (cdr (assq (car step) '((sub1 . 1-) (add1 . 1+) (plus . +) (difference . -)))))) (list test nil nil `(,var ,step)))) (defun loop-for-being (var val data-type?) ; FOR var BEING something ... - var = VAR, something = VAL. ; If what passes syntactically for a pathname isn't, then ; we trap to the ATTACHMENTS path; the expression which looked like ; a path is given as an argument to the IN preposition. If ; LOOP-ATTACHMENT-TRANSFORMER is not NIL, then we call that on the ; "form" to get the actual form; otherwise, we quote it. Thus, ; by default, FOR var BEING EACH expr OF expr-2 ; ==> FOR var BEING ATTACHMENTS IN 'expr OF expr-2. (let ((tem) (inclusive?) (ipps) (each?) (attachment)) (cond ((loop-tequal val "each") (setq each? t val (car loop-source-code))) (t (push val loop-source-code))) (cond ((and (setq tem (loop-lookup-keyword val loop-path-keyword-alist)) (or each? (not (loop-tequal (cadr loop-source-code) 'and)))) ;; FOR var BEING {each} path {prep expr}..., but NOT ;; FOR var BEING var-which-looks-like-path AND {ITS} ... (pop loop-source-code)) (t (setq val (loop-get-form)) (cond ((loop-tequal (car loop-source-code) 'and) ;; FOR var BEING value AND ITS path-or-ar (or (null each?) (loop-error "lisp: malformed being clause in loop of var " var)) (setq ipps `((of ,val)) inclusive? t) (pop loop-source-code) (or (loop-tequal (setq tem (pop loop-source-code)) 'its) (loop-tequal tem 'his) (loop-tequal tem 'her) (loop-tequal tem 'their) (loop-tequal tem 'each) (loop-error "lisp: loop expected its or each but found " tem)) (cond ((setq tem (loop-lookup-keyword (car loop-source-code) loop-path-keyword-alist)) (pop loop-source-code)) (t (push (setq attachment `(in ,(loop-get-form))) ipps)))) ((not (setq tem (loop-lookup-keyword (car loop-source-code) loop-path-keyword-alist))) ; FOR var BEING {each} a-r ... (setq ipps (list (setq attachment (list 'in val))))) (t ; FOR var BEING {each} pathname ... ; Here, VAL should be just PATHNAME. (pop loop-source-code))))) (cond ((not (null tem))) ((not (setq tem (loop-lookup-keyword 'attachments loop-path-keyword-alist))) (loop-error "lisp: loop trapped to attachments path illegally")) (t (or attachment (break)) (rplaca (cdr attachment) (cond (loop-attachment-transformer (funcall loop-attachment-transformer (cadr attachment))) (t (list 'quote (cadr attachment))))))) (setq tem (funcall (cadr tem) (car tem) var data-type? (nreconc ipps (loop-gather-preps (caddr tem))) inclusive? (caddr tem) (cdddr tem))) ;; TEM is now (bindings prologue-forms endtest setups steps) (c-mapc #'(lambda (x) (let (var val dtype) (cond ((atom x) (setq var x)) (t (setq var (car x) val (cadr x) dtype (caddr x)))) (loop-make-variable var val dtype))) (car tem)) (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue)) (cddr tem))) (defun loop-gather-preps (preps-allowed) (do ((list nil (cons (list (pop loop-source-code) (loop-get-form)) list)) (token (car loop-source-code) (car loop-source-code))) ((not (memq token preps-allowed)) (nreverse list)))) (defun loop-add-path (name data) (loop-add-keyword (cons name data) 'loop-path-keyword-alist)) (defmacro define-loop-path (names . cruft) (let ((forms ())) (setq forms (c-mapcar #'(lambda (name) `(loop-add-path ',name ',cruft)) (cond ((atom names) (list names)) (t names)))) `(eval-when (eval load compile) ,@forms))) (defun loop-path-carcdr (name var dtype pps inclusive? preps data) preps dtype ;Prevent unused arguments error (let ((vars) (step) (endtest `(,(cadr data) ,var)) (tem)) (or (setq tem (loop-lookup-keyword 'of pps)) (loop-error "lisp: loop path has no initialization -- " name)) (setq vars `((,var ,(cond (inclusive? (cadr tem)) (t `(,(car data) ,(cadr tem)))) ,dtype))) (setq step `(,var (,(car data) ,var))) (list vars nil nil nil endtest step))) (defun loop-interned-symbols-path (path variable data-type prep-phrases inclusive? allowed-preps data) path data-type allowed-preps data ; unused vars ; data-type should maybe be error-checked..... (let ((bindings) (presteps) (pretest) (poststeps) (posttest) (prologue) (indexv) (listv) (ob) (test) (step)) (push variable bindings) (and (not (null prep-phrases)) (or (cdr prep-phrases) (and (not (loop-tequal (caar prep-phrases) 'in)) (not (loop-tequal (caar prep-phrases) 'of)))) (loop-error "Illegal prep phrase(s) in interned-symbols path --" (list* variable 'being path prep-phrases))) (push (list (setq ob (gensym)) (cond ((null prep-phrases) 'obarray ) (t (cadar prep-phrases)))) bindings) ; Multics lisp does not store single-char-obs in the obarray buckets. ; Thus, we need to iterate over the portion of the obarray ; containing them also. (511. = (ascii 0)) (push `(,(setq indexv (gensym)) #+Multics 639. #+(and Maclisp (not Multics)) 511. #+Lispm 0 fixnum) bindings) #+Maclisp (push `(,(setq listv (gensym)) nil) bindings) #+Lispm (push `(setq ,indexv (array-dimension-n 2 ,ob)) prologue) (setq test `(and #-Multics (null ,listv) #+Multics (or (> ,indexv 510.) (null ,listv)) (prog () lp (cond ((< (setq ,indexv (1- ,indexv)) 0) (return t)) ((setq ,listv (arraycall #+Multics obarray #-Multics t ,ob ,indexv)) (return nil)) (t (go lp))))) ) (setq step `(,variable #+Multics (cond ((> ,indexv 510.) ,listv) (t (prog2 nil (car ,listv) (setq ,listv (cdr ,listv))))) #+(and Maclisp (not Multics)) (car ,listv) #+Lispm (ar-2 ,ob 1 ,indexv))) (cond (inclusive? (setq posttest test poststeps step prologue `((setq ,variable ,ob)))) (t (setq pretest test presteps step))) #+(and Maclisp (not Multics)) (setq poststeps `(,@poststeps ,listv (cdr ,listv))) (list bindings prologue pretest presteps posttest poststeps))) ; We don't want these defined in the compilation environment because ; the appropriate environment hasn't been set up. So, we just bootstrap ; them up. (c-mapc #'(lambda (x) (c-mapc #'(lambda (y) (loop-add-path y (cdr x))) (car x))) '(((car cars) loop-path-carcdr (of) car atom) ((cdr cdrs) loop-path-carcdr (of) cdr atom) ((cddr cddrs) loop-path-carcdr (of) cddr null) ((interned-symbols interned-symbol) loop-interned-symbols-path (in)) )) (or (status feature loop) (sstatus feature loop)) ;Loop macro blathering. ; ; This doc is totally wrong. Complete documentation (nice looking ; hardcopy) is available from GSB, or from ML:LSBDOC;LPDOC (which ; needs to be run through BOLIO). ; ;This is intended to be a cleaned-up version of PSZ's FOR package ;which is a cleaned-up version of the Interlisp CLisp FOR package. ;Note that unlike those crocks, the order of evaluation is the ;same as the textual order of the code, always. ; ;The form is introduced by the word LOOP followed by a series of clauses, ;each of which is introduced by a keyword which however need not be ;in any particular package. Certain keywords may be made "major" ;which means they are global and macros themselves, so you could put ;them at the front of the form and omit the initial "LOOP". ; ;Each clause can generate: ; ; Variables local to the loop. ; ; Prologue Code. ; ; Main Code. ; ; Epilogue Code. ; ;Within each of the three code sections, code is always executed strictly ;in the order that the clauses were written by the user. For parallel assignments ;and such there are special syntaxes within a clause. The prologue is executed ;once to set up. The main code is executed several times as the loop. The epilogue ;is executed once after the loop terminates. ; ;The term expression means any Lisp form. The term expression(s) means any number ;of Lisp forms, where only the first may be atomic. It stops at the first atom ;after the first form. ; ;The following clauses exist: ; ;Prologue: ; INITIALLY expression(s) ; This explicitly inserts code into the prologue. More commonly ; code comes from variable initializations. ; ;Epilogue: ; FINALLY expression(s) ; This is the only way to explicitly insert code into the epilogue. ; ;Side effects: ; DO expression(s) ; The expressions are evaluated. This is how you make a "body". ; DOING is synonymous with DO. ; ;Return values: ; RETURN expression(s) ; The last expression is returned immediately as the value of the form. ; This is equivalent to DO (RETURN expression) which you will ; need to use if you want to return multiple values. ; COLLECT expression(s) ; The return value of the form will be a list (unless over-ridden ; with a RETURN). The list is formed out of the values of the ; last expression. ; COLLECTING is synonymous with COLLECT. ; APPEND (or APPENDING) and NCONC (or NCONCING) can be used ; in place of COLLECT, forming the list in the appropriate ways. ; COUNT expression(s) ; The return value of the form will be the number of times the ; value of the last expression was non-NIL. ; SUM expression(s) ; The return value of the form will be the arithmetic sum of ; the values of the last expression. ; The following are a bit wierd syntactically, but Interlisp has them ; so they must be good. ; ALWAYS expression(s) ; The return value will be T if the last expression is true on ; every iteration, NIL otherwise. ; NEVER expressions(s) ; The return value will be T if the last expression is false on ; every iteration, NIL otherwise. ; THEREIS expression(s) ; This is wierd, I'm not sure what it really does. ; You probably want WHEN (NUMBERP X) RETURN X ; or maybe WHEN expression RETURN IT ; ;Conditionals: (these all affect only the main code) ; ; WHILE expression ; The loop terminates at this point if expression is false. ; UNTIL expression ; The loop terminates at this point if expression is true. ; WHEN expression clause ; Clause is performed only if expression is true. ; This affects only the main-code portion of a clause ; such as COLLECT. Use with FOR is a little unclear. ; IF is synonymous with WHEN. ; WHEN expression RETURN IT (also COLLECT IT, COUNT IT, SUM IT) ; This is a special case, the value of expression is returned if non-NIL. ; This works by generating a temporary variable to hold ; the value of the expression. ; UNLESS expression clause ; Clause is performed only if expression is false. ; ;Variables and iterations: (this is the hairy part) ; ; WITH variable = expression {AND variable = expression}... ; The variable is set to the expression in the prologue. ; If several variables are chained together with AND ; the setq's happen in parallel. Note that all variables ; are bound before any expressions are evaluated (unlike DO). ; ; FOR variable = expression {AND variable = expression}... ; At this point in the main code the variable is set to the expression. ; Equivalent to DO (PSETQ variable expression variable expression...) ; except that the variables are bound local to the loop. ; ; FOR variable FROM expression TO expression {BY expression} ; Numeric iteration. BY defaults to 1. ; BY and TO may be in either order. ; If you say DOWNTO instead of TO, BY defaults to -1 and ; the end-test is reversed. ; If you say BELOW instead of TO or ABOVE instead of DOWNTO ; the iteration stops before the end-value instead of after. ; The expressions are evaluated in the prologue then the ; variable takes on its next value at this point in the loop; ; hair is required to win the first time around if this FOR is ; not the first thing in the main code. ; FOR variable IN expression ; Iteration down members of a list. ; FOR variable ON expression ; Iteration down tails of a list. ; FOR variable IN/ON expression BY expression ; This is an Interlisp crock which looks useful. ; FOR var ON list BY expression[var] ; is the same as FOR var = list THEN expression[var] ; FOR var IN list BY expression[var] ; is similar except that var gets tails of the list ; and, kludgiferously, the internal tail-variable ; is substituted for var in expression. ; FOR variable = expression THEN expression ; General DO-type iteration. ; Note that all the different types of FOR clauses can be tied together ; with AND to achieve parallel assignment. Is this worthwhile? ; [It's only implemented for = mode.] ; AS is synonymous with FOR. ; ; FOR variable BEING expression(s) AND ITS pathname ; FOR variable BEING expression(s) AND ITS a-r ; FOR variable BEING {EACH} pathname {OF expression(s)} ; FOR variable BEING {EACH} a-r {OF expression(s)} ; Programmable iteration facility. Each pathname has a ; function associated with it, on LOOP-PATH-KEYWORD-ALIST; the ; alist has entries of the form (pathname function prep-list). ; prep-list is a list of allowed prepositions; after either of ; the above formats is parsed, then pairs of (preposition expression) ; are collected, while preposition is in prep-list. The expression ; may be a progn if there are multiple prepositions before the next ; keyword. The function is then called with arguments of: ; pathnname variable prep-phrases inclusive? prep-list ; Prep-phrases is the list of pairs collected, in order. Inclusive? ; is T for the first format, NIL otherwise; it says that the init ; value of the form takes on expression. For the first format, the ; list (OF expression) is pushed onto the fromt of the prep-phrases. ; In the above examples, a-r is a form to be evaluated to get an ; attachment-relationship. In this case, the pathname is taken as ; being ATTACHMENTS, and a-r is passed in by being treated as if it ; had been used with the preposition IN. The function should return ; a list of the form (bindings init-form step-form end-test); bindings ; are stuffed onto loop-variables, init-form is initialization code, ; step-form is step-code, and end-test tells whether or not to exit. ; ;Declarations? Not needed by Lisp machine. For Maclisp these will be done ;by a reserved word in front of the variable name as in PSZ's macro. ; ;The implementation is as a PROG. No initial values are given for the ;PROG-variables. PROG1 is used for parallel assignment. ; ;The iterating forms of FOR present a special problem. The problem is that ;you must do everything in the order that it was written by the user, but the ;FOR-variable gets its value in a different way in the first iteration than ;in the subsequent iterations. Note that the end-tests created by FOR have ;to be done in the appropriate order, since otherwise the next clause might get ;an error. ; ;The most general way is to introduce a flag, !FIRST-TIME, and compile the ;clause "FOR var = first TO last" as "INITIALLY (SETQ var first) ;WHEN (NOT !FIRST-TIME) DO (SETQ var (1+ var)) WHILE (<= var last)". ;However we try to optimize this by recognizing a special case: ;The special case is recognized where all FOR clauses are at the front of ;the main code; in this case if there is only one its stepping and ;endtest are moved to the end, and a jump to the endtest put at the ;front. If there are more than one their stepping and endtests are moved ;to the end, with duplicate endtests at the front except for the last ;which doesn't need a duplicate endtest. If FORs are embedded in the ;main code it can only be implemented by either a first-time flag or ;starting the iteration variable at a special value (initial minus step ;in the numeric iteration case). This could probably just be regarded as ;an error. The important thing is that it never does anything out of ;order. |
Added psl-1983/util/macroexpand.sl version [207f063148].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MACROEXPAND.SL - tools for expanding macros in forms % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>MACROEXPAND.SL.15, 2-Sep-82 10:32:10, Edit by BENSON % Fixed multiple argument SETQ macro expansion (defmacro macroexpand (form . macros) `(macroexpand1 ,form (list ,@macros))) (fluid '(macroexpand-signal*)) (de macroexpand1 (U L) (let ((macroexpand-signal* nil)(*macro-displace nil)) (while (null macroexpand-signal*) (setq macroexpand-signal* t) (setq U (macroexpand2 U L)))) U) (de macroexpand2 (U L) (cond ((or (atom U) (constantp (car U))) U) ((eqcar (car U) 'lambda) `((lambda ,(cadar U) ,.(foreach V in (cddar U) collect (macroexpand2 V L))) ,.(foreach V in (cdr U) collect (macroexpand2 V L)))) ((not (idp (car U))) U) (t (let ((fn (getd (car U)))(spfn (get (car U) 'macroexpand-func))) (cond (spfn (apply spfn (list U L))) ((eqcar fn 'fexpr) U) ((and (eqcar fn 'macro) (or (null L) (memq (car U) L))) (setq macroexpand-signal* nil) (apply (cdr fn) (list U))) (t (cons (car U) (foreach V in (cdr U) collect (macroexpand2 V L))))))))) (de macroexpand-cond (U L) (cons 'cond (foreach V in (cdr U) collect (foreach W in V collect (macroexpand2 W L))))) (de macroexpand-prog (U L) `(prog ,(cadr U) ,.(foreach V in (cddr U) collect (macroexpand2 V L)))) (de macroexpand-random (U L) (cons (car U) (foreach V in (cdr U) collect (macroexpand2 V L)))) (deflist '( % Should probably add a bunch more... (prog macroexpand-prog) (progn macroexpand-random) (cond macroexpand-cond) (and macroexpand-random) (or macroexpand-random) (setq macroexpand-random) (function macroexpand-random) ) 'macroexpand-func) (de macroexpand-loop () (catch 'macroexpand-loop `(toploop ',(and toploopread* #'read) ',#'prettyprint ',#'(lambda (u) (if (atom u) (throw 'macroexpand-loop) (macroexpand u))) "expand" ',(bldmsg "Entering macroexpand loop (atomic input forces exit) %w..." (if (and toploopread* (idp toploopread*) (not (eq toploopread* 'read))) (bldmsg "[reading with %w]" toploopread*) "")))) (printf "... Leaving macroexpand loop.")) |
Added psl-1983/util/man.sl version [3ff2d1677b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% MAN -- an online PSL reference manual facility. %%% Principal features are easy access to the index and %%% a command to jump directly from a line in the index %%% to the place in the manual referred to. %%% %%% Author: Cris Perdue %%% Date: 12/1/82 %%% %%% This package is still under development. %%% An index browsing mode is contemplated, also use of a specialized %%% representation of the reference manual. %%% A concept index browser and a table of contents browser %%% are contemplated as extensions. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Edit by Cris Perdue, 8 Feb 1983 1145-PST % Modified to use functions now defined in their own modules. (compiletime (load fast-int if extended-char)) (imports '(nmode string-search string-input)) %%% Defines 2 new nondestructive commands for text mode, %%% which seems to make them apply in LISP mode as well. %%% One is M-!, which takes you to information about the %%% subject of interest in the chapter and page referred to %%% by the next index reference. %%% The other is C-X I, which does a "Find File" on the file %%% containing the function index to the PSL manual. (add-to-command-list 'read-only-text-command-list (x-char M-!!) 'index-browse-command) (add-to-command-list 'read-only-text-command-list (x-chars C-X i) 'get-index-buffer) (nmode-establish-current-mode) (fluid '(manual-chapters manual-file-template)) % 0-TITLEPAGE % 00-PREFACE % 000-CONTENTS %%% A list of strings, each containing the base name of a chapter %%% of the manual. The first member of this list must be %%% referred to as chapter 1 in index references, and similarly %%% for other elements of the list. (setq manual-chapters '( "01-INTRODUCTION" "02-GETSTART" "03-RLISP" "04-DATATYPES" "05-NUMBERS" "06-IDS" "07-LISTS" "08-STRINGS" "09-FLOWOFCONTROL" "10-FUNCTIONS" "11-INTERP" "12-GLOBALS" "13-IO" "14-TOPLOOP" "15-ERRORS" "16-DEBUG" "17-EDITOR" "18-UTILITIES" "19-COMPLR" "20-DEC20" "21-SYSLISP" "22-IMPLEMENTATION" "23-PARSER" "24-BIBLIO" "25-FUN-INDEX" "26-TOP-INDEX" )) %%% This variable is a template for the name of a file that is %%% part of the manual. Actual manual file names are obtained by %%% substituting a name from the name list into this template. (setq manual-file-template "plpt:%w.lpt") (defun get-index-buffer () (find-file (bldmsg manual-file-template "25-FUN-INDEX"))) %%% This function gets the name that information is desired for, %%% gets the chapter and page of the "next" index reference after %%% point, does a "Find File" on the appropriate manual file, %%% goes to the appropriate page, and searches for an occurrence %%% of the key string. (defun index-browse-command () (let ((l (=> nmode-current-buffer current-line))) (let ((key (get-key l)) (dotpos (get-dot-pos l (=> nmode-current-buffer char-pos))) digitpos endpos chapter page) %% The first "." coming after point and with a digit on either %% side is used as the "." of the index entry. %% Contiguous digits to either side of the "." are taken %% to be chapter and page of the reference. %% This allows the user to distinguish between different %% index references even on the same line. (if (or (null key) (null dotpos)) then (ding) else (setq digitpos %% Search for non-digit or beginning of line. %% Position of earliest digit is returned. (for (from i (- dotpos 2) 0 -1) (do (if (not (digitp (indx l i))) then (return (+ i 1)))) (finally (return 0)))) (setq chapter (string-read (substring l digitpos dotpos))) %% Endpos is set to position of first non-digit after %% the page number, or end of line position, if all digits %% to end of line. (setq endpos (search-in-string-fn 'not-digitp l (+ dotpos 1))) (if (null endpos) then (setq endpos (+ (isizes l) 1))) (setq page (string-read (substring l (+ dotpos 1) endpos))) (find-file (bldmsg manual-file-template (nth manual-chapters chapter))) (move-to-buffer-start) %% Skip over pages preceding the desired one. (for (from i 1 (- page 1)) (do (forward-search "") (move-over-characters 1))) %% Search for an occurrence of the key string. %% This part should perhaps be refined to only move to %% a place within the page of interest. %% Note that forward-search expects the key to be entirely %% upper case and leaves point at the beginning of the string %% if found. (forward-search (string-upcase key)))))) %%% The key is taken to be a substring of the line string. %%% The key starts at the first nonblank character and runs %%% up to the first occurrence of either ". " or " .". This %%% is dependent on the precise format of index files produced %%% by Scribe. %%% This function is capable of returning NIL. (defun get-key (line) (let ((p1 (string-search ". " line)) (p2 (string-search " ." line))) (let ((end-pos (if (and p1 p2) then (min p1 p2) elseif (and p1 (null p2)) then p1 elseif (and p2 (null p1)) then p2 else nil)) (key-pos (search-in-string-fn 'nonblank line 0))) (if (and key-pos end-pos) then (substring line key-pos end-pos) else nil)))) %%% Searches for a dot which must be at or after "start". %%% The dot must be surrounded by a digit on either side. %%% NIL is returned if none found. (defun get-dot-pos (line start) (for (for dotpos (string-search-from "." line start) (string-search-from "." line (+ dotpos 1))) (while dotpos) (do (if (and (digitp (indx line (- dotpos 1))) (digitp (indx line (+ dotpos 1)))) then (return dotpos))))) (defun not-digitp (c) (not (digitp c))) (defun nonblank (c) (neq c #\SPACE)) %%% The position of the first character of the domain for which %%% testfn returns true and whose index is at least "start" is %%% returned. If none such exists, NIL is returned. (defun search-in-string-fn (testfn domain start) (if (not (stringp domain)) then (error 0 "Arg to search-in-string-fn not a string")) (for (from i start (isizes domain)) (do (if (funcall testfn (igets domain i)) then (return i))) (finally (return nil)))) |
Added psl-1983/util/mathlib.build version [a671fc4fa9].
> | 1 | in "mathlib.red"$ |
Added psl-1983/util/mathlib.red version [0fa5c5ceb3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. MATHLIB.RED - Some useful mathematical functions for PSL % % Most of these routines not very heavily tested. % Contributions from Galway, Griss, Irish, Morrison, and others. % % MATHLIB.RED, 16-Dec-82 21:56:52, Edit by GALWAY % Various fixes and enhancements too numerous for me to remember. % Includes fixes in SQRT function, modifications of RANDOM and other % functions to bring them more in line with Common Lisp, addition of MOD % and FLOOR. % <PSL.UTIL>MATHLIB.RED.13, 13-Sep-82 08:49:52, Edit by BENSON % Bug in EXP, changed 2**N to 2.0**N % <PSL.UTIL>MATHLIB.RED.12, 2-Sep-82 09:22:19, Edit by BENSON % Changed all calls in REDERR to calls on STDERROR % <PSL.UTIL>MATHLIB.RED.2, 17-Jan-82 15:48:21, Edit by GRISS % changed for PSL % Should these names be changed so that they all begin with an F or some % other distinguishing mark? Are they in conflict with anything? Or should % we wait until we have packages? % Consider using Sasaki's BigFloat package -- it has all this and more, to % arbitrary precision. The only drawback is speed. %***************** Constants declared as NewNam's **************************** % We can't use these long ones in Lisp1.6 'cause the reader craps out (and % it would truncate instead of round, anyway). These are here for reference % for implementation on other machines. % put('NumberPi,'NewNam,3.14159265358979324); % put('NumberPi!/2,'NewNam,1.57079632679489662); % put('NumberPi!/4,'NewNam,0.785398163397448310); BothTimes << put('Number2Pi,'NewNam,6.2831853); put('NumberPi,'NewNam,3.1415927); put('NumberPi!/2,'NewNam,1.5707963); put('NumberPi!/4,'NewNam,0.78539816); put('Number3Pi!/4,'NewNam,2.3561945); put('Number!-2Pi,'Newnam,-6.2831853); put('Number!-Pi,'NewNam,-3.1415927); put('Number!-Pi!/2,'NewNam,-1.5707963); put('Number!-Pi!/4,'NewNam,-0.78539816); put('SqrtTolerance,'NewNam,0.0000001); put('NumberE, 'NewNam, 2.718281828); put('NumberInverseE, 'NewNam, 0.36787944); % 1/e put('NaturalLog2,'NewNam,0.69314718); put('NaturalLog10,'NewNam,2.3025851); put('TrigPrecisionLimit,'NewNam,80); >>; %********************* Basic functions *************************************** lisp procedure mod(M,N); % Return M modulo N. Unlike remainder function--it returns positive result % in range 0..N-1, even if M is negative. (Needs more work for case of % negative N.) begin scalar result; result := remainder(M,N); if result >= 0 then return result; % else return N + result; end; lisp procedure Floor X; % Returns the largest integer less than or equal to X. (I.e. the "greatest % integer" function.) if fixp X then X else begin scalar N; N := fix X; % Note the trickiness to compensate for fact that (unlike APL's "FLOOR" % function) FIX truncates towards zero. return if X = float N then N else if X>=0 then N else N-1; end; lisp procedure Ceiling X; % Returns the smallest integer greater than or equal to X. if fixp X then X else begin scalar N; N := fix X; % Note the trickiness to compensate for fact that (unlike APL's "FLOOR" % function) FIX truncates towards zero. return if X = float N then N else if X>0 then N+1 else N; end; lisp procedure Round X; % Rounds to the closest integer. % Kind of sloppy -- it's biased when the digit causing rounding is a five, % it's a bit weird with negative arguments, round(-2.5)= -2. if fixp X then X else floor(X+0.5); %***************** Trigonometric Functions *********************************** % Trig functions are all in radians. The following few functions may be used % to convert to/from degrees, or degrees/minutes/seconds. lisp procedure DegreesToRadians x; x*0.017453292; % 2*pi/360 lisp procedure RadiansToDegrees x; x*57.29578; % 360/(2*pi) lisp procedure RadiansToDMS x; % Converts radians to a list of degrees, minutes, and seconds (rounded, not % truncated, to the nearest integer). begin scalar Degs,Mins; x := RadiansToDegrees x; Degs := fix x; x := 60*(x-Degs); Mins := fix x; return list(Degs,Mins, Round(60*(x-Mins))) end; lisp procedure DMStoRadians(Degs,Mins,Sex); % Converts degrees, minutes, seconds to radians. % DegreesToRadians(Degs+Mins/60.0+Sex/3600.0) DegreesToRadians(Degs+Mins*0.016666667+Sex*0.00027777778); lisp procedure sin x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of SIN"; if x > NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then << neg := not neg; x := -x >>; if x > NumberPi!/2 then x := NumberPi-x; return if neg then -ScaledSine x else ScaledSine x end; lisp procedure ScaledSine x; % assumes its argument is scaled to between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return x*(1+xsqrd*(-0.16666667+xsqrd*(0.0083333315+xsqrd*(-0.0001984090+ xsqrd*(0.0000027526-xsqrd*0.0000000239))))) end; lisp procedure cos x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. << if minusp x then x := - x; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of COS"; if x > NumberPi then x := x-Number2Pi*fix((x+NumberPi)/Number2Pi); if minusp x then x := - x; if x > NumberPi!/2 then -ScaledCosine(NumberPi-x) else ScaledCosine x >>; lisp procedure ScaledCosine x; % Expects its argument to be between 0 and pi/2. begin scalar xsqrd; xsqrd := x*x; return 1+xsqrd*(-0.5+xsqrd*(0.041666642+xsqrd*(-0.0013888397+ xsqrd*(0.0000247609-xsqrd*0.0000002605)))) end; lisp procedure tan x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of TAN"; if x > NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if minusp x then << neg := not neg; x := - x >>; if x < NumberPi!/4 then x := ScaledTangent x else x := ScaledCotangent(-(x-numberpi!/2)); return if neg then -x else x end; lisp procedure cot x; % Accurate to about 6 decimal places, so long as the argument is % of commensurate precision. This will, of course, NOT be true for % large arguments, since they will be coming in with small precision. begin scalar neg; if minusp x then << neg := T; x := - x >>; if x > NumberPi!/2 then x := x-NumberPi*fix((x+NumberPi!/2)/NumberPi); if x > TrigPrecisionLimit then LPriM "Possible loss of precision in computation of COT"; if minusp x then << neg := not neg; x := - x >>; if x < NumberPi!/4 then x := ScaledCotangent x else x := ScaledTangent(-(x-numberpi!/2)); return if neg then -x else x end; lisp procedure ScaledTangent x; % Expects its argument to be between 0 and pi/4. begin scalar xsqrd; xsqrd := x*x; return x*(1.0+xsqrd*(0.3333314+xsqrd*(0.1333924+xsqrd*(0.05337406 + xsqrd*(0.024565089+xsqrd*(0.002900525+xsqrd*0.0095168091)))))) end; lisp procedure ScaledCotangent x; % Expects its argument to be between 0 and pi/4. begin scalar xsqrd; xsqrd := x*x; return (1.0-xsqrd*(0.33333334+xsqrd*(0.022222029+xsqrd*(0.0021177168 + xsqrd*(0.0002078504+xsqrd*0.0000262619)))))/x end; lisp procedure sec x; 1.0/cos x; lisp procedure csc x; 1.0/sin x; lisp procedure sinD x; sin DegreesToRadians x; lisp procedure cosD x; cos DegreesToRadians x; lisp procedure tanD x; tan DegreesToRadians x; lisp procedure cotD x; cot DegreesToRadians x; lisp procedure secD x; sec DegreesToRadians x; lisp procedure cscD x; csc DegreesToRadians x; lisp procedure asin x; begin scalar neg; if minusp x then << neg := T; x := -x >>; if x > 1.0 then stderror list("Argument to ASIN too large:",x); return if neg then CheckedArcCosine x - NumberPi!/2 else NumberPi!/2 - CheckedArcCosine x end; lisp procedure acos x; begin scalar neg; if minusp x then << neg := T; x := -x >>; if x > 1.0 then stderror list("Argument to ACOS too large:",x); return if neg then NumberPi - CheckedArcCosine x else CheckedArcCosine x end; lisp procedure CheckedArcCosine x; % Return cosine of a "checked number", assumes its argument is in the range % 0 <= x <= 1. sqrt(1.0-x)*(1.5707963+x*(-0.2145988+x*(0.088978987+x*(-0.050174305+ x*(0.030891881+x*(-0.017088126+x*(0.0066700901-x*(0.0012624911)))))))); lisp procedure atan x; if minusp x then if x < -1.0 then Number!-Pi!/2 + CheckedArcTangent(-1.0/x) else -CheckedArcTangent(-x) else if x > 1.0 then NumberPi!/2 - CheckedArcTangent(1.0/x) else CheckedArcTangent x; lisp procedure acot x; if minusp x then if x < -1.0 then -CheckedArcTangent(-1.0/x) else Number!-Pi!/2 + CheckedArcTangent(-x) else if x > 1.0 then CheckedArcTangent(1.0/x) else NumberPi!/2 - CheckedArcTangent x; lisp procedure CheckedArcTangent x; begin scalar xsqrd; xsqrd := x*x; return x*(1+xsqrd*(-0.33333145+xsqrd*(0.19993551+xsqrd*(-0.14208899+ xsqrd*(0.10656264+xsqrd*(-0.07528964+xsqrd*(0.042909614+ xsqrd*(-0.016165737+xsqrd*0.0028662257)))))))) end; lisp procedure asec x; acos(1.0/x); lisp procedure acsc x; asin(1.0/x); lisp procedure asinD x; RadiansToDegrees asin x; lisp procedure acosD x; RadiansToDegrees acos x; lisp procedure atanD x; RadiansToDegrees atan x; lisp procedure acotD x; RadiansToDegrees acot x; lisp procedure asecD x; RadiansToDegrees asec x; lisp procedure acscD x; RadiansToDegrees acsc x; %****************** Roots and such ******************************************* lisp procedure sqrt N; % Simple Newton-Raphson floating point square root calculator. % Not waranted against truncation errors, etc. begin integer answer,scale; N:=FLOAT N; if N < 0.0 then stderror list("SQRT given negative argument:",N); if zerop N then return N; % Scale argument to within 1e-10 to 1e+10; scale := 0; while N > 1.0E10 do << scale := scale + 1; N := N * 1.0E-10 >>; while N < 1.0E-10 do << scale := scale - 1; N := N * 1.0E10 >>; answer := if N>2.0 then (N+1)/2 else if N<0.5 then 2/(N+1) else N; % Here's the heart of the algorithm. while abs(answer**2/N - 1.0) > SqrtTolerance do answer := 0.5*(answer+N/answer); return answer * 10.0**(5*scale) end; %******************** Logs and Exponentials ********************************** lisp procedure exp x; % Returns the exponential (ie, e**x) of its floatnum argument as % a flonum. The argument is scaled to % the interval -ln 2 to 0, and a Taylor series expansion % used (formula 4.2.45 on page 71 of Abramowitz and Stegun, % "Handbook of Mathematical Functions"). begin scalar N; N := ceiling(x / NaturalLog2); x := N * NaturalLog2 - x; return 2.0**N * (1.0+x*(-0.9999999995+x*(0.4999999206+x*(-0.1666653019+ x*(0.0416573475+x*(-0.0083013598+x*(0.0013298820+ x*(-0.0001413161)))))))) end; lisp procedure log x; % See Abramowitz and Stegun, page 69. if x <= 0.0 then stderror list("LOG given non-positive argument:",x) else if x < 1.0 then -log(1.0/x) else % Find natural log of x > 1; begin scalar nextx, ipart; % ipart is the "integer part" of the % logarithm. ipart := 0; % Keep multiplying by 1/e until x is small enough, may want to be more % "efficient" if we ever use really big numbers. while (nextx := NumberInverseE * x) > 1.0 do << x := nextx; ipart := ipart + 1; >>; return ipart + if x < 2.0 then CheckedLogarithm x else 2.0 * CheckedLogarithm(sqrt(x)); end; lisp procedure CheckedLogarithm x; % Should have 1 <= x <= 2. (i.e. x = 1+y 0 <= y <= 1) << x := x-1.0; x*(0.99999642+x*(-0.49987412+x*(0.33179903+x*(-0.24073381+x*(0.16765407+ x*(-0.09532939+x*(0.036088494-x*0.0064535442))))))) >>; lisp procedure log2 x; log x / NaturalLog2; lisp procedure log10 x; log x / NaturalLog10; %********************* Random Number Generator ******************************* % The declarations below constitute a linear, congruential % random number generator (see Knuth, "The Art of Computer % Programming: Volume 2: Seminumerical Algorithms", pp9-24). % With the given constants it has a period of 392931 and % potency 6. To have deterministic behaviour, set % RANDOMSEED. % % Constants are: 6 2 % modulus: 392931 = 3 * 7 * 11 % multiplier: 232 = 3 * 7 * 11 + 1 % increment: 65537 is prime % % Would benefit from being recoded in SysLisp, when full word integers should % be used with "automatic" modular arithmetic (see Knuth). Perhaps we should % have a longer period version? % By E. Benson, W. Galway and M. Griss fluid '(RandomSeed RandomModulus); RandomModulus := 392931; RandomSeed := remainder(time(),RandomModulus); lisp procedure next!-random!-number; % Returns a pseudo-random number between 0 and RandomModulus-1 (inclusive). RandomSeed := remainder(232*RandomSeed + 65537, RandomModulus); lisp procedure Random(N); % Return a pseudo-random number uniformly selected from the range 0..N-1. % NOTE that this used to be called RandomMod(N). Needs to be made more % compatible with Common LISP's random? fix( (float(N) * next!-random!-number()) / RandomModulus); procedure FACTORIAL N; % Simple factorial Begin scalar M; M:=1; for i:=1:N do M:=M*I; Return M; end; % Some functions from ALPHA_1 users lisp procedure Atan2D( Y, X ); RadiansToDegrees Atan2( Y, X ); lisp procedure Atan2( Y, X ); << X := float X; Y := Float Y; if X = 0.0 then % Y axis. if Y >= 0.0 then NumberPI!/2 else NumberPi + NumberPI!/2 else if X >= 0.0 and Y >= 0.0 then % First quadrant. Atan( Y / X ) else if X < 0.0 and Y >= 0.0 then % Second quadrant. NumberPI - Atan( Y / -X ) else if X < 0.0 and Y < 0.0 then % Third quadrant. NumberPI + Atan( Y / X ) else % Fourth quadrant. Number2Pi - Atan( -Y / X ) >>; lisp procedure TransferSign( S, Val ); % Transfers the sign of S to Val by returning abs(Val) if S >= 0, % otherwise -abs(Val). if S >= 0 then abs(Val) else -abs(Val); lisp procedure DMStoDegrees(Degs,Mins,Sex); % Converts degrees, minutes, seconds to degrees % Degs+Mins/60.0+Sex/3600.0 Degs+Mins*0.016666667+Sex*0.00027777778; lisp procedure DegreesToDMS x; % Converts degrees to a list of degrees, minutes, and seconds (all integers, % rounded, not truncated). begin scalar Degs,Mins; Degs := fix x; x := 60*(x-Degs); Mins := fix x; return list(Degs,Mins, round(60*(x-Mins))) end; end; |
Added psl-1983/util/mini-support-patch.red version [65b08a1674].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | GLOBAL '(SCNVAL); LISP PROCEDURE !%SCAN; <<SCNVAL := CHANNELREADTOKEN IN!*; TOKTYPE!*>>; PROCEDURE UNREADCH U; UNREADCHAR (ID2INT (U)); END; |
Added psl-1983/util/mini-support.fix version [f3b7b33f62].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | FLUID '(PromptString!* !*Break); % Error-print is called when the major loop returns a NIL. SYMBOLIC PROCEDURE ERROR!-PRINT; <<PRIN2 "ERROR in grammar, current token is "; PRIN2 !#TOK!#; PRIN2 " and stack is "; PRIN2 !#STACK!#; TERPRI() >>; % The following errs out if its argument is NIL SYMBOLIC PROCEDURE FAIL!-NOT U; IF U then T else begin scalar Promptstring!*; PRIN2T "FAIL-NOT called in a concatenation"; ERROR!-PRINT(); PromptString!*:="Mini-Error>"; U:=ContinuableERROR(997,"Failure scanning a concatenation",'(QUOTE T)); IF U AND SCAN!-TERM() THEN RETURN T; return begin scalar !*Break; return Error(997, "Could not Recover from FAIL-NOT"); end; end; % Invoke starts execution of a previously defined grammar. SYMBOLIC PROCEDURE INVOKE U; BEGIN SCALAR X,PromptString!*; PromptString!*:=Concat(Id2String U,">"); !#IDTYPE!# := 0; !#NUMTYPE!# := 2; !#STRTYPE!# := 1; FLAG (GET (U, 'KEYS), 'KEY); DIPBLD (GET (U, 'DIPS)); !#RTNOW!# := GET (U, 'RTS); !#GTNOW!# := GET (U, 'GTS); !#DIP!# := !#KEY!# := !#RT!# := !#GT!# := !#GENLABLIST!# := NIL; L: !#STACK!# := NIL; NEXT!-TOK(); X := APPLY (U, NIL); IF NULL X THEN << ERROR!-PRINT(); IF SCAN!-TERM() THEN <<PRIN2 ("Resuming scan"); TERPRI(); GOTO L>> >>; REMFLAG (GET (U, 'KEYS), 'KEY) END; |
Added psl-1983/util/mini-support.red version [0a7859a076].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % % % MINI % % (A SMALL META SYSTEM) % % % % % % Copyright (c) Robert R. Kessler 1979 % % Mods: MLG, Feb 1981 % % % This file is the support routines. % % The file MINI.MIN contains the MINI % % system self definition and MINI.SL % % is the Standard LISP translation % % of MINI.MIN. % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% GLOBAL '(!#KEY!# !#DIP!# !*MDEFN !#STACK!# !#STACK!-ELE!# !#TOK!# !#TOKTYPE!# !#NTOK!# !#LABLIST!# SINGLEOP!* FAILURE!* INDEXLIST!* !#RT!# !#GT!# !#RTNOW!# !#GTNOW!# !#IDTYPE!# !#NUMTYPE!# !#STRTYPE!# !#GENLABLIST!#); % Global description: % !#DIP!# - List of diphthongs for grammar being defined. % FAILURE!* - Value of failed match in pattern matcher. % !#GENLABLIST!# - List of generated labels used in push/pop lab. % !#GT!# - List of grammar terminators for invoked grammar. % !#GTNOW!# - List of grammar terminators for grammar being def. % !#IDTYPE!# - The value of toktype for id's (0) % INDEXLIST!* - List of number value pairs for pattern matcher. % !#KEY!# - List of key workds for grammar being defined. % !#LABLIST!# - The list of gensymed labels ($n). % !*MDEFN - Flag to MPRINT (ON) or EVAL (OFF) defined rule. % !#NUMTYPE!# - The value of toktype for numbers (2) % !#NTOK!# - Next token, used for diphthong checking. % !#RT!# - List of rule terminators for invoked grammar. % !#RTNOW!# - List of rule terminators for grammar being defined. % SINGLEOP!* - The operator for any match pattern (&). % !#STACK!# - The stack list: push +, pop #n , ref ##n % !#STACK!-ELE!# - Used to pass info between stack operations % !#SPECTYPE!# - The value of toktype for specials (3) % !#STRTYPE!# - The value of toktype for strings (1) % !#TOK!# - The current token % !#TOKTYPE!# - The type of the token from rSYMBOLIC Parser % (0-id, 1-str, 2-num, 3-special) % A grammar is defined by calling the function MINI with argument of % the name of the goal rule. i.e. MINI 'RUL redefines MINI itself. % Then to invoke a grammar, you use INVOKE goal rule name.(INVOKE 'RUL). SYMBOLIC PROCEDURE MINI U; << INVOKE 'RUL; RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE KEYS), LIST('QUOTE, !#KEY!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE DIPS), LIST('QUOTE, !#DIP!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE RTS), LIST('QUOTE, !#RT!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE GTS), LIST('QUOTE, !#GT!#)); NIL >>; % Invoke starts execution of a previously defined grammar. SYMBOLIC PROCEDURE INVOKE U; BEGIN SCALAR X; !#IDTYPE!# := 0; !#NUMTYPE!# := 2; !#STRTYPE!# := 1; FLAG (GET (U, 'KEYS), 'KEY); DIPBLD (GET (U, 'DIPS)); !#RTNOW!# := GET (U, 'RTS); !#GTNOW!# := GET (U, 'GTS); !#DIP!# := !#KEY!# := !#RT!# := !#GT!# := !#GENLABLIST!# := NIL; L: !#STACK!# := NIL; NEXT!-TOK(); X := APPLY (U, NIL); IF NULL X THEN << ERROR!-PRINT(); IF SCAN!-TERM() THEN <<PRIN2 ("Resuming scan"); TERPRI(); GOTO L>> >>; REMFLAG (GET (U, 'KEYS), 'KEY) END; % The following errs out if its argument is NIL SYMBOLIC PROCEDURE FAIL!-NOT U; U OR <<ERROR!-PRINT(); ERROR(997,"Failure scanning a concatenation.")>>; % This procedure is called when a rule is defined. If ON MDEFN then the % value is MPRINTed, otherwise, it is evaled. SYMBOLIC PROCEDURE RULE!-DEFINE U; << IF !*MDEFN THEN MPRINT U ELSE EVAL U>>; % Mprint is used so it may be redefined if something other than PRINT % is desired when ON MDEFN is used. SYMBOLIC PROCEDURE MPRINT U; << TERPRI(); PRINT U>>; % Error-print is called when the major loop returns a NIL. SYMBOLIC PROCEDURE ERROR!-PRINT; <<PRIN2 "ERROR in grammar, current token is "; PRIN2 !#TOK!#; PRIN2 " and stack is "; PRIN2 !#STACK!#; TERPRI() >>; % Scan for a rule terminator or grammar terminator by fetching tokens. % Returns T if a rule terminator is found and NIL for a grammar term. % The rule terminator causes processing to continue after the terminator. % The grammar terminator ceases processing. SYMBOLIC PROCEDURE SCAN!-TERM; BEGIN SCALAR X; PRIN2 ("Scanning for rule terminator: "); PRIN2 !#RTNOW!#; PRIN2 (" or grammar terminator: "); PRIN2 !#GTNOW!#; TERPRI(); L: X := NEXT!-TOK(); IF MEMQ (X, !#GTNOW!#) THEN RETURN NIL ELSE IF MEMQ (X, !#RTNOW!#) THEN RETURN T ELSE GOTO L END; % Add the argument to the current key list, if not already there. SYMBOLIC PROCEDURE ADDKEY U; <<IF NOT MEMQ (U, !#KEY!#) THEN !#KEY!# := U . !#KEY!#; T>>; % Add the argument to the current grammar terminator list. SYMBOLIC PROCEDURE ADDGTERM U; <<IF NOT MEMQ (U, !#GT!#) THEN !#GT!# := U . !#GT!#; T>>; % Add the argument to the current rule terminator list. SYMBOLIC PROCEDURE ADDRTERM U; <<IF NOT MEMQ (U, !#RT!#) THEN !#RT!# := U . !#RT!#; T>>; % This procedure will take a list of identifiers and flag them as % diphthongs (2 character max). SYMBOLIC PROCEDURE DIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << IF NOT MEMQ (X, !#DIP!#) THEN !#DIP!# := X . !#DIP!#; Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; W := GET (CAR Y, 'FOLLOW); % Property follow is list of legal dip terms; PUT (CAR Y, 'FOLLOW, (LIST (CADR Y, X)) . W) >>; RETURN T END; SYMBOLIC PROCEDURE UNDIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; REMPROP(CAR Y, 'FOLLOW) >>; RETURN T END; % Following procedure will eliminate the escapes in a list SYMBOLIC PROCEDURE STRIP!! U; IF PAIRP U THEN IF CAR U EQ '!! THEN CADR U . STRIP!! CDDR U ELSE CAR U . STRIP!! CDR U ELSE NIL; % Push something onto the stack; SYMBOLIC PROCEDURE PUSH U; !#STACK!# := U . !#STACK!#; % Reference a stack element SYMBOLIC PROCEDURE REF U; SCAN!-STACK (U, !#STACK!#); % Stack underflow is called then that error happens. Right now, it errors % out. Future enhancement is to make it more friendly to the user. SYMBOLIC PROCEDURE STACK!-UNDERFLOW; ERROR (4000, "Stack underflow"); % Like above, a stack error has occured, so quit the game. SYMBOLIC PROCEDURE STACK!-ERROR; ERROR (4001, "Error in stack access"); % Search stack for the element U elements from the top (1 is top). SYMBOLIC PROCEDURE SCAN!-STACK (U, STK); IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U = 1 THEN CAR STK ELSE SCAN!-STACK (U-1, CDR STK); % Remove the Uth element from the stack (1 is the top). SYMBOLIC PROCEDURE EXTRACT U; << !#STACK!# := FETCH!-STACK (U, !#STACK!#); !#STACK!-ELE!# >>; % Return the value found; % Recursive routine to remove the Uth element from the stack. SYMBOLIC PROCEDURE FETCH!-STACK (U, STK); BEGIN SCALAR X; IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U EQ 1 THEN <<!#STACK!-ELE!# := CAR STK; RETURN CDR STK>> ELSE RETURN CAR STK . FETCH!-STACK (U-1, CDR STK) END; % Retrieve the length of the stack. This is used to build a single % list used in repetition. It takes the top of the stack down to % the stack length at the beginning to build the list. Therefore, % STK!-LENGTH must be called prior to calling BUILD!-REPEAT, which % must be passed the value returned by the call to STK!-LENGTH. SYMBOLIC PROCEDURE STK!-LENGTH; LENGTH !#STACK!#; % The procedure to handle repetition by building a list out of the % top n values on the stack. SYMBOLIC PROCEDURE BUILD!-REPEAT U; BEGIN SCALAR V; V := STK!-LENGTH(); IF U > V THEN STACK!-ERROR() ELSE IF U = V THEN PUSH NIL ELSE IF U < V THEN BEGIN SCALAR L, I; % Build it for the top V-U elements L := NIL; FOR I := 1:(V-U) DO L := (EXTRACT 1) . L; PUSH L END; RETURN T END; % Actually get the next token, if !#NTOK!# has a value then use that, % else call your favorite token routine. % This routine must return an identifier, string or number. % If U is T then don't break up a quoted list right now. SYMBOLIC PROCEDURE GET!-TOK U; BEGIN SCALAR X; IF !#NTOK!# THEN << X := !#NTOK!#; !#NTOK!# := NIL; RETURN X >> ELSE << X := !%SCAN(); % Scan sets the following codes: % 0 - ID, and thus was escapeed % 1 - STRING % 2 - Integer % 3 - Special (;, (, ), etc.) % Therefore, it is important to distinguish between % the special and ID for key words. IF (X EQ 2) OR (X EQ 1) THEN RETURN (X . SCNVAL) ELSE RETURN (0 . INTERN SCNVAL) >> %//Ignore ESCAPE for now END; % Fetch the next token, if a diphthong, turn into an identifier SYMBOLIC PROCEDURE NEXT!-TOK; BEGIN SCALAR X,Y; !#TOK!# := GET!-TOK(NIL); !#TOKTYPE!# := CAR !#TOK!#; !#TOK!# := CDR !#TOK!#; IF (Y:=GET(!#TOK!#, 'FOLLOW)) THEN << !#NTOK!# := 0 . READCH(); % Use READCH since white space IF X := ATSOC(CDR !#NTOK!#, Y) THEN % within diphthong is illegal << !#TOK!# := CADR X; !#TOKTYPE!# := !#IDTYPE!# >> ELSE UNREADCH CDR !#NTOK!#; % Push the character back for the !#NTOK!# := NIL >>; % scanner if not part of diphthong RETURN !#TOK!# END; SYMBOLIC PROCEDURE T!-NTOK; <<NEXT!-TOK(); 'T>>; SYMBOLIC PROCEDURE EQTOK(X); % Test Token Value EQUAL(!#TOK!#,X); % maybe use EQ? SYMBOLIC PROCEDURE EQTOK!-NEXT(X); EQTOK(X) AND T!-NTOK(); % See if current token is an identifier and not a keyword. If it is, % then push onto the stack and fetch the next token. SYMBOLIC PROCEDURE ID; IF !#TOKTYPE!# EQ !#IDTYPE!# AND NOT FLAGP(!#TOK!#,'KEY) THEN <<PUSH !#TOK!#; IF NOT (MEMQ (!#TOK!#, !#GTNOW!#) OR MEMQ(!#TOK!#, !#RTNOW!#)) THEN NEXT!-TOK(); T>> ELSE NIL; % See if current token is an id whether or not it is a keyword. SYMBOLIC PROCEDURE ANYID; IF (!#TOKTYPE!# EQ !#IDTYPE!#) THEN % (!#TOKTYPE!# EQ !#SPECTYPE!#) OR FLAGP(!#TOK!#, 'KEY) THEN ANYTOK() ELSE NIL; % Always succeeds by pushing the current token onto the stack. SYMBOLIC PROCEDURE ANYTOK; <<PUSH !#TOK!#; NEXT!-TOK(); T>>; % Tests to see if the current token is a number, if so it pushes the % number onto the stack and fetches the next token. SYMBOLIC PROCEDURE NUM; IF (!#TOKTYPE!# EQ !#NUMTYPE!#) THEN ANYTOK() ELSE NIL; % Same as NUM, except for strings. SYMBOLIC PROCEDURE STR; IF (!#TOKTYPE!# EQ !#STRTYPE!#) THEN ANYTOK() ELSE NIL; % Generate a label. If the label has been previously generated, the % return the old value. (used by $n). SYMBOLIC PROCEDURE GENLAB U; BEGIN SCALAR X; IF X:=ASSOC(U, !#LABLIST!#) THEN RETURN CADR X; X:=INTERN GENSYM(); !#LABLIST!# := LIST(U, X) . !#LABLIST!#; RETURN X END; % Push the current label lists so we don't get any conflicts. LISP PROCEDURE PUSH!-LAB; << !#GENLABLIST!# := !#LABLIST!# . !#GENLABLIST!#; !#LABLIST!# := NIL; T>>; % Pop label lists. LISP PROCEDURE POP!-LAB; <<!#LABLIST!# := CAR !#GENLABLIST!#; !#GENLABLIST!# := CDR !#GENLABLIST!#; T>>; GLOBAL '(!*DO!#); ON DO!#; FLUID '(NEWENV!*); % RBMATCH will accept a list of rules and subject list and % search for a match on one of the rules. Upon finding the % match, the body will be executed. SYMBOLIC PROCEDURE RBMATCH (SUBLIST, RULESLIST, INITENV); BEGIN SCALAR TEMP, ENVLIST, RULFOUND, RVAL, TRYAGAIN, SN; % IF NUMARGS() EQ 4 THEN TRYAGAIN := T ELSE TRYAGAIN := NIL; % IF NUMARGS() > 2 THEN INITENV := ARGUMENT(3) ELSE INITENV:=NIL; RVAL := FAILURE!*; WHILE RULESLIST DO << RULFOUND := CAR RULESLIST; RULESLIST := CDR RULESLIST; ENVLIST := LIST (LIST (0, SUBLIST)); IF INITENV THEN ENVLIST := APPEND (ENVLIST, INITENV); IF (NEWENV!* := PEVAL (CAR RULFOUND, SUBLIST, ENVLIST)) NEQ FAILURE!* THEN IF (TEMP := EVAL (LIST (CDR RULFOUND, 'NEWENV!*, NIL, NIL, NIL))) NEQ FAILURE!* THEN IF TEMP EQ 'FAIL THEN <<RVAL := NIL; RETURN NIL>> ELSE IF TRYAGAIN THEN << PRIN2T ("Success, will try again"); RVAL := APPEND (TEMP, RVAL) >> ELSE <<RVAL := TEMP; RETURN TEMP >> >>; RETURN RVAL END RBMATCH; % % PEVAL accepts a subjectlist, a pattern and an environment. % It then determines if the subjectlist matches the pattern % with the particular environment. The pattern may contain % lists or variable expressions. The variable expressions are % of two form: & "ATOM" which will match a single list or % ATOM and & & "ATOM" which will test to see if the match is % equal to a previously matched item. %; SINGLEOP!* := '&; FAILURE!* := NIL; SYMBOLIC PROCEDURE PEVAL(P, S, ENV); IF P EQ S THEN LIST ENV ELSE IF EQCAR (S, '!#) AND !*DO!# THEN TST!#(P, S, ENV) ELSE IF ATOM P THEN NIL ELSE IF CAR P EQ SINGLEOP!* THEN TST!-SINGLE(P, S, ENV) ELSE IF ATOM S THEN NIL ELSE BEGIN SCALAR ENVL; ENVL := PEVAL (CAR P, CAR S, ENV); RETURN PEVALL (CDR P, CDR S, ENVL) END; SYMBOLIC PROCEDURE PEVALL (P, S, ENVL); IF NULL ENVL THEN NIL ELSE IF NULL CDR ENVL THEN PEVAL (P, S, CAR ENVL) ELSE APPEND (PEVAL(P, S, CAR ENVL), PEVALL(P, S, CDR ENVL)); SYMBOLIC PROCEDURE TST!-SINGLE (P, S, ENV); BEGIN SCALAR IDX; IF LENGTH (IDX := CDR P) NEQ 1 THEN << IF CAR IDX EQ SINGLEOP!* THEN (IF EQUAL (S, CADR ASSOC (CADR IDX, ENV)) THEN RETURN LIST (ENV)) ELSE IF MEMBER (S, CAR IDX) THEN RETURN LIST (LIST(CADR IDX, S) . ENV); RETURN FAILURE!* >>; RETURN LIST (LIST (CAR IDX, S) . ENV) END; SYMBOLIC PROCEDURE TST!# (P, S, ENV); BEGIN SCALAR OLST, N, ENVL, CLST, X; OLST := CADR S; N := CADDR S; ENVL := NIL; L: IF NULL OLST THEN RETURN ENVL; CLST := CAR OLST; X := PEVAL (P, CLST, ENV); OLST := CDR OLST; FOR EACH Y IN X DO ENVL := (LIST (N, CLST) . Y) . ENVL; GO TO L END; END; |
Added psl-1983/util/mini.build version [d95845b6fa].
> > > > > | 1 2 3 4 5 | in "mini-support-patch.red"$ in "mini-support.red"$ in "mini-support.fix"$ global '(PNAM); in "mini.sl"$ |
Added psl-1983/util/mini.demo version [876c3d55fc].
> > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | % ----- A simple DEMO of MINI ------- % Use after IN "/utah/psl/mini.build" MINI 'ROOT; % starts the mini parser generator ROOT: STMT* / 'QUIT ; % Define ROOT STMT: ID '= EXP @; +(SETQ #2 #1) .(PRINT #1) .(NEXT!-TOK) ; % Define STMT EXP: TERM < '+ EXP +(PLUS #2 #1) / '- EXP +(DIFFERENCE #2 #1)>; TERM: NUM / ID / '( EXP ') ; FIN % To run it, use % INVOKE 'ROOT; END; |
Added psl-1983/util/mini.min version [a5d4e4ca14].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % MINI - a small META system % % % % Copyright (c) Robert R. Kessler 1979 % % Mods: MLG, Feb 1981 % % % % This is the MINI system self definition. % % The file MINI-SUPPORT.RED contains the % % support routines and MINI.SL is the % % Standard LISP translation of this file. % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The following is the definition of the mini meta system in terms of % itself. MINI is very similar to META/REDUCE, except a lot of it has % been eliminated. The following features that are in META/REDUCE, are % not present in MINI: % - Backup is not supported. % - Diphthongs of more than 2 characters are not supported. Also, in % MINI, the diphthongs must be declared before they are used. % - Format operations are not supported (the => op). % - The symbol table operations are not supported (however, they could % easily be added as calls to the routines. % - The - operator for stripping off a level of parens is not supported. % - The META/REDUCE error operators are not supported (*** *****). % The following is a list of the differences between MINI and META/REDUCE: % - The += operator has been changed to +. to be consistent with the % meanings of the + (PUSH) and . (EVAL) operators. % - The @ operator also includes the semantics that it's token is used % as a rule terminator (for error recovery). When a token is found % during error recovery that is a rule terminator, the grammar is % reset to its initial stage and scanning continues. % - A new operator @@ has been added that is the same as the @ operator % but it signifies a grammar terminator. During error recovery, if % a grammar terminator is scanned, parsing will stop. % - The flag MDEFN controls whether a rule defined is EVALED or MPRINTed. % - MINI uses the RLISP token reader and is therefore much faster. % One consequences of this is that comments may be embedded anywhere % in the text and are ignored by %SCAN % Also, since %SCAN is used, certain quoted keywords need to have a % escape in front of them. The ones discovered so far are: '!+ '!- % '!( and '!). This also means that diphthongs that use these as % the first character must also be quoted (i.e. '!+= or '!-.). % The safe approach is to quote every special character. % To define a grammar, call the procedure MINI with the argument being the % root rule name. Then when the grammar is defined it may be called by % using INVOKE root rule name. % The following is the MINI Meta self definition. GLOBAL '(PNAM); MINI 'RUL; % Define the diphthongs to be used in the grammar. DIP: !#!#, !-!>, !+!., !@!@ ; % The root rule is called RUL. RUL: ('DIP ': ANYTOK[,]* .(DIPBLD #1) '; / (ID .(SETQ !#LABLIST!# NIL) ( ': ALT +(DE #2 NIL #1) @; / '= PRUL[,]* @; .(RULE!-DEFINE '(PUT (QUOTE ##2) (QUOTE RB) (QUOTE #1))) +(DE ##1 (A) (RBMATCH A (GET (QUOTE #1) (QUOTE RB)) NIL))) .(RULE!-DEFINE #1) .(NEXT!-TOK) ))* @@FIN ; % An alternative is a sequence of statements separated by /'s; ALT: SEQ < '/ ALT +(OR #2 #1) >; % A sequence is a list of items that must be matched. SEQ: REP < SEQ +(AND #2 (FAIL!-NOT #1)) >; % A repetition may be 0 or more single items (*) or 0 or more items % separated by any token (ID[,]* will parse a list of ID's separated by ,'s. REP: ONE <'[ (ID +(#1) / '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / ANYKEY +(EQTOK!-NEXT (QUOTE #1))) '] +(AND #2 #1) '* BLD!-EXPR / '* BLD!-EXPR>; % Create an sexpression to build a repetition. BLD!-EXPR: +(PROG (X) (SETQ X (STK!-LENGTH)) $1 (COND (#1 (GO $1))) (BUILD!-REPEAT X) (RETURN T)); ANYKEY: ANYTOK .(ADDKEY ##1) ; % Add a new KEY % One defines a single item. ONE: '' ANYKEY +(EQTOK!-NEXT (QUOTE #1)) / '@ ANYKEY .(ADDRTERM ##1) +(EQTOK (QUOTE #1)) / '@@ ANYKEY .(ADDGTERM ##1) +(EQTOK (QUOTE #1)) / '+ UNLBLD +(PUSH #1) / '. EVLBLD +(PROGN #1 T) / '= EVLBLD / '< ALT '> +(PROGN #1 T) / '( ALT ') / '+. EVLBLD +(PUSH #1) / ID +(#1) ; % This rule defines an un evaled list. It builds a list with everything % quoted. UNLBLD: '( UNLBLD ('. UNLBLD ') +(CONS #2 #1) / UNLBLD* ') +(LIST . (#2 . #1)) / ') +(LIST . #1)) / LBLD / ID +(QUOTE #1) ; % EVLBLD builds a list of evaled items. EVLBLD: '( EVLBLD ('. EVLBLD ') +(CONS #2 #1) / EVLBLD* ') +(#2 . #1) / ') ) / LBLD / ID ; LBLD: '# NUM +(EXTRACT #1) / '## NUM +(REF #1) / '$ NUM +(GENLAB #1) / '& NUM +(CADR (ASSOC #1 (CAR VARLIST))) / NUM / STR / '' ('( UNLBLD* ') +(LIST . #1) / ANYTOK +(QUOTE #1)); % Defines the pattern matching rules (PATTERN -> BODY). PRUL: .(SETQ INDEXLIST!* NIL) PAT '-> (EVLBLD)* +(LAMBDA (VARLIST T1 T2 T3) (AND . #1)) .(SETQ PNAM (GENSYM)) .(RULE!-DEFINE (LIST 'PUTD (LIST 'QUOTE PNAM) '(QUOTE EXPR) (LIST 'QUOTE #1))) +.(CONS #1 PNAM); % Defines a pattern. % We now allow the . operator to be the next to last in a (). PAT: '& ('< PSIMP[/]* '> NUM +.(PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #2 #1) ) / NUM +.(COND ((MEMQ ##1 INDEXLIST!*) (LIST '!& '!& #1)) (T (PROGN (SETQ INDEXLIST!* (CONS ##1 INDEXLIST!*)) (LIST '!& #1)))) ) / ID / '!( PAT* <'. PAT +.(APPEND #2 #1)> '!) / '' ANYTOK / STR / NUM ; % Defines the primitives in a pattern. PSIMP: ID / NUM / '( PSIMP* ') / '' ANYTOK; % The grammar terminator. FIN END; |
Added psl-1983/util/mini.sl version [15c3c91025].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NIL (DE RUL NIL (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0109 (COND ((OR (AND ( EQTOK!-NEXT (QUOTE DIP)) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !:)) (FAIL!-NOT ( AND (PROG (X) (SETQ X (STK!-LENGTH)) G0109 (COND ((AND (ANYTOK) (EQTOK!-NEXT ( QUOTE !,))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND ( PROGN (DIPBLD (EXTRACT 1)) T) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !;)))))))))) ( AND (ID) (FAIL!-NOT (AND (PROGN (SETQ !#LABLIST!# NIL) T) (FAIL!-NOT (AND ( OR (AND (EQTOK!-NEXT (QUOTE !:)) (FAIL!-NOT (AND (ALT) (FAIL!-NOT (AND (PUSH ( LIST (QUOTE DE) (EXTRACT 2) (QUOTE NIL) (EXTRACT 1))) (FAIL!-NOT (EQTOK ( QUOTE !;)))))))) (AND (EQTOK!-NEXT (QUOTE !=)) (FAIL!-NOT (AND (PROG (X) ( SETQ X (STK!-LENGTH)) G0109 (COND ((AND (PRUL) (EQTOK!-NEXT (QUOTE !,))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (EQTOK (QUOTE !;)) ( FAIL!-NOT (AND (PROGN (RULE!-DEFINE (LIST (QUOTE PUT) (LIST (QUOTE QUOTE) ( REF 2)) (LIST (QUOTE QUOTE) (QUOTE RB)) (LIST (QUOTE QUOTE) (EXTRACT 1)))) T) ( FAIL!-NOT (PUSH (LIST (QUOTE DE) (REF 1) (LIST (QUOTE A)) (LIST (QUOTE RBMATCH) (QUOTE A) (LIST (QUOTE GET) (LIST (QUOTE QUOTE) (EXTRACT 1)) (LIST ( QUOTE QUOTE) (QUOTE RB))) (QUOTE NIL))))))))))))) (FAIL!-NOT (AND (PROGN ( RULE!-DEFINE (EXTRACT 1)) T) (FAIL!-NOT (PROGN (NEXT!-TOK) T)))))))))) (GO G0109))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (EQTOK (QUOTE FIN))))) (DE ALT NIL (AND (SEQ) (FAIL!-NOT (PROGN (AND (EQTOK!-NEXT (QUOTE !/)) ( FAIL!-NOT (AND (ALT) (FAIL!-NOT (PUSH (LIST (QUOTE OR) (EXTRACT 2) (EXTRACT 1))))))) T)))) (DE SEQ NIL (AND (REP) (FAIL!-NOT (PROGN (AND (SEQ) (FAIL!-NOT (PUSH (LIST ( QUOTE AND) (EXTRACT 2) (LIST (QUOTE FAIL!-NOT) (EXTRACT 1)))))) T)))) (DE REP NIL (AND (ONE) (FAIL!-NOT (PROGN (OR (AND (EQTOK!-NEXT (QUOTE ![)) ( FAIL!-NOT (AND (OR (AND (ID) (FAIL!-NOT (PUSH (LIST (EXTRACT 1))))) (OR (AND ( EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (AND (ANYKEY) (FAIL!-NOT (PUSH (LIST ( QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (AND (ANYKEY) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !])) (FAIL!-NOT (AND (PUSH ( LIST (QUOTE AND) (EXTRACT 2) (EXTRACT 1))) (FAIL!-NOT (AND (EQTOK!-NEXT ( QUOTE !*)) (FAIL!-NOT (BLD!-EXPR))))))))))) (AND (EQTOK!-NEXT (QUOTE !*)) ( FAIL!-NOT (BLD!-EXPR)))) T)))) (DE BLD!-EXPR NIL (PUSH (LIST (QUOTE PROG) (LIST (QUOTE X)) (LIST (QUOTE SETQ) (QUOTE X) (LIST (QUOTE STK!-LENGTH))) (GENLAB 1) (LIST (QUOTE COND) ( LIST (EXTRACT 1) (LIST (QUOTE GO) (GENLAB 1)))) (LIST (QUOTE BUILD!-REPEAT) ( QUOTE X)) (LIST (QUOTE RETURN) (QUOTE T))))) (DE ANYKEY NIL (AND (ANYTOK) (FAIL!-NOT (PROGN (ADDKEY (REF 1)) T)))) (DE ONE NIL (OR (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (AND (ANYKEY) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK!-NEXT) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (OR (AND (EQTOK!-NEXT (QUOTE !@)) (FAIL!-NOT (AND (ANYKEY) ( FAIL!-NOT (AND (PROGN (ADDRTERM (REF 1)) T) (FAIL!-NOT (PUSH (LIST (QUOTE EQTOK) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))))) (OR (AND (EQTOK!-NEXT (QUOTE !@!@)) (FAIL!-NOT (AND (ANYKEY) (FAIL!-NOT (AND (PROGN (ADDGTERM (REF 1)) T) ( FAIL!-NOT (PUSH (LIST (QUOTE EQTOK) (LIST (QUOTE QUOTE) (EXTRACT 1)))))))))) ( OR (AND (EQTOK!-NEXT (QUOTE !+)) (FAIL!-NOT (AND (UNLBLD) (FAIL!-NOT (PUSH ( LIST (QUOTE PUSH) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT (QUOTE !.)) ( FAIL!-NOT (AND (EVLBLD) (FAIL!-NOT (PUSH (LIST (QUOTE PROGN) (EXTRACT 1) ( QUOTE T))))))) (OR (AND (EQTOK!-NEXT (QUOTE !=)) (FAIL!-NOT (EVLBLD))) (OR ( AND (EQTOK!-NEXT (QUOTE !<)) (FAIL!-NOT (AND (ALT) (FAIL!-NOT (AND ( EQTOK!-NEXT (QUOTE !>)) (FAIL!-NOT (PUSH (LIST (QUOTE PROGN) (EXTRACT 1) ( QUOTE T))))))))) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (ALT) ( FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))) (OR (AND (EQTOK!-NEXT (QUOTE !+!.)) ( FAIL!-NOT (AND (EVLBLD) (FAIL!-NOT (PUSH (LIST (QUOTE PUSH) (EXTRACT 1))))))) ( AND (ID) (FAIL!-NOT (PUSH (LIST (EXTRACT 1))))))))))))))) (DE UNLBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (UNLBLD) ( FAIL!-NOT (OR (AND (EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (UNLBLD) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (LIST (QUOTE CONS) ( EXTRACT 2) (EXTRACT 1))))))))) (OR (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0110 (COND ((UNLBLD) (GO G0110))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT ( AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (QUOTE LIST) (CONS ( EXTRACT 2) (EXTRACT 1)))))))) (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH ( CONS (QUOTE LIST) (EXTRACT 1))))))))))) (OR (LBLD) (AND (ID) (FAIL!-NOT ( PUSH (LIST (QUOTE QUOTE) (EXTRACT 1)))))))) (DE EVLBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (EVLBLD) ( FAIL!-NOT (OR (AND (EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (EVLBLD) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (LIST (QUOTE CONS) ( EXTRACT 2) (EXTRACT 1))))))))) (OR (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0111 (COND ((EVLBLD) (GO G0111))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT ( AND (EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (EXTRACT 2) (EXTRACT 1))))))) (EQTOK!-NEXT (QUOTE !))))))))) (OR (LBLD) (ID)))) (DE LBLD NIL (OR (AND (EQTOK!-NEXT (QUOTE !#)) (FAIL!-NOT (AND (NUM) ( FAIL!-NOT (PUSH (LIST (QUOTE EXTRACT) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT ( QUOTE !#!#)) (FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (LIST (QUOTE REF) ( EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT (QUOTE !$)) (FAIL!-NOT (AND (NUM) ( FAIL!-NOT (PUSH (LIST (QUOTE GENLAB) (EXTRACT 1))))))) (OR (AND (EQTOK!-NEXT ( QUOTE !&)) (FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (LIST (QUOTE CADR) (LIST ( QUOTE ASSOC) (EXTRACT 1) (LIST (QUOTE CAR) (QUOTE VARLIST))))))))) (OR (NUM) ( OR (STR) (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (OR (AND (EQTOK!-NEXT ( QUOTE !()) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0112 (COND (( UNLBLD) (GO G0112))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND ( EQTOK!-NEXT (QUOTE !))) (FAIL!-NOT (PUSH (CONS (QUOTE LIST) (EXTRACT 1))))))))) (AND (ANYTOK) (FAIL!-NOT (PUSH (LIST (QUOTE QUOTE) (EXTRACT 1))))))))))))))) (DE PRUL NIL (AND (PROGN (SETQ INDEXLIST!* NIL) T) (FAIL!-NOT (AND (PAT) ( FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !-!>)) (FAIL!-NOT (AND (PROG (X) (SETQ X ( STK!-LENGTH)) G0113 (COND ((EVLBLD) (GO G0113))) (BUILD!-REPEAT X) (RETURN T)) ( FAIL!-NOT (AND (PUSH (LIST (QUOTE LAMBDA) (LIST (QUOTE VARLIST) (QUOTE T1) ( QUOTE T2) (QUOTE T3)) (CONS (QUOTE AND) (EXTRACT 1)))) (FAIL!-NOT (AND ( PROGN (SETQ PNAM (GENSYM)) T) (FAIL!-NOT (AND (PROGN (RULE!-DEFINE (LIST ( QUOTE PUTD) (LIST (QUOTE QUOTE) PNAM) (LIST (QUOTE QUOTE) (QUOTE EXPR)) ( LIST (QUOTE QUOTE) (EXTRACT 1)))) T) (FAIL!-NOT (PUSH (CONS (EXTRACT 1) PNAM)))) ))))))))))))) (DE PAT NIL (OR (AND (EQTOK!-NEXT (QUOTE !&)) (FAIL!-NOT (OR (AND ( EQTOK!-NEXT (QUOTE !<)) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0114 (COND ((AND (PSIMP) (EQTOK!-NEXT (QUOTE !/))) (GO G0114))) ( BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (EQTOK!-NEXT (QUOTE !>)) ( FAIL!-NOT (AND (NUM) (FAIL!-NOT (PUSH (PROGN (SETQ INDEXLIST!* (CONS (REF 1) INDEXLIST!*)) (LIST (QUOTE !&) (EXTRACT 2) (EXTRACT 1)))))))))))) (AND ( NUM) (FAIL!-NOT (PUSH (COND ((MEMQ (REF 1) INDEXLIST!*) (LIST (QUOTE !&) ( QUOTE !&) (EXTRACT 1))) (T (PROGN (SETQ INDEXLIST!* (CONS (REF 1) INDEXLIST!*)) (LIST (QUOTE !&) (EXTRACT 1))))))))))) (OR (ID) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT (AND (PROG (X) (SETQ X (STK!-LENGTH)) G0114 (COND ((PAT) (GO G0114))) (BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (AND (PROGN (AND ( EQTOK!-NEXT (QUOTE !.)) (FAIL!-NOT (AND (PAT) (FAIL!-NOT (PUSH (APPEND ( EXTRACT 2) (EXTRACT 1))))))) T) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))))) ( OR (AND (EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (ANYTOK))) (OR (STR) (NUM))))))) (DE PSIMP NIL (OR (ID) (OR (NUM) (OR (AND (EQTOK!-NEXT (QUOTE !()) (FAIL!-NOT ( AND (PROG (X) (SETQ X (STK!-LENGTH)) G0115 (COND ((PSIMP) (GO G0115))) ( BUILD!-REPEAT X) (RETURN T)) (FAIL!-NOT (EQTOK!-NEXT (QUOTE !))))))) (AND ( EQTOK!-NEXT (QUOTE !')) (FAIL!-NOT (ANYTOK))))))) (PUT (QUOTE RUL) (QUOTE KEYS) (QUOTE (!-!> !& !$ !#!# !# !+!. !) !( !> !< !. !+ !@!@ !@ !* !] !' ![ !/ FIN != !; !, !: DIP))) (PUT (QUOTE RUL) (QUOTE DIPS) (QUOTE (!@!@ !+!. !-!> !#!#))) (PUT (QUOTE RUL) (QUOTE RTS) (QUOTE (!;))) (PUT (QUOTE RUL) (QUOTE GTS) (QUOTE (FIN))) NIL NIL |
Added psl-1983/util/misc-macros.sl version [d4cc40e130].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % MISC-MACROS.SL - assorted useful macros % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah (defmacro funcall u `(apply ,(car u) (list ,@(cdr u)))) (copyd 'call 'funcall) (defmacro eqfirst (u v) `(eqcar ,u ,v)) (defmacro bldid (s . args) `(intern (bldmsg ,s ,@args))) (defmacro nary-concat u (expand u 'concat)) (defmacro-no-displace defstub (name . rst) % quick, kludgy hack -- should be much better (let ((args (if (pairp rst) (pop rst)))) `(de ,name ,args (stub-print ',name ',args (list ,@args)) ,@rst (let ((*ContinuableError t)) (break))))) (de stub-print (name arg-names actual-args) (errorprintf "Stub %w called with arguments:" name) (for (in u arg-names) (in v actual-args) (do (errorprintf " %w: %p%n" u v))) (terpri)) (defmacro circular-list L `(let ((***CIRCULAR-LIST-ARG*** (list ,@L))) (nconc ***CIRCULAR-LIST-ARG*** ***CIRCULAR-LIST-ARG***))) (defmacro nothing U nil) % Nary no-op returning nil; args not evaluated. (defmacro make-list (N . rst) `(make-list-1 ,N ,(if (pairp rst) (car rst) nil))) (de make-list-1 (N init) (for (from i 1 N) (collect init))) |
Added psl-1983/util/narith.build version [cebe4aae5a].
> > > > | 1 2 3 4 | % NARITH.BUILD - Changes built-in arith to include BIGNUM hooks %/ Should later install as basic BIGNUM package in "narith.red"$ |
Added psl-1983/util/narith.red version [9028a22a9d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Generic arithmetic routines for PSL % New model, much less hairy lap % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 August 1982 % Copyright (c) 1982 University of Utah %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Note: Loading BIGFACE is supposed to define (or redefine) % the functions: % ISINUM % StaticIntBig % StaticBigFloat % Sys2Int % Int2Sys % FloatFix % % Mods by MLG, 21 dec 1982 % Take off INTERNALFUNCTION form FLOATFIX and StaticFloatBig % Change IsInum to be a procedure % Change names of FAKE and SFL to xxxxLOC CompileTime << % Some aliases Fluid '(ArithArgLoc StaticFloatLoc); put('ArithArg, 'NewNam, '(LispVar ArithArgLoc)); put('StaticFloat, 'NewNam, '(LispVar StaticFloatLoc)); >>; LoadTime << % Allocate Physical Space ArithArgLoc := GtWArray 2; StaticFloatLoc := GtWArray 3; >>; on Syslisp; %internal WArray ArithArg[1], StaticFloat = [1, 0, 0]; CompileTime << flag('(Coerce2 FloatPlus2 FloatDifference FloatTimes2 FloatQuotient FloatGreaterP FloatLessP IntFloat NonInteger2Error NonNumber1Error ), 'InternalFunction); syslsp macro procedure IsInumMac U; << U := second U; if atom U then list('eq, list('SignedField, U, '(ISub1 (WConst InfStartingBit)), '(IAdd1 (WConst InfBitLength))), U) else list('(lambda (X) (eq (SignedField X (ISub1 (WConst InfStartingBit)) (IAdd1 (WConst InfBitLength))) X)), U) >>; expr procedure NameGen Name; Intern Concat(ID2String Name, StringGensym()); macro procedure DefArith2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y); expr procedure GEN0(x, y, z); if isinum z then z else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArithPred2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then WGEN(x, y) else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefInt2Entry U; begin scalar generic, wgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN BGEN HARDGEN GEN0), list(generic, wgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC(x,y); if intp x and intp y then GEN0(x, y, WGEN(x, y)) else HARDGEN(x, y); expr procedure GEN0(x, y, z); if isinum z then z else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: NonInteger2Error(x, y, 'GENERIC); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArith1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC x; if intp x then GEN0(x, WGEN x) else HARDGEN x; expr procedure GEN0(x, z); if isinum z then z else HARDGEN x; expr procedure HARDGEN x; case Tag x of NEGINT, POSINT: Sys2Int WGEN x; FIXN: Sys2Int WGEN FixVal FixInf x; FLTN: FGEN x; BIGN: BGEN x; default: NonNumber1Error(x, 'GENERIC); end; >>); end; macro procedure DefArithPred1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen, gen0; U :=rest U; generic := first U; U := rest U; wgen := first U; U := rest U; fgen := first U; U := rest U; bgen := first U; hardgen := NameGen generic; gen0 := NameGen generic; Flag1(hardgen, 'InternalFunction); Flag1(gen0, 'InternalFunction); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN GEN0), list(generic, wgen, fgen, bgen, hardgen, gen0)), quote << expr procedure GENERIC x; if intp x then WGEN x else HARDGEN x; expr procedure HARDGEN x; case Tag x of NEGINT, POSINT: WGEN x; FIXN: WGEN FixVal FixInf x; FLTN: FGEN x; BIGN: BGEN x; default: NIL; end; >>); end; smacro procedure DefFloatEntry(Name, Prim); procedure Name(x, y); begin scalar f; f := GtFLTN(); Prim(FloatBase f, FloatBase FltInf x, FloatBase FltInf y); return MkFLTN f; end; >>; procedure Coerce2(X, Y, F); % % Returns type tag of strongest type and sets ArithArg[0] to be coerced X % and ArithArg[1] to coerced Y. % begin scalar T1, T2, P, C; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; T2 := Tag Y; case T2 of NEGINT: T2 := POSINT; FIXN: << T2 := POSINT; Y := FixVal FixInf Y >>; end; ArithArg[0] := X; ArithArg[1] := Y; if T1 eq T2 then return T1; % no coercion to be done if T1 < T2 then % coerce first arg to second << P := &ArithArg[0]; % P points to first (to be coerced) C := T2; % swap T1 and T2 T2 := T1; T1 := C >> else P := &ArithArg[1]; % P points to second if T1 > FLTN then return ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X, MkQuote Y)); case T1 of FLTN: case T2 of POSINT: @P := StaticIntFloat @P; BIGN: @P := StaticBigFloat @P; end; BIGN: @P := StaticIntBig @P; % @P must be inum end; return T1; end; procedure StaticIntFloat X; << !*WFloat(&StaticFloat[1], X); MkFLTN &StaticFloat[0] >>; procedure NonInteger2Error(X, Y, F); ContinuableError(99, "Non-integer argument in arithmetic", list(F, MkQuote X, MkQuote Y)); procedure NonNumber1Error(X, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X)); DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2); DefFloatEntry(FloatPlus2, !*FPlus2); DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference); DefFloatEntry(FloatDifference, !*FDifference); DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2); DefFloatEntry(FloatTimes2, !*FTimes2); DefArith2Entry(Quotient, WQuotient, FloatQuotient, BigQuotient); DefFloatEntry(FloatQuotient, !*FQuotient); DefArithPred2Entry(GreaterP, WGreaterP, FloatGreaterP, BigGreaterP); procedure FloatGreaterP(X, Y); if !*FGreaterP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefArithPred2Entry(LessP, WLessP, FloatLessP, BigLessP); procedure FloatLessP(X, Y); if !*FLessP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefInt2Entry(Remainder, WRemainder, BigRemainder); DefInt2Entry(LAnd, WAnd, BigLAnd); DefInt2Entry(LOr, WOr, BigLOr); DefInt2Entry(LXOr, WXOr, BigLXOr); DefInt2Entry(LShift, WShift, BigLShift); PutD('LSH, 'EXPR, cdr GetD 'LShift); DefArith1Entry(Add1, IAdd1, lambda X; FloatPlus2(X, '1.0), BigAdd1); DefArith1Entry(Sub1, ISub1, lambda X; FloatDifference(X, '1.0), BigSub1); DefArith1Entry(Minus, IMinus, lambda X; FloatDifference('0.0, X), BigMinus); DefArith1Entry(Fix, lambda X; X, FloatFix, lambda X; X); procedure FloatFix X; Sys2Int !*WFix FloatBase FltInf X; procedure Float X; case Tag X of POSINT, NEGINT: IntFloat X; FIXN: IntFloat FixVal FixInf X; FLTN: X; BIGN: FloatBigArg X; default: NonNumber1Error(X, 'Float); end; procedure IntFloat X; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, X); return MkFLTN F; end; DefArithPred1Entry(MinusP, IMinusP, lambda X; FloatLessP(X, '0.0), BigMinusP); DefArithPred1Entry(ZeroP, IZeroP, lambda X; EQN(X, '0.0), ReturnNil); DefArithPred1Entry(OneP, IOneP, lambda X; EQN(X, '1.0), ReturnNil); syslsp procedure ReturnNil U; NIL; syslsp procedure IsInum U; IsInumMac U; off Syslisp; END; |
Added psl-1983/util/nbarith.build version [0630aaaa9e].
> > > > | 1 2 3 4 | % NARITH.BUILD - Changes built-in arith to include BIGNUM hooks %/ Should later install as basic BIGNUM package in "nbarith.red"$ |
Added psl-1983/util/nbarith.red version [30832500cb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBARITH.RED - Generic arithmetic routines for PSL % New model, much less hairy lap % Author: Eric Benson and Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 9 August 1982 % Copyright (c) 1982 University of Utah %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The MODEL: % It is assumed that there is a range of INUMs (subset) called % BETAnums that can be safely operated on by the Wxxx or Ixxx routines % without loss of precesion or overflow, and return an INUM (or at least % a SYSINT. % % A UNARY operation (UN x) is done as: % Procedure UN x; % If BetaP x then <<x:=WUN x; if IntRangeP x then x else Sys2Int x>> % else UN!-HARD(x); % A UNARY predicate (UNP x) is done as: % Procedure UNP x; % If BetaP x then WUNP x % else UNP!-HARD(x); % A BINARY operation (BIN x y) is done as: % Procedure BIN(x,y); % If BetaP x and BetaP y % then <<x:=WBIN(x,y); % if IntRangeP x then x else Sys2Int x>> % else BIN!-HARD(x,y); % A BINARY predicate (BINP x y) is done as: % Procedure BINP(x,y); % If BetaP x and BetaP y then WBINP(x,y) % else BINP!-HARD(x,y); % IN some "safe" cases, BetaP can become IntP (beware of *) % In others, BetaP(y) may be too weak (eg, Lshift and Expt) % Note: Loading NBIG0 is supposed to define (or redefine) % the functions: % BetaP % Beta2P % BetaRangeP % Sys2Big % FloatFromBignum % Sys2Int % FloatFix % Removed IsInum and INTP in favor of BetaP % % Mods by MLG, 21 dec 1982 % Take off INTERNALFUNCTION form FLOATxxx % Change names of FAKE and SFL to xxxxLOC CompileTime << % Some aliases Fluid '(ArithArgLoc StaticFloatLoc); put('ArithArg, 'NewNam, '(LispVar ArithArgLoc)); put('StaticFloat, 'NewNam, '(LispVar StaticFloatLoc)); >>; LoadTime << % Allocate Physical Space ArithArgLoc := GtWArray 2; StaticFloatLoc := GtWArray 3; >>; expr procedure BetaP x; % Test tagged number is in Beta Range when BIGNUM loaded % Will redefine if NBIG loaded IntP x; expr procedure BetaRangeP w; % Test Word is in Beta Range when BIGNUM loaded % Ie, is FIXNUM size with no NBIG % Will redefine if NBIG loaded 'T; expr procedure Beta2P(x,y); % Test if BOTH in Beta range % Will be redefined if NBIG loaded if IntP x then Intp y else NIL; expr procedure Sys2Big W; % Out of safe range, convert to BIGN ContinuableError(99, "Sys2Big cant convert Word to BIGNUM, no BIGNUM's loaded", Sys2Int W); on Syslisp; CompileTime << %flag('(Coerce2 FloatPlus2 FloatDifference FloatTimes2 % FloatQuotient FloatGreaterP FloatLessP IntFloat % NonInteger2Error NonNumber1Error NonNumber2Error %), 'NotYetInternalFunction); expr procedure NameGen(Name,Part); % Generate Nice specific name from Generic name Intern Concat(ID2String Name,ID2String Part); smacro procedure NextArg(); % Just substitute in the context of U <<U:=cdr U; car U>>; smacro procedure Prologue(); % Common Prologue << generic := NextArg(); wgen := NextArg(); fgen := NextArg(); bgen := NextArg(); hardgen := NameGen(generic,'!-Hardcase); Flag1(hardgen, 'NotYetInternalFunction); >>; macro procedure DefArith2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then <<x:=WGEN(x,y); If IntP x then x else Sys2Int x>> else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); %/ Beware of Overflow, WGEN maybe should test args %/ Coerce2 is supposed to check this case FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArithPred2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then WGEN(x, y) else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); %/ Assumes Preds are safe against Overflow FLTN: FGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefInt2Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN BGEN HARDGEN), list(generic, wgen, bgen, hardgen)), quote << expr procedure GENERIC(x,y); if Beta2P(x,y) then <<x:=WGEN(x, y); if IntP x then x else Sys2Int x>> else HARDGEN(x, y); expr procedure HARDGEN(x, y); case Coerce2(x, y, 'GENERIC) of POSINT: Sys2Int WGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); FLTN: NonInteger2Error(x, y, 'GENERIC); BIGN: BGEN(WGetV(ArithArg, 0), WGetV(ArithArg, 1)); end; >>); end; macro procedure DefArith1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC x; if BetaP x then <<x:=WGEN x; if IntP x then x else Sys2Int x>> else HARDGEN x; expr procedure HARDGEN x; case Coerce1(x,'GENERIC) of POSINT: Sys2Int WGEN WGetv(ArithArg,0); FLTN: FGEN WGetv(ArithArg,0); BIGN: BGEN WGetv(ArithArg,0); default: NonNumber1Error(x,'GENERIC); end; >>); end; macro procedure DefArithPred1Entry U; begin scalar generic, wgen, fgen, bgen, hardgen; Prologue(); return SublA(Pair('(GENERIC WGEN FGEN BGEN HARDGEN), list(generic, wgen, fgen, bgen, hardgen)), quote << expr procedure GENERIC x; if BetaP x then WGEN x else HARDGEN x; expr procedure HARDGEN x; case Coerce1(x,'GENERIC) of POSINT: WGEN Wgetv(ArithArg,0); FLTN: FGEN Wgetv(ArithArg,0); BIGN: BGEN Wgetv(ArithArg,0); default: NIL; end; >>); end; smacro procedure DefFloatEntry(Name, Prim); procedure Name(x, y); begin scalar f; f := GtFLTN(); Prim(FloatBase f, FloatBase FltInf x, FloatBase FltInf y); return MkFLTN f; end; >>; % The support procedures for coercing types procedure Coerce1(X, F); % Returns type tag of coerced X type and sets ArithArg[0] to be coerced X % Beware of ADD1/SUB1 cases, maybe can optimize later begin scalar T1; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>; WPutv(ArithArg,0,X); return T1; end; procedure Coerce2(X, Y, F); % Returns type tag of strongest type and sets ArithArg[0] to be coerced X % and ArithArg[1] to coerced Y. begin scalar T1, T2, P, C; T1 := Tag X; case T1 of NEGINT: T1 := POSINT; FIXN: << T1 := POSINT; X := FixVal FixInf X >>; end; If T1=POSINT and not BetaRangeP(x) then <<T1:=BIGN; x:=Sys2Big x>>; T2 := Tag Y; case T2 of NEGINT: T2 := POSINT; FIXN: << T2 := POSINT; Y := FixVal FixInf Y >>; end; If T2=POSINT and not BetaRangeP(Y) then <<T2:=BIGN; y:=Sys2Big y>>; ArithArg[0] := X; ArithArg[1] := Y; if T1 eq T2 then return T1; % no coercion to be done if T1 < T2 then % coerce first arg to second << P := &ArithArg[0]; % P points to first (to be coerced) C := T2; % swap T1 and T2 T2 := T1; T1 := C >> else P := &ArithArg[1]; % P points to second if T1 > FLTN then return NonNumber2Error(X,Y,F); % Here, since no 2 arg Arith Preds that accept 1 number, one not case T1 of FLTN: case T2 of POSINT: @P := StaticIntFloat @P; BIGN: @P := FloatFromBignum @P; end; BIGN: @P := Sys2Big @P; % @P must be SYSint end; return T1; end; procedure StaticIntFloat X; << !*WFloat(&StaticFloat[1], X); MkFLTN &StaticFloat[0] >>; procedure NonInteger2Error(X, Y, F); ContinuableError(99, "Non-integer argument in arithmetic", list(F, MkQuote X, MkQuote Y)); procedure NonNumber1Error(X, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X)); procedure NonNumber2Error(X, Y, F); ContinuableError(99, "Non-numeric argument in arithmetic", list(F, MkQuote X,Mkquote Y)); % Now generate the entries for each operator DefArith2Entry(Plus2, WPlus2, FloatPlus2, BigPlus2); DefFloatEntry(FloatPlus2, !*FPlus2); DefArith2Entry(Difference, WDifference, FloatDifference, BigDifference); DefFloatEntry(FloatDifference, !*FDifference); DefArith2Entry(Times2, WTimes2, FloatTimes2, BigTimes2); % Beware of Overflow DefFloatEntry(FloatTimes2, !*FTimes2); DefArith2Entry(Quotient, WQuotient, FloatQuotient, BigQuotient); DefFloatEntry(FloatQuotient, !*FQuotient); DefArithPred2Entry(GreaterP, WGreaterP, FloatGreaterP, BigGreaterP); procedure FloatGreaterP(X, Y); if !*FGreaterP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; DefArithPred2Entry(LessP, WLessP, FloatLessP, BigLessP); procedure FloatLessP(X, Y); if !*FLessP(FloatBase FltInf X, FloatBase FltInf Y) then T else NIL; procedure Fdummy(x,y); StdError "Fdummy should never be called"; DefInt2Entry(Remainder, WRemainder, Fdummy, BigRemainder); DefInt2Entry(LAnd, WAnd, Fdummy, BigLAnd); DefInt2Entry(LOr, WOr, Fdummy, BigLOr); DefInt2Entry(LXOr, WXOr, Fdummy, BigLXOr); % Cant DO Lshift in terms of BETA sized shifts % Will toatlly redefine in BIG package DefInt2Entry(LShift, WShift, BigLShift); PutD('LSH, 'EXPR, cdr GetD 'LShift); DefArith1Entry(Add1, IAdd1, lambda X; FloatPlus2(X, '1.0), BigAdd1); DefArith1Entry(Sub1, ISub1, lambda X; FloatDifference(X, '1.0), BigSub1); DefArith1Entry(Minus, IMinus, lambda X; FloatDifference('0.0, X), BigMinus); DefArith1Entry(Fix, lambda X; X, FloatFix, lambda X; X); procedure FloatFix X; Sys2Int !*WFix FloatBase FltInf X; procedure Float X; case Tag X of POSINT, NEGINT: IntFloat X; FIXN: IntFloat FixVal FixInf X; FLTN: X; BIGN: FloatFromBigNum X; default: NonNumber1Error(X, 'Float); end; procedure IntFloat X; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, X); return MkFLTN F; end; DefArithPred1Entry(MinusP, IMinusP, lambda X; FloatLessP(X, '0.0), BigMinusP); DefArithPred1Entry(ZeroP, IZeroP, lambda X; EQN(X, '0.0), ReturnNil); DefArithPred1Entry(OneP, IOneP, lambda X; EQN(X, '1.0), ReturnNil); syslsp procedure ReturnNil U; NIL; off Syslisp; END; |
Added psl-1983/util/nbig0.build version [4de290d1e9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBIG0.BUILD - MLG, move BUILD info, add MC68000 case Compiletime<<load syslisp; Load Fast!-Vector; load inum; load if!-system>>; in "nbig0.red"$ % Now install the important globals for this machine if_system(VAX, << BigFloatHi!*:=btimes2(bdifference(btwopower 67, btwopower 11), btwopower 60);% Largest representable float. BigFloatLow!*:=BMinus BigFloatHi!*>>); if_system(MC68000, <<Setbits 30$ %/ Some BUG? % HP9836 sizes, range 10^-308 .. 10 ^308 % i GUESS: % 10^308 = 2 ^1025 % 15.8 digits, IEEE double ~56 bits BigFloatHi!*:=btimes2(BSUB1 BTWOPOWER 56, btwopower 961);% Largest representable float. BigFloatLow!*:=BMinus BigFloatHi!*>>); if_system(PDP10, << BigFloatHi!*:=btimes2(bsub1 btwopower 62, btwopower 65); BigFloatLow!*:=BMinus BigFloatHi!*>>); FloatSysHi!* := Float SysHi!*; FloatSysLow!* := Float SysLow!*; END; |
Added psl-1983/util/nbig0.red version [56622c7244].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % NBIG0.RED - Vector based BIGNUM package with INUM operations % M. L. Griss & B Morrison, 25 June 1982. % Copyright (C) 1982, A. C. Norman, B. Morrison, M. Griss % % Revision log: % 7 February 1983, MLG % Merged in NBIG1 (see its "revision history" below), plus clean-up. % Revision History of old NBIG1: % 28 Dec 1982, MLG: % Added BigZeroP and BigOneP for NArith % Changed Name to NBIG1.RED from BIGFACE % 22 Dec 1982, MLG: % Change way of converting from VECT to BIGN % Move Module dependency to .BUILD file % Changes for NEW-ARITH, involve name changes for MAKEFIXNUM % ISINUM, etc. % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman % Use the BIGN tag for better Interface % % 31 Dec 1982, MLG % Changed BNUM to check if arg ALREADY Big. Kludge % since new NARITH makes some things BIG earlier % since it calls the BIG funcs directly % 20 Dec 1982, MLG % Changed TrimBigNUM to TrimBigNum1 in BhardDivide % % 14 Dec 1982, MLG % Changed to put LOAD and IMPORTS in BUILD file % % 31 August 1982, A. C . Norman % Adjustments to many routines: in particular corrections to BHardDivide % (case D6 utterly wrong), and adjustments to BExpt (for performance) and % all logical operators (for treatment of negative inputs); % --------------------------------------------------------------- % ----------------------- % A bignum will be a VECTOR of Bigits: (digits in base BigBase): % [BIGPOS b1 ... bn] or [BIGNEG b1 ... bn]. BigZero is thus [BIGPOS] % All numbers are positive, with BIGNEG as 0 element to indicate negatives. % BETA.RED - some values of BETA testing % On DEC-20, Important Ranges are: % -------------------------------- % POSBETA | 0 | n | % -------------------------------- % 19 17 bits % -------------------------------- % NEGBETA | -1 | | % -------------------------------- % % -------------------------------- % POSINT | 0 | 0 | | % -------------------------------- % 5 13 18 bits % -------------------------------- % NEGINT | -1 | -1 | | % -------------------------------- % Thus BETA: 2^17-1 -131072 ... 131071 % INT 2^18-1 -262144 ... 262143 % FIX 2^35-1 -34359738368 ... 34359738367 % [Note that one bit used for sign in 36 bit word] fluid '(BigBetaHi!* % Largest BetaNum in BIG format BigBetaLow!* % Smallest BetaNum in BIG format BetaHi!* % Largest BetaNum as Inum BetaLow!* % Smallest BetaNum as Inum SysHi!* % Largest SYSINT in FixN format SysLow!* % Smallest SYSINT in FixN format BigSysHi!* % Largest SYSINT in BIG format BigSysLow!* % Smallest SYSINT in BIG format FloatSysHi!* % Largest SYSINT in Float format FloatSysLow!* % Smallest SYSINT in Float format BBase!* % BETA, base of system FloatBbase!* % As a float BigFloatHi!* % Largest Float in BIG format BigFloatLow!* % Smallest Float in BIG format StaticBig!* % Warray for conversion of SYS to BIG Bone!* % A one Bzero!* % A zero BBits!* % Number of Bits in BBASE!* LogicalBits!* Digit2Letter!* Carry!* OutputBase!* ); % -------------------------------------------------------------------------- % -------------------------------------------------------------------------- % Support functions: % % U, V, V1, V2 for arguments are Bignums. Other arguments are usually % fix/i-nums. smacro procedure PutBig(b,i,val); % Access elements of a BIGNUM IputV(b,i,val); smacro procedure GetBig(b,i); % Access elements of a BIGNUM IgetV(B,i); procedure setbits x; % % This function sets the globals for big bignum package. % "x" should be total # of bits per word. Begin scalar y; BBits!*:=iquotient(isub1 x,2); % Total number of bits per word used. BBase!*:=TwoPower BBits!*; % "Beta", where n=A0 + A1*beta + A2*(beta^2). FloatBbase!* := IntFloat Bbase!*; LogicalBits!*:=ISub1 BBase!*; % Used in LAnd,Lor, etc. BetaHi!*:=isub1 Bbase!*; BetaLow!* :=Iminus Bbase!*; Bone!* := Bnum 1; Bzero!* := Bnum 0; BigBetaHi!*:=BNum BetaHi!*; % Highest value of Ai BigBetaLow!*:=BMinus BigBetaHi!*; % Lowest value of Ai % here assume 2's complement y:=TwoPower idifference (x,2); % eg, 36 bits, 2^35-1=2^34+2^34-1 SysHi!* :=y+(y-1); y:=-y; Syslow!* :=y+y; BigSysHi!*:=bdifference(btwopower isub1 x, Bone!*); % Largest representable Syslisp integer. % Note that SYSPOS has leading 0, ie only x-1 active bits BigSysLow!*:=BMinus BPlus2(Bone!*, BigSysHi!*); % Smallest representable Syslisp integer. end; procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); procedure BSize V; % Upper Limit of [BIGxxx a1 ... An] If BigP V then VecLen VecInf V else 0; procedure GtPOS N; % Allocate [BIGPOS a1 ... an] Begin N:=MkVect N; IPutV(N,0,'BIGPOS); Return MkBigN Vecinf N; End; procedure GtNeg N; % Allocate [BIGNEG a1 ... an] Begin N:=MkVect N; IPutV(N,0,'BIGNEG); Return MkBigN VecInf N; End; procedure TrimBigNum V3; % truncate trailing 0 If Not BigP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; procedure BigAsVec B; % In order to see BIGITS MkVec Inf B; procedure VecAsBig V; MkBigN VecInf V; Procedure BIG2Sys U; % Convert a BIG to SYS, if in range If Blessp(U,BigSysLow!*) or Bgreaterp(U,BigSysHi!*) then ContinuableError(99,"BIGNUM too large to convert to SYS", U) else Big2SysAux U; procedure Big2SysAux U; % Convert a BIGN that is in range to a SYSINT begin scalar L,Sn,res; L:=BSize U; if IZeroP L then return 0; res:=IGetV(U,L); L:=ISub1 L; If BMinusP U then <<res:=-res; while L neq 0 do <<res:=ITimes2(res, Bbase!*); res:=IDifference(res, IGetV(U,L)); L:=ISub1 L>>; >> else while L neq 0 do <<res:=ITimes2(res, Bbase!*); res:=IPlus2(res, IGetV(U,L)); L:=ISub1 L>>; return Res; end; procedure TwoPower N; %fix/i-num 2**n Lsh(1,n); procedure BTwoPower N; % gives 2**n; n is fix/i-num; result BigNum if not (fixp N or BigP N) then NonIntegerError(N, 'BTwoPower) else begin scalar quot, rem, V; if BigP N then n:=big2sys n; quot:=Quotient(N,Bbits!*); rem:=Remainder(N,Bbits!*); V:=GtPOS(IAdd1 quot); IFor i:=1:quot do IPutV(v,i,0); IPutV(V,IAdd1 quot,twopower rem); return TrimBigNum1(V,IAdd1 quot); end; procedure BZeroP V1; IZerop BSize V1 and not BMinusP V1; procedure BOneP V1; Not BMinusP V1 and IOneP (BSize V1) and IOneP IGetV(V1,1); procedure BAbs V1; if BMinusP V1 then BMinus V1 else V1; procedure BMax(V1,V2); if BGreaterP(V2,V1) then V2 else V1; procedure BMin(V1,V2); if BLessP(V2,V1) then V2 else V1; procedure BExpt(V1,N); % V1 is Bignum, N is fix/i-num if not fixp N then NonIntegerError(N,'BEXPT) else if IZeroP N then Bone!* else if IOneP N then V1 else if IMinusP N then BQuotient(Bone!*,BExpt(V1,IMinus N)) else begin scalar V2; V2 := BExpt(V1,IQuotient(N,2)); if IZeroP IRemainder(N,2) then return BTimes2(V2,V2) else return BTimes2(BTimes2(V2,V1),V2) end; % --------------------------------------- % Logical Operations % % All take Bignum arguments procedure BLOr(V1,V2); % The main body of the OR code is only obeyed when both arguments % are positive, and so the result will be positive; if BMinusp V1 or BMinusp V2 then BLnot BLand(BLnot V1,BLnot V2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); Return V3 end; procedure BLXor(V1,V2); % negative arguments are coped with using the identity % LXor(a,b) = LNot LXor(Lnot a,b) = LNor LXor(a,Lnot b); begin scalar L1,L2,L3,V3,S; if BMinusp V1 then << V1 := BLnot V1; S := t >>; if BMinusp V2 then << V2 := BLnot V2; S := not S >>; L1:=BSize V1; L2:=BSize V2; IF L2>L1 then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; V3:=GtPOS L1; IFor I:=1:L2 do IPutV(V3,I,ILXor(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,I)); V1:=TrimBigNum1(V3,L1); if S then V1:=BLnot V1; return V1 end; % Not Used Currently: % % procedure BLDiff(V1,V2); % ***** STILL NEEDS ADJUSTING WRT -VE ARGS ***** % begin scalar V3,L1,L2; % L1:=BSize V1; % L2:=BSize V2; % V3:=GtPOS(max(L1,L2)); % IFor i:=1:min(L1,L2) do % IPutV(V3,i,ILAnd(IGetV(V1,i),ILXor(LogicalBits!*,IGetV(V2,i)))); % if IGreaterP(L1,L2) then IFor i:=(IAdd1 L2):L1 do IPutV(V3,i,IGetV(V1,i)); % if IGreaterP(L2,L1) then IFor i:=(IAdd1 L1):L2 do IPutV(V3,i,0); % return TrimBigNum1(V3,max(L1,L2)); % end; procedure BLAnd(V1,V2); % If both args are -ve the result will be too. Otherwise result will % be positive; if BMinusp V1 and BMinusp V2 then BLnot BLor(BLnot V1,BLnot v2) else begin scalar L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; L3:=Min(L1,L2); V3:=GtPOS L3; if BMinusp V1 then IFor I:=1:L3 do IPutV(V3,I,ILand(ILXor(Logicalbits!*,IGetV(V1,I)), IGetV(V2,I))) else if BMinusp V2 then IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I), ILXor(Logicalbits!*,IGetV(V2,I)))) else IFor I:=1:L3 do IPutV(V3,I,ILand(IGetV(V1,I),IGetV(V2,I))); return TrimBigNum1(V3,L3); End; procedure BLNot(V1); BMinus BSmallAdd(V1,1); procedure BLShift(V1,V2); % This seems a grimly inefficient way of doing things given that % the representation of big numbers uses a base that is a power of 2. % However it will do for now; if BMinusP V2 then BQuotient(V1, BTwoPower BMinus V2) else BTimes2(V1, BTwoPower V2); % ----------------------------------------- % Arithmetic Functions: % % U, V, V1, V2 are Bignum arguments. procedure BMinus V1; % Negates V1. if BZeroP V1 then V1 else begin scalar L1,V2; L1:=BSize V1; if BMinusP V1 then V2 := GtPOS L1 else V2 := GtNEG L1; IFor I:=1:L1 do IPutV(V2,I,IGetV(V1,I)); return V2; end; % Returns V1 if V1 is strictly less than 0, NIL otherwise. % procedure BMinusP V1; if (IGetV(V1,0) eq 'BIGNEG) then V1 else NIL; % To provide a conveninent ADD with CARRY. procedure AddCarry A; begin scalar S; S:=IPlus2(A,Carry!*); if IGeq(S,BBase!*) then <<Carry!*:= 1; S:=IDifference(S,BBase!*)>> else Carry!*:=0; return S; end; procedure BPlus2(V1,V2); begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if Sn1 and Not Sn2 then return BDifference2(V2,BMinus V1,Nil); if Sn2 and Not Sn1 then return BDifference2(V1,BMinus V2,Nil); return BPlusA2(V1,V2,Sn1); end; procedure BPlusA2(V1,V2,Sn1); % Plus with signs pre-checked and begin scalar L1,L2,L3,V3,temp; % identical. L1:=BSize V1; L2:=BSize V2; If IGreaterP(L2,L1) then <<L3:=L2; L2:=L1;L1:=L3; V3:=V2; V2:=V1;V1:=V3>>; L3:=IAdd1 L1; If Sn1 then V3:=GtNeg L3 else V3:=GtPOS L3; Carry!*:=0; IFor I:=1:L2 do <<temp:=IPlus2(IGetV(V1,I),IGetV(V2,I)); IPutV(V3,I,AddCarry temp)>>; temp:=IAdd1 L2; IFor I:=temp:L1 do IPutV(V3,I,AddCarry IGetV(V1,I)); IPutV(V3,L3,Carry!*); % Carry Out Return TrimBigNum1(V3,L3); end; procedure BDifference(V1,V2); if BZeroP V2 then V1 else if BZeroP V1 then BMinus V2 else begin scalar Sn1,Sn2; Sn1:=BMinusP V1; Sn2:=BMinusP V2; if (Sn1 and Not Sn2) or (Sn2 and Not Sn1) then return BPlusA2(V1,BMinus V2,Sn1); return BDifference2(V1,V2,Sn1); end; procedure SubCarry A; begin scalar S; S:=IDifference(A,Carry!*); if ILessP(S,0) then <<Carry!*:=1; S:=IPlus2(BBase!*,S)>> else Carry!*:=0; return S; end; Procedure BDifference2(V1,V2,Sn1); % Signs pre-checked and identical. begin scalar i,L1,L2,L3,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3; Sn1:=not Sn1>> else if L1 Eq L2 then <<i:=L1; while (IGetV(V2,i) Eq IGetV(V1,i) and IGreaterP(i,1)) do i:=ISub1 i; if IGreaterP(IGetV(V2,i),IGetV(V1,i)) then <<L3:=L1;L1:=L2;L2:=L3; V3:=V1;V1:=V2;V2:=V3;Sn1:=not Sn1>> >>; if Sn1 then V3:=GtNEG L1 else V3:=GtPOS L1; carry!*:=0; IFor I:=1:L2 do IPutV(V3,I,SubCarry IDifference(IGetV(V1,I),IGetV(V2,I))); IFor I:=(IAdd1 L2):L1 do IPutV(V3,I,SubCarry IGetV(V1,I)); return TrimBigNum1(V3,L1); end; procedure BTimes2(V1,V2); begin scalar L1,L2,L3,Sn1,Sn2,V3; L1:=BSize V1; L2:=BSize V2; if IGreaterP(L2,L1) then <<V3:=V1; V1:=V2; V2:=V3; % If V1 is larger, will be fewer L3:=L1; L1:=L2; L2:=L3>>; % iterations of BDigitTimes2. L3:=IPlus2(L1,L2); Sn1:=BMinusP V1; Sn2:=BMinusP V2; If (Sn1 and Sn2) or not(Sn1 or Sn2) then V3:=GtPOS L3 else V3:=GtNEG L3; IFor I:=1:L3 do IPutV(V3,I,0); IFor I:=1:L2 do BDigitTimes2(V1,IGetV(V2,I),L1,I,V3); return TrimBigNum1(V3,L3); end; Procedure BDigitTimes2(V1,V2,L1,I,V3); % V1 is a bignum, V2 a fixnum, L1=BSize L1, I=position of V2 in a bignum, % and V3 is bignum receiving result. I affects where in V3 the result of % a calculation goes; the relationship is that positions I:I+(L1-1) % of V3 receive the products of V2 and positions 1:L1 of V1. % V3 is changed as a side effect here. begin scalar J,carry,temp1,temp2; if zerop V2 then return V3 else << carry:=0; IFor H:=1:L1 do << temp1:=ITimes2(IGetV(V1,H),V2); temp2:=IPlus2(H,ISub1 I); J:=IPlus2(IPlus2(temp1,IGetV(V3,temp2)),carry); IPutV(V3,temp2,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IPutV(V3,IPlus2(L1,I),carry)>>; % carry should be < BBase!* here return V3; end; Procedure BSmallTimes2(V1,C); % V1 is a BigNum, C a fixnum. % Assume C positive, ignore sign(V1) % also assume V1 neq 0. if ZeroP C then return GtPOS 0 % Only used from BHardDivide, BReadAdd. else begin scalar J,carry,L1,L2,L3,V3; L1:=BSize V1; L2:=IPlus2(IQuotient(C,BBase!*),L1); L3:=IAdd1 L2; V3:=GtPOS L3; carry:=0; IFor H:=1:L1 do << J:=IPlus2(ITimes2(IGetV(V1,H),C),carry); IPutV(V3,H,IRemainder(J,BBase!*)); carry:=IQuotient(J,BBase!*)>>; IFor H:=(IAdd1 L1):L3 do << IPutV(V3,H,IRemainder(J:=carry,BBase!*)); carry:=IQuotient(J,BBase!*)>>; return TrimBigNum1(V3,L3); end; procedure BQuotient(V1,V2); car BDivide(V1,V2); procedure BRemainder(V1,V2); cdr BDivide(V1,V2); % BDivide returns a dotted pair, (Q . R). Q is the quotient and R is % the remainder. Both are bignums. R is of the same sign as V1. %; smacro procedure BSimpleQuotient(V1,L1,C,SnC); car BSimpleDivide(V1,L1,C,SnC); smacro procedure BSimpleRemainder(V1,L1,C,SnC); cdr BSimpleDivide(V1,L1,C,SnC); procedure BDivide(V1,V2); begin scalar L1,L2,Q,R,V3; L2:=BSize V2; If IZerop L2 then error(99, "Attempt to divide by 0 in BDIVIDE"); L1:=BSize V1; If ILessP(L1,L2) or (L1 Eq L2 and ILessP(IGetV(V1,L1),IGetV(V2,L2))) % This also takes care of case then return (GtPOS 0 . V1); % when V1=0. if IOnep L2 then return BSimpleDivide(V1,L1,IGetV(V2,1),BMinusP V2); return BHardDivide(V1,L1,V2,L2); end; % C is a fixnum (inum?); V1 is a bignum and L1 is its length. % SnC is T if C (which is positive) should be considered negative. % Returns quotient . remainder; each is a bignum. % procedure BSimpleDivide(V1,L1,C,SnC); begin scalar I,P,R,RR,Sn1,V2; Sn1:=BMinusP V1; if (Sn1 and SnC) or not(Sn1 or SnC) then V2:=GtPOS L1 else V2:=GtNEG L1; R:=0; I:=L1; While not IZeroP I do <<P:=IPlus2(ITimes2(R,BBase!*),IGetV(V1,I)); % Overflow. IPutV(V2,I,IQuotient(P, C)); R:=IRemainder(P, C); I:=ISub1 I>>; If Sn1 then RR:=GtNeg 1 else RR:=GtPOS 1; IPutV(RR,1,R); return (TrimBigNum1(V2,L1) . TrimBigNum1(RR,1)); end; procedure BHardDivide(U,Lu,V,Lv); % This is an algorithm taken from Knuth. begin scalar U1,V1,A,D,LCV,LCV1,f,f2,J,K,Lq,carry,temp, LL,M,N,N1,P,Q,QBar,SnU,SnV,U2; N:=Lv; N1:=IAdd1 N; M:=IDifference(Lu,Lv); Lq:=IAdd1 M; % Deal with signs of inputs; SnU:=BMinusP U; SnV:=BMinusp V; % Note that these are not extra-boolean, i.e. % for positive numbers MBinusP returns nil, for % negative it returns its argument. Thus the % test (SnU=SnV) does not reliably compare the signs of % U and V; if SnU then if SnV then Q := GtPOS Lq else Q := GtNEG Lq else if SnV then Q := GtNEG Lq else Q := GtPOS Lq; U1 := GtPOS IAdd1 Lu; % U is ALWAYS stored as if one digit longer; % Compute a scale factor to normalize the long division; D:=IQuotient(BBase!*,IAdd1 IGetV(V,Lv)); % Now, at the same time, I remove the sign information from U and V % and scale them so that the leading coefficeint in V is fairly large; carry := 0; IFor i:=1:Lu do << temp := IPlus2(ITimes2(IGetV(U,I),D),carry); IPutV(U1,I,IRemainder(temp,BBase!*)); carry := IQuotient(temp,BBase!*) >>; Lu := IAdd1 Lu; IPutV(U1,Lu,carry); V1:=BSmallTimes2(V,D); % So far all variables contain safe values, % i.e. numbers < BBase!*; IPutV(V1,0,'BIGPOS); if ILessp(Lv,2) then NonBigNumError(V,'BHARDDIVIDE); % To be safe; LCV := IGetV(V1,Lv); LCV1 := IGetv(V1,ISub1 Lv); % Top two digits of the scaled V accessed once % here outside the main loop; % Now perform the main long division loop; IFor I:=0:M do << J:=IDifference(Lu,I); % J>K; working on U1[K:J] K:=IDifference(J,N1); % in this loop. A:=IGetV(U1,J); P := IPlus2(ITimes2(A,BBase!*),IGetv(U1,Isub1 J)); % N.B. P is up to 30 bits long. Take care! ; if A Eq LCV then QBar := ISub1 BBase!* else QBar := Iquotient(P,LCV); % approximate next digit; f:=ITimes2(QBar,LCV1); f2:=IPlus2(ITimes2(IDifference(P,ITimes2(QBar,LCV)),BBase!*), IGetV(U1,IDifference(J,2))); while IGreaterP(f,f2) do << % Correct most overshoots in Qbar; QBar:=ISub1 QBar; f:=IDifference(f,LCV1);; f2:=IPlus2(f2,ITimes2(LCV,BBase!*)) >>; carry := 0; % Ready to subtract QBar*V1 from U1; IFor L:=1:N do << temp := IPlus2( Idifference( IGetV(U1,IPlus2(K,L)), ITimes2(QBar,IGetV(V1,L))), carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusp temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,IPlus2(K,L),temp) >>; % Now propagate borrows up as far as they go; LL := IPlus2(K,N); while (not IZeroP carry) and ILessp(LL,J) do << LL := IAdd1 LL; temp := IPlus2(IGetV(U1,LL),carry); carry := IQuotient(temp,BBase!*); temp := IRemainder(temp,BBase!*); if IMinusP temp then << carry := ISub1 carry; temp := IPlus2(temp,BBase!*) >>; IPutV(U1,LL,temp) >>; if not IZerop carry then << % QBar was still wrong - correction step needed. % This should not happen very often; QBar := ISub1 QBar; % Add V1 back into U1; carry := 0; IFor L := 1:N do << carry := IPlus2( IPlus2(IGetV(U1,Iplus2(K,L)), IGetV(V1,L)), carry); IPutV(U1,IPlus2(K,L),IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >>; LL := IPlus2(K,N); while ILessp(LL,J) do << LL := IAdd1 LL; carry := IPlus2(IGetv(U1,LL),carry); IPutV(U1,LL,IRemainder(carry,BBase!*)); carry := IQuotient(carry,BBase!*) >> >>; IPutV(Q,IDifference(Lq,I),QBar) >>; % End of main loop; U1 := TrimBigNum1(U1,IDifference(Lu,M)); f := 0; f2 := 0; % Clean up potentially wild values; if not BZeroP U1 then << % Unnormalize the remainder by dividing by D if SnU then IPutV(U1,0,'BIGNEG); if not IOnep D then << Lu := BSize U1; carry := 0; IFor L:=Lu step -1 until 1 do << P := IPlus2(ITimes2(carry,BBase!*),IGetV(U1,L)); IPutv(U1,L,IQuotient(P,D)); carry := IRemainder(P,D) >>; P := 0; if not IZeroP carry then BHardBug("remainder when unscaling", U,V,TrimBigNum1(U1,Lu),TrimBigNum1(Q,Lq)); U1 := TrimBigNum1(U1,Lu) >> >>; Q := TrimBigNum1(Q,Lq); % In case leading digit happened to be zero; P := 0; % flush out a 30 bit number; % Here, for debugging purposes, I will try to validate the results I % have obtained by testing if Q*V+U1=U and 0<=U1<V. I Know this slows things % down, but I will remove it when my confidence has improved somewhat; % if not BZerop U1 then << % if (BMinusP U and not BMinusP U1) or % (BMinusP U1 and not BMinusP U) then % BHardBug("remainder has wrong sign",U,V,U1,Q) >>; % if not BAbs U1<BAbs V then BHardBug("remainder out of range",U,V,U1,Q) % else if not BZerop(BDifference(BPlus2(BTimes2(Q,V),U1),U)) then % BHardBug("quotient or remainder incorrect",U,V,U1,Q); return (Q . U1) end; procedure BHardBug(msg,U,V,R,Q); % Because the inputs to BHardDivide are probably rather large, I am not % going to rely on BldMsg to display them; << Prin2T "***** Internal error in BHardDivide"; Prin2 "arg1="; Prin2T U; Prin2 "arg2="; Prin2T V; Prin2 "computed quotient="; Prin2T Q; Prin2 "computed remainder="; Prin2T R; StdError msg >>; procedure BGreaterP(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(V,U) else nil else if BMinusP V then U else BUnsignedGreaterP(U,V); procedure BLessp(U,V); if BMinusP U then if BMinusP V then BUnsignedGreaterP(U,V) else U else if BMinusP V then nil else BUnsignedGreaterP(V,U); procedure BGeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(V,U) else nil else if BMinusP V then U else BUnsignedGeq(U,V); procedure BLeq(U,V); if BMinusP U then if BMinusP V then BUnsignedGeq(U,V) else U else if BMinusP V then nil else BUnsignedGeq(V,U); procedure BUnsignedGreaterP(U,V); % Compare magnitudes of two bignums; begin scalar Lu,Lv,I; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; if IGreaterP(IGetV(U,Lv),IGetV(V,Lv)) then return U else return nil end; procedure BUnsignedGeq(U,V); % Compare magnitudes of two unsigned bignums; begin scalar Lu,Lv; Lu := BSize U; Lv := BSize V; if not (Lu eq Lv) then << if IGreaterP(Lu,Lv) then return U else return nil >>; while IGetV(U,Lv) eq IGetV(V,Lv) and IGreaterP(Lv,1) do Lv := ISub1 Lv; If IGreaterP(IGetV(V,Lv),IGetV(U,Lv)) then return nil else return U end; procedure BAdd1 V; BSmallAdd(V, 1); procedure BSub1 U; BSmallDiff(U, 1); % ------------------------------------------------ % Conversion to Float: procedure FloatFromBigNum V; if BZeroP V then 0.0 else if BGreaterP(V, BigFloatHi!*) or BLessp(V, BigFloatLow!*) then Error(99,list("Argument, ",V," to FLOAT is too large")) else begin scalar L,Res,Sn,I; % Careful, do not want to call itself recursively L:=BSize V; Sn:=BMinusP V; Res:=IntFloat IGetv(V,L); I:=ISub1 L; While not IZeroP I do << Res:=FloatTimes2(res,FloatBBase!*); Res:=FloatPlus2(Res, IntFloat IGetV(V,I)); I:=ISub1 I>>; if Sn then Res:=minus res; return res; end; % ------------------------------------------------ % Input and Output: Digit2Letter!* := % Ascii values of digits and characters. '[48 49 50 51 52 53 54 55 56 57 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]; % OutputBase!* is assumed to be positive and less than 37. procedure BChannelPrin2(Channel,V); If not BigP V then NonBigNumError(V, 'BPrin) %need? else begin scalar quot, rem, div, result, resultsign, myobase; myobase:=OutputBase!*; resultsign:=BMinusP V; div:=BSimpleDivide(V,Bsize V,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result; while Not BZeroP quot do <<div:=BSimpleDivide(quot,Bsize quot,OutputBase!*,nil); quot:=car div; rem:=cdr div; if Bzerop rem then rem:=0 else rem:=IGetV(rem,1); result:=rem . result>>; if resultsign then channelwritechar(Channel,char !-); if myobase neq 10 then <<ChannelWriteSysInteger(channel,myobase,10); ChannelWriteChar(Channel, char !#)>>; For each u in result do ChannelWriteChar(Channel, IGetV(digit2letter!*,u)); OutputBase!*:=myobase; return; end; procedure BRead(s,radix,sn); % radix is < Bbase!* %s=string of digits, radix=base, sn=1 or -1 begin scalar sz, res, ch; sz:=size s; res:=GtPOS 1; ch:=indx(s,0); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IPlus2(IDifference(ch,char A),10); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); IPutV(res,1,ch); IFor i:=1:sz do <<ch:=indx(s,i); if IGeq(ch,char A) and ILeq(ch,char Z) then ch:=IDifference(ch,IDifference(char A,10)); if IGeq(ch,char 0) and ILeq(ch,char 9) then ch:=IDifference(ch,char 0); res:=BReadAdd(res, radix, ch)>>; if iminusp sn then res:=BMinus res; return res; end; procedure BReadAdd(V, radix, ch); << V:=BSmallTimes2(V, radix); V:=BSmallAdd(V,ch)>>; procedure BSmallAdd(V,C); %V big, C fix. if IZerop C then return V else if Bzerop V then return int2Big C else if BMinusp V then BMinus BSmallDiff(BMinus V, C) else if IMinusP C then BSmallDiff(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS(IAdd1 L1); IFor i:=1:L1 do IPutV(V1,i,addcarry IGetV(V,i)); if IOneP carry!* then IPutV(V1,IAdd1 L1,1) else return TrimBigNum1(V1,L1); return V1 end; procedure BNum N; % Creates a Bignum of one BETA digit, value N. % N is POS or NEG IF BIGP N then N else BnumAux N; procedure BNumAux N; % Creates a Bignum of one BIGIT value N. % N is POS or NEG begin scalar B; if IZerop n then return GtPOS 0 else if IMinusp N then <<b:=GtNEG 1; n:= IMinus n>> else b:=GtPos 1; IPutV(b,1,N); Return b; end; procedure BSmallDiff(V,C); %V big, C fix if IZerop C then V else if BZeroP V then int2Big IMinus C else if BMinusP V then BMinus BSmallAdd(BMinus V, C) else if IMinusP C then BSmallAdd(V, IMinus C) else begin scalar V1,L1; Carry!*:=C; L1:=BSize V; V1:=GtPOS L1; IFor i:=1:L1 do IPuTV(V1,i,subcarry IGetV(V,i)); if not IZeroP carry!* then StdError BldMsg(" BSmallDiff V<C %p %p%n",V,C); return TrimBigNum1(V1,L1); end; on syslisp; syslsp procedure int2Big n; % Creates BigNum of value N. % From any N, BETA,INUM,FIXNUM or BIGNUM case tag n of NEGINT,POSINT: sys2Big n; FIXN: sys2Big fixval fixinf n; BIGN: N; default: NonIntegerError(n, 'int2Big); End; off syslisp; % Convert BIGNUMs to FLOAT procedure bigfromfloat X; if fixp x or bigp x then x else begin scalar bigpart,floatpart,power,sign,thispart; if minusp X then <<sign:=-1; X:=minus X>> else sign:=1; bigpart:=bzero!*; while neq(X, 0) and neq(x,0.0) do << if X < bbase!* then << bigpart:=bplus2(bigpart, bnum fix x); X:=0 >> else <<floatpart:=x; power:=0; while floatpart>=bbase!* do % get high end of number. <<floatpart:=floatpart/bbase!*; power:=power + bbits!* >>; thispart:=btimes2(btwopower power, bnum fix floatpart); X:=X- floatfrombignum thispart; bigpart:=bplus2(bigpart, thispart) >> >>; if minusp sign then bigpart := bminus bigpart; return bigpart; end; % Now Install Interfacing on syslisp; syslsp procedure SetUpGlobals; << Prin2t '"SetupGlobals"; SetBits BitsPerWord; Prin2T '" ... done";>>; off syslisp; SetupGlobals(); LoadTime << StaticBig!*:=GtWarray 10>>; % Assume dont need more than 10 slots to represent a BigNum % Version of SYSint % -- Output--- % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; procedure checkifreallybig UU; % If BIGNUM result is in older FIXNUM or INUM range % Convert Back. %/ Need a faster test if BLessP(UU, BigSysLow!*) or BGreaterp(UU,BigSysHi!*) then UU else Sys2Int Big2SysAux UU; procedure checkifreallybigpair VV; % Used to process DIVIDE checkifreallybig car VV . checkifreallybig cdr VV; procedure checkifreallybigornil UU; % Used for EXTRA-boolean tests if Null UU or BLessp(UU, BigSysLow!*) or BGreaterP(UU,BigSysHi!*) then UU else Sys2Int Big2SysAux UU; procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); on syslisp; procedure Lshift(U,V); If BetaP U and BetaP V then (if V<0 then Sys2Int Wshift(U,V) else if V< LispVar (BBits!* ) then Sys2Int Wshift(U,V) else BigLshift(Sys2Big U, Sys2Big V) ) else BigLshift(Sys2Big U, Sys2Big V) ; off syslisp; Copyd('LSH,'Lshift); procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; procedure BigSub1 U; CheckIfReallyBig BSub1 U; procedure BigLNot U; CheckIfReallyBig BLNot U; procedure BigMinus U; CheckIfReallyBig BMinus U; procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; procedure BigOneP U; CheckIfReallyBigOrNil BOneP U; procedure BigZeroP U; CheckIfReallyBigOrNil BZeroP U; % ---- Input ---- procedure MakeStringIntoLispInteger(S,Radix,Sn); CheckIfReallyBig BRead(S,Radix,Sn); on syslisp; procedure Int2Sys N; % Convert a random FIXed number to WORD Integer case tag(N) of POSINT,NEGINT: N; FIXN: FixVal FixInf N; BIGN: Big2SysAux N; default: NonNumber1Error(N,'Int2SYS); End; syslsp procedure Sys2Big N; % Convert a SYSint to a BIG % Must NOT use generic arith here % Careful that no GC if this BIGger than INUM Begin scalar Sn, A, B; If N=0 then return GtPos 0; A:= LispVar StaticBig!*; % Grab the base If N<0 then sn:=T; A[1]:=N; % Plant number N:=1; % now use N as counter While A[n]>=Bbase!* do <<N:=N+1; A[n]:=A[n-1]/Bbase!*; A[n-1]:=A[n-1]-a[n]*Bbase!*>>; % Careful handling of -N in case have largest NEG, not just % flip sign If Sn then <<B:=GtNeg N; For i:=1:N do Iputv(B,i,-A[i])>> else << B:= GtPos N; For i:=1:N do IputV(B,i,A[i])>>; Return B; End; off syslisp; % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure FloatFix U; % Careful of sign and range If FloatSysLow!* <= U and U <= FloatSysHi!* then Oldfloatfix U else bigfromfloat U; on syslisp; procedure BetaP x; % test if NUMBER in reduced INUM range If Intp x then (x <= Lispvar(betaHi!*)) and (x >= LispVar(betaLow!*)) else NIL; procedure BetaRangeP x; % Test if SYSINT in reduced INUM range if (x <= Lispvar(betaHi!*)) then (x>=LispVar(betaLow!*)) else NIL; procedure Beta2P(x,y); % Check for 2 argument arithmetic functions if BetaP x then BetaP y; off syslisp; End; end; |
Added psl-1983/util/nbig1.build version [b26716ae1a].
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 | % NBIG1.BUILD - BigNum Interface % Load with NBIG.LAP, rather than IMPORTS, for module order compiletime<<load syslisp; load fast!-vector; load inum>>; in "nbig1.red"$ End; |
Added psl-1983/util/nbig1.red version [b7a732734e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. NBIG1.RED - Bignum Interfacing % M.L. Griss and B Morrison % 25 June 1982 % -------------------------------------------------------------------------- % Revision History: % 28 Dec 1982, MLG: % Added BigZeroP and BigOneP for NArith % Changed Name to NBIG1.RED from BIGFACE % 22 Dec 1982, MLG: % Change way of converting from VECT to BIGN % Move Module dependency to .BUILD file % Changes for NEW-ARITH, involve name changes for MAKEFIXNUM % ISINUM, etc. % 21 December, 82: MLG % Change PRIN1 and PRIN2 hooks to refer to RecursiveChannelprinx % which changed in PK:PRINTERS.RED for prinlevel stuff % November: Variety of Bug Fixes by A. Norman % Use the BIGN tag for better Interface fluid '(WordHi!* WordLow!* SysHi!* SysLow!* BBase!* FloatHi!* FloatLow!*); smacro procedure PutBig(b,i,val); IputV(b,i,val); smacro procedure GetBig(b,i); IgetV(B,i); % on syslisp; % % procedure BigP x; % Tag(x) eq BIGN; % % off syslisp; lisp procedure BignumP (V); BigP V and ((GetBig(V,0) eq 'BIGPOS) or (GetBig(V,0) eq 'BIGNEG)); lisp procedure NonBigNumError(V,L); StdError BldMsg(" Expect a BIGNUM in %r, given %p%n",L,V); lisp procedure BSize V; (BignumP V and VecLen VecInf V) or 0; lisp procedure GtPOS N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGPOS); Return MkBigN Vecinf B; End; lisp procedure GtNeg N; Begin Scalar B; B:=MkVect N; IPutV(B,0,'BIGNEG); Return MkBigN VecInf B; End; lisp procedure TrimBigNum V3; % truncate trailing 0 If Not BignumP V3 then NonBigNumError(V3,'TrimBigNum) else TrimBigNum1(V3,BSize V3); lisp procedure TrimBigNum1(B,L3); Begin scalar v3; V3:=BigAsVec B; While IGreaterP(L3,0) and IZeroP IGetV(V3,L3) do L3:=ISub1 L3; If IZerop UpBv TruncateVector(V3,L3) then return GtPOS 0 else return B; end; lisp procedure BigAsVec B; MkVec Inf B; lisp procedure VecAsBig V; MkBigN VecInf V; % Convert special GLOBALS from VECTOR form to BIGN form % Cant recall SETBITS with NEW-ARITH WordHi!* := VecAsBig WordHi!*; WordLow!* := VecAsBig WordLow!*; SysHi!* := VecAsBig SysHi!*; SysLow!* := VecAsBig SysLow!*; FloatHi!* := VecAsBig FloatHi!*; FloatLow!* := VecAsBig FloatLow!*; % -- Output--- % MLG Change to interface to Recursive hooks, added for % Prinlevel stuff CopyD('OldChannelPrin1,'RecursiveChannelPrin1); CopyD('OldChannelPrin2,'RecursiveChannelPrin2); Lisp Procedure RecursiveChannelPrin1(Channel,U,Level); <<if BigNumP U then BChannelPrin2(Channel,U) else OldChannelPrin1(Channel, U,Level);U>>; Lisp Procedure RecursiveChannelPrin2(Channel,U,level); <<If BigNumP U then BChannelPrin2(Channel, U) else OldChannelPrin2(Channel, U,level);U>>; lisp procedure big2sys U; begin scalar L,Sn,res,I; L:=BSize U; if IZeroP L then return 0; Sn:=BMinusP U; res:=IGetV(U,L); I:=ISub1 L; while I neq 0 do <<res:=ITimes2(res, bbase!*); res:=IPlus2(res, IGetV(U,I)); I:=ISub1 I>>; if Sn then Res:=IMinus Res; return Res; end; Copyd('oldSys2Int, 'Sys2Int); symbolic procedure checkifreallybig UU; if BLessP(UU, WordLow!*) or BGreaterp(UU,WordHi!*) then UU else oldsys2int big2sys UU; symbolic procedure checkifreallybigpair VV; checkifreallybig car VV . checkifreallybig cdr VV; symbolic procedure checkifreallybigornil UU; if Null UU or BLessp(UU, WordLow!*) or BGreaterP(UU,WordHi!*) then UU else oldsys2int big2sys UU; lisp procedure BigPlus2(U,V); CheckIfReallyBig BPlus2(U,V); lisp procedure BigDifference(U,V); CheckIfReallyBig BDifference(U,V); lisp procedure BigTimes2(U,V); CheckIfReallyBig BTimes2(U,V); lisp procedure BigDivide(U,V); CheckIfReallyBigPair BDivide(U,V); lisp procedure BigQuotient(U,V); CheckIfReallyBig BQuotient(U,V); lisp procedure BigRemainder(U,V); CheckIfReallyBig BRemainder(U,V); lisp procedure BigLAnd(U,V); CheckIfReallyBig BLand(U,V); lisp procedure BigLOr(U,V); CheckIfReallyBig BLOr(U,V); lisp procedure BigLXOr(U,V); CheckIfReallyBig BLXor(U,V); lisp procedure BigLShift(U,V); CheckIfReallyBig BLShift(U,V); lisp procedure BigGreaterP(U,V); CheckIfReallyBigOrNil BGreaterP(U,V); lisp procedure BigLessP(U,V); CheckIfReallyBigOrNil BLessP(U,V); lisp procedure BigAdd1 U; CheckIfReallyBig BAdd1 U; lisp procedure BigSub1 U; CheckIfReallyBig BSub1 U; lisp procedure BigLNot U; CheckIfReallyBig BLNot U; lisp procedure BigMinus U; CheckIfReallyBig BMinus U; lisp procedure FloatBigArg U; FloatFromBigNum U; lisp procedure BigMinusP U; CheckIfReallyBigOrNil BMinusP U; lisp procedure BigOneP U; CheckIfReallyBigOrNil BOneP U; lisp procedure BigZeroP U; CheckIfReallyBigOrNil BZeroP U; % ---- Input ---- lisp procedure MakeStringIntoLispInteger(Str,Radix,Sn); CheckIfReallyBig BRead(Str,Radix,Sn); on syslisp; syslsp procedure IsInum U; U < lispvar bbase!* and U > minus lispvar bbase!*; copyd('oldInt2Sys, 'Int2Sys); procedure Int2Sys N; if BigP N then Big2Sys N else OldInt2Sys n; off syslisp; % Coercion/Transfer Functions copyd('oldFloatFix,'FloatFix); procedure floatfix U; if U < BBase!* then OldFloatFix U else bigfromfloat U; procedure Sys2Int N; % temporary; check range? Begin; n:=oldSys2Int N; return int2b N; end; syslsp procedure StaticIntBig Arg; % Convert an INT to a BIG int2b Arg; syslsp procedure StaticBigFloat Arg; % Convert a BigNum to a FLOAT; FloatFromBignum Arg; end; |
Added psl-1983/util/nbigbig.build version [24e6f72f9b].
> | 1 | in "bigbig.red"$ |
Added psl-1983/util/nstruct.build version [ddd821daec].
> > > | 1 2 3 | compiletime load clcomp,strings; in "nstruct.lsp"$ in "fast-struct.lsp"$ |
Added psl-1983/util/nstruct.ctl version [fa7a871bb9].
> > > > > > > > | 1 2 3 4 5 6 7 8 | psl:rlisp load clcomp,strings; off usermode; faslout "ploclap:nstruct"; in "nstruct.lsp"$ in "fast-struct.lsp"$ faslend; quit; |
Added psl-1983/util/nstruct.lsp version [769e49e6f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; -*- Mode:Lisp; Package:SI; Lowercase:True; Base:8 -*- ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;The master copy of this file is in MC:ALAN;NSTRUCT > ;The current Lisp machine copy is in AI:LISPM2;STRUCT > ;The current Multics copy is in >udd>Mathlab>Bawden>defstruct.lisp ;***** READ THIS PLEASE! ***** ;If you are thinking of munging anything in this file you might want ;to consider finding me (ALAN) and asking me to mung it for you. ;There is more than one copy of this file in the world (it runs in PDP10 ;and Multics MacLisp and on LispMachines) and whatever amazing ;features you are considering adding might be usefull to those people ;as well. If you still cannot contain yourself long enough to find ;me, AT LEAST send me a piece of mail describing what you did and why. ;Thanks for reading this flame. ; Alan Bawden (ALAN@MC) ;Things to fix: ;For LispMachine: ; :%P-LDB type (this is hard to do, punt for now.) ;For Multics: ; displacement is a problem (no displace) ; nth, nthcdr don't exist there ; ldb, dpb don't exist, so byte fields don't work without Mathlab macros ; callable accessors don't work ; dpb is needed at the user's compile time if he is using byte fields. ; PSL change deleted ;(eval-when (compile) ; (cond ((status feature ITS) ; (load '|alan;lspenv init|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>lspenv.lisp|)))) ; ;#+PDP10 ;(cond ((status nofeature noldmsg) ; (terpri msgfiles) ; (princ '#.(and (status feature PDP10) ; (maknam (nconc (exploden ";Loading DEFSTRUCT ") ; (exploden (caddr (truename infile)))))) ; msgfiles))) ; ;#+Multics ;(declare (genprefix defstruct-internal-) ; (macros t)) ; ;#M ;(eval-when (eval compile) ; (setsyntax #/: (ascii #\space) nil)) ; PSL change -- make sure everything we need at run time gets loaded (imports '(useful common strings)) (eval-when (eval) ;;So we may run the thing interpreted we need the simple ;;defstruct that lives here: ; PSL change (lapin "struct.initial")) ; (cond ((status feature ITS) ; (load '|alan;struct initial|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>initial_defstruct|)))) (eval-when (compile) ;;To compile the thing this probably is an old fasl: (!) ; PSL change (load nstruct)) ; (cond ((status feature ITS) ; (load '|alan;struct boot|)) ; ((status feature Multics) ; (load '|>udd>Mathlab>Bawden>boot_defstruct|)))) #+Multics (defun nth (n l) (do ((n n (sub1 n)) (l l (cdr l))) ((zerop n) (car l)))) #+Multics (defun nthcdr (n l) (do ((n n (1- n)) (l l (cdr l))) ((zerop n) l))) ; PSL change I'm not sure whether we need this at all ;#+Multics (defun displace (x y) (cond ((atom y) (rplaca x 'progn) (rplacd x (list y))) (t (rplaca x (car y)) (rplacd x (cdr y)))) x) ;;; You might think you could use progn for this, but you can't! (defun defstruct-dont-displace (x y) x ;ignored y) ;;; Eval this before attempting incremental compilation (eval-when (eval compile) ; PSL change ;#+PDP10 ;(defmacro append-symbols args ; (do ((l (reverse args) (cdr l)) ; (x) ; (a nil (if (or (atom x) ; (not (eq (car x) 'quote))) ; (if (null a) ; `(exploden ,x) ; `(nconc (exploden ,x) ,a)) ; (let ((l (exploden (cadr x)))) ; (cond ((null a) `',l) ; ((= 1 (length l)) `(cons ,(car l) ,a)) ; (t `(append ',l ,a))))))) ; ((null l) `(implode ,a)) ; (setq x (car l)))) ; ;#+Multics ;(defmacro append-symbols args ; `(make_atom (catenate . ,args))) ; ;#+LispM ;(defmacro append-symbols args ; `(intern (string-append . ,args))) (defmacro append-symbols args `(intern (string-concat . ,args))) (defmacro defstruct-putprop (sym val ind) `(push `(defprop ,,sym ,,val ,,ind) returns)) (defmacro defstruct-put-macro (sym fcn) ; PSL change `(push `(putd ',,sym 'macro (function (lambda (**put-mac**) (,,fcn **put-mac**)))) returns)) ; #M `(defstruct-putprop ,sym ,fcn 'macro) ; #Q (setq fcn (if (and (not (atom fcn)) ; (eq (car fcn) 'quote)) ; `'(macro . ,(cadr fcn)) ; `(cons 'macro ,fcn))) ; #Q `(push `(fdefine ',,sym ',,fcn t) returns)) (defmacro make-empty () `'%%defstruct-empty%%) (defmacro emptyp (x) `(eq ,x '%%defstruct-empty%%)) ;;;Here we must deal with the fact that error reporting works ;;;differently everywhere! ; PSL change (defmacro defstruct-error (message . args) `(stderror (list ,message . ,args))) ;#+PDP10 ;;;;first arg is ALWAYS a symbol or a quoted symbol: ;(defmacro defstruct-error (message &rest args) ; (let* ((chars (nconc (exploden (if (atom message) ; message ; (cadr message))) ; '(#/.))) ;"Bad frob" => "Bad frob." ; (new-message ; (maknam (if (null args) ; chars ; (let ((c (car chars))) ;"Bad frob." => "-- bad frob." ; (or (< c #/A) ; (> c #/Z) ; (rplaca chars (+ c #o40))) ; (append '(#/- #/- #\space) chars)))))) ; `(error ',new-message ; ,@(cond ((null args) `()) ; ((null (cdr args)) `(,(car args))) ; (t `((list ,@args))))))) ; ;#+Multics ;;;;first arg is ALWAYS a string: ;(defmacro defstruct-error (message &rest args) ; `(error ,(catenate "defstruct: " ; message ; (if (null args) ; "." ; ": ")) ; ,@(cond ((null args) `()) ; ((null (cdr args)) `(,(car args))) ; (t `((list ,@args)))))) ; ;#+LispM ;;;;first arg is ALWAYS a string: ;(defmacro defstruct-error (message &rest args) ; (do ((l args (cdr l)) ; (fs "") ; (na nil)) ; ((null l) ; `(ferror nil ; ,(string-append message ; (if (null args) ; "." ; (string-append ":" fs))) ; ,.(nreverse na))) ; (cond ((and (not (atom (car l))) ; (eq (caar l) 'quote) ; (symbolp (cadar l))) ; (setq fs (string-append fs " " (string-downcase (cadar l))))) ; (t ; (push (car l) na) ; (setq fs (string-append fs " ~S")))))) );End of eval-when (eval compile) ;;;If you mung the the ordering af any of the slots in this structure, ;;;be sure to change the version slot and the definition of the function ;;;get-defstruct-description. Munging the defstruct-slot-description ;;;structure should also cause you to change the version "number" in this manner. (defstruct (defstruct-description (:type :list) (:default-pointer description) (:conc-name defstruct-description-) (:alterant nil)) (version 'one) type (displace 'defstruct-dont-displace) slot-alist ; PSL change (named-p t) ; named-p constructors (default-pointer nil) (but-first nil) size (property-alist nil) ;;end of "expand-time" slots name include (initial-offset 0) (eval-when '(eval compile load)) alterant (conc-name nil) ; PSL change (callable-accessors nil) ; (callable-accessors #M nil #Q t) (size-macro nil) (size-symbol nil) ) (defun get-defstruct-description (name) (let ((description (get name 'defstruct-description))) (cond ((null description) (defstruct-error "A structure with this name has not been defined" name)) ((not (eq (defstruct-description-version) 'one)) (defstruct-error "The description of this structure is out of date, it should be recompiled using the current version of defstruct" name)) (t description)))) ;;;See note above defstruct-description structure before munging this one. (defstruct (defstruct-slot-description (:type :list) (:default-pointer slot-description) (:conc-name defstruct-slot-description-) (:alterant nil)) number (ppss nil) init-code (type 'notype) (property-alist nil) ref-macro-name ) ;;;Perhaps this structure wants a version slot too? (defstruct (defstruct-type-description (:type :list) (:default-pointer type-description) (:conc-name defstruct-type-description-) (:alterant nil)) ref-expander ref-no-args cons-expander cons-flavor (cons-keywords nil) (named-type nil) (overhead 0) (defstruct-expander nil) ) ;; (DEFSTRUCT (<name> . <options>) . <slots>) or (DEFSTRUCT <name> . <slots>) ;; ;; <options> is of the form (<option> <option> (<option> <val>) ...) ;; ;; <slots> is of the form (<slot> (<slot> <initial-value>) ...) ;; ;; Options: ;; :TYPE defaults to HUNK ;; :CONSTRUCTOR defaults to "MAKE-<name>" ;; :DEFAULT-POINTER defaults to empty (if no <val> given defaults to "<name>") ;; :CONC-NAME defaults to empty (if no <val> given defaults to "<name>-") ;; :SIZE-SYMBOL defaults to empty (if no <val> given defaults to "<name>-SIZE") ;; :SIZE-MACRO defaults to empty (if no <val> given defaults to "<name>-SIZE") ;; :ALTERANT defaults to "ALTER-<name>" ;; :BUT-FIRST must have a <val> given ;; :INCLUDE must have a <val> given ;; :PROPERTY (:property foo bar) gives the structure a foo property of bar. ;; :INITIAL-OFFSET can cause defstruct to skip over that many slots. ;; :NAMED takes no value. Tries to make the structure a named type. ;; :CALLABLE-ACCESSORS defaults to T on the LispMachine, NIL elsewhere. ;; <type> any type name can be used without a <val> instead of saying (TYPE <type>) ;; <other> any symbol with a non-nil :defstruct-option property. You say ;; (<other> <val>) and the effect is that of (:property <other> <val>) ;; ;; Properties used: ;; DEFSTRUCT-TYPE-DESCRIPTION each type has one, it is a type-description. ;; DEFSTRUCT-NAME each constructor, alterant and size macro has one, it is a name. ;; DEFSTRUCT-DESCRIPTION each name has one, it is a description (see below). ;; DEFSTRUCT-SLOT each accesor has one, it is of the form: (<name> . <slot>) ;; :DEFSTRUCT-OPTION if a symbol FOO has this property then it can be used as an ;; option giving the structure a FOO property of the value (which must be given). ; PSL change ;#Q ;(defprop defstruct "Structure" definition-type-name) ; PSL change (defmacro defstruct (options . items) ;(defmacro defstruct (options &body items) (let* ((description (defstruct-parse-options options)) (type-description (get (defstruct-description-type) 'defstruct-type-description)) (name (defstruct-description-name)) (new-slots (defstruct-parse-items items description)) (returns nil)) (push `',name returns) (or (null (defstruct-type-description-defstruct-expander)) (setq returns (append (funcall (defstruct-type-description-defstruct-expander) description) returns))) ; PSL change ; #Q (push `(record-source-file-name ',name 'defstruct) returns) (defstruct-putprop name description 'defstruct-description) (let ((alterant (defstruct-description-alterant)) (size-macro (defstruct-description-size-macro)) (size-symbol (defstruct-description-size-symbol))) (cond (alterant (defstruct-put-macro alterant 'defstruct-expand-alter-macro) (defstruct-putprop alterant name 'defstruct-name))) (cond (size-macro (defstruct-put-macro size-macro 'defstruct-expand-size-macro) (defstruct-putprop size-macro name 'defstruct-name))) (cond (size-symbol ; PSL change (push `(defvar ,size-symbol ; (push `(#M defvar #Q defconst ,size-symbol ,(+ (defstruct-description-size) (defstruct-type-description-overhead))) returns)))) ; PSL change old style DO (do ((cs (defstruct-description-constructors) (cdr cs))) ((null cs)) ; (do cs (defstruct-description-constructors) (cdr cs) (null cs) (defstruct-put-macro (caar cs) 'defstruct-expand-cons-macro) (defstruct-putprop (caar cs) name 'defstruct-name)) `(eval-when ,(defstruct-description-eval-when) ,.(defstruct-define-ref-macros new-slots description) . ,returns))) (defun defstruct-parse-options (options) (let ((name (if (atom options) options (car options))) (type nil) (constructors (make-empty)) (alterant (make-empty)) (included nil) (named-p nil) (but-first nil) (description (make-defstruct-description))) (setf (defstruct-description-name) name) (do ((op) (val) (vals) (options (if (atom options) nil (cdr options)) (cdr options))) ((null options)) (if (atom (setq op (car options))) (setq vals nil) (setq op (prog1 (car op) (setq vals (cdr op))))) (setq val (if (null vals) (make-empty) (car vals))) ; PSL change ; #Q AGAIN (selectq op (:type (if (emptyp val) (defstruct-error "The type option to defstruct must have a value given" name)) (setq type val)) (:default-pointer (setf (defstruct-description-default-pointer) (if (emptyp val) name val))) (:but-first (if (emptyp val) (defstruct-error "The but-first option to defstruct must have a value given" name)) (setq but-first val) (setf (defstruct-description-but-first) val)) (:conc-name (setf (defstruct-description-conc-name) (if (emptyp val) (append-symbols name '-) val))) (:callable-accessors (setf (defstruct-description-callable-accessors) (if (emptyp val) t val))) (:displace (setf (defstruct-description-displace) (cond ((or (emptyp val) (eq val 't)) 'displace) ((null val) 'defstruct-dont-displace) (t val)))) (:constructor (cond ((null val) (setq constructors nil)) (t (and (emptyp val) (setq val (append-symbols 'make- name))) (setq val (cons val (cdr vals))) (if (emptyp constructors) (setq constructors (list val)) (push val constructors))))) (:alterant (setq alterant val)) (:size-macro (setf (defstruct-description-size-macro) (if (emptyp val) ; PSL change (append-symbols name '\-size) ; (append-symbols name '-size) val))) (:size-symbol (setf (defstruct-description-size-symbol) (if (emptyp val) ; PSL change (append-symbols name '\-size) ; (append-symbols name '-size) val))) (:include (and (emptyp val) (defstruct-error "The include option to defstruct requires a value" name)) (setq included val) (setf (defstruct-description-include) vals)) (:property (push (cons (car vals) (if (null (cdr vals)) t (cadr vals))) (defstruct-description-property-alist))) (:named (or (emptyp val) (defstruct-error "The named option to defstruct doesn't take a value" name)) (setq named-p t)) (:eval-when (and (emptyp val) (defstruct-error "The eval-when option to defstruct requires a value" name)) (setf (defstruct-description-eval-when) val)) (:initial-offset (and (or (emptyp val) (not (fixp val))) (defstruct-error "The initial-offset option to defstruct requires a fixnum" name)) (setf (defstruct-description-initial-offset) val)) (otherwise (cond ((get op 'defstruct-type-description) (or (emptyp val) (defstruct-error "defstruct type used as an option with a value" op 'in name)) (setq type op)) ((get op ':defstruct-option) (push (cons op (if (emptyp val) t val)) (defstruct-description-property-alist))) (t ; PSL change ; #Q (multiple-value-bind (new foundp) ; (intern-soft op si:pkg-user-package) ; (or (not foundp) ; (eq op new) ; (progn (setq op new) (go AGAIN)))) (defstruct-error "defstruct doesn't understand this option" op 'in name)))))) (cond ((emptyp constructors) (setq constructors (list (cons (append-symbols 'make- name) nil))))) (setf (defstruct-description-constructors) constructors) (cond ((emptyp alterant) (setq alterant (append-symbols 'alter- name)))) (setf (defstruct-description-alterant) alterant) (cond ((not (null type)) (let ((type-description (or (get type 'defstruct-type-description) ; PSL change ; #Q (multiple-value-bind ; (new foundp) ; (intern-soft type si:pkg-user-package) ; (and foundp ; (not (eq type new)) ; (progn (setq type new) ; (get type 'defstruct-type-description)))) (defstruct-error "Unknown type in defstruct" type 'in name)))) (if named-p (setq type (or (defstruct-type-description-named-type) (defstruct-error "There is no way to make this defstruct type named" type 'in name))))))) (cond (included (let ((d (get-defstruct-description included))) (if (null type) (setq type (defstruct-description-type d)) (or (eq type (defstruct-description-type d)) (defstruct-error "defstruct types must agree for include option" included 'included 'by name))) (and named-p (not (eq type (defstruct-type-description-named-type (or (get type 'defstruct-type-description) (defstruct-error "Unknown type in defstruct" type 'in name 'including included))))) (defstruct-error "Included defstruct's type isn't a named type" included 'included 'by name)) (if (null but-first) (setf (defstruct-description-but-first) (defstruct-description-but-first d)) (or (equal but-first (defstruct-description-but-first d)) (defstruct-error "but-first options must agree for include option" included 'included 'by name))))) ((null type) (setq type (cond (named-p ; PSL change ':named-vector) ; #+PDP10 ':named-hunk ; #+Multics ':named-list ; #+LispM ':named-array) (t ':vector))))) ; #+PDP10 ':hunk ; #+Multics ':list ; #+LispM ':array))))) (let ((type-description (or (get type 'defstruct-type-description) (defstruct-error "Undefined defstruct type" type 'in name)))) (setf (defstruct-description-type) type) (setf (defstruct-description-named-p) (eq (defstruct-type-description-named-type) type))) description)) (defun defstruct-parse-items (items description) (let ((name (defstruct-description-name)) (offset (defstruct-description-initial-offset)) (include (defstruct-description-include)) (o-slot-alist nil) (conc-name (defstruct-description-conc-name))) (or (null include) (let ((d (get (car include) 'defstruct-description))) (setq offset (+ offset (defstruct-description-size d))) (setq o-slot-alist (subst nil nil (defstruct-description-slot-alist d))) (do ((l (cdr include) (cdr l)) (it) (val)) ((null l)) (cond ((atom (setq it (car l))) (setq val (make-empty))) (t (setq val (cadr it)) (setq it (car it)))) (let ((slot-description (cdr (assq it o-slot-alist)))) (and (null slot-description) (defstruct-error "Unknown slot in included defstruct" it 'in include 'included 'by name)) (setf (defstruct-slot-description-init-code) val))))) ; PSL change 1+ ==> add1 (do ((i offset (add1 i)) ; (do ((i offset (1+ i)) (l items (cdr l)) (slot-alist nil) ; PSL change ) ; #+PDP10 (chars (exploden conc-name))) ((null l) (setq slot-alist (nreverse slot-alist)) (setf (defstruct-description-size) i) (setf (defstruct-description-slot-alist) (nconc o-slot-alist slot-alist)) slot-alist) (cond ((atom (car l)) (push (defstruct-parse-one-field ; PSL change (car l) i nil nil conc-name) ; (car l) i nil nil conc-name #+PDP10 chars) slot-alist)) ((atom (caar l)) (push (defstruct-parse-one-field ; PSL change (caar l) i nil (cdar l) conc-name) ; (caar l) i nil (cdar l) conc-name #+PDP10 chars) slot-alist)) (t ; PSL change old style DO (do ((ll (car l) (cdr ll))) ((null ll)) ; (do ll (car l) (cdr ll) (null ll) (push (defstruct-parse-one-field (caar ll) i (cadar ll) ; PSL change (cddar ll) conc-name) ; (cddar ll) conc-name #+PDP10 chars) slot-alist))))))) ; PSL change (defun defstruct-parse-one-field (it number ppss rest conc-name) ;(defun defstruct-parse-one-field (it number ppss rest conc-name #+PDP10 chars) ; PSL change (let ((mname (if conc-name (intern (string-concat conc-name it)) ; (let ((mname (if conc-name #+PDP10 (implode (append chars (exploden it))) ; #+Multics (make_atom (catenate conc-name it)) ; #+LispM (intern (string-append conc-name it)) it))) ; PSL change bootstrap apparently doesn't work (cons it (let ((kludge (make-defstruct-slot-description))) (setf (defstruct-slot-description-number kludge) number) (setf (defstruct-slot-description-ppss kludge) ppss) (setf (defstruct-slot-description-init-code kludge) (if (null rest) (make-empty) (car rest))) (setf (defstruct-slot-description-ref-macro-name kludge) mname) kludge)))) ; (cons it (make-defstruct-slot-description ; number number ; ppss ppss ; init-code (if (null rest) (make-empty) (car rest)) ; ref-macro-name mname)))) (defun defstruct-define-ref-macros (new-slots description) (let ((name (defstruct-description-name)) (returns nil)) (if (not (defstruct-description-callable-accessors)) (do ((l new-slots (cdr l)) ; PSL change ; #Q (parent `(,name defstruct)) (mname)) ((null l)) (setq mname (defstruct-slot-description-ref-macro-name (cdar l))) (defstruct-put-macro mname 'defstruct-expand-ref-macro) (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot)) (let ((type-description (get (defstruct-description-type) 'defstruct-type-description))) (let ((code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (but-first (defstruct-description-but-first)) (default-pointer (defstruct-description-default-pointer))) (do ((args nil (cons (gensym) args)) ; PSL change 1- ==> sub1 (i n (sub1 i))) ; (i n (1- i))) ((< i 2) ;;Last arg (if it exists) is name of structure, ;; for documentation purposes. (and (= i 1) (setq args (cons name args))) (let ((body (cons (if but-first `(,but-first ,(car args)) (car args)) (cdr args)))) (and default-pointer (setq args `((,(car args) ,default-pointer) &optional . ,(cdr args)))) (setq args (reverse args)) (setq body (reverse body)) (do ((l new-slots (cdr l)) (mname)) ((null l)) (setq mname (defstruct-slot-description-ref-macro-name (cdar l))) ; PSL change ; #M ;;This must come BEFORE the defun. THINK! (defstruct-put-macro mname 'defstruct-expand-ref-macro) (let ((ref (lexpr-funcall code (defstruct-slot-description-number (cdar l)) description body)) (ppss (defstruct-slot-description-ppss (cdar l)))) ; PSL change (push `(defun ,mname ,args ; (push `(#M defun #Q defsubst-with-parent ,mname #Q ,parent ,args ,(if (null ppss) ref `(ldb ,ppss ,ref))) returns)) (defstruct-putprop mname (cons name (caar l)) 'defstruct-slot)))))))) returns)) ; PSL change ;#Q ;(defprop defstruct-expand-cons-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-size-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-alter-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defprop defstruct-expand-ref-macro ; defstruct-function-parent ; macroexpander-function-parent) ; ;#Q ;(defun defstruct-function-parent (sym) ; (values (or (get sym 'defstruct-name) ; (car (get sym 'defstruct-slot))) ; 'defstruct)) ; (defun defstruct-expand-size-macro (x) (let ((description (get-defstruct-description (get (car x) 'defstruct-name)))) (let ((type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type))))) (funcall (defstruct-description-displace) x (+ (defstruct-description-size) (defstruct-type-description-overhead)))))) (defvar defstruct-ref-macro-name) (defun defstruct-expand-ref-macro (x) (let* ((defstruct-ref-macro-name (car x)) (pair (get (car x) 'defstruct-slot)) (description (get-defstruct-description (car pair))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (code (defstruct-type-description-ref-expander)) (n (defstruct-type-description-ref-no-args)) (args (reverse (cdr x))) (nargs (length args)) (default (defstruct-description-default-pointer)) (but-first (defstruct-description-but-first))) (cond ((= n nargs) (and but-first (rplaca args `(,but-first ,(car args))))) ; PSL change 1+ ==> add1 ((and (= n (add1 nargs)) default) ; ((and (= n (1+ nargs)) default) (setq args (cons (if but-first `(,but-first ,default) default) args))) (t (defstruct-error "Wrong number of args to an accessor macro" x))) (let* ((slot-description (cdr (or (assq (cdr pair) (defstruct-description-slot-alist)) (defstruct-error "This slot no longer exists in this structure" (cdr pair) 'in (car pair))))) (ref (lexpr-funcall code (defstruct-slot-description-number) description (nreverse args))) (ppss (defstruct-slot-description-ppss))) (funcall (defstruct-description-displace) x (if (null ppss) ref `(ldb ,ppss ,ref)))))) (defun defstruct-parse-setq-style-slots (l slots others x) (do ((l l (cddr l)) (kludge (cons nil nil))) ((null l) kludge) (or (and (cdr l) (symbolp (car l))) (defstruct-error "Bad argument list to constructor or alterant macro" x)) (defstruct-make-init-dsc kludge (car l) (cadr l) slots others x))) (defun defstruct-make-init-dsc (kludge name code slots others x) (let ((p (assq name slots))) (if (null p) (if (memq name others) (push (cons name code) (cdr kludge)) (defstruct-error "Unknown slot to constructor or alterant macro" name 'in x)) (let* ((slot-description (cdr p)) (number (defstruct-slot-description-number)) (ppss (defstruct-slot-description-ppss)) (dsc (assoc number (car kludge)))) (cond ((null dsc) (setq dsc (list* number nil (make-empty) 0 0 nil)) (push dsc (car kludge)))) (cond ((null ppss) (setf (car (cddr dsc)) code) (setf (cadr dsc) t)) (t (cond ((and (numberp ppss) (numberp code)) (setf (ldb ppss (cadr (cddr dsc))) -1) (setf (ldb ppss (caddr (cddr dsc))) code)) (t (push (cons ppss code) (cdddr (cddr dsc))))) (or (eq t (cadr dsc)) (push name (cadr dsc))))))))) (defun defstruct-code-from-dsc (dsc) (let ((code (car (cddr dsc))) (mask (cadr (cddr dsc))) (bits (caddr (cddr dsc)))) (if (emptyp code) (setq code bits) (or (zerop mask) (setq code (if (numberp code) (boole 7 bits (boole 2 mask code)) (if (zerop (logand mask ; PSL change (next 2 lines) 1+ => add1, 1- => sub1 ; (1+ (logior mask (1- mask))))) ; (let ((ss (haulong (boole 2 mask (1- mask))))) (add1 (logior mask(sub1 mask))))) (let ((ss (haulong (boole 2 mask (sub1 mask))))) `(dpb ,(lsh bits (- ss)) ,(logior (lsh ss 6) ; PSL change (logand 8#77 ; (logand #o77 (- (haulong mask) ss))) ,code)) `(boole 7 ,bits (boole 2 ,mask ,code))))))) ; PSL change old style DO (do ((l (cdddr (cddr dsc)) (cdr l))) ((null l)) ; (do l (cdddr (cddr dsc)) (cdr l) (null l) (setq code `(dpb ,(cdar l) ,(caar l) ,code))) code)) (defun defstruct-expand-cons-macro (x) (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (slot-alist (defstruct-description-slot-alist)) (cons-keywords (defstruct-type-description-cons-keywords)) inits kludge (constructor-description (cdr (or (assq (car x) (defstruct-description-constructors)) (defstruct-error "This constructor is no longer defined for this structure" (car x) 'in (defstruct-description-name))))) (aux nil) (aux-init nil)) (if (null constructor-description) (setq kludge (defstruct-parse-setq-style-slots (cdr x) slot-alist cons-keywords x)) (prog (args l) (setq kludge (cons nil nil)) (setq args (cdr x)) (setq l (car constructor-description)) R (cond ((null l) (if (null args) (return nil) (go barf-tma))) ((atom l) (go barf)) ((eq (car l) '&optional) (go O)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go A)) ((null args) (go barf-tfa))) (defstruct-make-init-dsc kludge (pop l) (pop args) slot-alist cons-keywords x) (go R) O (and (null args) (go OD)) (pop l) (cond ((null l) (go barf-tma)) ((atom l) (go barf)) ((eq (car l) '&optional) (go barf)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go barf-tma))) (defstruct-make-init-dsc kludge (if (atom (car l)) (car l) (caar l)) (pop args) slot-alist cons-keywords x) (go O) OD (pop l) (cond ((null l) (return nil)) ((atom l) (go barf)) ((eq (car l) '&optional) (go barf)) ((eq (car l) '&rest) (go S)) ((eq (car l) '&aux) (go A))) (or (atom (car l)) (defstruct-make-init-dsc kludge (caar l) (cadar l) slot-alist cons-keywords x)) (go OD) S (and (atom (cdr l)) (go barf)) (defstruct-make-init-dsc kludge (cadr l) `(list . ,args) slot-alist cons-keywords x) (setq l (cddr l)) (and (null l) (return nil)) (and (atom l) (go barf)) (or (eq (car l) '&aux) (go barf)) A (pop l) (cond ((null l) (return nil)) ((atom l) (go barf)) ((atom (car l)) (push (car l) aux) (push (make-empty) aux-init)) (t (push (caar l) aux) (push (cadar l) aux-init))) (go A) barf (defstruct-error "Bad format for defstruct constructor arglist" `(,(car x) . ,(car constructor-description))) barf-tfa (defstruct-error "Too few arguments to constructor macro" x) barf-tma (defstruct-error "Too many arguments to constructor macro" x))) ; PSL change old style DO (do ((l slot-alist (cdr l))) ((null l)) ; (do l slot-alist (cdr l) (null l) (let* ((name (caar l)) (slot-description (cdar l)) (code (do ((aux aux (cdr aux)) (aux-init aux-init (cdr aux-init))) ((null aux) (defstruct-slot-description-init-code)) (and (eq name (car aux)) (return (car aux-init))))) (ppss (defstruct-slot-description-ppss))) (or (and (emptyp code) (null ppss)) (let* ((number (defstruct-slot-description-number)) (dsc (assoc number (car kludge)))) (cond ((null dsc) (setq dsc (list number nil (make-empty) 0 0)) (setq dsc (list* number nil (make-empty) 0 0 nil)) (push dsc (car kludge)))) (cond ((emptyp code)) ((eq t (cadr dsc))) ((null ppss) (and (emptyp (car (cddr dsc))) (setf (car (cddr dsc)) code))) ((memq name (cadr dsc))) ((and (numberp ppss) (numberp code)) (setf (ldb ppss (cadr (cddr dsc))) -1) (setf (ldb ppss (caddr (cddr dsc))) code)) (t (push (cons ppss code) (cdddr (cddr dsc))))))))) (selectq (defstruct-type-description-cons-flavor) (:list (do ((l nil (cons nil l)) ; PSL change 1- ==> sub1 (i (defstruct-description-size) (sub1 i))) ; (i (defstruct-description-size) (1- i))) ((= i 0) (setq inits l))) ; PSL change old style DO (do ((l (car kludge) (cdr l))) ((null l)) ; (do l (car kludge) (cdr l) (null l) ; PSL change incompatible NTH (setf (nth inits (add1 (caar l))) ; (setf (nth (caar l) inits) (defstruct-code-from-dsc (car l))))) (:alist (setq inits (car kludge)) ; PSL change old style DO (do ((l inits (cdr l))) ((null l)) ; (do l inits (cdr l) (null l) (rplacd (car l) (defstruct-code-from-dsc (car l))))) (otherwise (defstruct-error "Unknown constructor kind in this defstruct type" (defstruct-description-type)))) (funcall (defstruct-description-displace) x (funcall (defstruct-type-description-cons-expander) inits description (cdr kludge))))) (defun defstruct-expand-alter-macro (x) (let* ((description (get-defstruct-description (get (car x) 'defstruct-name))) (type-description (or (get (defstruct-description-type) 'defstruct-type-description) (defstruct-error "Unknown defstruct type" (defstruct-description-type)))) (ref-code (defstruct-type-description-ref-expander))) (or (= 1 (defstruct-type-description-ref-no-args)) (defstruct-error "Alterant macros cannot handle this defstruct type" (defstruct-description-type))) (do ((l (car (defstruct-parse-setq-style-slots (cddr x) (defstruct-description-slot-alist) nil x)) (cdr l)) (but-first (defstruct-description-but-first)) (body nil) (var (gensym)) (vars nil) (vals nil)) ((null l) (funcall (defstruct-description-displace) x `((lambda (,var) . ,(if (null vars) body `(((lambda ,vars . ,body) . ,vals)))) ,(if but-first `(,but-first ,(cadr x)) (cadr x))))) (let ((ref (funcall ref-code (caar l) description var))) (and (emptyp (car (cddr (car l)))) (setf (car (cddr (car l))) ref)) (let ((code (defstruct-code-from-dsc (car l)))) (if (null (cdr l)) (push `(setf ,ref ,code) body) (let ((sym (gensym))) (push `(setf ,ref ,sym) body) (push sym vars) (push code vals)))))))) (defmacro defstruct-define-type (type . options) (do ((options options (cdr options)) (op) (args) (type-description (make-defstruct-type-description)) (cons-expander nil) (ref-expander nil) (defstruct-expander nil)) ((null options) (or cons-expander (defstruct-error "No cons option in defstruct-define-type" type)) (or ref-expander (defstruct-error "No ref option in defstruct-define-type" type)) `(progn 'compile ,cons-expander ,ref-expander ,@(and defstruct-expander (list defstruct-expander)) (defprop ,type ,type-description defstruct-type-description))) (cond ((atom (setq op (car options))) (setq args nil)) (t (setq args (cdr op)) (setq op (car op)))) ; PSL change ;#Q AGAIN (selectq op (:cons (or (> (length args) 2) (defstruct-error "Bad cons option in defstruct-define-type" (car options) 'in type)) (let ((n (length (car args))) ; PSL change (name (append-symbols type '\-defstruct-cons))) ; (name (append-symbols type '-defstruct-cons))) (or (= n 3) (defstruct-error "Bad cons option in defstruct-define-type" (car options) 'in type)) (setf (defstruct-type-description-cons-flavor) #-LispM (cadr args) ; PSL change ) ; #+LispM (intern (string (cadr args)) si:pkg-user-package)) (setf (defstruct-type-description-cons-expander) name) (setq cons-expander `(defun ,name ,(car args) . ,(cddr args))))) (:ref (or (> (length args) 1) (defstruct-error "Bad ref option in defstruct-define-type" (car options) 'in type)) (let ((n (length (car args))) ; PSL change (name (append-symbols type '\-defstruct-ref))) ; (name (append-symbols type '-defstruct-ref))) (or (> n 2) (defstruct-error "Bad ref option in defstruct-define-type" (car options) 'in type)) (setf (defstruct-type-description-ref-no-args) (- n 2)) (setf (defstruct-type-description-ref-expander) name) (setq ref-expander `(defun ,name ,(car args) . ,(cdr args))))) (:overhead (setf (defstruct-type-description-overhead) (if (null args) (defstruct-error "Bad option to defstruct-define-type" (car options) 'in type) (car args)))) (:named (setf (defstruct-type-description-named-type) (if (null args) type (car args)))) (:keywords (setf (defstruct-type-description-cons-keywords) args)) (:defstruct (or (> (length args) 1) (defstruct-error "Bad defstruct option in defstruct-define-type" (car options) 'in type)) ; PSL change (let ((name (append-symbols type '\-defstruct-expand))) ; (let ((name (append-symbols type '-defstruct-expand))) (setf (defstruct-type-description-defstruct-expander) name) (setq defstruct-expander `(defun ,name . ,args)))) (otherwise ; PSL change ; #Q (multiple-value-bind (new foundp) ; (intern-soft op si:pkg-user-package) ; (or (not foundp) ; (eq op new) ; (progn (setq op new) (go AGAIN)))) (defstruct-error "Unknown option to defstruct-define-type" (car options) 'in type))))) ; PSL change ;#Q ;(defprop :make-array t :defstruct-option) ; ;(defstruct-define-type :array ; #Q (:named :named-array) ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc nil nil nil 1) ; #M (maclisp-array-for-defstruct arg description 't)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall t ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;#Q ;(defstruct-define-type :named-array ; (:keywords :make-array) ; :named (:overhead 1) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,(1+ i))) ; description etc nil t nil 1)) ; (:ref (n description arg) ; description ;ignored ; `(aref ,arg ,(1+ n)))) ; ;(defstruct-define-type :fixnum-array ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc 'art-32b nil nil 1) ; #M (maclisp-array-for-defstruct arg description 'fixnum)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall fixnum ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;(defstruct-define-type :flonum-array ; #Q (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; #M etc ;ignored in MacLisp ; #Q (lispm-array-for-defstruct arg #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc 'art-float nil nil 1) ; #M (maclisp-array-for-defstruct arg description 'flonum)) ; (:ref ; (n description arg) ; description ;ignored ; #M `(arraycall flonum ,arg ,n) ; #Q `(aref ,arg ,n))) ; ;#M ;(defstruct-define-type :un-gc-array ; (:cons ; (arg description etc) :alist ; etc ;ignored ; (maclisp-array-for-defstruct arg description 'nil)) ; (:ref ; (n description arg) ; description ;ignored ; `(arraycall nil ,arg ,n))) ; ;#Q ;(defstruct-define-type :array-leader ; (:named :named-array-leader) ; (:keywords :make-array) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct arg #'(lambda (v a i) ; `(store-array-leader ,v ,a ,i)) ; description etc nil nil t 1)) ; (:ref ; (n description arg) ; description ;ignored ; `(array-leader ,arg ,n))) ; ;#Q ;(defstruct-define-type :named-array-leader ; (:keywords :make-array) ; :named (:overhead 1) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct ; arg ; #'(lambda (v a i) ; `(store-array-leader ,v ,a ,(if (zerop i) ; 0 ; (1+ i)))) ; description etc nil t t 1)) ; (:ref ; (n description arg) ; description ;ignored ; (if (zerop n) ; `(array-leader ,arg 0) ; `(array-leader ,arg ,(1+ n))))) ; ;#Q ;(defprop :times t :defstruct-option) ; ;#Q ;(defstruct-define-type :grouped-array ; (:keywords :make-array :times) ; (:cons ; (arg description etc) :alist ; (lispm-array-for-defstruct ; arg ; #'(lambda (v a i) `(aset ,v ,a ,i)) ; description etc nil nil nil ; (or (cdr (or (assq ':times etc) ; (assq ':times (defstruct-description-property-alist)))) ; 1))) ; (:ref ; (n description index arg) ; description ;ignored ; (cond ((numberp index) ; `(aref ,arg ,(+ n index))) ; ((zerop n) ; `(aref ,arg ,index)) ; (t `(aref ,arg (+ ,n ,index)))))) ; ;#Q ;(defun lispm-array-for-defstruct (arg cons-init description etc type named-p leader-p times) ; (let ((p (cons nil nil)) ; (no-op 'nil)) ; (defstruct-grok-make-array-args ; (cdr (assq ':make-array (defstruct-description-property-alist))) ; p) ; (defstruct-grok-make-array-args ; (cdr (assq ':make-array etc)) ; p) ; (and type (putprop p type ':type)) ; (and named-p (putprop p `',(defstruct-description-name) ':named-structure-symbol)) ; (putprop p ; (let ((size (if named-p ; (1+ (defstruct-description-size)) ; (defstruct-description-size)))) ; (if (numberp times) ; (* size times) ; `(* ,size ,times))) ; (if leader-p ':leader-length ':dimensions)) ; (or leader-p ; (let ((type (get p ':type))) ; (or (atom type) ; (not (eq (car type) 'quote)) ; (setq type (cadr type))) ; (caseq type ; ((nil art-q art-q-list)) ; ((art-32b art-16b art-8b art-4b art-2b art-1b art-string) (setq no-op '0)) ; ((art-float) (setq no-op '0.0)) ; (t (setq no-op (make-empty)))))) ; (do ((creator ; (let ((dims (remprop p ':dimensions))) ; (do l (cdr p) (cddr l) (null l) ; (rplaca l `',(car l))) ; `(make-array ,(if (null dims) 0 (car dims)) ,@(cdr p)))) ; (var (gensym)) ; (set-ups nil (if (equal (cdar l) no-op) ; set-ups ; (cons (funcall cons-init (cdar l) var (caar l)) ; set-ups))) ; (l arg (cdr l))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator))))) ; ;#Q ;(defun defstruct-grok-make-array-args (args p) ; (let ((nargs (length args))) ; (if (and (not (> nargs 7)) ; (or (oddp nargs) ; (do ((l args (cddr l))) ; ((null l) nil) ; (or (memq (car l) '(:area :type :displaced-to :leader-list ; :leader-length :displaced-index-offset ; :named-structure-symbol :dimensions ; :length)) ; (return t))))) ; (do ((l args (cdr l)) ; (keylist '(:area :type :dimensions :displaced-to :old-leader-length-or-list ; :displaced-index-offset :named-structure-symbol) ; (cdr keylist))) ; ((null l) ; (and (boundp 'compiler:compiler-warnings-context) ; (boundp 'compiler:last-error-function) ; (not (null compiler:compiler-warnings-context)) ; (compiler:barf args '|-- old style :MAKE-ARRAY constructor keyword argument| ; 'compiler:warn)) ; p) ; (putprop p (car l) (car keylist))) ; (do ((l args (cddr l))) ; ((null l) p) ; (if (or (null (cdr l)) ; (not (memq (car l) '(:area :type :displaced-to :leader-list ; :leader-length :displaced-index-offset ; :named-structure-symbol :dimensions ; :length)))) ; (defstruct-error ; "defstruct can't grok these make-array arguments" ; args)) ; (putprop p ; (cadr l) ; (if (eq (car l) ':length) ; ':dimensions ; (car l))))))) ; ;#M ;(defun maclisp-array-for-defstruct (arg description type) ; (do ((creator `(array nil ,type ,(defstruct-description-size))) ; (var (gensym)) ; (no-op (caseq type ; (fixnum 0) ; (flonum 0.0) ; ((t nil) nil))) ; (set-ups nil (if (equal (cdar l) no-op) ; set-ups ; (cons `(store (arraycall ,type ,var ,(caar l)) ; ,(cdar l)) ; set-ups))) ; (l arg (cdr l))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator)))) ; ;#+PDP10 ;(defprop :sfa-function t :defstruct-option) ; ;#+PDP10 ;(defprop :sfa-name t :defstruct-option) ; ;#+PDP10 ;(defstruct-define-type :sfa ; (:keywords :sfa-function :sfa-name) ; (:cons ; (arg description etc) :alist ; (do ((creator `(sfa-create ,(or (cdr (or (assq ':sfa-function etc) ; (assq ':sfa-function (defstruct-description-property-alist)))) ; `',(defstruct-description-name)) ; ,(defstruct-description-size) ; ,(or (cdr (or (assq ':sfa-name etc) ; (assq ':sfa-name (defstruct-description-property-alist)))) ; `',(defstruct-description-name)))) ; (l arg (cdr l)) ; (var (gensym)) ; (set-ups nil (if (null (cdar l)) ; set-ups ; (cons `(sfa-store ,var ,(caar l) ; ,(cdar l)) ; set-ups)))) ; ((null l) ; (if set-ups ; `((lambda (,var) ; ,@(nreverse set-ups) ; ,var) ; ,creator) ; creator)))) ; (:ref ; (n description arg) ; description ;ignored ; `(sfa-get ,arg ,n))) ; ;#+PDP10 ;(defstruct-define-type :hunk ; (:named :named-hunk) ; (:cons ; (arg description etc) :list ; description ;ignored ; etc ;ignored ; (if arg ; `(hunk . ,(nconc (cdr arg) (ncons (car arg)))) ; (defstruct-error "No slots in hunk type defstruct"))) ; (:ref ; (n description arg) ; description ;ignored ; `(cxr ,n ,arg))) ; ;#+PDP10 ;(defstruct-define-type :named-hunk ; :named (:overhead 1) ; (:cons ; (arg description etc) :list ; etc ;ignored ; (if arg ; `(hunk ',(defstruct-description-name) ; . ,(nconc (cdr arg) (ncons (car arg)))) ; `(hunk ',(defstruct-description-name) nil))) ; (:ref ; (n description arg) ; description ;ignored ; (cond ((= n 0) `(cxr 0 ,arg)) ; (t `(cxr ,(1+ n) ,arg))))) ; ; PSL change ;#+(or PDP10 NIL) (defstruct-define-type :vector (:named :named-vector) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ,@arg)) (:ref (n description arg) description ;ignored `(vref ,arg ,n))) ;added for PSL (defstruct-define-type :named-vector (:keywords :make-vector) :named (:overhead 1) (:cons (arg description etc) :list description ;ignored etc ;ignored `(vector ',(defstruct-description-name) ,@arg)) (:ref (n description arg) description ;ignored `(vref ,arg ,(add1 n)))) ;#+(or PDP10 NIL) ;;;;Do this (much) better someday: ;(defstruct-define-type :extend ; :named ; (:defstruct (description) ; (and (defstruct-description-include) ; (error "--structure of type extend cannot include another." ; (defstruct-description-name))) ; (let* ((name (defstruct-description-name)) ; (ica-name (append-symbols 'internal-cons-a- name)) ; (v-slots nil)) ; (do ((i (defstruct-description-size) (1- i))) ; ((zerop i)) ; (push (do ((l (defstruct-description-slot-alist) (cdr l)) ; (n (1- i))) ;; ((null l) (let ((base 10.) ; (*nopoint t)) ; (implode (cons #/# (exploden n))))) ; (let ((slot-description (cdar l))) ; (and (= (defstruct-slot-description-number) n) ; (null (defstruct-slot-description-ppss)) ; (return (caar l))))) ; v-slots)) ; (push (cons 'extend-internal-conser ica-name) ; (defstruct-description-property-alist)) ; `((defvst (,name (no-selector-macros) (constructor ,ica-name)) ; ,@v-slots)))) ; (:cons (arg description etc) alist ; etc ;ignored ; (do ((alist arg (cdr alist)) ; (var (gensym)) ; (name (defstruct-description-name)) ; (conser `(,(cdr (assq 'extend-internal-conser ; (defstruct-description-property-alist))))) ; (inits nil (if (null (cdar alist)) ; inits ; (cons `(setf (|defvst-reference-by-name/|| ; ,name ,(caar alist) ,conser ,var) ; ,(cdar alist)) ; inits)))) ; ((null alist) ; (if (null inits) ; conser ; `((lambda (,var) ; ,.inits ; ,var) ; ,conser))))) ; (:ref (n description arg) ; `(|defvst-reference-by-name/|| ; ,(defstruct-description-name) ,n ,defstruct-ref-macro-name ,arg))) ; (defstruct-define-type :list (:named :named-list) (:cons (arg description etc) :list description ;ignored etc ;ignored `(list . ,arg)) (:ref (n description arg) description ;ignored #+Multics `(,(let ((i (\ n 4))) (cond ((= i 0) 'car) ((= i 1) 'cadr) ((= i 2) 'caddr) (t 'cadddr))) ,(do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(add1 n)))) ; #-Multics `(nth ,n ,arg))) (defstruct-define-type :named-list :named (:overhead 1) (:cons (arg description etc) :list etc ;ignored `(list ',(defstruct-description-name) . ,arg)) (:ref (n description arg) description ;ignored ; #+Multics `(,(let ((i (\ (1+ n) 4))) ; (cond ((= i 0) 'car) ; ((= i 1) 'cadr) ; ((= i 2) 'caddr) ; (t 'cadddr))) ; ,(do ((a arg `(cddddr ,a)) ; (i (// (1+ n) 4) (1- i))) ; ((= i 0) a))) ; PSL change incompatible NTH #-Multics `(nth ,arg ,(+ n 2)))) ; #-Multics `(nth ,(1+ n) ,arg))) (defstruct-define-type :list* (:cons (arg description etc) :list description ;ignored etc ;ignored `(list* . ,arg)) (:ref (n description arg) ; PSL change 1- ==> sub1 (let ((size (sub1 (defstruct-description-size)))) ; (let ((size (1- (defstruct-description-size)))) #+Multics (do ((a arg `(cddddr ,a)) (i (// n 4) (1- i))) ((= i 0) (let* ((i (\ n 4)) (a (cond ((= i 0) a) ((= i 1) `(cdr ,a)) ((= i 2) `(cddr ,a)) (t `(cdddr ,a))))) (if (< n size) `(car ,a) a)))) #-Multics (if (< n size) ; PSL change incompatible NTH `(nth ,arg ,(add1 n)) `(pnth ,arg ,(add1 n))))) ; `(nth ,n ,arg) ; `(nthcdr ,n ,arg)))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type list* cannot include another" (defstruct-description-name))) nil)) (defstruct-define-type :tree (:cons (arg description etc) :list etc ;ignored (if (null arg) (defstruct-error "defstruct cannot make an empty tree" (defstruct-description-name))) (make-tree-for-defstruct arg (defstruct-description-size))) (:ref (n description arg) (do ((size (defstruct-description-size)) (a arg) (tem)) (()) (cond ((= size 1) (return a)) ; PSL change // ==> / ((< n (setq tem (/ size 2))) ; ((< n (setq tem (// size 2))) (setq a `(car ,a)) (setq size tem)) (t (setq a `(cdr ,a)) (setq size (- size tem)) (setq n (- n tem)))))) (:defstruct (description) (and (defstruct-description-include) (defstruct-error "Structure of type tree cannot include another" (defstruct-description-name))) nil)) (defun make-tree-for-defstruct (arg size) (cond ((= size 1) (car arg)) ((= size 2) `(cons ,(car arg) ,(cadr arg))) (t (do ((a (cdr arg) (cdr a)) ; PSL change // ==> /, 1- ==> sub1 (m (/ size 2)) (n (sub1 (/ size 2)) (sub1 n))) ; (m (// size 2)) ; (n (1- (// size 2)) (1- n))) ((zerop n) `(cons ,(make-tree-for-defstruct arg m) ,(make-tree-for-defstruct a (- size m)))))))) ;(defstruct-define-type :fixnum ; (:cons ; (arg description etc) :list ; etc ;ignored ; (and (or (null arg) ; (not (null (cdr arg)))) ; (defstruct-error ; "Structure of type fixnum must have exactly 1 slot to be constructable" ; (defstruct-description-name))) ; (car arg)) ; (:ref ; (n description arg) ; n ;ignored ; description ;ignored ; arg)) ; #+Multics (defprop :external-ptr t :defstruct-option) #+Multics (defstruct-define-type :external (:keywords :external-ptr) (:cons (arg description etc) :alist (let ((ptr (cdr (or (assq ':external-ptr etc) (assq ':external-ptr (defstruct-description-property-alist)) (defstruct-error "No pointer given for external array" (defstruct-description-name)))))) (do ((creator `(array nil external ,ptr ,(defstruct-description-size))) (var (gensym)) (alist arg (cdr alist)) (inits nil (cons `(store (arraycall fixnum ,var ,(caar alist)) ,(cdar alist)) inits))) ((null alist) (if (null inits) creator `((lambda (,var) ,.inits ,var) ,creator)))))) (:ref (n description arg) description ;ignored `(arraycall fixnum ,arg ,n))) ;(defvar *defstruct-examine&deposit-arg*) ; ;(defun defstruct-examine (*defstruct-examine&deposit-arg* ; name slot-name) ; (eval (list (defstruct-slot-description-ref-macro-name ; (defstruct-examine&deposit-find-slot-description ; name slot-name)) ; '*defstruct-examine&deposit-arg*))) ; ;(defvar *defstruct-examine&deposit-val*) ; ;(defun defstruct-deposit (*defstruct-examine&deposit-val* ; *defstruct-examine&deposit-arg* ; name slot-name) ; (eval (list 'setf ; (list (defstruct-slot-description-ref-macro-name ; (defstruct-examine&deposit-find-slot-description ; name slot-name)) ; '*defstruct-examine&deposit-arg*) ; '*defstruct-examine&deposit-val*))) ;#Q ;(defun defstruct-get-locative (*defstruct-examine&deposit-arg* ; name slot-name) ; (let ((slot-description (defstruct-examine&deposit-find-slot-description ; name slot-name))) ; (or (null (defstruct-slot-description-ppss)) ; (defstruct-error ; "You cannot get a locative to a byte field" ; slot-name 'in name)) ; (eval (list 'locf ; (list (defstruct-slot-description-ref-macro-name) ; '*defstruct-examine&deposit-arg*))))) ; ;(defun defstruct-examine&deposit-find-slot-description (name slot-name) ; (let ((description (get-defstruct-description name))) ; (let ((slot-description ; (cdr (or (assq slot-name (defstruct-description-slot-alist)) ; (defstruct-error ; "No such slot in this structure" ; slot-name 'in name)))) ; (type-description ; (or (get (defstruct-description-type) 'defstruct-type-description) ; (defstruct-error ; "Undefined defstruct type" ; (defstruct-description-type))))) ; (or (= (defstruct-type-description-ref-no-args) 1) ; (defstruct-error ; "defstruct-examine and defstruct-deposit cannot handle structures of this type" ; (defstruct-description-type))) ; slot-description))) ; ; PSL change ;#+PDP10 ;(defprop defstruct ; #.(and (status feature PDP10) ; (caddr (truename infile))) ; version) ; ;(sstatus feature defstruct) |
Added psl-1983/util/numeric-operators.sl version [12520969cb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Numeric-Operators.SL - Definitions of Numeric Operators with "Fast" Option % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 7 January 1983 (based on the earlier Fast-Int module) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common useful)) % This file defines a set of C-like numeric operators that are a superset of the % numeric operators defined by the Common Lisp compatibility package. % The operators are: % % = Numeric Equal % ~= Numeric Not Equal % < Numeric Less Than % > Numeric Greater Than % <= Numeric Less Than or Equal % >= Numeric Greater Than or Equal % + Numeric Addition % - Numeric Minus or Subtraction % * Numeric Multiplication % / Numeric Division % // Numeric Remainder % ~ Integer Bitwise Logical Not % & Integer Bitwise Logical And % | Integer Bitwise Logical Or % ^ Integer Bitwise Logical Xor % << Integer Bitwise Logical Left Shift % >> Integer Bitwise Logical Right Shift % The switch FAST-INTEGERS controls an option that provides for an efficient % compiled implementation of these operators using Syslisp arithmetic. When the % switch is on, uses of these operators will compile into the corresponding % Syslisp arithmetic operators, which generally are open-compiled and fast. % However, the Syslisp operators perform machine arithmetic on untagged % integers: they will work only if their inputs are untagged integers, and they % produce untagged integer outputs. The (undocumented) functions Int2Sys and % Sys2Int can be used to convert between tagged Lisp integers and Syslisp % integers; however, no conversion is needed to convert between INUMs and % Syslisp integers within the valid range of INUMs. % This module modifies the FOR macro to use the numeric operators to implement % the FROM clause; thus, the FOR statement will use Syslisp arithmetic when the % FAST-INTEGERS switch is on. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % The Implementation: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generic definitions of functions defined in the Common Lisp package: (de = (a b) (EqN a b)) (de < (a b) (LessP a b)) (de > (a b) (GreaterP a b)) (de <= (a b) (LEq a b)) (de >= (a b) (GEq a b)) (de + (a b) (Plus2 a b)) (de * (a b) (Times2 a b)) (defmacro - args (cond ((null (cdr args)) `(fast-minus ,@args)) ((null (cddr args)) `(fast-difference ,@args)) (t (left-expand args 'fast-difference)))) (defmacro / args (cond ((null (cdr args)) `(recip ,(car args))) ((null (cddr args)) `(fast-quotient ,@args)) (t (left-expand args 'fast-quotient)))) % Generic definitions of functions not defined by the Common Lisp package: (de ~= (a b) (not (EqN a b))) (de fast-minus (a) (Minus a)) (de fast-difference (a b) (Difference a b)) (de fast-quotient (a b) (Quotient a b)) (de // (a b) (Remainder a b)) (de ~ (a) (LNot a)) (de & (a b) (LAnd a b)) (de | (a b) (LOr a b)) (de ^ (a b) (LXor a b)) (de << (a b) (LShift a b)) (de >> (a b) (LShift a (Minus b))) % Enable and Disable "fast" compiled definitions: (fluid '(*fast-integers)) (put 'fast-integers 'simpfg '((T (enable-fast-numeric-operators)) (NIL (disable-fast-numeric-operators)) )) (de enable-fast-numeric-operators () (put '= 'cmacro '(lambda (a b) (WEQ a b))) (put '~= 'cmacro '(lambda (a b) (WNEQ a b))) (put '< 'cmacro '(lambda (a b) (WLessP a b))) (put '> 'cmacro '(lambda (a b) (WGreaterP a b))) (put '<= 'cmacro '(lambda (a b) (WLEQ a b))) (put '>= 'cmacro '(lambda (a b) (WGEQ a b))) (put '+ 'cmacro '(lambda (a b) (WPlus2 a b))) (put 'fast-difference 'cmacro '(lambda (a b) (WDifference a b))) (put 'fast-minus 'cmacro '(lambda (a) (WDifference 0 a))) (put '* 'cmacro '(lambda (a b) (WTimes2 a b))) (put 'fast-quotient 'cmacro '(lambda (a b) (WQuotient a b))) (put '// 'cmacro '(lambda (a b) (WRemainder a b))) (put '~ 'cmacro '(lambda (a) (WNot a))) (put '& 'cmacro '(lambda (a b) (WAnd a b))) (put '| 'cmacro '(lambda (a b) (WOr a b))) (put '^ 'cmacro '(lambda (a b) (WXor a b))) (put '<< 'cmacro '(lambda (a b) (WShift a b))) (put '>> 'cmacro '(lambda (a b) (WShift a (WDifference 0 b)))) ) (de disable-fast-numeric-operators () (remprop '= 'cmacro) (remprop '~= 'cmacro) (remprop '< 'cmacro) (remprop '> 'cmacro) (remprop '<= 'cmacro) (remprop '>= 'cmacro) (remprop '+ 'cmacro) (remprop 'fast-difference 'cmacro) (remprop 'fast-minus 'cmacro) (remprop '* 'cmacro) (remprop 'fast-quotient 'cmacro) (remprop '// 'cmacro) (remprop '~ 'cmacro) (remprop '& 'cmacro) (remprop '| 'cmacro) (remprop '^ 'cmacro) (remprop '<< 'cmacro) (remprop '>> 'cmacro) ) % Here we redefine the FROM clause of FOR statements: (fluid '(for-vars* for-outside-vars* for-tests* for-prologue* for-conditions* for-body* for-epilogue* for-result*)) (de for-from-function (clause) (let* ((var (car clause)) (var1 (if (pairp var) (car var) var)) (clause (cdr clause)) (init (if (pairp clause) (or (pop clause) 1) 1)) (fin (if (pairp clause) (pop clause) nil)) (fin-var (if (and fin (not (numberp fin))) (gensym) nil)) (step (if (pairp clause) (car clause) 1)) (step-var (if (and step (not (numberp step))) (gensym) nil))) (tconc for-vars* (list* var init (cond (step-var `((+ ,var1 ,step-var))) ((zerop step) nil) ((onep step) `((+ ,var1 1))) ((eqn step -1) `((- ,var1 1))) (t `((+ ,var1 ,step)))))) (if fin-var (tconc for-vars* `(,fin-var ,fin))) (if step-var (tconc for-vars* `(,step-var ,step))) (cond (step-var (tconc for-tests* `(if (< ,step-var 0) (< ,var1 ,(or fin-var fin)) (> ,var1 ,(or fin-var fin))))) ((null fin)) ((minusp step) (tconc for-tests* `(< ,var1 ,(or fin-var fin)))) (t (tconc for-tests* `(> ,var1 ,(or fin-var fin))))))) |
Added psl-1983/util/object-test.sl version [f3ce88430d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (BothTimes (load objects mathlib)) (defflavor ship ((x-position 0.0) (y-position 0.0) (x-velocity 0.0) (y-velocity 0.0) ) () settable-instance-variables ) (setq s (make-instance 'ship)) (=> s x-position) (=> s y-position) (=> s x-velocity) (=> s y-velocity) (=> s describe) (=> s set-x-position 1.0) (=> s set-y-position 2.0) (=> s set-x-velocity 3.0) (=> s set-y-velocity 4.0) (=> s x-position) (=> s y-position) (=> s x-velocity) (=> s y-velocity) (=> s describe) (defmethod (ship speed) () (sqrt (+ (* x-velocity x-velocity) (* y-velocity y-velocity))) ) (=> s speed) (defmethod (ship speed) () (let ((x (=> self x-velocity)) (y (=> self y-velocity))) (sqrt (+ (* x x) (* y y))) )) (=> s speed) (defmethod (ship direction) () (if (= x-velocity 0.0) (if (< y-velocity 0.0) 270.0 90.0) (atanD (/ y-velocity x-velocity)) )) (=> s direction) (setq s1 (make-instance 'ship 'x-position 3.0 'y-position 3.5)) (=> s1 describe) (setq s2 (make-instance 'ship 'x-position 6.0 'y-position -6.0 'x-velocity 10.0 'y-velocity -10.0)) (=> s2 describe) |
Added psl-1983/util/objects.sl version [b50da80015].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Objects.SL - A simple facility for object-oriented programming. % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 22 July 1982 % Revised: 16 February 1983 % % 16-Feb-83 Alan Snyder % Add ev-send function. Rename declare and undeclare to declare-flavor % and undeclare-flavor, to avoid conflict with common lisp declare. % 30-Dec-82 Alan Snyder % General clean-up; rename internal functions and variables; document % method lookup functions; add method lookup trace facility. % 1-Nov-82 Alan Snyder % Added Object-Type function. % 27-Sept-82 Alan Snyder % Removed Variable-Table (which was available only at compile-time); made % Variable-Names available at both compile-time and load-time; now use % Variable-Names to "compile" method bodies. Result: now can compile new % method bodies after loading a "compiled" flavor definition. % 27-Sept-82 Alan Snyder % Evaluating (or loading) a DEFFLAVOR no longer clears the method table, if it % had been defined previously. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (Bothtimes (imports '(common fast-vector))) (imports '(association strings)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NOTE: THIS FILE DEFINES MACROS. IT MUST BE LOADED BEFORE ANY OF THESE % FUNCTIONS ARE USED. The recommended way to do this is to put the statement % (BothTimes (load objects)) at the beginning of your source file. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Summary of Public Functions: % % (defflavor flavor-name (var1 var2 ...) (flav1 flav2 ...) option1 option2 ...) % (defmethod (flavor-name message-name) (arg1 arg2 ...) form1 form2 ...) % % (make-instance 'flavor-name 'var1 value1 ...) % % (=> foo message-name arg1 arg2 ...) % % (send foo 'message-name arg1 arg2 ...) % (lexpr-send foo 'message-name arg1 arg2 ... rest-arg-list) % (lexpr-send-1 foo 'message-name arg-list) % (ev-send foo 'message-name arg-list) {EXPR form} % % (send-if-handles foo 'message-name arg1 arg2 ...) % (lexpr-send-if-handles foo 'message-name arg1 arg2 ... rest-arg-list) % (lexpr-send-1-if-handles foo 'message-name arg-list) % % (instantiate-flavor 'flavor-name init-list) % % (object-type x) --- returns the type of an object, or NIL if not an object % % (object-get-handler x message-name) -- lookup method function (see below) % (object-get-handler-quietly x message-name) % % (trace-method-lookups) - start recording stats about method lookup % (untrace-method-lookups) - stop recording stats about method lookup % (print-method-lookup-info) - untrace and print accumulated stats % % (declare-flavor flavor var1 var2 ...) NOTE: see warnings below! % (undeclare-flavor var1 var2 ...) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Constants, Fluids, and Macros (mere mortals should ignore these) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '($defflavor-expansion-context $object-number-of-reserved-slots $object-flavor-slot $object-debug-slot $defflavor-option-table $method-lookup-stats )) (setf $defflavor-expansion-context NIL) (BothTimes (progn (setf $object-number-of-reserved-slots 2) (setf $object-flavor-slot 0) (setf $object-debug-slot 1) )) (setf $defflavor-option-table (list (cons 'gettable-instance-variables '$defflavor-do-gettable-option) (cons 'settable-instance-variables '$defflavor-do-settable-option) (cons 'initable-instance-variables '$defflavor-do-initable-option) )) % Note the free variable FLAVOR-NAME in this macro: (defmacro $defflavor-error (format . arguments) `(ContinuableError 1000 (BldMsg ,(string-concat "DEFFLAVOR %w: " format) flavor-name . ,arguments) NIL)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DEFFLAVOR - Define a new flavor of Object % % Examples: % % (defflavor complex-number (real-part imaginary-part) ()) % % (defflavor complex-number (real-part imaginary-part) () % gettable-instance-variables % initable-instance-variables % ) % % (defflavor complex-number ((real-part 0.0) % (imaginary-part 0.0) % ) % () % gettable-instance-variables % (settable-instance-variables real-part) % ) % % An object is represented by a vector; instance variables are allocated % specific slots in the vector. Do not use names like "IF" or "WHILE" for % instance varibles: they are translated freely within method bodies (see % DEFMETHOD). Initial values for instance variables may be specified as % arguments to MAKE-INSTANCE, or as initializing expressions in the variable % list, or may be supplied by an INIT method (see MAKE-INSTANCE). % Uninitializied instance variables are bound to *UNBOUND*. % % The component flavor list currently must be null. Recognized options are: % % (GETTABLE-INSTANCE-VARIABLES var1 var2 ...) % (SETTABLE-INSTANCE-VARIABLES var1 var2 ...) % (INITABLE-INSTANCE-VARIABLES var1 var2 ...) % GETTABLE-INSTANCE-VARIABLES [make all instance variables GETTABLE] % SETTABLE-INSTANCE-VARIABLES [make all instance variables SETTABLE] % INITABLE-INSTANCE-VARIABLES [make all instance variables INITABLE] % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro defflavor (flavor-name variable-list flavor-list . options-list) (prog (var-names % List of valid instance variable names init-code % body of DEFAULT-INIT method describe-code % body of DESCRIBE method defmethod-list % list of created DEFMETHODs var-options % AList mapping var names to option list initable-vars % list of INITABLE instance variables ) (desetq (var-names init-code) ($defflavor-process-varlist flavor-name variable-list) ) (setf describe-code ($defflavor-build-describe flavor-name var-names)) (setf var-options ($defflavor-process-options-list flavor-name var-names options-list) ) (setf defmethod-list ($defflavor-create-methods flavor-name var-options)) (setf initable-vars ($defflavor-initable-vars flavor-name var-options)) (put flavor-name 'variable-names var-names) (setf defmethod-list (cons `(defmethod (,flavor-name default-init) () . ,init-code) defmethod-list)) (setf defmethod-list (cons `(defmethod (,flavor-name describe) () . ,describe-code) defmethod-list)) (if flavor-list ($defflavor-error "Component Flavors not implemented") ) % The previous actions happen at compile or dskin time. % The following actions happen at dskin or load time. (return `(progn (if (not (get ',flavor-name 'method-table)) (put ',flavor-name 'method-table (association-create))) (put ',flavor-name 'instance-vector-size ,(+ #.$object-number-of-reserved-slots (length var-names))) (put ',flavor-name 'variable-names ',var-names) (put ',flavor-name 'initable-variables ',initable-vars) ,@defmethod-list '(flavor ,flavor-name) % for documentation only )) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DEFMETHOD - Define a method on an existing flavor. % % Examples: % % (defmethod (complex-number real-part) () % real-part) % % (defmethod (complex-number set-real-part) (new-real-part) % (setf real-part new-real-part)) % % The body of a method can freely refer to the instance variables of the flavor % and can set them using SETF. Each method defines a function FLAVOR$METHOD % whose first argument is SELF, the object that is performing the method. All % references to instance variables (except within vectors or quoted lists) are % translated to an invocation of the form (IGETV SELF n). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro defmethod ((flavor-name method-name) argument-list . body) (setf argument-list (cons 'self argument-list)) (let ((function-name ($defflavor-function-name flavor-name method-name))) (put function-name 'source-code `(lambda ,argument-list . ,body)) (let ((new-code ($create-method-source-code function-name flavor-name))) % The previous actions happen at compile or dskin time. % The following actions happen at dskin or load time. `(progn ($flavor-define-method ',flavor-name ',method-name ',function-name) (putd ',function-name 'expr ',new-code) '(method ,flavor-name ,method-name) % for documentation only )))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % => - Convenient form for sending a message % % Examples: % % (=> r real-part) % % (=> r set-real-part 1.0) % % The message name is not quoted. Arguments to the method are supplied as % arguments to =>. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro => (object message-name . arguments) `(send ,object ',message-name . ,arguments)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SEND - Send a Message (Evaluated Message Name) % % Examples: % % (send r 'real-part) % % (send r 'set-real-part 1.0) % % Note that the message name is quoted. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro send (target-form method-form . argument-forms) % If the method name is known at compile time (i.e., the method-form is of % the form (QUOTE <id>)) and the target is either SELF (within the body of a % DEFMETHOD) or a variable which has been declared (using DECLARE-FLAVOR), % then optimize the form to a direct invocation of the method function. (if (and (PairP method-form) (eq (car method-form) 'quote) (not (null (cdr method-form))) (IdP (cadr method-form)) ) (let ((method-name (cadr method-form))) (cond ((and (eq target-form 'self) $defflavor-expansion-context) ($self-send-expansion method-name argument-forms)) ((and (IdP target-form) (get target-form 'declared-type)) ($direct-send-expansion target-form method-name argument-forms)) (t ($normal-send-expansion target-form method-form argument-forms)) )) ($normal-send-expansion target-form method-form argument-forms) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SEND-IF-HANDLES - Conditionally Send a Message (Evaluated Message Name) % % Examples: % % (send-if-handles r 'real-part) % % (send-if-handles r 'set-real-part 1.0) % % SEND-IF-HANDLES is like SEND, except that if the object defines no method % to handle the message, no error is reported and NIL is returned. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro send-if-handles (object message-name . arguments) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF*** ,@arguments))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND - Send a Message (Explicit "Rest" Argument List) % % Examples: % % (lexpr-send foo 'bar a b c list) % % The last argument to LEXPR-SEND is a list of the remaining arguments. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send (object message-name . arguments) (if arguments (let ((explicit-args (reverse (cdr (reverse arguments)))) (last-arg (LastCar arguments)) ) (if explicit-args `(lexpr-send-1 ,object ,message-name (append (list ,@explicit-args) ,last-arg)) `(lexpr-send-1 ,object ,message-name ,last-arg) ) ) `(let ((***SELF*** ,object)) (apply (object-get-handler ***SELF*** ,message-name) (list ***SELF***))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-IF-HANDLES % % This is the same as LEXPR-SEND, except that no error is reported % if the object fails to handle the message. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-if-handles (object message-name . arguments) (if arguments (let ((explicit-args (reverse (cdr (reverse arguments)))) (last-arg (LastCar arguments)) ) (if explicit-args `(lexpr-send-1-if-handles ,object ,message-name (append (list ,@explicit-args) ,last-arg)) `(lexpr-send-1-if-handles ,object ,message-name ,last-arg) ) ) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (list ***SELF***)))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-1 - Send a Message (Explicit Argument List) % % Examples: % % (lexpr-send-1 r 'real-part nil) % % (lexpr-send-1 r 'set-real-part (list 1.0)) % % Note that the message name is quoted and that the argument list is passed as a % single argument to LEXPR-SEND-1. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-1 (object message-name argument-list) `(let ((***SELF*** ,object)) (apply (object-get-handler ***SELF*** ,message-name) (cons ***SELF*** ,argument-list)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % EV-SEND - EXPR form of LEXPR-SEND-1 % % EV-SEND is just like LEXPR-SEND-1, except that it is an EXPR instead of % a MACRO. Its sole purpose is to be used as a run-time function object, % for example, as a function argument to a function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de ev-send (obj msg arg-list) (lexpr-send-1 obj msg arg-list) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % LEXPR-SEND-1-IF-HANDLES % % This is the same as LEXPR-SEND-1, except that no error is reported if the % object fails to handle the message. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro lexpr-send-1-if-handles (object message-name argument-list) `(let* ((***SELF*** ,object) (***HANDLER*** (object-get-handler-quietly ***SELF*** ,message-name)) ) (and ***HANDLER*** (apply ***HANDLER*** (cons ***SELF*** ,argument-list))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % MAKE-INSTANCE - Create a new instance of a flavor. % % Examples: % % (make-instance 'complex-number) % (make-instance 'complex-number 'real-part 0.0 'imaginary-part 1.0) % % MAKE-INSTANCE accepts an optional initialization list, consisting of % alternating pairs of instance variable names and corresponding initial values. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro make-instance (flavor-name . init-plist) `(instantiate-flavor ,flavor-name (list . ,init-plist) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % INSTANTIATE-FLAVOR % % This is the same as MAKE-INSTANCE, except that the initialization list is % provided as a single (required) argument. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun instantiate-flavor (flavor-name init-plist) (let* ((vector-size (get flavor-name 'instance-vector-size))) (if vector-size (let* ((object (MkVect (- vector-size 1))) ) (setf (igetv object #.$object-flavor-slot) flavor-name) (setf (igetv object #.$object-debug-slot) NIL) (for (from i #.$object-number-of-reserved-slots (- vector-size 1) 1) (do (iputv object i '*UNBOUND*)) ) ($object-perform-initialization object init-plist) (send-if-handles object 'default-init) (send-if-handles object 'init init-plist) object ) (ContError 0 "Attempt to instantiate undefined flavor: %w" flavor-name (Instantiate-Flavor flavor-name init-plist)) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Object-Type % % The OBJECT-TYPE function returns the type (an ID) of the specified object, or % NIL, if the argument is not an object. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun object-type (object) (if (and (VectorP object) (> (UpbV object) 1)) (let ((flavor-name (igetv object #.$object-flavor-slot))) (if (IdP flavor-name) flavor-name) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Method Lookup % % The following functions return method functions given an object and a message % name. The returned function can be invoked, passing the object as the first % argument and the message arguments as the remaining arguments. For example, % the expression (=> foo gorp a b c) is equivalent to: % % (apply (object-get-handler foo 'gorp) (list foo a b c)) % % It can be useful for efficiency reasons to lookup a method function once and % then apply it many times to the same object. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun object-get-handler (object message-name) % Returns the method function that implements the specified message when sent % to the specified object. If no such method exists, generate a continuable % error. (let ((flavor-name (object-type object))) (cond (flavor-name (let ((function-name ($flavor-fetch-method flavor-name message-name))) (or function-name (ContError 1000 "Flavor %w has no method %w." flavor-name message-name (object-get-handler object message-name) )))) (t (ContError 1000 "Object %w cannot receive messages." object (object-get-handler object message-name) ))))) (defun object-get-handler-quietly (object message-name) % Returns the method function that implements the specified message when sent % to the specified object, if it exists, otherwise returns NIL. (let ((flavor-name (object-type object))) (if flavor-name ($flavor-fetch-method flavor-name message-name)))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Method Lookup Tracing % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de trace-method-lookups () % Begin accumulating information about method lookups (invocations of % object-get-handler). The statistics are reset. (setf $method-lookup-stats (association-create)) (copyd 'object-get-handler '$traced-object-get-handler) ) (de untrace-method-lookups () % Stop accumulating information about method lookups. (copyd 'object-get-handler '$untraced-object-get-handler) ) (de print-method-lookup-info () % Stop accumulating information about method lookups and print a summary of % the accumulated information about method lookups. This summary shows which % methods were looked up and how many times each method was looked up. (untrace-method-lookups) (load gsort stringx) (setf $method-lookup-stats (gsort $method-lookup-stats '$method-info-sortfn)) (for (in pair $method-lookup-stats) (do (printf "%w %w%n" (string-pad-left (bldmsg "%w" (cdr pair)) 6) (car pair)))) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DECLARE-FLAVOR % % *** Read these warnings carefully! *** % % The DECLARE-FLAVOR macro allows you to declare that a specific symbol is % bound to an object of a specific flavor. This allows the flavors % implementation to eliminate the run-time method lookup normally associated % with sending a message to that variable, which can result in an appreciable % improvement in execution speed. This feature is motivated solely by % efficiency considerations and should be used ONLY where the performance % improvement is critical. % % Details: if you declare the variable X to be bound to an object of flavor % FOO, then WITHIN THE CONTEXT OF THE DECLARATION (see below), expressions of % the form (=> X GORP ...) or (SEND X 'GORP ...) will be replaced by function % invocations of the form (FOO$GORP X ...). Note that there is no check made % that the flavor FOO actually contains a method GORP. If it does not, then a % run-time error "Invocation of undefined function FOO$GORP" will be reported. % % WARNING: The DECLARE-FLAVOR feature is not presently well integrated with % the compiler. Currently, the DECLARE-FLAVOR macro may be used only as a % top-level form, like the PSL FLUID declaration. It takes effect for all % code evaluated or compiled henceforth. Thus, if you should later compile a % different file in the same compiler, the declaration will still be in % effect! THIS IS A DANGEROUS CROCK, SO BE CAREFUL! To avoid problems, I % recommend that DECLARE-FLAVOR be used only for uniquely-named variables. % The effect of a DECLARE-FLAVOR can be undone by an UNDECLARE-FLAVOR, which % also may be used only as a top-level form. Therefore, it is good practice % to bracket your code in the source file with a DECLARE-FLAVOR and a % corresponding UNDECLARE-FLAVOR. % % Here are the syntactic details: % % (DECLARE-FLAVOR FLAVOR-NAME VAR1 VAR2 ...) % (UNDECLARE-FLAVOR VAR1 VAR2 ...) % % *** Did you read the above warnings??? *** % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro declare-flavor (flavor-name . variable-names) (prog () % This macro returns NIL! (if (not (IdP flavor-name)) (StdError (BldMsg "Flavor name in DECLARE-FLAVOR is not an ID: %p" flavor-name)) % else (for (in var-name variable-names) (do (if (not (IdP var-name)) (StdError (BldMsg "Variable name in DECLARE-FLAVOR is not an ID: %p" var-name)) % else (put var-name 'declared-type flavor-name) ))) ))) (dm undeclare-flavor (form) (prog () % This macro returns NIL! (for (in var-name (cdr form)) (do (if (not (IdP var-name)) (StdError (BldMsg "Variable name in UNDECLARE-FLAVOR is not an ID: %p" var-name)) % else (remprop var-name 'declared-type) ))) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Representation Information: % % (You don't need to know any of this to use this stuff.) % % A flavor-name is an ID. It has the following properties: % % VARIABLE-NAMES A list of the instance variables of the flavor, in % order of their location in the instance vector. This % property exists at compile time, dskin time, and load % time. % % INITABLE-VARIABLES A list of the instance variables that have been declared % to be INITABLE. This property exists at dskin time and % at load time. % % METHOD-TABLE An association list mapping each method name (ID) % defined for the flavor to the corresponding function % name (ID) that implements the method. This property % exists at dskin time and at load time. % % INSTANCE-VECTOR-SIZE An integer that specifies the number of elements in the % vector that represents an instance of this flavor. This % property exists at dskin time and at load time. It is % used by MAKE-INSTANCE. % % The function that implements a method has a name of the form FLAVOR$METHOD. % Each such function ID has the following properties: % % SOURCE-CODE A list of the form (LAMBDA (SELF ...) ...) which is the % untransformed source code for the method. This property % exists at compile time and dskin time. % % Implementation Note: % % A tricky aspect of this code is making sure that the right things happen at % the right time. When a source file is read and evaluated (using DSKIN), then % everything must happen at once. However, when a source file is compiled to % produce a FASL file, then some actions must be performed at compile-time, % whereas other actions are supposed to occur when the FASL file is loaded. % Actions to occur at compile time are performed by macros; actions to occur at % load time are performed by the forms returned by macros. % % Another goal of the implementation is to avoid consing whenever possible % during method invocation. The current scheme prefers to compile into (APPLY % HANDLER (LIST args...)), for which the PSL compiler will produce code that % performs no consing. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Internal Functions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defun $object-perform-initialization (object init-plist) % Perform the initialization of instance variables in OBJECT as specified by % the INIT-PLIST, which contains alternating instance variable names and % initializing values. (let* ((flavor-name (igetv object #.$object-flavor-slot)) (initable-vars (get flavor-name 'initable-variables)) (variable-names (get flavor-name 'variable-names)) name value ) (while init-plist (setf name (car init-plist)) (setf init-plist (cdr init-plist)) (if init-plist (progn (setf value (car init-plist)) (setf init-plist (cdr init-plist))) (setf value nil) ) (if (memq name initable-vars) (iputv object ($object-lookup-variable-in-list variable-names name) value) (ContinuableError 1000 (BldMsg "%p not an initable instance variable of flavor %w" name flavor-name) NIL) )))) (defun $object-lookup-variable-in-list (variable-names name) (for (in v-name variable-names) (for i #.$object-number-of-reserved-slots (+ i 1)) (do (if (eq v-name name) (exit i))) (returns nil) )) (defun $substitute-for-symbols (U var-names) % Substitute in U for all unquoted instances of the symbols defined in % Var-Names. Also, change SETQ to SETF in forms, since only SETF can handle % the substituted forms. (cond ((IdP U) (let ((address ($object-lookup-variable-in-list var-names U))) (if address (list 'igetv 'self address) U) )) ((PairP U) (cond ((eq (car U) 'quote) U) ((eq (car U) 'setq) (cons 'setf ($substitute-for-symbols (cdr U) var-names))) (t (cons ($substitute-for-symbols (car U) var-names) ($substitute-for-symbols (cdr U) var-names))) ) ) (t U) )) (defun $flavor-define-method (flavor-name method-name function-name) (let ((method-table (get flavor-name 'method-table))) (association-bind method-table method-name function-name))) (copyd 'flavor-define-method '$flavor-define-method) % for compatibility! (defun $flavor-fetch-method (flavor-name method-name) % Returns NIL if the method is undefined. (let* ((method-table (get flavor-name 'method-table)) (assoc-pair (atsoc method-name method-table)) ) (if assoc-pair (cdr assoc-pair) nil))) (defun $create-method-source-code (function-name flavor-name) (let ((var-names (get flavor-name 'variable-names)) (source-code (get function-name 'source-code)) ($defflavor-expansion-context flavor-name) % FLUID variable! ) ($substitute-for-symbols (MacroExpand source-code) var-names) )) (defun $defflavor-process-varlist (flavor-name variable-list) % Process the instance variable list of a DEFFLAVOR. Create a list of valid % instance variable names and a list of forms to perform default % initialization of instance variables. (prog (var-names default-init-code init-form v) (for (in v-entry variable-list) (do (cond ((and (PairP v-entry) (IdP (car v-entry))) (setf v (car v-entry)) (setf init-form (cdr v-entry)) (if init-form (setf init-form (car init-form))) (setf init-form `(if (eq ,v '*UNBOUND*) (setf ,v ,init-form))) (setf default-init-code (aconc default-init-code init-form)) ) ((IdP v-entry) (setf v v-entry)) (t ($defflavor-error "Bad item in variable list: %p" v-entry) (setf v NIL) ) ) (if v (setf var-names (aconc var-names v))) )) (return (list var-names default-init-code)))) (defun $defflavor-build-describe (flavor-name var-names) % Return a list of forms that print a description of an instance. (let ((describe-code `((printf ,(string-concat "An object of flavor " (id2string flavor-name) ", has instance variable values:%n"))))) (for (in v var-names) (do (setf describe-code (aconc describe-code `(printf " %w: %p%n" ',v ,v))) )) (aconc describe-code NIL) )) (defun $defflavor-process-options-list (flavor-name var-names options-list) % Return an AList mapping var-names to a list of options (let ((var-options (association-create))) (for (in option options-list) (do ($defflavor-process-option flavor-name var-names var-options option) )) var-options )) (defun $defflavor-process-option (flavor-name var-names var-options option) % Process the option by modifying the AList VAR-OPTIONS. (let (option-keyword option-arguments) (cond ((PairP option) (setf option-keyword (car option)) (setf option-arguments (cdr option)) ) ((IdP option) (setf option-keyword option) ) (t ($defflavor-error "Bad item in options list: %p" option) (setf option-keyword '*NONE*) ) ) (when (neq option-keyword '*NONE*) (let ((pair (atsoc option-keyword $defflavor-option-table))) (if (null pair) ($defflavor-error "Bad option in options list: %w" option) (apply (cdr pair) (list flavor-name var-names var-options option-arguments)) ))))) (defun $defflavor-do-gettable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'GETTABLE) ) (defun $defflavor-do-settable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'SETTABLE) ) (defun $defflavor-do-initable-option (flavor-name var-names var-options args) ($defflavor-insert-keyword flavor-name var-names var-options args 'INITABLE) ) (defun $defflavor-insert-keyword (flavor-name var-names var-options args key) (if (null args) (setf args var-names)) % default: applies to all variables (for (in var args) % for each specified instance variable (do (if (not (memq var var-names)) ($defflavor-error "%p (in keyword option) not a variable." var) % else (let ((pair (atsoc var var-options))) (when (null pair) (setf pair (cons var nil)) (aconc var-options pair) ) (setf (cdr pair) (adjoinq key (cdr pair))) ))))) (defun $defflavor-define-access-function (flavor-name var-name) `(defmethod (,flavor-name ,var-name) () ,var-name)) (defun $defflavor-define-update-function (flavor-name var-name) (let ((method-name (intern (string-concat "SET-" (id2string var-name))))) `(defmethod (,flavor-name ,method-name) (new-value) (setf ,var-name new-value)))) (defun $defflavor-create-methods (flavor-name var-options) % Return a list of DEFMETHODs for GETTABLE and SETTABLE instance variables. (let ((defmethod-list)) (for (in pair var-options) (do (let ((var-name (car pair)) (keywords (cdr pair)) ) (if (or (memq 'GETTABLE keywords) (memq 'SETTABLE keywords)) (setf defmethod-list (cons ($defflavor-define-access-function flavor-name var-name) defmethod-list ))) (if (memq 'SETTABLE keywords) (setf defmethod-list (cons ($defflavor-define-update-function flavor-name var-name) defmethod-list ))) ))) defmethod-list )) (defun $defflavor-initable-vars (flavor-name var-options) % Return a list containing the names of instance variables that have been % declared to be INITable. (for (in pair var-options) (when (and (PairP pair) (or (memq 'INITABLE (cdr pair)) (memq 'SETTABLE (cdr pair)) ))) (collect (car pair)) ) ) (de $defflavor-function-name (flavor-name method-name) (intern (string-concat (id2string flavor-name) "$" (id2string method-name)))) (de $normal-send-expansion (target-form method-form argument-forms) `(let ((***SELF*** ,target-form)) (apply (object-get-handler ***SELF*** ,method-form) (list ***SELF*** ,@argument-forms)))) (de $self-send-expansion (method-name argument-forms) (cons ($defflavor-function-name $defflavor-expansion-context method-name) (cons 'self argument-forms))) (de $direct-send-expansion (target-id method-name argument-forms) (let ((target-type (get target-id 'declared-type))) (cons ($defflavor-function-name target-type method-name) (cons target-id argument-forms)))) (copyd '$untraced-object-get-handler 'object-get-handler) (de $traced-object-get-handler (obj method-name) (let* ((result ($untraced-object-get-handler obj method-name)) (count (association-lookup $method-lookup-stats result)) ) (association-bind $method-lookup-stats result (if count (+ count 1) 1)) result )) (de $method-info-sortfn (m1 m2) (numbersortfn (cdr m2) (cdr m1)) ) |
Added psl-1983/util/old-prettyprint.sl version [e5c9189a19].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %(!* YPP -- THE PRETTYPRINTER % % <BENSON>YPP.SL.19, 17-Sep-82 09:52:42, Edit by BENSON % Courtesy of IMSSS, with modifications for PSL % % %PP( LST:list ) FEXPR %PRETTYPRINT( X:any ) EXPR % %") (COMPILETIME (FLAG '(WARNING PP-VAL PP-DEF PP-DEF-1 BROKEN GET-GOOD-DEF S2PRINT SPRINT CHRCT SPACES-LEFT SAFE-PPOS PPFLATSIZE PP-SAVINGS POSN1 POSN2 PPOS) 'INTERNALFUNCTION)) (DE WARNING (X) (ERRORPRINTF "*** %L" X)) %(!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (X) (PROGN (SPRINT X 1) (TERPRI))) (DM PP (L) (LIST 'EVPP (LIST 'QUOTE (CDR L)))) (DE EVPP (L) (PROGN (MAPC L (FUNCTION PP1)) (TERPRI) T)) (DE PP1 (EXP) (PROG NIL (COND ((IDP EXP) (PROGN (PP-VAL EXP) (PP-DEF EXP))) (T (PROGN (SPRINT EXP 1) (TERPRI)))))) (DE PP-VAL (ID) (PROG (VAL) (COND ((ATOM (SETQ VAL (ERRORSET ID NIL NIL))) (RETURN NIL))) (TERPRI) (PRIN2 "(SETQ ") (PRIN1 ID) (S2PRINT " '" (CAR VAL)) (PRIN2 ")") (TERPRI))) (DE PP-DEF (ID) (PROG (DEF TYPE ORIG-DEF) (SETQ DEF (GETD ID)) TEST (COND ((NULL DEF) (RETURN (AND ORIG-DEF (WARNING (LIST "Gack. " ID " has no unbroken definition."))))) ((CODEP (CDR DEF)) (RETURN (WARNING (LIST "Can't PP compiled definition for" ID)))) ((AND (NOT ORIG-DEF) (BROKEN ID)) (PROGN (WARNING (LIST "Note:" ID "is broken or traced.")) (SETQ ORIG-DEF DEF) (SETQ DEF (CONS (CAR DEF) (GET-GOOD-DEF ID))) (GO TEST)))) (SETQ TYPE (CAR DEF)) (TERPRI) (SETQ ORIG-DEF (ASSOC TYPE '((EXPR . DE) (MACRO . DM) (FEXPR . DF) (NEXPR . DN)))) (RETURN (PP-DEF-1 (CDR ORIG-DEF) ID (CDDR DEF))))) (DE PP-DEF-1 (FN NAME TAIL) (PROGN (PRIN2 "(") (PRIN1 FN) (PRIN2 " ") (PRIN1 NAME) (PRIN2 " ") (COND ((NULL (CAR TAIL)) (PRIN2 "()")) (T (PRIN1 (CAR TAIL)))) (MAPC (CDR TAIL) (FUNCTION (LAMBDA (X) (S2PRINT " " X)))) (PRIN2 ")") (TERPRI))) (DE BROKEN (X) (GET X 'TRACE)) (DE GET-GOOD-DEF (X) (PROG (XX) (COND ((AND (SETQ XX (GET X 'TRACE)) (SETQ XX (ASSOC 'ORIGINALFN XX))) (RETURN (CDR XX)))))) %(!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (S EXP) (PROGN (OR (GREATERP (SPACES-LEFT) (PLUS (FLATSIZE2 S) (FLATSIZE EXP))) (TERPRI)) (PRIN2 S) (SPRINT EXP (ADD1 (POSN))))) (DE SPRINT (EXP LEFT-MARGIN) (PROG (ORIGINAL-SPACE NEW-SPACE CAR-EXP P-MACRO CADR-MARGIN ELT-MARGIN LBL-MARGIN SIZE) (COND ((ATOM EXP) (PROGN (SAFE-PPOS LEFT-MARGIN (FLATSIZE EXP)) (RETURN (PRIN1 EXP))))) (PPOS LEFT-MARGIN) (SETQ LEFT-MARGIN (ADD1 LEFT-MARGIN)) (SETQ ORIGINAL-SPACE (SPACES-LEFT)) (COND ((PAIRP (SETQ CAR-EXP (CAR EXP))) (PROGN (PRIN2 "(") (SPRINT CAR-EXP LEFT-MARGIN))) ((AND (IDP CAR-EXP) (SETQ P-MACRO (GET CAR-EXP 'PRINTMACRO))) (COND ((AND (STRINGP P-MACRO) (PAIRP (CDR EXP)) (NULL (CDDR EXP))) (PROGN (SAFE-PPOS (POSN1) (FLATSIZE2 P-MACRO)) (PRIN2 P-MACRO) (RETURN (AND (CDR EXP) (SPRINT (CADR EXP) (POSN1)))))) (T (PROGN (RETURN (APPLY P-MACRO (LIST EXP))))))) (T (PROGN (PRIN2 "(") (SAFE-PPOS (POSN1) (FLATSIZE CAR-EXP)) (PRIN1 CAR-EXP)))) (COND ((ATOM (SETQ EXP (CDR EXP))) (GO C))) (SETQ CADR-MARGIN (POSN2)) (SETQ NEW-SPACE (SPACES-LEFT)) (SETQ SIZE (PPFLATSIZE CAR-EXP)) (COND ((NOT (LESSP SIZE ORIGINAL-SPACE)) (SETQ CADR-MARGIN (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) ((OR (LESSP (PPFLATSIZE EXP) NEW-SPACE) (PROG (E1) (SETQ E1 EXP) LP (COND ((PAIRP (CAR E1)) (RETURN NIL)) ((ATOM (SETQ E1 (CDR E1))) (RETURN T)) (T (GO LP))))) (SETQ ELT-MARGIN (SETQ LBL-MARGIN NIL))) ((LESSP NEW-SPACE 24) (PROGN (COND ((NOT (AND (MEMQ CAR-EXP '(PROG LAMBDA SETQ)) (LESSP (PPFLATSIZE (CAR EXP)) NEW-SPACE))) (SETQ CADR-MARGIN LEFT-MARGIN))) (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) ((EQ CAR-EXP 'LAMBDA) (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN))) ((EQ CAR-EXP 'PROG) (PROGN (SETQ ELT-MARGIN CADR-MARGIN) (SETQ LBL-MARGIN LEFT-MARGIN))) ((OR (GREATERP SIZE 14) (AND (GREATERP SIZE 4) (NOT (LESSP (PPFLATSIZE (CAR EXP)) NEW-SPACE)))) (SETQ CADR-MARGIN (SETQ ELT-MARGIN (SETQ LBL-MARGIN LEFT-MARGIN)))) (T (SETQ ELT-MARGIN (SETQ LBL-MARGIN CADR-MARGIN)))) (COND ((ATOM (SETQ CAR-EXP (CAR EXP))) (PROGN (SAFE-PPOS CADR-MARGIN (PPFLATSIZE CAR-EXP)) (PRIN1 CAR-EXP))) (T (SPRINT CAR-EXP CADR-MARGIN))) A (COND ((ATOM (SETQ EXP (CDR EXP))) (GO C))) B (SETQ CAR-EXP (CAR EXP)) (COND ((ATOM CAR-EXP) (PROGN (SETQ SIZE (PPFLATSIZE CAR-EXP)) (COND (LBL-MARGIN (SAFE-PPOS LBL-MARGIN SIZE)) ((LESSP SIZE (SPACES-LEFT)) (PRIN2 " ")) (T (SAFE-PPOS LEFT-MARGIN SIZE))) (PRIN1 CAR-EXP))) (T (SPRINT CAR-EXP (COND (ELT-MARGIN ELT-MARGIN) (T (POSN2)))))) (GO A) C (COND (EXP (PROGN (COND ((LESSP (SPACES-LEFT) 3) (PPOS LEFT-MARGIN))) (PRIN2 " . ") (SETQ SIZE (PPFLATSIZE EXP)) (COND ((GREATERP SIZE (SPACES-LEFT)) (SAFE-PPOS LEFT-MARGIN SIZE))) (PRIN1 EXP)))) (COND ((LESSP (SPACES-LEFT) 1) (PPOS LEFT-MARGIN))) (PRIN2 ")"))) (PUT 'QUOTE 'PRINTMACRO "'") (PUT 'BACKQUOTE 'PRINTMACRO "`") (PUT 'UNQUOTE 'PRINTMACRO ",") (PUT 'UNQUOTEL 'PRINTMACRO ",@") (PUT 'UNQUOTED 'PRINTMACRO ",.") (PUT 'DE 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DM 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DF 'PRINTMACRO (FUNCTION PM-DEF)) (PUT 'DN 'PRINTMACRO (FUNCTION PM-DEF)) (DE PM-DEF (FORM) (PP-DEF-1 (CAR FORM) (CADR FORM) (CDDR FORM))) (DE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES-LEFT NIL (SUB1 (CHRCT))) (DE SAFE-PPOS (N SIZE) (PROG (MIN-N) (SETQ MIN-N (SUB1 (DIFFERENCE (LINELENGTH NIL) SIZE))) (COND ((LESSP MIN-N N) (PROGN (OR (GREATERP MIN-N (POSN1)) (TERPRI)) (PPOS MIN-N))) (T (PPOS N))))) (DE PPFLATSIZE (EXP) (DIFFERENCE (FLATSIZE EXP) (PP-SAVINGS EXP))) (DE PP-SAVINGS (Y) (PROG (N) (COND ((ATOM Y) (RETURN 0)) ((AND (EQ (CAR Y) 'QUOTE) (CDR Y) (NOT (NUMBERP (CADR Y)))) (RETURN (PLUS 7 (PP-SAVINGS (CDR Y)))))) (SETQ N 0) LP (COND ((ATOM Y) (RETURN N))) (SETQ N (PLUS N (PP-SAVINGS (CAR Y)))) (SETQ Y (CDR Y)) (GO LP))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) |
Added psl-1983/util/package.build version [e60ae9d248].
> > | 1 2 | CompileTime load Syslisp; in "package.red"$ |
Added psl-1983/util/package.red version [4af7c710cd].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PACKAGE.RED - Start of small package system % % Author: Martin Griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Friday, 23 October 1981 % Copyright (c) 1981 University of Utah % % Idea is that Hierachical ObLists created % Permit Root at NIL, ie Forest Of Trees % CurrentPackage!* is Name of package % Structure [Name,Father,Getfn,PutFn,RemFn,MapFn] under 'Package % Have set of Localxxxx(s) and Pathxxxx(s) for % xxxx= InternP Intern RemOb MapObl % By Storing Functions, have possibility of different % Oblist models at each level (Abstract data Type for Local Obarray ) CompileTime << Lisp Procedure PACKAGE x; %. Called from Token reader NIL; % dummy % To chnge package >>; Fluid '(\CurrentPackage!* %. Start of Search Path \PackageNames!* %. List of ALL package names PackageCharacter!* %. Character prefix for package ); PackageCharacter!* := char !\; % used for output Global '(SymPak!* MaxSym!*); % Dummy Package Field, to be SYSLSP <<MaxSym!*:=8000; SymPak!*:=Mkvect MaxSym!*; MaxSym!*>>; Lisp procedure SymPak d; % Access SYPAK field SymPak!*[d]; Lisp procedure PutSymPak(d,v); SymPak!*[d]:=v; CompileTime Put('SymPak,'Assign!-op,'PutSymPak); % -Hook in GetFn,PutFn, RemFn and MapFn for \Global ------ CopyD('GlobalMapObl,'MapObl); Lisp Procedure \SetUpInitialPackage; Begin Put('\Global,'\Package, '[\Global NIL \GlobalLookup \GlobalInstall \GlobalRemove \GlobalMapObl]); % Package is [name of self, father, GetFn, PutFn,RemFn,MapFn] \PackageNames!* := '(\Global); \CurrentPackage!* := '\Global; End; CompileTime << Lisp Smacro Procedure PackageName x; x[0]; Lisp Smacro Procedure PackageFather x; x[1]; Lisp Smacro Procedure PackageGetFn x; x[2]; Lisp Smacro Procedure PackagePutFn x; x[3]; Lisp Smacro Procedure PackageRemFn x; x[4]; Lisp Smacro Procedure PackageMapFn x; x[5]; >>; \SetupInitialPackage(); Lisp Procedure \PackageP(Name); %. test if legal package IdP(Name) and Get(Name,'\Package); Lisp Procedure \CreateRawPackage(Name,Father, GetFn, PutFn, RemFn, MapFn); %. Build New Package Begin Scalar V; If \PackageP Name then return ErrorPrintF("*** %r is already a package",Name); If Not \PackageP Father then return ErrorPrintF("*** %r cant be Father package",Father); V:=Mkvect(5); V[0]:=Name; V[1]:=Father; V[2]:=GetFn; V[3]:=PutFn; V[4] := RemFn; V[5] := MapFn; \PackageNames!* := Name . \PackageNames!*; Put(Name,'\Package,V); Return V End; Lisp Procedure \SetPackage(Name); %. Change Default If \PackageP(Name) then <<%PrintF(" Pack: %r->%r %n",\CurrentPackage!*,Name); \CurrentPackage!*:=Name>> else if Null Name then \SetPackage('\Global) else \PackageError(Name); Lisp procedure \PackageError(Name); Error(99, LIST(Name, " Is not a Package ")); % Note that we have to cleanup to some default package if % there is an error during ID name reading: CopyD('UnSafeToken,'ChannelReadToken); Lisp Procedure SafeToken(Channel); (LAMBDA (\CurrentPackage!*); UnSafeToken(Channel)) (\CurrentPackage!*); CopyD('ChannelReadToken,'SafeToken); Lisp Procedure PACKAGE x; %. Called from Token reader \SetPackage x; % --- User Package Stuff % --- Simple Buck Hash, using PAIRs (could later use Blocks) lisp Procedure HashFn(S,Htab); begin scalar Len, HashVal; % Fold together a bunch of bits S := StrInf S; HashVal := 0; % from the first 28 characters of the Len := StrLen S; % string. if IGreaterP(Len, 25) then Len := 25; for I := 0 step 1 until Len do HashVal := ILXOR(HashVal, ILSH(StrByt(S, I), IDifference(25, I))); return IRemainder(HashVal, VecLen VecInf Htab); end; Lisp Procedure HashGetFn(S,Htab); %. See if String S is There % Htab is Vector of Buckets Begin Scalar H,Buk,Hashloc; If not StringP S then Return NonStringError(S,'HashGetFn); HashLoc:=HashFn(S,Htab); Buk:=Htab[HashLoc]; Loop: If Null Buk then return 0; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then return H; goto Loop; End; Lisp Procedure HashPutFn(S,Htab); %. Install String at HashLoc Begin Scalar H,TopBuk,Buk,HashLoc; If not StringP S then NonStringError(S,'HashPutFn); HashLoc :=HashFn(S,Htab); TopBuk:=Buk:=Htab[HashLoc]; Loop: If Null Buk then goto new; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then return H; goto Loop; New: S:=CopyString S; % So doesnt grab I/O buffer H:=NewID S; SymPak(ID2Int H) := CurrentPackage!*; TopBuk:= H . TopBuk; Htab[HashLoc] := TopBuk; Return H; End; Lisp Procedure HashRemFn(S,Htab); %. remove String if there Begin Scalar H,TopBuk,Buk,HashLoc; If not StringP S then Return NonStringError(S,'HashRemFn); HashLoc :=HashFn(S,Htab); TopBuk:=Buk:=Htab[HashLoc]; Loop: If Null Buk then return 0; H:=Car Buk; Buk:=cdr Buk; If S=ID2String H then goto Rem; goto Loop; Rem: Htab[HashLoc] :=DelQ(H,TopBuk); SymPak(ID2Int H) := NIL; Return H End; Lisp Procedure HashMapFn(F,Htab); Begin Scalar H,Buk,HashLoc,Hmax; Hmax:=UPBV Htab; For HashLoc:=0:Hmax do <<Buk:=Htab[HashLoc]; For each H in Buk do Apply(F, List H)>>; Return Hmax; End; % -------- Generic routines over hash tables % --- Local Only Lisp procedure LocalIntern S; %. Force Into Current Package If IDP S then return LocalIntern Id2String S else if not StringP S then NonStringError(S,'LocalIntern) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalInstall S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; % already there Return Apply(PackagePutFn P,list S); End; Lisp procedure LocalInternP S; %. Test in Current Package If IDP S then LocalInternP ID2String S else if not StringP S then NonStringError(S,'LocalInternP) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageGetFn P,list S); End; Lisp procedure LocalRemOb S; %. Remove from Current Package If IDP S then LocalRemob ID2String S else if not StringP S then NonStringError(S,'LocalRemob) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalRemove S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageRemFn P,list S); End; Lisp procedure LocalMapObl F; %. Force Into Current Package if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalMapObl F else begin scalar P; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackageMapFn P,list F); End; % Over Full Tree From CurrentPackage!* Lisp procedure PathIntern S; %. Do in Current If not Internd If IDP S then PathIntern ID2String S else if not StringP S then NonStringError(S,'PathIntern) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalInstall S else begin scalar H,P; If IDP(H:=PathIntern1(S,CurrentPackage!*)) then return H; P:=Get(CurrentPackage!*,'\Package); Return Apply(PackagePutFn P,list S); % Do it at top level end; Lisp Procedure PathIntern1(S,CurrentPackage!*); % Search Ancestor Chain if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; Return PathIntern1(S,PackageFather P); % try ancestor End; Lisp Procedure AlternatePathIntern S; begin scalar H; H:=PathInternP S; If IDP H then return H; return LocalIntern S; End; Lisp procedure PathInternP S; %. TEST if Interned on Path PathInternP1(S,CurrentPackage!*); Lisp Procedure PathInternP1(S,CurrentPackage!*); If IDP S then PathInternP1(ID2String S,CurrentPackage!*) else if not StringP S then NonStringError(S,'PathInternP) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalLookup S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageGetFn P,list S); If IDP H then return H; return PathInternP1(S,PackageFather P); % try ancestor End; Lisp procedure PathRemOb S; %. Remove First On Path PathRemOb1(S,CurrentPackage!*); Lisp Procedure PathRemOb1(S,CurrentPackage!*); If IDP S then PathRemOb1(ID2String S,CurrentPackage!*) else if not StringP S then NonStringError(S,'PathRemob) else if CurrentPackage!* eq NIL or CurrentPackage!* eq '\Global then GlobalRemove S else begin scalar P,H; P:=Get(CurrentPackage!*,'\Package); H:=Apply(PackageRemFn P,list S); If IDP H then return H; return PathRemob1(S,PackageFather P); % try ancestor End; Lisp procedure PathMapObl F; %. Full path PathMapObl1(F,CurrentPackage!*); Lisp procedure PathMapObl1(F,Pack); if Pack eq NIL or Pack eq '\Global then GlobalMapObl F else begin scalar P,H; P:=Get(Pack,'\Package); Apply(PackageMapFn P,list F); Return PathMapObl1(F,PackageFather P); End; % ---- Build default Htabs for Bucket Hashed Case Lisp Procedure \CreateHashedPackage(Name,Father,n); Begin Scalar Gf,Pf,Rf,Mf,G; G:=Gensym(); Set(G, Mkvect n); Gf:=Gensym(); Pf:=Gensym(); Rf:=Gensym(); Mf:=Gensym(); PutD(Gf,'Expr,LIST('Lambda,'(S),LIST('HashGetFn,'S,G))); PutD(Pf,'Expr,LIST('Lambda,'(S),LIST('HashPutFn,'S,G))); PutD(Rf,'Expr,LIST('Lambda,'(S),LIST('HashRemFn,'S,G))); PutD(Mf,'Expr,LIST('Lambda,'(F),LIST('HashMapFn,'F,G))); Return \CreateRawPackage(Name,Father,Gf,Pf,Rf,Mf); End; Lisp Procedure \CreatePackage(Name,Father); \CreateHashedPackage(Name,Father,100); % ------ OutPut Functions CopyD('OldCprin2,'ChannelPrin2); CopyD('OldCprin1,'ChannelPrin1); %/ Take Channel and Itm Lisp Procedure NewCprin1(Channel,Itm); If IDP Itm then Begin Scalar IDN,PN; IDN:=ID2Int Itm; PN:=SymPak IDN; If IDP PN and PN then <<NewCprin1(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>; OldCprin1(Channel,Itm); End else OldCprin1(Channel,Itm); Lisp Procedure NewCprin2(Channel,Itm); If IDP Itm then Begin Scalar IDN,PN; IDN:=ID2Int Itm; PN:=SymPak IDN; If IDP PN and PN then <<NewCprin2(Channel,PN);ChannelWriteChar(Channel,PackageCharacter!*)>>; OldCprin2(Channel,Itm); End else OldCprin2(Channel,Itm); % ----- A simple Demo --------------- Procedure redef; Begin CopyD('Intern,'PathIntern ); CopyD('InternP,'PathInternP ); CopyD('RemOb ,'PathRemOb ); CopyD('MapObl ,'PathMapObl); CopyD('ChannelPrin1,'NewCPrin1); CopyD('ChannelPrin2,'NewCPrin2); end; CopyD('CachedGlobalLookup,'GlobalLookup); Procedure GlobalLookup S; <<LastLookedUp:=NIL; %/ Fix Cache Bug that always said YES CachedGlobalLookup S>>; CopyD('NonCopyInstall,'GlobalInstall); % Some Bug in this too, clobers string Procedure GlobalInstall(S); NonCopyInstall CopyString S; Redef(); \CreatePackage('\P1,'\Global); \CreatePackage('\P2,'\Global); end; |
Added psl-1983/util/parse-command-string.sl version [8fe170d992].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Parse-Command-String.SL - Parse Program Command String % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common fast-vector)) (de parse-command-string (s) % This procedure accepts a string and parses it into a sequence % of substrings separated by spaces. It is used to parse the % "command string" given to the PSL program when it is invoked. (let (s-list j (high (size s)) (i 0)) (while T % Scan for the beginning of an argument. (while (<= i high) (cond ((= (igets s i) (char space)) (setq i (+ i 1)) ) (t (exit))) ) (if (> i high) (exit)) % Scan for the end of the argument. (setq j i) (while (<= j high) (cond ((= (igets s j) (char space)) (exit) ) (t (setf j (+ j 1)))) ) (setq s-list (aconc s-list (substring s i j))) (setq i (+ j 1)) ) s-list)) |
Added psl-1983/util/parser-fix.red version [7ecf54b4d1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %7:51am Sunday, 4 April 1982 Some parser fixes. FLUID '(!*BREAK); procedure ParErr(x,y); Begin Scalar !*BREAK; % Turn off BREAK StdError(x); End; procedure ElseError x; ParErr("ELSE should appear only in IF statement",T); procedure ThenError x; ParErr("THEN should appear only in IF statement",T); DefineRop('THEN,4,ThenError); DefineRop('ELSE,4,ElseError); procedure DoError x; ParErr("DO should appear only in WHILE or FOR statements",T); procedure UntilError x; ParErr("UNTIL should appear only in REPEAT statement",T); DefineRop('Do,4,DoPError); DefineRop('Until,4,UntilMError); procedure SUMError x; ParErr("SUM should appear only in FOR statements",T); procedure STEPError x; ParErr("STEP should appear only in FOR statement",T); procedure ProductError x; ParErr("PRODUCT should appear only in FOR statement",T); DefineRop('STEP,4,STEPError); DefineRop('SUM,4,SUMError); DefineRop('PRODUCT,4,ProductError); procedure CollectError x; ParErr("COLLECT should appear only in FOR EACH statements",T); procedure CONCError x; ParErr("CONC should appear only in FOR EACH statement",T); procedure JOINError x; ParErr("JOIN should appear only in FOR EACH statement",T); DefineRop('CONC,4,CONCError); DefineRop('Collect,4,CollectError); DefineRop('JOIN,4,JOINError); % Parse Simple ATOM list SYMBOLIC PROCEDURE ParseAtomList(U,V,W); %. parse LIST of Atoms, maybe quoted % U=funcname, V=following Token, W=arg treatment BEGIN Scalar Atoms; IF V EQ '!*SEMICOL!* THEN RETURN ParErr("Missing AtomList after KEYWORD",T); L: Atoms:=V . Atoms; SCAN(); IF CURSYM!* eq '!*COMMA!* then <<V:=SCAN(); goto L>>; IF CURSYM!* eq '!*SEMICOL!* then Return <<OP := CURSYM!*; If W eq 'FEXPR then U . Reverse Atoms else LIST(U,MkQuotList Reverse Atoms)>>; ParErr("Expect only Comma delimeter in ParseAtomList",T); END; DefineRop('Load,NIL,ParseAtomList('Load,X,'Fexpr)); Definerop('A1,NIL,ParseAtomList('A0,X,'Expr)); Definerop('A2,NIL,ParseAtomList('A0,X,'FExpr)); procedure a0 x; print x; |
Added psl-1983/util/pathin.build version [b2b346730f].
> > | 1 2 | CompileTime load Useful; in "pathin.sl"$ |
Added psl-1983/util/pathin.sl version [5a2d0b39d4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % PATHIN.SL - Rlisp IN function with a search path % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 26 July 1982 % Copyright (c) 1982 University of Utah % % PATHIN(filename-tail:string):none EXPR % % PATHIN allows the use of a directory search path with the Rlisp IN function. % The fluid variable PATHIN* should be a list of strings, which are directory % names. These will be successively concatenated onto the front of the % string argument to PATHIN until an existing file is found. If one is found, % IN will be invoked on the file. If not, a continuable error occurs. % E.g, if PATHIN* is ("" "/usr/src/cmd/psl/" "/u/smith/"), (pathin "foo.red") % will attempt to open "foo.red", then "/usr/src/cmd/psl/foo.red", and finally % "/u/smith/foo.red". (bothtimes (fluid '(pathin*))) (compiletime (flag '(pathin-aux) 'internalfunction)) (loadtime (flag '(pathin) 'ignore)) % just like IN, gets done while compiling (loadtime (if (null pathin*) (setq pathin* '("")))) % acts like IN until path is changed (de pathin (filename-tail) (pathin-aux filename-tail pathin*)) (de pathin-aux (filename-tail search-path-list) (if (null search-path-list) (conterror 99 "File not found in path" (pathin filename-tail)) (let ((test-file (concat (first search-path-list) filename-tail))) (if (filep test-file) (evin (list test-file)) (pathin-aux filename-tail (rest search-path-list)))))) |
Added psl-1983/util/pathnamex.sl version [ef4b07b918].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PathNameX.SL - Useful Functions involving Pathnames % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % Revised: 4 February 1983 % % 4-Feb-83 Alan Snyder % Added pathname-without-name function. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load pathnames)) (de pathname-without-name (pn) % Return a pathname like PN but with no NAME, TYPE, or VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) )) (de pathname-without-type (pn) % Return a pathname like PN but with no TYPE or VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) )) (de pathname-without-version (pn) % Return a pathname like PN but with no VERSION. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type (pathname-type pn) )) (de pathname-set-default-type (pn typ) % Return a pathname like PN, except that if PN specifies no TYPE, % then with type TYP and no version. (setf pn (pathname pn)) (cond ((not (pathname-type pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type typ )) (t pn))) (de pathname-set-type (pn typ) % Return a pathname like PN, except with type TYP and no version. (setf pn (pathname pn)) (make-pathname 'host (pathname-host pn) 'device (pathname-device pn) 'directory (pathname-directory pn) 'name (pathname-name pn) 'type typ )) |
Added psl-1983/util/pcheck.build version [219fc451ab].
> | 1 | in "pcheck.red"$ |
Added psl-1983/util/pcheck.red version [9d7eef5695].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>PCHECK.RED.3, 11-Oct-82 18:14:36, Edit by BENSON % Changed CATCH to *CATCH % A little program to check parens in a LISP file Fluid '(LastSexpr!*); procedure Pcheck F; begin scalar Chan,OldChan; LastSexpr!*:=NIL; Chan:=Open(F,'Input); OldChan:=RDS(Chan); !*Catch(NIL,Pcheck1()); Rds(OldChan); Close chan; % Printf("last Full S-expression%r%n",LastSexpr!*); end; %/ can we enable Line counter somehow? procedure Pcheck1(); Begin Scalar x; L: x:=Read(); if x eq !$EOF!$ then return NIL; LastSexpr!*:=x; PrintSome x; Goto L; End; procedure printsome x; <<Prinsomelevel(x,2,3);terpri()>>; procedure prinsomelevel(x,l1,l2); If not pairp x then <<prin1 x; prin2 " ">> else if l1 <=0 then prin2 " ... " else if l2 <=0 then prin2 " ... " else <<prin2 "("; prinsomelevel(car x,l1-1,l2); if null cdr x then prin2 ")" else if ListP cdr x then <<prinsomelevel(cdr x,l1,l2-1); prin2 ")">> else <<prin2 " . "; prinsomelevel(cdr x,l1,l2-1); prin2 ")">> >>; procedure ListP x; null x or (Pairp x and ListP cdr x); end; |
Added psl-1983/util/poly.build version [42a531fa5a].
> | 1 | in "poly.red"$ |
Added psl-1983/util/poly.red version [cd130098a1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Simple POLY, RAT AND ALG system, based on POLY by Fitch and Marti. % Edit by Cris Perdue, 28 Jan 1983 2045-PST % "Dipthong" -> "Diphthong", order of revision history reversed % Modified by GRISS, JUly 1982 for PSL % MORRISON again, March 1981. % Parses INFIX expressions to PREFIX, then SIMPlifies and PRINTs % Handles also PREFIX expressions % Parser modified by OTTENHEIMER % February 1981, to be left associative March 1981. % Further modified by MORRISON % October 1980. % Modifed by GRISS and GALWAY % September 1980. % 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 ********************** smacro procedure RATNUM X; % parts of Rational CAR X; smacro procedure RATDEN X; CDR X; smacro procedure MKRAT(X,Y); CONS(X,Y); smacro procedure POLTRM X; % parts of Poly CAR X; smacro procedure POLRED X; CDR X; smacro procedure MKPOLY(X,Y); CONS(X,Y); smacro procedure TRMPWR X; % parts of TERM CAR X; smacro procedure TRMCOEF X; CDR X; smacro procedure MKTERM(X,Y); CONS(X,Y); smacro procedure PWRVAR X; % parts of Poly CAR X; smacro procedure PWREXPT X; CDR X; smacro procedure MKPWR(X,Y); CONS(X,Y); smacro procedure POLVAR X; PWRVAR TRMPWR POLTRM X; smacro procedure POLEXPT X; PWREXPT TRMPWR POLTRM X; smacro procedure POLCOEF X; TRMCOEF POLTRM X; %*********************** Utility Routines ***************************** procedure VARP X; IDP X OR (PAIRP X AND IDP CAR X); %*********************** Entry Point ********************************** FLUID '(!*RBACKTRACE !*RECHO REXPRESSION!* !*RMESSAGE PromptString!* TOK!* CurrentScantable!* ); !*RECHO := NIL; % No echo of parse !*RMESSAGE := T; % Do Print messages procedure RAT(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; Prin2T "Canonical Rational Evaluator"; PromptString!*:="poly> "; ALGINIT(); CLEARTOKEN(); % Initialize scanner LOOP: VVV := ERRORSET('(RPARSE),T,!*RBACKTRACE); IF ATOM VVV THEN % What about resetting the Scanner? <<PRINT LIST('RATT, 'error, VVV); CLEARTOKEN();GO TO LOOP>>; REXPRESSION!* := CAR VVV; IF !*RECHO THEN PRINT LIST('parse,REXPRESSION!*); IF REXPRESSION!* EQ 'QUIT THEN << PRINT 'QUITTING; RETURN >>; ERRORSET('(RATPRINT (RSIMP REXPRESSION!*)),T,!*RBACKTRACE); GOTO LOOP END RAT; procedure ALGG(); %. Main LOOP, end with QUIT OR Q BEGIN SCALAR VVV,PromptString!*; prin2t "non-canonical rational evaluator"; alginit(); promptstring!* := "poly> "; 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; procedure alginit(); %. called to init tables begin inittoken(); prin2t "quit; to exit"; 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; procedure cleartoken; nil; procedure inittoken; << AlgScantable!* := '[17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 Algdiphthong]; AlgScanTable!*[char '!+]:=11; AlgScanTable!*[char '!-]:=11; >>; procedure NTOKEN; Begin Scalar CurrentScantable!*; CurrentScanTable!* := AlgScanTable!*; TOK!* := RATOM(); Return Tok!*; End; 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 APPLY(Y,RSIMPL CDR X); Y:=PRESIMP X; % As "variable" ? IF ATOM Y OR NOT(X=Y) THEN RETURN RSIMP Y; RETURN RCREATE Y; END; procedure RSIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE RSIMP(CAR X) . RSIMPL CDR X; 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 APPLY(Y,RSIMPL CDR X); X:=PRESIMPL CDR X; IF (Y:=GET(OP,'PRESIMP)) THEN RETURN APPLY(Y,X); RETURN (OP . X); END; procedure PRESIMPL X; %. Simplify argument list IF NULL X THEN NIL ELSE PRESIMP(CAR X) . PRESIMPL CDR X; %**************** Simplification Routines for Rationals *************** procedure R!+(A,B); %. RAT addition IF RATDEN A = RATDEN B THEN %/ Risa MAKERAT(P!+(RATNUM A,RATNUM B),RATDEN A) ELSE MAKERAT(P!+(P!*(RATNUM A,RATDEN B), P!*(RATDEN A,RATNUM B)), P!*(RATDEN A,RATDEN B)); procedure R!-(A,B); %. RAT subtraction R!+(A,R!.NEG B); procedure R!.NEG A; %. RAT negation MKRAT(P!.NEG RATNUM A,RATDEN A); 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; procedure R!.RECIP A; %. RAT inverse IF RATNUM A=0 THEN ERROR(777,'(ZERO DIVISOR)) ELSE MKRAT(RATDEN A,RATNUM A); procedure R!/(A,B); %. RAT division R!*(A,R!.RECIP B); 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; 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) ) ) >>; 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))); 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; 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 ************* 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 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; IF POLEXPT A>POLEXPT B THEN RETURN MKPOLY(POLTRM A,P!+(POLRED A,B)); RETURN MKPOLY(POLTRM B,P!+(POLRED B,A)) END; procedure PORDERP(A,B); %. POL variable ordering IF A EQ B THEN 0 ELSE IF ORDERP(A,B) THEN 1 ELSE -1; 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)); 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)); 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)); 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; procedure ZCONS A; %. Make single term POL CONS(A,0); procedure PCREATE1(X); %. Create POLY from Variable/KERNEL ZCONS(CONS(CONS(X,1),1)); 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))); 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; procedure NUMGCD(A,B); %. Numeric GCD IF A=0 THEN ABS B ELSE NUMGCD(REMAINDER(B,A),A); 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; 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; procedure DIVIDEOUT(A,B); %. POL exact division CAR PDIVIDE(A,B); 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; procedure P!-(A,B); %. POL subtract P!+(A,P!.NEG B); procedure P!.NEG(A); %. POL Negate IF NUMBERP A THEN -A ELSE CONS(CONS(CAAR A,P!.NEG CDAR A),P!.NEG CDR A); 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; 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 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; 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; 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; 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; 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; 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; procedure MKATOM X; % Use LIST('RCREATE, LIST('QUOTE,x)); if doing EVAL mode X; %******************* Printing Routines ******************************** 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 NIL 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; procedure RPREC!* X; %. T if there is no significant addition in X. ATOM X OR (NUMBERP POLRED X AND POLRED X = 0); 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)); procedure SIMPLE X; %. POL that doest need () ATOM X OR ((POLRED X=0) AND (POLEXPT X=1) AND (POLCOEF X =1)); 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; 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 procedure RAT2PRE X; %. RATIONAL to Prefix IF RATDEN X = 1 THEN POL2PRE RATNUM X ELSE LIST('QUOTIENT,POL2PRE RATNUM X, POL2PRE RATDEN X); 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; 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); procedure PWR2PRE X; %. Power to Prefix IF PWREXPT X = 1 THEN PWRVAR X ELSE LIST('EXPT,PWRVAR X,PWREXPT X); %. prefix Pretty print 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 APPLY(PRINOP,LIST(A,PARENS)); PRIN2(CAR A); PRINARGS CDR A; RETURN A; END; 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 '!)>>; procedure PREPRINT A; <<PREPRIN(A,NIL); TERPRI(); A>>; 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 '!)>>; procedure PLUSPRIN(A,PARENS); NARYPRIN('! !+! ,CDR A,PARENS); procedure DIFFERENCEPRIN(A,PARENS); NARYPRIN('! !-! ,CDR A,PARENS); procedure TIMESPRIN(A,PARENS); NARYPRIN('!*,CDR A,PARENS); procedure QUOTPRIN(A,PARENS); NARYPRIN('!/,CDR A,PARENS); procedure EXPPRIN(A,PARENS); NARYPRIN('!^,CDR A,PARENS); procedure OrderP(x,y); % ordering of ID's as VARS Id2int(x) <= Id2Int (y); End; |
Added psl-1983/util/pr-demo.red version [ebde01d357].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PR-DEMO.RED: A small 3D version Picture RLISP demo file % See also the LISP syntax form in PR-DEMO.SL % Use IN "PU:PR-DEMO.RED"$ for best effects LOAD PRLISP; HP!.INIT(); % For HP2648a Outline := { 10, 10} _ {-10, 10} _ % Outline is 20 by 20 {-10,-10} _ { 10,-10} _ {10, 10}$ % Square Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}$ Cubeface := (Outline & Arrow) | ZMOVE 10$ Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90)$ % Make it larger for better viewing BigCube := Cube | Scale 5$ % and show it ESHOW BigCube$ % Some more views ESHOW (BigCube | XROT 20 | YROT 30 | ZROT 10)$ ESHOW (Cube | scale 2 | XMOVE (-240) | REPEATED(5, XMOVE 80))$ % Some curves: ESHOW {10,10} | circle(70)$ SHOW {10,10} | circle(50) | Xmove 20$ % Some control points for BSPLINE and BEZIER curves Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ ESHOW (Cpts & Cpts | BEZIER())$ ESHOW (Cpts & Cpts | BSPLINE())$ END; |
Added psl-1983/util/pr-demo.sl version [83a3c2b011].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % PR-DEMO.SL: A small 3D Picture RLISP demo file, using LISP syntax % Is equivalent to the PR-DEMO.RED form in RLISP syntax % Use (LAPIN "PU:PR-DEMO.SL") for best effects (LOAD PRLISP) % First call the xxx!.INIT routine, (HP!.INIT) % For HP2648a % Define a 20 x 20 square (SETQ OUTLINE (POINTSET (ONEPOINT 10 10) (ONEPOINT -10 10) (ONEPOINT -10 -10) (ONEPOINT 10 -10) (ONEPOINT 10 10))) % and an Arrow to place in square (SETQ ARROW (GROUP (POINTSET (ONEPOINT 0 -1) (ONEPOINT 0 2)) (POINTSET (ONEPOINT -1 1) (ONEPOINT 0 2) (ONEPOINT 1 1)))) % to produce the CubeFace. Will be shifted out by 10 units (SETQ CUBEFACE (TRANSFORM (GROUP OUTLINE ARROW) (ZMOVE 10))) % to produce a 20 x 20 x 20 Cube (SETQ CUBE (GROUP CUBEFACE (TRANSFORM CUBEFACE (XROT 180)) (TRANSFORM CUBEFACE (YROT 90)) (TRANSFORM CUBEFACE (YROT -90)) (TRANSFORM CUBEFACE (XROT 90)) (TRANSFORM CUBEFACE (XROT -90)))) % This is a bigger cube to be seen more clearly (SETQ BIGCUBE (TRANSFORM CUBE (SCALE 5))) % as can be seen (ESHOW BIGCUBE) % Some more views of the CUBE (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM BIGCUBE (XROT 20)) (YROT 30)) (ZROT 10))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM CUBE (SCALE 2)) (XMOVE -240)) (REPEATED 5 (XMOVE 80)))) % Draw a circle (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 70))) % and another (SHOW (TRANSFORM (TRANSFORM (ONEPOINT 10 10) (CIRCLE 50)) (XMOVE 20))) % Define Some control points for Bspline and Bezier (SETQ CPTS (POINTSET (ONEPOINT 0 0) (ONEPOINT 70 -60) (ONEPOINT 189 -69) (ONEPOINT 206 33) (ONEPOINT 145 130) (ONEPOINT 48 130) (ONEPOINT 0 84))) % And show the BSPLINE and BEZIER curves (ESHOW (GROUP CPTS (TRANSFORM CPTS (BEZIER)))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BSPLINE)))) |
Added psl-1983/util/pr-driv.build version [b6e7bd5f3b].
> > | 1 2 | CompileTime load pr!-main; in "pr-driv.red"$ |
Added psl-1983/util/pr-driv.red version [914f1faee0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. PR-DRIV.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE FLUID '(!*EMODE); loadtime <<!*EMODE:=NIL;>>; % initialize emode to off %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MoveToXY(0,0)>>$ Procedure HP!.Erase()$ %. Erase graphic diaplay screen <<HP!.Graphon(); HP!.Erases(); HP!.Graphoff()>>; Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. move pen to absolute location << HP!.GRCMD("d")$ XDEST := HP!.NormX XDEST$ YDEST := HP!.NormY YDEST$ HP!.OutInt XDEST$ HP!.OutChar Char '!,$ HP!.OutInt YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ XDEST := HP!.NormX XDEST$ %. destination and draw a YDEST := HP!.NormY YDEST$ HP!.OutInt XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'HP!.Erase)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<Graphoff(); Tek!.Erase(); Graphon()>>; Procedure TEK!.Erase(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. draw the line. TEK!.4BYTES (Xprevious, Yprevious)$ TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) echooff(); % also issue GS? Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); % Also issue US? Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'TEK!.Erase)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Top . . Bottom) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; FIX(Y)+12; Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.Erase(); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.EraseS(); % Delete Entire Screen <<GraphOFF(); Tel!.Erase(); Graphon()>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xprevious,Yprevious, X1, Y1,function dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); Echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('Erase,'TEL!.Erase); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Top . . Bottom) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.Erase(); % Delete Entire Screen <<Graphon(); ANN!.Erases(); GraphOff()>>; Procedure ANN!.DDA(X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL end; Procedure ANN!.MoveS(X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure ANN!.DrawS(X1,Y1); << ANN!.DDA(Xprevious,Yprevious, X1, Y1,function ANN!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(ANN!.DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('Erase,'ANN!.Erase); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Print "Device Now ANN60"; end; %********************************** % MPS device routines will only * % work If the MPS C library is * % resident in the system * % contact Paul Stay or Russ Fish * % University of Utah * %********************************** Fluid '(DDDD MDDD ABSDD); Procedure MPS!.DrawS (XDEST, YDEST); <<PSdraw2d(LIST(XDEST,YDEST) ,DDDD,ABSDD,0,1); %draw a line from cursor 0; %do x and y coordinates >>; Procedure MPS!.MoveS (XDEST, YDEST); <<PSdraw2d( LIST(XDEST,YDEST) , MDDD,ABSDD,0,1); %move to point x,y 0; >>; Procedure MPS!.Delay(); % no Delay function for mps NIL; Procedure MPS!.EraseS(); % setdisplay list to nil DISPLAY!.LIST := NIL$ Procedure MPS!.Erase(); % setdisplay list to nil <<MPS!.GraphOn(); DISPLAY!.LIST := NIL$ MPS!.GraphOff()>>; Procedure MPS!.VWPORT( X1, X2, Y1, Y2); %set up viewport << PSsetscale(300); %set up scale factor X1CLIP := MAX2(-500, X1); X2CLIP := MIN2(500, X2); Y1CLIP := MAX2(-500, Y1); Y2CLIP := MIN2(500, Y2); >>; Procedure MPS!.GRAPHON(); % Check this echooff(); Procedure MPS!.GRAPHOFF(); If not !*emode then echoon(); Procedure MPS!.INIT$ << PRINT "MPS IS DISPLAY DEVICE"; DEV!. := 'MPS; FNCOPY ( 'EraseS, 'MPS!.ERASES)$ FNCOPY ( 'Erase, 'MPS!.ERASE)$ % Add NORM functions FNCOPY ( 'MoveS, 'MPS!.MoveS)$ FNCOPY ( 'DrawS, 'MPS!.DrawS)$ FNCOPY ( 'VWPORT, 'MPS!.VWPORT)$ FNCOPY ( 'Delay, 'MPS!.Delay)$ FNCOPY( 'GraphOn, 'MPS!.GraphOn)$ FNCOPY( 'GraphOff, 'MPS!.GraphOff)$ PSINIT(1,0); % initialize device ERASE(); MPS!.VWPORT(-500,500,-500,500); % setup viewport Psscale(1,1,1,500); % setup scale hardware GLOBAL!.TRANSFORM := WINdoW(-300,60); >>; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen in G-mode << Graphoff(); ST!.OutChar 27; ST!.OutChar 12; GraphOn(); >>; Procedure ST!.Erase(); % erase screen in Text mode << Echooff(); ST!.OutChar 27; ST!.OutChar 12; If not !*emode then Echoon();>>; Procedure ST!.GraphOn(); << EchoOff(); ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); <<ST!.OutChar 31; % Maybe mixed VT-52/tek problem If Not !*EMODE Then EchoOn()>>; Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. so next X,Y set is MOVE >>$ Procedure ST!.DrawS (XDEST,YDEST)$ << %/ ST!.OutChar 29$ %/ Always after MOVE %/ ST!.4bytes(Xprevious, Yprevious)$ ST!.4BYTES (XDEST, YDEST)$ %. draw the line. >>$ Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'ST!.Erase)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/util/pr-main.build version [fbaa2db00f].
> | 1 | in "pr-main.red"$ |
Added psl-1983/util/pr-main.red version [4bdda55b20].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % % % Author: Fuh-Meei Chen, Paul Stay and Martin L. Griss % % Symbolic Computation Group % % Computer Science Dept. % % University of Utah % % % % <PSL.UTIL>PRLISP.RED.21, 9-Jan-82 22:47:43, Edit by GRISS % % <STAY.PICT>PRLISP.B 12-april-82 8:00:00 by Paul Stay % % changed bezier circle and bspline drivers and hp terminal % % on 10-april-82 by Paul Stay % % Added MPS support software for use on the graphics vax % % Added ST.INIT % % Copyright (c) 1981 University of Utah % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Part of the parser to accomplish the Pratt parser written % % in New-Rlisp runs at DEC-20. % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% RemFlag('(MKVECT),'TWOREG); %/ Seems in Error RemProp('!{,'NEWNAM!-OP); %. left and right brackets RemProp('!},'NEWNAM!-OP); %. handling. RemProp('!{,'NEWNAM); % left and right brackets are RemProp('!},'NEWNAM); % used to Define points. Put('!{, 'NEWNAM,'!*LBRAC!*); Put('!}, 'NEWNAM,'!*RBRAC!*); % Put on to the property list. DefineROP('!*LBRAC!*,NIL,LBC); % Define the precedence. DefineBOP('!*RBRAC!*,1,0); FLUID '(OP); Procedure LBC X; Begin scalar RES; If X EQ '!*RBRAC!* then <<OP := X; RES := '!*EMPTY!*>> else RES:= RDRIGHT(2,X); If OP EQ '!*RBRAC!* then OP := SCAN() else PARERR("Missing } after argument list",NIL); Return REPCOM('OnePoint,RES) end; Procedure REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); RemProp('!_,'NEWNAM); %. underscore handling. Put('!_,'NEWNAM,'POINTSET); % "_" is used for Pointset. DefineBOP('POINTSET,17,18,NARY('POINTSET,X,Y)); Put('!&,'NEWNAM,'GROUP); %. and sign handling. DefineBOP('GROUP,13,14,NARY('GROUP,X,Y)); % "&" is used for Group. Put('!|,'NEWNAM,'TRANSFORM); %. back slash handling. DefineROP('TRANSFORM,20, % "|" is used for transform. If EQCAR(X,'!*COMMA!*) then REPCOM('TRANSFORM,X)); DefineBOP('TRANSFORM,15,16); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of external Procedures to % % internal form. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ************************************** % conversion on structures of models. * % ************************************** NExpr Procedure POINTSET L$ 'POINTSET . L$ NExpr Procedure GROUP L$ 'GROUP . L$ NExpr Procedure TRANSFORM L$ 'TRANSFORM . L$ % *********************************** % conversion on interpreter level * % Procedures. * % *********************************** Procedure BSPLINE; LIST 'BSPLINE; Procedure BEZIER; LIST 'BEZIER; Procedure LINE; LIST 'LINE; Procedure CIRCLE(R); LIST('CIRCLE,R); Procedure COLOR N; List('Color,N); Procedure REPEATED(COUNT,TRANS); LIST('REPEATED,COUNT,TRANS); BothTimes <<Procedure MKLIST L$ 'LIST . L; >>; MACRO Procedure OnePoint L$ LIST('MKPOINT, MKLIST CDR L)$ MACRO Procedure MAT16 L; LIST('LIST2VECTOR, MKLIST (NIL. CDR L))$ Procedure PNT4(X1,X2,X3,X4); % create a vector of a point Begin scalar V; V:=MKVECT 4; V[1]:=X1; V[2]:=X2; V[3]:=X3; V[4]:=X4; Return V; end; % %%%%%%%%%%%%%%%%%%%%%%%%% % PAIR KLUDGES % % %%%%%%%%%%%%%%%%%%%%%%%%% Procedure PRLISPCDR L$ %. PRLISPCDR of a list. If PAIRP L then CDR L else 'NIL$ Procedure CAR1 L$ %. the Car1 element of If PAIRP L then CAR L else 'NIL$ %. a list. Procedure CAR2 L$ %. the CAR2 element of If LENGTH L > 1 then CADR L else 'NIL$ %. a list. Procedure CAR3 L$ %. the CAR3 element of If LENGTH L > 2 then CADDR L else 'NIL$ %. a list. Procedure CAR4 L$ %. the CAR4 element of If LENGTH L > 3 then CADDDR L else 'NIL$ %. a list. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % interpreter supporting Procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure V!.COPY V1$ %. Copy a vector Begin scalar N, V2$ V2 := MKVECT(N := SIZE V1)$ FOR I := 0 : N DO V2[I] := V1[I]$ Return V2$ end$ % ********************* % point primitive * % ********************* Procedure MKPOINT (POINTLIST)$ %. make a vector form for Begin scalar P,I; P:=Pnt4(0,0,0,1); I:=1; While PairP PointList and I<=4 do <<P[I]:=Car PointList; I:=I+1; PointList:=Cdr PointList>>; Return P End; % ************************** % initialize globals and * % and fluids * % set up for compiled * % version * % ************************** FLUID '( DISPLAY!.LIST %. Used for object definition for MPS MAT!*0 %. 4 x 4 Zero Matrix MAT!*1 %. 4 x 4 Unit Matrix FirstPoint!* % FirstPoint of PointSet is MOVED to GLOBAL!.TRANSFORM %. Accumulation Transform CURRENT!.TRANSFORM CURRENT!.LINE %. Line Style CURRENT!.COLOR %. Default Color X1CLIP % Set by VWPORT for Clipping X2CLIP Y1CLIP Y2CLIP FourClip % Vector to return New Clipped point Xprevious Yprevious DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := MAT16 ( 0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0)$ MAT!*1 := MAT16 (1,0,0,0, 0,1,0,0, 0,0,1,0, 0,0,0,1)$ % unit matrix. GLOBAL!.TRANSFORM := MAT!*1$ CURRENT!.TRANSFORM := MAT!*1$ % current transformation matrix % initialized as mat!*1. CURRENT!.LINE := 'LINE$ CURRENT!.COLOR := 'BLACK$ Xprevious := 0; Yprevious:=0; FourClip := PNT4(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 4 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); Xprevious := X; Yprevious := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); Xprevious := X; Yprevious := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeFourClip(X1,Y1,X2,Y2); <<FourClip[1]:=x1; FourClip[2]:=y1; FourClip[3]:=x2; FourClip[4]:=y2; FourClip>>; Procedure InView (L); NULL(Car L) and NULL(cadr L) and NULL(caddr L) and NULL (cadddr L); Procedure CLIP2D (x1,y1,x2,y2); % Iterative Clipper Begin scalar P1,P2,TMP; % Newmann and Sproull P1 := TESTPOINT(x1,y1); % Classify EndPoints, get 4 List P2 := TESTPOINT(x2,y2); If InView(P1) and InView(P2) then Return MakeFourClip(x1,y1,X2,Y2); WHILE NOT(InView(P1) AND InView(P2) OR LOGICAND(P1,P2)) DO << If InView(P1) then % SWAP to get Other END <<TMP := P1$ P1 := P2$ P2 := TMP$ TMP := X1$ X1 := X2$ X2 := TMP$ TMP := Y1$ Y1 := Y2$ Y2 := TMP>>$ If CADDDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X1CLIP-X1)) / (X2-X1)$ X1 := X1CLIP>> else If CADDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X2CLIP-X1)) / (X2-X1)$ X1 := X2CLIP>> else If CADR P1 then <<X1 := X1 + ((X2-X1)*(Y1CLIP-Y1)) / (Y2-Y1)$ Y1 := Y1CLIP>> else If CAR P1 then <<X1 := X1 + ((X2-X1)*(Y2CLIP-Y1)) / (Y2-Y1)$ Y1 := Y2CLIP>>$ P1 := TESTPOINT(X1,Y1)>>; % reTest P1 after clipping If Not LOGICAND(P1,P2) then Return MakeFourClip(X1,Y1,X2,Y2); Return NIL end$ Procedure LOGICAND (P1, P2)$ %. logical "and". (CAR P1 AND CAR P2) OR %. use in clipping (CADR P1 AND CADR P2) OR (CADDR P1 AND CADDR P2) OR (CADDDR P1 AND CADDDR P2) $ Procedure TESTPOINT(x,y)$ %. test If "P" LIST (If y > Y2CLIP then T else NIL, %. inside the viewport. If y < Y1CLIP then T else NIL, %.used in clipping If x > X2CLIP then T else NIL, If x < X1CLIP then T else NIL)$ % All NIL if Inside % ********************************** % tranformation matrices * % matrices internal are stored as * % OnePoint = [x y z w] * % matrix = [v1 v5 v9 v13 * % v2 v6 v10 v14 * % v3 v7 v11 v15 * % v4 v8 v12 v16 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 4 by 4 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. MAT16 ( % V1 and V2 are 4 by 4 matrices. V1[ 1] * V2[ 1] + V1[ 5] * V2[ 2] + V1[ 9] * V2[ 3] + V1[ 13] * V2[ 4], V1[ 2] * V2[ 1] + V1[ 6] * V2[ 2] + V1[ 10] * V2[ 3] + V1[ 14] * V2[ 4], V1[ 3] * V2[ 1] + V1[ 7] * V2[ 2] + V1[ 11] * V2[ 3] + V1[ 15] * V2[ 4], V1[ 4] * V2[ 1] + V1[ 8] * V2[ 2] + V1[ 12] * V2[ 3] + V1[ 16] * V2[ 4], V1[ 1] * V2[ 5] + V1[ 5] * V2[ 6] + V1[ 9] * V2[ 7] + V1[ 13] * V2[ 8], V1[ 2] * V2[ 5] + V1[ 6] * V2[ 6] + V1[ 10] * V2[ 7] + V1[ 14] * V2[ 8], V1[ 3] * V2[ 5] + V1[ 7] * V2[ 6] + V1[ 11] * V2[ 7] + V1[ 15] * V2[ 8], V1[ 4] * V2[ 5] + V1[ 8] * V2[ 6] + V1[ 12] * V2[ 7] + V1[ 16] * V2[ 8], V1[ 1] * V2[ 9] + V1[ 5] * V2[ 10] + V1[ 9] * V2[ 11] + V1[ 13] * V2[ 12], V1[ 2] * V2[ 9] + V1[ 6] * V2[ 10] + V1[ 10] * V2[ 11] + V1[ 14] * V2[ 12], V1[ 3] * V2[ 9] + V1[ 7] * V2[ 10] + V1[ 11] * V2[ 11] + V1[ 15] * V2[ 12], V1[ 4] * V2[ 9] + V1[ 8] * V2[ 10] + V1[ 12] * V2[ 11] + V1[ 16] * V2[ 12], V1[ 1] * V2[ 13] + V1[ 5] * V2[ 14] + V1[ 9] * V2[ 15] + V1[ 13] * V2[ 16], V1[ 2] * V2[ 13] + V1[ 6] * V2[ 14] + V1[ 10] * V2[ 15] + V1[ 14] * V2[ 16], V1[ 3] * V2[ 13] + V1[ 7] * V2[ 14] + V1[ 11] * V2[ 15] + V1[ 15] * V2[ 16], V1[ 4] * V2[ 13] + V1[ 8] * V2[ 14] + V1[ 12] * V2[ 15] + V1[ 16] * V2[ 16])$ Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[1] * V[1] + %. 1 by 4 and 4 by 1. U[2] * V[2] + % Returning a value. U[3] * V[3] + U[4] * V[4] $ Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U1,U2,U3,U4$ %. 1 by 4 with 4 by 4. U1 := U[1]$ % Returning a 1 by 4 vector. U2 := U[2]$ U3 := U[3]$ U4 := U[4]$ U:=Mkvect 4; u[1]:= U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; u[2]:= U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; u[3]:= U1 * V[9] + U2 * V[10] + U3 * V[11] + U4 * V[12]; u[4]:= U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; Return U; end$ % ************************************ % set up perspective transformtion * % given eye and screen distances * % ************************************ Procedure WINDOW(EYE,SCREEN)$ %. perspective transformation. Begin scalar SE$ SE := SCREEN - EYE$ % EYE and SCREEN are distances Return MAT16(SE,0.0,0.0,0.0, % from eye and screen to 0.0,SE,0.0,0.0, % origin respectively. 0.0,0.0,SE,0.0, 0.0,0.0,1.0, -EYE) end$ % ********************** % translation * % ********************** Procedure XMove (TX)$ %. x translation only Move (TX,0,0) $ Procedure YMove (TY)$ %. y translation only Move (0,TY,0) $ Procedure ZMove (TZ)$ %. z translation only Move (0,0,TZ) $ Procedure Move (TX,TY,TZ)$ %. Move origin / object$ MAT16 (1, 0, 0, TX, %. make a translation 0, 1, 0, TY, %. transformation matrix 0, 0, 1, TZ, %. [ 1 O O O 0, 0, 0, 1)$ %. 0 1 0 0 %. 0 0 1 0 %. Tx Ty Tz 1 ] % ******************* % rotation * % ******************* Procedure XROT (X)$ %. rotation about x FROTATE (X,2,3) $ Procedure YROT (X)$ %. rotation about y FROTATE (X,3,1) $ Procedure ZROT (X)$ %. rotation about z FROTATE (X,1,2) $ Procedure FROTATE (THETA,I,J)$ %. scale factor Begin scalar S,C,W,TEMP$ %. i and j are the index %. values to set up matrix S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib TEMP := V!.COPY MAT!*1; PutV (TEMP, 5 * I-4, C)$ PutV(TEMP, 5 * J-4, C)$ PutV (TEMP, I+4 * J-4,-S)$ PutV (TEMP, J+4 * I-4, S)$ Return TEMP end $ %/ Need to add rotate about an AXIS % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY,1) $ Procedure ZSCALE (SZ)$ %. scaling along Z axis only. SCALE1 (1,1,SZ) $ Procedure SCALE1(XT,YT,ZT)$ %. scaling transformation MAT16 ( XT, 0, 0, 0, %. matrix. 0 ,YT, 0, 0, 0 , 0,ZT, 0, 0 , 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 3 axes. SCALE1(SFACT,SFACT,SFACT); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Procedure definitions % % in the interpreter % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Put('OnePoint,'PBINTRP,'DrawPOINT)$ Put('POINTSET,'PBINTRP,'DrawPOINTSET)$ Put('GROUP,'PBINTRP,'DrawGROUP)$ Put('TRANSFORM,'PBINTRP,'PERFORMTRANSFORM)$ Put('PICTURE,'PBINTRP,'DrawModel)$ Put('CIRCLE,'PBINTRP,'DrawCIRCLE)$ Put('BEZIER,'PBINTRP,'DOBEZIER)$ Put('LINE,'PBINTRP,'DOLINE)$ Put('BSPLINE,'PBINTRP,'DOBSPLINE)$ Put('REPEATED, 'PBINTRP,'DOREPEATED)$ Put('Color,'pbintrp,'Docolor); %****************************************** % SETUP Procedure FOR BEZIER AND BSPLINE * % LINE and COLOR %****************************************** procedure DoColor(Object,N); Begin scalar SaveColor; SaveColor:=Current!.color; N:=Car1 N; % See CIRCLE example, huh? If IDP N then N:=EVAL N; ChangeColor N; Draw1(Object,CURRENT!.TRANSFORM); ChangeColor SaveColor; Return NIL; End; Procedure DOBEZIER OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BEZIER$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOBSPLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BSPLINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'LINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ %************************************* % interpreted function calls * %************************************* Procedure DOREPEATED(MODEL,REPTFUN)$ %. repeat applying Begin scalar TEMP,I,TRANS,COUNT,TS,TA,GRP$ %. transformations. TRANS := PRLISPCDR REPTFUN$ If LENGTH TRANS = 1 then TRANS := EVAL CAR1 TRANS else % "TRANS": transformation << TS :=CAR1 TRANS$ % matrix. TA := PRLISPCDR TRANS $ % "MODEL": the model. TRANS := APPLY(TS,TA) >> $ % "COUNT": the times "MODEL" COUNT := CAR1 REPTFUN$ % is going to be GRP := LIST('GROUP)$ % repeated. TEMP := V!.COPY TRANS$ FOR I := 1 : COUNT DO << GRP := LIST('TRANSFORM,MODEL,TEMP) . GRP$ TEMP := MAT!*MAT(TEMP,TRANS) >>$ GRP := REVERSE GRP$ Return GRP end$ %*********************************** % Define SHOW ESHOW Draw AND EDraw * % ESHOW AND EDraw ERASE THE SCREEN * %*********************************** Procedure SHOW X; %. ALIAS FOR Draw << If DEV!. = 'MPS then %. MPS driver don't call << %. echo functions for diplay %. device DISPLAY!.LIST := LIST (X, DISPLAY!.LIST); FOR EACH Z IN DISPLAY!.LIST DO If Z neq NIL then Draw1(Z,GLOBAL!.TRANSFORM); % Draw object list % to frame PSnewframe(); % display frame >> else << GraphOn(); % call echo off If not emode % If neccessary turn low level Draw1(X,GLOBAL!.TRANSFORM); % Draw model tekronix style GraphOff(); % call echoon >>; >>; Procedure ESHOW ZZ$ %. erases the screen and << Erase(); GraphOn(); DELAY(); Draw1(ZZ,GLOBAL!.TRANSFORM); % Draw model tekronix style If DEV!. = 'MPS then << % Mps display frame PSnewframe(); DISPLAY!.LIST := ZZ; >>; GraphOff(); 0 >>; DefineROP('SHOW,10); %. set up precedence DefineROP('ESHOW,10); Procedure Draw X; %. ALIAS FOR SHOW SHOW X$ Procedure EDraw ZZ$ %. erases the screen and ESHOW ZZ$ DefineROP('Draw,10); DefineROP('EDraw,10); Procedure Col N; % User top-level color <<GraphOn(); ChangeColor N; GraphOff()>>; %************************************* % Define Draw FUNCTIONS FOR VARIOUS * % TYPES OF DISPLAYABLE OBJECTS * %************************************* Procedure DrawModel PICT$ %. given picture "PICT" will Draw1(PICT,CURRENT!.TRANSFORM)$ %. be applyied with global Procedure DERROR(MSG,OBJECT); <<PRIN2 " Draw Error `"; PRIN2T MSG; PRIN2 OBJECT; ERROR(700,MSG)>>; Procedure Draw1 (PICT,CURRENT!.TRANSFORM)$ % Draw PICT with TRANSFORMATION Begin scalar ITM,ITSARGS$ If NULL Pict then Return NIL; If IDP PICT then PICT:=EVAL PICT; If VECTORP PICT AND SIZE(PICT)=4 then Return DrawPOINT PICT$ If NOT PAIRP PICT then DERROR("Non Pair in Draw1: ",PICT); ITM := CAR1 PICT$ ITSARGS := PRLISPCDR PICT$ If NOT (ITM = 'TRANSFORM) then ITSARGS := LIST ITSARGS$ % gets LIST of args ITM := GET (ITM,'PBINTRP)$ If NULL ITM then DERROR("Unknown Operator in Draw1:",PICT); APPLY(ITM,ITSARGS)$ Return PICT$ end$ Procedure DrawGROUP(GRP)$ % Draw a group object Begin scalar ITM,ITSARGS,LMNT$ If PAIRP GRP then FOR EACH LMNT IN GRP DO If PAIRP LMNT then Draw1 (LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL GRP,CURRENT!.TRANSFORM)$ Return GRP$ end$ Procedure DrawPOINTSET (PNTSET)$ Begin scalar ITM,ITSARGS,PT$ FirstPoint!* := 'T$ If PAIRP PNTSET then << If CURRENT!.LINE = 'BEZIER then PNTSET := DrawBEZIER PNTSET else If CURRENT!.LINE = 'BSPLINE then PNTSET := DrawBSPLINE PNTSET$ FOR EACH PT IN PNTSET DO <<If PAIRP PT then Draw1 (PT,CURRENT!.TRANSFORM) else Draw1 (EVAL PT,CURRENT!.TRANSFORM)$ FirstPoint!* := 'NIL>> >> else Draw1 (EVAL PNTSET,CURRENT!.TRANSFORM)$ Return PNTSET$ end$ Procedure DrawPOINT (PNT)$ Begin scalar CLP,X1,Y1,W1,V,U1,U2,U3,U4; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U1:=PNT[1]; U2:=PNT[2]; U3:= PNT[3]; U4:=PNT[4]; X1:=U1 * V[1] + U2 * V[2] + U3 * V[3] + U4 * V[4]; Y1:=U1 * V[5] + U2 * V[6] + U3 * V[7] + U4 * V[8]; W1:=U1 * V[13] + U2 * V[14] + U3 * V[15] + U4 * V[16]; IF NOT (W1 = 1.0) then <<x1:=x1/w1; y1:=y1/w1>>; If FirstPoint!* then Return MoveToXY(X1,Y1); % back to w=1 plane If needed. CLP := CLIP2D(Xprevious,Yprevious, X1,Y1)$ If CLP then <<MoveToXY(CLP[1],CLP[2])$ DrawToXY(CLP[3],CLP[4])>>$ end$ Procedure PERFORMTRANSFORM(PCTSTF,TRNSFRM)$ Begin scalar PROC,OLDTRNS,TRNSFMD,TRANSFOP, TRANSARG,ITM,ITSARGS$ If IDP TRNSFRM then TRNSFRM := EVAL TRNSFRM$ If VECTORP TRNSFRM AND SIZE(TRNSFRM) = 16 then Draw1 (PCTSTF,MAT!*MAT(TRNSFRM,CURRENT!.TRANSFORM)) else If PAIRP TRNSFRM then <<TRANSFOP := CAR1 TRNSFRM$ If (TRANSARG := PRLISPCDR TRNSFRM) then TRANSARG := LIST (PCTSTF,TRANSARG) else TRANSARG := LIST PCTSTF$ If (TRANSFOP = 'BEZIER OR TRANSFOP = 'BSPLINE) then APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG) else Draw1 (APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG), CURRENT!.TRANSFORM) >> end$ %*************************************** % circle bezier and bspline functions * %*************************************** Procedure DrawCIRCLE(CCNTR,RADIUS); %. Draw a circle with radius Begin scalar APNT,POLY,APNTX, APNTY$ %. "RADIUS". POLY := LIST('POINTSET)$ If IDP CCNTR then CCNTR := EVAL CCNTR$ RADIUS := CAR1 RADIUS$ If IDP RADIUS then RADIUS := EVAL RADIUS$ FOR ANGL := 180 STEP -15 UNTIL -180 DO % each line segment << APNTX := CCNTR[1] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[2] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBSPLINE CONPTS$ %. a closed bspline curve Begin scalar N,TWOLIST,PX,PY,CURPTS, %. will be Drawn when given BSMAT,II,TFAC,CPX,CPY$ %. a polygon "CONPTS". BSMAT := MAT16 % " CONPTS" is a pointset. ( -0.166666, 0.5, -0.5, 0.166666, 0.5 , -1.0, 0.0, 0.666666, -0.5 , 0.5, 0.5, 0.166666, 0.166666, 0.0, 0.0, 0.0 )$ CURPTS := NIL$ N := LENGTH CONPTS$ TWOLIST := APPend (CONPTS,CONPTS)$ WHILE N > 0 DO << PX :=PNT4 (GETV(CAR1 TWOLIST,1), GETV(CAR2 TWOLIST,1), GETV(CAR3 TWOLIST,1),GETV(CAR4 TWOLIST,1))$ PY := PNT4 (GETV(CAR1 TWOLIST,2), GETV(CAR2 TWOLIST,2), GETV(CAR3 TWOLIST,2), GETV(CAR4 TWOLIST,2))$ FOR I := 0.0 STEP 1.0 UNTIL 4.0 DO << II := I/4.$ TFAC := PNT4 (II*II*II, II*II, II, 1.)$ TFAC := PNT!*MAT(TFAC,BSMAT)$ CPX := PNT!*PNT(TFAC,PX)$ CPY := PNT!*PNT(TFAC,PY)$ CURPTS := LIST ('Onepoint, CPX, CPY) . CURPTS >>$ N := N - 1$ TWOLIST := PRLISPCDR TWOLIST >>$ Return REVERSE CURPTS end$ LISP Procedure DrawBEZIER CNTS; Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, I, T0, TEMP, FACTL; CURPTS := NIL; SAVEX := NIL; SAVEY := NIL; LEN := LENGTH CNTS; FOR I := 1 STEP 1 UNTIL LEN DO << SAVEX := GETV(CAR1 CNTS, 1) . SAVEX; SAVEY := GETV(CAR1 CNTS, 2) . SAVEY; CNTS := PRLISPCDR CNTS >>; SAVEX := LIST2VECTOR SAVEX; SAVEY := LIST2VECTOR SAVEY; NALL := 8.0 * (LEN - 1); FACTL := FACT (LEN - 1); T0 := 0.0; FOR T0 := 0.0 STEP 1.0 / NALL UNTIL 1.0 DO << CPX := 0.0; CPY := 0.0; TEMP := 0.0; FOR I := 0 STEP 1 UNTIL LEN - 1 DO << TEMP := FACTL / ((FACT I) * (FACT (LEN -1 - I))) * (T0 ** I) * (1.0 - T0)**(LEN -1 - I); CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY, 0.0) . CURPTS >>; Return REVERSE CURPTS; end; procedure FACT N; % Simple factorial Begin scalar M; M:=1; for i:=1:N do M:=M*I; Return M; end; LoadTime SetUpVariables(); |
Added psl-1983/util/pr-text.build version [c04e13d445].
> > | 1 2 | CompileTime load pr!-main; in "pr-text.red"$ |
Added psl-1983/util/pr-text.red version [bf51b5bc48].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 8 * 12 Vector Characters CV := MkVect(127)$ BlankChar := 'NIL$ % Labeled Points on Rectangle (8 x 12 ) % C4 Q6 S3 Q5 C3 % % % Q7 M3 Q4 % % % S4 M4 M0 M2 S2 % % % Q8 M1 Q3 % % % C1 Q1 S1 Q2 C2 % Corners: C1:={0,0}$ C2 := {8,0}$ C4:={0,12}$ C3:= {8,12}$ % Side MidPoints: S1 := {4,0}$ S3 := {4,12}$ S4 := {0,6}$ S2 := {8,6}$ % Middle: M0 := {4,6}$ M1 := {4,3}$ M2 := {6,6}$ M3 := {4,9}$ M4 := {2,6}$ % Side Quarter Points: Q1 := {2,0}$ Q2 := {6,0}$ Q3 := {8,3}$ Q4 := {8,9}$ Q5 := {6,12}$ Q6 := {2,12}$ Q7 := {0,9}$ Q8 := {0,3}$ For i:=0:127 do CV[I]:=BlankChar; % UpperCase: CV[Char A] := C1 _ S3 _ C2 & M4 _ M2$ CV[Char B] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M2 _ Q3 _ Q2 _ C1 $ CV[Char C] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char D] := C1 _ C4 _ Q5 _ Q4 _ Q3 _ Q2 _ C1$ CV[Char E] := C3 _ C4 _ C1 _ C2 & S4 _ S2$ CV[Char F] := C3 _ C4 _ C1 & S4 _ S2$ CV[Char G] := M0 _ S2 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char H] := C4 _ C1 & S4 _ S2 & C3 _ C2$ CV[Char I] := S1 _ S3$ CV[Char J] := C3 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char K] := C4 _ C1 & C3 _ S4 _ C2$ CV[Char L] := C4 _ C1 _ C2$ CV[Char M] := C1 _ C4 _ M0 _ C3 _ C2$ CV[Char N] := C1 _ C4 _ C2 _ C3$ CV[Char O] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3$ CV[Char P] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4$ CV[Char Q] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3 & C2 _ M1$ CV[Char R] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M0 _ C2$ CV[Char S] := Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char T] := C4 _ C3 & S3 _ S1$ CV[Char U] := C4 _ Q8 _ Q1 _ Q2 _ Q3 _ C3$ CV[Char V] := C4 _ S1 _ C3$ CV[Char W] := C4 _ Q1 _ M0 _ Q2 _ C3$ CV[Char X] := C1 _ C3 & C4 _ C2$ CV[Char Y] := C4 _ M0 _ C3 & M0 _ S1$ CV[Char Z] := C4 _ C3 _ C1 _ C2$ % Lower Case, Alias for Now: CV[Char Lower A] := CV[Char A]$ CV[Char Lower B] := CV[Char B]$ CV[Char Lower C] := CV[Char C]$ CV[Char Lower D] := CV[Char D]$ CV[Char Lower E] := CV[Char E]$ CV[Char Lower F] := CV[Char F]$ CV[Char Lower G] := CV[Char G]$ CV[Char Lower H] := CV[Char H]$ CV[Char Lower I] := CV[Char I]$ CV[Char Lower J] := CV[Char J]$ CV[Char Lower K] := CV[Char K]$ CV[Char Lower L] := CV[Char L]$ CV[Char Lower M] := CV[Char M]$ CV[Char Lower N] := CV[Char N]$ CV[Char Lower O] := CV[Char O]$ CV[Char Lower P] := CV[Char P]$ CV[Char Lower Q] := CV[Char Q]$ CV[Char Lower R] := CV[Char R]$ CV[Char Lower S] := CV[Char S]$ CV[Char Lower T] := CV[Char T]$ CV[Char Lower U] := CV[Char U]$ CV[Char Lower V] := CV[Char V]$ CV[Char Lower W] := CV[Char W]$ CV[Char Lower X] := CV[Char X]$ CV[Char Lower Y] := CV[Char Y]$ CV[Char Lower Z] := CV[Char Z]$ % Digits: CV[Char 0] := CV[Char O]$ CV[Char 1] := CV[Char I]$ CV[Char 2] := Q7 _ Q6 _ Q5 _ Q4 _ M0 _ C1 _ C2$ CV[Char 3] := C4 _ C3 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 4] := S1 _ S3 _ S4 _ S2$ CV[Char 5] := C3 _ C4 _ S4 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 6] := Q4 _ Q5 _ Q6 _ Q7 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M4 _ Q8$ CV[Char 7] := C4 _ C3 _ S1$ CV[Char 8] := M0 _ M4 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M0 & M2 _ Q4 _ Q5 _ Q6 _ Q7 _ M4$ CV[Char 9] := Q8 _ Q1 _ Q2 _ Q3 _ Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q4$ % Some Special Chars: CV[Char !+ ] := S1 _ S3 & S4 _ S2$ CV[Char !- ] := S4 _ S2 $ CV[Char !* ] := S1 _ S3 & S4 _ S2 & C1 _ C3 & C4 _ C2 $ CV[Char !/ ] := C1 _ C3 $ CV[Char !\ ] := C4 _ C2 $ CV[Char !( ] := Q6 _ Q7 _ Q8 _ Q1 $ CV[Char !) ] := Q5 _ Q4 _ Q3 _ Q2 $ CV[Char ![ ] := Q6 _ C4 _ C1 _ Q1$ CV[Char !] ] := Q5 _ C3 _ C2 _ Q2$ CV[Char != ] := Q7 _ Q4 & Q8 _ Q3 $ % Some Simple Display Routines: Xshift := Xmove(10)$ Yshift := Ymove(15)$ Procedure ShowString(S); <<Graphon(); ShowString1(S,Global!.Transform); Graphoff()>>; Procedure ShowString1(S,Current!.Transform); Begin scalar i,ch; For i:=0:Size S do <<Draw1(CV[S[i]],Current!.Transform); Current!.Transform := Mat!*mat(XShift,Current!.TRansform)>>; End; Procedure C x; if x:=CV[x] then EShow x; Procedure FullTest(); <<Global!.Transform := MAT!*1; ShowString "ABCDEFGHIJKLMNOPQRTSUVWXYZ 0123456789"; NIL>>; Procedure SpeedTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do C i; NIL>>; Procedure SlowTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do <<C i; Delay()>>; NIL>>; Procedure Delay; For i:=1:500 do nil; Procedure Text(S); List('TEXT,S); Put('TEXT,'PBINTRP,'DrawTEXT)$ Procedure DrawText(StartPoint,S); %. Draw a Text String Begin scalar MoveP; If IDP StartPoint then StartPoint := EVAL StartPoint$ S := CAR1 S$ If IDP S then S := EVAL S$ MoveP:=PositionAt StartPoint; ShowString1(S,Mat!*Mat(MoveP,Current!.Transform)); Return NIL; end$ Procedure PositionAt StartPoint; % return A matrix to set relative Origin << If IDP StartPoint then StartPoint := EVAL StartPoint$ Mat16(1,0,0,StartPoint[1], 0,1,0,StartPoint[2], 0,0,1,StartPoint[3], 0,0,0,StartPoint[4])>>; |
Added psl-1983/util/pr2d-demo.red version [1e41f74a3f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This is a small Picture RLISP demo file % For the simpler 2D version Load prlisp2d$ HP!.Init()$ Outline := { 10, 10} _ {-10, 10} _ % Outline is 20 by 20 {-10,-10} _ { 10,-10} _ {10, 10}$ % Square Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}$ Cube := (Outline & Arrow)$ BigCube := Cube | Scale 5$ Eshow Cube$ Show Cube | Xmove 30$ SHOW BigCube$ ESHOW BigCube | Zrot 30$ ESHOW {10,10} | circle(70)$ Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ ESHOW ( {10,10} | CIRCLE(50))$ ESHOW (Cpts & Cpts | BEZIER())$ ESHOW (Cpts & Cpts | BSPLINE())$ ESHOW (Cube | scale 2 | XMOVE (-240) | REPEATED(5, XMOVE 80))$ ESHOW {0,0} | Text("ABC DEF")$ ESHOW {5,5} | Text("123 456") | Zrot 25 | Scale 2$ Eshow { 10,10} | Text("123")$ Show {30,30} | Text("456") | scale 3$ END$ |
Added psl-1983/util/pr2d-demo.sl version [172b1629be].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Lisp Syntax form of PR2D-DEMO.RED % 2D Version (LOAD PRLISP2D) % Initialize for HP2648 (HP!.INIT) % Build some ObJects (SETQ OUTLINE (POINTSET (ONEPOINT 10 10) (ONEPOINT -10 10) (ONEPOINT -10 -10) (ONEPOINT 10 -10) (ONEPOINT 10 10))) (SETQ ARROW (GROUP (POINTSET (ONEPOINT 0 -1) (ONEPOINT 0 2)) (POINTSET (ONEPOINT -1 1) (ONEPOINT 0 2) (ONEPOINT 1 1)))) (SETQ CUBE (GROUP OUTLINE ARROW)) (SETQ BIGCUBE (TRANSFORM CUBE (SCALE 5))) (ESHOW CUBE) (SHOW (TRANSFORM CUBE (XMOVE 30))) (SHOW BIGCUBE) (ESHOW (TRANSFORM BIGCUBE (ZROT 30))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 70))) (SETQ CPTS (POINTSET (ONEPOINT 0 0) (ONEPOINT 70 -60) (ONEPOINT 189 -69) (ONEPOINT 206 33) (ONEPOINT 145 130) (ONEPOINT 48 130) (ONEPOINT 0 84))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (CIRCLE 50))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BEZIER)))) (ESHOW (GROUP CPTS (TRANSFORM CPTS (BSPLINE)))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM CUBE (SCALE 2)) (XMOVE -240)) (REPEATED 5 (XMOVE 80)))) (ESHOW (TRANSFORM (ONEPOINT 0 0) (TEXT "ABC DEF"))) (ESHOW (TRANSFORM (TRANSFORM (TRANSFORM (ONEPOINT 5 5) (TEXT "123 456")) (ZROT 25)) (SCALE 2))) (ESHOW (TRANSFORM (ONEPOINT 10 10) (TEXT "123"))) (SHOW (TRANSFORM (TRANSFORM (ONEPOINT 30 30) (TEXT "456")) (SCALE 3))) |
Added psl-1983/util/pr2d-driv.build version [9378b17ab6].
> > | 1 2 | CompileTime load Pr2d!-Main; in "pr2d-driv.red"$ |
Added psl-1983/util/pr2d-driv.red version [d5a33b98d3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %--------------------------------- %. PRLISP-DRIVER.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Symbolic Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE FLUID '(!*EMODE); loadtime <<!*EMODE:=NIL;>>; % initialize emode to off %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; Procedure DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MoveToXY(0,0)>>; Procedure HP!.Erase()$ %. EraseS graphic diaplay screen <<HP!.GraphOn(); HP!.Erases(); HP!.GraphOff()>>; Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. Move pen to absolute location << HP!.GRCMD("d")$ HP!.OutInt HP!.NormX XDEST$ HP!.OutChar Char '!,$ HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ HP!.OutInt HP!.NormX XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff If not !*emode then echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'HP!.Erase)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<Tek!.GraphOn(); Tek!.Erases(); TEK!.GraphOff()>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ %/ Dont do 31 unless go back to text mode TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. Draw the line. TEK!.4BYTES (HerePointX, HerePointY)$ %/ Can just do this, ignore reset TEXT or GRPAHICS mode, see ST! TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) If not !*emode then echooff(); Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'TEK!.Erase)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X+0.5)+40; Procedure TEL!.NormY Y; 12- FIX(Y+0.5); Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.Erase (); % Delete Entire Screen <<TEL!.GraphON(); TEL!.Erases(); TEL!.GraphOff()>>; Procedure Tel!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure Tel!.DrawS (X1,Y1); << DDA (Xprevious,Yprevious, X1, Y1,function TEL!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (DDA (X1,Y1,X2,Y2,function TEL!.Tdotc)) end; Procedure TEL!.Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure TEL!.dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('Erase,'TEL!.Erase); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Global!.Transform := MAT!*1; Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Top . . Bottom) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.Erase(); <<ANN!.Graphon(); ANN!.Erases(); Ann!.GraphOff()>>; Procedure ANN!.MoveS(X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure ANN!.DrawS(X1,Y1); << DDA(Xprevious,Yprevious, X1, Y1,function ANN!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); If not !*emode then echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('Erase,'ANN!.Erase); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Global!.Transform := Mat!*1; Print "Device Now ANN60"; end; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen << GraphOff(); ST!.OutChar 27; ST!.OutChar 12; Graphon()>>; Procedure ST!.Erase(); % erase screen << EchoOff(); ST!.OutChar 27; ST!.OutChar 12; If Not !*EMODE then EchoOn()>>; Procedure ST!.GraphOn(); << EchoOff(); ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); <<ST!.OutChar 31$ % Maybe mixed VT-52/tek problem If Not !*Emode Then EchoOn()>>; Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. US: sets terminal to Alpha mode. >>; Procedure ST!.DrawS (XDEST,YDEST)$ %. Same as MoveS but << %/ ST!.OutChar 29$ % Always after move %/ ST!.4bytes(HerePointX, HerePointY)>>$ ST!.4BYTES (XDEST, YDEST)$ %. Draw the line. >>; Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'Erase, 'ST!.Erase)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := MAT!*1; end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % HP2382 specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Hp2382 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) Procedure HP2382!.OutChar x; PBOUT x; Procedure HP2382!.OutCharString S; % Pbout a string For i:=0:Size S do HP2382!.OutChar S[i]; Procedure HP2382!.NormX X; FIX(X+0.5)+40; Procedure HP2382!.NormY Y; 12- FIX(Y+0.5); Procedure HP2382!.ChPrt(X,Y,Ch); <<HP2382!.OutChar Char ESC; HP2382!.OutChar Char '!&; HP2382!.OutChar Char '!a; HP2382!.OutINT (HP2382!.NormY Y); HP2382!.OutChar Char '!r; HP2382!.OutINT (HP2382!.NormX X); HP2382!.OutChar Char '!C; HP2382!.OutChar Ch>>; procedure HP2382!.OutINT x; <<If x>9 then HP2382!.OutChar(Char 0 +(x/10)); HP2382!.OutChar(Char 0 +remainder(x,10))>>; Procedure HP2382!.IdPrt(X,Y,Id); HP2382!.ChPrt(X,Y,ID2Int ID); Procedure HP2382!.StrPrt (X,Y,S); <<HP2382!.OutChar Char ESC; HP2382!.OutChar 89; HP2382!.OutChar (32+HP2382!.NormY Y); HP2382!.OutChar (32+ HP2382!.NormX X); HP2382!.OutCharString S>>; Procedure HP2382!.HOME (); % Home (0,0) <<HP2382!.OutChar CHAR ESC; HP2382!.OutChar 'H>>; Procedure HP2382!.EraseS (); % Delete Entire Screen <<HP2382!.HOME(); HP2382!.OutChar CHAR ESC; HP2382!.OutChar 'J>>; Procedure HP2382!.Erase (); % Delete Entire Screen <<HP2382!.GraphON(); HP2382!.Erases(); HP2382!.GraphOff()>>; Procedure HP2382!.MoveS (X1,Y1); <<Xprevious := X1; Yprevious := Y1>>; Procedure HP2382!.DrawS (X1,Y1); << DDA (Xprevious,Yprevious, X1, Y1,function HP2382!.dotc); Xprevious :=X1; Yprevious :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (DDA (X1,Y1,X2,Y2,function HP2382!.Tdotc)) end; Procedure HP2382!.Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; HP2382!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure HP2382!.dotc (X1,Y1); % Draw And Clip An X HP2382!.ChClip (X1,Y1,Char X) ; Procedure HP2382!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; HP2382!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure HP2382!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure HP2382!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do HP2382!.ChClip (X,Y,Id); end; Procedure HP2382!.Wzap (X1,X2,Y1,Y2); HP2382!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure HP2382!.Delay; NIL; Procedure HP2382!.GRAPHON(); If not !*emode then echooff(); Procedure HP2382!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP2382!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'HP2382!.EraseS); FNCOPY('Erase,'HP2382!.Erase); FNCOPY('MoveS,'HP2382!.MoveS); FNCOPY('DrawS,'HP2382!.DrawS); FNCOPY( 'NormX, 'HP2382!.NormX)$ FNCOPY( 'NormY, 'HP2382!.NormY)$ FNCOPY('VwPort,'HP2382!.VwPort); FNCOPY('Delay,'HP2382!.Delay); FNCOPY( 'GraphOn, 'HP2382!.GraphOn)$ FNCOPY( 'GraphOff, 'HP2382!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Global!.Transform := MAT!*1; Print "Device Now TEL"; end; |
Added psl-1983/util/pr2d-main.build version [8b89d4f3b4].
> | 1 | in "pr2d-main.red"$ |
Added psl-1983/util/pr2d-main.red version [c69ceaf080].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % PictureRLISP : A Lisp-Based Graphics Language System with % % Flexible Syntax and Hierarchical % % Data Structure % % 2D version................ % % Author: Fuh-Meei Chen, Paul Stay and Martin L. Griss % % Symbolic Computation Group % % Computer Science Dept. % % University of Utah % % % % <PSL.UTIL>PRLISP.RED.21, 9-Jan-82 22:47:43, Edit by GRISS % % <STAY.PICT>PRLISP.B 12-april-82 8:00:00 by Paul Stay % % changed bezier circle and bspline drivers and hp terminal % % on 10-april-82 by Paul Stay % % Added MPS support software for use on the graphics vax % % Added ST.INIT % % Copyright (c) 1981 University of Utah % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Part of the parser to accomplish the Pratt parser written % % in New-Rlisp runs at DEC-20. % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% RemFlag('(MKVECT),'TWOREG); %/ Seems in Error RemProp('!{,'NEWNAM!-OP); %. left and right brackets RemProp('!},'NEWNAM!-OP); %. handling. RemProp('!{,'NEWNAM); % left and right brackets are RemProp('!},'NEWNAM); % used to Define points. Put('!{, 'NEWNAM,'!*LBRAC!*); Put('!}, 'NEWNAM,'!*RBRAC!*); % Put on to the property list. DefineROP('!*LBRAC!*,NIL,LBC); % Define the precedence. DefineBOP('!*RBRAC!*,1,0); FLUID '(OP); Procedure LBC X; Begin scalar RES; If X EQ '!*RBRAC!* then <<OP := X; RES := '!*EMPTY!*>> else RES:= RDRIGHT(2,X); If OP EQ '!*RBRAC!* then OP := SCAN() else PARERR("Missing } after argument list",NIL); Return REPCOM('OnePoint,RES) end; Procedure REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); RemProp('!_,'NEWNAM); %. underscore handling. Put('!_,'NEWNAM,'POINTSET); % "_" is used for Pointset. DefineBOP('POINTSET,17,18,NARY('POINTSET,X,Y)); Put('!&,'NEWNAM,'GROUP); %. and sign handling. DefineBOP('GROUP,13,14,NARY('GROUP,X,Y)); % "&" is used for Group. Put('!|,'NEWNAM,'TRANSFORM); %. back slash handling. DefineROP('TRANSFORM,20, % "|" is used for transform. If EQCAR(X,'!*COMMA!*) then REPCOM('TRANSFORM,X)); DefineBOP('TRANSFORM,15,16); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % conversion of external Procedures to % % internal form. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ************************************** % conversion on structures of models. * % ************************************** NExpr Procedure POINTSET L$ 'POINTSET . L$ NExpr Procedure GROUP L$ 'GROUP . L$ NExpr Procedure TRANSFORM L$ 'TRANSFORM . L$ % *********************************** % conversion on interpreter level * % Procedures. * % *********************************** Procedure BSPLINE; LIST 'BSPLINE; Procedure BEZIER; LIST 'BEZIER; Procedure LINE; LIST 'LINE; Procedure CIRCLE(R); LIST('CIRCLE,R); Procedure COLOR N; List('Color,N); Procedure REPEATED(COUNT,TRANS); LIST('REPEATED,COUNT,TRANS); BothTimes <<Procedure MKLIST L$ 'LIST . L; >>; MACRO Procedure OnePoint L$ LIST('MKPOINT, MKLIST CDR L)$ MACRO Procedure Mat8 L; LIST('LIST2VECTOR, MKLIST (CDR L))$ Procedure Pnt2(X1,X2,X3); % create a vector of a point Begin scalar V; V:=MKVECT 2; V[0]:=X1; V[1]:=X2; V[2]:=X3; Return V; end; % %%%%%%%%%%%%%%%%%%%%%%%%% % PAIR KLUDGES % % %%%%%%%%%%%%%%%%%%%%%%%%% Procedure PRLISPCDR L$ %. PRLISPCDR of a list. If PAIRP L then CDR L else 'NIL$ Procedure CAR1 L$ %. the Car1 element of If PAIRP L then CAR L else 'NIL$ %. a list. Procedure CAR2 L$ %. the CAR2 element of If LENGTH L > 1 then CADR L else 'NIL$ %. a list. Procedure CAR3 L$ %. the CAR3 element of If LENGTH L > 2 then CADDR L else 'NIL$ %. a list. Procedure CAR4 L$ %. the CAR4 element of If LENGTH L > 3 then CADDDR L else 'NIL$ %. a list. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % interpreter supporting Procedures % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure V!.COPY V1$ %. Copy a vector Begin scalar N, V2$ V2 := MKVECT(N := SIZE V1)$ FOR I := 0 : N DO V2[I] := V1[I]$ Return V2$ end$ % ********************* % point primitive * % ********************* Procedure MKPOINT (POINTLIST)$ %. make a vector form for Begin scalar P,I; P:=Pnt2(0,0,1); I:=0; While PairP PointList and I<=2 do <<P[I]:=Car PointList; I:=I+1; PointList:=Cdr PointList>>; Return P End; % ************************** % initialize globals and * % and fluids * % set up for compiled * % version * % ************************** FLUID '( DISPLAY!.LIST %. Used for object definition for MPS MAT!*0 %. 3 x 3 Zero Matrix MAT!*1 %. 3 x 3 Unit Matrix FirstPoint!* % FirstPoint of PointSet is MOVED to GLOBAL!.TRANSFORM %. Accumulation Transform CURRENT!.TRANSFORM CURRENT!.LINE %. Line Style CURRENT!.COLOR %. Default Color X1CLIP % Set by VWPORT for Clipping X2CLIP Y1CLIP Y2CLIP ThreeClip % Vector to return New Clipped point HEREPOINTX %/ Same as Xprevious? HEREPOINTY Xprevious % To do DDA on TEL and AAA Yprevious % Set by Move, used by DRAW DEV!. % Device Name, set by xxx!.Init() )$ Procedure SetUpVariables; % Intialize Globals and Fluids Begin MAT!*0 := Mat8 ( 0,0,0, 0,0,0, 0,0,0)$ MAT!*1 := Mat8 (1,0,0, 0,1,0, 0,0,1)$ % unit matrix. GLOBAL!.TRANSFORM := MAT!*1$ CURRENT!.TRANSFORM := MAT!*1$ % current transformation matrix % initialized as mat!*1. CURRENT!.LINE := 'LINE$ CURRENT!.COLOR := 'BLACK$ HEREPOINTX := 0; HEREPOINTY:=0; ThreeClip := Vector(0,0,0,0); FirstPoint!* := NIL$ End; % ---------------- BASIC Moving and Drawing ------------------- % Project from Normalized 3 Vector to X,Y plane Procedure MoveToXY(X,Y)$ %. Move current cursor to x,y of P <<MoveS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ Procedure DrawToXY(X,Y)$ %. Move cursor to "P" and draw from Previous <<DrawS(X,Y); HEREPOINTX := X; HEREPOINTY := Y>>$ % ************************************** % clipping-- on 2-D display screen * % ************************************** Smacro procedure MakeThreeClip(X1,Y1,X2,Y2); <<ThreeClip[0]:=x1; ThreeClip[1]:=y1; ThreeClip[2]:=x2; ThreeClip[3]:=y2; ThreeClip>>; Procedure InView (L); NULL(Car L) and NULL(cadr L) and NULL(caddr L) and NULL (cadddr L); Procedure CLIP2D (x1,y1,x2,y2); % Iterative Clipper Begin scalar P1,P2,TMP; % Newmann and Sproull P1 := TESTPOINT(x1,y1); % Classify EndPoints, get 4 List P2 := TESTPOINT(x2,y2); If InView(P1) and InView(P2) then Return MakeThreeClip(x1,y1,X2,Y2); WHILE NOT(InView(P1) AND InView(P2) OR LOGICAND(P1,P2)) DO << If InView(P1) then % SWAP to get Other END <<TMP := P1$ P1 := P2$ P2 := TMP$ TMP := X1$ X1 := X2$ X2 := TMP$ TMP := Y1$ Y1 := Y2$ Y2 := TMP>>$ If CADDDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X1CLIP-X1)) / (X2-X1)$ X1 := X1CLIP>> else If CADDR P1 then <<Y1 := Y1 + ((Y2-Y1)*(X2CLIP-X1)) / (X2-X1)$ X1 := X2CLIP>> else If CADR P1 then <<X1 := X1 + ((X2-X1)*(Y1CLIP-Y1)) / (Y2-Y1)$ Y1 := Y1CLIP>> else If CAR P1 then <<X1 := X1 + ((X2-X1)*(Y2CLIP-Y1)) / (Y2-Y1)$ Y1 := Y2CLIP>>$ P1 := TESTPOINT(X1,Y1)>>; % reTest P1 after clipping If Not LOGICAND(P1,P2) then Return MakeThreeClip(X1,Y1,X2,Y2); Return NIL end$ Procedure LOGICAND (P1, P2)$ %. logical "and". (CAR P1 AND CAR P2) OR %. use in clipping (CADR P1 AND CADR P2) OR (CADDR P1 AND CADDR P2) OR (CADDDR P1 AND CADDDR P2) $ Procedure TESTPOINT(x,y)$ %. test If "P" LIST (If y > Y2CLIP then T else NIL, %. inside the viewport. If y < Y1CLIP then T else NIL, %.used in clipping If x > X2CLIP then T else NIL, If x < X1CLIP then T else NIL)$ % All NIL if Inside % ********************************** % tranformation matrices * % matrices internal are stored as * % OnePoint = [x y w] * % matrix = [v0 v3 v6 * % v1 v4 v7 * % v2 v5 v8 ] * % ********************************** %******************************************************* % Matrix Multiplication given two 3 by 3 matricies * %******************************************************* Procedure MAT!*MAT (V1,V2)$ %. multiplication of matrices. Mat8 ( % V1 and V2 are 3 by 3 matrices. V1[0] * V2[0] + V1[3] * V2[1] + V1[6] * V2[2], V1[1] * V2[0] + V1[4] * V2[1] + V1[7] * V2[2], V1[2] * V2[0] + V1[5] * V2[1] + V1[8] * V2[2], V1[0] * V2[3] + V1[3] * V2[4] + V1[6] * V2[5], V1[1] * V2[3] + V1[4] * V2[4] + V1[7] * V2[5], V1[2] * V2[3] + V1[5] * V2[4] + V1[8] * V2[5], V1[0] * v2[6] + V1[3] * V2[7] + V1[6] * V2[8], V1[1] * v2[6] + V1[4] * V2[7] + V1[7] * V2[8], V1[2] * v2[6] + V1[5] * V2[7] + V1[8] * V2[8]); Procedure PNT!*PNT(U,V)$ %. multiplication of matrices U[0] * V[0] + U[1] * V[1] + %. 1 by 3 and 3 by 1. U[2] * V[2] $ % Returning a value. Procedure PNT!*MAT(U,V)$ %. multiplication of matrices Begin scalar U0,U1,U2$ %. 1 by 3 with 3 by 3. U0 := U[0]$ U1 := U[1]$ % Returning a 1 by 3 vector. U2 := U[2]$ U:=Mkvect 2; u[0]:= U0 * V[0] + U1 * V[3] + U2 * V[6]; u[1]:= U0 * V[1] + U1 * V[4] + U2 * V[7]; u[2]:= U0 * V[2] + U1 * V[5] + U2 * V[8]; Return U; end$ % ********************** % translation * % ********************** Procedure XMove(TX)$ %. x translation only Move (TX,0) $ Procedure YMove(TY)$ %. y translation only Move (0,TY) $ Procedure Move(TX,TY)$ %. Move origin / object$ Mat8(1, 0, TX, %. make a translation 0, 1, TY, %. transformation matrix 0, 0, 1)$ % ******************* % Z rotation * % ******************* Procedure ZROT(Theta)$ %. rotation about z Begin scalar S,C; S := SIND (THETA)$ %. sin in degrees uses mathlib C := COSD (THETA)$ %. cos in degrees uses mathlib Return Mat8( C,-S,0, S,C,0, 0,0,1); end $ % ****************** % scaling * % ****************** Procedure XSCALE (SX)$ %. scaling along X axis only. SCALE1 (SX,1) $ Procedure YSCALE (SY)$ %. scaling along Y axis only. SCALE1 (1,SY) $ Procedure SCALE1(XT,YT)$ %. scaling transformation Mat8 ( XT, 0, 0, %. matrix. 0 ,YT, 0, 0, 0, 1)$ Procedure SCALE SFACT; %. scaling along 2 axes. SCALE1(SFACT,SFACT); % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Procedure definitions % % in the interpreter % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Put('OnePoint,'PBINTRP,'DrawPOINT)$ Put('POINTSET,'PBINTRP,'DrawPOINTSET)$ Put('GROUP,'PBINTRP,'DrawGROUP)$ Put('TRANSFORM,'PBINTRP,'PERFORMTRANSFORM)$ Put('PICTURE,'PBINTRP,'DrawModel)$ Put('CIRCLE,'PBINTRP,'DrawCIRCLE)$ Put('BEZIER,'PBINTRP,'DOBEZIER)$ Put('LINE,'PBINTRP,'DOLINE)$ Put('BSPLINE,'PBINTRP,'DOBSPLINE)$ Put('REPEATED, 'PBINTRP,'DOREPEATED)$ Put('Color,'pbintrp,'Docolor); %****************************************** % SETUP Procedure FOR BEZIER AND BSPLINE * % LINE and COLOR %****************************************** procedure DoColor(Object,N); Begin scalar SaveColor; SaveColor:=Current!.color; N:=Car1 N; % See CIRCLE example, huh? If IDP N then N:=EVAL N; ChangeColor N; Draw1(Object,CURRENT!.TRANSFORM); ChangeColor SaveColor; Return NIL; End; Procedure DOBEZIER OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BEZIER$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOBSPLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'BSPLINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ Procedure DOLINE OBJECT$ Begin scalar CURRENT!.LINE$ CURRENT!.LINE := 'LINE$ Draw1(Object,CURRENT!.TRANSFORM); end$ %************************************* % interpreted function calls * %************************************* Procedure DOREPEATED(MODEL,REPTFUN)$ %. repeat applying Begin scalar TEMP,I,TRANS,COUNT,TS,TA,GRP$ %. transformations. TRANS := PRLISPCDR REPTFUN$ If LENGTH TRANS = 1 then TRANS := EVAL CAR1 TRANS else % "TRANS": transformation << TS :=CAR1 TRANS$ % matrix. TA := PRLISPCDR TRANS $ % "MODEL": the model. TRANS := APPLY(TS,TA) >> $ % "COUNT": the times "MODEL" COUNT := CAR1 REPTFUN$ % is going to be GRP := LIST('GROUP)$ % repeated. TEMP := V!.COPY TRANS$ FOR I := 1 : COUNT DO << GRP := LIST('TRANSFORM,MODEL,TEMP) . GRP$ TEMP := MAT!*MAT(TEMP,TRANS) >>$ GRP := REVERSE GRP$ Return GRP end$ %*********************************** % Define SHOW ESHOW Draw AND EDraw * % ESHOW AND EDraw ERASE THE SCREEN * %*********************************** Procedure SHOW X; %. ALIAS FOR Draw << If DEV!. = 'MPS then %. MPS driver don't call << %. echo functions for diplay %. device DISPLAY!.LIST := LIST (X, DISPLAY!.LIST); FOR EACH Z IN DISPLAY!.LIST DO If Z neq NIL then Draw1(Z,GLOBAL!.TRANSFORM); % Draw object list % to frame PSnewframe(); % display frame >> else << GraphOn(); % call echo off If not emode % If neccessary turn low level Draw1(X,GLOBAL!.TRANSFORM); % Draw model tekronix style GraphOff(); % call echoon >>; >>; Procedure ESHOW ZZ$ %. erases the screen and <<Erase(); %. display the picture "ZZ" GraphOn(); DELAY(); Draw1(ZZ,GLOBAL!.TRANSFORM); % Draw model tekronix style If DEV!. = 'MPS then << % Mps display frame PSnewframe(); DISPLAY!.LIST := ZZ; >>; GraphOff(); 0 >>; DefineROP('SHOW,10); %. set up precedence DefineROP('ESHOW,10); Procedure Draw X; %. ALIAS FOR SHOW SHOW X$ Procedure EDraw ZZ$ %. erases the screen and ESHOW ZZ$ DefineROP('Draw,10); DefineROP('EDraw,10); Procedure Col N; % User top-level color <<GraphOn(); ChangeColor N; GraphOff()>>; %************************************* % Define Draw FUNCTIONS FOR VARIOUS * % TYPES OF DISPLAYABLE OBJECTS * %************************************* Procedure DrawModel PICT$ %. given picture "PICT" will Draw1(PICT,CURRENT!.TRANSFORM)$ %. be applyied with global Procedure DERROR(MSG,OBJECT); <<PRIN2 " Draw Error `"; PRIN2T MSG; PRIN2 OBJECT; ERROR(700,MSG)>>; Procedure Draw1 (PICT,CURRENT!.TRANSFORM)$ % Draw PICT with TRANSFORMATION Begin scalar ITM,ITSARGS$ If NULL Pict then Return NIL; If IDP PICT then PICT:=EVAL PICT; If VECTORP PICT AND SIZE(PICT)=2 then Return DrawPOINT PICT$ If NOT PAIRP PICT then DERROR("Non Pair in Draw1: ",PICT); ITM := CAR1 PICT$ ITSARGS := PRLISPCDR PICT$ If NOT (ITM = 'TRANSFORM) then ITSARGS := LIST ITSARGS$ % gets LIST of args ITM := GET (ITM,'PBINTRP)$ If NULL ITM then DERROR("Unknown Operator in Draw1:",PICT); APPLY(ITM,ITSARGS)$ Return PICT$ end$ Procedure DrawGROUP(GRP)$ % Draw a group object Begin scalar ITM,ITSARGS,LMNT$ If PAIRP GRP then FOR EACH LMNT IN GRP DO If PAIRP LMNT then Draw1 (LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL LMNT,CURRENT!.TRANSFORM) else Draw1 (EVAL GRP,CURRENT!.TRANSFORM)$ Return GRP$ end$ Procedure DrawPOINTSET (PNTSET)$ Begin scalar ITM,ITSARGS,PT$ FirstPoint!* := 'T$ If PAIRP PNTSET then << If CURRENT!.LINE = 'BEZIER then PNTSET := DrawBEZIER PNTSET else If CURRENT!.LINE = 'BSPLINE then PNTSET := DrawBSPLINE PNTSET$ FOR EACH PT IN PNTSET DO <<If PAIRP PT then Draw1 (PT,CURRENT!.TRANSFORM) else Draw1 (EVAL PT,CURRENT!.TRANSFORM)$ FirstPoint!* := 'NIL>> >> else Draw1 (EVAL PNTSET,CURRENT!.TRANSFORM)$ Return PNTSET$ end$ Procedure DrawPOINT (PNT)$ Begin scalar CLP,X1,Y1,W1,V,U0,U1,U2; If IDP PNT then PNT := EVAL PNT$ If PAIRP PNT then PNT := MKPOINT PNT; V:=CURRENT!.TRANSFORM; % Transform Only x,y and W U0:=PNT[0]; U1:=PNT[1]; U2:=PNT[2]; X1:=U0 * V[0] + U1 * V[1] + U2 * V[2]; Y1:=U0 * V[3] + U1 * V[4] + U2 * V[5]; W1:=U0 * V[6] + U1 * V[7] + U2 * V[8]; IF NOT( (W1=1) or (W1 = 1.0)) then <<x1:=x1/w1; y1:=y1/w1>>; If FirstPoint!* then Return MoveToXY(X1,Y1); % back to w=1 plane If needed. CLP := CLIP2D(HEREPOINTX,HerePointY, X1,Y1)$ If CLP then <<MoveToXY(CLP[0],CLP[1])$ DrawToXY(CLP[2],CLP[3])>>$ end$ Procedure PERFORMTRANSFORM(PCTSTF,TRNSFRM)$ Begin scalar PROC,OLDTRNS,TRNSFMD,TRANSFOP, TRANSARG,ITM,ITSARGS$ If IDP TRNSFRM then TRNSFRM := EVAL TRNSFRM$ If VECTORP TRNSFRM AND SIZE(TRNSFRM) = 8 then Draw1 (PCTSTF,MAT!*MAT(TRNSFRM,CURRENT!.TRANSFORM)) else If PAIRP TRNSFRM then <<TRANSFOP := CAR1 TRNSFRM$ If (TRANSARG := PRLISPCDR TRNSFRM) then TRANSARG := LIST (PCTSTF,TRANSARG) else TRANSARG := LIST PCTSTF$ If (TRANSFOP = 'BEZIER OR TRANSFOP = 'BSPLINE) then APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG) else Draw1 (APPLY(GET(TRANSFOP,'PBINTRP),TRANSARG), CURRENT!.TRANSFORM) >> end$ %*************************************** % circle bezier and bspline functions * %*************************************** Procedure DrawCIRCLE(CCNTR,RADIUS); %. Draw a circle Begin scalar APNT,POLY,APNTX, APNTY$ POLY := LIST('POINTSET)$ If IDP CCNTR then CCNTR := EVAL CCNTR$ RADIUS := CAR1 RADIUS$ If IDP RADIUS then RADIUS := EVAL RADIUS$ FOR ANGL := 180 STEP -15 UNTIL -180 DO % each line segment << APNTX := CCNTR[0] + RADIUS * COSD ANGL$ % represents an arc of 15 dgrs APNTY := CCNTR[1] + RADIUS * SIND ANGL$ POLY := LIST('Onepoint,APNTX,APNTY) . POLY>>$ Return REVERSE POLY end$ Procedure DrawBspline CONPTS$ %. a "closed" Periodic bspline curve Begin scalar N,CURPTS, % See CATMUL thesis Appendix CPX,CPY, % Note correction in Matrix! X0,X1,X2,X3, Y0,Y1,Y2,Y3, T1,T2,T3, J0,J1,J2, NPTS; NPTS := 4; N := LENGTH CONPTS$ %/ Check at least 4 ? CONPTS := Append (CONPTS,CONPTS)$ % To make a Closed Loop % Set the Initial 4 points X0:=0; % Dummy Y0:=0; X1:=GETV(CAR CONPTS,0); % Will Be X0,Y0 in loop Y1:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X2:=GETV(CAR CONPTS,0); Y2:=GETV(CAR CONPTS,1); CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); WHILE N > 0 DO << X0 := X1; Y0 := Y1; % Cycle Points X1 := X2; Y1 := Y2; X2 := X3; Y2 := Y3; CONPTS := CDR CONPTS; X3:=GETV(CAR CONPTS,0); Y3:=GETV(CAR CONPTS,1); % Compute X(t) and Y(t) for NPTS points on [0.0,1.0] FOR I := 0:NPTS-1 DO << T1 := FLOAT(I)/NPTS$ % Powers of t T2 := T1 * T1; T3 := T2 * T1; %/ ( -1 3 -3 1 %/ 3 -6 3 0 %/ -3 0 3 0 %/ 1 4 1 0 ) J0:= (1.0-T3) + 3.0*(T2-T1); J1 := 3.0*T3 - 6*T2 +4.0; J2 := 1.0+ 3.0*(T1 +T2- T3); CPX := (X0*J0 +X1*J1 + X2 *J2 +X3*T3)/6.0; CPY := (Y0*J0 +Y1*J1 + Y2 *J2 +Y3*T3)/6.0; CURPTS := Pnt2(CPX, CPY,1.0) . CURPTS >>$ N := N - 1>>; Return CURPTS end$ % Faster 2-d Bezier procedure DrawBEZIER CNTS; % Give list of Points Begin scalar LEN, NALL, SAVEX, SAVEY, CPX, CPY, CURPTS, T0, T1, TEMP, FACTL, TI, FI,COEFF; LEN := Isub1 LENGTH(CNTS); SaveX := MKVect Len; SaveY := MKVect Len; FACTL := IFACT LEN; FOR I := 0:LEN DO <<Coeff := FactL/(IFACT(i)*IFACT(Len-i)); SAVEX[I] := GETV(CAR CNTS, 0) * Coeff; SAVEY[I] := GETV(CAR CNTS, 1) * Coeff;; CNTS := CDR CNTS>>; NALL := 1.0/(8.0 * LEN); % Step Size FOR T0 := 0.0 STEP NALL UNTIL 1.0 DO << T1 := 1.0-T0; TI := T0; TEMP := T1**LEN; CPX := TEMP * SAVEX[0]; CPY := TEMP * SAVEY[0]; FOR I := 1:LEN DO << TEMP := (TI * (T1**(LEN - I))); TI := TI * T0; CPX := TEMP * SAVEX[I] + CPX; CPY := TEMP * SAVEY[I] + CPY >>; CURPTS := LIST ('ONEPOINT, CPX, CPY) . CURPTS >>; Return REVERSE CURPTS; end; procedure IFACT N; % fast factorial Begin scalar M; M:=1; While Igreaterp(N,1) do <<M:=Itimes2(N,M); N :=Isub1 N>>; Return M; end; LoadTime SetUpVariables(); % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/util/pr2d-text.build version [c7d7007ab5].
> > | 1 2 | CompileTime load pr2d!-main; in "pr2d-text.red"$ |
Added psl-1983/util/pr2d-text.red version [f81e924f12].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % 8 * 12 Vector Characters CV := MkVect(127)$ BlankChar := 'NIL$ % Labeled Points on Rectangle (8 x 12 ) % C4 Q6 S3 Q5 C3 % % % Q7 M3 Q4 % % % S4 M4 M0 M2 S2 % % % Q8 M1 Q3 % % % C1 Q1 S1 Q2 C2 % Corners: C1:={0,0}$ C2 := {8,0}$ C4:={0,12}$ C3:= {8,12}$ % Side MidPoints: S1 := {4,0}$ S3 := {4,12}$ S4 := {0,6}$ S2 := {8,6}$ % Middle: M0 := {4,6}$ M1 := {4,3}$ M2 := {6,6}$ M3 := {4,9}$ M4 := {2,6}$ % Side Quarter Points: Q1 := {2,0}$ Q2 := {6,0}$ Q3 := {8,3}$ Q4 := {8,9}$ Q5 := {6,12}$ Q6 := {2,12}$ Q7 := {0,9}$ Q8 := {0,3}$ For i:=0:127 do CV[I]:=BlankChar; % UpperCase: CV[Char A] := C1 _ S3 _ C2 & M4 _ M2$ CV[Char B] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M2 _ Q3 _ Q2 _ C1 $ CV[Char C] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char D] := C1 _ C4 _ Q5 _ Q4 _ Q3 _ Q2 _ C1$ CV[Char E] := C3 _ C4 _ C1 _ C2 & S4 _ S2$ CV[Char F] := C3 _ C4 _ C1 & S4 _ S2$ CV[Char G] := M0 _ S2 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4$ CV[Char H] := C4 _ C1 & S4 _ S2 & C3 _ C2$ CV[Char I] := S1 _ S3$ CV[Char J] := C3 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char K] := C4 _ C1 & C3 _ S4 _ C2$ CV[Char L] := C4 _ C1 _ C2$ CV[Char M] := C1 _ C4 _ M0 _ C3 _ C2$ CV[Char N] := C1 _ C4 _ C2 _ C3$ CV[Char O] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3$ CV[Char P] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4$ CV[Char Q] := Q3 _ Q2 _ Q1 _ Q8 _ Q7 _ Q6 _ Q5 _ Q4 _ Q3 & C2 _ M1$ CV[Char R] := C1 _ C4 _ Q5 _ Q4 _ M2 _ S4 & M0 _ C2$ CV[Char S] := Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char T] := C4 _ C3 & S3 _ S1$ CV[Char U] := C4 _ Q8 _ Q1 _ Q2 _ Q3 _ C3$ CV[Char V] := C4 _ S1 _ C3$ CV[Char W] := C4 _ Q1 _ M0 _ Q2 _ C3$ CV[Char X] := C1 _ C3 & C4 _ C2$ CV[Char Y] := C4 _ M0 _ C3 & M0 _ S1$ CV[Char Z] := C4 _ C3 _ C1 _ C2$ % Lower Case, Alias for Now: CV[Char Lower A] := CV[Char A]$ CV[Char Lower B] := CV[Char B]$ CV[Char Lower C] := CV[Char C]$ CV[Char Lower D] := CV[Char D]$ CV[Char Lower E] := CV[Char E]$ CV[Char Lower F] := CV[Char F]$ CV[Char Lower G] := CV[Char G]$ CV[Char Lower H] := CV[Char H]$ CV[Char Lower I] := CV[Char I]$ CV[Char Lower J] := CV[Char J]$ CV[Char Lower K] := CV[Char K]$ CV[Char Lower L] := CV[Char L]$ CV[Char Lower M] := CV[Char M]$ CV[Char Lower N] := CV[Char N]$ CV[Char Lower O] := CV[Char O]$ CV[Char Lower P] := CV[Char P]$ CV[Char Lower Q] := CV[Char Q]$ CV[Char Lower R] := CV[Char R]$ CV[Char Lower S] := CV[Char S]$ CV[Char Lower T] := CV[Char T]$ CV[Char Lower U] := CV[Char U]$ CV[Char Lower V] := CV[Char V]$ CV[Char Lower W] := CV[Char W]$ CV[Char Lower X] := CV[Char X]$ CV[Char Lower Y] := CV[Char Y]$ CV[Char Lower Z] := CV[Char Z]$ % Digits: CV[Char 0] := CV[Char O]$ CV[Char 1] := CV[Char I]$ CV[Char 2] := Q7 _ Q6 _ Q5 _ Q4 _ M0 _ C1 _ C2$ CV[Char 3] := C4 _ C3 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 4] := S1 _ S3 _ S4 _ S2$ CV[Char 5] := C3 _ C4 _ S4 _ M0 _ Q3 _ Q2 _ Q1 _ Q8$ CV[Char 6] := Q4 _ Q5 _ Q6 _ Q7 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M4 _ Q8$ CV[Char 7] := C4 _ C3 _ S1$ CV[Char 8] := M0 _ M4 _ Q8 _ Q1 _ Q2 _ Q3 _ M2 _ M0 & M2 _ Q4 _ Q5 _ Q6 _ Q7 _ M4$ CV[Char 9] := Q8 _ Q1 _ Q2 _ Q3 _ Q4 _ Q5 _ Q6 _ Q7 _ M4 _ M2 _ Q4$ % Some Special Chars: CV[Char !+ ] := S1 _ S3 & S4 _ S2$ CV[Char !- ] := S4 _ S2 $ CV[Char !* ] := S1 _ S3 & S4 _ S2 & C1 _ C3 & C4 _ C2 $ CV[Char !/ ] := C1 _ C3 $ CV[Char !\ ] := C4 _ C2 $ CV[Char !( ] := Q6 _ Q7 _ Q8 _ Q1 $ CV[Char !) ] := Q5 _ Q4 _ Q3 _ Q2 $ CV[Char ![ ] := Q6 _ C4 _ C1 _ Q1$ CV[Char !] ] := Q5 _ C3 _ C2 _ Q2$ CV[Char != ] := Q7 _ Q4 & Q8 _ Q3 $ % Some Simple Display Routines: Xshift := Xmove(10)$ Yshift := Ymove(15)$ Procedure ShowString(S); <<Graphon(); ShowString1(S,Global!.Transform); Graphoff()>>; Procedure ShowString1(S,Current!.Transform); Begin scalar i,ch; For i:=0:Size S do <<Draw1(CV[S[i]],Current!.Transform); Current!.Transform := Mat!*mat(XShift,Current!.TRansform)>>; End; Procedure C x; if x:=CV[x] then EShow x; Procedure FullTest(); <<Global!.Transform := MAT!*1; ShowString "ABCDEFGHIJKLMNOPQRTSUVWXYZ 0123456789"; NIL>>; Procedure SpeedTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do C i; NIL>>; Procedure SlowTest(); <<Global!.Transform := Mat!*1; For i:=0:127 do <<C i; Delay()>>; NIL>>; Procedure Delay; For i:=1:500 do nil; Procedure Text(S); List('TEXT,S); Put('TEXT,'PBINTRP,'DrawTEXT)$ Procedure DrawText(StartPoint,S); %. Draw a Text String Begin scalar MoveP; If IDP StartPoint then StartPoint := EVAL StartPoint$ S := CAR1 S$ If IDP S then S := EVAL S$ MoveP:=PositionAt StartPoint; ShowString1(S,Mat!*Mat(MoveP,Current!.Transform)); Return NIL; end$ Procedure PositionAt StartPoint; % return A matrix to set relative Origin << If IDP StartPoint then StartPoint := EVAL StartPoint$ Mat8(1,0,StartPoint[0], 0,1,StartPoint[1], 0,0,StartPoint[2])>>; |
Added psl-1983/util/pretty.build version [5d38e1e846].
> | 1 | in "pretty.red"$ |
Added psl-1983/util/pretty.red version [18ef06a09c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>PRETTY.RED.2, 2-Sep-82 09:16:32, Edit by BENSON % PRETTYPRINT returns NIL instead of its argument % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % A. C. Norman. July 1978; % Functions: % SUPERPRINT(X) print expression X % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = << SUPERPRINTM(X,POSN()), TERPRI() >> % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; SYMBOLIC; GLOBAL '(!*SYMMETRIC !*QUOTES THIN!*); !*SYMMETRIC:=T; !*QUOTES:=T; THIN!*:=5; SYMBOLIC PROCEDURE SUPERPRINT X; << SUPERPRINM(X,0); TERPRI(); X>>; SYMBOLIC PROCEDURE PRETTYPRINT X; << SUPERPRINM(X,POSN()); %WHAT REDUCE DOES NOW; TERPRI(); NIL >>; SYMBOLIC PROCEDURE SUPERPRINTM(X,LMAR); << SUPERPRINM(X,LMAR); TERPRI(); X >>; % FROM HERE DOWN THE FUNCTIONS ARE NOT INTENDED FOR DIRECT USE; FLUID '(STACK BUFFERI BUFFERO BN LMAR RMAR INITIALBLANKS PENDINGRPARS INDENTLEVEL INDBLANKS RPARCOUNT); SYMBOLIC PROCEDURE SUPERPRINM(X,LMAR); BEGIN SCALAR STACK,BUFFERI,BUFFERO,BN,INITIALBLANKS,RMAR, PENDINGRPARS,INDENTLEVEL,INDBLANKS,RPARCOUNT,W; BUFFERI:=BUFFERO:=LIST NIL; %FIFO BUFFER; INITIALBLANKS:=0; RPARCOUNT:=0; INDBLANKS:=0; RMAR:=LINELENGTH NIL-3; %RIGHT MARGIN; IF RMAR<25 THEN ERROR(0,LIST(RMAR+3, "LINELENGTH TOO SHORT FOR SUPERPRINTING")); BN:=0; %CHARACTERS IN BUFFER; INDENTLEVEL:=0; %NO INDENTATION NEEDED, YET; IF LMAR+20>=RMAR THEN LMAR:=RMAR-21; %NO ROOM FOR SPECIFIED MARGIN; W:=POSN(); IF W>LMAR THEN << TERPRI(); W:=0 >>; IF W<LMAR THEN INITIALBLANKS:=LMAR-W; PRINDENT(X,LMAR+3); %MAIN RECURSIVE PRINT ROUTINE; % TRAVERSE ROUTINE FINISHED - NOW TIDY UP BUFFERS; OVERFLOW 'NONE; %FLUSH OUT THE BUFFER; RETURN X END; % ACCESS FUNCTIONS FOR A STACK ENTRY; CompileTime << SMACRO PROCEDURE TOP; CAR STACK; SMACRO PROCEDURE DEPTH FRM; CAR FRM; SMACRO PROCEDURE INDENTING FRM; CADR FRM; SMACRO PROCEDURE BLANKCOUNT FRM; CADDR FRM; SMACRO PROCEDURE BLANKLIST FRM; CDDDR FRM; SMACRO PROCEDURE SETINDENTING(FRM,VAL); RPLACA(CDR FRM,VAL); SMACRO PROCEDURE SETBLANKCOUNT(FRM,VAL); RPLACA(CDDR FRM,VAL); SMACRO PROCEDURE SETBLANKLIST(FRM,VAL); RPLACD(CDDR FRM,VAL); SMACRO PROCEDURE NEWFRAME N; LIST(N,NIL,0); SMACRO PROCEDURE BLANKP CHAR; NUMBERP CAR CHAR; >>; SYMBOLIC PROCEDURE PRINDENT(X,N); % PRINT LIST X WITH INDENTATION LEVEL N; IF ATOM X THEN IF VECTORP X THEN PRVECTOR(X,N) ELSE FOR EACH C IN (IF !*SYMMETRIC THEN IF STRINGP X THEN EXPLODES X ELSE EXPLODE X ELSE EXPLODEC X) DO PUTCH C ELSE IF READMACROP X THEN << FOR EACH C IN GET(CAR X,'READMACROTOKEN) DO PUTCH C; PRINDENT(CADR X,N+GET(CAR X,'READMACROSIZE)) >> ELSE BEGIN SCALAR CX; IF 4*N>3*RMAR THEN << %LIST IS TOO DEEP FOR SANITY; OVERFLOW 'ALL; N:=N/8; IF INITIALBLANKS>N THEN << LMAR:=LMAR-INITIALBLANKS+N; INITIALBLANKS:=N >> >>; STACK := (NEWFRAME N) . STACK; PUTCH ('LPAR . TOP()); CX:=CAR X; PRINDENT(CX,N+1); IF IDP CX AND NOT ATOM CDR X THEN CX:=GET(CX,'PPFORMAT) ELSE CX:=NIL; IF CX=2 AND ATOM CDDR X THEN CX:=NIL; IF CX='PROG THEN << PUTCH '! ; PRINDENT(CAR (X:=CDR X),N+3) >>; % CX NOW CONTROLS THE FORMATTING OF WHAT FOLLOWS: % NIL DEFAULT ACTION % <NUMBER> FIRST FEW BLANKS ARE NON-INDENTING % PROG DISPLAY ATOMS AS LABELS; X:=CDR X; SCAN: IF ATOM X THEN GO TO OUTL; FINISHPENDING(); %ABOUT TO PRINT A BLANK; IF CX='PROG THEN << PUTBLANK(); OVERFLOW BUFFERI; %FORCE FORMAT FOR PROG; IF ATOM CAR X THEN << % A LABEL; LMAR:=INITIALBLANKS:=MAX(LMAR-6,0); PRINDENT(CAR X,N-3); % PRINT THE LABEL; X:=CDR X; IF NOT ATOM X AND ATOM CAR X THEN GO TO SCAN; IF LMAR+BN>N THEN PUTBLANK() ELSE FOR I:=LMAR+BN:N-1 DO PUTCH '! ; IF ATOM X THEN GO TO OUTL >> >> ELSE IF NUMBERP CX THEN << CX:=CX-1; IF CX=0 THEN CX:=NIL; PUTCH '! >> ELSE PUTBLANK(); PRINDENT(CAR X,N+3); X:=CDR X; GO TO SCAN; OUTL: IF NOT NULL X THEN << FINISHPENDING(); PUTBLANK(); PUTCH '!.; PUTCH '! ; PRINDENT(X,N+5) >>; PUTCH ('RPAR . (N-3)); IF INDENTING TOP()='INDENT AND NOT NULL BLANKLIST TOP() THEN OVERFLOW CAR BLANKLIST TOP() ELSE ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE EXPLODES X; %dummy function just in case another format is needed; EXPLODE X; SYMBOLIC PROCEDURE PRVECTOR(X,N); BEGIN SCALAR BOUND; BOUND:=UPBV X; % LENGTH OF THE VECTOR; STACK:=(NEWFRAME N) . STACK; PUTCH ('LSQUARE . TOP()); PRINDENT(GETV(X,0),N+3); FOR I:=1:BOUND DO << % PUTCH '!,; % removed "," between vector elements for PSL PUTBLANK(); PRINDENT(GETV(X,I),N+3) >>; PUTCH('RSQUARE . (N-3)); ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE PUTBLANK(); BEGIN SCALAR B; PUTCH TOP(); %REPRESENTS A BLANK CHARACTER; SETBLANKCOUNT(TOP(),BLANKCOUNT TOP()+1); SETBLANKLIST(TOP(),BUFFERI . BLANKLIST TOP()); %REMEMBER WHERE I WAS; INDBLANKS:=INDBLANKS+1 END; SYMBOLIC PROCEDURE ENDLIST L; %FIX UP THE BLANKS IN A COMPLETE LIST SO THAT THEY %WILL NOT BE TURNED INTO INDENTATIONS; PENDINGRPARS:=L . PENDINGRPARS; % WHEN I HAVE PRINTED A ')' I WANT TO MARK ALL OF THE BLANKS % WITHIN THE PARENTHESES AS BEING UNINDENTED, ORDINARY BLANK % CHARACTERS. IT IS HOWEVER POSSIBLE THAT I MAY GET A BUFFER % OVERFLOW WHILE PRINTING A STRING OF )))))))))), AND SO THIS % MARKING SHOULD BE DELAYED UNTIL I GET ROUND TO PRINTING % A FURTHER BLANK (WHICH WILL BE A CANDIDATE FOR A PLACE TO % SPLIT LINES). THIS DELAY IS DEALT WITH BY THE LIST % PENDINGRPARS WHICH HOLDS A LIST OF LEVELS THAT, WHEN % CONVENIENT, CAN BE TIDIED UP AND CLOSED OUT; SYMBOLIC PROCEDURE FINISHPENDING(); << FOR EACH STACKFRAME IN PENDINGRPARS DO << IF INDENTING STACKFRAME NEQ 'INDENT THEN FOR EACH B IN BLANKLIST STACKFRAME DO << RPLACA(B,'! ); INDBLANKS:=INDBLANKS-1 >>; % BLANKLIST OF STACKFRAME MUST BE NON-NIL SO THAT OVERFLOW % WILL NOT TREAT THE '(' SPECIALLY; SETBLANKLIST(STACKFRAME,T) >>; PENDINGRPARS:=NIL >>; SYMBOLIC PROCEDURE READMACROP X; !*QUOTES AND NOT ATOM X AND IDP CAR X AND GET(CAR X,'READMACROTOKEN) AND NOT ATOM CDR X AND NULL CDDR X; DEFLIST('( (QUOTE (!')) (BACKQUOTE (!`)) (UNQUOTE (!,)) (UNQUOTEL (!, !@)) (UNQUOTED (!, !.))), 'READMACROTOKEN); FOR EACH U IN '(QUOTE BACKQUOTE UNQUOTE) DO PUT(U,'READMACROSIZE,1); FOR EACH U IN '(UNQUOTEL UNQUOTED) DO PUT(U,'READMACROSIZE,2); % PROPERTY PPFORMAT DRIVES THE PRETTYPRINTER - % PROG : SPECIAL FOR PROG ONLY % 1 : (FN A1 % A2 % ... ) % 2 : (FN A1 A2 % A3 % ... ) ; PUT('PROG,'PPFORMAT,'PROG); PUT('LAMBDA,'PPFORMAT,1); PUT('LAMBDAQ,'PPFORMAT,1); PUT('SETQ,'PPFORMAT,1); PUT('SET,'PPFORMAT,1); PUT('WHILE,'PPFORMAT,1); PUT('T,'PPFORMAT,1); PUT('DE,'PPFORMAT,2); PUT('DF,'PPFORMAT,2); PUT('DM,'PPFORMAT,2); PUT('FOREACH,'PPFORMAT,4); % (FOREACH X IN Y DO ...) ETC; % NOW FOR THE ROUTINES THAT BUFFER THINGS ON A CHARACTER BY CHARACTER % BASIS, AND DEAL WITH BUFFER OVERFLOW; SYMBOLIC PROCEDURE PUTCH C; BEGIN IF ATOM C THEN RPARCOUNT:=0 ELSE IF BLANKP C THEN << RPARCOUNT:=0; GO TO NOCHECK >> ELSE IF CAR C='RPAR THEN << RPARCOUNT:=RPARCOUNT+1; % FORMAT FOR A LONG STRING OF RPARS IS: % )))) ))) ))) ))) ))) ; IF RPARCOUNT>4 THEN << PUTCH '! ; RPARCOUNT:=2 >> >> ELSE RPARCOUNT:=0; WHILE LMAR+BN>=RMAR DO OVERFLOW 'MORE; NOCHECK: BUFFERI:=CDR RPLACD(BUFFERI,LIST C); BN:=BN+1 END; SYMBOLIC PROCEDURE OVERFLOW FLG; BEGIN SCALAR C,BLANKSTOSKIP; %THE CURRENT BUFFER HOLDS SO MUCH INFORMATION THAT IT WILL %NOT ALL FIT ON A LINE. TRY TO DO SOMETHING ABOUT IT; % FLG IS ONE OF: % 'NONE DO NOT FORCE MORE INDENTATION % 'MORE FORCE ONE LEVEL MORE INDENTATION % <A POINTER INTO THE BUFFER> % PRINTS UP TO AND INCLUDING THAT CHARACTER, WHICH % SHOULD BE A BLANK; IF INDBLANKS=0 AND INITIALBLANKS>3 AND FLG='MORE THEN << INITIALBLANKS:=INITIALBLANKS-3; LMAR:=LMAR-3; RETURN 'MOVED!-LEFT >>; FBLANK: IF BN=0 THEN << %NO BLANK FOUND - CAN DO NO MORE FOR NOW; % IF FLG='MORE I AM IN TROUBLE AND SO HAVE TO PRINT % A CONTINUATION MARK. IN THE OTHER CASES I CAN JUST EXIT; IF NOT(FLG = 'MORE) THEN RETURN 'EMPTY; IF ATOM CAR BUFFERO THEN % CONTINUATION MARK NOT NEEDED IF LAST CHAR PRINTED WAS % SPECIAL (E.G. LPAR OR RPAR); PRIN2 "%+"; %CONTINUATION MARKER; TERPRI(); LMAR:=0; RETURN 'CONTINUED >> ELSE << SPACES INITIALBLANKS; INITIALBLANKS:=0 >>; BUFFERO:=CDR BUFFERO; BN:=BN-1; LMAR:=LMAR+1; C:=CAR BUFFERO; IF ATOM C THEN << PRINC C; GO TO FBLANK >> ELSE IF BLANKP C THEN IF NOT ATOM BLANKSTOSKIP THEN << PRINC '! ; INDBLANKS:=INDBLANKS-1; % BLANKSTOSKIP = (STACK-FRAME . SKIP-COUNT); IF C EQ CAR BLANKSTOSKIP THEN << RPLACD(BLANKSTOSKIP,CDR BLANKSTOSKIP-1); IF CDR BLANKSTOSKIP=0 THEN BLANKSTOSKIP:=T >>; GO TO FBLANK >> ELSE GO TO BLANKFOUND ELSE IF CAR C='LPAR OR CAR C='LSQUARE THEN << PRINC GET(CAR C,'PPCHAR); IF FLG='NONE THEN GO TO FBLANK; % NOW I WANT TO FLAG THIS LEVEL FOR INDENTATION; C:=CDR C; %THE STACK FRAME; IF NOT NULL BLANKLIST C THEN GO TO FBLANK; IF DEPTH C>INDENTLEVEL THEN << %NEW INDENTATION; % THIS LEVEL HAS NOT EMITTED ANY BLANKS YET; INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >>; GO TO FBLANK >> ELSE IF CAR C='RPAR OR CAR C='RSQUARE THEN << IF CDR C<INDENTLEVEL THEN INDENTLEVEL:=CDR C; PRINC GET(CAR C,'PPCHAR); GO TO FBLANK >> ELSE ERROR(0,LIST(C,"UNKNOWN TAG IN OVERFLOW")); BLANKFOUND: IF EQCAR(BLANKLIST C,BUFFERO) THEN SETBLANKLIST(C,NIL); % AT LEAST ONE ENTRY ON BLANKLIST OUGHT TO BE VALID, SO IF I % PRINT THE LAST BLANK I MUST KILL BLANKLIST TOTALLY; INDBLANKS:=INDBLANKS-1; % CHECK IF NEXT LEVEL REPRESENTS NEW INDENTATION; IF DEPTH C>INDENTLEVEL THEN << IF FLG='NONE THEN << %JUST PRINT AN ORDINARY BLANK; PRINC '! ; GO TO FBLANK >>; % HERE I INCREASE THE INDENTATION LEVEL BY ONE; IF BLANKSTOSKIP THEN BLANKSTOSKIP:=NIL ELSE << INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >> >>; %OTHERWISE I WAS INDENTING AT THAT LEVEL ANYWAY; IF BLANKCOUNT C>(THIN!*-1) THEN << %LONG THIN LIST FIX-UP HERE; BLANKSTOSKIP:=C . ((BLANKCOUNT C) - 2); SETINDENTING(C,'THIN); SETBLANKCOUNT(C,1); INDENTLEVEL:=(DEPTH C)-1; PRINC '! ; GO TO FBLANK >>; SETBLANKCOUNT(C,BLANKCOUNT C-1); TERPRI(); LMAR:=INITIALBLANKS:=DEPTH C; IF BUFFERO EQ FLG THEN RETURN 'TO!-FLG; IF BLANKSTOSKIP OR NOT (FLG='MORE) THEN GO TO FBLANK; % KEEP GOING UNLESS CALL WAS OF TYPE 'MORE'; RETURN 'MORE; %TRY SOME MORE; END; PUT('LPAR,'PPCHAR,'!(); PUT('LSQUARE,'PPCHAR,'![); PUT('RPAR,'PPCHAR,'!)); PUT('RSQUARE,'PPCHAR,'!]); |
Added psl-1983/util/prettyprint.build version [9da7686a13].
> > | 1 2 | Compiletime Load Useful; in "prettyprint.sl"$ |
Added psl-1983/util/prettyprint.sl version [1451038a4c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %(!* YPP -- THE PRETTYPRINTER % % <BENSON>YPP.SL.19, 17-Sep-82 09:52:42, Edit by BENSON % Courtesy of IMSSS, with modifications for PSL % % PP( LST:list ) FEXPR % PRETTYPRINT( X:any ) EXPR % % Revision History: % % Feb. 23, 1983 Douglas % Seperated the testing of specially treated test functions % and the printing of these special test functions to % eliminate a recursion problem with special forms in % the cdr slot. % % Feb. 10, 1983 Douglas Lanam % Fixed a bug where special list structures in the cdr position % were not handled correctly. % Also removed calls to the function "add" since this is not % a basic psl function. Replaced them with "plus". % % Feb. 8, 1983 Douglas Lanam % Fix of many numerous small bugs and some clean up of code. % % Feb. 5, 1983 MLG % Changed the nflatsize1 definition line to correct parens. % % Dec. 14, 1982 Douglas Lanam % Fixed bug with sprint-prog and sprint-lamdba, so that it % gets the correct left-margin for sub-expression. % % Dec. 13, 1982 Douglas Lanam % Removal of old code that put properties on 'de','df','dm', % than messed up prettyprint on expressions with that atom % in the car of the expression. Also handles prinlevel, and % prinlength. % Fix bug with '(quote x y). Taught system about labels in % progs and dos. Taught system about special forms: do,let, % de, df, dm, defmacro, and cond. % % November 1982 Douglas Lanam % Rewritten to be more compact, more modular, % and handle vectors. %") (COMPILETIME (FLAG '(WARNING PP-VAL PP-DEF PP-DEF-1 BROKEN GET-GOOD-DEF S2PRINT sprint-dtpr sprint-vector sprint-read-macro read-macro-internal-sprint is-read-macrop handle-read-macros handle-special-list-structures check-if-room-for-and-back-indent nflatsize1 CHRCT SPACES-LEFT SAFE-PPOS POSN1 POSN2 PPOS) 'INTERNALFUNCTION)) (compiletime (fluid '(prinlength prinlevel sprint-level))) (setq sprint-level 0) (DE WARNING (X) (ERRORPRINTF "*** %L" X)) %(!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (X) (PROGN (SPRINT X (posn)) (TERPRI))) (DM PP (L) (LIST 'EVPP (LIST 'QUOTE (CDR L)))) (DE EVPP (L) (PROGN (MAPC L (FUNCTION PP1)) (TERPRI) T)) (DE PP1 (EXP) (PROG NIL (COND ((IDP EXP) (PROGN (PP-VAL EXP) (PP-DEF EXP))) (T (PROGN (SPRINT EXP 1) (TERPRI)))))) (DE PP-VAL (ID) (PROG (VAL) (COND ((ATOM (SETQ VAL (ERRORSET ID NIL NIL))) (RETURN NIL))) (TERPRI) (sprint `(setq ,id ',(car val)) (posn)) (TERPRI))) (DE PP-DEF (ID) (PROG (DEF TYPE ORIG-DEF) (SETQ DEF (GETD ID)) TEST (COND ((NULL DEF) (RETURN (AND ORIG-DEF (WARNING (LIST "Gack. " ID " has no unbroken definition."))))) ((CODEP (CDR DEF)) (RETURN (WARNING (LIST "Can't PP compiled definition for" ID)))) ((AND (NOT ORIG-DEF) (BROKEN ID)) (PROGN (WARNING (LIST "Note:" ID "is broken or traced.")) (SETQ ORIG-DEF DEF) (SETQ DEF (CONS (CAR DEF) (GET-GOOD-DEF ID))) (GO TEST)))) (SETQ TYPE (CAR DEF)) (TERPRI) (SETQ ORIG-DEF (ASSOC TYPE '((EXPR . DE) (MACRO . DM) (FEXPR . DF) (NEXPR . DN)))) (RETURN (PP-DEF-1 (CDR ORIG-DEF) ID (CDDR DEF))))) (DE PP-DEF-1 (FN NAME TAIL) (sprint (cons fn (cons name tail)) (posn))) (DE BROKEN (X) (GET X 'TRACE)) (DE GET-GOOD-DEF (X) (PROG (XX) (COND ((AND (SETQ XX (GET X 'TRACE)) (SETQ XX (ASSOC 'ORIGINALFN XX))) (RETURN (CDR XX)))))) %(!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (S EXP) (PROGN (OR (GREATERP (SPACES-LEFT) (PLUS (FLATSIZE2 S) (nFLATSIZE EXP))) (TERPRI)) (PRIN2 S) (SPRINT EXP (ADD1 (POSN))))) (de make-room-for (left-margin size flag) (cond ((or %flag (greaterp (add1 size) (difference 75 (posn))) (lessp (add1 (posn)) left-margin)) (tab left-margin)))) (de is-read-macrop (exp) (and (pairp exp) (atom (car exp)) (pairp (cdr exp)) (null (cddr exp)) (get (car exp) 'printmacro))) (de read-macro-internal-sprint (read-macro-c a lm1) (make-room-for lm1 (plus2 (flatsize2 read-macro-c) (nflatsize a)) (or (pairp a) (vectorp a))) (princ read-macro-c) (internal-sprint a (plus2 (flatsize2 read-macro-c) lm1))) (de sprint-read-macro (exp left-margin) (let ((c (get (car exp) 'printmacro))) (read-macro-internal-sprint c (cadr exp) left-margin))) (de handle-read-macros (exp left-margin) (prog (c) (cond ((and (pairp exp) (atom (car exp)) (pairp (cdr exp)) (null (cddr exp)) (setq c (get (car exp) 'printmacro))) (read-macro-internal-sprint c (cadr exp) left-margin) (return t))))) (dm define-special-sprint-list-structure (x) ((lambda (tag test-if-special sprint-function) `(progn (put ',tag 'sprint-test ',test-if-special) (put ',tag 'sprint-function ',sprint-function))) (cadr x) (caddr x) (cadddr x))) (de handle-special-list-structures (exp left-margin) (prog (c test) (cond ((and (pairp exp) (atom (car exp))) (setq test (get (car exp) 'sprint-test)) (setq c (get (car exp) 'sprint-function)) (cond ((and (or (null test) (apply test (list exp))) c) (apply c (list exp left-margin)) (return t))))))) (de handle-special-list-structures-in-cdr-slot (exp left-margin) (prog (c test) (cond ((and (pairp exp) (atom (car exp))) (setq test (get (car exp) 'sprint-test)) (setq c (get (car exp) 'sprint-function)) (cond ((and (or (null test) (apply test (list exp))) c) (princ ". ") (apply c (list exp left-margin)) (return t))))))) (define-special-sprint-list-structure lambda sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure cond sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure progn sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure prog1 sprint-lambda-test sprint-lambda) (define-special-sprint-list-structure let sprint-let-test sprint-lambda) (define-special-sprint-list-structure defun sprint-defun-test sprint-defun) (define-special-sprint-list-structure do sprint-do-test sprint-prog) (define-special-sprint-list-structure prog sprint-prog-test sprint-prog) (define-special-sprint-list-structure de sprint-defun-test sprint-defun) (define-special-sprint-list-structure df sprint-defun-test sprint-defun) (define-special-sprint-list-structure dm sprint-defun-test sprint-defun) (define-special-sprint-list-structure defmacro sprint-defun-test sprint-defun) (de sprint-let-test (exp) (and (cdr exp) (pairp (cdr exp)) (pairp (cadr exp)))) (de sprint-do-test (exp) (and (cdr exp) (pairp (cdr exp)) (pairp (cadr exp)) (cddr exp) (pairp (cddr exp)) (pairp (caddr exp)))) (de sprint-defun-test (exp) (and (cdr exp) (pairp (cdr exp)) (cddr exp) (pairp (cddr exp)))) (de sprint-defun (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (let ((a (plus2 1 (posn)))) (princ (car exp)) (princ " ") (princ (cadr exp)) (princ " ") (internal-sprint (caddr exp) a) (do ((i (cdddr exp) (cdr i))) ((null i) %( (princ ")")) (tab a) (cond ((atom i) (princ ". ") (internal-sprint i (plus2 2 a) ) %( (princ ")") (return nil)) ((is-read-macrop i) (make-room-for a (plus2 2 (nflatsize i)) nil) (princ ". ") (sprint-read-macro i a) %( (princ ")") (return nil)) (t (internal-sprint (car i) a)))))) (de sprint-prog-test (exp) (and (cdr exp) (pairp (cdr exp)) (cddr exp))) (de sprint-prog (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (let ((b (posn)) (a (plus2 1 (plus2 (posn) (flatsize (car exp)))))) (princ (car exp)) (princ " ") (internal-sprint (cadr exp) a) (do ((i (cddr exp) (cdr i))) ((null i) %( (princ ")")) (tab b) (cond ((atom i) (princ ". ") (internal-sprint i (plus2 2 a) ) %( (princ ")") (return nil)) ((is-read-macrop i) (make-room-for a (plus2 2 (nflatsize i)) nil) (princ ". ") (sprint-read-macro i a) %( (princ ")") (return nil)) ((atom (car i)) (internal-sprint (car i) b)) (t (internal-sprint (car i) a)))))) (de sprint-lambda-test (exp) (and (cdr exp) (pairp (cdr exp)))) (de sprint-lambda (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (princ "(") %) (princ (car exp)) (princ " ") (let ((a (posn))) (internal-sprint (cadr exp) a) (do ((i (cddr exp) (cdr i))) ((null i) %( (princ ")")) (tab a) (cond ((atom i) (princ ". ") (internal-sprint i (plus2 2 a) ) %( (princ ")") (return nil)) ((is-read-macrop i) (make-room-for a (plus2 2 (nflatsize i)) nil) (princ ". ") (sprint-read-macro i a) %( (princ ")") (return nil)) (t (internal-sprint (car i) a)))))) (de depth-greater-than-n (l n) (cond ((weq n 0) t) ((pairp l) (do ((i l (cdr i))) ((null i)) (cond ((atom i) (return nil)) ((and (pairp i) (depth-greater-than-n (car i) (sub1 n))) (return t))))))) (de sprint-dtpr2 (exp left-margin) (make-room-for left-margin (nflatsize exp) nil) (prog (lm) (princ "(") %) (setq lm (plus2 1 (cond ((and (atom (car exp)) (null (vectorp (car exp))) (lessp (plus2 (posn) (nflatsize (car exp))) 40) (null (depth-greater-than-n exp 13))) (plus2 1 (plus2 left-margin (nflatsize (car exp))))) (t left-margin)))) (do ((a exp (cdr a)) (i 1 (add1 i)) (l (add1 left-margin) lm)) ((null a) % ( (princ ")")) (cond ((and (numberp prinlength) (greaterp i prinlength)) % ( (princ "...)") (return nil))) (cond ((atom a) (make-room-for l (plus2 2 (nflatsize a)) nil) (princ ". ") (internal-sprint a l) %( (princ ")") (return nil)) ((is-read-macrop a) (princ ". ") (sprint-read-macro a (plus2 l 2)) %( (princ ")") (return nil)) ((handle-special-list-structures-in-cdr-slot a left-margin) %( (princ ")") (return nil)) (t (internal-sprint (car a) l))) (cond ((cdr a) (cond ((greaterp (nflatsize (car a)) (difference 75 l)) (tab l)) (t (princ " "))) ))))) (de sprint-dtpr (exp left-margin) ((lambda (sprint-level) (cond ((and (numberp prinlevel) (greaterp sprint-level prinlevel)) (princ "#")) ((handle-read-macros exp left-margin)) ((handle-special-list-structures exp left-margin)) (t (sprint-dtpr2 exp left-margin)))) (add1 sprint-level))) (de sprint-vector (vector left-margin) ((lambda (sprint-level) (cond ((and (Numberp prinlevel) (greaterp sprint-level prinlevel)) (princ "#")) (t (prog (c) (princ "[") (let ((lm (add1 left-margin))) (do ((i 0 (1+ i)) (size (size vector))) ((greaterp i size) (princ "]")) (cond ((and (numberp prinlength) (greaterp i prinlength)) (princ "...]") (return nil))) (internal-sprint (getv vector i) lm) (cond ((lessp i size) (cond ((greaterp (nflatsize (getv vector (plus2 i 1))) (difference 75 lm)) (tab lm)) ((lessp (posn) lm) (tab lm)) (t (princ " "))))))))))) (add1 sprint-level))) (de check-if-room-for-and-back-indent (a lm) (cond ((and (atom a) (null (vectorp a)) (greaterp (add1 (nflatsize a)) (difference (linelength nil) lm)) (null (lessp (posn) 2))) (terpri) (cond ((eq (getv lispscantable* (id2int '!%)) 12) (princ "%")) ((eq (getv lispscantable* (id2int '!;)) 12) (princ ";")) (t (princ "%"))) (princ "**** <<<<<< Reindenting.") (terpri) lm))) (de internal-sprint (a lm) (let ((indent (check-if-room-for-and-back-indent a lm))) (cond ((lessp (posn) lm) (tab lm))) (cond ((handle-read-macros a lm)) ((handle-special-list-structures a lm)) (t (make-room-for lm (nflatsize a) (or (pairp a) (vectorp a))) (cond ((pairp a) (sprint-dtpr a (posn))) ((vectorp a) (sprint-vector a (posn))) (t (and (lessp (posn) lm) (tab lm)) (prin1 a))))) (cond (indent (terpri) (cond ((eq (getv lispscantable* (id2int '!%)) 12) (princ "%")) ((eq (getv lispscantable* (id2int '!;)) 12) (princ ";")) (t (princ "%"))) (princ "**** >>>>> Reindenting.") (terpri))))) (de sprint (exp left-margin) (let ((a (posn)) (sprint-level 0) (b (linelength nil))) (linelength 600) (cond ((eq a left-margin)) (t (tab left-margin))) (internal-sprint exp left-margin) (linelength b) nil)) (PUT 'QUOTE 'PRINTMACRO "'") (PUT 'BACKQUOTE 'PRINTMACRO "`") (PUT 'UNQUOTE 'PRINTMACRO ",") (PUT 'UNQUOTEL 'PRINTMACRO ",@") (PUT 'UNQUOTED 'PRINTMACRO ",.") (DE PM-DEF (FORM) (PP-DEF-1 (CAR FORM) (CADR FORM) (CDDR FORM))) (DE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES-LEFT NIL (SUB1 (CHRCT))) (DE SAFE-PPOS (N SIZE) (PROG (MIN-N) (SETQ MIN-N (SUB1 (DIFFERENCE (LINELENGTH NIL) SIZE))) (COND ((LESSP MIN-N N) (PROGN (OR (GREATERP MIN-N (POSN1)) (TERPRI)) (PPOS MIN-N))) (T (PPOS N))))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) (de nflatsize (n) (nflatsize1 n sprint-level)) (de nflatsize1 (n currentlevel) (cond ((and (numberp prinlevel) (wgreaterp currentlevel prinlevel)) 1) ((vectorp n) (do ((i (size n) (sub1 i)) (s (iplus2 1 (size n)) (iplus2 1 (iplus2 s (nflatsize1 (getv n i) (iplus2 1 currentlevel)))))) ((wlessp i 0) s))) ((atom n) (flatsize n)) ((is-read-macrop n) (let ((c (get (car n) 'printmacro))) (iplus2 (flatsize2 c) (nflatsize1 (cadr n) (iplus2 1 currentlevel))))) ((do ((i n (cdr i)) (s 1 (iplus2 (nflatsize1 (car i) (iplus2 1 currentlevel)) (iplus2 1 s)))) ((null i) s) (cond ((atom i) (return (iplus2 3 (iplus2 s (nflatsize1 i (iplus2 1 currentlevel)))))) ((is-read-macrop i) (return (iplus2 3 (iplus2 s (nflatsize1 i (iplus2 1 currentlevel)))))) ))))) |
Added psl-1983/util/printer-fix.build version [98f3bfa5e8].
> | 1 | in "printer-fix.red"$ |
Added psl-1983/util/printer-fix.red version [a9261531a4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % Some patches to I/O modules Fluid '(DigitStrBase); DigitStrBase:='"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; on syslisp; smacro procedure DigitStr(); strinf LispVar DigitstrBase; syslsp procedure SysPowerOf2P Num; case Num of 1: 0; 2: 1; 4: 2; 8: 3; 16: 4; 32: 5; default: NIL end; syslsp procedure ChannelWriteSysInteger(Channel, Number, Radix); begin scalar Exponent,N1; return if (Exponent := SysPowerOf2P Radix) then ChannelWriteBitString(Channel, Number, Radix - 1, Exponent) else if Number < 0 then << ChannelWriteChar(Channel, char '!-); WriteNumber1(Channel,-(Number/Radix),Radix); % To catch largest NEG ChannelWriteChar(Channel, strbyt(DigitStr(), - MOD(Number, Radix))) >> else if Number = 0 then ChannelWriteChar(Channel, char !0) else WriteNumber1(Channel, Number, Radix); end; syslsp procedure WriteNumber1(Channel, Number, Radix); if Number = 0 then Channel else << WriteNumber1(Channel, Number / Radix, Radix); ChannelWriteChar(Channel, strbyt(Digitstr(), MOD(Number, Radix))) >>; syslsp procedure ChannelWriteBitString(Channel, Number, DigitMask, Exponent); if Number = 0 then ChannelWriteChar(Channel,char !0) else ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); syslsp procedure ChannelWriteBitStrAux(Channel, Number, DigitMask, Exponent); if Number = 0 then Channel % Channel means nothing here else % just trying to fool the compiler << ChannelWriteBitStrAux(Channel, LSH(Number, -Exponent), DigitMask, Exponent); ChannelWriteChar(Channel, StrByt(DigitStr(), LAND(Number, DigitMask))) >>; |
Added psl-1983/util/prlisp-driver.red version [d8d853f1bb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %. PRLISP-DRIVER.RED Terminal/Graphics Drivers for PRLISP %. Date: ~December 1981 %. Authors: M.L. Griss, F. Chen, P. Stay %. Utah Computation Group %. Department of Computer Science %. University of Utah, Salt Lake City. %. Copyright (C) University of Utah 1982 % Also, need either EMODE or RAWIO files for EchoON/EchoOff % Note that under EMODE (!*EMODE= T), EchoOn and EchoOff % Already Done, so GraphOn and GraphOff need to test !*EMODE % csp 7/13/82 % Change to only set !*EMODE to NIL if it is unbound. FLUID '(!*EMODE); % initialize emode to off loadtime <<if UnboundP '!*EMODE then !*EMODE:=NIL;>>; %*************************** % setup functions for * % terminal devices * %*************************** FLUID '(!*UserMode); Procedure FNCOPY(NewName,OldName)$ %. to copy equivalent Begin scalar !*UserMode; CopyD(NewName,OldName); end; % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % hp specific Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure HP!.OutChar x; % Raw Terminal I/O Pbout x; Procedure HP!.OutCharString S; % Pbout a string For i:=0:Size S do HP!.OutChar S[i]; Procedure HP!.grcmd (acmd)$ %. prefix to graphic command <<HP!.OutChar char ESC$ HP!.OutChar char !*$ HP!.OutCharString ACMD$ DELAY() >>$ Procedure HP!.OutInt X; % Pbout a integer <<HP!.OutChar (char !0 + (X/100)); X:=Remainder(x,100); HP!.OutChar (char !0 + (x/10)); HP!.OutChar (char !0+Remainder(x,10)); nil>>; Procedure HP!.Delay$ %. Delay to wait for the display HP!.OutChar CHAR EOL; % Flush buffer Procedure HP!.EraseS()$ %. EraseS graphic diaplay screen <<HP!.GRCMD("dack")$ MOVETOPOINT ORIGIN >>$ Procedure HP!.NormX XX$ %. absolute position along FIX(XX+0.5)+360$ % X axis Procedure HP!.NormY YY$ %. absolute position along FIX(YY+0.5)+180$ % Y axis. Procedure HP!.MoveS (XDEST,YDEST)$ %. move pen to absolute location << HP!.GRCMD("d")$ X := HP!.NormX XDEST$ Y := HP!.NormY YDEST$ HP!.OutInt HP!.NormX XDEST$ HP!.OutChar Char '!,$ HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pacZ") >>$ Procedure HP!.DrawS (XDEST,YDEST)$ %. MoveS pen to the pen position <<HP!.GRCMD("d")$ X := HP!.NormX XDEST$ %. destination and draw a Y := HP!.NormY YDEST$ HP!.OutInt HP!.NormX XDEST$ %. line to it rom previous HP!.OutChar Char '!,$ %. pen position. HP!.OutInt HP!.NormY YDEST$ HP!.OutCharString "oZ"$ HP!.GRCMD("pbcZ")$'NIL>>$ Procedure HP!.CRSRWT()$ %. waiting for input a Begin scalar P,C1,C2,a$ %. character to position HP!.GRCMD("s4^")$ %. a cursor. C1:= READ()$ C2:= READ()$ a := READ()$ P := LIST ('POINT,C1-360,C2-180,HEREPOINT[3])$ HP!.GRCMD("dkZ")$ Return a.P$ end$ Procedure HP!.BUILDP()$ %. builds a list of Begin scalar PNTLST,UNFINISHED,PNT,PNT2,ACT,GRP, %. points from cursor PRVPNT,RAD$ %. MoveS. UNFINISHED := 'T$ PNTLST := LIST(HERE,'POINTSET)$ GRP := LIST('GROUP)$ While UNFINISHED do <<UNFINISHED := HP!.CRSRWT()$ HP!.OutInt UNFINISHED$ ACT := CAR1 UNFINISHED$ PNT := PRLISPCDR UNFINISHED$ HP!.OutInt PNT$HP!.OutInt ACT$ If ACT = 32 then % draw : using "space-bar" <<DrawModel PNT$ % key. PNTLST :=PNT . PNTLST>> else If ACT = 127 then % move : using "del" key. <<MOVEPOINT (PRLISPCDR PNT)$ PNTLST := REVERSE PNTLST$ GRP := PNTLST . GRP $ PNTLST := LIST (PNT,'POINTSET)>> else If ACT = 67 then % draw circle around center <<PNT2 := POINT % passing through cursor (NILTOZERO CAR2 PNT, % using "uppercase c" key. NILTOZERO CAR3 PNT)$ RAD := DISTANCE(CCNTR, PNT2)$ DRAWCIRCLE(LIST RAD)$ PNT := LIST('CIRCLE,RAD)$ PNTLST := PNT . PNTLST >> else If ACT = 99 then % sets circle center : <<MOVEPOINT (PRLISPCDR PNT)$ % using "lowercase c" key. SETCENTER LIST PNT$ PNTLST := LIST('CENTER,PNT) . PNTLST >> else If ACT = 13 then % finish : using "Return" <<UNFINISHED := NIL$ % key. GRP := REVERSE PNTLST . GRP >> >>$ Return REVERSE GRP$ end$ Procedure HP!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport << X1CLIP := MAX2 (-360,X1)$ %. for HP2648A terminal. X2CLIP := MIN2 (360,X2)$ Y1CLIP := MAX2 (-180,Y1)$ Y2CLIP := MIN2 (180,Y2) >>$ Procedure HP!.GRAPHON(); %. No special GraphOn/GraphOff If not !*emode then echooff(); Procedure HP!.GRAPHOFF(); If not !*emode then echoon(); Procedure HP!.INIT$ %. HP device specIfic Begin %. Procedures equivalent. PRINT "HP IS DEVICE"$ DEV!. := 'HP; FNCOPY( 'EraseS, 'HP!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'HP!.NormX)$ % initialization when FNCOPY( 'NormY, 'HP!.NormY)$ % using HP2648A. FNCOPY( 'MoveS, 'HP!.MoveS)$ FNCOPY( 'DrawS, 'HP!.DrawS)$ FNCOPY( 'CRSRWT, 'HP!.CRSRWT)$ FNCOPY( 'VWPORT, 'HP!.VWPORT)$ FNCOPY( 'Delay, 'HP!.Delay)$ FNCOPY( 'GraphOn, 'HP!.GraphOn)$ FNCOPY( 'GraphOff, 'HP!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TEKTRONIX specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Procedure TEK!.OutChar x; Pbout x; Procedure TEK!.EraseS(); %. EraseS screen, Returns terminal <<TEK!.OutChar Char ESC; %. to Alpha mode and places cursor. TEK!.OutChar Char FF>>; Procedure TEK!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << TEK!.OutChar HIGHERY NormY YDEST$ %. information to the TEK!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte TEK!.OutChar HIGHERX NormX XDEST$ %. sequences containing the TEK!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure HIGHERY YDEST$ %. convert Y to higher order Y. FIX(YDEST) / 32 + 32$ Procedure LOWERY YDEST$ %. convert Y to lower order Y. REMAINDER (FIX YDEST,32) + 96$ Procedure HIGHERX XDEST$ %. convert X to higher order X. FIX(XDEST) / 32 + 32$ Procedure LOWERX XDEST$ %. convert X to lower order X. REMAINDER (FIX XDEST,32) + 64$ Procedure TEK!.MoveS(XDEST,YDEST)$ <<TEK!.OutChar 29 $ %. GS: sets terminal to Graphic mode. TEK!.4BYTES (XDEST,YDEST)$ TEK!.OutChar 31>> $ %. US: sets terminal to Alpha mode. Procedure TEK!.DrawS (XDEST,YDEST)$ %. Same as Tek!.MoveS but << TEK!.OutChar 29$ %. draw the line. TEK!.4BYTES (CAR2 HERE, CAR3 HERE)$ TEK!.4BYTES (XDEST, YDEST)$ TEK!.OutChar 31>> $ Procedure TEK!.NormX DESTX$ %. absolute location along DESTX + 512$ %. X axis. Procedure TEK!.NormY DESTY$ %. absolute location along DESTY + 390$ %. Y axis. Procedure TEK!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-512,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (512,X2)$ Y1CLIP := MAX2 (-390,Y1)$ Y2CLIP := MIN2 (390,Y2) >>$ Procedure TEK!.Delay(); NIL; Procedure TEK!.GRAPHON(); %. No special GraphOn (? what of GS/US) If not !*emode then echooff(); Procedure TEK!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEK!.INIT$ %. TEKTRONIX device specIfic Begin %. Procedures equivalent. PRINT "TEKTRONIX IS DEVICE"$ DEV!. := ' TEK; FNCOPY( 'EraseS, 'TEK!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'TEK!.NormX)$ % initialization when using FNCOPY( 'NormY, 'TEK!.NormY)$ % Tektronix 4006-1. FNCOPY( 'MoveS, 'TEK!.MoveS)$ FNCOPY( 'DrawS, 'TEK!.DrawS)$ FNCOPY( 'VWPORT, 'TEK!.VWPORT)$ FNCOPY( 'Delay, 'TEK!.Delay)$ FNCOPY( 'GraphOn, 'TEK!.GraphOn)$ FNCOPY( 'GraphOff, 'TEK!.GraphOff)$ Erase()$ VWPORT(-800,800,-800,800)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Top . . Bottom) Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; FIX(Y)+12; Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xhere,Yhere, X1, Y1,function dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; %********************************** % MPS device routines will only * % work If the MPS C library is * % resident in the system * % contact Paul Stay or Russ Fish * % University of Utah * %********************************** Procedure MPS!.DrawS (XDEST, YDEST); << X := XDEST; Y := YDEST; PSdraw2d(LIST(X,Y) ,DDDD,ABS,0,1); %draw a line from cursor 0; %do x and y coordinates >>; Procedure MPS!.MoveS (XDEST, YDEST); << X := XDEST; Y := YDEST; PSdraw2d( LIST(X,Y) , MDDD,ABS,0,1); %move to point x,y 0; >>; Procedure MPS!.Delay(); % no Delay function for mps NIL; Procedure MPS!.EraseS(); % setdisplay list to nil DISPLAY!.LIST := NIL$ Procedure MPS!.VWPORT( X1, X2, Y1, Y2); %set up viewport << PSsetscale(300); %set up scale factor X1CLIP := MAX2(-500, X1); X2CLIP := MIN2(500, X2); Y1CLIP := MAX2(-500, Y1); Y2CLIP := MIN2(500, Y2); >>; Procedure MPS!.GRAPHON(); % Check this If not !*emode then echooff(); Procedure MPS!.GRAPHOFF(); If not !*emode then echoon(); Procedure MPS!.INIT$ << PRINT "MPS IS DISPLAY DEVICE"; DEV!. := 'MPS; FNCOPY ( 'EraseS, 'MPS!.ERASE)$ % Add NORM functions FNCOPY ( 'MoveS, 'MPS!.MoveS)$ FNCOPY ( 'DrawS, 'MPS!.DrawS)$ FNCOPY ( 'VWPORT, 'MPS!.VWPORT)$ FNCOPY ( 'Delay, 'MPS!.Delay)$ FNCOPY( 'GraphOn, 'MPS!.GraphOn)$ FNCOPY( 'GraphOff, 'MPS!.GraphOff)$ PSINIT(1,0); % initialize device ERASE(); MPS!.VWPORT(-500,500,-500,500); % setup viewport Psscale(1,1,1,500); % setup scale hardware GLOBAL!.TRANSFORM := WINdoW(-300,60); >>; %*************************************** % Apollo terminal driver and functions * %*************************************** Procedure ST!.OutChar x; % use Pbout instead PBOUT x; Procedure ST!.EraseS(); % erase screen << ST!.OutChar 27; ST!.OutChar 12>>; Procedure ST!.GraphOn(); << If Not !*Emode Then EchoOff(); If !*emode then ST!.OutChar 29>>$ % Should be same for TEK Procedure ST!.GraphOff(); << If Not !*Emode Then EchoOn(); If !*emode then ST!.OutChar 31>>$ % Maybe mixed VT-52/tek problem Procedure ST!.MoveS(XDEST,YDEST)$ << ST!.OutChar 29 $ %. GS: sets terminal to Graphic mode. ST!.4BYTES (XDEST,YDEST)$ %. US: sets terminal to Alpha mode. If not !*emode then ST!.OutChar 31>>$ Procedure ST!.DrawS (XDEST,YDEST)$ %. Same as MoveS but << If not !*emode then << ST!.OutChar 29$ ST!.4bytes(car2 here, car3 here)>>$ ST!.4BYTES (XDEST, YDEST)$ %. draw the line. If not !*emode then ST!.OutChar 31 >>$ Procedure PRLISP(); <<PRIN2T "Set Up for Apollo under EMODE"; !*Emode:=T; ST!.INIT()>>; Procedure ST!.4BYTES (XDEST, YDEST)$ %. Convert graphic plot << ST!.OutChar HIGHERY NormY YDEST$ %. information to the ST!.OutChar LOWERY NormY YDEST$ %. terminal in a 4 byte ST!.OutChar HIGHERX NormX XDEST$ %. sequences containing the ST!.OutChar LOWERX NormX XDEST >>$ %. High and Low order Y %. informationand High and %. Low order X information. Procedure ST!.Delay(); NIL; Procedure ST!.NormX DESTX$ %. absolute location along DESTX + 400$ %. X axis. Procedure ST!.NormY DESTY$ %. absolute location along DESTY + 300$ %. Y axis. Procedure ST!.VWPORT(X1,X2,Y1,Y2)$ %. set the viewport for << X1CLIP := MAX2 (-400,X1)$ %. Tektronix 4006-1. X2CLIP := MIN2 (400,X2)$ Y1CLIP := MAX2 (-300,Y1)$ Y2CLIP := MIN2 (300,Y2) >>$ Procedure ST!.INIT$ %. JW's fake TEKTRONIX Begin %. Procedures equivalent. PRINT "Apollo/ST is device"$ DEV!. := 'Apollo; FNCOPY( 'EraseS, 'ST!.EraseS)$ % should be called as for FNCOPY( 'NormX, 'ST!.NormX)$ % initialization when using FNCOPY( 'NormY, 'ST!.NormY)$ % APOtronix 4006-1. FNCOPY( 'MoveS, 'ST!.MoveS)$ FNCOPY( 'DrawS, 'ST!.DrawS)$ FNCOPY( 'VWPORT, 'ST!.VWPORT)$ FNCOPY( 'Delay, 'ST!.Delay)$ FNCOPY( 'GraphOn, 'ST!.GraphOn); FNCOPY( 'GraphOff, 'ST!.GraphOff); Erase()$ VWPORT(-400,400,-300,300)$ GLOBAL!.TRANSFORM := WINdoW(-300,60) end$ % --------- OTHER UTILITIES ------------ Procedure SAVEPICT (FIL,PICT,NAM)$ %. save a picture with no Begin scalar OLD; %. vectors. FIL := OPEN (FIL,'OUTPUT)$ % fil : list('dir,file.ext) OLD := WRS FIL$ % nam : id PRIN2 NAM$ PRIN2 '! !:!=! !'$ PRIN2 PICT$ % pict: name of pict to PRIN2 '!;$ WRS 'NIL$ CLOSE FIL$ % be saved. Return PICT$ % fil: file name to save % "pict". end$ % nam: name to be used % after TAILore. % type "in fil" to TAILore % old picture. |
Added psl-1983/util/prlisp.demo version [c339bb7944].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This is a small Picture RLISP demo file % For ANY driver Outline := { 10, 10} _ {-10, 10} _ % Outline is 20 by 20 {-10,-10} _ { 10,-10} _ {10, 10}$ % Square Arrow := {0,-1} _ {0,2} & {-1,1} _ {0,2} _ {1,1}$ Cubeface := (Outline & Arrow) | ZMOVE 10$ Cube := Cubeface & Cubeface | XROT (180) % 180 degrees & Cubeface | YROT ( 90) & Cubeface | YROT (-90) & Cubeface | XROT ( 90) & Cubeface | XROT (-90)$ BigCube := Cube | Scale 5$ ESHOW BigCube$ ESHOW {10,10} | circle(70)$ Cpts := {0,0} _ {70,-60} _ {189,-69} _ {206,33} _ {145,130} _ {48,130} _ {0,84} $ ESHOW ( {10,10} | CIRCLE(50))$ ESHOW (Cpts & Cpts | BEZIER())$ ESHOW (Cpts & Cpts | BSPLINE())$ ESHOW (BigCube | XROT 20 | YROT 30 | ZROT 10)$ ESHOW (Cube | scale 2 | XMOVE (-240) | REPEATED(5, XMOVE 80))$ END; |
Added psl-1983/util/program-command-interpreter.sl version [ae09e097f5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Program-Command-Interpreter.SL - Perform Program Command % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 August 1982 % Revised: 8 December 1982 % % 8-Dec-82 Alan Snyder % Changed use of DSKIN (now an EXPR). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This file redefines the start-up routine for PSL (Lisp Reader) to first read % and interpret the program command string. If the command string contains a % recognized command name, then the corresponding function is immediately % executed and the program QUITs. Otherwise, the normal top-level function % definition is restored and invoked as normal. Commands are defined using the % property PROGRAM-COMMAND (see below). This file defines only one command, % COMPILE, which is used to compile Lisp files (not RLisp files). (BothTimes (load common)) (load parse-command-string get-command-string compiler) (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (cond ((funboundp 'original-main) (copyd 'original-main 'main))) (de main () (let ((CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (CurrentScanTable* LispScanTable*) (c-list (parse-command-string (get-command-string))) (*usermode nil) (*redefmsg nil)) (perform-program-command c-list) (copyd 'main 'original-main) ) (original-main) ) (de perform-program-command (c-list) (if (not (Null c-list)) (let ((command (car c-list))) (if (StringP command) (let* ((command-id (intern (string-upcase command))) (func (get command-id 'PROGRAM-COMMAND))) (if func (apply func (list c-list)))))))) (put 'COMPILE 'PROGRAM-COMMAND 'compile-program-command) (fluid '(*quiet_faslout *WritingFASLFile)) (de compile-program-command (c-list) (setq c-list (cdr c-list)) (for (in file-name-root c-list) (do (let* ((form (list 'COMPILE-FILE file-name-root)) (*break NIL) (result (ErrorSet form T NIL)) ) (if (FixP result) (progn (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" file-name-root) )) ))) (quit)) (de compile-file (file-name-root) (let ((source-fn (string-concat file-name-root ".SL")) (binary-fn (string-concat file-name-root ".B")) (*quiet_faslout T) ) (if (not (FileP source-fn)) (printf "Unable to open source file: %w%n" source-fn) % else (printf "%n----- Compiling %w%n" source-fn binary-fn) (faslout file-name-root) (dskin source-fn) (faslend) (printf "%nDone compiling %w%n%n" source-fn) ))) |
Added psl-1983/util/psl-cref.red version [c4e8dd2cc3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % =============================================================== % CREF for PSL, requires GSORT and PSL-CREFIO.RED % Adapted from older RCREF % MLG, 6:28am Tuesday, 15 December 1981 % =============================================================== % MLG 20 Dec 1982: % Add FOR WHILE REPEAT FOREACH to EXPAND!* list % Ensures that not treated as undefined functions in processing % May need to add some other (CATCH?) % MLG 20 Dec 1982 % Add DS and DN as new ANLFN types, similar to DE, DF, DM etc %FLAG('(ANLFN CRFLAPO),'FTYPE); % To force PUTC %FLAG('(ANLFN CRFLAPO),'COMPILE); CompileTime << macro procedure DefANLFN U; list('put, MkQuote cadr U, ''ANLFN, list('function, 'lambda . cddr U)); flag('(ANLFN), 'FType); put('ANLFN, 'FunctionDefiningFunction, 'DefANLFN); >>; GLOBAL '(UNDEFG!* GSEEN!* BTIME!* EXPAND!* HAVEARGS!* NOTUSE!* NOLIST!* DCLGLB!* ENTPTS!* UNDEFNS!* SEEN!* TSEEN!* OP!*!* CLOC!* PFILES!* CURLIN!* PRETITL!* !*CREFTIME !*SAVEPROPS MAXARG!* !*CREFSUMMARY !*RLISP !*CREF !*DEFN !*MODE !*GLOBALS !*ALGEBRAICS ); FLUID '(GLOBS!* CALLS!* LOCLS!* TOPLV!* CURFUN!* DFPRINT!* ); !*ALGEBRAICS:='T; % Default is normal parse of algebraic; !*GLOBALS:='T; % Do analyse globals; !*RLISP:=NIL; % REDUCE as default; !*SAVEPROPS:=NIL; MAXARG!*:=15; % Maximum args in Standard Lisp; COMMENT EXPAND flag on these forces expansion of MACROS; EXPAND!*:='( WHILE FOREACH FOR REPEAT ); SYMBOLIC PROCEDURE STANDARDFUNCTIONS L; NOLIST!* := NCONC(DEFLIST(L,'ARGCOUNT),NOLIST!*); STANDARDFUNCTIONS '( (ABS 1) (ADD1 1) (APPEND 2) (APPLY 2) (ASSOC 2) (ATOM 1) (CAR 1) (CDR 1) (CAAR 1) (CADR 1) (CDAR 1) (CDDR 1) (CAAAR 1) (CAADR 1) (CADAR 1) (CADDR 1) (CDAAR 1) (CDADR 1) (CDDAR 1) (CDDDR 1) (CAAAAR 1) (CAAADR 1) (CAADAR 1) (CAADDR 1) (CADAAR 1) (CADADR 1) (CADDAR 1) (CADDDR 1) (CDAAAR 1) (CDAADR 1) (CDADAR 1) (CDADDR 1) (CDDAAR 1) (CDDADR 1) (CDDDAR 1) (CDDDDR 1) (CLOSE 1) (CODEP 1) (COMPRESS 1) (CONS 2) (CONSTANTP 1) (DE 3) (DEFLIST 2) (DELETE 2) (DF 3) (DIFFERENCE 2) (DIGIT 1) (DIVIDE 2) (DM 3) (DS 3) (DN 3) (EJECT 0) (EQ 2) (EQN 2) (EQUAL 2) (ERROR 2) (ERRORSET 3) (EVAL 1) (EVLIS 1) (EXPAND 2) (EXPLODE 1) (EXPT 2) (FIX 1) (FIXP 1) (FLAG 2) (FLAGP 2) (FLOAT 1) (FLOATP 1) (FLUID 1) (FLUIDP 1) (FUNCTION 1) (GENSYM 0) (GET 2) (GETD 1) (GETV 2) (GLOBAL 1) (GLOBALP 1) (GO 1) (GREATERP 2) (IDP 1) (INTERN 1) (LENGTH 1) (LESSP 2) (LINELENGTH 1) (LITER 1) (LPOSN 0) (MAP 2) (MAPC 2) (MAPCAN 2) (MAPCAR 2) (MAPCON 2) (MAPLIST 2) (MAX2 2) (MEMBER 2) (MEMQ 2) (MINUS 1) (MINUSP 1) (MIN2 2) (MKVECT 1) (NCONC 2) (NOT 1) (NULL 1) (NUMBERP 1) (ONEP 1) (OPEN 2) (PAGELENGTH 1) (PAIR 2) (PAIRP 1) (PLUS2 2) (POSN 0) (PRINC 1) (PRINT 1) (PRIN1 1) (PRIN2 1) (PROG2 2) (PUT 3) (PUTD 3) (PUTV 3) (QUOTE 1) (QUOTIENT 2) (RDS 1) (READ 0) (READCH 0) (REMAINDER 2) (REMD 1) (REMFLAG 2) (REMOB 1) (REMPROP 2) (RETURN 1) (REVERSE 1) (RPLACA 2) (RPLACD 2) (SASSOC 3) (SET 2) (SETQ 2) (STRINGP 1) (SUBLIS 2) (SUBST 3) (SUB1 1) (TERPRI 0) (TIMES2 2) (UNFLUID 1) (UPBV 1) (VECTORP 1) (WRS 1) (ZEROP 1) ); NOLIST!*:=APPEND('(AND COND LIST MAX MIN OR PLUS PROG PROG2 LAMBDA PROGN TIMES),NOLIST!*); FLAG ('(PLUS TIMES AND OR PROGN MAX MIN COND PROG LAMBDA CASE LIST), 'NARYARGS); DCLGLB!*:='(!*COMP EMSG!* !*RAISE); FLAG('(RDS DEFLIST FLAG FLUID GLOBAL REMPROP REMFLAG UNFLUID SETQ CREFOFF),'EVAL); SYMBOLIC PROCEDURE CREFON; BEGIN SCALAR A,OCRFIL,CRFIL; BTIME!*:=TIME(); DFPRINT!* := 'REFPRINT; !*DEFN := T; IF NOT !*ALGEBRAICS THEN PUT('ALGEBRAIC,'NEWNAM,'SYMBOLIC); FLAG(NOLIST!*,'NOLIST); FLAG(EXPAND!*,'EXPAND); FLAG(DCLGLB!*,'DCLGLB); % Global lists; ENTPTS!*:=NIL; % Entry points to package; UNDEFNS!*:=NIL; % Functions undefined in package; SEEN!*:=NIL; % List of all encountered functions; TSEEN!*:=NIL; % List of all encountered types not flagged FUNCTION; GSEEN!*:=NIL; % All encountered globals; PFILES!*:=NIL; % Processed files; UNDEFG!*:=NIL; % Undeclared globals encountered; CURLIN!*:=NIL; % Position in file(s) of current command ; PRETITL!*:=NIL; % T if error or questionables found ; % Usages in specific function under analysis; GLOBS!*:=NIL; % Globals refered to in this ; CALLS!*:=NIL; % Functions called by this; LOCLS!*:=NIL; % Defined local variables in this ; TOPLV!*:=T; % NIL if inside function body ; CURFUN!*:=NIL; % Current function beeing analysed; OP!*!*:=NIL; % Current op. in LAP code; SETPAGE(" Errors or questionables",NIL); END; SYMBOLIC PROCEDURE UNDEFDCHK FN; IF NOT FLAGP(FN,'DEFD) THEN UNDEFNS!* := FN . UNDEFNS!*; SYMBOLIC PROCEDURE PRINCNG U; PRINCN GETES U; SYMBOLIC PROCEDURE CREFOFF; % main call, sets up, alphabetizes and prints; BEGIN SCALAR TIM,X; DFPRINT!* := NIL; !*DEFN:=NIL; IF NOT !*ALGEBRAICS THEN REMPROP('ALGEBRAIC,'NEWNAM); %back to normal; TIM:=TIME()-BTIME!*; FOR EACH FN IN SEEN!* DO <<IF NULL GET(FN,'CALLEDBY) THEN ENTPTS!*:=FN . ENTPTS!*; UNDEFDCHK FN>>; TSEEN!*:=FOR EACH Z IN IDSORT TSEEN!* COLLECT <<REMPROP(Z,'TSEEN); FOR EACH FN IN (X:=GET(Z,'FUNS)) DO <<UNDEFDCHK FN; REMPROP(FN,'RCCNAM)>>; Z.X>>; FOR EACH Z IN GSEEN!* DO IF GET(Z,'USEDUNBY) THEN UNDEFG!*:=Z . UNDEFG!*; SETPAGE(" Summary",NIL); NEWPAGE(); PFILES!*:=PUNUSED("Crossreference listing for files:", FOR EACH Z IN PFILES!* COLLECT CDR Z); ENTPTS!*:=PUNUSED("Entry Points:",ENTPTS!*); UNDEFNS!*:=PUNUSED("Undefined Functions:",UNDEFNS!*); UNDEFG!*:=PUNUSED("Undeclared Global Variables:",UNDEFG!*); GSEEN!*:=PUNUSED("Global variables:",GSEEN!*); SEEN!*:=PUNUSED("Functions:",SEEN!*); FOR EACH Z IN TSEEN!* DO <<RPLACD(Z,PUNUSED(LIST(CAR Z," procedures:"),CDR Z)); X:='!( . NCONC(EXPLODE CAR Z,LIST '!)); FOR EACH FN IN CDR Z DO <<FN:=GETES FN; RPLACD(FN,APPEND(X,CDR FN)); RPLACA(FN,LENGTH CDR FN)>> >>; IF !*CREFSUMMARY THEN GOTO XY; IF !*GLOBALS AND GSEEN!* THEN <<SETPAGE(" Global Variable Usage",1); NEWPAGE(); FOR EACH Z IN GSEEN!* DO CREF6 Z>>; IF SEEN!* THEN CREF52(" Function Usage",SEEN!*); FOR EACH Z IN TSEEN!* DO CREF52(LIST(" ",CAR Z," procedures"),CDR Z); SETPAGE(" Toplevel calls:",NIL); X:=T; FOR EACH Z IN PFILES!* DO IF GET(Z,'CALLS) OR GET(Z,'GLOBS) THEN <<IF X THEN <<NEWPAGE(); X:=NIL>>; NEWLINE 0; NEWLINE 0; PRINCNG Z; SPACES2 15; UNDERLINE2 (LINELENGTH(NIL)-10); CREF51(Z,'CALLS,"Calls:"); IF !*GLOBALS THEN CREF51(Z,'GLOBS,"Globals:")>>; XY: IF !*SAVEPROPS THEN GOTO XX; REMPROPSS(SEEN!*,'(GALL CALLS GLOBS CALLEDBY ALSOIS SAMEAS)); REMFLAGSS(SEEN!*,'(SEEN CINTHIS DEFD)); REMPROPSS(GSEEN!*,'(USEDBY USEDUNBY BOUNDBY SETBY)); REMFLAGSS(GSEEN!*,'(DCLGLB GSEEN GLB2RF GLB2BD GLB2ST)); FOR EACH Z IN TSEEN!* DO REMPROP(CAR Z,'FUNS); FOR EACH Z IN HAVEARGS!* DO REMPROP(Z,'ARGCOUNT); HAVEARGS!* := NIL; XX: NEWLINE 2; IF NOT !*CREFTIME THEN RETURN; BTIME!*:=TIME()-BTIME!*; SETPAGE(" Timing Information",NIL); NEWPAGE(); NEWLINE 0; PRTATM " Total Time="; PRTNUM BTIME!*; PRTATM " (ms)"; NEWLINE 0; PRTATM " Analysis Time="; PRTNUM TIM; NEWLINE 0; PRTATM " Sorting Time="; PRTNUM (BTIME!*-TIM); NEWLINE 0; NEWLINE 0 END; SYMBOLIC PROCEDURE PUNUSED(X,Y); IF Y THEN <<NEWLINE 2; PRTLST X; NEWLINE 0; LPRINT(Y := IDSORT Y,8); NEWLINE 0; Y>>; SYMBOLIC PROCEDURE CREF52(X,Y); <<SETPAGE(X,1); NEWPAGE(); FOR EACH Z IN Y DO CREF5 Z>>; SYMBOLIC PROCEDURE CREF5 FN; % Print single entry; BEGIN SCALAR X,Y; NEWLINE 0; NEWLINE 0; PRIN1 FN; SPACES2 15; Y:=GET(FN,'GALL); IF Y THEN <<PRIN1 CDR Y; X:=CAR Y>> ELSE PRIN2 "Undefined"; SPACES2 25; IF FLAGP(FN,'NARYARGS) THEN PRIN2 " Nary Args " ELSE IF (Y:=GET(FN,'ARGCOUNT)) THEN <<PRIN2 " "; PRIN2 Y; PRIN2 " Args ">>; UNDERLINE2 (LINELENGTH(NIL)-10); IF X THEN <<NEWLINE 15; PRTATM '!Line!:; SPACES2 27; PRTNUM CDDR X; PRTATM '!/; PRTNUM CADR X; PRTATM " in "; PRTATM CAR X>>; CREF51(FN,'CALLEDBY,"Called by:"); CREF51(FN,'CALLS,"Calls:"); CREF51(FN,'ALSOIS,"Is also:"); CREF51(FN,'SAMEAS,"Same as:"); IF !*GLOBALS THEN CREF51(FN,'GLOBS,"Globals:") END; SYMBOLIC PROCEDURE CREF51(X,Y,Z); IF (X:=GET(X,Y)) THEN <<NEWLINE 15; PRTATM Z; LPRINT(IDSORT X,27)>>; SYMBOLIC PROCEDURE CREF6 GLB; % print single global usage entry; <<NEWLINE 0; PRIN1 GLB; SPACES2 15; NOTUSE!*:=T; CREF61(GLB,'USEDBY,"Global in:"); CREF61(GLB,'USEDUNBY,"Undeclared:"); CREF61(GLB,'BOUNDBY,"Bound in:"); CREF61(GLB,'SETBY,"Set by:"); IF NOTUSE!* THEN PRTATM "*** Not Used ***">>; SYMBOLIC PROCEDURE CREF61(X,Y,Z); IF (X:=GET(X,Y)) THEN <<IF NOT NOTUSE!* THEN NEWLINE 15 ELSE NOTUSE!*:=NIL; PRTATM Z; LPRINT(IDSORT X,27)>>; % Analyse bodies of LISP functions for % functions called, and globals used, undefined %; SMACRO PROCEDURE ISGLOB U; FLAGP(U,'DCLGLB); SMACRO PROCEDURE CHKSEEN S; % Has this name been encountered already?; IF NOT FLAGP(S,'SEEN) THEN <<FLAG1(S,'SEEN); SEEN!*:=S . SEEN!*>>; SMACRO PROCEDURE GLOBREF U; IF NOT FLAGP(U,'GLB2RF) THEN <<FLAG1(U,'GLB2RF); GLOBS!*:=U . GLOBS!*>>; SMACRO PROCEDURE ANATOM U; % Global seen before local..ie detect extended from this; IF !*GLOBALS AND U AND NOT(U EQ 'T) AND IDP U AND NOT ASSOC(U,LOCLS!*) THEN GLOBREF U; SMACRO PROCEDURE CHKGSEEN G; IF NOT FLAGP(G,'GSEEN) THEN <<GSEEN!*:=G . GSEEN!*; FLAG1(G,'GSEEN)>>; SYMBOLIC PROCEDURE DO!-GLOBAL L; % Catch global defns; % Distinguish FLUID from GLOBAL later; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; FLAG(L,'DCLGLB)>>; PUT('GLOBAL,'ANLFN,'DO!-GLOBAL); PUT('FLUID,'ANLFN,'DO!-GLOBAL); SYMBOLIC ANLFN PROCEDURE UNFLUID L; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; REMFLAG(L,'DCLGLB)>>; SYMBOLIC PROCEDURE ADD2LOCS LL; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH GG IN LL DO <<OLDLOC:=ASSOC(GG,LOCLS!*); IF NOT NULL OLDLOC THEN << QERLINE 0; PRIN2 "*** Variable "; PRIN1 GG; PRIN2 " nested declaration in "; PRINCNG CURFUN!*; NEWLINE 0; RPLACD(OLDLOC,NIL.OLDLOC)>> ELSE LOCLS!*:=(GG . LIST NIL) . LOCLS!*; IF ISGLOB(GG) OR FLAGP(GG,'GLB2RF) THEN GLOBIND GG; IF FLAGP(GG,'SEEN) THEN <<QERLINE 0; PRIN2 "*** Function "; PRINCNG GG; PRIN2 " used as variable in "; PRINCNG CURFUN!*; NEWLINE 0>> >> END; SYMBOLIC PROCEDURE GLOBIND GG; <<FLAG1(GG,'GLB2BD); GLOBREF GG>>; SYMBOLIC PROCEDURE REMLOCS LLN; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH LL IN LLN DO <<OLDLOC:=ASSOC(LL,LOCLS!*); IF NULL OLDLOC THEN IF GETD 'BEGIN THEN REDERR LIST(" Lvar confused",LL) ELSE ERROR(0,LIST(" Lvar confused",LL)); IF CDDR OLDLOC THEN RPLACD(OLDLOC,CDDR OLDLOC) ELSE LOCLS!*:=EFFACE1(OLDLOC,LOCLS!*)>> END; SYMBOLIC PROCEDURE ADD2CALLS FN; % Update local CALLS!*; IF NOT(FLAGP(FN,'NOLIST) OR FLAGP(FN,'CINTHIS)) THEN <<CALLS!*:=FN . CALLS!*; FLAG1(FN,'CINTHIS)>>; SYMBOLIC PROCEDURE ANFORM U; IF ATOM U THEN ANATOM U ELSE ANFORM1 U; SYMBOLIC PROCEDURE ANFORML L; BEGIN WHILE NOT ATOM L DO <<ANFORM CAR L; L:=CDR L>>; IF L THEN ANATOM L END; SYMBOLIC PROCEDURE ANFORM1 U; BEGIN SCALAR FN,X; FN:=CAR U; U:=CDR U; IF NOT ATOM FN THEN RETURN <<ANFORM1 FN; ANFORML U>>; IF NOT IDP FN THEN RETURN NIL ELSE IF ISGLOB FN THEN <<GLOBREF FN; RETURN ANFORML U>> ELSE IF ASSOC(FN,LOCLS!*) THEN RETURN ANFORML U; ADD2CALLS FN; CHECKARGCOUNT(FN,LENGTH U); IF FLAGP(FN,'NOANL) THEN NIL ELSE IF X:=GET(FN,'ANLFN) THEN APPLY(X,LIST U) ELSE ANFORML U END; SYMBOLIC ANLFN PROCEDURE LAMBDA U; <<ADD2LOCS CAR U; ANFORML CDR U; REMLOCS CAR U>>; SYMBOLIC PROCEDURE ANLSETQ U; <<ANFORML U; IF !*GLOBALS AND FLAGP(U:=CAR U,'GLB2RF) THEN FLAG1(U,'GLB2ST)>>; PUT('SETQ,'ANLFN,'ANLSETQ); SYMBOLIC ANLFN PROCEDURE COND U; FOR EACH X IN U DO ANFORML X; SYMBOLIC ANLFN PROCEDURE PROG U; <<ADD2LOCS CAR U; FOR EACH X IN CDR U DO IF NOT ATOM X THEN ANFORM1 X; REMLOCS CAR U>>; SYMBOLIC ANLFN PROCEDURE FUNCTION U; IF PAIRP(U:=CAR U) THEN ANFORM1 U ELSE IF ISGLOB U THEN GLOBREF U ELSE IF NULL ASSOC(U,LOCLS!*) THEN ADD2CALLS U; FLAG('(QUOTE GO),'NOANL); SYMBOLIC ANLFN PROCEDURE ERRORSET U; BEGIN SCALAR FN,X; ANFORML CDR U; IF EQCAR(U:=CAR U,'QUOTE) THEN RETURN ERSANFORM CADR U ELSE IF NOT((EQCAR(U,'CONS) OR (X:=EQCAR(U,'LIST))) AND QUOTP(FN:=CADR U)) THEN RETURN ANFORM U; ANFORML CDDR U; IF PAIRP(FN:=CADR FN) THEN ANFORM1 FN ELSE IF FLAGP(FN,'GLB2RF) THEN NIL ELSE IF ISGLOB FN THEN GLOBREF FN ELSE <<ADD2CALLS FN; IF X THEN CHECKARGCOUNT(FN,LENGTH CDDR U)>> END; SYMBOLIC PROCEDURE ERSANFORM U; BEGIN SCALAR LOCLS!*; RETURN ANFORM U END; SYMBOLIC PROCEDURE ANLMAP U; <<ANFORML CDR U; IF QUOTP(U:=CADDR U) AND IDP(U:=CADR U) AND NOT ISGLOBL U AND NOT ASSOC(U,LOCLS!*) THEN CHECKARGCOUNT(U,1)>>; FOR EACH X IN '(MAP MAPC MAPLIST MAPCAR MAPCON MAPCAN) DO PUT(X,'ANLFN,'ANLMAP); SYMBOLIC ANLFN PROCEDURE APPLY U; BEGIN SCALAR FN; ANFORML CDR U; IF QUOTP(FN:=CADR U) AND IDP(FN:=CADR FN) AND EQCAR(U:=CADDR U,'LIST) THEN CHECKARGCOUNT(FN,LENGTH CDR U) END; SYMBOLIC PROCEDURE QUOTP U; EQCAR(U,'QUOTE) OR EQCAR(U,'FUNCTION); PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); SYMBOLIC PROCEDURE OUTREF(S,VARLIS,BODY,TYPE); BEGIN SCALAR CURFUN!*,CALLS!*,GLOBS!*,LOCLS!*,TOPLV!*,A; A:=IF VARLIS MEMQ '(ANP!!ATOM ANP!!IDB ANP!!EQ ANP!!UNKNOWN) THEN NIL ELSE LENGTH VARLIS; S := OUTRDEFUN(S,TYPE,IF A THEN A ELSE GET(BODY,'ARGCOUNT)); IF A THEN <<ADD2LOCS VARLIS; ANFORM(BODY); REMLOCS VARLIS>> ELSE IF NULL BODY OR NOT IDP BODY THEN NIL ELSE IF VARLIS EQ 'ANP!!EQ THEN <<PUT(S,'SAMEAS,LIST BODY); TRAPUT(BODY,'ALSOIS,S)>> ELSE ADD2CALLS BODY; OUTREFEND S END; SYMBOLIC PROCEDURE TRAPUT(U,V,W); BEGIN SCALAR A; IF A:=GET(U,V) THEN (IF NOT(TOPLV!* OR W MEMQ A) THEN RPLACD(A,W . CDR A)) ELSE PUT(U,V,LIST W) END; SMACRO PROCEDURE TOPUT(U,V,W); IF W THEN PUT(U,V,IF TOPLV!* THEN UNION(W,GET(U,V)) ELSE W); SYMBOLIC PROCEDURE OUTREFEND S; <<TOPUT(S,'CALLS,CALLS!*); FOR EACH X IN CALLS!* DO <<REMFLAG1(X,'CINTHIS); IF NOT X EQ S THEN <<CHKSEEN X; TRAPUT(X,'CALLEDBY,S)>> >>; TOPUT(S,'GLOBS,GLOBS!*); FOR EACH X IN GLOBS!* DO <<TRAPUT(X,IF ISGLOB X THEN 'USEDBY ELSE <<CHKGSEEN X; 'USEDUNBY>>,S); REMFLAG1(X,'GLB2RF); IF FLAGP(X,'GLB2BD) THEN <<REMFLAG1(X,'GLB2BD); TRAPUT(X,'BOUNDBY,S)>>; IF FLAGP(X,'GLB2ST) THEN <<REMFLAG1(X,'GLB2ST); TRAPUT(X,'SETBY,S)>> >> >>; SYMBOLIC PROCEDURE RECREF(S,TYPE); <<QERLINE 2; PRTATM "*** Redefinition to "; PRIN1 TYPE; PRTATM " procedure, of:"; CREF5 S; REMPROPSS(S,'(CALLS GLOBS SAMEAS)); NEWLINE 2>>; SYMBOLIC PROCEDURE OUTRDEFUN(S,TYPE,V); BEGIN S:=QTYPNM(S,TYPE); IF FLAGP(S,'DEFD) THEN RECREF(S,TYPE) ELSE FLAG1(S,'DEFD); IF FLAGP(TYPE,'FUNCTION) AND (ISGLOB S OR ASSOC(S,LOCLS!*)) THEN <<QERLINE 0; PRIN2 "**** Variable "; PRINCNG S; PRIN2 " defined as function"; NEWLINE 0>>; IF V AND NOT FLAGP(TYPE,'NARYARG) THEN DEFINEARGS(S,V); PUT(S,'GALL,CURLIN!* . TYPE); GLOBS!*:=NIL; CALLS!*:=NIL; RETURN CURFUN!*:=S END; FLAG('(MACRO FEXPR),'NARYARG); SYMBOLIC PROCEDURE QTYPNM(S,TYPE); IF FLAGP(TYPE,'FUNCTION) THEN <<CHKSEEN S; S>> ELSE BEGIN SCALAR X,Y,Z; IF (Y:=GET(TYPE,'TSEEN)) AND (X:=ATSOC(S,CDR Y)) THEN RETURN CDR X; IF NULL Y THEN <<Y:=LIST ('!( . NCONC(EXPLODE TYPE,LIST '!))); PUT(TYPE,'TSEEN,Y); TSEEN!* := TYPE . TSEEN!*>>; X := COMPRESS (Z := EXPLODE S); CDR Y := (S . X) . CDR Y; Y := APPEND(CAR Y,Z); PUT(X,'RCCNAM,LENGTH Y . Y); TRAPUT(TYPE,'FUNS,X); RETURN X END; SYMBOLIC PROCEDURE DEFINEARGS(NAME,N); BEGIN SCALAR CALLEDWITH,X; CALLEDWITH:=GET(NAME,'ARGCOUNT); IF NULL CALLEDWITH THEN RETURN HASARG(NAME,N); IF N=CALLEDWITH THEN RETURN NIL; IF X := GET(NAME,'CALLEDBY) THEN INSTDOF(NAME,N,CALLEDWITH,X); HASARG(NAME,N) END; SYMBOLIC PROCEDURE INSTDOF(NAME,N,M,FNLST); <<QERLINE 0; PRIN2 "***** "; PRIN1 NAME; PRIN2 " called with "; PRIN2 M; PRIN2 " instead of "; PRIN2 N; PRIN2 " arguments in:"; LPRINT(IDSORT FNLST,POSN()+1); NEWLINE 0>>; SYMBOLIC PROCEDURE HASARG(NAME,N); <<HAVEARGS!*:=NAME . HAVEARGS!*; IF N>MAXARG!* THEN <<QERLINE 0; PRIN2 "**** "; PRIN1 NAME; PRIN2 " has "; PRIN2 N; PRIN2 " arguments"; NEWLINE 0 >>; PUT(NAME,'ARGCOUNT,N)>>; SYMBOLIC PROCEDURE CHECKARGCOUNT(NAME,N); BEGIN SCALAR CORRECTN; IF FLAGP(NAME,'NARYARGS) THEN RETURN NIL; CORRECTN:=GET(NAME,'ARGCOUNT); IF NULL CORRECTN THEN RETURN HASARG(NAME,N); IF NOT CORRECTN=N THEN INSTDOF(NAME,CORRECTN,N,LIST CURFUN!*) END; SYMBOLIC PROCEDURE REFPRINT U; BEGIN SCALAR X,Y; X:=IF CLOC!* THEN CAR CLOC!* ELSE "*TTYINPUT*"; IF (CURFUN!*:=ASSOC(X,PFILES!*)) THEN <<X:=CAR CURFUN!*; CURFUN!*:=CDR CURFUN!*>> ELSE <<PFILES!*:=(X.(CURFUN!*:=GENSYM())).PFILES!*; Y:=REVERSIP CDR REVERSIP CDR EXPLODE X; PUT(CURFUN!*,'RCCNAM,LENGTH Y . Y)>>; CURLIN!*:=IF CLOC!* THEN X.CDR CLOC!* ELSE NIL; CALLS!*:=GLOBS!*:=LOCLS!*:=NIL; ANFORM U; OUTREFEND CURFUN!* END; FLAG('(SMACRO NMACRO),'CREF); SYMBOLIC ANLFN PROCEDURE PUT U; IF TOPLV!* AND QCPUTX CADR U THEN ANPUTX U ELSE ANFORML U; PUT('PUTC,'ANLFN,GET('PUT,'ANLFN)); SYMBOLIC PROCEDURE QCPUTX U; EQCAR(U,'QUOTE) AND (FLAGP(CADR U,'CREF) OR FLAGP(CADR U,'COMPILE)); SYMBOLIC PROCEDURE ANPUTX U; BEGIN SCALAR NAM,TYP,BODY; NAM:=QCRF CAR U; TYP:=QCRF CADR U; U:=CADDR U; IF ATOM U THEN <<BODY:=QCRF U; U:='ANP!!ATOM>> ELSE IF CAR U MEMQ '(QUOTE FUNCTION) THEN IF EQCAR(U:=CADR U,'LAMBDA) THEN <<BODY:=CADDR U; U:=CADR U>> ELSE IF IDP U THEN <<BODY:=U; U:='ANP!!IDB>> ELSE RETURN NIL ELSE IF CAR U EQ 'CDR AND EQCAR(CADR U,'GETD) THEN <<BODY:=QCRF CADADR U; U:='ANP!!EQ>> ELSE IF CAR U EQ 'GET AND QCPUTX CADDR U THEN <<BODY:=QTYPNM(QCRF CADR U,CADR CADDR U); U:='ANP!!EQ>> ELSE IF CAR U EQ 'MKCODE THEN <<ANFORM CADR U; U:=QCRF CADDR U; BODY:=NIL>> ELSE <<BODY:=QCRF U; U:='ANP!!UNKNOWN>>; OUTREF(NAM,U,BODY,TYP) END; SYMBOLIC ANLFN PROCEDURE PUTD U; IF TOPLV!* THEN ANPUTX U ELSE ANFORML U; SYMBOLIC ANLFN PROCEDURE DE U; OUTDEFR(U,'EXPR); SYMBOLIC ANLFN PROCEDURE DN U; OUTDEFR(U,'NEXPR); SYMBOLIC ANLFN PROCEDURE DF U; OUTDEFR(U,'FEXPR); SYMBOLIC ANLFN PROCEDURE DM U; OUTDEFR(U,'MACRO); SYMBOLIC ANLFN PROCEDURE DS U; OUTDEFR(U,'SMACRO); SYMBOLIC PROCEDURE OUTDEFR(U,TYPE); OUTREF(CAR U,CADR U,CADDR U,TYPE); SYMBOLIC PROCEDURE QCRF U; IF NULL U OR U EQ T THEN U ELSE IF EQCAR(U,'QUOTE) THEN CADR U ELSE <<ANFORM U; COMPRESS EXPLODE '!?VALUE!?!?>>; FLAG('(EXPR FEXPR MACRO SMACRO NMACRO),'FUNCTION); CommentOutCode << % Lisp 1.6 LAP only SYMBOLIC ANLFN PROCEDURE LAP U; IF PAIRP(U:=QCRF CAR U) THEN BEGIN SCALAR GLOBS!*,LOCLS!*,CALLS!*,CURFUN!*,TOPLV!*,X; WHILE U DO <<IF PAIRP CAR U THEN IF X:=GET(OP!*!*:=CAAR U,'CRFLAPO) THEN APPLY(X,LIST U) ELSE IF !*GLOBALS THEN FOR EACH Y IN CDAR U DO ANLAPEV Y; U:=CDR U>>; QOUTREFE() END; SYMBOLIC CRFLAPO PROCEDURE !*ENTRY U; <<QOUTREFE(); U:=CDAR U; OUTRDEFUN(CAR U,CADR U,CADDR U)>>; SYMBOLIC PROCEDURE QOUTREFE; BEGIN IF NULL CURFUN!* THEN IF GLOBS!* OR CALLS!* THEN <<CURFUN!*:=COMPRESS EXPLODE '!?LAP!?!?; CHKSEEN CURFUN!*>> ELSE RETURN; OUTREFEND CURFUN!* END; SYMBOLIC CRFLAPO PROCEDURE !*LAMBIND U; FOR EACH X IN CADDAR U DO GLOBIND CAR X; SYMBOLIC CRFLAPO PROCEDURE !*PROGBIND U; FOR EACH X IN CADAR U DO GLOBIND CAR X; SYMBOLIC PROCEDURE LINCALL U; <<ADD2CALLS CAR (U:=CDAR U); CHECKARGCOUNT(CAR U,CADDR U)>>; PUT('!*LINK,'CRFLAPO,'LINCALL); PUT('!*LINKE,'CRFLAPO,'LINCALL); SYMBOLIC PROCEDURE ANLAPEV U; IF PAIRP U THEN IF CAR U MEMQ '(GLOBAL FLUID) THEN <<U:=CADR U; GLOBREF U; IF FLAGP(OP!*!*,'STORE) THEN PUT(U,'GLB2ST,'T)>> ELSE <<ANLAPEV CAR U; ANLAPEV CDR U>>; FLAG('(!*STORE),'STORE); FLAG('(POP MOVEM SETZM HRRZM),'STORE); SYMBOLIC PROCEDURE LAPCALLF U; BEGIN SCALAR FN; RETURN IF EQCAR(CADR (U:=CDAR U),'E) THEN <<ADD2CALLS(FN:=CADADR U); CHECKARGCOUNT(FN,CAR U)>> ELSE IF !*GLOBALS THEN ANLAPEV CADR U END; PUT('JCALL,'CRFLAPO,'LAPCALLF); PUT('CALLF,'CRFLAPO,'LAPCALLF); PUT('JCALLF,'CRFLAPO,'LAPCALLF); SYMBOLIC CRFLAPO PROCEDURE CALL U; IF NOT(CADDAR U = '(E !*LAMBIND!*)) THEN LAPCALLF U ELSE WHILE ((U:=CDR U) AND PAIRP CAR U AND CAAR U = 0) DO GLOBIND CADR CADDAR U; >>; SYMBOLIC PROCEDURE QERLINE U; IF PRETITL!* THEN NEWLINE U ELSE <<PRETITL!*:=T; NEWPAGE()>>; % These functions defined to be able to run in bare LISP % EQCAR MKQUOTE SYMBOLIC PROCEDURE EFFACE1(U,V); IF NULL V THEN NIL ELSE IF U EQ CAR V THEN CDR V ELSE RPLACD(V,EFFACE1(U,CDR V)); MAXARG!*:=15; END; |
Added psl-1983/util/psl-crefio.red version [27d4083135].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % =============================================================== % General Purpose I/O package for CREF, adapted to PSL % MLG, 6:19am Tuesday, 15 December 1981 % =============================================================== %============================================================================== % 11/18/82 - rrk - The function REMPROPSS was being called from RECREF in the % redefintion of a procedure with a single procedure name as the first % argument. This somehow caused the routine to go into an infinite loop. A % quick to turn the ID into a list within REMPROPSS solves the problem. The % reason that the call to REMPROPSS was not changed, is because it is not % clear if in some cases the argument will be a list. %============================================================================== GLOBAL '(!*FORMFEED ORIG!* LNNUM!* MAXLN!* TITLE!* PGNUM!* ); % FLAGS: FORMFEED (ON) controls ^L or spacer of ====; SYMBOLIC PROCEDURE INITIO(); % Set-up common defaults; BEGIN !*FORMFEED:=T; ORIG!*:=0; LNNUM!*:=0; LINELENGTH(75); MAXLN!*:=55; TITLE!*:=NIL; PGNUM!*:=1; END; SYMBOLIC PROCEDURE LPOSN(); LNNUM!*; INITIO(); SYMBOLIC PROCEDURE SETPGLN(P,L); BEGIN IF P THEN MAXLN!*:=P; IF L THEN LINELENGTH(L); END; % We use EXPLODE to produce a list of chars from atomname, % and TERPRI() to terminate a buffer..all else % done in package..spaces,tabs,etc. ; COMMENT Character lists are (length . chars), for FITS; SYMBOLIC PROCEDURE GETES U; % Returns for U , E=(Length . List of char); BEGIN SCALAR E; IF NOT IDP U THEN RETURN<<E:=EXPLODE U;LENGTH(E).E>>; IF NOT(E:=GET(U,'RCCNAM)) THEN <<E:=EXPLODE(U); E:=LENGTH(E) . E; PUT(U,'RCCNAM,E)>>; RETURN E; END; SYMBOLIC SMACRO PROCEDURE PRTWRD U; IF NUMBERP U THEN PRTNUM U ELSE PRTATM U; SYMBOLIC PROCEDURE PRTATM U; PRIN2 U; % For a nice print; SYMBOLIC PROCEDURE PRTLST U; IF ATOM U THEN PRIN2 U ELSE FOR EACH X IN U DO PRIN2 X; SYMBOLIC PROCEDURE PRTNUM N; PRIN2 N; SYMBOLIC PROCEDURE PRINCN E; % output a list of chars, update POSN(); WHILE (E:=CDR E) DO PRINC CAR E; CommentOutCode << % Defined in PSL SYMBOLIC PROCEDURE SPACES N; FOR I:=1:N DO PRINC '! ; SYMBOLIC PROCEDURE SPACES2 N; BEGIN SCALAR X; X := N - POSN(); IF X<1 THEN NEWLINE N ELSE SPACES X; END; >>; SYMBOLIC PROCEDURE SETPAGE(TITLE,PAGE); % Initialise current page and title; BEGIN TITLE!*:= TITLE ; PGNUM!*:=PAGE; END; SYMBOLIC PROCEDURE NEWLINE N; % Begins a fresh line at posn N; BEGIN LNNUM!*:=LNNUM!*+1; IF LNNUM!*>=MAXLN!* THEN NEWPAGE() ELSE TERPRI(); SPACES(ORIG!*+N); END; SYMBOLIC PROCEDURE NEWPAGE(); % Start a fresh page, with PGNUM and TITLE, if needed; BEGIN SCALAR A; A:=LPOSN(); LNNUM!*:=0; IF POSN() NEQ 0 THEN NEWLINE 0; IF A NEQ 0 THEN FORMFEED(); IF TITLE!* THEN <<SPACES2 5; PRTLST TITLE!*>>; SPACES2 (LINELENGTH(NIL)-4); IF PGNUM!* THEN <<PRTNUM PGNUM!*; PGNUM!*:=PGNUM!*+1>> ELSE PGNUM!*:=2; NEWLINE 10; NEWLINE 0; END; SYMBOLIC PROCEDURE UNDERLINE2 N; IF N>=LINELENGTH(NIL) THEN <<N:=LINELENGTH(NIL)-POSN(); FOR I:=0:N DO PRINC '!- ; NEWLINE(0)>> ELSE BEGIN SCALAR J; J:=N-POSN(); FOR I:=0:J DO PRINC '!-; END; SYMBOLIC PROCEDURE LPRINT(U,N); % prints a list of atoms within block LINELENGTH(NIL)-n; BEGIN SCALAR E, L,M; SPACES2 N; L := LINELENGTH NIL-POSN(); IF L<=0 THEN ERROR(13,"WINDOW TOO SMALL FOR LPRINT"); WHILE U DO <<E:=GETES CAR U; U:=CDR U; IF LINELENGTH NIL<POSN() THEN NEWLINE N; IF CAR E<(M := LINELENGTH NIL-POSN()) THEN PRINCN E ELSE IF CAR E<L THEN <<NEWLINE N; PRINCN E>> ELSE BEGIN E := CDR E; A: FOR I := 1:M DO <<PRINC CAR E; E := CDR E>>; NEWLINE N; IF NULL E THEN NIL ELSE IF LENGTH E<(M := L) THEN PRINCN(NIL . E) ELSE GO TO A END; PRINC '! >> END; % 11/18/82 rrk - Infinite loop caused by calls to this function with an % id as the ATMLST instead of a list. A quick patch to turn the single % id into a list is provided, eliminating the infinite loop. SYMBOLIC PROCEDURE REMPROPSS(ATMLST,LST); << IF NOT PAIRP ATMLST THEN ATMLST := LIST (ATMLST); WHILE ATMLST DO <<WHILE LST DO <<REMPROP(CAR ATMLST,CAR LST); LST:=CDR LST>>; ATMLST:=CDR ATMLST>> >>; SYMBOLIC PROCEDURE REMFLAGSS(ATMLST,LST); WHILE LST DO <<REMFLAG(ATMLST,CAR LST); LST:=CDR LST>>; CommentOutCode << % These are defined EXPRs in PSL SMACRO PROCEDURE REMFLAG1(U,V); REMFLAG(LIST U,V); SMACRO PROCEDURE FLAG1(U,V); FLAG(LIST U,V); >>; SYMBOLIC PROCEDURE FORMFEED; IF !*FORMFEED THEN EJECT() ELSE <<TERPRI(); PRIN2 " ========================================= "; TERPRI()>>; |
Added psl-1983/util/psl-input-stream.sl version [326ea20ca1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PSL-Input-Stream.SL - File Input Stream Objects (Portable PSL Version) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 10 December 1982 % % Summary of public functions: % % (setf s (open-input "file name")) % generates error on failure % (setf s (attempt-to-open-input "file name")) % returns NIL on failure % (setf ch (=> s getc)) % read character (map CRLF to LF) % (setf ch (=> s getc-image)) % read character (don't map CRLF to LF) % (setf ch (=> s peekc)) % peek at next character % (setf ch (=> s peekc-image)) % peek at next character (don't map CRLF to LF) % (setf str (=> s getl)) % Read a line; return string without terminating LF. % (=> s empty?) % Are there no more characters? % (=> s close) % Close the file. % (setf fn (=> s file-name)) % Return "true" name of file. % (setf date (=> s read-date)) % Return date that file was last read. % (setf date (=> s write-date)) % Return date that file was last written. % (=> s delete-file) % Delete the associated file. % (=> s undelete-file) % Undelete the associated file. % (=> s delete-and-expunge) % Delete and expunge the associated file. % (setf name (=> s author)) % Return the name of the file's author. % (setf name (=> s original-author)) % Return the original author's name. % (setf count (=> s file-length)) % Return the byte count of the file. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int)) (BothTimes (load objects)) (de attempt-to-open-input (file-name) (let ((p (ErrorSet (list 'open-input file-name) NIL NIL))) (and (PairP p) (car p)) )) (de open-input (file-name) (let ((s (make-instance 'input-stream))) (=> s open file-name) s)) (defflavor input-stream ((chn NIL) % PSL "channel" eof-flag % T => EOF has been detected file-name % file name given to OPEN ) () (gettable-instance-variables file-name) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (input-stream getc) () % Return the next character from the file. Line termination is represented % by a single NEWLINE (LF) character. Returns NIL on end of file. (if (not eof-flag) (let ((ch (ChannelReadChar chn))) (if (= ch #\EOF) (prog () (setf eof-flag T)) % return NIL on EOF ch % return the character, otherwise )))) (defmethod (input-stream getc-image) () (=> self getc)) (defmethod (input-stream empty?) () (null (=> self peekc-image))) (defmethod (input-stream peekc) () % Return the next character from the file, but don't advance to the next % character. Returns NIL on end of file. (let ((ch (=> self getc))) (when ch (ChannelUnReadChar chn ch) ch))) (defmethod (input-stream peekc-image) () (=> self peekc)) (defmethod (input-stream getl) () % Read and return (the remainder of) the current input line. % Read, but don't return the terminating EOL (if any). % Return NIL if no characters and end-of-file detected. (let ((s "")) (while T (let ((ch (=> self getc))) (if (null ch) (exit (if (string-empty? s) NIL s))) (if (= ch #\EOL) (exit s)) (setf s (string-concat s (string ch))) )))) (defmethod (input-stream tell-position) () NIL ) (defmethod (input-stream seek-position) (p) ) (defmethod (input-stream open) (name-of-file) % Open the specified file for input via SELF. If the file cannot be opened, % a Continuable Error is generated. (if chn (=> self close)) (setf eof-flag NIL) (setf chn (open name-of-file 'input)) (setf file-name (copystring name-of-file)) ) (defmethod (input-stream close) () (when chn (close chn) (setf chn NIL) (setf eof-flag T) )) (defmethod (input-stream read-date) () 0) (defmethod (input-stream write-date) () 0) (defmethod (input-stream delete-file) () ) (defmethod (input-stream undelete-file) () ) (defmethod (input-stream delete-and-expunge-file) () ) (defmethod (input-stream author) () "") (defmethod (input-stream original-author) () "") (defmethod (input-stream file-length) () 0) |
Added psl-1983/util/pslcomp-main.sl version [3358732da2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PSLCOMP-MAIN.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % Revised: 8 December 1982 % % 8-Dec-82 Alan Snyder % Changed use of DSKIN (now an EXPR). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This file redefines the start-up routine for PSLCOMP to read and interpret % the program command string as a list of source files to be compiled. (CompileTime (load common pathnames)) (load pathnamex parse-command-string get-command-string compiler) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (fluid '(*quiet_faslout *WritingFASLFile)) (cond ((funboundp 'original-main) (copyd 'original-main 'main))) (de main () (let ((CurrentReadMacroIndicator* 'LispReadMacro) % Crock! (CurrentScanTable* LispScanTable*) (c-list (parse-command-string (get-command-string))) (*usermode nil) (*redefmsg nil)) (compile-files c-list) (copyd 'main 'original-main) ) (original-main) ) (de compile-files (c-list) (cond ((null c-list) (PrintF "Portable Standard Lisp Compiler%n") (PrintF "Usage: PSLCOMP source-file ...%n") ) (t (for (in fn c-list) (do (attempt-to-compile-file fn)) ) (quit) ))) (de attempt-to-compile-file (fn) (let* ((form (list 'COMPILE-FILE fn)) (*break NIL) (result (ErrorSet form T NIL)) ) (cond ((FixP result) (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" fn) )) )) (de compile-file (fn) (let ((source-fn (namestring (pathname-set-default-type fn "SL"))) (binary-fn (namestring (pathname-set-type fn "B"))) (*quiet_faslout T) ) (if (not (FileP source-fn)) (printf "Unable to open source file: %w%n" source-fn) % else (printf "%n----- Compiling %w%n" source-fn binary-fn) (faslout (namestring (pathname-without-type binary-fn))) (dskin source-fn) (faslend) (printf "%nDone compiling %w%n%n" source-fn) ))) |
Added psl-1983/util/rawbreak.build version [7179ba0ee3].
> | 1 | in "rawbreak.red"$ |
Added psl-1983/util/rawbreak.red version [3817b60e20].
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | % RAWBREAK.RED - A safer break loop if RAWIO is loaded % MLG 16 Jan 1983 FLUID '(!*RAWIO); CopyD('OldBreak,'break); procedure newbreak(); Begin scalar OldRaw,x; OldRaw :=!*RawIo; If OldRaw then EchoOn(); x:=OldBreak(); If OldRaw Then EchoOff(); return x; End; Copyd('break,'newbreak); flag('break,'lose); |
Added psl-1983/util/rawio.red version [470fc5e9aa].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RAWIO.RED - Support routines for PSL Emode % % Author: Eric Benson % Computer Science Dept. % University of Utah % Date: 17 August 1981 % Copyright (c) 1981, 1982 University of Utah % Modified and maintained by William F. Galway. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DEC-20 version FLUID '(!*rawio); % T if terminal is using "raw" i.o. CompileTime << load if!-system; load syslisp$ if_system(Dec20, << load monsym$ load jsys$ >>) >>; BothTimes if_system(Dec20, % CompileTime probably suffices. << FLUID '( % Global? OldCCOCWords OldTIW OldJFNModeWord ); lisp procedure BITS1 U; if not NumberP U then Error(99, "Non-numeric argument to BITS") else lsh(1, 35 - U); macro procedure BITS U; begin scalar V; V := 0; for each X in cdr U do V := lor(V, BITS1 X); return V; end; >>); LoadTime if_system(Dec20, << OldJfnModeWord := NIL; % Flag "modes not saved yet" lap '((!*entry PBIN expr 0) % Read a single character from the TTY as a Lisp integer (pbin) % Issue PBIN (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry PBOUT expr 1) % write a single charcter to the TTY, works for integers and single char IDs % Don't bother with Int2Sys? (pbout) (!*exit 0) ); lap '((!*entry CharsInInputBuffer expr 0) % Returns the number of characters in the terminal input buffer. (!*MOVE (WConst 8#101) (reg 1)) % The input file (the terminal, = % 8#101) (sibe) % skip if input buffer empty (skipa (reg 1) (reg 2)) % otherwise # chars in r2 (setz (reg 1) 0) % if skipped, then zero (!*CALL Sys2Int) % Turn it into a number (!*exit 0) ); lap '((!*entry RFMOD expr 1) % returns the JFN mode word as Lisp integer (hrrzs (reg 1)) (rfmod) (!*MOVE (reg 2) (reg 1)) % Get mode word from R2 (!*CALL Sys2Int) (!*exit 0) ); lap '((!*entry RFCOC expr 1) % returns the 2 CCOC words for JFN as dotted pair of Lisp integers (hrrzs (reg 1)) (rfcoc) (!*PUSH (reg 2)) % save the first word (!*MOVE (reg 3) (reg 1)) (!*CALL Sys2Int) % make second into number (exch (reg 1) (indexed (reg st) 0)) % grab first word, save % tagged 2nd word. (!*CALL Sys2Int) % make first into number (!*POP (reg 2)) (!*JCALL Cons) % and cons them together ); lap '((!*entry RTIW expr 1) % Returns terminal interrupt word for specified process, or -5 for entire job, % as Lisp integer (hrrzs (reg 1)) % strip tag (rtiw) (!*MOVE (reg 2) (reg 1)) % result in r2, return in r1 (!*JCALL Sys2Int) % return as Lisp integer ); lisp procedure SaveInitialTerminalModes(); % Save the terminal modes, if not already saved. if null OldJfnModeWord then << OldJFNModeWord := RFMOD(8#101); OldCCOCWords := RFCOC(8#101); OldTIW := RTIW(-5); >>; lap '((!*entry SFMOD expr 2) % SFMOD(JFN, ModeWord); % set program related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (sfmod) (!*exit 0) ); lap '((!*entry STPAR expr 2) % STPAR(JFN, ModeWord); % set device related modes for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stpar) (!*exit 0) ); lap '((!*entry SFCOC expr 3) % SFCOC(JFN, CCOCWord1, CCOCWord2); % set control character output control for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*PUSH (reg 3)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (exch (reg 1) (indexed (reg st) 0)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 3)) (!*POP (reg 2)) (!*POP (reg 1)) (sfcoc) (!*exit 0) ); lap '((!*entry STIW expr 2) % STIW(JFN, ModeWord); % set terminal interrupt word for the specified terminal (hrrzs (reg 1)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL Int2Sys) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (stiw) (!*exit 0) ); lisp procedure EchoOff(); % A bit of a misnomer, perhaps "on_rawio" would be better. % Off echo, On formfeed, send all control characters % Allow input of 8-bit characters (meta key) if not !*rawio then % Avoid doing anything if already "raw mode" << SaveInitialTerminalModes(); % Note that 8#101, means "the terminal". % Clear bit 24 to turn echo off, % bits 28,29 turn off "translation" SFMOD(8#101, LAND(OldJFNModeWord, LNOT BITS(24, 28, 29))); % Set bit 0 to indicate "has mechanical tab" (so cntrl-L gets % through?). % Clear bit 34 to turn off cntrl-S/cntrl-Q STPAR(8#101, LAND(lor(OldJFNModeWord, BITS 1), LNOT BITS(34))); % More nonsense to turn off processing of control characters? SFCOC(8#101, LNOT(8#252525252525), LNOT(8#252525252525)); % Turn off terminal interrupts for entire job (-5), for everything % except cntrl-C (the bit number three that's one). STIW(-5,8#040000000000); !*rawio := T; % Turn on flag >>; lisp procedure EchoOn(); % Restore initial terminal echoing modes << % Avoid doing anything if OldJFNModeWord is NIL, means terminal mode % already "restored". if OldJFNModeWord then << SFMOD(8#101,OldJFNModeWord); STPAR(8#101,OldJFNModeWord); SFCOC(8#101,car OldCCOCWords,cdr OldCCOCWords); STIW(-5,OldTIW); >>; % Set to NIL so that things get saved again by % SaveInitialTerminalModes. (The terminal status may have been changed % between times.) OldJFNModeWord := NIL; !*rawio := NIL; % Indicate "cooked" i/o. >>; % Flush output buffer for stdoutput. (On theory that we're using buffered % I/O to speed things up.) Symbolic Procedure FlushStdOutputBuffer(); NIL; % Just a dummy routine for the 20. >> ); % END OF DEC-20 version. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % VAX Unix version LoadTime if_system(Unix, << % EchoOn, EchoOff, and CharsInInputBuffer are part of "kernel". Symbolic Procedure PBIN(); % Read a "raw character". NOTE--assumption that 0 gives terminal input. VaxReadChar(0); % Just call this with "raw mode" on. Symbolic Procedure PBOUT(chr); % NOTE ASSUMPTION that 1 gives terminal output. VaxWriteChar(1,chr); >>); % END OF Unix version. fluid '(!*EMODE); LoadTime << !*EMODE := NIL; Symbolic Procedure rawio_break(); % Redefined break handler to turn echoes back on after a break, unless % EMODE is running. << if !*rawio and not !*EMODE then EchoOn(); pre_rawio_break(); % May want to be paranoid and use a "catch(nil, % '(pre_rawio_break)" here. >>; % Carefully redefine the break handler. if null getd('pre_rawio_break) then << CopyD('pre_rawio_break, 'Break); CopyD('break, 'rawio_break); >>; >>; |
Added psl-1983/util/rcref.build version [80e3e73931].
> > > > | 1 2 3 4 | % changed to LOAD GSORT when needed. in "psl-crefio.red"$ Imports '(Gsort); in "psl-cref.red"$ |
Added psl-1983/util/read-macros.sl version [1166665d06].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % READ-MACROS.SL - some specilized reader macros % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % Edit by Cris Perdue, 1 Feb 1983 1400-PST % Dochar moved into "nonkernel", "C" for "CONTROL", etc. commented out. % Many miscellaneous symbolic names for characters removed. ((lambda (o-table) (setq LispScanTable* (TotalCopy o-table)) % in case it's in pure space (cond ((eq CurrentScanTable* o-table) (setq CurrentScanTable* LispScanTable*)))) LispScanTable*) % plug backquote and friends into the lisp reader via read macros % ` for backquote, , for unquote, ,@ for unquotel, and ,. for unquoted (de backquote-read-macro (channel qt) (list 'backquote (ChannelReadTokenWithHooks channel))) (de unquote-read-macro (channel qt) (list 'unquote (ChannelReadTokenWithHooks channel))) (de unquotel-read-macro (channel qt) (list 'unquotel (ChannelReadTokenWithHooks channel))) (de unquoted-read-macro (channel qt) (list 'unquoted (ChannelReadTokenWithHooks channel))) (putv LispScanTable* (char !`) 11) (putv LispScanTable* (char !,) 13) (put '!, (getv LispScanTable* 128) '((!@ . !,!@)(!. . !,!.))) (deflist '((!` backquote-read-macro) (!, unquote-read-macro) (!,!@ unquotel-read-macro) (!,!. unquoted-read-macro)) 'LispReadMacro) % A couple of MACLISP style sharp sign read macros... (putv LispScanTable* (char !#) 13) (put '!# (getv LispScanTable* 128) '((!. . !#!.) (!/ . !#!/) (!' . !#!') (!+ . !#!+) (!- . !#!-) (!\ . !#!\))) (deflist `((!#!' ,(function function-read-macro)) (!#!. ,(function eval-read-macro)) (!#!\ ,(function char-read-macro)) (!#!+ ,(function if-system-read-macro)) (!#!- ,(function if-not-system-read-macro)) (!#!/ ,(function single-char-read-macro))) 'LispReadMacro) (de function-read-macro (channel qt) `(function ,(ChannelReadTokenWithHooks channel))) (de eval-read-macro (channel qt) (eval (ChannelReadTokenWithHooks channel))) % (imports '(if-system)) % actually doesn't use the code, just the convention (fluid '(system_list*)) (de if-system-read-macro (channel qt) ((lambda (system) ((lambda (when_true) (cond ((memq system system_list*) when_true) (t (ChannelReadTokenWithHooks channel)))) (ChannelReadTokenWithHooks channel))) (ChannelReadTokenWithHooks channel))) (de if-not-system-read-macro (channel qt) ((lambda (system) ((lambda (when_false) (cond ((not (memq system system_list*)) when_false) (t (ChannelReadTokenWithHooks channel)))) (ChannelReadTokenWithHooks channel))) (ChannelReadTokenWithHooks channel))) %(de when-read-macro (channel qt) % (let ((a (ChannelReadTokenWithHooks channel))) % (let ((b (ChannelReadTokenWithHooks channel)) % (fn (and (idp a) (get a 'when-macro)))) % (if fn % (apply fn (list b)) % (StdError (BldMsg "Can't evaluate %r at %r time" b a)))))) % CompileTime and friends have to be made to work from LISP before these % will be of much use. %(foreach u in '(compile c CompileTime compile-time comp) do % (put u 'when-macro #'(lambda(x) `(CompileTime ,x)))) %(foreach u in '(load l LoadTime load-time) do % (put u 'when-macro #'(lambda(x) `(LoadTime ,x)))) %(foreach u in '(both b BothTimes both-times BothTime both-time) do % (put u 'when-macro #'(lambda(x) `(BothTimes ,x)))) %(foreach u in '(read r ReadTime read-time) do % (put u 'when-macro #'eval)) (de single-char-read-macro (channel qt) (ChannelReadChar channel)) % % Frightfully kludgey. Anybody know how to just read the one character? % ((lambda (*raise) % ((lambda (ch) % ((lambda (n) % (if (lessp n 128) % n % (StdError (BldMsg "%r is illegal after #/" ch)))) % (dochar ch))) % (ChannelReadTokenWithHooks channel))) % nil)) (de char-read-macro (channel qt) (dochar (ChannelReadTokenWithHooks channel))) % Definition of dochar moved to char-macro.sl in the kernel /csp % Alternative modifiers (below) removed, hope they aren't needed (yuk) /csp % (put 'c 'char-prefix-function (get 'control 'char-prefix-function)) % (put '!^ 'char-prefix-function (get 'control 'char-prefix-function)) % (put 'm 'char-prefix-function (get 'meta 'char-prefix-function)) (commentoutcode (deflist % let char know all about the "standard" two and three letter names for % non-printing ASCII characters. '((NUL 0) (SOH 1) (STX 2) (ETX 3) (EOT 4) (ENQ 5) (ACK 6) (BEL 7) (BS 8) (HT 9) (NL 10) (VT 11) (NP 12) (CR 13) (SO 14) (SI 15) (DLE 16) (DC1 17) (DC2 18) (DC3 19) (DC4 20) (NAK 21) (SYN 22) (ETB 23) (CAN 24) (EM 25) (SUB 26) (ESC 27) (FS 28) (GS 29) (RS 30) (US 31) (SP 32) (DEL 127)) 'charconst) ) (commentoutcode (deflist '((!^!@ 0) % "creeping featurism" here for sure... (!^A 1) (!^B 2) (!^C 3) (!^D 4) (!^E 5) (!^F 6) (!^G 7) (!^H 8) (!^I 9) (!^J 10) (!^K 11) (!^L 12) (!^M 13) (!^N 14) (!^O 15) (!^P 16) (!^Q 17) (!^R 18) (!^S 19) (!^T 20) (!^U 21) (!^V 22) (!^W 23) (!^X 24) (!^Y 25) (!^Z 26) (!^![ 8#33) (!^!\ 8#34) (!^!] 8#35) (!^!^ 8#36) (!^!~ 8#36) % for telerays... (!^!_ 8#37) (!^!/ 8#37) % for telerays... (!^!? 8#177)) 'charconst) ) (commentoutcode % It has been suggested that nice names for printing characters would be good, % too, so here are some. I don't really see that they're all that much use, % but I guess they don't do any harm. I doubt I'll ever use them, though. % If this isn't "creeping featurism" I don't know what is.... (foreach u in '((BANG !!) (EXCLAMATION !!) (AT !@) (ATSIGN !@) (SHARP !#) (POUND !#) (NUMBER !#) (NUMBER-SIGN !#) (HASH !#) (NOT-EQUAL !#) % For Algol 60 fans... (DOLLAR !$) (PERCENT !%) (CARET !^) (UPARROW !^) (AND !&) (AMPERSAND !&) (STAR !*) (TIMES !*) (LPAREN !( ) (LEFT-PARENTHESIS !( ) (LEFT-PAREN !( ) (LPAR !( ) (OPEN !( ) (RPAREN !) ) (RIGHT-PARENTHESIS !) ) (RIGHT-PAREN !) ) (RPAR !) ) (CLOSE !) ) (MINUS !-) (DASH !-) (UNDERSCORE !_) (UNDERLINE !_) (BACKARROW !_) (PLUS !+) (EQUAL !=) (EQUALS !=) (TILDE !~) (BACKQUOTE !`) (LBRACE !{) (LEFT-BRACE !{) (RBRACE !}) (RIGHT-BRACE !}) (LBRACKET ![) (LEFT-BRACKET ![) (LBRA ![) (RBRACKET !]) (RIGHT-BRACKET !]) (RBRA !]) (APOSTROPHE !') (SINGLE-QUOTE !') (QUOTE-MARK !') (DOUBLE-QUOTE !") (STRING-MARK !") % (QUOTE should this be ' or " -- I'll play it safe and not use either (COLON !:) (SEMI !;) (SEMICOL !;) (SEMICOLON !;) (QUESTION !?) (QUESTION-MARK !?) (QUESTIONMARK !?) (LESS !<) (LESS-THAN !<) (LANGLE !<) (LEFT-ANGLE !<) (LEFT-ANGLE-BRACKET !<) (GREATER !>) (GREATER-THAN !>) (GRTR !>) (RANGLE !>) (RIGHT-ANGLE !>) (RIGHT-ANGLE-BRACKET !>) (COMMA !,) (DOT !.) (PERIOD !.) (FULL-STOP !.) % For the English among us... (SLASH !/) (SOLIDUS !/) (DIVIDE !/) (BACKSLASH !\) (BAR !|) (VERTICAL !|) (VETICAL-BAR !|) (ZERO !0) (NAUGHT !0) % For the English among us... (ONE !1) (TWO !2) (THREE !3) (FOUR !4) (FIVE !5) (SIX !6) (SEVEN !7) (EIGHT !8) (NINE !9)) do (put (car u) 'charconst (dochar (cadr u)))) ) |
Added psl-1983/util/read-utils.build version [a87b59ebdc].
> | 1 | in "read-utils.red"$ |
Added psl-1983/util/read-utils.red version [933e38b624].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % READ-TABLE-UTILS.RED - Read Table Utils % % Author: M. L. Griss % Computer Science Dept. % University of Utah % Date: 28 August 1981 % Copyright (c) 1981 University of Utah % NOTE: Rather Crude, needs some work. % Edit by Cris Perdue, 28 Jan 1983 2040-PST % Occurrences of dipthong changed to diphthong Fluid '( CharacterClass!* ); Lisp procedure PrintScanTable (Table); Begin Scalar I; I := 0; For I :=0:127 do <<Prin1 I; TAB 5; prin2 Int2Id I; Tab 15; print CharacterClass!*[Table[I]] >>; PrintF(" Diphthong name: %r%n",Table[128]); %/ PrintF(" ReadMacro name: %r%n",Table[129]); %/ PrintF(" SpliceMacro name: %r%n",Table[130]); End; %%% Some id names for the classes Lisp Procedure CopyScanTable(OldTable); Begin If Null OldTable then OldTable:=CurrentScanTable!*; If not (vectorp OldTable and UpbV(oldTable)=130) then return StdError "CopyScanTable expects a valid Readtable"; OldTable:=Copy OldTable; OldTable[128]:=Gensym(); OldTable[129]:=Gensym(); OldTable[130]:=Gensym(); Return OldTable; End; LoadTime << CharacterClass!*:= '[Digit Digit Digit Digit Digit Digit Digit Digit Digit Digit Letter Delimiter Comment Diphthong IdEscape StringQuote Package Ignore Minus Plus Decimal]; Put('Letter, 'CharacterClass!*, 10); Put('Delimiter, 'CharacterClass!*, 11); Put('Comment, 'CharacterClass!*, 12); Put('Diphthong, 'CharacterClass!*, 13); Put('IdEscape, 'CharacterClass!*, 14); Put('StringQuote, 'CharacterClass!*, 15); Put('Package, 'CharacterClass!*, 16); Put('Ignore, 'CharacterClass!*, 17); Put('Minus, 'CharacterClass!*, 18); Put('Plus, 'CharacterClass!*, 19); Put('Decimal, 'CharacterClass!*, 20) >>; Lisp procedure PutCharacterClass(Table,Ch,Val); ChangeCharType(Table,Ch,Val); Symbolic Procedure ChangeCharType(TBL,Ch,Ty); %. Set Character type begin scalar IDNum; If IdP Ty then Ty := Get(Ty,'CharacterClass!*); If IDP Ch and (IDNum := ID2Int Ch) < 128 and Numberp Ty and Ty >=0 and Ty <=20 then PutV(TBL,IDNum,Ty) Else Error(99,"Cant Set ReadTable"); end; Symbolic Procedure PutDiphthong(TBL,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,TBL[128], (FollowCh . Diphthong) . GET(StartCh,TBL[128]))>> else Error(99, "Cant Declare Diphthong"); Symbolic Procedure MakeDiphthong(TBL,DipIndicator,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,DipIndicator, (FollowCh . Diphthong) . GET(StartCh,DipIndicator))>> else Error(99, "Cant Declare Diphthong"); Lisp procedure PutReadMacro(Table,x,Fn); Begin If not IdP x then IdError(x,'PutReadMacro); If Not IdP Fn then return IDError(x,'PutReadMacro); % Check Delimiter Class as 11 or 23 Put(x,Table[129],Fn); Remprop(x,Table[130]); End; %/ Splice macros currently "frowned" upon Lisp procedure PutSpliceMacro(Table,x,Fn); Begin If not IdP x then IdError(x,'PutSpliceMacro); If Not IdP Fn then return IDError(x,'PutSpliceMacro); % Check Delimiter Class as 11 or 13 Put(x,Table[130],Fn); Remprop(x,Table[129]); End; end; |
Added psl-1983/util/readme version [a5f3563bea].
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | The files in this directory constitute the most recent version of the Portable Standard LISP Manual. Each file is a separate chapter, and is preceded by its chapter number; e.g. 03-RLISP.LPT is the third chapter and discusses RLISP. Some other information is available in the files with no chapter number and in PD:*.DOC. To read these files in Emacs, use the Library available in uem: called Clean-files; there is a function called Clean LPT File which can put an lpt file into emacs-readbale form. That is, do: <Meta-X> Load Library$uem:Clean-Files <Meta-X> Clean LPT File$ Please do not change the version on PLPT:! |
Added psl-1983/util/ring-buffer.sl version [2504c42f57].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % RING-BUFFER.SL - General Ring Buffers % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 July 1982 % Revised: 16 November 1982 % % 16-Nov-82 Alan Snyder % Recoded using OBJECTS package. Added FETCH and ROTATE operations. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors)) (de ring-buffer-create (maximum-size) (make-instance 'ring-buffer 'maximum-size maximum-size)) (defflavor ring-buffer ((maximum-size 16) % Maximum number of elements. vec % Stores the elements. (size 0) % Elements 0..size-1 are valid. (ptr -1) % Element vec[ptr] is current. ) () (gettable-instance-variables maximum-size size) (initable-instance-variables maximum-size) ) (defmethod (ring-buffer init) (init-plist) (setf vec (mkvect (- maximum-size 1)))) (defmethod (ring-buffer push) (new-element) (let ((new-ptr (+ ptr 1))) (when (> new-ptr (vector-upper-bound vec)) (setf new-ptr 0)) (when (>= new-ptr size) (setf size (+ new-ptr 1))) (setf ptr new-ptr) (vector-store vec new-ptr new-element) new-element )) (defmethod (ring-buffer top) () % Returns NIL if the buffer is empty. (=> self fetch 0)) (defmethod (ring-buffer pop) () % Returns NIL if the buffer is empty. (when (> size 0) (let ((old-element (vector-fetch vec ptr))) (setf ptr (- ptr 1)) (when (< ptr 0) (setf ptr (- size 1))) old-element ))) (defmethod (ring-buffer fetch) (index) % Index 0 is the top element. % Index -1 is the next previous element, etc. % Index 1 is the most previous element, etc. % Returns NIL if the buffer is empty. (when (> size 0) (vector-fetch vec (ring-buffer-mod (+ ptr index) size)) )) (defmethod (ring-buffer rotate) (count) % Rotate -1 makes the next "older" element current (like POP), etc. % Rotate 1 makes the next "newer" element current, etc. (when (> size 0) (setf ptr (ring-buffer-mod (+ ptr count) size)) )) (de ring-buffer-mod (a b) (let ((remainder (// a b))) (if (>= remainder 0) remainder (+ b remainder)) )) % The following functions are defined for backwards compatibility: (de ring-buffer-push (rb new-element) (=> rb push new-element)) (de ring-buffer-top (rb) (=> rb top)) (de ring-buffer-pop (rb) (=> rb pop)) |
Added psl-1983/util/rlisp-parser.red version [a16a15658e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % RLISP-PARSER.RED - RLISP parser based on Nordstrom and Pratt model % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: May 1981 % Copyright (c) 1981 University of Utah % % Known Bugs and Problems: % Procedure TEMPLATES parsed at wrong precendence, so % procedure x/y; is ok % procedure (x/Y) fails! % % IF a Then B; ELSE c; parses badly, doesnt catch ELSE % QUOTIENT(A,B) parses as RECIP(A) % % Edit by Cris Perdue, 28 Jan 1983 2038-PST % Occurrences of "dipthong" changed to "diphthong" % <PSL.UTIL.NEWVERSIONS>RLISP-PARSER.RED.4, 16-Dec-82 12:11:15, Edit by KESSLER % Make SEMIC!* a Global (as in rlisp-support), so it won't be made fluid in % compilation of Scan. % <PSL.UTIL>RLISP-PARSER.RED.3, 13-Dec-82 13:14:36, Edit by OTHMER % Flagged EMB as 'FTYPE so debug functions will work % <PSL.UTIL>RLISP-PARSER.RED.42, 17-Mar-82 02:36:14, Edit by BENSON % Finally infix as prefix works!!! % <PSL.UTIL>RLISP-PARSER.RED.25, 14-Jan-82 13:16:34, Edit by BENSON % Added JOIN to for each % <PSL.UTIL>RLISP-PARSER.RED.24, 30-Dec-81 01:01:30, Edit by BENSON % Unfixed infix as prefix. Have to check to make sure the thing is an arglist % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:22:37, Edit by BENSON % fixed LAMBDA();... % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:21:43, Edit by BENSON % Infix operators used as prefix are parsed correctly % <PSL.UTIL>RLISP-PARSER.RED.19, 28-Dec-81 14:44:47, Edit by BENSON % Removed assign-op in favor of SetF % <PSL.UTIL>RLISP-PARSER.RED.36, 5-Feb-82 07:17:34, Edit by GRISS % Add NE as infix CompileTime flag('(DefineBOpX DefineROpX DoInfixAsPrefix IsOpOp DoPrefix DoInfix MakeLocals MkQuotList PrecSet InfixOp PrefixOp RlispRead RemSemicol SymErr RAtomHook CommentPart), 'InternalFunction); FLUID '(CURSYM!* !*InsideStructureRead); CURSYM!*:='! ; global '(Semic!* TokType!*); lisp procedure SymErr(X, Y); StdError BldMsg("Syntax error %r", X); SYMBOLIC PROCEDURE SCAN; BEGIN SCALAR X; A: CURSYM!* := RATOMHOOK(); IF TOKTYPE!* EQ 3 THEN %/ Also a R, (IF CURSYM!* EQ '!' THEN CURSYM!* := LIST('QUOTE, RLISPREAD()) ELSE IF (X:=GET(CURSYM!*,'NeWNAM!-OP))THEN <<IF X EQ '!*SEMICOL!* THEN SEMIC!* := CURSYM!*; CURSYM!*:=X >> ); IF (X:=(GET(CURSYM!*,'NEWNAM))) THEN CURSYM!*:=X; IF CURSYM!* EQ 'COMMENT THEN << WHILE NOT (READCH() MEMQ '(!; !$)) DO ; GOTO A >>; RETURN CURSYM!*; END; SYMBOLIC PROCEDURE RESETPARSER; CURSYM!*:= '! ; %----------------------------------------------------------------- %--- Boot strap functions, move to build file-----; FLUID '( %. Name of Grammer being defined DEFPREFIX DEFINFIX GRAMPREFIX GRAMINFIX ); %. Name of grammer running DEFPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined DEFINFIX := 'RLISPINFIX; %. Key for Grammer being defined GRAMPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined GRAMINFIX := 'RLISPINFIX; %. Key for Grammer being defined SYMBOLIC FEXPR PROCEDURE DEFINEBOP U; DEFINEBOPX U; SYMBOLIC PROCEDURE DEFINEBOPX U; % u=(opname, lprec, rprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Opname; Remove ' which used to suppress OP props Y := EVAL CADR U % Lprec . EVAL CADDR U % Rprec . IF NULL CDDDR U THEN NIL % Default function is NIL ELSE IF ATOM CADDDR U THEN CADDDR U ELSE LIST('LAMBDA,'(X Y),CADDDR U); PUT(W,DEFINFIX,Y) % Binop in CAR END; SYMBOLIC PROCEDURE INFIXOP U; % Used also in REDUCE GET(U,GRAMINFIX); SYMBOLIC PROCEDURE INFIXPREC U; % Used in REDUCE MathPrint BEGIN SCALAR V; IF NULL(V:=INFIXOP U) THEN RETURN NIL; IF PAIRP V AND NUMBERP CAR V THEN RETURN CAR V; RETURN NIL; END; SYMBOLIC FEXPR PROCEDURE DEFINEROP U; DEFINEROPX U; SYMBOLIC PROCEDURE DEFINEROPX U; % u=(opname,lprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Name, remove ' mark Y := EVAL CADR U % Lprec . IF NULL CDDR U THEN NIL % Default is NIL ELSE IF ATOM CADDR U THEN CADDR U % function name ELSE LIST('LAMBDA,'(X),CADDR U); % PUT(W,DEFPREFIX,Y) END; SYMBOLIC PROCEDURE PREFIXOP U; GET(U,GRAMPREFIX); FLUID '(OP); %. Current TOKEN being studied % ***** General Parser Functions *****; SYMBOLIC PROCEDURE PARSE0(RP,PRESCAN); %. Collect Phrase to LP<RP BEGIN SCALAR CURSYM,U; %/ IF COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; OP := IF PRESCAN THEN SCAN() ELSE CURSYM!*; %/ IF PRESCAN AND COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; U := RDRIGHT(RP,OP); %/ IF CURSYM THEN RPLACA(CURSYM,U); RETURN U END; SYMBOLIC PROCEDURE RDRIGHT(RP,Y); %. Collect phrase until OP with LP<RP % Y is starting TOKEN. % RP=NIL - Caller applies Function to Y, without collecting RHS subphrase BEGIN SCALAR TEMP,OP1,TEMPSCAN, TEMPOP, !*InsideStructureRead; !*InsideStructureRead := T; IF NULL RP THEN RETURN Y %/ ELSE IF IDFLAG THEN OP := SCAN() % Set IDFLAG if not Operator ELSE IF RP=0 AND Y EQ '!*SEMICOL!* THEN RETURN NIL %/ Toplevel ; or $? ELSE IF (TEMP:=PREFIXOP Y) THEN << TEMPSCAN := SCAN(); IF STRONGERINFIXOP(TEMPSCAN, Y, CAR TEMP) THEN OP := TEMPSCAN ELSE Y := DOPREFIX(CDR TEMP,Y,RDRIGHT(CAR TEMP,TEMPSCAN)) >> ELSE IF NOT INFIXOP Y THEN OP := SCAN() %/ Binary OP in Prefix Position ELSE IF ISOPOP(OP,RP,Y) THEN <<OP := Y; Y := NIL>> ELSE OP := SCAN();% Y:=DoINFIXasPREFIX(Y,OP:=SCAN()); RDLEFT: IF %/IDFLAG OR NOT (TEMP := INFIXOP OP) THEN IF NULL OP THEN <<Y := LIST(Y,NIL); OP := SCAN()>> ELSE Y := REPCOM(Y,RDRIGHT(99,OP)) %. Do as PREFIX ELSE IF RP>CAR TEMP THEN RETURN Y ELSE <<OP1:=OP; %/ !*ORD PROBLEM? TEMPSCAN := SCAN(); IF TEMPSCAN = '!*LPAR!* AND NOT FUNBOUNDP OP1 THEN << OP := TEMPSCAN; %/ kludge to allow infix/prefix TEMPSCAN := RDRIGHT(CADR TEMP, OP); IF EQCAR(TEMPSCAN, '!*COMMA!*) THEN Y := LIST(Y, REPCOM(OP1, TEMPSCAN)) ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,TEMPSCAN) >> ELSE IF STRONGERINFIXOP(TEMPSCAN, OP1, CADR TEMP) THEN << Y := LIST(Y, OP1); OP := TEMPSCAN >> ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,RDRIGHT(CADR TEMP,TEMPSCAN))>>; GO TO RDLEFT END; SYMBOLIC PROCEDURE STRONGERINFIXOP(NEXTOP, LASTOP, LASTPREC); BEGIN SCALAR TEMPOP, MATCHER; RETURN NOT PREFIXOP NEXTOP AND (TEMPOP := INFIXOP NEXTOP) AND NUMBERP LASTPREC AND NUMBERP CAR TEMPOP AND CAR TEMPOP <= 6 AND CAR TEMPOP <= LASTPREC AND NOT ((MATCHER := GET(LASTOP, 'CLOSER)) AND MATCHER EQ NEXTOP) AND NOT ISOPOP(NEXTOP, LASTPREC, LASTOP); END; DefList('((BEGIN END) (!*LPAR!* !*RPAR!*) (!*LSQB!* !*RSQB!*) (!*LVEC!* !*RVEC!*)), 'CLOSER); SYMBOLIC PROCEDURE DoINFIXasPREFIX(LHS,BOP); REPCOM(LHS,RDRIGHT(99,BOP)); %. Note that PREFIX functions have next token SCANed, and get an argument, %. "X", that is either this TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOPREFIX(ACT,ROP,RHS); IF NULL ACT THEN LIST(ROP,RHS) ELSE APPLY(ACT,LIST RHS); %. Note that INFIX functions have next token SCANed, and get two arguments, %. "X" and "Y"; "X" is LHS phrase, %. "Y" is either the scanned TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOINFIX(ACT,LHS,BOP,RHS); IF NULL ACT THEN LIST(BOP,LHS,RHS) ELSE APPLY(ACT,LIST(LHS,RHS)); SYMBOLIC PROCEDURE ISOPOP(XOP,RP,Y); %. Test for legal OP-> <-OP IF RP=2 THEN Y EQ '!*RPAR!* % LPAR scans for LP 2 ELSE IF RP=0 AND XOP EQ 'END AND Y MEMBER '(!*SEMICOL!* !*COLON!* !*RSQB!* END) THEN T ELSE IF Y MEMQ '(!*SEMICOL!* END !*RSQB!*) % Special cases in BEGIN-END THEN RP= -2 OR XOP MEMQ '(!*SEMICOL!* !*COLON!* !*RSQB!*) ELSE NIL; SYMBOLIC PROCEDURE PARERR(X,Y); StdError X; SYMBOLIC PROCEDURE REMCOM X; %. (, x y z) -> (x y z) IF EQCAR(X,'!*COMMA!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REMSEMICOL X; %. (; x y z) -> (x y z) IF EQCAR(X,'!*SEMICOL!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); %SYMBOLIC PROCEDURE SELF RHS; %. Prefix Operator returns RHS % RHS; SYMBOLIC PROCEDURE ParseNOOP X; <<OP:=SCAN();X>>; DEFINEROP('NOOP,NIL,ParseNOOP); %. Prevent TOKEN from being an OP SYMBOLIC PROCEDURE MKQUOTLIST U; %this could be replaced by MKQUOTE in most cases; 'LIST . FOR EACH X IN U COLLECT IF CONSTANTP X THEN X ELSE MKQUOTE X; SYMBOLIC PROCEDURE NARY(XOP,LHS,RHS); %. Remove repeated NARY ops IF EQCAR(LHS,XOP) THEN ACONC(LHS,RHS) ELSE LIST(XOP,LHS,RHS); % ***** Tables for Various Infix Operators *****; SYMBOLIC PROCEDURE ParseCOMMA(X,Y); NARY('!*COMMA!*,X,Y); DEFINEBOP('!*COMMA!*,5,6,ParseCOMMA ); SYMBOLIC PROCEDURE ParseSEMICOL(X,Y); NARY('!*SEMICOL!*,X,Y); DEFINEBOP('!*SEMICOL!*, - 1,0,ParseSEMICOL ); SYMBOLIC PROCEDURE ParseSETQ(LHS,RHS); %. Extended SETQ LIST(IF ATOM LHS THEN 'SETQ ELSE 'SETF, LHS, RHS); DEFINEBOP('SETQ,7,6,ParseSETQ); DEFINEBOP('CONS,23,21); SYMBOLIC PROCEDURE ParsePLUS2(X,Y); NARY('PLUS,X,Y); DEFINEBOP('PLUS,17,18,ParsePLUS2); %SYMBOLIC PROCEDURE ParsePLUS1(X); % IF EQCAR(X,'!*COMMA!*) THEN REPCOM('PLUS,X) ELSE X; % %DEFINEROP('PLUS,26,ParsePLUS1); %/ **** Prefix + sign... DEFINEROP('MINUS,26); SYMBOLIC PROCEDURE ParseDIFFERENCE(X); IF NUMBERP X THEN (0 - X ) ELSE IF EQCAR(X,'!*COMMA!*) THEN REPCOM('DIFFERENCE,X) ELSE LIST('MINUS,X); DEFINEROP('DIFFERENCE,26,ParseDIFFERENCE ); DEFINEBOP('DIFFERENCE,17,18); DEFINEBOP('TIMES,19,20); SYMBOLIC PROCEDURE ParseQUOTIENT(X); IF NOT EQCAR(X,'!*COMMA!*) THEN LIST('RECIP,X) ELSE REPCOM('QUOTIENT,X); DEFINEROP('QUOTIENT,26,ParseQUOTIENT); DEFINEBOP('QUOTIENT,19,20); DEFINEROP('RECIP,26); DEFINEBOP('EXPT,23,24); SYMBOLIC PROCEDURE ParseOR(X,Y); NARY('OR,X,Y); DEFINEBOP('OR,9,10,ParseOR); %/DEFINEROP('OR,26,REPCOM('OR,X)); SYMBOLIC PROCEDURE ParseAND(X,Y); NARY('AND,X,Y); DEFINEBOP('AND,11,12,ParseAND); %/DEFINEROP('AND,26,REPCOM('AND,X)); DEFINEROP('NOT,14); DEFINEBOP('MEMBER,15,16); %/DEFINEROP('MEMBER,26,REPCOM('MEMBER,X)); DEFINEBOP('MEMQ,15,16); %/DEFINEROP('MEMQ,26,REPCOM('MEMQ,X)); DEFINEBOP('EQ,15,16); %/DEFINEROP('EQ,26,REPCOM('EQ,X)); DEFINEBOP('EQUAL,15,16); DEFINEBOP('GEQ,15,16); DEFINEBOP('GREATERP,15,16); DEFINEBOP('LEQ,15,16); DEFINEBOP('LESSP,15,16); DEFINEBOP('NEQ,15,16); DEFINEBOP('NE,15,16); % ***** Tables and Definitions for Particular Parsing Constructs *****; % ***** IF Expression *****; DEFINEROP('IF,4,ParseIF); DEFINEBOP('THEN,3,6); DEFINEBOP('ELSE,3,6); SYMBOLIC PROCEDURE ParseIF X; BEGIN SCALAR Y,Z; IF OP EQ 'THEN THEN Y := PARSE0(6,T) ELSE PARERR("IF missing THEN",T); IF OP EQ 'ELSE THEN Z := LIST PARSE0(6,T); RETURN 'COND . LIST(X,Y) . IF Z THEN IF EQCAR(CAR Z,'COND) THEN CDAR Z ELSE LIST (T . Z) ELSE NIL END; SYMBOLIC PROCEDURE ParseCASE(X); %. Parser function BEGIN IF NOT (OP EQ 'OF) THEN PARERR("CASE Missing OF",T); RETURN 'CASE . X . CASELIST() END; DEFINEBOP('OF,3,6); DEFINEBOP('TO,8,9); DEFINEROP('CASE,4,ParseCASE); SYMBOLIC PROCEDURE CASELIST; BEGIN SCALAR TG,BOD,TAGLIST,BODLIST; L1: OP := SCAN(); % Drop OF, : , etc IF OP EQ 'END THEN GOTO L2; % For optional ; before END TG := PARSETAGS(); % The TAG expressions BOD:= PARSE0(6,T); % The expression BODLIST:=LIST(TG,BOD) . BODLIST; IF OP EQ '!*SEMICOL!* THEN GOTO L1; IF OP NEQ 'END THEN PARERR("Expect END after CASE list",T); L2: OP:=SCAN(); % Skip 'END RETURN REVERSE BODLIST; END; SYMBOLIC PROCEDURE PARSETAGS(); % Collects a single CASE-tag form; OP prescanned BEGIN SCALAR TG,TGLST; TG:=PARSE0(6,NIL); % , and : below 6 IF EQCAR(TG,'TO) THEN TG:='RANGE . CDR TG; % TO is infix OP IF TG MEMQ '(OTHERWISE DEFAULT) THEN RETURN <<IF OP NEQ '!*COLON!* THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); NIL>>; IF OP EQ '!*COLON!* THEN RETURN LIST(TG); IF OP EQ '!*COMMA!* THEN RETURN <<OP:=SCAN(); TGLST:=PARSETAGS(); IF NULL TGLST THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); TG . TGLST>>; PARERR("Expect one or more tags before : in CASE",T); END; % ***** Block Expression *****; fluid '(BlockEnders!*); BlockEnders!* :='(END !*RPAR!* !*SEMICOL!* ELSE UNTIL !*RSQB!*); SYMBOLIC PROCEDURE ParseBEGIN(X); ParseBEGIN1(REMSEMICOL X, COMMENTPART(SCAN(),BlockEnders!*)); DEFINEROP('BEGIN,-2,ParseBEGIN); DEFINEBOP('END,-3,-2); SYMBOLIC PROCEDURE ParseGO X; IF X EQ 'TO THEN LIST('GO,PARSE0(6,T)) % Why not Just SCAN? ELSE <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GO,NIL,ParseGO ); SYMBOLIC PROCEDURE ParseGOTO X; <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GOTO,NIL,ParseGOTO ); SYMBOLIC PROCEDURE ParseRETURN X; Begin Scalar XOP; RETURN LIST('RETURN, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('RETURN,NIL,ParseRETURN); SYMBOLIC PROCEDURE ParseEXIT X; Begin Scalar XOP; RETURN LIST('EXIT, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('EXIT,NIL,ParseEXIT); DEFINEBOP('!*COLON!*,1,0 ); SYMBOLIC PROCEDURE COMMENTPART(A,L); IF A MEMQ L THEN <<OP := A; NIL>> ELSE A . COMMENTPART(SCAN(),L); SYMBOLIC PROCEDURE ParseBEGIN1(L,COMPART); BEGIN SCALAR DECLS,S; % Look for Sequence of Decls after Block Header A: IF NULL L THEN GO TO ND %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; ELSE IF NULL CAR L THEN <<L := CDR L; GO TO A>> ELSE IF EQCAR(CAR L,'DECLARE) THEN <<DECLS :=APPEND(CDAR L, DECLS); % Reverse order collection L := CDR L>> ELSE <<S:=L; GO TO B>>; % Hold Body for Rescan GO TO A; B: IF NULL L THEN GO TO ND ELSE IF EQCAR(CAR L,'DECLARE) THEN PARERR("DECLARATION invalid in BEGIN body",NIL) ELSE IF EQCAR(CAR L,'!*COLON!*) THEN <<RPLACD(CDDAR L,CDR L); RPLACD(L,CDDAR L); RPLACA(L,CADAR L)>> ELSE IF CDR L AND NULL CADR L THEN <<RPLACD(L,CDDR L); L := NIL . L>>; L := CDR L; GO TO B; ND: RETURN ('PROG . MAKELOCALS(DECLS) . S); END; SYMBOLIC PROCEDURE MAKELOCALS(U); %. Remove Types from Reversed DECLARE IF NULL U THEN NIL ELSE APPEND(CDAR U,MAKELOCALS CDR U); % ***** Procedure Expression *****; GLOBAL '(!*MODE); !*MODE := 'SYMBOLIC; SYMBOLIC PROCEDURE NMODESTAT VV; % Parses TOP-LEVEL mode ....; BEGIN SCALAR TMODE,X; X:= CURSYM!*; % SCAN(); IF CURSYM!* EQ '!*SEMICOL!* THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; IF FLAGP(CURSYM!*,'DELIM) THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; TMODE := !*MODE; !*MODE := VV; % Local MODE change for MKPROC X := ERRORSET('(PARSE0 0 NIL),T,!*BACKTRACE); !*MODE := TMODE; RETURN IF ATOM X OR CDR X THEN NIL ELSE CAR X END; SYMBOLIC PROCEDURE NEWMODE VV; <<PRINT LIST('NEWMODE,LIST('QUOTE,VV)); IF NULL VV THEN VV:='SYMBOLIC; !*MODE := VV>>; CommentOutCode << fluid '(FTypes!*); FTYPES!* := '(EXPR FEXPR MACRO); SYMBOLIC PROCEDURE OLDPROCSTAT; BEGIN SCALAR BOOL,U,TYPE,X,Y,Z; IF FNAME!* THEN GO TO B ELSE IF CURSYM!* EQ 'PROCEDURE THEN TYPE := 'EXPR ELSE PROGN(TYPE := CURSYM!*,SCAN()); IF NOT CURSYM!* EQ 'PROCEDURE THEN GO TO C; X := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF ATOM X OR CDR X THEN GO TO A ELSE IF ATOM (X := CAR X) THEN X := LIST X; %no arguments; FNAME!* := CAR X; %function name; IF IDP FNAME!* %AND NOT(TYPE MEMQ FTYPES!*); THEN IF NULL FNAME!* OR (Z := GETTYPE FNAME!*) AND NOT Z MEMQ '(PROCEDURE OPERATOR) THEN GO TO D ELSE IF NOT GETD FNAME!* THEN FLAG(LIST FNAME!*,'FNC); %to prevent invalid use of function name in body; U := CDR X; Y := ERRORSET(LIST('FLAGTYPE,MKQUOTE U,MKQUOTE 'SCALAR), T,!*BACKTRACE); IF ATOM Y OR CDR Y THEN Y := NIL ELSE Y := CAR Y; X := CAR X . Y; A: Z := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF NOT ATOM Z AND NULL CDR Z THEN Z := CAR Z; IF NULL ERFG!* THEN Z:=PROCSTAT1(X,Z,TYPE); REMTYPE Y; REMFLAG(LIST FNAME!*,'FNC); FNAME!*:=NIL; IF NOT BOOL AND ERFG!* THEN REDERR "ERROR TERMINATION"; RETURN Z; B: BOOL := T; C: ERRORSET('(SYMERR (QUOTE PROCEDURE) T),T,!*BACKTRACE); GO TO A; D: LPRIE LIST(Z,FNAME!*,"INVALID AS PROCEDURE"); GO TO A END; >>; % Some OLD Crap looks at 'STAT values!!! DEFLIST ('((PROCEDURE PROCSTAT) (EXPR PROCSTAT) (FEXPR PROCSTAT) (EMB PROCSTAT) (MACRO PROCSTAT) (NMACRO PROCSTAT) (SMACRO PROCSTAT)), 'STAT); DEFLIST ('((ALGEBRAIC MODESTAT) (SYMBOLIC MODESTAT) (SYSLSP MODESTAT) ), 'STAT); %/ STAT used for OLD style BEGIN KEY search DEFLIST('((LISP SYMBOLIC)),'NEWNAM); DEFINEROP('SYMBOLIC,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEROP('ALGEBRAIC,NIL,NMODESTAT('ALGEBRAIC)); % Make it a Prefix OP DEFINEROP('SYSLSP,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEBOP('PROCEDURE,1,NIL,ParsePROCEDURE); % Pick up MODE -- will go DEFINEROP('PROCEDURE,NIL,ParsePROCEDURE('EXPR,X)); %/ Unary, use DEFAULT mode? SYMBOLIC PROCEDURE ParsePROCEDURE2(NAME,VARLIS,BODY,TYPE); BEGIN SCALAR Y; % IF FLAGP(NAME,'LOSE) AND (!*LOSE OR NULL !*DEFN) % THEN RETURN PROGN(LPRIM LIST(NAME, % "Not defined (LOSE Flag)"), % NIL); if (Y := get(Type, 'FunctionDefiningFunction)) then Body := list(Y, Name, VarLis, Body) else if (Y := get(Type, 'ImmediateDefiningFunction)) then return Apply(Y, list(Name, VarLis, Body)) ELSE BODY := LIST('PUTC, MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE LIST('LAMBDA,VARLIS, REFORM BODY)); RETURN IF !*MODE NEQ 'ALGEBRAIC THEN BODY %/ ELSE LIST('PROGN, %/ LIST('FLAG,MKQUOTE LIST NAME,MKQUOTE 'OPFN), %/ BODY) END; DefList('((Expr DE) (FExpr DF) (Macro DM) (NExpr DN) (SMacro DS)), 'FunctionDefiningFunction); put('Emb, 'ImmediateDefiningFunction, 'EmbFn); SYMBOLIC PROCEDURE ParsePROCEDURE1(NAM,ARGS,BODY,ARGTYPE,TYPES); %/ Crude conversion of PROC to PUTD. Need make Etypes and Ftypes %/ Keywords also. BEGIN SCALAR ETYPE,FTYPE; ETYPE:=!*MODE; FTYPE:='EXPR; IF NOT PAIRP TYPES THEN TYPES:=TYPES . NIL; FOR EACH Z IN TYPES DO IF FLAGP(Z,'ETYPE) THEN ETYPE:=Z ELSE IF FLAGP(Z,'FTYPE) THEN FTYPE:=Z; RETURN ParsePROCEDURE2(NAM,ARGS,BODY,FTYPE); END; FLAG('(EXPR FEXPR NEXPR NFEXPR MACRO SMACRO NMACRO EMB),'FTYPE); FLAG('(SYMBOLIC ALGEBRAIC LISP SYSLISP SYSLSP),'ETYPE); SYMBOLIC PROCEDURE ParsePROCEDURE(EFTYPES,Y); BEGIN SCALAR OP1,Z,Z1; OP := OP1 := SCAN(); IF OP1 EQ '!*SEMICOL!* THEN Y := LIST Y ELSE IF INFIXOP OP1 THEN Y := LIST(OP1,Y,PARSE0(8,T)) % Binary as Prefix ELSE Y := REPCOM(Y,PARSE0(8,NIL)); %/ Why 8 IF OP NEQ '!*SEMICOL!* THEN PARERR("PROCEDURE missing terminator after template",T); %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; Z := PARSE0(0,T); IF EQCAR(Z,'DECLARE) THEN <<Z1 := Z; Z := PARSE0(0,T)>>; % repeated DECL? RETURN ParsePROCEDURE1(CAR Y,CDR Y,Z,Z1,EFTYPES); % Nam, args, body, arg decl, E/Fmode END; % ***** Left and Right Parentheses Handling *****; DEFINEROP('!*LPAR!*,NIL,ParseLPAR); DEFINEBOP('!*RPAR!*,1,0); SYMBOLIC PROCEDURE ParseLPAR X; BEGIN SCALAR RES; IF X EQ '!*RPAR!* THEN <<OP := X; RES := '!*EMPTY!*>> ELSE RES:= RDRIGHT(2,X); IF OP EQ '!*RPAR!* THEN OP := SCAN() ELSE PARERR("Missing ) after argument list",NIL); RETURN RES END; % ***** Left and Right << and >> Handling *****; DEFINEROP('!*LSQB!*,-2,ParseRSQB); SYMBOLIC PROCEDURE ParseRSQB(X); IF OP EQ '!*RSQB!* THEN <<OP := SCAN(); 'PROGN . REMSEMICOL X>> ELSE PARERR("Missing right >> after Group",NIL); DEFINEBOP('!*RSQB!*,-3,0); %COMMENT ***** [] vector syntax; REMPROP('![,'NEWNAM); REMPROP('!],'NEWNAM); % ***** [] vector syntax; DEFINEBOP('!*LVEC!*,121,6,ParseLVEC); SYMBOLIC PROCEDURE ParseLVEC(X,Y); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,X,Y)>> ELSE PARERR("Missing ] in index expression ",NIL); % INDX is used for both Vectors and Strings in PSL. You will need to % have INDX map to GETV in vanilla Standard Lisp DEFINEBOP('!*RVEC!*,5,7); % ***** Lambda Expression *****; DEFINEROP('LAMBDA,0,ParseLAMBDA); SYMBOLIC PROCEDURE ParseLAMBDA X; LIST('LAMBDA,IF X AND X NEQ '!*EMPTY!* THEN REMCOM X ELSE NIL, PARSE0(6,T)); % ***** Repeat Expression *****; DEFINEROP('REPEAT,4,ParseREPEAT); SYMBOLIC PROCEDURE ParseREPEAT X; LIST('REPEAT,X, IF OP EQ 'UNTIL THEN PARSE0(6,T) ELSE PARERR("REPEAT missing UNTIL clause",T)) ; DEFINEBOP('UNTIL,3,6); % ***** While Expression *****; DEFINEROP('WHILE,4, ParseWHILE); SYMBOLIC PROCEDURE ParseWHILE X; LIST('WHILE,X, IF OP EQ 'DO THEN PARSE0(6,T) ELSE PARERR("WHILE missing DO clause",T)) ; DEFINEBOP('DO,3,6); % ***** Declare Expression *****; DEFINEROP('DECLARE,2,ParseDECL); DEFINEROP('DCL,2,ParseDECL); SYMBOLIC PROCEDURE ParseDECL X; BEGIN SCALAR Y,Z; A: IF OP NEQ '!*COLON!* THEN PARERR("DECLARE needs : before mode",T); IF (Z := SCAN()) MEMQ '(INTEGER REAL SCALAR) THEN OP := SCAN() ELSE Z := PARSE0(6,NIL); Y := ACONC(Y,Z . REMCOM X); IF OP EQ '!*SEMICOL!* THEN RETURN 'DECLARE . Y ELSE IF OP NEQ '!*COMMA!* THEN PARERR("DECLAREd variables separated by ,",T); X := PARSE0(2,T); GO TO A END; SYMBOLIC FEXPR PROCEDURE DECLARE U; %to take care of top level declarations; <<LPRIM "Declarations are not permitted at the top level"; NMODESTAT U>>; % ***** For Expression *****; DEFINEROP('FOR,NIL,ParseFOR); DEFINEBOP('STEP,3,6); DEFINEBOP('SUM,3,6); DEFINEBOP('PRODUCT,3,6); SYMBOLIC PROCEDURE ParseFOR X; BEGIN SCALAR INIT,STP,UNTL,ACTION,ACTEXPR; IF X EQ 'EACH THEN RETURN ParseFOREACH SCAN() ELSE IF X EQ 'ALL THEN RETURN ParseFORALL PARSE0(4,T) ELSE IF (OP := SCAN()) EQ 'SETQ THEN INIT := PARSE0(6,T) ELSE PARERR("FOR missing loop VAR assignment",T); IF OP EQ '!*COLON!* THEN <<STP := 1; OP := 'UNTIL>> ELSE IF OP EQ 'STEP THEN STP := PARSE0(6,T) ELSE PARERR("FOR missing : or STEP clause",T); IF OP EQ 'UNTIL THEN UNTL := PARSE0(6,T) ELSE PARERR("FOR missing UNTIL clause",T); ACTION := OP; IF ACTION MEMQ '(DO SUM PRODUCT) THEN ACTEXPR := PARSE0(6,T) ELSE PARERR("FOR missing action keyword",T); RETURN LIST('FOR, LIST('FROM,X,INIT,UNTL,STP), LIST(ACTION,ACTEXPR)) END; % ***** Foreach Expression *****; DEFINEROP('FOREACH,NIL,ParseFOREACH); DEFINEBOP('COLLECT,3,6); DEFINEBOP('CONC,3,6); DEFINEBOP('JOIN,3,6); SYMBOLIC PROCEDURE ParseFOREACH X; BEGIN SCALAR L,INON,ACTION; IF NOT ((INON := SCAN()) EQ 'IN OR INON EQ 'ON) THEN PARERR("FOR EACH missing iterator clause",T); L := PARSE0(6,T); IF NOT ((ACTION := OP) MEMBER '(DO COLLECT CONC JOIN)) THEN PARERR("FOR EACH missing action clause",T); RETURN LIST('FOREACH,X,INON,L,ACTION,PARSE0(6,T)) END; % ***** Let Expression *****; DEFINEBOP('LET,1,0,ParseLET); DEFINEROP('LET,0,ParseLET(NIL . NIL,X) ); DEFINEBOP('CLEAR,0,1,ParseCLEAR); DEFINEROP('CLEAR,0,ParseCLEAR(NIL . NIL,X)); DEFINEBOP('SUCH,3,6); SYMBOLIC PROCEDURE ParseLET(X,Y); ParseLET1(X,Y,NIL); SYMBOLIC PROCEDURE ParseCLEAR(X,Y); ParseLET1(X,Y,T); SYMBOLIC PROCEDURE ParseLET1(X,Y,Z); LIST('LET!*,CAR X,REMCOM Y,CDR X,NIL,Z); SYMBOLIC PROCEDURE ParseFORALL X; BEGIN SCALAR BOOL; IF OP EQ 'SUCH THEN IF SCAN() EQ 'THAT THEN BOOL := PARSE0(6,T) ELSE PARERR("FOR ALL missing SUCH THAT clause",T); IF NOT OP MEMQ '(LET CLEAR) THEN PARERR("FOR ALL missing ACTION",T); RETURN REMCOM X . BOOL END; % ******** Standard Qoted LIST collectors SYMBOLIC PROCEDURE RLISF(U,V,W); %. Used to Collect a list of IDs to %. FLAG with Something BEGIN V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; RETURN FLAG(V,U) END; SYMBOLIC PROCEDURE FLAGOP U; %. Declare U as Flagger RLISTAT(U,'FLAGOP); SYMBOLIC PROCEDURE RLISTAT(OPLIST,B); %. Declare els of OPLIST to be RLIS FOR EACH U IN OPLIST DO DEFINEROPX LIST(MKQUOTE U,NIL, LIST(IF B EQ 'FLAGOP THEN 'RLISF ELSE 'RLIS1, MKQUOTE U,'X,MKQUOTE B)); SYMBOLIC PROCEDURE RLIS1(U,V,W); %. parse LIST of args, maybe quoted % U=funcname, V=following Phrase, W=arg treatment BEGIN IF V EQ '!*SEMICOL!* THEN RETURN <<OP := V; IF W = 'NOQUOTE THEN LIST U ELSE LIST(U, NIL) >> ELSE V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; IF W EQ 'IO THEN V := MAPCAR(V,FUNCTION (LAMBDA J; NEWMKFIL J)); RETURN IF W EQ 'NOQUOTE THEN U . V ELSE LIST(U,MKQUOTLIST V) END; % ***** Parsing Rules For Various IO Expressions *****; RLISTAT('(IN OUT SHUT),'NOQUOTE); RLISTAT('(TR UNTR BR UNBR),'NOQUOTE); % for mini-trace in PSL RLISTAT('(LOAD HELP), 'NOQUOTE); FLAG('(IN OUT SHUT ON OFF TR UNTR UNTRST TRST),'NOCHANGE); % No REVAL of args DEFINEROP('FSLEND,NIL,ESTAT('FasLEND)); DEFINEROP('FaslEND,NIL,ESTAT('FaslEND)); RLISTAT('(WRITE),'NOQUOTE); RLISTAT('(ARRAY),1); % 2.11.3 ON/OFF STATEMENTS RLISTAT('(ON OFF), 'NOQUOTE); % ***** Parsing Rules for INTEGER/SCALAR/REAL *****; % These will eventually be removed in favor of DECLARE; DEFINEROP('INTEGER,0,ParseINTEGER); SYMBOLIC PROCEDURE ParseINTEGER X; LIST('DECLARE,REPCOM('INTEGER,X)); DEFINEROP('REAL,0,ParseREAL); SYMBOLIC PROCEDURE ParseREAL X; LIST('DECLARE,REPCOM('REAL,X)); DEFINEROP('SCALAR,0,ParseSCALAR); SYMBOLIC PROCEDURE ParseSCALAR X; LIST('DECLARE,REPCOM('SCALAR,X)); %/ Cuase problems in INTEGER procedure foo;... SYMBOLIC PROCEDURE COMM1 U; %. general Comment Parser BEGIN IF U EQ 'END THEN SCAN(); A: IF CURSYM!* EQ '!*SEMICOL!* OR U EQ 'END AND CURSYM!* MEMQ '(END ELSE UNTIL !*RPAR!* !*RSQB!*) THEN RETURN NIL; SCAN(); GOTO A; END; SYMBOLIC PROCEDURE ESTAT(FN); %. returns (FN), dropping till semicol ; BEGIN WHILE CURSYM!* NEQ '!*SEMICOL!* DO SCAN(); OP := '!*SEMICOL!*; RETURN LIST(FN); END; SYMBOLIC PROCEDURE ENDSTAT; %This procedure can also be used for any key-words which take no %arguments; BEGIN SCALAR X; X := OP; COMM1 'END; OP := '!*SEMICOL!*; RETURN LIST X END; % Some useful ESTATs: DEFINEROP('QUIT,NIL,ESTAT('QUIT)); DEFINEROP('PAUSE,NIL,ESTAT('PAUSE)); DEFINEROP('CONT,NIL,ESTAT('CONT)); DEFINEROP('RECLAIM,NIL,ESTAT('RECLAIM)); DEFINEROP('RETRY,NIL,ESTAT('RETRY)); DEFINEROP('SHOWTIME,NIL,ESTAT('SHOWTIME)); FLAG('(FSLEND CONT RECLAIM RETRY SHOWTIME QUIT PAUSE),'OPFN); % Symbolic OPS, or could use NOCHANGE RLISTAT('(FLAGOP),1); CommentOutCode << SYMBOLIC PROCEDURE INFIX X; % Makes Left ASSOC, not like CONS FOR EACH Y IN X DO DEFINEBOPX LIST(MKQUOTE Y,8,9,NIL); >>; FLAG('(NEWTOK),'EVAL); SYMBOLIC PROCEDURE PRECEDENCE U; PRECSET(CAR U,CADR U); SYMBOLIC PROCEDURE PRECSET(U,V); BEGIN SCALAR Z; IF NULL (Z := INFIXOP V) OR NULL (Z := CDR Z) THEN REDERR LIST(V,"NOT INFIX") ELSE DEFINEBOPX LIST(MKQUOTE U,CAR Z,CADR Z,NIL) END; RLISTAT('(INFIX PRECEDENCE),3); REMPROP('SHOWTIME,'STAT); %********************************************************************* % DEFINE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseDEFINE(X); % X is following Token BEGIN SCALAR Y,Z; B: IF X EQ '!*SEMICOL!* THEN RETURN <<OP:='!*SEMICOL!*; MKPROG(NIL,Z)>> ELSE IF X EQ '!*COMMA!* THEN <<X:=SCAN(); %/ Should use SCAN0 GO TO B>> ELSE IF NOT IDP X THEN GO TO ER; Y := SCAN(); IF NOT (Y EQ 'EQUAL) THEN GO TO ER; Z := ACONC(Z,LIST('PUT,MKQUOTE X,MKQUOTE 'NEWNAM, MKQUOTE PARSE0(6,T))); % So doesnt include , X := CURSYM!*; GO TO B; ER: SYMERR('DEFINE,T) END; DEFINEROP('DEFINE,NIL,ParseDEFINE); FLAG('(DEFINE),'EVAL); %********************************************************************* % 3.2.4 WRITE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseWRITE(X); BEGIN SCALAR Y,Z; X := REMCOM XREAD1 'LAMBDA; A: IF NULL X THEN RETURN MKPROG(NIL,'(TERPRI) . Y); Z := LIST('PRIN2,CAR X); IF NULL CDR X THEN Z := LIST('RETURN,Z); B: Y := ACONC(Y,Z); X := CDR X; GO TO A; END; DEFINEROP('WRITE,NIL,ParseWRITE); %********************************************************************* % VARIOUS DECLARATIONS %********************************************************************; SYMBOLIC PROCEDURE ParseOPERATOR(X); BEGIN SCALAR Y; Y := REMCOM PARSE0(0,NIL); RETURN IF !*MODE EQ 'SYMBOLIC THEN MKPROG(NIL,LIST LIST('FLAG,MKQUOTE Y,MKQUOTE 'OPFN)) ELSE IF X NEQ 'OPERATOR THEN IF EQCAR(CAR Y,'PROG) THEN CAR Y ELSE X . MAPCAR(LIST Y,FUNCTION MKARG) ELSE IF KEY!* NEQ 'OPERATOR AND GET(KEY!*,'FN) THEN (LAMBDA K; MKPROG(NIL,MAPCAR(Y,FUNCTION (LAMBDA J; LIST('FLAG,LIST('LIST,MKQUOTE J), K,K))))) MKQUOTE GET(KEY!*,'FN) ELSE MKPROG(NIL, LIST LIST('OPERATOR,MKQUOTE Y)) END; SYMBOLIC PROCEDURE OPERATOR U; MAPCAR(U,FUNCTION MKOP); DEFINEROP('OPERATOR,NIL,ParseOPERATOR); %. Diphthongs and READtable Changes Symbolic Procedure ChangeCharType(TBL,Ch,Ty); %. Set Character type begin scalar IDNum; If IDP Ch and (IDNum := ID2Int Ch) < 128 and Numberp Ty and Ty >=0 and Ty <=19 then PutV(TBL,IDNum,Ty) Else Error(99,"Cant Set ReadTable"); end; Symbolic Procedure MakeDiphthong(TBL,DipIndicator,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,DipIndicator, (FollowCh . Diphthong) . GET(StartCh,DipIndicator))>> else Error(99, "Cant Declare Diphthong"); SYMBOLIC PROCEDURE MYNEWTOK(X,REPLACE,PRTCHARS); BEGIN SCALAR Y; PUT(X,'NEWNAM!-OP,REPLACE); IF NULL PRTCHARS THEN Y:=LIST(X,X) ELSE IF IDP PRTCHARS THEN Y:=LIST(PRTCHARS,X) ELSE Y:=PRTCHARS; PUT(REPLACE,'PRTCH,Y); END; MYNEWTOK('!;,'!*SEMICOL!*,NIL)$ MYNEWTOK('!$,'!*SEMICOL!*,NIL)$ MYNEWTOK('!,,'!*COMMA!*,NIL)$ MYNEWTOK('!.,'CONS,NIL)$ MYNEWTOK('!:!=,'SETQ,'! !:!=! )$ MYNEWTOK('!+,'PLUS,'! !+! )$ MYNEWTOK('!-,'DIFFERENCE,'! !-! )$ MYNEWTOK('!*,'TIMES,NIL)$ MYNEWTOK('!/,'QUOTIENT,NIL)$ MYNEWTOK('!*!*,'EXPT,NIL)$ MYNEWTOK('!^,'EXPT,NIL)$ MYNEWTOK('!=,'EQUAL,NIL)$ MYNEWTOK('!:,'!*COLON!*,NIL)$ MYNEWTOK('!(,'!*LPAR!*,NIL)$ MYNEWTOK('!),'!*RPAR!*,NIL)$ MYNEWTOK('!{,'!*LSQB!*,NIL)$ MYNEWTOK('!},'!*RSQB!*,NIL)$ MYNEWTOK('!<!<,'!*LSQB!*,NIL)$ MYNEWTOK('!>!>,'!*RSQB!*,NIL)$ MYNEWTOK('![,'!*LVEC!*,NIL)$ MYNEWTOK('!],'!*RVEC!*,NIL)$ MYNEWTOK('!<,'LESSP,NIL)$ MYNEWTOK('!<!=,'LEQ,NIL)$ MYNEWTOK('!>!=,'GEQ,NIL)$ MYNEWTOK('!>,'GREATERP,NIL)$ fluid '(RLispScanTable!* RLispReadScanTable!*); RLispReadScanTable!* := ' [17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 LispDiphthong]; RLispScanTable!* := TotalCopy RLispReadScanTable!*; PutV(RLispScanTable!*, 128, 'RLISPDIPHTHONG); ChangeCharType(RLispScanTable!*, '!-, 11); ChangeCharType(RLispScanTable!*, '!+, 11); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!:,'!=,'!:!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!=,'!<!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!=,'!>!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!<,'!<!< ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!>,'!>!> ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!*,'!*,'!*!* ); Symbolic Procedure XReadEof(Channel,Ef); if !*InsideStructureRead then StdError BldMsg("Unexpected EOF while parsing on channel %r", Channel) else Throw('!$ERROR!$, list !$EOF!$); % embarrasingly gross kludge Put(Int2ID char EOF, 'RlispReadMacro, 'XReadEOF); Symbolic Procedure RatomHOOK(); %. To get READ MACRO', EG EOF ChannelReadTokenWithHooks IN!*; lisp procedure RlispChannelRead Channel; %. Parse S-expression from channel begin scalar CurrentScanTable!*, CurrentReadMacroIndicator!*, CurrentDiphthongIndicator!*; CurrentScanTable!* := RLispReadScanTable!*; CurrentReadMacroIndicator!* := 'LispReadMacro; CurrentDiphthongIndicator!* := 'LispDiphthong; return ChannelReadTokenWithHooks Channel; end; lisp procedure RlispRead(); %. Parse S-expr from current input RlispChannelRead IN!*; END; |
Added psl-1983/util/rlisp-support.red version [d930d8e40c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>RLISP-SUPPORT.RED.8, 13-Oct-82 10:21:02, Edit by BENSON % !*INT is globally T % <PSL.UTIL>RLISP-SUPPORT.RED.5, 5-Oct-82 11:05:30, Edit by BENSON % Changed SaveSystem to 3 arguments % <PSL.UTIL>RLISP-SUPPORT.RED.3, 20-Sep-82 11:57:21, Edit by BENSON % Added Begin1 and BeginRlisp to IgnoredInBacktrace!* CompileTime REMPROP('SHOWTIME,'STAT); %********************************************************************* % RLISP and REDUCE Support Code for NEW-RLISP / On PSL %********************************************************************; GLOBAL '(FLG!*); GLOBAL '(BLOCKP!* CMSG!* ERFG!* INITL!* LETL!* PRECLIS!* VARS!* !*FORCE CLOC!* !*DEMO !*QUIET OTIME!* !*SLIN LREADFN!* TSLIN!* !*NAT NAT!*!* CRCHAR!* IFL!* IPL!* KEY!* KEY1!* OFL!* OPL!* PROGRAM!* PROGRAML!* SEMIC!* !*OUTPUT EOF!* TECHO!* !*INT !*MODE !*CREF !*MSG !*PRET !*EXTRAECHO); FLUID '(!*DEFN !*ECHO DFPRINT!* !*TIME !*BACKTRACE CURSYM!*); % These global variables divide into two classes. The first %class are those which must be initialized at the top level of the %program. These are as follows; BLOCKP!* := NIL; %keeps track of which block is active; CMSG!* := NIL; %shows that continuation msg has been printed; EOF!* := NIL; %flag indicating an end-of-file; ERFG!* := NIL; %indicates that an input error has occurred; INITL!* := '(BLOCKP!* VARS!*); %list of variables initialized in BEGIN1; KEY!* := 'SYMBOLIC; %stores first word read in command; LETL!* := NIL; %used in algebraic mode for special delimiters; LREADFN!* := NIL; %used to define special reading function; %OUTL!* := NIL; %storage for output of input line; PRECLIS!*:= '(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ LESSP PLUS DIFFERENCE TIMES QUOTIENT EXPT CONS); %precedence list of infix operators; TECHO!* := NIL; %terminal echo status; VARS!* := NIL; %list of current bound variables during parse; !*BACKTRACE := NIL; %if ON, prints a LISP backtrace; !*CREF := NIL; %used by cross-reference program; !*DEMO := NIL; % causes a PAUSE (READCH) in COMMAND loop !*ECHO := NIL; %indicates echoing of input; !*FORCE := NIL; %causes all macros to expand; !*INT := T; % system is interactive %!*LOSE := T; %determines whether a function flagged LOSE %is defined; %!*MSG:=NIL; %flag to indicate whether messages should be %printed; !*NAT := NIL; %used in algebraic mode to denote 'natural' %output. Must be on in symbolic mode to %ensure input echoing; NAT!*!* := NIL; %temporary variable used in algebraic mode; !*OUTPUT := T; %used to suppress output; !*SLIN := NIL; %indicates that LISP code should be read; !*TIME := NIL; %used to indicate timing should be printed; % The second class are those global variables which are %initialized within some function, although they do not appear in that %function's variable list. These are; % CRCHAR!* next character in input line % CURSYM!* current symbol (i. e. identifier, parenthesis, % delimiter, e.t.c,) in input line % FNAME!* name of a procedure being read % FTYPES!* list of regular procedure types % IFL!* input file/channel pair - set in BEGIN to NIL % IPL!* input file list- set in BEGIN to NIL % KEY1!* current key-word being analyzed - set in RLIS1; % NXTSYM!* next symbol read in TOKEN % OFL!* output file/channel pair - set in BEGIN to NIL % OPL!* output file list- set in BEGIN to NIL % PROGRAM!* current input program % PROGRAML!* stores input program when error occurs for a % later restart % SEMIC!* current delimiter character (used to decide % whether to print result of calculation) % TTYPE!* current token type; % WS used in algebraic mode to store top level value % !*FORT used in algebraic mode to denote FORTRAN output % !*INT indicates interactive system use % !*MODE current mode of calculation % !*PRET indicates REDUCE prettyprinting of input; fluid '(IgnoredInBacktrace!*); IgnoredInBacktrace!* := Append(IgnoredInBacktrace!*, '(Begin1 BeginRlisp)); CompileTime flag('(FlagP!*!* CondTerPri LispFileNameP MkFil SetLispScanTable SetRlispScanTable ProgVr), 'InternalFunction); CompileTime << macro procedure PgLine U; % needed for LOCN ''(1 . 1); >>; %********************************************************************* % REDUCE SUPERVISOR %********************************************************************; % The true REDUCE supervisory function is BEGIN, again defined in %the system dependent part of this program. However, most of the work %is done by BEGIN1, which is called by BEGIN for every file %encountered on input; SYMBOLIC PROCEDURE FLAGP!*!*(U,V); IDP U AND FLAGP(U,V); FLUID '(PROMPTSTRING!*); fluid '(STATCOUNTER!*); STATCOUNTER!* := 0; lisp procedure RlispPrompt(); BldMsg("[%w] ", StatCounter!*); put('Symbolic, 'PromptFn, 'RlispPrompt); SYMBOLIC PROCEDURE BEGIN1; BEGIN SCALAR MODE,PARSERR,RESULT,PROMPT,WRKSP,MODEPRINT,PROMPTFN,RESULTL, PROMPTSTRING!*; A0: CURSYM!* := '!*SEMICOL!*; OTIME!* := TIME(); GO TO A1; A: %IF NULL IFL!* AND !*INT % THEN <<%/CRBUFLIS!* := (STATCOUNTER!* . CRBUF!*) . CRBUFLIS!*; % CRBUF!* := NIL>>; A1: IF NULL IFL!* AND !*INT THEN STATCOUNTER!* := STATCOUNTER!* + 1; IF PROMPTFN := GET(!*MODE,'PROMPTFN) THEN PROMPTSTRING!* := APPLY(PROMPTFN,NIL); A2: PARSERR := NIL; % IF !*OUTPUT AND !*INT AND NULL IFL!* AND NULL OFL!* % AND NULL !*DEFN % THEN TERPRI(); IF !*TIME THEN SHOWTIME(); IF TSLIN!* THEN PROGN(!*SLIN := CAR TSLIN!*, LREADFN!* := CDR TSLIN!*, TSLIN!* := NIL); MAPC(INITL!*,FUNCTION SINITL); IF !*INT THEN ERFG!* := NIL; %to make editing work properly; IF CURSYM!* EQ 'END THEN GO TO ND0; PROGRAM!* := ERRORSET('(COMMAND),T,!*BACKTRACE); CONDTERPRI(); IF ATOM PROGRAM!* OR CDR PROGRAM!* THEN GO TO ERR1; PROGRAM!* := CAR PROGRAM!*; IF PROGRAM!* EQ !$EOF!$ THEN GO TO ND1 ELSE IF EQCAR(PROGRAM!*,'!*COMMA!*) THEN GO TO ER ELSE IF CURSYM!* EQ 'END THEN GO TO ND0 ELSE IF EQCAR(PROGRAM!*,'RETRY) THEN PROGRAM!* := PROGRAML!* ;% ELSE IF PROGRAM!* EQ 'ED % THEN PROGN(CEDIT NIL,GO TO A2) % ELSE IF EQCAR(PROGRAM!*,'ED) % THEN PROGN(CEDIT CDR PROGRAM!*,GO TO A2); IF !*DEFN THEN GO TO D; B: %IF !*OUTPUT AND IFL!* AND !*ECHO THEN TERPRI(); RESULTL := ERRORSET(PROGRAM!*,T,!*BACKTRACE); IF ATOM RESULTL OR CDR RESULTL OR ERFG!* THEN GO TO ERR2 ELSE IF !*DEFN THEN GO TO A; RESULT := CAR RESULTL; IF IDP KEY!* AND GET(KEY!*,'STAT) EQ 'MODESTAT THEN MODE := KEY!* ELSE MODE := !*MODE; IF NULL !*OUTPUT OR IFL!* AND !*QUIET THEN GO TO C; IF SEMIC!* EQ '!; THEN << MODEPRINT := GET(MODE,'MODEPRINFN) OR 'PrintWithFreshLine; % IF NOT FLAGP(MODE,'NOTERPRI) THEN % TERPRI(); APPLY(MODEPRINT,RESULTL) >>; C: IF WRKSP := GET(MODE,'WORKSPACE) THEN SET(WRKSP,RESULT); GO TO A; D: IF ERFG!* THEN GO TO A ELSE IF FLAGP!*!*(KEY!*,'IGNORE) OR EQCAR(PROGRAM!*,'QUOTE) THEN GO TO B; IF PROGRAM!* THEN DFPRINT PROGRAM!*; IF FLAGP!*!*(KEY!*,'EVAL) THEN GO TO B ELSE GO TO A; ND0:COMM1 'END; ND1: EOF!* := NIL; IF NULL IPL!* %terminal END; THEN BEGIN IF OFL!* THEN WRS NIL; AA: IF NULL OPL!* THEN RETURN(OFL!* := NIL); CLOSE CDAR OPL!*; OPL!* := CDR OPL!*; GO TO AA END; RETURN NIL; ERR1: IF EOF!* OR PROGRAM!* EQ !$EOF!$ THEN GO TO ND1 ELSE IF PROGRAM!* EQ 'EXTRA! BEGIN THEN GO TO A % ELSE IF PROGRAM!* EQ !*!*ESC THEN GO TO A0 ELSE GO TO ER1; ER: LPRIE IF NULL ATOM CADR PROGRAM!* THEN LIST(CAADR PROGRAM!*,"UNDEFINED") ELSE "SYNTAX ERROR"; ER1: PARSERR := T; GO TO ERR3; ERR2: PROGRAML!* := PROGRAM!*; ERR3: RESETPARSER(); % IF NULL ERFG!* OR ERFG!* EQ 'HOLD % THEN LPRIE "ERROR TERMINATION *****"; ERFG!* := T; IF NULL !*INT THEN GO TO E; RESULT := PAUSE1 PARSERR; IF RESULT THEN RETURN NULL EVAL RESULT; ERFG!* := NIL; GO TO A; E: !*DEFN := T; %continue syntax analyzing but not evaluation; !*ECHO := T; IF NULL CMSG!* THEN LPRIE "CONTINUING WITH PARSING ONLY ..."; CMSG!* := T; GO TO A END; SYMBOLIC PROCEDURE CONDTERPRI; !*OUTPUT AND !*ECHO AND !*EXTRAECHO AND (NULL !*INT OR IFL!*) AND NULL !*DEFN AND POSN() > 0 AND TERPRI(); CommentOutCode << SYMBOLIC PROCEDURE ASSGNL U; IF ATOM U OR NULL (CAR U MEMQ '(SETK SETQ SETEL)) THEN NIL ELSE IF ATOM CADR U THEN MKQUOTE CADR U . ASSGNL CADDR U ELSE CADR U . ASSGNL CADDR U; >>; SYMBOLIC PROCEDURE DFPRINT U; %Looks for special action on a form, otherwise prettyprints it; IF DFPRINT!* THEN APPLY(DFPRINT!*,LIST U) % ELSE IF CMSG!* THEN NIL ELSE IF NULL EQCAR(U,'PROGN) THEN << PRINTF "%f"; PRETTYPRINT U >> ELSE BEGIN A: U := CDR U; IF NULL U THEN RETURN NIL; DFPRINT CAR U; GO TO A END; SYMBOLIC PROCEDURE SHOWTIME; BEGIN SCALAR X; X := OTIME!*; OTIME!* := TIME(); X := OTIME!*-X; % TERPRI(); PRIN2 "TIME: "; PRIN2 X; PRIN2T " MS"; END; SYMBOLIC PROCEDURE SINITL U; SET(U,GET(U,'INITL)); FLAG ('(IN OUT ON OFF SHUT),'IGNORE); %********************************************************************* % IDENTIFIER AND RESERVED CHARACTER READING %********************************************************************; % The function TOKEN defined below is used for reading %identifiers and reserved characters (such as parentheses and infix %operators). It is called by the function SCAN, which translates %reserved characters into their internal name, and sets up the output %of the input line. The following definitions of TOKEN and SCAN are %quite general, but also inefficient. THE READING PROCESS CAN OFTEN %BE SPEEDED UP BY A FACTOR OF AS MUCH AS FIVE IF THESE FUNCTIONS %(ESPECIALLY TOKEN) ARE CODED IN ASSEMBLY LANGUAGE; CommentOutCode << SYMBOLIC PROCEDURE PRIN2X U; OUTL!*:=U . OUTL!*; SYMBOLIC PROCEDURE PTOKEN; BEGIN SCALAR X; X := TOKEN(); IF X EQ '!) AND EQCAR(OUTL!*,'! ) THEN OUTL!*:= CDR OUTL!*; %an explicit reference to OUTL!* used here; PRIN2X X; IF NULL ((X EQ '!() OR (X EQ '!))) THEN PRIN2X '! ; RETURN X END; >>; SYMBOLIC PROCEDURE MKEX U; IF NOT(!*MODE EQ 'ALGEBRAIC) OR EQCAR(U,'AEVAL) THEN U ELSE NIL;%APROC(U,'AEVAL); SYMBOLIC PROCEDURE MKSETQ(U,V); LIST('SETQ,U,V); SYMBOLIC PROCEDURE MKVAR(U,V); U; SYMBOLIC PROCEDURE RPLCDX(U,V); IF CDR U=V THEN U ELSE RPLACD(U,V); SYMBOLIC PROCEDURE REFORM U; IF ATOM U OR CAR U EQ 'QUOTE THEN U ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U ELSE IF CAR U EQ 'PROG THEN PROGN(RPLCDX(CDR U,MAPCAR(CDDR U,FUNCTION REFORM)),U) ELSE IF CAR U EQ 'LAMBDA THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U) ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U THEN BEGIN SCALAR X; IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO)) THEN RETURN LIST('FUNCTION,X) ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U THEN REDERR "MACRO USED AS FUNCTION" ELSE RETURN U END % ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM)) ELSE IF ATOM CAR U THEN BEGIN SCALAR X,Y; IF (Y := GETD CAR U) AND CAR Y EQ 'MACRO AND EXPANDQ CAR U THEN RETURN REFORM APPLY(CDR Y,LIST U); X := REFORMLIS CDR U; IF NULL IDP CAR U THEN RETURN(CAR U . X) ELSE IF (NULL !*CREF OR EXPANDQ CAR U) AND (Y:= GET(CAR U,'NMACRO)) THEN RETURN APPLY(Y,IF FLAGP(CAR U,'NOSPREAD) THEN LIST X ELSE X) ELSE IF (NULL !*CREF OR EXPANDQ CAR U) AND (Y:= GET(CAR U,'SMACRO)) THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y) %we could use an atom SUBLIS here (eg, SUBLA); ELSE RETURN PROGN(RPLCDX(U,X),U) END ELSE REFORM CAR U . REFORMLIS CDR U; SYMBOLIC PROCEDURE REFORMLIS U; IF ATOM U THEN U ELSE REFORM CAR U . REFORMLIS CDR U; SYMBOLIC PROCEDURE EXPANDQ U; %determines if macro U should be expanded in REFORM; FLAGP(U,'EXPAND) OR !*FORCE AND NULL FLAGP(U,'NOEXPAND); CommentOutCode << SYMBOLIC PROCEDURE ARRAYP U; GET(U,'ARRAY); SYMBOLIC PROCEDURE GETTYPE U; %it might be better to use a table here for more generality; IF NULL ATOM U THEN 'FORM ELSE IF NUMBERP U THEN 'NUMBER ELSE IF ARRAYP U THEN 'ARRAY ELSE IF GETD U THEN 'PROCEDURE ELSE IF GLOBALP U THEN 'GLOBAL ELSE IF FLUIDP U THEN 'FLUID ELSE IF GET(U,'MATRIX) THEN 'MATRIX ELSE IF GET(U,'SIMPFN) OR GET(U,'MSIMPFN) THEN 'OPERATOR ELSE IF FLAGP(U,'PARM) THEN 'PARAMETER ELSE NIL; SYMBOLIC PROCEDURE GETELS U; GETEL(CAR U . EVLIS(CDR U)); SYMBOLIC PROCEDURE SETELS(U,V); SETEL(CAR U . EVLIS(CDR U),V); >>; %. Top Level Entry Function %. --- Special Flags ----- % !*DEMO - SYMBOLIC PROCEDURE COMMAND; BEGIN SCALAR X,Y; IF !*DEMO AND (X := IFL!*) THEN PROGN(TERPRI(),RDS NIL,READCH(),RDS CDR X); % IF EDIT!* THEN EDITLINE() ELSE IF FLG!* THEN GO TO A; IF !*SLIN THEN <<KEY!* := SEMIC!* := '!;; CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; X := IF LREADFN!* THEN APPLY(LREADFN!*,NIL) ELSE READ(); IF KEY!* EQ '!; THEN KEY!* := IF ATOM X THEN X ELSE CAR X>> ELSE <<SetRlispScanTable(); MakeInputAvailable(); SCAN(); CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; KEY!* := CURSYM!*; X := XREAD1 NIL>>; IF !*PRET THEN PROGN(TERPRI(),RPRINT X); X := REFORM X; IF CLOC!* AND NOT ATOM X AND CAR X MEMQ '(DE DF DM) THEN PUT(CADR X,'LOCN,CLOC!*) ELSE IF CLOC!* AND EQCAR(X,'PROGN) AND CDDR X AND NOT ATOM CADDR X AND CAADDR X MEMQ '(DE DF DM) THEN PUT(CADR CADDR X,'LOCN,CLOC!*); % IF IFL!*='(DSK!: (INPUT . TMP)) AND % (Y:= PGLINE()) NEQ '(1 . 0) % THEN LPL!*:= Y; %use of IN(noargs); IF NULL IDP KEY!* OR NULL(GET(KEY!*,'STAT) EQ 'MODESTAT) AND NULL(KEY!* EQ 'ED) THEN X := MKEX X; A: IF FLG!* AND IFL!* THEN BEGIN CLOSE CDR IFL!*; IPL!* := DELETE(IFL!*,IPL!*); IF IPL!* THEN RDS CDAR IPL!* ELSE RDS NIL; IFL!* := NIL END; FLG!* := NIL; RETURN X END; OFF R2I; SYMBOLIC PROCEDURE RPRINT U; % Autoloading stub << LOAD RPRINT; RPRINT U >>; ON R2I; %********************************************************************* % GENERAL FUNCTIONS %********************************************************************; %SYMBOLIC PROCEDURE MAPC2(U,V); % %this very conservative definition is to allow for systems with % %poor handling of functional arguments, and because of bootstrap- % %ping difficulties; % BEGIN SCALAR X,Y,Z; % A: IF NULL U THEN RETURN REVERSIP Z; % X := CAR U; % Y := NIL; % B: IF NULL X THEN GO TO C; % Y := APPLY(V,LIST CAR X) . Y; % X := CDR X; % GO TO B; % C: U := CDR U; % Z := REVERSIP Y . Z: % GO TO A % END; %********************************************************************* % FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES %********************************************************************; SYMBOLIC PROCEDURE LPRIE U; << ERRORPRINTF("***** %L", U); ERFG!* := T >>; SYMBOLIC PROCEDURE LPRIM U; !*MSG AND ERRORPRINTF("*** %L", U); SYMBOLIC PROCEDURE REDERR U; BEGIN %TERPRI(); LPRIE U; ERROR(99,NIL) END; SYMBOLIC PROCEDURE PROGVR VAR; IF NOT ATOM VAR THEN NIL ELSE IF NUMBERP VAR OR FLAGP(VAR,'SHARE) OR NOT(!*MODE EQ 'ALGEBRAIC) AND FLUIDP VAR THEN T ELSE BEGIN SCALAR X; IF X := GET(VAR,'DATATYPE) THEN RETURN CAR X END; SYMBOLIC PROCEDURE MKARG U; IF NULL U THEN NIL ELSE IF ATOM U THEN IF PROGVR U THEN U ELSE MKQUOTE U ELSE IF CAR U EQ 'QUOTE THEN MKQUOTE U ELSE IF FLAGP!*!*(CAR U,'NOCHANGE) AND NOT FLAGP(KEY1!*,'QUOTE) THEN U ELSE 'LIST . MAPCAR(U,FUNCTION MKARG); SYMBOLIC PROCEDURE MKPROG(U,V); 'PROG . (U . V); CommentOutCode << SYMBOLIC PROCEDURE SETDIFF(U,V); IF NULL V THEN U ELSE SETDIFF(DELETE(CAR V,U),CDR V); SYMBOLIC PROCEDURE REMTYPE VARLIS; BEGIN SCALAR X,Y; VARS!* := SETDIFF(VARS!*,VARLIS); A: IF NULL VARLIS THEN RETURN NIL; X := CAR VARLIS; Y := CDR GET(X,'DATATYPE); IF Y THEN PUT(X,'DATATYPE,Y) ELSE PROGN(REMPROP(X,'DATATYPE),REMFLAG(LIST X,'PARM)); VARLIS := CDR VARLIS; GO TO A END; >>; DEFLIST('((LISP SYMBOLIC)),'NEWNAM); FLAG('(FOR),'NOCHANGE); FLAG('(REPEAT),'NOCHANGE); FLAG('(WHILE),'NOCHANGE); CommentOutCode << COMMENT LISP arrays built with computed index into a vector; % FLUID '(U V X Y N); %/ Fix for MAPC closed compile SYMBOLIC PROCEDURE ARRAY U; FOR EACH X IN U DO BEGIN INTEGER Y; IF NULL CDR X OR NOT IDP CAR X THEN REDERR LIST(X,"CANNOT BECOME AN ARRAY"); Y:=1; FOR EACH V IN CDR X DO Y:=Y*(V+1); PUT(CAR X,'ARRAY,MKVECT(Y-1)); PUT(CAR X,'DIMENSION,ADD1LIS CDR X); END; SYMBOLIC PROCEDURE CINDX!* U; BEGIN SCALAR V; INTEGER N; N:=0; IF NULL(V:=DIMENSION CAR U) THEN REDERR LIST(CAR U,"NOT AN ARRAY"); FOR EACH Y IN CDR U DO <<IF NULL V THEN REDERR LIST(U,"TOO MANY INDICES"); IF Y<0 OR Y>CAR V-1 THEN REDERR LIST(U,"INDEX OUT OF RANGE"); N:=Y+N*CAR V; V:=CDR V>>; IF V THEN REDERR LIST(U,"TOO FEW INDICES"); RETURN N END; %UNFLUID '(U V X Y N); %/ Fix for MAPC closed compile SYMBOLIC PROCEDURE GETEL U; GETV(ARRAYP CAR U,CINDX!* U); SYMBOLIC PROCEDURE SETEL(U,V); PUTV(ARRAYP CAR U,CINDX!* U,V); SYMBOLIC PROCEDURE DIMENSION U; GET(U,'DIMENSION); COMMENT further support for REDUCE arrays; SYMBOLIC PROCEDURE TYPECHK(U,V); BEGIN SCALAR X; IF (X := GETTYPE U) EQ V OR X EQ 'PARAMETER THEN LPRIM LIST(U,"ALREADY DEFINED AS",V) ELSE IF X THEN REDERR LIST(X,U,"INVALID AS",V) END; SYMBOLIC PROCEDURE NUMLIS U; NULL U OR (NUMBERP CAR U AND NUMLIS CDR U); CompileTime REMPROP('ARRAY,'STAT); %for bootstrapping purposes; SYMBOLIC PROCEDURE ARRAYFN U; BEGIN SCALAR X,Y; A: IF NULL U THEN RETURN; X := CAR U; IF ATOM X THEN REDERR "SYNTAX ERROR" ELSE IF TYPECHK(CAR X,'ARRAY) THEN GO TO B; Y := IF NOT(!*MODE EQ 'ALGEBRAIC) THEN !*EVLIS CDR X ELSE REVLIS CDR X; IF NOT NUMLIS Y THEN LPRIE LIST("INCORRECT ARRAY ARGUMENTS FOR",CAR X); ARRAY LIST (CAR X . Y); B: U := CDR U; GO TO A END; SYMBOLIC PROCEDURE ADD1LIS U; IF NULL U THEN NIL ELSE (CAR U+1) . ADD1LIS CDR U; >>; %********************************************************************* %********************************************************************* % REDUCE FUNCTIONS FOR HANDLING INPUT AND OUTPUT OF FILES %********************************************************************* %********************************************************************; GLOBAL '(CONTL!*); MACRO PROCEDURE IN U; LIST('EVIN, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVIN U; BEGIN SCALAR CHAN,ECHO,ECHOP,EXTN,OSLIN,OLRDFN,OTSLIN; ECHOP := SEMIC!* EQ '!;; ECHO := !*ECHO; IF NULL IFL!* THEN TECHO!* := !*ECHO; %terminal echo status; OSLIN := !*SLIN; OLRDFN := LREADFN!*; OTSLIN := TSLIN!*; TSLIN!* := NIL; FOR EACH FL IN U DO <<CHAN := OPEN(FL,'INPUT); IFL!* := FL . CHAN; IPL!* := IFL!* . IPL!*; RDS (IF IFL!* THEN CDR IFL!* ELSE NIL); !*ECHO := ECHOP; !*SLIN := T; IF LISPFILENAMEP FL THEN LREADFN!* := NIL ELSE !*SLIN := OSLIN; BEGIN1(); IF !*SLIN THEN RESETPARSER(); IF CHAN THEN CLOSE CHAN; LREADFN!* := OLRDFN; !*SLIN := OSLIN; IF FL EQ CAAR IPL!* THEN IPL!* := CDR IPL!* ELSE REDERR LIST("FILE STACK CONFUSION",FL,IPL!*)>>; !*ECHO := ECHO; %restore echo status; TSLIN!* := OTSLIN; IF IPL!* AND NULL CONTL!* THEN IFL!* := CAR IPL!* ELSE IFL!* := NIL; RDS(IF IFL!* THEN CDR IFL!* ELSE NIL); RETURN NIL END; CommentOutCode << lisp procedure RedIN F; begin scalar !*Echo, !*Output, !*SLIN, Chan; IPL!* := (IFL!* := (F . (Chan := Open(F, 'Input)))) . IPL!*; RDS Chan; Begin1(); IPL!* := cdr IPL!*; RDS(if not null IPL!* then cdr first IPL!* else NIL); end; >>; SYMBOLIC PROCEDURE LISPFILENAMEP S; %. Look for ".SL" or ".LSP" BEGIN SCALAR C, I, SS; SS := SIZE S; IF SS < 3 THEN RETURN NIL; I := SS; LOOP: IF I < 0 THEN RETURN NIL; IF INDX(S, I) = CHAR '!. THEN GOTO LOOPEND; I := I - 1; GOTO LOOP; LOOPEND: I := I + 1; C := SS - I; IF NOT (C MEMBER '(1 2)) THEN RETURN NIL; C := SUBSEQ(S, I, SS + 1); RETURN IF C MEMBER '("SL" "sl" "LSP" "lsp" "Sl" "Lsp") THEN T ELSE NIL; END; MACRO PROCEDURE OUT U; LIST('EVOUT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVOUT U; %U is a list of one file; BEGIN SCALAR CHAN,FL,X; IF NULL U THEN RETURN NIL ELSE IF CAR U EQ 'T THEN RETURN <<WRS(OFL!* := NIL); NIL>>; FL := MKFIL CAR U; IF NOT (X := ASSOC(FL,OPL!*)) THEN <<CHAN := OPEN(FL,'OUTPUT); OFL!* := FL . CHAN; OPL!* := OFL!* . OPL!*>> ELSE OFL!* := X; WRS CDR OFL!* END; MACRO PROCEDURE SHUT U; LIST('EVSHUT, MKQUOTE CDR U); SYMBOLIC PROCEDURE EVSHUT U; %U is a list of names of files to be shut; BEGIN SCALAR FL,FL1; A: IF NULL U THEN RETURN NIL ELSE IF FL1 := ASSOC((FL := MKFIL CAR U),OPL!*) THEN GO TO B ELSE IF NOT (FL1 := ASSOC(FL,IPL!*)) THEN REDERR LIST(FL,"NOT OPEN"); IF FL1 NEQ IFL!* THEN <<CLOSE CDR FL1; IPL!* := DELETE(FL1,IPL!*)>> ELSE REDERR LIST("CANNOT CLOSE CURRENT INPUT FILE",CAR FL); GO TO C; B: OPL!* := DELETE(FL1,OPL!*); IF FL1=OFL!* THEN <<OFL!* := NIL; WRS NIL>>; CLOSE CDR FL1; C: U := CDR U; GO TO A END; %/ removed STAT property %********************************************************************* % FUNCTIONS HANDLING INTERACTIVE FEATURES %********************************************************************; %GLOBAL Variables referenced in this Section; CONTL!* := NIL; SYMBOLIC PROCEDURE PAUSE; PAUSE1 NIL; SYMBOLIC PROCEDURE PAUSE1 BOOL; BEGIN % IF BOOL THEN % IF NULL IFL!* % THEN RETURN IF !*INT AND GETD 'CEDIT AND YESP 'EDIT!? % THEN CEDIT() ELSE % NIL % ELSE IF GETD 'EDIT1 AND ERFG!* AND CLOC!* AND YESP 'EDIT!? % THEN RETURN <<CONTL!* := NIL; % IF OFL!* THEN <<LPRIM LIST(CAR OFL!*,'SHUT); % CLOSE CDR OFL!*; % OPL!* := DELETE(OFL!*,OPL!*); % OFL!* := NIL>>; % EDIT1(CLOC!*,NIL)>> % ELSE IF FLG!* THEN RETURN (EDIT!* := NIL); IF NULL IFL!* OR YESP 'CONT!? THEN RETURN NIL; CONTL!* := IFL!* . !*ECHO . CONTL!*; RDS (IFL!* := NIL); !*ECHO := TECHO!* END; SYMBOLIC PROCEDURE CONT; BEGIN SCALAR FL,TECHO; IF IFL!* THEN RETURN NIL %CONT only active from terminal; ELSE IF NULL CONTL!* THEN REDERR "NO FILE OPEN"; FL := CAR CONTL!*; TECHO := CADR CONTL!*; CONTL!* := CDDR CONTL!*; IF FL=CAR IPL!* THEN <<IFL!* := FL; RDS IF FL THEN CDR FL ELSE NIL; !*ECHO := TECHO>> ELSE <<EOF!* :=T; LPRIM LIST(FL,"NOT OPEN"); ERROR(99,NIL)>> END; %/DEFLIST ('((PAUSE ENDSTAT) (CONT ENDSTAT) (RETRY ENDSTAT)),'STAT); %/PUT('RETRY,'STAT,'ENDSTAT); FLAG ('(CONT),'IGNORE); %******** "rend" fixups GLOBAL '(!*INT CONTL!* DATE!* !*MODE IMODE!* CRCHAR!* !*SLIN LREADFN!*); REMFLAG('(BEGINRLISP),'GO); %---- Merge into XREAD1 in command ---- % Shouldnt USE Scan in COMMAND, since need change Parser first FLUID '(!*PECHO); Symbolic Procedure XREAD1 x; %. With Catches Begin scalar Form!*; Form!*:=PARSE0(0, NIL); If !*PECHO then PRIN2T LIST("parse>",Form!*); Return Form!* end; lisp procedure Xread X; Begin scalar Form!*; MakeInputAvailable(); Form!*:=PARSE0(0, T); If !*PECHO then PRIN2T LIST("parse>",Form!*); Return Form!* end; !*PECHO:=NIL; SYMBOLIC PROCEDURE BEGINRLISP; BEGIN SCALAR A,B,PROMPTSTRING!*; %/ !*BAKGAG := NIL; !*INT := T; !*ECHO := NIL; A := !*SLIN; !*SLIN := LREADFN!* := NIL; CONTL!* := IFL!* := IPL!* := OFL!* := OPL!* := NIL; !*MODE := IMODE!*; CRCHAR!* := '! ; %/ RDSLSH NIL; %/ SETPCHAR '!*; SetRlispScanTable(); % IF SYSTEM!* NEQ 0 THEN CHKLEN(); IF DATE!* EQ NIL THEN IF A THEN <<PRIN2 "Entering RLISP..."; GO TO B>> ELSE GO TO A; %/ IF FILEP '((REDUCE . INI)) THEN <<IN REDUCE.INI; TERPRI()>>; %/ ERRORSET(QUOTE LAPIN "PSL.INI", NIL, NIL); % no error if not there PRIN2 DATE!*; DATE!* := NIL; % IF SYSTEM!* NEQ 1 THEN GO TO A; % IF !*HELP THEN PRIN2 "For help, type HELP()"; B: TERPRI(); A: BEGIN1(); % TERPRI(); !*SLIN := T; %/ RDSLSH NIL; SetLispScanTable(); PRIN2T "Entering LISP..." END; FLAG('(BEGINRLISP),'GO); PUTD('BEGIN,'EXPR, CDR GETD 'BEGINRLISP); SYMBOLIC PROCEDURE MKFIL U; %converts file descriptor U into valid system filename; U; SYMBOLIC PROCEDURE NEWMKFIL U; %converts file descriptor U into valid system filename; U; lisp procedure SetPChar C; %. Set prompt, return old one begin scalar OldPrompt; OldPrompt := PromptString!*; PromptString!* := if StringP C then C else if IDP C then CopyString ID2String C else BldMsg("%w", C); return OldPrompt; end; COMMENT Some Global Variables required by REDUCE; %GLOBAL '(!*!*ESC); % %!*!*ESC := 'ESC!.NOT!.NEEDED!.NOW; %to make it user settable (used to be a NEWNAM); COMMENT The remaining material in this file introduces extensions or redefinitions of code in the REDUCE source files, and is not really necessary to run a basic system; lisp procedure SetRlispScanTable(); << CurrentReadMacroIndicator!* :='RLispReadMacro; CurrentScanTable!* := RLispScanTable!* >>; lisp procedure SetLispScanTable(); << CurrentReadMacroIndicator!* :='LispReadMacro; CurrentScanTable!* := LispScanTable!* >>; PutD('LispSaveSystem, 'EXPR, cdr GetD 'SaveSystem); lisp procedure SaveSystem(S, F, I); %. Set up for saving EXE file << StatCounter!* := 0; RemD 'Main; Copyd('Main, 'RlispMain); Date!* := BldMsg("%w, %w", S, Date()); LispSaveSystem("PSL", F, I) >>; lisp procedure RlispMain(); << BeginRlisp(); StandardLisp() >>; lisp procedure Rlisp(); % Uses new top loop << SetRlispScanTable(); TopLoop('ReformXRead, 'PrintWithFreshLine, 'Eval, "rlisp", "PSL Rlisp") >>; lisp procedure ReformXRead(); Reform XRead T; !*RAISE := T; %IF GETD 'ADDSQ THEN IMODE!* := 'ALGEBRAIC ELSE IMODE!* := 'SYMBOLIC; IMODE!* := 'SYMBOLIC; TSLIN!* := NIL; !*MSG := T; END; |
Added psl-1983/util/rlisp.build version [008da78a20].
> > | 1 2 | in "rlisp-parser.red"$ in "rlisp-support.red"$ |
Added psl-1983/util/rlispcomp.sl version [04de8e3ce2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % RLISPCOMP.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 27 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This program reads and interprets % the program command string as a list of source files to be compiled. (CompileTime (load common pathnames)) (load pathnamex parse-command-string get-command-string compiler) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (fluid '(*usermode *redefmsg CurrentReadMacroIndicator* CurrentScanTable*)) (fluid '(*quiet_faslout *WritingFASLFile)) (de rlispcomp () (let ((c-list (parse-command-string (get-command-string))) (*usermode nil) (*redefmsg nil)) (compile-files c-list) ) ) (de compile-files (c-list) (cond ((null c-list) (PrintF "RLisp Compiler%n") (PrintF "Usage: RLISPCOMP source-file ...%n") ) (t (for (in fn c-list) (do (attempt-to-compile-file fn)) ) (quit) ))) (de attempt-to-compile-file (fn) (let* ((form (list 'COMPILE-FILE fn)) (*break NIL) (result (ErrorSet form T NIL)) ) (cond ((FixP result) (if *WritingFASLFile (faslend)) (printf "%n ***** Error during compilation of %w.%n" fn) )) )) (de compile-file (fn) (let ((source-fn (namestring (pathname-set-default-type fn "RED"))) (binary-fn (namestring (pathname-set-type fn "B"))) (*quiet_faslout T) ) (if (not (FileP source-fn)) (printf "Unable to open source file: %w%n" source-fn) % else (printf "%n----- Compiling %w%n" source-fn binary-fn) (faslout (namestring (pathname-without-type binary-fn))) (eval (list 'in source-fn)) % Damn FEXPRs (faslend) (printf "%nDone compiling %w%n%n" source-fn) ))) |
Added psl-1983/util/rprint.build version [3f6c215438].
> | 1 | in "rprint.red"$ |
Added psl-1983/util/rprint.red version [4840e5e9cc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE RPRINT; COMMENT THE STANDARD LISP TO REDUCE PRETTY PRINTER; COMMENT THESE GUYS ARE SET BY THE OLD PARSER AND DO NOT NORMALLY EXIST IN PSL; PUT('EXPT,'OP,'((19 19))); PUT('TIMES,'OP,'((17 17))); PUT('!*SEMICOL!*,'OP,'((-1 0))); PUT('OR,'OP,'((3 3))); PUT('GEQ,'OP,'((11 11))); PUT('NOT,'OP,'(NIL 5)); PUT('RECIP,'OP,'(NIL 18)); PUT('QUOTIENT,'OP,'((18 18))); PUT('MEMQ,'OP,'((7 7))); PUT('MINUS,'OP,'(NIL 16)); PUT('SETQ,'OP,'((2 2))); PUT('GREATERP,'OP,'((12 12))); PUT('MEMBER,'OP,'((6 6))); PUT('AND,'OP,'((4 4))); PUT('CONS,'OP,'((20 20))); PUT('PLUS,'OP,'((15 15))); PUT('EQUAL,'OP,'((8 8))); PUT('LEQ,'OP,'((13 13))); PUT('DIFFERENCE,'OP,'((16 16))); PUT('NEQ,'OP,'((9 9))); PUT('LESSP,'OP,'((14 14))); PUT('!*COMMA!*,'OP,'((5 6))); PUT('EQ,'OP,'((10 10))); FLUID '(PRETOP PRETOPRINF); PRETOP := 'OP; PRETOPRINF := 'OPRINF; FLUID '(COMBUFF); FLUID '(CURMARK BUFFP RMAR !*N); SYMBOLIC PROCEDURE RPRINT U; BEGIN INTEGER !*N; SCALAR BUFF,BUFFP,CURMARK,RMAR,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); RMAR := LINELENGTH NIL; X := GET('!*SEMICOL!*,PRETOP); !*N := 0; MPRINO1(U,LIST(CAAR X,CADAR X)); PRIN2OX ";"; OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE RPRIN1 U; BEGIN SCALAR BUFF,BUFFP,CURMARK,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); X := GET('!*SEMICOL!*,PRETOP); MPRINO1(U,LIST(CAAR X,CADAR X)); OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE MPRINO U; MPRINO1(U,LIST(0,0)); SYMBOLIC PROCEDURE MPRINO1(U,V); BEGIN SCALAR X; IF X := ATSOC(U,COMBUFF) THEN <<FOR EACH Y IN CDR X DO COMPROX Y; COMBUFF := DELETE(X,COMBUFF)>>; IF NUMBERP U AND U<0 AND (X := GET('DIFFERENCE,PRETOP)) THEN RETURN BEGIN SCALAR P; X := CAR X; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; PRINOX U; IF P THEN PRINOX ")" END ELSE IF ATOM U THEN RETURN PRINOX U ELSE IF NOT ATOM CAR U THEN <<CURMARK := CURMARK+1; PRIN2OX "("; MPRINO CAR U; PRIN2OX ")"; OMARK LIST(CURMARK,3); CURMARK := CURMARK-1>> ELSE IF X := GET(CAR U,PRETOPRINF) THEN RETURN BEGIN SCALAR P; P := CAR V>0 AND NOT CAR U MEMQ '(BLOCK PROG QUOTE STRING); IF P THEN PRIN2OX "("; APPLY(X,LIST CDR U); IF P THEN PRIN2OX ")" END ELSE IF X := GET(CAR U,PRETOP) THEN RETURN IF CAR X THEN INPRINOX(U,CAR X,V) ELSE IF CDDR U THEN REDERR "SYNTAX ERROR" ELSE IF NULL CADR X THEN INPRINOX(U,LIST(100,1),V) ELSE INPRINOX(U,LIST(100,CADR X),V) ELSE PRINOX CAR U; IF RLISTATP CAR U THEN RETURN RLPRI(CDR U,V); U := CDR U; IF NULL U THEN PRIN2OX "()" ELSE MPRARGS(U,V) END; SYMBOLIC PROCEDURE MPRARGS(U,V); IF NULL CDR U THEN <<PRIN2OX " "; MPRINO1(CAR U,LIST(100,100))>> ELSE INPRINOX('!*COMMA!* . U,LIST(0,0),V); SYMBOLIC PROCEDURE INPRINOX(U,X,V); BEGIN SCALAR P; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; OMARK '(M U); INPRINO(CAR U,X,CDR U); IF P THEN PRIN2OX ")"; OMARK '(M D) END; SYMBOLIC PROCEDURE INPRINO(OPR,V,L); BEGIN SCALAR FLG,X; CURMARK := CURMARK+2; X := GET(OPR,PRETOP); IF X AND CAR X THEN <<MPRINO1(CAR L,LIST(CAR V,0)); L := CDR L; FLG := T>>; WHILE L DO <<IF OPR EQ '!*COMMA!* THEN <<PRIN2OX ","; OMARKO CURMARK>> ELSE IF OPR EQ 'SETQ THEN <<PRIN2OX " := "; OMARK LIST(CURMARK,1)>> ELSE IF ATOM CAR L OR NOT OPR EQ GET!*(CAAR L,'ALT) THEN <<OMARK LIST(CURMARK,1); OPRINO(OPR,FLG); FLG := T>>; MPRINO1(CAR L,LIST(IF NULL CDR L THEN 0 ELSE CAR V, IF NULL FLG THEN 0 ELSE CADR V)); L := CDR L>>; CURMARK := CURMARK-2 END; SYMBOLIC PROCEDURE OPRINO(OPR,B); (LAMBDA X; IF NULL X THEN <<IF B THEN PRIN2OX " "; PRINOX OPR; PRIN2OX " ">> ELSE PRIN2OX CAR X) GET(OPR,'PRTCH); SYMBOLIC PROCEDURE PRIN2OX U; <<RPLACD(BUFFP,EXPLODE2 U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE PRINOX U; <<RPLACD(BUFFP,EXPLODE U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE GET!*(U,V); IF NUMBERP U THEN NIL ELSE GET(U,V); SYMBOLIC PROCEDURE OMARK U; <<RPLACD(BUFFP,LIST U); BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE OMARKO U; OMARK LIST(U,0); SYMBOLIC PROCEDURE COMPROX U; BEGIN SCALAR X; IF CAR BUFFP = '(0 0) THEN RETURN <<FOR EACH J IN U DO PRIN2OX J; OMARK '(0 0)>>; X := CAR BUFFP; RPLACA(BUFFP,LIST(CURMARK+1,3)); FOR EACH J IN U DO PRIN2OX J; OMARK X END; SYMBOLIC PROCEDURE RLISTATP U; GET(U,'STAT) MEMBER '(ENDSTAT RLIS RLIS2); SYMBOLIC PROCEDURE RLPRI(U,V); IF NULL U THEN NIL ELSE IF NOT CAAR U EQ 'LIST OR CDR U THEN REDERR "RPRINT FORMAT ERROR" ELSE BEGIN PRIN2OX " "; OMARK '(M U); INPRINO('!*COMMA!*,LIST(0,0),RLPRI1 CDAR U); OMARK '(M D) END; SYMBOLIC PROCEDURE RLPRI1 U; IF NULL U THEN NIL ELSE IF EQCAR(CAR U,'QUOTE) THEN CADAR U . RLPRI1 CDR U ELSE IF STRINGP CAR U THEN CAR U . RLPRI1 CDR U ELSE REDERR "RPRINT FORMAT ERROR"; SYMBOLIC PROCEDURE CONDOX U; BEGIN SCALAR X; OMARK '(M U); CURMARK := CURMARK+2; WHILE U DO <<PRIN2OX "IF "; MPRINO CAAR U; OMARK LIST(CURMARK,1); PRIN2OX " THEN "; IF CDR U AND EQCAR(CADAR U,'COND) AND NOT EQCAR(CAR REVERSE CADAR U,'T) THEN <<X := T; PRIN2OX "(">>; MPRINO CADAR U; IF X THEN PRIN2OX ")"; U := CDR U; IF U THEN <<OMARKO(CURMARK-1); PRIN2OX " ELSE ">>; IF U AND NULL CDR U AND CAAR U EQ 'T THEN <<MPRINO CADAR U; U := NIL>>>>; CURMARK := CURMARK-2; OMARK '(M D) END; PUT('COND,PRETOPRINF,'CONDOX); SYMBOLIC PROCEDURE BLOCKOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "BEGIN "; IF CAR U THEN VARPRX CAR U; U := CDR U; OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3); WHILE U DO <<MPRINO CAR U; IF NOT EQCAR(CAR U,'!*LABEL) AND CDR U THEN PRIN2OX "; "; U := CDR U; IF U THEN OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3)>>; OMARK LIST(CURMARK-1,-1); PRIN2OX " END"; CURMARK := CURMARK-2; OMARK '(M D) END; SYMBOLIC PROCEDURE RETOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "RETURN "; OMARK '(M U); MPRINO CAR U; CURMARK := CURMARK-2; OMARK '(M D); OMARK '(M D) END; PUT('RETURN,PRETOPRINF,'RETOX); %SYMBOLIC PROCEDURE VARPRX U; % MAPC(CDR U,FUNCTION (LAMBDA J; % <<PRIN2OX CAR J; % PRIN2OX " "; % INPRINO('!*COMMA!*,LIST(0,0),CDR J); % PRIN2OX "; "; % OMARK LIST(CURMARK,6)>>)); COMMENT a version for the old parser; SYMBOLIC PROCEDURE VARPRX U; BEGIN SCALAR TYP; U := REVERSE U; WHILE U DO <<IF CDAR U EQ TYP THEN <<PRIN2OX ","; OMARKO(CURMARK+1); PRINOX CAAR U>> ELSE <<IF TYP THEN <<PRIN2OX "; "; OMARK '(M D)>>; PRINOX (TYP := CDAR U); PRIN2OX " "; OMARK '(M U); PRINOX CAAR U>>; U := CDR U>>; PRIN2OX "; "; OMARK '(M D) END; PUT('BLOCK,PRETOPRINF,'BLOCKOX); SYMBOLIC PROCEDURE PROGOX U; BLOCKOX(MAPCAR(REVERSE CAR U,FUNCTION (LAMBDA J; J . 'SCALAR)) . LABCHK CDR U); SYMBOLIC PROCEDURE LABCHK U; BEGIN SCALAR X; FOR EACH Z IN U DO IF ATOM Z THEN X := LIST('!*LABEL,Z) . X ELSE X := Z . X; RETURN REVERSIP X END; PUT('PROG,PRETOPRINF,'PROGOX); SYMBOLIC PROCEDURE GOX U; <<PRIN2OX "GO TO "; PRINOX CAR U>>; PUT('GO,PRETOPRINF,'GOX); SYMBOLIC PROCEDURE LABOX U; <<PRINOX CAR U; PRIN2OX ": ">>; PUT('!*LABEL,PRETOPRINF,'LABOX); SYMBOLIC PROCEDURE QUOTOX U; IF STRINGP U THEN PRINOX U ELSE <<PRIN2OX "'"; PRINSOX CAR U>>; SYMBOLIC PROCEDURE PRINSOX U; IF ATOM U THEN PRINOX U ELSE <<PRIN2OX "("; OMARK '(M U); CURMARK := CURMARK+1; WHILE U DO <<PRINSOX CAR U; U := CDR U; IF U THEN <<OMARK LIST(CURMARK,-1); IF ATOM U THEN <<PRIN2OX " . "; PRINSOX U; U := NIL>> ELSE PRIN2OX " ">>>>; CURMARK := CURMARK-1; OMARK '(M D); PRIN2OX ")">>; PUT('QUOTE,PRETOPRINF,'QUOTOX); SYMBOLIC PROCEDURE PROGNOX U; BEGIN CURMARK := CURMARK+1; PRIN2OX "<<"; OMARK '(M U); WHILE U DO <<MPRINO CAR U; U := CDR U; IF U THEN <<PRIN2OX "; "; OMARKO CURMARK>>>>; OMARK '(M D); PRIN2OX ">>"; CURMARK := CURMARK-1 END; PUT('PROG2,PRETOPRINF,'PROGNOX); PUT('PROGN,PRETOPRINF,'PROGNOX); SYMBOLIC PROCEDURE REPEATOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "REPEAT "; MPRINO CAR U; PRIN2OX " UNTIL "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('REPEAT,PRETOPRINF,'REPEATOX); SYMBOLIC PROCEDURE WHILEOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "WHILE "; MPRINO CAR U; PRIN2OX " DO "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('WHILE,PRETOPRINF,'WHILEOX); SYMBOLIC PROCEDURE PROCOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; IF CADDDR CDR U THEN <<MPRINO CADDDR CDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCOX1(CAR U,CADR U,CADDR U) END; SYMBOLIC PROCEDURE PROCOX1(U,V,W); BEGIN PRINOX U; IF V THEN MPRARGS(V,LIST(0,0)); PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK-1; OMARK '(M D) END; PUT('PROC,PRETOPRINF,'PROCOX); SYMBOLIC PROCEDURE PROCEOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; MPRINO CADR U; PRIN2OX " "; IF NOT CADDR U EQ 'EXPR THEN <<MPRINO CADDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCEOX1(CAR U,CADDDR U,CAR CDDDDR U) END; SYMBOLIC PROCEDURE PROCEOX1(U,V,W); BEGIN PRINOX U; IF V THEN MPRARGS(MAPCAR(V,FUNCTION CAR),LIST(0,0)); %we need to check here for non-default type; PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK -1; OMARK '(M D) END; PUT('PROCEDURE,PRETOPRINF,'PROCEOX); SYMBOLIC PROCEDURE PROCEOX0(U,V,W,X); PROCEOX LIST(U,'SYMBOLIC,V,MAPCAR(W,FUNCTION (LAMBDA J; J . 'SYMBOLIC)),X); SYMBOLIC PROCEDURE DEOX U; PROCEOX0(CAR U,'EXPR,CADR U,CADDR U); PUT('DE,PRETOPRINF,'DEOX); SYMBOLIC PROCEDURE DFOX U; PROCEOX0(CAR U,'FEXPR,CADR U,CADDR U); PUT('DF,PRETOPRINF,'DFOX); SYMBOLIC PROCEDURE DMOX U; PROCEOX0(CAR U,'MACRO,CADR U,CADDR U); PUT('DM,PRETOPRINF,'DMOX); SYMBOLIC PROCEDURE LAMBDOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; PROCOX1('LAMBDA,CAR U,CADR U) END; PUT('LAMBDA,PRETOPRINF,'LAMBDOX); SYMBOLIC PROCEDURE EACHOX U; <<PRIN2OX "FOR EACH "; WHILE CDR U DO <<MPRINO CAR U; PRIN2OX " "; U := CDR U>>; MPRINO CAR U>>; PUT('FOREACH,PRETOPRINF,'EACHOX); COMMENT Declarations needed by old parser; IF NULL GET('!*SEMICOL!*,'OP) THEN <<PUT('!*SEMICOL!*,'OP,'((-1 0))); PUT('!*COMMA!*,'OP,'((5 6)))>>; COMMENT RPRINT MODULE, Page 2; FLUID '(ORIG CURPOS); SYMBOLIC PROCEDURE PRINOS U; BEGIN INTEGER CURPOS; SCALAR ORIG; ORIG := LIST POSN(); CURPOS := CAR ORIG; PRINOY(U,0); TERPRI0X() END; SYMBOLIC PROCEDURE PRINOY(U,N); BEGIN SCALAR X; IF CAR(X := SPACELEFT(U,N)) THEN RETURN PRINOM(U,N) ELSE IF NULL CDR X THEN RETURN IF CAR ORIG<10 THEN PRINOM(U,N) ELSE <<ORIG := 9 . CDR ORIG; TERPRI0X(); RPSPACES2(CURPOS := 9+CADAR U); PRINOY(U,N)>> ELSE BEGIN A: U := PRINOY(U,N+1); IF NULL CDR U OR CAAR U<=N THEN RETURN; TERPRI0X(); RPSPACES2(CURPOS := CAR ORIG+CADAR U); GO TO A END; RETURN U END; SYMBOLIC PROCEDURE SPACELEFT(U,MARK); %U is an expanded buffer of characters delimited by non-atom marks %of the form: '(M ...) or '(INT INT)) %MARK is an integer; BEGIN INTEGER N; SCALAR FLG,MFLG; N := RMAR - CURPOS; U := CDR U; %move over the first mark; WHILE U AND NOT FLG AND N>=0 DO <<IF ATOM CAR U THEN N := N-1 ELSE IF CAAR U EQ 'M THEN NIL ELSE IF MARK>=CAAR U THEN <<FLG := T; U := NIL . U>> ELSE MFLG := T; U := CDR U>>; RETURN ((N>=0) . MFLG) END; SYMBOLIC PROCEDURE PRINOM(U,MARK); BEGIN INTEGER N; SCALAR FLG,X; N := CURPOS; U := CDR U; WHILE U AND NOT FLG DO <<IF ATOM CAR U THEN <<X := PRIN20X CAR U; N := N+1>> ELSE IF CAAR U EQ 'M THEN IF CADAR U EQ 'U THEN ORIG := N . ORIG ELSE ORIG := CDR ORIG ELSE IF MARK>=CAAR U AND NOT(X='!, AND RMAR-N-6>CHARSPACE(U,X,MARK)) THEN <<FLG := T; U := NIL . U>>; U := CDR U>>; CURPOS := N; IF MARK=0 AND CDR U THEN <<TERPRI0X(); TERPRI0X(); ORIG := LIST 0; CURPOS := 0; PRINOY(U,MARK)>>; %must be a top level constant; RETURN U END; SYMBOLIC PROCEDURE CHARSPACE(U,CHR,MARK); %determines if there is space until the next character CHR; BEGIN INTEGER N; N := 0; WHILE U DO <<IF CAR U = CHR THEN U := LIST NIL ELSE IF ATOM CAR U THEN N := N+1 ELSE IF CAR U='(M U) THEN <<N := 1000; U := LIST NIL>> ELSE IF NUMBERP CAAR U AND CAAR U<MARK THEN U := LIST NIL; U := CDR U>>; RETURN N END; SYMBOLIC PROCEDURE RPSPACES2 N; %FOR I := 1:N DO PRIN20X '! ; WHILE N>0 DO <<PRIN20X '! ; N := N-1>>; SYMBOLIC PROCEDURE PRIN2ROX U; BEGIN INTEGER M,N; SCALAR X,Y; M := RMAR-12; N := RMAR-1; WHILE U DO IF CAR U EQ '!" THEN <<IF NOT STRINGSPACE(CDR U,N-!*N) THEN <<TERPRI0X(); !*N := 0>> ELSE NIL; PRIN20X '!"; U := CDR U; WHILE NOT CAR U EQ '!" DO <<PRIN20X CAR U; U := CDR U; !*N := !*N+1>>; PRIN20X '!"; U := CDR U; !*N := !*N+2; X := Y := NIL>> ELSE IF ATOM CAR U AND NOT(CAR U EQ '! AND (!*N=0 OR NULL X OR CDR U AND BREAKP CADR U OR BREAKP X AND NOT Y EQ '!!)) THEN <<Y := X; PRIN20X(X := CAR U); !*N := !*N+1; U := CDR U; IF !*N=N OR !*N>M AND NOT BREAKP CAR U AND NOSPACE(U,N-!*N) THEN <<TERPRI0X(); X := Y := NIL>> ELSE NIL>> ELSE U := CDR U END; SYMBOLIC PROCEDURE NOSPACE(U,N); IF N<1 THEN T ELSE IF NULL U THEN NIL ELSE IF NOT ATOM CAR U THEN NOSPACE(CDR U,N) ELSE IF NOT CAR U EQ '!! AND (CADR U EQ '! OR BREAKP CADR U) THEN NIL ELSE NOSPACE(CDR U,N-1); SYMBOLIC PROCEDURE BREAKP U; U MEMBER '(!< !> !; !: != !) !+ !- !, !' !"); SYMBOLIC PROCEDURE STRINGSPACE(U,N); IF N<1 THEN NIL ELSE IF CAR U EQ '!" THEN T ELSE STRINGSPACE(CDR U,N-1); COMMENT Some interfaces needed; PUT('CONS,'PRTCH,'(! !.! !.)); GLOBAL '(RPRIFN!* RTERFN!*); COMMENT RPRIFN!* allows output from RPRINT to be handled differently, RTERFN!* allows end of lines to be handled differently; SYMBOLIC PROCEDURE PRIN20X U; IF RPRIFN!* THEN APPLY(RPRIFN!*,LIST U) ELSE PRIN2 U; SYMBOLIC PROCEDURE TERPRI0X; IF RTERFN!* THEN APPLY(RTERFN!*,NIL) ELSE TERPRI(); END; |
Added psl-1983/util/set-macros.sl version [05d585cfef].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % SET-MACROS.SL - macros for various flavors of assignments % % Author: Don Morrison % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: Wednesday, 12 May 1982 % Copyright (c) 1981 University of Utah % <PSL.UTIL>SET-MACROS.SL.2, 12-Oct-82 15:53:58, Edit by BENSON % Added IGETV to SETF-SAFE list % Somewhat expanded setf macro. Major difference between this and the builtin % version is that it always returns the RHS, instead of something % indeterminant. Note that the setf-safe flag can be used to indicate that % the assignment function itself returns the "right thing", so setf needn't % do anything special. Also a lot more functions are represented in this % version, including c....r (mostly useful for macros) and list/cons (which % gives a primitive sort of destructuring setf). (defmacro setf u (cond ((atom u) nil) ((atom (cdr u)) (stderror "Odd number of arguments to setf.")) ((atom (cddr u)) (setf2 (car u) (cadr u))) (t `(progn ,@(setf1 u))))) (de setf1 (u) (cond ((atom u) nil) ((atom (cdr u)) (stderror "Odd number of arguments to setf.")) (t (cons (setf2 (car u) (cadr u)) (setf1 (cddr u)))))) (de setf2 (lhs rhs) (if (atom lhs) `(setq ,lhs ,rhs) (cond ((and (idp (car lhs)) (flagp (car lhs) 'setf-safe)) (expand-setf lhs rhs)) ((atom rhs) `(progn ,(expand-setf lhs rhs) ,rhs)) (t `(let ((***SETF-VAR*** ,rhs)) ,(expand-setf lhs '***SETF-VAR***) ***SETF-VAR***))))) (de expand-setf (lhs rhs) (let ((fn (car lhs)) (op)) (cond ((and (idp fn) (setq op (get fn 'assign-op))) `(,op ,@(cdr lhs) ,rhs)) ((and (idp fn) (setq op (get fn 'setf-expand))) (apply op (list lhs rhs))) ((and (idp fn) (setq op (getd fn)) (eqcar op 'macro)) (expand-setf (apply (cdr op) (list lhs)) rhs)) (t (expand-setf (ContinuableError 99 (BldMsg "%r is not a known form for assignment" `(setf ,lhs ,rhs)) lhs) rhs))))) (flag '(getv indx eval value get list cons vector getd igetv) 'setf-safe) (defmacro-no-displace car-cdr-setf (rplacfn pathfn) `#'(lambda (lhs rhs) `(,',rplacfn (,',pathfn ,(cadr lhs)) ,rhs))) (deflist '( (car rplaca) (cdr rplacd) (getv putv) (igetv iputv) (indx setindx) (sub setsub) (eval set) (value set) (get put) (flagp flag-setf) (getd getd-setf) ) 'assign-op) (remprop 'nth 'assign-op) % Remove default version (which is incorrect anyway) (deflist `( (caar ,(car-cdr-setf rplaca car)) (cadr ,(car-cdr-setf rplaca cdr)) (caaar ,(car-cdr-setf rplaca caar)) (cadar ,(car-cdr-setf rplaca cdar)) (caadr ,(car-cdr-setf rplaca cadr)) (caddr ,(car-cdr-setf rplaca cddr)) (caaaar ,(car-cdr-setf rplaca caaar)) (cadaar ,(car-cdr-setf rplaca cdaar)) (caadar ,(car-cdr-setf rplaca cadar)) (caddar ,(car-cdr-setf rplaca cddar)) (caaadr ,(car-cdr-setf rplaca caadr)) (cadadr ,(car-cdr-setf rplaca cdadr)) (caaddr ,(car-cdr-setf rplaca caddr)) (cadddr ,(car-cdr-setf rplaca cdddr)) (cdar ,(car-cdr-setf rplacd car)) (cddr ,(car-cdr-setf rplacd cdr)) (cdaar ,(car-cdr-setf rplacd caar)) (cddar ,(car-cdr-setf rplacd cdar)) (cdadr ,(car-cdr-setf rplacd cadr)) (cdddr ,(car-cdr-setf rplacd cddr)) (cdaaar ,(car-cdr-setf rplacd caaar)) (cddaar ,(car-cdr-setf rplacd cdaar)) (cdadar ,(car-cdr-setf rplacd cadar)) (cdddar ,(car-cdr-setf rplacd cddar)) (cdaadr ,(car-cdr-setf rplacd caadr)) (cddadr ,(car-cdr-setf rplacd cdadr)) (cdaddr ,(car-cdr-setf rplacd caddr)) (cddddr ,(car-cdr-setf rplacd cdddr)) (nth ,#'(lambda (lhs rhs) `(rplaca (pnth ,@(cdr lhs)) ,rhs))) (pnth ,#'expand-pnth-setf) (lastcar ,#'(lambda (lhs rhs) `(rplaca (lastpair ,(cadr lhs)) ,rhs))) (list ,#'list-setf) (cons ,#'cons-setf) (vector ,#'vector-setf) ) 'setf-expand) (fluid '(*setf-debug)) (de expand-pnth-setf (lhs rhs) (let ((L (cadr lhs))(n (caddr lhs))) (cond ((onep n) `(setf ,L ,rhs)) ((fixp n) `(rplacd (pnth ,L (sub1 ,n)) ,rhs)) (t (let ((expnsn (errorset `(setf2 ',L ',rhs) *setf-debug *setf-debug))) (if (atom expnsn) `(rplacd (pnth ,L (sub1 ,n) ,rhs)) `(let ((***PNTH-SETF-VAR*** ,n)) (if (onep ***PNTH-SETF-VAR***) ,(car expnsn) (rplacd (pnth ,L (sub1 ***PNTH-SETF-VAR***)) ,rhs))))))))) (de flag-setf (nam flg val) (cond (val (flag (list nam) flg) t) (t (remflag (list nam) flg) nil))) (de getd-setf (trgt src) (cond % not correct for the parallel case... % ((idp src) (copyd trgt src)) ((or (codep src) (eqcar src 'lambda)) % is this kludge worthwhile? (progn (putd trgt 'expr src) (cons 'expr src))) ((pairp src) (progn (putd trgt (car src) (cdr src)) src)) (t (ContinuableError 99 (bldmsg "%r is not a funtion spec." src) src)))) (de list-setf (lhs rhs) (if (atom rhs) `(progn ,.(destructure-form (cdr lhs) rhs) ,rhs) `(let ((***LIST-SETF-VAR*** ,rhs)) ,.(destructure-form (cdr lhs) '***LIST-SETF-VAR***) ***LIST-SETF-VAR***))) (de cons-setf (lhs rhs) (if (atom rhs) `(progn (setf ,(cadr lhs) (car ,rhs)) (setf ,(caddr lhs) (cdr ,rhs)) ,rhs) `(let ((***CONS-SETF-VAR*** ,rhs)) (setf ,(cadr lhs) (car ***CONS-SETF-VAR***)) (setf ,(caddr lhs) (cdr ***CONS-SETF-VAR***)) ***CONS-SETF-VAR***))) (de vector-setf (lhs rhs) (let ((x (if (atom rhs) rhs '***VECTOR-SETF-VAR***))) (let ((L (for (in u (cdr lhs)) (from i 0) (collect `(setf ,u (getv ,x ,i)))))) (if (atom rhs) `(progn ,.L ,x) `(let ((***VECTOR-SETF-VAR*** ,rhs)) ,.L ,x))))) % Some more useful assignment macros (defmacro push (item stack) `(setf ,stack (cons ,item ,stack))) (defmacro pop (stack . rst) (let ((x `(prog1 (car ,stack) (setf ,stack (cdr ,stack))))) (if rst `(setf ,(car rst) ,x) x))) (defmacro adjoin-to (e s) `(setf ,s (adjoin ,e ,s))) (defmacro adjoinq-to (e s) `(setf ,s (adjoinq ,e ,s))) (defmacro incr (var . rst) `(setf ,var ,(if rst `(plus ,var ,@rst) `(add1 ,var)))) (defmacro decr (var . rst) `(setf ,var ,(if rst `(difference ,var (plus ,@rst)) `(sub1 ,var)))) (defmacro clear L `(setf ,.(foreach u in L conc `(,u nil)))) % Parallel assignment macros (defmacro psetq rst % psetq looks like a multi-arg setq but does its work in parallel. (cond ((null rst) nil) ((cddr rst) `(setq ,(car rst) (prog1 ,(cadr rst) (psetq . ,(cddr rst))))) % the last pair. keep it simple; no superfluous % (prog1 (setq...) (psetq)). ((cdr rst) `(setq . ,rst)) (t (StdError "psetq passed an odd number of arguments")))) (defmacro psetf rst % psetf looks like a multi-arg setf but does its work in parallel. (cond ((null rst) nil) ((cddr rst) `(setf ,(car rst) (prog1 ,(cadr rst) (psetf . ,(cddr rst))))) ((cdr rst) `(setf . ,rst)) (t (StdError "psetf passed an odd number of arguments")))) (defmacro defswitch (nam var . acts) (let ((read-act (if (pairp acts) (car acts) nil)) (set-acts (if (pairp acts) (cdr acts) nil))) (when (null var) (setf var (newid (bldmsg "%w-SWITCH-VAR*" nam)))) `(progn (fluid '(,var)) (de ,nam () (let ((,nam ,var)) ,read-act) ,var) (setf (get ',nam 'assign-op) #'(lambda (,nam) ,@set-acts (setq ,var ,nam))) (flag '(,nam) 'setf-safe)))) |
Added psl-1983/util/setup.sl version [f7518ba214].
> > > > > > > > > | 1 2 3 4 5 6 7 8 9 | (load rlisp) (dskin "patch.sl") (copyd 'list-to-string 'list2string) (load clcomp) ;(setq *install t) ;(setq *traceall t) (dskin "un-rlisp.lsp") (compile '(collect-spelling-and-comments-aux-aux)) (collect-spelling-and-comments "pi:read.red") |
Added psl-1983/util/slow-strings.sl version [4505d0eae4].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SLOW-STRINGS - Useful String Functions (with lots of error checking) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Defines the following functions: % % (string-fetch s i) % (string-store s i ch) % (string-length s) % (string-upper-bound s) % (string-empty? s) % % See FAST-STRINGS for faster (unchecked) compiled versions of these functions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de string-fetch (s i) (cond ((not (StringP s)) (NonStringError s 'String-Fetch)) ((not (FixP i)) (NonIntegerError i 'String-Fetch)) (t (indx s i)) )) (de string-store (s i c) (cond ((not (StringP s)) (NonStringError s 'String-Store)) ((not (FixP i)) (NonIntegerError i 'String-Store)) ((not (FixP c)) (NonCharacterError c 'String-Store)) (t (setindx s i c)) )) (de string-length (s) (cond ((not (StringP s)) (NonStringError s 'String-Length)) (t (Plus2 (size s) 1)) )) (de string-upper-bound (s) (cond ((not (StringP s)) (NonStringError s 'String-Upper-Bound)) (t (size s)) )) (de string-empty? (s) (cond ((not (StringP s)) (NonStringError s 'String-Empty?)) (t (EqN (size s) -1)) )) |
Added psl-1983/util/slow-vectors.sl version [0d5025f39e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % SLOW-VECTORS - Useful Vector Functions (with lots of error checking) % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 September 1982 % % Defines the following functions: % % (vector-fetch v i) % (vector-store v i x) % (vector-size v) % (vector-upper-bound v) % (vector-empty? v) % % See FAST-VECTORS for faster (unchecked) compiled versions of these functions. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de vector-fetch (v i) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Fetch)) ((not (FixP i)) (NonIntegerError i 'Vector-Fetch)) (t (indx v i)) )) (de vector-store (v i x) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Store)) ((not (FixP i)) (NonIntegerError i 'Vector-Store)) (t (setindx v i x)) )) (de vector-size (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Size)) (t (Plus2 (size v) 1)) )) (de vector-upper-bound (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Upper-Bound)) (t (size v)) )) (de vector-empty? (v) (cond ((not (Vectorp v)) (NonVectorError v 'Vector-Empty?)) (t (EqN (size v) -1)) )) |
Added psl-1983/util/sm.build version [608fcdb372].
> | 1 | in "sm.red"$ |
Added psl-1983/util/sm.red version [0b8ca6fee7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % SM.RED - String match to replace find % M.L.G procedure sm(p,s); Sm1(p,0,size(p),s,0,size(s)); procedure sm1(p,p1,p2,s,s1,s2); Begin scalar c; L1: % test Range if p1>p2 then return (if s1>s2 then T else NIL) else if s1>s2 then return NIL; % test if % something if (c:=p[p1]) eq char !% then goto L3; L2: % exact match if c eq s[s1] then <<p1:=p1+1; s1:=s1+1; goto L1>>; return NIL; L3: % special cases p1:=p1+1; if p1>p2 then return stderror "pattern ran out in % case of sm"; c:=p[p1]; if c eq char !% then goto L2; if c eq char !? then <<p1:=p1+1; s1:=s1+1; goto L1>>; if c eq char !* then % 0 or more vs 1 or more return <<while not(c:=sm1(p,p1+1,p2,s,s1,s2)) and s1<=s2 do s1:=s1+1; c>>; Return Stderror Bldmsg(" %% %r not known in sm",int2id c); end; |
Added psl-1983/util/step.build version [d787d9c8db].
> > | 1 2 | CompileTime load(Useful, CLComp); in "step.lsp"$ |
Added psl-1983/util/step.lsp version [712f92701c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; STEP.LSP - Single-step evaluator ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 30 March 1982 ;;; Copyright (c) 1982 University of Utah ;;; #+Tops20 (eval-when (compile eval) ; Needed for PBIN in STEP-GET-CHAR (load monsym)) (imports '(evalhook)) ; Tell the loader that evalhook is needed (defvar step-level 0 "Level of recursion while stepping") (defvar step-form () "Current form being evaluated") (defvar step-pending-forms () "Buffer of forms being evaluated") (defvar abort-step () "Flag to indicate exiting step") (defvar step-dispatch (make-vector 127 t ()) "Dispatch table for character commands") (defvar step-channel () "I/O Channel used for printing truncated forms.") (eval-when (compile eval) ;;;; DEF-STEP-COMMAND - define a character command routine (defmacro def-step-command (char . form) `(vset step-dispatch ,char (function (lambda () ,@form)))) ) ;;;; STEP - user entry point (defun step (form) (let ((step-level 0) (step-pending-forms ()) (abort-step ())) (prog1 (step-eval form) (terpri)))) ;;;; STEP-EVAL - main routine (defun step-eval (step-form) (if abort-step (eval step-form) (let ((step-pending-forms (cons step-form step-pending-forms))) (step-print-form step-form "-> ") (let ((macro-call (macro-p (first step-form)))) (when macro-call (setq step-form (funcall macro-call step-form)) (step-print-form step-form "<->"))) (let ((step-value (let ((step-level (add1 step-level))) (step-command)))) (unless (and abort-step (not (eql abort-step step-level))) (setq abort-step ()) ;; Print the non macro-expanded form (step-print-value (first step-pending-forms) step-value)) step-value)))) ;;;; Control-N - Continue stepping each time (def-step-command #\ (evalhookfn step-form #'step-eval)) ;;;; Space - do not step lower levels (def-step-command #\blank (eval step-form)) ;;;; Control-U - go up to next higher evaluation level (def-step-command #\ (setq abort-step (- step-level 2)) (eval step-form)) ;;;; Control-X - abort stepping entirely (def-step-command #\ (setq abort-step -1) (eval step-form)) ;;;; Control-G - grind the current form (def-step-command #\bell (terpri) (prettyprint (first step-pending-forms)) (step-command)) ;;;; Control-P is the same as Control-G (vset step-dispatch #\ (vref step-dispatch #\bell)) ;;;; Control-R grinds the form in Rlisp syntax (def-step-command #\ (terpri) (rprint (first step-pending-forms)) ; This will only (step-command)) ; work in Rlisp ;;;; Control-E - edit the current form (def-step-command #\ (setq step-form (edit step-form)) (step-command)) ;;;; Control-B - go into a break loop (def-step-command #\ (step-break) (step-command)) ;;;; Control-L redisplay the last 10 pending forms (def-step-command #\ff (display-last-10) (step-command)) ;;;; ? - help (def-step-command #\? (load help) (displayhelpfile 'step) (step-command)) (defun display-last-10 () (display-aux step-pending-forms 10)) (defun display-aux (b n) (let ((step-level (sub1 step-level))) (unless (or (null b) (eql n 0)) (display-aux (rest b) (sub1 n)) (step-print-form (first b) "-> ")))) ;;;; STEP-COMMAND - read a character and dispatch on it (defun step-command () (let ((c (vref step-dispatch (step-get-char)))) (if c (funcall c) (ouch #\bell) (step-command)))) ;;;; STEP-PRINT-FORM - print incoming form with indentation (defun step-print-form (form herald) (terpri) (tab (min step-level 15)) (princ herald) (channelprin1 step-channel form)) ;;;; STEP-PRINT-VALUE - print form and result of evaluation (defun step-print-value (form value) (terpri) (tab (min step-level 15)) (princ "<- ") (channelprin1 step-channel form) (terpri) (tab (+ (min step-level 15) 3)) (prin1 value)) ;;;; STEP-BREAK - errset-protected break loop (defun step-break () (errset (break) ())) ;;;; STEP-GET-CHAR - read a single character #+Tops20 (lap '((*entry step-get-char expr 0) (*move #\? (reg 1)) (pbout) (pbin) (*exit 0))) #-Tops20 (defun step-get-char () (let ((promptstring* "?")) (do ((ch (channelreadchar stdin*) (channelreadchar stdin*))) ((not (eql ch #\eol)) ch)))) ;;;; STEP-PUT-CHAR - prints on current channel, truncates to one line (defun step-put-char (channel ch) (if (not (eql ch #\eol)) (unless (> (posn) 75) (writechar ch)))) (eval-when (load eval) ; Open a special channel (let ((specialwritefunction* #'step-put-char) (specialreadfunction* #'writeonlychannel) (specialclosefunction* #'illegalstandardchannelclose)) (setq step-channel (open "" 'special))) ) |
Added psl-1983/util/string-input.sl version [b5488c07e0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Input from strings %%% Cris Perdue %%% 12/1/82 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (compiletime (load if fast-int)) (fluid '(channel-string channel-string-pos)) %%% Takes two arguments: a string and a function. %%% The function must take 1 argument. With-input-from-string %%% will call the function and pass it a channel number. If the %%% function takes input from the channel (which is the point of %%% all this), it will receive successive characters from the %%% string as its input. %%% %%% This is not currently unwind-protected. (defun with-input-from-string (str fn) (let ((specialreadfunction* 'string-readchar) (specialwritefunction* 'readonlychannel) (specialclosefunction* 'null) (channel-string str) (channel-string-pos 0)) (let ((chan (open "" 'special)) value) (setq value (apply fn (list chan))) (close chan) value))) %%% This is similar to with-input-from-string, but the string %%% passed in is effectively padded on the right with a single %%% blank. No storage allocation is performed to give this %%% effect. (defun with-input-from-terminated-string (str fn) (let ((specialreadfunction* 'string-readchar-terminated) (specialwritefunction* 'readonlychannel) (specialclosefunction* 'null) (channel-string str) (channel-string-pos 0)) (let ((chan (open "" 'special)) value) (setq value (apply fn (list chan))) (close chan) value))) %%% Reads from the string. The string is effectively padded with %%% a blank at the end so if the expression in the string is for %%% example a single token, it need not be followed by a terminator. (defun string-read (str) (with-input-from-terminated-string str 'channelread)) %%% Reads a single token from the string using channelreadtoken. %%% The string need contain no terminator character; a blank is %%% provided if necessary by string-readtoken. (defun string-readtoken (str) (with-input-from-terminated-string str 'channelreadtoken)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Internal routines. (defun string-readchar (chan) (if (> channel-string-pos (size channel-string)) then $eof$ else (prog1 (indx channel-string channel-string-pos) (setq channel-string-pos (+ channel-string-pos 1))))) %%% Includes hack that tacks on a blank for termination of READ %%% and friends. (defun string-readchar-terminated (chan) (if (<= channel-string-pos (size channel-string)) then (prog1 (indx channel-string channel-string-pos) (setq channel-string-pos (+ channel-string-pos 1))) elseif (= channel-string-pos (+ 1 (size channel-string))) then (prog1 32 % Blank (setq channel-string-pos (+ channel-string-pos 1))) else $eof$)) |
Added psl-1983/util/string-search.sl version [143a9308fc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% STRING-SEARCH %%% %%% Author: Cris Perdue %%% 11/23/82 %%% %%% General-purpose searches for substring. Case is important. %%% If the target is found, the index in the domain of the %%% leftmost character of the leftmost match is returned, %%% otherwise NIL. %%% %%% (STRING-SEARCH TARGET DOMAIN). %%% %%% If passed two strings, Common LISP "search" will give the %%% same results. %%% %%% (STRING-SEARCH-FROM TARGET DOMAIN START) %%% %%% Like string-search, but the search effectively starts at index %%% START in the domain. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% Implementation note: In both of these, the value of the first %%% character of the target is precomputed and it is tested against %%% characters of the domain separately from the other characters of %%% the target. (compiletime (load fast-int if)) (defun string-search (target domain) (if (not (and (stringp target) (stringp domain))) then (error 0 "Arg to string-search not a string")) (let* ((s (isizes target)) (m (- (isizes domain) s))) (if (= s -1) then 0 else (let ((c (igets target 0))) (for (from i 0 m) (do (if (eq (igets domain i) c) then (if (for (from u 1 s) (from v (+ i 1)) (do (if (neq (igets target u) (igets domain v)) then (return nil))) (finally (return t))) then (return i))))))))) %%% Like string-search, but takes an explicit starting index %%% in the domain string. (defun string-search-from (target domain start) (if (not (and (stringp target) (stringp domain))) then (error 0 "Arg to substring-search not a string")) (let* ((s (isizes target)) (m (- (isizes domain) s))) (if (= s -1) then start else (let ((c (igets target 0))) (for (from i start m) (do (if (eq (igets domain i) c) then (if (for (from u 1 s) (from v (+ i 1)) (do (if (neq (igets target u) (igets domain v)) then (return nil))) (finally (return t))) then (return i))))))))) |
Added psl-1983/util/strings.build version [160fbec5df].
> > | 1 2 | CompileTime load(SysLisp, Useful, CLComp); in "strings.lsp"$ |
Added psl-1983/util/strings.lsp version [e9a20ea9cf].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;; ;;; STRINGS.LSP - Common Lisp string operations ;;; ;;; Author: Eric Benson ;;; Symbolic Computation Group ;;; Computer Science Dept. ;;; University of Utah ;;; Date: 7 April 1982 ;;; Copyright (c) 1982 University of Utah ;;; (eval-when (load) (imports '(chars))) ; Uses the CHARS module (eval-when (compile) ; Local functions (localf string-equal-aux string<-aux string<=-aux string<>-aux string-lessp-aux string-not-greaterp-aux string-not-equal-aux string-trim-left-index string-trim-right-index bag-element bag-element-aux string-concat-aux)) ;;;; CHAR - fetch a character in a string ;(defun char (s i) ; not defined because CHAR means something else in PSL ; (elt (stringify s) i)) ;;;; RPLACHAR - store a character in a string (defun rplachar (s i x) (setelt s i x)) ;;;; STRING= - compare two strings (substring options not implemented) (fset 'string= (fsymeval 'eqstr)) ; Same function in PSL ;;;; STRING-EQUAL - compare two strings, ignoring case, bits and font (defun string-equal (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (or (eq s1 s2) (let ((len1 (string-length s1)) (len2 (string-length s2))) (and (eql len1 len2) (string-equal-aux s1 s2 len1 0))))) (defun string-equal-aux (s1 s2 len i) (or (eql len i) (and (char-equal (char s1 i) (char s2 i)) (string-equal-aux s1 s2 len (add1 i))))) ;;;; STRING< - lexicographic comparison of strings (defun string< (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string<-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string<-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((eql i len2) ()) ((char= (char s1 i) (char s2 i)) (string<-aux s1 s2 len1 len2 (add1 i))) ((char< (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING> - lexicographic comparison of strings (defun string> (s1 s2) (string< s2 s1)) ;;;; STRING<= - lexicographic comparison of strings (defun string<= (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string<=-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string<=-aux (s1 s2 len1 len2 i) (cond ((eql i len1) i) ((eql i len2) ()) ((char= (char s1 i) (char s2 i)) (string<=-aux s1 s2 len1 len2 (add1 i))) ((char< (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING>= - lexicographic comparison of strings (defun string>= (s1 s2) (string<= s2 s1)) ;;;; STRING<> - lexicographic comparison of strings (defun string<> (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (let ((len1 (string-length s1)) (len2 (string-length s2))) (if (<= len1 len2) (string<>-aux s1 s2 len1 len2 0) (string<>-aux s2 s1 len2 len1 0)))) (defun string<>-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((char= (char s1 i) (char s2 i)) (string<>-aux s1 s2 len1 len2 (add1 i))) (t i))) ;;;; STRING-LESSP - lexicographic comparison of strings (defun string-lessp (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string-lessp-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string-lessp-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((eql i len2) ()) ((char-equal (char s1 i) (char s2 i)) (string-lessp-aux s1 s2 len1 len2 (add1 i))) ((char-lessp (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING-GREATERP - lexicographic comparison of strings (defun string-greaterp (s1 s2) (string-lessp s2 s1)) ;;;; STRING-NOT-GREATERP - lexicographic comparison of strings (defun string-not-greaterp (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (string-not-greaterp-aux s1 s2 (string-length s1) (string-length s2) 0)) (defun string-not-greaterp-aux (s1 s2 len1 len2 i) (cond ((eql i len1) i) ((eql i len2) ()) ((char-equal (char s1 i) (char s2 i)) (string-not-greaterp-aux s1 s2 len1 len2 (add1 i))) ((char-lessp (char s1 i) (char s2 i)) i) (t ()))) ;;;; STRING-NOT-LESSP - lexicographic comparison of strings (defun string-not-lessp (s1 s2) (string-lessp= s2 s1)) ;;;; STRING-NOT-EQUAL - lexicographic comparison of strings (defun string-not-equal (s1 s2) (setq s1 (stringify s1)) (setq s2 (stringify s2)) (let ((len1 (string-length s1)) (len2 (string-length s2))) (if (<= len1 len2) (string-not-equal-aux s1 s2 len1 len2 0) (string-not-equal-aux s2 s1 len2 len1 0)))) (defun string-not-equal-aux (s1 s2 len1 len2 i) (cond ((eql i len1) (if (eql i len2) () i)) ((char-equal (char s1 i) (char s2 i)) (string-not-equal-aux s1 s2 len1 len2 (add1 i))) (t i))) ;;;; MAKE-STRING - construct a string (defun make-string (count fill-character) (mkstring (sub1 count) fill-character)) ;;;; STRING-REPEAT - concat together copies of a string (defun string-repeat (s i) (setq s (stringify s)) (cond ((eql i 0) "") ((eql i 1) (copystring s)) (t (let ((len (string-length s))) (let ((s1 (make-string (* i len) #\Space))) (do ((j 1 (+ j 1)) (i1 -1)) ((> j i)) (do ((k 0 (+ k 1))) ((eql k len)) (setq i1 (add1 i1)) (rplachar s1 i1 (char s k)))) s1))))) ;;;; STRING-TRIM - remove leading and trailing characters from a string (defun string-trim (c-bag s) (setq s (stringify s)) (let ((len (string-length s))) (let ((i1 (string-trim-left-index c-bag s 0 len)) (i2 (string-trim-right-index c-bag s len))) (if (<= i2 i1) "" (substring s i1 i2))))) (defun string-trim-left-index (c-bag s i uplim) (if (or (eql i uplim) (not (bag-element (char s i) c-bag))) i (string-trim-left-index c-bag s (add1 i) uplim))) (defun string-trim-right-index (c-bag s i) (if (or (eql i 0) (not (bag-element (char s (sub1 i)) c-bag))) i (string-trim-right-index c-bag s (sub1 i)))) (defun bag-element (elem c-bag) (cond ((consp c-bag) (memq elem c-bag)) ((stringp c-bag) (bag-element-aux elem c-bag 0 (string-length c-bag))) (t ()))) (defun bag-element-aux (elem c-bag i uplim) (and (< i uplim) (or (char= elem (char c-bag i)) (bag-element-aux elem c-bag (add1 i) uplim)))) ;;;; STRING-LEFT-TRIM - remove leading characters from string (defun string-left-trim (c-bag s) (setq s (stringify s)) (let ((len (string-length s))) (let ((i1 (string-trim-left-index c-bag s 0 len))) (if (<= len i1) "" (substring s i1 len))))) ;;;; STRING-RIGHT-TRIM - remove trailing characters from string (defun string-right-trim (c-bag s) (setq s (stringify s)) (let ((i2 (string-trim-right-index c-bag s (string-length s)))) (if (<= i2 0) "" (substring s 0 i2)))) ;;;; STRING-UPCASE - copy and raise all alphabetic characters in string (defun string-upcase (s) (setq s (stringify s)) (nstring-upcase (copystring s))) ;;;; NSTRING-UPCASE - destructively raise all alphabetic characters in string (defun nstring-upcase (s) (let ((len (string-length s))) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (when (lowercasep c) (rplachar s i (char-upcase c))))) s)) ;;;; STRING-DOWNCASE - copy and lower all alphabetic characters in string (defun string-downcase (s) (setq s (stringify s)) (nstring-downcase (copystring s))) ;;;; NSTRING-DOWNCASE - destructively raise all alphabetic characters in string (defun nstring-downcase (s) (let ((len (string-length s))) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (when (uppercasep c) (rplachar s i (char-downcase c))))) s)) ;;;; STRING-CAPITALIZE - copy and raise first letter of all words in string (defun string-capitalize (s) (setq s (stringify s)) (nstring-capitalize (copystring s))) ;;;; NSTRING-CAPITALIZE - destructively raise first letter of all words (defun nstring-capitalize (s) (let ((len (string-length s)) (in-word-flag ())) (do ((i 0 (+ i 1))) ((eql i len)) (let ((c (char s i))) (cond ((uppercasep c) (if in-word-flag (rplachar s i (char-downcase c)) (setq in-word-flag t))) ((lowercasep c) (when (not in-word-flag) (rplachar s i (char-upcase c)) (setq in-word-flag t))) (t (setq in-word-flag ()))))) s)) ;;;; STRING - coercion to a string, named STRINGIFY in PSL (defun stringify (x) (cond ((stringp x) x) ((symbolp x) (get-pname x)) (t (stderror (bldmsg "%r cannot be coerced to a string" x))))) ;;;; STRING-TO-LIST - unpack string characters into a list (defun string-to-list (s) (string2list s)) ; PSL function ;;;; STRING-TO-VECTOR - unpack string characters into a vector (defun string-to-vector (s) (string2vector s)) ; PSL function ;;;; SUBSTRING - subsequence restricted to strings (defun substring (string start end) (subseq (stringify string) start end)) ;;;; STRING-LENGTH - last index of a string, plus one (defun string-length (s) (add1 (size s))) ;;;; STRING-CONCAT - concatenate strings (defmacro string-concat args (let ((len (length args))) (cond ((eql len 0) "") ((eql len 1) `(copystring (stringify ,(first args)))) (t (string-concat-aux args len))))) (defun string-concat-aux (args len) (if (eql len 2) `(concat (stringify ,(first args)) (stringify ,(second args))) `(concat (stringify ,(first args)) ,(string-concat-aux (rest args) (sub1 len))))) |
Added psl-1983/util/stringx.sl version [763cf966b3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % STRINGX - Useful String Functions % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 9 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (load fast-int fast-strings common)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (CompileTime (progn (put 'make-string 'cmacro % temporary bug fix '(lambda (sz init) (mkstring (- sz 1) init))) )) % End of CompileTime %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (de string-rest (s i) (substring s i (string-length s))) (de string-pad-right (s desired-length) % Pad the specified string with spaces on the right side to the specified % length. Returns a new string. (let ((len (string-length s))) (if (< len desired-length) (string-concat s (make-string (- desired-length len) #\space)) s))) (de string-pad-left (s desired-length) % Pad the specified string with spaces on the left side to the specified % length. Returns a new string. (let ((len (string-length s))) (if (< len desired-length) (string-concat (make-string (- desired-length len) #\space) s) s))) (de string-largest-common-prefix (s1 s2) % Return the string that is the largest common prefix of S1 and S2. (for (from i 0 (min (string-upper-bound s1) (string-upper-bound s2)) 1) (while (= (string-fetch s1 i) (string-fetch s2 i))) (returns (substring s1 0 i)) )) (de strings-largest-common-prefix (l) % Return the string that is the largest common prefix of the elements % of L, which must be a list of strings. (cond ((null l) "") ((null (cdr l)) (car l)) (t (let* ((prefix (car l)) (limit (string-length prefix)) ) % Prefix[0..LIMIT-1] is the string that is a prefix of all % strings so far examined. (for (in s (cdr l)) (with i) (do (let ((n (string-length s))) (if (< n limit) (setf limit n)) ) (setf i 0) (while (< i limit) (if (~= (string-fetch prefix i) (string-fetch s i)) (setf limit i) (setf i (+ i 1)) )) )) (substring prefix 0 limit) )))) |
Added psl-1983/util/struct.initial version [a012f0708a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;-*-lisp-*- (defmacro defstruct ((name . opts) . slots) (let ((dp (cadr (assq 'default-pointer opts))) (conc-name (cadr (assq 'conc-name opts))) (cons-name (implode (append '(m a k e -) (explodec name))))) ; #Q (fset-carefully cons-name '(macro . initial_defstruct-cons)) ; #M (putprop cons-name 'initial_defstruct-cons 'macro) ; PSL change (putd cons-name 'macro (cdr (getd 'initial_defstruct-cons))) ; PSL change 1+ ==> add1 (do ((i 0 (add1 i)) (l slots (cdr l)) (foo nil (cons (list slot init) foo)) (chars (explodec conc-name)) (slot) (acsor) (init)) ((null l) (putprop cons-name foo 'initial_defstruct-inits) `',name) (cond ((atom (car l)) (setq slot (car l)) (setq init nil)) (t (setq slot (caar l)) (setq init (cadar l)))) (setq acsor (implode (append chars (explodec slot)))) (putprop acsor dp 'initial_defstruct-dp) ; #Q (fset-carefully acsor '(macro . initial_defstruct-ref)) ; #M (putprop acsor 'initial_defstruct-ref 'macro) ; PSL change (putd acsor 'macro (cdr (getd 'initial_defstruct-ref))) (putprop acsor i 'initial_defstruct-i)))) (defun initial_defstruct-ref (form) (let ((i (get (car form) 'initial_defstruct-i)) (p (if (null (cdr form)) (get (car form) 'initial_defstruct-dp) (cadr form)))) ; PSL change incompatible NTH #-Multics `(nth ,p ,(add1 i)) ; #-Multics `(nth ,i ,p) #+Multics `(car ,(do ((i i (1- i)) (x p `(cdr ,x))) ((zerop i) x))) )) (defun initial_defstruct-cons (form) (do ((inits (get (car form) 'initial_defstruct-inits) (cdr inits)) (gen (gensym)) (x nil (cons (or (get form (caar inits)) (cadar inits)) x))) ((null inits) `(list . ,x)))) |
Added psl-1983/util/sysbuild.mic version [4962874d84].
> > > > > > > | 1 2 3 4 5 6 7 | @def pl: dsk:,plap: @PSL:RLISP *LOAD BUILD; *BUILD '''A; *QUIT; @def pl: plap: @reset . |
Added psl-1983/util/tel-ann-driver.red version [b00b28347a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TELERAY specIfic Procedures % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Basic Teleray 1061 Plotter % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-12,12) := (Bottom . . Top) % Physical Size is D.X=~8inch, D.Y=~6inch % Want square asp[ect ratio for 100*100 Procedure TEL!.OutChar x; PBOUT x; Procedure TEL!.OutCharString S; % Pbout a string For i:=0:Size S do TEL!.OutChar S[i]; Procedure TEL!.NormX X; FIX(X)+40; Procedure TEL!.NormY Y; 12 - FIX(Y); Procedure TEL!.ChPrt(X,Y,Ch); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutChar Ch>>; Procedure TEL!.IdPrt(X,Y,Id); TEL!.ChPrt(X,Y,ID2Int ID); Procedure TEL!.StrPrt (X,Y,S); <<TEL!.OutChar Char ESC; TEL!.OutChar 89; TEL!.OutChar (32+TEL!.NormY Y); TEL!.OutChar (32+ TEL!.NormX X); TEL!.OutCharString S>>; Procedure TEL!.HOME (); % Home (0,0) <<TEL!.OutChar CHAR ESC; TEL!.OutChar 'H>>; Procedure TEL!.EraseS (); % Delete Entire Screen <<TEL!.OutChar CHAR ESC; TEL!.OutChar '!j>>; Procedure TEL!.DDA (X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST (X1,Y1)) >>; Return NIL end; Procedure Tel!.MoveS (X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure Tel!.DrawS (X1,Y1); << TEL!.DDA (Xhere,Yhere, X1, Y1,function TEL!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl (X); % Convert Idlist To Char List Begin scalar Y; While Pairp (X) do <<Y := getv (Sfromid car X, 1) . Y;X := Cdr X >>; Return (Reverse (Y)) end; FLUID '(Tchars); Procedure Texter (X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl (Explode2 (Txt)); Return (TEL!.DDA (X1,Y1,X2,Y2,function Tdotc)) end; Procedure Tdotc (X1,Y1); Begin If Null Tchars then Return (Nil); If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return ('T) end; Procedure TEL!.dotc (X1,Y1); % Draw And Clip An X TEL!.ChClip (X1,Y1,Char X) ; Procedure TEL!.ChClip (X1,Y1,Id); Begin If (X1 > X2clip) Or (X1 < X1clip) then Goto No; If (Y1 > Y2clip) Or (Y1 < Y1clip) then Goto No; TEL!.ChPrt (X1 , Y1,Id); No:Return ('T) end; Procedure Tel!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2 (-40,X1); X2clip := Min2 (40,X2); Y1clip := Max2 (-12,Y1); Y2clip := Min2 (12,Y2)>>; Procedure Tel!.Wfill (X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do TEL!.ChClip (X,Y,Id); end; Procedure TEL!.Wzap (X1,X2,Y1,Y2); TEL!.Wfill (X1,X2,Y1,Y2,'! ) ; Procedure TEL!.Delay; NIL; Procedure TEL!.GRAPHON(); If not !*emode then echooff(); Procedure TEL!.GRAPHOFF(); If not !*emode then echoon(); Procedure TEL!.INIT (); % Setup For TEL As Device; Begin Dev!. := 'TEL; FNCOPY('EraseS,'TEL!.EraseS); FNCOPY('MoveS,'TEL!.MoveS); FNCOPY('DrawS,'TEL!.DrawS); FNCOPY( 'NormX, 'TEL!.NormX)$ FNCOPY( 'NormY, 'TEL!.NormY)$ FNCOPY('VwPort,'TEL!.VwPort); FNCOPY('Delay,'TEL!.Delay); FNCOPY( 'GraphOn, 'TEL!.GraphOn)$ FNCOPY( 'GraphOff, 'TEL!.GraphOff)$ Erase(); VwPort (-40,40,-12,12); Print "Device Now TEL"; end; % Basic ANN ARBOR AMBASSADOR Plotter % % Screen Range Is X := (-40,40) := (Left . . Right) % Y := (-30,30) := (Bottom . . Top) Procedure ANN!.OutChar x; PBOUT x; Procedure ANN!.OutCharString S; % Pbout a string For i:=0:Size S do ANN!.OutChar S[i]; Procedure ANN!.NormX X; % so --> X 40 + FIX(X+0.5); Procedure ANN!.NormY Y; % so ^ 30 - FIX(Y+0.5); % | Y Procedure ANN!.XY(X,Y); << Ann!.OutChar(char ESC); Ann!.OutChar(char ![); x:=Ann!.NormX(x); y:=Ann!.NormY(y); % Use "quick and dirty" conversion to decimal digits. Ann!.OutChar(char 0 + (1 + Y)/10); Ann!.OutChar(char 0 + remainder(1 + Y, 10)); Ann!.OutChar(char !;); % Delimiter between row digits and column digits. Ann!.OutChar(char 0 + (1 + X)/10); Ann!.OutChar(char 0 + remainder(1 + X, 10)); Ann!.OutChar(char H); % Terminate the sequence >>; Procedure ANN!.ChPrt(X,Y,Ch); <<ANN!.XY(X,Y); ANN!.OutChar Ch>>; Procedure ANN!.IdPrt(X,Y,Id); ANN!.ChPrt(X,Y,ID2Int ID); Procedure ANN!.StrPrt(X,Y,S); <<ANN!.XY(X,Y); ANN!.OutCharString S>>; Procedure ANN!.EraseS(); % Delete Entire Screen <<ANN!.OutChar CHAR ESC; ANN!.OutChar Char '![; Ann!.OutChar Char 2; Ann!.OutChar Char J; Ann!.XY(0,0);>>; Procedure ANN!.DDA(X1,Y1,X2,Y2,dotter); Begin scalar Dx,Dy,Xc,Yc,I,R,S; % From N & S, Page 44, Draw Straight Pointset Dx := X2-X1; Dy := Y2-Y1; R := 0.5; If Dx >= 0 then Xc := 1 else <<Xc := -1;Dx := -Dx >>; If Dy >= 0 then Yc := 1 else <<Yc := -1;Dy := -Dy >>; If Dx <= Dy then Goto doy; S := FLOAT(Dy)/Dx; For I := 1:Dx do <<R := R+S; If R>=1.0 then <<Y1 := Y1+Yc;R := R-1.0 >>; X1 := X1+Xc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL; doy:S := float(Dx) / Dy; For I := 1:Dy do <<R := R+S; If R>=1.0 then <<X1 := X1+Xc;R := R-1 >>; Y1 := Y1+Yc; APPLY(dotter,LIST(X1,Y1)) >>; Return NIL end; Procedure ANN!.MoveS(X1,Y1); <<Xhere := X1; Yhere := Y1>>; Procedure ANN!.DrawS(X1,Y1); << ANN!.DDA(Xhere,Yhere, X1, Y1,function ANN!.dotc); Xhere :=X1; Yhere :=Y1>>; Procedure Idl2chl(X); % Convert Idlist To Char List Begin scalar Y; While Pairp(X) do <<Y := getv(Sfromid car X, 1) . Y;X := Cdr X >>; Return(Reverse(Y)) end; FLUID '(Tchars); Procedure Texter(X1,Y1,X2,Y2,Txt); Begin scalar Tchars; Tchars := Idl2chl(Explode2(Txt)); Return(ANN!.DDA(X1,Y1,X2,Y2,function ANN!.Tdotc)) end; Procedure ANN!.Tdotc(X1,Y1); Begin If Null Tchars then Return(Nil); If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Car Tchars); No:Tchars := Cdr Tchars; Return('T) end; Procedure ANN!.dotc(X1,Y1); % Draw And Clip An X ANN!.ChClip(X1,Y1,Char !*) ; Procedure ANN!.ChClip(X1,Y1,Id); Begin If(X1 > X2clip) Or(X1 < X1clip) then Goto No; If(Y1 > Y2clip) Or(Y1 < Y1clip) then Goto No; ANN!.ChPrt(X1 , Y1,Id); No:Return('T) end; Procedure ANN!.VwPort(X1,X2,Y1,Y2); <<X1clip := Max2(-40,X1); X2clip := Min2(40,X2); Y1clip := Max2(-30,Y1); Y2clip := Min2(30,Y2)>>; Procedure ANN!.Wfill(X1,X2,Y1,Y2,Id); Begin scalar X,Y; For Y := Y1 : Y2 do For X := X1 : X2 do ANN!.ChClip(X,Y,Id); end; Procedure ANN!.Wzap(X1,X2,Y1,Y2); ANN!.Wfill(X1,X2,Y1,Y2,'! ) ; Procedure ANN!.Delay; NIL; Procedure ANN!.GRAPHON(); If not !*emode then echooff(); Procedure ANN!.GRAPHOFF(); If not !*emode then echoon(); Procedure ANN!.INIT(); % Setup For ANN As Device; Begin Dev!. := 'ANN60; FNCOPY('EraseS,'ANN!.EraseS); FNCOPY('MoveS,'ANN!.MoveS); FNCOPY('DrawS,'ANN!.DrawS); FNCOPY('NormX, 'ANN!.NormX)$ FNCOPY('NormY, 'ANN!.NormY)$ FNCOPY('VwPort,'ANN!.VwPort); FNCOPY('Delay,'ANN!.Delay); FNCOPY('GraphOn, 'ANN!.GraphOn)$ FNCOPY('GraphOff, 'ANN!.GraphOff)$ Erase(); VwPort(-40,40,-30,30); Print "Device Now ANN60"; end; |
Added psl-1983/util/test-arith.red version [2905b61015].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % ARITHMETIC.RED - Arithmetic routines for PSL with new integer tags % % Author: Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 17 January 1982 % Copyright (c) 1982 University of Utah % on SysLisp; syslsp procedure IsInum U; SignedField(U, InfStartingBit - 1, InfBitLength + 1) eq U; CompileTime << internal WConst IntFunctionEntry = 0, BigFunctionEntry = 1, FloatFunctionEntry = 2, FunctionNameEntry = 3; >>; syslsp procedure TwoArgDispatch(FirstArg, SecondArg); TwoArgDispatch1(FirstArg, SecondArg, Tag FirstArg, Tag SecondArg); lap '((!*entry TwoArgDispatch1 expr 4) (!*JUMPNOTEQ (Label NotNeg1) (reg 3) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 3)) NotNeg1 (!*JUMPNOTEQ (Label NotNeg2) (reg 4) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 4)) NotNeg2 (!*JUMPWGREATERP (Label NonNumeric) (reg 3) (WConst FltN)) (!*JUMPWGREATERP (Label NonNumeric) (reg 4) (WConst FltN)) (!*WSHIFT (reg 3) (WConst 2)) (!*WPLUS2 (reg 4) (reg 3)) (!*POP (reg 3)) (!*JUMPON (reg 4) 0 15 ((Label IntInt) (Label IntFix) (Label IntBig) (Label IntFloat) (Label FixInt) (Label FixFix) (Label FixBig) (Label FixFloat) (Label BigInt) (Label BigFix) (Label BigBig) (Label BigFloat) (Label FloatInt) (Label FloatFix) (Label FloatBig) (Label FloatFloat))) (!*JCALL TwoArgError) FixBig (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntBig (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntBig) (!*POP (reg 2)) (!*POP (reg 3)) BigBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) BigFix (!*FIELD (reg 2) (reg 2) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) BigInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntBig) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FixInt (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) FixFix (!*FIELD (reg 1) (reg 1) % grab the value for the fixnum (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) IntInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) FixFloat (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) IntFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticIntFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatFix (!*FIELD (reg 2) (reg 2) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 2) (WConst AddressingUnitsPerItem)) (reg 2)) FloatInt (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticIntFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) BigFloat (!*PUSH (reg 3)) (!*PUSH (reg 2)) (!*CALL StaticBigFloat) (!*POP (reg 2)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) FloatBig (!*PUSH (reg 3)) (!*PUSH (reg 1)) (!*MOVE (reg 2) (reg 1)) (!*CALL StaticBigFloat) (!*MOVE (reg 1) (reg 2)) (!*POP (reg 1)) (!*POP (reg 3)) (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) NonNumeric (!*POP (reg 3)) (!*JCALL TwoArgError) ); syslsp procedure TwoArgError(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger2Error(FirstArg, SecondArg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg, SecondArg)); syslsp procedure NonInteger1Error(Arg, DispatchTable); ContinuableError('99, '"Non-integer argument in arithmetic", list(DispatchTable[FunctionNameEntry], Arg)); syslsp procedure OneArgDispatch FirstArg; OneArgDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label OneBig) (Label OneFloat))) (!*JCALL OneArgError) OneBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) OneFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) ); syslsp procedure OneArgError(FirstArg, Dummy, DispatchTable); ContinuableError('99, '"Non-numeric argument in arithmetic", list(DispatchTable[FunctionNameEntry], FirstArg)); syslsp procedure OneArgPredicateDispatch FirstArg; OneArgPredicateDispatch1(FirstArg, Tag FirstArg); lap '((!*entry OneArgPredicateDispatch1 expr 2) (!*JUMPNOTEQ (Label NotNeg1) (reg 2) (WConst NegInt)) (!*MOVE (WConst PosInt) (reg 2)) NotNeg1 (!*POP (reg 3)) (!*JUMPON (reg 2) 0 3 ((Label OneInt) (Label OneFix) (Label OneBig) (Label OneFloat))) (!*MOVE (QUOTE NIL) (reg 1)) (!*EXIT 0) OneBig (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst BigFunctionEntry)))) (reg t1)) (!*JCALL FastApply) OneFix (!*FIELD (reg 1) (reg 1) (WConst InfStartingBit) (WConst InfBitLength)) (!*MOVE (MEMORY (reg 1) (WConst AddressingUnitsPerItem)) (reg 1)) OneInt (!*MOVE (MEMORY (reg 3) (WConst 0)) (reg t1)) (!*JCALL FastApply) OneFloat (!*MOVE (MEMORY (reg 3) (WConst (times2 (WConst AddressingUnitsPerItem) (WConst FloatFunctionEntry)))) (reg t1)) (!*JCALL FastApply) ); syslsp procedure MakeFixnum N; begin scalar F; F := GtFIXN(); FixVal F := N; return MkFIXN F; end; syslsp procedure BigFloatFix N; StdError List('"Bignums not yet supported [BigFloatFix]",N); syslsp procedure ReturnNIL(); NIL; syslsp procedure ReturnFirstArg Arg; Arg; %internal WArray StaticFloatBuffer = [1, 0, 0]; % %internal WConst StaticFloatItem = MkItem(FLTN, StaticFloatBuffer); % syslsp procedure StaticIntFloat Arg; %<< !*WFloat(&StaticFloatBuffer[1], Arg); % StaticFloatItem >>; FloatIntArg Arg; syslsp procedure StaticIntBig Arg; StdError LIST('"Bignums not yet supported [StaticIntBig]",Arg); syslsp procedure StaticBigFloat Arg; StdError LIST('"Bignums not yet supported [StaticBigFloat]",Arg); off SysLisp; CompileTime << macro procedure DefArith2Entry U; DefArithEntry(2 . 'TwoArgDispatch . StupidParserFix cdr U); macro procedure DefArith1Entry U; DefArithEntry(1 . 'OneArgDispatch . StupidParserFix cdr U); macro procedure DefArith1PredicateEntry U; DefArithEntry(1 . 'OneArgPredicateDispatch . StupidParserFix cdr U); lisp procedure StupidParserFix X; % Goddamn Rlisp parser won't let me just give "Difference" as the parameter % to a macro if null X then X else RemQuote car X . StupidParserFix cdr X; lisp procedure RemQuote X; if EqCar(X, 'QUOTE) then cadr X else X; lisp procedure DefArithEntry L; SublA(Pair('(NumberOfArguments DispatchRoutine NameOfFunction IntFunction BigFunction FloatFunction), L), quote(lap '((!*entry NameOfFunction expr NumberOfArguments) (!*Call DispatchRoutine) % 30 is ID, won't do for 68000 (fullword (MkItem 30 (IDLoc IntFunction))) (fullword (MkItem 30 (IDLoc BigFunction))) (fullword (MkItem 30 (IDLoc FloatFunction))) (fullword (MkItem 30 (IDLoc NameOfFunction)))))); >>; DefArith2Entry(Plus2, IntPlus2, BigPlus2, FloatPlus2); syslsp procedure IntPlus2(FirstArg, SecondArg); if IsInum(FirstArg := WPlus2(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatPlus2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FPlus2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Difference, IntDifference, BigDifference, FloatDifference); syslsp procedure IntDifference(FirstArg, SecondArg); if IsInum(FirstArg := WDifference(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; syslsp procedure FloatDifference(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FDifference(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Times2, IntTimes2, BigTimes2, FloatTimes2); % What about overflow? syslsp procedure IntTimes2(FirstArg, SecondArg); begin scalar Result; Result := WTimes2(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatTimes2(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FTimes2(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry('Divide, IntDivide, BigDivide, FloatDivide); DefArith2Entry('Quotient, IntQuotient, BigQuotient, FloatQuotient); syslsp procedure IntDivide(FirstArg, SecondArg); IntQuotient(FirstArg, SecondArg) . IntRemainder(FirstArg, SecondArg); syslsp procedure FloatDivide(FirstArg, SecondArg); FloatQuotient(FirstArg, SecondArg) . FloatRemainder(FirstArg, SecondArg); syslsp procedure IntQuotient(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); Result := WQuotient(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatQuotient(FirstArg, SecondArg); begin scalar F; if FloatZeroP SecondArg then return ContError(99, "Attempt to divide by zero in Quotient", Quotient(FirstArg, SecondArg)); F := GtFLTN(); !*FQuotient(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(Remainder, IntRemainder, BigRemainder, FloatRemainder); syslsp procedure IntRemainder(FirstArg, SecondArg); begin scalar Result; if SecondArg eq 0 then return ContError(99, "Attempt to divide by zero in Remainder", Remainder(FirstArg, SecondArg)); Result := WRemainder(FirstArg, SecondArg); return if not IsInum Result then MakeFixnum Result else Result; end; syslsp procedure FloatRemainder(FirstArg, SecondArg); begin scalar F; F := GtFLTN(); !*FRemainder(FloatBase F, FloatBase FltInf FirstArg, FloatBase FltInf SecondArg); return MkFLTN F; end; DefArith2Entry(LAnd, IntLAnd, BigLAnd, NonInteger2Error); syslsp procedure IntLAnd(FirstArg, SecondArg); if IsInum(FirstArg := WAnd(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LOr, IntLOr, BigLOr, NonInteger2Error); syslsp procedure IntLOr(FirstArg, SecondArg); if IsInum(FirstArg := WOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LXOr, IntLXOr, BigLXOr, NonInteger2Error); syslsp procedure IntLXOr(FirstArg, SecondArg); if IsInum(FirstArg := WXOr(FirstArg, SecondArg)) then FirstArg else MakeFixnum FirstArg; DefArith2Entry(LShift, IntLShift, BigLShift, NonInteger2Error); PutD('LSH, 'EXPR, cdr GetD 'LShift); procedure IntLShift(FirstArg, SecondArg); BigLShift(Int2B FirstArg, Int2B SecondArg); DefArith2Entry('GreaterP, IntGreaterP, BigGreaterP, FloatGreaterP); syslsp procedure IntGreaterP(FirstArg, SecondArg); WGreaterP(FirstArg, SecondArg); syslsp procedure FloatGreaterP(FirstArg, SecondArg); !*FGreaterP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith2Entry('LessP, IntLessP, BigLessP, FloatLessP); syslsp procedure IntLessP(FirstArg, SecondArg); WLessP(FirstArg, SecondArg); syslsp procedure FloatLessP(FirstArg, SecondArg); !*FLessP(FloatBase FltInf FirstArg, FloatBase FltInf SecondArg) and T; DefArith1Entry(Add1, IntAdd1, BigAdd1, FloatAdd1); syslsp procedure IntAdd1 FirstArg; if IsInum(FirstArg := WPlus2(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatAdd1 FirstArg; FloatPlus2(FirstArg, 1.0); DefArith1Entry(Sub1, IntSub1, BigSub1, FloatSub1); lisp procedure IntSub1 FirstArg; if IsInum(FirstArg := WDifference(FirstArg, 1)) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatSub1 FirstArg; FloatDifference(FirstArg, 1.0); DefArith1Entry(LNot, IntLNot, BigLNot, NonInteger1Error); lisp procedure IntLNot X; if IsInum(X := WNot X) then X else MakeFixnum X; DefArith1Entry('Minus, IntMinus, BigMinus, FloatMinus); lisp procedure IntMinus FirstArg; if IsInum(FirstArg := WMinus FirstArg) then FirstArg else MakeFixnum FirstArg; lisp procedure FloatMinus FirstArg; FloatDifference(0.0, FirstArg); DefArith1Entry(Fix, ReturnFirstArg, ReturnFirstArg, FloatFix); syslsp procedure FloatFix Arg; begin scalar R; return if IsInum(R :=!*WFix FloatBase FltInf Arg) then R else MakeFixnum R; end; DefArith1Entry(Float, FloatIntArg, FloatBigArg, ReturnFirstArg); syslsp procedure FloatIntArg Arg; begin scalar F; F := GtFLTN(); !*WFloat(FloatBase F, Arg); return MkFLTN F; end; DefArith1PredicateEntry(MinusP, IntMinusP, BigMinusP, FloatMinusP); syslsp procedure IntMinusP FirstArg; WLessP(FirstArg, 0); lisp procedure FloatMinusP FirstArg; FloatLessP(FirstArg, 0.0); DefArith1PredicateEntry(ZeroP, IntZeroP, ReturnNIL, FloatZeroP); lisp procedure IntZeroP FirstArg; FirstArg = 0; lisp procedure FloatZeroP FirstArg; EQN(FirstArg, 0.0); DefArith1PredicateEntry(OneP, IntOneP, ReturnNIL, FloatOneP); lisp procedure IntOneP FirstArg; FirstArg = 1; lisp procedure FloatOneP FirstArg; EQN(FirstArg, 1.0); END; |
Added psl-1983/util/time-fnc.sl version [5d20e26e01].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Time-fnc.sl : code to time function calls. ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Written by Douglas Lanam. (November 1982). ;; ;; To be compiled inside `pfrl' using the command: ;; (compile-file time-fnc). ;; ;; The object created is usuable in any psl on machine it is compiled for. ;; ;; Usage: ;; ;; do ;; (timef function-name-1 function-name-2 ...) ;; ;; Timef is a fexpr. ;; It will redefine the functions named so that timing information is ;; kept on these functions. ;; This information is kept on the property list of the function name. ;; The properties used are `time' and `number-of-calls'. ;; ;; (get function-name 'time) gives you the total time in the function. ;; (not counting gc time). ;; Note, this is the time from entrance to exit. ;; The timef function redefines the function with an ;; unwind-protect, so calls that are interrupted ;; by *throws are counted. ;; ;; (get function-name 'number-of-calls) gives you the number of times ;; the function is called. ;; ;; To stop timing do : ;; (untimef function-name1 ..) ;; or do (untimef) for all functions. ;; (untimef) is a fexpr. ;; ;; To print timing information do ;; (print-time-info function-name-1 function-name-2 ..) ;; ;; or do (print-time-info) for timing information on all function names. ;; ;; special variables used: ;; *timed-functions* : list of all functions currently being timed. ;; *all-timed-functions* : list of all functions ever timed in the ;; current session. ;; ;; Comment: if tr is called on a called on a function that is already ;; being timed, and then untimef is called on the function, the ;; function will no longer be traced. ;; (defvar *timed-functions* nil) (defvar *all-timed-functions* nil) (defun timef fexpr (names) (cond ((null names) *timed-functions*) ((f-mapc '(lambda (x) (or (memq x *timed-functions*) (let ((a (getd x))) (cond (a (put x 'orig-function-def a) (setq *timed-functions* (cons x *timed-functions*)) (or (memq x *all-timed-functions*) (setq *all-timed-functions* (cons x *all-timed-functions*))) (set-up-time-function (car a) x (cdr a))) (t (princ x) (princ " is not a defined function.") (terpri)))))) names)))) (defun set-up-time-function (type x old-func) (let ((y (cond ((codep old-func) (code-number-of-arguments old-func)) (t (length (cadr old-func))))) (args) (function) (result-var (gensym)) (gc-time-var (gensym)) (time-var (gensym))) (do ((i y (difference i 1))) ((= i 0)) (setq args (cons (gensym) args))) (putd x type `(lambda ,args (time-function ',x ',old-func (list (time) . ,args)))) x)) (defvar |* timing time *| 0) #+dec20 (defvar *call-overhead-time* 0.147) #+vax (defvar *call-overhead-time* 0.1) #+dec20 (defvar *time-overhead-time* 0.437) #+vax (defvar *time-overhead-time* 1.3) (defvar |* number of sub time calls *| 0) (defun time-function (name function-pointer arguments) (let ((itime-var (car arguments)) (result) (n) (endt) (total-fnc-time) (time-var) (gc-time-var)) (unwind-protect (let ((|* timing time *| 0) (|* number of sub time calls *| 0)) (unwind-protect (let () (setq gc-time-var gctime* time-var (time) result (apply function-pointer (cdr arguments)) endt (time)) result) (cond (time-var (or endt (setq endt (time))) (Setq n |* number of sub time calls *|) (put name 'number-of-sub-time-calls (+ n (or (get name 'number-of-sub-time-calls) 0))) (setq total-fnc-time (- (- endt time-var) |* timing time *|)) (put name 'time (+ (or (get name 'time) 0) (- total-fnc-time (- gctime* gc-time-var)))) (put name 'number-of-calls (1+ (or (get name 'number-of-calls) 0))))))) (prog () (setq |* timing time *| (- (- |* timing time *| itime-var) total-fnc-time))) (setq |* number of sub time calls *| (1+ |* number of sub time calls *|)) (setq |* timing time *| (+ |* timing time *| (time))))))) (defun untimef fexpr (names) (f-mapc '(lambda (x) (cond ((memq x *timed-functions*) (let ((a (get x 'orig-function-def))) (cond (a (putd x (car a) (cdr a))))) (setq *timed-functions* (delq x *timed-functions*))))) (or names *timed-functions*))) (defun print-time-info fexpr (names) (f-mapc '(lambda (x) (let ((n (get x 'number-of-calls)) (ns (get x 'number-of-sub-time-calls)) (time) (t1 (get x 'time))) (princ x) (princ " ") (tab 20) (princ (or n 0)) (princ " calls") (cond (n (setq time (max 0 (difference (difference (or t1 0) (times *call-overhead-time* (or n 0))) (times *time-overhead-time* (or ns 0))))) (tab 31) (princ time) (princ " ms") (tab 48) (princ (quotient (float time) (float n))) (princ " ms\/call"))) (terpri))) (or names *all-timed-functions*)) (terpri)) |
Added psl-1983/util/time.stamp version [ee9769e919].
> | 1 | 30-Jul-82 11:41:24 |
Added psl-1983/util/useful.build version [fbb85a415c].
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 | CompileTime load Useful; in "backquote.sl"$ in "read-macros.sl"$ in "destructure.sl"$ in "cond-macros.sl"$ in "bind-macros.sl"$ in "set-macros.sl"$ in "iter-macros.sl"$ in "for-macro.sl"$ in "misc-macros.sl"$ in "macroexpand.sl"$ |
Added psl-1983/util/useful.ctl version [a22a625429].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | @cd pu: @psl:rlisp load build,useful; off redefmsg,usermode; in "backquote.sl"$ in "read-macros.sl"$ in "destructure.sl"$ in "cond-macros.sl"$ in "bind-macros.sl"$ in "set-macros.sl"$ in "iter-macros.sl"$ remflag('(for),'lose); in "for-macro.sl"$ in "misc-macros.sl"$ in "macroexpand.sl"$ build 'useful; quit; @tags pu:useful.tags pu:backquote.sl pu:read-macros.sl pu:destructure.sl pu:cond-macros.sl pu:bind-macros.sl pu:set-macros.sl pu:iter-macros.sl pu:for-macro.sl pu:misc-macros.sl pu:macroexpand.sl * |
Added psl-1983/util/useful.tags version [66d0b90850].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | PS:<PSL.UTIL>BACKQUOTE.SL.0 00410,PSL (dm backquote (u) (backquote-form (cadr u)))686 (de backquote-form (u)712 (de backquote-vector (u)1392 (de backquote-list (u)2074 (de backquote-constantp (u)3251 (de backquote-constant-value (x)3387 (dm quoted-list (u) (mkquote (cdr u)))3712 (dm list* (u) (expand (cdr u) 'cons))3755 (dm quoted-list* (u)3779 (dm unquote (u) (ContinuableError4175 PS:<PSL.UTIL>READ-MACROS.SL.0 00493,PSL (de backquote-read-macro (channel qt)659 (de unquote-read-macro (channel qt)756 (de unquotel-read-macro (channel qt)852 (de unquoted-read-macro (channel qt)949 (de function-read-macro (channel qt)1899 (de eval-read-macro (channel qt)1988 (de if-system-read-macro (channel qt)2184 (de if-not-system-read-macro (channel qt)2462 (de single-char-read-macro (channel qt)3571 (de char-read-macro (channel qt)3961 (de DoChar (u)4028 PS:<PSL.UTIL>DESTRUCTURE.SL.0 00297,PSL (de destructure-form (target path)324 (de flatten (U)671 (de defmacro-1 (U)1055 (de macro-displace (u v)1450 (dm defmacro (u) (defmacro-1 u))1626 (dm defmacro-displace (u)1656 (dm defmacro-no-displace (u)1742 (defmacro desetq (U V)1916 PS:<PSL.UTIL>COND-MACROS.SL.0 00215,PSL (defmacro if (predicate then . else)327 (defmacro xor (u v) 448 (defmacro when (p . c) `(cond (,p . ,c)))713 (defmacro unless (p . c) `(cond ((not ,p) . ,c)))766 PS:<PSL.UTIL>BIND-MACROS.SL.0 00179,PSL (defmacro prog1 (first . body)315 (defmacro let (specs . body)444 (defmacro let* (specs . body)910 (de let*1 (specs body)1097 PS:<PSL.UTIL>SET-MACROS.SL.0 00808,PSL (defmacro setf u808 (de setf1 (u)1002 (de setf2 (lhs rhs)1182 (de expand-setf (lhs rhs)1513 (de expand-pnth-setf (lhs rhs)3934 (de flag-setf (nam flg val)4408 (de getd-setf (trgt src)4520 (de list-setf (lhs rhs)4918 (de cons-setf (lhs rhs)5149 (de vector-setf (lhs rhs)5478 (defmacro push (item stack) `(setf ,stack (cons ,item ,stack)))5826 (defmacro pop (stack . rst)5857 (defmacro adjoin-to (e s) `(setf ,s (adjoin ,e ,s)))6016 (defmacro adjoinq-to (e s) `(setf ,s (adjoinq ,e ,s)))6074 (defmacro incr (var . rst)6104 (defmacro decr (var . rst)6193 (defmacro clear L6286 (defmacro psetq rst6387 (defmacro psetf rst6797 (defmacro defswitch (nam var . acts)7128 (de ,nam () (let ((,nam ,var)) ,read-act) ,var)7401 PS:<PSL.UTIL>ITER-MACROS.SL.0 00254,PSL (defmacro do (iterators result . body)316 (defmacro do* (iterators result . body)1011 (defmacro do-loop (iterators prologue result . body)1717 (defmacro do-loop* (iterators prologue result . body)2443 PS:<PSL.UTIL>FOR-MACRO.SL.0 01041,PSL (dm for (U) (for-build-loop (cdr U) 'do-loop 'let))593 (defmacro for* U613 (de for-build-loop (U loop-fn let-fn)693 (de process-for-clause (clause)2490 (de for-in-function (clause)2881 (de for-on-function (clause)3390 (de for-from-function (clause)3564 (de for-for-function (clause) (tconc for-vars* clause))4661 (de for-with-function (clause) 4696 (de for-initially-function (clause)4800 (de for-finally-function (clause)4905 (de for-do-function (clause)5005 (de for-collect-function (clause)5107 (de for-conc-function (clause)5558 (de for-join-function (clause)6024 (de for-intersection-function (clause)7168 (de for-intersectionq-function (clause)7606 (de for-always-function (clause)8849 (de for-never-function (clause)9007 (de for-thereis-function (clause)9159 (de for-returns-function (clause)9345 (de for-while-function (clause)9455 (de for-until-function (clause)9553 (de for-when-function (clause)9649 (de for-unless-function (clause)9751 PS:<PSL.UTIL>MISC-MACROS.SL.0 00489,PSL (defmacro funcall u `(apply ,(car u) (list ,@(cdr u))))323 (defmacro eqfirst (u v) `(eqcar ,u ,v))392 (defmacro bldid (s . args) `(intern (bldmsg ,s ,@args)))452 (defmacro nary-concat u (expand u 'concat))499 (de stub-print (name arg-names actual-args)817 (defmacro circular-list L1001 (defmacro nothing U nil) % Nary no-op returning nil; args not evaluated.1189 (defmacro make-list (N . rst)1222 (de make-list-1 (N init)1304 PS:<PSL.UTIL>MACROEXPAND.SL.0 00308,PSL (defmacro macroexpand (form . macros)318 (de macroexpand1 (U L)419 (de macroexpand2 (U L)624 (de macroexpand-cond (U L)1296 (de macroexpand-prog (U L)1421 (de macroexpand-random (U L)1528 (de macroexpand-setq (U L)1627 (de macroexpand-loop ()1989 |
Added psl-1983/util/util.sl version [01886823db].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % % UTIL.SL - General Utility/Support functions % % Author: Nancy Kendzierski % Hewlett-Packard/CRC % Date: 23 September 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load common strings objects)) (fluid '(nmode-terminal)) (defun integer$parse (str) % Return an integer corresponding to the string -- not the characters % in the string, but the number in the string. (prog (i negative error ch num) (setf i 0) (setf num 0) (if (<= (string-length str) 0) (return NIL)) (setf ch (indx str 0)) (cond ((= ch (char -)) (let () (setf negative t) (setf i (add1 i)))) ((= ch (char +)) (setf i (add1 i)))) (if (>= i (string-length str)) (return NIL)) (for (from i i (size str)) (do (setq ch (indx str i)) (cond ((or (< ch (char 0)) (> ch (char 9))) (exit (setq error t))) (t (setq num (+ (* num 10) (- ch (char 0)))))))) (cond (error (return NIL)) (negative (return (setq num (minus num)))) (t (return num))))) (defun integer$unparse (num) % Return an ASCII string version of the integer. (let ((str "") (negative nil) temp) (cond ((< num 0) (setf negative t) (setf num (minus num)))) (while (> num 0) (setq temp (divide num 10)) (setq num (car temp)) (setq str (string-concat (string (+ (cdr temp) (char 0))) str))) (cond ((equal str "") "0") (negative (string-concat "-" str)) (t str)) )) (defun integer-base$parse (base str) % Return an integer corresponding to the string -- not the characters % in the string, but the number in the string. (prog (i negative error ch num max-digit) (setf max-digit (+ #\0 (- base 1))) (setf i 0) (setf num 0) (if (<= (string-length str) 0) (return NIL)) (setf ch (indx str 0)) (cond ((= ch (char -)) (let () (setf negative t) (setf i (add1 i)))) ((= ch (char +)) (setf i (add1 i)))) (if (>= i (string-length str)) (return NIL)) (for (from i i (size str)) (do (setq ch (indx str i)) (cond ((or (< ch (char 0)) (> ch max-digit)) (exit (setq error t))) (t (setq num (+ (* num base) (- ch (char 0)))))))) (cond (error (return NIL)) (negative (return (setq num (minus num)))) (t (return num))))) (defun integer-base$unparse (base num) % Return an ASCII string version of the integer. (let ((str "") (negative nil) temp) (cond ((< num 0) (setf negative t) (setf num (minus num)))) (while (> num 0) (setq temp (divide num base)) (setq num (car temp)) (setq str (string-concat (string (+ (cdr temp) (char 0))) str))) (cond ((equal str "") "0") (negative (string-concat "-" str)) (t str)) )) (defun LoadSoftKey (key mode command label) % Load a soft key on an HP264X terminal % key: 0 <= key <= 8 % mode: 'N 'L or 'T % command: string (maximum 80 characters) % label: string (maximum 80 characters) (prog (cmd command-size label-size restore-echo?) (setq cmd (string 27 38)) % Escape-& is soft-key command prefix start. % Set up proper mode. (cond ((= mode 'N) (setq cmd (concat cmd "f0a"))) ((= mode 'L) (setq cmd (concat cmd "f1a"))) ((= mode 'T) (setq cmd (concat cmd "f2a"))) (t (return "Illegal mode") )) % Set up soft-key number. (if (or (< key 0) (> key 8)) (return "Illegal soft-key number")) (setq cmd (string-concat cmd (integer$unparse key) "k")) % Set up label length, command length, and command. (setq label-size (+ 1 (size label))) (if (> label-size 80) (return "Label too long")) (setq command-size (+ 1 (size command))) (if (> command-size 80) (return "Command too long")) (setq cmd (string-concat cmd (integer$unparse label-size) "d" (integer$unparse command-size) "L" label command)) % Turn echoing off, if necessary. (cond ((not (=> nmode-terminal raw-mode)) (=> nmode-terminal enter-raw-mode) (setq restore-echo? t))) % Output the string of command characters. (for (from i 0 (size cmd)) (do (pbout (indx cmd i)))) (if restore-echo? (=> nmode-terminal leave-raw-mode)) )) |
Added psl-1983/util/vector-fix.build version [922e47a4a3].
> > | 1 2 | CompileTime load Syslisp; in "vector-fix.red"$ |
Added psl-1983/util/vector-fix.red version [2aea2cd204].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % <PSL.UTIL>VECTOR-FIX.RED.5, 18-Mar-82 13:50:06, Edit by BENSON % Removed patches that were installed in V3 interp % <PSL.UTIL>VECTOR-FIX.RED.4, 20-Jan-82 12:15:26, Edit by GRISS % Patch to allow 0 element vectors % on Syslisp; syslsp procedure MkWords N; %. Allocate vector, init all to #0 if IntP N then << if N < (-1) then StdError '"A WORD vector with fewer than zero elements cannot be allocated" else begin scalar W; W := GtWRDS N; for I := 0 step 1 until N do WrdItm(W, I) := 0; return MkWRDS W; % Tag it end >> else NonIntegerError(N, 'MkWords); % A special facility to truncate X-vects in place % extract peices syslsp procedure TruncateVector(V,I); If Not VectorP V then NonVectorError(V,'TruncateVector) else if not IntP I then NonIntegerError(I,'TruncateVector) else begin scalar Len,Len2,VI; VI:=VecInf V; Len:=VecLen VI; If Len=I then return V; % Already the size If Len<I then return StdError "Cannot Lengthen a Vector in TruncateVector"; If Len<(-1) then return StdError "Cant TruncateVector to less then -1"; @VI := MkItem(HVECT,I); VecItm(VI, I+1) := MkItem(HVECT, Len-I-2); return V end; % Missing Words Operations syslsp procedure WordsP W; tag(w) eq Wrds; syslsp procedure TruncateWords(V,I); If Not WordsP V then NonWordsError(V,'TruncateWords) else if not IntP I then NonIntegerError(I,'TruncateWords) else begin scalar Len,Len2,VI; VI:=WRDInf V; Len:=WRDLen VI; If Len=I then return V; % Already the size If Len<I then return StdError "Cannot Lengthen a Words in TruncateWords"; If Len<(-1) then return StdError "Cant TruncateWords to less then -1"; @VI := MkItem(HWRDS,I); WrdItm(VI, I+1) := MkItem(HWRDS, Len-I-2); return V end; syslsp procedure GetWords(WRD, I); %. Retrieve the I'th entry of WRD begin scalar StripV, StripI; return if WordsP WRD then if IntP I then % can't have Wordss bigger than INUM << StripV := WRDInf WRD; StripI := IntInf I; if StripI >= 0 and StripI <= WRDLen StripV then WRDItm(StripV, StripI) else StdError BldMsg('"Subscript %r in GetWords is out of range", I) >> else IndexError(I, 'GetWords) else NonWordsError(WRD, 'GetWords); end; syslsp procedure PutWords(WRD, I, Val); %. Store Val at I'th position of WRD begin scalar StripV, StripI; return if WordsP WRD then if IntP I then % can't have Wordss bigger than INUM << StripV := WRDInf WRD; StripI := IntInf I; if StripI >= 0 and StripI <= WRDLen StripV then WRDItm(StripV, StripI) := Val else StdError BldMsg('"Subscript %r in PutWords is out of range", I) >> else IndexError(I, 'PutWords) else NonWordsError(WRD, 'PutWords); end; syslsp procedure UpbW V; %. Upper limit of Words V if WordsP V then MkINT WRDLen WRDInf V else NIL; off Syslisp; END; |
Added psl-1983/util/zbasic.build version [b1e95bf621].
> > | 1 2 | CompileTime load ZBoot; in "zbasic.lsp"$ |
Added psl-1983/util/zbasic.lsp version [9dd663d2dc].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZBASIC contains 6 packages -- (1) YLSTS -- useful functions for lists. (2) YNUMS -- useful functions for numbers. (3) YSTRS -- useful functions for strings. (4) YIO -- useful functions for user io. (5) YCNTRL -- useful functions for program control. (6) YRARE -- functions we use now, but may eliminate. ") (!* " YLSTS -- BASIC LIST UTILITIES CCAR ( X:any ):any CCDR ( X:any ):any LAST ( X:list ):any NTH-CDR ( L:list N:number ):list NTH-ELT ( L:list N:number ):elt of list NTH-TAIL( L:list N:number ):list TAIL-P ( X:list Y:list ):extra-boolean NCONS ( X:any ): (CONS X NIL) KWOTE ( X:any ): '<eval of #X> MKQUOTE ( X:any ): '<eval of #X> RPLACW ( X:list Y:list ):list DREMOVE ( X:any L:list ):list REMOVE ( X:any L:list ):list DSUBST ( X:any Y:any Z:list ):list LSUBST ( NEW:list OLD:list X:any ):list COPY ( X:list ):list TCONC ( P:list X:any ): tconc-ptr LCONC ( P:list X:list ):list CVSET ( X:list ):set ENTER ( ELT:element SET:list ):set ABSTRACT( FN:function L:list ):list EACH ( L:list FN:function ):extra-boolean SOME ( L:list FN:function ):extra-boolean INTERSECTION ( SET1:list SET2:list ):extra-boolean SETDIFFERENCE ( SET1:list SET2:list ):extra-boolean SUBSET ( SET1:any SET2:list ):extra boolean UNION ( X:list Y:list ):list SEQUAL ( X:list Y:list ):extra boolean MAP2C ( X:list Y:list FN:function ):NIL MAP2 ( X:list Y:list FN:function ):NIL ATSOC ( ALST:list, KEY:atom ):any ") (FLUID '(!#SET2)) (!* "CCAR( X:any ):any ---- Careful Car. Returns car of x if x is a list, else NIL.") (CDE CCAR (!#X) (COND ((PAIRP !#X) (CAR !#X)))) (!* "CCDR( X:any ):any ---- Careful Cdr. Returns cdr of x if x is a list, else NIL.") (CDE CCDR (!#X) (COND ((PAIRP !#X) (CDR !#X)))) (!* "LAST( X:list ):any ---- Returns the last cell in X. E.g. (LAST '(A B C)) = (C), (LAST '(A B . C)) = C.") (!* (CDE LAST (!#X) (COND ((ATOM !#X) !#X) ((NULL (CDR !#X)) !#X) (T (LAST (CDR !#X))))) ) (CDM LAST (!#X) (CONS 'LASTPAIR (CDR !#X))) (!* "NTH-CDR( L:list N:number ):list ------- Returns the nth cdr of list--0 is the list, 1 the cdr ...") (CDE NTH!-CDR (!#L !#N) (COND ((LESSP !#N 1) !#L) ((ATOM !#L) NIL) (T (NTH!-CDR (CDR !#L) (SUB1 !#N))))) (!* "NTH-TAIL( L:list N:number ):list ------- Returns the nth tail of list--1 is the list, 2 the cdr ...") (CDE NTH!-TAIL (!#L !#N) (COND ((LESSP !#N 2) !#L) ((ATOM !#L) NIL) (T (NTH!-TAIL (CDR !#L) (SUB1 !#N))))) (!* "NTH-ELT( L:list N:number ):list ------- Returns the nth elt of list--1 is the car, 2 the cadr ...") (CDE NTH!-ELT (!#L !#N) (CAR (NTH!-TAIL !#L !#N))) (!* "TAIL-P( X:list Y:list ):extra-boolean ------ If X is a non-nil tail of Y (X eq cdr Y or cddr Y or...), return X. Renamed to avoid a conflict with TAILP in compiler") (CDE TAIL!-P (!#X !#Y) (COND (!#X (PROG NIL LP (COND ((ATOM !#Y) (RETURN NIL)) ((EQ !#X !#Y) (RETURN !#X))) (SETQ !#Y (CDR !#Y)) (GO LP))))) (!* " NCONS( X:any ): (CONS X NIL) ----- Returns (CONS X NIL) ") (!* (CDE NCONS (!#X) (CONS !#X NIL)) ) (!* " KWOTE( X:any ): '<eval of #X> MKQUOTE( X:any ): '<eval of #X> ------- Returns the quoted value of its argument. ") (CDM KWOTE (!#X) (CONS 'MKQUOTE (CDR !#X))) (!* (CDE MKQUOTE (!#X) (LIST 'QUOTE !#X)) ) (!* "RPLACW( X:list Y:list ):list ------ Destructively replace the Whole list X by Y.") (!* (CDE RPLACW (!#X !#Y) (RPLACA (RPLACD !#X (CDR !#Y)) (CAR !#Y))) ) (!* "DREMOVE( X:any L:list ):list ------- Remove destructively all equal occurrances of X from L.") (CDE DREMOVE (!#X !#L) (COND ((ATOM !#L) NIL) ((EQUAL !#X (CAR !#L)) (COND ((CDR !#L) (PROGN (RPLACA !#L (CADR !#L)) (RPLACD !#L (CDDR !#L)) (DREMOVE !#X !#L))))) (T (PROG (!#Z) (SETQ !#Z !#L) LP (COND ((ATOM (CDR !#L)) (RETURN !#Z)) ((EQUAL !#X (CADR !#L)) (RPLACD !#L (CDDR !#L))) (T (SETQ !#L (CDR !#L)))) (GO LP))))) (!* "REMOVE( X:any L:list ):list ------ Return copy of L with all equal occurrences of X removed.") (CDE REMOVE (!#X !#L) (COND ((ATOM !#L) !#L) ((EQUAL (CAR !#L) !#X) (REMOVE !#X (CDR !#L))) (T (CONS (CAR !#L) (REMOVE !#X (CDR !#L)))))) (!* "COPY( X:list ):list ---- Make a copy of X--EQUAL but not EQ (except for atoms).") (!* (CDE COPY (!#X) (SUBST 0 0 !#X)) ) (!* "DSUBST( X:any Y:any Z:list ):list ------ Destructively substitute copies(??) of X for Y in Z.") (!* (CDE DSUBST (!#X !#Y !#Z) (PROG (!#B) (COND ((EQUAL !#Y (SETQ !#B !#Z)) (RETURN (COPY !#X)))) LP (COND ((VECTORP !#Z) (RETURN (PROG (!#I) (SETQ !#I (UPBV !#Z)) LOOP (COND ((LESSP !#I 1) (RETURN NIL))) (PUTV !#Z !#I (DSUBST !#X !#Y (GETV !#Z !#I))) (SETQ !#I (SUB1 !#I)) (GO LOOP)))) ((ATOM !#Z) (RETURN !#B)) ((EQUAL !#Y (CAR !#Z)) (RPLACA !#Z (COPY !#X))) (T (DSUBST !#X !#Y (CAR !#Z)))) (COND ((AND !#Y (EQUAL !#Y (CDR !#Z))) (PROGN (RPLACD !#Z (COPY !#X)) (RETURN !#B)))) (SETQ !#Z (CDR !#Z)) (GO LP))) ) (!* "DSUBST is the same as SubstIP.") (CDM DSUBST (!#X) (CONS 'SUBSTIP (CDR !#X))) (!* "LSUBST( NEW:list OLD:list X:any ):list ------ Substitute elts of NEW (splicing) for the element old in X") (CDE LSUBST (!#NEW !#OLD !#X) (COND ((NULL !#X) NIL) ((VECTORP !#X) (PROG (!#V !#I) (SETQ !#I (UPBV !#X)) (SETQ !#V (MKVECT !#I)) LOOP (COND ((LESSP !#I 1) (RETURN !#V))) (PUTV !#V !#I (LSUBST !#NEW !#OLD (GETV !#V !#I))) (SETQ !#I (SUB1 !#I)) (GO LOOP))) ((ATOM !#X) (COND ((EQUAL !#OLD !#X) !#NEW) (T !#X))) ((EQUAL !#OLD (CAR !#X)) (NCONC (COPY !#NEW) (LSUBST !#NEW !#OLD (CDR !#X)))) (T (CONS (LSUBST !#NEW !#OLD (CAR !#X)) (LSUBST !#NEW !#OLD (CDR !#X)))) )) (!* (!* "TCONC( P:list X:any ): tconc-ptr ----- Pointer consists of (CONS LIST (LAST LIST)). Returns (and alters) pointer consisting of (CONS LIST1 (LAST LIST1)), where LIST1 = (NCONC1 LIST X). Avoids searching down the list as nconc1 does, by pointing at last elt of list for nconc1. To use, setq ptr to (NCONS NIL), tconc elts, return car of ptr.") (CDE TCONC (!#P !#X) (COND ((NULL !#P) (CONS (SETQ !#X (NCONS !#X)) !#X)) ((ATOM !#P) (PROGN (PRINT !#P) (ERROR 24 "BAD ARGUMENT 0 TCONC"))) ((CDR !#P) (RPLACD !#P (CDR (RPLACD (CDR !#P) (NCONS !#X))))) (T (RPLACA (RPLACD !#P (SETQ !#X (NCONS !#X))) !#X)))) (!* "LCONC( P:list X:list ):list ----- Same as TCONC, but NCONCs instead of NCONC1s.") (CDE LCONC (!#P !#X) (PROG (!#Y) (COND ((NULL !#X) (RETURN !#P)) ((OR (ATOM !#X) (CDR (SETQ !#Y (LAST !#X)))) (PRINT !#X)) ((NULL !#P) (RETURN (CONS !#X !#Y))) ((ATOM !#P) (PRINT !#P)) ((NULL (CAR !#P)) (RETURN (RPLACA (RPLACD !#P !#Y) !#X))) (T (PROGN (RPLACD (CDR !#P) !#X) (RETURN (RPLACD !#P !#Y))))) (ERROR 25 "BAD ARGUMENT 0 LCONC"))) ) (!* "CVSET( X:list ):list -------------------- Converts list to set, i.e., removes redundant elements.") (CDE CVSET (!#X) (PROG (!#RES) (COND ((NULL !#X) (RETURN NIL))) (SETQ !#RES (NCONS NIL)) LOOP (COND ((NULL !#X) (RETURN (CAR !#RES)))) (COND ((NOT (MEMBER (CAR !#X) (CDR !#X))) (TCONC !#RES (CAR !#X)))) (SETQ !#X (CDR !#X)) (GO LOOP))) (!* "ENTER( ELT:element SET:list ):list ----- Returns (ELT . SET) if ELT is not member of SET, else SET.") (CDE ENTER (!#ELT !#SET) (COND ((MEMBER !#ELT !#SET) !#SET) (T (CONS !#ELT !#SET)))) (!* "ABSTRACT( FN:function L:list ):list -------- Returns list of elts of list satisfying FN.") (CDE ABSTRACT (!#FN !#L) (PROG (!#ABSTRACTED) (SETQ !#ABSTRACTED (NCONS NIL)) (MAPC !#L (FUNCTION (LAMBDA (!#Z) (COND ((APPLY !#FN (LIST !#Z)) (TCONC !#ABSTRACTED !#Z)))))) (RETURN (CAR !#ABSTRACTED)))) (!* "EACH( L:list FN:function ):extra boolean ---- Returns L if each elt satisfies FN, else NIL.") (CDE EACH (!#L !#FN) (PROG (!#LIS) (SETQ !#LIS !#L) LOOP (COND ((NULL !#LIS) (RETURN (COND (!#L !#L) (T T)))) ((NOT (APPLY !#FN (NCONS (CAR !#LIS)))) (RETURN NIL))) (SETQ !#LIS (CDR !#LIS)) (GO LOOP))) (!* "SOME( L:list FN:function ):extra boolean ---- Returns the first tail of the list whose CAR satisfies function.") (CDE SOME (!#L !#FN) (PROG NIL LOOP (COND ((NULL !#L) (RETURN NIL)) ((APPLY !#FN (LIST (CAR !#L))) (RETURN !#L))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "INTERSECTION( #SET1:list #SET2:list ):extra boolean ------------ Returns list of elts in SET1 which are also members of SET2 ") (CDE INTERSECTION (!#SET1 !#SET2) (ABSTRACT (FUNCTION INTERSECTION1) !#SET1)) (CDE INTERSECTION1 (!#ELT) (MEMBER !#ELT !#SET2)) (!* "SETDIFFERENCE( #SET1:list #SET2:list ):extra boolean ------------- Returns all elts of SET1 not members of SET2.") (CDE SETDIFFERENCE (!#SET1 !#SET2) (ABSTRACT (FUNCTION SETDIFFERENCE1) !#SET1)) (CDE SETDIFFERENCE1 (!#ELT) (NOT (MEMBER !#ELT !#SET2))) (!* "SUBSET( #SET1:any #SET2:list ):extra boolean ------ Returns SET1 if each element of SET1 is a member of SET2.") (CDE SUBSET (!#SET1 !#SET2) (AND !#SET1 (EACH !#SET1 (FUNCTION SUBSET1)))) (CDE SUBSET1 (!#ELT) (MEMBER !#ELT !#SET2)) (!* "UNION( X:list Y:list ):list ----- Returns the union of lists X, Y") (CDE UNION (!#X !#Y) (APPEND !#X (SETDIFFERENCE !#Y !#X))) (!* "SEQUAL( X:list Y:list ):extra boolean ------ Returns X if X and Y are set-equal: same length and X subset of Y.") (CDE SEQUAL (!#X !#Y) (AND (EQUAL (LENGTH !#X) (LENGTH !#Y)) (SUBSET !#X !#Y))) (!* "MAP2( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired tails of X and Y.") (DE MAP2 (!#L1 !#L2 !#FN) (PROG NIL LOOP (COND ((NULL (AND !#L1 !#L2)) (COND ((OR !#L1 !#L2) (ERROR 0 "MAP2: mismatched lists")) (T (RETURN NIL))))) (APPLY !#FN (LIST !#L1 !#L2)) (SETQ !#L1 (CDR !#L1)) (SETQ !#L2 (CDR !#L2)) (GO LOOP))) (!* "MAP2C( X:list Y:list FN:function ):NIL ------ Applies FN (of two arguments) to successive paired elts of X and Y.") (DE MAP2C (!#L1 !#L2 !#FN) (PROG NIL LOOP (COND ((NULL (AND !#L1 !#L2)) (COND ((OR !#L1 !#L2) (ERROR 0 "MAP2C: mismatched lists")) (T (RETURN NIL))))) (APPLY !#FN (LIST (CAR !#L1) (CAR !#L2))) (SETQ !#L1 (CDR !#L1)) (SETQ !#L2 (CDR !#L2)) (GO LOOP))) (!* "ATSOC( ALST:list, KEY:atom ):any ----- Like ASSOC, except uses an EQ check. Returns first element of ALST whose CAR is KEY.") (!* (CDE ATSOC (KEY ALST) (COND ((NULL ALST) NIL) ((EQ (CAAR ALST) KEY) (CAR ALST)) (T (ATSOC KEY (CDR ALST))))) ) (!* " YNUMS -- BASIC NUMBER UTILITIES ADD1 ( number ):number EXPR SUB1 ( number ):number EXPR ZEROP ( any ):boolean EXPR MINUSP ( number ):boolean EXPR PLUSP ( number ):boolean EXPR POSITIVE( X:any ):extra-boolean EXPR NEGATIVE( X:any ):extra-boolean EXPR NUMERAL ( X:number/digit/any ):boolean EXPR GREAT1 ( X:number Y:number ):extra-boolean EXPR LESS1 ( X:number Y:number ):extra-boolean EXPR GEQ ( X:number Y:number ):extra-boolean EXPR LEQ ( X:number Y:number ):extra-boolean EXPR ODD ( X:integer ):boolean EXPR SIGMA ( L:list FN:function ):integer EXPR RAND16 ( ):integer EXPR IRAND ( N:integer ):integer EXPR ") (!* "The DEC compiler may optimize calls to PLUS2, DIFFERENCE, EQUAL, LESSP, etc. by converting them to calls to ADD1, SUB1, ZEROP, MINUSP, etc. This will create circular defintions in the conditional defintions, about which the compiler will complain. Such complaints can be ignored.") (!* (COND ((AND (CODEP (CCDR (GETD 'ADD1))) (CODEP (CCDR (GETD 'SUB1))) (CODEP (CCDR (GETD 'MINUSP)))) (PROGN (TERPRI) (PRIN2 "Ignore any circular definition msg for ADD1, SUB1, MINUSP") (TERPRI)))) (!* "ADD1( number ):number EXPR ---- Note: DEC compiler optimizes (PLUS2 N 1) into (ADD1 N). ") (CDE ADD1 (!#N) (PLUS2 !#N 1)) (!* "SUB1( number ):number EXPR ---- Note: DEC compiler optimizes (DIFFERENCE N 1) into (SUB1 N). ") (CDE SUB1 (!#N) (DIFFERENCE !#N 1)) (!* "ZEROP( X:any ):boolean EXPR ----- Returns non-nil iff X equals 0.") (CDE ZEROP (!#X) (EQN !#X 0)) (!* "MINUSP( N:number ):boolean EXPR ------ Returns non-nil iff N is less than 0.") (CDE MINUSP (!#N) (LESSP !#N 0)) ) (!* "PLUSP( N:number ):boolean EXPR ----- Returns non-nil iff N is greater than 0.") (CDE PLUSP (!#N) (GREATERP !#N 0)) (!* "ODD( X:integer ):boolean EXPR --- Returns T if x is odd, else NIL. WARNING: EVENP is used by REDUCE to test if a list has even length. ODD and EVENP are thus highly distinct.") (CDE ODD (!#X) (EQN 1 (REMAINDER !#X 2))) (!* "POSITIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a positive number.") (CDE POSITIVE (!#X) (AND (NUMBERP !#X) (GREATERP !#X 0))) (!* "NEGATIVE( X:any ):boolean EXPR -------- Returns non-nil iff X is a negative number.") (CDE NEGATIVE (!#X) (AND (NUMBERP !#X) (LESSP !#X 0))) (!* "NUMERAL( X:any ): boolean EXPR ------- Returns true for both numbers and digits. Some dialects had been treating the digits as numbers, and this fn is included as a replacement for NUMBERP where NUMBERP might really be checking for digits. N.B.: Digits are characters and thus ID's") (DE NUMERAL (!#X) (OR (DIGIT !#X) (NUMBERP !#X))) (!* "GREAT1( X:number Y:number ):extra-boolean EXPR ------ Returns X if it is strictly greater than Y, else NIL. GREATERP is simpler if only T/NIL is needed.") (CDE GREAT1 (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (GREATERP !#X !#Y)) !#X))) (!* "LESS1( X:number Y:number ):extra-boolean EXPR ----- Returns X if it is strictly less than Y, else NIL LESSP is simpler if only T/NIL is needed.") (CDE LESS1 (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (LESSP !#X !#Y)) !#X))) (!* (!* "GEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is greater than or equal to Y, else NIL.") (CDE GEQ (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (NOT (LESSP !#X !#Y))) !#X))) (!* "LEQ( X:number Y:number ):extra-boolean EXPR --- Returns X if it is less than or equal to Y, else NIL.") (CDE LEQ (!#X !#Y) (COND ((AND (NUMBERP !#X) (NUMBERP !#Y) (NOT (GREATERP !#X !#Y))) !#X))) ) (!* "SIGMA( L:list, FN:function ):integer EXPR ----- Returns sum of results of applying FN to each elt of LST.") (CDE SIGMA (!#L !#FN) (COND ((NULL !#L) 0) (T (PLUS2 (APPLY !#FN (LIST (CAR !#L))) (SIGMA (CDR !#L) !#FN))))) (!* "RAND16( ):integer EXPR IRAND ( N:integer ):integer EXPR ------ Linear-congruential random-number generator. To avoid dependence upon the big number package, we are forced to use 16-bit numbers, which means the generator will cycle after only 2^16. The randomness obtained should be sufficient for selecting choices in VOCAL, but not for monte-carlo experiments and other sensitive stuff.") (GLOBAL '(G!:RANDOM G!:RADD G!:RMUL G!:RMOD)) (!* "decimal 14933 = octal 35125, decimal 21749 = octal 52365 ") (SETQ G!:RANDOM 0) (SETQ G!:RADD 14933) (SETQ G!:RMUL 21749) (SETQ G!:RMOD (TIMES 256 256)) (!* "Returns a new 16-bit unsigned random integer. Leftmost bits are most random so you shouldn't use REMAINDER to scale this to range") (DE RAND16 NIL (SETQ G!:RANDOM (REMAINDER (TIMES G!:RMUL (PLUS G!:RADD G!:RANDOM)) G!:RMOD))) (!* "Scale new random number to range 0 to N-1 with approximately equal probability. Uses times/quotient instead of remainder to make best use of high-order bits which are most random") (DE IRAND (N) (QUOTIENT (TIMES (RAND16) N) G!:RMOD)) (!* " YSTRS -- BASIC STRING UTILITIES EXPLODEC ( X:any ):char-list EXPR EXPLODE2 ( X:any ):char-list EXPR FLATSIZE ( X:str ):integer EXPR FLATSIZE2( X:str ):integer EXPR NTHCHAR ( X:str N:number ):char-id EXPR ICOMPRESS( LST:lst ):<interned id> EXPR SUBSTR ( STR:str START:num LENGTH:num ):string EXPR CAT-DE ( L: list of strings ):string EXPR CAT-ID-DE( L: list of strings ):<uninterned id> EXPR SSEXPR ( S: string ):<interned id> EXPR ") (!* (!* "EXPLODE2( X:any ):char-list EXPR EXPLODEC( X:any ):char-list EXPR -------- List of characters which would appear in PRIN2 of X. If either is built into the interpreter, we will use that defintion for both. Otherwise, the definition below should work, but inefficiently. Note that this definition does not support vectors and lists. (The DEC and IBM interpreters support EXPLODE and EXPLODE2 by using the same internal algorithm that is used for PRIN1 (PRIN2), but put the chars generated into a list instead of printing them. Thus, they work on arbitrary s-expressions.) ") (!* "If either EXPLODEC or EXPLODE2 is defined, the CDE does nothing.") (COND ((GETD 'EXPLODEC) (FLAG '(EXPLODE2) 'LOSE))) (CDE EXPLODE2 (!#X) (PROG (!#BIG !#TAIL) (COND ((IDP !#X) (GO IDS)) ((STRINGP !#X) (GO STRS)) ((NUMBERP !#X) (RETURN (EXPLODE !#X))) ((CODEP !#X) (RETURN (EXPLODE !#X))) (T (ERROR "EXPLODE2 -- bad argument"))) (!* "For ids -- Note: last elt of #BIG will never be bang unless char before it was also a bang.") IDS (SETQ !#TAIL (SETQ !#BIG (EXPLODE !#X))) IDLP (COND ((EQUAL (CAR !#TAIL) '!!) (RPLACW !#TAIL (CDR !#TAIL))) ((NULL (CDR !#TAIL)) (RETURN !#BIG))) (SETQ !#TAIL (CDR !#TAIL)) (GO IDLP) (!* "For strings. #BIG has at least 2 elts, the quotes") STRS (SETQ !#TAIL (SETQ !#BIG (EXPLODE !#X))) STRLP(COND ((NULL (CDDR !#TAIL)) (PROGN (RPLACD !#TAIL NIL) (RETURN (CDR !#BIG)))) ((EQUAL (CAR (SETQ !#TAIL (CDR !#TAIL))) '!") (RPLACD !#TAIL (CDDR !#TAIL)))) (GO STRLP))) (REMFLAG '(EXPLODEC EXPLODE2) 'LOSE) (CDE EXPLODEC (!#X) (EXPLODE2 !#X)) (CDE EXPLODE2 (!#X) (EXPLODEC !#X)) (!* "Note: According to the STANDARD LISP REPORT, EXPLODE and EXPLODE2 are only defined for atoms. If your interpreter does not support extended EXPLODE and EXPLODE2, then change the second CDE's below for FLATSIZE and FLATSIZE2 to get recursive versions of them.") (!* " FLATSIZE( X:any ):integer EXPR -------- Number of chars in a PRIN1 of X. Also equals length of list created by EXPLODE of X, assuming that EXPLODE extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN1, but count chars instead of printing them. ") (CDE FLATSIZE (!#X) (LENGTH (EXPLODE !#X))) (!* "If your EXPLODE only works for atoms, comment out the above CDE and turn the CDE below into DE.") (CDE FLATSIZE (E) (COND ((ATOM E) (LENGTH (EXPLODE E))) (T ((LAMBDA (L1 D) (COND ((NULL D) (PLUS L1 2)) (T ((LAMBDA (L2) (COND ((ATOM D) (PLUS 5 L1 L2)) (T (PLUS 1 L1 L2)))) (FLATSIZE D))))) (FLATSIZE (CAR E)) (CDR E))))) (!* " FLATSIZE2( X:any ):integer EXPR --------- Number of chars in a PRIN2 of X. Also equals length of list created by EXPLODE2 of X, assuming that EXPLODE2 extends to arbitrary s-expressions. DEC and IBM interpreters use the same internal algorithm that is used for PRIN2, but count chars instead of printing them. ") (!* " FLATSIZE will often suffice for FLATSIZE2 ") (CDE FLATSIZE2 (!#X) (LENGTH (EXPLODE2 !#X))) (!* "If your EXPLODE2 only works for atoms, comment out the CDE above and turn the CDE below into DE.") (CDE FLATSIZE2 (E) (COND ((ATOM E) (LENGTH (EXPLODE2 E))) (T ((LAMBDA (L1 D) (COND ((NULL D) (PLUS L1 2)) (T ((LAMBDA (L2) (COND ((ATOM D) (PLUS 5 L1 L2)) (T (PLUS 1 L1 L2)))) (FLATSIZE2 D))))) (FLATSIZE2 (CAR E)) (CDR E))))) ) (!* " NTHCHAR( X:any, N:number ):character-id EXPR ------- Returns nth character of EXPLODE2 of X.") (CDE NTHCHAR (!#X !#N) (PROG (!#Y) (COND ((SETQ !#Y (NTH!-TAIL (EXPLODE2 !#X) !#N)) (RETURN (CAR !#Y)))))) (!* "ICOMPRESS( LST:list ):interned atom EXPR --------- Returns INTERN'ed atom made by COMPRESS.") (!* (CDE ICOMPRESS (!#LST) (INTERN (COMPRESS !#LST))) ) (!* "Implode is the same as ICOMPRESS, but more efficient.") (CDM ICOMPRESS (!#X) (CONS 'IMPLODE (CDR !#X))) (!* "SUBSTR( STR:string START:number LENGTH:number ):string EXPR ------ Returns a substring of the given LENGTH beginning with the character at location START in the string. NB: The first location of the string is 0. If START or LENGTH is negative, 0 is assumed. If the length given would exceed the end of the string, the subtring returned quietly goes to end of string, no error.") (!* (CDE SUBSTR (!#STR !#START !#LENGTH) (PROG (!#BIG !#TAIL) (COND ((NOT (STRINGP !#STR)) (ERROR 0 "SUBSTR -- argument not a string.")) ((OR (NOT (NUMBERP !#START)) (NOT (NUMBERP !#LENGTH))) (ERROR 0 "SUBSTR -- start or length not number")) ((LESSP !#LENGTH 1) (RETURN "")) ((EQUAL !#STR "") (RETURN "")) ((MINUSP !#START) (SETQ !#START 0))) (!* "Fall thru when CDR of #BIG is desired first character") (SETQ !#BIG (EXPLODE !#STR)) LP (COND ((MINUSP (SETQ !#START (SUB1 !#START))) NIL) ((NULL (CDR (SETQ !#BIG (CDR !#BIG)))) (RETURN "")) ((EQUAL (CAR !#BIG) '!") (PROGN (!* "Next char must also be quote") (SETQ !#BIG (CDR !#BIG)) (GO LP))) (T (GO LP))) (!* "CDR of #BIG is desired first character") (!* "When length drops below zero, chop off remainder") (!* "If list ends first, make string from what we have") (SETQ !#TAIL !#BIG) LP2 (COND ((MINUSP (SETQ !#LENGTH (SUB1 !#LENGTH))) (RPLACD !#TAIL (LIST '!"))) ((NULL (CDR (SETQ !#TAIL (CDR !#TAIL)))) NIL) ((EQUAL (CAR !#TAIL) '!") (PROGN (SETQ !#TAIL (CDR !#TAIL)) (GO LP2))) (T (GO LP2))) (RETURN (COMPRESS (RPLACA !#BIG '!"))))) ) (!* "SUBSTR is handled more efficiently by PSL function SUB") (CDE SUBSTR (!#S !#ST !#LEN) (SUB !#S (COND ((MINUSP !#ST) 0) (T !#ST)) (SUB1 !#LEN))) (!* "CAT-DE( L: list of expressions ):string EXPR ------- Returns a string made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT macro.") (DE CAT!-DE (!#L) (COMPRESS (CONS '!" (NCONC (MAPCAN !#L (FUNCTION EXPLODE2)) (LIST '!"))))) (!* "CAT-ID-DE( L: list of any ):uninterned id EXPR ------- Returns an id made from the concatenation of the prin2 names of the expressions in the list. Usually called via CAT-ID macro.") (DE CAT!-ID!-DE (!#L) (COMPRESS (MAPCAN !#L (FUNCTION EXPLODE2)))) (!* "SSEXPR( S: string ): id EXPR ------ Returns ID `read' from string. Not very robust.") (DE SSEXPR (!#STR) (COND ((STRINGP !#STR) (ICOMPRESS (EXPLODE2 !#STR))) (T !#STR))) (!* "YIO -- simple I/O utilities. All EXPR's. CONFIRM (#QUEST: string ):boolean EATEOL ():NIL TTY-DE (#L: list ):NIL TTY-TX-DE (#L: list ):NIL TTY-XT-DE (#L: list ):NIL TTY-TT-DE (#L: list ):NIL TTY-ELT (#X: elt ):NIL PRINA (#X: any ):NIL PRIN1SQ (#X: any ):NIL PRIN2SQ (#X: any ):NIL PRINCS (#X: single-char-id ):NIL --queue-code-- SEND ():NIL SEND-1 (#EE) ENQUEUE (#FN #ARG) Q-PRIN1 (#E: any ):NIL Q-PRINT (#E: any ):NIL Q-PRIN2 (#E: any ):NIL Q-TERPRI () ONEARG-TERPRI (#E: any ):NIL Q-TYO (#N: ascii-code ):NIL Q-PRINC (#C: single-char-id ):NIL * Q-TTY-DE (#CMDS: list ):NIL * Q-TTY-XT-DE (#CMDS: list ):NIL * Q-TTY-TX-DE (#CMDS: list ):NIL * Q-TTY-TT-DE (#CMDS: list ):NIL ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (FLAG '(PRINT PRIN1 PRIN2 PRINC SETCUR TYO PPRINT TERPRI POSN PPOS) 'SAY!:PRINT) (DE PRINT2 (!#X) (PROGN (PRIN2 !#X) (TERPRI) !#X)) (DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) (SETQ !#ANS (UPPER!-CASE (READCH))) (COND ((EQUAL !#ANS !$EOL!$) (SETQ !#ANS (UPPER!-CASE (READCH))))) (COND ((EQUAL !#ANS 'Y) (PROGN (EATEOL) (RETURN T))) ((EQUAL !#ANS 'N) (PROGN (EATEOL) (RETURN NIL))) ((EQUAL !#ANS '!?) (PROGN (EATEOL) (GO LP0))) (T (PROGN (EATEOL) (TTY!-XT "Please type Y, N or ?.")))) (GO LP1))) (CDE UPPER!-CASE (CH) (PROG (TMP) (COND ((AND (LITER CH) (SETQ TMP (MEMQ CH '(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)))) (RETURN (CAR (NTH!-TAIL '(Z Y X W V U T S R Q P O N M L K J I H G F E D C B A) (LENGTH TMP))))) (T (RETURN CH))))) (!* DE CONFIRM (!#QUEST) (PROG (!#ANS) LP0 (TTY!-XT !#QUEST) LP1 (SEND) (SETQ !#ANS (CAR (EXPLODEC (READ)))) (COND ((EQ !#ANS 'Y) (PROGN (EATEOL) (RETURN T))) ((EQ !#ANS 'N) (PROGN (EATEOL) (RETURN NIL))) ((EQ !#ANS '!?) (GO LP0)) (T (TTY!-XT "Please type Y, N or ?."))) (GO LP1))) (!* "Eat (discard) text until $EOL$ or <ESC> seen. <ESC> meaningful only on PDP-10 systems. $EOL$ meaningful only on correctly-implemented Standard-LISP systems. ") (DE EATEOL NIL (PROG (!#CH) LP (SETQ !#CH (READCH)) (COND ((MEMQ !#CH (LIST '!$EOL!$ !$EOL!$)) (RETURN NIL))) (GO LP))) (!* "An idea whose time has not yet come... ") (!* DE TTY!-DE (EOLS!#BEFORE !#L EOLS!#AFTER) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) LP1 (COND ((ONEP EOLS!#BEFORE) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#BEFORE) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#BEFORE (SUB1 EOLS!#BEFORE)) (GO LP1)))) (MAPC !#L (FUNCTION TTY!-ELT)) LP1 (COND ((ONEP EOLS!#AFTER) (TTY!-ELT !$EOL!$)) ((ZEROP EOLS!#AFTER) NIL) (T (PROGN (TTY!-ELT !$EOL!$) (SETQ EOLS!#AFTER (SUB1 EOLS!#AFTER)) (GO LP2)))) (WRS OLD!#CHAN))) (!* "So, for now at least, ... ") (DE TTY!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (MAPC !#L (FUNCTION TTY!-ELT)) (WRS OLD!#CHAN))) (DE TTY!-TX!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (TTY!-ELT !$EOL!$) (MAPC !#L (FUNCTION TTY!-ELT)) (WRS OLD!#CHAN))) (DE TTY!-XT!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (MAPC !#L (FUNCTION TTY!-ELT)) (TTY!-ELT !$EOL!$) (WRS OLD!#CHAN))) (DE TTY!-TT!-DE (!#L) (PROG (OLD!#CHAN) (SETQ OLD!#CHAN (WRS NIL)) (TTY!-ELT !$EOL!$) (MAPC !#L (FUNCTION TTY!-ELT)) (TTY!-ELT !$EOL!$) (WRS OLD!#CHAN))) (DE TTY!-ELT (!#E) (COND ((EQ !#E !$EOL!$) (Q!-TERPRI)) (T (Q!-PRIN2 !#E)))) (!* "PRINA( X:any ): any ----- Prin2s expression, after TERPRIing if it is too big for line, or spacing if it is not at the beginning of a line. Returns the value of X. Except for the space, this is just PRIN2 in the IBM interpreter.") (DE PRINA (!#X) (PROGN (COND ((LEQ (CHRCT) (FLATSIZE !#X)) (TERPRI)) ((GREATERP (POSN) 0) (PRIN2 " "))) (PRIN2 !#X))) (!* "CHRCT (): <number> ----- CHaRacter CounT left in line. Also a CDE in YPP.LSP -- built into IMSSS DEC interpreter.") (CDE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (!* "BINARY (#X: boolean): old-value ------ Stub for non-IMSSS interpreters. In IMSSS interpreter, will put terminal into binary mode or take it out, according to argument, and return old value.") (CDE BINARY (!#X) NIL) (!* "PRIN1SQ (#X: any) ------- PRIN1, Safe, use apostrophe for Quoted expressions. This is essentially a PRIN1 which tries not to exceed the right margin. It exceeds it only in those cases where the pname of a single atom exceeds the entire linelength. In such cases, <big> is printed at the terminal as a warning. (QUOTE xxx) structures are printed in 'xxx form to save space. Again, this is a little superfluous for the IBM interpreter. ") (DE PRIN1SQ (!#X) (PROG (!#SIZE) (COND ((ATOM !#X) (PROGN (SETQ !#SIZE (FLATSIZE !#X)) (COND ((LESSP (CHRCT) !#SIZE) (PROGN (TERPRI) (COND ((LESSP (CHRCT) !#SIZE) (TTY "<big>")))))) (RETURN (PRIN1 !#X)))) ((AND (EQ (CAR !#X) 'QUOTE) (CDR !#X) (NULL (CDDR !#X)) (NOT (NUMBERP (CADR !#X)))) (PROGN (PRINCS "'") (RETURN (PRIN1SQ (CADR !#X)))))) (PRINCS "(") LP (PRIN1SQ (CAR !#X)) (SETQ !#X (CDR !#X)) (COND ((NULL !#X) (RETURN (PRINCS ")")))) (PRINCS " ") (COND ((NULL (ATOM !#X)) (GO LP))) (PRINCS ".") (PRINCS " ") (PRIN1SQ !#X) (PRINCS ")"))) (!* "PRIN2SQ (#X: any) ------- PRIN2, Safe, use apostrophe for Quoted expressions. Just like PRIN1SQ, but uses PRIN2 as a basis. ") (DE PRIN2SQ (!#X) (PROG (!#SIZE) (COND ((ATOM !#X) (PROGN (SETQ !#SIZE (FLATSIZE !#X)) (COND ((LESSP (CHRCT) !#SIZE) (PROGN (TERPRI) (COND ((LESSP (CHRCT) !#SIZE) (TTY "<big>")))))) (RETURN (PRIN2 !#X)))) ((AND (EQ (CAR !#X) 'QUOTE) (CDR !#X) (NULL (CDDR !#X)) (NOT (NUMBERP (CADR !#X)))) (PROGN (PRINCS "'") (RETURN (PRIN2SQ (CADR !#X)))))) (PRINCS "(") LP (PRIN2SQ (CAR !#X)) (SETQ !#X (CDR !#X)) (COND ((NULL !#X) (RETURN (PRINCS ")")))) (PRINCS " ") (COND ((NULL (ATOM !#X)) (GO LP))) (PRINCS ".") (PRINCS " ") (PRIN2SQ !#X) (PRINCS ")"))) (!* "PRINCS (#X: single-character-atom) ------- PRINC Safe. Does a PRINC, but first worries about right margin. ") (DE PRINCS (!#X) (PROGN (COND ((LESSP (CHRCT) 1) (TERPRI))) (PRINC !#X))) (!* "1980 Jul 24 -- New Queued-I/O routines. To interface other code to this new I/O method, the following changes must be made in other code: PRIN2 --> TTY TERPRI --> $EOL$ inside a TTY, which causes Q-TERPRI to be called TYO --> Q-TYO PRIN1, PRINT -- These are used only for debugging. Do a (SEND) just before starting to print things in realtime, or use Q-PRIN1 etc. TTY -- Ok, expands into TTY-DE which calls Q-PRIN2 and Q-TERPRI. SAY -- I don't know what to do with this crock. It seems to be a poor substitute for TTY. If so it can be changed to TTY with the arguments fixed to be correct. <!GRAM>LPARSE.LSP ") (GLOBAL '(!*BATCHOUT !*BATCHQUEUE !*BATCHMAX !*BATCHCNT G!:WASTED!:SENDS G!:GOOD!:SENDS G!:GOOD!:OUTPUTS)) (!* "When *BATCHOUT is NIL, output is done in realtime and *BATCHQUEUE remains NIL. When *BATCHOUT is true, output is queued and SEND executes&dequeues it later.") (!* "Initialize *BATCHQUEUE for TCONC operations.") (SETQ !*BATCHQUEUE (NCONS NIL)) (!* "Initialize *BATCHMAX and *BATCHCNT ") (SETQ !*BATCHMAX 100) (SETQ !*BATCHCNT !*BATCHMAX) (DE SEND NIL (PROGN (COND ((CAR !*BATCHQUEUE) (PROGN (SETQ G!:GOOD!:SENDS (ADD1 G!:GOOD!:SENDS)) (SETQ G!:GOOD!:OUTPUTS (PLUS G!:GOOD!:OUTPUTS (LENGTH (CAR !*BATCHQUEUE)))) (MAPC (CAR !*BATCHQUEUE) (FUNCTION SEND!-1)) (SETQ !*BATCHCNT !*BATCHMAX) (!* "Set it again up for TCONC's.") (SETQ !*BATCHQUEUE (NCONS NIL)))) (T (SETQ G!:WASTED!:SENDS (ADD1 G!:WASTED!:SENDS)))))) (DE SEND!-1 (!#EE) (APPLY (CAR !#EE) (NCONS (CDR !#EE)))) (DE ENQUEUE (!#FN !#ARG) (PROGN (COND ((ZEROP (SETQ !*BATCHCNT (SUB1 !*BATCHCNT))) (SEND))) (SETQ !*BATCHQUEUE (TCONC !*BATCHQUEUE (CONS !#FN !#ARG))))) (DE Q!-PRIN1 (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRIN1 !#E)) (1 (PRIN1 !#E)))) (DE Q!-PRINT (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRINT !#E)) (1 (PRINT !#E)))) (DE Q!-PRIN2 (!#E) (COND (!*BATCHOUT (ENQUEUE 'PRIN2 !#E)) (1 (PRIN2 !#E)))) (DE Q!-TERPRI NIL (COND (!*BATCHOUT (ENQUEUE 'ONEARG!-TERPRI NIL)) (1 (TERPRI)))) (DE ONEARG!-TERPRI (!#E) (TERPRI)) (DE Q!-TYO (!#N) (COND (!*BATCHOUT (ENQUEUE 'TYO !#N)) (1 (TYO !#N)))) (DE Q!-PRINC (!#C) (COND (!*BATCHOUT (ENQUEUE 'PRINC !#C)) (1 (PRINC !#C)))) (!* " These call PRIN2, so they would cause double-enqueuing. ") (!* DE Q!-TTY!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-DE !#CMDS)) (1 (TTY!-DE !#CMDS)))) (!* DE Q!-TTY!-XT!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-XT!-DE !#CMDS)) (1 (TTY!-XT!-DE !#CMDS)))) (!* DE Q!-TTY!-TX!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-TX!-DE !#CMDS)) (1 (TTY!-TX!-DE !#CMDS)))) (!* DE Q!-TTY!-TT!-DE (!#CMDS) (COND (!*BATCHOUT (ENQUEUE 'TTY!-TT!-DE !#CMDS)) (1 (TTY!-TT!-DE !#CMDS)))) (SETQ G!:WASTED!:SENDS (SETQ G!:GOOD!:SENDS (SETQ G!:GOOD!:OUTPUTS 0))) (!* " YCNTRL -- ROUTINES INVOLVED WITH PROGRAM CONTROL STRUCTURES CATCH ( EXP:s-expression LABELS:id or idlist ):any EXPR THROW ( VALU:any LABEL:id ): error label EXPR ERRSET-DE ( #EXP #LBL ):any EXPR APPLY# ( ARG1: function ARG2: argument:list ):any EXPR BOUND ( X:any ):boolean EXPR MKPROG ( VARS:id-lst BODY:exp ):prog EXPR BUG-STOP (): any EXPR ") (GLOBAL '(!$THROWN!$ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* (!* "CATCH( EXP:s-expression LABELS:id or idlist ): any EXPR ----- For use with throw. If no THROW occurs in expression, then returns value of expression. If thrown label is MEMQ or EQ to labels, then returns thrown value. OW, thrown label is passed up higher. Expression should be quoted, as in ERRORSET.") (CDE CATCH (!#EXP !#LABELS) (PROG (!#EE) (COND ((PAIRP (SETQ !#EE (ERRORSET !#EXP G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (RETURN (CAR !#EE))) ((OR (EQ !#LABELS T) (EQ !#EE !#LABELS) (MEMQ !#EE !#LABELS)) (RETURN !$THROWN!$)) (T (ERROR !#EE NIL))))) (!* "THROW( VALU:any LABEL:id ): error label EXPR ----- Throws value with label up to enclosing CATCH having label. If there is no such CATCH, causes error.") (CDE THROW (!#VALU !#LABEL) (PROGN (SETQ !$THROWN!$ !#VALU) (ERROR !#LABEL NIL))) ) (!* "ERRSET-DE ( EXP LBL ):any EXPR Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them. Usually called via ERRSET macro.") (DE ERRSET!-DE (!#EXP !#LBL) (PROG (!#Y) (SETQ !#Y (ERRORSET !#EXP G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (COND ((OR (PAIRP !#Y) (NULL !#Y) (EQ !#Y '!$EOF!$) (EQ !#Y !#LBL) (EQ !#LBL 'ERRORX)) (RETURN !#Y)) (T (ERROR !#Y "propagated"))))) (!* "APPLY#(ARG1: function ARG2: argument:list): any EXPR ------ Like APPLY, but can use fexpr and macro functions.") (CDE APPLY!# (!#ARG1 !#ARG2) (EVAL (CONS !#ARG1 !#ARG2))) (!* "BOUND( X:any ): boolean EXPR ----- Returns T if X is a bound id.") (CDE BOUND (!#X) (AND (IDP !#X) (PAIRP (ERRORSET !#X NIL NIL)))) (!* "MKPROG( VARS:id-lst BODY:exp ) EXPR ------ Makes a prog around the body, binding the vars.") (CDE MKPROG (!#VARS !#BODY) (CONS 'PROG (CONS !#VARS !#BODY))) (!* "BUGSTOP ():NIL EXPR ------- Enter a read/eval/print loop, exit when OK is seen.") (DE BUG!-STOP (!#STR) (PROG (!#EXP OLD!#ICHAN OLD!#OCHAN OLD!#LENGTH) (SETQ OLD!#ICHAN (RDS NIL)) (SETQ OLD!#OCHAN (WRS NIL)) (SETQ OLD!#LENGTH (LINELENGTH NIL)) (LINELENGTH 78) (COND ((PAIRP !#STR) (TTY!-DE !#STR)) (T (PRIN2 !#STR))) LOOP (TERPRI) (PRIN2 "--Bug Stop-- Type OK to continue.") (TERPRI) (SETQ !#EXP (ERRORSET '(READ) T NIL)) (COND ((ATOM !#EXP) (PROGN (PRIN2 " --Read failed-- ") (GO LOOP)))) (SETQ !#EXP (CAR !#EXP)) (COND ((EQ !#EXP 'OK) (PROGN (EATEOL) (PRIN2 "resuming... ") (TERPRI) (LINELENGTH OLD!#LENGTH) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN NIL))) ((AND (PAIRP !#EXP) (EQ (CAR !#EXP) 'RETURN)) (PROGN (EATEOL) (PRIN2 "returning... ") (TERPRI) (LINELENGTH OLD!#LENGTH) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN (EVAL (CADR !#EXP)))))) (SETQ !#EXP (ERRORSET !#EXP T NIL)) (COND ((ATOM !#EXP) (PRIN2 " --EVAL failed-- ")) (T (PRIN1 (CAR !#EXP)))) (GO LOOP))) (!* " YRARE -- ROUTINES WHICH ARE USED, BUT OF DUBIOUS USEFULNESS ?? DELETE THESE ?? LOADV ( V:vector FN:function ):vector EXPR AMONG ( ALST KEY ITEM ) EXPR INSERT ( ITEM ALST KEY ) EXPR DCONS ( X:any Y:list ):list EXPR SUBLIST ( X:list P1:integer P2:integer ):list EXPR SUBLIST1( Y ) EXPR LDIFF ( X:list Y:list ):list EXPR used in editor/copy in ZEDIT MAPCAR# ( L:list FN:function ):any EXPR MAP# ( L:list FN:function ):any EXPR INITIALP( X:list Y:list ):boolean EXPR SUBLISTP( X:list Y:list ):list EXPR INITQ ( X:any Y:list R:fn ):boolean EXPR ") (!* "LOADV( V:vector FN:function ):vector EXPR ----- Loads vector with values. Function should be 1-place numerical. V[I] _ FN( I ). If value of function is 'novalue, then doesn't change value. ??") (CDE LOADV (!#V !#FN) (PROG (!#CTR !#LEN) (COND ((NOT (SETQ !#LEN (VECTORP !#V))) (RETURN !#V))) (SETQ !#CTR 0) LOOP (PUTV !#V !#CTR (APPLY !#FN (LIST !#CTR))) (COND ((LESSP !#CTR !#LEN) (PROGN (MAKE !#CTR 1) (GO LOOP)))) (RETURN !#V))) (!* "AMONG(ALST:association-list KEY:atom ITEM:atom):boolean EXPR ----- Tests if item is found under key in association list. Uses EQUAL tests.") (CDE AMONG (!#ALST !#KEY !#ITEM) (PROG (RES) (SETQ RES (ERRORSET (LIST 'AMONG1 (MKQUOTE !#ALST) (MKQUOTE !#KEY) (MKQUOTE !#ITEM)) NIL NIL)) (COND ((EQ RES 'FOUND) (RETURN T)) ((NULL RES) (RETURN NIL)) ((ATOM RES) (ERROR RES NIL))))) (CDE AMONG1 (!#ALST !#KEY !#ITEM) (MAPC !#ALST (FUNCTION (LAMBDA (!#ENTRY) (AND (EQUAL (CAR !#ENTRY) !#KEY) (MEMQ !#ITEM (CDR !#ENTRY)) (ERROR 'FOUND NIL)))))) (!* "INSERT (ITEM:item ALST:association:list KEY:any):association list ------ EXPR (destructive operation on ALST) Inserts item in association list under key or if key not present adds (KEY ITEM) to the ALST.") (CDE INSERT (!#ITEM !#ALST !#KEY) (PROG (!#AS!:ITEM) (COND ((SETQ !#AS!:ITEM (ASSOC !#KEY !#ALST)) (COND ((NOT (MEMBER !#ITEM (CCDR !#AS!:ITEM))) (RPLACD !#AS!:ITEM (CONS !#ITEM (CDR !#AS!:ITEM)))))) (T (DCONS (LIST !#KEY !#ITEM) !#ALST))) (RETURN !#ALST))) (!* "DCONS( X:any Y:list ):list EXPR ----- Destructively cons x to list.") (CDE DCONS (!#X !#Y) (PROGN (RPLACD !#Y (CONS (CAR !#Y) (CDR !#Y))) (RPLACA !#Y !#X))) (!* "SUBLIST( X:list P1:integer P2:integer ):list EXPR ------- Returns sublist from p1 to p2 positions, negatives counting from end. I.e., (SUBLIST '(A B C D E) 2 -2) = (B C D)") (CDE SUBLIST (!#X !#P1 !#P2) (LDIFF (NTH!-TAIL !#X (SETQ !#P1 (SUBLIST1 !#X !#P1))) (NTH!-TAIL !#X (ADD1 (SUBLIST1 !#X !#P2))))) (CDE SUBLIST1 (!#X !#Y) (COND ((LESSP !#Y 0) (MAX 1 (PLUS 1 !#Y (LENGTH !#X)))) (T !#Y))) (!* "LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X.") (CDE LDIFF (!#X !#Y) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) NIL) ((NULL !#Y) !#X) (T (PROG (!#V !#Z) (SETQ !#Z (SETQ !#V (NCONS (CAR !#X)))) LOOP (SETQ !#X (CDR !#X)) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) (RETURN !#Z))) (SETQ !#V (CDR (RPLACD !#V (NCONS (CAR !#X))))) (GO LOOP))))) (!* "MAPCAR#( L:list FN:function ):any EXPR ------- Extends mapcar to work on general s-expressions as well as lists. The return is of same form, i.e. (MAPCAR# 'ATOM '(A B C . D)) = (T T T . T) Also, if for any member of list the variable SPLICE is set to true by function, then for that member the return from the function is spliced into the return.") (CDE MAPCAR!# (!#L !#FN) (PROG (!#M !#SPLICE !#TEMP) (SETQ !#M (NCONS NIL)) LOOP (COND ((NULL !#L) (RETURN (CAR !#M))) ((ATOM !#L) (RETURN (COND ((NULL (CAR !#M)) (APPLY !#FN (LIST !#L))) (T (PROGN (RPLACD (CDR !#M) (APPLY !#FN (LIST !#L))) (CAR !#M))))))) (SETQ !#TEMP (APPLY !#FN (LIST (CAR !#L)))) (COND (!#SPLICE (PROGN (SETQ !#SPLICE NIL) (LCONC !#M !#TEMP))) (T (TCONC !#M !#TEMP))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "MAP#( L:list FN:function ):any EXPR ---- Extends map to work on general s-expressions as well as lists.") (CDE MAP!# (!#L !#FN) (PROG (!#MAPPED) LOOP (COND ((NULL !#L) (RETURN !#MAPPED))) (APPLY !#FN (LIST !#L)) (COND ((ATOM !#L) (RETURN !#MAPPED))) (SETQ !#L (CDR !#L)) (GO LOOP))) (!* "INITIALP( X:list Y:list ):boolean EXPR -------- Returns T if X is EQUAL to some ldiff of Y.") (CDE INITIALP (!#X !#Y) (COND ((NULL !#X) (COND (!#Y !#Y) (T T))) ((NULL !#Y) NIL) ((NOT (EQUAL (CAR !#X) (CAR !#Y))) NIL) (T (INITIALP (CDR !#X) (CDR !#Y))))) (!* "SUBLISTP( X:list Y:list ):list EXPR -------- Returns a tail of Y (or T) if X is a sublist of Y.") (CDE SUBLISTP (!#X !#Y) (COND ((NULL !#X) (COND (!#Y !#Y) (T T))) ((NULL !#Y) NIL) ((INITIALP !#X !#Y) T) (T (SUBLISTP !#X (CDR !#Y))))) (!* "INITQ( X:any Y:list R:fn ):boolean EXPR ----- Returns T if x is an initial portion of Y under the relation R.") (CDE INITQ (!#X !#Y !#R) (COND ((OR (NULL !#X) (NULL !#Y)) NIL) ((APPLY !#R (LIST (CAR !#X) (CAR !#Y))) (CONS (CAR !#X) (INITQ (CDR !#X) (CDR !#Y) !#R))))) |
Added psl-1983/util/zboot.build version [a01c9dacb4].
> > | 1 2 | compiletime load zboot; in "zboot.lsp"$ |
Added psl-1983/util/zboot.lsp version [16e9d05d1c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (DM !* (!#X) NIL) (SETQ !*EOLINSTRINGOK T) (!* "Needed for PSL, to avoid error messages while reading strings which contain carriage returns.") (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* " ZBOOT -- Bootstrapping functions and SLISP extensions ONEP (U) EXPR used where? LIST2 (U V) EXPR compiler support fn LIST3 (U V W) EXPR compiler support fn LIST4 (U V W X) EXPR compiler support fn LIST5 (U V W X Y) EXPR compiler support fn MAPOBL (!*PI!*) EXPR UTAH random utility REVERSIP (U) EXPR UTAH support fn WARNING (U) EXPR UTAH support fn IMSSS additions: (complement LOSE mechanism) CDEF (FDSCR TYPE) EXPR conditional function definition CDE (Z) FEXPR conditional expr definition CDF (Z) FEXPR conditional fexpr definition CDM (Z) FEXPR conditional macro definition CLAP( LAPCODE ) FEXPR conditional lap definition C-SETQ (#ARGS) FEXPR conditional setq These are for compatibility with the IBM interpreter: ERASE( #FILE: file descriptor ):NIL EXPR ") (!* "ARE THESE USED ONLY IN COMPILER PACKAGE?") (!* (REMFLAG '(LIST2 LIST3 LIST4 LIST5 REVERSIP) 'LOSE)) (!* (GLOBAL '(OBLIST))) (!* "IMSSS additions: ") (!* "CDEF( FNDSCR: pair, TYPE: {expr,fexpr,macro} ): {id,NIL} EXPR ---- Conditional function definition. #FNDSCR = (NAME ARGS BODY) #TYPE = {EXPR, FEXPR, or MACRO} If the function is already defined, a warning is printed, the function is not redefined, and nil is returned. Otherwise, the function is defined and the name is returned. CDEF is called by CDE, CDM and CDF, analogs to DE, DF and DM.") (!* (DE CDEF (!#FDSCR !#TYPE) (PROG (!#NAME !#NEWARGS !#NEWBODY !#OLDDEF) (COND ((ATOM !#FDSCR) (RETURN (WARNING "Bad arg to CDEF.")))) (SETQ !#NAME (CAR !#FDSCR)) (COND ((NOT (EQUAL (LENGTH !#FDSCR) 3)) (RETURN (WARNING (LIST "Bad args to CDEF for " !#NAME))))) (SETQ !#NEWARGS (CADR !#FDSCR)) (SETQ !#NEWBODY (CADDR !#FDSCR)) (COND ((NULL (SETQ !#OLDDEF (GETD !#NAME))) (RETURN (PUTD !#NAME !#TYPE (LIST 'LAMBDA !#NEWARGS !#NEWBODY)))) ((PAIRP (CDR !#OLDDEF)) (WARNING (LIST !#NAME " already " (LENGTH (CADDR !#OLDDEF)) "-arg " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE))) (T (WARNING (LIST !#NAME " is a compiled " (CAR !#OLDDEF) ", not redefined as " (LENGTH !#NEWARGS) "-arg " !#TYPE)))))) (DF CDE (!#Z) (CDEF !#Z 'EXPR)) (DF CDF (!#Z) (CDEF !#Z 'FEXPR)) (DF CDM (!#Z) (CDEF !#Z 'MACRO)) (!* "CLAP( LAPCODE ): {id,NIL} EXPR ---- Conditional lap definition. If the function already has a compiled definition, warning is given, the function is not redefined, and nil is returned. Otherwise, LAP is called.") (DE CLAP (LAP!#CODE) (PROG (!#ENTRY !#ID OLD!#DEF) (COND ((NULL (SETQ !#ENTRY (ASSOC '!*ENTRY LAP!#CODE))) (RETURN (WARNING "CLAP: No *ENTRY in lap code.")))) (SETQ !#ID (CADR !#ENTRY)) (SETQ OLD!#DEF (GETD !#ID)) (COND ((OR (NULL OLD!#DEF) (PAIRP (CDR OLD!#DEF))) (LAP LAP!#CODE)) (T (WARNING (LIST !#ID " is compiled " (CAR OLD!#DEF) ", not changed to compiled " (CADDR !#ENTRY) ".")))))) ) (DM CDE (!#X) (CONS 'DE (CDR !#X))) (DM CDF (!#X) (CONS 'DF (CDR !#X))) (DM CDM (!#X) (CONS 'DM (CDR !#X))) (!* "C-SETQ( ARGS: (id any)): any FEXPR ------ Conditional SETQ. If the cadr of #ARGS is already defined, it is not reset and its old value is returned. Otherwise, it acts like SETQ. ") (DF C!-SETQ (!#ARGS) (COND ((PAIRP (ERRORSET (CAR !#ARGS) NIL NIL)) (EVAL (CAR !#ARGS))) (T (SET (CAR !#ARGS) (EVAL (CADR !#ARGS)))))) (!* "This CDE is best left here to avoid bootstrapping problems.") (CDE WARNING (!#X!#) (PROG (!#CHAN!#) (SETQ !#CHAN!# (WRS NIL)) (TERPRI) (PRIN2 "*** ") (COND ((ATOM !#X!#) (PRIN2 !#X!#)) (T (MAPC !#X!# (FUNCTION PRIN2)))) (TERPRI) (WRS !#CHAN!#))) (!* (CDE ONEP (U) (OR (EQUAL U 1) (EQUAL U 1.0))) (CDE LIST2 (U V) (CONS U (CONS V NIL))) (CDE LIST3 (U V W) (CONS U (CONS V (CONS W NIL)))) (CDE LIST4 (U V W X) (CONS U (CONS V (CONS W (CONS X NIL))))) (CDE LIST5 (U V W X Y) (CONS U (CONS V (CONS W (CONS X (CONS Y NIL)))))) ) (!* "This definition of MAPOBL doesn't work in PSL, because the oblist has a different structure. MAPOBL is defined in the interpreter though.") (!*(CDE MAPOBL (!*PI!*) (FOREACH X IN OBLIST DO (FOREACH Y IN X DO (APPLY !*PI!* (LIST Y)))))) (!* (CDE REVERSIP (U) (PROG (X Y) (WHILE U (PROGN (SETQ X (CDR U)) (SETQ Y (RPLACD U Y)) (SETQ U X))) (RETURN Y))) ) (!* "ERASE( #FILE: file descriptor ):NIL EXPR ----- This is defined in the IBM interpreter to (irrevocably) delete a file from the file system, which is a highly necessary operation when you are not allowed versions of files. It should be a no-op in the TENEX interpreters until such an operation seems necessary. This assumes the user will delete and expunge old versions from the exec.") (CDE ERASE (!#FILE) NIL) |
Added psl-1983/util/zfiles.build version [8ffb82c309].
> > > | 1 2 3 | CompileTime load(ZBoot, ZBasic, ZMacro, If!-System); in "zfiles.lsp"$ in "zsys.lsp"$ |
Added psl-1983/util/zfiles.lsp version [c2f77b2248].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZFILES contains 2 packages -- (1) YFILES -- useful functions for accessing files. (2) YTOPCOM -- useful functions for compiling files. ") (!* " YFILES -- BASIC FILE ACCESSING UTILITIES FORM-FILE ( FILE:DSCR ): filename EXPR GRABBER ( SELECTION FILE:DSCR ): NIL EXPR DUMPER ( FILE:DSCR ): NIL EXPR DUMPFNS-DE ( SELECTION FILE:DSCR ): NIL EXPR DUMP-REMAINING ( SELECTION:list DUMPED:list ): NIL EXPR FCOPY ( IN:DSCR OUT:DSCR filedscrs ):boolean EXPR REFPRINT-FOR-GRAB-CTL( #X: any ):NIL EXPR G:CREFON Switched on by cross reference program CREF:FILE G:JUST:FNS Save only fn names in variable whose name is the first field of filename if T, O/W save all exprs in that variable G:FILES List of files read into LISP G:SHOW:TRACE Turns backtrace in ERRORSET on if T G:SHOW:ERRORS Prints ERRORSET error messages if T ") (GLOBAL '(G!:FILES G!:CREFON G!:JUST!:FNS)) (GLOBAL '(G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (FLUID '(F!:FILE!:ID F!:OLD!:FILE PPPRINT)) (FLUID '(DUMP!#ID)) (!* "GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE. See ZMACROS.") (!* "GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER IDS <file-dscr>) Like GRAB, but only reads in specified ids. See ZMACROS.") (!* "FORM-FILE( FILE:DSCR ): filename EXPR --------- Takes a file dscr, possibly NIL, and returns a file name corresponding to that dscr and suitable as an argument to OPEN. F:OLD:FILE is set to this file name for future reference. Meanwhile, F:FILE:ID is set to a lisp identifier, and the file name is put on the OPEN:FILE:NAME property of that identifier. The identifier can be used to hold info about the file. E.g. its value may be a list of objects read from the file. NB: FORM-FILE is at the lowest level of machine-independant code. MAKE-OPEN-FILE-NAME is a system dependant routine that creates file names specifically tailored to the version of SLISP in use. ") (DE FORM!-FILE (FILE!#DSCR) (PROG (!#TEMP) (COND ((IDP FILE!#DSCR) (MAKE FILE!#DSCR NCONS))) (!* "COND below: case 1--defaults to most recent file referenced case 2--virtual file name: access property list case 3--build usable file name from all or part of FILE:DSCR given") (COND ((NULL (CAR FILE!#DSCR)) (COND (F!:OLD!:FILE (PROGN (TTY " = " F!:FILE!:ID) (RETURN F!:OLD!:FILE))) (T (ERROR 0 "No file specified and no default file.")))) ((SETQ !#TEMP (GET (CAR FILE!#DSCR) 'OPEN!:FILE!:NAME)) (PROGN (SETQ F!:FILE!:ID (CAR FILE!#DSCR)) (RETURN (SETQ F!:OLD!:FILE !#TEMP)))) (T (RETURN (MAKE!-OPEN!-FILE!-NAME FILE!#DSCR)))))) (!* "GRABBER( SELECTION:id-list FILE:DSCR ):T EXPR ------- Opens the specified file, applies GRAB-EVAL-CTL to each expression on it, and then closes it. Returns T. See GRAB-EVAL-CTL for important side effects.") (DE GRABBER (!#SELECTION FILE!#DSCR) (PROG (!#Y EXPR!#READ !#ICHAN IBASE FILE!#ID FILE!#NAME) (SETQ FILE!#NAME (FORM!-FILE FILE!#DSCR)) (!* SETQ FILE!#NAME (GET FILE!#ID 'FILE!:NAME)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ G!:FILES (NCONC1 G!:FILES FILE!#ID)) (SET FILE!#ID (LIST NIL)) (SETQ IBASE (PLUS 5 5)) (RDS (SETQ !#ICHAN (OPEN FILE!#NAME 'INPUT))) LOOP (SETQ EXPR!#READ (ERRORSET '(READ) T G!:SHOW!:TRACE)) (COND (!#SELECTION (PRINA "."))) (COND ((AND (PAIRP EXPR!#READ) (NEQ !$EOF!$ (CAR EXPR!#READ))) (PROGN (ERRORSET (LIST 'GRAB!-EVAL!-CTL (MKQUOTE !#SELECTION) (MKQUOTE (CAR EXPR!#READ)) (MKQUOTE FILE!#ID)) T G!:SHOW!:TRACE) (COND ((NOT (SUBSET !#SELECTION (CDR (EVAL FILE!#ID)))) (GO LOOP)))))) (RDS NIL) (CLOSE !#ICHAN) (SET FILE!#ID (DREMOVE NIL (EVAL FILE!#ID))) (TERPRI) (RETURN T))) (!* "GRAB-EVAL-CTL( #SELECTION EXPR#READ FILE#ID ) EXPR ------------- Examines each expression read from file, and determines whether to EVAL that expression. Also decides whether to append the expression, or an id taken from it, or nothing at all, to the value of the file id poined at by FILE#ID. The file id is stored for use as an argument to DUMP or COMPILE, for example. Note: G:JUSTFNS suppresses the storage of comments from the file. When reading LAP files, no list of fns is made.") (DE GRAB!-EVAL!-CTL (!#SELECTION EXPR!#READ FILE!#ID) (COND ((ATOM EXPR!#READ) NIL) ((AND (EQ (CAR EXPR!#READ) 'SETQ) (EQ (CADR EXPR!#READ) FILE!#ID)) NIL) ((AND (OR (NULL !#SELECTION) (MEMBER (CADR EXPR!#READ) !#SELECTION)) (MEMBER (CAR EXPR!#READ) '(DE DF DM SETQ CDE CDF CDM C!-SETQ))) (PROGN (PRINA (CADR EXPR!#READ)) (EVAL EXPR!#READ) (COND ((AND (NEQ (CADR EXPR!#READ) 'IBASE) (NOT (MEMBER (CADR EXPR!#READ) (EVAL FILE!#ID))) (NOT (MEMBER (CAR EXPR!#READ) '(LAP CLAP)))) (NCONC1 (EVAL FILE!#ID) (CADR EXPR!#READ)))))) ((NULL !#SELECTION) (PROGN (OR G!:JUST!:FNS (NCONC1 (EVAL FILE!#ID) EXPR!#READ)) (!* "G:JUST:FNS reduces consumption of string space.") (COND (G!:CREFON (REFPRINT!-FOR!-GRAB!-CTL EXPR!#READ))) (EVAL EXPR!#READ) (PRINA (CCAR EXPR!#READ)))))) (!* "DUMPER( FILE:DSCR : file-dscr ): NIL EXPR ------ Dumps file onto disk. Filename as in GRABBER. Prettyprints the defined functions, set variables, and evaluated expressions which are members of the value of the variable filename. (For DEC versions: If IBASE neq 10, puts (SETQ IBASE current:base) at head of file.)") (DE DUMPER (!#DSCR) (PROG (!#OCHAN OLD!#OCHAN FILE!#ID) (!* SETQ FILE!#ID (FORM!-FILE !#DSCR)) (SETQ !#OCHAN (OPEN (FORM!-FILE !#DSCR) 'OUTPUT)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ OLD!#OCHAN (WRS !#OCHAN)) (MAPC (EVAL FILE!#ID) (FUNCTION PP1)) (CLOSE !#OCHAN) (WRS OLD!#OCHAN) (RETURN T))) (!* "DUMPFNS-DE( FNS FILE:DSCR ): NIL EXPR ---------- Like DUMPER. Copies old file, putting new definitions for specified functions/variables. E.g.: (DUMPFNS-DE '(A B) '(FOO)) will first copy verbatim all the expressions on FOO.LSP which do not define A or B. Then the core definitions of A and B are dumped onto the file.") (DE DUMPFNS!-DE (!#SELECTION FILE!#DSCR) (PROG (FILE!#ID FILE!#NAME IBASE !#OLD !#DUMPED !#ICHAN !#OCHAN OLD!#ICHAN OLD!#OCHAN !#ID) (SETQ FILE!#NAME (FORM!-FILE FILE!#DSCR)) (SETQ FILE!#ID F!:FILE!:ID) (SETQ IBASE (PLUS 5 5)) (SETQ OLD!#ICHAN (RDS (SETQ !#ICHAN (OPEN FILE!#NAME 'INPUT)))) (SETQ OLD!#OCHAN (WRS (SETQ !#OCHAN (OPEN FILE!#NAME 'OUTPUT)))) LOOP (SETQ !#OLD (ERRORSET '(READ) G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (COND ((OR (ATOM !#OLD) (EQ (SETQ !#OLD (CAR !#OLD)) !$EOF!$)) (PROGN (!* "dump remaining selected objects") (DUMP!-REMAINING !#SELECTION !#DUMPED) (CLOSE !#ICHAN) (CLOSE !#OCHAN) (RDS OLD!#ICHAN) (WRS OLD!#OCHAN) (RETURN T)))) (COND ((AND (PAIRP !#OLD) (MEMBER (CAR !#OLD) '(SETQ DE DF DM CDE CDF CDM)) (MEMBER (SETQ !#ID (CADR !#OLD)) !#SELECTION)) (PROGN (SETQ !#DUMPED (CONS (CONS !#ID (COND ((EQ 'SETQ (CAR !#OLD)) (PROGN (PP!-VAL !#ID) 'VAL)) (T (PROGN (PP!-DEF !#ID) 'DEF)))) !#DUMPED)) (GO LOOP)))) (COND ((AND (PAIRP !#OLD) (EQ (CAR !#OLD) 'SETQ) (EQ (CADR !#OLD) 'IBASE)) (ERRORSET !#OLD T G!:SHOW!:TRACE))) (TERPRI) (APPLY PPPRINT (LIST !#OLD 1)) (TERPRI) (TERPRI) (GO LOOP))) (!* "DUMP-REMAINING( SELECTION:list DUMPED:list ) EXPR -------------- Taken out of DUMPFNS for ease of reading. Dumps those properties of items in selection which have not already been dumped.") (DE DUMP!-REMAINING (!#SELECTION !#DUMPED) (PROG (DUMP!#ID !#IGNORE) LOOP (SETQ DUMP!#ID (CAR !#SELECTION)) (SETQ !#IGNORE (MAPCAN !#DUMPED (FUNCTION (LAMBDA (!#PAIR) (COND ((EQ DUMP!#ID (CAR !#PAIR)) (LIST (CDR !#PAIR))))) ))) (OR (MEMBER 'VAL !#IGNORE) (PP!-VAL DUMP!#ID)) (OR (MEMBER 'DEF !#IGNORE) (PP!-DEF DUMP!#ID)) (COND ((SETQ !#SELECTION (CDR !#SELECTION)) (GO LOOP))))) (!* "FCOPY( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the prettyprinter. Useful for removing angle brackets or for tightening up function format. Returns T on normal exit, NIL if error reading file. ") (DE FCOPY (IN!#DSCR OUT!#DSCR) (PROG (IN!#CHAN OUT!#CHAN !#EXP) (SETQ IN!#CHAN (OPEN (FORM!-FILE IN!#DSCR) 'INPUT)) (SETQ OUT!#CHAN (OPEN (FORM!-FILE OUT!#DSCR) 'OUTPUT)) (RDS IN!#CHAN) (WRS OUT!#CHAN) (LINELENGTH 80) LOOP (SETQ !#EXP (ERRORSET '(READ) T T)) (COND ((OR (ATOM !#EXP) (EQ (CAR !#EXP) !$EOF!$)) (PROGN (CLOSE IN!#CHAN) (RDS NIL) (CLOSE OUT!#CHAN) (WRS NIL) (RETURN (EQ !#EXP !$EOF!$))))) (SETQ !#EXP (CAR !#EXP)) (TTY ".") (COND ((ATOM !#EXP) (SPRINT !#EXP 1)) ((MEMQ (CAR !#EXP) '(DE DF DM CDE CDF CDM)) (PROGN (PRIN2 "(") (PRIN1 (CAR !#EXP)) (PRIN2 " ") (PRIN1 (CADR !#EXP)) (PRIN2 " ") (PRIN1 (CADDR !#EXP)) (S2PRINT " " (CADDDR !#EXP)) (PRIN2 ")"))) ((EQ (CAR !#EXP) 'SETQ) (PROGN (PRIN2 "(") (PRIN1 (CAR !#EXP)) (PRIN2 " ") (PRIN1 (CADR !#EXP)) (S2PRINT " " (CADDR !#EXP)) (PRIN2 ")"))) (T (SPRINT !#EXP 1))) (TERPRI) (TERPRI) (GO LOOP))) (!* "FCOPY-SQ ( IN:DSCR filename, OUT:DSCR filename ):boolean EXPR ----- Reformats file using the compacting printer. Letterizes and reports via '<big>' message long strings. Returns T on normal exit, NIL if error reading file. ") (DE FCOPY!-SQ (IN!#DSCR OUT!#DSCR) (PROG (IN!#CHAN OUT!#CHAN !#EXP) (SETQ IN!#CHAN (OPEN (FORM!-FILE IN!#DSCR) 'INPUT)) (SETQ OUT!#CHAN (OPEN (FORM!-FILE OUT!#DSCR) 'OUTPUT)) (RDS IN!#CHAN) (WRS OUT!#CHAN) LOOP (SETQ !#EXP (ERRORSET '(READ) T T)) (COND ((ATOM !#EXP) (PROGN (CLOSE IN!#CHAN) (RDS NIL) (CLOSE OUT!#CHAN) (WRS NIL) (RETURN (EQ !#EXP !$EOF!$)))) ((EQ (SETQ !#EXP (CAR !#EXP)) !$EOF!$) (PROGN (CLOSE IN!#CHAN) (CLOSE OUT!#CHAN) (RETURN T)))) (TTY ".") (PRIN1SQ !#EXP) (TERPRI) (TERPRI) (GO LOOP))) (!* "Dummy -- may be replaced by real cref routine.") (DE REFPRINT!-FOR!-GRAB!-CTL (!#X) NIL) (!* " YTOPCOM -- Compiler Control functions (DF COMPILE-FILE (FILE:NAME) (DF COMPILE-IN-CORE (FILE:NAME) ") (!* "Commonly used globals. Declared in this file so each individual file doesn't have to declare them. ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "Other globals/fluids") (GLOBAL '(!*SAVEDEF)) (FLUID '(F!:FILE!:ID COMPILED!:FNS)) (!* "This flag is checked by COMPILE-FILE.") (FLAG '(EXPR FEXPR) 'COMPILE) (!* "PPLAP( MODE CODE ) EXPR ----- Prints the lap code in some appropriate format. Currently uses PRIN1SQ (PRIN1, Safe, use apostrophe to Quote non-numeric expressions).") (DE PPLAP (!#MODE !#CODE) (PRIN1SQ (LIST !#MODE (MKQUOTE !#CODE)))) (!* "COMPILE-FILE( FILE:DSCR ) FEXPR ------------ Reads the given file, and creates a corresponding LAP file. Each expression on the original file is mapped into an expression on the LAP file. Comments map into NIL. Function definitions map into the corresponding LAP code. These definitions are compiled, but NOT evaluated -- hence the functions will not be loaded into this core image by this routine. All other expressions are evaluated in an errorset then copied verbatim. EXCEPTION: UNFLUID is evalutated, but converted into a comment when printed, to avoid confusing loader. ") (FLUID '(QUIET_FASLOUT!*)) (!* "Controls printing of welcome message in FASLOUT.") (DF COMPILE!-FILE (FILE!:DSCR) (PROG (IN!:SEXPR LSP!:FILE LAP!:FILE OLD!:SAVEDEF LAP!:FN!:NAME LAP!:OUT QUIET_FASLOUT!* LAP!:FN LSP!:FILE!:ID OCHAN ICHAN TYPE MODE) (!* "*SAVEDEF Saves LAP code generated by the compiler on the property list of the function under indicator COMPEXP") (!* (SETQ OLD!:SAVEDEF !*SAVEDEF) (SETQ !*SAVEDEF T)) (SETQ QUIET_FASLOUT!* T) (GCMSG NIL) (!* "Note: If FILE:DSCR = (AAA BBB) then TENEX: from LSP:FILE = '<AAA>BBB.LSP', LSP:FILE:ID = BBB to LAP:FILE = '<AAA>BBB.LAP', LAP:FILE:ID = BBB CMS: from LSP:FILE = 'AAA BBB', LSP:FILE:ID = AAA to LAP:FILE = 'AAA LAP', LAP:FILE:ID = AAA This is non-ideal, since the first filename gets lost. It is not clear, however, what an elegant solution would be. Perhaps the file id should have a list of filenames, one for each extension... ") (SETQ LSP!:FILE (FORM!-FILE FILE!:DSCR)) (SETQ LSP!:FILE!:ID F!:FILE!:ID) (SETQ ICHAN (OPEN LSP!:FILE 'INPUT)) (!* "Try to create lap file corresponding to LSP file.") (SETQ LAP!:FILE (SUBST '!; 'LSP LSP!:FILE)) (!* "But if that doesn't work out..") (COND ((EQUAL LSP!:FILE LAP!:FILE) (SETQ LAP!:FILE (FORM!-FILE (CONS LSP!:FILE!:ID '!;))))) (!* SETQ LAP!:FILE!:ID F!:FILE!:ID) (ERRORSET (LIST 'ERASE (MKQUOTE LAP!:FILE)) G!:SHOW!:ERRORS G!:SHOW!:TRACE) (!*(SETQ OCHAN (OPEN LAP!:FILE 'OUTPUT))) (FASLOUT LAP!:FILE) (RDS ICHAN) (WHILE (AND (PAIRP (SETQ IN!:SEXPR (ERRORSET '(READ) NIL NIL))) (NOT (EQ (SETQ IN!:SEXPR (CAR IN!:SEXPR)) !$EOF!$))) (!* PROGN (SETQ COMPILED!:FNS NIL) (SETQ TYPE (SELECTQ (CAR IN!:SEXPR) ((DE CDE) 'EXPR) ((DF CDF) 'FEXPR) ((DM CDM) 'MACRO) NIL)) (SETQ MODE (SELECTQ (CAR IN!:SEXPR) ((CDE CDF CDM) 'CLAP) ((DE DF DM) 'LAP) NIL)) (COND ((FLAGP TYPE 'COMPILE) (PROG NIL (PRINA (SETQ LAP!:FN!:NAME (CADR IN!:SEXPR))) (SETQ LAP!:OUT (SIMPLIFYLAP (CONS (LIST '!*ENTRY LAP!:FN!:NAME TYPE (LENGTH (CADDR IN!:SEXPR))) (!&COMPROC (CONS 'LAMBDA (CDDR IN!:SEXPR)) LAP!:FN!:NAME)))) (WRS OCHAN) (!* LOOP (SETQ LAP!:OUT (CDR (REMPROP LAP!:FN!:NAME 'COMPEXP)))) (PPLAP MODE LAP!:OUT) (TERPRI) (!*(COND ((SETQ COMPILED!:FNS (DREMOVE LAP!:FN!:NAME COMPILED!:FNS)) (PROGN (SETQ LAP!:FN!:NAME (CCAR COMPILED!:FNS)) (GO LOOP))))) (WRS NIL) (PRINA "ok"))) ((MEMQ (CAR IN!:SEXPR) '(!* !*!*)) NIL) ((EQ (CAR IN!:SEXPR) 'UNFLUID) (EVAL IN!:SEXPR)) (T (PROGN (ERRORSET (LIST 'EVAL (MKQUOTE IN!:SEXPR)) T NIL) (!* "Be sure errors are printed to terminal") (WRS OCHAN) (SPRINT IN!:SEXPR 1) (TERPRI) (WRS NIL))))) (DFPRINTFASL IN!:SEXPR)) (SETQ !*SAVEDEF OLD!:SAVEDEF) (CLOSE ICHAN) (RDS NIL) (!* (CLOSE OCHAN)) (FASLEND))) (!* "COMPILE-IN-CORE( FILE:DSCR ):NIL FEXPR --------------- Compiles all EXPRS and FEXPRS on a file and loads compiled code into core. Creates a file FILE:NAME.cpl which is a compilation log consisting of the names of functions compiled and the space used in their loading.") (DF COMPILE!-IN!-CORE (FILE!:DSCR) (PROG (IN!:SEXPR LAP!:FN!:NAME LAP!:FN LOG!:FILE LOG!:CHAN LSP!:CHAN LSP!:FILE!:ID LSP!:FILE) (SETQ LSP!:FILE (FORM!-FILE FILE!:DSCR)) (SETQ LSP!:FILE!:ID F!:FILE!:ID) (SETQ LSP!:CHAN (OPEN LSP!:FILE 'INPUT)) (SETQ LOG!:FILE (FORM!-FILE (CONS LSP!:FILE!:ID 'CPL))) (SETQ LOG!:CHAN (OPEN LOG!:FILE 'OUTPUT)) (RDS LSP!:CHAN) (WHILE (AND (PAIRP (SETQ IN!:SEXPR (ERRORSET '(READ) G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (NOT (EQ !$EOF!$ (SETQ IN!:SEXPR (CAR IN!:SEXPR)))) (PAIRP (ERRORSET IN!:SEXPR G!:SHOW!:ERRORS G!:SHOW!:TRACE))) (COND ((MEMQ (CAR IN!:SEXPR) '(DE DF CDE CDF)) (PROGN (SETQ LAP!:FN!:NAME (CADR IN!:SEXPR)) (WRS LOG!:CHAN) (COMPILE (NCONS LAP!:FN!:NAME)) (WRS NIL) (PRINA LAP!:FN!:NAME))))) (SETQ COMPILED!:FNS NIL) (RDS NIL) (CLOSE LSP!:CHAN) (CLOSE LOG!:CHAN))) (!* "GCMSG( X:boolean ):any EXPR ----- Pre-defined in both SLISP and new IBM intpreter, so this cde shouln't do anything. GCMSG turns the garbage collection msgs on or off.") (CDE GCMSG (!#X) NIL) |
Added psl-1983/util/zmacro.build version [fba4d3e5b7].
> > | 1 2 | compiletime load(zboot,zbasic,zmacro); in "zmacro.lsp"$ |
Added psl-1983/util/zmacro.lsp version [767d0232b8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZMACRO contains two macro packages -- (1) YMACS -- basically useful macros and fexprs. (2) YSAIMACS -- macros used to simulate many SAIL constructs. ") (!* " YMACS -- USEFUL MACROS AND FEXPRS (see also YSAIMAC) * ( X:any ): NIL MACRO ** ( X:list ) MACRO NEQ ( X:any Y:any ):boolean MACRO NEQN ( X:any Y:any ):boolean MACRO NEQUAL ( X:any Y:any ):boolean MACRO MAKE ( variable template ) MACRO SETQQ ( variable value ) MACRO EXTEND ( function series ) MACRO DREVERSE( list ):list MACRO APPENDL ( lists ) MACRO NCONCL ( lists ) MACRO NCONC1 ( lst exp1 ... expn ): any MACRO SELECTQ ( exp cases last-resort ) MACRO WHILE ( test body ) MACRO REPEAT ( body test ) MACRO FOREACH ( var in/of lst do/collect exp ) MACRO SAY ( test expressions ) MACRO DIVERT ( channel expressions ) MACRO CAT ( list of any ):string MACRO CAT-ID ( list of any ):<uninterned id> MACRO TTY ( L:list ):NIL MACRO TTY-TX ( L:list ):NIL MACRO TTY-XT ( L:list ):NIL MACRO TTY-TT ( L:list ):NIL MACRO ERRSET ( expression label ) MACRO GRAB ( file ) MACRO GRABFNS ( ids file-dscr ) MACRO DUMP ( file-dscr ) MACRO DUMPFNS ( ids file-dscr ) MACRO used to expand macros: XP#SELECTQ (#L#) EXPR XP#WHILE (#BOOL #BODY) EXPR XP#FOREACH (#VAR #MOD #LST #ACTION #BODY) EXPR XP#SAY1 ( expression ) EXPR ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "In ZBOOT, not needed here." (CDM !* (!#X) NIL) ) (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* "**( X:list ) MACRO ===> (PROGN <lists>) For comments--all atoms are ignored, lists evaluated as in PROGN.") (CDM !*!* (!#X) (CONS 'PROGN (ABSTRACT (FUNCTION PAIRP) (CDR !#X)))) (!* "NEQ( X:any Y:any ):boolean MACRO ===> (NOT (EQ X Y)) ") (!* "Changed to CDM because NEQ in PSL means NOT EQUAL. We hope to change that situation, however.") (CDM NEQ (!#X) (LIST 'NOT (CONS 'EQ (CDR !#X)))) (!* "NEQN( X:any Y:any ):boolean MACRO ===> (NOT (EQN X Y)) ") (DM NEQN (!#X) (LIST 'NOT (CONS 'EQN (CDR !#X)))) (!* "NEQUAL( X:any Y:any ):boolean MACRO ===> (NOT (EQUAL X Y)) ") (DM NEQUAL (!#X) (LIST 'NOT (CONS 'EQUAL (CDR !#X)))) (!* "MAKE( variable template ) MACRO ===> (SETQ <var> <some form using var>) To change the value of a variable depending upon template. Uses similar format for template as editor MBD. There are 3 cases. 1) template is numerical: (MAKE VARIABLE 3) = (SETQ VARIABLE (PLUS VARIABLE 3)) 2) Template is a series, whose first element is an atom: (MAKE VARIABLE ASSOC ITEM) = (SETQ VARIABLE (ASSOC ITEM VARIABLE)) 3) Otherwise, variable is substituted for occurrences of * in template. (MAKE VARIABLE (ASSOC (CADR *) (CDDR *)) = (SETQ VARIABLE (ASSOC (CADR VARIABLE) (CDDR VARIABLE))") (CDM MAKE (!#X) (PROGN (SETQ !#X (CDR !#X)) (LIST 'SETQ (CAR !#X) (COND ((NUMBERP (CADR !#X)) (CONS 'PLUS !#X)) ((ATOM (CADR !#X)) (APPEND (CDR !#X) (LIST (CAR !#X)))) (T (SUBST (CAR !#X) '!* (CADR !#X))))))) (!* "SETQQ( variable value ) MACRO ===> (SETQ VARIABLE 'VALUE) ") (CDM SETQQ (!#X) (LIST 'SETQ (CADR !#X) (MKQUOTE (CADDR !#X)))) (!* "EXTEND( function series ) MACRO ===> (FN ELT1 (FN ELT2 ... (FN ELTn-1 ELTn))) Applies 2-place function to series, similarly to PLUS. E.g.: (EXTEND SETQ A B C D 5) = (SETQ A (SETQ B (SETQ C (SETQ D 5))))") (CDM EXTEND (!#X) (EXPAND (CDDR !#X) (CADR !#X))) (!* "DREVERSE( L: list ):list MACRO ===> (REVERSIP L) Synonym for REVERSIP.") (DM DREVERSE (!#X) (CONS 'REVERSIP (CDR !#X))) (!* "APPENDL( lists ) MACRO ===> (APPEND LIST1 (APPEND LIST2 ....)) EXPAND's APPEND to a list of arguments instead of just 2.") (CDM APPENDL (!#X) (EXPAND (CDR !#X) 'APPEND)) (!* "NCONCL( lists ) MACRO ===> (NCONC LST1 (NCONC LST2 ....)) EXPAND's NCONC to a list of arguments instead of just 2.") (CDM NCONCL (!#X) (EXPAND (CDR !#X) 'NCONC)) (!* "NCONC1( lst exp1 ... expn ): any MACRO ===> (NCONC LST (LIST EXP1 ... EXPn)) Destructively add exp1 ... exp-n to the end of lst.") (CDM NCONC1 (!#X) (LIST 'NCONC (CADR !#X) (CONS 'LIST (CDDR !#X)))) (!* "SELECTQ( exp cases last-resort ) MACRO ===> (COND ...) Exp is a lisp expression to be evaluated. Each case-i is of the form (key-i exp1 exp2...expm). Last-resort is a lisp expression to be evaluated. Generates a COND statement: If key-i is an atom, case-i becomes the cond-pair: ((EQUAL exp key-i) (PROGN exp1 exp2 ... expm)) If key-i is a list, case-i becomes the cond-pair: ((MEMBER exp key-i) (PROGN exp1 exp2 ... expm)) Last-resort becomes the final cond-pair: (T last-resort) If exp is non-atomic, it should not be re-evaluated in each clause, so a dummy variable (#SELECTQ) is set to the value of exp in the first test and that dummy variable is used in all successive tests. Note: (1) A FEXPR version of SELECTQ would forbid use of RETURN and GO. (2) The form created must NOT have a prog or lambda wrapped around the cond expression, as this would also forbid RETURN and GO. Since #SELECTQ can't be lambda-bound by any means whatsoever and remain consistent with the standard-lisp report (if GO or RETURN appears inside a consequent), there is no way we can make SELECTQ re-entrant. If you go into a break with ^B or ^H and execute another SELECTQ you will clobber the one and only incarnation of #SELECTQ, and if it happened to be in the middle of deciding which consequent to execute, then when you continue the computation it won't work correctly. Update -- IMSSS break pkg now tries to protect #SELECTQ. Update -- uses XP#SELECTQ which can be compiled to speed up macro expansion. ") (CDM SELECTQ (!#SLQ) (XP!#SELECTQ (CDR !#SLQ))) (DE XP!#SELECTQ (!#L!#) (PROG (!#FIRSTCL !#RESTCL !#RSLT) (SETQ !#RSLT (NCONS 'COND)) (COND ((ATOM (CAR !#L!#)) (SETQ !#FIRSTCL (SETQ !#RESTCL (CAR !#L!#)))) ((EQ (CAAR !#L!#) 'SETQ) (PROGN (SETQ !#FIRSTCL (CAR !#L!#)) (SETQ !#RESTCL (CADAR !#L!#)))) (T (SETQ !#FIRSTCL (LIST 'SETQ (SETQ !#RESTCL '!#SELECTQ) (CAR !#L!#))))) LP (COND ((CDR (SETQ !#L!# (CDR !#L!#))) (PROGN (NCONC !#RSLT (NCONS (CONS (LIST (COND ((ATOM (CAAR !#L!#)) 'EQUAL) (T 'MEMBER)) !#FIRSTCL (LIST 'QUOTE (CAAR !#L!#))) (COND ((NULL (CDDAR !#L!#)) (CDAR !#L!#)) (T (NCONS (CONS 'PROGN (CDAR !#L!#)))))))) (SETQ !#FIRSTCL !#RESTCL) (GO LP)))) (NCONC !#RSLT (NCONS (CONS T !#L!#))) (RETURN !#RSLT))) (!* "WHILE( test body ) MACRO ===> (PROG ...) <while loop> While test is true do body.") (!* (CDM WHILE (!#X) (XP!#WHILE (CADR !#X) (CDDR !#X))) (DE XP!#WHILE (!#BOOL !#BODY) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (NCONC (LIST 'PROG NIL !#LAB (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'RETURN NIL)))) (APPEND !#BODY (LIST (LIST 'GO !#LAB))))))) ) (!* (!* "REPEAT( body test ) MACRO ===> (PROG ...) <repeat loop> Repeat body until test is true. Jim found that this fn as we had it was causing compiler errors. The BODY was (CDDR U) and the BOOL was (CADR U). Question: Does the fact that Utah was unable to reproduce our compiler errors lie in this fact. Does function until test becomes non-NIL.") (CDM REPEAT (!#X) (XP!#REPEAT (CADR !#X) (CADDR !#X))) (DE XP!#REPEAT (!#BODY !#BOOL) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (LIST 'PROG NIL !#LAB !#BODY (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'GO !#LAB))))))) ) (!* (!* "FOREACH( var in/of lst do/collect exp ) MACRO ===> (MAPxx LST (FUNCTION (LAMBDA (VAR) EXP))) Undocumented FOREACH supplied by Utah. Required by compiler. Update: modified to call xp#foreach which can be compiled to speed up macro expansion.") (CDM FOREACH (!#X) (XP!#FOREACH (CADR !#X) (CADDR !#X) (CAR (SETQ !#X (CDDDR !#X))) (CADR !#X) (CADDR !#X))) (DE XP!#FOREACH (!#VAR !#MOD !#LST !#ACTION !#BODY) (PROG (!#FN) (SETQ !#FN (COND ((EQ !#ACTION 'DO) (COND ((EQ !#MOD 'IN) 'MAPC) (T 'MAP))) ((EQ !#MOD 'IN) 'MAPCAR) (T 'MAPLIST))) (RETURN (LIST !#FN !#LST (LIST 'FUNCTION (LIST 'LAMBDA (LIST !#VAR) !#BODY)))))) ) (!* "SAY( test expressions ) MACRO ===> (COND (<test> (PROGN (PRIN2 ...) (PRIN2 ...) ...))) If test is true then evaluate and prin2 all expressions. Exceptions: the value of printing functions, those flaged with SAY:PRINT (including: PRINT PRIN1 PRIN2 PRINC TYO PPRINT TERPRI POSN DOHOME DORIGH DOLEFT DOUP DODOWN DPYNCH DPYCHR SETCUR MOVECUR) are just evaluated. E.g.: (In the example @ is used for quotes) (SAY T @this @ (PRIN1 '!!AND!!) @ that@) appears as: this !!AND!! that ") (DM SAY (!#X) (LIST 'COND (LIST (CADR !#X) (CONS 'PROGN (MAPCAR (CDDR !#X) (FUNCTION XP!#SAY1)))))) (DE XP!#SAY1 (!#Y) (COND ((AND (PAIRP !#Y) (EQ (CAR !#Y) 'PRINTER)) (CADR !#Y)) ((AND (PAIRP !#Y) (FLAGP (CAR !#Y) 'SAY!:PRINT)) !#Y) (T (LIST 'Q!-PRIN2 !#Y)))) (FLAG '(Q!-PRINT Q!-PRIN1 Q!-PRIN2 Q!-PRINC SETCUR Q!-TYO PPRINT POSN PPOS TTY) 'SAY!:PRINT) (!* "DIVERT( channel expressions ) MACRO ===> (PROG (ochan) <select given chan> <eval exps> <select ochan>) Yields PROG that selects channel for output, evaluates each expression, and then reselects prior channel.") (CDM DIVERT (!#L) (CONS 'PROG (CONS (LIST 'OLD!#CHAN) (CONS (LIST 'SETQ 'OLD!#CHAN (LIST 'WRS (CADR !#L))) (APPEND (CDDR !#L) (LIST (LIST 'WRS 'OLD!#CHAN))))))) (!* "CAT( list of any ):string MACRO ===> (CAT-DE (LIST <list>)) Evaluates all arguments given and forms a string from the concatenation of their prin2 names. ") (CDM CAT (!#X) (LIST 'CAT!-DE (CONS 'LIST (CDR !#X)))) (!* "CAT-ID( list of any ):<uninterned id> MACRO ===> (CAT-ID-DE (LIST <list>)) Evaluates all arguments given and forms an id from the concatenation of their prin2 names. ") (CDM CAT!-ID (!#X) (LIST 'CAT!-ID!-DE (CONS 'LIST (CDR !#X)))) (!* "TTY ( L:list ):NIL MACRO TTY-TX( L:list ):NIL MACRO TTY-XT( L:list ):NIL MACRO TTY-TT( L:list ):NIL MACRO ===> (TTY-xx-DE (LIST <list>)) TTY is selected for output, then each elt of list is evaluated and PRIN2'ed, except for $EOL$'s, which cause a TERPRI. Then prior output channel is reselected. TTY-TX adds leading TERPRI. TTY-XT adds trailing TERPRI. TTY-TT adds leading and trailing TERPRI's. ") (!* "CDMs were making all of the following unloadable into existing QDRIVER.SAV core image. I flushed the 'C' July 27") (!* "TTY-DE now takes two extra arguments, for the number of TERPRIs to preceed and follow the other printed material.") (DM TTY (!#X) (LIST 'TTY!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TX (!#X) (LIST 'TTY!-TX!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-XT (!#X) (LIST 'TTY!-XT!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TT (!#X) (LIST 'TTY!-TT!-DE (CONS 'LIST (CDR !#X)))) (!* "ERRSET (expression label) MACRO ===> (ERRSET-DE 'exp 'label) Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them.") (CDM ERRSET (!#X) (LIST 'ERRSET!-DE (MKQUOTE (CADR !#X)) (MKQUOTE (CADDR !#X)))) (!* "GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE.") (DM GRAB (!#X) (LIST 'GRABBER NIL (MKQUOTE (CDR !#X)))) (!* "GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER FNS <file-dscr>) Like grab, but only reads in specified fns/vars.") (DM GRABFNS (!#X) (LIST 'GRABBER (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* "DUMP( <file description> ) MACRO ===> (DUMPER '<file-dscr>) Dumps file onto disk. Filename as in GRAB. Prettyprints.") (DM DUMP (!#X) (LIST 'DUMPER (MKQUOTE (CDR !#X)))) (!* "DUMPFNS( <ids> . <file dscr> ) MACRO ===> (DUMPFNS-DE <fns> '<file-dscr>) Like DUMP, but copies old file, inserting new defs for specified fns/vars") (DM DUMPFNS (!#X) (LIST 'DUMPFNS!-DE (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* " We are currently defining these to be macros everywhere, but might want them to be exprs while interpreted, in which case use the following to get compile-time macros.") (!* PUT 'NEQ 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQ !#X !#Y)))) (!* PUT 'NEQN 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQN !#X !#Y)))) (!* PUT 'NEQUAL 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQUAL !#X !#Y)))) (!* " YSAIMAC -- MACROS used to simulate SAIL constructs. macros: DO-UNTIL SAI-IF SAI2-IF SAI-DONE SAI-CONTINUE SAI-WHILE SAI-FOREACH SAI-FOR SAI-BEGIN PBEGIN PRETURN SAI-ASSIGN MSETQ SAI-COLLECT IFC OUTSTR SAI-SAY SAI-& SAI-LENGTH CVSEST CVSEN CVS SUBSTRING-FOR SUBSTRING-TO PUSHES PUSHVARS SLIST SAI-MAPC SAI-EQU auxiliary exprs used to expand macros: XP#SAY-IF XP#SAI-WHILE XP#SAI-FOREACH XP#SAI-FOR XP#SUBSTRING-TO ") (DM DO!-UNTIL (FORM) (LIST 'PROG NIL 'L (CADR FORM) (LIST 'COND (LIST (CADDDR FORM) NIL) (LIST 1 '(GO L))))) (!* "SAI-IF ( sailish if-expression ) MACRO (IF test1 THEN exp1 [ ELSEIF testi THEN expi ] [ELSE expn]) ===> (COND (test1 exp1) ... (testi expi) ... (T expn)) Embedded expressions do not cause embedded COND's, (unlike ALGOL!). Examples: (IF (ATOM Y) THEN (CAR X)) (IF (ATOM Y) THEN (CAR X) ELSE (CADR X)) (IF (ATOM Y) THEN (CAR X) ELSEIF (ATOM Z) THEN (CADR X)) ") (DM SAI!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DM SAI2!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DE XP!#SAI!-IF (IF!#X) (PROG (!#ANTE !#CONSEQ !#TEMP !#ANS) (SETQ !#ANS NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#ANTE (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ (SETQ !#TEMP (CAR IF!#X)) 'THEN) (SETQ IF!#X (CDR IF!#X)))) (SETQ !#CONSEQ NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#TEMP (CAR IF!#X)) (COND ((OR (EQ !#TEMP 'ELSE) (EQ !#TEMP 'ELSEIF) (EQ !#TEMP 'EF)) (RETURN NIL))) (SETQ !#CONSEQ (CONS !#TEMP !#CONSEQ)) (SETQ IF!#X (CDR IF!#X)) (GO WHTAG))))) (SETQ !#ANS (CONS (CONS !#ANTE (REVERSE !#CONSEQ)) !#ANS)) (COND ((NOT IF!#X) (RETURN NIL))) (SETQ !#TEMP (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ !#TEMP 'ELSE) (PROGN (SETQ !#ANS (CONS (CONS 'T IF!#X) !#ANS)) (RETURN NIL)))) (!* " MUST BE ELSEIF") (GO WHTAG))))) (RETURN (CONS 'COND (REVERSE !#ANS))))) (DM SAI!-DONE (C!#X) '(RETURN NIL)) (DM SAI!-CONTINUE (C!#X) '(GO CONTINUE!:)) (!* "SAI-WHILE ( sailish while-expression ) MACRO (WHILE b DO e1 e2 ... en) does e1,..., en as long as b is non-nil. ===> (PROG NIL CONTINUE: (COND ((NULL b) (RETURN NIL))) e1 ... en (GO CONTINUE:)) N.B. (WHILE b DO ... (RETURN e)) has the RETURN relative to the PROG in the expansion. As in SAIL, (CONTINUE) and DONE work as statements. (They are also macros.) ") (DM SAI!-WHILE (WH!#X) (XP!#SAI!-WHILE WH!#X)) (DE XP!#SAI!-WHILE (WH!#X) (APPENDL (LIST 'PROG NIL 'CONTINUE!: (LIST 'COND (LIST (LIST 'NOT (CADR WH!#X)) (LIST 'RETURN NIL)))) (SAI!-IF (EQ (CADDR WH!#X) 'DO) THEN (CDDDR WH!#X) ELSE (CDDR WH!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOREACH (FOREACH!#X) (XP!#SAI!-FOREACH FOREACH!#X)) (DE XP!#SAI!-FOREACH (FORE!#X) (APPENDL (LIST 'PROG '(FORE!#TEMP) (LIST 'SETQ 'FORE!#TEMP (CADDDR FORE!#X)) 'CONTINUE!: '(SAI!-IF (NULL FORE!#TEMP) THEN (RETURN NIL)) (LIST 'SETQ (CADR FORE!#X) '(CAR FORE!#TEMP)) '(SETQ FORE!#TEMP (CDR FORE!#TEMP))) (CDR (CDDDDR FORE!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOR (FOR!#X) (XP!#SAI!-FOR FOR!#X)) (DE XP!#SAI!-FOR (FOR!#X) (CONS 'PROG (CONS NIL (CONS (LIST 'SETQ (CADR FOR!#X) (CADDDR FOR!#X)) (CONS 'FOR!#LOOP!: (CONS (LIST 'SAI!-IF (LIST (COND ((GREATERP (EVAL (CADR (CDDDDR FOR!#X))) 0) 'GREATERP) (T 'LESSP)) (CADR FOR!#X) (CADDDR (CDDDDR FOR!#X))) 'THEN '(RETURN NIL)) (APPEND (CDR (CDDDDR (CDDDDR FOR!#X))) (LIST 'CONTINUE!: (LIST 'SETQ (CADR FOR!#X) (LIST 'PLUS (CADR FOR!#X) (CADR (CDDDDR FOR!#X)))) '(GO FOR!#LOOP!:))))))))) (DM SAI!-BEGIN (BEG!#X) (CONS 'DO (CDR BEG!#X))) (DM PBEGIN (PBEG!#X) (LIST 'CATCH (KWOTE (CONS 'PROG (CDR PBEG!#X))) ''!$PLAB)) (DM PRETURN (PRET!#X) (LIST 'THROW (KWOTE (CADR PRET!#X)) (KWOTE '!$PLAB))) (DM SAI!-ASSIGN (!#X) (LIST 'SETQ (CADR !#X) (CADDR !#X))) (DM MSETQ (MSETQ!#X) (CONS 'PROG (CONS '(!#!#RESULT) (CONS (LIST 'SETQ '!#!#RESULT (CADDR MSETQ!#X)) (MAPCAR (CADR MSETQ!#X) (FUNCTION (LAMBDA (X) (LIST 'SETQ X '(POP !#!#RESULT))))))))) (DM SAI!-COLLECT (X) (LIST 'SETQ (CADDDR X) (LIST 'CONS (CADR X) (CADDDR X)))) (DM IFC (X) (COND ((EVAL (CADR X)) (CADDDR X)) ((EQ (CAR (CDDDDR X)) 'ELSEC) (CADR (CDDDDR X))) (T NIL))) (DM OUTSTR (!#X) (CONS 'TTY (CDR !#X))) (!* DE TTYMSG (!#X) (MAPC !#X (FUNCTION (LAMBDA (!#ELT) (COND ((STRINGP !#ELT) (PRIN2 !#ELT)) ((EQ !#ELT 'T) (TERPRI)) (T (PRINT (EVAL !#ELT)))))))) (DM SAI!-SAY (!#X) (CONS 'TTY (CDR !#X))) (DM SAI!-!& (!#X) (CONS 'CAT (CDR !#X))) (DM SAI!-LENGTH (!#X) (CONS 'FLATSIZE2 (CDR !#X))) (DM CVSEST (!#X) (CADR !#X)) (DM CVSEN (!#X) (CADR !#X)) (DM CVS (!#X) (CADR !#X)) (DM SUBSTRING!-FOR (!#L) (LIST 'SUBSTR (CADR !#L) (LIST 'SUB1 (CADDR !#L)) (CADDDR !#L))) (!* "REM is planning on cleaning this up so it works in all cases... The form that (SUBSTRING-TO stringexpr low high) should expand into is ((LAMBDA (#STRING) (SUBSTR #STRING low high)) stringexpr) except that low and high have been modified to replace INF by explicit calls to (FLATSIZE2 #STRING). Thus things like (SUBSTRING-TO (READ) 2 (SUB1 INF)) should work without requiring the user to type the same string twice. Probably that inner (SUBSTR ...) should simply be ((LAMBDA (INF) (SUBSTR #STRING low high)) (FLATSIZE2 #STRING)) where we don't have to internally modify low or high at all!") (DM SUBSTRING!-TO (!#L) (XP!#SUBSTRING!-TO (CDR !#L))) (DE XP!#SUBSTRING!-TO (!#L) (PROG (STREXP LOWEXP HIEXP IN!:LOW!:BOUND INNER!:INF!:BOUND OUTER!:STRING!:BOUND OLDRES NEWRES) (SETQ STREXP (CAR !#L)) (SETQ LOWEXP (CADR !#L)) (SETQ HIEXP (CADDR !#L)) (SETQ IN!:LOW!:BOUND (LIST (LIST 'LAMBDA '(!#LOW !#HIGH) '(SUBSTR !#STRING !#LOW (DIFFERENCE !#HIGH !#LOW))) (LIST 'SUB1 (LIST 'MAX 1 LOWEXP)) HIEXP)) (SETQ INNER!:INF!:BOUND (LIST (LIST 'LAMBDA '(INF) IN!:LOW!:BOUND) '(FLATSIZE2 !#STRING))) (SETQ OUTER!:STRING!:BOUND (LIST (LIST 'LAMBDA '(!#STRING) INNER!:INF!:BOUND) STREXP)) (RETURN OUTER!:STRING!:BOUND))) (DM PUSHES (!#X) NIL) (DM PUSHVARS (!#X) NIL) (DM SLIST (!#X) (CONS 'LIST (CDR !#X))) (DM SAI!-MAPC (!#L) (LIST 'MAPC (CADDR !#L) (CADR !#L))) (DM SAI!-EQU (!#L) (CONS 'EQUAL (CDR !#L))) |
Added psl-1983/util/zpedit.build version [a53a3976fc].
> > | 1 2 | CompileTime load(ZBoot, ZBasic, ZMacro); in "zpedit.lsp"$ |
Added psl-1983/util/zpedit.lsp version [8c7739dd3b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZPEDIT contains two packages -- (1) YPP -- a derivative of the ILISP pretty-printer. (2) YEDIT -- a derivative of the ILISP form-oriented editor. ") (!* " YPP -- THE PRETTYPRINTER PP( LST:list ) FEXPR PP1( X:any ) EXPR PP-VAL ( X:id ) EXPR PP-DEF ( X:id ) EXPR SPRINT( X:any COL:number ) EXPR and others... ") (FLUID '(PP!#PROPS PP!#FLAGS PRINTMACRO COMMENTCOL COMMENTFLG CONTOURFLG PPPRINT)) (FLUID '(!#FILE)) (SETQ PP!#PROPS '(READMACRO PRINTMACRO)) (SETQ PP!#FLAGS '(FLUID GLOBAL)) (SETQ COMMENTCOL 50) (SETQ COMMENTFLG NIL) (SETQ CONTOURFLG T) (!* "Tell the loader we need ZBasic and ZMacro.") (IMPORTS '(ZBOOT ZBASIC ZMACRO)) (!* "Change the system prettyprint function to use this one.") (DE PRETTYPRINT (!#X) (PROGN (SPRINT !#X 1) (TERPRI))) (!* "Tell editor to use SPRINT for PP command.") (SETQ PPPRINT 'SPRINT) (PUT 'QUOTE 'PRINTMACRO '!#QUOTE) (PUT '!* 'PRINTMACRO '!#!*) (CDF PP (!#L) (PROGN (MAPC !#L (FUNCTION PP1)) (TERPRI) T)) (DF PPL (!#L) (PROG (!#FILE) (SETQ !#L (APPLY (FUNCTION APPEND) (MAPCAR !#L (FUNCTION ADD!#SELF!#REF)))) (!* "Print the readmacros at the front of the file in a PROGN") (!* "#FILE becomes non-nil when printing to files") (WRS (SETQ !#FILE (WRS NIL))) (COND ((AND !#FILE (MEMQ 'READMACRO PP!#PROPS)) (PROGN (MAPC !#L (FUNCTION FPP!#READMACRO)) (!* "Trick: #FILE is now NIL if readmacros were printed") (COND ((NULL !#FILE) (PROGN (SPRINT ''READMACROS!-LOADED 1) (PRIN2 ")"))))))) (MAPC !#L (FUNCTION PP1)))) (!* "SETCHR is only meaningful in the dec slisp, where it is defined") (CDE SETCHR (CHR FLAGS) NIL) (DE FPP!#READMACRO (!#A) (COND ((GET !#A 'READMACRO) (PROGN (!* "Put the readmacros inside a PROGN") (COND (!#FILE (PROGN (TERPRI) (PRIN2 "(PROGN") (SETQ !#FILE NIL)))) (SPRINT (LIST 'SETCHR (LIST 'QUOTE !#A) (SETCHR !#A NIL)) 2))))) (DE PP1 (!#EXP) (PROG NIL (TERPRI) (COND ((IDP !#EXP) (PROG (!#PROPS !#FLAGS) (SETQ !#PROPS PP!#PROPS) LP1 (COND (!#PROPS (PROGN (PP!-PROP !#EXP (CAR !#PROPS)) (SETQ !#PROPS (CDR !#PROPS)) (GO LP1)))) (SETQ !#FLAGS PP!#FLAGS) LP2 (COND (!#FLAGS (PROGN (PP!-FLAG !#EXP (CAR !#FLAGS)) (SETQ !#FLAGS (CDR !#FLAGS)) (GO LP2)))) (PP!-VAL !#EXP) (PP!-DEF !#EXP))) (T (PROGN (SPRINT !#EXP 1) (TERPRI)))))) (DE PP!-VAL (!#ID) (PROG (!#VAL) (COND ((ATOM (SETQ !#VAL (ERRORSET !#ID NIL NIL))) (RETURN NIL))) (TERPRI) (PRIN2 "(SETQ ") (PRIN1 !#ID) (S2PRINT " '" (CAR !#VAL)) (PRIN2 ")") (TERPRI))) (DE PP!-DEF (!#ID) (PROG (!#DEF !#TYPE ORIG!#DEF) (SETQ !#DEF (GETD !#ID)) TEST (COND ((NULL !#DEF) (RETURN (AND ORIG!#DEF (WARNING (LIST "Gack. " !#ID " has no unbroken definition."))))) ((ATOM !#DEF) (RETURN (WARNING (LIST "Bad definition for " !#ID " : " !#DEF)))) ((CODEP (CDR !#DEF)) (RETURN (WARNING (LIST "Can't PP compiled def for " !#ID)))) ((NOT (AND (CDR !#DEF) (EQ (CADR !#DEF) 'LAMBDA) (CDDR !#DEF) (CDDDR !#DEF) (NULL (CDDDDR !#DEF)))) (WARNING (LIST !#ID " has ill-formed definition."))) ((AND (NOT ORIG!#DEF) (BROKEN !#ID)) (PROGN (WARNING (LIST "Note: " !#ID " is broken or traced.")) (SETQ ORIG!#DEF !#DEF) (SETQ !#DEF (GET!#GOOD!#DEF !#ID)) (GO TEST)))) (SETQ !#TYPE (CAR !#DEF)) (TERPRI) (COND ((EQ !#TYPE 'EXPR) (PRIN2 "(DE ")) ((EQ !#TYPE 'FEXPR) (PRIN2 "(DF ")) ((EQ !#TYPE 'MACRO) (PRIN2 "(DM ")) (T (RETURN (WARNING (LIST "Bad fntype for " !#ID " : " !#TYPE))))) (PRIN1 !#ID) (PRIN2 " ") (PRIN1 (CADDR !#DEF)) (MAPC (CDDDR !#DEF) (FUNCTION (LAMBDA (!#X) (S2PRINT " " !#X)))) (PRIN2 ")") (TERPRI))) (DE BROKEN (!#X) (GET !#X 'TRACE)) (DE GET!#GOOD!#DEF (!#X) (PROG (!#XX!#) (COND ((AND (SETQ !#XX!# (GET !#X 'TRACE)) (IDP (SETQ !#XX!# (CDR !#XX!#)))) (RETURN (GETD !#XX!#)))))) (DE PP!-PROP (!#ID !#PROP) (PROG (!#VAL) (COND ((NULL (SETQ !#VAL (GET !#ID !#PROP))) (RETURN NIL))) (TERPRI) (PRIN2 "(PUT '") (PRIN1 !#ID) (PRIN2 " '") (PRIN1 !#PROP) (S2PRINT " '" !#VAL) (PRIN2 ")") (TERPRI))) (DE PP!-FLAG (!#ID !#FLAG) (PROG NIL (COND ((NULL (FLAGP !#ID !#FLAG)) (RETURN NIL))) (TERPRI) (PRIN2 "(FLAG '(") (PRIN1 !#ID) (PRIN2 ") '") (PRIN1 !#FLAG) (PRIN2 ")") (TERPRI))) (DE ADD!#SELF!#REF (!#ID) (PROG (!#L) (COND ((NOT (MEMQ !#ID (SETQ !#L (EVAL !#ID)))) (PROGN (RPLACD !#L (CONS (CAR !#L) (CDR !#L))) (RPLACA !#L !#ID)))) (RETURN !#L))) (!* "S2PRINT: prin2 a string and then sprint an expression.") (DE S2PRINT (!#S !#EXP) (PROGN (OR (GREATERP (SPACES!#LEFT) (PLUS (FLATSIZE2 !#S) (FLATSIZE !#EXP))) (TERPRI)) (PRIN2 !#S) (SPRINT !#EXP (ADD1 (POSN))))) (DE SPRINT (!#EXP LEFT!#MARGIN) (PROG (ORIGINAL!#SPACE NEW!#SPACE CAR!#EXP P!#MACRO CADR!#MARGIN ELT!#MARGIN LBL!#MARGIN !#SIZE) (COND ((ATOM !#EXP) (PROGN (SAFE!#PPOS LEFT!#MARGIN (FLATSIZE !#EXP)) (RETURN (PRIN1 !#EXP))))) (PPOS LEFT!#MARGIN) (SETQ LEFT!#MARGIN (ADD1 LEFT!#MARGIN)) (SETQ ORIGINAL!#SPACE (SPACES!#LEFT)) (COND ((PAIRP (SETQ CAR!#EXP (CAR !#EXP))) (PROGN (PRIN2 "(") (SPRINT CAR!#EXP LEFT!#MARGIN))) ((AND (IDP CAR!#EXP) (SETQ P!#MACRO (GET CAR!#EXP 'PRINTMACRO))) (COND ((STRINGP P!#MACRO) (PROGN (SAFE!#PPOS (POSN1) (FLATSIZE2 P!#MACRO)) (PRIN2 P!#MACRO) (RETURN (AND (CDR !#EXP) (SPRINT (CADR !#EXP) (POSN1)))))) (T (PROGN (SETQ PRINTMACRO NIL) (SETQ !#EXP (APPLY P!#MACRO (LIST !#EXP))) (COND ((NULL PRINTMACRO) (RETURN NIL)) ((ATOM PRINTMACRO) (PROGN (SETQ CAR!#EXP PRINTMACRO) (PRIN2 "(") (SPRINT (CAR !#EXP) LEFT!#MARGIN))) (T (PROGN (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (CDR PRINTMACRO))) (SETQ LBL!#MARGIN (COND ((EQ (CAR PRINTMACRO) 'PROG) LEFT!#MARGIN) (T CADR!#MARGIN))) (GO B)))))))) (T (PROGN (PRIN2 "(") (SAFE!#PPOS (POSN1) (FLATSIZE CAR!#EXP)) (PRIN1 CAR!#EXP)))) (COND ((ATOM (SETQ !#EXP (CDR !#EXP))) (GO C))) (SETQ CADR!#MARGIN (POSN2)) (SETQ NEW!#SPACE (SPACES!#LEFT)) (SETQ !#SIZE (PPFLATSIZE CAR!#EXP)) (COND ((NOT (LESSP !#SIZE ORIGINAL!#SPACE)) (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) ((EQ CAR!#EXP '!*) (PROGN (SETQ LEFT!#MARGIN (SETQ CADR!#MARGIN (PLUS LEFT!#MARGIN 2))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN NIL)))) ((OR (LESSP (PPFLATSIZE !#EXP) NEW!#SPACE) (PROG (!#E1) (SETQ !#E1 !#EXP) LP (COND ((PAIRP (CAR !#E1)) (RETURN NIL)) ((ATOM (SETQ !#E1 (CDR !#E1))) (RETURN T)) (T (GO LP))))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN NIL))) ((LESSP NEW!#SPACE 24) (PROGN (COND ((NOT (AND (MEMQ CAR!#EXP '(SETQ LAMBDA PROG SELECTQ SET)) (LESSP (PPFLATSIZE (CAR !#EXP)) NEW!#SPACE))) (SETQ CADR!#MARGIN LEFT!#MARGIN))) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) ((EQ CAR!#EXP 'LAMBDA) (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN))) ((EQ CAR!#EXP 'PROG) (PROGN (SETQ ELT!#MARGIN CADR!#MARGIN) (SETQ LBL!#MARGIN LEFT!#MARGIN))) ((OR (GREATERP !#SIZE 14) (AND (GREATERP !#SIZE 4) (NOT (LESSP (PPFLATSIZE (CAR !#EXP)) NEW!#SPACE)))) (SETQ CADR!#MARGIN (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN LEFT!#MARGIN)))) (T (SETQ ELT!#MARGIN (SETQ LBL!#MARGIN CADR!#MARGIN)))) (COND ((ATOM (SETQ CAR!#EXP (CAR !#EXP))) (PROGN (SAFE!#PPOS CADR!#MARGIN (PPFLATSIZE CAR!#EXP)) (PRIN1 CAR!#EXP))) (T (SPRINT CAR!#EXP CADR!#MARGIN))) A (COND ((ATOM (SETQ !#EXP (CDR !#EXP))) (GO C))) B (SETQ CAR!#EXP (CAR !#EXP)) (COND ((ATOM CAR!#EXP) (PROGN (SETQ !#SIZE (PPFLATSIZE CAR!#EXP)) (COND (LBL!#MARGIN (SAFE!#PPOS LBL!#MARGIN !#SIZE)) ((LESSP !#SIZE (SPACES!#LEFT)) (PRIN2 " ")) (T (SAFE!#PPOS LEFT!#MARGIN !#SIZE))) (PRIN1 CAR!#EXP))) (T (SPRINT CAR!#EXP (COND (ELT!#MARGIN ELT!#MARGIN) (T (POSN2))))) ) (GO A) C (COND (!#EXP (PROGN (COND ((LESSP (SPACES!#LEFT) 3) (PPOS LEFT!#MARGIN))) (PRIN2 " . ") (SETQ !#SIZE (PPFLATSIZE !#EXP)) (COND ((GREATERP !#SIZE (SPACES!#LEFT)) (SAFE!#PPOS LEFT!#MARGIN !#SIZE))) (PRIN1 !#EXP)))) (COND ((LESSP (SPACES!#LEFT) 1) (PPOS LEFT!#MARGIN))) (PRIN2 ")"))) (DE SPRIN1 (!#EXP !#C1 !#C2) (PROG (!#ROOM) (SETQ !#ROOM (DIFFERENCE (LINELENGTH NIL) !#C1)) (COND ((GREATERP (PLUS (FLATSIZE !#EXP) 3) !#ROOM) (COND ((NULL (STRINGP !#EXP)) (SPRINT !#EXP !#C2)) ((FIRSTLINE!-FITS !#EXP !#ROOM) (PROGN (PPOS !#C1) (PRIN1 !#EXP))) (T (PROGN (TERPRI) (PRIN1 !#EXP))))) (T (SPRINT !#EXP !#C1))))) (DE SPRINL (!#EXP !#C1 !#C2) (PROG (!#SIZE) (COND ((ATOM !#EXP) (RETURN (SPRIN1 !#EXP !#C1 !#C2))) (T (PROGN (PPOS !#C1) (PRIN2 "(")))) A (SPRIN1 (CAR !#EXP) (ADD1 !#C1) !#C2) (COND ((NULL (SETQ !#EXP (CDR !#EXP))) (PROGN (COND ((LESSP (SPACES!#LEFT) 1) (PPOS !#C2))) (RETURN (PRIN2 ")")))) ((ATOM !#EXP) (PROGN (COND ((LESSP (SPACES!#LEFT) 3) (PPOS !#C1))) (PRIN2 " . ") (SETQ !#SIZE (ADD1 (PPFLATSIZE !#EXP))) (COND ((GREATERP !#SIZE (SPACES!#LEFT)) (SAFE!#PPOS !#C1 !#SIZE))) (PRIN1 !#EXP) (PRIN2 ")"))) (T (PROGN (SETQ !#C1 (POSN1)) (GO A)))))) (DE !#QUOTE (!#L) (!#QUOTES !#L "'")) (DE !#QUOTES (!#L !#CH) (PROG (!#N) (COND ((ATOM (CDR !#L)) (PROGN (SETQ !#N (POSN1)) (SPRINL !#L !#N (PLUS !#N 3)))) (T (PROGN (PRIN2 !#CH) (SETQ !#N (POSN1)) (SPRIN1 (CADR !#L) !#N !#N)))))) (!* "Addition for PSL, backquote and friends.") (PUT 'BACKQUOTE 'PRINTMACRO '!#BACKQUOTE) (DE !#BACKQUOTE (!#L) (!#QUOTES !#L "`")) (PUT 'UNQUOTE 'PRINTMACRO '!#UNQUOTE) (DE !#UNQUOTE (!#L) (!#QUOTES !#L ",")) (PUT 'UNQUOTEL 'PRINTMACRO '!#UNQUOTEL) (DE !#UNQUOTEL (!#L) (!#QUOTES !#L ",@")) (PUT 'UNQUOTED 'PRINTMACRO '!#UNQUOTED) (DE !#UNQUOTED (!#L) (!#QUOTES !#L ",.")) (DE !#!* (!#L) (PROG (!#F !#N) (COND ((ATOM (CDR !#L)) (RETURN (SPRINL !#L (SETQ !#N (POSN1)) (PLUS !#N 3))))) (!* COND ((EQ (CADR !#L) 'E) (EVAL (CADDR !#L)))) (WRS (SETQ !#F (WRS NIL))) (COND ((OR !#F COMMENTFLG) (SPRINL !#L (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) (PLUS (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) 3))) (T (PRIN2 "(* ...)"))))) (!* DE SPRINL (!#EXP !#C1 !#C2) (PROG NIL (COND ((ATOM !#EXP) (RETURN (SPRIN1 !#EXP !#C1 !#C2))) (T (PROGN (PPOS !#C1) (PRIN2 "(")))) A (SPRIN1 (CAR !#EXP) (ADD1 !#C1) !#C2) (COND ((NULL (SETQ !#EXP (CDR !#EXP))) (PROGN (COND ((LESSP (SPACES!#LEFT) 1) (PPOS !#C2))) (RETURN (PRIN2 ")")))) (T (PROGN (SETQ !#C1 (POSN1)) (GO A)))))) (!* DE !#QUOTE (!#L) (PROG (!#N) (COND ((NUMBERP (CADR !#L)) (SPRINL !#L (SETQ !#N (POSN1)) (PLUS !#N 3))) (T (PROGN (PRIN2 "'") (SETQ !#N (POSN1)) (SPRIN1 (CADR !#L) !#N !#N)))))) (!* DE !#!* (!#L) (PROG (!#F) (COND ((EQ (CADR !#L) 'E) (EVAL (CADDR !#L)))) (WRS (SETQ !#F (WRS NIL))) (COND ((OR !#F COMMENTFLG) (SPRINL !#L (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) (PLUS (COND (CONTOURFLG (POSN1)) (T COMMENTCOL)) 3))) (T (PRIN2 "(* ...)"))))) (DE PRINCOMMA (!#LIST FIRST!#COL) (COND (!#LIST (PROGN (PRIN2 (CAR !#LIST)) (MAPC (CDR !#LIST) (FUNCTION (LAMBDA (ELT) (PROGN (PRIN2 ", ") (COND ((LESSP (SPACES!#LEFT) (PLUS 2 (FLATSIZE2 ELT))) (PROGN (TERPRI) (PPOS FIRST!#COL)))) (PRIN2 ELT))))) (PRIN2 "."))))) (CDE CHRCT NIL (DIFFERENCE (MIN 80 (LINELENGTH NIL)) (POSN))) (DE SPACES!#LEFT NIL (SUB1 (CHRCT))) (DE SAFE!#PPOS (!#N !#SIZE) (PROG (MIN!#N) (SETQ MIN!#N (SUB1 (DIFFERENCE (LINELENGTH NIL) !#SIZE))) (COND ((LESSP MIN!#N !#N) (PROGN (OR (GREATERP MIN!#N (POSN1)) (TERPRI)) (PPOS MIN!#N))) (T (PPOS !#N))))) (DE PPFLATSIZE (!#EXP) (DIFFERENCE (FLATSIZE !#EXP) (PP!#SAVINGS !#EXP))) (DE PP!#SAVINGS (Y) (PROG (N) (COND ((ATOM Y) (RETURN 0)) ((AND (EQ (CAR Y) 'QUOTE) (CDR Y) (NOT (NUMBERP (CADR Y)))) (RETURN (PLUS 7 (PP!#SAVINGS (CDR Y)))))) (SETQ N 0) LP (COND ((ATOM Y) (RETURN N))) (SETQ N (PLUS N (PP!#SAVINGS (CAR Y)))) (SETQ Y (CDR Y)) (GO LP))) (DE FIRSTLINE!-FITS (!#STR !#N) (PROG (!#BIG) (!* "This addition is an empirical hack") (SETQ !#N (PLUS2 !#N 2)) (SETQ !#BIG (EXPLODE !#STR)) LP (COND ((EQ (CAR !#BIG) !$EOL!$) (RETURN T)) ((NULL (SETQ !#BIG (CDR !#BIG))) (RETURN T)) ((ZEROP (SETQ !#N (SUB1 !#N))) (RETURN NIL))) (GO LP))) (DE POSN1 NIL (ADD1 (POSN))) (DE POSN2 NIL (PLUS 2 (POSN))) (DE PPOS (N) (PROG NIL (OR (GREATERP N (POSN)) (TERPRI)) (SETQ N (SUB1 N)) LOOP (COND ((LESSP (POSN) N) (PROGN (PRIN2 " ") (GO LOOP)))))) (!* " YEDIT -- THE EDITOR " " Originally from ilisp editor -- see zedit.doc for evolution. EDITF (X) FEXPR EDITFNS (X) FEXPR EDITV (X) FEXPR EDITP (X) FEXPR EDITE (EXPR COMS ATM) EXPR ") (!* "Due to deficiency in standard-lisp") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "G!:EDIT!:ERRORS and G!:EDIT!:TRACE switch editor errorset args on/off") (GLOBAL '(G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (!* " Global to editor") (FLUID '(F!:E!#LOOKDPTH F!:E!#TRACEFLG F!:E!#LAST!#ID F!:E!#MAXLEVEL F!:E!#UPFINDFLG F!:E!#MAXLOOP F!:E!#EDITCOMSL F!:E!#USERMACROS F!:E!#MACROS F!:E!#OPS F!:E!#MAX!#PLENGTH)) (!* " Fluid in editor, but initialized to non-NIL at top level") (FLUID '(F!:E!#DEPTH)) (!* " Fluid in editor ") (FLUID '(F!:E!#LOCLST F!:E!#LOCLST!#0 F!:E!#MARKLST F!:E!#UNDOLST F!:E!#UNDOLST!#1 F!:E!#OLDPROMPT F!:E!#ID F!:E!#INBUF F!:E!#CMD F!:E!#UNFIND F!:E!#FINDFLAG F!:E!#COM0 F!:E!#TOPFLG F!:E!#COPYFLG F!:E!#LASTP1 F!:E!#LASTP2 F!:E!#LCFLG F!:E!#LASTAIL F!:E!#SN F!:E!#TOFLG F!:E!#1 F!:E!#2 F!:E!#3)) (!* "EDITLINEREAD():list EXPR ------------ Prints a supplementary prompt before the READ generated prompt. Reads a line of input containing a series of LISP expressions. But the several expressions on the line must be separated by spaces or commas and terminated with a bare CR. ") (FLUID '(PROMPTSTRING!*)) (DE EDITLINEREAD NIL (PROG (!#NEXT !#RES PROMPTSTRING!*) (!* "PromptString!* for PSL (EAB 2:08am Friday, 6 November 1981)") (SETQ PROMPTSTRING!* "-E- ") (!* (PRIN2 "-E-")) (TERPRI) LOOP (SETQ !#RES (NCONC !#RES (LIST (READ)))) (COND ((NOT (MEMQ (SETQ !#NEXT (READCH)) '(!, ! ))) (RETURN !#RES)) (T (GO LOOP))))) (DM EDIT!#!# (!#X) (LIST 'EDIT!#!#DE (MKQUOTE (CDR !#X)))) (DE EDIT!#!#DE (!#COMS) ((LAMBDA (F!:E!#LOCLST F!:E!#UNDOLST!#1) (EDITCOMS !#COMS)) F!:E!#LOCLST NIL)) (DF EDITFNS (!#X) (PROG (!#Y) (SETQ !#Y (EVAL (CAR !#X))) LP (COND ((NULL !#Y) (RETURN NIL))) (ERRORSET (CONS 'EDITF (CONS (PRIN1 (CAR !#Y)) (CDR !#X))) G!:EDIT!:ERRORS G!:EDIT!:TRACE) (SETQ !#Y (CDR !#Y)) (GO LP))) (DF EDITF (!#X) (PROG (!#Y !#FN) (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((IDP (CAR !#X)) (PROGN (COND ((SETQ !#Y (GET (SETQ !#FN (CAR !#X)) 'TRACE)) (SETQ !#FN (CDR !#Y)))) (COND ((SETQ !#Y (GETD !#FN)) (PROGN (RPLACD !#Y (EDITE (CDR !#Y) (CDR !#X) (CAR !#X))) (RETURN (SETQ F!:E!#LAST!#ID (CAR !#X))))) ((AND (SETQ !#Y (GET !#FN 'VALUE)) (PAIRP (CDR !#Y))) (GO L1))))) ((PAIRP (CAR !#X)) (GO L1))) (PRIN1 (CAR !#X)) (PRIN2 " not editable.") (ERROR NIL NIL) L1 (PRINT2 "=EDITV") (RETURN (EVAL (CONS 'EDITV !#X))))) (DF EDITV (!#X) (PROG (!#Y) (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((PAIRP (CAR !#X)) (PROGN (EDITE (EVAL (CAR !#X)) (CDR !#X) NIL) (RETURN T))) ((AND (IDP (CAR !#X)) (PAIRP (ERRORSET (CAR !#X) G!:EDIT!:ERRORS G!:EDIT!:TRACE))) (PROGN (SET (CAR !#X) (EDITE (EVAL (CAR !#X)) (CDR !#X) (CAR !#X))) (RETURN (SETQ F!:E!#LAST!#ID (CAR !#X))))) (T (PROGN (TERPRI) (PRIN1 (CAR !#X)) (PRIN2 " not editable") (ERROR NIL NIL)))))) (!* "For PSL, the BREAK function uses an EXPR, EDIT. I don't know how else to edit a form but to call the FEXPR EDITV.") (FLUID '(EDIT!:FORM)) (DE EDIT (EDIT!:FORM) (PROGN (EDITV EDIT!:FORM) EDIT!:FORM)) (DF EDITP (!#X) (PROGN (COND ((NULL !#X) (PROGN (PRIN2 " = ") (SETQ !#X (LIST (PRIN1 F!:E!#LAST!#ID)))))) (COND ((PAIRP (CAR !#X)) (PROGN (PRIN2 "=EDITV") (EVAL (CONS 'EDITV !#X)))) ((IDP (CAR !#X)) (PROGN (!* "For PSL, changed (CDAR !#X) to (PROP (CAR !#X))") (EDITE (PROP (CAR !#X)) (CDR !#X) (CAR !#X)) (SETQ F!:E!#LAST!#ID (CAR !#X)))) (T (PROGN (TERPRI) (PRIN1 (CAR !#X)) (PRIN2 " not editable.") (ERROR NIL NIL)))))) (DE EDITE (!#EXPR !#COMS !#ATM) (COND ((NULL (PAIRP !#EXPR)) (PROGN (PRINT !#EXPR) (PRIN2 " not editable.") (ERROR NIL NIL))) (T (CAR (LAST (EDITL (LIST !#EXPR) !#COMS !#ATM NIL NIL)))))) (DE EDITL (F!:E!#LOCLST !#COMS !#ATM F!:E!#MARKLST !#MESS) (PROG (F!:E!#CMD F!:E!#LASTAIL F!:E!#UNDOLST F!:E!#UNDOLST!#1 F!:E!#FINDFLAG F!:E!#LCFLG F!:E!#UNFIND F!:E!#LASTP1 F!:E!#LASTP2 F!:E!#INBUF F!:E!#LOCLST!#0 F!:E!#COM0 F!:E!#OLDPROMPT) (SETQ F!:E!#LOCLST (ERRORSET (LIST 'EDITL0 (ADD1 F!:E!#DEPTH) (MKQUOTE !#COMS) (MKQUOTE !#MESS) (MKQUOTE !#ATM)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((PAIRP F!:E!#LOCLST) (RETURN (CAR F!:E!#LOCLST))) (T (ERROR NIL NIL))))) (DE EDITL0 (F!:E!#DEPTH !#COMS !#MESS F!:E!#ID) (PROG (!#RES) (COND ((NULL !#COMS) NIL) ((EQ (CAR !#COMS) 'START) (SETQ F!:E!#INBUF (CDR !#COMS))) ((PAIRP (ERRORSET (LIST 'EDIT1 (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (RETURN F!:E!#LOCLST)) (T (ERROR NIL NIL))) (TERPRI) (PRINT2 (OR !#MESS "EDIT")) (COND ((OR (EQ (CAR F!:E!#LOCLST) (CAR (LAST (CAR (COND ((SETQ F!:E!#CMD (GET 'EDIT 'LASTVALUE)) F!:E!#CMD) (T '((NIL)))))))) (AND F!:E!#ID (EQ (CAR F!:E!#LOCLST) (CAR (LAST (CAR (COND ((SETQ F!:E!#CMD (GET F!:E!#ID 'EDIT!-SAVE)) F!:E!#CMD) (T '((NIL)))))))))) (PROGN (SETQ F!:E!#LOCLST (CAR F!:E!#CMD)) (SETQ F!:E!#MARKLST (CADR F!:E!#CMD)) (SETQ F!:E!#UNDOLST (CADDR F!:E!#CMD)) (COND ((CAR F!:E!#UNDOLST) (SETQ F!:E!#UNDOLST (CONS NIL F!:E!#UNDOLST)))) (SETQ F!:E!#UNFIND (CDDDR F!:E!#CMD))))) LP (SETQ !#RES (ERRORSET '(EDITL1) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'OK) (RETURN F!:E!#LOCLST)) ((EQ !#RES 'STOP) (ERROR 'STOP NIL)) (T (GO LP))))) (DE EDIT1 (!#COMS) (PROG (!#X) (SETQ !#X !#COMS) L1 (COND ((NULL !#X) (RETURN NIL))) (EDITCOM (SETQ F!:E!#CMD (CAR !#X)) NIL) (SETQ !#X (CDR !#X)) (GO L1))) (DE EDITVAL (!#X) (PROG (!#RES) (SETQ !#RES (ERRORSET !#X G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (AND !#RES (ATOM !#RES) (ERROR !#RES NIL)) (RETURN !#RES))) (DE EDITL1 NIL (PROG (!#RES) CT (SETQ F!:E!#FINDFLAG NIL) (COND ((NULL F!:E!#OLDPROMPT) (SETQ F!:E!#OLDPROMPT (CONS F!:E!#DEPTH '!#)))) A (SETQ F!:E!#UNDOLST!#1 NIL) (SETQ F!:E!#CMD (EDITREAD)) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ F!:E!#COM0 (COND ((ATOM F!:E!#CMD) F!:E!#CMD) (T (CAR F!:E!#CMD)))) (SETQ !#RES (ERRORSET (LIST 'EDITCOM (MKQUOTE F!:E!#CMD) T) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'OK) (ERROR 'OK NIL)) ((EQ !#RES 'STOP) (ERROR 'STOP NIL)) (F!:E!#UNDOLST!#1 (PROGN (SETQ F!:E!#UNDOLST!#1 (CONS F!:E!#COM0 (CONS F!:E!#LOCLST!#0 F!:E!#UNDOLST!#1))) (SETQ F!:E!#UNDOLST (CONS F!:E!#UNDOLST!#1 F!:E!#UNDOLST))))) (COND ((PAIRP !#RES) (GO A))) (SETQ F!:E!#INBUF NIL) (TERPRI) (COND (F!:E!#CMD (PROGN (PRIN1 F!:E!#CMD) (PRIN2 " ?")))) (GO CT))) (DE EDITREAD NIL (PROG (!#X) (COND ((NULL F!:E!#INBUF) (PROG NIL LP (TERPRI) (COND ((NOT (EQUAL (CAR F!:E!#OLDPROMPT) 0)) (PRIN2 (CAR F!:E!#OLDPROMPT)))) (SETQ F!:E!#INBUF (ERRORSET '(EDITLINEREAD) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((ATOM F!:E!#INBUF) (PROGN (TERPRI) (GO LP)))) (SETQ F!:E!#INBUF (CAR F!:E!#INBUF))))) (SETQ !#X (CAR F!:E!#INBUF)) (SETQ F!:E!#INBUF (CDR F!:E!#INBUF)) (RETURN !#X))) (DE EDITCOM (!#CMD F!:E!#TOPFLG) (PROGN (SETQ F!:E!#CMD !#CMD) (COND (F!:E!#TRACEFLG (EDITRACEFN !#CMD))) (COND (F!:E!#FINDFLAG (COND ((EQ F!:E!#FINDFLAG 'BF) (PROGN (SETQ F!:E!#FINDFLAG NIL) (EDITBF !#CMD NIL))) (T (PROGN (SETQ F!:E!#FINDFLAG NIL) (EDITQF !#CMD))))) ((NUMBERP !#CMD) (SETQ F!:E!#LOCLST (EDIT1F !#CMD F!:E!#LOCLST))) ((ATOM !#CMD) (EDITCOMA !#CMD (NULL F!:E!#TOPFLG))) (T (EDITCOML !#CMD (NULL F!:E!#TOPFLG)))) (CAR F!:E!#LOCLST))) (DE EDITCOMA (!#CMD F!:E!#COPYFLG) (PROG (!#TEM) (SELECTQ !#CMD (NIL NIL) (OK (COND (F!:E!#ID (REMPROP F!:E!#ID 'EDIT!-SAVE))) (PUT 'EDIT 'LASTVALUE (CONS (LAST F!:E!#LOCLST) (CONS F!:E!#MARKLST (CONS F!:E!#UNDOLST F!:E!#LOCLST)))) (ERROR 'OK NIL)) (STOP (ERROR 'STOP NIL)) (SAVE (COND (F!:E!#ID (PUT 'EDIT 'LASTVALUE (PUT F!:E!#ID 'EDIT!-SAVE (CONS F!:E!#LOCLST (CONS F!:E!#MARKLST (CONS F!:E!#UNDOLST F!:E!#UNFIND))))))) (ERROR 'OK NIL)) (TTY!: (SETQ F!:E!#CMD F!:E!#COM0) (SETQ F!:E!#LOCLST (EDITL F!:E!#LOCLST NIL NIL NIL 'TTY!:))) (E (COND (F!:E!#TOPFLG (COND ((PAIRP (SETQ !#TEM (EDITVAL (EDITREAD)))) (EDIT!#PRINT (CAR !#TEM) F!:E!#LOOKDPTH NIL))) ) (T (PROGN (EDITQF !#CMD) T)))) (P (EDITBPNT0 (CAR F!:E!#LOCLST) 2)) (!? (EDITBPNT0 (CAR F!:E!#LOCLST) 100)) (PP (EDITBPNT0 (CAR F!:E!#LOCLST) NIL)) (!^ (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (LAST F!:E!#LOCLST))) (!@0 (COND ((NULL (CDR F!:E!#LOCLST)) (ERROR NIL NIL))) (PROG NIL LP (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST)) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (GO LP))))) (MARK (SETQ F!:E!#MARKLST (CONS F!:E!#LOCLST F!:E!#MARKLST))) (UNDO (EDITUNDO F!:E!#TOPFLG NIL (COND (F!:E!#INBUF (EDITREAD))))) (TEST (SETQ F!:E!#UNDOLST (CONS NIL F!:E!#UNDOLST))) (!@UNDO (EDITUNDO T T NIL)) (UNBLOCK (COND ((SETQ !#TEM (MEMQ NIL F!:E!#UNDOLST)) (EDITSMASH !#TEM (LIST NIL) (CDR !#TEM))) (T (PRINT2 " not blocked")))) (!_ (COND (F!:E!#MARKLST (PROGN (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (CAR F!:E!#MARKLST)))) (T (ERROR NIL NIL)))) (!\ (COND (F!:E!#UNFIND (PROGN (SETQ !#CMD F!:E!#LOCLST) (SETQ F!:E!#LOCLST F!:E!#UNFIND) (AND (CDR !#CMD) (SETQ F!:E!#UNFIND !#CMD)))) (T (ERROR NIL NIL)))) (!\P (COND ((AND F!:E!#LASTP1 (NOT (EQ F!:E!#LASTP1 F!:E!#LOCLST))) (SETQ F!:E!#LOCLST F!:E!#LASTP1)) ((AND F!:E!#LASTP2 (NOT (EQ F!:E!#LASTP2 F!:E!#LOCLST))) (SETQ F!:E!#LOCLST F!:E!#LASTP2)) (T (ERROR NIL NIL)))) (!_!_ (COND (F!:E!#MARKLST (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (SETQ F!:E!#LOCLST (CAR F!:E!#MARKLST)) (SETQ F!:E!#MARKLST (CDR F!:E!#MARKLST)))) (T (ERROR NIL NIL)))) ((F BF) (COND ((NULL F!:E!#TOPFLG) (PROGN (SETQ F!:E!#FINDFLAG !#CMD) (RETURN NIL))) (T (PROGN (SETQ !#TEM (EDITREAD)) (SELECTQ !#CMD (F (EDITQF !#TEM)) (BF (EDITBF !#TEM NIL)) (ERROR NIL NIL)))))) (UP (EDITUP)) (DELETE (SETQ !#CMD '(DELETE)) (EDIT!: '!: NIL NIL)) (NX (EDIT!* 1)) (BK (EDIT!* -1)) (!@NX (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROG (!#UF) (SETQ !#UF F!:E!#LOCLST) LP (COND ((OR (NULL (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (NULL (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((OR (NULL (SETQ !#TEM (MEMQ (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)))) (NULL (CDR !#TEM))) (GO LP))) (EDITCOM 'NX NIL) (SETQ F!:E!#UNFIND !#UF) (RETURN F!:E!#LOCLST))) F!:E!#LOCLST))) (!?!? (EDITH F!:E!#UNDOLST)) (COND ((AND (NULL (SETQ !#TEM (EDITMAC !#CMD F!:E!#MACROS NIL))) (NULL (SETQ !#TEM (EDITMAC !#CMD F!:E!#USERMACROS NIL)))) (RETURN (EDITDEFAULT !#CMD))) (T (EDITCOMS (COPY (CDR !#TEM)))))))) (DE EDITCOML (!#CMD F!:E!#COPYFLG) (PROG (!#C2 !#C3 !#TEM) LP (COND ((PAIRP (CDR !#CMD)) (PROGN (SETQ !#C2 (CADR !#CMD)) (COND ((PAIRP (CDDR !#CMD)) (SETQ !#C3 (CADDR !#CMD))))))) (COND ((AND F!:E!#LCFLG (SELECTQ !#C2 ((TO THRU THROUGH) (COND ((NULL (CDDR !#CMD)) (PROGN (SETQ !#C3 -1) (SETQ !#C2 'THRU)))) T) NIL)) (PROGN (EDITTO (CAR !#CMD) !#C3 !#C2) (RETURN NIL))) ((NUMBERP (CAR !#CMD)) (PROGN (EDIT2F (CAR !#CMD) (CDR !#CMD)) (RETURN NIL))) ((EQ !#C2 '!:!:) (PROGN (EDITCONT (CAR !#CMD) (CDDR !#CMD)) (RETURN NIL)))) (SELECTQ (CAR !#CMD) (S (SET !#C2 (COND ((NULL !#C2) (ERROR NIL NIL)) (T ((LAMBDA (F!:E!#LOCLST) (EDITLOC (CDDR !#CMD))) F!:E!#LOCLST))))) (R (SETQ !#C2 (EDITNEWC2 (LIST (CAR F!:E!#LOCLST)) !#C2)) (EDITDSUBST !#C3 !#C2 (CAR F!:E!#LOCLST))) (E (SETQ !#TEM (EVAL !#C2)) (COND ((NULL (CDDR !#CMD)) (PRINT !#TEM))) (RETURN !#TEM)) (I (SETQ !#CMD (CONS (COND ((ATOM !#C2) !#C2) (T (EVAL !#C2))) (MAPCAR (CDDR !#CMD) (FUNCTION (LAMBDA (X) (COND (F!:E!#TOPFLG (PRINT (EVAL X))) (T (EVAL X)))))))) (SETQ F!:E!#COPYFLG NIL) (GO LP)) (N (COND ((ATOM (CAR F!:E!#LOCLST)) (ERROR NIL NIL))) (EDITNCONC (CAR F!:E!#LOCLST) (COND (F!:E!#COPYFLG (COPY (CDR !#CMD))) (T (APPEND (CDR !#CMD) NIL))))) (P (COND ((NOT (EQ F!:E!#LASTP1 F!:E!#LOCLST)) (PROGN (SETQ F!:E!#LASTP2 F!:E!#LASTP1) (SETQ F!:E!#LASTP1 F!:E!#LOCLST)))) (EDITBPNT (CDR !#CMD))) (F (EDIT4F !#C2 !#C3)) (FS (PROG NIL L1 (COND ((SETQ !#CMD (CDR !#CMD)) (PROGN (EDITQF (SETQ F!:E!#CMD (CAR !#CMD))) (GO L1)))))) (F!= (EDIT4F (CONS '!=!= !#C2) !#C3)) (ORF (EDIT4F (CONS '!*ANY!* (CDR !#CMD)) 'N)) (BF (EDITBF !#C2 !#C3)) (NTH (COND ((NOT (EQ (SETQ !#TEM (EDITNTH (CAR F!:E!#LOCLST) !#C2)) (CAR F!:E!#LOCLST))) (SETQ F!:E!#LOCLST (CONS !#TEM F!:E!#LOCLST))))) (IF (COND ((AND (PAIRP (SETQ !#TEM (EDITVAL !#C2))) (CAR !#TEM)) (COND ((CDR !#CMD) (EDITCOMS !#C3)))) ((AND (CDDR !#CMD) (CDDDR !#CMD)) (EDITCOMS (CADDDR !#CMD))) (T (ERROR NIL NIL)))) (BI (EDITBI !#C2 (COND ((CDDR !#CMD) !#C3) (T !#C2)) (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (RI (EDITRI !#C2 !#C3 (AND (CDR !#CMD) (CDDR !#CMD) (CAR F!:E!#LOCLST)))) (RO (EDITRO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (LI (EDITLI !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (LO (EDITLO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (BO (EDITBO !#C2 (AND (CDR !#CMD) (CAR F!:E!#LOCLST)))) (M (EDITM !#CMD !#C2)) (NX (EDIT!* !#C2)) (BK (EDIT!* (MINUS !#C2))) (ORR (EDITOR (CDR !#CMD))) (MBD (EDITMBD NIL (CDR !#CMD))) (XTR (EDITXTR NIL (CDR !#CMD))) ((THRU TO) (EDITTO NIL !#C2 (CAR !#CMD))) ((A B !: AFTER BEFORE) (EDIT!: (CAR !#CMD) NIL (CDR !#CMD))) (MV (EDITMV NIL (CADR !#CMD) (CDDR !#CMD))) ((LP LPQ) (EDITRPT (CDR !#CMD) (EQ (CAR !#CMD) 'LPQ))) (LC (EDITLOC (CDR !#CMD))) (LCL (EDITLOCL (CDR !#CMD))) (!_ (SETQ F!:E!#LOCLST (EDITNEWLOCLST F!:E!#LOCLST !#C2))) (BELOW (EDITBELOW !#C2 (COND ((CDDR !#CMD) !#C3) (T 1)))) (SW (EDITSW (CADR !#CMD) (CADDR !#CMD))) (BIND (PROG (F!:E!#1 F!:E!#2 F!:E!#3) (EDITCOMS (CDR !#CMD)))) (COMS (PROG NIL L1 (COND ((SETQ !#CMD (CDR !#CMD)) (PROGN (EDITCOM (SETQ F!:E!#CMD (EVAL (CAR !#CMD))) NIL) (GO L1)))))) (COMSQ (EDITCOMS (CDR !#CMD))) (COND ((AND (NULL (SETQ !#TEM (EDITMAC (CAR !#CMD) F!:E!#MACROS T))) (NULL (SETQ !#TEM (EDITMAC (CAR !#CMD) F!:E!#USERMACROS T)))) (RETURN (EDITDEFAULT !#CMD))) ((NOT (ATOM (SETQ !#C3 (CAR !#TEM)))) (EDITCOMS (SUBLIS (PAIR !#C3 (CDR !#CMD)) (CDR !#TEM)))) (T (EDITCOMS (SUBST (CDR !#CMD) !#C3 (CDR !#TEM)))))))) (DE EDITNEWC2 (F!:E!#LOCLST !#C2) (PROGN (EDIT4F !#C2 T) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (COND ((AND (ATOM !#C2) F!:E!#UPFINDFLG (PAIRP (CAR F!:E!#LOCLST))) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST))))) (DE EDITM (!#CMD !#C2) (PROG (!#NEWMACRO !#TEM) (COND ((ATOM !#C2) (COND ((SETQ !#TEM (EDITMAC !#C2 F!:E!#USERMACROS NIL)) (PROGN (RPLACD !#TEM (CDDR !#CMD)) (RETURN NIL))) (T (SETQ !#NEWMACRO (CONS !#C2 (CONS NIL (CDDR !#CMD))))))) ((SETQ !#TEM (EDITMAC (CAR !#C2) F!:E!#USERMACROS T)) (PROGN (RPLACA !#TEM (CADDR !#CMD)) (RPLACD !#TEM (CDDDR !#CMD)) (RETURN NIL))) (T (PROGN (NCONC F!:E!#EDITCOMSL (LIST (CAR !#C2))) (SETQ !#NEWMACRO (CONS (CAR !#C2) (CDDR !#CMD)))))) (SETQ F!:E!#USERMACROS (CONS !#NEWMACRO F!:E!#USERMACROS)))) (DE EDITNEWLOCLST (F!:E!#LOCLST !#C2) (PROG (!#UF !#TEM) (SETQ !#UF F!:E!#LOCLST) (SETQ !#C2 (EDITFPAT !#C2)) LP (COND ((COND ((AND (ATOM !#C2) (PAIRP (CAR F!:E!#LOCLST))) (EQ !#C2 (CAAR F!:E!#LOCLST))) ((EQ (CAR !#C2) 'IF) (COND ((ATOM (SETQ !#TEM (EDITVAL (CADR !#C2)))) NIL) (T !#TEM))) (T (EDIT4E !#C2 (COND ((EQ (CAR !#C2) '!') (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))))) (PROGN (SETQ F!:E!#UNFIND !#UF) (RETURN F!:E!#LOCLST))) ((SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST)) (GO LP))) (ERROR NIL NIL))) (DE EDITMAC (!#C !#LST !#FLG) (PROG (!#X !#Y) LP (COND ((NULL !#LST) (RETURN NIL)) ((EQ !#C (CAR (SETQ !#X (CAR !#LST)))) (PROGN (SETQ !#Y (CDR !#X)) (COND ((COND (!#FLG (CAR !#Y)) (T (NULL (CAR !#Y)))) (RETURN !#Y)))))) (SETQ !#LST (CDR !#LST)) (GO LP))) (DE EDITCOMS (!#COMS) (PROG NIL L1 (COND ((ATOM !#COMS) (RETURN (CAR F!:E!#LOCLST)))) (EDITCOM (CAR !#COMS) NIL) (SETQ !#COMS (CDR !#COMS)) (GO L1))) (DE EDITH (!#LST) (PROG NIL (TERPRI) (MAPC !#LST (FUNCTION (LAMBDA (!#ELT) (PROGN (COND ((NULL !#ELT) (PRIN2 " block")) ((NULL (CAR !#ELT)) NIL) ((NUMBERP (CAR !#ELT)) (PRIN2 (LIST (CAR !#ELT) "--"))) (T (PRIN1 (CAR !#ELT)))) (PRIN2 " "))))))) (DE EDITUNDO (!#PRINTFLG !#UNDOFLG !#UNDOP) (PROG (!#LST !#FLG) (SETQ !#LST F!:E!#UNDOLST) LP (COND ((OR (NULL !#LST) (NULL (CAR !#LST))) (GO OUT))) (COND ((NULL !#UNDOP) (SELECTQ (CAAR !#LST) ((NIL !@UNDO UNBLOCK) (GO LP1)) (UNDO (COND ((NULL !#UNDOFLG) (GO LP1)))) NIL)) ((NOT (EQ !#UNDOP (CAAR !#LST))) (GO LP1))) (EDITUNDOCOM (CAR !#LST) !#PRINTFLG) (COND ((NULL !#UNDOFLG) (RETURN NIL))) (SETQ !#FLG T) LP1 (SETQ !#LST (CDR !#LST)) (GO LP) OUT (COND (!#FLG NIL) ((AND !#LST (CDR !#LST)) (PRINT2 " blocked")) (T (PRINT2 " nothing saved"))))) (DE EDITUNDOCOM (!#X !#FLG) (PROG (!#C !#Y !#Z) (COND ((ATOM !#X) (ERROR NIL NIL)) ((NOT (EQ (CAR (LAST F!:E!#LOCLST)) (CAR (LAST (CADR !#X))))) (PROGN (PRINT2 " different expression") (SETQ F!:E!#CMD NIL) (ERROR NIL NIL)))) (SETQ !#C (CAR !#X)) (SETQ F!:E!#LOCLST (CADR !#X)) (SETQ !#Y (CDR !#X)) L1 (COND ((SETQ !#Y (CDR !#Y)) (PROGN (SETQ !#Z (CAR !#Y)) (COND ((EQ (CAR !#Z) 'R) ((LAMBDA (F!:E!#LOCLST) (EDITCOM (LIST 'R (CADR !#Z) (CADDR !#Z)) NIL)) (CADDDR !#Z))) (T (EDITSMASH (CAR !#Z) (CADR !#Z) (CDDR !#Z)))) (GO L1)))) (EDITSMASH !#X NIL (CONS (CAR !#X) (CDR !#X))) (COND (!#FLG (PROGN (COND ((NUMBERP !#C) (PRINT2 (LIST !#C "--"))) (T (PRIN1 !#C))) (PRIN2 " undone")))) (RETURN T))) (DE EDITSMASH (!#OLD !#A !#D) (PROGN (COND ((ATOM !#OLD) (ERROR NIL NIL))) (SETQ F!:E!#UNDOLST!#1 (CONS (CONS !#OLD (CONS (CAR !#OLD) (CDR !#OLD))) F!:E!#UNDOLST!#1)) (RPLACA !#OLD !#A) (RPLACD !#OLD !#D))) (DE EDITNCONC (!#X !#Y) (PROG (!#TEM) (RETURN (COND ((NULL !#X) !#Y) ((ATOM !#X) (ERROR NIL NIL)) (T (PROGN (EDITSMASH (SETQ !#TEM (LAST !#X)) (CAR !#TEM) !#Y) !#X)))))) (DE EDITDSUBST (!#X !#Y !#Z) (PROG NIL LP (COND ((NULL (PAIRP !#Z)) (RETURN NIL)) ((EQUAL !#Y (CAR !#Z)) (EDITSMASH !#Z (COPY !#X) (CDR !#Z))) (T (EDITDSUBST !#X !#Y (CAR !#Z)))) (COND ((AND !#Y (EQ !#Y (CDR !#Z))) (PROGN (EDITSMASH !#Z (CAR !#Z) (COPY !#X)) (RETURN NIL)))) (SETQ !#Z (CDR !#Z)) (GO LP))) (DE EDIT1F (!#C F!:E!#LOCLST) (COND ((EQUAL !#C 0) (COND ((NULL (CDR F!:E!#LOCLST)) (ERROR NIL NIL)) (T (CDR F!:E!#LOCLST)))) ((ATOM (CAR F!:E!#LOCLST)) (ERROR NIL NIL)) ((GREATERP !#C 0) (COND ((GREATERP !#C (LENGTH (CAR F!:E!#LOCLST))) (ERROR NIL NIL)) (T (CONS (CAR (SETQ F!:E!#LASTAIL (NTH!-TAIL (CAR F!:E!#LOCLST) !#C))) F!:E!#LOCLST)))) ((GREATERP (MINUS !#C) (LENGTH (CAR F!:E!#LOCLST))) (ERROR NIL NIL)) (T (CONS (CAR (SETQ F!:E!#LASTAIL (NTH!-TAIL (CAR F!:E!#LOCLST) (PLUS (LENGTH (CAR F!:E!#LOCLST)) (PLUS !#C 1))))) F!:E!#LOCLST)))) (DE EDIT2F (!#N !#X) (PROG (!#CL) (SETQ !#CL (CAR F!:E!#LOCLST)) (COND ((ATOM !#CL) (ERROR NIL NIL)) (F!:E!#COPYFLG (SETQ !#X (COPY !#X))) (T (SETQ !#X (APPEND !#X NIL)))) (COND ((GREATERP !#N 0) (COND ((GREATERP !#N (LENGTH !#CL)) (ERROR NIL NIL)) ((NULL !#X) (GO DELETE)) (T (GO REPLACE)))) ((OR (EQUAL !#N 0) (NULL !#X) (GREATERP (MINUS !#N) (LENGTH !#CL))) (ERROR NIL NIL)) (T (PROGN (COND ((NOT (EQUAL !#N -1)) (SETQ !#CL (NTH!-TAIL !#CL (MINUS !#N))))) (EDITSMASH !#CL (CAR !#X) (CONS (CAR !#CL) (CDR !#CL))) (COND ((CDR !#X) (EDITSMASH !#CL (CAR !#CL) (NCONC (CDR !#X) (CDR !#CL))))) (RETURN NIL)))) DELETE (COND ((EQUAL !#N 1) (PROGN (OR (PAIRP (CDR !#CL)) (ERROR NIL NIL)) (EDITSMASH !#CL (CADR !#CL) (CDDR !#CL)))) (T (PROGN (SETQ !#CL (NTH!-TAIL !#CL (DIFFERENCE !#N 1))) (EDITSMASH !#CL (CAR !#CL) (CDDR !#CL))))) (RETURN NIL) REPLACE (COND ((NOT (EQUAL !#N 1)) (SETQ !#CL (NTH!-TAIL !#CL !#N)))) (EDITSMASH !#CL (CAR !#X) (CDR !#CL)) (COND ((CDR !#X) (EDITSMASH !#CL (CAR !#CL) (NCONC (CDR !#X) (CDR !#CL))))))) (DE EDIT4E (!#PAT !#Y) (COND ((EQ !#PAT !#Y) T) ((ATOM !#PAT) (OR (EQ !#PAT '!&) (EQUAL !#PAT !#Y))) ((EQ (CAR !#PAT) '!*ANY!*) (PROG NIL LP (COND ((NULL (SETQ !#PAT (CDR !#PAT))) (RETURN NIL)) ((EDIT4E (CAR !#PAT) !#Y) (RETURN T))) (GO LP))) ((AND (EQ (CAR !#PAT) '!') (ATOM !#Y)) (PROG (!#Z) (SETQ !#PAT (CDR !#PAT)) (SETQ !#Z (EXPLODE2 !#Y)) LP (COND ((EQ (CAR !#PAT) '!') (PROGN (FREELIST !#Z) (PRINT2 "=") (PRIN1 !#Y) (RETURN T))) ((NULL !#Z) (RETURN NIL)) ((NOT (EQ (CAR !#PAT) (CAR !#Z))) (PROGN (FREELIST !#Z) (RETURN NIL)))) (SETQ !#PAT (CDR !#PAT)) (SETQ !#Z (CDR !#Z)) (GO LP))) ((EQ (CAR !#PAT) '!-!-) (OR (NULL (SETQ !#PAT (CDR !#PAT))) (PROG NIL LP (COND ((EDIT4E !#PAT !#Y) (RETURN T)) ((ATOM !#Y) (RETURN NIL))) (SETQ !#Y (CDR !#Y)) (GO LP)))) ((EQ (CAR !#PAT) '!=!=) (EQ (CDR !#PAT) !#Y)) ((ATOM !#Y) NIL) ((EDIT4E (CAR !#PAT) (CAR !#Y)) (EDIT4E (CDR !#PAT) (CDR !#Y))))) (DE EDITQF (!#PAT) (PROG (!#Q1) (COND ((AND (PAIRP (CAR F!:E!#LOCLST)) (PAIRP (SETQ !#Q1 (CDAR F!:E!#LOCLST))) (SETQ !#Q1 (MEMQ !#PAT !#Q1))) (SETQ F!:E!#LOCLST (CONS (COND (F!:E!#UPFINDFLG !#Q1) (T (PROGN (SETQ F!:E!#LASTAIL !#Q1) (CAR !#Q1)))) F!:E!#LOCLST))) (T (EDIT4F !#PAT 'N))))) (DE EDIT4F (!#PAT F!:E!#SN) (PROG (!#LL !#X !#FF) (SETQ !#FF (LIST NIL)) (SETQ F!:E!#CMD !#PAT) (SETQ !#PAT (EDITFPAT !#PAT)) (SETQ !#LL F!:E!#LOCLST) (COND ((EQ F!:E!#SN 'N) (PROGN (SETQ F!:E!#SN 1) (COND ((ATOM (CAR F!:E!#LOCLST)) (GO LP1)) ((AND (ATOM (CAAR F!:E!#LOCLST)) F!:E!#UPFINDFLG) (PROGN (SETQ !#LL (CONS (CAAR F!:E!#LOCLST) F!:E!#LOCLST)) (GO LP1))) (T (SETQ !#LL (CONS (CAAR F!:E!#LOCLST) F!:E!#LOCLST))))) )) (COND ((AND F!:E!#SN (NOT (NUMBERP F!:E!#SN))) (SETQ F!:E!#SN 1))) (COND ((AND (EDIT4E (COND ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:)) (CDR !#PAT)) (T !#PAT)) (CAR !#LL)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (RETURN (SETQ F!:E!#LOCLST !#LL)))) (SETQ !#X (CAR !#LL)) LP (COND ((EDIT4F1 !#PAT !#X F!:E!#MAXLEVEL !#FF) (PROGN (AND (CDR F!:E!#LOCLST) (SETQ F!:E!#UNFIND F!:E!#LOCLST)) (RETURN (CAR (SETQ F!:E!#LOCLST (NCONC (CAR !#FF) (COND ((EQ (CADR !#FF) (CAR !#LL)) (CDR !#LL)) (T !#LL)))))))) ((NULL F!:E!#SN) (ERROR NIL NIL))) LP1 (SETQ !#X (CAR !#LL)) (COND ((NULL (SETQ !#LL (CDR !#LL))) (ERROR NIL NIL)) ((AND (SETQ !#X (MEMQ !#X (CAR !#LL))) (PAIRP (SETQ !#X (CDR !#X)))) (GO LP))) (GO LP1))) (DE EDITFPAT (!#PAT) (COND ((PAIRP !#PAT) (COND ((OR (EQ (CAR !#PAT) '!=!=) (EQ (CAR !#PAT) '!')) !#PAT) (T (MAPCAR !#PAT (FUNCTION EDITFPAT))))) ((EQ (NTHCHAR !#PAT -1) '!') (CONS '!' (EXPLODE2 !#PAT))) (T !#PAT))) (DE EDIT4F1 (!#PAT !#X !#LVL !#FF) (PROG NIL LP (COND ((NOT (GREATERP !#LVL 0)) (PROGN (PRINT2 " maxlevel exceeded") (RETURN NIL))) ((ATOM !#X) (RETURN NIL)) ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:) (EDIT4E (CDR !#PAT) !#X) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) T) ((AND (OR (ATOM !#PAT) (NOT (EQ (CAR !#PAT) '!:!:!:))) (EDIT4E !#PAT (CAR !#X)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (COND ((OR (NULL F!:E!#UPFINDFLG) (PAIRP (CAR !#X))) (PROGN (SETQ F!:E!#LASTAIL !#X) (SETQ !#X (CAR !#X)))))) ((AND !#PAT (EQ !#PAT (CDR !#X)) (OR (NULL F!:E!#SN) (EQUAL (SETQ F!:E!#SN (DIFFERENCE F!:E!#SN 1)) 0))) (SETQ !#X (CDR !#X))) ((AND F!:E!#SN (PAIRP (CAR !#X)) (EDIT4F1 !#PAT (CAR !#X) (DIFFERENCE !#LVL 1) !#FF) (EQUAL F!:E!#SN 0)) (SETQ !#X (CAR !#X))) (T (PROGN (SETQ !#X (CDR !#X)) (SETQ !#LVL (DIFFERENCE !#LVL 1)) (GO LP)))) (COND ((AND !#FF (NOT (EQ !#X (CADR !#FF)))) (TCONC !#FF !#X))) (RETURN (OR !#FF T)))) (DE EDITFINDP (!#X !#PAT !#FLG) (PROG (F!:E!#SN F!:E!#LASTAIL !#FF) (SETQ F!:E!#SN 1) (AND (NULL !#FLG) (SETQ !#PAT (EDITFPAT !#PAT))) (RETURN (OR (EDIT4E !#PAT !#X) (EDIT4F1 !#PAT !#X F!:E!#MAXLEVEL !#FF))) )) (DE EDITBF (!#PAT !#N) (PROG (!#LL !#X !#Y !#FF) (SETQ !#LL F!:E!#LOCLST) (SETQ !#FF (LIST NIL)) (SETQ F!:E!#CMD !#PAT) (SETQ !#PAT (EDITFPAT !#PAT)) (COND ((AND (NULL !#N) (CDR !#LL)) (GO LP1))) LP (COND ((EDITBF1 !#PAT (CAR !#LL) F!:E!#MAXLEVEL !#Y !#FF) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) (RETURN (CAR (SETQ F!:E!#LOCLST (NCONC (CAR !#FF) (COND ((EQ (CAR !#LL) (CADR !#FF)) (CDR !#LL)) (T !#LL))))))))) LP1 (SETQ !#X (CAR !#LL)) (COND ((NULL (SETQ !#LL (CDR !#LL))) (ERROR NIL NIL)) ((OR (SETQ !#Y (MEMQ !#X (CAR !#LL))) (SETQ !#Y (TAIL!-P !#X (CAR !#LL)))) (GO LP))) (GO LP1))) (DE EDITBF1 (!#PAT !#X !#LVL !#TAIL !#FF) (PROG (!#Y) LP (COND ((NOT (GREATERP !#LVL 0)) (PROGN (PRINT2 " maxlevel exceeded") (RETURN NIL))) ((EQ !#TAIL !#X) (RETURN (COND ((EDIT4E (COND ((AND (PAIRP !#PAT) (EQ (CAR !#PAT) '!:!:!:)) (CDR !#PAT)) (T !#PAT)) !#X) (TCONC !#FF !#X)))))) (SETQ !#Y !#X) LP1 (COND ((NULL (OR (EQ (CDR !#Y) !#TAIL) (ATOM (CDR !#Y)))) (PROGN (SETQ !#Y (CDR !#Y)) (GO LP1)))) (SETQ !#TAIL !#Y) (COND ((AND (PAIRP (CAR !#TAIL)) (EDITBF1 !#PAT (CAR !#TAIL) (DIFFERENCE !#LVL 1) NIL)) (SETQ !#TAIL (CAR !#TAIL))) ((AND (EQ (CAR !#PAT) '!:!:!:) (EDIT4E (CDR !#PAT) !#TAIL)) T) ((AND (OR (ATOM !#PAT) (NOT (EQ (CAR !#PAT) '!:!:!:))) (EDIT4E !#PAT (CAR !#TAIL))) (COND ((OR (NULL F!:E!#UPFINDFLG) (PAIRP (CAR !#TAIL))) (PROGN (SETQ F!:E!#LASTAIL !#TAIL) (SETQ !#TAIL (CAR !#TAIL)))))) ((AND !#PAT (EQ !#PAT (CDR !#TAIL))) (SETQ !#X (CDR !#X))) (T (PROGN (SETQ !#LVL (DIFFERENCE !#LVL 1)) (GO LP)))) (COND ((NOT (EQ !#TAIL (CADR !#FF))) (TCONC !#FF !#TAIL))) (RETURN !#FF))) (DE EDITNTH (!#X !#N) (COND ((ATOM !#X) (ERROR NIL NIL)) ((NOT (NUMBERP !#N)) (OR (MEMQ !#N !#X) (MEMQ (SETQ !#N (EDITELT !#N (LIST !#X))) !#X) (TAIL!-P !#N !#X))) ((EQUAL !#N 0) (ERROR NIL NIL)) ((NULL (SETQ !#N (COND ((OR (NOT (LESSP !#N 0)) (GREATERP (SETQ !#N (PLUS (LENGTH !#X) !#N 1)) 0)) (NTH!-TAIL !#X !#N))))) (ERROR NIL NIL)) (T !#N))) (DE EDITBPNT0 (!#EXP !#DEPTH) (PROGN (COND ((NOT (EQUAL F!:E!#LASTP1 F!:E!#LOCLST)) (PROGN (SETQ F!:E!#LASTP2 F!:E!#LASTP1) (SETQ F!:E!#LASTP1 F!:E!#LOCLST)))) (TERPRI) (!* " 3nd arg to edit#print indicates whether print should start with ... ") (!* " 2nd arg to sprint is left margin") (COND (!#DEPTH (EDIT!#PRINT !#EXP !#DEPTH (TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)))) (T (SPRINT !#EXP 1))))) (DE EDITBPNT (!#X) (PROG (!#Y !#N) (COND ((EQUAL (CAR !#X) 0) (SETQ !#Y (CAR F!:E!#LOCLST))) (T (SETQ !#Y (CAR (EDITNTH (CAR F!:E!#LOCLST) (CAR !#X)))))) (COND ((NULL (CDR !#X)) (SETQ !#N 2)) ((NOT (NUMBERP (SETQ !#N (CADR !#X)))) (ERROR NIL NIL)) ((LESSP !#N 0) (ERROR NIL NIL))) (TERPRI) (!* " 3nd arg indicates whether print should start with ... ") (EDIT!#PRINT !#Y !#N (TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST))) (RETURN !#Y))) (DE EDITRI (!#M !#N !#X) (PROG (!#A !#B) (SETQ !#A (EDITNTH !#X !#M)) (SETQ !#B (EDITNTH (CAR !#A) !#N)) (COND ((OR (NULL !#A) (NULL !#B)) (ERROR NIL NIL))) (EDITSMASH !#A (CAR !#A) (EDITNCONC (CDR !#B) (CDR !#A))) (EDITSMASH !#B (CAR !#B) NIL))) (DE EDITRO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((OR (NULL !#X) (ATOM (CAR !#X))) (ERROR NIL NIL))) (EDITSMASH (SETQ !#N (LAST (CAR !#X))) (CAR !#N) (CDR !#X)) (EDITSMASH !#X (CAR !#X) NIL))) (DE EDITLI (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((NULL !#X) (ERROR NIL NIL))) (EDITSMASH !#X (CONS (CAR !#X) (CDR !#X)) NIL))) (DE EDITLO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((OR (NULL !#X) (ATOM (CAR !#X))) (ERROR NIL NIL))) (EDITSMASH !#X (CAAR !#X) (CDAR !#X)))) (DE EDITBI (!#M !#N !#X) (PROG (!#A !#B) (SETQ !#B (CDR (SETQ !#A (EDITNTH !#X !#N)))) (SETQ !#X (EDITNTH !#X !#M)) (COND ((AND !#A (NOT (GREATERP (LENGTH !#A) (LENGTH !#X)))) (PROGN (EDITSMASH !#A (CAR !#A) NIL) (EDITSMASH !#X (CONS (CAR !#X) (CDR !#X)) !#B))) (T (ERROR NIL NIL))))) (DE EDITBO (!#N !#X) (PROGN (SETQ !#X (EDITNTH !#X !#N)) (COND ((ATOM (CAR !#X)) (ERROR NIL NIL))) (EDITSMASH !#X (CAAR !#X) (EDITNCONC (CDAR !#X) (CDR !#X))))) (DE EDITDEFAULT (!#X) (PROG (!#Y) (COND (F!:E!#LCFLG (RETURN (COND ((EQ F!:E!#LCFLG T) (EDITQF !#X)) (T (EDITCOM (LIST F!:E!#LCFLG !#X) F!:E!#TOPFLG))))) ((PAIRP !#X) (RETURN (COND ((SETQ !#Y (ATSOC (CAR !#X) F!:E!#OPS)) (EDITRAN !#X (CDR !#Y))) (T (ERROR NIL NIL))))) ((NULL F!:E!#TOPFLG) (ERROR NIL NIL)) ((MEMQ !#X F!:E!#EDITCOMSL) (COND (F!:E!#INBUF (PROGN (SETQ !#X (CONS !#X F!:E!#INBUF)) (SETQ F!:E!#INBUF NIL))) (T (ERROR NIL NIL)))) ((AND (EQ (NTHCHAR !#X -1) 'P) (MEMQ (SETQ !#X (ICOMPRESS (REVERSIP (CDR (REVERSIP (EXPLODE !#X)))))) '(!^ !_ UP NX BK !@NX UNDO))) (SETQ F!:E!#INBUF (CONS 'P F!:E!#INBUF))) (T (ERROR NIL NIL))) (RETURN (COND ((SETQ !#Y (ATSOC (CAR !#X) F!:E!#OPS)) (EDITRAN !#X (CDR !#Y))) (T (EDITCOM (SETQ F!:E!#CMD !#X) F!:E!#TOPFLG)))))) (DE EDITUP NIL (PROG (!#CL F!:E!#LOCLST!#1 !#X !#Y) (SETQ !#CL (CAR F!:E!#LOCLST)) (!* "unused LP was here") (COND ((NULL (SETQ F!:E!#LOCLST!#1 (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((TAIL!-P !#CL (CAR F!:E!#LOCLST!#1)) (RETURN NIL)) ((NOT (SETQ !#X (MEMQ !#CL (CAR F!:E!#LOCLST!#1)))) (ERROR NIL NIL)) ((OR (EQ !#X F!:E!#LASTAIL) (NOT (SETQ !#Y (MEMQ !#CL (CDR !#X))))) NIL) ((AND (EQ !#CL (CAR F!:E!#LASTAIL)) (TAIL!-P F!:E!#LASTAIL !#Y)) (SETQ !#X F!:E!#LASTAIL)) (T (PROGN (TERPRI) (PRIN2 !#CL) (PRINT2 " - location uncertain"))) ) (COND ((EQ !#X (CAR F!:E!#LOCLST!#1)) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#1)) (T (SETQ F!:E!#LOCLST (CONS !#X F!:E!#LOCLST!#1)))) (RETURN NIL))) (DE EDIT!* (!#N) (CAR (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#CMD F!:E!#LOCLST !#M) (PROGN (COND ((NOT (GREATERP !#M !#N)) (ERROR NIL NIL))) (EDITCOM '!@0 NIL) (EDITCOM (DIFFERENCE !#N !#M) NIL) F!:E!#LOCLST)) NIL F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (EDITUP) (LENGTH (CAR F!:E!#LOCLST)))) F!:E!#LOCLST))))) (DE EDITOR (!#COMS) (PROG (!#RES) LP (COND ((NULL !#COMS) (ERROR NIL NIL))) (SETQ !#RES (ERRORSET (LIST 'EDITOR1 (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((PAIRP !#RES) (RETURN (CAR F!:E!#LOCLST))) (!#RES (ERROR !#RES NIL))) (SETQ !#COMS (CDR !#COMS)) (GO LP))) (DE EDITOR1 (!#COMS) (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (COND ((ATOM (CAR !#COMS)) (EDITCOM (CAR !#COMS))) (T (EDITCOMS (CAR !#COMS)))) F!:E!#LOCLST)) F!:E!#LOCLST))) (DE EDITERRCOM (!#COMS) (ERRORSET (LIST 'EDITCOMS (MKQUOTE !#COMS)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (DE EDITRPT (!#EDRX !#QUIET) (PROG (!#EDRL !#EDRPTCNT) (SETQ !#EDRL F!:E!#LOCLST) (SETQ !#EDRPTCNT 0) LP (COND ((GREATERP !#EDRPTCNT F!:E!#MAXLOOP) (PRINT2 " maxloop exceeded")) ((PAIRP (EDITERRCOM !#EDRX)) (PROGN (SETQ !#EDRL F!:E!#LOCLST) (SETQ !#EDRPTCNT (PLUS !#EDRPTCNT 1)) (GO LP))) ((NULL !#QUIET) (PROGN (PRIN1 !#EDRPTCNT) (PRINT2 " occurrences")))) (SETQ F!:E!#LOCLST !#EDRL))) (DE EDITLOC (!#X) (PROG (!#OLDL !#OLDF F!:E!#LCFLG !#L) (SETQ !#OLDL F!:E!#LOCLST) (SETQ !#OLDF F!:E!#UNFIND) (SETQ F!:E!#LCFLG T) (COND ((ATOM !#X) (EDITCOM !#X NIL)) ((AND (NULL (CDR !#X)) (ATOM (CAR !#X))) (EDITCOM (CAR !#X) NIL)) (T (GO LP))) (SETQ F!:E!#UNFIND !#OLDL) (RETURN (CAR F!:E!#LOCLST)) LP (SETQ !#L F!:E!#LOCLST) (COND ((PAIRP (EDITERRCOM !#X)) (PROGN (SETQ F!:E!#UNFIND !#OLDL) (RETURN (CAR F!:E!#LOCLST))))) (COND ((EQUAL !#L F!:E!#LOCLST) (PROGN (SETQ F!:E!#LOCLST !#OLDL) (SETQ F!:E!#UNFIND !#OLDF) (ERROR NIL NIL)))))) (DE EDITLOCL (!#COMS) (CAR (SETQ F!:E!#LOCLST (NCONC ((LAMBDA (F!:E!#LOCLST F!:E!#UNFIND) (PROGN (EDITLOC !#COMS) F!:E!#LOCLST)) (LIST (CAR F!:E!#LOCLST)) NIL) (CDR F!:E!#LOCLST))))) (DE EDIT!: (!#TYPE !#LC !#X) (PROG (F!:E!#TOFLG F!:E!#LOCLST!#0) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ !#X (MAPCAR !#X (FUNCTION (LAMBDA (!#X) (COND ((AND (PAIRP !#X) (EQ (CAR !#X) '!#!#)) ((LAMBDA (F!:E!#LOCLST F!:E!#UNDOLST!#1) (COPY (EDITCOMS (CDR !#X)))) F!:E!#LOCLST NIL)) (T !#X)))))) (COND (!#LC (PROGN (COND ((EQ (CAR !#LC) 'HERE) (SETQ !#LC (CDR !#LC)))) (EDITLOC !#LC)))) (EDITUP) (COND ((EQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (SETQ !#LC NIL))) (SELECTQ !#TYPE ((B BEFORE) (EDIT2F -1 !#X)) ((A AFTER) (COND ((CDAR F!:E!#LOCLST) (EDIT2F -2 !#X)) (T (EDITCOML (CONS 'N !#X) F!:E!#COPYFLG)))) ((!: FOR) (COND ((OR !#X (CDAR F!:E!#LOCLST)) (EDIT2F 1 !#X)) ((MEMQ (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (PROGN (EDITUP) (EDIT2F 1 (LIST NIL)))) (T (EDITCOMS '(0 (NTH -2) (2))))) (RETURN (COND ((NULL !#LC) F!:E!#LOCLST)))) (ERROR NIL NIL)) (RETURN NIL))) (DE EDITMBD (!#LC !#X) (PROG (!#Y F!:E!#TOFLG) (COND (!#LC (EDITLOC !#LC))) (EDITUP) (SETQ !#Y (COND (F!:E!#TOFLG (CAAR F!:E!#LOCLST)) (T (LIST (CAAR F!:E!#LOCLST))))) (EDIT2F 1 (LIST (COND ((OR (ATOM (CAR !#X)) (CDR !#X)) (APPEND !#X !#Y)) (T (LSUBST !#Y '!* (CAR !#X)))))) (SETQ F!:E!#LOCLST (CONS (CAAR F!:E!#LOCLST) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CDR F!:E!#LOCLST)) (T F!:E!#LOCLST)))) (RETURN (COND ((NULL !#LC) F!:E!#LOCLST))))) (DE EDITXTR (!#LC !#X) (PROG (F!:E!#TOFLG) (COND (!#LC (EDITLOC !#LC))) ((LAMBDA (F!:E!#LOCLST F!:E!#UNFIND) (PROGN (EDITLOC !#X) (SETQ !#X (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))))) (LIST (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CAAR F!:E!#LOCLST)) (T (CAR F!:E!#LOCLST)))) NIL) (EDITUP) (EDIT2F 1 (COND (F!:E!#TOFLG (APPEND !#X NIL)) (T (LIST !#X)))) (AND (NULL F!:E!#TOFLG) (PAIRP (CAAR F!:E!#LOCLST)) (SETQ F!:E!#LOCLST (CONS (CAAR F!:E!#LOCLST) (COND ((TAIL!-P (CAR F!:E!#LOCLST) (CADR F!:E!#LOCLST)) (CDR F!:E!#LOCLST)) (T F!:E!#LOCLST))))))) (DE EDITELT (!#LC F!:E!#LOCLST) (PROG (!#Y) (EDITLOC !#LC) LP (SETQ !#Y F!:E!#LOCLST) (COND ((CDR (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (GO LP))) (RETURN (CAR !#Y)))) (DE EDITCONT (!#LC1 F!:E!#SN) (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROG (!#RES) (SETQ !#LC1 (EDITFPAT !#LC1)) LP (COND ((NULL (EDIT4F !#LC1 'N)) (ERROR NIL NIL))) (SETQ !#RES (ERRORSET (LIST 'EDITLOCL (MKQUOTE F!:E!#SN)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((NULL !#RES) (GO LP)) ((ATOM !#RES) (ERROR !#RES NIL))) LP1 (COND ((NULL (SETQ F!:E!#LOCLST (CDR F!:E!#LOCLST))) (ERROR NIL NIL)) ((COND ((ATOM !#LC1) (EQ !#LC1 (CAAR F!:E!#LOCLST))) ((EQ (CAR !#LC1) '!') (EDIT4E !#LC1 (CAAR F!:E!#LOCLST))) (T (EDIT4E !#LC1 (CAR F!:E!#LOCLST)))) (RETURN F!:E!#LOCLST))) (GO LP1))) F!:E!#LOCLST))) (DE EDITSW (!#M !#N) (PROG (!#Y !#Z !#TEM) (SETQ !#Y (EDITNTH (CAR F!:E!#LOCLST) !#M)) (SETQ !#Z (EDITNTH (CAR F!:E!#LOCLST) !#N)) (SETQ !#TEM (CAR !#Y)) (EDITSMASH !#Y (CAR !#Z) (CDR !#Y)) (EDITSMASH !#Z !#TEM (CDR !#Z)))) (DE EDITMV (!#LC !#OP !#X) (PROG (F!:E!#LOCLST!#0 F!:E!#LOCLST!#1 !#Z F!:E!#TOFLG) (SETQ F!:E!#LOCLST!#0 F!:E!#LOCLST) (AND !#LC (EDITLOC !#LC)) (COND ((EQ !#OP 'HERE) (PROGN (COND ((NULL !#LC) (PROGN (EDITLOC !#X) (SETQ !#X NIL)))) (SETQ !#OP '!:))) ((EQ (CAR !#X) 'HERE) (COND ((NULL !#LC) (PROGN (EDITLOC (CDR !#X)) (SETQ !#X NIL))) (T (SETQ !#X (CDR !#X)))))) (EDITUP) (SETQ F!:E!#LOCLST!#1 F!:E!#LOCLST) (SETQ !#Z (CAAR F!:E!#LOCLST)) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#0) (AND !#X (EDITLOC !#X)) (EDITCOML (COND (F!:E!#TOFLG (CONS !#OP (APPEND !#Z NIL))) (T (LIST !#OP !#Z))) NIL) (PROG (F!:E!#LOCLST) (SETQ F!:E!#LOCLST F!:E!#LOCLST!#1) (EDITCOMS '(1 DELETE))) (RETURN (COND ((NULL !#LC) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST!#1) F!:E!#LOCLST)) ((NULL !#X) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST!#1) F!:E!#LOCLST!#0)) (T (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) F!:E!#LOCLST!#0)))))) (DE EDITTO (!#LC1 !#LC2 !#FLG) (PROGN (SETQ F!:E!#LOCLST ((LAMBDA (F!:E!#LOCLST) (PROGN (COND (!#LC1 (PROGN (EDITLOC !#LC1) (EDITUP)))) (EDITBI 1 (COND ((AND (NUMBERP !#LC1) (NUMBERP !#LC2) (GREATERP !#LC2 !#LC1)) (DIFFERENCE (PLUS !#LC2 1) !#LC1)) (T !#LC2)) (CAR F!:E!#LOCLST)) (COND ((AND (EQ !#FLG 'TO) (CDAAR F!:E!#LOCLST)) (EDITRI 1 -2 (CAR F!:E!#LOCLST)))) (EDITCOM 1 NIL) F!:E!#LOCLST)) F!:E!#LOCLST)) (SETQ F!:E!#TOFLG T))) (DE EDITBELOW (!#PLACE !#DEPTH) (PROGN (COND ((LESSP (SETQ !#DEPTH (EVAL !#DEPTH)) 0) (ERROR NIL NIL))) (PROG (!#N1 !#N2) (SETQ !#N1 (LENGTH ((LAMBDA (F!:E!#LOCLST F!:E!#LCFLG) (PROGN (EDITCOM !#PLACE NIL) F!:E!#LOCLST)) F!:E!#LOCLST '!_))) (SETQ !#N2 (LENGTH F!:E!#LOCLST)) (COND ((LESSP !#N2 (PLUS !#N1 !#DEPTH)) (ERROR NIL NIL))) (SETQ F!:E!#UNFIND F!:E!#LOCLST) (SETQ F!:E!#LOCLST (NTH!-TAIL F!:E!#LOCLST (DIFFERENCE (DIFFERENCE (PLUS !#N2 1) !#N1) !#DEPTH)))))) (DE EDITRAN (!#C !#DEF) (SETQ F!:E!#LOCLST (OR ((LAMBDA (F!:E!#LOCLST) (PROG (!#Z !#W) (COND ((NULL !#DEF) (ERROR NIL NIL)) ((NULL (SETQ !#Z (CAR !#DEF))) (GO OUT))) LP (COND ((NULL !#Z) (ERROR NIL NIL)) ((NULL (SETQ !#W (MEMQ (CAR !#Z) !#C))) (PROGN (SETQ !#Z (CDR !#Z)) (GO LP)))) OUT (SETQ !#Z (APPLY (CAR (SETQ !#DEF (CADR !#DEF))) (PROG (F!:E!#1 F!:E!#2 F!:E!#3) (SETQ F!:E!#1 (CDR (LDIFF !#C !#W))) (SETQ F!:E!#2 (CAR !#Z)) (SETQ F!:E!#3 (CDR !#W)) (RETURN (MAPCAR (CDR !#DEF) (FUNCTION (LAMBDA (!#X) (SELECTQ !#X (!#1 F!:E!#1) (!#2 F!:E!#2) (!#3 F!:E!#3) (EVAL !#X))))))))) (RETURN (COND ((NULL !#Z) (PROGN (SETQ F!:E!#UNFIND F!:E!#LOCLST) NIL)) (T !#Z))))) F!:E!#LOCLST) F!:E!#LOCLST))) (DE EDIT!#PRINT (!#E !#DEPTH !#DOTFLG) (PROG (!#RES) (SETQ !#RES (ERRORSET (LIST 'DEPTH!#PRINT (MKQUOTE !#E) !#DEPTH 0 (MKQUOTE !#DOTFLG)) G!:EDIT!:ERRORS G!:EDIT!:TRACE)) (COND ((EQ !#RES 'TOOBIG) (RETURN (PRINT2 " ...> "))) ((ATOM !#RES) (ERROR !#RES NIL))) (RETURN !#E))) (DE DEPTH!#PRINT (!#E !#DEPTH !#PLENGTH !#DOTFLG) (PROG NIL (OR (LESSP (SETQ !#PLENGTH (ADD1 !#PLENGTH)) F!:E!#MAX!#PLENGTH) (ERROR 'TOOBIG NIL)) (COND ((ATOM !#E) (PROGN (PRIN1 !#E) (RETURN !#PLENGTH))) ((ZEROP !#DEPTH) (PROGN (PRIN2 "&") (RETURN !#PLENGTH)))) (PRIN2 (COND (!#DOTFLG "... ") (T "("))) (SETQ !#DEPTH (SUB1 !#DEPTH)) LOOP (SETQ !#PLENGTH (DEPTH!#PRINT (CAR !#E) !#DEPTH !#PLENGTH NIL)) (SETQ !#E (CDR !#E)) (COND ((NULL !#E) NIL) ((ATOM !#E) (PROGN (PRIN2 " . ") (PRIN1 !#E))) (T (PROGN (PRIN2 " ") (GO LOOP)))) (PRIN2 ")") (RETURN !#PLENGTH))) (!* "LDIFF( X:list Y:list ):list EXPR ----- If X is a tail of Y, returns the list difference of X and Y, a list of the elements of Y preceeding X.") (CDE LDIFF (!#X !#Y) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) NIL) ((NULL !#Y) !#X) (T (PROG (!#V !#Z) (SETQ !#Z (SETQ !#V (LIST (CAR !#X)))) LOOP (SETQ !#X (CDR !#X)) (COND ((OR (EQ !#X !#Y) (ATOM !#X)) (RETURN !#Z))) (SETQ !#V (CDR (RPLACD !#V (LIST (CAR !#X))))) (GO LOOP))))) (!* "FREELIST is an efficiency hack in the DEC interpreter." "It explicitly returns the cells of a list to the freelist.") (CDE FREELIST (!#X) NIL) (!* "EDITRACEFN is an optional debugging routine for the editor.") (CDE EDITRACEFN (!#X) NIL) (DE PRINT2 (!#X) (PROGN (PRIN2 !#X) (TERPRI) !#X)) (SETQ F!:E!#LOOKDPTH -1) (SETQ F!:E!#DEPTH -1) (SETQ F!:E!#TRACEFLG NIL) (SETQ F!:E!#LAST!#ID NIL) (SETQ F!:E!#MAXLEVEL 300) (SETQ F!:E!#UPFINDFLG T) (SETQ F!:E!#MAXLOOP 30) (SETQ F!:E!#EDITCOMSL '(S R E I N P F FS F!= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR MBD XTR THRU TO A B !: AFTER BEFORE FOR MV LP LPQ LC LCL !_ BELOW SW BIND COMS COMSQ INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SECOND THIRD NEX REPACK MAKEFN)) (SETQ F!:E!#USERMACROS NIL) (SETQ F!:E!#MAX!#PLENGTH 1750) (SETQ F!:E!#MACROS '((MAKEFN (EX ARGS N M) (IF 'M ((BI N M) (LC . N) (BELOW !\)) ((IF 'N ((BI N) (LC . N) (BELOW !\))))) (E (MAPC '(LAMBDA (!#X !#Y) (EDITDSUBST !#X !#Y (EDIT!#!#))) 'ARGS (CDR 'EX)) T) (E (PUTD (CAR 'EX) 'EXPR (CONS 'LAMBDA (CONS 'ARGS (EDIT!#!#)))) T) UP (1 EX)) (REPACK !#X (LC . !#X) REPACK) (REPACK NIL (IF (PAIRP (EDIT!#!#)) (1) NIL) (I !: (PRINT (READLIST (EDITE (EXPLODE (EDIT!#!#)) NIL NIL))))) (NEX (!#X) (BELOW !#X) NX) (NEX NIL (BELOW !_) NX) (THIRD !#X (ORR ((LC . !#X) (LC . !#X) (LC . !#X)))) (SECOND !#X (ORR ((LC . !#X) (LC . !#X)))))) (SETQ F!:E!#OPS '((INSERT (BEFORE AFTER FOR) (EDIT!: F!:E!#2 F!:E!#3 F!:E!#1)) (REPLACE (WITH BY) (EDIT!: !: F!:E!#1 F!:E!#3)) (CHANGE (TO) (EDIT!: !: F!:E!#1 F!:E!#3)) (DELETE NIL (EDIT!: !: F!:E!#1 NIL)) (EMBED (IN WITH) (EDITMBD F!:E!#1 F!:E!#3)) (SURROUND (WITH IN) (EDITMBD F!:E!#1 F!:E!#3)) (MOVE (TO) (EDITMV F!:E!#1 (CAR F!:E!#3) (CDR F!:E!#3))) (EXTRACT (FROM) (EDITXTR F!:E!#3 F!:E!#1)))) |
Added psl-1983/util/zsys.lsp version [16649324f3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | (!* "ZSYS -- the system dependent file. Currently, the only code in it is MAKE-OPEN-FILE-NAME, which uses a semi machine-independant file description to create a filename suitable for OPEN in the resident system. N.B.: TO SET THIS CODE UP FOR A PARTICULAR INTEPRETER, REMOVE THE * FROM BEFORE THE APPROPRIATE SETQ BELOW. THAT SHOULD BE ALL YOU NEED TO DO. ") (COMPILETIME (GLOBAL '(G!:SYSTEM)) (IF!_SYSTEM TOPS20 (SETQ G!:SYSTEM 'PSL!-TOPS20)) (IF!_SYSTEM UNIX (SETQ G!:SYSTEM 'PSL!-UNIX)) (!* SETQ G!:SYSTEM 'IMSSS!-TENEX) (!* SETQ G!:SYSTEM 'UTAH!-TOPS10) (!* SETQ G!:SYSTEM 'UTAH!-TENEX) (!* SETQ G!:SYSTEM 'CMS) (!* SETQ G!:SYSTEM 'ORVYL) (PROGN (TERPRI) (PRIN2 "Filenames will be made for ") (PRIN2 G!:SYSTEM) (PRIN2 " system.") (TERPRI)) ) (FLUID '(F!:FILE!:ID F!:OLD!:FILE)) (COMPILETIME (!* "This macro (and those following) are separated only for readability. The appropriate MAKE-xxx-NAME will provide the body of the definition for MAKE-OPEN-FILE-NAME. Note: (a) #DSCR can be mentioned free in the macros since it is the lambda variable for MAKE-OPEN-FILE-NAME. (b) ORVYL and CMS differ only in the delimiter they use. (c) When compiling, all these macros are REMOB'ed to clear up otherwise extraneous code.") (DM MAKE!-SYS!-FILE!-NAME (!#X) (SELECTQ G!:SYSTEM (PSL!-TOPS20 '(MAKE!-PSL!-TOPS20!-NAME)) (PSL!-UNIX '(MAKE!-PSL!-UNIX!-NAME)) (UTAH!-TENEX '(MAKE!-UTAH!-TENEX!-NAME)) (UTAH!-TOPS10 '(MAKE!-UTAH!-TOPS10!-NAME)) (IMSSS!-TENEX '(MAKE!-IMSSS!-TENEX!-NAME)) (ORVYL '(MAKE!-IBM!-NAME !.)) (CMS '(MAKE!-IBM!-NAME ! )) (ERROR 0 (LIST "Don't know how to make file names for system " G!:SYSTEM)))) (DM MAKE!-UTAH!-TENEX!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST 'DIR!: !#DIR (CONS !#NAM !#EXT))))))))) (!* "Use decimal equivalent of PPNs for tops 10. Maybe the ROCT switch in the interpreter will allow octal PPNS??") (DM MAKE!-UTAH!-TOPS10!-NAME (!#X) '(PROG (!#DIR !#NAM !#EXT) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (LIST (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP))) ((EQ (CDR !#DSCR) '!;) (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) (LIST !#DSCR))) (T (PROGN (SETQ !#DIR (CAR !#DSCR)) (COND ((NOT (AND (PAIRP !#DIR) (NUMBERP (CAR !#DIR)) (NUMBERP (CADR !#DIR)))) (BUG!-STOP "Bad PPN: USE (<n> <n>) w/ decimal equiv of octal PPN.") )) (SETQ F!:FILE!:ID (SETQ !#NAM (CADR !#DSCR))) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (LIST !#DIR (CONS !#NAM !#EXT))))))))) (DM MAKE!-IMSSS!-TENEX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (RETURN (SETQ F!:OLD!:FILE (LIST (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (CONS (SETQ F!:FILE!:ID (CAR !#DSCR)) 'LSP)) ((EQ (CDR !#DSCR) '!;) (SETQ F!:FILE!:ID (CAR !#DSCR))) ((IDP (CDR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (CAR !#DSCR)) !#DSCR)) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (CONS DIR!#NAM !#EXT))))))))) (DM MAKE!-PSL!-TOPS20!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR))) ) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (LIST '!! '!<) (EXPLODE (CAR !#DSCR)) (LIST '!! '!>) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT))))))))) (DM MAKE!-PSL!-UNIX!-NAME (!#X) '(PROG (DIR!#NAM !#EXT) (!* "#DSCR is a list") (COND ((STRINGP !#DSCR) (MAKE !#DSCR NCONS))) (RETURN (SETQ F!:OLD!:FILE (COND ((NULL (PAIRP !#DSCR)) (ERROR 0 (LIST "BAD FILE DSCR: " !#DSCR))) ((NULL (CDR !#DSCR)) (COND ((STRINGP (CAR !#DSCR)) (PROGN (SETQ F!:FILE!:ID (EXTRACT!-FILE!-ID (CAR !#DSCR))) (CAR !#DSCR))) (T (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. 'LSP))))) ((EQ (CDR !#DSCR) '!;) (ID2STRING (SETQ F!:FILE!:ID (CAR !#DSCR)))) ((IDP (CDR !#DSCR)) (ID!-LIST!-TO!-STRING (LIST (SETQ F!:FILE!:ID (CAR !#DSCR)) '!. (CDR !#DSCR)))) (T (PROGN (SETQ DIR!#NAM (COMPRESS (NCONCL (EXPLODE (CAR !#DSCR)) (LIST '!! '!/) (EXPLODE (CADR !#DSCR))))) (SETQ F!:FILE!:ID (CADR !#DSCR)) (SETQ !#EXT (COND ((NULL (CDDR !#DSCR)) 'LSP) ((IDP (CDDR !#DSCR)) (CDDR !#DSCR)) (T (CADDR !#DSCR)))) (ID!-LIST!-TO!-STRING (LIST DIR!#NAM '!. !#EXT)))))))))) (IF!_SYSTEM TOPS20 (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a TOPS-20 filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (ID2STRING (CAR !#X)))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (IF!_SYSTEM UNIX (PROGN (DE EXTRACT!-FILE!-ID (!#X) (PROG (!#Y) (!* "Take a UNIX filename string and try to find a root file name in it") (SETQ !#Y (DREVERSE (EXPLODE2 !#X))) (SETQ !#X !#Y) LOOP1(COND ((OR (NULL !#X) (MEMQ (CAR !#X) '(!: !>))) (GO LOOP1END)) ((EQ (CAR !#X) '!.) (PROGN (SETQ !#Y (CDR !#X)) (GO LOOP1END)))) (SETQ !#X (CDR !#X)) (GO LOOP1) LOOP1END (SETQ !#X !#Y) LOOP2(COND ((OR (NULL !#X) (NULL (CDR !#X))) (GO LOOP2END)) ((MEMQ (CADR !#X) '(!> !:)) (PROGN (RPLACD !#X NIL) (GO LOOP2END)))) (SETQ !#X (CDR !#X)) (GO LOOP2) LOOP2END (RETURN (ICOMPRESS (DREVERSE !#Y))))) (FLUID '(!*LOWER)) (!* "*LOWER when T all output (including EXPLODE) is in lowercase") (DE ID!-LIST!-TO!-STRING (!#X) (PROG (!#S !*LOWER) (SETQ !*LOWER T) (SETQ !#S "") LOOP (COND ((NULL !#X) (RETURN !#S))) (SETQ !#S (CONCAT !#S (LIST2STRING (EXPLODE2 (CAR !#X))))) (SETQ !#X (CDR !#X)) (GO LOOP))))) (!* "IBM code got lost") (DE MAKE!-OPEN!-FILE!-NAME (!#DSCR) (MAKE!-SYS!-FILE!-NAME)) (!* "Remove excess baggage once macros have been used.") (!* COND ((CODEP (CDR (GETD 'MAKE!-OPEN!-FILE!-NAME))) (PROGN (REMOB 'MAKE!-SYS!-FILE!-NAME) (REMOB 'MAKE!-UTAH!-TENEX!-NAME) (REMOB 'MAKE!-UTAH!-TOPS10!-NAME) (REMOB 'MAKE!-IMSSS!-TENEX!-NAME) (REMOB 'MAKE!-IBM!-NAME)))) |
Added psl-1983/windows/-file.list version [3d010f45f6].
> > > > > > > > | 1 2 3 4 5 6 7 8 | Window Package Source Files Summary - 8 October 1982 ------------------------------------------------------------------------------- DISPLAY-CHAR.SL - type representing chars on display screen (with enhancements) HP2648A.SL - terminal handler for HP2648A family PHYSICAL-SCREEN.SL - physical screen abstract data type SHARED-PHYSICAL-SCREEN.SL - shared physical screen: handles overlapping screens VIRTUAL-SCREEN.SL - virtual screen abstract data type VT52X.SL - terminal handler for 9836 extended VT52 emulator |
Added psl-1983/windows/-this-.directory version [182b213b12].
> > | 1 2 | This directory contains the sources and non-loadable binaries for the NMODE editor. |
Added psl-1983/windows/9836-alpha.sl version [c6e648ccc0].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % 9836-Alpha.SL - Terminal Interface for 9836 Alpha Memory % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 13 December 1982 % Revised: 27 January 1983 % % Note: uses efficiency hacks that require 80-column width! % Note: contains 68000 LAP code; must be compiled! % Note: uses all 25 lines; assumes keyboard input buffer has been relocated % % 27-Jan-83 Alan Snyder % Revise to use all 25 lines of the screen. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int syslisp)) (defflavor 9836-alpha ( (height 25) % number of rows (0 indexed) (maxrow 24) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (buffer-address (int2sys 16#512000)) % an absolute address ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (9836-alpha get-character) () (keyboard-input-character) ) (defmethod (9836-alpha ring-bell) () (ChannelWriteChar 1 #\Bell) ) (defmethod (9836-alpha move-cursor) (row column) (setf cursor-row row) (setf cursor-column column) (screen-set-cursor-position row column) ) (defmethod (9836-alpha enter-raw-mode) () (when (not raw-mode) % (EchoOff) % Enable Keypad? (setf raw-mode T) )) (defmethod (9836-alpha leave-raw-mode) () (when raw-mode (setf raw-mode NIL) % Disable Keypad? % (EchoOn) )) (defmethod (9836-alpha erase) () % This method should be invoked to initialize the screen to a known state. (setf cursor-column 0) (for (from row 0 maxrow) (do (setf cursor-row row) (=> self clear-line) )) (setf cursor-row 0) ) (defmethod (9836-alpha clear-line) () (=> self write-line cursor-row #.(make-vector 80 32)) ) (defmethod (9836-alpha convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) ch) (defmethod (9836-alpha normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (9836-alpha highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (9836-alpha supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (9836-alpha write-char) (row column ch) (screen80-write-char buffer-address row column ch) ) (defmethod (9836-alpha write-line) (row data) (screen80-write-line buffer-address row data) ) (defmethod (9836-alpha read-char) (row column) (let ((offset (+ column (* row width)))) (halfword buffer-address offset) )) % The following methods are provided for INTERNAL use only! (defmethod (9836-alpha init) () ) (lap '((*entry screen80-write-char expr 4) % buffer-address row column word (move!.l (reg 2) (reg t1)) (moveq 80 (reg t2)) (mulu (reg t1) (reg t2)) (add!.l (reg 3) (reg t2)) (lsl!.l 1 (reg t2)) (move!.w (reg 4) (indexed (reg t2) (displacement (reg 1) 0))) (rts) )) (lap '((*entry screen80-write-line expr 3) % buffer-address row data (move!.l (reg 2) (reg t1)) % move row address to T1 (moveq 80 (reg t2)) % move 80 to T2 (mulu (reg t1) (reg t2)) % multiply row address by 80 (lsl!.l 1 (reg t2)) % convert to byte offset (adda!.l (reg t2) (reg 1)) % A1: address of line in buffer (move!.l (minus 80) (reg t1)) (addq!.l 4 (reg 3)) % skip data header word (*lbl (label loop)) (addq!.l 2 (reg 3)) % skip upper halfword in data (move!.w (autoincrement (reg 3)) (autoincrement (reg 1))) (addq!.l 1 (reg t1)) (bmi (label loop)) (rts) )) |
Added psl-1983/windows/display-char.sl version [7154b7f967].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % DISPLAY-CHAR.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 8 October 1982 % % This file defines MACROS. Load it at Compile Time! % % Display characters are ASCII characters that are "tagged" with display % enhancement bits. They are used by the Windows package. This file defines % macros for creating and manipulating display characters. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (load fast-int) (put 'INVERSE-VIDEO 'enhancement-bits 1) (put 'BLINK 'enhancement-bits 2) (put 'UNDERLINE 'enhancement-bits 4) (put 'INTENSIFY 'enhancement-bits 8) (dm dc-make-enhancement-mask (form) (setf form (cdr form)) (let ((mask 0) bits) (for (in keyword form) (do (if (setf bits (get keyword 'enhancement-bits)) (setf mask (| mask bits)) (StdError (BldMsg "Undefined enhancement: %p" keyword)) ))) (<< mask 8))) (defmacro dc-make-font-mask (font-number) `(<< ,font-number 12)) (defmacro display-character-cons (enhancement-mask font-mask char-code) `(| (| ,enhancement-mask ,font-mask) ,char-code)) (defmacro dc-enhancement-mask (dc) `(& ,dc 16#F00)) (defmacro dc-enhancement-index (dc) % Use this to index an array. `(& (>> ,dc 8) 16#F)) (defmacro dc-font-mask (dc) `(& ,dc 16#F000)) (defmacro dc-font-number (dc) `(>> ,dc 12)) (defmacro dc-character-code (dc) `(& ,dc 16#FF)) |
Added psl-1983/windows/display-char.t version [a91d191dd5].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NOTES ON THE DISPLAY CHARACTER DATATYPE Cris Perdue 10/11/82 File: PW:DISPLAY-CHAR.T ----------------------------------- This module provides a set of macros for manipulating "display-character" objects. These objects are represented to LISP as integers, but are dealt with as a separate type of object. (DC-MAKE-ENHANCEMENT-MASK KEYWORD . . . ) Macro This macro generates a specific enhancement mask object. The keywords are unevaluated identifiers. At present, the possible keywords are INVERSE-VIDEO, BLINK, UNDERLINE, and INTENSIFY, which should be meaningful with respect to HP terminals. (DC-MAKE-FONT-MASK FONT-NUMBER) Macro This makes a font mask object, given a font number. Font numbers have no definition yet, because we have no fonts. (DISPLAY-CHARACTER-CONS ENHANCEMENT-MASK FONT-MASK CHAR-CODE) Macro This macro generates a display character object, given an enhancement mask, a font mask, and a character code. The mask objects' purpose in life is to be used as arguments to this function and to be compared against each other. (DC-ENHANCEMENT-MASK DC) Macro Extracts the enhancement mask from a display character. (DC-ENHANCEMENT-INDEX DC) Macro There are a finite number of different combinations of display enhancements that are possible for a display-character. This macro returns an integer in the range from 0 that uniquely identifies the combination of enhancements in effect for this display-character. There should probably be a symbolic constant giving the maximum value for the identifying integer. With N different enhancements, the value turns out to be 2 raised to the Nth power, minus 1. (DC-FONT-MASK DC) Macro Extracts the font mask from a display character. (DC-FONT-NUMBER DC) Macro Obtains the font number from a display character. (DC-CHARACTER-CODE DC) Macro Obtains the character code from a display character object. |
Added psl-1983/windows/hp2648a.b version [7dfc842061].
cannot compute difference between binary files
Added psl-1983/windows/hp2648a.sl version [7eeaa0a8f1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % HP2648A.SL - Terminal Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 16 August 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor hp2648a ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) markers % vector indicating locations of field markers (marker-table % table for generating markers (Vector (char @) (char B) (char A) (char C) (char D) (char F) (char E) (char G) (char H) (char J) (char I) (char K) (char L) (char N) (char M) (char O) )) ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move () `(out-chars ESC & !a))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (hp2648a get-character) () (& (PBIN) 8#377) ) (defmethod (hp2648a ring-bell) () (out-char BELL) ) (defmethod (hp2648a move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move) (out-n column) (out-char C)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move) (out-n row) (out-char R)))) (t % arbitrary movement (out-move) (out-n row) (out-char (lower R)) (out-n column) (out-char C))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (hp2648a enter-raw-mode) () (when (not raw-mode) (EchoOff) (out-chars ESC & !s 1 A) % Enable Keypad (setf raw-mode T))) (defmethod (hp2648a leave-raw-mode) () (when raw-mode (setf raw-mode NIL) (out-chars ESC & !s 0 A) % Disable Keypad (EchoOn))) (defmethod (hp2648a erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (for (from row 0 maxrow) (do (let ((marker-line (vector-fetch markers row))) (for (from col 0 maxcol) (do (vector-store marker-line col NIL)) )))) ) (defmethod (hp2648a clear-line) () (out-chars ESC K) (let ((marker-line (vector-fetch markers cursor-row))) (for (from col cursor-column maxcol) (do (vector-store marker-line col NIL)) ))) (defmethod (hp2648a convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (hp2648a normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (hp2648a highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (hp2648a supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (hp2648a update-line) (row old-line new-line columns) % Old-Line is updated. % This code is particularly complicated because of the way HP terminals % implement display enhancements using field markers. Most terminals % don't require this level of complexity. (prog (last-nonblank-column col terminal-enhancement old new marker-line first-col last-col) (setf first-col (car columns)) (setf last-col (cdr columns)) (setf marker-line (vector-fetch markers row)) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (if (> first-col last-col) (return NIL)) % No change at all! (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. % Using ClearEOL can cause problems when display enhancements are used. If % you write to the position just to the right of the terminal's % end-of-line, the existing field will be extended. To avoid this problem, % we will avoid using ClearEOL where the immediately preceding character % has a non-zero enhancement. (when (= (vector-fetch new-line last-col) #\space) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) #\space) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2)) (or (<= last-nonblank-column 0) (~= (dc-enhancement-mask (vector-fetch old-line last-nonblank-column)) 0))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col #\space) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (other than those that will be taken care % of by ClearEOL): (setf col first-col) % current column under examination (setf old (vector-fetch old-line col)) % terminal's contents at that location (setf new (vector-fetch new-line col)) % new contents for that location (setf terminal-enhancement (dc-enhancement-mask old)) % terminal's enhancement for that location % (enhancement in OLD will not always be correct as we go) (if (not (and (= cursor-row row) (<= cursor-column col))) (=> self move-cursor row col)) (while (<= col last-col) % First, we check to see if we need to write a new field marker. % A field marker is needed if the terminal's idea of the current % character's enhancement is different than the desired enhancement. (when (~= terminal-enhancement (dc-enhancement-mask new)) (=> self move-cursor-forward col old-line) (=> self write-field-marker new) ) % Next, we check to see if we need to write a new character code. (when (~= old new) % check this first for efficiency (let ((old-code (dc-character-code old)) (new-code (dc-character-code new)) ) (when (or (and (= new-code #\space) (= col last-col)) % last SPACE must be written (may extend EOL) (~= old-code new-code)) (=> self move-cursor-forward col old-line) (PBOUT new-code) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0))) )) (vector-store old-line col new) ) % The following code is executed only if there is a next character. (if (< col maxcol) (let* ((next-col (+ col 1)) (next-old (vector-fetch old-line next-col)) (next-new (vector-fetch new-line next-col)) ) % Compute the terminal's idea of the enhancement for the next % character. This is invalid if we are about to ClearEOL, but % that case doesn't matter. (setf terminal-enhancement (if (vector-fetch marker-line next-col) % field marker there (dc-enhancement-mask next-old) (dc-enhancement-mask new))) (setf old next-old) (setf new next-new) )) (setf col (+ col 1)) ) % Check to see if a final field marker is needed. (when (and (<= col maxcol) (or (null last-nonblank-column) (<= col last-nonblank-column)) (~= terminal-enhancement (dc-enhancement-mask old))) (=> self move-cursor-forward col old-line) (=> self write-field-marker new) ) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (hp2648a init) () (setf markers (MkVect maxrow)) (for (from row 0 maxrow) (do (vector-store markers row (MkVect maxcol))) ) ) (defmethod (hp2648a move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move) (out-n column) (out-char C) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (hp2648a write-field-marker) (ch) (out-chars ESC & !d) (PBOUT (vector-fetch marker-table (dc-enhancement-index ch))) (vector-store (vector-fetch markers cursor-row) cursor-column T) ) |
Added psl-1983/windows/perq.b version [f32f46fe61].
cannot compute difference between binary files
Added psl-1983/windows/perq.sl version [3cd2f05efb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % PERQ.SL - Terminal Interface % % Author: Robert Kessler, U of Utah % Date: 27 Jan 1983 % based on teleray.SL by G.Q.Maguire,Jr. % U of Utah % 3 November 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor perq ( (height 70) % number of rows (0 indexed) (maxrow 69) % highest numbered row (width 84) % number of columns (0 indexed) (maxcol 83) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (perq get-character) () (& (PBIN) 8#377) ) (defmethod (perq ring-bell) () (out-char BELL) ) (defmethod (perq move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (perq enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (perq leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (perq erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (perq clear-line) () (out-chars ESC K) ) (defmethod (perq convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (perq normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (perq highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (perq supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (perq update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (PBOUT new-code) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0) )) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (perq init) () ) (defmethod (perq &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (perq &set-terminal-enhancement) (enh) ) |
Added psl-1983/windows/physical-screen.b version [73b11f8078].
cannot compute difference between binary files
Added psl-1983/windows/physical-screen.sl version [41c073c121].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 20 December 1982 % % Adapted from Will Galway's EMODE Virtual Screen package. % % A physical screen is a rectangular character display. Changes to the physical % screen are made using the Write operation. These changes are saved and sent % to the actual display only when REFRESH or FULL-REFRESH is performed. % FULL-REFRESH should be called to initialize the state of the display. % % 20-Dec-82 Alan Snyder % Added cached terminal methods to improve efficiency. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-physical-screen (display-terminal) (make-instance 'physical-screen 'terminal display-terminal)) (defflavor physical-screen (height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column cursor-row % desired cursor position after refresh cursor-column % desired cursor position after refresh changed-row-range % bounds on rows where new-image differs from display changed-column-ranges % bounds on columns in each row terminal % the display terminal new-image % new image (after refresh) displayed-image % image on the display terminal update-line-method % terminal's update-line method move-cursor-method % terminal's move-cursor method get-char-method % terminal's get-character method convert-char-method % terminal's convert-character method ) () (gettable-instance-variables height width cursor-row cursor-column) (initable-instance-variables terminal) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (defmacro range-create () `(cons 10000 0)) (defmacro range-cons (min max) `(cons ,min ,max)) (defmacro range-min (r) `(car ,r)) (defmacro range-max (r) `(cdr ,r)) (defmacro range-set-min (r x) `(rplaca ,r ,x)) (defmacro range-set-max (r x) `(rplacd ,r ,x)) (defmacro range-reset (r) `(let ((*r* ,r)) (rplaca *r* 10000) (rplacd *r* 0))) (defmacro range-empty? (r) `(< (range-max ,r) (range-min ,r))) (defmacro range-within? (r x) `(and (<= (range-min ,r) ,x) (<= ,x (range-max ,r)))) (defmacro range-extend (r x) `(let ((*r* ,r) (*x* ,x)) % New minimum if x < old minimum (if (< *x* (range-min *r*)) (range-set-min *r* *x*)) % New maximum if x > old maximum. (if (> *x* (range-max *r*)) (range-set-max *r* *x*)) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (physical-screen ring-bell) () (=> terminal ring-bell)) (defmethod (physical-screen enter-raw-mode) () (=> terminal enter-raw-mode)) (defmethod (physical-screen leave-raw-mode) () (=> terminal leave-raw-mode)) (defmethod (physical-screen get-character) () (apply get-char-method (list terminal))) (defmethod (physical-screen convert-character) (ch) (apply convert-char-method (list terminal ch))) (defmethod (physical-screen normal-enhancement) () (=> terminal normal-enhancement)) (defmethod (physical-screen highlighted-enhancement) () (=> terminal highlighted-enhancement)) (defmethod (physical-screen supported-enhancements) () (=> terminal supported-enhancements)) (defmethod (physical-screen write) (ch row col) (when (~= ch (image-fetch new-image row col)) (image-store new-image row col ch) (range-extend changed-row-range row) (range-extend (vector-fetch changed-column-ranges row) col) )) (defmethod (physical-screen set-cursor-position) (row col) (setf cursor-row row) (setf cursor-column col)) (defmethod (physical-screen refresh) (breakout-allowed) (for (from row (range-min changed-row-range) (range-max changed-row-range)) (for break-count 0 (+ break-count 1)) (with changed-columns breakout) (until (and breakout-allowed (= (& break-count 3) 0) % test every 4 lines (input-available?) (setf breakout T))) (do (setf changed-columns (vector-fetch changed-column-ranges row)) (when (not (range-empty? changed-columns)) (apply update-line-method (list terminal row (vector-fetch displayed-image row) (vector-fetch new-image row) changed-columns )) (range-reset changed-columns))) (finally (range-set-min changed-row-range row) (if (range-empty? changed-row-range) (range-reset changed-row-range)) (if (not (or breakout (and breakout-allowed (input-available?)))) (apply move-cursor-method (list terminal cursor-row cursor-column))) ) )) (defmethod (physical-screen full-refresh) (breakout-allowed) (=> terminal erase) (for (from row 0 maxrow) (with line range) (do (setq range (vector-fetch changed-column-ranges row)) (range-set-min range 0) (range-set-max range maxcol) (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) )) (range-set-min changed-row-range 0) (range-set-max changed-row-range maxrow) (=> self refresh breakout-allowed) ) (defmethod (physical-screen write-to-stream) (s) (for (from row 0 maxrow) (with line) (do (setf line (vector-fetch displayed-image row)) (for (from col 0 maxcol) (do (=> s putc (dc-character-code (vector-fetch line col)))) ) (=> s put-newline) )) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (physical-screen init) (init-plist) % For internal use only! (setf height (=> terminal height)) (setf maxrow (- height 1)) (setf width (=> terminal width)) (setf maxcol (- width 1)) (setf cursor-row 0) (setf cursor-column 0) (setf displayed-image (=> self create-image)) (setf new-image (=> self create-image)) (setf changed-row-range (range-create)) (setf changed-column-ranges (MkVect maxrow)) (for (from row 0 maxrow) (do (vector-store changed-column-ranges row (range-create)))) (setf update-line-method (object-get-handler terminal 'update-line)) (setf move-cursor-method (object-get-handler terminal 'move-cursor)) (setf get-char-method (object-get-handler terminal 'get-character)) (setf convert-char-method (object-get-handler terminal 'convert-character)) ) (defmethod (physical-screen create-image) () (let ((image (MkVect maxrow)) (line (MkVect maxcol)) ) (for (from col 0 maxcol) (do (vector-store line col (char space))) ) (for (from row 0 maxrow) (do (vector-store image row (copyvector line))) ) image)) |
Added psl-1983/windows/shared-physical-screen.b version [aeca92324f].
cannot compute difference between binary files
Added psl-1983/windows/shared-physical-screen.sl version [eaaf319c74].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Shared-Physical-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 17 August 1982 % Revised: 22 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A shared-physical-screen is a rectangular character display whose display % area is shared by a number of different owners. An owner can be any object % that supports the following operations: % % Assert-Ownership () - assert ownership of all desired screen locations % Send-Changes (break-ok) - send all changed contents to the shared screen % Send-Contents (break-ok) - send entire contents to the shared screen % Screen-Cursor-Position () - return desired cursor position on screen % % Each character position on the physical screen is owned by a single owner. % Each owner is responsible for asserting ownership of those character % positions it wishes to be able to write on. The actual ownership of each % character position is determined by a prioritized list of owners. Owners % assert ownership in reverse order of priority; the highest priority owner % therefore appears to "overlap" all other owners. % % A shared physical screen object provides an opaque interface: no access to % the underlying physical screen object should be required. % % 22-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 27-Dec-82 Alan Snyder % Changed SELECT-PRIMARY-OWNER and REMOVE-OWNER to avoid redundant % recomputation (and screen rewriting). % 21-Dec-82 Alan Snyder % Efficiency hacks: Special tests for owners that are virtual-screens. % Added methods: &GET-OWNER-CHANGES, &GET-OWNER-CONTENTS, and % &ASSERT-OWNERSHIP. % 16-Dec-82 Alan Snyder % Bug fix: SET-SCREEN failed to update size (invoked the wrong method). % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors)) (de create-shared-physical-screen (physical-screen) (make-instance 'shared-physical-screen 'screen physical-screen)) (defflavor shared-physical-screen ( height % number of rows (0 indexed) maxrow % highest numbered row width % number of columns (0 indexed) maxcol % highest numbered column (owner-list NIL) % prioritized list of owners (lowest priority first) (recalculate T) % T => must recalculate ownership owner-map % maps screen location to owner (or NIL) screen % the physical-screen ) () (gettable-instance-variables height width) (initable-instance-variables screen) ) (declare-flavor physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: (defmacro map-fetch (map row col) `(vector-fetch (vector-fetch ,map ,row) ,col)) (defmacro map-store (map row col value) `(vector-store (vector-fetch ,map ,row) ,col ,value)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: (defmethod (shared-physical-screen ring-bell) () (=> screen ring-bell)) (defmethod (shared-physical-screen enter-raw-mode) () (=> screen enter-raw-mode)) (defmethod (shared-physical-screen leave-raw-mode) () (=> screen leave-raw-mode)) (defmethod (shared-physical-screen get-character) () (=> screen get-character)) (defmethod (shared-physical-screen convert-character) (ch) (=> screen convert-character ch)) (defmethod (shared-physical-screen normal-enhancement) () (=> screen normal-enhancement)) (defmethod (shared-physical-screen highlighted-enhancement) () (=> screen highlighted-enhancement)) (defmethod (shared-physical-screen supported-enhancements) () (=> screen supported-enhancements)) (defmethod (shared-physical-screen write-to-stream) (s) (=> screen write-to-stream s)) (defmethod (shared-physical-screen set-screen) (new-screen) (setf screen new-screen) (=> self &new-screen) ) (defmethod (shared-physical-screen owner) (row col) % Return the current owner of the specified screen location. (if recalculate (=> self &recalculate-ownership)) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-fetch owner-map row col))) (defmethod (shared-physical-screen select-primary-owner) (owner) % Make the specified OWNER the primary owner (adding it to the list of owners, % if not already there). (when (not (eq (lastcar owner-list) owner)) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf owner-list (aconc owner-list owner)) (when (not recalculate) (=> self &assert-ownership owner) (=> self &get-owner-contents owner nil) (=> self &update-cursor owner) ))) (defmethod (shared-physical-screen remove-owner) (owner) % Remove the specified owner from the list of owners. The owner will lose % ownership of his screen area. Screen ownership will be recalculated in its % entirety when necessary (to determine the new ownership of the screen area). (when (memq owner owner-list) % redundancy check (setf owner-list (DelQIP owner owner-list)) (setf recalculate T) )) (defmethod (shared-physical-screen refresh) (breakout-allowed) % Update the screen: obtain changed contents from the owners, % send it to the screen, refresh the screen. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen refresh breakout-allowed)) (defmethod (shared-physical-screen full-refresh) (breakout-allowed) % Just like REFRESH, except that the screen is cleared first. This operation % should be used to initialize the state of the screen when the program % starts or when uncontrolled output may have occured. (if recalculate (=> self &recalculate-ownership) (=> self &get-owners-changes breakout-allowed) ) (=> screen full-refresh breakout-allowed)) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods % The following methods are for use only by owners to perform the % AssertOwnership operation when invoked by this object: (defmethod (shared-physical-screen set-owner) (row col owner) (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (map-store owner-map row col owner))) (defmethod (shared-physical-screen set-owner-region) (row col h w owner) % This method provided for convenience and efficiency. (let ((last-row (+ row (- h 1))) (last-col (+ col (- w 1))) (map owner-map) ) (cond ((and (<= row maxrow) (<= col maxcol) (>= last-row 0) (>= last-col 0)) (if (< row 0) (setf row 0)) (if (< col 0) (setf col 0)) (if (> last-row maxrow) (setf last-row maxrow)) (if (> last-col maxcol) (setf last-col maxcol)) (for (from r row last-row) (do (for (from c col last-col) (do (map-store map r c owner)) ))))))) % The following method is for use only by owners: (defmethod (shared-physical-screen write) (ch row col owner) % Conditional write: write the specified character to the specified location % only if that location is owned by the specified owner. The actual display % will not be updated until REFRESH or FULL-REFRESH is performed. (if (and (>= row 0) (<= row maxrow) (>= col 0) (<= col maxcol)) (progn (if recalculate (=> self &recalculate-ownership)) (if (eq owner (map-fetch owner-map row col)) (=> screen write ch row col))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: (defmethod (shared-physical-screen init) (init-plist) (=> self &new-screen) ) (defmethod (shared-physical-screen &new-screen) () (setf height (=> screen height)) (setf width (=> screen width)) (=> self &new-size) ) (defmethod (shared-physical-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf owner-map (mkvect maxrow)) (for (from row 0 maxrow) (do (iputv owner-map row (mkvect maxcol)))) (setf recalculate t)) (defmethod (shared-physical-screen &recalculate-ownership) () % Reset ownership to NIL, then ask all OWNERS to assert ownership. % Then ask all OWNERS to send all contents. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (map-store map r c NIL)))))) (for (in owner owner-list) (do (=> self &assert-ownership owner))) (setf recalculate NIL) (=> self &get-owners-contents)) (defmethod (shared-physical-screen &get-owners-changes) (breakout-allowed) % Ask all OWNERS to send any changed contents. (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-changes owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-changes) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-changes owner breakout-allowed) (=> owner send-changes breakout-allowed) )) (defmethod (shared-physical-screen &get-owners-contents) (breakout-allowed) % Ask all OWNERS to send all of their contents; unowned screen area % is blanked. (let ((map owner-map)) (for (from r 0 maxrow) (do (for (from c 0 maxcol) (do (if (null (map-fetch map r c)) (=> screen write #\space r c))))))) (for (in owner owner-list) (with last-owner) (do (=> self &get-owner-contents owner breakout-allowed) (setf last-owner owner)) (finally (if last-owner (=> self &update-cursor last-owner))) ) ) (defmethod (shared-physical-screen &get-owner-contents) (owner breakout-allowed) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$send-contents owner breakout-allowed) (=> owner send-contents breakout-allowed) )) (defmethod (shared-physical-screen &assert-ownership) (owner) (if (eq (object-type owner) 'virtual-screen) % hack for efficiency (virtual-screen$assert-ownership owner) (=> owner assert-ownership) )) (defmethod (shared-physical-screen &update-cursor) (owner) (let ((pair (if (eq (object-type owner) 'virtual-screen) (virtual-screen$screen-cursor-position owner) (=> owner screen-cursor-position) ))) (if (PairP pair) (=> screen set-cursor-position (car pair) (cdr pair))))) (undeclare-flavor screen) |
Added psl-1983/windows/teleray.b version [83ff82d758].
cannot compute difference between binary files
Added psl-1983/windows/teleray.sl version [4c83f1a64a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % TELERAY.SL - Terminal Interface % % Author: G.Q. Maguire Jr., U of Utah % Date: 3 Nov 1982 % based on VT52X.SL by Alan Snyder % Hewlett-Packard/CRC % 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor teleray ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (teleray get-character) () (& (PBIN) 8#377) ) (defmethod (teleray ring-bell) () (out-char BELL) ) (defmethod (teleray move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (teleray enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (teleray leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (teleray erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (teleray clear-line) () (out-chars ESC K) ) (defmethod (teleray convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (teleray normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray highlighted-enhancement) () (dc-make-enhancement-mask) ) (defmethod (teleray supported-enhancements) () (dc-make-enhancement-mask) ) (defmethod (teleray update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (if (> new-code 127) (progn (PBOUT 27) (PBOUT 82) (PBOUT (+ 64 (- new-code 128)))) (PBOUT new-code)) (setf cursor-column (+ cursor-column 1)) (when (> cursor-column maxcol) (setf cursor-column 0) (setf cursor-row (+ cursor-row 1)) (if (> cursor-row maxrow) (=> self move-cursor 0 0) )) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (teleray init) () ) (defmethod (teleray &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (teleray &set-terminal-enhancement) (enh) ) |
Added psl-1983/windows/virtual-screen.b version [ceedd7cd2e].
cannot compute difference between binary files
Added psl-1983/windows/virtual-screen.sl version [a771de14f2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Virtual-Screen.SL % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 18 August 1982 % Revised: 22 February 1983 % % Inspired by Will Galway's EMODE Virtual Screen package. % % A virtual screen is an object that can be used as independent rectangular % character display, but in fact shares a physical screen with other objects. A % virtual screen object maintains a stored representation of the image on the % virtual screen, which is used to update the physical screen when new areas of % the virtual screen become "exposed". A virtual screen does not itself % maintain any information about changes to its contents. It sends all changes % directly to the physical screen as they are made, and sends the entire screen % contents to the physical screen upon its request. % % A virtual screen is a legitimate "owner" for a shared physical screen, in that % it satisfies the required interface. % % 22-Feb-83 Alan Snyder % Declare -> Declare-Flavor. % 28-Dec-82 Alan Snyder % Avoid writing to shared screen when virtual screen is not exposed. Add % WRITE-STRING and WRITE-VECTOR methods. Improve efficiency of CLEAR-TO-EOL % method. Remove patch that avoided old compiler bug. Reformat. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load fast-int fast-vectors display-char)) (de create-virtual-screen (shared-physical-screen) (make-instance 'virtual-screen 'screen shared-physical-screen)) (defflavor virtual-screen ((height (=> screen height)) % number of rows (0 indexed) maxrow % highest numbered row (width (=> screen width)) % number of columns (0 indexed) maxcol % highest numbered column (row-origin 0) % position of upper left on the shared screen (column-origin 0) % position of upper left on the shared screen (default-enhancement (=> screen normal-enhancement)) (cursor-row 0) % the virtual cursor position (cursor-column 0) % the virtual cursor position (exposed? NIL) image % the virtual image screen % the shared-physical-screen ) () (gettable-instance-variables height width row-origin column-origin screen exposed?) (settable-instance-variables default-enhancement) (initable-instance-variables height width row-origin column-origin screen default-enhancement) ) (declare-flavor shared-physical-screen screen) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private Macros: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmacro image-fetch (image row col) `(vector-fetch (vector-fetch ,image ,row) ,col)) (defmacro image-store (image row col value) `(vector-store (vector-fetch ,image ,row) ,col ,value)) (dm for-all-positions (form) % Executes the body repeatedly with the following variables % bound: ROW, COL, SCREEN-ROW, SCREEN-COL. `(for (from row 0 maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))))) (dm for-all-columns (form) % Executes the body repeatedly with the following variables % bound: COL, SCREEN-COL. `(for (from col 0 maxcol) (with screen-col ch) (do (setf screen-col (+ column-origin col)) ,@(cdr form) ))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Public methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen set-size) (new-height new-width) % Change the size of the screen. The screen is first DeExposed. The contents % are cleared. You must Expose the screen yourself if you want it to be % displayed. (=> self deexpose) (setf height new-height) (setf width new-width) (=> self &new-size) ) (defmethod (virtual-screen set-origin) (new-row new-column) % Change the location of the screen. The screen is first DeExposed. You must % Expose the screen yourself if you want it to be displayed. (=> self deexpose) (setf row-origin new-row) (setf column-origin new-column) ) (defmethod (virtual-screen set-cursor-position) (row column) (cond ((< row 0) (setf row 0)) ((> row maxrow) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((> column maxcol) (setf column maxcol))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (virtual-screen write) (ch row column) % Write one character using the default enhancement. (if (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc screen-row (+ column column-origin) self)) ))) (defmethod (virtual-screen write-range) (ch row left-column right-column) % Write repeatedly. (when (and (>= row 0) (<= row maxrow) (<= left-column maxcol) (>= right-column 0) ) (if (< left-column 0) (setf left-column 0)) (if (> right-column maxcol) (setf right-column maxcol)) (let ((dc (display-character-cons default-enhancement 0 (& ch 16#FF))) (screen-row (+ row row-origin)) ) (setq dc (=> screen convert-character dc)) (for (from col left-column right-column) (do (image-store image row col dc) (if exposed? (=> screen write dc screen-row (+ col column-origin) self)) ))))) (defmethod (virtual-screen write-display-character) (dc row column) % Write one character (explicit enhancement) (when (and (>= row 0) (<= row maxrow) (>= column 0) (<= column maxcol)) (setq dc (=> screen convert-character dc)) (image-store image row column dc) (if exposed? (=> screen write dc (+ row row-origin) (+ column column-origin) self)) )) (defmethod (virtual-screen write-string) (row left-column s count) % S is a string of characters. Write S[0..COUNT-1] using the default % enhancement to the specified row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((smax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column smax) maxcol) (setf smax (- maxcol left-column))) (for (from i 0 smax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (string-fetch s i))) (setf ch (display-character-cons default-enhancement 0 ch)) (setf ch (=> screen convert-character ch)) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen write-vector) (row left-column v count) % V is a vector of display-characters. Write V[0..COUNT-1] to the specified % row, starting at the specified column. (when (and (> count 0) (>= row 0) (<= row maxrow) (<= left-column maxcol) (> (+ left-column count) 0) ) (let ((vmax (- count 1)) (image-row (vector-fetch image row)) (screen-row (+ row row-origin)) ) (if (< left-column 0) (setf left-column 0)) (if (> (+ left-column vmax) maxcol) (setf vmax (- maxcol left-column))) (for (from i 0 vmax) (for col left-column (+ col 1)) (for screen-col (+ left-column column-origin) (+ screen-col 1)) (do (let ((ch (vector-fetch v i))) (vector-store image-row col ch) (if exposed? (=> screen write ch screen-row screen-col self)) )))))) (defmethod (virtual-screen clear) () (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for-all-positions (image-store image row col dc) ) (if exposed? (for-all-positions (=> screen write dc screen-row screen-col self) )) )) (defmethod (virtual-screen clear-to-end) (first-row) (if (< first-row 0) (setf first-row 0)) (let ((dc (display-character-cons default-enhancement 0 #\space))) (setq dc (=> screen convert-character dc)) (for (from row first-row maxrow) (with screen-row) (do (setf screen-row (+ row-origin row)) (for-all-columns (image-store image row col dc) ) (if exposed? (for-all-columns (=> screen write dc screen-row screen-col self) )) )))) (defmethod (virtual-screen clear-to-eol) (row first-column) (when (and (>= row 0) (<= row maxrow)) (if (< first-column 0) (setf first-column 0)) (let ((dc (display-character-cons default-enhancement 0 #\space)) (image-row (vector-fetch image row)) ) (setq dc (=> screen convert-character dc)) (for (from col first-column maxcol) (do (vector-store image-row col dc))) (if exposed? (let ((screen-row (+ row row-origin))) (for (from col (+ first-column column-origin) (+ maxcol column-origin)) (do (=> screen write dc screen-row col self))))) ))) (defmethod (virtual-screen expose) () % Expose the screen. Make it overlap all other screens. (=> screen select-primary-owner self) (setf exposed? T) ) (defmethod (virtual-screen deexpose) () % Remove the screen from the display. (when exposed? (=> screen remove-owner self) (setf exposed? NIL) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Semi-Private methods: % The following methods are for use ONLY by the shared physical screen. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen send-changes) (breakout-allowed) % This method is invoked by the shared physical screen to obtain any buffered % changes to the virtual screen image. Since the virtual screen does not % buffer any changes, this method does nothing. ) (defmethod (virtual-screen send-contents) (breakout-allowed) % This method is invoked by the shared physical screen to obtain the entire % virtual screen image. (for-all-positions (let ((ch (image-fetch image row col))) (=> screen write ch screen-row screen-col self) ))) (defmethod (virtual-screen assert-ownership) () % This method is invoked by the shared physical screen to obtain the desired % area for the virtual screen. (=> screen set-owner-region row-origin column-origin height width self) ) (defmethod (virtual-screen screen-cursor-position) () % This method is invoked by the shared physical screen to obtain the desired % cursor position for the virtual screen. (cons (+ cursor-row row-origin) (+ cursor-column column-origin) )) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Private methods: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (virtual-screen init) (init-plist) (=> self &new-size) ) (defmethod (virtual-screen &new-size) () (if (< height 0) (setf height 0)) (if (< width 0) (setf width 0)) (setf maxrow (- height 1)) (setf maxcol (- width 1)) (setf image (make-vector maxrow NIL)) (let ((line (make-vector maxcol #\space))) (for (from row 0 maxrow) (do (vector-store image row (copyvector line)))) ) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (undeclare-flavor screen) |
Added psl-1983/windows/vscreen.t version [acaca8705e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SPECIFICATION OF THE VIRTUAL-SCREEN DATATYPE Cris Perdue 10/1/82 File: pw:vscreen.t VIRTUAL-SCREEN Flavor A virtual screen is an object that can be used as independent rectangular character display, but in fact shares a physical screen with other objects. The coordinate system is based at (0,0) with the origin at the upper left-hand corner of the screen. A virtual-screen has an associated virtual cursor position. Each character on a virtual screen has a specific associated display enhancement, such as inverse video or underlining. A virtual screen object maintains a stored representation of the image on the virtual screen, which is used to update the physical screen when new areas of the virtual screen become "exposed". A virtual screen does not itself maintain any information about changes to its contents. It informs the physical screen of all changes as they are made, and sends the entire screen contents to the physical screen upon its request. In contrast with LISP Machine "windows" (the equivalent of these virtual-screens), a program may write onto a virtual screen at any time. Whether the virtual screen is exposed, covered, or partially covered by virtual screens makes no difference. In all cases any change to a virtual screen that shows is permitted and sent to the shared-physical-screen as soon as it is made. The change is visible to the user as soon as a refresh operation is done. The following initialization options exist: screen (required) The shared-physical-screen on which this screen may become exposed. height, width (optional) The height and width of this screen, in characters. These default to the height and width of the shared-physical-screen of this screen. row-origin, column-origin (optional) Offset of the upper left-hand corner (origin) of this screen from the upper left-hand corner of the associated shared-physical-screen. These may be negative. (?) default-enhancement (optional) Display enhancement(s) to be applied to characters written into this screen by the "write" method. Display enhancements include inverse video and underlining. Defaults to the value of the normal-enhancement of the associated shared-physical-screen. Enhancement values may be legally generated by the function dc-make-enhancement, not documented here. (Defined in the file pw:display-char.sl.) Note: Characters written to this screen by write-display-character do not have the default enhancement applied. Note on clipping: All operations that modify the contents of the virtual screen effectively clip. If any or all of the coordinates to be modified lie outside the screen, any part of the operation applying to those coordinates is ignored and no warning is given. Attempts to move the cursor off the virtual screen just move it to the nearest border point. (CREATE-VIRTUAL-SCREEN SHARED-PHYSICAL-SCREEN) Creates a virtual-screen associated with the specified shared-physical-screen. All the rest of the virtual-screen's attributes are defaulted. (=> VIRTUAL-SCREEN SET-CURSOR-POSITION ROW COLUMN) Sets the virtual-screen's (virtual) cursor position. It is intended that virtual screens will be shown on actual screens that have at least one actual cursor. At certain times there will be an actual cursor displayed at the position of the virtual-screen's cursor. If the position is out of range, the nearest in-range values will be used instead without complaint. (=> VIRTUAL-SCREEN WRITE CH ROW COLUMN) Write a single character, represented as an integer, at the given coordinates. The character is written with the virtual-screen's default enhancements. (=> VIRTUAL-SCREEN WRITE-RANGE CH ROW LEFT-COLUMN RIGHT-COLUMN) Writes the same character to a range of positions within a line of the virtual-screen. The left-column and right-column coordinates are inclusive. The default-enhancements are used. (=> VIRTUAL-SCREEN WRITE-DISPLAY-CHARACTER DC ROW COLUMN) A single character is written to the virtual-screen with explicit enhancements. The DC argument is a character-with-enhancements object, not documented here. (=> VIRTUAL-SCREEN CLEAR) The entire contents of the virtual-screen is set to blanks with the default enhancement. All clearing operations set the cleared portion of the screen to blanks with the default enhancement. (=> VIRTUAL-SCREEN CLEAR-TO-END FIRST-ROW) Clears the entire contents of the rows from first-row to the end of the screen. (=> VIRTUAL-SCREEN CLEAR-TO-EOL ROW FIRST-COLUMN) Clears the given row from first-column to the end. (=> VIRTUAL-SCREEN EXPOSE) Causes the select-primary-owner method to be invoked on the shared-physical-screen of the virtual screen. The effect of this should be to guarantee that the virtual screen is exposed in front of all other virtual screens associated with the same shared-physical-screen (until this operation is invoked on some other virtual-screen). Also guarantees that the actual screen's cursor is displayed at the position of this virtual-screen's cursor. (=> VIRTUAL-SCREEN DEEXPOSE) Causes the remove-owner method to be invoked on the shared-physical-screen of this virtual screen. The effect should be to entirely remove this virtual screen from display on the shared-physical-screen. SEMI-PRIVATE METHODS These methods are invoked by the shared-physical-screen. They are not intended for public use. Shared-physical-screens require their "owner" objects to supply these methods. (=> VIRTUAL-SCREEN SEND-CHANGES BREAKOUT-ALLOWED) An "owner" object is permitted to delay sending changes to the shared-physical-screen. When the shared-physical-screen is to be brought up to date, it invokes this operation on its owners, which must write onto the shared-physical-screen to bring it up to date. Virtual-screens do not buffer or delay any updating, so this operation is a no-op. (=> VIRTUAL-SCREEN SEND-CONTENTS BREAKOUT-ALLOWED) This method is invoked by the shared-physical-screen to force an owner to write its entire contents out to the shared-physical-screen. (=> VIRTUAL-SCREEN ASSERT-OWNERSHIP) This method is invoked by the shared-physical-screen with the expectation that it in turn will invoke the shared-physical-screen's set-owner-region operation with parameters specifying what area is to be occupied by the owner. (=> VIRTUAL-SCREEN SCREEN-CURSOR-POSITION) This method is expected to return the coordinates of the virtual-screen's cursor, in the coordinate system of the shared-physical-screen. |
Added psl-1983/windows/vt52x.b version [9edf869fae].
cannot compute difference between binary files
Added psl-1983/windows/vt52x.sl version [0dc9bb5113].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % VT52X.SL - Terminal Interface % % Author: Alan Snyder % Hewlett-Packard/CRC % Date: 6 October 1982 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (BothTimes (load objects)) (CompileTime (load display-char fast-int fast-vectors)) (defflavor vt52x ( (height 24) % number of rows (0 indexed) (maxrow 23) % highest numbered row (width 80) % number of columns (0 indexed) (maxcol 79) % highest numbered column (cursor-row 0) % cursor position (cursor-column 0) % cursor position (raw-mode NIL) (terminal-enhancement 0) % current enhancement (applies to most output) (terminal-blank #\space) % character used by ClearEOL ) () (gettable-instance-variables height width maxrow maxcol raw-mode) ) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (CompileTime (defmacro out-n (n) `(progn (if (> ,n 9) (PBOUT (+ (char 0) (/ ,n 10)))) (PBOUT (+ (char 0) (// ,n 10)))))) (CompileTime (defmacro out-char (ch) `(PBOUT (char ,ch)))) (CompileTime (dm out-chars (form) (for (in ch (cdr form)) (with L) (collect (list 'out-char ch) L) (returns (cons 'progn L))))) (CompileTime (defmacro out-move (row col) `(progn (out-chars ESC Y) (PBOUT (+ ,row 32)) (PBOUT (+ ,col 32))))) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% (defmethod (vt52x get-character) () (& (PBIN) 8#377) ) (defmethod (vt52x ring-bell) () (out-char BELL) ) (defmethod (vt52x move-cursor) (row column) (cond ((< row 0) (setf row 0)) ((>= row height) (setf row maxrow))) (cond ((< column 0) (setf column 0)) ((>= column width) (setf column maxcol))) (cond ((and (= row cursor-row) (= column cursor-column))) % no action needed ((and (= row 0) (= column 0)) (out-chars ESC H)) % cursor HOME ((= row cursor-row) % movement on current row (cond ((= column 0) (out-char CR)) % move to left margin ((= column (- cursor-column 1)) (out-chars ESC D)) % move LEFT ((= column (+ cursor-column 1)) (out-chars ESC C)) % move RIGHT (t (out-move row column)))) ((= column cursor-column) % movement on same column (cond ((= row (- cursor-row 1)) (out-chars ESC A)) % move UP ((= row (+ cursor-row 1)) (out-char LF)) % move DOWN (t (out-move row column)))) (t % arbitrary movement (out-move row column))) (setf cursor-row row) (setf cursor-column column) ) (defmethod (vt52x enter-raw-mode) () (when (not raw-mode) (EchoOff) % Enable Keypad? (setf raw-mode T))) (defmethod (vt52x leave-raw-mode) () (when raw-mode (=> self &set-terminal-enhancement 0) (setf raw-mode NIL) % Disable Keypad? (EchoOn))) (defmethod (vt52x erase) () % This method should be invoked to initialize the screen to a known state. (out-chars ESC H ESC J) (setf cursor-row 0) (setf cursor-column 0) (setf terminal-enhancement NIL) % force resetting when needed ) (defmethod (vt52x clear-line) () (out-chars ESC K) ) (defmethod (vt52x convert-character) (ch) (setq ch (& ch (display-character-cons (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) (dc-make-font-mask 0) 16#FF))) (let ((code (dc-character-code ch))) (if (or (< code #\space) (= code (char rubout))) (setq ch #\space))) ch) (defmethod (vt52x normal-enhancement) () (dc-make-enhancement-mask) ) (defmethod (vt52x highlighted-enhancement) () (dc-make-enhancement-mask INVERSE-VIDEO) ) (defmethod (vt52x supported-enhancements) () (dc-make-enhancement-mask INVERSE-VIDEO BLINK UNDERLINE INTENSIFY) ) (defmethod (vt52x update-line) (row old-line new-line columns) % Old-Line is updated. (let ((first-col (car columns)) (last-col (cdr columns)) (last-nonblank-column NIL) ) % Find out the minimal actual bounds: (while (and (<= first-col last-col) (= (vector-fetch new-line last-col) (vector-fetch old-line last-col))) (setf last-col (- last-col 1)) ) (while (and (<= first-col last-col) (= (vector-fetch new-line first-col) (vector-fetch old-line first-col))) (setf first-col (+ first-col 1)) ) % The purpose of the following code is to determine whether or not to use % ClearEOL. If we decide to use ClearEOL, then we will set the variable % LAST-NONBLANK-COLUMN to the obvious index; otherwise, we will set it to % NIL. If we decide to use ClearEOL, then we will clear out the OLD-LINE % now, but do the actual ClearEOL later. % Use of ClearEOL is appropriate if the rightmost changed character has % been changed to a space, and the remainder of the line is blank. It % is appropriate only if it replaces writing at least 3 blanks. (when (= (vector-fetch new-line last-col) terminal-blank) (setf last-nonblank-column (vector-upper-bound new-line)) (while (and (>= last-nonblank-column 0) (= (vector-fetch new-line last-nonblank-column) terminal-blank) ) (setf last-nonblank-column (- last-nonblank-column 1)) ) % We have computed the column containing the rightmost non-blank % character. Now, we can decide whether we want to do a ClearEOL or not. (if (and (< last-nonblank-column (- last-col 2))) % then (while (> last-col last-nonblank-column) (vector-store old-line last-col terminal-blank) (setf last-col (- last-col 1)) ) % else (setf last-nonblank-column NIL) )) % Output all changed characters (except those ClearEOL will do): (if (not (and (= cursor-row row) (<= cursor-column first-col))) (=> self move-cursor row first-col)) % The VT52X will scroll if we write to the bottom right position. % This (hopefully temporary) hack will avoid writing there. (if (and (= row maxrow) (= last-col maxcol)) (setf last-col (- maxcol 1)) ) (for (from col first-col last-col) (do (let ((old (vector-fetch old-line col)) (new (vector-fetch new-line col)) ) (when (~= old new) (let ((new-enhancement (dc-enhancement-mask new)) (new-code (dc-character-code new)) ) % Do we need to change the terminal enhancement? (if (~= terminal-enhancement new-enhancement) (=> self &set-terminal-enhancement new-enhancement) ) (=> self &move-cursor-forward col old-line) (PBOUT new-code) (if (< cursor-column maxcol) (setf cursor-column (+ cursor-column 1)) % otherwise % (pretend we don't know the cursor position... % the two versions of the emulator differ at this point!) (setf cursor-column 10000) (setf cursor-row 10000) ) (vector-store old-line col new) ))))) % Do the ClearEOL, if that's what we decided to do. (when last-nonblank-column (=> self &move-cursor-forward (+ last-nonblank-column 1) old-line) (=> self clear-line) ) )) % The following methods are provided for INTERNAL use only! (defmethod (vt52x init) () ) (defmethod (vt52x &move-cursor-forward) (column line) (cond ((> (- column cursor-column) 4) (out-move cursor-row column) (setf cursor-column column)) (t (while (< cursor-column column) (PBOUT (dc-character-code (vector-fetch line cursor-column))) (setf cursor-column (+ cursor-column 1)) )))) (defmethod (vt52x &set-terminal-enhancement) (enh) (setf terminal-enhancement enh) (out-char ESC) (PBOUT 3) (PBOUT (dc-enhancement-index enh)) ) |
Added psl-1983/windows/windows.lap version [900262c232].
> > > > > | 1 2 3 4 5 | (faslin "pw:hp2648a.b") (faslin "pw:physical-screen.b") (faslin "pw:shared-physical-screen.b") (faslin "pw:virtual-screen.b") (faslin "pw:vt52x.b") |
Added psl-1983/x-psl/bare-psl.exe version [c6e12ac320].
cannot compute difference between binary files
Added psl-1983/x-psl/bug-fix.log version [1c86f257f7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | Bug: Compress doesn't work on a list of ASCII values Fix: Make it call Lisp2Char on each element of the list. By: Eric Date: 4:51pm Tuesday, 12 October 1982 Source: PI:EXPLODE-COMPRESS.RED Module: IO in kernel Remarks: The numbers 0..9 no longer work the same as !0..!9 Bug: In open-coded arithmetic/vector access. Fix: Added (USESDEST USESDEST) clause to ASSOCPAT By: Eric Date: 11:10am Monday, 11 October 1982 Source: P20C:DEC20-COMP.RED and PVC:VAX-COMP.RED; P68C:M68K-COMP.RED should also be changed. Module: DEC20-COMP and VAX-COMP Remarks: Bug: Catch no longer needed in Read, due to change in EOF handling Fix: Removed CATCH($READ$, ChannelRead IN*) from READ, similarly for COMPRESS and IMPLODE By: Eric Date: 1:31pm Friday, 8 October 1982 Source: PI:READ.RED, PI:EXPLODE-COMPRESS.RED Module: IO in kernel Remarks: Bug: There is no EXPR for reading files Fix: Change DSKIN from a FEXPR to a one argument EXPR By: Eric Date: 12:14pm Tuesday, 5 October 1982 Source: PI:DSKIN.RED Module: IO in kernel Remarks: This change is incompatible for those using DSKIN with multiple arguments. These uses will have to change to multiple DSKINs. Feature: The printing functions use the variables PRINLEVEL and PRINLENGTH, as described in the Common Lisp Manual. By: Eric Date: 12:12pm Tuesday, 5 October 1982 Source: PI:PRINTERS.RED Module: IO in kernel Remarks: Bug: BIGNUM quotient, re-evaluation errors Fix: Improved BIGNUM and BIGFACE installed By: M. L. Griss, for A. C. Norman Date: 4 October 1982. Source: PU:BIGFACE.RED, PU:BIGBIG.RED Module: BIGNUM Remarks: Some errors still remain, in BLDIFF, etc. and minor typo's fixed. Bug: Scantable in POLY was inherited from CURRENTSCANTABLE!* not "nice" under PSL Fix: Added an ALGSCANTABLE!*, similar to RLISP table By: Martin Date: 3:41pm Tuesday, 28 September 1982 Source: PU:POLY.RED Module: POLY Remarks: Bug: (REMAINDER (RANDOM) n) wasnet good for 3,7 or 11 Fix: Defined RandomModulus variable and RANDOMMOD(N) function By: Martin Date: 3:38pm Tuesday, 28 September 1982 Source: PU:mathlib.red Module: MATHLIB Remarks: Maybe just a "quick" fix and needs further examination Bug: CopyStringToFrom wasn't safe Fix: Make it safe By: Cris Date: 10:37am Tuesday, 28 September 1982 Source: PI:COPIERS.RED Module: kernel Remarks: Bug: *THROW wasn't restoring the outer variable bindings Fix: Call on RestoreEnvironment. By: Eric Date: 8:55am Monday, 27 September 1982 Source: PI:CATCH-THROW.RED Module: EVAL in kernel Remarks: Bug: PRINTX in DEBUG didn't handle circular vectors. Fix: Now it does. By: Eric Date: 5:44pm Friday, 24 September 1982 Source: PU:DEBUG.RED Module: DEBUG Remarks: Also made DEBUG use CODE-NUMBER-OF-ARGUMENTS to find out the # of arguments to a compiled function. Feature: The printing function for code pointers prints the number of arguments expected, in the format #<Code 3 284313>, where 3 is the # of arguments and 284313 is the address. The address part is now printed in the "preferred" radix of the machine, defined by the WConst CompressedBinaryRadix, which is 8 on the Dec-20 and Cray, and 16 on the Vax, 68000, and 360. By: Eric Date: 5:38pm Friday, 24 September 1982 Source: PI:PRINTERS.RED and PXX:GLOBAL-DATA.RED (for constant definition) Module: IO in kernel Remarks: Bug: No way to find out how many arguments a compiled function gets. Fix: Put a header above the entry point with the # of arguments, accessed by the function CODE-NUMBER-OF-ARGUMENTS, which expects a code pointer as its argument and returns the number of arguments the code pointer expects, or NIL. By: Eric Date: 5:17pm Friday, 24 September 1982 Source: PC:PASS-1-LAP.SL (to add header word), PC:DATA-MACHINE.RED (to define access macro), PI:PUTD-GETD.RED (to define callable entry point). Module: PASS-1-LAP, SYSLISP, PROP in kernel Remarks: Only functions compiled since this change have the header word; old FASL files will have to be recompiled to make use of this feature. Bug: IDs (symbols) are not garbage collected. Fix: Allocate symbols as a free list linked through the name cell By: Eric Date: 5:02pm Friday, 24 September 1982 Source: PI:COPYING-GC.RED, PI:COMPACTING-GC.RED, PI:ALLOCATORS.RED, PC:LAP-TO-ASM.RED Module: LAP-TO-ASM, ALLOC in kernel Remarks: Bug: "FOO not compiled" messages in compiler are still unclear. Fix: Now says "Value of FOO not used, therefore not compiled", or "Top level FOO in (FOO BAR) not used, therefore not compiled" By: Eric Date: 11:43am Monday, 20 September 1982 Source: PC:COMPILER.RED Module: COMPILER Remarks: Bug: Printing {99} in ERROR is only noise. Fix: Only print message, don't print number By: Eric Date: 11:32am Monday, 20 September 1982 Source: PI:ERROR-ERRORSET.RED and PI:ERROR-HANDLERS.RED Module: ERROR in kernel Remarks: Bug: Unmatched right paren in a file is not an error. Fix: Only allow an unmatched right paren from the terminal By: Eric Date: 11:26am Monday, 20 September 1982 Source: PI:READ.RED Module: IO Remarks: Bug: CAR of a form is sometimes evaluated; compiler and Eval do not agree. Fix: CAR of a form is NEVER evaluated; only a LAMBDA form or globally defined function name is allowed. By: Eric Date: 10:41am Monday, 20 September 1982 Source: PC:COMPILER.RED and PI:EVAL-APPLY.RED Module: EVAL in kernel, and COMPILER Remarks: Bug: Backtrace is not very helpful Fix: Suppress printing of interpreter functions; better formatting By: Eric Date: 10:24am Monday, 20 September 1982 Source: PI:BACKTRACE.RED Module: EXTRA Remarks: It's still not too hot. Bug: The prettyprinter is weak, and conses a lot. Fix: Use the IMSSS prettyprinter, with a few modifications. By: Eric Date: 9:27am Monday, 20 September 1982 Source: Added PU:PRETTYPRINT.SL and PU:PRETTYPRINT.BUILD. Deleted PU:PRETTY.RED and PU:PRETTY.BUILD. Changed PI:AUTOLOAD.RED Module: Removed PRETTY, added PRETTYPRINT, changed FASL in kernel Remarks: Bug: Not all I/O functions have channel-specific counterparts Fix: Added ChannelTerPri, ChannelLineLength, ChannelPosn, ChannelEject ChannelReadCH, ChannelPrint, ChannelPrin2T, ChannelSpaces ChannelTab, ChannelSpaces2, ChannelPrinC By: Eric Date: 4:21pm Friday, 17 September 1982 Source: on PI: PRINTF.RED, OTHER-IO.RED, EASY-SL.RED, EASY-NON-SL.RED Module: IO and RANDM, in kernel Remarks: Bug: DO with no return forms returns T instead of NIL Fix: Typo in DO, DO*, DO-LOOP, DO-LOOP*, ((null (cdr result) nil)) ==> ((null (cdr result)) nil) By: Eric Date: 5:09pm Wednesday, 15 September 1982 Source: PU:ITER-MACROS.SL Module: USEFUL Remarks: Bug: Token scanner won't read 1+ and 1- as symbols Fix: Patch in ChannelReadToken By: Eric Date: 11:01am Wednesday, 15 September 1982 Source: PI:TOKEN-SCANNER.RED Module: IO in kernel Remarks: Still doesn't scan -1+ as a symbol Bug: InternP doesn't work for strings Fix: Checks to see if a symbol with that pname is interned By: Eric Date: 9:36am Wednesday, 15 September 1982 Source: PI:OBLIST.RED Module: SYMBL in kernel Remarks: Bug: (igetv (igetv x 5) y) generates bad code Fix: Add USESDEST clause to ASSOCPAT in xxx-COMP.RED By: Eric Date: 2:11pm Monday, 13 September 1982 Source: P20C:DEC20-COMP.RED and PVC:VAX-COMP.RED (Should also be done to P68C:M68K-COMP.RED). Module: DEC20-COMP and VAX-COMP Remarks: Bug: in EXP Fix: Changed 2**N to 2.0**N By: Eric Date: 8:50am Monday, 13 September 1982 Source: PU:MATHLIB.RED Module: MATHLIB Remarks: Bug: APPLY(x, list(1,2,3,4,5,6)) doesn't avoid consing Fix: Add a PA1FN for APPLY so that !&PaList isn't applied to the 2nd arg By: Eric Date: 4:26pm Friday, 10 September 1982 Source: PC:COMPILER.RED and PC:COMP-DECLS.RED Module: COMPILER, COMP-DECLS Remarks: Bug: Compiler error and warning messages are confusing Fix: Use more English, always print the function name By: Eric Date: 9:54am Friday, 10 September 1982 Source: PC:COMPILER.RED Module: COMPILER Remarks: Bug: FLUID and MACRO can't have the same name Fix: Use indicator VARTYPE for variables, instead of sharing TYPE with functions. By: Eric Date: 9:16am Friday, 10 September 1982 Source: PI:FLUID-GLOBAL.RED Module: PROP in kernel Remarks: Bug: DUMPLISP blows away the last page of the stack in rare cases on the 20 Fix: Add some slack in the call to UNMAP-SPACE from DUMPLISP By: Eric Date: 10:24am Friday, 3 September 1982 Source: P20:DUMPLISP.RED Module: EXTRA Remarks: Bug: WNOT was not caught by constant folding Fix: Added PA1REFORMFN = &DOOP for WNOT By: Eric Date: 9:47am Friday, 3 September 1982 Source: PC:COMP-DECLS.RED Module: COMP-DECLS Remarks: Bug: CHAR-UPCASE and CHAR-DOWNCASE returned NIL instead of their arguments if the function didn't modify them. Fix: Return the argument instead By: Eric Date: 2:25pm Thursday, 2 September 1982 Source: PU:CHARS.LSP Module: CHARS Remarks: Bug: Right parens cause an error at the top level Fix: Make ) a read macro to be ignored outside of list reading By: Eric Date: 2:08pm Thursday, 2 September 1982 Source: PI:READ.RED Module: IO in kernel Remarks: Bug: PSL-SAVE.CTL requires that you are connected to P20: Fix: add a logical name definition def DSK: DSK:,P20: By: Eric Date: 1:35pm Thursday, 2 September 1982 Source: P20:PSL-SAVE.CTL Module: None Remarks: Bug: XJsysError and JSYS constants are wrong Fix: Fixed. By: Eric Date: 1:28pm Thursday, 2 September 1982 Source: P20:20-INTERRUPT.RED Module: INTERRUPT Remarks: Bug: MACROEXPAND does not handle multiple argument SETQ Fix: Removed MACROEXPAND-SETQ, use MACROEXPAND-RANDOM instead By: Eric Date: 10:33am Thursday, 2 September 1982 Source: PU:MACROEXPAND.SL Module: USEFUL Remarks: Bug: Functions in Mathlib call REDERR which is only defined in Rlisp Fix: Have them call StdError instead By: Eric Date: 9:20am Thursday, 2 September 1982 Source: PU:MATHLIB.RED Module: MATHLIB Remarks: Bug: Prettyprint returns its argument, which is worse than useless Fix: Make it return NIL instead By: Eric Date: 9:15am Thursday, 2 September 1982 Source: PU:PRETTY.RED Module: PRETTY Remarks: Bug: ContError does not handle atoms as the ReEvalForm Fix: Now it does. By: Eric Date: 9:11am Thursday, 2 September 1982 Source: PI:CONT-ERROR.RED Module: MACRO in kernel Remarks: Bug: (QUOTE x y) is incorrectly printed Fix: Change ChannelPrintPair so that only (QUOTE x) prints as 'x By: Eric Date: 8:59am Thursday, 2 September 1982 Source: PI:PRINTERS.RED Module: IO in kernel Remarks: |
Added psl-1983/x-psl/bug-mail.txt version [04d9b532d1].
more than 10,000 changes
Added psl-1983/x-psl/bugs.list version [a4ceff961c].
> > > > > > > | 1 2 3 4 5 6 7 | PSL-bug-missfeature-recipients: @<PSL.UTAH>LOCAL-PSL-BUGEES.LIST, "hplabs!localpsl"@cs, ; People interested in commenting on suspected PSL bugs/missfeatures. ; This is the one that comes in locally and will go to hplabs also. ; Referenced by PSL-BUGS. ; Maintained by KESSLER |
Added psl-1983/x-psl/bugs.txt version [962f325889].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 | Date: 1-Nov-82 14:56:40 From: Cris Perdue <Perdue at HP-HULK> Subject: APPEND Class: Request, deficiency In PSL the function APPEND now takes exactly 2 arguments. Could it be extended to take an arbitrary number. Probably 0 and 1 should also be legitimate numbers of arguments. What say? RESPONSE (Eric): Someday... Date: 30-Oct-82 18:49:42 From: douglas <LANAM at HP-HULK> Subject: difference in apply betwen compiled and interpreted code. Class: Bug Dealing with apply to nexprs.: 18 lisp> (dn nexpr (a) (princ a) (terpri)) NEXPR 19 lisp> (de calling-function (arg) (apply (function nexpr) (list arg)) 19 lisp> ) CALLING-FUNCTION 20 lisp> (calling-function 'a) A NIL 21 lisp> (calling-function '(a b)) (A B) NIL 22 lisp> (compile '(calling-function)) *** Function `CALLING-FUNCTION' has been redefined *** (CALLING-FUNCTION): base 257007, length 3 words NIL 23 lisp> (calling-function '(a b)) ((A B)) NIL 24 lisp> (calling-function 'a) (A) NIL 25 lisp> ^C -------- Note: This bug does not exist on the vax. On the vax, this function runs the same interpretively and compiled. (The interpretive version on the 20 is the same definition as that on the vax). This use to work on the 20 until about 3 weeks ago. douglas RESPONSE (Eric): Fixed. Date: 27-Oct-82 17:16:07 From: douglas <LANAM at HP-HULK> Subject: bug in psl - (tr get) Class: Bug Do (tr get) in psl, and you get an endless message: ***** Undefined function 'GET' called from compiled code over and over and over and over ... douglas RESPONSE (Eric): It should not let you (tr get). This could be fixed by changing DEBUG not to use REMD, and using some other method of avoiding the "foo redefined" message. Date: 22-Oct-82 09:38:48 From: douglas <LANAM at HP-HULK> Subject: function timings. Class: Request Is it possible to make a version of psl that gives me a profile of all the lisp functions called and how much cpu time was spent in each. (I would assume since this involves some overhead, it should not be put in the standard psl). It would be preferable to have this on the vax. RESPONSE (Lanam): Doug has written a package to do this. Date: 18-Oct-82 12:29:47 From: Alan Snyder <AS at HP-HULK> Subject: compiler bug Class: Compiler bug The compiler incorectly compiles the first clause of the COND in the function below. It compiles to return M2, rather than M1. (de foo (i1 i2) (let ((m1 (> i1 3)) (m2 (> i2 4)) ) (cond ((not (eq m1 m2)) m1) (t (+ i1 i2)) ))) RESPONSE (Eric): Fixed. Date: 15 Oct 1982 1131-PDT From: PERDUE at HP-HULK Subject: Make-String Class: Documentation bug The reference manual claims that the first argument to make-string is the upper limit for indices into the string, but in fact it is the number of characters in the string. RESPONSE (): Still extant. Date: 9-Oct-82 12:14:25 From: douglas <LANAM at HP-HULK> Subject: Terminal interrupt (^B) error Class: Bug Similar to the one on the vax, on the 20 it also tries to reexecute previously typed in expressions. 8 lisp> (show 'thing) (thing (ako ($if-added (add-instance)) ($if-removed (remove-instance))) (instance ($value (request) (domain) (rule)) ($if-added (add-ako)) ($if-removed (remove-ako))) (self ($value (%(fname :frame))))) nil Time: 120 ms 9 lisp> *** Break in cleario at 43316 Break loop ***** `show' is an unbound ID ***** Continuation requires a value for `show' Break loop thing Time: 1 ms 12 lisp break>>> ^C douglas RESPONSE (): Extant bug. Date: 7-Oct-82 15:17:52 From: Alan Snyder <AS at HP-HULK> Subject: Interaction with EXEC location printout Class: Bug PSL is apparently using a reserved location in an improper way. The location ".JBSYM" (whatever that is) is supposed to point to a symbol table, but it apparently does not contain a proper value, since if you ask EXEC to print out locations in symbolic mode, the EXEC will blow up trying to do a symbol table lookup. Please fix this bug. (I have noticed NDDT get screwed up doing symbol table lookup also; perhaps this is the cause of that problem as well.) (This analysis is based on information provided by Tim Eldredge.) RESPONSE (Eric): BARE-PSL is now created with no symbol table at all. This prevents the EXEC from being blown up, but prevents debugging at times. The LINKER was trying to make a symbol table that wouldn't fit in memory with PSL. Date: 6-Oct-82 10:00:11 From: FILMAN at HP-HULK Subject: Re: apply and list Class: Complaint, documentation deficiency If only EXPRs can be correctly applied, then you need to fix the documentation, where it says: "We permit macros and fexprs to be applied;" though the rest of the sentence presents a confusing disclaimer. In any case, why can FEXPRs and MACROS be correctly applied? Bob RESPONSE (Eric): They can be applied, but the result of Apply(FexprOrMacro, X) is the same as Apply(cdr getd FexprOrMacro, X). That means that the code is treated as though it were an EXPR. FEXPRs take a single argument, which is a list of unevaluated parameters. In the case of EXPRs, Apply(X, Y) is the same as Eval(cons(X, for each U in Y collect list('QUOTE, U))). This is not the case for FEXPRs or macros. In the case of macros, Apply can be used to perform macro expansion, i.e. (apply 'let '((let ((x y)) z))) returns ((lambda (x) z) y). In the case of FEXPRs, the list given to APPLY should have one element, which is the formal parameter to the function, e.g. if x=1, y=2 and z=3, then (apply 'list '((x y z))) returns (1 2 3). This type of thing is only dome in unusual situations, e.g. in Eval. It is generally not recommended that macros and fexprs be given to APPLY. The function which does what you want is EVAL. Date: 5-Oct-82 17:47:25 From: FILMAN at HP-HULK Subject: Apply and list Class: Inquiry, deficiency Apply doesn't seem to work with list. I.e.: (apply 'list '(3 4 5)) ==> nil Is this a feature or a bug? Bob RESPONSE (Eric): Only EXPRs can be APPLYed correctly. LIST is a FEXPR. Date: 5 Oct 1982 1628-PDT From: Alan Snyder <AS at HP-HULK> Subject: Fast vector access Class: Compiler bug The PSL compiler still has a bug related to fast vector access: (de foo (v) (cons (+ (igetv v 0) (igetv v 1)) (+ (igetv v 2) (igetv v 3)) )) FOO (setf v [1 2 3 4]) [1 2 3 4] (foo v) (3 . 7) (compile '(foo)) *** (FOO): base 460253, length 6 words NIL (foo v) (0 . 7) (*ENTRY FOO EXPR 1) (*ALLOC 0) (*MOVE (MEMORY (REG 1) (WCONST 4)) (REG 2)) (*WPLUS2 (REG 2) (MEMORY (REG 1) (WCONST 3))) (*MOVE (MEMORY (REG 1) (WCONST 1)) (REG 1)) (*WPLUS2 (REG 1) (MEMORY (REG 1) (WCONST 2))) (*LINKE 0 CONS EXPR 2) RESPONSE (Eric): Fixed. Date: 5-Oct-82 15:11:06 From: Cris Perdue <Perdue at HP-HULK> Subject: Documentation for REPEAT Class: Documentation bug Documentation for REPEAT is still incorrect in the latest PSL reference manual. The syntax is: Repeat ([S:form], E:form): nil RESPONSE (): Still extant. Date: 2-Oct-82 14:15:18 From: douglas <LANAM at HP-HULK> Subject: Printing of error messages in compiler. Class: Suggestion Could the error messages that are longer than one line, be indented about 1 tab stop (5-8 spaces on the 2nd and succeeding lines so that they stand out and are easier to distinguish and read). An example would be *** Car in (car (foo 'foo1 (foo2 (foo3 'ffo4 (foo4 'xjks) 'sdjkl) (append (foo2 'x) (apply 'foo3 '4))))), not used, therefore not compiled. Due to macros, a number of these come up in my program. thanks, douglas RESPONSE (Cris): Low priority. Date: 2-Oct-82 12:48:03 From: douglas <LANAM at HP-HULK> Subject: PRINC does too much. Class: Complaint Princ should not check the position of the line to determine whether or not the atom will fit. There should be a higher level function with that property. I thought princ should just print the atom. (or is there a lower level princ with out that check and possibly added carriage return not printed). douglas RESPONSE (Eric): Improvement is needed. Date: 2-Oct-82 12:46:12 From: douglas <LANAM at HP-HULK> Subject: Please do not have psl come up in the editor. Class: Complaint This is not a desired start up position. 1) Reading logs of background jobs is very difficult, if you can get them to work at all. 2) Nmode does not work on a lot of terminals. (including the ever popular chipmunk. 3) The first thing I want to do in a lisp is dskin or fasl in my files, not edit a command to do this. 4) It is even difficult to run do's with this type of mode. (shell scripts). douglas RESPONSE (AS): PSL no longer comes up in the editor. Date: 1-Oct-82 11:23:53 From: Alan Snyder <AS at HP-HULK> Subject: Printing of the escape character (!) Class: Complaint, deficiency The atom - prints as !- in Lisp mode. The atom + prints as !+ in Lisp mode. I believe this is a mistake. The printer should not insert unnecessary !'s. RESPONSE (Cris): Extant deficiency. I assume it will be fixed when someone shows he/she is being really hurt. It's a real crock in my personal opinion. Date: 30-Sep-82 11:09:01 From: Alan Snyder <AS at HP-HULK> Subject: "<foo> already loaded" messages Class: Request, complaint I would like to reiterate a request made previously, I believe, by Doug to get rid of the "FOO already loaded" messages. If you feel strongly that some sort of warning is needed when people type (LOAD FOO) by hand, then I would suggest having LOAD return a string that would be printed by the Read-Eval-Print loop. I don't think there is any need to print these messages when the LOAD is contained in a file (either source or object) that is being read. RESPONSE (Eric): Fixed. Date: 29-Sep-82 11:34:48 From: douglas <LANAM at HP-HULK> Subject: upon exit of psl (or interrupt with ^c). Class: Request Can the terminal keys be restored upon exit of psl-nmode (or interrupt with ^c)? dougla Add to things psl should do when ^c is typed: restore cntl-s. (This should be possible since emacs does this). douglas RESPONSE (Cris): Use C-X C-Z to exit NMODE; this problem does not occur when using ^C to exit PSL in its ordinary top loop. Date: 29-Sep-82 10:01:01 From: douglas <LANAM at HP-HULK> Subject: Bug in nmode Class: Bug, deficiency If you type (expression) cntrl-] E. where the cntrl-] E is on the start of a new line, you get Exiting NMODE Lisp End of File read!, shouldn't it execute the last expression? Why should typing a carriage return before the cntrl-] E make a difference? douglas RESPONSE (Alan): If RETURN is typed before Lisp-E, NMODE is not supposed to read the previous expression. "End of File read!" is a reasonable response. "Exiting NMODE Lisp" is a confusing message, but not generated by NMODE. Date: 28-Sep-82 20:59:41 From: douglas <LANAM at HP-HULK> Subject: Close all parenthsis to a particular level. Class: Request How about adding the ability of ] to close all parenthesis (as in franz, maclisp, ucilisp). It would be nice if it could stop at [ (as in franz, maclisp, ucilisp). But I realize you use [] for reading arrayes, thus maybe you could use {} for this type of bracketing. It would be nice to type } to close an expression instead of )))))) (and have to count them also, or wait for the editor to match them flipping the screen at 1200 baud (That process is a pain to go through in the editor). douglas RESPONSE (Cris): This is a relatively low priority now, I'd say. Date: 28-Sep-82 13:50:35 From: Cris Perdue <Perdue at HP-HULK> Subject: CompileTime and DskIn Class: Note (CompileTime (dskin "blah.sl")) has the effect of treating the contents of blah.sl as though they were textually embedded in the file with the CompileTime form: those forms are compiled. (CompileTime (load blah)) on the other hand causes the definitions in blah.b to be made available at compile time. Even if there is a text file blah.lap rather than binary blah.b, "load" seems to only load the definitions. If a file with (CompileTime (load foo)) in it is compiled, and if foo.lap (another source file) exists rather than foo.b, then the contents of foo.lap are effectively included in the source file I am trying to compile. This is a difference in behavior between compiled and non-compiled files. RESPONSE (Eric): Extant bug. This is the actual behavior. LOAD should always make the definitions available rather than compiling them. It is intended that DSKIN result in compiling the contents of the file referred to. Date: 28-Sep-82 11:19:30 From: Alan Snyder <AS at HP-HULK> Subject: RETURN complaint Class: Compiler bug, complaint The PSL compiler now produces an error message if it encounters a RETURN with no arguments. This is fine. However, it still generates an invocation of "NIL". It should be possible to avoid generating garbage code when there are errors in the source. RESPONSE (Eric): A warning is now issued, but code to return NIL is generated and compilation continues. Date: 28-Sep-82 11:01:15 From: Cris Perdue <Perdue at HP-HULK> Subject: Documentation update for CopyStringToFrom Class: Note Copy all characters from OLD into NEW. This operation is destructive. If the lengths of OLD and NEW differ, only the lesser number of characters is copied. If NEW is longer than OLD, the part not copied into is left unchanged. RESPONSE (): To be put into the manual. Date: 27-Sep-82 13:01:31 From: Alan Snyder <AS at HP-HULK> Subject: Undefined functions Class: Complaint The error "Undefined function FOO called from compiled code" should (i.e., ought to be, for the user's sake) continuable. RESPONSE (Eric): Yes, that would be one benefit of loading a register with the number of arguments being passed to a function. The problem now is that continuation is performed by interpreting a LISP form, and it is not known how many arguments should be put in the list to be evaluated. Date: 27-Sep-82 11:27:15 From: Cris Perdue <Perdue at HP-HULK> Subject: EOF handling Class: Inquiry There appears to be no documentation in the reference manual concerning end of file handling, except for the case of READ. It appears to be undocumented for ChannelReadChar in particular. RESPONSE (Cris): See below, message from AS. Date: 27-Sep-82 04:33:32 From: douglas <LANAM at HP-HULK> Subject: Speed of psl Class: Inquiry I am finding psl on the vax to be much slower than psl on the 20. Is this true? Is there any reason for this? (Things are noticiable a factor of 4 slower with equivalent load averages - but I did not do any timings). douglas RESPONSE (): ?? Date: 27-Sep-82 09:02:49 From: Alan Snyder <AS at HP-HULK> Subject: ChannelRead exception handling Class: Bug, documentation error The manual says that ChannelRead will catch $READ$ and return $EOF$. This is false; only Read does the catch. RESPONSE (Eric): None of the input functions use THROW any more. Thus no catches are performed, either. READ and company return the value of the variable $EOF$. Character at a time functions return (char EOF). Date: 24-Sep-82 14:20:40 From: FILMAN at HP-HULK Subject: Page and section numbers Class: Suggestion, complaint I find confusing the fact that (in the PSL manual) page and section numbers are annotated the same way. When the index refers to 8.5, I don't know whether to rush off to section 8.5 (wrong) or page 8.5 . How about 8.5 for sections and 8-5 for pages, or something like that? Bob RESPONSE (): No response yet. Date: 27 Sep 1982 03:57:05-PDT From: douglas at HP-Hewey Subject: VAX version and prettyprint Class: VAX deficiency The module prettyprint does not exist on the vax (only the older module pretty). douglas RESPONSE (Eric): Fixed. Date: 23-Sep-82 15:26:13 From: douglas <LANAM at HP-HULK> Subject: Backtrace. Class: Complain I found if you have (x (y (z a))) and you get an error evaluating (z a), you might find x and y on the backtrace stack even though you haven't executed it yet. Worse, if you trace y, y will never say it is entered but will be on the backtrace stack. douglas RESPONSE (Cris): Just what should appear on the backtrace stack and when is has been a matter of some debate. The phenomenon you are seeing occurs just in interpreted code. Date: 22-Sep-82 15:34:38 From: douglas <LANAM at HP-HULK> Subject: DO loops Class: Bug do still returns t when there are no clauses after the test. the manual says it returns nil. RESPONSE (Eric): USEFUL has been rebuilt and presumably DO is correct. Date: 20-Sep-82 15:50:44 From: douglas <LANAM at HP-HULK> Subject: Scanner Class: Bug 1.2xa is read as two tokens 1.2 and xa. 1.2ea gives a error message that the exponent is missing. same with 1.2x-a and 1.2e-a 1xa is two atoms 1 and xa. 1ea says that the exponent in the float is missing. douglas RESPONSE (Cris): Still extant. I consider this a relatively low priority. Common LISP has a well-defined and general scanner that we should implement eventually. Date: 20-Sep-82 11:07:38 From: Alan Snyder <AS at HP-HULK> Subject: Excess right parens during compilation Class: Complaint When compiling a file, extra right parens should produce a warning message, as (in my case) they often are the result of a paren mismatch in the middle of a function definition. RESPONSE (Eric): The compiler now gives a warning message about this. Date: 20-Sep-82 10:43:11 From: Alan Snyder <AS at HP-HULK> Subject: Functions to "replace" MAIN Class: Complaint I have found when writing functions designed to "replace" MAIN, that it is necessary for those functions to initialize the variables CurrentReadMacroIndicator* and CurrentScanTable*, otherwise after a SaveSystem when the program comes up, the scan table will be in a very strange state. I believe that this initialization should be performed by a "pre-main" procedure and that user-written "main" procedures should be spared these details, which tend to be system-dependent. Your source code for Main claims "Redefine this function to call whatever top loop is desired." I agree, except that "this function" should be one that does nothing except invoke the "standard" top loop. RESPONSE (Eric): Fixed. Date: 20-Sep-82 09:06:06 From: PAULSON Subject: Read macros, the "BUG" function Class: Bug, deficiency Two problems: (1) Read macros are apparently not attached to read tables. Therefore a read macro for one read table may interfere with other read tables, including the system read table. (2) the function BUG bombs on directory access privileges. RESPONSE (Cris): Still extant. At some point the Common LISP input mechanisms should be implemented for PSL, solving the read macro problem. RESPONSE (Cris): The BUG function is still incorrect, but in a different way. Date: 18-Sep-82 15:54:10 From: douglas <LANAM at HP-HULK> Subject: What does #<Code:0> mean? Class: Inquiry Why is this the return value of faslin? RESPONSE (Eric): No comment on this question. Faslin now returns NIL. Date: 17-Sep-82 11:40:31 From: Alan Snyder <AS at HP-HULK> Subject: Use of fluid variables Class: Suggestion As part of the current effort to "clean up" PSL, I would like to suggest that an effort be made to reduce or eliminate the use of fluid variables as "optional" or "implied" arguments, by defining new functions with explicit arguments. For example, instead of having SpecialReadFunction*, SpecialWriteFunction*, and SpecialCloseFunction*, there should be an additional function OpenSpecial that takes four arguments, the filename, and the three functions. Another example is DumpFileName*: currently there is no way to save a PSL that does not have DumpFileName* bound to the name of the file it was dumped to. In the case of "system" programs, the default dump file should probably be "PSL.EXE" (i.e., something that would write in the user's directory). There should be a variant of DumpLisp that takes the filename as an argument (and does NOT bind DumpFileName*). These are the two examples that come to mind, there may be others. RESPONSE (Eric): DumpLisp and SaveSystem now take arguments rather than using fluid variables. The problem with fluid variables and "open" is still extant. Date: 17-Sep-82 11:14:26 From: Alan Snyder <AS at HP-HULK> Subject: message "($FLUID FOO) not compiled" Class: Compiler complaint, inquiry What does the message "($FLUID FOO) not compiled" mean? It sounds like the compiler has broken or something, although the program seems to work. Furthermore, why shouldn't it be compiled? Did the compiler run out of registers or something? Suggested fix: either fix the compiler to compile it, or change the error message to be more informative to naive users. RESPONSE (Eric): The message has been changed to "not used, therefore not compiled." Date: 17-Sep-82 09:54:27 From: Alan Snyder <AS at HP-HULK> Subject: Endings of strings Class: Complaint If I forget the ending " on a string in a file, then I get one message "string continued over EOL" for every succeeding line in the file when the file is read in. There should be only one message given. Furthermore, if you believe that multi-line strings are bad (which I do), then you should probably generate an Error so that you don't read the remainder of the file in "reverse polarity" (in terms of what is inside vs. outside of string literals). (Manual note: I couldn't find anything in my manual that addresses the issue of multi-line string literals.) RESPONSE (Eric): There is (and has been) a flag to turn off the message. I don't plan to change this; some major users in fact depend heavily on multi-line string literals. Date: 17-Sep-82 02:46:17 From: douglas <LANAM at HP-HULK> Subject: Proposal for inum/wnum arithmetic. Class: Suggestion I have thought of a reason for having both i and w commands. I think the w should be what both are now (just do the machine operation and dont worry about tags). But the i commands (iplus, ishift, ilor, etc.) could take their arguments make sure they are working on a full word (either go down the pointer to the integer object or move the immediate number into a full word (or register), play with it there, then if the number if to be passed to another procedure or used outside the context of the i num arithmetic functions, to be send to a function that would convert the word back to psl format. If small, convert to immediate format, if big, return the pointer to the object. This way I could have access to a full word on any machine, and be able to produce efficient open code, and not have to worry about the psl tag bits. The proposal would be if the system sees (ilor (ishift x n) (iland a b)), that x, n, a, and b would be converted first, then the operations done, and then the one result would be converted back. No type checking would be done (if it is an immediate number, the pointer would be followed and its location used, for efficiency.). How does this idea sound? RESPONSE (Eric): Not altogether right. Some of this would be more applicable to Franz LISP than it is to PSL. Date: 16 Sep 1982 1141-PDT From: Kendzierski at HP-HULK (Nancy) Subject: UNION clause of FOR Class: Documentation bug The manual states that "(UNION EXP) is similar to (COLLECT EXP), but only adds an element to the list if it is not equal to anything already there." However, I get the following results with COLLECT and UNION: ----------------------------- (for (from i 1 4) (collect (cond ((= i 1) 1) ((= i 2) 1) ((= i 3) 3) ((= i 4) 3)) )) Returned: (1 1 3 3) ----------------------------- (for (from i 1 4) (union (cond ((= i 1) 1) ((= i 2) 1) ((= i 3) 3) ((= i 4) 3)) )) Returned: 3 ----------------------------- RESPONSE (Cris): Actually, UNION is similar to JOIN rather than COLLECT. Thanks. (The manual is incorrect.) Date: 13 Sep 1982 1249-PDT From: Alan Snyder <AS at HP-HULK> Subject: Make-String Class: Bug in COMMON.SL Make-String in compiled form creates a string with 1 too many elements. RESPONSE (Eric): Fixed. Date: 10 Sep 1982 1606-PDT From: Alan Snyder <AS at HP-HULK> Subject: (APPLY x (LIST a b c...)) Class: Bug, complaint The manual states that (APPLY x (LIST a b c...)) is compiled in such a way that the list (LIST a b c ...) is not actually constructed. This is a very useful optimization that I rely upon to make message passing efficient in my OBJECTS package. However, I was recently surprised to discover that the optimization is not performed if there are six or more elements in the list. I surmise that this is somehow related to the number of real (as opposed to virtual) registers in the DEC-20 implementation, but don't see any reason why this should prevent the optimization from being carried out. What gives? RESPONSE (Eric) It's a nasty interaction between optimized compilation of LIST and optimized compilation of APPLY. I can fix it. RESPONSE (Eric): Fixed. Date: 10-Sep-82 10:49:18 From: douglas <LANAM at HP-HULK> Subject: configuration of bps and heap on 20 Class: Request Can the configuration of the above in psl be changed by moving approx. 20K-30K of heap space from heap to bps in bare-psl and psl? thanks, douglas Date: 10-Sep-82 10:22:02 From: douglas <LANAM at HP-HULK> Subject: Breakfunction property Class: Documentation deficiency, documentation bug I found if you set the value of breakfunction on the propertylist of an atom, and type the atom at the break level, it will execute that function. This needs to be documented somewhere. Also the help file printed at the level should be able to be updated to reflect any changes the user may make. I am not sure I like having atoms automatically changed into functions at type in, but I do like being able to change the break system to take control characters instead of alphabetic characters. douglas Date: 10-Sep-82 09:07:36 From: douglas <LANAM at HP-HULK> Subject: warnings by compiler. Class: Request When the compiler says something is declared fluid, could you include the function that caused this on the same line in the message. Due to the fast number of lisp systems, I have a hard time remembering whether yours does it before it prints the function name concerning it or after. douglas RESPONSE (Eric): Fixed. Date: 9-Sep-82 15:08:09 From: douglas <LANAM at HP-HULK> Subject: psl space allocations on the vax Class: Request Could the psl on the vax be reconfigured so that there is 100K words of bps free at its startup (currently it is approx 46K words)? thanks, douglas Date: 9-Sep-82 14:32:52 From: douglas <LANAM at HP-HULK> Subject: " . . . not compiled" message Class: Inquiry, complaint, request Does the following mean the whole phrase was not compiled or just the car was not compiled? *** (car (merge-comment (*i-put-datum (frame ($local type)) (get-field-location 'nil ($local key1)) '3 '(insert-frame (fname :frame))) 'finherit: 'continue)) not compiled. If the first, it is very, very wrong since all of these functions are my own and do side effects (set property lists). If the second, the message should be changed to something like, return value of car is not used and thus car is not being compiled. douglas RESPONSE (Eric) It means just the CAR was not compiled. I'll see what I can do about the message. RESPONSE (Eric) Fixed the message. Date: 9-Sep-82 14:29:09 From: douglas <LANAM at HP-HULK> Subject: Fluid and macro of the same name Class: Bug, deficiency One cannot use the same name for a fluid and a macro. Please fix this soon. It is a very annoying restriction that shouldn't exist. douglas RESPONSE (Eric) Fixed. Date: 3-Sep-82 13:06:38 From: FILMAN at HP-HULK Subject: emode and [] Class: EMODE deficiency, EMODE complaint The s-expression functions in emode don't seem to know about []'s. Since these are the default construction of defstruct, this is a serious deficiency. Bob Date: 3-Sep-82 11:57:28 From: Cris Perdue <Perdue at HP-HULK> Subject: STEP bug Class: Bug Try (step '(plus 3 4)). Step using ^N. The stepper breaks after a couple of steps. RESPONSE(Benson): Fixed. Date: 3-Sep-82 04:52:14 From: douglas <LANAM at HP-HULK> Subject: can you change princ, Class: Request Can you change the printing of the following by princ, so that the open parens are on the beginning of the line, not the end? I think that this would be more pleasant to look at. Currently: (THING (WCHEM-CLASS (WCH) (WCHO (C-O-STRETCH-ALCOHOL) (O-H-DEFORMATION ( (THING (WCHEM-CLASS (WCH) (WCHO (C-O-STRETCH-ALCOHOL) (O-H-DEFORMATION ( O-H-STRETCH-FREE-OH-ALCOHOL) (O-H-STRETCH-INTRAMOLECULAR-H-BONDED-ALCOHOL) ( C=O-STRETCH-OVERTONE) (C=O-STRETCH)))) (Actually I tried to copy this off my terminal and one line got mixed up, but it still displays what is currently done. douglas RESPONSE(Benson): That's what PRETTYPRINT is for. It has been suggested that the top loop use PRETTYPRINT instead of PRINT. Any opinions? Date: 2-Sep-82 15:17:00 From: Alan Snyder <AS at HP-HULK> Subject: Garbage collection trap request Class: Feature request I would like to have the GC starting and ending messages printed by specific functions that are invoked at the beginning and ending of each garbage collection. These functions should take as arguments all information that they use to construct an appropriate message. This change would allow me to alter the form of announcement without mucking with the GC itself. In particular, I don't want to have to make an altered copy of the GC code or access its private variables. I realize that the GC-start function would have to be written to not allocate any storage. I need this feature to display a GC announcement in NMODE. Date: 2-Sep-82 12:13:04 From: douglas <LANAM at HP-HULK> Subject: flag *continuableerror Class: Documentation request I found a flag *continuableerror which should be documented in the manual. (It is very useful). Date: 2-Sep-82 11:45:35 From: FILMAN at HP-HULK Subject: printing circular structures to depth Class: Feature request, notice, miscellaneous Unfortunately, PSL doesn't have a printlevel function (that prints a structure only to a certain depth). Nor does the circular printing function deal with circularity in vectors. I've written a (not deeply thought-out) depth-limited printing function of my own. Since PSL doesn't come with the most complete set of user utilities, how about a user-utility function area for such contributions? Bob Date: 2-Sep-82 11:05:43 From: Alan Snyder <AS at HP-HULK> Subject: Char-UpCase and Char-DownCase Class: Bug Char-UpCase and Char-DownCase return NIL instead of their argument when no conversion is done. RESPONSE (Eric): Fixed. Date: 2-Sep-82 10:53:48 From: FILMAN at HP-HULK Subject: atomic rules Class: Complaint In PSL, (atom x) == (not (pairp x)). Thus, vectors, code pointers strings, etc are all atoms. I know that this is documented. However, it is counter-intuitive (counter-intuitive == the other lisps I've played with don't do it this way). Not having read the fine print, I spent an afternoon discovering this fact. Bob RESPONSE (Eric) I agree it is confusing, but it conforms to all the other Lisps I know of! Perhaps you are confusing atoms with symbols (called litatoms in Interlisp?) Date: 2-Sep-82 10:43:26 From: douglas <LANAM at HP-HULK> Subject: continuable break. Class: Inquiry, feature request Is there a function that would be (contbreak) ? Which is something to (break) as (conterror) is to (error)? douglas RESPONSE (Eric) That's really what ContinuableError is. It just puts you in a break loop where you can fix things. Date: 2-Sep-82 01:58:26 From: douglas <LANAM at HP-HULK> Subject: break package and returning new values. Class: Inquiry I have read through the break package, and tried a few things, and can not find how I can do something that means (return value) where value is a lisp-expression to be evaluated and become the value of the call to break(or conterror), without calling the editor. I would like to be able to return a value or evaluate an expression that may not be similar to the expression that caused the error and return that value back from the break point (similar to what one can do in maclisp/franz/lisp machine lisp). How do I do this? douglas RESPONSE(Snyder): Just type the expression at the break handler, then type 'C' for "continue using last value". Date: 1-Sep-82 23:02:45 From: douglas <LANAM at HP-HULK> Subject: Did someone change faslout? It use to echo input, but now it doesn't seem to. Can you change faslout back to echoing input that is just passed to the fasl file. I can not figure out easily when I finish typing an expression to faslout any more. Date: 1-Sep-82 22:58:44 From: douglas <LANAM at HP-HULK> Subject: defn* and *defn Class: Documentation request what is defn* and *defn? and what is dfprint*? They are on page 19.3. They seem important yet are pretty much undocumented. What are they. RESPONSE (Eric) *DEFN and DFPRINT* are used by the top loop to allow processing other than evaluation. if *DEFN is non-NIL, DFPRINT* is applied to each form instead of being evaluated. This is the means by which FASLOUT and other functions work. Date: 1-Sep-82 22:55:56 From: douglas <LANAM at HP-HULK> Subject: macros expanding to "bothtimes" Class: Complaint, bug, deficiency HP-PSL 3.0, 27-Aug-82 1 lisp> (bothtimes (setq x 2)) 2 2 lisp> x 2 3 lisp> (dm x (y) `(bothtimes (setq . ,(cdr y))) 3 lisp> ) X 4 lisp> (x z 4) 4 5 lisp> z 4 6 lisp> (faslout "junk") FASLOUT: (DSKIN files) or type in expressions When all done execute (FASLEND) T 7 lisp> (bothtimes (setq a 3)) 3 8 lisp> (x b 4) 9 lisp> (faslend) *** Init code length is 2 *** A declared fluid *** B declared fluid **FASL**INITCODE**NIL 10 lisp> a 3 11 lisp> b NIL 12 lisp> (quit) I do not think this is correct, the call to x on line 8 should be expanded by the compiler and then the system should notice that it is a bothtimes clause and should be executed at compile time and compiled. Instead it appears to be just compiled. The x is expanded (it is just not executed at compile time like it is suppose to be). Can you fix this soon? thanks, douglas Date: 1-Sep-82 17:00:41 From: FILMAN at HP-HULK Subject: trace Class: Inquiry The function "trace" is defined but doesn't trace; nor is it documented in my version of the documentation. Bob Date: 1-Sep-82 12:08:02 From: FILMAN at HP-HULK Subject: circular structure bugs Class: Bug, deficiency 1) Printx doesn't handle circular vector structures. Since defstruct makes vectors, this is a serious problem 2) Consider the following sequence: (setq bbb '[a b c d]) (indx bbb 3) --> d (setindx bbb 3 bbb) --> prints the appropriate circular structure (indx bbb 3) --> an infinite structure (indx (indx bbb 3) 3) --> produces a push down overflow error (indx (indx (indx bbb 3) 3) 1) --> also produces a push down overflow error What gives? Bob Date: 1-Sep-82 12:01:03 From: douglas <LANAM at HP-HULK> Subject: br does not work with macros. Class: Bug If you have a function x which is a macro. Say (dm x (y) (rplaca y 'princ)) then do (br x) . Before the call to br, (x 'a) typed into the interpretor will execute the princ and return a. After the call to br, typeing (x 'a) to the interpretor will cause the expression (princ 'a) to be returned but not evaluated. douglas Date: 1-Sep-82 11:52:25 From: douglas <LANAM at HP-HULK> Subject: compiletime Class: Bug do @psl (compiletime (setq a 1)) a You will get that a has been set to 1. I do not think this is right. RESPONSE (Eric) (compiletime xxx) really means (eval-when (compile eval) xxx) in the current setup. I think (eval-when (compile) xxx) does what you want. Date: 31-Aug-82 11:14:18 From: douglas <LANAM at HP-HULK> Subject: declaration of functions and variables. Class: Deficiency, feature request I think it is better to have a declaration statement to declare something as a fexpr or as a nexpr, if you wish to use it before defining it in compiled code. Currently the manual says to write a dummy version. But something like : (declare (*fexpr x) (*nexpr x)) would be better. It could also be used in compiling files that reference other files but that you don't wish to load everything in to compile it. Also, (fluid x) should not set x to nil. and there should be two property list names for function type and variable type, not one, you should be able to use a name as a global variable and a fexpr. douglas Date: 31-Aug-82 10:46:17 From: douglas <LANAM at HP-HULK> Subject: feature in print. Class: Request It would be nice if print could know about readmacrochars that do as follows ^lisp-expression => (tag lisp-expression). An example is quote. Note: it should make sure the tagged list is of length 2 before doing the special print(at least in the case of quote). douglas Date: 30-Aug-82 15:34:57 From: FILMAN at HP-HULK Subject: break and emode Class: Deficiency When trying to "q" from a break in emode, the cursor goes to the end of the second following line, not the next line. That is, if the screen is: (cursor shown by *) q* first line second line and you execute a meta-e, you get: q first line second line* not what you should get, which is: q first line* second line Bob Date: 30-Aug-82 13:38:40 From: FILMAN at HP-HULK Subject: emode, breaks and "a" Class: Bug Giving an "a" from emode inside a break seems to confuse the emode page printing routines some. Bob Date: 30-Aug-82 10:34:10 From: FILMAN at HP-HULK Subject: break window Class: Inquiry What happened to the break window? Bob RESPONSE(Perdue): It was removed because it behaved very poorly in various slightly "unusual" situations. Date: 28-Aug-82 03:57:53 From: douglas <LANAM at HP-HULK> Subject: interrupt and dumpsave. Class: Deficiency If you do (load interrupt) (savesystem "xxx.exe") (quit) @xxx.exe The interrupts will not work in xxx.exe, but the system will think the file was already loaded. douglas RESPONSE (Eric) The function (INITIALIZEINTERRUPTS) is called when the module is loaded. It needs to be called in a fresh core image as well. It's not clear to me what the best way to ensure that is. Date: 28-Aug-82 03:56:46 From: douglas <LANAM at HP-HULK> Subject: vector print length limit. Class: Feature request There should be a special variable (say *printlength) which is set to the maximum number of elements in a vector, list, (half-words vectors), which are printed out. The rest could be printed ... . This variable could be reset by the user (nil for no limit). But I think there should be a limit in the system (say 25-30?), often I get a strange error in compiled code which results in the endless printing of a vector. douglas Date: 27-Aug-82 16:09:05 From: douglas <LANAM at HP-HULK> Subject: Printing "quote" expressions Class: Bug @psl 1 lisp> '(quote a b) 'A 2 lisp> douglas RESPONSE (Eric) Fixed (see BUG-FIX.LOG). Date: 27-Aug-82 14:55:33 From: douglas <LANAM at HP-HULK> Subject: file function needed. Class: Feature request Is there a function which can tell me when a file was last written to the disk? I could use such a function. (I know this is machine/operating system dependent). douglas RESPONSE(Snyder): The file <HP-PSL.EMODE>DIRECTORY.SL has functions that almost do what you want. Take the part of FILE-DELETED-STATUS that does at GTJFN to get a JFN, then pass that to JFN-WRITE-DATE. RESPONSE(Perdue): It appears that we will be adopting the Common LISP file manipulation functions. Date: 26 Aug 1982 17:21-PDT (Thursday) From: Liu (?) at HP-PCD Subject: Function cells, function bindings, property lists Class: Inquiry, documentation deficiency We run psl on VAX/750 under UNIX. The problems are (1) I first defined a function "x". Then I initialized the property list of "x" by using "SetProp" which turned my function definition into "NIL". (2) I went on typing my function definition again. Then I looked at my property list. It has my function definition with some other goodies in it. I'll imagine the function cell and the property cell are two seperate entities. So, these side effects are unexpected and undesired. Following is a sample of the problems. 1 lisp> (de x (y) (car y)) X 2 lisp> (pp x) (DE X (Y) (CAR Y)) T 3 lisp> (setprop 'x '((color . red))) ((COLOR . RED)) 4 lisp> (prop 'x) ((COLOR . RED)) 5 lisp> (pp x) *** X has ill-formed definition. (DE X NIL) T 6 lisp> (de x (y) (car y)) Do you really want to redefine the system function `X'?(Y or N)y *** Function `X' has been redefined X 7 lisp> (pp x) (DE X (Y) (CAR Y)) T 8 lisp> (prop 'x) ((*LAMBDALINK LAMBDA (Y) (CAR Y)) USER (COLOR . RED)) RESPONSE(Perdue): Thanks for the good observation. It turns out that the function cell in PSL always contains a machine instruction, so the lambda expression can't be stored there. PSL stores the lambda expression on the property list. I don't believe this fact is documented. RESPONSE (Eric) Calling SETPROP is inadvisable under almost any situation. Date: 26 Aug 1982 16:35-PDT (Thursday) From: Someone at HP-PCD Subject: "apply" function Class: Comment When the function "(apply 'plus '(1 2 3))" is entered, psl returns a line of the form #<Unknown:15602127320> rather than the result "6". RESPONSE(Perdue): PLUS is a MACRO, so you don't get what you expect as an answer. In general, applying a macro causes it to perform macro expansion but not to evaluate the expanded form. Probably applying a macro ought to either be an error. In some LISPs (apply fn arglist) is equivalent to (eval (cons fn arglist)) when fn is a macro, but these are not equivalent when fn is a normal function. Date: 26-Aug-82 15:27:19 From: FILMAN at HP-HULK Subject: ***** Unexpected EOF while reading {99} Class: Inquiry I get the above message in a break, and all the ^q's I give it don't pop. Is there some sure way back to the top level? Bob RESPONSE(Perdue): Say "a" rather than "q" to get out. There is a menu that tends to come up these days, even when you don't want it. When you don't want it, use ^XO to get out of it. A couple of ^XOs and it will even disappear from the screen. We'll get rid of that menu altogether in a day or so. Date: 26-Aug-82 12:14:36 From: FILMAN at HP-HULK Subject: closures Class: Comment, documentation deficiency I was pleased to see the documentation on closures on page 10.9 of the psl manual. Unfortunately, this stuff is not implemented. Perhaps a better warning than "[??? Not yet connected to V3 ???]" could be associated with this material. Bob Date: 26-Aug-82 12:12:28 From: FILMAN at HP-HULK Subject: defstruct Class: Documentation deficiency The defstruct documentation in the psl manual does not correspond to the implementation in psl. For example, defstructp doesn't exist. Chris assures me that the defstruct in psl is lisp machine defstruct. Perhaps the manual could be adjusted for this reality. Bob Date: 26-Aug-82 11:54:50 From: FILMAN at HP-HULK Subject: emode and mm Class: Bug If you're in emode, and call mm, the exit from mm leaves emode confused. The various controll characters to the screen get printed. Doing an ^x^z and a continue psl fixes the problem. Bob Date: 26-Aug-82 11:23:54 From: douglas <LANAM at HP-HULK> Subject: bugs in emode. Class: Bug, inquiry try the following: @psl 1 lisp> (emode) ^\e^L (that is type meta-e, cntl-l as the first input to emode). can ctrl-h work the same as ^b ? It does in emacs. douglas Date: 26-Aug-82 10:58:53 From: FILMAN at HP-HULK Subject: Handling of macro expansion in the interpreter Class: Comment This is a subtle one, that most lisp's get wrong. In PSL, macros eat stack. For example, the sequence (setq x 1000) (dm awhile (l)(cond ((eval (cadr l)) (eval (caddr l)) l) (t nil))) (awhile (greaterp x 0) (setq x (sub1 x))) gets a stack overflow; it needn't. I believe that stanford 1.6 lisp does this right, while uci-lisp does it wrong. Bob Date: 26 Aug 1982 0857-PDT From: douglas <LANAM> Subject: you can do a funcall or apply on a code pointer. Class: Comment Date: 26-Aug-82 09:47:51 From: douglas <LANAM at HP-HULK> Subject: why are there global variables which can be bound statically? Class: Inquiry, complaint what is really gained by this? RESPONSE(Perdue): It is thought that it is not meaningful to rebind certain global variables. The declaration is useful to some LISP implementations. message continues: I find it unreasonable that I can not do (let ((out* (open "junk" 'output))) (princ ....)))) And if I can't do it this way, I have to use a catch to make sure that out* is bound correctly after the body of the let is executed. douglas RESPONSE(Perdue): The official PSL I/O system will probably be redone along the lines of Common LISP. Date: 26-Aug-82 09:22:25 From: douglas <LANAM at HP-HULK> Subject: errors in manual. Class: Documentation bug Page 14.1: Under the function savesystem, is a spelling error. lispbannner!* should be lispbanner!*. On page 13.2 is the following : BREAKOUT!* (initially: NIL) global similar to BREAKOUT!*. Date: 25-Aug-82 13:50:26 From: FILMAN at HP-HULK Subject: Page headings in the manual Class: Documentation The psl manual "swaps" the page and section numbers on left and right pages, but leaves the "PSL Manual" and section names unswapped. This is a bit confusing. RESPONSE(Kendzierski): This has been remedied in newer editions of the manual. Date: 25-Aug-82 13:40:16 From: FILMAN at HP-HULK Subject: "bug" function Class: Bug The (bug) function gives an access failure (and dies in emode) The function defstructp is undefined. Date: 22-Aug-82 13:45:20 From: PAULSON at HP-HULK Subject: SUBSTRING Class: Complaint, documentation deficiency In INTERLISP, (SUBSTRING STR N M) gives you the Nth through Mth elements of the string. Makes sense, right? And in ZLisp, (NSUBSTRING STR N M) gives you the (N+1)th through (M+1)th elements. Fine- ZLisp does zero-indexing. But in PSL, (SUBSTRING N M) gives you the (N+1)th through Mth elements. This does not make sense at all (and it isn't documented either.) RESPONSE (Eric) SUBSTRING in PSL is exactly the same as SUBSTRING in Zetalisp, except that the END argument is required, not optional, and the AREA argument is not used. Date: 20 Aug 1982 17:34:58-PDT From: Martin.Griss <Griss at UTAH-20> Subject: [Norman.kentvax at UDel-Relay: psl stray queries] Class: Miscellaneous this is a very initial bunch of psl queries/thoughts. it is also a test to see if i can get mail out of this vax & over to you lot. (a)i (a) on vax psl 'messages' and 'real output' get interleaved in what seems to be an assynchronous manner. at least i seem to get error messages all mixed in with the stuff i print, so the idiom print <my own messages>; error 'stop here; is not as helpful as I would like. RESPONSE (Eric) VAX Unix terminal output has been changed to be line buffered to speed it up. This should have the side benefit of removing the interleaving of stdout and errout. (b) I have tried to use rlisp <<here | tee logfile on echo; .... to get a copy of input & output of a set of standartd tests. the 'on echo;' seems not to be honoured? also the error recovery is a mess in this case because i go into lisp syntax & need to type special error-break-loop commands to escape it, and these are abominated unless i am in the error loop. (c) in ann error I wanted to see the value of fluid variables called a,b,c,d,... but of course some of these letters gave magic effects! i ended up with going (eval 'c) & similar nasties. yuk. also could the backtrace print values that fluids have on the stack, or could i have some similar easy way to see values of fluids that have been covered up by subsequent bindings. furthermore the mess one gets on going (backtrace) is a MESS and i find it hard to see the stuff that i want for all the muck that i dont. RESPONSE (Eric) Yes, backtrace and break are both weak. (d) try printing (expt 2 31). for me it gives an infinite string of - signs!!!!!!! RESPONSE (Eric) The problem is due to the fact that the most negative number in a 2's complement representation has no positive counterpart. The solution (courtesy of Alan Snyder) is to do the computations on numbers less than zero, so that positive numbers are negated before processing rather than negative numbers being negated. This will probably be fixed in PSL soon. (e) lack of bignums is mildly bothersome - for work with reduce I guess i will lash up a botched bignum package representing numbers as vectors (so they pass the atom test), cos i presume your proper version is in the pipeline but not ready yet. RESPONSE (Eric) Bignums do exist, as a loadable module. Do (LOAD BIG). (f) i looked for the followng functions without apparent success: random() generate random number timeofday() like date() but gives wallclock time (I wanted it to help generate a good seed for my own random number generator!) RESPONSE (Eric) (RANDOM) is obtained by LOADing MATHLIB. It uses (TIME) to generate its seed. If (TIME) is not documented it should be. (g) in rlisp, various things I expected to be errors were not trapped very hard, e.g. a missing ')' seemed to be continuable when i didn't expect/want it to. also "help help" failed by turning into (help 'help) internally, not (help help), and in a break look following an error (help <anything?>) complained about the help package not being loaded even though I had called it from rlisp. RESPONSE (Eric) There were bugs in the help system which I believe have been fixed. HELP HELP; is still parsed incorrectly in RLisp, and that probably will not be fixed. (h) i suspect that often while in an break loop i want further errors ignored rather than letting them push me further into deeper break loops. I might be happy to have a break level that eats simple 1-char commands to continue, quit, backtrace with one char that pushes me into a brand new read-eval-print loop. for rlisp I guess that should be an rlisp r-e-p loop? RESPONSE (Eric) It has been suggested that there be an absolute limit on depth of break loops. In any case it seems clear that the break loop mechanism should be redesigned; this is far from the only complaint. I will try to collect further notes to pass on as I think of things: just put these somewhere in your big pile of gripes! Was good to see you in Pittsburg. cheers. arthur Date: 19-Aug-82 10:07:31 From: Alan Snyder <AS at HP-HULK> Subject: WNOT Class: CMACRO Bug The *WNOT CMACRO produces bad code when its argument is an integer constant. For example, the expression (WNot 7) produces (SETCM (REG 1) 7), which computes the complement of the contents of register 7. RESPONSE (Eric) This case should be caught and evaluated in the first pass of the compiler. The CMACRO should never be used. Date: 19-Aug-82 09:35:24 From: LANAM at HP-HULK Subject: History list package Class: Deficiency When you do (hist), it tell you things like: 5 Inp: (HIST) Ans: NIL 6 Inp: Q Ans: NIL But it doesn't tell me that the Q on (inp 6) is a response to the break package, not the evaluation of the atom q. It also doesn't tell me that (ans 4) is nil because it never existed.{History is an undefined function}. RESPONSE (Eric) In general whenever a value is not returned by a function in the top loop, such as if an error occurs, NIL is put in the value position. Would it be preferable to put something else there, such as "Abnormal termination"? Date: 18-Aug-82 12:16:33 From: Alan Snyder <AS at HP-HULK> Subject: Fast arithmetic and fast vector access Class: Compiler bug There is a serious PSL compiler bug relating to the interaction between fast arithmetic and fast vector access. In the following code, note that register 1 is clobbered by the MOVE instruction before it is used as an index register in the ADD instruction. (Possibly useful info: if the vector fetch is replaced by CAR, the compiler does the right thing, i.e., moves V to a free register before loading register 1.) PLEASE FIX THIS BUG!!!! ---------------------------------------------- (CompileTime (Load Fast-Vector)) (de test (v a) (WPlus2 (IGetV v 0) a)) ---------------------------------------------- (*ENTRY TEST EXPR 2) (*ALLOC 0) (*MOVE (REG 2) (REG 1)) (*WPLUS2 (REG 1) (MEMORY (REG 1) (WCONST 1))) (*EXIT 0) ---------------------------------------------- (MOVE (REG 1) (REG 2)) (ADD (REG 1) (INDEXED (REG 1) 1)) (POPJ (REG ST) 0) ---------------------------------------------- RESPONSE (Eric) I believe this bug has been fixed in the latest release from Utah. Date: 18-Aug-82 09:52:47 From: Alan Snyder <AS at HP-HULK> Subject: PRINTX Class: Deficiency PRINTX apparently does not handle shared structures involving Vectors. RESPONSE (Eric) True. Don Morrison wrote a quick and dirty circular structure printer GRAPH-TO-TREE, obtained by LOADing GRAPH-TREE, which correctly handles circular vectors. Date: 15-Aug-82 12:36:13 From: LANAM at HP-HULK Subject: bug in macroexpand. HP-PSL 3.0, 12-Aug-82 1 lisp> (macroexpand '(setq a b c d)) (SETQ A B) The result should have been '(setq a b c d)). RESPONSE (Perdue): Right on expanding SETQ. There may be an associated compiler bug, too. RESPONSE (Eric) I fixed the source for MACROEXPAND. The compiler does its own processing and is not affected. Date: 14-Aug-82 18:59:24 From: LANAM at HP-HULK Subject: what does ($fluid :value) not compiled mean? Class: Inquiry I got this between two functions I compiled, but there was no code between the two function (and the declaration was pages earlier). thanks, douglas RESPONSE (Eric) "*** FOO not compiled" from the compiler means that FOO has no side effects and is used in a place where no value is required. The compiler does not issue code for such expressions. Date: 14-Aug-82 18:33:00 From: LANAM at HP-HULK Subject: Compiling variables in the CAR position Class: Inquiry, complaint HP-PSL 3.0, 12-Aug-82 1 lisp> (setq *comp t) T 2 lisp> (defun a (b) (b b)) *** Functional form converted to APPLY (B B) *** (A): base 412016, length 3 words A Why is it, if the function and argument have the same name, it gives me this message, but if I change either the name of the function or the argument, it doesn't give me this message? I don't think this message should pop up. Even if the function b was declared already. (defun a (b) (B b)) causes the system to think that b is a variable bound to a function. I think this is wrong. If I had wanted that I would have done (apply b (list b)) instead of (b b). RESPONSE (Perdue): (defun a (b) (b b)) is compiled heuristically. The compiler guesses whether the call on b is directly a function call or whether "b" is used as a function-valued variable. On the basis of local context it guesses b is a variable in function position. I'm sure it will be a low priority for fixing, since it is easily worked around. RESPONSE (Eric) This handling of variables in the function position goes against the accepted practice in recent Lisp systems. I made the decision to do it that way, but have gotten only complaints about it. (Of course those who like it that way probably wouldn't say anything about it unless it went away!) On reflection and further use I believe it should not have been done this way. It is also inconsistent with the Common Lisp definition. Should it be changed now? Date: 14-Aug-82 14:57:28 From: LANAM at HP-HULK Subject: (reset) should end a (faslout) If i do (faslout), get an error, and do (reset), I do not think the system should be in fasl mode any more. I think if I wanted to continue the (faslout), or save it, I would use the continue option of the break package, and not do (reset). douglas RESPONSE (Eric) FASLOUT sets a global variable and returns, rather than binding a fluid and doing the processing within that binding. One solution is to write a COMPILE-FILE function which binds *DEFN so that popping out will abandon processing. Date: 12-Aug-82 16:36:41 From: LANAM at HP-HULK Subject: READ Class: Bug do (let () (setq y (readch)) (unreadchar y) (read))word the system will return wORD note: that read normally changes all the characters in its word to upper case. But if the character was sent back to the input stream from unreadchar, its initial case remains and the atom that read interns has its first character in lower case if it was typed that way. The above should have returned WORD. The above is with *raise = t. douglas RESPONSE (Eric) This wsa due to a bug in READCH and has been fixed. By the way, UNREADCHAR is not the correct dual to READCH (in fact it is not currently defined). UNREADCHAR is the dual of READCHAR, which returns a character (integer) instead of an ID. Date: 12-Aug-82 16:27:30 From: LANAM at HP-HULK Subject: search in emode Class: Proposal I looked at the source to search.red in pe: and found that it does a very dumb search algorithm. The search algorithm should be replaced with the kmp algorithm which can be found in most data structures/algorithm books. I have a version running in lisp (but not fully compatible with emode functions) which I can send. The whole algorithm is about 20 lines of code. I also have a version in pascal which runs on my 9836 ( i debugged it on there when the hulk was down and moved it over. ---- I am including the whole algorithm in lisp slightly commented. This version to work with emode needs to convert some or the list of characters and vectors of character to vectors of ints, and needs to ignore case (this version does not ignore case). This code has been checked and works. I am using a variation of it in my program for my search through the history table. It runs much faster than the algorithm currently used in emode. If you wish to install it, I can help in debugging this part of the code and checking it works, if you can get someone else to interface it to the reset of emode and set up the correct accessing of emode data structures. douglas ----- %% %% Implemenation of Knuth_Morris_Pratt algorithm. %% %% %% p: input-pattern format vector of characters: %% '[a b c]. %% %% output failure link vector to be used by emode_kmp_scan. %% (defun emode_kmp_flowchart_construction (p) (let ((m (size p))) (let ((*flink (mkvect (iplus2 1 m)))) (iputv *flink 0 -1) (do ((i 1 (+ 1 i))) ((> i m) *flink) (do ((j (igetv *flink (- i 1)) (igetv *flink j))) ((or (eq j -1) (eq (igetv p j) (igetv p (- i 1)))) (iputv *flink i (+ j 1)))))))) %% %% p : input _string in vector format '[ a b c] %% m : upper bound of vector p (answer for above is 2). %% s : line of characters to be searched %% format list of characters: '(A b c d e . ..) %% *flink : failure link vector from emode_kmp_flowchart_construction. %% %% returns t if succeed, nil if not found. %% (defun emode_kmp_scan (p m s *flink) (and s (prog (j) (setq j 0) %% %% if next character does not match use failure links %% to back up and try again. %% loop (cond ((and (neq j -1) (neq (igetv p j) (car s))) (setq j (igetv *flink j)) (go loop))) %% %% if you have matched the entire pattern => succeed. %% (and (= j m) (return t)) (or (setq j (+ 1 j) s (cdr s)) %% %% move pointer in line, %% %% if no more line, fail. (return nil)) (go loop)))) Date: 12-Aug-82 11:06:18 From: LANAM at HP-HULK Subject: GO inside AND Class: Compiler deficiency The Psl compiler does not allow a go inside an and clause inside a prog. ex: 10 lisp> (defun xx () (prog () loop (and (go loop)))) ***** (GO LOOP) INVALID GO XX Thus causing me to have to say (cond (expression (go loop))) inside a prog when i want to say (and should be allowed to say): (and expression (go loop)) douglas RESPONSE (Eric) This use of GO within AND is in violation of Standard Lisp. There isn't a good reason for this restriction and it should probably be removed from the compiler. In the meantime, if you use (WHEN foo (GO xx)) instead of (AND foo (GO xx)), everything should be fine. Use of OR in this fashion should be replaced by (UNLESS foo (GO xx)). Date: 11 Aug 1982 0932-PDT From: JOHNSON at HP-HULK Subject: Documentation Bug Class: Documentation Bug Section 5.1, paragraph 2 of <HP-PSL>HP-PSL.R contains the meaningless sentence: "Some of the <PSL> directories have no corresponding <PSL> directory." Date: 10 Aug 1982 1620-PDT From: Kendzierski at HP-HULK (Nancy) Subject: REPEAT Class: Horrid documentation bug The manual states that the REPEAT construct (section 9.3; page 9.7) is repeated until the value of the expression is NIL. RESPONSE (Perdue): Actually, Nancy had quite a bit more to say, but the real problem is that the documentation for the LISP REPEAT is totally scrambled, though the RLISP documentation looks OK. Syntax for repeat is really: (REPEAT <stmt> . . . <condition>) The statements are executed until the condition becomes true. The condition is really and end-test. Date: 10-Aug-82 13:28:27 From: LANAM at HP-HULK Subject: word size Class: Inquiry Is there a function which returns the word size (number of bits) that logical operations operate on, built into psl? Date: 10-Aug-82 13:27:26 From: LANAM at HP-HULK Subject: bug in print and lshift. Class: Bug type the following to the top level of the psl interpreter on the 20. (lshift 2 34) You get an endless unstoppable output of hyphens. ---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------... douglas RESPONSE (Eric) See response above to Norman. Date: 10-Aug-82 12:01:02 From: LANAM at HP-HULK Subject: addresses Class: Inquiry What function returns the address of a lisp object? What function takes an address (from above function) or some other int, and gives me the lisp object at that address? RESPONSE (Eric) The first operation can be done but is probably not advisable. There is no defined function to do it from the interpreter, but the macro INF can be used in compiled code by LOADing SYSLISP. The second probably cannot be done, since the tag defines the type of an object and is not recoverable from the address. (This may not be completely true, you can sometimes tell from the contents of the object). Perhaps you could explain why you want to do this, there may be some more appropriate operation. Date: 10-Aug-82 11:40:02 From: LANAM at HP-HULK Subject: documentation of compiled in line functions. Class: Suggestion They should be mentioned where their non compiled in line counterpart is. RESPONSE (Perdue): The fast arithmetic procedures that are compiled in line turn out to be described in the section on SYSLISP, section 21.4 in particular. Date: 10-Aug-82 11:37:05 From: LANAM at HP-HULK Subject: (maxint) => ??? Class: Inquiry Is there a function that return maxint and minint? also maxfloat, and minfloat? RESPONSE (Eric) Currently none. The Common Lisp definition says these are constant global variables (not exactly the same names, though). Date: 10-Aug-82 10:31:26 From: LANAM at HP-HULK Subject: bug in time with garbage collection Class: Bug, deficiency When *time = t, the system should report cpu and garbage collection time seperately, not as one total number. Cpu time: 496 ms. GC time: 2500 ms. not Time: 2996 ms. The current timing given is misleading. douglas RESPONSE (Eric) Currently GC time is not saved. It would be pretty simple to do, just a matter of choosing how. Date: 9-Aug-82 11:03:03 From: LANAM at HP-HULK Subject: Fast vector access Class: Bug I got the message: (memory ($local y) (wconst 19)) not compiled when I did: (defun xx (y) (do ((i 100 (sub1 i))) (eq i 0)) (igetv y 18))) RESPONSE (Perdue): Looks like a bug. Please use WGETV rather than igetv until we find out that igetv is for public consumption. I think they will do the same thing anyway. RESPONSE (Eric) This is not a bug! See the comment above on "*** FOO not compiled". If you want to have this compiled, you must do something with a side effect inside the loop. Date: 9-Aug-82 09:08:11 From: LANAM at HP-HULK Subject: fluid Class: Inquiry, documentation deficiency (fluid '(abc)) will set the value of abc to nil. Why? The documentation does not say that such a thing is done. It should leave abc as an unbound variable. douglas RESPONSE (Eric) This is in conformance with the Standard Lisp report. If it is not described in the PSL manual it should be. Date: 29 Jul 1982 17:39:24-PDT From: Tony Hearn <HEARN at RAND-AI> Subject: Strange REDUCE bug Class: Bug If you do in REDUCE on the VAX: x := x+1; x; You SHOULD, I believe, get a "push down stack overflow" error. Instead, you go off into mystery (system seems to hang) and finally get an "illegal instruction" message and a core dump. RESPONSE (Eric) Stack overflow on VAX Unix is not handled well by the operating system. Franz Lisp has the same problem. Perhaps 4.2BSD will do a better job. Date: 26 Jul 1982 17:35:58-PDT from: lseward at RAND-UNIX Subject: PSL distribution files Class: News I am listing off sources and have been straightening out the vax-comp and vax-interp files. Suggestion: have subdirectories src, build, and bin and put the appropriate things in them. Otherwise the statement (in the documentation) "This directories contains sources for ..." is very misleading. larry Date: 13 Jul 1982 12:23:31-PDT From: Galway@UTAH-20 at HP-Speech Subject: break loop "feature" Class: Comment, proposal The current break handler inherits the reader, evaluator, and printer from whatever the current TopLoop uses (if TopLoop is being used). I suspect that this is a mistake, since it makes it awkward to deal with special "exotic" top loops. It's already somewhat confusing that depending upon the circumstances you will either get a LISP reader, or and Rlisp reader. Think about how wonderful it would be if your reader only returned vectors to be "evaluated" by adding them up (say, for a desk calculator or something). I suggest that instead we only have one, or maybe two, break loops. Default would use LISP's READ/EVAL/PRINT. And perhaps it should notice when Rlisp is in effect, and use its READ/EVAL/PRINT in that case. Comments? RESPONSE (Eric) Definitely. The break loop is all wrong. Lets redo it. Date: 25 Jun 1982 2106-PDT From: LANAM Subject: package proprosal Class: Proposal I would like the system to remember the package definition name of a variable and functions in .b files so that I dont' get the system binding files which were compiled in package a but loaded in package b refering to package b functions when a package is not specified. Just binding everything to global would not work since then it would be a nuisance to have to always write out a local package name in a file on every function and variable. (This is a proposal to send along with any bug reports to martin). douglas RESPONSE (Eric) Packages are not fully integrated into the system. This will probably have to wait for a redesign of PSL to include packages in the kernel. Date: 6-Aug-82 14:09:27 From: LANAM at HP-HULK Subject: bug with *time Class: Bug If the first thing you say to psl is (setq *time t) you get back Time: 211392 ms (or some such large number). RESPONSE (Eric) True. Date: 4 Aug 1982 01:36:20-PDT From: daemon at HP-Speech From: Tony Hearn <HEARN at RAND-AI> Subject: PSL cannot read bignums correctly The source for the bigfloat package contains bignums. It does not seem to read or maybe compile correctly. Can PSL currently read bignums? RESPONSE (Griss): PSL can read bignums with BIG loaded. Without it, bignums will not be read correctly. It is probably true that bignum constants cannot be compiled in either case. RESPONSE (Eric) This has been fixed completely. Date: 27 Jul 1982 16:18:52-PDT From: Martin.Griss <Griss at UTAH-20> Subject: ExitTopLoop Class: Proposal Id like to add and ExitTopLoop comand, eg !$exitTopLoop!$ as distinguided atom? Or some such, perhaps have on property list of atom and action function, ala Break, perhaps using toploop name as key? GET(InputValue,ModuleName,...). Date: 27 Jul 1982 1058-PDT From: BATALI Subject: Easy file reading Class: Complaint There ought to be an expr to read a file. The only way to do this now is something like: (eval `(dskin ,filename)) I see no reason why dskin should not be an nexpr: virtually all present uses of it use string arguments so it wouldn't matter. L&C, John RESPONSE (Eric) Definitely. Let's make DSKIN an EXPR with ONE argument, since that's all it's used for 99.99...% of the time. Incompatible with some existing code? Date: 27 Jul 1982 16:19:23-PDT From: Martin.Griss <Griss at UTAH-20> Subject: VAX QUIT Class: Proposal, response I think QUIT should have an associated function, FullStop or some such. (Or have 2 low level functions, QuitAndKeep, QuitAndKill), and let system admin choose which QUIT is which. Date: 25 Jun 1982 1948-PDT From: LANAM Subject: VAX cntrl-d Class: Bug Type cntrl-d (eof) as the first character, and the system will go into an endless loop. douglas Date: 26 Jul 1982 17:36:09-PDT From: Eric Benson <BENSON at UTAH-20> Subject: VAX QUIT Class: Response, comment Perhaps it's a misfeature. The alternative is to make (QUIT) irrevocable. Reading EOF will cause the PSL process to terminate, which allows the use of shell scripts and/or I/O redirection. If you want to do that from the terminal, type one or more ^Ds. Date: 26 Jul 1982 17:35:51-PDT Subject:VAX QUIT From: hearn at RAND-RELAY Class: Comment, complaint When you do (quit) to psl, you get the message "stopped", and you have a job sitting there. My UNIX guys say this is a bug, and should be fixed. I know that you can restart the stopped job, but apart from that facility, the stopped job does get in the way every so often. Furthermore, when I try to do "time preduce", I can't get the timing info out. RESPONSE (Eric) The function (EXITLISP) has been added to the VAX Unix version and should be in the next edition of the manual. It calls the Unix subroutine exit(), which will kill off the process as you wish. Date: 29 Jul 1982 1412-PDT From: BATALI Subject: Use of variables w. same name as functions Class: Bug, comment, complaint The function: (defun or-list? (list predicate) (cond ((null list) nil) ((funcall predicate (car list)) t) (t (or-list? (cdr list) predicate)))) Is T if any of the predicate applied to any of its elements is T. It works fine interpreted, but the compiler goes into an infinite loop printing: Functional form converted to (APPLY PREDICATE (LIST (CAR LIST))) Not a pretty sight. Ghastly, John RESPONSE (Perdue): This bug is due to use of "list" as both a local variable and a function, and it occurs even though "list" is not explicitly used as a function here at all. The problem is inherent in any LISP that allows variables in the "function position" and has both a variable and function binding cell for atoms. RESPONSE (Eric) See previous comment. Date: 6-Aug-82 10:31:49 From: LANAM at HP-HULK Subject: structure of variable historylist* Class: Inquiry, complaint why is the car of history an endless structure: (historylist* (historylist* (historylist* (historylist* .... the (caddr historylist*) is also this strange structure. isn't there a simplier structure that could be used? douglas RESPONSE (Eric) This only happens when you try to get the value of historylist* from the top loop! Of course it becomes circular. It's really just an a-list of inputs and outputs. Date: 5-Aug-82 16:20:10 From: LANAM at HP-HULK Subject: + and - as start of atom names. Class: Request It would be nice if the scanner was changed such that if + and - are followed directly by an alphabetic character, (ex +a), then an atom is returned ( +a ), instead of two atoms (+ and a). douglas RESPONSE (Eric) Yes, it would be nice. This will require a rewrite of the token scanner. Perhaps we can get Lisp code from CMU for the Common Lisp token scanner. Date: 5-Aug-82 16:05:15 From: LANAM at HP-HULK Subject: (eval and macros) Class: Inquiry, bug is there any reason the following should produce different results: (eval expression) and (eval (macroexpand expression)) I have an example (a bit hairy and long), where the second is correct and the first gives a strange error message about trying to set the number 2. could someone spend some time to look at this to decide what may be the problem. thanks, douglas Date: 5-Aug-82 15:37:32 From: LANAM at HP-HULK Subject: can the sytem just break instead of halt when bps size is exceeded? Class: Inquiry, request Date: 5-Aug-82 15:23:44 From: LANAM at HP-HULK Subject: what is bps? I got error ? fatal error : bps exhausted during faslout. and the system aborted. what happened? RESPONSE (Perdue): You ran out of space for compiled code. PSL provides no information about the sizes of spaces, so far as I know. I'm very interested in this myself, and I don't even know the initial sizes of most of the spaces. Binary program space is not reclaimed. Maybe someday it will be. RESPONSE (Eric) Yes, this will require a redesign of low-level storage allocation in PSL. Date: 5-Aug-82 15:09:07 From: LANAM at HP-HULK Subject: package system and faslout/faslin Class: Comment, advice faslout/faslin known nothing about the package system, and will produce a file that can not be read in successfully, if that file references variables in packages. (usually you will get an operating system error (illegal instruction)). The manual's suggestion to rename functions in global is not a real solution, and suggests further that the package system is not really usuable in a real sense yet. This section of the system is not finished and I do not feel is in a useful enough state to be advertised or included in the manual. douglas RESPONSE (Eric) Totally true! Date: 5-Aug-82 13:05:17 From: Cris Perdue <Perdue> Subject: Unwanted PSL messages Class: Response To not get bothered about redefining system functions, set the global flag *usermode to NIL. The flag *redefmsg determines whether you are told when functions are redefined. There is currently no way to get a quiet dskin, except modifying the code or writing your own. I don't know if you can turn off the "*** blah already loaded" message. There is no mechanism established for forcing the system to reload a library module unless you specify "pl:" as the location of the module. RESPONSE (Eric) There is currently no way to turn off the *** ... already loaded message. It mostly generates more heat than light, perhaps it should just be removed? Date: 5 Aug 1982 1259-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Re: start up file. Class: Response No, there is no "init file". We have had several requests for that feature, so perhaps it can be added soon. RESPONSE (Eric) Yes, init files would be nice. They do require some system dependent primitives, especially the ability to find the home directory of a user. Not a hard job, but the primitives should be specified before doing it. Date: 5-Aug-82 08:31:23 From: LANAM at HP-HULK Subject: tr bug Class: Request tr shouldn't ask me how many arguments a compiled function takes. Why can't it just create a nexpr instead and not worry about the number of arguments? (sometimes I don't feel like looking up the answer to this question). RESPONSE (Eric) Code blocks should include the number of arguments they expect so that this query needn't happen. Date: 5-Aug-82 14:02:21 From: LANAM at HP-HULK Subject: FASLOUT Class: Bug, deficiency (faslout) during (faslout) should not be executed. (it currently is). douglas RESPONSE (Eric) Fixed. Date: 3-Aug-82 15:22:56 From: LANAM at HP-HULK Subject: bug with faslout/faslend. do (faslout "foo") then do something to cause an error, (any error or break will do). such as: (eval-when (compile) (+ 'a 'b)) {actually macros can cause errors, as can any eval-when construct}. If you do (faslend) in the break point, then (reset), the system will only echo your input after that. If you do (faslend) again, an error (illegal instruction) occurs, and psl will halt. Date: 3-Aug-82 15:13:55 From: LANAM at HP-HULK Subject: package/compiler/fasl bug Class: Fatal bug With the following file (called a.lisp), do the following and you will get illegal instruction. (load package) (faslout "A") (dskin "a.lisp") (faslend) (faslin "a.b") file a.lisp: ----------- (\load \package) (\setpackage '\global) (eval-when (compile) (createpackage 'franz 'global) (setpackage 'franz)) (createpackage 'franz 'global) (setpackage 'franz) (eval-when (compile) (localintern 'franz\xx)) (de franz\xx (yy) yy) Date: 2-Aug-82 15:43:38 From: BATALI at HP-HULK Subject: TYPE function Class: Request It would be just dreamy if there were a function TYPE, which returns an ID signifying the type of its argument: (type 'foo) => ID (type 5) => FIXNUM (type '(a b)) => PAIR Etc. RESPONSE (Perdue): Yes, probably named TYPEP, as in Common LISP. See similar requests made very early. Date: Fri Jul 30 14:04:39 1982 From: John Tupper (hp-pcd) Subject: TR Class: Bug Vax psl bug: When the debug package is loaded, the normal trace functions don't work correctly. After loading the debug stuff, (UNTR) does not restore the original definition of the function. (TR) works fine, and (UNTR) will cause tracing to halt; it just doesn't restore the original definition. maddog RESPONSE (Eric) The "standard" PSL TR function is very poor. The 20 and Vax systems should be changed to autoload DEBUG instead of using this brain-damaged version. Date: 30-Jul-82 15:41:22 From: Alan Snyder <AS at HP-HULK> Subject: EMODE cursor movement Class: Bug EMODE (on the HP2648 at least) fails to check for attempts to move the cursor off the right edge of the screen. For example, if you type in a line that is longer than the screen width, the cursor will move to the next line and occasionally random stuff will come out (parts of escape sequences, it looks like). Date: Fri Jul 30 11:40:05 1982 From: tw cook (hp-pcd) Subject: testing 'bug' function - ignore Class: News I have implemented the 'bug' function in our PSL - it just fires up 'mail' to PSL, which forwards both to PSL at labs and to the notesgroup LISPERS here. Those of you at hplabs who are listening - does stuff mailed to PSL@HULK get eventually sent on to Griss & crew? Should I mail to them as well? If so, how do I get there (via mail)? Thanks, tw Date: 30 Jul 1982 11:28-PDT (Friday) From: Ching-Chao.Liu <hp-pcd!ching> Subject: FUnboundP Class: Manual bug On page 10.4 of psl manual, the description of FUnBoundP is incorrect. It should be Tests whether there is a definition in the function cell of U; returns NIL if there is a definition, T if not. Date: 27-Jul-82 16:38:49 From: LANAM at HP-HULK Subject: break package Class: Comment In a break package, if I have a variable i (or q, c, r, m, or e), and want to print its value, i need to do (eval 'i) RESPONSE (Eric) Yes, it's clumsy. Break loop needs reworking (actually starting over). See other previous comments. From: Alan Snyder <AS at HP-HULK> Subject: PSL bug Class: Deficiency The ContError macro is not very robust. For example, consider the following expansion (admittedly, the argument is improper): (MacroExpand '(ContError 0 "" file-name file-name)) ==> (CONTINUABLEERROR 0 (BLDMSG "" FILE-NAME) (LIST '#<Unknown:261740000002>)) Naturally, this form will cause the garbage collector to barf. When the compiler is given this sort of stuff, it produces the following lovely code: ------------------------------------------------------------ Compiling TEST Source Code: (LAMBDA (FILE-NAME) (TEST1 (CONTERROR 0 "s" FILE-NAME FILE-NAME))) ------------------------------------------------------------ Expanded Source Code: (LAMBDA (FILE-NAME) (TEST1 (CONTINUABLEERROR 0 (BLDMSG "s" FILE-NAME) (LIST '#<Unknown:254000006725>)))) ------------------------------------------------------------ Object Code: (*ENTRY TEST EXPR 1) (*ALLOC 1) (*MOVE (REG 1) (REG 2)) (*MOVE '"s" (REG 1)) (*LINK BLDMSG EXPR 2) (*MOVE (REG 1) (FRAME 1)) (*MOVE '#<Unknown:254000006725> (REG 1)) (*LINK NCONS EXPR 1) (*MOVE (REG 1) (REG 3)) (*MOVE (FRAME 1) (REG 2)) (*MOVE '0 (REG 1)) (*LINK CONTINUABLEERROR EXPR 3) (*LINKE 1 TEST1 EXPR 1) L0003L0004 (FULLWORD 0) (STRING "s") (*ENTRY TEST EXPR 1) (ADJSP (REG ST) 1) (MOVE (REG 2) (REG 1)) (MOVE (REG 1) "L0001") (PUSHJ (REG ST) (ENTRY BLDMSG)) (MOVEM (REG 1) (INDEXED (REG ST) 0)) (MOVE (REG 1) "L0002") (PUSHJ (REG ST) (ENTRY NCONS)) (MOVE (REG 3) (REG 1)) (MOVE (REG 2) (INDEXED (REG ST) 0)) (SETZM (REG 1)) (PUSHJ (REG ST) (ENTRY CONTINUABLEERROR)) (ADJSP (REG ST) -1) (JRST (ENTRY TEST1)) L0002 (FULLWORD (MKITEM 10 "L0003")) L0001 (FULLWORD (MKITEM 4 "L0004")) *** Function `TEST' has been redefined *** (TEST): base 374744, length 17 words ------------------------------------------------------------ There is no warning message of any kind. However, when the compiled code is loaded and executed, it will also create bad data that the garbage collector will barf on. RESPONSE (Eric) Fixed. See BUG-FIX.LOG Date: 27 Jul 1982 1638-PDT From: LANAM at HP-HULK Subject: break package problem Class: Deficiency In a break package, if I have a variable i (or q, c, r, m, or e), and want to print its value, i need to do (eval 'i) RESPONSE (Eric): Same as above. Date: 27 Jul 1982 1629-PDT From: LANAM at HP-HULK Subject: string "123" => 123 conversion function needed? Class: Inquiry Is there a function that will convert "123" into the number 123, or "12.4e2" into the number "12.4e2" ? RESPONSE (Eric): A read-from-string function should be implemented. It should be quite easy. Date: 27 Jul 1982 1439-PDT From: LANAM at HP-HULK Subject: br Class: Inquiry If i use br, How do I continue from a break level. I tried every letter given by ?. 'R' gave an error, something about nil undefined. 'c' did something similar. 'q' went to top level. douglas RESPONSE (Eric) BR has never worked right. It should be removed along with TR in MINI-TRACE Date: 27 Jul 1982 1433-PDT From: LANAM at HP-HULK Subject: untr Class: Deficiency untr does untrace a function, but unlike the manual says, it does not restore the original definition. It leaves a strange lisp function around which is similar to the function when it is traced. It would be nice if the functions definition was restored to its original place. RESPONSE (Eric) Yes, UNTR in DEBUG doesn't remove the tracing function, it just suppresses the tracing. The function to resore it to its original state is RESTR, as described in the manual in section 16.10. Date: Mon Jul 26 15:10:41 1982 In-real-life: Tw Cook Subject: psl bug? Class: Bug In the Vax version: If you run (help emode) [or any long help] then do a control-C to try and interrupt it, you get thrown into a break loop which I have not been able to exit from. Is this an error in the help code, rather than in psl itself? RESPONSE (Eric) The interrupt handler on the VAX has some strange behavior I have not been able to track down. Date: 26 Jul 1982 1520-PDT From: LANAM at HP-HULK Subject: bad feature : read macros on property list. Class: Deficiency By having the function associated with read macros stored on the property list, there is an inability to have different read macros in different read tables, for the same character. douglas RESPONSE (Eric) True. The whole input/output subsystem is very poor, for which there's no one to blame but me. See previous comments about the token scanner. Date: 26 Jul 1982 1155-PDT From: Alan Snyder <AS> Subject: EMODE bug Class: Bug EMODE believes that ^Z marks the end of a text file. RESPONSE (Eric) PSL uses a character as the EOF marker, which happens to be ^Z on the Dec-20. Any file with a ^Z in it will not be read correctly. Date: 24 Jul 1982 1044-PDT From: LANAM at HP-HULK Subject: scanner read bug with numbers. Class: Bug 45 lisp> 1.000000000000000000000000000000000000000000000000000 0.0 46 lisp> 1.222222222222222222222222222222222222222222222222222222 1.7682604E33 47 lisp> 100000000000000000000000000000000000000000000000 0 48 lisp> 2222222222222222222222222222222 2386092942 49 lisp> 1000000000000000000000 25209864192 50 lisp> 1000000000000 3567587328 douglas FIXED (Benson): Actually, just a crude patch that should improve things. Date: 24 Jul 1982 1043-PDT From: LANAM at HP-HULK Subject: can prettyprint do better than this with the following please? Class: Request (DEF FRANZ\FACT (EXPR LAMBDA (N) (COND ((EQ N 0) 1) (T (* N (FRANZ\FACT (!- N 1)))) ))) I would like the cond split up into 2 lines (one per clause). Date: 23 Jul 1982 1738-PDT From: LANAM at HP-HULK Subject: apply on macros. Class: inquiry Is there an apply that works on any function (whether the function is a macro or not), and acts the same whether the function was written as a macro or an expr or a fexpr? This would be very useful (especially with the number of basic functions written as macros in psl). RESPONSE (Eric) The function you want is EVAL, not APPLY. APPLY is meant to be a primitive operation which does no evaluation. Date: 23 Jul 1982 1718-PDT From: LANAM at HP-HULK Subject: how easy is it to redefine the psl reader? Class: inquiry Is there a table describing the automaton? Or is it hardwired in? Is the table accessable in lisp and changable? This would be very useful. RESPONSE (Eric) It is hardwired in. See previous comments on the token scanner. Date: 23 Jul 1982 1715-PDT From: LANAM at HP-HULK Subject: identifiers starting with numbers Class: request I would like the system to read an atom like 1+ as the atom |1+|, not the number 1 and the atom +. How can I teach the system to handle this? 1a would be an atom. 1 a would be the number 1 followed by the atom a. I need this feature to handle a franz conversion since a basic franz function is 1+ and 1-. douglas RESPONSE (Eric) Likewise. Date: 23 Jul 1982 1657-PDT From: LANAM at HP-HULK Subject: identifier bug. Class: Deficiency Characters and identifiers should be separate entities. The character c and the identifier c are not the same thing. Currently in the system, it is possible to intern a single character-name identifier into a package, but it is impossible to type its name back in. (setpackage 'franz) (localintern 'a) => franz\a (Setq franz\a 3) will set global\a (set (localintern 'a) 3) will set franz\a. franz\a is interpreted as global\a. I should be able to have my franz\a. douglas RESPONSE (Eric) Single character identifiers are treated very specially in PSL. Since packages are not integrated, they cannot be interned in packages other than GLOBAL. Date: 21 Jul 1982 16:48:33-PDT From: hearn@RAND-RELAY at HP-Speech Subject: Readch() Class: Inquiry, Bug Readch does not do case conversion, irrespective of the setting of *raise. If *raise is on, shouldn't lower case be converted to upper case? RESPONSE: Date: 21 Jul 1982 16:48:40-PDT From: BENSON@UTAH-20 at HP-Speech Subject: Re: Question on readch() I've changed the source for ReadCh so that it does case conversion on *Raise. This bit of Standard Lisp compatibility seems to have slipped through the cracks until now. I guess ReadCh just isn't used that much. Date: 21 Jul 1982 1549-PDT From: Alan Snyder <AS at HP-HULK> Subject: UnBoundP Class: Documentation deficiency The function UnBoundP should be described (or mentioned) in the chapter on Identifiers. Date: 21 Jul 1982 1422-PDT From: Alan Snyder <AS> Subject: DEFSTRUCT Class: Deficiency Using DEFSTRUCT (from NSTRUCT) causes the PSL compiler to produce "function redefined" messages. As far as the user is concerned, these messages are spurious and should be suppressed. Date: 21 Jul 1982 1253-PDT From: Alan Snyder <AS> Subject: "Constant" list structure Class: Deficiency, comment PSL allows a program to modify "constant" list structure that has been created by the compiler in the code space. Since this "constant" list structure is not scanned by the garbage collector, any pointers inserted into it will not be updated when garbage collection occurs, and will henceforth point to randomness. PSL should use the address protection provided by the hardware to prevent modification of "constant" list structure. RESPONSE (Benson): It is incorrect to modify list structure constants. They are placed in code space on the VAX when a dumplisp is done. Date: 21 Jul 1982 1127-PDT From: Alan Snyder <AS> Subject: Unhandled THROW Class: Deficiency, documentation bug The manual (section 9.4) says that an unhandled THROW is treated as an ERROR in the context of the THROW. In fact, what happens is that PSL is restarted at top-level. I would prefer that it behave as the manual describes. RESPONSE (Eric) It's very hard to fix with the current implementation of CATCH. Date: 16 Jul 1982 0244-PDT From: BATALI Subject: Compiler bug Class: Bug Here is an interesting function: (de c3 () (cond ((= 3 3) 'yes) (t (= 3 3)))) Interpreted: (c3) YES Compiled: (c3) T Obviously the compiler is doing something grossly clever, obviously it is doing it wrong. --John Date: 16 Jul 1982 0237-PDT From: BATALI Subject: Compiler bug Class: Bug, deficiency The compiler doesn't enforce the restrictions on the placement of RETURN statements. (See pages 9.4 and 9.5 of the manual.) This function gets an error if interpreted, but returns its argument when compiled: (de just-return (arg) (return arg)) Actually, the compiler ought to complain about this one. --John Date: 16 Jul 1982 0149-PDT From: BATALI Subject: RPLACHAR (String package) Class: Bug, compiler bug The function RPLACHAR stores a character into a string. It works fine in interpreted code, but when called from a compiled function, we get: ***** Undefined function STRINF called from compiled code Looking on the property list of RPLACHAR, we notice a CMACRO property whose value is: (LAMBDA (S I X) (PUTSTRBYT (STRINF S) I X)) Which seems to be where the call to STRINF comes from. Giving RPLACHAR a CMACRO property of nil "fixes" the problem. --John RESPONSE (Eric) Fixed. Date: 15 Jul 1982 1258-PDT From: Alan Snyder <AS> Subject: EMODE C-M-B Class: Bug, comment C-M-B (backwards s-expr) loses if the corresponding left paren is the first character in the buffer: it leaves the cursor to the right of the paren. There is explicit code that makes this adjustment, and this code is marked in the source as being a "KLUDGE!". I don't know why this kludge is there. Date: 14 Jul 1982 1404-PDT From: Alan Snyder <AS> Subject: STRING< (String package) Class: Bug The function STRING< in STRINGS.LSP has the interesting property that both of the following forms evaluate to NIL: (string< "b" "aa") (string< "aa" "b") This anomoly results from the improper testing of string length in the function. The other string comparison functions seem to have the same bug. [This seems to have been fixed.] Date: 14 Jul 1982 0759-PDT From: Alan Snyder <AS> Subject: EMODE bug Class: Bug I fixed a bug in REFRESH.RED: ClearWindow() previously failed to clear the associated virtual screen, causing the old contents to later reappear in place of empty lines. Date: 13 Jul 1982 1739-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: FIND module Class: Documentation deficiency The "find" module is not loaded in bare PSL, but the documentation does not mention the fact. Date: 13 Jul 1982 1144-PDT From: Alan Snyder <AS> Subject: FindPrefix, FindSuffix -- request Class: Request FindPrefix and FindSuffix should convert their string argument to upper case. Date: 13 Jul 1982 1140-PDT From: Alan Snyder <AS> Subject: PrettyPrint Class: Request For direct use by a human, it would be better if PRETTYPRINT returned NIL, instead of its argument. That way, the user doesn't have to see the same object printed twice by the Read/Eval/Print loop. Date: 13 Jul 1982 1120-PDT From: LANAM Subject: Interning with the package system Class: Inquiry How can I get the package-specifier prefix in a string and concat it with other strings, and then intern it. I tried, and the package-specifier prefix character got an escape character inserted before it. RESPONSE (Benson): Can't be done. Date: 13 Jul 1982 1114-PDT From: Alan Snyder <AS> Subject: COND Class: Deficiency COND behaves differently in some cases depending upon whether it is interpreted or compiled. An example is provided by the following function: (de foo (a) (cond ((= a 3) 4) a)) If interpreted, FOO will return the parameter A unless A is 3. If compiled, FOO will return NIL in those same cases. The compiled code is shown below: ------------------------------------------------------------ Compiling FOO Source: (LAMBDA (A) (COND ((= A 3) 4) A)) ------------------------------------------------------------ Object: (*ENTRY FOO EXPR 1) (*ALLOC 0) (*JUMPNOTEQ (LABEL G0004) (REG 1) '3) (*MOVE '4 (REG 1)) (*EXIT 0) (*LBL (LABEL G0004)) (*MOVE 'NIL (REG 1)) (*MOVE 'NIL (REG 1)) (*EXIT 0) *** Function `FOO' has been redefined *** (FOO): base 334750, length 7 words ------------------------------------------------------------ Date: 13 Jul 1982 1056-PDT From: Alan Snyder <AS> Subject: ErrorSet Class: Deficiency ErrorSet is currently implemented as an EXPR. This fact has the subtle, yet critical effect that the form enclosed in the error set can only use fluid variables. If you don't declare the variables fluid, the code will work interpretively, but will execute incorrectly when compiled. No warning is given by the compiler, nor is there any hint in the manual that this problem exists. Note: the file directory.sl that we sent to Utah fails when compiled for this reason. I suggest you send a message to Will about this. RESPONSE (Eric) Yes, this is also true of CATCH. I have implemented *CATCH which is a special form and open-compiles. It will be easy to define ERRSET as a macro or special form now. Date: 13 Jul 1982 1045-PDT From: BATALI Subject: Readmacros Class: Deficiency, comment I've been experimenting with read macros in PSL. None of the advertised functions for creating them exist, but the following works: (defmacro define-read-macro (table id fname) `(progn (put ',id 'lispreadmacro ',fname) (putv ,table (id2int ',id) 11) ;; delimiter ',id)) This does what PutReadMacro is supposed to do (but it doesn't evaluate the id or the fname). Note how this seems to work: If the reader (actually, the function ChannelReadTokenWithHooks) sees a character with code 11 in the scantable, it looks for the LISPREADMACRO property on the id corresponding to the character. If there is one there, it applys it in place of ChannelReadTokenWithHooks to the input channel. This would be fine and not very interesting and I certainly wouldn't be sending you this long message if it weren't for the fact that this scheme means you can't "bind" a scantable and expect different behaviour from characters. This is because, although the scantable can be bound, the system still looks for the LISPREADMACRO property of the id. So it is not possible for a character to have different properties on different scantables. Thus: (define-read-macro somerandomscantable* !( ChannelTotallyTrashSystem) Would lose no matter which scan table is currently in effect. We need the ability to pair characters with functions in particular scantables only. It is very likely that the PSL people understand this, and indeed, the relevant sections of the manual (pp 13.10 - 13.11 and 13.18) seem to claim that this is what ought to go on. --John RESPONSE (Eric) This was reported earlier (actually later because this is in reverse chronological order). Date: 13 Jul 1982 1030-PDT From: BATALI Subject: Unwind-Protect Class: Suggestion Here is the code for unwind-protect. It has the same semantics as the lisp-machine version (except in interpreted code that happens to use the variable unwind-protect-value). The only problem is the problem with catch being an EXPR. (defmacro unwind-protect (protected-form . undo-forms) `(let ((unwind-protect-value (catch nil ',protected-form))) (progn . ,undo-forms) (if throwsignal!* (throw throwtag!* unwind-protect-value) unwind-protect-value))) Date: 12 Jul 1982 1836-PDT From: BATALI Subject: Dipthongs Class: Inquiry, documentation deficiency What are dipthongs? Why are they neat? How do I use them? Why aren't they documented? Date: 12 Jul 1982 1145-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: EMODE terminal handling Class: Deficiency EMODE does not use the terminal driver that corresponds to TOPS-20's idea of what the terminal type is. It just uses whatever terminal driver is loaded (HP2648A in our case). Date: 12 Jul 1982 1102-PDT From: Johnson Subject: PSL String Package Class: Request, remark A routine to convert from STRING to INTEGER would be nice. The SUBSTRING function is peculiar: its last argument is one greater than the index of the last character to be extracted, even given that indexes begin at zero! Date: 9 Jul 1982 1456-PDT From: Alan Snyder <AS> Subject: PSL internal bug Class: Bug The following example demonstrates a bug in PSL. It is the shortest example I could find, derived from a real attempt at compiling a file. The offending object is a machine instruction, the exact identity of which changes with different programs. In this case, it is "CAMN 0(17)". The example is highly sensitive to change. For instance, if the function name is changed to "FOO", no error is reported. Similarly, no error is reported if any of the loaded modules are omitted. ------------------------------------------------------------------------------- @psl:bare-psl PSL 3.0, 9-Jun-82 1 lisp> (load emode common jsys) NIL 2 lisp> (faslout "nul:") FASLOUT: (DSKIN files) or type in expressions When all done execute (FASLEND) T 3 lisp> (de fooo (name) 3 lisp> (let ((n (string-length name))) 3 lisp> (cond ((= (indx name (- n 1)) (char >)) 3 lisp> (concat name "*.*.*")) 3 lisp> name))) FOOO4 lisp> (faslend) *** Init code length is 1 **FASL**INITCODE**NIL 5 lisp> (reclaim) ***** Fatal error during garbage collection Illegal item in heap at 502462 ------------------------------------------------------------------------------- Date: 30 Jul 1982 11:27-PDT (Friday) From: John.Tupper <hp-pcd!maddog> Subject: bug report I have found a bug in the vax version of the psl zpedit. When I add something to the end of an s-expression [with the n command] the editor changes the old last expression to nil. start: (LIST (CAR X) (CDR Y)) execute: (N (BOGUS BO GUS)) finish: (LIST (CAR X) NIL (BOGUS BO GUS)) The same thing happens with the bo command. start: (LIST (CAR X) (CDR Y)) execute: bo 3 finish: (LIST (CAR X) NIL) icky-poo, maddog Date: 9 Jul 1982 0948-PDT From: SOREFF at HP-THOR Subject: Structure editor "A" command Class: Bug I've constructed an example of how the "(a s-expression)" command in the structure editor can fail. It seems to fail when one is adding an item after the last expression in a list. I've edited the log slightly, removing blank lines to make it more compact. @take psl PSL 3.0, 9-Jun-82 1 lisp> (load zpedit) NIL 2 lisp> (setq a '(b c d e f g)) (B C D E F G) 3 lisp> (editv a) EDIT -E- p (B C D E F G) -E- 3 p D -E- (a z) 0 p (B C D (Z) E F G) -E- 7 p (a y) 0 p G (B C D (Z) E F NIL (Y)) -E- pp (B C D (Z) E F NIL (Y)) -E- 8 p (Y) -E- (a x) -E- p ... NIL (X)) -E- ^ -E- p (B C D (Z) E F NIL NIL (X)) -E- ok A 4 lisp> (quit) Date: 9 Jul 1982 0938-PDT From: Alan Snyder <AS> Subject: DOLIST Class: Bug DOLIST (in PU:COMMON.SL) fails to bind the loop variable. Date: 8 Jul 1982 1447-PDT From: Alan Snyder <AS> Subject: EMODE C-M-B Class: Bug, deficiency EMODE C-M-B (backward sexpr) gets excessively confused by comments. For example, when at the end of the following text (setq a b) %%%%%%%%%% C-M-B will stop at the "b". (Probably other commands have similar problems.) I think the reason for this is that '%' (the comment character) is ignored by scan-word by not by skip-blanks. Thus in the implementation of C-M-B, skip-blanks skips back to the '%', and then skip-word skips back to the 'b'. The probable fix would be to change the scan table. Date: 7 Jul 1982 1651-PDT From: SOREFF at HP-THOR Subject: Structure editor "N" command Class: Bug I think I've run into a bug in the PSL structure editor. The "N" command, which appears to be supposed to append an s-expression on the end of the current list, does that, but also changes the expression just before the added one to NIL. @login guest Job 5 on TTY152 7-Jul-82 4:41PM Previous LOGIN: 7-Jul-82 4:40PM @take <psl>logical-names @r <psl>bare-psl PSL 3.0, 9-Jun-82 1 lisp> (load zpede^F^Fit) ***** `ZPED^FIT' load module not found {99} Break loop 2 lisp break>> q 3 lisp> (load zpedit) NIL 4 lisp> (setq tst '(a b c d e f g)) (A B C D E F G) 5 lisp> (editv tst) EDIT -E- p (A B C D E F G) -E- (-3 z) p (A B Z C D E F G) -E- (n x) p (A B Z C D E F NIL X) -E- ok TST 6 lisp> (quit) Date: 7 Jul 1982 0929-PDT From: Alan Snyder <AS> Subject: NTH and PNTH Class: Bug The function NTH produces obscure error messages if the index argument is out of range. The error messages are obscure because (1) they refer to the function PNTH, which the user should have no need to know about, and (2) they report an index which is different than the value given in the call to NTH. [8/4/82 - This has been fixed.] A similar comment applies to PNTH: the error message reports an incorrect index value. [8/4/82 - This hasn't.] Date: 7 Jul 1982 0852-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: IN and EVIN Class: Documentation deficiency, bug IN and EVIN, available from RLISP, are not defined as functions. IN even has an entry in the manual, though there is no description of what it does (page 31.12). These should be available from LISP. Date: 6 Jul 1982 1212-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: RDS, WRS Class: Complaint RDS and WRS are virtually guaranteed to cause lossage concerning I/O channels, especially since there is no UNWIND-PROTECT in PSL. Date: 6 Jul 1982 1209-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Debugging Class: Deficiency There are various deficiencies concerned with debugging. There is no genuine backtrace that uses the saved variable bindings, even for interpreted code. The error handling system is so portable that it evidently cannot use the DEC-20 APR trap mechanism, etc.. It is difficult to set up an interpreted version of a subsystem that is usually compiled. (This is a separate issue from the capabilities of the system internals.) In particular, facilities for requiring certain files to be present when a procedure is loaded for interpretive execution don't exist. Also functions for loading interpreted and compiled code are distinct, not to mention the additional distinct function for loading "system" files (files in pl:). Date: 6 Jul 1982 1041-PDT From: Johnson Subject: DSKIN Class: Inquiry (DskIn "foo.lsp") prints the values of all the forms evaluated in foo.lsp. Is there a silent version of DskIn? RESPONSE (Benson): Yes: LAPIN. Date: 2 Jul 1982 2335-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: DEC-20 REENTER and CONTINUE To: psl at HP-HULK On the DEC-20, ^C followed by REENTER or CONTINUE screws up badly for some reason. I would think they would just not be available commands. Date: 2 Jul 1982 2334-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Debugger user interface Class: Bug The "break loop" does not establish echoing as it is entered. Date: 2 Jul 1982 2329-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: FINDPREFIX and FINDSUFFIX Class: Documentation deficiency, bug These are not loaded with the USEFUL library and there whereabouts is not documented in the manual, though they themselves are. They appear in pu:find.red. Date: 1 Jul 1982 1406-PDT From: Kendzierski (Nancy) Subject: CRLF variable Class: Bug, documentation bug The manual (page 20.2, section 20.3.1 "TOPS-20 User Level Interface") states that "a global variable, CRLF, is provided with the <CR><LF> string. Attempts to use this global variable result in a CRLF is an unbound id {99} message from psl. RESPONSE (Benson): Loading the EXEC module defines CRLF. Date: 30 Jun 1982 1057-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: "FLAGS" Class: Inquiry, deficiency In Chapter 12 of the manual the RLISP "On" and "Off" constructs are discussed briefly. It appears that LISP users should not just set the corresponding global variables, because On and Off may have additional side effects. If this is true, there should be some easy way of doing On and Off in LISP. Date: 28 Jun 1982 1746-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: C-M-rubout in EMODE Class: Bug Sometimes (always?) goes into an infinite loop. Date: 28 Jun 1982 1714-PDT From: Kendzierski (Nancy) Subject: PSL logical names Class: Inquiry How come p20d: as <psl.20-dist> isn't defined in the <psl>logical-names.cmd file? It is listed in the manual on page 22.2. Date: 6/23/82 From: Kendzierski Subject: !*SAVENAMES Where: Page 16.18 Class: Inquiry Why is !*SAVENAMES initially NIL? Date: 6/23/82 From: Kendzierski Subject: RCRef Where: Page 18.3 Class: Inquiry Is RCRef only available in RLisp? Why? or How is it used in Lisp? From: Kendzierski Date: 6/23/82 Subject: !*LOSE Where: Page 16.18 Class: Documentation deficiency !*LOSE -- what is this? It's constantly referred to, but never defined/explained Date: 6/23/82 From: Kendzierski Subject: #+ Where: Page 18.3 Class: Inquiry Why doesn't #+ accept three arguments? Because the third is optional? Date: 6/23/82 From: Kendzierski Subject: ANYREG Class: Inquiry If the most common adjust function removes ANYREG to eliminate looking for it in patterns, why have it? Date: 6/11/82 From: AS Subject: I/O channels Class: improvement, section 13.1, page 13.1 Why is a channel an integer instead of something more abstact? If you allow I/O to strings and lists, then why limit the maximum number of channels? Date: 6/11/82 From: AS Re: improvement, section 13.2, page 13.3 Using global variables to initialize channel functions when a channel is OPENed is poor. It would be better to define a separate OPEN-SPECIAL that takes additional arguments, or use a keyword init list a la Zetalisp. Similar comments about misuse of global variables apply elsewhere, e.g. DUMPLISP. Date: 6/11/82 From: AS Re: manual, section 13.6, page 13.13 PRINTF is an expr that takes a variable number of arguments. If this is possible then you should explain how users can do it. Date: 6/11/82 From: AS Subject: LISP vs. RLISP syntax Class: Inquiry, bug Where: manual, section 16.5, page 16.13 Can EMBEDding be done using Lisp syntax? If so, how? Can STUBs be defined using Lisp syntax? If so, how? Date: 6/11/82 From: AS Subject: EDITF Class: Bug, inquiry Where: manual, section 17.5, page 17.11 I was not able to achieve any effect by giving extra command arguments to EDITF. In any case, COMS:forms is not a defined type; it should be either [COMS:form] or COMS:form-list. Date: 6/11/82 From: AS Subject: FIELD, GETFIELD Class: Documentation deficiency Re: manual, section 21.2.8, page 21.7 Is the field accessing function FIELD or GETFIELD? Both names are used in the manual. Neither name is defined in our PSL. Date: 6/25/82 From: Filman Subject: READ, Interactive input Class: Feature request It would be very nice to have some way of telling PSL to consider all open parens to be closed, like right square bracket ("]") in some LISPs. It would also be nice not to get an error message whenever one types excess right parentheses. Date: 6/25 From: Perdue, Griss, AS Subject: Common-LISP compatibility library Class: Documentation bug The Common-LISP compatibility library has been split into 2 parts: a compatible part which redefines no PSL functions, and an incompatible part that does. The incompatible part is PL:CLCOMP. Date: 18 Jun 1982 From: SOREFF at HP-THOR Subject: Module loaded test Is there any predicate which checks to see if an atom is the name of a load module which has been loaded? RESPONSE (Perdue): No, but it is currently the practice to use the expression "(memq <atom> options*)" to determine this. Date: 18 Jun 1982 1424-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Char macro The char macro is not well documented and the use of <Ctrl-G> is almost certainly not correct. Date: 18 Jun 1982 1425-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: PLAP: logical name Class: Distribution of PSL The name PLAP: is used in the full-restore.ctl file, but is not a standard logical name. It should be PL: instead. RESPONSE (Griss): The file full-restore.ctl is not documented, wasn't intended for distribution. Something will be done to make things consistent. Date: 18 Jun 1982 1429-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Batch control files Class: Distribution of PSL The batch control files use the standard logical names. For this to work properly, users who rebuild PSL should have a BATCH.CMD file that TAKEs the logical-names command file. This approach is cleaner than having mentions of the actual name of the PSL directory, if not others, in each batch control file. Date: 18 Jun 1982 1431-PDT From: Cris Perdue <Perdue at HP-HULK> Subject: Building new directories Class: Documentation bug The DEC-20 release notes suggest the use of the standard logical names as arguments to the TOPS-20 BUILD command. Our version of BUILD does not accept a logical name for the building of a NEW directory (it's OK for old ones, although that feature may be a local addition to the code). Date: 6/16/82 From: Alan Snyder <AS> Subject: PSL compiler bug; RETURN Class: Bug I have discovered what appears to be a bug in the PSL compiler. When you use (RETURN) with no argument, the compiler generates a "call" to the function NIL, which is undefined. The interpreter has no problem. For example: 16 June 1982 Alan Snyder ---------------------------------------- Compiling TEST Source: (LAMBDA NIL (PROG NIL (RETURN)) 3) ---------------------------------------- Object: (*ENTRY TEST EXPR 0) (*ALLOC 0) (*LINK NIL EXPR 0) (*MOVE '3 (REG 1)) (*EXIT 0) *** Function `TEST' has been redefined *** (TEST): base 326164, length 3 words ---------------------------------------- RESPONSE (csp): Definitely a bug. Not hard to fix, the solution awaits a decision about just what error checking there should be on RETURN. RESPONSE (Benson): The compiler now gives a warning message. From: Lanam Subject: Packages Class: Bugs, Information Doug uncovered the following: The current package is never changed as a module is loaded. This means that if one changes the current package, it should be reset as soon as possible. Some functions are "autoloaded". Be aware of this when changing the current package. Date: 5/27 From: Lanam Class: Bug asin (n) where n > 1 or n < -1 gives the error that REDERR is an undefined function. Date: 5/27 From: Lanam Class: Deficiency I can not find any method of general type checking or type coersion. Date: 5/27 From: Lanam Class: Bug (close) with no arguments says nil is an undefined function. Date: 5/27 From: Lanam Class: Note (car nil) and (cdr nil) is illegal. I would prefer (car nil) => nil and (cdr nil) => nil. Date: 5/27 From: Lanam Subject: Reader Class: Bug Typing an extra ")" to the top level interpreter gives you an error message. It would be nicer if it was just ignored. Date: 5/27 From: Lanam Subject: Getd, Putd Class: Comment It would be nice if (putd new-function-name (getd old-function name)) worked. At present the best I can see is (let ((x (getd ..))) (putd new (car x) (cdr x))) Date: 5/27 From: Lanam Subject: Lexprs Class: Feature request Need a package that allows lexpr and (arg n) inside lexprs. Date: 5/27 From: Lanam Subject: Defun Class: Deficiency Defun in common lisp compatibility only handles exprs, not macros, or fexprs. Date: 5/27 From: Lanam Subject: Function/special definition Class: Bug Cannot have the names of fexprs or macros or nexprs, be the name of a special variable also. Date: 5/27 From: Lanam Subject: Char function Class: Documentation bug There are two char functions described in the manual. The one mentioned as being loaded with the Common-LISP strings package is not loaded in with the strings package. Date: 5/24 From: Goldstein Subject: Argument checking Class: Clarification Is it the case that PSL does not check for functions that receive the wrong number of arguments? Is it able to do so (for interpretive & for compiled code)? It would be nice if it had such an error checking mode. Date: 5/24 From: Goldstein Subject: Section 8.7 Class: Documentation deficiency The arguments to the string functions are not defined. Date: 5/24 From: Goldstein Subject: Globals, fluids; Section 10.4 Class: Bug, Documentation bug The manual claims that global variables cannot be rebound. However, no error occured for: ((lambda (throwtag*) 1) 1) which rebinds this global?? Date: 5/24 From: Goldstein Subject: Closures, Section 10.3.1 Class: Question What is the timetable for implementing closures. Altbind is unavailable at our site. Date: 5/24 From: Goldstein Subject: Global variables; Section 12.2 The description of the globals is frequently missing or too cryptic. Date: 5/24 From: Goldstein Subject: Lisp Rlisp compatibility Class: Deficiency If RLISP is only a parser for Lisp, then there should be functions: On, Off, In, Out. Why don't these functions exist. Ditto for <=, >=, etc. RESPONSE (Griss, as told to Perdue): This situation is basically historical. The problems with On, Off, In, Out, etc. are due to the RLISP preprocessor doing some semantics as well as parsing. It is gradually being cleaned up. Date: 5/23 From: Goldstein Subject: Definition of Equal, sec 4.2 Class: Documentation deficiency Comment about open-compiling that begins "... Otherwise, ..." is confusing. The text says that "This is not true of EQ and Eqn". What is not true. EQ is supposed to be open-compiled as well. Date: 5/23 From: Goldstein Subject: Definition of EqCar, sec 4.2 Class: Deficiency, Inquiry EqCar(U,V) does not complain if (Car U) is illegal, e.g. (EQCAR "ab" V). (1) Does the definition check, or is some random thing happening; and (2) should it report an error if (CAR U) is illegal. RESPONSE (Perdue): 1) The definition checks that U is pairp. 2) It evidently should not report an error if U is not pairp. Date: 5/23 From: Goldstein Subject: Definition of Null, sec 4.2 Class: Manual, Inquiry Is it reasonable to place documentation of Null in 4.2.2, Is Null a predicate for testing Type of an Object? Date: 5/23 From: Goldstein Subject: Definition of Intern and NewId, sec 4.2 Class: Manual deficiency Interning a newId does not lose NewId's property list, if no previous ID with this print name has been interned, e.g. (setq x (newId "ABC")) %No atom with this print name exists. (put x 'prop 'val) (intern x) (get 'ABC 'prop) --> val Manual could be clearer in this regard. Date: 5/23 From: Goldstein Subject: Arithmetic functions Class: Manual, Inconsistency MACRO rather than NEXPR is used for the multi-argument functions like PLUS. What is the rationale for this. Date: 5/23 From: Goldstein Subject: Help function Class: Inconsistency (help top-loop) and (help toploop) are not the same. The former just prints the file. The latter executes a function that prints the file, then prints the current bindings of the reader, printer, etc. This might be confusing to a novice user. Perhaps, the file should be toploop.hlp (without the - sign). Date: 5/22 From: Goldstein Subject: Backtrace Class: Improvement It would be nice if BACKTRACE did not print the functions that it itself put on the stack, since they are artifacts of its use and not relevant to debugging. Date: 5/22 From: Goldstein Subject: EMODE Class: Improvement (1) bind backspace to the rubout handler. (2) Commands like read and write file should use the default file associated with the current buffer. (3) Auto save and Auto fill are two important additions. (4) Write should say that the file was written. Date: 5/22 From: Goldstein Subject: HELP function Class: Improvement It would be nice if the HELP function also informed the user of some dynamic properties, e.g. HELP <module> should let the user know if the module is loaded. Date: 5/22 From: Goldstein Subject: HELP function Class: Documentation deficiency (HELP) states that a certain set of help files are available. In fact, there is a larger set corresponding to thse described in the manual. Date: 5/22 From: Goldstein Subject: EMACS function Class: Bug (EMACS) tries to run <EDITORS>EMACS.EXE. The HP HULK has no directory <EDITORS>. Date: 5/22 From: Goldstein Subject: MMFORK variable Class: Consistency The manual describes the convention that globals have the suffix !*. But, the MM command uses the variable MMFORK with no suffix. Date: 5/22 From: Goldstein Subject: HELP function Class: Bug In RLISP mode, HELP FOR; losses because the parser attempts to parse FOR unless FOR appears in quotes. Date: 5/22 From: Goldstein Subject: External, Internal, Exported; section 21.2 Class: Documentation bug In the example, EXPORTED ... appears, but it is not documented in the preceding text. Only external, internal are documented. Date: 5/22 From: Goldstein Subject: SYSLISP; p21.3 Class: Documentation deficiency The manual does not explain how to reformulate a LISP function into a SYSLISP function when in LISP mode, i.e. is there a some kind of reformulator that converts calls to plus to calls to wplus2. Date: 5/22 From: Goldstein Subject: *TIME variable Class: Bug Executing (setq !*Time T) causes an error which caused system to begin prompting with line number 1. This only happened the first time, and did not repeat when !*Time was toggled. Repeatable in a fresh PSL. Does not occur in RLISP mode, only in LISP mode. Date: 5/8 From: Goldstein Subject: How to make a dribble file Class: Inquiry It appears that PSL cannot write to two channels at the same time, thus preventing a dribble file. RESPONSE (Griss): Redefine PRINT functions to write to two channels or define your own special channel with a writechannel function that writes to two other channels. Date: 5/8 From: Goldstein Subject: TOPS-20, DOCMDS, CMDS Class: Documentation deficiency, Bug These functions do not seemed to be defined. RESPONSE (Griss): Help file erroneously mentions exec0. Exec, MM and EMACS are autoloading. The rest are obtained by LOAD EXEC;. Date: 5/8 From: Goldstein Subject: Prettyprinting Class: Inquiry Is there a prettyprinter? RESPONSE (Griss): Yes, the function Prettyprint. Date: 5/8 From: Goldstein Subject: PPF Class: Bugs Debug module has the function PPF which apparently pretty prints in RLISP format. PPF tries to print according to the currently loaded parser. Unfortunately, it detects whats loaded by looking for the function RPRINT, which is autoloading. Also, ppf and plist lose when the fn or plist is not defined. RESPONSE (Griss): True. Date: 5/8 From: Goldstein Subject: Interrupt characters Class: Documentation deficiency There don't seem to be any interrupt characters, e.g. control-g to return to toplevel. (An interrupt package is mentioned, but not cited as complete.). RESPONSE (Griss): Interrupts exist (Load Interrupt), but not documented. Date: 5/8 From: Goldstein Subject: LAPOUT, LAPEND Class: Obsolete, Inquiry The functions LAPOUT, and LAPEND do not seem to exist. Possibly a renaming has taken place since the 18 January manual. RESPONSE (Griss): FASLOUT and FASLEND are the correct functions. Date: 5/8 From: Goldstein Subject: Saving a PSL Class: Inquiry, obsolete I tried SAVESYSTEM, followed by the TOPS-20 SAVE command. However, when I tried to run the resulting .exe file, I got the complaint "No starting address". How is a PSL saved and restarted. (Manual, p.14.1) RESPONSE (Griss): The file on the tape is still incorrect. Patch needed to handle tops 20 release. RESOLUTION: Apparently fixed. Date: 5/8 From: Goldstein Subject: HELP Class: Documentation bug, documentation deficiency The manual claims that HELP of no arguments prints a message. It works in Lisp mode as (HELP) and in RLISP mode as HELP; but HELP(); loses?? RESPONSE (Griss): help() still loses. help mini-editor requires ! before -. Date: 5/8 From: Goldstein Subject: Rubout handler Class: Inquiry The Rubout handler is line-oriented, and apparently one cannot rubout accross cr's. Is this true? RESPONSE (Griss): Yes. Date: 5/8 From: Goldstein Subject: PSL memory usage Class: Inquiry What is the size of various PSL spaces. Date: 5/8 From: Goldstein Subject: PSL memory usage Class: Feature request One would like an INQUIR function that prints out PSL memory usage statistics. Date: 5/8 From: Goldstein Subject: HELP facility Class: Documentation bug; Bug Note that some help files are incorrect; eg HELP editor refers to minieditor, not mini-editor |
Added psl-1983/x-psl/check-in-out.txt version [a7ffc6f8bf].
Added psl-1983/x-psl/ex-bare-psl.exe version [84a851b521].
cannot compute difference between binary files
Added psl-1983/x-psl/ex-nmode.exe version [62441a97be].
cannot compute difference between binary files
Added psl-1983/x-psl/ex-psl.exe version [b7b2234228].
cannot compute difference between binary files
Added psl-1983/x-psl/ex-rlisp.exe version [a7378c8f6f].
cannot compute difference between binary files
Added psl-1983/x-psl/full-psl-names.cmd version [e3ec710fb9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | take psl:psl-names ! Defines names commented out here ; psl: ss:<psl> ! System-wide definition ;define psys: ss:<psl.subsys> ! Directory of executable files ;define psl: ss:<psl>,ss:<psl.subsys> ;OBJECT CODE FILES ;define pl: ss:<psl.lap> ! All PSL .B files live here ;define plap: ss:<psl.lap> ! Loadable files (untouched by search path games) ;SOURCE CODE, COMMAND FILES, (also .rel files) define pk: ss:<psl.kernel> ! Machine-independent kernel sources define pi: pk: ! Old logical name for kernel stuff define pcr: ss:<psl.kernel-cray> ! cray kernel sources define p20: ss:<psl.kernel-20> ! Dec-20 kernel sources define pv: ss:<psl.kernel-vax> ! Vax kernel sources define php: ss:<psl.kernel-hp9836> ! hp9836 kernel define phpp: ss:<psl.kernel-hp9836-pascal> ! Pascal sources for HP9836 define p68: ss:<psl.kernel-68> ! 68000 kernel sources define p10x: ss:<psl.kernel-tenex> ! Tenex and KI specific kernel sources define pnk: ss:<psl.nonkernel> ! Machine-independent non-kernel define p20nk: ss:<psl.nonkernel-20> ! Dec-20 non-kernel define pvnk: ss:<psl.nonkernel-vax> ! Vax non-kernel define pc: ss:<psl.comp> ! Machine-independent compiler sources define pcrc: ss:<psl.comp-cray> ! CRAY compiler sources define p20c: ss:<psl.comp-20> ! Dec-20 compiler sources define pvc: ss:<psl.comp-vax> ! Vax compiler sources define p68c: ss:<psl.comp-68> ! 68000 compiler sources define phpc: ss:<psl.comp-hp9836> ! Hp9836 compiler sources - fix name ;define pu: ss:<psl.util> ! Machine-independent loadable modules ;define p20u: ss:<psl.util-20> ! Dec-20 utility program sources define pvu: ss:<psl.util-vax> ! Vax utility program sources define phpu: ss:<psl.util-hp9836> ! Hp9836 utility program sources ;define pn: ss:<psl.nmode> ! NMODE sources and binaries define pe: ss:<psl.emode> ! EMODE sources ;define pw: ss:<psl.windows> ! WINDOW PACKAGE sources and binaries define pg: ss:<glisp> ! GLISP, not a subdirectory at HP . . . ;DOCUMENTATION FILES ;define plpt: ss:<psl.lpt> ! Printable version of ref. manual ;define pman: ss:<psl.manual> ! Manual sources and working files ;define pndoc: ss:<psl.nmode-doc> ! Documentation for NMODE ;define ph: ss:<psl.help> ! xxx.HLP => help, ! xxx.DOC => documentation of PU: file ;define p20h: ss:<psl.help-20> ! For the DEC-20 define pvh: ss:<psl.help-vax> ! For the VAX define phph: ss:<psl.help-hp9836> ! For the HP9836 define p20dist: ss:<psl.dist-20> ! Dec-20 distribution docs and tools define pvdist: ss:<psl.dist-vax> ! Vax distribution docs and tools define phpdist: ss:<psl.dist-hp9836> ! HP9836 distribution docs and tools define padist: ss:<psl.dist-apollo> ! Apollo distribution docs and tools ;define pd: ss:<psl.doc> ! Should be source and output files for ! formal documents (except the manual) ;define p20d: ss:<psl.doc-20> ! For the DEC-20 define pvd: ss:<psl.doc-vax> ! For VAX define phpd: ss:<psl.doc-hp9836> ! For HP9836 define pad: ss:<psl.doc-apollo> ! For Apollo ;MAINTAINER-ORIENTED ARCANA AND ESOTERICA (no erotica) ! Files for pl: not generated, e.g. from .sl, .red files define p20l: ss:<psl.lap-20> define pvl: ss:<psl.lap-vax> define phpl: ss:<psl.lap-hp9836> ! Files that belong on "psl:" on the "target" machine, but not ! necessarily on "psl:" on the central file repository machine. define p20psl: ss:<psl.psl-20> define pvpsl: ss:<psl.psl-vax> define phppsl: ss:<psl.psl-hp9836> define psup: ss:<psl.support> ! PSL support stuff define p20sup: ss:<psl.support-20> ! PSL support stuff, 20 specific define pvsup: ss:<psl.support-vax> ! PSL support stuff, Vax spcific define phpsup: ss:<psl.support-hp9836> ! PSL support stuff, Hp9836 define pasup: ss:<psl.support-apollo> ! For Apollo ;define pnew: ss:<psl.new> ! Pre-release loadable files define s: ss:<psl.scratch> ! Scratch directory define pt: ss:<psl.tests> ! Test directory define p20t: ss:<psl.tests-20> ! 20 sub-case define phpt: ss:<psl.tests-hp9836> ! hp9836 sub-case take |
Added psl-1983/x-psl/hps-logical-names.cmd version [3a18e2b7d4].
> > | 1 2 | take psl:psl-names.cmd take |
Added psl-1983/x-psl/logical-names.cmd version [6ad8518730].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ! Unused names with unknown purpose are commented out with a ";?". ! [WFG, U. of U.] define psl: ps:<psl> ! System-wide definition define pb: ps:<psl.betty> ! Betty sources define pc: ps:<psl.comp> ! Machine-independent compiler sources define p20c: ps:<psl.comp.20> ! Dec-20 compiler sources define p20ec: ps:<psl.comp.20.ext> ! Extended Dec-20 compiler sources define p68c: ps:<psl.comp.68> ! 68000 compiler sources define capollo: ps:<psl.comp.68.apollo> ! Apollo compiler sources define pac: ps:<psl.comp.68.apollo> ! Apollo compiler sources define phpc: ps:<psl.comp.68.hp> ! Hp9836 compiler sources - fix name define cwicat: ps:<psl.comp.68.wicat> ! wicat compiler sources define pwc: ps:<psl.comp.68.wicat> ! wicat compiler sources define pcrc: ps:<psl.comp.cray> ! CRAY compiler sources define pvc: ps:<psl.comp.vax> ! Vax compiler sources define pdist: ps:<psl.dist> ! Distribution main directory define p20dist: ps:<psl.dist.20> ! Dec-20 distribution documents define p68dist: ps:<psl.dist.68> ! 68K distribution documents define pcrdist: ps:<psl.dist.cray> ! Cray distribution documents define phpdist: ps:<psl.dist.hp> ! HP distribution documents define pvdist: ps:<psl.dist.vax> ! Vax distribution define pd: ps:<psl.doc> ! Other documentation define p20d: ps:<psl.doc.20> ! Dec-20 Documentation define p68d: ps:<psl.doc.68> ! 68000 Documentation define pad: ps:<psl.doc.68.apollo> ! Apollo Documentation define phpd: ps:<psl.doc.68.hp> ! hp9836 Documentation define pwd: ps:<psl.doc.68.wicat> ! Wicat Documentation define pcrd: ps:<psl.doc.cray> ! CRAY Documentation define pndoc: ps:<psl.doc.nmode> ! NMODE Documentation define pvd: ps:<psl.doc.vax> ! Vax Documentation define pe: ps:<psl.emode> ! Emode sources and support define pg: ps:<psl.glisp> ! GLISP sources define ph: ps:<psl.help> ! Help files define pk: ps:<psl.kernel> ! Machine-independent kernel sources define p20: ps:<psl.kernel.20> ! Dec-20 kernel sources define p20e: ps:<psl.kernel.20.ext> ! Extended Dec-20 kernel sources define p68: ps:<psl.kernel.68> ! 68000 kernel sources define kapollo: ps:<psl.kernel.68.apollo> ! Apollo kernel sources define pa: ps:<psl.kernel.68.apollo> ! Apollo kernel sources define php: ps:<psl.kernel.68.hp> ! hp9836 kernel (fix name) define khp: ps:<psl.kernel.68.hp> ! Hp9836 kernel sources define kwicat: ps:<psl.kernel.68.wicat> !wicat kernel sources define pcr: ps:<psl.kernel.cray> ! CRAY kernel sources define p10x: ps:<psl.kernel.tenex> ! Tenex and KI specific kernel sources define pv: ps:<psl.kernel.vax> ! Vax kernel sources define pl: ps:<psl.lap> ! Loadable files define ple: ps:<psl.lap.ext> ! Loadable files for extended 20 define plap: ps:<psl.lap> ! Loadable files (untouched by search ! path games) define plpt: ps:<psl.lpt> ! Printable version of documentation define pm: ps:<psl.manual> ! The Psl Manual sources define pnew: ps:<psl.new> ! New versions of anything define pn: ps:<psl.nmode> ! NMODE sources define pne: ps:<psl.nmode.ext> ! Extended 20 NMODE binaries define pnb: ps:<psl.nmode.binary> ! NMODE Binaries define pnk: ps:<psl.nonkernel> ! Machine-independent non-kernel define p20nk: ps:<psl.nonkernel.20> ! Dec-20 non-kernel define pvnk: ps:<psl.nonkernel.vax> ! Vax non-kernel define pr: ps:<psl.reduce> ! Reduce files for PSL define pred: ps:<psl.reduce> ! Reduce files for PSL define psc: ps:<psl.scratch> ! Scratch area define psup: ps:<psl.support> ! Local PSL support stuff define p20sup: ps:<psl.support.20> ! Local PSL support stuff, 20 specific define pasup: ps:<psl.support.apollo> ! Local PSL support Apollo define phpsup: ps:<psl.support.hp> ! Local PSL support HP define pvsup: ps:<psl.support.vax> ! Local PSL support stuff, Vax spcific define pt: ps:<psl.tests> ! Test directory define p20t: ps:<psl.tests.20> ! 20 sub-case define phpt: ps:<psl.tests.hp> ! hp sub-case define pvt: ps:<psl.test.vax> ! vax sub-case define ptr: ps:<psl.trash> ! Trash to be backed up and discarded. define putah: ps:<psl.utah> ! Utah specific files. define pu: ps:<psl.util> ! Machine-independent utility programs define p20u: ps:<psl.util.20> ! Dec-20 utility program sources define p20eu: ps:<psl.util.20.ext> ! Extended Dec-20 utility program srcs define phpu: ps:<psl.util.hp> ! HP utility program sources define pvu: ps:<psl.util.vax> ! Vax utility program sources define pw: ps:<psl.windows> ! WINDOW PACKAGE sources define pwb: ps:<psl.windows.binary> ! WINDOW PACKAGE binaries ; A few others to make things nice define pi: pk: take |
Added psl-1983/x-psl/news-28-aug-82.txt version [01c69b30f9].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 30-Jul-82 17:06:17-PDT,2293;000000000001 Date: 30 Jul 1982 1706-PDT From: Alan Snyder <AS> Subject: NEW EMODE To: PSL-News: ;, PSL-Users: ; cc: AS ------------------------------ EMODE Changes ------------------------------ A new PSL has been installed with the following changes made to EMODE: 1. C-X C-R (Read File) now replaces the contents of the current buffer with the contents of the file, instead of inserting the contents of the file at the current location in the buffer. This is an INCOMPATIBLE change. (If you want to insert a file, you can first read it into an auxiliary buffer.) 2. File INPUT and OUTPUT have been speeded up greatly (by a factor of 5). Still noticably slower than EMACS, however. 3. Three bugs in file I/O have been fixed: (a) EMODE no longer treats a ^Z in a file as an end-of-file mark; (b) EMODE will no longer lose the last line of a file should it lack a terminating CRLF; (c) EMODE no longer appends a spurious blank line when writing to a file. 4. Many more EMACS commands have been implemented (see list below). Please note that Lisp Indentation (available using TAB, LineFeed, and C-M-Q) makes many bad choices. These deficiencies are known, but it was decided that in this case something was better than nothing. Complaints about indentation are considered redundant. Send bug reports to "PSL@Hulk". New EMODE commands: C-Q (Quoted Insert) M-\ (Delete Horizontal Space) C-X C-O (Delete Blank Lines) M-M and C-M-M (Back to Indentation) M-^ (Delete Indentation) M-@ (Mark Word) C-X H (Mark Whole Buffer) C-M-@ (Mark Sexp) Tab (Indent for Lisp) LineFeed (Indent New Line) C-M-U (Backward Up List) [ should also be C-M-( ] C-M-O (Forward Up List) [ should be C-M-) ] C-M-A and C-M-[ (Beginning of Defun) C-M-D (Down List) C-M-E and C-M-] (End of Defun) C-M-H (Mark Defun) C-M-N (Next List) C-M-P (Previous List) C-M-Q (Indent Sexp) M-( (Insert Parens) M-) (Move over Paren) ------------------------------------------------------------------------------- ------- 10-Aug-82 17:02:41-PDT,1652;000000000001 Date: 10 Aug 1982 1702-PDT From: Cris Perdue <Perdue> Subject: Latest, hottest PSL news To: PSL-News: ;, PSL-Users: ; PSL NEWS FLASH!! -- August 10, 1982 CATCH An implementation of CATCH with "correct" semantics is on its way. Eric Benson has an implementation that allows code for the body of the CATCH to be compiled in line. Variables used free inside the body will not have to be declared fluid. Unhandled exceptions will, unfortunately, continue to result in abort to the top level. BUG FIXES Be sure to peruse PSL:BUGS.TXT. In addition to an invaluable compilation of commentary, bug reports and just plain flaming, this file contains reports of some fixes to bugs! TOKEN SCANNER FOUND WANTING The current PSL token scanner has been tried in the balance and found wanting. Eric Benson says it was ripped off from some other token scanner in rather a hurry and needs to be replaced. PACKAGE SYSTEM ALSO FOUND WANTING Sources close to Doug Lanam report that the PSL "package system" is not adequate. We asked Martin Griss, "What about the package system?". He admitted the inadequacy, calling the package system "experimental" and saying that the fasloader needs to know about packages. EMODE IMPROVED AND DOCUMENTED Some improvements to EMODE are described in the key documentation file PSL:HP-PSL.IBM (and .LPT). Enhancements continue at a rapid pace, leading one experienced observer to comment, "Looks like Alan has really been tearing into EMODE -- impressive!". The file PE:DISPATCH.DOC contains some key information on customization of EMODE. More reports to come. ------- 16-Aug-82 09:59:32-PDT,520;000000000001 Date: 16 Aug 1982 0959-PDT From: Alan Snyder <AS> Subject: New PSL To: PSL-News: ;, PSL-Users: ; cc: AS A new version of "NPSL" has been installed with the following changes: * EMODE now uses clear-EOL for faster redisplay. * EMODE's start-up glitches have been removed. EMODE will now start up in 1-window mode. * A "compile" command has been added; you can now say "PSL compile foo" to EXEC to compile the file "foo.sl". (This feature has been added to both PSL and NPSL.) ------- |
Added psl-1983/x-psl/news.txt version [5537baf101].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | 28-Sep-82 17:50:20-PDT,3097;000000000000 Date: 28 Sep 1982 1750-PDT From: Alan Snyder <AS> Subject: new PSL!!!! To: PSL-News: ;, PSL-Users: ; cc: AS Important Change to PSL! We have installed a new version of PSL on HULK. It contains a number of significant changes which are described here. In addition, you must change your LOGIN.CMD file to TAKE PSL:LOGICAL-NAMES.CMD instead of <PSL>LOGICAL-NAMES.CMD. The <PSL> directory will disappear soon, so make this change right away! [These changes, except for NMODE, will appear on THOR and HEWEY shortly. There are no immediate plans to move NMODE to the Vax.] Summary of changes: * If you run "PSL", you will now get a PSL that contains the NMODE editor, which is a replacement for EMODE. PSL will start up in the editor, instead of the PSL listen loop. You can easily get back to the PSL listen loop from NMODE by typing C-] L. NMODE is a decent subset of EMACS, so if you are familiar with EMACS you should be able to use NMODE without too much difficulty. If you are familiar with EMODE, you should read the file PSL:NMODE-GUIDE.TXT, which explains the differences between NMODE and EMODE. A printed copy of this memo, including the NMODE command chart, is available in the documentation area next to Helen Asakawa's office. * The "PSL" program (what you get when you say "PSL" to EXEC) no longer contains the PSL compiler. Instead, there is a separate program for compiling (Lisp) files. To compile a file "FOO.SL", give the command "PSLCOMP FOO" to EXEC. PSLCOMP will produce a binary file "FOO.B" that can then be LOADed or FASLINed. To run the compiler interactively, just say "PSLCOMP" to EXEC. * The PSL directories that contain the source and binaries for all PSL modules have been moved to a private structure called SS: (the directories are now SS:<PSL*>). The old PSL directories (PS:<PSL*>) will disappear soon. In addition, the new directories have been reorganized somewhat to better reflect the structure of the implementation. The file PSL:-THIS-.DIRECTORY contains a brief description of the new structure. If you have used logical names to refer to PSL directories, then this change should not cause too many problems. * A number of small bug fixes and improvements have been made. The most notable improvements are (1) a more readable backtrace, (2) a better prettyprinter, and (3) the definition of a "complete" set of I/O functions taking an explicit channel argument (these functions all have names like ChannelTerpri, where Terpri is an example of an I/O function that uses the default I/O channels). The file PSL:BUG-FIX.LOG contains an exhaustive listing of the recent changes. The documentation has been updated to reflect these changes. The following new or revised documents are available in the documentation area next to Helen Asakawa's office: Notes on PSL at HP DEC-20 PSL New Users' Guide NMODE for EMODE Users How to customize NMODE We have made "documentation packets" containing copies of these documents. Users are encouraged to pick up a copy! ------- 11-Oct-82 15:55:41-PDT,5771;000000000000 Date: 11 Oct 1982 1555-PDT From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; cc: AS PSL NEWS - 11 October 1982 A new PSL has been installed on Hulk and Hewey. There are a number of improvements, plus some INCOMPATIBLE changes (see below). A most noticable change (on Hulk) is that PSL no longer automatically starts up in the NMODE editor. However, if you want PSL to start up in the editor, you can still make this happen using another new feature, INIT files (see below). Otherwise, you can explicitly enter NMODE by invoking the function NMODE, with no arguments. In addtion, NMODE now supports the extended VT52 emulator on the 9836 (get the latest version from Tracy). (No, NMODE is not yet installed on Hewey.) ------------------------------------------------------------------------------- INCOMPATIBLE CHANGES TO PSL: ------------------------------------------------------------------------------- This latest version of PSL has 3 changes which may require some application programs to be changed: 1. SAVESYSTEM SaveSystem now takes 3 arguments. The first argument is the banner, the second is the file to be written, and the third is a list of forms to evaluated when the new core image is started. For example: (SaveSystem "PSL 3.1" "PSL.EXE" '((InitializeInterrupts))) 2. DUMPLISP Dumplisp now takes 1 argument, the file to be written. For example: (Dumplisp "PSL.EXE") 3. DSKIN Dskin has been changed from a FEXPR to a single-argument EXPR. This should only affect calls to DSKIN with multiple arguments. They will have to be changed to several calls, each with one argument. 4. BR and UNBR The functions BR and UNBR are no longer part of PSL. These functions provided a facility for breaking on entry and exit to specific functions. However, they didn't work very well and no one has figured out how to make them work, so they have been removed. Send complaints to PSL. ------------------------------------------------------------------------------- MAJOR IMPROVEMENTS TO PSL: ------------------------------------------------------------------------------- The following features have been added to PSL: 1. Init files When PSL, RLISP, or PSLCOMP (note: not BARE-PSL) is executed, if a file PSL.INIT, RLISP.INIT, or PSLCOMP.INIT, respectively, is in your home (login) directory, it will be read and evaluated. This allows you to automatically customize your Lisp environment. (The init files are .pslrc, .rlisprc, and .pslcomprc on the Vax.) If you want PSL to come up in NMODE, include the statement (setf nmode-auto-start T) in your PSL.INIT file. 2. Prinlevel and Prinlength The variables PRINLEVEL and PRINLENGTH now exist, as described in the Common Lisp Reference Manual. These variables allow you to limit the depth of printing of nested structures and the number of elements of structured objects printed. These variables affect Prin1 and Prin2 (Princ) and those functions that use them (Printf, Print). They do not currently affect Prettyprint, although this may be done in the future. The Printx function now properly handles circular vectors. ------------------------------------------------------------------------------- CHANGES TO NMODE: ------------------------------------------------------------------------------- * NMODE also supports init files (this isn't new, but wasn't stressed in previous documentation). When NMODE starts up, it will read and execute the file NMODE.INIT in the user's home (login) directory. This file should contain PSL (Lisp) forms. * NMODE now reads a default init file if the user has no personal init file. The name of this default init file is "PSL:NMODE.INIT". If you make your own NMODE.INIT file, you should consider including in it the statement "(nmode-read-and-evaluate-file nmode-default-init-file-name)", which will execute the default init file. * NMODE now supports the 9836 VT52 emulator (which has recently been extended to accept commands to change the display enhancement). The default NMODE init file will set up the NMODE VT52 driver if the system terminal type is VT52. * NMODE no longer always starts up in the editor after it is RESET, ABORTed, or ^C'ed and STARTed. It will only restart in the editor if it was in the editor beforehand. * NMODE will now read and write files containing stray CRs. * M-X command completion is more like EMACS. * Typing an undefined command now tells you what command you typed. * New commands: C-X C-L (Lowercase Region) C-X C-U (Uppercase Region) C-X E (Exchange Windows) C-X ^ (Grow Window) M-' (Upcase Digit) M-C (Uppercase Initial) M-L (Lowercase Word) M-U (Uppercase Word) M-X Append to File M-X DIRED M-X Delete File M-X Delete and Expunge File M-X Edit Directory M-X Find File M-X Insert Buffer M-X Insert File M-X Kill Buffer M-X Kill File M-X List Buffers M-X Prepend to File M-X Query Replace M-X Replace String M-X Save All Files M-X Select Buffer M-X Undelete File M-X Visit File M-X Write File M-X Write Region (Case conversion commands contributed by Jeff Soreff) * Some bugs relating to improper window adjustment have been fixed. For example, when the bottom window "pops up", the top window will now be adjusted. Also, C-X O now works properly in 1-window mode when the two windows refer to the same buffer (i.e., it switches between two independent buffer positions). * Bug fix: It should no longer be possible to find a "killed" buffer in a previously unexposed window. ------- 9-Nov-82 08:17:56-PST,4505;000000000000 Date: 9 Nov 1982 0817-PST From: Alan Snyder <AS> Subject: new PSL installed To: PSL-News: ;, PSL-Users: ; A new version of PSL has been installed on Hulk. Here are the details: New PSL Changes (9 November 1982) ---- PSL Changes ------------------------------------------------------------- * The major change in PSL is that CATCH/THROW has been reimplemented to conform to the Common Lisp definition (see Section 7.10 of the Common Lisp manual). In particular, CATCH has been changed to a special form so that its second argument is evaluated only once, instead of twice. THIS IS AN INCOMPATIBLE CHANGE: if you use CATCH, you must change your programs. For example, if you wrote: (catch 'foo (list 'frobnicate x y z)) you should change it to: (catch 'foo (frobnicate x y z)) One aspect of this change is that an "unhandled" throw is now reported as an error in the context of the throw, rather than (as before) aborting to top-level and restarting the job. Also implemented are UNWIND-PROTECT, CATCH-ALL, and UNWIND-ALL, as described in the Common Lisp manual, with the exception that the catch-function in CATCH-ALL and UNWIND-ALL should expect exactly 2 arguments. Note that in Common Lisp, the proper way to catch any throw is to use CATCH-ALL, not CATCH with a tag of NIL. * A related change is that the RESET function is now implemented by THROWing 'RESET, which is caught at the top-level. Thus, UNWIND-PROTECTs cannot be circumvented by RESET. ---- NMODE Changes ----------------------------------------------------------- New Features: * C-X C-B now enters a DIRED-like "Buffer Browser" that allows you to select a buffer, delete buffers, etc. * DIRED and the Buffer Browser can now operate in a split-screen mode, where the upper window is used for displaying the buffer/file list and the bottom window is used to examine a particular buffer/file. This mode is enabled by setting the variable BROWSER-SPLIT-SCREEN to T. If this variable is NIL, then DIRED and the Buffer Browser will automatically start up in one window mode. * M-X Apropos has been implemented. It will show you all commands whose corresponding function names contain a given string. Thus, if you enter "window", you will see all commands whose names include the string "window", such as "ONE-WINDOW-COMMAND". * M-X Auto Fill Mode has been implemented by Jeff Soreff, along with C-X . (Set Fill Prefix) and C-X F (Set Fill Column). If you want NMODE to start up in Auto Fill mode, put the following in your NMODE.INIT file: (activate-minor-mode auto-fill-mode) * NMODE now attempts to display a message whenever PSL is garbage-collecting. This feature is not 100% reliable: sometimes a garbage collect will happen and no message will be displayed. Minor Improvements: * C-N now extends the buffer (like EMACS) if typed without a command argument while on the last line of the buffer. * Lisp break handling has been made more robust. In particular, NMODE now ensures that IN* and OUT* are set to reasonable values. * The OUTPUT buffer now starts out with the "modified" attribute ("*") off. * The implementation of command prefix characters (i.e., C-X, M-X, C-], and Escape) and command arguments (i.e., C-U, etc.) has changed. The most visible changes are that C-U, etc. echo differently, and that Escape can now be followed by bit-prefix characters. (In other words, NMODE will recognize "Escape ^\ E" as Esc-M-E, rather than "Esc-C-\ E"; the 9836 terminal emulator has been modified to generate such escape sequences under some circumstances.) NMODE customizers may be interested to know that all of these previously-magic characters can now be redefined (on a per-mode basis, even), just like any other character. * If you are at or near the end of the buffer, NMODE will put the current line closer to the bottom of the screen when it adjusts the window. * C-X C-F (Find File) and the Dired 'E' command will no longer "find" an incorrect version of the specified file, should one happen to already be in a buffer. * The 'C' (continue) command to the PSL break loop now works again. * The "NMODE" indicator on the current window's mode line no longer disappears when the user is entering string input. * The command C-X 4 F (Find File in Other Window) now sets the buffer's file name properly. ------- 6-Dec-82 18:41:19-PST,1969;000000000000 Date: 6 Dec 1982 1841-PST From: Cris Perdue <Perdue> Subject: LOADable modules, and HELP for them To: PSL-News: ;, PSL-Users: ; NEW PACKAGES: Some relatively new packages have been made available by various people here. These belong in PU: (loadable utilities) at some point, but for now they are all on PNEW:, both the source code and the object code. See below for an explanation of PNEW:. Documentation for each of these is either in the source file or in PH:<file>.DOC, which has been greatly cleaned up. HASH.SL HISTORY.SL IF.SL MAN.SL NEWPP.SL STRING-INPUT.SL STRING-SEARCH.SL TIME-FNC.SL DOCUMENTATION ON PH: (the HELP directory): PH: has been greatly cleaned up. It should now be reasonable to browse through PH: for information on packages not described in the PSL reference manual. TO THE USERS: These files are intended to be IMPORTed or LOADed. If you wish to use modules from PNEW:, you must put PNEW: into your definition of the "logical device" PL:. The command "INFO LOGICAL PL:" to the EXEC will tell you what the current definition of PL: is. Put a line of the form: "DEFINE PL: <directory>,<directory>, ..., PNEW:" into your LOGIN.CMD file, including the same directories that are given when you ask the EXEC, with PNEW: added at the end as shown. GETTING MOST RECENT VERSIONS OF MODULES: PNEW: also contains the object files for new versions of existing modules where the latest version is more recent than the latest "release" of PSL. In particular, where PSL.EXE includes the module preloaded in it, PSL.EXE will not include the version in PNEW:. If you want the latest version when you LOAD or IMPORT, put PNEW: at the front of the list defining PL:. TO THE IMPLEMENTORS: If one of these is your product and you feel it is well tried and no longer experimental, please send a note to Nancy K. asking her to move the source to PU: and the object file to PL:. ------- 4-Jan-83 14:37:11-PST,1577;000000000000 Date: 4 Jan 1983 1437-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; FILES THAT DESCRIBE OTHER FILES If you need to look at the PSL directories on HULK or find something in those directories, look for files with names that start with "-", such as -THIS-.DIRECTORY or -FILE-NOTES.TXT. These files appear at the beginning of an ordinary directory listing and they describe the directory they are in, plus the files and/or subdirectories of that directory. PSL directories likely to be of interest to users are: PSL: (PSL root directory), PU: (source code for libraries), PNEW: (place to keep revisions of source files), PH: (help files and documentation for libraries). LIBRARY MODULES NOW LISTED PU: is the repository for the source code of library modules, generally contributed by users. The file PU:-FILE-NOTES.TXT contains a listing of available library modules, in most cases with a one-line description of each module. Please look here for interesting utilities. If no documentation appears to exist, bug the author of the module, also listed. (Documentation may appear in PH: or in the source file itself on PU:.) SAVESYSTEM The function SAVESYSTEM, which used to take one argument, now takes three arguments. The first is the banner, the second is the file to be written, and the third is a list of forms to be evaluated when the new core image is started. PSL.TAGS For those of you who browse through PSL source code, the file PSL.TAGS moved to p20sup: from psl:. ------- 11-Jan-83 13:09:13-PST,1516;000000000000 Date: 11 Jan 1983 1309-PST From: Cris Perdue <Perdue> Subject: PSL NEWS To: PSL-News: ;, PSL-Users: ; When compiled code calls a function that is undefined, the error is now continuable. If the error is continued, the function call is repeated. The function EXITLISP is now available in DEC-20 PSL, where it is currently a synonym for QUIT. Both functions cause PSL to return to a command interpreter. If the operating system permits a choice, QUIT is a continuable exit, and EXITLISP is a permanent exit (that terminates the PSL process). The functions LPOSN and CHANNELLPOSN now exist. These return a meaningful value for channels that are open for output, giving the number of the current line within the current output page. To be precise, the value is the number of newlines output since the most recent formfeed. People have been using the undocumented STRING-CONCAT function. This function is NOT actually compatible with Common LISP. It should be used as a function that applies only to string arguments, and is otherwise like CONCAT. Various bugs have been fixed, notably in the compiler and debugging facilities. A new directory of possible interest is PSYS:. This contains executable files. Executables already documented as being on PSL: will stay there for some time, but new ones are on PSYS:. DOCUMENTATION The reference manual has been significantly revised and a new version will be made available to all PSL users within a week or two. ------- 11-Jan-83 13:20:09-PST,4950;000000000000 Date: 11 Jan 1983 1319-PST From: Alan Snyder <AS> Subject: NMODE news To: PSL-News: ;, PSL-Users: ; cc: AS NMODE changes (10-Nov-1982 through 5-Jan-1983): * Bug fix: In the previous version of NMODE, digits and hyphen would insert themselves in the buffer even in "read-only" modes like Dired. They now act to specify command arguments in those modes. * Bug fix: control characters are now displayed properly in the message lines at the bottom of the screen. * Some bugs in auto fill mode have been fixed. * C-S and C-R now get you an incremental search, very much like that in EMACS. [Incremental search was implemented by Jeff Soreff.] * The window scrolling commands have been changed to ring the bell if no actual scrolling takes place (because you are already at the end of the buffer, etc.). In addition, some bugs in the scroll-by-pages commands have been fixed: (1) Previously, a request to scroll by too many pages was ignored; now it will scroll by as many pages as possible. (2) Previously, a backwards scroll near the beginning of the buffer could fail to leave the cursor in the same relative position on the screen. * A number of changes have been made that improve the efficiency of refresh, input completion (on buffer names and M-X command names), and Lisp I/O to and from buffers (Lisp-E). * Jeff Soreff has implemented the following commands: M-A (Backward Sentence) M-E (Forward Sentence) M-K (Kill Sentence) C-X Rubout (Backward Kill Sentence) M-[ (Backward Paragraph) M-] (Forward Paragraph) M-H (Mark Paragraph) M-Q (Fill Paragraph) M-G (Fill Region) M-Z (Fill Comment) M-S (Center Line) C-X = and C-= (What Cursor Position) These are basically the same as EMACS, except for M-Z, which is new. M-Z (Fill Comment) is like M-Q (Fill Paragraph), except that it first scans the beginning of the current line for a likely prefix and temporarily sets the fill prefix to that string. The prefix is determined to be any string of indentation, followed by zero or more non-alphanumeric, non-blank characters, followed by any indentation. The Fill Prefix works somewhat better than EMACS: lines not containing the fill prefix delimit paragraphs. * New EMACS commands implemented: C-M-\ (Indent Region) (for both Text and Lisp modes) C-M-C (inserts a ^C) * Defined C-? same as M-?, C-( same as C-M-(, C-) same as C-M-), for the convenience of 9836 users. * The following commands have been enhanced to obey the C-U argument as in EMACS: C-Y (Insert Kill Buffer) M-Y (Unkill Previous) M-^ (Delete Indentation) C-M-(, C-M-U, and C-( (Backward Up List) C-M-) and C-) (Forward Up List) C-M-N (Move Forward List) C-M-P (Move Backward List) C-M-A and C-M-[ (Move Backward Defun) C-M-E and C-M-] (End of Defun) * The C-X = command has been extended: if you give it a numeric argument, it will go to the specified line number. * NMODE's Lisp parsing has been vastly improved. It now recognizes the following: lists, vectors, comments, #/ character constants, string literals, ! as the escape character, and prefixes (including quote, backquote, comma, comma-atsign, and #-quote). The only restriction is that parsing is always done from the beginning of the line; thus newline cannot appear in string literals or be quoted in any way. * NMODE's Lisp indenting has also been improved. It now recognizes special cases of indenting under functional forms, and indents to match the leftmost (rather than the rightmost) of a sequence of forms on a line. It also knows about prefixes, like quote. * Inserting a right bracket in Lisp mode now displays the matching bracket, just as inserting a right paren does. * Inserting a right paren (or right bracket) now will avoid trying to display the "matching" left paren (or left bracket) when inside a comment, etc. * Changed multi-line Lisp indenting commands to avoid indenting (in fact, remove any indentation from) blank lines. * The indenting commands now avoid modifying the buffer if the indentation remains unchanged. * When a command (such as C-X K) asks for the name of an existing buffer, CR will now complete the name, if possible, and terminate if the name uniquely specifies one existing buffer. This behavior is more similar to EMACS than the previous behavior, where CR did no completion. * String input is now confirmed by moving the cursor to the beginning of the input line. ------- 11-Jan-83 17:19:31-PST,1032;000000000001 Date: 11 Jan 1983 1719-PST From: Cris Perdue <Perdue> Subject: More PSL News To: PSL-News: ;, PSL-Users: ; The behavior of LOAD has been modified so it is possible to use LOAD to load in ".SL" files. As in the past, LOAD searches in two places for a file to load: first in the connected directory (DSK: for the DEC-20 cognoscenti), then on PL: (or the equivalent on other machines). On each of these directories it searches through a list of file extensions (.b, .lap, and .sl) for a file with the right name and that extension. Thus LOAD looks first for <file>.b, then <file>.lap, then <file>.sl, then pl:<file>.b, then pl:<file>.lap, finally pl:<file>.sl. Until the latest version of PSL, LOAD would only search for .b and .lap files. The extended behavior should help people who often do not compile files. The main thing to remember is to either keep any .b file in the same directory with the .sl, or else make sure that the .b file's directory is searched before the .sl file's directory. ------- 19-Jan-83 18:28:27-PST,1437;000000000003 Date: 19 Jan 1983 1826-PST From: PERDUE at HP-HULK Subject: PSL News Update To: psl-news LOADing files The LOAD function uses two lists in searching for a file to actually load. The lists are: loaddirectories* This initially has the value: ("" "pl:"). It is a list of strings which indicate the directory to look in. Directories are searched in order of the list. loadextensions* This initially has the value: ((".b" . FASLIN) (".lap" . LAPIN) (".sl" . LAPIN)). It is an association list. Each element is a pair whose CAR is a string representing a file extension and whose CDR is a function to apply to LOAD a file of this extension. Within each directory of loaddirectories*, the members of loadextensions* are used in order in searching for a file to load. NOTES: The value of loadextensions* has recently changed. Removal of the last element of loadextensions* will restore the old behavior. Do not expect the exact strings that appear in these lists to remain identical across machines or across time, but it is reasonable to believe that the lists and their use will be stable for some time. DEBUGGING: BR and UNBR BR and UNBR were removed from the PSL system some time ago. To satisfy their devotees, they have been resurrected in a library named BR-UNBR. A bug has also been fixed and very soon the system library file will have the fix (if in a hurry see pnew:). ------- 24-Jan-83 09:42:10-PST,703;000000000000 Date: 21 Jan 1983 1909-PST From: PERDUE at HP-HULK Subject: Documentation directories To: psl-news The PSL documentation directory "pd:" has been cleaned up and there are now also machine-dependent directories p20d:, pvd:, phpd:, and pad: (Apollo). No great news of yet concerning the contents of these directories, though they do contain some rather new documents in source and final form. Note that some of these logical names are new, and there are some other new logical names as well: the group based on the root name "pdist" has been filled out, and the group based on the name "psup:" has also been filled out with a couple of new directories and their logical names. ------- 9-Feb-83 13:22:20-PST,4442;000000000000 Date: 9 Feb 1983 1317-PST From: AS at HP-HULK Subject: NMODE changes To: psl-news The following recent changes are available in PSL:NMODE.EXE on Hulk, and on the 9836 (except for Dired). Recent NMODE changes (20-Jan-1983 through 9-Feb-1983): Changes: * The Buffer Browser (C-X C-B) has changed in a number of ways. It has three new commands: F Saves the buffer in a file, if there are unsaved changes. M-~ Turns off the buffer-modified flag. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,F,N, and M-~ all obey a numeric argument of either sign. The Buffer Browser now starts up pointing at the previously-current buffer. After performing a sort command, the cursor now continues to point at the same buffer. * DIRED (the File browser) has been changed in a number of ways. One SIGNIFICANT INCOMPATIBLE change is that the K and C-K commands now delete the file immediately and remove the file from the display (instead of just marking them for later deletion). In addition, there are two new commands: I (Ignore File) Removes the file from the display list, without any effect on the actual file. N Restores all Ignored files to the display list. In addition, Backspace has been made equivalent to Rubout. Also, the commands D,U,K,I,Rubout,Backspace,and N all obey a numeric argument of either sign. The sort-by-filename procedure has been changed to sort version numbers in numerical, rather than lexicographic order. When Dired starts, the files are sorted using this procedure, instead of leaving them in the order returned by the file system. After performing a sort command, the cursor now continues to point at the same file. Dired will now automatically kill any buffer it had created for viewing a file as soon as you view a new file or exit Dired, unless the buffer contains unsaved changes. * M-X Insert File now takes as its default the file name used in the previous M-X Insert File command. This behavior matches EMACS. * Lisp-E (and Lisp-D, a new command) now insert a free EOL at the end of the buffer, if needed, whenever the buffer-modified flag is set. Previously the free EOL was inserted only when the current position was at the end of the buffer, regardless of the state of the buffer-modified flag. New commands: M-X Count Occurrences (aka M-X How Many) M-X Delete Matching Lines (aka M-X Flush Lines) M-X Delete Non-Matching Lines (aka M-X Keep Lines) M-X Insert Date (not on 9836 yet) M-X Kill Some Buffers M-X Rename Buffer M-X Revert File M-X Set Key M-X Set Visited Filename Lisp-D (in Lisp mode) executes the current defun (if the current position is within a defun) or executes from the current position (otherwise). Improvements: * NMODE now checks the system's terminal type every time it is restarted. This change allows you to use an NMODE that was detached from one kind of terminal and later attached on another kind of terminal. * Fixed bug in Dec-20 version: Find File could leave around an empty file if you tried to find a nonexistent file in a directory that allows you to create new files but whose default file protection does not allow you to delete them. (On the Dec-20, Find File determines the name of a new file by writing an empty file and immediately deleting it.) * A soft-key feature has been added, intended primarily for use on the 9836. The command Esc-/ will read a soft-key designator (a single character in the range '0' to 'W') and execute the definition of the corresponding softkey (numbered 0 through 39). Softkeys are defined using the function (nmode-define-softkey n fcn label-string), where n is the softkey number and fcn is either NIL (for undefined), a function ID (which will be invoked), or a string (which will be executed as if typed at the keyboard). NMODE on the 9836 sets up the keyboard so that the function keys K0 through K9 send an appropriate Esc-/ sequence (using shift and control as modifiers). * The two message/prompt lines at the bottom of the screen are now sometimes updated independently of the rest of the screen. This change makes writing messages and prompts more efficient. ------- 25-Feb-83 11:03:02-PST,2247;000000000000 Date: 25 Feb 1983 1059-PST From: AS at HP-HULK Subject: recent NMODE changes To: psl-news Recent NMODE changes (14-Feb-1983 through 24-Feb-1983): Bugs fixed: * Dired wasn't garbage collecting old buffers used to view files, as had been intended. * M-Z would enter an infinite loop on a paragraph at the end of the buffer whose last line had no terminating Newline character. * When filling with a fill prefix, the cursor would sometimes be placed improperly. * M-X Rename Buffer didn't convert the new buffer name to upper case. * The Permanent Goal Column feature (Set by C-X C-N) didn't work. * The incremental search commands did not handle bit-prefix characters (e.g., the Meta prefix) properly. Typing a bit-prefix character would terminate the search, but then the bit-prefix character would not be recognized as such. * When executing Lisp from the OUTPUT buffer in one-window mode, the window would not be adjusted if the other (unexposed) window also was attached to the OUTPUT buffer. * The cursor was being positioned improperly when the window was scrolled horizontally. Performance Improvements: * The efficiency of Lisp printing to the OUTPUT buffer has been improved significantly through the use of internal buffering. One visible change is that the screen is updated only after an entire line is written. * Insertion into text buffers has been speeded up by eliminating some unnecessary string consing that occurred when inserting at the beginning or end of a line (which is very common). EMACS Compatibility Enhancements: * M-X Set Visited Filename now converts the new name to the true name of the file, if possible. * M-X Rename Buffer now checks for attempts to use the name of an existing buffer. * Query-Replace now terminates when you type a character that is not a query-replace command and rereads that character. * C-M-D has been extended to obey the command argument (either positive or negative). It still differs from the EMACS C-M-D command in that it always stays within the current enclosing list. * M-( has been extended to obey the command argument. * The M-) command (Move Over Paren) has been implemented. ------- 18-Mar-83 16:29:39-PST,6873;000000000000 Date: 18 Mar 1983 1626-PST From: AS at HP-HULK Subject: recent NMODE changes To: psl-news cc: AS Recent NMODE changes (28-Feb-1983 through 16-Mar-1983): (Not all of these changes have been installed on all systems.) Bugs Fixed: * NMODE will now refresh the display and clear the message line when it is interrupted and restarted. * The C-X D command would list the connected directory, rather than the directory of the current file, if the current file name contained a device specification but no directory specification (e.g., "FOO:BAR.TXT"). * The 9836 color screen driver would crash if it tried to display a buffer containing characters with integer values greater than 127. * The command to write the contents of the current screen to a file would always write the main screen, even when NMODE was using multiple screens. * NMODE would crash if it encountered a file (on the 9836) with an "invalid" file name (e.g., "FOO.BAR.TEXT"). Performance Improvements: * File I/O on the 9836 has been speeded up greatly. * The 9836 color screen driver has been modified to speed up refresh. * Keyboard interaction has been speeded up significantly following the discovery that certain keyboard input functions were not compiled. New Commands: * DIRED is now available on the 9836. * There is a new command, M-X List Browsers, which brings up a Browser Browser showing all existing browsers (i.e., the Buffers browser and, on the 9836, the NMODE Documentation browser), as well as all potential browsers (i.e., File Directory browsers). Potential browsers are displayed as prototype browsers. Commands are provided to view documentation on a browser (or prototype) and to enter a browser (or instantiate a prototype). * There is a new command, M-X Print Buffer, also available as C-X C-P, which prints the contents of the current buffer in a format suitable for printing devices. A file/device name is requested from the user; the default is LPT: on the Dec-20 and PRINTER: on the 9836. This command translates tabs to spaces and control characters to ^X form. Note: using C-X C-W on the 9836 to write the buffer to PRINTER: does not work. * A Browse command has been added to Dired. This command allows one to browse thru a subdirectory. * A Create command has been added to the Buffer Browser to create new buffers. A Create command has been added to Dired to create new files. Changes: * The command to write the contents of the current screen to a file has been changed from C-X P to M-X Write Screen. In addition, this command now has its own default file name. * The Buffer Browser (C-X C-B) now always displays all named buffers. Previously, it would ignore buffers whose names began with a "+", unless an argument was specified to the C-X C-B command. The use of "+" to name "internal" buffers has been replaced by the use of "unnamed" buffers. * A number of changes have been made to the common browser mechanism, which affect the behavior of all browsers (Buffers, Files, Documentation, and the Browser Browser): Browsers now use "unnamed" buffers (a new NMODE feature) to display the lists of items. This change means that browsers no longer appear in the Buffer Browser list of buffers and cannot be selected using C-X B. Instead, the Browser Browser (M-X List Browsers) can be used to display all existing browsers and to select an existing browser. The Buffer Browser and the Browser Browser now update themselves automatically under various circumstances, most notably when you enter or select them, to take account of any items created or deleted since the browser was last updated. The File Directory Browser (DIRED) does not update itself automatically, since that operation would be too time-consuming. However, it supports a new command, Look (L), which causes it to re-read the specified directory. When you attempt to create a browser, NMODE will first look for an existing browser with the desired information. If an existing browser is found, it will be reentered. As described above, the Buffers and Browser browsers update themselves automatically when they are entered. When a File Directory browser is reused, it also updates itself automatically. Quitting a browser no longer kills the browser, but merely returns the display to its previous state. This change encourages reentering existing browsers instead of unnecessarily creating new ones. It is possible to kill a browser using the Kill (K) command of the Browser Browser, if you desperately need to reclaim the space taken up by a browser. Quitting a browser now does a better job of restoring the previous screen contents. The help line at the bottom of the screen is now automatically maintained. Previously, it was displayed only when the browser was entered and would not be restored when returning to the browser from another window or buffer. The ? command (which used to refresh the help line) now displays a buffer of documentation about the browser. Browsers now do a better job of managing the screen, especially when the split-screen option is enabled. (When the split-screen option is enabled, the top window is used to display the list of items, and the bottom window is used to display a particular item. The split-screen option is enabled by including the statement (SETF BROWSER-SPLIT-SCREEN T) in your NMODE.INIT file. Split-screen will probably become the default soon.) When the split-screen option is enabled, each browser will endeavor to ensure that the bottom window displays the most-recently selected item. When there is no selected item, the browser will display documentation in the bottom window (using an "unnamed" buffer). The window label line for a browser now displays additional information about the browser. For example, the label line for a File Directory Browser displays the name of the directory. In addition, the label line for a browser documentation buffer displays a descriptive sentence. * A number of incompatible changes have been made to the common browser mechanism to support the above changes. If you have written your own browser using these mechanisms, you should consult the sources of the standard browsers to see the kinds of changes you should make. (See Buffer-Browser.SL, Dired.SL, Doc.SL, Browser.SL, and Browser-Support.SL, all in the PN: directory.) * Another incompatible change: the function buffer-create-unselectable has been replaced by the function create-unnamed-buffer, which (as the name suggests) does not take a name-of-buffer argument. (See PN:Buffers.SL.) ------- |
Added psl-1983/x-psl/nmail.init version [48e77a0596].
> > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | % This is the default NMail.INIT file, which is run if there is no % NMail.INIT file in the user's home directory. If you make your % own NMail.INIT file, it might be a good idea to put the statement % (nmode-read-and-evaluate-file nmail-default-init-file-name) at the % beginning, which will cause this file to be executed first. % This loads the "pre-defined" filters. (add-filters-from-file "<kendzierski.mail>filter-defs.sl") (add-to-command-list 'Mail-Command-List (x-char <) 'display-filters-command) %(add-to-command-list 'Mail-Command-List % (x-char P) % 'apply-filter-command) (add-to-command-list 'Mail-Command-List (x-char >) 'remove-filters-command) (nmode-establish-current-mode) |
Added psl-1983/x-psl/nmode-chart.txt version [eea7c24a86].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE command list (Lisp mode) - 25 January 1983 -------------------------------------------------------- ) INSERT-CLOSING-BRACKET Backspace DELETE-BACKWARD-HACKING-TABS-COMMAND C-% REPLACE-STRING-COMMAND C-( BACKWARD-UP-LIST-COMMAND C-) FORWARD-UP-LIST-COMMAND C-- NEGATIVE-ARGUMENT C-0 ARGUMENT-DIGIT C-1 ARGUMENT-DIGIT C-2 ARGUMENT-DIGIT C-3 ARGUMENT-DIGIT C-4 ARGUMENT-DIGIT C-5 ARGUMENT-DIGIT C-6 ARGUMENT-DIGIT C-7 ARGUMENT-DIGIT C-8 ARGUMENT-DIGIT C-9 ARGUMENT-DIGIT C-< MARK-BEGINNING-COMMAND C-= WHAT-CURSOR-POSITION-COMMAND C-> MARK-END-COMMAND C-? HELP-DISPATCH C-@ SET-MARK-COMMAND C-A MOVE-TO-START-OF-LINE-COMMAND C-B MOVE-BACKWARD-CHARACTER-COMMAND C-D DELETE-FORWARD-CHARACTER-COMMAND C-E MOVE-TO-END-OF-LINE-COMMAND C-F MOVE-FORWARD-CHARACTER-COMMAND C-G NMODE-ABORT-COMMAND C-K KILL-LINE C-L NMODE-REFRESH-COMMAND C-M-( BACKWARD-UP-LIST-COMMAND C-M-) FORWARD-UP-LIST-COMMAND C-M-- NEGATIVE-ARGUMENT C-M-0 ARGUMENT-DIGIT C-M-1 ARGUMENT-DIGIT C-M-2 ARGUMENT-DIGIT C-M-3 ARGUMENT-DIGIT C-M-4 ARGUMENT-DIGIT C-M-5 ARGUMENT-DIGIT C-M-6 ARGUMENT-DIGIT C-M-7 ARGUMENT-DIGIT C-M-8 ARGUMENT-DIGIT C-M-9 ARGUMENT-DIGIT C-M-@ MARK-FORM-COMMAND C-M-A MOVE-BACKWARD-DEFUN-COMMAND C-M-B MOVE-BACKWARD-FORM-COMMAND C-M-Backspace MARK-DEFUN-COMMAND C-M-D DOWN-LIST C-M-E END-OF-DEFUN-COMMAND C-M-F MOVE-FORWARD-FORM-COMMAND C-M-H MARK-DEFUN-COMMAND C-M-I LISP-TAB-COMMAND C-M-K KILL-FORWARD-FORM-COMMAND C-M-L SELECT-PREVIOUS-BUFFER-COMMAND C-M-M BACK-TO-INDENTATION-COMMAND C-M-N MOVE-FORWARD-LIST-COMMAND C-M-O SPLIT-LINE-COMMAND C-M-P MOVE-BACKWARD-LIST-COMMAND C-M-Q LISP-INDENT-SEXPR C-M-R REPOSITION-WINDOW-COMMAND C-M-Return BACK-TO-INDENTATION-COMMAND C-M-Rubout KILL-BACKWARD-FORM-COMMAND C-M-T TRANSPOSE-FORMS C-M-Tab LISP-TAB-COMMAND C-M-U BACKWARD-UP-LIST-COMMAND C-M-V SCROLL-OTHER-WINDOW-COMMAND C-M-W APPEND-NEXT-KILL-COMMAND C-M-X M-X-PREFIX C-M-[ MOVE-BACKWARD-DEFUN-COMMAND C-M-\ LISP-INDENT-REGION-COMMAND C-M-] END-OF-DEFUN-COMMAND C-N MOVE-DOWN-EXTENDING-COMMAND C-O OPEN-LINE-COMMAND C-P MOVE-UP-COMMAND C-Q INSERT-NEXT-CHARACTER-COMMAND C-R REVERSE-SEARCH-COMMAND C-Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND C-S INCREMENTAL-SEARCH-COMMAND C-Space SET-MARK-COMMAND C-T TRANSPOSE-CHARACTERS-COMMAND C-U UNIVERSAL-ARGUMENT C-V NEXT-SCREEN-COMMAND C-W KILL-REGION C-X C-X-PREFIX C-X . SET-FILL-PREFIX-COMMAND C-X 1 ONE-WINDOW-COMMAND C-X 2 TWO-WINDOWS-COMMAND C-X 3 VIEW-TWO-WINDOWS-COMMAND C-X 4 VISIT-IN-OTHER-WINDOW-COMMAND C-X < SCROLL-WINDOW-LEFT-COMMAND C-X = WHAT-CURSOR-POSITION-COMMAND C-X > SCROLL-WINDOW-RIGHT-COMMAND C-X A APPEND-TO-BUFFER-COMMAND C-X B SELECT-BUFFER-COMMAND C-X C-B BUFFER-BROWSER-COMMAND C-X C-F FIND-FILE-COMMAND C-X C-L LOWERCASE-REGION-COMMAND C-X C-N SET-GOAL-COLUMN-COMMAND C-X C-O DELETE-BLANK-LINES-COMMAND C-X C-S SAVE-FILE-COMMAND C-X C-T TRANSPOSE-LINES C-X C-U UPPERCASE-REGION-COMMAND C-X C-V VISIT-FILE-COMMAND C-X C-W WRITE-FILE-COMMAND C-X C-X EXCHANGE-POINT-AND-MARK C-X C-Z NMODE-EXIT-TO-SUPERIOR C-X D DIRED-COMMAND C-X E EXCHANGE-WINDOWS-COMMAND C-X F SET-FILL-COLUMN-COMMAND C-X G GET-REGISTER-COMMAND C-X H MARK-WHOLE-BUFFER-COMMAND C-X K KILL-BUFFER-COMMAND C-X O OTHER-WINDOW-COMMAND C-X P WRITE-SCREEN-PHOTO-COMMAND C-X Rubout BACKWARD-KILL-SENTENCE-COMMAND C-X T TRANSPOSE-REGIONS C-X V NMODE-INVERT-VIDEO C-X X PUT-REGISTER-COMMAND C-X ^ GROW-WINDOW-COMMAND C-Y INSERT-KILL-BUFFER C-] LISP-PREFIX Esc-4 MOVE-BACKWARD-WORD-COMMAND Esc-5 MOVE-FORWARD-WORD-COMMAND Esc-A MOVE-UP-COMMAND Esc-B MOVE-DOWN-COMMAND Esc-C MOVE-FORWARD-CHARACTER-COMMAND Esc-D MOVE-BACKWARD-CHARACTER-COMMAND Esc-F MOVE-TO-BUFFER-END-COMMAND Esc-J NMODE-FULL-REFRESH Esc-L OPEN-LINE-COMMAND Esc-M KILL-LINE Esc-P DELETE-FORWARD-CHARACTER-COMMAND Esc-S SCROLL-WINDOW-UP-LINE-COMMAND Esc-T SCROLL-WINDOW-DOWN-LINE-COMMAND Esc-U SCROLL-WINDOW-UP-PAGE-COMMAND Esc-V SCROLL-WINDOW-DOWN-PAGE-COMMAND Esc-h MOVE-TO-BUFFER-START-COMMAND Escape ESC-PREFIX Lisp-? LISP-HELP-COMMAND Lisp-A LISP-ABORT-COMMAND Lisp-B LISP-BACKTRACE-COMMAND Lisp-C LISP-CONTINUE-COMMAND Lisp-E EXECUTE-FORM-COMMAND Lisp-L EXIT-NMODE Lisp-Q LISP-QUIT-COMMAND Lisp-R LISP-RETRY-COMMAND Lisp-Y YANK-LAST-OUTPUT-COMMAND M-% QUERY-REPLACE-COMMAND M-' UPCASE-DIGIT-COMMAND M-( INSERT-PARENS M-- NEGATIVE-ARGUMENT M-/ HELP-DISPATCH M-0 ARGUMENT-DIGIT M-1 ARGUMENT-DIGIT M-2 ARGUMENT-DIGIT M-3 ARGUMENT-DIGIT M-4 ARGUMENT-DIGIT M-5 ARGUMENT-DIGIT M-6 ARGUMENT-DIGIT M-7 ARGUMENT-DIGIT M-8 ARGUMENT-DIGIT M-9 ARGUMENT-DIGIT M-; INSERT-COMMENT-COMMAND M-< MOVE-TO-BUFFER-START-COMMAND M-> MOVE-TO-BUFFER-END-COMMAND M-? HELP-DISPATCH M-@ MARK-WORD-COMMAND M-A BACKWARD-SENTENCE-COMMAND M-B MOVE-BACKWARD-WORD-COMMAND M-Backspace MARK-DEFUN-COMMAND M-C UPPERCASE-INITIAL-COMMAND M-D KILL-FORWARD-WORD-COMMAND M-E FORWARD-SENTENCE-COMMAND M-F MOVE-FORWARD-WORD-COMMAND M-G FILL-REGION-COMMAND M-H MARK-PARAGRAPH-COMMAND M-I TAB-TO-TAB-STOP-COMMAND M-K KILL-SENTENCE-COMMAND M-L LOWERCASE-WORD-COMMAND M-M BACK-TO-INDENTATION-COMMAND M-Q FILL-PARAGRAPH-COMMAND M-R MOVE-TO-SCREEN-EDGE-COMMAND M-Return BACK-TO-INDENTATION-COMMAND M-Rubout KILL-BACKWARD-WORD-COMMAND M-S CENTER-LINE-COMMAND M-T TRANSPOSE-WORDS M-Tab TAB-TO-TAB-STOP-COMMAND M-U UPPERCASE-WORD-COMMAND M-V PREVIOUS-SCREEN-COMMAND M-W COPY-REGION M-X M-X-PREFIX M-X Append to File APPEND-TO-FILE-COMMAND M-X Apropos APROPOS-COMMAND M-X Auto Fill Mode AUTO-FILL-MODE-COMMAND M-X Count Occurrences COUNT-OCCURRENCES-COMMAND M-X DIRED EDIT-DIRECTORY-COMMAND M-X Delete File DELETE-FILE-COMMAND M-X Delete Matching Lines DELETE-MATCHING-LINES-COMMAND M-X Delete Non-Matching Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Delete and Expunge File DELETE-AND-EXPUNGE-FILE-COMMAND M-X Edit Directory EDIT-DIRECTORY-COMMAND M-X Execute Buffer EXECUTE-BUFFER-COMMAND M-X Execute File EXECUTE-FILE-COMMAND M-X Find File FIND-FILE-COMMAND M-X Flush Lines DELETE-MATCHING-LINES-COMMAND M-X How Many COUNT-OCCURRENCES-COMMAND M-X Insert Buffer INSERT-BUFFER-COMMAND M-X Insert Date INSERT-DATE-COMMAND M-X Insert File INSERT-FILE-COMMAND M-X Keep Lines DELETE-NON-MATCHING-LINES-COMMAND M-X Kill Buffer KILL-BUFFER-COMMAND M-X Kill File DELETE-FILE-COMMAND M-X Kill Some Buffers KILL-SOME-BUFFERS-COMMAND M-X Lisp Mode LISP-MODE-COMMAND M-X List Buffers BUFFER-BROWSER-COMMAND M-X Make Space NMODE-GC M-X Prepend to File PREPEND-TO-FILE-COMMAND M-X Query Replace QUERY-REPLACE-COMMAND M-X Rename Buffer RENAME-BUFFER-COMMAND M-X Replace String REPLACE-STRING-COMMAND M-X Revert File REVERT-FILE-COMMAND M-X Save All Files SAVE-ALL-FILES-COMMAND M-X Select Buffer SELECT-BUFFER-COMMAND M-X Set Key SET-KEY-COMMAND M-X Set Visited Filename SET-VISITED-FILENAME-COMMAND M-X Start Scripting START-SCRIPTING-COMMAND M-X Start Timing NMODE START-TIMING-COMMAND M-X Stop Scripting STOP-SCRIPTING-COMMAND M-X Stop Timing NMODE STOP-TIMING-COMMAND M-X Text Mode TEXT-MODE-COMMAND M-X Undelete File UNDELETE-FILE-COMMAND M-X Visit File VISIT-FILE-COMMAND M-X Write File WRITE-FILE-COMMAND M-X Write Region WRITE-REGION-COMMAND M-Y UNKILL-PREVIOUS M-Z FILL-COMMENT-COMMAND M-[ BACKWARD-PARAGRAPH-COMMAND M-\ DELETE-HORIZONTAL-SPACE-COMMAND M-] FORWARD-PARAGRAPH-COMMAND M-^ DELETE-INDENTATION-COMMAND M-~ BUFFER-NOT-MODIFIED-COMMAND Newline INDENT-NEW-LINE-COMMAND Return RETURN-COMMAND Rubout DELETE-BACKWARD-HACKING-TABS-COMMAND Tab LISP-TAB-COMMAND ] INSERT-CLOSING-BRACKET C-\ "Meta" prefix on Dec-20 C-[ (Escape) "Meta" prefix on 9836 C-^ "Control" prefix C-Z "Control-Meta" prefix |
Added psl-1983/x-psl/nmode-customizing.txt version [caf7643a39].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | How to customize NMODE Alan Snyder 24 September 1982 ------------------------------------------------------------------------------- This memo explains how to customize NMODE by redefining the effect of input keystrokes. NMODE is customized by executing Lisp forms. These forms may be executed directly within NMODE (using Lisp-E), or may be stored in an INIT file, which is read by NMODE when it first starts up. The name of the INIT file read by NMODE is "NMODE.INIT" in the user's home directory. There are three concepts that must be understood to customize NMODE: Commands, Functions, and Modes. 1) Commands. The effect of given keystroke or sequence of keystrokes in NMODE is based on a mapping between "commands" and "functions". A "command" may be either a single "extended character" or a sequence of characters. An extended character is a 9-bit character with distinct "Control" and "Meta" bits. Thus "C-M-A" is a single "extended character", even though on many terminals you have to use two keystrokes to enter it. Extended characters are specified using the macro X-CHAR, for example: (x-char A) the letter "A" (upper case) (x-char C-F) Control-F (x-char C-M-Z) Control-Meta-Z (x-char CR) Carriage-Return (x-char TAB) Tab (x-char BACKSPACE) Backspace (x-char NEWLINE) Newline (x-char RUBOUT) Rubout (x-char C-M-RUBOUT) Control-Meta-Rubout (The macros described in this section are defined in the load module EXTENDED-CHAR.) It is important to note that on most terminals, some Ascii control characters are mapped to extended "Control" characters and some aren't. Those that aren't are: Backspace, CR, Newline, Tab, and Escape. Even if you type "CNTL-I" on the keyboard, you will get "Tab" and not "Control-I". The remaining Ascii control characters are mapped to extended "Control" characters, thus typing "CNTL-A" on the keyboard gives "Control-A". As mentioned above, a command can be a sequence of characters. There are two forms: Prefix commands and Extended commands. Prefix commands: A prefix command consists of two characters, the first of which is a defined "prefix character". In NMODE, there are 3 predefined prefix characters: C-X, ESC, and C-]. Prefix commands are specified using the X-CHARS macro, for example: (x-chars C-X C-F) (x-chars ESC A) (x-chars C-] E) Extended commands: An extended command consists of the character M-X and a string. Extended commands are defined using the M-X macro, for example: (M-X "Lisp Mode") (M-X "Revert File") The case of the letters in the string is irrelevant, except to specify how the command name will be displayed when "completion" is used by the user. By convention, the first letter of each word in an extended command name is capitalized. 2) Functions. NMODE commands are implemented by PSL functions. By convention, most (but not all) PSL functions that implement NMODE commands have names ending with "-COMMAND", for example, MOVE-FORWARD-CHARACTER-COMMAND. An NMODE command function should take no arguments. The function can perform its task using a large number of existing support functions; see PN:BUFFER.SL and PN:MOVE-COMMANDS.SL for examples. A command function can determine the command argument (given by C-U) by inspecting global variables: nmode-command-argument: the numeric value (default: 1) nmode-command-argument-given: T if the user specified an argument nmode-command-number-given: T if the user typed digits in the argument See the files PN:MOVE-COMMANDS.SL, PN:LISP-COMMANDS.SL, and PN:COMMANDS.SL for many examples of NMODE command functions. 3) Modes. The mapping between commands and functions is dependent on the current "mode". Examples of existing modes are "Text Mode", which is the basic mode for text editing, "Lisp Mode", which is an extension of "Text Mode" for editing and executing Lisp code, and "Dired Mode", which is a specialized mode for the Directory Editor Subsystem. A mode is defined by a list of Lisp forms which are evaluated to determine the state of a Dispatch Table. The Dispatch Table is what is actually used to map from commands to functions. Every time the user selects a new buffer, the Dispatch Table is cleared and the Lisp forms defining the mode for the new buffer are evaluated to fill the Dispatch Table. The forms are evaluated in reverse order, so that the first form is evaluated last. Thus, any command definitions made by one form supercede those made by forms appearing after it in the list. Two functions are commonly invoked by mode-defining forms: NMODE-ESTABLISH-MODE and NMODE-DEFINE-COMMANDS. NMODE-ESTABLISH-MODE takes one argument, a list of mode defining forms, and evaluates those forms. Thus, NMODE-ESTABLISH-MODE can be used to define one mode in terms of (as an extension of or a modification to) another mode. NMODE-DEFINE-COMMANDS takes one argument, a list of pairs, where each pair consists of a COMMAND and a FUNCTION. This form of list is called a "command list". Command lists are not used directly to map from commands to functions. Instead, NMODE-DEFINE-COMMANDS reads the command list it is given and for each COMMAND-FUNCTION pair in the command list (in order), it alters the Dispatch Table to map the specified COMMAND to the corresponding FUNCTION. Note that as a convenience, whenever you define an "upper case" command, the corresponding "lower case" command is also defined to map to the same function. Thus, if you define C-M-A, you automatically define C-M-a to map to the same function. If you want the lower case command to map to a different function, you must define the lower case command "after" defining the upper case command. The usual technique for modifying one or more existing modes is to modify one of the command lists given to NMODE-DEFINE-COMMANDS. The file PN:MODE-DEFS.SL contains the definition of most predefined NMODE command lists, as well as the definition of most predefined modes. To modify a mode or modes, you must alter one or more command lists by adding (or perhaps removing) entries. Command lists are manipulated using two functions: (add-to-command-list list-name command func) (remove-from-command-list list-name command) Here are some examples: (add-to-command-list 'text-command-list (x-char BACKSPACE) 'delete-backward-character-command) (add-to-command-list 'lisp-command-list (x-char BACKSPACE) 'delete-backward-hacking-tabs-command) (remove-from-command-list 'read-only-text-command-list (x-char BACKSPACE)) [The above forms change BACKSPACE from being the same as C-B to being the same as RUBOUT.] (add-to-command-list 'read-only-text-command-list (x-char M-@) 'set-mark-command) [The above form makes M-@ set the mark.] (add-to-command-list 'read-only-terminal-command-list (x-chars ESC Y) 'print-buffer-names-command) [The above form makes Esc-Y print a list of all buffer names. Esc-Y is sent by HP264X terminals when the "Display Functions" key is hit.] Note that these functions change only the command lists, not the Dispatch Table which is actually used to map from commands to functions. To cause the Dispatch Table to be updated to reflect any changes in the command lists, you must invoke the function NMODE-ESTABLISH-CURRENT-MODE. |
Added psl-1983/x-psl/nmode-emacs.txt version [4eebcfbf6a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMACS users - A quick comparison Alan Snyder (2 February 1983) -------------------------------------------------------------------------------- Introduction If you are familiar with EMACS on the Dec-20, then you should have little trouble using NMODE, since NMODE is largely compatible with EMACS. If you are using an HP terminal or the 9836 VT52 emulator, then you can use the cursor keys and other special function keys with NMODE. There are some differences between NMODE and EMACS, and these are described below. What you are most likely to find is that there are some EMACS commands that have not (yet) been implemented in NMODE; section I below lists the most significant of these. (We are not promising to implement all EMACS commands, but if there is some command you just can't live without, let us know, or volunteer to implement it yourself!) Section II describes areas of inconsistency between NMODE and EMACS; some of these are deficiencies in NMODE that may someday be fixed, others are regarded as features of NMODE, and others are just plain differences which are not likely to go away. Section III lists other known deficiencies in NMODE, many of which we hope to fix. Section IV summarizes those features of NMODE that EMACS doesn't have. -------------------------------------------------------------------------------- I. Things that EMACS has that NMODE doesn't (an incomplete list) * Auto Save * Help Character (C-_) * Many 'options' variables (NMODE has almost none) * Most Minor Modes, including: Word Abbrev Mode Auto Arg Mode Atom Word Mode Overwrite Mode Indent Tabs Mode * The Tags Package M-. (find tag) M-X Visit Tag Table M-X Tags Search * Local Modes specification in files * Syntax Table * Miscellaneous commands: C-M-G (grind form) M-= (count lines region) C-M-Z (exit recursive edit) M-Esc (Execute Minibuffer) C-X Esc (ReExecute Minibuffer) * Mail Commands: C-X M (Send Mail) C-X R (Read Mail) M-X Check Mail * Comment commands: C-; (indent for comment) C-M-; (kill comment) Return (skip trailing comment terminator) C-X ; (set comment column) M-N (down comment line) M-P (up comment line) M-J or M-Linefeed (indent new comment line) * Indentation commands: C-X Tab (indent rigidly) * Text-Processor commands: M-# (change font word) M-_ (underline word) C-X # (change font region) C-X _ (underline region) * File commands: C-X C-D (directory display) C-X C-Q (set file read only) M-X Clean Directory M-X Copy File M-X List Files M-X Reap File M-X Rename File M-X View Directory M-X View File * Page commands: C-X [ (previous page) C-X ] (next page) C-X L (count lines page) C-X C-P (mark page) M-X What Page * Many M-X commands, including: M-X Compare Windows M-X List Matching Lines M-X Occur M-X Tabify M-X Untabify M-X View Buffer * Keyboard macros C-X ( C-X ) C-X E C-X Q M-X Name Kbd Macro M-X Write Kbd Macro * Command Libraries M-X Kill Libraries M-X List Library M-X List Loaded Libraries M-X Load Library M-X Run Library * Spelling Correction (M-$) * Narrowing: C-X N (Narrow Bounds to Region) C-X P (Narrow Bounds to Page) C-X W (Widen Bounds) -------------------------------------------------------------------------------- II. Inconsistencies between NMODE and EMACS A. NMODE Features * NMODE DIRED 'E' and 'V' commands allow editing of the file. These commands do not use "recursive editing": arbitrary switching between buffers and windows is allowed; C-M-L returns to the previous buffer (not C-M-Z). * NMODE has a separate ring of marks for each buffer. * NMODE C-X C-B brings up a buffer browser, instead of just listing the buffers. * NMODE's Lisp parsing commands recognize comments, string literals, character literals, etc. For this reason, the commands C-M-N (Forward List) and C-M-P (Backward List) are not really needed, although they are presently still provided. * When the fill prefix is non-null, NMODE treats lines not beginning with the fill prefix as delimiting a paragraph (ZMACS does this, too). EMACS will treat a single preceding line without the fill prefix as the first line of the paragraph and will insert the prefix onto that line when you do M-Q. * NMODE's incremental search allows you to rubout the old search string (inserted by an immediate C-S or C-R) one character at a time, instead of all at once (like EMACS). B. NMODE Deficiencies (may be fixed someday) * NMODE Query-Replace does not alter the case of the replacement string, does not support word search, does not support recursive edit. * NMODE does not have a ring buffer of buffers; the default buffer for C-X B may be different than in EMACS. * NMODE's incremental search does not escape to a non-incremental search, does not do word searches, always ignores case. * No completion on File Name input. * NMODE doesn't set the Mode from the first line of a file. * In NMODE, M-digit does not enter autoarg mode (i.e., if you then type a digit (without Meta), the digit is inserted. * NMODE search commands never set the Mark. * NMODE lacks true read-only buffers. * NMODE's Dired does not support C, H, or N. Dired commands do not take a command argument. * NMODE's Kill Buffer commands ask for confirmation rather than offering to write out the buffer. * NMODE's C-M-Q command does not use the command argument. * NMODE's C-X H command does not use the command argument. * NMODE's M-< command does not use the command argument. * NMODE's M-> command does not use the command argument. * NMODE's C-X C-Z command does not save any files. * NMODE's M-X Make Space command does not offer to delete buffers, kill rings, etc. * NMODE's C-M-R command works only in Lisp mode (it doesn't do paragraphs). * NMODE's Return command doesn't delete blanks and tabs when moving onto a new line. * NMODE's Return command is not changed in Auto Fill mode. * NMODDE's LineFeed command is quite a bit different: (1) it doesn't delete spaces before the inserted CRLF; (2) it doesn't use the fill prefix to indent; (3) it passes the command argument to the Return command, rather than to the Tab command. * NMODE's C-X T command doesn't try to readjust the marks. * NMODE's C-X 4 command recognizes only B and F as options (not C-B or C-F). C. Just Plain Differences * NMODE customization is completely different than EMACS customization. * NMODE M-X commands always prompt for their arguments; Escape is not a terminator for the command name. * Find File in NMODE creates a buffer whose name is of the form "foo.bar", rather than "foo". * In NMODE, the various Lisp-related commands (C-M-B, etc.) are defined only in Lisp mode. * NMODE's "defun" commands don't set the mark. * C-M-L means "return to previous buffer" instead of "insert formfeed". * C-] is a prefix character (in Lisp mode) instead of meaning "abort". * C-X P means "write screen photo" instead of "narrow bounds to page". * NMODEs text filling commands compress non-leading tabs into spaces; EMACS leaves them alone. -------------------------------------------------------------------------------- III. Known deficiencies of NMODE * During prompted character input, the cursor remains in the edit window. * Printing to the OUTPUT buffer is slow. * Quitting out of NMODE to the standard break handler won't restore echoing. * NMODE does not provide a good way to interrupt a Lisp-E execution or printout. (The only way is to ^C NMODE and then START it.) * "Typeout" is clumsy. * If you type ^^x to get C-X, the prompt string is sort of strange. -------------------------------------------------------------------------------- IV. Things that NMODE has that EMACS doesn't * Miscellaneous Commands: M-Z - format comment (automatically sets the fill prefix) C-X V - toggle between normal and inverse-video C-X < - scroll window left C-X > - scroll window right C-X P - write screen photograph to file C-X E - exchange windows * Lisp Interface Commands * Buffer Browser * Split Screen option for Dired (and the Buffer Browser) * Two-Screen option (on 9836 with auxiliary color monitor) ------------------------------------------------------------------------------- |
Added psl-1983/x-psl/nmode-guide.txt version [d9690c387b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | NMODE for EMODE users Alan Snyder 28 October 1982 ------------------------------------------------------------------------------- NMODE is a new PSL text editor installed at HP. This note describes the NMODE editor in terms of its differences from EMODE, the previous PSL text editor. NMODE is a new editor that retains much of the basic structure and algorithms of EMODE. However, there are many differences between NMODE and EMODE, of interest to both users and experts. For experts, the differences can be summed up very easily: NMODE is a complete rewrite of EMODE. Virtually no EMODE function or fluid variable is present in NMODE. Thus, any code that interacts with the insides of EMODE must be rewritten to run in NMODE. Even code to define new function keys must be changed. In many cases, it is only necessary to change function names. However, code that accesses EMODE fluid variables probably requires greater revision, since many EMODE fluid variables have no counterparts in NMODE. In particular, there are no fluid variables containing information about the current buffer or the current window. Information describing how to customize NMODE by redefining keys or defining new commands may be found in the file "PSL:NMODE-CUSTOMIZING.TXT". For users, the differences between NMODE and EMODE can be divided into a number of categories: * New Lisp Interaction * Incompatible Changes * Limitations * Extension of existing commands to conform to EMACS * New EMACS commands implemented * Bug Fixes * Miscellaneous Improvements These categories are described below: ------------------------------------------------------------------------------- * New Lisp Interaction NMODE provides a new set of editor commands for executing forms from a buffer and interacting with the Break Handler. These commands use a new prefix character, C-], which echoes as "Lisp-". In the remainder of this document, the notation "Lisp-X" will be used to refer to the command sequence C-] X (where X is an arbitrary character). The "Lisp-" commands are available only in Lisp Mode. Three "Lisp-" commands are always available in Lisp mode: Lisp-E executes a form in the current buffer beginning at the start of the current line. (This command was invoked as M-E in EMODE.) Output produced by the execution of a Lisp form is written to an output buffer (called "OUTPUT" in NMODE), which will pop up automatically in the "other" window if it is not exposed when output occurs. As in EMODE, this automatic pop-up can be suppressed by setting the global variable *OutWindow to NIL; however, in NMODE, this flag will be ignored when a Break occurs. In NMODE, output is always written at the END of the output buffer, even if the input is coming from the same buffer. Thus, when you execute a form from the output buffer, the cursor will jump to the end of the buffer when the output is printed. However, the mark is set at the point where you did the Lisp-E, so you can get back using C-X C-X. Lisp-Y will yank the output from the previous Lisp-E into the current buffer. (This command was invoked as C-M-Y in EMODE.) The output is obtained from the output buffer. Only the starting and ending positions of the last output text are saved, so that if the output buffer has been modified, Lisp-Y may get the wrong text. Lisp-L will transfer to a "normal" PSL Lisp Listener. (This command was invoked as C-M-Z in EMODE.) To return to NMODE, evaluate the form (NMODE). In NMODE, the Lisp prompt is displayed as part of the window label when the OUTPUT buffer is displayed, as opposed to permanently reserving a separate line on the screen for the Lisp prompt as EMODE does. NMODE does not use a break menu. However, NMODE does provide a set of special commands that can be used when a Lisp evaluation has entered a break loop. These commands are: Lisp-B: print a backtrace Lisp-Q: quit out of current break loop Lisp-A: abort to top-level (restarts NMODE) Lisp-R: retry (from a continuable error) (existing ErrorForm is re-evaluated) Lisp-C: continue (from a continuable error) (value of the last form executed is used for the value) Lisp-?: Brief help on above commands. Lisp-C is used to return a new value as the result value of the offending form (in the case of a continuable error). The value is specified by executing a form using Lisp-E; Lisp-C then "returns" the most recent result of execution. Lisp-B by itself prints the normal backtrace. C-U Lisp-B will in addition print the names of "interpreter" functions, such as COND and PROG. C-U C-U Lisp-B will print a verbose backtrace that displays the entire contents of the stack. The PSL function YesP has been redefined in NMODE to use NMODE prompted string input. It requires that the user type "Yes" or "No". ------------------------------------------------------------------------------- * Incompatible Changes A number of existing EMODE functions are performed using different commands in NMODE, leaving their original commands either undefined or doing something different. These are: C-X C-R (Visit File): now C-X C-V (to conform with EMACS) M-E (Execute Form): now Lisp-E (typed as: C-] E) C-M-Y (Yank Last Output): now Lisp-Y (typed as: C-] Y) C-M-Z (Exit NMode): now Lisp-L (typed as: C-] L) C-X 2 (View Two Windows): now C-X 3 (to conform with EMACS) C-M-O (Forward Up List): now C-M-) (same as EMACS) ------------------------------------------------------------------------------- * Limitations There are limitations imposed by NMODE that are not present in EMODE: * Currently, NMODE can be used only with HP terminals and with the 9836 running an extended VT52 emulator (the extensions are to support display enhancements). * Currently, NMODE runs only on TOPS-20. ------------------------------------------------------------------------------- * Extension of existing commands to conform to EMACS A large number of existing EMODE commands have been extended in NMODE to conform either exactly or more closely to the EMACS definitions. Many of these changes relate to the use of command arguments (specified by C-U). In EMODE, C-U simply defines a positive repetition count and repetitively executes the definition of the following command character. In NMODE, C-U works as in EMACS: it can accept either a positive or negative argument, which is interpreted in arbitrary ways by the following command. The following EMODE commands have been extended in notable ways: C-@ With an argument, pops a ring of marks (which is per-buffer). C-K Is unaffected by trailing white space at the end of the line. C-L Now repositions the current window. Accepts C-U argument. C-N and C-P Now remember the "goal column". C-V and M-V Scroll by lines or screenfuls, according to C-U argument. C-X 1 With an argument, expands the bottom window instead of the top. C-X 2 Now makes the bottom window current (use C-X 3 for top window). C-X C-S Now won't save an unmodified buffer. C-X C-V Now offers to save a modified buffer. C-X D Obeys command argument (without arg, uses current directory). C-X K Now asks for the name of the buffer to kill. C-X O Now works even in 1-window mode. M-< and M-> Now set the mark. Return Now will move "into" a region of blank lines. ------------------------------------------------------------------------------- * New EMACS commands implemented The following EMACS commands are newly implemented in NMODE: BackSpace Move Backward Character C-% Replace String C-< Mark Beginning C-> Mark End C-G Aborts commands that request string input C-M-( Backward Up List C-M-) Forward Up List C-M-O Split Line C-M-R Reposition Window (for Lisp DEFUNs only) C-M-Return Same as M-M C-M-T Transpose Forms C-M-Tab Lisp Tab (also C-M-I) C-M-V Scroll other window C-M-W Append Next Kill C-Rubout Delete Backward Hacking Tabs C-Space Same as C-@ C-X 3 View Two Windows C-X 4 Visit in Other Window (Find File or Select Buffer) C-X A Append to Buffer C-X C-N Set Goal Column C-X C-T Transpose Lines C-X G Get Register C-X T Transpose Regions C-X X Put Register C-^ The "control prefix" (used to type things like C-%) M-0 thru M-9 Define a numeric argument (also C-0, C-M-0, etc.) M-Hyphen Defines a numeric argument (also C-Hyphen, C-M-Hyphen, etc.) M-R Move to Screen Edge M-Return Same as M-M M-T Transpose Words M-Tab inserts a "Tab" (also M-I) M-~ Buffer Not Modified ------------------------------------------------------------------------------- * Bug Fixes In the process of writing NMODE, a number of bugs in EMODE were fixed. These include: * M-Y has been made "safe". It checks that the contents of the region equal the contents of the current kill buffer before killing the region. * Dired SORT commands no longer throw away all user-specified changes. * The interaction between NMODE and the Lisp Environment is much more robust. It is much more difficult to get NMODE "screwed up". In NMODE, it is possible to Quit out of an "Unexpected EOF" error. * NMODE does not allow the user to select one of its internal buffers. * In NMODE, string input can be terminated only by Return or C-G (C-G aborts the command). * The M-? command now accepts any syntactically valid command, including character sequences using prefix characters. * NMODE will not screw up if the cursor is moved into a part of a line that does not show on the display. * The window position indicator ("--68%--") now works reasonably. * EMODE always advances to the next line after a M-E; NMODE suppresses this action in two cases where it is spurious: (1) when NMODE is starting up, (2) when the buffer pointer is at the beginning of the line, such as after "executing" a number. ------------------------------------------------------------------------------- * Miscellaneous Improvements * NMODE supports INIT files. When first started up, NMODE will execute the file "NMODE.INIT" on the user's home directory, if the file exists. The file should contain a sequence of Lisp forms. * Completion of buffer names is implemented in NMODE. Completion is requested using the Space character. * File names now always expand to the full "true" file name (as in EMACS). As a result, Find File will always find a file in an existing buffer if possible, regardless of the exact string typed by the user. In addition, file names specified by the user now MERGE with the default file name. * Find File now creates a reasonable buffer name, instead of using the exact string typed by the user. The buffer name will not be displayed on the mode line, if it is completely redundant. * "Lisp" and "Text" modes are now available; the choice is based on file name. In "Text" mode, the Lisp related commands (both C-M-* and Lisp-*) are undefined, Tab is self-inserting, and Rubout does not "hack tabs". * The M-X extended command interface has been implemented. The following M-X commands are defined: "M-X Lisp Mode" and "M-X Text Mode", which set the mode of the current buffer. * Display Refresh is interruptible, allowing faster type-ahead. Parenthesis matching is also interruptible, which is especially important in the case of inserting an unmatched parenthesis. * Prompting has been improved. * Horizontal scrolling is supported. Two new commands, C-X < and C-X >, are provided to scroll the window horizontally. They accept a C-U argument. * The buffer display now shows a '!' at the end of any line that extends past the right edge of the screen. * Displaying one buffer in two windows now works reasonably. * Each buffer has a modified flag which indicates whether the contents of the buffer have been changed since the buffer was last read or written. * The "mode line" now uses inverse video and is much more like EMACS. * Display enhancements are supported in a general fashion. A new command C-X V has been implemented to switch between normal and inverse video. * When entering string input, C-R will yank the default string into the input buffer. ------------------------------------------------------------------------------- |
Added psl-1983/x-psl/nmode.init version [54466585b2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This is the "default" NMODE.INIT file. It will be evaluated when NMODE starts % up, unless the file *NMODE.INIT exists, in which case that file will be % evaluated instead. It is recommended that any personal NMODE.INIT file begin % with the form: % % (nmode-read-and-evaluate-file nmode-default-init-file-name) % % which will cause this file to be evaluated first. % Make the BACKSPACE key behave like Rubout! % Make M-BACKSPACE behave like M-Rubout! (remove-from-command-list 'Read-Only-Text-Command-List (x-char BACKSPACE)) (remove-from-command-list 'Lisp-Command-List (x-char M-BACKSPACE)) (add-to-command-list 'Text-Command-List (x-char BACKSPACE) 'delete-backward-character-command) (add-to-command-list 'Text-Command-List (x-char M-BACKSPACE) 'kill-backward-word-command) (add-to-command-list 'Lisp-Command-List (x-char BACKSPACE) 'delete-backward-hacking-tabs-command) (nmode-establish-current-mode) (when (not (funboundp 'nmode-define-softkey)) (nmode-define-softkey 0 'exit-nmode "Exit") (nmode-define-softkey 1 'buffer-browser-command "Buffers") (nmode-define-softkey 2 'find-file-command "Find File") (nmode-define-softkey 3 'save-file-command "Save File") (if (not (funboundp 'browser-browser-command)) (nmode-define-softkey 4 'browser-browser-command "Browsers") (nmode-define-softkey 4 'fill-paragraph-command "Fill Para") ) (nmode-define-softkey 5 'pasemulate "Hulk") (nmode-define-softkey 6 'pasfiler "Filer") (nmode-define-softkey 8 (string (x-char ^!])) "Lisp-") (nmode-define-softkey 9 (string (x-char ^!\) #/X) "M-X") ) |
Added psl-1983/x-psl/psl-bugs.dist version [eafd79c896].
> > | 1 2 | PSL-Buggees: utah-cs!localpsl@HP-Venus, - localpsl |
Added psl-1983/x-psl/psl-names.cmd version [4b3fa347d8].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | ; psl: ss:<psl> ! System-wide definition define psys: ss:<psl.subsys> ! Directory of executable files define psl: ss:<psl>,ss:<psl.subsys> ;OBJECT CODE FILES define pl: ss:<psl.lap> ! All PSL .B files live here define plap: ss:<psl.lap> ;SOURCE CODE, COMMAND FILES, (also .rel files) define pu: ss:<psl.util> ! Machine-independent loadable modules define p20u: ss:<psl.util-20> ! Dec-20 utility program sources define pn: ss:<psl.nmode> ! NMODE sources define pnb: ss:<psl.nmode-binary> ! NMODE binaries define pw: ss:<psl.windows> ! WINDOW PACKAGE sources define pwb: ss:<psl.windows-binary> ! WINDOW PACKAGE binaries ;DOCUMENTATION FILES define plpt: ss:<psl.lpt> ! Printable version of ref. manual define pman: ss:<psl.manual> ! Manual sources and working files define pndoc: ss:<psl.nmode-doc> ! Documentation for NMODE define ph: ss:<psl.help> ! xxx.HLP => help, ! xxx.DOC => documentation of PU: file define p20h: ss:<psl.help-20> ! For the DEC-20 define pd: ss:<psl.doc> ! Should be source and output files for ! formal documents (except the manual) define p20d: ss:<psl.doc-20> ! For the DEC-20 ;MAINTAINER-ORIENTED ARCANA AND ESOTERICA (no erotica) define pnew: ss:<psl.new> ! Pre-release loadable files take |
Added psl-1983/x-psl/psl.exe version [5edfe08316].
cannot compute difference between binary files
Added psl-1983/x-psl/psl.tags version [a16f232fee].
more than 10,000 changes
Added psl-1983/x-psl/rlisp.exe version [58fd6576d3].
cannot compute difference between binary files
Added psl-1983/x-psl/rlispcomp.exe version [8539826aaa].
cannot compute difference between binary files
Added psl-1983/x-psl/tag-psl.log version [e206c40797].
cannot compute difference between binary files
Added psl/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 r30/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 r30/alg1.fap version [aacbacb657].
cannot compute difference between binary files
Added r30/alg1.red version [1a1faaa573].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 | %********************************************************************* %********************************************************************* % REDUCE BASIC ALGEBRAIC PROCESSOR (PART 1) %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; %********************************************************************* % NON-LOCAL VARIABLES REFERENCED IN THIS SECTION %********************************************************************; FLUID '(ALGLIST!* ARBL!* !*EXP !*GCD !*INTSTR !*LCM !*MCD !*MODE); GLOBAL '(ASYMPLIS!* CURSYM!* DMODE!* DOMAINLIST!* EXLIST!* EXPTL!* EXPTP!* FRASC!* FRLIS!* INITL!* KORD!* KPROPS!* LETL!* MCHFG!* MCOND!* MOD!* MUL!* NAT!*!* NCMP!* OFL!* POSN!* POWLIS!* POWLIS1!* SPLIS!* SUBFG!* TSTACK!* TYPL!* WS WTL!* !*EZGCD !*FLOAT !*FORT !*GROUP !*INT !*MATCH !*MSG !*NAT !*NERO !*NOSUBS !*NUMVAL !*OUTP !*PERIOD !*PRI !*RESUBS !*SQVAR!* !*SUB2 !*VAL !*XDN); GLOBAL '(DSUBL!* SUBL!*); %not used at moment; ALGLIST!* := NIL; %association list for previously simplified %expressions; ARBL!* := NIL; %used for storage of arbitrary vars in LET %statements; ASYMPLIS!* := NIL; %association list of asymptotic replacements; % CURSYM!* current symbol (i. e. identifier, parenthesis, % delimiter, e.t.c,) in input line; DMODE!* := NIL; %name of current polynomial domain mode if not %integer; DOMAINLIST!* := NIL; %list of currently supported poly domain modes; %DSUBL!* := NIL; %list of previously calculated derivatives of % expressions; EXLIST!* := '((!*)); %property list for standard forms used as % kernels; EXPTL!* := NIL; %list of exprs with non-integer exponents; EXPTP!* := NIL; %flag telling EXPTs appear in LET statements; FRASC!* := NIL; %association list for free variables in %substitution rules; FRLIS!* := NIL; %list of renamed free variables to be found in %substitutions; INITL!* := APPEND('(FRASC!* MCOND!* SUBFG!* !*SUB2 TSTACK!*),INITL!*); KORD!* := NIL; %kernel order in standard forms; KPROPS!* := NIL; %list of active non-atomic kernel plists; LETL!* := '(LET MATCH CLEAR SAVEAS SUCH); %special delimiters; MCHFG!* := NIL; %indicates that a pattern match occurred during %a cycle of the matching routines; MCOND!* := NIL; %used for temporary storage of a conditional %expression in a substitution; MOD!* := NIL; %modular base, NIL for integer arithmetic; MUL!* := NIL; %list of additional evaluations needed in a %given multiplication; NAT!*!* := NIL; %temporary variable used in algebraic mode; NCMP!* := NIL; %flag indicating non-commutative multiplication %mode; OFL!* := NIL; %current output file name; POSN!* := NIL; %used to store output character position in %printing functions; POWLIS!* := NIL; %association list of replacements for powers; POWLIS1!* := NIL; %association list of conditional replacements %for powers; SPLIS!* := NIL; %substitution list for sums and products; SUBFG!* := T; %flag to indicate whether substitution %is required during evaluation; %SUBL!* := NIL; %list of previously evaluated expressions; TSTACK!* := 0; %stack counter in SIMPTIMES; % TYPL!*; WTL!* := NIL; %tells that a WEIGHT assignment has been made; !*EXP := T; %expansion control flag; !*EZGCD := NIL; %ezgcd calculation flag; !*FLOAT := NIL; %floating arithmetic mode flag; !*FORT := NIL; %specifies FORTRAN output; !*GCD := NIL; %greatest common divisor mode flag; !*GROUP := NIL; %causes expressions to be grouped when EXP off; !*INTSTR := NIL; %makes expression arguments structured; %!*INT indicates interactive system use; !*LCM := T; %least common multiple computation flag; !*MATCH := NIL; %list of pattern matching rules; !*MCD := T; %common denominator control flag; !*MODE := 'SYMBOLIC; %current evaluation mode; !*MSG := T; %flag controlling message printing; !*NAT := T; %specifies natural printing mode; !*NERO := NIL; %flag to suppress printing of zeros; !*NOSUBS := NIL; %internal flag controlling substitution; !*NUMVAL := NIL; %used to indicate that numerical expressions %should be converted to a real value; !*OUTP := NIL; %holds prefix output form for extended output %package; !*PERIOD := T; %prints a period after a fixed coefficient %when FORT is on; !*PRI := NIL; %indicates that fancy output is required; !*RESUBS := T; %external flag controlling resubstitution; !*SQVAR!*:='(T); %variable used by *SQ expressions to control %resimplification; !*SUB2 := NIL; %indicates need for call of RESIMP; !*VAL := T; %controls operator argument evaluation; !*XDN := T; %flag indicating that denominators should be %expanded; %initial values of some global variables in BEGIN1 loops; PUT('TSTACK!*,'INITL,0); PUT('SUBFG!*,'INITL,T); %Old name for the expression workspace; %PUT('!*ANS,'NEWNAM,'WS); %********************************************************************* % GENERAL FUNCTIONS %********************************************************************; SYMBOLIC PROCEDURE ATOMLIS U; NULL U OR (ATOM CAR U AND ATOMLIS CDR U); SYMBOLIC PROCEDURE CARX(U,V); IF NULL CDR U THEN CAR U ELSE REDERR LIST("Wrong number of arguments to",V); SYMBOLIC PROCEDURE DELASC(U,V); IF NULL V THEN NIL ELSE IF ATOM CAR V OR U NEQ CAAR V THEN CAR V . DELASC(U,CDR V) ELSE CDR V; SYMBOLIC PROCEDURE LENGTHC U; %gives character length of U excluding string and escape chars; BEGIN INTEGER N; SCALAR X; N := 0; X := EXPLODE U; IF CAR X EQ '!" THEN RETURN LENGTH X-2; WHILE X DO <<IF CAR X EQ '!! THEN X := CDR X; N := N+1; X := CDR X>>; RETURN N END; SYMBOLIC PROCEDURE GET!*(U,V); IF NUMBERP U THEN NIL ELSE GET(U,V); SYMBOLIC PROCEDURE MAPCONS(U,V); FOR EACH J IN U COLLECT V . J; SYMBOLIC PROCEDURE MAPPEND(U,V); FOR EACH J IN U COLLECT APPEND(V,J); SYMBOLIC PROCEDURE NLIST(U,N); IF N=0 THEN NIL ELSE U . NLIST(U,N-1); SYMBOLIC PROCEDURE NTH(U,N); CAR PNTH(U,N); SYMBOLIC PROCEDURE PNTH(U,N); IF NULL U THEN REDERR "Index out of range" ELSE IF N=1 THEN U ELSE PNTH(CDR U,N-1); SYMBOLIC PROCEDURE PERMP(U,V); IF NULL U THEN T ELSE IF CAR U EQ CAR V THEN PERMP(CDR U,CDR V) ELSE NOT PERMP(CDR U,SUBST(CAR V,CAR U,CDR V)); SYMBOLIC PROCEDURE REMOVE(X,N); %Returns X with Nth element removed; IF NULL X THEN NIL ELSE IF N=1 THEN CDR X ELSE CAR X . REMOVE(CDR X,N-1); SYMBOLIC PROCEDURE REVPR U; CDR U . CAR U; SYMBOLIC PROCEDURE REPEATS X; IF NULL X THEN NIL ELSE IF CAR X MEMBER CDR X THEN CAR X . REPEATS CDR X ELSE REPEATS CDR X; SYMBOLIC PROCEDURE SMEMBER(U,V); %determines if S-expression U is a member of V at any level; IF U=V THEN T ELSE IF ATOM V THEN NIL ELSE SMEMBER(U,CAR V) OR SMEMBER(U,CDR V); SYMBOLIC PROCEDURE SMEMQ(U,V); %true if id U is a member of V at any level (excluding %quoted expressions); IF ATOM V THEN U EQ V ELSE IF CAR V EQ 'QUOTE THEN NIL ELSE SMEMQ(U,CAR V) OR SMEMQ(U,CDR V); SYMBOLIC PROCEDURE SMEMQL(U,V); %Returns those members of id list U contained in V at any %level (excluding quoted expressions); IF NULL U THEN NIL ELSE IF SMEMQ(CAR U,V) THEN CAR U . SMEMQL(CDR U,V) ELSE SMEMQL(CDR U,V); SYMBOLIC PROCEDURE SMEMQLP(U,V); %True if any member of id list U is contained at any level %in V (exclusive of quoted expressions); IF NULL V THEN NIL ELSE IF ATOM V THEN V MEMQ U ELSE IF CAR V EQ 'QUOTE THEN NIL ELSE SMEMQLP(U,CAR V) OR SMEMQLP(U,CDR V); SYMBOLIC PROCEDURE SPACES N; FOR I:= 1:N DO PRIN2 " "; SYMBOLIC PROCEDURE SUBLA(U,V); BEGIN SCALAR X; IF NULL U OR NULL V THEN RETURN V ELSE IF ATOM V THEN RETURN IF X:= ATSOC(V,U) THEN CDR X ELSE V ELSE RETURN(SUBLA(U,CAR V) . SUBLA(U,CDR V)) END; SYMBOLIC PROCEDURE XNP(U,V); %returns true if the atom lists U and V have at least one common %element; U AND (CAR U MEMQ V OR XNP(CDR U,V)); %********************************************************************* % FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES %********************************************************************; SYMBOLIC PROCEDURE MSGPRI(U,V,W,X,Y); BEGIN SCALAR NAT1,Z; IF NULL Y AND NULL !*MSG THEN RETURN; NAT1 := !*NAT; !*NAT := NIL; IF OFL!* AND (!*FORT OR NOT NAT1) THEN GO TO C; A: TERPRI(); LPRI ((IF NULL Y THEN "***" ELSE "*****") . IF U AND ATOM U THEN LIST U ELSE U); POSN!* := POSN(); MAPRIN V; PRIN2 " "; LPRI IF W AND ATOM W THEN LIST W ELSE W; POSN!* := POSN(); MAPRIN X; IF NOT Y OR Y EQ 'HOLD THEN TERPRI(); IF NULL Z THEN GO TO B; WRS CDR Z; GO TO D; B: IF NULL OFL!* THEN GO TO D; C: Z := OFL!*; WRS NIL; GO TO A; D: !*NAT := NAT1; IF Y THEN IF Y EQ 'HOLD THEN ERFG!* := Y ELSE ERROR1() END; SYMBOLIC PROCEDURE ERRACH U; BEGIN TERPRI!* T; LPRIE "CATASTROPHIC ERROR *****"; PRINTTY U; LPRIW(" ",NIL); REDERR "Please send output and input listing to A. C. Hearn" END; SYMBOLIC PROCEDURE ERRPRI1 U; MSGPRI("Substitution for",U,"not allowed",NIL,'HOLD); SYMBOLIC PROCEDURE ERRPRI2(U,V); MSGPRI("Syntax error:",U,"invalid",NIL,V); SYMBOLIC PROCEDURE REDMSG(U,V); IF NULL !*MSG THEN NIL ELSE IF TERMINALP() THEN YESP LIST("Declare",U,V,"?") OR ERROR1() ELSE LPRIM LIST(U,"declared",V); SYMBOLIC PROCEDURE TYPERR(U,V); <<TERPRI!* T; PRIN2!* "***** "; IF NOT ATOM U AND ATOM CAR U AND ATOM CADR U AND NULL CDDR U THEN <<PRIN2!* CAR U; PRIN2!* " "; PRIN2!* CADR U>> ELSE MAPRIN U; PRIN2!* " invalid as "; PRIN2!* V; TERPRI!* NIL; ERFG!* := T; ERROR1()>>; %********************************************************************* % ALGEBRAIC MODE FUNCTIONS AND DECLARATIONS REFERENCED IN SECTION 1 %********************************************************************; %SYMBOLIC PROCEDURE APROC(U,V); % IF NULL U THEN NIL % ELSE IF ATOM U % THEN IF NUMBERP U AND FIXP U THEN U ELSE LIST(V,MKARG U) % ELSE IF FLAGP(CAR U,'NOCHANGE) OR GET(CAR U,'STAT) THEN U % ELSE IF FLAGP(CAR U,'BOOLEAN) % THEN CAR U . FOR EACH J IN CDR U COLLECT APROC(J,'REVAL) % ELSE IF CDR U AND EQCAR(CADR U,'QUOTE) THEN U % ELSE LIST(V,MKARG U); SYMBOLIC PROCEDURE FORMINPUT(U,VARS,MODE); BEGIN SCALAR X; IF X := ASSOC(CAR U,INPUTBUFLIS!*) THEN RETURN CDR X ELSE REDERR LIST("Entry",CAR U,"not found") END; PUT('INPUT,'FORMFN,'FORMINPUT); SYMBOLIC PROCEDURE FORMWS(U,VARS,MODE); BEGIN SCALAR X; IF X := ASSOC(CAR U,RESULTBUFLIS!*) THEN RETURN MKQUOTE CDR X ELSE REDERR LIST("Entry",CAR U,"not found") END; PUT('WS,'FORMFN,'FORMWS); FLAG ('(AEVAL ARRAYFN COND FLAG GETEL GO PROG PROGN PROG2 RETURN SETQ SETK SETEL VARPRI),'NOCHANGE); %NB: FLAG IS NEEDED IN ALGEBRAIC PROC/OPERATOR DEFINITION; FLAG ('(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ FIXP LESSP NUMBERP ORDP),'BOOLEAN); FLAG ('(OR AND NOT),'BOOLARGS); DEFLIST ('((SUM (ADDSQ . (NIL . 1))) (PRODUCT (MULTSQ . (1 . 1)))), 'BIN); FLAG ('(SUM PRODUCT),'DELIM); FLAG ('(SUM PRODUCT),'NODEL); DEFLIST ('((EXP ((NIL (RMSUBS1)) (T (RMSUBS)))) (FACTOR ((NIL (SETQ !*EXP T)) (T (SETQ !*EXP NIL) (RMSUBS)))) (FORT ((NIL (SETQ !*NAT NAT!*!*)) (T (SETQ !*NAT NIL)))) (GCD ((T (RMSUBS)))) (MCD ((NIL (RMSUBS)) (T (RMSUBS)))) (NAT ((NIL (SETQ NAT!*!* NIL)) (T (SETQ NAT!*!* T)))) (NUMVAL ((T (RMSUBS)) (NIL (SETDMODE NIL)))) (VAL ((T (RMSUBS)))) (FLOAT ((T (RMSUBS))))),'SIMPFG); %********************************************************************* % SELECTORS AND CONSTRUCTORS USED IN ALGEBRAIC CALCULATIONS %********************************************************************; NEWTOK '((!. !+) ADD); NEWTOK '((!. !*) MULT); NEWTOK '((!. !* !*) TO); NEWTOK '((!. !/) OVER); INFIX TO,.*,.+,./; SMACRO PROCEDURE U.+V; %standard (polynomial) addition constructor; U . V; SMACRO PROCEDURE LC U; %leading coefficient of standard form; CDAR U; SMACRO PROCEDURE LDEG U; %leading degree of standard form; CDAAR U; SMACRO PROCEDURE LT U; %leading term of standard form; CAR U; SMACRO PROCEDURE U.*V; %standard form multiplication constructor; U . V; SMACRO PROCEDURE MVAR U; %main variable of standard form; CAAAR U; SMACRO PROCEDURE LPOW U; %leading power of standard form; CAAR U; SMACRO PROCEDURE PDEG U; %returns the degree of the power U; CDR U; SMACRO PROCEDURE RED U; %reductum of standard form; CDR U; SMACRO PROCEDURE TC U; %coefficient of standard term; CDR U; SMACRO PROCEDURE TDEG U; %degree of standard term; CDAR U; SMACRO PROCEDURE TPOW U; %power of standard term; CAR U; SMACRO PROCEDURE TVAR U; %main variable of a standard term; CAAR U; SMACRO PROCEDURE NUMR U; %numerator of standard quotient; CAR U; SMACRO PROCEDURE DENR U; %denominator of standard quotient; CDR U; SMACRO PROCEDURE U ./ V; %constructor for standard quotient; U . V; %********************************************************************* % MACROS AND PROCEDURES FOR CONVERTING BETWEEN VARIOUS FORMS %********************************************************************; SYMBOLIC PROCEDURE !*A2F U; %U is an algebraic expression. Value is the equivalent form %or an error if conversion is not possible; !*Q2F SIMP!* U; SYMBOLIC PROCEDURE !*A2K U; %U is an algebraic expression. Value is the equivalent kernel %or an error if conversion is not possible. %earlier versions used SIMP0; BEGIN SCALAR X; IF KERNP(X := SIMP!* U) THEN RETURN MVAR NUMR X ELSE TYPERR(U,'kernel) END; SMACRO PROCEDURE !*F2A U; PREPF U; SMACRO PROCEDURE !*F2Q U; %U is a standard form, value is a standard quotient; U . 1; SMACRO PROCEDURE !*K2F U; %U is a kernel, value is a standard form; LIST (TO(U,1) . 1); SMACRO PROCEDURE !*K2Q U; %U is a kernel, value is a standard quotient; LIST(TO(U,1) . 1) . 1; SYMBOLIC PROCEDURE !*N2F U; %U is a number. Value is a standard form; IF ZEROP U THEN NIL ELSE U; SMACRO PROCEDURE !*P2F U; %U is a standard power, value is a standard form; LIST (U . 1); SMACRO PROCEDURE !*P2Q U; %U is a standard power, value is a standard quotient; LIST(U . 1) . 1; SYMBOLIC PROCEDURE !*Q2F U; %U is a standard quotient, value is a standard form; IF DENR U=1 THEN NUMR U ELSE TYPERR(PREPSQ U,'polynomial); SYMBOLIC PROCEDURE !*Q2K U; %U is a standard quotient, value is a kernel or an error if %conversion not possible; IF KERNP U THEN MVAR NUMR U ELSE TYPERR(PREPSQ U,'kernel); SMACRO PROCEDURE !*T2F U; %U is a standard term, value is a standard form; LIST U; SMACRO PROCEDURE !*T2Q U; %U is a standard term, value is a standard quotient; LIST U . 1; %********************************************************************* % FUNCTIONS FOR ALGEBRAIC EVALUATION OF PREFIX FORMS %********************************************************************; SYMBOLIC PROCEDURE REVAL U; REVAL1(U,T); SYMBOLIC PROCEDURE AEVAL U; REVAL1(U,NIL); SYMBOLIC PROCEDURE REVAL1(U,V); BEGIN SCALAR ALGLIST!*,X,Y; LOOP: IF STRINGP U THEN RETURN U ELSE IF NUMBERP U AND FIXP U THEN IF MOD!* THEN GO TO B ELSE RETURN U ELSE IF ATOM U THEN NIL ELSE IF CAR U EQ '!*COMMA!* THEN ERRPRI2(U,T) ELSE IF CAR U EQ '!*SQ THEN GO TO B ELSE IF ARRAYP CAR U THEN <<U := GETELV U; GO TO LOOP>>; X := LIST U; Y := TYPL!*; A: IF NULL Y THEN GO TO B ELSE IF APPLY(CAR Y,X) THEN RETURN APPLY(GET(CAR Y,'EVFN),X); Y := CDR Y; GO TO A; B: U := SIMP!* U; IF NULL V THEN RETURN MK!*SQ U; U := PREPSQX U; RETURN IF EQCAR(U,'MINUS) AND NUMBERP CADR U THEN -CADR U ELSE U END; SYMBOLIC PROCEDURE PREPSQX U; IF !*INTSTR THEN PREPSQ!* U ELSE PREPSQ U; SYMBOLIC PROCEDURE IEVAL U; %returns algebraic value of U if U is an integer or an error; BEGIN IF NUMBERP U THEN IF FIXP U THEN RETURN U ELSE TYPERR(U,"integer") ELSE IF NOT ATOM U AND ARRAYP CAR U THEN U := GETELV U; U := SIMP!* U; IF DENR U NEQ 1 OR NOT ATOM NUMR U THEN TYPERR(PREPSQ U,"integer"); U := NUMR U; IF NULL U THEN U := 0; RETURN U END; SYMBOLIC PROCEDURE GETELV U; %returns the value of the array element U; GETEL(CAR U . FOR EACH X IN CDR U COLLECT IEVAL X); SYMBOLIC PROCEDURE SETELV(U,V); SETEL(CAR U . FOR EACH X IN CDR U COLLECT IEVAL X,V); SYMBOLIC PROCEDURE REVLIS U; FOR EACH J IN U COLLECT REVAL J; SYMBOLIC PROCEDURE REVOP1 U; IF !*VAL THEN CAR U . REVLIS CDR U ELSE U; SYMBOLIC PROCEDURE MK!*SQ U; IF NULL NUMR U THEN 0 ELSE IF ATOM NUMR U AND DENR U=1 THEN NUMR U ELSE '!*SQ . EXPCHK U . IF !*RESUBS THEN !*SQVAR!* ELSE LIST NIL; SYMBOLIC PROCEDURE EXPCHK U; IF !*EXP THEN U ELSE CANPROD(MKPROD!* NUMR U,MKPROD!* DENR U); %********************************************************************* % EVALUATION FUNCTIONS FOR BOOLEAN OPERATORS %********************************************************************; SYMBOLIC PROCEDURE EVALEQUAL(U,V); (LAMBDA X; NUMBERP X AND ZEROP X) REVAL LIST('DIFFERENCE,U,V); PUT('EQUAL,'BOOLFN,'EVALEQUAL); SYMBOLIC PROCEDURE EVALGREATERP(U,V); (LAMBDA X; ATOM DENR X AND DOMAINP NUMR X AND NUMR X AND !:MINUSP NUMR X) SIMP!* LIST('DIFFERENCE,V,U); PUT('GREATERP,'BOOLFN,'EVALGREATERP); SYMBOLIC PROCEDURE EVALGEQ(U,V); NOT EVALLESSP(U,V); PUT('GEQ,'BOOLFN,'EVALGEQ); SYMBOLIC PROCEDURE EVALLESSP(U,V); (LAMBDA X; ATOM DENR X AND DOMAINP NUMR X AND NUMR X AND !:MINUSP NUMR X) SIMP!* LIST('DIFFERENCE,U,V); PUT('LESSP,'BOOLFN,'EVALLESSP); SYMBOLIC PROCEDURE EVALLEQ(U,V); NOT EVALGREATERP(U,V); PUT('LEQ,'BOOLFN,'EVALLEQ); SYMBOLIC PROCEDURE EVALNEQ(U,V); NOT EVALEQUAL(U,V); PUT('NEQ,'BOOLFN,'EVALNEQ); SYMBOLIC PROCEDURE EVALNUMBERP U; (LAMBDA X; ATOM DENR X AND DOMAINP NUMR X) SIMP!* U; PUT('NUMBERP,'BOOLFN,'EVALNUMBERP); %********************************************************************* % FUNCTIONS FOR CONVERTING PREFIX FORMS INTO CANONICAL FORM %********************************************************************; SYMBOLIC PROCEDURE SIMP!* U; BEGIN SCALAR X; IF EQCAR(U,'!*SQ) AND CADDR U THEN RETURN CADR U; X := MUL!* . !*SUB2; %save current environment; MUL!* := NIL; U:= SIMP U; A: IF NULL MUL!* THEN GO TO B; U:= APPLY(CAR MUL!*,LIST U); MUL!*:= CDR MUL!*; GO TO A; B: MUL!* := CAR X; U := SUBS2 U; !*SUB2 := CDR X; RETURN U END; SYMBOLIC PROCEDURE SUBS2 U; BEGIN SCALAR XEXP; IF NULL SUBFG!* THEN RETURN U ELSE IF !*SUB2 OR POWLIS1!* THEN U := SUBS2Q U; IF NULL !*MATCH AND NULL SPLIS!* THEN RETURN U ELSE IF NULL !*EXP THEN <<XEXP:= T; !*EXP := T; U := RESIMP U>>; IF !*MATCH THEN U := SUBS3Q U; IF SPLIS!* THEN U := SUBS4Q U; IF XEXP THEN !*EXP := NIL; RETURN U END; SYMBOLIC PROCEDURE SIMP U; BEGIN SCALAR X; IF ATOM U THEN RETURN SIMPATOM U ELSE IF CAR U EQ '!*SQ AND CADDR U THEN RETURN CADR U ELSE IF X := ASSOC(U,ALGLIST!*) THEN RETURN CDR X ELSE IF NOT IDP CAR U THEN GO TO E ELSE IF FLAGP(CAR U,'OPFN) THEN RETURN !*SSAVE(SIMP EVAL(CAR U . FOR EACH J IN (IF FLAGP(CAR U,'NOVAL) THEN CDR U ELSE REVLIS CDR U) COLLECT MKQUOTE J),U) ELSE IF X := GET(CAR U,'POLYFN) THEN RETURN !*SSAVE(!*F2Q APPLY(X, FOR EACH J IN CDR U COLLECT !*Q2F SIMP!* J), U) ELSE IF GET(CAR U,'OPMTCH) AND NOT(GET(CAR U,'SIMPFN) EQ 'SIMPIDEN) AND (X := OPMTCH REVOP1 U) THEN RETURN SIMP X ELSE IF X := GET(CAR U,'SIMPFN) THEN RETURN !*SSAVE(IF FLAGP(CAR U,'FULL) OR X EQ 'SIMPIDEN THEN APPLY(X,LIST U) ELSE APPLY(X,LIST CDR U),U) ELSE IF ARRAYP CAR U THEN RETURN !*SSAVE(SIMP GETELV U,U) ELSE IF (X := GET(CAR U,'MATRIX)) THEN GO TO M ELSE IF FLAGP(CAR U,'BOOLEAN) THEN TYPERR(GETINFIX CAR U,"algebraic operator") ELSE IF GET(CAR U,'INFIX) THEN GO TO E ELSE IF FLAGP(CAR U,'NOCHANGE) THEN RETURN !*SSAVE(SIMP EVAL U,U) ELSE <<REDMSG(CAR U,"operator"); MKOP CAR U; RETURN SIMP U>>; M: IF NOT EQCAR(X,'MAT) THEN REDERR LIST("Matrix",CAR U,"not set") ELSE IF NOT NUMLIS (U := REVLIS CDR U) OR LENGTH U NEQ 2 THEN GO TO E; RETURN !*SSAVE(SIMP NTH(NTH(CDR X,CAR U),CADR U),U); E: IF EQCAR(CAR U,'MAT) THEN <<X := CAR U; GO TO M>> ELSE ERRPRI2(GETINFIX U,T) END; SYMBOLIC PROCEDURE GETINFIX U; %finds infix symbol for U if it exists; BEGIN SCALAR X; RETURN IF X := GET(U,'PRTCH) THEN CAR X ELSE U END; SYMBOLIC PROCEDURE !*SSAVE(U,V); BEGIN ALGLIST!* := (V . U) . ALGLIST!*; RETURN U END; SYMBOLIC PROCEDURE NUMLIS U; NULL U OR (NUMBERP CAR U AND NUMLIS CDR U); SYMBOLIC PROCEDURE SIMPATOM U; IF NULL U THEN NIL ./ 1 ELSE IF NUMBERP U THEN IF ZEROP U THEN NIL ./ 1 ELSE IF NOT FIXP U THEN !*D2Q IF NULL DMODE!* THEN !*FT2RN MKFLOAT U ELSE IF DMODE!* EQ '!:FT!: THEN MKFLOAT U ELSE APPLY(GET('!:FT!:,DMODE!*),LIST MKFLOAT U) ELSE IF DMODE!* AND FLAGP(DMODE!*,'CONVERT) THEN !*D2Q APPLY(GET(DMODE!*,'I2D),LIST U) ELSE U ./ 1 ELSE IF FLAGP(U,'SHARE) THEN SIMP EVAL U ELSE BEGIN SCALAR Z; IF !*NUMVAL AND (Z := GET(U,'DOMAINFN)) THEN <<SETDMODE GET(U,'TARGETMODE); RETURN !*D2Q APPLY(Z,NIL)>>; FOR EACH X IN TYPL!* DO IF APPLY(X,LIST U) THEN TYPERR(U,'scalar); RETURN MKSQ(U,1) END; SYMBOLIC PROCEDURE MKOP U; BEGIN SCALAR X; IF NULL U THEN TYPERR("Local variable","operator") ELSE IF (X := GETTYPE U) EQ 'OPERATOR THEN LPRIM LIST(U,"already defined as operator") ELSE IF X AND NOT X EQ 'PROCEDURE THEN TYPERR(U,'operator) ELSE IF U MEMQ FRLIS!* THEN TYPERR(U,"free variable") ELSE PUT(U,'SIMPFN,'SIMPIDEN) END; SYMBOLIC PROCEDURE SIMPCAR U; SIMP CAR U; PUT('QUOTE,'SIMPFN,'SIMPCAR); FLAGOP SHARE; FLAG('(WS !*MODE),'SHARE); %********************************************************************* % SIMPLIFICATION FUNCTIONS FOR EXPLICIT OPERATORS %********************************************************************; SYMBOLIC PROCEDURE SIMPABS U; (LAMBDA X; ABSF NUMR X ./ DENR X) SIMPCAR U; PUT('ABS,'SIMPFN,'SIMPABS); SYMBOLIC PROCEDURE SIMPEXPT U; BEGIN SCALAR FLG,M,N,X; IF DMODE!* EQ '!:MOD!: THEN <<X := T; DMODE!* := NIL>>; %exponents must not use modular arithmetic; N := SIMP!* CARX(CDR U,'EXPT); IF X THEN DMODE!* := '!:MOD!:; U := CAR U; A: M := NUMR N; IF NOT ATOM M OR DENR N NEQ 1 THEN GO TO NONUMEXP ELSE IF NULL M THEN RETURN IF NUMBERP U AND ZEROP U THEN REDERR " 0**0 formed" ELSE 1 ./ 1 ELSE IF ONEP U THEN RETURN 1 ./ 1; X := SIMP U; %we could use simp!* here, except that it messes up the %handling of gamma matrix expressions; IF !*NUMVAL AND DOMAINP NUMR X AND DOMAINP DENR X AND NOT (ATOM NUMR X AND ATOM DENR X) THEN RETURN NUMEXPT(MK!*SQ X,M,1) ELSE IF NOT M<0 THEN RETURN EXPTSQ(X,M) ELSE IF !*MCD THEN RETURN INVSQ EXPTSQ(X,-M) ELSE RETURN EXPSQ(X,M); %using OFF EXP code here; %there may be a pattern matching problem though; NONUMEXP: IF ONEP U THEN RETURN 1 ./ 1 ELSE IF ATOM U THEN GO TO A2 ELSE IF CAR U EQ 'TIMES THEN <<N := PREPSQ N; X := 1 ./ 1; FOR EACH Z IN CDR U DO X := MULTSQ(SIMPEXPT LIST(Z,N),X); RETURN X>> ELSE IF CAR U EQ 'QUOTIENT THEN <<IF NOT FLG AND !*MCD THEN GO TO A2; N := PREPSQ N; RETURN MULTSQ(SIMPEXPT LIST(CADR U,N), SIMPEXPT LIST(CADDR U,LIST('MINUS,N)))>> ELSE IF CAR U EQ 'EXPT THEN <<N := MULTSQ(SIMP CADDR U,N); U := CADR U; X := NIL; GO TO A>> ELSE IF CAR U EQ 'MINUS AND NUMBERP M AND DENR N=1 THEN RETURN MULTSQ(SIMPEXPT LIST(-1,M), SIMPEXPT LIST(CADR U,M)); A2: IF NULL FLG THEN <<FLG := T; U := PREPSQ IF NULL X THEN (X := SIMP!* U) ELSE X; GO TO NONUMEXP>> ELSE IF NUMBERP U AND ZEROP U THEN RETURN NIL ./ 1 ELSE IF NOT NUMBERP M THEN M := PREPF M; IF M MEMQ FRLIS!* THEN RETURN LIST ((U . M) . 1) . 1; %"power" is not unique here; N := PREPF CDR N; IF !*MCD OR CDR X NEQ 1 OR NOT NUMBERP M OR N NEQ 1 OR ATOM U THEN GO TO C % ELSE IF MINUSF CAR X THEN RETURN MULTSQ(SIMPEXPT LIST(-1,M), % SIMPEXPT LIST(PREPF NEGF CAR X,M)); ELSE IF CAR U EQ 'PLUS OR NOT !*MCD AND N=1 THEN RETURN MKSQ(U,M); %to make pattern matching work; C: IF !*NUMVAL AND NUMTYPEP U AND NUMTYPEP M AND NUMTYPEP N THEN RETURN NUMEXPT(U,M,N) ELSE RETURN SIMPX1(U,M,N) END; SYMBOLIC PROCEDURE NUMEXPT(U,M,N); %U,M and N are all numbers. Result is standard quotient for U**(M/N); BEGIN SCALAR X; RETURN IF X := TARGETCONV(LIST(U,M,N),'BIGFLOAT) THEN !*D2Q IF N=1 AND ATOM M AND FIXP M THEN TEXPT!:(CAR X,M) ELSE TEXPT!:ANY(CAR X, IF N=1 THEN CADR X ELSE BFQUOTIENT!:(CADR X,CADDR X)) ELSE SIMPX1(U,M,N) END; SYMBOLIC PROCEDURE IEXPT(U,N); IF NULL MOD!* THEN U**N ELSE IF N<0 THEN CEXPT(CRECIP U,-N) ELSE CEXPT(U,N); PUT('EXPT,'SIMPFN,'SIMPEXPT); SYMBOLIC PROCEDURE SIMPX1(U,M,N); %U,M and N are prefix expressions; %Value is the standard quotient expression for U**(M/N); BEGIN SCALAR FLG,X,Z; IF NUMBERP M AND NUMBERP N OR NULL SMEMQLP(FRLIS!*,M) OR NULL SMEMQLP(FRLIS!*,N) THEN GO TO A; EXPTP!* := T; RETURN !*K2Q LIST('EXPT,U,IF N=1 THEN M ELSE LIST('QUOTIENT,M,N)); A: IF NUMBERP M THEN IF MINUSP M THEN <<M := -M; GO TO MNS>> ELSE IF FIXP M THEN GO TO E ELSE GO TO B ELSE IF ATOM M THEN GO TO B ELSE IF CAR M EQ 'MINUS THEN <<M := CADR M; GO TO MNS>> ELSE IF CAR M EQ 'PLUS THEN GO TO PLS ELSE IF CAR M EQ 'TIMES AND NUMBERP CADR M AND FIXP CADR M AND NUMBERP N THEN GO TO TMS; B: Z := 1; C: IF IDP U AND NOT FLAGP(U,'USED!*) THEN FLAG(LIST U,'USED!*); U := LIST('EXPT,U,IF N=1 THEN M ELSE LIST('QUOTIENT,M,N)); IF NOT U MEMBER EXPTL!* THEN EXPTL!* := U . EXPTL!*; D: RETURN MKSQ(U,IF FLG THEN -Z ELSE Z); %U is already in lowest %terms; E: IF NUMBERP N AND FIXP N THEN GO TO INT; Z := M; M := 1; GO TO C; MNS: IF !*MCD THEN RETURN INVSQ SIMPX1(U,M,N); FLG := NOT FLG; GO TO A; PLS: Z := 1 ./ 1; PL1: M := CDR M; IF NULL M THEN RETURN Z; Z := MULTSQ(SIMPEXPT LIST(U, LIST('QUOTIENT,IF FLG THEN LIST('MINUS,CAR M) ELSE CAR M,N)), Z); GO TO PL1; TMS: Z := GCDN(N,CADR M); N := N/Z; Z := CADR M/Z; M := RETIMES CDDR M; GO TO C; INT:Z := DIVIDE(M,N); IF CDR Z<0 THEN Z:= (CAR Z - 1) . (CDR Z+N); X := SIMPEXPT LIST(U,CAR Z); IF CDR Z=0 THEN RETURN X ELSE IF N=2 THEN RETURN MULTSQ(X,SIMPSQRT LIST U) ELSE RETURN MULTSQ(X,EXPTSQ(SIMPRAD(SIMP!* U,N),CDR Z)) END; SYMBOLIC PROCEDURE EXPSQ(U,N); %RAISES STANDARD QUOTIENT U TO NEGATIVE POWER N WITH EXP OFF; MULTF(EXPF(NUMR U,N),MKSFPF(DENR U,-N)) ./ 1; SYMBOLIC PROCEDURE EXPF(U,N); %U is a standard form. Value is standard form of U raised to %negative integer power N. MCD is assumed off; %what if U is invertable?; IF NULL U THEN NIL ELSE IF ATOM U THEN MKRN(1,U**(-N)) ELSE IF DOMAINP U THEN !:EXPT(U,N) ELSE IF RED U THEN MKSP!*(U,N) ELSE (LAMBDA X; IF X>0 AND SFP MVAR U THEN MULTF(EXPTF(MVAR U,X),EXPF(LC U,N)) ELSE MVAR U TO X .* EXPF(LC U,N) .+ NIL) (LDEG U*N); SYMBOLIC PROCEDURE SIMPRAD(U,N); %simplifies radical expressions; BEGIN SCALAR X,Y,Z; X := RADF(NUMR U,N); Y := RADF(DENR U,N); Z := MULTSQ(CAR X ./ 1,1 ./ CAR Y); Z := MULTSQ(MULTSQ(MKROOTLF(CDR X,N) ./ 1, 1 ./ MKROOTLF(CDR Y,N)), Z); RETURN Z END; SYMBOLIC PROCEDURE MKROOTLF(U,N); %U is a list of prefix expressions, N an integer. %Value is standard form for U**(1/N); IF NULL U THEN 1 ELSE MULTF(MKROOTF(CAR U,N),MKROOTLF(CDR U,N)); SYMBOLIC PROCEDURE MKROOTF(U,N); %U is a prefix expression, N an integer. %Value is a standard form for U**(1/N); !*P2F IF EQCAR(U,'EXPT) AND FIXP CADDR U THEN MKSP(IF N=2 THEN MKSQRT CADR U ELSE LIST('EXPT,CADR U,LIST('QUOTIENT,1,N)),CADDR U) ELSE MKSP(IF N=2 THEN MKSQRT U ELSE LIST('EXPT,U,LIST('QUOTIENT,1,N)),1); COMMENT The following three procedures return a partitioned root expression, which is a dotted pair of integral part (a standard form) and radical part (a list of prefix expressions). The whole structure represents U**(1/N); SYMBOLIC PROCEDURE RADF(U,N); %U is a standard form, N a positive integer. Value is a partitioned %root expression for U**(1/N); BEGIN SCALAR IPART,RPART,X,Y,!*GCD; IF NULL U THEN RETURN LIST U; !*GCD := T; IPART := 1; WHILE NOT DOMAINP U DO <<Y := COMFAC U; IF CAR Y THEN <<X := DIVIDE(PDEG CAR Y,N); IF CAR X NEQ 0 THEN IPART:=MULTF(!*P2F(MVAR U TO CAR X),IPART); IF CDR X NEQ 0 THEN RPART := MKEXPT(IF SFP MVAR U THEN PREPF MVAR U ELSE MVAR U,CDR X) . RPART>>; X := QUOTF1(U,COMFAC!-TO!-POLY Y); U := CDR Y; IF MINUSF X THEN <<X := NEGF X; U := NEGF U>>; IF X NEQ 1 THEN <<X := RADF1(SQFRF X,N); IPART := MULTF(CAR X,IPART); RPART := APPEND(RPART,CDR X)>>>>; IF U NEQ 1 THEN <<X := RADD(U,N); IPART := MULTF(CAR X,IPART); RPART := APPEND(CDR X,RPART)>>; RETURN IPART . RPART END; SYMBOLIC PROCEDURE RADF1(U,N); %U is a form_power list, N a positive integer. Value is a %partitioned root expression for U**(1/N); BEGIN SCALAR IPART,RPART,X; IPART := 1; FOR EACH Z IN U DO <<X := DIVIDE(CDR Z,N); IF NOT(CAR X=0) THEN IPART := MULTF(EXPTF(CAR Z,CAR X),IPART); IF NOT(CDR X=0) THEN RPART := MKEXPT(PREPSQ!*(CAR Z ./ 1),CDR X) . RPART>>; RETURN IPART . RPART END; SYMBOLIC PROCEDURE RADD(U,N); %U is a domain element, N an integer. %Value is a partitioned root expression for U**(1/N); BEGIN SCALAR IPART,X; IPART := 1; IF NOT ATOM U THEN RETURN LIST(1,U) ELSE IF U<0 THEN IF N=2 THEN <<IPART := !*K2F 'I; U := -U>> ELSE IF REMAINDER(N,2)=1 THEN <<IPART := -1; U := -U>> ELSE RETURN LIST(1,U); X := NROOTN(U,N); RETURN IF CDR X=1 THEN LIST MULTD(CAR X,IPART) ELSE LIST(MULTD(CAR X,IPART),CDR X) END; SYMBOLIC PROCEDURE IROOT(M,N); %M and N are positive integers. %If M**(1/N) is an integer, this value is returned, otherwise NIL; BEGIN SCALAR X,X1,BK; IF M=0 THEN RETURN M; X := 10**CEILING(LENGTHC M,N); %first guess; A: X1 := X**(N-1); BK := X-M/X1; IF BK<0 THEN RETURN NIL ELSE IF BK=0 THEN RETURN IF X1*X=M THEN X ELSE NIL; X := X-CEILING(BK,N); GO TO A END; SYMBOLIC PROCEDURE CEILING(M,N); %M and N are positive integers. Value is ceiling of (M/N) (i.e., %least integer greater or equal to M/N); (LAMBDA X; IF CDR X=0 THEN CAR X ELSE CAR X+1) DIVIDE(M,N); SYMBOLIC PROCEDURE MKEXPT(U,N); IF N=1 THEN U ELSE LIST('EXPT,U,N); SYMBOLIC PROCEDURE NROOTN(N,X); %N is an integer, X a positive integer. Value is a pair %of integers I,J such that I*J**(1/X)=N**(1/X); BEGIN SCALAR I,J,R,SIGNN; R := 1; IF N<0 THEN <<N := -N; IF REMAINDER(X,2)=0 THEN SIGNN := T ELSE R := -1>>; J := 2**X; WHILE REMAINDER(N,J)=0 DO <<N := N/J; R := R*2>>; I := 3; J := 3**X; WHILE J<=N DO <<WHILE REMAINDER(N,J)=0 DO <<N := N/J; R := R*I>>; IF REMAINDER(I,3)=1 THEN I := I+4 ELSE I := I+2; J := I**X>>; IF SIGNN THEN N := -N; RETURN R . N END; SYMBOLIC PROCEDURE SIMPIDEN U; BEGIN SCALAR Y,Z; U:= REVOP1 U; IF FLAGP(CAR U,'NONCOM) THEN NCMP!* := T; IF NULL SUBFG!* THEN GO TO C ELSE IF FLAGP(CAR U,'LINEAR) AND (Z := FORMLNR U) NEQ U THEN RETURN SIMP Z ELSE IF Z := OPMTCH U THEN RETURN SIMP Z ELSE IF Z := NUMVALCHK U THEN RETURN Z; C: IF FLAGP(CAR U,'SYMMETRIC) THEN U := CAR U . ORDN CDR U ELSE IF FLAGP(CAR U,'ANTISYMMETRIC) THEN <<IF REPEATS CDR U THEN RETURN (NIL ./ 1) ELSE IF NOT PERMP(Z:= ORDN CDR U,CDR U) THEN Y := T; U := CAR U . Z>>; U := MKSQ(U,1); RETURN IF Y THEN NEGSQ U ELSE U END; SYMBOLIC PROCEDURE NUMVALCHK U; BEGIN SCALAR Y,Z; IF NULL !*NUMVAL THEN RETURN NIL ELSE IF ATOM U THEN RETURN NIL ELSE IF (Z := GET(CAR U,'DOMAINFN)) AND DOMAINLISP CDR U AND (Y := TARGETCONV(CDR U,GET(CAR U,'TARGETMODE))) THEN <<SETDMODE GET(CAR U,'TARGETMODE); RETURN !*D2Q APPLY(Z,Y)>> ELSE RETURN NIL END; SYMBOLIC PROCEDURE NUMTYPEP U; %returns true if U is a possible number, NIL otherwise; IF ATOM U THEN NUMBERP U ELSE IF GET(CAR U,'DNAME) THEN U ELSE IF CAR U EQ 'MINUS THEN NUMTYPEP CADR U ELSE IF CAR U EQ 'QUOTIENT THEN NUMTYPEP CADR U AND NUMTYPEP CADDR U ELSE NIL; SYMBOLIC PROCEDURE DOMAINLISP U; %true if U is a list of domain element numbers, NIL otherwise; IF NULL U THEN T ELSE NUMTYPEP CAR U AND DOMAINLISP CDR U; SYMBOLIC PROCEDURE TARGETCONV(U,V); %U is a list of domain elements, V a domain mode; %if all elements of U can be converted to mode V, a list of the %converted elements is returned, otherwise NIL is returned; BEGIN SCALAR X,Y,Z; V := GET(V,'TAG); A: IF NULL U THEN RETURN REVERSIP X ELSE IF ATOM (Z := NUMR SIMPCAR U) THEN X := APPLY(GET(V,'I2D),LIST IF NULL Z THEN 0 ELSE Z) . X ELSE IF CAR Z EQ V THEN X := Z . X ELSE IF Y := GET(CAR Z,V) THEN X := APPLY(Y,LIST Z) . X ELSE RETURN NIL; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE SIMPDIFF U; ADDSQ(SIMPCAR U,SIMPMINUS CDR U); PUT('DIFFERENCE,'SIMPFN,'SIMPDIFF); SYMBOLIC PROCEDURE SIMPMINUS U; NEGSQ SIMP CARX(U,'MINUS); PUT('MINUS,'SIMPFN,'SIMPMINUS); SYMBOLIC PROCEDURE SIMPPLUS U; BEGIN SCALAR Z; Z := NIL ./ 1; A: IF NULL U THEN RETURN Z; Z := ADDSQ(SIMPCAR U,Z); U := CDR U; GO TO A END; PUT('PLUS,'SIMPFN,'SIMPPLUS); SYMBOLIC PROCEDURE SIMPQUOT U; MULTSQ(SIMPCAR U,SIMPRECIP CDR U); PUT('QUOTIENT,'SIMPFN,'SIMPQUOT); SYMBOLIC PROCEDURE SIMPRECIP U; IF NULL !*MCD THEN SIMPEXPT LIST(CARX(U,'RECIP),-1) ELSE INVSQ SIMP CARX( U,'RECIP); PUT('RECIP,'SIMPFN,'SIMPRECIP); SYMBOLIC PROCEDURE SIMPSQRT U; BEGIN SCALAR X,Y; X := XSIMP CAR U; RETURN IF !*NUMVAL AND (Y := NUMVALCHK MKSQRT PREPSQ!* X) THEN Y ELSE SIMPRAD(X,2) END; SYMBOLIC PROCEDURE XSIMP U; EXPCHK SIMP!* U; SYMBOLIC PROCEDURE SIMPTIMES U; BEGIN SCALAR X,Y; IF TSTACK!* NEQ 0 OR NULL MUL!* THEN GO TO A0; Y := MUL!*; MUL!* := NIL; A0: TSTACK!* := TSTACK!*+1; X := SIMPCAR U; A: U := CDR U; IF NULL NUMR X THEN GO TO C ELSE IF NULL U THEN GO TO B; X := MULTSQ(X,SIMPCAR U); GO TO A; B: IF NULL MUL!* OR TSTACK!*>1 THEN GO TO C; X:= APPLY(CAR MUL!*,LIST X); MUL!*:= CDR MUL!*; GO TO B; C: TSTACK!* := TSTACK!*-1; IF TSTACK!* = 0 THEN MUL!* := Y; RETURN X; END; PUT('TIMES,'SIMPFN,'SIMPTIMES); SYMBOLIC PROCEDURE SIMPSUB U; BEGIN SCALAR X,Z,Z1; A: IF NULL CDR U THEN GO TO D ELSE IF NOT EQEXPR CAR U THEN ERRPRI2(CAR U,T); X := CADAR U; Z1 := TYPL!*; B: IF NULL Z1 THEN GO TO B1 ELSE IF APPLY(CAR Z1,LIST X) THEN GO TO C; Z1 := CDR Z1; GO TO B; B1: X := !*A2K X; C: Z := (X . CADDAR U) . Z; U := CDR U; GO TO A; D: U := SIMP!* CAR U; RETURN QUOTSQ(SUBF(NUMR U,Z),SUBF(DENR U,Z)) END; SYMBOLIC PROCEDURE RESIMP U; %U is a standard quotient. %Value is the resimplified standard quotient; QUOTSQ(SUBF1(NUMR U,NIL),SUBF1(DENR U,NIL)); PUT('SUB,'SIMPFN,'SIMPSUB); SYMBOLIC PROCEDURE EQEXPR U; NOT ATOM U AND CAR U MEMQ '(EQ EQUAL) AND CDDR U AND NULL CDDDR U; SYMBOLIC PROCEDURE SIMP!*SQ U; IF NULL CADR U THEN RESIMP CAR U ELSE CAR U; PUT('!*SQ,'SIMPFN,'SIMP!*SQ); %********************************************************************* % FUNCTIONS FOR DEFINING AND MANIPULATING POLYNOMIAL DOMAIN MODES %********************************************************************; GLOBAL '(DMODE!* DOMAINLIST!*); SYMBOLIC PROCEDURE INITDMODE U; %checks that U is a valid domain mode, and sets up appropriate %interfaces to the system; BEGIN DMODECHK U; PUT(U,'SIMPFG,LIST(LIST(T,LIST('SETDMODE,MKQUOTE U)), '(NIL (SETDMODE NIL)))) END; SYMBOLIC PROCEDURE SETDMODE U; %Sets polynomial domain mode to U. If U is NIL, integers are used; BEGIN SCALAR X; IF NULL U THEN RETURN <<RMSUBS(); DMODE!* := NIL>> ELSE IF NULL(X := GET(U,'TAG)) THEN REDERR LIST("Domain mode error:",U,"is not a domain mode") ELSE IF DMODE!* EQ X THEN RETURN NIL; RMSUBS(); IF DMODE!* THEN LPRIM LIST("Domain mode", GET(DMODE!*,'DNAME),"changed to",U); IF U := GET(U,'MODULE!-NAME) THEN LOAD!-MODULE U; DMODE!* := X END; SYMBOLIC PROCEDURE DMODECHK U; %checks to see if U has complete specification for a domain mode; BEGIN SCALAR Z; IF NOT(Z := GET(U,'TAG)) THEN REDERR LIST("Domain mode error:","No tag for",Z) ELSE IF NOT(GET(Z,'DNAME) EQ U) THEN REDERR LIST("Domain mode error:", "Inconsistent or missing DNAME for",Z) ELSE IF NOT Z MEMQ DOMAINLIST!* THEN REDERR LIST("Domain mode error:", Z,"not on domain list"); U := Z; FOR EACH X IN DOMAINLIST!* DO IF U=X THEN NIL ELSE IF NOT(GET(U,X) OR GET(X,U)) THEN REDERR LIST("Domain mode error:", "No conversion defined between",U,"and",X); Z := '(DIFFERENCE I2D MINUSP PLUS PREPFN QUOTIENT SPECPRN TIMES ZEROP); IF NOT FLAGP(U,'FIELD) THEN Z := 'DIVIDE . 'GCD . Z; FOR EACH X IN Z DO IF NOT GET(U,X) THEN REDERR LIST("Domain mode error:", X,"is not defined for",U) END; COMMENT *** General Support Functions ***; SYMBOLIC PROCEDURE !*D2Q U; %converts domain element U into a standard quotient; IF EQCAR(U,'!:RN!:) AND !*MCD THEN CDR U ELSE U ./ 1; SYMBOLIC PROCEDURE FIELDP U; %U is a domain element. Value is T if U is invertable, NIL %otherwise; NOT ATOM U AND FLAGP(CAR U,'FIELD); SYMBOLIC PROCEDURE !:EXPT(U,N); %raises domain element U to power N. Value is a domain element; IF NULL U THEN IF N=0 THEN REDERR "0/0 formed" ELSE NIL ELSE IF N=0 THEN 1 ELSE IF N<0 THEN !:RECIP !:EXPT(IF NOT FIELDP U THEN MKRATNUM U ELSE U,-N) ELSE IF ATOM U THEN U**N ELSE BEGIN SCALAR V,W,X; V := APPLY(GET(CAR U,'I2D),LIST 1); %unit element; X := GET(CAR U,'TIMES); A: W := DIVIDE(N,2); IF CDR W=1 THEN V := APPLY(X,LIST(U,V)); IF CAR W=0 THEN RETURN V; U := APPLY(X,LIST(U,U)); N := CAR W; GO TO A END; SYMBOLIC PROCEDURE !:MINUS U; %U is a domain element. Value is -U; IF ATOM U THEN -U ELSE DCOMBINE(U,-1,'TIMES); SYMBOLIC PROCEDURE !:MINUSP U; IF ATOM U THEN MINUSP U ELSE APPLY(GET(CAR U,'MINUSP),LIST U); GLOBAL '(!:PREC!:); SYMBOLIC PROCEDURE !:ONEP U; %Allow for round-up of two in the last place in bigfloats; IF ATOM U THEN U=1 ELSE IF !:ZEROP DCOMBINE(U,1,'DIFFERENCE) THEN T ELSE CAR U EQ '!:BF!: AND !:ZEROP DCOMBINE(BFPLUS!:(U,'!:BF!: . 2 . -!:PREC!:), 1,'DIFFERENCE); SYMBOLIC PROCEDURE !:RECIP U; %U is an invertable domain element. Value is 1/U; IF NUMBERP U AND ABS U=1 THEN U ELSE DCOMBINE(1,U,'QUOTIENT); SYMBOLIC PROCEDURE !:ZEROP U; %returns T if domain element U is 0, NIL otherwise; IF ATOM U THEN U=0 ELSE APPLY(GET(CAR U,'ZEROP),LIST U); SYMBOLIC PROCEDURE DCOMBINE(U,V,FN); %U and V are domain elements, but not both atoms (integers). %FN is a binary function on domain elements; %Value is the domain element representing FN(U,V); IF ATOM U THEN APPLY(GET(CAR V,FN),LIST(APPLY(GET(CAR V,'I2D),LIST U),V)) ELSE IF ATOM V THEN APPLY(GET(CAR U,FN),LIST(U,APPLY(GET(CAR U,'I2D),LIST V))) ELSE IF CAR U EQ CAR V THEN APPLY(GET(CAR U,FN),LIST(U,V)) ELSE BEGIN SCALAR X; IF NOT(X := GET(CAR U,CAR V)) THEN <<V := APPLY(GET(CAR V,CAR U),LIST V); X := GET(CAR U,FN)>> ELSE <<U := APPLY(X,LIST U); X := GET(CAR V,FN)>>; RETURN APPLY(X,LIST(U,V)) END; COMMENT *** Tables for Various domain arithmetics ***: Syntactically, such elements have the following form: <domain element> := integer|(<domain identifier> . <domain structure>). To introduce a new domain, we need to define: 1) A conversion function from integer to the given mode. 2) A conversion function from new mode to or from every other mode. 3) Particular instance of the binary operations +,- and * for this mode. 4) Particular instance of ZEROP, MINUSP for this mode. 5) If domain is a field, a quotient must be defined. If domain is a ring, a gcd and divide must be defined, and also a quotient function which returns NIL if the division fails. 6) A printing function for this mode. 7) A function to convert structure to an appropriate prefix form. 8) A reading function for this mode. 9) A DNAME property for the tag, and a TAG property for the DNAME To facilitate this, all such modes should be listed in the global variable DOMAINLIST!*; COMMENT *** Tables for rational numbers ***; FLUID '(!*RATIONAL); DOMAINLIST!* := UNION('(!:RN!:),DOMAINLIST!*); PUT('RATIONAL,'TAG,'!:RN!:); PUT('!:RN!:,'DNAME,'RATIONAL); FLAG('(!:RN!:),'FIELD); PUT('!:RN!:,'I2D,'!*I2RN); PUT('!:RN!:,'MINUSP,'RNMINUSP!:); PUT('!:RN!:,'PLUS,'RNPLUS!:); PUT('!:RN!:,'TIMES,'RNTIMES!:); PUT('!:RN!:,'DIFFERENCE,'RNDIFFERENCE!:); PUT('!:RN!:,'QUOTIENT,'RNQUOTIENT!:); PUT('!:RN!:,'ZEROP,'RNZEROP!:); PUT('!:RN!:,'PREPFN,'RNPREP!:); PUT('!:RN!:,'SPECPRN,'RNPRIN); SYMBOLIC PROCEDURE MKRATNUM U; %U is a domain element. Value is equivalent rational number; IF ATOM U THEN !*I2RN U ELSE APPLY(GET(CAR U,'!:RN!:),LIST U); SYMBOLIC PROCEDURE MKRN(U,V); %converts two integers U and V into a rational number, an integer %or NIL; IF U=0 THEN NIL ELSE IF V<0 THEN MKRN(-U,-V) ELSE (LAMBDA M; (LAMBDA (N1,N2); IF N2=1 THEN N1 ELSE '!:RN!: . (N1 . N2)) (U/M,V/M)) GCDN(U,V); SYMBOLIC PROCEDURE !*I2RN U; %converts integer U to rational number; '!:RN!: . (U . 1); SYMBOLIC PROCEDURE RNMINUSP!: U; CADR U<0; SYMBOLIC PROCEDURE RNPLUS!:(U,V); MKRN(CADR U*CDDR V+CDDR U*CADR V,CDDR U*CDDR V); SYMBOLIC PROCEDURE RNTIMES!:(U,V); MKRN(CADR U*CADR V,CDDR U*CDDR V); SYMBOLIC PROCEDURE RNDIFFERENCE!:(U,V); MKRN(CADR U*CDDR V-CDDR U*CADR V,CDDR U*CDDR V); SYMBOLIC PROCEDURE RNQUOTIENT!:(U,V); MKRN(CADR U*CDDR V,CDDR U*CADR V); SYMBOLIC PROCEDURE RNZEROP!: U; CADR U=0; SYMBOLIC PROCEDURE RNPREP!: U; IF CDDR U=1 THEN CADR U ELSE LIST('QUOTIENT,CADR U,CDDR U); SYMBOLIC PROCEDURE RNPRIN U; MAPRIN RNPREP!: U; INITDMODE 'RATIONAL; COMMENT *** Tables for floats ***; DOMAINLIST!* := UNION('(!:FT!:),DOMAINLIST!*); PUT('FLOAT,'TAG,'!:FT!:); PUT('!:FT!:,'DNAME,'FLOAT); FLAG('(!:FT!:),'FIELD); PUT('!:FT!:,'I2D,'!*I2FT); PUT('!:FT!:,'!:RN!:,'!*FT2RN); PUT('!:FT!:,'MINUSP,'FTMINUSP!:); PUT('!:FT!:,'PLUS,'FTPLUS!:); PUT('!:FT!:,'TIMES,'FTTIMES!:); PUT('!:FT!:,'DIFFERENCE,'FTDIFFERENCE!:); PUT('!:FT!:,'QUOTIENT,'FTQUOTIENT!:); PUT('!:FT!:,'ZEROP,'FTZEROP!:); PUT('!:FT!:,'PREPFN,'FTPREP!:); PUT('!:FT!:,'SPECPRN,'PRIN2!*); SYMBOLIC PROCEDURE MKFLOAT U; '!:FT!: . U; SYMBOLIC PROCEDURE !*I2FT U; %converts integer U to floating point form or NIL; IF U=0 THEN NIL ELSE '!:FT!: . FLOAT U; SYMBOLIC PROCEDURE !*FT2RN U; BEGIN INTEGER M; SCALAR X; U := CDR U; %pick up actual number; M := FIX(1000000*U); X := GCDN(1000000,M); X := (M/X) . (1000000/X); MSGPRI(NIL,U,"represented by",LIST('QUOTIENT,CAR X,CDR X),NIL); RETURN '!:RN!: . X END; SYMBOLIC PROCEDURE FTMINUSP!: U; CDR U<0; SYMBOLIC PROCEDURE FTPLUS!:(U,V); (LAMBDA X; IF ABS(X/CDR U)<0.000001 AND ABS(X/CDR V)<0.000001 THEN 0 ELSE '!:FT!: . X) (CDR U+CDR V); SYMBOLIC PROCEDURE FTTIMES!:(U,V); CAR U . (CDR U*CDR V); SYMBOLIC PROCEDURE FTDIFFERENCE!:(U,V); CAR U .(CDR U-CDR V); SYMBOLIC PROCEDURE FTQUOTIENT!:(U,V); CAR U . (CDR U/CDR V); SYMBOLIC PROCEDURE FTZEROP!: U; CDR U=0.0; SYMBOLIC PROCEDURE FTPREP!: U; CDR U; INITDMODE 'FLOAT; COMMENT *** Entry points for the bigfloat package ***; FLUID '(!*BIGFLOAT); PUT('BIGFLOAT,'SIMPFG,'((T (RMSUBS) (SETDMODE (QUOTE BIGFLOAT))) (NIL (SETDMODE NIL)))); PUT('NUMVAL,'SIMPFG,'((T (RMSUBS) (SETDMODE (QUOTE BIGFLOAT))))); PUT('BIGFLOAT,'TAG,'!:BF!:); COMMENT *** Tables for modular integers ***; FLUID '(!*MODULAR); DOMAINLIST!* := UNION('(!:MOD!:),DOMAINLIST!*); PUT('MODULAR,'TAG,'!:MOD!:); PUT('!:MOD!:,'DNAME,'MODULAR); FLAG('(!:MOD!:),'FIELD); FLAG('(!:MOD!:),'CONVERT); PUT('!:MOD!:,'I2D,'!*I2MOD); PUT('!:MOD!:,'!:BF!:,'MODCNV); PUT('!:MOD!:,'!:FT!:,'MODCNV); PUT('!:MOD!:,'!:RN!:,'MODCNV); PUT('!:MOD!:,'MINUSP,'MODMINUSP!:); PUT('!:MOD!:,'PLUS,'MODPLUS!:); PUT('!:MOD!:,'TIMES,'MODTIMES!:); PUT('!:MOD!:,'DIFFERENCE,'MODDIFFERENCE!:); PUT('!:MOD!:,'QUOTIENT,'MODQUOTIENT!:); PUT('!:MOD!:,'ZEROP,'MODZEROP!:); PUT('!:MOD!:,'PREPFN,'MODPREP!:); PUT('!:MOD!:,'SPECPRN,'MODPRIN); SYMBOLIC PROCEDURE !*I2MOD U; %converts integer U to modular form; IF (U := CMOD U)=0 THEN NIL ELSE '!:MOD!: . U; SYMBOLIC PROCEDURE MODCNV U; REDERR LIST("Conversion between modular integers and", GET(CAR U,'DNAME),"not defined"); SYMBOLIC PROCEDURE MODMINUSP!: U; NIL; %what else can one do?; SYMBOLIC PROCEDURE MODPLUS!:(U,V); (LAMBDA X; IF X=0 THEN NIL ELSE IF X=1 THEN 1 ELSE CAR U . X) CPLUS(CDR U,CDR V); SYMBOLIC PROCEDURE MODTIMES!:(U,V); (LAMBDA X; IF X=1 THEN 1 ELSE CAR U . X) CTIMES(CDR U,CDR V); SYMBOLIC PROCEDURE MODDIFFERENCE!:(U,V); CAR U . CPLUS(CDR U,MOD!*-CDR V); SYMBOLIC PROCEDURE MODQUOTIENT!:(U,V); CAR U . CTIMES(CDR U,CRECIP CDR V); SYMBOLIC PROCEDURE MODZEROP!: U; CDR U=0; SYMBOLIC PROCEDURE MODPREP!: U; CDR U; SYMBOLIC PROCEDURE MODPRIN U; PRIN2!* CDR U; INITDMODE 'MODULAR; %********************************************************************* % FUNCTIONS FOR MODULAR ARITHMETIC %********************************************************************; COMMENT This section defines routines for modular integer arithmetic. It assumes that such numbers are normalized in the range 0<=n<p, where p is the modular base; COMMENT The actual modulus is stored in MOD!*; SYMBOLIC PROCEDURE CEXPT(M,N); %returns the normalized value of M**N; BEGIN INTEGER P; P := 1; WHILE N>0 DO <<IF REMAINDER(N,2)=1 THEN P := CTIMES(P,M); N := N/2; IF N>0 THEN M := CTIMES(M,M)>>; RETURN P END; SYMBOLIC PROCEDURE CPLUS(M,N); %returns the normalized sum of U and V; (LAMBDA L; IF L>=MOD!* THEN L-MOD!* ELSE L) (M+N); SYMBOLIC PROCEDURE CMINUS(M); %returns the negative of M; IF M=0 THEN M ELSE MOD!*-M; SYMBOLIC PROCEDURE CDIF(M,N); %returns the normalized difference of M and N; (LAMBDA L; IF L<0 THEN L+MOD!* ELSE L) (M-N); SYMBOLIC PROCEDURE CRECIP M; %returns the normalized reciprocal of M modulo MOD!* %provided M is non-zero mod MOD!*, and M and MOD!* are co-prime. %If not, an error results; CRECIP1(MOD!*,M,0,1); SYMBOLIC PROCEDURE CRECIP1(A,B,X,Y); %This is essentially the same as RECIPROCAL-BY-GCD in the Norman/ %Moore factorizer; IF B=0 THEN REDERR "Invalid modular division" ELSE IF B=1 THEN IF Y<0 THEN Y+MOD!* ELSE Y ELSE BEGIN SCALAR W; W := A/B; %truncated integer division; RETURN CRECIP1(B,A-B*W,Y,X-Y*W) END; SYMBOLIC PROCEDURE CTIMES(M,N); %returns the normalized product of M and N; REMAINDER(M*N,MOD!*); SYMBOLIC PROCEDURE SETMOD U; %always returns value of MOD!* on entry. %if U=0, no other action, otherwise MOD!* is set to U; IF U=0 THEN MOD!* ELSE (LAMBDA N; <<MOD!* := U; N>>) MOD!*; FLAG('(SETMOD),'OPFN); %to make it a symbolic operator; SYMBOLIC PROCEDURE CMOD M; %returns normalized M; (LAMBDA N; IF N<0 THEN N+MOD!* ELSE N) REMAINDER(M,MOD!*); %A more general definition; %SYMBOLIC PROCEDURE CMOD M; %returns normalized M; % (LAMBDA N; %IF N<0 THEN N+MOD!* ELSE N) % IF ATOM M THEN REMAINDER(M,MOD!*) % ELSE BEGIN SCALAR X; % X := DCOMBINE(M,MOD!*,'DIVIDE); % RETURN CDR X % END; %********************************************************************* % FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD QUOTIENTS %********************************************************************; SYMBOLIC PROCEDURE ADDSQ(U,V); %U and V are standard quotients. %Value is canonical sum of U and V; IF NULL NUMR U THEN V ELSE IF NULL NUMR V THEN U ELSE IF DENR U=1 AND DENR V=1 THEN ADDF(NUMR U,NUMR V) ./ 1 ELSE BEGIN SCALAR X,Y,Z; IF NULL !*EXP THEN <<U := NUMR U ./ MKPROD!* DENR U; V := NUMR V ./ MKPROD!* DENR V>>; IF !*LCM THEN X := GCDF!*(DENR U,DENR V) ELSE X := GCDF(DENR U,DENR V); Z := CANSQ1(QUOTF(DENR U,X) ./ QUOTF(DENR V,X)); Y := ADDF(MULTF(NUMR U,DENR Z),MULTF(NUMR V,NUMR Z)); IF NULL Y THEN RETURN NIL ./ 1; Z := MULTF(DENR U,DENR Z); IF ONEP X THEN RETURN Y ./ Z; X := GCDF(Y,X); RETURN IF X=1 THEN Y ./ Z ELSE CANSQ1(QUOTF(Y,X) ./ QUOTF(Z,X)) END; SYMBOLIC PROCEDURE MULTSQ(U,V); %U and V are standard quotients. %Value is canonical product of U and V; IF NULL NUMR U OR NULL NUMR V THEN NIL ./ 1 ELSE IF DENR U=1 AND DENR V=1 THEN MULTF(NUMR U,NUMR V) ./ 1 ELSE BEGIN SCALAR X,Y; X := GCDF(NUMR U,DENR V); Y := GCDF(NUMR V,DENR U); RETURN CANSQ1(MULTF(QUOTF(NUMR U,X),QUOTF(NUMR V,Y)) ./ MULTF(QUOTF(DENR U,Y),QUOTF(DENR V,X))) END; SYMBOLIC PROCEDURE NEGSQ U; NEGF NUMR U ./ DENR U; SMACRO PROCEDURE MULTPQ(U,V); MULTSQ(!*P2Q U,V); SYMBOLIC PROCEDURE CANCEL U; %returns canonical form of non-canonical standard form U; IF !*MCD OR DENR U=1 THEN CANONSQ MULTSQ(NUMR U ./ 1,1 ./ DENR U) ELSE MULTSQ(NUMR U ./ 1,SIMPEXPT LIST(MK!*SQ(DENR U ./ 1),-1)); %********************************************************************* % FUNCTIONS FOR ADDING AND MULTIPLYING STANDARD FORMS %********************************************************************; SYMBOLIC SMACRO PROCEDURE PEQ(U,V); %tests for equality of powers U and V; U = V; SYMBOLIC PROCEDURE ADDF(U,V); %U and V are standard forms. Value is standard form for U+V; IF NULL U THEN V ELSE IF NULL V THEN U ELSE IF DOMAINP U THEN ADDD(U,V) ELSE IF DOMAINP V THEN ADDD(V,U) ELSE IF PEQ(LPOW U,LPOW V) THEN (LAMBDA (X,Y); IF NULL X THEN Y ELSE LPOW U .* X .+ Y) (ADDF(LC U,LC V),ADDF(RED U,RED V)) ELSE IF ORDPP(LPOW U,LPOW V) THEN LT U .+ ADDF(RED U,V) ELSE LT V .+ ADDF(U,RED V); SYMBOLIC PROCEDURE ADDD(U,V); %U is a domain element, V a standard form. %Value is a standard form for U+V; IF NULL V THEN U ELSE IF DOMAINP V THEN ADDDM(U,V) ELSE LT V .+ ADDD(U,RED V); SYMBOLIC PROCEDURE ADDDM(U,V); %U and V are both domain elements. %Value is standard form for U+V; IF ATOM U AND ATOM V THEN !*N2F PLUS2(U,V) ELSE BEGIN SCALAR X; RETURN IF !:ZEROP(X := DCOMBINE(U,V,'PLUS)) THEN NIL ELSE X END; SYMBOLIC PROCEDURE DOMAINP U; ATOM U OR ATOM CAR U; SYMBOLIC PROCEDURE NONCOMP U; NOT ATOM U AND FLAGP!*!*(CAR U,'NONCOM); SYMBOLIC PROCEDURE MULTF(U,V); %U and V are standard forms. %Value is standard form for U*V; BEGIN SCALAR X,Y; A: IF NULL U OR NULL V THEN RETURN NIL ELSE IF ONEP U THEN RETURN V ELSE IF ONEP V THEN RETURN U ELSE IF DOMAINP U THEN RETURN MULTD(U,V) ELSE IF DOMAINP V THEN RETURN MULTD(V,U) ELSE IF NOT(!*EXP OR NCMP!* OR WTL!* OR X) THEN <<U := MKPROD U; V := MKPROD V; X := T; GO TO A>>; X := MVAR U; Y := MVAR V; IF NONCOMP X AND NONCOMP Y THEN RETURN MULTFNC(U,V) ELSE IF X EQ Y THEN <<X := MKSPM(X,LDEG U+LDEG V); Y := ADDF(MULTF(!*T2F LT U,RED V),MULTF(RED U,V)); RETURN IF NULL X OR NULL(U := MULTF(LC U,LC V)) THEN Y ELSE IF NULL !*MCD THEN ADDF(IF X=1 THEN U ELSE !*T2F(X .* U),Y) ELSE X .* U .+ Y>> ELSE IF ORDOP(X,Y) THEN <<X := MULTF(LC U,V); Y := MULTF(RED U,V); RETURN IF NULL X THEN Y ELSE LPOW U .* X .+ Y>>; X := MULTF(U,LC V); Y := MULTF(U,RED V); RETURN IF NULL X THEN Y ELSE LPOW V .* X .+ Y END; SYMBOLIC PROCEDURE MULTFNC(U,V); %returns canonical product of U and V, with both main vars non- %commutative; BEGIN SCALAR X,Y; X := MULTF(LC U,!*T2F LT V); RETURN ADDF((IF NOT DOMAINP X AND MVAR X EQ MVAR U THEN ADDF(!*T2F(MKSPM(MVAR U,LDEG U+LDEG V) .* LC X), MULTF(!*P2F LPOW U,RED X)) ELSE !*T2F(LPOW U .* X)), ADDF(MULTF(RED U,V),MULTF(!*T2F LT U,RED V))) END; SYMBOLIC PROCEDURE MULTD(U,V); %U is a domain element, V a standard form. %Value is standard form for U*V; IF NULL V THEN NIL ELSE IF DOMAINP V THEN MULTDM(U,V) ELSE LPOW V .* MULTD(U,LC V) .+ MULTD(U,RED V); SYMBOLIC PROCEDURE MULTDM(U,V); %U and V are both domain elements. Value is standard form for U*V; IF ATOM U AND ATOM V THEN TIMES2(U,V) ELSE BEGIN SCALAR X; RETURN IF !:ONEP(X := DCOMBINE(U,V,'TIMES)) THEN 1 ELSE X END; SMACRO PROCEDURE MULTPF(U,V); MULTF(!*P2F U,V); GLOBAL '(!*FACTOR); %used to call a factorizing routine if it exists; SYMBOLIC PROCEDURE MKPROD U; BEGIN SCALAR W,X,Y,Z,!*EXP; IF NULL U OR KERNLP U THEN RETURN U; %first make sure there are no further simplifications; IF DENR(X := SUBS2(U ./ 1)) = 1 AND NUMR X NEQ U THEN <<U := NUMR X; IF NULL U OR KERNLP U THEN RETURN U>>; !*EXP := T; W := CKRN U; U := QUOTF(U,W); X := EXPND U; IF NULL X OR KERNLP X THEN RETURN MULTF(W,X); %after this point, U is not KERNLP; IF !*FACTOR OR !*GCD THEN Y := FCTRF X ELSE <<Y := CKRN X; X := QUOTF(X,Y); Y := LIST(Y,X . 1)>>; IF CDADR Y>1 OR CDDR Y THEN <<Z := CAR Y; FOR EACH J IN CDR Y DO Z := MULTF(MKSP!*(CAR J,CDR J),Z)>> ELSE IF NOT !*GROUP AND TMSF U>TMSF CAADR Y THEN Z := MULTF(MKSP!*(CAADR Y,CDADR Y),CAR Y) ELSE Z := MKSP!*(U,1); RETURN MULTF(W,Z) END; SYMBOLIC PROCEDURE MKSP!*(U,N); %Returns a standard form for U**N, in which U is first made %positive and then converted into a kernel; BEGIN SCALAR B; IF MINUSF U THEN <<B := T; U := NEGF U>>; U := !*P2F MKSP(U,N); RETURN IF B AND NOT ZEROP REMAINDER(N,2) THEN NEGF U ELSE U END; SYMBOLIC PROCEDURE TMSF U; %U is a standard form. %Value is number of terms in U (including kernel structure); BEGIN INTEGER N; SCALAR X; N := 0; A: IF NULL U THEN RETURN N ELSE IF DOMAINP U THEN RETURN N+1; N := N+(IF SFP(X := MVAR U) THEN TMSF X ELSE 1)+TMSF!* LC U; IF LDEG U NEQ 1 THEN N := N+2; U := RED U; IF U THEN N := N+1; GO TO A END; SYMBOLIC PROCEDURE TMSF!* U; IF NUMBERP U AND ABS FIX U=1 THEN 0 ELSE TMSF U+1; SYMBOLIC PROCEDURE TMS U; TMSF NUMR SIMP!* U; FLAG('(TMS),'OPFN); FLAG('(TMS),'NOVAL); SYMBOLIC PROCEDURE EXPND U; IF DOMAINP U THEN U ELSE ADDF(IF NOT SFP MVAR U OR LDEG U<0 THEN MULTPF(LPOW U,EXPND LC U) ELSE MULTF(EXPTF(EXPND MVAR U,LDEG U),EXPND LC U), EXPND RED U); SYMBOLIC PROCEDURE MKPROD!* U; IF DOMAINP U THEN U ELSE MKPROD U; SYMBOLIC PROCEDURE CANPROD(P,Q); %P and Q are kernel product standard forms, value is P/Q; BEGIN SCALAR V,W,X,Y,Z; IF DOMAINP Q THEN RETURN CANCEL(P ./ Q); WHILE NOT DOMAINP P OR NOT DOMAINP Q DO IF SFPF P THEN <<Z := CPROD1(MVAR P,LDEG P,V,W); V := CAR Z; W := CDR Z; P := LC P>> ELSE IF SFPF Q THEN <<Z := CPROD1(MVAR Q,LDEG Q,W,V); W := CAR Z; V := CDR Z; Q := LC Q>> ELSE IF DOMAINP P THEN <<Y := LPOW Q . Y; Q := LC Q>> ELSE IF DOMAINP Q THEN <<X := LPOW P . X; P := LC P>> ELSE <<X := LPOW P . X; Y := LPOW Q . Y; P := LC P; Q := LC Q>>; V := REPROD(V,REPROD(X,P)); W := REPROD(W,REPROD(Y,Q)); IF MINUSF W THEN <<V := NEGF V; W := NEGF W>>; W := CANCEL(V ./ W); V := NUMR W; IF NOT DOMAINP V AND NULL RED V AND ONEP LC V AND LDEG V=1 AND SFP(X := MVAR V) THEN V := X; RETURN CANSQ1(V ./ DENR W) END; SYMBOLIC PROCEDURE SFPF U; NOT DOMAINP U AND SFP MVAR U; SYMBOLIC PROCEDURE SFP U; %determines if mvar U is a standard form; NOT ATOM U AND NOT ATOM CAR U; SYMBOLIC PROCEDURE REPROD(U,V); %U is a list of powers,V a standard form; %value is product of terms in U with V; <<WHILE U DO <<V := MULTPF(CAR U,V); U := CDR U>>; V>>; SYMBOLIC PROCEDURE CPROD1(P,M,V,W); %U is a standard form, which occurs in a kernel raised to power M. %V is a list of powers multiplying P**M, W a list dividing it. %Value is a dotted pair of lists of powers after all possible kernels %have been cancelled; BEGIN SCALAR Z; Z := CPROD2(P,M,W,NIL); W := CADR Z; V := APPEND(CDDR Z,V); Z := CPROD2(CAR Z,M,V,T); V := CADR Z; W := APPEND(CDDR Z,W); IF CAR Z NEQ 1 THEN V := MKSP(CAR Z,M) . V; RETURN V . W END; SYMBOLIC PROCEDURE CPROD2(P,M,U,B); %P and M are as in CPROD1. U is a list of powers. B is true if P**M %multiplies U, false if it divides. %Value has three parts: the first is the part of P which does not %have any common factors with U, the second a list of powers (plus %U) which multiply U, and the third a list of powers which divide U; %it is implicit here that the kernel standard forms are positive; BEGIN SCALAR N,V,W,Y,Z; WHILE U AND P NEQ 1 DO <<IF (Z := GCDF(P,CAAR U)) NEQ 1 THEN <<P := QUOTF(P,Z); Y := QUOTF(CAAR U,Z); IF Y NEQ 1 THEN V := MKSP(Y,CDAR U) . V; IF B THEN V := MKSP(Z,M+CDAR U) . V ELSE IF (N := M-CDAR U)>0 THEN W := MKSP(Z,N) . W ELSE IF N<0 THEN V := MKSP(Z,-N) . V>> ELSE V := CAR U . V; U := CDR U>>; RETURN (P . NCONC(U,V) . W) END; SYMBOLIC PROCEDURE MKSPM(U,P); %U is a unique kernel, P an integer; %value is 1 if P=0 and not the weight variable K!*, %NIL if U**P is 0 or standard power of U**P otherwise; IF P=0 AND NOT(U EQ 'K!*) THEN 1 ELSE BEGIN SCALAR X; IF SUBFG!* AND (X:= ATSOC(U,ASYMPLIS!*)) AND CDR X<=P THEN RETURN NIL; SUB2CHK U; RETURN U TO P END; SYMBOLIC PROCEDURE SUB2CHK U; %determines if kernel U is such that a power substitution i %necessary; IF SUBFG!* AND(ATSOC(U,POWLIS!*) OR NOT ATOM U AND CAR U MEMQ '(EXPT SQRT) AND ASSOC(CADR U,POWLIS!*)) THEN !*SUB2 := T; SYMBOLIC PROCEDURE NEGF U; MULTD(-1,U); %********************************************************************* % FUNCTIONS FOR DIVIDING STANDARD FORMS %********************************************************************; SYMBOLIC PROCEDURE QUOTSQ(U,V); MULTSQ(U,INVSQ V); SYMBOLIC PROCEDURE QUOTF!*(U,V); IF NULL U THEN NIL ELSE (LAMBDA X; IF NULL X THEN ERRACH LIST("DIVISION FAILED",U,V) ELSE X) QUOTF(U,V); SYMBOLIC PROCEDURE QUOTF(U,V); BEGIN SCALAR XEXP; XEXP := !*EXP; !*EXP := T; U := QUOTF1(U,V); !*EXP := XEXP; RETURN U END; SYMBOLIC PROCEDURE QUOTF1(P,Q); %P and Q are standard forms %Value is the quotient of P and Q if it exists or NIL; IF NULL P THEN NIL ELSE IF P=Q THEN 1 ELSE IF Q=1 THEN P ELSE IF DOMAINP Q THEN QUOTFD(P,Q) ELSE IF DOMAINP P THEN NIL ELSE IF MVAR P EQ MVAR Q THEN BEGIN SCALAR U,V,W,X,Y,Z,Z1; INTEGER N; A:IF IDP(U := RANK P) OR IDP(V := RANK Q) OR U<V THEN RETURN NIL; %the above IDP test is because of the possibility of a free %variable in the degree position from LET statements; U := LT!* P; V := LT!* Q; W := MVAR Q; X := QUOTF1(TC U,TC V); IF NULL X THEN RETURN NIL; N := TDEG U-TDEG V; IF N NEQ 0 THEN Y := W TO N; P := ADDF(P,MULTF(IF N=0 THEN Q ELSE MULTPF(Y,Q),NEGF X)); %leading terms of P and Q do not cancel if MCD is off; %however, there may be a problem with off exp; IF P AND (DOMAINP P OR MVAR P NEQ W) THEN RETURN NIL ELSE IF N=0 THEN GO TO B; Z := ACONC(Z,Y .* X); %provided we have a non-zero power of X, terms %come out in right order; IF NULL P THEN RETURN IF Z1 THEN NCONC(Z,Z1) ELSE Z; GO TO A; B: IF NULL P THEN RETURN NCONC(Z,X) ELSE IF !*MCD THEN RETURN NIL ELSE Z1 := X; GO TO A END ELSE IF ORDOP(MVAR P,MVAR Q) THEN QUOTK(P,Q) ELSE NIL; SYMBOLIC PROCEDURE QUOTFD(P,Q); %P is a standard form, Q a domain element; %Value is P/Q if division is exact or NIL otherwise; IF FIELDP Q THEN MULTD(!:RECIP Q,P) ELSE IF DOMAINP P THEN QUOTDD(P,Q) ELSE QUOTK(P,Q); SYMBOLIC PROCEDURE QUOTDD(U,V); %U and V are domain elements, value is U/V if division is exact, %NIL otherwise; IF ATOM U THEN IF ATOM V THEN IF REMAINDER(U,V)=0 THEN U/V ELSE NIL ELSE QUOTDD(APPLY(GET(CAR V,'I2D),LIST U),V) ELSE IF ATOM V THEN QUOTDD(U,APPLY(GET(CAR U,'I2D),LIST V)) ELSE DCOMBINE(U,V,'QUOTIENT); SYMBOLIC PROCEDURE QUOTK(P,Q); (LAMBDA W; IF W THEN IF NULL RED P THEN LIST (LPOW P .* W) ELSE (LAMBDA Y;IF Y THEN LPOW P .* W .+ Y ELSE NIL) QUOTF1(RED P,Q) ELSE NIL) QUOTF1(LC P,Q); SYMBOLIC PROCEDURE RANK P; %P is a standard form %Value is the rank of P; IF !*MCD THEN LDEG P ELSE BEGIN INTEGER M,N; SCALAR Y; N := LDEG P; Y := MVAR P; A: M := LDEG P; IF NULL RED P THEN RETURN N-M; P := RED P; IF DEGR(P,Y)=0 THEN RETURN IF M<0 THEN IF N<0 THEN -M ELSE N-M ELSE N; GO TO A END; SYMBOLIC PROCEDURE LT!* P; %Returns true leading term of polynomial P; IF !*MCD OR LDEG P>0 THEN CAR P ELSE BEGIN SCALAR X,Y; X := LT P; Y := MVAR P; A: P := RED P; IF NULL P THEN RETURN X ELSE IF DEGR(P,Y)=0 THEN RETURN (Y . 0) .* P; GO TO A END; SYMBOLIC PROCEDURE REMF(U,V); %returns the remainder of U divided by V; CDR QREMF(U,V); PUT('REMAINDER,'POLYFN,'REMF); SYMBOLIC PROCEDURE QREMF(U,V); %returns the quotient and remainder of U divided by V; BEGIN INTEGER N; SCALAR X,Y,Z; IF DOMAINP V THEN RETURN QREMD(U,V); Z := LIST NIL; %final value; A: IF DOMAINP U THEN RETURN PRADDF(Z,NIL . U) ELSE IF MVAR U EQ MVAR V THEN IF (N := LDEG U-LDEG V)<0 THEN RETURN PRADDF(Z,NIL . U) ELSE <<X := QREMF(LC U,LC V); Y := MULTPF(LPOW U,CDR X); Z := PRADDF(Z,(IF N=0 THEN CAR X ELSE MULTPF(MVAR U TO N,CAR X)) . Y); U := IF NULL CAR X THEN RED U ELSE ADDF(ADDF(U,MULTF(IF N=0 THEN V ELSE MULTPF(MVAR U TO N,V), NEGF CAR X)), NEGF Y); GO TO A>> ELSE IF NOT ORDOP(MVAR U,MVAR V) THEN RETURN PRADDF(Z,NIL . U); X := QREMF(LC U,V); Z := PRADDF(Z,MULTPF(LPOW U,CAR X) . MULTPF(LPOW U,CDR X)); U := RED U; GO TO A END; SYMBOLIC PROCEDURE PRADDF(U,V); %U and V are dotted pairs of standard forms; ADDF(CAR U,CAR V) . ADDF(CDR U,CDR V); SYMBOLIC PROCEDURE QREMD(U,V); %Returns a dotted pair of quotient and remainder of form U %divided by domain element V; IF NULL U THEN U . U ELSE IF V=1 THEN LIST U ELSE IF NOT ATOM V AND FLAGP(CAR V,'FIELD) THEN LIST MULTDM(!:RECIP V,U) ELSE IF DOMAINP U THEN QREMDD(U,V) ELSE BEGIN SCALAR X; X := QREMF(LC U,V); RETURN PRADDF(MULTPF(LPOW U,CAR X) . MULTPF(LPOW U,CDR X), QREMD(RED U,V)) END; SYMBOLIC PROCEDURE QREMDD(U,V); %returns a dotted pair of quotient and remainder of non-invertable %domain element U divided by non-invertable domain element V; IF ATOM U AND ATOM V THEN DIVIDEF(U,V) ELSE DCOMBINE(U,V,'DIVIDE); SYMBOLIC PROCEDURE DIVIDEF(M,N); (LAMBDA X; (IF CAR X=0 THEN NIL ELSE CAR X). IF CDR X=0 THEN NIL ELSE CDR X) DIVIDE(M,N); SYMBOLIC PROCEDURE LQREMF(U,V); %returns a list of coeffs of powers of V in U, constant term first; BEGIN SCALAR X,Y; Y := LIST U; WHILE CAR(X := QREMF(CAR Y,V)) DO Y := CAR X . CDR X . CDR Y; RETURN REVERSIP Y END; %********************************************************************* % GREATEST COMMON DIVISOR ROUTINES %********************************************************************; SYMBOLIC PROCEDURE GCDN(P,Q); %P and Q are integers. Value is absolute value of gcd of P and Q; IF Q = 0 THEN ABS P ELSE GCDN(Q,REMAINDER(P,Q)); SYMBOLIC PROCEDURE COMFAC P; %P is a non-atomic standard form %CAR of result is lowest common power of leading kernel in %every term in P (or NIL). CDR is gcd of all coefficients of %powers of leading kernel; BEGIN SCALAR X,Y; IF NULL RED P THEN RETURN LT P; X := LC P; Y := MVAR P; %leading kernel; A: P := RED P; IF DEGR(P,Y)=0 THEN RETURN NIL . GCDF1(X,P) ELSE IF NULL RED P THEN RETURN LPOW P . GCDF1(X,LC P) ELSE X := GCDF1(LC P,X); GO TO A END; SYMBOLIC PROCEDURE DEGR(U,VAR); IF DOMAINP U OR NOT MVAR U EQ VAR THEN 0 ELSE LDEG U; PUT('GCD,'POLYFN,'GCDF!*); SYMBOLIC PROCEDURE GCDF!*(U,V); BEGIN SCALAR !*GCD; !*GCD := T; RETURN GCDF(U,V) END; SYMBOLIC PROCEDURE GCDF(U,V); %U and V are standard forms. %Value is the gcd of U and V, complete only if *GCD is true; BEGIN SCALAR !*EXP,Y,Z; !*EXP := T; IF NULL U THEN RETURN ABSF V ELSE IF NULL V THEN RETURN ABSF U ELSE IF U=1 OR V=1 THEN RETURN 1 ELSE IF !*GCD AND !*EZGCD THEN RETURN EZGCDF(U,V); IF QUOTF1(U,V) THEN Z := V ELSE IF QUOTF1(V,U) THEN Z := U ELSE <<IF !*GCD THEN <<Y := SETKORDER KERNORD(U,V); U := REORDER U; V := REORDER V>>; Z := GCDF1(U,V); IF !*GCD THEN <<IF U AND V AND (NULL QUOTF1(U,Z) OR NULL QUOTF1(V,Z)) THEN ERRACH LIST("GCDF FAILED",PREPSQ U,PREPSQ V); %this probably implies that integer overflow occurred; SETKORDER Y; Z := REORDER Z>>>>; RETURN ABSF Z END; SYMBOLIC PROCEDURE GCDF1(U,V); IF NULL U THEN V ELSE IF NULL V THEN U ELSE IF ONEP U OR ONEP V THEN 1 ELSE IF DOMAINP U THEN GCDFD(U,V) ELSE IF DOMAINP V THEN GCDFD(V,U) ELSE IF QUOTF1(U,V) THEN V ELSE IF QUOTF1(V,U) THEN U ELSE IF MVAR U EQ MVAR V THEN BEGIN SCALAR X,Y,Z; X := COMFAC U; Y := COMFAC V; Z := GCDF1(CDR X,CDR Y); IF !*GCD THEN Z := MULTF(GCDK(QUOTF1(U,COMFAC!-TO!-POLY X), QUOTF1(V,COMFAC!-TO!-POLY Y)), Z); IF CAR X AND CAR Y THEN IF PDEG CAR X>PDEG CAR Y THEN Z := MULTPF(CAR Y,Z) ELSE Z := MULTPF(CAR X,Z); RETURN Z END ELSE IF ORDOP(MVAR U,MVAR V) THEN GCDF1(CDR COMFAC U,V) ELSE GCDF1(CDR COMFAC V,U); SYMBOLIC PROCEDURE GCDFD(U,V); %U is a domain element, V a form; %Value is gcd of U and V; IF NOT ATOM U AND FLAGP(CAR U,'FIELD) THEN 1 ELSE GCDFD1(U,V); SYMBOLIC PROCEDURE GCDFD1(U,V); IF NULL V THEN U ELSE IF DOMAINP V THEN GCDDD(U,V) ELSE GCDFD1(GCDFD1(U,LC V),RED V); SYMBOLIC PROCEDURE GCDDD(U,V); %U and V are domain elements. If they are invertable, value is 1 %otherwise the gcd of U and V as a domain element; IF U=1 OR V=1 THEN 1 ELSE IF ATOM U THEN IF NOT FIELDP V THEN GCDDD1(U,V) ELSE 1 ELSE IF ATOM V THEN IF NOT FLAGP(CAR U,'FIELD) THEN GCDDD1(U,V) ELSE 1 ELSE IF FLAGP(CAR U,'FIELD) OR FLAGP(CAR V,'FIELD) THEN 1 ELSE GCDDD1(U,V); SYMBOLIC PROCEDURE GCDDD1(U,V); %U and V are non-invertable domain elements. Value is gcd of U and V; IF ATOM U AND ATOM V THEN GCDN(U,V) ELSE DCOMBINE(U,V,'GCD); SYMBOLIC PROCEDURE GCDK(U,V); %U and V are primitive polynomials in the main variable VAR; %result is gcd of U and V; BEGIN SCALAR LCLST,VAR,W,X; IF U=V THEN RETURN U ELSE IF DOMAINP U OR DEGR(V,(VAR := MVAR U))=0 THEN RETURN 1 ELSE IF LDEG U<LDEG V THEN <<W := U; U := V; V := W>>; IF QUOTF1(U,V) THEN RETURN V ELSE IF LDEG V=1 THEN RETURN 1; A: W := REMK(U,V); IF NULL W THEN RETURN V ELSE IF DEGR(W,VAR)=0 THEN RETURN 1; LCLST := ADDLC(V,LCLST); IF X := QUOTF1(W,LC W) THEN W := X ELSE FOR EACH Y IN LCLST DO WHILE (X := QUOTF1(W,Y)) DO W := X; U := V; V := PP W; IF DEGR(V,VAR)=0 THEN RETURN 1 ELSE GO TO A END; SYMBOLIC PROCEDURE ADDLC(U,V); IF U=1 THEN V ELSE (LAMBDA X; IF X=1 OR X=-1 OR NOT ATOM X AND FLAGP(CAR X,'FIELD) THEN V ELSE X . V) LC U; SYMBOLIC PROCEDURE DELALL(U,V); IF NULL V THEN NIL ELSE IF U EQ CAAR V THEN DELALL(U,CDR V) ELSE CAR V . DELALL(U,CDR V); SYMBOLIC PROCEDURE KERNORD(U,V); BEGIN SCALAR X,Y,Z; X := APPEND(POWERS(U,NIL),POWERS(V,NIL)); WHILE X DO <<Y := MAXDEG(CDR X,CAR X); X := DELALL(CAR Y,X); Z := CAR Y . Z>>; RETURN Z END; SYMBOLIC PROCEDURE MAXDEG(U,V); IF NULL U THEN V ELSE IF CDAR U>CDR V THEN MAXDEG(CDR U,CAR U) ELSE MAXDEG(CDR U,V); SYMBOLIC PROCEDURE POWERS(FORM,POWLST); IF NULL FORM OR DOMAINP FORM THEN POWLST ELSE BEGIN SCALAR X; IF (X := ATSOC(MVAR FORM,POWLST)) THEN LDEG FORM>CDR X AND RPLACD(X,LDEG FORM) ELSE POWLST := (MVAR FORM . LDEG FORM) . POWLST; RETURN POWERS(RED FORM,POWERS(LC FORM,POWLST)) END; SYMBOLIC PROCEDURE LCM(U,V); %U and V are standard forms. Value is lcm of U and V; IF NULL U OR NULL V THEN NIL ELSE IF ONEP U THEN V ELSE IF ONEP V THEN U ELSE MULTF(U,QUOTF(V,GCDF(U,V))); SYMBOLIC PROCEDURE REMK(U,V); %modified pseudo-remainder algorithm %U and V are polynomials, value is modified prem of U and V; BEGIN SCALAR F1,VAR,X; INTEGER K,N; F1 := LC V; VAR := MVAR V; N := LDEG V; WHILE (K := DEGR(U,VAR)-N)>=0 DO <<X := NEGF MULTF(LC U,RED V); IF K>0 THEN X := MULTPF(VAR TO K,X); U := ADDF(MULTF(F1,RED U),X)>>; RETURN U END; SYMBOLIC PROCEDURE PP U; %returns the primitive part of the polynomial U wrt leading var; QUOTF1(U,COMFAC!-TO!-POLY COMFAC U); SYMBOLIC PROCEDURE COMFAC!-TO!-POLY U; IF NULL CAR U THEN CDR U ELSE LIST U; SYMBOLIC PROCEDURE LNC U; %U is a standard form. %Value is the leading numerical coefficient; IF NULL U THEN 0 ELSE IF DOMAINP U THEN U ELSE LNC LC U; COMMENT In this sub-section, we consider the manipulation of factored forms. These have the structure <monomial> . <form-power-list> where the monomial is itself a standard form (satisfying the KERNLP test) and a form-power is a dotted pair whose car is a standard form and cdr an integer>0. We have thus represented the form as a product of a monomial and powers of non-monomial factors; SYMBOLIC PROCEDURE FCTRF U; %U is a standard form. Value is a standard factored form; %The function FACTORF is an assumed entry point to a factorization %module which itself returns a form power list; BEGIN SCALAR X,Y,!*GCD; !*GCD := T; IF DOMAINP U THEN RETURN LIST U ELSE IF !*FACTOR THEN RETURN FACTORF U; X := COMFAC U; U := QUOTF(U,COMFAC!-TO!-POLY X); Y := FCTRF CDR X; IF CAR X THEN Y := MULTPF(CAR X,CAR Y) . CDR Y; IF DOMAINP U THEN RETURN MULTF(U,CAR Y) . CDR Y ELSE IF MINUSF U THEN <<U := NEGF U; Y := NEGF CAR Y . CDR Y>>; RETURN CAR Y . FACMERGE(SQFRF U,CDR Y) END; SYMBOLIC PROCEDURE FACMERGE(U,V); %Returns the merge of the form_power_lists U and V; APPEND(U,V); SYMBOLIC PROCEDURE SQFRF U; %U is a non-trivial form which is primitive in its main variable %and has a positive leading numerical coefficient. %SQFRF performs square free factorization on U and returns a %form power list; BEGIN INTEGER K,N; SCALAR V,W,X,Z,!*GCD; N := 1; X := MVAR U; !*GCD := T; A: V := GCDF(U,DIFF(U,X)); K := DEGR(V,X); IF K>0 THEN U := QUOTF(U,V); IF W THEN <<IF U NEQ W THEN Z := FACMERGE(LIST(QUOTF(W,U) . N),Z); N := N+1>>; IF K=0 THEN RETURN FACMERGE(LIST(U . N),Z); W := U; U := V; GO TO A END; SYMBOLIC PROCEDURE DIFF(U,V); %a polynomial differentation routine which does not check %indeterminate dependences; IF DOMAINP U THEN NIL ELSE ADDF(ADDF(MULTPF(LPOW U,DIFF(LC U,V)), MULTF(LC U,DIFFP1(LPOW U,V))), DIFF(RED U,V)); SYMBOLIC PROCEDURE DIFFP1(U,V); IF NOT CAR U EQ V THEN NIL ELSE IF CDR U=1 THEN 1 ELSE MULTD(CDR U,!*P2F(CAR U TO (CDR U-1))); SYMBOLIC PROCEDURE MINUSF U; %U is a non-zero standard form. %Value is T if U has a negative leading numerical coeff, %NIL otherwise; IF NULL U THEN NIL ELSE IF DOMAINP U THEN IF ATOM U THEN U<0 ELSE APPLY(GET(CAR U,'MINUSP),LIST U) ELSE MINUSF LC U; SYMBOLIC PROCEDURE ABSF U; %U is a standard form %value is a standard form in which the leading power has a %positive coefficient; IF MINUSF U THEN NEGF U ELSE U; SYMBOLIC PROCEDURE CANONSQ U; %U is a standard quotient %value is a standard quotient in which the leading power %of the denominator has a positive numerical coefficient. %If FLOAT is true, then denom is given LNC of 1; BEGIN IF NULL NUMR U THEN RETURN NIL ./ 1 ELSE IF MINUSF DENR U THEN U:= NEGF NUMR U ./ NEGF DENR U; RETURN CANSQ1 U END; SYMBOLIC PROCEDURE CANSQ1 U; %Normalizes denominator of standard quotient U where possible %returning normalized quotient; IF DENR U=1 THEN U ELSE IF DOMAINP DENR U AND !:ONEP DENR U THEN NUMR U ./ 1 ELSE IF NULL DMODE!* OR NULL FLAGP(DMODE!*,'FIELD) THEN U ELSE BEGIN SCALAR X; X := LNC DENR U; IF !:ONEP X THEN RETURN U; IF ATOM X THEN X := APPLY(GET(DMODE!*,'I2D),LIST X); X := DCOMBINE(1,X,'QUOTIENT); U := MULTD(X,NUMR U) ./ MULTD(X,DENR U); RETURN IF DOMAINP DENR U AND !:ONEP DENR U THEN NUMR U ./ 1 ELSE U END; SYMBOLIC PROCEDURE INVSQ U; IF NULL NUMR U THEN REDERR "Zero denominator" ELSE CANONSQ REVPR U; %********************************************************************* % FUNCTIONS FOR SUBSTITUTING IN STANDARD FORMS %********************************************************************; SYMBOLIC PROCEDURE SUBF(U,L); BEGIN SCALAR X; %domain may have changed, so next line uses simpatom; IF DOMAINP U THEN RETURN !*D2Q U ELSE IF NCMP!* AND NONCOMEXPF U THEN RETURN SUBF1(U,L); X := REVERSE XN(FOR EACH Y IN L COLLECT CAR Y, KERNORD(U,NIL)); X := SETKORDER X; U := SUBF1(REORDER U,L); SETKORDER X; RETURN REORDER NUMR U ./ REORDER DENR U END; SYMBOLIC PROCEDURE NONCOMEXPF U; NOT DOMAINP U AND (NONCOMP MVAR U OR NONCOMEXPF LC U OR NONCOMEXPF RED U); SYMBOLIC PROCEDURE SUBF1(U,L); %U is a standard form, %L an association list of substitutions of the form %(<kernel> . <substitution>). %Value is the standard quotient for substituted expression. %Algorithm used is essentially the straight method. %Procedure depends on explicit data structure for standard form; IF DOMAINP U THEN IF ATOM U THEN IF NULL DMODE!* THEN U ./ 1 ELSE SIMPATOM U ELSE IF DMODE!* EQ CAR U THEN !*D2Q U ELSE SIMP PREPF U ELSE BEGIN INTEGER N; SCALAR KERN,M,W,X,XEXP,Y,Y1,Z; Z := NIL ./ 1; A0: KERN := MVAR U; IF M := ASSOC(KERN,ASYMPLIS!*) THEN M := CDR M; A: IF NULL U OR (N := DEGR(U,KERN))=0 THEN GO TO B ELSE IF NULL M OR N<M THEN Y := LT U . Y; U := RED U; GO TO A; B: IF NOT ATOM KERN AND NOT ATOM CAR KERN THEN KERN := PREPF KERN; IF NULL L THEN XEXP := IF KERN EQ 'K!* THEN 1 ELSE KERN ELSE IF (XEXP := SUBSUBLIS(L,KERN)) = KERN AND NOT ASSOC(KERN,ASYMPLIS!*) THEN GO TO F; C: W := 1 ./ 1; N := 0; IF Y AND CDAAR Y<0 THEN GO TO H; X := SIMP!* XEXP; IF NULL L AND KERNP X AND MVAR NUMR X EQ KERN THEN GO TO F ELSE IF NULL NUMR X THEN GO TO E; %Substitution of 0; FOR EACH J IN Y DO <<M := CDAR J; W := MULTSQ(EXPTSQ(X,M-N),W); N := M; Z := ADDSQ(MULTSQ(W,SUBF1(CDR J,L)),Z)>>; E: Y := NIL; IF NULL U THEN RETURN Z ELSE IF DOMAINP U THEN RETURN ADDSQ(!*D2Q U,Z); GO TO A0; F: SUB2CHK KERN; FOR EACH J IN Y DO Z := ADDSQ(MULTPQ(CAR J,SUBF1(CDR J,L)),Z); GO TO E; H: %Substitution for negative powers; X := SIMPRECIP LIST XEXP; J: Y1 := CAR Y . Y1; Y := CDR Y; IF Y AND CDAAR Y<0 THEN GO TO J; K: M := -CDAAR Y1; W := MULTSQ(EXPTSQ(X,M-N),W); N := M; Z := ADDSQ(MULTSQ(W,SUBF1(CDAR Y1,L)),Z); Y1 := CDR Y1; IF Y1 THEN GO TO K ELSE IF Y THEN GO TO C ELSE GO TO E END; SYMBOLIC PROCEDURE SUBSUBLIS(U,V); BEGIN SCALAR X; RETURN IF X := ASSOC(V,U) THEN CDR X ELSE IF ATOM V THEN V ELSE IF NOT IDP CAR V THEN FOR EACH J IN V COLLECT SUBSUBLIS(U,J) ELSE IF FLAGP(CAR V,'SUBFN) THEN SUBSUBF(U,V) ELSE IF GET(CAR V,'DNAME) THEN V ELSE FOR EACH J IN V COLLECT SUBSUBLIS(U,J) END; SYMBOLIC PROCEDURE SUBSUBF(L,EXPN); %Sets up a formal SUB expression when necessary; BEGIN SCALAR X,Y; FOR EACH J IN CDDR EXPN DO IF (X := ASSOC(J,L)) THEN <<Y := X . Y; L := DELETE(X,L)>>; EXPN := SUBLIS(L,CAR EXPN) . FOR EACH J IN CDR EXPN COLLECT SUBSUBLIS(L,J); %to ensure only opr and individual args are transformed; IF NULL Y THEN RETURN EXPN; EXPN := ACONC(FOR EACH J IN REVERSIP Y COLLECT LIST('EQUAL,CAR J,CDR J),EXPN); RETURN MK!*SQ IF L THEN SIMPSUB EXPN ELSE !*P2Q MKSP('SUB . EXPN,1) END; FLAG('(INT DF),'SUBFN); SYMBOLIC PROCEDURE KERNP U; DENR U=1 AND NOT DOMAINP(U := NUMR U) AND NULL RED U AND ONEP LC U AND LDEG U=1; %********************************************************************* % FUNCTIONS FOR RAISING CANONICAL FORMS TO A POWER %********************************************************************; SYMBOLIC PROCEDURE EXPTSQ(U,N); BEGIN SCALAR X; IF N=1 THEN RETURN U ELSE IF N=0 THEN RETURN IF NULL NUMR U THEN REDERR " 0**0 formed" ELSE 1 ./ 1 ELSE IF NULL NUMR U THEN RETURN U ELSE IF N<0 THEN RETURN SIMPEXPT LIST(MK!*SQ U,N) ELSE IF NULL !*EXP THEN RETURN MKSFPF(NUMR U,N) ./ MKSFPF(DENR U,N) ELSE IF KERNP U THEN RETURN MKSQ(MVAR NUMR U,N) ELSE IF DOMAINP NUMR U THEN RETURN MULTSQ(!:EXPT(NUMR U,N) ./ 1, 1 ./ EXPTF(DENR U,N)) ELSE IF DENR U=1 THEN RETURN EXPTF(NUMR U,N) ./ 1; X := U; WHILE (N := N-1)>0 DO X := MULTSQ(U,X); RETURN X END; SYMBOLIC PROCEDURE EXPTF(U,N); IF DOMAINP U THEN !:EXPT(U,N) ELSE IF !*EXP OR KERNLP U THEN EXPTF1(U,N) ELSE MKSFPF(U,N); SYMBOLIC PROCEDURE EXPTF1(U,N); %iterative multiplication seems to be faster than a binary sub- %division algorithm, probably because multiplying a small polynomial %by a large one is cheaper than multiplying two medium sized ones; BEGIN SCALAR X; X: = U; WHILE (N := N-1)>0 DO X := MULTF(U,X); RETURN X END; %********************************************************************* % FUNCTIONS FOR MAKING STANDARD POWERS %********************************************************************; SYMBOLIC SMACRO PROCEDURE GETPOWER(U,N); %U is a list (<kernel> . <properties>), N a positive integer. %Value is the standard power of U**N; CAR U . N; % BEGIN SCALAR V; % V := CADR U; % IF NULL V THEN RETURN CAAR RPLACA(CDR U,LIST (CAR U . N)); % A: IF N=CDAR V THEN RETURN CAR V % ELSE IF N<CDAR V % THEN RETURN CAR RPLACW(V,(CAAR V . N) . (CAR V . CDR V)) % ELSE IF NULL CDR V % THEN RETURN CADR RPLACD(V,LIST (CAAR V . N)); % V := CDR V; % GO TO A % END; SYMBOLIC PROCEDURE MKSP(U,P); %U is a (non-unique) kernel and P a non-zero integer %Value is the standard power for U**P; GETPOWER(FKERN U,P); SYMBOLIC PROCEDURE U TO P; %U is a (unique) kernel and P a non-zero integer; %Value is the standard power of U**P; U . P; % GETPOWER(FKERN U,P); SYMBOLIC PROCEDURE FKERN U; %finds the unique "p-list" reference to the kernel U. The choice of %the search and merge used here has a strong influence on some %timings. The ordered list used here is also used by Prepsq* to %order factors in printed output, so cannot be unilaterally changed; BEGIN SCALAR X,Y; IF ATOM U THEN RETURN LIST(U,NIL); Y := IF ATOM CAR U THEN GET(CAR U,'KLIST) ELSE EXLIST!*; IF NOT (X := ASSOC(U,Y)) THEN <<X := LIST(U,NIL); Y := ORDAD(X,Y); IF ATOM CAR U THEN <<KPROPS!* := UNION(LIST CAR U,KPROPS!*); PUT(CAR U,'KLIST,Y)>> ELSE EXLIST!* := Y>>; RETURN X END; SYMBOLIC PROCEDURE MKSFPF(U,N); %raises form U to power N with EXP off. Returns a form; % IF DOMAINP U THEN !:EXPT(U,N) % ELSE IF N>=0 AND KERNLP U % THEN IF NULL RED U AND ONEP LC U THEN !*P2F MKSP(MVAR U,LDEG U*N) % ELSE EXPTF1(U,N) % ELSE IF N=1 OR NULL SUBFG!* THEN MKSP!*(U,N) % ELSE (LAMBDA X; %IF X AND CDR X<=N THEN NIL ELSE MKSP!*(U,N)) % ASSOC(U,ASYMPLIS!*); EXPTF(MKPROD!* U,N); SYMBOLIC PROCEDURE MKSQ(U,N); %U is a kernel, N a non-zero integer; %Value is a standard quotient of U**N, after making any %possible substitutions for U; BEGIN SCALAR X,Y,Z; IF NULL SUBFG!* THEN GO TO A1 ELSE IF (Y := ASSOC(U,WTL!*)) AND NULL CAR(Y := MKSQ('K!*,N*CDR Y)) THEN RETURN Y ELSE IF NOT ATOM U THEN GO TO B ELSE IF NULL !*NOSUBS AND (Z:= GET(U,'AVALUE)) THEN GO TO D; FLAG(LIST U,'USED!*); %tell system U used as algebraic var; A: IF !*NOSUBS OR N=1 THEN GO TO A1 ELSE IF (Z:= ASSOC(U,ASYMPLIS!*)) AND CDR Z<=N THEN RETURN NIL ./ 1 ELSE IF ((Z:= ASSOC(U,POWLIS!*)) OR NOT ATOM U AND CAR U MEMQ '(EXPT SQRT) AND (Z := ASSOC(CADR U,POWLIS!*))) AND NOT(N*CADR Z)<0 %implements explicit sign matching; THEN !*SUB2 := T; A1: IF NULL X THEN X := FKERN U; X := !*P2F GETPOWER(X,N) ./ 1; RETURN IF Y THEN MULTSQ(Y,X) ELSE X; B: IF NULL !*NOSUBS AND ATOM CAR U AND (Z:= ASSOC(U,GET(CAR U,'KVALUE))) THEN GO TO C ELSE IF NOT('USED!* MEMQ CDDR (X := FKERN U)) THEN ACONC(X,'USED!*); GO TO A; C: Z := CDR Z; D: %optimization is possible as shown if all expression %dependency is known; %IF CDR Z THEN RETURN EXPTSQ(CDR Z,N); %value already computed; IF NULL !*RESUBS THEN !*NOSUBS := T; X := SIMPCAR Z; !*NOSUBS := NIL; %RPLACD(Z,X); %save simplified value; %SUBL!* := Z . SUBL!*; RETURN EXPTSQ(X,N) END; %********************************************************************* % FUNCTIONS FOR INTERNAL ORDERING OF EXPRESSIONS %********************************************************************; SYMBOLIC PROCEDURE ORDAD(A,U); IF NULL U THEN LIST A ELSE IF ORDP(A,CAR U) THEN A . U ELSE CAR U . ORDAD(A,CDR U); SYMBOLIC PROCEDURE ORDN U; IF NULL U THEN NIL ELSE IF NULL CDR U THEN U ELSE IF NULL CDDR U THEN ORD2(CAR U,CADR U) ELSE ORDAD(CAR U,ORDN CDR U); SYMBOLIC PROCEDURE ORD2(U,V); IF ORDP(U,V) THEN LIST(U,V) ELSE LIST(V,U); SYMBOLIC PROCEDURE ORDP(U,V); %returns TRUE if U ordered ahead or equal to V, NIL otherwise. %an expression with more structure at a given level is ordered %ahead of one with less; IF NULL U THEN NULL V ELSE IF NULL V THEN T ELSE IF ATOM U THEN IF ATOM V THEN IF NUMBERP U THEN NUMBERP V AND NOT U<V ELSE IF NUMBERP V THEN T ELSE ORDERP(U,V) ELSE NIL ELSE IF ATOM V THEN T ELSE IF CAR U=CAR V THEN ORDP(CDR U,CDR V) ELSE ORDP(CAR U,CAR V); SYMBOLIC PROCEDURE ORDPP(U,V); IF CAR U EQ CAR V THEN CDR U>CDR V ELSE IF NCMP!* THEN NCMORDP(CAR U,CAR V) ELSE ORDOP(CAR U,CAR V); SYMBOLIC PROCEDURE ORDOP(U,V); BEGIN SCALAR X; X := KORD!*; A: IF NULL X THEN RETURN ORDP(U,V) ELSE IF U EQ CAR X THEN RETURN T ELSE IF V EQ CAR X THEN RETURN; X := CDR X; GO TO A END; SYMBOLIC PROCEDURE NCMORDP(U,V); IF NONCOMP U THEN IF NONCOMP V THEN ORDOP(U,V) ELSE T ELSE IF NONCOMP V THEN NIL ELSE ORDOP(U,V); %********************************************************************* % FUNCTIONS FOR REORDERING STANDARD FORMS %*********************************************************************; SYMBOLIC PROCEDURE REORDER U; %reorders a standard form so that current kernel order is used; IF DOMAINP U THEN U ELSE RADDF(RMULTPF(LPOW U,REORDER LC U),REORDER RED U); SYMBOLIC PROCEDURE RADDF(U,V); %adds reordered forms U and V; IF NULL U THEN V ELSE IF NULL V THEN U ELSE IF DOMAINP U THEN ADDD(U,V) ELSE IF DOMAINP V THEN ADDD(V,U) ELSE IF PEQ(LPOW U,LPOW V) THEN (LPOW U .* RADDF(LC U,LC V)) .+ RADDF(RED U,RED V) ELSE IF ORDPP(LPOW U,LPOW V) THEN LT U . RADDF(RED U,V) ELSE LT V . RADDF(U,RED V); SYMBOLIC PROCEDURE RMULTPF(U,V); %multiplies power U by reordered form V; IF NULL V THEN NIL ELSE IF DOMAINP V OR ORDOP(CAR U,MVAR V) THEN !*T2F(U .* V) ELSE (LPOW V .* RMULTPF(U,LC V)) .+ RMULTPF(U,RED V); SYMBOLIC PROCEDURE KORDER U; <<KORD!* := IF U = '(NIL) THEN NIL ELSE FOR EACH X IN U COLLECT !*A2K X; RMSUBS()>>; RLISTAT '(KORDER); SYMBOLIC PROCEDURE SETKORDER U; BEGIN SCALAR V; V := KORD!*; KORD!* := U; RETURN V END; %********************************************************************* % FUNCTIONS WHICH APPLY BASIC PATTERN MATCHING RULES %********************************************************************; SYMBOLIC PROCEDURE EMTCH U; IF ATOM U THEN U ELSE (LAMBDA X; IF X THEN X ELSE U) OPMTCH U; SYMBOLIC PROCEDURE OPMTCH U; BEGIN SCALAR X,Y,Z; X := GET(CAR U,'OPMTCH); IF NULL X THEN RETURN NIL ELSE IF NULL SUBFG!* THEN RETURN NIL; %NULL(!*SUB2 := T); Z := FOR EACH J IN CDR U COLLECT EMTCH J; A: IF NULL X THEN RETURN; Y := MCHARG(Z,CAAR X,CAR U); B: IF NULL Y THEN GO TO C ELSE IF EVAL SUBLA(CAR Y,CDADAR X) THEN RETURN SUBLA(CAR Y,CADDAR X); Y := CDR Y; GO TO B; C: X := CDR X; GO TO A END; SYMBOLIC PROCEDURE MCHARG(U,V,W); %procedure to determine if an argument list matches given template; %U is argument list of operator W; %V is argument list template being matched against; %if there is no match, value is NIL, %otherwise a list of lists of free variable pairings; IF NULL U AND NULL V THEN LIST NIL ELSE BEGIN INTEGER M,N; M := LENGTH U; N := LENGTH V; IF FLAGP(W,'NARY) AND M>2 THEN IF M<6 AND FLAGP(W,'SYMMETRIC) THEN RETURN MCHCOMB(U,V,W) ELSE IF N=2 THEN <<U := CDR MKBIN(W,U); M := 2>> ELSE RETURN NIL; %we cannot handle this case; RETURN IF M NEQ N THEN NIL ELSE IF FLAGP(W,'SYMMETRIC) THEN MCHSARG(U,V) ELSE IF MTP V THEN LIST PAIR(V,U) ELSE MCHARG2(U,V,LIST NIL) END; SYMBOLIC PROCEDURE MCHCOMB(U,V,OP); BEGIN INTEGER N; N := LENGTH U - LENGTH V +1; IF N<1 THEN RETURN NIL ELSE IF N=1 THEN RETURN MCHSARG(U,V) ELSE IF NOT SMEMQLP(FRLIS!*,V) THEN RETURN NIL; RETURN FOR EACH X IN COMB(U,N) CONC MCHSARG((OP . X) . SETDIFF(U,X),V) END; SYMBOLIC PROCEDURE COMB(U,N); %value is list of all combinations of N elements from the list U; BEGIN SCALAR V; INTEGER M; IF N=0 THEN RETURN LIST NIL ELSE IF (M:=LENGTH U-N)<0 THEN RETURN; A: IF M=0 THEN RETURN U . V; V := NCONC(V,MAPCONS(COMB(CDR U,N-1),CAR U)); U := CDR U; M := M-1; GO TO A END; SYMBOLIC PROCEDURE MCHARG2(U,V,W); %matches compatible list U against template V; BEGIN SCALAR Y; IF NULL U THEN RETURN W; Y := MCHK(CAR U,CAR V); U := CDR U; V := CDR V; RETURN FOR EACH J IN Y CONC MCHARG2(U,UPDTEMPLATE(J,V),MAPPEND(W,J)) END; SYMBOLIC PROCEDURE UPDTEMPLATE(U,V); BEGIN SCALAR X,Y; RETURN FOR EACH J IN V COLLECT IF (X := SUBLA(U,J)) = J THEN J ELSE IF (Y := REVAL X) NEQ X THEN Y ELSE X END; SYMBOLIC PROCEDURE MCHK(U,V); IF U=V THEN LIST NIL ELSE IF ATOM V THEN IF V MEMQ FRLIS!* THEN LIST LIST (V . U) ELSE NIL ELSE IF ATOM U %special check for negative number match; THEN IF NUMBERP U AND U<0 THEN MCHK(LIST('MINUS,-U),V) ELSE NIL ELSE IF CAR U EQ CAR V THEN MCHARG(CDR U,CDR V,CAR U) ELSE NIL; SYMBOLIC PROCEDURE MKBIN(U,V); IF NULL CDDR V THEN U . V ELSE LIST(U,CAR V,MKBIN(U,CDR V)); SYMBOLIC PROCEDURE MTP V; NULL V OR (CAR V MEMQ FRLIS!* AND NOT CAR V MEMBER CDR V AND MTP CDR V); SYMBOLIC PROCEDURE MCHSARG(U,V); REVERSIP IF MTP V THEN FOR EACH J IN PERMUTATIONS V COLLECT PAIR(J,U) ELSE FOR EACH J IN PERMUTATIONS U CONC MCHARG2(J,V,LIST NIL); SYMBOLIC PROCEDURE PERMUTATIONS U; IF NULL U THEN LIST U ELSE FOR EACH J IN U CONC MAPCONS(PERMUTATIONS DELETE(J,U),J); FLAGOP ANTISYMMETRIC,SYMMETRIC; FLAG ('(PLUS TIMES CONS),'SYMMETRIC); %********************************************************************* % FUNCTIONS FOR CONVERTING CANONICAL FORMS INTO PREFIX FORMS %********************************************************************; SYMBOLIC PROCEDURE PREPSQ U; IF NULL NUMR U THEN 0 ELSE SQFORM(U,FUNCTION PREPF); SYMBOLIC PROCEDURE SQFORM(U,V); (LAMBDA (X,Y); IF Y=1 THEN X ELSE LIST('QUOTIENT,X,Y)) (APPLY(V,LIST NUMR U),APPLY(V,LIST DENR U)); SYMBOLIC PROCEDURE PREPF U; REPLUS PREPF1(U,NIL); SYMBOLIC PROCEDURE PREPF1(U,V); IF NULL U THEN NIL ELSE IF DOMAINP U THEN LIST RETIMES((IF ATOM U THEN IF U<0 THEN LIST('MINUS,-U) ELSE U ELSE IF APPLY(GET(CAR U,'MINUSP),LIST U) THEN LIST('MINUS,PREPD !:MINUS U) ELSE PREPD U) . EXCHK(V,NIL,NIL)) ELSE NCONC(PREPF1(LC U,IF MVAR U EQ 'K!* THEN V ELSE LPOW U .* V) ,PREPF1(RED U,V)); SYMBOLIC PROCEDURE PREPD U; APPLY(GET(CAR U,'PREPFN),LIST U); SYMBOLIC PROCEDURE EXCHK(U,V,W); IF NULL U THEN IF NULL W THEN V ELSE EXCHK(U,LIST('EXPT,CAAR W,PREPSQX CDAR W) . V,CDR W) ELSE IF EQCAR(CAAR U,'EXPT) THEN EXCHK(CDR U,V, BEGIN SCALAR X,Y; X := ASSOC(CADAAR U,W); Y := SIMP LIST('TIMES,CDAR U,CADDAR CAR U); IF X THEN RPLACD(X,ADDSQ(Y,CDR X)) ELSE W := (CADAAR U . Y) . W; RETURN W END) ELSE IF CDAR U=1 THEN EXCHK(CDR U, SQCHK CAAR U . V,W) ELSE EXCHK(CDR U,LIST('EXPT,SQCHK CAAR U,CDAR U) . V,W); SYMBOLIC PROCEDURE REPLUS U; IF ATOM U THEN U ELSE IF NULL CDR U THEN CAR U ELSE 'PLUS . U; SYMBOLIC PROCEDURE RETIMES U; BEGIN SCALAR X,Y; A: IF NULL U THEN GO TO D ELSE IF ONEP CAR U THEN GO TO C ELSE IF NOT EQCAR(CAR U,'MINUS) THEN GO TO B; X := NOT X; IF ONEP CADAR U THEN GO TO C ELSE U := CADAR U . CDR U; B: Y := CAR U . Y; C: U := CDR U; GO TO A; D: Y := IF NULL Y THEN 1 ELSE IF CDR Y THEN 'TIMES . REVERSE Y ELSE CAR Y; RETURN IF X THEN LIST('MINUS,Y) ELSE Y END; SYMBOLIC PROCEDURE SQCHK U; IF ATOM U THEN U ELSE IF CAR U EQ '!*SQ THEN PREPSQ CADR U ELSE IF CAR U EQ 'EXPT AND CADDR U=1 THEN CADR U ELSE IF ATOM CAR U THEN U ELSE PREPF U; %********************************************************************* % BASIC OUTPUT PACKAGE FOR CANONICAL FORMS %********************************************************************; %Global variables referenced in this section; GLOBAL '(VARNAM!* ORIG!* YCOORD!* YMIN!* SPARE!*); SPARE!* := 5; %RIGHT MARGIN, TO AVOID TROUBLE WITH PREMATURE %LINE-BREAKS INSERTED BY LISP; VARNAM!* := 'ANS; ORIG!*:=0; POSN!* := 0; YCOORD!* := 0; YMIN!* := 0; DEFLIST ('((!*SQ !*SQPRINT)),'SPECPRN); SYMBOLIC PROCEDURE !*SQPRINT U; SQPRINT CAR U; SYMBOLIC PROCEDURE SQPRINT U; %mathprints the standard quotient U; BEGIN SCALAR Z; Z := ORIG!*; IF !*NAT AND POSN!*<20 THEN ORIG!* := POSN!*; IF !*PRI OR WTL!* THEN GO TO C ELSE IF CDR U NEQ 1 THEN GO TO B ELSE XPRINF(CAR U,NIL,NIL); A: RETURN (ORIG!* := Z); B: PRIN2!* "("; XPRINF(CAR U,NIL,NIL); PRIN2!* ") / (";; XPRINF(CDR U,NIL,NIL); PRIN2!* ")"; GO TO A; C: MAPRIN(!*OUTP := U := PREPSQ!* U); GO TO A END; SYMBOLIC PROCEDURE VARPRI(U,V,W); BEGIN SCALAR X,Y; %U is expression being printed %V is a list of expressions assigned to U %W is a flag which is true if expr is last in current set; IF NULL U THEN U := 0; %allow for unset array elements; IF !*NERO AND U=0 THEN RETURN; IF W MEMQ '(FIRST ONLY) THEN TERPRI!* T; X := TYPL!*; A: IF NULL X THEN GO TO B ELSE IF APPLY(CAR X,LIST U) AND (Y:= GET(CAR X,'PRIFN)) THEN RETURN APPLY(Y,LIST(U,V,W)); X := CDR X; GO TO A; B: IF !*FORT THEN RETURN FVARPRI(U,V,W) ELSE IF NULL V THEN GO TO C; INPRINT('SETQ,GET('SETQ,'INFIX),MAPCAR(V,FUNCTION EVAL)); OPRIN 'SETQ; C: MAPRIN U; IF NULL W OR W EQ 'FIRST THEN RETURN NIL ELSE IF NOT !*NAT THEN PRIN2!* "$"; TERPRI!*(NOT !*NAT); RETURN END; SYMBOLIC PROCEDURE XPRINF(U,V,W); %U is a standard form. %V is a flag which is true if a term has preceded current form. %W is a flag which is true if form is part of a standard term; %Procedure prints the form and returns NIL; BEGIN A: IF NULL U THEN RETURN NIL ELSE IF DOMAINP U THEN RETURN XPRID(U,V,W); XPRINT(LT U,V); U := RED U; V := T; GO TO A END; SYMBOLIC PROCEDURE XPRID(U,V,W); %U is a domain element. %V is a flag which is true if a term has preceded element. %W is a flag which is true if U is part of a standard term. %Procedure prints element and returns NIL; BEGIN IF MINUSF U THEN <<OPRIN 'MINUS; U := !:MINUS U>> ELSE IF V THEN OPRIN 'PLUS; IF NOT W OR U NEQ 1 THEN IF ATOM U THEN PRIN2!* U ELSE MAPRIN U END; SYMBOLIC PROCEDURE XPRINT(U,V); %U is a standard term. %V is a flag which is true if a term has preceded this term. %Procedure prints the term and returns NIL; BEGIN SCALAR FLG,W; FLG := NOT ATOM TC U AND RED TC U; IF NOT FLG THEN GO TO A ELSE IF V THEN OPRIN 'PLUS; PRIN2!* "("; A: XPRINF(TC U,IF FLG THEN NIL ELSE V,NOT FLG); IF FLG THEN PRIN2!* ")"; IF NOT ATOM TC U OR NOT ABS FIX TC U=1 THEN OPRIN 'TIMES; W := TPOW U; IF ATOM CAR W THEN PRIN2!* CAR W ELSE IF NOT ATOM CAAR W OR CAAR W EQ '!*SQ THEN GO TO C ELSE IF CAAR W EQ 'PLUS THEN MAPRINT(CAR W,100) ELSE MAPRIN CAR W; B: IF CDR W=1 THEN RETURN; OPRIN 'EXPT; PRIN2!* CDR W; IF NOT !*NAT THEN RETURN; YCOORD!* := YCOORD!*-1; IF YMIN!*>YCOORD!* THEN YMIN!* := YCOORD!*; RETURN; C: PRIN2!* "("; IF NOT ATOM CAAR W THEN XPRINF(CAR W,NIL,NIL) ELSE SQPRINT CADAR W; PRIN2!* ")"; GO TO B END; %********************************************************************* % FUNCTIONS FOR PRINTING PREFIX EXPRESSIONS %********************************************************************; %Global variables referenced in this sub-section; GLOBAL '(OBRKP!* PLINE!* !*FORT !*LIST !*NAT YMAX!*); OBRKP!* := T; PLINE!* := NIL; !*FORT:=NIL; !*LIST := NIL; !*NAT := NAT!*!* := T; YMAX!* := 0; INITL!* := APPEND('(ORIG!* PLINE!*),INITL!*); PUT('ORIG!*,'INITL,0); FLAG('(LINELENGTH),'OPFN); %to make it a symbolic operator; SYMBOLIC PROCEDURE MATHPRINT L; BEGIN TERPRI!* T; MAPRIN L; TERPRI!* T END; SYMBOLIC PROCEDURE MAPRIN U; MAPRINT(U,0); SYMBOLIC PROCEDURE MAPRINT(L,P); BEGIN SCALAR X,Y; IF NULL L THEN RETURN NIL ELSE IF ATOM L THEN GO TO B ELSE IF STRINGP L THEN RETURN PRIN2!* L ELSE IF NOT ATOM CAR L THEN MAPRINT(CAR L,P) ELSE IF X := GET(CAR L,'SPECPRN) THEN RETURN APPLY(X,LIST CDR L) ELSE IF X := GET(CAR L,'INFIX) THEN GO TO A ELSE PRIN2!* CAR L; PRIN2!* "("; OBRKP!* := NIL; IF CDR L THEN INPRINT('!*COMMA!*,0,CDR L); OBRKP!* := T; E: RETURN PRIN2!* ")"; B: IF NUMBERP L THEN GO TO D; C: RETURN PRIN2!* L; D: IF NOT L<0 THEN GO TO C; PRIN2!* "("; PRIN2!* L; GO TO E; A: P := NOT X>P; IF NOT P THEN GO TO G; Y := ORIG!*; PRIN2!* "("; ORIG!* := IF POSN!*<18 THEN POSN!* ELSE ORIG!*+3; G: INPRINT(CAR L,X,CDR L); IF NOT P THEN RETURN; PRIN2!* ")"; ORIG!* := Y END; SYMBOLIC PROCEDURE INPRINT(OP,P,L); BEGIN IF GET(OP,'ALT) THEN GO TO A ELSE IF OP EQ 'EXPT AND !*NAT AND FLATSIZEC CAR L+FLATSIZEC CADR L> (LINELENGTH NIL-SPARE!*)-POSN!* THEN TERPRI!* T; %to avoid breaking exponent over line; MAPRINT(CAR L,P); A0: L := CDR L; A: IF NULL L THEN RETURN NIL ELSE IF NOT ATOM CAR L AND OP EQ GET!*(CAAR L,'ALT) THEN GO TO B; OPRIN OP; B: MAPRINT(CAR L,P); IF NOT !*NAT OR NOT OP EQ 'EXPT THEN GO TO A0; YCOORD!* := YCOORD!*-1; IF YMIN!*>YCOORD!* THEN YMIN!* := YCOORD!*; GO TO A0 END; SYMBOLIC PROCEDURE FLATSIZEC U; IF NULL U THEN 0 ELSE IF ATOM U THEN LENGTHC U ELSE FLATSIZEC CAR U + FLATSIZEC CDR U; SYMBOLIC PROCEDURE OPRIN OP; (LAMBDA X; IF NULL X THEN PRIN2!* OP ELSE IF !*FORT THEN PRIN2!* CADR X ELSE IF !*LIST AND OBRKP!* AND OP MEMQ '(PLUS MINUS) THEN BEGIN TERPRI!* T; PRIN2!* CAR X END ELSE IF !*NAT AND OP EQ 'EXPT THEN BEGIN YCOORD!* := YCOORD!*+1; IF YCOORD!*>YMAX!* THEN YMAX!* := YCOORD!* END ELSE PRIN2!* CAR X) GET(OP,'PRTCH); SYMBOLIC PROCEDURE PRIN2!* U; BEGIN INTEGER M,N; IF !*FORT THEN RETURN FPRIN2 U; N := LENGTHC U; IF N>(LINELENGTH NIL-SPARE!*) THEN GO TO D; M := POSN!*+N; A: IF M>(LINELENGTH NIL-SPARE!*) THEN GO TO C ELSE IF NOT !*NAT THEN PRIN2 U ELSE PLINE!* := (((POSN!* . M) . YCOORD!*) . U) . PLINE!*; B: RETURN (POSN!* := M); C: TERPRI!* T; IF (M := POSN!*+N)<=(LINELENGTH NIL-SPARE!*) THEN GO TO A; D: %identifier longer than one line; IF !*FORT THEN REDERR LIST(U,"too long for FORTRAN"); %let LISP print the atom; TERPRI!* NIL; PRIN2T U; M := REMAINDER(N,(LINELENGTH NIL-SPARE!*)); GO TO B END; SYMBOLIC PROCEDURE TERPRI!* U; BEGIN INTEGER N; IF !*FORT THEN RETURN FTERPRI(U) ELSE IF NOT PLINE!* OR NOT !*NAT THEN GO TO B; N := YMAX!*; PLINE!* := REVERSE PLINE!*; A: SCPRINT(PLINE!*,N); TERPRI(); IF N= YMIN!* THEN GO TO B; N := N-1; GO TO A; B: IF U THEN TERPRI(); C: PLINE!* := NIL; POSN!* := ORIG!*; YCOORD!* := YMAX!* := YMIN!* := 0 END; SYMBOLIC PROCEDURE SCPRINT(U,N); BEGIN SCALAR M; POSN!* := 0; A: IF NULL U THEN RETURN NIL ELSE IF NOT CDAAR U=N THEN GO TO B ELSE IF NOT (M:= CAAAAR U-POSN!*)<0 THEN SPACES M; PRIN2 CDAR U; POSN!* := CDAAAR U; B: U := CDR U; GO TO A END; COMMENT ***** FORTRAN OUTPUT PACKAGE *****; GLOBAL '(CARDNO!* FORTWIDTH!*); FLAG ('(CARDNO!* FORTWIDTH!*),'SHARE); CARDNO!*:=20; FORTWIDTH!* := 70; FLUID '(FBRKT); %bracket level counter; SYMBOLIC PROCEDURE VARNAME U; %sets the default variable assignment name; VARNAM!* := CAR U; RLISTAT '(VARNAME); SYMBOLIC PROCEDURE FLENGTH(U,CHARS); IF CHARS<0 THEN CHARS ELSE IF ATOM U THEN CHARS-IF NUMBERP U THEN IF FIXP U THEN FLATSIZEC U+1 ELSE FLATSIZEC U ELSE FLATSIZEC((LAMBDA X; IF X THEN CADR X ELSE U) GET(U,'PRTCH)) ELSE FLENGTH(CAR U,FLENLIS(CDR U,CHARS)-2); SYMBOLIC PROCEDURE FLENLIS(U,CHARS); IF NULL U THEN CHARS ELSE IF CHARS<0 THEN CHARS ELSE IF ATOM U THEN FLENGTH(U,CHARS) ELSE FLENLIS(CDR U,FLENGTH(CAR U,CHARS)); SYMBOLIC PROCEDURE FMPRINT(L,P); BEGIN SCALAR X; IF NULL L THEN RETURN NIL ELSE IF ATOM L THEN GO TO B ELSE IF STRINGP L THEN RETURN FPRIN2 L ELSE IF NOT ATOM CAR L THEN FMPRINT(CAR L,P) ELSE IF X := GET(CAR L,'INFIX) THEN GO TO A ELSE IF X := GET(CAR L,'SPECPRN) THEN RETURN APPLY(X,LIST CDR L) ELSE FPRIN2 CAR L; FPRIN2 "("; FBRKT := NIL . FBRKT; X := !*PERIOD; !*PERIOD := NIL; %turn off . inside an op exp; IF CDR L THEN FNPRINT('!*COMMA!*,0,CDR L); !*PERIOD := X; E: FPRIN2 ")"; RETURN FBRKT := CDR FBRKT; B: IF NUMBERP L THEN GO TO D; C: RETURN FPRIN2 L; D: IF NOT L<0 THEN GO TO C; FPRIN2 "("; FBRKT := NIL . FBRKT; FPRIN2 L; GO TO E; A: P := NOT X>P; IF P THEN <<FPRIN2 "("; FBRKT := NIL . FBRKT>>; FNPRINT(CAR L,X,CDR L); IF P THEN <<FPRIN2 ")"; FBRKT := CDR FBRKT>> END; SYMBOLIC PROCEDURE FNPRINT(OP,P,L); BEGIN IF OP EQ 'EXPT THEN RETURN FEXPPRI(P,L) ELSE IF GET(OP,'ALT) THEN GO TO A; FMPRINT(CAR L,P); A0: L := CDR L; A: IF NULL L THEN RETURN NIL ELSE IF NOT ATOM CAR L AND OP EQ GET!*(CAAR L,'ALT) THEN GO TO B; FOPRIN OP; B: FMPRINT(CAR L,P); GO TO A0 END; SYMBOLIC PROCEDURE FEXPPRI(P,L); BEGIN SCALAR PPERIOD; FMPRINT(CAR L,P); FOPRIN 'EXPT; PPERIOD := !*PERIOD; IF NUMBERP CADR L THEN !*PERIOD := NIL ELSE !*PERIOD := T; FMPRINT(CADR L,P); !*PERIOD := PPERIOD END; SYMBOLIC PROCEDURE FOPRIN OP; (LAMBDA X; IF NULL X THEN FPRIN2 OP ELSE FPRIN2 CADR X) GET(OP,'PRTCH); FLUID '(COUNTR EXPLIS FVAR NCHARS VAR); SYMBOLIC PROCEDURE FVARPRI(U,V,W); %prints an assignment in FORTRAN notation; BEGIN INTEGER COUNTR,LLENGTH,NCHARS; SCALAR EXPLIS,FVAR,VAR; LLENGTH := LINELENGTH NIL; LINELENGTH FORTWIDTH!*; IF STRINGP U THEN RETURN <<FPRIN2 U; IF W EQ 'ONLY THEN FTERPRI(T)>>; IF EQCAR(U,'!*SQ) THEN U := PREPSQ!* CADR U; COUNTR := 0; NCHARS := ((LINELENGTH NIL-SPARE!*)-12)*CARDNO!*; %12 is to allow for indentation and end of line effects; VAR := VARNAM!*; FVAR := IF NULL V THEN VAR ELSE EVAL CAR V; IF POSN!*=0 AND W THEN FORTPRI(FVAR,U) ELSE <<FMPRINT(U,0); IF W THEN FTERPRI W>>; %means that expression preceded by a string; LINELENGTH LLENGTH; END; SYMBOLIC PROCEDURE FORTPRI(FVAR,XEXP); BEGIN SCALAR FBRKT; IF FLENGTH(XEXP,NCHARS)<0 THEN XEXP := CAR XEXP . FOUT(CDR XEXP,CAR XEXP); POSN!* := 0; FPRIN2 " "; FMPRINT(FVAR,0); FPRIN2 "="; FMPRINT(XEXP,0); FTERPRI(T) END; SYMBOLIC PROCEDURE FOUT(ARGS,OP); BEGIN INTEGER NCHARSL; SCALAR DISTOP,X,Z; NCHARSL := NCHARS; IF OP MEMQ '(PLUS TIMES) THEN DISTOP := OP; WHILE ARGS DO <<X := CAR ARGS; IF ATOM X AND (NCHARSL := FLENGTH(X,NCHARSL)) OR (NULL CDR ARGS OR DISTOP) AND (NCHARSL := FLENGTH(X,NCHARSL))>0 THEN Z := X . Z ELSE IF DISTOP AND FLENGTH(X,NCHARS)>0 THEN <<Z := FOUT1(DISTOP . ARGS) . Z; ARGS := LIST NIL>> ELSE <<Z := FOUT1 X . Z; NCHARSL := FLENGTH(OP,NCHARSL)>>; NCHARSL := FLENGTH(OP,NCHARSL); ARGS := CDR ARGS>>; RETURN REVERSIP Z END; SYMBOLIC PROCEDURE FOUT1 XEXP; BEGIN SCALAR FVAR; FVAR := GENVAR(); EXPLIS := (XEXP . FVAR) . EXPLIS; FORTPRI(FVAR,XEXP); RETURN FVAR END; SYMBOLIC PROCEDURE FPRIN2 U; % FORTRAN output of U; BEGIN INTEGER M,N; N := FLATSIZEC U; M := POSN!*+N; IF NUMBERP U AND FIXP U AND !*PERIOD THEN M := M+1; IF M<(LINELENGTH NIL-SPARE!*) THEN POSN!* := M ELSE <<TERPRI(); SPACES 5; PRIN2 ". "; POSN!* := N+7>>; PRIN2 U; IF NUMBERP U AND FIXP U AND !*PERIOD THEN PRIN2 "." END; SYMBOLIC PROCEDURE FTERPRI(U); <<IF NOT POSN!*=0 AND U THEN TERPRI(); POSN!* := 0>>; SYMBOLIC PROCEDURE GENVAR; INTERN COMPRESS APPEND(EXPLODE VAR,EXPLODE(COUNTR := COUNTR + 1)); UNFLUID '(EXPLIS FBRKT FVAR NCHARS); %********************************************************************* % FOR ALL COMMAND %********************************************************************; SYMBOLIC PROCEDURE FORALLSTAT; BEGIN SCALAR ARBL,CONDS; IF CURSYM!* MEMQ LETL!* THEN SYMERR('forall,T); FLAG(LETL!*,'DELIM); ARBL := REMCOMMA XREAD NIL; IF CURSYM!* EQ 'SUCH THEN <<IF NOT SCAN() EQ 'THAT THEN SYMERR('let,T); CONDS := XREAD NIL>>; REMFLAG(LETL!*,'DELIM); RETURN IFLET1(ARBL,CONDS) END; SYMBOLIC PROCEDURE IFLET U; IFLET1(NIL,U); SYMBOLIC PROCEDURE IFLET1(ARBL,CONDS); IF NOT CURSYM!* MEMQ LETL!* THEN SYMERR('let,T) ELSE LIST('FORALL,ARBL,CONDS,XREAD1 T); SYMBOLIC PROCEDURE FORMARB(U,VARS,MODE); <<ARBL!* := CAR U . ARBL!*; MKQUOTE CAR U>>; PUT('ARB,'FORMFN,'FORMARB); PUT('FORALL,'STAT,'FORALLSTAT); SYMBOLIC FEXPR PROCEDURE FORALL U; BEGIN SCALAR X,Y; X := FOR EACH J IN CAR U COLLECT NEWVAR J; Y := PAIR(CAR U,X); MCOND!* := SUBLA(Y,CADR U); FRASC!* := Y; FRLIS!* := UNION(X,FRLIS!*); RETURN EVAL CADDR U END; SYMBOLIC PROCEDURE FORMFORALL(U,VARS,MODE); BEGIN SCALAR ARBL!*,X; % VARS := APPEND(CAR U,VARS); %semantics are different; IF NULL CADR U THEN X := T ELSE X := FORMBOOL(CADR U,VARS,MODE); RETURN LIST('FORALL,UNION(ARBL!*,CAR U), X,FORM1(CADDR U,VARS,MODE)) END; PUT('FORALL,'FORMFN,'FORMFORALL); SYMBOLIC PROCEDURE NEWVAR U; IF NOT IDP U THEN TYPERR(U,"free variable") ELSE INTERN COMPRESS APPEND(EXPLODE '!=,EXPLODE U); %********************************************************************* % 2.19 SUBSTITUTION COMMANDS %********************************************************************; SYMBOLIC PROCEDURE FORMLET1(U,VARS,MODE); 'LIST . FOR EACH X IN U COLLECT IF EQEXPR X THEN LIST('LIST,MKQUOTE 'EQUAL,FORM1(CADR X,VARS,MODE), !*S2ARG(FORM1(CADDR X,VARS,MODE),VARS)) ELSE ERRPRI2(X,T); SYMBOLIC PROCEDURE !*S2ARG(U,VARS); %makes all NOCHANGE operators into their listed form; IF ATOM U THEN U ELSE IF NOT IDP CAR U OR NOT FLAGP(CAR U,'NOCHANGE) THEN FOR EACH J IN U COLLECT !*S2ARG(J,VARS) ELSE MKARG(U,VARS); PUT('LET,'FORMFN,'FORMLET); PUT('CLEAR,'FORMFN,'FORMCLEAR); PUT('MATCH,'FORMFN,'FORMMATCH); SYMBOLIC PROCEDURE FORMCLEAR(U,VARS,MODE); LIST('CLEAR,FORMCLEAR1(U,VARS,MODE)); SYMBOLIC PROCEDURE FORMCLEAR1(U,VARS,MODE); 'LIST . FOR EACH X IN U COLLECT FORM1(X,VARS,MODE); SYMBOLIC PROCEDURE FORMLET(U,VARS,MODE); LIST('LET,FORMLET1(U,VARS,MODE)); SYMBOLIC PROCEDURE FORMMATCH(U,VARS,MODE); LIST('MATCH,FORMLET1(U,VARS,MODE)); SYMBOLIC PROCEDURE LET U; LET0(U,NIL); SYMBOLIC PROCEDURE LET0(U,V); BEGIN FOR EACH X IN U DO LET2(CADR X,CADDR X,V,T); MCOND!* := FRASC!* := NIL END; SYMBOLIC PROCEDURE LET2(U,V,W,B); BEGIN SCALAR FLG,X,Y,Z; %FLG is set true if free variables are found in following; X := SUBLA(FRASC!*,U); IF X NEQ U THEN IF ATOM X THEN GO TO LER1 %an atom cannot be free; ELSE <<FLG := T; U := X>>; X := SUBLA(FRASC!*,V); IF X NEQ V THEN <<V := X; IF EQCAR(V,'!*SQ!*) THEN V := PREPSQ!* CADR V>>; %to ensure no kernels or powers are copied during %pattern matching process; %check for unmatched free variables; X := SMEMQL(FRLIS!*,MCOND!*); Y := SMEMQL(FRLIS!*,U); IF (Z := SETDIFF(X,Y)) OR (Z := SETDIFF(SETDIFF(SMEMQL(FRLIS!*,V),X), SETDIFF(Y,X))) THEN <<LPRIE ("Unmatched free variable(s)" . Z); ERFG!* := 'HOLD; RETURN NIL>> ELSE IF EQCAR(U,'GETEL) THEN U := EVAL CADR U; A: X := U; IF NUMBERP X THEN GO TO LER1 ELSE IF IDP X AND FLAGP(X,'RESERVED) THEN REDERR LIST(X,"is a reserved identifier"); Y := TYPL!*; B: IF NULL Y THEN GO TO C ELSE IF (Z := APPLY(CAR Y,LIST X)) OR APPLY(CAR Y,LIST V) THEN RETURN APPLY(GET(CAR Y,'LETFN), LIST(X,V,GET(CAR Y,'NAME),B,Z)); Y := CDR Y; GO TO B; C: IF NOT ATOM X THEN GO TO NONATOM; IF B OR W THEN GO TO D; %We remove all conceivable properties when an atom is cleared; REMPROP(X,'AVALUE); REMPROP(X,'OPMTCH); % REMPROP(X,'KLIST); %since the relevant objects may still %exist; REMPROP(X,'MATRIX); IF ARRAYP X THEN <<REMPROP(X,'ARRAY); REMPROP(X,'DIMENSION)>>; WTL!* := DELASC(X,WTL!*); RMSUBS(); %since all kernel lists are gone; RETURN; D: X := SIMP0 X; IF NOT DENR X=1 OR DOMAINP (X := NUMR X) THEN GO TO LER1; D1: IF W OR FLG OR DOMAINP X OR RED X OR LC X NEQ 1 OR LDEG X NEQ 1 OR EXPTP!* THEN GO TO PRODCT; Y := MVAR X; IF ATOM Y THEN IF FLAGP(Y,'USED!*) THEN RMSUBS() ELSE NIL ELSE IF 'USED!* MEMQ CDDR FKERN Y THEN RMSUBS(); SETK1(Y,V,B); RETURN; NONATOM: %replacement for non-atomic expression; IF NOT IDP CAR X THEN GO TO LER2 ELSE IF ARRAYP CAR X THEN GO TO ARR ELSE IF CAR X EQ 'DF THEN GO TO DIFF ELSE IF (Y := GET(CAR X,'MATRIX)) THEN RETURN LETMTR(U,V,Y) ELSE IF NOT GET(CAR X,'SIMPFN) THEN GO TO LER3 ELSE GO TO D; PRODCT: %replacement of powers and products; IF EXPTP!* THEN W:= T; %to allow for normal form for exponent expressions; EXPTP!* := NIL; RMSUBS(); IF NULL FLG AND RED X THEN RETURN SPLIS!* := XADD(LIST(X,W . T,V,NIL), SPLIS!*,U,B); Y := KERNLP X; IF Y=-1 THEN BEGIN X:= NEGF X; V:= LIST('MINUS,V) END ELSE IF Y NEQ 1 THEN GO TO LER1; X := KLISTT X; Y := LIST(W . (IF MCOND!* THEN MCOND!* ELSE T),V,NIL); IF CDR X THEN RETURN (!*MATCH := XADD!*(X . Y,!*MATCH,U,B)) ELSE IF NULL W AND ONEP CDAR X THEN GO TO P1; IF V=0 AND NULL W AND NOT FLG THEN <<ASYMPLIS!* := XADD(CAR X,ASYMPLIS!*,U,B); POWLIS!* := XADD(CAAR X . CDAR X . Y,POWLIS!*,U,NIL)>> ELSE IF W OR NOT CDAR Y EQ T OR FRASC!* THEN POWLIS1!* := XADD(CAR X . Y,POWLIS1!*,U,B) ELSE IF NULL B AND (Z := ASSOC(CAAR X,ASYMPLIS!*)) AND Z=CAR X THEN ASYMPLIS!* := DELASC(CAAR X,ASYMPLIS!*) ELSE <<POWLIS!* := XADD(CAAR X . CDAR X . Y,POWLIS!*,U,B); ASYMPLIS!* := DELASC(CAAR X,ASYMPLIS!*)>>; RETURN; P1: X := CAAR X; IF ATOM X THEN GO TO LER1; RETURN PUT(CAR X, 'OPMTCH, XADD!*(CDR X . Y,GET(CAR X,'OPMTCH),U,B)); DIFF: %rules for differentiation; IF NULL LETDF(U,V,W,X,B) THEN GO TO D ELSE RETURN; ARR: %array replacements; SETELV(X,V); RETURN; LER1:EXPTP!* := NIL; RETURN ERRPRI1 U; LER2:RETURN ERRPRI2(U,'HOLD); LER3:REDMSG(CAR X,"operator"); MKOP CAR X; GO TO A END; SYMBOLIC PROCEDURE SIMP0 U; BEGIN SCALAR X; IF EQCAR(U,'!*SQ) THEN RETURN SIMP0 PREPSQ!* CADR U; X := SUBFG!* . !*SUB2; SUBFG!* := NIL; IF ATOM U OR CAR U MEMQ '(EXPT MINUS PLUS TIMES QUOTIENT) THEN U := SIMP U ELSE U := SIMPIDEN U; SUBFG!* := CAR X; !*SUB2 := CDR X; RETURN U END; SYMBOLIC PROCEDURE MATCH U; LET0(U,T); SYMBOLIC PROCEDURE CLEAR U; BEGIN RMSUBS(); FOR EACH X IN U DO <<LET2(X,NIL,NIL,NIL); LET2(X,NIL,T,NIL)>>; MCOND!* := FRASC!* := NIL END; SYMBOLIC PROCEDURE SETK(U,V); <<LET2(U,V,NIL,T); V>>; %U is a literal atom or a pseudo-kernel, V an expression %SETK associates value V with U and returns V; % IF ATOM U THEN SETK1(U,V,T) % ELSE IF ARRAYP CAR U % THEN <<SETELV(U,V); %V>> % ELSE !*A2K REVOP1 U; SYMBOLIC PROCEDURE SETK1(U,V,B); BEGIN SCALAR X,Y; IF NOT ATOM U THEN GO TO C ELSE IF NULL B THEN GO TO B1 ELSE IF (X := GET(U,'AVALUE)) THEN GO TO A; X := NIL . NIL; PUT(U,'AVALUE,X); A: RPLACD(RPLACA(X,V),NIL); RETURN V; B1: IF NOT GET(U,'AVALUE) THEN MSGPRI(NIL,U,"not found",NIL,NIL) ELSE REMPROP(U,'AVALUE); RETURN; C: IF NOT ATOM CAR U THEN REDERR "Invalid syntax: improper assignment" ELSE IF NULL B THEN GO TO B2 ELSE IF NOT (Y := GET(CAR U,'KVALUE)) THEN GO TO E ELSE IF X := ASSOC(U,Y) THEN GO TO D; X := NIL . NIL; ACONC(Y,U . X); GO TO A; D: X := CDR X; GO TO A; E: X := NIL . NIL; PUT(CAR U,'KVALUE,LIST(U . X)); GO TO A; B2: IF NOT(Y := GET(CAR U,'KVALUE)) OR NOT (X := ASSOC(U,Y)) THEN MSGPRI(NIL,U,"not found",NIL,NIL) ELSE PUT(CAR U,'KVALUE,DELETE(X,Y)); RETURN; END; SYMBOLIC PROCEDURE KLISTT U; IF ATOM U THEN NIL ELSE CAAR U . KLISTT CDR CARX(U,'LIST); SYMBOLIC PROCEDURE KERNLP U; IF DOMAINP U THEN U ELSE IF NULL CDR U THEN KERNLP CDAR U ELSE NIL; SYMBOLIC PROCEDURE RMSUBS; <<RMSUBS1(); RMSUBS2()>>; SYMBOLIC PROCEDURE RMSUBS2; BEGIN RPLACA(!*SQVAR!*,NIL); !*SQVAR!* := LIST T; % WHILE KPROPS!* DO % <<REMPROP(CAR KPROPS!*,'KLIST); %KPROPS!* := CDR KPROPS!*>>; % EXLIST!* := LIST '(!*); %This is too dangerous: someone else may have constructed a %standard form; ALGLIST!* := NIL END; SYMBOLIC PROCEDURE RMSUBS1; NIL; % BEGIN % A: IF NULL SUBL!* THEN GO TO B; % RPLACD(CAR SUBL!*,NIL); % SUBL!* := CDR SUBL!*; % GO TO A; % B: IF NULL DSUBL!* THEN RETURN; % RPLACA(CAR DSUBL!*,NIL); % DSUBL!* := CDR DSUBL!*; % GO TO B % END; SYMBOLIC PROCEDURE XADD(U,V,W,B); %adds replacement U to table V, with new rule at head; BEGIN SCALAR X; X := ASSOC(CAR U,V); IF NULL X THEN GO TO C; V := DELETE(X,V); IF B THEN BEGIN RMSUBS1(); V := U . V END; A: RETURN V; C: IF B THEN V := U . V; GO TO A END; SYMBOLIC PROCEDURE XADD!*(U,V,W,B); %adds replacement U to table V, with new rule at head; %also checks boolean part for equality; BEGIN SCALAR X; X := V; WHILE X AND NOT(CAR U=CAAR X AND CADR U=CADAR X) DO X := CDR X; IF X THEN <<V := DELETE(CAR X,V); IF B THEN RMSUBS1()>>; IF B THEN V := U . V; RETURN V END; RLISTAT '(CLEAR LET MATCH); FLAG ('(CLEAR LET MATCH),'QUOTE); %********************************************************************* % VARIOUS DECLARATIONS %********************************************************************; PUT('OPERATOR,'FORMFN,'FORMOPR); SYMBOLIC PROCEDURE FORMOPR(U,VARS,MODE); IF MODE EQ 'SYMBOLIC THEN MKPROG(NIL,LIST LIST('FLAG,MKQUOTE U,MKQUOTE 'OPFN)) ELSE LIST('OPERATOR,MKARG(U,VARS)); SYMBOLIC PROCEDURE OPERATOR U; FOR EACH J IN U DO MKOP J; RLISTAT '(OPERATOR); SYMBOLIC PROCEDURE DEN U; MK!*SQ (DENR SIMP!* U ./ 1); SYMBOLIC PROCEDURE NUM U; MK!*SQ (NUMR SIMP!* U ./ 1); FLAG ('(DEN NUM ABS MAX MIN),'OPFN); FLAG('(DEN NUM),'NOVAL); PUT('SAVEAS,'FORMFN,'FORMSAVEAS); SYMBOLIC PROCEDURE FORMSAVEAS(U,VARS,MODE); LIST('SAVEAS,FORMCLEAR1(U,VARS,MODE)); SYMBOLIC PROCEDURE SAVEAS U; LET0(LIST LIST('EQUAL,CAR U, IF FRASC!* AND EQCAR(WS,'!*SQ) THEN PREPSQ CADR WS ELSE WS), NIL); RLISTAT '(SAVEAS); SYMBOLIC PROCEDURE TERMS U; TERMSF NUMR SIMP!* U; FLAG ('(TERMS),'OPFN); FLAG('(TERMS),'NOVAL); SYMBOLIC PROCEDURE TERMSF U; %U is a standard form. %Value is number of terms in U (excluding kernel structure); BEGIN INTEGER N; N := 0; A: IF NULL U THEN RETURN N ELSE IF DOMAINP U THEN RETURN N+1; N := N + TERMSF LC U; U := RED U; GO TO A END; %********************************************************************* %********************************************************************* %********************************************************************* % SECTION 3 % SPECIFIC ALGEBRAIC PACKAGES %********************************************************************* %********************************************************************* %********************************************************************; %********************************************************************* %All these packages except where noted are self-contained and any or %all may be omitted as required; %********************************************************************; %********************************************************************* %********************************************************************* % DIFFERENTIATION PACKAGE %********************************************************************* %********************************************************************; % REQUIRES EXPRESSION DEPENDENCY MODULE; SYMBOLIC PROCEDURE SIMPDF U; %U is a list of forms, the first an expression and the remainder %kernels and numbers. %Value is derivative of first form wrt rest of list; BEGIN SCALAR V,X,Y; IF NULL SUBFG!* THEN RETURN MKSQ('DF . U,1); V := CDR U; U := SIMP!* CAR U; A: IF NULL V OR NULL NUMR U THEN RETURN U; X := IF NULL Y OR Y=0 THEN SIMP!* CAR V ELSE Y; IF NULL KERNP X THEN TYPERR(PREPSQ X,"kernel"); X := CAAAAR X; V := CDR V; IF NULL V THEN GO TO C; Y := SIMP!* CAR V; IF NULL NUMR Y THEN <<V := CDR V; Y := NIL; GO TO A>> ELSE IF NOT DENR Y=1 OR NOT NUMBERP NUMR Y THEN GO TO C; V := CDR V; B: FOR I:=1:CAR Y DO U := DIFFSQ(U,X); Y := NIL; GO TO A; C: U := DIFFSQ(U,X); GO TO A END; PUT('DF,'SIMPFN,'SIMPDF); SYMBOLIC PROCEDURE DIFFSQ(U,V); %U is a standard quotient, V a kernel. %Value is the standard quotient derivative of U wrt V. %Algorithm: df(x/y,z)= (x'-(x/y)*y')/y; MULTSQ(ADDSQ(DIFFF(NUMR U,V),NEGSQ MULTSQ(U,DIFFF(DENR U,V))), 1 ./ DENR U); SYMBOLIC PROCEDURE DIFFF(U,V); %U is a standard form, V a kernel. %Value is the standard quotient derivative of U wrt V; IF DOMAINP U THEN NIL ./ 1 ELSE ADDSQ(ADDSQ(MULTPQ(LPOW U,DIFFF(LC U,V)), MULTSQ(LC U ./ 1,DIFFP(LPOW U,V))), DIFFF(RED U,V)); SYMBOLIC PROCEDURE DIFFP(U,V); %U is a standard power, V a kernel. %Value is the standard quotient derivative of U wrt V; BEGIN SCALAR W,X,Y,Z; INTEGER N; N := CDR U; %integer power; U := CAR U; %main variable; IF U EQ V AND (W := 1 ./ 1) THEN GO TO E ELSE IF ATOM U THEN GO TO F %ELSE IF (X := ASSOC(U,DSUBL!*)) AND (X := ATSOC(V,CDR X)) % AND (W := CDR X) THEN GO TO E %deriv known; %DSUBL!* not used for now; ELSE IF (NOT ATOM CAR U AND (W:= DIFFF(U,V))) OR (CAR U EQ '!*SQ AND (W:= DIFFSQ(CADR U,V))) THEN GO TO C %extended kernel found; ELSE IF (X:= GET!*(CAR U,'DFN)) THEN NIL ELSE IF CAR U EQ 'PLUS AND (W:=DIFFSQ(SIMP U,V)) THEN GO TO C ELSE GO TO H; %unknown derivative; Y := X; Z := CDR U; A: W := DIFFSQ(SIMP CAR Z,V) . W; IF CAAR W AND NULL CAR Y THEN GO TO H; %unknown deriv; Y := CDR Y; Z := CDR Z; IF Z AND Y THEN GO TO A ELSE IF Z OR Y THEN GO TO H; %arguments do not match; Y := REVERSE W; Z := CDR U; W := NIL ./ 1; B: %computation of kernel derivative; IF CAAR Y THEN W := ADDSQ(MULTSQ(CAR Y,SIMP SUBLA(PAIR(CAAR X,Z), CDAR X)), W); X := CDR X; Y := CDR Y; IF Y THEN GO TO B; C: %save calculated deriv in case it is used again; %IF X := ATSOC(U,DSUBL!*) THEN GO TO D %ELSE X := U . NIL; %DSUBL!* := X . DSUBL!*; D: %RPLACD(X,XADD(V . W,CDR X,NIL,T)); E: %allowance for power; %first check to see if kernel has weight; IF (X := ATSOC(U,WTL!*)) THEN W := MULTPQ('K!* TO (-CDR X),W); RETURN IF N=1 THEN W ELSE MULTSQ(!*T2Q((U TO (N-1)) .* N),W); F: %check for possible unused substitution rule; IF NOT DEPENDS(U,V) AND (NOT (X:= ATSOC(U,POWLIS!*)) OR NOT CAR DIFFSQ(SIMP CADDDR X,V)) THEN RETURN NIL ./ 1; W := MKSQ(LIST('DF,U,V),1); GO TO E; H: %final check for possible kernel deriv; IF CAR U EQ 'DF THEN IF DEPENDS(CADR U,V) THEN W := 'DF . CADR U . DERAD(V,CDDR U) ELSE RETURN NIL ./ 1 ELSE IF DEPENDS(U,V) THEN W := LIST('DF,U,V) ELSE RETURN NIL ./ 1; W := IF X := OPMTCH W THEN SIMP X ELSE MKSQ(W,1); GO TO E END; SYMBOLIC PROCEDURE DERAD(U,V); IF NULL V THEN LIST U ELSE IF NUMBERP CAR V THEN CAR V . DERAD(U,CDR V) ELSE IF U=CAR V THEN IF CDR V AND NUMBERP CADR V THEN U . (CADR V + 1) . CDDR V ELSE U . 2 . CDR V ELSE IF ORDP(U,CAR V) THEN U . V ELSE CAR V . DERAD(U,CDR V); SYMBOLIC PROCEDURE LETDF(U,V,W,X,B); BEGIN SCALAR Z; IF ATOM CADR X THEN GO TO E ELSE IF NOT GETTYPE CAADR X EQ 'OPERATOR THEN GO TO LER3; A: RMSUBS(); IF NOT FRLP CDADR X OR NULL CDDR X OR CDDDR X OR NOT FRLP CDDR X OR NOT CADDR X MEMBER CDADR X THEN GO TO E; Z := LPOS(CADDR X,CDADR X); IF NOT GET(CAADR X,'DFN) THEN PUT(CAADR X, 'DFN, NLIST(NIL,LENGTH CDADR X)); W := GET(CAADR X,'DFN); B1: IF NULL W OR Z=0 THEN RETURN ERRPRI1 U ELSE IF Z NEQ 1 THEN GO TO C ELSE IF NULL B THEN GO TO D; % ELSE IF CAR W % THEN MSGPRI("Assignment for",X,"redefined",NIL,NIL); RETURN RPLACA(W,CDADR X . V); C: W := CDR W; Z := Z-1; GO TO B1; D: %IF NULL CAR W THEN MSGPRI(NIL,X,"not found",NIL,NIL); RETURN RPLACA(W,NIL); LER3:REDMSG(CAADR X,"operator"); MKOP CAADR X; GO TO A; E: %check for dependency; IF CADDR X MEMQ FRLIS!* THEN RETURN NIL ELSE IF IDP CADR X AND NOT(CADR X MEMQ FRLIS!*) THEN DEPEND1(CADR X,CADDR X,T) ELSE IF NOT ATOM CADR X AND IDP CAADR X AND FRLP CDADR X THEN DEPEND1(CAADR X,CADDR X,T); RETURN NIL END; SYMBOLIC PROCEDURE FRLP U; NULL U OR (CAR U MEMQ FRLIS!* AND FRLP CDR U); SYMBOLIC PROCEDURE LPOS(U,V); IF U EQ CAR V THEN 1 ELSE LPOS(U,CDR V)+1; END; |
Added r30/alg2.fap version [8991844ee1].
cannot compute difference between binary files
Added r30/alg2.red version [95a91c908a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %********************************************************************* %********************************************************************* % REDUCE BASIC ALGEBRAIC PROCESSOR (PART 2) %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; COMMENT The following free variables are referenced in this module; FLUID '(!*MCD); GLOBAL '(ASYMPLIS!* FRLIS!* KORD!* MCHFG!* MCOND!* POWLIS!* POWLIS1!* SPLIS!* SUBFG!* TYPL!* VARNAM!* WTL!* !*FLOAT !*FORT !*MATCH !*NAT !*PRI !*RESUBS !*SUB2); %********************************************************************* %********************************************************************* % FUNCTIONS WHICH APPLY MORE GENERAL PATTERN MATCHING RULES %********************************************************************* %********************************************************************; %********************************************************************* % FUNCTIONS FOR MATCHING POWERS %********************************************************************; COMMENT Fluid variable used in this section; FLUID '(!*STRUCTURE); !*STRUCTURE := NIL; COMMENT If STRUCTURE is ON, then expressions like (a**(b/2))**2 are not simplified, to allow some attempt at a structure theorem use, especially in the integrator; SYMBOLIC PROCEDURE SUBS2Q U; QUOTSQ(SUBS2F NUMR U,SUBS2F DENR U); SYMBOLIC PROCEDURE SUBS2F U; BEGIN SCALAR X; !*SUB2 := NIL; X := SUBS2F1 U; IF (!*SUB2 OR POWLIS1!*) AND !*RESUBS THEN IF NUMR X=U AND DENR X=1 THEN !*SUB2 := NIL ELSE X := SUBS2Q X; RETURN X; END; SYMBOLIC PROCEDURE SUBS2F1 U; IF DOMAINP U THEN !*D2Q U ELSE BEGIN SCALAR KERN,V,W,X,Y,Z; KERN := MVAR U; Z := NIL ./ 1; A: IF NULL U OR DEGR(U,KERN)=0 THEN GO TO A1; Y := LT U .+ Y; U := RED U; GO TO A; A1: X := POWLIS!*; A2: IF NULL X THEN GO TO B ELSE IF CAAAR Y = CAAR X THEN <<W := SUBS2P(CAAR Y,CADAR X,CADDDR CAR X); GO TO E1>> % ELSE IF EQCAR(KERN,'SQRT) AND CADR KERN = CAAR X % THEN <<W := RADDSQ(SUBS2P(CADR KERN . CDAAR Y, % CADAR X,CADDDR CAR X),2);% GO TO E1>>; ELSE IF EQCAR(KERN,'EXPT) AND CADR KERN = CAAR X AND EQCAR(CADDR KERN,'QUOTIENT) AND CADR CADDR KERN = 1 AND NUMBERP CADDR CADDR KERN THEN <<V := DIVIDE(CDAAR Y,CADDR CADDR KERN); IF CAR V NEQ 0 THEN W := MKSQ(CADR KERN,CAR V) ELSE W := 1 ./ 1; IF CDR V NEQ 0 THEN <<V := CANCEL(CDR V.CADDR CADDR KERN); W := MULTSQ(RADDSQ(SUBS2P(CADR KERN . CAR V, CADAR X,CADDDR CAR X), CDR V),W)>>; GO TO E1>>; X := CDR X; GO TO A2; B: X := POWLIS1!*; L2: IF NULL X THEN GO TO L3 ELSE IF W:= MTCHP(CAAR Y,CAAR X,CADDAR X,CAADAR X,CDADAR X) THEN GO TO E1; X := CDR X; GO TO L2; L3: IF EQCAR(KERN,'EXPT) AND NOT !*STRUCTURE THEN GO TO L1; Z := ADDSQ(MULTPQ(CAAR Y,SUBS2F1 CDAR Y),Z); C: Y := CDR Y; IF Y THEN GO TO A1; D: RETURN ADDSQ(Z,SUBS2F1 U); E1: Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z); GO TO C; L1: IF ONEP CDAAR Y THEN W := MKSQ(KERN,1) ELSE W := SIMPEXPT LIST(CADR KERN, LIST('TIMES,CADDR KERN,CDAAR Y)); Z := ADDSQ(MULTSQ(W,SUBS2F1 CDAR Y),Z); Y := CDR Y; IF Y THEN GO TO L1 ELSE GO TO D; END; SYMBOLIC PROCEDURE SUBS2P(U,V,W); %U is a power, V an integer, and W an algebraic expression, such %that CAR U**V=W. Value is standard quotient for U with this %substitution; BEGIN V := DIVIDE(CDR U,V); IF CAR V=0 THEN RETURN !*P2Q U; W := EXPTSQ(SIMP W,CAR V); RETURN IF CDR V=0 THEN W ELSE MULTPQ(CAR U TO CDR V,W) END; SYMBOLIC PROCEDURE RADDSQ(U,N); %U is a standard quotient, N and integer. Value is sq for U**(1/N); SIMPEXPT LIST(MK!*SQ U,LIST('QUOTIENT,1,N)); SYMBOLIC PROCEDURE MTCHP(U,V,W,FLG,BOOL); %U is a standard power, V a power to be matched against. %W is the replacement expression. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is the substitution standard quotient if a match found, %NIL otherwise; BEGIN SCALAR X; X := MTCHP1(U,V,FLG,BOOL); A: IF NULL X THEN RETURN NIL ELSE IF EVAL SUBLA(CAR X,BOOL) THEN GO TO B; X := CDR X; GO TO A; B: V := DIVIDE(CDR U,SUBLA(CAR X,CDR V)); W := EXPTSQ(SIMP SUBLA(CAR X,W),CAR V); IF CDR V NEQ 0 THEN W := MULTPQ(CAR U TO CDR V,W); RETURN W END; SYMBOLIC PROCEDURE MTCHP1(U,V,FLG,BOOL); %U is a standard power, V a power to be matched against. %FLG is a flag which is T if an exact power match required. %BOOL is a boolean expression to be satisfied for substitution. %Value is a list of possible free variable pairings which %match conditions; BEGIN SCALAR X; IF U=V THEN RETURN LIST NIL ELSE IF NOT (X:= MCHK(CAR U,CAR V)) THEN RETURN NIL ELSE IF CDR V MEMQ FRLIS!* THEN RETURN MAPCONS(X,CDR V . CDR U) ELSE IF (FLG AND NOT CDR U=CDR V) OR (IF !*MCD THEN CDR U<CDR V ELSE (CDR U*CDR V)<0 OR %implements explicit sign matching; ABS CDR U<ABS CDR V) THEN RETURN NIL ELSE RETURN X END; %********************************************************************* % FUNCTIONS FOR MATCHING PRODUCTS %********************************************************************; SYMBOLIC PROCEDURE SUBS3Q U; %U is a standard quotient. %Value is a standard quotient with all product substitutions made; BEGIN SCALAR X; X := MCHFG!*; %save value in case we are in inner loop; MCHFG!* := NIL; U := QUOTSQ(SUBS3F NUMR U,SUBS3F DENR U); MCHFG!* := X; RETURN U END; SYMBOLIC PROCEDURE SUBS3F U; %U is a standard form. %Value is a standard quotient with all product substitutions made; SUBS3F1(U,!*MATCH,T); SYMBOLIC PROCEDURE SUBS3F1(U,L,BOOL); %U is a standard form. %L is a list of possible matches. %BOOL is a boolean variable which is true if we are at top level. %Value is a standard quotient with all product substitutions made; BEGIN SCALAR X,Z; Z := NIL ./ 1; A: IF NULL U THEN RETURN Z ELSE IF DOMAINP U THEN RETURN ADDSQ(Z,U ./ 1) ELSE IF BOOL AND DOMAINP LC U THEN GO TO C; X := SUBS3T(LT U,L); IF NOT BOOL %not top level; OR NOT MCHFG!* THEN GO TO B; %no replacement made; MCHFG!* := NIL; IF NULL !*RESUBS THEN GO TO B ELSE IF !*SUB2 OR POWLIS1!* THEN X := SUBS2Q X; %make another pass; X := SUBS3Q X; B: Z := ADDSQ(Z,X); U := CDR U; GO TO A; C: X := LIST LT U ./ 1; GO TO B END; SYMBOLIC PROCEDURE SUBS3T(U,V); %U is a standard term, V a list of matching templates. %Value is a standard quotient for the substituted term; BEGIN SCALAR X,Y,Z; X := MTCHK(CAR U,IF DOMAINP CDR U THEN SIZCHK(V,1) ELSE V); IF NULL X THEN GO TO A %lpow doesn't match; ELSE IF NULL CAAR X THEN GO TO B; %complete match found; Y := SUBS3F1(CDR U,X,NIL); %check tc for match; IF MCHFG!* THEN RETURN MULTPQ(CAR U,Y); A: RETURN LIST U . 1; %no match; B: X := CDDAR X; %list(<subst value>,<denoms>); Z := CAADR X; %leading denom; MCHFG!* := NIL; %initialize for tc check; Y := SUBS3F1(CDR U,!*MATCH,NIL); MCHFG!* := T; IF CAR Z NEQ CAAR U THEN GO TO E ELSE IF Z NEQ CAR U %powers don't match; THEN Y := MULTPQ(CAAR U TO (CDAR U-CDR Z),Y); B1: Y := MULTSQ(SIMPCAR X,Y); X := CDADR X; IF NULL X THEN RETURN Y; Z := 1; %unwind remaining denoms; C: IF NULL X THEN GO TO D; Z:=LIST(MKSP(CAAR X, %was IF ATOM CAAR X OR SFP CAAR X THEN CAAR X ELSE REVOP1 CAAR X; IF !*MCD THEN CDAR X ELSE -CDAR X) . Z); %kernel CAAR X is not unique here; X := CDR X; GO TO C; D: RETURN IF !*MCD THEN CAR Y . MULTF(Z,CDR Y) ELSE MULTF(Z,CAR Y) . CDR Y; E: IF SIMP CAR Z NEQ SIMP CAAR U THEN ERRACH LIST('SUBS3T,U,X,Z); %maybe arguments were in different order, otherwise it's fatal; IF CDR Z NEQ CDAR U THEN Y:= MULTPQ(CAAR U TO (CDAR U-CDR Z),Y); GO TO B1 END; SYMBOLIC PROCEDURE SIZCHK(U,N); IF NULL U THEN NIL ELSE IF LENGTH CAAR U>N THEN SIZCHK(CDR U,N) ELSE CAR U . SIZCHK(CDR U,N); SYMBOLIC PROCEDURE MTCHK(U,V); %U is a standard power, V a list of matching templates. %If a match is made, value is of the form: %list list(NIL,<boolean form>,<subst value>,<denoms>), %otherwise value is an updated list of templates; BEGIN SCALAR FLG,V1,W,X,Y,Z; FLG := NONCOMP CAR U; A0: IF NULL V THEN RETURN Z; V1 := CAR V; W := CAR V1; A: IF NULL W THEN GO TO D; X := MTCHP1(U,CAR W,CAADR V1,CDADR V1); B: IF NULL X THEN GO TO C ELSE IF CAR (Y := SUBLA(CAR X,DELETE(CAR W,CAR V1)) . LIST(SUBLA(CAR X,CADR V1), SUBLA(CAR X,CADDR V1), SUBLA(CAR X,CAR W) . CADDDR V1)) THEN Z := Y . Z ELSE IF EVAL SUBLA(CAR X,CDADR V1) THEN RETURN LIST Y; X := CDR X; GO TO B; C: IF FLG THEN GO TO C1; W := CDR W; GO TO A; C1: IF CADDDR V1 AND NOT NOCP CADDDR V1 THEN GO TO E; D: Z := APPEND(Z,LIST V1); E: V := CDR V; GO TO A0 END; SYMBOLIC PROCEDURE NOCP U; NULL U OR (NONCOMP CAAR U AND NOCP CDR U); %********************************************************************* % FUNCTIONS FOR MATCHING SUMS %********************************************************************; SYMBOLIC PROCEDURE SUBS4Q U; QUOTSQ(SUBS4F NUMR U,SUBS4F DENR U); SYMBOLIC PROCEDURE SUBS4F U; BEGIN SCALAR W,X,Y,Z; X := SPLIS!*; A: IF NULL X THEN RETURN U ./ 1; W := LQREMF!*(U,CAAR X); IF NULL CDR W THEN <<X := CDR X; GO TO A>>; X := SIMP CADDAR X; Y := 1 ./ 1; Z := NIL ./ 1; WHILE W DO <<IF CAR W THEN Z := ADDSQ(MULTSQ(CAR W ./ 1,Y),Z); Y := MULTSQ(X,Y); W := CDR W>>; RETURN IF DENR Z=1 AND NUMR Z=U THEN U ./ 1 ELSE SUBS4Q Z; %one could test on size here and only change if smaller; END; SYMBOLIC PROCEDURE LQREMF!*(U,V); IF DOMAINP U THEN LIST U ELSE LQREMF(U,REORDER V); %********************************************************************* %********************************************************************* % EXTENDED OUTPUT PACKAGE FOR EXPRESSIONS %********************************************************************* %********************************************************************; %Global variables used in this Section; GLOBAL '(DNL!* FACTORS!* ORDL!* UPL!* !*ALLFAC !*DIV !*RAT); DNL!* := NIL; %output control flag: puts powers in denom; FACTORS!* := NIL; %list of output factors; ORDL!* := NIL; %list of kernels introduced by ORDER statement; UPL!* := NIL; %output control flag: puts denom powers in %numerator; !*ALLFAC := T; %factoring option for this package; !*DIV := NIL; %division option in this package; !*RAT := NIL; %flag indicating rational mode for output; !*PRI := T; %to activate this package; SYMBOLIC PROCEDURE FACTOR U; FACTOR1(U,T,'FACTORS!*); SYMBOLIC PROCEDURE FACTOR1(U,V,W); BEGIN SCALAR X,Y; Y := EVAL W; FOR EACH J IN U DO <<X := !*A2K J; IF V THEN Y := ACONC(DELETE(X,Y),X) ELSE IF NOT X MEMBER Y THEN MSGPRI(NIL,J,"not found",NIL,NIL) ELSE Y := DELETE(X,Y)>>; SET(W,Y) END; SYMBOLIC PROCEDURE REMFAC U; FACTOR1(U,NIL,'FACTORS!*); RLISTAT '(FACTOR REMFAC); SYMBOLIC PROCEDURE ORDER U; IF U AND NULL CAR U AND NULL CDR U THEN (ORDL!* := NIL) ELSE FOR EACH X IN U DO <<IF (X := !*A2K X) MEMBER ORDL!* THEN ORDL!* := DELETE(X,ORDL!*); ORDL!* := ACONC(ORDL!*,X)>>; RLISTAT '(ORDER); SYMBOLIC PROCEDURE UP U; FACTOR1(U,T,'UPL!*); SYMBOLIC PROCEDURE DOWN U; FACTOR1(U,T,'DNL!*); RLISTAT '(UP DOWN); SYMBOLIC PROCEDURE FORMOP U; IF DOMAINP U THEN U ELSE RADDF(MULTOP(LPOW U,FORMOP LC U),FORMOP RED U); SYMBOLIC PROCEDURE MULTOP(U,V); IF NULL KORD!* THEN MULTPF(U,V) ELSE IF CAR U EQ 'K!* THEN V ELSE RMULTPF(U,V); SYMBOLIC SMACRO PROCEDURE LCX U; %returns leading coefficient of a form with zero reductum, or an %error otherwise; CDR CARX U; SYMBOLIC PROCEDURE QUOTOF(P,Q); %P is a standard form, Q a standard form which is either a domain %element or has zero reductum. %returns the quotient of P and Q for output purposes; IF NULL P THEN NIL ELSE IF P=Q THEN 1 ELSE IF Q=1 THEN P ELSE IF DOMAINP Q THEN QUOTOFD(P,Q) ELSE IF DOMAINP P THEN MKSP(MVAR Q,-LDEG Q) .* QUOTOF(P,LCX Q) .+ NIL ELSE (LAMBDA (X,Y); IF CAR X EQ CAR Y THEN (LAMBDA (N,W,Z); IF N=0 THEN RADDF(W,Z) ELSE ((CAR Y TO N) .* W) .+ Z) (CDR X-CDR Y,QUOTOF(LC P,LCX Q),QUOTOF(RED P,Q)) ELSE IF ORDOP(CAR X,CAR Y) THEN (X .* QUOTOF(LC P,Q)) .+ QUOTOF(RED P,Q) ELSE MKSP(CAR Y,- CDR Y) .* QUOTOF(P,LCX Q) .+ NIL) (LPOW P,LPOW Q); SYMBOLIC PROCEDURE QUOTOFD(P,Q); %P is a form, Q a domain element. Value is quotient of P and Q %for output purposes; IF NULL P THEN NIL ELSE IF DOMAINP P THEN QUOTODD(P,Q) ELSE (LPOW P .* QUOTOFD(LC P,Q)) .+ QUOTOFD(RED P,Q); SYMBOLIC PROCEDURE QUOTODD(P,Q); %P and Q are domain elements. Value is domain element for P/Q; IF ATOM P AND ATOM Q THEN MKRN(P,Q) ELSE LOWEST!-TERMS(P,Q); SYMBOLIC PROCEDURE LOWEST!-TERMS(U,V); %reduces compatible domain elements U and V to a ratio in lowest %terms. Value as a rational may contain domain arguments rather than %just integers; IF FLAGP(CAR V,'FIELD) OR FLAGP(CAR U,'FIELD) THEN MULTDM(U,!:EXPT(V,-1)) ELSE BEGIN SCALAR X; X := DCOMBINE(U,V,'GCD); U := DCOMBINE(U,X,'QUOTIENT); V := DCOMBINE(V,X,'QUOTIENT); RETURN IF !:ONEP V THEN U ELSE '!:RN!: . (U . V) END; SYMBOLIC PROCEDURE CKRN U; BEGIN SCALAR X; IF DOMAINP U THEN RETURN U; A: X := GCK2(CKRN CDAR U,X); IF NULL CDR U THEN RETURN IF NONCOMP MVAR U THEN X ELSE LIST(CAAR U . X) ELSE IF DOMAINP CDR U OR NOT CAAAR U EQ CAAADR U THEN RETURN GCK2(CKRN CDR U,X); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE GCK2(U,V); %U and V are domain elements or forms with a zero reductum. %Value is the gcd of U and V; IF NULL V THEN U ELSE IF U=V THEN U ELSE IF DOMAINP U THEN IF DOMAINP V THEN GCDDD(U,V) ELSE GCK2(U,CDARX V) ELSE IF DOMAINP V THEN GCK2(CDARX U,V) ELSE (LAMBDA (X,Y); IF CAR X EQ CAR Y THEN LIST((IF CDR X>CDR Y THEN Y ELSE X) . GCK2(CDARX U,CDARX V)) ELSE IF ORDOP(CAR X,CAR Y) THEN GCK2(CDARX U,V) ELSE GCK2(U,CDARX V)) (CAAR U,CAAR V); SYMBOLIC PROCEDURE CDARX U; CDR CARX U; SYMBOLIC PROCEDURE PREPSQ!* U; BEGIN SCALAR X; IF NULL NUMR U THEN RETURN 0; X := KORD!*; KORD!* := APPEND((FOR EACH J IN FACTORS!* CONC IF NOT IDP J THEN NIL ELSE FOR EACH K IN GET(J,'KLIST) COLLECT CAR K), APPEND(FACTORS!*,ORDL!*)); IF KORD!* NEQ X OR WTL!* THEN U := FORMOP NUMR U . FORMOP DENR U; U := IF !*RAT OR (NOT !*FLOAT AND !*DIV) OR UPL!* OR DNL!* THEN REPLUS PREPSQ!*1(NUMR U,DENR U,NIL) ELSE SQFORM(U,FUNCTION(LAMBDA J; REPLUS PREPSQ!*1(J,1,NIL))); KORD!* := X; RETURN U END; SYMBOLIC PROCEDURE PREPSQ!*0(U,V); %U is a standard quotient, but not necessarily in lowest terms. %V a list of factored powers; %Value is equivalent list of prefix expressions (an implicit sum); BEGIN SCALAR X; RETURN IF NULL NUMR U THEN NIL ELSE IF (X := GCDF(NUMR U,DENR U)) NEQ 1 THEN PREPSQ!*1(QUOTF(NUMR U,X),QUOTF(DENR U,X),V) ELSE PREPSQ!*1(NUMR U,DENR U,V) END; SYMBOLIC PROCEDURE PREPSQ!*1(U,V,W); %U and V are the numerator and denominator expression resp, %in lowest terms. %W is a list of powers to be factored from U; BEGIN SCALAR X,Y,Z; %look for "factors" in the numerator; IF NOT DOMAINP U AND (MVAR U MEMBER FACTORS!* OR (NOT ATOM MVAR U AND CAR MVAR U MEMBER FACTORS!*)) THEN RETURN NCONC(IF V=1 THEN PREPSQ!*0(LC U ./ V,LPOW U . W) ELSE (BEGIN SCALAR N,V1,Z1; %see if the same "factor" appears in denominator; N := LDEG U; V1 := V; Z1 := !*K2F MVAR U; WHILE (Z := QUOTF(V1,Z1)) DO <<V1 := Z; N := N-1>>; RETURN PREPSQ!*0(LC U ./ V1, IF N>0 THEN (MVAR U .** N) . W ELSE IF N<0 THEN MKSP(LIST('EXPT,MVAR U,N),1) . W ELSE W) END), PREPSQ!*0(RED U ./ V,W)); %now see if there are any remaining "factors" in denominator %(KORD!* contains all potential kernel factors); IF NOT DOMAINP V THEN FOR EACH J IN KORD!* DO BEGIN INTEGER N; SCALAR Z1; N := 0; Z1 := !*K2F J; WHILE Z := QUOTF(V,Z1) DO <<N := N-1; V := Z>>; IF N<0 THEN W := MKSP(LIST('EXPT,J,N),1) . W END; %now all "factors" have been removed; IF KERNLP U THEN <<U := MKKL(W,U); W := NIL>>; IF DNL!* THEN <<X := IF NULL !*ALLFAC THEN 1 ELSE CKRN U; Z := CKRN!*(X,DNL!*); X := QUOTOF(X,Z); U := QUOTOF(U,Z); V := QUOTOF(V,Z)>>; Y := CKRN V; IF UPL!* THEN <<Z := CKRN!*(Y,UPL!*); Y := QUOTOF(Y,Z); U := QUOTOF(U,Z); V := QUOTOF(V,Z)>>; IF NULL !*DIV AND NULL !*FLOAT THEN Y := 1; U := CANONSQ (U . QUOTOF(V,Y)); % IF !*GCD THEN U := CANCEL U; U := QUOTOF(NUMR U,Y) ./ DENR U; IF NULL !*ALLFAC THEN X := 1 ELSE X := CKRN NUMR U; IF !*ALLFAC AND X NEQ CAR U THEN GO TO B ELSE IF W THEN <<W := EXCHK(W,NIL,NIL); GO TO C>>; D: U := PREPSQ U; RETURN IF EQCAR(U,'PLUS) THEN CDR U ELSE LIST U; B: IF ONEP X AND NULL W THEN GO TO D ELSE IF !*FLOAT THEN X := QUOTOF(X,KERNLP X); U := QUOTOF(NUMR U,X) . DENR U; W := PREPF MKKL(W,X); IF U = (1 ./ 1) THEN RETURN W ELSE IF EQCAR(W,'TIMES) THEN W := CDR W ELSE W := LIST W; C: RETURN LIST RETIMES ACONC(W,PREPSQ U) END; SYMBOLIC PROCEDURE MKKL(U,V); IF NULL U THEN V ELSE MKKL(CDR U,LIST (CAR U . V)); SYMBOLIC PROCEDURE CKRN!*(U,V); IF NULL U THEN ERRACH 'CKRN!* ELSE IF DOMAINP U THEN 1 ELSE IF CAAAR U MEMBER V THEN LIST (CAAR U . CKRN!*(CDR CARX U,V)) ELSE CKRN!*(CDR CARX U,V); COMMENT Procedures for printing the structure of expressions; FLUID '(COUNTR VAR VARLIS); SYMBOLIC PROCEDURE STRUCTR U; BEGIN SCALAR COUNTR,FVAR,VAR,VARLIS; %VARLIS is a list of elements of form: %(<unreplaced expression> . <newvar> . <replaced exp>); COUNTR :=0; FVAR := VAR := VARNAM!*; IF CDR U THEN FVAR := CADR U; U := SIMPCAR U; U := STRUCTF NUMR U./ STRUCTF DENR U; IF NULL !*FORT THEN MATHPRINT MK!*SQ U; IF COUNTR=0 AND NULL !*FORT THEN RETURN NIL; IF NULL !*FORT THEN <<IF NULL !*NAT THEN TERPRI(); PRIN2T " WHERE">> ELSE VARLIS := REVERSIP VARLIS; FOR EACH X IN VARLIS DO <<TERPRI!* T; IF NULL !*FORT THEN PRIN2!* " "; VARPRI(CDDR X,LIST MKQUOTE CADR X,T)>>; IF !*FORT THEN VARPRI(MK!*SQ U,LIST MKQUOTE FVAR,T) END; RLISTAT '(STRUCTR); SYMBOLIC PROCEDURE STRUCTF U; IF NULL U THEN NIL ELSE IF DOMAINP U THEN U ELSE BEGIN SCALAR X,Y; X := MVAR U; IF SFP X THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y ELSE X := STRUCTK(PREPSQ!*(STRUCTF X ./ 1),GENVAR(),X) ELSE IF NOT ATOM X AND NOT ATOMLIS CDR X THEN IF Y := ASSOC(X,VARLIS) THEN X := CADR Y ELSE X := STRUCTK(X,GENVAR(),X); RETURN X .** LDEG U .* STRUCTF LC U .+ STRUCTF RED U END; SYMBOLIC PROCEDURE STRUCTK(U,ID,V); BEGIN SCALAR X; IF X := SUBCHK1(U,VARLIS,ID) THEN RPLACD(X,(V . ID . U) . CDR X) ELSE IF X := SUBCHK2(U,VARLIS) THEN VARLIS := (V . ID . X) . VARLIS ELSE VARLIS := (V . ID . U) . VARLIS; RETURN ID END; SYMBOLIC PROCEDURE SUBCHK1(U,V,ID); BEGIN SCALAR W; WHILE V DO <<SMEMBER(U,CDDAR V) AND <<W := V; RPLACD(CDAR V,SUBST(ID,U,CDDAR V))>>; V := CDR V>>; RETURN W END; SYMBOLIC PROCEDURE SUBCHK2(U,V); BEGIN SCALAR BOOL; FOR EACH X IN V DO SMEMBER(CDDR X,U) AND <<BOOL := T; U := SUBST(CADR X,CDDR X,U)>>; IF BOOL THEN RETURN U ELSE RETURN NIL END; UNFLUID '(COUNTR VAR VARLIS); %********************************************************************* %********************************************************************* % COEFF OPERATOR PACKAGE %********************************************************************* %********************************************************************; %********************************************************************* % REQUIRES EXTENDED OUTPUT PACKAGE %********************************************************************; FLAG ('(HIPOW!* LOWPOW!*),'SHARE); GLOBAL '(HIPOW!* LOWPOW!*); SYMBOLIC PROCEDURE COEFF(U,V,W); BEGIN SCALAR X,Y,Z; V := !*A2K V; IF ATOM W THEN (IF NOT ARRAYP W THEN (IF NUMBERP(W := REVAL W) THEN TYPERR(W,'ID))) ELSE IF NOT ARRAYP CAR W THEN TYPERR(CAR W,'array) ELSE W := CAR W . FOR EACH X IN CDR W COLLECT IF X EQ 'TIMES THEN X ELSE REVAL X; U := !*Q2F SIMP!* U; X := SETKORDER LIST V; Y := REORDER U; SETKORDER X; IF NULL Y THEN GO TO B0; WHILE NOT DOMAINP Y AND MVAR Y=V DO <<Z := (LDEG Y . MK!*SQ1 CANCEL (LC Y ./ 1)) . Z; Y := RED Y>>; B: IF NULL Y THEN GO TO B1; B0: Z := (0 . MK!*SQ1 CANCEL (Y ./ 1)) . Z; B1: LOWPOW!* := CAAR Z; IF (NOT ATOM W AND ATOM CAR W AND (Y := DIMENSION CAR W)) OR ((Y := DIMENSION W) AND NULL CDR Y) THEN GO TO G; Y := EXPLODE W; W := NIL; C: W := INTERN COMPRESS APPEND(Y,EXPLODE CAAR Z) . W; SETK1(CAR W,CDAR Z,T); IF NULL CDR Z THEN GO TO D; Z := CDR Z; GO TO C; D: HIPOW!* := CAAR Z; LPRIM ACONC(W,"are non zero"); E: RETURN HIPOW!*; G: Z := REVERSE Z; IF ATOM W THEN <<IF CAAR Z NEQ (CAR Y-1) THEN <<Y := LIST(CAAR Z+1); PUT(W,'ARRAY,MKARRAY Y); PUT(W,'DIMENSION,Y)>>; W := LIST(W,'TIMES)>>; HIPOW!* := CAAR Z; Y := PAIR(CDR W,Y); G0: WHILE NOT SMEMQ('TIMES,CAAR Y) DO Y := CDR Y; Y := CDAR Y-REVAL SUBST(0,'TIMES,CAAR Y)-1; %-1 needed since DIMENSION gives length, not highest index; IF CAAR Z>Y THEN REDERR LIST("Index",CAAR Z,"out of range"); H: IF NULL Z OR Y NEQ CAAR Z THEN SETELV(SUBST(Y,'TIMES,W),0) ELSE <<SETELV(SUBST(Y,'TIMES,W),CDAR Z); Z := CDR Z>>; IF Y=0 THEN GO TO E; Y := Y-1; GO TO H END; SYMBOLIC PROCEDURE MK!*SQ1 U; IF WTL!* THEN PREPSQ U ELSE MK!*SQ U; FLAG ('(COEFF),'OPFN); FLAG ('(COEFF),'NOVAL); %********************************************************************* %********************************************************************* % ASYMPTOTIC COMMAND PACKAGE %********************************************************************; %********************************************************************; SYMBOLIC PROCEDURE WEIGHT U; BEGIN SCALAR Y,Z; RMSUBS(); FOR EACH X IN U DO IF NOT EQEXPR X THEN ERRPRI2(X,'HOLD) ELSE <<Y := !*A2K CADR X; Z := REVAL CADDR X; IF NOT (NUMBERP Z AND FIXP Z AND Z>0) THEN TYPERR(Z,"weight"); WTL!* := (Y . Z) . DELASC(Y,WTL!*)>> END; SYMBOLIC PROCEDURE WTLEVEL U; BEGIN INTEGER N; SCALAR X; N := REVAL CAR U; IF NOT(NUMBERP N AND FIXP N AND NOT N<0) THEN ERRPRI2(N,'HOLD); N := N+1; X := ATSOC('K!*,ASYMPLIS!*); IF N=CDR X THEN RETURN NIL ELSE IF N<=CDR X THEN RMSUBS2(); RMSUBS1(); RPLACD(X,N) END; RLISTAT '(WEIGHT WTLEVEL); ALGEBRAIC LET K!***2=0; %********************************************************************* %********************************************************************* % LINEAR OPERATOR PACKAGE %********************************************************************* %********************************************************************; %Global variables referenced in this Section; GLOBAL '(DEPL!*); %list of dependencies among kernels; %********************************************************************* % FUNCTIONS FOR DEFINING AND CHECKING EXPRESSION DEPENDENCY %********************************************************************; SYMBOLIC PROCEDURE DEPEND U; FOR EACH X IN CDR U DO DEPEND1(CAR U,X,T); SYMBOLIC PROCEDURE NODEPEND U; <<RMSUBS(); FOR EACH X IN CDR U DO DEPEND1(CAR U,X,NIL)>>; RLISTAT '(DEPEND NODEPEND); SYMBOLIC PROCEDURE DEPEND1(U,V,BOOL); BEGIN SCALAR Y,Z; U := !*A2K U; V := !*A2K V; IF U EQ V THEN RETURN NIL; Y := ASSOC(U,DEPL!*); IF Y THEN IF BOOL THEN RPLACD(Y,UNION(LIST V,CDR Y)) ELSE IF (Z := DELETE(V,CDR Y)) THEN RPLACD(Y,Z) ELSE DEPL!* := DELETE(Y,DEPL!*) ELSE IF NULL BOOL THEN LPRIM LIST(U,"has no prior dependence on",V) ELSE DEPL!* := LIST(U,V) . DEPL!* END; SYMBOLIC PROCEDURE DEPENDS(U,V); IF NULL U OR NUMBERP U OR NUMBERP V THEN NIL ELSE IF U=V THEN U ELSE IF ATOM U AND U MEMQ FRLIS!* THEN T %to allow the most general pattern matching to occur; ELSE IF (LAMBDA X; X AND LDEPENDS(CDR X,V)) ASSOC(U,DEPL!*) THEN T ELSE IF NOT ATOM U AND (LDEPENDS(CDR U,V) OR DEPENDS(CAR U,V)) THEN T ELSE IF ATOM V THEN NIL ELSE DEPENDSL(U,CDR V); SYMBOLIC PROCEDURE LDEPENDS(U,V); U AND (DEPENDS(CAR U,V) OR LDEPENDS(CDR U,V)); SYMBOLIC PROCEDURE DEPENDSL(U,V); V AND (DEPENDS(U,CAR V) OR DEPENDSL(U,CDR V)); SYMBOLIC PROCEDURE FREEOF(U,V); NOT(SMEMBER(V,U) OR V MEMBER ASSOC(U,DEPL!*)); FLAG('(FREEOF),'BOOLEAN); INFIX FREEOF; PRECEDENCE FREEOF,LESSP; %put it above all boolean operators; %********************************************************************* % FUNCTIONS FOR SIMPLIFYING LINEAR OPERATORS %********************************************************************; SYMBOLIC PROCEDURE LINEAR U; FOR EACH X IN U DO <<IF NOT IDP X THEN TYPERR(X,'operator); FLAG(LIST X,'LINEAR); MKOP X>>; RLISTAT '(LINEAR); PUT('LINEAR,'SIMPFG,'((RMSUBS))); SYMBOLIC PROCEDURE FORMLNR U; (LAMBDA (X,Y,Z); IF Y = 1 THEN U ELSE IF NOT DEPENDS(Y,CAR Z) THEN LIST('TIMES,Y,X . 1 . Z) ELSE IF ATOM Y THEN U ELSE IF CAR Y EQ 'PLUS THEN 'PLUS . FOR EACH J IN CDR Y COLLECT FORMLNR(X . J. Z) ELSE IF CAR Y EQ 'MINUS THEN LIST('MINUS,FORMLNR(X . CADR Y . Z)) ELSE IF CAR Y EQ 'DIFFERENCE THEN LIST('DIFFERENCE,FORMLNR(X . CADR Y . Z), FORMLNR(X . CADDR Y . Z)) ELSE IF CAR Y EQ 'TIMES THEN FORMLNTMS(X,CDR Y,Z,U) ELSE IF CAR Y EQ 'QUOTIENT THEN FORMLNQUOT(X,CDR Y,Z,U) ELSE IF CAR Y EQ 'RECIP AND NOT DEPENDS(CADR Y,CAR Z) THEN LIST('QUOTIENT,X . 1 . Z,CADR Y) ELSE (LAMBDA V; IF V THEN LIST('TIMES,CAR V,X . CDR V . Z) ELSE U) EXPT!-SEPARATE(Y,CAR Z)) (CAR U,CADR U,!*A2K CADDR U . CDDDR U); SYMBOLIC PROCEDURE FORMSEPARATE(U,V); %separates U into two parts, and returns a dotted pair of them: those %which are not commutative and do not depend on V, and the remainder; BEGIN SCALAR W,X,Y; FOR EACH Z IN U DO IF NOT NONCOMP Z AND NOT DEPENDS(Z,V) THEN X := Z . X ELSE IF (W := EXPT!-SEPARATE(Z,V)) THEN <<X := CAR W . X; Y := CDR W . Y>> ELSE Y := Z . Y; RETURN REVERSIP X . REVERSIP Y END; SYMBOLIC PROCEDURE EXPT!-SEPARATE(U,V); %determines if U is an expression in EXPT that can be separated into %two parts, one that does not depend on V and one that does, %except if there is no non-dependent part, NIL is returned; IF NOT EQCAR(U,'EXPT) OR DEPENDS(CADR U,V) OR NOT EQCAR(CADDR U,'PLUS) THEN NIL ELSE EXPT!-SEPARATE1(CDADDR U,CADR U,V); SYMBOLIC PROCEDURE EXPT!-SEPARATE1(U,V,W); BEGIN SCALAR X; X := FORMSEPARATE(U,W); RETURN IF NULL CAR X THEN NIL ELSE LIST('EXPT,V,REPLUS CAR X) . IF NULL CDR X THEN 1 ELSE LIST('EXPT,V,REPLUS CDR X) END; SYMBOLIC PROCEDURE FORMLNTMS(U,V,W,X); %U is a linear operator, V its first argument with TIMES removed, %W the rest of the arguments and X the whole expression. %Value is the transformed expression; BEGIN SCALAR Y; Y := FORMSEPARATE(V,CAR W); RETURN IF NULL CAR Y THEN X ELSE 'TIMES . ACONC(CAR Y, IF NULL CDDR Y THEN FORMLNR(U . CADR Y . W) ELSE U . ('TIMES . CDR Y) . W) END; SYMBOLIC PROCEDURE FORMLNQUOT(FN,QUOTARGS,REST,WHOLE); %FN is a linear operator, QUOTARGS its first argument with QUOTIENT %removed, REST the remaining arguments, WHOLE the whole expression. %Value is the transformed expression; BEGIN SCALAR X; RETURN IF NOT DEPENDS(CADR QUOTARGS,CAR REST) THEN LIST('QUOTIENT,FORMLNR(FN . CAR QUOTARGS . REST), CADR QUOTARGS) ELSE IF NOT DEPENDS(CAR QUOTARGS,CAR REST) AND CAR QUOTARGS NEQ 1 THEN LIST('TIMES,CAR QUOTARGS, FORMLNR(FN . LIST('RECIP,CADR QUOTARGS) . REST)) ELSE IF EQCAR(CAR QUOTARGS,'PLUS) THEN 'PLUS . FOR EACH J IN CDAR QUOTARGS COLLECT FORMLNR(FN . ('QUOTIENT . J . CDR QUOTARGS) . REST) ELSE IF EQCAR(CAR QUOTARGS,'MINUS) THEN LIST('MINUS,FORMLNR(FN . ('QUOTIENT . CADAR QUOTARGS . CDR QUOTARGS) . REST)) ELSE IF EQCAR(CAR QUOTARGS,'TIMES) AND CAR(X := FORMSEPARATE(CDAR QUOTARGS,CAR REST)) THEN 'TIMES . ACONC(CAR X, FORMLNR(FN . LIST('QUOTIENT,MKTIMES CDR X, CADR QUOTARGS) . REST)) ELSE IF EQCAR(CADR QUOTARGS,'TIMES) AND CAR(X := FORMSEPARATE(CDADR QUOTARGS,CAR REST)) THEN LIST('TIMES,LIST('RECIP,MKTIMES CAR X), FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,MKTIMES CDR X) . REST)) ELSE IF X := EXPT!-SEPARATE(CAR QUOTARGS,CAR REST) THEN LIST('TIMES,CAR X,FORMLNR(FN . LIST('QUOTIENT,CDR X,CADR QUOTARGS) . REST)) ELSE IF X := EXPT!-SEPARATE(CADR QUOTARGS,CAR REST) THEN LIST('TIMES,LIST('RECIP,CAR X), FORMLNR(FN . LIST('QUOTIENT,CAR QUOTARGS,CDR X) . REST)) ELSE IF (X := REVAL!* CADR QUOTARGS) NEQ CADR QUOTARGS THEN FORMLNQUOT(FN,LIST(CAR QUOTARGS,X),REST,WHOLE) ELSE WHOLE END; SYMBOLIC PROCEDURE MKTIMES U; IF NULL CDR U THEN CAR U ELSE 'TIMES . U; SYMBOLIC PROCEDURE REVAL!* U; %like REVAL, except INTSTR is always ON; BEGIN SCALAR !*INTSTR; !*INTSTR := T; RETURN REVAL U END; %********************************************************************* % FUNCTIONS FOR ALGEBRAIC MODE OPERATIONS ON POLYNOMIALS %********************************************************************; SYMBOLIC PROCEDURE POLPART(EXPRN,KERN,FN); BEGIN SCALAR X,Y; EXPRN := !*A2F EXPRN; KERN := !*A2K KERN; IF DOMAINP EXPRN THEN RETURN NIL ELSE IF MVAR EXPRN EQ KERN THEN RETURN !*F2A APPLY(FN,LIST EXPRN); X := SETKORDER LIST KERN; EXPRN := REORDER EXPRN; IF NOT(MVAR EXPRN EQ KERN) THEN EXPRN := NIL ELSE EXPRN := APPLY(FN,LIST EXPRN); SETKORDER X; RETURN !*F2A EXPRN END; SYMBOLIC PROCEDURE DEG(U,KERN); POLPART(U,KERN,'CDAAR); SYMBOLIC PROCEDURE LCOF(U,KERN); POLPART(U,KERN,'CDAR); SYMBOLIC PROCEDURE LTERM(U,KERN); POLPART(U,KERN,'!*LTERM); SYMBOLIC PROCEDURE !*LTERM U; LT U .+ NIL; SYMBOLIC PROCEDURE MAINVAR U; IF DOMAINP(U := !*A2F U) THEN NIL ELSE IF SFP(U := MVAR U) THEN PREPF U ELSE U; SYMBOLIC PROCEDURE REDUCT(EXPRN,KERN); BEGIN SCALAR X,Y; EXPRN := !*A2F EXPRN; KERN := !*A2K KERN; IF DOMAINP EXPRN THEN RETURN EXPRN ELSE IF MVAR EXPRN EQ KERN THEN RETURN !*F2A CDR EXPRN; X := SETKORDER LIST KERN; EXPRN := REORDER EXPRN; IF MVAR EXPRN EQ KERN THEN EXPRN := CDR EXPRN; SETKORDER X; RETURN !*F2A EXPRN END; SYMBOLIC OPERATOR DEG,LCOF,LTERM,MAINVAR,REDUCT; %********************************************************************* % SIMPLIFICATION RULES FOR ELEMENTARY FUNCTIONS %********************************************************************; ALGEBRAIC; COMMENT RULE FOR I**2; REMFLAG('(I),'RESERVED); LET I**2= -1; FLAG('(E I NIL PI T),'RESERVED); COMMENT LOGARITHMS; OPERATOR LOG; LET LOG(E)= 1, LOG(1)= 0; FOR ALL X LET LOG(E**X)=X; FOR ALL X LET DF(LOG(X),X) = 1/X; COMMENT TRIGONOMETRICAL FUNCTIONS; SYMBOLIC PROCEDURE SIMPTRIG U; %This is a basic simplification function for trigonometrical %functions. The prefix expression U is of the form (<trig-function> % <argument>). It is assumed that the trig-function is either even %or odd, with even the default (and the odd case a flag "odd"). %The value is a standard quotient for the simplified expression; BEGIN SCALAR BOOL,FN,X,Y,Z; FN := CAR U; U := CDR U; IF NULL U OR CDR U THEN REDERR LIST("Wrong number of arguments to",FN); U := SIMP!* CAR U; IF NULL NUMR U AND FLAGP(FN,'ODD) THEN RETURN NIL ./ 1; X := LIST(FN,PREPSQ!* U); IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z ELSE IF Z := NUMVALCHK X THEN RETURN Z ELSE IF MINUSF NUMR U THEN <<IF FLAGP(FN,'ODD) THEN BOOL := T; X := LIST(FN,PREPSQ!*(NEGF NUMR U ./ DENR U)); IF SUBFG!* AND (Z := OPMTCH X) THEN RETURN SIMP Z>>; X := MKSQ(X,1); RETURN IF BOOL THEN NEGSQ X ELSE X END; DEFLIST('((ACOS SIMPTRIG) (ASIN SIMPTRIG) (ATAN SIMPTRIG) (ACOSH SIMPTRIG) (ASINH SIMPTRIG) (ATANH SIMPTRIG) (COS SIMPTRIG) (SIN SIMPTRIG) (TAN SIMPTRIG) (COT SIMPTRIG)(ACOT SIMPTRIG)(COTH SIMPTRIG)(ACOTH SIMPTRIG) (COSH SIMPTRIG) (SINH SIMPTRIG) (TANH SIMPTRIG) ),'SIMPFN); %The following declaration causes the simplifier to pass the full %expression (including the function) to SIMPTRIG; FLAG ('(ACOS ASIN ATAN ACOSH ASINH ATANH COS SIN TAN COSH SINH TANH COT ACOT COTH ACOTH), 'FULL); FLAG('(ASIN ATAN ASINH ATANH SIN TAN SINH TANH COT ACOT COTH ACOTH), 'ODD); %In the following rules, it is not necessary to let f(0)=0, when f %is odd, since SIMPTRIG already does this; LET COS(0)= 1, COS(PI/2)= 0, SIN(PI/2)= 1, SIN(PI)= 0, COS(PI)=-1, COSH 0=1; FOR ALL X LET COS ACOS X=X, SIN ASIN X=X, TAN ATAN X=X, COSH ACOSH X=X, SINH ASINH X=X, TANH ATANH X=X, COT ACOT X=X, COTH ACOTH X=X; FOR ALL N SUCH THAT NUMBERP N AND FIXP N LET SIN(N*PI)=0, COS(N*PI) = (-1)**N; FOR ALL X LET DF(ACOS(X),X)= -SQRT(1-X**2)/(1-X**2), DF(ASIN(X),X)= SQRT(1-X**2)/(1-X**2), DF(ATAN(X),X)= 1/(1+X**2), DF(ACOSH(X),X)= SQRT(X**2-1)/(X**2-1), DF(ASINH(X),X)= SQRT(X**2+1)/(X**2+1), DF(ATANH(X),X)= 1/(1-X**2), DF(COS X,X)= -SIN(X), DF(SIN(X),X)= COS(X), DF(TAN X,X)=1+TAN X**2, DF(SINH X,X)=COSH X, DF(COSH X,X)=SINH X, DF(TANH X,X)=1-TANH X**2, DF(COT X,X)=-1-COT X**2, DF(COTH X,X)=1-COTH X**2; LET E**(I*PI/2) = I, E**(I*PI) = -1, E**(3*I*PI/2)=-I; %FOR ALL X LET E**LOG X=X; %requires every power to be checked; FOR ALL X,Y LET DF(X**Y,X)= Y*X**(Y-1), DF(X**Y,Y)= LOG X*X**Y; COMMENT SQUARE ROOTS; DEFLIST('((SQRT SIMPSQRT)),'SIMPFN); %FOR ALL X LET SQRT X**2=X; FLUID '(!*!*SQRT); %Used to indicate that SQRTs have been used; SYMBOLIC PROCEDURE MKSQRT U; <<IF NULL !*!*SQRT THEN <<!*!*SQRT := T; ALGEBRAIC FOR ALL X LET SQRT X**2=X>>; LIST('SQRT,U)>>; FOR ALL X LET DF(SQRT X,X)=SQRT X/(2*X); COMMENT ERF,EXP, EXPINT AND DILOG; OPERATOR ERF,EXP,EXPINT,DILOG; LET ERF 0=0; LET DILOG(0)=PI**2/6; FOR ALL X LET ERF(-X)=-ERF X; FOR ALL X LET DF(ERF X,X)=2*SQRT(PI)*E**(-X**2/2)/PI; FOR ALL X LET EXP(X)=E**X; FOR ALL X LET DF(EXPINT(X),X)=E**X/X; FOR ALL X LET DF(DILOG X,X)=-LOG X/(X-1); SYMBOLIC; %********************************************************************* %********************************************************************* % SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************* %********************************************************************; SYMBOLIC PROCEDURE NSSIMP(U,V); %U is a prefix expression involving non-commuting %quantities. Result is an expression of the form % SUM R(I)*PRODUCT M(I,J) where the R(I) are standard %quotients and the M(I,J) non-commuting expressions; %N. B: the products in M(I,J) are returned in reverse order %(to facilitate, e.g., matrix augmentation); BEGIN SCALAR W,X,Y,Z; U := DSIMP(U,V); A: IF NULL U THEN RETURN Z; W := CAR U; C: IF NULL W THEN GO TO D ELSE IF NUMBERP CAR W OR NOT(EQCAR(CAR W,'!*DIV) OR APPLY(V,LIST CAR W)) THEN X := ACONC(X,CAR W) ELSE Y := ACONC(Y,CAR W); W := CDR W; GO TO C; D: IF NULL Y THEN GO TO ER; E: Z := ADDNS(((IF NULL X THEN 1 ./ 1 ELSE SIMPTIMES X) . Y),Z); U := CDR U; X := Y:= NIL; GO TO A; ER: Y := GET(V,'NAME); IF IDP CAR X THEN IF NOT FLAGP(CAR X,GET(Y,'FN)) THEN REDMSG(CAR X,Y) ELSE REDERR LIST(Y,X,"not set") ELSE IF Y EQ 'MATRIX THEN <<Y:= '((MAT (1))); GO TO E>> %to allow a scalar to be a 1 by 1 matrix; ELSE REDERR LIST("Missing",Y,X); PUT(CAR X,Y,Y); Y := LIST CAR X; X := CDR X; GO TO E END; SYMBOLIC PROCEDURE DSIMP(U,V); %result is a list of lists representing a sum of products; %N. B: symbols are in reverse order in product list; IF NUMBERP U THEN LIST LIST U ELSE IF ATOM U THEN (LAMBDA W; (LAMBDA X; IF X AND NOT X EQ W AND SUBFG!* THEN DSIMP(X,V) ELSE IF FLAGP(U,'SHARE) THEN DSIMP(EVAL U,V) ELSE <<FLAG(LIST U,'USED!*); LIST LIST U>>) GET(U,W)) GET(V,'NAME) ELSE IF CAR U EQ 'PLUS THEN FOR EACH J IN CDR U CONC DSIMP(J,V) ELSE IF CAR U EQ 'DIFFERENCE THEN NCONC(DSIMP(CADR U,V), DSIMP('MINUS . CDDR U,V)) ELSE IF CAR U EQ 'MINUS THEN DSIMPTIMES(LIST(-1,CARX CDR U),V) ELSE IF CAR U EQ 'TIMES THEN DSIMPTIMES(CDR U,V) ELSE IF CAR U EQ 'QUOTIENT THEN DSIMPTIMES(LIST(CADR U, LIST('RECIP,CARX CDDR U)),V) ELSE IF NOT APPLY(V,LIST U) THEN LIST LIST U ELSE IF CAR U EQ 'RECIP THEN LIST LIST LIST('!*DIV,CARX CDR U) ELSE IF CAR U EQ 'EXPT THEN (LAMBDA Z; IF NOT NUMBERP Z OR NOT FIXP Z THEN ERRPRI2(U,T) ELSE IF Z<0 THEN LIST LIST LIST('!*DIV,'TIMES . NLIST(CADR U,-Z)) ELSE IF Z=0 THEN LIST LIST LIST('!*DIV,CADR U,1) ELSE DSIMPTIMES(NLIST(CADR U,Z),V)) REVAL CADDR U ELSE IF CAR U EQ 'MAT THEN LIST LIST U ELSE IF ARRAYP CAR U THEN DSIMP(GETELV U,V) ELSE (LAMBDA X; IF X THEN DSIMP(X,V) ELSE (LAMBDA Y; IF Y THEN DSIMP(Y,V) ELSE LIST LIST U) OPMTCH REVOP1 U) OPMTCH U; SYMBOLIC PROCEDURE DSIMPTIMES(U,V); IF NULL U THEN ERRACH 'DSIMPTIMES ELSE IF NULL CDR U THEN DSIMP(CAR U,V) ELSE (LAMBDA J; FOR EACH K IN DSIMPTIMES(CDR U,V) CONC MAPPEND(J,K)) DSIMP(CAR U,V); SYMBOLIC PROCEDURE ADDNS(U,V); IF NULL V THEN LIST U ELSE IF CDR U=CDAR V THEN (LAMBDA X; IF NULL CAR X THEN CDR V ELSE (X . CDR U) . CDR V) ADDSQ(CAR U,CAAR V) ELSE IF ORDP(CDR U,CDAR V) THEN U . V ELSE CAR V . ADDNS(U,CDR V); SYMBOLIC PROCEDURE NSLET(U,V,W,B,FLG); BEGIN IF FLG THEN GO TO A ELSE IF NOT ATOM U THEN IF ARRAYP CAR U THEN GO TO A ELSE TYPERR(U,"array"); REDMSG(U,W); PUT(U,W,W); A: IF NULL B THEN GO TO C ELSE IF NOT ATOM U OR FLAGP(U,'USED!*) THEN RMSUBS(); C: IF NOT ATOM U THEN IF ARRAYP CAR U THEN SETELV(U,IF B THEN V ELSE NIL) ELSE PUT(CAR U,'OPMTCH,XADD!*(CDR U . LIST(NIL . (IF MCOND!* THEN MCOND!* ELSE T),V,NIL), GET(CAR U,'OPMTCH),U,B)) ELSE IF NULL B THEN REMPROP(U,W) ELSE IF W EQ 'MATRIX AND NOT EQCAR(V,'MAT) THEN PUT(U,W,IF MATP V THEN GET(V,'MATRIX) ELSE LIST('MAT,LIST V)) %1 by 1 matrix case; ELSE PUT(U,W,V) END; SYMBOLIC PROCEDURE NSP(U,V); IF NUMBERP U THEN NIL ELSE IF ATOM U THEN GET(U,V) OR (FLAGP(U,'SHARE) AND NSP(EVAL U,V)) ELSE IF CAR U MEMQ '(TIMES QUOTIENT) THEN NSOR(CDR U,V) ELSE IF CAR U MEMQ '(PLUS DIFFERENCE MINUS EXPT RECIP) THEN NSP(CADR U,V) ELSE IF ARRAYP CAR U THEN NSP(GETELX U,V) ELSE FLAGP(CAR U,GET(V,'FN)); SYMBOLIC PROCEDURE GETELX U; %to take care of free variables in LET statements; IF SMEMQLP(FRLIS!*,CDR U) THEN NIL ELSE IF NULL(U := GETELV U) THEN 0 ELSE REVAL U; SYMBOLIC PROCEDURE NSOR(U,V); U AND (NSP(CAR U,V) OR NSOR(CDR U,V)); %********************************************************************* %********************************************************************* % MATRIX PACKAGE %********************************************************************* %********************************************************************; %********************************************************************* % REQUIRES SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************; SYMBOLIC PROCEDURE MATRIX U; %declares list U as matrices; BEGIN SCALAR V,W; INTEGER N; TYPL!* := UNION('(MATP),TYPL!*); A: IF NULL U THEN RETURN NIL ELSE IF ATOM CAR U AND NOT TYPECHK(CAR U,'MATRIX) THEN PUT(CAR U,'MATRIX,'MATRIX) ELSE IF NOT IDP CAAR U OR LENGTH (V := REVLIS CDAR U) NEQ 2 OR NOT NUMLIS V THEN GO TO ER ELSE IF NOT TYPECHK(CAAR U,'MATRIX) THEN GO TO C; B: U := CDR U; GO TO A; C: N := CAR V; D: IF N=0 THEN GO TO E; W := NZERO CADR V . W; N := N-1; GO TO D; E: PUT(CAAR U,'MATRIX,'MAT . W); W := NIL; GO TO B; ER: ERRPRI2(CAR U,'HOLD); GO TO B END; RLISTAT '(MATRIX); SYMBOLIC PROCEDURE NZERO N; %returns a list of N zeros; IF N=0 THEN NIL ELSE 0 . NZERO(N-1); SYMBOLIC PROCEDURE FORMMAT(U,VARS,MODE); 'LIST . MKQUOTE 'MAT . FOR EACH X IN U COLLECT('LIST . FORMLIS(X,VARS,MODE)); PUT('MAT,'FORMFN,'FORMMAT); SYMBOLIC PROCEDURE MATP U; %predicate which tests for matrix expressions; NSP(U,'MATRIX); FLAG('(MAT TP),'MATFLG); PUT('TP,'MSIMPFN,'TP); PUT('MATP,'LETFN,'NSLET); PUT('MATP,'NAME,'MATRIX); PUT('MATRIX,'FN,'MATFLG); PUT('MATP,'EVFN,'MATSM!*); PUT('MATP,'PRIFN,'MATPRI!*); END; |
Added r30/bfloat.fap version [83e0a2433d].
cannot compute difference between binary files
Added r30/bfloat.red version [e6913340a1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 | COMMENT Module for Arbitrary Precision Real Arithmetic; SYMBOLIC; COMMENT *** Tables for Bigfloats ***; GLOBAL '(DOMAINLIST!*); DOMAINLIST!* := UNION('(!:BF!:),DOMAINLIST!*); PUT('BIGFLOAT,'TAG,'!:BF!:); PUT('!:BF!:,'DNAME,'BIGFLOAT); FLAG('(!:BF!:),'FIELD); PUT('!:BF!:,'I2D,'I2BF!:); PUT('!:FT!:,'!:BF!:,'!*FT2BF); PUT('!:RN!:,'!:BF!:,'!*RN2BF); PUT('!:BF!:,'MINUSP,'MINUSP!:); PUT('!:BF!:,'PLUS,'BFPLUS!:); PUT('!:BF!:,'TIMES,'TTIMES!:); PUT('!:BF!:,'DIFFERENCE,'TDIFFERENCE!:); PUT('!:BF!:,'QUOTIENT,'BFQUOTIENT!:); PUT('!:BF!:,'ZEROP,'ZEROP!:); PUT('!:BF!:,'PREPFN,'BFPREP!:); PUT('!:BF!:,'SPECPRN,'BFPRIN); COMMENT SMACROS needed; SYMBOLIC SMACRO PROCEDURE MT!: U; CADR U; SYMBOLIC SMACRO PROCEDURE EP!: U; CDDR U; SYMBOLIC PROCEDURE I2BF!: U; '!:BF!: . U . 0; SYMBOLIC PROCEDURE !*RN2BF U; BEGIN SCALAR X; X := GET('!:BF!:,'I2D); RETURN APPLY(GET('!:BF!:,'QUOTIENT), LIST(APPLY(X,LIST CADR U),APPLY(X,LIST CDDR U))) END; SYMBOLIC PROCEDURE !*FT2BF U; CONV!:A2BF CDR U; GLOBAL '(!:PREC!:); SYMBOLIC PROCEDURE BFPLUS!:(U,V); %value is sum of U and V, or zero (NIL) if outside precision; BEGIN SCALAR X,Y; X := TPLUS!:(U,V); Y := '!:BF!: . ABS MT!: X . (EP!: X+!:PREC!:-1); RETURN IF LESSP!:(Y,ABS!: U) AND LESSP!:(Y,ABS!: V) THEN NIL ELSE X END; SYMBOLIC PROCEDURE BFQUOTIENT!:(U,V); DIVIDE!:(U,V,!:PREC!:); SYMBOLIC PROCEDURE BFPREP!: U; U; SYMBOLIC PROCEDURE BFPRIN NMBR; %prints a big-float in a variety of formats. Still needs work %for fortran output; BEGIN INTEGER J,K; SCALAR U,V,W; NMBR := ROUND!:MT('!:BF!: . NMBR,!:PREC!:-2); IF ZEROP!:(NMBR) THEN RETURN PRIN2!* '!0; U := EXPLODE ABS(J := MT!: NMBR); K := EP!: NMBR; IF K>=0 THEN IF K>5 THEN GO TO ETYPE ELSE <<V := LIST('!.,'!0); WHILE (K := K-1)>=0 DO V := '!0 . V; U := NCONC(U,V)>> ELSE IF (K := ORDER!:(NMBR)+1)>0 THEN <<V := U; WHILE (K := K-1)>0 DO V := CDR V; RPLACD(V,'!. . CDR V)>> ELSE IF K<-10 THEN GO TO ETYPE ELSE <<WHILE (K := K+1)<=0 DO U := '!0 . U; U := '!0 . '!. . U>>; BFPRIN1(U,J); RETURN NMBR; ETYPE: IF NULL( CDR(U)) THEN RPLACD(U , LIST('!0)); U:= CAR U . '!. . CDR U; J := BFPRIN1(U,J); IF J=0 THEN <<PRIN2!*("E " ); J:=2>> ELSE IF J=1 THEN <<PRIN2!*(" E " ); J:=4>> ELSE IF J=2 THEN <<PRIN2!*(" E "); J:=0>> ELSE IF J=3 THEN <<PRIN2!*(" E " ); J:=0>> ELSE IF J=4 THEN <<PRIN2!*(" E "); J:=2>>; U:=EXPLODE( K:=ORDER!:(NMBR)); IF K>=0 THEN U:=CONS('!+,U); WHILE U DO <<PRIN2!*( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2!*(" "); J:=0>> >>; RETURN NMBR END; SYMBOLIC PROCEDURE BFPRIN1(U,J); BEGIN SCALAR V,W; IF J<0 THEN U := '!- . U; %suppress trailing zeros; V := U; WHILE NOT(CAR V EQ '!.) DO V := CDR V; V := CDR V; L: WHILE CDR V AND NOT(CADR V EQ '!0) DO V := CDR V; W := CDR V; WHILE W AND CAR W EQ '!0 DO W := CDR W; IF NULL W THEN RPLACD(V,NIL) ELSE <<V := W; GO TO L>>; %now print the number; J := 0; FOR EACH CHAR IN U DO <<PRIN2!* CHAR; J := J+1; IF J=5 THEN <<IF !*NAT THEN PRIN2!* '! ; J := 0>>>>; RETURN J END; SYMBOLIC PROCEDURE BFLERRMSG U; %Standard error message for BFLOAT module; REDERR LIST("Invalid argument to",U); COMMENT Simp property for !:BF!: since PREP is identity; SYMBOLIC PROCEDURE !:BF!:SIMP U; ('!:BF!: . U) ./ 1; PUT('!:BF!:,'SIMPFN,'!:BF!:SIMP); !:PREC!: := 12; %default value; INITDMODE 'BIGFLOAT; SYMBOLIC PROCEDURE PRECISION N; IF N=0 THEN !:PREC!:-2 ELSE <<!:PREC!: := N+2; N>>; SYMBOLIC OPERATOR PRECISION; COMMENT *** Tables for Elementary Function Numerical Values ***; DEFLIST('((EXP BIGFLOAT) (LOG BIGFLOAT) (SIN BIGFLOAT) (COS BIGFLOAT) (TAN BIGFLOAT) (ASIN BIGFLOAT) (ACOS BIGFLOAT) (ATAN BIGFLOAT) (SQRT BIGFLOAT)), 'TARGETMODE); PUT('EXP,'DOMAINFN,'EXP!*); SYMBOLIC PROCEDURE EXP!* U; EXP!:(U,!:PREC!:); PUT('LOG,'DOMAINFN,'LOG!*); SYMBOLIC PROCEDURE LOG!* U; LOG!:(U,!:PREC!:); PUT('SIN,'DOMAINFN,'SIN!*); SYMBOLIC PROCEDURE SIN!* U; SIN!:(U,!:PREC!:); PUT('COS,'DOMAINFN,'COS!*); SYMBOLIC PROCEDURE COS!* U; COS!:(U,!:PREC!:); PUT('TAN,'DOMAINFN,'TAN!*); SYMBOLIC PROCEDURE TAN!* U; TAN!:(U,!:PREC!:); PUT('ASIN,'DOMAINFN,'ASIN!*); SYMBOLIC PROCEDURE ASIN!* U; ASIN!:(U,!:PREC!:); PUT('ACOS,'DOMAINFN,'ACOS!*); SYMBOLIC PROCEDURE ACOS!* U; ACOS!:(U,!:PREC!:); PUT('ATAN,'DOMAINFN,'ATAN!*); SYMBOLIC PROCEDURE ATAN!* U; ATAN!:(U,!:PREC!:); PUT('SQRT,'DOMAINFN,'SQRT!*); SYMBOLIC PROCEDURE SQRT!* U; SQRT!:(U,!:PREC!:); COMMENT *** Tables for constants with numerical values ***; DEFLIST('((E BIGFLOAT) (PI BIGFLOAT)),'TARGETMODE); PUT('E,'DOMAINFN,'E!*); PUT('PI,'DOMAINFN,'PI!*); SYMBOLIC PROCEDURE PI!*; IF !:PREC!:>1000 THEN !:BIGPI !:PREC!: ELSE !:PI !:PREC!:; SYMBOLIC PROCEDURE E!*; !:E !:PREC!:; %*************************************************************$ %*************************************************************$ %** **$ %** ARBITRARY PRECISION REAL ARITHMETIC SYSTEM **$ %** machine-independent version **$ %** **$ %** made by **$ %** **$ %** Tateaki Sasaki **$ %** **$ %** The University of Utah, March 1979 **$ %** **$ %**=========================================================**$ %** **$ %** For design philosophy and characteristics of this **$ %** system, see T. Sasaki, "An Arbitrary Precision **$ %** Real Arithmetic Package in REDUCE," Proceedings **$ %** of EUROSAM '79, Marseille (France), June 1979. **$ %** **$ %** For implementing and using this system, see T. Sasaki, **$ %** "Manual for Arbitrary Precision Real Arithmetic **$ %** System in REDUCE," Operating Report of Utah Sym- **$ %** bolic Computation Group. **$ %** **$ %**=========================================================**$ %** **$ %** In order to speed up this system, you have only to **$ %** rewrite four routines (DECPREC!:, INCPREC!:, **$ %** PRECI!:, and ROUND!:LAST) machine-dependently. **$ %** **$ %**=========================================================**$ %** **$ %** Table of Contents **$ %** **$ %** 1-1. Initialization. **$ %** 1-2. Constructor, selectors and basic predicate. **$ %** 1-3. Temporary routines for rational number arithmetic. **$ %** 1-4. Counters. **$ %** 1-5. Routines for converting the numeric type. **$ %** 1-6. Routines for converting a big-float number. **$ %** 1-7. Routines for reading/printing numbers. **$ %** 2-1. Arithmetic manipulation routines. **$ %** 2-2. Arithmetic predicates. **$ %** 3-1. Elementary constants. **$ %** 3-2. Routines for saving constants. **$ %** 4-1. Elementary functions. **$ %** 5-1. Appendix: routines for defining infix operators. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-1. Initialization. **$ %** **$ %*************************************************************$ %*************************************************************$ SYMBOLIC$ % Mode ====> SYMBOLIC mode $ GLOBAL '(!:PREC!:)$ % For the global precision $ %!:PREC!: := NIL$ % Default value of !:PREC!:$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-2. CONSTRUCTOR, SELECTORS and basic PREDICATE. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE MAKE!:BF(MT,EP); %****************$ %========================================================$ % This function constructs an internal representation of $ % a number "n" composed of the mantissa MT and the $ % exponent EP with the base 10. The magnitude of $ % the number thus constructed is hence MT*10**EP. $ % **** CAUTION! MT and EP are integers. So, EP denotes $ % **** the order of the last figure in "n", where $ % **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1), $ % **** with the exception ORDER(0)=0. $ % The number "n" is said to be of precision "k" if its $ % mantissa is a k-figure number. $ % MT and EP are any integers (positive or negative). So,$ % you can handle any big or small numbers. In this $ % sense, "BF" denotes a BIG-FLOATING-POINT number. $ % Hereafter, an internal representation of a number $ % constructed by MAKE!:BF is referred to as a $ % BIG-FLOAT representation. $ %========================================================$ CONS('!:BF!: , CONS(MT,EP))$ %*************************************************************$ SYMBOLIC PROCEDURE BFP!:(X); %******************************$ %==============================================$ % This function returns T if X is a BIG-FLOAT $ % representation, else it returns NIL. $ % X is any LISP entity. $ %==============================================$ IF ATOM(X) THEN NIL ELSE IF CAR(X) EQ '!:BF!: THEN T ELSE NIL$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE MT!:(NMBR); %*********************$ %====================================================$ % This function selects the mantissa of a number "n".$ % NMBR is a BIG-FLOAT representation of "n". $ %====================================================$ CADR(NMBR)$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE EP!:(NMBR); %*********************$ %====================================================$ % This function selects the exponent of a number "n".$ % NMBR is a BIG-FLOAT representation of "n". $ %====================================================$ CDDR(NMBR)$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-3. Temporary routines for rational number arithmetic. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE MAKE!:RATNUM(NM,DN); %*******************$ %=====================================================$ % This function constructs an internal representation $ % of a rational number composed of the numerator $ % NM and the denominator DN. $ % NM and DN are any integers (positive or negative). $ % **** Four routines in this section are temporary. $ % **** That is, if your system has own routines $ % **** for rational number arithmetic, you can $ % **** accommodate our system to yours only by $ % **** redefining these four routines. $ %=====================================================$ IF DN=0 THEN REDERR ("ZERO DENOMINATOR IN MAKE!:RATNUM") ELSE IF DN>0 THEN CONS('!:RATNUM!: , CONS( NM, DN)) ELSE CONS('!:RATNUM!: , CONS(-NM,-DN))$ %*************************************************************$ SYMBOLIC PROCEDURE RATNUMP!:(X); %**************************$ %===================================================$ % This function returns T if X is a rational number $ % representation, else it returns NIL. $ % X is any LISP entity. $ %===================================================$ IF ATOM(X) THEN NIL ELSE IF CAR(X) EQ '!:RATNUM!: THEN T ELSE NIL$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE NUMR!:(RNMBR); %******************$ %===================================================$ % This function selects the numerator of a rational $ % number "n". $ % RNMBR is a rational number representation of "n". $ %===================================================$ CADR(RNMBR)$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE DENM!:(RNMBR); %******************$ %=====================================================$ % This function selects the denominator of a rational $ % number "n". $ % RNMBR is a rational number representation of "n". $ %=====================================================$ CDDR(RNMBR)$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-4. COUNTERS. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC SMACRO PROCEDURE PRECI!:(NMBR); %******************$ %====================================================$ % This function counts the precision of a number "n".$ % NMBR is a BIG-FLOAT representation of "n". $ %====================================================$ LENGTH( EXPLODE( ABS( MT!:(NMBR))))$ %*************************************************************$ SYMBOLIC PROCEDURE ORDER!:(NMBR); %*************************$ %================================================$ % This function counts the order of a number "n".$ % NMBR is a BIG-FLOAT representation of "n". $ % **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1) $ % **** when n is not 0, and ORDER(0)=0. $ %================================================$ IF MT!:(NMBR)=0 THEN 0 ELSE PRECI!:(NMBR) + EP!:(NMBR) - 1$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-5. Routines for converting the numeric type. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:A2BF(N); %*************************$ %======================================================$ % This function converts a number N or a number-like $ % entity N to a <BIG-FLOAT>, i.e., a BIG-FLOAT $ % representation of N. $ % N is either an integer, a floating-point number, $ % a string representing a number, a rational $ % number, or a <BIG-FLOAT>. $ % **** This function is the most general conversion $ % **** function to get a BIG-FLOAT representation.$ % **** In this sense, A means an Arbitrary number.$ % **** A rational number is converted to a <BIG-FLOAT> $ % **** of precision !:PREC!: if !:PREC!: is not $ % **** NIL, else the precision is set 50. $ %======================================================$ IF BFP!:(N) THEN N ELSE IF FIXP(N) THEN MAKE!:BF(N,0) ELSE IF FLOATP(N) THEN READ!:NUM(N) ELSE IF STRINGP(N) THEN READ!:NUM(N) ELSE IF RATNUMP!:(N) THEN CONV!:R2BF(N , (IF !:PREC!: THEN !:PREC!: ELSE 50) ) ELSE BFLERRMSG 'CONV!:A2BF$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:F2BF(FNMBR); %*********************$ %================================================$ % This function converts a floating-point number $ % FNMBR to a <BIG-FLOAT>, i.e., a BIG-FLOAT $ % representation. $ % FNMBR is a floating-point number. $ % **** CAUSION!. If you input a number, say, 0.1,$ % **** some systems do not accept it as 0.1 $ % **** but may accept it as 0.09999999. $ % **** In such a case, you had better use $ % **** CONV!:S2BF than to use CONV!:F2BF. $ %================================================$ IF FLOATP(FNMBR) THEN READ!:NUM(FNMBR) ELSE BFLERRMSG 'CONV!:F2BF$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:I2BF(INTGR); %*********************$ %====================================================$ % This function converts an integer INTGR to a <BIG- $ % FLOAT>, i.e., a BIG-FLOAT representation. $ % INTGR is an integer. $ %====================================================$ IF FIXP(INTGR) THEN MAKE!:BF(INTGR,0) ELSE BFLERRMSG 'CONV!:I2BF$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:R2BF(RNMBR,K); %*******************$ %=====================================================$ % This function converts a rational number RNMBR to a $ % <BIG-FLOAT> of precision K, i.e., a BIG-FLOAT $ % representation with a given precision. $ % RNMBR is a rational number representation. $ % K is a positive integer. $ %=====================================================$ IF RATNUMP!:(RNMBR) AND FIXP(K) AND K>0 THEN DIVIDE!:( MAKE!:BF( NUMR!:(RNMBR),0) , MAKE!:BF( DENM!:(RNMBR),0) , K) ELSE BFLERRMSG 'CONV!:R2BF$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:S2BF(STRNG); %*********************$ %==============================================$ % This function converts a string representing $ % a number "n" to a <BIG-FLOAT>, i.e., $ % a BIG-FLOAT representation. $ % STRNG is a string representing "n". "n" may $ % be an integer, a floating-point number $ % of any precision, or a rational number. $ % **** CAUTION! Some systems may set the $ % **** maximum size of string. $ %==============================================$ IF STRINGP(STRNG) THEN READ!:NUM(STRNG) ELSE BFLERRMSG 'CONV!:S2BF$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:BF2F(NMBR); %**********************$ %=========================================================$ % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT $ % representation of "n", to a floating-point number. $ % NMBR is a BIG-FLOAT representation of the number "n". $ %=========================================================$ IF BFP!:(NMBR) THEN TIMES( FLOAT( MT!:(NMBR)) , FLOAT( EXPT(10 , EP!:(NMBR))) ) ELSE BFLERRMSG 'CONV!:BF2F$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:BF2I(NMBR); %**********************$ %=========================================================$ % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT $ % representation of "n", to an integer. The result $ % is the integer part of "n". $ % **** For getting the nearest integer to "n", please use $ % **** the combination MT!:( CONV!:EP(NMBR,0)). $ % NMBR is a BIG-FLOAT representation of the number "n". $ %=========================================================$ IF BFP!:(NMBR) THEN IF EP!:(NMBR:=CUT!:EP(NMBR,0)) = 0 THEN MT!:(NMBR) ELSE MT!:(NMBR)*EXPT(10 , EP!:(NMBR)) ELSE BFLERRMSG 'CONV!:BF2I$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:BF2R(NMBR); %**********************$ %=========================================================$ % This function converts a <BIG-FLOAT>, i.e., a BIG-FLOAT $ % representation of "n", to a rational number. $ % NMBR is a BIG-FLOAT representation of "n". $ % **** The numerator and the denominator of the result $ % **** have no common divisor. $ %=========================================================$ IF BFP!:(NMBR) THEN BEGIN INTEGER NN,ND,M,N,Q; IF (Q:=EP!:(NMBR)) >= 0 THEN <<NN:=MT!:(NMBR)*EXPT(10,Q); ND:=1; M:=1>> ELSE <<NN:=MT!:(NMBR); ND:=EXPT(10,-Q); IF ABS(NN) > ABS(ND) THEN <<M:=NN; N:=ND>> ELSE <<M:=ND; N:=NN>>; WHILE NOT(N=0) DO <<Q:=REMAINDER(M,N); M:=N; N:=Q>> >>; RETURN MAKE!:RATNUM( NN/M , ND/M); END ELSE BFLERRMSG 'CONV!:BF2R$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-6. Routines for converting a BIG-FLOAT number. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE DECPREC!:(NMBR,K); %*********************$ %======================================================$ % This function converts a number "n" to an equivalent $ % number the precision of which is decreased by K.$ % **** CAUTION! No rounding is made. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is a positive integer. $ %======================================================$ MAKE!:BF( MT!:(NMBR)/EXPT(10,K) , EP!:(NMBR)+K)$ %*************************************************************$ SYMBOLIC PROCEDURE INCPREC!:(NMBR,K); %*********************$ %======================================================$ % This function converts a number "n" to an equivalent $ % number the precision of which is increased by K.$ % **** CAUTION! No rounding is made. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is a positive integer. $ %======================================================$ MAKE!:BF( MT!:(NMBR)*EXPT(10,K) , EP!:(NMBR)-K)$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:MT(NMBR,K); %**********************$ %===========================================$ % This function converts a number "n" to an $ % equivalent number of precision K by $ % rounding "n" or adding "0"s to "n". $ % NMBR is a BIG-FLOAT representation of "n".$ % K is a positive integer. $ %===========================================$ IF BFP!:(NMBR) AND FIXP(K) AND K>0 THEN IF (K:=PRECI!:(NMBR)-K) = 0 THEN NMBR ELSE IF K<0 THEN INCPREC!:(NMBR,-K) ELSE ROUND!:LAST( DECPREC!:(NMBR,K-1)) ELSE BFLERRMSG 'CONV!:MT$ %*************************************************************$ SYMBOLIC PROCEDURE CONV!:EP(NMBR,K); %**********************$ %==============================================$ % This function converts a number "n" to an $ % equivalent number having the exponent K $ % by rounding "n" or adding "0"s to "n". $ % NMBR is a BIG-FLOAT representation of "n". $ % K is an integer (positive or negative). $ %==============================================$ IF BFP!:(NMBR) AND FIXP(K) THEN IF (K:=K-EP!:(NMBR)) = 0 THEN NMBR ELSE IF K<0 THEN INCPREC!:(NMBR,-K) ELSE ROUND!:LAST( DECPREC!:(NMBR,K-1)) ELSE BFLERRMSG 'CONV!:EP$ %*************************************************************$ SYMBOLIC PROCEDURE CUT!:MT(NMBR,K); %***********************$ %======================================================$ % This function returns a given number "n" unchanged $ % if its precision is not greater than K, else it $ % cuts off its mantissa at the (K+1)th place and $ % returns an equivalent number of precision K. $ % **** CAUTION! No rounding is made. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is a positive integer. $ %======================================================$ IF BFP!:(NMBR) AND FIXP(K) AND K>0 THEN IF (K:=PRECI!:(NMBR)-K) <= 0 THEN NMBR ELSE DECPREC!:(NMBR,K) ELSE BFLERRMSG 'CUT!:MT$ %*************************************************************$ SYMBOLIC PROCEDURE CUT!:EP(NMBR,K); %***********************$ %======================================================$ % This function returns a given number "n" unchanged $ % if its exponent is not less than K, else it $ % cuts off its mantissa and returns an equivalent $ % number of exponent K. $ % **** CAUTION! No rounding is made. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is an integer (positive or negative). $ %======================================================$ IF BFP!:(NMBR) AND FIXP(K) THEN IF (K:=K-EP!:(NMBR)) <= 0 THEN NMBR ELSE DECPREC!:(NMBR,K) ELSE BFLERRMSG 'CUT!:EP$ %*************************************************************$ SYMBOLIC PROCEDURE MATCH!:(N1,N2); %************************$ %==========================================================$ % This function converts either "n1" or "n2" so that they $ % have the same exponent, which is the smaller of $ % the exponents of "n1" and "n2". $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ % **** CAUTION! Using this function, one of the previous $ % **** expressions of "n1" and "n2" is lost. $ %==========================================================$ IF BFP!:(N1) AND BFP!:(N2) THEN BEGIN INTEGER E1,E2; SCALAR N; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN T; IF E1>E2 THEN <<RPLACA(N1 , CAR(N:=CONV!:EP(N1,E2))); RPLACD(N1 , CDR(N)) >> ELSE <<RPLACA(N2 , CAR(N:=CONV!:EP(N2,E1))); RPLACD(N2 , CDR(N)) >>; RETURN T; END ELSE BFLERRMSG 'MATCH!:$ %*************************************************************$ SYMBOLIC PROCEDURE ROUND!:MT(NMBR,K); %*********************$ %========================================================$ % This function rounds a number "n" at the (K+1)th place $ % and returns an equivalent number of precision K $ % if the precision of "n" is greater than K, else $ % it returns the given number unchanged. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is a positive integer. $ %========================================================$ IF BFP!:(NMBR) AND FIXP(K) AND K>0 THEN IF (K:=PRECI!:(NMBR)-K-1) < 0 THEN NMBR ELSE IF K=0 THEN ROUND!:LAST(NMBR) ELSE ROUND!:LAST( DECPREC!:(NMBR,K)) ELSE BFLERRMSG 'ROUND!:MT$ %*************************************************************$ SYMBOLIC PROCEDURE ROUND!:EP(NMBR,K); %*********************$ %==================================================$ % This function rounds a number "n" and returns an $ % equivalent number having the exponent K if $ % the exponent of "n" is less than K, else $ % it returns the given number unchanged. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is an integer (positive or negative). $ %==================================================$ IF BFP!:(NMBR) AND FIXP(K) THEN IF (K:=K-1-EP!:(NMBR)) < 0 THEN NMBR ELSE IF K=0 THEN ROUND!:LAST(NMBR) ELSE ROUND!:LAST( DECPREC!:(NMBR,K)) ELSE BFLERRMSG 'ROUND!:EP$ %*************************************************************$ SYMBOLIC PROCEDURE ROUND!:LAST(NMBR); %*********************$ %=====================================================$ % This function rounds a number "n" at its last place.$ % NMBR is a BIG-FLOAT representation of "n". $ %=====================================================$ BEGIN SCALAR N; N := DIVIDE(ABS(MT!:(NMBR)),10); IF CDR N<5 THEN N := CAR N ELSE N := CAR N+1; IF MT!:(NMBR) < 0 THEN N := -N; RETURN MAKE!:BF(N , EP!:(NMBR)+1); END$ %*************************************************************$ %*************************************************************$ %** **$ %** 1-7. Routines for reading/printing numbers. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE READ!:LNUM(L); %*************************$ %=======================================================$ % This function reads a long number "n" represented by $ % a list in a way described below, and constructs $ % a BIG-FLOAT representation of "n". $ % **** Using this function, you can input any long $ % **** floating-point numbers without difficulty. $ % L is a list of integers, the first element of which $ % gives the order of "n" and all the next elements $ % when concatenated give the mantissa of "n". $ % **** ORDER(n)=k if 10**k <= ABS(n) < 10**(k+1). $ % **** Except for the first element, all integers in L $ % **** should not begin with "0" because some $ % **** systems suppress leading zeros. $ %=======================================================$ IF MEMBER(NIL , MAPCAR(L,'FIXP)) THEN BFLERRMSG 'READ!:LNUM ELSE BEGIN INTEGER MT,EP,K,SIGN; SCALAR U,V; MT:=0; EP:=CAR( U:=L)+1; IF CADR(L)>0 THEN SIGN:=1 ELSE SIGN:=-1; WHILE U:=CDR(U) DO <<V:=EXPLODE( ABS( CAR(U))); K:=0; WHILE V DO <<K:=K+1; V:=CDR(V) >>; MT:=MT*EXPT(10,K)+ABS( CAR(U)); EP:=EP-K>>; RETURN MAKE!:BF(SIGN*MT,EP); END$ %*************************************************************$ SYMBOLIC PROCEDURE READ!:NUM(N); %**************************$ %========================================================$ % This function reads a number or a number-like entity N $ % and constructs a BIG-FLOAT representation of it. $ % N is an integer, a floating-point number, or a string $ % representing a number. $ % **** If the system does not accept or may incorrectly $ % **** accept the floating-point numbers, you can $ % **** input them as strings such as "1.234E-56", $ % **** "-78.90 D+12" , "+3456 B -78", or "901/234". $ % **** A rational number in a string form is converted $ % **** to a <BIG-FLOAT> of precision !:PREC!: if $ % **** !:PREC!: is not NIL, else the precision of $ % **** the result is set 50. $ % **** Some systems set the maximum size of strings. If $ % **** you want to input long numbers exceeding $ % **** such a maximum size, please use READ!:LNUM. $ %========================================================$ IF FIXP(N) THEN MAKE!:BF(N,0) ELSE IF NOT( NUMBERP(N) OR STRINGP(N)) THEN BFLERRMSG 'READ!:NUM ELSE BEGIN INTEGER J,M,SIGN; SCALAR CH,U,V,L,APPEAR!.,APPEAR!/; J:=M:=0; SIGN:=1; U:=V:=APPEAR!.:=APPEAR!/:=NIL; L:=EXPLODE(N); LOOP: CH:=CAR(L); IF DIGIT(CH) THEN <<U:=CONS(CH,U); J:=J+1>> ELSE IF CH EQ '!. THEN <<APPEAR!.:=T ; J:=0 >> ELSE IF CH EQ '!/ THEN <<APPEAR!/:=T; V:=U; U:=NIL>> ELSE IF CH EQ '!- THEN SIGN:=-1 ELSE IF CH EQ 'E OR CH EQ 'D OR CH EQ 'B OR CH EQ '!e OR CH EQ '!d OR CH EQ '!b THEN GO TO JUMP; ENDL: IF L:=CDR(L) THEN GOTO LOOP ELSE GOTO MAKE; JUMP: WHILE L:=CDR(L) DO <<IF DIGIT( CH:=CAR(L)) OR CH EQ '!- THEN V:=CONS(CH,V) >>; L:=REVERSE(V); IF CAR(L) EQ '!- THEN M:=-COMPRESS( CDR(L)) ELSE M:= COMPRESS(L); MAKE: U:=REVERSE(U); V:=REVERSE(V); IF APPEAR!/ THEN RETURN CONV!:R2BF ( MAKE!:RATNUM( SIGN*COMPRESS(V) , COMPRESS(U)) , (IF !:PREC!: THEN !:PREC!: ELSE 50) ); IF APPEAR!. THEN J:=-J ELSE J:=0; IF SIGN=1 THEN U:=COMPRESS(U) ELSE U:=-COMPRESS(U); RETURN MAKE!:BF(U,J+M); END$ %*************************************************************$ SYMBOLIC PROCEDURE PRINT!:BF(NMBR,TYPE); %******************$ %==========================================================$ % This function prints a number "n" in the print-type TYPE.$ % NMBR is a BIG-FLOAT representation of "n". $ % TYPE is either 'N, 'I, 'E, 'F, 'L, 'R, meaning as: $ % TYPE='N ... the internal representation is printed. $ % TYPE='I ... the integer part is printed. $ % TYPE='E ... <mantissa in form *.***>E<exponent>. $ % TYPE='F ... <integer part>.<decimal part>. $ % TYPE='L ... in a list form readable by READ!:LNUM. $ % TYPE='R ... printed as a rational number. $ % **** The number is printed by being inserted a blank $ % **** after each five characters. Therefore, you $ % **** can not use the printed numbers as input data, $ % **** except when they are printed in type 'L. $ %==========================================================$ IF NOT( TYPE EQ 'N OR TYPE EQ 'I OR TYPE EQ 'E OR TYPE EQ 'F OR TYPE EQ 'L OR TYPE EQ 'R) OR NOT( BFP!:(NMBR)) THEN BFLERRMSG 'PRINT!:BF ELSE BEGIN INTEGER J,K; SCALAR U,V; IF ZEROP!:(NMBR) THEN NMBR:=MAKE!:BF(0,0); IF TYPE EQ 'I THEN GOTO ITYPE ELSE IF TYPE EQ 'E THEN GOTO ETYPE ELSE IF TYPE EQ 'F THEN GOTO FTYPE ELSE IF TYPE EQ 'L THEN GOTO LTYPE ELSE IF TYPE EQ 'R THEN GOTO RTYPE; NTYPE: PRINT(NMBR); RETURN T; ITYPE: U:=EXPLODE( CONV!:BF2I(NMBR)); J:=0; WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; TERPRI(); RETURN T; ETYPE: U:=EXPLODE( ABS( J:=MT!:(NMBR))); IF NULL( CDR(U)) THEN RPLACD(U , LIST(0)); IF J>=0 THEN U:=CONS( CAR(U) , CONS('!. , CDR(U))) ELSE U:=CONS('!- , CONS( CAR(U) , CONS('!.,CDR(U)))); J:=0; WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; IF J=0 THEN <<PRIN2("E " ); J:=2>> ELSE IF J=1 THEN <<PRIN2(" E " ); J:=4>> ELSE IF J=2 THEN <<PRIN2(" E "); J:=0>> ELSE IF J=3 THEN <<PRIN2(" E " ); J:=0>> ELSE IF J=4 THEN <<PRIN2(" E "); J:=2>>; U:=EXPLODE( K:=ORDER!:(NMBR)); IF K>=0 THEN U:=CONS('!+,U); WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; TERPRI(); RETURN T; FTYPE: U:=EXPLODE( ABS( MT!:(NMBR))); IF (J:=EP!:(NMBR)) >= 0 THEN <<V:=NIL; WHILE (J:=J-1)>=0 DO V:=CONS(0,V); U:=NCONC(U,V) >> ELSE IF (J:=ORDER!:(NMBR)+1) > 0 THEN <<V:=U; WHILE (J:=J-1)>0 DO V:=CDR(V); RPLACD(V , CONS('!.,CDR(V))) >> ELSE <<WHILE (J:=J+1)<=0 DO U:=CONS(0,U); U:=CONS(0 , CONS('!.,U)) >>; IF MT!:(NMBR) < 0 THEN U:=CONS('!-,U); J:=0; WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; TERPRI(); RETURN T; LTYPE: PRIN2(" '("); PRIN2( ORDER!:(NMBR)); PRIN2(" "); U:=EXPLODE( MT!:(NMBR)); J:=0; WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J>=5 AND U AND NOT( CAR(U) EQ '!0) THEN <<PRIN2(" "); J:=J-5>> >>; PRIN2(")"); TERPRI(); RETURN T; RTYPE: PRINT!:RATNUM( CONV!:BF2R(NMBR)); RETURN T; END$ %*************************************************************$ SYMBOLIC PROCEDURE PRINT!:RATNUM(RNMBR); %******************$ %======================================================$ % This function prints a rational number "n". $ % RNMBR is a rational number representation of "n". $ % **** The number is printed by being inserted a blank $ % **** after each five characters. So, you can $ % **** not use the printed numbers as input data. $ %======================================================$ IF NOT( RATNUMP!:(RNMBR)) THEN BFLERRMSG 'PRINT!:RATNUM ELSE BEGIN INTEGER J; SCALAR U,V; U:=NUMR!:(RNMBR); V:=DENM!:(RNMBR); IF V<0 THEN <<U:=-U; V:=-V>>; J:=0; U:=EXPLODE(U); WHILE U DO <<PRIN2( CAR(U)); U:=CDR(U); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; IF J=0 THEN <<PRIN2("/ " ); J:=2>> ELSE IF J=1 THEN <<PRIN2(" / " ); J:=4>> ELSE IF J=2 THEN <<PRIN2(" / "); J:=0>> ELSE IF J=3 THEN <<PRIN2(" / " ); J:=0>> ELSE IF J=4 THEN <<PRIN2(" / "); J:=2>>; V:=EXPLODE(V); WHILE V DO <<PRIN2( CAR(V)); V:=CDR(V); J:=J+1; IF J=5 THEN <<PRIN2(" "); J:=0>> >>; TERPRI(); RETURN T; END$ %*************************************************************$ %*************************************************************$ %** **$ %** 2-1. Arithmetic manipulation routines. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE ABS!:(NMBR); %***************************$ %===============================================$ % This function makes the absolute value of "n".$ % N is a BIG-FLOAT representation of "n". $ %===============================================$ IF MT!:(NMBR) > 0 THEN NMBR ELSE MAKE!:BF( -MT!:(NMBR) , EP!:(NMBR))$ %*************************************************************$ SYMBOLIC PROCEDURE MINUS!:(NMBR); %*************************$ %=============================================$ % This function makes the minus number of "n".$ % N is a BIG-FLOAT representation of "n". $ %=============================================$ MAKE!:BF( -MT!:(NMBR) , EP!:(NMBR))$ %*************************************************************$ SYMBOLIC PROCEDURE PLUS!:(N1,N2); %*************************$ %==========================================================$ % This function calculates the sum of "n1" and "n2". $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ BEGIN INTEGER E1,E2; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN MAKE!:BF( MT!:(N1)+MT!:(N2) , E1) ELSE IF E1>E2 THEN RETURN MAKE!:BF ( MT!:( INCPREC!:(N1,E1-E2))+MT!:(N2) , E2) ELSE RETURN MAKE!:BF ( MT!:(N1)+MT!:( INCPREC!:(N2,E2-E1)) , E1); END$ %*************************************************************$ SYMBOLIC PROCEDURE DIFFERENCE!:(N1,N2); %*******************$ %==========================================================$ % This function calculates the difference of "n1" and "n2".$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ BEGIN INTEGER E1,E2; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN MAKE!:BF( MT!:(N1)-MT!:(N2) , E1) ELSE IF E1>E2 THEN RETURN MAKE!:BF ( MT!:( INCPREC!:(N1,E1-E2))-MT!:(N2) , E2) ELSE RETURN MAKE!:BF ( MT!:(N1)-MT!:( INCPREC!:(N2,E2-E1)) , E1); END$ %*************************************************************$ SYMBOLIC PROCEDURE TIMES!:(N1,N2); %************************$ %==========================================================$ % This function calculates the product of "n1" and "n2". $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ MAKE!:BF( MT!:(N1)*MT!:(N2) , EP!:(N1)+EP!:(N2))$ %*************************************************************$ SYMBOLIC PROCEDURE DIVIDE!:(N1,N2,K); %*********************$ %==========================================================$ % This function calculates the quotient of "n1" and "n2", $ % with the precision K, by rounding the ratio of "n1" $ % and "n2" at the (K+1)th place. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ % K is any positive integer. $ %==========================================================$ BEGIN N1:=CONV!:MT(N1 , K+PRECI!:(N2)+1); N1:=MAKE!:BF( MT!:(N1)/MT!:(N2) , EP!:(N1)-EP!:(N2)); RETURN ROUND!:MT(N1,K); END$ %*************************************************************$ SYMBOLIC PROCEDURE EXPT!:(NMBR,K); %************************$ %===============================================$ % This function calculates the Kth power of "n".$ % The result will become a long number if $ % ABS(K) >> 1. $ % NMBR is a BIG-FLOAT representation of "n". $ % K is an integer (positive or negative). $ % **** For calculating a power X**K, with non- $ % **** integer K, please use TEXPT!:ANY. $ %===============================================$ IF K>=0 THEN MAKE!:BF( EXPT( MT!:(NMBR) , K) , EP!:(NMBR)*K) ELSE DIVIDE!:( MAKE!:BF(1,0) , EXPT!:(NMBR,-K) , -PRECI!:(NMBR)*K)$ %*************************************************************$ SYMBOLIC PROCEDURE TPLUS!:(N1,N2); %************************$ %==========================================================$ % This function calculates the sum of "n1" and "n2" $ % up to a precision specified by !:PREC!: or N1 or N2.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2",$ % otherwise they are converted to <BIG-FLOAT>'s. $ %==========================================================$ IF BFP!:( N1:=CONV!:A2BF(N1)) AND BFP!:( N2:=CONV!:A2BF(N2)) THEN ROUND!:MT ( PLUS!:(N1,N2) , (IF !:PREC!: THEN !:PREC!: ELSE MAX( PRECI!:(N1) , PRECI!:(N2))) ) ELSE BFLERRMSG 'TPLUS!:$ %*************************************************************$ SYMBOLIC PROCEDURE TDIFFERENCE!:(N1,N2); %******************$ %==========================================================$ % This function calculates the difference of "n1" and "n2" $ % up to a precision specified by !:PREC!: or N1 or N2.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2",$ % otherwise they are converted to <BIG-FLOAT>'s. $ %==========================================================$ IF BFP!:( N1:=CONV!:A2BF(N1)) AND BFP!:( N2:=CONV!:A2BF(N2)) THEN ROUND!:MT ( DIFFERENCE!:(N1,N2) , (IF !:PREC!: THEN !:PREC!: ELSE MAX( PRECI!:(N1) , PRECI!:(N2))) ) ELSE BFLERRMSG 'TDIFFERENCE!:$ %*************************************************************$ SYMBOLIC PROCEDURE TTIMES!:(N1,N2); %***********************$ %==========================================================$ % This function calculates the product of "n1" and "n2" $ % up to a precision specified by !:PREC!: or N1 or N2.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2",$ % otherwise they are converted to <BIG-FLOAT>'s. $ %==========================================================$ IF BFP!:( N1:=CONV!:A2BF(N1)) AND BFP!:( N2:=CONV!:A2BF(N2)) THEN ROUND!:MT ( TIMES!:(N1,N2) , (IF !:PREC!: THEN !:PREC!: ELSE MAX( PRECI!:(N1) , PRECI!:(N2))) ) ELSE BFLERRMSG 'TTIMES!:$ %*************************************************************$ SYMBOLIC PROCEDURE TDIVIDE!:(N1,N2); %**********************$ %==========================================================$ % This function calculates the quotient of "n1" and "n2" $ % up to a precision specified by !:PREC!: or N1 or N2.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2",$ % otherwise they are converted to <BIG-FLOAT>'s. $ %==========================================================$ IF BFP!:( N1:=CONV!:A2BF(N1)) AND BFP!:( N2:=CONV!:A2BF(N2)) THEN DIVIDE!:(N1 , N2 , (IF !:PREC!: THEN !:PREC!: ELSE MAX( PRECI!:(N1) , PRECI!:(N2))) ) ELSE BFLERRMSG 'TDIVIDE!:$ %*************************************************************$ SYMBOLIC PROCEDURE TEXPT!:(NMBR,K); %***********************$ %=====================================================$ % This function calculates the Kth power of "n" up to $ % the precision specified by !:PREC!: or NMBR. $ % NMBR is a BIG-FLOAT representation of "n", $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is an integer (positive or negative). $ % **** For calculating a power X**K, where K is not $ % **** an integer, please use TEXPT!:ANY. $ %=====================================================$ IF BFP!:( NMBR:=CONV!:A2BF(NMBR)) AND FIXP(K) THEN IF K=0 THEN MAKE!:BF(1,0) ELSE IF K=1 THEN NMBR ELSE IF K<0 THEN TDIVIDE!:( MAKE!:BF(1,0) , TEXPT!:(NMBR,-K) ) ELSE TEXPT!:CAL(NMBR , K , (IF !:PREC!: THEN !:PREC!: ELSE PRECI!:(NMBR)) ) ELSE BFLERRMSG 'TEXPT!:$ SYMBOLIC PROCEDURE TEXPT!:CAL(NMBR,K,PREC); IF K=1 THEN NMBR ELSE BEGIN INTEGER K2; SCALAR U; U:=ROUND!:MT( TIMES!:(NMBR,NMBR) , PREC); IF K=2 THEN RETURN U ELSE IF (K-2*(K2:=K/2)) = 0 THEN RETURN TEXPT!:CAL(U,K2,PREC) ELSE RETURN ROUND!:MT ( TIMES!:(NMBR , TEXPT!:CAL(U,K2,PREC)) , PREC); END$ %*************************************************************$ SYMBOLIC PROCEDURE QUOTIENT!:(N1,N2); %*********************$ %==========================================================$ % This function calculates the integer quotient of "n1" $ % and "n2", just as the "QUOTIENT" for integers does. $ % **** For calculating the quotient up to a necessary $ % **** precision, please use DIVIDE!:. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ BEGIN INTEGER E1,E2; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN MAKE!:BF( MT!:(N1)/MT!:(N2) , 0) ELSE IF E1>E2 THEN RETURN QUOTIENT!:( INCPREC!:(N1,E1-E2) , N2) ELSE RETURN QUOTIENT!:( N1 , INCPREC!:(N2,E2-E1)); END$ %*************************************************************$ SYMBOLIC PROCEDURE REMAINDER!:(N1,N2); %********************$ %==========================================================$ % This function calculates the remainder of "n1" and "n2", $ % just as the "REMAINDER" for integers does. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ BEGIN INTEGER E1,E2; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN MAKE!:BF( REMAINDER( MT!:(N1) , MT!:(N2)) , E2) ELSE IF E1>E2 THEN RETURN REMAINDER!:( INCPREC!:(N1,E1-E2) , N2) ELSE RETURN REMAINDER!:( N1 , INCPREC!:(N2,E2-E1)); END$ %*************************************************************$ SYMBOLIC PROCEDURE TEXPT!:ANY(X,Y); %***********************$ %====================================================$ % This function calculates the power x**y, where "x" $ % and "y" are any numbers. The precision of $ % the result is specified by !:PREC!: or X or Y.$ % **** For a negative "x", this function returns $ % **** -(-x)**y unless "y" is an integer. $ % X is a BIG-FLOAT representation of "x", otherwise $ % it is converted to a <BIG-FLOAT>. $ % Y is either an integer, a floating-point number, $ % or a BIG-FLOAT number, i.e., a BIG-FLOAT $ % representation of "y". $ %====================================================$ IF FIXP(Y) THEN TEXPT!:(X,Y) ELSE IF INTEGERP!:(Y) THEN TEXPT!:(X , CONV!:BF2I(Y)) ELSE IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( BFP!:( Y:=CONV!:A2BF(Y))) THEN BFLERRMSG 'TEXPT!:ANY ELSE IF MINUSP!:(Y) THEN TDIVIDE!:( MAKE!:BF(1,0) , TEXPT!:ANY(X , MINUS!:(Y)) ) ELSE BEGIN INTEGER N; SCALAR XP,YP; N:=(IF !:PREC!: THEN !:PREC!: ELSE MAX( PRECI!:(X) , PRECI!:(Y)) ); IF MINUSP!:(X) THEN XP:=MINUS!:(X) ELSE XP:=X; IF INTEGERP!:( TIMES!:(Y , CONV!:I2BF(2))) THEN <<XP:=INCPREC!:(XP,1); YP:=TEXPT!:(XP , CONV!:BF2I(Y)); YP:=TIMES!:(YP , SQRT!:(XP,N+1)); YP:=ROUND!:MT(YP,N) >> ELSE <<YP:=TTIMES!:(Y , LOG!:(XP,N+1)); YP:=EXP!:(YP,N) >>; RETURN (IF MINUSP!:(X) THEN MINUS!:(YP) ELSE YP); END$ %*************************************************************$ SYMBOLIC PROCEDURE MAX!:(N1,N2); %**************************$ %==========================================================$ % This function returns the larger of "n1" and "n2". $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ IF GREATERP!:(N2,N1) THEN N2 ELSE N1$ %*************************************************************$ SYMBOLIC PROCEDURE MIN!:(N1,N2); %**************************$ %==========================================================$ % This function returns the smaller of "n1" and "n2". $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ IF LESSP!:(N2,N1) THEN N2 ELSE N1$ %*************************************************************$ %*************************************************************$ %** **$ %** 2-2. Arithmetic predicates. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE GREATERP!:(N1,N2); %*********************$ %==========================================================$ % This function returns T if "n1" > "n2" else returns NIL. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ BEGIN INTEGER E1,E2; IF (E1:=EP!:(N1)) = (E2:=EP!:(N2)) THEN RETURN (IF MT!:(N1) > MT!:(N2) THEN T ELSE NIL) ELSE IF E1>E2 THEN IF MT!:( INCPREC!:(N1,E1-E2)) > MT!:(N2) THEN RETURN T ELSE RETURN NIL ELSE IF MT!:(N1) > MT!:( INCPREC!:(N2,E2-E1)) THEN RETURN T ELSE RETURN NIL; END$ %*************************************************************$ SYMBOLIC PROCEDURE GEQ!:(N1,N2); %**************************$ %==========================================================$ % This function returns T if "n1" >= "n2" else returns NIL.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ NOT( LESSP!:(N1,N2))$ %*************************************************************$ SYMBOLIC PROCEDURE EQUAL!:(N1,N2); %************************$ %==========================================================$ % This function returns T if "n1" = "n2" else returns NIL. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ IF ZEROP!:( DIFFERENCE!:(N1,N2)) THEN T ELSE NIL$ %*************************************************************$ SYMBOLIC PROCEDURE LESSP!:(N1,N2); %************************$ %==========================================================$ % This function returns T if "n1" < "n2" else returns NIL. $ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ GREATERP!:(N2,N1)$ %*************************************************************$ SYMBOLIC PROCEDURE LEQ!:(N1,N2); %**************************$ %==========================================================$ % This function returns T if "n1" <= "n2" else returns NIL.$ % N1 and N2 are BIG-FLOAT representations of "n1" and "n2".$ %==========================================================$ NOT( GREATERP!:(N1,N2))$ %*************************************************************$ SYMBOLIC PROCEDURE INTEGERP!:(X); %*************************$ %===================================================$ % This function returns T if X is a BIG-FLOAT $ % representing an integer, else it returns NIL.$ % X is any LISP entity. $ %===================================================$ IF BFP!:(X) THEN IF EP!:(X)>=0 OR EQUAL!:(X , CONV!:I2BF( CONV!:BF2I(X))) THEN T ELSE NIL ELSE NIL$ %*************************************************************$ SYMBOLIC PROCEDURE MINUSP!:(X); %***************************$ %===================================================$ % This function returns T if "x"<0 else returns NIL.$ % X is any LISP entity. $ %===================================================$ IF BFP!:(X) AND MT!:(X) < 0 THEN T ELSE NIL$ %*************************************************************$ SYMBOLIC PROCEDURE ZEROP!:(X); %****************************$ %===================================================$ % This function returns T if "x"=0 else returns NIL.$ % X is any LISP entity. $ %===================================================$ IF BFP!:(X) AND MT!:(X) = 0 THEN T ELSE NIL$ %*************************************************************$ %*************************************************************$ %** **$ %** 3-1. Elementary CONSTANTS. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE !:PI(K); %*******************************$ %====================================================$ % This function calculates the value of the circular $ % constant "PI", with the precision K, by $ % using Machin's well known identity: $ % PI = 16*atan(1/5) - 4*atan(1/239). $ % Calculation is performed mainly on integers. $ % K is a positive integer. $ %====================================================$ IF NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG '!:PI ELSE IF K<=20 THEN ROUND!:MT ( MAKE!:BF( 314159265358979323846 , -20) , K) ELSE BEGIN INTEGER K3,S,SS,M,N,X; SCALAR U; U:=GET!:CONST( '!:PI , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; SS:=N:=EXPT(10 , K3:=K+3)/5; X :=-5**2; M:=1; WHILE NOT(N=0) DO <<N:=N/X; SS:=SS+N/( M:=M+2) >>; S:=N:=EXPT(10,K3)/239; X:=-239**2; M:=1; WHILE NOT(N=0) DO <<N:=N/X; S:=S+N/( M:=M+2) >>; ANS: U:=ROUND!:MT( MAKE!:BF( 16*SS-4*S , -K3) , K); SAVE!:CONST( '!:PI , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:BIGPI(K); %****************************$ %====================================================$ % This function calculates the value of the circular $ % constant "PI", with the precision K, by the $ % arithmetic-geometric mean method. (See, $ % R. Brent, JACM Vol.23, #2, pp.242-251(1976).) $ % K is a positive integer. $ % **** This function should be used only when you $ % **** need "PI" of precision higher than 1000. $ %====================================================$ IF NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG '!:BIGPI ELSE BEGIN INTEGER K2,N; SCALAR DCUT,HALF,X,Y,U,V; U:=GET!:CONST( '!:PI , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; K2 :=K+2; HALF:=CONV!:S2BF("0.5"); DCUT:=MAKE!:BF(10,-K2); X:=CONV!:I2BF( N:=1); Y:=DIVIDE!:(X , !:SQRT2(K2) , K2); U:=CONV!:S2BF("0.25"); WHILE GREATERP!:( ABS!:(DIFFERENCE!:(X,Y)) , DCUT) DO <<V:=X; X:=TIMES!:( PLUS!:(X,Y) , HALF); Y:=SQRT!:( CUT!:EP( TIMES!:(Y,V) , -K2) , K2); V:=DIFFERENCE!:(X,V); V:=TIMES!:( TIMES!:(V,V) , CONV!:I2BF(N)); U:=DIFFERENCE!:(U , CUT!:EP(V,-K2)); N:=2*N>>; V:=CUT!:MT( EXPT!:( PLUS!:(X,Y) , 2) , K2); U:=DIVIDE!:(V , TIMES!:( CONV!:I2BF(4) , U) , K); SAVE!:CONST( '!:PI , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:E(K); %********************************$ %=====================================================$ % This function calculates the value of "e", the base $ % of the natural logarithm, with the precision K,$ % by summing the Taylor series for exp(x=1). $ % Calculation is performed mainly on integers. $ % K is a positive integer. $ %=====================================================$ IF NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG '!:E ELSE IF K<=20 THEN ROUND!:MT ( MAKE!:BF( 271828182845904523536 , -20) , K) ELSE BEGIN INTEGER K2,ANS,M,N; SCALAR U; U:=GET!:CONST( '!:E , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; K2:=K+2; M :=1; N :=EXPT(10,K2); ANS:=0; WHILE NOT(N=0) DO ANS:=ANS+( N:=N/( M:=M+1)); ANS:=ANS+2*EXPT(10,K2); U:=ROUND!:MT( MAKE!:BF(ANS,-K2) , K); SAVE!:CONST( '!:E , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:E01(K); %******************************$ %=====================================================$ % This function calculates exp(0.1), the value of the $ % exponential function at the point 0.1, with $ % the precision K. $ % K is a positive integer. $ %=====================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:E01 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=EXP!:( CONV!:S2BF("0.1") , K); SAVE!:CONST( '!:E01 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:LOG2(K); %*****************************$ %==============================================$ % This function calculates log(2), the natural $ % logarithm of 2, with the precision K. $ % K is a positive integer. $ %==============================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:LOG2 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=LOG!:( CONV!:I2BF(2) , K); SAVE!:CONST( '!:LOG2 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:LOG3(K); %*****************************$ %==============================================$ % This function calculates log(3), the natural $ % logarithm of 3, with the precision K. $ % K is a positive integer. $ %==============================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:LOG3 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=LOG!:( CONV!:I2BF(3) , K); SAVE!:CONST( '!:LOG3 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:LOG5(K); %*****************************$ %==============================================$ % This function calculates log(5), the natural $ % logarithm of 5, with the precision K. $ % K is a positive integer. $ %==============================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:LOG5 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=LOG!:( CONV!:I2BF(5) , K); SAVE!:CONST( '!:LOG5 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:LOG10(K); %****************************$ %===============================================$ % This function calculates log(10), the natural $ % logarithm of 10, with the precision K. $ % K is a positive integer. $ %===============================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:LOG10 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=LOG!:( CONV!:I2BF(10) , K); SAVE!:CONST( '!:LOG10 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:LOGPI(K); %****************************$ %===============================================$ % This function calculates log(PI), the natural $ % logarithm of "PI", with the precision K. $ % K is a positive integer. $ %===============================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:LOGPI , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=LOG!:( !:PI(K+2) , K); SAVE!:CONST( '!:LOGPI , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRT2(K); %****************************$ %===================================================$ % This function calculates SQRT(2), the square root $ % of 2, with the precision K. $ % K is a positive integer. $ %===================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRT2 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( CONV!:I2BF(2) , K); SAVE!:CONST( '!:SQRT2 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRT3(K); %****************************$ %===================================================$ % This function calculates SQRT(3), the square root $ % of 3, with the precision K. $ % K is a positive integer. $ %===================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRT3 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( CONV!:I2BF(3) , K); SAVE!:CONST( '!:SQRT3 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRT5(K); %****************************$ %===================================================$ % This function calculates SQRT(5), the square root $ % of 5, with the precision K. $ % K is a positive integer. $ %===================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRT5 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( CONV!:I2BF(5) , K); SAVE!:CONST( '!:SQRT5 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRT10(K); %***************************$ %====================================================$ % This function calculates SQRT(10), the square root $ % of 10, with the precision K. $ % K is a positive integer. $ %====================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRT10 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( CONV!:I2BF(10) , K); SAVE!:CONST( '!:SQRT10 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRTPI(K); %***************************$ %====================================================$ % This function calculates SQRT(PI), the square root $ % of "PI", with the precision K. $ % K is a positive integer. $ %====================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRTPI , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( !:PI(K+2) , K); SAVE!:CONST( '!:SQRTPI , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:SQRTE(K); %****************************$ %===================================================$ % This function calculates SQRT(e), the square root $ % of "e", with the precision K. $ % K is a positive integer. $ %===================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:SQRTE , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=SQRT!:( !:E(K+2) , K); SAVE!:CONST( '!:SQRTE , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRT2(K); %****************************$ %=================================================$ % This function calculates CBRT(2), the cube root $ % of 2, with the precision K. $ % K is a positive integer. $ %=================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRT2 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( CONV!:I2BF(2) , K); SAVE!:CONST( '!:CBRT2 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRT3(K); %****************************$ %=================================================$ % This function calculates CBRT(3), the cube root $ % of 3, with the precision K. $ % K is a positive integer. $ %=================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRT3 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( CONV!:I2BF(3) , K); SAVE!:CONST( '!:CBRT3 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRT5(K); %****************************$ %=================================================$ % This function calculates CBRT(5), the cube root $ % of 5, with the precision K. $ % K is a positive integer. $ %=================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRT5 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( CONV!:I2BF(5) , K); SAVE!:CONST( '!:CBRT5 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRT10(K); %***************************$ %==================================================$ % This function calculates CBRT(10), the cube root $ % of 10, with the precision K. $ % K is a positive integer. $ %==================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRT10 , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( CONV!:I2BF(10) , K); SAVE!:CONST( '!:CBRT10 , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRTPI(K); %***************************$ %==================================================$ % This function calculates CBRT(PI), the cube root $ % of "PI", with the precision K. $ % K is a positive integer. $ %==================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRTPI , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( !:PI(K+2) , K); SAVE!:CONST( '!:CBRTPI , U); RETURN U; END$ %*************************************************************$ SYMBOLIC PROCEDURE !:CBRTE(K); %****************************$ %=================================================$ % This function calculates CBRT(e), the cube root $ % of "e", with the precision K. $ % K is a positive integer. $ %=================================================$ BEGIN SCALAR U; U:=GET!:CONST( '!:CBRTE , K); IF U = "NOT FOUND" THEN NIL ELSE RETURN U; U:=CBRT!:( !:E(K+2) , K); SAVE!:CONST( '!:CBRTE , U); RETURN U; END$ %*************************************************************$ %*************************************************************$ %** **$ %** 3-2. Routines for saving CONSTANTS. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE GET!:CONST(CNST,K); %********************$ %==================================================$ % This function returns the value of constant CNST $ % of the precision K, if it was calculated $ % previously with, at least, the precision K, $ % else it returns "NOT FOUND". $ % CNST is the name of the constant (to be quoted). $ % K is a positive integer. $ %==================================================$ IF ATOM(CNST) AND FIXP(K) AND K>0 THEN BEGIN SCALAR U; U:=GET(CNST , 'SAVE!:C); IF NULL(U) OR CAR(U)<K THEN RETURN "NOT FOUND" ELSE IF CAR(U)=K THEN RETURN CDR(U) ELSE RETURN ROUND!:MT(CDR(U),K); END ELSE BFLERRMSG 'GET!:CONST$ %*************************************************************$ SYMBOLIC PROCEDURE SAVE!:CONST(CNST,NMBR); %****************$ %=================================================$ % This function saves the value of constant CNST $ % for the later use. $ % CNST is the name of the constant (to be quoted).$ % NMBR is a BIG-FLOAT representation of the value.$ %=================================================$ IF ATOM(CNST) AND BFP!:(NMBR) THEN PUT(CNST , 'SAVE!:C , CONS( PRECI!:(NMBR) , NMBR)) ELSE BFLERRMSG 'SAVE!:CONST$ %*************************************************************$ SYMBOLIC PROCEDURE SET!:CONST(CNST,L); %********************$ %=================================================$ % This function sets the value of constant CNST. $ % CNST is the name of the constant (to be quoted).$ % L is a list of integers, which represents the $ % value of the constant in the way described $ % in the function READ!:LNUM. $ %=================================================$ SAVE!:CONST(CNST , READ!:LNUM(L))$ %*************************************************************$ SYMBOLIC$ %SETTING THE CONSTANTS ***************************$ SET!:CONST( '!:PI , '( 0 3141 59265 35897 93238 46264 33832 79502 88419 71693 99375 105820 9749 44592 30781 64062 86208 99862 80348 25342 11706 79821 48086 51328 23066 47093 84460 95505 82231 72535 94081 28481 1174 5028410 2701 93852 11055 59644 62294 89549 30381 96442 88109 8) )$ SET!:CONST( '!:E , '( 0 2718 28182 84590 45235 36028 74713 52662 49775 72470 93699 95957 49669 67627 72407 66303 53547 59457 13821 78525 16642 74274 66391 93200 30599 21817 41359 66290 43572 90033 42952 60595 63073 81323 28627 943490 7632 33829 88075 31952 510190 1157 38341 9) )$ SET!:CONST( '!:E01 , '( 0 1105 17091 80756 47624 81170 78264 90246 66822 45471 94737 51871 87928 63289 44096 79667 47654 30298 91433 18970 74865 36329 2) )$ SET!:CONST( '!:LOG2 , '(-1 6931 47180 55994 53094 17232 12145 81765 68075 50013 43602 55254 1206 800094 93393 62196 96947 15605 86332 69964 18687 54200 2) )$ SET!:CONST( '!:LOG3 , '( 0 1098 61228 866810 9691 39524 52369 22525 70464 74905 57822 74945 17346 94333 63749 42932 18608 96687 36157 54813 73208 87879 7) )$ SET!:CONST( '!:LOG5 , '( 0 1609 43791 2434100 374 60075 93332 26187 63952 56013 54268 51772 19126 47891 47417 898770 7657 764630 1338 78093 179610 7999 7) )$ SET!:CONST( '!:LOG10 , '( 0 2302 58509 29940 456840 1799 14546 84364 20760 11014 88628 77297 60333 27900 96757 26096 77352 48023 599720 5089 59829 83419 7) )$ SET!:CONST( '!:LOGPI , '( 0 1144 72988 5849400 174 14342 73513 53058 71164 72948 12915 31157 15136 23071 47213 77698 848260 7978 36232 70275 48970 77020 1) )$ SET!:CONST( '!:SQRT2 , '( 0 1414 21356 23730 95048 80168 872420 96980 7856 96718 75376 94807 31766 79737 99073 24784 621070 38850 3875 34327 64157 27350 1) )$ SET!:CONST( '!:SQRT3 , '( 0 17320 5080 75688 77293 52744 634150 5872 36694 28052 53810 38062 805580 6979 45193 301690 88000 3708 11461 86757 24857 56756 3) )$ SET!:CONST( '!:SQRT5 , '( 0 22360 6797 74997 89696 40917 36687 31276 235440 6183 59611 52572 42708 97245 4105 209256 37804 89941 441440 8378 78227 49695 1) )$ SET!:CONST( '!:SQRT10, '( 0 3162 277660 1683 79331 99889 35444 32718 53371 95551 39325 21682 685750 4852 79259 44386 39238 22134 424810 8379 30029 51873 47))$ SET!:CONST( '!:SQRTPI, '( 0 1772 453850 9055 16027 29816 74833 41145 18279 75494 56122 38712 821380 7789 85291 12845 91032 18137 49506 56738 54466 54162 3) )$ SET!:CONST( '!:SQRTE , '( 0 1648 721270 7001 28146 8486 507878 14163 57165 3776100 710 14801 15750 79311 64066 10211 94215 60863 27765 20056 36664 30028 7) )$ SET!:CONST( '!:CBRT2 , '( 0 1259 92104 98948 73164 7672 106072 78228 350570 2514 64701 5079800 819 75112 15529 96765 13959 48372 93965 62436 25509 41543 1) )$ SET!:CONST( '!:CBRT3 , '( 0 1442 249570 30740 8382 32163 83107 80109 58839 18692 53499 35057 75464 16194 54168 75968 29997 33985 47554 79705 64525 66868 4) )$ SET!:CONST( '!:CBRT5 , '( 0 1709 97594 66766 96989 35310 88725 43860 10986 80551 105430 5492 43828 61707 44429 592050 4173 21625 71870 10020 18900 220450 ) )$ SET!:CONST( '!:CBRT10, '( 0 2154 4346900 318 83721 75929 35665 19350 49525 93449 42192 10858 24892 35506 34641 11066 48340 80018 544150 3543 24327 61012 6) )$ SET!:CONST( '!:CBRTPI, '( 0 1464 59188 75615 232630 2014 25272 63790 39173 85968 55627 93717 43572 55937 13839 36497 98286 26614 56820 67820 353820 89750 ) )$ SET!:CONST( '!:CBRTE , '( 0 1395 61242 50860 89528 62812 531960 2586 83759 79065 15199 40698 26175 167060 3173 90156 45951 84696 97888 17295 83022 41352 1) )$ %*************************************************************$ %*************************************************************$ %** **$ %** 4-1. Elementary FUNCTIONS. **$ %** **$ %*************************************************************$ %*************************************************************$ %*************************************************************$ SYMBOLIC PROCEDURE SQRT!:(X,K); %***************************$ %===================================================$ % This function calculates SQRT(x), the square root $ % of "x", with the precision K, by Newton's $ % iteration method. $ % X is a BIG-FLOAT representation of "x", x >= 0, $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %===================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR MINUSP!:(X) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'SQRT!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE BEGIN INTEGER K2,NCUT,NFIG; SCALAR DCUT,HALF,DY,Y,Y0,U; K2 :=K+2; NCUT:=K2-(ORDER!:(X)+1)/2; HALF:=CONV!:S2BF("0.5"); DCUT:=MAKE!:BF(10,-NCUT); DY :=MAKE!:BF(20,-NCUT); Y0:=CONV!:MT(X,2); IF REMAINDER( EP!:(Y0) , 2) = 0 THEN Y0:=MAKE!:BF( 3+2*MT!:(Y0)/25 , EP!:(Y0)/2) ELSE Y0:=MAKE!:BF( 10+2*MT!:(Y0)/9 , (EP!:(Y0)-1)/2); NFIG:=1; WHILE NFIG<K2 OR GREATERP!:( ABS!:(DY) , DCUT) DO <<IF (NFIG:=2*NFIG) > K2 THEN NFIG:=K2; U :=DIVIDE!:(X,Y0,NFIG); Y :=TIMES!:( PLUS!:(Y0,U) , HALF); DY:=DIFFERENCE!:(Y,Y0); Y0:=Y>>; RETURN ROUND!:MT(Y,K); END$ %*************************************************************$ SYMBOLIC PROCEDURE CBRT!:(X,K); %***************************$ %===================================================$ % This function calculates CBRT(x), the cube root $ % of "x", with the precision K, by Newton's $ % iteration method. $ % X is a BIG-FLOAT representation of any real "x", $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %===================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'CBRT!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE IF MINUSP!:(X) THEN MINUS!:( CBRT!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2,NCUT,NFIG,J; SCALAR DCUT,THRE,DY,Y,U; K2 :=K+2; NCUT:=K2-(ORDER!:(X)+2)/3; THRE:=CONV!:I2BF(3); DCUT:=MAKE!:BF(10,-NCUT); DY :=MAKE!:BF(20,-NCUT); Y:=CONV!:MT(X,3); IF (J:=REMAINDER( EP!:(Y) , 3)) = 0 THEN Y:=MAKE!:BF( 5 + MT!:(Y)/167 , EP!:(Y)/3) ELSE IF J=1 OR J=-2 THEN Y:=MAKE!:BF( 10+ MT!:(Y)/75 , (EP!:(Y)-1)/3) ELSE Y:=MAKE!:BF( 22+2*MT!:(Y)/75 , (EP!:(Y)-2)/3); NFIG:=1; WHILE NFIG<K2 OR GREATERP!:( ABS!:(DY) , DCUT) DO <<IF (NFIG:=2*NFIG) > K2 THEN NFIG:=K2; U :=CUT!:MT( TIMES!:(Y,Y) , NFIG); U :=DIVIDE!:(X , U , NFIG); J :=ORDER!:( U:=DIFFERENCE!:(U,Y))+NCUT-K2; DY:=DIVIDE!:(U , THRE , MAX(1,NFIG+J)); Y :=PLUS!:(Y,DY) >>; RETURN ROUND!:MT(Y,K); END$ %*************************************************************$ SYMBOLIC PROCEDURE EXP!:(X,K); %****************************$ %=================================================$ % This function calculates exp(x), the value of $ % the exponential function at the point "x", $ % with the precision K, by summing terms of $ % the Taylor series for exp(z), 0 < z < 1. $ % X is a BIG-FLOAT representation of any real "x",$ % otherwise it is converted to a <BIG-FLOAT>.$ % K is a positive integer. $ %=================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'EXP!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(1) ELSE BEGIN INTEGER K2,M; SCALAR ONE,Q,R,Y,YQ,YR,SAVE!:P; K2 :=K+2; ONE:=CONV!:I2BF(1); Q:=CONV!:I2BF( M:=CONV!:BF2I( Y:=ABS!:(X))); R:=DIFFERENCE!:(Y,Q); IF ZEROP!:(Q) THEN YQ:=ONE ELSE << SAVE!:P:=!:PREC!:; !:PREC!::=K2; YQ:=TEXPT!:( !:E(K2) , M); !:PREC!::=SAVE!:P>>; IF ZEROP!:(R) THEN YR:=ONE ELSE BEGIN INTEGER J,N; SCALAR DCUT,FCTRIAL,RI,TM; DCUT:=MAKE!:BF(10,-K2); YR:=RI:=TM:=ONE; M:=1; J:=0; WHILE GREATERP!:(TM,DCUT) DO <<FCTRIAL:=CONV!:I2BF( M:=M*( J:=J+1)); RI:=CUT!:EP( TIMES!:(RI,R) , -K2); N :=MAX(1 , K2-ORDER!:(FCTRIAL)+ORDER!:(RI)); TM:=DIVIDE!:(RI,FCTRIAL,N); YR:=PLUS!:(YR,TM); IF REMAINDER(J,10)=0 THEN YR:=CUT!:EP(YR,-K2) >>; END; Y:=CUT!:MT( TIMES!:(YQ,YR) , K+1); RETURN (IF MINUSP!:(X) THEN DIVIDE!:(ONE,Y,K) ELSE ROUND!:LAST(Y) ); END$ %*************************************************************$ SYMBOLIC PROCEDURE LOG!:(X,K); %****************************$ %===================================================$ % This function calculates log(x), the value of the $ % logarithmic function at the point "x", with $ % the precision K, by summing terms of the $ % Taylor series for log(1+z), 0 < z < 0.10518. $ % X is a BIG-FLOAT representation of "x", x > 0, $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %===================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR MINUSP!:(X) OR ZEROP!:(X) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'LOG!: ELSE IF EQUAL!:(X , CONV!:I2BF(1)) THEN CONV!:I2BF(0) ELSE BEGIN INTEGER K2,M; SCALAR EE,ES,ONE,SIGN,L,Y,Z,SAVE!:P; K2 :=K+2; ONE:=CONV!:I2BF(1); EE :=!:E(K2); ES :=!:E01(K2); IF GREATERP!:(X,ONE) THEN <<SIGN:=ONE; Y:=X>> ELSE <<SIGN:=MINUS!:(ONE); Y:=DIVIDE!:(ONE,X,K2) >>; IF LESSP!:(Y,EE) THEN <<M:=0; Z:=Y>> ELSE <<IF (M:=(ORDER!:(Y)*23)/10) = 0 THEN Z:=Y ELSE << SAVE!:P:=!:PREC!:; !:PREC!::=K2; Z:=DIVIDE!:(Y , TEXPT!:(EE,M) , K2); !:PREC!::=SAVE!:P>>; WHILE GREATERP!:(Z,EE) DO <<M:=M+1; Z:=DIVIDE!:(Z,EE,K2) >> >>; L:=CONV!:I2BF(M); Y:=CONV!:S2BF("0.1"); WHILE GREATERP!:(Z,ES) DO <<L:=PLUS!:(L,Y); Z:=DIVIDE!:(Z,ES,K2) >>; Z:=DIFFERENCE!:(Z,ONE); BEGIN INTEGER N; SCALAR DCUT,TM,ZI; Y:=TM:=ZI:=Z; Z:=MINUS!:(Z); DCUT:=MAKE!:BF(10,-K2); M:=1; WHILE GREATERP!:( ABS!:(TM) , DCUT) DO <<ZI:=CUT!:EP( TIMES!:(ZI,Z) , -K2); N :=MAX(1 , K2+ORDER!:(ZI)); TM:=DIVIDE!:(ZI , CONV!:I2BF( M:=M+1) , N); Y :=PLUS!:(Y,TM); IF REMAINDER(M,10)=0 THEN Y:=CUT!:EP(Y,-K2) >>; END; Y:=PLUS!:(Y,L); RETURN ROUND!:MT( TIMES!:(SIGN,Y) , K); END$ %*************************************************************$ SYMBOLIC PROCEDURE LN!:(X,K); %*****************************$ %=================================================$ % This function calculates log(x), the value of $ % the logarithmic function at the point "x", $ % with the precision K, by solving $ % x = exp(y) by Newton's method. $ % X is a BIG-FLOAT representation of "x", x > 0, $ % otherwise it is converted to a <BIG-FLOAT>.$ % K is a positive integer. $ %=================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR MINUSP!:(X) OR ZEROP!:(X) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'LN!: ELSE IF EQUAL!:(X , CONV!:I2BF(1)) THEN CONV!:I2BF(0) ELSE BEGIN INTEGER K2,M; SCALAR EE,ONE,SIGN,Y,Z,SAVE!:P; K2 :=K+2; ONE:=CONV!:I2BF(1); EE :=!:E(K2+2); IF GREATERP!:(X,ONE) THEN <<SIGN:=ONE; Y:=X>> ELSE <<SIGN:=MINUS!:(ONE); Y:=DIVIDE!:(ONE,X,K2) >>; IF LESSP!:(Y,EE) THEN <<M:=0; Z:=Y>> ELSE <<IF (M:=(ORDER!:(Y)*23)/10) = 0 THEN Z:=Y ELSE << SAVE!:P:=!:PREC!:; !:PREC!::=K2; Z:=DIVIDE!:(Y , TEXPT!:(EE,M) , K2); !:PREC!::=SAVE!:P>>; WHILE GREATERP!:(Z,EE) DO <<M:=M+1; Z:=DIVIDE!:(Z,EE,K2) >> >>; BEGIN INTEGER NFIG,N; SCALAR DCUT,DX,DY,X0; DCUT:=MAKE!:BF(10,-K2); DY :=MAKE!:BF(20,-K2); Y:=DIVIDE!:( DIFFERENCE!:(Z,ONE) , CONV!:S2BF("1.72") , 2); NFIG:=1; WHILE NFIG<K2 OR GREATERP!:( ABS!:(DY) , DCUT) DO <<IF (NFIG:=2*NFIG) > K2 THEN NFIG:=K2; X0:=EXP!:(Y,NFIG); DX:=DIFFERENCE!:(Z,X0); N :=MAX(1 , NFIG+ORDER!:(DX)); DY:=DIVIDE!:(DX,X0,N); Y :=PLUS!:(Y,DY) >>; END; Y:=PLUS!:( CONV!:I2BF(M) , Y); RETURN ROUND!:MT( TIMES!:(SIGN,Y) , K); END$ %*************************************************************$ SYMBOLIC PROCEDURE SIN!:(X,K); %****************************$ %=================================================$ % This function calculates sin(x), the value of $ % the sine function at the point "x", with $ % the precision K, by summing terms of the $ % Taylor series for sin(z), 0 < z < PI/4. $ % X is a BIG-FLOAT representation of any rael "x",$ % otherwise it is converted to a <BIG-FLOAT>.$ % K is a positive integer. $ %=================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'SIN!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE IF MINUSP!:(X) THEN MINUS!:( SIN!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2,M; SCALAR PI4,SIGN,Q,R,Y; K2 :=K+2; M :=PRECI!:(X); PI4:=TIMES!:( !:PI(K2+M) , CONV!:S2BF("0.25")); IF LESSP!:(X,PI4) THEN <<M:=0; R:=X>> ELSE <<M:=CONV!:BF2I( Q:=QUOTIENT!:(X,PI4)); R:=DIFFERENCE!:(X , TIMES!:(Q,PI4)) >>; SIGN:=CONV!:I2BF(1); IF M>=8 THEN M:=REMAINDER(M,8); IF M>=4 THEN <<SIGN:=MINUS!:(SIGN); M:=M-4>>; IF M=0 THEN GOTO SN ELSE IF M=1 THEN GOTO M1 ELSE IF M=2 THEN GOTO M2 ELSE GOTO M3; M1: R:=CUT!:MT( DIFFERENCE!:(PI4,R) , K2); RETURN TIMES!:(SIGN , COS!:(R,K)); M2: R:=CUT!:MT(R,K2); RETURN TIMES!:(SIGN , COS!:(R,K)); M3: R:=CUT!:MT( DIFFERENCE!:(PI4,R) , K2); SN: BEGIN INTEGER J,N,NCUT; SCALAR DCUT,FCTRIAL,RI,TM; NCUT:=K2-MIN(0 , ORDER!:(R)+1); DCUT:=MAKE!:BF(10,-NCUT); Y:=RI:=TM:=R; R:=MINUS!:( CUT!:EP( TIMES!:(R,R) , -NCUT)); M:=J:=1; WHILE GREATERP!:( ABS!:(TM) , DCUT) DO <<J:=J+2; FCTRIAL:=CONV!:I2BF( M:=M*J*(J-1)); RI:=CUT!:EP( TIMES!:(RI,R) , -NCUT); N :=MAX(1 , K2-ORDER!:(FCTRIAL)+ORDER!:(RI)); TM:=DIVIDE!:(RI,FCTRIAL,N); Y :=PLUS!:(Y,TM); IF REMAINDER(J,20)=0 THEN Y:=CUT!:EP(Y,-NCUT) >>; END; RETURN ROUND!:MT( TIMES!:(SIGN,Y) , K); END$ %*************************************************************$ SYMBOLIC PROCEDURE COS!:(X,K); %****************************$ %=================================================$ % This function calculates cos(x), the value of $ % the cosine function at the point "x", with $ % the precision K, by summing terms of the $ % Taylor series for cos(z), 0 < z < PI/4. $ % X is a BIG-FLOAT representation of any real "x",$ % otherwise it is converted to a <BIG-FLOAT>.$ % K is a positive integer. $ %=================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'COS!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(1) ELSE IF MINUSP!:(X) THEN COS!:( MINUS!:(X) , K) ELSE BEGIN INTEGER K2,M; SCALAR PI4,SIGN,Q,R,Y; K2 :=K+2; M :=PRECI!:(X); PI4:=TIMES!:( !:PI(K2+M) , CONV!:S2BF("0.25")); IF LESSP!:(X,PI4) THEN <<M:=0; R:=X>> ELSE <<M:=CONV!:BF2I( Q:=QUOTIENT!:(X,PI4)); R:=DIFFERENCE!:(X , TIMES!:(Q,PI4)) >>; SIGN:=CONV!:I2BF(1); IF M>=8 THEN M:=REMAINDER(M,8); IF M>=4 THEN <<SIGN:=MINUS!:(SIGN); M:=M-4>>; IF M>=2 THEN SIGN:=MINUS!:(SIGN); IF M=0 THEN GOTO CS ELSE IF M=1 THEN GOTO M1 ELSE IF M=2 THEN GOTO M2 ELSE GOTO M3; M1: R:=CUT!:MT( DIFFERENCE!:(PI4,R) , K2); RETURN TIMES!:(SIGN , SIN!:(R,K)); M2: R:=CUT!:MT(R,K2); RETURN TIMES!:(SIGN , SIN!:(R,K)); M3: R:=CUT!:MT( DIFFERENCE!:(PI4,R) , K2); CS: BEGIN INTEGER J,N; SCALAR DCUT,FCTRIAL,RI,TM; DCUT:=MAKE!:BF(10,-K2); Y:=RI:=TM:=CONV!:I2BF(1); R:=MINUS!:( CUT!:EP( TIMES!:(R,R) , -K2)); M:=1; J:=0; WHILE GREATERP!:( ABS!:(TM) , DCUT) DO <<J:=J+2; FCTRIAL:=CONV!:I2BF( M:=M*J*(J-1)); RI:=CUT!:EP( TIMES!:(RI,R) , -K2); N :=MAX(1 , K2-ORDER!:(FCTRIAL)+ORDER!:(RI)); TM:=DIVIDE!:(RI,FCTRIAL,N); Y :=PLUS!:(Y,TM); IF REMAINDER(J,20)=0 THEN Y:=CUT!:EP(Y,-K2) >>; END; RETURN ROUND!:MT( TIMES!:(SIGN,Y) , K); END$ %*************************************************************$ SYMBOLIC PROCEDURE TAN!:(X,K); %****************************$ %=================================================$ % This function calculates tan(x), the value of $ % the tangent function at the point "x", $ % with the precision K, by calculating $ % sin(x) or cos(x) = sin(PI/2-x). $ % X is a BIG-FLOAT representation of any real "x",$ % otherwise it is converted to a <BIG-FLOAT>.$ % K is a positive integer. $ %=================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'TAN!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE IF MINUSP!:(X) THEN MINUS!:( TAN!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2,M; SCALAR ONE,PI4,SIGN,Q,R; K2 :=K+2; ONE:=CONV!:I2BF(1); M :=PRECI!:(X); PI4:=TIMES!:( !:PI(K2+M) , CONV!:S2BF("0.25")); IF LESSP!:(X,PI4) THEN <<M:=0; R:=X>> ELSE <<M:=CONV!:BF2I( Q:=QUOTIENT!:(X,PI4)); R:=DIFFERENCE!:(X , TIMES!:(Q,PI4)) >>; IF M>=4 THEN M:=REMAINDER(M,4); IF M>=2 THEN SIGN:=MINUS!:(ONE) ELSE SIGN:=ONE; IF M=1 OR M=3 THEN R:=DIFFERENCE!:(PI4,R); R:=CUT!:MT(R,K2); IF M=0 OR M=3 THEN GOTO M03 ELSE GOTO M12; M03: R:=SIN!:(R,K2); Q:=DIFFERENCE!:(ONE , TIMES!:(R,R)); Q:=SQRT!:( CUT!:MT(Q,K2) , K2); RETURN TIMES!:(SIGN , DIVIDE!:(R,Q,K)); M12: R:=SIN!:(R,K2); Q:=DIFFERENCE!:(ONE , TIMES!:(R,R)); Q:=SQRT!:( CUT!:MT(Q,K2) , K2); RETURN TIMES!:(SIGN , DIVIDE!:(Q,R,K)); END$ %*************************************************************$ SYMBOLIC PROCEDURE ASIN!:(X,K); %***************************$ %==================================================$ % This function calculates asin(x), the value of $ % the arcsine function at the point "x", $ % with the precision K, by calculating $ % atan(x/SQRT(1-x**2)) by ATAN!:. $ % The answer is in the range [-PI/2 , PI/2]. $ % X is a BIG-FLOAT representation of "x", IxI <= 1,$ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %==================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR GREATERP!:( ABS!:(X) , CONV!:I2BF(1)) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ASIN!: ELSE IF MINUSP!:(X) THEN MINUS!:( ASIN!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2; SCALAR ONE,Y; K2 :=K+2; ONE:=CONV!:I2BF(1); IF LESSP!:( DIFFERENCE!:(ONE,X) , MAKE!:BF(10,-K2)) THEN RETURN ROUND!:MT ( TIMES!:( !:PI(K+1) , CONV!:S2BF("0.5")) , K); Y:=CUT!:MT( DIFFERENCE!:(ONE , TIMES!:(X,X)) , K2); Y:=DIVIDE!:(X , SQRT!:(Y,K2) , K2); RETURN ATAN!:(Y,K); END$ %*************************************************************$ SYMBOLIC PROCEDURE ACOS!:(X,K); %***************************$ %==================================================$ % This function calculates acos(x), the value of $ % the arccosine function at the point "x", $ % with the precision K, by calculating $ % atan(SQRT(1-x**2)/x) if x > 0 or $ % atan(SQRT(1-x**2)/x) + PI if x < 0. $ % The answer is in the range [0 , PI]. $ % X is a BIG-FLOAT representation of "x", IxI <= 1,$ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %==================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR GREATERP!:( ABS!:(X) , CONV!:I2BF(1)) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ACOS!: ELSE BEGIN INTEGER K2; SCALAR Y; K2:=K+2; IF LESSP!:( ABS!:(X) , MAKE!:BF(50,-K2)) THEN RETURN ROUND!:MT ( TIMES!:( !:PI(K+1) , CONV!:S2BF("0.5")) , K); Y:=DIFFERENCE!:( CONV!:I2BF(1) , TIMES!:(X,X)); Y:=CUT!:MT(Y,K2); Y:=DIVIDE!:( SQRT!:(Y,K2) , ABS!:(X) , K2); RETURN (IF MINUSP!:(X) THEN ROUND!:MT ( DIFFERENCE!:( !:PI(K+1) , ATAN!:(Y,K)) , K) ELSE ATAN!:(Y,K) ); END$ %*************************************************************$ SYMBOLIC PROCEDURE ATAN!:(X,K); %***************************$ %====================================================$ % This function calculates atan(x), the value of the $ % arctangent function at the point "x", with $ % the precision K, by summing terms of the $ % Taylor series for atan(z) if 0 < z < 0.42. $ % Otherwise the following identities are used: $ % atan(x) = PI/2 - atan(1/x) if 1 < x and $ % atan(x) = 2*atan(x/(1+SQRT(1+x**2))) $ % if 0.42 <= x <= 1. $ % The answer is in the range [-PI/2 , PI/2]. $ % X is a BIG-FLOAT representation of any real "x", $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %====================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ATAN!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE IF MINUSP!:(X) THEN MINUS!:( ATAN!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2; SCALAR ONE,PI4,Y,Z; K2 :=K+2; ONE:=CONV!:I2BF(1); PI4:=TIMES!:( !:PI(K2) , CONV!:S2BF("0.25")); IF EQUAL!:(X,ONE) THEN RETURN ROUND!:MT(PI4,K); IF GREATERP!:(X,ONE) THEN RETURN ROUND!:MT ( DIFFERENCE!:( PLUS!:(PI4,PI4) , ATAN!:( DIVIDE!:(ONE,X,K2) , K+1)) , K); IF LESSP!:(X , CONV!:S2BF("0.42")) THEN GOTO AT; Y:=PLUS!:(ONE , CUT!:MT( TIMES!:(X,X) , K2)); Y:=PLUS!:(ONE , SQRT!:(Y,K2)); Y:=ATAN!:( DIVIDE!:(X,Y,K2) , K+1); RETURN ROUND!:MT( TIMES!:(Y , CONV!:I2BF(2)) , K); AT: BEGIN INTEGER M,N,NCUT; SCALAR DCUT,TM,ZI; NCUT:=K2-MIN(0 , ORDER!:(X)+1); Y:=TM:=ZI:=X; Z:=MINUS!:( CUT!:EP( TIMES!:(X,X) , -NCUT)); DCUT:=MAKE!:BF(10,-NCUT); M:=1; WHILE GREATERP!:( ABS!:(TM) , DCUT) DO <<ZI:=CUT!:EP( TIMES!:(ZI,Z) , -NCUT); N :=MAX(1 , K2+ORDER!:(ZI)); TM:=DIVIDE!:(ZI , CONV!:I2BF( M:=M+2) , N); Y :=PLUS!:(Y,TM); IF REMAINDER(M,20)=0 THEN Y:=CUT!:EP(Y,-NCUT) >>; END; RETURN ROUND!:MT(Y,K) END$ %*************************************************************$ SYMBOLIC PROCEDURE ARCSIN!:(X,K); %*************************$ %==================================================$ % This function calculates arcsin(x), the value of $ % the arcsine function at the point "x", with $ % the precision K, by solving $ % x = sin(y) if 0 < x <= 0.72, or $ % SQRT(1-x**2) = sin(y) if 0.72 < x, $ % by Newton's iteration method. $ % The answer is in the range [-PI/2 , PI/2]. $ % X is a BIG-FLOAT representation of "x", IxI <= 1,$ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %==================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR GREATERP!:( ABS!:(X) , CONV!:I2BF(1)) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ARCSIN!: ELSE IF ZEROP!:(X) THEN CONV!:I2BF(0) ELSE IF MINUSP!:(X) THEN MINUS!:( ARCSIN!:( MINUS!:(X) , K)) ELSE BEGIN INTEGER K2; SCALAR DCUT,ONE,PI2,Y; K2 :=K+2; DCUT:=MAKE!:BF(10 , -K2+ORDER!:(X)+1); ONE :=CONV!:I2BF(1); PI2 :=TIMES!:( !:PI(K2+2) , CONV!:S2BF("0.5")); IF LESSP!:( DIFFERENCE!:(ONE,X) , DCUT) THEN RETURN ROUND!:MT(PI2,K); IF GREATERP!:(X , CONV!:S2BF("0.72")) THEN GOTO AC ELSE GOTO AS; AC: Y:=CUT!:MT( DIFFERENCE!:(ONE , TIMES!:(X,X)) , K2); Y:=ARCSIN!:( SQRT!:(Y,K2) , K); RETURN ROUND!:MT( DIFFERENCE!:(PI2,Y) , K); AS: BEGIN INTEGER NFIG,N; SCALAR CX,DX,DY,X0; DY:=ONE; Y :=X; NFIG:=1; WHILE NFIG<K2 OR GREATERP!:( ABS!:(DY) , DCUT) DO <<IF (NFIG:=2*NFIG) > K2 THEN NFIG:=K2; X0:=SIN!:(Y,NFIG); CX:=DIFFERENCE!:(ONE , TIMES!:(X0,X0)); CX:=CUT!:MT(CX,NFIG); CX:=SQRT!:(CX,NFIG); DX:=DIFFERENCE!:(X,X0); N :=MAX(1 , NFIG+ORDER!:(DX)); DY:=DIVIDE!:(DX,CX,N); Y :=PLUS!:(Y,DY) >>; END; RETURN ROUND!:MT(Y,K); END$ %*************************************************************$ SYMBOLIC PROCEDURE ARCCOS!:(X,K); %*************************$ %====================================================$ % This function calculates arccos(x), the value of $ % the arccosine function at the point "x", with $ % the precision K, by calculating $ % arcsin(SQRT(1-x**2)) if x > 0.72 and $ % PI/2 - arcsin(x) otherwise by ARCSIN!:. $ % The answer is in the range [0 , PI]. $ % X is a BIG-FLOAT representation of "x", IxI <= 1, $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %====================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR GREATERP!:( ABS!:(X) , CONV!:I2BF(1)) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ARCCOS!: ELSE IF LEQ!:(X , CONV!:S2BF("0.72")) THEN ROUND!:MT( DIFFERENCE!: ( TIMES!:( !:PI(K+1) , CONV!:S2BF("0.5")) , ARCSIN!:(X,K) ) , K) ELSE ARCSIN!:( SQRT!:( CUT!:MT ( DIFFERENCE!:( CONV!:I2BF(1) , TIMES!:(X,X)) , K+2) , K+2) , K)$ %*************************************************************$ SYMBOLIC PROCEDURE ARCTAN!:(X,K); %*************************$ %==================================================$ % This function calculates arctan(x), the value of $ % the arctangent function at the point "x", $ % with the precision K, by calculating $ % arcsin(x/SQRT(1+x**2)) by ARCSIN!: $ % The answer is in the range [-PI/2 , PI/2]. $ % X is a BIG-FLOAT representation of any real "x", $ % otherwise it is converted to a <BIG-FLOAT>. $ % K is a positive integer. $ %==================================================$ IF NOT( BFP!:( X:=CONV!:A2BF(X))) OR NOT( FIXP(K)) OR K<=0 THEN BFLERRMSG 'ARCTAN!: ELSE IF MINUSP!:(X) THEN MINUS!:( ARCTAN!:( MINUS!:(X) , K)) ELSE ARCSIN!:( DIVIDE!:(X , SQRT!:( CUT!:MT ( PLUS!:( CONV!:I2BF(1) , TIMES!:(X,X)) , K+2) , K+2) , K+2) , K)$ END; |
Added r30/bfloat.tst version [2e19f4c2d2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | on time; 123/100; %this used the ordinary rational number system; on bigfloat; %now we shall use big-floats; ws/2; %Note that trailing zeros have been suppressed, although we know %that this number was calculated to a default precision of 10; %Let us raise this to a high power; ws**24; %Now let us evaluate pi; pi; %Of course this was treated symbolically; on numval; %However, this will force numerical evaluation; ws; %Let us try a higher precision; precision 50; pi; %Now find the cosine of pi/6; cos(ws/6); %This should be the sqrt(3)/2; ws**2; %Here are some well known examples which show the power of the big %float system; precision 10; %the usual default again; let xx=e**(pi*sqrt(163)); let yy=1-2*cos((6*log(2)+log(10005))/sqrt(163)); %now ask for numerical values of constants; on numval; %first notice that xx looks like an integer; xx; %and that yy looks like zero; yy; %but of course it's an illusion; precision 50; xx; yy; %now let's look at an unusual way of finding an old friend; nn := 8$ a := 1$ b := 1/sqrt 2$ u:= 1/4$ x := 1$ for i:=1:nn do <<y := a; a := (a+b)/2; b := sqrt(y*b); %arith-geom mean; u := u-x*(a-y)**2; x := 2*x; write a**2/u>>; %the limit is obviously: pi; end; |
Added r30/cedit.fap version [b9fe9ffa5a].
cannot compute difference between binary files
Added r30/cedit.red version [27ec1b236b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INPUT STRING EDITOR; GLOBAL '(CRBUF!* CRBUF1!* CRBUFLIS!* ESC!* STATCOUNTER RPRIFN!* RTERFN!* !$EOL!$ !*EAGAIN !*FULL); !*EAGAIN := NIL; %ESC!* := INTERN ASCII 125; %this is system dependent and defines %a terminator for strings; SYMBOLIC PROCEDURE RPLACW(U,V); IF ATOM U OR ATOM V THEN ERRACH LIST('RPLACW,U,V) ELSE RPLACD(RPLACA(U,CAR V),CDR V); SYMBOLIC PROCEDURE CEDIT N; BEGIN SCALAR X,OCHAN; OCHAN := WRS NIL; IF N EQ 'FN THEN X := REVERSIP CRBUF!* ELSE IF NULL N THEN IF NULL CRBUFLIS!* THEN <<STATCOUNTER := STATCOUNTER-1; REDERR "No previous entry">> ELSE X := CDAR CRBUFLIS!* ELSE IF (X := ASSOC(CAR N,CRBUFLIS!*)) THEN X := CDR X ELSE <<STATCOUNTER := STATCOUNTER-1; REDERR LIST("Entry",CAR N,"not found")>>; CRBUF!* := NIL; X := FOR EACH J IN X COLLECT J; %to make a copy; TERPRI(); EDITP X; TERPRI(); X := CEDIT1 X; WRS OCHAN; IF X EQ 'FAILED THEN NIL ELSE CRBUF1!* := X END; GLOBAL '(!*BLANKNOTOK!*); SYMBOLIC PROCEDURE CEDIT1 U; BEGIN SCALAR X,Y,Z; Z := SETPCHAR '!>; IF NOT !*EAGAIN THEN <<PRIN2T "For help, type ?"; !*EAGAIN := T>>; WHILE U AND (CAR U EQ !$EOL!$) DO U := CDR U; U := APPEND(U,LIST '! ); %to avoid 'last char' problem; IF !*FULL THEN EDITP U; TOP: X := U; %current pointer position; A: Y := READCH(); %current command; IF Y EQ 'P OR Y EQ 'p THEN EDITP X ELSE IF Y EQ 'I OR Y EQ 'i THEN EDITI X ELSE IF Y EQ 'C OR Y EQ 'c THEN EDITC X ELSE IF Y EQ 'D OR Y EQ 'd THEN EDITD X ELSE IF Y EQ 'F OR Y EQ 'f THEN X := EDITF(X,NIL) ELSE IF Y EQ 'E OR Y EQ 'e THEN <<TERPRI(); EDITP1 U; SETPCHAR Z; RETURN U>> ELSE IF Y EQ 'Q OR Y EQ 'q THEN <<SETPCHAR Z; RETURN 'FAILED>> ELSE IF Y EQ '!? THEN EDITH X ELSE IF Y EQ 'B OR Y EQ 'b THEN GO TO TOP ELSE IF Y EQ 'K OR Y EQ 'k THEN EDITF(X,T) ELSE IF Y EQ 'S OR Y EQ 's THEN X := EDITS X ELSE IF Y EQ '! AND NOT !*BLANKNOTOK!* OR Y EQ 'X OR Y EQ 'x THEN X := EDITN X ELSE IF Y EQ '! AND !*BLANKNOTOK!* THEN GO TO A ELSE IF Y EQ !$EOL!$ THEN GO TO A ELSE LPRIM!* LIST(Y,"Invalid editor character"); GO TO A END; SYMBOLIC PROCEDURE EDITC X; IF NULL CDR X THEN LPRIM!* "No more characters" ELSE RPLACA(X,READCH()); SYMBOLIC PROCEDURE EDITD X; IF NULL CDR X THEN LPRIM!* "No more characters" ELSE RPLACW(X,CADR X . CDDR X); SYMBOLIC PROCEDURE EDITF(X,BOOL); BEGIN SCALAR Y,Z; Y := CDR X; Z := READCH(); IF NULL Y THEN RETURN <<LPRIM!* LIST(Z,"Not found"); X>>; WHILE CDR Y AND NOT Z EQ CAR Y DO Y := CDR Y; RETURN IF NULL CDR Y THEN <<LPRIM!* LIST(Z,"Not found"); X>> ELSE IF BOOL THEN RPLACW(X,CAR Y . CDR Y) ELSE Y END; SYMBOLIC PROCEDURE EDITH X; <<PRIN2T "THE FOLLOWING COMMANDS ARE SUPPORTED:"; PRIN2T " B move pointer to beginning"; PRIN2T " C<character> replace next character by <character>"; PRIN2T " D delete next character"; PRIN2T " E end editing and reread text"; PRIN2T " F<character> move pointer to next occurrence of <character>"; PRIN2T " I<string><escape> insert <string> in front of pointer"; PRIN2T " K<character> delete all chars until <character>"; PRIN2T " P print string from current pointer"; PRIN2T " Q give up with error exit"; PRIN2T " S<string><escape> search for first occurrence of <string>"; PRIN2T " positioning pointer just before it"; PRIN2T " <space> or X move pointer right one character"; TERPRI(); PRIN2T "ALL COMMAND SEQUENCES SHOULD BE FOLLOWED BY A CARRIAGE RETURN"; PRIN2T " TO BECOME EFFECTIVE">>; SYMBOLIC PROCEDURE EDITI X; BEGIN SCALAR Y,Z; WHILE (Y := READCH()) NEQ ESC!* DO Z := Y . Z; RPLACW(X,NCONC(REVERSIP Z,CAR X . CDR X)) END; SYMBOLIC PROCEDURE EDITN X; IF NULL CDR X THEN LPRIM!* "NO MORE CHARACTERS" ELSE CDR X; SYMBOLIC PROCEDURE EDITP U; <<EDITP1 U; TERPRI()>>; SYMBOLIC PROCEDURE EDITP1 U; FOR EACH X IN U DO IF X EQ !$EOL!$ THEN TERPRI() ELSE PRIN2 X; SYMBOLIC PROCEDURE EDITS U; BEGIN SCALAR X,Y,Z; X := U; WHILE (Y := READCH()) NEQ ESC!* DO Z := Y . Z; Z := REVERSIP Z; A: IF NULL X THEN RETURN <<LPRIM!* "not found"; U>> ELSE IF EDMATCH(Z,X) THEN RETURN X; X := CDR X; GO TO A END; SYMBOLIC PROCEDURE EDMATCH(U,V); %matches list of characters U against V. Returns rest of V if %match occurs or NIL otherwise; IF NULL U THEN V ELSE IF NULL V THEN NIL ELSE IF CAR U=CAR V THEN EDMATCH(CDR U,CDR V) ELSE NIL; SYMBOLIC PROCEDURE LPRIM!* U; <<LPRIM U; TERPRI()>>; COMMENT Editing Function Definitions; REMPROP('EDITDEF,'STAT); SYMBOLIC PROCEDURE EDITDEF U; EDITDEF1 CAR U; SYMBOLIC PROCEDURE EDITDEF1 U; BEGIN SCALAR TYPE,X; IF NULL(X := GETD U) THEN RETURN LPRIM LIST(U,"not defined") ELSE IF CODEP CDR X OR NOT EQCAR(CDR X,'LAMBDA) THEN RETURN LPRIM LIST(U,"cannot be edited"); TYPE := CAR X; X := CDR X; IF TYPE EQ 'EXPR THEN X := 'DE . U . CDR X ELSE IF TYPE EQ 'FEXPR THEN X := 'DF . U . CDR X ELSE IF TYPE EQ 'MACRO THEN X := 'DM . U . CDR X ELSE REDERR LIST("strange function type",TYPE); RPRIFN!* := 'ADD2BUF; RTERFN!* := 'ADDTER2BUF; CRBUF!* := NIL; X := ERRORSET(LIST('RPRINT,MKQUOTE X),T,NIL); RPRIFN!* := NIL; RTERFN!* := NIL; IF ERRORP X THEN RETURN (CRBUF!* := NIL); CRBUF!* := CEDIT 'FN; RETURN NIL END; SYMBOLIC PROCEDURE ADD2BUF U; CRBUF!* := U . CRBUF!*; SYMBOLIC PROCEDURE ADDTER2BUF; CRBUF!* := !$EOL!$ . CRBUF!*; PUT('EDITDEF,'STAT,'RLIS); COMMENT Displaying past input expressions; PUT('DISPLAY,'STAT,'RLIS); SYMBOLIC PROCEDURE DISPLAY U; BEGIN SCALAR X; U := CAR U; X := CRBUFLIS!*; TERPRI(); IF NOT NUMBERP U THEN U := LENGTH X; WHILE U>0 AND X DO <<PRIN2 CAAR X; PRIN2 ": "; EDITP CDAR X; TERPRI(); X := CDR X; U := U-1>>; END; END; |
Added r30/cmacro.fap version [2d3a54a545].
cannot compute difference between binary files
Added r30/cmacro.red version [c46d5f52d1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT DECSYSTEM 10 AND 20 COMPILER MACRO MODULE; PUT('COMPLR,'IMPORTS,'(LAP)); COMMENT fixups for PDP-10 assembly; FLAG('(NCONS XCONS),'LOSE); FLAG('(LIST2 LIST3 LIST4 LIST5),'LOSE); REMFLAG('(XN),'LOSE); COMMENT Global variable and flag values for PDP-10 version; GLOBAL '(MAXNARGS !*NOLINKE !*ORD !*PLAP !*R2I); MAXNARGS := 14; !*NOLINKE := NIL; !*ORD := NIL; !*PLAP := NIL; !*R2I := T; %We also need; FLUID '(REGS); COMMENT general functions; SYMBOLIC PROCEDURE !&MKFUNC FN; MKQUOTE FN; COMMENT c-macros for PDP-10 Implementation; SYMBOLIC PROCEDURE !*ALLOC N; IF N=0 THEN NIL ELSE IF N=1 THEN LIST '(PUSH P 1) ELSE LIST(LIST('ADD,'P,LIST('C,0,0,N,N)),'(213 P 85 16)); SYMBOLIC PROCEDURE !*DEALLOC N; IF N>0 THEN LIST LIST('SUB,'P,LIST('C,0,0,N,N)) ELSE NIL; COMMENT !*ENTRY is handled by the loader; SYMBOLIC PROCEDURE !*EXIT; LIST '(POPJ P); SYMBOLIC PROCEDURE !*STORE(REG,FLOC); % Uses R as extra reg; BEGIN SCALAR OP,PQ; IF NUMBERP FLOC THEN (IF FLOC>5 THEN FLOC := 'EXARG . (FLOC - 6) ELSE IF FLOC<1 THEN PQ := '(P)) ELSE IF EQCAR(FLOC,'GLOBAL) THEN FLOC := 'FLUID . CDR FLOC; IF NUMBERP REG AND REG>5 THEN RETURN IF IDP FLOC OR NUMBERP FLOC AND FLOC>0 THEN !*LOAD(FLOC,REG) ELSE NCONC(!*LOAD('R,REG), LIST ('MOVEM . ('R . (FLOC . PQ)))); OP := IF REG THEN 'MOVEM ELSE <<REG := 0; 'SETZM>>; RETURN LIST (OP . (REG . (FLOC . PQ))) END; SYMBOLIC PROCEDURE !*JUMP ADR; LIST LIST('JRST,0,ADR); SYMBOLIC PROCEDURE !*JUMPNIL ADR; LIST LIST('JUMPE,1,ADR); SYMBOLIC PROCEDURE !*JUMPT ADR; LIST LIST('JUMPN,1,ADR); SYMBOLIC PROCEDURE !*JUMPE(ADR,EXP); NCONC(!*LOADEXP(1,EXP,'(CAMN . CAIN)),LIST LIST('JRST,0,ADR)); SYMBOLIC PROCEDURE !*JUMPN(ADR,EXP); NCONC(!*LOADEXP(1,EXP,'(CAME . CAIE)),LIST LIST('JRST,0,ADR)); SYMBOLIC PROCEDURE !*LBL ADR; LIST ADR; SYMBOLIC PROCEDURE !*LAMBIND(REGS,ALST); %produces the parameter list for binding; BEGIN SCALAR X,Y; ALST := REVERSE ALST; REGS := REVERSE REGS; WHILE ALST DO <<IF NULL REGS THEN X := 0 ELSE <<X := CAR REGS; REGS := CDR REGS>>; Y := LIST(0,X,LIST('FLUID,CAAR ALST)) . Y; ALST := CDR ALST>>; RETURN '(CALL 0 (E !*LAMBIND!*)) . Y END; SYMBOLIC PROCEDURE !*PROGBIND ALST; !*LAMBIND(NIL,ALST); SYMBOLIC PROCEDURE !*FREERSTR ALST; '((CALL 0 (E !*SPECRSTR!*))); SYMBOLIC PROCEDURE !*LOAD(REG,EXP); % Uses R as extra reg; IF REG=EXP THEN NIL ELSE IF NUMBERP REG AND REG>5 THEN IF IDP EXP OR NUMBERP EXP AND EXP>0 THEN !*STORE(EXP,REG) ELSE IF EXP='(QUOTE NIL) THEN !*STORE(NIL,REG) ELSE NCONC(!*LOAD('R,EXP),!*STORE('R,REG)) ELSE !*LOADEXP(REG,EXP,'(MOVE . MOVEI)); SYMBOLIC PROCEDURE !*LINK(FN,TYPE,NARGS); !*MKLINK(FN,TYPE,NARGS,-1,'CALL); SYMBOLIC PROCEDURE !*LINKE(FN,TYPE,NARGS,N); !*MKLINK(FN,TYPE,NARGS,N,'JCALL); COMMENT Auxiliary functions used by the c-macros; SYMBOLIC PROCEDURE !*OPEN U; IF CAR U EQ 'LAMBDA THEN SUBPLIS(U,'(1 1)) ELSE U; SYMBOLIC PROCEDURE SUBPLIS(X,Y); SUBLIS(PAIR(CADR X,Y),CADDR X); SYMBOLIC PROCEDURE !*LOADEXP(REG,U,OPS); %OPS=(direct . immediate). When not MOVE, uses D as extra reg; %REG is always an actual machine register; IF ATOM U THEN IF IDP U OR U>0 AND U<6 THEN LIST LIST(CAR OPS,REG,U) ELSE IF U>5 THEN LIST LIST(CAR OPS,REG,'EXARG . (U - 6)) ELSE LIST LIST(CAR OPS,REG,U,'P) ELSE IF CAR U EQ 'QUOTE THEN LIST LIST(CDR OPS,REG,U) ELSE IF CAR U EQ 'GLOBAL THEN LIST LIST(CAR OPS,REG,'FLUID . CDR U) ELSE IF CAR U EQ 'FLUID THEN LIST LIST(CAR OPS,REG,U) ELSE IF NOT CAR OPS EQ 'MOVE THEN NCONC(!*LOAD('D,U),LIST LIST(CAR OPS,REG,'D)) ELSE BEGIN SCALAR X,Y,Z; X := 'ANYREG; IF ATOM (Y := CADR U) THEN IF IDP Y THEN X := 'OPEN ELSE IF Y<1 THEN Y := Y . '(P) ELSE IF Y>5 THEN Y := LIST ('EXARG . (Y - 6)) ELSE X := 'OPEN ELSE IF CAR Y EQ 'GLOBAL THEN Y := LIST ('FLUID . CDR Y) ELSE IF CAR Y EQ 'FLUID THEN Y := LIST Y ELSE <<X := 'OPEN; Z := !*LOAD(REG,Y); Y := REG>>; IF NOT (X := GET(CAR U,X)) THEN LPRIE LIST("Incomplete macro definition for", CAR U); RETURN NCONC(Z,SUBPLIS(X,LIST(REG,Y))) END; SYMBOLIC PROCEDURE !*MKLINK(FN,TYPE,NARGS,N,CALL); BEGIN SCALAR B,Y; B := N<0; IF (Y := GET(FN,'OPEN)) AND (B OR NOT FLAGP(FN,'NOPENR)) THEN <<Y := !*OPEN Y; IF NOT B THEN Y := APPEND(Y,LIST(LIST('!*DEALLOC,N),'(!*EXIT)))>> ELSE <<Y := LIST LIST(CALL, IF TYPE EQ 'FEXPR THEN 15 ELSE NARGS, LIST('E,FN)); IF N>0 THEN Y := LIST('!*DEALLOC,N) . Y>>; RETURN Y END; COMMENT Peep-hole optimization tables; SYMBOLIC PROCEDURE !&STOPT U; %this has to use fact that LLNGTH is offset during code generation; IF CDAR U='(1 0) AND CADR U='(!*ALLOC 0) THEN <<RPLACA(U,'(PUSH P 1)); RPLACD(U,NIL)>> ELSE IF CDAR U='(2 -1) AND CADR U='(!*STORE 1 0) AND CADDR U='(!*ALLOC -1) THEN <<RPLACA(U,'(PUSH P 1)); RPLACA(CDR U,'(PUSH P 2)); RPLACD(CDR U,NIL)>>; PUT('!*STORE,'OPTFN,'!&STOPT); COMMENT Some PDP-10 dependent optimizations; SYMBOLIC PROCEDURE !&PAEQUAL(U,VARS); (LAMBDA(X,Y); IF !&EQVP X OR !&EQVP Y THEN 'EQ ELSE IF NUMBERP X OR NUMBERP Y THEN 'EQN ELSE 'EQUAL) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('EQUAL,'PA1FN,'!&PAEQUAL); SYMBOLIC PROCEDURE !&EQP U; %!&EQP is true if U is an object for which EQ can replace EQUAL; INUMP U OR IDP U; SYMBOLIC PROCEDURE !&EQVP U; %!&EQVP is true if EVAL U is an object for which EQ can %replace EQUAL; INUMP U OR EQCAR(U,'QUOTE) AND !&EQP CADR U; SYMBOLIC PROCEDURE !&PAMEMBER(U,VARS); (LAMBDA(X,Y); IF !&EQVP X THEN 'MEMQ ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'MEMBER ELSE BEGIN SCALAR A; A := (Y := CADR Y); WHILE Y AND A DO <<A := !&EQP CAR Y; Y := CDR Y>>; RETURN IF A THEN 'MEMQ ELSE 'MEMBER END) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('MEMBER,'PA1FN,'!&PAMEMBER); SYMBOLIC PROCEDURE !&PAASSOC(U,VARS); (LAMBDA(X,Y); IF !&EQVP X THEN 'ATSOC ELSE IF NOT EQCAR(Y,'QUOTE) THEN 'ASSOC ELSE BEGIN SCALAR A; A := T; Y := CADR Y; WHILE Y AND A DO <<A := !&EQP CAAR Y; Y := CDR Y>>; RETURN IF A THEN 'ATSOC ELSE 'ASSOC END) (CADR U,CADDR U) . !&PALIS(CDR U,VARS); PUT('ASSOC,'PA1FN,'!&PAASSOC); SYMBOLIC PROCEDURE !&COMAPPLY(EXP,STATUS); % Look for LIST; BEGIN INTEGER N,NN; SCALAR FN,ARGS; EXP := CDR EXP; FN := CAR EXP; ARGS := CDR EXP; IF !&CFNTYPE FN EQ 'FEXPR THEN LPRIE LIST(FN,"IS NOT AN EXPR FOR APPLY"); IF NULL ARGS OR CDR ARGS OR NOT EQCAR(CAR ARGS,'LIST) OR (NN := (N := LENGTH CDAR ARGS))>MAXNARGS THEN RETURN !&CALL('APPLY,EXP,STATUS); ARGS := REVERSE (FN . REVERSE CDAR ARGS); ARGS := !&COMLIS ARGS; !&STORE1(); FN := CAR ARGS; ARGS := CDR ARGS; IF STATUS>0 THEN !&CLRREGS(); WHILE N>0 DO <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS); ARGS := CDR ARGS; N := N - 1>>; !&ATTACH ('!*LINKF . (NN . !&LOCATE FN)); REGS := LIST (1 . NIL) END; %PUT('APPLY,'COMPFN,'!&COMAPPLY); %Only works for compiled functions; SYMBOLIC PROCEDURE !&COMRPLAC(EXP,STATUS); BEGIN SCALAR FN,X,Y; FN := IF CAR EXP EQ 'RPLACA THEN '!*RPLACA ELSE '!*RPLACD; EXP := !&COMLIS CDR EXP; Y := IF CAR EXP = '(QUOTE NIL) THEN NIL ELSE IF Y := !&RASSOC(CAR EXP,REGS) THEN CAR Y ELSE <<!&LREG('TT,CAR EXP,CDR EXP,STATUS); 'TT>>; IF STATUS<2 THEN <<IF Y=1 THEN !&LREG(Y := 'TT,CAR EXP,CDR EXP,STATUS); !&LREG1(CADR EXP,STATUS)>>; !&ATTACH (FN . (Y . !&LOCATE CADR EXP)) END; PUT('RPLACA,'COMPFN,'!&COMRPLAC); PUT('RPLACD,'COMPFN,'!&COMRPLAC); COMMENT Additional c-macros defined in PDP-10 implementation; SYMBOLIC PROCEDURE !*LINKF(NARGS,FNEXP); !*LOADEXP(NARGS,FNEXP,'(CALLF!@ . CALLF)); SYMBOLIC PROCEDURE !*RPLACA(REG,EXP); !*LOADEXP!*(REG,EXP,'((RPLCA!@ . RPLCA) . (HRRZS!@ . HRRZS))); SYMBOLIC PROCEDURE !*RPLACD(REG,EXP); !*LOADEXP!*(REG,EXP,'((RPLCD!@ . RPLCD) . (HLLZS!@ . HLLZS))); SYMBOLIC PROCEDURE !*LOADEXP!*(REG,EXP,OPS); IF REG THEN IF NUMBERP REG AND REG>5 THEN NCONC(!*LOAD('R,REG),!*LOADEXP('R,EXP,CAR OPS)) ELSE !*LOADEXP(REG,EXP,CAR OPS) ELSE !*LOADEXP(0,EXP,CDR OPS); FLAG('(!*LINKF !*RPLACA !*RPLACD),'MC); FLAG('(LINKF),'UNKNOWNUSE); COMMENT Open coded functions in this version; PUT('CAR,'OPEN,'(LAMBDA (X Y) ((HLRZ X 0 Y)))); PUT('CDR,'OPEN,'(LAMBDA (X Y) ((HRRZ X 0 Y)))); FLAG('(RPLACA RPLACD),'NOPENR); PUT('CAR,'ANYREG,'(LAMBDA (X Y) ((HLRZ!@ X . Y)))); PUT('CDR,'ANYREG,'(LAMBDA (X Y) ((HRRZ!@ X . Y)))); COMMENT PDP-10 interpreter function register use; FLAG( '( CAR CDR RPLACA RPLACD ATOM CLOSE CODEP CONSTANTP EJECT EQ FIXP FLOATP GET IDP LINELENGTH LPOSN NCONS NOT NUMBERP NULL PAGELENGTH PAIRP POSN REMPROP REVERSE STRINGP TERPRI VECTORP XCONS UPBV !*LAMBIND!* !*PROGBIND!* !*SPECRSTR!* BIGP INUMP RECLAIM TYO UNTYI ),'ONEREG); FLAG('( ABS ATSOC CONS FIX FLOAT GETD GETV LENGTH PRINC PUTV PUT REMD !*BOX ASCII BINI BINO DELIMITER EXAMINE EXCISE FILEP GCTIME IGNORE LETTER MKCODE NUMVAL RDSLSH SCANSET SETPCHAR SPEAK TIME ),'TWOREG); COMMENT Code for counting macro execution use; FLUID '(MCPROCS !*COUNTMC); SYMBOLIC PROCEDURE RESETMC U; BEGIN SCALAR L; !*COUNTMC := U; FOR EACH L IN MCPROCS DO <<SET(L,CDR (131072 + 1)); % FWD of a fresh FIXNUM; DEPOSIT(!*BOX EVAL L,0); % FWD = numeric 0 now; PUT(L,'MCCOUNT,0)>> END; SYMBOLIC PROCEDURE COUNTMC L; LIST LIST(118800,0,LIST('FLUID,L)); SYMBOLIC PROCEDURE PRINTMC; BEGIN SCALAR SM; SM := 0; PRIN2 "DYNAMIC COUNT:"; TERPRI(); FOR EACH L IN MCPROCS DO <<PRIN2 L; PRIN2 " "; SM := PRINT (CAR 131072 . EVAL L) + SM>>; PRIN2 "DYNAMIC TOTAL: "; PRINT SM; TERPRI(); PRIN2 "STATIC COUNT:"; TERPRI(); SM := 0; FOR EACH L IN MCPROCS DO <<PRIN2 L; PRIN2 " "; SM := PRINT GET(L,'MCCOUNT) + SM>>; PRIN2 "STATIC TOTAL: "; PRINT SM END; MCPROCS := '(!*ALLOC !*DEALLOC !*ENTRY !*EXIT !*LOAD !*STORE !*JUMP !*JUMPE !*JUMPN !*JUMPT !*JUMPNIL !*LBL !*LAMBIND !*PROGBIND !*FREERSTR !*LINK !*LINKF !*LINKE !*RPLACA !*RPLACD); RESETMC NIL; SYMBOLIC PROCEDURE LAPPRI U; BEGIN A: IF NULL U THEN RETURN NIL; PRIN1 CAR U; U := CDR U; IF NULL U THEN RETURN NIL; SPACES2 24; PRIN1 CAR U; U := CDR U; IF NULL U THEN RETURN NIL; SPACES2 48; PRIN1 CAR U; TERPRI(); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE SPACES2 N; <<IF POSN()>N THEN TERPRI(); SPACES(N-POSN())>>; END; |
Added r30/complr.fap version [abd1e7988d].
cannot compute difference between binary files
Added r30/complr.red version [fca8972bb7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT ************************************************************** ********************************************************************** THE STANDARD LISP COMPILER ********************************************************************** *********************************************************************; COMMENT machine dependent parts are in a separate file; COMMENT these include the macros described below and, in addition, an auxiliary function !&MKFUNC which is required to pass functional arguments (input as FUNCTION <func>) to the loader. In most cases, !&MKFUNC may be defined as MKQUOTE; COMMENT global flags used in this compiler: !*MODULE indicates block compilation (a future extension of this compiler) !*MSG indicates whether certain messages should be printed !*NOLINKE if ON inhibits use of !*LINKE c-macro !*ORD if ON forces left-to-right argument evaluation !*PLAP if ON causes LAP output to be printed !*R2I if ON causes recursion removal where possible; GLOBAL '(!*MODULE !*MSG !*NOLINKE !*ORD !*PLAP !*R2I); COMMENT global variables used: ERFG!* used by REDUCE to control error recovery MAXNARGS maximum number of arguments permitted; GLOBAL '(ERFG!* MAXNARGS); MAXNARGS := 15; %Standard LISP limit; COMMENT fluid variables used: ALSTS alist of fluid parameters CODELIST code being built CONDTAIL simulated stack of position in the tail of a COND DFPRINT!* name of special definition process (or NIL) EXIT label for !*EXIT jump FLAGG used in !&COMTST, and in !&FIXREST FREELST list of free variables with bindings GOLIST storage map for jump labels IREGS initial register contents IREGS1 temporary placeholder for IREGS for branch compilation JMPLIST list of locations in CODELIST of transfers LBLIST list of label words LLNGTH cell whose CAR is length of frame NAME name of function being currently compiled NARG number of arguments in function REGS known current contents of registers as an alist with elements of form (<reg> . <contents>) REGS1 temporary placeholder for REGS during branch compilation SLST association list for stores which have not yet been used STLST list of active stores in function STOMAP storage map for variables SWITCH boolean expression value flag - keeps track of NULLs; FLUID '(ALSTS CODELIST CONDTAIL DFPRINT!* EXIT FLAGG FREELST GOLIST IREGS IREGS1 JMPLIST LBLIST LLNGTH NAME NARG REGS REGS1 SLST STLST STOMAP SWITCH); COMMENT c-macros used in this compiler; COMMENT The following c-macros must NOT change regs 1-MAXNARGS: !*ALLOC n allocate new stack frame of n words !*DEALLOC n deallocate above frame !*ENTRY name type nargs entry point to function name of type type with nargs args !*EXIT exit to previously saved return address !*STORE reg floc store contents of reg (or NIL) in floc !*JUMP adr unconditional jump !*JUMPC adr exp type jump to adr if exp is of type type !*JUMPNC adr exp type jump to adr if exp is not of type type !*JUMPNIL adr jump on register 1 eq to NIL !*JUMPT adr jump on register 1 not eq to NIL !*JUMPE adr exp jump on register 1 eq to exp !*JUMPN adr exp jump on register 1 not eq to exp !*LBL adr define label !*LAMBIND regs alst bind free lambda vars in alst currently in regs !*PROGBIND alst bind free prog vars in alst !*FREERSTR alst unbind free variables in alst COMMENT the following c-macro must only change specific register being loaded: !*LOAD reg exp load exp into reg; COMMENT the following c-macros do not protect regs 1-MAXNARGS: !*LINK fn type nargs link to fn of type type with nargs args !*LINKE fn type nargs n link to fn of type type with nargs args and exit removing frame of n words !*CODE list this macro allows for the inclusion of a list of c-macro expressions (or even explicit assembly language) in a function definition; FLAG('(!*ALLOC !*DEALLOC !*ENTRY !*EXIT !*STORE !*JUMP !*JUMPC !*JUMPNC !*JUMPNIL !*JUMPT !*JUMPE !*JUMPN !*LBL !*LAMBIND !*PROGBIND !*FREERSTR !*LOAD !*LINK !*LINKE !*CODE), 'MC); COMMENT general functions used in this compiler; SYMBOLIC PROCEDURE ATSOC(U,V); IF NULL V THEN NIL ELSE IF U EQ CAAR V THEN CAR V ELSE ATSOC(U,CDR V); SYMBOLIC PROCEDURE EQCAR(U,V); NOT ATOM U AND CAR U EQ V; SYMBOLIC PROCEDURE LPRI U; IF ATOM U THEN LPRI LIST U ELSE FOR EACH X IN U DO <<PRIN2 X; PRIN2 " ">>; SYMBOLIC PROCEDURE LPRIE U; <<LPRI ("*****" . IF ATOM U THEN LIST U ELSE U); ERFG!* := T; TERPRI()>>; SYMBOLIC PROCEDURE LPRIM U; IF !*MSG THEN <<TERPRI(); LPRI ("***" . IF ATOM U THEN LIST U ELSE U); TERPRI()>>; SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U); SYMBOLIC PROCEDURE REVERSIP U; BEGIN SCALAR X,Y; WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>; RETURN Y END; SYMBOLIC PROCEDURE RPLACW(A,B); RPLACA(RPLACD(A,CDR B),CAR B); COMMENT the following two functions are used by the CONS open coding. They should be defined in the interpreter if possible. They should only be compiled without a COMPFN for CONS; SYMBOLIC PROCEDURE NCONS U; U . NIL; SYMBOLIC PROCEDURE XCONS(U,V); V . U; COMMENT Top level compiling functions; SYMBOLIC PROCEDURE COMPILE X; BEGIN SCALAR EXP; FOR EACH Y IN X DO IF NULL (EXP := GETD Y) THEN LPRIM LIST(Y,'UNDEFINED) ELSE COMPD(Y,CAR EXP,CDR EXP); RETURN X END; SYMBOLIC PROCEDURE COMPD(NAME,TYPE,EXP); BEGIN IF NOT FLAGP(TYPE,'COMPILE) THEN <<LPRIM LIST("UNCOMPILABLE FUNCTION",NAME,"OF TYPE", TYPE); RETURN NIL>>; IF NOT ATOM EXP THEN IF !*MODULE THEN MODCMP(NAME,TYPE,EXP) ELSE IF DFPRINT!* THEN APPLY(DFPRINT!*, LIST IF TYPE EQ 'EXPR THEN 'DE . (NAME . CDR EXP) ELSE IF TYPE EQ 'FEXPR THEN 'DF . (NAME . CDR EXP) ELSE IF TYPE EQ 'MACRO THEN 'DM . (NAME . CDR EXP) ELSE LIST('PUTD,MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE EXP)) ELSE BEGIN SCALAR X; IF FLAGP(TYPE,'COMPILE) THEN PUT(NAME,'CFNTYPE,LIST TYPE); X := LIST('!*ENTRY,NAME,TYPE,LENGTH CADR EXP) . !&COMPROC(EXP, IF FLAGP(TYPE,'COMPILE) THEN NAME); IF !*PLAP THEN FOR EACH Y IN X DO PRINT Y; LAP X; %this is the entry point to the assembler. LAP %must remove any preexisting function definition; IF (X := GET(NAME,'CFNTYPE)) AND EQCAR(GETD NAME,CAR X) THEN REMPROP(NAME,'CFNTYPE) END; RETURN NAME END; FLAG('(EXPR FEXPR MACRO),'COMPILE); SYMBOLIC PROCEDURE !&COMPROC(EXP,NAME); %compiles a function body, returning the generated LAP; BEGIN SCALAR CODELIST,FLAGG,IREGS,IREGS1,JMPLIST,LBLIST, LLNGTH,REGS,REGS1,ALSTS,EXIT,SLST,STLST,STOMAP, CONDTAIL,FREELST, SWITCH; INTEGER NARG; LLNGTH := LIST 1; NARG := 0; EXIT := !&GENLBL(); STOMAP := '((NIL 1)); CODELIST := LIST ('!*ALLOC . LLNGTH); EXP := !&PASS1 EXP; IF LENGTH CADR EXP>MAXNARGS THEN LPRIE LIST("TOO MANY ARGS FOR COMPILER IN",NAME); FOR EACH Z IN CADR EXP DO <<!&FRAME Z; NARG := NARG + 1; IF NOT NONLOCAL Z THEN IREGS := NCONC(IREGS, LIST LIST(NARG,Z)); REGS := NCONC(REGS,LIST LIST(NARG,Z))>>; IF NULL REGS THEN REGS := LIST (1 . NIL); ALSTS := !&FREEBIND(CADR EXP,T); !&PASS2 CADDR EXP; !&FREERST(ALSTS,0); !&PASS3(); RPLACA(LLNGTH,1 - CAR LLNGTH); RETURN CODELIST END; SYMBOLIC PROCEDURE NONLOCAL X; IF FLUIDP X THEN 'FLUID ELSE IF GLOBALP X THEN 'GLOBAL ELSE NIL; COMMENT Pass 1 of the compiler; SYMBOLIC PROCEDURE !&PASS1 EXP; !&PA1(EXP,NIL); SYMBOLIC PROCEDURE !&PA1(U,VBLS); BEGIN SCALAR X; RETURN IF ATOM U THEN IF CONSTANTP U OR U MEMQ '(NIL T) THEN MKQUOTE U ELSE IF U MEMQ VBLS THEN U ELSE IF NONLOCAL U THEN U ELSE <<MKNONLOCAL U; U>> ELSE IF NOT ATOM CAR U THEN !&PA1(CAR U,VBLS) . !&PALIS(CDR U,VBLS) ELSE IF X := GET(CAR U,'PA1FN) THEN APPLY(X,LIST(U,VBLS)) ELSE IF (X := GETD CAR U) AND CAR X EQ 'MACRO AND NOT GET(CAR U,'COMPFN) THEN !&PA1(APPLY(CDR X,LIST U),VBLS) ELSE IF X := GET(CAR U,'CMACRO) THEN !&PA1(SUBLIS(PAIR(CADR X,CDR U),CADDR X),VBLS) ELSE IF !&CFNTYPE CAR U EQ 'FEXPR AND NOT GET(CAR U,'COMPFN) THEN LIST(CAR U,MKQUOTE CDR U) ELSE IF CAR U MEMQ VBLS OR FLUIDP CAR U THEN LIST('APPLY,CAR U,!&PALIST(CDR U,VBLS)) ELSE CAR U . !&PALIS(CDR U,VBLS) END; SYMBOLIC PROCEDURE !&PAIDEN(U,VBLS); U; PUT('GO,'PA1FN,'!&PAIDEN); PUT('QUOTE,'PA1FN,'!&PAIDEN); PUT('CODE,'PA1FN,'!&PAIDEN); SYMBOLIC PROCEDURE !&PACOND(U,VBLS); 'COND . FOR EACH Z IN CDR U COLLECT LIST(!&PA1(CAR Z,VBLS), !&PA1(!&MKPROGN CDR Z,VBLS)); PUT('COND,'PA1FN,'!&PACOND); SYMBOLIC PROCEDURE !&PAFUNC(U,VBLS); IF ATOM CADR U THEN !&MKFUNC CADR U ELSE !&MKFUNC COMPD(!&MKNAM NAME,'EXPR,CADR U); PUT('FUNCTION,'PA1FN,'!&PAFUNC); SYMBOLIC PROCEDURE !&PALAMB(U,VBLS); 'LAMBDA . LIST(CADR U,!&PA1(!&MKPROGN CDDR U,APPEND(CADR U,VBLS))); PUT('LAMBDA,'PA1FN,'!&PALAMB); SYMBOLIC PROCEDURE !&PALIST(U,VBLS); 'LIST . !&PALIS(U,VBLS); SYMBOLIC PROCEDURE !&PAPROG(U,VBLS); 'PROG . (CADR U . !&PAPROG1(CDDR U,APPEND(CADR U,VBLS))); SYMBOLIC PROCEDURE !&PAPROG1(U,VBLS); FOR EACH X IN U COLLECT IF ATOM X THEN X ELSE !&PA1(X,VBLS); PUT('PROG,'PA1FN,'!&PAPROG); SYMBOLIC PROCEDURE !&PALIS(U,VBLS); FOR EACH X IN U COLLECT !&PA1(X,VBLS); SYMBOLIC PROCEDURE MKNONLOCAL U; <<LPRIM LIST(U,"declared fluid"); FLUID LIST U; LIST('FLUID,U)>>; SYMBOLIC PROCEDURE !&MKNAM U; %generates unique name for auxiliary function in U; INTERN COMPRESS APPEND(EXPLODE U,EXPLODE GENSYM()); SYMBOLIC PROCEDURE !&MKPROGN U; IF NULL U OR CDR U THEN 'PROGN . U ELSE CAR U; COMMENT CMACRO definitions for some functions; COMMENT We do not expand CAAAAR and similar functions, since fewer instructions are generated without open coding; DEFLIST('((CAAR (LAMBDA (U) (CAR (CAR U)))) (CADR (LAMBDA (U) (CAR (CDR U)))) (CDAR (LAMBDA (U) (CDR (CAR U)))) (CDDR (LAMBDA (U) (CDR (CDR U)))) (CAAAR (LAMBDA (U) (CAR (CAR (CAR U))))) (CAADR (LAMBDA (U) (CAR (CAR (CDR U))))) (CADAR (LAMBDA (U) (CAR (CDR (CAR U))))) (CADDR (LAMBDA (U) (CAR (CDR (CDR U))))) (CDAAR (LAMBDA (U) (CDR (CAR (CAR U))))) (CDADR (LAMBDA (U) (CDR (CAR (CDR U))))) (CDDAR (LAMBDA (U) (CDR (CDR (CAR U))))) (CDDDR (LAMBDA (U) (CDR (CDR (CDR U))))) (NOT (LAMBDA (U) (NULL U)))),'CMACRO); COMMENT Pass 2 of the compiler; SYMBOLIC PROCEDURE !&PASS2 EXP; !&COMVAL(EXP,0); SYMBOLIC PROCEDURE !&COMVAL(EXP,STATUS); %computes code for value of EXP; IF !&ANYREG(EXP,NIL) THEN IF STATUS>1 THEN NIL ELSE !&LREG1(EXP,STATUS) ELSE !&COMVAL1(EXP,STOMAP,STATUS); SYMBOLIC PROCEDURE !&COMVAL1(EXP,STOMAP,STATUS); BEGIN SCALAR X; IF ATOM EXP THEN IF STATUS<2 THEN !&LREG1(EXP,STATUS) ELSE NIL ELSE IF NOT ATOM CAR EXP THEN IF CAAR EXP EQ 'LAMBDA THEN !&COMPLY(CAR EXP,CDR EXP,STATUS) ELSE LPRIE LIST("INVALID FUNCTION",CAR EXP) ELSE IF X := GET(CAR EXP,'COMPFN) THEN APPLY(X,LIST(EXP,STATUS)) ELSE IF !*R2I AND CAR EXP EQ NAME AND STATUS=0 AND NULL FREELST THEN !&COMREC(EXP,STATUS) ELSE IF CAR EXP EQ 'LAMBDA THEN LPRIE LIST("INVALID USE OF LAMBDA IN FUNCTION",NAME) ELSE IF CAR EXP EQ '!*CODE THEN !&ATTACH EXP ELSE !&CALL(CAR EXP,CDR EXP,STATUS); RETURN NIL END; SYMBOLIC PROCEDURE !&ANYREG(U,V); %determines if U can be loaded in any register; %!*ORD = T means force correct order, unless safe; IF EQCAR(U,'QUOTE) THEN T ELSE (ATOM U OR IDP CAR U AND GET(CAR U,'ANYREG) AND !&ANYREG(CADR U,NIL)) AND (NULL !*ORD OR !&ANYREGL V); SYMBOLIC PROCEDURE !&ANYREGL U; NULL U OR !&ANYREG(CAR U,NIL) AND !&ANYREGL CDR U; SYMBOLIC PROCEDURE !&CALL(FN,ARGS,STATUS); !&CALL1(FN,!&COMLIS ARGS,STATUS); SYMBOLIC PROCEDURE !&CALL1(FN,ARGS,STATUS); %ARGS is reversed list of compiled arguments of FN; BEGIN INTEGER ARGNO; ARGNO := LENGTH ARGS; !&LOADARGS(ARGS,STATUS); !&ATTACH LIST('!*LINK,FN,!&CFNTYPE FN,ARGNO); IF FLAGP(FN,'ONEREG) THEN REGS := (1 . NIL) . CDR REGS ELSE IF FLAGP(FN,'TWOREG) THEN REGS := (1 . NIL) . DELASC(2,CDR REGS) ELSE REGS := LIST (1 . NIL) END; SYMBOLIC PROCEDURE DELASC(U,V); IF NULL V THEN NIL ELSE IF U=CAAR V THEN CDR V ELSE CAR V . DELASC(U,CDR V); SYMBOLIC PROCEDURE !&COMLIS EXP; %returns reversed list of compiled arguments; BEGIN SCALAR ACUSED,Y; WHILE EXP DO <<IF !&ANYREG(CAR EXP,CDR EXP) THEN Y := CAR EXP . Y ELSE <<IF ACUSED THEN !&STORE1(); !&COMVAL1(CAR EXP,STOMAP,1); ACUSED := GENSYM(); REGS := (1 . (ACUSED . CDAR REGS)) . CDR REGS; Y := ACUSED . Y>>; EXP := CDR EXP>>; RETURN Y END; SYMBOLIC PROCEDURE !&STORE1; %Marks contents of register 1 for storage; BEGIN SCALAR X; X := CADAR REGS; IF NULL X OR EQCAR(X,'QUOTE) THEN RETURN NIL ELSE IF NOT ATSOC(X,STOMAP) THEN !&FRAME X; !&STORE0(X,1) END; SYMBOLIC PROCEDURE !&COMPLY(FN,ARGS,STATUS); BEGIN SCALAR ALSTS,VARS; INTEGER I; VARS := CADR FN; !&LOADARGS(!&COMLIS ARGS,1); ARGS := !&REMVARL VARS; % The stores that were protected; I := 1; FOR EACH V IN VARS DO <<!&FRAME V; REGS := !&REPASC(I,V,REGS); I := I + 1>>; ALSTS := !&FREEBIND(VARS,T); %Old fluid values saved; I := 1; FOR EACH V IN VARS DO <<IF NOT NONLOCAL V THEN !&STORE0(V,I); I := I + 1>>; !&COMVAL(CADDR FN,STATUS); !&FREERST(ALSTS,STATUS); !&RSTVARL(VARS,ARGS) END; SYMBOLIC PROCEDURE !&COMREC(EXP,STATUS); BEGIN SCALAR X,Z; !&LOADARGS(!&COMLIS CDR EXP,STATUS); Z := CODELIST; IF NULL CDR Z THEN LPRIE LIST("CIRCULAR DEFINITION FOR",CAR EXP); WHILE CDDR Z DO Z := CDR Z; IF CAAR Z EQ '!*LBL THEN X := CDAR Z ELSE <<X := !&GENLBL(); RPLACD(Z,LIST('!*LBL . X,CADR Z))>>; !&ATTJMP X END; SYMBOLIC PROCEDURE !&LOADARGS(ARGS,STATUS); BEGIN INTEGER N; N := LENGTH ARGS; IF N>MAXNARGS THEN LPRIE LIST("TOO MANY ARGUMENTS IN",NAME); IF STATUS>0 THEN !&CLRREGS(); WHILE ARGS DO <<!&LREG(N,CAR ARGS,CDR ARGS,STATUS); N := N - 1; ARGS := CDR ARGS>> END; SYMBOLIC PROCEDURE !&LOCATE X; BEGIN SCALAR Y,VTYPE; IF EQCAR(X,'QUOTE) THEN RETURN LIST X ELSE IF Y := !&RASSOC(X,REGS) THEN RETURN LIST CAR Y ELSE IF NOT ATOM X THEN RETURN LIST (CAR X . !&LOCATE CADR X) ELSE IF VTYPE := NONLOCAL X THEN RETURN LIST LIST(VTYPE,X); WHILE Y := ATSOC(X,SLST) DO SLST := DELETE(Y,SLST); RETURN IF Y := ATSOC(X,STOMAP) THEN CDR Y ELSE LIST MKNONLOCAL X END; SYMBOLIC PROCEDURE !&LREG(REG,U,V,STATUS); BEGIN SCALAR X,Y; IF (X := ASSOC(REG,REGS)) AND U MEMBER CDR X THEN RETURN NIL ELSE IF (Y := ASSOC(REG,IREGS)) AND (STATUS>0 OR !&MEMLIS(CADR Y,V)) THEN <<!&STORE0(CADR Y,REG); IREGS := DELETE(Y,IREGS)>>; !&ATTACH ('!*LOAD . (REG . !&LOCATE U)); REGS := !&REPASC(REG,U,REGS) END; SYMBOLIC PROCEDURE !&LREG1(X,STATUS); !&LREG(1,X,NIL,STATUS); COMMENT Functions for handling non-local variables; SYMBOLIC PROCEDURE !&FREEBIND(VARS,LAMBP); %bind FLUID variables in lambda or prog lists; %LAMBP is true for LAMBDA, false for PROG; BEGIN SCALAR FALST,FREGS,X,Y; INTEGER I; I := 1; FOR EACH X IN VARS DO <<IF FLUIDP X THEN <<FALST := (X . !&GETFFRM X) . FALST; FREGS := I . FREGS>> ELSE IF GLOBALP X THEN LPRIE LIST("CANNOT BIND GLOBAL ", X); I := I + 1>>; IF NULL FALST THEN RETURN NIL; IF LAMBP THEN !&ATTACH LIST('!*LAMBIND,FREGS,FALST) ELSE !&ATTACH LIST('!*PROGBIND,FALST); RETURN FALST END; SYMBOLIC PROCEDURE !&FREERST(ALSTS,STATUS); %restores FLUID variables; IF ALSTS THEN !&ATTACH LIST('!*FREERSTR,ALSTS); SYMBOLIC PROCEDURE !&ATTACH U; CODELIST := U . CODELIST; SYMBOLIC PROCEDURE !&STORE0(U,REG); %marks expression U in register REG for storage; BEGIN SCALAR X; X := '!*STORE . (REG . !&GETFRM U); STLST := X . STLST; !&ATTACH X; IF ATOM U THEN <<!&CLRSTR U; SLST := (U . CODELIST) . SLST>> END; SYMBOLIC PROCEDURE !&CLRSTR VAR; %removes unneeded stores; BEGIN SCALAR X; IF CONDTAIL THEN RETURN NIL; X := ATSOC(VAR,SLST); IF NULL X THEN RETURN NIL; STLST := !&DELEQ(CADR X,STLST); SLST := !&DELEQ(X,SLST); RPLACA(CADR X,'!*NOOP) END; COMMENT Functions for general tests; SYMBOLIC PROCEDURE !&COMTST(EXP,LABL); %compiles boolean expression EXP. %If EXP has the same value as SWITCH then branch to LABL, %otherwise fall through; %REGS/IREGS are active registers for fall through, %REGS1/IREGS1 for branch; BEGIN SCALAR X; WHILE EQCAR(EXP,'NULL) DO <<SWITCH := NOT SWITCH; EXP := CADR EXP>>; IF NOT ATOM EXP AND ATOM CAR EXP AND (X := GET(CAR EXP,'COMTST)) THEN APPLY(X,LIST(EXP,LABL)) ELSE <<IF EXP='(QUOTE T) THEN IF SWITCH THEN !&ATTJMP LABL ELSE FLAGG := T ELSE <<!&COMVAL(EXP,1); !&ATTACH LIST(IF SWITCH THEN '!*JUMPT ELSE '!*JUMPNIL,CAR LABL); !&ADDJMP CODELIST>>; REGS1 := REGS; IREGS1 := IREGS>>; IF EQCAR(CAR CODELIST,'!*JUMPT) THEN REGS := (1 . ('(QUOTE NIL) . CDAR REGS)) . CDR REGS ELSE IF EQCAR(CAR CODELIST,'!*JUMPNIL) THEN REGS1 := (1 . ('(QUOTE NIL) . CDAR REGS1)) . CDR REGS1 END; COMMENT Specific function open coding; SYMBOLIC PROCEDURE !&COMANDOR(EXP,STATUS); BEGIN SCALAR FN,LABL,IREGSL,REGSL; FN := CAR EXP EQ 'AND; LABL := !&GENLBL(); IF STATUS>1 THEN BEGIN SCALAR REGS1; !&TSTANDOR(EXP,LABL); REGS := !&RMERGE2(REGS,REGS1) END ELSE BEGIN IF STATUS>0 THEN !&CLRREGS(); EXP := CDR EXP; WHILE EXP DO <<!&COMVAL(CAR EXP,IF CDR EXP THEN 1 ELSE STATUS); %to allow for recursion on last entry; IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL; IF CDR EXP THEN <<!&ATTACH LIST(IF FN THEN '!*JUMPNIL ELSE '!*JUMPT,CAR LABL); !&ADDJMP CODELIST>>; EXP := CDR EXP>>; IREGS := !&RMERGE IREGSL; REGS := !&RMERGE REGSL END; !&ATTLBL LABL END; SYMBOLIC PROCEDURE !&TSTANDOR(EXP,LABL); BEGIN SCALAR FLG,FLG1,FN,LAB2,REGSL,REGS1L,TAILP; %FLG is initial switch condition; %FN is appropriate AND/OR case; %FLG1 determines appropriate switching state; FLG := SWITCH; SWITCH := NIL; FN := CAR EXP EQ 'AND; FLG1 := FLG EQ FN; EXP := CDR EXP; LAB2 := !&GENLBL(); !&CLRREGS(); WHILE EXP DO <<SWITCH := NIL; IF NULL CDR EXP AND FLG1 THEN <<IF FN THEN SWITCH := T; !&COMTST(CAR EXP,LABL); REGSL := REGS . REGSL; REGS1L := REGS1 . REGS1L>> ELSE <<IF NOT FN THEN SWITCH := T; IF FLG1 THEN <<!&COMTST(CAR EXP,LAB2); REGSL := REGS1 . REGSL; REGS1L := REGS . REGS1L>> ELSE <<!&COMTST(CAR EXP,LABL); REGSL := REGS . REGSL; REGS1L := REGS1 . REGS1L>>>>; IF NULL TAILP THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; EXP := CDR EXP>>; !&ATTLBL LAB2; REGS := IF NOT FLG1 THEN CAR REGSL ELSE !&RMERGE REGSL; REGS1 := IF FLG1 THEN CAR REGS1L ELSE !&RMERGE REGS1L; IF TAILP THEN CONDTAIL := CDR CONDTAIL; SWITCH := FLG END; PUT('AND,'COMPFN,'!&COMANDOR); PUT('OR,'COMPFN,'!&COMANDOR); PUT('AND,'COMTST,'!&TSTANDOR); PUT('OR,'COMTST,'!&TSTANDOR); SYMBOLIC PROCEDURE !&COMCOND(EXP,STATUS); %compiles conditional expressions; %registers REGS and IREGS are set for dropping through, %REGS1 and IREGS1 are set for a branch; BEGIN SCALAR IREGS1,REGS1,FLAGG,SWITCH,LAB1,LAB2,REGSL,IREGSL,TAILP; EXP := CDR EXP; LAB1 := !&GENLBL(); IF STATUS>0 THEN !&CLRREGS(); FOR EACH X IN EXP DO <<LAB2 := !&GENLBL(); SWITCH := NIL; IF CDR X THEN !&COMTST(CAR X,LAB2) %update CONDTAIL; ELSE <<!&COMVAL(CAR X,1); !&ATTACH LIST('!*JUMPNIL,CAR LAB2); !&ADDJMP CODELIST; IREGS1 := IREGS; REGS1 := (1 . '(QUOTE NIL) . CDAR REGS) . CDR REGS>>; IF NULL TAILP THEN <<CONDTAIL := NIL . CONDTAIL; TAILP := T>>; !&COMVAL(CADR X,STATUS); % Branch code; %test if need jump to LAB1; IF NOT !&TRANSFERP CAR CODELIST THEN <<!&ATTJMP LAB1; IREGSL := IREGS . IREGSL; REGSL := REGS . REGSL>>; REGS := REGS1; %restore register status for next iteration; IREGS := IREGS1; IREGS1 := NIL; %we do not need to set REGS1 to NIL since all !&COMTSTs %are required to set it; !&ATTLBL LAB2>>; IF NULL FLAGG AND STATUS<2 THEN <<!&LREG1('(QUOTE NIL),STATUS); IREGS := !&RMERGE1(IREGS,IREGSL); REGS := !&RMERGE1(REGS,REGSL)>> ELSE IF REGSL THEN <<IREGS := !&RMERGE1(IREGS,IREGSL); REGS := !&RMERGE1(REGS,REGSL)>>; !&ATTLBL LAB1; IF TAILP THEN CONDTAIL := CDR CONDTAIL END; SYMBOLIC PROCEDURE !&RMERGE U; IF NULL U THEN NIL ELSE !&RMERGE1(CAR U,CDR U); SYMBOLIC PROCEDURE !&RMERGE1(U,V); IF NULL V THEN U ELSE !&RMERGE1(!&RMERGE2(U,CAR V),CDR V); SYMBOLIC PROCEDURE !&RMERGE2(U,V); IF NULL U OR NULL V THEN NIL ELSE (LAMBDA X; IF X THEN (CAAR U . XN(CDAR U,CDR X)) . !&RMERGE2(CDR U,DELETE(X,V)) ELSE !&RMERGE2(CDR U,V)) ASSOC(CAAR U,V); FLAG('(!*JUMP !*LINKE ERROR),'TRANSFER); PUT('COND,'COMPFN,'!&COMCOND); SYMBOLIC PROCEDURE !&COMCONS(EXP,STATUS); IF NULL (EXP := CDR EXP) OR NULL CDR EXP OR CDDR EXP THEN LPRIE "MISMATCH OF ARGUMENTS" ELSE IF CADR EXP='(QUOTE NIL) THEN !&CALL('NCONS,LIST CAR EXP,STATUS) ELSE IF EQCAR(!&RASSOC(CADR EXP,REGS),1) AND !&ANYREG(CAR EXP,NIL) THEN !&CALL1('XCONS,!&COMLIS REVERSE EXP,STATUS) ELSE IF !&ANYREG(CADR EXP,NIL) THEN !&CALL('CONS,EXP,STATUS) ELSE !&CALL1('XCONS,REVERSIP !&COMLIS EXP,STATUS); PUT('CONS,'COMPFN,'!&COMCONS); SYMBOLIC PROCEDURE !&COMGO(EXP,STATUS); <<!&CLRREGS(); IF STATUS>2 THEN <<!&ATTJMP !&GETLBL CADR EXP; SLST := NIL>> ELSE LPRIE LIST(EXP,"INVALID")>>; PUT('GO,'COMPFN,'!&COMGO); SYMBOLIC PROCEDURE !&COMLIST(EXP,STATUS); %we only support explicit functions up to 5 arguments here; BEGIN SCALAR M,N,FN; EXP := CDR EXP; M := MIN(MAXNARGS,5); N := LENGTH EXP; IF N=0 THEN !&LREG1('(QUOTE NIL),STATUS) ELSE IF N>M THEN !&COMVAL(!&COMLIST1 EXP,STATUS) ELSE !&CALL(IF N=1 THEN 'NCONS ELSE IF N=2 THEN 'LIST2 ELSE IF N=3 THEN 'LIST3 ELSE IF N=4 THEN 'LIST4 ELSE 'LIST5,EXP,STATUS) END; SYMBOLIC PROCEDURE LIST2(U,V); U . (V . NIL); SYMBOLIC PROCEDURE LIST3(U,V,W); U . (V . (W . NIL)); SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . (V . (W . (X . NIL))); SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . (V . (W . (X . (Y . NIL)))); SYMBOLIC PROCEDURE !&COMLIST1 EXP; IF NULL EXP THEN '(QUOTE NIL) ELSE LIST('CONS,CAR EXP,'LIST . CDR EXP); PUT('LIST,'COMPFN,'!&COMLIST); SYMBOLIC PROCEDURE !&PAMAP(U,VARS); IF EQCAR(CADDR U,'FUNCTION) THEN (LAMBDA X; LIST(CAR U, !&PA1(CADR U,VARS), MKQUOTE (IF ATOM X THEN X ELSE !&PA1(X,VARS)))) CADR CADDR U ELSE CAR U . !&PALIS(CDR U,VARS); PUT('MAP,'PA1FN,'!&PAMAP); PUT('MAPC,'PA1FN,'!&PAMAP); PUT('MAPCAN,'PA1FN,'!&PAMAP); PUT('MAPCAR,'PA1FN,'!&PAMAP); PUT('MAPCON,'PA1FN,'!&PAMAP); PUT('MAPLIST,'PA1FN,'!&PAMAP); SYMBOLIC PROCEDURE !&COMMAP(EXP,STATUS); BEGIN SCALAR BODY,FN,LAB1,LAB2,LAB3,TMP,MTYPE,RESULT,SLST1,VAR,X; BODY := CADR EXP; FN := CADDR EXP; LAB1 := !&GENLBL(); LAB2 := !&GENLBL(); MTYPE := IF CAR EXP MEMQ '(MAPCAR MAPLIST) THEN 'CONS ELSE IF CAR EXP MEMQ '(MAPCAN MAPCON) THEN <<LAB3 := !&GENLBL(); 'NCONC>> ELSE NIL; !&CLRREGS(); IF MTYPE THEN <<!&FRAME (RESULT := GENSYM()); IF NULL LAB3 THEN !&STORE0(RESULT,NIL)>>; !&FRAME (VAR := GENSYM()); !&COMVAL(BODY,1); REGS := LIST LIST(1,VAR); IF LAB3 THEN <<!&STORE0(VAR,1); !&FRAME (TMP := GENSYM()); !&COMVAL('(NCONS 'NIL),1); !&STORE0(RESULT,1); !&STORE0(TMP,1); !&LREG1(VAR,1)>>; !&ATTJMP LAB2; !&ATTLBL LAB1; !&STORE0(VAR,1); X := IF CAR EXP MEMQ '(MAP MAPCON MAPLIST) THEN VAR ELSE LIST('CAR,VAR); IF EQCAR(FN,'QUOTE) THEN FN := CADR FN; SLST1 := SLST; %to allow for store in function body; !&COMVAL(LIST(FN,X),IF MTYPE THEN 1 ELSE 3); IF MTYPE THEN <<IF LAB3 THEN <<!&ATTACH LIST('!*JUMPNIL,CAR LAB3); !&ADDJMP CODELIST; !&ATTACH '(!*LOAD 2 1); !&LREG1(TMP,1); !&STORE0(TMP,2); !&ATTACH '(!*LINK NCONC EXPR 2); !&ATTLBL LAB3>> ELSE <<!&LREG(2,RESULT,NIL,1); !&ATTACH '(!*LINK CONS EXPR 2); !&STORE0(RESULT,1)>>; REGS := LIST (1 . NIL)>>; SLST := XN(SLST,SLST1); !&COMVAL(LIST('CDR,VAR),1); !&ATTLBL LAB2; !&ATTACH LIST('!*JUMPT,CAR LAB1); !&ADDJMP CODELIST; IF MTYPE THEN !&COMVAL(LIST(IF LAB3 THEN 'CDR ELSE 'REVERSIP,RESULT),1) ELSE REGS := LIST LIST(1,MKQUOTE NIL) END; SYMBOLIC PROCEDURE XN(U,V); IF NULL U THEN NIL ELSE IF CAR U MEMBER V THEN CAR U . XN(CDR U,DELETE(CAR U,V)) ELSE XN(CDR U,V); PUT('MAP,'COMPFN,'!&COMMAP); PUT('MAPC,'COMPFN,'!&COMMAP); PUT('MAPCAN,'COMPFN,'!&COMMAP); PUT('MAPCAR,'COMPFN,'!&COMMAP); PUT('MAPCON,'COMPFN,'!&COMMAP); PUT('MAPLIST,'COMPFN,'!&COMMAP); SYMBOLIC PROCEDURE !&COMPROG(EXP,STATUS); %compiles program blocks; BEGIN SCALAR ALSTS,GOLIST,PG,PROGLIS,EXIT; INTEGER I; PROGLIS := CADR EXP; EXP := CDDR EXP; EXIT := !&GENLBL(); PG := !&REMVARL PROGLIS; %protect prog variables; FOR EACH X IN PROGLIS DO !&FRAME X; ALSTS := !&FREEBIND(PROGLIS,NIL); FOR EACH X IN PROGLIS DO IF NOT NONLOCAL X THEN !&STORE0(X,NIL); FOR EACH X IN EXP DO IF ATOM X THEN GOLIST := (X . !&GENLBL()) . GOLIST; WHILE EXP DO <<IF ATOM CAR EXP THEN <<!&CLRREGS(); !&ATTLBL !&GETLBL CAR EXP; REGS := LIST (1 . NIL)>> ELSE !&COMVAL(CAR EXP,IF STATUS>2 THEN 4 ELSE 3); IF NULL CDR EXP AND STATUS<2 AND (ATOM CAR EXP OR NOT CAAR EXP MEMQ '(GO RETURN)) THEN EXP := LIST '(RETURN (QUOTE NIL)) ELSE EXP := CDR EXP>>; !&ATTLBL EXIT; IF CDR !&FINDLBL EXIT THEN REGS := LIST (1 . NIL); !&FREERST(ALSTS,STATUS); !&RSTVARL(PROGLIS,PG) END; PUT('PROG,'COMPFN,'!&COMPROG); SYMBOLIC PROCEDURE !&REMVARL VARS; FOR EACH X IN VARS COLLECT !&REMVAR X; SYMBOLIC PROCEDURE !&REMVAR X; %removes references to variable X from IREGS and REGS %and protects SLST; <<!&REMSTORES X; !&PROTECT X>>; SYMBOLIC PROCEDURE !&REMSTORES X; BEGIN FOR EACH Y IN IREGS DO IF X EQ CADR Y THEN <<!&STORE0(CADR Y,CAR Y); IREGS := DELETE(Y,IREGS)>>; FOR EACH Y IN REGS DO WHILE X MEMBER CDR Y DO RPLACD(Y,!&DELEQ(X,CDR Y)) END; SYMBOLIC PROCEDURE !&PROTECT U; BEGIN SCALAR X; IF X := ATSOC(U,SLST) THEN SLST := !&DELEQ(X,SLST); RETURN X END; SYMBOLIC PROCEDURE !&RSTVARL(VARS,LST); FOR EACH X IN VARS DO <<!&REMSTORES X; !&CLRSTR X; !&UNPROTECT CAR LST; LST := CDR LST>>; SYMBOLIC PROCEDURE !&UNPROTECT VAL; %restores VAL to SLST; IF VAL THEN SLST := VAL . SLST; SYMBOLIC PROCEDURE !&COMPROGN(EXP,STATUS); BEGIN EXP := CDR EXP; IF NULL EXP THEN RETURN NIL; WHILE CDR EXP DO <<!&COMVAL(CAR EXP,IF STATUS<2 THEN 2 ELSE STATUS); EXP := CDR EXP>>; !&COMVAL(CAR EXP,STATUS) END; PUT('PROG2,'COMPFN,'!&COMPROGN); PUT('PROGN,'COMPFN,'!&COMPROGN); SYMBOLIC PROCEDURE !&COMRETURN(EXP,STATUS); <<IF STATUS<4 OR NOT !&ANYREG(CADR EXP,NIL) THEN !&LREG1(CAR !&COMLIS LIST CADR EXP,STATUS); !&ATTJMP EXIT>>; PUT('RETURN,'COMPFN,'!&COMRETURN); SYMBOLIC PROCEDURE !&COMSETQ(EXP,STATUS); BEGIN SCALAR X; EXP := CDR EXP; IF STATUS>1 AND (NULL CADR EXP OR CADR EXP='(QUOTE NIL)) THEN !&STORE2(CAR EXP,NIL) ELSE <<!&COMVAL(CADR EXP,1); !&STORE2(CAR EXP,1); IF X := !&RASSOC(CAR EXP,IREGS) THEN IREGS := DELETE(X,IREGS); REGS := (1 . (CAR EXP . CDAR REGS)) . CDR REGS>> END; SYMBOLIC PROCEDURE !&REMSETVAR(U,V); %removes references to SETQ variable U from regs list V; IF NULL V THEN NIL ELSE (CAAR V . !&REMS1(U,CDAR V)) . !&REMSETVAR(U,CDR V); SYMBOLIC PROCEDURE !&REMS1(U,V); %removes references to SETQ variable U from list V; IF NULL V THEN NIL ELSE IF SMEMQ(U,CAR V) THEN !&REMS1(U,CDR V) ELSE CAR V . !&REMS1(U,CDR V); SYMBOLIC PROCEDURE SMEMQ(U,V); %true if atom U is a member of V at any level (excluding %quoted expressions); IF ATOM V THEN U EQ V ELSE IF CAR V EQ 'QUOTE THEN NIL ELSE SMEMQ(U,CAR V) OR SMEMQ(U,CDR V); SYMBOLIC PROCEDURE !&STORE2(U,V); BEGIN SCALAR VTYPE; REGS := !&REMSETVAR(U,REGS); IF VTYPE := NONLOCAL U THEN !&ATTACH LIST('!*STORE,V,LIST(VTYPE,U)) ELSE IF NOT ATSOC(U,STOMAP) THEN !&ATTACH LIST('!*STORE,V,MKNONLOCAL U) ELSE !&STORE0(U,V) END; PUT('SETQ,'COMPFN,'!&COMSETQ); COMMENT Specific test open coding; SYMBOLIC PROCEDURE !&COMEQ(EXP,LABL); BEGIN SCALAR U,V,W; U := CADR EXP; V := CADDR EXP; IF U MEMBER CDAR REGS THEN W := !&COMEQ1(V,U) ELSE IF V MEMBER CDAR REGS THEN W := !&COMEQ1(U,V) ELSE IF !&ANYREG(V,NIL) THEN <<!&COMVAL(U,1); W := !&LOCATE V>> ELSE IF !&ANYREG(U,LIST V) THEN <<!&COMVAL(V,1); W := !&LOCATE U>> ELSE <<U := !&COMLIS CDR EXP; W := !&LOCATE CADR U>>; !&ATTACH ((IF SWITCH THEN '!*JUMPE ELSE '!*JUMPN) . (CAR LABL . W)); IREGS1 := IREGS; REGS1 := REGS; !&ADDJMP CODELIST END; SYMBOLIC PROCEDURE !&COMEQ1(U,V); IF !&ANYREG(U,LIST V) THEN !&LOCATE U ELSE <<!&COMVAL(U,1); !&LOCATE V>>; PUT('EQ,'COMTST,'!&COMEQ); SYMBOLIC PROCEDURE !&TESTFN(EXP,LABL); %generates c-macros !*JUMPC and !*JUMPNC; BEGIN SCALAR X; IF NOT (X := !&RASSOC(CADR EXP,REGS)) THEN !&COMVAL(CADR EXP,1); !&CLRREGS(); !&ATTACH LIST(IF SWITCH THEN '!*JUMPC ELSE '!*JUMPNC, CAR LABL, IF X THEN CAR X ELSE 1,CAR EXP); REGS1 := REGS; !&ADDJMP CODELIST END; COMMENT Support functions; SYMBOLIC PROCEDURE !&MEMLIS(U,V); V AND (!&MEMB(U,CAR V) OR !&MEMLIS(U,CDR V)); SYMBOLIC PROCEDURE !&MEMB(U,V); IF ATOM V THEN U EQ V ELSE !&MEMB(U,CADR V); SYMBOLIC PROCEDURE !&RASSOC(U,V); IF NULL V THEN NIL ELSE IF U MEMBER CDAR V THEN CAR V ELSE !&RASSOC(U,CDR V); SYMBOLIC PROCEDURE !&REPASC(REG,U,V); IF NULL V THEN LIST LIST(REG,U) ELSE IF REG=CAAR V THEN LIST(REG,U) . CDR V ELSE CAR V . !&REPASC(REG,U,CDR V); SYMBOLIC PROCEDURE !&CLRREGS; %store deferred values in IREGS; WHILE IREGS DO <<!&STORE0(CADAR IREGS,CAAR IREGS); IREGS := CDR IREGS>>; SYMBOLIC PROCEDURE !&CFNTYPE FN; BEGIN SCALAR X; RETURN IF NOT ATOM FN THEN 'EXPR ELSE IF X := GET(FN,'CFNTYPE) THEN CAR X ELSE IF X := GETD FN THEN CAR X ELSE 'EXPR END; SYMBOLIC PROCEDURE !&GENLBL; BEGIN SCALAR L; L := GENSYM(); LBLIST := LIST L . LBLIST; RETURN LIST L END; SYMBOLIC PROCEDURE !&GETLBL LABL; BEGIN SCALAR X; X := ATSOC(LABL,GOLIST); IF NULL X THEN LPRIE LIST(LABL," - MISSING LABEL -"); RETURN CDR X END; SYMBOLIC PROCEDURE !&FINDLBL LBLST; ASSOC(CAR LBLST,LBLIST); SYMBOLIC PROCEDURE !&RECHAIN(OLBL,NLBL); % Fix OLBL to now point at NLBL; BEGIN SCALAR X,Y,USES; X := !&FINDLBL OLBL; Y := !&FINDLBL NLBL; RPLACA(OLBL,CAR NLBL); % FIX L VAR; USES := CDR X; % OLD USES; RPLACD(X,NIL); RPLACD(Y,APPEND(USES,CDR Y)); FOR EACH X IN USES DO RPLACA(CDR X,CAR NLBL) END; SYMBOLIC PROCEDURE !&MOVEUP U; IF CAADR U EQ '!*JUMP THEN <<JMPLIST := !&DELEQ(CDR U,JMPLIST); RPLACW(U,CDR U); JMPLIST := U . JMPLIST>> ELSE RPLACW(U,CDR U); SYMBOLIC PROCEDURE !&ATTLBL LBL; IF CAAR CODELIST EQ '!*LBL THEN !&RECHAIN(LBL,CDAR CODELIST) ELSE !&ATTACH ('!*LBL . LBL); SYMBOLIC PROCEDURE !&ATTJMP LBL; BEGIN IF CAAR CODELIST EQ '!*LBL THEN <<!&RECHAIN(CDAR CODELIST,LBL); CODELIST := CDR CODELIST>>; IF !&TRANSFERP CAR CODELIST THEN RETURN NIL; !&ATTACH ('!*JUMP . LBL); !&ADDJMP CODELIST END; SYMBOLIC PROCEDURE !&TRANSFERP X; FLAGP(IF CAR X EQ '!*LINK THEN CADR X ELSE CAR X,'TRANSFER); SYMBOLIC PROCEDURE !&ADDJMP CLIST; BEGIN SCALAR X; X := !&FINDLBL CDAR CLIST; RPLACD(X,CAR CLIST . CDR X); JMPLIST := CLIST . JMPLIST END; SYMBOLIC PROCEDURE !&REMJMP CLIST; BEGIN SCALAR X; X := !&FINDLBL CDAR CLIST; RPLACD(X,!&DELEQ(CAR CLIST,CDR X)); JMPLIST := !&DELEQ(CLIST,JMPLIST); !&MOVEUP CLIST END; SYMBOLIC PROCEDURE !&DELEQ(U,V); IF NULL V THEN NIL ELSE IF U EQ CAR V THEN CDR V ELSE CAR V . !&DELEQ(U,CDR V); SYMBOLIC PROCEDURE !&FRAME U; %allocates space for U in frame; BEGIN SCALAR Z; STOMAP := LIST(U,Z := CADAR STOMAP - 1) . STOMAP; IF Z<CAR LLNGTH THEN RPLACA(LLNGTH,Z) END; SYMBOLIC PROCEDURE !&GETFRM U; (LAMBDA X; IF X THEN CDR X ELSE LPRIE LIST("COMPILER ERROR: LOST VAR",U)) ATSOC(U,STOMAP); SYMBOLIC PROCEDURE !&GETFFRM U; BEGIN SCALAR X; X := !&GETFRM U; FREELST := X . FREELST; RETURN X END; COMMENT Pass 3 of the compiler (post code generation fixups); SYMBOLIC PROCEDURE !&PASS3; BEGIN SCALAR FLAGG; %remove spurious stores; FOR EACH J IN SLST DO <<STLST := !&DELEQ(CADR J,STLST); RPLACA(CADR J,'!*NOOP)>>; !&FIXCHAINS(); !&FIXLINKS(); !&FIXFRM(); !&ATTLBL EXIT; IF FLAGG THEN <<IF NOT !*NOLINKE AND CAAR CODELIST EQ '!*LBL AND CAADR CODELIST EQ '!*LINKE THEN RPLACA(CDR CODELIST, LIST('!*LINK,CADADR CODELIST, CADR CDADR CODELIST, CADDR CDADR CODELIST)); %removes unnecessary !*LINKE; !&ATTACH ('!*DEALLOC . LLNGTH); !&ATTACH LIST '!*EXIT>>; !&PEEPHOLEOPT(); !&FIXREST() END; SYMBOLIC PROCEDURE !&FIXCHAINS; BEGIN SCALAR EJMPS,EJMPS1,P,Q; %find any common chains of code; IF NOT CAR CODELIST='!*LBL . EXIT THEN !&ATTLBL EXIT; CODELIST := CDR CODELIST; IF NOT CAR CODELIST='!*JUMP . EXIT THEN !&ATTJMP EXIT; EJMPS := REVERSE JMPLIST; WHILE EJMPS DO BEGIN P := CAR EJMPS; EJMPS := CDR EJMPS; IF CAAR P EQ '!*JUMP THEN <<EJMPS1 := EJMPS; WHILE EJMPS1 DO IF CAR P=CAAR EJMPS1 AND CADR P=CADAR EJMPS1 THEN <<!&REMJMP P; !&FIXCHN(P,CDAR EJMPS1); EJMPS1 := NIL>> ELSE EJMPS1 := CDR EJMPS1>> END END; SYMBOLIC PROCEDURE !&FIXLINKS; %replace !*LINK by !*LINKE where appropriate; BEGIN SCALAR EJMPS,P,Q; EJMPS := JMPLIST; IF NOT !*NOLINKE THEN WHILE EJMPS DO BEGIN P := CAR EJMPS; Q := CDR P; EJMPS := CDR EJMPS; IF NOT CADAR P EQ CAR EXIT THEN RETURN NIL ELSE IF NOT CAAR P EQ '!*JUMP OR NOT CAAR Q EQ '!*LINK THEN RETURN FLAGG := T; RPLACW(CAR Q, '!*LINKE . (CADAR Q . (CADDAR Q . (CADR CDDAR Q . LLNGTH)))); !&REMJMP P END ELSE FLAGG := T END; SYMBOLIC PROCEDURE !&FINDBLK(U,LBL); IF NULL CDR U THEN NIL ELSE IF CAADR U EQ '!*LBL AND !&TRANSFERP CADDR U THEN U ELSE IF GET(CAADR U,'NEGJMP) AND CADADR U EQ LBL THEN U ELSE !&FINDBLK(CDR U,LBL); PUT('!*NOOP,'OPTFN,'!&MOVEUP); PUT('!*LBL,'OPTFN,'!&LBLOPT); SYMBOLIC PROCEDURE !&LBLOPT U; BEGIN SCALAR Z; IF CADAR U EQ CADADR U THEN RETURN !&REMJMP CDR U ELSE IF CAADR U EQ '!*JUMP AND (Z := GET(CAADDR U,'NEGJMP)) AND CADAR U EQ CADR CADDR U THEN RETURN <<Z := Z . (CADADR U . CDDR CADDR U); !&REMJMP CDR U; !&REMJMP CDR U; RPLACD(U,Z . (CADR U . CDDR U)); !&ADDJMP CDR U; T>> ELSE RETURN NIL END; SYMBOLIC PROCEDURE !&PEEPHOLEOPT; %'peep-hole' optimization for various cases; BEGIN SCALAR X,Z; Z := CODELIST; WHILE Z DO IF NOT (X := GET(CAAR Z,'OPTFN)) OR NOT APPLY(X,LIST Z) THEN Z := CDR Z END; SYMBOLIC PROCEDURE !&FIXREST; %checks for various cases involving unique (and unused) labels %and sequences like (JUMPx lab) M1 ... Mn ... (LAB lab) M1 ... Mn %where Mi do not affect reg 1; BEGIN SCALAR LABS,TLABS,X,Y,Z; WHILE CODELIST DO <<IF CAAR CODELIST EQ '!*LBL THEN <<!&LBLOPT CODELIST; IF CDR (Z := !&FINDLBL CDAR CODELIST) THEN <<Y := CAR CODELIST . Y; IF NULL CDDR Z AND !&TRANSFERP CADR Z AND CAADR Y EQ '!*LOAD AND !&NOLOADP(CDADR Y, CDR ATSOC(CADR Z, JMPLIST)) THEN <<IF NOT !&NOLOADP(CDADR Y, CDR CODELIST) THEN RPLACW(CDR CODELIST, CADR Y . CADR CODELIST . CDDR CODELIST); RPLACW(CDR Y,CDDR Y)>> ELSE <<IF NULL CDDR Z AND CAADR CODELIST EQ '!*JUMP AND GET(CAADR Z,'NEGJMP) THEN LABS := (CADR Z . Y) . LABS; IF !&TRANSFERP CADR CODELIST THEN TLABS := (CADAR Y . Y) . TLABS>>>>>> ELSE IF GET(CAAR CODELIST,'NEGJMP) AND (Z := ATSOC(CAR CODELIST,LABS)) THEN <<X := CAR CODELIST; CODELIST := CDR CODELIST; Z := CDDR Z; WHILE CAR Y=CAR Z AND (CAAR Y EQ '!*STORE OR CAAR Y EQ '!*LOAD AND NOT CADAR Y=1) DO <<CODELIST := CAR Y . CODELIST; RPLACW(Z,CADR Z . CDDR Z); Y := CDR Y>>; CODELIST := X . CODELIST; Y := X . Y>> ELSE IF CAAR CODELIST EQ '!*JUMP AND (Z := ATSOC(CADAR CODELIST,TLABS)) AND (X := !&FINDBLK(CDR CODELIST, IF CAAR Y EQ '!*LBL THEN CADAR Y ELSE NIL)) THEN BEGIN SCALAR W; IF NOT CAADR X EQ '!*LBL THEN <<IF NOT CAAR X EQ '!*LBL THEN X := CDR RPLACD(X, ('!*LBL . !&GENLBL()) . CDR X); W := GET(CAADR X,'NEGJMP) . (CADAR X . CDDADR X); !&REMJMP CDR X; RPLACD(X,W . (CADR X . CDDR X)); !&ADDJMP CDR X>> ELSE X := CDR X; W := NIL; REPEAT <<W := CAR Y . W; Y := CDR Y>> UNTIL Y EQ CDR Z; RPLACD(X,NCONC(W,CDR X)); !&REMJMP CODELIST; TLABS := NIL; %since code chains have changed; CODELIST := NIL . (CAR Y . CODELIST); Y := CDR Y END ELSE Y := CAR CODELIST . Y; CODELIST := CDR CODELIST>>; CODELIST := Y END; SYMBOLIC PROCEDURE !&NOLOADP(ARGS,INSTRS); %determines if a LOAD is not necessary in instruction stream; ATOM CADR ARGS AND (CAAR INSTRS EQ '!*LOAD AND CDAR INSTRS=ARGS OR CAAR INSTRS EQ '!*STORE AND (CDAR INSTRS=ARGS OR NOT CADDAR INSTRS=CADR ARGS AND !&NOLOADP(ARGS,CDR INSTRS))); SYMBOLIC PROCEDURE !&FIXCHN(U,V); BEGIN SCALAR X; WHILE CAR U=CAR V DO <<!&MOVEUP U; V := CDR V>>; X := !&GENLBL(); IF CAAR V EQ '!*LBL THEN !&RECHAIN(X,CDAR V) ELSE RPLACW(V,('!*LBL . X) . (CAR V . CDR V)); IF CAAR U EQ '!*LBL THEN <<!&RECHAIN(CDAR U,X); !&MOVEUP U>>; IF CAAR U EQ '!*JUMP THEN RETURN NIL; RPLACW(U,('!*JUMP . X) . (CAR U . CDR U)); !&ADDJMP U END; SYMBOLIC PROCEDURE !&FIXFRM; BEGIN SCALAR HOLES,LST,X,Y,Z; INTEGER N; IF NULL STLST AND NULL FREELST THEN RETURN RPLACA(LLNGTH,1); N := 0; WHILE NOT N<CAR LLNGTH DO <<Y := NIL; FOR EACH LST IN STLST DO IF N=CADDR LST THEN Y := CDDR LST . Y; FOR EACH LST IN FREELST DO IF N=CAR LST THEN Y := LST . Y; IF NULL Y THEN HOLES := N . HOLES ELSE Z := (N . Y) . Z; N := N - 1>>; Y := Z; IF CAAR Z>CAR LLNGTH THEN RPLACA(LLNGTH,CAAR Z); WHILE HOLES DO <<WHILE HOLES AND CAR HOLES<CAR LLNGTH DO HOLES := CDR HOLES; IF HOLES THEN <<HOLES := REVERSIP HOLES; FOR EACH X IN CDAR Z DO RPLACA(X,CAR HOLES); RPLACA(LLNGTH, IF NULL CDR Z OR CAR HOLES<CAADR Z THEN CAR HOLES ELSE CAADR Z); HOLES := REVERSIP CDR HOLES; Z := CDR Z>>>>; %now see if we can map frame to registers; N := IF NARG<3 THEN 3 ELSE NARG + 1; IF FREELST OR NULL !®P CODELIST OR CAR LLNGTH<N - MAXNARGS THEN RETURN NIL; FOR EACH X IN STLST DO RPLACW(X, LIST('!*LOAD, N - CADDR X, IF NULL CADR X THEN '(QUOTE NIL) ELSE CADR X)); WHILE Y DO <<FOR EACH X IN CDAR Y DO NOT CAR X>0 AND RPLACA(X,N - CAR X); %first test makes sure replacement only occurs once; Y := CDR Y>>; RPLACA(LLNGTH,1) END; SYMBOLIC PROCEDURE !®P U; %there is no test for !*LAMBIND/!*PROGBIND %since FREELST tested explicitly in !&FIXFRM; IF NULL CDR U THEN T ELSE IF CAAR U MEMQ '(!*LOAD !*STORE) AND NUMBERP CADAR U AND CADAR U>2 THEN NIL ELSE IF FLAGP(CAADR U,'UNKNOWNUSE) AND NOT (IDP CADADR U AND (FLAGP(CADADR U,'ONEREG) OR FLAGP(CADADR U,'TWOREG)) OR CAR U='!*JUMP . EXIT) THEN NIL ELSE !®P CDR U; FLAG('(!*CODE !*LINK !*LINKE),'UNKNOWNUSE); SYMBOLIC PROCEDURE !*CODE U; EVAL U; PUT('!*JUMPN,'NEGJMP,'!*JUMPE); PUT('!*JUMPE,'NEGJMP,'!*JUMPN); PUT('!*JUMPNIL,'NEGJMP,'!*JUMPT); PUT('!*JUMPT,'NEGJMP,'!*JUMPNIL); PUT('!*JUMPC,'NEGJMP,'!*JUMPNC); PUT('!*JUMPNC,'NEGJMP,'!*JUMPC); COMMENT Some arithmetic optimizations to reduce the amount of code generated; SYMBOLIC PROCEDURE !&PAPLUS2(U,VARS); IF CADDR U=1 THEN LIST('ADD1,!&PA1(CADR U,VARS)) ELSE IF CADR U=1 THEN LIST('ADD1,!&PA1(CADDR U,VARS)) ELSE 'PLUS2 . !&PALIS(CDR U,VARS); PUT('PLUS2,'PA1FN,'!&PAPLUS2); SYMBOLIC PROCEDURE !&PADIFF(U,VARS); IF CADDR U=1 THEN LIST('SUB1,!&PA1(CADR U,VARS)) ELSE 'DIFFERENCE . !&PALIS(CDR U,VARS); PUT('DIFFERENCE,'PA1FN,'!&PADIFF); SYMBOLIC PROCEDURE !&PALESSP(U,VARS); IF CADDR U=0 THEN LIST('MINUSP,!&PA1(CADR U,VARS)) ELSE 'LESSP . !&PALIS(CDR U,VARS); PUT('LESSP,'PA1FN,'!&PALESSP); COMMENT removing unnecessary calls to MINUS; SYMBOLIC PROCEDURE !&PAMINUS(U,VARS); IF EQCAR(U := !&PA1(CADR U,VARS),'QUOTE) AND NUMBERP CADR U THEN MKQUOTE ( - CADR U) ELSE LIST('MINUS,U); PUT('MINUS,'PA1FN,'!&PAMINUS); END; |
Added r30/debug.fap version [e52466da01].
cannot compute difference between binary files
Added r30/debug.red version [9a75ff9ea2].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE DEBUG; COMMENT TRACE FUNCTIONS; COMMENT functions defined in REDUCE but not Standard LISP; SYMBOLIC PROCEDURE LPRI U; BEGIN A: IF NULL U THEN RETURN NIL; PRIN2 CAR U; PRIN2 " "; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE LPRIW (U,V); BEGIN SCALAR X; U := U . IF V AND ATOM V THEN LIST V ELSE V; IF OFL!* AND (!*FORT OR NOT !*NAT OR !*DEFN) THEN GO TO C; TERPRI(); A: LPRI U; TERPRI(); IF NULL X THEN GO TO B; WRS CDR X; RETURN NIL; B: IF NULL OFL!* THEN RETURN NIL; C: X := OFL!*; WRS NIL; GO TO A END; SYMBOLIC PROCEDURE LPRIM U; !*MSG AND LPRIW("***",U); SYMBOLIC PROCEDURE LPRIE U; BEGIN SCALAR X; IF !*INT THEN GO TO A; X:= !*DEFN; !*DEFN := NIL; A: ERFG!* := T; LPRIW ("*****",U); IF NULL !*INT THEN !*DEFN := X END; SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U); SYMBOLIC PROCEDURE REVERSIP U; BEGIN SCALAR X,Y; WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>; RETURN Y END; COMMENT if we knew how many arguments a function had we could use EMBED mechanism; GLOBAL '(TRACEFLAG!* !*COMP !*MODE); TRACEFLAG!* := T; SYMBOLIC FEXPR PROCEDURE TRACE L; BEGIN SCALAR COMP,FN,G1,G2,LST,DEFN; COMP := !*COMP; !*COMP := NIL; %we don't want TRACE FEXPR compiled; WHILE L DO BEGIN FN := CAR L; L := CDR L; G1 := GENSYM(); %trace counter; G2 := GENSYM(); %used to hold original definition; DEFN := GETD FN; IF GET(FN,'TRACE) THEN RETURN LPRIM LIST(FN,"ALREADY TRACED") ELSE IF NOT DEFN THEN RETURN LPRIM LIST(FN,"UNDEFINED"); LST := FN . LST; TR!-PUTD(G2,CAR DEFN,CDR DEFN); REMD FN; TR!-PUTD(FN,'FEXPR,LIST('LAMBDA,'(!-L), LIST('TRACE1,'!-L,MKQUOTE G1, MKQUOTE(CAR DEFN . G2),MKQUOTE FN))); PUT(FN,'TRACE,G1 . DEFN); SET(G1,0); PUT('TRACE,'CNTRS,G1 . GET('TRACE,'CNTRS)); END; !*COMP := COMP; RETURN REVERSIP LST END; SYMBOLIC PROCEDURE TR!-PUTD(U,V,W); %PUTD even if U is flagged LOSE; BEGIN SCALAR BOOL; IF FLAGP(U,'LOSE) THEN <<BOOL := T; REMFLAG(LIST U,'LOSE)>>; PUTD(U,V,W); IF BOOL THEN FLAG(LIST U,'LOSE) END; SYMBOLIC PROCEDURE TRACE1(ARGS,CNTR,DEFN,NAME); BEGIN SCALAR BOOL,COUNT,VAL,X; SET(CNTR,EVAL CNTR+1); %update counter; COUNT := EVAL CNTR; IF TRACEFLAG!* THEN <<PRIN2 "*** ENTERING "; IF NOT COUNT=1 THEN <<PRIN2 COUNT; PRINC " ">>; PRIN2 NAME; PRIN2 ": ">>; BOOL := CAR DEFN MEMQ '(FEXPR FSUBR); IF NULL BOOL THEN ARGS := EVAL('LIST . ARGS); IF TRACEFLAG!* THEN PRINT ARGS; VAL := IF BOOL THEN EVAL(CDR DEFN . ARGS) ELSE APPLY(CDR DEFN,ARGS); IF TRACEFLAG!* THEN <<PRIN2 "*** LEAVING "; IF NOT COUNT=1 THEN <<PRIN2 COUNT; PRINC " ">>; PRIN2 NAME; PRIN2 ": "; PRINT VAL>>; SET(CNTR,COUNT-1); RETURN VAL END; SYMBOLIC FEXPR PROCEDURE UNTRACE L; BEGIN SCALAR COMP,FN,LST,DEFN; COMP := !*COMP; !*COMP := NIL; WHILE L DO BEGIN FN := CAR L; L := CDR L; DEFN := GET(FN,'TRACE); IF NULL DEFN THEN RETURN LPRIM LIST(FN,"NOT TRACED"); REMD FN; TR!-PUTD(FN,CADR DEFN,CDDR DEFN); REMPROP(FN,'TRACE); LST := FN . LST; PUT('TRACE,'CNTRS,DELETE(CAR DEFN,GET('TRACE,'CNTRS))) END; !*COMP := COMP; RETURN REVERSIP LST END; SYMBOLIC PROCEDURE TR U; TR1(U,'TRACE); SYMBOLIC PROCEDURE UNTR U; TR1(U,'UNTRACE); FLUID '(!*NOUUO); SYMBOLIC PROCEDURE TR1(U,V); BEGIN SCALAR X; !*NOUUO := T; X := EVAL (V . U); IF NOT !*MODE EQ 'SYMBOLIC THEN <<TERPRI(); PRINT X>> ELSE RETURN X END; DEFLIST ('((TR RLIS) (UNTR RLIS)),'STAT); FLAG('(TR UNTR),'IGNORE); %PUT('TR,'ARGMODE,'(((ARB!-NO SYMBOLIC) TR . NOVAL))); %PUT('UNTR,'ARGMODE,'(((ARB!-NO SYMBOLIC) UNTR . NOVAL))); COMMENT TRACESET FUNCTIONS; SYMBOLIC PROCEDURE TRSET1(U,V); FOR EACH X IN U DO BEGIN DCL Y:SYMBOLIC; Y := GETD X; IF NULL Y OR NOT CAR Y MEMQ '(EXPR FEXPR MACRO) THEN LPRIM LIST(X,"CANNOT BE TRACESET") ELSE IF V AND FLAGP(X,'TRST) THEN LPRIM LIST(X,"ALREADY TRACESET") ELSE IF NULL V AND NOT FLAGP(X,'TRST) THEN LPRIM LIST(X,"NOT TRACESET") ELSE <<IF V THEN FLAG(LIST X,'TRST) ELSE REMFLAG(LIST X,'TRST); TRSET2(CDR Y,V)>> END; SYMBOLIC PROCEDURE TRSET2(U,!*S!*); IF ATOM U THEN NIL ELSE IF CAR U EQ 'QUOTE THEN NIL ELSE IF CAR U EQ 'SETQ THEN RPLACD(CDR U, IF !*S!* THEN LIST SUBLIS(LIST('VBL . CADR U, 'X . GENSYM(), 'EXP . CADDR U), '((LAMBDA (X) (PROG NIL (SETQ VBL X) (PRIN2 (QUOTE VBL)) (PRIN2 (QUOTE ! !=! )) (PRIN2 X) (TERPRI) (RETURN X))) EXP)) ELSE CDADDR U) ELSE FOR EACH J IN U COLLECT TRSET2(J,!*S!*); SYMBOLIC PROCEDURE TRST U; TRSET1(U,T); SYMBOLIC PROCEDURE UNTRST U; TRSET1(U,NIL); DEFLIST('((TRST RLIS) (UNTRST RLIS)),'STAT); FLAG('(TRST UNTRST),'IGNORE); %PUT('TRST,'ARGMODE,'(((ARB!-NO SYMBOLIC) TRST . NOVAL))); %PUT('UNTRST,'ARGMODE,'(((ARB!-NO SYMBOLIC) UNTRST . NOVAL))); COMMENT EMBED FUNCTIONS; SYMBOLIC PROCEDURE EMBFN(U,V,W); BEGIN SCALAR NNAME,X,Y; IF !*DEFN THEN OUTDEF LIST('EMBFN,MKQUOTE U,MKQUOTE V,MKQUOTE W); X := GETD U; IF NULL X THEN REDERR LIST(U,"NOT DEFINED") ELSE IF NOT CAR X MEMQ '(FEXPR FSUBR EXPR SUBR) THEN REDERR LIST(U,"NOT EMBEDDABLE"); NNAME := GENSYM(); Y := NNAME . X . LIST('LAMBDA,V,SUBST(NNAME,U,W)); PUT(U,'EMB,Y); RETURN MKQUOTE U END; SYMBOLIC PROCEDURE EMBED U; %U is a list of function names; WHILE U DO BEGIN SCALAR TYPE,X,Y; X := CAR U; U := CDR U; Y := GET(X,'EMB); IF NULL Y THEN RETURN LPRIM LIST(X,"NOT EMBEDDED"); PUT(X,'UNEMB,Y); REMPROP(X,'EMB); TR!-PUTD(CAR Y,CAADR Y,CDADR Y); TYPE := IF CAADR Y MEMQ '(FSUBR FEXPR) THEN 'FEXPR ELSE 'EXPR; TR!-PUTD(X,TYPE,CDDR Y) END; SYMBOLIC PROCEDURE UNEMBED U; WHILE U DO BEGIN SCALAR X,Y; X := CAR U; U := CDR U; Y := GET(X,'UNEMB); IF NULL Y THEN RETURN LPRIM LIST(X,"NOT EMBEDDED"); PUT(X,'EMB,Y); REMPROP(X,'UNEMB); REMD CAR Y; TR!-PUTD(X,CAADR Y,CDADR Y) END; DEFLIST('((EMBED RLIS) (UNEMBED RLIS)),'STAT); END; |
Added r30/edit.fap version [3e6700b3b3].
cannot compute difference between binary files
Added r30/edit.red version [9922bb8394].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE EDIT; %PUT('EDIT,'IMPORTS,'(IO)); %needs CLOSE; FLUID '(BASE); GLOBAL '(FILE!* PAGE!* LINE!* EDIT!* FLG!*); COMMENT EDIT!* indicates that an edit fork has just been left, FLG!* that CMD or EDIT has been called; GLOBAL '(CRST!* CRLFST!* EDITFORK!* SYSTEM!* !$EOL!$); CRST!* := LIST(IF SYSTEM!* = 1 THEN !$EOL!$ ELSE INTERN ASCII 13,'!"); CRLFST!* := LIST(INTERN ASCII 13,INTERN ASCII 10,'!"); EDITFORK!* := IF SYSTEM!* = 1 THEN "<SUBSYS>SOS.SAV" ELSE "SYS:EDIT.EXE"; FLUID '(BASE); SYMBOLIC PROCEDURE CREATE U; CALLEDITOR(U,NIL,NIL,2); SYMBOLIC PROCEDURE CALLEDITOR(FILE,PAGE,LINE,CREATEF); BEGIN SCALAR BASE; BASE := 10.; IF NULL FILE THEN GO RET; IF NULL LINE THEN GO NL; IF PAGE THEN PAGE := '!/ . EXPLODE2 PAGE; LINE := IF ATOM LINE THEN EXPLODE2 LINE ELSE '!^ . '!+ . EXPLODE2 CAR LINE; IF SYSTEM!* = 1 THEN LINE := NCONC(!$EOL!$ . 'P . NCONC(LINE,PAGE),CRST!*) ELSE LINE := COMPRESS('!" . 'P . NCONC(LINE,NCONC(PAGE,CRST!*))); NL: IF SYSTEM!* = 1 THEN FILE := IF CREATEF=1 THEN APPEND('(!" !/ R ! ),FILE) ELSE '!" . FILE ELSE FILE := APPEND(IF CREATEF=1 THEN '(!" E D I T ! !/ R ! ) ELSE IF CREATEF=2 THEN '(!" C R E A T E ! ) ELSE '(!" E D I T ! ), NCONC(FILE,CRLFST!*)); FILE := COMPRESS FILE . LINE; RET: RETURN XEQKEEP('EDITFORK!*,EDITFORK!*,FILE) END; SYMBOLIC PROCEDURE EDITLINE; BEGIN INTEGER VAL; SCALAR XECHO; EDIT!* := NIL; IF IFL!* THEN <<LPRIW("*****","Editing can only be done from terminal"); RETURN NIL>> ELSE IF NOT FILEP(FILE!* := MKFIL FILE!*) THEN <<LPRIW("*****","Unknown file name"); RETURN IFL!* := NIL>>; IFL!* := FILE!* . OPEN(FILE!*,'INPUT); RDS CDR IFL!*; IPL!* := IFL!* . IPL!*; XECHO := !*ECHO; !*ECHO := NIL; !%FPAGE PAGE!*; LOOP: !%NEXTTYI(); VAL := CDR PGLINE(); IF PAIRP VAL THEN VAL := CAR VAL; IF VAL<LINE!* THEN <<SKIPTO !$EOL!$; GO TO LOOP>>; !*ECHO := XECHO; IF VAL>LINE!* THEN REDERR "Line not found"; IF !*ECHO THEN TYO !%NEXTTYI(); %If !*RAISE is on this will be upper case; END; SYMBOLIC PROCEDURE EDITSTAT; BEGIN SCALAR X,Y,Z; X := RLIS(); Y := CDR X; X := NULL(CAR X EQ 'EDIT); IF NULL CDR Y THEN IF X THEN REDERR "Invalid argument for CMD" ELSE IF STRINGP CAR Y OR IDP CAR Y AND FILEP CAR Y THEN RETURN LIST('CALLEDITOR,MKQUOTE EXPLODE2 CAR Y, NIL,NIL,0) ELSE RETURN LIST('EDIT0,MKQUOTE Y,NIL); Y := CAR Y . REMCOM CDR Y; IF NULL CDR Y THEN IF X THEN REDERR "Invalid argument for CMD" ELSE RETURN LIST('CALLEDITOR, MKQUOTE EXPLODE2 CAR Y,NIL,NIL,0) ELSE RETURN LIST('EDIT0,MKQUOTE Y,X) END; SYMBOLIC PROCEDURE REMCOM U; IF NULL U THEN NIL ELSE IF CAR U EQ '!, THEN REMCOM CDR U ELSE CAR U . REMCOM CDR U; SYMBOLIC PROCEDURE EDIT0(U,V); %U is function name or file description. %V is T if CMD, NIL if EDIT; <<FLG!* := T; IF NULL CDR U THEN IF V THEN REDERR "Invalid argument for CMD" ELSE EDIT11(CAR U,NIL,T) % ELSE IF IDP CADR U THEN EDIT11(CAR U,CADR U,T) ELSE EDIT2(CAR U,IF CDDR U THEN CADDR U ELSE 1,CADR U,T,V)>>; SYMBOLIC PROCEDURE EDIT11(U,W,V); %U is name of function being edited %V is T if called; BEGIN SCALAR LOC; LOC:=IF NULL V THEN U ELSE IF NULL W THEN GET(U,'LOCN) ELSE IF (LOC:=ATSOC(GET(U,'LOCNF),W)) THEN CDR LOC; IF NOT LOC THEN RETURN EDITDEF1 U; EDIT2(CAR LOC,CADR LOC,CDDR LOC,V,NIL) END; SYMBOLIC PROCEDURE EDIT2(FILE,PAGE,LINE,CALLED,NOCHANGE); BEGIN %!*DEFN := NIL; ?; IF NOT FIXP PAGE THEN TYPERR(PAGE,"integer") ELSE IF NOT FIXP LINE THEN TYPERR(LINE,"integer"); FILE!* := FILE; PAGE!* := PAGE; LINE!* := LINE; EDIT!* := T; RETURN IF NOCHANGE THEN BEGIN1() ELSE CALLEDITOR(EXPLODE2 FILE,PAGE,LINE,0) END; %SYMBOLIC PROCEDURE FILEMK U; % Convert a file specification from lisp format to a string. % This is essentially the inverse of MKFILE; % BEGIN SCALAR DEV,NAME,FLG,FLG2; % IF NULL U THEN RETURN NIL % ELSE IF ATOM U THEN NAME := EXPLODE2 U % ELSE FOR EACH X IN U DO % IF X EQ 'DIR!: THEN FLG := T % ELSE IF ATOM X THEN % IF FLG THEN <<FLG := NIL; % DEV := '!< . NCONC(EXPLODE2 X,LIST '!>)>> % ELSE IF X EQ 'DSK!: THEN DEV:=NIL % ELSE IF !%DEVP X THEN DEV := EXPLODE2 X % ELSE NAME := EXPLODE2 X % ELSE IF ATOM CDR X THEN % NAME := NCONC(EXPLODE2 CAR X,'!. . EXPLODE2 CDR X) % ELSE <<FLG2 := T; % DEV := '![ . NCONC(EXPLODE2 CAR X, % '!, . NCONC(EXPLODE2 CADR X,LIST '!]))>>; % U := IF FLG2 THEN NCONC(NAME,DEV) ELSE NCONC(DEV,NAME); % RETURN COMPRESS('!" . NCONC(U,'(!"))) % END; SYMBOLIC PROCEDURE EDIT1(U,V); <<CLOSE CDR IFL!*; IPL!*:=CDR IPL!*; RDS IF IPL!* THEN CDR (IFL!*:=CAR IPL!*) ELSE IFL!*:=NIL; EDIT11(U,NIL,V)>>; END; |
Added r30/entry.fap version [26fd85e846].
cannot compute difference between binary files
Added r30/entry.nred version [0a0393ee80].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT This file sets up necessary entry points for autoloading modules in Reduce. It uses a modified version of the Defautoload function of Eric Benson; SYMBOLIC MACRO PROCEDURE DEFAUTOLOAD U; % (DEFAUTOLOAD name), (DEFAUTOLOAD name loadname), % (DEFAUTOLOAD name loadname fntype), or % (DEFAUTOLOAD name loadname fntype numargs) % Default is 1 Arg EXPR in module of same name; BEGIN SCALAR NAME, NUMARGS, LOADNAME, FNTYPE; U := CDR U; NAME := CAR U; U := CDR U; IF U THEN <<LOADNAME := CAR U; U :=CDR U>> ELSE LOADNAME := NAME; IF EQCAR(NAME, 'QUOTE) THEN NAME := CADR NAME; IF ATOM LOADNAME THEN LOADNAME := LIST LOADNAME ELSE IF CAR LOADNAME EQ 'QUOTE THEN LOADNAME := CADR LOADNAME; FOR EACH J IN LOADNAME COLLECT IF IDP J THEN LIST('RED3!:,(J . 'FAP)) ELSE J; IF U THEN <<FNTYPE := CAR U; U := CDR U>> ELSE FNTYPE := 'EXPR; IF U THEN NUMARGS := CAR U ELSE NUMARGS := 1; NUMARGS := IF NUMARGS=0 THEN NIL ELSE IF NUMARGS=1 THEN '(X1) ELSE IF NUMARGS=2 THEN '(X1 X2) ELSE IF NUMARGS=3 THEN '(X1 X2 X3) ELSE IF NUMARGS=4 THEN '(X1 X2 X3 X4) ELSE ERROR(99,LIST(NUMARGS,"too large in DEFAUTOLOAD")); RETURN LIST('PUTD, MKQUOTE NAME, MKQUOTE FNTYPE, MKQUOTE LIST('LAMBDA, NUMARGS, 'PROGN . ACONC(FOR EACH J IN LOADNAME COLLECT LIST('LOAD!-MODULE,MKQUOTE J), LIST('APPLY, MKQUOTE NAME, 'LIST . NUMARGS)))) END; COMMENT Actual Entry Point Definitions; %input editor entry points; DEFAUTOLOAD CEDIT; DEFAUTOLOAD(DISPLAY,CEDIT); PUT('DISPLAY,'STAT,'RLIS); DEFAUTOLOAD(EDITDEF,CEDIT); PUT('EDITDEF,'STAT,'RLIS); DEFAUTOLOAD(EDITDEF1,CEDIT); %Compiler and LAP entry points; %DEFAUTOLOAD(COMPD,'(LAP COMPLR CMACRO),EXPR,3); %DEFAUTOLOAD(COMPILE,'(LAP COMPLR CMACRO)); DEFAUTOLOAD(LAP,'(LAP COMPILER CMACRO)); %Cross-reference module entry points; PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); DEFAUTOLOAD(CREFON,'(RCREF REDIO),EXPR,0); %Factorizer module entry points; REMPROP('FACTOR,'STAT); DEFAUTOLOAD(EZGCDF,FACTOR,EXPR,2); DEFAUTOLOAD(FACTORF,FACTOR); DEFAUTOLOAD(SIMPFACTORIZE,FACTOR); PUT('FACTORIZE,'SIMPFN,'SIMPFACTORIZE); DEFAUTOLOAD(SIMPNPRIMITIVE,FACTOR); PUT('NPRIMITIVE,'SIMPFN,'SIMPNPRIMITIVE); DEFAUTOLOAD(SIMPRESULTANT,FACTOR); PUT('RESULTANT,'SIMPFN,'SIMPRESULTANT); PUT('FACTOR,'STAT,'RLIS); %FASL module entry points; REMPROP('FASLOUT,'STAT); DEFAUTOLOAD(FASLOUT,'(LAP COMPLR CMACRO FAP)); PUT('FASLOUT,'STAT,'RLIS); %Help module entry points (not yet available); %REMFLAG('(HELP),'GO); %REMPROP('HELP,'STAT); %DEFAUTOLOAD HELP; %FLAG('(HELP),'GO); %PUT('HELP,'STAT,'RLIS); %Part module entry points; DEFAUTOLOAD(ARGLENGTH,PART); FLAG('(ARGLENGTH),'OPFN); DEFAUTOLOAD(SIMPPART,PART); PUT('PART,'SIMPFN,'SIMPPART); DEFAUTOLOAD(SIMPSETPART,PART); PUT('SETPART!*,'SIMPFN,'SIMPSETPART); PUT('PART,'SETQFN,'SETPART!*); %Prettyprint module entry point; DEFAUTOLOAD(PRETTYPRINT,PRETTY); %Matrix module entry points; DEFAUTOLOAD(DETQ,MATR); DEFAUTOLOAD(LETMTR,MATR,EXPR,3); DEFAUTOLOAD(MAPC2,MATR,EXPR,2); %used by SOLVE; DEFAUTOLOAD(MATSM!*,MATR); DEFAUTOLOAD(SIMPDET,MATR); PUT('DET,'SIMPFN,'SIMPDET); DEFAUTOLOAD(SIMPTRACE,MATR); PUT('TRACE,'SIMPFN,'SIMPTRACE); %META module entry point (not yet available); %DEFAUTOLOAD META; %Rprint module entry point; DEFAUTOLOAD RPRINT; %SOLVE module entry point; DEFAUTOLOAD(SIMPSOLVE,'(MATR SOLVE)); PUT('SOLVE,'SIMPFN,'SIMPSOLVE); %High energy physics module entry points; REMPROP('INDEX,'STAT); REMPROP('MASS,'STAT); REMPROP('MSHELL,'STAT); REMPROP('VECDIM,'STAT); REMPROP('VECTOR,'STAT); DEFAUTOLOAD(INDEX,HEPHYS); DEFAUTOLOAD(MASS,HEPHYS); DEFAUTOLOAD(MSHELL,HEPHYS); DEFAUTOLOAD(VECDIM,HEPHYS); DEFAUTOLOAD(VECTOR,HEPHYS); PUT('INDEX,'STAT,'RLIS); PUT('MSHELL,'STAT,'RLIS); PUT('MASS,'STAT,'RLIS); PUT('VECDIM,'STAT,'RLIS); PUT('VECTOR,'STAT,'RLIS); FLAGOP NONCOM,NOSPUR; %Integrator module entry point; DEFAUTOLOAD(SIMPINT,INT); PUT('INT,'SIMPFN,'SIMPINT); PUT('BIGFLOAT,'MODULE!-NAME,'BFLOAT); %Debug module entry points; DEFAUTOLOAD(EMBFN,DEBUG,EXPR,3); %DEFAUTOLOAD(SU2SL,TRANS); % exec and system editor entry points; REMFLAG('(EXEC PUSH),'GO); IF SYSTEM!* NEQ 0 THEN <<REMPROP('CMD,'STAT); REMPROP('EDIT,'STAT); REMPROP('CREATE,'STAT); REMPROP('EXEC,'STAT); REMPROP('PUSH,'STAT); DEFAUTOLOAD(EXEC,EXEC,EXPR,0); DEFAUTOLOAD(PUSH,EXEC,EXPR,0); DEFAUTOLOAD(CREATE,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(EDIT1,'(EXEC EDIT),EXPR,2); DEFAUTOLOAD(CMD,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(EDITSTAT,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(PINSTAT,EXEC,EXPR,0); PUT('CMD,'STAT,'EDITSTAT); PUT('EXEC,'STAT,'PINSTAT); PUT('PUSH,'STAT,'PINSTAT); PUT('CREATE,'STAT,'PINSTAT); PUT('EDIT,'STAT,'EDITSTAT); FLAG('(EXEC PUSH CREATE),'IGNORE); FLAG('(CMD EDIT),'EVAL); %FLAG('(EXEC PUSH),'GO); >>; END; |
Added r30/entry.red version [35bb9b6801].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT This file sets up necessary entry points for autoloading modules in Reduce. It uses a modified version of the Defautoload function of Eric Benson; SYMBOLIC MACRO PROCEDURE DEFAUTOLOAD U; % (DEFAUTOLOAD name), (DEFAUTOLOAD name loadname), % (DEFAUTOLOAD name loadname fntype), or % (DEFAUTOLOAD name loadname fntype numargs) % Default is 1 Arg EXPR in module of same name; BEGIN SCALAR NAME, NUMARGS, LOADNAME, FNTYPE; U := CDR U; NAME := CAR U; U := CDR U; IF U THEN <<LOADNAME := CAR U; U :=CDR U>> ELSE LOADNAME := NAME; IF EQCAR(NAME, 'QUOTE) THEN NAME := CADR NAME; IF ATOM LOADNAME THEN LOADNAME := LIST LOADNAME ELSE IF CAR LOADNAME EQ 'QUOTE THEN LOADNAME := CADR LOADNAME; IF U THEN <<FNTYPE := CAR U; U := CDR U>> ELSE FNTYPE := 'EXPR; IF U THEN NUMARGS := CAR U ELSE NUMARGS := 1; NUMARGS := IF NUMARGS=0 THEN NIL ELSE IF NUMARGS=1 THEN '(X1) ELSE IF NUMARGS=2 THEN '(X1 X2) ELSE IF NUMARGS=3 THEN '(X1 X2 X3) ELSE IF NUMARGS=4 THEN '(X1 X2 X3 X4) ELSE ERROR(99,LIST(NUMARGS,"too large in DEFAUTOLOAD")); RETURN LIST('PUTD, MKQUOTE NAME, MKQUOTE FNTYPE, MKQUOTE LIST('LAMBDA, NUMARGS, 'PROGN . ACONC(FOR EACH J IN LOADNAME COLLECT LIST('LOAD!-MODULE,MKQUOTE J), LIST('APPLY, MKQUOTE NAME, 'LIST . NUMARGS)))) END; COMMENT Actual Entry Point Definitions; %input editor entry points; DEFAUTOLOAD CEDIT; DEFAUTOLOAD(DISPLAY,CEDIT); PUT('DISPLAY,'STAT,'RLIS); DEFAUTOLOAD(EDITDEF,CEDIT); PUT('EDITDEF,'STAT,'RLIS); DEFAUTOLOAD(EDITDEF1,CEDIT); %Compiler and LAP entry points; %DEFAUTOLOAD(COMPD,'(LAP COMPLR CMACRO),EXPR,3); %DEFAUTOLOAD(COMPILE,'(LAP COMPLR CMACRO)); DEFAUTOLOAD(LAP,'(LAP COMPILER CMACRO)); %Cross-reference module entry points; PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); DEFAUTOLOAD(CREFON,'(RCREF REDIO),EXPR,0); %Factorizer module entry points; REMPROP('FACTOR,'STAT); DEFAUTOLOAD(EZGCDF,FACTOR,EXPR,2); DEFAUTOLOAD(FACTORF,FACTOR); DEFAUTOLOAD(SIMPFACTORIZE,FACTOR); PUT('FACTORIZE,'SIMPFN,'SIMPFACTORIZE); DEFAUTOLOAD(SIMPNPRIMITIVE,FACTOR); PUT('NPRIMITIVE,'SIMPFN,'SIMPNPRIMITIVE); DEFAUTOLOAD(SIMPRESULTANT,FACTOR); PUT('RESULTANT,'SIMPFN,'SIMPRESULTANT); PUT('FACTOR,'STAT,'RLIS); %FASL module entry points; REMPROP('FASLOUT,'STAT); DEFAUTOLOAD(FASLOUT,'(LAP COMPLR CMACRO FAP)); PUT('FASLOUT,'STAT,'RLIS); %Help module entry points (not yet available); %REMFLAG('(HELP),'GO); %REMPROP('HELP,'STAT); %DEFAUTOLOAD HELP; %FLAG('(HELP),'GO); %PUT('HELP,'STAT,'RLIS); %Part module entry points; DEFAUTOLOAD(ARGLENGTH,PART); FLAG('(ARGLENGTH),'OPFN); DEFAUTOLOAD(SIMPPART,PART); PUT('PART,'SIMPFN,'SIMPPART); DEFAUTOLOAD(SIMPSETPART,PART); PUT('SETPART!*,'SIMPFN,'SIMPSETPART); PUT('PART,'SETQFN,'SETPART!*); %Prettyprint module entry point; DEFAUTOLOAD(PRETTYPRINT,PRETTY); %Matrix module entry points; DEFAUTOLOAD(DETQ,MATR); DEFAUTOLOAD(LETMTR,MATR,EXPR,3); DEFAUTOLOAD(MAPC2,MATR,EXPR,2); %used by SOLVE; DEFAUTOLOAD(MATSM!*,MATR); DEFAUTOLOAD(SIMPDET,MATR); PUT('DET,'SIMPFN,'SIMPDET); DEFAUTOLOAD(SIMPTRACE,MATR); PUT('TRACE,'SIMPFN,'SIMPTRACE); %META module entry point (not yet available); %DEFAUTOLOAD META; %Rprint module entry point; DEFAUTOLOAD RPRINT; %SOLVE module entry point; DEFAUTOLOAD(SIMPSOLVE,'(MATR SOLVE)); PUT('SOLVE,'SIMPFN,'SIMPSOLVE); %High energy physics module entry points; REMPROP('INDEX,'STAT); REMPROP('MASS,'STAT); REMPROP('MSHELL,'STAT); REMPROP('VECDIM,'STAT); REMPROP('VECTOR,'STAT); DEFAUTOLOAD(INDEX,HEPHYS); DEFAUTOLOAD(MASS,HEPHYS); DEFAUTOLOAD(MSHELL,HEPHYS); DEFAUTOLOAD(VECDIM,HEPHYS); DEFAUTOLOAD(VECTOR,HEPHYS); PUT('INDEX,'STAT,'RLIS); PUT('MSHELL,'STAT,'RLIS); PUT('MASS,'STAT,'RLIS); PUT('VECDIM,'STAT,'RLIS); PUT('VECTOR,'STAT,'RLIS); FLAGOP NONCOM,NOSPUR; %Integrator module entry point; DEFAUTOLOAD(SIMPINT,INT); PUT('INT,'SIMPFN,'SIMPINT); PUT('BIGFLOAT,'MODULE!-NAME,'BFLOAT); %Debug module entry points; DEFAUTOLOAD(EMBFN,DEBUG,EXPR,3); %DEFAUTOLOAD(SU2SL,TRANS); % exec and system editor entry points; REMFLAG('(EXEC PUSH),'GO); IF SYSTEM!* NEQ 0 THEN <<REMPROP('CMD,'STAT); REMPROP('EDIT,'STAT); REMPROP('CREATE,'STAT); REMPROP('EXEC,'STAT); REMPROP('PUSH,'STAT); DEFAUTOLOAD(EXEC,EXEC,EXPR,0); DEFAUTOLOAD(PUSH,EXEC,EXPR,0); DEFAUTOLOAD(CREATE,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(EDIT1,'(EXEC EDIT),EXPR,2); DEFAUTOLOAD(CMD,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(EDITSTAT,'(EXEC EDIT),EXPR,0); DEFAUTOLOAD(PINSTAT,EXEC,EXPR,0); PUT('CMD,'STAT,'EDITSTAT); PUT('EXEC,'STAT,'PINSTAT); PUT('PUSH,'STAT,'PINSTAT); PUT('CREATE,'STAT,'PINSTAT); PUT('EDIT,'STAT,'EDITSTAT); FLAG('(EXEC PUSH CREATE),'IGNORE); FLAG('(CMD EDIT),'EVAL); %FLAG('(EXEC PUSH),'GO); >>; END; |
Added r30/exec.fap version [ccf71a7c7b].
cannot compute difference between binary files
Added r30/exec.red version [0d2458d6d1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT This file provides support for calling the EXEC and the system editor under TOPS-20 or TENEX; SYMBOLIC; GLOBAL '(PROGEXT!* PSYSDEV!* CRLFST!* EXECFORK!* EXECFILE!* SYSTEM!* !$EOL!$); PROGEXT!* := IF SYSTEM!*>0 THEN '(V A S !.) ELSE '(E X E !.); PSYSDEV!* := IF SYSTEM!*>0 THEN '(!< S U B S Y S !>) ELSE '(S Y S !:); CRLFST!* := IF SYSTEM!*<0 THEN LIST(INTERN ASCII 13,INTERN ASCII 10,'!") ELSE LIST(!$EOL!$,'!"); EXECFORK!* := EXECFILE!* := IF SYSTEM!*<0 THEN "<SYSTEM>EXEC.EXE" ELSE "<SYSTEM>EXEC.SAV"; SYMBOLIC PROCEDURE PINSTAT; BEGIN SCALAR X,Y,Z; Z := CURSYM!*; IF DELCP(X := NXTSYM!*) THEN GO TO DUN; Y := REVERSIP EXPLODEC NXTSYM!*; IF DELCP(X := CRCHAR!*) THEN GO TO DUN; Y := CRCHAR!* . Y; CRCHAR!* := '! ; WHILE NOT DELCP(X := READCHQ()) DO Y := X . Y; DUN: NXTSYM!* := X; TTYPE!* := 3; SCAN(); RETURN LIST(Z,IF Y THEN MKQUOTE REVERSIP Y ELSE NIL) END; SYMBOLIC PROCEDURE READCHQ; IF !*INT AND NULL IFL!* THEN READCH1() ELSE READCH(); REMPROP('EXEC,'STAT); REMPROP('PUSH,'STAT); REMFLAG('(EXEC PUSH),'GO); SYMBOLIC PROCEDURE PUSH U; EXEC U; %we might as well support both; SYMBOLIC PROCEDURE EXEC U; BEGIN SCALAR V,X,Y,Z; IF NULL U THEN RETURN XEQKEEP('EXECFORK!*,EXECFILE!*,NIL); V := U; A: IF CAR U EQ '!: OR CAR U EQ '!< THEN Y := T ELSE IF CAR U EQ '!. THEN Z := T ELSE IF SEPRP CAR U THEN GO TO B; X := CAR U . X; IF (U := CDR U) THEN GO TO A; B: X := REVERSIP('!" . IF Z THEN X ELSE APPEND(PROGEXT!*,X)); X := COMPRESS('!" . IF Y THEN X ELSE APPEND(PSYSDEV!*,X)); RETURN XEQKILL(X,LIST COMPRESS('!" . APPEND(V,CRLFST!*))) END; PUT('EXEC,'STAT,'PINSTAT); PUT('PUSH,'STAT,'PINSTAT); %FLAG('(EXEC PUSH),'GO); SYMBOLIC PROCEDURE XEQKILL(FILENAME,ARG); %handles infrequent calls by creating and killing each fork; <<!%XEQ(FILENAME,T,T,NIL,ARG); TERPRI(); PRIN2T "Returned to REDUCE ..."; NIL>>; SYMBOLIC EXPR PROCEDURE XEQKEEP(FORKN,FILE,ARG); %This retains the lower fork for speedy subsequent calls to the same %program (e.g., PUSH or EDIT), and the ---FILE check will set up the %fork again after a SAVE; BEGIN SCALAR A; A:=ERRORSET(LIST('!%XEQ,FORKN,T,NIL,NIL,MKQUOTE ARG),NIL,NIL); SET(FORKN,IF ATOM A THEN !%XEQ(FILE,T,NIL,NIL,ARG) ELSE CAR A); TERPRI(); PRIN2T "Returned to REDUCE ..." END; %SYMBOLIC PROCEDURE KFORK U; % PAIRP ERRORSET(LIST('JSYS,153,MKQUOTE U,0,0,1),NIL,NIL); %DATE!*:=JSYS(144,'(BUF),-1,604241920,1); %The following function is called by BEGIN. It checks that terminal % linelength in REDUCE is shorter than the width of the controlling % terminal. % Commented out as it is to sensitive to operating system differences. %SYMBOLIC PROCEDURE CHKLEN; % BEGIN SCALAR A,B; % A := ERRORSET('(JSYS 63 65 24 0 3),NIL,NIL); %Try MTOPR first, % A := IF PAIRP A THEN CAR A % ELSE BOOLE(1,LSH(JSYS(71,65,0,0,2),-18),127); % else use RFMOD % IF A<10 THEN RETURN; % B := LINELENGTH NIL; % IF A LEQ B THEN LINELENGTH(A-1); % RETURN B % END; END; |
Added r30/factor.fap version [5b232e8b5a].
cannot compute difference between binary files
Added r30/factor.red version [e27d73334f].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 | % *********************************************** % ******* The REDUCE Factorization module ******* % ******* A. C. Norman and P. M. A. Moore ******* % ***********************************************; % This version dated 12 September 1982. ACN; % This file should be used with a system dependent file containing % a setting of the variable LARGEST!-SMALL!-MODULUS. % If at all possible the integer arithmetic % operations used here should be mapped onto corresponding ones % available in the underlying Lisp implementation, and the support % for modular arithmetic (perhaps based on these integer arithmetic % operations) should be reviewed. This file provides placeholder % definitions of functions that are used on some implementations % to support block compilation, car/cdr access checks and the like. % The front-end files on the systems that can use these features will % disable the definitions given here by use of a 'LOSE flag;; SYMBOLIC; % MODULE FSUPPORT; % Support for factorizer; DEFLIST('((MINUS!-ONE -1)),'NEWNAM); %so that it EVALs properly; SYMBOLIC SMACRO PROCEDURE CARCHECK U; NIL; FLUID '(!*TRFAC FACTOR!-LEVEL FACTOR!-TRACE!-LIST); SYMBOLIC SMACRO PROCEDURE FACTOR!-TRACE ACTION; BEGIN SCALAR STREAM; IF !*TRFAC AND FACTOR!-LEVEL = 1 THEN STREAM := NIL . NIL ELSE STREAM := ASSOC(FACTOR!-LEVEL,FACTOR!-TRACE!-LIST); IF STREAM THEN << STREAM:=WRS CDR STREAM; ACTION; WRS STREAM >> END; SYMBOLIC SMACRO PROCEDURE GCD(M,N); GCDN(M,N); SYMBOLIC SMACRO PROCEDURE ILOGAND(M,N); LOGAND2(M,N); SYMBOLIC SMACRO PROCEDURE ILOGOR(M,N); LOGOR2(M,N); SYMBOLIC SMACRO PROCEDURE ILOGXOR(M,N); LOGXOR2(M,N); SYMBOLIC MACRO PROCEDURE LOGAND U; EXPAND(CDR U,'LOGAND2); SYMBOLIC MACRO PROCEDURE LOGOR U; EXPAND(CDR U,'LOGOR2); SYMBOLIC MACRO PROCEDURE LOGXOR U; EXPAND(CDR U,'LOGXOR2); SYMBOLIC SMACRO PROCEDURE IMIN(U,V); MIN(U,V); SYMBOLIC SMACRO PROCEDURE IRECIP U; 1/U; SYMBOLIC SMACRO PROCEDURE IRIGHTSHIFT(U,N); LEFTSHIFT(U,-N); SYMBOLIC SMACRO PROCEDURE ISDOMAIN U; DOMAINP U; SYMBOLIC SMACRO PROCEDURE MODULE U; NIL; SYMBOLIC SMACRO PROCEDURE ENDMODULE; NIL; SYMBOLIC SMACRO PROCEDURE BLKCMP; NIL; SYMBOLIC SMACRO PROCEDURE EXPORTS U; NIL; SYMBOLIC SMACRO PROCEDURE IMPORTS U; NIL; DEFLIST('((MODULE RLIS) (EXPORTS RLIS) (IMPORTS RLIS) (ENDMODULE ENDSTAT)),'STAT); SYMBOLIC SMACRO PROCEDURE PRINC U; PRIN2 U; SYMBOLIC SMACRO PROCEDURE PRINTC U; PRIN2T U; SYMBOLIC SMACRO PROCEDURE READGCTIME; GCTIME(); SYMBOLIC SMACRO PROCEDURE READTIME; TIME()-GCTIME(); SYMBOLIC SMACRO PROCEDURE REVERSEWOC U; REVERSIP U; SYMBOLIC SMACRO PROCEDURE TTAB N; SPACES(N-POSN()); % Operators for fast arithmetic; SYMBOLIC MACRO PROCEDURE IPLUS U; EXPAND(CDR U,'PLUS2); SYMBOLIC MACRO PROCEDURE ITIMES U; EXPAND(CDR U,'TIMES2); SMACRO PROCEDURE ISUB1 A; A-1; SMACRO PROCEDURE IADD1 A; A+1; SMACRO PROCEDURE IMINUS A; -A; SMACRO PROCEDURE IDIFFERENCE(A,B); A-B; SMACRO PROCEDURE IQUOTIENT(A,B); A/B; SMACRO PROCEDURE IREMAINDER(A,B); REMAINDER(A,B); SMACRO PROCEDURE IGREATERP(A,B); A>B; SMACRO PROCEDURE ILESSP(A,B); A<B; SMACRO PROCEDURE IMINUSP A; A<0; NEWTOK '((!#) HASH); NEWTOK '((!# !+) IPLUS); NEWTOK '((!# !-) IDIFFERENCE); NEWTOK '((!# !*) ITIMES); NEWTOK '((!# !/) IQUOTIENT); NEWTOK '((!# !>) IGREATERP); NEWTOK '((!# !<) ILESSP); INFIX #+,#-,#*,#/,#>,#<; PRECEDENCE #+,+; PRECEDENCE #-,-; PRECEDENCE #*,*; PRECEDENCE #/,/; PRECEDENCE #>,>; PRECEDENCE #<,<; FLAG('(IPLUS ITIMES),'NARY); DEFLIST('((IDIFFERENCE IMINUS)),'UNARY); DEFLIST('((IMINUS IPLUS)), 'ALT); SYMBOLIC PROCEDURE MOVED(OLD,NEW); << REMD OLD; PUTD(OLD,'EXPR,CDR GETD NEW) >>; SMACRO PROCEDURE EVENP A; REMAINDER(A,2)=0; SMACRO PROCEDURE SUPERPRINT A; PRETTYPRINT A; %The following number is probably not machine dependent; GLOBAL '(TWENTYFOURBITS); TWENTYFOURBITS := 2**24-1; COMMENT An Exponential Function for Real Numbers; % The following definitions constitute a simple floating % point exponential function. The argument is normalized to % the interval -ln 2 to 0, and a Taylor series expansion % used (formula 4.2.45 on page 71 of Abramowitz and Stegun, % "Handbook of Mathematical Functions"). Note that little % effort has been expended to minimize truncation errors. % On many systems it will be appropriate to define a system- % specific EXP routine that does bother about rounding and that % understands the precision of the host floating point arithmetic; SYMBOLIC PROCEDURE CEILING!-FLOAT X; % Returns the ceiling (fixnum) of its floatnum argument; BEGIN SCALAR N; N := FIX X; RETURN IF X = FLOAT N THEN N ELSE N+1 END; GLOBAL '(EXP!-COEFFS NATURAL!-LOG!-2); EXP!-COEFFS := MKVECT 7; PUTV(EXP!-COEFFS,0,1.0); PUTV(EXP!-COEFFS,1,-1.0); PUTV(EXP!-COEFFS,2,0.49999992); PUTV(EXP!-COEFFS,3,-0.16666530); PUTV(EXP!-COEFFS,4,0.41657347E-1); PUTV(EXP!-COEFFS,5,-0.83013598E-2); PUTV(EXP!-COEFFS,6,0.13298820E-2); PUTV(EXP!-COEFFS,7,-0.14131610E-3); NATURAL!-LOG!-2 := 0.69314718; SYMBOLIC PROCEDURE EXP X; % Returns the exponential (ie, e**x) of its floatnum argument as % a floatnum; BEGIN SCALAR N,ANS; N := CEILING!-FLOAT(X / NATURAL!-LOG!-2); X := N * NATURAL!-LOG!-2 - X; ANS := 0.0; FOR I := UPBV EXP!-COEFFS STEP -1 UNTIL 0 DO ANS := GETV(EXP!-COEFFS,I) + X*ANS; RETURN ANS * 2**N END; COMMENT A Random Number Generator; % The declarations below constitute a linear, congruential % random number generator (see Knuth, "The Art of Computer % Programming: Volume 2: Seminumerical Algorithms", pp9-24). % With the given constants it has a period of 392931 and % potency 6. To have deterministic behaviour, set % RANDOM!-SEED. % % Constants are: 6 2 % modulus: 392931 = 3 * 7 * 11 % multiplier: 232 = 3 * 7 * 11 + 1 % increment: 65537 is prime; GLOBAL '(RANDOM!-SEED); SYMBOLIC PROCEDURE RANDOMIZE(); RANDOM!-SEED := REMAINDER(TIME(),392931); RANDOMIZE(); SYMBOLIC PROCEDURE RANDOM; % Returns a pseudo-random number between 0 and 392931; RANDOM!-SEED := REMAINDER(232*RANDOM!-SEED + 65537, 392931); COMMENT Support for Real Square Roots; SYMBOLIC PROCEDURE SQRT N; % return sqrt of n if same is exact, or something non-numeric % otherwise. Note that only the floating point parts of this % code get excercised by the factorizer, and that they only % ever get called with arguments in the range 1 to 10**12; IF NOT NUMBERP N THEN 'NONNUMERIC ELSE IF N<0 THEN 'NEGATIVE ELSE IF FLOATP N THEN SQRT!-FLOAT N ELSE IF N<2 THEN N ELSE NR(N,(N+1)/2); SYMBOLIC PROCEDURE NR(N,ROOT); % root is an overestimate here. nr moves downwards to root. % In the case of this being called on really big numbers the % initial approximate used will be bad & the iteration will start % in effect by halving it until it is reasonable. This could do % with improvement in any system where big square roots will be % taken at all often; BEGIN SCALAR W; W:=ROOT*ROOT; IF N=W THEN RETURN ROOT; W:=(ROOT+N/ROOT)/2; IF W>=ROOT THEN RETURN !*P2F MKSP(LIST('SQRT,N),1); RETURN NR(N,W) END; GLOBAL '(SQRT!-FLOAT!-TOLERANCE); SQRT!-FLOAT!-TOLERANCE := 0.00001; SYMBOLIC PROCEDURE SQRT!-FLOAT N; % Simple Newton-Raphson floating point square root calculator; BEGIN SCALAR SCALE,ANS; IF N=0.0 THEN RETURN 0.0 ELSE IF N<0.0 THEN REDERR "SQRT!-FLOAT GIVEN NEGATIVE ARGUMENT"; SCALE := 1.0; % Detatch the exponent by doing a sequence of multiplications % and divisions by powers of 2 until the remaining number is in % the range 1.0 to 4.0. On a binary machine the scaling should % not introduce any error at all; WHILE N > 256.0 DO << SCALE := SCALE * 16.0; N := N/256.0 >>; WHILE N < 1.0/256.0 DO << SCALE := SCALE / 16.0; N := N*256.0 >>; % Coarse scaled: now finish off the job; WHILE N < 1.0 DO << SCALE := SCALE / 2.0; N := N*4.0 >>; WHILE N > 4.0 DO << SCALE := SCALE * 2.0; N := N/4.0 >>; ANS := 2.0; % 5 iterations get me as good a result % as I can reasonably want & it is cheaper % to do 5 always than to test for stopping % criteria; FOR I:=1:5 DO ANS := (ANS+N/ANS)/2.0; RETURN ANS*SCALE END; COMMENT A Simple Sorting Routine; SYMBOLIC PROCEDURE SORT(L,FN); BEGIN SCALAR TREE; IF NULL L OR NULL CDR L THEN RETURN L; FOR EACH J IN L DO TREE := TREEADD(J,TREE,FN); RETURN FLATTREE(TREE,NIL) END; SYMBOLIC PROCEDURE TREEADD(ITEM,TREE,FN); % add item to a tree, using fn as an order predicate; IF NULL TREE THEN ITEM . (NIL . NIL) ELSE IF APPLY(FN,LIST(ITEM,CAR TREE)) THEN CAR TREE . (TREEADD(ITEM,CADR TREE,FN). CDDR TREE) ELSE CAR TREE . (CADR TREE . TREEADD(ITEM,CDDR TREE,FN)); SYMBOLIC PROCEDURE FLATTREE(TREE,L); IF NULL TREE THEN L ELSE FLATTREE(CADR TREE,CAR TREE . FLATTREE(CDDR TREE,L)); % Modular arithmetic; FLUID '(CURRENT!-MODULUS MODULUS!/2 LARGEST!-SMALL!-MODULUS); % LARGEST!-SMALL!-MODULUS must be set in the front-end (system % dependent) file; SYMBOLIC PROCEDURE SET!-SMALL!-MODULUS P; BEGIN SCALAR PREVIOUS!-MODULUS; IF P>LARGEST!-SMALL!-MODULUS THEN ERRORF "Overlarge modulus being used"; PREVIOUS!-MODULUS:=CURRENT!-MODULUS; CURRENT!-MODULUS:=P; MODULUS!/2 := P/2; RETURN PREVIOUS!-MODULUS END; SMACRO PROCEDURE MODULAR!-PLUS(A,B); BEGIN SCALAR RESULT; RESULT:=A #+ B; IF NOT RESULT #< CURRENT!-MODULUS THEN RESULT:=RESULT #- CURRENT!-MODULUS; RETURN RESULT END; SMACRO PROCEDURE MODULAR!-DIFFERENCE(A,B); BEGIN SCALAR RESULT; RESULT:=A #- B; IF IMINUSP RESULT THEN RESULT:=RESULT #+ CURRENT!-MODULUS; RETURN RESULT END; SYMBOLIC PROCEDURE MODULAR!-NUMBER A; BEGIN A:=REMAINDER(A,CURRENT!-MODULUS); IF IMINUSP A THEN A:=A #+ CURRENT!-MODULUS; RETURN A END; SMACRO PROCEDURE MODULAR!-TIMES(A,B); REMAINDER(A*B,CURRENT!-MODULUS); SMACRO PROCEDURE MODULAR!-RECIPROCAL A; RECIPROCAL!-BY!-GCD(CURRENT!-MODULUS,A,0,1); SYMBOLIC PROCEDURE RECIPROCAL!-BY!-GCD(A,B,X,Y); %On input A and B should be coprime. This routine then %finds X and Y such that A*X+B*Y=1, and returns the value Y %on input A > B; IF B=0 THEN ERRORF "INVALID MODULAR DIVISION" ELSE IF B=1 THEN IF IMINUSP Y THEN Y #+ CURRENT!-MODULUS ELSE Y ELSE BEGIN SCALAR W; %N.B. Invalid modular division is either: % a) attempt to divide by zero directly % b) modulus is not prime, and input is not % coprime with it; W:=IQUOTIENT(A,B); %Truncated integer division; RETURN RECIPROCAL!-BY!-GCD(B,A #- B #* W, Y,X #- Y #* W) END; SMACRO PROCEDURE MODULAR!-QUOTIENT(A,B); MODULAR!-TIMES(A,MODULAR!-RECIPROCAL B); SMACRO PROCEDURE MODULAR!-MINUS A; IF A=0 THEN A ELSE CURRENT!-MODULUS #- A; % Comparison functions used with the sort package; SYMBOLIC PROCEDURE LESSPCAR(A,B); CAR A < CAR B; SYMBOLIC PROCEDURE LESSPCDR(A,B); CDR A < CDR B; SYMBOLIC PROCEDURE LESSPPAIR(A,B); IF CAR A=CAR B THEN CDR A < CDR B ELSE CAR A < CAR B; SYMBOLIC PROCEDURE GREATERPCDR(A,B); CDR A > CDR B; SYMBOLIC PROCEDURE LESSPCDADR(A,B); CDADR A < CDADR B; SYMBOLIC PROCEDURE LESSPDEG(A,B); IF DOMAINP B THEN NIL ELSE IF DOMAINP A THEN T ELSE LDEG A < LDEG B; SYMBOLIC PROCEDURE ORDOPCAR(A,B); ORDOP(CAR A,CAR B); SYMBOLIC PROCEDURE ORDERFACTORS(A,B); IF CDR A=CDR B THEN ORDP(CAR A,CAR B) ELSE CDR A < CDR B; % ENDMODULE; MODULE FLUIDS; % ******************************************************************* % % copyright (c) university of cambridge, england 1981 % % *******************************************************************; SYMBOLIC PROCEDURE ERRORF MSGG; BEGIN TERPRI(); PRIN2 "*** ERROR IN FACTORIZATION: "; PRIN2 MSGG; TERPRI(); ERROR(0,'ERRORF) END; % macro definitions for functions that create and % access reduce-type datastructures; SMACRO PROCEDURE TVAR A; CAAR A; FLUID '(POLYZERO); POLYZERO:=NIL; SMACRO PROCEDURE POLYZEROP U; NULL U; SMACRO PROCEDURE DIDNTGO Q; NULL Q; SMACRO PROCEDURE DEPENDS!-ON!-VAR(A,V); (LAMBDA !#!#A; (NOT DOMAINP !#!#A) AND (MVAR !#!#A=V)) A; SMACRO PROCEDURE L!-NUMERIC!-C(A,VLIST); LNC A; % macro definitions for use in berlekamps algorithm; % SMACROs used in linear equation package; SMACRO PROCEDURE GETM2(A,I,J); % Store by rows, to ease pivoting process; GETV(GETV(A,I),J); SMACRO PROCEDURE PUTM2(A,I,J,V); PUTV(GETV(A,I),J,V); SMACRO PROCEDURE !*D2N A; % converts domain elt into number; (LAMBDA !#A!#; IF NULL !#A!# THEN 0 ELSE !#A!#) A; SMACRO PROCEDURE !*NUM2F N; % converts number to s.f. ; (LAMBDA !#N!#; IF !#N!#=0 THEN NIL ELSE !#N!#) N; SMACRO PROCEDURE !*MOD2F U; U; SMACRO PROCEDURE !*F2MOD U; U; SMACRO PROCEDURE COMES!-BEFORE(P1,P2); % Similar to the REDUCE function ORDPP, but does not cater for % non-commutative terms and assumes that exponents are small % integers; (CAR P1=CAR P2 AND IGREATERP(CDR P1,CDR P2)) OR (NOT CAR P1=CAR P2 AND ORDOP(CAR P1,CAR P2)); SMACRO PROCEDURE ADJOIN!-TERM (P,C,R); (LAMBDA !#C!#; % Lambda binding prevents repeated evaluation of C; IF NULL !#C!# THEN R ELSE (P .* !#C!#) .+ R) C; % a load of access smacros for image sets follow: ; SMACRO PROCEDURE GET!-IMAGE!-SET S; CAR S; SMACRO PROCEDURE GET!-CHOSEN!-PRIME S; CADR S; SMACRO PROCEDURE GET!-IMAGE!-LC S; CADDR S; SMACRO PROCEDURE GET!-IMAGE!-MOD!-P S; CADR CDDR S; SMACRO PROCEDURE GET!-IMAGE!-CONTENT S; CADR CDR CDDR S; SMACRO PROCEDURE GET!-IMAGE!-POLY S; CADR CDDR CDDR S; SMACRO PROCEDURE GET!-F!-NUMVEC S; CADR CDDR CDDDR S; SMACRO PROCEDURE PUT!-IMAGE!-POLY!-AND!-CONTENT(S,IMCONT,IMPOL); LIST(GET!-IMAGE!-SET S, GET!-CHOSEN!-PRIME S, GET!-IMAGE!-LC S, GET!-IMAGE!-MOD!-P S, IMCONT, IMPOL, GET!-F!-NUMVEC S); FLUID '( !*GCD !*EXP SAFE!-FLAG BASE!-TIME GC!-BASE!-TIME LAST!-DISPLAYED!-TIME LAST!-DISPLAYED!-GC!-TIME INPUT!-POLYNOMIAL PRIMES CURRENT!-MODULUS MODULUS!/2 POLY!-MOD!-P INPUT!-LEADING!-COEFFICIENT INPUT!-NORM INPUT!-MAIN!-VARIABLE NUMBER!-NEEDED BEST!-VARIABLE KNOWN!-FACTORS X!*!*P DX!*!*P WORK!-VECTOR1 DWORK1 WORK!-VECTOR2 DWORK2 POLY!-VECTOR DPOLY LINEAR!-FACTORS NULL!-SPACE!-BASIS SPLIT!-LIST FACTOR!-COUNT BEST!-FACTOR!-COUNT BEST!-KNOWN!-FACTORS MODULAR!-SPLITTINGS BEST!-MODULUS VALID!-IMAGE!-SETS FACTORED!-LC MULTIVARIATE!-INPUT!-POLY BEST!-SET!-POINTER IMAGE!-FACTORS TRUE!-LEADING!-COEFFTS IRREDUCIBLE INVERTED INVERTED!-SIGN NUMBER!-OF!-FACTORS M!-IMAGE!-VARIABLE MODULAR!-VALUES NO!-OF!-RANDOM!-SETS NO!-OF!-BEST!-SETS IMAGE!-SET!-MODULUS !*ALL!-CONTENTS FACTOR!-X SFP!-COUNT FACTOR!-TRACE!-LIST FACTOR!-LEVEL !*OVERVIEW !*OVERSHOOT NON!-MONIC !*NEW!-TIMES!-MOD!-P POLYNOMIAL!-TO!-FACTOR FORBIDDEN!-SETS FORBIDDEN!-PRIMES VARS!-TO!-KILL ZERO!-SET!-TRIED BAD!-CASE PREVIOUS!-DEGREE!-MAP TARGET!-FACTOR!-COUNT MODULAR!-INFO MULTIVARIATE!-FACTORS IMAGE!-SET CHOSEN!-PRIME IMAGE!-LC IMAGE!-MOD!-P IMAGE!-CONTENT IMAGE!-POLY F!-NUMVEC VALID!-PRIMES UNIVARIATE!-INPUT!-POLY NO!-OF!-RANDOM!-PRIMES NO!-OF!-BEST!-PRIMES UNIVARIATE!-FACTORS !*FORCE!-PRIME !*FORCE!-ZERO!-SET !*LINEAR !*MULTIVARIATE!-TREATMENT !*TIMINGS RECONSTRUCTING!-GCD FULL!-GCD PREDICTIONS PRIME!-BASE ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE DEGREE!-BOUNDS UNKNOWNS!-LIST UNKNOWN DEG!-OF!-UNKNOWN DIVISOR!-FOR!-UNKNOWN DIFFERENCE!-FOR!-UNKNOWN BEST!-KNOWN!-FACTOR!-LIST COEFFT!-VECTORS REDUCED!-DEGREE!-LCLST UNLUCKY!-CASE !*KERNREVERSE EXACT!-QUOTIENT!-FLAG NUMBER!-OF!-UNKNOWNS MAX!-UNKNOWNS USER!-PRIME NN !*LINEAR FACTORS!-DONE COEFFTBD HENSEL!-POLY ZEROVARSET ZSET OTHERVARS SAVE!-ZSET REDUCTION!-COUNT ); !*TIMINGS:=NIL; % Default not to displaying timings; !*OVERSHOOT:=NIL; % Default not to show overshoot occurring; RECONSTRUCTING!-GCD:=NIL; % This is primarily a factorizer! ; FLUID '(HENSEL!-GROWTH!-SIZE ALPHALIST); FLUID '( FACVEC FHATVEC FACTORVEC MODFVEC ALPHAVEC DELFVEC DELTAM CURRENT!-FACTOR!-PRODUCT ); GLOBAL '(POSN!* SPARE!*); %used in TTAB*; SYMBOLIC PROCEDURE TTAB!* N; << IF N>(LINELENGTH NIL - SPARE!*) THEN N:=0; IF POSN!* > N THEN TERPRI!*(NIL); WHILE NOT(POSN!*=N) DO PRIN2!* '! >>; SMACRO PROCEDURE PRINTSTR L; << PRIN2!* L; TERPRI!*(NIL) >>; SYMBOLIC PROCEDURE FAC!-PRINTSF A; << IF A THEN XPRINF(A,NIL,NIL) ELSE PRIN2!* 0; TERPRI!* NIL >>; SMACRO PROCEDURE PRINSF U; IF U THEN XPRINF(U,NIL,NIL) ELSE PRIN2!* 0; SMACRO PROCEDURE PRINTVAR V; PRINTSTR V; SMACRO PROCEDURE PRINVAR V; PRIN2!* V; SYMBOLIC PROCEDURE PRINTVEC(STR1,N,STR2,V); << FOR I:=1:N DO << PRIN2!* STR1; PRIN2!* I; PRIN2!* STR2; FAC!-PRINTSF GETV(V,I) >>; TERPRI!*(NIL) >>; SMACRO PROCEDURE DISPLAY!-TIME(STR,MT); % Displays the string str followed by time mt (millisecs); << PRINC STR; PRINC MT; PRINTC " millisecs." >>; % trace control package. % %; SMACRO PROCEDURE TRACE!-TIME ACTION; IF !*TIMINGS THEN ACTION; SMACRO PROCEDURE NEW!-LEVEL(N,C); (LAMBDA FACTOR!-LEVEL; C) N; SYMBOLIC PROCEDURE SET!-TRACE!-FACTOR(N,FILE); FACTOR!-TRACE!-LIST:=(N . (IF FILE=NIL THEN NIL ELSE OPEN(MKFIL FILE,'OUTPUT))) . FACTOR!-TRACE!-LIST; SYMBOLIC PROCEDURE CLEAR!-TRACE!-FACTOR N; BEGIN SCALAR W; W := ASSOC(N,FACTOR!-TRACE!-LIST); IF W THEN << IF CDR W THEN CLOSE CDR W; FACTOR!-TRACE!-LIST:=DELASC(N,FACTOR!-TRACE!-LIST) >>; RETURN NIL END; SYMBOLIC PROCEDURE CLOSE!-TRACE!-FILES(); << WHILE FACTOR!-TRACE!-LIST DO CLEAR!-TRACE!-FACTOR(CAAR FACTOR!-TRACE!-LIST); NIL >>; FACTOR!-TRACE!-LIST:=NIL; FACTOR!-LEVEL:=0; % start with a numeric value; ENDMODULE; MODULE ALPHAS; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %********************************************************************; % % this section contains access and update functions for the alphas; SYMBOLIC PROCEDURE GET!-ALPHA POLY; % gets the poly and its associated alpha from the current alphalist % if poly is not on the alphalist then we force an error; BEGIN SCALAR W; W:=ASSOC!-ALPHA(POLY,ALPHALIST); IF NULL W THEN ERRORF LIST("Alpha not found for ",POLY," in ", ALPHALIST); RETURN W END; SYMBOLIC PROCEDURE DIVIDE!-ALL!-ALPHAS N; % multiply the factors by n mod p and alter the alphas accordingly; BEGIN SCALAR OM,M; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; M:=MODULAR!-EXPT( MODULAR!-RECIPROCAL MODULAR!-NUMBER N, NUMBER!-OF!-FACTORS #- 1); ALPHALIST:=FOR EACH A IN ALPHALIST COLLECT (TIMES!-MOD!-P(N,CAR A) . TIMES!-MOD!-P(M,CDR A)); SET!-MODULUS OM END; SYMBOLIC PROCEDURE MULTIPLY!-ALPHAS(N,OLDPOLY,NEWPOLY); % multiply all the alphas except the one associated with oldpoly % by n mod p. also replace oldpoly by newpoly in the alphalist; BEGIN SCALAR OM,FACA,W; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; N:=MODULAR!-NUMBER N; OLDPOLY:=REDUCE!-MOD!-P OLDPOLY; FACA:=GET!-ALPHA OLDPOLY; ALPHALIST:=DELETE(FACA,ALPHALIST); ALPHALIST:=FOR EACH A IN ALPHALIST COLLECT CAR A . TIMES!-MOD!-P(CDR A,N); ALPHALIST:=(REDUCE!-MOD!-P NEWPOLY . CDR FACA) . ALPHALIST; SET!-MODULUS OM END; SYMBOLIC PROCEDURE MULTIPLY!-ALPHAS!-RECIP(N,OLDPOLY,NEWPOLY); % multiply all the alphas except the one associated with oldpoly % by the reciprocal mod p of n. also replace oldpoly by newpoly; BEGIN SCALAR OM,W; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; N:=MODULAR!-RECIPROCAL MODULAR!-NUMBER N; W:=MULTIPLY!-ALPHAS(N,OLDPOLY,NEWPOLY); SET!-MODULUS OM; RETURN W END; ENDMODULE; MODULE BIGMODP; % (C) Copyright 1981, University of Cambridge; % Modular arithmetic where the modulus may be a bignum. % Currently only called from section UNIHENS; SYMBOLIC PROCEDURE SET!-GENERAL!-MODULUS P; IF NOT NUMBERP P THEN CURRENT!-MODULUS ELSE BEGIN SCALAR PREVIOUS!-MODULUS; PREVIOUS!-MODULUS:=CURRENT!-MODULUS; CURRENT!-MODULUS:=P; MODULUS!/2 := P/2; RETURN PREVIOUS!-MODULUS END; SYMBOLIC PROCEDURE GENERAL!-PLUS!-MOD!-P(A,B); % form the sum of the two polynomials a and b % working over the ground domain defined by the routines % general!-modular!-plus, general!-modular!-times etc. the inputs to % this routine are assumed to have coefficients already % in the required domain; IF NULL A THEN B ELSE IF NULL B THEN A ELSE IF ISDOMAIN A THEN IF ISDOMAIN B THEN !*NUM2F GENERAL!-MODULAR!-PLUS(A,B) ELSE (LT B) .+ GENERAL!-PLUS!-MOD!-P(A,RED B) ELSE IF ISDOMAIN B THEN (LT A) .+ GENERAL!-PLUS!-MOD!-P(RED A,B) ELSE IF LPOW A = LPOW B THEN ADJOIN!-TERM(LPOW A, GENERAL!-PLUS!-MOD!-P(LC A,LC B), GENERAL!-PLUS!-MOD!-P(RED A,RED B)) ELSE IF COMES!-BEFORE(LPOW A,LPOW B) THEN (LT A) .+ GENERAL!-PLUS!-MOD!-P(RED A,B) ELSE (LT B) .+ GENERAL!-PLUS!-MOD!-P(A,RED B); SYMBOLIC PROCEDURE GENERAL!-TIMES!-MOD!-P(A,B); IF (NULL A) OR (NULL B) THEN NIL ELSE IF ISDOMAIN A THEN GEN!-MULT!-BY!-CONST!-MOD!-P(B,A) ELSE IF ISDOMAIN B THEN GEN!-MULT!-BY!-CONST!-MOD!-P(A,B) ELSE IF MVAR A=MVAR B THEN GENERAL!-PLUS!-MOD!-P( GENERAL!-PLUS!-MOD!-P(GENERAL!-TIMES!-TERM!-MOD!-P(LT A,B), GENERAL!-TIMES!-TERM!-MOD!-P(LT B,RED A)), GENERAL!-TIMES!-MOD!-P(RED A,RED B)) ELSE IF ORDOP(MVAR A,MVAR B) THEN ADJOIN!-TERM(LPOW A,GENERAL!-TIMES!-MOD!-P(LC A,B), GENERAL!-TIMES!-MOD!-P(RED A,B)) ELSE ADJOIN!-TERM(LPOW B, GENERAL!-TIMES!-MOD!-P(A,LC B),GENERAL!-TIMES!-MOD!-P(A,RED B)); SYMBOLIC PROCEDURE GENERAL!-TIMES!-TERM!-MOD!-P(TERM,B); %multiply the given polynomial by the given term; IF NULL B THEN NIL ELSE IF ISDOMAIN B THEN ADJOIN!-TERM(TPOW TERM, GEN!-MULT!-BY!-CONST!-MOD!-P(TC TERM,B),NIL) ELSE IF TVAR TERM=MVAR B THEN ADJOIN!-TERM(MKSP(TVAR TERM,IPLUS(TDEG TERM,LDEG B)), GENERAL!-TIMES!-MOD!-P(TC TERM,LC B), GENERAL!-TIMES!-TERM!-MOD!-P(TERM,RED B)) ELSE IF ORDOP(TVAR TERM,MVAR B) THEN ADJOIN!-TERM(TPOW TERM,GENERAL!-TIMES!-MOD!-P(TC TERM,B),NIL) ELSE ADJOIN!-TERM(LPOW B, GENERAL!-TIMES!-TERM!-MOD!-P(TERM,LC B), GENERAL!-TIMES!-TERM!-MOD!-P(TERM,RED B)); SYMBOLIC PROCEDURE GEN!-MULT!-BY!-CONST!-MOD!-P(A,N); % multiply the polynomial a by the constant n; IF NULL A THEN NIL ELSE IF N=1 THEN A ELSE IF ISDOMAIN A THEN !*NUM2F GENERAL!-MODULAR!-TIMES(A,N) ELSE ADJOIN!-TERM(LPOW A,GEN!-MULT!-BY!-CONST!-MOD!-P(LC A,N), GEN!-MULT!-BY!-CONST!-MOD!-P(RED A,N)); SYMBOLIC PROCEDURE GENERAL!-DIFFERENCE!-MOD!-P(A,B); GENERAL!-PLUS!-MOD!-P(A,GENERAL!-MINUS!-MOD!-P B); SYMBOLIC PROCEDURE GENERAL!-MINUS!-MOD!-P A; IF NULL A THEN NIL ELSE IF ISDOMAIN A THEN GENERAL!-MODULAR!-MINUS A ELSE (LPOW A .* GENERAL!-MINUS!-MOD!-P LC A) .+ GENERAL!-MINUS!-MOD!-P RED A; SYMBOLIC PROCEDURE GENERAL!-REDUCE!-MOD!-P A; %converts a multivariate poly from normal into modular polynomial; IF NULL A THEN NIL ELSE IF ISDOMAIN A THEN !*NUM2F GENERAL!-MODULAR!-NUMBER A ELSE ADJOIN!-TERM(LPOW A, GENERAL!-REDUCE!-MOD!-P LC A, GENERAL!-REDUCE!-MOD!-P RED A); SYMBOLIC PROCEDURE GENERAL!-MAKE!-MODULAR!-SYMMETRIC A; % input is a multivariate MODULAR poly A with nos in the range 0->(p-1). % This folds it onto the symmetric range (-p/2)->(p/2); IF NULL A THEN NIL ELSE IF DOMAINP A THEN IF A>MODULUS!/2 THEN !*NUM2F(A - CURRENT!-MODULUS) ELSE A ELSE ADJOIN!-TERM(LPOW A, GENERAL!-MAKE!-MODULAR!-SYMMETRIC LC A, GENERAL!-MAKE!-MODULAR!-SYMMETRIC RED A); SYMBOLIC PROCEDURE GENERAL!-MODULAR!-PLUS(A,B); BEGIN SCALAR RESULT; RESULT:=A+B; IF RESULT >= CURRENT!-MODULUS THEN RESULT:=RESULT-CURRENT!-MODULUS; RETURN RESULT END; SYMBOLIC PROCEDURE GENERAL!-MODULAR!-DIFFERENCE(A,B); BEGIN SCALAR RESULT; RESULT:=A-B; IF RESULT < 0 THEN RESULT:=RESULT+CURRENT!-MODULUS; RETURN RESULT END; SYMBOLIC PROCEDURE GENERAL!-MODULAR!-NUMBER A; BEGIN A:=REMAINDER(A,CURRENT!-MODULUS); IF A < 0 THEN A:=A+CURRENT!-MODULUS; RETURN A END; SYMBOLIC PROCEDURE GENERAL!-MODULAR!-TIMES(A,B); BEGIN SCALAR RESULT; RESULT:=REMAINDER(A*B,CURRENT!-MODULUS); IF RESULT < 0 THEN RESULT:=RESULT+CURRENT!-MODULUS; RETURN RESULT END; SYMBOLIC PROCEDURE GENERAL!-MODULAR!-RECIPROCAL A; BEGIN RETURN RECIPROCAL!-BY!-GCD(CURRENT!-MODULUS,A,0,1) END; SYMBOLIC PROCEDURE RECIPROCAL!-BY!-GCD(A,B,X,Y); %On input A and B should be coprime. This routine then %finds X and Y such that A*X+B*Y=1, and returns the value Y %on input A > B; IF B=0 THEN ERRORF "INVALID MODULAR DIVISION" ELSE IF B=1 THEN IF Y < 0 THEN Y+CURRENT!-MODULUS ELSE Y ELSE BEGIN SCALAR W; %N.B. Invalid modular division is either: % a) attempt to divide by zero directly % b) modulus is not prime, and input is not % coprime with it; W:=QUOTIENT(A,B); %Truncated integer division; RETURN RECIPROCAL!-BY!-GCD(B,A-B*W,Y,X-Y*W) END; SYMBOLIC PROCEDURE GENERAL!-MODULAR!-QUOTIENT(A,B); GENERAL!-MODULAR!-TIMES(A,GENERAL!-MODULAR!-RECIPROCAL B); SYMBOLIC PROCEDURE GENERAL!-MODULAR!-MINUS A; IF A=0 THEN A ELSE CURRENT!-MODULUS - A; ENDMODULE; MODULE COEFFTS; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % code for trying to determine more multivariate coefficients % by inspection before using multivariate hensel construction. ; SYMBOLIC PROCEDURE DETERMINE!-MORE!-COEFFTS(); % ...; BEGIN SCALAR UNKNOWNS!-LIST,UV,R,W,BEST!-KNOWN!-FACTOR!-LIST; BEST!-KNOWN!-FACTORS:=MKVECT NUMBER!-OF!-FACTORS; UV:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO PUTV(UV,I,CONVERT!-FACTOR!-TO!-TERMVECTOR( GETV(IMAGE!-FACTORS,I),GETV(TRUE!-LEADING!-COEFFTS,I))); R:=RED MULTIVARIATE!-INPUT!-POLY; % we know all about the leading coeffts; IF NOT DEPENDS!-ON!-VAR(R,M!-IMAGE!-VARIABLE) OR NULL(W:=TRY!-FIRST!-COEFFT( LDEG R,LC R,UNKNOWNS!-LIST,UV)) THEN << FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(BEST!-KNOWN!-FACTORS,I,FORCE!-LC( GETV(IMAGE!-FACTORS,I),GETV(TRUE!-LEADING!-COEFFTS,I))); COEFFT!-VECTORS:=UV; RETURN NIL >>; FACTOR!-TRACE << PRINTSTR "By exploiting any sparsity wrt the main variable in the"; PRINTSTR "factors, we can try guessing some of the multivariate"; PRINTSTR "coefficients." >>; TRY!-OTHER!-COEFFTS(R,UNKNOWNS!-LIST,UV); W:=CONVERT!-AND!-TRIAL!-DIVIDE UV; TRACE!-TIME IF FULL!-GCD THEN PRINTC "Possible gcd found" ELSE PRINTC "Have found some coefficients"; RETURN SET!-UP!-GLOBALS(UV,W) END; SYMBOLIC PROCEDURE CONVERT!-FACTOR!-TO!-TERMVECTOR(U,TLC); % ...; BEGIN SCALAR TERMLIST,RES,N,SLIST; TERMLIST:=(LDEG U . TLC) . LIST!-TERMS!-IN!-FACTOR RED U; RES:=MKVECT (N:=LENGTH TERMLIST); FOR I:=1:N DO << SLIST:=(CAAR TERMLIST . I) . SLIST; PUTV(RES,I,CAR TERMLIST); TERMLIST:=CDR TERMLIST >>; PUTV(RES,0,(N . (N #- 1))); UNKNOWNS!-LIST:=(REVERSEWOC SLIST) . UNKNOWNS!-LIST; RETURN RES END; SYMBOLIC PROCEDURE TRY!-FIRST!-COEFFT(N,C,SLIST,UV); % ...; BEGIN SCALAR COMBNS,UNKNOWN,W,L,D,V,M; COMBNS:=GET!-TERM(N,SLIST); IF (COMBNS='NO) OR NOT NULL CDR COMBNS THEN RETURN NIL; L:=CAR COMBNS; FOR I:=1:NUMBER!-OF!-FACTORS DO << W:=GETV(GETV(UV,I),CAR L); % degree . coefft ; IF NULL CDR W THEN << UNKNOWN:=(I . CAR L); D:=CAR W >> ELSE << C:=QUOTF(C,CDR W); IF DIDNTGO C THEN RETURN >>; L:=CDR L >>; IF DIDNTGO C THEN RETURN NIL; PUTV(V:=GETV(UV,CAR UNKNOWN),CDR UNKNOWN,(D . C)); M:=GETV(V,0); PUTV(V,0,(CAR M . (CDR M #- 1))); IF CDR M = 1 AND FACTORS!-COMPLETE UV THEN RETURN 'COMPLETE; RETURN C END; SYMBOLIC PROCEDURE SOLVE!-NEXT!-COEFFT(N,C,SLIST,UV); % ...; BEGIN SCALAR COMBNS,W,UNKNOWN,DEG!-OF!-UNKNOWN,DIVISOR!-FOR!-UNKNOWN, DIFFERENCE!-FOR!-UNKNOWN,V; DIFFERENCE!-FOR!-UNKNOWN:=POLYZERO; DIVISOR!-FOR!-UNKNOWN:=POLYZERO; COMBNS:=GET!-TERM(N,SLIST); IF COMBNS='NO THEN RETURN 'NOGOOD; WHILE COMBNS DO << W:=SPLIT!-TERM!-LIST(CAR COMBNS,UV); IF W='NOGOOD THEN RETURN W; COMBNS:=CDR COMBNS >>; IF W='NOGOOD THEN RETURN W; IF NULL UNKNOWN THEN RETURN; W:=QUOTF(ADDF(C,NEGF DIFFERENCE!-FOR!-UNKNOWN), DIVISOR!-FOR!-UNKNOWN); IF DIDNTGO W THEN RETURN 'NOGOOD; PUTV(V:=GETV(UV,CAR UNKNOWN),CDR UNKNOWN,(DEG!-OF!-UNKNOWN . W)); N:=GETV(V,0); PUTV(V,0,(CAR N . (CDR N #- 1))); IF CDR N = 1 AND FACTORS!-COMPLETE UV THEN RETURN 'COMPLETE; RETURN W END; SYMBOLIC PROCEDURE SPLIT!-TERM!-LIST(TERM!-COMBN,UV); % ...; BEGIN SCALAR A,V,W; A:=1; FOR I:=1:NUMBER!-OF!-FACTORS DO << W:=GETV(GETV(UV,I),CAR TERM!-COMBN); % degree . coefft ; IF NULL CDR W THEN IF V OR (UNKNOWN AND NOT((I.CAR TERM!-COMBN)=UNKNOWN)) THEN RETURN V:='NOGOOD ELSE << UNKNOWN:=(I . CAR TERM!-COMBN); DEG!-OF!-UNKNOWN:=CAR W; V:=UNKNOWN >> ELSE A:=MULTF(A,CDR W); TERM!-COMBN:=CDR TERM!-COMBN >>; IF V='NOGOOD THEN RETURN V; IF V THEN DIVISOR!-FOR!-UNKNOWN:=ADDF(DIVISOR!-FOR!-UNKNOWN,A) ELSE DIFFERENCE!-FOR!-UNKNOWN:=ADDF(DIFFERENCE!-FOR!-UNKNOWN,A); RETURN 'OK END; SYMBOLIC PROCEDURE FACTORS!-COMPLETE UV; % ...; BEGIN SCALAR FACTOR!-NOT!-DONE,R; R:=T; FOR I:=1:NUMBER!-OF!-FACTORS DO IF NOT(CDR GETV(GETV(UV,I),0)=0) THEN IF FACTOR!-NOT!-DONE THEN RETURN R:=NIL ELSE FACTOR!-NOT!-DONE:=T; RETURN R END; SYMBOLIC PROCEDURE CONVERT!-AND!-TRIAL!-DIVIDE UV; % ...; BEGIN SCALAR W,R,FDONE!-PRODUCT!-MOD!-P,OM; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; FDONE!-PRODUCT!-MOD!-P:=1; FOR I:=1:NUMBER!-OF!-FACTORS DO << W:=GETV(UV,I); W:= IF (CDR GETV(W,0))=0 THEN TERMVECTOR2SF W ELSE MERGE!-TERMS(GETV(IMAGE!-FACTORS,I),W); R:=QUOTF(MULTIVARIATE!-INPUT!-POLY,W); IF DIDNTGO R THEN BEST!-KNOWN!-FACTOR!-LIST:= ((I . W) . BEST!-KNOWN!-FACTOR!-LIST) ELSE IF RECONSTRUCTING!-GCD AND I=1 THEN RETURN FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS( LIST W,M!-IMAGE!-VARIABLE,NIL) ELSE W ELSE << MULTIVARIATE!-FACTORS:=W . MULTIVARIATE!-FACTORS; FDONE!-PRODUCT!-MOD!-P:=TIMES!-MOD!-P( REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I), FDONE!-PRODUCT!-MOD!-P); MULTIVARIATE!-INPUT!-POLY:=R >> >>; IF FULL!-GCD THEN RETURN; IF NULL BEST!-KNOWN!-FACTOR!-LIST THEN MULTIVARIATE!-FACTORS:= PRIMITIVE!.PARTS(MULTIVARIATE!-FACTORS,M!-IMAGE!-VARIABLE,NIL) ELSE IF NULL CDR BEST!-KNOWN!-FACTOR!-LIST THEN << IF RECONSTRUCTING!-GCD THEN IF NOT(CAAR BEST!-KNOWN!-FACTOR!-LIST=1) THEN ERRORF("gcd is jiggered in determining other coeffts") ELSE FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS( LIST MULTIVARIATE!-INPUT!-POLY, M!-IMAGE!-VARIABLE,NIL) ELSE MULTIVARIATE!-INPUT!-POLY ELSE MULTIVARIATE!-FACTORS:=PRIMITIVE!.PARTS( MULTIVARIATE!-INPUT!-POLY . MULTIVARIATE!-FACTORS, M!-IMAGE!-VARIABLE,NIL); BEST!-KNOWN!-FACTOR!-LIST:=NIL >>; FACTOR!-TRACE << IF NULL BEST!-KNOWN!-FACTOR!-LIST THEN PRINTSTR "We have completely determined all the factors this way" ELSE IF MULTIVARIATE!-FACTORS THEN << PRIN2!* "We have completely determined the following factor"; PRINTSTR IF (LENGTH MULTIVARIATE!-FACTORS)=1 THEN ":" ELSE "s:"; FOR EACH WW IN MULTIVARIATE!-FACTORS DO FAC!-PRINTSF WW >> >>; SET!-MODULUS OM; RETURN FDONE!-PRODUCT!-MOD!-P END; SYMBOLIC PROCEDURE SET!-UP!-GLOBALS(UV,F!-PRODUCT); IF NULL BEST!-KNOWN!-FACTOR!-LIST OR FULL!-GCD THEN 'DONE ELSE BEGIN SCALAR I,R,N,K,FLIST!-MOD!-P,IMF,OM,SAVEK; N:=LENGTH BEST!-KNOWN!-FACTOR!-LIST; BEST!-KNOWN!-FACTORS:=MKVECT N; COEFFT!-VECTORS:=MKVECT N; R:=MKVECT N; K:=IF RECONSTRUCTING!-GCD THEN 1 ELSE 0; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; FOR EACH W IN BEST!-KNOWN!-FACTOR!-LIST DO << I:=CAR W; W:=CDR W; IF RECONSTRUCTING!-GCD AND I=1 THEN << SAVEK:=K; K:=1 >> ELSE K:=K #+ 1; % in case we are reconstructing gcd we had better know % which is the gcd and which the cofactor - so don't move % move the gcd from elt one; PUTV(R,K,IMF:=GETV(IMAGE!-FACTORS,I)); FLIST!-MOD!-P:=(REDUCE!-MOD!-P IMF) . FLIST!-MOD!-P; PUTV(BEST!-KNOWN!-FACTORS,K,W); PUTV(COEFFT!-VECTORS,K,GETV(UV,I)); IF RECONSTRUCTING!-GCD AND K=1 THEN K:=SAVEK; % restore k if necessary; >>; IF NOT(N=NUMBER!-OF!-FACTORS) THEN << ALPHALIST:=FOR EACH MODF IN FLIST!-MOD!-P COLLECT (MODF . REMAINDER!-MOD!-P(TIMES!-MOD!-P(F!-PRODUCT, CDR GET!-ALPHA MODF),MODF)); NUMBER!-OF!-FACTORS:=N >>; SET!-MODULUS OM; IMAGE!-FACTORS:=R; RETURN 'NEED! TO! RECONSTRUCT END; SYMBOLIC PROCEDURE GET!-TERM(N,L); % ...; IF N#<0 THEN 'NO ELSE IF NULL CDR L THEN GET!-TERM!-N(N,CAR L) ELSE BEGIN SCALAR W,RES; FOR EACH FTERM IN CAR L DO << W:=GET!-TERM(N#-CAR FTERM,CDR L); IF NOT(W='NO) THEN RES:= APPEND(FOR EACH V IN W COLLECT (CDR FTERM . V),RES) >>; RETURN IF NULL RES THEN 'NO ELSE RES END; SYMBOLIC PROCEDURE GET!-TERM!-N(N,U); IF NULL U OR N #> CAAR U THEN 'NO ELSE IF CAAR U = N THEN LIST(CDAR U . NIL) ELSE GET!-TERM!-N(N,CDR U); ENDMODULE; MODULE CPRES; % part of resultant program; SYMBOLIC PROCEDURE CPRES(A,B,X); % calculates res(A,B) wrt X modulo p; % A and B are multivariate polynomials modulo p with X as main variable; BEGIN INTEGER K, MR, MQ, NR, NQ, NUM!-B, LOOP!-COUNT; SCALAR C, D, NEW!-A, NEW!-B, NEW!-C, Q, V; IF NOT (MVAR A=X AND MVAR B=X) THEN ERRORF "VARIABLE IS NOT IN BOTH POLYNOMIALS"; V := DELETE(X,UNION(VARIABLES!-IN!-FORM A,VARIABLES!-IN!-FORM B)); IF (V = NIL) THEN RETURN NATURAL!-PRS!-ALGORITHM(A,B,X); % simple case; Q := CAR V; % Q is some variable other than X occuring in A or B; MR := LDEG A; NR := LDEG B; MQ := DEGREE!-IN!-VARIABLE(A,Q); NQ := DEGREE!-IN!-VARIABLE(B,Q); K := MR*NQ + NR*MQ; COMMENT limit of degree of resultant in Q; COMMENT I think the given value is wrong; % PRINTC "VALUE OF K IS"; % SUPERPRINT K; % initialise variables ; C := 0; D := 1; NUM!-B := -1; NEW!-A := A; NEW!-B := B; % main loop starts here; WHILE (LEADING!-DEGREE D <= K) DO BEGIN LOOP!-COUNT := 0; % ensures going round inner loop >= once; % I'd use a boolean but there aren't any; % PRINTC "VALUE OF D IS"; % SUPERPRINT D; WHILE ((DEGREE!-IN!-VARIABLE(NEW!-A,X) < MR) OR (DEGREE!-IN!-VARIABLE(NEW!-B,X) < NR) OR (LOOP!-COUNT = 0)) DO BEGIN LOOP!-COUNT := 1; NUM!-B := NUM!-B + 1; IF (NUM!-B=SET!-MODULUS 0) THEN ERRORF "PRIME TOO SMALL"; NEW!-A := EVALUATE!-MOD!-P(A,Q,NUM!-B); NEW!-B := EVALUATE!-MOD!-P(B,Q,NUM!-B); % PRINTC "NEW!-A AND NEW!-B ARE"; % SUPERPRINT NEW!-A; % SUPERPRINT NEW!-B; END; % PRINTC "RECURSE HERE"; NEW!-C := CPRES(NEW!-A,NEW!-B,X); COMMENT recursion applied; % PRINTC "VALUE OF NEW!-C AFTER RECURSION IS"; % SUPERPRINT NEW!-C; % PRINTC "VALUE OF NUM!-B IS"; % SUPERPRINT NUM!-B; % PRINTC "INTERPOLATE HERE"; C := INTERPOLATE (D,NUM!-B,C,NEW!-C,Q); % PRINTC "VALUE OF C AFTER INTERPOLATION IS"; % SUPERPRINT C; D := TIMES!-MOD!-P(DIFFERENCE!-MOD!-P (!*K2F Q,!*N2F NUM!-B),D) END; RETURN C END; SYMBOLIC PROCEDURE INTERPOLATE(POLY!-D,NUMBER!-B,POLY!-A,POLY!-C,VAR); % inputs - D = PI(xr - bi) for 0<=i<=k where the bi are distinct ; % elements of GF(p) - B is an element of GF(p) distinct from the ; % bi - A(x1 ... xr) is a poly mod p of degree k or less in xr ; % - C(x1 ... xr-1) is a poly mod p ; % outputs H(x1 ... xr) of degree k+1 or less in xr where H ; % interpolates A for all points xr=bi and also H = C when xr=B ; % VAR = xr ; PLUS!-MOD!-P(POLY!-A, TIMES!-MOD!-P(QUOTIENT!-MOD!-P(POLY!-D, EVALUATE!-MOD!-P(POLY!-D, VAR, NUMBER!-B)), DIFFERENCE!-MOD!-P(POLY!-C, EVALUATE!-MOD!-P(POLY!-A, VAR, NUMBER!-B)))); SYMBOLIC PROCEDURE MAIN!-VARIABLE A; % returns mvar a unless a is numeric, in which case returns nil; IF ISDOMAIN A THEN NIL ELSE MVAR A; ENDMODULE; MODULE DEGSETS; %**********************************************************************; % % copyright (c) university of cambridge, england 1979 % %**********************************************************************; %**********************************************************************; % % degree set processing %; SYMBOLIC PROCEDURE CHECK!-DEGREE!-SETS(N,MULTIVARIATE!-CASE); % MODULAR!-INFO (vector of size N) contains the % modular factors now; BEGIN SCALAR DEGREE!-SETS,W,X!-IS!-FACTOR,DEGS; W:=SPLIT!-LIST; FOR I:=1:N DO << IF MULTIVARIATE!-CASE THEN X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT GETV(VALID!-IMAGE!-SETS,CDAR W); DEGS:=FOR EACH V IN GETV(MODULAR!-INFO,CDAR W) COLLECT LDEG V; DEGREE!-SETS:= (IF X!-IS!-FACTOR THEN 1 . DEGS ELSE DEGS) . DEGREE!-SETS; W:=CDR W >>; CHECK!-DEGREE!-SETS!-1 DEGREE!-SETS; BEST!-SET!-POINTER:=CDAR SPLIT!-LIST; IF MULTIVARIATE!-CASE AND FACTORED!-LC THEN << WHILE NULL(W:=GET!-F!-NUMVEC GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER)) AND (SPLIT!-LIST:=CDR SPLIT!-LIST) DO BEST!-SET!-POINTER:=CDAR SPLIT!-LIST; IF NULL W THEN BAD!-CASE:=T >>; % make sure the set is ok for distributing the % leading coefft where necessary; END; SYMBOLIC PROCEDURE CHECK!-DEGREE!-SETS!-1 L; % L is a list of degree sets. Try to discover if the entries % in it are consistent, or if they imply that some of the % modular splittings were 'false'; BEGIN SCALAR I,DEGREE!-MAP,DEGREE!-MAP1,DPOLY, PLAUSIBLE!-SPLIT!-FOUND,TARGET!-COUNT; FACTOR!-TRACE << PRINTC "Degree sets are:"; FOR EACH S IN L DO << PRINC " "; FOR EACH N IN S DO << PRINC " "; PRINC N >>; TERPRI() >> >>; DPOLY:=SUM!-LIST CAR L; TARGET!-COUNT:=LENGTH CAR L; FOR EACH S IN CDR L DO TARGET!-COUNT:=IMIN(TARGET!-COUNT, LENGTH S); IF NULL PREVIOUS!-DEGREE!-MAP THEN << DEGREE!-MAP:=MKVECT DPOLY; % To begin with all degrees of factors may be possible; FOR I:=0:DPOLY DO PUTV(DEGREE!-MAP,I,T) >> ELSE << FACTOR!-TRACE "Refine an existing degree map"; DEGREE!-MAP:=PREVIOUS!-DEGREE!-MAP >>; DEGREE!-MAP1:=MKVECT DPOLY; FOR EACH S IN L DO << % For each degree set S I will collect in DEGREE-MAP1 a % bitmap showing what degree factors would be consistent % with that set. By ANDing together all these maps % (into DEGREE-MAP) I find what degrees for factors are % consistent with the whole of the information I have; FOR I:=0:DPOLY DO PUTV(DEGREE!-MAP1,I,NIL); PUTV(DEGREE!-MAP1,0,T); PUTV(DEGREE!-MAP1,DPOLY,T); FOR EACH D IN S DO FOR I:=DPOLY#-D#-1 STEP -1 UNTIL 0 DO IF GETV(DEGREE!-MAP1,I) THEN PUTV(DEGREE!-MAP1,I#+D,T); FOR I:=0:DPOLY DO PUTV(DEGREE!-MAP,I,GETV(DEGREE!-MAP,I) AND GETV(DEGREE!-MAP1,I)) >>; FACTOR!-TRACE << PRINTC "Possible degrees for factors are: "; FOR I:=1:DPOLY#-1 DO IF GETV(DEGREE!-MAP,I) THEN << PRINC I; PRINC " " >>; TERPRI() >>; I:=DPOLY#-1; WHILE I#>0 DO IF GETV(DEGREE!-MAP,I) THEN I:=-1 ELSE I:=I#-1; IF I=0 THEN << FACTOR!-TRACE PRINTC "Degree analysis proves polynomial irreducible"; RETURN IRREDUCIBLE:=T >>; FOR EACH S IN L DO IF LENGTH S=TARGET!-COUNT THEN BEGIN % Sets with too many factors are not plausible anyway; I:=S; WHILE I AND GETV(DEGREE!-MAP,CAR I) DO I:=CDR I; % If I drop through with I null it was because the set was % consistent, otherwise it represented a false split; IF NULL I THEN PLAUSIBLE!-SPLIT!-FOUND:=T END; PREVIOUS!-DEGREE!-MAP:=DEGREE!-MAP; IF PLAUSIBLE!-SPLIT!-FOUND OR ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE THEN RETURN NIL; % PRINTC "Going to try getting some more images"; RETURN BAD!-CASE:=T END; SYMBOLIC PROCEDURE SUM!-LIST L; IF NULL CDR L THEN CAR L ELSE CAR L #+ SUM!-LIST CDR L; ENDMODULE; MODULE EZGCD; % ******************************************************************* % % copyright (c) university of cambridge, england 1981 % % *******************************************************************; % polynomial gcd algorithms; % % a. c. norman. 1981. % % %**********************************************************************; SYMBOLIC PROCEDURE EZGCDF(U,V); %entry point for REDUCE call in GCDF; BEGIN SCALAR FACTOR!-LEVEL; FACTOR!-LEVEL := 0; RETURN POLY!-ABS GCDLIST LIST(U,V) END; %SYMBOLIC PROCEDURE SIMPEZGCD U; % calculate the gcd of the polynomials given as arguments; % BEGIN % SCALAR FACTOR!-LEVEL,W; % FACTOR!-LEVEL:=0; % U := FOR EACH P IN U COLLECT << % W := SIMP!* P; % IF (DENR W NEQ 1) THEN % REDERR "EZGCD requires polynomial arguments"; % NUMR W >>; % RETURN (POLY!-ABS GCDLIST U) ./ 1 % END; %PUT('EZGCD,'SIMPFN,'SIMPEZGCD); SYMBOLIC PROCEDURE SIMPNPRIMITIVE P; % Remove any simple numeric factors from the expression P; BEGIN SCALAR NP,DP; IF ATOM P OR NOT ATOM CDR P THEN REDERR "NPRIMITIVE requires just one argument"; P := SIMP!* CAR P; IF POLYZEROP(NUMR P) THEN RETURN NIL ./ 1; NP := QUOTFAIL(NUMR P,NUMERIC!-CONTENT NUMR P); DP := QUOTFAIL(DENR P,NUMERIC!-CONTENT DENR P); RETURN (NP ./ DP) END; PUT('NPRIMITIVE,'SIMPFN,'SIMPNPRIMITIVE); SYMBOLIC PROCEDURE POLY!-GCD(U,V); %U and V are standard forms. %Value is the gcd of U and V; BEGIN SCALAR XEXP,Y,Z; IF POLYZEROP U THEN RETURN POLY!-ABS V ELSE IF POLYZEROP V THEN RETURN POLY!-ABS U ELSE IF U=1 OR V=1 THEN RETURN 1; XEXP := !*EXP; !*EXP := T; % The case of one argument exactly dividing the other is % detected specially here because it is perhaps a fairly % common circumstance; IF QUOTF1(U,V) THEN Z := V ELSE IF QUOTF1(V,U) THEN Z := U ELSE IF !*GCD THEN Z := GCDLIST LIST(U,V) ELSE Z := 1; !*EXP := XEXP; RETURN POLY!-ABS Z END; MOVED('GCDF,'POLY!-GCD); SYMBOLIC PROCEDURE EZGCD!-COMFAC P; %P is a standard form %CAR of result is lowest common power of leading kernel in %every term in P (or NIL). CDR is gcd of all coefficients of %powers of leading kernel; IF DOMAINP P THEN NIL . POLY!-ABS P ELSE IF NULL RED P THEN LPOW P . POLY!-ABS LC P ELSE BEGIN SCALAR POWER,COEFLIST,VAR; % POWER will be the first part of the answer returned, % COEFLIST will collect a list of all coefs in the polynomial % P viewed as a poly in its main variable, % VAR is the main variable concerned; VAR := MVAR P; WHILE MVAR P=VAR AND NOT DOMAINP RED P DO << COEFLIST := LC P . COEFLIST; P:=RED P >>; IF MVAR P=VAR THEN << COEFLIST := LC P . COEFLIST; IF NULL RED P THEN POWER := LPOW P ELSE COEFLIST := RED P . COEFLIST >> ELSE COEFLIST := P . COEFLIST; RETURN POWER . GCDLIST COEFLIST END; GLOBAL '(!*FLOAT); SYMBOLIC PROCEDURE GCD!-WITH!-NUMBER(N,A); % n is a number, a is a polynomial - return their gcd, given that % n is non-zero; IF N=1 OR NOT ATOM N OR !*FLOAT THEN 1 ELSE IF DOMAINP A THEN IF A=NIL THEN ABS N ELSE IF NOT ATOM A THEN 1 ELSE GCD(N,A) ELSE GCD!-WITH!-NUMBER(GCD!-WITH!-NUMBER(N,LC A),RED A); MOVED('GCDFD,'GCD!-WITH!-NUMBER); SYMBOLIC PROCEDURE CONTENTS!-WITH!-RESPECT!-TO(P,V); IF DOMAINP P THEN NIL . POLY!-ABS P ELSE IF MVAR P=V THEN EZGCD!-COMFAC P ELSE BEGIN SCALAR Y,W; Y := SETKORDER LIST V; P := REORDER P; W := EZGCD!-COMFAC P; SETKORDER Y; P := REORDER P; RETURN REORDER W END; SYMBOLIC PROCEDURE NUMERIC!-CONTENT FORM; % Find numeric content of non-zero polynomial; IF DOMAINP FORM THEN ABS FORM ELSE IF NULL RED FORM THEN NUMERIC!-CONTENT LC FORM ELSE BEGIN SCALAR G1; G1 := NUMERIC!-CONTENT LC FORM; IF NOT (G1=1) THEN G1 := GCD(G1,NUMERIC!-CONTENT RED FORM); RETURN G1 END; SYMBOLIC PROCEDURE GCDLIST L; % Return the GCD of all the polynomials in the list L. % % First find all variables mentioned in the polynomials in L, % and remove monomial content from them all. If in the process % a constant poly is found, take special action. If then there % is some variable that is mentioned in all the polys in L, and % which occurs only linearly in one of them establish that as % main variable and proceed to GCDLIST3 (which will take s % a special case exit). Otherwise, if there are any variables that % do not occur in all the polys in L they can not occur in the GCD, % so take coefficients with respect to them to get a longer list of % smaller polynomials - restart. Finally we have a set of polys % all involving exactly the same set of variables; IF NULL L THEN NIL ELSE IF NULL CDR L THEN POLY!-ABS CAR L ELSE IF DOMAINP CAR L THEN GCDLD(CDR L,CAR L) ELSE BEGIN SCALAR L1,GCONT,X; % Copy L to L1, but on the way detect any domain elements % and deal with them specially; WHILE NOT NULL L DO << IF NULL CAR L THEN L := CDR L ELSE IF DOMAINP CAR L THEN << L1 := LIST LIST GCDLD(CDR L,GCDLD(MAPCARCAR L1,CAR L)); L := NIL >> ELSE << L1 := (CAR L . POWERS1 CAR L) . L1; L := CDR L >> >>; IF NULL L1 THEN RETURN NIL ELSE IF NULL CDR L1 THEN RETURN POLY!-ABS CAAR L1; % Now L1 is a list where each polynomial is paired with information % about the powers of variables in it; GCONT := NIL; % Compute monomial content on things in L; X := NIL; % First time round flag; L := FOR EACH P IN L1 COLLECT BEGIN SCALAR GCONT1,GCONT2,W; % Set GCONT1 to least power information, and W to power % difference; W := FOR EACH Y IN CDR P COLLECT << GCONT1 := (CAR Y . CDDR Y) . GCONT1; CAR Y . (CADR Y-CDDR Y) >>; % Now get the monomial content as a standard form (in GCONT2); GCONT2 := NUMERIC!-CONTENT CAR P; IF NULL X THEN << GCONT := GCONT1; X := GCONT2 >> ELSE << GCONT := VINTERSECTION(GCONT,GCONT1); % Accumulate monomial gcd; X := GCD(X,GCONT2) >>; FOR EACH Q IN GCONT1 DO IF NOT CDR Q=0 THEN GCONT2 := MULTF(GCONT2,!*P2F MKSP(CAR Q,CDR Q)); RETURN QUOTFAIL1(CAR P,GCONT2,"Term content division failed") . W END; % Here X is the numeric part of the final GCD; FOR EACH Q IN GCONT DO X := MULTF(X,!*P2F MKSP(CAR Q,CDR Q)); TRACE!-TIME << PRIN2!* "Term gcd = "; FAC!-PRINTSF X >>; RETURN POLY!-ABS MULTF(X,GCDLIST1 L) END; SYMBOLIC PROCEDURE GCDLIST1 L; % Items in L are monomial-primitive, and paired with power information. % Find out what variables are common to all polynomials in L and % remove all others; BEGIN SCALAR UNIONV,INTERSECTIONV,VORD,X,L1,REDUCTION!-COUNT; UNIONV := INTERSECTIONV := CDAR L; FOR EACH P IN CDR L DO << UNIONV := VUNION(UNIONV,CDR P); INTERSECTIONV := VINTERSECTION(INTERSECTIONV,CDR P) >>; IF NULL INTERSECTIONV THEN RETURN 1; FOR EACH V IN INTERSECTIONV DO UNIONV := VDELETE(V,UNIONV); % Now UNIONV is list of those variables mentioned that % are not common to all polynomials; INTERSECTIONV := SORT(INTERSECTIONV,FUNCTION LESSPCDR); IF CDAR INTERSECTIONV=1 THEN << % I have found something that is linear in one of its variables; VORD := MAPCARCAR APPEND(INTERSECTIONV,UNIONV); L1 := SETKORDER VORD; TRACE!-TIME << PRINC "Selecting "; PRINC CAAR INTERSECTIONV; PRINTC " as main because some poly is linear in it" >>; X := GCDLIST3(FOR EACH P IN L COLLECT REORDER CAR P,NIL,VORD); SETKORDER L1; RETURN REORDER X >> ELSE IF NULL UNIONV THEN RETURN GCDLIST2(L,INTERSECTIONV); TRACE!-TIME << PRINC "The variables "; PRINC UNIONV; PRINTC " can be removed" >>; VORD := SETKORDER MAPCARCAR APPEND(UNIONV,INTERSECTIONV); L1 := NIL; FOR EACH P IN L DO L1:=SPLIT!-WRT!-VARIABLES(REORDER CAR P,MAPCARCAR UNIONV,L1); SETKORDER VORD; RETURN GCDLIST1(FOR EACH P IN L1 COLLECT (REORDER P . TOTAL!-DEGREE!-IN!-POWERS(P,NIL))) END; SYMBOLIC PROCEDURE GCDLIST2(L,VARS); % Here all the variables in VARS are used in every polynomial % in L. Select a good variable ordering; BEGIN SCALAR X,X1,GG,LMODP,ONESTEP,VORD,OLDMOD,IMAGE!-SET,GCDPOW, UNLUCKY!-CASE; % In the univariate case I do not need to think very hard about % the selection of a main variable!! ; IF NULL CDR VARS THEN RETURN GCDLIST3(MAPCARCAR L,NIL,LIST CAAR VARS); OLDMOD := SET!-MODULUS NIL; % If some variable appears at most to degree two in some pair % of the polynomials then that will do as a main variable; VARS := MAPCARCAR SORT(VARS,FUNCTION GREATERPCDR); % Vars is now arranged with the variable that appears to highest % degree anywhere in L first, and the rest in descending order; L := FOR EACH P IN L COLLECT CAR P . SORT(CDR P,FUNCTION LESSPCDR); L := SORT(L,FUNCTION LESSPCDADR); % Each list of degree information in L is sorted with lowest degree % vars first, and the polynomial with the lowest degree variable % of all will come first; X := INTERSECTION(DEG2VARS(CDAR L),DEG2VARS(CDADR L)); IF NOT NULL X THEN << TRACE!-TIME << PRINC "Two inputs are at worst quadratic in "; PRINTC CAR X >>; GO TO X!-TO!-TOP >>; % Here I have found two polys with a common % variable that they are quadratic in; % Now generate modular images of the gcd to guess its degree wrt % all possible variables; % If either (a) modular gcd=1 or (b) modular gcd can be computed with % just 1 reduction step, use that information to choose a main variable; TRY!-AGAIN: % Modular images may be degenerate; SET!-MODULUS RANDOM!-PRIME(); UNLUCKY!-CASE := NIL; IMAGE!-SET := FOR EACH V IN VARS COLLECT (V . MODULAR!-NUMBER RANDOM()); TRACE!-TIME << PRINC "Select variable ordering using P="; PRINC CURRENT!-MODULUS; PRINC " and substitutions from "; PRINTC IMAGE!-SET >>; X1 := VARS; TRY!-VARS: IF NULL X1 THEN GO TO IMAGES!-TRIED; LMODP := FOR EACH P IN L COLLECT MAKE!-IMAGE!-MOD!-P(CAR P,CAR X1); IF UNLUCKY!-CASE THEN GO TO TRY!-AGAIN; LMODP := SORT(LMODP,FUNCTION LESSPDEG); GG := GCDLIST!-MOD!-P(CAR LMODP,CDR LMODP); IF DOMAINP GG OR (REDUCTION!-COUNT<2 AND (ONESTEP:=T)) THEN << TRACE!-TIME << PRINC "Select "; PRINTC CAR X1 >>; X := LIST CAR X1; GO TO X!-TO!-TOP >>; GCDPOW := (CAR X1 . LDEG GG) . GCDPOW; X1 := CDR X1; GO TO TRY!-VARS; IMAGES!-TRIED: % In default of anything better to do, use image variable such that % degree of gcd wrt it is as large as possible; VORD := MAPCARCAR SORT(GCDPOW,FUNCTION GREATERPCDR); TRACE!-TIME << PRINC "Select order by degrees: "; PRINTC GCDPOW >>; GO TO ORDER!-CHOSEN; X!-TO!-TOP: FOR EACH V IN X DO VARS := DELETE(V,VARS); VORD := APPEND(X,VARS); ORDER!-CHOSEN: TRACE!-TIME << PRINC "Selected Var order = "; PRINTC VORD >>; SET!-MODULUS OLDMOD; VARS := SETKORDER VORD; X := GCDLIST3(FOR EACH P IN L COLLECT REORDER CAR P,ONESTEP,VORD); SETKORDER VARS; RETURN REORDER X END; SYMBOLIC PROCEDURE GCDLIST!-MOD!-P(GG,L); IF NULL L THEN GG ELSE IF GG=1 THEN 1 ELSE GCDLIST!-MOD!-P(GCD!-MOD!-P(GG,CAR L),CDR L); SYMBOLIC PROCEDURE DEG2VARS L; IF NULL L THEN NIL ELSE IF CDAR L>2 THEN NIL ELSE CAAR L . DEG2VARS CDR L; SYMBOLIC PROCEDURE VDELETE(A,B); IF NULL B THEN NIL ELSE IF CAR A=CAAR B THEN CDR B ELSE CAR B . VDELETE(A,CDR B); SYMBOLIC PROCEDURE INTERSECTION(U,V); IF NULL U THEN NIL ELSE IF MEMBER(CAR U,V) THEN CAR U . INTERSECTION(CDR U,V) ELSE INTERSECTION(CDR U,V); SYMBOLIC PROCEDURE VINTERSECTION(A,B); BEGIN SCALAR C; RETURN IF NULL A THEN NIL ELSE IF NULL (C:=ASSOC(CAAR A,B)) THEN VINTERSECTION(CDR A,B) ELSE IF CDAR A>CDR C THEN IF CDR C=0 THEN VINTERSECTION(CDR A,B) ELSE C . VINTERSECTION(CDR A,B) ELSE IF CDAR A=0 THEN VINTERSECTION(CDR A,B) ELSE CAR A . VINTERSECTION(CDR A,B) END; SYMBOLIC PROCEDURE VUNION(A,B); BEGIN SCALAR C; RETURN IF NULL A THEN B ELSE IF NULL (C:=ASSOC(CAAR A,B)) THEN CAR A . VUNION(CDR A,B) ELSE IF CDAR A>CDR C THEN CAR A . VUNION(CDR A,DELETE(C,B)) ELSE C . VUNION(CDR A,DELETE(C,B)) END; SYMBOLIC PROCEDURE MAPCARCAR L; FOR EACH X IN L COLLECT CAR X; SYMBOLIC PROCEDURE GCDLD(L,N); % GCD of the domain element N and all the polys in L; IF N=1 OR N=-1 THEN 1 ELSE IF L=NIL THEN ABS N ELSE IF CAR L=NIL THEN GCDLD(CDR L,N) ELSE GCDLD(CDR L,GCD!-WITH!-NUMBER(N,CAR L)); SYMBOLIC PROCEDURE SPLIT!-WRT!-VARIABLES(P,VL,L); % Push all the coeffs in P wrt variables in VL onto the list L % Stop if 1 is found as a coeff; IF P=NIL THEN L ELSE IF NOT NULL L AND CAR L=1 THEN L ELSE IF DOMAINP P THEN ABS P . L ELSE IF MEMBER(MVAR P,VL) THEN SPLIT!-WRT!-VARIABLES(RED P,VL,SPLIT!-WRT!-VARIABLES(LC P,VL,L)) ELSE P . L; SYMBOLIC PROCEDURE GCDLIST3(L,ONESTEP,VLIST); % GCD of the nontrivial polys in the list L given that they all % involve all the variables that any of them mention, % and they are all monomial-primitive. % ONESTEP is true if it is predicted that only one PRS step % will be needed to compute the gcd - if so try that PRS step; BEGIN SCALAR OLD!-MODULUS,PRIME,UNLUCKY!-CASE,IMAGE!-SET,GG,GCONT, COFACTOR,ZEROS!-LIST,L1,W,LCG,W1,REDUCED!-DEGREE!-LCLST,P1,P2; % Make all the polys primitive; L1:=FOR EACH P IN L COLLECT P . EZGCD!-COMFAC P; L:=FOR EACH C IN L1 COLLECT QUOTFAIL1(CAR C,COMFAC!-TO!-POLY CDR C, "Content divison in GCDLIST3 failed"); % All polys in L are now primitive; % Because all polys were monomial-primitive, there should % be no power of V to go in the result; GCONT:=GCDLIST FOR EACH C IN L1 COLLECT CDDR C; IF DOMAINP GCONT THEN IF NOT GCONT=1 THEN ERRORF "GCONT has numeric part"; % GCD of contents complete now; IF DOMAINP (GG:=CAR (L:=SORT(L,FUNCTION DEGREE!-ORDER))) THEN RETURN GCONT; % Primitive part of one poly is a constant (must be +/-1); IF LDEG GG=1 THEN << % True gcd is either GG or 1; IF DIVISION!-TEST(GG,L) THEN RETURN MULTF(POLY!-ABS GG,GCONT) ELSE RETURN GCONT >>; % All polys are now primitive and nontrivial. Use a modular % method to extract GCD; IF ONESTEP THEN << % Try to take gcd in just one pseudoremainder step, because some % previous modular test suggests it may be possible; P1 := POLY!-ABS CAR L; P2 := POLY!-ABS CADR L; IF P1=P2 THEN << IF DIVISION!-TEST(P1,CDDR L) THEN RETURN MULTF(P1,GCONT) >> ELSE << TRACE!-TIME PRINTC "Just one pseudoremainder step needed?"; GG := POLY!-GCD(LC P1,LC P2); GG := EZGCD!-PP ADDF(MULTF(RED P1, QUOTFAIL1(LC P2,GG, "Division failure when just one pseudoremainder step needed")), MULTF(RED P2,NEGF QUOTFAIL1(LC P1,GG, "Division failure when just one pseudoremainder step needed"))); TRACE!-TIME FAC!-PRINTSF GG; IF DIVISION!-TEST(GG,L) THEN RETURN MULTF(GG,GCONT) >> >>; OLD!-MODULUS:=SET!-MODULUS NIL; %Remember modulus; LCG:=FOR EACH POLY IN L COLLECT LC POLY; TRACE!-TIME << PRINTC "L.C.S OF L ARE:"; FOR EACH LCPOLY IN LCG DO FAC!-PRINTSF LCPOLY >>; LCG:=GCDLIST LCG; TRACE!-TIME << PRIN2!* "LCG (=GCD OF THESE) = "; FAC!-PRINTSF LCG >>; TRY!-AGAIN: UNLUCKY!-CASE:=NIL; IMAGE!-SET:=NIL; SET!-MODULUS(PRIME:=RANDOM!-PRIME()); % Produce random univariate modular images of all the % polynomials; W:=L; IF NOT ZEROS!-LIST THEN << IMAGE!-SET:= ZEROS!-LIST:=TRY!-MAX!-ZEROS!-FOR!-IMAGE!-SET(W,VLIST); TRACE!-TIME << PRINTC IMAGE!-SET; PRINC " Zeros-list = "; PRINTC ZEROS!-LIST >> >>; TRACE!-TIME PRINTC LIST("IMAGE SET",IMAGE!-SET); GG:=MAKE!-IMAGE!-MOD!-P(CAR W,CAR VLIST); TRACE!-TIME PRINTC LIST("IMAGE SET",IMAGE!-SET," GG",GG); IF UNLUCKY!-CASE THEN << TRACE!-TIME << PRINTC "Unlucky case, try again"; PRINT IMAGE!-SET >>; GO TO TRY!-AGAIN >>; L1:=LIST(CAR W . GG); MAKE!-IMAGES: IF NULL (W:=CDR W) THEN GO TO IMAGES!-CREATED!-SUCCESSFULLY; L1:=(CAR W . MAKE!-IMAGE!-MOD!-P(CAR W,CAR VLIST)) . L1; IF UNLUCKY!-CASE THEN << TRACE!-TIME << PRINTC "UNLUCKY AGAIN..."; PRINTC L1; PRINT IMAGE!-SET >>; GO TO TRY!-AGAIN >>; GG:=GCD!-MOD!-P(GG,CDAR L1); IF DOMAINP GG THEN << SET!-MODULUS OLD!-MODULUS; TRACE!-TIME PRINT "Primitive parts are coprime"; RETURN GCONT >>; GO TO MAKE!-IMAGES; IMAGES!-CREATED!-SUCCESSFULLY: L1:=REVERSEWOC L1; % Put back in order with smallest first; % If degree of gcd seems to be same as that of smallest item % in input list, that item should be the gcd; IF LDEG GG=LDEG CAR L THEN << GG:=POLY!-ABS CAR L; TRACE!-TIME << PRIN2!* "Probable GCD = "; FAC!-PRINTSF GG >>; GO TO RESULT >> ELSE IF (LDEG CAR L=ADD1 LDEG GG) AND (LDEG CAR L=LDEG CADR L) THEN << % Here it seems that I have just one pseudoremainder step to % perform, so I might as well do it; TRACE!-TIME << PRINTC "Just one pseudoremainder step needed" >>; GG := POLY!-GCD(LC CAR L,LC CADR L); GG := EZGCD!-PP ADDF(MULTF(RED CAR L, QUOTFAIL1(LC CADR L,GG, "Division failure when just one pseudoremainder step needed")), MULTF(RED CADR L,NEGF QUOTFAIL1(LC CAR L,GG, "Divison failure when just one pseudoremainder step needed"))); TRACE!-TIME FAC!-PRINTSF GG; GO TO RESULT >>; W:=L1; FIND!-GOOD!-COFACTOR: IF NULL W THEN GO TO SPECIAL!-CASE; % No good cofactor available; IF DOMAINP GCD!-MOD!-P(GG,COFACTOR:=QUOTIENT!-MOD!-P(CDAR W,GG)) THEN GO TO GOOD!-COFACTOR!-FOUND; W:=CDR W; GO TO FIND!-GOOD!-COFACTOR; GOOD!-COFACTOR!-FOUND: COFACTOR:=MONIC!-MOD!-P COFACTOR; TRACE!-TIME PRINTC "*** Good cofactor found"; W:=CAAR W; TRACE!-TIME << PRIN2!* "W= "; FAC!-PRINTSF W; PRIN2!* "GG= "; FAC!-PRINTSF GG; PRIN2!* "COFACTOR= "; FAC!-PRINTSF COFACTOR >>; IMAGE!-SET:=SORT(IMAGE!-SET,FUNCTION ORDOPCAR); TRACE!-TIME << PRINC "IMAGE-SET = "; PRINTC IMAGE!-SET; PRINC "PRIME= "; PRINTC PRIME; PRINTC "L (=POLYLIST) IS:"; FOR EACH LL IN L DO FAC!-PRINTSF LL >>; GG:=RECONSTRUCT!-GCD(W,GG,COFACTOR,L,PRIME,IMAGE!-SET,LCG); IF GG='NOGOOD THEN GOTO TRY!-AGAIN; GO TO RESULT; SPECIAL!-CASE: % Here I have to do the first step of a PRS method; TRACE!-TIME << PRINTC "*** SPECIAL CASE IN GCD ***"; PRINTC L; PRINTC "----->"; PRINTC GG >>; REDUCED!-DEGREE!-LCLST:=NIL; TRY!-REDUCED!-DEGREE!-AGAIN: TRACE!-TIME << PRINTC "L1 ="; FOR EACH ELL IN L1 DO PRINT ELL >>; W1:=REDUCED!-DEGREE(CAADR L1,CAAR L1); W:=CAR W1; W1:=CDR W1; TRACE!-TIME << PRINC "REDUCED!-DEGREE = "; FAC!-PRINTSF W; PRINC " and its image = "; FAC!-PRINTSF W1 >>; % reduce the degree of the 2nd poly using the 1st. Result is % a pair : (new poly . image new poly); IF DOMAINP W AND NOT NULL W THEN << SET!-MODULUS OLD!-MODULUS; RETURN GCONT >>; % we're done as they're coprime; IF W AND LDEG W = LDEG GG THEN << GG:=W; GO TO RESULT >>; % possible gcd; IF NULL W THEN << % the first poly divided the second one; L1:=(CAR L1 . CDDR L1); % discard second poly; IF NULL CDR L1 THEN << GG := POLY!-ABS CAAR L1; GO TO RESULT >>; GO TO TRY!-REDUCED!-DEGREE!-AGAIN >>; % haven't made progress yet so repeat with new polys; IF LDEG W<=LDEG GG THEN << GG := POLY!-ABS W; GO TO RESULT >> ELSE IF DOMAINP GCD!-MOD!-P(GG,COFACTOR:=QUOTIENT!-MOD!-P(W1,GG)) THEN << W := LIST LIST W; GO TO GOOD!-COFACTOR!-FOUND >>; L1:= IF LDEG W <= LDEG CAAR L1 THEN ((W . W1) . (CAR L1 . CDDR L1)) ELSE (CAR L1 . ((W . W1) . CDDR L1)); % replace first two polys by the reduced poly and the first % poly ordering according to degree; GO TO TRY!-REDUCED!-DEGREE!-AGAIN; % need to repeat as we still haven't found a good cofactor; RESULT: % Here GG holds a tentative gcd for the primitive parts of % all input polys, and GCONT holds a proper one for the content; IF DIVISION!-TEST(GG,L) THEN << SET!-MODULUS OLD!-MODULUS; RETURN MULTF(GG,GCONT) >>; TRACE!-TIME PRINTC LIST("Trial division by ",GG," failed"); GO TO TRY!-AGAIN END; GLOBAL '(KORD!*); SYMBOLIC PROCEDURE MAKE!-A!-LIST!-OF!-VARIABLES L; BEGIN SCALAR VLIST; FOR EACH LL IN L DO VLIST:=VARIABLES!.IN!.FORM(LL,VLIST); RETURN MAKE!-ORDER!-CONSISTENT(VLIST,KORD!*) END; SYMBOLIC PROCEDURE MAKE!-ORDER!-CONSISTENT(L,M); % L is a subset of M. Make its order consistent with that % of M; IF NULL L THEN NIL ELSE IF NULL M THEN ERRORF("Variable missing from KORD*") ELSE IF CAR M MEMBER L THEN CAR M . MAKE!-ORDER!-CONSISTENT(DELETE(CAR M,L),CDR M) ELSE MAKE!-ORDER!-CONSISTENT(L,CDR M); SYMBOLIC PROCEDURE TRY!-MAX!-ZEROS!-FOR!-IMAGE!-SET(L,VLIST); IF NULL VLIST THEN ERROR(0,"VLIST NOT SET IN TRY-MAX-ZEROS-...") ELSE BEGIN SCALAR Z; Z:=FOR EACH V IN CDR VLIST COLLECT IF DOMAINP LC CAR L OR NULL QUOTF(LC CAR L,!*K2F V) THEN (V . 0) ELSE (V . MODULAR!-NUMBER RANDOM()); FOR EACH FF IN CDR L DO Z:=FOR EACH W IN Z COLLECT IF ZEROP CDR W THEN IF DOMAINP LC FF OR NULL QUOTF(LC FF,!*K2F CAR W) THEN W ELSE (CAR W . MODULAR!-NUMBER RANDOM()) ELSE W; RETURN Z END; SYMBOLIC PROCEDURE RECONSTRUCT!-GCD(FULL!-POLY,GG,COFACTOR,POLYLIST, P,IMSET,LCG); % ... ; IF NULL ADDF(FULL!-POLY,NEGF MULTF(GG,COFACTOR)) THEN GG ELSE (LAMBDA FACTOR!-LEVEL; BEGIN SCALAR NUMBER!-OF!-FACTORS,IMAGE!-FACTORS, TRUE!-LEADING!-COEFFTS,MULTIVARIATE!-INPUT!-POLY, IRREDUCIBLE,NON!-MONIC,BAD!-CASE,TARGET!-FACTOR!-COUNT, MULTIVARIATE!-FACTORS,HENSEL!-GROWTH!-SIZE,ALPHALIST, COEFFTS!-VECTORS,BEST!-KNOWN!-FACTORS,PRIME!-BASE, M!-IMAGE!-VARIABLE, RECONSTRUCTING!-GCD,FULL!-GCD; IF NOT(CURRENT!-MODULUS=P) THEN ERRORF("GCDLIST HAS NOT RESTORED THE MODULUS"); % *WARNING* GCDLIST does not restore the modulus so % I had better reset it here! ; IF POLY!-MINUSP LCG THEN ERROR(0,LIST("Negative GCD: ",LCG)); FULL!-POLY:=POLY!-ABS FULL!-POLY; INITIALISE!-HENSEL!-FLUIDS(FULL!-POLY,GG,COFACTOR,P,LCG); TRACE!-TIME << PRINTC "TRUE LEADING COEFFTS ARE:"; FOR I:=1:2 DO << FAC!-PRINTSF GETV(IMAGE!-FACTORS,I); PRIN2!* " WITH L.C.:"; FAC!-PRINTSF GETV(TRUE!-LEADING!-COEFFTS,I) >> >>; IF DETERMINE!-MORE!-COEFFTS()='DONE THEN RETURN FULL!-GCD; IF NULL ALPHALIST THEN ALPHALIST:=ALPHAS(2, LIST(GETV(IMAGE!-FACTORS,1),GETV(IMAGE!-FACTORS,2)),1); IF ALPHALIST='FACTORS! NOT! COPRIME THEN ERRORF LIST("image factors not coprime?",IMAGE!-FACTORS); IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "The following modular polynomials are chosen such that:"; TERPRI(); PRIN2!* " a(2)*f(1) + a(1)*f(2) = 1 mod "; PRINTSTR HENSEL!-GROWTH!-SIZE; TERPRI(); PRINTSTR " where degree of a(1) < degree of f(1),"; PRINTSTR " and degree of a(2) < degree of f(2),"; PRINTSTR " and"; FOR I:=1:2 DO << PRIN2!* " a("; PRIN2!* I; PRIN2!* ")="; FAC!-PRINTSF CDR GET!-ALPHA GETV(IMAGE!-FACTORS,I); PRIN2!* "and f("; PRIN2!* I; PRIN2!* ")="; FAC!-PRINTSF GETV(IMAGE!-FACTORS,I); TERPRI!* T >> >>; RECONSTRUCT!-MULTIVARIATE!-FACTORS( FOR EACH V IN IMSET COLLECT (CAR V . MODULAR!-NUMBER CDR V)); IF IRREDUCIBLE OR BAD!-CASE THEN RETURN 'NOGOOD ELSE RETURN FULL!-GCD END) (FACTOR!-LEVEL+1) ; SYMBOLIC PROCEDURE INITIALISE!-HENSEL!-FLUIDS(FPOLY,FAC1,FAC2,P,LCF1); % ... ; BEGIN SCALAR LC1!-IMAGE,LC2!-IMAGE; RECONSTRUCTING!-GCD:=T; MULTIVARIATE!-INPUT!-POLY:=MULTF(FPOLY,LCF1); PRIME!-BASE:=HENSEL!-GROWTH!-SIZE:=P; NUMBER!-OF!-FACTORS:=2; LC1!-IMAGE:=MAKE!-NUMERIC!-IMAGE!-MOD!-P LCF1; LC2!-IMAGE:=MAKE!-NUMERIC!-IMAGE!-MOD!-P LC FPOLY; % Neither of the above leading coefficients will vanish; FAC1:=TIMES!-MOD!-P(LC1!-IMAGE,FAC1); FAC2:=TIMES!-MOD!-P(LC2!-IMAGE,FAC2); IMAGE!-FACTORS:=MKVECT 2; TRUE!-LEADING!-COEFFTS:=MKVECT 2; PUTV(IMAGE!-FACTORS,1,FAC1); PUTV(IMAGE!-FACTORS,2,FAC2); PUTV(TRUE!-LEADING!-COEFFTS,1,LCF1); PUTV(TRUE!-LEADING!-COEFFTS,2,LC FPOLY); % If the GCD is going to be monic, we know the lc % of both cofactors exactly; NON!-MONIC:=NOT(LCF1=1); M!-IMAGE!-VARIABLE:=MVAR FPOLY END; SYMBOLIC PROCEDURE DIVISION!-TEST(GG,L); % Predicate to test if GG divides all the polynomials in the list L; IF NULL L THEN T ELSE IF NULL QUOTF(CAR L,GG) THEN NIL ELSE DIVISION!-TEST(GG,CDR L); SYMBOLIC PROCEDURE DEGREE!-ORDER(A,B); % Order standard forms using their degrees wrt main vars; IF DOMAINP A THEN T ELSE IF DOMAINP B THEN NIL ELSE LDEG A<LDEG B; SYMBOLIC PROCEDURE MAKE!-IMAGE!-MOD!-P(P,V); % Form univariate image, set UNLUCKY!-CASE if leading coefficient % gets destroyed; BEGIN SCALAR LP; LP := DEGREE!-IN!-VARIABLE(P,V); P := MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(P,V); IF NOT DEGREE!-IN!-VARIABLE(P,V)=LP THEN UNLUCKY!-CASE := T; RETURN P END; SYMBOLIC PROCEDURE MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(P,V); % Make a modular image of P, keeping only the variable V; IF DOMAINP P THEN IF P=NIL THEN NIL ELSE !*N2F MODULAR!-NUMBER P ELSE IF MVAR P=V THEN ADJOIN!-TERM(LPOW P, MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(LC P,V), MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(RED P,V)) ELSE PLUS!-MOD!-P( TIMES!-MOD!-P(IMAGE!-OF!-POWER(MVAR P,LDEG P), MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(LC P,V)), MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(RED P,V)); SYMBOLIC PROCEDURE IMAGE!-OF!-POWER(V,N); BEGIN SCALAR W; W := ASSOC(V,IMAGE!-SET); IF NULL W THEN << W := MODULAR!-NUMBER RANDOM(); IMAGE!-SET := (V . W) . IMAGE!-SET >> ELSE W := CDR W; RETURN MODULAR!-EXPT(W,N) END; SYMBOLIC PROCEDURE MAKE!-NUMERIC!-IMAGE!-MOD!-P P; % Make a modular image of P; IF DOMAINP P THEN IF P=NIL THEN 0 ELSE MODULAR!-NUMBER P ELSE MODULAR!-PLUS( MODULAR!-TIMES(IMAGE!-OF!-POWER(MVAR P,LDEG P), MAKE!-NUMERIC!-IMAGE!-MOD!-P LC P), MAKE!-NUMERIC!-IMAGE!-MOD!-P RED P); SYMBOLIC PROCEDURE TOTAL!-DEGREE!-IN!-POWERS(FORM,POWLST); % Returns a list where each variable mentioned in FORM is paired % with the maximum degree it has. POWLST collects the list, and should % normally be NIL on initial entry; IF NULL FORM OR DOMAINP FORM THEN POWLST ELSE BEGIN SCALAR X; IF (X := ATSOC(MVAR FORM,POWLST)) THEN LDEG FORM>CDR X AND RPLACD(X,LDEG FORM) ELSE POWLST := (MVAR FORM . LDEG FORM) . POWLST; RETURN TOTAL!-DEGREE!-IN!-POWERS(RED FORM, TOTAL!-DEGREE!-IN!-POWERS(LC FORM,POWLST)) END; SYMBOLIC PROCEDURE POWERS1 FORM; % For each variable V in FORM collect (V . (MAX . MIN)) where % MAX and MIN are limits to the degrees V has in FORM; POWERS2(FORM,POWERS3(FORM,NIL),NIL); SYMBOLIC PROCEDURE POWERS3(FORM,L); % Start of POWERS1 by collecting power information for % the leading monomial in FORM; IF DOMAINP FORM THEN L ELSE POWERS3(LC FORM,(MVAR FORM . (LDEG FORM . LDEG FORM)) . L); SYMBOLIC PROCEDURE POWERS2(FORM,POWLST,THISMONOMIAL); IF DOMAINP FORM THEN IF NULL FORM THEN POWLST ELSE POWERS4(THISMONOMIAL,POWLST) ELSE POWERS2(LC FORM, POWERS2(RED FORM,POWLST,THISMONOMIAL), LPOW FORM . THISMONOMIAL); SYMBOLIC PROCEDURE POWERS4(NEW,OLD); % Merge information from new monomial into old information, % updating MAX and MIN details; IF NULL NEW THEN FOR EACH V IN OLD COLLECT (CAR V . (CADR V . 0)) ELSE IF NULL OLD THEN FOR EACH V IN NEW COLLECT (CAR V . (CDR V . 0)) ELSE IF CAAR NEW=CAAR OLD THEN << % variables match - do MAX and MIN on degree information; IF CDAR NEW>CADAR OLD THEN RPLACA(CDAR OLD,CDAR NEW); IF CDAR NEW<CDDAR OLD THEN RPLACD(CDAR OLD,CDAR NEW); RPLACD(OLD,POWERS4(CDR NEW,CDR OLD)) >> ELSE IF ORDOP(CAAR NEW,CAAR OLD) THEN << RPLACD(CDAR OLD,0); % Some variable not mentioned in new monomial; RPLACD(OLD,POWERS4(NEW,CDR OLD)) >> ELSE (CAAR NEW . (CDAR NEW . 0)) . POWERS4(CDR NEW,OLD); SYMBOLIC PROCEDURE EZGCD!-PP U; %returns the primitive part of the polynomial U wrt leading var; QUOTF1(U,COMFAC!-TO!-POLY EZGCD!-COMFAC U); SYMBOLIC PROCEDURE EZGCD!-SQFRF P; %P is a primitive standard form; %value is a list of square free factors; BEGIN SCALAR PDASH,P1,D,V; PDASH := DIFF(P,V := MVAR P); D := POLY!-GCD(P,PDASH); % p2*p3**2*p4**3*... ; IF DOMAINP D THEN RETURN LIST P; P := QUOTFAIL1(P,D,"GCD division in FACTOR-SQFRF failed"); P1 := POLY!-GCD(P, ADDF(QUOTFAIL1(PDASH,D,"GCD division in FACTOR-SQFRF failed"), NEGF DIFF(P,V))); RETURN P1 . EZGCD!-SQFRF D END; SYMBOLIC PROCEDURE REDUCED!-DEGREE(U,V); %U and V are primitive polynomials in the main variable VAR; %result is pair: (reduced poly of U by V . its image) where by % reduced I mean using V to kill the leading term of U; BEGIN SCALAR VAR,W,X; TRACE!-TIME << PRINTC "ARGS FOR REDUCED!-DEGREE ARE:"; FAC!-PRINTSF U; FAC!-PRINTSF V >>; IF U=V OR QUOTF1(U,V) THEN RETURN (NIL . NIL) ELSE IF LDEG V=1 THEN RETURN (1 . 1); TRACE!-TIME PRINTC "CASE NON-TRIVIAL SO TAKE A REDUCED!-DEGREE:"; VAR := MVAR U; IF LDEG U=LDEG V THEN X := NEGF LC U ELSE X:=(MKSP(VAR,LDEG U - LDEG V) .* NEGF LC U) .+ NIL; W:=ADDF(MULTF(LC V,U),MULTF(X,V)); TRACE!-TIME FAC!-PRINTSF W; IF DEGR(W,VAR)=0 THEN RETURN (1 . 1); TRACE!-TIME << PRINC "REDUCED!-DEGREE-LCLST = "; PRINT REDUCED!-DEGREE!-LCLST >>; REDUCED!-DEGREE!-LCLST := ADDLC(V,REDUCED!-DEGREE!-LCLST); TRACE!-TIME << PRINC "REDUCED!-DEGREE-LCLST = "; PRINT REDUCED!-DEGREE!-LCLST >>; IF X := QUOTF1(W,LC W) THEN W := X ELSE FOR EACH Y IN REDUCED!-DEGREE!-LCLST DO WHILE (X := QUOTF1(W,Y)) DO W := X; U := V; V := EZGCD!-PP W; TRACE!-TIME << PRINTC "U AND V ARE NOW:"; FAC!-PRINTSF U; FAC!-PRINTSF V >>; IF DEGR(V,VAR)=0 THEN RETURN (1 . 1) ELSE RETURN (V . MAKE!-UNIVARIATE!-IMAGE!-MOD!-P(V,VAR)) END; MOVED('COMFAC,'EZGCD!-COMFAC); MOVED('PP,'EZGCD!-PP); ENDMODULE; MODULE FACMISC; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % miscellaneous routines used from several sections ; %**********************************************************************; % (1) investigate variables in polynomial; SYMBOLIC PROCEDURE MULTIVARIATEP(A,V); IF DOMAINP A THEN NIL ELSE IF NOT(MVAR A EQ V) THEN T ELSE IF MULTIVARIATEP(LC A,V) THEN T ELSE MULTIVARIATEP(RED A,V); SYMBOLIC PROCEDURE VARIABLES!-IN!-FORM A; % collect variables that occur in the form a; VARIABLES!.IN!.FORM(A,NIL); SYMBOLIC PROCEDURE GET!.COEFFT!.BOUND(POLY,DEGBD); % calculates a coefft bound for the factors of poly. this simple % bound is that suggested by paul wang and linda p. rothschild in % math.comp.vol29 july 75 p.940 due to gel'fond; % Note that for tiny polynomials the bound is forced up to be % larger than any prime that will get used in the mod-p splitting; MAX(GET!-HEIGHT POLY * FIXEXPFLOAT SUMOF DEGBD,110); SYMBOLIC PROCEDURE SUMOF DEGBD; IF NULL DEGBD THEN 0 ELSE CDAR DEGBD + SUMOF CDR DEGBD; SYMBOLIC PROCEDURE FIXEXPFLOAT N; % Compute exponential function e**n for potentially large N, % rounding result up somewhat. Note that exp(13)=442413 or so, % so if the basic floating point exponential function is accurate % to 6 or so digits we are protected here against roundoff; IF N>13 THEN BEGIN SCALAR N2; N2 := N/2; RETURN FIXEXPFLOAT(N2)*FIXEXPFLOAT(N-N2) END ELSE 2+FIX EXP FLOAT N; % (2) timer services; SYMBOLIC PROCEDURE SET!-TIME(); << LAST!-DISPLAYED!-TIME:=BASE!-TIME:=READTIME(); LAST!-DISPLAYED!-GC!-TIME:=GC!-BASE!-TIME:=READGCTIME(); NIL >>; GLOBAL '(!*TEST); %not really supported in REDUCE anymore; SYMBOLIC PROCEDURE PRINT!-TIME M; % display time used so far, with given message; BEGIN SCALAR TOTAL,INCR,GCTOTAL,GCINCR,W; IF NOT !*TEST THEN RETURN NIL; W:=READTIME(); TOTAL:=W-BASE!-TIME; INCR:=W-LAST!-DISPLAYED!-TIME; LAST!-DISPLAYED!-TIME:=W; W:=READGCTIME(); GCTOTAL:=W-GC!-BASE!-TIME; GCINCR:=W-LAST!-DISPLAYED!-GC!-TIME; LAST!-DISPLAYED!-GC!-TIME:=W; IF ATOM M THEN PRINC M ELSE << PRINC CAR M; M:=CDR M; WHILE NOT ATOM M DO << PRINC '! ; PRINC CAR M; M:=CDR M >>; IF NOT NULL M THEN << PRINC '! ; PRINC M >> >>; PRINC " after "; PRINMILLI INCR; PRINC "+"; PRINMILLI GCINCR; PRINC " seconds (total = "; PRINMILLI TOTAL; PRINC "+"; PRINMILLI GCTOTAL; PRINC ")"; TERPRI() END; SYMBOLIC PROCEDURE PRINMILLI N; % print n/1000 as a decimal fraction with 2 decimal places; BEGIN SCALAR U,D1,D01; N:=N+5; %rounding; N:=QUOTIENT(N,10); %now centiseconds; N:=DIVIDE(N,10); D01:=CDR N; N:=CAR N; N:=DIVIDE(N,10); D1:=CDR N; U:=CAR N; PRINC U; PRINC '!.; PRINC D1; PRINC D01; RETURN NIL END; % (3) minor variations on ordinary algebraic operations; SYMBOLIC PROCEDURE QUOTFAIL(A,B); % version of quotf that fails if the division does; IF POLYZEROP A THEN POLYZERO ELSE BEGIN SCALAR W; W:=QUOTF(A,B); IF DIDNTGO W THEN ERRORF LIST("UNEXPECTED DIVISION FAILURE",A,B) ELSE RETURN W END; SYMBOLIC PROCEDURE QUOTFAIL1(A,B,MSG); % version of quotf that fails if the division does, and gives % custom message; IF POLYZEROP A THEN POLYZERO ELSE BEGIN SCALAR W; W:=QUOTF(A,B); IF DIDNTGO W THEN ERRORF MSG ELSE RETURN W END; % (4) pseudo-random prime numbers - small and large; GLOBAL '(TEENY!-PRIMES); SYMBOLIC PROCEDURE SET!-TEENY!-PRIMES(); BEGIN SCALAR I; I:=-1; TEENY!-PRIMES:=MKVECT 9; PUTV(TEENY!-PRIMES,I:=IADD1 I,3); PUTV(TEENY!-PRIMES,I:=IADD1 I,5); PUTV(TEENY!-PRIMES,I:=IADD1 I,7); PUTV(TEENY!-PRIMES,I:=IADD1 I,11); PUTV(TEENY!-PRIMES,I:=IADD1 I,13); PUTV(TEENY!-PRIMES,I:=IADD1 I,17); PUTV(TEENY!-PRIMES,I:=IADD1 I,19); PUTV(TEENY!-PRIMES,I:=IADD1 I,23); PUTV(TEENY!-PRIMES,I:=IADD1 I,29); PUTV(TEENY!-PRIMES,I:=IADD1 I,31) END; SET!-TEENY!-PRIMES(); SYMBOLIC PROCEDURE RANDOM!-SMALL!-PRIME(); BEGIN SCALAR P; P:=ILOGOR(1,SMALL!-RANDOM!-NUMBER()); WHILE NOT PRIMEP P DO P:=ILOGOR(1,SMALL!-RANDOM!-NUMBER()); RETURN P END; SYMBOLIC PROCEDURE SMALL!-RANDOM!-NUMBER(); % Returns a number in the range 3 to 103 with a distribution % favouring smaller numbers; BEGIN SCALAR W; W:=REMAINDER(RANDOM(),2000); W:=TIMES(W,W); % In range 0 to about 4 million; RETURN IPLUS(3,W/40000) END; SYMBOLIC PROCEDURE RANDOM!-TEENY!-PRIME L; % get one of the first 10 primes at random providing it is % not in the list L or that L says we have tried them all; IF L='ALL OR (LENGTH L = 10) THEN NIL ELSE BEGIN SCALAR P; AGAIN: P:=GETV(TEENY!-PRIMES,REMAINDER(RANDOM(),10)); IF MEMBER(P,L) THEN GOTO AGAIN; RETURN P END; SYMBOLIC PROCEDURE PRIMEP N; % Test if prime. Only for use on small integers. % Does not consider '2' to be a prime; IGREATERP(N,2) AND ILOGAND(N,1)=1 AND PRIMETEST(N,3); SYMBOLIC PROCEDURE PRIMETEST(N,TRIAL); IF IGREATERP(ITIMES(TRIAL,TRIAL),N) THEN T ELSE IF IREMAINDER(N,TRIAL)=0 THEN NIL ELSE PRIMETEST(N,IPLUS(TRIAL,2)); GLOBAL '(BIT1AND23 PSEUDO!-PRIMES); BIT1AND23:=LOGOR(1,LEFTSHIFT(1,23)); FLAG('(BIT1AND23 TWENTYFOURBITS),'CONSTANT); % PSEUDO-PRIMES will be a list of all composite numbers which % do not have a factor less than 68, and which are in the range % 2**23 to 2**24 for which 2**(n-1)=1 mod n; PSEUDO!-PRIMES:=MKVECT 121; BEGIN SCALAR I,L; I:=0; L:= '( 8534233 8650951 8725753 8727391 8745277 8902741 9006401 9037729 9040013 9056501 9073513 9131401 9273547 9371251 9480461 9533701 9564169 9567673 9588151 9591661 9724177 9729301 9774181 9863461 10024561 10031653 10084177 10251473 10266001 10323769 10331141 10386241 10402237 10403641 10425511 10505701 10545991 10610063 10700761 10712857 10763653 10802017 10974881 11081459 11115037 11335501 11367137 11541307 11585293 11592397 11777599 12032021 12096613 12263131 12273769 12322133 12327121 12376813 12407011 12498061 12599233 12659989 12711007 12854437 12932989 13057787 13073941 13295281 13338371 13446253 13448593 13500313 13635289 13694761 13747361 13773061 13838569 13856417 13991647 13996951 14026897 14154337 14179537 14282143 14324473 14469841 14589901 14671801 14676481 14709241 14794081 14796289 14865121 14899751 14980411 15082901 15101893 15139199 15188557 15220951 15268501 15479777 15525241 15583153 15603391 15621409 15700301 15732721 15757741 15802681 15976747 15978007 16070429 16132321 16149169 16324001 16349477 16360381 16435747 16705021 16717061 16773121); WHILE L DO << PUTV(PSEUDO!-PRIMES,I,CAR L); I:=I+1; L:=CDR L >> END; SYMBOLIC PROCEDURE RANDOM!-PRIME(); BEGIN SCALAR P,W,OLDMOD; IF TWENTYFOURBITS>LARGEST!-SMALL!-MODULUS THEN << REPEAT P := LOGOR(1,REMAINDER(RANDOM(),LARGEST!-SMALL!-MODULUS - 1)) UNTIL P*P>LARGEST!-SMALL!-MODULUS AND PRIMEP P; RETURN P >>; % W will become 1 when P is prime; OLDMOD := CURRENT!-MODULUS; WHILE NOT (W=1) DO << % OR in bits 1 and 2**23 to make number odd and large; P:=LOGOR(BIT1AND23,LOGAND(TWENTYFOURBITS,RANDOM())); % A random (odd) 24 bit integer; IF IREMAINDER(P,3)=0 OR IREMAINDER(P,5)=0 OR IREMAINDER(P,7)=0 OR IREMAINDER(P,11)=0 OR IREMAINDER(P,13)=0 OR IREMAINDER(P,17)=0 OR IREMAINDER(P,19)=0 OR IREMAINDER(P,23)=0 OR IREMAINDER(P,29)=0 OR IREMAINDER(P,31)=0 OR IREMAINDER(P,37)=0 OR IREMAINDER(P,41)=0 OR IREMAINDER(P,43)=0 OR IREMAINDER(P,47)=0 OR IREMAINDER(P,53)=0 OR IREMAINDER(P,59)=0 OR IREMAINDER(P,61)=0 OR IREMAINDER(P,67)=0 THEN W:=0 ELSE << SET!-MODULUS P; W:=MODULAR!-EXPT(2,ISUB1 P); IF W=1 AND PSEUDO!-PRIME!-P P THEN W:=0 >> >>; SET!-MODULUS OLDMOD; RETURN P END; SYMBOLIC PROCEDURE PSEUDO!-PRIME!-P N; BEGIN SCALAR LOW,MID,HIGH,V; LOW:=0; HIGH:=121; % Size of vector of pseudo-primes; WHILE NOT (HIGH=LOW) DO << % Binary search in table; MID:=IRIGHTSHIFT(IPLUS(IADD1 HIGH,LOW),1); % Mid point of (low,high); V:=GETV(PSEUDO!-PRIMES,MID); IF IGREATERP(V,N) THEN HIGH:=ISUB1 MID ELSE LOW:=MID >>; RETURN (GETV(PSEUDO!-PRIMES,LOW)=N) END; % (5) usefull routines for vectors; SYMBOLIC PROCEDURE FORM!-SUM!-AND!-PRODUCT!-MOD!-P(AVEC,FVEC,R); % sum over i (avec(i) * fvec(i)); BEGIN SCALAR S; S:=POLYZERO; FOR I:=1:R DO S:=PLUS!-MOD!-P(TIMES!-MOD!-P(GETV(AVEC,I),GETV(FVEC,I)), S); RETURN S END; SYMBOLIC PROCEDURE FORM!-SUM!-AND!-PRODUCT!-MOD!-M(AVEC,FVEC,R); % Same as above but AVEC holds alphas mod p and want to work % mod m (m > p) so minor difference to change AVEC to AVEC mod m; BEGIN SCALAR S; S:=POLYZERO; FOR I:=1:R DO S:=PLUS!-MOD!-P(TIMES!-MOD!-P( !*F2MOD !*MOD2F GETV(AVEC,I),GETV(FVEC,I)),S); RETURN S END; SYMBOLIC PROCEDURE REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(V,PT,N); % substitute for the given variable in all elements creating a % new vector for the result. (all arithmetic is mod p); BEGIN SCALAR NEWV; NEWV:=MKVECT N; FOR I:=1:N DO PUTV(NEWV,I,EVALUATE!-MOD!-P(GETV(V,I),CAR PT,CDR PT)); RETURN NEWV END; SYMBOLIC PROCEDURE MAKE!-BIVARIATE!-VEC!-MOD!-P(V,IMSET,VAR,N); BEGIN SCALAR NEWV; NEWV:=MKVECT N; FOR I:=1:N DO PUTV(NEWV,I,MAKE!-BIVARIATE!-MOD!-P(GETV(V,I),IMSET,VAR)); RETURN NEWV END; SYMBOLIC PROCEDURE TIMES!-VECTOR!-MOD!-P(V,N); % product of all the elements in the vector mod p; BEGIN SCALAR W; W:=1; FOR I:=1:N DO W:=TIMES!-MOD!-P(GETV(V,I),W); RETURN W END; SYMBOLIC PROCEDURE MAKE!-VEC!-MODULAR!-SYMMETRIC(V,N); % fold each elt of V which is current a modular poly in the % range 0->(p-1) onto the symmetric range (-p/2)->(p/2); FOR I:=1:N DO PUTV(V,I,MAKE!-MODULAR!-SYMMETRIC GETV(V,I)); % (6) Combinatorial fns used in finding values for the variables; SYMBOLIC PROCEDURE MAKE!-ZEROVARSET VLIST; % vlist is a list of pairs (v . tag) where v is a variable name and % tag is a boolean tag. The procedure splits the list into two % according to the tags: Zerovarset is set to a list of variables % whose tag is false and othervars contains the rest; FOR EACH W IN VLIST DO IF CDR W THEN OTHERVARS:= CAR W . OTHERVARS ELSE ZEROVARSET:= CAR W . ZEROVARSET; SYMBOLIC PROCEDURE MAKE!-ZEROSET!-LIST N; % Produces a list of lists each of length n with all combinations of % ones and zeroes; BEGIN SCALAR W; FOR K:=0:N DO W:=APPEND(W,KCOMBNS(K,N)); RETURN W END; SYMBOLIC PROCEDURE KCOMBNS(K,M); % produces a list of all combinations of ones and zeroes with k ones % in each; IF K=0 OR K=M THEN BEGIN SCALAR W; IF K=M THEN K:=1; FOR I:=1:M DO W:=K.W; RETURN LIST W END ELSE IF K=1 OR K=ISUB1 M THEN << IF K=ISUB1 M THEN K:=0; LIST!-WITH!-ONE!-A(K,1 #- K,M) >> ELSE APPEND( FOR EACH X IN KCOMBNS(ISUB1 K,ISUB1 M) COLLECT (1 . X), FOR EACH X IN KCOMBNS(K,ISUB1 M) COLLECT (0 . X) ); SYMBOLIC PROCEDURE LIST!-WITH!-ONE!-A(A,B,M); % Creates list of all lists with one a and m-1 b's in; BEGIN SCALAR W,X,R; FOR I:=1:ISUB1 M DO W:=B . W; R:=LIST(A . W); FOR I:=1:ISUB1 M DO << X:=(CAR W) . X; W:=CDR W; R:=APPEND(X,(A . W)) . R >>; RETURN R END; SYMBOLIC PROCEDURE MAKE!-NEXT!-ZSET L; BEGIN SCALAR K,W; IMAGE!-SET!-MODULUS:=IADD1 IMAGE!-SET!-MODULUS; SET!-MODULUS IMAGE!-SET!-MODULUS; W:=FOR EACH LL IN CDR L COLLECT FOR EACH N IN LL COLLECT IF N=0 THEN N ELSE << K:=MODULAR!-NUMBER RANDOM(); WHILE (ZEROP K) OR (ONEP K) DO K:=MODULAR!-NUMBER RANDOM(); IF K>MODULUS!/2 THEN K:=K-CURRENT!-MODULUS; K >>; SAVE!-ZSET:=NIL; RETURN W END; ENDMODULE; MODULE FACMOD; %**********************************************************************; % % copyright (c) university of cambridge, england 1979 % %**********************************************************************; %**********************************************************************; % % modular factorization section %; %**********************************************************************; % modular factorization : discover the factor count mod p; SAFE!-FLAG:=CARCHECK 0; % For speed of array access - important here; SYMBOLIC PROCEDURE GET!-FACTOR!-COUNT!-MOD!-P (N,POLY!-MOD!-P,P,X!-IS!-FACTOR); % gets the factor count mod p from the nth image using the % first half of Berlekamp's method; BEGIN SCALAR OLD!-M,F!-COUNT,WTIME; OLD!-M:=SET!-MODULUS P; % PRINC "prime = ";% PRINTC CURRENT!-MODULUS; % PRINC "degree = ";% PRINTC LDEG POLY!-MOD!-P; TRACE!-TIME DISPLAY!-TIME("Entered GET-FACTOR-COUNT after ",TIME()); WTIME:=TIME(); F!-COUNT:=MODULAR!-FACTOR!-COUNT(); TRACE!-TIME DISPLAY!-TIME("Factor count obtained in ",TIME()-WTIME); SPLIT!-LIST:= ((IF X!-IS!-FACTOR THEN CAR F!-COUNT#+1 ELSE CAR F!-COUNT) . N) . SPLIT!-LIST; PUTV(MODULAR!-INFO,N,CDR F!-COUNT); SET!-MODULUS OLD!-M END; SYMBOLIC PROCEDURE MODULAR!-FACTOR!-COUNT(); BEGIN SCALAR POLY!-VECTOR,WVEC1,WVEC2,X!-TO!-P, N,WTIME,W,LIN!-F!-COUNT,NULL!-SPACE!-BASIS; KNOWN!-FACTORS:=NIL; DPOLY:=LDEG POLY!-MOD!-P; WVEC1:=MKVECT (2#*DPOLY); WVEC2:=MKVECT (2#*DPOLY); X!-TO!-P:=MKVECT DPOLY; POLY!-VECTOR:=MKVECT DPOLY; FOR I:=0:DPOLY DO PUTV(POLY!-VECTOR,I,0); POLY!-TO!-VECTOR POLY!-MOD!-P; W:=COUNT!-LINEAR!-FACTORS!-MOD!-P(WVEC1,WVEC2,X!-TO!-P); LIN!-F!-COUNT:=CAR W; IF DPOLY#<4 THEN RETURN (IF DPOLY=0 THEN LIN!-F!-COUNT ELSE LIN!-F!-COUNT#+1) . LIST(LIN!-F!-COUNT . CADR W, DPOLY . POLY!-VECTOR, NIL); % When I use Berlekamp I certainly know that the polynomial % involved has no linear factors; WTIME:=TIME(); NULL!-SPACE!-BASIS:=USE!-BERLEKAMP(X!-TO!-P,CADDR W,WVEC1); TRACE!-TIME DISPLAY!-TIME("Berlekamp done in ",TIME()-WTIME); N:=LIN!-F!-COUNT #+ LENGTH NULL!-SPACE!-BASIS #+ 1; % there is always 1 more factor than the number of % null vectors we have picked up; RETURN N . LIST( LIN!-F!-COUNT . CADR W, DPOLY . POLY!-VECTOR, NULL!-SPACE!-BASIS) END; %**********************************************************************; % Extraction of linear factors is done specially; SYMBOLIC PROCEDURE COUNT!-LINEAR!-FACTORS!-MOD!-P(WVEC1,WVEC2,X!-TO!-P); % Compute gcd(x**p-x,u). It will be the product of all the % linear factors of u mod p; BEGIN SCALAR DX!-TO!-P,LIN!-F!-COUNT,LINEAR!-FACTORS; FOR I:=0:DPOLY DO PUTV(WVEC2,I,GETV(POLY!-VECTOR,I)); DX!-TO!-P:=MAKE!-X!-TO!-P(CURRENT!-MODULUS,WVEC1,X!-TO!-P); FOR I:=0:DX!-TO!-P DO PUTV(WVEC1,I,GETV(X!-TO!-P,I)); IF DX!-TO!-P#<1 THEN << IF DX!-TO!-P#<0 THEN PUTV(WVEC1,0,0); PUTV(WVEC1,1,MODULAR!-MINUS 1); DX!-TO!-P:=1 >> ELSE << PUTV(WVEC1,1,MODULAR!-DIFFERENCE(GETV(WVEC1,1),1)); IF DX!-TO!-P=1 AND GETV(WVEC1,1)=0 THEN IF GETV(WVEC1,0)=0 THEN DX!-TO!-P:=-1 ELSE DX!-TO!-P:=0 >>; IF DX!-TO!-P#<0 THEN LIN!-F!-COUNT:=COPY!-VECTOR(WVEC2,DPOLY,WVEC1) ELSE LIN!-F!-COUNT:=GCD!-IN!-VECTOR(WVEC1,DX!-TO!-P, WVEC2,DPOLY); LINEAR!-FACTORS:=MKVECT LIN!-F!-COUNT; FOR I:=0:LIN!-F!-COUNT DO PUTV(LINEAR!-FACTORS,I,GETV(WVEC1,I)); DPOLY:=QUOTFAIL!-IN!-VECTOR(POLY!-VECTOR,DPOLY, LINEAR!-FACTORS,LIN!-F!-COUNT); RETURN LIST(LIN!-F!-COUNT,LINEAR!-FACTORS,DX!-TO!-P) END; SYMBOLIC PROCEDURE MAKE!-X!-TO!-P(P,WVEC1,X!-TO!-P); BEGIN SCALAR DX!-TO!-P,DW1; IF P#<DPOLY THEN << FOR I:=0:P#-1 DO PUTV(X!-TO!-P,I,0); PUTV(X!-TO!-P,P,1); RETURN P >>; DX!-TO!-P:=MAKE!-X!-TO!-P(P/2,WVEC1,X!-TO!-P); DW1:=TIMES!-IN!-VECTOR(X!-TO!-P,DX!-TO!-P,X!-TO!-P,DX!-TO!-P,WVEC1); DW1:=REMAINDER!-IN!-VECTOR(WVEC1,DW1, POLY!-VECTOR,DPOLY); IF NOT(IREMAINDER(P,2)=0) THEN << FOR I:=DW1 STEP -1 UNTIL 0 DO PUTV(WVEC1,I#+1,GETV(WVEC1,I)); PUTV(WVEC1,0,0); DW1:=REMAINDER!-IN!-VECTOR(WVEC1,DW1#+1, POLY!-VECTOR,DPOLY) >>; FOR I:=0:DW1 DO PUTV(X!-TO!-P,I,GETV(WVEC1,I)); RETURN DW1 END; SYMBOLIC PROCEDURE FIND!-LINEAR!-FACTORS!-MOD!-P(P,N); % P is a vector representing a polynomial of degree N which has % only linear factors. Find all the factors and return a list of % them; BEGIN SCALAR ROOT,VAR,W,VEC1; IF N#<1 THEN RETURN NIL; VEC1:=MKVECT 1; PUTV(VEC1,1,1); ROOT:=0; WHILE (N#>1) AND NOT (ROOT #> CURRENT!-MODULUS) DO << W:=EVALUATE!-IN!-VECTOR(P,N,ROOT); IF W=0 THEN << %a factor has been found!!; IF VAR=NIL THEN VAR:=MKSP(M!-IMAGE!-VARIABLE,1) . 1; W:=!*F2MOD ADJOIN!-TERM(CAR VAR,CDR VAR,!*N2F MODULAR!-MINUS ROOT); KNOWN!-FACTORS:=W . KNOWN!-FACTORS; PUTV(VEC1,0,MODULAR!-MINUS ROOT); N:=QUOTFAIL!-IN!-VECTOR(P,N,VEC1,1) >>; ROOT:=ROOT#+1 >>; KNOWN!-FACTORS:= VECTOR!-TO!-POLY(P,N,M!-IMAGE!-VARIABLE) . KNOWN!-FACTORS END; %**********************************************************************; % Berlekamp's algorithm part 1: find null space basis giving factor % count; SYMBOLIC PROCEDURE USE!-BERLEKAMP(X!-TO!-P,DX!-TO!-P,WVEC1); % Set up a basis for the set of remaining (nonlinear) factors % using Berlekamp's algorithm; BEGIN SCALAR BERL!-M,BERL!-M!-SIZE,W, DCURRENT,CURRENT!-POWER,WTIME; BERL!-M!-SIZE:=DPOLY#-1; BERL!-M:=MKVECT BERL!-M!-SIZE; FOR I:=0:BERL!-M!-SIZE DO << W:=MKVECT BERL!-M!-SIZE; FOR J:=0:BERL!-M!-SIZE DO PUTV(W,J,0); %initialize to zero; PUTV(BERL!-M,I,W) >>; % Note that column zero of the matrix (as used in the % standard version of Berlekamp's algorithm) is not in fact % needed and is not used here; % I want to set up a matrix that has entries % x**p, x**(2*p), ... , x**((n-1)*p) % as its columns, % where n is the degree of poly-mod-p % and all the entries are reduced mod poly-mod-p; % Since I computed x**p I have taken out some linear factors, % so reduce it further; DX!-TO!-P:=REMAINDER!-IN!-VECTOR(X!-TO!-P,DX!-TO!-P, POLY!-VECTOR,DPOLY); DCURRENT:=0; CURRENT!-POWER:=MKVECT BERL!-M!-SIZE; PUTV(CURRENT!-POWER,0,1); FOR I:=1:BERL!-M!-SIZE DO << IF CURRENT!-MODULUS#>DPOLY THEN DCURRENT:=TIMES!-IN!-VECTOR( CURRENT!-POWER,DCURRENT, X!-TO!-P,DX!-TO!-P, WVEC1) ELSE << % Multiply by shifting; FOR I:=0:CURRENT!-MODULUS#-1 DO PUTV(WVEC1,I,0); FOR I:=0:DCURRENT DO PUTV(WVEC1,CURRENT!-MODULUS#+I, GETV(CURRENT!-POWER,I)); DCURRENT:=DCURRENT#+CURRENT!-MODULUS >>; DCURRENT:=REMAINDER!-IN!-VECTOR( WVEC1,DCURRENT, POLY!-VECTOR,DPOLY); FOR J:=0:DCURRENT DO PUTV(GETV(BERL!-M,J),I,PUTV(CURRENT!-POWER,J, GETV(WVEC1,J))); % also I need to subtract 1 from the diagonal of the matrix; PUTV(GETV(BERL!-M,I),I, MODULAR!-DIFFERENCE(GETV(GETV(BERL!-M,I),I),1)) >>; WTIME:=TIME(); % PRINT!-M("Q matrix",BERL!-M,BERL!-M!-SIZE); W := FIND!-NULL!-SPACE(BERL!-M,BERL!-M!-SIZE); TRACE!-TIME DISPLAY!-TIME("Null space found in ",TIME()-WTIME); RETURN W END; SYMBOLIC PROCEDURE FIND!-NULL!-SPACE(BERL!-M,BERL!-M!-SIZE); % Diagonalize the matrix to find its rank and hence the number of % factors the input polynomial had; BEGIN SCALAR NULL!-SPACE!-BASIS; % find a basis for the null-space of the matrix; FOR I:=1:BERL!-M!-SIZE DO NULL!-SPACE!-BASIS:= CLEAR!-COLUMN(I,NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE); % PRINT!-M("Null vectored",BERL!-M,BERL!-M!-SIZE); RETURN TIDY!-UP!-NULL!-VECTORS(NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE) END; SYMBOLIC PROCEDURE PRINT!-M(M,BERL!-M,BERL!-M!-SIZE); << PRINTC M; FOR I:=0:BERL!-M!-SIZE DO << FOR J:=0:BERL!-M!-SIZE DO << PRINC GETV(GETV(BERL!-M,I),J); TTAB((4#*J)#+4) >>; TERPRI() >> >>; SYMBOLIC PROCEDURE CLEAR!-COLUMN(I, NULL!-SPACE!-BASIS,BERL!-M,BERL!-M!-SIZE); % Process column I of the matrix so that (if possible) it % just has a '1' in row I and zeros elsewhere; BEGIN SCALAR II,W; % I want to bring a non-zero pivot to the position (i,i) % and then add multiples of row i to all other rows to make % all but the i'th element of column i zero. First look for % a suitable pivot; II:=0; SEARCH!-FOR!-PIVOT: IF GETV(GETV(BERL!-M,II),I)=0 OR ((II#<I) AND NOT(GETV(GETV(BERL!-M,II),II)=0)) THEN IF (II:=II#+1)#>BERL!-M!-SIZE THEN RETURN (I . NULL!-SPACE!-BASIS) ELSE GO TO SEARCH!-FOR!-PIVOT; % Here ii references a row containing a suitable pivot element for % column i. Permute rows in the matrix so as to bring the pivot onto % the diagonal; W:=GETV(BERL!-M,II); PUTV(BERL!-M,II,GETV(BERL!-M,I)); PUTV(BERL!-M,I,W); % swop rows ii and i ; W:=MODULAR!-MINUS MODULAR!-RECIPROCAL GETV(GETV(BERL!-M,I),I); % w = -1/pivot, and is used in zeroing out the rest of column i; FOR ROW:=0:BERL!-M!-SIZE DO IF ROW NEQ I THEN BEGIN SCALAR R; %process one row; R:=GETV(GETV(BERL!-M,ROW),I); IF NOT(R=0) THEN << R:=MODULAR!-TIMES(R,W); %that is now the multiple of row i that must be added to row ii; FOR COL:=I:BERL!-M!-SIZE DO PUTV(GETV(BERL!-M,ROW),COL, MODULAR!-PLUS(GETV(GETV(BERL!-M,ROW),COL), MODULAR!-TIMES(R,GETV(GETV(BERL!-M,I),COL)))) >> END; FOR COL:=I:BERL!-M!-SIZE DO PUTV(GETV(BERL!-M,I),COL, MODULAR!-TIMES(GETV(GETV(BERL!-M,I),COL),W)); RETURN NULL!-SPACE!-BASIS END; SYMBOLIC PROCEDURE TIDY!-UP!-NULL!-VECTORS(NULL!-SPACE!-BASIS, BERL!-M,BERL!-M!-SIZE); BEGIN SCALAR ROW!-TO!-USE; ROW!-TO!-USE:=BERL!-M!-SIZE#+1; NULL!-SPACE!-BASIS:= FOR EACH NULL!-VECTOR IN NULL!-SPACE!-BASIS COLLECT BUILD!-NULL!-VECTOR(NULL!-VECTOR, GETV(BERL!-M,ROW!-TO!-USE:=ROW!-TO!-USE#-1),BERL!-M); BERL!-M:=NIL; % Release the store for full matrix; % PRINC "Null vectors: "; % PRINT NULL!-SPACE!-BASIS; RETURN NULL!-SPACE!-BASIS END; SYMBOLIC PROCEDURE BUILD!-NULL!-VECTOR(N,VEC,BERL!-M); % At the end of the elimination process (the CLEAR-COLUMN loop) % certain columns, indicated by the entries in NULL-SPACE-BASIS % will be null vectors, save for the fact that they need a '1' % inserted on the diagonal of the matrix. This procedure copies % these null-vectors into some of the vectors that represented % rows of the Berlekamp matrix; BEGIN % PUTV(VEC,0,0); % Not used later!!; FOR I:=1:N#-1 DO PUTV(VEC,I,GETV(GETV(BERL!-M,I),N)); PUTV(VEC,N,1); % FOR I:=N#+1:BERL!-M!-SIZE DO % PUTV(VEC,I,0); RETURN VEC . N END; %**********************************************************************; % Berlekamp's algorithm part 2: retrieving the factors mod p; SYMBOLIC PROCEDURE GET!-FACTORS!-MOD!-P(N,P); % given the modular info (for the nth image) generated by the % previous half of Berlekamp's method we can reconstruct the % actual factors mod p; BEGIN SCALAR NTH!-MODULAR!-INFO,OLD!-M,WTIME; NTH!-MODULAR!-INFO:=GETV(MODULAR!-INFO,N); OLD!-M:=SET!-MODULUS P; WTIME:=TIME(); PUTV(MODULAR!-INFO,N, CONVERT!-NULL!-VECTORS!-TO!-FACTORS NTH!-MODULAR!-INFO); TRACE!-TIME DISPLAY!-TIME("Factors constructed in ",TIME()-WTIME); SET!-MODULUS OLD!-M END; SYMBOLIC PROCEDURE CONVERT!-NULL!-VECTORS!-TO!-FACTORS M!-INFO; % Using the null space found, complete the job % of finding modular factors by taking gcd's of the % modular input polynomial and variants on the % null space generators; BEGIN SCALAR NUMBER!-NEEDED,FACTORS, WORK!-VECTOR1,DWORK1,WORK!-VECTOR2,DWORK2,WTIME; KNOWN!-FACTORS:=NIL; WTIME:=TIME(); FIND!-LINEAR!-FACTORS!-MOD!-P(CDAR M!-INFO,CAAR M!-INFO); TRACE!-TIME DISPLAY!-TIME("Linear factors found in ",TIME()-WTIME); DPOLY:=CAADR M!-INFO; POLY!-VECTOR:=CDADR M!-INFO; NULL!-SPACE!-BASIS:=CADDR M!-INFO; IF DPOLY=0 THEN RETURN KNOWN!-FACTORS; % All factors were linear; IF NULL NULL!-SPACE!-BASIS THEN RETURN KNOWN!-FACTORS:= VECTOR!-TO!-POLY(POLY!-VECTOR,DPOLY,M!-IMAGE!-VARIABLE) . KNOWN!-FACTORS; NUMBER!-NEEDED:=LENGTH NULL!-SPACE!-BASIS; % count showing how many more factors I need to find; WORK!-VECTOR1:=MKVECT DPOLY; WORK!-VECTOR2:=MKVECT DPOLY; FACTORS:=LIST (POLY!-VECTOR . DPOLY); TRY!-NEXT!-NULL: IF NULL!-SPACE!-BASIS=NIL THEN ERRORF "RAN OUT OF NULL VECTORS TOO EARLY"; WTIME:=TIME(); FACTORS:=TRY!-ALL!-CONSTANTS(FACTORS, CAAR NULL!-SPACE!-BASIS,CDAR NULL!-SPACE!-BASIS); TRACE!-TIME DISPLAY!-TIME("All constants tried in ",TIME()-WTIME); IF NUMBER!-NEEDED=0 THEN RETURN KNOWN!-FACTORS:=APPEND!-NEW!-FACTORS(FACTORS, KNOWN!-FACTORS); NULL!-SPACE!-BASIS:=CDR NULL!-SPACE!-BASIS; GO TO TRY!-NEXT!-NULL END; SYMBOLIC PROCEDURE TRY!-ALL!-CONSTANTS(LIST!-OF!-POLYS,V,DV); % use gcd's of v, v+1, v+2, ... to try to split up the % polynomials in the given list; BEGIN SCALAR A,B,AA,S,WTIME; % aa is a list of factors that can not be improved using this v, % b is a list that might be; AA:=NIL; B:=LIST!-OF!-POLYS; S:=0; TRY!-NEXT!-CONSTANT: PUTV(V,0,S); % Fix constant term of V to be S; % WTIME:=TIME(); A:=SPLIT!-FURTHER(B,V,DV); % TRACE!-TIME DISPLAY!-TIME("Polys split further in ",TIME()-WTIME); B:=CDR A; A:=CAR A; AA:=NCONC(A,AA); % Keep aa up to date as a list of polynomials that this poly % v can not help further with; IF B=NIL THEN RETURN AA; % no more progress possible here; IF NUMBER!-NEEDED=0 THEN RETURN NCONC(B,AA); % no more progress needed; S:=S#+1; IF S#<CURRENT!-MODULUS THEN GO TO TRY!-NEXT!-CONSTANT; % Here I have run out of choices for the constant % coefficient in v without splitting everything; RETURN NCONC(B,AA) END; SYMBOLIC PROCEDURE SPLIT!-FURTHER(LIST!-OF!-POLYS,V,DV); % list-of-polys is a list of polynomials. try to split % its members further by taking gcd's with the polynomial % v. return (a . b) where the polys in a can not possibly % be split using v+constant, but the polys in b might % be; IF NULL LIST!-OF!-POLYS THEN NIL . NIL ELSE BEGIN SCALAR A,B,GG,Q; A:=SPLIT!-FURTHER(CDR LIST!-OF!-POLYS,V,DV); B:=CDR A; A:=CAR A; IF NUMBER!-NEEDED=0 THEN GO TO NO!-SPLIT; % if all required factors have been found there is no need to % search further; DWORK1:=COPY!-VECTOR(V,DV,WORK!-VECTOR1); DWORK2:=COPY!-VECTOR(CAAR LIST!-OF!-POLYS,CDAR LIST!-OF!-POLYS, WORK!-VECTOR2); DWORK1:=GCD!-IN!-VECTOR(WORK!-VECTOR1,DWORK1, WORK!-VECTOR2,DWORK2); IF DWORK1=0 OR DWORK1=CDAR LIST!-OF!-POLYS THEN GO TO NO!-SPLIT; DWORK2:=COPY!-VECTOR(CAAR LIST!-OF!-POLYS,CDAR LIST!-OF!-POLYS, WORK!-VECTOR2); DWORK2:=QUOTFAIL!-IN!-VECTOR(WORK!-VECTOR2,DWORK2, WORK!-VECTOR1,DWORK1); % Here I have a splitting; GG:=MKVECT DWORK1; COPY!-VECTOR(WORK!-VECTOR1,DWORK1,GG); A:=((GG . DWORK1) . A); COPY!-VECTOR(WORK!-VECTOR2,DWORK2,Q:=MKVECT DWORK2); B:=((Q . DWORK2) . B); NUMBER!-NEEDED:=NUMBER!-NEEDED#-1; RETURN (A . B); NO!-SPLIT: RETURN (A . ((CAR LIST!-OF!-POLYS) . B)) END; SYMBOLIC PROCEDURE APPEND!-NEW!-FACTORS(A,B); % Convert to REDUCE (rather than vector) form; IF NULL A THEN B ELSE VECTOR!-TO!-POLY(CAAR A,CDAR A,M!-IMAGE!-VARIABLE) . APPEND!-NEW!-FACTORS(CDR A,B); CARCHECK SAFE!-FLAG; % Restore status quo; ENDMODULE; MODULE FACPRIM; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % % multivariate polynomial factorization more or less as described % by paul wang in: math. comp. vol.32 no.144 oct 1978 pp. 1215-1231 % 'an improved multivariate polynomial factoring algorithm' % % p. m. a. moore. 1979. % % %**********************************************************************; %----------------------------------------------------------------------; % this code works by using a local database of fluid variables % whose meaning is (hopefully) obvious. % they are used as follows: % % global name: set in: comments: % % m!-factored!-leading! create!.images only set if non-numeric % -coefft % m!-factored!-images factorize!.images vector % m!-input!-polynomial factorize!-primitive! % -polynomial % m!-best!-image!-pointer choose!.best!.image % m!-image!-factors choose!.best!.image vector % m!-true!-leading! choose!.best!.image vector % -coeffts % m!-prime choose!.best!.image % irreducible factorize!.images predicate % inverted create!.images predicate % m!-inverted!-sign create!-images +1 or -1 % non!-monic determine!-leading! predicate % -coeffts % (also reconstruct!-over! % -integers) % m!-number!-of!-factors choose!.best!.image % m!-image!-variable square!.free!.factorize % or factorize!-form % m!-image!-sets create!.images vector % this last contains the images of m!-input!-polynomial and the % numbers associated with the factors of lc m!-input!-polynomial (to be % used later) the latter existing only when the lc m!-input!-polynomial % is non-integral. ie.: % m!-image!-sets=< ... , (( d . u ), a, d) , ... > ( a vector) % where: a = an image set (=association list); % d = cont(m!-input!-polynomial image wrt a); % u = prim.part.(same) which is non-trivial square-free % by choice of image set.; % d = vector of numbers associated with factors in lc % m!-input!-polynomial (these depend on a as well); % the number of entries in m!-image!-sets is defined by the fluid % variable, no.of.random.sets; % % % %----------------------------------------------------------------------; %**********************************************************************; % multivariate factorization part 1. entry point for this code: % ** n.b.** the polynomial is assumed to be non-trivial and primitive; SYMBOLIC PROCEDURE SQUARE!.FREE!.FACTORIZE U; % u primitive (multivariate) poly but not yet square free. % result is list of factors consed with their respective multiplicities: % ((f1 . m1),(f2 . m2),...) where mi may = mj when i not = j ; % u is non-trivial - ie. at least linear in some variable; %***** nb. this does not use best square free method *****; BEGIN SCALAR V,W,X,Y,I,NEWU,F!.LIST,SFP!-COUNT; SFP!-COUNT:=0; FACTOR!-TRACE IF NOT U=POLYNOMIAL!-TO!-FACTOR THEN << PRIN2!* "Primitive polynomial to factor: "; FAC!-PRINTSF U >>; IF NULL M!-IMAGE!-VARIABLE THEN ERRORF LIST("M-IMAGE-VARIABLE not set: ",U); V:=POLY!-GCD(U, DERIVATIVE!-WRT!-MAIN!-VARIABLE(U,M!-IMAGE!-VARIABLE)); IF ONEP V THEN << FACTOR!-TRACE PRINTSTR "The polynomial is square-free."; RETURN SQUARE!-FREE!-PRIM!-FACTOR(U,1) >> ELSE FACTOR!-TRACE << PRINTSTR "We now square-free decompose this to produce a series of "; PRINTSTR "(square-free primitive) factors which we treat in turn: "; TERPRI(); TERPRI() >>; W:=QUOTFAIL(U,V); X:=POLY!-GCD(V,W); NEWU:=QUOTFAIL(W,X); IF NOT ONEP NEWU THEN << F!.LIST:=APPEND(F!.LIST, SQUARE!-FREE!-PRIM!-FACTOR(NEWU,1)) >>; I:=2; % power of next factors; % from now on we can avoid an extra gcd and any diffn; WHILE NOT DOMAINP V DO << V:=QUOTFAIL(V,X); W:=QUOTFAIL(W,NEWU); X:=POLY!-GCD(V,W); NEWU:=QUOTFAIL(W,X); IF NOT ONEP NEWU THEN << F!.LIST:=APPEND(F!.LIST, SQUARE!-FREE!-PRIM!-FACTOR(NEWU,I)) >>; I:=IADD1 I >>; IF NOT V=1 THEN F!.LIST:=(V . 1) . F!.LIST; RETURN F!.LIST END; SYMBOLIC PROCEDURE SQUARE!-FREE!-PRIM!-FACTOR(U,I); % factorize the square-free primitive factor u whose multiplicity % in the original poly is i. return the factors consed with this % multiplicity; BEGIN SCALAR W; SFP!-COUNT:=IADD1 SFP!-COUNT; FACTOR!-TRACE << IF NOT(U=POLYNOMIAL!-TO!-FACTOR) THEN << PRIN2!* "("; PRIN2!* SFP!-COUNT; PRIN2!* ") Square-free primitive factor: "; FAC!-PRINTSF U; PRIN2!* " with multiplicity "; PRIN2!* I; TERPRI!*(NIL) >> >>; W:=DISTRIBUTE!.MULTIPLICITY(FACTORIZE!-PRIMITIVE!-POLYNOMIAL U,I); FACTOR!-TRACE IF NOT U=POLYNOMIAL!-TO!-FACTOR THEN << PRIN2!* "Factors of ("; PRIN2!* SFP!-COUNT; PRINTSTR ") are: "; FAC!-PRINTFACTORS(1 . W); TERPRI(); TERPRI() >>; RETURN W END; SYMBOLIC PROCEDURE DISTRIBUTE!.MULTIPLICITY(FACTORLIST,N); % factorlist is a simple list of factors of a square free primitive % multivariate poly and n is their multiplicity in a square free % decomposition of another polynomial. result is a list of form: % ((f1 . n),(f2 . n),...) where fi are the factors.; FOR EACH W IN FACTORLIST COLLECT (W . N); SYMBOLIC PROCEDURE FACTORIZE!-PRIMITIVE!-POLYNOMIAL U; % u is primitive square free and at least linear in % m!-image!-variable. m!-image!-variable is the variable preserved in % the univariate images. this function determines a random set of % integers and a prime to create a univariate modular image of u, % factorize it and determine the leading coeffts of the factors in the % full factorization of u. finally the modular image factors are grown % up to the full multivariates ones using the hensel construction; % result is simple list of irreducible factors; IF DEGREE!-IN!-VARIABLE(U,M!-IMAGE!-VARIABLE) = 1 THEN LIST U ELSE IF UNIVARIATEP U THEN UNIVARIATE!-FACTORIZE U ELSE BEGIN SCALAR VALID!-IMAGE!-SETS,FACTORED!-LC,IMAGE!-FACTORS,PRIME!-BASE, ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE,ZSET,ZEROVARSET,OTHERVARS, MULTIVARIATE!-INPUT!-POLY,BEST!-SET!-POINTER,REDUCTION!-COUNT, TRUE!-LEADING!-COEFFTS,NUMBER!-OF!-FACTORS, INVERTED!-SIGN,IRREDUCIBLE,INVERTED,VARS!-TO!-KILL, FORBIDDEN!-SETS,ZERO!-SET!-TRIED,NON!-MONIC, NO!-OF!-BEST!-SETS,NO!-OF!-RANDOM!-SETS,BAD!-CASE, TARGET!-FACTOR!-COUNT,MODULAR!-INFO,MULTIVARIATE!-FACTORS, HENSEL!-GROWTH!-SIZE,ALPHALIST,BASE!-TIMER,W!-TIME, PREVIOUS!-DEGREE!-MAP,IMAGE!-SET!-MODULUS,COEFFTS!-VECTORS, BEST!-KNOWN!-FACTORS,RECONSTRUCTING!-GCD,FULL!-GCD; BASE!-TIMER:=TIME(); TRACE!-TIME DISPLAY!-TIME( " Entered multivariate primitive polynomial code after ", BASE!-TIMER - BASE!-TIME); %note that this code works by using a local database of %fluid variables that are updated by the subroutines directly %called here. this allows for the relativly complicated %interaction between flow of data and control that occurs in %the factorization algorithm; FACTOR!-TRACE << PRINTSTR "From now on we shall refer to this polynomial as U."; PRINTSTR "We now create an image of U by picking suitable values "; PRINTSTR "for all but one of the variables in U."; PRIN2!* "The variable preserved in the image is "; PRINVAR M!-IMAGE!-VARIABLE; TERPRI!*(NIL) >>; INITIALIZE!-FLUIDS U; % set up the fluids to start things off; W!-TIME:=TIME(); TRYAGAIN: GET!-SOME!-RANDOM!-SETS(); CHOOSE!-THE!-BEST!-SET(); TRACE!-TIME << DISPLAY!-TIME("Modular factoring and best set chosen in ", TIME()-W!-TIME); W!-TIME:=TIME() >>; IF IRREDUCIBLE THEN RETURN LIST U ELSE IF BAD!-CASE THEN << IF !*OVERSHOOT THEN PRINTC "Bad image sets - loop"; BAD!-CASE:=NIL; GOTO TRYAGAIN >>; RECONSTRUCT!-IMAGE!-FACTORS!-OVER!-INTEGERS(); TRACE!-TIME << DISPLAY!-TIME("Image factors reconstructed in ",TIME()-W!-TIME); W!-TIME:=TIME() >>; IF IRREDUCIBLE THEN RETURN LIST U ELSE IF BAD!-CASE THEN << IF !*OVERSHOOT THEN PRINTC "Bad image factors - loop"; BAD!-CASE:=NIL; GOTO TRYAGAIN >>; DETERMINE!.LEADING!.COEFFTS(); TRACE!-TIME << DISPLAY!-TIME("Leading coefficients distributed in ", TIME()-W!-TIME); W!-TIME:=TIME() >>; IF IRREDUCIBLE THEN RETURN LIST U ELSE IF BAD!-CASE THEN << IF !*OVERSHOOT THEN PRINTC "Bad split shown by LC distribution"; BAD!-CASE:=NIL; GOTO TRYAGAIN >>; IF DETERMINE!-MORE!-COEFFTS()='DONE THEN << TRACE!-TIME << DISPLAY!-TIME("All the coefficients distributed in ", TIME()-W!-TIME); W!-TIME:=TIME() >>; RETURN CHECK!-INVERTED MULTIVARIATE!-FACTORS >>; TRACE!-TIME << DISPLAY!-TIME("More coefficients distributed in ", TIME()-W!-TIME); W!-TIME:=TIME() >>; RECONSTRUCT!-MULTIVARIATE!-FACTORS(NIL); IF BAD!-CASE AND NOT IRREDUCIBLE THEN << IF !*OVERSHOOT THEN PRINTC "Multivariate overshoot - restart"; BAD!-CASE:=NIL; GOTO TRYAGAIN >>; TRACE!-TIME DISPLAY!-TIME("Multivariate factors reconstructed in ", TIME()-W!-TIME); IF IRREDUCIBLE THEN RETURN LIST U; RETURN CHECK!-INVERTED MULTIVARIATE!-FACTORS END; SYMBOLIC PROCEDURE INITIALIZE!-FLUIDS U; % Set up the fluids to be used in factoring primitive poly; BEGIN SCALAR W,W1,WTIME; IF !*FORCE!-ZERO!-SET THEN << NO!-OF!-RANDOM!-SETS:=1; NO!-OF!-BEST!-SETS:=1 >> ELSE << NO!-OF!-RANDOM!-SETS:=9; % we generate this many and calculate their factor counts; NO!-OF!-BEST!-SETS:=5; % we find the modular factors of this many; >>; IMAGE!-SET!-MODULUS:=5; VARS!-TO!-KILL:=VARIABLES!-TO!-KILL LC U; MULTIVARIATE!-INPUT!-POLY:=U; TARGET!-FACTOR!-COUNT:=DEGREE!-IN!-VARIABLE(U,M!-IMAGE!-VARIABLE); IF NOT DOMAINP LC MULTIVARIATE!-INPUT!-POLY THEN IF DOMAINP (W:= TRAILING!.COEFFT(MULTIVARIATE!-INPUT!-POLY, M!-IMAGE!-VARIABLE)) THEN << INVERTED:=T; % note that we are 'inverting' the poly m!-input!-polynomial; W1:=INVERT!.POLY(MULTIVARIATE!-INPUT!-POLY,M!-IMAGE!-VARIABLE); MULTIVARIATE!-INPUT!-POLY:=CDR W1; INVERTED!-SIGN:=CAR W1; % to ease the lc problem, m!-input!-polynomial <- poly % produced by taking numerator of (m!-input!-polynomial % with 1/m!-image!-variable substituted for % m!-image!-variable); % m!-inverted!-sign is -1 if we have inverted the sign of % the resulting poly to keep it +ve, else +1; FACTOR!-TRACE << PRIN2!* "The trailing coefficient of U wrt "; PRINVAR M!-IMAGE!-VARIABLE; PRIN2!* "(="; PRIN2!* W; PRINTSTR ") is purely numeric so we 'invert' U to give: "; PRIN2!* " U <- "; FAC!-PRINTSF MULTIVARIATE!-INPUT!-POLY; PRINTSTR "This simplifies any problems with the leading "; PRINTSTR "coefficient of U." >> >> ELSE << TRACE!-TIME PRINTC "Factoring the leading coefficient:"; WTIME:=TIME(); FACTORED!-LC:= FACTORIZE!-FORM!-RECURSION LC MULTIVARIATE!-INPUT!-POLY; TRACE!-TIME DISPLAY!-TIME("Leading coefficient factored in ", TIME()-WTIME); % factorize the lc of m!-input!-polynomial completely; FACTOR!-TRACE << PRINTSTR "The leading coefficient of U is non-trivial so we must "; PRINTSTR "factor it before we can decide how it is distributed"; PRINTSTR "over the leading coefficients of the factors of U."; PRINTSTR "So the factors of this leading coefficient are:"; FAC!-PRINTFACTORS FACTORED!-LC >> >>; MAKE!-ZEROVARSET VARS!-TO!-KILL; % Sets ZEROVARSET and OTHERVARS; IF NULL ZEROVARSET THEN ZERO!-SET!-TRIED:=T ELSE << ZSET:=MAKE!-ZEROSET!-LIST LENGTH ZEROVARSET; SAVE!-ZSET:=ZSET >> END; SYMBOLIC PROCEDURE VARIABLES!-TO!-KILL LC!-U; % picks out all the variables in u except var. also checks to see if % any of these divide lc u: if they do they are dotted with t otherwise % dotted with nil. result is list of these dotted pairs; FOR EACH W IN CDR KORD!* COLLECT IF (DOMAINP LC!-U) OR DIDNTGO QUOTF(LC!-U,!*K2F W) THEN (W . NIL) ELSE (W . T); %**********************************************************************; % multivariate factorization part 2. creating image sets and picking % the best one; FLUID '(USABLE!-SET!-FOUND); SYMBOLIC PROCEDURE GET!-SOME!-RANDOM!-SETS(); % here we create a number of random sets to make the input % poly univariate by killing all but 1 of the variables. at % the same time we pick a random prime to reduce this image % poly mod p; BEGIN SCALAR IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P,WTIME, IMAGE!-CONTENT,IMAGE!-POLY,F!-NUMVEC,FORBIDDEN!-PRIMES,I,J, USABLE!-SET!-FOUND; VALID!-IMAGE!-SETS:=MKVECT NO!-OF!-RANDOM!-SETS; I:=0; WHILE I < NO!-OF!-RANDOM!-SETS DO << WTIME:=TIME(); GENERATE!-AN!-IMAGE!-SET!-WITH!-PRIME( IF I<IDIFFERENCE(NO!-OF!-RANDOM!-SETS,3) THEN NIL ELSE T); TRACE!-TIME DISPLAY!-TIME(" Image set generated in ",TIME()-WTIME); I:=IADD1 I; PUTV(VALID!-IMAGE!-SETS,I,LIST( IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P,IMAGE!-CONTENT, IMAGE!-POLY,F!-NUMVEC)); FORBIDDEN!-SETS:=IMAGE!-SET . FORBIDDEN!-SETS; FORBIDDEN!-PRIMES:=LIST CHOSEN!-PRIME; J:=1; WHILE (J<3) AND (I<NO!-OF!-RANDOM!-SETS) DO << WTIME:=TIME(); IMAGE!-MOD!-P:=FIND!-A!-VALID!-PRIME(IMAGE!-LC,IMAGE!-POLY, NOT NUMBERP IMAGE!-CONTENT); IF NOT(IMAGE!-MOD!-P='NOT!-SQUARE!-FREE) THEN << TRACE!-TIME DISPLAY!-TIME(" Prime and image mod p found in ", TIME()-WTIME); I:=IADD1 I; PUTV(VALID!-IMAGE!-SETS,I,LIST( IMAGE!-SET,CHOSEN!-PRIME,IMAGE!-LC,IMAGE!-MOD!-P, IMAGE!-CONTENT,IMAGE!-POLY,F!-NUMVEC)); FORBIDDEN!-PRIMES:=CHOSEN!-PRIME . FORBIDDEN!-PRIMES >>; J:=IADD1 J >> >> END; SYMBOLIC PROCEDURE CHOOSE!-THE!-BEST!-SET(); % given several random sets we now choose the best by factoring % each image mod its chosen prime and taking one with the % lowest factor count as the best for hensel growth; BEGIN SCALAR SPLIT!-LIST,POLY!-MOD!-P,NULL!-SPACE!-BASIS, KNOWN!-FACTORS,W,N,FNUM,REMAINING!-SPLIT!-LIST,WTIME; MODULAR!-INFO:=MKVECT NO!-OF!-RANDOM!-SETS; WTIME:=TIME(); FOR I:=1:NO!-OF!-RANDOM!-SETS DO << W:=GETV(VALID!-IMAGE!-SETS,I); GET!-FACTOR!-COUNT!-MOD!-P(I,GET!-IMAGE!-MOD!-P W, GET!-CHOSEN!-PRIME W,NOT NUMBERP GET!-IMAGE!-CONTENT W) >>; SPLIT!-LIST:=SORT(SPLIT!-LIST,FUNCTION LESSPPAIR); % this now contains a list of pairs (m . n) where % m is the no: of factors in image no: n. the list % is sorted with best split (smallest m) first; TRACE!-TIME DISPLAY!-TIME(" Factor counts found in ",TIME()-WTIME); IF CAAR SPLIT!-LIST = 1 THEN << IRREDUCIBLE:=T; RETURN NIL >>; W:=NIL; WTIME:=TIME(); FOR I:=1:NO!-OF!-BEST!-SETS DO << N:=CDAR SPLIT!-LIST; GET!-FACTORS!-MOD!-P(N, GET!-CHOSEN!-PRIME GETV(VALID!-IMAGE!-SETS,N)); W:=(CAR SPLIT!-LIST) . W; SPLIT!-LIST:=CDR SPLIT!-LIST >>; % pick the best few of these and find out their % factors mod p; TRACE!-TIME DISPLAY!-TIME(" Best factors mod p found in ",TIME()-WTIME); REMAINING!-SPLIT!-LIST:=SPLIT!-LIST; SPLIT!-LIST:=REVERSEWOC W; % keep only those images that are fully factored mod p; WTIME:=TIME(); CHECK!-DEGREE!-SETS(NO!-OF!-BEST!-SETS,T); % the best image is pointed at by best!-set!-pointer; TRACE!-TIME DISPLAY!-TIME(" Degree sets analysed in ",TIME()-WTIME); % now if these didn't help try the rest to see % if we can avoid finding new image sets altogether: ; IF BAD!-CASE THEN << BAD!-CASE:=NIL; WTIME:=TIME(); WHILE REMAINING!-SPLIT!-LIST DO << N:=CDAR REMAINING!-SPLIT!-LIST; GET!-FACTORS!-MOD!-P(N, GET!-CHOSEN!-PRIME GETV(VALID!-IMAGE!-SETS,N)); W:=(CAR REMAINING!-SPLIT!-LIST) . W; REMAINING!-SPLIT!-LIST:=CDR REMAINING!-SPLIT!-LIST >>; TRACE!-TIME DISPLAY!-TIME(" More sets factored mod p in ",TIME()-WTIME); SPLIT!-LIST:=REVERSEWOC W; WTIME:=TIME(); CHECK!-DEGREE!-SETS(NO!-OF!-RANDOM!-SETS - NO!-OF!-BEST!-SETS,T); % best!-set!-pointer hopefully points at the best image ; TRACE!-TIME DISPLAY!-TIME(" More degree sets analysed in ",TIME()-WTIME) >>; ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE:=T; FACTOR!-TRACE << W:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER); PRIN2!* "The chosen image set is: "; FOR EACH X IN GET!-IMAGE!-SET W DO << PRINVAR CAR X; PRIN2!* "="; PRIN2!* CDR X; PRIN2!* "; " >>; TERPRI!*(NIL); PRIN2!* "and chosen prime is "; PRINTSTR GET!-CHOSEN!-PRIME W; PRINTSTR "Image polynomial (made primitive) = "; FAC!-PRINTSF GET!-IMAGE!-POLY W; IF NOT(GET!-IMAGE!-CONTENT W=1) THEN << PRIN2!* " with (extracted) content of "; FAC!-PRINTSF GET!-IMAGE!-CONTENT W >>; PRIN2!* "The image polynomial mod "; PRIN2!* GET!-CHOSEN!-PRIME W; PRINTSTR ", made monic, is:"; FAC!-PRINTSF GET!-IMAGE!-MOD!-P W; PRINTSTR "and factors of the primitive image mod this prime are:"; FOR EACH X IN GETV(MODULAR!-INFO,BEST!-SET!-POINTER) DO FAC!-PRINTSF X; IF (FNUM:=GET!-F!-NUMVEC W) AND NOT !*OVERVIEW THEN << PRINTSTR "The numeric images of each (square-free) factor of"; PRINTSTR "the leading coefficient of the polynomial are as"; PRIN2!* "follows (in order):"; PRIN2!* " "; FOR I:=1:LENGTH CDR FACTORED!-LC DO << PRIN2!* GETV(FNUM,I); PRIN2!* "; " >>; TERPRI!*(NIL) >> >> END; %**********************************************************************; % multivariate factorization part 3. reconstruction of the % chosen image over the integers; SYMBOLIC PROCEDURE RECONSTRUCT!-IMAGE!-FACTORS!-OVER!-INTEGERS(); % the hensel construction from modular case to univariate % over the integers; BEGIN SCALAR BEST!-MODULUS,BEST!-FACTOR!-COUNT,INPUT!-POLYNOMIAL, INPUT!-LEADING!-COEFFICIENT,BEST!-KNOWN!-FACTORS,S,W,I, X!-IS!-FACTOR,X!-FACTOR; S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER); BEST!-KNOWN!-FACTORS:=GETV(MODULAR!-INFO,BEST!-SET!-POINTER); BEST!-MODULUS:=GET!-CHOSEN!-PRIME S; BEST!-FACTOR!-COUNT:=LENGTH BEST!-KNOWN!-FACTORS; INPUT!-POLYNOMIAL:=GET!-IMAGE!-POLY S; IF LDEG INPUT!-POLYNOMIAL=1 THEN IF NOT(X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT S) THEN ERRORF LIST("Trying to factor a linear image poly: ", INPUT!-POLYNOMIAL) ELSE BEGIN SCALAR BRECIP,WW,OM,X!-MOD!-P; NUMBER!-OF!-FACTORS:=2; PRIME!-BASE:=BEST!-MODULUS; X!-FACTOR:=!*K2F M!-IMAGE!-VARIABLE; PUTV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER, PUT!-IMAGE!-POLY!-AND!-CONTENT(S,LC GET!-IMAGE!-CONTENT S, MULTF(X!-FACTOR,GET!-IMAGE!-POLY S))); OM:=SET!-MODULUS BEST!-MODULUS; BRECIP:=MODULAR!-RECIPROCAL RED (WW:=REDUCE!-MOD!-P INPUT!-POLYNOMIAL); X!-MOD!-P:=!*F2MOD X!-FACTOR; ALPHALIST:=LIST( (X!-MOD!-P . BRECIP), (WW . MODULAR!-MINUS MODULAR!-TIMES(BRECIP,LC WW))); DO!-QUADRATIC!-GROWTH(LIST(X!-FACTOR,INPUT!-POLYNOMIAL), LIST(X!-MOD!-P,WW),BEST!-MODULUS); W:=LIST INPUT!-POLYNOMIAL; % All factors apart from X-FACTOR; SET!-MODULUS OM END ELSE << INPUT!-LEADING!-COEFFICIENT:=LC INPUT!-POLYNOMIAL; FACTOR!-TRACE << PRINTSTR "Next we use the Hensel Construction to grow these modular"; PRINTSTR "factors into factors over the integers." >>; W:=RECONSTRUCT!.OVER!.INTEGERS(); IF IRREDUCIBLE THEN RETURN T; IF (X!-IS!-FACTOR:=NOT NUMBERP GET!-IMAGE!-CONTENT S) THEN << NUMBER!-OF!-FACTORS:=LENGTH W + 1; X!-FACTOR:=!*K2F M!-IMAGE!-VARIABLE; PUTV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER, PUT!-IMAGE!-POLY!-AND!-CONTENT(S,LC GET!-IMAGE!-CONTENT S, MULTF(X!-FACTOR,GET!-IMAGE!-POLY S))); FIX!-ALPHAS() >> ELSE NUMBER!-OF!-FACTORS:=LENGTH W; IF NUMBER!-OF!-FACTORS=1 THEN RETURN IRREDUCIBLE:=T >>; IF NUMBER!-OF!-FACTORS>TARGET!-FACTOR!-COUNT THEN RETURN BAD!-CASE:=LIST GET!-IMAGE!-SET S; IMAGE!-FACTORS:=MKVECT NUMBER!-OF!-FACTORS; I:=1; FACTOR!-TRACE PRINTSTR "The full factors of the image polynomial are:"; FOR EACH IM!-FACTOR IN W DO << PUTV(IMAGE!-FACTORS,I,IM!-FACTOR); FACTOR!-TRACE FAC!-PRINTSF IM!-FACTOR; I:=IADD1 I >>; IF X!-IS!-FACTOR THEN << PUTV(IMAGE!-FACTORS,I,X!-FACTOR); FACTOR!-TRACE << FAC!-PRINTSF X!-FACTOR; FAC!-PRINTSF GET!-IMAGE!-CONTENT GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER) >> >> END; SYMBOLIC PROCEDURE DO!-QUADRATIC!-GROWTH(FLIST,MODFLIST,P); BEGIN SCALAR FHATVEC,ALPHAVEC,FACTORVEC,MODFVEC,FACVEC, CURRENT!-FACTOR!-PRODUCT,OM,I,DELTAM,M; FHATVEC:=MKVECT NUMBER!-OF!-FACTORS; ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS; FACTORVEC:=MKVECT NUMBER!-OF!-FACTORS; MODFVEC:=MKVECT NUMBER!-OF!-FACTORS; FACVEC:=MKVECT NUMBER!-OF!-FACTORS; CURRENT!-FACTOR!-PRODUCT:=1; I:=0; FOR EACH FF IN FLIST DO << PUTV(FACTORVEC,I:=IADD1 I,FF); CURRENT!-FACTOR!-PRODUCT:=MULTF(FF,CURRENT!-FACTOR!-PRODUCT) >>; I:=0; FOR EACH MODFF IN MODFLIST DO << PUTV(MODFVEC,I:=IADD1 I,MODFF); PUTV(ALPHAVEC,I,CDR GET!-ALPHA MODFF) >>; DELTAM:=P; M:=DELTAM*DELTAM; WHILE M<LARGEST!-SMALL!-MODULUS DO << QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS); M:=M*DELTAM >>; HENSEL!-GROWTH!-SIZE:=DELTAM; ALPHALIST:=NIL; FOR J:=1:NUMBER!-OF!-FACTORS DO ALPHALIST:=(REDUCE!-MOD!-P GETV(FACTORVEC,J) . GETV(ALPHAVEC,J)) . ALPHALIST END; SYMBOLIC PROCEDURE FIX!-ALPHAS(); % we extracted a factor x (where x is the image variable) % before any alphas were calculated, we now need to put % back this factor and its coresponding alpha which incidently % will change the other alphas; BEGIN SCALAR OM,F1,X!-FACTOR,A,ARECIP,B; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; F1:=REDUCE!-MOD!-P INPUT!-POLYNOMIAL; X!-FACTOR:=!*F2MOD !*K2F M!-IMAGE!-VARIABLE; ARECIP:=MODULAR!-RECIPROCAL (A:=EVALUATE!-MOD!-P(F1,M!-IMAGE!-VARIABLE,0)); B:=TIMES!-MOD!-P(MODULAR!-MINUS ARECIP, QUOTFAIL!-MOD!-P(DIFFERENCE!-MOD!-P(F1,A),X!-FACTOR)); ALPHALIST:=(X!-FACTOR . ARECIP) . (FOR EACH AA IN ALPHALIST COLLECT ((CAR AA) . REMAINDER!-MOD!-P(TIMES!-MOD!-P(B,CDR AA),CAR AA))); SET!-MODULUS OM END; %**********************************************************************; % multivariate factorization part 4. determining the leading % coefficients; SYMBOLIC PROCEDURE DETERMINE!.LEADING!.COEFFTS(); % this function determines the leading coeffts to all but a constant % factor which is spread over all of the factors before reconstruction; BEGIN SCALAR DELTA,C,S; S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER); DELTA:=GET!-IMAGE!-CONTENT S; % cont(the m!-input!-polynomial image); IF NOT DOMAINP LC MULTIVARIATE!-INPUT!-POLY THEN << TRUE!-LEADING!-COEFFTS:= DISTRIBUTE!.LC(NUMBER!-OF!-FACTORS,IMAGE!-FACTORS,S, FACTORED!-LC); IF BAD!-CASE THEN << BAD!-CASE:=LIST GET!-IMAGE!-SET S; TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1; IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T; RETURN BAD!-CASE >>; DELTA:=CAR TRUE!-LEADING!-COEFFTS; TRUE!-LEADING!-COEFFTS:=CDR TRUE!-LEADING!-COEFFTS; % if the lc problem exists then use wang's algorithm to % distribute it over the factors. ; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "We now determine the leading coefficients of the "; PRINTSTR "factors of U by using the factors of the leading"; PRINTSTR "coefficient of U and their (square-free) images"; PRINTSTR "referred to earlier:"; FOR I:=1:NUMBER!-OF!-FACTORS DO << PRINSF GETV(IMAGE!-FACTORS,I); PRIN2!* " with l.c.: "; FAC!-PRINTSF GETV(TRUE!-LEADING!-COEFFTS,I) >> >>; IF NOT ONEP DELTA THEN FACTOR!-TRACE << IF !*OVERVIEW THEN << PRINTSTR "In determining the leading coefficients of the factors"; PRIN2!* "of U, " >>; PRIN2!* "We have an integer factor, "; PRIN2!* DELTA; PRINTSTR ", left over that we "; PRINTSTR "cannot yet distribute correctly." >> >> ELSE << TRUE!-LEADING!-COEFFTS:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(TRUE!-LEADING!-COEFFTS,I,LC GETV(IMAGE!-FACTORS,I)); IF NOT ONEP DELTA THEN FACTOR!-TRACE << PRIN2!* "U has a leading coefficient = "; PRIN2!* DELTA; PRINTSTR " which we cannot "; PRINTSTR "yet distribute correctly over the image factors." >> >>; IF NOT ONEP DELTA THEN << FOR I:=1:NUMBER!-OF!-FACTORS DO << PUTV(IMAGE!-FACTORS,I,MULTF(DELTA,GETV(IMAGE!-FACTORS,I))); PUTV(TRUE!-LEADING!-COEFFTS,I, MULTF(DELTA,GETV(TRUE!-LEADING!-COEFFTS,I))) >>; DIVIDE!-ALL!-ALPHAS DELTA; C:=EXPT(DELTA,ISUB1 NUMBER!-OF!-FACTORS); MULTIVARIATE!-INPUT!-POLY:=MULTF(C,MULTIVARIATE!-INPUT!-POLY); NON!-MONIC:=T; FACTOR!-TRACE << PRINTSTR "(a) We multiply each of the image factors by the "; PRINTSTR "absolute value of this constant and multiply"; PRIN2!* "U by "; IF NOT(NUMBER!-OF!-FACTORS=2) THEN << PRIN2!* DELTA; PRIN2!* "**"; PRIN2!* ISUB1 NUMBER!-OF!-FACTORS >> ELSE PRIN2!* DELTA; PRINTSTR " giving new image factors"; PRINTSTR "as follows: "; FOR I:=1:NUMBER!-OF!-FACTORS DO FAC!-PRINTSF GETV(IMAGE!-FACTORS,I) >> >>; % if necessary, fiddle the remaining integer part of the % lc of m!-input!-polynomial; END; %**********************************************************************; % multivariate factorization part 5. reconstruction; SYMBOLIC PROCEDURE RECONSTRUCT!-MULTIVARIATE!-FACTORS VSET!-MOD!-P; % Hensel construction for multivariate case % Full univariate split has already been prepared (if factoring); % but we only need the modular factors and the true leading coeffts; (LAMBDA FACTOR!-LEVEL; BEGIN SCALAR S,OM,U0,ALPHAVEC,WTIME,PREDICTIONS, BEST!-FACTORS!-MOD!-P,FHATVEC,W1,FVEC!-MOD!-P,D,DEGREE!-BOUNDS, LC!-VEC; ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS; BEST!-FACTORS!-MOD!-P:=MKVECT NUMBER!-OF!-FACTORS; LC!-VEC := MKVECT NUMBER!-OF!-FACTORS; % This will preserve the LCs of the factors while we are working % mod p since they may contain numbers that are bigger than the % modulus.; IF NOT( (D:=MAX!-DEGREE(MULTIVARIATE!-INPUT!-POLY,0)) < PRIME!-BASE) THEN FVEC!-MOD!-P:=CHOOSE!-LARGER!-PRIME D; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; IF NULL FVEC!-MOD!-P THEN << FVEC!-MOD!-P:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(FVEC!-MOD!-P,I,REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I)) >>; FOR I:=1:NUMBER!-OF!-FACTORS DO << PUTV(ALPHAVEC,I,CDR GET!-ALPHA GETV(FVEC!-MOD!-P,I)); PUTV(BEST!-FACTORS!-MOD!-P,I, REDUCE!-MOD!-P GETV(BEST!-KNOWN!-FACTORS,I)); PUTV(LC!-VEC,I,LC GETV(BEST!-KNOWN!-FACTORS,I)) >>; % Set up the Alphas, input factors mod p and remember to save % the LCs for use after finding the multivariate factors mod p; IF NOT RECONSTRUCTING!-GCD THEN << S:=GETV(VALID!-IMAGE!-SETS,BEST!-SET!-POINTER); VSET!-MOD!-P:=FOR EACH V IN GET!-IMAGE!-SET S COLLECT (CAR V . MODULAR!-NUMBER CDR V) >>; % PRINC "KORD* =";% PRINT KORD!*; % PRINC "ORDER OF VARIABLE SUBSTITUTION=";% PRINT VSET!-MOD!-P; U0:=REDUCE!-MOD!-P MULTIVARIATE!-INPUT!-POLY; SET!-DEGREE!-BOUNDS VSET!-MOD!-P; WTIME:=TIME(); FACTOR!-TRACE << PRINTSTR "We use the Hensel Construction to grow univariate modular"; PRINTSTR "factors into multivariate modular factors, which will in"; PRINTSTR "turn be used in the later Hensel construction. The"; PRINTSTR "starting modular factors are:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,")=",BEST!-FACTORS!-MOD!-P); PRIN2!* "The modulus is "; PRINTSTR CURRENT!-MODULUS >>; FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(U0, BEST!-FACTORS!-MOD!-P, VSET!-MOD!-P); IF BAD!-CASE THEN << TRACE!-TIME << DISPLAY!-TIME(" Multivariate modular factors failed in ", TIME()-WTIME); WTIME:=TIME() >>; TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1; IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T; SET!-MODULUS OM; RETURN BAD!-CASE >>; TRACE!-TIME << DISPLAY!-TIME(" Multivariate modular factors found in ", TIME()-WTIME); WTIME:=TIME() >>; FHATVEC:=MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(BEST!-FACTORS!-MOD!-P, NUMBER!-OF!-FACTORS); FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(FVEC!-MOD!-P,I,GETV(BEST!-FACTORS!-MOD!-P,I)); MAKE!-VEC!-MODULAR!-SYMMETRIC(BEST!-FACTORS!-MOD!-P, NUMBER!-OF!-FACTORS); FOR I:=1:NUMBER!-OF!-FACTORS DO << % W1:=GETV(COEFFT!-VECTORS,I); % PUTV(BEST!-KNOWN!-FACTORS,I, % MERGE!-TERMS(GETV(BEST!-FACTORS!-MOD!-P,I),W1)); PUTV(BEST!-KNOWN!-FACTORS,I, FORCE!-LC(GETV(BEST!-FACTORS!-MOD!-P,I),GETV(LC!-VEC,I))); % Now we put back the LCs before growing the multivariate % factors to be correct over the integers giving the final % result; >>; WTIME:=TIME(); W1:=HENSEL!-MOD!-P( MULTIVARIATE!-INPUT!-POLY, FVEC!-MOD!-P, BEST!-KNOWN!-FACTORS, GET!.COEFFT!.BOUND(MULTIVARIATE!-INPUT!-POLY, TOTAL!-DEGREE!-IN!-POWERS(MULTIVARIATE!-INPUT!-POLY,NIL)), VSET!-MOD!-P, HENSEL!-GROWTH!-SIZE); IF CAR W1='OVERSHOT THEN << TRACE!-TIME << DISPLAY!-TIME(" Full factors failed in ",TIME()-WTIME); WTIME:=TIME() >>; TARGET!-FACTOR!-COUNT:=NUMBER!-OF!-FACTORS - 1; IF TARGET!-FACTOR!-COUNT=1 THEN IRREDUCIBLE:=T; SET!-MODULUS OM; RETURN BAD!-CASE:=T >>; IF NOT(CAR W1='OK) THEN ERRORF W1; TRACE!-TIME << DISPLAY!-TIME(" Full factors found in ",TIME()-WTIME); WTIME:=TIME() >>; IF RECONSTRUCTING!-GCD THEN << FULL!-GCD:=IF NON!-MONIC THEN CAR PRIMITIVE!.PARTS( LIST GETV(CDR W1,1),M!-IMAGE!-VARIABLE,NIL) ELSE GETV(CDR W1,1); SET!-MODULUS OM; RETURN FULL!-GCD >>; FOR I:=1:GETV(CDR W1,0) DO MULTIVARIATE!-FACTORS:=GETV(CDR W1,I) . MULTIVARIATE!-FACTORS; IF NON!-MONIC THEN MULTIVARIATE!-FACTORS:= PRIMITIVE!.PARTS(MULTIVARIATE!-FACTORS,M!-IMAGE!-VARIABLE,NIL); FACTOR!-TRACE << PRINTSTR "The full multivariate factors are:"; FOR EACH X IN MULTIVARIATE!-FACTORS DO FAC!-PRINTSF X >>; SET!-MODULUS OM; END) (FACTOR!-LEVEL*100); SYMBOLIC PROCEDURE CHECK!-INVERTED MULTI!-FACLIST; BEGIN SCALAR INV!.SIGN,L; IF INVERTED THEN << INV!.SIGN:=1; MULTI!-FACLIST:= FOR EACH X IN MULTI!-FACLIST COLLECT << L:=INVERT!.POLY(X,M!-IMAGE!-VARIABLE); INV!.SIGN:=(CAR L) * INV!.SIGN; CDR L >>; IF NOT(INV!.SIGN=INVERTED!-SIGN) THEN ERRORF LIST("INVERSION HAS LOST A SIGN",INV!.SIGN) >>; RETURN MULTIVARIATE!-FACTORS:=MULTI!-FACLIST END; ENDMODULE; MODULE FACTOR; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; % factorization of polynomials % % p. m. a. moore 1979. % % %**********************************************************************; SYMBOLIC PROCEDURE MULTIPLE!-RESULT(Z,W); % z is a list of items (n . prefix-form), and the largest value % of n must come first in this list. w is supposed to be an array % name. the items in the list z are put into the array w; BEGIN SCALAR X,Y,N; N:=(LENGTH Z)-1; IF NOT IDP W THEN << LPRIM "ANSWERS WILL BE IN 'ANS'"; W:='ANS >>; IF ATOM W AND (Y := DIMENSION W) AND NULL CDR Y THEN << % one dimensional array found; Y := CAR Y-1; IF CAAR Z>Y THEN REDERR "ARRAY TOO SMALL"; WHILE NOT Y<0 DO << IF NULL Z OR Y NEQ CAAR Z THEN SETELV(LIST(W,Y),0) ELSE << SETELV(LIST(W,Y),CDAR Z); Z := CDR Z >>; Y := Y-1 >>; RETURN !*N2F N ./ 1 >>; % here w was not the name of a 1-dimensional array, so i % will spread the results out into various discrete variables; Y := EXPLODE W; W := NIL; FOR EACH ZZ IN Z DO << W := INTERN COMPRESS APPEND(Y,EXPLODE CAR ZZ) . W; SETK1(CAR W,CDR ZZ,T) >>; IF LENGTH W=1 THEN LPRIM ACONC(W,"IS NOW NON-ZERO") ELSE LPRIM ACONC(W,"ARE NOW NON-ZERO"); RETURN !*N2F N ./ 1 END; %**********************************************************************; SYMBOLIC PROCEDURE FACTORF U; % This is the entry to the factorizer that is to be used % by programmers working at the symbolic level. U is to % be a standard form. FACTORF hands back a list giving the factors % of U. The format of said list is described below in the % comments with FACTORIZE!-FORM. % Entry to the factorizer at any level other than this is at % the programmers own risk!! ; FACTORF1(U,NIL); SYMBOLIC PROCEDURE FACTORF1(U,!*FORCE!-PRIME); % This entry to the factorizer allows one to force % the code to use some particular prime for its % modular factorization. It is not for casual % use; BEGIN SCALAR FACTOR!-LEVEL,BASE!-TIME,LAST!-DISPLAYED!-TIME, GC!-BASE!-TIME,LAST!-DISPLAYED!-GC!-TIME,GCDSAVE, CURRENT!-MODULUS,MODULUS!/2,W; GCDSAVE := !*GCD; !*GCD := T; % This code will not work otherwise! ; SET!-TIME(); FACTOR!-LEVEL := 0; W := FACTORIZE!-FORM U; !*GCD := GCDSAVE; RETURN W END; %**********************************************************************; SYMBOLIC PROCEDURE FACTORIZE!-FORM P; % input: % p is a reduce standard form that is to be factorized % over the integers % result: (nc . l) % where nc is numeric (may be just 1) % and l is list of the form: % ((p1 . x1) (p2 . x2) .. (pn . xn)) % where p<i> are standard forms and x<i> are integers, % and p= product<i> p<i>**x<i>; % % method: % (a) reorder polynomial to make the variable of lowest maximum % degree the main one and the rest ordered similarly; % (b) use contents and primitive parts to split p up as far as possible % (c) use square-free decomposition to continue the process % (c.1) detect & perform special processing on cyclotomic polynomials % (d) use modular-based method to find factors over integers; BEGIN SCALAR NEW!-KORDER,OLD!-KORDER; NEW!-KORDER:=KERNORD(P,POLYZERO); IF !*KERNREVERSE THEN NEW!-KORDER:=REVERSE NEW!-KORDER; OLD!-KORDER:=SETKORDER NEW!-KORDER; P:=REORDER P; % Make var of lowest degree the main one; P:=FACTORIZE!-FORM1(P,NEW!-KORDER); SETKORDER OLD!-KORDER; P := (CAR P . FOR EACH W IN CDR P COLLECT (REORDER CAR W . CDR W)); IF MINUSP CAR P AND NOT CDR P=NIL THEN P := (- CAR P) . (NEGF CAADR P . CDADR P) . CDDR P; RETURN P END; SYMBOLIC PROCEDURE FACTORIZE!-FORM1(P,GIVEN!-KORDER); % input: % p is a reduce standard form that is to be factorized % over the integers % given-korder is a list of kernels in the order of importance % (ie when finding leading terms etc. we use this list) % See FACTORIZE-FORM above; IF DOMAINP P THEN (P . NIL) ELSE BEGIN SCALAR M!-IMAGE!-VARIABLE,VAR!-LIST, POLYNOMIAL!-TO!-FACTOR,N; IF !*ALL!-CONTENTS THEN VAR!-LIST:=GIVEN!-KORDER ELSE << M!-IMAGE!-VARIABLE:=CAR GIVEN!-KORDER; VAR!-LIST:=LIST M!-IMAGE!-VARIABLE >>; RETURN (LAMBDA FACTOR!-LEVEL; << FACTOR!-TRACE << PRIN2!* "FACTOR : "; FAC!-PRINTSF P; PRIN2!* "Chosen main variable is "; PRINTVAR M!-IMAGE!-VARIABLE >>; POLYNOMIAL!-TO!-FACTOR:=P; N:=NUMERIC!-CONTENT P; P:=QUOTF(P,N); IF POLY!-MINUSP P THEN << P:=NEGF P; N:=-N >>; FACTOR!-TRACE << PRIN2!* "Numeric content = "; FAC!-PRINTSF N >>; P:=FACTORIZE!-BY!-CONTENTS(P,VAR!-LIST); P:=N . SORT!-FACTORS P; FACTOR!-TRACE << TERPRI(); TERPRI(); PRINTSTR "Final result is:"; FAC!-PRINTFACTORS P >>; P >>) (FACTOR!-LEVEL+1) END; SYMBOLIC PROCEDURE FACTORIZE!-FORM!-RECURSION P; % this is essentially the same as FACTORIZE!-FORM except that % we must be careful of stray minus signs due to a possible % reordering in the recursive factoring; BEGIN SCALAR S,N,X,RES,NEW!-KORDER,OLD!-KORDER; NEW!-KORDER:=KERNORD(P,POLYZERO); IF !*KERNREVERSE THEN NEW!-KORDER:=REVERSE NEW!-KORDER; OLD!-KORDER:=SETKORDER NEW!-KORDER; P:=REORDER P; % Make var of lowest degree the main one; X:=FACTORIZE!-FORM1(P,NEW!-KORDER); SETKORDER OLD!-KORDER; N := CAR X; X := FOR EACH P IN CDR X COLLECT (REORDER CAR P . CDR P); IF MINUSP N THEN << S:=-1; N:=-N >> ELSE S:=1; RES:=FOR EACH FF IN X COLLECT IF POLY!-MINUSP CAR FF THEN << S:=S*(-1**CDR FF); (NEGF CAR FF . CDR FF) >> ELSE FF; IF MINUSP S THEN ERRORF LIST( "Stray minus sign in recursive factorisation:",X); RETURN (N . RES) END; SYMBOLIC PROCEDURE SORT!-FACTORS L; %sort factors as found into some sort of standard order. The order %used here is more or less random, but will be self-consistent; SORT(L,FUNCTION ORDERFACTORS); %**********************************************************************; % contents and primitive parts as applied to factorization; SYMBOLIC PROCEDURE FACTORIZE!-BY!-CONTENTS(P,V); %use contents wrt variables in list v to split the %polynomial p. return a list of factors; % specification is that on entry p *must* be positive; IF DOMAINP P THEN ERRORF LIST("FACTORIZE-BY-CONTENTS HANDED DOMAIN ELT:",P) ELSE IF NULL V THEN SQUARE!.FREE!.FACTORIZE P ELSE BEGIN SCALAR C,W,L,WTIME; W:=CONTENTS!-WITH!-RESPECT!-TO(P,CAR V); % contents!-with!-respect!-to returns a pair (g . c) where % if g=nil the content is just c, otherwise g is a power % [ x ** n ] and g*c is the content; IF NOT NULL CAR W THEN << % here a power of v divides p; L:=(!*K2F CAAR W . CDAR W) . NIL; P:=QUOTFAIL(P,!*P2F CAR W); IF P=1 THEN RETURN L ELSE IF DOMAINP P THEN ERRORF "P SHOULD NOT BE CONSTANT HERE" >>; C:=CDR W; IF C=1 THEN << %no progress here; IF NULL L THEN FACTOR!-TRACE << PRIN2!* "Polynomial is primitive wrt "; PRINVAR CAR V; TERPRI!*(NIL) >> ELSE FACTOR!-TRACE << PRINTSTR "Content is: "; FAC!-PRINTFACTORS(1 . L) >>; RETURN IF !*ALL!-CONTENTS THEN APPEND(FACTORIZE!-BY!-CONTENTS(P,CDR V),L) ELSE APPEND(SQUARE!.FREE!.FACTORIZE P,L) >>; P:=QUOTFAIL(P,C); %primitive part; % p is now primitive, so if it is not a real polynomial it % must be a unit. since input was +ve it had better be +1 !! ; IF P=-1 THEN ERRORF "NEGATIVE PRIMITIVE PART IN FACTORIZE-BY-CONTENTS"; TRACE!-TIME PRINTC "Factoring the content:"; WTIME:=TIME(); L:=APPEND(CDR1 FACTORIZE!-FORM!-RECURSION C,L); TRACE!-TIME DISPLAY!-TIME("Content factored in ", TIME()-WTIME); FACTOR!-TRACE << PRIN2!* "Content wrt "; PRINVAR CAR V; PRIN2!* " is: "; FAC!-PRINTSF COMFAC!-TO!-POLY W; PRINTSTR "Factors of content are: "; FAC!-PRINTFACTORS(1 . L) >>; IF P=1 THEN RETURN L ELSE IF !*ALL!-CONTENTS THEN RETURN APPEND(FACTORIZE!-BY!-CONTENTS(P,CDR V),L) ELSE RETURN APPEND(SQUARE!.FREE!.FACTORIZE P,L) END; SYMBOLIC PROCEDURE CDR1 A; IF CAR A=1 THEN CDR A ELSE ERRORF LIST("NUMERIC CONTENT NOT EXTRACTED:",CAR A); ENDMODULE; MODULE FACUNI; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; SYMBOLIC PROCEDURE UNIVARIATE!-FACTORIZE POLY; % input poly a primitive square-free univariate polynomial at least % quadratic and with +ve lc. output is a list of the factors of poly % over the integers ; IF TESTX!*!*N!+1 POLY THEN FACTORIZEX!*!*N!+1(M!-IMAGE!-VARIABLE,LDEG POLY,1) ELSE IF TESTX!*!*N!-1 POLY THEN FACTORIZEX!*!*N!-1(M!-IMAGE!-VARIABLE,LDEG POLY,1) ELSE UNIVARIATE!-FACTORIZE1 POLY; SYMBOLIC PROCEDURE UNIVARIATE!-FACTORIZE1 POLY; BEGIN SCALAR VALID!-PRIMES,UNIVARIATE!-INPUT!-POLY,BEST!-SET!-POINTER, NUMBER!-OF!-FACTORS,IRREDUCIBLE,FORBIDDEN!-PRIMES, NO!-OF!-BEST!-PRIMES,NO!-OF!-RANDOM!-PRIMES,BAD!-CASE, TARGET!-FACTOR!-COUNT,MODULAR!-INFO,UNIVARIATE!-FACTORS, HENSEL!-GROWTH!-SIZE,ALPHALIST,PREVIOUS!-DEGREE!-MAP, ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE,REDUCTION!-COUNT; %note that this code works by using a local database of %fluid variables that are updated by the subroutines directly %called here. this allows for the relativly complicated %interaction between flow of data and control that occurs in %the factorization algorithm; FACTOR!-TRACE << PRIN2!* "Univariate polynomial="; FAC!-PRINTSF POLY; PRINTSTR "The polynomial is univariate, primitive and square-free"; PRINTSTR "so we can treat it slightly more specifically. We"; PRINTSTR "factorise mod several primes,then pick the best one"; PRINTSTR "to use in the Hensel construction." >>; INITIALIZE!-UNIVARIATE!-FLUIDS POLY; % set up the fluids to start things off; TRYAGAIN: GET!-SOME!-RANDOM!-PRIMES(); CHOOSE!-THE!-BEST!-PRIME(); IF IRREDUCIBLE THEN << UNIVARIATE!-FACTORS:=LIST UNIVARIATE!-INPUT!-POLY; GOTO EXIT >> ELSE IF BAD!-CASE THEN << BAD!-CASE:=NIL; GOTO TRYAGAIN >>; RECONSTRUCT!-FACTORS!-OVER!-INTEGERS(); IF IRREDUCIBLE THEN << UNIVARIATE!-FACTORS:=LIST UNIVARIATE!-INPUT!-POLY; GOTO EXIT >>; EXIT: FACTOR!-TRACE << PRINTSTR "The univariate factors are:"; FOR EACH FF IN UNIVARIATE!-FACTORS DO FAC!-PRINTSF FF >>; RETURN UNIVARIATE!-FACTORS END; %********************************************************************** % univariate factorization part 1. initialization and setting fluids; SYMBOLIC PROCEDURE INITIALIZE!-UNIVARIATE!-FLUIDS U; % Set up the fluids to be used in factoring primitive poly; BEGIN SCALAR W,W1; IF !*FORCE!-PRIME THEN << NO!-OF!-RANDOM!-PRIMES:=1; NO!-OF!-BEST!-PRIMES:=1 >> ELSE << NO!-OF!-RANDOM!-PRIMES:=5; % we generate this many modular images and calculate % their factor counts; NO!-OF!-BEST!-PRIMES:=3; % we find the modular factors of this many; >>; UNIVARIATE!-INPUT!-POLY:=U; TARGET!-FACTOR!-COUNT:=LDEG U END; %**********************************************************************; % univariate factorization part 2. creating modular images and picking % the best one; SYMBOLIC PROCEDURE GET!-SOME!-RANDOM!-PRIMES(); % here we create a number of random primes to reduce the input mod p; BEGIN SCALAR CHOSEN!-PRIME,POLY!-MOD!-P,I; VALID!-PRIMES:=MKVECT NO!-OF!-RANDOM!-PRIMES; I:=0; WHILE I < NO!-OF!-RANDOM!-PRIMES DO << POLY!-MOD!-P:= FIND!-A!-VALID!-PRIME(LC UNIVARIATE!-INPUT!-POLY, UNIVARIATE!-INPUT!-POLY,NIL); IF NOT(POLY!-MOD!-P='NOT!-SQUARE!-FREE) THEN << I:=IADD1 I; PUTV(VALID!-PRIMES,I,CHOSEN!-PRIME . POLY!-MOD!-P); FORBIDDEN!-PRIMES:=CHOSEN!-PRIME . FORBIDDEN!-PRIMES >> >> END; SYMBOLIC PROCEDURE CHOOSE!-THE!-BEST!-PRIME(); % given several random primes we now choose the best by factoring % the poly mod its chosen prime and taking one with the % lowest factor count as the best for hensel growth; BEGIN SCALAR SPLIT!-LIST,POLY!-MOD!-P,NULL!-SPACE!-BASIS, KNOWN!-FACTORS,W,N; MODULAR!-INFO:=MKVECT NO!-OF!-RANDOM!-PRIMES; FOR I:=1:NO!-OF!-RANDOM!-PRIMES DO << W:=GETV(VALID!-PRIMES,I); GET!-FACTOR!-COUNT!-MOD!-P(I,CDR W,CAR W,NIL) >>; SPLIT!-LIST:=SORT(SPLIT!-LIST,FUNCTION LESSPPAIR); % this now contains a list of pairs (m . n) where % m is the no: of factors in set no: n. the list % is sorted with best split (smallest m) first; IF CAAR SPLIT!-LIST = 1 THEN << IRREDUCIBLE:=T; RETURN NIL >>; W:=SPLIT!-LIST; FOR I:=1:NO!-OF!-BEST!-PRIMES DO << N:=CDAR W; GET!-FACTORS!-MOD!-P(N,CAR GETV(VALID!-PRIMES,N)); W:=CDR W >>; % pick the best few of these and find out their % factors mod p; SPLIT!-LIST:=DELETE(W,SPLIT!-LIST); % throw away the other sets; CHECK!-DEGREE!-SETS(NO!-OF!-BEST!-PRIMES,NIL); % the best set is pointed at by best!-set!-pointer; ONE!-COMPLETE!-DEG!-ANALYSIS!-DONE:=T; FACTOR!-TRACE << W:=GETV(VALID!-PRIMES,BEST!-SET!-POINTER); PRIN2!* "The chosen prime is "; PRINTSTR CAR W; PRIN2!* "The polynomial mod "; PRIN2!* CAR W; PRINTSTR ", made monic, is:"; FAC!-PRINTSF CDR W; PRINTSTR "and the factors of this modular polynomial are:"; FOR EACH X IN GETV(MODULAR!-INFO,BEST!-SET!-POINTER) DO FAC!-PRINTSF X; >> END; %**********************************************************************; % univariate factorization part 3. reconstruction of the % chosen image over the integers; SYMBOLIC PROCEDURE RECONSTRUCT!-FACTORS!-OVER!-INTEGERS(); % the hensel construction from modular case to univariate % over the integers; BEGIN SCALAR BEST!-MODULUS,BEST!-FACTOR!-COUNT,INPUT!-POLYNOMIAL, INPUT!-LEADING!-COEFFICIENT,BEST!-KNOWN!-FACTORS,S; S:=GETV(VALID!-PRIMES,BEST!-SET!-POINTER); BEST!-KNOWN!-FACTORS:=GETV(MODULAR!-INFO,BEST!-SET!-POINTER); INPUT!-LEADING!-COEFFICIENT:=LC UNIVARIATE!-INPUT!-POLY; BEST!-MODULUS:=CAR S; BEST!-FACTOR!-COUNT:=LENGTH BEST!-KNOWN!-FACTORS; INPUT!-POLYNOMIAL:=UNIVARIATE!-INPUT!-POLY; UNIVARIATE!-FACTORS:=RECONSTRUCT!.OVER!.INTEGERS(); IF IRREDUCIBLE THEN RETURN T; NUMBER!-OF!-FACTORS:=LENGTH UNIVARIATE!-FACTORS; IF NUMBER!-OF!-FACTORS=1 THEN RETURN IRREDUCIBLE:=T END; SYMBOLIC PROCEDURE RECONSTRUCT!.OVER!.INTEGERS(); BEGIN SCALAR W,LCLIST,NON!-MONIC; SET!-MODULUS BEST!-MODULUS; FOR I:=1:BEST!-FACTOR!-COUNT DO LCLIST:=INPUT!-LEADING!-COEFFICIENT . LCLIST; IF NOT (INPUT!-LEADING!-COEFFICIENT=1) THEN << BEST!-KNOWN!-FACTORS:= FOR EACH FF IN BEST!-KNOWN!-FACTORS COLLECT MULTF(INPUT!-LEADING!-COEFFICIENT,!*MOD2F FF); NON!-MONIC:=T; FACTOR!-TRACE << PRINTSTR "(a) Now the polynomial is not monic so we multiply each"; PRINTSTR "of the modular factors, f(i), by the absolute value of"; PRIN2!* "the leading coefficient: "; PRIN2!* INPUT!-LEADING!-COEFFICIENT; PRINTSTR '!.; PRINTSTR "To bring the polynomial into agreement with this, we"; PRIN2!* "multiply it by "; IF BEST!-FACTOR!-COUNT > 2 THEN << PRIN2!* INPUT!-LEADING!-COEFFICIENT; PRIN2!* "**"; PRINTSTR ISUB1 BEST!-FACTOR!-COUNT >> ELSE PRINTSTR INPUT!-LEADING!-COEFFICIENT >> >>; W:=UHENSEL!.EXTEND(INPUT!-POLYNOMIAL, BEST!-KNOWN!-FACTORS,LCLIST,BEST!-MODULUS); IF IRREDUCIBLE THEN RETURN T; IF CAR W ='OK THEN RETURN CDR W ELSE ERRORF W END; % Now some special treatment for cyclotomic polynomials; SYMBOLIC PROCEDURE TESTX!*!*N!+1 U; NOT DOMAINP U AND ( LC U=1 AND RED U = 1); SYMBOLIC PROCEDURE TESTX!*!*N!-1 U; NOT DOMAINP U AND ( LC U=1 AND RED U = -1); SYMBOLIC PROCEDURE FACTORIZEX!*!*N!+1(VAR,DEGREE,VORDER); % Deliver factors of (VAR**VORDER)**DEGREE+1 given that it is % appropriate to treat VAR**VORDER as a kernel; IF EVENP DEGREE THEN FACTORIZEX!*!*N!+1(VAR,DEGREE/2,2*VORDER) ELSE BEGIN SCALAR W; W := FACTORIZEX!*!*N!-1(VAR,DEGREE,VORDER); W := NEGF CAR W . CDR W; RETURN FOR EACH P IN W COLLECT NEGATE!-VARIABLE(VAR,2*VORDER,P) END; SYMBOLIC PROCEDURE NEGATE!-VARIABLE(VAR,VORDER,P); % VAR**(VORDER/2) -> -VAR**(VORDER/2) in the polynomial P; IF DOMAINP P THEN P ELSE IF MVAR P=VAR THEN IF REMAINDER(LDEG P,VORDER)=0 THEN LT P .+ NEGATE!-VARIABLE(VAR,VORDER,RED P) ELSE (LPOW P .* NEGF LC P) .+ NEGATE!-VARIABLE(VAR,VORDER,RED P) ELSE (LPOW P .* NEGATE!-VARIABLE(VAR,VORDER,LC P)) .+ NEGATE!-VARIABLE(VAR,VORDER,RED P); SYMBOLIC PROCEDURE INTEGER!-FACTORS N; % Return integer factors of N, with attached multiplicities. Assumes % that N is fairly small; BEGIN SCALAR L,Q,M,W; % L is list of results generated so far, Q is current test divisor, % and M is associated multiplicity; IF N=1 THEN RETURN '((1 . 1)); Q := 2; M := 0; TOP: W := DIVIDE(N,Q); WHILE CDR W=0 DO << N := CAR W; W := DIVIDE(N,Q); M := M+1 >>; IF NOT M=0 THEN L := (Q . M) . L; IF Q>CAR W THEN << IF NOT N=1 THEN L := (N . 1) . L; RETURN REVERSEWOC L >>; Q := ILOGOR(1,IADD1 Q); % Test divide by 2,3,5,7,9,11,13,... ; M := 0; GO TO TOP END; SYMBOLIC PROCEDURE FACTORED!-DIVISORS FL; % FL is an association list of primes and exponents. Return a list % of all subsets of this list, i.e. of numbers dividing the % original integer. Exclude '1' from the list; IF NULL FL THEN NIL ELSE BEGIN SCALAR L,W; W := FACTORED!-DIVISORS CDR FL; L := W; FOR I := 1:CDAR FL DO << L := LIST (CAAR FL . I) . L; FOR EACH P IN W DO L := ((CAAR FL . I) . P) . L >>; RETURN L END; SYMBOLIC PROCEDURE FACTORIZEX!*!*N!-1(VAR,DEGREE,VORDER); IF EVENP DEGREE THEN APPEND(FACTORIZEX!*!*N!+1(VAR,DEGREE/2,VORDER), FACTORIZEX!*!*N!-1(VAR,DEGREE/2,VORDER)) ELSE IF DEGREE=1 THEN LIST((MKSP(VAR,VORDER) .* 1) .+ (-1)) ELSE BEGIN SCALAR FACDEG,L; FACDEG := '((1 . 1)) . FACTORED!-DIVISORS INTEGER!-FACTORS DEGREE; RETURN FOR EACH FL IN FACDEG COLLECT CYCLOTOMIC!-POLYNOMIAL(VAR,FL,VORDER) END; SYMBOLIC PROCEDURE CYCLOTOMIC!-POLYNOMIAL(VAR,FL,VORDER); % Create Psi<degree>(var**order) % where degree is given by the association list of primes and % multiplicities FL; IF NOT CDAR FL=1 THEN CYCLOTOMIC!-POLYNOMIAL(VAR,(CAAR FL . SUB1 CDAR FL) . CDR FL, VORDER*CAAR FL) ELSE IF CDR FL=NIL THEN IF CAAR FL=1 THEN (MKSP(VAR,VORDER) .* 1) .+ (-1) ELSE QUOTFAIL((MKSP(VAR,VORDER*CAAR FL) .* 1) .+ (-1), (MKSP(VAR,VORDER) .* 1) .+ (-1)) ELSE QUOTFAIL(CYCLOTOMIC!-POLYNOMIAL(VAR,CDR FL,VORDER*CAAR FL), CYCLOTOMIC!-POLYNOMIAL(VAR,CDR FL,VORDER)); ENDMODULE; MODULE IMAGESET; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %*******************************************************************; % % this section deals with the image sets used in % factorising multivariate polynomials according % to wang's theories. % ref: math. comp. vol.32 no.144 oct 1978 pp 1217-1220 % 'an improved multivariate polynomial factoring algorithm' % %*******************************************************************; %*******************************************************************; % first we have routines for generating the sets %*******************************************************************; SYMBOLIC PROCEDURE GENERATE!-AN!-IMAGE!-SET!-WITH!-PRIME GOOD!-SET!-NEEDED; % given a multivariate poly (in a fluid) we generate an image set % to make it univariate and also a random prime to use in the % modular factorization. these numbers are random except that % we will not allow anything in forbidden!-sets or forbidden!-primes; BEGIN SCALAR CURRENTLY!-FORBIDDEN!-SETS,U,WTIME; U:=MULTIVARIATE!-INPUT!-POLY; % a bit of a handful to type otherwise!!!! ; IMAGE!-SET:=NIL; CURRENTLY!-FORBIDDEN!-SETS:=FORBIDDEN!-SETS; TRYANOTHERSET: IF IMAGE!-SET THEN CURRENTLY!-FORBIDDEN!-SETS:=IMAGE!-SET . CURRENTLY!-FORBIDDEN!-SETS; WTIME:=TIME(); IMAGE!-SET:=GET!-NEW!-SET CURRENTLY!-FORBIDDEN!-SETS; % PRINC "Trying imageset= "; % PRINTC IMAGE!-SET; TRACE!-TIME << DISPLAY!-TIME(" New image set found in ",TIME()-WTIME); WTIME:=TIME() >>; IMAGE!-LC:=MAKE!-IMAGE!-LC!-LIST(LC U,IMAGE!-SET); % list of image lc's wrt different variables in IMAGE-SET; % PRINC "Image set to try is:";% PRINTC IMAGE!-SET; % PRIN2!* "L.C. of poly is:";% FAC!-PRINTSF LC U; % PRINTC "Image l.c.s with variables substituted on order:"; % FOR EACH IMLC IN IMAGE!-LC DO FAC!-PRINTSF IMLC; TRACE!-TIME DISPLAY!-TIME(" Image of lc made in ",TIME()-WTIME); IF (CAAR IMAGE!-LC)=0 THEN GOTO TRYANOTHERSET; WTIME:=TIME(); IMAGE!-POLY:=MAKE!-IMAGE(U,IMAGE!-SET); TRACE!-TIME << DISPLAY!-TIME(" Image poly made in ",TIME()-WTIME); WTIME:=TIME() >>; IMAGE!-CONTENT:=GET!.CONTENT IMAGE!-POLY; % note: the content contains the image variable if it % is a factor of the image poly; TRACE!-TIME DISPLAY!-TIME(" Content found in ",TIME()-WTIME); IMAGE!-POLY:=QUOTFAIL(IMAGE!-POLY,IMAGE!-CONTENT); % make sure the image polynomial is primitive which includes % making the leading coefft positive (-ve content if % necessary); WTIME:=TIME(); IMAGE!-MOD!-P:=FIND!-A!-VALID!-PRIME(IMAGE!-LC,IMAGE!-POLY, NOT NUMBERP IMAGE!-CONTENT); IF IMAGE!-MOD!-P='NOT!-SQUARE!-FREE THEN GOTO TRYANOTHERSET; TRACE!-TIME << DISPLAY!-TIME(" Prime and image mod p found in ",TIME()-WTIME); WTIME:=TIME() >>; IF FACTORED!-LC THEN IF F!-NUMVEC:=UNIQUE!-F!-NOS(FACTORED!-LC,IMAGE!-CONTENT, IMAGE!-SET) THEN << USABLE!-SET!-FOUND:=T; TRACE!-TIME DISPLAY!-TIME(" Nos for lc found in ",TIME()-WTIME) >> ELSE << TRACE!-TIME DISPLAY!-TIME(" Nos for lc failed in ", TIME()-WTIME); IF (NOT USABLE!-SET!-FOUND) AND GOOD!-SET!-NEEDED THEN GOTO TRYANOTHERSET >> END; SYMBOLIC PROCEDURE GET!-NEW!-SET FORBIDDEN!-S; % associate each variable in vars-to-kill with a random no. mod % image-set-modulus. If the boolean tagged with a variable is true then % a value of 1 or 0 is no good and so rejected, however all other % variables can take these values so they are tried exhaustively before % using truly random values. sets in forbidden!-s not allowed; BEGIN SCALAR OLD!.M,ALIST,N,NEXTZSET,W; IF ZERO!-SET!-TRIED THEN << IF !*FORCE!-ZERO!-SET THEN ERRORF "Zero set tried - possibly it was invalid"; IMAGE!-SET!-MODULUS:=IADD1 IMAGE!-SET!-MODULUS; OLD!.M:=SET!-MODULUS IMAGE!-SET!-MODULUS; ALIST:=FOR EACH V IN VARS!-TO!-KILL COLLECT << N:=MODULAR!-NUMBER RANDOM(); IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS; IF CDR V THEN << WHILE N=0 OR N=1 OR (N = (ISUB1 CURRENT!-MODULUS)) DO N:=MODULAR!-NUMBER RANDOM(); IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS >>; CAR V . N >> >> ELSE << OLD!.M:=SET!-MODULUS IMAGE!-SET!-MODULUS; NEXTZSET:=CAR ZSET; ALIST:=FOR EACH ZV IN ZEROVARSET COLLECT << W:=ZV . CAR NEXTZSET; NEXTZSET:=CDR NEXTZSET; W >>; IF OTHERVARS THEN ALIST:= APPEND(ALIST,FOR EACH V IN OTHERVARS COLLECT << N:=MODULAR!-NUMBER RANDOM(); WHILE N=0 OR N=1 OR (N = (ISUB1 CURRENT!-MODULUS)) DO N:=MODULAR!-NUMBER RANDOM(); IF N>MODULUS!/2 THEN N:=N-CURRENT!-MODULUS; V . N >>); IF NULL(ZSET:=CDR ZSET) THEN IF NULL SAVE!-ZSET THEN ZERO!-SET!-TRIED:=T ELSE ZSET:=MAKE!-NEXT!-ZSET SAVE!-ZSET; ALIST:=FOR EACH V IN CDR KORD!* COLLECT ATSOC(V,ALIST); % Puts the variables in alist in the right order; >>; SET!-MODULUS OLD!.M; RETURN IF MEMBER(ALIST,FORBIDDEN!-S) THEN GET!-NEW!-SET FORBIDDEN!-S ELSE ALIST END; %********************************************************************** % now given an image/univariate polynomial find a suitable random prime; SYMBOLIC PROCEDURE FIND!-A!-VALID!-PRIME(LC!-U,U,FACTOR!-X); % finds a suitable random prime for reducing a poly mod p. % u is the image/univariate poly. we are not allowed to use % any of the primes in forbidden!-primes (fluid). % lc!-u is either numeric or (in the multivariate case) a list of % images of the lc; BEGIN SCALAR CURRENTLY!-FORBIDDEN!-PRIMES,RES,PRIME!-COUNT,V,W; IF FACTOR!-X THEN U:=MULTF(U,V:=!*K2F M!-IMAGE!-VARIABLE); CHOSEN!-PRIME:=NIL; CURRENTLY!-FORBIDDEN!-PRIMES:=FORBIDDEN!-PRIMES; PRIME!-COUNT:=1; TRYANOTHERPRIME: IF CHOSEN!-PRIME THEN CURRENTLY!-FORBIDDEN!-PRIMES:=CHOSEN!-PRIME . CURRENTLY!-FORBIDDEN!-PRIMES; CHOSEN!-PRIME:=GET!-NEW!-PRIME CURRENTLY!-FORBIDDEN!-PRIMES; SET!-MODULUS CHOSEN!-PRIME; IF NOT ATOM LC!-U THEN << W:=LC!-U; WHILE W AND ((DOMAINP CAAR W AND NOT(MODULAR!-NUMBER CAAR W = 0)) OR NOT (DOMAINP CAAR W OR MODULAR!-NUMBER L!-NUMERIC!-C(CAAR W,CDAR W)=0)) DO W:=CDR W; IF W THEN GOTO TRYANOTHERPRIME >> ELSE IF MODULAR!-NUMBER LC!-U=0 THEN GOTO TRYANOTHERPRIME; RES:=MONIC!-MOD!-P REDUCE!-MOD!-P U; IF NOT SQUARE!-FREE!-MOD!-P RES THEN IF MULTIVARIATE!-INPUT!-POLY AND (PRIME!-COUNT:=PRIME!-COUNT+1)>5 THEN RES:='NOT!-SQUARE!-FREE ELSE GOTO TRYANOTHERPRIME; IF FACTOR!-X AND NOT(RES='NOT!-SQUARE!-FREE) THEN RES:=QUOTFAIL!-MOD!-P(RES,!*F2MOD V); RETURN RES END; SYMBOLIC PROCEDURE GET!-NEW!-PRIME FORBIDDEN!-P; % get a small prime that is not in the list forbidden!-p; % we pick one of the first 10 primes if we can; IF !*FORCE!-PRIME THEN !*FORCE!-PRIME ELSE BEGIN SCALAR P,PRIMES!-DONE; FOR EACH PP IN FORBIDDEN!-P DO IF PP<32 THEN PRIMES!-DONE:=PP.PRIMES!-DONE; TRYAGAIN: IF NULL(P:=RANDOM!-TEENY!-PRIME PRIMES!-DONE) THEN << P:=RANDOM!-SMALL!-PRIME(); PRIMES!-DONE:='ALL >> ELSE PRIMES!-DONE:=P . PRIMES!-DONE; IF MEMBER(P,FORBIDDEN!-P) THEN GOTO TRYAGAIN; RETURN P END; %*********************************************************************** % find the numbers associated with each factor of the leading % coefficient of our multivariate polynomial. this will help % to distribute the leading coefficient later.; SYMBOLIC PROCEDURE UNIQUE!-F!-NOS(V,CONT!.U0,IM!.SET); % given an image set (im!.set), this finds the numbers associated with % each factor in v subject to wang's condition (2) on the image set. % this is an implementation of his algorithm n. if the condition % is met the result is a vector containing the images of each factor % in v, otherwise the result is nil; BEGIN SCALAR D,K,Q,R,LC!.IMAGE!.VEC; % v's integer factor is at the front: ; K:=LENGTH CDR V; % no. of non-trivial factors of v; IF NOT NUMBERP CONT!.U0 THEN CONT!.U0:=LC CONT!.U0; PUTV(D:=MKVECT K,0,ABS(CONT!.U0 * CAR V)); % d will contain the special numbers to be used in the % loop below; PUTV(LC!.IMAGE!.VEC:=MKVECT K,0,ABS(CONT!.U0 * CAR V)); % vector for result with 0th entry filled in; V:=CDR V; % throw away integer factor of v; % k is no. of non-trivial factors (say f(i)) in v; % d will contain the nos. associated with each f(i); % v is now a list of the f(i) (and their multiplicities); FOR I:=1:K DO << Q:=ABS MAKE!-IMAGE(CAAR V,IM!.SET); PUTV(LC!.IMAGE!.VEC,I,Q); V:=CDR V; FOR J:=ISUB1 I STEP -1 UNTIL 0 DO << R:=GETV(D,J); WHILE NOT ONEP R DO << R:=GCD(R,Q); Q:=Q/R >>; IF ONEP Q THEN RETURN LC!.IMAGE!.VEC:=NIL; % if q=1 here then we have failed the condition so exit; >>; IF NULL LC!.IMAGE!.VEC THEN RETURN LC!.IMAGE!.VEC; PUTV(D,I,Q); % else q is the ith number we want; >>; RETURN LC!.IMAGE!.VEC END; SYMBOLIC PROCEDURE GET!.CONTENT U; % u is a univariate square free poly. gets the content of u (=integer); % if lc u is negative then the minus sign is pulled out as well; % nb. the content includes the variable if it is a factor of u; BEGIN SCALAR C; C:=IF POLY!-MINUSP U THEN -(NUMERIC!-CONTENT U) ELSE NUMERIC!-CONTENT U; IF NOT DIDNTGO QUOTF(U,!*K2F M!-IMAGE!-VARIABLE) THEN C:=ADJOIN!-TERM(MKSP(M!-IMAGE!-VARIABLE,1),C,POLYZERO); RETURN C END; %********************************************************************; % finally we have the routines that use the numbers generated % by unique.f.nos to determine the true leading coeffts in % the multivariate factorization we are doing and which image % factors will grow up to have which true leading coefft. %********************************************************************; SYMBOLIC PROCEDURE DISTRIBUTE!.LC(R,IM!.FACTORS,S,V); % v is the factored lc of a poly, say u, whose image factors (r of % them) are in the vector im.factors. s is a list containing the % image information including the image set, the image poly etc. % this uses wang's ideas for distributing the factors in v over % those in im.factors. result is (delta . vector of the lc's of % the full factors of u) , where delta is the remaining integer part % of the lc that we have been unable to distribute. ; (LAMBDA FACTOR!-LEVEL; BEGIN SCALAR K,DELTA,DIV!.COUNT,Q,UF,I,D,MAX!.MULT,F,NUMVEC, DVEC,WVEC,DTWID,W; DELTA:=GET!-IMAGE!-CONTENT S; % the content of the u image poly; DIST!.LC!.MSG1(DELTA,IM!.FACTORS,R,S,V); V:=CDR V; % we are not interested in the numeric factors of v; K:=LENGTH V; % number of things to distribute; NUMVEC:=GET!-F!-NUMVEC S; % nos. associated with factors in v; DVEC:=MKVECT R; WVEC:=MKVECT R; FOR J:=1:R DO << PUTV(DVEC,J,1); PUTV(WVEC,J,DELTA*LC GETV(IM!.FACTORS,J)) >>; % result lc's will go into dvec which we initialize to 1's; % wvec is a work vector that we use in the division process % below; V:=REVERSE V; FOR J:=K STEP -1 UNTIL 1 DO << % (for each factor in v, call it f(j) ); F:=CAAR V; % f(j) itself; MAX!.MULT:=CDAR V; % multiplicity of f(j) in v (=lc u); V:=CDR V; D:=GETV(NUMVEC,J); % number associated with f(j); I:=1; % we trial divide d into lc of each image % factor starting with 1st; DIV!.COUNT:=0; % no. of d's that have been distributed; FACTOR!-TRACE << PRIN2!* "f("; PRIN2!* J; PRIN2!* ")= "; FAC!-PRINTSF F; PRIN2!* "There are "; PRIN2!* MAX!.MULT; PRINTSTR " of these in the leading coefficient."; PRIN2!* "The absolute value of the image of f("; PRIN2!* J; PRIN2!* ")= "; PRINTSTR D >>; WHILE ILESSP(DIV!.COUNT,MAX!.MULT) AND NOT IGREATERP(I,R) DO << Q:=DIVIDE(GETV(WVEC,I),D); % first trial division; FACTOR!-TRACE << PRIN2!* " Trial divide into "; PRIN2!* GETV(WVEC,I); PRINTSTR " :" >>; WHILE (ZEROP CDR Q) AND ILESSP(DIV!.COUNT,MAX!.MULT) DO << PUTV(DVEC,I,MULTF(GETV(DVEC,I),F)); % f(j) belongs in lc of ith factor; FACTOR!-TRACE << PRIN2!* " It goes so an f("; PRIN2!* J; PRIN2!* ") belongs in "; FAC!-PRINTSF GETV(IM!.FACTORS,I); PRINTSTR " Try again..." >>; DIV!.COUNT:=IADD1 DIV!.COUNT; % another d done; PUTV(WVEC,I,CAR Q); % save the quotient for next factor to distribute; Q:=DIVIDE(CAR Q,D); % try again; >>; I:=IADD1 I; % as many d's as possible have gone into that % factor so now try next factor; FACTOR!-TRACE << PRINTSTR " no good so try another factor ..." >> >>; % at this point the whole of f(j) should have been % distributed by dividing d the maximum no. of times % (= max!.mult), otherwise we have an extraneous factor; IF ILESSP(DIV!.COUNT,MAX!.MULT) THEN RETURN BAD!-CASE:=T >>; IF BAD!-CASE THEN RETURN; FACTOR!-TRACE << PRINTSTR "The leading coefficients are now correct to within an"; PRINTSTR "integer factor and are as follows:"; FOR J:=1:R DO << PRINSF GETV(IM!.FACTORS,J); PRIN2!* " with l.c. "; FAC!-PRINTSF GETV(DVEC,J) >> >>; IF ONEP DELTA THEN << FOR J:=1:R DO << W:=LC GETV(IM!.FACTORS,J) / EVALUATE!-IN!-ORDER(GETV(DVEC,J),GET!-IMAGE!-SET S); IF W<0 THEN BEGIN SCALAR OLDPOLY; DELTA:= -DELTA; OLDPOLY:=GETV(IM!.FACTORS,J); PUTV(IM!.FACTORS,J,NEGF OLDPOLY); % to keep the leading coefficients positive we negate the % image factors when necessary; MULTIPLY!-ALPHAS(-1,OLDPOLY,GETV(IM!.FACTORS,J)); % remember to fix the alphas as well; END; PUTV(DVEC,J,MULTF(ABS W,GETV(DVEC,J))) >>; DIST!.LC!.MSG2(DVEC,IM!.FACTORS,R); RETURN (DELTA . DVEC) >>; % if delta=1 then we know the true lc's exactly so put in their % integer contents and return with result. % otherwise try spreading delta out over the factors: ; FACTOR!-TRACE << PRIN2!* " Here delta is not 1 meaning that we have a content, "; PRINTSTR DELTA; PRINTSTR "of the image to distribute among the factors somehow."; PRINTSTR "For each IM-factor we can divide its leading"; PRINTSTR "coefficient by the image of its determined leading"; PRINTSTR "coefficient and see if there is a non-trivial result."; PRINTSTR "This will indicate a factor of delta belonging to this"; PRINTSTR "IM-factor's leading coefficient." >>; FOR J:=1:R DO << DTWID:=EVALUATE!-IN!-ORDER(GETV(DVEC,J),GET!-IMAGE!-SET S); UF:=GETV(IM!.FACTORS,J); D:=GCD(LC UF,DTWID); PUTV(DVEC,J,MULTF(LC UF/D,GETV(DVEC,J))); PUTV(IM!.FACTORS,J,MULTF(DTWID/D,UF)); % have to fiddle the image factors by an integer multiple; MULTIPLY!-ALPHAS!-RECIP(DTWID/D,UF,GETV(IM!.FACTORS,J)); % fix the alphas; DELTA:=DELTA/(DTWID/D) >>; % now we've done all we can to distribute delta so we return with % what's left: ; IF DELTA<=0 THEN ERRORF LIST("FINAL DELTA IS -VE IN DISTRIBUTE!.LC",DELTA); FACTOR!-TRACE << PRINTSTR " Finally we have:"; FOR J:=1:R DO << PRINSF GETV(IM!.FACTORS,J); PRIN2!* " with l.c. "; FAC!-PRINTSF GETV(DVEC,J) >> >>; RETURN (DELTA . DVEC) END) (FACTOR!-LEVEL * 10); SYMBOLIC PROCEDURE DIST!.LC!.MSG1(DELTA,IM!.FACTORS,R,S,V); FACTOR!-TRACE << TERPRI(); TERPRI(); PRINTSTR "We have a polynomial whose image factors (call"; PRINTSTR "them the IM-factors) are:"; PRIN2!* DELTA; PRINTSTR " (= numeric content, delta)"; PRINTVEC(" f(",R,")= ",IM!.FACTORS); PRIN2!* " wrt the image set: "; FOR EACH X IN GET!-IMAGE!-SET S DO << PRINVAR CAR X; PRIN2!* "="; PRIN2!* CDR X; PRIN2!* ";" >>; TERPRI!*(NIL); PRINTSTR "We also have its true multivariate leading"; PRINTSTR "coefficient whose factors (call these the"; PRINTSTR "LC-factors) are:"; FAC!-PRINTFACTORS V; PRINTSTR "We want to determine how these LC-factors are"; PRINTSTR "distributed over the leading coefficients of each"; PRINTSTR "IM-factor. This enables us to feed the resulting"; PRINTSTR "image factors into a multivariate Hensel"; PRINTSTR "construction."; PRINTSTR "We distribute each LC-factor in turn by dividing"; PRINTSTR "its image into delta times the leading coefficient"; PRINTSTR "of each IM-factor until it finds one that it"; PRINTSTR "divides exactly. The image set is chosen such that"; PRINTSTR "this will only happen for the IM-factors to which"; PRINTSTR "this LC-factor belongs - (there may be more than"; PRINTSTR "one if the LC-factor occurs several times in the"; PRINTSTR "leading coefficient of the original polynomial)."; PRINTSTR "This choice also requires that we distribute the"; PRINTSTR "LC-factors in a specific order:" >>; SYMBOLIC PROCEDURE DIST!.LC!.MSG2(DVEC,IM!.FACTORS,R); FACTOR!-TRACE << PRINTSTR "Since delta=1, we have no non-trivial content of the"; PRINTSTR "image to deal with so we know the true leading coefficients"; PRINTSTR "exactly. We fix the signs of the IM-factors to match those"; PRINTSTR "of their true leading coefficients:"; FOR J:=1:R DO << PRINSF GETV(IM!.FACTORS,J); PRIN2!* " with l.c. "; FAC!-PRINTSF GETV(DVEC,J) >> >>; ENDMODULE; MODULE INTERFAC; %**********************************************************************; % % copyright (c) university of cambridge, england 1981 % %**********************************************************************; %**********************************************************************; % Routines that are specific to REDUCE. % These are either routines that are not needed in the HASH system % (which is the other algebra system that this factorizer % can be plugged into) or routines that are specifically % redefined in the HASH system. ; %---------------------------------------------------------------------; % The following would normally live in section: ALPHAS %---------------------------------------------------------------------; SYMBOLIC PROCEDURE ASSOC!-ALPHA(POLY,ALIST); ASSOC(POLY,ALIST); %---------------------------------------------------------------------; % The following would normally live in section: COEFFTS %---------------------------------------------------------------------; SYMBOLIC PROCEDURE TERMVECTOR2SF V; BEGIN SCALAR R,W; FOR I:=CAR GETV(V,0) STEP -1 UNTIL 1 DO << W:=GETV(V,I); % degree . coefft; R:=IF CAR W=0 THEN CDR W ELSE (MKSP(M!-IMAGE!-VARIABLE,CAR W) .* CDR W) .+ R >>; RETURN R END; SYMBOLIC PROCEDURE FORCE!-LC(A,N); % force polynomial a to have leading coefficient as specified; (LPOW A .* N) .+ RED A; SYMBOLIC PROCEDURE MERGE!-TERMS(U,V); MERGE!-TERMS1(1,U,V,CAR GETV(V,0)); SYMBOLIC PROCEDURE MERGE!-TERMS1(I,U,V,N); IF I#>N THEN U ELSE BEGIN SCALAR A,B; A:=GETV(V,I); IF DOMAINP U OR NOT(MVAR U=M!-IMAGE!-VARIABLE) THEN IF NOT(CAR A=0) THEN ERRORF LIST("MERGING COEFFTS FAILED",U,A) ELSE IF CDR A THEN RETURN CDR A ELSE RETURN U; B:=LT U; IF TDEG B=CAR A THEN RETURN (IF CDR A THEN TPOW B .* CDR A ELSE B) .+ MERGE!-TERMS1(I #+ 1,RED U,V,N) ELSE IF TDEG B #> CAR A THEN RETURN B .+ MERGE!-TERMS1(I,RED U,V,N) ELSE ERRORF LIST("MERGING COEFFTS FAILED ",U,A) END; SYMBOLIC PROCEDURE LIST!-TERMS!-IN!-FACTOR U; % ...; IF DOMAINP U THEN LIST (0 . NIL) ELSE (LDEG U . NIL) . LIST!-TERMS!-IN!-FACTOR RED U; SYMBOLIC PROCEDURE TRY!-OTHER!-COEFFTS(R,UNKNOWNS!-LIST,UV); BEGIN SCALAR LDEG!-R,LC!-R,W; WHILE NOT DOMAINP R AND (R:=RED R) AND NOT(W='COMPLETE) DO << IF NOT DEPENDS!-ON!-VAR(R,M!-IMAGE!-VARIABLE) THEN << LDEG!-R:=0; LC!-R:=R >> ELSE << LDEG!-R:=LDEG R; LC!-R:=LC R >>; W:=SOLVE!-NEXT!-COEFFT(LDEG!-R,LC!-R,UNKNOWNS!-LIST,UV) >> END; %---------------------------------------------------------------------; % The following would normally live in section: FACMISC %---------------------------------------------------------------------; SYMBOLIC PROCEDURE DERIVATIVE!-WRT!-MAIN!-VARIABLE(P,VAR); % partial derivative of the polynomial p with respect to % its main variable, var; IF DOMAINP P OR (MVAR P NEQ VAR) THEN NIL ELSE BEGIN SCALAR DEGREE; DEGREE:=LDEG P; IF DEGREE=1 THEN RETURN LC P; %degree one term is special; RETURN (MKSP(MVAR P,DEGREE-1) .* MULTF(DEGREE,LC P)) .+ DERIVATIVE!-WRT!-MAIN!-VARIABLE(RED P,VAR) END; SYMBOLIC PROCEDURE UNIVARIATEP U; % tests to see if u is univariate; DOMAINP U OR NOT MULTIVARIATEP(U,MVAR U); SYMBOLIC PROCEDURE VARIABLES!.IN!.FORM(A,SOFAR); IF DOMAINP A THEN SOFAR ELSE << IF NOT MEMQ(MVAR A,SOFAR) THEN SOFAR:=MVAR A . SOFAR; VARIABLES!.IN!.FORM(RED A, VARIABLES!.IN!.FORM(LC A,SOFAR)) >>; SYMBOLIC PROCEDURE DEGREE!-IN!-VARIABLE(P,V); % returns the degree of the polynomial p in the % variable v; IF DOMAINP P THEN 0 ELSE IF LC P=0 THEN ERRORF "Polynomial with a zero coefficient found" ELSE IF V=MVAR P THEN LDEG P ELSE MAX(DEGREE!-IN!-VARIABLE(LC P,V), DEGREE!-IN!-VARIABLE(RED P,V)); SYMBOLIC PROCEDURE GET!-HEIGHT POLY; % find height (max coefft) of given poly; IF NULL POLY THEN 0 ELSE IF NUMBERP POLY THEN ABS POLY ELSE MAX(GET!-HEIGHT LC POLY,GET!-HEIGHT RED POLY); SYMBOLIC PROCEDURE POLY!-MINUSP A; IF A=NIL THEN NIL ELSE IF DOMAINP A THEN MINUSP A ELSE POLY!-MINUSP LC A; SYMBOLIC PROCEDURE POLY!-ABS A; IF POLY!-MINUSP A THEN NEGF A ELSE A; SYMBOLIC PROCEDURE FAC!-PRINTFACTORS L; % procedure to print the result of factorize!-form; % ie. l is of the form: (c . f) % where c is the numeric content (may be 1) % and f is of the form: ( (f1 . e1) (f2 . e2) ... (fn . en) ) % where the fi's are s.f.s and ei's are numbers; << TERPRI(); IF NOT (CAR L = 1) THEN FAC!-PRINTSF CAR L; FOR EACH ITEM IN CDR L DO FAC!-PRINTSF !*P2F MKSP(PREPF CAR ITEM,CDR ITEM) >>; %---------------------------------------------------------------------; % The following would normally live in section: FACPRIM %---------------------------------------------------------------------; SYMBOLIC PROCEDURE INVERT!.POLY(U,VAR); % u is a non-trivial primitive square free multivariate polynomial. % assuming var is the top-level variable in u, this effectively % reverses the position of the coeffts: ie % a(n)*var**n + a(n-1)*var**(n-1) + ... + a(0) % becomes: % a(0)*var**n + a(1)*var**(n-1) + ... + a(n) . ; BEGIN SCALAR W,INVERT!-SIGN; W:=INVERT!.POLY1(RED U,LDEG U,LC U,VAR); IF POLY!-MINUSP LC W THEN << W:=NEGF W; INVERT!-SIGN:=-1 >> ELSE INVERT!-SIGN:=1; RETURN INVERT!-SIGN . W END; SYMBOLIC PROCEDURE INVERT!.POLY1(U,D,V,VAR); % d is the degree of the poly we wish to invert. % assume d > ldeg u always, and that v is never nil; IF (DOMAINP U) OR NOT (MVAR U=VAR) THEN (VAR TO D) .* U .+ V ELSE INVERT!.POLY1(RED U,D,(VAR TO (D-LDEG U)) .* (LC U) .+ V,VAR); SYMBOLIC PROCEDURE TRAILING!.COEFFT(U,VAR); % u is multivariate poly with var as the top-level variable. we find % the trailing coefft - ie the constant wrt var in u; IF DOMAINP U THEN U ELSE IF MVAR U=VAR THEN TRAILING!.COEFFT(RED U,VAR) ELSE U; %---------------------------------------------------------------------; % The following would normally live in section: FACTOR %---------------------------------------------------------------------; SYMBOLIC PROCEDURE SIMPFACTORIZE U; % factorize the polynomial p, putting the factors into % the array w, and return the number of factors found. % w(0) gets set to the (numeric) content of p (which % may well be just +1). w should be a one-dimensional array. if it % the name of a variable, not an array, the variables w0, w1,... % will be set instead; BEGIN SCALAR P,W,!*FORCE!-PRIME,X,Y,Z,FACTOR!-COUNT; IF ATOM U THEN REDERR "FACTORIZE needs arguments" ELSE IF ATOM CDR U THEN U := LIST(CAR U,'FACTOR); P:= !*Q2F SIMP!* CAR U; W := CADR U; IF NOT ATOM CDDR U AND NUMBERP CADDR U THEN !*FORCE!-PRIME := CADDR U; X:=FACTORF1(P,!*FORCE!-PRIME); Z:= (0 . CAR X) . NIL; FACTOR!-COUNT:=0; FOR EACH FFF IN CDR X DO FOR I:=1:CDR FFF DO Z:=((FACTOR!-COUNT:=FACTOR!-COUNT+1) . MK!*SQ(CAR FFF ./ 1)) . Z; RETURN MULTIPLE!-RESULT(Z,W) END; PUT('FACTORIZE,'SIMPFN,'SIMPFACTORIZE); %---------------------------------------------------------------------; % The following would normally live in section: IMAGESET %---------------------------------------------------------------------; SYMBOLIC PROCEDURE MAKE!-IMAGE!-LC!-LIST(U,IMSET); REVERSEWOC MAKE!-IMAGE!-LC!-LIST1(U,IMSET, FOR EACH X IN IMSET COLLECT CAR X); SYMBOLIC PROCEDURE MAKE!-IMAGE!-LC!-LIST1(U,IMSET,VARLIST); % If IMSET=((x1 . a1, x2 . a2, ... , xn . an)) (ordered) where xj is % the variable and aj its value, then this fn creates n images of U wrt % sets S(i) where S(i)= ((x1 . a1), ... , (xi . ai)). The result is an % ordered list of pairs: (u(i) . X(i+1)) where u(i)= U wrt S(i) and % X(i) = (xi, ... , xn) and X(n+1) = NIL. VARLIST = X(1). % (Note. the variables tagged to u(i) should be all those % appearing in u(i) unless it is degenerate). The returned list is % ordered with u(1) first and ending with the number u(n); IF NULL IMSET THEN NIL ELSE IF DOMAINP U THEN LIST(!*D2N U . CDR VARLIST) ELSE IF MVAR U=CAAR IMSET THEN BEGIN SCALAR W; W:=HORNER!-RULE!-FOR!-ONE!-VAR( U,CAAR IMSET,CDAR IMSET,POLYZERO,LDEG U) . CDR VARLIST; RETURN IF POLYZEROP CAR W THEN LIST (0 . CDR W) ELSE (W . MAKE!-IMAGE!-LC!-LIST1(CAR W,CDR IMSET,CDR VARLIST)) END ELSE MAKE!-IMAGE!-LC!-LIST1(U,CDR IMSET,CDR VARLIST); SYMBOLIC PROCEDURE HORNER!-RULE!-FOR!-ONE!-VAR(U,X,VAL,C,DEGG); IF DOMAINP U OR NOT(MVAR U=X) THEN ADDF(U,MULTF(C,!*NUM2F(VAL**DEGG))) ELSE BEGIN SCALAR NEWDEG; NEWDEG:=LDEG U; RETURN HORNER!-RULE!-FOR!-ONE!-VAR(RED U,X,VAL, ADDF(LC U,MULTF(C,!*NUM2F(VAL**(IDIFFERENCE(DEGG,NEWDEG))))), NEWDEG) END; SYMBOLIC PROCEDURE MAKE!-IMAGE(U,IMSET); % finds image of u wrt image set, imset, (=association list); IF DOMAINP U THEN U ELSE IF MVAR U=M!-IMAGE!-VARIABLE THEN ADJOIN!-TERM(LPOW U,!*NUM2F EVALUATE!-IN!-ORDER(LC U,IMSET), MAKE!-IMAGE(RED U,IMSET)) ELSE !*NUM2F EVALUATE!-IN!-ORDER(U,IMSET); SYMBOLIC PROCEDURE EVALUATE!-IN!-ORDER(U,IMSET); % makes an image of u wrt imageset, imset, using horner's rule. result % should be purely numeric; IF DOMAINP U THEN !*D2N U ELSE IF MVAR U=CAAR IMSET THEN HORNER!-RULE(EVALUATE!-IN!-ORDER(LC U,CDR IMSET), LDEG U,RED U,IMSET) ELSE EVALUATE!-IN!-ORDER(U,CDR IMSET); SYMBOLIC PROCEDURE HORNER!-RULE(C,DEGG,A,VSET); % c is running total and a is what is left; IF DOMAINP A THEN (!*D2N A)+C*((CDAR VSET)**DEGG) ELSE IF NOT(MVAR A=CAAR VSET) THEN EVALUATE!-IN!-ORDER(A,CDR VSET)+C*((CDAR VSET)**DEGG) ELSE BEGIN SCALAR NEWDEG; NEWDEG:=LDEG A; RETURN HORNER!-RULE(EVALUATE!-IN!-ORDER(LC A,CDR VSET) +C*((CDAR VSET)**(IDIFFERENCE(DEGG,NEWDEG))),NEWDEG,RED A,VSET) END; %---------------------------------------------------------------------; % The following would normally live in section: MHENSFNS %---------------------------------------------------------------------; SYMBOLIC PROCEDURE MAX!-DEGREE(U,N); % finds maximum degree of any single variable in U (n is max so far); IF DOMAINP U THEN N ELSE IF IGREATERP(N,LDEG U) THEN MAX!-DEGREE(RED U,MAX!-DEGREE(LC U,N)) ELSE MAX!-DEGREE(RED U,MAX!-DEGREE(LC U,LDEG U)); SYMBOLIC PROCEDURE DIFF!-OVER!-K!-MOD!-P(U,K,V); % derivative of u wrt v divided by k (=number); IF DOMAINP U THEN NIL ELSE IF MVAR U = V THEN IF LDEG U = 1 THEN QUOTIENT!-MOD!-P(LC U,MODULAR!-NUMBER K) ELSE ADJOIN!-TERM(MKSP(V,ISUB1 LDEG U), QUOTIENT!-MOD!-P( TIMES!-MOD!-P(MODULAR!-NUMBER LDEG U,LC U), MODULAR!-NUMBER K), DIFF!-OVER!-K!-MOD!-P(RED U,K,V)) ELSE ADJOIN!-TERM(LPOW U, DIFF!-OVER!-K!-MOD!-P(LC U,K,V), DIFF!-OVER!-K!-MOD!-P(RED U,K,V)); SYMBOLIC PROCEDURE DIFF!-K!-TIMES!-MOD!-P(U,K,V); % differentiates u k times wrt v and divides by (k!) ie. for each term % a*v**n we get [n k]*a*v**(n-k) if n>=k and nil if n<k where % [n k] is the binomial coefficient; IF DOMAINP U THEN NIL ELSE IF MVAR U = V THEN IF LDEG U < K THEN NIL ELSE IF LDEG U = K THEN LC U ELSE ADJOIN!-TERM(MKSP(V,LDEG U - K), TIMES!-MOD!-P(BINOMIAL!-COEFFT!-MOD!-P(LDEG U,K),LC U), DIFF!-K!-TIMES!-MOD!-P(RED U,K,V)) ELSE ADJOIN!-TERM(LPOW U, DIFF!-K!-TIMES!-MOD!-P(LC U,K,V), DIFF!-K!-TIMES!-MOD!-P(RED U,K,V)); SYMBOLIC PROCEDURE SPREADVAR(U,V,SLIST); % find all the powers of V in U and merge their degrees into SLIST. % We ignore the constant term wrt V; IF DOMAINP U THEN SLIST ELSE << IF MVAR U=V AND NOT MEMBER(LDEG U,SLIST) THEN SLIST:=LDEG U . SLIST; SPREADVAR(RED U,V,SPREADVAR(LC U,V,SLIST)) >>; %---------------------------------------------------------------------; % The following would normally live in section: UNIHENS %---------------------------------------------------------------------; SYMBOLIC PROCEDURE ROOT!-SQUARES(U,SOFAR); IF NULL U THEN PMAM!-SQRT SOFAR ELSE IF DOMAINP U THEN PMAM!-SQRT(SOFAR+(U*U)) ELSE ROOT!-SQUARES(RED U,SOFAR+(LC U * LC U)); %---------------------------------------------------------------------; % The following would normally live in section: VECPOLY %---------------------------------------------------------------------; SYMBOLIC PROCEDURE POLY!-TO!-VECTOR P; % spread the given univariate polynomial out into POLY-VECTOR; IF ISDOMAIN P THEN PUTV(POLY!-VECTOR,0,!*D2N P) ELSE << PUTV(POLY!-VECTOR,LDEG P,LC P); POLY!-TO!-VECTOR RED P >>; SYMBOLIC PROCEDURE VECTOR!-TO!-POLY(P,D,V); % Convert the vector P into a polynomial of degree D in variable V; BEGIN SCALAR R; IF D#<0 THEN RETURN NIL; R:=!*N2F GETV(P,0); FOR I:=1:D DO IF GETV(P,I) NEQ 0 THEN R:=((V TO I) .* GETV(P,I)) .+ R; RETURN R END; ENDMODULE; MODULE LINMODP; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % % This section solves linear equations mod p; SYMBOLIC PROCEDURE LU!-FACTORIZE!-MOD!-P(A,N); % A is a matrix of size N*N. Overwrite it with its LU factorization; BEGIN SCALAR W; FOR I:=1:N DO BEGIN SCALAR II,PIVOT; II:=I; WHILE (PIVOT:=GETM2(A,II,I))=0 OR IREMAINDER(PIVOT,PRIME!-BASE)=0 DO << II:=II+1; IF II>N THEN RETURN W:='SINGULAR >>; IF W='SINGULAR THEN RETURN W; IF NOT II=I THEN BEGIN SCALAR TEMP; TEMP:=GETV(A,I); PUTV(A,I,GETV(A,II)); PUTV(A,II,TEMP) END; PUTM2(A,I,0,II); % Remember pivoting information; PIVOT:=MODULAR!-RECIPROCAL PIVOT; PUTM2(A,I,I,PIVOT); FOR J:=I+1:N DO PUTM2(A,I,J,MODULAR!-TIMES(PIVOT,GETM2(A,I,J))); FOR II:=I+1:N DO BEGIN SCALAR MULTIPLE; MULTIPLE:=GETM2(A,II,I); FOR J:=I+1:N DO PUTM2(A,II,J,MODULAR!-DIFFERENCE(GETM2(A,II,J), MODULAR!-TIMES(MULTIPLE,GETM2(A,I,J)))) END END; RETURN W END; SYMBOLIC PROCEDURE BACK!-SUBSTITUTE(A,V,N); % A is an N*N matrix as produced by LU-FACTORIZE-MOD-P, and V is % a vector of length N. Overwrite V with solution to linear equations; BEGIN FOR I:=1:N DO BEGIN SCALAR II; II:=GETM2(A,I,0); % Pivot control; IF NOT II=I THEN DO BEGIN SCALAR TEMP; TEMP:=GETV(V,I); PUTV(V,I,GETV(V,II)); PUTV(V,II,TEMP) END END; FOR I:=1:N DO BEGIN PUTV(V,I,TIMES!-MOD!-P(!*N2F GETM2(A,I,I),GETV(V,I))); FOR II:=I+1:N DO PUTV(V,II,DIFFERENCE!-MOD!-P(GETV(V,II), TIMES!-MOD!-P(GETV(V,I),!*N2F GETM2(A,II,I)))) END; % Now do the actual back substitution; FOR I:=N-1 STEP -1 UNTIL 1 DO FOR J:=I+1:N DO PUTV(V,I,DIFFERENCE!-MOD!-P(GETV(V,I), TIMES!-MOD!-P(!*N2F GETM2(A,I,J),GETV(V,J)))); RETURN V END; ENDMODULE; MODULE MHENSFNS; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % This section contains some of the functions used in % the multivariate hensel growth. (ie they are called from % section MULTIHEN or function RECONSTRUCT-MULTIVARIATE-FACTORS). ; SYMBOLIC PROCEDURE SET!-DEGREE!-BOUNDS V; DEGREE!-BOUNDS:=FOR EACH VAR IN V COLLECT (CAR VAR . DEGREE!-IN!-VARIABLE(MULTIVARIATE!-INPUT!-POLY,CAR VAR)); SYMBOLIC PROCEDURE GET!-DEGREE!-BOUND V; BEGIN SCALAR W; W:=ATSOC(V,DEGREE!-BOUNDS); IF NULL W THEN ERRORF(LIST("Degree bound not found for ", V," in ",DEGREE!-BOUNDS)); RETURN CDR W END; SYMBOLIC PROCEDURE CHOOSE!-LARGER!-PRIME N; % our prime base in the multivariate hensel must be greater than n so % this sets a new prime to be that (previous one was found to be no % good). We also set up various fluids e.g. the Alphas; % the primes we can choose are < 2**24 so if n is bigger % we collapse; IF N > 2**24-1 THEN ERRORF LIST("CANNOT CHOOSE PRIME > GIVEN NUMBER:",N) ELSE BEGIN SCALAR P,FLIST!-MOD!-P,K,FVEC!-MOD!-P,FORBIDDEN!-PRIMES; TRYNEWPRIME: IF P THEN FORBIDDEN!-PRIMES:=P . FORBIDDEN!-PRIMES; P:=RANDOM!-PRIME(); % this chooses a word-size prime (currently 24 bits); SET!-MODULUS P; IF NOT(P>N) OR MEMBER(P,FORBIDDEN!-PRIMES) OR POLYZEROP REDUCE!-MOD!-P LC MULTIVARIATE!-INPUT!-POLY THEN GOTO TRYNEWPRIME; FOR I:=1:NUMBER!-OF!-FACTORS DO FLIST!-MOD!-P:=(REDUCE!-MOD!-P GETV(IMAGE!-FACTORS,I) . FLIST!-MOD!-P); ALPHALIST:=ALPHAS(NUMBER!-OF!-FACTORS,FLIST!-MOD!-P,1); IF ALPHALIST='FACTORS! NOT! COPRIME THEN GOTO TRYNEWPRIME; HENSEL!-GROWTH!-SIZE:=P; PRIME!-BASE:=P; FACTOR!-TRACE << PRIN2!* "New prime chosen: "; PRINTSTR HENSEL!-GROWTH!-SIZE >>; K:=NUMBER!-OF!-FACTORS; FVEC!-MOD!-P:=MKVECT K; FOR EACH W IN FLIST!-MOD!-P DO << PUTV(FVEC!-MOD!-P,K,W); K:=ISUB1 K >>; RETURN FVEC!-MOD!-P END; SYMBOLIC PROCEDURE BINOMIAL!-COEFFT!-MOD!-P(N,R); IF N<R THEN NIL ELSE IF N=R THEN 1 ELSE IF R=1 THEN !*NUM2F MODULAR!-NUMBER N ELSE BEGIN SCALAR N!-C!-R,B,J; N!-C!-R:=1; B:=MIN(R,N-R); N:=MODULAR!-NUMBER N; R:=MODULAR!-NUMBER R; FOR I:=1:B DO << J:=MODULAR!-NUMBER I; N!-C!-R:=MODULAR!-QUOTIENT( MODULAR!-TIMES(N!-C!-R, MODULAR!-DIFFERENCE(N,MODULAR!-DIFFERENCE(J,1))), J) >>; RETURN !*NUM2F N!-C!-R END; SYMBOLIC PROCEDURE MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(BVEC,N); % makes a vector whose ith elt is product over j [ BVEC(j) ] / BVEC(i); % NB. we must NOT actually do the division here as we are likely % to be working mod p**n (some n > 1) and the division can involve % a division by p.; BEGIN SCALAR BHATVEC,R; BHATVEC:=MKVECT N; FOR I:=1:N DO << R:=1; FOR J:=1:N DO IF NOT(J=I) THEN R:=TIMES!-MOD!-P(R,GETV(BVEC,J)); PUTV(BHATVEC,I,R) >>; RETURN BHATVEC END; SYMBOLIC PROCEDURE MAX!-DEGREE!-IN!-VAR(FVEC,V); BEGIN SCALAR R,D; R:=0; FOR I:=1:NUMBER!-OF!-FACTORS DO IF R<(D:=DEGREE!-IN!-VARIABLE(GETV(FVEC,I),V)) THEN R:=D; RETURN R END; SYMBOLIC PROCEDURE MAKE!-GROWTH!-FACTOR PT; % pt is of form (v . n) where v is a variable. we make the s.f. v-n; IF CDR PT=0 THEN !*F2MOD !*K2F CAR PT ELSE PLUS!-MOD!-P(!*F2MOD !*K2F CAR PT,MODULAR!-MINUS CDR PT); SYMBOLIC PROCEDURE TERMS!-DONE!-MOD!-P(FVEC,DELFVEC,DELFACTOR); % calculate the terms introduced by the corrections in DELFVEC; BEGIN SCALAR FLIST,DELFLIST; FOR I:=1:NUMBER!-OF!-FACTORS DO << FLIST:=GETV(FVEC,I) . FLIST; DELFLIST:=GETV(DELFVEC,I) . DELFLIST >>; RETURN TERMS!-DONE1!-MOD!-P(NUMBER!-OF!-FACTORS,FLIST,DELFLIST, NUMBER!-OF!-FACTORS,DELFACTOR) END; SYMBOLIC PROCEDURE TERMS!-DONE1!-MOD!-P(N,FLIST,DELFLIST,R,M); IF N=1 THEN (CAR FLIST) . (CAR DELFLIST) ELSE BEGIN SCALAR K,I,F1,F2,DELF1,DELF2; K:=N/2; I:=1; FOR EACH F IN FLIST DO << IF I>K THEN F2:=(F . F2) ELSE F1:=(F . F1); I:=I+1 >>; I:=1; FOR EACH DELF IN DELFLIST DO << IF I>K THEN DELF2:=(DELF . DELF2) ELSE DELF1:=(DELF . DELF1); I:=I+1 >>; F1:=TERMS!-DONE1!-MOD!-P(K,F1,DELF1,R,M); DELF1:=CDR F1; F1:=CAR F1; F2:=TERMS!-DONE1!-MOD!-P(N-K,F2,DELF2,R,M); DELF2:=CDR F2; F2:=CAR F2; DELF1:= PLUS!-MOD!-P(PLUS!-MOD!-P( TIMES!-MOD!-P(F1,DELF2), TIMES!-MOD!-P(F2,DELF1)), TIMES!-MOD!-P(TIMES!-MOD!-P(DELF1,M),DELF2)); IF N=R THEN RETURN DELF1; RETURN (TIMES!-MOD!-P(F1,F2) . DELF1) END; SYMBOLIC PROCEDURE PRIMITIVE!.PARTS(FLIST,VAR,UNIVARIATE!-INPUTS); % finds the prim.part of each factor in flist wrt variable var; % Note that FLIST may contain univariate or multivariate S.F.s % (according to UNIVARIATE!-INPUTS) - in the former case we correct the % ALPHALIST if necessary; BEGIN SCALAR C,PRIMF; IF NULL VAR THEN ERRORF "Must take primitive parts wrt some non-null variable"; IF NON!-MONIC THEN FACTOR!-TRACE << PRINTSTR "Because we multiplied the original primitive"; PRINTSTR "polynomial by a multiple of its leading coefficient"; PRINTSTR "(see (a) above), the factors we have now are not"; PRINTSTR "necessarily primitive. However the required factors"; PRINTSTR "are merely their primitive parts." >>; RETURN FOR EACH FW IN FLIST COLLECT << IF NOT DEPENDS!-ON!-VAR(FW,VAR) THEN ERRORF LIST("WRONG VARIABLE",VAR,FW); C:=COMFAC FW; IF CAR C THEN ERRORF(LIST( "FACTOR DIVISIBLE BY MAIN VARIABLE:",FW,CAR C)); PRIMF:=QUOTFAIL(FW,CDR C); IF NOT(CDR C=1) AND UNIVARIATE!-INPUTS THEN MULTIPLY!-ALPHAS(CDR C,FW,PRIMF); PRIMF >> END; SYMBOLIC PROCEDURE MAKE!-PREDICTED!-FORMS(PFS,V); % PFS is a vector of S.F.s which represents the sparsity of % the associated polynomials wrt V. Here PFS is adjusted to a % suitable form for handling this sparsity. ie. we record the % degrees of V in a vector for each poly in PFS. Each % monomial (in V) represents an unknown (its coefft) in the predicted % form of the associated poly. We count the maximum no of unknowns for % each poly and return the maximum of these; BEGIN SCALAR L,N,PVEC,J,W; MAX!-UNKNOWNS:=0; FOR I:=1:NUMBER!-OF!-FACTORS DO << W:=GETV(PFS,I); % get the ith poly; L:=SORT(SPREADVAR(W,V,NIL),FUNCTION LESSP); % Pick out the monomials in V from this poly and order % them in increasing degree; N:=IADD1 LENGTH L; % no of unknowns in predicted poly - we add % one for the constant term; NUMBER!-OF!-UNKNOWNS:=(N . I) . NUMBER!-OF!-UNKNOWNS; IF MAX!-UNKNOWNS<N THEN MAX!-UNKNOWNS:=N; PVEC:=MKVECT ISUB1 N; % get space for the info on this poly; J:=0; PUTV(PVEC,J,ISUB1 N); % put in the length of this vector which will vary % from poly to poly; FOR EACH M IN L DO PUTV(PVEC,J:=IADD1 J,M); % put in the monomial info; PUTV(PFS,I,PVEC); % overwrite the S.F. in PFS with the more compact vector; >>; NUMBER!-OF!-UNKNOWNS:=SORT(NUMBER!-OF!-UNKNOWNS,FUNCTION LESSPCAR); RETURN MAX!-UNKNOWNS END; SYMBOLIC PROCEDURE MAKE!-CORRECTION!-VECTORS(PFS,BFS,N); % set up space for the vector of vectors to hold the correction % terms as we generate them by the function SOLVE-FOR-CORRECTIONS. % Also put in the starting values; BEGIN SCALAR CVS,CV; CVS:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=1:NUMBER!-OF!-FACTORS DO << CV:=MKVECT N; % each CV will hold the corrections for the ith factor; % the no of corrections we put in here depends on the % maximum no of unknowns we have in the predicted % forms, giving a set of soluble linear systems (hopefully); PUTV(CV,1,GETV(BFS,I)); % put in the first 'corrections'; PUTV(CVS,I,CV) >>; RETURN CVS END; SYMBOLIC PROCEDURE CONSTRUCT!-SOLN!-MATRICES(PFS,VAL); % Here we construct the matrices - one for each linear system % we will have to solve to see if our predicted forms of the % answer are correct. Each matrix is a vector of row-vectors % - the ijth elt is in jth slot of ith row-vector (ie zero slots % are not used here); BEGIN SCALAR SOLN!-MATRIX,RESVEC,N,PV; RESVEC:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=1:NUMBER!-OF!-FACTORS DO << PV:=GETV(PFS,I); SOLN!-MATRIX:=MKVECT(N:=IADD1 GETV(PV,0)); CONSTRUCT!-ITH!-MATRIX(SOLN!-MATRIX,PV,N,VAL); PUTV(RESVEC,I,SOLN!-MATRIX) >>; RETURN RESVEC END; SYMBOLIC PROCEDURE CONSTRUCT!-ITH!-MATRIX(SM,PV,N,VAL); BEGIN SCALAR MV; MV:=MKVECT N; % this will be the first row; PUTV(MV,1,1); % the first column represents the constant term; FOR J:=2:N DO PUTV(MV,J,MODULAR!-EXPT(VAL,GETV(PV,ISUB1 J))); % first row is straight substitution; PUTV(SM,1,MV); % now for the rest of the rows: ; FOR J:=2:N DO << MV:=MKVECT N; PUTV(MV,1,0); CONSTRUCT!-MATRIX!-ROW(MV,ISUB1 J,PV,N,VAL); PUTV(SM,J,MV) >> END; SYMBOLIC PROCEDURE CONSTRUCT!-MATRIX!-ROW(MROW,J,PV,N,VAL); BEGIN SCALAR D; FOR K:=2:N DO << D:=GETV(PV,ISUB1 K); % degree representing the monomial; IF D<J THEN PUTV(MROW,K,0) ELSE << D:=MODULAR!-TIMES(!*D2N BINOMIAL!-COEFFT!-MOD!-P(D,J), MODULAR!-EXPT(VAL,IDIFFERENCE(D,J))); % differentiate and substitute all at once; PUTV(MROW,K,D) >> >> END; SYMBOLIC PROCEDURE PRINT!-LINEAR!-SYSTEMS(SOLN!-M,CORRECTION!-V, PREDICTED!-F,V); << FOR I:=1:NUMBER!-OF!-FACTORS DO PRINT!-LINEAR!-SYSTEM(I,SOLN!-M,CORRECTION!-V,PREDICTED!-F,V); TERPRI!*(NIL) >>; SYMBOLIC PROCEDURE PRINT!-LINEAR!-SYSTEM(I,SOLN!-M,CORRECTION!-V, PREDICTED!-F,V); BEGIN SCALAR PV,SM,CV,MR,N,TT; TERPRI!*(T); PRIN2!* " i = "; PRINTSTR I; TERPRI!*(NIL); SM:=GETV(SOLN!-M,I); CV:=GETV(CORRECTION!-V,I); PV:=GETV(PREDICTED!-F,I); N:=IADD1 GETV(PV,0); FOR J:=1:N DO << % for each row in matrix ... ; PRIN2!* "( "; TT:=2; MR:=GETV(SM,J); % matrix row; FOR K:=1:N DO << % for each elt in row ... ; PRIN2!* GETV(MR,K); TTAB!* (TT:=TT+10) >>; PRIN2!* ") ( ["; IF J=1 THEN PRIN2!* 1 ELSE PRINSF ADJOIN!-TERM(MKSP(V,GETV(PV,ISUB1 J)),1,POLYZERO); PRIN2!* "]"; TTAB!* (TT:=TT+10); PRIN2!* " )"; IF J=(N/2) THEN PRIN2!* " = ( " ELSE PRIN2!* " ( "; PRINSF GETV(CV,J); TTAB!* (TT:=TT+30); PRINTSTR ")"; IF NOT(J=N) THEN << TT:=2; PRIN2!* "("; TTAB!* (TT:=TT+N*10); PRIN2!* ") ("; TTAB!* (TT:=TT+10); PRIN2!* " ) ("; TTAB!* (TT:=TT+30); PRINTSTR ")" >> >>; TERPRI!*(T) END; SYMBOLIC PROCEDURE TRY!-PREDICTION(SM,CV,PV,N,I,POLY,V,FF,FFHAT, LU!-DECOMPN!-DONE); BEGIN SCALAR W,FFI,FHATI; SM:=GETV(SM,I); CV:=GETV(CV,I); PV:=GETV(PV,I); IF NOT(N=IADD1 GETV(PV,0)) THEN ERRORF LIST("Predicted unknowns gone wrong? ",N,IADD1 GETV(PV,0)); IF NOT LU!-DECOMPN!-DONE THEN << W:=LU!-FACTORIZE!-MOD!-P(SM,N); IF W='SINGULAR THEN << FACTOR!-TRACE << PRIN2!* "Prediction for "; PRIN2!* IF NULL FF THEN 'f ELSE 'a; PRIN2!* "("; PRIN2!* I; PRINTSTR ") failed due to singular matrix." >>; RETURN (W . I) >> >>; BACK!-SUBSTITUTE(SM,CV,N); W:= IF NULL FF THEN TRY!-FACTOR(POLY,CV,PV,N,V) ELSE << FFI := GETV(FF,I); FHATI := GETV(FFHAT,I); % The unfolding here is to get round % a bug in the PSL compiler 12/9/82. It % will be tidied back up as soon as % possible; TRY!-ALPHA(POLY,CV,PV,N,V,FFI,FHATI) >>; IF W='BAD!-PREDICTION THEN << FACTOR!-TRACE << PRIN2!* "Prediction for "; PRIN2!* IF NULL FF THEN 'f ELSE 'a; PRIN2!* "("; PRIN2!* I; PRINTSTR ") was an inadequate guess." >>; RETURN (W . I) >>; FACTOR!-TRACE << PRIN2!* "Prediction for "; PRIN2!* IF NULL FF THEN 'f ELSE 'a; PRIN2!* "("; PRIN2!* I; PRIN2!* ") worked: "; FAC!-PRINTSF CAR W >>; RETURN (I . W) END; SYMBOLIC PROCEDURE TRY!-FACTOR(POLY,TESTV,PREDICTEDF,N,V); BEGIN SCALAR R,W; R:=GETV(TESTV,1); FOR J:=2:N DO << W:=!*F2MOD ADJOIN!-TERM(MKSP(V,GETV(PREDICTEDF,ISUB1 J)),1, POLYZERO); R:=PLUS!-MOD!-P(R,TIMES!-MOD!-P(W,GETV(TESTV,J))) >>; W:=QUOTIENT!-MOD!-P(POLY,R); IF DIDNTGO W OR NOT POLYZEROP DIFFERENCE!-MOD!-P(POLY,TIMES!-MOD!-P(W,R)) THEN RETURN 'BAD!-PREDICTION ELSE RETURN LIST(R,W) END; SYMBOLIC PROCEDURE TRY!-ALPHA(POLY,TESTV,PREDICTEDF,N,V,FI,FHATI); BEGIN SCALAR R,W,WR; R:=GETV(TESTV,1); FOR J:=2:N DO << W:=!*F2MOD ADJOIN!-TERM(MKSP(V,GETV(PREDICTEDF,ISUB1 J)),1, POLYZERO); R:=PLUS!-MOD!-P(R,TIMES!-MOD!-P(W,GETV(TESTV,J))) >>; IF POLYZEROP (WR:=DIFFERENCE!-MOD!-P(POLY,TIMES!-MOD!-P(R,FHATI))) THEN RETURN LIST (R,WR); W:=QUOTIENT!-MOD!-P(WR,FI); IF DIDNTGO W OR NOT POLYZEROP DIFFERENCE!-MOD!-P(WR,TIMES!-MOD!-P(W,FI)) THEN RETURN 'BAD!-PREDICTION ELSE RETURN LIST(R,WR) END; ENDMODULE; MODULE MODPOLY; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % routines for performing arithmetic on multivariate % polynomials with coefficients that are modular % numbers as defined by modular!-plus etc; % note that the datastructure used is the same as that used in % REDUCE except that it is assumesd that domain elements are atomic; SYMBOLIC PROCEDURE PLUS!-MOD!-P(A,B); % form the sum of the two polynomials a and b % working over the ground domain defined by the routines % modular!-plus, modular!-times etc. the inputs to this % routine are assumed to have coefficients already % in the required domain; IF NULL A THEN B ELSE IF NULL B THEN A ELSE IF ISDOMAIN A THEN IF ISDOMAIN B THEN !*NUM2F MODULAR!-PLUS(A,B) ELSE (LT B) .+ PLUS!-MOD!-P(A,RED B) ELSE IF ISDOMAIN B THEN (LT A) .+ PLUS!-MOD!-P(RED A,B) ELSE IF LPOW A = LPOW B THEN ADJOIN!-TERM(LPOW A, PLUS!-MOD!-P(LC A,LC B),PLUS!-MOD!-P(RED A,RED B)) ELSE IF COMES!-BEFORE(LPOW A,LPOW B) THEN (LT A) .+ PLUS!-MOD!-P(RED A,B) ELSE (LT B) .+ PLUS!-MOD!-P(A,RED B); SYMBOLIC PROCEDURE TIMES!-MOD!-P(A,B); IF (NULL A) OR (NULL B) THEN NIL ELSE IF ISDOMAIN A THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(B,A) ELSE IF ISDOMAIN B THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,B) ELSE IF MVAR A=MVAR B THEN PLUS!-MOD!-P( PLUS!-MOD!-P(TIMES!-TERM!-MOD!-P(LT A,B), TIMES!-TERM!-MOD!-P(LT B,RED A)), TIMES!-MOD!-P(RED A,RED B)) ELSE IF ORDOP(MVAR A,MVAR B) THEN ADJOIN!-TERM(LPOW A,TIMES!-MOD!-P(LC A,B),TIMES!-MOD!-P(RED A,B)) ELSE ADJOIN!-TERM(LPOW B, TIMES!-MOD!-P(A,LC B),TIMES!-MOD!-P(A,RED B)); SYMBOLIC PROCEDURE TIMES!-TERM!-MOD!-P(TERM,B); %multiply the given polynomial by the given term; IF NULL B THEN NIL ELSE IF ISDOMAIN B THEN ADJOIN!-TERM(TPOW TERM, MULTIPLY!-BY!-CONSTANT!-MOD!-P(TC TERM,B),NIL) ELSE IF TVAR TERM=MVAR B THEN ADJOIN!-TERM(MKSP(TVAR TERM,IPLUS(TDEG TERM,LDEG B)), TIMES!-MOD!-P(TC TERM,LC B), TIMES!-TERM!-MOD!-P(TERM,RED B)) ELSE IF ORDOP(TVAR TERM,MVAR B) THEN ADJOIN!-TERM(TPOW TERM,TIMES!-MOD!-P(TC TERM,B),NIL) ELSE ADJOIN!-TERM(LPOW B, TIMES!-TERM!-MOD!-P(TERM,LC B), TIMES!-TERM!-MOD!-P(TERM,RED B)); SYMBOLIC PROCEDURE DIFFERENCE!-MOD!-P(A,B); PLUS!-MOD!-P(A,MINUS!-MOD!-P B); SYMBOLIC PROCEDURE MINUS!-MOD!-P A; IF NULL A THEN NIL ELSE IF ISDOMAIN A THEN MODULAR!-MINUS A ELSE (LPOW A .* MINUS!-MOD!-P LC A) .+ MINUS!-MOD!-P RED A; SYMBOLIC PROCEDURE REDUCE!-MOD!-P A; %converts a multivariate poly from normal into modular polynomial; IF NULL A THEN NIL ELSE IF ISDOMAIN A THEN !*NUM2F MODULAR!-NUMBER A ELSE ADJOIN!-TERM(LPOW A,REDUCE!-MOD!-P LC A,REDUCE!-MOD!-P RED A); SYMBOLIC PROCEDURE MONIC!-MOD!-P A; % This procedure can only cope with polys that have a numeric % leading coeff; IF A=NIL THEN NIL ELSE IF ISDOMAIN A THEN 1 ELSE IF LC A = 1 THEN A ELSE IF NOT DOMAINP LC A THEN ERRORF "LC NOT NUMERIC IN MONIC-MOD-P" ELSE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A, MODULAR!-RECIPROCAL LC A); SYMBOLIC PROCEDURE QUOTFAIL!-MOD!-P(A,B); % Form quotient A/B, but complain if the division is % not exact; BEGIN SCALAR C; EXACT!-QUOTIENT!-FLAG:=T; C:=QUOTIENT!-MOD!-P(A,B); IF EXACT!-QUOTIENT!-FLAG THEN RETURN C ELSE ERRORF "QUOTIENT NOT EXACT (MOD P)" END; SYMBOLIC PROCEDURE QUOTIENT!-MOD!-P(A,B); % truncated quotient of a by b; IF NULL B THEN ERRORF "B=0 IN QUOTIENT-MOD-P" ELSE IF ISDOMAIN B THEN MULTIPLY!-BY!-CONSTANT!-MOD!-P(A, MODULAR!-RECIPROCAL B) ELSE IF A=NIL THEN NIL ELSE IF ISDOMAIN A THEN EXACT!-QUOTIENT!-FLAG:=NIL ELSE IF MVAR A=MVAR B THEN XQUOTIENT!-MOD!-P(A,B,MVAR B) ELSE IF ORDOP(MVAR A,MVAR B) THEN ADJOIN!-TERM(LPOW A, QUOTIENT!-MOD!-P(LC A,B), QUOTIENT!-MOD!-P(RED A,B)) ELSE EXACT!-QUOTIENT!-FLAG:=NIL; SYMBOLIC PROCEDURE XQUOTIENT!-MOD!-P(A,B,V); % truncated quotient a/b given that b is nontrivial; IF A=NIL THEN NIL ELSE IF (ISDOMAIN A) OR (NOT MVAR A=V) OR ILESSP(LDEG A,LDEG B) THEN EXACT!-QUOTIENT!-FLAG:=NIL ELSE IF LDEG A = LDEG B THEN BEGIN SCALAR W; W:=QUOTIENT!-MOD!-P(LC A,LC B); IF DIFFERENCE!-MOD!-P(A,TIMES!-MOD!-P(W,B)) THEN EXACT!-QUOTIENT!-FLAG:=NIL; RETURN W END ELSE BEGIN SCALAR TERM; TERM:=MKSP(MVAR A,IDIFFERENCE(LDEG A,LDEG B)) .* QUOTIENT!-MOD!-P(LC A,LC B); %that is the leading term of the quotient. now subtract %term*b from a; A:=PLUS!-MOD!-P(RED A, TIMES!-TERM!-MOD!-P(NEGATE!-TERM TERM,RED B)); % or a:=a-b*term given leading terms must cancel; RETURN TERM .+ XQUOTIENT!-MOD!-P(A,B,V) END; SYMBOLIC PROCEDURE NEGATE!-TERM TERM; % negate a term; TPOW TERM .* MINUS!-MOD!-P TC TERM; SYMBOLIC PROCEDURE REMAINDER!-MOD!-P(A,B); % remainder when a is divided by b; IF NULL B THEN ERRORF "B=0 IN REMAINDER-MOD-P" ELSE IF ISDOMAIN B THEN NIL ELSE IF ISDOMAIN A THEN A ELSE XREMAINDER!-MOD!-P(A,B,MVAR B); SYMBOLIC PROCEDURE XREMAINDER!-MOD!-P(A,B,V); % remainder when the modular polynomial a is % divided by b, given that b is non degenerate; IF (ISDOMAIN A) OR (NOT MVAR A=V) OR ILESSP(LDEG A,LDEG B) THEN A ELSE BEGIN SCALAR Q,W; Q:=QUOTIENT!-MOD!-P(MINUS!-MOD!-P LC A,LC B); % compute -lc of quotient; W:=IDIFFERENCE(LDEG A,LDEG B); %ldeg of quotient; IF W=0 THEN A:=PLUS!-MOD!-P(RED A, MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED B,Q)) ELSE A:=PLUS!-MOD!-P(RED A,TIMES!-TERM!-MOD!-P( MKSP(MVAR B,W) .* Q,RED B)); % the above lines of code use red a and red b because % by construction the leading terms of the required % answers will cancel out; RETURN XREMAINDER!-MOD!-P(A,B,V) END; SYMBOLIC PROCEDURE MULTIPLY!-BY!-CONSTANT!-MOD!-P(A,N); % multiply the polynomial a by the constant n; IF NULL A THEN NIL ELSE IF N=1 THEN A ELSE IF ISDOMAIN A THEN !*NUM2F MODULAR!-TIMES(A,N) ELSE ADJOIN!-TERM(LPOW A,MULTIPLY!-BY!-CONSTANT!-MOD!-P(LC A,N), MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED A,N)); SYMBOLIC PROCEDURE GCD!-MOD!-P(A,B); % return the monic gcd of the two modular univariate % polynomials a and b. Set REDUCTION-COUNT to the number % of steps taken in the process; << REDUCTION!-COUNT := 0; IF NULL A THEN MONIC!-MOD!-P B ELSE IF NULL B THEN MONIC!-MOD!-P A ELSE IF ISDOMAIN A THEN 1 ELSE IF ISDOMAIN B THEN 1 ELSE IF IGREATERP(LDEG A,LDEG B) THEN ORDERED!-GCD!-MOD!-P(A,B) ELSE ORDERED!-GCD!-MOD!-P(B,A) >>; SYMBOLIC PROCEDURE ORDERED!-GCD!-MOD!-P(A,B); % as above, but deg a > deg b; BEGIN SCALAR STEPS; STEPS := 0; TOP: A := REDUCE!-DEGREE!-MOD!-P(A,B); IF NULL A THEN RETURN MONIC!-MOD!-P B; STEPS := STEPS + 1; IF DOMAINP A THEN << REDUCTION!-COUNT := REDUCTION!-COUNT+STEPS; RETURN 1 >> ELSE IF LDEG A<LDEG B THEN BEGIN SCALAR W; REDUCTION!-COUNT := REDUCTION!-COUNT + STEPS; STEPS := 0; W := A; A := B; B := W END; GO TO TOP END; SYMBOLIC PROCEDURE REDUCE!-DEGREE!-MOD!-P(A,B); % Compute A-Q*B where Q is a single term chosen so that the result % has lower degree than A did; BEGIN SCALAR Q,W; Q:=MODULAR!-QUOTIENT(MODULAR!-MINUS LC A,LC B); % compute -lc of quotient; W:=IDIFFERENCE(LDEG A,LDEG B); %ldeg of quotient; % the next lines of code use red a and red b because % by construction the leading terms of the required % answers will cancel out; IF W=0 THEN RETURN PLUS!-MOD!-P(RED A, MULTIPLY!-BY!-CONSTANT!-MOD!-P(RED B,Q)) ELSE RETURN PLUS!-MOD!-P(RED A,TIMES!-TERM!-MOD!-P( MKSP(MVAR B,W) .* Q,RED B)) END; SYMBOLIC PROCEDURE DERIVATIVE!-MOD!-P A; % derivative of a wrt its main variable; IF ISDOMAIN A THEN NIL ELSE IF LDEG A=1 THEN LC A ELSE DERIVATIVE!-MOD!-P!-1(A,MVAR A); SYMBOLIC PROCEDURE DERIVATIVE!-MOD!-P!-1(A,V); IF ISDOMAIN A THEN NIL ELSE IF NOT MVAR A=V THEN NIL ELSE IF LDEG A=1 THEN LC A ELSE ADJOIN!-TERM(MKSP(V,ISUB1 LDEG A), MULTIPLY!-BY!-CONSTANT!-MOD!-P(LC A, MODULAR!-NUMBER LDEG A), DERIVATIVE!-MOD!-P!-1(RED A,V)); SYMBOLIC PROCEDURE SQUARE!-FREE!-MOD!-P A; % predicate that tests if a is square-free as a modular % univariate polynomial; IF ISDOMAIN A THEN T ELSE ISDOMAIN GCD!-MOD!-P(A,DERIVATIVE!-MOD!-P A); SYMBOLIC PROCEDURE EVALUATE!-MOD!-P(A,V,N); % evaluate polynomial A at the point V=N; IF ISDOMAIN A THEN A ELSE IF V=NIL THEN ERRORF "Variable=NIL in EVALUATE-MOD-P" ELSE IF MVAR A=V THEN HORNER!-RULE!-MOD!-P(LC A,LDEG A,RED A,N,V) ELSE ADJOIN!-TERM(LPOW A, EVALUATE!-MOD!-P(LC A,V,N), EVALUATE!-MOD!-P(RED A,V,N)); SYMBOLIC PROCEDURE HORNER!-RULE!-MOD!-P(V,DEGG,A,N,VAR); % v is the running total, and it must be multiplied by % n**deg and added to the value of a at n; IF ISDOMAIN A OR NOT MVAR A=VAR THEN << V:=TIMES!-MOD!-P(V,EXPT!-MOD!-P(N,DEGG)); PLUS!-MOD!-P(A,V) >> ELSE BEGIN SCALAR NEWDEG; NEWDEG:=LDEG A; RETURN HORNER!-RULE!-MOD!-P(PLUS!-MOD!-P(LC A, TIMES!-MOD!-P(V,EXPT!-MOD!-P(N,IDIFFERENCE(DEGG,NEWDEG)))), NEWDEG,RED A,N,VAR) END; SYMBOLIC PROCEDURE EXPT!-MOD!-P(A,N); % a**n; IF N=0 THEN 1 ELSE IF N=1 THEN A ELSE BEGIN SCALAR W,X; W:=DIVIDE(N,2); X:=EXPT!-MOD!-P(A,CAR W); X:=TIMES!-MOD!-P(X,X); IF NOT (CDR W = 0) THEN X:=TIMES!-MOD!-P(X,A); RETURN X END; SYMBOLIC PROCEDURE MAKE!-BIVARIATE!-MOD!-P(U,IMSET,V); % Substitute into U for all variables in IMSET which should result in % a bivariate poly. One variable is M-IMAGE-VARIABLE and V is the other % U is modular multivariate with these two variables at top 2 levels % - V at 2nd level; IF DOMAINP U THEN U ELSE IF MVAR U = M!-IMAGE!-VARIABLE THEN ADJOIN!-TERM(LPOW U,MAKE!-UNIVARIATE!-MOD!-P(LC U,IMSET,V), MAKE!-BIVARIATE!-MOD!-P(RED U,IMSET,V)) ELSE MAKE!-UNIVARIATE!-MOD!-P(U,IMSET,V); SYMBOLIC PROCEDURE MAKE!-UNIVARIATE!-MOD!-P(U,IMSET,V); % Substitute into U for all variables in IMSET giving a univariate % poly in V. U is modular multivariate with V at top level; IF DOMAINP U THEN U ELSE IF MVAR U = V THEN ADJOIN!-TERM(LPOW U,!*NUM2F EVALUATE!-IN!-ORDER!-MOD!-P(LC U,IMSET), MAKE!-UNIVARIATE!-MOD!-P(RED U,IMSET,V)) ELSE !*NUM2F EVALUATE!-IN!-ORDER!-MOD!-P(U,IMSET); SYMBOLIC PROCEDURE EVALUATE!-IN!-ORDER!-MOD!-P(U,IMSET); % makes an image of u wrt imageset, imset, using horner's rule. result % should be purely numeric (and modular); IF DOMAINP U THEN !*D2N U ELSE IF MVAR U=CAAR IMSET THEN HORNER!-RULE!-IN!-ORDER!-MOD!-P( EVALUATE!-IN!-ORDER!-MOD!-P(LC U,CDR IMSET),LDEG U,RED U,IMSET) ELSE EVALUATE!-IN!-ORDER!-MOD!-P(U,CDR IMSET); SYMBOLIC PROCEDURE HORNER!-RULE!-IN!-ORDER!-MOD!-P(C,DEGG,A,VSET); % c is running total and a is what is left; IF DOMAINP A THEN MODULAR!-PLUS(!*D2N A, MODULAR!-TIMES(C,MODULAR!-EXPT(CDAR VSET,DEGG))) ELSE IF NOT(MVAR A=CAAR VSET) THEN MODULAR!-PLUS( EVALUATE!-IN!-ORDER!-MOD!-P(A,CDR VSET), MODULAR!-TIMES(C,MODULAR!-EXPT(CDAR VSET,DEGG))) ELSE BEGIN SCALAR NEWDEG; NEWDEG:=LDEG A; RETURN HORNER!-RULE!-IN!-ORDER!-MOD!-P( MODULAR!-PLUS( EVALUATE!-IN!-ORDER!-MOD!-P(LC A,CDR VSET), MODULAR!-TIMES(C, MODULAR!-EXPT(CDAR VSET,(IDIFFERENCE(DEGG,NEWDEG))))), NEWDEG,RED A,VSET) END; SYMBOLIC PROCEDURE MAKE!-MODULAR!-SYMMETRIC A; % input is a multivariate MODULAR poly A with nos in the range 0->(p-1). % This folds it onto the symmetric range (-p/2)->(p/2); IF NULL A THEN NIL ELSE IF DOMAINP A THEN IF A>MODULUS!/2 THEN !*NUM2F(A - CURRENT!-MODULUS) ELSE A ELSE ADJOIN!-TERM(LPOW A,MAKE!-MODULAR!-SYMMETRIC LC A, MAKE!-MODULAR!-SYMMETRIC RED A); ENDMODULE; MODULE MULTIHEN; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; %**********************************************************************; % hensel construction for the multivariate case % (this version is highly recursive); SYMBOLIC PROCEDURE FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(POLY, BEST!-FACTORS,VARIABLE!-SET); % All arithmetic is done mod p, best-factors is overwritten; IF NULL VARIABLE!-SET THEN BEST!-FACTORS ELSE (LAMBDA FACTOR!-LEVEL; BEGIN SCALAR GROWTH!-FACTOR,B0S,RES,CORRECTION!-FACTOR,SUBSTRES,V, B1,BHAT0S,W,K,DEGBD,FIRST!-TIME,REDPOLY,D, PREDICTED!-FORMS,NUMBER!-OF!-UNKNOWNS,SOLVE!-COUNT, CORRECTION!-VECTORS,SOLN!-MATRICES,MAX!-UNKNOWNS, UNKNOWNS!-COUNT!-LIST,TEST!-PREDICTION,POLY!-REMAINING, PREDICTION!-RESULTS,ONE!-PREDICTION!-FAILED,KK; V:=CAR VARIABLE!-SET; DEGBD:=GET!-DEGREE!-BOUND CAR V; FIRST!-TIME:=T; GROWTH!-FACTOR:=MAKE!-GROWTH!-FACTOR V; POLY!-REMAINING:=POLY; PREDICTION!-RESULTS:=MKVECT NUMBER!-OF!-FACTORS; FACTOR!-TRACE << PRINTSTR "Want f(i) s.t."; PRIN2!* " product over i [ f(i) ] = "; PRINSF POLY; PRIN2!* " mod "; PRINTSTR HENSEL!-GROWTH!-SIZE; TERPRI!*(NIL); PRINTSTR "We know f(i) as follows:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS); PRIN2!* " and we shall put in powers of "; PRINSF GROWTH!-FACTOR; PRINTSTR " to find them fully." >>; B0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P(BEST!-FACTORS, V,NUMBER!-OF!-FACTORS); % The above made a copy of the vector; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(BEST!-FACTORS,I, DIFFERENCE!-MOD!-P(GETV(BEST!-FACTORS,I),GETV(B0S,I))); REDPOLY:=EVALUATE!-MOD!-P(POLY,CAR V,CDR V); FACTOR!-TRACE << PRIN2!* "First solve the problem in one less variable by putting "; PRINVAR CAR V; PRIN2!* "="; PRINTSTR CDR V; IF CDR VARIABLE!-SET THEN << PRIN2!* "and growing wrt "; PRINTVAR CAADR VARIABLE!-SET >>; TERPRI!*(NIL) >>; FIND!-MULTIVARIATE!-FACTORS!-MOD!-P(REDPOLY,B0S,CDR VARIABLE!-SET); % answers in b0s; IF BAD!-CASE THEN RETURN; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(BEST!-FACTORS,I, PLUS!-MOD!-P(GETV(B0S,I),GETV(BEST!-FACTORS,I))); FACTOR!-TRACE << PRIN2!* "After putting back any knowledge of "; PRINVAR CAR V; PRINTSTR ", we have the"; PRINTSTR "factors so far as:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS); PRINTSTR "Subtracting the product of these from the polynomial"; PRIN2!* "and differentiating wrt "; PRINVAR CAR V; PRINTSTR " gives a residue:" >>; RES:=DIFF!-OVER!-K!-MOD!-P( DIFFERENCE!-MOD!-P(POLY, TIMES!-VECTOR!-MOD!-P(BEST!-FACTORS,NUMBER!-OF!-FACTORS)), 1,CAR V); % RES is the residue and must eventually be reduced to zero; FACTOR!-TRACE << FAC!-PRINTSF RES; TERPRI!*(NIL) >>; IF NOT POLYZEROP RES AND CDR VARIABLE!-SET AND NOT ZEROP CDR V THEN << PREDICTED!-FORMS:=MAKE!-BIVARIATE!-VEC!-MOD!-P(BEST!-FACTORS, CDR VARIABLE!-SET,CAR V,NUMBER!-OF!-FACTORS); FIND!-MULTIVARIATE!-FACTORS!-MOD!-P( MAKE!-BIVARIATE!-MOD!-P(POLY,CDR VARIABLE!-SET,CAR V), PREDICTED!-FORMS,LIST V); % answers in PREDICTED!-FORMS; FACTOR!-TRACE << PRINTSTR "To help reduce the number of Hensel steps we try"; PRIN2!* "predicting how many terms each factor will have wrt "; PRINVAR CAR V; PRINTSTR "."; PRINTSTR "Predictions are based on the bivariate factors :"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",PREDICTED!-FORMS) >>; MAKE!-PREDICTED!-FORMS(PREDICTED!-FORMS,CAR V); % sets max!-unknowns and number!-of!-unknowns; FACTOR!-TRACE << TERPRI!*(NIL); PRINTSTR "We predict :"; FOR EACH W IN NUMBER!-OF!-UNKNOWNS DO << PRIN2!* CAR W; PRIN2!* " terms in f("; PRIN2!* CDR W; PRINTSTR '!) >>; IF (CAAR NUMBER!-OF!-UNKNOWNS)=1 THEN << PRIN2!* "Since we predict only one term for f("; PRIN2!* CDAR NUMBER!-OF!-UNKNOWNS; PRINTSTR "), we can try"; PRINTSTR "dividing it out now:" >> ELSE << PRIN2!* "So we shall do at least "; PRIN2!* ISUB1 CAAR NUMBER!-OF!-UNKNOWNS; PRIN2!* " Hensel step"; IF (CAAR NUMBER!-OF!-UNKNOWNS)=2 THEN PRINTSTR "." ELSE PRINTSTR "s." >>; TERPRI!*(NIL) >>; UNKNOWNS!-COUNT!-LIST:=NUMBER!-OF!-UNKNOWNS; WHILE UNKNOWNS!-COUNT!-LIST AND (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=1 DO BEGIN SCALAR I,R; UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST; I:=CDR W; W:=QUOTIENT!-MOD!-P(POLY!-REMAINING,R:=GETV(BEST!-FACTORS,I)); IF DIDNTGO W OR NOT POLYZEROP DIFFERENCE!-MOD!-P(POLY!-REMAINING, TIMES!-MOD!-P(W,R)) THEN IF ONE!-PREDICTION!-FAILED THEN << FACTOR!-TRACE PRINTSTR "Predictions are no good"; MAX!-UNKNOWNS:=NIL >> ELSE << FACTOR!-TRACE << PRIN2!* "Guess for f("; PRIN2!* I; PRINTSTR ") was bad." >>; ONE!-PREDICTION!-FAILED:=I >> ELSE << PUTV(PREDICTION!-RESULTS,I,R); FACTOR!-TRACE << PRIN2!* "Prediction for f("; PRIN2!* I; PRIN2!* ") worked: "; FAC!-PRINTSF R >>; POLY!-REMAINING:=W >> END; W:=LENGTH UNKNOWNS!-COUNT!-LIST; IF W=1 AND NOT ONE!-PREDICTION!-FAILED THEN << PUTV(BEST!-FACTORS,CDAR UNKNOWNS!-COUNT!-LIST,POLY!-REMAINING); GOTO EXIT >> ELSE IF W=0 AND ONE!-PREDICTION!-FAILED THEN << PUTV(BEST!-FACTORS,ONE!-PREDICTION!-FAILED,POLY!-REMAINING); GOTO EXIT >>; SOLVE!-COUNT:=1; IF MAX!-UNKNOWNS THEN CORRECTION!-VECTORS:=MAKE!-CORRECTION!-VECTORS(PREDICTED!-FORMS, BEST!-FACTORS,MAX!-UNKNOWNS) >>; BHAT0S:=MAKE!-MULTIVARIATE!-HATVEC!-MOD!-P(B0S,NUMBER!-OF!-FACTORS); K:=1; KK:=0; CORRECTION!-FACTOR:=GROWTH!-FACTOR; % next power of growth-factor we are % adding to the factors; B1:=MKVECT NUMBER!-OF!-FACTORS; TEMPLOOP: WHILE NOT POLYZEROP RES AND (NULL MAX!-UNKNOWNS OR NULL TEST!-PREDICTION) DO IF K>DEGBD THEN RETURN << FACTOR!-TRACE << PRIN2!* "We have overshot the degree bound for "; PRINTVAR CAR V >>; IF !*OVERSHOOT THEN PRINTC "Multivariate degree bound overshoot -> restart"; BAD!-CASE:=T >> ELSE IF POLYZEROP(SUBSTRES:=EVALUATE!-MOD!-P(RES,CAR V,CDR V)) THEN << K:=IADD1 K; RES:=DIFF!-OVER!-K!-MOD!-P(RES,K,CAR V); CORRECTION!-FACTOR:= TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >> ELSE << FACTOR!-TRACE << PRIN2!* "Hensel Step "; PRINTSTR (KK:=KK #+ 1); PRIN2!* "-------------"; IF KK>10 THEN PRINTSTR "-" ELSE TERPRI!*(T); PRIN2!* "Next corrections are for ("; PRINSF GROWTH!-FACTOR; IF NOT (K=1) THEN << PRIN2!* ") ** "; PRIN2!* K >> ELSE PRIN2!* '!); PRINTSTR ". To find these we solve:"; PRIN2!* " sum over i [ f(i,1)*fhat(i,0) ] = "; PRINSF SUBSTRES; PRIN2!* " mod "; PRIN2!* HENSEL!-GROWTH!-SIZE; PRINTSTR " for f(i,1), "; IF FIRST!-TIME THEN << FIRST!-TIME:=NIL; PRIN2!* " where fhat(i,0) = product over j [ f(j,0) ]"; PRIN2!* " / f(i,0) mod "; PRINTSTR HENSEL!-GROWTH!-SIZE >>; TERPRI!*(NIL) >>; SOLVE!-FOR!-CORRECTIONS(SUBSTRES,BHAT0S,B0S,B1, CDR VARIABLE!-SET); % Answers left in B1; IF BAD!-CASE THEN RETURN; IF MAX!-UNKNOWNS THEN << SOLVE!-COUNT:=IADD1 SOLVE!-COUNT; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(GETV(CORRECTION!-VECTORS,I),SOLVE!-COUNT,GETV(B1,I)); IF SOLVE!-COUNT=CAAR UNKNOWNS!-COUNT!-LIST THEN TEST!-PREDICTION:=T >>; FACTOR!-TRACE << PRINTSTR " Giving:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,",1) = ",B1) >>; D:=TIMES!-MOD!-P(CORRECTION!-FACTOR, TERMS!-DONE!-MOD!-P(BEST!-FACTORS,B1,CORRECTION!-FACTOR)); IF DEGREE!-IN!-VARIABLE(D,CAR V)>DEGBD THEN RETURN << FACTOR!-TRACE << PRIN2!* "We have overshot the degree bound for "; PRINTVAR CAR V >>; IF !*OVERSHOOT THEN PRINTC "Multivariate degree bound overshoot -> restart"; BAD!-CASE:=T >>; D:=DIFF!-K!-TIMES!-MOD!-P(D,K,CAR V); FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(BEST!-FACTORS,I, PLUS!-MOD!-P(GETV(BEST!-FACTORS,I), TIMES!-MOD!-P(GETV(B1,I),CORRECTION!-FACTOR))); K:=IADD1 K; RES:=DIFF!-OVER!-K!-MOD!-P(DIFFERENCE!-MOD!-P(RES,D),K,CAR V); FACTOR!-TRACE << PRINTSTR " New factors are now:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS); PRIN2!* " and residue = "; FAC!-PRINTSF RES; PRINTSTR "-------------" >>; CORRECTION!-FACTOR:= TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>; IF NOT POLYZEROP RES AND NOT BAD!-CASE THEN << SOLN!-MATRICES:=CONSTRUCT!-SOLN!-MATRICES(PREDICTED!-FORMS,CDR V); FACTOR!-TRACE << PRINTSTR "We use the results from the Hensel growth to"; PRINTSTR "produce a set of linear equations to solve"; PRINTSTR "for coefficients in the relevent factors:" >>; WHILE UNKNOWNS!-COUNT!-LIST AND (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=SOLVE!-COUNT DO << UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST; FACTOR!-TRACE PRINT!-LINEAR!-SYSTEM(CDR W,SOLN!-MATRICES, CORRECTION!-VECTORS,PREDICTED!-FORMS,CAR V); W:=TRY!-PREDICTION(SOLN!-MATRICES,CORRECTION!-VECTORS, PREDICTED!-FORMS,CAR W,CDR W,POLY!-REMAINING,CAR V, NIL,NIL,NIL); IF CAR W='SINGULAR OR CAR W='BAD!-PREDICTION THEN IF ONE!-PREDICTION!-FAILED THEN << FACTOR!-TRACE PRINTSTR "Predictions were no help."; RETURN MAX!-UNKNOWNS:=NIL >> ELSE ONE!-PREDICTION!-FAILED:=CDR W ELSE << PUTV(PREDICTION!-RESULTS,CAR W,CADR W); POLY!-REMAINING:=CADDR W >> >>; IF NULL MAX!-UNKNOWNS THEN GOTO TEMPLOOP; W:=LENGTH UNKNOWNS!-COUNT!-LIST; IF W>1 OR (W=1 AND ONE!-PREDICTION!-FAILED) THEN << TEST!-PREDICTION:=NIL; GOTO TEMPLOOP >>; IF W=1 OR ONE!-PREDICTION!-FAILED THEN << W:=IF ONE!-PREDICTION!-FAILED THEN ONE!-PREDICTION!-FAILED ELSE CDAR UNKNOWNS!-COUNT!-LIST; PUTV(PREDICTION!-RESULTS,W,POLY!-REMAINING) >>; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(BEST!-FACTORS,I,GETV(PREDICTION!-RESULTS,I)); IF NOT ONE!-PREDICTION!-FAILED THEN PREDICTIONS:= (CAR V . LIST(SOLN!-MATRICES,PREDICTED!-FORMS,MAX!-UNKNOWNS, NUMBER!-OF!-UNKNOWNS)) . PREDICTIONS >>; EXIT: FACTOR!-TRACE << IF NOT BAD!-CASE THEN IF FIRST!-TIME THEN PRINTSTR "Therefore these factors are already correct." ELSE << PRINTSTR "Correct factors are:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",BEST!-FACTORS) >>; TERPRI!*(NIL); PRINTSTR "******************************************************"; TERPRI!*(NIL) >> END) (FACTOR!-LEVEL+1); SYMBOLIC PROCEDURE SOLVE!-FOR!-CORRECTIONS(C,FHATVEC,FVEC,RESVEC,VSET); % ....; IF NULL VSET THEN FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(RESVEC,I, REMAINDER!-MOD!-P( TIMES!-MOD!-P(C,GETV(ALPHAVEC,I)), GETV(FVEC,I))) ELSE (LAMBDA FACTOR!-LEVEL; BEGIN SCALAR RESIDUE,GROWTH!-FACTOR,F0S,FHAT0S,V,F1, CORRECTION!-FACTOR,SUBSTRES,K,DEGBD,FIRST!-TIME,REDC,D, PREDICTED!-FORMS,MAX!-UNKNOWNS,SOLVE!-COUNT,NUMBER!-OF!-UNKNOWNS, CORRECTION!-VECTORS,SOLN!-MATRICES,W,PREVIOUS!-PREDICTION!-HOLDS, UNKNOWNS!-COUNT!-LIST,TEST!-PREDICTION,POLY!-REMAINING, PREDICTION!-RESULTS,ONE!-PREDICTION!-FAILED,KK; V:=CAR VSET; DEGBD:=GET!-DEGREE!-BOUND CAR V; FIRST!-TIME:=T; GROWTH!-FACTOR:=MAKE!-GROWTH!-FACTOR V; POLY!-REMAINING:=C; PREDICTION!-RESULTS:=MKVECT NUMBER!-OF!-FACTORS; REDC:=EVALUATE!-MOD!-P(C,CAR V,CDR V); FACTOR!-TRACE << PRINTSTR "Want a(i) s.t."; PRIN2!* "(*) sum over i [ a(i)*fhat(i) ] = "; PRINSF C; PRIN2!* " mod "; PRINTSTR HENSEL!-GROWTH!-SIZE; PRIN2!* " where fhat(i) = product over j [ f(j) ]"; PRIN2!* " / f(i) mod "; PRINTSTR HENSEL!-GROWTH!-SIZE; PRINTSTR " and"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",FVEC); TERPRI!*(NIL); PRIN2!* "First solve the problem in one less variable by putting "; PRINVAR CAR V; PRIN2!* '!=; PRINTSTR CDR V; TERPRI!*(NIL) >>; SOLVE!-FOR!-CORRECTIONS(REDC, FHAT0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P( FHATVEC,V,NUMBER!-OF!-FACTORS), F0S:=REDUCE!-VEC!-BY!-ONE!-VAR!-MOD!-P( FVEC,V,NUMBER!-OF!-FACTORS), RESVEC, CDR VSET); % Results left in RESVEC; IF BAD!-CASE THEN RETURN; FACTOR!-TRACE << PRINTSTR "Giving:"; PRINTVEC(" a(",NUMBER!-OF!-FACTORS,",0) = ",RESVEC); PRINTSTR "Subtracting the contributions these give in (*) from"; PRIN2!* "the R.H.S. of (*) "; PRIN2!* "and differentiating wrt "; PRINVAR CAR V; PRINTSTR " gives a residue:" >>; RESIDUE:=DIFF!-OVER!-K!-MOD!-P(DIFFERENCE!-MOD!-P(C, FORM!-SUM!-AND!-PRODUCT!-MOD!-P(RESVEC,FHATVEC, NUMBER!-OF!-FACTORS)),1,CAR V); FACTOR!-TRACE << FAC!-PRINTSF RESIDUE; PRIN2!* " Now we shall put in the powers of "; PRINSF GROWTH!-FACTOR; PRINTSTR " to find the a's fully." >>; IF NOT POLYZEROP RESIDUE AND NOT ZEROP CDR V THEN << W:=ATSOC(CAR V,PREDICTIONS); IF W THEN << PREVIOUS!-PREDICTION!-HOLDS:=T; FACTOR!-TRACE << PRINTSTR "We shall use the previous prediction for the form of"; PRIN2!* "polynomials wrt "; PRINTVAR CAR V >>; W:=CDR W; SOLN!-MATRICES:=CAR W; PREDICTED!-FORMS:=CADR W; MAX!-UNKNOWNS:=CADDR W; NUMBER!-OF!-UNKNOWNS:=CADR CDDR W >> ELSE << FACTOR!-TRACE << PRINTSTR "We shall use a new prediction for the form of polynomials "; PRIN2!* "wrt "; PRINTVAR CAR V >>; PREDICTED!-FORMS:=MKVECT NUMBER!-OF!-FACTORS; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(PREDICTED!-FORMS,I,GETV(FVEC,I)); % make a copy of the factors in a vector that we shall % overwrite; MAKE!-PREDICTED!-FORMS(PREDICTED!-FORMS,CAR V); % sets max!-unknowns and number!-of!-unknowns; >>; FACTOR!-TRACE << TERPRI!*(NIL); PRINTSTR "We predict :"; FOR EACH W IN NUMBER!-OF!-UNKNOWNS DO << PRIN2!* CAR W; PRIN2!* " terms in a("; PRIN2!* CDR W; PRINTSTR '!) >>; IF (CAAR NUMBER!-OF!-UNKNOWNS)=1 THEN << PRIN2!* "Since we predict only one term for a("; PRIN2!* CDAR NUMBER!-OF!-UNKNOWNS; PRINTSTR "), we can test it right away:" >> ELSE << PRIN2!* "So we shall do at least "; PRIN2!* ISUB1 CAAR NUMBER!-OF!-UNKNOWNS; PRIN2!* " Hensel step"; IF (CAAR NUMBER!-OF!-UNKNOWNS)=2 THEN PRINTSTR "." ELSE PRINTSTR "s." >>; TERPRI!*(NIL) >>; UNKNOWNS!-COUNT!-LIST:=NUMBER!-OF!-UNKNOWNS; WHILE UNKNOWNS!-COUNT!-LIST AND (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=1 DO BEGIN SCALAR I,R,WR,FI; UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST; I:=CDR W; W:=QUOTIENT!-MOD!-P( WR:=DIFFERENCE!-MOD!-P(POLY!-REMAINING, TIMES!-MOD!-P(R:=GETV(RESVEC,I),GETV(FHATVEC,I))), FI:=GETV(FVEC,I)); IF DIDNTGO W OR NOT POLYZEROP DIFFERENCE!-MOD!-P(WR,TIMES!-MOD!-P(W,FI)) THEN IF ONE!-PREDICTION!-FAILED THEN << FACTOR!-TRACE PRINTSTR "Predictions are no good."; MAX!-UNKNOWNS:=NIL >> ELSE << FACTOR!-TRACE << PRIN2!* "Guess for a("; PRIN2!* I; PRINTSTR ") was bad." >>; ONE!-PREDICTION!-FAILED:=I >> ELSE << PUTV(PREDICTION!-RESULTS,I,R); FACTOR!-TRACE << PRIN2!* "Prediction for a("; PRIN2!* I; PRIN2!* ") worked: "; FAC!-PRINTSF R >>; POLY!-REMAINING:=WR >> END; W:=LENGTH UNKNOWNS!-COUNT!-LIST; IF W=1 AND NOT ONE!-PREDICTION!-FAILED THEN << PUTV(RESVEC,CDAR UNKNOWNS!-COUNT!-LIST, QUOTFAIL!-MOD!-P(POLY!-REMAINING,GETV(FHATVEC, CDAR UNKNOWNS!-COUNT!-LIST))); GOTO EXIT >> ELSE IF W=0 AND ONE!-PREDICTION!-FAILED THEN << PUTV(RESVEC,ONE!-PREDICTION!-FAILED, QUOTFAIL!-MOD!-P(POLY!-REMAINING,GETV(FHATVEC, ONE!-PREDICTION!-FAILED))); GOTO EXIT >>; SOLVE!-COUNT:=1; IF MAX!-UNKNOWNS THEN CORRECTION!-VECTORS:=MAKE!-CORRECTION!-VECTORS(PREDICTED!-FORMS, RESVEC,MAX!-UNKNOWNS) >>; F1:=MKVECT NUMBER!-OF!-FACTORS; K:=1; KK:=0; CORRECTION!-FACTOR:=GROWTH!-FACTOR; IF NOT POLYZEROP RESIDUE THEN FIRST!-TIME:=NIL; TEMPLOOP: WHILE NOT POLYZEROP RESIDUE AND (NULL MAX!-UNKNOWNS OR NULL TEST!-PREDICTION) DO IF K>DEGBD THEN RETURN << FACTOR!-TRACE << PRIN2!* "We have overshot the degree bound for "; PRINTVAR CAR V >>; IF !*OVERSHOOT THEN PRINTC "Multivariate degree bound overshoot -> restart"; BAD!-CASE:=T >> ELSE IF POLYZEROP(SUBSTRES:=EVALUATE!-MOD!-P(RESIDUE,CAR V,CDR V)) THEN << K:=IADD1 K; RESIDUE:=DIFF!-OVER!-K!-MOD!-P(RESIDUE,K,CAR V); CORRECTION!-FACTOR:= TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >> ELSE << FACTOR!-TRACE << PRIN2!* "Hensel Step "; PRINTSTR (KK:=KK #+ 1); PRIN2!* "-------------"; IF KK>10 THEN PRINTSTR "-" ELSE TERPRI!*(T); PRIN2!* "Next corrections are for ("; PRINSF GROWTH!-FACTOR; IF NOT (K=1) THEN << PRIN2!* ") ** "; PRIN2!* K >> ELSE PRIN2!* '!); PRINTSTR ". To find these we solve:"; PRIN2!* " sum over i [ a(i,1)*fhat(i,0) ] = "; PRINSF SUBSTRES; PRIN2!* " mod "; PRIN2!* HENSEL!-GROWTH!-SIZE; PRINTSTR " for a(i,1). "; TERPRI!*(NIL) >>; SOLVE!-FOR!-CORRECTIONS(SUBSTRES,FHAT0S,F0S,F1,CDR VSET); % answers in f1; IF BAD!-CASE THEN RETURN; IF MAX!-UNKNOWNS THEN << SOLVE!-COUNT:=IADD1 SOLVE!-COUNT; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(GETV(CORRECTION!-VECTORS,I),SOLVE!-COUNT,GETV(F1,I)); IF SOLVE!-COUNT=CAAR UNKNOWNS!-COUNT!-LIST THEN TEST!-PREDICTION:=T >>; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(RESVEC,I,PLUS!-MOD!-P(GETV(RESVEC,I),TIMES!-MOD!-P( GETV(F1,I),CORRECTION!-FACTOR))); FACTOR!-TRACE << PRINTSTR " Giving:"; PRINTVEC(" a(",NUMBER!-OF!-FACTORS,",1) = ",F1); PRINTSTR " New a's are now:"; PRINTVEC(" a(",NUMBER!-OF!-FACTORS,") = ",RESVEC) >>; D:=TIMES!-MOD!-P(CORRECTION!-FACTOR, FORM!-SUM!-AND!-PRODUCT!-MOD!-P(F1,FHATVEC, NUMBER!-OF!-FACTORS)); IF DEGREE!-IN!-VARIABLE(D,CAR V)>DEGBD THEN RETURN << FACTOR!-TRACE << PRIN2!* "We have overshot the degree bound for "; PRINTVAR CAR V >>; IF !*OVERSHOOT THEN PRINTC "Multivariate degree bound overshoot -> restart"; BAD!-CASE:=T >>; D:=DIFF!-K!-TIMES!-MOD!-P(D,K,CAR V); K:=IADD1 K; RESIDUE:=DIFF!-OVER!-K!-MOD!-P( DIFFERENCE!-MOD!-P(RESIDUE,D),K,CAR V); FACTOR!-TRACE << PRIN2!* " and residue = "; FAC!-PRINTSF RESIDUE; PRINTSTR "-------------" >>; CORRECTION!-FACTOR:= TIMES!-MOD!-P(CORRECTION!-FACTOR,GROWTH!-FACTOR) >>; IF NOT POLYZEROP RESIDUE AND NOT BAD!-CASE THEN << IF NULL SOLN!-MATRICES THEN SOLN!-MATRICES:= CONSTRUCT!-SOLN!-MATRICES(PREDICTED!-FORMS,CDR V); FACTOR!-TRACE << PRINTSTR "The Hensel growth so far allows us to test some of"; PRINTSTR "our predictions:" >>; WHILE UNKNOWNS!-COUNT!-LIST AND (CAR (W:=CAR UNKNOWNS!-COUNT!-LIST))=SOLVE!-COUNT DO << UNKNOWNS!-COUNT!-LIST:=CDR UNKNOWNS!-COUNT!-LIST; FACTOR!-TRACE PRINT!-LINEAR!-SYSTEM(CDR W,SOLN!-MATRICES, CORRECTION!-VECTORS,PREDICTED!-FORMS,CAR V); W:=TRY!-PREDICTION(SOLN!-MATRICES,CORRECTION!-VECTORS, PREDICTED!-FORMS,CAR W,CDR W,POLY!-REMAINING,CAR V,FVEC, FHATVEC,PREVIOUS!-PREDICTION!-HOLDS); IF CAR W='SINGULAR OR CAR W='BAD!-PREDICTION THEN IF ONE!-PREDICTION!-FAILED THEN << FACTOR!-TRACE PRINTSTR "Predictions were no help."; RETURN MAX!-UNKNOWNS:=NIL >> ELSE << IF PREVIOUS!-PREDICTION!-HOLDS THEN << PREDICTIONS:=DELASC(CAR V,PREDICTIONS); PREVIOUS!-PREDICTION!-HOLDS:=NIL >>; ONE!-PREDICTION!-FAILED:=CDR W >> ELSE << PUTV(PREDICTION!-RESULTS,CAR W,CADR W); POLY!-REMAINING:=CADDR W >> >>; IF NULL MAX!-UNKNOWNS THEN << IF PREVIOUS!-PREDICTION!-HOLDS THEN PREDICTIONS:=DELASC(CAR V,PREDICTIONS); GOTO TEMPLOOP >>; W:=LENGTH UNKNOWNS!-COUNT!-LIST; IF W>1 OR (W=1 AND ONE!-PREDICTION!-FAILED) THEN << TEST!-PREDICTION:=NIL; GOTO TEMPLOOP >>; IF W=1 OR ONE!-PREDICTION!-FAILED THEN << W:=IF ONE!-PREDICTION!-FAILED THEN ONE!-PREDICTION!-FAILED ELSE CDAR UNKNOWNS!-COUNT!-LIST; PUTV(PREDICTION!-RESULTS,W,QUOTFAIL!-MOD!-P( POLY!-REMAINING,GETV(FHATVEC,W))) >>; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(RESVEC,I,GETV(PREDICTION!-RESULTS,I)); IF NOT PREVIOUS!-PREDICTION!-HOLDS AND NOT ONE!-PREDICTION!-FAILED THEN PREDICTIONS:= (CAR V . LIST(SOLN!-MATRICES,PREDICTED!-FORMS,MAX!-UNKNOWNS, NUMBER!-OF!-UNKNOWNS)) . PREDICTIONS >>; EXIT: FACTOR!-TRACE << IF NOT BAD!-CASE THEN IF FIRST!-TIME THEN PRINTSTR "But these a's are already correct." ELSE << PRINTSTR "Correct a's are:"; PRINTVEC(" a(",NUMBER!-OF!-FACTORS,") = ",RESVEC) >>; TERPRI!*(NIL); PRINTSTR "**************************************************"; TERPRI!*(NIL) >> END) (FACTOR!-LEVEL+1); ENDMODULE; MODULE NATURAL; % part of resultant program; SYMBOLIC PROCEDURE NATURAL!-PRS!-ALGORITHM(A,B,X); % A,B are univariate polynomials mod p. The procedure calculates; % the natural prs and hence res(A,B) mod p.; % one poly may be a number; IF NOT (UNIVARIATEP A AND UNIVARIATEP B) THEN ERRORF "NON UNIVARIATE POLYS INPUT TO NATURAL PRS ALG" ELSE BEGIN INTEGER V, TEMPANS, ANS, LOOP; SCALAR T1, T2, T3; IF NOT X = CAR UNION(VARIABLES!-IN!-FORM A, VARIABLES!-IN!-FORM B) THEN ERRORF "WRONG VARIABLE INPUT TO NATURAL"; LOOP := 0; % loop is used as a pseudo-boolean; V := 0; TEMPANS := 1; T3 := REMAINDER!-MOD!-P(A,B); IF (T3 = A) THEN << T1 := B; T2 := A; T3 := REMAINDER!-MOD!-P(T1,T2) >> ELSE << T1 := A; T2 := B >>; WHILE (LOOP = 0) DO << TEMPANS := MODULAR!-TIMES(TEMPANS, MODULAR!-EXPT(LC T2, LDEG T1 - LEADING!-DEGREE T3)); V := LOGXOR(V,LOGAND(LDEG T1,LDEG T2,1)); IF (LEADING!-DEGREE T3 = 0) THEN LOOP := 1 ELSE BEGIN T1 := T2; T2 := T3; T3 := REMAINDER!-MOD!-P(T1,T2); IF NOT (LEADING!-DEGREE T3 < LDEG T2) THEN ERRORF "PRS DOES NOT CONVERGE" END >>; ANS := MODULAR!-TIMES(TEMPANS, MODULAR!-EXPT(!*D2N T3,LDEG T2)); RETURN IF V=0 THEN ANS ELSE MODULAR!-MINUS ANS END; ENDMODULE; MODULE PFACTOR; % ******************************************************************* % % Copyright (C) University of Cambridge, England 1979 % % *******************************************************************; % factorization of polynomials modulo p % % a. c. norman. 1978. % % %**********************************************************************; SYMBOLIC PROCEDURE SIMPPFACTORIZE U; % q is a prefix form. convert to standard quotient, factorize, % return the factors in the array w. do all work mod p; BEGIN SCALAR Q,W,P,FF,NN,GCDSAV,BASE!-TIME,LAST!-DISPLAYED!-TIME, GC!-BASE!-TIME,LAST!-DISPLAYED!-GC!-TIME, USER!-PRIME,CURRENT!-MODULUS,MODULUS!/2; IF ATOM U OR ATOM CDR U OR ATOM CDDR U THEN REDERR "PFACTORIZE requires 3 arguments"; Q := CAR U; W := CADR U; P := CADDR U; SET!-TIME(); GCDSAV := !*GCD; !*GCD:=T; %gcd explicitly enabled during the following call to simp!*; Q:= SIMP!* Q; %convert to standard quotient; NN := !*Q2F Q; %must be a polynomial; P:=SIMP!* P; %should be a number; IF NOT (DENR P=1) THEN REDERR "P HAS A DENOMINATOR IN PFACTOR"; P:=NUMR P; IF NOT NUMBERP P THEN REDERR "P NOT A NUMBER IN PFACTOR"; IF NOT PRIMEP P THEN REDERR "P NOT PRIME IN PFACTOR"; USER!-PRIME:=P; SET!-MODULUS P; !*GCD:=GCDSAV; IF DOMAINP NN OR (REDUCE!-MOD!-P LC NN=NIL) THEN PRINTC "*** DEGENERATE CASE IN PFACTOR"; IF NOT (LENGTH VARIABLES!-IN!-FORM NN=1) THEN REDERR "MULTIVARIATE INPUT TO PFACTOR"; NN:=MONIC!-MOD!-P REDUCE!-MOD!-P NN; PRINT!-TIME "About to call FACTOR-FORM-MOD-P"; NN:=ERRORSET('(FACTOR!-FORM!-MOD!-P NN),T,T); PRINT!-TIME "FACTOR-FORM-MOD-P returned"; IF ERRORP NN THEN GO TO FAILED; NN:=CAR NN; FF:=0; %factor count; P:=LIST (0 . 1); FOR EACH FFF IN NN DO FOR I:=1:CDR FFF DO P:= ((FF:=FF+1) . MK!*SQ(CAR FFF ./ 1)) . P; RETURN MULTIPLE!-RESULT(P,W); FAILED: PRINTC "****** FACTORIZATION FAILED******"; RETURN MULTIPLE!-RESULT(LIST(1 . MK!*SQ Q),W) END; PUT('PFACTORIZE,'SIMPFN,'SIMPPFACTORIZE); SYMBOLIC PROCEDURE FACTOR!-FORM!-MOD!-P P; % input: % p is a reduce standard form that is to be factorized % mod prime; % result: % ((p1 . x1) (p2 . x2) .. (pn . xn)) % where p<i> are standard forms and x<i> are integers, % and p= product<i> p<i>**x<i>; SORT!-FACTORS FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P; SYMBOLIC PROCEDURE FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P; IF P=1 THEN NIL ELSE IF DOMAINP P THEN (P . 1) . NIL ELSE BEGIN SCALAR DP,V; V:=(MKSP(MVAR P,1).* 1) .+ NIL; DP:=0; WHILE EVALUATE!-MOD!-P(P,MVAR V,0)=0 DO << P:=QUOTFAIL!-MOD!-P(P,V); DP:=DP+1 >>; IF DP>0 THEN RETURN ((V . DP) . FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P); DP:=DERIVATIVE!-MOD!-P P; IF DP=NIL THEN << %here p is a something to the power current!-modulus; P:=DIVIDE!-EXPONENTS!-BY!-P(P,CURRENT!-MODULUS); P:=FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P P; RETURN MULTIPLY!-MULTIPLICITIES(P,CURRENT!-MODULUS) >>; DP:=GCD!-MOD!-P(P,DP); IF DP=1 THEN RETURN FACTORIZE!-PP!-MOD!-P P; %now p is not square-free; P:=QUOTFAIL!-MOD!-P(P,DP); %factorize p and dp separately; P:=FACTORIZE!-PP!-MOD!-P P; DP:=FACTORIZE!-BY!-SQUARE!-FREE!-MOD!-P DP; % i feel that this scheme is slightly clumsy, but % square-free decomposition mod p is not as straightforward % as square free decomposition over the integers, and pfactor % is probably not going to be slowed down too badly by % this; RETURN MERGEFACTORS(P,DP) END; %**********************************************************************; % code to factorize primitive square-free polynomials mod p; SYMBOLIC PROCEDURE DIVIDE!-EXPONENTS!-BY!-P(P,N); IF ISDOMAIN P THEN P ELSE (MKSP(MVAR P,EXACTQUOTIENT(LDEG P,N)) .* LC P) .+ DIVIDE!-EXPONENTS!-BY!-P(RED P,N); SYMBOLIC PROCEDURE EXACTQUOTIENT(A,B); BEGIN SCALAR W; W:=DIVIDE(A,B); IF CDR W=0 THEN RETURN CAR W; ERROR("INEXACT DIVISION",LIST(A,B,W)) END; SYMBOLIC PROCEDURE MULTIPLY!-MULTIPLICITIES(L,N); IF NULL L THEN NIL ELSE (CAAR L . (N*CDAR L)) . MULTIPLY!-MULTIPLICITIES(CDR L,N); SYMBOLIC PROCEDURE MERGEFACTORS(A,B); % a and b are lists of factors (with multiplicities), % merge them so that no factor occurs more than once in % the result; IF NULL A THEN B ELSE MERGEFACTORS(CDR A,ADDFACTOR(CAR A,B)); SYMBOLIC PROCEDURE ADDFACTOR(A,B); %add factor a into list b; IF NULL B THEN LIST A ELSE IF CAR A=CAAR B THEN (CAR A . (CDR A + CDAR B)) . CDR B ELSE CAR B . ADDFACTOR(A,CDR B); SYMBOLIC PROCEDURE FACTORIZE!-PP!-MOD!-P P; %input a primitive square-free polynomial p, % output a list of irreducible factors of p; BEGIN SCALAR VARS; IF P=1 THEN RETURN NIL ELSE IF ISDOMAIN P THEN RETURN (P . 1) . NIL; % now I am certain that p is not degenerate; PRINT!-TIME "primitive square-free case detected"; VARS:=VARIABLES!-IN!-FORM P; IF LENGTH VARS=1 THEN RETURN UNIFAC!-MOD!-P P; ERRORF "SHAMBLED IN PFACTOR - MULTIVARIATE CASE RESURFACED" END; SYMBOLIC PROCEDURE UNIFAC!-MOD!-P P; %input p a primitive square-free univariate polynomial %output a list of the factors of p over z mod p; BEGIN SCALAR MODULAR!-INFO,M!-IMAGE!-VARIABLE; IF ISDOMAIN P THEN RETURN NIL ELSE IF LDEG P=1 THEN RETURN (P . 1) . NIL; MODULAR!-INFO:=MKVECT 1; M!-IMAGE!-VARIABLE:=MVAR P; GET!-FACTOR!-COUNT!-MOD!-P(1,P,USER!-PRIME,NIL); PRINT!-TIME "Factor counts obtained"; GET!-FACTORS!-MOD!-P(1,USER!-PRIME); PRINT!-TIME "Actual factors extracted"; RETURN FOR EACH Z IN GETV(MODULAR!-INFO,1) COLLECT (Z . 1) END; ENDMODULE; MODULE PRES; % part of resultant program; SYMBOLIC PROCEDURE RESULTANTF(A,B,X); % returns resultant of A,B wrt X; BEGIN SCALAR C, NEW!-A, NEW!-B, NEW!-C, PRIMES!-USED, LOOP!-COUNT, ORDER!-CHANGE; INTEGER M, N, D, E, Q, F, OLD!-MODULUS, NEW!-PRIME; IF (NULL A OR NULL B) THEN ERRORF "NIL POLYNOMIAL PASSED TO RESULTANTF"; IF NOT (MEMBER(X,VARIABLES!-IN!-FORM A) AND MEMBER(X,VARIABLES!-IN!-FORM B)) THEN ERRORF "X MUST OCCUR IN BOTH POLYNOMIALS INPUT TO RESULTANTF"; % X must be in both polynomials if it is to be eliminated % between them; ORDER!-CHANGE := NIL; % pseudo-boolean, indicates whether the order of % the variables has been changed; % check X is the main variable of A and B, if not make it so; IF NOT ((X=MVAR A) AND (X=MVAR B)) THEN BEGIN SCALAR V; V := SETKORDER APPEND(CONS(X,NIL), DELETE(X,UNION(VARIABLES!-IN!-FORM A, VARIABLES!-IN!-FORM B))); A := REORDER A; B := REORDER B; ORDER!-CHANGE := LIST V END; % initialise variables ; OLD!-MODULUS := SET!-MODULUS NIL; M := LDEG A; N := LDEG B; D := MAX!-NORM!-COEFFS(A,X); E := MAX!-NORM!-COEFFS(B,X); Q := 1; C := 0; PRIMES!-USED := NIL; % list of primes used - dont want repetitions; NEW!-A := 0; NEW!-B := 0; F := 2 * FACTORIAL(M+N) * D**N * E**M; % F/2 is the limit of the coefficients of the resultant of A,B ; % main loop starts here; WHILE NOT (Q > F) DO BEGIN LOOP!-COUNT := T; % used as a pseudo-boolean; WHILE ((DEGREE!-IN!-VARIABLE(NEW!-A,X) < M) OR (DEGREE!-IN!-VARIABLE(NEW!-B,X) < N) OR LOOP!-COUNT ) DO BEGIN LOOP!-COUNT := NIL; % set up prime modulus before calling cpres ; NEW!-PRIME := RANDOM!-PRIME(); WHILE MEMBER(NEW!-PRIME,PRIMES!-USED) DO NEW!-PRIME := RANDOM!-PRIME(); PRIMES!-USED := NEW!-PRIME . PRIMES!-USED; SET!-MODULUS NEW!-PRIME; NEW!-A := REDUCE!-MOD!-P A; NEW!-B := REDUCE!-MOD!-P B END; NEW!-C := CPRES(NEW!-A,NEW!-B,X); C := CHINESE!-REMAINDER(C,NEW!-C,Q,NEW!-PRIME); Q := Q * NEW!-PRIME; IF 2* GET!-HEIGHT C > F THEN ERRORF "COEFFICIENT BOUND EXCEEDED" END; IF ORDER!-CHANGE THEN BEGIN SETKORDER CAR ORDER!-CHANGE; C := REORDER C END; SET!-MODULUS OLD!-MODULUS; %return to original state before exiting; RETURN C END; SYMBOLIC PROCEDURE MAX!-NORM!-COEFFS(A,VAR); % var must be the main variable of A; IF ISDOMAIN A THEN ABS !*D2N A ELSE IF NOT MVAR A = VAR THEN SUM!-OF!-NORMS A ELSE MAX(SUM!-OF!-NORMS LC A,MAX!-NORM!-COEFFS(RED A,VAR)); SYMBOLIC PROCEDURE SUM!-OF!-NORMS A; IF ISDOMAIN A THEN ABS !*D2N A ELSE PLUS(SUM!-OF!-NORMS LC A,SUM!-OF!-NORMS RED A); SYMBOLIC PROCEDURE CHINESE!-REMAINDER(POLY!-B,POLY!-A,Q,P); % poly!-b is a poly with !coeffs! < Q/2 ; % poly!-a is a poly mod p ; % returns a poly with !coeffs! < PQ/2 ; IF ISDOMAIN POLY!-A THEN IF ISDOMAIN POLY!-B THEN GARNERS!-ALG(!*D2N POLY!-B,!*D2N POLY!-A,Q,P) ELSE ADJOIN!-TERM(LPOW POLY!-B, CHINESE!-REMAINDER(LC POLY!-B,0,Q,P), CHINESE!-REMAINDER(RED POLY!-B,POLY!-A,Q,P)) ELSE IF ISDOMAIN POLY!-B THEN ADJOIN!-TERM(LPOW POLY!-A, CHINESE!-REMAINDER(0,LC POLY!-A,Q,P), CHINESE!-REMAINDER(POLY!-B,RED POLY!-A,Q,P)) ELSE IF LPOW POLY!-A = LPOW POLY!-B THEN ADJOIN!-TERM(LPOW POLY!-A, CHINESE!-REMAINDER(LC POLY!-B,LC POLY!-A,Q,P), CHINESE!-REMAINDER(RED POLY!-B,RED POLY!-A,Q,P)) ELSE IF COMES!-BEFORE(LPOW POLY!-A,LPOW POLY!-B) THEN ADJOIN!-TERM(LPOW POLY!-A, CHINESE!-REMAINDER(0,LC POLY!-A,Q,P), CHINESE!-REMAINDER(POLY!-B,RED POLY!-A,Q,P)) ELSE ADJOIN!-TERM(LPOW POLY!-B, CHINESE!-REMAINDER(LC POLY!-B,0,Q,P), CHINESE!-REMAINDER(RED POLY!-B,POLY!-A,Q,P)); SYMBOLIC PROCEDURE GARNERS!-ALG(B,A,Q,P); % inputs !B! < Q/2, A mod P ; % returns unique integer c such that c = B mod Q and c = A modP; % and !c! < PQ/2 ; BEGIN INTEGER L; L := MODULAR!-QUOTIENT(MODULAR!-DIFFERENCE(A,MODULAR!-NUMBER B), MODULAR!-NUMBER Q); IF L*2 > P THEN L := DIFFERENCE(L,P); % PRINTC "L IS"; % SUPERPRINT L; RETURN !*NUM2F PLUS(B,TIMES(L,Q)) END; SYMBOLIC PROCEDURE LEADING!-DEGREE A; % returns 0 if a is numeric, ldeg a otherwise; IF ISDOMAIN A THEN 0 ELSE LDEG A; SYMBOLIC PROCEDURE FACTORIAL N; IF NOT ISDOMAIN N THEN ERRORF "NUMBER EXPECTED IN FACTORIAL" ELSE IF N < 0 THEN ERRORF "NEGATIVE NUMBER GIVEN TO FACTORIAL" ELSE IF N = 0 THEN 1 ELSE N * FACTORIAL(N-1); ENDMODULE; MODULE RSLTNT; % (C) Copyright 1979, University of Cambridge; % RESULTANT CALCULATION; SYMBOLIC PROCEDURE SIMPRESULTANT U; % COMPUTE THE RESULTANT OF A AND B WITH RESPECT TO % THE VARIABLE 'VAR'; BEGIN SCALAR A,B,VAR; IF ATOM U OR ATOM CDR U OR ATOM CDDR U THEN REDERR "RESULTANT requires 3 arguments"; A:= !*Q2F SIMP!* CAR U; %must be polynomials; B:= !*Q2F SIMP!* CADR U; VAR:= !*Q2K SIMP!* CADDR U; % PRINTC "LISP DATASTRUCTURES THAT ARE ARGS FOR RESULTANT"; % SUPERPRINT A; % SUPERPRINT B; % SUPERPRINT VAR; A := RESULTANTF(A,B,VAR); RETURN (A ./ 1); END; PUT('RESULTANT,'SIMPFN,'SIMPRESULTANT); ENDMODULE; MODULE UNIHENS; % ******************************************************************* % % copyright (c) university of cambridge, england 1981 % % *******************************************************************; % new hensel construction and related code ; % - univariate case with quadratic growth; % % p. m. a. moore. 1979. % % %**********************************************************************; SYMBOLIC PROCEDURE UHENSEL!.EXTEND(POLY,BEST!-FLIST,LCLIST,P); % extend poly=product(factors in best!-flist) mod p % even if poly is non-monic. return a list (ok. list of factors) if % factors can be extended to be correct over the integers, % otherwise return a list (failed <reason> <reason>); BEGIN SCALAR W,K,TIMER,OLD!-MODULUS,ALPHAVEC,MODULAR!-FLIST,FACTORVEC, MODFVEC,COEFFTBD,FCOUNT,FHATVEC,DELTAM,MOD!-SYMM!-FLIST, CURRENT!-FACTOR!-PRODUCT,FACVEC,FACTORS!-DONE,HENSEL!-POLY; PRIME!-BASE:=P; OLD!-MODULUS:=SET!-MODULUS P; TIMER:=READTIME(); NUMBER!-OF!-FACTORS:=LENGTH BEST!-FLIST; W:=EXPT(LC POLY,NUMBER!-OF!-FACTORS -1); IF LC POLY < 0 THEN ERRORF LIST("LC SHOULD NOT BE -VE",POLY); COEFFTBD:=MAX(110,LC POLY*GET!-COEFFT!-BOUND(POLY,LDEG POLY)); POLY:=MULTF(POLY,W); MODULAR!-FLIST:=FOR EACH FF IN BEST!-FLIST COLLECT REDUCE!-MOD!-P FF; % modular factors have been multiplied by a constant to % fix the l.c.'s, so they may be out of range - this % fixes that; IF NOT(W=1) THEN FACTOR!-TRACE << PRIN2!* "Altered univariate polynomial: "; FAC!-PRINTSF POLY >>; % make sure the leading coefft will not cause trouble % in the hensel construction; MOD!-SYMM!-FLIST:=FOR EACH FF IN MODULAR!-FLIST COLLECT MAKE!-MODULAR!-SYMMETRIC FF; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRIN2!* "The factors mod "; PRIN2!* P; PRINTSTR " to start from are:"; FCOUNT:=1; FOR EACH FF IN MOD!-SYMM!-FLIST DO << PRIN2!* " f("; PRIN2!* FCOUNT; PRIN2!* ")="; FAC!-PRINTSF FF; FCOUNT:=IADD1 FCOUNT >>; TERPRI!*(NIL) >>; ALPHALIST:=ALPHAS(NUMBER!-OF!-FACTORS,MODULAR!-FLIST,1); % 'magic' polynomials associated with the image factors; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "The following modular polynomials are chosen such that:"; TERPRI(); PRIN2!* " a(1)*h(1) + ... + a("; PRIN2!* NUMBER!-OF!-FACTORS; PRIN2!* ")*h("; PRIN2!* NUMBER!-OF!-FACTORS; PRIN2!* ") = 1 mod "; PRINTSTR P; TERPRI(); PRINTSTR " where h(i)=(product of all f(j) [see below])/f(i)"; PRINTSTR " and degree of a(i) < degree of f(i)."; FCOUNT:=1; FOR EACH A IN MODULAR!-FLIST DO << PRIN2!* " a("; PRIN2!* FCOUNT; PRIN2!* ")="; FAC!-PRINTSF CDR GET!-ALPHA A; PRIN2!* " f("; PRIN2!* FCOUNT; PRIN2!* ")="; FAC!-PRINTSF A; FCOUNT:=IADD1 FCOUNT >> >>; K:=0; FACTORVEC:=MKVECT NUMBER!-OF!-FACTORS; MODFVEC:=MKVECT NUMBER!-OF!-FACTORS; ALPHAVEC:=MKVECT NUMBER!-OF!-FACTORS; FOR EACH MODSYMMF IN MOD!-SYMM!-FLIST DO << PUTV(FACTORVEC,K:=K+1,FORCE!-LC(MODSYMMF,CAR LCLIST)); LCLIST:=CDR LCLIST >>; K:=0; FOR EACH MODFACTOR IN MODULAR!-FLIST DO << PUTV(MODFVEC,K:=K+1,MODFACTOR); PUTV(ALPHAVEC,K,CDR GET!-ALPHA MODFACTOR); >>; % best!-fvec is now a vector of factors of poly correct % mod p with true l.c.s forced in ; FHATVEC:=MKVECT NUMBER!-OF!-FACTORS; W:=HENSEL!-MOD!-P(POLY,MODFVEC,FACTORVEC,COEFFTBD,NIL,P); IF CAR W='OVERSHOT THEN BEGIN SCALAR OKLIST,BADLIST,M,R,FF,OM,POL; M:=CADR W; % the modulus; R:=GETV(FACTORVEC,0); % the no: of factors; IF R=2 THEN RETURN (IRREDUCIBLE:=T); IF FACTORS!-DONE THEN << POLY:=HENSEL!-POLY; FOR EACH WW IN FACTORS!-DONE DO POLY:=MULTF(POLY,WW) >>; POL:=POLY; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; ALPHALIST:=NIL; FOR I:=R STEP -1 UNTIL 1 DO ALPHALIST:= (REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I)) . ALPHALIST; SET!-MODULUS OM; % bring alphalist up to date; FOR I:=1:R DO << FF:=GETV(FACTORVEC,I); IF NOT DIDNTGO(W:=QUOTF(POL,FF)) THEN << OKLIST:=FF . OKLIST; POL:=W>> ELSE BADLIST:=(I . FF) . BADLIST >>; IF NULL BADLIST THEN W:='OK . OKLIST ELSE << IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "Overshot factors are:"; FOR EACH F IN BADLIST DO << PRIN2!* " f("; PRIN2!* CAR F; PRIN2!* ")="; FAC!-PRINTSF CDR F >> >>; W:=TRY!.COMBINING(BADLIST,POL,M,NIL); IF CAR W='ONE! BAD! FACTOR THEN BEGIN SCALAR X; W:=APPEND(OKLIST,CDR W); X:=1; FOR EACH V IN W DO X:=MULTF(X,V); W:='OK . (QUOTFAIL(POL,X) . W) END ELSE W:='OK . APPEND(OKLIST,W) >>; IF (NOT !*LINEAR) AND MULTIVARIATE!-INPUT!-POLY THEN << POLY:=1; NUMBER!-OF!-FACTORS:=0; FOR EACH FACC IN CDR W DO << POLY:=MULTF(POLY,FACC); NUMBER!-OF!-FACTORS:=1 #+ NUMBER!-OF!-FACTORS >>; % make sure poly is the product of the factors we have, % we recalculate it this way because we may have the wrong % lc in old value of poly; RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,CDR W, NUMBER!-OF!-FACTORS); IF M=DELTAM THEN ERRORF LIST("Coefft bound < prime ?", COEFFTBD,M); M:=DELTAM*DELTAM; WHILE M<LARGEST!-SMALL!-MODULUS DO << QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS); M:=M*DELTAM >>; HENSEL!-GROWTH!-SIZE:=DELTAM; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; ALPHALIST:=NIL; FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO ALPHALIST:= (REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I)) . ALPHALIST; SET!-MODULUS OM >> END ELSE BEGIN SCALAR R,FACLIST,OM; R:=GETV(FACTORVEC,0); % no of factors; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; ALPHALIST:=NIL; FOR I:=R STEP -1 UNTIL 1 DO ALPHALIST:=(REDUCE!-MOD!-P GETV(FACTORVEC,I) . GETV(ALPHAVEC,I)) . ALPHALIST; SET!-MODULUS OM; % bring alphalist up to date; FOR I:=R STEP -1 UNTIL 1 DO FACLIST:=GETV(FACTORVEC,I) . FACLIST; W:=CAR W . FACLIST END; SET!-MODULUS OLD!-MODULUS; FACTOR!-TRACE BEGIN SCALAR K; K:=0; PRINTSTR "Univariate factors, possibly with adjusted leading"; PRINTSTR "coefficients, are:"; FOR EACH WW IN CDR W DO << PRIN2!* " f("; PRIN2!* (K:=K #+ 1); PRIN2!* ")="; FAC!-PRINTSF WW >> END; RETURN IF IRREDUCIBLE THEN T ELSE IF NON!-MONIC THEN (CAR W . PRIMITIVE!.PARTS(CDR W,M!-IMAGE!-VARIABLE,T)) ELSE W END; SYMBOLIC PROCEDURE GET!-COEFFT!-BOUND(POLY,DDEG); % this uses Mignottes bound which is minimal I believe; % NB. poly had better be univariate as bound only valid for this; BINOMIAL!-COEFFT(DDEG/2,DDEG/4) * ROOT!-SQUARES(POLY,0); SYMBOLIC PROCEDURE BINOMIAL!-COEFFT(N,R); IF N<R THEN NIL ELSE IF N=R THEN 1 ELSE IF R=1 THEN N ELSE BEGIN SCALAR N!-C!-R,B; N!-C!-R:=1; B:=MIN(R,N-R); FOR I:=1:B DO N!-C!-R:=(N!-C!-R * (N - I + 1)) / I; RETURN N!-C!-R END; SYMBOLIC PROCEDURE PMAM!-SQRT N; % find the square root of n and return integer part + 1; % n is fixed pt on input as it may be very large ie > largest % allowed floating pt number so i scale it appropriately; BEGIN SCALAR S,TEN!*!*14,TEN!*!*12; S:=0; TEN!*!*12:=10**12; TEN!*!*14:=100*TEN!*!*12; WHILE N>TEN!*!*14 DO << S:=IADD1 S; N:=1+N/TEN!*!*12 >>; RETURN ((FIX SQRT FLOAT N) + 1) * 10**(6*S) END; SYMBOLIC PROCEDURE FIND!-ALPHAS!-IN!-A!-RING(N,MFLIST,FHATLIST,GAMMA); % find the alphas (as below) given that the modulus may not be prime % but is a prime power.; BEGIN SCALAR GG,M,PPOW,I,GG!-MOD!-P,MODFLIST,WVEC,ALPHA,ALPHAZEROS,W; IF NULL PRIME!-BASE THEN ERRORF LIST("Prime base not set for finding alphas", CURRENT!-MODULUS,N,MFLIST); M:=SET!-MODULUS PRIME!-BASE; MODFLIST:= IF M=PRIME!-BASE THEN MFLIST ELSE FOR EACH FTHING IN MFLIST COLLECT REDUCE!-MOD!-P !*MOD2F FTHING; ALPHALIST:=ALPHAS(N,MODFLIST,GAMMA); IF M=PRIME!-BASE THEN << SET!-MODULUS M; RETURN ALPHALIST >>; I:=0; ALPHAZEROS:=MKVECT N; WVEC:=MKVECT N; FOR EACH MODFTHING IN MODFLIST DO << PUTV(MODFVEC,I:=IADD1 I,MODFTHING); PUTV(ALPHAVEC,I,!*F2MOD(ALPHA:=CDR GET!-ALPHA MODFTHING)); PUTV(ALPHAZEROS,I,ALPHA); PUTV(WVEC,I,ALPHA); PUTV(FHATVEC,I,CAR FHATLIST); FHATLIST:=CDR FHATLIST >>; GG:=GAMMA; PPOW:=PRIME!-BASE; WHILE PPOW<M DO << SET!-MODULUS M; GG:=!*F2MOD QUOTFAIL(!*MOD2F DIFFERENCE!-MOD!-P(GG, FORM!-SUM!-AND!-PRODUCT!-MOD!-M(WVEC,FHATVEC,N)),PRIME!-BASE); SET!-MODULUS PRIME!-BASE; GG!-MOD!-P:=REDUCE!-MOD!-P !*MOD2F GG; FOR K:=1:N DO << PUTV(WVEC,K,W:=REMAINDER!-MOD!-P( TIMES!-MOD!-P(GETV(ALPHAZEROS,K),GG!-MOD!-P), GETV(MODFVEC,K))); PUTV(ALPHAVEC,K,ADDF(GETV(ALPHAVEC,K),MULTF(!*MOD2F W,PPOW)))>>; PPOW:=PPOW*PRIME!-BASE >>; SET!-MODULUS M; I:=0; RETURN (FOR EACH FTHING IN MFLIST COLLECT (FTHING . !*F2MOD GETV(ALPHAVEC,I:=IADD1 I))) END; SYMBOLIC PROCEDURE ALPHAS(N,FLIST,GAMMA); % finds alpha,beta,delta,... wrt factors f(i) in flist s.t: % alpha*g(1) + beta*g(2) + delta*g(3) + ... = gamma mod p; % where g(i)=product(all the f(j) except f(i) itself); % (cf. xgcd!-mod!-p below). n is number of factors in flist; IF N=1 THEN LIST(CAR FLIST . GAMMA) ELSE BEGIN SCALAR K,W,F1,F2,I,GAMMA1,GAMMA2; K:=N/2; F1:=1; F2:=1; I:=1; FOR EACH F IN FLIST DO << IF I>K THEN F2:=TIMES!-MOD!-P(F,F2) ELSE F1:=TIMES!-MOD!-P(F,F1); I:=I+1 >>; W:=XGCD!-MOD!-P(F1,F2,1,POLYZERO,POLYZERO,1); IF ATOM W THEN RETURN 'FACTORS! NOT! COPRIME; GAMMA1:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(CDR W,GAMMA),F1); GAMMA2:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(CAR W,GAMMA),F2); I:=1; F1:=NIL; F2:=NIL; FOR EACH F IN FLIST DO << IF I>K THEN F2:=F . F2 ELSE F1:=F . F1; I:=I+1 >>; RETURN APPEND( ALPHAS(K,F1,GAMMA1), ALPHAS(N-K,F2,GAMMA2)) END; SYMBOLIC PROCEDURE XGCD!-MOD!-P(A,B,X1,Y1,X2,Y2); % finds alpha and beta s.t. alpha*a+beta*b=1; % returns alpha . beta or nil if a and b are not coprime; IF NULL B THEN NIL ELSE IF ISDOMAIN B THEN BEGIN B:=MODULAR!-RECIPROCAL B; X2:=MULTIPLY!-BY!-CONSTANT!-MOD!-P(X2,B); Y2:=MULTIPLY!-BY!-CONSTANT!-MOD!-P(Y2,B); RETURN X2 . Y2 END ELSE BEGIN SCALAR Q; Q:=QUOTIENT!-MOD!-P(A,B); % Truncated quotient here; RETURN XGCD!-MOD!-P(B,DIFFERENCE!-MOD!-P(A,TIMES!-MOD!-P(B,Q)), X2,Y2, DIFFERENCE!-MOD!-P(X1,TIMES!-MOD!-P(X2,Q)), DIFFERENCE!-MOD!-P(Y1,TIMES!-MOD!-P(Y2,Q))) END; SYMBOLIC PROCEDURE HENSEL!-MOD!-P(POLY,MVEC,FVEC,CBD,VSET,P); % hensel construction building up in powers of p; % given that poly=product(factors in factorvec) mod p, find the full % factors over the integers. mvec contains the univariate factors mod p % while fvec contains our best knowledge of the factors to date. % fvec includes leading coeffts (and in multivariate case possibly other % coeffts) of the factors. return a list whose first element is a flag % with one of the following values: % ok construction worked, the cdr of the result is a list of % the correct factors.; % failed inputs must have been incorrect % overshot factors are correct mod some power of p (say p**m), % but are not correct over the integers. % result is (overshot,p**m,list of factors so far); BEGIN SCALAR W,U0,DELFVEC,OLD!.MOD,RES,M; U0:=INITIALIZE!-HENSEL(NUMBER!-OF!-FACTORS,P,POLY,MVEC,FVEC,CBD); % u0 contains the product (over integers) of factors mod p; IF NUMBER!-OF!-FACTORS=1 THEN GOTO EXIT; % only one factor to grow! but need to go this deep to % construct the alphas and set things up for the % multivariate growth which may follow; FACTOR!-TRACE << PRINTSTR "We are now ready to use the Hensel construction to grow"; PRIN2!* "in powers of "; PRINTSTR CURRENT!-MODULUS; IF NOT !*OVERVIEW THEN <<PRIN2!* "Polynomial to factor (=U): "; FAC!-PRINTSF HENSEL!-POLY>>; PRIN2!* "Initial factors mod "; PRIN2!* P; PRINTSTR " with some correct coefficients:"; W:=1; FOR I:=1:NUMBER!-OF!-FACTORS DO << PRIN2!* " f("; PRIN2!* W; PRIN2!* ")="; FAC!-PRINTSF GETV(FACTORVEC,I); W:=IADD1 W >>; IF NOT !*OVERVIEW THEN << PRIN2!* "Coefficient bound = "; PRIN2!* COEFFTBD; TERPRI!*(NIL); PRIN2!* "The product of factors over the integers is "; FAC!-PRINTSF U0; PRINTSTR "In each step below, the residue is U - (product of the"; PRINTSTR "factors as far as we know them). The correction to each"; PRINTSTR "factor, f(i), is (a(i)*v) mod f0(i) where f0(i) is"; PRIN2!* "f(i) mod "; PRIN2!* P; PRINTSTR "(ie. the f(i) used in calculating the a(i))" >> >>; OLD!.MOD:=SET!-MODULUS P; RES:=ADDF(HENSEL!-POLY,NEGF U0); % calculate the residue. from now on this is always % kept in res; M:=P; % measure of how far we have built up factors - at this; % stage we know the constant terms mod p in the factors; WHILE NOT POLYZEROP RES DO << IF (M/2)>COEFFTBD THEN RETURN << % we started with a false split of the image so some % of the factors we have built up must amalgamate in % the complete factorization; IF !*OVERSHOOT THEN << PRINC IF NULL VSET THEN "Univariate " ELSE "Multivariate "; PRINTC "coefft bound overshoot" >>; IF NOT !*OVERVIEW THEN FACTOR!-TRACE PRINTSTR "We have overshot the coefficient bound"; W:='OVERSHOT >>; RES:=QUOTFAIL(RES,DELTAM); % next term in residue; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRIN2!* "Residue divided by "; PRIN2!* M; PRIN2!* " is "; FAC!-PRINTSF RES >>; IF (NOT !*LINEAR) AND NULL VSET AND M<=LARGEST!-SMALL!-MODULUS AND M>P THEN QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS); W:=REDUCE!-MOD!-P RES; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRIN2!* "Next term in residue to kill is:"; PRINSF W; PRIN2!* " which is of size "; FAC!-PRINTSF (DELTAM*M); >>; SOLVE!-FOR!-CORRECTIONS(W,FHATVEC,MODFVEC,DELFVEC,VSET); % delfvec is vector of next correction terms to factors; MAKE!-VEC!-MODULAR!-SYMMETRIC(DELFVEC,NUMBER!-OF!-FACTORS); IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "Correction terms are:"; W:=1; FOR I:=1:NUMBER!-OF!-FACTORS DO << PRIN2!* " To f("; PRIN2!* W; PRIN2!* "): "; FAC!-PRINTSF MULTF(M,GETV(DELFVEC,I)); W:=IADD1 W >> >>; W:=TERMS!-DONE(FACTORVEC,DELFVEC,M); RES:=ADDF(RES,NEGF W); % subtract out the terms generated by these corrections % from the residue; CURRENT!-FACTOR!-PRODUCT:= ADDF(CURRENT!-FACTOR!-PRODUCT,MULTF(M,W)); % add in the correction terms to give new factor product; FOR I:=1:NUMBER!-OF!-FACTORS DO PUTV(FACTORVEC,I, ADDF(GETV(FACTORVEC,I),MULTF(GETV(DELFVEC,I),M))); % add the corrections into the factors; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR " giving new factors as:"; W:=1; FOR I:=1:NUMBER!-OF!-FACTORS DO << PRIN2!* " f("; PRIN2!* W; PRIN2!* ")="; FAC!-PRINTSF GETV(FACTORVEC,I); W:=IADD1 W >> >>; M:=M*DELTAM; IF NOT POLYZEROP RES AND NULL VSET AND NOT RECONSTRUCTING!-GCD THEN BEGIN SCALAR J,U,FAC; J:=0; WHILE (J:=J #+ 1)<=NUMBER!-OF!-FACTORS DO % IF NULL GETV(DELFVEC,J) AND; % - Try dividing out every time for now; IF NOT DIDNTGO (U:=QUOTF(HENSEL!-POLY,FAC:=GETV(FACTORVEC,J))) THEN << HENSEL!-POLY:=U; RES:=ADJUST!-GROWTH(FAC,J,M); J:=NUMBER!-OF!-FACTORS >> END >>; EXIT: IF FACTORS!-DONE THEN << IF NOT(W='OVERSHOT) THEN M:=P*P; SET!-HENSEL!-FLUIDS!-BACK P >>; IF (NOT (W='OVERSHOT)) AND NULL VSET AND (NOT !*LINEAR) AND MULTIVARIATE!-INPUT!-POLY THEN WHILE M<LARGEST!-SMALL!-MODULUS DO << IF NOT(M=DELTAM) THEN QUADRATIC!-STEP(M,NUMBER!-OF!-FACTORS); M:=M*DELTAM >>; % set up the alphas etc so that multivariate growth can % use a hensel growth size of about word size; SET!-MODULUS OLD!.MOD; % reset the old modulus; HENSEL!-GROWTH!-SIZE:=DELTAM; PUTV(FACTORVEC,0,NUMBER!-OF!-FACTORS); RETURN IF W='OVERSHOT THEN LIST('OVERSHOT,M,FACTORVEC) ELSE 'OK . FACTORVEC END; SYMBOLIC PROCEDURE INITIALIZE!-HENSEL(R,P,POLY,MVEC,FVEC,CBD); % set up the vectors and initialize the fluids; BEGIN SCALAR U0,W; DELFVEC:=MKVECT R; FACVEC:=MKVECT R; HENSEL!-POLY:=POLY; MODFVEC:=MVEC; FACTORVEC:=FVEC; COEFFTBD:=CBD; FACTORS!-DONE:=NIL; DELTAM:=P; U0:=1; FOR I:=1:R DO U0:=MULTF(GETV(FACTORVEC,I),U0); CURRENT!-FACTOR!-PRODUCT:=U0; RETURN U0 END; % SYMBOLIC PROCEDURE RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,FACLIST,N); % BEGIN SCALAR I,OM,MODF; % CURRENT!-FACTOR!-PRODUCT:=POLY; % OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; % I:=0; % FOR EACH FAC IN FACLIST DO << % PUTV(FACTORVEC,I:=IADD1 I,FAC); % PUTV(MODFVEC,I,MODF:=REDUCE!-MOD!-P FAC); % PUTV(ALPHAVEC,I,CDR GET!-ALPHA MODF) >>; % FOR I:=1:N DO << % PRINC "f("; % PRINC I; % PRINC ") = "; % FAC!-PRINTSF GETV(FACTORVEC,I); % PRINC "f("; % PRINC I; % PRINC ") mod p = "; % FAC!-PRINTSF GETV(MODFVEC,I); % PRINC "a("; % PRINC I; % PRINC ") = "; % FAC!-PRINTSF GETV(ALPHAVEC,I) >>; % SET!-MODULUS OM % END; SYMBOLIC PROCEDURE RESET!-QUADRATIC!-STEP!-FLUIDS(POLY,FACLIST,N); BEGIN SCALAR I,OM,FACPAIRLIST,CFP!-MOD!-P,FHATLIST; CURRENT!-FACTOR!-PRODUCT:=POLY; OM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; CFP!-MOD!-P:=REDUCE!-MOD!-P CURRENT!-FACTOR!-PRODUCT; I:=0; FACPAIRLIST:=FOR EACH FAC IN FACLIST COLLECT << I:= I #+ 1; (FAC . REDUCE!-MOD!-P FAC) >>; FHATLIST:=FOR EACH FACC IN FACPAIRLIST COLLECT QUOTFAIL!-MOD!-P(CFP!-MOD!-P,CDR FACC); IF FACTORS!-DONE THEN ALPHALIST:= FIND!-ALPHAS!-IN!-A!-RING(I, FOR EACH FACPR IN FACPAIRLIST COLLECT CDR FACPR, FHATLIST,1); % a bug has surfaced such that the alphas get out of step % in this case so recalculate them to stop the error for now; I:=0; FOR EACH FACPAIR IN FACPAIRLIST DO << PUTV(FACTORVEC,I:=IADD1 I,CAR FACPAIR); PUTV(MODFVEC,I,CDR FACPAIR); PUTV(ALPHAVEC,I,CDR GET!-ALPHA CDR FACPAIR) >>; % FOR I:=1:N DO << % PRINC "f("; % PRINC I; % PRINC ") = "; % FAC!-PRINTSF GETV(FACTORVEC,I); % PRINC "f("; % PRINC I; % PRINC ") mod p = "; % FAC!-PRINTSF GETV(MODFVEC,I); % PRINC "a("; % PRINC I; % PRINC ") = "; % FAC!-PRINTSF GETV(ALPHAVEC,I) >>; SET!-MODULUS OM END; SYMBOLIC PROCEDURE QUADRATIC!-STEP(M,R); % code for adjusting the hensel variables to take quadratic % steps in the growing process; BEGIN SCALAR W,S,CFP!-MOD!-P; SET!-MODULUS M; CFP!-MOD!-P:=REDUCE!-MOD!-P CURRENT!-FACTOR!-PRODUCT; FOR I:=1:R DO PUTV(FACVEC,I,REDUCE!-MOD!-P GETV(FACTORVEC,I)); FOR I:=1:R DO PUTV(FHATVEC,I, QUOTFAIL!-MOD!-P(CFP!-MOD!-P,GETV(FACVEC,I))); W:=FORM!-SUM!-AND!-PRODUCT!-MOD!-M(ALPHAVEC,FHATVEC,R); W:=!*MOD2F PLUS!-MOD!-P(1,MINUS!-MOD!-P W); S:=QUOTFAIL(W,DELTAM); SET!-MODULUS DELTAM; S:=!*F2MOD S; % Boxes S up to look like a poly mod deltam; FOR I:=1:R DO << W:=REMAINDER!-MOD!-P(TIMES!-MOD!-P(S,GETV(ALPHAVEC,I)), GETV(MODFVEC,I)); PUTV(ALPHAVEC,I, ADDF(!*MOD2F GETV(ALPHAVEC,I),MULTF(!*MOD2F W,DELTAM))) >>; S:=MODFVEC; MODFVEC:=FACVEC; FACVEC:=S; DELTAM:=M; % this is our new growth rate; SET!-MODULUS DELTAM; FOR I:=1:R DO << PUTV(FACVEC,I,"RUBBISH"); % we will want to overwrite facvec next time so we % had better point it to the old (no longer needed) % modvec. Also mark it as containing rubbish for safety; PUTV(ALPHAVEC,I,!*F2MOD GETV(ALPHAVEC,I)) >>; % Make sure the alphas are boxed up as being mod new deltam; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "The new modular polynomials are chosen such that:"; TERPRI(); PRIN2!* " a(1)*h(1) + ... + a("; PRIN2!* R; PRIN2!* ")*h("; PRIN2!* R; PRIN2!* ") = 1 mod "; PRINTSTR M; TERPRI(); PRINTSTR " where h(i)=(product of all f(j) [see below])/f(i)"; PRINTSTR " and degree of a(i) < degree of f(i)."; FOR I:=1:R DO << PRIN2!* " a("; PRIN2!* I; PRIN2!* ")="; FAC!-PRINTSF GETV(ALPHAVEC,I); PRIN2!* " f("; PRIN2!* I; PRIN2!* ")="; FAC!-PRINTSF GETV(MODFVEC,I) >> >> END; SYMBOLIC PROCEDURE TERMS!-DONE(FVEC,DELFVEC,M); BEGIN SCALAR FLIST,DELFLIST; FOR I:=1:NUMBER!-OF!-FACTORS DO << FLIST:=GETV(FVEC,I) . FLIST; DELFLIST:=GETV(DELFVEC,I) . DELFLIST >>; RETURN TERMS!.DONE(NUMBER!-OF!-FACTORS,FLIST,DELFLIST, NUMBER!-OF!-FACTORS,M) END; SYMBOLIC PROCEDURE TERMS!.DONE(N,FLIST,DELFLIST,R,M); IF N=1 THEN (CAR FLIST) . (CAR DELFLIST) ELSE BEGIN SCALAR K,I,F1,F2,DELF1,DELF2; K:=N/2; I:=1; FOR EACH F IN FLIST DO << IF I>K THEN F2:=(F . F2) ELSE F1:=(F . F1); I:=I+1 >>; I:=1; FOR EACH DELF IN DELFLIST DO << IF I>K THEN DELF2:=(DELF . DELF2) ELSE DELF1:=(DELF . DELF1); I:=I+1 >>; F1:=TERMS!.DONE(K,F1,DELF1,R,M); DELF1:=CDR F1; F1:=CAR F1; F2:=TERMS!.DONE(N-K,F2,DELF2,R,M); DELF2:=CDR F2; F2:=CAR F2; DELF1:= ADDF(ADDF( MULTF(F1,DELF2), MULTF(F2,DELF1)), MULTF(MULTF(DELF1,M),DELF2)); IF N=R THEN RETURN DELF1; RETURN (MULTF(F1,F2) . DELF1) END; SYMBOLIC PROCEDURE TRY!.COMBINING(L,POLY,M,SOFAR); % l is a list of factors, f(i), s.t. (product of the f(i) mod m) = poly % but no f(i) divides poly over the integers. we find the combinations % of the f(i) that yield the true factors of poly over the integers. % sofar is a list of these factors found so far. ; IF POLY=1 THEN IF NULL L THEN SOFAR ELSE ERRORF(LIST("TOO MANY BAD FACTORS:",L)) ELSE BEGIN SCALAR N,RES,FF,V,W,W1,COMBINED!.FACTORS,LL; N:=LENGTH L; IF N=1 THEN IF LDEG CAR L > (LDEG POLY)/2 THEN RETURN ('ONE! BAD! FACTOR . SOFAR) ELSE ERRORF(LIST("ONE BAD FACTOR DOES NOT FIT:",L)); IF N=2 OR N=3 THEN << W:=LC CDAR L; % The LC of all the factors is the same; WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W); % poly's LC may be a higher power of w than we want % and we must return a result with the same % LC as each of the combined factors; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "We combine:"; FOR EACH LF IN L DO FAC!-PRINTSF CDR LF; PRIN2!* " mod "; PRIN2!* M; PRINTSTR " to give correct factor:"; FAC!-PRINTSF POLY >>; COMBINE!.ALPHAS(L,T); RETURN (POLY . SOFAR) >>; LL:=FOR EACH FF IN L COLLECT (CDR FF . CAR FF); FOR K:=2:(N/2) DO << W:=KOUTOF(K,IF 2*K=N THEN CDR L ELSE L,NIL); WHILE W AND (V:=FACTOR!-TRIALDIV(POLY,CAR W,M,LL))='DIDNTGO DO << W:=CDR W; WHILE W AND ((CAR W = '!*LAZYADJOIN) OR (CAR W = '!*LAZYKOUTOF)) DO IF CAR W= '!*LAZYADJOIN THEN W:=LAZY!-ADJOIN(CADR W,CADDR W,CADR CDDR W) ELSE W:=KOUTOF(CADR W,CADDR W,CADR CDDR W) >>; IF NOT(V='DIDNTGO) THEN << FF:=CAR V; V:=CDR V; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "We combine:"; FOR EACH A IN CAR W DO FAC!-PRINTSF A; PRIN2!* " mod "; PRIN2!* M; PRINTSTR " to give correct factor:"; FAC!-PRINTSF FF >>; FOR EACH A IN CAR W DO << W1:=L; WHILE NOT (A = CDAR W1) DO W1:=CDR W1; COMBINED!.FACTORS:=CAR W1 . COMBINED!.FACTORS; L:=DELETE(CAR W1,L) >>; COMBINE!.ALPHAS(COMBINED!.FACTORS,T); RETURN RES:=TRY!.COMBINING(L,V,M,FF . SOFAR) >> >>; IF RES THEN RETURN RES ELSE << W:=LC CDAR L; % The LC of all the factors is the same; WHILE NOT (W=LC POLY) DO POLY:=QUOTFAIL(POLY,W); % poly's LC may be a higher power of w than we want % and we must return a result with the same % LC as each of the combined factors; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR "We combine:"; FOR EACH FF IN L DO FAC!-PRINTSF CDR FF; PRIN2!* " mod "; PRIN2!* M; PRINTSTR " to give correct factor:"; FAC!-PRINTSF POLY >>; COMBINE!.ALPHAS(L,T); RETURN (POLY . SOFAR) >> END; SYMBOLIC PROCEDURE KOUTOF(K,L,SOFAR); % produces all permutations of length k from list l accumulating them % in sofar as we go. we use lazy evaluation in that this results in % a permutation dotted with: % ( '!*lazy . (argument for eval) ) % except when k=1 when the permutations are explicitly given.; IF K=1 THEN APPEND( FOR EACH F IN L COLLECT LIST CDR F,SOFAR) ELSE IF K>LENGTH L THEN SOFAR ELSE << WHILE EQCAR(L,'!*LAZYADJOIN) OR EQCAR(L,'!*LAZYKOUTOF) DO IF CAR L='!*LAZYADJOIN THEN L := LAZY!-ADJOIN(CADR L,CADDR L,CADR CDDR L) ELSE L := KOUTOF(CADR L,CADDR L,CADR CDDR L); IF K=LENGTH L THEN (FOR EACH LL IN L COLLECT CDR LL ) . SOFAR ELSE KOUTOF(K,CDR L, LIST('!*LAZYADJOIN,CDAR L, LIST('!*LAZYKOUTOF,(K-1),CDR L,NIL), SOFAR)) >>; SYMBOLIC PROCEDURE LAZY!-ADJOIN(ITEM,L,TAIL); % dots item with each element in l using lazy evaluation on l. % if l is null tail results; << WHILE EQCAR(L,'!*LAZYADJOIN) OR EQCAR(L,'!*LAZYKOUTOF) DO IF CAR L ='!*LAZYADJOIN THEN L:=LAZY!-ADJOIN(CADR L,CADDR L,CADR CDDR L) ELSE L:=KOUTOF(CADR L,CADDR L,CADR CDDR L); IF NULL L THEN TAIL ELSE (ITEM . CAR L) . IF NULL CDR L THEN TAIL ELSE LIST('!*LAZYADJOIN,ITEM,CDR L,TAIL) >>; SYMBOLIC PROCEDURE FACTOR!-TRIALDIV(POLY,FLIST,M,LLIST); % Combines the factors in FLIST mod M and test divides the result % into POLY (over integers) to see if it goes. If it doesn't % then DIDNTGO is returned, else the pair (D . Q) is % returned where Q is the quotient obtained and D is the product % of the factors mod M; IF POLYZEROP POLY THEN ERRORF "Test dividing into zero?" ELSE BEGIN SCALAR D,Q; D:=COMBINE(FLIST,M,LLIST); IF DIDNTGO(Q:=QUOTF(POLY,CAR D)) THEN << FACTOR!-TRACE PRINTSTR " it didn't go"; RETURN 'DIDNTGO >> ELSE << FACTOR!-TRACE PRINTSTR " it worked !"; RETURN (CAR D . QUOTF(Q,CDR D)) >> END; SYMBOLIC PROCEDURE COMBINE(FLIST,M,L); % multiply factors in flist mod m; % L is a list of the factors for use in FACTOR!-TRACE; BEGIN SCALAR OM,RES,W,LCF,LCFINV,LCFPROD; FACTOR!-TRACE << PRIN2!* "We combine factors "; FOR EACH FF IN FLIST DO << W:=ASSOC(FF,L); PRIN2!* "f("; PRIN2!* CDR W; PRIN2!* "), " >> ; PRIN2!* "and try dividing : " >>; LCF := LC CAR FLIST; % ALL LEADING COEFFTS SHOULD BE THE SAME; LCFPROD := 1; % This is one of only two places in the entire factorizer where % it is ever necessary to use a modulus larger than word-size; IF M>LARGEST!-SMALL!-MODULUS THEN << OM:=SET!-GENERAL!-MODULUS M; LCFINV := GENERAL!-MODULAR!-RECIPROCAL LCF; RES:=GENERAL!-REDUCE!-MOD!-P CAR FLIST; FOR EACH FF IN CDR FLIST DO << IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST"; RES:=GENERAL!-TIMES!-MOD!-P( GENERAL!-TIMES!-MOD!-P(LCFINV, GENERAL!-REDUCE!-MOD!-P FF),RES); LCFPROD := LCFPROD*LCF >>; RES:=GENERAL!-MAKE!-MODULAR!-SYMMETRIC RES; SET!-MODULUS OM; RETURN (RES . LCFPROD) >> ELSE << OM:=SET!-MODULUS M; LCFINV := MODULAR!-RECIPROCAL LCF; RES:=REDUCE!-MOD!-P CAR FLIST; FOR EACH FF IN CDR FLIST DO << IF NOT LCF=LC FF THEN ERRORF "BAD LC IN FLIST"; RES:=TIMES!-MOD!-P(TIMES!-MOD!-P(LCFINV,REDUCE!-MOD!-P FF),RES); LCFPROD := LCFPROD*LCF >>; RES:=MAKE!-MODULAR!-SYMMETRIC RES; SET!-MODULUS OM; RETURN (RES . LCFPROD) >> END; SYMBOLIC PROCEDURE COMBINE!.ALPHAS(FLIST,FIXLCS); % combine the alphas associated with each of these factors to % give the one alpha for their combination; BEGIN SCALAR F1,A1,FF,AA,OLDM,W,LCFAC,LCFINV,SAVEFLIST;; OLDM:=SET!-MODULUS HENSEL!-GROWTH!-SIZE; FLIST:=FOR EACH FAC IN FLIST COLLECT << SAVEFLIST:= (REDUCE!-MOD!-P CDR FAC) . SAVEFLIST; (CAR FAC) . CAR SAVEFLIST >>; IF FIXLCS THEN << LCFINV:=MODULAR!-RECIPROCAL LC CDAR FLIST; LCFAC:=MODULAR!-EXPT(LC CDAR FLIST,SUB1 LENGTH FLIST) >> ELSE << LCFINV:=1; LCFAC:=1 >>; % If FIXLCS is set then we have combined n factors % (each with the same l.c.) to give one and we only need one % l.c. in the result, we have divided the combination by % lc**(n-1) and we must be sure to do the same for the % alphas.; FF:=CDAR FLIST; AA:=CDR GET!-ALPHA FF; FLIST:=CDR FLIST; WHILE FLIST DO << F1:=CDAR FLIST; A1:=CDR GET!-ALPHA F1; FLIST:=CDR FLIST; AA:=PLUS!-MOD!-P(TIMES!-MOD!-P(AA,F1),TIMES!-MOD!-P(A1,FF)); FF:=TIMES!-MOD!-P(FF,TIMES!-MOD!-P(LCFINV,F1)) >>; FOR EACH A IN ALPHALIST DO IF NOT MEMBER(CAR A,SAVEFLIST) THEN FLIST:=(CAR A . IF LCFAC=1 THEN CDR A ELSE TIMES!-MOD!-P(CDR A,LCFAC)) . FLIST; ALPHALIST:=(FF . AA) . FLIST; SET!-MODULUS OLDM END; %*********************************************************************; % The following code is for dividing out factors in the middle % of the Hensel construction and adjusting all the associated % variables that go with it. %; SYMBOLIC PROCEDURE ADJUST!-GROWTH(FACDONE,K,M); % One factor (at least) divides out so we can reconfigure the % problem for Hensel constrn giving a smaller growth and hopefully % reducing the coefficient bound considerably; BEGIN SCALAR W,U,BOUND!-SCALE,MODFLIST,FACTORLIST,FHATLIST, MODFDONE,B; FACTORLIST:=VEC2LIST!-WITHOUT!-K(FACTORVEC,K); MODFLIST:=VEC2LIST!-WITHOUT!-K(MODFVEC,K); FHATLIST:=VEC2LIST!-WITHOUT!-K(FHATVEC,K); W:=NUMBER!-OF!-FACTORS; MODFDONE:=GETV(MODFVEC,K); TOP: FACTORS!-DONE:=FACDONE . FACTORS!-DONE; IF (NUMBER!-OF!-FACTORS:=NUMBER!-OF!-FACTORS #- 1)=1 THEN << FACTORS!-DONE:=HENSEL!-POLY . FACTORS!-DONE; NUMBER!-OF!-FACTORS:=0; HENSEL!-POLY:=1; IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR " All factors found:"; FOR EACH FD IN FACTORS!-DONE DO FAC!-PRINTSF FD >>; RETURN POLYZERO >>; FHATLIST:=FOR EACH FHAT IN FHATLIST COLLECT QUOTFAIL!-MOD!-P(IF NULL FHAT THEN POLYZERO ELSE FHAT,MODFDONE); U:=COMFAC FACDONE; % Take contents and prim. parts; IF CAR U THEN ERRORF(LIST("Factor divisible by main variable: ",FACDONE,CAR U)); FACDONE:=QUOTFAIL(FACDONE,CDR U); BOUND!-SCALE:=CDR U; IF NOT((B:=LC FACDONE)=1) THEN BEGIN SCALAR B!-INV,OLD!-M; HENSEL!-POLY:=QUOTFAIL(HENSEL!-POLY,B**NUMBER!-OF!-FACTORS); B!-INV:=MODULAR!-RECIPROCAL MODULAR!-NUMBER B; MODFLIST:=FOR EACH MODF IN MODFLIST COLLECT TIMES!-MOD!-P(B!-INV,MODF); % This is one of only two places in the entire factorizer where % it is ever necessary to use a modulus larger than word-size; IF M>LARGEST!-SMALL!-MODULUS THEN << OLD!-M:=SET!-GENERAL!-MODULUS M; FACTORLIST:=FOR EACH FACC IN FACTORLIST COLLECT ADJOIN!-TERM(LPOW FACC,QUOTFAIL(LC FACC,B), GENERAL!-MAKE!-MODULAR!-SYMMETRIC( GENERAL!-TIMES!-MOD!-P( GENERAL!-MODULAR!-RECIPROCAL GENERAL!-MODULAR!-NUMBER B, GENERAL!-REDUCE!-MOD!-P RED FACC))) >> ELSE << OLD!-M:=SET!-MODULUS M; FACTORLIST:=FOR EACH FACC IN FACTORLIST COLLECT ADJOIN!-TERM(LPOW FACC,QUOTFAIL(LC FACC,B), MAKE!-MODULAR!-SYMMETRIC( TIMES!-MOD!-P(MODULAR!-RECIPROCAL MODULAR!-NUMBER B, REDUCE!-MOD!-P RED FACC))) >>; % We must be careful not to destroy the information % that we have about the leading coefft; SET!-MODULUS OLD!-M; FHATLIST:=FOR EACH FHAT IN FHATLIST COLLECT TIMES!-MOD!-P( MODULAR!-EXPT(B!-INV,NUMBER!-OF!-FACTORS #- 1),FHAT) END; TRY!-ANOTHER!-FACTOR: IF (W:=W #- 1)>0 THEN IF NOT DIDNTGO (U:=QUOTF(HENSEL!-POLY,FACDONE:=CAR FACTORLIST)) THEN << HENSEL!-POLY:=U; FACTORLIST:=CDR FACTORLIST; MODFDONE:=CAR MODFLIST; MODFLIST:=CDR MODFLIST; FHATLIST:=CDR FHATLIST; GOTO TOP >> ELSE << FACTORLIST:=APPEND(CDR FACTORLIST,LIST CAR FACTORLIST); MODFLIST:=APPEND(CDR MODFLIST,LIST CAR MODFLIST); FHATLIST:=APPEND(CDR FHATLIST,LIST CAR FHATLIST); GOTO TRY!-ANOTHER!-FACTOR >>; SET!-FLUIDS!-FOR!-NEWHENSEL(FACTORLIST,FHATLIST,MODFLIST); BOUND!-SCALE:= BOUND!-SCALE * GET!-COEFFT!-BOUND( QUOTFAIL(HENSEL!-POLY,BOUND!-SCALE**(NUMBER!-OF!-FACTORS #- 1)), LDEG HENSEL!-POLY); % We expect the new coefficient bound to be smaller, but on % dividing out a factor our polynomial's height may have grown % more than enough to compensate in the bound formula for % the drop in degree. Anyway, the bound we computed last time % will still be valid, so let's stick with the smaller; IF BOUND!-SCALE < COEFFTBD THEN COEFFTBD := BOUND!-SCALE; W:=QUOTFAIL(ADDF(HENSEL!-POLY,NEGF CURRENT!-FACTOR!-PRODUCT), M/DELTAM); IF NOT !*OVERVIEW THEN FACTOR!-TRACE << PRINTSTR " Factors found to be correct:"; FOR EACH FD IN FACTORS!-DONE DO FAC!-PRINTSF FD; PRINTSTR "Remaining factors are:"; PRINTVEC(" f(",NUMBER!-OF!-FACTORS,") = ",FACTORVEC); PRIN2!* "New coefficient bound is "; PRINTSTR COEFFTBD; PRIN2!* " and the residue is now "; FAC!-PRINTSF W >>; RETURN W END; SYMBOLIC PROCEDURE VEC2LIST!-WITHOUT!-K(V,K); % Turn a vector into a list leaving out Kth element; BEGIN SCALAR W; FOR I:=1:NUMBER!-OF!-FACTORS DO IF NOT(I=K) THEN W:=GETV(V,I) . W; RETURN W END; SYMBOLIC PROCEDURE SET!-FLUIDS!-FOR!-NEWHENSEL(FLIST,FHATLIST,MODFLIST); << CURRENT!-FACTOR!-PRODUCT:=1; ALPHALIST:= FIND!-ALPHAS!-IN!-A!-RING(NUMBER!-OF!-FACTORS,MODFLIST,FHATLIST,1); FOR I:=NUMBER!-OF!-FACTORS STEP -1 UNTIL 1 DO << PUTV(FACTORVEC,I,CAR FLIST); PUTV(MODFVEC,I,CAR MODFLIST); PUTV(FHATVEC,I,CAR FHATLIST); PUTV(ALPHAVEC,I,CDR GET!-ALPHA CAR MODFLIST); CURRENT!-FACTOR!-PRODUCT:=MULTF(CAR FLIST,CURRENT!-FACTOR!-PRODUCT); FLIST:=CDR FLIST; MODFLIST:=CDR MODFLIST; FHATLIST:=CDR FHATLIST >> >>; SYMBOLIC PROCEDURE SET!-HENSEL!-FLUIDS!-BACK P; % After the Hensel growth we must be careful to set back any fluids % that have been changed when we divided out a factor in the middle % of growing. Since calculating the alphas involves modular division % we cannot do it mod DELTAM which is generally a non-trivial power of % P (prime). So we calculate them mod P and if necessary we can do a % few quadratic growth steps later. ; BEGIN SCALAR N,FD,MODFLIST,FULLF,MODF; SET!-MODULUS P; DELTAM:=P; N:=NUMBER!-OF!-FACTORS #+ LENGTH (FD:=FACTORS!-DONE); CURRENT!-FACTOR!-PRODUCT:=HENSEL!-POLY; FOR I:=(NUMBER!-OF!-FACTORS #+ 1):N DO << PUTV(FACTORVEC,I,FULLF:=CAR FD); PUTV(MODFVEC,I,MODF:=REDUCE!-MOD!-P FULLF); CURRENT!-FACTOR!-PRODUCT:=MULTF(FULLF,CURRENT!-FACTOR!-PRODUCT); MODFLIST:=MODF . MODFLIST; FD:=CDR FD >>; FOR I:=1:NUMBER!-OF!-FACTORS DO << MODF:=REDUCE!-MOD!-P !*MOD2F GETV(MODFVEC,I); % need to 'unbox' a modpoly before reducing it mod p as we % know that the input modpoly is wrt a larger modulus % (otherwise this would be a stupid thing to do anyway!) % and so we are just pretending it is a full poly; MODFLIST:=MODF . MODFLIST; PUTV(MODFVEC,I,MODF) >>; ALPHALIST:=ALPHAS(N,MODFLIST,1); FOR I:=1:N DO PUTV(ALPHAVEC,I,CDR GET!-ALPHA GETV(MODFVEC,I)); NUMBER!-OF!-FACTORS:=N END; ENDMODULE; MODULE VECPOLY; %**********************************************************************; % % copyright (c) university of cambridge, england 1979 % %**********************************************************************; %**********************************************************************; % Routines for working with modular univariate polynomials % stored as vectors. Used to avoid unwarranted storage management % in the mod-p factorization process; SAFE!-FLAG:=CARCHECK 0; SYMBOLIC PROCEDURE COPY!-VECTOR(A,DA,B); % Copy A into B; << FOR I:=0:DA DO PUTV(B,I,GETV(A,I)); DA >>; SYMBOLIC PROCEDURE TIMES!-IN!-VECTOR(A,DA,B,DB,C); % Put the product of A and B into C and return its degree. % C must not overlap with either A or B; BEGIN SCALAR DC,IC,W; IF DA#<0 OR DB#<0 THEN RETURN MINUS!-ONE; DC:=DA#+DB; FOR I:=0:DC DO PUTV(C,I,0); FOR IA:=0:DA DO << W:=GETV(A,IA); FOR IB:=0:DB DO << IC:=IA#+IB; PUTV(C,IC,MODULAR!-PLUS(GETV(C,IC), MODULAR!-TIMES(W,GETV(B,IB)))) >> >>; RETURN DC END; SYMBOLIC PROCEDURE QUOTFAIL!-IN!-VECTOR(A,DA,B,DB); % Overwrite A with (A/B) and return degree of result. % The quotient must be exact; IF DA#<0 THEN DA ELSE IF DB#<0 THEN ERRORF "Attempt to divide by zero" ELSE IF DA#<DB THEN ERRORF "Bad degrees in QUOTFAIL-IN-VECTOR" ELSE BEGIN SCALAR DC; DC:=DA#-DB; % Degree of result; FOR I:=DC STEP -1 UNTIL 0 DO BEGIN SCALAR Q; Q:=MODULAR!-QUOTIENT(GETV(A,DB#+I),GETV(B,DB)); FOR J:=0:DB#-1 DO PUTV(A,I#+J,MODULAR!-DIFFERENCE(GETV(A,I#+J), MODULAR!-TIMES(Q,GETV(B,J)))); PUTV(A,DB#+I,Q) END; FOR I:=0:DB#-1 DO IF GETV(A,I) NEQ 0 THEN ERRORF "Quotient not exact in QUOTFAIL!-IN!-VECTOR"; FOR I:=0:DC DO PUTV(A,I,GETV(A,DB#+I)); RETURN DC END; SYMBOLIC PROCEDURE REMAINDER!-IN!-VECTOR(A,DA,B,DB); % Overwrite the vector A with the remainder when A is % divided by B, and return the degree of the result; BEGIN SCALAR DELTA,DB!-1,RECIP!-LC!-B,W; IF DB=0 THEN RETURN MINUS!-ONE ELSE IF DB=MINUS!-ONE THEN ERRORF "ATTEMPT TO DIVIDE BY ZERO"; RECIP!-LC!-B:=MODULAR!-MINUS MODULAR!-RECIPROCAL GETV(B,DB); DB!-1:=DB#-1; % Leading coeff of B treated specially, hence this; WHILE NOT((DELTA:=DA#-DB) #< 0) DO << W:=MODULAR!-TIMES(RECIP!-LC!-B,GETV(A,DA)); FOR I:=0:DB!-1 DO PUTV(A,I#+DELTA,MODULAR!-PLUS(GETV(A,I#+DELTA), MODULAR!-TIMES(GETV(B,I),W))); DA:=DA#-1; WHILE NOT(DA#<0) AND GETV(A,DA)=0 DO DA:=DA#-1 >>; RETURN DA END; SYMBOLIC PROCEDURE EVALUATE!-IN!-VECTOR(A,DA,N); % Evaluate A at N; BEGIN SCALAR R; R:=GETV(A,DA); FOR I:=DA#-1 STEP -1 UNTIL 0 DO R:=MODULAR!-PLUS(GETV(A,I), MODULAR!-TIMES(R,N)); RETURN R END; SYMBOLIC PROCEDURE GCD!-IN!-VECTOR(A,DA,B,DB); % Overwrite A with the gcd of A and B. On input A and B are % vectors of coefficients, representing polynomials % of degrees DA and DB. Return DG, the degree of the gcd; BEGIN SCALAR W; IF DA=0 OR DB=0 THEN << PUTV(A,0,1); RETURN 0 >> ELSE IF DA#<0 OR DB#<0 THEN ERRORF "GCD WITH ZERO NOT ALLOWED"; TOP: % Reduce the degree of A; DA:=REMAINDER!-IN!-VECTOR(A,DA,B,DB); IF DA=0 THEN << PUTV(A,0,1); RETURN 0 >> ELSE IF DA=MINUS!-ONE THEN << W:=MODULAR!-RECIPROCAL GETV(B,DB); FOR I:=0:DB DO PUTV(A,I,MODULAR!-TIMES(GETV(B,I),W)); RETURN DB >>; % Now reduce degree of B; DB:=REMAINDER!-IN!-VECTOR(B,DB,A,DA); IF DB=0 THEN << PUTV(A,0,1); RETURN 0 >> ELSE IF DB=MINUS!-ONE THEN << W:=MODULAR!-RECIPROCAL GETV(A,DA); IF NOT (W=1) THEN FOR I:=0:DA DO PUTV(A,I,MODULAR!-TIMES(GETV(A,I),W)); RETURN DA >>; GO TO TOP END; CARCHECK SAFE!-FLAG; ENDMODULE; MODULE ZMODP; % ******************************************************************* % % copyright (c) university of cambridge, england 1979 % % *******************************************************************; % modular arithmetic for use in univariate factorization % routines; SYMBOLIC PROCEDURE SET!-MODULUS P; IF NOT NUMBERP P OR P=0 THEN CURRENT!-MODULUS ELSE BEGIN SCALAR PREVIOUS!-MODULUS; PREVIOUS!-MODULUS:=CURRENT!-MODULUS; CURRENT!-MODULUS:=P; MODULUS!/2:=P/2; SET!-SMALL!-MODULUS P; RETURN PREVIOUS!-MODULUS END; SYMBOLIC PROCEDURE MODULAR!-EXPT(A,N); % a**n; IF N=0 THEN 1 ELSE IF N=1 THEN A ELSE BEGIN SCALAR X; X:=MODULAR!-EXPT(A,IQUOTIENT(N,2)); X:=MODULAR!-TIMES(X,X); IF NOT (IREMAINDER(N,2) = 0) THEN X:=MODULAR!-TIMES(X,A); RETURN X END; LISP SET!-MODULUS(1) ; % forces everything into a standard state; ENDMODULE; END; |
Added r30/factor.tst version [0d9fbf428c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT FACTORIZER TEST FILE; ARRAY A(20),B(20); FACTORIZE(X**2-1,A); %To make sure factorizer is loaded; SYMBOLIC RANDOMIZE(); %To set RANDOM-SEED. This can be set direct if %deterministic behavior is required. ALGEBRAIC PROCEDURE TEST(PROB,NFAC); BEGIN SCALAR BASETIME; P := FOR I:=1:NFAC PRODUCT A(I); WRITE "Problem number ",PROB; LISP BASETIME := TIME(); LISP PRIN2T LIST("The random seed is",RANDOM!-SEED); M := FACTORIZE(P, B); LISP BASETIME := TIME() - BASETIME; LISP LPRI LIST("Time =",BASETIME); LISP TERPRI(); Q := FOR I:=0:M PRODUCT B(I); IF (M=NFAC) AND (P=Q) THEN RETURN OK; WRITE "This example failed"; FOR I:=0:M DO WRITE B(I); RETURN FAILED END; % Wang test case 1; A(1) := X*Y+Z+10$ A(2) := X*Z+Y+30$ A(3) := X+Y*Z+20$ TEST(1,3); % Wang test case 2; A(1) := X**3*Z+X**3*Y+Z-11$ A(2) := X**2*Z**2+X**2*Y**2+Y+90$ TEST(2,2); % Wang test case 3; A(1) := X**3*Y**2+X*Z**4+X+Z$ A(2) := X**3+X*Y*Z+Y**2+Y*Z**3$ TEST(3,2); % Wang test case 4; A(1) := X**2*Z+Y**4*Z**2+5$ A(2) := X*Y**3+Z**2$ A(3) := -X**3*Y+Z**2+3$ A(4) := X**3*Y**4+Z**2$ TEST(4,4); % Wang test case 5; A(1) := 3*U**2*X**3*Y**4*Z+X*Z**2+Y**2*Z**2+19*Y**2$ A(2) := U**2*Y**4*Z**2+X**2*Z+5$ A(3) := U**2+X**3*Y**4+Z**2$ TEST(5,3); % Wang test case 6; A(1) := W**4*X**5*Y**6-W**4*Z**3+W**2*X**3*Y+X*Y**2*Z**2$ A(2) := W**4*Z**6-W**3*X**3*Y-W**2*X**2*Y**2*Z**2+X**5*Z -X**4*Y**2+Y**2*Z**3$ A(3) := -X**5*Z**3+X**2*Y**3+Y*Z$ TEST(6,3); % Wang test case 7; A(1) := X+Y+Z-2$ A(2) := X+Y+Z-2$ A(3) := X+Y+Z-3$ A(4) := X+Y+Z-3$ A(5) := X+Y+Z-3$ TEST(7,5); % Wang test case 8; A(1) := -Z**31-W**12*Z**20+Y**18-Y**14+X**2*Y**2+X**21+W**2$ A(2) := -15*Y**2*Z**16+29*W**4*X**12*Z**3+21*X**3*Z**2+3*W**15*Y**20$ TEST(8,2); % Wang test case 9; A(1) := 18*U**2*W**3*X*Z**2+10*U**2*W*X*Y**3+15*U*Z**2+6*W**2*Y**3*Z**2$ A(2) := X$ A(3) := 25*U**2*W**3*Y*Z**4+32*U**2*W**4*Y**4*Z**3- 48*U**2*X**2*Y**3*Z**3-2*U**2*W*X**2*Y**2+44*U*W*X*Y**4*Z**4- 8*U*W*X**3*Z**4+4*W**2*X+11*W**2*X**3*Y+12*Y**3*Z**2$ A(4) := Z$ A(5) := Z$ A(6) := U$ A(7) := U$ A(8) := U$ A(9) := U$ TEST(9,9); % Wang test case 10; A(1) := 31*U**2*X*Z+35*W**2*Y**2+40*W*X**2+6*X*Y$ A(2) := 42*U**2*W**2*Y**2+47*U**2*W**2*Z+22*U**2*W**2+9*U**2*W*X**2+21 *U**2*W*X*Y*Z+37*U**2*Y**2*Z+U**2*W**2*X*Y**2*Z**2+8*U**2*W**2 *Z**2+24*U**2*W*X*Y**2*Z**2+24*U**2*X**2*Y*Z**2+12*U**2*X*Y**2 *Z**2+13*U*W**2*X**2*Y**2+27*U*W**2*X**2*Y+39*U*W*X*Z+43*U* X**2*Y+44*U*W**2* Z**2+37*W**2*X*Y+29*W**2*Y**2+31*W**2*Y*Z**2 +12*W*X**2*Y*Z+43*W*X*Y*Z**2+22*X*Y**2+23*X*Y*Z+24*X*Y+41*Y**2 *Z$ TEST(10,2); % Wang test case 11; A(1) := -36*U**2*W**3*X*Y*Z**3-31*U**2*W**3*Y**2+20*U**2*W**2*X**2*Y**2 *Z**2-36*U**2*W*X*Y**3*Z+46*U**2*W*X+9*U**2*Y**2-36*U*W**2*Y**3 +9*U*W*Y**3-5*U*W*X**2*Y**3+48*U*W*X**3*Y**2*Z+23*U*W*X**3*Y**2 -43*U*X**3*Y**3*Z**3-46*U*X**3*Y**2+29*W**3*X*Y**3*Z**2- 14*W**3*X**3*Y**3*Z**2-45*X**3-8*X*Y**2$ A(2) := 13*U**3*W**2*X*Y*Z**3-4*U*X*Y**2-W**3*Z**3-47*X*Y$ A(3) := X$ A(4) := Y$ TEST(11,4); % Wang test case 12; A(1) := X+Y+Z-3$ A(2) := X+Y+Z-3$ A(3) := X+Y+Z-3$ TEST(12,3); % Wang test case 13; A(1) := 2*W*Z+45*X**3-9*Y**3-Y**2+3*Z**3$ A(2) := W**2*Z**3-W**2+47*X*Y$ TEST(13,2); % Wang test case 14; A(1) := 18*X**4*Y**5+41*X**4*Y**2-37*X**4+26*X**3*Y**4+38*X**2*Y**4-29* X**2*Y**3-22*Y**5$ A(2) := 33*X**5*Y**6-22*X**4+35*X**3*Y+11*Y**2$ TEST(14,2); % Wang test case 15; A(1) := 12*W**2*X*Y*Z**3-W**2*Z**3+W**2-29*X-3*X*Y**2$ A(2) := 14*W**2*Y**2+2*W*Z+18*X**3*Y-8*X*Y**2-Y**2+3*Z**3$ A(3) := Z$ A(4) := Z$ A(5) := Y$ A(6) := Y$ A(7) := Y$ A(8) := X$ A(9) := X$ A(10) := X$ A(11) := X$ A(12) := X$ A(13) := X$ TEST(15,13); % Test 16 - the 40th degree polynomial that comes from % SIGSAM problem number 7; A(1) := 8192*Y**10+20480*Y**9+58368*Y**8-161792*Y**7+198656*Y**6+ 199680*Y**5-414848*Y**4-4160*Y**3+171816*Y**2-48556*Y+469$ A(2) := 8192*Y**10+12288*Y**9+66560*Y**8-22528*Y**7-138240*Y**6+ 572928*Y**5-90496*Y**4-356032*Y**3+113032*Y**2+23420*Y-8179$ A(3) := 4096*Y**10+8192*Y**9+1600*Y**8-20608*Y**7+20032*Y**6+87360*Y**5- 105904*Y**4+18544*Y**3+11888*Y**2-3416*Y+1$ A(4) := 4096*Y**10+8192*Y**9-3008*Y**8-30848*Y**7+21056*Y**6+146496* Y**5-221360*Y**4+1232*Y**3+144464*Y**2-78488*Y+11993$ TEST(16,4); % Test 17 - taken from Erich Kaltofen's thesis. This polynomial % splits mod all possible primes p; A(1) := X**25-25*X**20-3500*X**15-57500*X**10+21875*X**5-3125$ TEST(17,1); % Test 18 - another 'hard-to-factorize' univariate; A(1) := X**18+9*X**17+45*X**16+126*X**15+189*X**14+27*X**13- 540*X**12-1215*X**11+1377*X**10+15444*X**9+46899*X**8+ 90153*X**7+133893*X**6+125388*X**5+29160*X**4- 32076*X**3+26244*X**2-8748*X+2916$ TEST(18,1); % Test 19 - another example chosen to lead to false splits mod p; A(1) := X**16+4*X**12-16*X**11+80*X**9+2*X**8+160*X**7+ 128*X**6-160*X**5+28*X**4-48*X**3+128*X**2-16*X+1$ A(2) := X**16+4*X**12+16*X**11-80*X**9+2*X**8-160*X**7+ 128*X**6+160*X**5+28*X**4+48*X**3+128*X**2+16*X+1$ TEST(19,2); % End of all tests; END; |
Added r30/fap.fap version [a48d1d36c3].
cannot compute difference between binary files
Added r30/fap.red version [e2bec6970e].
cannot compute difference between binary files
Added r30/fend.fap version [e547190f19].
cannot compute difference between binary files
Added r30/fend.red version [81c96e9da3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT R E D U C E PREPROCESSOR FOR DECSYSTEMS 10 AND 20; COMMENT Standard LISP Functions Defined in LISP 1.6: ABS AND APPEND APPLY ATOM CAR ... CDDDDR COND CONS DIVIDE EQ EQUAL EVAL FIX GENSYM GET GO LENGTH LINELENGTH MEMBER MEMQ MINUS NCONC NOT NULL NUMBERP OR PRINC PRIN1 PROG QUOTE READCH REMAINDER RETURN REVERSE RPLACA RPLACD SET SETQ SUBST TERPRI; COMMENT compiler support functions needed for DEC-10 implementation; REMFLAG('(LIST2 LIST3 LIST4 LIST5 REVERSIP),'LOSE); SYMBOLIC PROCEDURE LIST2(U,V); U . V . NIL; SYMBOLIC PROCEDURE LIST3(U,V,W); U . V . W . NIL; SYMBOLIC PROCEDURE LIST4(U,V,W,X); U . V . W . X . NIL; SYMBOLIC PROCEDURE LIST5(U,V,W,X,Y); U . V . W . X . Y . NIL; SYMBOLIC PROCEDURE REVERSIP U; BEGIN SCALAR X,Y; WHILE U DO <<X := CDR U; Y := RPLACD(U,Y); U := X>>; RETURN Y END; COMMENT Primitive Standard LISP Functions Defined in terms of LISP 1.6; SYMBOLIC PROCEDURE EQN(M,N); M EQ N OR NUMBERP M AND M=N; SYMBOLIC PROCEDURE EXPLODE2 U; EXPLODEC U; SYMBOLIC PROCEDURE FLUID U; BEGIN A: IF NULL U THEN RETURN NIL; IF GETD 'MODBIND AND NOT GET(CAR U,'MODE) THEN PUT(CAR U,'MODE,'SYMBOLIC); %interface to mode system; IF GETD CAR U THEN ERROR(10,LIST("Function",CAR U,"cannot be fluid")); FLAG(LIST CAR U,'FLUID); IF NULL !*DEFN THEN QSET(CAR U,NIL); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE QSET(U,V); IF ATOM ERRORSET(U,NIL,NIL) THEN SET(U,V); !*DEFN := NIL; SYMBOLIC PROCEDURE FLUIDP U; FLAGP(U,'FLUID); SYMBOLIC PROCEDURE GLOBAL U; BEGIN A: IF NULL U THEN RETURN NIL; IF GETD 'MODBIND AND NOT GET(CAR U,'MODE) THEN PUT(CAR U,'MODE,'SYMBOLIC); %interface to mode system; IF GETD CAR U THEN ERROR(10,LIST("Function",CAR U,"cannot be global")); FLAG(LIST CAR U,'GLOBAL); IF NULL !*DEFN THEN QSET(CAR U,NIL); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE GLOBALP U; FLAGP(U,'GLOBAL); GLOBAL '(OBLIST); FLUID '(!*PI!*); GLOBAL '(FTYPES!*); FTYPES!* := '(EXPR FEXPR MACRO); FLAG('(EXPR FEXPR),'COMPILE); PUTD('!%PUTD,'EXPR,CDR GETD 'PUTD); SYMBOLIC PROCEDURE PUTD(NAME,TYPE,BODY); BEGIN IF TYPE EQ 'SUBR THEN TYPE:='EXPR ELSE IF TYPE EQ 'FSUBR THEN TYPE:='FEXPR ELSE GO NOWARN; WARNING "(F)SUBR converted to (F)EXPR in PUTD"; NOWARN: IF FLAGP(NAME,'LOSE) THEN RETURN NIL ELSE IF TYPE MEMQ FTYPES!* AND GETD NAME AND NULL !*DEFN THEN <<WARNING LIST(NAME,"redefined"); REMPROP(NAME,'TRACE); REMPROP(NAME,'TRACECNT)>>; IF !*COMP AND FLAGP(TYPE,'COMPILE) AND NOT CODEP BODY THEN COMPD(NAME,TYPE,BODY) ELSE IF TYPE MEMQ FTYPES!* THEN !%PUTD(NAME,TYPE,BODY) ELSE PUT(NAME,TYPE,BODY); RETURN NAME END; !*COMP := NIL; SYMBOLIC PROCEDURE UNFLUID U; <<FOR EACH X IN U DO REMPROP(X,'MODE); REMFLAG(U,'FLUID)>>; COMMENT COMPOSITE STANDARD LISP FUNCTIONS NOT DEFINED IN LISP 1.6; SYMBOLIC PROCEDURE ASSOC(U,V); %looks for U in association list V using an EQUAL test; IF NULL V THEN NIL ELSE IF U=CAAR V THEN CAR V ELSE ASSOC(U,CDR V); FEXPR PROCEDURE DE U; PUTD(CAR U,'EXPR,'LAMBDA . CADR U . CDDR U); SYMBOLIC PROCEDURE DEFLIST(L,V); IF NULL L THEN NIL ELSE PROGN(PUT(CAAR L,V,CADAR L),CAAR L) . DEFLIST(CDR L,V); SYMBOLIC PROCEDURE DELETE(U,V); IF NULL V THEN NIL ELSE IF U = CAR V THEN CDR V ELSE CAR V . DELETE(U,CDR V); FEXPR PROCEDURE DF U; PUTD(CAR U,'FEXPR,'LAMBDA . CADR U . CDDR U); FEXPR PROCEDURE DM U; PUTD(CAR U,'MACRO,'LAMBDA . CADR U . CDDR U); SYMBOLIC PROCEDURE EXPAND(L,FN); IF NULL L THEN NIL ELSE IF NULL CDR L THEN CAR L ELSE LIST(FN,CAR L,EXPAND(CDR L,FN)); SYMBOLIC PROCEDURE M**N; BEGIN SCALAR P,Q; IF N<0 THEN RETURN (1.0/M**(-N)) ELSE IF N=0 OR M=1 THEN RETURN 1; P := 1; A: Q := DIVIDE(N,2); IF CDR Q = 0 THEN GO TO B; P := M*P; IF CAR Q = 0 THEN RETURN P; B: N := CAR Q; M := M*M; GO TO A END; SYMBOLIC PROCEDURE MAPOBL !*PI!*; FOR EACH X IN OBLIST DO FOR EACH Y IN X DO !*PI!* Y; SYMBOLIC MACRO PROCEDURE MAX U; EXPAND(CDR U,'MAX2); SYMBOLIC PROCEDURE MAX2(U,V); IF U<V THEN V ELSE U; SYMBOLIC MACRO PROCEDURE MIN U; EXPAND(CDR U,'MIN2); SYMBOLIC PROCEDURE MIN2(U,V); IF U>V THEN V ELSE U; SYMBOLIC PROCEDURE ONEP U; U=1 OR U=1.0; SYMBOLIC PROCEDURE PAIR(U,V); IF NULL U AND NULL V THEN NIL ELSE IF NULL U OR NULL V THEN ERROR(171,LIST(LIST(U,V),"mismatched - PAIR")) ELSE (CAR U . CAR V) . PAIR(CDR U,CDR V); SYMBOLIC MACRO PROCEDURE PLUS U; EXPAND(CDR U,'PLUS2); SYMBOLIC PROCEDURE SASSOC(U,V,!*PI!*); %looks for U in association list V using an EQUAL test. %If U is not found, !*PI!*() is returned; IF NULL V THEN !*PI!*() ELSE IF U=CAAR V THEN CAR V ELSE SASSOC(U,CDR V,!*PI!*); SYMBOLIC PROCEDURE SUBLIS(X,Y); BEGIN SCALAR U; IF NULL X THEN RETURN Y; U := X; A: IF NULL U THEN RETURN IF ATOM Y OR (U := SUBLIS(X,CAR Y) . SUBLIS(X,CDR Y)) = Y THEN Y ELSE U ELSE IF Y = CAAR U THEN RETURN CDAR U; U := CDR U; GO TO A END; SYMBOLIC MACRO PROCEDURE TIMES U; EXPAND(CDR U,'TIMES2); SYMBOLIC PROCEDURE QUIT; FREEZE T; END; |
Added r30/fisl.fap version [7fcc19328b].
cannot compute difference between binary files
Added r30/fisl.red version [0e12a41d69].
cannot compute difference between binary files
Added r30/hephys.fap version [799a025018].
cannot compute difference between binary files
Added r30/hephys.red version [af10fd28e1].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %********************************************************************* %********************************************************************* % HIGH ENERGY PHYSICS PACKAGE %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; %********************************************************************* % REQUIRES SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************; %********************************************************************* % NON LOCAL VARIABLES REFERENCED IN THIS PACKAGE %********************************************************************; FLUID '(!*S!*); GLOBAL '(DEFINDICES!* INDICES!* MUL!* NCMP!* NDIM!* TYPL!* !*SUB2); DEFINDICES!* := NIL; %deferred indices in N dim calculations; INDICES!* := NIL; %list of indices in High Energy Physics %tensor expressions; NDIM!* := 4; %number of dimensions in gamma algebra; COMMENT The generalizations in this package for n dimensional vector and gamma algebra are due to Gastmans, Van Proeyen and Verbaeten, University of Leuven, Belgium; %********************************************************************* % SOME DECLARATIONS %********************************************************************; DEFLIST ('((CONS SIMPDOT)),'SIMPFN); SYMBOLIC PROCEDURE VECTOR U; VECTOR1 U; SYMBOLIC PROCEDURE VECTOR1 U; <<TYPL!* := UNION('(HVECTORP),TYPL!*); FOR EACH X IN U DO PUT(X,'VECTOR,'VECTOR)>>; SYMBOLIC PROCEDURE HVECTORP U; NSP(U,'VECTOR); PUT('VECTOR,'FN,'VECFN); PUT('HVECTORP,'LETFN,'NSLET); PUT('HVECTORP,'NAME,'VECTOR); PUT('HVECTORP,'EVFN,'VEVAL); PUT('G,'SIMPFN,'SIMPGAMMA); FLAGOP NONCOM,NOSPUR; FLAG ('(G),'NONCOM); SYMBOLIC PROCEDURE INDEX U; BEGIN VECTOR1 U; RMSUBS(); INDICES!* := UNION(INDICES!*,U) END; SYMBOLIC PROCEDURE REMIND U; BEGIN INDICES!* := SETDIFF(INDICES!*,U) END; SYMBOLIC PROCEDURE MASS U; <<TYPL!* := UNION('(HVECTORP),TYPL!*); FOR EACH X IN U DO <<PUT(CADR X,'MASS,CADDR X); PUT(CADR X,'VECTOR,'VECTOR)>>>>; SYMBOLIC PROCEDURE GETMAS U; (LAMBDA X; IF X THEN X ELSE REDERR LIST(U,"has no mass")) GET!*(U,'MASS); SYMBOLIC PROCEDURE VECDIM U; BEGIN TYPL!* := UNION('(HVECTORP),TYPL!*); NDIM!* := CAR U END; SYMBOLIC PROCEDURE MSHELL U; BEGIN SCALAR X,Z; TYPL!* := UNION('(HVECTORP),TYPL!*); A: IF NULL U THEN RETURN LET0(Z,NIL); X := GETMAS CAR U; Z := LIST('EQUAL,LIST('CONS,CAR U,CAR U),LIST('EXPT,X,2)) . Z; U := CDR U; GO TO A END; RLISTAT '(VECDIM INDEX MASS MSHELL REMIND VECTOR); %********************************************************************* % FUNCTIONS FOR SIMPLIFYING HIGH ENERGY EXPRESSIONS %********************************************************************; SYMBOLIC PROCEDURE VEVAL U; BEGIN SCALAR Z; U := NSSIMP(U,'HVECTORP); A: IF NULL U THEN RETURN REPLUS Z ELSE IF NULL CDAR U THEN REDERR "Missing vector" ELSE IF CDDAR U THEN REDERR LIST("Redundant vector",CDAR U); Z := ACONC(Z,RETIMES(PREPSQ CAAR U . CDAR U)); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE VMULT U; BEGIN SCALAR Z; Z := LIST LIST(1 . 1); A: IF NULL U THEN RETURN Z; Z := VMULT1(NSSIMP(CAR U,'HVECTORP),Z); IF NULL Z THEN RETURN; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE VMULT1(U,V); BEGIN SCALAR Z; IF NULL V THEN RETURN; A: IF NULL U THEN RETURN Z ELSE IF CDDAR U THEN REDERR("Redundant vector" . CDAR U); Z := NCONC(Z,MAPCAR(V,FUNCTION (LAMBDA J; MULTSQ(CAR J,CAAR U) . APPEND(CDR J,CDAR U)))); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE SIMPDOT U; MKVARG(U,FUNCTION DOTORD); SYMBOLIC PROCEDURE DOTORD U; <<IF XNP(U,INDICES!*) AND NOT MEMQ('ISIMPQ,MUL!*) THEN MUL!* := ACONC(MUL!*,'ISIMPQ) ELSE NIL; IF 'A MEMQ U THEN REDERR "A represents only gamma5 in vector expressions" ELSE MKSQ('CONS . ORD2(CAR U,CARX(CDR U,'DOT)),1)>>; SYMBOLIC PROCEDURE MKVARG(U,V); BEGIN SCALAR Z; U := VMULT U; Z := NIL ./ 1; A: IF NULL U THEN RETURN Z; Z := ADDSQ(MULTSQ(APPLY(V,LIST CDAR U),CAAR U),Z); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE SPUR U; <<RMSUBS(); MAP(U,FUNCTION (LAMBDA J; <<REMFLAG(LIST CAR J,'NOSPUR); REMFLAG(LIST CAR J,'REDUCE)>>))>>; RLISTAT '(SPUR); SYMBOLIC PROCEDURE SIMPGAMMA !*S!*; IF NULL !*S!* OR NULL CDR !*S!* THEN REDERR "Missing arguments for G operator" ELSE BEGIN IF NOT MEMQ('ISIMPQ,MUL!*) THEN MUL!*:= ACONC(MUL!*,'ISIMPQ); NCMP!* := T; RETURN MKVARG(CDR !*S!*,FUNCTION (LAMBDA J; LIST ((('G . CAR !*S!* . J) . 1) . 1) . 1)) END; SYMBOLIC PROCEDURE SIMPEPS U; MKVARG(U,FUNCTION EPSORD); SYMBOLIC PROCEDURE EPSORD U; IF REPEATS U THEN NIL ./ 1 ELSE MKEPSQ U; SYMBOLIC PROCEDURE MKEPSK U; %U is of the form (v1 v2 v3 v4). %Value is <sign flag> . <kernel for EPS(v1,v2,v3,v4)>; BEGIN SCALAR X; IF XNP(U,INDICES!*) AND NOT 'ISIMPQ MEMQ MUL!* THEN MUL!* := ACONC(MUL!*,'ISIMPQ); X := ORDN U; U := PERMP(X,U); RETURN U . ('EPS . X) END; SYMBOLIC PROCEDURE MKEPSQ U; (LAMBDA X; (LAMBDA Y; IF NULL CAR X THEN NEGSQ Y ELSE Y) MKSQ(CDR X,1)) MKEPSK U; %********************************************************************* % FUNCTIONS FOR SIMPLIFYING VECTOR AND GAMMA MATRIX EXPRESSIONS %********************************************************************; SYMBOLIC SMACRO PROCEDURE MKG(U,L); %Value is the standard form for G(L,U); !*P2F('G . L . U TO 1); SYMBOLIC SMACRO PROCEDURE MKA L; %Value is the standard form for G(L,A); !*P2F(LIST('G,L,'A) TO 1); SYMBOLIC SMACRO PROCEDURE MKGF(U,L); MKSF('G . (L . U)); SYMBOLIC PROCEDURE MKG1(U,L); IF NOT FLAGP(L,'NOSPUR) THEN MKG(U,L) ELSE MKGF(U,L); SYMBOLIC SMACRO PROCEDURE MKPF(U,V); MULTPF(U,V); SYMBOLIC PROCEDURE MKF(U,V); MULTF(U,V); SYMBOLIC PROCEDURE MULTD!*(U,V); IF ONEP U THEN V ELSE MULTD(U,V); SYMBOLIC SMACRO PROCEDURE ADDFS(U,V); ADDF(U,V); SYMBOLIC SMACRO PROCEDURE MULTFS(U,V); %U and V are pseudo standard forms %Value is pseudo standard form for U*V; MULTF(U,V); FLUID '(NDIMS!*); SYMBOLIC PROCEDURE ISIMPQ U; BEGIN SCALAR NDIMS!*; NDIMS!* := SIMP NDIM!*; IF DENR NDIMS!* NEQ 1 THEN <<!*SUB2 := T; NDIMS!* := MULTPF(MKSP(LIST('RECIP,DENR NDIMS!*),1), NUMR NDIMS!*)>> ELSE NDIMS!* := NUMR NDIMS!*; A: U := ISIMP1(NUMR U,INDICES!*,NIL,NIL,NIL) ./ DENR U; IF DEFINDICES!* THEN <<INDICES!* := UNION(DEFINDICES!*,INDICES!*); DEFINDICES!* := NIL; GO TO A>> ELSE IF NULL !*SUB2 THEN RETURN U ELSE RETURN RESIMP U END; SYMBOLIC PROCEDURE ISIMP1(U,I,V,W,X); IF NULL U THEN NIL ELSE IF DOMAINP U THEN IF X THEN MULTD(U,SPUR0(CAR X,I,V,W,CDR X)) ELSE IF V THEN REDERR("Unmatched index" . I) ELSE IF W THEN MULTFS(EMULT W,ISIMP1(U,I,V,NIL,X)) ELSE U ELSE ADDFS(ISIMP2(CAR U,I,V,W,X),ISIMP1(CDR U,I,V,W,X)); SYMBOLIC PROCEDURE ISIMP2(U,I,V,W,X); BEGIN SCALAR Z; IF ATOM (Z := CAAR U) THEN GO TO A ELSE IF CAR Z EQ 'CONS AND XNP(CDR Z,I) THEN RETURN DOTSUM(U,I,V,W,X) ELSE IF CAR Z EQ 'G THEN GO TO B ELSE IF CAR Z EQ 'EPS THEN RETURN ESUM(U,I,V,W,X); A: RETURN MKPF(CAR U,ISIMP1(CDR U,I,V,W,X)); B: Z := GADD(APPN(CDDR Z,CDAR U),X,CADR Z); RETURN ISIMP1(MULTD!*(NB CAR Z,CDR U),I,V,W,CDR Z) END; SYMBOLIC PROCEDURE NB U; IF U THEN 1 ELSE -1; SYMBOLIC SMACRO PROCEDURE MKDOT(U,V); %Returns a standard form for U.V; MKSF('CONS . ORD2(U,V)); SYMBOLIC PROCEDURE DOTSUM(U,I,V,W,X); BEGIN SCALAR I1,N,U1,U2,V1,Y,Z; N := CDAR U; IF NOT (CAR (U1 := CDAAR U) MEMBER I) THEN U1 := REVERSE U1; U2 := CADR U1; U1 := CAR U1; V1 := CDR U; IF N=2 THEN GO TO H ELSE IF N NEQ 1 THEN REDERR U; A: IF U1 MEMBER I THEN GO TO A1 ELSE IF NULL (Z := MKDOT(U1,U2)) THEN RETURN NIL ELSE RETURN MKF(Z,ISIMP1(V1,I1,V,W,X)); A1: I1 := DELETE(U1,I); IF U1 EQ U2 THEN RETURN MULTF(NDIMS!*,ISIMP1(V1,I1,V,W,X)) ELSE IF NOT (Z := ATSOC(U1,V)) THEN GO TO C ELSE IF U2 MEMBER I THEN GO TO D; U1 := CDR Z; GO TO E; C: IF Z := MEMLIS(U1,X) THEN RETURN ISIMP1(V1, I1, V, W, SUBST(U2,U1,Z) . DELETE(Z,X)) ELSE IF Z := MEMLIS(U1,W) THEN RETURN ESUM((('EPS . SUBST(U2,U1,Z)) . 1) . V1, I1, V, DELETE(Z,W), X) ELSE IF U2 MEMBER I AND NULL Y THEN GO TO G; RETURN ISIMP1(V1,I,(U1 . U2) . V,W,X); D: U1 := U2; U2 := CDR Z; E: I := I1; V := DELETE(Z,V); GO TO A; G: Y := T; Z := U1; U1 := U2; U2 := Z; GO TO A1; H: IF U1 EQ U2 THEN REDERR U; I := I1 := DELETE(U1,I); U1 := U2; GO TO A END; SYMBOLIC PROCEDURE MKSF U; %U is a kernel. %Value is a (possibly substituted) standard form for U; BEGIN SCALAR X; X := MKSQ(U,1); IF CDR X=1 THEN RETURN CAR X; !*SUB2 := T; RETURN !*P2F(U TO 1) END; %********************************************************************* % FUNCTIONS FOR SIMPLIFYING DIRAC GAMMA MATRICES %********************************************************************; SYMBOLIC PROCEDURE GADD(U,V,L); BEGIN SCALAR W,X; INTEGER N; N := 0; %number of gamma5 interchanges; IF NOT (X := ATSOC(L,V)) THEN GO TO A; V := DELETE(X,V); W := CDDR X; %list being built; X := CADR X; %true if gamma5 remains; A: IF NULL U THEN RETURN ((REMAINDER(N,2)=0) . (L . X . W) . V) ELSE IF CAR U EQ 'A THEN GO TO C ELSE W := CAR U . W; B: U := CDR U; GO TO A; C: IF NDIMS!* NEQ 4 THEN REDERR "Gamma5 not allowed unless vecdim is 4"; X := NOT X; N := LENGTH W + N; GO TO B END; %********************************************************************* % FUNCTIONS FOR COMPUTING TRACES OF DIRAC GAMMA MATRICES %********************************************************************; SYMBOLIC PROCEDURE SPUR0(U,I,V1,V2,V3); BEGIN SCALAR L,W,I1,KAHP,N,Z; L := CAR U; N := 1; Z := CADR U; U := REVERSE CDDR U; IF Z THEN U := 'A . U; %GAMMA5 REMAINS; IF NULL U THEN GO TO END1 ELSE IF NULL FLAGP(L,'NOSPUR) THEN IF CAR U EQ 'A AND (LENGTH U<5 OR HEVENP U) OR NOT CAR U EQ 'A AND NOT HEVENP U THEN RETURN NIL ELSE IF NULL I THEN <<W := REVERSE U; GO TO END1>>; A: IF NULL U THEN GO TO END1 ELSE IF CAR U MEMBER I THEN IF CAR U MEMBER CDR U THEN <<IF CAR U EQ CADR U THEN <<I := DELETE(CAR U,I); U := CDDR U; N := MULTF(N,NDIMS!*); GO TO A>>; KAHP := T; I1 := CAR U . I1; GO TO A1>> ELSE IF CAR U MEMBER I1 THEN GO TO A1 ELSE IF Z := BASSOC(CAR U,V1) THEN <<V1 := DELETE(Z,V1); I := DELETE(CAR W,I); U := OTHER(CAR U,Z) . CDR U; GO TO A>> ELSE IF Z := MEMLIS(CAR U,V2) THEN RETURN IF FLAGP(L,'NOSPUR) AND NULL V1 AND NULL V3 AND NULL CDR V2 THEN MKF(MKGF(APPEND(REVERSE W,U),L), MULTFS(N,MKEPSF Z)) ELSE MULTD!*(N, ISIMP1(SPUR0( L . (NIL . APPEND(REVERSE U,W)),NIL,V1,DELETE(Z,V2),V3), I,NIL,LIST Z,NIL)) ELSE IF Z := MEMLIS(CAR U,V3) THEN IF NDIMS!*=4 THEN RETURN SPUR0I(U,DELETE(CAR U,I),V1,V2, DELETE(Z,V3),L,N,W,Z) ELSE <<INDICES!* := DELETE(CAR U,INDICES!*); I := DELETE(CAR U,I); IF NOT CAR U MEMQ DEFINDICES!* THEN DEFINDICES!* := CAR U . DEFINDICES!*; GO TO A1>> ELSE REDERR LIST("Unmatched index",CAR U); A1: W := CAR U . W; U := CDR U; GO TO A; END1: IF KAHP THEN IF NDIMS!*=4 THEN <<Z := MULTFS(N,KAHANE(REVERSE W,I1,L)); RETURN ISIMP1(Z,SETDIFF(I,I1),V1,V2,V3)>> ELSE Z := SPURDIM(W,I,L,NIL,1) ELSE Z := SPURR(W,L,NIL,1); RETURN IF NULL Z THEN NIL ELSE IF GET('EPS,'KLIST) AND NOT FLAGP(L,'NOSPUR) THEN ISIMP1(MULTFS(N,Z),I,V1,V2,V3) ELSE MULTFS(Z,ISIMP1(N,I,V1,V2,V3)) END; SYMBOLIC PROCEDURE SPUR0I(U,I,V1,V2,V3,L,N,W,Z); BEGIN SCALAR KAHP,I1; IF FLAGP(L,'NOSPUR) AND FLAGP(CAR Z,'NOSPUR) THEN ERRACH "This NOSPUR option not implemented" ELSE IF FLAGP(CAR Z,'NOSPUR) THEN KAHP := CAR Z; Z := CDR Z; I1 := CAR Z; Z := REVERSE CDR Z; IF I1 THEN Z := 'A . Z; I1 := NIL; <<WHILE NULL (CAR U EQ CAR Z) DO <<I1 := CAR Z . I1; Z := CDR Z>>; Z := CDR Z; U := CDR U; IF FLAGP(L,'NOSPUR) THEN <<W := W . (U . (I1 . Z)); I1 := CAR W; Z := CADR W; U := CADDR W; W := CDDDR W>>; W := REVERSE W; IF NULL ((NULL U OR NOT EQCAR(W,'A)) AND (U := APPEND(U,W))) THEN <<IF NOT HEVENP U THEN N := - N; U := 'A . APPEND(U,CDR W)>>; IF KAHP THEN L := KAHP; Z := MKF(MKG(REVERSE I1,L), MULTF(BRACE(U,L,I),MULTFS(N,MKG1(Z,L)))); Z := ISIMP1(Z,I,V1,V2,V3); IF NULL Z OR (Z := QUOTF(Z,2)) THEN RETURN Z ELSE ERRACH LIST('SPUR0,N,I,V1,V2,V3)>> END; SYMBOLIC PROCEDURE SPURDIM(U,I,L,V,N); BEGIN SCALAR W,X,Y,Z,Z1; INTEGER M; A: IF NULL U THEN RETURN IF NULL V THEN N ELSE IF FLAGP(L,'NOSPUR) THEN MULTFS(N,MKGF(V,L)) ELSE MULTFS(N,SPRGEN V) ELSE IF NOT(CAR U MEMQ CDR U) THEN <<V := CAR U . V; U := CDR U; GO TO A>>; X := CAR U; Y := CDR U; W := Y; M := 1; B: IF X MEMQ I THEN GO TO D ELSE IF NOT X EQ CAR W THEN GO TO C ELSE IF NULL(W := MKDOT(X,X)) THEN RETURN Z; IF X MEMQ I THEN W := NDIMS!*; RETURN ADDFS(MKF(W,SPURDIM(DELETE(X,Y),I,L,V,N)),Z); C: Z1 := MKDOT(X,CAR W); IF CAR W MEMQ I THEN Z := ADDFS(SPURDIM(SUBST(X,CAR W,REMOVE(Y,M)), I,L,V,2*N),Z) ELSE IF Z1 THEN Z := ADDFS(MKF(Z1,SPURDIM(REMOVE(Y,M),I,L,V,2*N)),Z); W := CDR W; N := -N; M := M+1; GO TO B; D: WHILE NOT(X EQ CAR W) DO <<Z:= ADDFS(SPURDIM(SUBST(CAR W,X,REMOVE(Y,M)),I,L,V,2*N),Z); W := CDR W; N := -N; M := M+1>>; RETURN ADDFS(MKF(NDIMS!*,SPURDIM(DELETE(X,Y),I,L,V,N)),Z) END; SYMBOLIC PROCEDURE APPN(U,N); IF N=1 THEN U ELSE APPEND(U,APPN(U,N-1)); SYMBOLIC PROCEDURE OTHER(U,V); IF U EQ CAR V THEN CDR V ELSE CAR V; SYMBOLIC PROCEDURE KAHANE(U,I,L); %The Kahane algorithm for Dirac matrix string reduction %Ref: Kahane, J., Journ. Math. Phys. 9 (1968) 1732-1738; BEGIN SCALAR P,R,V,W,X,Y,Z; INTEGER K,M; K := 0; MARK: IF EQCAR(U,'A) THEN GO TO A1; A: P := NOT P; %vector parity; IF NULL U THEN GO TO D ELSE IF CAR U MEMBER I THEN GO TO C; A1: W := ACONC(W,CAR U); B: U := CDR U; GO TO A; C: Y := CAR U . P; Z := (X . (Y . W)) . Z; X := Y; W := NIL; K := K+1; GO TO B; D: Z := (NIL . (X . W)) . Z; %BEWARE ... END OF STRING HAS OPPOSITE CONVENTION; PASS2: M := 1; L1: IF NULL Z THEN GO TO L9; U := CAAR Z; X := CADAR Z; W := CDDAR Z; Z := CDR Z; M := M+1; IF NULL U THEN GO TO L2 ELSE IF (CAR U EQ CAR X) AND EXC(X,CDR U) THEN GO TO L7; W := REVERSE W; R := T; L2: P := NOT EXC(X,R); X := CAR X; Y := NIL; L3: IF NULL Z THEN REDERR("Unmatched index" . IF Y THEN IF NOT ATOM CADAR Y THEN CADAR Y ELSE IF NOT ATOM CAAR Y THEN CAAR Y ELSE NIL ELSE NIL) ELSE IF (X EQ CAR (I := CADAR Z)) AND NOT EXC(I,P) THEN GO TO L5 ELSE IF (X EQ CAR (I := CAAR Z)) AND EXC(I,P) THEN GO TO L4; Y := CAR Z . Y; Z := CDR Z; GO TO L3; L4: X := CADAR Z; W := APPR(CDDAR Z,W); R := T; GO TO L6; L5: X := CAAR Z; W := APPEND(CDDAR Z,W); R := NIL; L6: Z := APPR(Y,CDR Z); IF NULL X THEN GO TO L8 ELSE IF NOT EQCAR(U,CAR X) THEN GO TO L2; L7: IF W AND CDR U THEN W := ACONC(CDR W,CAR W); V := MULTFS(BRACE(W,L,NIL),V); %V := ('BRACE . L . W) . V; GO TO L1; L8: V := MKG(W,L); %V := LIST('G . L . W); Z := REVERSE Z; K := K/2; GO TO L1; L9: U := 2**K; IF NOT (REMAINDER(K-M,2) = 0) THEN U := - U; RETURN MULTD!*(U,V) %RETURN 'TIMES . U . V; END; SYMBOLIC PROCEDURE APPR(U,V); IF NULL U THEN V ELSE APPR(CDR U,CAR U . V); SYMBOLIC PROCEDURE EXC(U,V); IF NULL CDR U THEN V ELSE NOT V; SYMBOLIC PROCEDURE BRACE(U,L,I); IF NULL U THEN 2 ELSE IF XNP(I,U) OR FLAGP(L,'NOSPUR) THEN ADDF(MKG1(U,L),MKG1(REVERSE U,L)) ELSE IF CAR U EQ 'A THEN IF HEVENP U THEN ADDFS(MKG(U,L), NEGF MKG('A . REVERSE CDR U,L)) ELSE MKF(MKA L,SPR2(CDR U,L,2,NIL)) ELSE IF HEVENP U THEN SPR2(U,L,2,NIL) ELSE SPR1(U,L,2,NIL); SYMBOLIC PROCEDURE SPR1(U,L,N,B); IF NULL U THEN NIL ELSE IF NULL CDR U THEN MULTD!*(N,MKG1(U,L)) ELSE BEGIN SCALAR M,X,Z; X := U; M := 1; A: IF NULL X THEN RETURN Z; Z:= ADDFS(MKF(MKG1(LIST CAR X,L), IF NULL B THEN SPURR(REMOVE(U,M),L,NIL,N) ELSE SPR1(REMOVE(U,M),L,N,NIL)), Z); X := CDR X; N := - N; M := M+1; GO TO A END; SYMBOLIC PROCEDURE SPR2(U,L,N,B); IF NULL CDDR U AND NULL B THEN MULTD!*(N,MKDOT(CAR U,CADR U)) ELSE (LAMBDA X; IF B THEN ADDFS(SPR1(U,L,N,B),X) ELSE X) ADDFS(SPURR(U,L,NIL,N), MKF(MKA L,SPURR(APPEND(U,LIST 'A),L,NIL,N))); SYMBOLIC PROCEDURE HEVENP U; NULL U OR NOT HEVENP CDR U; SYMBOLIC PROCEDURE BASSOC(U,V); IF NULL V THEN NIL ELSE IF U EQ CAAR V OR U EQ CDAR V THEN CAR V ELSE BASSOC(U,CDR V); SYMBOLIC PROCEDURE MEMLIS(U,V); IF NULL V THEN NIL ELSE IF U MEMBER CAR V THEN CAR V ELSE MEMLIS(U,CDR V); SYMBOLIC PROCEDURE SPURR(U,L,V,N); BEGIN SCALAR W,X,Y,Z,Z1; INTEGER M; A: IF NULL U THEN GO TO B ELSE IF CAR U MEMBER CDR U THEN GO TO G; V := CAR U . V; U := CDR U; GO TO A; B: RETURN IF NULL V THEN N ELSE IF FLAGP(L,'NOSPUR) THEN MULTD!*(N,MKGF(V,L)) ELSE MULTD!*(N,SPRGEN V); G: X := CAR U; Y := CDR U; W := Y; M := 1; H: IF NOT X EQ CAR W THEN GO TO H1 ELSE IF NULL(W:= MKDOT(X,X)) THEN RETURN Z ELSE RETURN ADDFS(MKF(W,SPURR(DELETE(X,Y),L,V,N)),Z); H1: Z1 := MKDOT(X,CAR W); IF Z1 THEN Z:= ADDFS(MKF(Z1,SPURR(REMOVE(Y,M),L,V,2*N)),Z); W := CDR W; N := - N; M := M+1; GO TO H END; SYMBOLIC PROCEDURE SPRGEN V; BEGIN SCALAR X,Y,Z; IF NOT (CAR V EQ 'A) THEN RETURN SPRGEN1(V,T) ELSE IF NULL (X := COMB(V := CDR V,4)) THEN RETURN NIL ELSE IF NULL CDR X THEN GO TO E; C: IF NULL X THEN RETURN MULTPF('I TO 1,Z); Y := MKEPSF CAR X; IF ASIGN(CAR X,V,1)=-1 THEN Y := NEGF Y; Z := ADDF(MULTF(Y,SPRGEN1(SETDIFF(V,CAR X),T)),Z); D: X := CDR X; GO TO C; E: Z := MKEPSF CAR X; GO TO D END; SYMBOLIC PROCEDURE ASIGN(U,V,N); IF NULL U THEN N ELSE ASIGN(CDR U,V,ASIGN1(CAR U,V,-1)*N); SYMBOLIC PROCEDURE ASIGN1(U,V,N); IF U EQ CAR V THEN N ELSE ASIGN1(U,CDR V,-N); SYMBOLIC PROCEDURE SPRGEN1(U,B); IF NULL U THEN NIL ELSE IF NULL CDDR U THEN (LAMBDA X; IF B THEN X ELSE NEGF X) MKDOT(CAR U,CADR U) ELSE BEGIN SCALAR W,X,Y,Z; X := CAR U; U := CDR U; Y := U; A: IF NULL U THEN RETURN Z ELSE IF NULL(W:= MKDOT(X,CAR U)) THEN GO TO C; Z := ADDF(MULTF(W,SPRGEN1(DELETE(CAR U,Y),B)),Z); C: B := NOT B; U := CDR U; GO TO A END; %********************************************************************* % FUNCTIONS FOR EPSILON ALGEBRA %********************************************************************; PUT('EPS,'SIMPFN,'SIMPEPS); SYMBOLIC PROCEDURE MKEPSF U; (LAMBDA X; (LAMBDA Y; IF NULL CAR X THEN NEGF Y ELSE Y) MKSF CDR X) MKEPSK U; SYMBOLIC PROCEDURE ESUM(U,I,V,W,X); BEGIN SCALAR Y,Z,Z1; Z := CAR U; U := CDR U; IF CDR Z NEQ 1 THEN U := MULTF(EXPTF(MKEPSF CDAR Z,CDR Z-1),U); Z := CDAR Z; A: IF REPEATS Z THEN RETURN; B: IF NULL Z THEN RETURN ISIMP1(U,I,V,REVERSE Y . W,X) ELSE IF NOT (CAR Z MEMBER I) THEN GO TO D ELSE IF NOT (Z1 := BASSOC(CAR Z,V)) THEN GO TO C; V := DELETE(Z1,V); I := DELETE(CAR Z,I); Z := APPEND(REVERSE Y,OTHER(CAR Z,Z1) . CDR Z); Y := NIL; GO TO A; C: IF Z1 := MEMLIS(CAR Z,W) THEN GO TO C1 ELSE RETURN ISIMP1(U,I,V,APPEND(REVERSE Y,Z) . W,X); C1: Z := APPEND(REVERSE Y,Z); Y := XN(I,XN(Z,Z1)); RETURN ISIMP1(MULTFS(EMULT1(Z1,Z,Y),U), SETDIFF(I,Y), V, DELETE(Z1,W), X); D: Y := CAR Z . Y; Z := CDR Z; GO TO B END; SYMBOLIC PROCEDURE EMULT U; IF NULL CDR U THEN MKEPSF CAR U ELSE IF NULL CDDR U THEN EMULT1(CAR U,CADR U,NIL) ELSE MULTFS(EMULT1(CAR U,CADR U,NIL),EMULT CDDR U); SYMBOLIC PROCEDURE EMULT1(U,V,I); (LAMBDA (X,Y); (LAMBDA (M,N); IF M=4 THEN 24*N ELSE IF M=3 THEN MULTD(6*N,MKDOT(CAR X,CAR Y)) ELSE MULTD!*(N*(IF M = 0 THEN 1 ELSE M), CAR DETQ MAPLIST(X, FUNCTION (LAMBDA K; MAPLIST(Y, FUNCTION (LAMBDA J; MKDOT(CAR K,CAR J) . 1)))))) (LENGTH I, (LAMBDA J; NB IF PERMP(U,APPEND(I,X)) THEN NOT J ELSE J) PERMP(V,APPEND(I,Y)))) (SETDIFF(U,I),SETDIFF(V,I)); END; |
Added r30/instal.doc version [d5b1cd3805].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | REDUCE INSTALLATION GUIDE FOR THE DECSYSTEMS 10 AND 20 Version 3.0 by Anthony C. Hearn The Rand Corporation Santa Monica, CA 90406 USA April 1983 ABSTRACT This guide describes the DECSYSTEM REDUCE distribution tape and procedures for installing, testing and maintaining REDUCE on a DECSYSTEM 10 or 20 running TOPS-10 or TOPS-20. Rand Publication CP79(4/83) Copyright (c) 1983 The Rand Corporation _T_A_B_L_E__O_F__C_O_N_T_E_N_T_S 1. INTRODUCTION ........................................................ 1 2. DESCRIPTION OF THE DECSYSTEM REDUCE DISTRIBUTION TAPE ............... 1 3. INSTALLING REDUCE ................................................... 1 3.1 Assembly of the LISP Interpreter .......................... 2 3.2 Assembly of REDUCE ........................................ 3 3.3 Making REDUCE Accessible to Users ......................... 4 4. PRINTING DOCUMENTS .................................................. 4 5. TESTING REDUCE ...................................................... 4 6. RUNNING REDUCE PROGRAMS ............................................. 5 7. WORKING WITH MINIMAL DISK SPACE ..................................... 5 8. REBUILDING REDUCE FASL FILES ........................................ 6 9. PROGRAM REGISTRATION ................................................ 6 10. INQUIRIES AND REPORTING OF ERRORS .................................. 7 REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 1 1. _I_N_T_R_O_D_U_C_T_I_O_N This guide describes the DECSYSTEM REDUCE distribution tape and procedures for installing, testing and maintaining REDUCE on a DECSYSTEM 10 or 20 running TOPS-10 or TOPS-20. The distributed version of REDUCE requires at least 140 pages of memory in order to run effectively. The job times given in this guide are for a DECSYSTEM 2060T running REDUCE with a 230 page memory partition. The following adjustment factors for other machines have been found to apply. KA-10 6.7 2040 3.3 KI-10 3.3 KL-10 1.0 These factors are however approximate and will vary according to machine con- figuration and memory speeds. 2. _D_E_S_C_R_I_P_T_I_O_N__O_F__T_H_E__D_E_C_S_Y_S_T_E_M__R_E_D_U_C_E__D_I_S_T_R_I_B_U_T_I_O_N__T_A_P_E The distribution tape is in DUMPER (BACKUP) format and recorded in interchange mode at a density of 1600 bpi. The files are organized into groups with the following structure: DOC REDUCE documents, all with an extension DOC, including: instal.doc Installation instructions (i.e., this document) reduce.doc REDUCE User's Manual sl.doc Standard LISP Report sldec.doc Manual for Standard LISP on DECSYSTEM 10 and 20 tops10.doc System specific operation notes. tops20.doc EXE reduce.exe, the REDUCE executable file. FASL Fast loading LISP files for loading REDUCE functions, all with the extension FAP. SRC MACRO and RLISP sources for creating LISP and REDUCE. These files have the extensions MAC, RED and SL. UTIL Macro Interpreted Command facility scripts for building REDUCE, etc. XMPL REDUCE examples, tests, demonstrations and the interactive lessons. The lessons have names LESS1 through LESS7 with no extension. Other such files have the extension TST. 3. _I_N_S_T_A_L_L_I_N_G__R_E_D_U_C_E To install REDUCE, you need to create a directory for the REDUCE file system. A good name for this under TOPS-20 is <reduce>, which will be used to describe REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 2 it from now on. Connect to this directory, mount the tape and give the fol- lowing commands: TMOUNT MTA: MYTAPE:/REELID:name of tape DUMPER (or R BACKUP on TOPS-10 machines) TAPE MYTAPE INTERCHANGE DEN 1600 RESTORE *.* EXIT This will retrieve all the files on the tape, and requires approximately the following pages of disk space, in 512K bytes: DOC 200 EXE 200 FASL 330 SRC 500 UTIL 10 XMPL 60 ---- total 1300 If you are running on a computer using Release 4 or later of TOPS-20, and no source updates are necessary, then you are now ready to run REDUCE and its supporting Standard LISP system. In this case, you can proceed to the section "Making REDUCE Accessible to Users". Otherwise you must assemble the Standard LISP interpreter and build the REDUCE executable file as described in the fol- lowing sub-sections. 3.1 _A_s_s_e_m_b_l_y__o_f__t_h_e__L_I_S_P__I_n_t_e_r_p_r_e_t_e_r To assemble the Standard LISP interpreter, the following two steps are neces- sary: 1) Using a suitable editor, look for the line "OPSYS is set here" in the file LISP.MAC. This is approximately 400 lines from the beginning of the file. Change the following lines to give OPSYS the appropriate value for your system. These values are: OPSYS==-1 TOPS-20 (the default) OPSYS==0 TOPS-10 OPSYS==1 TENEX 2) Build the LISP execute file LISP.EXE by the following sequence of commands: LOAD LISP SAVE (or SAVE LISP 12 under TOPS-10) This assembly takes about 60 seconds to complete on the DECSYSTEM 2060 described earlier. If this assembly is done on a machine running the TOPS-20AN (Arpanet) monitor, a message "Multiply defined global symbol CLOSE" may be printed. This is due REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 3 to the presence of a JSYS CLOSE in the TCP/IP enhancements that conflicts with the LISP function CLOSE in the assembler. This conflict causes no harm, and can therefore be ignored. 3.2 _A_s_s_e_m_b_l_y__o_f__R_E_D_U_C_E In the following narrative, user input is shown in lower case and system out- put in upper case. Except where noted, user input terminates with a carriage return. For TOPS-10, the following sequence of commands is used: .as dsk: sys: DSK ASSIGNED .r lisp 70 ALLOCATE? y SYS: <cr> FWDS=7000<space> BPS.=100000<space> SPDL=600<space> RPDL=600<space> HASH=475<space> STANDARD LISP (APRIL 1983) *(setq fislsize 1500) 1500 *(load rlisp rend alg1 alg2 rend2 entry) NIL *(excise) T *(quit) .save reduce REDUCE SAVED For TOPS-20, the following sequence is used: @def sys: <reduce>,sys: @lisp ALLOCATE? y CORE (K): 60<space> SYS: <space> FWDS=12000<space> SPDL=600<space> RPDL=600<space> REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 4 HASH=475<space> STANDARD LISP (APRIL 1983) *(load rlisp rend alg1 alg2 rend2 entry) NIL *(excise) T *(quit) @save reduce REDUCE.EXE.1 SAVED This assembly takes about 10 seconds. For those systems that support the Macro Interpreted Commands facility, the file group UTIL contains a number of files that can be used to facilitate the building process. In particular, the files mkred1.mic and mkred2.mic can be used to perform the above assembly for TOPS-10 and TOPS-20 respectively. For example, to build REDUCE under TOPS-20, you would say do mkred2 3.3 _M_a_k_i_n_g__R_E_D_U_C_E__A_c_c_e_s_s_i_b_l_e__t_o__U_s_e_r_s In order to make REDUCE accessible to them, users should be instructed to include <reduce> in their SYS: pathname by a system command such as def sys: <reduce>,sys: Alternatively, the file reduce.exe and the files in the group FASL (i.e., those with the extension fap) should be moved to a SYS: directory. The FASL files must be moved since they are needed during REDUCE runs. 4. _P_R_I_N_T_I_N_G__D_O_C_U_M_E_N_T_S A number of documents relating to the assembly and running of LISP and REDUCE are included in the file group DOC. The documents are pagenated and formatted with standard ASCII control characters and may therefore be printed by stan- dard printing programs. A maximum page length of 60 lines is assumed. Note also that the left margin offset must be supplied by the user. 5. _T_E_S_T_I_N_G__R_E_D_U_C_E To test the REDUCE installation, the following job should be run: Under TOPS-10: Under TOPS-20: .r reduce 140 @reduce REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 5 REDUCE 3.0, 15-Apr-83 REDUCE 3.0, 15-Apr-83 *in "reduce.tst"; *core 70; *in "reduce.tst"; This requires about 25 seconds on the DEC 2060 as described above. If the out- put is directed to a file (by a command such as "out out;"), this time is reduced to about 16 seconds. Other programs for testing the REDUCE system assembly may also be found in the file group XMPL. 6. _R_U_N_N_I_N_G__R_E_D_U_C_E__P_R_O_G_R_A_M_S Once reduce.exe has been placed on the user's search path, REDUCE is simply invoked with its name: reduce REDUCE will respond with a banner line and then prompt for the first line of input: reduce 3.0, 15-Apr-83 ... 1: Prototypical instructions for using the TOPS-10 and TOPS-20 versions of REDUCE are available as the files tops10.doc and tops-20.doc respectively. You should edit the appropriate version to reflect your site-specific implementa- tion before issuing it to users. See also the REDUCE User's Manual for further details. 7. _W_O_R_K_I_N_G__W_I_T_H__M_I_N_I_M_A_L__D_I_S_K__S_P_A_C_E Many of the REDUCE system files are not necessary for the running of REDUCE. In situations where disk space is at a premium, the following files may be deleted from disk: -all files in the groups DOC, SRC, UTIL and XMPL, -the files alg1.fap, alg2.fap, entry.fap, rend.fap, rend2.fap and rlisp.fap from the file group FASL. Although the file groups DOC and XMPL are not necessary, it is advisable to leave at least the REDUCE manual, TOP-10 or TOPS-20 operating instructions and the REDUCE interactive lessons on-line for users. REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 6 8. _R_E_B_U_I_L_D_I_N_G__R_E_D_U_C_E__F_A_S_L__F_I_L_E_S Because of its organization into independently compilable modules, the current REDUCE system is fairly easy to maintain. If any source updates are necessary, they can be incorporated into the appropriate files using a convenient editor. Once any of the system source files have been updated, it is necessary to rebuild the equivalent fast loading modules in order to utilize the changes. The following job will achieve this: .r reduce 140 (or "reduce" under TOPS-20) REDUCE 3.0, 15-Apr-83 ... *core 70; (TOPS-20 only) *symbolic; *faslout <filename>; <system message> *in "<filename>.red"$ *faslend; where <filename> is the name of the source file (eg, alg1). A MIC script is also available for this purpose. This is called as follows: do mkfas1 <filename> (TOPS-10) or do mkfas2 <filename> (TOPS-20). If the modules ALG1, ALG2, ENTRY, FEND, FISL, REND, REND2 or RLISP have been changed, then the REDUCE execute file must be rebuilt (see the section "Assem- bly of REDUCE"). Since all other modules are loaded on demand, one simply needs to ensure that the updated FASL files are on the appropriate directory to complete the update. 9. _P_R_O_G_R_A_M__R_E_G_I_S_T_R_A_T_I_O_N After installing REDUCE, fill out the accompanying registration form and send to: Dr. Anthony C.Hearn The Rand Corporation 1700 Main Street Santa Monica, CA 90406 Telephone (213) 393-0411. This should be done so that you can be advised direct of any changes which are made to the system. Persons receiving REDUCE from sources other than the REDUCE Installation Guide for DECSYSTEMS 10 and 20 Page 7 Rand Corporation are particularly requested to follow this procedure. The test time requested on the registration form is the time printed by the final call of SHOWTIME in the output from the test described in the section "Testing REDUCE". 10. _I_N_Q_U_I_R_I_E_S__A_N_D__R_E_P_O_R_T_I_N_G__O_F__E_R_R_O_R_S Any enquiries regarding the assembly or operation of REDUCE should also be directed to the above address. Suspected errors should be accompanied by the relevant job output and a copy of the input source. REDUCE REGISTRATION FORM After installing REDUCE, please fill out this form and send to the address listed at the bottom. This should be done so that you can be advised direct of any changes made to the system. Persons receiving REDUCE from sources other than the Rand Corporation are particularly requested to follow this procedure. Contact Person ______________________________________________ Date__________ Title ______________________________________________ Organization ______________________________________________ Address ______________________________________________ City, State ______________________________________________ Zip___________ Telephone ______________________________________________ Ext___________ Network Address______________________________________________ (ARPANET, CSNET or UUCP, if available) COMPUTER DESCRIPTION Vendor ___________ Model _____________ Operating System _________________ Equivalent, if not DECSYSTEM, IBM or VAX ___________________________________ TIMING Please indicate the test time as printed by the final call of SHOWTIME in the output from the installation test described in the section "Testing REDUCE", of the REDUCE Installation Guide. Also give the total system time, region (virtual) and real system memory available, if known and applicable. Time ___________ Total System Time ___________ Region ___________ Real System Memory ___________ Please also write on the back of this form any comments you may have about the installation procedure, and system documentation and performance. If you would like to be listed in a published registry of REDUCE system holders, please check here ___. Mail this completed form to: Dr. Anthony C. Hearn The Rand Corporation 1700 Main Street Santa Monica, CA 90406 |
Added r30/int.fap version [99e5ba929f].
cannot compute difference between binary files
Added r30/int.red version [3c98ef9665].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 | COMMENT REDUCE INTEGRATION PACKAGE WITHOUT ALGEBRAIC EXTENSIONS; COMMENT Messages look better if one does OFF RAISE; OFF ECHO; SYMBOLIC; FLAG('(INTERR),'TRANSFER); %For the compiler; COMMENT SMACRO's needed to support Cambridge LISP constructs; SMACRO PROCEDURE EVENP X; REMAINDER(X,2)=0; SMACRO PROCEDURE GCD(U,V); GCDN(U,V); INFIX IEQUAL; SYMBOLIC SMACRO PROCEDURE U IEQUAL V; EQN(U,V); SMACRO PROCEDURE READCLOCK; TIME(); SMACRO PROCEDURE REVERSEWOC U; REVERSIP U; SMACRO PROCEDURE SUPERPRINT U; PRETTYPRINT U; %the next two are needed since arguments may not be numbers; SMACRO PROCEDURE ONEP U; U=1; SMACRO PROCEDURE ZEROP U; U=0; COMMENT The following three smacros can be used if there is a reason for not using actual vectors; %SMACRO PROCEDURE MKVECT N; %MKNILL(N+1); %SMACRO PROCEDURE PUTV(U,N,V); %CAR RPLACA(PNTH(U,N+1),V); %SMACRO PROCEDURE GETV(U,N); %NTH(U,N+1); COMMENT End of Cambridge LISP compatibility section; FLUID '(LORDER SILLIESLIST VARLIST); GLOBAL '(GENSYMCOUNT); SYMBOLIC SMACRO PROCEDURE !*F2POL U; %U is a standard form; %Value is a polynomial form after power substitutions made; %If a quotient results from substitutions, an error occurs; !*Q2F SUBS2F U; SYMBOLIC SMACRO PROCEDURE !*MULTF!*(U,V); MULTF(U,V); SYMBOLIC PROCEDURE FLATTEN U; IF NULL U THEN NIL ELSE IF ATOM U THEN LIST U ELSE IF ATOM CAR U THEN CAR U . FLATTEN CDR U ELSE NCONC(FLATTEN CAR U,FLATTEN CDR U); SYMBOLIC PROCEDURE GENSYM1 U; << GENSYMCOUNT:=GENSYMCOUNT+1; COMPRESS APPEND(EXPLODE U,EXPLODE GENSYMCOUNT) >>; SYMBOLIC SMACRO PROCEDURE PRINTC X; PRIN2T X; SYMBOLIC PROCEDURE MKNILL N; IF N=0 THEN NIL ELSE NIL . MKNILL(N-1); SYMBOLIC PROCEDURE SQRT N; % return sqrt of n if same is exact, or something non-numeric % otherwise; IF NOT NUMBERP N THEN 'NONNUMERIC ELSE IF N<0 THEN 'NEGATIVE ELSE IF FLOATP N THEN SQRT!-FLOAT N ELSE IF N<2 THEN N ELSE NR(N,(N+1)/2); SYMBOLIC PROCEDURE NR(N,ROOT); % root is an overestimate here. nr moves downwards to root; BEGIN SCALAR W; W:=ROOT*ROOT; IF N=W THEN RETURN ROOT; W:=(ROOT+N/ROOT)/2; IF W>=ROOT THEN RETURN !*P2F MKSP(MKSQRT N,1); RETURN NR(N,W) END; GLOBAL '(SQRT!-FLOAT!-TOLERANCE); SQRT!-FLOAT!-TOLERANCE := 0.00001; SYMBOLIC PROCEDURE SQRT!-FLOAT N; % Simple Newton-Raphson floating point square root calculator. % Not warranted against truncation errors, etc; BEGIN INTEGER SCALE; SCALAR ANS; IF N<0.0 THEN REDERR "SQRT!-FLOAT GIVEN NEGATIVE ARGUMENT"; % Scale argument to within 1e-10 to 1e+10; SCALE := 0; WHILE N > 1E+10 DO << SCALE := SCALE + 1; N := N/1E+10 >>; WHILE N < 1E-10 DO << SCALE := SCALE - 1; N := N*1E-10 >>; ANS := IF N>2.0 THEN (N+1)/2 ELSE IF N<0.5 THEN 2/(N+1) ELSE N; WHILE ABS(ANS**2/N - 1.0) > SQRT!-FLOAT!-TOLERANCE DO ANS := 0.5*(ANS+N/ANS); RETURN ANS*10**(5*SCALE) END; COMMENT Kludge to define derivative of an integral; SYMBOLIC PUT('DF,'OPMTCH,'(((INT !&Y !&X) !&X) (NIL . T) (EVL!* !&Y) NIL) . GET('DF,'OPMTCH)); GLOBAL '(FRLIS!*); SYMBOLIC FRLIS!* := '!&X . '!&Y . FRLIS!*; SYMBOLIC IF NOT GETD 'MODBIND THEN <<PUT('EVL!*,'OPMTCH,'(((!&X) (NIL . T) !&X NIL))); PUT('EVL!*,'SIMPFN,'SIMPIDEN)>>; % MKOP 'SQRT>>; %distinguish between mode and non-mode system; ALGEBRAIC; %FOR ALL X LET SQRT X**2=X; SYMBOLIC; COMMENT support for module use; GLOBAL '(EXPORTSLIST!* IMPORTSLIST!* !*MODULEP); DEFLIST('((EXPORTS RLIS) (IMPORTS RLIS) (MODULE RLIS) (ENDMODULE ENDSTAT)),'STAT); SYMBOLIC PROCEDURE EXPORTS U; BEGIN EXPORTSLIST!* := UNION(U,EXPORTSLIST!*); END; SYMBOLIC PROCEDURE IMPORTS U; BEGIN IMPORTSLIST!* := UNION(U,IMPORTSLIST!*); END; SYMBOLIC PROCEDURE MODULE U; %Sets up a module definition; BEGIN !*MODULEP := T; END; SYMBOLIC PROCEDURE ENDMODULE; BEGIN EXPORTSLIST!* := NIL; IMPORTSLIST!* := NIL; !*MODULEP := NIL END; %**********************************************************************; % SET REDUCE AND LISP OPTIONS ONCE AND FOR ALL; %ON COMP; % ALL FLUID VARIABLES ARE DECLARED HERE; FLUID '(CONTENT SQFR ZLIST INDEXLIST SQRTLIST )$ FLUID '(!*MCD !*GCD !*EXP !*SQRT !*STRUCTURE); FLUID '( PT ULIST REDUCTIONEQ LOGLIST CLIST CCOUNT CVAL CMAP TANLIST LHS BADPART CUBEROOTFLAG VARLIST CLOGFLAG EXPRESSION RESIDUE VARIABLE ORDEROFELIM CMATRIX DENOMINATOR TAYLORVARIABLE !*PURERISCH !*NOLNR); %FLAGS TO BE SET USING 'ON' AND 'OFF' STATEMENTS; GLOBAL '(!*RATINTSPECIAL !*TRINT !*SEPLOGS !*FAILHARD !*TRDIV !*STATISTICS !*NUMBER!* !*SPSIZE!* BTRLEVEL !*GENSYMLIST!*); BTRLEVEL:=5; %DEFAULT TO A REASONABLY FULL BACKTRACE; ON SEPLOGS;%,OVERLAYMODE; %TOPLEVELCODE:='(COMPILER RLISP APROC); %**********************************************************************; SMACRO PROCEDURE FIRSTSUBS U; CAR U; % THE FIRST SUBSTITUTION IN A SUBSTITUTION LIST; SMACRO PROCEDURE RSUBS U; CDR U; SMACRO PROCEDURE LSUBS U; CAR U; % THE ABOVE TWO FUNCTIONS DEFINE LEFT AND RIGHT HALVES OF A % SUBSTITUTION RULE; SMACRO PROCEDURE LFIRSTSUBS U; CAAR U; SMACRO PROCEDURE RFIRSTSUBS U; CDAR U; % SOME COMBINATIONS OF THE ABOVE; SMACRO PROCEDURE ARGOF U; CADR U; % THE ARGUMENT OF A UNARY FUNCTION; FLAG ('(ATAN DILOG ERF EXPINT EXPT LOG TAN),'TRANSCENDENTAL); ALGEBRAIC; %Patterns for integration of various logarithmic cases; %FOR ALL X,A,B,C,D LET INT(LOG(A*X+B)/(C*X+D),X)= % LOG(C*X+D)*LOG(B*C-A*D)/C - LOG C*LOG(C*X+D)/C % - DILOG((A*C*X+B*C)/(B*C-A*D))/C; %% A=1; %FOR ALL X,B,C,D LET INT(LOG(X+B)/(C*X+D),X)= % LOG(C*X+D)*(LOG(B*C-D)-LOG C)/C -DILOG((C*X+B*C)/(B*C-D))/C; %% B=0; %FOR ALL X,A,C,D LET INT(LOG(A*X)/(C*X+D),X)= % LOG(C*X+D)*(LOG(-1)+LOG(A)+LOG(D)-LOG C)/C - DILOG(-C*X/D)/C; %% C=1; %FOR ALL X,A,B,D LET INT(LOG(A*X+B)/(X+D),X)= % LOG(X+D)*LOG(B-A*D)-DILOG((A*X+B)/(B-A*D)); %% D=0; %FOR ALL X,A,B,C LET INT(LOG(A*X+B)/(C*X),X)= % LOG(C*X)*LOG(B)/C - DILOG((A*X+B)/B)/C; %% A=1, B=0; %FOR ALL X,C,D LET INT(LOG(X)/(C*X+D),X)= % LOG(C*X+D)*(LOG(-1)+LOG(D)-LOG(C))/C - DILOG(-C*X/D)/C; %% A=1, C=1; %FOR ALL X,B,D LET INT(LOG(X+B)/(X+D),X)= % LOG(X+D)*LOG(B-D) - DILOG((X+B)/(B-D)); %% A=1, D=0; %FOR ALL X,B,C LET INT(LOG(X+B)/(C*X),X)= % LOG(C*X)*LOG(B)/C - DILOG((X+B)/B)/C; %% B=0, C=1; %FOR ALL X,A,D LET INT(LOG(A*X)/(X+D),X)= % LOG(X+D)*(LOG(-1)+LOG(A)+LOG(D)) - DILOG(-X/D); %% C=1, D=0; %FOR ALL X,A,B LET INT(LOG(A*X+B)/X,X)= % LOG(X+D)*(LOG(-1)+LOG(D)) - DILOG(-X/D); %% A=1, C=1, D=0; %FOR ALL X,B LET INT(LOG(X+B)/X,X)= % LOG(X)*LOG(B) - DILOG((X+B)/B); %% A=1, B=0, C=1; %FOR ALL X,D LET INT(LOG(X)/(X+D),X)= % LOG(X+D)*(LOG(-1)+LOG(D)) - DILOG(-X/D); % LISP; !*NOLNR:=NIL; MODULE CONTENTS; EXPORTS CONTENTS,CONTENTSMV,DFNUMR,DIFFLOGS,FACTORLISTLIST,MULTSQFREE, MULTUP,SQFREE,SQMERGE; IMPORTS INT!-FAC,FQUOTF,GCDF,INTERR,!*MULTF!*,PARTIALDIFF,QUOTF,ORDOP, ADDF,NEGF,DOMAINP,DIFFF,MKSP,NEGSQ,INVSQ,ADDSQ,MULTSQ,DIFFSQ; COMMENT we assume that no power substitution is necessary in this module; SYMBOLIC PROCEDURE CONTENTS(P,V); % FIND THE CONTENTS OF THE POLYNOMIAL P WRT VARIABLE V; % NOTE THAT V MAY NOT BE THE MAIN VARIABLE OF P; IF DOMAINP(P) THEN P ELSE IF V=MVAR P THEN CONTENTSMV(P,V,NIL) ELSE IF ORDOP(V,MVAR P) THEN P ELSE CONTENTSMV(MAKEMAINVAR(P,V),V,NIL); SYMBOLIC PROCEDURE CONTENTSMV(P,V,SOFAR); % FIND CONTENTS OF POLYNOMIAL P; % V IS MAIN VARIABLE OF P; % SOFAR IS PARTIAL RESULT; IF SOFAR=1 THEN 1 ELSE IF DOMAINP P THEN GCDF(P,SOFAR) ELSE IF NOT V=MVAR P THEN GCDF(P,SOFAR) ELSE CONTENTSMV(RED P,V,GCDF(LC P,SOFAR)); SYMBOLIC PROCEDURE MAKEMAINVAR(P,V); % BRING V UP TO BE THE MAIN VARIABLE IN POLYNOMIAL P; % NOTE THAT THE RECONSTRUCTED P MUST BE USED WITH CARE SINCE; % IT DOES NOT CONFORM TO THE NORMAL REDUCE ORDERING RULES; IF DOMAINP P THEN P ELSE IF V=MVAR P THEN P ELSE MERGEADD(MULCOEFFSBY(MAKEMAINVAR(LC P,V),LPOW P,V), MAKEMAINVAR(RED P,V),V); SYMBOLIC PROCEDURE MULCOEFFSBY(P,POW,V); % MULTIPLY EACH COEFFICIENT IN P BY THE STANDARD POWER POW; IF NULL P THEN NIL ELSE IF DOMAINP P OR NOT V=MVAR P THEN ((POW .* P) .+ NIL) ELSE (LPOW P .* ((POW .* LC P) .+ NIL)) .+ MULCOEFFSBY(RED P,POW,V); SYMBOLIC PROCEDURE MERGEADD(A,B,V); % ADD POLYNOMIALS A AND B GIVEN THAT THEY HAVE SAME MAIN VARIABLE V; IF DOMAINP A OR NOT V=MVAR A THEN IF DOMAINP B OR NOT V=MVAR B THEN ADDF(A,B) ELSE LT B .+ MERGEADD(A,RED B,V) ELSE IF DOMAINP B OR NOT V=MVAR B THEN LT A .+ MERGEADD(RED A,B,V) ELSE (LAMBDA XC; IF XC=0 THEN (LPOW A .* ADDF(LC A,LC B)) .+ MERGEADD(RED A,RED B,V) ELSE IF XC>0 THEN LT A .+ MERGEADD(RED A,B,V) ELSE LT B .+ MERGEADD(A,RED B,V)) (TDEG LT A-TDEG LT B); SYMBOLIC PROCEDURE SQFREE(P,VL); IF (NULL VL) OR (DOMAINP P) THEN <<CONTENT:=P; NIL>> ELSE BEGIN SCALAR W,V,DP,GG,PG,DPG,P1,W1; W:=CONTENTS(P,CAR VL); % CONTENT OF P ; P:=QUOTF(P,W); % MAKE P PRIMITIVE; W:=SQFREE(W,CDR VL); % PROCESS CONTENT BY RECURSION; IF P=1 THEN RETURN W; V:=CAR VL; % PICK OUT VARIABLE FROM LIST; WHILE NOT (P=1) DO << DP:=PARTIALDIFF(P,V); GG:=GCDF(P,DP); PG:=QUOTF(P,GG); DPG:=NEGF PARTIALDIFF(PG,V); P1:=GCDF(PG,ADDF(QUOTF(DP,GG),DPG)); W1:=P1.W1; P:=GG>>; RETURN SQMERGE(REVERSE W1,W,T) END; SYMBOLIC PROCEDURE SQMERGE(W1,W,SIMPLEW1); % W AND W1 ARE LISTS OF FACTORS OF EACH POWER. IF SIMPLEW1 IS TRUE % THEN W1 CONTAINS ONLY SINGLE FACTORS FOR EACH POWER. ; IF NULL W1 THEN W ELSE IF NULL W THEN IF CAR W1=1 THEN NIL.SQMERGE(CDR W1,W,SIMPLEW1) ELSE (IF SIMPLEW1 THEN LIST CAR W1 ELSE CAR W1). SQMERGE(CDR W1,W,SIMPLEW1) ELSE IF CAR W1=1 THEN (CAR W).SQMERGE(CDR W1,CDR W,SIMPLEW1) ELSE APPEND(IF SIMPLEW1 THEN LIST CAR W1 ELSE CAR W1,CAR W). SQMERGE(CDR W1,CDR W,SIMPLEW1); SYMBOLIC PROCEDURE MULTUP L; % L IS A LIST OF S.F.'S. RESULT IS S.Q. FOR PRODUCT OF ELEMENTS OF L; BEGIN SCALAR RES; RES:=1 ./ 1; WHILE NOT NULL L DO << RES:=MULTSQ(RES,(CAR L) ./ 1); L:=CDR L >>; RETURN RES END; SYMBOLIC PROCEDURE DIFLIST(L,CL,X,RL); % DIFFERENTIATES L (LIST OF S.F.'S) WRT X TO PRODUCE THE SUM OF; % TERMS FOR THE DERIVATIVE OF NUMR OF 1ST PART OF ANSWER. CL IS; % COEFFICIENT LIST (S.F.'S) & RL IS LIST OF DERIVATIVES WE HAVE; % DEALT WITH SO FAR; % RESULT IS S.Q.; IF NULL L THEN NIL ./ 1 ELSE BEGIN SCALAR TEMP; TEMP:=MULTSQ(MULTUP RL,MULTUP CDR L); TEMP:=MULTSQ(DIFFF(CAR L,X),TEMP); TEMP:=MULTSQ(TEMP,(CAR CL) ./ 1); RETURN ADDSQ(TEMP,DIFLIST(CDR L,CDR CL,X,(CAR L).RL)) END; SYMBOLIC PROCEDURE MULTSQFREE W; % W IS LIST OF SQFREE FACTORS. RESULT IS PRODUCT OF EACH LIST IN W % TO GIVE ONE POLYNOMIAL FOR EACH SQFREE POWER; IF NULL W THEN NIL ELSE (!*Q2F MULTUP CAR W).MULTSQFREE CDR W; SYMBOLIC PROCEDURE L2LSF L; % L IS A LIST OF KERNELS. RESULT IS A LIST OF SAME MEMBERS AS S.F.'S; IF NULL L THEN NIL ELSE ((MKSP(CAR L,1) .* 1) .+ NIL).L2LSF CDR L; SYMBOLIC PROCEDURE DFNUMR(X,DL); % GIVES THE DERIVATIVE OF THE NUMR OF THE 1ST PART OF ANSWER.; % DL IS LIST OF ANY EXPONENTIAL OR 1+TAN**2 THAT OCCUR IN INTEGRAND; % DENR. THESE ARE DIVIDED OUT FROM RESULT BEFORE HANDING IT BACK.; % RESULT IS S.Q., READY FOR PRINTING; BEGIN SCALAR TEMP1,TEMP2,COEFLIST,QLIST,COUNT; IF NOT NULL SQFR THEN << COUNT:=0; QLIST:=CDR SQFR; COEFLIST:=NIL; WHILE NOT NULL QLIST DO << COUNT:=COUNT+1; COEFLIST:=COUNT.COEFLIST; QLIST:=CDR QLIST >>; COEFLIST:=REVERSE COEFLIST >>; TEMP1:=MULTSQ(DIFLIST(L2LSF ZLIST,L2LSF INDEXLIST,X,NIL), MULTUP SQFR); IF NOT NULL SQFR AND NOT NULL CDR SQFR THEN << TEMP2:=MULTSQ(DIFLIST(CDR SQFR,COEFLIST,X,NIL), MULTUP L2LSF ZLIST); TEMP2:=MULTSQ(TEMP2,(CAR SQFR) ./ 1) >> ELSE TEMP2:=NIL ./ 1; TEMP1:=ADDSQ(TEMP1,NEGSQ TEMP2); TEMP2:=CDR TEMP1; TEMP1:=CAR TEMP1; QLIST:=NIL; WHILE NOT NULL DL DO << IF NOT CAR DL MEMBER QLIST THEN QLIST:=(CAR DL).QLIST; DL:=CDR DL >>; WHILE NOT NULL QLIST DO << TEMP1:=QUOTF(TEMP1,CAR QLIST); QLIST:=CDR QLIST >>; RETURN TEMP1 ./ TEMP2 END; SYMBOLIC PROCEDURE DIFFLOGS(LL,DENM1,X); % LL IS LIST OF LOG TERMS (WITH COEFFTS), DEN IS COMMON DENOMINATOR; % OVER WHICH THEY ARE TO BE PUT. RESULT IS S.Q. FOR DERIVATIVE OF ALL; % THESE WRT X; IF NULL LL THEN NIL ./ 1 ELSE BEGIN SCALAR TEMP,QU,CVAR,LOGORATAN,ARG; LOGORATAN:=CAAR LL; CVAR:=CADAR LL; ARG:=CDDAR LL; TEMP:=MULTSQ(CVAR ./ 1,DIFFSQ(ARG,X)); IF LOGORATAN='IDEN THEN QU:=1 ./ 1 ELSE IF LOGORATAN='LOG THEN QU:=ARG ELSE IF LOGORATAN='ATAN THEN QU:=ADDSQ(1 ./ 1,MULTSQ(ARG,ARG)) ELSE INTERR "LOGORATAN=? IN DIFFLOGS"; %NOTE CALL TO SPECIAL DIVISION ROUTINE; QU:=FQUOTF(!*F2POL !*MULTF!*(!*MULTF!*(DENM1,NUMR TEMP), DENR QU),NUMR QU); %*MUST* GO EXACTLY; TEMP:=MULTSQ(INVSQ (DENR TEMP ./ 1),QU); %RESULT OF FQUOTF IS A S.Q; RETURN SUBS2Q ADDSQ(TEMP,DIFFLOGS(CDR LL,DENM1,X)) END; SYMBOLIC PROCEDURE FACTORLISTLIST (W,CLOGFLAG); % W IS LIST OF LISTS OF SQFREE FACTORS IN S.F. RESULT IS LIST OF LOG; % TERMS REQUIRED FOR INTEGRAL ANSWER. THE ARGUMENTS FOR EACH LOG FN; % ARE IN S.Q.; BEGIN SCALAR RES,X,Y; WHILE NOT NULL W DO << X:=CAR W; WHILE NOT NULL X DO << Y:=FACBYPP(CAR X,VARLIST); WHILE NOT NULL Y DO << RES:=APPEND(INT!-FAC CAR Y,RES); Y:=CDR Y >>; X:=CDR X >>; W:=CDR W >>; RETURN RES END; SYMBOLIC PROCEDURE FACBYPP(P,VL); %USE CONTENTS/PRIMITIVE PARTS TO TRY TO FACTOR P; IF NULL VL THEN LIST P ELSE BEGIN SCALAR PRINCILAP!-PART,CO; CO:=CONTENTS(P,CAR VL); VL:=CDR VL; IF CO=1 THEN RETURN FACBYPP(P,VL); %THIS VAR NO HELP; PRINCILAP!-PART:=QUOTF(P,CO); %PRIMITIVE PART; IF PRINCILAP!-PART=1 THEN RETURN FACBYPP(P,VL); %AGAIN NO HELP; RETURN NCONC(FACBYPP(PRINCILAP!-PART,VL),FACBYPP(CO,VL)) END; ENDMODULE; MODULE CSOLVE; EXPORTS BACKSUBST4CS,CREATECMAP,FINDPIVOT,PRINTSPREADC,PRINTVECSQ, SPREADC,SUBST4ELIMINATEDS; IMPORTS NTH,INTERR,!*MULTF!*,PRINTSF,PRINTSQ,QUOTF,PUTV,NEGF,INVSQ, NEGSQ,ADDSQ,MULTSQ,MKSP,ADDF,DOMAINP,PNTH; % routines to do with the C constants; SYMBOLIC PROCEDURE FINDPIVOT CVEC; % Finds first non-zero element in CVEC and returns its cell number.; % If no such element exists, result is nil.; BEGIN SCALAR I,X; I:=1; X:=GETV(CVEC,I); WHILE I<CCOUNT AND NULL X DO << I:=I+1; X:=GETV(CVEC,I) >>; IF NULL X THEN RETURN NIL; RETURN I END; SYMBOLIC PROCEDURE SUBST4ELIMINATEDCS(NEWEQN,SUBSTORDER,CEQNS); % Substitutes into NEWEQN for all the C's that have been eliminated so; % far. These are given by CEQNS. SUBSTORDER gives the order of; % substitution as well as the constant multipliers. Result is the; % transformed NEWEQN.; IF NULL SUBSTORDER THEN NEWEQN ELSE BEGIN SCALAR NXT,ROW,CVAR,TEMP; ROW:=CAR CEQNS; NXT:=CAR SUBSTORDER; IF NULL (CVAR:=GETV(NEWEQN,NXT)) THEN RETURN SUBST4ELIMINATEDCS(NEWEQN,CDR SUBSTORDER,CDR CEQNS); NXT:=GETV(ROW,NXT); FOR I:=0 : CCOUNT DO << TEMP:=!*MULTF!*(NXT,GETV(NEWEQN,I)); TEMP:=ADDF(TEMP,NEGF !*MULTF!*(CVAR,GETV(ROW,I))); PUTV(NEWEQN,I,!*F2POL TEMP) >>; RETURN SUBST4ELIMINATEDCS(NEWEQN,CDR SUBSTORDER,CDR CEQNS) END; SYMBOLIC PROCEDURE BACKSUBST4CS(CS2SUBST,CS2SOLVE,CMATRIX); % Solves the C-eqns and sets vector CVAL to the C-constant values; % CMATRIX is a list of matrix rows for C-eqns after Gaussian ; % elimination has been performed. CS2SOLVE is a list of the remaining; % C's to evaluate and CS2SUBST are the C's we have evaluated already.; IF NULL CMATRIX THEN NIL ELSE BEGIN SCALAR EQNN,CVAR,ALREADY,SUBSTLIST,TEMP,TEMP2; EQNN:=CAR CMATRIX; CVAR:=CAR CS2SOLVE; ALREADY:=NIL ./ 1; % The S.Q. nil ; SUBSTLIST:=CS2SUBST; % NOW SUBSTITUTE FOR PREVIOUSLY EVALUATED C'S:; WHILE NOT NULL SUBSTLIST DO << TEMP:=CAR SUBSTLIST; IF NOT NULL GETV(EQNN,TEMP) THEN ALREADY:=ADDSQ(ALREADY,MULTSQ(GETV(EQNN,TEMP) ./ 1, GETV(CVAL,TEMP))); SUBSTLIST:=CDR SUBSTLIST >>; % NOW SOLVE FOR THE C GIVEN BY CVAR (ANY REMAINING C'S ASSUMED ZERO); TEMP:=NEGSQ ADDSQ(GETV(EQNN,0) ./ 1,ALREADY); IF NOT NULL (TEMP2:=QUOTF(NUMR TEMP,GETV(EQNN,CVAR))) THEN TEMP:=TEMP2 ./ DENR TEMP ELSE TEMP:=MULTSQ(TEMP,INVSQ(GETV(EQNN,CVAR) ./ 1)); IF NOT NULL NUMR TEMP THEN PUTV(CVAL,CVAR, RESIMP ROOTEXTRACTSQ SUBS2Q TEMP); BACKSUBST4CS(REVERSEWOC(CVAR . REVERSEWOC CS2SUBST), CDR CS2SOLVE,CDR CMATRIX) END; %**********************************************************************; % Routines to deal with linear equations for the constants C; %**********************************************************************; SYMBOLIC PROCEDURE CREATECMAP; %Sets LOGLIST to list of things of form (LOG C-constant f), where f is; % function linear in one of the z-variables and C-constant is in S.F.; % When creating these C-constant names, the CMAP is also set up and ; % returned as the result.; BEGIN SCALAR I,L,C; L:=LOGLIST; I:=1; WHILE NOT NULL L DO << C:=(GENSYM1('C) . I) . C; I:=I+1; RPLACD(CAR L,((MKSP(CAAR C,1) .* 1) .+ NIL) . CDAR L); L:=CDR L >>; IF !*TRINT THEN PRINTC ("Constants Map" . C); RETURN C END; SYMBOLIC PROCEDURE SPREADC(EQNN,CVEC1,W); %SETS A VECTOR 'CVEC1' TO COEFFICIENTS OF C<I> IN EQNN; IF DOMAINP EQNN THEN PUTV(CVEC1,0,ADDF(GETV(CVEC1,0), !*F2POL !*MULTF!*(EQNN,W))) ELSE BEGIN SCALAR MV,T1,T2; SPREADC(RED EQNN,CVEC1,W); MV:=MVAR EQNN; T1:=ASSOC(MV,CMAP); %TESTS IF IT IS A C VAR; IF NOT NULL T1 THEN RETURN << T1:=CDR T1; %LOC IN VECTOR FOR THIS C; IF NOT (TDEG LT EQNN=1) THEN INTERR "NOT LINEAR IN C EQN"; T2:=ADDF(GETV(CVEC1,T1),!*MULTF!*(W,LC EQNN)); PUTV(CVEC1,T1,!*F2POL T2) >>; T1:=((LPOW EQNN) .* 1) .+ NIL; %THIS MAIN VAR AS SF; SPREADC(LC EQNN,CVEC1,!*F2POL !*MULTF!*(W,T1)) END; SYMBOLIC PROCEDURE PRINTSPREADC CVEC1; BEGIN FOR I:=0 : CCOUNT DO << PRIN2 I; PRINTC ":"; PRINTSF(GETV(CVEC1,I)) >>; PRINTC "END OF PRINTSPREADC OUTPUT" END; %SYMBOLIC PROCEDURE PRINTVECSQ CVEC; %% PRINT CONTENTS OF CVEC WHICH CONTAINS S.Q.'S (NOT S.F.'S); %% STARTS FROM CELL 1 NOT 0 AS ABOVE ROUTINE (PRINTSPREADC); % BEGIN % FOR I:=1 : CCOUNT DO << % PRIN2 I; % PRINTC ":"; % IF NULL GETV(CVEC,I) THEN PRINTC "0" % ELSE PRINTSQ(GETV(CVEC,I)) >>; % PRINTC "END OF PRINTVECSQ OUTPUT" % END; ENDMODULE; MODULE CUBEROOT; EXPORTS CUBEROOTDF; IMPORTS CONTENTSMV,GCDF,!*MULTF!*,NROOTN,PARTIALDIFF,PRINTDF,QUOTF,VP2, MKSP,MK!*SQ,DOMAINP; %CUBE-ROOT OF STANDARD FORMS; SYMBOLIC PROCEDURE CUBEROOTSQ A; CUBEROOTF NUMR A ./ CUBEROOTF DENR A; SYMBOLIC PROCEDURE CUBEROOTF P; BEGIN SCALAR IP,QP; IF NULL P THEN RETURN NIL; IP:=CUBEROOTF1 P; QP:=CDR IP; IP:=CAR IP; %RESPECTABLE AND NASTY PARTS OF THE CUBEROOT; IF ONEP QP THEN RETURN IP; %EXACT ROOT FOUND; QP:=LIST('EXPT,PREPF QP,'(QUOTIENT 1 3)); CUBEROOTFLAG:=T; %SYMBOLIC CUBE-ROOT INTRODUCED; QP:=(MKSP(QP,1).* 1) .+ NIL; RETURN !*F2POL !*MULTF!*(IP,QP) END; SYMBOLIC PROCEDURE CUBEROOTF1 P; %RETURNS A . B WITH P=A**2*B; %does this need power reduction??; IF DOMAINP P THEN NROOTN(P,3) ELSE BEGIN SCALAR CO,PPP,G,PG; CO:=CONTENTSMV(P,MVAR P,NIL); %CONTENTS OF P; PPP:=QUOTF(P,CO); %PRIMITIVE PART; %NOW CONSIDER PPP=P1*P2**2*P3**3*P4**4*...; CO:=CUBEROOTF1(CO); %PROCESS CONTENTS VIA RECURSION; G:=GCDF(PPP,PARTIALDIFF(PPP,MVAR PPP)); %G=P2*P3**2*P4**3*...; IF NOT DOMAINP G THEN << PG:=QUOTF(PPP,G); %PG=P1*P2*P3*P4*...; G:=GCDF(G,PARTIALDIFF(G,MVAR G)); % G=G3*G4**2*G5**3*...; G:=GCDF(G,PG)>>; %A TRIPLE FACTOR OF PPP; IF DOMAINP G THEN PG:=1 . PPP ELSE << PG:=QUOTF(PPP,!*MULTF!*(G,!*MULTF!*(G,G))); %WHAT'S LEFT; PG:=CUBEROOTF1(!*F2POL PG); %SPLIT THAT UP; RPLACA(PG,!*MULTF!*(CAR PG,G))>>; %PUT IN THE THING FOUND HERE; RPLACA(PG,!*F2POL !*MULTF!*(CAR PG,CAR CO)); RPLACD(PG,!*F2POL !*MULTF!*(CDR PG,CDR CO)); RETURN PG END; ENDMODULE; MODULE DEPEND; EXPORTS DEPENDSPL,DEPENDSP,INVOLVESQ,INVOLVSF; IMPORTS TAYLORP,DOMAINP; SYMBOLIC PROCEDURE DEPENDSP(X,V); IF NULL V THEN T ELSE IF ATOM X THEN IF X EQ V THEN X ELSE NIL ELSE IF CAR X = '!*SQ THEN INVOLVESQ(CADR X,V) ELSE IF TAYLORP X THEN IF V EQ TAYLORVARIABLE THEN TAYLORVARIABLE ELSE NIL ELSE BEGIN SCALAR W; IF X=V THEN RETURN V; % CHECK IF A PREFIX FORM EXPRESSION DEPENDS ON THE VARIABLE V; % NOTE THAT THIS ASSUMES THE FORM X IS IN NORMAL PREFIX NOTATION; W := X; % preserve the dependency; X:=CDR X; % READY TO RECURSIVELY CHECK ARGUMENTS; SCAN: IF NULL X THEN RETURN NIL; % NO DEPENDENCY FOUND; IF DEPENDSP(CAR X,V) THEN RETURN W; X:=CDR X; GO TO SCAN END; SYMBOLIC PROCEDURE TAYLORP U; NIL; %dummy for now; SYMBOLIC PROCEDURE INVOLVESQ(SQ,TERM); INVOLVESF(NUMR SQ,TERM) OR INVOLVESF(DENR SQ,TERM); SYMBOLIC PROCEDURE INVOLVESF(SF,TERM); IF DOMAINP SF OR NULL SF THEN NIL ELSE IF DEPENDSP(MVAR SF,TERM) THEN T ELSE INVOLVESF(LC SF,TERM) OR INVOLVESF(RED SF,TERM); ENDMODULE; MODULE DF2Q; EXPORTS DF2Q; IMPORTS ADDF,GCDF,MKSP,!*MULTF!*,QUOTF; COMMENT This module converts distributed forms to standard forms. We assume that results already have reduced powers, so that no power substitution is necessary; %TRIAL REPLACEMENT FOR DF2Q; SYMBOLIC PROCEDURE DF2Q P; % Converts distributed form P to standard quotient; BEGIN SCALAR N,D,GG,W; IF NULL P THEN RETURN NIL ./ 1; D:=DENR LC P; W:=RED P; WHILE NOT NULL W DO << GG:=GCDF(D,DENR LC W); %GET DENOMINATOR OF ANSWER...; D:=!*MULTF!*(D,QUOTF(DENR LC W,GG)); %..AS LCM OF DENOMS IN INPUT; W:=RED W >>; N:=NIL; %PLACE TO BUILD NUMERATOR OF ANSWER; WHILE NOT NULL P DO << N:=ADDF(N,!*MULTF!*(XL2F(LPOW P,ZLIST,INDEXLIST), !*MULTF!*(NUMR LC P,QUOTF(D,DENR LC P)))); P:=RED P >>; RETURN N ./ D END; SYMBOLIC PROCEDURE XL2F(L,Z,IL); % L is an exponent list from a D.F., Z is the Z-list, % IL is the list of indices. % Value is L converted to standard form. ; IF NULL Z THEN 1 ELSE IF CAR L=0 THEN XL2F(CDR L,CDR Z,CDR IL) ELSE IF NOT ATOM CAR L THEN BEGIN SCALAR TEMP; IF CAAR L=0 THEN TEMP:= CAR IL ELSE TEMP:=LIST('PLUS,CAR IL,CAAR L); TEMP:=MKSP(LIST('EXPT,CAR Z,TEMP),1); RETURN !*MULTF!*(((TEMP .* 1) .+ NIL), XL2F(CDR L,CDR Z,CDR IL)) END % ELSE IF MINUSP CAR L THEN ; % MULTSQ(INVSQ (((MKSP(CAR Z,-CAR L) .* 1) .+ NIL)), ; % XL2F(CDR L,CDR Z,CDR IL)) ; ELSE !*MULTF!*((MKSP(CAR Z,CAR L) .* 1) .+ NIL, XL2F(CDR L,CDR Z,CDR IL)); ENDMODULE; MODULE DISTRIB; EXPORTS DFPRINTFORM,MULTBYARBPOWERS,NEGDF,QUOTDFCONST,SUB1IND,VP1, VP2,PLUSDF,MULTDF,MULTDFCONST,ORDDF; IMPORTS INTERR,ADDSQ,NEGSQ,EXPTSQ,SIMP,DOMAINP,MK!*SQ,ADDF, MULTSQ,INVSQ,MINUSP,MKSP,SUB1; %*********************************************************************** % ROUTINES FOR MANIPULATING DISTRIBUTED FORMS. % NOTE: % THE EXPRESSIONS LT,RED,LC,LPOW HAVE BEEN USED ON DISTRIBUTED % FORMS AS THE LATTER'S STRUCTURE IS SUFFICIENTLY SIMILAR TO % S.F.'S. HOWEVER LC DF IS A S.Q. NOT A S.F. AND LPOW DF IS A % LIST OF THE EXPONENTS OF THE VARIABLES. THIS ALSO MAKES % LT DF DIFFERENT. RED DF IS D.F. AS EXPECTED. %**********************************************************************; SYMBOLIC PROCEDURE PLUSDF(U,V); % U and V are D.F.'s. Value is D.F. for U+V; IF NULL U THEN V ELSE IF NULL V THEN U ELSE IF LPOW U=LPOW V THEN (LAMBDA(X,Y); IF NULL NUMR X THEN Y ELSE (LPOW U .* X) .+ Y) (ADDSQ(LC U,LC V),PLUSDF(RED U,RED V)) ELSE IF ORDDF(LPOW U,LPOW V) THEN LT U .+ PLUSDF(RED U,V) ELSE (LT V) .+ PLUSDF(U,RED V); SYMBOLIC PROCEDURE ORDDF(U,V); % U and V are the LPOW of a D.F. - i.e. the list of exponents ; % Value is true if LPOW U '>' LPOW V and false otherwise ; IF NULL U THEN IF NULL V THEN INTERR "ORDDF = CASE" ELSE INTERR "ORDDF V LONGER THAN U" ELSE IF NULL V THEN INTERR "ORDDF U LONGER THAN V" ELSE IF EXPTCOMPARE(CAR U,CAR V) THEN T ELSE IF EXPTCOMPARE(CAR V,CAR U) THEN NIL ELSE ORDDF(CDR U,CDR V); SYMBOLIC PROCEDURE EXPTCOMPARE(X,Y); IF ATOM X THEN IF ATOM Y THEN X>Y ELSE NIL ELSE IF ATOM Y THEN T ELSE CAR X > CAR Y; SYMBOLIC PROCEDURE NEGDF U; IF NULL U THEN NIL ELSE (LPOW U .* NEGSQ LC U) .+ NEGDF RED U; SYMBOLIC PROCEDURE MULTDF(U,V); % U and V are D.F.'s. Value is D.F. for U*V; % reduces squares of square-roots as it goes; IF NULL U OR NULL V THEN NIL ELSE BEGIN SCALAR Y; %use (a+b)*(c+d) = (a*c) + a*(c+d) + b*(c+d); Y:=MULTERM(LT U,LT V); %leading terms; Y:=PLUSDF(Y,MULTDF(RED U,V)); Y:=PLUSDF(Y,MULTDF((LT U) .+ NIL,RED V)); RETURN Y END; SYMBOLIC PROCEDURE MULTERM(U,V); %multiply two terms to give a D.F.; BEGIN SCALAR COEF; COEF:= SUBS2Q MULTSQ(CDR U,CDR V); %coefficient part; RETURN MULTDFCONST(COEF,MULPOWER(CAR U,CAR V)) END; SYMBOLIC PROCEDURE MULPOWER(U,V); % u and v are exponent lists. multiply corresponding forms; BEGIN SCALAR R,S; R:=ADDEXPTSDF(U,V); IF NOT NULL SQRTLIST THEN S:=REDUCEROOTS(R,ZLIST); R:=(R .* (1 ./ 1)) .+ NIL; IF NOT (S=NIL) THEN R:=MULTDF(R,S); RETURN R END; SYMBOLIC PROCEDURE REDUCEROOTS(R,ZL); BEGIN SCALAR S; WHILE NOT NULL R DO << IF EQCAR(CAR ZL,'SQRT) THEN S:=TRYREDUCTION(R,CAR ZL,S); R:=CDR R; ZL:=CDR ZL >>; RETURN S END; SYMBOLIC PROCEDURE TRYREDUCTION(R,VAR,S); BEGIN SCALAR X; X:=CAR R; %CURRENT EXPONENT; IF NOT ATOM X THEN << R:=X; X:=CAR R >>; %NUMERIC PART; IF (X=0) OR (X=1) THEN RETURN S; %NO REDUCTION POSSIBLE; X:=DIVIDE(X,2); RPLACA(R,CDR X); %REDUCE EXPONENT AS REDORDED; X:=CAR X; VAR:=SIMP CADR VAR; %SQRT ARG AS A S Q; VAR:=EXPTSQ(VAR,X); X:=MULTDFCONST(1 ./ DENR VAR,F2DF NUMR VAR); %DISTRIBUTE; IF S=NIL THEN S:=X ELSE S:=MULTDF(S,X); RETURN S END; SYMBOLIC PROCEDURE ADDEXPTSDF(X,Y); % X and Y are LPOW's of D.F. Value is list of sum of exponents; IF NULL X THEN IF NULL Y THEN NIL ELSE INTERR "X TOO LONG" ELSE IF NULL Y THEN INTERR "Y TOO LONG" ELSE EXPTPLUS(CAR X,CAR Y).ADDEXPTSDF(CDR X,CDR Y); SYMBOLIC PROCEDURE EXPTPLUS(X,Y); IF ATOM X THEN IF ATOM Y THEN X+Y ELSE LIST (X+CAR Y) ELSE IF ATOM Y THEN LIST (CAR X +Y) ELSE INTERR "BAD EXPONENT SUM"; SYMBOLIC PROCEDURE MULTDFCONST(X,U); % X is S.Q. not involving Z variables of D.F. U. Value is D.F.; % for X*U; IF (NULL U) OR (NULL NUMR X) THEN NIL ELSE LPOW U .* SUBS2Q MULTSQ(X,LC U) .+ MULTDFCONST(X,RED U); SYMBOLIC PROCEDURE F2DF P; % P is standard form. Value is P in D.F.; IF DOMAINP P THEN DFCONST(P ./ 1) ELSE IF MVAR P MEMBER ZLIST THEN PLUSDF(MULTDF(VP2DF(MVAR P,TDEG LT P,ZLIST),F2DF LC P), F2DF RED P) ELSE PLUSDF(MULTDFCONST(((LPOW P .* 1) .+ NIL) ./ 1,F2DF LC P), F2DF RED P); SYMBOLIC PROCEDURE VP1(VAR,DEGG,Z); % Takes VAR and finds it in Z (=list), raises it to power DEGG and puts; % the result in exponent list form for use in a distributed form.; IF NULL Z THEN INTERR "VAR NOT IN Z-LIST AFTER ALL" ELSE IF VAR=CAR Z THEN DEGG.VP2 CDR Z ELSE 0 . VP1(VAR,DEGG,CDR Z); SYMBOLIC PROCEDURE VP2 Z; % Makes exponent list of zeroes; IF NULL Z THEN NIL ELSE 0 . VP2 CDR Z; SYMBOLIC PROCEDURE VP2DF(VAR,EXPRN,Z); % Makes VAR**EXPRN into exponent list and then converts the resulting % power into a distributed form. % special care with square-roots; IF EQCAR(VAR,'SQRT) AND EXPRN>1 THEN MULPOWER(VP1(VAR,EXPRN,Z),VP2 Z) ELSE (VP1(VAR,EXPRN,Z) .* (1 ./ 1)) .+ NIL; SYMBOLIC PROCEDURE DFCONST Q; % Makes a distributed form from standard quotient constant Q; IF NUMR Q=NIL THEN NIL ELSE ((VP2 ZLIST) .* Q) .+ NIL; %DF2Q MOVED TO A SECTION OF ITS OWN; SYMBOLIC PROCEDURE DF2PRINTFORM P; %CONVERT TO A STANDARD FORM GOOD ENOUGH FOR PRINTING; IF NULL P THEN NIL ELSE BEGIN SCALAR MV,CO; MV:=XL2Q(LPOW P,ZLIST,INDEXLIST); IF MV=(1 ./ 1) THEN << CO:=LC P; IF DENR CO=1 THEN RETURN ADDF(NUMR CO, DF2PRINTFORM RED P); CO:=MKSP(MK!*SQ CO,1); RETURN (CO .* 1) .+ DF2PRINTFORM RED P >>; CO:=LC P; IF NOT (DENR CO=1) THEN MV:=MULTSQ(MV,1 ./ DENR CO); MV:=MKSP(MK!*SQ MV,1) .* NUMR CO; RETURN MV .+ DF2PRINTFORM RED P END; SYMBOLIC PROCEDURE XL2Q(L,Z,IL); % L is an exponent list from a D.F., Z is the Z-list, % IL is the list of indices. % Value is L converted to standard quotient. ; IF NULL Z THEN 1 ./ 1 ELSE IF CAR L=0 THEN XL2Q(CDR L,CDR Z,CDR IL) ELSE IF NOT ATOM CAR L THEN BEGIN SCALAR TEMP; IF CAAR L=0 THEN TEMP:= CAR IL ELSE TEMP:=LIST('PLUS,CAR IL,CAAR L); TEMP:=MKSP(LIST('EXPT,CAR Z,TEMP),1); RETURN MULTSQ(((TEMP .* 1) .+ NIL) ./ 1, XL2Q(CDR L,CDR Z,CDR IL)) END ELSE IF MINUSP CAR L THEN MULTSQ(INVSQ (((MKSP(CAR Z,-CAR L) .* 1) .+ NIL) ./ 1), XL2Q(CDR L,CDR Z,CDR IL)) ELSE MULTSQ(((MKSP(CAR Z,CAR L) .* 1) .+ NIL) ./ 1, XL2Q(CDR L,CDR Z,CDR IL)); SYMBOLIC PROCEDURE MULTBYARBPOWERS U; % Multiplies the ordinary D.F., U, by arbitrary powers % of the z-variables; % i-1 j-1 k-1 % i.e. x z z ... so result is D.F. with the exponent list % 1 2 % appropriately altered to contain list elements instead of numeric % ones; IF NULL U THEN NIL ELSE ((ADDARBEXPTSDF LPOW U) .* LC U) .+ MULTBYARBPOWERS RED U; SYMBOLIC PROCEDURE ADDARBEXPTSDF X; % Adds the arbitrary powers to powers in exponent list, X, to produce % new exponent list. e.g. 3 -> (2) to represent x**3 now becoming: % 3 i-1 i+2 % x * x = x . ; IF NULL X THEN NIL ELSE LIST EXPTPLUS(CAR X,-1) . ADDARBEXPTSDF CDR X; ENDMODULE; MODULE DIVIDE; EXPORTS FQUOTF,TESTDIVDF,DFQUOTDF; IMPORTS DF2Q,F2DF,GCDF,INTERR,MULTDF,NEGDF,PLUSDF,PRINTDF,PRINTSF, QUOTF,MULTSQ,INVSQ,NEGSQ; %EXACT DIVISION OF STANDARD FORMS TO GIVE A STANDARD QUOTIENT; %INTENDED FOR DIVIDING OUT KNOWN FACTORS AS PRODUCED BY THE; %INTEGRATION PROGRAM. HORRIBLE AND SLOW, I EXPECT!!; SYMBOLIC PROCEDURE DFQUOTDF(A,B); BEGIN SCALAR RESIDUE; IF (!*TRINT OR !*TRDIV) THEN << PRINTC "DFQUOTDF CALLED ON "; PRINTDF A; PRINTDF B>>; A:=DFQUOTDF1(A,B); IF (!*TRINT OR !*TRDIV) THEN << PRINTC "QUOTIENT GIVEN AS "; PRINTDF A >>; IF NOT NULL RESIDUE THEN BEGIN SCALAR GRES,W; IF !*TRINT OR !*TRDIV THEN << PRINTC "RESIDUE IN DFQUOTDF ="; PRINTDF RESIDUE; PRINTC "WHICH SHOULD BE ZERO"; W:=RESIDUE; GRES:=NUMR LC W; W:=RED W; WHILE NOT NULL W DO << GRES:=GCDF(GRES,NUMR LC W); W:=RED W >>; PRINTC "I.E. THE FOLLOWING VANISHES"; PRINTSF GRES>>; INTERR "NON-EXACT DIVISION DUE TO A LOG TERM" END; RETURN A END; SYMBOLIC PROCEDURE FQUOTF(A,B); % INPUT: A AND B STANDARD QUOTIENTS WITH (A/B) AN EXACT; % DIVISION WITH RESPECT TO THE VARIABLES IN ZLIST, ; % BUT NOT NECESSARILY OBVIOUSLY SO. THE 'NON-OBVIOUS' PROBLEMS; % WILL BE BECAUSE OF (E.G.) SQUARE-ROOT SYMBOLS IN B; % OUTPUT: STANDARD QUOTIENT FOR (A/B); % (PRINTS MESSAGE IF REMAINDER IS NOT 'CLEARLY' ZERO; % A MUST NOT BE ZERO; BEGIN SCALAR T1; IF NULL A THEN INTERR "A=0 IN FQUOTF"; T1:=QUOTF(A,B); %TRY IT THE EASY WAY; IF NOT NULL T1 THEN RETURN T1 ./ 1; %OK; RETURN DF2Q DFQUOTDF(F2DF A,F2DF B) END; SYMBOLIC PROCEDURE DFQUOTDF1(A,B); BEGIN SCALAR Q; IF NULL B THEN INTERR "ATTEMPT TO DIVIDE BY ZERO"; Q:=SQRTLIST; %REMOVE SQRTS FROM DENOMINATOR, MAYBE; WHILE NOT NULL Q DO BEGIN SCALAR CONJ; CONJ:=CONJSQRT(B,CAR Q); %CONJUGATE WRT GIVEN SQRT; IF NOT (B=CONJ) THEN << A:=MULTDF(A,CONJ); B:=MULTDF(B,CONJ) >>; Q:=CDR Q END; Q:=DFQUOTDF2(A,B); RESIDUE:=REVERSEWOC RESIDUE; RETURN Q END; SYMBOLIC PROCEDURE DFQUOTDF2(A,B); %AS ABOVE BUT A AND B ARE DISTRIBUTED FORMS, AS IS THE RESULT; IF NULL A THEN NIL ELSE BEGIN SCALAR XD,LCD; XD:=XPDIFF(LPOW A,LPOW B); IF XD='FAILED THEN << XD:=LT A; A:=RED A; RESIDUE:=XD .+ RESIDUE; RETURN DFQUOTDF2(A,B) >>; LCD:=SUBS2Q MULTSQ(LC A,INVSQ LC B); IF NULL NUMR LCD THEN RETURN DFQUOTDF2(RED A,B); LCD := XD .* LCD; XD:=PLUSDF(A,MULTDF(NEGDF (LCD .+ NIL),B)); IF XD AND (LPOW XD = LPOW A OR XPDIFF(LPOW XD,LPOW B) = 'FAILED) THEN <<IF !*TRINT OR !*TRDIV THEN <<PRINTC "DFQUOTDF TROUBLE:"; PRINTDF XD>>; XD := ROOTEXTRACTDF XD; IF !*TRINT OR !*TRDIV THEN PRINTDF XD>>; RETURN LCD .+ DFQUOTDF2(XD,B) END; SYMBOLIC PROCEDURE ROOTEXTRACTDF U; IF NULL U THEN NIL ELSE BEGIN SCALAR V; V := RESIMP ROOTEXTRACTSQ LC U; RETURN IF NULL NUMR V THEN ROOTEXTRACTDF RED U ELSE (LPOW U .* V) .+ ROOTEXTRACTDF RED U END; SYMBOLIC PROCEDURE ROOTEXTRACTSQ U; IF NULL NUMR U THEN U ELSE ROOTEXTRACTF NUMR U ./ ROOTEXTRACTF DENR U; SYMBOLIC PROCEDURE ROOTEXTRACTF V; IF DOMAINP V THEN V ELSE BEGIN SCALAR U,R,C,X,P; U := MVAR V; P := LDEG V; R := ROOTEXTRACTF RED V; C := ROOTEXTRACTF LC V; IF NULL C THEN RETURN R ELSE IF ATOM U THEN RETURN (LPOW V .* C) .+ R ELSE IF CAR U EQ 'SQRT OR CAR U EQ 'EXPT AND EQCAR(CADDR U,'QUOTIENT) AND CAR CDADDR U = 1 AND NUMBERP CADR CDADDR U THEN <<P := DIVIDE(P,IF CAR U EQ 'SQRT THEN 2 ELSE CADR CDADDR U); IF CAR P = 0 THEN RETURN IF NULL C THEN R ELSE (LPOW V .* C) .+ R ELSE IF NUMBERP CADR U THEN <<C := MULTD(CADR U ** CAR P,C); P := CDR P>> ELSE <<X := SIMPEXPT LIST(CADR U,CAR P); IF DENR X = 1 THEN <<C := MULTF(NUMR X,C); P := CDR P>>>>>>; RETURN IF P=0 THEN ADDF(C,R) ELSE IF NULL C THEN R ELSE ((U TO P) .* C) .+ R END; PUT('DF,'SIMPFN,'SIMPDF!*); SYMBOLIC PROCEDURE SIMPDF!* U; BEGIN SCALAR V,V1; V:=SIMPDF U; V1:=ROOTEXTRACTSQ V; IF NOT(V1=V) THEN RETURN RESIMP V1 ELSE RETURN V END; SYMBOLIC PROCEDURE XPDIFF(A,B); %RESULT IS LIST A-B, OR 'FAILED' IF A MEMBER OF THIS WOULD BE NEGATIVE; IF NULL A THEN IF NULL B THEN NIL ELSE INTERR "B TOO LONG IN XPDIFF" ELSE IF NULL B THEN INTERR "A TOO LONG IN XPDIFF" ELSE IF CAR B>CAR A THEN 'FAILED ELSE (LAMBDA R; IF R='FAILED THEN 'FAILED ELSE (CAR A-CAR B) . R) (XPDIFF(CDR A,CDR B)); SYMBOLIC PROCEDURE CONJSQRT(B,VAR); %SUBST(VAR=-VAR,B); IF NULL B THEN NIL ELSE CONJTERM(LPOW B,LC B,VAR) .+ CONJSQRT(RED B,VAR); SYMBOLIC PROCEDURE CONJTERM(XL,COEF,VAR); %DITTO BUT WORKING ON A TERM; IF INVOLVESP(XL,VAR,ZLIST) THEN XL .* NEGSQ COEF ELSE XL .* COEF; SYMBOLIC PROCEDURE INVOLVESP(XL,VAR,ZL); %CHECK IF EXPONENT LIST HAS NON-ZERO POWER FOR VARIABLE; IF NULL XL THEN INTERR "VAR NOT FOUND IN INVOLVESP" ELSE IF CAR ZL=VAR THEN (NOT ZEROP CAR XL) ELSE INVOLVESP(CDR XL,VAR,CDR ZL); ENDMODULE; MODULE DRIVER; EXPORTS INTEGRATESQ,SIMPINT,PURGE,SIMPINT1; IMPORTS ALGEBRAICCASE,ALGFNPL,FINDZVARS,GETVARIABLES,INTERR,PRINTSQ, TRANSCENDENTALCASE,VARSINLIST,KERNP,SIMPCAR,PREPSQ,MKSQ,SIMP, OPMTCH,FORMLNR; %FORM IS INT(EXPR,VAR,X1,X2,...); %MEANING IS INTEGRATE EXPR WRT VAR, GIVEN THAT THE RESULT MAY; %CONTAIN LOGS OF X1,X2,...; % X1, ETC ARE INTENDED FOR USE WHEN THE SYSTEM HAS TO BE HELPED; % IN THE CASE THAT EXPR IS ALGEBRAIC; SYMBOLIC PROCEDURE SIMPINT U; % Simplify an integral, links up with general prefix mode system; BEGIN SCALAR EXPRESSION,VARIABLE,TT,LOGLIST,W,!*GCD,!*MCD,!*EXP, !*PURERISCH,!*SQRT,!*STRUCTURE; % ARGUMENT IS A LIST OF TWO ELEMENTS, WHICH ARE PREFIX FORMS; % OF THE INTEGRAND AND VARIABLE OF INTEGRATION; !*GCD:=T; !*MCD:=T; !*EXP:=T; !*SQRT:=T; !*STRUCTURE := T; VARIABLE:=CDR U; EXPRESSION:=SIMPP CAR U; %CONVERT INTEGRAND INTO A SQ; IF NULL VARIABLE THEN GO TO NOTENOUGHARGS; W:=CDR VARIABLE; VARIABLE:= !*Q2K SIMPP CAR VARIABLE; %CONVERT VARIABLE; %NOW ARGUMENTS HAVE BEEN CHECKED. START WORK; LOGLIST:=MAPCAR(W,FUNCTION SIMPP); U:=ERRORSET('(INTEGRATESQ EXPRESSION VARIABLE LOGLIST), NIL,!*BACKTRACE); IF NOT ATOM U THEN RETURN CAR U; %INTEGRATION OK; RETURN SIMPINT1(EXPRESSION . VARIABLE.W); % LEAVE IT FORMAL & LINEARISED; NOTENOUGHARGS: INTERR "NOT ENOUGH ARGS FOR INT"; TOOMANYARGS: INTERR "TOO MANY ARGS FOR INT" END; SYMBOLIC PROCEDURE SIMPP U; %converts U to canonical form. Resimplifies if U is a *sq form; IF EQCAR(U,'!*SQ) THEN RESIMP CADR U ELSE SIMP U; PUT('INT,'SIMPFN,'SIMPINT); SYMBOLIC PROCEDURE INTEGRATESQ(INTEGRAND,VAR,XLOGS); BEGIN SCALAR VARLIST,ZLIST; IF !*TRINT THEN << PRINTC "INTEGRAND IS..."; PRINTSQ INTEGRAND >>; VARLIST:=GETVARIABLES INTEGRAND; VARLIST:=VARSINLIST(XLOGS,VARLIST); %IN CASE MORE EXIST IN XLOGS; ZLIST:=FINDZVARS(VARLIST,LIST VAR,VAR,NIL); %%IMPORTSANT KERNELS; %the next section causes problems with nested exponentials or logs; BEGIN SCALAR OLDZLIST; WHILE OLDZLIST NEQ ZLIST DO << OLDZLIST:=ZLIST; FOREACH ZZ IN OLDZLIST DO ZLIST:=FINDZVARS(PSEUDODIFF(ZZ,VAR),ZLIST,VAR,T) >> END; IF !*TRINT THEN << PRINTC "WITH 'NEW' FUNCTIONS :"; PRINT ZLIST >>; IF !*PURERISCH AND NOT ALLOWEDFNS ZLIST THEN RETURN SIMPINT1 (INTEGRAND . VAR.NIL); % IF IT IS NOT SUITABLE FOR RISCH; VARLIST:=PURGE(ZLIST,VARLIST); % NOW ZLIST IS LIST OF THINGS THAT DEPEND ON X, AND VARLIST IS LIST; % OF CONSTANT KERNELS IN INTEGRAND; RETURN TRANSCENDENTALCASE(INTEGRAND,VAR,XLOGS,ZLIST,VARLIST) END; SYMBOLIC PROCEDURE PSEUDODIFF(A,VAR); IF ATOM A THEN NIL ELSE IF CAR A MEMQ '(EXPT PLUS TIMES QUOTIENT LOG SQRT) THEN BEGIN SCALAR AA,BB; FOREACH ZZ IN CDR A DO << BB:=PSEUDODIFF(ZZ,VAR); IF AA THEN AA:=BB . AA ELSE BB >>; RETURN AA END ELSE LIST PREPSQ SIMPDF(LIST(A,VAR)); MKOP 'INT!*; SYMBOLIC PROCEDURE SIMPINT1 U; BEGIN SCALAR V,!*SQRT; U := 'INT . PREPSQ CAR U . CDR U; IF (V := FORMLNR U) NEQ U THEN IF !*NOLNR THEN << V:= SIMP SUBST('INT!*,'INT,V); RETURN REMAKESF NUMR V ./ REMAKESF DENR V>> ELSE <<!*NOLNR:= NIL . !*NOLNR; U:=ERRORSET(LIST('SIMP,MKQUOTE V),NIL,!*BACKTRACE); IF PAIRP U THEN V:=CAR U; !*NOLNR:= CDR !*NOLNR; RETURN V>>; RETURN IF (V := OPMTCH U) THEN SIMP V ELSE MKSQ(U,1) END; SYMBOLIC PROCEDURE REMAKESF U; %remakes standard form U, substituting operator INT for INT!*; IF DOMAINP U THEN U ELSE ADDF(MULTPF(IF EQCAR(MVAR U,'INT!*) THEN MKSP('INT . CDR MVAR U,LDEG U) ELSE LPOW U,REMAKESF LC U), REMAKESF RED U); SYMBOLIC PROCEDURE ALLOWEDFNS U; IF NULL U THEN T ELSE IF ATOM CAR U OR FLAGP(CAAR U,'TRANSCENDENTAL) THEN ALLOWEDFNS CDR U ELSE NIL; SYMBOLIC PROCEDURE PURGE(A,B); IF NULL A THEN B ELSE IF NULL B THEN NIL ELSE PURGE(CDR A,DELETE(CAR A,B)); ENDMODULE; MODULE D3D4; EXPORTS CUBIC,QUARTIC; IMPORTS COVECDF,CUBEROOTF,NTH,FORCEAZERO,MAKEPOLYDF,MULTDF,MULTDFCONST, !*MULTF!*,NEGDF,PLUSDF,PRINTDF,PRINTSF,QUADRATIC,SQRTF,VP1,VP2,ADDF, NEGF; %SPLITTING OF CUBICS AND QUARTICS; SYMBOLIC PROCEDURE CUBIC(POL,VAR,RES); %SPLIT THE UNIVARIATE (WRT Z-VARS) CUBIC POL, AT LEAST IF A; %CHANGE OF ORIGIN PUTS IT IN THE FORM (X-A)**3-B=0; BEGIN SCALAR A,B,C,D,V,SHIFT,P,Q,DSC; V:=COVECDF(POL,VAR,3); SHIFT:=FORCEAZERO(V,3); %MAKE COEFF X**2 VANISH; %ALSO CHECKS UNIVARIATE; % IF SHIFT='FAILED THEN GO TO PRIME; A:=GETV(V,3); B:=GETV(V,2); %=0, I HOPE!; C:=GETV(V,1); D:=GETV(V,0); IF !*TRINT THEN << PRINTC "CUBIC HAS COEFFICIENTS"; PRINTSF A; PRINTSF B; PRINTSF C; PRINTSF D >>; IF NOT NULL C THEN << PRINTC "CUBIC TOO HARD TO SPLIT"; GO TO EXIT >>; A:=CUBEROOTF(A); %CAN'T EVER FAIL; D:=CUBEROOTF(D); IF !*TRINT THEN << PRINTC "CUBE ROOTS OF A AND D ARE"; PRINTSF A; PRINTSF D>>; %NOW A*(X+SHIFT)+D IS A FACTOR OF POL; %CREATE X+SHIFT IN P; P:=(VP2 ZLIST .* SHIFT) .+ NIL; P:=(VP1(VAR,1,ZLIST) .* (1 ./ 1)) .+ P; %(X+SHIFT); B:=NIL; B:=(VP2 ZLIST .* (D ./ 1)) .+ B; B:=PLUSDF(B,MULTDFCONST(A ./ 1,P)); B:=MAKEPOLYDF B; %GET RID OF DENOMINATOR; IF !*TRINT THEN << PRINTC "ONE FACTOR OF THE CUBIC IS"; PRINTDF B >>; RES:=('LOG . B) . RES; %NOW FORM THE (QUADRATIC) COFACTOR; B:=(VP2 ZLIST .* (!*F2POL !*MULTF!*(D,D) ./ 1)) .+ NIL; B:=PLUSDF(B,MULTDFCONST(NEGF !*F2POL !*MULTF!*(A,D) ./ 1,P)); B:=PLUSDF(B,MULTDFCONST(!*F2POL !*MULTF!*(A,A) ./ 1, MULTDF(P,P))); RETURN QUADRATIC(MAKEPOLYDF B,VAR,RES); %DEAL WITH WHAT IS LEFT; PRIME: PRINTC "THE FOLLOWING CUBIC DOES NOT SPLIT"; EXIT: PRINTDF POL; RETURN ('LOG . POL) . RES END; FLUID '(KNOWNDISCRIMSIGN); SYMBOLIC PROCEDURE QUARTIC(POL,VAR,RES); %SPLITS UNIVARIATE (WRT Z-VARS) QUARTICS THAT CAN BE WRITTEN; %IN THE FORM (X-A)**4+B*(X-A)**2+C; BEGIN SCALAR A,B,C,D,E,V,SHIFT,P,Q,P1,P2,DSC; V:=COVECDF(POL,VAR,4); SHIFT:=FORCEAZERO(V,4); %MAKE COEFF X**3 VANISH; % IF SHIFT='FAILED THEN GO TO PRIME; A:=GETV(V,4); B:=GETV(V,3); %=0, I HOPE!; C:=GETV(V,2); D:=GETV(V,1); E:=GETV(V,0); IF !*TRINT THEN << PRINTC "QUARTIC HAS COEFFICIENTS"; PRINTSF A; PRINTSF B; PRINTSF C; PRINTSF D; PRINTSF E >>; IF NOT NULL D THEN << PRINTC "QUARTIC TOO HARD TO SPLIT"; GO TO EXIT >>; B:=C; C:=E; %SQUASH UP THE NOTATION; IF KNOWNDISCRIMSIGN EQ 'NEGATIVE THEN GO TO COMPLEX; DSC := !*F2POL ADDF(MULTF(B,B),MULTF(-4,MULTF(A,C))); P2 := MINUSF C; IF NOT P2 AND MINUSF DSC THEN GO TO COMPLEX; P1 := NULL B OR MINUSF B; IF NOT P1 THEN IF P2 THEN P1 := T ELSE P2 := T; P1 := IF P1 THEN 'POSITIVE ELSE 'NEGATIVE; P2 := IF P2 THEN 'NEGATIVE ELSE 'POSITIVE; A := SQRTF A; DSC := SQRTF DSC; E := INVSQ(ADDF(A,A) ./ 1); D := MULTSQ(ADDF(B,NEGF DSC) ./ 1,E); E := MULTSQ(ADDF(B,DSC) ./ 1,E); IF !*TRINT THEN <<PRINTC "QUADRATIC FACTORS WILL HAVE COEFFICIENTS"; PRINTSF A; PRINT 0; PRINTSQ D; PRINTC "OR"; PRINTSQ E>>; P := (VP2 ZLIST .* SHIFT) .+ NIL; P := (VP1(VAR,1,ZLIST) .* (1 ./ 1)) .+ P; %(X+SHIFT); Q := MULTDF(P,P); %SQUARE OF SAME; Q := MULTDFCONST(A ./ 1,Q); P := PLUSDF(Q,(VP2 ZLIST .* D) .+ NIL); Q := PLUSDF(Q,(VP2 ZLIST .* E) .+ NIL); IF !*TRINT THEN <<PRINTC "ALLOWING FOR CHANGE OF ORIGIN:"; PRINTDF P; PRINTDF Q>>; KNOWNDISCRIMSIGN := P1; RES := QUADRATIC(P,VAR,RES); KNOWNDISCRIMSIGN := P2; RES := QUADRATIC(Q,VAR,RES); GO TO QUARTICDONE; COMPLEX: A:=SQRTF(A); C:=SQRTF(C); B:=ADDF(!*F2POL !*MULTF!*(2,!*MULTF!*(A,C)),NEGF B); B:=SQRTF B; %NOW A*(X+SHIFT)**2 (+/-) B*(X+SHIFT) + C IS A FACTOR; IF !*TRINT THEN << PRINTC "QUADRATIC FACTORS WILL HAVE COEFFICIENTS"; PRINTSF A; PRINTSF B; PRINTSF C>>; P:=(VP2 ZLIST .* SHIFT) .+ NIL; P:=(VP1(VAR,1,ZLIST) .* (1 ./ 1)) .+ P; %(X+SHIFT); Q:=MULTDF(P,P); %SQUARE OF SAME; P:=MULTDFCONST(B ./ 1,P); Q:=MULTDFCONST(A ./ 1,Q); Q:=PLUSDF(Q,(VP2 ZLIST .* (C ./ 1)) .+ NIL); IF !*TRINT THEN << PRINTC "ALLOWING FOR CHANGE OF ORIGIN, P (+/-) Q WITH P,Q="; PRINTDF P; PRINTDF Q>>; %NOW P+Q AND P-Q ARE THE FACTORS OF THE QUARTIC; KNOWNDISCRIMSIGN := 'NEGATIVE; RES:=QUADRATIC(PLUSDF(Q,P),VAR,RES); RES:=QUADRATIC(PLUSDF(Q,NEGDF P),VAR,RES); QUARTICDONE: KNOWNDISCRIMSIGN := NIL; IF !*TRINT THEN PRINTC "QUARTIC DONE"; RETURN RES; PRIME: PRINTC "THE FOLLOWING QUARTIC DOES NOT SPLIT"; EXIT: PRINTDF POL; RETURN ('LOG . POL) . RES END; ENDMODULE; MODULE FACTR; EXPORTS INT!-FAC,VAR2DF; IMPORTS CUBIC,DF2Q,F2DF,INTERR,MULTDF,PRINTDF,QUADRATIC,QUARTIC,UNIFAC, UNIFORM,VP1,VP2,SUB1; SYMBOLIC PROCEDURE INT!-FAC X; %INPUT: PRIMITIVE, SQUARE-FREE POLYNOMIAL (S.FORM); %OUTPUT: % LIST OF 'FACTORS' WRT ZLIST; % EACH ITEM IN THIS LIST IS EITHER; % LOG . SQ; % OR ATAN . SQ; % AND THESE LOGS AND ARCTANS ARE ALL THAT IS NEEDED IN THE; % INTEGRATION OF 1/(ARGUMENT); BEGIN SCALAR RES,POL,DSET,VAR,DEGREE,VARS; POL:=F2DF X; %CONVERT TO DISTRIBUTED FORM; DSET:=DEGREESET(POL); %NOW EXTRACT FACTORS OF THE FORM 'X' OR 'LOG(X)' ETC; %THESE CORRESPOND TO ITEMS IN DSET WITH A NON-ZERO CDR; BEGIN SCALAR ZL,DS; ZL:=ZLIST; DS:=DSET; WHILE NOT NULL DS DO << IF ONEP CDAR DS THEN << RES:=('LOG . VAR2DF(CAR ZL,1,ZLIST)) . RES; %RECORD IN ANSWER; POL:=MULTDF(VAR2DF(CAR ZL,-1,ZLIST),POL); %DIVIDE OUT; IF !*TRINT THEN << PRINTC "TRIVIAL FACTOR FOUND"; PRINTDF CDAR RES>>; RPLACA(DS,SUB1 CAAR DS . CDAR DS) >> ELSE IF NULL ZEROP CDAR DS THEN INTERR "REPEATED TRIVIAL FACTOR IN ARG TO FACTOR"; ZL:=CDR ZL; DS:=CDR DS >>; END; %SINGLE TERM FACTORS ALL REMOVED NOW; DSET:=MAPCAR(DSET,FUNCTION CAR); %GET LOWER BOUNDS; IF !*TRINT THEN PRINTC ("UPPER BOUNDS OF REMAINING FACTORS ARE NOW: " . DSET); IF DSET=VP2 ZLIST THEN GO TO FINISHED; %THING LEFT IS CONSTANT; BEGIN SCALAR DS,ZL; VAR:=CAR ZLIST; DEGREE:=CAR DSET; IF NOT ZEROP DEGREE THEN VARS:=VAR . VARS; DS:=CDR DSET; ZL:=CDR ZLIST; WHILE NOT NULL DS DO << IF NOT ZEROP CAR DS THEN << VARS:=CAR ZL . VARS; IF ZEROP DEGREE OR DEGREE>CAR DS THEN << VAR:=CAR ZL; DEGREE:=CAR DS >> >>; ZL:=CDR ZL; DS:=CDR DS >> END; % NOW VAR IS VARIABLE THAT THIS POLY INVOLVES TO LOWEST DEGREE; % DEGREE IS THE DEGREE OF THE POLY IN SAME VARIABLE; IF !*TRINT THEN PRINTC ("BEST VAR IS " . VAR . "WITH EXPONENT " . DEGREE); IF ONEP DEGREE THEN << RES:=('LOG . POL) . RES; %CERTAINLY IRREDUCIBLE; IF !*TRINT THEN << PRINTC "THE FOLLOWING IS CERTAINLY IRREDUCIBLE"; PRINTDF POL>>; GO TO FINISHED >>; IF DEGREE=2 THEN << IF !*TRINT THEN << PRINTC "QUADRATIC"; PRINTDF POL>>; RES:=QUADRATIC(POL,VAR,RES); GO TO FINISHED >>; DSET:=UNIFORM(POL,VAR); IF NOT (DSET='FAILED) THEN << IF !*TRINT THEN << PRINTC "UNIVARIATE POLYNOMIAL"; PRINTDF POL >>; RES:=UNIFAC(DSET,VAR,DEGREE,RES); GO TO FINISHED >>; IF NOT NULL CDR VARS THEN GO TO NASTY; %ONLY TRY UNIVARIATE NOW; IF DEGREE=3 THEN << IF !*TRINT THEN << PRINTC "CUBIC"; PRINTDF POL>>; RES:=CUBIC(POL,VAR,RES); % IF !*OVERLAYMODE % THEN EXCISE 'D3D4; GO TO FINISHED >>; IF DEGREE=4 THEN << IF !*TRINT THEN << PRINTC "QUARTIC"; PRINTDF POL>>; RES:=QUARTIC(POL,VAR,RES); % IF !*OVERLAYMODE % THEN EXCISE 'D3D4; GO TO FINISHED>>; %ELSE ABANDON HOPE AND HAND BACK SOME RUBBISH.; NASTY: RES:=('LOG . POL) . RES; PRINTC "THE FOLLOWING POLYNOMIAL HAS NOT BEEN PROPERLY FACTORED"; PRINTDF POL; GO TO FINISHED; FINISHED: %RES IS A LIST OF D.F. S AS REQUIRED; POL:=NIL; %CONVERT BACK TO STANDARD FORMS; WHILE NOT NULL RES DO BEGIN SCALAR TYPE,ARG; TYPE:=CAAR RES; ARG:=CDAR RES; ARG:=DF2Q ARG; IF TYPE='LOG THEN RPLACD(ARG,1); POL:=(TYPE . ARG) . POL; RES:=CDR RES END; RETURN POL END; SYMBOLIC PROCEDURE VAR2DF(VAR,N,ZLIST); ((VP1(VAR,N,ZLIST) .* (1 ./ 1)) .+ NIL); SYMBOLIC PROCEDURE DEGREESET POL; %FINDS DEGREE BOUNDS FOR ALL VARS IN DISTRIBTED FORM POLY; DEGREESUB(DBL LPOW POL,RED POL); SYMBOLIC PROCEDURE DBL X; % CONVERTS LIST OF X INTO LIST OF (X . X); IF NULL X THEN NIL ELSE (CAR X . CAR X) . DBL CDR X; SYMBOLIC PROCEDURE DEGREESUB(CUR,POL); % UPDATE DEGREE BOUNDS 'CUR' TO INCLUDE INFO ABOUT POL; << WHILE NOT NULL POL DO << CUR:=DEGREESUB1(CUR,LPOW POL); POL:=RED POL >>; CUR >>; SYMBOLIC PROCEDURE DEGREESUB1(CUR,NXT); %MERGE INFORMATION FROM EXPONENT SET NEXT INTO CUR; IF NULL CUR THEN NIL ELSE DEGREESUB2(CAR CUR,CAR NXT) . DEGREESUB1(CDR CUR,CDR NXT); SYMBOLIC PROCEDURE DEGREESUB2(TWO,ONE); MAX(CAR TWO,ONE) . MIN(CDR TWO,ONE); ENDMODULE; MODULE IBASICS; EXPORTS PARTIALDIFF,PRINTDF,PRINTSQ,RATIONALINTEGRATE,PRINTSF,INTERR; IMPORTS DF2PRINTFORM,SQPRINT,VARSINSF,TERPRI!*,ADDSQ,MULTSQ,MULTD,MKSP; %PRINT STANDARD QUOTIENT (RATIONAL FUNCTION); % CRUDE EQUIVALENT TO PRINTSF NUMR U: "/": PRINTSF DENO U; SYMBOLIC PROCEDURE PRINTSQ U; BEGIN TERPRI!*(T); %START ON A NEW LINE; SQPRINT U; %LOGICAL PRINT ROUTINE; TERPRI!*(T) END; % PRINT STANDARD FORM (POLYNOMIAL); FLUID '(U!*); %NEEDED BECAUSE OF THE ERRORSET; SYMBOLIC PROCEDURE PRINTSF U!*; IF NULL U!* THEN PRINT 0 ELSE BEGIN SCALAR W; W:=ERRORSET('(PROG NIL (TERPRI!* T) (XPRINF U!* NIL NIL) (TERPRI!* T)),2,!*BACKTRACE); IF NOT ATOM W THEN RETURN CAR W; PRINTC "REDUCE PRINTING FAILED ON STANDARD FORM"; PRINT U!*; TERPRI!*(T); RETURN U!* END; UNFLUID '(U!*); SYMBOLIC PROCEDURE PRINTDF U; % PRINT DISTRIBUTED FORM VIA CHEAP CONVERSION TO REDUCE STRUCTURE; BEGIN SCALAR !*GCD; PRINTSF DF2PRINTFORM U; END; SYMBOLIC PROCEDURE INTERR MESS; BEGIN PRINTC "INTEGRATION PACKAGE ERROR"; PRINTC MESS; ERROR1() END; SYMBOLIC PROCEDURE RATIONALINTEGRATE(X,VAR); BEGIN SCALAR N,D; N:=NUMR X; D:=DENR X; IF NOT VAR MEMBER VARSINSF(D,NIL) THEN RETURN SUBS2Q MULTSQ(POLYNOMIALINTEGRATE(N,VAR),1 ./ D); INTERR "RATIONAL INTEGRATION NOT CODED YET" END; % INTEGRATE STANDARD FORM. RESULT IS STANDARD QUOTIENT; SYMBOLIC PROCEDURE POLYNOMIALINTEGRATE(X,V); IF NULL X THEN NIL ./ 1 ELSE IF ATOM X THEN ((MKSP(V,1) .* 1) .+ NIL) ./ 1 ELSE BEGIN SCALAR R; R:=POLYNOMIALINTEGRATE(RED X,V); % DEAL WITH REDUCTUM; IF V=MVAR X THEN BEGIN SCALAR DEGREE,NEWLT; DEGREE:=1+TDEG LT X; NEWLT:=((MKSP(V,DEGREE) .* LC X) .+ NIL) ./ 1; % UP EXPONENT; R:=ADDSQ(MULTSQ(NEWLT,1 ./ DEGREE),R) END ELSE BEGIN SCALAR NEWTERM; NEWTERM:=(((LPOW X) .* 1) .+ NIL) ./ 1; NEWTERM:=MULTSQ(NEWTERM,POLYNOMIALINTEGRATE(LC X,V)); R:=ADDSQ(R,NEWTERM) END; RETURN SUBS2Q R END; % PARTIAL DIFFERENTIATION OF P WRT V - P IS S.F. AS IS RESULT; SYMBOLIC PROCEDURE PARTIALDIFF(P,V); IF ATOM P THEN NIL ELSE IF V=MVAR P THEN (LAMBDA X; IF X=1 THEN LC P ELSE ((MKSP(V,X-1) .* MULTD(X,LC P)) .+ PARTIALDIFF(RED P,V))) (TDEG LT P) ELSE (LAMBDA X; IF NULL X THEN PARTIALDIFF(RED P,V) ELSE ((LPOW P .* X) .+ PARTIALDIFF(RED P,V))) (PARTIALDIFF(LC P,V)); PUT('PDIFF,'SIMPFN,'SIMPPDIFF); ENDMODULE; MODULE JPATCHES; EXPORTS !*MULTF!*; IMPORTS !*MULTF!*SQRT,SIMPSQRTI,RETIMES,MULTSQ,SIMPEXPT,INVSQ,MKSQ,XN, FLATTEN,MKSPM,MKSP,EXPTF,SIMP,GCDN,ADDF,ORDOP,NONCOMP,MKSFPF, MULTD,DOMAINP; %SYMBOLIC PROCEDURE SIMPX1(U,M,N); % %U,M AND N ARE PREFIX EXPRESSIONS; % %VALUE IS THE STANDARD QUOTIENT EXPRESSION FOR U**(M/N); % BEGIN SCALAR FLG,Z; % IF NULL FRLIS!* OR NULL XN(FRLIS!*,FLATTEN (M . N)) % THEN GO TO A; % EXPTP!* := T; % RETURN !*K2Q LIST('EXPT,U,IF N=1 THEN M % ELSE LIST('QUOTIENT,M,N)); % A: IF NUMBERP M AND FIXP M THEN GO TO E % ELSE IF ATOM M THEN GO TO B % ELSE IF CAR M EQ 'MINUS THEN GO TO MNS % ELSE IF CAR M EQ 'PLUS THEN GO TO PLS % ELSE IF CAR M EQ 'TIMES AND NUMBERP CADR M AND FIXP CADR M % AND NUMBERP N % THEN GO TO TMS; % B: Z := 1; % C: IF ATOM U AND NOT NUMBERP U THEN FLAG(LIST U,'USED!*); % U := LIST('EXPT,U,IF N=1 THEN M ELSE LIST('QUOTIENT,M,N)); % IF NOT U MEMBER EXPTL!* THEN EXPTL!* := U . EXPTL!*; % D: RETURN MKSQ(U,IF FLG THEN -Z ELSE Z); %U IS ALREADY IN LOWEST % %TERMS; % E: IF NUMBERP N AND FIXP N THEN GO TO INT; % Z := M; % M := 1; % GO TO C; % MNS: M := CADR M; % IF !*MCD THEN RETURN INVSQ SIMPX1(U,M,N); % FLG := NOT FLG; % GO TO A; % PLS: Z := 1 ./ 1; % PL1: M := CDR M; % IF NULL M THEN RETURN Z; % Z := MULTSQ(SIMPEXPT LIST(U, % LIST('QUOTIENT,IF FLG THEN LIST('MINUS,CAR M) % ELSE CAR M,N)), % Z); % GO TO PL1; % TMS: Z := GCDN(N,CADR M); % N := N/Z; % Z := CADR M/Z; % M := RETIMES CDDR M; % GO TO C; % INT:Z := DIVIDE(M,N); % IF CDR Z<0 THEN Z:= (CAR Z - 1) . (CDR Z+N); % IF CDR Z=0 % THEN RETURN SIMPEXPT LIST(U,CAR Z); % IF N=2 AND !*SQRT % THEN RETURN MULTSQ(SIMPEXPT LIST(U,CAR Z), % SIMPSQRTI U); % RETURN MULTSQ(SIMPEXPT LIST(U,CAR Z), % MKSQ(LIST('EXPT,U,LIST('QUOTIENT,1,N)),CDR Z)) % END; ENDMODULE; MODULE KRON; EXPORTS LINFAC,QUADFAC; IMPORTS EVALAT,LINETHROUGH,QUADTHROUGH,TESTDIV; %KRONEKER FACTORIZATION FOR UNIVARIATE POLYS OVER THE INTEGERS; %ONLY LINEAR AND QUADRATIC FACTORS ARE FOUND HERE; SYMBOLIC PROCEDURE LINFAC(W); TRYKR(W,'(0 1)); SYMBOLIC PROCEDURE QUADFAC(W); TRYKR(W,'(-1 0 1)); SYMBOLIC PROCEDURE TRYKR(W,POINTS); %LOOK FOR FACTOR OF W BY EVALUATION AT (POINTS) AND USE OF; % INTERPOLATE. RETURN (FAC . COFAC) WITH FAC=NIL IF NONE; %FOUND AND COFAC=NIL IF NOTHING WORTHWHILE IS LEFT; BEGIN SCALAR VALUES,ATTEMPT; IF NULL W THEN RETURN NIL . NIL; IF (LENGTH POINTS > CAR W) THEN RETURN W . NIL; %THAT SAYS IF W IS ALREADY TINY, IT IS ALREADY FACTORED; VALUES:=MAPCAR(POINTS,FUNCTION (LAMBDA X; EVALAT(W,X))); IF !*TRINT THEN << PRINTC ("AT X= " . POINTS); PRINTC ("P(X)= " . VALUES)>>; IF 0 MEMBER VALUES THEN GO TO LUCKY; %(X-1) IS A FACTOR!; VALUES:=MAPCAR(VALUES,FUNCTION ZFACTORS); RPLACD(VALUES,MAPCAR(CDR VALUES,FUNCTION (LAMBDA Y; APPEND(Y,MAPCAR(Y,FUNCTION MINUS))))); IF !*TRINT THEN <<PRINTC "POSSIBLE FACTORS GO THROUGH SOME OF"; PRINT VALUES>>; ATTEMPT:=SEARCH4FAC(W,VALUES,NIL); IF NULL ATTEMPT THEN ATTEMPT:=NIL . W; RETURN ATTEMPT; LUCKY: %HERE (X-1) IS A FACTOR BECAUSE P(0) OR P(1) OR P(-1); %VANISHED AND CASES P(0), P(-1) WILL HAVE BEEN REMOVED; %ELSEWHERE; ATTEMPT:='(1 1 -1); %THE FACTOR; RETURN ATTEMPT . TESTDIV(W,ATTEMPT) END; SYMBOLIC PROCEDURE SEARCH4FAC(W,VALUES,CV); %COMBINATORIAL SEARCH. CV GETS CURRENT SELECTED VALUE-SET; %RETURNS NIL IF FAILS, ELSE FACTOR . COFACTOR; IF NULL VALUES THEN TRYFACTOR(W,CV) ELSE BEGIN SCALAR FF,Q; FF:=CAR VALUES; %TRY ALL VALUES HERE; LOOP: IF NULL FF THEN RETURN NIL; %NO FACTOR FOUND; Q:=SEARCH4FAC(W,CDR VALUES,(CAR FF) . CV); IF NULL Q THEN << FF:=CDR FF; GO TO LOOP>>; RETURN Q END; SYMBOLIC PROCEDURE TRYFACTOR(W,CV); %TESTS IF CV REPRESENTS A FACTOR OF W; BEGIN SCALAR FF,Q; IF NULL CDDR CV THEN FF:=LINETHROUGH(CADR CV,CAR CV) ELSE FF:=QUADTHROUGH(CADDR CV,CADR CV,CAR CV); IF FF='FAILED THEN RETURN NIL; %IT DOES NOT INTERPOLATE; Q:=TESTDIV(W,FF); IF Q='FAILED THEN RETURN NIL; %NOT A FACTOR; RETURN FF . Q END; ENDMODULE; MODULE LOWDEG; EXPORTS FORCEAZERO,MAKEPOLYDF,QUADRATIC,COVECDF,EXPONENTDF; IMPORTS DFQUOTDF,GCDF,INTERR,MINUSDFP,MULTDF,MULTDFCONST,!*MULTF!*, NEGSQ,MINUSP,PRINTSQ,MULTSQ,INVSQ,PNTH,NTH,MKNILL, NEGDF,PLUSDF,PRINTDF,PRINTSQ,QUOTF,SQRTDF,VAR2DF,VP2,ADDSQ,SUB1; %SPLITTING OF LOW DEGREE POLYNOMIALS; SYMBOLIC PROCEDURE COVECDF(POL,VAR,DEGREE); %EXTRACT COEFFICIENTS OF POLYNOMIAL WRT VAR, GIVEN A DEGREE-BOUND % DEGREE; %RESUL IS A LISP VECTOR; BEGIN SCALAR I,V,X,W; W:=POL; V:=MKVECT(DEGREE); WHILE NOT NULL W DO << X:=EXPONENTOF(VAR,LPOW W,ZLIST); IF (X<0) OR (X>DEGREE) THEN INTERR "BAD DEGREE IN COVECDF"; PUTV(V,X,LT W . GETV(V,X)); W:=RED W >>; FOR I:=0:DEGREE DO PUTV(V,I,MULTDF(REVERSEWOC GETV(V,I), VAR2DF(VAR,-I,ZLIST))); RETURN V END; SYMBOLIC PROCEDURE QUADRATIC(POL,VAR,RES); %ADD IN TO RES LOGS OR ARCTANS CORRESPONDING TO SPLITTING THE % POLYNOMIAL; % POL GIVEN THAT IT IS QUADRATIC WRT VAR; %; %DOES NOT ASSUME POL IS UNIVARIATE; BEGIN SCALAR A,B,C,W,DISCRIM; W:=COVECDF(POL,VAR,2); A:=GETV(W,2); B:=GETV(W,1); C:=GETV(W,0); % THAT SPLIT THE QUADRATIC UP TO FIND THE COEFFICIENTS A,B,C; IF !*TRINT THEN << PRINTC "A="; PRINTDF A; PRINTC "B="; PRINTDF B; PRINTC "C="; PRINTDF C>>; DISCRIM:=PLUSDF(MULTDF(B,B), MULTDFCONST((-4) . 1,MULTDF(A,C))); IF !*TRINT THEN << PRINTC "DISCRIMINANT IS"; PRINTDF DISCRIM>>; IF NULL DISCRIM THEN INTERR "DISCRIM=0 IN QUADRATIC"; IF KNOWNDISCRIMSIGN THEN <<IF KNOWNDISCRIMSIGN EQ 'NEGATIVE THEN GO TO ATANCASE>> ELSE IF (NOT CLOGFLAG) AND (MINUSDFP DISCRIM) THEN GO TO ATANCASE; DISCRIM:=SQRTDF(DISCRIM); IF DISCRIM='FAILED THEN GO TO NOFACTORS; IF !*TRINT THEN << PRINTC "SQUARE-ROOT IS"; PRINTDF DISCRIM>>; W:=VAR2DF(VAR,1,ZLIST); W:=MULTDF(W,A); B:=MULTDFCONST(1 ./ 2,B); DISCRIM:=MULTDFCONST(1 ./ 2,DISCRIM); W:=PLUSDF(W,B); %A*X+B/2; A:=PLUSDF(W,DISCRIM); B:=PLUSDF(W,NEGDF(DISCRIM)); IF !*TRINT THEN << PRINTC "FACTORS ARE"; PRINTDF A; PRINTDF B>>; RETURN ('LOG . A) . ('LOG . B) . RES; ATANCASE: DISCRIM:=SQRTDF NEGDF DISCRIM; %SQRT(4*A*C-B**2) THIS TIME!; IF DISCRIM='FAILED THEN GO TO NOFACTORS; %SQRT DID NOT EXIST?; RES := ('LOG . POL) . RES; %ONE PART OF THE ANSWER; A:=MULTDF(A,VAR2DF(VAR,1,ZLIST)); A:=PLUSDF(B,MULTDFCONST(2 ./ 1,A)); A:=DFQUOTDF(A,DISCRIM); %ASSUMES DIVISION IS EXACT; RETURN ('ATAN . A) . RES; NOFACTORS: PRINTC "THE FOLLOWING QUADRATIC DOES NOT SEEM TO FACTOR"; PRINTDF POL; RETURN ('LOG . POL) . RES END; SYMBOLIC PROCEDURE EXPONENTOF(VAR,L,ZL); IF NULL ZL THEN INTERR "VAR NOT FOUND IN EXPONENTOF" ELSE IF VAR=CAR ZL THEN CAR L ELSE EXPONENTOF(VAR,CDR L,CDR ZL); SYMBOLIC PROCEDURE DF2SF A; IF NULL A THEN NIL ELSE IF ((NULL RED A) AND (ONEP DENR LC A) AND (LPOW A=VP2 ZLIST)) THEN NUMR LC A ELSE INTERR "NASTY CUBIC OR QUARTIC"; SYMBOLIC PROCEDURE MAKEPOLYDF P; %MULTIPLY DF BY LCM OF DENOMINATORS OF ALL COEFFICIENT DENOMINATORS; BEGIN SCALAR H,W; IF NULL(W:=P) THEN RETURN NIL; %POLY IS ZERO ALREADY; H:=DENR LC W; %A GOOD START; W:=RED W; WHILE NOT NULL W DO << H:=QUOTF(!*MULTF!*(H,DENR LC W),GCDF(H,DENR LC W)); W:=RED W >>; %H IS NOW LCM OF DENOMINATORS; RETURN MULTDFCONST(!*F2POL H ./ 1,P) END; SYMBOLIC PROCEDURE FORCEAZERO(P,N); %SHIFT POLYNOMIAL P SO THAT COEFF OF X**(N-1) VANISHES; %RETURN THE AMOUNT OF THE SHIFT, UPDATE (VECTOR) P; BEGIN SCALAR R,I,W; FOR I:=0:N DO PUTV(P,I,DF2SF GETV(P,I)); %CONVERT TO POLYS; R:=GETV(P,N-1); IF NULL R THEN RETURN NIL ./ 1; %ALREADY ZERO; R:= SUBS2Q MULTSQ(R ./ 1,INVSQ(!*MULTF!*(N,GETV(P,N)) ./ 1)); %THE SHIFT AMOUNT; %NOW I HAVE TO SET P:=SUBST(X-R,X,P) AND THEN REDUCE TO SF AGAIN; IF !*TRINT THEN << PRINTC "SHIFT IS BY "; PRINTSQ R>>; W:=MKVECT(N); %WORKSPACE VECTOR; FOR I:=0:N DO PUTV(W,I,NIL ./ 1); %ZERO IT; I:=N; WHILE NOT MINUSP I DO << MULVECBYXR(W,NEGSQ R,N); %W:=(X-R)*W; PUTV(W,0,ADDSQ(GETV(W,0),GETV(P,I) ./ 1)); I:=I-1 >>; IF !*TRINT THEN << PRINTC "SQ SHIFTED POLY IS"; PRINT W>>; FOR I:=0:N DO PUTV(P,I,GETV(W,I)); W:=DENR GETV(P,0); FOR I:=1:N DO W:=QUOTF(!*MULTF!*(W,DENR GETV(P,I)), GCDF(W,DENR GETV(P,I))); FOR I:=0:N DO PUTV(P,I,NUMR SUBS2Q MULTSQ(GETV(P,I),W ./ 1)); W:=GETV(P,0); FOR I:=1:N DO W:=GCDF(W,GETV(P,I)); IF NOT (W=1) THEN FOR I:=0:N DO PUTV(P,I,QUOTF(GETV(P,I),W)); IF !*TRINT THEN << PRINTC "FINAL SHIFTED POLY IS "; PRINT P>>; RETURN R END; SYMBOLIC PROCEDURE MULVECBYXR(W,R,N); %W IS A VECTOR REPRESENTING A POLY OF DEGREE N; %MULTIPLY IT BY (X+R); BEGIN SCALAR I,IM1; I:=N; IM1:=SUB1 I; WHILE NOT MINUSP IM1 DO << PUTV(W,I,SUBS2Q ADDSQ(GETV(W,IM1),MULTSQ(R,GETV(W,I)))); I:=IM1; IM1:=SUB1 I >>; PUTV(W,0,SUBS2Q MULTSQ(GETV(W,0),R)); RETURN W END; ENDMODULE; MODULE REFORM; EXPORTS LOGSTOSQ,SUBSTINULIST; IMPORTS PREPSQ,MKSP,NTH,MULTSQ,ADDSQ,DOMAINP,INVSQ,PLUSDF; SYMBOLIC PROCEDURE SUBSTINULIST ULIST; % Substitutes for the C-constants in the values of the U's given in; % ULIST. Result is a D.F.; IF NULL ULIST THEN NIL ELSE BEGIN SCALAR TEMP,LCU; LCU:=LC ULIST; TEMP:=EVALUATEUCONST NUMR LCU; IF NULL NUMR TEMP THEN TEMP:=NIL ELSE TEMP:=((LPOW ULIST) .* SUBS2Q MULTSQ(TEMP,INVSQ(DENR LCU ./ 1))) .+ NIL; RETURN PLUSDF(TEMP,SUBSTINULIST RED ULIST) END; SYMBOLIC PROCEDURE EVALUATEUCONST COEFFT; % Substitutes for the C-constants into COEFFT (=S.F.). Result is S.Q.; IF NULL COEFFT OR DOMAINP COEFFT THEN COEFFT ./ 1 ELSE BEGIN SCALAR TEMP; IF NULL(TEMP:=ASSOC(MVAR COEFFT,CMAP)) THEN TEMP:=(!*P2F LPOW COEFFT) ./ 1 ELSE TEMP:=GETV(CVAL,CDR TEMP); TEMP:=MULTSQ(TEMP,EVALUATEUCONST(LC COEFFT)); RETURN SUBS2Q ADDSQ(TEMP,EVALUATEUCONST(RED COEFFT)) END; SYMBOLIC PROCEDURE LOGSTOSQ; % Converts LOGLIST to sum of the log terms as a S.Q.; BEGIN SCALAR LGLST,LOGSQ,I,TEMP; I:=1; LGLST:=LOGLIST; LOGSQ:=NIL ./ 1; LOOP: IF NULL LGLST THEN RETURN LOGSQ; TEMP:=CDDR CAR LGLST; IF !*TRINT THEN << PRINTC "Standard Form ARG FOR ADDITIONAL LOG ETC ="; PRINT TEMP >>; IF NOT (CAAR LGLST='IDEN) THEN << TEMP:=PREPSQ TEMP; %CONVERT TO PREFIX FORM; TEMP:=LIST(CAAR LGLST,TEMP); %FUNCTION NAME; TEMP:=((MKSP(TEMP,1) .* 1) .+ NIL) ./ 1 >>; TEMP:=MULTSQ(TEMP,GETV(CVAL,I)); LOGSQ:= SUBS2Q ADDSQ(TEMP,LOGSQ); LGLST:=CDR LGLST; I:=I+1; GO TO LOOP END; ENDMODULE; MODULE SIMPLOG; EXPORTS SIMPLOG,SIMPLOGSQ; IMPORTS QUOTF,PREPF,MKSP,SIMP!*,MULTSQ,SIMPTIMES,ADDSQ,MINUSF,NEGF, ADDF,COMFAC,NEGSQ,MK!*SQ,CARX; SYMBOLIC PROCEDURE SIMPLOG(EXXPR); SIMPLOGI(CARX(EXXPR,'LOG)); SYMBOLIC PROCEDURE SIMPLOGI(SQ); BEGIN IF ATOM SQ THEN GO TO SIMPLIFY; IF CAR SQ EQ 'TIMES THEN RETURN ADDSQ(SIMPLOGI CADR SQ,SIMPLOGI CADDR SQ); IF CAR SQ EQ 'QUOTIENT THEN RETURN ADDSQ(SIMPLOGI CADR SQ, NEGSQ SIMPLOGI CADDR SQ); IF CAR SQ EQ 'EXPT THEN RETURN SIMPTIMES LIST(CADDR SQ, MK!*SQ SIMPLOGI CADR SQ); IF CAR SQ = '!*SQ THEN RETURN SIMPLOGSQ CADR SQ; SIMPLIFY: SQ:=SIMP!* SQ; RETURN SIMPLOGSQ SQ END; SYMBOLIC PROCEDURE SIMPLOGSQ SQ; ADDSQ((SIMPLOG2 NUMR SQ),NEGSQ(SIMPLOG2 DENR SQ)); SYMBOLIC PROCEDURE SIMPLOG2(SF); IF ATOM SF THEN IF NULL SF THEN REDERR "LOG 0 FORMED" ELSE IF NUMBERP SF THEN IF SF IEQUAL 1 THEN NIL ./ 1 ELSE IF SF IEQUAL 0 THEN REDERR "LOG 0 FORMED" ELSE((MKSP(LIST('LOG,SF),1) .* 1) .+ NIL) ./ 1 ELSE FORMLOG(SF) ELSE BEGIN SCALAR FORM; FORM:=COMFAC SF; IF NOT NULL CAR FORM THEN RETURN ADDSQ(FORMLOG(FORM .+ NIL), SIMPLOG2 QUOTF(SF,FORM .+ NIL)); % WE HAVE KILLED COMMON POWERS; FORM:=CDR FORM; IF FORM NEQ 1 THEN RETURN ADDSQ(SIMPLOG2 FORM, SIMPLOG2 QUOTF(SF,FORM)); % REMOVE A COMMON FACTOR FROM THE SF; RETURN (FORMLOG SF) END; SYMBOLIC PROCEDURE FORMLOG(SF); IF (NULL RED SF) THEN IF EQCAR(MVAR SF,'EXPT) THEN ADDSQ(SIMPLOG2 LC SF, SUBS2Q MULTSQ(SIMPLOGI MVAR SF,SIMP!* LDEG SF)) ELSE IF (LC SF IEQUAL 1) AND (LDEG SF IEQUAL 1) THEN ((MKSP(LIST('LOG,MVAR SF),1) .* 1) .+ NIL) ./ 1 ELSE ADDSQ(SIMPTIMES LIST(LIST('LOG,MVAR SF),LDEG SF), SIMPLOG2 LC SF) ELSE IF MINUSF SF THEN ADDF((MKSP(LIST('LOG,-1),1) .* 1) .+ NIL, FORMLOG2 NEGF SF) ./ 1 ELSE (FORMLOG2 SF) ./ 1; SYMBOLIC PROCEDURE FORMLOG2 SF; ((MKSP(LIST('LOG,PREPF SF),1) .* 1) .+ NIL); ENDMODULE; MODULE SIMPSQRT; SYMBOLIC PROCEDURE SIMPSQRTSQ SQ; (SIMPSQRT2 NUMR SQ) ./ (SIMPSQRT2 DENR SQ); SYMBOLIC PROCEDURE SIMPSQRT2(SF); IF ATOM SF THEN IF NULL SF THEN NIL ELSE IF NUMBERP SF THEN IF MINUSP SF THEN !*F2POL !*MULTF!*(SIMPSQRT2 (-SF), (MKSP(MKSQRT(-1),1) .* 1) .+ NIL) ELSE BEGIN SCALAR N; N:=SQRT SF; IF IDP N THEN RETURN (MKSP(MKSQRT!* SF,1) .* 1) .+ NIL ELSE RETURN N END ELSE FORMSQRT(SF) ELSE BEGIN SCALAR FORM; FORM:=COMFAC SF; IF NOT NULL CAR FORM THEN RETURN !*F2POL !*MULTF!*(FORMSQRT(FORM .+ NIL), SIMPSQRT2 QUOTF(SF,FORM .+ NIL)); % WE HAVE KILLED COMMON POWERS; FORM:=CDR FORM; IF FORM NEQ 1 THEN RETURN !*F2POL !*MULTF!*(SIMPSQRT2 FORM, SIMPSQRT2 QUOTF(SF,FORM)); % REMOVE A COMMON FACTOR FROM THE SF; RETURN FORMSQRT SF END; SYMBOLIC PROCEDURE FORMSQRT(SF); %Is *F2POL really necessary here??; IF (NULL RED SF) THEN IF (LC SF IEQUAL 1) AND (LDEG SF IEQUAL 1) THEN (MKSP(MKSQRT!* MVAR SF,1) .* 1) .+ NIL ELSE !*F2POL !*MULTF!*(NUMR SIMPEXPT(LIST(MKSQRT!* MVAR SF,LDEG SF)), SIMPSQRT2 LC SF) ELSE (MKSP(MKSQRT!* SF,1) .* 1) .+ NIL; SYMBOLIC PROCEDURE MKSQRT!* U; IF SFP U THEN MKSQRT !*F2A U ELSE MKSQRT U; ALGEBRAIC; % OPERATOR SQRT; SYMBOLIC; % DEFLIST ('((SQRT (((X) QUOTIENT (SQRT X) (TIMES 2 X))))),'DFN); SYMBOLIC PROCEDURE SIMPSQRTI SQ; BEGIN IF ATOM SQ THEN IF NUMBERP SQ THEN RETURN (SIMPSQRT2 SQ) ./ 1 ELSE RETURN ((MKSP(MKSQRT SQ,1) .* 1) .+ NIL) ./ 1; IF CAR SQ EQ 'TIMES THEN RETURN SUBS2Q MULTSQ(SIMPSQRTI CADR SQ,SIMPSQRTI CADDR SQ); IF CAR SQ EQ 'QUOTIENT THEN RETURN SUBS2Q MULTSQ(SIMPSQRTI CADR SQ, INVSQ SIMPSQRTI CADDR SQ); IF CAR SQ EQ 'EXPT THEN RETURN SIMPEXPT LIST(MK!*SQ SIMPSQRTI CADR SQ,CADDR SQ); IF CAR SQ = '!*SQ THEN RETURN SIMPSQRTSQ CADR SQ; RETURN SIMPSQRTSQ SIMP!* SQ END; ENDMODULE; MODULE SOLVE; EXPORTS SOLVE!-FOR!-U; IMPORTS NTH,FINDPIVOT,GCDF,GENSYM1,MKVECT,INTERR,MULTDFCONST, !*MULTF!*,NEGDF,ORDDF,PLUSDF,PRINTDF,PRINTSF,PRINTSPREADC,PRINTSQ, QUOTF,PUTV,SPREADC,SUBST4ELIMINATEDCS,MKNILL,PNTH,DOMAINP,ADDF, INVSQ,MULTSQ; %*********************************************************************** % ROUTINES FOR SOLVING THE FINAL REDUCTION EQUATION: %**********************************************************************; SYMBOLIC PROCEDURE UTERM(POWU,RHS); % Finds the contribution from RHS of reduction equation, of the; % U-coefficient given by POWU. Result is in D.F.; IF NULL RHS THEN NIL ELSE BEGIN SCALAR COEF,POWER; POWER:=ADDINDS(POWU,LPOW RHS); COEF:=EVALUATECOEFFTS(NUMR LC RHS,POWU); IF NULL COEF THEN RETURN UTERM(POWU,RED RHS); COEF:=COEF ./ DENR LC RHS; RETURN PLUSDF((POWER .* COEF) .+ NIL,UTERM(POWU,RED RHS)) END; SYMBOLIC PROCEDURE SOLVE!-FOR!-U(RHS,LHS,ULIST); % Solves the reduction eqn LHS = RHS. Returns list of U-coefficients; % and their values (ULIST are those we have so far), and a list of; % C-equations to be solved (CLIST are the eqns we have so far); IF NULL LHS THEN ULIST ELSE BEGIN SCALAR U,LPOWLHS; LPOWLHS:=LPOW LHS; BEGIN SCALAR LL,MM,CHGE; LL:=MAXORDER(RHS,ZLIST,0); MM:=LORDER; WHILE MM DO << IF CAR LL < CAR MM THEN << CHGE:=T; RPLACA(MM,CAR LL) >>; LL:=CDR LL; MM:=CDR MM >>; IF !*TRINT AND CHGE THEN << PRINT ("Maxorder now ".LORDER) >> END; U:=PICKUPU(RHS,LPOW LHS,T); IF NULL U THEN << IF !*TRINT THEN << PRINTC "****** C-EQUATION TO SOLVE:"; PRINTSF NUMR LC LHS; PRINTC " = 0"; PRINTC " ">>; % Remove a zero constant from the lhs, rather than use % Gauss Elim; IF GAUSSELIMN(NUMR LC LHS,LT LHS) THEN LHS:=SQUASHCONSTANTS(RED LHS) ELSE LHS:=RED LHS >> ELSE << ULIST:=(CAR U . SUBS2Q MULTSQ(COEFDF(LHS,LPOWLHS),INVSQ CDR U)).ULIST; IF !*STATISTICS THEN !*NUMBER!*:=!*NUMBER!*+1; IF !*TRINT THEN << PRINTC ("**** U(".CAR U); PRINTC " ="; PRINTSQ MULTSQ(COEFDF(LHS,LPOWLHS),INVSQ CDR U); PRINTC " ">>; LHS:=PLUSDF(LHS, NEGDF MULTDFCONST(CDAR ULIST,UTERM(CAR U,RHS))) >>; IF !*TRINT THEN << PRINTC ".... LHS is now:"; PRINTDF LHS; PRINTC " ">>; RETURN SOLVE!-FOR!-U(RHS,LHS,ULIST) END; SYMBOLIC PROCEDURE SQUASHCONSTANTS(EXPRESS); BEGIN SCALAR CONSTLST,II,XP,CL,SUBBY,CMT,XX; CONSTLST:=REVERSE CMAP; CMT:=CMATRIX; XXX: XX:=CAR CMT; % Look at next row of Cmatrix; CL:=CONSTLST; % and list of the names; II:=1; % will become index of removed constant; WHILE NOT GETV(XX,II) DO << II:=II+1; CL:=CDR CL >>; SUBBY:=CAAR CL; %II is now index, and SUBBY the name; IF MEMBER(SUBBY,SILLIESLIST) THEN <<CMT:=CDR CMT; GO TO XXX>>; %This loop must terminate; % This is because at least one constant remains; XP:=PREPSQ !*F2Q GETV(XX,0); % start to build up the answer; CL:=CDR CL; IF NOT (CCOUNT=II) THEN FOR JJ=II+1:CCOUNT DO << IF GETV(XX,JJ) THEN XP:=LIST('PLUS,XP, LIST('TIMES,CAAR CL, PREPSQ !*F2Q GETV(XX,JJ))); CL:=CDR CL >>; XP:=LIST('QUOTIENT,LIST('MINUS,XP), PREPSQ !*F2Q GETV(XX,II)); IF !*TRINT THEN << PRIN2 "Replace "; PRIN2 SUBBY; PRIN2 " by "; PRINTSQ SIMP XP >>; SILLIESLIST:=SUBBY . SILLIESLIST; RETURN SUBDF(EXPRESS,XP,SUBBY) END; SYMBOLIC PROCEDURE CHECKU(ULIST,U); % Checks that U is not already in ULIST - ie. that this u-coefficient; % has not already been given a value; IF NULL ULIST THEN NIL ELSE IF (CAR U) = CAAR ULIST THEN T ELSE CHECKU(CDR ULIST,U); SYMBOLIC PROCEDURE CHECKU1(POWU,RHS); %Checks that use of a particular U-term will not cause trouble; %by introducing negative exponents into lhs when it is used; BEGIN TOP: IF NULL RHS THEN RETURN NIL; IF NEGIND(POWU,LPOW RHS) THEN IF NOT NULL EVALUATECOEFFTS(NUMR LC RHS,POWU) THEN RETURN T; RHS:=RED RHS; GO TO TOP END; SYMBOLIC PROCEDURE NEGIND(PU,PR); %check if substituting index values in power gives rise to -ve % exponents; IF NULL PU THEN NIL ELSE IF (CAR PU+CAAR PR)<0 THEN T ELSE NEGIND(CDR PU,CDR PR); SYMBOLIC PROCEDURE EVALUATECOEFFTS(COEFFT,INDLIST); % Substitutes the values of the i,j,k,...'s that appear in the S.F. ; % COEFFT (=coefficient of r.h.s. of reduction equation). Result is S.F.; IF NULL COEFFT OR DOMAINP COEFFT THEN IF ZEROP COEFFT THEN NIL ELSE COEFFT ELSE BEGIN SCALAR TEMP; IF MVAR COEFFT MEMBER INDEXLIST THEN TEMP:=VALUECOEFFT(MVAR COEFFT,INDLIST,INDEXLIST) ELSE TEMP:=!*P2F LPOW COEFFT; TEMP:=!*MULTF!*(TEMP,EVALUATECOEFFTS(LC COEFFT,INDLIST)); RETURN ADDF(!*F2POL TEMP,EVALUATECOEFFTS(RED COEFFT,INDLIST)) END; SYMBOLIC PROCEDURE VALUECOEFFT(VAR,INDVALUES,INDLIST); % Finds the value of VAR, which should be in INDLIST, given INDVALUES; % - the corresponding values of INDLIST variables; IF NULL INDLIST THEN INTERR "VALUECOEFFT - NO VALUE" ELSE IF VAR EQ CAR INDLIST THEN IF ZEROP CAR INDVALUES THEN NIL ELSE CAR INDVALUES ELSE VALUECOEFFT(VAR,CDR INDVALUES,CDR INDLIST); SYMBOLIC PROCEDURE ADDINDS(POWU,POWRHS); % Adds indices in POWU to those in POWRHS. Result is LPOW of D.F.; IF NULL POWU THEN IF NULL POWRHS THEN NIL ELSE INTERR "POWRHS TOO LONG" ELSE IF NULL POWRHS THEN INTERR "POWU TOO LONG" ELSE (CAR POWU + CAAR POWRHS).ADDINDS(CDR POWU,CDR POWRHS); SYMBOLIC PROCEDURE PICKUPU(RHS,POWLHS,FLG); % Picks up the 'lowest' U coefficient from RHS if it exists and returns; % it in the form of LT of D.F.; % returns NIL if no legal term in RHS can be found; % POWLHS is the power we want to match (LPOW of D.F); % and COEFFU is the list of previous coefficients that must be zero; BEGIN SCALAR COEFFU,U; PT:=RHS; TOP: IF NULL PT THEN RETURN NIL; %no term found - failed; U:=NEXTU(LT PT,POWLHS); %check this term...; IF NULL U THEN GO TO NOTTHISONE; IF NOT TESTORD(CAR U,LORDER) THEN GO TO NEVERTHISONE; IF NOT CHECKCOEFFTS(COEFFU,CAR U) THEN GO TO NOTTHISONE; %that inhibited clobbering things already passed over; IF CHECKU(ULIST,U) THEN GO TO NOTTHISONE; %that avoided redefining a u value; IF CHECKU1(CAR U,RHS) THEN GO TO NEVERTHISONE; %avoid introduction of negative exponents; IF FLG THEN U:=PATCHUPTAN(LIST U,POWLHS,RED PT,RHS); RETURN U; NEVERTHISONE: COEFFU:=(LC PT) . COEFFU; NOTTHISONE: PT:=RED PT; GO TO TOP END; SYMBOLIC PROCEDURE PATCHUPTAN(U,POWLHS,RPT,RHS); BEGIN SCALAR UU,CC,DD,TANLIST,REDU,REDU1; PT:=RPT; WHILE PT DO << IF (UU:=PICKUPU(PT,POWLHS,NIL)) AND TESTORD(CAR UU,LORDER) THEN << % Nasty found, patch it up; CC:=(GENSYM1('!C).CAAR U).CC; % CC is an alist of constants; IF !*TRINT THEN << PRINTC ("****** U(".CAAR U); PRINTC " ="; PRINT CAAR CC >>; REDU:=PLUSDF(REDU, MULTDFCONST(!*K2Q CAAR CC,UTERM(CAAR U,RHS))); U:=UU.U >>; IF PT THEN PT:=RED PT >>; REDU1:=REDU; WHILE REDU1 DO BEGIN SCALAR XX; XX:=CAR REDU1; IF !*TRINT THEN << PRIN2 "Introduced RESIDUE "; PRINT XX >>; IF (NOT TESTORD(CAR XX,LORDER)) THEN << IF !*TRINT THEN << PRINTSQ CDR XX; PRINTC " = 0" >>; IF DD:=KILLSINGLES(CADR XX,CC) THEN << REDU:=SUBDF(REDU,0,CAR DD); REDU1:=SUBDF(REDU1,0,CAR DD); ULIST:=((CDR DD).(NIL ./ 1)).ULIST; U:=RMVE(U,CDR DD); CC:=PURGECONST(CC,DD) >> ELSE REDU1:=CDR REDU1 >> ELSE REDU1:=CDR REDU1 END; FOREACH XX IN REDU DO << IF (NOT TESTORD(CAR XX,LORDER)) THEN << WHILE CC DO << ADDCTOMAP(CAAR CC); ULIST:=((CDAR CC).(!*K2Q CAAR CC)) . ULIST; IF !*STATISTICS THEN !*NUMBER!*:=!*NUMBER!*+1; CC:=CDR CC >>; GAUSSELIMN(NUMR LC REDU,LT REDU)>> >>; IF REDU THEN << WHILE CC DO << ADDCTOMAP(CAAR CC); ULIST:=((CDAR CC).(!*K2Q CAAR CC)).ULIST; IF !*STATISTICS THEN !*NUMBER!*:=!*NUMBER!*+1; CC:=CDR CC >>; LHS:=PLUSDF(LHS,NEGDF REDU) >>; RETURN CAR U END; SYMBOLIC PROCEDURE KILLSINGLES(XX,CC); IF ATOM XX THEN NIL ELSE IF NOT (CDR XX EQ NIL) THEN NIL ELSE BEGIN SCALAR DD; DD:=ASSOC(CAAAR XX,CC); IF DD THEN RETURN DD; RETURN KILLSINGLES(CDAR XX,CC) END; SYMBOLIC PROCEDURE RMVE(L,X); IF CAAR L=X THEN CDR L ELSE CONS(CAR L,RMVE(CDR L,X)); SYMBOLIC PROCEDURE SUBDF(A,B,C); % SUBSTITUTE B FOR C INTO THE DF A; % Used to get rid of silly constants introduced; IF A=NIL THEN NIL ELSE BEGIN SCALAR X; X:=SUBF(NUMR LC A,LIST (C . B)) ; IF X=(NIL . 1) THEN RETURN SUBDF(RED A,B,C) ELSE RETURN PLUSDF( LIST ((LPOW A).((CAR X).MULTF(CDR X,DENR LC A))), SUBDF(RED A,B,C)) END; SYMBOLIC PROCEDURE TESTORD(A,B); % Test order of two DF's in recursive fashion; IF NULL A THEN T ELSE IF CAR A LEQ CAR B THEN TESTORD(CDR A,CDR B) ELSE NIL; SYMBOLIC PROCEDURE TANFROM(RHS,Z,NN); % We notice that in all bad cases we have (j-num)tan**j...; % Extract the num; BEGIN SCALAR N,ZZ,R,RR; R:=RHS; N:=0; ZZ:=ZLIST; WHILE CAR ZZ NEQ Z DO << N:=N+1; ZZ:=CDR ZZ >>; WHILE R DO << RR:=CAAR R; % The list of powers; FOR I=1:N DO RR:=CDR RR; IF FIXP CAAR RR THEN IF CAAR RR>0 THEN << RR:=NUMR CDAR R; IF NULL RED RR THEN RR:=NIL ./ 1 ELSE IF FIXP (RR:=QUOTF(RED RR,LC RR)) THEN RR:=-RR ELSE RR:=0>>; IF ATOM RR THEN RETURN RR; R:=CDR R >>; IF NULL R THEN RETURN MAXFROM(LHS,NN)+1; RETURN MAX(RR,MAXFROM(LHS,NN)+1) END; SYMBOLIC PROCEDURE COEFDF(Y,U); IF Y=NIL THEN NIL ELSE IF LPOW Y=U THEN LC Y ELSE COEFDF(RED Y,U); SYMBOLIC PROCEDURE PURGECONST(A,B); % Remove a const from and expression. May be the same as DELETE?; IF NULL A THEN NIL ELSE IF CAR A=B THEN PURGECONST(CDR A,B) ELSE CONS(CAR A,PURGECONST(CDR A,B)); SYMBOLIC PROCEDURE MAXORDER(RHS,Z,N); % Find a limit on the order of terms, theis is ad hoc; IF NULL Z THEN NIL ELSE IF EQCAR(CAR Z,'SQRT) THEN CONS(1,MAXORDER(RHS,CDR Z,N+1)) ELSE IF (ATOM CAR Z) OR (CAAR Z NEQ 'TAN) THEN CONS(MAXFROM(LHS,N)+1,MAXORDER(RHS,CDR Z,N+1)) ELSE CONS(TANFROM(RHS,CAR Z,N),MAXORDER(RHS,CDR Z,N+1)); SYMBOLIC PROCEDURE MAXFROM(L,N); % Largest order in the nth varable; IF NULL L THEN 0 ELSE MAX(NTH(CAAR L,N+1),MAXFROM(CDR L,N)); SYMBOLIC PROCEDURE COPY U; IF ATOM U THEN U ELSE CONS(COPY CAR U,COPY CDR U); SYMBOLIC PROCEDURE ADDCTOMAP CC; BEGIN SCALAR NCVAL; CCOUNT:=CCOUNT+1; NCVAL:=MKVECT(CCOUNT); FOR I=0:(CCOUNT-1) DO PUTV(NCVAL,I,GETV(CVAL,I)); PUTV(NCVAL,CCOUNT,NIL ./ 1); CVAL:=NCVAL; CMAP:=(CC . CCOUNT).CMAP; IF !*TRINT THEN << PRIN2 "Constant Map CHANGED TO "; PRINT CMAP >>; CMATRIX:=MAPCAR(CMATRIX,FUNCTION ADDTOVECTOR); END; SYMBOLIC PROCEDURE ADDTOVECTOR V; BEGIN SCALAR VV; VV:=MKVECT(CCOUNT); FOR I=0:(CCOUNT-1) DO PUTV(VV,I,GETV(V,I)); PUTV(VV,CCOUNT,NIL); RETURN VV END; SYMBOLIC PROCEDURE CHECKCOEFFTS(CL,INDV); % checks to see that the coefficients in CL (coefficient list - S.Q.s); % are zero when the i,j,k,... are given values in INDV (LPOW of; % D.F.). if so the result is true else NIL=false; IF NULL CL THEN T ELSE BEGIN SCALAR RES; RES:=EVALUATECOEFFTS(NUMR CAR CL,INDV); IF NOT(NULL RES OR RES=0) THEN RETURN NIL ELSE RETURN CHECKCOEFFTS(CDR CL,INDV) END; SYMBOLIC PROCEDURE NEXTU(LTRHS,POWLHS); % picks out the appropriate U coefficients for term: LTRHS to match the; % powers of the z-variables given in POWLHS (= exponent list of D.F.). ; % return this coefficient in form LT of D.F. If U coefficient does; % not exist then result is NIL. If it is multiplied by a zero then; % result is NIL; IF NULL LTRHS THEN NIL ELSE BEGIN SCALAR INDLIST,UCOEFFT; INDLIST:=SUBTRACTINDS(POWLHS,CAR LTRHS,NIL); IF NULL INDLIST THEN RETURN NIL; UCOEFFT:=EVALUATECOEFFTS(NUMR CDR LTRHS,INDLIST); IF NULL UCOEFFT OR UCOEFFT=0 THEN RETURN NIL; RETURN INDLIST .* (UCOEFFT ./ DENR CDR LTRHS) END; SYMBOLIC PROCEDURE SUBTRACTINDS(POWLHS,L,SOFAR); % subtract the indices in list L from those in POWLHS to find; % appropriate values for i,j,k,... when equating coefficients of terms; % on lhs of reduction eqn. SOFAR is the resulting value list we; % have constructed so far. if any i,j,k,... value is -ve then result; % is NIL; IF NULL L THEN REVERSEWOC SOFAR ELSE IF ((CAR POWLHS)-(CAAR L))<0 THEN NIL ELSE SUBTRACTINDS(CDR POWLHS,CDR L, ((CAR POWLHS)-(CAAR L)) . SOFAR); SYMBOLIC PROCEDURE GAUSSELIMN(EQUATION,TOKILL); % Performs Gaussian elimination on the matrix for the c-equations; % as each c-equation is found. EQUATION is the next one to deal with; BEGIN SCALAR NEWROW,PIVOT; IF ZEROP CCOUNT THEN GO TO NOWAY; %FAILURE; NEWROW:=MKVECT(CCOUNT); SPREADC(EQUATION,NEWROW,1); SUBST4ELIMINATEDCS(NEWROW,REVERSE ORDEROFELIM,REVERSE CMATRIX); PIVOT:=FINDPIVOT NEWROW; IF NULL PIVOT THEN GO TO NOPIVOTFOUND; ORDEROFELIM:=PIVOT . ORDEROFELIM; NEWROW:=MAKEPRIM NEWROW; %REMOVE HCF FROM NEW EQUATION; CMATRIX:=NEWROW . CMATRIX; % IF !*TRINT THEN PRINTSPREADC NEWROW; RETURN T; NOPIVOTFOUND: IF NULL GETV(NEWROW,0) THEN << IF !*TRINT THEN PRINTC "Already included"; RETURN NIL>>; %EQUATION WAS 0=0; NOWAY: BADPART:=TOKILL . BADPART; %NON-INTEGRABLE TERM; IF !*TRINT THEN PRINTC "Inconsistent"; RETURN NIL END; SYMBOLIC PROCEDURE MAKEPRIM ROW; BEGIN SCALAR I,G; G:=GETV(ROW,0); FOR I:=1:CCOUNT DO G:=GCDF(G,GETV(ROW,I)); IF G NEQ 1 THEN FOR I:=0:CCOUNT DO PUTV(ROW,I,QUOTF(GETV(ROW,I),G)); FOR I := 0:CCOUNT DO <<G := GETV(ROW,I); IF G AND NOT DOMAINP G THEN PUTV(ROW,I,NUMR RESIMP((ROOTEXTRACTF G) ./ 1))>>; RETURN ROW END; ENDMODULE; MODULE SQRTF; EXPORTS MINUSDFP,SQRTDF,NROOTN,DOMAINP,MINUSF; IMPORTS CONTENTSMV,GCDF,INTERR,!*MULTF!*,PARTIALDIFF,PRINTDF,QUOTF, SIMPSQRT2,VP2; %SQUARE-ROOT OF STANDARD FORMS; SYMBOLIC PROCEDURE MINUSDFP A; %TEST SIGN OF LEADING COEDD OF D.F; IF NULL A THEN INTERR "MINUSDFP 0 ILLEGAL" ELSE MINUSF NUMR LC A; SYMBOLIC PROCEDURE SQRTDF L; %TAKES SQUARE ROOT OF D.F.; IF NULL L THEN NIL ELSE IF NOT NULL RED L THEN 'FAILED ELSE BEGIN SCALAR C; IF LPOW L=VP2 ZLIST THEN GO TO OK; PRINTC "SQRTDF NOT COMPLETE"; PRINTDF L; RETURN 'FAILED; OK: RETURN (LPOW L .* SQRTSQ LC L) .+ NIL END; SYMBOLIC PROCEDURE SQRTSQ A; SQRTF NUMR A ./ SQRTF DENR A; SYMBOLIC PROCEDURE SQRTF P; BEGIN SCALAR IP,QP; IF NULL P THEN RETURN NIL; IP:=SQRTF1 P; QP:=CDR IP; IP:=CAR IP; %RESPECTABLE AND NASTY PARTS OF THE SQRT; IF ONEP QP THEN RETURN IP; %EXACT ROOT FOUND; QP:=SIMPSQRT2 QP; RETURN !*F2POL !*MULTF!*(IP,QP) END; SYMBOLIC PROCEDURE SQRTF1 P; %RETURNS A . B WITH P=A**2*B; IF DOMAINP P THEN NROOTN(P,2) ELSE BEGIN SCALAR CO,PP,G,PG; CO:=CONTENTSMV(P,MVAR P,NIL); %CONTENTS OF P; PP:=QUOTF(P,CO); %PRIMITIVE PART; CO:=SQRTF1(CO); %PROCESS CONTENTS VIA RECURSION; G:=GCDF(PP,PARTIALDIFF(PP,MVAR PP)); PG:=QUOTF(PP,G); G:=GCDF(G,PG); %A REPEATED FACTOR OF PP; IF G=1 THEN PG:=1 . PP ELSE << PG:= !*F2POL QUOTF(PP,!*MULTF!*(G,G)); %WHAT IS STILL LEFT; PG:=SQRTF1(PG); %SPLIT THAT UP; RPLACA(PG,!*MULTF!*(CAR PG,G))>>; %PUT IN THE THING FOUND HERE; RPLACA(PG,!*F2POL !*MULTF!*(CAR PG,CAR CO)); RPLACD(PG,!*F2POL !*MULTF!*(CDR PG,CDR CO)); RETURN PG END; % NROOTN removed as in REDUCE base; ENDMODULE; MODULE TDIFF; EXPORTS !-!-SIMPDF; IMPORTS SIMPCAR,KERNP,DIFFSQ,PREPSQ,MSGPRI; FLAG('(!-!-SIMPDF),'LOSE); %TDF(EXPR,VAR) DIFFERENTIATES BUT WITH TIMING SERVICE; SYMBOLIC PROCEDURE !-!-SIMPDF U; %U IS A LIST OF FORMS, THE FIRST AN EXPRESSION AND THE REMAINDER %KERNELS AND NUMBERS. %VALUE IS DERIVATIVE OF FIRST FORM WRT REST OF LIST; BEGIN SCALAR V,X,Y,TT; TT := TIME(); %start the clock; V := CDR U; U := SIMPCAR U; A: IF NULL V OR NULL NUMR U THEN GO TO EXIT; X := IF NULL Y OR Y=0 THEN SIMPCAR V ELSE Y; IF NULL KERNP X THEN GO TO E; X := CAAAAR X; V := CDR V; IF NULL V THEN GO TO C; Y := SIMPCAR V; IF NULL NUMR Y THEN GO TO D ELSE IF NOT DENR Y=1 OR NOT NUMBERP NUMR Y THEN GO TO C; Y := CAR Y; V := CDR V; B: IF Y=0 THEN GO TO A; U := DIFFSQ(U,X); Y := Y-1; GO TO B; C: U := DIFFSQ(U,X); GO TO A; D: Y := NIL; V := CDR V; GO TO A; EXIT: PRINT LIST('TIME,TIME()-TT); RETURN U; E: MSGPRI("DIFFERENTIATION WRT",PREPSQ X,"NOT ALLOWED",NIL,T) END; PUT('TDF,'SIMPFN,'!-!-SIMPDF); ENDMODULE; MODULE TIDYSQRT; EXPORTS SQRT2TOP; %GENERAL TIDYING UP ABOUT SQUARE ROOTS; %SYMBOLIC PROCEDURE TIDYSQRTDF A; % IF NULL A THEN NIL % ELSE BEGIN SCALAR TT,R; % TT:=TIDYSQRT LC A; % R:=TIDYSQRTDF RED A; % IF NULL NUMR TT THEN RETURN R; % RETURN ((LPOW A) .* TT) .+ R % END; % %SYMBOLIC PROCEDURE TIDYSQRT Q; % BEGIN SCALAR NN,DD; % NN:=TIDYSQRTF NUMR Q; % IF NULL NN THEN NIL ./ 1; %ANSWER IS ZERO; % DD:=TIDYSQRTF DENR Q; % RETURN MULTSQ(NN,INVSQ DD) % END; % % %SYMBOLIC PROCEDURE TIDYSQRTF P; %%INPUT - STANDARD FORM; %%OUTPUT - STANDARD QUOTIENT; %% SIMPLIFIES SQRT(A)**N WITH N>1; % IF DOMAINP P THEN P ./ 1 % ELSE BEGIN SCALAR V,W; % V:=LPOW P; % IF CAR V='I THEN V:=MKSP('(SQRT -1),CDR V); %I->SQRT(-1); % IF EQCAR(CAR V,'SQRT) AND NOT ONEP CDR V THEN BEGIN SCALAR X; % %HERE WE HAVE A REDUCTION TO APPLY; % X:=DIVIDE(CDR V,2); %HALVE EXPONENT; % W:=EXPTSQ(SIMP CADAR V,CAR X); %RATIONAL PART OF ANSWER; % IF NOT ZEROP CDR X THEN W:=MULTSQ(W, % ((MKSP(CAR V,1) .* 1) .+ NIL) ./ 1); % %THE NEXT LINE ALLOWS FOR THE HORRORS OF NESTED SQRTS; % W:=TIDYSQRT W % END % ELSE W:=((V .* 1) .+ NIL) ./ 1; % V:=MULTSQ(W,TIDYSQRTF LC P); % RETURN ADDSQ(V,TIDYSQRTF RED P) % END; % % %MOVE SQRTS IN A SQ TO THE NUMERATOR; SYMBOLIC PROCEDURE MULTOUTDENR Q; BEGIN SCALAR N,D,ROOT,CONJ; N:=NUMR Q; D:=DENR Q; LOOP:ROOT:=FINDSQUAREROOT D; %SEARCH DENOM; IF NULL ROOT THEN RETURN (N . D); %NOTHING TO BE DONE; CONJ:=CONJUGATEWRT(D,ROOT); N:=!*F2POL !*MULTF!*(N,CONJ); D:=!*F2POL !*MULTF!*(D,CONJ); GO TO LOOP END; SYMBOLIC PROCEDURE SQRT2TOP Q; BEGIN SCALAR N,D; N:=MULTOUTDENR Q; D:=DENR N; N:=NUMR N; IF D EQ DENR Q THEN RETURN Q;%NO CHANGE; IF D IEQUAL 1 THEN RETURN (N ./ 1); Q:=GCDCOEFFSOFSQRTS N; IF Q IEQUAL 1 THEN IF MINUSF D THEN RETURN (NEGF N ./ NEGF D) ELSE RETURN (N ./ D); Q:=GCDF(Q,D); N:=QUOTF(N,Q); D:=QUOTF(D,Q); IF MINUSF D THEN RETURN (NEGF N ./ NEGF D) ELSE RETURN (N ./ D) END; %SYMBOLIC PROCEDURE DENRSQRT2TOP Q; %BEGIN % SCALAR N,D; % N:=MULTOUTDENR Q; % D:=DENR N; % N:=NUMR N; % IF D EQ DENR Q % THEN RETURN D; %NO CHANGES; % IF D IEQUAL 1 % THEN RETURN 1; % Q:=GCDCOEFFSOFSQRTS N; % IF Q IEQUAL 1 % THEN RETURN D; % Q:=GCDF(Q,D); % IF Q IEQUAL 1 % THEN RETURN D % ELSE RETURN QUOTF(D,Q) % END; SYMBOLIC PROCEDURE FINDSQUAREROOT P; %LOCATE A SQRT SYMBOL IN POLY P; IF DOMAINP P THEN NIL ELSE BEGIN SCALAR W; W:=MVAR P; %CHECK MAIN VAR FIRST; IF ATOM W THEN RETURN NIL; %WE HAVE PASSED ALL SQRTS; IF EQCAR(W,'SQRT) THEN RETURN W; W:=FINDSQUAREROOT LC P; IF NULL W THEN W:=FINDSQUAREROOT RED P; RETURN W END; SYMBOLIC PROCEDURE CONJUGATEWRT(P,VAR); % VAR -> -VAR IN FORM P; IF DOMAINP P THEN P ELSE IF MVAR P=VAR THEN BEGIN SCALAR X,C,R; X:=TDEG LT P; %DEGREE; C:=LC P; %COEFFICIENT; R:=RED P; %REDUCTUM; X:=REMAINDER(X,2); %NOW JUST 0 OR 1; IF X=1 THEN C:=NEGF C; %-COEFFICIENT; RETURN (LPOW P .* C) .+ CONJUGATEWRT(R,VAR) END ELSE IF ORDOP(VAR,MVAR P) THEN P ELSE (LPOW P .* CONJUGATEWRT(LC P,VAR)) .+ CONJUGATEWRT(RED P,VAR); SYMBOLIC PROCEDURE GCDCOEFFSOFSQRTS U; IF ATOM U THEN IF NUMBERP U AND MINUSP U THEN -U ELSE U ELSE IF EQCAR(MVAR U,'SQRT) THEN BEGIN SCALAR V; V:=GCDCOEFFSOFSQRTS LC U; IF V IEQUAL 1 THEN RETURN V ELSE RETURN GCDF(V,GCDCOEFFSOFSQRTS RED U) END ELSE BEGIN SCALAR ROOT; ROOT:=FINDSQUAREROOT U; IF NULL ROOT THEN RETURN U; U:=MAKEMAINVAR(U,ROOT); ROOT:=GCDCOEFFSOFSQRTS LC U; IF ROOT IEQUAL 1 THEN RETURN 1 ELSE RETURN GCDF(ROOT,GCDCOEFFSOFSQRTS RED U) END; ENDMODULE; MODULE TRCASE; EXPORTS TRANSCENDENTALCASE; IMPORTS BACKSUBST4CS,COUNTZ,CREATECMAP,CREATEINDICES,DF2Q,DFNUMR, DIFFLOGS,FSDF,FACTORLISTLIST,FINDSQRTS,FINDTRIALDIVS,GCDF,MKVECT, INTERR,LOGSTOSQ,MERGIN,MULTBYARBPOWERS,!*MULTF!*,MULTSQFREE, PRINTDF,PRINTFACTORS,PRINTSQ,QUOTF,RATIONALINTEGRATE,PUTV, SIMPINT1,SOLVE!-FOR!-U,SQFREE,SQMERGE,SQRT2TOP,SUBSTINULIST,TRIALDIV, MERGEIN,NEGSQ,ADDSQ,F2DF,MKNILL,PNTH,INVSQ,MULTSQ,DOMAINP,MK!*SQ, MKSP,PRETTYPRINT,PREPSQ; FLUID '(DENBAD VAR XLOGS); % For the ERRORSET below; SYMBOLIC PROCEDURE TRANSCENDENTALCASE(INTEGRAND,VAR,XLOGS,ZLIST,VARLIST); BEGIN SCALAR DIVLIST,W,JHD!-CONTENT,CONTENT,PRIM,SQFR,DFU,INDEXLIST, % JHD!-CONTENT is local, while CONTENT is free (set in SQFREE); SILLIESLIST,ORIGINALORDER,ORIGINALLHS,WRONGWAY, SQRTLIST,TANLIST,LOGLIST,DFLOGS,EPRIM,DFUN,UNINTEGRAND, SQRTFLAG,BADPART,RHS,LHS,GCDQ,CMAP,CVAL,ORDEROFELIM,CMATRIX; SCALAR CUBEROOTFLAG,CCOUNT,DENOMINATOR,RESULT,DENBAD; GENSYMCOUNT:=0; INTEGRAND:=SQRT2TOP INTEGRAND; % Move the sqrts to the numerator; IF !*TRINT THEN << PRINTC "EXTENSION VARIABLES Z<I> ARE"; PRINT ZLIST>>; IF !*RATINTSPECIAL AND NULL CDR ZLIST THEN RETURN RATIONALINTEGRATE(INTEGRAND,VAR); % *** NOW UNNORMALIZE INTEGRAND, MAYBE *** ; BEGIN SCALAR W,Z,GG; GG:=1; FOREACH Z IN ZLIST DO << W:=DIFFSQ(SIMP Z,VAR); GG:=MULTF(GG,QUOTF(DENR W,GCDF(DENR W,GG))) >>; GG:=QUOTF(GG,GCDF(GG,DENR INTEGRAND)); UNINTEGRAND:=(MULTF(GG,NUMR INTEGRAND) ./ MULTF(GG,DENR INTEGRAND)); IF !*TRINT THEN << PRINTC "UNNORMALIZED INTEGRAND ="; PRINTSQ UNINTEGRAND >> END; DIVLIST:=FINDTRIALDIVS ZLIST; %ALSO PUTS SOME THINGS ON LOGLIST SOMETIMES; % IF !*TRINT THEN << PRINTC "EXPONENTIALS AND TANS TO TRY DIVIDING:"; % PRINT DIVLIST>>; SQRTLIST:=FINDSQRTS ZLIST; % IF !*TRINT THEN << PRINTC "SQUARE-ROOT Z-VARIABLES"; % PRINT SQRTLIST >>; DIVLIST:=TRIALDIV(DENR UNINTEGRAND,DIVLIST); % IF !*TRINT THEN << PRINTC "DIVISORS:"; % PRINT CAR DIVLIST; % PRINT CDR DIVLIST>>; %N.B. THE NEXT LINE ALSO SETS 'CONTENT' AS A FREE VARIABLE; % Since SQFREE may be used later, we copy it into JHD!-CONTENT; PRIM:=SQFREE(CDR DIVLIST,ZLIST); JHD!-CONTENT:=CONTENT; PRINTFACTORS(PRIM,NIL); EPRIM:=SQMERGE(COUNTZ CAR DIVLIST,PRIM,NIL); PRINTFACTORS(EPRIM,T); % IF !*TRINT THEN << TERPRI(); % PRINTSF DENOMINATOR; % TERPRI(); % PRINTC "...CONTENT IS:"; % PRINTSF JHD!-CONTENT>>; SQFR:=MULTSQFREE EPRIM; % IF !*TRINT THEN << PRINTC "...SQFR IS:"; % SUPERPRINT SQFR>>; INDEXLIST:=CREATEINDICES ZLIST; % IF !*TRINT THEN << PRINTC "...INDICES ARE:"; % SUPERPRINT INDEXLIST>>; DFU:=DFNUMR(VAR,CAR DIVLIST); % IF !*TRINT THEN << TERPRI(); % PRINTC "************ DERIVATIVE OF U IS:"; % PRINTSQ DFU>>; LOGLIST:=APPEND(LOGLIST,FACTORLISTLIST (PRIM,NIL)); LOGLIST:=MERGEIN(XLOGS,LOGLIST); LOGLIST:=MERGEIN(TANLIST,LOGLIST); CMAP:=CREATECMAP(); CCOUNT:=LENGTH CMAP; IF !*TRINT THEN << PRINTC "LOGLIST "; PRINT LOGLIST >>; DFLOGS:=DIFFLOGS(LOGLIST,DENR UNINTEGRAND,VAR); IF !*TRINT THEN << PRINTC "************ 'DERIVATIVE' OF LOGS IS:"; PRINTSQ DFLOGS>>; DFLOGS:=ADDSQ((NUMR UNINTEGRAND) ./ 1,NEGSQ DFLOGS); % Put everything in reduction eqn over common denominator: ; GCDQ:=GCDF(DENR DFLOGS,DENR DFU); DFUN:= !*F2POL !*MULTF!*(NUMR DFU, DENBAD:=QUOTF(DENR DFLOGS,GCDQ)); DENBAD:=!*MULTF!*(DENR DFU,DENBAD); DENBAD:= !*F2POL !*MULTF!*(DENR UNINTEGRAND,DENBAD); DFLOGS:= !*F2POL !*MULTF!*(NUMR DFLOGS,QUOTF(DENR DFU,GCDQ)); DFU:=DFUN; % Now DFU and DFLOGS are S.F.s; RHS:=MULTBYARBPOWERS F2DF DFU; IF !*TRINT THEN << PRINTC "Distributed Form of U is:"; PRINTDF RHS>>; LHS:=F2DF DFLOGS; IF !*TRINT THEN << PRINTC "Distributed Form of l.h.s. is:"; PRINTDF LHS; TERPRI()>>; CVAL:=MKVECT(CCOUNT); FOR I:=0 : CCOUNT DO PUTV(CVAL,I,NIL ./ 1); LORDER:=MAXORDER(RHS,ZLIST,0); ORIGINALORDER:=LORDER; ORIGINALLHS:=LHS; IF !*TRINT THEN << PRINTC "Maximum order determined as "; PRINT LORDER >>; IF !*STATISTICS THEN << !*NUMBER!*:=0; !*SPSIZE!*:=1; FOREACH XX IN LORDER DO !*SPSIZE!*:=!*SPSIZE!* * (XX+1) >>; % That calculates the largest U that can appear; DFUN:=SOLVE!-FOR!-U(RHS,LHS,NIL); BACKSUBST4CS(NIL,ORDEROFELIM,CMATRIX); % IF !*TRINT THEN IF NOT (CCOUNT=0) THEN PRINTVECSQ CVAL; IF !*STATISTICS THEN << PRIN2 !*NUMBER!*; PRIN2 " used out of "; PRINTC !*SPSIZE!* >>; BADPART:=SUBSTINULIST BADPART; %SUBSTITUTE FOR C<I> STILL IN BADPART; DFUN:=DF2Q SUBSTINULIST DFUN; % IF !*TRINT THEN SUPERPRINT DFUN; RESULT:= SUBS2Q MULTSQ(DFUN,INVSQ(DENOMINATOR ./ 1)); RESULT:= SUBS2Q MULTSQ(RESULT,INVSQ(JHD!-CONTENT ./ 1)); % IF !*TRINT THEN SUPERPRINT RESULT; DFLOGS:=LOGSTOSQ(); IF NOT NULL NUMR DFLOGS THEN RESULT:=ADDSQ(RESULT,DFLOGS); IF !*TRINT THEN << SUPERPRINT RESULT; TERPRI(); PRINTC "*****************************************************"; PRINTC "************ THE INTEGRAL IS : **********************"; PRINTC "*****************************************************"; TERPRI(); PRINTSQ RESULT; TERPRI()>>; IF NOT NULL BADPART THEN << IF !*TRINT THEN PRINTC "PLUS A BAD PART"; LHS:=BADPART; LORDER:=MAXORDER(RHS,ZLIST,0); WHILE LORDER DO << IF CAR LORDER > CAR ORIGINALORDER THEN WRONGWAY:=T; LORDER:=CDR LORDER; ORIGINALORDER:=CDR ORIGINALORDER >>; DFUN:=DF2Q BADPART; IF !*TRINT THEN <<PRINTSQ DFUN; PRINTC "DENBAD = "; PRINTSF DENBAD>>; DFUN:= SUBS2Q MULTSQ(DFUN,INVSQ(DENBAD ./ 1)); IF WRONGWAY THEN << RESULT:= NIL ./ 1; DFUN:=INTEGRAND >>; IF ROOTCHECKP(UNINTEGRAND,VAR) THEN RETURN SIMPINT1(INTEGRAND . VAR.NIL) ELSE IF !*PURERISCH OR ALLOWEDFNS ZLIST THEN DFUN:=SIMPINT1 (DFUN . VAR.NIL) ELSE << !*PURERISCH:=T; IF !*TRINT THEN <<PRINTC " [Transforming ..."; PRINTSQ DFUN>>; DENBAD:=TRANSFORM(DFUN,VAR); IF DENBAD=DFUN THEN DFUN:=SIMPINT1(DFUN . VAR.NIL) ELSE <<DENBAD:=ERRORSET('(INTEGRATESQ DENBAD VAR XLOGS), NIL,!*BACKTRACE); IF NOT ATOM DENBAD THEN DFUN:=UNTAN CAR DENBAD ELSE DFUN:=SIMPINT1(DFUN . VAR.NIL) >> >>; IF !*TRINT THEN PRINTSQ DFUN; IF !*FAILHARD THEN INTERR "FAILHARD SWITCH SET"; RESULT:=ADDSQ(RESULT,DFUN) >>; % IF !*OVERLAYMODE % THEN EXCISE TRANSCODE; RETURN SQRT2TOP RESULT END; %UNFLUID '(DFUN VAR XLOGS); ENDMODULE; MODULE HALFANGLE; EXPORTS HALFANGLE,UNTAN; SYMBOLIC PROCEDURE TRANSFORM(U,X); % Transform the SQ U to remove the 'bad' functions sin, cos, cot etc % in favor of half angles; HALFANGLE(U,X); % Rest of this page is due to Harrington; %PROCEDURES FOR CONVERSION TO HALF ANGLE TANGENTS; % SOME NEWRED PROCEDURES THAT IM USED TO; SYMBOLIC PROCEDURE QUOTQQ(U1,V1); MULTSQ(U1, INVSQ(V1)); SYMBOLIC PROCEDURE !*SUBTRQ(U1,V1); ADDSQ(U1, NEGSQ(V1)); SYMBOLIC PROCEDURE !*INT2QM(U1); IF U1=0 THEN NIL . 1 ELSE U1 . 1; SYMBOLIC PROCEDURE HALFANGLE(R,X); % TOP LEVEL PROCEDURE FOR CONVERTING; % R IS A RATIONAL EXPRESSION TO BE CONVERTED, % X THE INTEGRATION VARIABLE; % A RATIONAL EXPRESSION IS RETURNED; QUOTQQ(HFAGLF(NUMR(R),X), HFAGLF(DENR(R),X)); SYMBOLIC PROCEDURE HFAGLF(P,X); % CONVERTING POLYNOMIALS, A RATIONAL EXPRESSION IS RETURNED; IF DOMAINP(P) THEN !*F2Q(P) ELSE SUBS2Q ADDSQ(MULTSQ(EXPTSQ(HFAGLK(MVAR(P),X), LDEG(P)), HFAGLF(LC(P),X)), HFAGLF(RED(P),X)); SYMBOLIC PROCEDURE HFAGLK(K,X); % CONVERTING KERNELS, A RATIONAL EXPRESSION IS RETURNED; BEGIN SCALAR KT; IF ATOM K OR NOT MEMBER(X,FLATTEN(CDR(K))) THEN RETURN !*K2Q K; K := CAR(K) . HFAGLARGS(CDR(K), X); KT := SIMP LIST('TAN, LIST('QUOTIENT, CADR(K), 2)); RETURN IF CAR(K) = 'SIN THEN QUOTQQ(MULTSQ(!*INT2QM(2),KT), ADDSQ(!*INT2QM(1), EXPTSQ(KT,2))) ELSE IF CAR(K) = 'COS THEN QUOTQQ(!*SUBTRQ(!*INT2QM(1), EXPTSQ(KT,2)), ADDSQ(!*INT2QM(1), EXPTSQ(KT,2))) ELSE IF CAR(K) = 'TAN THEN QUOTQQ(MULTSQ(!*INT2QM(2),KT), !*SUBTRQ(!*INT2QM(1), EXPTSQ(KT,2))) ELSE IF CAR(K) = 'SINH THEN QUOTQQ(!*SUBTRQ(EXPTSQ(!*K2Q('EXPT.('E. CDR K)),2), !*INT2QM(1)), MULTSQ(!*INT2QM(2), !*K2Q('EXPT . ('E . CDR(K))))) ELSE IF CAR(K) = 'COSH THEN QUOTQQ(ADDSQ(EXPTSQ(!*K2Q('EXPT.('E. CDR K)),2), !*INT2QM(1)), MULTSQ(!*INT2QM(2), !*K2Q('EXPT . ('E . CDR(K))))) ELSE IF CAR(K) = 'TANH THEN QUOTQQ(!*SUBTRQ(EXPTSQ(!*K2Q('EXPT.('E. CDR K)),2), !*INT2QM(1)), ADDSQ(EXPTSQ(!*K2Q ('EXPT.('E.CDR(K))),2), !*INT2QM(1))) ELSE !*K2Q(K); % ADDITIONAL TRANSFORMATION MIGHT BE ADDED HERE; END; SYMBOLIC PROCEDURE HFAGLARGS(L,X); %CONVERSION OF ARGUMENT LIST; IF NULL L THEN NIL ELSE PREPSQ(HFAGLK(CAR(L),X)) . HFAGLARGS(CDR(L), X); SYMBOLIC PROCEDURE UNTANF X; BEGIN SCALAR Y,Z,W; IF DOMAINP X THEN RETURN X . 1; Y := MVAR X; IF EQCAR(Y,'INT) THEN ERROR(99,NIL); %assume all is hopeless; Z := LDEG X; W := 1 . 1; Y := IF ATOM Y THEN !*K2Q Y ELSE IF CAR Y EQ 'TAN THEN IF REMAINDER(Z,2)=0 THEN <<Z := Z/2; SIMP LIST('QUOTIENT, LIST('PLUS, LIST('MINUS, LIST('COS, 'TIMES . (2 . CDR Y))), 1),LIST('PLUS, LIST('COS, 'TIMES . (2 . CDR Y)), 1))>> ELSE IF Z=1 THEN SIMP LIST('QUOTIENT, LIST('PLUS, LIST('MINUS, LIST('COS, 'TIMES . (2 . CDR Y))), 1),LIST('SIN, 'TIMES . (2 . CDR Y))) ELSE <<Z := (Z - 1)/2; W := SIMP LIST('QUOTIENT, LIST('PLUS, LIST('MINUS, LIST('COS, 'TIMES . (2 . CDR Y))), 1),LIST('SIN, 'TIMES . (2 . CDR Y))); SIMP LIST('QUOTIENT, LIST('PLUS, LIST('MINUS, LIST('COS, 'TIMES . (2 . CDR Y))), 1),LIST('PLUS, LIST('COS, 'TIMES . (2 . CDR Y)), 1))>> ELSE SIMP Y; RETURN ADDSQ(MULTSQ(MULTSQ(EXPTSQ(Y,Z),UNTANF LC X),W), UNTANF RED X) END; SYMBOLIC PROCEDURE UNTANLIST(Y); IF NULL Y THEN NIL ELSE (PREPSQ (UNTAN(SIMP CAR Y)) . UNTANLIST(CDR Y)); SYMBOLIC PROCEDURE UNTAN(X); COMMENT EXPECTS X TO BE CANONICAL QUOTIENT; BEGIN SCALAR Y; Y:=COSSQCHK SINSQRDCHK MULTSQ(UNTANF(NUMR X), INVSQ UNTANF(DENR X)); RETURN IF LENGTH FLATTEN Y>LENGTH FLATTEN X THEN X ELSE Y END; SYMBOLIC PROCEDURE SINSQRDCHK(X); MULTSQ(SINSQCHKF(NUMR X), INVSQ SINSQCHKF(DENR X)); SYMBOLIC PROCEDURE SINSQCHKF(X); BEGIN SCALAR Y,Z,W; IF DOMAINP X THEN RETURN X . 1; Y := MVAR X; Z := LDEG X; W := 1 . 1; Y := IF EQCAR(Y,'SIN) THEN IF REMAINDER(Z,2) = 0 THEN <<Z := QUOTIENT(Z,2); SIMP LIST('PLUS,1,LIST('MINUS, LIST('EXPT,('COS . CDR(Y)),2)))>> ELSE IF Z = 1 THEN !*K2Q Y ELSE << Z := QUOTIENT(DIFFERENCE(Z,1),2); W := !*K2Q Y; SIMP LIST('PLUS,1,LIST('MINUS, LIST('EXPT,('COS . CDR(Y)),2)))>> ELSE !*K2Q Y; RETURN ADDSQ(MULTSQ(MULTSQ(EXPTSQ(Y,Z),SINSQCHKF(LC X)),W), SINSQCHKF(RED X)); END; SYMBOLIC PROCEDURE COSSQCHKF(X); BEGIN SCALAR Y,Z,W,X1,X2; IF DOMAINP X THEN RETURN X . 1; Y := MVAR X; Z := LDEG X; W := 1 . 1; X1 := COSSQCHKF(LC X); X2 := COSSQCHKF(RED X); X := ADDSQ(MULTSQ(!*P2Q LPOW X,X1),X2); Y := IF EQCAR(Y,'COS) THEN IF REMAINDER(Z,2) = 0 THEN <<Z := QUOTIENT(Z,2); SIMP LIST('PLUS,1,LIST('MINUS, LIST('EXPT,('SIN . CDR(Y)),2)))>> ELSE IF Z = 1 THEN !*K2Q Y ELSE << Z := QUOTIENT(DIFFERENCE(Z,1),2); W := !*K2Q Y; SIMP LIST('PLUS,1,LIST('MINUS, LIST('EXPT,('SIN . CDR(Y)),2)))>> ELSE !*K2Q Y; Y := ADDSQ(MULTSQ(MULTSQ(EXPTSQ(Y,Z),W),X1),X2); RETURN IF LENGTH(Y) > LENGTH(X) THEN X ELSE Y; END; SYMBOLIC PROCEDURE COSSQCHK(X); BEGIN SCALAR GCD1; GCD1 := !*GCD; !*GCD := T; X := MULTSQ(COSSQCHKF(NUMR X), INVSQ COSSQCHKF(DENR X)); !*GCD := GCD1; RETURN X; END; SYMBOLIC PROCEDURE LROOTCHK(L,X); % CHECKS EACH MEMBER OF LIST L FOR A ROOT; IF NULL L THEN NIL ELSE KROOTCHK(CAR L, X) OR LROOTCHK(CDR L, X); SYMBOLIC PROCEDURE KROOTCHK(F,X); % CHECKS A KERNEL TO SEE IF IT IS A ROOT; IF ATOM F THEN NIL ELSE IF CAR(F) = 'SQRT AND MEMBER(X, FLATTEN CDR F) THEN T ELSE IF CAR(F) = 'EXPT AND NOT ATOM CADDR(F) AND CAADDR(F) = 'QUOTIENT AND MEMBER(X, FLATTEN CADR F) THEN T ELSE LROOTCHK(CDR F, X); SYMBOLIC PROCEDURE ROOTCHK1P(F,X); % CHECKS POLYNOMIAL FOR A ROOT; IF DOMAINP F THEN NIL ELSE KROOTCHK(MVAR F,X) OR ROOTCHK1P(LC F, X) OR ROOTCHK1P(RED F, X); SYMBOLIC PROCEDURE ROOTCHECKP(F,X); % CHECKS RATIONAL (STANDARD QUOTIENT) FOR A ROOT; ROOTCHK1P(NUMR F, X) OR ROOTCHK1P(DENR F, X); ENDMODULE; MODULE TRIALDIV; EXPORTS COUNTZ,FINDSQRTS,FINDTRIALDIVS,PRINTFACTORS,TRIALDIV,SIMP,MKSP; IMPORTS !*MULTF!*,PRINTSF,QUOTF; SYMBOLIC PROCEDURE COUNTZ DL; % DL is a list of S.F.s; BEGIN SCALAR S,N,RL; LOOP2: IF NULL DL THEN RETURN ARRANGELISTZ RL; N:=1; LOOP1: N:=N+1; S:=CAR DL; DL:=CDR DL; IF NOT NULL DL AND (S EQ CAR DL) THEN GO TO LOOP1 ELSE RL:=(S.N).RL; GO TO LOOP2 END; SYMBOLIC PROCEDURE ARRANGELISTZ D; BEGIN SCALAR N,S,RL,R; N:=1; IF NULL D THEN RETURN RL; LOOPD: IF (CDAR D)=N THEN S:=(CAAR D).S ELSE R:=(CAR D).R; D:=CDR D; IF NOT NULL D THEN GO TO LOOPD; D:=R; RL:=S.RL; S:=NIL; R:=NIL; N:=N+1; IF NOT NULL D THEN GO TO LOOPD; RETURN REVERSEWOC RL END; SYMBOLIC PROCEDURE PRINTFACTORS(W,PRDENOM); % W is a list of factors to each power. If PRDENOM is true ; % this prints denominator of answer, else prints square-free ; % decomposition. ; BEGIN SCALAR I,WX; I:=1; IF PRDENOM THEN << DENOMINATOR:=1; IF !*TRINT THEN PRINTC "DENOMINATOR OF 1ST PART OF ANSWER IS:"; IF NOT NULL W THEN W:=CDR W >>; LOOPX: IF W=NIL THEN RETURN; IF !*TRINT THEN PRINTC ("FACTORS OF MULTIPLICITY".I); WX:=CAR W; WHILE NOT NULL WX DO << IF !*TRINT THEN PRINTSF CAR WX; FOR J:=1 : I DO DENOMINATOR:= !*F2POL !*MULTF!*(CAR WX,DENOMINATOR); %this call of F2POL is probably not necessary??; WX:=CDR WX >>; I:=I+1; W:=CDR W; GO TO LOOPX END; SYMBOLIC PROCEDURE FINDTRIALDIVS ZL; %ZL IS LIST OF KERNELS FOUND IN INTEGRAND. RESULT IS A LIST; %GIVING THINGS TO BE TREATED SPECIALLY IN THE INTEGRATION; %VIZ: EXPS AND TANS; %RESULT IS LIST OF FORM ((A . B) ...); % WITH A A KERNEL AND CAR A=EXPT OR TAN; % AND B A STANDARD FORM FOR EITHER EXPT OR (1+TAN**2); BEGIN SCALAR DLISTS1,ARGS1; WHILE NOT NULL ZL DO << IF EXPORTAN CAR ZL THEN << IF CAAR ZL='TAN THEN << ARGS1:=(MKSP(CAR ZL,2) .* 1) .+ 1; TANLIST:=(ARGS1 ./ 1) . TANLIST>> ELSE ARGS1:=!*K2F CAR ZL; DLISTS1:=(CAR ZL . ARGS1) . DLISTS1>>; ZL:=CDR ZL >>; RETURN DLISTS1 END; SYMBOLIC PROCEDURE EXPORTAN DL; IF ATOM DL THEN NIL ELSE BEGIN % EXTRACT EXP OR TAN FNS FROM THE Z-LIST; IF EQ(CAR DL,'TAN) THEN RETURN T; NXT: IF NOT EQ(CAR DL,'EXPT) THEN RETURN NIL; DL:=CADR DL; IF ATOM DL THEN RETURN T; GO TO NXT END; SYMBOLIC PROCEDURE FINDSQRTS Z; BEGIN SCALAR R; WHILE NOT NULL Z DO << IF EQCAR(CAR Z,'SQRT) THEN R:=(CAR Z) . R; Z:=CDR Z >>; RETURN R END; SYMBOLIC PROCEDURE TRIALDIV(X,DL); BEGIN SCALAR QLIST,Q; WHILE NOT NULL DL DO IF NOT NULL(Q:=QUOTF(X,CDAR DL)) THEN << IF (CAAAR DL='TAN) AND NOT EQCAR(QLIST,CDAR DL) THEN LOGLIST:=('IDEN . SIMP CADR CAAR DL) . LOGLIST; %TAN FIDDLE!; QLIST:=(CDAR DL).QLIST; X:=Q >> ELSE DL:=CDR DL; RETURN QLIST.X END; ENDMODULE; MODULE UNIFAC; EXPORTS EVALAT,LINETHROUGH,QUADTHROUGH,TESTDIV,UNIFAC,ZFACTORS; IMPORTS CUBIC,LINFAC,PRINTDF,QUADFAC,QUADRATIC,QUARTIC,VP1,ZFACTOR, GCD,MINUSP,PRETTYPRINT; %UNIVARIATE FACTORIZATION FOR INTEGRATION; SYMBOLIC PROCEDURE ZFACTORS N; %PRODUCES A LIST OF ALL (POSITIVE) INTEGER FACTORS OF THE ; %INTEGER N; IF N=0 THEN LIST 0 ELSE IF (N:=ABS N)=1 THEN LIST 1 ELSE COMBINATIONTIMES ZFACTOR N; SYMBOLIC PROCEDURE ZFACTOR N; % INPUT N A POSITIVE INTEGER; % OUTPUT A LIST ((PRIME . EXPONENT) ...) GIVING FACTORS OF N; BEGIN SCALAR FL,Q,W,C; C:=0; %MULTIPLICITY; TRY2: Q:=DIVIDE(N,2); %PULL OUT FACTORS OF 2; IF ZEROP CDR Q THEN << C:=C+1; N:=CAR Q; GO TO TRY2 >>; IF NOT ZEROP C THEN FL:=(2 . C) . FL; W:=3; C:=0; TRYW: Q:=DIVIDE(N,W); IF ZEROP CDR Q THEN << C:=C+1; N:=CAR Q; GO TO TRYW >>; IF NOT ZEROP C THEN FL:=(W . C) . FL; IF REMAINDER(W,3)=1 THEN W:=W+4 ELSE W:=W+2; C:=0; IF NOT ((W*W)>N) THEN GO TO TRYW; IF NOT ONEP N THEN FL:=(N . 1) . FL; RETURN FL END; SYMBOLIC PROCEDURE COMBINATIONTIMES FL; IF NULL FL THEN LIST 1 ELSE BEGIN SCALAR N,C,RES,PR; N:=CAAR FL; C:=CDAR FL; PR:=COMBINATIONTIMES CDR FL; WHILE NOT MINUSP C DO << RES:=PUTIN(EXPT(N,C),PR,RES); C:=C-1 >>; RETURN RES END; SYMBOLIC PROCEDURE PUTIN(N,L,W); IF NULL L THEN W ELSE PUTIN(N,CDR L,(N*CAR L) . W); SYMBOLIC PROCEDURE UNIFAC(POL,VAR,DEGREE,RES); BEGIN SCALAR W,Q,C; W:=POL; IF !*TRINT THEN SUPERPRINT W; %NOW TRY LOOKING FOR LINEAR FACTORS; TRYLIN: Q:=LINFAC(W); IF NULL CAR Q THEN GO TO NOMORELIN; RES := ('LOG . BACK2DF(CAR Q,VAR)) . RES; W:=CDR Q; GO TO TRYLIN; NOMORELIN: Q:=QUADFAC(W); IF NULL CAR Q THEN GO TO NOMOREQUAD; RES := QUADRATIC(BACK2DF(CAR Q,VAR),VAR,RES); W:=CDR Q; GO TO NOMORELIN; NOMOREQUAD: IF NULL W THEN RETURN RES; %ALL DONE; DEGREE:=CAR W; %DEGREE OF WHAT IS LEFT; C:=BACK2DF(W,VAR); IF DEGREE=3 THEN RES:=CUBIC(C,VAR,RES) ELSE IF DEGREE=4 THEN RES:=QUARTIC(C,VAR,RES) ELSE IF ZEROP REMAINDER(DEGREE,2) AND PAIRP (Q := HALFPOWER CDDR W) THEN <<W := (DEGREE/2) . (CADR W . Q); W := UNIFAC(W,VAR,CAR W,NIL); RES := PLUCKFACTORS(W,VAR,RES)>> ELSE << PRINTC "THE FOLLOWING HAS NOT BEEN SPLIT"; PRINTDF C; RES:=('LOG . C) . RES>>; RETURN RES END; SYMBOLIC PROCEDURE HALFPOWER W; IF NULL W THEN NIL ELSE IF CAR W=0 THEN (LAMBDA R; IF R EQ 'FAILED THEN R ELSE CADR W . R) HALFPOWER CDDR W ELSE 'FAILED; SYMBOLIC PROCEDURE PLUCKFACTORS(W,VAR,RES); BEGIN SCALAR S,P,Q,R,KNOWNDISCRIMSIGN; WHILE W DO <<P := CAR W; IF CAR P EQ 'ATAN THEN NIL ELSE IF CAR P EQ 'LOG THEN <<Q := DOUBLEPOWER CDR P . Q; %PRIN2 "Q="; %PRINTDF CAR Q; >> ELSE INTERR "BAD FORM"; W := CDR W>>; WHILE Q DO <<P := CAR Q; IF CAAAR P=4 THEN <<KNOWNDISCRIMSIGN := 'NEGATIVE; RES := QUARTIC(P,VAR,RES); KNOWNDISCRIMSIGN := NIL>> ELSE IF CAAAR P=2 THEN RES := QUADRATIC(P,VAR,RES) ELSE RES := ('LOG . P) . RES; Q := CDR Q>>; RETURN RES END; SYMBOLIC PROCEDURE DOUBLEPOWER R; IF NULL R THEN NIL ELSE (LIST(2*CAAAR R) . CDAR R) . DOUBLEPOWER CDR R; SYMBOLIC PROCEDURE BACK2DF(P,V); %UNDO THE EFFECT OF UNIFORM; BEGIN SCALAR R,N; N:=CAR P; P:=CDR P; WHILE NOT MINUSP N DO << IF NOT ZEROP CAR P THEN R:= (VP1(V,N,ZLIST) .* (CAR P ./ 1)) .+ R; P:=CDR P; N:=N-1 >>; RETURN REVERSEWOC R END; SYMBOLIC PROCEDURE EVALAT(P,N); %EVALUATE POLYNOMIAL AT INTEGER POINT N; BEGIN SCALAR R; R:=0; P:=CDR P; WHILE NOT NULL P DO << R:=N*R+CAR P; P:=CDR P >>; RETURN R END; SYMBOLIC PROCEDURE TESTDIV(A,B); % QUOTIENT A/B OR FAILED; BEGIN SCALAR Q; Q:=TESTDIV1(CDR A,CAR A,CDR B,CAR B); IF Q='FAILED THEN RETURN Q; RETURN (CAR A-CAR B) . Q END; SYMBOLIC PROCEDURE TESTDIV1(A,DA,B,DB); IF DA<DB THEN BEGIN CHECK0: IF NULL A THEN RETURN NIL ELSE IF NOT ZEROP CAR A THEN RETURN 'FAILED; A:=CDR A; GO TO CHECK0 END ELSE BEGIN SCALAR Q; Q:=DIVIDE(CAR A,CAR B); IF ZEROP CDR Q THEN Q:=CAR Q ELSE RETURN 'FAILED; A:=TESTDIV1(AMBQ(CDR A,CDR B,Q),DA-1,B,DB); IF A='FAILED THEN RETURN A; RETURN Q . A END; SYMBOLIC PROCEDURE AMBQ(A,B,Q); % A-B*Q WITH Q AN INTEGER; IF NULL B THEN A ELSE ((CAR A)-(CAR B)*Q) . AMBQ(CDR A,CDR B,Q); SYMBOLIC PROCEDURE LINETHROUGH(Y0,Y1); BEGIN SCALAR A; A:=Y1-Y0; IF ZEROP A THEN RETURN 'FAILED; IF A<0 THEN <<A:=-A; Y0:=-Y0 >>; IF ONEP GCDN(A,Y0) THEN RETURN LIST(1,A,Y0); RETURN 'FAILED END; SYMBOLIC PROCEDURE QUADTHROUGH(YM1,Y0,Y1); BEGIN SCALAR A,B,C; A:=DIVIDE(YM1+Y1,2); IF ZEROP CDR A THEN A:=(CAR A)-Y0 ELSE RETURN 'FAILED; IF ZEROP A THEN RETURN 'FAILED; %LINEAR THINGS ALREADY DONE; C:=Y0; B:=DIVIDE(Y1-YM1,2); IF ZEROP CDR B THEN B:=CAR B ELSE RETURN 'FAILED; IF NOT ONEP GCDN(A,GCD(B,C)) THEN RETURN 'FAILED; IF A<0 THEN <<A:=-A; B:=-B; C:=-C>>; RETURN LIST(2,A,B,C) END; ENDMODULE; MODULE UNIFORM; EXPORTS UNIFORM; IMPORTS EXPONENTOF; SYMBOLIC PROCEDURE UNIFORM(P,V); %CONVERT FROM D.F. IN ONE VARIABLE (V) TO A SIMPLE LIST OF; %COEFFS (WITH DEGREE CONSED ONTO FRONT); %FAILS IF COEFFICIENTS ARE NOT ALL SIMPLE INTEGERS; IF NULL P THEN 0 . (0 . NIL) ELSE BEGIN SCALAR A,B,C,D; A:=EXPONENTOF(V,LPOW P,ZLIST); B:=LC P; IF NOT ONEP DENR B THEN RETURN 'FAILED; B:=NUMR B; IF NULL B THEN B:=0 ELSE IF NOT NUMBERP B THEN RETURN 'FAILED; IF A=0 THEN RETURN A . (B . NIL); %CONSTANT TERM; C:=UNIFORM(RED P,V); IF C='FAILED THEN RETURN 'FAILED; D:=CAR C; C:=CDR C; D:=D+1; WHILE NOT (A=D) DO << C:=0 . C; D:=D+1>>; RETURN A . (B . C) END; ENDMODULE; MODULE MAKEVARS; EXPORTS GETVARIABLES,VARSINLIST,VARSINSQ,VARSINSF,FINDZVARS, CREATEINDICES,MERGEIN; IMPORTS DEPENDSP,UNION; % Note that 'i' is already maybe committed for sqrt(-1); %also 'l' and 'o' are not used as the print badly on certain; %terminals etc and may lead to confusion; !*GENSYMLIST!* := '(! j ! k ! l ! m ! n ! o ! p ! q ! r ! s ! t ! u ! v ! w ! x ! y ! z); %MAPC(!*GENSYMLIST!*,FUNCTION REMOB); %REMOB protection; SYMBOLIC PROCEDURE VARSINLIST(L,VL); %L IS A LIST OF S.Q. - FIND ALL VARIABLES MENTIONED; %GIVEN THAL VL IS A LIST ALREADY KNOWN ABOUT; BEGIN WHILE NOT NULL L DO << VL:=VARSINSF(NUMR CAR L,VARSINSF(DENR CAR L,VL)); L:=CDR L >>; RETURN VL END; SYMBOLIC PROCEDURE GETVARIABLES SQ; VARSINSF(NUMR SQ,VARSINSF(DENR SQ,NIL)); SYMBOLIC PROCEDURE VARSINSF(FORM,L); IF ATOM FORM THEN L ELSE BEGIN WHILE NOT ATOM FORM DO << L:=VARSINSF(LC FORM,UNION(L,LIST MVAR FORM)); FORM:=RED FORM >>; RETURN L END; SYMBOLIC PROCEDURE FINDZVARS(VL,ZL,VAR,FLG); BEGIN SCALAR V; % VL is the crude list of variables found in the original integrand; % ZL must have merged into it all EXP, LOG etc terms from this; % If FLG is true then ignore DF as a function; SCAN: IF NULL VL THEN RETURN ZL; V:=CAR VL; % NEXT VARIABLE; VL:=CDR VL; % at present items get put onto ZL if they are non-atomic; % and they depend on the main variable. The arguments of; % functions are decomposed by recursive calls to findzvar; %give up if V has been declared dependent on other things; IF ASSOC(V,DEPL!*) THEN ERROR1() ELSE IF NOT ATOM V AND (NOT V MEMBER ZL) AND DEPENDSP(V,VAR) THEN IF CAR V MEMQ '(TIMES QUOTIENT PLUS MINUS DIFFERENCE INT) OR (((CAR V) EQ 'EXPT) AND FIXP CADDR V) THEN ZL:=FINDZVARS(CDR V,ZL,VAR,FLG) ELSE IF FLG AND CAR V='DF THEN << !*PURERISCH:=T; RETURN ZL >> % TRY AND STOP IT; ELSE ZL:=V.FINDZVARS(CDR V,ZL,VAR,FLG); % SCAN ARGUMENTS OF FN; GO TO SCAN END; SYMBOLIC PROCEDURE CREATEINDICES ZL; % Produces a list of unique indices, each associated with a ; % different Z-variable; REVERSEWOC CRINDEX1(ZL,!*GENSYMLIST!*); SYMBOLIC PROCEDURE CRINDEX1(ZL,GL); BEGIN IF NULL ZL THEN RETURN NIL; IF NULL GL THEN << GL:=LIST GENSYM1 'i; %new symbol needed; NCONC(!*GENSYMLIST!*,GL) >>; RETURN (CAR GL) . CRINDEX1(CDR ZL,CDR GL) END; SYMBOLIC PROCEDURE RMEMBER(A,B); IF NULL B THEN NIL ELSE IF A=CDAR B THEN CAR B ELSE RMEMBER(A,CDR B); SYMBOLIC PROCEDURE MERGEIN(DL,LL); %ADJOIN LOGS OF THINGS IN DL TO EXISTING LIST LL; IF NULL DL THEN LL ELSE IF RMEMBER(CAR DL,LL) THEN MERGEIN(CDR DL,LL) ELSE MERGEIN(CDR DL,('LOG . CAR DL) . LL); ENDMODULE; MODULE VECTOR; EXPORTS MKIDENM,MKVEC2,MKVEC; IMPORTS MKNILL,PNTH; SYMBOLIC PROCEDURE MKVEC(L); BEGIN SCALAR V,I; V:=MKVECT(-1+LENGTH L); I:=0; WHILE L DO << PUTV(V,I,(CAR L) ./ 1); I:=I+1; L:=CDR L >>; RETURN V END; ENDMODULE; END; |
Added r30/int.tst version [4c7b3ccc6e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT THE REDUCE INTEGRATION TEST PACKAGE Edited By Anthony C. Hearn The Rand Corporation This file is designed to provide a set of representative tests of the Reduce integration package. Not all examples go through, even when an integral exists, since some of the arguments are outside the domain of applicability of the current package. However, future improvements to the package will result in more closed-form evaluations in later releases. We would appreciate any additional contributions to this test file either because they illustrate some feature (good or bad) of the current package, or suggest domains which future versions should handle. Any suggestions for improved organization of this test file (e.g., in a way which corresponds more directly to the organization of a standard integration table book such as Gradshteyn and Ryznik) are welcome. Acknowledgments: The examples in this file have been contributed by the following. Any omissions to this list should be reported to the Editor. David M. Dahm John P. Fitch Steven Harrington Anthony C. Hearn K. Siegfried Koelbig Ernst Krupnikov Arthur C. Norman Herbert Stoyan ; Comment we first set up a suitable testing function; SYMBOLIC OPERATOR TIME; PROCEDURE TESTINT(A,B); BEGIN SCALAR DIFFCE,RES,TT; TT:=TIME(); RES:=INT(A,B); WRITE "Time for Integral: ",TIME()-TT," ms"; DIFFCE := DF(RES,B)-A; IF DIFFCE NEQ 0 THEN BEGIN FOR ALL X LET TAN X=SIN(2*X)/(1+COS(2*X)), SIN X**2=1-COS X**2, TANH X= (E**(X)-E**(-X))/(E**X+E**(-X)); DIFFCE := DIFFCE; FOR ALL X CLEAR TAN X,SIN X**2,TANH X END; %hopefully, difference appeared non-zero due to absence of %above transformations; IF DIFFCE NEQ 0 THEN WRITE "DERIVATIVE OF INTEGRAL NOT EQUAL TO INTEGRAND"; RETURN RES END; % REFERENCES ARE TO GRADSHTEYN & RYZHIK; testint(1/x,x); % 2.01 #2; testint((x+1)**3/(x-1)**4,x); testint(log x,x); testint(x*log x,x); testint(x**2*log x,x); testint(x**p*log x,x); testint((log x)**2,x); testint(x**9*log x**11,x); testint(log x**2/x,x); testint(1/log x,x); testint(1/(x*log x),x); testint(sin log x,x); testint(cos log x,x); testint((log x)**p/x,x); testint(log x *(a*x+b),x); testint((a*x+b)**2*log x,x); testint(log x/(a*x+b)**2,x); testint(log x/sqrt(a*x+b),x); testint(x*log (a*x+b),x); testint(x**2*log(a*x+b),x); testint(log(x**2+a**2),x); testint(x*log(x**2+a**2),x); testint(x**2*log(x**2+a**2),x); testint(x**4*log(x**2+a**2),x); testint(log(x**2-a**2),x); testint(log(log(log(log(x)))),x); testint(sin x,x); % 2.01 #5; testint(cos x,x); % #6; testint(tan x,x); % #11; testint(1/tan(x),x); % 2.01 #12; testint(1/cos x,x); testint(1/sin x,x); testint(sin x**2,x); testint(x**3*sin(x**2),x); testint(sin x**3,x); testint(sin x**p,x); testint((sin x**2+1)**2*cos x,x); testint(cos x**2,x); testint(cos x**3,x); testint(sin(a*x+b),x); testint(1/cos x**2,x); testint(1/(1+cos x),x); testint(1/(1-cos x),x); testint(sqrt(1-cos x),x); testint(sin x* sin (2*x),x); testint(x*sin x,x); testint(x**2*sin x,x); testint(x*sin x**2,x); testint(x**2*sin x**2,x); testint(x*sin x**3,x); testint(x*cos x,x); testint(x**2*cos x,x); testint(x*cos x**2,x); testint(x**2*cos x**2,x); testint(x*cos x**3,x); testint(sin x/x,x); testint(cos x/x,x); testint(sin x/x**2,x); testint(sin x**2/x,x); testint(tan x**3,x); testint(e**x,x); % 2.01 #3; testint(a**x,x); % 2.01 #4; testint(e**(a*x),x); testint(e**(a*x)/x,x); testint(1/(a+b*e**(m*x)),x); testint(e**(2*x)/(1+e**x),x); testint(1/(a*e**(m*x)+b*e**(-m*x)),x); testint(x*e**(a*x),x); testint(x**20*e**x,x); testint(a**x/b**x,x); testint(a**x*b**x,x); testint(a**x/x**2,x); testint(x*a**x/(1+b*x)**2,x); testint(x*e**(a*x)/(1+a*x)**2,x); testint(x*k**(x**2),x); testint(e**(x**2),x); testint(x*e**(x**2),x); testint((2*x**3+x)*(e**(x**2))**2*e**(1-x*e**(x**2))/(1-x*e**(x**2))**2, x); testint(e**(e**(e**(e**x))),x); testint(e**x*log x,x); testint(x*e**x*log x,x); testint(e**(2*x)*log(e**x),x); z:=a+b*x; testint(z**p,x); testint(x*z**p,x); testint(x**2*z**p,x); testint(1/z,x); testint(1/z**2,x); testint(x/z,x); testint(x**2/z,x); testint(1/(x*z),x); testint(1/(x**2*z),x); testint(1/(x*z)**2,x); testint(1/(c**2+x**2),x); testint(1/(c**2-x**2),x); u:=sqrt(a+b*x); v:=sqrt(c+d*x); testint(u*v,x); testint(u,x); testint(x*u,x); testint(x**2*u,x); testint(u/x,x); testint(u/x**2,x); testint(1/u,x); testint(x/u,x); testint(x**2/u,x); testint(1/(x*u),x); testint(1/(x**2*u),x); testint(u**p,x); testint(x*u**p,x); testint(sin z,x); testint(cos z,x); testint(tan z,x); testint(1/tan z,x); testint(1/sin z,x); testint(1/cos z,x); testint(sin z**2,x); testint(sin z**3,x); testint(cos z**2,x); testint(cos z**3,x); testint(1/cos z**2,x); testint(1/(1+sin x),x); testint(1/(1-sin x),x); testint(x**2*sin z**2,x); testint(cos x*cos(2*x),x); testint(x**2*cos z**2,x); testint(1/tan x**3,x); testint(x**3*tan(x)**4,x); testint(x*tan(x)**2,x); testint(sin(2*x)*cos(3*x),x); testint(sin x**2*cos x**2,x); testint(1/(sin x**2*cos x**2),x); testint(d**x*sin x,x); testint(x*d**x*sin x,x); testint(x**2*d**x*sin x,x); testint(d**x*cos x,x); testint(x*d**x*cos x,x); testint(x**2*d**x*cos x,x); testint(x**3*d**x*sin x,x); testint(x**3*d**x*cos x,x); testint(sin x*sin(2*x)*sin(3*x),x); testint(cos x*cos(2*x)*cos(3*x),x); testint(x*cos(xi/sin(x))*cos(x)/sin(x)**2,x); Comment this integral has given trouble at various times; testint(atan((-sqrt(2)+2*x)/sqrt(2)),x); Comment many of these integrals used to require Steve Harrington's code to evaluate. They originated in Novosibirsk as examples of using Analytik. There are still a few examples which could be evaluated using better heuristics; testint(a*sin(3*x+5)**2*cos(3*x+5),x); testint(log(x**2)/x**3,x); testint(x*sin(x+a),x); testint((log(x)*(1-x)-1)/(e**x*log(x)**2),x); testint(x**3*(a*x**2+b)**(-1),x); testint(x**(1/2)*(x+1)**(-7/2),x); testint(x**(-1)*(x+1)**(-1),x); testint(x**(-1/2)*(2*x-1)**(-1),x); testint((x**2+1)*x**(1/2),x); testint(x**(-1)*(x-a)**(1/3),x); testint(x*sinh(x),x); testint(x*cosh(x),x); testint(x**2*(2*x**2+x)**2,x); testint(x*(x**2+2*x+1),x); testint(sinh(2*x)/cosh(2*x),x); testint(sin(2*x+3)*cos(x)**2,x); testint(x*atan(x),x); testint(x*acot(x),x); testint(x*log(x**2+a),x); testint(sin(x+a)*cos(x),x); testint(cos(x+a)*sin(x),x); testint((2+2*sin(x))**(1/2),x); testint((2-2*sin(x))**(1/2),x); testint((2+2*cos(x))**(1/2),x); testint((2-2*cos(x))**(1/2),x); testint(1/(x**(1/2)-(x-1)**(1/2)),x); testint(1/(1-(x+1)**(1/2)),x); testint(x/(x**4+36)**(1/2),x); int(1/(x**(1/3)+x**(1/2)),x); testint(log(2+3*x**2),x); testint(cot(x),x); int(cot x**4,x); testint(tanh(x),x); testint(coth(x),x); testint(b**x,x); testint((x**4+x**(-4)+2)**(1/2),x); testint((2*x+1)/(3*x+2),x); testint(x*log(x+(x**2+1)**(1/2)),x); testint(x*(e**x*sin(x)+1)**2,x); testint(x*e**x*cos(x),x); Comment the following set came from Herbert Stoyan who used to be in Dresden; testint(1/(x-3)**4,x); testint(x/(x**3-1),x); testint(x/(x**4-1),x); testint(log(x)*(x**3+1)/(x**4+2),x); testint(log(x)+log(x+1)+log(x+2),x); testint(1/(x**3+5),x); testint(sqrt(x**2+3),x); testint(x/(x+1)**2,x); COMMENT The following integrals were contributed by David M. Dahm. He also developed the code to make most of them integrable; testint(1/(2*x**3-1),x); testint(1/(x**3-2),x); testint(1/(a*x**3-b),x); testint(1/(x**4-2),x); testint(1/(5*x**4-1),x); testint(1/(3*x**4+7),x); testint(1/(x**4+3*x**2-1),x); testint(1/(x**4-3*x**2-1),x); testint(1/(x**4-3*x**2+1),x); testint(1/(x**4-4*x**2+1),x); testint(1/(x**4+4*x**2+1),x); testint(1/(x**4+x**2+2),x); testint(1/(x**4-x**2+2),x); testint(1/(x**6-2),x); testint(1/(x**6+2),x); testint(1/(x**8+1),x); testint(1/(x**8-x**4+1),x); COMMENT The following integrals were used among others as a test of Moses' SIN program; testint(asin x,x); testint(x**2*asin x,x); testint(sec x**2/(1+sec x**2-3*tan x),x); testint(1/sec x**2,x); testint((5*x**2-3*x-2)/(x**2*(x-2)),x); testint(1/(4*x**2+9)**(1/2),x); testint((x**2+4)**(-1/2),x); testint(1/(9*x**2-12*x+10),x); testint(1/(x**8-2*x**7+2*x**6-2*x**5+x**4),x); testint((a*x**3+b*x**2+c*x+d)/((x+1)*x*(x-3)),x); testint(1/(2-log(x**2+1))**5,x); testint((2*x**3+x)*e**(x**2)**2*e**(1-x*e**(x**2))/(1-x*e**(x**2))**2 ,x); testint(2*x*e**(x**2)*log(x)+e**(x**2)/x+(log(x)-2)/(log(x)**2+x)**2+ ((2/x)*log(x)+(1/x)+1)/(log(x)**2+x),x); Comment here is an example of using the integrator with pattern matching; for all m,n let int(k1**m*log(k1)**n/(p**2-k1**2),k1)=foo(m,n), int(k1*log(k1)**n/(p**2-k1**2),k1)=foo(1,n), int(k1**m*log(k1)/(p**2-k1**2),k1)=foo(m,1), int(k1*log(k1)/(p**2-k1**2),k1)=foo(1,1), int(log(k1)**n/(k1*(p**2-k1**2)),k1)=foo(-1,n); int(k1**2*log(k1)/(p**2-k1**2),k1); COMMENT It is interesting to see how much of this one can be done; let f1s= (12*log(s/mc**2)*s**2*pi**2*mc**3*(-8*s-12*mc**2+3*mc) + pi**2*(12*s**4*mc+3*s**4+176*s**3*mc**3-24*s**3*mc**2 -144*s**2*mc**5-48*s*mc**7+24*s*mc**6+4*mc**9-3*mc**8)) /(384*e**(s/y)*s**2); int(f1s,s); factor int; ws; Comment Some definite integrals; algebraic procedure dint(f,x,x1,x2); begin scalar y; y := int(f,x); return sub(x=x2,y) - sub(x=x1,y) end; dint(sin x,x,0,pi/2); dint(x/(x+2),x,2,6); dint(log(x),x,1,5); dint((1+x**2/p**2)**(1/2),x,0,p); dint(x**9+y+y**x+x,x,0,2); Comment the following integrals reveal deficiencies in the current integrator; %this one seems to run forever; %testint(x**7/(x**12+1),x); %high degree denominator; %testint(1/(2-log(x**2+1))**5,x); %the next two integrals should return a closed-form solution; testint(1/(a+b*sin x),x); testint(1/(a+b*sin x+cos x),x); %this example should evaluate; testint(sin(2*x)/cos(x),x); %this example, which appeared in Tobey's thesis, needs factorization %over algebraic fields. It currently gives an ugly answer; int((7*x**13+10*x**8+4*x**7-7*x**6-4*x**3-4*x**2+3*x+3)/ (x**14-2*x**8-2*x**7-2*x**4-4*x**3-x**2+2*x+1),x); end; |
Added r30/lap.fap version [0965c7b16d].
cannot compute difference between binary files
Added r30/lap.red version [a09ad164fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE LAP; SYMBOLIC; COMMENT definition of LAP ops; SYMBOLIC FEXPR PROCEDURE MACOPS L; BEGIN A: IF NULL L THEN RETURN T; PUT(CAR L,'MACOP,CADR L); L := CDDR L; GO TO A END; MACOPS(PUSHJ, 176, POPJ, 179, PUSH, 177, POP, 178, CALL, 28, JCALL, 29, CALLF, 30, JCALLF, 31, JRST, 172, JSP, 181, CALLF!@, 15376, JCALLF!@, 15888, MOVE, 128, MOVEI, 129, MOVEM, 130, HRRZS,363, MOVNI, 137, HLLZS,331, CAIE, 194, CAIN, 198, CAME, 202, CAMGE, 205, CAMLE, 203, CAMN, 206, ADD, 184, SUB, 188, IMUL, 144, CLEARM, 258, CLEARB, 259, EXCH, 168, TDZA, 412, JUMP, 208, JUMPE, 210, JUMPN, 214, HRRZ, 360, HLRZ, 364, HRRM, 354, HRLM, 326, HRLI, 325, HRRZ!@, 184336, HLRZ!@, 186384, HRRM!@, 181264, HRLM!@, 166928, HRRZS!@, 185872, HLLZS!@, 169488, JUMPGE, 213); MACOPS(NIL,0,A,1,B,2,C,3,TT,7,D,10,R,11,P,12,SP,15); MACOPS(CARA, 364, CARA!@, 186384, CDRA, 360, CDRA!@, 184336, RPLCA, 326, RPLCA!@, 166928, RPLCD, 354, RPLCD!@, 181264, JSYS, 68); MACOPS(SETO, 316, MOVSI, 133, ILDB, 92, IDPB, 94, TRZ, 400, HRRI, 353, HRROI, 369, HRL, 324, HRRZ, 360, TRO, 432, ADDI, 185, AOBJN, 171, CAIL, 193, SKIPA, 220, SKIPE, 218, SETZM, 258, BLT, 169, SUBI, 189, AOJN, 230, SKIPG, 223, LDB, 93, AOJA, 228, SOJA, 244, CAIG, 199, CAILE, 195, LSH, 162, IORM, 286, HRLZ, 332, HRLZM, 334, SOJE, 242, SOJN, 246, DPB, 95, ANDI, 261); FLUID '(BPORG BPEND CLIST QLIST); FLUID '(!*PWRDS !*PGWD !*SAVECOM CONLIST GEN REMSYMS); SYMBOLIC PROCEDURE LAP U; LAP10 U; SYMBOLIC PROCEDURE LAP10 U; BEGIN SCALAR SL,LOC,CONLIST,GEN,REMSYMS,X; GEN := GENSYM(); %entry point for constants; CONLIST := LIST NIL; %constant list; LOC := BPORG; %entry point for function; WHILE U DO <<IF ATOM(X := CAR U) THEN <<IF !*PGWD THEN PRINT X; DEFSYM(X,BPORG)>> ELSE IF CAR X EQ '!*ENTRY THEN <<IF SL THEN RPLACD(CDAR SL,BPORG); SL := LIST(CDR X,BPORG) . SL; LOC := BPORG; IF !*COUNTMC THEN RPLACD(U,APPEND( <<PUT(CAR X,'MCCOUNT,ADD1 GET(CAR X,'MCCOUNT)); COUNTMC CAR X>>,CDR U)); IF !*PGWD THEN PRINT X>> ELSE IF CADR X MEMBER '(EXPR FEXPR) THEN <<IF SL THEN RPLACD(CDAR SL,BPORG); SL := LIST(X,BPORG) . SL; LOC := BPORG; IF !*PGWD THEN PRINT X>> ELSE IF NOT NUMBERP CAR X AND FLAGP(CAR X,'MC) THEN RPLACD(U,APPEND(IF !*COUNTMC THEN <<PUT(CAR X,'MCCOUNT,ADD1 GET(CAR X,'MCCOUNT)); COUNTMC CAR X>>, APPEND(EVAL(CAR X . FOR EACH J IN CDR X COLLECT MKQUOTE J), CDR U))) ELSE <<DEPOSIT(BPORG,KWD X); IF (BPORG := BPORG+1)>BPEND THEN REDERR "BINARY PROGRAM SPACE EXCEEDED">>; U := CDR U>>; IF SL THEN <<RPLACD(CDAR SL,BPORG); SL := REVERSIP SL; IF !*PWRDS THEN FOR EACH X IN SL DO LPRIM LIST(CAAR X,CADR X,'BASE, CDDR X-CADR X, 'WORDS,BPEND-CDDR X,'LEFT)>>; DEFSYM(GEN,BPORG); %define entry point for constants; WHILE CONLIST := CDR CONLIST DO <<CLIST := (CAR CONLIST . BPORG) . CLIST; DEPOSIT(BPORG,KWD CAR CONLIST); IF (BPORG := BPORG+1)>BPEND THEN REDERR "BINARY PROGRAM SPACE EXCEEDED">>; FOR EACH X IN REMSYMS DO REMSYM X; IF !*SAVECOM THEN FOR EACH X IN SL DO <<REMD CAAR X; !%PUTD(CAAR X,CADAR X,MKCODE(CADR X,CADDAR X))>>; END; SYMBOLIC PROCEDURE KWD U; BEGIN SCALAR X; X := GWD U; IF !*PGWD THEN BEGIN INTEGER N; PRIN1 U; SPACES2 30; N := BASE; BASE := 7+1; PRINT(IF X < 0 THEN X + 68719476736 ELSE X); BASE := N END; RETURN X END; SYMBOLIC PROCEDURE SPACES2 N; BEGIN SCALAR M; M := N-POSN(); IF M<1 THEN PRIN2 " " ELSE WHILE M>0 DO <<PRIN2 " "; M := M-1>> END; % PRINT MACROS FIRST, IF T; !*PWRDS := T; % PRINT SPACE-USAGE, IF T; !*PGWD := NIL; % PRINT EXPANDED CODE IF T; !*SAVECOM := T; % ACTUALLY LOAD IF T; !*SAVEDEF := NIL; % RETAIN EXPR/FEXPR IF T; QSET('QLIST,NIL); QSET('CLIST,NIL); SYMBOLIC PROCEDURE GWD X; BEGIN SCALAR WRD,FLD; WRD := LAPEVAL CAR X; WRD := LSH(WRD,IF WRD<512 THEN 27 ELSE 18); FLD := '((23 . 15) (0 . 262143) (18 . -1)); MAPC(CDR X, FUNCTION LAMBDA ZZ; <<WRD := WRD + LSH(BOOLE(1,CDAR FLD,LAPEVAL ZZ), CAAR FLD); FLD := CDR FLD>>); RETURN WRD END; SYMBOLIC PROCEDURE RELOC L; LAPEVAL CAR L + 96; SYMBOLIC PROCEDURE LAPEVAL X; IF NUMBERP X THEN X ELSE IF ATOM X THEN GVAL X ELSE IF CAR X MEMBER '(E QUOTE) THEN !*BOX IF (NOT ATOM (X := CADR X) OR NUMBERP X AND NOT INUMP X) OR STRINGP X THEN BEGIN SCALAR Y; Y := QLIST; A: IF NULL Y THEN RETURN CAR (QLIST := X . QLIST) ELSE IF X=CAR Y AND FLOATP X EQ FLOATP CAR Y THEN RETURN CAR Y; Y := CDR Y; GO TO A END ELSE X ELSE IF CAR X EQ 'FLUID OR CAR X EQ 'SPECIAL THEN <<QSET(CADR X,NIL); !*BOX GET(CADR X,'VALUE)>> ELSE IF CAR X EQ 'C THEN BEGIN SCALAR N,CPTR; CPTR := CLIST; L11: IF NULL CPTR THEN GO TO L12 ELSE IF CDR X=CAAR CPTR THEN RETURN CDAR CPTR; CPTR := CDR CPTR; GO TO L11; L12: GVAL GEN; N := 0; CPTR := CONLIST; A: IF NULL CDR CPTR THEN RPLACD(CPTR,LIST CDR X); IF CDR X=CADR CPTR THEN RETURN N; N := N + 1; CPTR := CDR CPTR; GO TO A END ELSE IF CAR X EQ 'RELOC THEN LAPEVAL CADR X + 96 ELSE IF CAR X EQ 'EXARG AND NOT ATOM CDR X THEN LAPEVAL 'EXARG + LAPEVAL CADR X ELSE LAPEVAL CAR X + LAPEVAL CDR X; SYMBOLIC PROCEDURE DEFSYM(SYM,VAL); BEGIN SCALAR Z; IF Z := GET(SYM,'UNDEF) THEN GO TO PATCH; REMSYMS := SYM . REMSYMS; A: RETURN PUT(SYM,'SYM,VAL); PATCH: IF NULL Z THEN <<REMPROP(SYM,'UNDEF); GO TO A>>; DEPOSIT(CAR Z,EXAMINE CAR Z + VAL); Z := CDR Z; GO TO PATCH END; SYMBOLIC PROCEDURE GVAL SYM; BEGIN SCALAR X; IF X := GET(SYM,'MACOP) THEN RETURN X ELSE IF X := GET(SYM,'SYM) THEN RETURN X ELSE IF GET(SYM,'VALUE) THEN RETURN !*BOX SYM; PUT(SYM, 'UNDEF, BPORG . IF X := GET(SYM,'UNDEF) THEN X ELSE <<REMSYMS := SYM . REMSYMS; NIL>>); RETURN 0 END; SYMBOLIC PROCEDURE REMSYM L; IF GET(L,'UNDEF) THEN LPRIE LIST(L,"UNDEFINED SYMBOL") ELSE IF NULL REMPROP(L,'SYM) THEN LPRIE LIST(L,"MULTIPLY DEFINED") ELSE IF CAADR L EQ 'PNAME THEN REMOB L %means L has no props; ELSE NIL; BPORG1 := BPORG; LAP10 '((GWD EXPR 1) (PUSH P (C 0)) (PUSH P 1) (PUSHJ P TAG04) (CAIG 1 511) (LSH 1 9) (HLRZ 2 1) (HRRZ 3 1) (CAIN 2 34816) (CAIL 3 512) (JRST 0 TAG01) (MOVEM 1 -1 P) (JUMPN 3 TAG02) TAG01 (HRLZM 1 -1 P) (PUSHJ P TAG04) (ANDI 1 15) (LSH 1 23) (IORM 1 -1 P) (PUSHJ P TAG04) (HRRM 1 -1 P) (PUSHJ P TAG04) (HRLZ 1 1) (IORM 1 -1 P) TAG02 (POP P 1) (POP P 1) (JCALL 1 (E !*BOX)) TAG03 (POP P 1) (JRST 0 TAG02) TAG04 (MOVE 2 -1 P) (JUMPE 2 TAG03) (CARA 1 0 2) (CDRA 2 0 2) (MOVEM 2 -1 P) (CALL 1 (E LAPEVAL)) (JCALL 1 (E NUMVAL))); CLIST := NIL; IF BPEND<131072 THEN BPORG := BPORG1; %means DECUS version; END; |
Added r30/less1 version [3da48e6880].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 1 David R. Stoutemyer University of Hawaii COMMENT This is lesson 1 of 7 interactive lessons about the REDUCE system for computer symbolic mathematics. These lessons presume an acquaintance with elementary calculus, together with a previous exposure to some computer programming language. These lessons have been designed for use on a DECsystem 10 or 20. Apart from changes to the prompt and interrupt characters however they should work just as well with any REDUCE implementation. In REDUCE, any sequence of characters from the word "COMMENT" through the next semicolon or dollar-sign statement separator is an explanatory remark ignored by the system. In general, either separator signals the end of a statement, with the dollar sign suppressing any output that might otherwise automatically be produced by the statement. The typing of a carriage return initiates the immediate sequential execution of all statements which have been terminated on that line. When REDUCE is ready for more input, it will prompt you with an asterisk at the left margin. To terminate the lesson and return to the operating system, type an interrupt character (DEC: control-C ) at any time. Expressions can be formed using "**", "*", "/", "+", and "-" to indicate exponentiation, multiplication, division, addition, and subtraction or negation respectively. Assignments to variables can be done using the operator ":=". For example:; R2D2 := (987654321/15)**3; COMMENT The immediately preceding line, without a semicolon, is the computed output generated by the line with a semicolon which precedes it. Note that exact indefinite-precision rational arithmetic was used, in contrast to the limited-precision arithmetic of traditional programming languages. We can use the name R2D2 to represent its value in subsequent expressions such as; R2D2 := -R2D2/25 + 3*(13-5); COMMENT Now I will give you an opportunity to try some analogous computations. To do so, type the letter N followed by a carriage return in response to our question "CONT?" (You could type Y if you wish to relinquish this opportunity, but I strongly recommend reinforced learning through active participation.) After trying an example or two, type the command "CONT" terminated by a semicolon and carriage return when you wish to proceed with the rest of the lesson. To avoid interference with our examples, please don't assign anything to any variable names beginning with the letters E through I. To avoid lengthy delays, I recommend keeping all of your examples approximately as trivial as ours, saving your more ambitious experiments until after the lesson. If you happen to initiate a calculation requiring an undue amount of time to evaluate or to print, you can abort that computation with an interrupt to get back to the operating system. Restart REDUCE, followed by the statement "IN LESS1", followed by a semicolon and return, to restart the lesson at the beginning; PAUSE; COMMENT Now watch this example illustrating some more dramatic differences from traditional scientific programming systems:; E1 := 2*G + 3*G + H**3/H; COMMENT Note how we are allowed to use variables to which we have assigned no values! Note too how similar terms and similar factors are combined automatically. REDUCE also automatically expands products and powers of sums, together with placing expressions over common denominators, as illustrated by the examples:; E2 := E1*(F+G); E2 := E1**2; E1+1/E1; COMMENT Our last example also illustrates that there is no need to assign an expression if we do not plan to use its value later. Try some similar examples:; PAUSE; COMMENT It is not always desirable to expand expressions over a common denominator, and we can use the OFF statement to turn off either or both computational flags which control these transformations. The flag named EXP controls EXPansion, and the flag named MCD controls the Making of Common Denominators; OFF EXP, MCD; E2 := E1**2 $ E2 := E2*(F+G) + 1/E1; COMMENT To turn these flags back on, we type:; ON EXP, MCD; COMMENT Try a few relevant examples with these flags turned off individually and jointly; PAUSE; COMMENT Now consider the example:; E2 := (2*(F*H)**2 - F**2*G*H - (F*G)**2 - F*H**3 + F*H*G**2 - H**4 + G*H**3)/(F**2*H - F**2*G - F*H**2 + 2*F*G*H - F*G**2 - G*H**2 + G**2*H); COMMENT It is not obvious, but the numerator and denominator of this expression share a nontrivial common divisor which can be cancelled. To make REDUCE automatically cancel greatest common divisors, we turn on the computational flag named GCD:; ON GCD; E2; COMMENT The flag is not on by default because 1. It can consume a lot of time. 2. Often we know in advance the few places where a nontrivial GCD can occur in our problem. 3. Even without GCD cancellation, expansion and common denomin- ators guarantee that any rational expression which is equiv- alent to zero simplifies to zero. 4. When the denominator is the greatest common divisor, such as for (X**2 - 2*X + 1)/(X-1), REDUCE cancels the greatest common divisor even when GCD is OFF. 5. GCD cancellation sometimes makes expressions more complicated, such as with (F**10 - G**10)/(F**2 - F*G). Try the examples mentioned in this comment, together with one or two other relevant ones; PAUSE; COMMENT Exact rational arithmetic can consume an alarming amount of computer time when the constituent integers have quite large magnitudes, and the results become awkward to interpret qualitatively. When this is the case and somewhat inexact numerical coefficients are acceptable, we can have the arithmetic done floating point by turning on the computational flag FLOAT. With this flag on, any non-integer rational numbers are approximated by floating-point numbers, and the result of any arithmetic operation is floating-point when any of its operands is floating point. For example:; ON FLOAT, EXP; E1:= (12.3456789E3 *F + 3*G)**2 + 1/2; COMMENT With FLOAT off, any floating-point constants are automatically approximated by rational numbers:; OFF FLOAT; E1 := 12.35*G; PAUSE; COMMENT A number of elementary functions, such as SIN, COS and LOG, are built into REDUCE. Moreover, the letter E represents the base of the natural logarithms, so the exponentiation operator enables us to represent the exponential function as well as fractional powers. For example:; E1:= SIN(-F*G) + LOG(E) + (3*G**2*COS(-1))**(1/2); COMMENT What automatic simplifications can you identify in this example? Note that most REDUCE implementations do not approximate the values of these functions for non-trivial numerical arguments, and exact computations are generally impossible for such cases. Experimentally determine some other built-in simplifications for these functions; PAUSE; COMMENT Later you will learn how to introduce additional simplifications and additional functions, including numerical approximations for examples such as COS(1). Differentiation is also built-into REDUCE. For example, to differentiate E1 with respect to F; E2 := DF(E1,F); COMMENT To compute the second derivative of E2 with respect to G, we can type either DF(E2,G,2) or DF(E1,F,1,G,2) or DF(E1,F,G,2) or DF(E1,G,2,F,1) or; DF(E1,G,2,F); COMMENT Surely you can't resist trying a few derivatives of your own! (Careful, High-order derivatives can be alarmingly complicated); PAUSE; COMMENT REDUCE uses the name I to represent (-1)**(1/2), incorporating some simplification rules such as replacing I**2 by -1. Here is an opportunity to experimentally determine other simplifications such as for I**3, 1/I**23, and (I**2-1)/(I-1); PAUSE; COMMENT Clearly it is inadvisable to use E or I as a variable. T is also inadvisable for reasons that will become clear later. The value of a variable is said to be "bound" to the variable. Any variable to which we have assigned a value is called a bound variable, and any variable to which we have not assigned a value is called an indeterminate. Occasionally it is desirable to make a bound variable into an indeterminate, and this can be done using the CLEAR command. For example:; CLEAR R2D2, E1, E2; E2; COMMENT If you suspect that a degenerate assignment, such as E1:=E1, would suffice to clear a bound variable, try it on one of your own bound variables:; PAUSE; COMMENT REDUCE also supports matrix algebra, as illustrated by the following sequence:; MATRIX E1(4,1), F, H; COMMENT This declaration establishes E1 as a matrix with 4 rows and 1 column, while establishing F and H as matrices of unspecified size. To establish element values (and sizes if not already established in the MATRIX declaration), we can use the MAT function, as illustrated by the following example:; H := MAT((LOG(G), G+3), (G, 5/7)); COMMENT Only after establishing the size and establishing the element values of a declared matrix by executing a matrix assignment can we refer to an individual element or to the matrix as a whole. For example to increase the last element of H by 1 then form twice the transpose of H, we can type; H(2,2) := H(2,2) + 1; 2*TP(H); COMMENT To compute the determinant of H:; DET(H); COMMENT To compute the trace of H:; TRACE(H); COMMENT To compute the inverse of H, we can type H**(-1) or 1/H. To compute the solution to the equation H*F = MAT((G),(2)), we can left-multiply the right-hand side by the inverse of H:; F := 1/H*MAT((G),(2)); COMMENT Notes: 1. MAT((G),(2))/H would denote right-multiplication by the inverse, which is not what we want. 2. Solutions for a set of right-hand-side vectors are most efficiently computed simultaneously by collecting the right- hand sides together as the columns of a single multiple-column matrix. 3. Subexpressions of the form 1/H*... or H**(-1)*... are computed more efficiently than if the inverse is computed separately in a previous statement, so separate computation of the inverse is advisable only if several solutions are desired and if they cannot be computed simultaneously. 4. MAT must have parentheses around each row of elements even if there is only one row or only one element per row. 5. References to individual matrix elements must have exactly two subscripts, even if the matrix has only one row or one column. Congratulations on completing lesson 1! I urge you to try a sequence of more ambitious examples for the various features that have been introduced, in order to gain some familiarity with the relationship between problem size and computing time for various operations. (In most implementations, the command "ON TIME" causes computing time to be printed.) I also urge you to bring to the next lesson appropriate examples from textbooks, articles, or elsewhere, in order to experience the decisive learning reinforcement afforded by meaningful personal examples that are not arbitrarily contrived. To avoid the possibility of interference from assignments and declar- ations in lesson 1, it is wise to execute lesson 2 in a fresh REDUCE job, when you are ready. ;END; |
Added r30/less2 version [0a0bc43137].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 2 David R. Stoutemyer University of Hawaii COMMENT This is lesson 2 of 7 REDUCE lessons. Please refrain from using variables beginning with the letters F through H during the lesson. By now you have probably had the experience of generating an expression, and then having to repeat the calculation because you forgot to assign it to a variable or because you did not expect to want to use it later. REDUCE maintains a history of all inputs and computation during an interactive session. (Note, this is only for interactive sessions.) To use an input expression in a new computation, you can say INPUT(n) where n is the appropriate command number. The evaluated computations can be accessed through WS(n) or simply WS if you wish to refer to the last computation. WS stands for Work Space. As with all REDUCE expressions, these can also be used to create new expressions: (INPUT(n)/WS(n2))**2 Special characters can be used to make unique REDUCE variable names that reduce the chance of accidental interference with any other variables. In general, whenever you want to include an otherwise forbidden character such as * in a name, merely precede it by an exclamation point, which is called the escape character. However, pick a character other than "*", which is used for many internal REDUCE names. Otherwise, if most of us use "*" the purpose will be defeated; G+!%H; WS; PAUSE; COMMENT You can also name the expression in the workspace by using the command SAVEAS, for example:; SAVEAS GPLUSH; GPLUSH; PAUSE; COMMENT You may have noticed that REDUCE imposes its own order on the indeterminates and functional forms that appear in results, and that this ordering can strongly affect the intelligibility of the results. For example:; G1:= 2*H*G + E + F1 + F + F**2 + F2 + 5 + LOG(F1) + SIN(F1); COMMENT The ORDER declaration permits us to order indeterminates and functional forms as we choose. For example, to order F2 before F1, and to order F1 before all remaining variables:; ORDER F2, F1; G1; PAUSE; COMMENT Now suppose we partially change our mind and decide to order LOG(F1) ahead of F1; ORDER LOG(F1), F1; G1; COMMENT Note that any other indeterminates or functional forms under the influence of a previous ORDER declaration, such as F2, rank before those mentioned in the later declaration. Try to determine the default ordering algorithm used in your REDUCE implementation, and try to achieve some delicate rearrangements using the ORDER declaration.; PAUSE; COMMENT You may have also noticed that REDUCE factors out any number, indeterminate, functional form, or the largest integer power thereof which exactly divides every term of a result or every term of a parenthesized subexpression of a result. For example:; ON EXP, MCD; G1:= F**2*(G**2 + 2*G) + F*(G**2+H)/(2*F1); COMMENT This process usually leads to more compact expressions and reveals important structural information. However, the process can yield results which are difficult to interpret if the resulting parentheses are nested more than about two levels, and it is often desirable to see a fully expanded result to facilitate direct comparison of all terms. To suppress this monomial factoring, we can turn off an output control flag named ALLFAC; OFF ALLFAC; G1; PAUSE; COMMENT The ALLFAC monomial-factorization process is strongly dependent upon the ordering. We can achieve a more selective monomial factorization by using the FACTOR decalaration, which declares a variable to have FACTOR status. If any indeterminates or functional forms occurring in an expression are in FACTOR status when the expression is printed, terms having the same powers of the indeterminates or functional forms are collected together, and the power is factored out. Terms containing two or more indeterminates or functional forms under FACTOR status are not included in this monomial factorization process. For example:; OFF ALLFAC; FACTOR F; G1; FACTOR G; G1; PAUSE; COMMENT We can use the REMFAC command to remove items from factor status; REMFAC F; G1; COMMENT ALLFAC can still have an effect on the coefficients of the monomials that have been factored out under the influence of FACTOR:; ON ALLFAC; G1; PAUSE; COMMENT It is often desirable to distribute denominators over all factored subexpressions generated under the influence of a FACTOR declaration, such as when we wish to view a result as a polynomial or as a power series in the factored indeterminates or functional forms, with coefficients which are rational functions of any other indeterminates or functional forms. (A mnemonic aid is: think RAT for RATional-function coefficients.) For example:; ON RAT; G1; PAUSE; COMMENT RAT has no effect on expressions which have no indeterminates or functional forms under the influence of FACTOR. The related but different DIV flag permits us to distribute numerical and monomial factors of the denominator over every term of the numerator, expressing these distributed portions as rational-number coefficients and negative power factors respectively. (A mnemonic aid: DIV DIVides by monomials.) The overall effect can also depend strongly on whether the RAT flag is on or off. Series and polynomials are often most attractive with RAT and DIV both on; ON DIV, RAT; G1; OFF RAT; G1; PAUSE; REMFAC G; G1; PAUSE; COMMENT With a very complicated result, detailed study of the result is often facilitated by having each new term begin on a new line, which can be accomplished using the LIST flag:; ON LIST; G1; PAUSE; COMMENT In various combinations, ORDER, FACTOR, the computational flags EXP, MCD, GCD, and FLOAT, together with the output control flags ALLFAC, RAT, DIV, and LIST provide a variety of output alternatives. With experience, it is usually possible to use these tools to produce a result in the desired form, or at least in a form which is far more acceptable than the one produced by the default settings. I encourage you to experiment with various combinations while this information is fresh in your mind; PAUSE; OFF LIST, RAT, DIV, GCD, FLOAT; ON ALLFAC, MCD, EXP; COMMENT You may have wondered whether or not an assignment to a variable, say F1, automatically updates the value of a bound variable, say G1, which was previously assigned an expression containing F1. The answer is: 1. If F1 was a bound variable in the expression when it was set to G1, then subsequent changes to the value of F1 have no effect on G1 because all traces of F1 in G1 disappeared after F1 contributed its value to the formation of G1. 2. If F1 was an indeterminate in an expression previously assigned to G1, then for each subsequent use of G1, F1 contributes its current value at the time of that use. These phenomena are illustrated by the following sequence:; PAUSE; F2 := F; G1 := F1 + F2; F2 := G; G1; F1 := G; F1 := H; G1; F1 := G; G1; COMMENT Experience indicates that it is well worth studying this sequence and experimenting with others until these phenomena are thoroughly understood. You might, for example, mimic the above example, but with another level of evaluation included by inserting a statement analogous to "Q9:=G1" after "F2:=G", and inserting an expression analogous to "Q9" at the end, to compare with G1. ; PAUSE; COMMENT Note also, that if an indeterminant is used directly, or indirectly through another expression, in evaluating itself, this will lead to an infinite recursion. For example, the following expression results in infinite recursion at the first evaluation of H1. On some machines (Vax/Unix, IBM) this will cause REDUCE to terminate abnormally. H1 := H1 + 1 You may experiment with this problem, later at your own risk. It is often desirable to make an assignment to an indeterminate in a previously established expression have a permanent effect, as if the assignment were done before forming the expression. This can be done by using the substitute function, SUB. G1 := F1 + F2; H1 := SUB(F1=H, G1); F1 := G; H1; COMMENT Note the use of "=" rather than ":=" in SUB. This function is also valuable for achieving the effect of a local assignment within a subexpression, without binding the involved indeterminate or functional form in the rest of the expression or wherever else it occurs. More generally the SUB function can have any number of equations of the form "indeterminate or functional form = expression", separated by commas, before the expression which is its last argument. Try devising a set of examples which reveals whether such multiple substitutions are done left to right, right to left, in parallel, or unpredictably. This is the end of lesson 2. To execute lesson 3, start a fresh REDUCE job. ;END; |
Added r30/less3 version [29c2261ad3].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 3 David R. Stoutemyer University of Hawaii COMMENT This is lesson 3 of 7 REDUCE lessons. Please refrain from using variables beginning with the letters F through H during the lesson. Mathematics is replete with many named elementary and not-so- elementary functions besides the set built into REDUCE such as SIN, COS, and LOG, and it is often convenient to utilize expressions containing a functional form such as f(x) to denote an unknown function or a class of functions. Functions are called operators in REDUCE, and by merely declaring their names as such, we are free to use them for functional forms. For example; OPERATOR F; G1 := F(F(COT(F)), F()); COMMENT Note that 1. We can use the same name for both a variable and an operator. (However, this practice often leads to confusion.) 2. We can use the same operator for any number of arguments -- including zero arguments such as for F(). 3. We can assign values to specific instances of functional forms; PAUSE; COMMENT COT is one of the functions already defined in REDUCE together with a few of its properties. However, the user can augment or even override these definitions depending on the needs of a given problem. For example, if one wished to write COT(F) in terms of TAN, one could say; COT(F) := 1/TAN(F); G1 := G1 + COT(H+1); PAUSE; COMMENT Naturally, our assignment for COT(F) did not affect COT(H+1) in our example above. However, we can use a LET rule to make all cotangents automatically be replaced by the reciprocal of the corresponding tangents:; FOR ALL F LET COT(F) = 1/TAN(F); G1; COMMENT Any variable designated "FOR ALL" is a dummy variable which is distinct from any other previously or subsequently introduced indeterminate, variable, or dummy variable having the same name outside the rule. To clear a LET rule having dummy variables, the CLEAR command must employ the same dummy variables; FOR ALL F CLEAR COT(F); COT(G+5); PAUSE; COMMENT The arguments of a functional form on the left-hand side of a LET rule can be more complicated than mere indeterminates. For example, we may wish to inform REDUCE how to differentiate expressions involving SEC, which is not defined in the basic system; OPERATOR SEC; FOR ALL G1 LET DF(SEC(G1),G1) = SEC(G1)*TAN(G1); DF(3*SEC(F*G), G); COMMENT Also, REDUCE obviously knows the chain rule because otherwise we would have had to type FOR ALL Y,X LET DF(SEC(Y),X)=SEC(Y)*TAN(Y)*DF(Y,X); PAUSE; COMMENT As another example, suppose that we wish to employ the angle-sum identities for SIN and COS; FOR ALL X, Y LET SIN(X+Y) = SIN(X)*COS(Y) + SIN(Y)*COS(X), COS(X+Y) = COS(X)*COS(Y) - SIN(X)*SIN(Y); COS(5+F-G); COMMENT Note that: 1. LET can have any number of replacement rules separated by commas. 2. There was no need for rules with 3 or more addends, because the above rules were automatically employed recursively, with two of the three addends 5, F, and -G grouped together as one of the dummy variables the first time through. 3. Despite the subexpression F-G in our example, there was no need to make rules for the difference of two angles, because subexpressions of the form X-Y are treated as X+(-Y). 4. Built-in rules were employed to convert expressions of the form SIN(-X) or COS(-X) to -SIN(X) or COS(X) respectively. As an exercise, try to implement rules which transform the logarithms of products and quotients respectively to sums and differences of logarithms, while converting the logarithm of a power of a quantity to the power times the logarithm of the quantity; PAUSE; COMMENT Actually, the left-hand side of a LET rule also can be somewhat more general than a functional form. The left-hand side can be a power of an indeterminate or of a functional form, or the left- hand side can be a product of such powers and/or indeterminates or functional forms. For example, we can have the rule "FOR ALL X LET SIN(X)**2=1-COS(X)**2", or we can have the rule; FOR ALL X LET COS(X)**2 = 1 - SIN(X)**2; G1 := COS(F)**3 + COS(G); PAUSE; COMMENT Note that a replacement takes place wherever a left-hand side of a rule divides a term. With a rule replacing SIN(X)**2 and a rule replacing COS(X)**2 simultaneously in effect, an expression which uses either one will lead to an infinite recursion that eventually exhausts the available storage. (Try it if you wish -- after the lesson). We are also permitted to employ a more symmetric rule using a top level "+" provided that no free variables appear in the rule. However, a rule such as "FOR ALL X LET SIN(X)**2+COS(X)**2=1" is not permitted. We can get around the restriction against a top-level "+" on the left side though, at the minor nuisance of having to employ an operator whenever we want the rule applied to an expression:; FOR ALL X CLEAR COS(X)**2; OPERATOR TRIGSIMP; FOR ALL A, C, X LET TRIGSIMP(X) = X, TRIGSIMP(A*SIN(X)**2 + A*COS(X)**2 + C) = A + TRIGSIMP(C), TRIGSIMP(A*SIN(X)**2 + A*COS(X)**2) = A, TRIGSIMP(SIN(X)**2 + COS(X)**2 + C) = 1 + TRIGSIMP(C), TRIGSIMP(SIN(X)**2 + COS(X)**2) = 1; G1 := F*COS(G)**2 + F*SIN(G)**2 + G*SIN(G)**2 + G*COS(G)**2 + 5; G1 := TRIGSIMP(G1); PAUSE; COMMENT Why doesn't our rule TRIGSIMP(X)=X defeat the other more specific ones? The reason is that rules are applied in a last-in-first-applied order, with the whole process immediately restarted whenever any rule succeeds. Thus the rule TRIGSIMP(X)=X, intended to make the operator TRIGSIMP eventually evaporate, is tried only after all of the genuine simplification rules have done all that they can. For such reasons we usually write rules for an operator in an order which proceeds from the most general to the most specific cases. Experimentation will reveal that TRIGSIMP will not simplify higher powers of sine and cosine, such as COS(X)**4 + 2*COS(X)**2*SIN(X)**2 + SIN(X)**4, and that TRIGSIMP will not necessarily work when there are more than 6 terms. This latter restriction is not fundamental but is a practical one imposed to keep the combinatorial searching associated with the current algorithm under reasonable control. As an exercise, see if you can generalize the rules sufficiently so that 5*COS(H)**2+6*SIN(H)**2 simplifies to 5 + SIN(H)**2 or to 6-COS(H)**2; PAUSE; COMMENT LET rules do not need to have a "FOR ALL" prefix. For example, we could introduce the simplification rule "LET E**(I*PI)=-1". As another example, we might wish to replace all subsequent instances of M*C**2 by ENERGY; CLEAR M, C, ENERGY; LET M*C**2 = ENERGY; G1 := 3*M**2*C**2 + M*C**3 + C**2 + M + M*C + M1*C1**2; PAUSE; COMMENT Suppose that instead we wish to replace M by ENERGY/C**2:; CLEAR M*C**2; LET M = ENERGY/C**2; G1; COMMENT Without the CLEAR M*C**2, the subsequent statements would have produced an infinite recursion. You may wonder how a LET rule of the trivial form "LET indeterminate = ..." differs from the corresponding assignment "indeterminate := ...". The difference is 1. The LET rule does not replace any contained bound variables with their values until the rule is actually used for a replacement. 2. The LET rule performs the evaluation of any contained bound variables every time the rule is used. Thus, the rule "LET X = X + 1" would cause infinite recursion at the first subsequent occurrence of X, as would the pair of rules "LET X=Y" and "LET Y=X". (Try it! -- after the lesson.) To illustrate point 1 above, compare the following sequence with the analogous earlier one in lesson 2 using assignments throughout; CLEAR E1, F; E2:= F; LET F1 = E1 + E2; F1; E2 := G; F1; PAUSE; COMMENT For a subsequent example, we need to replace E**(I*X) by COS(X)**2 + I*SIN(X)**2 for all X. See if you can successfully introduce this rule; PAUSE; E**I; COMMENT REDUCE does not match I as an instance of the pattern I*X with X=1, so if you neglected to include a rule for this degenerate case, do so now; PAUSE; CLEAR X, N, NMINUS1; ZERO := E**(N*I*X) - E**(NMINUS1*I*X)*E**(I*X); REALZERO := SUB(I=0, ZERO); IMAGZERO := SUB(I=0, -I*ZERO); COMMENT Regarding the last two assignments as equations, we can solve them to get recurrence relations defining SIN(N*X) and COS(N*X) in terms of angles having lower multiplicity. Can you figure out why I didn't use N-1 rather than NMINUS1 above? Can you devise a similar technique to derive the angle-sum identities that we previously implemented?; PAUSE; COMMENT To implement a set of trigonometric multiple-angle expansion rules, we need to match the patterns SIN(N*X) and COS(N*X) only when N is an integer exceeding 1. We can implement one of the necessary rules as follows; FOR ALL N,X SUCH THAT NUMBERP N AND N>1 LET COS(N*X) = COS(X)*COS((N-1)*X) - SIN(X)*SIN((N-1)*X); COMMENT Note: 1. In a conditional LET statement, any dummy variables should appear in the preceding FOR ALL clause. 2. NUMBERP, standing for NUMBER Predicate, is a built-in function which yields true if and only if its argument is an integer or a floating-point number. In lesson 6 we will learn how to write such a function exclusively for integers, so until then our multiple-angle rules should not be used under the influence of ON FLOAT. 3. Arbitrarily-complicated true-false conditions can be composed using the relational operators =, NEQ, <, >, <=, >=, together with the logical operators "AND", "OR", "NOT". 4. Operators < and > work only when both sides are integers or floating-point numbers. Moreover, = together with NEQ check only whether or not the two sides appear identical under the influence of whatever rules and computational flags are in effect. For example, (X-1)/(X+1)=(X**2-2*X+1)/(X**2-1) will yield false under the influence of OFF GCD. Operator <= works only in circumstances where < or = would work, and similarly for >=. Consequently, it is usually advisable to compare the difference in two expressions with 0, which forces a certain amount of algebraic simplification. 5. The relational operators have higher precedence than "NOT", which has higher precedence than "AND", which has higher precedence than "OR". 6. In a sequence of items joined by "AND" operators, testing is done left to right, and testing is discontinued after the first item which is false. 7. In a sequence of items joined by "OR" operators, testing is done left to right, and testing is discontinued after the first item which is true. 8. We didn't actually need the "AND N>1" part in the above rule Can you guess why? Your mission is to complete the set of multiple-angle rules and to test them on the example COS(4*X) + COS(X/3) + COS(F*X); PAUSE; COMMENT Now suppose that we wish to write a set of rules for doing symbolic integration, such that expressions of the form INTEGRATE(X**P,X) are replaced by X**(P+1)/(P+1) for arbitrary X and P, provided P is independent of X. This will of course be less complete that the analytic integration package available with REDUCE, but for specific classes of integrals it is often a reasonable way to do such integration. Noting that DF(P,X) is 0 if P is independent of X, we can accomplish this as follows; OPERATOR INTEGRATE; FOR ALL P,X SUCH THAT DF(P,X)=0 LET INTEGRATE(X**P,X) = X**(P+1)/(P+1); INTEGRATE(F**5,F); INTEGRATE(G**G, G); INTEGRATE(F**G,F); G1 := INTEGRATE(G*F**5,F) + INTEGRATE(F**5+F**G,F); COMMENT The last example indicates that we must incorporate rules which distribute integrals over sums and extract factors which are independent of the second argument of INTEGRATE. Can you think of LET rules which accomplish this? It is a good exercise, but this particular pair of properties of INTEGRATE is so prevalent in mathematics that operators with these properties are called linear, and a corresponding declaration is built into REDUCE; LINEAR INTEGRATE; G1; G1:= INTEGRATE(F+1,F) + INTEGRATE(1/F**5,F); PAUSE; COMMENT We overcame one difficulty and uncovered 3 others. Clearly REDUCE does not regard F to match the pattern F**P as F**1, or 1 to match the pattern as F**0, or 1/F**5 to match the pattern as F**(-1), so we can add additional rules for such cases; FOR ALL P,X SUCH THAT DF(P,X)=0 LET INTEGRATE(1/X**P,X) = X**(1-P)/(1-P); FOR ALL X LET INTEGRATE(X,X) = X**2/2, INTEGRATE(1,X) = X; G1; COMMENT A remaining problem is that INTEGRATE(X**-1,X) will lead to X**0/(-1+1), which simplifies to 1/0, which will cause a zero-divide error message. Consequently, we should also include the correct rule for this special case; FOR ALL X LET INTEGRATE(X**-1,X) = LOG(X); INTEGRATE(1/X,X); COMMENT This is the end of lesson 3. We leave it as an intriguing exercise to extend this integrator. ;END; |
Added r30/less4 version [d6cbd09664].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 4 David R. Stoutemyer University of Hawaii COMMENT This is lesson 4 of 7 REDUCE lessons. As before, please refrain from using variables beginning with the letters F through H during the lesson. In theory, assignments and LET statements are sufficient to accomplish anything that any other practical computing mechanism is capable of doing. However, it is more convenient for some purposes to use function procedures which can employ branched selection and iteration as do most traditional programming languages. As a trivial example, if we invariably wanted to replace cotangents with the corresponding tangents, we could type; ALGEBRAIC PROCEDURE COT(X); 1/TAN(X); COMMENT As an example of the use of this function, we have; COT(LOG(F)); COMMENT Note: 1. The procedure definition automatically declares the procedure name as an operator. 2. A procedure can be executed any time after its definition, until it is cleared. 3. Any parameters are dummy variables that are distinct from any other variables with the same name outside the procedure definition, and the corresponding arguments can be arbitrary expressions. 4. The value returned by a procedure is the value of the expression following the procedure statement. We can replace this definition with a different one; ALGEBRAIC PROCEDURE COT(Y); COS(Y)/SIN(Y); G1:= COT(LOG(F)); COMMENT In place of the word ALGEBRAIC, we can optionally use the word INTEGER when a function always returns an integer value, or we can optionally use the word REAL when a function always returns a floating-point value. Try writing a procedure definition for the sine in terms of the cosine, then type G1; PAUSE; COMMENT Here is a more complicated function which introduces the notion of a conditional expression; ALGEBRAIC PROCEDURE SUMCHECK(AJ, J, M, N, S); COMMENT J is an indeterminate and the other parameters are expressions. This function returns the global variable named PROVED if the function can inductively verify that S equals the sum of AJ for J going from M through N, returning the global variable named UNPROVED otherwise. For the best chance of proving a correct sum, the function should be executed under the influence of ON EXP, ON MCD, and any other user-supplied simplification rules relevant to the expression classes of AJ and S; IF SUB(J=M,AJ)-SUB(N=M,S) NEQ 0 OR S+SUB(J=N+1,AJ)-SUB(N=N+1,S) NEQ 0 THEN UNPROVED ELSE PROVED; ON EXP, MCD; CLEAR X, J, N; SUMCHECK(J, J, 1, N, N*(N+1)/2); SUMCHECK(X**J, J, 0, N, (X**(N+1)-1)/(X-1)); COMMENT Within procedures of this sort a global variable is any variable which is not one of the parameters, and a global variable has the value, if any, which is current for that name at the point from where the procedure is used. Conditional expressions have the form IF condition THEN expression1 ELSE expression2. There are generally several equivalent ways of writing a conditional expression. For example, the body of the above procedure could have been written IF SUB(J=M,A)-SUB(N=M,S)=0 AND S+SUB(J=N+1,A)-SUB(N=N+1,S)=0 THEN PROVED ELSE UNPROVED. Note how we compare a difference with 0, rather than comparing two nonzero expressions, for reasons explained in lesson 3. As an exercise, write a procedure analogous to SUMCHECK for proving closed-form product formulas, then test it on the valid formula that COS(N*X) equals the product of COS(J*X)/COS(J*X-X) for J ranging from 1 through N. You do not need to include prefatory comments describing parameters and the returned value until you learn how to use a text editor; PAUSE; COMMENT Most REDUCE statements are also expressions because they have a value. The value is usually 0 if nothing else makes sense, but I will mention the value only if it is useful. The value of an assignment statement is the assigned value. Thus a multiple assignment, performed right to left, can be achieved by a sequence of the form "variable1 := variable2 := ... := variableN := expression", moreover, assignments can be inserted within ordinary expressions such as X*(Y:=5). Such assignments must usually be parenthesized because of the low precedence of the assignment operator, and excessive use of this construct tends to make programs confusing. REDUCE treats as a single expression any sequence of statements preceded by the pair of adjacent characters << and followed by the pair >>. The value of such a group expression is the value of the last statement in the group. Group expressions facilitate the implementation of tasks that are most easily stated as a sequence of operations. However, such sequences often utilize temporary variables to count, hold intermediate results, etc., and it is hazardous to use global variables for that purpose. If a top-level REDUCE statement or another function directly or indirectly uses that variable name, then its value or its virgin indeterminate status there might be damaged by our use as a temporary variable. In large programs or programs which rely on the work of others, such interference has a nonnegligible probability, even if all programmers agree to the convention that all such temporary variables should begin with the function name as a prefix and all programmers attempt to comply with the convention. For this reason, REDUCE provides another expression-valued sequence called a BEGIN-block, which permits the declaration of local variables that are distinct from any other variables outside the block having the same name. Another advantage of using local variables for temporary variables is that the perhaps large amount of storage occupied by their values can be reclaimed after leaving their block. A BEGIN-block consists of the word BEGIN, followed by optional declarations, followed by a sequence of statements, followed by the word END. As a convenience, any text from the word END to the next statement separator, >>, END, ELSE, or UNTIL is a comment. Within BEGIN-blocks, it is often convenient to return control and a value from someplace other than the end of the block rather than have the value be that of the last statement. Consequently, control and a value must be returned via a RETURN-statement or the form RETURN expression or RETURN, 0 being returned in the latter case. These features and others are illustrated by the following function; PAUSE; ALGEBRAIC PROCEDURE LIMIT(EX, INDET, PNT); BEGIN COMMENT This function uses up through 4 iterations of L'Hospital's rule to attempt determination of the limit of expression EX as indeterminate INDET approaches expression PNT. This function is intended for the case where SUB(INDET=PNT, EX) yields 0/0, provoking a zero-divide message. This function returns the global variable named UNDEFINED when the limit is 0 dividing an expression which did not simplify to 0, and this function returns the global variable named UNKNOWN when it cannot determine the limit. Otherwise this function returns an expression which is the limit. For best results, this function should be executed under the influence of ON EXP, ON MCD, and any user-supplied simplification rules appropriate to the expression classes of EX and PNT; INTEGER ITERATION; SCALAR N, D, NLIM, DLIM; ITERATION := 0; N := NUM(EX); D := DEN(EX); NLIM := SUB(INDET=PNT, N); DLIM := SUB(INDET=PNT, D); WHILE NLIM=0 AND DLIM=0 AND ITERATION<5 DO << N := DF(N, INDET); D := DF(D, INDET); NLIM := SUB(INDET=PNT, N); DLIM := SUB(INDET=PNT, D); ITERATION := ITERATION + 1 >>; RETURN (IF NLIM=0 THEN IF DLIM=0 THEN UNKNOWN ELSE 0 ELSE IF DLIM=0 THEN UNDEFINED ELSE NLIM/DLIM) END; % Examples follow.. PAUSE; G1 := (E**X-1)/X; % Evaluation at 0, causes zero divide prompt at top level, continue % anyway. SUB(X=0, G1); LIMIT(G1, X, 0); G1:= ((1-X)/LOG(X))**2; % Evaluation at 1, causes zero divide prompt at top level, continue % anyway. SUB(X=1, G1); LIMIT(G1, X, 1); COMMENT Note: 1. The idea behind L'Hospital's rule is that as long as the numerator and denominator are both zero at the limit point, we can replace them by their derivatives without altering the limit of the quotient. 2. Assignments within groups and BEGIN-blocks do not automatically cause output. 3. Local variables are declared INTEGER, REAL, or SCALAR, the latter corresponding to the same most general class denoted by ALGEBRAIC in a procedure statement. All local variables are initialized to zero, so they cannot serve as indeterminates. Moreover, if we attempted to overcome this by clearing them, we would clear all variables with their names. 4. We do not declare the attributes of parameters. 5. The NUM and DEN functions respectively extract the numerator and denominator of their arguments. (With OFF MCD, the denominator of 1+1/X would be 1.) 6. The WHILE-loop has the general form WHILE condition DO statement. REDUCE also has a "GO TO" statement, and using commas rather than semicolons to prevent termination of this comment, the above general form of a WHILE-loop is equivalent to BEGIN GO TO TEST, LOOP: statement, TEST: IF condition THEN GO TO LOOP, RETURN 0 END . A GOTO statement is permitted only within a block, and the GOTO statement cannot refer to a label outside the same block or to a label inside a block that the GOTO statement is not also within. Actually, 99.99% of REDUCE BEGIN-blocks are less confusing if written entirely without GOTOs, and I mention them primarily to explain WHILE-loops in terms of a more primitive notion. 7. The LIMIT function provides a good illustration of nested conditional expressions. Proceeding sequentially through such nests, each ELSE clause is matched with the nearest preceding unmatched THEN clause in the group or block. In order to help reveal their structure, I have consistently indented nested conditional statements, continuations of multi-line statements and loop-bodies according to one of the many staunchly defended indentation styles. However, older versions of REDUCE may ruin my elegant style. If you have such a version, I encourage you to indent nonetheless, in anticipation of a replacement for your obsolete version. (If you have an instructor, I also urge you to humor him by adopting his style for the duration of the course.) 8. PL/I programmers take note: "IF ... THEN ... ELSE ..." is regarded as one expression, and semicolons are used to separate rather than terminate statements. Moreover, BEGIN and END are brackets rather than statements, so a semicolon is never needed immediately after BEGIN, and a semicolon is necessary immediately preceding END only if the END is intended as a labeled destination for a GOTO. Within conditional expressions, an inappropriate semicolon after an END, a >>, or an ELSE-clause is likely to be one of your most prevalent mistakes.; PAUSE; COMMENT The next exercise is based on the above LIMIT function: For the sum of positive expressions AJ for J ranging from some finite initial value to infinity, the infinite series converges if the limit of the ratio SUB(J=J+1,AJ)/AJ is less than 1 as J approaches infinity. The series diverges if this limit exceeds 1, and the test is inconclusive if the limit is 1. To convert the problem to the form required by the above LIMIT program, we can replace J by the indeterminate 1/!*FOO in the ratio, then take the limit as !*FOO approaches zero. (Since an indeterminate is necessary here, I picked the weird name !*FOO to make the chance of conflict negligible) After writing such a function to perform the ratio test, test it on the examples AJ=J/2**J, AJ=1/J**2, AJ=2**J/J**10, and AJ=1/J. (The first two converge and the second two diverge); PAUSE; COMMENT Groups or blocks can be used wherever any arbitrary expression is allowed, including the right-hand side of a LET rule. The need for loops with an integer index variable running from a given initial value through a given final value by a given increment is so prevalent that REDUCE offers a convenient special way of accomplishing it via a FOR-loop, which has the general form FOR index := initial STEP increment UNTIL final DO statement . Except for the use of commas as statement separators, this construct is equivalent to BEGIN INTEGER index, index := initial, IF increment>0 THEN WHILE index <= final DO << statement, index := index + increment >> ELSE WHILE index >= final DO << statement, index := index + increment >>, RETURN 0 END . Note: 1. The index variable is automatically declared local to the FOR- loop. 2. "initial", "increment", and "final" must have integer values. 3. FORTRAN programmers take note: the body of the loop is not automatically executed at least once. 4. An acceptable abbreviation for "STEP 1 UNTIL" is ":". 5. Since the WHILE-loop and the FOR-loop have implied BEGIN- blocks, a RETURN statement within their bodies cannot transfer control further than the point following the loops. Another frequent need is to produce output from within a group or block, because such output is not automatically produced. This can be done using the WRITE-statement, which has the form WRITE expression1, expression2, ..., expressionN. Beginning a new line with expression1, the expressions are printed immediately adjacent to each other, split over line boundaries if necessary. The value of the WRITE-statement is the value of its last expression, and any of the expressions can be a character-string of the form "character1 character2 ... characterM" . Inserting the word "WRITE" on a separate line before an assignment is convenient for debugging, because the word is then easily deleted afterward. These features and others are illustrated by the following equation solver; ARRAY CF(2); OPERATOR SOLVEFOR, SOLN; FOR ALL X, LHS, RHS LET SOLVEFOR(X, LHS, RHS) = SOLVEFOR(X, LHS-RHS); COMMENT LHS and RHS are expressions such that P=NUM(LHS-RHS) is a polynomial of degree at most 2 in the indeterminate or functional form X. Otherwise an error message is printed. As a convenience, RHS can be omitted if it is 0. If P is quadratic in X, the two values of X which satisfy P=0 are stored as the values of the functional forms SOLN(1) and SOLN(2). If P is a first-degree polynomial in X, SOLN(1) is set to the one solution. If P simplifies to 0, SOLN(1) is set to the identifier ARBITRARY. If P is an expression which does not simplify to zero but does not contain X, SOLN(1) is set to the identifier NONE. In all other cases, SOLN(1) is set to the identifier UNKNOWN. The function then returns the number of SOLN forms which were set. This function prints a well deserved warning message if the denominator of LHS-RHS contains X. This function also uses the global array CF as temporary storage. If LHS-RHS is not polynomial in X, it is wise to execute this function under the influence of ON GCD; FOR ALL X, LHSMRHS LET SOLVEFOR(X, LHSMRHS) = BEGIN INTEGER HIPOW; SCALAR TEMP; IF LHSMRHS = 0 THEN << SOLN(1) := ARBITRARY; RETURN 1 >>; HIPOW := COEFF(LHSMRHS, X, CF); IF HIPOW = 0 THEN << SOLN(1) := NONE; RETURN 1 >>; IF HIPOW > 2 THEN << SOLN(1) := UNKNOWN; RETURN 1 >>; IF HIPOW = 1 THEN << SOLN(1) := -CF(0)/CF(1); IF DF(SUB(X=!*FOO, SOLN(1)), !*FOO) NEQ 0 THEN SOLN(1) := UNKNOWN; RETURN 1 >>; CF(0) := CF(0)/CF(2); CF(1) := -CF(1)/CF(2)/2; IF DF(SUB(X=!*FOO, CF(0)), !*FOO) NEQ 0 OR DF(SUB(X=!*FOO, CF(1)), !*FOO) NEQ 0 THEN << SOLN(1) := UNKNOWN; RETURN 1 >>; TEMP := (CF(1)**2 - CF(0))**(1/2); SOLN(1) := CF(1) + TEMP; SOLN(2) := CF(1) - TEMP; RETURN 2 END; FOR K:=1:SOLVEFOR(X, A*X**2, -B*X-C) DO WRITE SOLN(K) := SOLN(K); FOR K:=1:SOLVEFOR(LOG(X), 5*LOG(X)-7) DO WRITE SOLN(K) := SOLN(K); FOR K:=1:SOLVEFOR(X, X, X) DO WRITE SOLN(K) := SOLN(K); FOR K:= 1:SOLVEFOR(X, 5) DO WRITE SOLN(K) := SOLN(K); FOR K:=1:SOLVEFOR(X, X**3+X+1) DO WRITE SOLN(K) := SOLN(K); FOR K:=1:SOLVEFOR(X, X*E**X, 1) DO WRITE SOLN(K) := SOLN(K); G1 := X/(E**X-1); FOR K:=1:SOLVEFOR(X, G1) DO WRITE SOLN(K) := SOLN(K); SUB(X=SOLN(1), G1); LIMIT(G1, X, SOLN(1)); COMMENT Here we have used LET rules to permit the user the convenience of omitting default arguments. (Function definitions have to have a fixed number of parameters.) Array elements are designated by the same syntax as matrix elements and as functional forms having integer arguments. Here are some desiderata that may help you decide which of these alternatives is most appropriate for a particular application: 1. The lower bound of each array subscript is 0, vs 1 for matrices vs unrestricted for functional forms. 2. The upper bound of each array subscript must have a specific integer value at the time the array is declared, as must the upper bounds of matrix subscripts when a matrix is first referred to, on the left side of a matrix assignment. In contrast, functional forms never require a commitment to a specific upper bound. 3. An array can have any fixed number of subscripts, a matrix must have exactly 2, and a functional form can have a varying arbitrary number. 4. Matrix operations, such as transpose and inverse, are built-in only for matrices. 5. For most implementations, access to array elements requires time approximately proportional to the number of subscripts, whereas access to matrix elements takes time approximately proportional to the sum of the two subscript values, whereas access to functional forms takes average time approximately proportional to the number of bound functional forms having that name. 6. Only functional forms permit the effect of a subscripted indeterminate such as having an answer be "A(M,N) + B(3,4)". 7. All arrays, matrices, and operators are global regardless of where they are declared, so declaring them within a BEGIN block does not afford the protection and automatic storage recovery of local variables. Moreover, clearing them within a BEGIN-block will clear them globally, and functions cannot return an array or a matrix value. Furthermore, REDUCE parameters are value-type parameters, which means that an assignment to a parameter has no effect on the corresponding argument. Thus, matrix or array results cannot be transmitted back to an argument either. 8. It is often advantageous to use two or more of these alternatives to represent a set of quantities at different times in the same program. For example, to get the general form of the inverse of a 3-by-3 matrix, we could write MATRIX AA, OPERATOR A, AA := MAT((0,0,0),(0,0,0),(0,0,0)), FOR J:=1:3 DO FOR K:=1:3 DO AA(J,K) := A(J,K), AA**-1 . As another example, we might use an array to receive some polynomial coefficients, then transfer the values to a matrix for inversion. The COEFF function is the remaining new feature in our SOLVEFOR example. The first argument is a polynomial expression in the indeterminate or functional form which is the second argument, and the third argument is a singly-subscripted array-name or an array cross-section for receiving the polynomial coefficients of the integer powers which correspond to their subscripts. An array cross-section is a multiply-subscripted array-reference with an asterisk as one subscript and specific integer values as the others. Examples are Q(5,*) which indicates the fifth row of Q, and Q(*,5) which indicates the fifth column of Q. Alternatively, the third argument of COEFF can be an indeterminate, in which case nonzero coefficients are assigned to indeterminates with names constructed by concatenating the integer power, as a suffix, to the given indeterminate. For example; CLEAR C,X; COEFF(X**5+2, X, C); PAUSE; COMMENT This technique is usually more convenient when COEFF is used interactively at the top level, whereas the array technique is usually more convenient when COEFF is used indirectly within a group or block. COEFF returns the highest subscript or suffix for which it made an assignment. COEFF does not check to make sure that the coefficients do not contain its second argument within a functional form, so that is the reason we differentiated. The reason we first substituted the indeterminate !*FOO for the second argument is that differentiation does not work with respect to a functional form. The last exercise is to rewrite the last rule so that we can solve equations which simplify to the form a*x**(m+2*l) + b*x**(m+l) + c*x**m = 0, where m>=0 and l>=1. The solutions are 0, with multiplicity m, x1*E**(2*j*I*pi/l), x2*E**(2*j*I*pi/l), with j = 0, 1, ..., l-1, where x1 and x2 are the solutions to the quadratic equation a*x**2 + b*x + c = 0 . As a convenience to the user, you might also wish to have a global flag named SOLVEPRINT, such that when it is nonzero, the solutions are automatically printed. This is the end of lesson 4. When you are ready to run lesson 5, start a new REDUCE job. ;END; |
Added r30/less5 version [36810f37fe].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 5 David R. Stoutemyer University of Hawaii COMMENT This is lesson 5 of 7 REDUCE lessons. There are at least two good reasons for wanting to save REDUCE expression assignments on secondary storage: 1. So that one can logout, then resume computation at a later time. 2. So that needed storage space can be cleared without irrecoverably losing the values of variables which are not needed in the next expression but will be needed later. Using trivial small expressions, the following sequence illustrates how this could be done: OFF NAT, OUT TEMP, F1 := (F + G)**2, G1 := G*F1, OUT T, CLEAR F1, H1 := H*G1, OUT TEMP, CLEAR G1, H2 := F*H1, CLEAR H1, SHUT TEMP, IN TEMP, F1, ON NAT, F1 . ON NAT yields the natural output style with raised exponents, which is unsuitable for subsequent input. The OUT-statement causes subsequent output to be directed to the file named in the statement, until overridden by a different OUT-statement or until the file is closed by a SHUT-statement. File T is the terminal, and any other name designates a file on secondary storage. Such names must comply with the local file-naming conventions as well as with the REDUCE syntax. If the output is not of lasting importance, I find that including something like "TEMPORARY" or "SCRATCH" in the name helps remind me to delete it later. Successive OUT-statements to the same file will append rather than overwrite output if and only if there is no intervening SHUT- statement for that file. The SHUT-statement also has the effect of an implied OUT T. Note: 1. The generated output is the simplified expression rather than the raw form entered at the terminal. 2. Each output assignment automatically has a dollar-sign appended so that it is legal input and so that (perhaps lengthy) output will not unavoidably be generated at the terminal when the file is read in later. 3. Output cannot be sent simultaneously to 2 or more files. 4. Statements entered at the terminal which do not generate output -- such as declarations, LET rules, and procedure definitions -- do not appear in the secondary storage file. 5. One could get declarations, procedure definitions, rules, etc. written on secondary storage from the terminal by typing statements such as WRITE " ALGEBRAIC PROCEDURE ... ... " . This could serve as a means of generating permanent copies of LET rules, procedures, etc., but it is quite awkward compared with the usual way, which is to generate a file containing the REDUCE program by using a text editor, then load the program by using the IN-statement. If you have refrained from learning a local text editor and the operating- system file-management commands, hesitate no longer. A half dozen of the most basic commands will enable you to produce (and modify!) programs more conveniently than any other method. To keep from confusing the editor from REDUCE, I suggest that your first text-editing exercise be a letter to me: David R. Stoutemyer Electrical Engineering Department University of Hawaii Honolulu, Hawaii 96822 . Tell me your suggestions for improving this set of lessons. 5. The reason I didn't actually execute the above sequence of statements is that when the input to REDUCE comes from a batch file, both the input and output are sent to the output file, (which is convenient for producing a file containing both the input and output of a demonstration.) Consequently, you would have seen none of the statements between the "OUT TEMP" and "OUT T" as well as between the second "OUT TEMP" and the "SHUT TEMP", until the IN statement was executed. The example is confusing enough without having things scrambled from the order you would type them. To clarify all of this, I encourage you to actually execute the above sequence, with an appropriately chosen file name and using semicolons rather than commas. Afterwards, to return to the lesson, type CONT; PAUSE; COMMENT Suppose you and your colleagues developed or obtained a set of REDUCE files containing supplementary packages such as trigono- metric simplification, Laplace transforms, etc. It would be a waste of time (and perhaps paper) to have these files printed at the terminal every time they were loaded, so this printing can be suppressed by inserting the statement "OFF ECHO" at the beginning of the file, together with the statement "ON ECHO" at the end of the file. The lessons have amply demonstrated the PAUSE-statement, which is useful for insertion in batch files at the top-level or within functions when input from the user is necessary or desired. It often happens that after generating an expression, one decides that it would be convenient to use it as the body of a function definition, with one or more of the indeterminates therein as parameters. This can be done as follows; (1-(V/C)**2)**(1/2); FOR ALL V SAVEAS F(V); F(5); COMMENT Alternatively, we can use SAVEAS to save the previous expression as an indeterminate; SAVEAS FOF5; FOF5; COMMENT I find this technique more convenient than referring to the special variable WS; PAUSE; COMMENT The FOR-loop provides a convenient way to form finite sums or products with specific integer index limits. However, this need is so ubiquitous that REDUCE provides even more convenient syntax of the forms FOR index := initial STEP increment UNTIL final SUM expression, FOR index := initial STEP increment UNTIL final PRODUCT expression. As before, ":" is an acceptable abbreviation for "STEP 1 UNTIL". As an example of their use, here is a very concise definition of a function which computes Taylor-series expansions of symbolic expressions:; ALGEBRAIC PROCEDURE TAYLOR(EX, X, PT, N); COMMENT This function returns the degree N Taylor-series expansion of expression EX with respect to indeterminate X, expanded about expression PT. For a series-like appearance, display the answer under the influence of FACTOR X, ON RAT, and perhaps also ON DIV; SUB(X=PT, EX) + FOR K:=1:N SUM(SUB(X=PT, DF(EX,X,K))*(X-PT)**K / FOR J:=1:K PRODUCT J); CLEAR A, X; FACTOR X; ON RAT, DIV; G1 := TAYLOR(E**X, X, 0, 4); G2 := TAYLOR(E**COS(X)*COS(SIN(X)), X, 0, 3); TAYLOR(LOG(X), X, 0, 4); COMMENT It would, of course, be more efficient to compute each derivative and factorial from the preceding one. (Similarly for (X-PT)**K if and only if PT NEQ 0). The Fourier series expansion of our example E**COS(X)*COS(SIN(X)) is 1 + cos(x) + cos(2*x)/2 + cos(3*x)/(3*2) + ... . Use the above SUM and PRODUCT features to generate the partial sum of this series through terms of order COS(6*X); PAUSE; COMMENT Closed-form solutions are often unobtainable for nontrivial problems, even using computer algebra. When this is the case, truncated symbolic series solutions are often worth trying before resorting to approximate numerical solutions. When we combine truncated series it is pointless (and worse yet, misleading) to retain terms of higher order than is justified by the constituents. For example, if we wish to multiply together the truncated series G1 and G2 generated above, there is no point in retaining terms higher than third degree in X. We can avoid even generating such terms as follows; LET X**4 = 0; G3 := G1*G2; COMMENT Replacing X**4 with 0 has the effect of also replacing all higher powers of X with 0. We could, of course, use our TAYLOR function to compute G3 directly, but differentiation is time consuming compared to truncated polynomial algebra. Moreover, our TAYLOR function requires a closed-form expression to begin with, whereas iterative techniques often permit us to construct symbolic series solutions even when we have no such closed form. Now consider the truncated series; CLEAR Y; FACTOR Y; H1 := TAYLOR(COS Y, Y, 0, 6); COMMENT Suppose we regard terms of order X**N in G1 as being comparable to terms of order Y**(2*N) in H1, and we want to form (G1*H1)**2. This can be done as follows; LET Y**7 = 0; F1 := (G1*H1)**2; COMMENT Note however that any terms of the form C*X**M*Y**N with 2*M+N > 6 are inconsistent with the accuracy of the constituent series, and we have generated several such misleading terms by independently truncating powers of X and Y. To avoid generating such junk, we can specify that a term be replaced by 0 whenever a weighted sum of exponents of specified indeterminates and functional forms exceeds a specified weight level. In our example this is done as follows; WEIGHT X=2, Y=1; WTLEVEL 6; F1 := F1; COMMENT variables not mentioned in a WEIGHT declaration have a weight of 0, and the default weight-level is 2; PAUSE; COMMENT In lesson 2 I promised to show you ways to overcome the lack in most REDUCE implementations of automatic numerical techniques for approximating fractional powers and transcendental functions of numerical values. One way is to provide a supplementary LET rule for numerical arguments. For example, since our TAYLOR function would reveal that the Taylor series for cos x is 1 - x**2/2! + x**4/4! - ...; FOR ALL X SUCH THAT NUMBERP X LET ABS(X)=X,ABS(-X)=X; EPSRECIP := 1024 $ ON FLOAT; WHILE 1.0 + 1.0/EPSRECIP NEQ 1.0 DO EPSRECIP := EPSRECIP + EPSRECIP; FOR ALL X SUCH THAT NUMBERP NUM X AND NUMBERP DEN X LET COS X = BEGIN COMMENT X is integer, real, or a rational number. This rule returns the Taylor-series approximation to COS X, truncated when the last included term is less than (1/EPSRECIP) of the returned answer. EPSRECIP is a global variable initialized to a value that is appropriate to the local floating-point precision. Arbitrarily larger values are justifiable when X is exact and FLOAT is off. No angle reduction is performed, so this function is not recommended for ABS(X) >= about PI/2; INTEGER K; SCALAR MXSQ, TERM, ANS; K := 1; MXSQ := -X*X; TERM := MXSQ/2; ANS := TERM + 1; WHILE ABS(NUM TERM)*EPSRECIP*DEN(ANS)-ABS(NUM ANS)*DEN(TERM)>0 DO << TERM:= TERM*MXSQ/K/(K+1); ANS:= TERM + ANS; K := K+2 >>; RETURN ANS END; COS(F) + COS(1/2); OFF FLOAT; COS(1/2); COMMENT As an exercise, write a similar rule for the SIN or LOG, or replace the COS rule with an improved one which uses angle reduction so that angles outside a modest range are represented as equivalent angles within the range, before computing the Taylor series; PAUSE; COMMENT There is a REDUCE compiler, and you may wish to learn the local incantations for using it. However, even if rules such as the above ones are compiled, they will be slow compared to the implementation-dependent hand-coded ones used by most FORTRAN-like systems, so REDUCE provides a way to generate FORTRAN programs which can then be compiled and executed in a subsequent job step. This is useful when there is a lot of floating-point computation or when we wish to exploit an existing FORTRAN program. Suppose, for example, that we wish to utilize an existing FORTRAN subroutine which uses the Newton-Rapheson iteration Xnew := Xold - SUB(X=Xold, F(X)/DF(F(X),X)) to attempt an approximate solution to the equation F(X)=0. Most such subroutines require the user to provide a FORTRAN function or subroutine which, given Xold, returns F(X)/DF(F(X),X) evaluated at X=Xold. If F(X) is complicated, manual symbolic derivation of DF(F(X),X) is a tedious and error-prone process. We can get REDUCE to relieve us of this responsibility as is illustrated below for the trivial example F(X) = X*E**X - 1: ON FORT, FLOAT, OUT FONDFFILE, WRITE " REAL FUNCTION FONDF(XOLD)", WRITE " REAL XOLD, F", F := XOLD*E**XOLD - 1.0, FONDF := F/DF(F,XOLD), WRITE " RETURN", WRITE " END", SHUT FONDFFILE . COMMENT Under the influence of ON FORT, the output generated by assignments is printed as valid FORTRAN assignment statements, using as many continuation lines as necessary up to the amount specified by the global variable !*CARDNO, which is initially set to 20. The output generated by an expression which is not an assignment is a corresponding assignment to a variable named ANS. In either case, expressions which would otherwise exceed !*CARDNO continuation lines are evaluated piecewise, using ANS as an intermediate variable. Try executing the above sequence, using an appropriate filename and using semicolons rather than commas at the end of the lines, then print the file after the lesson to see how it worked; PAUSE; OFF FORT, FLOAT; COMMENT To make this technique usable by non-REDUCE programmers, we could write a more general REDUCE program which given merely the expression F by the user, outputs not only the function FONDF, but also any necessary Job-control commands and an appropriate main program for calling the Newton-Rapheson subroutine and printing the results. Sometimes it is desirable to modify or supplement the syntax of REDUCE. For example: 1. Electrical engineers may prefer to input J as the representation of (-1)**(1/2). 2. Many users may prefer to input LN to denote natural logarithms. 3. A user with previous exposure to the PL/I-FORMAC computer- algebra system might prefer to use DERIV instead of DF to request differentiation. 4. A macrophiliac might prefer to have N! followed by a blank always be replaced by the expression (FOR K:=1:N PRODUCT N). Such lexical macros can be established by the DEFINE declaration:; CLEAR X,J,N; %Define for 1:N causes a prompt for an unbound ID. Continue anyway. DEFINE J=I, LN=LOG, DERIV=DF, N! =(FOR K:=1:N PRODUCT K); COMMENT Now watch!; N := 3; G1 := SUB(X=LN(J**3*X), DERIV(X**2,X)/N! ); COMMENT Each "equation" in a DEFINE declaration must be of the form "name = item", where each item is an expression, an operator, or a REDUCE-reserved word such as "FOR". Such replacements take place during the lexical scanning, before any evaluation, LET rules, or built-in simplification. Think of a good application for this facility, then try it; PAUSE; COMMENT When REDUCE is being run in batch mode, it is preferable to have REDUCE make reasonable decisions and proceed when it encounters apparently undeclared operators, divisions by zero, etc. In interactive mode, it is preferable to pause and query the user. ON INT specifies the latter style, and OFF INT specifies the former. Under the influence of OFF INT, we can also have most error messages suppressed by specifying OFF MSG. This is sometimes useful when we expect abnormal conditions and do not want our listing marred by the associated messages. INT is automatically turned off during input from a batch file in response to an IN-command from a terminal. Some implementations permit the user to dynamically request more storage by executing a command of the form CORE number, where the number is an integer specifying the total desired core in some units such as bytes, words, kilobytes, or kilowords; PAUSE; COMMENT Some implementations have a trace command for debugging, which employs the syntax TR functionname1, functionname2, ..., functionnameN . An analogous command named UNTR removes function names from trace status; PAUSE; COMMENT Some implementations have an assignment-tracing command for debugging, which employs the syntax TRST functionname1, functionname2, ..., functionnameN. An analogous command named UNTRST removes functionnames from this status. All assignments in the designated functions are reported, except for assignments to array elements. Such functions must be uncompiled and must have a top-level BEGIN-block. To apply both TRST and TR to a function simultaneously, it is crucial to request them in that order, and it is necessary to relinquish the two kinds of tracing in the opposite order; PAUSE; COMMENT The REDUCE algebraic algorithms are written in a subset of REDUCE called RLISP. In turn, the more sophisticated features of RLISP are written in a small subset of RLISP which is written in a subset of LISP that is relatively common to most LISP systems. RLISP is ideal for implementing algebraic algorithms, but the RLISP environment is not most suitable for the routine use of these algorithms in the natural mathematical style of the preceding lessons. Accordingly, REDUCE jobs are initially in a mode called ALGEBRAIC, which provides the user with the environment illustrated in the preceding lessons, while insulating him from accidental interaction with the numerous functions, global variables, etc. necessary for implementing the built-in algebra. In contrast, the underlying RLISP system together with all of the algebraic simplification algorithms written therein is called SYMBOLIC mode. As we have seen, algebraic-mode rules and procedures can be used to extend the built-in algebraic capabilities. However, some extensions can be accomplished most easily or efficiently by descending to SYMBOLIC mode. To make REDUCE operate in symbolic mode, we merely execute the top level mode-declaration statement consisting of the word SYMBOLIC. We can subsequently switch back by executing the statement consisting of the word ALGEBRAIC. RLISP has the semantics of LISP with the syntax of our by-now-familiar algebraic-mode REDUCE, so RLISP provides a natural tool for many applications besides computer algebra, such as games, theorem-proving, natural-language translation, computer-aided instruction, and artificial intelligence in general. For this reason, it is possible to run RLISP without any of the symbolic-mode algebraic algorithms that are written in RLISP, and it is advisable to thus save space when the application does not involve computer algebra. We have now discussed virtually every feature that is available in algebraic mode, so lesson 6 will deal solely with RLISP, and lesson 7 will deal with communication between ALGEBRAIC and SYMBOLIC mode for mathematical purposes. However, I suggest that you proceed to those lessons only if and when: 1. You have consolidated and fully absorbed the information in lessons 1 through 5 by considerable practice beyond the exercises therein. (The exercises were intended to also suggest good related project ideas.) 2. You feel the need for a facility which you believe is impossible or quite awkward to implement solely in ALGEBRAIC mode. 3. You have read the pamphlet "Introduction to LISP", by D. Lurie, or an equivalent. 4. You are familiar with definition of Standard LISP, as described in the "Standard LISP Report" which was published in the October 1979 SIGPLAN Notices. Remember, when you decide to take lesson 6, it is better to do so from a RLISP job than from a REDUCE job. Also, don't forget to print your newly generated FORTRAN file and to delete any temporary files created by this lesson. ;END; |
Added r30/less6 version [eb1f7dac42].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 6 David R. Stoutemyer University of Hawaii COMMENT This is lesson 6 of 7 REDUCE lessons. A prerequisite is to read the phamphlet "An Introduction to LISP", by D. Lurie'. To avoid confusion between RLISP and the SYMBOLIC-mode algebraic algorithms, this lesson will treat only RLISP. Lesson 7 deals with how the REDUCE algebraic mode is implemented in RLISP and how the user can interact directly with that implementation. That is why I suggested that you run this lesson in RLISP rather than full REDUCE. If you forgot or do not have a locally available separate RLISP, then please switch now to symbolic mode by typing the statement SYMBOLIC; PAUSE; COMMENT Your most frequent mistakes are likely to be forgetting to quote data examples, using commas as separators within lists, and not puting enough levels of parentheses in your data examples. Now that you have learned from your reading about the built-in RLISP functions CAR, CDR, CONS, ATOM, EQ, NULL, LIST, APPEND, REVERSE, DELETE, MAPLIST, MAPCON, LAMBDA, FLAG, FLAGP, PUT, GET, DEFLIST, NUMBERP, ZEROP, ONEP, AND, EVAL, PLUS, TIMES, CAAR, CADR, etc., here is an opportunity to reinforce the learning by practice.: Write expressions using CAR, CDR, CDDR, etc., (which are defined only through 4 letters between C and R), to individually extract each atom from F, where; F := '((JOHN . DOE) (1147 HOTEL STREET) HONOLULU); PAUSE; COMMENT My solutions are CAAR F, CDAR F, CAADR F, CADADR F, CADDR CADR F, and CADDR F. Although commonly the "." is only mentioned in conjunction with data, we can also use it as an infix alias for CONS. Do this to build from F and from the data 'MISTER the s-expression consisting of F with MISTER inserted before JOHN.DOE; PAUSE; COMMENT My solution is ('MISTER . CAR F) . CDR F . Enough of these inane exercises -- let's get on to something useful! Let's develop a collection of functions for operating on finite sets. We will let the elements be arbitrary s-expressions, and we will represent a set as a list of its elements in arbitrary order, without duplicates. Here is a function which determines whether its first argument is a member of the set which is its second element; SYMBOLIC PROCEDURE MEMBERP(ELEM, SET1); COMMENT Returns T if s-expression ELEM is a top-level element of list SET1, returning NIL otherwise; IF NULL SET1 THEN NIL ELSE IF ELEM = CAR SET1 THEN T ELSE MEMBERP(ELEM, CDR SET1); MEMBERP('BLUE, '(RED BLUE GREEN)); COMMENT This function illustrates several convenient techniques for writing functions which process lists: 1. To avoid the errors of taking the CAR or the CDR of an atom, and to build self confidence while it is not immediately apparent how to completely solve the problem, treat the trivial cases first. For an s-expression or list argument, the most trivial cases are generally when one or more of the arguments are NIL, and a slightly less trivial case is when one or more is an atom. (Note that we will get an error message if we use MEMBERP with a second argument which is not a list. We could check for this, but in the interest of brevity, I will not strive to make our set-package give set-oriented error messages.) 2. Use CAR to extract the first element and use CDR to refer to the remainder of the list. 3. Use recursion to treat more complicated cases by extracting the first element and using the same functions on smaller arguments.; PAUSE; COMMENT To make MEMBERP into an infix operator we make the declaration; INFIX MEMBERP; '(JOHN.DOE) MEMBERP '((FIG.NEWTON) FONZO (SANTA CLAUS)); COMMENT Infix operators associate left, meaning expressions of the form (operator1 operator operand2 operator ... operandN) are interpreted as ((...(operand1 operator operand2) operator ... operandN). Operators may also be flagged RIGHT by FLAG ('(op1 op2 ...), 'RIGHT) . to give the interpretation (operand1 operator (operand2 operator (... operandN))...). Of the built-in operators, only ".", "*=", "+", and "*" associate right. If we had made the infix declaration before the function definition, the latter could have begun with the more natural statement SYMBOLIC PROCEDURE ELEM MEMBERP SET . Infix functions can also be referred to by functional notation if one desires. Actually, an analogous infix operator named MEMBER is already built-into RLISP, so we will use MEMBER rather than MEMBERP from here on; MEMBER(1147, CADR F); COMMENT Inspired by the simple yet elegant definition of MEMBERP, write a function named SETP which uses MEMBER to check for a duplicate element in its list argument, thus determining whether or not the argument of SETP is a set; PAUSE; COMMENT My solution is; SYMBOLIC PROCEDURE SETP CANDIDATE; COMMENT Returns T if list CANDIDATE is a set, returning NIL otherwise; IF NULL CANDIDATE THEN T ELSE IF CAR CANDIDATE MEMBER CDR CANDIDATE THEN NIL ELSE SETP CDR CANDIDATE; SETP '(KERMIT, (COOKIE MONSTER)); SETP '(DOG CAT DOG); COMMENT If you used a BEGIN-block, local variables, loops, etc., then your solution is surely more awkward than mine. For the duration of the lesson, try to do everything without groups, BEGIN-blocks, local variables, assignments, and loops. Everything can be done using function composition, conditional expressions, and recursion. It will be a mind-expanding experience -- more so than transcendental meditation, psilopsybin, and EST. Afterward, you can revert to your old ways if you disagree. Thus endeth the sermon. Incidentally, to make the above definition of SETP work for non-list arguments all we have to do is insert "ELSE IF ATOM CANDIDATE THEN NIL" below "IF NULL CANDIDATE THEN T". Now try to write an infix procedure named SUBSETOF, such that SET1 SUBSETOF SET2 returns NIL if SET1 contains an element that SET2 does not, returning T otherwise. You are always encouraged, by the way, to use any functions that are already builtin, or that we have previously defined, or that you define later as auxiliary functions; PAUSE; COMMENT My solution is; INFIX SUBSETOF; SYMBOLIC PROCEDURE SET1 SUBSETOF SET2; IF NULL SET1 THEN T ELSE IF CAR SET1 MEMBER SET2 THEN CDR SET1 SUBSETOF SET2 ELSE NIL; '(ROOF DOOR) SUBSETOF '(WINDOW DOOR FLOOR ROOF); '(APPLE BANANA) SUBSETOF '((APPLE COBBLER) (BANANA CREME PIE)); COMMENT Two sets are equal when they have identical elements, not necessarily in the same order. Write an infix procedure named EQSETP which returns T if its two operands are equal sets, returning NIL otherwise; PAUSE; COMMENT The following solution introduces the PRECEDENCE declaration; INFIX EQSETP; PRECEDENCE EQSETP, =; PRECEDENCE SUBSETOF, EQSETP; SYMBOLIC PROCEDURE SET1 EQSETP SET2; SET1 SUBSETOF SET2 AND SET2 SUBSETOF SET1; '(BALLET TAP) EQSETP '(TAP BALLET); '(PINE FIR ASPEN) EQSETP '(PINE FIR PALM); COMMENT The precedence declarations make SUBSETOF have a higher precedence than EQSETP and make the latter have higher precedence than "=", which is higher than "AND",. Consequently, these declarations enabled me to omit parentheses around "SET1 SUBSUBSETOF SET2" and around "SET2 SUBSETOF SET1". All prefix operators are higher than any infix operator, and to inspect the ordering among the latter, we merely inspect the value of the global variable named; PRECLIS!*; COMMENT Now see if you can write a REDUCE infix function named PROPERSUBSETOF, which determines if its left operand is a proper subset of its right operand, meaning it is a subset which is not equal to the right operand; PAUSE; COMMENT All of the above exercises have been predicates. In contrast, the next exercise is to write a function called MAKESET, which returns a list which is a copy of its argument, omitting duplicates; PAUSE; COMMENT How about; SYMBOLIC PROCEDURE MAKESET LIS; IF NULL LIS THEN NIL ELSE IF CAR LIS MEMBER CDR LIS THEN MAKESET CDR LIS ELSE CAR LIS . MAKESET CDR LIS; COMMENT As you may have guessed, the next exercise is to implement an operator named INTERSECT, which returns the intersection of its set operands; PAUSE; COMMENT Here is my solution; INFIX INTERSECT; PRECEDENCE INTERSECT, SUBSETOF; SYMBOLIC PROCEDURE SET1 INTERSECT SET2; IF NULL SET1 THEN NIL ELSE IF CAR SET1 MEMBER SET2 THEN CAR SET1 . CDR SET1 INTERSECT SET2 ELSE CDR SET1 INTERSECT SET2; COMMENT Symbolic-mode REDUCE has a built-in function named SETDIFF, which returns the set of elements which are in its first argument but not the second. See if you can write an infix definition of a similar function named DIFFSET; PAUSE; COMMENT Presenting --; INFIX DIFFSET; PRECEDENCE DIFFSET, INTERSECT; SYMBOLIC PROCEDURE LEFT DIFFSET RIGHT; IF NULL LEFT THEN NIL ELSE IF CAR LEFT MEMBER RIGHT THEN CDR LEFT DIFFSET RIGHT ELSE CAR LEFT . (CDR LEFT DIFFSET RIGHT); '(SEAGULL WREN CONDOR) DIFFSET '(WREN LARK); COMMENT The symmetric difference of two sets is the set of all elements which are in only one of the two sets. Implement a corresponding infix function named SYMDIFF. Look for the easy way! There is almost always one for examinations and instructional exercises; PAUSE; COMMENT Presenting --; INFIX SYMDIFF; PRECEDENCE SYMDIFF, INTERSECT; SYMBOLIC PROCEDURE SET1 SYMDIFF SET2; APPEND(SET1 DIFFSET SET2, SET2 DIFFSET SET1); '(SEAGULL WREN CONDOR) SYMDIFF '(WREN LARK); COMMENT We can use APPEND because the two set differences are disjoint. The above set of exercises (exercises of set?) have all returned set results. The cardinality, size, or length of a set is the number of elements in the set. More generally, it is useful to have a function which returns the length of its list argument, and such a function is built-into RLISP. See if you can write a similar function named SIZEE; PAUSE; COMMENT Presenting --; SYMBOLIC PROCEDURE SIZEE LIS; IF NULL LIS THEN 0 ELSE 1 + SIZEE CDR LIS; SIZEE '(HOW MARVELOUSLY CONCISE); SIZEE '(); COMMENT Literal atoms, meaning atoms which are not numbers, are stored uniquely in LISP and in RLISP, so comparison for equality of literal atoms can be implemented by comparing their addresses, which is significantly more efficient than a character-by-character comparison of their names. The comparixon operator "EQ" compares addresses, so it is the most efficient choice when comparing only literal atoms. The assignments N2 := N1 := 987654321, S2 := S1 := '(FROG (SALAMANDER.NEWT)), make N2 have the same address as N1 and make S2 have the same address as S1, but if N1 and N2 were constructed independently, they would not generally have the same address, and similarly for S1 vs S2. The comparison operator "=", which is an alias for "EQUAL", does a general test for identical s-expressions, which need not be merely two pointers to the same address. Since "=" is built-in, compiled, and crucial, I will define my own differently-named version denoted ".=" as follows:; NEWTOK '((!.!=) MYEQUAL); INFIX MYEQUAL; PRECEDENCE MYEQUAL, EQUAL; SYMBOLIC PROCEDURE S1 MYEQUAL S2; IF ATOM S1 THEN IF ATOM S2 THEN S1 EQATOM S2 ELSE NIL ELSE IF ATOM S2 THEN NIL ELSE CAR S1 MYEQUAL CAR S2 AND CDR S1 MYEQUAL CDR S2; SYMBOLIC PROCEDURE A1 EQATOM A2; IF NUMBERP A1 THEN IF NUMBERP A2 THEN ZEROP(A1-A2) ELSE NIL ELSE IF NUMBERP A2 THEN NIL ELSE A1 EQ A2; COMMENT Here I introduced a help function named EQATOM, because I was beginning to become confused by detail when I got to the line which uses EQATOM. Consequently, I procrastinated on attending to some fine detail by relegating it to a help function which I was confident could be successfully written later. After completing MYEQUAL, I was confident that it would work provided EQATOM worked, so I could then turn my attention entirely to EQATOM, freed of further distraction by concern about the more ambitious overall goal. It turns out that EQATOM is a rather handy utility function anyway, and practice helps develop good judgement about where best to so subdivide tasks. This psychological divide-and-conquer programming technique is important in most other programming languages too. ".=" is differnt from our previous examples in that ".=" recurses down the CAR as well as down the CDR of an s-expression; PAUSE; COMMENT If a list has n elements, our function named MEMBERP or the equivalent built-in function named MEMBER requires on the order of n "=" tests. Consequently, the above definitions of SETP and MAKESET, which require on the order of n membership tests, will require on the order of n**2 "=" tests. Similarly, if the two operands have m and n elements, the above definitions of SUBSETOF, EQSETP, INTERSECT, DIFFSET, and SYMDIFF require on the order of m*n "=" tests. We could decrease the growth rates to order of n and order of m+n respectively by sorting the elements before giving lists to these functions. The best algorithms sort a list of n elements in the order of n*log(n) element comparisons, and this need be done only once per input set. To do so we need a function which returns T if the first arguemtn is "=" to the second argument or should be placed to the left of the second argument. Such a function, named ORDP, is already built-into symbolic-mode REDUCE, based on the following rules: 1. Any number orders left of NIL. 2. Larger numbers order left of smaller numbers. 4. Literal atoms order left of numbers. 3. Literal atoms order among themselves by address, as determined by the built-in RLISP function named ORDERP. 5. Non-atoms order left of atoms. 6. Non-atoms order among themselves according to ORDP of their CARs, with ties broken according to ORDP of their CDRs. Try writing an analogous function named MYORD, and, if you are in REDUCE rather than RLISP, test its behaviour in comparison to ORDP; PAUSE; COMMENT Whether or not we use sorted sets, we can reduce the proportionality constant associated with the growth rate by replacing "=" by "EQ" if the set elements are restricted to literal atoms. However, with such elements we can use property-lists to achieve the growth rates of the sorted algorithms without any need to sort the sets. On any LISP system that is efficient enough to support REDUCE with acceptable performance, the time required sto access a property of an atome is modest and very insensitive to the number of distinct atoms in the program and data. Consequently, the basic technique for any of our set operations is: 1. Scan the list argument or one of the two list arguments, flagging each element as "SEEN". 2. During the first scan, or during a second scan of the same list, or during a scan of the second list, check each element to see whether or not it has already been flagged, and act accordingly. 3. Make a final pass through all elements which were flagged to remove the flag "SEEN". (Otherwise, we may invalidate later set operations which utilize any of the same atoms.) We could use indicators rather than flags, but the latter are slightly more efficient when an indicator would have only one value (such as having "SEEN" as the value of an indicator named "SEENORNOT"). As an example, here is INTERSECT defined using this technique; SYMBOLIC PROCEDURE INTERSECT(S1, S2); BEGIN SCALAR ANS, SET2; FLAG(S1, 'SEEN); SET2 := S2; WHILE SET2 DO << IF FLAGP(CAR SET2, 'SEEN) THEN ANS := CAR SET2 . ANS; SET2 := CDR SET2 >>; REMFLAG(S1, 'SEEN); RETURN ANS END; COMMENT Perhaps you noticed that, having used a BEGIN-block, group, loop, and assignments, I have not practiced what I preached about using only function composition, conditional expressions, and recursion during this lesson. Well, now that you have had some exposure to both extremes, I think you should always fairly consider both together with appropriate compromises, in each case choosing whatever is most clear, concise, and natural. For set operations based on the property-list approach, I find the style exemplified immediately above most natural. As your last exercise for this lesson, develop a file containing a package for set operations based upon either property-lists or sorting. This is the end of lesson 6. When you are ready to run the final lesson 7, load a fresh copy of REDUCE. ;END; |
Added r30/less7 version [084109c012].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT REDUCE INTERACTIVE LESSON NUMBER 7 David R. Stoutemyer University of Hawaii COMMENT This is lesson 7 of 7 REDUCE lessons. It was suggested that you bring a REDUCE source listing, together with a cross-reference (CREF) thereof, but this lesson is beneficial even without them. Sometimes it is desired to have a certain facility available to algebraic mode, no such facility is described in the REDUCE User's manual, and there is no easy way to implement the facility directly in algebraic mode. The possibilities are: 1. The facility exists for algebraic mode, but is undocumented. 2. The facility exists, but is available only in symbolic mode. 3. The facility is not built-in for either mode. Perusal of the source listing and CREF, together with experimentation can reveal which of these alternatives is true. (Even in case 3, an inquiry to A.C. Hearn at the Rand Corporation may reveal that someone else has already implemented the supplementary facility and can send a copy.) ;PAUSE;COMMENT A type of statement is available to both modes if its leading keyword appears in either of the equivalent statements PUT (..., 'STAT, ...) or DEFLIST('(...), 'STAT) . A symbolic-mode global variable is available to algebraic mode and vice-versa if the name of the variable appears in either of the equivalent statements SHARE ..., or FLAG('(...), 'SHARE) . A function defined in symbolic mode is directly available to algebraic mode if the function name appears in one of the statements SYMBOLIC OPERATOR ..., PUT(..., 'SIMPFN, ...), DEFLIST('(...), 'SIMPFN), FLAG('(...), 'OPFUN), FLAG('(...), 'DIRECT). Only in the latter case can the function be used as a predicate for use in IF or WHILE statements. ;PAUSE;COMMENT Other functions which are used but not defined in RLISP are the built-in LISP functions. See a description of the underlying LISP system for documentation on these functions. Particularly notable built-in features available only to symbolic mode include 1. A predicate named FIXP which returns NIL if its argument is not an integer, returning T otherwise. 2. A function named FIX, which returns the truncated integer portion of its floating-point argument. 3. A function named SPACES, which prints the number of blanks indicated by its integer argument. 4. A function named REDERR, which provokes an error interrupt after printing its arguments. 5. A predicate named KERNP, which returns NIL if its argument is not an indeterminate or a functional form. 6. A function named MATHPRINT, which prints its argument in natural mathematical notation, beginning on a new line. 7. A function named MAPRIN, which is like MATHPRINT, but does not automatically start or end a new line. 8. A function named TERPRI!*, which ends the current print-line. Thus, for example, all that we have to do to make the predicate FIXP and the function FIX available to algebraic mode is to type SYMBOLIC FLAG('(FIXP), 'DIRECT), SYMBOLIC OPERATOR FIX . When such simple remedies are unavailable, we can introduce our own statements or write our own SYMBOLIC-mode variables and procedures, then use these techniques to make them available to algebraic mode. In order to do so, it is usually necessary to understand how REDUCE represents and simplifies algebraic expressions. ;PAUSE;COMMENT One of the REDUCE representations is called Cambridge Prefix: An expression is either an atom or a list consisting of a literal atom, denoting a function or operator name, followed by arguments which are Cambridge Prefix expressions. The most common unary operator names are MINUS, LOG, SIN, and COS. The most common binary operator names are DIFFERENCE, QUOTIENT, and EXPT. The most common nary operator names are PLUS and TIMES. Thus, for example, the expression 3*x**2*y + x**(1/2) + e**(-x) could be represented as '(PLUS (TIMES 3 (EXPT X 2) Y) (EXPT X (QUOTIENT 1 2)) (EXPT E (MINUS X)) The parser produces an unsimplified Cambridge Prefix version of algebraic-mode expressions typed by the user, then the simplifier returns a simplified prefix version. When a symbolic procedure that has been declared a symbolic operator is invoked from algebraic mode, the procedure is given simplified Cambridge Prefix versions of the arguments. To illustrate these ideas, here is an infix function named ISFREEOF, which determines whether its left argument is free of the indeterminate, function name, or literal subexpression which is the right argument. This is similar to the REDUCE FREEOF function but less general; PAUSE;COMMENT SYMBOLIC FLAG('(ISFREEOF), 'DIRECT); INFIX ISFREEOF; SYMBOLIC PROCEDURE CAMPRE1 ISFREEOF CAMPRE2; IF CAMPRE1=CAMPRE2 THEN NIL ELSE IF ATOM CAMPRE1 THEN T ELSE (CAR CAMPRE1 ISFREEOF CAMPRE2) AND (CDR CAMPRE1 ISFREEOF CAMPRE2); ALGEBRAIC IF LOG(5+X+COS(Y)) ISFREEOF SIN(Z-7) THEN WRITE "WORKS ONE WAY"; ALGEBRAIC IF NOT(LOG(5+X+COS(Y)) ISFREEOF COS(Y)) THEN WRITE "WORKS OTHER WAY TOO"; COMMENT Conceivably we might wish to distinguish when CAMPRE2 is a literal atom occuring as a function name from the case when CAMPRE2 is a literal atom and occurs as an indeterminate. Accordingly, see if you can write two such more specialized infix predicates named ISFREEOFINDET and ISFREEOFFUNCTION; PAUSE; COMMENT When writing a symbolic-mode function, it is often desired to invoke the algebraic simplifier from within the function. This can be done by using the function named REVAL, which returns a simplified Cambridge Prefix version of its prefix argument. Usually, REDUCE uses and produces a different representation, which I call REDUCE prefix. The symbolic function AEVAL returns a simplified REDUCE-prefix version of its prefix argument. Both REVAL and AEVAL can take either type of prefix argument. A REDUCE-prefix expression is an integer, a floating-point number, an indeterminate, or an expression of the form ('!*SQ standardquotient . !*SQVAR!*). !*SQVAR!* is a global variable which is set to T when the REDUCE- prefix expression is originally formed. The values of !*SQVAR!* is reset to NIL if subsequent LET, MATCH, or computational ON statements could change the environment is such a way that the expression might require resimplification next time it is used. ;PAUSE;COMMENT Standard quotients are neither Cambridge nor REDUCE prefix, so the purpose of the atom '!*SQ is to make the value of all algebraic-mode variables always be some type of prefix form at the top level. A standard quotient is a unit-normal dotted pair of 2 standard forms, and a standard form is the REDUCE representation for a polynomial. Unit-normal means that the leading coefficient of the denominator is positive. REDUCE has a built-in symbolic function SIMP!*, which returns the simplified standard quotient representation of its argument, which can be either Cambridge or REDUCE prefix. REDUCE also has symbolic functions named NEGSQ, INVSQ, ADDSQ, MULTSQ, DIVSQ, DIFFSQ, and CANONSQ which respectively negate, reciprocate, add, multiply, divide, differentiate, and unit-normalize standard quotients. There is also a function named ABSQ, which negates a standard quotient if the leading coefficient of its numerator is negative, and there is a function named EXPTSQ which raises a standard quotient to an integer power. Finally, there is a function named MK!*SQ, which returns a REDUCE prefix version of its standard-quotient argument, and there is also a function named PREPSQ which returns a Cambridge prefix version of its standard-quotient argument. If there is a sequence of operations, rather than converting from prefix to standard quotient and back at each step, it is usually more efficient to do the operations on standard quotients, then use MK!*SQ to make the final result be REDUCE prefix. Also it is often more efficient to work with polynomials rather than rational functions during the intermediate steps. ;PAUSE;COMMENT The coefficient domain of polynomials is floating-point numbers, integers, integers modulo an arbitrary integer modulus, or rational numbers. However, zero is represented as NIL. The polynomial variables are called kernels, which can be indeterminates or uniquely-stored fully simplified Cambridge-prefix functional forms. The latter alternative permits the representation of expressions which could not otherwise be represented as the ratio of two expanded polynomials, such as 1. subexpressions of the form LOG(...) or SIN(...). 2. subexpressions of the form indeterminate**noninteger. 3. unexpanded polynomials, each polynomial factor being represented as a functional form. 4. rational expressions not placed over a common denominator, each quotient subexrpession being represented as a functional form. A polynomial is represented as a list of its nonzero terms in decreasing order of the degree of the leading "variable". Each term is represented as a standard power dotted with its coefficient, which is a standard form in the remaining variables. A standard power is represented as a variable dotted with a positive integer degree. ;PAUSE;COMMENT Letting ::= denote "is defined as" and letting | denote "or", we can summarize the REDUCE data representations as follows: reduceprefix ::= ('!*SQ standardquotient . !*SQVAR!*) standardquotient ::= NUMR(standardquotient) ./ DENR(standardquotient) NUMR(standardquotient) ::= standardform DENR(standardquotient) ::= unitnormalstandardform domainelement ::= NIL | nonzerointeger | nonzerofloat | nonzerointeger . positiveinteger standardform ::= domainelement | LT(standardform) .+ RED(standardform) RED(standardform) ::= standardform LT(standardform) := LPOW(standardform) .* LC(standardform) LPOW(standardform) := MVAR(standardform) .** LDEG(standardform) LC(standardform) ::= standardform MVAR(standardform) ::= kernel kernel ::= indeterminate | functionalform functionalform ::= (functionname Cambridgeprefix1 Cambridgeprefix2 ...) Cambridgeprefix ::= integer | float | indeterminate | functionalform LC(unitnormalstandardform) ::= positivedomainelement | unitnormalstandardform I have taken this opportunity to also introduce the major REDUCE selector macros named NUMR, DENR, LT, RED, LPOW, LC, MVAR, and LDEG, together with the major constructor macros named ./, .+, .*, and .** . The latter are just mnemonic aliases for "." A comparison of my verbal and more formal definitions also reveals that the selectors are respectively just aliases for CAR, CDR, CAR, CDR, CAAR, CDAR, CAAAR, and CDAAR. Since these selectors and constructors are macros rather than functions, they afford a more readable and modifiable programming style at no cost in ultimate efficiency. Thus you are encouraged to use them and to invent your own when convenient. As an example of how this can be done, here is the macro definition for extracting the main variable of a standard term; SYMBOLIC SMACRO PROCEDURE TVAR TRM; CAAR TRM; PAUSE; COMMENT It turns out that there are already built-in selectors named TC, TPOW, and TDEG, which respectively extract the coefficient, leading power, and leading degree of a standard term. There are also built-in constructors named !*P2F, !*K2F, !*K2Q, and !*T2Q, which respectively make a power into astandard form, a kernel into a standard form, a kernel into a standard quotient, and a term into a standard quotient. See the User's Manual for a complete list. The unary functions NEGF and ABSF respectively negate, and unit- normalize their standard-form arguments. The binary functions ADDF, MULTF, QUOTF, SUBF, EXPTF, and GCDF respectively add, multiply, divide, substitute into, raise to a positive integer power, and determine the greatest common divisor of standard forms. See if you can use them to define a macro which subtracts standard forms; PAUSE; COMMENT The best way to become adept at working with standard forms and standard quotients is to study the corresponding portions of the REDUCE source listing. The listing of ADDF and its subordinates is particularly instructive. As an exercise, see if you can write a function named ISFREEOFKERN which determines whether or not its left argument is free of the kernel which is the right argument, using REDUCE prefix rather than Cambridge prefix for the left argument; PAUSE; COMMENT As a final example of the interaction between modes, here is a function which produces simple print plots; SHARE NCOLSMINUS1; NCOLSMINUS1 := 66; SYMBOLIC OPERATOR PLOT; SYMBOLIC; PROCEDURE PLOT(EX, XINIT, DX, NDX, YINIT, DY); BEGIN COMMENT This procedure produces a print-plot of univariate expression EX, with its variable beginning at the number XINIT, and increasing by the number DX each line down for a total of integer NDX lines. The value of EX increases right by increments of number DY per column, beginning with the number YINIT at the left edge. The shared global variable named NCOLSMINUS1, initially 66, is 1 less than the number of columns used. Points are plotted using "*", except ">" is used at the right edge to indicate points further right, and "<" is used at the left edge to indicate points further left. Without supplementary rules, many REDUCE implementations will be unable to numerically evaluate expressions involving operations other than +, -, *, /, and integer powers; SCALAR X, FLOATSAV; INTEGER COL; FLOATSAV := !*FLOAT; ON FLOAT; X := LISTOFVARS EX; IF LENGTH X > 1 THEN REDERR "ERROR: 1st arg of PLOT can have at most 1 indeterminate"; IF NULL X THEN X := !/FOO ELSE X := CAR X; X := ERRORCATCH(FOR J:= 0:NDX DO << COL := ROUND REVAL((SUBST(X=XINIT+J*DX, EX) - YINIT)/DY); IF COL<0 THEN WRITE "<" ELSE IF COL > NCOLSMINUS1 THEN << SPACES(NCOLSMINUS1); PRINC ">"; TERPRI!*() >> ELSE << SPACES(COL); PRINC "*"; TERPRI!*() >> >> ); IF NULL FLOATSAV THEN OFF FLOAT; IF NULL X THEN REDERR "ERROR: UNABLE TO PERFORM FLOATING-POINT EVALUATION OF 1ST ARG" END; PAUSE; SYMBOLIC PROCEDURE LISTOFVARS CAMPRE; IF NULL CAMPRE OR NUMBERP CAMPRE THEN NIL ELSE IF ATOM CAMPRE THEN CAMPRE ELSE VARSINARGS CDR CAMPRE; SYMBOLIC PROCEDURE VARSINARGS LISTOFCAMPRE; IF NULL LISTOFCAMPRE THEN NIL ELSE UNION(LISTOFVARS CAR LISTOFCAMPRE, VARSINARGS CDR LISTOFCAMPRE); INTEGER PROCEDURE ROUND X; BEGIN SCALAR ANS, FLOATSAV; FLOATSAV := !*FLOAT; ON FLOAT; ANS := REVAL X; IF NOT NUMBERP X THEN REDDERR "ROUND GIVEN NON-NUMERIC ARGUMENT"; IF ANS >=0 THEN ANS := FIX(ANS+00.5) ELSE ANS:= FIX(ANS-0.5); IF NULL FLOATSAV THEN OFF FLOAT; RETURN ANS PLOT(X**2, 0, 0.025, 40, 0, 0.01); END; PAUSE; COMMENT We leave it as an exercise to write a more elaborate plot procedure which offers amenities such as automatic scaling, numbered ordinates, etc. In closing we suggest another exercise: The lack of lists together with operations of CAR, CDR, and "." are one of the major limitations of algebraic mode. Here is a start toward overcoming this limitation,. We leave the completion to you; ALGEBRAIC OPERATOR LIST; SYMBOLIC OPERATOR FIRSTT, REST, PRESERT; SYMBOLIC PROCEDURE FIRSTT LIS; IF ATOM LIS OR NOT(CAR LIS EQ 'LIST) THEN REDERR "FIRST MUST HAVE LIST ARGUMENT" ELSE CADR LIS; COMMENT Good luck with these exercises, with REDUCE, with computer algebra and with all of your endeavors. ;END; |
Added r30/lisp.mac version [d18f7bbc1c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 7470 7471 7472 7473 7474 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 9516 9517 9518 9519 9520 9521 9522 9523 9524 9525 9526 9527 | ;LISP.MAC, 9-Apr-81 21:51, Edit by FRICK ; ;NUMVAL redefined. It now gives error if given anything but INUM or FIXNUM. ;LISP.MAC, 26-Sep-80 10:44, Edit by FRICK ; ;%FSLID defined as support for PRELOAD facility. ;LISP.MAC, 25-Aug-80 12:06, Edit by FRICK ; ;Make ^Z comments work inside other comments. ;Corrected bug in initial dialogue. SYLO+1 is CAILE C,"z" instead ; of CAIG C,"z" ;<FRICK>LISP.MAC.28, 22-Nov-79 15:31:17, Edit by FRICK ; ;Define ERJMP for Tenex. Don't include RSCAN for Tenex. ;<FRICK>LISP.MAC.27, 21-Nov-79 11:21:50, Edit by FRICK ; ;Corrected bug in FUNARG. APFNG+6 is MOVN R,APFNG1 instead of HRRZ R,APFNG1. ;<FRICK>LISP.MAC.26, 13-Nov-79 19:48:53, Edit by FRICK ; ;Convert lower case to upper case on answer to start up questions ;<FRICK>LISP.MAC.24, 11-Nov-79 16:46:11, Edit by FRICK ; ;REMD now returns NIL or the removed type . function, as in Standard Lisp. ;Corrected bug in errormessage for index error in GETV, PUTV. ;PROG2 is again a defined function. ;<FRICK>LISP.MAC.20, 8-Nov-79 19:33:42, Edit by FRICK ; ;Added code for new FASLOD. Switches OFLD and NFLD controls assembling ; of new FASLOD and old FASLOAD. Both might be on at the same time. ;<FRICK>LISP.MAC.3, 1-Nov-79 16:26:25, Edit by FRICK ; ;For high core BPS in Tops-10 now computes start of high core. ; ;Fix bug in XEQ by guaranteeing 0 at end of RSCAN string. ;<FRICK>LISP.MAC.1, 28-Oct-79 16:06:56, Edit by FRICK ; ;An atom as first argument to FILEP means a filename for a file on DSK: ; with blank extension. ; ;XEQnow clears the terminal input buffer before simulating terminal ; input. ;<FRICK>LISP.MAC.4, 26-Oct-79 12:32:56, Edit by FRICK ; ;The charcters "+", "-" and "'" are now preceded by a "!" in PRIN1 and ; EXPLODE. ;<FRICK>LISP.MAC.2, 9-Oct-79 12:59:52, Edit by FRICK ; ;EOF is now signaled by returning the value of the interned id $EOF$. ;This value is originally the uninterned id $EOF$, but it can be ; changed. ; ;Cange of edit of 27-Mar-79. TYI (and READCH) now ignores null. ;<FRICK>LISP.MAC.16, 12-Sep-79 13:07:31, Edit by FRICK ; ;READ does now read negative bignums without dropping the minus sign ; ;When using high core in Tops-10, preserves high core data area. ;<FRICK>LISP.MAC.12, 16-Aug-79 16:13:29, Edit by FRICK ; ;BPS in high core now allowed also in Tops-10. ;Assembler switch SZBPS decides whether size of BPS is user settable. ;SZBPS is allways on if HCBPS is off. EXCORE only defined when SZBPS is ;on. ; ;Function EVLIS now defined. ;<FRICK>LISP.MAC.29, 2-Jul-79 15:11:01, Edit by FRICK ; ;Corrected bug in EQUAL so that EQUAL may return T for vectors. ;<FRICK>LISP.MAC.26, 15-Jun-79 19:08:49, Edit by FRICK ; ;The UUO handler changed to allow UUOs to be executed via a XCT. ;The MAPping functions have been changed to use this. ;<FRICK>LISP.MAC.19, 9-Jun-79 13:39:56, Edit by FRICK ; ;Included "T" and "?" in IDCHTAB. ;<FRICK>LISP.MAC.16, 29-May-79 18:40:20, Edit by FRICK ; ;Corrected error at XTYO so that character count now is reset at CR when ; echoing and TYO treats ascii 37 correctly. ;<FRICK>LISP.MAC.12, 23-May-79 23:07:49, Edit by FRICK ; ;The assembler switch APPL is defined. When on (off by default), EVAL ; return its arg when undefined function or unbound variable. ;<FRICK>LISP.MAC.11, 21-May-79 10:22:03, Edit by FRICK ; ;%SOSSWAP is now under assembler switch SOSSW that is off by default ;<FRICK>LISP.MAC.9, 17-May-79 15:29:09, Edit by FRICK ; ;%SOSSWAP and %SWAP only defined if OPSYS is > 0 (TENEX) ; ;If switch JSYXEQ is on then functions JSYS, %XEQ, ERRSTR and GETAB$ are defined ;<FRICK>LISP.MAC.7, 10-May-79 14:43:10, Edit by FRICK ; ;EOL conversion is now only done on input, not in READ0 routine used by ; COMPRESS or internal string reader READP1. ;The EOL conversion has further been changed so that CR, LF and FF are ; converted as follows: ; a CR is ignored if the next character is LF, FF or CRLF, ; a LF is converted to CRLF, ; a FF is converted to CRLF followed by FF. ;<FRICK>LISP.MAC.3, 4-May-79 18:12:32, Edit by FRICK ; ;Change unsafe BLT in ARGPDL ;<FRICK>LISP.MAC.16, 17-Apr-79 13:52:39, Edit by FRICK ;Call GET jsys as JSYS 200 to avoid name clash. Use SAV or EXE depending ; on OPSYS switch. ;<FRICK>LISP.MAC.15, 9-Apr-79 13:48:00, Edit by FRICK ; ;Removed <ht> in macro ML1 that gives problems in older MACRO versions ;<FRICK>LISP.MAC.14, 1-Apr-79 16:15:23, Edit by FRICK ; ;This file has been renumbered. ;<FRICK>LISP.MAC.13, 29-Mar-79 15:14:41, Edit by FRICK ; ;If the argument to FREEZE is true then the special stack is unbound ; to top level before halting. FREEZE checks if memory allocation is ; necessary when restarting if the argument is true. ;<FRICK>LISP.MAC.12, 27-Mar-79 18:00:20, Edit by FRICK ; ;The TYI routine now reads all characters exept ^Z but including % and ; null. This means that READCH reads % and null. ;<FRICK>LISP.MAC.5, 13-Mar-79 17:37:43, Edit by FRICK ; ;RDSLSH now knows about %. (RDSLSH T) sets % to be a normal letter, ; (RDSLSH NIL) sets % to be comment start. ;<FRICK>LISP.MAC.4, 12-Mar-79 16:31:30, Edit by FRICK ; ;Corrected bug in sixbit messages generated by prevoious edit, now ; generates EOL output again. ; ;*ECHO flag is now tested before *RAISE flag so that the status of ; *RAISE doesn't affect the echoed character. ; ;Corrected bug in MAPCAN, MAPCON: They now work also when NIL is ; returned as value by the applied function. ;<FRICK>LISP.MAC.26, 13-Feb-79 15:25:31, Edit by FRICK ; ;The character strings CR LF and CR FF are now replaced with the single ; character CRLF (ascii 37) in the routine TYID that does all input. ;CRLF is converted back to CR and LF in the internal routine TYO that ; does all output. The only exeption to this is the Lisp function TYO, ; (TYO 37) still will output a ascii 37. ;$EOL$ has as value the character id CRLF, so that READCH now returns ; the value of $EOL$ at end of line and PRINC $EOL$ is equivalent to ; TERPRI. ;SCAN now returns an interned character id in SCNVAL when seeing a ; delimiter. Because of this, UNTYI is replaced with UNREADCH that is ; similar but takes a character id as argument instead of ascii code. ; ;% now indicates start of a comment that ends with CRLF. Everything from ; % to (but not including) CRLF will be transparent to READ but not to ; READCH. SCAN has initially the same start and end of comment as READ ; and it will also not ignore the comment end character. As a consequence ; a comment can only be placed where a CRLF is legal. The special ; comment that starts with a ^Z and ends with CRLF does ignore the CRLF ; so that it can be placed anywhere. ; ;(AND) returns T. ;<FRICK>LISP.MAC.6, 31-Jan-79 14:03:36, Edit by FRICK ; ;READCH and EXPLODE are speeded up by maintaining an array of all ; interned character ids. This array is initially zero, but it is ; updated by INTERN and REMOB. ;<FRICK>LISP.MAC.4, 29-Jan-79 17:37:09, Edit by FRICK ; ;EXPLODE, READ (and COMPRESS) checks that they have the right scanner ; table and temporarily switches table if necessary. If an error occurs, ; this will leave the tables as if (SCANSET NIL) had been executed. ;<FRICK>LISP.MAC.1, 25-Jan-79 14:41:23, Edit by FRICK ; ;Corrected bug in EVAL when calling compiled EXPR with more than 5 args. ;<FRICK>LISP.MAC.13, 3-Jan-79 17:48:17, Edit by FRICK ; ;The use of L as indicator of octal numbers is now controlled by the ; switch ROCT. If ROCT is on then the change in edit of 26-Nov-78 is ; implemented, otherwise it is not. ; ;The symbol ILLAD is defined as the illegal address that generates a garbage ; collection. Setting it to 775777 (-2001) instead of 777777 (-1) seems to ; allewiate the problems mentioned in edit 25-Oct-78. For this reason ; CNSPRB is off by default in all versions of the system. ; ;The ^Z that indicates an ignored cr-lf is now not output if output is ; going to the terminal. ; ;The HALT that ended FREEZE in the Tops-10 version, is changed to EXIT 1, . ;<FRICK>LISP.MAC.7, 26-Nov-78 19:55:50, Edit by FRICK ; ;A number ended by the letter L, is read as an octal number also when ; the value of IBASE is not 8. When the value of BASE is 8, then end ; integers whith L when printed by PRIN1 but not when printed by PRIN2. ;<FRICK>LISP.MAC.1, 8-Nov-78 18:59:12, Edit by FRICK ; ;An atom as first argument to OPEN means a filename for a file on DSK: ; with blank extension. ;<FRICK>LISP.MAC.29, 3-Nov-78 17:15:24, Edit by FRICK ; ;Define SYM entry LMKSTR to make a Lisp string from top of SPDL ;<FRICK>LISP.MAC.28, 1-Nov-78 18:11:11, Edit by FRICK ; ;Make SETPCHAR return previous prompter as a non-interned identifier ;<FRICK>LISP.MAC.25, 25-Oct-78 19:10:13, Edit by FRICK ; ;Define an assembler switch CNSPRB, that when on will insert two instructions ; in the cons routine. These instructions will check explicitly for end ; of the free list instead of detecting the need for garbage collection ; by an illegal memory reference that occurs when the free list is empty. ; Explicit checking is slightly slower, but there seems to be some problems ; with the illegal memory reference mechanism on some virtual memory ; versions of the Tops-10 monitor. ;<FRICK>LISP.MAC.24, 26-Sep-78 16:38:51, Edit by FRICK ; ;Garbage collector now marks from reg REL also. ;<FRICK.SLSHEEP>LISP.MAC.2, 24-Sep-78 16:38:49, Edit by FRICK ; ;Declare some more symbols internal. ;<FRICK>LISP.MAC.17, 18-Sep-78 19:22:04, Edit by FRICK ; ;Fix bug in GCGAG output, so that it works also when number of cells ; collected are more than an INUM. ;<FRICK>LISP.MAC.11, 3-Sep-78 17:11:44, Edit by FRICK ; ;LINELENGTH now checks that its argument is NIL or greater than 0. ;PAGELENGTH now checks that its argument is NIL or greater than or equal to 0. ; ;DIGIT and LITER now returns NIL if their argument is not an ; interned id with a one character print name. ;<FRICK>LISP.MAC.7, 27-Aug-78 15:44:35, Edit by FRICK ; ;The ERROR print routine (also used by WARNING) doesn't relay any ;more on register T being saved. The stack is used instead. ;<FRICK>LISP.MAC.6, 24-Aug-78 16:53:44, Edit by FRICK ;(EQUAL 1 1.0) now returns NIL instead of T. ; ;The first argument to REMFLAG is a list whose elements now not ; have to be ids. REMFLAG does nothing for those that aren't ids. ; ;SUBR and FSUBR are now completely replaced by EXPR and FEXPR. ;For compatibility reason FASLOD will convert (F)SUBR to (F)EXPR and ;give a message about it the end of each load. ; ;Digits in DIGIT, EXPLODE and READCH are now character ids, not INUMs. ; ;The initialization file LISP.LSP is renamed to LISP.SL. ;<FRICK>LISP.MAC.2, 20-Aug-78 18:10:26, Edit by FRICK ; ;Make PATOM available as a SUBR. ;<FRICK>LISP.MAC.254, 1-Aug-78 17:49:50, Edit by FRICK ; ;Define Fasload type 11 to be similar to 13 but the codepointer ; is put on the property list with PUT instead of PUTD. ;<FRICK>LISP.MAC.252, 27-Jul-78 18:53:43, Edit by FRICK ; ;Make ERREx print the left half of register A if it isn't 0. ;This involves a change to PRINL also. ;Make a small change to PRINEL and remove PRIN1B that now is unnecessary. ;<FRICK>LISP.MAC.250, 25-Jul-78 23:52:04, Edit by FRICK ; ;Include this list of changes and renumber pages. ;<FRICK>LISP.MAC.245, 22-Jul-78 19:46:45, Edit by FRICK ; ;Set *ERRMSG to T on toplevel only if it is NIL. ; ;Make the OP routine (i.e. all binary numerical routines) check ;first that the arguments are numbers so that the error message ;"x IS NOT A NUMBER" gets the right "x". ; ;The garbage collector now also marks from the top element of ;the SPDL. ;<FRICK>LISP.MAC.238, 14-Jul-78 13:50:27, Edit by FRICK ; ;RETURN and GO now works in other than the last statement in ;a PROGN. ; ;SKIPTO now initialize register AR4 so that it doesn't think ;everything is EDIT or SOS line numbers. ;<FRICK>LISP.MAC.237, 10-Jul-78 01:21:58, Edit by FRICK SUBTTL HISTORY OF CHANGES --- PAGE 1 ; ;COPYRIGHT (C) 1979 University of Utah. ; ;Permission to copy without fee all or part of this material is granted ;provided that copies are not made or distributed for direct commercial ;advantage, the Utah copyright notice and the title of the program and ;its date appear, and notice is given that copying is by permission of ;the University of Utah. To copy otherwise, or to republish, requires a ;fee and/or specific permission. ; SUBTTL AC DEFINITIONS AND EXTERNALS --- PAGE 2 TITLE LISP INTERPRETER COMMENT TABLE OF CONTENTS 1. History of changes 2. Assembling switches, AC Definitions, Symbols and Externals 3. Top Level and Initialization 4. APR Interrupt routines 5. UUO Handler and SUBR-call routines 6. ERROR Handler and Backtrace 7. TYI and TYO 8. INPUT and OUTPUT initialization and control 9. PRINT 10. READ and SCANner tables 11. Interpretive routines of LISP 12. Arithmetic routines 13. Bignum routines 14. Gfpak. Galois field package 15. EXPLODE, READLIST, FLATSIZE, etc. 16. EVAL and APPLY and bindings 17. ARRAY, EXARRAY, STORE 18. EXAMINE, DEPOSIT, BOOLE 19. Garbage Collector 20. GETSYM, PUTSYM and R50MAK 21. FASLOAD, FASLOD 22. ED - Alvine LOAD EXCISE, MORCOR, MOVSYM, etc. 23. FILEP SOSSWAP JSYS, GETAB#, XEQ 24. RBLK, WBLK 25. CORE, ALLOC 26. SETSYS, LSSAVE 27. Re-allocate code after a ST REHASH 28. Lisp atoms and initial OBLIST BPS, FS, FWS 29. Once-only Lisp Storage Allocator PAGE COMMENT General differences from Stanford's 1.6 are: 1) Octal ppns, 2) Explicit i/o for SOS-linkage, 3) The '*' prompt-char can be dynamically changed, to consist of up to 4 characters; 4) The subr CORE(n) is used to increase (or partially cut) core; 5) The subr ALLOC() just goes to LISPGO to alloc new core; 6) Altmode can be typed as 33 or 175. 7) Binary-I/O (36-bit) by INBIN,OUTBIN,BINI,BINO. 8) BPS & EXAMINE,DEPOSIT may address to 256K, vs old 64K limit. 9) RBLK,WBLK can manipulate overlay-blocks in BPS as files. Assembles for TOPS-20, TENEX or TOPS-10, operating systems depending on the setting of the variable OPSYS. N.B. Code for TENEX and TOPS-20 in CHKACS, CHKAC0, SETAPR makes assumptions about PA1050's acc and ^O handler locations. OPSYS is set here ;OPSYS==0 ;Assembles for TOPS-10. ;OPSYS==1 ;Assembles for TENEX OPSYS==-1 ;Assembles for TOPS-20. IFNDEF OPSYS,<OPSYS==-1> ;TOPS-20 is default ;When OPSYS not is zero, this has the following effects: ; 1) The 10x psi is enabled for 10/50 ^O (simulated); ; 2) The swapout for the SOS-link is done as an inferior fork, ; which returns to LISPGO, unless using LISP.TNX patchs. ; 3) The initial start-up questions are slightly changed. ;SYDEV==1 ;When on has the following effects: ; 1) An initial question for system device or directory ; to use as SYS: device: ; For TENEX version asks for system directory number ; (default: number for <REDUCE>, or if that not ; exists, the users directory). ; For TOPS-10 or -20 version asks for system device ; name (default: SYS: ). ; 2) The subr SETSYS is used to dynamically change SYS: . ;CNSPRB==1 ;When on, will check explicitly for the end of the free list, ; instead of detecting it by an illegal memory reference. ;STL==0 ;When on, will assemble for Standard Lisp ;OCTPPN==0 ;When off, will assemble for SU-AI's PPNs. MOD==1 ;When on, will assemble GFPAK modular arithmetics ;ALOD==1 ;When on will assemble LOAD, *PUTSYM and *GETSYM. ;AED==1 ;When on will assemble ED and GRINDEF interface. ;NFLD==0 ;When off dont assemble new FASLOD OFLD==1 ;When on, assemble old FASLOAD ;RWB==1 ;When on will assemble WBLK and RBLK. ;ASARY==1 ;When on will assemble array routines EPDL==0 ;When on, will create a 3rd pdl pointed to by EP ;FNRG==0 ;When on, will assemble funarg features ;HCBPS==1 ;When on puts BPS in high core ;SZBPS==1 ;When on, size of BPS is user decidable, and EXCORE defined. ;ROCT==1 ;When on will read an integer followed by L as octal ;JSYXEQ==0 ;When off, will not define JSYS, %XEQ, ERRSTR and GETAB$ ;SOSSW==1 ;When on assembles %SOSSWAP, used by SOSLINK ;APPL==1 ;When on, EVAL returns arg when undefined PAGE ;Default values for switches IFE OPSYS,<IFNDEF HCBPS,HCBPS==0 ;(Default low core for 10/50) IFNDEF SZBPS,SZBPS==1 IF1,PRINTX Note: being assembled for TOPS-10, not TENEX or TOPS-20. SEARCH UUOSYM JSYXEQ==0 ; JSYSes not defined in TOPS-10 IFNDEF OCTPPN,< OCTPPN==1 IF1,PRINTX Note: if for SU-AI, reassemble with OCTPPN==0 >> IFN OPSYS,<IFNDEF HCBPS,HCBPS==1 ;(Default high core 400000:676776) IFNDEF SZBPS,SZBPS==0 OCTPPN==1 > ;Permit (0,nnn) format if desired. IFL OPSYS,<SEARCH MONSYM IF1,PRINTX Note: being assembled for TOPS-20, not TENEX or TOPS-10. > IFG OPSYS,<SEARCH STENEX OPDEF ERJMP [JUMP 16,] IF1,PRINTX Note: being assembled for TENEX, not TOPS-10 or TOPS-20. > IFNDEF STL,<STL==1> IFN STL,< IFNDEF AED,AED==0 IFNDEF ALOD,ALOD==0 IFNDEF RWB,RWB==0 IFNDEF ASARY,ASARY==0> IFNDEF SYDEV,<SYDEV==1> ;Default: SYDEV is on. IFNDEF CNSPRB,<CNSPRB==0> IFNDEF MOD,<MOD==0> IFNDEF ALOD,<ALOD==1> IFNDEF AED,<AED==1> IFNDEF RWB,<RWB==1> IFNDEF ASARY,<ASARY==1> IFNDEF NFLD,<NFLD==1> IFNDEF OFLD,<OFLD==0> IFNDEF EPDL,<EPDL==0> IFNDEF APPL,<APPL==0> IFNDEF FNRG,<FNRG==1> IFNDEF HCBPS,HCBPS==1 IFNDEF SZBPS,SZBPS==1 IFE HCBPS,SZBPS==1 IFNDEF ROCT,<ROCT==0> IFNDEF JSYXEQ,<JSYXEQ==1> IFNDEF SOSSW,<SOSSW==0> PAGE TEN==^D10 INUMIN=377777 ;Lower limit of INUMs. BCKETS==77 INITBPS== 2000 ;Initial (default) size of BPS. INITCORE==^D12*2000-1 ;Initial (default) size of Lisp core . MAXCORE==^D124 ;Maximum size of Lisp core, to allow for I/O buffers. MINFBPS==1000 ;Necessary BPS for Fap bootstrap fisltable BOTBPS==1320 ;Necessary BPS for Fap loaded functions ILLAD==775777 ;Illegal address to generate interrupt when free list exhausted. ;Atom type tags ID=1000000-1 ;identifier CODE=ID-1 ;code pointer CODMIN==CODE VECT=CODE-1 ;vector STRNG=VECT-1 ;string FLONU=STRNG-1 ;floating point number FIXNU=FLONU-1 ;single word integer POSNU=FIXNU-1 ;positive bignum. Must be odd NEGNU=POSNU-1 ;negative bignum ATMIN=NEGNU-1 ;addresses bigger than this, are atom tags. INUM0=1+<INUMIN+ATMIN>/2 IFN <ATMIN+INUMIN-2*INUM0>,<INUMIN=INUMIN+1> DEFINE PR%%IN (XX)< PRINTX Maximum INUM modulus is XX > IF1,<XX==ATMIN-INUM0 PR%%IN \XX > PAGE ;Accumulator definitions ;'sacred' means sacred to the interpreter ;'marked' means marked from right and left half by the garbage collector ;'protected' means protected during garbage collection NIL=0 ;sacred, marked, protected ;atom head of NIL A=1 ;marked, protected ;results of functions and first arg of subrs B=A+1 ;marked, protected ;second arg of subrs C=B+1 ;marked, protected ;third arg of subrs AR4=4 ;marked, protected ;fourth arg of subrs (old AR1) AR5=5 ;marked, protected ;fifth arg of subrs (old AR2A) T=6 ;marked, protected ;minus number of args internaly TT=7 ;marked, protected REL=10 ;marked, protected ;rarely used IFE EPDL,< EP==14 S=11 > IFN EPDL,< S==11 EP=11 ;sacred, protected ;exp push down stack pointer > D=12 R=13 ; protected P=14 ;sacred, protected ;regular push down stack pointer F=15 ;sacred ;free storage list pointer FF=16 ;sacred ;full word list pointer SP=17 ;sacred, protected ;special pushdown stack pointer NACS==5 ;number of argument acs NSUA==16 ;maximum number of subr arguments X==0 ;X indicates impure (modified) code locations ; Added Inst-definitions for legibility... OPDEF PCALL [PUSHJ P,] OPDEF PRET [POPJ P,] OPDEF PSAVE [PUSH P,] OPDEF PREST [POP P,] OPDEF PSKPRT [AOS (P)] OPDEF P1DROP [SUB P,[1,,1]] OPDEF P2DROP [SUB P,[2,,2]] OPDEF P3DROP [SUB P,[3,,3]] OPDEF PXDROP [SUB P,] OPDEF CARA [HLRZ ] OPDEF CDRA [HRRZ ] OPDEF RPLCA [HRLM ] OPDEF RPLCD [HRRM ] PAGE ;UUO definitions ;UUOs used to call functions from compiled code ;the number of arguments is given by the ac field ;the address is a pointer either to the function ;name or the code of the function OPDEF FCALL [34B8] ;ordinary function call-may be changed to PCALL OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST OPDEF CALLF [36B8] ;like FCALL but may not be changed to PCALL OPDEF JCALLF [37B8] ;like JCALL but may not be changed to JRST ;error UUOs UOERRE==1 UOERRL==10 UOERRG==20 UOERRI==21 USTRTP==22 ;ERRL and ERRE spans more than one UUO, to allow for larger ac-field ;Ac-field contains error number. OPDEF ERRE1 [1B8] ; 1 ;print expression, ordinary lisp error, bactrace OPDEF ERRE2 [2B8] ; 2 OPDEF ERRE3 [3B8] ; 3 OPDEF ERRE4 [4B8] ; 4 OPDEF ERRE5 [5B8] ; 5 OPDEF ERRE6 [6B8] ; 6 OPDEF ERRE7 [7B8] ; 7 OPDEF ERRL0 [10B8] ; 8 ;ordinary lisp error ;gives backtrace OPDEF ERRL1 [11B8] ; 9 OPDEF ERRL2 [12B8] ; 10 OPDEF ERRL3 [13B8] ; 11 OPDEF ERRL4 [14B8] ; 12 OPDEF ERRL5 [15B8] ; 13 OPDEF ERRL6 [16B8] ; 14 OPDEF ERRL7 [17B8] ; 15 OPDEF ERRG [20B8] ; 16 ;space overflow error ;no backtrace OPDEF ERRI [21B8] ; 17 ;ill. mem. ref. OPDEF STRTIP [22B8] ; 18 ;print error message and continue PAGE ;system UUOs OPDEF TTYUUO [51B8] OPDEF INCHRW [TTYUUO 0,] OPDEF OUTCHR [TTYUUO 1,] OPDEF OUTSTR [TTYUUO 3,] OPDEF INCHWL [TTYUUO 4,] OPDEF INCHSL [TTYUUO 5,] OPDEF CLRBFI [TTYUUO 11,] OPDEF SKPINC [TTYUUO 13,] OPDEF TALK [PCALL TTYCLR] ;this is to turn off control O. ;when ttyser lets you do this ;easily, change me ;system uuos DEVCHR==4 CORE==11 RESET==0 APRINI==16 MSTIME==23 STIME==27 SETUWP==36 PAGE ;I/O bits and constants LNPRVT==6 ;lines per vertical tab TTYPL==0 ;teletype pagelength. No paging LPTPL==0 ;line printer pagelength. No paging TTYLL==105 ;teletype linelength LPTLL==160 ;line printer linelength MLIOB==203 ;max length of I/O buffer NIOB==2 ;no of I/O buffers per device NIOCH==17 ;number of I/O channels FSTCH==1 ;first I/O channel TTCH==0 ;teletype I/O channel BLKSIZE==NIOB*MLIOB+COUNT+1 INB==2 OUTB==1 AVLB==40 DIRB==4 ;special ASCII characters ALTMOD==175 ;LISP'S ALTMODE (TENEX-PA1050 & SU-AI) 33'S CONVERTED. IGCRLF==32 ;ignored cr-lf RUBOUT==177 CRLF==37 ;TYID converts the sequence CR LF or CR FORMF to CRLF. TYO converts back. LF==12 CR==15 TAB==11 BELL==7 DBLQT==42 ;double quote " VT==13 ;vertical tab FORMF==14 ;form feed ;byte pointer field definitions ACFLD==^D12 ;ac field XFLD== ^D17 ;index field OPFLD==^D8 ;opcode field SIGN==400000 ;sign marker for bignums PAGE ;external and internal symbols EXTERNAL .JB41 ;instruction to be executed on UUO EXTERNAL .JBAPR ;address of APR interupt routines EXTERNAL .JBCNI ;interupt condition flags EXTERNAL .JBFF ;first location beyond program EXTERNAL .JBREL ;address of last legal instruction in core image EXTERNAL .JBREN ;reentry address EXTERNAL .JBSA ;starting address EXTERNAL .JBSYM ;address of symbol table EXTERNAL .JBTPC ;program counter at time of interupt EXTERNAL .JBUUO ;uuo is put here with effective address computed EXTERNAL .JBHRL ;RH= High-segment .JBREL, LH set 0. ;apr flags PDOV==200000 ;push down list overflow MPV==20000 ;memory protection violation NXM==10000 ;non-existant memory referenced APRFLG==PDOV+MPV+NXM ;any of the above ;foolst macros: these get relocated (RH addr) relative to FS. DEFINE FOO < XLIST BAZ (\FOOCNT) LIST > DEFINE BAZ (X) <FOOCNT=FOOCNT+1 FOO'X:! SUPPRESS FOO'X > FOOCNT=0 SUBTTL TOP LEVEL AND INITIALIZATION --- PAGE 3 LISPGO: SETOM RETFLG# ;enter via INITFN JRST STRT ;go to re-allocator DEBUGO: SETZM RETFLG ;clear return flag to allow INITFN to be changed JSR CHKACS ;entry point to get into read-eval-print loop JUMPN A,LSPRT2 ; without unbinding spec pdl... ;If NIL looks like an atomheader, we skip ; reseting the ACCs, etc, else refresh... START: CALLI RESET ;Initializations for lisp interrupts... JSR APRSET ;Set up APRs and Tenex ^chars. JSR CHKAC0 ;Reset NIL if necessary, else retain any user additions. IFN AED,SETZM PSAV1 FOO SETZB 1,VERMSG MOVE 17,[1,,2] BLT 17,17 ;clear acs, other than NIL. MOVEI F,ILLAD ;empty fs list LSPRT1: MOVE P,C2# ;Initialize regular PDL. IFN EPDL,MOVE EP,EC2# ;initialize EPDL SKIPE SP,SPSAV# PCALL TUNBIND ;Unbind spec pdl to top MOVE SP,SC2# ;Initialize special PDL. PUSH SP,[0] ;mark for unbind FOO MOVEI B,TRUTH FOO SKIPN ERRSW ;only change if NIL FOO MOVEM B,ERRSW ;print error messages SETZM ERRTN ;return to top level on errors SETOM PRVCNT# ;initialize counter for errio IFN OPSYS,SETZM KBINTF SETZM EXARG ;Delete content of MOVE A,[EXARG,,EXARG+1] ; extended ascs to BLT A,EXARG+NSUA-NACS-1 ; allow gc LSPRT2: PCALL TTYRET ;Return output for gc msg. JSR CHKNIL ;initialize nil SKIPE HASHFG# JRST REHASH ;rehash if necessary SKIPN FF PCALL AGC2 ;garbage collect only if necessary SETZM GCFFLG# SKIPN BSFLG# ;initial bootstrap for macros JRST BOOTS SKIPE BPSFLG# JRST BINER2 ;BPS OVERFLOW DURING A (LOAD T). SKIPN RETFLG ;test for error return JRST LISP2 FOO SKIPE A,INITF CALLF 0,(A) ;evaluate initialization function SETZM RETFLG LISP2: PCALL TTYRET ;return all i/o to tty PCALL TERPRI SKIPE GOBF# ;garbaged oblist flag STRTIP [SIXBIT /_***** GARBAGED OBLIST_!/] SETZM GOBF LISP1: PCALL READ ;this is the top level of lisp PCALL EVAL PCALL TERPRI PCALL PRINT PCALL TERPRI JRST LISP1 PAGE ;return from lisp error LSPRE: CLRBFI ;clear input buffer FOO SKIPE RSTSW JRST LISP2 ;(*rset t) goes to read-eval-print loop without unbind LSPRET: MOVE P,C2 ;return from bell PCALL TERPRI IFN AED,<SKIPE P,PSAV1# ;bell from alvine? JRST [HRRZ REL,ED ;yes, return to alvine JRST 1(REL)]> ;improved magic MOVEM SP,SPSAV ;force unbinding of spec pdl SETOM RETFLG ;set return flag JRST LSPRT1 ;bootstrapper for macro definitions & Lisp extensions... BOOTS: SETOM BSFLG MOVEI A,BSTYI PCALL READP1 PCALL EVAL PCALL READ ;last prog calls ERR, back to LISP1. JRST .-2 BSTYI: ILDB A,[POINT 7,[ASCII /(RDS(OPEN '(SYS:(LISP.SL)) 'INPUT))/]] PRET PAGE ;Verify that NIL is a good atom, perhaps with user properties, ; else reset it (AC0) to be the Urlisp atomheader... IFN OPSYS,< CHKACS: X ;Tenex-Pa1050 needs to be clever about ^C's. CALLI A,MSTIME ;Do a simple op to ensure PA1050 exists. JSR CHKNIL JUMPN A,@CHKACS ;Didn't have to fix it, MOVE NIL,@700032 ; else check last ac0 saved in PA1050. JSR CHKNIL JUMPE A,@CHKACS ; Not ok either, have to refresh all accs. HRLZ 17,700032 ;Was ok, so grab the save-acc blk BLT 17,17 ; from PA1050's area. JRST CHKACS+2 ;Set ac1 non0 and return successfully. CHKAC0: X ;Setup 0 without worrying about 1:17. JSR CHKNIL JUMPN A,@CHKAC0 ;Tenex's was ok, MOVE NIL,@700032 JSR CHKNIL JRST @CHKAC0 > ; or PA1050's, else CNIL2 reset. CHKNIL: X ;Yet another impure loc, for JSRing. JSP TT,CHKNI1 JUMPN A,@CHKNIL ; o.k. MOVE NIL,CNIL3 ; refresh NIL MOVEI A,NIL ;Return 0 if have to reset... JRST @CHKNIL CHKNI1: HLRO A,NIL AOJN A,SETNIL ;LH not -1. CDRA A,NIL CAILE A,@GCPP1 ;(base of FS) CAIL A,@GCP1 ;(base of FWS) JRST SETNIL ; proplist addr not in FS. FOO MOVEI B,VALUE GETNIL: MOVS C,(A) ;Make sure it has a VALUE cell, MOVS A,(C) CAIN B,(A) ; else EVAL would say "#0 Unbound Variable". JRST GOTNIL CARA A,C JUMPN A,GETNIL JRST (TT) GOTNIL: HLRZS A ;We don't require this to be UrLisp's VNIL cell. SKIPE (A) ;Check that it points back to NIL tho, SETNIL: MOVEI A,NIL ; else reset it. JRST (TT) ;Return non0: didn't have to reset. IFE OPSYS,<CHKACS==CHKNIL ;Don't have to worry about separate CHKAC0==CHKNIL> ; PA1050 accs being present after a ^C. SUBTTL APR INTERRUPT ROUTINES --- PAGE 4 ;arithmetic processor interupts ;mem. protect. violation, nonex. mem. or pdl overflow APRINT: MOVEM R,ACSAV+R MOVE R,.JBCNI ;get interrupt bits SETZM .JBCNI ;Clear for compiled-code Pdl check: <JUMPGE P,@.JBAPR> TRNE R,MPV+NXM ;what kind JRST ILLMEM JUMPN NIL,MES21 ;a pdl overflow STRTIP [SIXBIT /_***** PDL OVERFLOW FROM GC - CAN'T CONTINUE!/] JRST START MES21: SETZM .JBUUO SKIPL P ERRG ^D256,[SIXBIT /REG PUSHDOWN CAPACITY EXCEEDED!/] SKIPL SP SPDLOV: ERRG ^D257,[SIXBIT /SPEC PUSHDOWN CAPACITY EXCEEDED!/] IFN EPDL,<SKIPL EP ERRG ^D258,[SIXBIT /EXP PUSHDOWN CAPACITY EXCEEDED!/] > TRNN R,PDOV HALT ;lisp should not be here BINER2: SETZM BPSFLG ERRG ^D259,[SIXBIT /BINARY PROGRAM SPACE EXCEEDED!/] ILLMEM: LDB R,[POINT 4,@.JBTPC,XFLD] ;get index field of bad word CAIN R,F ;is it F ? CAIE F,ILLAD ERRI 2,@.JBTPC ;no! error PSAVE .JBTPC ;yes! save return address MOVEI R,APRFLG CALLI R,APRINI ; reset interupt, MOVEI R,AGC1 JRSTF @R ; garbage collect and continue PAGE APRSET: 0 ;SET UP NECESSARY INTERRUPTS. MOVE A,[JSR UUOH] MOVEM A,.JB41 MOVEI A,APRINT MOVEM A,.JBAPR MOVEI A,APRFLG CALLI A,APRINI ;THIS DOES THE 10/50 SETUP. IFE OPSYS,< IFN HCBPS,< SETZ A, CALLI A,SETUWP ;Necessary as RESET resets high core write bit. HALT > JRST @APRSET> IFN OPSYS,< ; and for TENEX (Accs 1&2 are free): MOVEI 1,400000 ;FORK HANDLE FOR THIS FORK. RIR ;GET THE PA1050 FILE'S LEVTAB,,CHNTAB. IFG OPSYS,< MOVE 1,[XWD 1,CHANL0] EXCH 1,^D30(2) ;Set channel addresses... HRRZS 1 ; Normally would just use chn 0 for ^O CAIL 1,700000 ; but PA1050 also diddles on chn 30, HRRM 1,CHANL0 > ; so do local CHANL0 then PA1050's CFOBF. MOVE 1,[XWD 1,CHANL1] MOVEM 1,1(2) MOVE 1,[XWD 1,CHANL2] MOVEM 1,2(2) MOVE 1,[XWD 1,CHANL3] MOVEM 1,3(2) IFG OPSYS,< MOVE 1,["O"-100,,^D30];Set terminal-characters... ATI > MOVE 1,["P"-100,,1] ATI MOVE 1,["E"-100,,2] ATI MOVE 1,["K"-100,,3] ATI MOVEI 1,400000 IFG OPSYS,<MOVSI 2,(1B0+1B1+1B2+1B3)> IFL OPSYS,<MOVSI 2,(1B1+1B2+1B3)> AIC IFG OPSYS,SETZM CTRLOF# ;Init. SETZM KBINTF# ;Init. JRST @APRSET IFG OPSYS,< CHANL0: SETCMM CTRLOF ;Flip-flop the ^O flag. DEBRK > PAGE CHANL1: PSAVE 1 ; ^P HANDLER... PSAVE 2 ; Prints current file's <Line>/<Page>. PSAVE 3 MOVEI 1," " PBOUT SKIPG LINUM JRST [MOVM 2,LINUM PCALL IPNUM JRST .+3] HRROI 1,LINUM PSOUT MOVEI 1,"/" PBOUT MOVE 2,PGNUM PCALL IPNUM IFG OPSYS,MOVEI 1,37 IFL OPSYS,<MOVEI 1,CR PBOUT MOVEI 1,LF > PBOUT PREST 3 PREST 2 PREST 1 DEBRK IPNUM: MOVEI 1,101 ADDI 2,1 MOVEI 3,^D10 NOUT PRET PRET CHANL2: PSAVE 1 HRROI 1,[ASCIZ /^E /] PSOUT PREST 1 HLLOS KBINTF ;Flag RH -- next UUO becomes (ERR). DEBRK CHANL3: PSAVE 1 HRROI 1,[ASCIZ /^K /] PSOUT PREST 1 HRROS KBINTF ;Flag LH -- next UUO breaks out to top. DEBRK KBINTH: MOVE A,KBINTF ;Handle KB ^char now -- from UUOH, AGC, etc. SETZM KBINTF IFG OPSYS,SETZM CTRLOF TLNE A,-1 ;Which was it? JRST LSPRET ; ^K - escape to top-level. MOVEI A,NIL JRST ERR ; ^E - (ERR NIL) to ERRSET or top. > ;end of IFN OPSYS SUBTTL UUO HANDLER AND SUBR CALL ROUTINES --- PAGE 5 UUOH: X ;jsr location MOVEM T,TSV# MOVEM TT,TTSV# LDB T,[POINT 9,.JBUUO,OPFLD] ;get opcode CAIGE T,34 ;is it a function call? JRST ERROR ;or a LISP error? IFN OPSYS,< SKIPE KBINTF ;Has user hit ^Chars on KB? JRST KBINTH ; Yes, handle it. > HRRZ TT,UUOH SOSA TT MOVEI TT,@(TT) LDB T,[POINT 9,(TT),OPFLD] CAIN T,256 ;Is it XCT JRST .-3 HRRM TT,UUOCL-1 LDB T,[POINT 5,.JBUUO,ACFLD] TRZN T,20 PSAVE UUOH ;call|callf -- return addr. CARA R,@.JBUUO CAIE R,ID JRST UUOS ;if wasn't an id head, else... CAIE T,17 TDZA R,R MOVEI R,1 ;R=0 if T=0-16, else 1(17). CDRA T,@.JBUUO FOO MOVEI D,FUNCELL UUOH1: JUMPE T,UUOH3 MOVS TT,(T) MOVS T,(TT) CAIN D,(T) JRA T,UUOH2 CARA T,TT JRST UUOH1 PAGE UUOH2: CARA TT,T HRL T,.JBUUO ;name of function, for backtrace ;FOO CAIN TT,SUBR ; JRST @UUST(R) ;FOO CAIN TT,FSUBR ; JRST @UUFST(R) CARA D,(T) CAIE D,ID CAIGE D,CODMIN JRST .+2 SUBI R,4 ;its a subr or fsubr FOO CAIN TT,EXPR JRST @UUET(R) FOO CAIN TT,FEXPR JRST @UUFET(R) UUOH4: HRRZ A,.JBUUO ERRE1 ^D16,[SIXBIT /UNDEFINED UUO!/] ;e.g., a MACRO or no def. UUOH3: PSAVE A PSAVE B HRRZ A,.JBUUO FOO MOVEI B,VALUE PCALL GET JUMPE A,UUOH4 CDRA T,(A) HRL T,.JBUUO ;name of function, for backtrace PREST B PREST A JRST UUOEXP PAGE UUOSC: CDRA T,(T) UUOSBR: FOO SKIPE NOUUOF JRST UUOCL MOVE TT,.JBUUO HRLI T,(PCALL) TLNE TT,1000 ;1000 means no push HRLI T,(JRST) TLNN TT,2000 ;2000 means no clobber MOVEM T,X UUOCL: MOVE TT,TTSV MOVE R,T MOVE T,TSV JRST (R) UUOS: HRRZ T,.JBUUO ;If not an atomheader, what? CAIL R,CODMIN JRST UUOSC ; code pointer CAILE T,@GCPP1 ; Base of FS, CAIL T,@GCP1 ; FWS... JRST UUOSBR UUOEXP: PSAVE T ;<fn name or NIL,,func def> LDB T,ARGFLD JUMPE T,IAPPLY CAIN T,17 MOVEI T,1 MOVEI TT,IAPPLY SKIPA R,T ARGPDL: LDB R,ARGFLD ARGP1: HRLZ T,R ADD P,T JUMPGE P,MES21 ;check for stack overflow MOVEI T,1(P) HRLI T,A CAIG R,NACS JRST .+4 BLT T,NACS(P) MOVEI T,NACS+1(P) HRLI T,EXARG ADDI P,(R) BLT T,(P) MOVNI T,(R) JRST (TT) EXARG: BLOCK NSUA-NACS+1 ARGFLD: POINT 4,.JBUUO,ACFLD PAGE ;R=0 => compiler calling a - ;R=1 => compiler calling f type ;for an expr or fexpr that has a code pointer, 4 is subtracted ; from R, to map expr into subr and fexpr into fsubr UUST: UUOSC UUOS2 ;calling f (page 15 - EVAL). UUFST: UUOS9 ;calling - its a f UUOSC UUET: UUOEXP UUOS6 ;calling f its an expr (page 15 - EVAL). UUFET: UUOS3 ;calling - its a fexpr UUOEXP UUOSFE: HRRZ A,.JBUUO ERRE1 ^D17,[SIXBIT /CALLED AS EXPR!/] UUOS9: PSAVE T JSP TT,ARGPDL MOVEI TT,UUOCL QTLFY: MOVEI A,0 ;If AGC and GCGAG(T), can clobber QTLFY1: JUMPE T,(TT) ; .JBUUO and UUOH, so saved in GC. EXCH A,(P) PCALL QTIFY PREST B PCALL CONS AOJA T,QTLFY1 UUOS3: PSAVE T JSP TT,ARGPDL JSP TT,QTLFY JRST UUOS3I SUBTTL ERROR HANDLER AND BACKTRACE --- PAGE 6 ERRSUB: HRRZ A,.JBUUO ;Print SIXBITed messages (errors)... JUMPE A,CPOPJ HRLI A,(POINT 6,0) MOVEM A,ERRPTR# ERRORB: ILDB A,ERRPTR CAIN A,01 ;conversion from sixbit PRET CAIN A,77 HRREI A,CRLF-40 ADDI A,40 PCALL TYO JRST ERRORB WHEAD: PCALL ERRIO MOVEI B,3 JRST ERHED+2 ERHED: PCALL ERRIO MOVEI B,5 PCALL TERPRI MOVEI R,TYO XCT "*",CTY SOJG B,.-1 XCT " ",CTY PRET TOURET: PCALL TERPRI ;subroutine to return output to previously selected device OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect SOSL PRVCNT ;when prvcnt goes negative, then reselect PRET PSAVE PRVSEL# ;previously selected output PREST TYOD PRET ;subroutine to force error messages out on tty ERRIO: FOO CDRA B,ERRSW CAIE B,INUM0 ;inum0 => print message on selected device AOSLE PRVCNT ;Deselected iff PRVCNT already <0. PRET TALK ;undo control o MOVE B,[JRST TTYO] EXCH B,TYOD MOVEM B,PRVSEL PRET ERRTN: 0 ;0 => top level * ;- => pdl to reset to - stored by errorset ;+ => string tyo pout rtn flag PAGE ;subroutine to search oblist for closest function to address in R ERSUB3: JSR CHKNIL ;Reset AC0 if need be. FOO MOVEI A,QST HRLZ B,INT1 MOVNS B SETZB AR5,GOBF CAIL R,STRT MOVEI AR5,STRT FOO CAIL R,FS MOVEI A,NIL PSAVE .JBAPR MOVEI C,[SETOM GOBF ;Intercept ill-mem-refs, flag JRST ERRO2G] ; "garbaged OBLIST" for LISP2. HRRM C,.JBAPR HLRZ C,@RHX5 ERRO2B: JUMPE C,[AOBJN B,.-1 PREST .JBAPR ;oblist done, restore JRST PRIN2D] ;print closest match CARA TT,(C) CDRA TT,(TT) JRST ERRO2C+1 ERRO2C: CARA TT,TT JUMPE TT,ERRO2G MOVS TT,(TT) CARA AR4,(TT) FOO CAIE AR4,FUNCELL JRST ERRO2C CDRA TT,(TT) CDRA TT,(TT) CARA AR4,(TT) CAIE AR4,ID CAIGE AR4,CODMIN JRST ERRO2G CDRA TT,(TT) CAMLE TT,AR5 ;LE to prefer car to quote CAMLE TT,R JRST ERRO2G MOVE AR5,TT CARA A,(C) ERRO2G: CDRA C,(C) JRST ERRO2B PAGE ;dispatcher for error message uuos ERROR: MOVEI B,APRFLG ;Enable 10/50 interrupts. CALLI B,APRINI LDB B,[POINT 9,.JBUUO,OPFLD] ;get opcode CAIL B,UOERRE ;what CAILE B,USTRTP ;is it? JRST ILLUUO ; an illegal opcode LDB R,[POINT 9,.JBUUO,ACFLD] ;error number ADDI R,INUM0 CAIL B,USTRTP JRST STRTYP ;print message and continue FOO SETZM VERMSG CAIL B,UOERRI JRST ERROR2 ;illegal memory reference HRRM R,ERRX ;error number CAIL B,UOERRG JRST ERRORG ;space overflow error CAIL B,UOERRL JRST ERROR1 ;ordinary LISP error FOO HRRZM A,VERMSG ;set EMSG* to expression PSAVE A ;save it FOO SKIPN ERRSW JRST ERREND ;dont print message, call (err nil) PCALL ERHED ;print message on tty PREST A PCALL PRIN1 ;print expression XCT " ",CTY JRST ERRORA ;then ordinary Lisp error ERRORG: SKIPN P,ERRTN ;if in errset, restore p to that level MOVE P,C2 ;else to top level ERROR1: ;and attempt to print message FOO SKIPN ERRSW JRST ERREND ;dont print message, call (err nil) PCALL ERHED ;print message on tty ERRORA: PCALL ERRSUB ;print the message JRST ERRBK ;go the backtrace ;STRTYP uses acs A, B and R STRTYP: PCALL ERRIO PCALL ERRSUB ;print message and continue PCALL OUTRET JRST @UUOH ERROR2: HRRZ A,.JBUUO MOVEI B,[SIXBIT / ILL MEM REF FROM !/] SUBI R,420 JRST ERSUB2 PAGE ILLUUO: HRRZ A,UUOH MOVEI B,[SIXBIT / ILL UUO FROM !/] MOVEI R,INUM0+1 FOO SETZM VERMSG ERSUB2: HRRM R,ERRX FOO SKIPN ERRSW JRST ERREND ;dont print message PSAVE A PSAVE B PCALL ERHED PCALL PRINL2 ;print number PREST A PCALL ERRSUB+1 ;print message PREST R PCALL ERSUB3 ;print nearest oblist match ERRBK: FOO SKIPE BACTRF PCALL BKTRC ;print backtrace PCALL TOURET ;return to previous device ERREND: JSR CHKNIL ;Insure NIL is set properly. ERRX: MOVEI A,X ;(ERR x) error number ERR2: SKIPN ERRTN JRST LSPRE ERR: SKIPN P,ERRTN JRST LSPRET ;not in an errset, or bad error -- go to top level ERR1: PREST B PCALL UBD ;unbind to previous errset IFN EPDL,PREST EP FOO PREST ERRSW PREST ERRTN JRST ERRP4 ;and proceed ERRORSET:PSAVE PA3 PSAVE PA4 PSAVE ERRTN FOO EXCH B,ERRSW ;INUM0 -> print on selected device (not nec TYO). PSAVE B IFN EPDL,PSAVE EP PSAVE SP MOVEM P,ERRTN PUSH SP,[0] ;mark for unbind FOO EXCH C,BACTRF ;bind BACTRF on spdl to save from error FOO HRLI C,BACTRF PUSH SP,C PCALL EVAL PCALL NCONS JRST ERR1 PAGE .ERROR: FOO HRRZM B,VERMSG PSAVE A FOO SKIPN ERRSW JRST .ERR1 MOVE A,B PCALL ERRIO JUMPE A,.ERRO PCALL ERHED+1 PCALL PRINEL .ERRO: FOO SKIPE BACTRF PCALL BKTRC PCALL TOURET .ERR1: JSR CHKNIL PREST A JRST ERR2 PRINEL: JSP D,PATMTP JRST PRIN2 PSAVE A CARA A,(A) PCALL PRIN1 PRINE1: CDRA T,@(P) MOVEM T,(P) JUMPE T,POPAJ XCT " ",CTY CARA A,(T) PCALL PRIN2 JRST PRINE1 ;WARNING prints a warning message on the tty WARNING: FOO SKIPN %MSG JRST FALSE PCALL WHEAD PCALL PRINEL JRST TOURET PAGE BKTRC: ;backtrace subroutine FOO CDRA A,BACTRF ;Nil or non-Nil or 0 or +-n... BKTRA: SETZM RVAL ;No stack-args printed, unless 0 or neg. CAIG A,INUMIN JRST BKTR0A HRREI B,-INUM0(A) SKIPG B SETOM RVAL ;0 or neg also prints stack args. MOVM B,B HRRZ A,P SUB A,B ;Just the top n items or JUMPN B,BKTR0B ;0 == T otherwise. BKTR0A: SKIPN A,ERRTN ;backtrace to previous errset MOVE A,C2 ;or top level BKTR0B: HRRZM A,BAKLEV# STRTIP [SIXBIT /_BACKTRACE_!/] FOO MOVE A,VBPORG PCALL NUMVAL MOVEM A,HVAL MOVEI D,-1(P) BKTR2: CAMG D,BAKLEV JRST FALSE ;done HRRZ A,(D) ;get pdl element FOO CAIGE A,FS JUMPN A,BKTR2B ;this is (hopefully) a true program address IFN HCBPS,< CAML A,HVAL ;Check for High BPS subrs, JRST BKTR2A ; else an INUM. CAILE A,400000 ;PCALL from location 377777 is illegal JRST BKTR1B ;Test it. > IFE HCBPS,< CAILE A,INUMIN ;Check for Excore BPS subrs, JRST BKTR2A ; else an INUM. CAML A,HVAL SOJA D,BKTR2 CAMLE A,JRELO JRST BKTR1B ;Test it. > CAIGE A,@GCP1 ;Within FS or NIL? BKTR2A: SKIPN RVAL ;Want to print args on stack? SOJA D,BKTR2 ; Unknown, neither prog nor sexpr, so skip. MOVEI A,"=" PCALL TYO HRRZ A,(D) BKTR2C: PCALL PRIN2D JRST BKTR1C PAGE BKTR2B: CAIE A,ILIST3 ;evaluating arguments ? JRST BKTR1B ;no HRRZ B,-1(D) ;maybe CAIE B,EXP2 CAIN B,ESB1 JRST BKTR1A ;yes BKTR1B: CAIN A,CPOPJ JRST [HLRZ A,(D) ;calling a function PCALL PRIN2D STRTIP [SIXBIT /-ENTER !/] SOJA D,BKTR2] HLRZ B,-1(A) CAILE B,(JCALLF 17,@(17)) CAIN B,(PCALL) ;tests for various types of calls CAIGE B,(FCALL) JRST [CAIG A,INUMIN SOJA D,BKTR2 ;Not a proper function call. JRST BKTR2A ];This could print as a INUM. PSAVE -1(A) ;save object of function call MOVEI R,-1(A) ;location of function call PCALL ERSUB3 ;print closest oblist match XCT "-",CTY PREST R TLNE R,17 HRRZ R,ERSUB3 ;qst -- cant handle indexed calls HRRZS R CARA B,(R) CAIN B,ID JRST [CDRA A,R ;was calling an atomic function JRST BKTR2C] ;print its name CAIL B,CODMIN ;code pointer ? CDRA R,(R) ;yes PCALL ERSUB3 ;was calling a code location; print closest match BKTR1C: XCT " ",CTY BKTR1: SOJA D,BKTR2 ;continue BKTR1A: HLRE B,-1(D) ADD B,D HLRZ A,-3(B) JUMPE A,BKTR1 PCALL PRIN2D STRTIP [SIXBIT /-EVALARGS !/] SOJA D,BKTR2 PRIN2D: PSAVE D PCALL PRIN2 PREST D PRET SUBTTL TYI & TYO --- PAGE 7 ;Input routines... BINI: PCALL TYID JRST FIX1A ITYI: PCALL TYI FIXI: ADDI A,INUM0 PRET TYICC: PCALL COMIGN TYI: MOVEI AR4,1 TYIC: PCALL TYID1 JUMPE A,.-1 ;Ignore null CAIN A,IGCRLF ;start of ignored cr-lf JRST TYICC ;read comment PRET TYIA: CAIN A,LF ;If it is LF JRST RETCRLF ; then return CRLF CAIN A,FORMF ; else if it is FORMF JRST RCRLFFF ; then return CRLF FF CAIE A,CR PRET PCALL TYID ;Read next character CAIN A,CRLF ;If it is CRLF PRET ; then return it MOVEM A,OLDCH ; else backup character MOVEI A,CR ; and return CR PRET RCRLFFF:MOVEM A,OLDCH ;Backup FF RETCRLF:MOVEI A,CRLF PRET TYID1: SKIPE A,OLDCH JRST TYI1 TYID: JRST TTYI+X ;<SOSG X> for other device input... JRST TYI2X TYI3: ILDB A,X ;pointer SKIPGE INCH ;IF BINARY-MODE INPUT, PRET ; SKIP LINUM &FECHO & RAISE CODE. TYI3A: TDNN AR4,@X ;pointer JRST TYI4 MOVE A,@TYI3A CAMN A,[<ASCII / />+1] ;page mark for stopgap AOSA PGNUM ;increment page number MOVEM A,LINUM MOVNI A,5 ADDM A,@TYID ;adjust character count for line number AOS @TYI3 ;increment byte pointer over line number and tab JRST TYID PAGE TYI4: SKIPLE LINUM JRST TYI4A CAIN A,LF JRST TYI4L CAIE A,FORMF JRST TYI4A SETZM LINUM AOSA PGNUM TYI4L: SOS LINUM TYI4A: FOO SKIPN VFECHO JRST TYI4E CAIN A,"D"-100 ;On! File-input echoed to TTY. JRST TYI4W PCALL XTYO JRST TYI4E TYI4W: IFN OPSYS,< PSAVE 2 ;Unless ^D encountered in file... MOVEI 1,100 ; want to pause during echo, RFMOD ; e.g., demo on a CRT. PSAVE 2 TRZ 2,776000 ;Clear wakeup,echo. TRO 2,020000 ;Set just punctuation, SFMOD WAITSP: PBIN ;Wait til user types a space on KB. CAIE 1," " JRST WAITSP MOVEI 1,100 PREST 2 SFMOD ;Restore old TTYmodes. PREST 2 JRST TYID ;Get next file-character. > IFE OPSYS,< SETSTS TTCH,1+1B28 ;OFF ECHO TO TTY, TO GET <sp>... WAITSP: INCHRW A CAIE A," " JRST WAITSP SETSTS TTCH,1 JRST TYID > PAGE TYI2X: INPUT X,0 TYI2Y: STATZ X,740000 ERRL0 ^D128,AIN.8 ;input error TYI2Z: STATO X,20000 JRST TYI3 ;continue with file PSAVE T ;end of file PSAVE C PSAVE R PSAVE AR4 MOVE A,INCH HLRZ T,CHTAB(A) ;inlst -- remaining files to input JUMPE T,TYI2E ;none left -- stop HRRZ C,CHTAB(A) ;get location of data for this channel MOVE R,CHDEV(C) MOVEM R,DEV MOVE R,CHPPN(C) MOVEM R,PPN PCALL SETIN ;start next input PREST AR4 PREST R PREST C PREST T JRST TYI TYI2E: PCALL INCNT ;(CLOSE (RDS NIL)) TALK ;turn off control o FOO MOVE A,V$EOF$ ;we are done JRST ERR PGLINE: MOVM A,LINUM SKIPG LINUM AOJA A,.+3 MOVE C,[POINT 7,LINUM] PCALL NUM10 ;convert ascii line number to an integer PCALL FIX1A ;(may be larger than INUM size - 99999). SKIPG LINUM ;If not line numbered file PCALL NCONS ; then (pg line) MOVE B,PGNUM HRLI A,INUM0+1(B) JRST DCONSA ; else (pg . line) OLDCH: 0 ; * PGNUM: 0 ; * LINUM: 0 ; * 0 ;zero to terminate num10 PAGE ;teletype input TTYI: FOO SKIPE DDTIFG JRST TTYID INCHSL A ;single char if line has been typed JRST [TALK ;turn off control o. OUTSTR PCHAR ;output THE PROMPT-CHAR(S). INCHWL A ;wait for a line JRST .+1] TTYXIT: CAIN A,BELL JRST LSPRET ;bell returns to top level CAIN A,33 MOVEI A,ALTMOD ;<esc> becomes <alt> (DECUS tty input). TYI4E: FOO SKIPE VRAISE CAIGE A,"A"+40 JRST TYIA CAIG A,"Z"+40 TRZ A,40 ;If flag on, make lowercase into upper. PRET TTYID: TALK ;turn off control o, remove this when ttyser works INCHRW A ;single character input ddt submode style CAIE A,RUBOUT JRST TTYXIT OUTCHR ["\"] ;echo backslash SKIPE PSAV JRST RDRUB ;rubout in read resets to top level of read PRET PCHAR: ASCIZ /*/ ;INITIAL (DEFAULT) PROMPT-CHAR. SETPCH: PCALL GT1PNM TRZ A,377 ;(INSURE NULL AT END OF STRING). EXCH A,PCHAR ;1-4 CHARS. JRST PNGNK2 ;return previous promter as non-interned id PAGE ;output ROUTINES. BINO: PSAVE A PCALL NUMVAL PCALL TYOD JRST POPAJ ITYO: SUBI A,INUM0 PSAVE CFIXI ;go to FIXI after TYO XTYO: CAIN A,CRLF ;is it CRLF JRST TYO+2 ;yes! output as is, do not convert to CR LF TYO: CAIG A,CRLF JRST TYO3 SOSGE CHCT JRST TYO1 TYOD: JRST TTYO+X ;sosg x for other device JRST TYO2X TYO5: IDPB A,X PRET TYO2X: OUT X,0 JRST TYO5 ERRL0 ^D129,[SIXBIT /OUTPUT ERROR!/] TYO3: CAIE A,CRLF JRST TYO3X MOVEI A,CR PCALL TYO3XX MOVEI A,LF TYO3X: CAIG A,CR CAIGE A,TAB JUMPN A,TYO+2 ;everything between 0(null) and 11(tab) decrement chct TYO3XX: PSAVE B MOVE B,LINL CAIN A,TAB JRST [SUB B,CHCT IORI B,7 ;simulate tab effect on chct SUB B,LINL SETCAM B,CHCT JRST TYO4] CAIN A,CR MOVEM B,CHCT ;reset chct after a cr CAIN A,VT JRST [PSAVE C MOVE B,LNCT IDIVI B,LNPRVT ADDI B,1 IMULI B,LNPRVT MOVEM B,LNCT PREST C JRST TYO6] CAIN A,FORMF TYO7: SETZM LNCT CAIE A,LF JRST TYO4 AOS LNCT TYO6: SKIPE B,PAGL CAMLE B,LNCT JRST TYO4 MOVEI A,FORMF JRST TYO7 PAGE TYO1: SKIPN OUTCH JRST TYO11 ;don't print a IGCRLF to terminal PSAVE A ;linelength exceeded MOVEI A,IGCRLF ;ignored cr-lf PCALL TYOD PREST A TYO11: PCALL TERPRI SOSA CHCT TYO4: PREST B JRST TYOD LINELENGTH: JUMPE A,LINEL1 CAIG A,INUM0 ERRE2 ^D36,[SIXBIT /ILLEGAL ARG TO LINELENGTH!/] SUBI A,INUM0 HRRM A,LINL HRRM A,CHCT LINEL1: HRRZ A,LINL CFIXI: JRST FIXI PAGELENGTH: JUMPE A,PAGEL1 CAIGE A,INUM0 ERRE2 ^D37,[SIXBIT /ILLEGAL ARG TO PAGELENGTH!/] SUBI A,INUM0 HRRM A,PAGL JUMPE A,PAGEL1 SKIPE LNCT PCALL EJECT PAGEL1: HRRZ A,PAGL JRST FIXI POSN: SKIPA A,LINL LPOSN: SKIPA A,LNCT SUB A,CHCT JRST FIX1A LINL: TTYLL ;* CHCT: TTYLL ;* PAGL: TTYPL LNCT: 0 ;teletype output TTYO: ;Output 1 char from A... IFG OPSYS,SKIPN CTRLOF ; unless ^O on. OUTCHR A PRET PAGE TTYRET: PCALL OUTCNT JRST INCNT TTYCLR: ;Turn off ^O, in a way such that msg IFLE OPSYS, < ; or promptchar will print. SKPINC PRET PRET > IFG OPSYS, < PSAVE A MOVEI 1,101 DOBE SETZM CTRLOF JRST POPAJ > TTOCH: 0 ;* 0 ;tty page number -- always zero 0 ;tty line number -- always zero TTOLL: TTYLL ;* TTOHP: TTYLL ;* TTOPL: TTYPL TTOVP: 0 SUBTTL INPUT AND OUTPUT INITIALIZATION AND CONTROL --- PAGE 8 ;convert ascii to sixbit for device initialization routines SIXMAK: SETZM SIXMK2# MOVE AR4,[POINT 6,SIXMK2] HRROI R,SIXMK1 PCALL PRINTA ;use print to unpack ascii characters MOVE A,SIXMK2 PRET SIXMK1: ADDI A,40 TLNN AR4,770000 PRET ;last character position -- ignore remaining chars CAIN A,"."+40 MOVEI A,0 ;ignore dots at end of numbers for decimal base CAIN A,":"+40 HRLI AR4,(POINT 6,0,29) ;deposit : in last char position IDPB A,AR4 PRET ;subroutine to process next item in file name list INXTIO: JUMPE T,FALSE CDRA T,(T) NXTIO: CARA A,(T) PCALL ATOM JUMPE A,CPOPJ ;non-atomic CARA A,(T) JRST SIXMAK ;make sixbit if atomic IFN OCTPPN,<IOPPNX==NUMVAL> PAGE IOSUB: PCALL NXTIO MOVEM T,DEVDAT# LDB B,[POINT 6,A,35] JUMPE A,IOPPN ;non-atomic item, must be ppn or (file.ext) CAIE B,":"-40 JRST IOFIL ;not a device name -- must be file name TRZ A,77 ;clear out the : IFN OPSYS,PCALL CHKDIR IODEV2: MOVEM A,DEV PCALL INXTIO JUMPN A,IOFIL2 ;not ppn or (fil.ext) IOPPN: JUMPE T,FIL PCALL PPNEXT JUMPN A,IOEXT ;(fil.ext) CARA A,(T) CARA A,(A) ;caar is project number PCALL IOPPNX HRLM A,PPN ;project number CARA A,(T) PCALL CADR ;cadar is programmer number PCALL IOPPNX HRRM A,PPN ;programmer number MOVSI A,(SIXBIT /DSK/) ;disk is assumed JRST IODEV2 IOFIL: JUMPN A,IOFIL3 ;was it an atom JUMPE T,FIL ;no, was it nil (end) PCALL PPNEXT JUMPE A,CPOPJ ;see a ppn, no file named IOEXT: CARA A,(T) ;(file.ext) CDRA A,(A) ;get cdr == extension PCALL SIXMAK HLLZM A,EXT CARA A,(T) CARA A,(A) ;get car = file name PCALL SIXMAK FIL: JUMPE T,.+2 CDRA T,(T) SKIPE DEV PRET PSAVE A ;no device named MOVSI A,(SIXBIT /DSK/) MOVEM A,DEV JRST POPAJ IOFIL2: LDB B,[POINT 6,A,35] CAIN B,":"-40 JRST FALSE ;saw a :,not file name IOFIL3: SETZM EXT ;file name -- clear extension JRST FIL PAGE PPNEXT: CARA A,(T) CDRA A,(A) ;cdar JRST ATOM ;ppn iff (not(atom(cdar l))) IFE OCTPPN,< IOPPNX: PCALL SIXMAK TRNE A,77 PRET LSH A,-6 JRST .-3 > IFN OPSYS,< CHKDIR: CAME A,[SIXBIT /DIR/] ;i.e., (... DIR: directory filename ...) PRET PSAVE T PCALL INXTIO JUMPE A,NIXDIR ;NON-ATOMIC. CARA A,(T) PCALL PNAMUK SETZM 1(C) IFG OPSYS ,< MOVSI A,400000 HRROI B,1(SP) STDIR JRST NIXDIR JRST NIXDIR HRRZM A,PPN > IFL OPSYS, < HRLI A,440700 ; MAKE UP A HRRI A,1(SP) ; BYTE POINTER MOVE B,A MOVEI C,"<" LP1: ILDB 4,A IDPB C,B MOVE C,4 JUMPN C,LP1 MOVEI C,">" ; PUT IN LEFT BRACKET IDPB C,B IDPB 4,B MOVEI A,0 HRROI B,1(SP) RCDIR ERJMP NIXDIR SYSNU: HRLI C,X MOVEM C,PPN > P1DROP ;SLUFF. USEDSK: MOVSI A,(SIXBIT /DSK/) PRET NIXDIR: PREST T ;TRY AS FILENAME INSTEAD. JRST USEDSK > ;end of IFN OPSYS PAGE ;subroutine to reset all i/o channels -- used by excise and realloc IOBRST: X ;jsr location HRRZ A,.JBREL HRLM A,.JBSA MOVEM A,CORUSE MOVEM A,.JBSYM SETZM CHTAB+FSTCH MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1] BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table JRST @IOBRST CHTAB=.-FSTCH ;GC'D BY GCMKL AS AN ARRAY, SINCE LH=LIST, BLOCK NIOCH ;[1-17] RH=ADDR OF .JBFF DATA BLK. ;* ;channel data CHNAM==0 ;name of channel CHDEV==1 ;name of device CHPPN==2 ;ppn for input channel CHOCH==3 ;oldch for input channels CHPAGE==4 ;page number for input CHLINE==5 ;line number for input CHDAT==6 ;device data POINTR==7 ;byte pointer for device buffer COUNT==10 ;character count for device buffer CHLL==2 ;linelength for output channel CHHP==3 ;hposit for output channels CHPL==4 ;pagelength for output channel CHVP==5 ;vposit for output channels ;flags in left half of CHNAM BINM==400000 ;binary I/O OUTM==1 ;output PAGE OPEN: JUMPE A,.+3 JSP D,ATMTYP PCALL NCONS MOVE T,A SETZB A,DEV FOO CAIE B,INBIN FOO CAIN B,OUTBIN TLO A,BINM ;binary I/O FOO CAIE B,OUTPUT FOO CAIN B,OUTBIN TLO A,OUTM ;output FOO CAIE B,INPUT JUMPE A,[MOVE A,B ERRE1 ^D18,[SIXBIT /NOT A KEYWORD FOR OPEN!/]] MOVE B,[-NIOCH,,FSTCH] OPEN1: SKIPN C,CHTAB(B) JRST OPEN2 ;found free channel without buffer SKIPN CHNAM(C) JRST DEVCLR ;found free channel with buffer AOBJN B,OPEN1 ;try next channel ERRL0 ^D130,[SIXBIT "NO I/O CHANNELS LEFT!"] OPEN2: PSAVE A MOVEI A,BLKSIZ PCALL MORCOR ;expand core for buffer if necessary MOVE C,A PREST A HRRM C,CHTAB(B) DEVCLR: HRRZ C,CHTAB(B) HRR A,B HLLOM A,CHNAM(C) MOVEI B,INUM0(B) PSAVE B SETZM PPN TLNE A,OUTM JRST SETOUT PCALL SETIN JRST POPAJ PAGE SETIN: PSAVE A ;CHANNEL #. PCALL IOSUB ;get device and file name MOVEM A,LOOKIN ;file name MOVE A,DEV CALLI A,DEVCHR TLNN A,INB JRST AIN.2 ;not input device TLNN A,AVLB JRST AIN.4 ;not available PREST A HLLZS ININIT MOVEI B,13 SKIPGE A HRRM B,ININIT ;BINARY-INBIN. DPB A,[POINT 4,ININIT,ACFLD] ;set up channel numbers DPB A,[POINT 4,INLOOK,ACFLD] DPB A,[POINT 4,ININBF,ACFLD] HRRZ B,CHTAB(A) HRLM T,CHTAB(A) ;save remaining file name list MOVEI A,CHDAT(B) MOVEM A,DEV+1 ;pointer to bufdat IFN SYDEV,<PCALL SYSDEV> ;Check for SYS: ININIT: INIT X,X ;INIT CHN#,STATUS DEV: X ;SIXBIT /DEV/ X ;XWD 0,IBUF JRST AIN.7 ;cant init PUSH B,DEV PUSH B,PPN INLOOK: LOOKUP X,LOOKIN JRST AIN.7 ;cant find file PUSH B,[0] ;oldch PUSH B,[0] ;line number PUSH B,[0] ;page number ADDI B,4 HRRM B,.JBFF ININBF: INBUF X,NIOB JRST TRUE PAGE IFN SYDEV, < ;shunt SYS: to <LISP>'s dir (or wherever). SYSDEV: MOVSI A,(SIXBIT /SYS/) CAME A,DEV PRET IFG OPSYS,<MOVSI A,(SIXBIT /DSK/)> IFLE OPSYS,<MOVE A,SYSNUM> MOVEM A,DEV IFG OPSYS,<PSAVE SYSNUM PREST PPN > PRET > ENTR: LOOKIN: BLOCK 4 EXT=LOOKIN+1 PPN=LOOKIN+3 PAGE SETOUT: PSAVE A PCALL IOSUB ;get device and file name MOVEM A,ENTR ;file name SETZM ENTR+2 ;zero creation date PREST A DPB A,[POINT 4,OUINIT,ACFLD] ;setup channel numbers DPB A,[POINT 4,OUTENT,ACFLD] DPB A,[POINT 4,OUTOBF,ACFLD] HRRZ B,CHTAB(A) MOVEI A,CHDAT(B) HRLM A,DEVO+1 MOVE A,DEV MOVEM A,DEVO CALLI A,DEVCHR TLNN A,OUTB JRST AOUT.2 ;not output device TLNN A,AVLB JRST AOUT.4 ;not available HLLZS OUINIT MOVEI A,13 SKIPGE CHNAM(B) HRRM A,OUINIT ;BINARY-OUTBIN. OUINIT: INIT X,X ;INIT CHN#,STATUS DEVO: X ;SIXBIT /DEV/ X ;XWD OBUF,0 JRST AOUT.4 ;cant init PUSH B,DEV OUTENT: ENTER X,ENTR JRST OUTERR ;cant enter PUSH B,[LPTLL] ;linelength PUSH B,[LPTLL] ;chrct PUSH B,[LPTPL] ;pagelength PUSH B,[0] ;linct ADDI B,4 HRRM B,.JBFF OUTOBF: OUTBUF X,NIOB JRST POPAJ OUTERR: MOVE A,DEVDAT LDB B,[POINT 3,ENTR+1,35] CAIE B,2 ERRE1 ^D19,[SIXBIT /DIRECTORY FULL!/] ERRE1 ^D20,[SIXBIT /FILE IS WRITE PROTECTED!/] PAGE INCNT: MOVEI A,NIL ;(CLOSE (RDS NIL)) PSAVE [JRST CLOSE] RDS: PSAVE INCH# PCALL IOSEL TLNE A,OUTM ;test to see if it is an input channel ERRL0 ^D131,[SIXBIT/NO INPUT - RDS!/] SKIPN TT MOVEI TT,TTOCH-CHOCH ;tty deselect MOVEI D,CHOCH(TT) HRLI D,OLDCH BLT D,CHLINE(TT) ;save channel data JUMPE A,ITTYRE ;select tty DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers DPB A,[POINT 4,TYI2Y,ACFLD] DPB A,[POINT 4,TYI2Z,ACFLD] HRRM B,TYI3 ;set up tyi parameters HRRM B,TYI3A MOVSI B,CHOCH(C) INC3: HRRI B,OLDCH BLT B,LINUM ;restore channel data MOVEM T,TYID FOO PREST VINC EXCH A,INCH ;flags,,channel#. IOEND: HRRZS A JUMPN A,FIXI PRET ITTYRE: MOVE T,[JRST TTYI] ;reselect tty MOVSI B,TTOCH JRST INC3 PAGE OUTCNT: MOVEI A,NIL ;(CLOSE (WRS NIL)) PSAVE [JRST CLOSE] WRS: PSAVE OUTCH# PCALL IOSEL TLNN A,OUTM ;is it output channel JUMPN A,[ERRL0 ^D132,[SIXBIT /NO OUTPUT - WRS!/]] SKIPN TT MOVEI TT,TTOLL-CHLL ;tty deselect MOVEI D,CHLL(TT) HRLI D,LINL BLT D,CHVP(TT) ;save channel data JUMPE A,OTTYRE ;return to tty DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers HRRM B,TYO5 ;set up tyo2 parameters MOVSI B,CHLL(C) OUTC3: HRRI B,LINL BLT B,LNCT ;get channel data MOVEM T,TYOD FOO PREST VOUTC EXCH A,OUTCH ;flags,,channel#. JRST IOEND OTTYRE: MOVE T,[JRST TTYO] MOVSI B,TTOLL ;tty reselect JRST OUTC3 PAGE IOSEL: PCALL GCHNO ;convert into channel number SKIPE TT,A ADDI TT,INUM0 EXCH TT,-1(P) SKIPE TT HRRZ TT,CHTAB(TT) JUMPE A,CPOPJ SKIPE C,CHTAB(A) SKIPN T,CHNAM(C) JRST CPOPJ1 HLL A,T MOVEI B,POINTR(C) MOVEI T,COUNT(C) HRLI T,(SOSG) PRET CLOSE: PCALL GCHNO ;convert into channel number ICLOSE: JUMPE A,CPOPJ ;don't close terminal cannel SKIPE D,CHTAB(A) SETZM CHNAM(D) ;blast channel name DPB A,[POINT 4,.+1,ACFLD] RELEASE X, ;release channel HRRZS CHTAB(A) ;release channel table entry JRST FIXI ;convert A into channel number GCHNO: SKIPE A SUBI A,INUM0 CAIG A,NIOCH JUMPGE A,CPOPJ ADDI A,INUM0 ERRE1 ^D21,[SIXBIT /IS NOT A CHANNEL NAME!/] AOUT.2: AIN.2: MOVE A,DEVDAT ERRE1 ^D22,[SIXBIT /ILLEGAL DEVICE!/] AOUT.4: AIN.4: MOVE A,DEVDAT ERRE1 ^D23,[SIXBIT /DEVICE NOT AVAILABLE!/] AIN.7: MOVE A,DEVDAT ERRE1 ^D24,[SIXBIT /CAN'T FIND FILE!/] SUBTTL PRINT --- PAGE 9 PRINT: MOVEI R,TYO PCALL PRIN1 TERPRI: PSAVE A MOVEI A,CRLF TERPR1: PCALL TYO CPOPAJ: JRST POPAJ EJECT: MOVEI A,CR PCALL TYO MOVEI A,FORMF PCALL TYO JRST FALSE PRINC: PSAVE A PCALL GTFCH JRST TERPR1 PRIN2: SKIPA R,.+1 PRIN1: HRRZI R,TYO ;<HRRZI> = <551>, NEGATIVE FOR PRIN2. PSAVE A PCALL PRINTA JRST POPAJ PRINTA: HLRZ B,SLSH ;PRIN3 OR PRIN3C SET BY SCANSET SKIPGE R MOVEI B,PRIN4 HRRM B,PRIN5 PRINT4: PSAVE A JSP D,PATMTP JRST PRINT1 XCT "(",CTY PRINT3: MOVE A,TT ;[if 0 --> NIL's 777777 --> ill mem ref]. PCALL PRINT4 CDRA A,@(P) JUMPE A,PRINT2 MOVEM A,(P) XCT " ",CTY JSP D,PATMTP JRST .+2 JRST PRINT3 XCT ".",CTY XCT " ",CTY PCALL PRIN1A PRINT2: XCT ")",CTY JRST POPAJ PAGE PRINT1: PSAVE CPOPAJ PRIN1A: JUMPE TT,PRINIC ;inum JUMPL TT,PRINL ;not a Lisp expression CDRA A,(A) CAIN TT,ID JUMPN A,PRINN CAIL TT,CODMIN JRST PCODE JUMPN A,@PRITAB-ATMIN-1(TT) ;go to print routine for the given type PRINL: XCT "#",CTY HLRZ A,-1(P) JUMPE A,.+3 ;usually there is no left half PCALL PRINL1 XCT ",",CTY HRRZ A,-1(P) PRINL1: MOVEI C,8 PRINI3: JUMPL A,[MOVE B,0 ;case of -2^35 MOVEI A,1 DIVI A,(C) JRST .+2] IDIVI A,0(C) HRLM B,(P) SKIPE A PCALL .-3 JRST FP7A1 PRITAB: BPRI ;negative bignum BPRI+1 ;positive bignum PRINI1 ;integer PRINO ;floating point number PSTR ;string PVEC ;vector PAGE PRINL2: MOVEI R,TYO JRST PRINL1 PRINI1: SKIPA A,(A) PRINIC: SUBI A,INUM0 FOO CDRA C,VBASE SUBI C,INUM0 JUMPGE A,PRINI2 XCT "-",CTY MOVNS A PRINI2: PCALL PRINI3 PRINI4: IFN ROCT,<CAIN C,10 JRST POCTNM> CAIN C,TEN FOO SKIPE %NOPOINT PRET MOVEI A,"." JRST (R) IFN ROCT,< POCTNM: JUMPL R,CPOPJ MOVEI A,"L" JRST (R) > PVEC: PSAVE -1(A) HRLI A,(POINT 18) PSAVE A MOVEI A,"[" PCALL (R) JRST PVECL+1 PVECL: XCT ",",CTY ILDB A,(P) PCALL PRINT4 SOSL -1(P) JRST PVECL MOVEI A,"]" P2DROP JRST (R) PCODE: XCT "#",CTY XCT "#",CTY JRST PRINL1 CTY: JSA A,TYOI TYOI: X PSAVE A LDB A,[POINT 6,-1(A),ACFLD] PCALL (R) PREST A JRA A,(A) PAGE PRINN: FOO MOVEI B,PNAME PCALL GET4 JUMPE A,PRINL CARA A,D PCALL PRIDST ILDB A,C JUMPE A,CPOPJ ;special case of null character PRIN2X: JUMPL R,PRIN4 ;never slash LDB B,SL1FLD JRST PRIN2N(B) ;1 for no slash PRIN3: SKIPL CHRTAB(A) ;<0 for no slash PRIN2N: PCALL SLSHPR ;slashify PRIN4: PCALL (R) ILDB A,C PRIN5: JUMPN A,PRIN3+X ;prin4 for never slash PRET PSTR: PCALL PRIDST MOVE A,STRBEG JRST PSTR3 PSTREC: PCALL (R) MOVE A,STREND PSTR3: SKIPL R ;dont print " if no slashify PSTR2: PCALL (R) ILDB A,C CAMN A,STREND JRST PSTREC JUMPN A,PSTR2 MOVE A,STREND JUMPGE R,(R) PRET PRIDST: MOVEI C,2(SP) PCALL PNAMU3 PUSH C,[0] HRLI C,(POINT 7,0,35) HRRI C,2(SP) PRET SLSHPR: PSAVE A HRRZ A,SLSH PCALL (R) JRST POPAJ PAGE PRINO: MOVE A,(A) SETZB B,C JUMPG A,FP1 JUMPE A,FP3 MOVNS A XCT "-",CTY FP1: CAMGE A,FT01 JRST FP4 CAML A,FT8 AOJA B,FP4 FP3: MULI A,400 ASHC B,-243(A) MOVE A,B SETZM FPTEM# PCALL FP7 XCT ".",CTY MOVNI T,8 ADD T,FPTEM MOVE B,C FP3A: MOVE A,B MULI A,TEN PCALL FP7B SKIPE B AOJL T,FP3A PRET FP4: MOVNI C,6 MOVEI TT,0 FP4A: ADDI TT,1(TT) XCT FCP(B) TRZA TT,1 FMPR A,@FCP+1(B) AOJN C,FP4A PSAVE TT MOVNI B,-2(B) DPB B,[POINT 2,FP4C,11] PCALL FP3 MOVEI A,"E" PCALL (R) FP4C: XCT "+"+X,CTY PREST A FP7: JUMPE A,FP7B IDIVI A,TEN AOS FPTEM HRLM B,(P) JUMPE A,FP7A1 PCALL FP7 FP7A1: HLRE A,(P) FP7B: ADDI A,"0" JRST (R) PAGE 353473426555 ;1e32 266434157116 ;1e16 FT8: 1.0E8 1.0E4 1.0E2 1.0E1 FT: 1.0E0 026637304365 ;1e-32 113715126246 ;1e-16 146527461671 ;1e-8 163643334273 ;1e-4 172507534122 ;1e-2 FT01: 175631463146 ;1e-1 FT0: FCP: CAMLE A,FT0(C) CAMGE A,FT(C) XWD C,FT0 SUBTTL SUPER FAST TABLE DRIVEN READ --- PAGE 10 ;magic scanner table bit definitions ;bit 0=0 iff slashified as nth id character ;bit 1=0 iff slashified as 1st id character ;bits 2-5 ratab index ;bits 6-8 dotab index ;bits 9-10 strtab index ;bits 11-13 idtab index ;bits 14-16 exptab index ;bits 17-19 rdtab index ;bits 20-25 ascii to radix 50 conversion ;bits used by the alternative SCANner ;bits 26-29 ratab index ;bits 30-31 strtab index ;bits 32-34 idtab index ;bit 35=0 iff slashified as 1st id character ;bit 32=0 iff slashified as nth id character ;The following 8 words are modified by SCANSET and SCANRESET IGEND: CRLF STRBEG: DBLQT ;string start STREND: DBLQT ;string end SLSH: XWD PRIN3,"!" ;slashtest,slashifier SL1FLD: POINT 1,CHRTAB(A),1 RATFLD: POINT 4,CHRTAB(A),5 STRFLD: POINT 2,CHRTAB(A),10 IDFLD: POINT 3,CHRTAB(A),13 DOTFLD: NUMFLD: POINT 3,CHRTAB(A),8 EXPFLD: POINT 3,CHRTAB(A),16 RDFLD: POINT 3,CHRTAB(A),19 R50FLD: POINT 6,CHRTAB(A),25 ;magic state flags in t EXP==1 ;exponent NEXP==2 ;negative exponent SAWDOT==4 ;saw a dot (.) MINSGN==10 ;negative number IFN ROCT,<OCTNM==20 ;octal number (saw a L) RDIG==6 > IFE ROCT,RDIG==5 ;atom type in R for SCAN IDCLS==0 ;identifier STRCLS==1 ;string NUMCLS==2 ;number DELCLS==3 ;delimiter PAGE ;macros for scanner table DEFINE RAD50 (X)< IFB <X>,<R50VAL=0> IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL="X"-"0"+1>> IFIDN <"X"><".">,<R50VAL=45> IFIDN <"X"><"$">,<R50VAL=46> IFIDN <"X"><"%">,<R50VAL=47> IFGE <"X"-"A">,<R50VAL="X"-"A"+13>> DEFINE TABIN (SN,S1,R,D,S,I,E,RD,R50,RE<2>,SE<3>,IE<2>,S1E<0>)< XLIST IRPC R50< RAD50 (R50) BYTE (1)SN,S1(4)R(3)D(2)S(3)I,E,RD(6)R50VAL(4)RE(2)SE(3)IE(1)S1E> LIST> DEFINE LET (X)< TABIN (0,0,5,2,3,4,2,0,X)> DEFINE SCNLET (X)< TABIN (1,1,5,2,3,4,2,0,X,5,3,4,1)> DEFINE DELIMIT (X,Y)< TABIN (0,0,2,2,3,2,2,Y,X)> DEFINE IGNORE (X)< TABIN (0,0,3,2,3,2,2,0,X,3)> PAGE CHRTAB: TABIN (0,0,1,1,1,1,1,0,< >,1,1,1) ;null LET (< >) IGNORE (< >) ;tab,lf,vtab,ff,cr LET (< >) ;16 to 31 TABIN (0,0,0,0,0,0,0,0,< >,0,0,0) ;igmrk LET (< >) ;33 -- <ESC> JUST A LETTER WHEN IN A FILE. LET (< >) ;34 to 36 IGNORE (< >) ;37 (EOL) and space TABIN (0,0,4,2,3,3,2,0,< >,4,3,3) ;! the new slashifier TABIN (0,0,9,2,2,2,2,0,< >,9,2) ;" LET (< $>) ;#$ TABIN (0,0,0,0,3,0,0,0,<%>,0,3,0) ;% is comment start LET (< >) ;& TABIN (0,0,2,2,3,4,2,5,< >) ;' the new quote character DELIMIT (< >,0) DELIMIT (< >,1) ;() LET (< >) ;* TABIN (0,0,3,2,3,4,2,0,< >) ;+ TABIN (0,0,3,2,3,2,2,0,< >) ;, ignored for READ, delimit for SCAN TABIN (0,0,6,2,3,4,2,0,< >) ;- TABIN (0,0,7,3,3,2,2,4,<.>,7) LET (< >) ;/ old slashifyer is just a letter now TABIN (1,0,8,RDIG,3,4,3,0,<0123456789>,8,3,4) LET (< >) ;:; DELIMIT (< >,2) ;< super paranthesis LET (< >) ;= DELIMIT (< >,3) ;> super paranthesis LET (< >) ;? LET (< >) ;@ old quote character is just a letter now SCNLET (<ABCD>) TABIN (1,1,5,4,3,4,2,0,<E>,5,3,4,1) ;E exponent for floating point number SCNLET (<FGHIJK>) IFE ROCT,SCNLET(<L>) IFN ROCT,< TABIN (1,1,5,5,3,4,2,0,<L>,5,3,4,1) ;L ends an octal number > SCNLET (<MNOPQRSTUVWXYZ>) DELIMIT (< >,6) ;[ vector start LET (< >) ;\ DELIMIT (< >,3) ;] vector end LET (< >) ;^_` SCNLET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>) ;lower case LET (< >) ;{ DELIMIT (< >,3) ;175 -- ALTMODE (ALSO DECUS' 33 CONVERTED DURING TTI INPUT). LET (< >) ;~ DELIMIT (< >,6) ;rubout PAGE IDCHTAB:BLOCK "?" ;table of character ids. updated by INTERN and FOO XWD 0,QST BLOCK 100-"?"-1 ; REMOB. refered to by READCH and EXPLODE. READCH: PCALL TYI RECH1: TRNN A,100 SKIPA C,IDCHTAB(A) HLRZ C,IDCHTAB-100(A) TRNE C,-1 ;is it in character id table ? JRST RETC ;yes! return it PSAVE TT ;save TT and PSAVE T ; T for EXPLODE LSH A,35 MOVE C,SP PUSH C,A PCALL INTER0 PREST T PREST TT PRET READP1: SETZM NOINFG READ0: PSAVE TYID PSAVE OLDCH SETZM OLDCH# HRLI A,(JRST) MOVEM A,TYID PCALL READ+1 PREST OLDCH PREST TYID PRET RDRUB: MOVEI A,CR PCALL TTYO MOVEI A,LF PCALL TTYO SKIPA P,PSAV# READ: SETZM NOINFG# ;0 means intern SKIPN OLSCNV JRST READD SETZ A, PCALL SCANSET PSAVE A PCALL READD EXCH A,(P) PCALL SCANSET JRST POPAJ READD: MOVEM P,PSAV PCALL READ1 SETZM PSAV PRET READ1: PCALL RATOM PRET ;atom XCT RDTAB2(B) JRST READ1 ;try again RDTAB2: JRST READ2 ;0 ( JFCL ;1 ) JRST READ4 ;2 < JFCL ;3 ],>,$ JFCL ;4 . JRST RDQT ;5 ' JRST READVC ;6 [ READ2: PCALL RATOM JRST READ2A ;atom XCT RDTAB(B) READ2A: PSAVE A PCALL READ2 PREST B JRST XCONS RDTAB: PCALL READ2 ;0 ( JRST FALSE ;1 ) PCALL READ4 ;2 < JRST READ5 ;3 ],>,$ JRST RDT ;4 . PCALL RDQT ;5 ' PCALL READVC ;6 [ RDTX: PCALL RATOM PRET ;atom XCT RDTAB2(B) DOTERR: SETZM OLDCH ERRL0 ^D133,[SIXBIT /DOT CONTEXT ERROR!/] RDT: PCALL RDTX PSAVE A PCALL RATOM JRST DOTERR CAIN B,1 JRST POPAJ CAIE B,3 JRST DOTERR MOVEM A,OLDCH JRST POPAJ READ4: PCALL READ2 MOVE B,OLDCH CAIE B,ALTMOD TYI1: SETZM OLDCH ;kill the > or ] PRET READ5: MOVEM A,OLDCH ;save > or ] or $ JRST FALSE ;and return nil RDQT: PCALL READ1 QTIFY: PCALL NCONS FOO HRLI A,CQUOTE JRST DCONSA ;skip a comment COMENT: CAIN A,IGCRLF ;^Z ? JRST COMIGN ;yes. end on CRLF MOVE A,IGEND ;no. end on IGEND HRRM A,COMM+1 ;set end char COMM: PCALL TYIC ;AR4 must contain 1 here CAIE A,CRLF+X JRST COMM PRET ;skip a super (^Z) comment COMIGN: PCALL TYID1 ;AR4 must contain 1 here CAIE A,CRLF JRST COMIGN PRET PAGE READVC: PCALL READ2 MOVE B,OLDCH ENDVC: CAIN B,"]" SETZM OLDCH LTOVEC: JUMPE A,CPOPJ PSAVE A ;save list CDRA A,(A) PCALL LENGTH PCALL MKVECT ;make a vector CDRA B,(A) EXCH A,(P) MOVSI C,(POINT 18,(B)) MOVS A,(A) IDPB A,C CARA A,A JUMPN A,.-3 JRST POPAJ PAGE ;atom parser RATOM: SETZB T,R ;IDCLS in R HRLI C,(POINT 7,0,35) HRRI C,(SP) SETZM 1(C) ;clear first word MOVEI AR4,1 RATOM2: PCALL TYID1 LDB B,RATFLD JRST RATAB(B) RATAB: PCALL COMENT ;0 comment JRST RATOM2 ;1 null JRST RATOM3 ;2 delimit JRST RATOM2 ;3 ignore PCALL TYIC ;4 ! JRST RDID ;5 letter JRST RDNMIN ;6 - JRST RDOT ;7 . JRST RDNUM ;8 digit JRST RDSTR ;9 string ;a real dotted pair RDOT2: MOVEM A,OLDCH MOVEI A,"." RATOM3: LDB B,RDFLD HRRI R,DELCLS ;delimiter CPOPJ1: PSKPRT ;non-atom (ie a delimiter) PRET ;dot handler RDOT: PCALL TYID1 LDB B,DOTFLD JRST DOTAB(B) DOTAB: PCALL COMENT ;0 comment JRST RDOT ;1 null JRST RDOT2 ;2 delimit JRST RDOT2 ;3 dot JRST RDOT2 ;4 E IFN ROCT,JRST RDOT2 ;5 L MOVEI B,0 ;6 (5) digit IDPB B,C TLO T,SAWDOT JRST RDNUM PAGE ;string scanner STRTAB: PCALL COMENT ;0 comment JRST RDSTR ;1 null JRST STR2 ;2 delimit IDPB A,C ;3 string element RDSTR: PCALL TYID1 LDB B,STRFLD ;A huge string (e.g. missing close-quote) JRST STRTAB(B) ; will overflow SPDL and clobber I/O bufs. STR2: PCALL TYID1 LDB B,STRFLD CAIN B,2 JRST RDSTR-1 MOVEM A,OLDCH HRRI R,STRCLS ;string LMKSTR: PCALL IDEND MSTR1: PCALL IDSUB PCALL PNAMAK HRLI A,STRNG JRST DCONSA ;identifier scanner IDTAB: PCALL COMENT ;0 JRST RDID+1 ;1 null JRST MAKID ;2 delimit PCALL TYIC ;3 ! RDID: IDPB A,C ;4 letter or digit PCALL TYID1 LDB B,IDFLD JRST IDTAB(B) PAGE ;number scanner NUMTAB: PCALL COMENT ;0 comment JRST RDNUM+1 ;1 null JRST NUMAK ;2 delimit JRST RDNDOT ;3 dot JRST RDE ;4 e IFN ROCT,JRST OCTNUM ;5 L RDNUM: IDPB A,C ;6 (5) digit PCALL TYID1 LDB B,NUMFLD JRST NUMTAB(B) RDNDOT: TLOE T,SAWDOT JRST NUMAK ;two dots - delimit MOVEI A,0 JRST RDNUM RDNMIN: TLO T,MINSGN JRST RDNUM+1 ;exponent scanner RDE: TLO T,EXP MOVEI A,0 IDPB A,C PCALL TYID1 CAIN A,"-" TLOA T,NEXP CAIN A,"+" JRST RDE2+1 JRST RDE2+2 EXPTAB: PCALL COMENT ;0 JRST RDE2+1 ;1 null JRST NUMAK ;2 delimit RDE2: IDPB A,C ;3 digit PCALL TYID1 LDB B,EXPFLD JRST EXPTAB(B) IFN ROCT,< OCTNUM: TLO T,OCTNM PCALL TYID1 LDB B,NUMFLD SOJG B,NUMAK JUMPL B,OCTNUM+1 PCALL COMENT JRST B,OCTNUM+1 > PAGE ;semantic routines ;identifier interner and builder IDEND: TDZA A,A IDEND1: IDPB A,C TLNE C,760000 JRST IDEND1 PRET MAKID: MOVEM A,OLDCH PCALL IDEND SKIPE NOINFG JRST NOINTR ;dont intern it INTER0: PCALL INTER2 ;is it in oblist PRET ;found PCALL PNAIMK ;not there MAKID2: SKIPGE C,IDCHPO# ;character id ? JRST MKID2 ;no! TRNN C,100 JRST .+3 HRLM A,IDCHTAB-100(C) JRST MKID2 HRRM A,IDCHTAB(C) MKID2: MOVE C,CURBUC HLRZ B,@RHX2 PCALL CONS ;cons it into the oblist HRLM A,@RHX2 JRST CAR CURBUC: 0 ;pname unmaker PNAMUK: MOVE C,SP PNAMUD: PCALL GETPNM PNAMU3: CARA B,(A) PUSH C,(B) CDRA A,(A) JUMPN A,PNAMU3 PRET ;idsub constructs a iowd pointer for a print name IDSUB: HRRZS C CAML C,JRELO ;top of spec pdl JRST SPDLOV MOVNS C ADDI C,(SP) HRLZS C HRRI C,1(SP) MOVEM C,IDPTR# MOVEI B,1 ANDCAM B,(C) ;clear low bit AOBJN C,.-1 PRET NOINTR: PCALL IDSUB PNAIMK: PCALL PNAMAK JRST PNGNK1 PAGE ;identifier interner INTERT: PCALL PNAMUK INTER2: PCALL IDSUB INTER1: MOVE B,1(SP) ;get first word of pname LSH B,-1 ;right justify it SETOM IDCHPO ;indicate no character id TDNE B,[1777,,777777] ;character id ? JRST INT1 ;no! MOVE T,B LSH T,-12 HLRZM T,IDCHPO ;is a character id INT1: IDIVI B,BCKETS+X ;compute hash code RHX2: FOO HLRZ T,OBTBL(B+1) ;get bucket MOVEM B+1,CURBUC ;save bucket number MOVE C,T JRST MAKID1 MAKID3: MOVE C,T ;save previous atom CDRA T,(T) ;get next atom MAKID1: JUMPE T,CPOPJ1 ;not in oblist CARA A,(T) ;next id in oblist FOO MOVEI B,PNAME PCALL IGET JUMPE A,[ERRL2 ^D167,[SIXBIT \MISSING PRINT NAME IN OBLIST!\]] MOVE D,IDPTR ;found pname MAKID5: JUMPE A,MAKID3 ;not the one MOVS A,(A) MOVE B,(A) CAME B,(D) JRST MAKID3 ;not the one CARA A,A ;ok so far AOBJN D,MAKID5 JUMPN A,MAKID3 ;not the one CARA A,(T) ;this is it CARA B,(C) RPLCA A,(C) RPLCA B,(T) PRET ;pname builder PNAMAK: MOVE T,IDPTR MOVEI TT,C PNAMB: MOVE A,(T) PCALL FWCONS PCALL NCONS RPLCD A,(TT) MOVE TT,A AOBJN T,PNAMB RETC: HRRZ A,C PRET PAGE ;number builder NUMAK: MOVEM A,OLDCH HRRI R,NUMCLS ;number MOVEI A,0 IDPB A,C IDPB A,C HRRZS C CAML C,JRELO ;top of spec pdl JRST SPDLOV MOVSI C,(POINT 7,0,35) HRRI C,(SP) TLNE T,SAWDOT+EXP JRST NUMAK2 ;decimal number or flt pt FOO MOVE A,VIBASE ;ibase integrer SUBI A,INUM0 IFN ROCT,<TLNE T,OCTNM MOVEI A,10 ;octal number > PCALL NUM NUMAK4: MOVEI B,FIXNU NUMAK6: TLNE T,MINSGN MOVNS A JRST MAKNUM NUMAK2: PCALL NUM10 MOVEM A,TT TLNN T,SAWDOT JRST [PCALL FLOAT1 ;flt pt without fraction MOVE TT,A JRST NUMAK3] PCALL NUM10 ;fraction part EXCH A,TT TLNN T,EXP JUMPE AR5,NUMAK4 ;no exponent and no fraction PCALL FLOAT1 EXCH A,TT PCALL FLOAT1 MOVEI AR4,FT01 PCALL FLOSUB FMPR A,B FADRM A,TT NUMAK3: PCALL NUM10 ;exponent part MOVE AR5,A MOVEI AR4,FT-1 TLNE T,NEXP MOVEI AR4,FT01 ;-exponent PCALL FLOSUB FMPR TT,B ;positive exponent MOVEI B,FLONU MOVE A,TT JFCL 10,FLOOV JRST NUMAK6 PAGE FLOSUB: MOVSI B,(1.0) TRZE AR5,1 FMPR B,(AR4) JUMPE AR5,CPOPJ LSH AR5,-1 SOJA AR4,FLOSUB+1 ;variable radix integer builder NUM10: MOVEI A,TEN NUM: HRRM A,NUM1 JFCL 10,.+1 ;clear carry0 flag SETZB A,AR5 NUM2: ILDB B,C JUMPE B,CPOPJ ;done NUM1: IMULI A,X ADDI A,-"0"(B) NUM3: JFCL 10,RDBNM AOJA AR5,NUM2 PAGE INTERN: MOVEM A,AR5 PCALL INTERT ;is it in oblist PRET ;found it MOVE A,AR5 ;not there CARA B,(A) CAIE B,STRNG JRST MAKID2 ;put it there CDRA A,(A) PCALL PNGNK1 ;make an id of it JRST MAKID2 REMOB: JUMPE A,CPOPJ ;never remove NIL JSP D,NILID ;return NIL if not an id PSAVE A PCALL INTERT SKIPA B,CURBUC JRST POPAJ ;not on oblist RHX5: FOO HLRZ C,OBTBL+X(B) CARA T,(C) CAMN T,A JRST [CDRA TT,(C) HRLM TT,@RHX5 JRST POPAJ] REMOB3: MOVE TT,C CDRA C,(C) CARA T,(C) CAME T,A JRST REMOB3 CDRA T,(C) RPLCD T,(TT) SKIPGE C,IDCHPO ;character id ? JRST POPAJ ;no! TRNN C,100 JRST .+3 HRRZM IDCHTAB-100(C) JRST POPAJ HLLZM IDCHTAB(C) POPAJ: PREST A PRET ;Get print name for identifier or string. Return with skip if sucessful. GETPNM: JSP D,ATMTYP JRST .+2 NOPNAM: ERRL0 ^D134,[SIXBIT /NO PRINT NAME!/] CDRA A,(A) CAIN TT,STRNG ;is it a string? JUMPN A,CPOPJ ;yes CAIE TT,ID JRST NOPNAM FOO MOVEI B,PNAME PCALL GET4 JUMPE A,NOPNAM ;didn't find it CARA A,D PRET PAGE ;return NIL if argument is not on the oblist .INTERNP:JSP D,NILID ;return NIL if not an id MOVE AR5,A PCALL GT1PNM ;get first word of pname MOVE B,A LSH B,-1 XCT INT1 ;compute hash code XCT INT1+1 ;get bucket EXCH A,T MOVE B,AR5 JRST FLAGP1 ;SKIPTO subr 1 arg. Skips reading until found character that matches ; first character in the argument SKIPTO: MOVEI AR4,1 PSAVE A PCALL GTFCH PCALL COMM-1 ;read as comment JRST POPAJ RDSLSH: MOVE D,[POINT 18,NQUOT] MOVE R,[POINT 7,[ASCIZ "%'!@/<>["]] MOVEI B,(5B3+2B6+3B8+4B11+2B14) ;Letter JUMPN A,RDSL2 MOVEI B,(3B8) ;Comment AOJA D,RDSL2 RDSL1: DPB B,[POINT 18,CHRTAB(A),19] ILDB B,D RDSL2: ILDB A,R JUMPN A,RDSL1 JRST SCANSET NQUOT: <5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35> <2B3+2B6+3B8+4B11+2B14+5B17>+<4B21+2B24+3B26+3B29+2B32+0B35> <5B3+2B6+3B8+4B11+2B14+0B17>+<5B21+2B24+3B26+4B29+2B32+0B35> <2B3+2B6+3B8+2B11+2B14+2B17>+<2B21+2B24+3B26+2B29+2B32+3B35> <2B3+2B6+3B8+2B11+2B14+6B17> PAGE ; SCAN -- GENERAL PURPOSE ADAPTER FOR LISP SCANNER OLDSCN: CRLF ;IGEND DBLQT ;STRBEG DBLQT ;STREND XWD PRIN3,"!" ;SLSH POINT 1,CHRTAB(A),1 ;SL1FLD POINT 4,CHRTAB(A),5 ;RATFLD POINT 2,CHRTAB(A),10 ;STRFLD POINT 3,CHRTAB(A),13 ;IDFLD IGEND2: CRLF+X ;IGEND STRBE2: DBLQT ;STRBEG STREN2: DBLQT ;STREND SLSH2: XWD PRIN3C,"!"+X ;SLSH SL1F2: POINT 1,CHRTAB(A),35 ;SL1FLD RATF2: POINT 4,CHRTAB(A),29 ;RATFLD STRF2: POINT 2,CHRTAB(A),31 ;STRFLD IDF2: POINT 3,CHRTAB(A),34 ;IDFLD LETFLD: POINT 1,CHRTAB(A),32 ;ON IF LETTER OR DIGIT ALLFLD: POINT 10,CHRTAB(A),35 ;ALL NEW FIELDS SCANSET:JUMPN A,.+2 SKIPA B,[XWD OLDSCN,IGEND] MOVE B,[XWD IGEND2,IGEND] BLT B,IDFLD EXCH A,OLSCNV# ;Get previous setting PRET PRIN3C: LDB B,LETFLD JRST PRIN2N(B) PAGE SCAN: SETOM NOINFG PCALL RATOM SKIPA PCALL READCH+1 FOO MOVEM A,SCNV MOVEI A,INUM0(R) PRET UNREADCH: PSAVE A PCALL GTFCH MOVEM A,OLDCH JRST POPAJ LETTER: MOVEI B,5B29+3B31+4B34+1B35 LET2: SUBI A,INUM0 DPB B,ALLFLD JRST FALSE DELIMITER: SKIPA B,[2B29+3B31+2B34+0B35] ;A DELIMITER, NOT A LETTER. IGNORE: MOVEI B,3B29+3B31+2B34+0B35 JRST LET2 PAGE SCANINIT: SUBI A,INUM0 SUBI B,INUM0 HRRM A,IGST2 ;IGSTRT MOVEM B,IGEND2 ;IGEND MOVEI B,2B29+3B31+2B34+0B35 ;DELIMITER MOVEI A,177 DPB B,ALLFLD SOJG A,.-1 MOVE A,[XWD "A"-"Z"-1,"A"] MOVEI B,5B29+3B31+4B34+1B35 ;LETTER DPB B,ALLFLD AOBJN A,.-1 MOVE A,[XWD "a"-"z"-1,"a"] DPB B,ALLFLD AOBJN A,.-1 MOVE A,[XWD "0"-"9"-1,"0"] MOVEI B,8B29+3B31+4B34+0B35 ;DIGIT DPB B,ALLFLD AOBJN A,.-1 IGST2: MOVEI A,X MOVEI B,0 ;IGSTRT DPB B,ALLFLD MOVEI A,-INUM0(AR4) ;STREND MOVEM A,STREN2 MOVEI B,2 DPB B,STRF2 MOVEI A,-INUM0(C) ;STRBEG MOVEM A,STRBE2 MOVEI B,9 DPB B,RATF2 MOVEI A,-INUM0(AR5) HRRM AR5,SLSH2 ;SLASHIFIER MOVEI B,4B29+3B31+3B34+0B35 ;SLASHIFIER DPB B,ALLFLD MOVEI A,0 ;NULL MOVEI B,1B29+1B31+1B34+0B35 ;NULL DPB B,ALLFLD MOVEI A,"." MOVEI B,7 DPB B,RATF2 SETZM CHRTAB+IGCRLF ;^Z IS ALWAYS A COMMENT-CHAR. JRST FALSE SUBTTL LISP INTERPRETER SUBROUTINES --- PAGE 11 IF1,PURGE CDR CADDDR: SKIPA A,(A) CADDAR: CARA A,(A) CADDR: SKIPA A,(A) CADAR: CARA A,(A) CADR: SKIPA A,(A) CAAR: CARA A,(A) CAR: CARA A,(A) PRET CDDDDR: SKIPA A,(A) CDDDAR: CARA A,(A) CDDDR: SKIPA A,(A) CDDAR: CARA A,(A) CDDR: SKIPA A,(A) CDAR: CARA A,(A) CDR: CDRA A,(A) PRET CAADDR: SKIPA A,(A) CAADAR: CARA A,(A) CAADR: SKIPA A,(A) CAAAR: CARA A,(A) JRST CAAR CDADDR: SKIPA A,(A) CDADAR: CARA A,(A) CDADR: SKIPA A,(A) CDAAR: CARA A,(A) JRST CDAR CAAADR: SKIPA A,(A) CAAAAR: CARA A,(A) JRST CAAAR CDDADR: SKIPA A,(A) CDDAAR: CARA A,(A) JRST CDDAR CDAADR: SKIPA A,(A) CDAAAR: CARA A,(A) JRST CDAAR CADADR: SKIPA A,(A) CADAAR: CARA A,(A) JRST CADAR RPLACA: RPLCA B,(A) PRET RPLACD: RPLCD B,(A) PRET PAGE QUOTE: CARA A,(A) ;car and quote duplicated for backtrace PRET AASCII: PCALL NUMVAL LSH A,^D29 PNGNK2: PCALL BNCONS PNGNK1: FOO HRLI A,PNAME PCALL DCONSA PCALL NCONS IDCONS: HRLI A,ID JRST DCONSA NCONS: HRLZS A JRST DCONSA CONS: EXCH B,A XCONS: HRL A,B DCONSA: IFN CNSPRB,< CAIN F,ILLAD PCALL AGC> EXCH A,(F) EXCH A,F AOS CONSVAL PRET FW0CNS: MOVEI A,0 FWCONS: JUMPN FF,FWC1 EXCH A,FWC0# PCALL AGC EXCH A,FWC0 FWC1: EXCH A,(FF) EXCH A,FF PRET PAGE IFE STL,< SASSOC: PCALL SAS1 JCALLF 0,(C) PRET SAS0: CARA B,T SAS1: JUMPE B,CPOPJ MOVS T,(B) MOVS TT,(T) CAIE A,(TT) JRST SAS0 CDRA A,T JRST CPOPJ1 ATSOC: PCALL SAS1 JRST FALSE > ;end of IFE STL IFN STL,< ATSOC: EXCH A,B PCALL GET4 SKIPE A CDRA A,TT > PRET REVERSE:SKIPN T,A PRET MOVEI A,NIL HLL A,(T) CDRA T,(T) PCALL DCONSA JUMPN T,.-3 CPOPJ: PRET LENGTH: MOVEI B,0 LNGTH1: JSP D,ATMTYP JRST FIX1 CDRA A,(A) AOJA B,LNGTH1 LAST: MOVE C,A CDRA A,(A) JSP D,NATMTYP JRST LAST JRST RETC NATMTYP:SETZ TT, CAILE A,INUMIN JRST 1(D) CARA TT,(A) CAILE TT,ATMIN JRST 1(D) JRST (D) PAGE PATOM: MOVEI D,TRFA PATMTP: JUMPE A,NILIN SETZ TT, CAILE A,INUMIN JRST (D) ;inum CAIGE A,@GCP1 ;Base of FWS CAIGE A,@GCPP1 ;Base of FS SOJA TT,(D) ;not a Lisp cell NILIN: CARA TT,(A) CAILE TT,ATMIN JRST (D) ;atom JRST 1(D) ATOM: MOVEI D,TRFA ATMTYP: SETZ TT, CAILE A,INUMIN JRST (D) ;inum CARA TT,(A) CAILE TT,ATMIN JRST (D) ;atom JRST 1(D) PAIRP: JSP D,ATMTYP MOVEI A,NIL PRET CONSTANTP:JSP D,ATMTYP CAIN TT,ID MOVEI A,NIL PRET STRINGP:JSP D,ATMTYP CAIE TT,STRNG MOVEI A,NIL PRET NUMBERP:JSP D,ATMTYP CAILE TT,FLONU FALSE: MOVEI A,NIL PRET FIXP: JSP D,ATMTYP CAILE TT,FIXNU MOVEI A,NIL PRET FLOATP: JSP D,ATMTYP CAIE TT,FLONU MOVEI A,NIL PRET INUMP: CAIG A,INUMIN MOVEI A,NIL PRET PAGE BIGP: JSP D,ATMTYP CPOSNU: CAILE TT,POSNU JRST FALSE JUMPE TT,FALSE PRET IDP: MOVEI D,TRUE NILID: CAILE A,INUMIN JRST FALSE HLLE TT,(A) AOJE TT,(D) JRST FALSE ;return NIL if not an id ;give error if not id CHKID: CAILE A,INUMIN JRST NOID HLLE TT,(A) AOJE TT,(D) NOID: ERRE1 ^D25,[SIXBIT /IS NOT AN IDENTIFIER!/] EQ: CAMN A,B TRFA: JRST TRUE JRST FALSE ZEROP: JSP D,ONUMV JRST FALSE ;BIGNUM CAN'T BE ZERO NOT: NULL: JUMPN A,FALSE TRUE: FOO MOVEI A,TRUTH PRET LITER: PCALL .INTERNP JUMPE A,CPOPJ ROT T,7 CAIL T,"A" CAILE T,"z" JRST FALSE CAILE T,"Z" CAIL T,"a" JRST RETB JRST FALSE DIGIT: PCALL .INTERNP JUMPE A,CPOPJ ROT T,7 CAIL T,"0" CAILE T,"9" JRST FALSE JRST RETB PAGE IF1,<PURGE GET> ;MONSYM has defined GET, so purge it. GETD: FOO MOVEI B,FUNCELL GET: JSP D,NILID ;return NIL if not id IGET: PCALL GET1 SKIPE A GET2: CARA A,D PRET GET1: CDRA A,(A) GET4: JUMPE A,CPOPJ GET0: MOVS TT,(A) MOVS D,(TT) CAIN B,(D) PRET CARA A,TT JUMPN A,GET0 PRET IFE STL,< GETL: CDRA A,(A) GETL0: CARA T,(A) CARA T,(T) MOVE C,B GETL1: MOVS TT,(C) CAIN T,(TT) JRST CAR CARA C,TT JUMPN C,GETL1 CDRA A,(A) JUMPN A,GETL0 PRET > REMD: FOO MOVEI B,FUNCELL REMPROP:JSP D,NILID ;return NIL if not id REMP1: MOVE T,A CDRA A,(T) JUMPE A,CPOPJ ;we are done if it is not there MOVS TT,(A) MOVS D,(TT) CAIE B,(D) JRST REMP1 HLRM TT,(T) JUMPN T,GET2 HLROM TT,CNIL3 ;reset NIL JRST GET2 PAGE PUTD: EXCH A,C IPUTD: PCALL XCONS EXCH A,C FOO MOVEI B,FUNCELL PUT: JSP D,CHKID MOVE T,A MOVE A,B JSP D,CHKID MOVE A,T PCALL GET1 JUMPN A,CSET1 MOVE A,C PCALL XCONS CDRA B,(T) PCALL CONS RPLCD A,(T) JUMPN T,CDAR RPLCD A,CNIL3 ;set NIL JRST CDAR CSET1: FOO CAIN B,VALUE CARA TT,D RPLCD C,(TT) JRST RETC IFE STL,< DEFPROP: CDRA C,(A) CDRA B,(C) CARA A,(A) CARA B,(B) CARA C,(C) PSAVE A PCALL PUT JRST POPAJ > MKCODE: PCALL NUMVAL IMKCODE:HRLI A,CODE JRST DCONSA CODEP: JSP D,ATMTYP CAIGE TT,CODMIN JRST FALSE CAIL TT,ID MOVEI A,NIL PRET PAGE FLAGP: JSP D,NILID CDRA A,(A) FLAGP1: PCALL MEMQ+1 JUMPN A,TRUE PRET FLAG: MOVEI D,FLAG1 FLAGO: HRRM D,FLAGX MOVE T,A MOVE A,B JSP D,CHKID ;flag indicator must be id FLAGL: JUMPE T,FALSE CARA A,(T) FLAGX: PCALL X CDRA T,(T) JRST FLAGL FLAG1: JSP D,CHKID ;may only flag id CDRA A,(A) PCALL MEMQ+1 JUMPN A,CPOPJ CARA C,(T) CDRA A,(C) PCALL XCONS FLAG2: RPLCD A,(C) JUMPN C,CPOPJ RPLCD A,CNIL3 PRET REMFLAG:JSP D,FLAGO JSP D,NILID FLAG3: MOVE C,A CDRA A,(C) JUMPE A,CPOPJ CARA D,(A) CAIE B,(D) ;B is preserved by XCONS JRST FLAG3 CDRA A,(A) JRST FLAG2 PAGE EQUAL: MOVE C,P ;Unfortunately, if BIGNUMs are involved here, EQUAL1: CAMN A,B ; potential AGC so save your variables. JRST TRUE JSP D,PATMTP SKIPA T,TT ;ATOM HRROI T,(TT) EXCH A,B JSP D,PATMTP JRST EQLATM ;ATOM AOJGE T,NOEQL ;not atom but first arg was PSAVE A PSAVE B CDRA A,TT CARA B,(B) PCALL EQUAL1 PREST B PREST A CDRA A,(A) CDRA B,(B) JRST EQUAL1 EQLATM: CAME T,TT ;same atom type ? JRST NOEQL ;no, try for floating point JUMPLE TT,NOEQL ;Inum and non lisp cell adresses must be EQ CAILE TT,POSNU ;Bignum CAIN TT,STRNG JRST EQS CAIN TT,VECT JRST EQV CDRA A,(A) CDRA B,(B) MOVE A,(A) CAMN A,(B) JRST TRUE NOEQL: MOVE P,C JRST FALSE PAGE EQS: CDRA D,(A) CDRA TT,(B) EQS2: JUMPE D,NOEQL MOVS D,(D) MOVS TT,(TT) MOVE B,(TT) CAME B,(D) JRST NOEQL HLRZS D HLRZS TT JUMPN TT,EQS2 JUMPN D,NOEQL JRST TRUE EQV: CDRA TT,(A) CDRA D,(B) MOVE B,-1(TT) CAME B,-1(D) JRST NOEQL ;different size PSAVE B HRLI TT,(POINT 18) PSAVE TT HRLI D,(POINT 18) PSAVE D EQV2: ILDB A,(P) ILDB B,-1(P) PCALL EQUAL1 SOSL -2(P) JRST EQV2 P3DROP JRST TRUE PAGE SUBAS==EXARG SUBBS==EXARG+1 SUBST: MOVEM A,SUBAS# ;Recurse..find subportion in C =B, and MOVEM B,SUBBS# ; re-CONS with A instead. SUBS0: MOVE A,SUBAS MOVE B,SUBBS PSAVE C MOVE A,C PCALL EQUAL PREST C JUMPN A,SUBS3 CAILE C,INUMIN JRST SUBS1 CARA T,(C) CAILE T,ATMIN JRST SUBS1 PSAVE C CARA C,(C) PCALL SUBS0 EXCH A,(P) CDRA C,(A) PCALL SUBS0 PREST B JRST XCONS SUBS1: SKIPA A,C SUBS3: HRRZ A,SUBAS PRET PAGE NCONC: JUMPE A,PROG2 MOVE TT,A MOVE C,TT CDRA TT,(C) JUMPN TT,.-2 RPLCD B,(C) PRET APPEND: JUMPE A,PROG2 MOVEI C,AR4 MOVE TT,A APP1: CARA A,(TT) PSAVE B PCALL CONS ;saves b PREST B RPLCD A,(C) MOVE C,A CDRA TT,(TT) JUMPN TT,APP1 JRST RETAR4 PROGN: SKIPN B,A PRET PROGN1: PSAVE B CARA A,(B) PCALL EVAL PREST B COND2: SKIPL C,PA4 JRST RETC ;exit if a RETURN was found CDRA B,(B) SKIPL PA3 ;exit if a GO was found JUMPN B,PROGN1 PRET PAGE MEMBER: MOVEM A,SUBAS MEMB1: JUMPE B,FALSE MOVE A,SUBAS PSAVE B CARA B,(B) PCALL EQUAL AJMN: JUMPN A,POPAJ PREST B CDRA B,(B) JRST MEMB1 MEMQ: EXCH A,B JUMPE A,CPOPJ MOVS C,(A) CAIN B,(C) PRET CARA A,C JUMPN A,MEMQ+2 PRET AND: JUMPE A,TRUE SKIPA C,AJMN OR: MOVSI C,(JUMPE A,) JUMPE A,CPOPJ HRRI C,ANDOR PSAVE A PSAVE C JRST ANDORI ANDOR: EXCH A,-1(P) CDRA A,(A) JUMPE A,POP1AJ MOVEM A,-1(P) ANDORI: CARA A,(A) PCALL EVAL XCT (P) POP2J: P2DROP PRET POP1AJ: P1DROP JRST POPAJ PAGE GENSYM: MOVE B,[POINT 7,GNUM,34] MOVNI C,4 MOVEI TT,"0" GENSY2: LDB T,B AOS T DPB T,B CAIG T,"9" JRST GENSY1 DPB TT,B ADD B,[XWD 70000,0] AOJN C,GENSY2 GENSY1: MOVE A,GNUM PCALL FWCONS PCALL NCONS JRST PNGNK1 GNUM: ASCII /G0000/ ;* IFE STL,< CSYM: CARA A,(A) PSAVE A PCALL GT1PNM MOVEM A,GNUM JRST POPAJ > GT1PNM: PCALL GETPNM CARA A,(A) MOVE A,(A) PRET PAGE LIST: FOO MOVEI B,CEVAL JRST MAPCAR ILIST: MOVEI T,0 JUMPE A,ILIST2 ILIST1: PSAVE A ;Evals list, leaving on P, & neg # in T. CARA A,(A) PSAVE TT HRLM T,(P) PCALL EVAL ILIST3: PREST TT HLRE T,TT EXCH A,(P) CDRA A,(A) SOS T JUMPN A,ILIST1 ILIST2: JRST (TT) MAPCAN: TLO B,400000 MAPCON: TLOA B,100000 MAPCAR: TLO B,400000 MAPLIST:TLOA B,200000 MAPC: TLO B,400000 MAP: JUMPE A,FALSE PSAVE A HLLM B,(P) HRLI B,(FCALL 1,) PSAVE B PSAVE A HRLZM P,(P) MAPL2: SKIPGE -2(P) CARA A,(A) ;MAPC or MAPCAR. XCT -1(P) LDB C,[POINT 2,-2(P),2] JUMPE C,MAP1 TRNN C,1 PCALL NCONS JUMPE A,MAP1 ;Case of NIL returned in MAPCAN, MAPCON HLR B,(P) RPLCD A,(B) TRNE C,1 PCALL LAST HRLM A,(P) MAP1: CDRA A,@-2(P) HRRM A,-2(P) JUMPN A,MAPL2 PREST AR4 P2DROP JRST RETAR4 PAGE PA3: 0 ;lh=0=>rh =next prog statement * ;lh - =>rh = tag to go to PA4: -1,,0 ;lh=-1,rh=pntr to prog less bound var list * ;lh=+,rh return value PROG: PSAVE PA3 PSAVE PA4 CARA T,(A) CDRA A,(A) HRROM A,PA4 MOVEM A,PA3 PUSH SP,[0] ;mark for unbind JUMPE T,PG0 PG7A: CARA A,(T) MOVEI AR4,NIL PCALL BIND CDRA T,(T) JUMPN T,PG7A PG0: SKIPA T,PA3 PG5A: MOVE T,A PG1: JUMPE T,PG2 CARA A,(T) CDRA T,(T) CARA B,(A) CAILE B,ATMIN JRST PG1 MOVEM T,PA3 PCALL EVAL SKIPL A,PA4 JRST PG4 ;return SKIPL T,PA3 JRST PG1 PG5: JUMPE A,EG1 CARA TT,(A) CDRA A,(A) CAIN TT,(T) JRST PG5A ;found tag JRST PG5 PG2: TDZA A,A PG4: HRRZS A PCALL UNBIND ERRP4: PREST PA4 PREST PA3 PRET GO: CARA A,(A) HRROM A,PA3 IFE STL,<CARA B,(A) CAILE B,ATMIN> JRST FALSE IFE STL,<PCALL EVAL JRST GO+1> PAGE RETURN: HRRZM A,PA4 PRET SETQ: CARA B,(A) PSAVE B PCALL CADR PCALL EVAL MOVE B,A PREST A SET: MOVE AR4,B PCALL BIND SUB SP,[XWD 1,1] RETAR4: CDRA A,AR4 PRET CON2: CDRA A,(T) COND: JUMPE A,CPOPJ ;entry PSAVE A CARA A,(A) CARA A,(A) PCALL EVAL PREST T JUMPE A,CON2 CARA B,(T) JRST COND2 EG1: HRRZ A,T ERRE1 ^D26,[SIXBIT /UNDEFINED PROG TAG-GO!/] SUBTTL ARITHMETIC SUBROUTINES --- PAGE 12 IFE STL,< ;macro expander -- (foo a b c) is expanded into (*foo (*foo a b) c) EXPAND: MOVE C,B CDRA A,(A) PCALL REVERSE JRST EXPA1 EXPN1: MOVE C,B EXPA1: CDRA T,(A) CARA A,(A) JUMPE T,CPOPJ PSAVE A MOVE A,T PCALL EXPA1 EXCH A,(P) PCALL NCONS PREST B PCALL XCONS HRL A,C JRST DCONSA > PAGE ADD1: CAILE A,INUMIN CAILE A,ATMIN-1 SKIPA B,[INUM0+1] AOJA A,CPOPJ .PLUS: JSP C,OP ADD A,TT FADR A,TT JRST BPLUS SUB1: CAILE A,INUMIN+1 CAILE A,ATMIN SKIPA B,[INUM0+1] SOJA A,CPOPJ .DIF: JSP C,OP SUB A,TT FSBR A,TT JRST BDIF .TIMES: JSP C,OP IMUL A,TT FMPR A,TT JRST BTIMES .QUO: CAIN B,INUM0 JRST ZERODIV JSP C,OP IDIV A,TT FDVR A,TT JRST BQUO .GREAT: EXCH A,B JUMPE B,FALSE .LESS: JUMPE A,CPOPJ CAIN B,INUM0 JRST MINUSP JSP C,OP JRST COMP2 JRST COMP2 JRST BCMPR COMP2: CAML A,TT JRST FALSE JRST TRUE PAGE MAKNUM: CAIN B,FIXNU JRST FIX1A FLO1A: MOVEI B,FLONU JRST FQCONS FIX1B: SUBI A,INUM0 MOVEI B,FIXNU FQCONS: PCALL FWCONS JRST XCONS IF1,PURGE NUMVAL ;To avoid confusion with NUMVAL in STENEX NUMVLX: JFCL 17,.+1 ONUMV: MOVEI B,FIXNU CAILE A,INUMIN JRST ONUMV1 CARA B,(A) CAILE B,ATMIN CAILE B,FLONU NUMV2: ERRE1 ^D27,[SIXBIT /IS NOT A NUMBER!/] CDRA A,(A) CAIG B,POSNU JRST (D) ;Normal return if bignum SKIPA A,(A) ONUMV1: SUBI A,INUM0 JRST 1(D) ;Return with skip if fixnum or flonum NUMVAL: CAILE A,INUMIN JRST FIXV1 CARA D,(A) CAIE D,FIXNU ERRE2 ^D46,[SIXBIT /IS NOT A WORD SIZE INTEGER/] CDRA A,(A) FIXV2: SKIPA A,(A) FIXV1: SUBI A,INUM0 PRET PAGE FLOAT: PSAVE A JSP D,ONUMV JRST BFLOT CAIN B,FLONU JRST POPAJ MOVEI D,FLO1A MOVEM D,(P) FLOAT1: IDIVI A,400000 SKIPE A TLC A,254000 TLC B,233000 FADR A,B PRET FIX: PSAVE A JSP D,ONUMV JRST POPAJ ;BIGNUM CAIE B,FLONU JRST POPAJ MOVEM A,(P) MULI A,400 TSC A,A JFCL 17,.+1 ASH B,-243(A) FIX2: JFCL 10,BFIX P1DROP FIX1: MOVE A,B JRST FIX1A MINUSP: JSP D,ONUMV JRST MINSP2 ;BIGNUM JUMPGE A,FALSE JRST TRUE MINUS: JSP D,NUMVLX JRST MINS2 ;BIGNUM MOVNS A ABS2IN: JFCL 10,FIXOV3 JRST MAKNUM ABS: JSP D,NUMVLX JRST ABS2 MOVMS A JRST ABS2IN PAGE DIVIDE: CAIN B,INUM0 JRST ZERODIV JSP C,OP JRST RDIV JRST ILLNUM JRST BDIV RDIV: JFCL 17,.+1 IDIV A,TT JFCL 10,DIVMB ;FREAK CASE OF -2**35 IN A. PSAVE B PCALL FIX1A EXCH A,(P) PCALL FIX1A PREST B JRST XCONS REMAINDER: PCALL DIVIDE JRST CDR FIXOV: ERRL0 ^D135,[SIXBIT /INTEGER OVERFLOW!/] ZERODIV:ERRL0 ^D136,[SIXBIT /ZERO DIVISOR!/] FLOOV: ERRL0 ^D137,[SIXBIT /FLOATING OVERFLOW!/] ILLNUM: ERRL0 ^D138,[SIXBIT /NON-INTEGRAL OPERAND!/] GCD: JSP C,OP JRST GCD2 JRST ILLNUM JRST BGCD GCD2: JFCL 17,.+1 MOVMS A MOVMS TT JFCL 10,DIVMB ;FREAK CASE OF -2**35 IN A OR TT. ;euclid's algorithm GCD3: CAMG A,TT EXCH A,TT JUMPE TT,FIX1A IDIV A,TT MOVE A,B JRST GCD3 DIVMB: MOVEI B,FIXNU PCALL BIGTSB JRST @2(C) PAGE ;general arithmetic op code routine for mixed types OP: CAIG A,INUMIN JRST OPA1 SUBI A,INUM0 CAIG B,INUMIN JRST OPA2 HRREI TT,-INUM0(B) XCT (C) ;inum op (cannot cause overflow) FIX1A: ADDI A,INUM0 CAILE A,INUMIN CAILE A,ATMIN JRST FIX1B PRET NONUM1: MOVE A,TT OPA1: CARA T,(A) CAILE T,ATMIN CAILE T,FLONU JRST NUMV2 ;A is not a number CDRA A,(A) CAIE T,FIXNU JRST OPA6 SKIPA A,(A) OPA2: ;first arg is a FIXNUM MOVEI T,FIXNU CAILE B,INUMIN JRST OPB2 MOVE TT,B CARA B,(B) CAILE B,ATMIN CAILE B,FLONU JRST NONUM1 ;TT is not a number CDRA TT,(TT) CAIE B,FIXNU JRST OPA5 SKIPA TT,(TT) OPB2: HRREI TT,-INUM0(B) MOVE AR4,A ;<MOVEI B,FIXNU> supplied by DIVMB. JFCL 17,.+1 XCT (C) ;fixed pt op OPOV: JFCL 10,FIXOVL JRST FIX1A OPA6: CAILE B,INUMIN ;first arg is not FIXNUM JRST OPB7 CDRA TT,(B) CARA B,(B) CAIE B,FLONU JRST OPB3 ;second arg is not a FLONUM CAIN T,FLONU ;second arg is FLONUM; test first arg SKIPA A,(A) PCALL BFLT ;not a FLONUM, must be BIGNUM; float it MOVE TT,(TT) OPR: JFCL 17,.+1 XCT 1(C) ;flt pt op JFCL 10,FLOOV JRST FLO1A PAGE OPA5: ;first arg is FIXNUM but second arg is not CAIE B,FLONU ;is second arg a FLONUM JRST BIGOP ;no. it must be a bignum PCALL FLOAT1 JRST OPR-1 OPB3: ;first arg is not fixnum, second arg is not flonum CAIE B,FIXNU ;is second arg FIXNUM ? JRST OPB9 ;no. it must be bignum SKIPA TT,(TT) OPB7: HRREI TT,-INUM0(B) MOVEI B,FIXNU CAIE T,FLONU JRST BIGOP MOVE A,(A) EXCH A,TT PCALL FLOAT1 OPB8: EXCH A,TT JRST OPR OPB9: ;second arg is bignum CAIE T,FLONU ;is first arg a FLONUM ? JRST BIGOP ;no MOVE A,(A) EXCH A,TT EXCH B,T PCALL BFLT JRST OPB8 BIGOP: PCALL BIGTST JRST @2(C) SUBTTL BIGNUM ARITHMETIC ROUTINES --- PAGE 13 ;Power of ten PWR10: MOVEM B,BASEX# MOVE C,B IMUL B,B ;BASE^2 IMUL B,B ;BASE^4 IMUL B,C ;BASE^5 IMUL B,B ;BASE^ten MOVEM B,BASE10# PRET B0CONS: MOVEI A,0 BNCONS: MOVEI B,0 BCONS: PCALL FWCONS JRST CONS ;Bignum PRINT BPRI: XCT "-",CTY PCALL COPY FOO MOVE B,VBASE SUBI B,INUM0 PCALL PWR10 PCALL BPRJ MOVE C,BASEX JRST PRINI4 BPRJ: MOVE B,BASE10 PCALL Q1 JUMPE B,BPR2 ;zero quotient PSAVE A ;remainder MOVE A,B ;quotient PCALL BPRJ PREST A ;remainder BPR1: MOVEI C,TEN ;print ten digits SOJL C,CPOPJ IDIV A,BASEX HRLM B,(P) PCALL BPR1+1 JRST FP7A1 ;particular TYO for digit ;Ignore leading zero digits for first word BPR2: JUMPE A,CPOPJ IDIV A,BASEX HRLM B,(P) PCALL BPR2 JRST FP7A1 ;particular TYO for digit PAGE ;Divides bignum in A by integer in B ;Destroys original bignum ;Returns remainder in A, quotient in B .Q1: Q1: MOVEM B,Y# PSAVE A CDRA A,(A) JUMPE A,Q1A PCALL Q1+1 PREST C RPLCD B,(C) CARA T,(C) MOVE B,(T) DIV A,Y Q1B: MOVEM A,(T) ;replace old digit MOVE A,B MOVE B,C PRET Q1A: PREST C CARA T,(C) MOVE A,(T) IDIV A,Y JUMPN A,Q1B ;non-zero quotient - keep it HRRZM FF,(T) ;reclaim full word MOVE FF,T HRRZM F,(C) ;reclaim free word HRRZ F,C MOVEI C,0 JRST Q1B+1 PAGE ;Bignum READ RDBNM: PSAVE [NIL] ;initial value of bignum MOVSI C,700 HRRI C,(SP) ;byte pointer to spec pdl MOVEM T,TSAV# MOVEM C,RDPTR# HRRZ B,NUM1 ;base of number PCALL PWR10 RDNM1: MOVEI C,TEN ;ten digits at a time MOVEI A,0 ILDB B,RDPTR JUMPE B,RDNM2 ;end of bignum IMUL A,BASEX ADDI A,-"0"(B) SOJG C,.-4 MOVE B,BASE10 PCALL RDSUB JRST RDNM1 RDNM2: CAIN C,TEN ;no digits in last superdigit JRST RDNM3 HRREI C,-TEN(C) ;number of digits in last MOVEI B,1 IMUL B,BASEX AOJL C,.-1 ;compute basex^(number of digits) PCALL RDSUB RDNM3: LDB B,[POINT 1,TSAV,14] ;MINSGN TRC B,POSNU ;sign of bignum PREST A P1DROP JRST XCONS RDSUB: MOVE C,-1(P) PCALL BTIME1 ;bignum(C)*int(B)+int(A) MOVEM A,-1(P) PRET PAGE BTIME0: PSAVE B PCALL COPY MOVE C,A PREST B MOVEI A,0 ;big(C)*int(B)+int(A) BTIME1: JUMPE C,BNCONS ;end of bignum MOVEM B,MULR# ;multiplier PSAVE C ;bignum BT1B: MOVEM A,CARRY# MOVS T,(C) MOVE A,(T) MUL A,MULR ADD B,CARRY TLZE B,SIGN ADDI A,1 BT1E: MOVEM B,(T) ;store low order product+carry in bignum HLRZS T ;(CDR bignum) JUMPE T,BT1C ;end of bignum MOVE C,T JRST BT1B BT1C: JUMPE A,POPAJ ;no high order part PCALL BNCONS ;conses for remaining high order part RPLCD A,(C) ;RPLACD end of bignum JRST POPAJ PAGE ;Bignum copy .COPY: COPY: JUMPE A,CPOPJ CARA B,(A) PSAVE (B) CDRA A,(A) PCALL COPY MOVE B,A PREST A JRST BCONS ;Bignum reclaim RECLAIM:CAILE A,INUMIN PRET EXCH A,F EXCH A,(F) HLRZ B,A ;type HRRZS A CAIE B,POSNU CAIN B,NEGNU JRST UNCONS PRET ;BIGNUM UNCONS UNCONS: JUMPE A,CPOPJ CARA B,(A) MOVEM FF,(B) MOVE FF,B EXCH A,F EXCH A,(F) HRRZS A JRST UNCONS ;BIGNUM MINUSP MINSP2: CAIN B,POSNU JRST FALSE JRST TRUE ;BIGNUM MINUS MINS2: TRCA B,1 ABS2: MOVEI B,POSNU ;BIGNUM ABS JRST XCONS ;compare two bignums A<B BCMPR: PCALL BDIF PSAVE A PCALL MINUSP EXCH A,(P) PCALL RECLAIM JRST POPAJ PAGE ;DIFFERENCE of two bignums BDIF: TRC TT,1 ;complement sign of bignum in B ;sum of two bignums ;bignums in A and B; sign(A) in T, sign(B) in TT BPLUS: PSAVE B PCALL COPY EXCH A,(P) PCALL COPY PREST C MOVE B,A MOVEI A,0 CAME T,TT JRST BDIF1 ;signs different PSAVE T ;sign of result PCALL BADD PREST B JRST XCONS BDIF1: CAIN TT,POSNU EXCH B,C PCALL BSUB ;posnum in C, negnum in B JUMPL B,BDIF3 PCALL SUPRSS JRST MAKPOS BDIF3: PCALL COMPLM MOVEI B,NEGNU JRST MAKBIG BSUB: MOVNI TT,1 MOVSI T,(SUB TT,(B)) JRST BAS BADD: MOVEI TT,1 MOVSI T,(ADD TT,(B)) PAGE ;cry(A)(+ or -) big(B) + big(C) into A, sign into B. ;destroys both bignums BAS: HRRM TT,BCRY PSAVE B BP2A: HRRM B,BTMP MOVS B,(B) CARA TT,(C) EXCH TT,FF EXCH TT,(FF) ;reclaim full word EXCH C,F EXCH C,(F) ;reclaim free word ADD TT,A XCT T ;big(C) (+ or -) big (B) MOVEI A,0 TLZE TT,SIGN ;turn off high bit BCRY: HRREI A,. ;set carry if overflow or negative BP2B: MOVEM TT,(B) HLRZS B HRRZS C JUMPE B,BP2F ;end of B JUMPN C,BP2A JRST BP2D ;finish with carry (+ or -) big(B) BP2F: JUMPE C,BP2H ;end of C also EXCH B,C RPLCD B,@BTMP ;RPLACD end of big(B) with rest of C MOVSI T,(ADD TT,(B)) ;finish with big(C) + carry BP2D: HRRM B,BTMP MOVS B,(B) MOVE TT,A XCT T ;carry (+ or -) integer JUMPL TT,BP2K MOVEM TT,(B) CAME T,[SUB TT,(B)] JRST POSXIT ;can quit now MOVEI A,0 ;turn off carry JRST BP2L ;continue to negate BP2K: HRRE A,BCRY TLZ TT,SIGN ;make high bit zero MOVEM TT,(B) BP2L: HLRZS B JUMPN B,BP2D BP2H: JUMPLE A,XIT ;no carry PCALL BNCONS BTMP: HRRM A,. ;RPLACD end of bignum with carry POSXIT: MOVEI B,0 ;sign positive JRST POPAJ XIT: MOVE B,A ;sign in B JRST POPAJ PAGE ;suppress leading zeros from bignum SUPRSS: SKIPA C,[JRST COMPL7] ;complement bignum (2^35 complement) COMPLM: MOVSI C,(SUBM T,(B)) JUMPE A,CPOPJ PSAVE A HRLZI T,SIGN MOVEI TT,0 COMPL4: MOVS B,(A) SKIPN (B) JUMPE TT,COMPL3 XCT C HRLOI T,SIGN-1 COMPL7: SKIPE (B) MOVEM A,TT COMPL3: HLRZ A,B JUMPN A,COMPL4 ;continue JUMPE TT,COMPL5 ;all zeros CDRA A,(TT) HLLZS (TT) ;RPLACD high order non-zero with NIL COMPL6: PCALL UNCONS ;UNCONS leading zeros JRST POPAJ COMPL5: EXCH A,(P) JRST COMPL6 ;sign(TT)*sign(T) into TT MQSIGN: CAIE T,POSNU TRC TT,1 PRET PAGE ;bignum multiply ;big (A) * big (B) into A, signs in T,TT BTIMES: PCALL MQSIGN PSAVE TT ;save sign of result PCALL BMUL PREST B JRST MAKBIG ;0(P) is partial result ;-1(P) is remaining reversed multiplier ;-2(P) is multiplicand BMUL: PSAVE B PCALL REVERSE PSAVE A MOVEI A,0 PSAVE A BTLOOP: SKIPN C,-1(P) JRST BTEND ;end of multiplier JUMPE A,BTLP2 ;first time MOVE B,A PCALL FWCONS-1 PCALL CONS ;increase length of product BTLP2: MOVEM A,(P) MOVE A,-2(P) PCALL COPY MOVS B,(C) ;next multiplier digit MOVE C,A HLRZM B,-1(P) MOVE B,(B) MOVEI A,0 PCALL BTIME1 MOVE C,(P) JUMPE C,BTLOOP ;no add needed on first time MOVE B,A MOVEI A,0 PCALL BADD JRST BTLOOP BTEND: P3DROP JRST SUPRSS PAGE ;extensions of interpreter routines and tests REPEAT 0,< ;ONUMVAL for bignums goes here NUMVD2: HRRZ C,0(P) ;address of <PCALL ONUMVAL> +1 FOO CAIL C,FS ;LISP-system area of code? PRET ; No, user or BPS gets a BIGNUM-pntr back. P1DROP CAIN C,ZEROP+1 JRST FALSE CAIN C,MINUSP+1 JRST MINSP2 CAIN C,MINUS+1 JRST MINS2 CAIN C,ABS+1 JRST ABS2 CAIN C,FIX+2 JRST POPAJ CAIN C,FLOAT+2 JRST BFLOT IFN MOD,<CAIN C,CMOD+1 JRST CMOD1 > PAGE > ;number overflow, use bignums FIXOVL: MOVEI C,(C) CAIN C,.TIMES+1 JRST REMUL ;TIMES overflowed. Recompute. JUMPE A,FIXOV2 ;PLUS(mbeta mbeta) overflows 2 bits. FIXOV3: TLC A,SIGN ;all other cases just overflowed 1 bit MOVM B,A MOVE TT,A MOVEI A,1 FIXOVX: PCALL MKBG JRST XCONS FIXOV2: SETZ B, SETO TT, ;(NEGATIVE). MOVEI A,2 ;== -2*beta. JRST FIXOVX REMUL: MOVE A,AR4 MOVEI T,FIXNU PCALL BIGTSB JRST BTIMES ;use the bignum multiplication MAKPOS: MOVEI B,POSNU ;Make a LISP number from bignum -- A is list, B is sign MAKBIG: JUMPE A,FIX1A ;NULL list produces zero CDRA C,(A) JUMPN C,XCONS ;a real bignum CARA C,(A) ;only one word of precision MOVE C,(C) CAIE B,POSNU MOVNS C ;negative PCALL UNCONS MOVE A,C JRST FIX1A PAGE BIGTSB: MOVEI B,FIXNU ;Transforms general numbers in (A,T),(TT,B) ;into bignums in (A,T),(B,TT), values in A,B; signs in T,TT. BIGTST: EXCH B,T ;funny ac usage in lisp PSAVE T PSAVE TT PCALL BIGSUB ;convert number originally in A,T EXCH B,-1(P) EXCH A,(P) PCALL BIGSUB ;convert number originally in TT,B MOVE TT,B MOVE B,A PREST A PREST T PRET BIGSUB: CAIE B,POSNU CAIN B,NEGNU PRET ;no conversion necessary CAIE B,FIXNU JRST NUMV2 ;already checked for flonum MOVEI B,0 MOVE TT,A ;get value of number MOVM A,TT JUMPGE A,BIGSRT MOVEI A,1 ;bastard case of -2^35 MKBG: PCALL MKBIG JRST BIGSND BIGSRT: PCALL BCONS BIGSND: SKIPGE TT SKIPA B,[NEGNU] MOVEI B,POSNU PRET MKBIG: PSAVE B PCALL BNCONS MOVE B,A PREST A JRST BCONS PAGE BFLOT: MOVEI T,FLO1A MOVEM T,(P) MOVE T,B ;Make a floating pt number out of a bignum BFLT: PSAVE C PSAVE T CAIE T,POSNU CAIN T,NEGNU SKIPA T,[-200] JRST NUMV2 BFLT2: MOVE C,B CARA B,(A) CDRA A,(A) ADDI T,43 JUMPN A,BFLT2 ;find last two words of bignum MOVE B,(B) MOVE C,(C) BFLT3: TLNE B,SIGN/2 JRST BFLT4 ASHC B,1 SOJA T,BFLT3 ;normalize B,C BFLT4: JUMPGE T,FLOOV ASH B,-10 DPB T,[POINT 8,B,8] MOVE A,B PREST T PREST C CAIE T,POSNU MOVNS A PRET ;Make a bignum from a flt pt number BFIX: MOVM A,(P) MULI A,400 MOVEI C,-243(A) ;#left shifts needed IDIVI C,43 ;C_#extra words-1, D_#shifts MOVEI A,0 ASHC A,(C+1) PSAVE B PCALL BNCONS MOVE B,A PREST A PCALL BCONS SOJL C,BFIX2 MOVE B,A MOVEI A,0 PCALL BCONS SOJGE C,.-3 BFIX2: PREST TT PCALL BIGSND JRST XCONS PAGE ;Bignum divide BDIV: PCALL MQSIGN ;complement sign of TT if T is negnum PSAVE T ;sign of remainder PSAVE TT ;sign of quotient PCALL DIVSUB BDIV2: EXCH B,(P) PCALL MAKBIG ;quotient MOVE B,-1(P) MOVEM A,-1(P) PREST A PCALL MAKBIG ;remainder PREST B JRST XCONS BQUO: PCALL MQSIGN PSAVE TT PCALL DIVSUB PSAVE A MOVE A,B PCALL UNCONS PREST A PREST B JRST MAKBIG DIVSUB: CDRA C,(B) JUMPN C,DIV1 ;NULL(CDR B) means single length divisor BQUO1: PSAVE B PCALL COPY PREST B CARA B,(B) MOVE B,(B) PCALL Q1 PSAVE B ;quotient PCALL BNCONS MOVE B,A JRST POPAJ PAGE ;DIV1 does long division of X/Y ;enter with x in A, Y in B. DIV1: PSAVE A ;X PSAVE B ;Y MOVE A,B PCALL HIDIG HRLOI A,SIGN/2-1 IDIV A,(C) ;(beta/2-1)/Y[N-1]+1 ADDI A,1 MOVEM A,SCALE# MOVE B,A MOVE A,(P) ;Y - divisor PCALL BTIME0 ;SCALE*Y MOVEM A,V ;scaled divisor MOVEM A,(P) ;protect V from GC PCALL HIDIG POP C,VH ;V[N-1] POP C,VH1 ;V[N-2] MOVE A,-1(P) ;X - numerator PCALL COPY PCALL EXTND MOVE B,SCALE MOVE C,A PCALL BTIME1-1 ;SCALE*X -- scaled numerator MOVEM A,-1(P) ;U PSAVE [NIL] HRRZM P,QUO# ;pointer to quotient list PCALL LENGTH PSAVE A MOVE A,V# PCALL LENGTH PREST B SUB B,A ;LENGTH(U)-LENGTH(V) MOVE A,-2(P) ;U JUMPLE B,DIV1X ;special case of U<V PCALL DIV2 ;carry out division with parameters DIV1X: PCALL SUPRSS ;suppress leading zeros of remainder JUMPE A,DIV1Y ;zero remainder MOVE B,SCALE PCALL Q1 ;U/SCALE - final remainder in B MOVE A,B DIV1Y: EXCH A,(P) PCALL SUPRSS ;suppress leading zeros in quotient PREST B JRST POP2J PAGE ;Recursive function to position V properly with respect to U. ; on successive calls to DIV3 which calculates quotient digits. ;Enter DIV2 with U in A, N in B. N= LENGTH(U)-LENGTH(V)-1. DIV2: SOJLE B,DIV3 PSAVE A ;U CDRA A,(A) PCALL DIV2 RPLCD A,@(P) ;(RPLACD U,(DIV3(CDR U))) PREST A JRST DIV3 ;Enter with U[J] in A DIV3: PSAVE A ;UJ PCALL HIDIG POP C,A ;UH CAML A,VH# JRST DIVCS1 ;strange case when UH>=VH POP C,B ;UH1 DIV A,VH ;(UH*beta+UH1)/VH PSAVE A ;quotient digit L1: MOVEM B,REM# ;remainder MUL A,VH1# SUB A,REM ;(VH1*QUO)-beta*REM CAMGE B,(C) ;UH2 SUBI A,1 JUMPG A,DIVCS2 ;quotient too big L4: MOVE A,V MOVE B,(P) ;quotient digit PCALL BTIME0 ;Q*V MOVE C,-1(P) ;UJ MOVE B,A MOVEI A,0 PCALL BSUB ;UJ-Q*V JUMPL B,DIVCS3 ;quotient too big L3: MOVEM A,-1(P) ;new UJ PREST A ;quotient digit MOVE B,@QUO PCALL BCONS MOVEM A,@QUO ;new quotient list MOVE A,(P) PCALL DIVSRT ;shorten UJ by one digit JRST POPAJ PAGE ;Special case of UH>=VH DIVCS1: HRLOI A,SIGN-1 ;BETA-1 PSAVE A POP C,B ;UH1 JRST DIVC2A ;R_UH1+VH ;Special case correction for quotient DIVCS2: SOS A,(P) ;quotient_quotient-1 MOVE B,REM DIVC2A: ADD B,VH ;R_R+VH JUMPL B,L4 ;overflow ... R >= beta. JRST L1 ;Special case of quotient too large DIVCS3: SOS (P) ;quotient_quotient-1 PSAVE A MOVE A,V PCALL COPY MOVE C,A PREST B MOVEI A,0 PCALL BADD ;U_U+V MOVEM A,-1(P) PCALL DIVSRT ;shorten overflowed digit JRST L3+1 PAGE ;Pushes successive digits of list in A onto pdl ;Returns C pointing to pdl location of last digit HIDIG: MOVE C,P MOVS B,(A) PSAVE (B) HLRZ A,B JUMPN A,HIDIG+1 EXCH C,P PRET ;Shorten list by one DIVSRT: MOVE C,A CDRA A,(A) CDRA B,(A) ;CDDR JUMPN B,.-3 HLLZS (C) ;NULL (CDDR C) => RPLACD(C NIL) CARA B,(A) JRST UNCONS ;Lengthen list by one EXTND: PSAVE A PCALL LAST MOVE T,A PCALL B0CONS RPLCD A,(T) JRST POPAJ PAGE TA==4 TB==5 TC==6 TD==7 UP==10 VP==11 Q==12 ;Bignum GCD BGCD: PSAVE B PCALL COPY EXCH A,(P) ;V PCALL COPY PSAVE A ;U PCALL COPY MOVE C,A MOVE A,-1(P) PCALL COPY MOVE B,A ;U MOVEI A,0 PCALL BSUB ;V-U PSAVE B PCALL BSUBND JUMPE A,GCDSC1 ;U=V PCALL UNCONS PREST B JUMPGE B,BGCD2 ;U>=V MOVE A,(P) EXCH A,-1(P) MOVEM A,(P) PAGE ;Now V<U V in -1(P), U in (P) BGCD2: MOVE A,-1(P) JUMPE A,GCDEND ;V is zero CDRA B,(A) JUMPE B,GCDSING ;V is single precision PCALL LENGTH ;LENGTH (V) MOVE T,A MOVE A,(P) ;U PCALL LENGTH SUB A,T ;L(U)-L(V) JUMPE A,GCD4 SOJN A,GCD7A ;>1 MOVE A,-1(P) ;V PCALL EXTND ;lengthen V by one high order zero GCD4: MOVE A,(P) ;U PCALL HIDIG HRLOI A,SIGN/2-1 ;BETA/2-1 IDIV A,(C) ;(BETA/2-1)/U[N-1]+1 ADDI A,1 MOVEM A,SCALE PCALL GCSB MOVE UP,A ;SCALE*UH MOVE A,-1(P) ;V PCALL HIDIG PCALL GCSB MOVE VP,A ;SCALE*VH MOVEI TA,1 MOVEI TD,1 SETZB TC,TB PAGE GCD5: MOVE A,UP ADD A,TA MOVE B,VP ADD B,TC JUMPE B,GCD7 JUMPL A,GCD5X ;overflow case IDIV A,B ;(U'+A)/(V'+C) GCD5A: MOVE Q,A MOVE A,UP ADD A,TB MOVE B,VP ADD B,TD JUMPE B,GCD7 SKIPG B TDZA A,A ;special case of V'+D = BETA IDIV A,B ;(U'+B)/(V'+D) CAME A,Q JRST GCD7 MOVE A,TC EXCH TA,TC ;A'_C IMUL A,Q SUB TC,A ;C'_A-Q*C MOVE A,TD EXCH TB,TD ;B'_D IMUL A,Q SUB TD,A ;D'_B-Q*D MOVE A,VP EXCH UP,VP ;UP'_VP IMUL A,Q SUB VP,A ;VP'_UP-Q*VP JRST GCD5 PAGE ;Special case when U'+A=BETA GCD5X: MOVEI A,1 MOVE C,B MOVEI B,0 DIV A,C JRST GCD5A GCD7: JUMPE TB,GCD7A MOVE A,(P) ;U MOVE B,-1(P) ;V PSAVE TC PSAVE TD PCALL GCDSB ;A*U+B*V PREST TB PREST TA EXCH A,(P) ;U MOVE B,-1(P) PCALL GCDSB ;C*U+D*V MOVEM A,-1(P) ;V JRST BGCD2 GCDSB: PSAVE TA PSAVE TB PSAVE B MOVM B,TA PCALL BTIME0 EXCH A,(P) ;B MOVM B,-1(P) ;TB PCALL BTIME0 PREST B ;A*TA PREST TA PREST TB XOR TA,TB MOVE C,A MOVEI A,0 JUMPGE TA,BADD ;signs same PCALL BSUB ;signs different BSUBND: JUMPGE B,SUPRSS JRST COMPLM GCD7A: MOVE A,-1(P) PCALL SUPRSS MOVE B,A MOVE A,(P) PCALL DIV1 ;U/V EXCH B,-1(P) ;V_REMAINDER MOVEM B,(P) ;U_V PCALL UNCONS ;dont need quotient JRST BGCD2 PAGE GCDSING: PREST A ;U MOVE B,(P) ;V - single precision CARA B,(B) MOVE B,(B) MOVEM B,(P) PCALL Q1 ;U MOD V into A PREST B ;A < B JUMPE A,GCDS2 ;Single precision GCD IDIV B,A MOVE B,A MOVE A,C JUMPN A,.-3 GCDS2: MOVE A,B JRST FIX1A GCSB: MOVE A,-1(C) MUL A,SCALE MOVE B,A MOVE A,(C) IMUL A,SCALE ADD A,B PRET GCDSC1: P2DROP PREST A JRST MAKPOS GCDEND: PREST A ;U is result P1DROP JRST MAKPOS SUBTTL GENERALIZED GFPAK, FOR BIGNUMS --- PAGE 14 IFN MOD,< ;THE REST OF THIS PAGE IS UNDER THIS SWITCH ;TITLE GFPAK4 -- GALOIS FIELD PACKAGE ; THE MODULUS CANNOT BE A BIGNUM, WITH THIS VERSION OF GFPAK; ; THE ARG TO CMOD CAN BE, THOUGH. ; Every other arg is assumed to be FIXNUM or INUM !!! ; THE MODULUS SHOULD ALWAYS BE SET OR RESET BY THE FUNCTION SETMOD; ; IT SHOULD NOT BE SET BY A SETQ IN LISP/REDUCE. ; THE MODULUS CAN BE INTERROGATED FOR ITS CURRENT VALUE BY: ; 1) THE VALUE RETURNED FROM THE FUNCTION (SETMOD 0), ; WHICH DOESN'T ALTER THE CURRENT VALUE; OR BY ; 2) THE VALUE OF THE EXTERNAL VARIABLE MOD*. ; (SETMOD NIL) IS LEGITIMATE, AND IS == (SETQ MOD* NIL). GFP: 0 ;STRICTLY LOCAL: THE SINGLE-PRECISION MODULUS. ;VBIGP IS THE VALUE-CELL OF THE VARIABLE MOD*, ; AND PERMITS EXTERNAL-INTERROGATION. ;VBIGP IS ALSO USED IN CMOD, AS A FIXNUM, ; (TO AVOID RE-FIX1A-ING GFP EACH TIME). ; IT IS THUS PROTECTED DURING A GC. PAGE ;(SETMOD A) SETS P, THE NUMBER OF ELEMENTS OF THE FIELD, TO A IF A.NE.0 ; AND RETURNS P AS A RESULT IN ANY CASE. ; DOES NOT CHECK TO SEE IF P IS PRIME, WHICH IT SHOULD BE. INTERNAL SETMOD SETMOD: MOVE C,A ;Preserve pntr around NUMVAL. JUMPE A,SETM2 ;If NIL, just reset cells. PCALL NUMVAL JUMPE A,SETM3 ;If "0", interrogate old value. SETM2: MOVMM A,GFP ;Internal cell (for local use). FOO MOVEM C,VBIGP ;External pntr (for users and CMOD). SETM3: FOO MOVE A,VBIGP ;Return current value. PRET ;(CMOD A) NORMALIZES A MOD P, REGARDLESS +/- SIZE INTERNAL CMOD CMOD: JSP D,ONUMV JRST CMOD1 CAIN B,FLONU JRST ILLNUM ;FLOATING POINT NUMBERS ARE ILLEGAL IDIV A,GFP SKIPGE A,B ;IF A WAS NEG, REMAINDER IS NEG ADD A,GFP JRST FIX1A ;CONVERT & EXIT CMOD1: PSAVE B PCALL COPY MOVE B,GFP PCALL Q1 PREST B CAIE B,POSNU MOVNS A JRST CDIF1 PAGE ;(CPLUS A B) RETURNS THE SUM OF A AND B IN THE CURRENT GALOIS FIELD ; ASSUMES A & B ALREADY NORMALIZED. INTERNAL CPLUS CPLUS: MOVEM B,TMP ;SAVE B PCALL NUMVAL ;CONVERT A EXCH A,TMP ;SAVE A PCALL NUMVAL ;CONVERT B ADD A,TMP ;ADD CAML A,GFP ;SKIP IF LESS, ELSE SUB A,GFP ; NORMALIZE JRST FIX1A ;CONVERT AND EXIT TMP: 0 ;CDIF(A,B) RETURNS A-B MOD P, A,B ARE ELEMENTS OF GF(P) INTERNAL CDIF CDIF: MOVEM B,TMP ;SAVE B PCALL NUMVAL ;CONVERT A EXCH A,TMP ;SAVE A PCALL NUMVAL ;CONVERT B EXCH A,TMP SUB A,TMP ;SUBTRACT CDIF1: SKIPGE A ; SKIP IF GREATEQ 0,ELSE ADD A,GFP ; NORMALIZE JRST FIX1A ;CONVERT AND EXIT ;(CTIMES A B) RETURNS THE PRODUCT OF A AND B IN THE CURRENT GALOIS FIELD ; ASSUMES A & B NON-NEG ... NORMALIZED. INTERNAL CTIMES CTIMES: MOVEM B,TMP ;SAVE B PCALL NUMVAL ;CONVERT A EXCH A,TMP ;SAVE A PCALL NUMVAL ;CONVERT B MUL A,TMP ;MULTIPLY DIV A,GFP ;DIVIDE BY P TO GET IN RANGE MOVE A,B ;MOVE REMAINDER JRST FIX1A ;WHICH WE CONVERT AND EXIT PAGE ;(CRECIP A) RETURNS THE INVERSE OF A IN THE CURRENT GALOIS FIELD. ; COMPUTATION USES EXTENDED EUCLIDEAN ALGORITHM, WHEREBY ; (GCD P A) IS COMPUTED, AND NUMBERS X AND Y ARE FOUND SUCH THAT ; P*X + A*Y = (GCD P A) = 1 BECAUSE P IS PRIME (WE HOPE). ; SINCE P*X O (MOD P) WE DO NOT IN FACT COMPUTE X. ; Y IS OF COURSE THE MULTIPLICATIVE INVERSE OF A. ;ALGORITHM: ; A(I)=A(I+1)*Q(I)+A(I+2) ; Y(I+2)=Y(I)-Q(I)*Y(I+1) ; A(1)=P, A(2)=A, Y(1)=0, Y(2)=1 ; A(N+2)=0, Y(N+1)=Y ;STORAGE ALLOCATION: ; A: A(I+1) ; B: A(I) ; C: A(I+2) (BECAUSE OF THE WAY IDIV WORKS) ; AR4: Y(I) ; AR5: Y(I+1) INTERNAL CRECIP CRECIP: PCALL NUMVAL ;GET VALUE OF ARGUMENT IN A(2) SETZM AR4 ;Y(1)=0 MOVEI AR5,1 ;Y(2)=1 MOVE B,GFP ;A(1)=P LOOP: IDIV B,A ;C=A(I+2), B=Q(I) JUMPE C,EXIT ;IF A(I+2)=0, WE ARE THROUGH IMUL B,AR5 ;Q(I)*Y(I+1) EXCH AR4,AR5 SUB AR5,B ;Y(I+2) MOVE B,A MOVE A,C JRST LOOP ;NEXT ITERATION EXIT: SKIPGE A,AR5 ;A_Y(N+1). IF NEGATIVE ADD A,GFP ;ADD P TO GET 0.LT.Y.LT.P JRST FIX1A ;CONVERT TO LISP NUMBER AND EXIT > ;END OF IFN MOD SUBTTL EXPLODE, COMPRESS AND FRIENDS --- PAGE 15 IFE STL,< FLATSIZE:HLLZS FLAT1 MOVEI R,FLAT2 PCALL PRINTA FLAT1: MOVEI A,X ;* JRST FIX1A FLAT2: AOS FLAT1 PRET > %EXPLODE:SKIPA R,.+1 ;LIKE PRIN2 & PRIN1, EXPLODE: HRRZI R,EXPL1 ; <HRRZI>=551, negative R trick. SKIPN OLSCNV ;READ scanner? JRST EXPLO1 ;Yes! PSAVE A MOVEI A,NIL PCALL SCANSET EXCH A,(P) PCALL EXPLO1 EXCH A,(P) PCALL SCANSET JRST POPAJ EXPLO1: MOVSI AR4,AR4 PCALL PRINTA JRST RETAR4 EXPL1: PSAVE B PSAVE C ANDI A,177 PCALL RECH1 PCALL NCONS HLR B,AR4 RPLCD A,(B) RPLCA A,AR4 PREST C JRST POPBJ PAGE IFE STL,< READLIST:TDZA T,T COMPRESS:MOVNI T,1 MOVEM T,NOINFG > IFN STL,< COMPRESS:SETOM NOINFG > PSAVE OLDCH SETZM OLDCH JUMPE A,[ERRL0 ^D141,[SIXBIT /NO LIST-COMPRESS!/]] HRRM A,MKNAM3 MOVEI A,MKNAM2 PCALL READ0 CDRA T,MKNAM3 CAIE T,-1 JUMPN T,[ERRL0 ^D142,[SIXBIT /MORE THAN ONE S-EXPRESSION-COMPRESS!/]] PREST OLDCH PRET MKNAM2: PSAVE B PSAVE TT MKNAM3: MOVEI TT,X JUMPE TT,MKNAM6 CAIN TT,-1 ERRL0 ^D143,[SIXBIT /READ UNHAPPY-COMPRESS!/] CDRA B,(TT) HRRM B,MKNAM3 CARA A,(TT) PCALL GTFCH MKNAM4: PREST TT JRST POPBJ MKNAM6: MOVEI A," " HLLOS MKNAM3 JRST MKNAM4 GTFCH: CAILE A,INUMIN JRST GTFINV GTFCH2: PCALL GETPNM CARA A,(A) LDB A,[POINT 7,(A),6] PRET GTFINV: SUBI A,INUM0-"0" CAIG A,"9" CAIGE A,"0" ERRL1 ^D144,[SIXBIT /NUMBER NOT DIGIT!/] PRET SUBTTL EVAL APPLY -- THE INTERPRETER --- PAGE 16 EV3: CARA A,(AR4) FOO MOVEI B,VALUE PCALL GET+1 ;don't need to check for id JUMPE A,UNDFUN ;function object has no definition CDRA A,(A) CARA B,(AR4) CAIE A,(B) ;Error if same id UBDPTR: FOO CAIN A,UNBOUND JRST UNDFUN CDRA B,(AR4) ;eval (cons a (cdr AR4)) PCALL CONS EVAL: HRRZM A,AR4 CAILE A,INUMIN JRST CPOPJ CARA T,(A) CAILE T,ATMIN JRST EE1 ;x is atomic CAILE T,INUMIN JRST UNDFUN CARA TT,(T) CAIN TT,ID JRST EE2 ;car (x) is an id CAIL TT,CODMIN JRST EVCOD CAIG TT,ATMIN JRST EXP3 IFE APPL,< UNDFUN: CARA A,(AR4) ERRE1 ^D28,[SIXBIT /UNDEFINED FUNCTION - EVAL!/] > IFN APPL,< JRST RETAR4 UNDFUN==RETAR4 > EE1: CAIE T,ID PRET ;constant FOO MOVEI B,VALUE PCALL IGET EXCH A,AR4 JUMPE AR4,UNBVAR CDRA AR4,(AR4) IFE APPL,< FOO CAIN AR4,UNBOUND UNBVAR: ERRE1 ^D29,[SIXBIT /UNBOUND VARIABLE - EVAL!/] > IFN APPL,< FOO CAIE AR4,UNBOUND UNBVAR==CPOPJ > MOVEM AR4,A PRET PAGE IFN FNRG,< ALIST: SKIPE A,-1(P) PCALL NUMBERP PUSH SP,[0] ;mark for unbind JUMPN A,AEVAL7 ;number MOVE C,SC2 ;bottom of spec pdl MOVEM C,AEVAL5# SETOM AEVAL2 AEVAL8: MOVE C,SP AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl JRST AEVAL1 ;done AEVAL4: POP C,AR4 JUMPE AR4,AEVAL6 ;thru with block MOVSS AR4 PUSH SP,(AR4) ;save value cell HLRZM AR4,(AR4) ;store previous value in value cell HRLM AR4,(SP) ;save pointer to spec pdl loc JRST AEVAL4 FNGUBD: EXCH A,(P) ;spec pdl pointer PCALL NUMVAL MOVE D,A FNGUB2: POP SP,T JUMPE T,POPAJ ;done MOVSS T ;pointer to value cell RPLCA T,(T) SKIPN 1(D) AOBJN D,.-1 ;skip over spec pdl marker PUSH D,(T) ;put value cell in spec pdl HLRZM T,(T) ;restore value cell JRST FNGUB2 %EVAL: PSAVE A PSAVE B PCALL ALIST PREST A MOVEI A,UNBIND EXCH A,(P) JRST EVAL PAGE AEVAL1: SKIPGE AEVAL2 SKIPN B,-1(P) PRET ;done with binding MOVE A,B ;ALIST binding... PCALL REVERSE SKIPA ABIND2: MOVE A,B CDRA B,(A) CARA A,(A) CDRA AR4,(A) CARA A,(A) PCALL BIND JUMPN B,ABIND2 PRET ;spec pdl binding AEVAL7: MOVE A,-1(P) PCALL NUMVAL SETZM AEVAL2 MOVEM A,AEVAL5 ;point to unbind to JRST AEVAL8 AEVAL2: 0 ;0 for number, -1 for a-list * > ;end of IFN FNRG PAGE EE2: CDRA T,(T) FOO MOVEI D,FUNCELL EE21: JUMPE T,EV3 MOVS TT,(T) MOVS T,(TT) CAIN D,(T) JRA T,EE3 CARA T,TT JRST EE21 EE3: CARA TT,T CARA D,(T) ;FOO CAIN TT,SUBR ; JRST EVCOD FOO CAIN TT,EXPR JRST AEXPQ ;FOO CAIN TT,FSUBR ; JRST EFS FOO CAIN TT,MACRO JRST EFM FOO CAIE TT,FEXPR JRST UNDFUN CAIE D,ID CAIGE D,CODMIN JRST AFEXP EFS: CDRA T,(T) CDRA A,(AR4) JRST (T) AFEXP: HLL T,(AR4) PSAVE T CDRA A,(A) UUOS3I: TLO A,400000 PSAVE A MOVNI T,1 JRST IAPPLY AEXP: HLL T,(AR4) EXP3: CDRA A,(AR4) UUOS6: PSAVE T CILIST: JSP TT,ILIST EXP2: JRST IAPPLY PAGE AEXPQ: CAIE D,ID CAIGE D,CODMIN JRST AEXP EVCOD: CDRA A,(AR4) HLL T,(AR4) UUOS2: CDRA T,(T) PSAVE T ;For POPJ below --> call this addr. JSP TT,ILIST ESB1: MOVEI TT,CPOPJ PDLARG: HRREI R,NACS(T) JUMPGE R,PDLA1(R) MOVMS R CAILE R,NSUA-NACS ERRL1 ^D145,[SIXBIT /TOO MANY ARGS FOR EXPR!/] HRLI R,(R) PXDROP R MOVEI A,EXARG HRLI A,1(P) BLT A,EXARG-1(R) PDLA1: PREST A+4 PREST A+3 PREST A+2 PREST A+1 PREST A JRST (TT) EFM: CALLF 1,(T) JRST EVAL PAGE IFN FNRG,< %APPLY: MOVEI R,3 JSP TT,ARGP1 MOVEM T,APFNG1# PCALL ALIST MOVE T,APFNG1 JSP TT,PDLARG PSAVE C ;spec pdl pointer PSAVE [FNGUBD] > APPLY: PSAVE A MOVEI T,0 AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list CARA C,(B) PSAVE C ;push arg CDRA B,(B) SOJA T,AP3 IFN FNRG,< IAP4: JUMPGE D,TOOFEW ;special case for fexprs AOJN R,TOOFEW PSAVE B MOVE A,SP PCALL FIX1A EXCH A,(P) MOVE B,A MOVNI R,2 SOJA T,IAP5 FUNCT: PSAVE A MOVE A,SP PCALL FIX1A PREST B HLL A,(B) PCALL DCONSA FOO HRLI A,FUNARG JRST DCONSA PAGE APFNG: SOS T MOVEM T,APFNG1 JSP TT,PDLARG ;get args and funarg list CDRA A,(A) CDRA D,(A) ;a-list pointer CARA A,(A) ;function MOVN R,APFNG1 ;Positive no. of args PSAVE D PSAVE [FNGUBD] JSP TT,ARGP1 ;replace args and fn name PSAVE D ;a-list pointer PCALL ALIST ;set up spec pdl PREST D AOS T,APFNG1 > ;end of IFN FNRG IAPPLY: MOVE C,T ;state of world at entrance ADDI C,(P) ;t has - number of args on pdl ILP1A: CDRA B,(C) ;next pdl slot has function- poss fun name in lh CAILE B,INUMIN JRST UNDTAG CARA TT,(B) CAILE TT,ATMIN JRST IAP1 ;fn is atomic FOO CAIN TT,LAMBDA JRST IAPLMB IFN FNRG,< FOO CAIN TT,FUNARG JRST APFNG > FOO CAIN TT,LABEL JRST APLBL PSAVE T MOVE A,B PCALL EVAL PREST T MOVE C,T ADDI C,(P) ILP1B: MOVEM A,(C) JRST ILP1A UNDTAG: MOVE A,(C) ;FN NAME,,FN TLNE A,-1 ;Any function name ? HLRZS A ;Yes! ERRE1 ^D30,[SIXBIT /UNDEFINED FUNCTION - APPLY!/] PAGE IAP1: CAIGE TT,CODMIN JRST UNDTAG CAIE TT,ID JRST APCOD FOO MOVEI D,FUNCELL CDRA B,(B) IAPL1: JUMPE B,IAP2 MOVS TT,(B) MOVS B,(TT) CAIN D,(B) JRA B,IAPL2 CARA B,TT JRST IAPL1 IAPL2: CARA TT,B ;FOO CAIN TT,SUBR ; JRST APCOD FOO CAIE TT,EXPR ERRE1 ^D31,[SIXBIT /NOT EXPR - APPLY!/] CARA D,(B) CAIE D,ID CAIGE D,CODMIN JRST IAPXPR APCOD: CDRA B,(B) HRRZM B,(C) JRST ESB1 IAPXPR: CDRA A,B JRST ILP1B PAGE IAPLMB: CDRA B,(B) CARA TT,(B) CDRA B,(B) CARA D,(TT) CAIN D,ID JUMPN TT,[ERRL1 ^D146,[SIXBIT /ILLEGAL LAMBDA FORMAT!/]] MOVE R,T IPLMB1: JUMPE T,IPLMB2 ;no more args JUMPE TT,TOMANY ;too many args supplied IAP5: CARA A,(TT) MOVEI AR4,1(T) ADD AR4,P HLLZ D,(AR4) ;tested in IAP4 RPLCA A,(AR4) CDRA TT,(TT) AOJA T,IPLMB1 IFE FNRG,IAP4==TOFEW IPLMB2: JUMPN TT,IAP4 ;too few args supplied PUSH SP,[0] ;mark for unbind JUMPE R,IAP69 IPLMB4: PREST AR4 CARA A,AR4 PCALL BIND AOJL R,IPLMB4 IAP69: PREST AR4 TLNE AR4,-1 FOO SKIPN BACTRF JRST .+3 HRRI AR4,CPOPJ PSAVE AR4 PCALL PROGN1 JRST UNBIND TOMANY: ERRL1 ^D147,[SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/] TOOFEW: ERRL1 ^D148,[SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/] PAGE APLBL: PUSH SP,[0] ;mark for unbind CDRA B,(B) CARA A,(B) CDRA B,(B) CARA AR4,(B) MOVEM AR4,(C) PCALL BIND MOVEI A,APLBL1 EXCH A,-1(C) EXCH A,LBLAD# HRLI A,LBLAD PUSH SP,A JRST IAPPLY APLBL1: PSAVE LBLAD JRST SPECSTR IAP2: CDRA A,(C) FOO MOVEI B,VALUE PCALL GET+1 ;don't need to check for id JUMPE A,UNDTAG CDRA A,(A) CDRA B,(C) CAIE A,(B) FOO CAIN A,UNBOUND JRST UNDTAG JRST ILP1B RETB: PROG2: HRRZ A,B PRET PAGE BIND: JSP D,CHKID FOO CAIE A,TRUTH JUMPN A,BIND4 ERRE2 ^D32,[SIXBIT /MAY NOT BE CHANGED!/] BIND4: PSAVE B PCALL BIND1 ;get value cell PUSH SP,(A) RPLCA A,(SP) HRRZM AR4,(A) POPBJ: PREST B PRET BIND1: HRRZM A,BIND3# FOO MOVEI B,VALUE PCALL GET+1 JUMPN A,CPOPJ FOO MOVEI A,UNBOUND PCALL DCONSA MOVE TT,A FOO HRLI A,VALUE PCALL DCONSA CDRA B,@BIND3 PCALL CONS RPLCD A,@BIND3 MOVE A,TT PRET TUNBIND:SETZM SPSAV MOVE B,SC2 UBD: CAMN SP,B PRET PCALL UNBIND JRST UBD SPECSTR: ;LAP...<PCALL SPECSTR> UNBIND: POP SP,T JUMPE T,CPOPJ MOVSS T HLRZM T,(T) JRST UNBIND PAGE PROGBIND:MOVEI D,PROGB1 ;LAP...<CALL 0,PROGBIND><0 0 (FLUID --)> SPEC1: PREST T PUSH SP,[0] ;mark for unbind SPEC2: LDB R,[POINT 13,(T),ACFLD] CAIG R,377 JRST (D) ;prog- or lam-bind JRST (T) ;next is opcode, so quit. LAMBIND:JSP D,SPEC1 ;LAP...<CALL 0,LAMBIND><0 x (FLUID --)> JUMPE R,SPEC3 ;Init = NIL CAIG R,NACS JRST LAMB1 CAIG R,NSUA ;Extended regs. JRST LAMB2 ;Yes MOVNI R,(R) ;From pdl ADDI R,NSUA+1(P) LAMB1: SKIPA R,(R) PROGB1: SETZ R, SPEC3: EXCH R,@(T) HRL R,(T) PUSH SP,R ;<address,,old-value>. AOJA T,SPEC2 LAMB2: MOVE R,EXARG-NACS-1(R) JRST SPEC3 ;Miscellaneous special case compiler run time routines %AMAKE: PSAVE A ;make alist for fsubr that requires it MOVE A,SP PCALL FIX1A MOVE B,A JRST POPAJ IFE STL,< %UDT: PCALL ERHED ;error print for undefined computed go tag PCALL PRIN1 STRTIP [SIXBIT / UNDEFINED COMPUTED GO TAG IN !/] MOVEI R,INUM0+17 HRRM R,ERRX CDRA R,(P) PCALL ERSUB3 JRST ERREND-1 %LCALL: MOVN A,T ;set up routine for compile lsubr ADDI A,INUM0 ADDI T,(P) PSAVE T PCALL (3) PREST T SUBI T,(P) HRLI T,-1(T) ADD P,T PRET > SUBTTL ARRAY SUBROUTINES --- PAGE 17 IFN ASARY,< ARRERR=-1 ARRAY: PCALL ARRAYS HRRI AR5,1(R) MOVE A,AR5 PUSH R,[0] AOBJN A,.-1 ARREND: MOVE A,BPPNR# MOVEM AR5,-1(A) MOVEI A,1(R) PCALL FIX1A ;MOVEI A,INUM0+1(R) FOO MOVEM A,VBPORG PRET ARRAYS: PSAVE A FOO MOVE A,VBPORG PCALL NUMVAL ;SUBI A,INUM0 MOVEM A,BPPNR FOO MOVE A,VBPEND PCALL NUMVAL ;MOVNI A,-INUM0-2(A) MOVN A,A ADDI A,2 ADD A,BPPNR ;bporg-bpend+2 HRLM A,BPPNR HRRZ A,BPPNR ADDI A,2 PCALL IMKCODE FOO MOVEI B,EXPR PREST A CDRA AR4,(A) ;(cdr l) CARA A,(A) ;(car l)name PCALL IPUTD CARA A,(AR4) ;(cadr l)mode PSAVE AR4 PCALL EVAL ;eval mode PREST AR4 MOVEM A,AMODE# MOVEI C,44 JUMPE A,ARRY1 MOVEI C,-INUM0(A) CAILE A,INUMIN JRST ARRY1 MOVEI C,22 MOVE A,GCMKL HRL A,BPPNR PCALL DCONSA ;IFF Lisp-pntrs requested, MOVEM A,GCMKL ;record for GC marking of arrays. ARRY1: MOVEM C,BSIZE# MOVEI A,44 IDIV A,C MOVEM A,NBYTES# CDRA A,(AR4) ;(cddr l)bound pair list JSP TT,ILIST AOS R,BPPNR MOVEI AR4,1 ;AR4 is array size MOVEI AR5,0 ;AR5 is cumulative residue AOJGE T,ARRYS ;single dimension MOVEI D,A-1 SUB D,T ;D is next ac for array code generation ARRY2: PCALL ARRB0 TLC TT,(IMULI) DPB D,[POINT 4,TT,ACFLD] PUSH R,TT CAIN D,A JRST ARRY3 MOVSI TT,(ADD) ADDI TT,1(D) DPB D,[POINT 4,TT,ACFLD] PUSH R,TT SOJA D,ARRY2 ARRB0: PREST TT ;E.G., after ARRAY XX(5,6), EXCH TT,(P) ; extents= (0:5,0:6), =42, = 0:41, CAILE TT,INUMIN ; generates SUBR #22002, say, and JRST ARRB1 ;22000/ -25,,22016 ;-N/2,,data CARA A,(TT) ; 001/ 5,,-10 ;INUM0*8 CDRA TT,(TT) ; 002/ IMULI A,7 SUBI TT,(A) ; 003/ ADD A,B ADDI TT,1 ; 004/ SUB A,22001 JRST ARRB2 ; 005/ JUMPL A,ARRERR;indexing .LT. (0,0) ; 006/ CAIL A,^D42 ARRB1: MOVEI A,INUM0 ; 007/ JRST ARRERR SUB TT,A ; 010/ IDIVI A,2 ;half-word pntrs. ARRB2: IMUL A,AR4 ; 011/ IMULI B,-^D18_12 ;bytesize. IMULB AR4,TT ; 012/ HRLZI C,(POINT 18,0(B),17) ADDM A,AR5 ; 013/ ADDI C,22016(A) PRET ; 014/ LDB A,C ;proper halfword. ; 015/ PRET ;returning pntr, etc. ARRY3: PUSH R,[ADD A,B] ; 016/ ...,,... ;INITIALLY 0 or NIL. ARRYS: PCALL ARRB0 HRRZ TT,BPPNR MOVEM AR5,(TT) ;SUBR-1, e.g. 22001. HRLI TT,(SUB A,) PUSH R,TT PUSH R,[JUMPL A,ARRERR] MOVE TT,AR4 HRLI TT,(CAIL A,) PUSH R,TT PUSH R,[JRST ARRERR] IDIV AR4,NBYTES ;calc #words in array SKIPE AR5 ;correct for remainder non-zero ADDI AR4,1 MOVE TT,NBYTES SOJE TT,ARRY6 ADDI TT,1 HRLI TT,(IDIVI A,) PUSH R,TT MOVN TT,BSIZE LSH TT,14 HRLI TT,(IMULI B,) PUSH R,TT MOVEI TT,44+200 SUB TT,BSIZE LSH TT,6 ARRY6: ADD TT,BSIZE LSH TT,6 SKIPE AR5,AMODE CAIL AR5,INUMIN ADDI TT,40 ;mode not = T TLC TT,(MOVSI C,) PUSH R,TT MOVEI TT,4(R) HRLI TT,(ADDI C,(A)) PUSH R,TT PUSH R,[LDB A,C] MOVSI AR5,(PRET) SKIPN TT,AMODE MOVE AR5,[JRST FLO1A] CAIL TT,INUMIN MOVE AR5,[JRST FIX1A] PUSH R,AR5 MOVS AR5,AR4 MOVNS AR5 PRET STORE: PSAVE A PCALL CADR PCALL EVAL ;value to store EXCH A,(P) CARA A,(A) PCALL EVAL ;byte pointer returned in c PREST A NSTR: PSAVE A TLNE C,40 JSP D,ONUMV ;numerical array JRST BIGNER ;BIGNUM IS ERROR DPB A,C PREST A PRET > ;end of IFN ASARY from line 300 PAGE IFN ALOD&ASARY,< EXARRAY:PSAVE A CARA A,(A) PCALL GETSYM JUMPE A,POPAJ PCALL NUMVAL EXCH A,(P) PCALL ARRAYS PREST A HRRM A,-2(R) HRR AR5,A JRST ARREND > ;end of IFN ALOD&ASARY DLVECT: IFN ASARY,SETZ AR4, ;To reduce GC overhead, or GCing of JSP D,ATMTYP CAIE TT,VECT IFN ASARY,< JRST .+2 JRST ISVC ; obsolete array in BPS overlays, e.g. MOVE AR4,A PCALL GETD JUMPE A,FALSE ;Gone. CARA D,(A) FOO CAIE D,EXPR > JRST FALSE ISVC: CDRA A,(A) MOVEI TT,GCMKL ;Delete a Lisp array from the GC list, DLARRLP:CDRA T,(TT) ; If done with it, tho can't reclaim core yet. CARA C,(T) CAIN C,-2(A) JRST DLFOUND CDRA TT,(TT) JUMPN TT,DLARRLP JRST FALSE ;Not found. DLFOUND:CDRA T,(T) RPLCD T,(TT) ;Cut out of list. IFN ASARY,<SKIPE A,AR4 PCALL REMD> ;Delete the SUBR pointer from the Lisp array JRST TRUE PAGE MKVECT: PCALL NUMVAL JUMPL A,VECOV+1 PSAVE A LSH A,-1 PSAVE A FOO MOVE A,VBPORG PCALL NUMVAL EXCH A,(P) ADD A,(P) ADDI A,3 PCALL FIX1A PSAVE A FOO MOVE B,VBPEND PCALL .GREAT JUMPN A,VECOV FOO PREST VBPORG ;set new bporg MOVE A,GCMKL HRL A,(P) PCALL DCONSA HRRM A,GCMKL PREST A ;old bporg, i.e. beginning of vector MOVE B,(P) LSH B,-1 ADDI B,1 MOVNS B HRLM B,(A) ADDI A,2 HRRM A,-2(A) MOVE B,-2(A) SETZM (B) ;fill vector with NIL AOBJN B,.-1 PREST -1(A) ;Upper limit for vector HRLI A,VECT JRST DCONSA PAGE GETV: JSP T,OPV CARA A,(B) CDRA A,(B) PUTV: JSP T,OPV RPLCA A,(B) RPLCD A,(B) OPV: JSP D,ATMTYP CAIE TT,VECT ERRE2 ^D33,[SIXBIT /IS NOT A VECTOR!/] CDRA TT,(A) MOVE A,C SUBI B,INUM0 JUMPL B,INXOV CAMLE B,-1(TT) ;compare with upper limit JRST INXOV ;too big TRNE B,1 ;odd or eaven ADDI T,1 ;odd LSH B,-1 ADDI B,(TT) XCT (T) PRET VECTORP: UPBV: JSP D,ATMTYP CAIE TT,VECT JRST FALSE CDRA A,(A) MOVE A,-1(A) JRST FIX1A INXOV: MOVEI A,INUM0(B) ERRE2 ^D34,[SIXBIT /SUBSCRIPT IS OUT OF RANGE!/] VECOV: MOVE A,-2(P) ADDI A,INUM0 ERRE2 ^D35,[SIXBIT /TOO BIG VECTOR!/] SUBTTL EXAMINE, DEPOSIT , ETC --- PAGE 18 BOOLE: SUBI A,INUM0 DPB A,[POINT 4,BOOLI,OPFLD-2] MOVE A,B PCALL NUMVAL EXCH C,A BOOLL: PCALL NUMVAL BOOLI: SETZB C,A JRST FIX1A EXAMINE:PCALL NUMVAL ;<MOVE A,-INUM0(A)> MOVE A,(A) JRST FIX1A DEPOSIT:MOVE C,B PCALL NUMVAL ;<MOVEI C,-INUM0(A) EXCH A,C ; MOVE A,B > JSP D,ONUMV BIGNER: ERRL0 ^D139,[SIXBIT /BIGNUM UNSUITABLE AS ARG!/] ;AASCII,BOOLE,etc. MOVEM A,(C) JRST MAKNUM LSH: MOVEI C,-INUM0(B) PCALL NUMVAL LSH A,(C) JRST FIX1A SUBTTL GARBAGE COLLECTOR --- PAGE 19 GC: PCALL AGC JRST FALSE AGC2: SKIPE GCFFLG ;did we just do a GC from top ? PRET ;yes, don't do it again SETOM GCFFLG ;indicate GC from top AGC: MOVEM R,ACSAV+R AGC1: MOVEM SP,SPSAV ;save in case of ^C MOVE NIL,CNIL3 ;set NIL PSAVE .JBUUO PSAVE UUOH GCPK1: PSAVE PA3 PSAVE PA4 PSAVE UBDPTR ;special atom UNBOUND; not on OBLIST PSAVE MKNAM3 PSAVE GCMKL ;i/o channel input lists and arrays PSAVE BIND3 GCPK2: PSAVE [XWD 0,GCP6] ;this is a return address MOVEI D,ACSAV BLT D,ACSAV+11 ;save ACs 0 through 11 GCP2: SETZB NIL,X ;gc indicator, init. for bit table zero MOVE A,C3GC GCP5: BLT A,X ;zero bit tables, .=top of bit tables FOO SKIPN GCGAGV JRST GCP5A CAIN F,ILLAD STRTIP [SIXBIT /_*** FREE STG EXHAUSTED_!/] SKIPN FF STRTIP [SIXBIT /_*** FULL WORD SPACE EXHAUSTED_!/] GCP5A: MOVEI TT,1 MOVEI A,0 CALLI A,STIME ;time MOVEM A,GCTIMT# GCP3: MOVEI C,X ;.=bottom of reg pdl GCP6B: MOVE S,P HLL C,P MOVEI B,0 GC1: CAMN C,S PRET HRRZ A,(C) GCP: CAIGE A,X ;.=bottom of bit tables GCPP1: FOO CAIGE A,FS JRST GCEND GCP1: CAIL A,X ;.=bottom of full word space (fws) JRST GCMFWS MOVE F,(A) LSHC A,-5 ROT B,5 MOVE AR4,GCBT(B) GCBTP2: TDOE AR4,X(A) ;bit tab- (fs_-5), .=magic number for sync JRST GCEND GCBTP1: MOVEM AR4,X(A) ;bit tab- (fs_-5) PSAVE F CARA A,F JRST GCP GCMFWS: MOVEI AR4,X(A) ;.=- bottom of fws IDIVI AR4,44 MOVNS AR5 LSH AR5,36 ADD AR5,C2GC DPB TT,AR5 GCEND: CAMN P,S AOJA C,GC1 PREST A HRRZS A JRST GCP CNIL3: FOO XWD ID,CNIL2 ;NIL header to refresh ac 0 GCMKL: XWD 0,.+1+X ;Appended to, for each Lisp-pntr array. XWD .+1,.+2 XWD -NSUA+NACS-1,EXARG XWD .+1,.+2 XWD -11,ACSAV ;Reg 0 - 10 are saved from gc this way XWD .+1,NIL XWD -NIOCH,CHTAB+FSTCH C2GC: XWD 430100+AR4,X ;.=bottom of fws bit table C3GC: 0 ;<bottom bit table,,bottom bit table+1> GCBT: XWD 400000,0 ZZ==1B1 XLIST REPEAT ^D31,<ZZ ZZ==ZZ/2> LIST PAGE GCP6: HRRZ R,SC2 GCP6C: CAILE R,(SP) ;mark sp JRST GCP6A PSAVE (R) HRRZ C,P PCALL GCP6B P1DROP AOJA R,GCP6C GCP6A: HRRZ R,GCMKL ;mark arrays GCP6D: JUMPE R,GCSWP CARA A,(R) MOVE D,(A) ;<-N,,ADDR> GCP6E: PSAVE (D) CDRA C,P PSAVE (D) MOVSS (P) PCALL GCP6B P2DROP AOBJN D,GCP6E CDRA R,(R) JRST GCP6D GFSWPP: PHASE 0 GFSP1==. JUMPL S,.+3 HRRZM F,(R) HRRZ F,R ROT S,1 AOBJN R,.-4 MOVE S,(D) HRLI R,-40 AOBJN D,GFSP1 LPROG==. JRST GFSPR DEPHASE PAGE ;garbage collector sweep GCSWP: MOVSI R,GFSWPP BLT R,LPROG MOVEI F,ILLAD MOVE D,C3GCS FOO MOVEI R,FS GCBTL1: HRLI R,X ;-(32-<fs&37> MOVE S,(D) GCBTL2: ROT S,X ;fs&37 AOBJN D,GFSP1 GFSPR: MOVE A,C1GCS MOVE B,C2GCS PCALL GCS0 FOO SKIPN GCGAGV JRST GCSP1 PCALL WHEAD MOVE A,F PCALL GCPNT STRTIP [SIXBIT / FREE STG,!/] MOVE A,FF PCALL GCPNT1 STRTIP [SIXBIT / FULL WORDS AVAILABLE!/] PCALL TOURET GCSP1: PXDROP [XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p PREST UUOH PREST .JBUUO MOVE NIL,ACSAV SETZM SPSAV CAIN F,ILLAD ERRG ^D260,[SIXBIT /NO FREE STG LEFT!/] JUMPE FF,[ERRG ^D261,[SIXBIT /NO FULL WORDS LEFT!/]] MOVEI A,0 CALLI A,STIME ;time SUB A,GCTIMT ADDM A,GCTIM# MOVSI D,ACSAV BLT D,S ;reload ac's MOVE R,ACSAV+R IFN OPSYS,< SKIPE KBINTF ;Any user ^char interrupts from KB? JRST KBINTH > ; Yes, process. PRET PAGE GCS0: MOVEI FF,0 GCS1: ILDB C,B JUMPN C,GCS2 HRRZM FF,(A) HRRZ FF,A GCS2: AOBJN A,GCS1 PRET C1GCS: 0 ;<- length of fws,,bottom of fws> C2GCS: POINT 1,X,35 ;.=bottom of fws bit table C3GCS: 0 ;-n wds in bt,,bt GCTIME: MOVE A,GCTIM JRST FIX1A TIME: MOVEI A,0 CALLI A,STIME JRST FIX1A SPEAK: MOVE A,CONSVAL# JRST FIX1A GCPNT1: MOVEI B,0 JUMPE A,LOOP0 HRRZ A,(A) AOJA B,.-2 ; B:=LENGTH(A) GCPNT: MOVEI B,0 JRST .+2 HRRZ A,(A) CAIE A,ILLAD AOJA B,.-2 LOOP0: PCALL FIX1 JRST PRIN1 SUBTTL GETSYM,PUTSYM --- PAGE 20 IFN ALOD,< ;this entire page R50MAK: PCALL PNAMUK PUSH C,[0] HRLI C,700 HRRI C,(SP) MOVEI B,0 MK3: ILDB A,C LDB A,R50FLD CAMGE B,[50*50*50*50*50] SKIPN A PRET IMULI B,50 ADD B,A JRST MK3 GETSYM: PCALL R50MAK TLO B,040000 ;04 for globals MOVE C,.JBSYM MK7: CAMN B,(C) JRST MK10 ;found AOBJP C,.+2 AOBJN C,MK7 TLC B,140000 ;10 for locals TLNN B,100000 TLON B,400000 ;Suppressed to DDT JRST MK7-1 JRST FALSE MK10: MOVE A,1(C) ;value JRST FIX1A PUTSYM: PSAVE B PCALL R50MAK MOVE A,B TLO A,040000 ;make global SKIPL .JBSYM AOS .JBSYM ;increment initial symbol table pointer PSAVE A MOVEI A,2 PCALL EXPND2 MOVN B,[XWD 2,2] ADDB B,.JBSYM PREST (B) ;Name PREST 1(B) ;value JRST FALSE > ;end of IFN ALOD SUBTTL FASLOAD --- PAGE 21 ;From MIT-ML, converted to LISP 1.6 of Utah ;By KRK, Last edit: 09 Aug 76 IFN OFLD,< LDFNM2==137 ;Address of Lisp version number (if any). LDGPRO==0 ;Address (relative to reg P) of internal QLIST LDPRLS==-1 ; - " - P.URCLOBRL LDAAOB: 0 ;Currently highest index in Atomtable LDAGCM: 0 ;Address of GCMKL word for Atomtable LDAPTR: 0(TT) ;Base address for Atomtable. Index in TT LDBYTS: 0 ;Holds word being unpacked into bytes LDEOFJ: 0 ;Error index LDF2DP: 0 ;XOR between current and file version number LDGROW: 0 ;For extended Atomtable. Not used LDHLOC: 0 ;Not used LDOFST: 0(TT) ;Start of currently loaded routine. Relocation base ;LDPRDF: 0 ;Internal !*PREDEF flag ;Error indices LOOK==-1 EMPTYF==0 FORMAT==1 GCPROT==2 BPFULL==3 FTFULL==4 PAGE ; FASLOD('ArrayForFisl); FASLOD: ;MOVEM B,LDPRDF ;"Print redefined funcs". FOO SKIPN C,VPURIFY TLOA C,(1B0) FOO CDRA C,VP.URCLOBRL PSAVE C ;- to omit; 0 or old-addr to purify. PSAVE C ;LDGPRO zeroed below. SETZM LDEOFJ ;An EOF is erroneous until LDBEND byte. JSP D,ATMTYP CAIE TT,VECT JRST LDFERR CDRA A,(A) ;Lookup ATOMTABLE's access addr... MOVEI B,-2(A) MOVEM B,LDAGCM ;Addr of array's allocation-wd (GCMKL). MOVE B,-2(A) HRRM B,LDAPTR ;Addr of array's data base-wd. SETZ TT, SETZM @LDAPTR ;0th is NIL [N.B. indirection-addr uses TT]. LDMORE: JSP T,LDGTWD ; ...except that can get empty file. JUMPE TT,.-1 ;Sluff leading/trailing 0 words. SETZM LDEOFJ ;(Reset after a new file's LDMORE). AOS LDEOFJ ;Now 1 for "Format error". CAME TT,[ASCII /FASLP/] JSP D,LDFERR ;Improper format for FASL file. JSP T,LDGTWD ;Get 2nd word of each file. XOR TT,LDFNM2 ;Compare to Lisp's version&flags. MOVEM TT,LDF2DP ;Nonzero if different. SETZM FFFSUB# SETZM LDGPRO(P) ;Internal QLIST effectively. HLLZ A,@LDAGCM ;[-length,,0] AOBJN A,.+1 MOVEM A,LDAAOB ;Commence with 1th cell; NIL is 0th. FOO MOVE A,VBPORG PCALL NUMVAL HRRM A,LDOFST ;Also a TT indirection pntr. HRRZM A,R ;Form AOBJP wd in R for BPS storage... MOVE B,LDAGCM ; [Use this rather than BPEND1]. SUBI A,-1(B) JUMPL A,USE.IT FOO MOVE A,VBPEND PCALL NUMVAL MOVE B,A MOVE A,R SUBI A,(B) JUMPGE A,FASLNC USE.IT: HRLI R,(A) ; [-<available BPS>,,<starting BPORG>] SETZM LDHLOC ;Initialize for the BPS section. MOVE AR4,[000400,,LDBYTS] ;Initialize for accessing each JRST LDBIN ; 9*4 series of bytes. PAGE ;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED, ;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES: ;;; AR4 BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES ;;; R AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE LDREL: HRRI TT,@LDOFST ;[RELOCATABLE WORD] LDABS: MOVEM TT,(R) ;[ABSOLUTE WORD] LDABS1: AOBJP R,FASLNC ;EXCEEDED AVAILABLE BPS -- NO CORE. LDBIN: TLNN AR4,770000 JRST LDBIN2 ;OUT OF RELOCATION BYTES - GET MORE. LDBIN1: JSP T,LDGTWD ;GET WORD FROM INPUT FILE ILDB T,AR4 ;GET CORRESPONDING RELOCATION BYTE JSP D,@LDTTBL(T) ; - IT TELLS US WHERE TO GO LDTTBL: LDABS ; 0 ABSOLUTE LDREL ; 1 RELOCATABLE LDSPC ; 2 SPECIAL LDPRC ; 3 PURIFIABLE CALL LDQAT ; 4 QUOTED ATOM LDQLS ; 5 QUOTED LIST LDGLB ; 6 GLOBALSYM PATCH LDGET ; 7 GET DDT SYMBOL PATCH LDAREF ; 10 ARRAY REFERENCE LDPEN ; 11 PUT ENTRY POINT LDATM ; 12 ATOMTABLE ENTRY LDENT ; 13 ENTRY POINT INFO LDLOC ; 14 LOC TO ANOTHER PLACE LDPUT ; 15 PUT DDT SYMBOL LDEVAL ; 16 EVALUATE MUNGEABLE LDBEND ; 17 END OF BINARY LDBIN2: JSP T,LDGTWD ;GET WORD OF RELOCATION BYTES MOVEM TT,LDBYTS SOJA AR4,LDBIN1 ;INIT BYTE POINTER AND GO GET DATA WORD PAGE LDSPC: MOVE T,TT ;[SPECIAL] MOVE A,@LDAPTR HLR TT,A ;GET ADDRESS OF SPECIAL CELL TRNE TT,777000 ;WAS SUCH AN ADDRESS REALLY THERE? JRST LDABS ; YES, WIN TRNE TT,6 ; NO, IS THIS ATOM A NUMBER? JSP D,LDFERR ; YES - LOSE!!! TRZE TT,20 ;IS IT NON INTERNED ID ? PCALL %GCPRO ;YES. PROTECT IT MOVE TT,T HRRZ A,@LDAPTR SKIPN A JSP D,LDFERR ;NO, LOSE IF NIL...ELSE PCALL BIND1 ;GET VALUE CELL MOVE TT,T HRLM A,@LDAPTR ;SAVE VC ADDR IN ATOMTABLE (LH). HRR TT,A ;AT LAST WE WIN JRST LDABS LDQAT: MOVE D,@LDAPTR ;[QUOTED ATOM] TLNN D,777001 ;SKIP IF SPECIAL OR ALREADY USED TLO D,1 ;ELSE TURN ON REFERENCE BIT MOVEM D,@LDAPTR HRRI TT,(D) ;GET ADDRESS OF ATOM JRST LDABS LDGLB: JSP D,LDFERR REPEAT 0,< SKIPL TT ;[GLOBALSYM PATCH] SKIPA TT,LSYMS(TT) ;GET VALUE OF GLOBAL SYMBOL MOVN TT,LSYMS(TT) ;OR MAYBE NEGATIVE THEREOF ADD TT,-1(R) ;ADD TO ADDRESS FIELD OF HRRM TT,-1(R) ; LAST WORD LOADED JRST LDBIN > PAGE LDQLS: MOVSI C,11 ;[QUOTED LIST] PCALL LDLIST ;GOBBLE UP A LIST JUMPE C,.+2 MOVEM TT,(R) ;PUT WORD IN BPS PSAVE A JSP T,LDGTWD ;GET HASH KEY FOR LIST PREST A PCALL %GCPRO ;PROTECT NEW LIST FROM GC. JUMPE C,LDEVL7 ;IF -2, THIS LIST GOES INTO ATOMTABLE. JRST LDABS1 ;OR -1, JUST INTO BPS. LDLIS0: JSP T,LDGTWD LDLIST: LDB T,[POINT 2,TT,2] ;[CONSTRUCT LIST] JRST @LDLTBL(T) LDLTBL: LDLATM ;ATOM LDLLST ;LIST LDLDLS ;DOTTED LIST LDLEND ;END OF LIST LDLATM: MOVE A,@LDAPTR TLNN A,777011 IOR A,C MOVEM A,@LDAPTR PSAVE A JRST LDLIS0 LDLLST: TDZA A,A LDLDLS: PREST A HRRZS TT JUMPE TT,LDLLS3 LDLLS1: PREST B PCALL XCONS SOJG TT,LDLLS1 LDLLS3: PSAVE A JRST LDLIS0 LDLEND: HLRZ C,TT TRC C,777776 ;-1 to 1, -2 to 0. TRNE C,777776 ;Any other? JSP D,LDFERR ; is error. PREST A MOVSS TT HRRI TT,(A) PRET PAGE LDPRC: MOVE D,@LDAPTR ;[PURIFIABLE CALL] TLNE D,777000 JRST LDPRC1 ;JUMP IF ATOM HAS SPECIAL CELL TLNE D,6 JSP D,LDFERR ;LOSE IF NUMBER TLO D,1 ;ELSE TURN ON REFERENCE BIT MOVEM D,@LDAPTR LDPRC1: TRNN D,-1 ;MUST HAVE NON-NIL ATOM TO CALL JSP D,LDFERR HRR TT,D ;PUT ADDRESS OF ATOM IN CALL SKIPGE T,LDPRLS(P) ;SKIP FOR PURIFYING HACKERY JRST LDABS ; Not active...DONE. MOVEM TT,(R) ;Store the call-word, HRRZ C,R ; and get its address... JSP AR5,TRYSMSH ;NOW TRY TO SMASH IT JRST LDABS1 ;SMASHED HRLI A,(R) ;NOT SMASHED ... HRR A,LDPRLS(P) ; APPEND ADDR TO PURE LIST PCALL DCONSA ; TO RE-TRY AT LDFEND. MOVEM A,LDPRLS(P) JRST LDABS1 IFN 0,< LDSMSH: LDB T,[POINT 9,(AR5),8] CAIL T,34 ;CALL CAILE T,35 ;JCALL PRET HRRZ A,(AR5) ;Pntr to atomhead. PCALL GETD ;TRY TO GET EXPR, FEXPR PROP LDB D,[POINT 4,(AR5),12] ;Destroys A,B,C,T,TT JUMPE A,CPOPJ1 ;Can't be smashed since undefined yet. CARA B,(A) MOVE T,APOPJ1 FOO CAIN B,EXPR MOVE T,[CAILE D,NSUA] FOO CAIN B,FEXPR MOVE T,[CAIE D,17] XCT T APOPJ1: JRST CPOPJ1 ;Don't smash if wrong # args wanted. CDRA A,(A) ;ELSE WIN - SMASH THE CALL CARA TT,(A) CAIE TT,ID CAIGE TT,CODMIN JRST CPOPJ1 CDRA A,(A) MOVE TT,(AR5) MOVSI T,(PCALL) ;FCALL BECOMES PCALL TLNE TT,1000 MOVSI T,(JRST) ;JCALL BECOMES JRST IOR T,A MOVEM T,(AR5) ;***SMASH!*** PRET > ;End of IFN 0 PAGE LDGET: JSP D,LDFERR REPEAT 0,< CAMN TT,XC-1 JRST LDLHRL MOVE D,TT ;[GET DDT SYMBOL PATCH] TLNN D,200000 ;MAYBE THE ASSEMBLER LEFT US A VALUE? JRST LDGET2 JSP T,LDGTWD ;FETCH IT THEN SKIPE LDF2DP JRST LDGET2 ;CAN'T USE IT IF VERSIONS DIFFER LDGET1: TLNE D,400000 ;MAYBE NEGATE SYMBOL? MOVNS TT LDB D,[400200,,D] ;GET FIELD NUMBER XCT LDXCT(D) ;HASH UP VALUE FOR FIELD MOVE T,LDMASK(D) ;ADD INTO FIELD ADD TT,-1(R) ; MASKED APPROPRIATELY AND TT,T ANDCAM T,-1(R) IORM TT,-1(R) JRST LDBIN LDGET2: PSAVE . ;RANDOM P SLOT PSAVE AR4 ;SAVE UP ACS PSAVE D PSAVE R PSAVE F MOVEI R,0 TLZ D,740000 CAME D,LAPFIV(R) ;IF DDTSYM REQUEST IS FOR A GLOBAL SYM JRST LDGT5A ;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS LSHC R,-2 ;GLOBALSYM INDEX FROM THE PERMUTATION TABLE LSH F,-42 LDB TT,LDGET6(F) MOVE TT,LSYMS(TT) JRST LDGT5B LDGT5A: MOVEI TT,R70 CAMN D,[SQUOZE 0,R70] JRST LDGT5B PCALL UNSQOZ ;CONVERT SQUOZE TO A LISP SYMBOL MOVEI C,(A) MOVEI B,QSYM ;TRY TO FIND SYM PROPERTY PCALL GET JUMPN A,LDGETJ ;WIN SKIPN JOBSYM JRST LDGETX LDB D,[004000,,-2(P)] LDGET4: MOVE TT,D IDIVI D,50 JUMPE R,LDGET4 PCALL GETDD0 JRST LDGETX PAGE LDGT5B: MOVEM TT,-4(P) ;WIN, WIN - USE RANDOM P SLOT MOVEI A,-4(P) ; TO FAKE UP A FIXNUM JRST LDGETJ LDGETX: MOVEI A,(C) PCALL NCONS MOVEI B,QGETDDTSYM ;DO A FAIL-ACT PCALL XCONS PCALL LDGETQ LDGETJ: PREST F ;RESTORE ACS PREST R PREST D PREST AR4 MOVE TT,(A) PCALL TYPEP ;FIGURE OUT WHAT WE GOT BACK PREST -1(P) ;POP RANDOM SLOT (REMEMBER THE LOCKI!) CAIN A,FIXNU JRST LDGET1 LDGETV: CAIN A,FLONU ;USE A FLONUM IF WE GET ONE JRST LDGET1 LDGETW: SKIPE TT,JOBSYM MOVSI TT,1 MOVEM TT,LDDDTP(P) JRST LDGET2 LDGETQ:; FAC [CAN'T GET DDT SYMBOL - FASLOAD!] LDGET6: REPEAT 4,<<11_^D24>+<<<3-.RPCNT>*11>_^D30> LAP5P(R) > LDXCT: MOVSS TT ;INDEX FIELD HRRZS TT ;ADDRESS FIELD LSH TT,^D23 ;AC FIELD JFCL ;OPCODE FIELD LDMASK: -1 ;INDEX FIELD 0,,-1 ;ADDRESS FIELD 0 17, ;AC FIELD -1 ;OPCODE FIELD LDLHRL: HRLZ TT,LDOFST ADDM TT,-1(R) JRST LDBIN > PAGE LDAREF: JSP D,LDFERR REPEAT 0,< PSAVE TT ;[ARRAY REFERENCE] MOVE D,@LDAPTR TLNN D,777001 TLO D,11 MOVEM D,@LDAPTR MOVEI A,(D) PCALL TTSR+1 ;NCALL TO TTSR HLL TT,(P) PXDROP R70+1 JRST LDABS > LDATM: LDB T,[POINT 3,TT,3] ;[ATOMTABLE ENTRY] JRST @LDATBL(T) LDATBL: LDATPN ;INTERNED ID LDATPI ;NON INTERNED ID LDATPS ;STRING LDATFX ;FIXNUM LDATFL ;FLONUM LDATBP ;POSNUM (POSITIVE BIGNUM) LDATBN ;NEGNUM (NEGATIVE BIGNUM) LDAREF ;TO GET ERROR LDATPB: MOVSI C,(TT) MOVN C,C HRRI C,0(SP) JSP T,LDGTWD MOVEM TT,1(C) AOBJN C,LDGTWD ; T still has return address PRET LDATPN: PCALL LDATPB ;[ATOMTABLE INTERNED ID ENTRY] PCALL INTER0 LDATP8: MOVE TT,LDAAOB MOVEM A,@LDAPTR AOBJP TT,LDAEXT MOVEM TT,LDAAOB JRST LDBIN LDATPI: PCALL LDATPB ;[ATOMTABLE NON INTERNED ID ENTRY] PCALL NOINTR TLO A,20 ;Mark for saving JRST LDATB2 PAGE LDATPS: PCALL LDATPB ;[ATOMTABLE STRING ENTRY] PCALL MSTR1 JRST LDATB2 LDATFX: JSP T,LDGTWD ;[ATOMTABLE FIXNUM ENTRY] PCALL FIX1A CAILE A,INUMIN TLOA A,12 ;INUM -- doesn't need GC pro. TLO A,2 JRST LDATP8 LDATFL: JSP T,LDGTWD ;[ATOMTABLE FLONUM ENTRY] PCALL FLO1A TLO A,4 JRST LDATP8 LDATBN: SKIPA C,[NEGNU] ;[ATOMTABLE NEGNUM ENTRY] LDATBP: MOVEI C,POSNU ;[ATOMTABLE POSNUM ENTRY] PSAVE C MOVEI C,(TT) MOVEI B,NIL LDATB1: JSP T,LDGTWD PCALL FWCONS PCALL CONS MOVE B,A SOJG C,LDGTWD ;T STILL HAS RETURN ADDRESS PREST B PCALL XCONS LDATB2: TLO A,6 JRST LDATP8 LDAEXT: MOVEI T,FTFULL JRST LDERRT REPEAT 0,< MOVM T,LDGROW ;[ATOMTABLE EXTEND] MOVNS T HRL TT,T MOVEM TT,LDAAOB ; Another page or so. MOVS TT,@LDAGCM ADD TT,T ; and protect the extension. MOVSM TT,@LDAGCM JRST LDBIN > PAGE LDENT: PCALL LDEPIN ;[ENTRY POINT INFO] FOO SKIPN VPREDEF JRST LDNRDF MOVE A,-1(P) PCALL GETD JUMPE A,LDNRDF MOVE A,-1(P) PSAVE R PSAVE AR4 PCALL WHEAD PCALL PRIN1 STRTIP [SIXBIT / REDEFINED!/] PCALL TOURET PREST AR4 PREST R LDNRDF: PREST B PREST C PREST A FOO CAIE B,SUBR JRST .+3 FOO MOVEI B,EXPR JRST .+4 FOO CAIE B,FSUBR JRST .+3 FOO MOVEI B,FEXPR SETOM FFFSUB PCALL IPUTD ;USES T,TT JRST LDBIN LDPEN: PCALL LDEPIN ;[PUT ENTRY POINT] PREST B PREST A PREST C PCALL PUT JRST LDBIN LDEPIN: HRRZ C,@LDAPTR ;[ENTRY POINT INFO] MOVSS TT HRRZ A,@LDAPTR PSAVE A ;ENTRY NAME. PSAVE C ;SUBR TYPE. JSP T,LDGTWD ;TT_<ARGS,,ENTRY-RELOC>... MOVEI A,@LDOFST CAILE A,(R) JSP D,LDFERR PCALL IMKCODE EXCH A,-2(P) JRST (A) PAGE LDLOC: JSP D,LDFERR REPEAT 0,< MOVEI TT,@LDOFST MOVEI D,(R) CAMLE D,LDHLOC MOVEM D,LDHLOC CAMG TT,LDHLOC JRST LDLOC5 MOVE D,LDHLOC SUBI D,(R) MOVSI D,(D) ADD R,D HRR R,LDHLOC SETZ TT, ADD AR4,[040000,,] JRST LDABS LDLOC5: HRRZ D,LDOFST CAIGE TT,(D) JSP D,LDFERR MOVEI D,(TT) SUBI D,(R) MOVSI D,(D) ADD R,D HRRI R,(TT) JRST LDBIN > PAGE LDPUT: JSP D,LDFERR REPEAT 0,< SKIPN A,V$SYMBOLS ;[PUT DDT SYMBOLS] JRST LDPUT3 CAIE A,SYMBOLS JRST LDPUT7 TLNN TT,40000 JRST LDPUT3 LDPUT7: SKIPN JOBSYM JRST LDPUT3 PSAVE AR4 JUMPL TT,LDPUT2 MOVE D,R LDPUT0: PSAVE D PSAVE F TLZ TT,740000 LDPUT1: MOVE T,TT IDIVI TT,50 JUMPE D,LDPUT1 MOVEI B,-1(P) MOVSI R,400000 PCALL PUTDD0 JRST LDRSTX LDPUT2: MOVE D,TT JSP T,LDGTWD EXCH TT,D TLNN TT,100000 JRST LDPT2A MOVE T,LDOFST ADD T,D HRRM T,D LDPT2A: TLNN TT,200000 JRST LDPUT0 HRLZ T,LDOFST ADD D,T JRST LDPUT0 LDPUT3: JUMPGE TT,LDBIN ;DON'T WANT TO PUT DDT SYM, BUT JSP T,LDGTWD ; MAYBE NEED TO FLUSH EXTRA WORD JRST LDBIN > PAGE LDEVAL: SETZ C, ;[EVALUATE MUNGEABLE] PCALL LDLIST PSAVE A PSAVE C PSAVE AR4 PSAVE R MOVEI A,(R) PCALL FIX1A FOO MOVEM A,VBPORG ;Permit the mungeable to alter BPORG. SKIPL A,LDPRLS-4(P) FOO HRRZM A,VP.URCLOBRL ;Save us in case of ERR. MOVE A,-3(P) PCALL EVAL EXCH A,-3(P) ;Save value, retrieve S-expr. PSAVE A FOO CDRA A,VP.URCLOBRL HRRM A,LDPRLS-5(P) FOO MOVE A,VBPORG PCALL NUMVAL PREST B PREST R SUBI A,(R) ;If BPORG unchanged, JUMPE A,LDEVL5 ; then leave R & FARRAY alone. JUMPLE A,LDEVL4 ; If lowered, keep R, just fix FARRAY. ADDM A,LDOFST ;Hence can't do future LDLOC ********** HRLI A,(A) ADD R,A ;Else decrease space-avail left. LDEVL4: FOO MOVE A,VFARRY ;Save S-exprs which change BPORG. PCALL XCONS FOO HRRZM A,VFARRY LDEVL5: PREST AR4 PREST C PREST A JUMPN C,LDBIN ;IF -1, THROW AWAY VALUE; PCALL %GCPRO ;OR -2, PROTECT & ENTER IN ATOMTABLE. LDEVL7: TLO A,16 ;FROM LDQLS, IS ALREADY PROTECTED JRST LDATP8 %GCPRO: HRRZ B,LDGPRO-1(P) PCALL CONS HRRM A,LDGPRO-1(P) CARA A,(A) ;RETURN WHAT WE JUST APPENDED. PRET PAGE LDBEND: CAME TT,[ASCII \FASLP\] ;[END OF BINARY] JSP D,LDFERR AOS LDEOFJ ;Now have seen End-of-Data in a file... ; Update BPS bounds and protect atoms ; from GC, then try for next file. LDFEND: ;[END OF FILE] HRRZ A,R CAMGE A,LDHLOC MOVE A,LDHLOC PCALL FIX1A FOO MOVEM A,VBPORG ;UPDATE BPORG HRRZ R,LDAAOB LDGCPR: SOJLE R,LDSDPL ;[GC PROTECT AS YET UNPROTECTED ATOMS] MOVEI TT,(R) MOVE AR5,@LDAPTR HRRZ A,AR5 TLNN AR5,777010 ;IF VALUE-CELL OR ALREADY PROTECTED, TLNN AR5,1 ;OR NO NEED (NEVER REF'D), JRST LDGCPR ; PASS BY. TLNE AR5,26 JRST LDGCP1 ;FIX,FLO,BIG,string or non-interned id JRST LDGCPR LDGCP1: HRRZ A,AR5 PCALL %GCPRO JRST LDGCPR LDSDPL: SKIPGE TT,LDPRLS(P) ;[RE-TRY SMASHING DOWN PURE LIST] JRST LDEOMM FOO MOVEM TT,VP.URCLOBRL ;Following retains locs unsmashed. FOO MOVEI R,VP.URCLOBRL LDSDP1: SKIPN TT,LDPRLS(P) JRST LDEOMM LDSDP2: CDRA T,(TT) MOVEM T,LDPRLS(P) CARA C,(TT) JSP AR5,TRYSMSH JRST LDSDP3 CDRA R,(R) JRST LDSDP1 LDSDP3: MOVE TT,LDPRLS(P) RPLCD TT,(R) JRST LDSDP1 PAGE LDEOMM: SKIPN A,LDGPRO(P) ;Have processed a FASL file completely, JRST LDFNIL FOO MOVE B,VF.LIST ; and protected internal Lisp node refs PCALL CONS ; off the PDL with this final save. FOO MOVEM A,VF.LIST LDFNIL: MOVE A,LDAGCM MOVE A,(A) ;Now clear array (so won't be SSAVEd), SETZM 0(A) ; and read til true EOF does ERR $EOF$ AOBJN A,.-1 ; or see start of next FASL in series. ;However, doesn't clear access routine. SETOM LDEOFJ ;EOF will be okay, or start of next file. JRST LDMORE ;Continue, with the extra PDL cells. LDGTWD: PCALL TYID ;This is BINI w/o Lisp # conversion... MOVE TT,A ; so inputting a 36-bit word or $EOF$. JRST 0(T) FASLNC: MOVEI T,BPFULL JRST LDERRT LDFERR: SKIPGE T,LDEOFJ ;Externally invoked after any ERRSET. JRST LDFSUB ; OK - return after proper EOF. MOVE T,LDEOFJ LDERRT: MOVEI A,LDERRN ;Change... MOVEM A,LDEOFJ ; Avoid doubly-printed LERRs. CAILE T,LDERRN ERRL1 ^D149,[SIXBIT \FASLOAD BUG!\] JRST .+1(T) ;Else dispatch to the various errs... LDERR0: ERRL1 ^D150,[SIXBIT \FASLOAD EMPTY FILE!\] ERRL1 ^D151,[SIXBIT \FASLOAD FORMAT ERR!\] ERRL1 ^D152,[SIXBIT \FASLOAD GC-PRO ERR!\] ERRL1 ^D153,[SIXBIT \FASLOAD EXCEEDS BPS!\] ERRL1 ^D154,[SIXBIT \FISLTABLE FULL!\] LDERRN==.-LDERR0 ERRL1 ^D155,[SIXBIT \NOGO!\] LDFSUB: SKIPN FFFSUB PRET SETZM FFFSUB FOO SKIPE %MSG STRTIP [SIXBIT /_*** (F)SUBR CONVERTED TO (F)EXPR_!/] PRET > ;End of IFN OFLD IFN OFLD!NFLD,< ;Try convert slow link to fast link TRYSMSH:HRRZ A,(C) ;right half of instruction HLRZ T,(C) ;left half CAIL T,(FCALL) ;is it FCALL or CAILE T,777(JCALL) ; JCALL JRST (AR5) ;No! Treat as sucessful, i.e. never smash PCALL GETD ;get function definition JUMPE A,1(AR5) ; unsucessful if wasn't there MOVSI TT,(PCALL) ; replacement FCALL - PCALL TRNE T,1000 MOVSI TT,(JRST) ; JCALL - JRST ANDI T,740 ;Now check EXPR - FEXPR FOO MOVEI D,EXPR CAIN T,740 FOO MOVEI D,FEXPR ;argcount 17 means call a FEXPR CARA B,(A) ;get function type CAIE B,(D) ;is it right type for the call? JRST 1(AR5) ;No! unsucessful CDRA A,(A) ;code part CARA D,(A) ;check tag CAIE D,ID CAIGE D,CODMIN JRST 1(AR5) ;not a code pointer! unsucessful HRR TT,(A) ;get code address into new instruction MOVEM TT,(C) ;change instruction JRST (AR5) ;sucessful > ;End of IFN OFLD!NFLD IFN NFLD,< ;New version of FASLOD FASLOAD:PSAVE [0] ;internal F.LIST HRRM P,LDQLIS ;save its pointer FOO SKIPE VPURIFY ;want to try converting slow links to fast? TDZA B,B ;yes SETO B, ;no! make negative to indicate that PSAVE B ;internal P.URCLOBRL HRRM P,LDPURC ;save its pointer MOVEM P,LDSTCK# ;save for stack check at end JSP D,ATMTYP ;check F.ISLTABLE CAIE TT,VECT ;is it a vector? ERRL2 ^D168,[SIXBIT /NO TABLE FOR FASL!/] ;no! error CDRA A,(A) ;get its base address SETZM (A) ;first element is NIL HRRM A,CTOPAT ;current top of table HRRM A,LDATBAS ;base of table JSP T,RSTBPO ;set internal BPORG and BPEND SETZM CALHLF ;indicate need new word in half word buffer MOVEI D,LDLOP+1 ;return address for LDBYT LDNWD: PCALL TYID ;byte buffer is empty. get new word MOVEM A,LDBTWD ;save word in buffer MOVE A,[POINT 6,LDBTWD] ;get byte pointer MOVEM A,LDBTPO# ;save it LDBYT: ILDB A,LDBTPO ;get a byte JUMPN A,(D) ;not 0 means not empty buffer HRRZ TT,LDBTPO ;buffer might be empty CAIN TT,LDBTWD ;does pointer still point to buffer? JRST (D) ;yes! 0 byte JRST LDNWD ;no! buffer empty LDID: JSP D,LDHLF ;Get length of id PCALL %FSLID+1 ;make interned id LDPUTA: AOS .+1 ;update top of table CTOPAT: MOVEM A,X ;move object into table ;this is the loader loop LDLOP: JSP D,LDBYT ;get new loader code byte CAIG A,LDBTMX ;is it a legal code JRST @LDJTAB(A) ;Yes! Dispatch ERRL2 ^D169,[SIXBIT /FASL FORMAT ERROR!/] ;No! Error LDJTAB: LDEND LDID LDGENSYM LDSTRNG LDPOSN LDNEGN LDFIXN LDFLON LDQUO LDCAL LDRLO LDAXCON LDXCON LDOFFSET LDENTRY LDXPR LDLAPBLOCK LDNCON LDPUTV LDMKVCT .LDABS LDPUSH .LDEVAL LDFLUID LDSYM LDEVID LDSETQ LDIPUT .LDPUT LDIPTD LDPUTD LDNUMP LDXPRS LDPOP LDEVIX .LDLIST LDPOPN LDPROTECT LDBTMX==.-LDJTAB-1 LDGENSYM: ;make non interned id FOO MOVEI C,PNAME PCALL MKFWLIS ;make print name list PCALL IDCONS-1 ;make into id JRST LDPUTA ;put into table LDPOSN: SKIPA C,CPOSNU ;positive bignum LDNEGN: MOVEI C,NEGNU ;negative bignum JRST LDSTRNG+1 LDSTRNG:MOVEI C,STRNG ;string PCALL MKFWLIS ;read and make full word list JRST LDPUTA ;put into table MKFWLIS:JSP D,LDHLF ;read length of list MOVE TT,A ;save count SKIPA B,[0] ;start with NIL MOVE B,A ;current list PCALL TYID ;read a word PCALL BCONS ;cons into list SOJG TT,.-3 ;go back for more HRL A,C ;get tag JRST DCONSA ;cons it LDFIXN: PCALL BINI ;read a fixnum JRST LDPUTA ;put into table LDFLON: PCALL TYID ;read a word PCALL FLO1A ;tag as floating point number JRST LDPUTA ;put into table LDMKVCT:JSP T,SAVBPO ;allow BPORG to be changed JSP D,LDHLF ;get uplim for vector PCALL MKVECT+1 ;make vector HRRZ C,(A) ;vector address HRRM C,CLIPTV ;update "current vector base" MOVE C,A JSP T,RSTBPO ;update internal BPORG MOVE A,C JRST LDPUTA ;put vector into table LDPUSH: MOVEI T,LDPU1 ;return address, push on stack LGETVX: JSP D,LDHLF ;get table index HRRZ A,@LDATBAS ;get element from table JRST (T) .LDABS: MOVEI D,LDPU1 ;push on stack LDHLF: SETZ A, EXCH A,CALHLF# JUMPN A,.+3 PCALL TYID ;half word buffer empty. read new word HLROM A,CALHLF ;save in buffer, -1 in lh make non-zero MOVEI A,(A) ;get right half (get rid of -1) JRST (D) ;return LDAXCON:MOVEI D,.+3 ;make list ending with absolute JRST LDHLF LDXCON: JSP T,LGETVX ;make list ending with table element SKIPA TT,A ;save table element in TT LDNCON: SETZ TT, ;end with NIL (ordinary list) JSP D,LDHLF ;length of list EXCH A,TT ;get end into A PREST B ;get element from stack PCALL XCONS ;cons into list SOJG TT,.-2 ;maybee more LDPU1: PSAVE A ;save on stack JRST LDLOP ;return to loop ;execute EXPR, arguments are on stack. put result on stack LDXPR: JSP T,LGETVX ;get function id from table PSAVE A ;save it LDXPRS: JSP T,SAVBPO ;function is on stack JSP D,LDBYT ;number of args PREST REL ;function DPB A,[POINT 4,LDCALL,ACFLD] ;update call instruction MOVN T,A JSP TT,PDLARG ;put args into regs LDCALL: CALLF X,(REL) ;call function PSAVE A ;save result on stack MOVEI T,LDLOP ;return address RSTBPO: ;Update internal BPORG and BPEND as the might have been changed FOO HRRZ A,VBPEND PCALL NUMVAL HRRM A,LDBPEN ;update internal BPEND FOO HRRZ A,VBPORG PCALL NUMVAL HRRM A,LDBPOR ;update internal BPORG JRST (T) .LDEVAL:JSP T,SAVBPO JSP T,LGETVX ;get fexpr id PREST B ;argument list PCALL CONS PCALL EVAL ;evaluate fexpr JRST LDCALL+1 LDPOP: P1DROP ;remove top of stack JRST LDLOP LDEVID: JSP T,LGETVX ;get id from table PCALL EVAL ;get its value JRST LDPU1 ;push it on stack LDSETQ: JSP T,LGETVX ;get id from table PCALL BIND1 ;get its value cell PREST (A) ;update value cell from stack JRST LDLOP LDIPUT: JSP T,LGETVX ;get id from table HRRM A,CLIPUT ;update "current property indicator" JRST LDLOP LDIPTD: JSP T,LGETVX HRRM A,CLIPTD ;update "current function type" JRST LDLOP .LDPUT: JSP T,LGETVX PREST C ;property value CLIPUT: MOVEI B,X ;property indicator PCALL PUT JRST LDLOP LDPUTD: JSP T,LGETVX PSAVE A ;save function id FOO MOVEI B,TRACE ;remove TRACE property PCALL REMP1 FOO SKIPN VPREDEF ;want to warn for redefined function JRST NOPRDF ;no! MOVE A,(P) ;is function PCALL GETD ; already defined JUMPE A,NOPRDF MOVE A,(P) ;yes! PCALL WHEAD ;warning header PCALL PRIN1 ;print function name STRTIP [SIXBIT / REDEFINED!/] PCALL TOURET ;return to current output NOPRDF: PREST C ;function id PREST A ;function body CLIPTD: MOVEI B,X ;function type PCALL IPUTD ;define it JRST LDLOP LDPUTV: JSP D,LDHLF ;get vector index PREST C ;value to put into vector SETZ B, LSHC A,-1 JUMPN B,.+3 ;B = 0 means even index CLIPTV: HRLM C,X(A) ;X is current vector base. updated by LDMKVCT JRST LDLOP HRRM C,@CLIPTV ;odd index. value goes into right half JRST LDLOP LDLAPBLOCK: ;load a block of code JSP D,LDHLF ;no of words to load LDBPORG:MOVEI R,X ;internal BPORG MOVEI C,(R) ADDI C,(A) ;new BPORG LDBPEND:CAILE C,X ;compare with internal BPEND JRST BINER2 ;error if bigger HRRM C,LDBPOR ;update BPORG HRRM R,LDRLBAS ;set block base addres for relocation SOJ R, HRRM R,LDRSTRT ;set patch address base HLLZS MPAFUN ;no patch function seen MOVNI C,(A) ;make HRL R,C ; iowd PCALL TYID ;read a word MOVEM A,1(R) ;deposit in BPS AOBJN R,.-2 ;maybee more JRST LDLOP MAPAT: MOVEI C,X ;old patch address ADDI C,77 MOVEI T,(T) ;patching function CAIE T,@MPAFUN ;same as old LDRSTRT: MOVEI C,X ;no! use patch base address. set by LDLAPBLOCK HRRM T,MPAFUN ;set current patch function MPARET: JSP D,LDBYT ;Get relative patch address. Patch funs return here JUMPE A,[HRRM C,MAPAT ;0 byte means save patch address JRST LDLOP] ; and end patching ADDI C,(A) ;update patch address HRRZ A,(C) ;get index or address MPAFUN: JRST X ;go patch LDRLO: JSP T,MAPAT ;enter patch loop LDRLBAS:ADDI A,X ;relocation base HRRM A,(C) ;put into instruction JRST MPARET ;return to patch loop LDQUO: JSP T,MAPAT ;enter patch loop HRRZ A,@LDATBAS ;get element from table HRRM A,(C) ;put in instruction JRST MPARET LDCAL: JSP T,MAPAT ;enter patch loop HRRZ A,@LDATBAS ;get table element HRRM A,(C) ;put in instruction LDPURC: SKIPL REL,X ;If iternal PURIFY switch is on JSP AR5,TRYSMSH+1 ; try to convert slow link to fast JRST MPARET ;did it or no PURIFY! return to patch loop MOVE A,REL ;couldn't do it. get internal P.URCLOBRL HRLI A,(C) ;cons instruction address PCALL DCONSA ; into list MOVEM A,@LDPURC ; and move into P.URCLOBRL JRST MPARET ;return to loop LDFLUID:JSP T,LGETVX ;get id from table PCALL BIND1 ;get its value cell JRST LDPUTA ;put it into table LDEVIX: MOVE A,(P) ;top of stack JSP D,NATMTYP ;check if it needs to be gc-protected JRST LDEPRO ;not atom! needs protection JUMPE TT,.LDLIST ;INUM doesn't need potection CAIE TT,ID ;is an id? JRST LDEPRO ;no! protect PCALL .INTERNP ;is it interned JUMPN A,.LDLIST ;if yes, don't protect MOVE A,(P) ;get top of stack LDEPRO: CDRA B,@LDQLIS ;internal F.LIST PCALL CONS HRRM A,@LDQLIS ;update internal F.LIST .LDLIST:PREST A ;take top of stack JRST LDPUTA ;put it into table LDSYM: JSP T,LGETVX ;get id from table MOVE T,A ;save in case of error FOO MOVEI B,SYM ;get SYM PCALL GET ; property JUMPE A,[MOVE A,T ;if none ERRE2 ^D38,[SIXBIT / IS NOT A SYM!/]] ;error PCALL NUMVAL ;get address JRST LDPUTA ;put into table LDOFFSET: JSP T,LGETVX ;get address from table MOVE T,A ;save it JSP D,LDHLF ;get offset ADDI A,(T) ;update address JRST LDPUTA ;put it into table LDNUMP: JSP T,LGETVX ;get object from table PCALL FIX1A ;convert to number JRST LDPU1 ;put on stack LDPOPN: PREST A ;get top of stack PCALL NUMVAL ;convert to address JRST LDPUTA ;put into table LDPROTECT: ;protect objects by consing them into internal F.LIST LDQLIS: CDRA B,X ;get internal F.LIST JRST .+3 ;enter loop PCALL CONS ;cons object into list MOVE B,A ;save list JSP T,LGETVX ;get new object JUMPN A,.-3 ;if not NIL go back HRRM B,@LDQLIS ;update internal F.LIST JRST LDLOP LDENTRY:HRRZ C,LDRLBAS ;get start of lap block JSP D,LDHLF ;get relative address ADDI C,(A) ;get real address JSP D,LDBYT ;no of args EXCH A,C PCALL IMKCODE ;make code pointer JRST LDPU1 ;push on stack LDEND: CAME P,LDSTCK ;end of loading. check stack consistency ERRL2 ^D170,[SIXBIT /FASL STACK OUT OF SYNC!/] PREST B ;internal P.URCLOBRL JUMPL B,NOPURC ;negative if PURIFY is off FOO MOVEI A,VP.URCLOB PCALL NCONC ;concatenate to P.URCLOBRL MOVE REL,A ;try smash instructions on list CDRA AR4,(REL) JRST SMSHLE ;enter loop SMSHLP: CARA C,(AR4) ;get instruction address JSP AR5,TRYSMSH ;try smash instruction JRST .+2 ;Smashed! MOVE REL,AR4 ;Not smashed! keep address in list CDRA AR4,(AR4) ;next element HRRM AR4,(REL) ;this will remove address of smashed instruction SMSHLE: JUMPN AR4,SMSHLP ;if more go back NOPURC: PREST B ;internal F.LIST FOO HRRZ A,VF.LIST ;F.LIST PCALL XCONS ;save internal F.LIST on F.LIST FOO HRRM A,VF.LIST ;update F.LIST MOVEI T,CPOPJ ;return address SAVBPO: HRRZ A,LDBPEN PCALL FIX1A FOO HRRZM A,VBPEND HRRZ A,LDBPOR PCALL FIX1A FOO HRRZM A,VBPORG ;Allow change of BPORG JRST (T) LDBTWD: X LDATBAS:Z X(A) ;First six bits of this word must be 0 to make LDBYT correct ;%FSLID is an EXPR that reads an id from a FSL file, it is used by ; the PRELOAD device. %FSLID: PCALL TYID ;Get length of id MOVN C,A ;make HRLZI C,(C) ; HRRI C,(SP) ; iowd PCALL TYID ;get a word MOVEM A,1(C) ;put in buffer AOBJN C,.-2 ;get more if not finished JRST INTER0 ;intern it > ;End of IFN NFLD SUBTTL ALVINE AND LOADER INTERFACES --- PAGE 22 ;interface to alvine IFN AED,< ED: MOVEI REL,X ;Reset to EDP2 by: STRT, EXCISE, EXCORE. JRST (REL) EDP2: PSAVE A HRRZ A,CORUSE HRRM A,LST AOS A HRRM A,ED MOVSI A,(SIXBIT /ED/) PCALL SYSINI HRLM A,LST MOVNS A PCALL MORCOR PCALL SYSINQ PREST A JRST ED GRINDEF:PSAVE A PCALL ED PREST A JRST 2(REL) > ;end of IFN AED EXCISE: MOVE A,JRELO IFN AED,<MOVEI B,EDP2 HRRM B,ED> IFN ALOD,SETZM LDFLG ;initial loader symbol table flag CALLI A,CORE JRST .+1 JSR IOBRST IFE HCBPS,PCALL CHKVBP ;Ensure BPORG and BPEND in low BPS. JRST TRUE PAGE VAR LIT PAGE ; lisp loader interface IFN ALOD,< LOAD: AOS B,CORUSE MOVEM B,OLDCU# MOVEM A,LDPAR# JUMPE A,LOAD2 ;If NIL, @.JBREL+1 FOO MOVE A,VBPORG ; else into BPS @BPORG. PCALL NUMVAL MOVE B,A LOAD2: MOVEM B,RVAL ;final destination of loaded code MOVSI A,(SIXBIT /LOD/) PCALL SYSINI SUBI A,150 ;extra room for locations 0 to 137 and slop MOVNS A ;length(loader) = 5400 approx. HRRZM A,LODSIZ# ADDI A,10 ;Space for start of symbol table etc. PCALL MORCOR ;expand core for loader MOVEM A,LOWLSP# ;location of blt'ed low lisp MOVE B,LODSIZ ADD B,A MOVEM B,HVAL ;temporary destination of loaded code HRLI A,0 ;<0,,LOWLSP> -- HVAL. BLT A,(B) ;blt up low lisp HLL A,NAME+3 ;IOWD length(loader),137 . HRRI A,137-1 PCALL SYSINP SKIPE LDFLG# JRST LOAD3 ;If already have them, skip SYMs. MOVSI A,(SIXBIT /SYM/) PCALL SYSINI MOVNS A ;length symbols PCALL MORCOR ;expand core for symbols SKIPGE B,.JBSYM SOS B ;if no symbol table, use original jobsym. HLRZ A,NAME+3 ;-length(symbols) ADDB A,B HLL A,NAME+3 ;symbol table iowd PCALL SYSINP HRRM B,.JBSYM HLLZ A,NAME+3 ADDM A,.JBSYM SETOM LDFLG ;Lisp symbols loaded, until next EXCISE. SKIPA LOAD3: SOS .JBSYM ;want jobsym to point one below 1st symbol MOVE 3,HVAL ;h MOVE 5,RVAL ;r MOVE 2,3 SUB 2,5 ;x=h-r HRLI 5,12 ;(w) -- LH index needed because HRLI 2,11 ;(v) uses @X, etc. SETZB 1,4 ;(N,S) IFN SYDEV,<MOVE 4,SYSNUM> ;Tell Loader current SYS: used by Lisp. JSP 0,140 ;call the loader LOAD4: HRRZM 5,RLAST# ;last location loaded(in final area) MOVE T,OLDCU MOVE A,.JBSYM MOVEM A,.JBSYM(T) MOVE A,.JBREL MOVEM A,.JBREL(T) ;update jobrel HRLZ 0,LOWLSP SOS LODSIZ AOBJN 0,.+1 ;<LOWLSP+1,,A> -- LODSIZ. BLT 0,@LODSIZ ;blt down low lisp MOVE 0,@LOWLSP ;<LOWLSP,,NIL> -- all accs now restored. MOVE B,RLAST MOVE A,RVAL HRL A,HVAL ;<HVAL,,RVAL> -- RLAST. SKIPE LDPAR JRST BINLD ;If into BPS, check room first. MOVE C,RLAST ;new coruse LDRET2: BLT A,(B) ;blt down loaded code HRRZM C,CORUSE ;top of code loaded MOVEI B,1 ANDCAM B,.JBSYM SUB C,.JBSYM ;length of free core ORCMI C,776000 AOJGE C,START ;no contraction ADD C,.JBREL ;new top of core MOVE B,C PCALL MOVDWN HRLM C,.JBSA CALLI C,CORE ;contract core JRST .+1 JRST START BINLD: PSAVE A ;Check for BPS exceeded... PSAVE B ;<MOVEI C,INUM0(B) CDRA A,B ; CAML C,VBPEND PCALL FIX1A ; JRST BPSERR PSAVE A ; MOVEM C,VBPORG> FOO MOVE B,VBPEND PCALL .LESS JUMPE A,[SETOM BPSFLG ;Flag "BPS exceeded" for LISP2 check. JRST START ] FOO PREST VBPORG ;Update it; loading fits. PREST B PREST A SOS C,OLDCU ;old top of core JRST LDRET2 > ;end of IFN ALOD PAGE IFN AED!ALOD,< SYSINI: MOVEM A,NAME+1 IFLE <OPSYS+SYDEV-1>,<SETZM NAME+3 > IFN SYDEV,<PSAVE SYSNUM IFLE OPSYS,<PREST .+2> IFG OPSYS,<PREST NAME+3> > INIT 17 IFE SYDEV,<SIXBIT /SYS/ > IFN SYDEV,< IFLE OPSYS,< X > IFG OPSYS,<SIXBIT /DSK/ > > 0 JRST AIN.4+1 LOOKUP NAME JRST SYSINER ;error INPUT [IOWD 1,NAME+3 ;input size of file 0] HLRO A,NAME+3 PRET SYSINER:RELEASE IFE ALOD,<ERRL1 ^D156,[SIXBIT /LISP.ED MISSING!/]> IFN ALOD,< MOVSI B,(SIXBIT /SYM/) CAME A,B ;Are we in LOAD mode? IFN AED,ERRL1 ^D156,[SIXBIT /LISP.ED OR LOD MISSING!/] ;No, safe to use IFE AED,ERRL1 ^D156,[SIXBIT /LISP.LOD MISSING!/] ; low core routines. OUTSTR [ASCIZ / LISP.SYM not found!! No load. /] ; Yes -- Loader in low core, though, MOVE 5,RVAL ; so have to fake the BLT JRST LOAD4 ; with original RVAL. > ;end of IFN ALOD NAME: SIXBIT /LISP/ ;Filename of system, 0 ; .* auxiliaries (e.g. SYM, LOD, ED). 0 0 > ;end of IFN ALOD!AED PAGE IFN ALOD,< SYSINP: MOVEM A,LST> ;LOAD IFN ALOD!AED!RWB,< SYSINQ: ;ED, RBLK IFN OPSYS,< ;KLUDGE to circumvent bug in PA1050... MOVS A,LST ; to wit: uses SIN which plants a nul, SUB A,LST ; which clobbers wd after input-blk. HLRZ A,A IFN HCBPS,<CAIGE A,400000> CAMGE A,.JBREL PSAVE 1(A) INPUT LST IFN HCBPS,<CAIGE A,400000> CAMGE A,.JBREL PREST 1(A) > IFE OPSYS,<INPUT LST> ;ELSE just input it. STATZ 740000 ERRL1 ^D157,AIN.8 RELEASE PRET LST: 0 0 > ;end of IFN ALOD!AED!RWB AIN.8: SIXBIT /INPUT ERROR!/ PAGE IFN ALOD,< MOVDWN: HLRZ A,.JBSYM JUMPE A,MOVS1 ADDI A,1(B) HRL A,.JBSYM HRRM A,.JBSYM BLT A,(B) ;downward blt PRET MOVSYM: MOVE B,.JBREL HRLM B,.JBSA HLRE A,.JBSYM JUMPE A,MOVS1 ADDI B,1(A) ;new bottom of symbol table MOVNI A,1(A) ADD A,.JBSYM ;last loc of old symbol table HRRM B,.JBSYM PSAVE C MOVE B,.JBREL ;last loc of new symbol table MOVE C,(A) ;simulated upward blt MOVEM C,(B) SUBI B,1 ADDI A,-1 ;lf+1,rt-1 JUMPL A,.-4 PREST C PRET MOVS1: HRRZM B,.JBSYM PRET> ;end of IFN ALOD ;enter with size needed in a ;exit with pointer in a to core MORCOR: PSAVE B PCALL EXPND2 MOVE B,CORUSE# ADDM A,CORUSE MOVE A,B PREST B PRET EXPND2: HRRZ B,.JBSYM SUB B,CORUSE SUBM A,B JUMPL B,EXPND3 ADD B,.JBREL ;new core size CALLI B,CORE ;expand core TCORE3: ERRL1 ^D158,[SIXBIT /CAN'T EXPAND CORE!/] IFN ALOD,<PSAVE A PCALL MOVSYM PREST A> IFE ALOD,<MOVE B,.JBREL HRRZM B,.JBSYM HRLM B,.JBSA> EXPND3: PRET SUBTTL SOSLINK INLINE WITH LISP MAIN --- PAGE 23 %FPAGE: SUBI A,INUM0 ;FIND-PAGE N, IN THE FILE. PSAVE A %FP.LP: SOSG A,0(P) JRST POPAJ ;Stop when get there, returning 0=NIL. PCALL TYI ;(ERR $EOF$) if too few <ff>. CAIE A,14 JRST .-2 JRST %FP.LP %NEXTTYI: PCALL TYI ;Doing a PEEKC(). MOVEM A,OLDCH JRST FIX1A FILEP: PCALL FILEPX RELEASE 0, PRET FILEPX: PSAVE A ;Test for a file's existence. MOVSI B,(SIXBIT /DSK/);Clear any left over. MOVEM B,DEV SETZM PPN JUMPE A,.+3 JSP D,ATMTYP PCALL NCONS MOVE T,A ;Permit @((F.E)) or full @(DIR: D F.E)) . PCALL IOSUB MOVEM A,LOOKIN IFN SYDEV,<PCALL SYSDEV > ;Change SYS: if necessary. MOVE A,DEV MOVEM A,DEV2 INIT 0,17 DEV2: X 0 JRST AIN.7 PREST A LOOKUP 0,LOOKIN ;Using chan 0 (no INC or INPUT needed). MOVEI A,NIL ; file not found. PRET PAGE IFN SOSSW,< %SOSSWAP: SUBI 2,INUM0 ;(PAGE # .LT. 2^16, OF COURSE). SUBI 4,INUM0 LSH 4,^D16 ;ERGO, 2 BECOMES 400000 PSAVE 4 PSAVE 2 PSAVE 1 ;FILE SPECIFICATION MOVE 1,3 PCALL NUMVAL ;(LINE # .LT. 99999). MOVE 4,[POINT 7,T,34] MKLIN1: IDIVI 1,^D10 ADDI 2,60 DPB 2,4 ADD 4,[XWD 70000,0] TLNN 4,400000 JRST MKLIN1 TRO T,1 EXCH T,(P) ;T WILL NOW CONTAIN FILE SPECIFICATION SETZM DEV PCALL IOSUB ;RETURNS FILENM IN A MOVEM 17,ACSAV+17 MOVEI 17,ACSAV BLT 17,ACSAV+16 ;SAVE ACCS 0-17 for return from subr. PREST 15 PREST 16 PREST 13 ;00/01/02 == GET,R-O,CREATE. MOVEM P,ACSAV+P MOVE 14,A HLL 13,EXT ;SET BY IOSUB IFGE OPSYS,<CALLI 11,24 ;GETPPN UUO SETZ 11, HRRZS 11 > IFL OPSYS,<GJINF MOVE 11,2 > SETZB 1,12 ;HIGH ACCS FOR SOS ARE NOW SET ... TO WIT: ; ;ACC 11 = PPN ; 12 = (UNUSED). ; 13 = EXT,,FLAGS ;BITS 18-19 = 0 (GET FILE), 1 (READ-ONLY), 2 (CREATE IT) ; 14 = FILENM ; 15 = LINE #, IN ASCID FORM (BIT 35 ON); ; 16 = PAGE #. PAGE IFE OPSYS, < ;USE LABORIOUS METHOD OF MAKING CORE-IMAGE. ; == FOR 10/50 SYSTEMS...VESTIGIAL. ;SWAP IS NOT DECLARED INTERNAL/SUBR (THO IT COULD BE). ;FIRST SAVES ALL ACCUMULATORS AS FILE 'QQSVAC.TMP' ;SAV -- SWAPS OUT (EFFECTIVELY) 116 THRU MIN(LH(E+2),.JBREL) ; -- MUST GO TO THE DISK (& WILL, REGARDLESS OF DEVICE). ; -- USES 1; DOES NOT SAVE ANY HIGH SEGMENT !!! ; -- THE FORMAT IS A NON-ZERO-COMPRESS (75--END). ; -- THE ACCS ARE RESTORED IF A RUN IS NOT DONE. ;RUN -- USES THE DEC RUN-UUO WHICH DESTROYS THE ACCUMULATORS ; -- THEREFORE, IF YOU WISH TO PASS ARGUMENTS (IN THE ACCS) ; -- TO THE NEW PROGRAM, PICK THEM UP FROM THE TMP FILE. EXTERNAL .JBCOR,.JBS41,.JBDDT SLOC==74 .JBSDD==114 SWAP: MOVEI 1,ACBLK BLT 1,ACBLK+17 ;CAN'T OUTPUT FROM BELOW LOC 115 MOVE 1,[XWD ACSAV,6] ;RESTORE UNCLOBBERED HI-ACCS BLT 1,17 CALLI 1,30 ;PJOB IDIVI 1,^D10 LSH 1,6 OR 1,2 LSH 1,^D24 OR 1,[SIXBIT/00SVAC/] MOVEM 1,ACHEAD ADDI 1,5460-4143 ;'LP' - 'AC' INIT 17 ;DUMP MODE SIXBIT /DSK/ 0 ;NO BUFFERS JRST AOUT.4+1 SETZM ACHEAD+2 SETZM ACHEAD+3 ENTER ACHEAD ERRL1 ^D159,SWOUT2 OUTPUT [IOWD 20,ACBLK 0] STATZ 740000 ERRL2 ^D160,SWOUT2 CLOSE STATZ 740000 ERRL2 ^D161,SWOUT2 MOVEM 1,IOFILE SETZM IOFILE+2 SETZM IOFILE+3 ENTER IOFILE ERRL2 ^D162,SWOUT2 HRRZ 2,.JBCOR MOVEM 2,OLDCOR MOVE 2,.JBREL HRRM 2,.JBCOR SUBI 2,SLOC ;NOT OUTPUTTING FIRST 0-SLOC LOCS MOVEM 2,1 ;N WORDS OF DATA MOVN 2,2 SUBI 2,1 ;-(N+1) == DATA + NULL HEADER WORD HRLM 2,OLIST MOVE 2,.JBREL HRRM 2,MVX+^D9 ;HIGHEST LOC BEFORE RELOC = DITTO BLT ADDI 2,2000 CALLI 2,CORE ;SPACE TO RELOCATE INTO ERRL2 ^D163,SWOUT2 MOVE 3,[XWD MVX,MV] BLT 3,MVE MOVE 3,[XWD 216,116] JRST MV MVX: PHASE 4 MV: MOVE 2,SLOC(1) MOVEM 2,SLOC+100(1) ;MOVE 100 UPWARD SOJG 1,MV SETZM SLOC+100 ;NULL HEADER WORD MOVE 2,.JBDDT MOVEM 2,.JBSDD+100 MOVE 2,.JB41 MOVEM 2,.JBS41+100 OUTPUT OLIST+100 ;AT RELOCATED IOWD BLT 3,0-0 ;MOVE BACK DOWN MVE: JRST MVY DEPHASE MVY: MOVE 2,[XWD ACSAV,6] BLT 2,17 ;RESTORE AGAIN OVER CODE HRRZ 2,MVX+^D10 CALLI 2,CORE ;REDUCE CORE BY 1K TO PREVIOUS STRTIP [SIXBIT /_*** WOULDN'T REDUCE CORE_!/] STATZ 740000 ;NOW CHECK FOR OUTPUT ERRORS ERRL2 ^D164,SWOUT2 CLOSE 0, STATZ 740000 ERRL2 ^D165,SWOUT2 RELEAS 0, MOVE 2,OLDCOR HRRM 2,.JBCOR RUNUUO: SETZM NEWCOR MOVSI 1,1 ;SA INC HRRI 1,DEVC2 CLRBFI ;DELETE CR,LF IF ANY...DISTURB SOS. CALLI 1,35 ;RUN UUO HALT ; POSSIBLY RECOVERABLE, BUT EXIT ANYWAY ACBLK: BLOCK 20 DEVC2: SIXBIT/SYS/ SIXBIT/SOS/ SIXBIT/SAV/ 0 0 NEWCOR: OLDCOR: 0-0 IOFILE: ACHEAD: SIXBIT/QQSVAC/ SIXBIT/TMP/ 0 0 OLIST: XWD 0-0,SLOC+100-1 0 SWOUT2: SIXBIT /COULDN'T SWAP SUCCESSFULLY_!/ > ;******** CLOSE OF IFE OPSYS, FROM SWAP: ********. PAGE IFN OPSYS, < ;EASIER WITH TENEX %SWAP: MOVSI 1,1 ;SET B17 MOVE 2,[POINT 7,FILSOS] GTJFN JRST SOSER1 HRRZ 3,1 ;AC1(RH) NOW HAS DESIRED JFN. MOVSI 1,(1B1+1B3) ;Spec. cap. & use AC2. MOVEI 2,0 ;VIRTUAL ADDRESS OF ACCS. CFORK ;CREATE INFERIOR FORK. JRST SOSER2 EXCH 1,3 HRL 1,3 ;SET UP (LH) WITH HANDLE JSYS 200 ;GET JSYS HRRZ 1,3 MOVEI 2,2 ;INDEX INTO ENTRY-VEC SFRKV ;START THAT FORK ;AC1 HAS INFERIOR-F HANDLE! WFORK ;CURRENT FORK WAITS UNTIL THE ; INFERIOR FORK TERMINATES. KFORK ;INF-FORK STILL EXISTS, SO! SWAPEX: MOVSI 17,ACSAV BLT 17,17 ;Restore accs PRET ; and return. FILSOS: ASCIZ /<SUBSYS>SOS.SAV/ SOSER1: OUTSTR FILSOS OUTSTR [ASCIZ / NOT FOUND /] SOSER2: OUTSTR [ASCIZ /COULDN'T SOSSWAP/] JRST SWAPEX > ;CLOSE OF IFN OPSYS. > ;******* Close of IFN SOSSW, from %SOSSWAP: **** %ACSAV: ACSAV: BLOCK 20 PAGE IFN JSYXEQ,< ;The rest of this page is under this switch COMMENT The JSYS function executes a JSYS and returns the result. It is called as JSYS(jsysno,arg1,arg2,arg3,retreg) where jsysno is the number of the JSYS, retreg is the number of the register in which the executed JSYS will return its value and argN is loaded into register N as argument to the JSYS. The value of the global variable JSYSAR4 is taken as arg4 (initial value is 0). If argN is a number then that number is converted to machine- representation and loaded into reg N. If argN is not the list (BUF) then it must be a string or an id. This string or id is written in a buffer as a ASCIZ string and a pointer to that string is loaded into reg N. If argN is (BUF) then a pointer to a stringbuffer is loaded into reg N. Only one of the argN may be (BUF). If there is a (BUF) this indicates that the JSYS will write a string into the string buffer, using retreg as updated string- pointer and return as value the string converted into a LISP string. If there is no (BUF) among the arguments, then the content of the retreg register is converted into a LISP number and returned as value of JSYS. %JSYS: PSAVE B ; A1 arg. PSAVE C ; A2 arg. PSAVE AR4 ; A3 arg. FOO PSAVE VJSYSAR4 ; A4 arg. CAIG A,INUM0+777 ; JSYS number CAIGE A,INUM0+1 ERRE2 ^D39,[SIXBIT /NOT A JSYS!/] SUBI A,INUM0 HRRM A,JSY ; Set which JSYS. MOVE A,AR5 CAIG A,INUM0+4 CAIGE A,INUM0+1 ERRE2 ^D40,[SIXBIT /NOT A RETURN REGISTER!/] SUBI A,INUM0 HRRM A,RETREG ; Set which register contains the value MOVEI AR5,1 HRRM AR5,RBUFAR ; No string returned. MOVEM SP,STRST# ;Start of string buffer. Special stack is used HRREI B,-3 JSARLP: HRRM B,NJSAR NJSAR: MOVE A,X(P) ; Get arg. JSP D,ATMTYP ; What type is it? CAIE TT,FIXNU ; If not a fixnum JUMPN TT,JSASTB ; or an Inum must be string or buffer PCALL NUMVAL ; A number. Convert to machine format MOVEM A,@NJSAR ; and set arg. JRST JSARLE JSASTB: CAIE TT,ID ; An id CAIN TT,STRNG ; or a string ? JRST JSASTR ; Yes! FOO CAIE TT,BUF ; Return string buffer? ERRE2 ^D41,[SIXBIT /ILLEGAL JSYS ARG!/] ; No! Error. HRRM B,RBUFAR ; Arg no for return string pointer. JRST JSARLE JSASTR: MOVE C,STRST ; String buffer position. MOVEI B,1(C) HRROM B,@NJSAR ; Set arg to string pointer. PCALL PNAMUD ; Unpack into buffer PUSH C,[0] ; Deposit zero at end of string. MOVEM C,STRST ; Update string buffer. JSARLE: HRRE B,NJSAR ; Next arg. AOJLE B,JSARLP HRRZ B,RBUFAR ; Return string? SOJE B,NORST ; No! MOVE B,STRST ; String buffer position. PUSH B,[0] ; Zero first word. RBUFAR: HRROM B,X(P) ; Set arg to string pointer for return string. NORST: HRRZM B,STRST ; 0 or address of output string. PREST 4 ; A4 arg. PREST 3 ; A3 arg. PREST 2 ; A2 arg. PREST 1 ; A1 arg. JSY: JSYS X ERJMP JSYERR ERJMP JSYERR RETREG: MOVE A,X ; Load return value into register 1. SKIPE B,STRST ; Return string? JRST MKSTR ; Yes! Convert to Lisp string. JRST FIX1A ;No! Convert to LISP number and return ;JSYS error return JSYERR: PCALL ERRSTR ERRE2 ^D42,[SIXBIT /JSYS ERROR!/] ; ERRSTR returns the last system error message as a Lisp string; ERRSTR: HRROI A,1(SP) ; Pointer to buffer for string. HRLOI B,400000 ; .FHSLF SETZ 3, ERSTR ERJMP EER ERJMP EER MKSTR1: MOVEI B,1(SP) MKSTR: SKIPG C,A ; Convert from ASCII string to LISP string. JRST FALSE ; Return NIL if no string. LDB AR4,A ; Last character. JUMPN AR4,NOBCKP ; O.k. if not null. CAIN B,(A) ; Only one word? JRST NOBCKP ; Yes! Never step back pointer. HLRZ AR4,A CAIN AR4,350700 ; Null in beginning of word? MOVEI C,-1(A) ; Yes! Step back pointer. NOBCKP: HRL A,B ; Start of string. SUBI B,1(SP) ; - expected start of string. JUMPE B,LMKSTR ; Don't need to move string if start is o.k.. HRRI A,1(SP) ; Expected start of string. SUBI C,(B) ; Updated end of string. BLT A,(C) ; Move string. JRST LMKSTR ; Make into LISP string. EER: FOO MOVEI A,QST ;Couldn't get error string return ? PRET GETAB$: PCALL NUMVAL HRRM A,GETALO HLLZ B,A MOVE C,SP GETALO: MOVEI A,X HRL A,B GETAB JRST GERR PUSH C,A AOBJN B,GETALO GERR: MOVSI A,700 HRR A,3 JRST MKSTR1 ; !%XEQ generates inferior forks %XEQ: MOVEM A,FORKH# ; FILENAME OR PREVIOUS FORK HANDLE #. MOVEM B,STAD# ; T=START, NIL=RESUME, 0-N = EVEC POS. MOVEM C,KILL# ; T=KFORK, NIL=KEEP FOR A RESUME-FORK. MOVEM AR4,ACSADR# ; NIL=NONE, N=ADDR OF ACCBLK MOVEM AR5,ARGSTR# ; NIL=NONE, RSCAN . TTYINP Tops20, TTYINP Tenex IFL OPSYS,< ;RSCAN not defined in TENEX JUMPE AR5,NORTYI CARA A,(AR5) JUMPE A,NRSCN ; NO RSCAN PCALL PNAMUK PUSH C,[0] ; Must end with 0 HRROI A,1(SP) RSCAN JRST FAIL6 NRSCN: MOVE A,FORKH > ;END OF IFL OPSYS NORTYI: PCALL NUMBERP ; IF NUMBERP FILE/FORKH JUMPN A,OLDFORK ; THEN GOTO OLDFORK; MOVE A,FORKH PCALL PNAMUK PUSH C,[0] ; Must end with 0 MOVSI A,100001 ; OLD FILES ONLY. HRROI B,1(SP) GTJFN ; GTJFN OF STRING ON SP STACK. JRST FAIL1 MOVEM A,SAVJFN# MOVSI A,200000 ; 1B1 SETZ B, ; SETUP ACS BELOW, IF ANY. CFORK JRST FAIL2 MOVEM A,FORKH HRRZ A,SAVJFN HRL A,FORKH JSYS 200 ; GET OF FORK,,JFN. SKIPN A,STAD FOO MOVEI A,TRUTH ; START, NOT RESUME. MOVEM A,STAD JRST TRYIT OLDFORK:MOVE A,FORKH PCALL NUMVAL CAIL A,400001 CAIL A,400035 ERRE2 ^D43,[SIXBIT /NOT A FORK HANDLE!/] MOVEM A,FORKH RFSTS TLNN A,777777 ERRL2 ^D168,[SIXBIT /DEAD FORK IN XEQ!/] MOVEM B,FORKPC# TRYIT: MOVEI A,100 ;PRIMARY INPUT CFIBF ;Flush buffer to be safe RFMOD MOVEM B,OTTMOD# SKIPN A,ACSADR JRST NOACS PCALL NUMVAL MOVE B,A MOVE A,FORKH SFACS NOACS: MOVE A,FORKH SKIPN C,STAD JRST DOSFORK ; IF NULL STAD THEN START FORK FOO CAIN C,TRUTH TDZA C,C ; IF STAD=T THEN START AT EVEC+0 SUBI C,INUM0 ; UNBOX NUMBER GEVEC ADD B,C MOVEM B,FORKPC HLRZ AR4,B ; CHECK LH LENGTH VERSUS STAD CAIE AR4,(JRST) JRST ITENEX CAIL C,2 JRST FAIL5 ; 10/50 CAN ONLY ST/REE 0/1. JRST DOSFORK ITENEX: CAIL C,(AR4) JRST FAIL5 DOSFORK:HRRZ B,FORKPC SFORK ; SFORK AT PC, RATHER THAN RFORK IFG OPSYS,<SKIPN A,ARGSTR JRST NTAR> IFL OPSYS,<SKIPN C,ARGSTR JRST DOWFORK CDRA A,(C) JUMPE A,NTAR> PCALL PNAMUK HRRZ C,SP HRLI C,700 MOVEI A,100 ;Primary output designator; XL1: MOVEI AR4,127 XL2: ILDB B,C JUMPE B,NTAR STI SOJG AR4,XL2 DIBE JRST XL1 NTAR: MOVE A,FORKH DOWFORK:WFORK MOVEI A,100 MOVE B,OTTMOD SFMOD MOVE A,FORKH SKIPN B,KILL JRST FIX1A ; RETURN FORKH# FOR FUTURE RESUME. KFORK ; KFORK IF NON-NIL FLAG. JRST FALSE FAIL1: PSAVE FORKH PCALL ERRSTR PCALL NCONS PRET B PCALL XCONS MOVE B,A MOVEI A,INUM0 JRST .ERROR FAIL6: CARA A,ARGSTR PSAVE A JRST FAIL1+1 FAIL2: MOVE A,SAVJFN RLJFN JFCL PCALL ERRSTR ERRE2 ^D44,[SIXBIT /ERROR IN XEQ!/] FAIL5: MOVE A,STAD ERRE2 ^D45,[SIXBIT /BAD ENTRY VECTOR IN XEQ!/] > ;End of IFN JSYXEQ SUBTTL BPS SWAPPING ROUTINES --- PAGE 24 IFN RWB,< ;to end of page INTERNAL RBLK, WBLK RBLK: PCALL FILEPX ; (RBLK <FILE>) no 2nd arg anymore. JUMPE A,RBLK0 ; Not found. INPUT [IOWD 1,LST 0] JRST SYSINQ RBLK0: RELEASE 0, JRST AIN.7 WBLK: INIT 17 ; (WBLK <file> <start-addr> <end-addr>) SIXBIT /DSK/ 0 JRST AOUT.4+1 HRLZM A,DEV MOVE A,B ;IN CASE ADDRESSES OVER 64K. PCALL NUMVAL EXCH A,C PCALL NUMVAL SUBI C,1 SUBM C,A ;A_ -(A-(C-1)) == ARG1:ARG2 INCLUSIVE HRL C,A MOVEM C,LST MOVEI T,DEV PCALL IOSUB MOVEM A,ENTR SETZM ENTR+2 ;CREATION DATE ENTER ENTR JRST OUTERR+1 OUTPUT [IOWD 1,LST 0] OUTPUT LST CLOSE STATZ 740000 JRST TYO2X+2 ;"OUTPUT ERROR". PRET > ;end of IFN RWB SUBTTL CORE EXPANDING ROUTINES --- PAGE 25 INTERNAL TCORE TCORE: SUBI A,INUM0 ;== ^C, CORE N, START EXCEPT FOR N =<0 JUMPL A,TCORE0 ;JUST RETURN CURRENT LISP-ALLOC SIZE JUMPE A,TCORE0+1 ;JUST RETURN CURRENT CORE SIZE CAILE A,MAXCORE ;LIMIT .LT. 124K OR SO, ALLOWING FOR I/O BUFFS JRST TCORE3 LSH A,^D10 SUBI A,1 CAMGE A,JRELO JRST TCORE1 ;Smaller than current Lisp area alloc. CAML A,.JBREL JRST TCORE2 ;LARGER THAN CURRENT CORE, SO EXPAND. IFE HCBPS,< SKIPN VXCORE JRST TCORE4 STRTIP [SIXBIT /_*** CAN'T EXCISE_!/] JRST TCORE0+1 > TCORE4: CAMG A,JRELO PCALL TCORE5 TCORE2: CALLI A,CORE JRST TCORE3 JRST LISPGO ;GO ALLOCATE CORE TCORE1: STRTIP [SIXBIT /_*** CAN'T CUT CORE INTO ALLOCATED SPACE_!/] TCORE0: SKIPA A,JRELO ;-1 GIVES CURRENT LISP-ALLOC AREA HRRZ A,.JBREL ; 0 GIVES CURRENT TOTAL CORE ASSIGNED ADDI A,1777 LSH A,-^D10 JRST FIXI TCORE5: MOVE B,JRELO CAME B,CORUSE FOO SKIPN %MSG PRET ; OUTSTR [ASCIZ / ;*** EXCISED ;/] PRET PAGE ; EXCORE( n ) permits arbitrary expansion of BPS above Lisp spaces, ; by: 1) flagging STRT allocator not to alloc extra core, ; 2) creating or extending a high BPS area of nK, ; 3) setting BPORG and BPEND up there appropriately, ; 4) doing an I/O reset, to get the buffers above BPS, ; permitting future LOADs, EDs, etc. ; EXCORE( 0 ) forces the BPORG and BPEND pntrs down to their last ; positions in low BPS, but doesn't clear the high...which ; is retained indefinitely or until an EXCISE. ; EXCORE(NIL) permits ALLOC() or ST to allocate extra core as usual. ; Has also the effect of EXCORE(0). IFN SZBPS,< ;Only defined when not maximal BPS. EXCORE: IFE HCBPS,< ;Only when BPS in low core MOVEM A,VXCORE# ;If NIL, flag for STRT allocation, JUMPE A,CHKVBP HRREI C,-INUM0(A) ;else JUMPL C,EXCORT LSH C,^D10 ; Convert nK to n*1024 words. JUMPE C,CHKVBP ; If arg=0, put BP pntrs back to low BPS. FOO MOVE A,VBPEND PCALL NUMVAL CAML A,FSO ;Are the pntrs in low BPS still? JRST EXCOR2 ; No, extend from this BPEND. MOVEM A,OBPEND# ; Yes, save positions for a later CHKVBP. FOO MOVE A,VBPORG PCALL NUMVAL MOVEM A,OBPORG# SKIPA A,JRELO ;Start BPS. [Could use CORUSE instead] EXCOR2: SETZ B, ;If 0, pntrs were already in high BPS. ADD A,C ;Extend by amt of arg. IORI A,777 ; End of page. CAIGE A,MAXCORE*^D1024 ;More than 124K requested, CALLI A,CORE ; or can't get it? JRST TCORE3 ; Say so. JUMPE B,EXCOR3 ;Got it -- set pntrs to it. MOVE A,JRELO ;[or CORUSE] ADDI A,1 PCALL FIX1A FOO MOVEM A,VBPORG EXCOR3: MOVE A,.JBREL PCALL FIX1A FOO MOVEM A,VBPEND JSR IOBRST ;Set JOBSA and clear I/O pntrs. CALLI RESET ;Set JOBFF. JSR APRSET PCALL TTYRET EXCORT: MOVE A,VXCORE PRET PAGE CHKVBP: FOO MOVE A,VBPEND ;Ensure BP pntrs to low BPS. PCALL NUMVAL CAMGE A,FSO JRST EXCORT ;Already low, no change needed. MOVE A,OBPEND PCALL FIX1A FOO MOVEM A,VBPEND MOVE A,OBPORG PCALL FIX1A FOO MOVEM A,VBPORG JRST EXCORT > IFN HCBPS,< JUMPE A,CPOPJ ;Do nothing if argument NIL. PCALL NUMVAL JUMPLE A,CPOPJ LSH A,^D10 MOVE AR5,A FOO MOVE A,VBPEND PCALL NUMVAL ADD AR5,A IORI AR5,777 HRLZ A,AR5 TLNN AR5,-1 CALLI A,CORE JRST TCORE3 MOVE A,AR5 PCALL FIX1A FOO MOVEM A,VBPEND PRET > > ;End of IFN SZBPS PAGE FREEZE: SKIPE A ;If going to toplevel, then PCALL TUNBIND ; unbind to toplevel MOVEM 17,ACSAV+17 ;This routine halts Lisp in a manner MOVEI 17,ACSAV ; that can be later re-started. BLT 17,ACSAV+16 IFL OPSYS,< MOVE 1,VBPORG PCALL NUMVAL MOVEM 1,.JBHRL > IFN OPSYS,< MOVEI 1,400000 MOVE 2,[2,,ENTFRZ] SEVEC > ;Tell it where to start or continue. MOVEI 1,NEWST ;Unfortunately, need to do this MOVEI 2,NEWREE ; in order to thwart PA1050, HRRM 1,.JBSA ; if ST or REE w/o clearing it. HRRM 2,.JBREN IFN OPSYS,< HALTF > IFE OPSYS,<EXIT 1,> NEWST: TDZA NIL,NIL NEWREE: SETO NIL, IFN OPSYS,< MOVEI 1,400000 ;Tell it the normal Lisp entries. MOVE 2,[2,,ENTVEC] SEVEC > IFL OPSYS,< MOVE 1,.JBREL HRLI 1,676777 CALLI 1,CORE JRST .+1 > MOVEI 1,LISPGO MOVEI 2,DEBUGO HRRM 1,.JBSA HRRM 2,.JBREN JSR IOBRST ;Clear I/O bufs. JUMPN NIL,[MOVE NIL,ACSAV SETZM RETFLG JRST START ] ;REE to get past INITFN. CALLI RESET JSR APRSET ;Reset 10/50 or Tenex interrupts. MOVSI 17,ACSAV BLT 17,17 PCALL TTYRET SKIPN A,ACSAV+1 ;Test arg of FREEZE... PRET ; NIL -- Return, no files open. MOVE A,.JBREL ; Non-NIL -- GOTO top-level INITFN. CAMN A,JRELO JRST LSPRET ;Unexpanded core. G.c. not necessary. JRST LISPGO IFN OPSYS,< ENTVEC: JRST LISPGO JRST DEBUGO ENTFRZ: JRST NEWST JRST NEWREE > SUBTTL AUXILIARY ROUTINES --- PAGE 26 IFN OPSYS,< LSSAVE: MOVEM 17,ACSAV+17 ;This routine SSAVEs Lisp in a manner MOVEI 17,ACSAV ; that can be later run, no files open. BLT 17,ACSAV+16 MOVE 17,ACSAV+17 ;Restore it. MOVEI 1,400000 MOVE 2,[2,,ENTFRZ] SEVEC MOVSI 1,(1B0+1B17) HRROI 2,LSSFIL GTJFN JRST LSSER1 HRLI 1,400000 MOVEI 2,LSSTBL SETZ 3, SSAVE HRRZS 1 RLJFN JRST LSSER1 MOVEI 1,400000 MOVE 2,[2,,ENTVEC] SEVEC JRST TRUE ;Distinguish from a NEWST's NIL! LSSER1: MOVEI 1,400000 MOVE 2,[2,,ENTVEC] SEVEC ERRL2 ^D166,[SIXBIT /COULDN'T SSAVE/] LSSFIL: IFL OPSYS,ASCIZ /LSSAVE.EXE/ IFG OPSYS,ASCIZ /LSSAVE.SAV/ LSSTBL: -700,,520B26+0 ;Pages 0-677 below PA1050. 0 > PAGE IFN SYDEV,< SETSYS: IFG OPSYS,<SUBI A,INUM0 ;CHANGE SYS: <DIR> NUMBER. CAIGE A,0 ; Permit 0 ... user's dir. SKIPA A,SYSNUM# MOVEM A,SYSNUM JRST FIXI> IFLE OPSYS,<MOVE T,A PCALL ATOM JUMPE A,GVDV MOVE A,T PCALL SIXMAK TRC A,":"-40 TRNE A,77 JRST GVDV HLLZM A,SYSNUM# MOVE A,T PRET GVDV: SETZB A,B SKIPA AR4,[POINT 6,SYSNUM] ADDI A,40(B) LSH A,7 ILDB B,AR4 JUMPN B,.-3 ADDI A,":" LSH A,1 SKIPA AR4,[1] LSH A,7 TLNN A,774000 JRST .-2 MOVEM A,1(SP) MOVEI C,1(SP) JRST MSTR1 > > SUBTTL REALLOC CODE --- PAGE 27 STRT: MOVE P,C2 SKIPE SP,SPSAV PCALL TUNBIND MOVE A,.JBREL ;New top of core -- becomes JRELO below. HRLM A,.JBSA SUB A,JRELO# ;length of extra core JUMPE A,RREL4 ;no expansion SKIPG A HALT ;smaller core -- bitch. IFN AED,<MOVEI B,EDP2 HRRM B,ED> IFE HCBPS,<SKIPE VXCORE ;If XCORE(Nil), go ahead and allocate, JRST RREL4 > ; else retain as is...usually expanded BPS. MOVE A,.JBREL TRO A,1777 CALLI A,CORE SKIPA A,.JBREL MOVE A,.JBREL HRLM A,.JBSA SUB A,JRELO PCALL TCORE5 IFN ALOD,SETZM LDFLG ;initial loader symbol table flag MOVE F,EFWSO# SUB F,FWSO# ;old length of fws HRRZS B,A ACHLOC: ASH A,-2+X ;1/4 of new core to fws * User-patchable * ADD A,F ;new length of fws MOVE C,B STKLOC: ASH C,-6 ;1/64 of new core to each pdl MOVE AR4,C HRL AR4,C HLRZ AR5,SC2 ;-old length of spec pdl ADD AR5,.JBREL ;new bottom of spec pdl HLL AR5,SC2 ;old length of spec pdl SUB AR5,AR4 ;new pointer for spec pdl MOVEM AR5,SC2 IFN EPDL,< HLRZ EP,EC2 ;-old length of exp pdl ADD AR5,EP ;new bottom of exp pdl HLL AR5,EC2 ;old length of exp pdl SUB AR5,AR4 ;new pointer for exp pdl MOVEM AR5,EC2 > MOVNS C2 ;old reg pdl pointer HLRZ AR4,C2 ;old length of reg pdl ADD C,AR4 ;new length of reg pdl HRRZ B,AR5 ;new bottom of reg pdl SUB B,FSO# MOVEI T,44 ;1/36 space for fws bit tables IDIVM A,T ;new length of fws bit tables AOS T SUB B,T ;B:=SPL-FSO-(FWS/36+1)-FWS-PL, then SUB B,A ;B:=B-(B/33+1)+FSO SUB B,C MOVEI TT,41 ;1/33 space for fs bit table IDIVM B,TT ;new length of fs bit table SUBI B,1(TT) ;new length of fs ADD B,FSO ;new bottom of fs HRRM B,GCP1 MOVN SP,B ;- new bottom of fws HRRM SP,GCMFWS HRLZM A,C1GCS MOVNS C1GCS ;- new length of fws HRRM B,C1GCS ADDI B,-1(A) ;new top of fws AOS B MOVE SP,FSO LSH SP,-5 SUBM B,SP HRRM SP,GCBTP2 ;magic number for bit table references HRRM SP,GCBTP1 HRLM B,C3GC ;bottom of bit tables --- for bit table zeroing HRRM B,GCP2 HRRM B,GCP MOVNI SP,-1(TT) HRLM SP,C3GCS HRRM B,C3GCS ;iowd for FS bit table sweep AOS B MOVE SP,FSO ANDI SP,37 HRRM SP,GCBTL2 ;magic number to position bit table word SUBI SP,^D32 HRRM SP,GCBTL1 HRRM B,C3GC ;bottom of bit table ADDI B,-1(TT) HRRM B,C2GCS ;bottom of fws bit table AOS B HRRM B,C2GC ADDI B,-1(T) HRRM B,GCP5 ;top of bit tables AOS B ;bottom of reg pdl HRRZ A,RHX2 ;oblist pointer MOVEM A,(B) HRRM B,GCP3 ;room for acs AOS B HRRM B,C2 ;reg pdl bottom MOVNI A,-10(C) HRLM A,C2 ;reg pdl size HRRZ A,.JBREL HRRZM A,JRELO ;new top of core MOVE A,GCP1 HRRM A,.+4 ;To... MOVE A,FWSO HRRM A,.+1 ;From... MOVE A,.(F) ;old bottom of fws * MOVEM A,.(F) ;new bottom of fws * SOJGE F,.-2 ;f has length (old) of fws HRRZ AR4,GCP1 SUB AR4,FWSO ;displacement for fws MOVE AR5,FSO ;bottom of fs RREL1: CARA A,(AR5) ;Adjust pntrs in new FS to new FWS... CAMG A,EFWSO CAMGE A,FWSO JRST RREL2 ADD A,AR4 RPLCA A,(AR5) ;fix car pointer RREL2: CDRA A,(AR5) CAMG A,EFWSO CAMGE A,FWSO JRST RREL3 ADD A,AR4 RPLCD A,(AR5) ;fix cdr pointer RREL3: CAMGE AR5,FWSO AOJA AR5,RREL1 MOVE A,GCP1 ;bottom of fws HRRZM A,FWSO MOVE A,C3GC ;bottom of bit table + 1 HRRZM A,EFWSO RREL4: FOO SETZB FF,DDTIFG ;Flag for AGC. JSR IOBRST JRST START ;-------------------------------------------------------------------- RLOCA: MOVE B,AR4 ;= FS+BPS LENGTHS. HRLI AR4,BFWS HRRI AR4,FS(B) MOVEI AR5,EFWS-BFWS(AR4) BLT AR4,(AR5) MOVEI AR4,FS-BFWS(B) MOVEI AR5,BFWS-1 REL1: CARA A,(AR5) CAILE A,EFWS JRST REL2 CAIGE A,BFWS JSP R,REL4 ADD A,AR4 REL2: RPLCA A,(F) CDRA A,(AR5) CAILE A,EFWS JRST REL3 CAIGE A,BFWS JSP R,REL4 ADD A,AR4 REL3: RPLCD A,(F) SOS F CAILE AR5,FS SOJA AR5,REL1 JRST RREL4 ;Now do the IOBRST and START. REL4: CAIL A,FS ADD A,FF JRST 1(R) PAGE REHASH: ;ONCE ONLY, per HASHFG. FOO MOVEI A,BFWS PSAVE A HRRM A,RHX2 HRRM A,RHX5 RH4: MOVSI B,X ;* FOO MOVEI A,BFWS+1(B) FOO MOVEM A,BFWS(B) AOBJN B,.-2 FOO SETZM BFWS(B) MOVSI AR5,-BCKETS RH1: FOO HLRZ C,OBTBL(AR5) RH3: JUMPE C,RH2 CARA A,(C) PSAVE C PSAVE AR5 PCALL INTERN PREST AR5 PREST C CDRA C,(C) JRST RH3 RH2: AOBJN AR5,RH1 SETZM HASHFG PREST A HRRM A,@GCP3 FOO MOVEM A,OBLIST JRST START SUBTTL LISP ATOMS AND OBLIST --- PAGE 28 RVAL: 0 HVAL: 0 VAR LIT PAGE FS: DEFINE MAKBUC (A,%B) <DEFINE OBT'A <%B=.> IFN <BCKETS-1-A>,<XWD %B,.+1> IFE <BCKETS-1-A>,<XWD %B,NIL> IF1 <%B=0>> DEFINE ADDOB (A,C,%B) <OBT'A DEFINE OBT'A<%B=.> IF1 <%B=0> XWD C,%B> DEFINE PUTOB (A,B) <ZZ==<ASCII /A/>_<-1> ZZ==-ZZ/BCKETS*BCKETS+ZZ ADDOB \ZZ,B> DEFINE PSTRCT (A) <ZZ==[ASCII /A/] LENGTH ZY,A REPEAT <ZY-1>/5,<XWD ZZ,.+1 ZZ==ZZ+1> XWD ZZ,0> DEFINE MKAT (A,B,C,D) <XLIST IRP A< PUTOB A,.+1 D XWD ID,.+1 XX==<B-EXPR>*<B-FEXPR> IFN XX,<XWD .+1,.+2 XWD B,C'A> IFE XX,<XWD .+1,.+4 XWD FUNCELL,.+1 XWD B,.+1 XWD CODE,C'A> XWD .+1,NIL XWD PNAME,.+1 PSTRCT A> LIST> PAGE DEFINE MKAT1 (A,B,C,D) <XLIST IRP C <PUTOB C,.+1 XWD ID,.+1 XX==<B-EXPR>*<B-FEXPR> IFN XX,<XWD .+1,.+2 XWD B,D'A> IFE XX,<XWD .+1,.+4 XWD FUNCELL,.+1 XWD B,.+1 XWD CODE,D'A> XWD .+1,NIL XWD PNAME,.+1 PSTRCT C> LIST> DEFINE LENGTH (A,B) <A==0 IRPC B,<A==A+1>> DEFINE ML1 (A)<XLIST IRP A,<XLIST INTERNAL A V'A= INUM0+A MKAT A,SYM,V> LIST> ;These SYMs are for direct access from LAP code (e.g. LISP.TNX) DEFINE ML (A)< XLIST IRP A,<PUTOB A,.+1 A: XWD ID,.+1 XWD .+1,NIL XWD PNAME,.+1 PSTRCT A> LIST> OBTBL: OBLIST: ZZ==0 ;Base of array or linear-list of hash buckets. XLIST ;REPEAT BCKETS,<MAKBUC \ZZ REPEAT BCKETS,<MAKBUC \ZZ ZZ==ZZ+1> LIST ; ZZ==ZZ+1> PAGE ML <LAMBDA,EXPR,FEXPR,SYM,FUNCELL,VALUE,PNAME,TRACE> ML <LABEL,MACRO,INPUT,OUTPUT,INBIN,OUTBIN> ML <SUBR,FSUBR> MKAT <RPLACA,RPLACD,MINUS,TERPRI,READ,CAR,CDR,CAAR>,EXPR MKAT <CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,EXPR MKAT <CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,EXPR MKAT <CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,CONS>,EXPR MKAT <PROG2,ATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,ATSOC,PATOM>,EXPR MKAT <POSN,LINELENGTH,NUMBERP,EQUAL,SUBST,GET,INTERN,MEMBER>,EXPR MKAT <COMPRESS,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,EXPR IFN AED,<MKAT <ED,GRINDEF>,EXPR> MKAT <TIME,FIX,SET,LENGTH,ADD1,SUB1,LAST,WARNING>,EXPR MKAT <GCTIME,REVERSE,SPEAK,MAPLIST,MEMQ>,EXPR MKAT <PUT,PRIN2,ERR,MAPCAR,EXAMINE,DEPOSIT,LSH,MAPCAN,MAPCON>,EXPR MKAT <NCONS,XCONS,REMPROP,MINUSP,MAP,MAPC>,EXPR MKAT <WRS,RDS,OPEN,CLOSE,EXCISE,REMAINDER,ABS,BKTRA>,EXPR MKAT <PGLINE>,EXPR MKAT <%FSLID,%FPAGE,%NEXTTYI,SETPCHAR,DLVECT>,EXPR IFN SOSSW,MKAT %SOSSWAP,EXPR IFN RWB,<MKAT <RBLK,WBLK>,EXPR> MKAT <FILEP,FREEZE>,EXPR IFN SZBPS,MKAT <EXCORE>,EXPR MKAT <CORE>,EXPR,T MKAT <BINI,BINO,TYID,TYOD>,EXPR MKAT1 VINC,VALUE,INC* VINC:NIL MKAT1 VOUTC,VALUE,OUTC* VOUTC:NIL IFN OPSYS,MKAT LSSAVE,EXPR IFN JSYXEQ,<MKAT <%XEQ,GETAB$,ERRSTR>,EXPR MKAT1 VJSYSAR4,VALUE,JSYSAR4 VJSYSAR4: INUM0 ML BUF MKAT JSYS,EXPR,%> IFN SYDEV,<MKAT SETSYS,EXPR> MKAT EXPLODEC,EXPR,% MKAT TYO,EXPR,I MKAT TYI,EXPR,I MKAT EVAL,EXPR,,CEVAL: MKAT <LIST,COND,PROG,SETQ>,FEXPR MKAT1 LIST,EXPR,EVLIS MKAT <OR,AND,GO,PROGN>,FEXPR IFN ASARY,<MKAT <ARRAY,STORE>,FEXPR ML1 NSTR IFN ALOD,<MKAT EXARRAY,FEXPR> > MKAT1 QUOTE,FEXPR,FUNCTION IFN FNRG,< ML FUNARG MKAT1 FUNCT,FEXPR,*FUNCTION MKAT <%EVAL,%APPLY>,EXPR > MKAT <APPEND,NCONC,APPLY,REMOB,ERRORSET,FIXP,FLOATP,INUMP,BIGP>,EXPR MKAT <PUTD,GETD,REMD,PRINC,FLAG,FLAGP,REMFLAG,MKCODE,FLOAT,DIGIT>,EXPR MKAT <BOOLE,LITER,IDP,PAIRP,CONSTANTP,STRINGP,VECTORP,CODEP>,EXPR MKAT <MKVECT,UPBV,GETV,PUTV>,EXPR MKAT INTERNP,EXPR,. MKAT ASCII,EXPR,A MKAT QUOTE,FEXPR,,CQUOTE: MKAT1 FIX1A,EXPR,*BOX ML1 <EXARG,ATMTYP,NATMTYP,INTER0,FWCONS,ACHLOC,CHRTAB> MKAT INUM0,SYM,S INTERN INUM0 SINUM0: XWD FIXNU,VINUM0 IFN OPSYS,ML1 <READP1,PNAMUK,%ACSAV,LMKSTR> IFN OPSYS*SOSSW,ML1 %SWAP PUTOB T,.+1 TRUTH: XWD ID,.+1 XWD .+1,.+2 XWD VALUE,VTRUTH XWD .+1,NIL XWD PNAME,.+1 PSTRCT T VTRUTH: TRUTH PUTOB NIL,0 CNIL2: XWD .+1,.+2 XWD VALUE,VNIL XWD .+1,NIL XWD PNAME,.+1 PSTRCT NIL VNIL: NIL IFE STL,< MKAT <SASSOC,SETARG,GETL,ARG,READLIST,FLATSIZE>,EXPR MKAT <CSYM,DEFPROP>,FEXPR MKAT1 EXPN1,EXPR,*EXPAND1 MKAT1 EXPAND,EXPR,*EXPAND MKAT1 LCALL,SYM,*LCALL,INUM0+% MKAT1 UDT,SYM,*UDT,INUM0+% > MKAT1 AMAKE,SYM,*AMAKE,INUM0+% MKAT1 %NOPOINT,VALUE,*NOPOINT %NOPOINT: NIL MKAT1 BACTRF,VALUE,*BAKGAG BACTRF:NIL MKAT1 ERRSW,VALUE,*ERRMSG ERRSW:TRUTH MKAT1 V$EOF$,VALUE,$EOF$ V$EOF$: $EOF$ $EOF$: XWD ID,.+1 XWD .+1,NIL XWD PNAME,.+1 PSTRCT $EOF$ MKAT1 GCGAGV,VALUE,*GCGAG GCGAGV:NIL MKAT1 VFECHO,VALUE,*ECHO VFECHO:NIL MKAT1 VRAISE,VALUE,*RAISE VRAISE:NIL MKAT1 DDTIFG,VALUE,*DDTIN DDTIFG:TRUTH MKAT1 NOUUOF,VALUE,*NOUUO NOUUOF:NIL MKAT1 %MSG,VALUE,*MSG %MSG: TRUTH MKAT1 GC,EXPR,RECLAIM MKAT1 INITF,VALUE,INITFN* INITF:NIL MKAT1 %SYSTM,VALUE,SYSTEM* %SYSTM: OPSYS+INUM0 MKAT <SCANINIT,SCANSET,SCAN,UNREADCH>,EXPR MKAT <LETTER,DELIMITER,IGNORE,RDSLSH>,EXPR MKAT1 SCNV,VALUE,SCNVAL SCNV: NIL MKAT SKIPTO,EXPR MKAT <LPOSN,PAGELENGTH,EJECT,NUMVAL>,EXPR MKAT ERROR,EXPR,. MKAT1 VERMSG,VALUE,EMSG* VERMSG: NIL IFN OFLD!NFLD,< MKAT1 VPURIFY,VALUE,*PURIFY VPURIFY: NIL MKAT1 VPREDEF,VALUE,*PREDEF VPREDEF: NIL MKAT1 VF.LIST,VALUE,F.LIST VF.LIST: NIL MKAT1 VP.URCLOBRL,VALUE,P.URCLOBRL VP.URCLOBRL: NIL > IFN OFLD,< MKAT <FASLOD,LDFERR>,EXPR MKAT1 VFARRY,VALUE,FARRY VFARRY: NIL > IFN NFLD,MKAT FASLOAD,EXPR ;UNBOUND is a non-interned identifier UNBOUND:XWD ID,.+1 XWD .+1,NIL XWD PNAME,.+1 PSTRCT UNBOUND IFN MOD,< MKAT <SETMOD,CMOD,CPLUS,CDIF,CTIMES,CRECIP>,EXPR MKAT1 VBIGP,VALUE,MOD* VBIGP: NIL > MKAT1 LAMBIND,EXPR,*LAMBIND* MKAT1 PROGBIND,EXPR,*PROGBIND* MKAT1 SPECSTR,EXPR,*SPECRSTR* MKAT1 PLUS,EXPR,PLUS2,. MKAT1 DIF,EXPR,DIFFERENCE,. MKAT1 QUO,EXPR,QUOTIENT,. MKAT1 TIMES,EXPR,TIMES2,. MKAT1 RSTSW,VALUE,*RSET RSTSW:NIL MKAT1 GREAT,EXPR,GREATERP,. MKAT1 LESS,EXPR,LESSP,. IFN ALOD,<MKAT LOAD,EXPR MKAT1 PUTSYM,EXPR,*PUTSYM MKAT1 GETSYM,EXPR,*GETSYM> MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V VOBLIST: OBLIST VBASE: 8+INUM0 VIBASE: 8+INUM0 VBPORG: XWD 0,.+1 XWD FIXNU,VBPORX VBPEND: XWD 0,.+1 XWD FIXNU,VBPENX PUTOB ?,.+1 QST: XWD ID,.+1 XWD .+1,NIL XWD PNAME,.+1 PSTRCT ? BFWS: ;All the FWS LITerals from above atoms, etc. XLIST ; includes VBPORX,VBPENX datums. LIT VINUM0: INUM0 VBPORX: 400000 VBPENX: 700000-1000-2 ;676776 --> 1 for SYSINP and 1000 for slop. LIST EFWS: 0 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY) --- PAGE 29 ALLOC:! CALLI RESET ;Later IOBRST & another RESET. MOVEI P,ALLPDL-1 IFN OPSYS, < ;LISP.EXE SIZE LT DESIRED STARTING SIZE. MOVEI A,INITCORE PCALL ALCORH > IFL OPSYS,<GETPPN A, HLRM A,SYSNU> IFN SYDEV, < IFG OPSYS, < MOVEI 1,1 ;MATCH EXACTLY HRROI 2,[ASCIZ /REDUCE/] STDIR JFCL GJINF ;IN DESPERATION, USE HIS LOGIN DIR #. HRRZM 1,SYSNUM > IFLE OPSYS,< MOVEI A,(SIXBIT /SYS/) HRLZM A,SYSNUM > > ;End of IFN SYDEV OUTSTR [ASCIZ / Allocate? /] INCHRW C CAIE C,"n" CAIGE C,"O" JRST ALLC00 IFN OPSYS,< OUTSTR [ASCIZ / Core (K): /] PCALL ALLNUM JUMPLE A,ALLTNX CAIG A,MAXCORE ;Asking for too much core ? JRST .+3 ;No OUTSTR [ASCIZ / Will give you maximum allowed/] MOVEI A,MAXCORE LSH A,^D10 SUBI A,1 PCALL ALCORE ALLTNX:! MOVEI A,^D8 HRRM A,ALLRDX ;Remaining inputs are octal. > IFN SYDEV, < IFG OPSYS, < OUTSTR [ASCIZ / SYS: dir# /] PCALL ALLNUM SKIPN A GJINF ;If user said "0", use his dir. SKIPL A HRRM A,SYSNUM > IFLE OPSYS,< OUTSTR [ASCIZ / SYS: /] SETZ A, SYLO:! INCHRW C CAILE C,"z" JRST SYLE CAIL C,"a" TRZ C,40 ;Convert lower case to upper CAIL C,"A" CAILE C,"Z" JRST SYLE LSH A,6 ADDI A,-40(C) JRST SYLO INCHRW C SYLE:! CAIN C,RUBOUT JRST [OUTSTR [ASCIZ /XXX /] JRST SYLO-1] CAILE C," " JRST SYLE-1 CAIN C,15 INCHRW C ;<lf> assumed. JUMPE A,.+2 HRLZM A,SYSNUM > > ;End of IFN SYDEV OUTSTR [ASCIZ / FWDS= /] PCALL ALLNUM JUMPL A,.+2 HRRM A,ALLC02 IFN SZBPS,< OUTSTR [ASCIZ / BPS.= /] PCALL ALLNUM JUMPL A,.+5 ;USE DEFAULT ? CAIGE A,MINFBPS MOVEI A,MINFBPS ADDI A,BOTBPS HRRZM A,SBPS > OUTSTR [ASCIZ / SPDL= /] PCALL ALLNUM JUMPL A,.+4 HRRM A,ALLC20 MOVNS A HRRM A,ALLC21 IFN EPDL,< OUTSTR [ASCIZ / EPDL= /] PCALL ALLNUM JUMPL A,.+4 HRRM A,ALLC40 MOVNS A HRRM A,ALLC41 > OUTSTR [ASCIZ / RPDL= /] PCALL ALLNUM JUMPL A,.+2 HRRM A,ALLC30 OUTSTR [ASCIZ / HASH= /] PCALL ALLNUM CAIG A,BCKETS JRST ALLC00 HRRM A,INT1 MOVNS A HRRM A,RH4 SETOM HASHFG ;ONCE ONLY. ALLC00:! MOVE A,.JBREL HRRZM A,JRELO HRLM A,.JBSA MOVEI A,DEBUGO HRRM A,.JBREN MOVEI A,LISPGO HRRM A,.JBSA IFN OPSYS,< MOVEI 1,400000 MOVE 2,[2,,ENTVEC] SEVEC > OUTSTR [ASCIZ / /] IFE HCBPS,< MOVEI A,FS PCALL FIX1A MOVEM A,VBPORG MOVEI A,FS ADD A,SBPS HRRZM A,FSO ;SET ONCE AND FOR EVER!!! SOS A PCALL FIX1A MOVEM A,VBPEND > IFN HCBPS,< MOVEI A,FS MOVEM A,FSO IFN OPSYS,MOVEI A,400000 ;First loc of high-segment. IFE OPSYS,< HRRZ B,.JBREL ;highest address in low core TRNN B,400000 ;is low core higher than 128k MOVEI B,377777 ;no, assume high core start at 400000 MOVE A,[XWD -2,.GTUPM] ;get high core orig. from monitor GETTAB A, ;.GTUPM indexed by current high core number HRLI A,1(B) ;table or call not present, use assumed value LSH A,-^D18 ;convert to address of high segment ANDI A,777000 ;clear any low bits ADDI A,.JBHDA> ;Add space for vestigial job data area MOVEM A,VBPORX IFE SZBPS,MOVEI A,700000-1000-2 ;PA1050 - 1 page. IFN SZBPS,ADD A,SBPS MOVEM A,VBPENX MOVSS A PCALL ALCORH SETZ A, CALLI A,SETUWP HALT > MOVE A,JRELO ALLC20:! SUBI A,1000+X ALLC21:! HRLI A,-1000+X MOVEM A,SC2 IFN EPDL,< ALLC40:! SUBI A,100+X ALLC41:! HRLI A,-100+X MOVEM A,EC2 > SUB A,FSO HRRZS B,A ASH A,-4 ALLC02:! ADDI A,400+X MOVE C,B ASH C,-6 ALLC30:! ADDI C,1000+X ;Stg order= prgm bps fs fws bt btf pdl epdl sp MOVEI T,44 IDIVM A,T AOS T ;size of btf SUB B,T SUB B,A SUB B,C ;remaining storage MOVEI TT,^D32+1 IDIVM B,TT ;bt size -1 SUBI B,1(TT) ;free storage size IFE HCBPS,<ADD B,SBPS> HRRZ AR4,B ADDI B,FS HRRZM B,FWSO HRRM B,GCP1 ;b hac top of fs MOVN SP,B HRRM SP,GCMFWS HRLZM A,C1GCS ;length of fws MOVNS C1GCS HRRM B,C1GCS ADDI B,-1(A) ;bottom of bt-1 AOS B MOVE SP,FSO LSH SP,-5 SUBM B,SP HRRM SP,GCBTP2 HRRM SP,GCBTP1 HRLM B,C3GC HRRM B,GCP2 HRRM B,GCP HRRZM B,EFWSO MOVNI SP,-1(TT) HRLM SP,C3GCS HRRM B,C3GCS AOS B MOVE SP,FSO ANDI SP,37 HRRM SP,GCBTL2 SUBI SP,^D32 HRRM SP,GCBTL1 HRRM B,C3GC ADDI B,-1(TT) HRRM B,C2GCS AOS B HRRM B,C2GC ADDI B,-1(T) HRRM B,GCP5 AOS B MOVEI A,OBTBL IFE HCBPS,<ADD A,SBPS> MOVEM A,(B) HRRM B,GCP3 AOS B HRRM B,C2 MOVNI A,-10(C) HRLM A,C2 IFE HCBPS,<MOVE FF,SBPS> IFN HCBPS,<SETZ FF, > MOVEI F,BFWS-1(FF) JUMPE FF,RLOCA MOVEI C,FOOLST REL5:! MOVE B,(C) ;Relocate all FS refs w/i system code, CDRA A,(B) ; by length of alloc'd BPS, iff HCBPS=0. ADD A,FF RPLCD A,(B) HLR B,B CDRA A,(B) ADD A,FF RPLCD A,(B) CAIGE C,EFOLST-1 AOJA C,REL5 MOVEI A,TRUTH ADD A,FF HRLM A,IDCHTAB+"T"-100 JRST RLOCA ;Uses values in AR4,F,FF. PAGE ALLNUM:! MOVSI A,400000 ;high bit on for no-digits-seen. INCHRW C CAIN C,15 INCHRW C ;<lf> assumed. CAIN C,RUBOUT JRST [OUTSTR [ASCIZ /XXX /] JRST ALLNUM] CAIL C,"0" CAILE C,"9" PRET TLZ A,400000 ;turn off hi bit on digit ALLRDX:! IFN OPSYS,IMULI A,^D10+X ;first a decimal number IFE OPSYS,IMULI A,^D8 ;only octal ADDI A,-"0"(C) JRST ALLNUM+1 ALCORE:! CAMG A,.JBREL PRET ;Already bigger. ALCORH:! CALLI A,CORE HALT PRET ALLPDL:! BLOCK 10 IFN SZBPS,<SBPS:! INITBPS+BOTBPS> PAGE I=0 DEFINE GARP (A,B) <XWD FOO'A,FOO'B> FOO 0 FOOLST:! XLIST REPEAT <FOOCNT/2>,< GARP (\I,\<I+1>) I=I+2> LIST EFOLST:! DEFINE MKENT (A)< INTERNAL A> ;These are for BIGNUMs (in ARITH)... MKENT <NUMV2,FLOOV,FS> MKENT <LAST,FIX1A,NUMVAL,REVERSE,LENGTH,XCONS,CONS,CTY,MINUSP> MKENT <NUM1,NUM3,FWCONS,FALSE,TRUE,NCONS,IDCONS> ;These are for GFPAK MKENT <.PLUS,REMAINDER,.COPY,.Q1,MAKBIG,POPAJ> ;These are for SCAN... MKENT <CHRTAB,RATOM,OLDCH,NOINFG,TYI> ;Most of the rest are for ALVINE... MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,EQUAL,SUBST> MKENT <LNCT,PAGL,CHCT,LINL,POSN,TYOD,TYID> MKENT <GET,INTERN,REMOB,COMPRESS,GENSYM,FIX,LENGTH,PATOM> MKENT <MAPLIST,GC,PUT,FIXP,FLOATP,ATMTYP,NATMTYP,IPUTD,IMKCODE> MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRORSET,%APPLY> MKENT <SPECSTR,LAMBIND,PROGBIND,INTER0,ATOM,READCH,SET,PRIN2> MKENT <FP7A1,TERPRI,LSPRET,BKTRC> MKENT <TYO,ITYO,EVAL,APPLY,%EVAL,INPUT,OUTPUT> IFE STL,MKENT <READLIST,GETL,SASSOC,SAS1,FLATSIZE> IFN AED,MKENT PSAV1 ;SOME MORE FOR FRICK'S "SHEEP" SYSTEM... IFN ASARY,MKENT <ARRAY,ARRAYS,ARREND> MKENT <GCMKL,PRINT1,EJECT,OPEN,RDS,WRS,CLOSE,PRINC,GETD,PUTD,DCONSA> MKENT <PCHAR,FIXOV,ZERODIV,ILLNUM,STKLOC,ATSOC,EXARG,MKVECT> SUPPRESS FOOCNT,I END ALLOC |
Added r30/lisp.sl version [1fd36c4432].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | This file is loaded automatically by Lisp, just after its initial allocation of storage spaces, and supplies system extensions. (SETQ IBASE (SETQ BASE 8.))) (SETQ !$EOL!$ (INTERN (ASCII 37))) (COND ((NOT (GETD 'EXCORE)) (PROG (X) (PUTD '!%TSTFISL 'EXPR '(LAMBDA NIL NIL)) (PUTD '!%ENDFISL 'EXPR '(LAMBDA NIL NIL)) (COND ((GREATERP (SETQ X BPORG) 673000) (ERROR 0 "NO FISLTABLE ROOM"))) (SETQ BPORG 673000) (SETQ FISLSIZE (DIFFERENCE (DIFFERENCE BPEND BPORG) 2)) (SETQ FISLTABLE (MKVECT(DIFFERENCE (TIMES2 2 FISLSIZE) 1))) (SETQ BPORG X))) (T (SETQ FISLSIZE 1000) (PUTD '!%TSTFISL 'EXPR '(LAMBDA NIL (PROG (X) (COND ((GREATERP (SETQ X BPORG) (DIFFERENCE BPEND FISLSIZE)) (ERROR 0 "NO FISLTABLE ROOM"))) (SETQ BPORG (DIFFERENCE (DIFFERENCE BPEND FISLSIZE) 1)) (SETQ FISLTABLE (MKVECT (DIFFERENCE (TIMES2 2 FISLSIZE) 5))) (SETQ BPORG X)))) (PUTD '!%ENDFISL 'EXPR '(LAMBDA NIL (PROGN (DLVECT FISLTABLE) (SETQ FISLTABLE NIL)))))) (PUTD '!%DEVP 'EXPR '(LAMBDA (X) (OR (EQ (CAR (REVERSE (EXPLODE X))) (QUOTE !:)) (AND (NOT (ATOM X)) (NOT (ATOM (CDR X))))))) (PUTD 'FISLF 'EXPR '(LAMBDA(FILES !*PREDEF !*PURIFY) (PROG (X) (COND ((AND (NULL (FILEP FILES)) (NULL (!%DEVP (CAR FILES)))) (SETQ FILES (CONS (QUOTE SYS:) FILES)))) (SETQ X (RDS (OPEN FILES 'INBIN))) (!%TSTFISL) (ERRORSET '(FASLOD FISLTABLE !*PREDEF !*PURIFY) T !*BAKGAG) (CLOSE (RDS X)) (!%ENDFISL) (LDFERR)))) (MAPC '(!%TSTFISL !%ENDFISL) (FUNCTION REMOB)) (PUTD 'DCONSA 'EXPR (MKCODE (PLUS2 (!*BOX (CDDR (GETD 'XCONS))) 1) 1)) Do various setups, then ERR() back to main EVAL loop. (FISLF '((FEND . FAP)) NIL T) (FISLF '((FISL . FAP)) NIL T))) %(RDS (OPEN '(DSK!: (FEND . SL)) 'INPUT)) %(RDS (OPEN '(DSK!: (FISL . SL)) 'INPUT)) (SETQ BASE (SETQ IBASE (PLUS2 7 3))) (LINELENGTH 69) (DM COMPILE (X) (PROGN (LOAD COMPLR CMACRO LAP) X)) (DE COMPD (X Y Z) (PROGN (COMPILE) (COMPD X Y Z))) (DM TR (X) (PROGN (LOAD DEBUG) X)) (DM TRST (X) (PROGN (LOAD DEBUG) X)) (MAPC '(SUBRLOC SYMLOC !%FLIST !%FNAM !*AMAKE !%TALK !%SWAP) (FUNCTION REMOB)) (REMOB (QUOTE LAST)) (PUTD '!%SCAN 'EXPR (CDR (GETD 'SCAN 'EXPR))) (REMOB 'SCAN) (PROG NIL (CLOSE (RDS NIL)) (CLOSE (WRS NIL)) (PRIN2 " Standard Lisp (April 1983)") (EXCISE) (SETQ !*BAKGAG T) (SETQ !*DDTIN NIL) (SETQ !*NOPOINT T) (SETQ !*NOUUO T) (SETQ !*RAISE T) (SETQ DFPRINT!* NIL) (ERR)) |
Added r30/matr.fap version [9f94df42d8].
cannot compute difference between binary files
Added r30/matr.red version [3a4079024a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %********************************************************************* %********************************************************************* % MATRIX PACKAGE %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; %********************************************************************* % REQUIRES SIMPLIFICATION FUNCTIONS FOR NON-SCALAR QUANTITIES %********************************************************************; FLUID '(!*EXP !*S!*); %Used in this module; GLOBAL '(SUBFG!* !*SUB2 !*NAT); SYMBOLIC PROCEDURE MATSM!* U; %matrix expression simplification function; BEGIN U := MATSM U; U := IF NULL CDR U AND NULL CDAR U THEN MK!*SQ2 CAAR U ELSE 'MAT . MAPC2(U,FUNCTION MK!*SQ2); !*SUB2 := NIL; %since all substitutions done; RETURN U END; SYMBOLIC PROCEDURE MAPC2(U,V); %this very conservative definition is to allow for systems with %poor handling of functional arguments, and because of bootstrap- %ping difficulties, which are no longer really relevant; BEGIN SCALAR X,Y,Z; A: IF NULL U THEN RETURN REVERSIP Z; X := CAR U; Y := NIL; B: IF NULL X THEN GO TO C; Y := APPLY(V,LIST CAR X) . Y; X := CDR X; GO TO B; C: U := CDR U; Z := REVERSIP Y . Z: GO TO A END; SYMBOLIC PROCEDURE MK!*SQ2 U; BEGIN SCALAR X; X := !*SUB2; %since we need value for each element; U := SUBS2 U; !*SUB2 := X; RETURN MK!*SQ U END; SYMBOLIC PROCEDURE MATSM U; BEGIN SCALAR X,Y; U := NSSIMP(U,'MATP); A: IF NULL U THEN RETURN X; Y := MULTSM(CAAR U,MATRIXTIMES CDAR U); X := IF NULL X THEN Y ELSE ADDM(X,Y); U := CDR U; GO TO A END; SYMBOLIC PROCEDURE MATRIXTIMES U; %returns matrix canonical form for matrix symbol product U; BEGIN SCALAR X,Y,Z; INTEGER N; A: IF NULL U THEN RETURN Z ELSE IF EQCAR(CAR U,'!*DIV) THEN GO TO D ELSE IF ATOM CAR U THEN GO TO ER ELSE IF CAAR U EQ 'MAT THEN GO TO C1 ELSE IF (X := GET(CAAR U,'MSIMPFN)) THEN X := APPLY(X,CDAR U) ELSE GO TO ER; B: Z := IF NULL Z THEN X ELSE IF NULL CDR Z AND NULL CDAR Z THEN MULTSM(CAAR Z,X) ELSE MULTM(X,Z); C: U := CDR U; GO TO A; C1: IF NOT LCHK CDAR U THEN REDERR "MATRIX MISMATCH"; X := MAPC2(CDAR U,FUNCTION XSIMP); GO TO B; D: Y := MATSM CADAR U; IF (N := LENGTH CAR Y) NEQ LENGTH Y THEN REDERR "NON SQUARE MATRIX" ELSE IF (Z AND N NEQ LENGTH Z) THEN REDERR "MATRIX MISMATCH" ELSE IF CDDAR U THEN GO TO H ELSE IF NULL CDR Y AND NULL CDAR Y THEN GO TO E; X := SUBFG!*; SUBFG!* := NIL; IF NULL Z THEN Z:= GENERATEIDENT N; Z := LNRSOLVE(Y,Z); SUBFG!* := X; GO TO C; E: IF NULL CAAAR Y THEN REDERR "ZERO DENOMINATOR"; Y := REVPR CAAR Y; Z := IF NULL Z THEN LIST LIST Y ELSE MULTSM(Y,Z); GO TO C; H: IF NULL Z THEN Z := GENERATEIDENT N; GO TO C; ER: REDERR LIST('MATRIX,CAR U,"NOT SET") END; SYMBOLIC PROCEDURE LCHK U; BEGIN INTEGER N; IF NULL U OR ATOM CAR U THEN RETURN NIL; N := LENGTH CAR U; REPEAT U := CDR U UNTIL NULL U OR ATOM CAR U OR LENGTH CAR U NEQ N; RETURN NULL U END; SYMBOLIC PROCEDURE ADDM(U,V); %returns sum of two matrix canonical forms U and V; FOR EACH J IN ADDM1(U,V,FUNCTION CONS) COLLECT ADDM1(CAR J,CDR J,FUNCTION ADDSQ); SYMBOLIC PROCEDURE ADDM1(U,V,W); IF NULL U AND NULL V THEN NIL ELSE IF NULL U OR NULL V THEN REDERR "MATRIX MISMATCH" ELSE APPLY(W,LIST(CAR U,CAR V)) . ADDM1(CDR U,CDR V,W); SYMBOLIC PROCEDURE TP U; TP1 MATSM U; SYMBOLIC PROCEDURE TP1 U; %returns transpose of the matrix canonical form U; %U is destroyed in the process; BEGIN SCALAR V,W,X,Y,Z; V := W := LIST NIL; WHILE CAR U DO <<X := U; Y := Z := LIST NIL; WHILE X DO <<Z := CDR RPLACD(Z,LIST CAAR X); X := CDR RPLACA(X,CDAR X)>>; W := CDR RPLACD(W,LIST CDR Y)>>; RETURN CDR V END; SYMBOLIC PROCEDURE SCALPROD(U,V); %returns scalar product of two lists (vectors) U and V; IF NULL U AND NULL V THEN NIL ./ 1 ELSE IF NULL U OR NULL V THEN REDERR "MATRIX MISMATCH" ELSE ADDSQ(MULTSQ(CAR U,CAR V),SCALPROD(CDR U,CDR V)); SYMBOLIC PROCEDURE MULTM(U,V); %returns matrix product of two matrix canonical forms U and V; (LAMBDA X; FOR EACH Y IN U COLLECT FOR EACH K IN X COLLECT SCALPROD(Y,K)) TP1 V; SYMBOLIC PROCEDURE MULTSM(!*S!*,U); %returns product of standard quotient !*S!* and matrix standard %form U; IF !*S!* = (1 ./ 1) THEN U ELSE MAPC2(U,FUNCTION (LAMBDA J; MULTSQ(!*S!*,J))); SYMBOLIC PROCEDURE LETMTR(U,V,Y); %substitution for matrix elements; BEGIN SCALAR Z; IF NOT EQCAR(Y,'MAT) THEN REDERR LIST('MATRIX,CAR U,"NOT SET") ELSE IF NOT NUMLIS (Z := REVLIS CDR U) OR LENGTH Z NEQ 2 THEN RETURN ERRPRI2(U,'HOLD); RPLACA(PNTH(NTH(CDR Y,CAR Z),CADR Z),V); END; SYMBOLIC PROCEDURE MATPRI!*(U,V,W); %symbolic interface to VARPRI; MATPRI(CDR U,IF V THEN EVAL CAR V ELSE NIL); SYMBOLIC PROCEDURE MATPRI(U,X); %prints a matrix canonical form U with name X; BEGIN SCALAR M,N; M := 1; IF NULL X THEN X := 'MAT; FOR EACH Y IN U DO <<N := 1; FOR EACH Z IN Y DO <<VARPRI(Z,LIST MKQUOTE LIST(X,M,N),T); IF !*NAT THEN TERPRI!* T; N := N+1>>; M := M+1>> END; %********************************************************************* % MATRIX INVERSION ROUTINES %********************************************************************; SYMBOLIC PROCEDURE LNRSOLVE(U,V); %U is a matrix standard form, V a compatible matrix form; %Value is U**(-1)*V; BEGIN INTEGER N; SCALAR X,!*S!*; X := !*EXP; !*EXP := T; N := LENGTH U; !*S!* := BACKSUB(BAREISS CAR NORMMAT AUGMENT(U,V),N); U := MAPC2(RHSIDE(CAR !*S!*,N), FUNCTION (LAMBDA J; CANCEL(J . CDR !*S!*))); !*EXP := X; RETURN U END; SYMBOLIC PROCEDURE AUGMENT(U,V); IF NULL U THEN NIL ELSE APPEND(CAR U,CAR V) . AUGMENT(CDR U,CDR V); SYMBOLIC PROCEDURE GENERATEIDENT N; %returns matrix canonical form of identity matrix of order N; BEGIN SCALAR U,V; FOR I := 1:N DO <<U := NIL; FOR J := 1:N DO U := ((IF I=J THEN 1 ELSE NIL) . 1) . U; V := U . V>>; RETURN V END; SYMBOLIC PROCEDURE RHSIDE(U,M); IF NULL U THEN NIL ELSE PNTH(CAR U,M+1) . RHSIDE(CDR U,M); SYMBOLIC PROCEDURE BAREISS U; %The 2-step integer preserving elimination method of Bareiss %based on the implementation of Lipson; %If the value of procedure is NIL then U is singular, otherwise the %value is the triangularized form of U (in matrix polynomial form); BEGIN SCALAR AA,C0,CI1,CI2,IK1,IJ,KK1,KJ,K1J,K1K1,UI,U1,X; INTEGER K,K1; %U1 points to K-1th row of U %UI points to Ith row of U %IJ points to U(I,J) %K1J points to U(K-1,J) %KJ points to U(K,J) %IK1 points to U(I,K-1) %KK1 points to U(K,K-1) %K1K1 points to U(K-1,K-1) %M in comments is number of rows in U %N in comments is number of columns in U; AA:= 1; K:= 2; K1:=1; U1:=U; GO TO PIVOT; AGN: U1 := CDR U1; IF NULL CDR U1 OR NULL CDDR U1 THEN RETURN U; AA:=NTH(CAR U1,K); %AA := U(K,K); K:=K+2; K1:=K-1; U1:=CDR U1; PIVOT: %pivot algorithm; K1J:= K1K1 := PNTH(CAR U1,K1); IF CAR K1K1 THEN GO TO L2; UI:= CDR U1; %I := K; L: IF NULL UI THEN RETURN NIL ELSE IF NULL CAR(IJ := PNTH(CAR UI,K1)) THEN GO TO L1; L0: IF NULL IJ THEN GO TO L2; X:= CAR IJ; RPLACA(IJ,NEGF CAR K1J); RPLACA(K1J,X); IJ:= CDR IJ; K1J:= CDR K1J; GO TO L0; L1: UI:= CDR UI; GO TO L; L2: UI:= CDR U1; %I:= K; L21: IF NULL UI THEN RETURN; %IF I>M THEN RETURN; IJ:= PNTH(CAR UI,K1); C0:= ADDF(MULTF(CAR K1K1,CADR IJ), MULTF(CADR K1K1,NEGF CAR IJ)); IF C0 THEN GO TO L3; UI:= CDR UI; %I:= I+1; GO TO L21; L3: C0:= QUOTF!*(C0,AA); KK1 := KJ := PNTH(CADR U1,K1); %KK1 := U(K,K-1); IF CDR U1 AND NULL CDDR U1 THEN GO TO EV0 ELSE IF UI EQ CDR U1 THEN GO TO COMP; L31: IF NULL IJ THEN GO TO COMP; %IF I>N THEN GO TO COMP; X:= CAR IJ; RPLACA(IJ,NEGF CAR KJ); RPLACA(KJ,X); IJ:= CDR IJ; KJ:= CDR KJ; GO TO L31; %pivoting complete; COMP: IF NULL CDR U1 THEN GO TO EV; UI:= CDDR U1; %I:= K+1; COMP1: IF NULL UI THEN GO TO EV; %IF I>M THEN GO TO EV; IK1:= PNTH(CAR UI,K1); CI1:= QUOTF!*(ADDF(MULTF(CADR K1K1,CAR IK1), MULTF(CAR K1K1,NEGF CADR IK1)), AA); CI2:= QUOTF!*(ADDF(MULTF(CAR KK1,CADR IK1), MULTF(CADR KK1,NEGF CAR IK1)), AA); IF NULL CDDR K1K1 THEN GO TO COMP3;%IF J>N THEN GO TO COMP3; IJ:= CDDR IK1; %J:= K+1; KJ:= CDDR KK1; K1J:= CDDR K1K1; COMP2: IF NULL IJ THEN GO TO COMP3; RPLACA(IJ,QUOTF!*(ADDF(MULTF(CAR IJ,C0), ADDF(MULTF(CAR KJ,CI1), MULTF(CAR K1J,CI2))), AA)); IJ:= CDR IJ; KJ:= CDR KJ; K1J:= CDR K1J; GO TO COMP2; COMP3: UI:= CDR UI; GO TO COMP1; EV0:IF NULL C0 THEN RETURN; EV: KJ := CDR KK1; X := CDDR K1K1; %X := U(K-1,K+1); RPLACA(KJ,C0); EV1:KJ:= CDR KJ; IF NULL KJ THEN GO TO AGN; RPLACA(KJ,QUOTF!*(ADDF(MULTF(CAR K1K1,CAR KJ), MULTF(CAR KK1,NEGF CAR X)), AA)); X := CDR X; GO TO EV1 END; SYMBOLIC PROCEDURE BACKSUB(U,M); BEGIN SCALAR DETM,DET1,IJ,IJJ,RI,SUMM,UJ,UR; INTEGER I,JJ; %N in comments is number of columns in U; IF NULL U THEN REDERR "SINGULAR MATRIX"; UR := REVERSE U; DETM := CAR PNTH(CAR UR,M); %DETM := U(I,J); IF NULL DETM THEN REDERR "SINGULAR MATRIX"; I := M; ROWS: I := I-1; UR := CDR UR; IF NULL UR THEN RETURN U . DETM; %IF I=0 THEN RETURN U . DETM; RI := CAR UR; JJ := M+1; IJJ:=PNTH(RI,JJ); R2: IF NULL IJJ THEN GO TO ROWS; %IF JJ>N THEN GO TO ROWS; IJ := PNTH(RI,I); %J := I; DET1 := CAR IJ; %DET1 := U(I,I); UJ := PNTH(U,I); SUMM := NIL; %SUMM := 0; R3: UJ := CDR UJ; %J := J+1; IF NULL UJ THEN GO TO R4; %IF J>M THEN GO TO R4; IJ := CDR IJ; SUMM := ADDF(SUMM,MULTF(CAR IJ,NTH(CAR UJ,JJ))); %SUMM:=SUMM+U(I,J)*U(J,JJ); GO TO R3; R4: RPLACA(IJJ,QUOTF!*(ADDF(MULTF(DETM,CAR IJJ),NEGF SUMM),DET1)); %U(I,J):=(DETM*U(I,J)-SUMM)/DET1; JJ := JJ+1; IJJ := CDR IJJ; GO TO R2 END; SYMBOLIC PROCEDURE NORMMAT U; %U is a matrix standard form. %Value is dotted pair of matrix polynomial form and factor; BEGIN SCALAR X,Y,Z; X := 1; FOR EACH V IN U DO <<Y := 1; FOR EACH W IN V DO Y := LCM(Y,DENR W); Z := (FOR EACH W IN V COLLECT MULTF(NUMR W,QUOTF(Y,DENR W))) . Z; X := MULTF(Y,X)>>; RETURN REVERSE Z . X END; %********************************************************************* % DETERMINANT AND TRACE ROUTINES %********************************************************************; SYMBOLIC PROCEDURE SIMPDET U; DETQ MATSM CARX(U,'DET); COMMENT The hashing and determinant routines below are due to M. L. Griss; COMMENT Some general purpose hashing functions; FLAG('(ARRAY),'EVAL); %declared again for bootstrapping purposes; ARRAY !$HASH 64; %general array for hashing; SYMBOLIC PROCEDURE GETHASH KEY; %access previously saved element; ASSOC(KEY,!$HASH(REMAINDER(KEY,64))); SYMBOLIC PROCEDURE PUTHASH(KEY,VALU); BEGIN INTEGER K; SCALAR BUK; K := REMAINDER(KEY,64); BUK := (KEY . VALU) . !$HASH K; !$HASH K := BUK; RETURN CAR BUK END; SYMBOLIC PROCEDURE CLRHASH; FOR I := 0:64 DO !$HASH I := NIL; COMMENT Determinant Routines; SYMBOLIC PROCEDURE DETQ U; %top level determinant function; BEGIN INTEGER LEN; LEN := LENGTH U; %number of rows; FOR EACH X IN U DO IF LENGTH X NEQ LEN THEN REDERR "NON SQUARE MATRIX"; IF LEN=1 THEN RETURN CAAR U; CLRHASH(); U := DETQ1(U,LEN,0); CLRHASH(); RETURN U END; SYMBOLIC PROCEDURE DETQ1(U,LEN,IGNNUM); %U is a square matrix of order LEN. Value is the determinant of U; %Algorithm is expansion by minors of first row; %IGNNUM is packed set of column indices to avoid; BEGIN INTEGER N2; SCALAR ROW,SIGN,Z; ROW := CAR U; %current row; N2 := 1; IF LEN=1 THEN RETURN <<WHILE TWOMEM(N2,IGNNUM) DO <<N2 := 2*N2; ROW := CDR ROW>>; CAR ROW>>; %last row, single element; IF Z := GETHASH IGNNUM THEN RETURN CDR Z; LEN := LEN-1; U := CDR U; Z := NIL ./ 1; FOR EACH X IN ROW DO <<IF NOT TWOMEM(N2,IGNNUM) THEN <<IF NUMR X THEN <<IF SIGN THEN X := NEGSQ X; Z:= ADDSQ(MULTSQ(X,DETQ1(U,LEN,N2+IGNNUM)), Z)>>; SIGN := NOT SIGN>>; N2 := 2*N2>>; PUTHASH(IGNNUM,Z); RETURN Z END; SYMBOLIC PROCEDURE TWOMEM(N1,N2); %for efficiency reasons, this procedure should be coded in assembly %language; REMAINDER(N2/N1,2)=1; PUT('DET,'SIMPFN,'SIMPDET); SYMBOLIC PROCEDURE SIMPTRACE U; BEGIN INTEGER N; SCALAR Z; U := MATSM CARX(U,'TRACE); IF LENGTH U NEQ LENGTH CAR U THEN REDERR "NON SQUARE MATRIX"; Z := NIL ./ 1; N := 1; A: IF NULL U THEN RETURN Z; Z := ADDSQ(NTH(CAR U,N),Z); U := CDR U; N := N+1; GO TO A END; PUT('TRACE,'SIMPFN,'SIMPTRACE); END; |
Added r30/mkfas1.mic version [54c205b3f7].
cannot compute difference between binary files
Added r30/mkfas2.mic version [385759cf17].
> > > > > > > > | 1 2 3 4 5 6 7 8 | @REDUCE *CORE 80; *SYMBOLIC; *OFF RAISE; *FASLOUT "'A"; *IN "'A.RED"$ *FASLEND; *BYE; |
Added r30/mkred1.mic version [e17b3830f5].
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | .AS DSK: SYS: .R LISP 70 *Y *7000 100000 600 600 475 *(SETQ FISLSIZE 1500) *(LOAD RLISP REND ALG1 ALG2 REND2 ENTRY) *(EXCISE) *(QUIT) .SA REDUCE .DEAS SYS: |
Added r30/mkred2.mic version [f730a7c3dc].
> > > > > > > | 1 2 3 4 5 6 7 | @RUN LISP *Y60 *12000 600 600 475 *(LOAD RLISP REND ALG1 ALG2 REND2 ENTRY) *(EXCISE) *(QUIT) @SAVE REDUCE |
Added r30/part.fap version [84282016d6].
cannot compute difference between binary files
Added r30/part.red version [f74680a47c].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SYMBOLIC PROCEDURE SIMPPART U; BEGIN SCALAR EXPN; EXPN := PREPSQ!* SIMP!* CAR U; U := CDR U; WHILE U DO BEGIN SCALAR X,Y; IF ATOM EXPN THEN MSGPRI("Expression",EXPN, "does not have part",CAR U,T) ELSE IF NOT NUMBERP(X := REVAL CAR U) THEN MSGPRI("Invalid argument",CAR U,"to part",NIL,T) ELSE IF X=0 THEN RETURN <<EXPN := CAR EXPN; U := NIL>> ELSE IF X<0 THEN <<X := -X; Y := REVERSE CDR EXPN>> ELSE Y := CDR EXPN; IF LENGTH Y<X THEN MSGPRI("Expression",EXPN, "does not have part",CAR U,T) ELSE EXPN := NTH(Y,X); U := CDR U END; RETURN SIMP EXPN END; PUT('PART,'SIMPFN,'SIMPPART); SYMBOLIC PROCEDURE SIMPSETPART U; %Simplifies a SETPART expression; (LAMBDA X; SIMP SIMPSETP1(PREPSQ!* SIMP!* CAR U,REVERSE CDR X,CAR X)) REVERSE CDR U; SYMBOLIC PROCEDURE SIMPSETP1(EXPN,PTLIST,REP); IF NULL PTLIST THEN REP ELSE IF ATOM EXPN THEN MSGPRI("Expression",EXPN, "does not have part",CAR PTLIST,T) ELSE BEGIN SCALAR X; IF NOT NUMBERP(X := REVAL CAR PTLIST) THEN MSGPRI("Invalid argument",CAR PTLIST,"to part",NIL,T) ELSE RETURN IF X=0 THEN REP . CDR EXPN ELSE IF X<0 THEN CAR EXPN . REVERSE SSL(REVERSE CDR EXPN, -X,CDR PTLIST,REP,EXPN . CAR PTLIST) ELSE CAR EXPN . SSL(CDR EXPN,X,CDR PTLIST, REP,EXPN . CAR PTLIST) END; SYMBOLIC PROCEDURE SSL(EXPN,INDX,PTLIST,REP,REST); IF NULL EXPN THEN MSGPRI("Expression",CAR REST,"does not have part",CDR REST) ELSE IF INDX=1 THEN SIMPSETP1(CAR EXPN,PTLIST,REP) . CDR EXPN ELSE CAR EXPN . SSL(CDR EXPN,INDX-1,PTLIST,REP,REST); PUT('PART,'SETQFN,'SETPART!*); PUT('SETPART!*,'SIMPFN,'SIMPSETPART); SYMBOLIC PROCEDURE ARGLENGTH U; BEGIN SCALAR X; X := PREPSQ!* SIMP!* U; RETURN IF ATOM X THEN -1 ELSE LENGTH CDR X END; FLAG('(ARGLENGTH),'OPFN); END; |
Added r30/pretty.fap version [476f2072b8].
cannot compute difference between binary files
Added r30/pretty.red version [4d5d9e2168].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | % This package prints list structures in an indented format that % is intended to make them legible. There are a number of special % cases recognized, but in general the intent of the algorithm % is that given a list (R1 R2 R3 ...), SUPERPRINT checks if % the list will fit directly on the current line and if so % prints it as: % (R1 R2 R3 ...) % if not it prints it as: % (R1 % R2 % R3 % ... ) % where each sublist is similarly treated. % % A. C. Norman. July 1978; % Functions: % SUPERPRINT(X) print expression X % SUPERPRINTM(X,M) print expression X with left margin M % PRETTYPRINT(X) = << SUPERPRINTM(X,POSN()), TERPRI() >> % % Flag: % !*SYMMETRIC If TRUE, print with escape characters, % otherwise do not (as PRIN1/PRIN2 % distinction). defaults to TRUE; % !*QUOTES If TRUE, (QUOTE x) gets displayed as 'x. % default is TRUE; % % Variable: % THIN!* if THIN!* expressions can be fitted onto % a single line they will be printed that way. % this is a parameter used to control the % formatting of long thin lists. default % value is 5; SYMBOLIC; GLOBAL '(!*SYMMETRIC !*QUOTES THIN!*); !*SYMMETRIC:=T; !*QUOTES:=T; THIN!*:=5; SYMBOLIC PROCEDURE SUPERPRINT X; << SUPERPRINM(X,0); TERPRI(); X>>; SYMBOLIC PROCEDURE PRETTYPRINT X; << SUPERPRINM(X,POSN()); %WHAT REDUCE DOES NOW; TERPRI(); TERPRI(); NIL>>; SYMBOLIC PROCEDURE SUPERPRINTM(X,LMAR); << SUPERPRINM(X,LMAR); TERPRI(); X >>; % FROM HERE DOWN THE FUNCTIONS ARE NOT INTENDED FOR DIRECT USE; % THE FOLLOWING FUNCTIONS ARE DEFINED HERE IN CASE THIS PACKAGE % IS CALLED FROM LISP RATHER THAN REDUCE; SYMBOLIC PROCEDURE EQCAR(A,B); PAIRP A AND CAR A EQ B; SYMBOLIC PROCEDURE SPACES N; FOR I=1:N DO PRIN2 '! ; % END OF COMPATIBILITY SECTION; FLUID '(STACK BUFFERI BUFFERO BN LMAR RMAR INITIALBLANKS PENDINGRPARS INDENTLEVEL INDBLANKS RPARCOUNT); SYMBOLIC PROCEDURE SUPERPRINM(X,LMAR); BEGIN SCALAR STACK,BUFFERI,BUFFERO,BN,INITIALBLANKS,RMAR, PENDINGRPARS,INDENTLEVEL,INDBLANKS,RPARCOUNT,W; BUFFERI:=BUFFERO:=LIST NIL; %FIFO BUFFER; INITIALBLANKS:=0; RPARCOUNT:=0; INDBLANKS:=0; RMAR:=LINELENGTH(NIL)-3; %RIGHT MARGIN; IF RMAR<25 THEN ERROR(0,LIST(RMAR+3, "LINELENGTH TOO SHORT FOR SUPERPRINTING")); BN:=0; %CHARACTERS IN BUFFER; INDENTLEVEL:=0; %NO INDENTATION NEEDED, YET; IF LMAR+20>=RMAR THEN LMAR:=RMAR-21; %NO ROOM FOR SPECIFIED MARGIN; W:=POSN(); IF W>LMAR THEN << TERPRI(); W:=0 >>; IF W<LMAR THEN INITIALBLANKS:=LMAR-W; PRINDENT(X,LMAR+3); %MAIN RECURSIVE PRINT ROUTINE; % TRAVERSE ROUTINE FINISHED - NOW TIDY UP BUFFERS; OVERFLOW 'NONE; %FLUSH OUT THE BUFFER; RETURN X END; % ACCESS FUNCTIONS FOR A STACK ENTRY; SMACRO PROCEDURE TOP; CAR STACK; SMACRO PROCEDURE DEPTH FRM; CAR FRM; SMACRO PROCEDURE INDENTING FRM; CADR FRM; SMACRO PROCEDURE BLANKCOUNT FRM; CADDR FRM; SMACRO PROCEDURE BLANKLIST FRM; CDDDR FRM; SMACRO PROCEDURE SETINDENTING(FRM,VAL); RPLACA(CDR FRM,VAL); SMACRO PROCEDURE SETBLANKCOUNT(FRM,VAL); RPLACA(CDDR FRM,VAL); SMACRO PROCEDURE SETBLANKLIST(FRM,VAL); RPLACD(CDDR FRM,VAL); SMACRO PROCEDURE NEWFRAME N; LIST(N,NIL,0); SMACRO PROCEDURE BLANKP CHAR; NUMBERP CAR CHAR; SYMBOLIC PROCEDURE PRINDENT(X,N); % PRINT LIST X WITH INDENTATION LEVEL N; IF ATOM X THEN IF VECTORP X THEN PRVECTOR(X,N) ELSE FOR EACH C IN (IF !*SYMMETRIC THEN IF STRINGP X THEN EXPLODES X ELSE EXPLODE X ELSE EXPLODEC X) DO PUTCH C ELSE IF QUOTEP X THEN << PUTCH '!'; PRINDENT(CADR X,N+1) >> ELSE BEGIN SCALAR CX; IF 4*N>3*RMAR THEN << %LIST IS TOO DEEP FOR SANITY; OVERFLOW 'ALL; N:=N/8; IF INITIALBLANKS>N THEN << LMAR:=LMAR-INITIALBLANKS+N; INITIALBLANKS:=N >> >>; STACK := (NEWFRAME N) . STACK; PUTCH ('LPAR . TOP()); CX:=CAR X; PRINDENT(CX,N+1); IF IDP CX AND NOT ATOM CDR X THEN CX:=GET(CX,'PPFORMAT) ELSE CX:=NIL; IF CX=2 AND ATOM CDDR X THEN CX:=NIL; IF CX='PROG THEN << PUTCH '! ; PRINDENT(CAR (X:=CDR X),N+3) >>; % CX NOW CONTROLS THE FORMATTING OF WHAT FOLLOWS: % NIL DEFAULT ACTION % <NUMBER> FIRST FEW BLANKS ARE NON-INDENTING % PROG DISPLAY ATOMS AS LABELS; X:=CDR X; SCAN: IF ATOM X THEN GO TO OUT; FINISHPENDING(); %ABOUT TO PRINT A BLANK; IF CX='PROG THEN << PUTBLANK(); OVERFLOW BUFFERI; %FORCE FORMAT FOR PROG; IF ATOM CAR X THEN << % A LABEL; LMAR:=INITIALBLANKS:=MAX(LMAR-6,0); PRINDENT(CAR X,N-3); % PRINT THE LABEL; X:=CDR X; IF NOT ATOM X AND ATOM CAR X THEN GO TO SCAN; IF LMAR+BN>N THEN PUTBLANK() ELSE FOR I=LMAR+BN:N-1 DO PUTCH '! ; IF ATOM X THEN GO TO OUT >> >> ELSE IF NUMBERP CX THEN << CX:=CX-1; IF CX=0 THEN CX:=NIL; PUTCH '! >> ELSE PUTBLANK(); PRINDENT(CAR X,N+3); X:=CDR X; GO TO SCAN; OUT: IF NOT NULL X THEN << FINISHPENDING(); PUTBLANK(); PUTCH '!.; PUTCH '! ; PRINDENT(X,N+5) >>; PUTCH ('RPAR . (N-3)); IF INDENTING TOP()='INDENT AND NOT NULL BLANKLIST TOP() THEN OVERFLOW CAR BLANKLIST TOP() ELSE ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE EXPLODES X; %dummy function just in case another format is needed; EXPLODE X; SYMBOLIC PROCEDURE PRVECTOR(X,N); BEGIN SCALAR BOUND; BOUND:=UPBV X; % LENGTH OF THE VECTOR; STACK:=(NEWFRAME N) . STACK; PUTCH ('LSQUARE . TOP()); PRINDENT(GETV(X,0),N+3); FOR I=1:BOUND DO << PUTCH '!,; PUTBLANK(); PRINDENT(GETV(X,I),N+3) >>; PUTCH('RSQUARE . (N-3)); ENDLIST TOP(); STACK:=CDR STACK END; SYMBOLIC PROCEDURE PUTBLANK(); BEGIN SCALAR B; PUTCH TOP(); %REPRESENTS A BLANK CHARACTER; SETBLANKCOUNT(TOP(),BLANKCOUNT TOP()+1); SETBLANKLIST(TOP(),BUFFERI . BLANKLIST TOP()); %REMEMBER WHERE I WAS; INDBLANKS:=INDBLANKS+1 END; SYMBOLIC PROCEDURE ENDLIST L; %FIX UP THE BLANKS IN A COMPLETE LIST SO THAT THEY %WILL NOT BE TURNED INTO INDENTATIONS; PENDINGRPARS:=L . PENDINGRPARS; % WHEN I HAVE PRINTED A ')' I WANT TO MARK ALL OF THE BLANKS % WITHIN THE PARENTHESES AS BEING UNINDENTED, ORDINARY BLANK % CHARACTERS. IT IS HOWEVER POSSIBLE THAT I MAY GET A BUFFER % OVERFLOW WHILE PRINTING A STRING OF )))))))))), AND SO THIS % MARKING SHOULD BE DELAYED UNTIL I GET ROUND TO PRINTING % A FURTHER BLANK (WHICH WILL BE A CANDIDATE FOR A PLACE TO % SPLIT LINES). THIS DELAY IS DEALT WITH BY THE LIST % PENDINGRPARS WHICH HOLDS A LIST OF LEVELS THAT, WHEN % CONVENIENT, CAN BE TIDIED UP AND CLOSED OUT; SYMBOLIC PROCEDURE FINISHPENDING(); << FOR EACH STACKFRAME IN PENDINGRPARS DO << IF INDENTING STACKFRAME NEQ 'INDENT THEN FOR EACH B IN BLANKLIST STACKFRAME DO << RPLACA(B,'! ); INDBLANKS:=INDBLANKS-1 >>; % BLANKLIST OF STACKFRAME MUST BE NON-NIL SO THAT OVERFLOW % WILL NOT TREAT THE '(' SPECIALLY; SETBLANKLIST(STACKFRAME,T) >>; PENDINGRPARS:=NIL >>; SYMBOLIC PROCEDURE QUOTEP X; !*QUOTES AND NOT ATOM X AND CAR X='QUOTE AND NOT ATOM CDR X AND NULL CDDR X; % PROPERTY PPFORMAT DRIVES THE PRETTYPRINTER - % PROG : SPECIAL FOR PROG ONLY % 1 : (FN A1 % A2 % ... ) % 2 : (FN A1 A2 % A3 % ... ) ; PUT('PROG,'PPFORMAT,'PROG); PUT('LAMBDA,'PPFORMAT,1); PUT('LAMBDAQ,'PPFORMAT,1); PUT('SETQ,'PPFORMAT,1); PUT('SET,'PPFORMAT,1); PUT('WHILE,'PPFORMAT,1); PUT('T,'PPFORMAT,1); PUT('DE,'PPFORMAT,2); PUT('DF,'PPFORMAT,2); PUT('DM,'PPFORMAT,2); PUT('FOREACH,'PPFORMAT,4); % (FOREACH X IN Y DO ...) ETC; % NOW FOR THE ROUTINES THAT BUFFER THINGS ON A CHARACTER BY CHARACTER % BASIS, AND DEAL WITH BUFFER OVERFLOW; SYMBOLIC PROCEDURE PUTCH C; BEGIN IF ATOM C THEN RPARCOUNT:=0 ELSE IF BLANKP C THEN << RPARCOUNT:=0; GO TO NOCHECK >> ELSE IF CAR C='RPAR THEN << RPARCOUNT:=RPARCOUNT+1; % FORMAT FOR A LONG STRING OF RPARS IS: % )))) ))) ))) ))) ))) ; IF RPARCOUNT>4 THEN << PUTCH '! ; RPARCOUNT:=2 >> >> ELSE RPARCOUNT:=0; WHILE LMAR+BN>=RMAR DO OVERFLOW 'MORE; NOCHECK: BUFFERI:=CDR RPLACD(BUFFERI,LIST C); BN:=BN+1 END; SYMBOLIC PROCEDURE OVERFLOW FLG; BEGIN SCALAR C,BLANKSTOSKIP; %THE CURRENT BUFFER HOLDS SO MUCH INFORMATION THAT IT WILL %NOT ALL FIT ON A LINE. TRY TO DO SOMETHING ABOUT IT; % FLG IS ONE OF: % 'NONE DO NOT FORCE MORE INDENTATION % 'MORE FORCE ONE LEVEL MORE INDENTATION % <A POINTER INTO THE BUFFER> % PRINTS UP TO AND INCLUDING THAT CHARACTER, WHICH % SHOULD BE A BLANK; IF INDBLANKS=0 AND INITIALBLANKS>3 AND FLG='MORE THEN << INITIALBLANKS:=INITIALBLANKS-3; LMAR:=LMAR-3; RETURN 'MOVED!-LEFT >>; FBLANK: IF BN=0 THEN << %NO BLANK FOUND - CAN DO NO MORE FOR NOW; % IF FLG='MORE I AM IN TROUBLE AND SO HAVE TO PRINT % A CONTINUATION MARK. IN THE OTHER CASES I CAN JUST EXIT; IF NOT(FLG = 'MORE) THEN RETURN 'EMPTY; IF ATOM CAR BUFFERO THEN % CONTINUATION MARK NOT NEEDED IF LAST CHAR PRINTED WAS % SPECIAL (E.G. LPAR OR RPAR); PRIN2 "%+"; %CONTINUATION MARKER; TERPRI(); LMAR:=0; RETURN 'CONTINUED >> ELSE << SPACES INITIALBLANKS; INITIALBLANKS:=0 >>; BUFFERO:=CDR BUFFERO; BN:=BN-1; LMAR:=LMAR+1; C:=CAR BUFFERO; IF ATOM C THEN << PRIN2 C; GO TO FBLANK >> ELSE IF BLANKP C THEN IF NOT ATOM BLANKSTOSKIP THEN << PRIN2 '! ; INDBLANKS:=INDBLANKS-1; % BLANKSTOSKIP = (STACK-FRAME . SKIP-COUNT); IF C EQ CAR BLANKSTOSKIP THEN << RPLACD(BLANKSTOSKIP,CDR BLANKSTOSKIP-1); IF CDR BLANKSTOSKIP=0 THEN BLANKSTOSKIP:=T >>; GO TO FBLANK >> ELSE GO TO BLANKFOUND ELSE IF CAR C='LPAR OR CAR C='LSQUARE THEN << PRIN2 GET(CAR C,'PPCHAR); IF FLG='NONE THEN GO TO FBLANK; % NOW I WANT TO FLAG THIS LEVEL FOR INDENTATION; C:=CDR C; %THE STACK FRAME; IF NOT NULL BLANKLIST C THEN GO TO FBLANK; IF DEPTH C>INDENTLEVEL THEN << %NEW INDENTATION; % THIS LEVEL HAS NOT EMITTED ANY BLANKS YET; INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >>; GO TO FBLANK >> ELSE IF CAR C='RPAR OR CAR C='RSQUARE THEN << IF CDR C<INDENTLEVEL THEN INDENTLEVEL:=CDR C; PRIN2 GET(CAR C,'PPCHAR); GO TO FBLANK >> ELSE ERROR(0,LIST(C,"UNKNOWN TAG IN OVERFLOW")); BLANKFOUND: IF EQCAR(BLANKLIST C,BUFFERO) THEN SETBLANKLIST(C,NIL); % AT LEAST ONE ENTRY ON BLANKLIST OUGHT TO BE VALID, SO IF I % PRINT THE LAST BLANK I MUST KILL BLANKLIST TOTALLY; INDBLANKS:=INDBLANKS-1; % CHECK IF NEXT LEVEL REPRESENTS NEW INDENTATION; IF DEPTH C>INDENTLEVEL THEN << IF FLG='NONE THEN << %JUST PRINT AN ORDINARY BLANK; PRIN2 '! ; GO TO FBLANK >>; % HERE I INCREASE THE INDENTATION LEVEL BY ONE; IF BLANKSTOSKIP THEN BLANKSTOSKIP:=NIL ELSE << INDENTLEVEL:=DEPTH C; SETINDENTING(C,'INDENT) >> >>; %OTHERWISE I WAS INDENTING AT THAT LEVEL ANYWAY; IF BLANKCOUNT C>(THIN!*-1) THEN << %LONG THIN LIST FIX-UP HERE; BLANKSTOSKIP:=C . ((BLANKCOUNT C) - 2); SETINDENTING(C,'THIN); SETBLANKCOUNT(C,1); INDENTLEVEL:=(DEPTH C)-1; PRIN2 '! ; GO TO FBLANK >>; SETBLANKCOUNT(C,(BLANKCOUNT C)-1); TERPRI(); LMAR:=INITIALBLANKS:=DEPTH C; IF BUFFERO EQ FLG THEN RETURN 'TO!-FLG; IF BLANKSTOSKIP OR NOT (FLG='MORE) THEN GO TO FBLANK; % KEEP GOING UNLESS CALL WAS OF TYPE 'MORE'; RETURN 'MORE; %TRY SOME MORE; END; PUT('LPAR,'PPCHAR,'!(); PUT('LSQUARE,'PPCHAR,'![); PUT('RPAR,'PPCHAR,'!)); PUT('RSQUARE,'PPCHAR,'!]); END; |
Added r30/rcref.fap version [4f334c1a69].
cannot compute difference between binary files
Added r30/rcref.red version [b6551d4110].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT Cross reference program module; COMMENT Requires REDIO.RED file to define I/O primitives and sorting functions; SYMBOLIC; DEFLIST('((ANLFN PROCSTAT) (CRFLAPO PROCSTAT)),'STAT); FLAG('(ANLFN CRFLAPO),'COMPILE); GLOBAL '(UNDEFG!* GSEEN!* BTIME!* EXPAND!* HAVEARGS!* NOTUSE!* NOLIST!* DCLGLB!* ENTPTS!* UNDEFNS!* SEEN!* TSEEN!* OP!*!* CLOC!* PFILES!* CURLIN!* PRETITL!* !*CREFTIME !*SAVEPROPS DFPRINT!* MAXARG!* !*CREFSUMMARY !*RLISP !*CREF !*DEFN !*MODE !*GLOBALS !*ALGEBRAICS ); FLUID '(GLOBS!* CALLS!* LOCLS!* TOPLV!* CURFUN!* ); !*ALGEBRAICS:='T; % Default is normal parse of algebraic; !*GLOBALS:='T; % Do analyze globals; !*RLISP:=NIL; % REDUCE as default; !*SAVEPROPS:=NIL; MAXARG!*:=15; % Maximum args in Standard Lisp; COMMENT EXPAND flag on these forces expansion of MACROS; EXPAND!*:='( ); SYMBOLIC PROCEDURE STANDARDFUNCTIONS L; NOLIST!* := NCONC(DEFLIST(L,'ARGCOUNT),NOLIST!*); STANDARDFUNCTIONS '( (LAMBDA 2) (ABS 1) (ADD1 1) (APPEND 2) (APPLY 2) (ASSOC 2) (ATOM 1) (CAR 1) (CDR 1) (CAAR 1) (CADR 1) (CDAR 1) (CDDR 1) (CAAAR 1) (CAADR 1) (CADAR 1) (CADDR 1) (CDAAR 1) (CDADR 1) (CDDAR 1) (CDDDR 1) (CAAAAR 1) (CAAADR 1) (CAADAR 1) (CAADDR 1) (CADAAR 1) (CADADR 1) (CADDAR 1) (CADDDR 1) (CDAAAR 1) (CDAADR 1) (CDADAR 1) (CDADDR 1) (CDDAAR 1) (CDDADR 1) (CDDDAR 1) (CDDDDR 1) (CLOSE 1) (CODEP 1) (COMPRESS 1) (CONS 2) (CONSTANTP 1) (DE 3) (DEFLIST 2) (DELETE 2) (DF 3) (DIFFERENCE 2) (DIGIT 1) (DIVIDE 2) (DM 3) (EJECT 0) (EQ 2) (EQN 2) (EQUAL 2) (ERROR 2) (ERRORSET 3) (EVAL 1) (EVLIS 1) (EXPAND 2) (EXPLODE 1) (EXPT 2) (FIX 1) (FIXP 1) (FLAG 2) (FLAGP 2) (FLOAT 1) (FLOATP 1) (FLUID 1) (FLUIDP 1) (FUNCTION 1) (GENSYM 0) (GET 2) (GETD 1) (GETV 2) (GLOBAL 1) (GLOBALP 1) (GO 1) (GREATERP 2) (IDP 1) (INTERN 1) (LENGTH 1) (LESSP 2) (LINELENGTH 1) (LITER 1) (LPOSN 0) (MAP 2) (MAPC 2) (MAPCAN 2) (MAPCAR 2) (MAPCON 2) (MAPLIST 2) (MAX2 2) (MEMBER 2) (MEMQ 2) (MINUS 1) (MINUSP 1) (MIN2 2) (MKVECT 1) (NCONC 2) (NOT 1) (NULL 1) (NUMBERP 1) (ONEP 1) (OPEN 2) (PAGELENGTH 1) (PAIR 2) (PAIRP 1) (PLUS2 2) (POSN 0) (PRIN2 1) (PRINT 1) (PRIN1 1) (PRIN2 1) (PROG2 2) (PUT 3) (PUTD 3) (PUTV 3) (QUOTE 1) (QUOTIENT 2) (RDS 1) (READ 0) (READCH 0) (REMAINDER 2) (REMD 1) (REMFLAG 2) (REMOB 1) (REMPROP 2) (RETURN 1) (REVERSE 1) (RPLACA 2) (RPLACD 2) (SASSOC 3) (SET 2) (SETQ 2) (STRINGP 1) (SUBLIS 2) (SUBST 3) (SUB1 1) (TERPRI 0) (TIMES2 2) (UNFLUID 1) (UPBV 1) (VECTORP 1) (WRS 1) (ZEROP 1) ); NOLIST!*:=APPEND('(AND COND LIST MAX MIN OR PLUS PROG PROG2 PROGN TIMES),NOLIST!*); FLAG ('(PLUS TIMES AND OR PROGN MAX MIN COND PROG CASE LIST), 'NARYARGS); DCLGLB!*:='(!*COMP EMSG!* !*RAISE); IF NOT GETD 'BEGIN THEN FLAG('(RDS DEFLIST FLAG FLUID GLOBAL REMPROP REMFLAG UNFLUID SETQ CREFOFF),'EVAL); SYMBOLIC PROCEDURE CREFON; BEGIN SCALAR A,OCRFIL,CRFIL; BTIME!*:=TIME(); DFPRINT!* := 'REFPRINT; !*DEFN := T; IF NOT !*ALGEBRAICS THEN PUT('ALGEBRAIC,'NEWNAM,'SYMBOLIC); FLAG(NOLIST!*,'NOLIST); FLAG(EXPAND!*,'EXPAND); FLAG(DCLGLB!*,'DCLGLB); % Global lists; ENTPTS!*:=NIL; % Entry points to package; UNDEFNS!*:=NIL; % Functions undefined in package; SEEN!*:=NIL; % List of all encountered functions; TSEEN!*:=NIL; % List of all encountered types not flagged % FUNCTION; GSEEN!*:=NIL; % All encountered globals; PFILES!*:=NIL; % Processed files; UNDEFG!*:=NIL; % Undeclared globals encountered; CURLIN!*:=NIL; % Position in file(s) of current command ; PRETITL!*:=NIL; % T if error or questionables found ; % Usages in specific function under analysis; GLOBS!*:=NIL; % Globals refered to in this ; CALLS!*:=NIL; % Functions called by this; LOCLS!*:=NIL; % Defined local variables in this ; TOPLV!*:=T; % NIL if inside function body ; CURFUN!*:=NIL; % Current function beeing analysed; OP!*!*:=NIL; % Current op. in LAP code; SETPAGE(" Errors or questionables",NIL); IF GETD 'BEGIN THEN RETURN NIL; % In REDUCE; % The following loop is used when running in bare LISP; NDF: IF NOT (A EQ !$EOF!$) THEN GO LOP; CRFIL:=NIL; IF NULL OCRFIL THEN GO LOP; CRFIL:=CAAR OCRFIL; RDS CDAR OCRFIL; OCRFIL:=CDR OCRFIL; LOP: A:=ERRORSET('(!%NEXTTYI),T,!*BAKGAG); IF ATOM A THEN GO NDF; CLOC!*:=IF CRFIL THEN CRFIL . PGLINE() ELSE NIL; A:=ERRORSET('(READ),T,!*BAKGAG); IF ATOM A THEN GO NDF; A:=CAR A; IF NOT PAIRP A THEN GO LOP; IF CAR A EQ 'DSKIN THEN <<OCRFIL:=(CRFIL.RDS OPEN(CDR A,'INPUT)).OCRFIL; CRFIL:=CDR A; GO LOP>>; ERRORSET(LIST('REFPRINT,MKQUOTE A),T,!*BAKGAG); IF FLAGP(CAR A,'EVAL) AND (CAR A NEQ 'SETQ OR CADDR A MEMQ '(T NIL) OR CONSTANTP CADDR A OR EQCAR(CADDR A,'QUOTE)) THEN ERRORSET(A,T,!*BAKGAG); IF !*DEFN THEN GO LOP END; SYMBOLIC PROCEDURE UNDEFDCHK FN; IF NOT FLAGP(FN,'DEFD) THEN UNDEFNS!* := FN . UNDEFNS!*; SYMBOLIC PROCEDURE PRIN2NG U; PRIN2N GETES U; SYMBOLIC SMACRO PROCEDURE MSORT LST; % Build tree then collapse; TREE2LST(TREESORT(LST),NIL); SYMBOLIC PROCEDURE CREFOFF; % main call, sets up, alphabetizes and prints; BEGIN SCALAR TIM,X; DFPRINT!* := NIL; !*DEFN:=NIL; IF NOT !*ALGEBRAICS THEN REMPROP('ALGEBRAIC,'NEWNAM); %back to normal; TIM:=TIME()-BTIME!*; FOR EACH FN IN SEEN!* DO <<IF NULL GET(FN,'CALLEDBY) THEN ENTPTS!*:=FN . ENTPTS!*; UNDEFDCHK FN>>; TSEEN!*:=FOR EACH Z IN MSORT TSEEN!* COLLECT <<REMPROP(Z,'TSEEN); FOR EACH FN IN (X:=GET(Z,'FUNS)) DO <<UNDEFDCHK FN; REMPROP(FN,'RCCNAM)>>; Z.X>>; FOR EACH Z IN GSEEN!* DO IF GET(Z,'USEDUNBY) THEN UNDEFG!*:=Z . UNDEFG!*; SETPAGE(" Summary",NIL); NEWPAGE(); PFILES!*:=PUNUSED("Crossreference listing for files:", FOR EACH Z IN PFILES!* COLLECT CDR Z); ENTPTS!*:=PUNUSED("Entry Points:",ENTPTS!*); UNDEFNS!*:=PUNUSED("Undefined Functions:",UNDEFNS!*); UNDEFG!*:=PUNUSED("Undeclared Global Variables:",UNDEFG!*); GSEEN!*:=PUNUSED("Global variables:",GSEEN!*); SEEN!*:=PUNUSED("Functions:",SEEN!*); FOR EACH Z IN TSEEN!* DO <<RPLACD(Z,PUNUSED(LIST(CAR Z," procedures:"),CDR Z)); X:='!( . NCONC(EXPLODE CAR Z,LIST '!)); FOR EACH FN IN CDR Z DO <<FN:=GETES FN; RPLACD(FN,APPEND(X,CDR FN)); RPLACA(FN,LENGTH CDR FN)>> >>; IF !*CREFSUMMARY THEN GOTO XY; IF !*GLOBALS AND GSEEN!* THEN <<SETPAGE(" Global Variable Usage",1); NEWPAGE(); FOR EACH Z IN GSEEN!* DO CREF6 Z>>; IF SEEN!* THEN CREF52(" Function Usage",SEEN!*); FOR EACH Z IN TSEEN!* DO CREF52(LIST(" ",CAR Z," procedures"),CDR Z); SETPAGE(" Toplevel calls:",NIL); X:=T; FOR EACH Z IN PFILES!* DO IF GET(Z,'CALLS) OR GET(Z,'GLOBS) THEN <<IF X THEN <<NEWPAGE(); X:=NIL>>; NEWLINE 0; NEWLINE 0; PRIN2NG Z; SPACES2 15; UNDERLINE2 (LINELENGTH(NIL)-10); CREF51(Z,'CALLS,"Calls:"); IF !*GLOBALS THEN CREF51(Z,'GLOBS,"Globals:")>>; XY: IF !*SAVEPROPS THEN GOTO XX; REMPROPSS(SEEN!*,'(GALL CALLS GLOBS CALLEDBY ALSOIS SAMEAS)); REMFLAGSS(SEEN!*,'(SEEN CINTHIS DEFD)); REMPROPSS(GSEEN!*,'(USEDBY USEDUNBY BOUNDBY SETBY)); REMFLAGSS(GSEEN!*,'(DCLGLB GSEEN GLB2RF GLB2BD GLB2ST)); FOR EACH Z IN TSEEN!* DO REMPROP(CAR Z,'FUNS); FOR EACH Z IN HAVEARGS!* DO REMPROP(Z,'ARGCOUNT); HAVEARGS!* := NIL; XX: NEWLINE 2; IF NOT !*CREFTIME THEN RETURN; BTIME!*:=TIME()-BTIME!*; SETPAGE(" Timing Information",NIL); NEWPAGE(); NEWLINE 0; PRTATM " Total Time="; PRTNUM BTIME!*; PRTATM " (ms)"; NEWLINE 0; PRTATM " Analysis Time="; PRTNUM TIM; NEWLINE 0; PRTATM " Sorting Time="; PRTNUM (BTIME!*-TIM); NEWLINE 0; NEWLINE 0 END; SYMBOLIC PROCEDURE PUNUSED(X,Y); IF Y THEN <<NEWLINE 2; PRTLST X; NEWLINE 0; LPRINT(Y := MSORT Y,8); NEWLINE 0; Y>>; SYMBOLIC PROCEDURE CREF52(X,Y); <<SETPAGE(X,1); NEWPAGE(); FOR EACH Z IN Y DO CREF5 Z>>; SYMBOLIC PROCEDURE CREF5 FN; % Print single entry; BEGIN SCALAR X,Y; NEWLINE 0; NEWLINE 0; PRIN1 FN; SPACES2 15; Y:=GET(FN,'GALL); IF Y THEN <<PRIN1 CDR Y; X:=CAR Y>> ELSE PRIN2 "Undefined"; SPACES2 25; IF FLAGP(FN,'NARYARGS) THEN PRIN2 " Nary Args " ELSE IF (Y:=GET(FN,'ARGCOUNT)) THEN <<PRIN2 " "; PRIN2 Y; PRIN2 " Args ">>; UNDERLINE2 (LINELENGTH(NIL)-10); IF X THEN <<NEWLINE 15; PRTATM '!Line!:; SPACES2 27; PRTNUM CDDR X; PRTATM '!/; PRTNUM CADR X; PRTATM " in "; PRTATM CAR X>>; CREF51(FN,'CALLEDBY,"Called by:"); CREF51(FN,'CALLS,"Calls:"); CREF51(FN,'ALSOIS,"Is also:"); CREF51(FN,'SAMEAS,"Same as:"); IF !*GLOBALS THEN CREF51(FN,'GLOBS,"Globals:") END; SYMBOLIC PROCEDURE CREF51(X,Y,Z); IF (X:=GET(X,Y)) THEN <<NEWLINE 15; PRTATM Z; LPRINT(MSORT X,27)>>; SYMBOLIC PROCEDURE CREF6 GLB; % print single global usage entry; <<NEWLINE 0; PRIN1 GLB; SPACES2 15; NOTUSE!*:=T; CREF61(GLB,'USEDBY,"Global in:"); CREF61(GLB,'USEDUNBY,"Undeclared:"); CREF61(GLB,'BOUNDBY,"Bound in:"); CREF61(GLB,'SETBY,"Set by:"); IF NOTUSE!* THEN PRTATM "*** Not Used ***">>; SYMBOLIC PROCEDURE CREF61(X,Y,Z); IF (X:=GET(X,Y)) THEN <<IF NOT NOTUSE!* THEN NEWLINE 15 ELSE NOTUSE!*:=NIL; PRTATM Z; LPRINT(MSORT X,27)>>; % Analyse bodies of LISP functions for % functions called, and globals used, undefined %; SYMBOLIC SMACRO PROCEDURE FLAG1(U,V); FLAG(LIST U,V); SYMBOLIC SMACRO PROCEDURE REMFLAG1(U,V); REMFLAG(LIST U,V); SYMBOLIC SMACRO PROCEDURE ISGLOB U; FLAGP(U,'DCLGLB); SYMBOLIC SMACRO PROCEDURE CHKSEEN S; % Has this name been encountered already?; IF NOT FLAGP(S,'SEEN) THEN <<FLAG1(S,'SEEN); SEEN!*:=S . SEEN!*>>; SYMBOLIC SMACRO PROCEDURE GLOBREF U; IF NOT FLAGP(U,'GLB2RF) THEN <<FLAG1(U,'GLB2RF); GLOBS!*:=U . GLOBS!*>>; SYMBOLIC SMACRO PROCEDURE ANATOM U; % Global seen before local..ie detect extended from this; IF !*GLOBALS AND U AND NOT(U EQ 'T) AND IDP U AND NOT ASSOC(U,LOCLS!*) THEN GLOBREF U; SYMBOLIC SMACRO PROCEDURE CHKGSEEN G; IF NOT FLAGP(G,'GSEEN) THEN <<GSEEN!*:=G . GSEEN!*; FLAG1(G,'GSEEN)>>; SYMBOLIC PROCEDURE DO!-GLOBAL L; % Catch global defns; % Distinguish FLUID from GLOBAL later; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; FLAG(L,'DCLGLB)>>; PUT('GLOBAL,'ANLFN,'DO!-GLOBAL); PUT('FLUID,'ANLFN,'DO!-GLOBAL); SYMBOLIC ANLFN PROCEDURE UNFLUID L; IF PAIRP(L:=QCRF CAR L) AND !*GLOBALS AND TOPLV!* THEN <<FOR EACH V IN L DO CHKGSEEN V; REMFLAG(L,'DCLGLB)>>; SYMBOLIC PROCEDURE ADD2LOCS LL; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH GG IN LL DO <<OLDLOC:=ASSOC(GG,LOCLS!*); IF NOT NULL OLDLOC THEN << QERLINE 0; PRIN2 "*** Variable "; PRIN1 GG; PRIN2 " nested declaration in "; PRIN2NG CURFUN!*; NEWLINE 0; RPLACD(OLDLOC,NIL.OLDLOC)>> ELSE LOCLS!*:=(GG . LIST NIL) . LOCLS!*; IF ISGLOB(GG) OR FLAGP(GG,'GLB2RF) THEN GLOBIND GG; IF FLAGP(GG,'SEEN) THEN <<QERLINE 0; PRIN2 "*** Function "; PRIN2NG GG; PRIN2 " used as variable in "; PRIN2NG CURFUN!*; NEWLINE 0>> >> END; SYMBOLIC PROCEDURE GLOBIND GG; <<FLAG1(GG,'GLB2BD); GLOBREF GG>>; SYMBOLIC PROCEDURE REMLOCS LLN; BEGIN SCALAR OLDLOC; IF !*GLOBALS THEN FOR EACH LL IN LLN DO <<OLDLOC:=ASSOC(LL,LOCLS!*); IF NULL OLDLOC THEN IF GETD 'BEGIN THEN REDERR LIST(" Lvar confused",LL) ELSE ERROR(0,LIST(" Lvar confused",LL)); IF CDDR OLDLOC THEN RPLACD(OLDLOC,CDDR OLDLOC) ELSE LOCLS!*:=EFFACE1(OLDLOC,LOCLS!*)>> END; SYMBOLIC PROCEDURE ADD2CALLS FN; % Update local CALLS!*; IF NOT(FLAGP(FN,'NOLIST) OR FLAGP(FN,'CINTHIS)) THEN <<CALLS!*:=FN . CALLS!*; FLAG1(FN,'CINTHIS)>>; SYMBOLIC PROCEDURE ANFORM U; IF ATOM U THEN ANATOM U ELSE ANFORM1 U; SYMBOLIC PROCEDURE ANFORML L; BEGIN WHILE NOT ATOM L DO <<ANFORM CAR L; L:=CDR L>>; IF L THEN ANATOM L END; SYMBOLIC PROCEDURE ANFORM1 U; BEGIN SCALAR FN,X; FN:=CAR U; U:=CDR U; IF NOT ATOM FN THEN RETURN <<ANFORM1 FN; ANFORML U>>; IF NOT IDP FN THEN RETURN NIL ELSE IF ISGLOB FN THEN <<GLOBREF FN; RETURN ANFORML U>> ELSE IF ASSOC(FN,LOCLS!*) THEN RETURN ANFORML U; ADD2CALLS FN; CHECKARGCOUNT(FN,LENGTH U); IF FLAGP(FN,'NOANL) THEN NIL ELSE IF X:=GET(FN,'ANLFN) THEN APPLY(X,LIST U) ELSE ANFORML U END; SYMBOLIC ANLFN PROCEDURE LAMBDA U; <<ADD2LOCS CAR U; ANFORML CDR U; REMLOCS CAR U>>; SYMBOLIC PROCEDURE ANLSETQ U; <<ANFORML U; IF !*GLOBALS AND FLAGP(U:=CAR U,'GLB2RF) THEN FLAG1(U,'GLB2ST)>>; PUT('SETQ,'ANLFN,'ANLSETQ); SYMBOLIC ANLFN PROCEDURE COND U; FOR EACH X IN U DO ANFORML X; SYMBOLIC ANLFN PROCEDURE PROG U; <<ADD2LOCS CAR U; FOR EACH X IN CDR U DO IF NOT ATOM X THEN ANFORM1 X; REMLOCS CAR U>>; SYMBOLIC ANLFN PROCEDURE FOREACH U; <<ANFORM CADDR U; ADD2LOCS LIST CAR U; ANFORM CADR CDDDR U; REMLOCS LIST CAR U >>; SYMBOLIC ANLFN PROCEDURE FOR U; <<ANFORML CADR U; ADD2LOCS LIST CAR U; ANFORM CADDDR U; REMLOCS LIST CAR U>>; SYMBOLIC ANLFN PROCEDURE FUNCTION U; IF PAIRP(U:=CAR U) THEN ANFORM1 U ELSE IF ISGLOB U THEN GLOBREF U ELSE IF NULL ASSOC(U,LOCLS!*) THEN ADD2CALLS U; FLAG('(QUOTE GO),'NOANL); SYMBOLIC ANLFN PROCEDURE ERRORSET U; BEGIN SCALAR FN,X; ANFORML CDR U; IF EQCAR(U:=CAR U,'QUOTE) THEN RETURN ERSANFORM CADR U ELSE IF NOT((EQCAR(U,'CONS) OR (X:=EQCAR(U,'LIST))) AND QUOTP(FN:=CADR U)) THEN RETURN ANFORM U; ANFORML CDDR U; IF PAIRP(FN:=CADR FN) THEN ANFORM1 FN ELSE IF FLAGP(FN,'GLB2RF) THEN NIL ELSE IF ISGLOB FN THEN GLOBREF FN ELSE <<ADD2CALLS FN; IF X THEN CHECKARGCOUNT(FN,LENGTH CDDR U)>> END; SYMBOLIC PROCEDURE ERSANFORM U; BEGIN SCALAR LOCLS!*; RETURN ANFORM U END; SYMBOLIC PROCEDURE ANLMAP U; <<ANFORML CDR U; IF QUOTP(U:=CADDR U) AND IDP(U:=CADR U) AND NOT ISGLOBL U AND NOT ASSOC(U,LOCLS!*) THEN CHECKARGCOUNT(U,1)>>; FOR EACH X IN '(MAP MAPC MAPLIST MAPCAR MAPCON MAPCAN) DO PUT(X,'ANLFN,'ANLMAP); SYMBOLIC ANLFN PROCEDURE APPLY U; BEGIN SCALAR FN; ANFORML CDR U; IF QUOTP(FN:=CADR U) AND IDP(FN:=CADR FN) AND EQCAR(U:=CADDR U,'LIST) THEN CHECKARGCOUNT(FN,LENGTH CDR U) END; SYMBOLIC PROCEDURE QUOTP U; EQCAR(U,'QUOTE) OR EQCAR(U,'FUNCTION); PUT('CREF ,'SIMPFG ,'((T (CREFON)) (NIL (CREFOFF)))); SYMBOLIC PROCEDURE OUTREF(S,VARLIS,BODY,TYPE); BEGIN SCALAR CURFUN!*,CALLS!*,GLOBS!*,LOCLS!*,TOPLV!*,A; A:=IF VARLIS MEMQ '(ANP!!ATOM ANP!!IDB ANP!!EQ ANP!!UNKNOWN) THEN NIL ELSE LENGTH VARLIS; S := OUTRDEFUN(S,TYPE,IF A THEN A ELSE GET(BODY,'ARGCOUNT)); IF A THEN <<ADD2LOCS VARLIS; ANFORM(BODY); REMLOCS VARLIS>> ELSE IF NULL BODY OR NOT IDP BODY THEN NIL ELSE IF VARLIS EQ 'ANP!!EQ THEN <<PUT(S,'SAMEAS,LIST BODY); TRAPUT(BODY,'ALSOIS,S)>> ELSE ADD2CALLS BODY; OUTREFEND S END; SYMBOLIC PROCEDURE TRAPUT(U,V,W); BEGIN SCALAR A; IF A:=GET(U,V) THEN (IF NOT(TOPLV!* OR W MEMQ A) THEN RPLACD(A,W . CDR A)) ELSE PUT(U,V,LIST W) END; SYMBOLIC SMACRO PROCEDURE TOPUT(U,V,W); IF W THEN PUT(U,V,IF TOPLV!* THEN UNION(W,GET(U,V)) ELSE W); SYMBOLIC PROCEDURE OUTREFEND S; <<TOPUT(S,'CALLS,CALLS!*); FOR EACH X IN CALLS!* DO <<REMFLAG1(X,'CINTHIS); IF NOT X EQ S THEN <<CHKSEEN X; TRAPUT(X,'CALLEDBY,S)>> >>; TOPUT(S,'GLOBS,GLOBS!*); FOR EACH X IN GLOBS!* DO <<TRAPUT(X,IF ISGLOB X THEN 'USEDBY ELSE <<CHKGSEEN X; 'USEDUNBY>>,S); REMFLAG1(X,'GLB2RF); IF FLAGP(X,'GLB2BD) THEN <<REMFLAG1(X,'GLB2BD); TRAPUT(X,'BOUNDBY,S)>>; IF FLAGP(X,'GLB2ST) THEN <<REMFLAG1(X,'GLB2ST); TRAPUT(X,'SETBY,S)>> >> >>; SYMBOLIC PROCEDURE RECREF(S,TYPE); <<QERLINE 2; PRTATM "*** Redefinition to "; PRIN1 TYPE; PRTATM " procedure, of:"; CREF5 S; REMPROPSS(S,'(CALLS GLOBS SAMEAS)); NEWLINE 2>>; SYMBOLIC PROCEDURE OUTRDEFUN(S,TYPE,V); BEGIN S:=QTYPNM(S,TYPE); IF FLAGP(S,'DEFD) THEN RECREF(S,TYPE) ELSE FLAG1(S,'DEFD); IF FLAGP(TYPE,'FUNCTION) AND (ISGLOB S OR ASSOC(S,LOCLS!*)) THEN <<QERLINE 0; PRIN2 "**** Variable "; PRIN2NG S; PRIN2 " defined as function"; NEWLINE 0>>; IF V AND NOT FLAGP(TYPE,'NARYARG) THEN DEFINEARGS(S,V); PUT(S,'GALL,CURLIN!* . TYPE); GLOBS!*:=NIL; CALLS!*:=NIL; RETURN CURFUN!*:=S END; FLAG('(MACRO FEXPR),'NARYARG); SYMBOLIC PROCEDURE QTYPNM(S,TYPE); IF FLAGP(TYPE,'FUNCTION) THEN <<CHKSEEN S; S>> ELSE BEGIN SCALAR X,Y,Z; IF (Y:=GET(TYPE,'TSEEN)) AND (X:=ATSOC(S,CDR Y)) THEN RETURN CDR X; IF NULL Y THEN <<Y:=LIST ('!( . NCONC(EXPLODE TYPE,LIST '!))); PUT(TYPE,'TSEEN,Y); TSEEN!* := TYPE . TSEEN!*>>; X := COMPRESS (Z := EXPLODE S); RPLACD(Y,(S . X) . CDR Y); Y := APPEND(CAR Y,Z); PUT(X,'RCCNAM,LENGTH Y . Y); TRAPUT(TYPE,'FUNS,X); RETURN X END; SYMBOLIC PROCEDURE DEFINEARGS(NAME,N); BEGIN SCALAR CALLEDWITH,X; CALLEDWITH:=GET(NAME,'ARGCOUNT); IF NULL CALLEDWITH THEN RETURN HASARG(NAME,N); IF N=CALLEDWITH THEN RETURN NIL; IF X := GET(NAME,'CALLEDBY) THEN INSTDOF(NAME,N,CALLEDWITH,X); HASARG(NAME,N) END; SYMBOLIC PROCEDURE INSTDOF(NAME,N,M,FNLST); <<QERLINE 0; PRIN2 "***** "; PRIN1 NAME; PRIN2 " called with "; PRIN2 M; PRIN2 " instead of "; PRIN2 N; PRIN2 " arguments in:"; LPRINT(MSORT FNLST,POSN()+1); NEWLINE 0>>; SYMBOLIC PROCEDURE HASARG(NAME,N); <<HAVEARGS!*:=NAME . HAVEARGS!*; IF N>MAXARG!* THEN <<QERLINE 0; PRIN2 "**** "; PRIN1 NAME; PRIN2 " has "; PRIN2 N; PRIN2 " arguments"; NEWLINE 0 >>; PUT(NAME,'ARGCOUNT,N)>>; SYMBOLIC PROCEDURE CHECKARGCOUNT(NAME,N); BEGIN SCALAR CORRECTN; IF FLAGP(NAME,'NARYARGS) THEN RETURN NIL; CORRECTN:=GET(NAME,'ARGCOUNT); IF NULL CORRECTN THEN RETURN HASARG(NAME,N); IF NOT CORRECTN=N THEN INSTDOF(NAME,CORRECTN,N,LIST CURFUN!*) END; SYMBOLIC PROCEDURE REFPRINT U; BEGIN SCALAR X,Y; X:=IF CLOC!* THEN FILEMK CAR CLOC!* ELSE "*TTYINPUT*"; IF (CURFUN!*:=ASSOC(X,PFILES!*)) THEN <<X:=CAR CURFUN!*; CURFUN!*:=CDR CURFUN!*>> ELSE <<PFILES!*:=(X.(CURFUN!*:=GENSYM())).PFILES!*; Y:=REVERSIP CDR REVERSIP CDR EXPLODE X; PUT(CURFUN!*,'RCCNAM,LENGTH Y . Y)>>; CURLIN!*:=IF CLOC!* THEN X.CDR CLOC!* ELSE NIL; CALLS!*:=GLOBS!*:=LOCLS!*:=NIL; ANFORM U; OUTREFEND CURFUN!* END; FLAG('(SYMBOLIC SMACRO NMACRO),'CREF); SYMBOLIC ANLFN PROCEDURE PUT U; IF TOPLV!* AND QCPUTX CADR U THEN ANPUTX U ELSE ANFORML U; PUT('PUTC,'ANLFN,GET('PUT,'ANLFN)); SYMBOLIC PROCEDURE QCPUTX U; EQCAR(U,'QUOTE) AND (FLAGP(CADR U,'CREF) OR FLAGP(CADR U,'COMPILE)); SYMBOLIC PROCEDURE ANPUTX U; BEGIN SCALAR NAM,TYP,BODY; NAM:=QCRF CAR U; TYP:=QCRF CADR U; U:=CADDR U; IF ATOM U THEN <<BODY:=QCRF U; U:='ANP!!ATOM>> ELSE IF CAR U MEMQ '(QUOTE FUNCTION) THEN IF EQCAR(U:=CADR U,'LAMBDA) THEN <<BODY:=CADDR U; U:=CADR U>> ELSE IF IDP U THEN <<BODY:=U; U:='ANP!!IDB>> ELSE RETURN NIL ELSE IF CAR U EQ 'CDR AND EQCAR(CADR U,'GETD) THEN <<BODY:=QCRF CADADR U; U:='ANP!!EQ>> ELSE IF CAR U EQ 'GET AND QCPUTX CADDR U THEN <<BODY:=QTYPNM(QCRF CADR U,CADR CADDR U); U:='ANP!!EQ>> ELSE IF CAR U EQ 'MKCODE THEN <<ANFORM CADR U; U:=QCRF CADDR U; BODY:=NIL>> ELSE <<BODY:=QCRF U; U:='ANP!!UNKNOWN>>; OUTREF(NAM,U,BODY,TYP) END; SYMBOLIC ANLFN PROCEDURE PUTD U; IF TOPLV!* THEN ANPUTX U ELSE ANFORML U; SYMBOLIC ANLFN PROCEDURE DE U; OUTDEFR(U,'EXPR); SYMBOLIC ANLFN PROCEDURE DF U; OUTDEFR(U,'FEXPR); SYMBOLIC ANLFN PROCEDURE DM U; OUTDEFR(U,'MACRO); SYMBOLIC PROCEDURE OUTDEFR(U,TYPE); OUTREF(CAR U,CADR U,CADDR U,TYPE); SYMBOLIC PROCEDURE QCRF U; IF NULL U OR U EQ T THEN U ELSE IF EQCAR(U,'QUOTE) THEN CADR U ELSE <<ANFORM U; COMPRESS EXPLODE '!?VALUE!?!?>>; FLAG('(EXPR FEXPR MACRO SYMBOLIC SMACRO NMACRO),'FUNCTION); SYMBOLIC ANLFN PROCEDURE LAP U; IF PAIRP(U:=QCRF CAR U) THEN BEGIN SCALAR GLOBS!*,LOCLS!*,CALLS!*,CURFUN!*,TOPLV!*,X; WHILE U DO <<IF PAIRP CAR U THEN IF X:=GET(OP!*!*:=CAAR U,'CRFLAPO) THEN APPLY(X,LIST U) ELSE IF !*GLOBALS THEN FOR EACH Y IN CDAR U DO ANLAPEV Y; U:=CDR U>>; QOUTREFE() END; SYMBOLIC CRFLAPO PROCEDURE !*ENTRY U; <<QOUTREFE(); U:=CDAR U; OUTRDEFUN(CAR U,CADR U,CADDR U)>>; SYMBOLIC PROCEDURE QOUTREFE; BEGIN IF NULL CURFUN!* THEN IF GLOBS!* OR CALLS!* THEN <<CURFUN!*:=COMPRESS EXPLODE '!?LAP!?!?; CHKSEEN CURFUN!*>> ELSE RETURN; OUTREFEND CURFUN!* END; SYMBOLIC CRFLAPO PROCEDURE !*LAMBIND U; FOR EACH X IN CADDAR U DO GLOBIND CAR X; SYMBOLIC CRFLAPO PROCEDURE !*PROGBIND U; FOR EACH X IN CADAR U DO GLOBIND CAR X; SYMBOLIC PROCEDURE LINCALL U; <<ADD2CALLS CAR (U:=CDAR U); CHECKARGCOUNT(CAR U,CADDR U)>>; PUT('!*LINK,'CRFLAPO,'LINCALL); PUT('!*LINKE,'CRFLAPO,'LINCALL); SYMBOLIC PROCEDURE ANLAPEV U; IF PAIRP U THEN IF CAR U MEMQ '(GLOBAL FLUID) THEN <<U:=CADR U; GLOBREF U; IF FLAGP(OP!*!*,'STORE) THEN PUT(U,'GLB2ST,'T)>> ELSE <<ANLAPEV CAR U; ANLAPEV CDR U>>; FLAG('(!*STORE),'STORE); SYMBOLIC PROCEDURE QERLINE U; IF PRETITL!* THEN NEWLINE U ELSE <<PRETITL!*:=T; NEWPAGE()>>; % These functions defined to be able to run in bare LISP; SYMBOLIC PROCEDURE EQCAR(U,V); PAIRP U AND CAR U EQ V; SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U); SYMBOLIC PROCEDURE EFFACE1(U,V); IF NULL V THEN NIL ELSE IF U EQ CAR V THEN CDR V ELSE RPLACD(V,EFFACE1(U,CDR V)); % Systemdependent part; MAXARG!*:=14; FLAG('(POP MOVEM SETZM HRRZM),'STORE); SYMBOLIC PROCEDURE LAPCALLF U; BEGIN SCALAR FN; RETURN IF EQCAR(CADR (U:=CDAR U),'E) THEN <<ADD2CALLS(FN:=CADADR U); CHECKARGCOUNT(FN,CAR U)>> ELSE IF !*GLOBALS THEN ANLAPEV CADR U END; PUT('JCALL,'CRFLAPO,'LAPCALLF); PUT('CALLF,'CRFLAPO,'LAPCALLF); PUT('JCALLF,'CRFLAPO,'LAPCALLF); SYMBOLIC CRFLAPO PROCEDURE CALL U; IF NOT(CADDAR U = '(E !*LAMBIND!*)) THEN LAPCALLF U ELSE WHILE ((U:=CDR U) AND PAIRP CAR U AND CAAR U = 0) DO GLOBIND CADR CADDAR U; END; |
Added r30/redio.fap version [5e234b0a96].
cannot compute difference between binary files
Added r30/redio.red version [6da04ab67d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT General Purpose I/O package ... sorting and positioning; SYMBOLIC; !*RAISE := NIL; GLOBAL '(!*FORMFEED ORIG!* RCCNUMS!* BTIME!* LNNUM!* MAXLN!* TITLE!* PGNUM!*); % FLAGS: FORMFEED (ON) controls ^L or spacer of ====; SYMBOLIC PROCEDURE INITIO(); % Set-up common defaults; BEGIN !*FORMFEED:=T; ORIG!*:=0; LNNUM!*:=0; LINELENGTH(75); MAXLN!*:=55; TITLE!*:=NIL; PGNUM!*:=1; END; SYMBOLIC PROCEDURE LPOSN(); LNNUM!*; INITIO(); SYMBOLIC PROCEDURE RCCBLD(); % Initialises RCC as number 0 to RCCNUMS!*-1 on Plist of all % characters; BEGIN SCALAR L,N,V; N:=0; % digits are now ids; L:='(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9 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 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 !{ !! !" !# !; !% !& !' !( !) !_ != !} !\ !^ !@ !+ !* !< !> !? ![ !- !] !| !~ !` !; !: !, !. !/ !$ ! ); RCCNUMS!*:=1 . NIL; FOR I:=1:7 DO RCCNUMS!*:=(CAR(RCCNUMS!*) * 128 ) . RCCNUMS!*; WHILE L DO <<V:=CAR L;L:=CDR L; IF V THEN PUT(V,'RCC,N); N:=N+1>>; END; RCCBLD(); SYMBOLIC PROCEDURE SETPGLN(P,L); BEGIN IF P THEN MAXLN!*:=P; IF L THEN LINELENGTH(L); END; % We use EXPLODE to produce a list of chars from atomname, % and TERPRI() to terminate a buffer..all else % done in package..spaces,tabs,etc. ; COMMENT Character lists are (length . chars), for FITS; SYMBOLIC PROCEDURE GETES U; % Returns for U , E=(Length . List of char); BEGIN SCALAR E; IF NOT IDP U THEN RETURN<<E:=EXPLODE U;LENGTH(E).E>>; IF NOT(E:=GET(U,'RCCNAM)) THEN <<E:=EXPLODE(U); E:=LENGTH(E) . E; PUT(U,'RCCNAM,E)>>; RETURN E; END; SYMBOLIC SMACRO PROCEDURE PRTWRD U; IF NUMBERP U THEN PRTNUM U ELSE PRTATM U; SYMBOLIC PROCEDURE PRTATM U; PRIN2 U; % For a nice print; SYMBOLIC PROCEDURE PRTLST U; IF ATOM U THEN PRIN2 U ELSE FOR EACH X IN U DO PRIN2 X; SYMBOLIC PROCEDURE PRTNUM N; PRIN2 N; SYMBOLIC PROCEDURE PRIN2N E; % output a list of chars, update POSN(); WHILE (E:=CDR E) DO PRIN2 CAR E; SYMBOLIC PROCEDURE SPACES N; FOR I:=1:N DO PRIN2 '! ; SYMBOLIC PROCEDURE SPACES2 N; BEGIN SCALAR X; X := N - POSN(); IF X<1 THEN NEWLINE N ELSE SPACES X; END; SYMBOLIC PROCEDURE SETPAGE(TITLE,PAGE); % Initialise current page and title; BEGIN TITLE!*:= TITLE ; PGNUM!*:=PAGE; END; SYMBOLIC PROCEDURE NEWLINE N; % Begins a fresh line at posn N; BEGIN LNNUM!*:=LNNUM!*+1; IF LNNUM!*>=MAXLN!* THEN NEWPAGE() ELSE TERPRI(); SPACES(ORIG!*+N); END; SYMBOLIC PROCEDURE NEWPAGE(); % Start a fresh page, with PGNUM and TITLE, if needed; BEGIN SCALAR A; A:=LPOSN(); LNNUM!*:=0; IF POSN() NEQ 0 THEN NEWLINE 0; IF A NEQ 0 THEN FORMFEED(); IF TITLE!* THEN <<SPACES2 5; PRTLST TITLE!*>>; SPACES2 (LINELENGTH(NIL)-4); IF PGNUM!* THEN <<PRTNUM PGNUM!*; PGNUM!*:=PGNUM!*+1>> ELSE PGNUM!*:=2; NEWLINE 10; NEWLINE 0; END; SYMBOLIC PROCEDURE UNDERLINE2 N; IF N>=LINELENGTH(NIL) THEN <<N:=LINELENGTH(NIL)-POSN(); FOR I:=0:N DO PRIN2 '!- ; NEWLINE(0)>> ELSE BEGIN SCALAR J; J:=N-POSN(); FOR I:=0:J DO PRIN2 '!-; END; SYMBOLIC PROCEDURE LPRINT(U,N); % prints a list of atoms within block LINELENGTH(NIL)-n; BEGIN SCALAR E; INTEGER L,M; SPACES2 N; L := LINELENGTH NIL-POSN(); IF L<=0 THEN ERROR(13,"WINDOW TOO SMALL FOR LPRINT"); WHILE U DO <<E:=GETES CAR U; U:=CDR U; IF LINELENGTH NIL<POSN() THEN NEWLINE N; IF CAR E<(M := LINELENGTH NIL-POSN()) THEN PRIN2N E ELSE IF CAR E<L THEN <<NEWLINE N; PRIN2N E>> ELSE BEGIN E := CDR E; A: FOR I := 1:M DO <<PRIN2 CAR E; E := CDR E>>; NEWLINE N; IF NULL E THEN NIL ELSE IF LENGTH E<(M := L) THEN PRIN2N(NIL . E) ELSE GO TO A END; PRIN2 '! >> END; SYMBOLIC PROCEDURE REMPROPSS(ATMLST,LST); WHILE ATMLST DO <<WHILE LST DO <<REMPROP(CAR ATMLST,CAR LST); LST:=CDR LST>>; ATMLST:=CDR ATMLST>>; SYMBOLIC PROCEDURE REMFLAGSS(ATMLST,LST); WHILE LST DO <<REMFLAG(ATMLST,CAR LST); LST:=CDR LST>>; SYMBOLIC PROCEDURE FORMFEED; IF !*FORMFEED THEN EJECT() ELSE <<TERPRI(); PRIN2 " ========================================= "; TERPRI()>>; % ======= Extended IO and ALPHA-SORT package, Needs BIGNUMS; %Establish RCC (Reduce charactercode) for collating % and then each atom to be printed will be % lst of chars stored under 'RCCNAM % with numeric collating order under 'RCCORD ; SYMBOLIC SMACRO PROCEDURE GETRCC CHAR; GET(CHAR,'RCC); SYMBOLIC PROCEDURE GETORD U; % Given an atom, it is RCCNAM, stored under 'RCCNAM % and its RCCORD evaluated(essentially packed pname); BEGIN SCALAR E,N,NN; IF NOT IDP U THEN GOTO L1; IF (N:=GET(U,'RCCORD)) THEN RETURN (U .N); L1: E:=GETES U; N:=0; NN:=RCCNUMS!*; WHILE (E:=CDR E) AND NN DO <<N:=GETRCC(CAR E)*CAR(NN)+N; NN:=CDR NN>>; IF IDP U THEN PUT(U,'RCCORD,N); RETURN (U . N); END; % **** SORTING SECTION ****** % routines modified from funtr for alphabetic sorting % and i/o...merge of cref,alp RCC etc; % TREE SORT OF LIST OF ATOMS; % % TREE IS NIL or STRUCT(VAL:value,SONS:node-pair) % node-pair=STRUCT(LNODE:tree,RNODE:tree); SYMBOLIC PROCEDURE NEWNODE(ELEM); LIST(ELEM,NIL); SYMBOLIC SMACRO PROCEDURE VAL NODE; % will have (ATOM . lst) as elem; CAAR NODE; SYMBOLIC SMACRO PROCEDURE PREPVAL ELEM; GETORD ELEM; SYMBOLIC SMACRO PROCEDURE LNODE NODE; CADR NODE; SYMBOLIC SMACRO PROCEDURE RNODE NODE; CDDR NODE; SYMBOLIC SMACRO PROCEDURE NEWLFT(NODE,ELEM); RPLACA(CDR NODE,NEWNODE ELEM); SYMBOLIC SMACRO PROCEDURE NEWRGT(NODE,ELEM); RPLACD(CDR NODE,NEWNODE ELEM); SYMBOLIC SMACRO PROCEDURE MSORT LST; % Build tree then collapse; TREE2LST(TREESORT(LST),NIL); SYMBOLIC PROCEDURE TREESORT LST; % Uses insert of elemnt to tree; BEGIN SCALAR TREE; IF NULL LST THEN RETURN NIL; TREE:=NEWNODE PREPVAL( CAR LST); WHILE (LST:=CDR LST) DO PUTTREE(PREPVAL(CAR LST),TREE); RETURN TREE; END; SYMBOLIC SMACRO PROCEDURE TORGT( ELEM,NODE); % RETURNS T if ELEM to go to right of VAL(NODE); CDR(ELEM)>CDAR(NODE); SYMBOLIC PROCEDURE PUTTREE(ELEM,NODE); BEGIN DWN: IF TORGT(ELEM,NODE) THEN GOTO RGT; IF LNODE NODE THEN <<NODE:=LNODE NODE;GO TO DWN>>; NEWLFT(NODE,ELEM); RETURN; RGT: IF RNODE NODE THEN <<NODE:=RNODE NODE;GO TO DWN>>; NEWRGT(NODE,ELEM); RETURN; END; SYMBOLIC PROCEDURE TREE2LST(TREE,LST); BEGIN WHILE TREE DO <<LST:=VAL(TREE) .TREE2LST(RNODE TREE,LST); TREE:=LNODE TREE>>; RETURN LST; END; SYMBOLIC PROCEDURE UNION(X,Y); IF NULL X THEN Y ELSE UNION(CDR X,IF CAR X MEMBER Y THEN Y ELSE CAR X . Y); !*RAISE := T; %system standard?; % Convert a file specification from lisp format to a string. % This is essentially the inverse of MKFILE; SYMBOLIC PROCEDURE FILEMK U; BEGIN SCALAR DEV,NAME,FLG,FLG2; IF NULL U THEN RETURN NIL ELSE IF ATOM U THEN NAME := EXPLODEC U ELSE FOR EACH X IN U DO IF X EQ 'DIR!: THEN FLG := T ELSE IF ATOM X THEN IF FLG THEN DEV := '!< . NCONC(EXPLODEC X,LIST '!>) ELSE IF X EQ 'DSK!: THEN DEV:=NIL ELSE IF !%DEVP X THEN DEV := EXPLODEC X ELSE NAME := EXPLODEC X ELSE IF ATOM CDR X THEN NAME := NCONC(EXPLODEC CAR X,'!. . EXPLODEC CDR X) ELSE <<FLG2 := T; DEV := '![ . NCONC(EXPLODEC CAR X, '!, . NCONC(EXPLODEC CADR X,LIST '!]))>>; U := IF FLG2 THEN NCONC(NAME,DEV) ELSE NCONC(DEV,NAME); RETURN COMPRESS('!" . NCONC(U,'(!"))) END; END; |
Added r30/reduce.doc version [d738db3b41].
cannot compute difference between binary files
Added r30/reduce.tst version [ebf0cc271a].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | SHOWTIME$ COMMENT SOME EXAMPLES OF THE F O R STATEMENT; COMMENT SUMMING THE SQUARES OF THE EVEN POSITIVE INTEGERS THROUGH 50; FOR I:=2 STEP 2 UNTIL 50 SUM I**2; COMMENT TO SET W TO THE FACTORIAL OF 10; W := FOR I:=1:10 PRODUCT I; COMMENT ALTERNATIVELY, WE COULD SET THE ELEMENTS A(I) OF THE ARRAY A TO THE FACTORIAL OF I BY THE STATEMENTS; ARRAY A(10); A(0):=1$ FOR I:=1:10 DO A(I):=I*A(I-1); COMMENT THE ABOVE VERSION OF THE F O R STATEMENT DOES NOT RETURN AN ALGEBRAIC VALUE, BUT WE CAN NOW USE THESE ARRAY ELEMENTS AS FACTORIALS IN EXPRESSIONS, E. G.; 1+A(5); COMMENT WE COULD HAVE PRINTED THE VALUES OF EACH A(I) AS THEY WERE COMPUTED BY REPLACING THE F O R STATEMENT BY; FOR I:=1:10 DO WRITE A(I):= I*A(I-1); COMMENT ANOTHER WAY TO USE FACTORIALS WOULD BE TO INTRODUCE AN OPERATOR FAC BY AN INTEGER PROCEDURE AS FOLLOWS; INTEGER PROCEDURE FAC (N); BEGIN INTEGER M; M:=1; L1: IF N=0 THEN RETURN M; M:=M*N; N:=N-1; GO TO L1 END; COMMENT WE CAN NOW USE FAC AS AN OPERATOR IN EXPRESSIONS, E. G.; Z**2+FAC(4)-2*FAC 2*Y; COMMENT NOTE IN THE ABOVE EXAMPLE THAT THE PARENTHESES AROUND THE ARGUMENTS OF FAC MAY BE OMITTED SINCE IT IS A UNARY OPERATOR; COMMENT THE FOLLOWING EXAMPLES ILLUSTRATE THE SOLUTION OF SOME COMPLETE PROBLEMS; COMMENT THE F AND G SERIES (REF SCONZO, P., LESCHACK, A. R. AND TOBEY, R. G., ASTRONOMICAL JOURNAL, VOL 70 (MAY 1965); DEPS:= -SIG*(MU+2*EPS)$ DMU:= -3*MU*SIG$ DSIG:= EPS-2*SIG**2$ F1:= 1$ G1:= 0$ FOR I:= 1:8 DO BEGIN F2:= -MU*G1 + DEPS*DF(F1,EPS) + DMU*DF(F1,MU) + DSIG*DF(F1,SIG)$ WRITE "F(",I,") := ",F2; G2:= F1 + DEPS*DF(G1,EPS) + DMU*DF(G1,MU) + DSIG*DF(G1,SIG)$ WRITE "G(",I,") := ",G2; F1:=F2$ G1:=G2 END; COMMENT A PROBLEM IN FOURIER ANALYSIS; FOR ALL X,Y LET COS(X)*COS(Y)= (COS(X+Y)+COS(X-Y))/2, COS(X)*SIN(Y)= (SIN(X+Y)-SIN(X-Y))/2, SIN(X)*SIN(Y)= (COS(X-Y)-COS(X+Y))/2, COS(X)**2= (1+COS(2*X))/2, SIN(X)**2= (1-COS(2*X))/2; FACTOR COS,SIN; ON LIST; (A1*COS(WT)+ A3*COS(3*WT)+ B1*SIN(WT)+ B3*SIN(3*WT))**3; COMMENT END OF FOURIER ANALYSIS EXAMPLE; OFF LIST; FOR ALL X,Y CLEAR COS X*COS Y, COS X*SIN Y, SIN X*SIN Y, COS(X)**2,SIN(X)**2; COMMENT LEAVING SUCH REPLACEMENTS ACTIVE WOULD SLOW DOWN SUBSEQUENT COMPUTATION; COMMENT THE FOLLOWING PROGRAM, WRITTEN IN COLLABORATION WITH DAVID BARTON AND JOHN FITCH, SOLVES A PROBLEM IN GENERAL RELATIVITY. IT WILL COMPUTE THE EINSTEIN TENSOR FROM ANY GIVEN METRIC; ON NERO; COMMENT HERE WE INTRODUCE THE COVARIANT AND CONTRAVARIANT METRICS; OPERATOR P1,Q1,X; ARRAY GG(3,3),H(3,3)$ GG(0,0):=E**(Q1(X(1)))$ GG(1,1):=-E**(P1(X(1)))$ GG(2,2):=-X(1)**2$ GG(3,3):=-X(1)**2*SIN(X(2))**2$ FOR I:=0:3 DO H(I,I):=1/GG(I,I)$ COMMENT GENERATE CHRISTOFFEL SYMBOLS AND STORE IN ARRAYS CS1 AND CS2; ARRAY CS1(3,3,3),CS2(3,3,3)$ FOR I:=0:3 DO FOR J:=I:3 DO BEGIN FOR K:=0:3 DO CS1(J,I,K) := CS1(I,J,K):=(DF(GG(I,K),X(J))+DF(GG(J,K),X(I)) -DF(GG(I,J),X(K)))/2; FOR K:=0:3 DO CS2(J,I,K):= CS2(I,J,K) := FOR P := 0:3 SUM H(K,P)*CS1(I,J,P) END; COMMENT NOW COMPUTE THE RIEMANN TENSOR AND STORE IN R(I,J,K,L); ARRAY R(3,3,3,3)$ FOR I:=0:3 DO FOR J:=I+1:3 DO FOR K:=I:3 DO FOR L:=K+1:IF K=I THEN J ELSE 3 DO BEGIN R(J,I,L,K) := R(I,J,K,L) := FOR Q := 0:3 SUM GG(I,Q)*(DF(CS2(K,J,Q),X(L))-DF(CS2(J,L,Q),X(K)) + FOR P:=0:3 SUM (CS2(P,L,Q)*CS2(K,J,P) -CS2(P,K,Q)*CS2(L,J,P)))$ LET R(I,J,L,K) = -R(I,J,K,L), R(J,I,K,L)= -R(I,J,K,L); IF I=K AND J<=L THEN GO TO A$ R(K,L,I,J) := R(L,K,J,I) := R(I,J,K,L)$ LET R(L,K,I,J) = -R(I,J,K,L), R(K,L,J,I)= -R(I,J,K,L); A: END$ COMMENT NOW COMPUTE AND PRINT THE RICCI TENSOR; ARRAY RICCI(3,3)$ FOR I:=0:3 DO FOR J:=0:3 DO WRITE RICCI(J,I) := RICCI(I,J) := FOR P := 0:3 SUM FOR Q := 0:3 SUM H(P,Q)*R(Q,I,P,J); COMMENT NOW COMPUTE AND PRINT THE RICCI SCALAR; RS := FOR I:= 0:3 SUM FOR J:= 0:3 SUM H(I,J)*RICCI(I,J); COMMENT FINALLY COMPUTE AND PRINT THE EINSTEIN TENSOR; ARRAY EINSTEIN(3,3); FOR I:=0:3 DO FOR J:=0:3 DO WRITE EINSTEIN(I,J):=RICCI(I,J)-RS*GG(I,J)/2; COMMENT END OF EINSTEIN TENSOR PROGRAM; CLEAR GG,H,CS1,CS2,R,RICCI,EINSTEIN; COMMENT AN EXAMPLE USING THE MATRIX FACILITY; MATRIX XX,YY; LET XX= MAT((A11,A12),(A21,A22)), YY= MAT((Y1),(Y2)); 2*DET XX - 3*W; ZZ:= XX**(-1)*YY; 1/XX**2; COMMENT END OF MATRIX EXAMPLES; COMMENT THE FOLLOWING EXAMPLES WILL FAIL UNLESS THE FUNCTIONS NEEDED FOR PROBLEMS IN HIGH ENERGY PHYSICS HAVE BEEN LOADED; COMMENT A PHYSICS EXAMPLE; ON DIV; COMMENT THIS GIVES US OUTPUT IN SAME FORM AS BJORKEN AND DRELL; MASS KI= 0, KF= 0, PI= M, PF= M; VECTOR EI,EF; MSHELL KI,KF,PI,PF; LET PI.EI= 0, PI.EF= 0, PI.PF= M**2+KI.KF, PI.KI= M*K,PI.KF= M*KP, PF.EI= -KF.EI, PF.EF= KI.EF, PF.KI= M*KP, PF.KF= M*K, KI.EI= 0, KI.KF= M*(K-KP), KF.EF= 0, EI.EI= -1, EF.EF= -1; OPERATOR GP; FOR ALL P LET GP(P)= G(L,P)+M; COMMENT THIS IS JUST TO SAVE US A LOT OF WRITING; GP(PF)*(G(L,EF,EI,KI)/(2*KI.PI) + G(L,EI,EF,KF)/(2*KF.PI)) * GP(PI)*(G(L,KI,EI,EF)/(2*KI.PI) + G(L,KF,EF,EI)/(2*KF.PI)) $ WRITE "THE COMPTON CROSS-SECTION IS ",WS; COMMENT END OF FIRST PHYSICS EXAMPLE; OFF DIV; COMMENT ANOTHER PHYSICS EXAMPLE; FACTOR MM,P1.P3; INDEX X1,Y1,Z; MASS P1=MM,P2=MM,P3= MM,P4= MM,K1=0; MSHELL P1,P2,P3,P4,K1; VECTOR Q1,Q2; OPERATOR GA,GB; FOR ALL P LET GA(P)=G(LA,P)+MM, GB(P)= G(LB,P)+MM; GA(-P2)*G(LA,X1)*GA(-P4)*G(LA,Y1)* (GB(P3)*G(LB,X1)*GB(Q1) *G(LB,Z)*GB(P1)*G(LB,Y1)*GB(Q2)*G(LB,Z) + GB(P3) *G(LB,Z)*GB(Q2)*G(LB,X1)*GB(P1)*G(LB,Z)*GB(Q1)*G(LB,Y1))$ LET Q1=P1-K1, Q2=P3+K1; COMMENT IT IS USUALLY FASTER TO MAKE SUCH SUBSTITUTIONS AFTER ALL THE TRACE ALGEBRA IS DONE; WRITE "CXN =",WS; COMMENT END OF SECOND PHYSICS EXAMPLE; SHOWTIME$ END; |
Added r30/rend.fap version [1429c388c2].
cannot compute difference between binary files
Added r30/rend.red version [d76347de50].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT The following is needed to get string case correct; FLAG('(OFF),'EVAL); OFF RAISE; COMMENT The following functions, which are referenced in the basic REDUCE source (RLISP, ALG1, ALG2, MATR and PHYS) should be defined to complete the definition of REDUCE: BYE DELCP ERROR1 FILETYPE MKFIL ORDERP QUIT SEPRP SETPCHAR. Prototypical descriptions of these functions are as follows; SYMBOLIC PROCEDURE BYE; %Returns control to the computer's operating system command level. %The current REDUCE job cannot be restarted; EVAL '(QUIT); SYMBOLIC PROCEDURE DELCP U; %Returns true if U is a semicolon, dollar sign, or other delimiter. %This definition replaces the one in the BOOT file; U EQ '!; OR U EQ '!$ OR U EQ INTERN ASCII 125; SYMBOLIC PROCEDURE ERROR1; %This is the only call to an error function in the REDUCE source. It %should cause an error return, but NOT print anything, as preceding %statements have already done that. In terms of the LISP error %function it can be defined as follows; ERROR(99,NIL); SYMBOLIC PROCEDURE FILETYPE U; %determines the extension of a file U; IF ATOM U THEN NIL ELSE IF NOT ATOM CAR U AND NULL CDR U THEN FILETYPE CAR U ELSE IF DEVP CAR U THEN IF CAR U EQ 'DIR!: THEN FILETYPE CADDR U ELSE FILETYPE CADR U ELSE IF NOT IDP CDR U THEN NIL ELSE CDR U; SYMBOLIC PROCEDURE DEVP U; %determines if U is a file device type. NOT ATOM U OR IDP U AND CAR REVERSIP EXPLODE U EQ '!:; %SYMBOLIC PROCEDURE MKFIL U; %converts file descriptor U into valid system filename; %U; %this is the simplest one can do; %SYMBOLIC PROCEDURE ORDERP(U,V); %Returns true if U has same or higher order than id V by some %consistent convention (eg unique position in memory); %It must usually be defined in LAP, as in following DEC 10 version; %It must also be loaded BEFORE ALG2.RED; LAP '((ORDERP EXPR 2) (104960 1 2) (112640 1 (C 0)) (MOVEI 1 (QUOTE T)) (POPJ P)); %SYMBOLIC PROCEDURE QUIT; %Returns control to the computer's operating system command level. %The current REDUCE job can however be restarted; GLOBAL '(!$EOL!$); SYMBOLIC PROCEDURE SEPRP U; %returns true if U is a blank or other separator (eg, tab or ff). %This definition replaces one in the BOOT file; U EQ '! OR U EQ '! OR U EQ !$EOL!$ OR U EQ INTERN ASCII 12; %SYMBOLIC PROCEDURE SETPCHAR U; %This function sets the terminal prompt character to U and returns %the previous value; %U; COMMENT The following functions are only referenced if various flags are set, or the functions are actually defined. They are defined in another module, which is not needed to build the basic system. The name of the flag follows the function name, enclosed in parentheses: BFQUOTIENT!: (BIGFLOAT) CEDIT (?) COMPD (COMP) EDIT1 This function provides a link to an editor. However, a definition is not necessary, since REDUCE checks to see if it has a function value. EMBFN (?) EZGCDF (EZGCD) FACTORF (FACTOR) LOAD!-MODULE (property list attribute MODULE-NAME) This function is used to load an external module into the system. It is only called if an attribute DOMAIN-MODE is given to a domain mode tag PRETTYPRINT (DEFN --- also called by DFPRINT) This function is used in particular for output of RLISP expressions in LISP syntax. If that feature is needed, and the prettyprint module is not available, then it should be defined as PRINT RPRINT (PRET) TEXPT!: (BIGFLOAT) TEXPT!:ANY (BIGFLOAT) TIME (TIME) returns elapsed time from some arbitrary initial point in milliseconds; COMMENT The FACTOR module also requires a definition for GCTIME, the time taken for garbage collection. If this is not defined in the given system, the following definition may be used; SYMBOLIC PROCEDURE GCTIME; 0; COMMENT The following definition overrides the standard source version; REMFLAG('(PRINTPROMPT),'LOSE); SYMBOLIC PROCEDURE PRINTPROMPT U; NIL; FLAG('(PRINTPROMPT),'LOSE); COMMENT There is also one global variable in the system which must be set independent of the sources, namely **ESC. This variable is used to "escape" from an input sequence to the top level of REDUCE. For complete flexibility, it should be defined as a global. Otherwise, a NEWNAM statement can be used. However, it MUST be defined in LISP before RLISP is loaded, and cannot be left until this file is defined. At the moment, this feature is not supported, as it interferes with the editing facilities; GLOBAL '(!*!*ESC); !*!*ESC := '!*ESC!*; COMMENT In addition, the global variable ESC* is used by the interactive string editor (defined in CEDIT) as a terminator for input strings. On ASCII terminals, <escape> is a good candidate; GLOBAL '(ESC!*); ESC!* := INTERN ASCII 125; %escape character; COMMENT We also need to define a function BEGIN, which acts as the top-level call to REDUCE, and sets the appropriate variables. The following is a minimum definition; REMFLAG('(BEGIN),'GO); FLUID '(LREADFN!* !*ECHO !*MODE !*SLIN); GLOBAL '(CRCHAR!* DATE!* ORIG!* !*EXTRAECHO !*HELP !*INT); GLOBAL '(CONTL!* IFL!* IPL!* OFL!* OPL!*); COMMENT The following two variables are DEC 10 specific; GLOBAL '(SYSTEM!* !*BAKGAG); SYMBOLIC PROCEDURE BEGIN; BEGIN SCALAR A1; ORIG!* := 0; !*ECHO := NOT !*INT; % !*EXTRAECHO := T; %this is needed in systems which do not %have the "standard" eol convention; CONTL!* := IFL!* := IPL!* := OFL!* := OPL!* := NIL; A1 := !*SLIN; !*SLIN := NIL; %shows we have entered this BEGIN; %The next eight lines are DEC 10 specific; !*BAKGAG := NIL; %turn off backtrace; LREADFN!* := NIL; %define a special reading function; RDSLSH NIL; %modify reader for Rlisp token handling; SCANSET T; %use table driven scanner; % IF SYSTEM!* NEQ 0 THEN CHKLEN(); % IF SYSTEM!*=1 THEN BEGIN SCALAR A2; % SETSYS % IF PAIRP(A2:=ERRORSET('(JSYS 32 0 "<REDUCE>" 0 1),NIL,NIL)) % THEN BOOLE(1,CAR A2,262143) ELSE 0 END; %end of DEC 10 specific code; IF NULL DATE!* THEN <<IF A1 THEN PRIN2T "Reduce Parsing ..."; GO TO A>>; IF FILEP '((REDUCE . INI)) THEN <<IN "REDUCE.INI"; TERPRI()>>; %allows for the automatic load of an initialization file; LINELENGTH IF !*INT THEN 72 ELSE 115; PRIN2 "REDUCE 3.0, "; PRIN2 DATE!*; PRIN2T " ..."; !*MODE := IF GETD 'ADDSQ THEN 'ALGEBRAIC ELSE 'SYMBOLIC; DATE!* := NIL; IF !*HELP THEN PRIN2 "For help, type HELP<escape>"; TERPRI(); A: CRCHAR!* := '! ; %necessary initialization of CRCHAR!*; BEGIN1(); !*SLIN := T; RESETPARSER(); %in case *SLIN affects this; PRIN2T "Entering LISP ..."; SETPCHAR '!* END; FLAG('(BEGIN),'GO); COMMENT And now to set some system dependent variables; DATE!* := "15-Apr-83"; %!*INT := T; %sets the appropriate interactive mode. %Needs to be suppressed during bootstrapping %to avoid CRBUF!* being used; COMMENT on the DEC 10, the end-of-file condition is not handled in quite the way described in the Standard LISP Report. The following statement is necessary to solve this problem; %!$EOF!$ := '!$EOF!$; COMMENT And finally ...; %REMD 'BEGIN2; %used in full bootstrap and needed later; COMMENT Definitions needed to support Norman-Moore factorizer on the PDP-10; FLUID '(LARGEST!-SMALL!-MODULUS); LARGEST!-SMALL!-MODULUS := 2**32; SYMBOLIC PROCEDURE LOGAND2(M,N); BOOLE(1,M,N); SYMBOLIC PROCEDURE LOGOR2(M,N); BOOLE(7,M,N); SYMBOLIC PROCEDURE LOGXOR2(M,N); BOOLE(6,M,N); REMFLAG('(IRIGHTSHIFT), 'LOSE); SYMBOLIC SMACRO PROCEDURE IRIGHTSHIFT(U,N); LSH(U,-N); FLAG('(IRIGHTSHIFT), 'LOSE); SYMBOLIC SMACRO PROCEDURE LEFTSHIFT(U,N); LSH(U,N); COMMENT Definition of MKFIL to handle string file names properly; SYMBOLIC PROCEDURE MKFIL U; %U is an ID or string. Result is a permissible LISP 1.6 filename. BEGIN SCALAR FILE,V,Y,Y1,Z; IF NULL U THEN FILERR U ELSE IF NOT STRINGP U THEN RETURN IF IDP U THEN U ELSE FILERR U; V := EXPLODEC U; A: Z := NEXTELM V; V := CDR Z; Z := CAR Z; IF NULL V THEN NIL ELSE IF CAR V EQ '!: THEN <<FILE := MKFRAG('!: . '!! . Z) . FILE; V := CDR V>> ELSE IF CAR V EQ '!. THEN IF NULL Z THEN FILERR U ELSE <<Y := NEXTELM CDR V; V := CDR Y; FILE := (MKFRAG Z . MKFRAG CAR Y) . FILE; Z := NIL>> ELSE IF CAR V EQ '!< THEN <<Y := NEXTELM CDR V; V := CDR Y; IF NOT EQCAR(V,'!>) THEN FILERR U; FILE := MKFRAG CAR Y . 'DIR!: . FILE; V := CDR V>> ELSE IF CAR V EQ '!> THEN FILERR U ELSE IF CAR V EQ '![ THEN <<Y := NEXTELM CDR V; V := CDR Y; IF NOT EQCAR(V,'!,) THEN FILERR U; Y1 := MKFRAG CAR Y; Y := NEXTELM CDR V; V := CDR Y; IF NOT EQCAR(V,'!]) THEN FILERR U; FILE := LIST(Y1,MKFRAG CAR Y) . FILE; V := CDR V>> ELSE IF CAR V EQ '!, OR CAR V EQ '!] THEN FILERR U; IF V THEN GO TO A ELSE IF Z THEN FILE := MKFRAG Z . IF NULL FILE THEN '(DSK!:) ELSE FILE; RETURN REVERSE FILE END; GLOBAL '(LITERS!*); SYMBOLIC PROCEDURE NEXTELM U; BEGIN SCALAR X,Y; WHILE U AND NOT(CAR U MEMQ '(!. !: !< !> ![ !, !])) DO <<IF LITER CAR U THEN IF Y := ATSOC(CAR U,LITERS!*) THEN X := CDR Y . X ELSE X := CAR U . X ELSE IF DIGIT CAR U THEN X := CAR U . X ELSE X := CAR U . '!! . X; U := CDR U>>; RETURN X . U END; LITERS!* := '((!a . A) (!b . B) (!c . C) (!d . D) (!e . E) (!f . F) (!g . G) (!h . H) (!i . I) (!j . J) (!k . K) (!l . L) (!m . M) (!n . N) (!o . O) (!p . P) (!q . Q) (!r . R) (!s . S) (!t . T) (!u . U) (!v . V) (!w . W) (!x . X) (!y . Y) (!z . Z)); SYMBOLIC PROCEDURE FILERR U; TYPERR(U,"file name"); SYMBOLIC PROCEDURE MKFRAG U; (LAMBDA X; IF NUMBERP X THEN X ELSE INTERN X) COMPRESS REVERSIP U; END; |
Added r30/rend2.fap version [50331b809c].
cannot compute difference between binary files
Added r30/rend2.red version [87fc4bc34b].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT The material in this file introduces extensions or redefinitions of code in the REDUCE source files, and is not really necessary to run a basic system; COMMENT Introduction of Infix Character Strings Peculiar to the PDP-10; PUT(INTERN ASCII 27,'NEWNAM,'!$); PUT(INTERN ASCII 125,'NEWNAM,'!$); PUT('!^,'NEWNAM,'EXPT); COMMENT REDUCE Functions defined in front end for greater efficiency; COMMENT The following routine is used by DETQ; LAP '((TWOMEM EXPR 2) (MOVE C B) (CALL 1 (E NUMVAL)) (EXCH A C) (CALL 1 (E NUMVAL)) (133120 A C) (JUMPE A TAG) (MOVEI A (QUOTE T)) TAG (POPJ P)); FLAG('(TWOMEM),'LOSE); GLOBAL '(TTYPE!* SCNVAL); REMFLAG('(TOKEN),'LOSE); SYMBOLIC PROCEDURE TOKEN; IF NULL IFL!* AND !*INT THEN TOKEN1() ELSE IF (TTYPE!*:=!%SCAN()) = 0 THEN INTERN SCNVAL ELSE IF SCNVAL EQ '!' THEN LIST('QUOTE,RREAD()) ELSE SCNVAL; FLAG('(TOKEN),'LOSE); COMMENT Redefinition of REDUCE IO functions for greater flexibility; %SYMBOLIC PROCEDURE SLREADFN; % BEGIN SCALAR !*MODE,!*SLIN; % !*MODE := 'SYMBOLIC; % !*SLIN := T; % BEGIN1(); % RESETPARSER(); %since SCANSET seems to get set to NIL % END; %PUT('SL,'ACTION,'SLREADFN); PUT('LOAD,'STAT,'RLIS); %to make available as a command; FLAG('(LOAD),'NOFORM); PUT('TR,'STAT,'RLIS); PUT('TRST,'STAT,'RLIS); FLAG('(TR TRST UNTR UNTRST),'IGNORE); COMMENT SIMPFG properties for various flags; PUT('CREF,'SIMPFG,'((T (PROG NIL (FISLM (QUOTE RCREF)) (CREFON))) (NIL (CREFOFF)))); COMMENT Declarations needed for FAP building; %ALG1: FLAG('(CDIF CMINUS CMOD CPLUS CTIMES SETMOD),'LOSE); % FACTOR: FLUID '(LARGEST!-SMALL!-MODULUS); LARGEST!-SMALL!-MODULUS := 2**32; SYMBOLIC PROCEDURE LOGAND2(M,N); BOOLE(1,M,N); SYMBOLIC PROCEDURE LOGOR2(M,N); BOOLE(7,M,N); SYMBOLIC PROCEDURE LOGXOR2(M,N); BOOLE(6,M,N); SYMBOLIC SMACRO PROCEDURE LEFTSHIFT(U,N); LSH(U,N); %RLISP: FLAG('(TOKEN COMMAND ATSOC PRINTPROMPT RESETPARSER),'LOSE); COMMENT redefining COMMAND; GLOBAL '(EDIT!* !*DEMO !*PRET); REMFLAG('(COMMAND),'LOSE); SYMBOLIC PROCEDURE COMMAND; BEGIN SCALAR X,Y; IF !*DEMO AND (X := IFL!*) THEN PROGN(TERPRI(),RDS NIL,READCH(),RDS CDR X); IF EDIT!* THEN EDITLINE() ELSE IF FLG!* THEN GO TO A; IF !*SLIN THEN <<!%NEXTTYI(); KEY!* := SEMIC!* := '!;; CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; X := IF LREADFN!* THEN APPLY(LREADFN!*,NIL) ELSE READ(); IF KEY!* EQ '!; THEN KEY!* := IF ATOM X THEN X ELSE CAR X>> ELSE <<SCAN(); CLOC!* := IF IFL!* THEN CAR IFL!* . PGLINE() ELSE NIL; KEY!* := CURSYM!*; X := XREAD1 NIL>>; IF !*PRET THEN PROGN(TERPRI(),RPRINT X); % IF IFL!*='(DSK!: (INPUT . TMP)) AND % (Y:= PGLINE()) NEQ '(1 . 0) % THEN LPL!*:= Y; %use of IN(noargs); A: IF FLG!* AND IFL!* THEN BEGIN CLOSE CDR IFL!*; IPL!* := DELETE(IFL!*,IPL!*); IF IPL!* THEN RDS CDAR IPL!* ELSE RDS NIL; IFL!* := NIL END; FLG!* := NIL; IF NULL !*SLIN THEN X := FORM X; IF CLOC!* AND NOT ATOM X AND CAR X MEMQ '(DE DF DM) THEN PUT(CADR X,'LOCN,CLOC!*) ELSE IF CLOC!* AND EQCAR(X,'PROGN) AND CDDR X AND NOT ATOM CADDR X AND CAADDR X MEMQ '(DE DF DM) THEN PUT(CADR CADDR X,'LOCN,CLOC!*); RETURN X END; FLAG('(COMMAND),'LOSE); FLUID '(TSLIN!* !*SLIN); SYMBOLIC PROCEDURE RDFNEV(X,Y,Z,U); <<IF (X EQ !*SLIN OR X AND !*SLIN) AND Y EQ LREADFN!* THEN Z:=NIL ELSE <<IF U THEN TSLIN!* := (!*SLIN . LREADFN!*); !*SLIN := X; LREADFN!* := Y>>; IF U THEN EVAL CAR U ELSE Z>>; REMFLAG('(SLISP RLISP),'GO); FEXPR PROCEDURE SLISP U; RDFNEV(T,NIL,"Standard Lisp parsing . . .",U); FEXPR PROCEDURE RLISP U; RDFNEV(NIL,NIL,"Rlisp parsing . . .",U); PUTD('LISP,'FEXPR,CDR GETD 'RLISP); GLOBAL '(!*BACKTRACE); SYMBOLIC PROCEDURE RMOSTAT; BEGIN SCALAR TMODE,X,Y; IF NOT(KEY!* EQ (X:=CURSYM!*)) THEN SYMERR("SYNTAX ERROR",NIL) ELSE IF FLAGP(SCAN(),'DELIM) THEN <<!*MODE:='SYMBOLIC; RETURN LIST X>>; KEY!* := CURSYM!*; TMODE := !*MODE; !*MODE := 'SYMBOLIC; Y := ERRORSET('(XREAD1 NIL),NIL,!*BACKTRACE); !*MODE := TMODE; IF ATOM Y OR CDR Y THEN ERROR(10,NIL); RETURN X . CAR Y END; PUT('RLISP,'STAT,'RMOSTAT); PUT('SLISP,'STAT,'RMOSTAT); FLAG('(SLISP RLISP),'GO); FLAG('(SLISP RLISP),'EVAL); FLAG('(SLISP RLISP),'IGNORE); REMFLAG('(RESETPARSER),'LOSE); SYMBOLIC PROCEDURE RESETPARSER; IF !*SLIN THEN <<RDSLSH NIL; SCANSET T>> ELSE COMM1 T; FLAG('(RESETPARSER),'LOSE); REMFLAG('(OFF),'EVAL); COMMENT fixups for build of REDUCE; %MAPOBL FUNCTION LAMBDA J; % <<REMFLAG(LIST J,'LOSE); REMFLAG(LIST J,'FLUID)>>; FLAG('(!*S!* !*S1!* !*PI!*),'FLUID); REMPROP('U,'VALUE); REMPROP('W,'VALUE); REMPROP('X,'VALUE); REMPROP('Y,'VALUE); IF SYSTEM!*=-1 THEN PUTD('SETSITE,'EXPR,'(LAMBDA NIL NIL)); FLAG('(CORE),'OPFN); COMMENT some global variable initializations; INITFN!* := 'BEGIN; !*GCGAG := NIL; !*INT := T; !*NOUUO := NIL; !*RAISE := T; KLIST := NIL; TMODE!* := NIL; TSLIN!* := NIL; !*BEGIN := NIL; !*COMP := NIL; !*FSLOUT := NIL; COMMENT Some additional constructs for TOPS-10; IF SYSTEM!* EQ 0 THEN <<FLAG('(EXCORE),'OPFN); FISLSIZE := 1500; %big enough for factor; PUT('BFLOAT,'FAPSIZE,7); PUT('COMPLR,'FAPSIZE,6); PUT('FACTOR,'FAPSIZE,27); PUT('FAP,'FAPSIZE,3); PUT('HEPHYS,'FAPSIZE,3); PUT('INT,'FAPSIZE,11); PUT('MATR,'FAPSIZE,2); PUT('RCREF,'FAPSIZE,3); PUT('RPRINT,'FAPSIZE,2); PUT('SOLVE,'FAPSIZE,4)>>; COMMENT The following two functions are only needed for TENEX; IF SYSTEM!* EQ 1 THEN BEGIN PUTD('STDIR,'EXPR,'(LAMBDA (U) (PROG (A) (SETQ A (ERRORSET (LIST 'JSYS 32 0 (MKQUOTE U) 0 1) NIL NIL)) (RETURN (COND ((ATOM A) 0) (T (BOOLE 1 (CAR A) 262143))))))); PUTD('SETSYS!:,'EXPR,'(LAMBDA (U) (SETSYS (STDIR U)))) END; END; |
Added r30/rlisp.fap version [4d2d4335cd].
cannot compute difference between binary files
Added r30/rlisp.red version [7f0b9cc1ed].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | %********************************************************************* %********************************************************************* % THE REDUCE TRANSLATOR %********************************************************************* %********************************************************************; %Copyright (c) 1983 The Rand Corporation; SYMBOLIC; %Most of REDUCE is defined in symbolic mode; %********************************************************************* % NON-LOCAL VARIABLES USED IN TRANSLATOR %********************************************************************; %The following are used as non-local variables in this section; FLUID '(DFPRINT!* LREADFN!* SEMIC!* TSLIN!* !*BACKTRACE !*DEFN !*ECHO !*MODE !*OUTPUT !*RAISE !*SLIN !*TIME); GLOBAL '(BLOCKP!* CMSG!* CRBUFLIS!* CRBUF!* CRBUF1!* EOF!* ERFG!* FNAME!* FTYPES!* INITL!* INPUTBUFLIS!* LETL!* MOD!* OTIME!* OUTL!* PRECLIS!* PROMPTEXP RESULTBUFLIS!* TTYPE!* TYPL!* STATCOUNTER !*NAT NAT!*!* CRCHAR!* CURSYM!* IFL!* IPL!* KEY!* !*FORCE NXTSYM!* OFL!* OPL!* PROGRAM!* PROGRAML!* WS !*FORT TECHO!* !*BLANKNOTOK!* !*COMPOSITES !*CREF !*DEMO !*EXTRAECHO !*INT !*LOSE !*MSG !*PRET !*!*ESC); % These non-local variables divide into two classes. The first %class are those which must be initialized at the top level of the %program. These are as follows; %BLOCKP!* := NIL; %keeps track of which block is active; %CRBUFLIS!* := NIL; %terminal input buffer; %CMSG!* := NIL; %shows that continuation msg has been printed; %DFPRINT!* := NIL; %used to define special output process; %EOF!* := NIL; %flag indicating an end-of-file; %ERFG!* := NIL; %indicates that an input error has occurred; INITL!* := '(BLOCKP!* OUTL!*); %list of variables initialized in BEGIN1; %INPUTBUFLIS!* := NIL; %association list for storing input commands; KEY!* := 'SYMBOLIC; %stores first word read in command; %LETL!* := NIL; %used in algebraic mode for special delimiters; %LREADFN!* := NIL; %used to define special reading function; %MOD!* := NIL; %modular base, NIL for integer arithmetic; %OUTL!* := NIL; %storage for output of input line; PRECLIS!*:= '(OR AND NOT MEMBER MEMQ EQUAL NEQ EQ GEQ GREATERP LEQ LESSP PLUS DIFFERENCE TIMES QUOTIENT EXPT CONS); %precedence list of infix operators; %RESULTBUFLIS!* := NIL; %association list for storing command outputs; STATCOUNTER := 0; %terminal statement counter; %TECHO!* := NIL; %terminal echo status; %TSLIN!* := NIL; %stack of input reading functions; %!*BACKTRACE := NIL; %if ON, prints a LISP backtrace; %!*BLANKNOTOK!* := NIL; %if ON, disables blank as CEDIT character; %!*COMPOSITES := NIL; %used to indicate the use of composite numbers; %!*CREF := NIL; %used by cross-reference program; %!*DEFN := NIL; %indicates that LISP code should be output; %!*ECHO := NIL; %indicates echoing of input; %!*FORCE := NIL; %causes all macros to expand; !*LOSE := T; %determines whether a function flagged LOSE %is defined; %!*MSG:=NIL; %flag to indicate whether messages should be %printed; %!*NAT := NIL; %used in algebraic mode to denote 'natural' %output. Must be on in symbolic mode to %ensure input echoing; %NAT!*!* := NIL; %temporary variable used in algebraic mode; !*OUTPUT := T; %used to suppress output; !*RAISE := T; %causes lower to be converted to upper case; %!*SLIN := NIL; %indicates that LISP code should be read; %!*TIME := NIL; %used to indicate timing should be printed; % The second class are those non-local variables which are %initialized within some function, although they do not appear in that %function's variable list. These are; % CRCHAR!* next character in input line % CURSYM!* current symbol (i. e. identifier, parenthesis, % delimiter, e.t.c,) in input line % FNAME!* name of a procedure being read % FTYPES!* list of regular procedure types % IFL!* input file/channel pair - set in BEGIN to NIL % IPL!* input file list- set in BEGIN to NIL % NXTSYM!* next symbol read in TOKEN % OFL!* output file/channel pair - set in BEGIN to NIL % OPL!* output file list- set in BEGIN to NIL % PROGRAM!* current input program % PROGRAML!* stores input program when error occurs for a % later restart % PROMPTEXP expression used for command prompt % SEMIC!* current delimiter character (used to decide % whether to print result of calculation) % TTYPE!* current token type % WS used in algebraic mode to store top level value % !*FORT used in algebraic mode to denote FORTRAN output % !*INT indicates interactive system use % !*MODE current mode of calculation % !*PRET indicates REDUCE prettyprinting of input; COMMENT THE FOLLOWING IS USED AS A FLUID VARIABLE; FLUID '(!*S!*); %********************************************************************* % GO TO STATEMENT %********************************************************************; % It is necessary to introduce the GO TO statement at this %point as part of the boot-strapping process. A general description %of the method of statement implementation is given later; SYMBOLIC PROCEDURE GOSTAT; BEGIN SCALAR VAR; VAR := IF EQ(SCAN(),'TO) THEN SCAN() ELSE CURSYM!*; SCAN(); RETURN LIST('GO,VAR) END; PUT('GO,'STAT,'GOSTAT); PUT('GOTO,'NEWNAM,'GO); %********************************************************************* % INITIALIZATION OF INFIX OPERATORS %********************************************************************; % Several operators in REDUCE are used in an infix form (e.g., %+,- ). The internal alphanumeric names associated with these %operators are introduced by the function NEWTOK defined below. %This association, and the precedence of each infix operator, is %initialized in this section. We also associate printing characters %with each internal alphanumeric name as well; DEFLIST ('( (NOT NOT) (PLUS PLUS) (DIFFERENCE MINUS) (MINUS MINUS) (TIMES TIMES) (QUOTIENT RECIP) (RECIP RECIP) ), 'UNARY); FLAG ('(AND OR !*COMMA!* PLUS TIMES),'NARY); FLAG ('(CONS SETQ PLUS TIMES),'RIGHT); DEFLIST ('((MINUS PLUS) (RECIP TIMES)),'ALT); SYMBOLIC PROCEDURE MKPREC; BEGIN SCALAR X,Y,Z; X := '!*COMMA!* . ('SETQ . PRECLIS!*); Y := 1; A: IF NULL X THEN RETURN NIL; PUT(CAR X,'INFIX,Y); PUT(CAR X,'OP,LIST LIST(Y,Y)); %for RPRINT; IF Z := GET(CAR X,'UNARY) THEN PUT(Z,'INFIX,Y); IF AND(Z,NULL FLAGP(Z,'NARY)) THEN PUT(Z,'OP,LIST(NIL,Y)); X := CDR X; Y := ADD1 Y; GO TO A END; MKPREC(); SYMBOLIC PROCEDURE ATSOC(U,V); IF NULL V THEN NIL ELSE IF U EQ CAAR V THEN CAR V ELSE ATSOC(U,CDR V); SYMBOLIC PROCEDURE CONSESCC U; IF NULL U THEN NIL ELSE '!! . CAR U . CONSESCC CDR U; SYMBOLIC PROCEDURE LSTCHR(U,V); IF NULL CDR U THEN CAR U . (NIL . V) ELSE LIST(CAR U,LIST LSTCHR(CDR U,V)); SYMBOLIC PROCEDURE NEWTOK U; BEGIN SCALAR V,X,Y,Z; V := CDR U; U := CAR U; Y := U; IF NULL(X:= GET(CAR Y,'SWITCH!*)) THEN GO TO D; Y := CDR Y; A: IF NULL Y THEN GO TO E ELSE IF NULL CAR X THEN PROGN(RPLACA(X,LIST LSTCHR(Y,V)),GO TO C) ELSE IF NULL(Z := ATSOC(CAR Y,CAR X)) THEN GO TO B1; B: Y := CDR Y; X := CDR Z; GO TO A; B1: RPLACA(X,APPEND(CAR X,LIST LSTCHR(Y,V))); C: X := INTERN COMPRESS CONSESCC U; IF CDR V THEN IF CDDR V THEN Y:= LIST(CADR V,CADDR V) ELSE Y:= LIST(CADR V,X) ELSE Y:= LIST(X,X); %the print list; PUT(CAR V,'PRTCH,Y); IF X := GET(CAR V,'UNARY) THEN PUT(X,'PRTCH,Y); RETURN NIL; D: PUT(CAR Y,'SWITCH!*,CDR LSTCHR(Y,V)); GO TO C; E: IF !*MSG THEN LPRIM LIST(COMPRESS CONSESCC U,"redefined"); %test on MSG is for bootstrapping purposes; RPLACD(X,V); GO TO C END; NEWTOK '((!$) !*SEMICOL!*); NEWTOK '((!;) !*SEMICOL!*); NEWTOK '((!+) PLUS ! !+! ); NEWTOK '((!-) DIFFERENCE ! !-! ); NEWTOK '((!*) TIMES); NEWTOK '((!* !*) EXPT); NEWTOK '((!/) QUOTIENT); NEWTOK '((!=) EQUAL); NEWTOK '((!,) !*COMMA!*); NEWTOK '((!() !*LPAR!*); NEWTOK '((!)) !*RPAR!*); NEWTOK '((!:) !*COLON!*); NEWTOK '((!: !=) SETQ ! !:!=! ); NEWTOK '((!.) CONS); NEWTOK '((!<) LESSP); NEWTOK '((!< !=) LEQ); NEWTOK '((!< !<) !*LSQB!*); NEWTOK '((!>) GREATERP); NEWTOK '((!> !=) GEQ); NEWTOK '((!> !>) !*RSQB!*); FLAG('(NEWTOK),'EVAL); %********************************************************************* % REDUCE SUPERVISOR %********************************************************************; % The true REDUCE supervisory function is BEGIN, again defined in %the system dependent part of this program. However, most of the work %is done by BEGIN1, which is called by BEGIN for every file %encountered on input; SYMBOLIC PROCEDURE ERRORP U; %returns true if U is an ERRORSET error format; ATOM U OR CDR U; SYMBOLIC PROCEDURE FLAGP!*!*(U,V); IDP U AND FLAGP(U,V); SYMBOLIC PROCEDURE PRINTPROMPT U; %Prints the prompt expression for input; PROGN(IF OFL!* THEN WRS NIL, PRIN2 U, IF OFL!* THEN WRS CDR OFL!*); SYMBOLIC PROCEDURE BEGIN1; BEGIN SCALAR MODE,PARSERR,RESULT; A0: CURSYM!* := '!*SEMICOL!*; OTIME!* := TIME(); A: IF NULL TERMINALP() THEN GO TO A2 ELSE IF STATCOUNTER>0 THEN ADD2BUFLIS(); STATCOUNTER := STATCOUNTER + 1; PROMPTEXP := COMPRESS('!! . APPEND(EXPLODE STATCOUNTER,EXPLODE '!:! )); SETPCHAR PROMPTEXP; A2: PARSERR := NIL; IF !*TIME THEN EVAL '(SHOWTIME); %Since a STAT; IF !*OUTPUT AND NULL OFL!* AND TERMINALP() AND NULL !*DEFN THEN TERPRI(); IF TSLIN!* THEN PROGN(!*SLIN := CAR TSLIN!*, LREADFN!* := CDR TSLIN!*, TSLIN!* := NIL); MAPCAR(INITL!*,FUNCTION SINITL); IF !*INT THEN ERFG!* := NIL; %to make editing work properly; IF CURSYM!* EQ 'END THEN GO TO ND0; IF TERMINALP() AND NULL(KEY!* EQ 'ED) THEN PRINTPROMPT PROMPTEXP; PROGRAM!* := ERRORSET('(COMMAND),T,!*BACKTRACE); CONDTERPRI(); IF ERRORP PROGRAM!* THEN GO TO ERR1; PROGRAM!* := CAR PROGRAM!*; IF PROGRAM!* EQ !$EOF!$ AND TTYPE!*=3 THEN GO TO ND1 ELSE IF CURSYM!* EQ 'END THEN GO TO ND0 ELSE IF EQCAR(PROGRAM!*,'RETRY) THEN PROGRAM!* := PROGRAML!* ELSE IF PROGRAM!* EQ 'ED AND GETD 'CEDIT THEN PROGN(CEDIT NIL,GO TO A2) ELSE IF EQCAR(PROGRAM!*,'ED) AND GETD 'CEDIT THEN PROGN(CEDIT CDR PROGRAM!*,GO TO A2); %The following section decides what the target mode should be. %That mode is also assumed to be the printing mode; IF IDP KEY!* AND GET(KEY!*,'STAT) EQ 'MODESTAT THEN MODE := KEY!* ELSE IF NULL ATOM PROGRAM!* AND NULL(CAR PROGRAM!* EQ 'QUOTE) AND (NULL(IDP CAR PROGRAM!* AND (FLAGP(CAR PROGRAM!*,'NOCHANGE) OR FLAGP(CAR PROGRAM!*,'INTFN) OR CAR PROGRAM!* EQ 'LIST)) OR CAR PROGRAM!* MEMQ '(SETQ SETEL) AND EQCAR(CADDR PROGRAM!*,'QUOTE)) THEN MODE := 'SYMBOLIC ELSE MODE := !*MODE; PROGRAM!* := CONVERTMODE1(PROGRAM!*,NIL,'SYMBOLIC,MODE); ADD2INPUTBUF PROGRAM!*; IF !*DEFN THEN GO TO D; B: IF !*OUTPUT AND IFL!* AND !*ECHO THEN TERPRI(); RESULT := ERRORSET(PROGRAM!*,T,!*BACKTRACE); IF ERRORP RESULT OR ERFG!* THEN PROG2(PROGRAML!* := PROGRAM!*,GO TO ERR2) ELSE IF !*DEFN THEN GO TO A; RESULT := CAR RESULT; IF NULL(MODE EQ 'SYMBOLIC) AND RESULT THEN ADD2RESULTBUF RESULT; C: IF NULL !*OUTPUT THEN GO TO A ELSE IF SEMIC!* EQ '!; THEN IF MODE EQ 'SYMBOLIC THEN IF NULL RESULT AND NULL(!*MODE EQ 'SYMBOLIC) THEN NIL ELSE BEGIN TERPRI(); PRINT RESULT END ELSE IF RESULT THEN VARPRI(RESULT,SETVARS PROGRAM!*,'ONLY); GO TO A; D: IF ERFG!* THEN GO TO A ELSE IF FLAGP!*!*(KEY!*,'IGNORE) OR EQCAR(PROGRAM!*,'QUOTE) THEN GO TO B; IF PROGRAM!* THEN DFPRINT PROGRAM!*; IF FLAGP!*!*(KEY!*,'EVAL) THEN GO TO B ELSE GO TO A; ND0:COMM1 'END; ND1: EOF!* := NIL; IF NULL IPL!* %terminal END; THEN BEGIN IF OFL!* THEN PROGN(WRS NIL,OFL!* := NIL); AA: IF NULL OPL!* THEN RETURN NIL; CLOSE CDAR OPL!*; OPL!* := CDR OPL!*; GO TO AA END; RETURN NIL; ERR1: IF EOF!* OR PROGRAM!* EQ !$EOF!$ AND TTYPE!*=3 THEN GO TO ND1 ELSE IF PROGRAM!* EQ "BEGIN invalid" THEN GO TO A ELSE IF PROGRAM!* EQ !*!*ESC AND TTYPE!*=3 THEN GO TO A0; PARSERR := T; ERR2: RESETPARSER(); %in case parser needs to be modified; ERFG!* := T; IF NULL !*INT THEN GO TO E; RESULT := PAUSE1 PARSERR; IF RESULT THEN RETURN NULL EVAL RESULT; ERFG!* := NIL; GO TO A; E: !*DEFN := T; %continue syntax analyzing but not evaluation; !*ECHO := T; IF NULL CMSG!* THEN LPRIE "Continuing with parsing only ..."; CMSG!* := T; GO TO A END; SYMBOLIC PROCEDURE ADD2BUFLIS; BEGIN CRBUF!* := REVERSIP CRBUF!*; %put in right order; A: IF CAR CRBUF!* EQ !$EOL!$ OR (!*BLANKNOTOK!* AND CAR CRBUF!* EQ '! ) THEN PROG2(CRBUF!* := CDR CRBUF!*, GO TO A); CRBUFLIS!* := (STATCOUNTER . CRBUF!*) . CRBUFLIS!*; CRBUF!* := NIL END; SYMBOLIC PROCEDURE ADD2INPUTBUF U; BEGIN IF TERMINALP() THEN INPUTBUFLIS!* := (STATCOUNTER . U) . INPUTBUFLIS!* END; SYMBOLIC PROCEDURE ADD2RESULTBUF U; BEGIN WS := U; IF TERMINALP() THEN RESULTBUFLIS!* := (STATCOUNTER . U) . RESULTBUFLIS!* END; SYMBOLIC PROCEDURE CONDTERPRI; !*OUTPUT AND !*ECHO AND !*EXTRAECHO AND (NULL !*INT OR IFL!*) AND NULL !*DEFN AND TERPRI(); SYMBOLIC PROCEDURE RESETPARSER; %resets the parser after an error; IF NULL !*SLIN THEN COMM1 T; SYMBOLIC PROCEDURE SETVARS U; IF ATOM U THEN NIL ELSE IF CAR U MEMQ '(SETEL SETK) THEN CADR U . SETVARS CADDR U ELSE IF CAR U EQ 'SETQ THEN MKQUOTE CADR U . SETVARS CADDR U ELSE NIL; SYMBOLIC PROCEDURE TERMINALP; %true if input is coming from an interactive terminal; !*INT AND NULL IFL!*; SYMBOLIC PROCEDURE DFPRINT U; %Looks for special action on a form, otherwise prettyprints it; IF DFPRINT!* THEN APPLY(DFPRINT!*,LIST U) ELSE IF CMSG!* THEN NIL ELSE IF NULL EQCAR(U,'PROGN) THEN PRETTYPRINT U ELSE BEGIN A: U := CDR U; IF NULL U THEN RETURN NIL; DFPRINT CAR U; GO TO A END; SYMBOLIC PROCEDURE SHOWTIME; BEGIN SCALAR X; X := OTIME!*; OTIME!* := TIME(); X := OTIME!*-X; % IF NULL TERMINALP() THEN TERPRI(); TERPRI(); PRIN2 "TIME: "; PRIN2 X; PRIN2T " MS"; % IF TERMINALP() THEN TERPRI(); END; SYMBOLIC PROCEDURE SINITL U; SET(U,GET(U,'INITL)); FLAG ('(IN OUT ON OFF SHUT),'IGNORE); %********************************************************************* % IDENTIFIER AND RESERVED CHARACTER READING %********************************************************************; % The function TOKEN defined below is used for reading %identifiers and reserved characters (such as parentheses and infix %operators). It is called by the function SCAN, which translates %reserved characters into their internal name, and sets up the output %of the input line. The following definitions of TOKEN and SCAN are %quite general, but also inefficient. THE READING PROCESS CAN OFTEN %BE SPEEDED UP BY A FACTOR OF AS MUCH AS FIVE IF THESE FUNCTIONS %(ESPECIALLY TOKEN) ARE CODED IN ASSEMBLY LANGUAGE; SYMBOLIC PROCEDURE PRIN2X U; OUTL!*:=U . OUTL!*; SYMBOLIC PROCEDURE MKQUOTE U; LIST('QUOTE,U); SYMBOLIC PROCEDURE REVERSIP U; BEGIN SCALAR X,Y; A: IF NULL U THEN RETURN Y; X := CDR U; Y := RPLACD(U,Y); U := X; GO TO A END; SYMBOLIC PROCEDURE MKSTRNG U; %converts the uninterned id U into a string; %if strings are not constants, this should be replaced by %LIST('STRING,U); U; CRCHAR!* := '! ; SYMBOLIC PROCEDURE READCH1; BEGIN SCALAR X; IF NULL TERMINALP() THEN RETURN READCH() ELSE IF CRBUF1!* THEN BEGIN X := CAR CRBUF1!*; CRBUF1!* := CDR CRBUF1!* END ELSE X := READCH(); CRBUF!* := X . CRBUF!*; RETURN X END; SYMBOLIC PROCEDURE TOKEN1; BEGIN SCALAR X,Y,Z; X := CRCHAR!*; A: IF SEPRP X THEN GO TO SEPR ELSE IF DIGIT X THEN GO TO NUMBER ELSE IF LITER X THEN GO TO LETTER ELSE IF X EQ '!% THEN GO TO COMENT ELSE IF X EQ '!! THEN GO TO ESCAPE ELSE IF X EQ '!' THEN GO TO QUOTE ELSE IF X EQ '!" THEN GO TO STRING; TTYPE!* := 3; IF X EQ !$EOF!$ THEN GO TO EOF; NXTSYM!* := X; IF DELCP X THEN GO TO D; A1: CRCHAR!* := READCH1(); GO TO C; ESCAPE: Z := !*RAISE; !*RAISE := NIL; Y := X . Y; X := READCH1(); !*RAISE := Z; LETTER: TTYPE!* := 0; LET1: Y := X . Y; IF DIGIT (X := READCH1()) OR LITER X THEN GO TO LET1 ELSE IF X EQ '!! THEN GO TO ESCAPE; NXTSYM!* := INTERN COMPRESS REVERSIP Y; B: CRCHAR!* := X; C: RETURN NXTSYM!*; NUMBER: TTYPE!* := 2; NUM1: Y := X . Y; Z := X; IF DIGIT (X := READCH1()) OR X EQ '!. OR X EQ 'E OR Z EQ 'E THEN GO TO NUM1; NXTSYM!* := COMPRESS REVERSIP Y; GO TO B; QUOTE: CRCHAR!* := READCH1(); NXTSYM!* := MKQUOTE RREAD(); TTYPE!* := 4; GO TO C; STRING: Z := !*RAISE; !*RAISE := NIL; STRINX: Y := X . Y; IF NULL((X := READCH1()) EQ '!") THEN GO TO STRINX; Y := X . Y; NXTSYM!* := MKSTRNG COMPRESS REVERSIP Y; !*RAISE := Z; TTYPE!* := 1; GO TO A1; COMENT: IF NULL(READCH1() EQ !$EOL!$) THEN GO TO COMENT; SEPR: X := READCH1(); GO TO A; D: CRCHAR!* := '! ; GO TO C; EOF:CRCHAR!* := '! ; FILENDERR() END; SYMBOLIC PROCEDURE TOKEN; %This provides a hook for a faster TOKEN; TOKEN1(); SYMBOLIC PROCEDURE FILENDERR; BEGIN EOF!* := T; ERROR(99,IF IFL!* THEN LIST("EOF read in file",CAR IFL!*) ELSE LIST "EOF read") END; SYMBOLIC PROCEDURE PTOKEN; BEGIN SCALAR X; X := TOKEN(); IF X EQ '!) AND EQCAR(OUTL!*,'! ) THEN OUTL!*:= CDR OUTL!*; %an explicit reference to OUTL!* used here; PRIN2X X; IF NULL ((X EQ '!() OR (X EQ '!))) THEN PRIN2X '! ; RETURN X END; SYMBOLIC PROCEDURE RREAD1; BEGIN SCALAR X,Y; X := PTOKEN(); IF NULL (TTYPE!*=3) THEN RETURN X ELSE IF X EQ '!( THEN RETURN RRDLS() ELSE IF NULL (X EQ '!+ OR X EQ '!-) THEN RETURN X; Y := PTOKEN(); IF NULL NUMBERP Y THEN PROGN(NXTSYM!* := " ", SYMERR("Syntax error: improper number",NIL)) ELSE IF X EQ '!- THEN Y := APPLY('MINUS,LIST Y); %we need this construct for bootstrapping purposes; RETURN Y END; SYMBOLIC PROCEDURE RRDLS; BEGIN SCALAR X,Y; X := RREAD1(); IF NULL (TTYPE!*=3) THEN GO TO A ELSE IF X EQ '!) THEN RETURN NIL ELSE IF NULL (X EQ '!.) THEN GO TO A; X := RREAD1(); Y := PTOKEN(); IF NULL (TTYPE!*=3) OR NULL (Y EQ '!)) THEN PROGN(NXTSYM!* := " ",SYMERR("Invalid S-expression",NIL)) ELSE RETURN X; A: RETURN (X . RRDLS()) END; SYMBOLIC PROCEDURE RREAD; PROGN(PRIN2X " '",RREAD1()); SYMBOLIC PROCEDURE SCAN; BEGIN SCALAR X,Y; IF NULL (CURSYM!* EQ '!*SEMICOL!*) THEN GO TO B; A: NXTSYM!* := TOKEN(); B: IF NULL ATOM NXTSYM!* THEN GO TO Q1 ELSE IF NXTSYM!* EQ 'ELSE OR CURSYM!* EQ '!*SEMICOL!* THEN OUTL!* := NIL; PRIN2X NXTSYM!*; C: IF NULL IDP NXTSYM!* THEN GO TO L ELSE IF (X:=GET(NXTSYM!*,'NEWNAM)) AND (NULL (X=NXTSYM!*)) THEN GO TO NEW ELSE IF NXTSYM!* EQ 'COMMENT OR NXTSYM!* EQ '!% AND TTYPE!*=3 THEN GO TO COMM ELSE IF NULL(TTYPE!* = 3) THEN GO TO L ELSE IF NXTSYM!* EQ !*!*ESC THEN ERROR(9999,!*!*ESC) ELSE IF NXTSYM!* EQ !$EOF!$ THEN RETURN FILENDERR() ELSE IF NXTSYM!* EQ '!' THEN GO TO QUOTE ELSE IF NULL (X:= GET(NXTSYM!*,'SWITCH!*)) THEN GO TO L ELSE IF CADR X EQ '!*SEMICOL!* THEN GO TO DELIM; SW1: NXTSYM!* := TOKEN(); IF NULL(TTYPE!* = 3) THEN GO TO SW2 ELSE IF NXTSYM!* EQ !$EOF!$ THEN RETURN FILENDERR() ELSE IF CAR X THEN GO TO SW3; SW2: CURSYM!*:=CADR X; IF CURSYM!* EQ '!*RPAR!* THEN GO TO L2 ELSE RETURN CURSYM!*; SW3: IF NULL (Y:= ATSOC(NXTSYM!*,CAR X)) THEN GO TO SW2; PRIN2X NXTSYM!*; X := CDR Y; GO TO SW1; COMM: IF DELCP CRCHAR!* THEN GO TO COM1; CRCHAR!* := READCH(); GO TO COMM; COM1: CRCHAR!* := '! ; CONDTERPRI(); GO TO A; DELIM: SEMIC!*:=NXTSYM!*; RETURN (CURSYM!*:='!*SEMICOL!*); NEW: NXTSYM!* := X; IF STRINGP X THEN GO TO L ELSE IF ATOM X THEN GO TO C ELSE GO TO L; QUOTE: NXTSYM!* := MKQUOTE RREAD1(); GO TO L; Q1: IF NULL (CAR NXTSYM!* EQ 'STRING) THEN GO TO L; PRIN2X " "; PRIN2X CADR(NXTSYM!* := MKQUOTE CADR NXTSYM!*); L: CURSYM!*:=NXTSYM!*; L1: NXTSYM!* := TOKEN(); IF NXTSYM!* EQ !$EOF!$ AND TTYPE!* = 3 THEN RETURN FILENDERR(); L2: IF NUMBERP NXTSYM!* OR (ATOM NXTSYM!* AND NULL GET(NXTSYM!*,'SWITCH!*)) THEN PRIN2X " "; RETURN CURSYM!*; EOF: FILENDERR() END; %********************************************************************* % EXPRESSION READING %********************************************************************; % The conversion of a REDUCE expression to LISP prefix form is %carried out by the function XREAD. This function initiates the %scanning process, and then calls the auxiliary function XREAD1 to %perform the actual parsing. Both XREAD and XREAD1 are used by many %functions whenever an expression must be read; FLAG ('(END !*COLON!* !*SEMICOL!*),'DELIM); SYMBOLIC PROCEDURE EQCAR(U,V); NULL ATOM U AND CAR U EQ V; SYMBOLIC PROCEDURE MKSETQ(U,V); LIST('SETQ,U,V); SYMBOLIC PROCEDURE MKVAR(U,V); U; SYMBOLIC PROCEDURE REMCOMMA U; IF EQCAR(U,'!*COMMA!*) THEN CDR U ELSE LIST U; SYMBOLIC PROCEDURE ARRAYP U; GET(U,'ARRAY); SYMBOLIC PROCEDURE GETTYPE U; %it might be better to use a table here for more generality; IF NULL ATOM U THEN 'FORM ELSE IF NUMBERP U THEN 'NUMBER ELSE IF ARRAYP U THEN 'ARRAY ELSE IF GET(U,'SIMPFN) OR GET(U,'MSIMPFN) THEN 'OPERATOR ELSE IF GET(U,'AVALUE) THEN 'VARIABLE ELSE IF GETD U THEN 'PROCEDURE ELSE IF GLOBALP U THEN 'GLOBAL ELSE IF FLUIDP U THEN 'FLUID ELSE IF GET(U,'MATRIX) THEN 'MATRIX ELSE IF FLAGP(U,'PARM) THEN 'PARAMETER ELSE NIL; SYMBOLIC PROCEDURE XREAD1 U; BEGIN SCALAR V,W,X,Y,Z,Z1,Z2; % V: EXPRESSION BEING BUILT % W: PREFIX OPERATOR STACK % X: INFIX OPERATOR STACK % Y: INFIX VALUE OR STAT PROPERTY % Z: CURRENT SYMBOL % Z1: NEXT SYMBOL % Z2: TEMPORARY STORAGE; A: Z := CURSYM!*; A1: IF NULL IDP Z THEN NIL ELSE IF Z EQ '!*LPAR!* THEN GO TO LPAREN ELSE IF Z EQ '!*RPAR!* THEN GO TO RPAREN ELSE IF Y := GET(Z,'INFIX) THEN GO TO INFX ELSE IF NXTSYM!* EQ '!: THEN NIL ELSE IF FLAGP(Z,'DELIM) THEN GO TO DELIMIT ELSE IF Y := GET(Z,'STAT) THEN GO TO STAT; A2: Y := NIL; A3: W := Z . W; NEXT: Z := SCAN(); GO TO A1; LPAREN: Y := NIL; IF SCAN() EQ '!*RPAR!* THEN GO TO LP1; %function of no args; Z := XREAD1 IF EQCAR(W,'MAT) THEN PROGN(TYPL!* := UNION('(MATP),TYPL!*),'MAT) ELSE 'PAREN; IF U EQ 'MAT THEN GO TO LP2 ELSE IF NULL EQCAR(Z,'!*COMMA!*) THEN GO TO A3 ELSE IF NULL W THEN (IF U EQ 'LAMBDA THEN GO TO A3 ELSE SYMERR("Improper delimiter",NIL)) ELSE W := (CAR W . CDR Z) . CDR W; GO TO NEXT; LP1: IF W THEN W := LIST CAR W . CDR W; %function of no args; GO TO NEXT; LP2: Z := REMCOMMA Z; GO TO A3; RPAREN: IF NULL U OR U EQ 'GROUP OR U EQ 'PROC THEN SYMERR("Too many right parentheses",NIL) ELSE GO TO END1; INFX: IF Z EQ '!*COMMA!* OR NULL ATOM (Z1 := SCAN()) OR NUMBERP Z1 THEN GO TO IN1 ELSE IF Z1 EQ '!*RPAR!*%infix operator used as variable; OR Z1 EQ '!*COMMA!* OR FLAGP(Z1,'DELIM) THEN GO TO IN2 ELSE IF Z1 EQ '!*LPAR!*%infix operator in prefix position; AND NULL ATOM(Z1 := XREAD 'PAREN) AND CAR Z1 EQ '!*COMMA!* AND (Z := Z . CDR Z1) THEN GO TO A1; IN1: IF W THEN GO TO UNWIND ELSE IF NULL(Z := GET(Z,'UNARY)) THEN SYMERR("Redundant operator",NIL); V := '!*!*UN!*!* . V; GO TO PR1; IN2: Y := NIL; W := Z . W; IN3: Z := Z1; GO TO A1; UNWIND: Z2 := MKVAR(CAR W,Z); UN1: W:= CDR W; IF NULL W THEN GO TO UN2 ELSE IF NUMBERP CAR W THEN SYMERR("Missing Operator",NIL); Z2 := LIST(CAR W,Z2); GO TO UN1; UN2: V:= Z2 . V; PRECED: IF NULL X THEN IF Y=0 THEN GO TO END2 ELSE NIL ELSE IF Y<CAAR X OR (Y=CAAR X AND ((Z EQ CDAR X AND NULL FLAGP(Z,'NARY) AND NULL FLAGP(Z,'RIGHT)) OR GET(CDAR X,'ALT))) THEN GO TO PR2; PR1: X:= (Y . Z) . X; IF NULL(Z EQ '!*COMMA!*) THEN GO TO IN3 ELSE IF CDR X OR NULL U OR U MEMQ '(LAMBDA MAT PAREN) THEN GO TO NEXT ELSE GO TO END2; PR2: %IF CDAR X EQ 'SETQ THEN GO TO ASSIGN ELSE; IF CADR V EQ '!*!*UN!*!* THEN (IF CAR V EQ '!*!*UN!*!* THEN GO TO PR1 ELSE Z2 := LIST(CDAR X,CAR V)) ELSE Z2 := CDAR X . IF EQCAR(CAR V,CDAR X) AND FLAGP(CDAR X,'NARY) THEN (CADR V . CDAR V) ELSE LIST(CADR V,CAR V); X:= CDR X; V := Z2 . CDDR V; GO TO PRECED; STAT: IF NULL(FLAGP(Z,'GO) OR NULL(U EQ 'PROC) AND (FLAGP(Y,'ENDSTAT) OR (NULL DELCP NXTSYM!* AND NULL (NXTSYM!* EQ '!,)))) THEN GO TO A2; W := APPLY(Y,NIL) . W; Y := NIL; GO TO A; DELIMIT: IF Z EQ '!*COLON!* AND NULL(U EQ 'FOR) AND (NULL BLOCKP!* OR NULL W OR NULL ATOM CAR W OR CDR W) OR FLAGP(Z,'NODEL) AND (NULL U OR U EQ 'GROUP AND NULL Z EQ '!*RSQB!*) THEN SYMERR("Improper delimiter",NIL) ELSE IF U MEMQ '(MAT PAREN) THEN SYMERR("Too few right parentheses",NIL); END1: IF Y THEN SYMERR("Improper delimiter",NIL) ELSE IF NULL V AND NULL W AND NULL X THEN RETURN NIL; Y := 0; GO TO UNWIND; END2: IF NULL CDR V THEN RETURN CAR V ELSE SYMERR("Improper delimiter",NIL) END; %SYMBOLIC PROCEDURE GETELS U; % GETEL(CAR U . !*EVLIS CDR U); %SYMBOLIC PROCEDURE !*EVLIS U; % MAPCAR(U,FUNCTION EVAL); FLAG ('(ENDSTAT MODESTAT RETSTAT),'ENDSTAT); FLAG ('(ELSE UNTIL),'NODEL); FLAG ('(BEGIN),'GO); SYMBOLIC PROCEDURE XREAD U; PROGN(SCAN(),XREAD1 U); FLAG('(XREAD),'OPFN); %to make it an operator; SYMBOLIC PROCEDURE COMMAND; BEGIN SCALAR X; IF !*DEMO AND (X := IFL!*) THEN PROGN(TERPRI(),RDS NIL,READCH(),RDS CDR X); IF NULL !*SLIN THEN PROGN(SCAN(),KEY!* := CURSYM!*,X := XREAD1 NIL) ELSE PROGN(KEY!* := (SEMIC!* := '!;), X := IF LREADFN!* THEN APPLY(LREADFN!*,NIL) ELSE READ(), IF KEY!* EQ '!; THEN KEY!* := IF ATOM X THEN X ELSE CAR X); IF !*PRET THEN PROGN(TERPRI(),RPRINT X); IF NULL !*SLIN THEN X := FORM X; RETURN X END; FLAG ('(DEFLIST FLAG FLUID GLOBAL REMFLAG REMPROP UNFLUID),'EVAL); %********************************************************************* % GENERAL FUNCTIONS %********************************************************************; SYMBOLIC PROCEDURE ACONC(U,V); %adds element V to the tail of U. U is destroyed in process; NCONC(U,LIST V); SYMBOLIC PROCEDURE PRIN2T U; PROGN(PRIN2 U, TERPRI(), U); SYMBOLIC PROCEDURE UNION(X,Y); IF NULL X THEN Y ELSE UNION(CDR X,IF CAR X MEMBER Y THEN Y ELSE CAR X . Y); SYMBOLIC PROCEDURE XN(U,V); IF NULL U THEN NIL ELSE IF CAR U MEMBER V THEN CAR U . XN(CDR U,DELETE(CAR U,V)) ELSE XN(CDR U,V); SYMBOLIC PROCEDURE U>=V; NOT(U<V); SYMBOLIC PROCEDURE U<=V; NOT(U>V); SYMBOLIC PROCEDURE U NEQ V; NOT(U=V); %********************************************************************* % FUNCTIONS FOR PRINTING DIAGNOSTIC AND ERROR MESSAGES %********************************************************************; SYMBOLIC PROCEDURE LPRI U; BEGIN A: IF NULL U THEN RETURN NIL; PRIN2 CAR U; PRIN2 " "; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE LPRIW (U,V); BEGIN SCALAR X; U := U . IF V AND ATOM V THEN LIST V ELSE V; IF OFL!* AND (!*FORT OR NOT !*NAT OR !*DEFN) THEN GO TO C; TERPRI(); A: LPRI U; TERPRI(); IF NULL X THEN GO TO B; WRS CDR X; RETURN NIL; B: IF NULL OFL!* THEN RETURN NIL; C: X := OFL!*; WRS NIL; GO TO A END; SYMBOLIC PROCEDURE LPRIM U; !*MSG AND LPRIW("***",U); SYMBOLIC PROCEDURE LPRIE U; BEGIN SCALAR X; IF !*INT THEN GO TO A; X:= !*DEFN; !*DEFN := NIL; A: ERFG!* := T; LPRIW ("*****",U); IF NULL !*INT THEN !*DEFN := X END; SYMBOLIC PROCEDURE PRINTTY U; BEGIN SCALAR OFL; IF NULL !*FORT AND !*NAT THEN PRINT U; IF NULL OFL!* THEN RETURN NIL; OFL := OFL!*; WRS NIL; PRINT U; WRS CDR OFL END; SYMBOLIC PROCEDURE REDERR U; BEGIN LPRIE U; ERROR1() END; FLAG('(REDERR),'OPFN); SYMBOLIC PROCEDURE SYMERR(U,V); BEGIN SCALAR X; ERFG!* := T; IF NUMBERP CURSYM!* OR NOT(X := GET(CURSYM!*,'PRTCH)) THEN X := CURSYM!* ELSE X := CAR X; TERPRI(); IF !*ECHO THEN TERPRI(); OUTL!*:=CAR OUTL!* . '!$!$!$ . CDR OUTL!*; COMM1 T; MAPCAR(REVERSIP OUTL!*,FUNCTION PRIN2); TERPRI(); OUTL!* := NIL; IF NULL V THEN REDERR U ELSE REDERR(X . ("invalid" . (IF U THEN LIST("in",U,"statement") ELSE NIL))) END; SYMBOLIC PROCEDURE TYPERR(U,V); REDERR LIST(U,"invalid as",V); %********************************************************************* % STATEMENTS %********************************************************************; % With the exception of assignment statements, which are %handled by XREAD, statements in REDUCE are introduced by a key-word, %which initiates a reading process peculiar to that statement. The %key-word is recognized (in XREAD1) by the indicator STAT on its %property list. The corresponding property is the name of the %function (of no arguments) which carries out the reading sequence. We %begin by introducing several statements which are necessary in a %basic system. Later on, we introduce statements which are part of the %complete system, but may be omitted if the corresponding %constructions are not required. % System users may add new statements to REDUCE by putting the %name of the statement reading function on the property list of the %new key-word with the indicator STAT. The reading function could be %defined as a new function or be a function already in the system. %Several applications only require that the arguments be grouped %together and quoted (such as IN, OUT, etc). To help with this, the %following two general statement reading functions are available. They %are used in this translator by ARRAY defined later. The function RLIS %reads a list of arguments and returns it as one argument; SYMBOLIC PROCEDURE RLIS; BEGIN SCALAR X; X := CURSYM!*; RETURN IF FLAGP!*!*(SCAN(),'DELIM) THEN LIST(X,NIL) ELSE X . REMCOMMA XREAD1 'LAMBDA END; SYMBOLIC PROCEDURE FLAGOP U; BEGIN FLAG(U,'FLAGOP); RLISTAT U END; SYMBOLIC PROCEDURE RLISTAT U; BEGIN A: IF NULL U THEN RETURN NIL; PUT(CAR U,'STAT,'RLIS); U := CDR U; GO TO A END; RLISTAT '(FLAGOP); %********************************************************************* % COMMENTS %********************************************************************; SYMBOLIC PROCEDURE COMM1 U; BEGIN SCALAR BOOL; IF U EQ 'END THEN GO TO B; A: IF CURSYM!* EQ '!*SEMICOL!* OR U EQ 'END AND CURSYM!* MEMQ '(END ELSE THEN UNTIL !*RPAR!* !*RSQB!*) THEN RETURN NIL ELSE IF U EQ 'END AND NULL BOOL THEN PROGN(LPRIM LIST("END-COMMENT NO LONGER SUPPORTED"), BOOL := T); B: SCAN(); GO TO A END; %********************************************************************* % CONDITIONAL STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMCOND(U,VARS,MODE); 'COND . FORMCOND1(U,VARS,MODE); SYMBOLIC PROCEDURE FORMCOND1(U,VARS,MODE); IF NULL U THEN NIL ELSE LIST(FORMBOOL(CAAR U,VARS,MODE),FORMC(CADAR U,VARS,MODE)) . FORMCOND1(CDR U,VARS,MODE); PUT('COND,'FORMFN,'FORMCOND); SYMBOLIC PROCEDURE IFSTAT; BEGIN SCALAR CONDX,CONDIT; FLAG(LETL!*,'DELIM); A: CONDX := XREAD T; REMFLAG(LETL!*,'DELIM); IF NOT CURSYM!* EQ 'THEN THEN GO TO C; CONDIT := ACONC(CONDIT,LIST(CONDX,XREAD T)); IF NOT CURSYM!* EQ 'ELSE THEN GO TO B ELSE IF SCAN() EQ 'IF THEN GO TO A ELSE CONDIT := ACONC(CONDIT,LIST(T,XREAD1 T)); B: RETURN ('COND . CONDIT); C: IF NOT CURSYM!* MEMQ LETL!* THEN SYMERR('IF,T); RETURN IFLET CONDX END; PUT('IF,'STAT,'IFSTAT); FLAG ('(THEN ELSE),'DELIM); %********************************************************************* % COMPOUND STATEMENT %********************************************************************; SYMBOLIC PROCEDURE DECL U; BEGIN SCALAR VARLIS,W; A: IF CURSYM!* EQ '!*SEMICOL!* THEN GO TO C ELSE IF NOT FLAGP!*!*(CURSYM!*,'TYPE) THEN RETURN VARLIS ELSE IF CURSYM!* EQ 'DCL THEN GO TO DCL; W := CURSYM!*; IF SCAN() EQ 'PROCEDURE THEN RETURN PROCSTAT1 W; VARLIS := APPEND(VARLIS,PAIRVARS(REMCOMMA XREAD1 NIL,NIL,W)); B: IF NOT CURSYM!* EQ '!*SEMICOL!* THEN SYMERR(NIL,T) ELSE IF NULL U THEN RETURN LIST('DCL,MKQUOTE VARLIS); %top level declaration; C: SCAN(); GO TO A; DCL: VARLIS := APPEND(VARLIS,DCLSTAT1()); GO TO B END; FLAG ('(DCL REAL INTEGER SCALAR),'TYPE); SYMBOLIC PROCEDURE DCLSTAT; LIST('DCL,MKQUOTE DCLSTAT1()); SYMBOLIC PROCEDURE DCLSTAT1; BEGIN SCALAR X,Y; A: X := XREAD NIL; IF NOT CURSYM!* EQ '!*COLON!* THEN SYMERR('DCL,T); Y := APPEND(Y,PAIRVARS(REMCOMMA X,NIL,SCAN())); IF SCAN() EQ '!*SEMICOL!* THEN RETURN Y ELSE IF NOT CURSYM!* EQ '!*COMMA!* THEN SYMERR('DCL,T) ELSE GO TO A END; GLOBAL '(!*VARS!*); SYMBOLIC PROCEDURE DCL U; %U is a list of (id, mode) pairs, which are declared as global vars; BEGIN SCALAR X; !*VARS!* := APPEND(U,!*VARS!*); X := MAPCAR(U,FUNCTION CAR); GLOBAL X; FLAG(X,'SHARE); A: IF NULL U THEN RETURN NIL; SET(CAAR U,GET(CDAR U,'INITVALUE)); U := CDR U; GO TO A END; PUT('INTEGER,'INITVALUE,0); PUT('DCL,'STAT,'DCLSTAT); SYMBOLIC PROCEDURE MKPROG(U,V); 'PROG . (U . V); SYMBOLIC PROCEDURE SETDIFF(U,V); IF NULL V THEN U ELSE SETDIFF(DELETE(CAR V,U),CDR V); SYMBOLIC PROCEDURE PAIRVARS(U,VARS,MODE); BEGIN SCALAR X; A: IF NULL U THEN RETURN APPEND(REVERSIP X,VARS); X := (CAR U . MODE) . X; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE FORMBLOCK(U,VARS,MODE); 'PROG . APPEND(INITPROGVARS CAR U, FORMPROG1(CDR U,APPEND(CAR U,VARS),MODE)); SYMBOLIC PROCEDURE INITPROGVARS U; BEGIN SCALAR X,Y,Z; A: IF NULL U THEN RETURN(REVERSIP X . REVERSIP Y) ELSE IF Z := GET(CDAR U,'INITVALUE) THEN Y := MKSETQ(CAAR U,Z) . Y; X := CAAR U . X; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE FORMPROG(U,VARS,MODE); 'PROG . CAR U . FORMPROG1(CDR U,PAIRVARS(CAR U,VARS,MODE),MODE); SYMBOLIC PROCEDURE FORMPROG1(U,VARS,MODE); IF NULL U THEN NIL ELSE IF ATOM CAR U THEN CAR U . FORMPROG1(CDR U,VARS,MODE) ELSE IF IDP CAAR U AND GET(CAAR U,'STAT) EQ 'MODESTAT THEN FORMC(CADAR U,VARS,CAAR U) . FORMPROG1(CDR U,VARS,MODE) ELSE FORMC(CAR U,VARS,MODE) . FORMPROG1(CDR U,VARS,MODE); PUT('BLOCK,'FORMFN,'FORMBLOCK); PUT('PROG,'FORMFN,'FORMPROG); SYMBOLIC PROCEDURE BLOCKSTAT; BEGIN SCALAR X,HOLD,VARLIS; BLOCKP!* := NIL . BLOCKP!*; SCAN(); IF CURSYM!* MEMQ '(NIL !*RPAR!*) THEN REDERR "BEGIN invalid"; VARLIS := DECL T; A: IF CURSYM!* EQ 'END AND NOT NXTSYM!* EQ '!: THEN GO TO B; X := XREAD1 NIL; IF EQCAR(X,'END) THEN GO TO C; NOT CURSYM!* EQ 'END AND SCAN(); IF X THEN HOLD := ACONC(HOLD,X); GO TO A; B: COMM1 'END; C: BLOCKP!* := CDR BLOCKP!*; RETURN MKBLOCK(VARLIS,HOLD) END; SYMBOLIC PROCEDURE MKBLOCK(U,V); 'BLOCK . (U . V); PUTD('BLOCK,'MACRO, '(LAMBDA (U) (CONS 'PROG (CONS (MAPCAR (CADR U) (FUNCTION CAR)) (CDDR U))))); SYMBOLIC PROCEDURE DECSTAT; %only called if a declaration occurs at the top level or not first %in a block; BEGIN SCALAR X,Y,Z; IF BLOCKP!* THEN SYMERR('BLOCK,T); X := CURSYM!*; Y := NXTSYM!*; Z := DECL NIL; IF Y NEQ 'PROCEDURE THEN REDERR LIST(X,"invalid outside block"); RETURN Z END; PUT('INTEGER,'STAT,'DECSTAT); PUT('REAL,'STAT,'DECSTAT); PUT('SCALAR,'STAT,'DECSTAT); PUT('BEGIN,'STAT,'BLOCKSTAT); %********************************************************************* % RETURN STATEMENT %********************************************************************; SYMBOLIC PROCEDURE RETSTAT; IF NOT BLOCKP!* THEN SYMERR(NIL,T) ELSE LIST('RETURN, IF FLAGP!*!*(SCAN(),'DELIM) THEN NIL ELSE XREAD1 T); PUT('RETURN,'STAT,'RETSTAT); %********************************************************************* % EVALUATION MODE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE MODESTAT; BEGIN SCALAR X; X:= CURSYM!*; RETURN IF FLAGP!*!*(SCAN(),'DELIM) THEN PROGN(!*MODE := X, NIL) ELSE LIST(X,XREAD1 T) END; %********************************************************************* % LAMBDA STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMLAMB(U,VARS,MODE); LIST('LAMBDA,CAR U,FORM1(CADR U,PAIRVARS(CAR U,VARS,MODE),MODE)); PUT('LAMBDA,'FORMFN,'FORMLAMB); SYMBOLIC PROCEDURE LAMSTAT; BEGIN SCALAR X,Y; X:= XREAD 'LAMBDA; % X := FLAGTYPE(IF NULL X THEN NIL ELSE REMCOMMA X,'SCALAR); IF X THEN X := REMCOMMA X; Y := LIST('LAMBDA,X,XREAD T); % REMTYPE X; RETURN Y END; PUT ('LAMBDA,'STAT,'LAMSTAT); %********************************************************************* % GROUP STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMPROGN(U,VARS,MODE); 'PROGN . FORMCLIS(U,VARS,MODE); PUT('PROGN,'FORMFN,'FORMPROGN); SYMBOLIC PROCEDURE MKPROGN; %Expects a list of statements terminated by a >>; BEGIN SCALAR LST; A: LST := ACONC(LST,XREAD 'GROUP); IF NULL(CURSYM!* EQ '!*RSQB!*) THEN GO TO A; SCAN(); RETURN 'PROGN . LST END; PUT('!*LSQB!*,'STAT,'MKPROGN); FLAG('(!*RSQB!*),'DELIM); FLAG('(!*RSQB!*),'NODEL); %********************************************************************* % EXPRESSION MODE ANALYSIS %********************************************************************; COMMENT This module is required at this point for bootstrapping purposes; SYMBOLIC PROCEDURE EXPDRMACRO U; %returns the macro form for U if expansion is permitted; BEGIN SCALAR X; IF NULL(X := GETRMACRO U) THEN RETURN NIL ELSE IF NULL !*CREF AND (NULL !*DEFN OR CAR X EQ 'SMACRO) OR FLAGP(U,'EXPAND) OR !*FORCE AND NULL FLAGP(U,'NOEXPAND) THEN RETURN X ELSE RETURN NIL END; SYMBOLIC PROCEDURE GETRMACRO U; %returns a Reduce macro definition for U, if one exists, %in GETD format; BEGIN SCALAR X; RETURN IF NOT IDP U THEN NIL ELSE IF (X := GETD U) AND CAR X EQ 'MACRO THEN X ELSE IF (X := GET(U,'SMACRO)) THEN 'SMACRO . X % ELSE IF (X := GET(U,'NMACRO)) THEN 'NMACRO . X; ELSE NIL END; SYMBOLIC PROCEDURE APPLMACRO(U,V,W); APPLY(U,LIST(W . V)); %SYMBOLIC PROCEDURE APPLNMACRO(U,V,W); % APPLY(U,IF FLAGP(W,'NOSPREAD) THEN LIST V ELSE V); SYMBOLIC PROCEDURE APPLSMACRO(U,V,W); %We could use an atom sublis here, eg SUBLA; SUBLIS(PAIR(CADR U,V),CADDR U); PUT('MACRO,'MACROFN,'APPLMACRO); %PUT('NMACRO,'MACROFN,'APPLNMACRO); PUT('SMACRO,'MACROFN,'APPLSMACRO); FLAG('(ED GO QUOTE),'NOFORM); SYMBOLIC PROCEDURE FORM1(U,VARS,MODE); BEGIN SCALAR X,Y; IF ATOM U THEN RETURN IF U EQ 'ED THEN LIST U ELSE IF NOT(IDP U AND (X:= GET(MODE,'IDFN))) THEN U ELSE APPLY(X,LIST(U,VARS)) ELSE IF NOT ATOM CAR U THEN RETURN FORMLIS(U,VARS,MODE) ELSE IF NOT IDP CAR U THEN TYPERR(CAR U,"operator") ELSE IF FLAGP(CAR U,'NOFORM) THEN RETURN U ELSE IF ARRAYP CAR U AND (MODE EQ 'SYMBOLIC OR INTEXPRLISP(CDR U,VARS)) THEN RETURN LIST('GETEL,INTARGFN(U,VARS)) ELSE IF GET(CAR U,'STAT) EQ 'MODESTAT THEN RETURN CONVERTMODE(CADR U,VARS,MODE,CAR U) ELSE IF (X := GET(CAR U,'FORMFN)) THEN RETURN MACROCHK(APPLY(X,LIST(CDR U,VARS,MODE)),MODE) ELSE IF GET(CAR U,'STAT) EQ 'RLIS THEN RETURN MACROCHK(FORMRLIS(U,VARS,MODE),MODE); X := FORMLIS(CDR U,VARS,MODE); Y := IF X=CDR U THEN U ELSE CAR U . X; RETURN IF MODE EQ 'SYMBOLIC OR GET(CAR U,'STAT) OR CDR U AND EQCAR(CADR U,'QUOTE) OR INTEXPRNP(Y,VARS) AND NULL !*COMPOSITES AND NULL MOD!* THEN MACROCHK(Y,MODE) ELSE IF NOT(MODE EQ 'ALGEBRAIC) THEN CONVERTMODE(Y,VARS,MODE,'ALGEBRAIC) ELSE ('LIST . MKQUOTE CAR U . X) END; SYMBOLIC PROCEDURE FORMLIS(U,VARS,MODE); MAPCAR(U,FUNCTION (LAMBDA X; FORM1(X,VARS,MODE))); SYMBOLIC PROCEDURE FORMCLIS(U,VARS,MODE); MAPCAR(U,FUNCTION (LAMBDA X; FORMC(X,VARS,MODE))); SYMBOLIC PROCEDURE FORM U; FORM1(U,!*VARS!*,!*MODE); SYMBOLIC PROCEDURE MACROCHK(U,MODE); BEGIN SCALAR Y; %expands U if CAR U is a macro and expansion allowed; IF ATOM U THEN RETURN U ELSE IF (Y := EXPDRMACRO CAR U) AND (MODE EQ 'SYMBOLIC OR IDP CAR U AND FLAGP(CAR U,'OPFN)) THEN RETURN APPLY(GET(CAR Y,'MACROFN),LIST(CDR Y,CDR U,CAR U)) ELSE RETURN U END; PUT('SYMBOLIC,'IDFN,'SYMBID); SYMBOLIC PROCEDURE SYMBID(U,VARS); U; % IF ATSOC(U,VARS) OR FLUIDP U OR GLOBALP U OR U MEMQ '(NIL T) % OR FLAGP(U,'SHARE) THEN U % ELSE <<LPRIM LIST(U,"Non-Local Identifier");% U>>; PUT('ALGEBRAIC,'IDFN,'ALGID); SYMBOLIC PROCEDURE ALGID(U,VARS); IF ATSOC(U,VARS) OR FLAGP(U,'SHARE) THEN U ELSE MKQUOTE U; PUT('INTEGER,'IDFN,'INTID); SYMBOLIC PROCEDURE INTID(U,VARS); BEGIN SCALAR X,Y; RETURN IF (X := ATSOC(U,VARS)) THEN IF CDR X EQ 'INTEGER THEN U ELSE IF Y := GET(CDR X,'INTEGER) THEN APPLY(Y,LIST(U,VARS)) ELSE IF CDR X EQ 'SCALAR THEN !*!*A2I(U,VARS) ELSE REDERR LIST(CDR X,"not convertable to INTEGER") ELSE !*!*A2I(MKQUOTE U,VARS) END; SYMBOLIC PROCEDURE CONVERTMODE(EXPRN,VARS,TARGET,SOURCE); CONVERTMODE1(FORM1(EXPRN,VARS,SOURCE),VARS,TARGET,SOURCE); SYMBOLIC PROCEDURE CONVERTMODE1(EXPRN,VARS,TARGET,SOURCE); BEGIN SCALAR X; % EXPRN := FORM1(EXPRN,VARS,SOURCE); IF TARGET EQ SOURCE THEN RETURN EXPRN ELSE IF IDP EXPRN AND (X := ATSOC(EXPRN,VARS)) AND NOT(CDR X EQ 'SCALAR) AND NOT(CDR X EQ SOURCE) THEN RETURN CONVERTMODE(EXPRN,VARS,TARGET,CDR X) ELSE IF NOT (X := GET(SOURCE,TARGET)) THEN TYPERR(SOURCE,TARGET) ELSE RETURN APPLY(X,LIST(EXPRN,VARS)) END; PUT('ALGEBRAIC,'SYMBOLIC,'!*!*A2S); PUT('SYMBOLIC,'ALGEBRAIC,'!*!*S2A); FLUID '(!*!*A2SFN); !*!*A2SFN := 'AEVAL; SYMBOLIC PROCEDURE !*!*A2S(U,VARS); IF NULL U OR CONSTANTP U AND NULL FIXP U OR INTEXPRNP(U,VARS) AND NULL !*COMPOSITES AND NULL MOD!* OR NOT ATOM U AND IDP CAR U AND FLAGP(CAR U,'NOCHANGE) AND NOT(CAR U EQ 'GETEL) THEN U ELSE IF U = '(QUOTE NIL) THEN NIL ELSE LIST(!*!*A2SFN,U); SYMBOLIC PROCEDURE !*!*S2A(U,VARS); U; SYMBOLIC PROCEDURE FORMC(U,VARS,MODE); %this needs to be generalized; IF MODE EQ 'ALGEBRAIC AND INTEXPRNP(U,VARS) THEN U ELSE CONVERTMODE(U,VARS,'SYMBOLIC,MODE); SYMBOLIC PROCEDURE INTARGFN(U,VARS); %transforms U into a function with integer arguments. %We assume that the analysis is done in algebraic mode; 'LIST . FORM1(CAR U,VARS,'ALGEBRAIC) . MAPCAR(CDR U, FUNCTION (LAMBDA X; CONVERTMODE(X,VARS,'INTEGER,'ALGEBRAIC))); PUT('ALGEBRAIC,'INTEGER,'!*!*A2I); SYMBOLIC PROCEDURE !*!*A2I(U,VARS); IF INTEXPRNP(U,VARS) THEN U ELSE LIST('!*S2I,LIST('REVAL,U)); PUT('SYMBOLIC,'INTEGER,'!*!*S2I); SYMBOLIC PROCEDURE !*!*S2I(U,VARS); IF NUMBERP U AND FIXP U THEN U ELSE LIST('!*S2I,U); SYMBOLIC PROCEDURE !*S2I U; IF NUMBERP U AND FIXP U THEN U ELSE TYPERR(U,"integer"); PUT('INTEGER,'SYMBOLIC,'IDENTITY); SYMBOLIC PROCEDURE IDENTITY(U,VARS); U; SYMBOLIC PROCEDURE FORMBOOL(U,VARS,MODE); IF MODE EQ 'SYMBOLIC THEN FORM1(U,VARS,MODE) ELSE IF ATOM U THEN IF NOT IDP U OR ATSOC(U,VARS) OR U EQ 'T THEN U ELSE FORMC!*(U,VARS,MODE) ELSE IF INTEXPRLISP(CDR U,VARS) AND GET(CAR U,'BOOLFN) THEN U ELSE IF IDP CAR U AND GET(CAR U,'BOOLFN) THEN GET(CAR U,'BOOLFN) . FORMCLIS(CDR U,VARS,MODE) ELSE IF IDP CAR U AND FLAGP(CAR U,'BOOLEAN) THEN CAR U . MAPCAR(CDR U,FUNCTION (LAMBDA X; IF FLAGP(CAR U,'BOOLARGS) THEN FORMBOOL(X,VARS,MODE) ELSE FORMC!*(X,VARS,MODE))) ELSE FORMC!*(U,VARS,MODE); SYMBOLIC PROCEDURE FORMC!*(U,VARS,MODE); BEGIN SCALAR !*!*A2SFN; !*!*A2SFN := 'REVAL; RETURN FORMC(U,VARS,MODE) END; SYMBOLIC PROCEDURE FORMSETQ(U,VARS,MODE); BEGIN SCALAR TARGET,X,Y; IF EQCAR(CADR U,'QUOTE) THEN MODE := 'SYMBOLIC; IF IDP CAR U AND (Y := ATSOC(CAR U,VARS)) AND NOT(CDR Y EQ 'SCALAR) THEN TARGET := CDR Y ELSE TARGET := 'SYMBOLIC; X := CONVERTMODE(CADR U,VARS,TARGET,MODE); RETURN IF NOT ATOM CAR U THEN IF NOT IDP CAAR U THEN TYPERR(CAR U,"assignment") ELSE IF ARRAYP CAAR U AND (MODE EQ 'SYMBOLIC OR INTEXPRLISP(CDAR U,VARS)) THEN LIST('SETEL,INTARGFN(CAR U,VARS),X) ELSE IF Y := GET(CAAR U,'SETQFN) THEN FORM1((Y . APPEND(CDAR U,CDR U)),VARS,MODE) ELSE LIST('SETK,FORM1(CAR U,VARS,MODE),X) ELSE IF NOT IDP CAR U THEN TYPERR(CAR U,"assignment") ELSE IF MODE EQ 'SYMBOLIC OR Y OR FLAGP(CAR U,'SHARE) OR EQCAR(X,'QUOTE) THEN MKSETQ(CAR U,X) ELSE LIST('SETK,MKQUOTE CAR U,X) END; PUT('CAR,'SETQFN,'RPLACA); PUT('CDR,'SETQFN,'RPLACD); PUT('SETQ,'FORMFN,'FORMSETQ); SYMBOLIC PROCEDURE FORMFUNC(U,VARS,MODE); IF IDP CAR U THEN IF GETRMACRO CAR U THEN REDERR LIST("Macro",CAR U,"Used as Function") ELSE LIST('FUNCTION,CAR U) ELSE LIST('FUNCTION,FORM1(CAR U,VARS,MODE)); PUT('FUNCTION,'FORMFN,'FORMFUNC); SYMBOLIC PROCEDURE FORMRLIS(U,VARS,MODE); IF NOT FLAGP(CAR U,'FLAGOP) THEN LIST(CAR U,'LIST . FORMLIS(CDR U,VARS,'ALGEBRAIC)) ELSE MKPROG(NIL,LIST('FLAG,MKQUOTE CDR U,MKQUOTE CAR U) . GET(CAR U,'SIMPFG)); SYMBOLIC PROCEDURE MKARG(U,VARS); %returns the "unevaled" form of U; IF NULL U OR CONSTANTP U THEN U ELSE IF ATOM U THEN IF ATSOC(U,VARS) THEN U ELSE MKQUOTE U ELSE IF CAR U EQ 'QUOTE THEN MKQUOTE U ELSE 'LIST . MAPCAR(U,FUNCTION (LAMBDA X; MKARG(X,VARS))); %********************************************************************* % PROCEDURE STATEMENT %********************************************************************; FTYPES!* := '(EXPR FEXPR MACRO); FLUID '(!*COMP); SYMBOLIC PROCEDURE PUTC(NAME,TYPE,BODY); %defines a non-standard function, such as an smacro. Returns NAME; BEGIN IF !*COMP AND FLAGP(TYPE,'COMPILE) THEN COMPD(NAME,TYPE,BODY) ELSE PUT(NAME,TYPE,BODY); RETURN NAME END; SYMBOLIC PROCEDURE PAIRXVARS(U,V,VARS,MODE); %Pairs procedure variables and their modes, taking into account %the convention which allows a top level prog to change the mode %of such a variable; BEGIN SCALAR X,Y; A: IF NULL U THEN RETURN APPEND(REVERSIP X,VARS) . V ELSE IF (Y := ATSOC(CAR U,V)) THEN <<V := DELETE(Y,V); IF NOT(CDR Y EQ 'SCALAR) THEN X := (CAR U . CDR Y) . X ELSE X := (CAR U . MODE) . X>> ELSE X := (CAR U . MODE) . X; U := CDR U; GO TO A END; SYMBOLIC PROCEDURE FORMPROC(U,VARS,MODE); BEGIN SCALAR BODY,NAME,TYPE,VARLIS,X,Y; NAME := CAR U; IF CADR U THEN MODE := CADR U; %overwrite previous mode; U := CDDR U; TYPE := CAR U; IF FLAGP(NAME,'LOSE) AND (!*LOSE OR NULL !*DEFN) THEN RETURN PROGN(LPRIM LIST(NAME, "not defined (LOSE flag)"), NIL); VARLIS := CADR U; U := CADDR U; X := IF EQCAR(U,'BLOCK) THEN CADR U ELSE NIL; Y := PAIRXVARS(VARLIS,X,VARS,MODE); IF X THEN RPLACA(CDR U,CDR Y); BODY:= FORM1(U,CAR Y,MODE); IF TYPE EQ 'EXPR THEN BODY := LIST('DE,NAME,VARLIS,BODY) ELSE IF TYPE EQ 'FEXPR THEN BODY := LIST('DF,NAME,VARLIS,BODY) ELSE IF TYPE EQ 'MACRO THEN BODY := LIST('DM,NAME,VARLIS,BODY) ELSE IF TYPE EQ 'EMB THEN RETURN EMBFN(NAME,VARLIS,BODY) ELSE BODY := LIST('PUTC, MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE LIST('LAMBDA,VARLIS,BODY)); IF NOT(MODE EQ 'SYMBOLIC) THEN BODY := LIST('PROGN, LIST('FLAG,MKQUOTE LIST NAME,MKQUOTE 'OPFN), BODY); IF !*DEFN AND TYPE MEMQ '(MACRO SMACRO) THEN EVAL BODY; RETURN BODY END; PUT('PROCEDURE,'FORMFN,'FORMPROC); SYMBOLIC PROCEDURE PROCSTAT1 MODE; BEGIN SCALAR BOOL,U,TYPE,X,Y,Z; BOOL := ERFG!*; IF FNAME!* THEN GO TO B ELSE IF CURSYM!* EQ 'PROCEDURE THEN TYPE := 'EXPR ELSE PROGN(TYPE := CURSYM!*,SCAN()); IF NOT CURSYM!* EQ 'PROCEDURE THEN GO TO C; X := ERRORSET('(XREAD (QUOTE PROC)),NIL,!*BACKTRACE); IF ERRORP X THEN GO TO A ELSE IF ATOM (X := CAR X) THEN X := LIST X; %no arguments; FNAME!* := CAR X; %function name; IF IDP FNAME!* %AND NOT(TYPE MEMQ FTYPES!*); THEN IF NULL FNAME!* OR (Z := GETTYPE FNAME!*) AND NOT Z MEMQ '(PROCEDURE OPERATOR) THEN GO TO D ELSE IF NOT GETD FNAME!* THEN FLAG(LIST FNAME!*,'FNC); %to prevent invalid use of function name in body; U := CDR X; Y := U; X := CAR X . Y; A: Z := ERRORSET('(XREAD T),NIL,!*BACKTRACE); IF NOT ERRORP Z THEN Z := CAR Z; IF NULL ERFG!* THEN Z:=LIST('PROCEDURE,CAR X,MODE,TYPE,Y,Z); REMFLAG(LIST FNAME!*,'FNC); FNAME!*:=NIL; IF ERFG!* THEN PROGN(Z := NIL,IF NOT BOOL THEN ERROR1()); RETURN Z; B: BOOL := T; C: ERRORSET('(SYMERR (QUOTE PROCEDURE) T),NIL,!*BACKTRACE); GO TO A; D: TYPERR(LIST(Z,FNAME!*),"procedure"); GO TO A END; SYMBOLIC PROCEDURE PROCSTAT; PROCSTAT1 NIL; DEFLIST ('((PROCEDURE PROCSTAT) (EXPR PROCSTAT) (FEXPR PROCSTAT) (EMB PROCSTAT) (MACRO PROCSTAT) (SMACRO PROCSTAT)), 'STAT); DEFLIST ('((ALGEBRAIC MODESTAT) (SYMBOLIC MODESTAT)), 'STAT); DEFLIST('((LISP SYMBOLIC)),'NEWNAM); COMMENT Defining GEQ, LEQ and NEQ as SMACROS; SMACRO PROCEDURE U>=V; NOT(U<V); SMACRO PROCEDURE U<=V; NOT(U>V); SMACRO PROCEDURE U NEQ V; NOT(U=V); %********************************************************************* % END STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ENDSTAT; %This procedure can also be used for any key-words which take no %arguments; BEGIN SCALAR X; X := CURSYM!*; COMM1 'END; RETURN LIST X END; PUT('END,'STAT,'ENDSTAT); PUT('BYE,'STAT,'ENDSTAT); PUT('QUIT,'STAT,'ENDSTAT); FLAG('(BYE QUIT),'EVAL); PUT('SHOWTIME,'STAT,'ENDSTAT); %********************************************************************* %********************************************************************* % MODULAR STATEMENTS %********************************************************************* %********************************************************************; % The remaining statements defined in this section are truly %modular, and any may be omitted if desired. %********************************************************************* % FUNCTIONS FOR INTRODUCING NEW INFIX OPERATORS %********************************************************************; SYMBOLIC PROCEDURE INFIX X; BEGIN SCALAR Y; IF !*MODE EQ 'ALGEBRAIC THEN MAPCAR(X,FUNCTION MKOP); IF Y := XN(X,PRECLIS!*) THEN LPRIM APPEND(Y,'(REDEFINED)); PRECLIS!* := APPEND(REVERSE X,SETDIFF(PRECLIS!*,X)); MKPREC() END; SYMBOLIC PROCEDURE PRECEDENCE U; BEGIN SCALAR X,Y,Z; PRECLIS!* := DELETE(CAR U,PRECLIS!*); Y := CADR U; X := PRECLIS!*; A: IF NULL X THEN REDERR LIST (Y,"not found") ELSE IF Y EQ CAR X THEN GO TO B; Z := CAR X . Z; X := CDR X; GO TO A; B: PRECLIS!* := NCONC(REVERSIP Z,CAR X . (CAR U . CDR X)); MKPREC() END; RLISTAT '(INFIX PRECEDENCE); FLAG('(INFIX PRECEDENCE),'EVAL); %********************************************************************* % FOR STATEMENT %********************************************************************; %REMPROP('FOR,'STAT); %in case rebuilding system on top of itself; SYMBOLIC PROCEDURE FORLOOP; BEGIN SCALAR ACTION,BODY,INCR,VAR,X; X := XREAD1 'FOR; IF ATOM X OR NOT CAR X MEMQ '(EQUAL SETQ) THEN SYMERR('FOR,T); VAR := CADR X; X := CADDR X; IF NOT IDP VAR THEN SYMERR('FOR,T); % VAR := CAR FLAGTYPE(LIST VAR,'INTEGER); IF CURSYM!* EQ 'STEP THEN <<INCR := XREAD T; IF NOT CURSYM!* EQ 'UNTIL THEN SYMERR('FOR,T)>> ELSE IF CURSYM!* EQ '!*COLON!* THEN INCR := 1 ELSE SYMERR('FOR,T); INCR := LIST(X,INCR,XREAD T); IF NOT GET(ACTION := CURSYM!*,'BIN) AND NOT ACTION EQ 'DO THEN SYMERR('FOR,T); BODY := XREAD T; % REMTYPE LIST VAR; RETURN LIST('FOR,VAR,INCR,ACTION,BODY) END; SYMBOLIC PROCEDURE FORMFOR(U,VARS,MODE); LIST('FOR,CAR U, MAPCAR(CADR U,FUNCTION (LAMBDA X; FORMC(X,VARS,MODE))), CADDR U, FORMC(CADDDR U, (CAR U . IF INTEXPRLISP(CADR U,VARS) THEN 'INTEGER ELSE MODE) . VARS,MODE)); PUT('FOR,'FORMFN,'FORMFOR); SYMBOLIC PROCEDURE INTEXPRNP(U,VARS); %determines if U is an integer expression; IF ATOM U THEN IF NUMBERP U THEN FIXP U ELSE IF (U := ATSOC(U,VARS)) THEN CDR U EQ 'INTEGER ELSE NIL ELSE IDP CAR U AND FLAGP(CAR U,'INTFN) AND INTEXPRLISP(CDR U,VARS); SYMBOLIC PROCEDURE INTEXPRLISP(U,VARS); NULL U OR INTEXPRNP(CAR U,VARS) AND INTEXPRLISP(CDR U,VARS); FLAG('(DIFFERENCE EXPT MINUS PLUS TIMES),'INTFN); SYMBOLIC MACRO PROCEDURE FOR U; BEGIN SCALAR ACTION,ALGP,BODY,EXP,INCR,LAB1,LAB2,RESULT,TAIL,VAR,X; %ALGP is used to determine if the loop calculation must be %done algebraically or not; VAR := CADR U; INCR := CADDR U; ACTION := CADDDR U; BODY := CAR CDDDDR U; IF ALGMODEP CAR INCR OR ALGMODEP CADR INCR OR ALGMODEP CADDR INCR THEN ALGP := T; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := IF ALGP THEN LIST('LIST,MKQUOTE 'DIFFERENCE,CADR INCR,VAR) ELSE LIST('DIFFERENCE,CADR INCR,VAR); IF CAR INCR NEQ 1 THEN X := IF ALGP THEN LIST('LIST,MKQUOTE 'TIMES,CAR INCR,X) ELSE LIST('TIMES,CAR INCR,X); IF NOT ACTION EQ 'DO THEN <<ACTION := GET(ACTION,'BIN); EXP := GENSYM(); BODY := LIST('SETQ,EXP, LIST(CAR ACTION,LIST('SIMP,BODY),EXP)); RESULT := LIST('SETQ,EXP,MKQUOTE CDR ACTION) . RESULT; TAIL := LIST LIST('RETURN,LIST('MK!*SQ,EXP)); EXP := LIST EXP>>; LAB1 := GENSYM(); LAB2 := GENSYM(); X := IF ALGP THEN LIST('AMINUSP!:,X) ELSE LIST('MINUSP,X); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(X,LIST('GO,LAB2))) . BODY . LIST('SETQ,VAR, IF ALGP THEN LIST('AEVAL, LIST('LIST,MKQUOTE 'PLUS,VAR,CAR INCR)) ELSE LIST('PLUS2,VAR,CAR INCR)) . LIST('GO,LAB1) . LAB2 . TAIL); RETURN MKPROG(VAR . EXP,RESULT) END; SYMBOLIC PROCEDURE ALGMODEP U; EQCAR(U,'AEVAL); SYMBOLIC PROCEDURE AMINUSP!: U; BEGIN SCALAR X; U := AEVAL U; X := U; IF FIXP X THEN RETURN MINUSP X ELSE IF NOT EQCAR(X,'!*SQ) THEN MSGPRI(NIL,REVAL U,"invalid in FOR statement",NIL,T); X := CADR X; IF FIXP CAR X AND FIXP CDR X THEN RETURN MINUSP CAR X ELSE IF NOT CDR X = 1 OR NOT DOMAINP (X := CAR X) THEN MSGPRI(NIL,REVAL U,"invalid in FOR statement",NIL,T) ELSE RETURN APPLY('!:MINUSP,LIST X) END; FLAG('(FOR),'NOCHANGE); SYMBOLIC PROCEDURE FORSTAT; IF SCAN() EQ 'ALL THEN FORALLSTAT() ELSE IF CURSYM!* EQ 'EACH THEN FOREACHSTAT() ELSE FORLOOP(); PUT('FOR,'STAT,'FORSTAT); FLAG ('(STEP DO UNTIL),'DELIM); %********************************************************************* % FOR EACH STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMFOREACH(U,VARS,MODE); LIST('FOREACH,CAR U,CADR U,FORMC(CADDR U,VARS,MODE),CADDDR U, FORMC(CAR CDDDDR U,(CAR U . MODE) . VARS,MODE)); PUT('FOREACH,'FORMFN,'FORMFOREACH); SYMBOLIC PROCEDURE FOREACHSTAT; BEGIN SCALAR W,X,Y,Z; X := SCAN(); Y := SCAN(); IF NOT Y MEMQ '(IN ON) THEN SYMERR("FOR EACH",T); IF FLAGP('CONC,'DELIM) THEN W := T ELSE FLAG('(COLLECT CONC),'DELIM); Z := XREAD T; IF NULL W THEN REMFLAG('(COLLECT CONC),'DELIM); W := CURSYM!*; IF NOT W MEMQ '(DO COLLECT CONC) THEN SYMERR("FOR EACH",T); RETURN LIST('FOREACH,X,Y,Z,W,XREAD T) END; PUT('FOREACH,'STAT,'FOREACHSTAT); SYMBOLIC MACRO PROCEDURE FOREACH U; BEGIN SCALAR ACTION,BODY,FN,LST,MOD,VAR; VAR := CADR U; U := CDDR U; MOD := CAR U; U := CDR U; LST := CAR U; U := CDR U; ACTION := CAR U; U := CDR U; BODY := CAR U; FN := IF ACTION EQ 'DO THEN IF MOD EQ 'IN THEN 'MAPC ELSE 'MAP ELSE IF ACTION EQ 'CONC THEN IF MOD EQ 'IN THEN 'MAPCAN ELSE 'MAPCON ELSE IF ACTION EQ 'COLLECT THEN IF MOD EQ 'IN THEN 'MAPCAR ELSE 'MAPLIST ELSE REDERR LIST(ACTION,"invalid in FOREACH statement"); RETURN LIST(FN,LST,LIST('FUNCTION,LIST('LAMBDA,LIST VAR,BODY))) END; %********************************************************************* % REPEAT STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMREPEAT(U,VARS,MODE); LIST('REPEAT,FORMC(CAR U,VARS,MODE),FORMBOOL(CADR U,VARS,MODE)); PUT('REPEAT,'FORMFN,'FORMREPEAT); SYMBOLIC PROCEDURE REPEATSTAT; BEGIN SCALAR BODY; BODY:= XREAD T; IF NOT CURSYM!* EQ 'UNTIL THEN SYMERR('REPEAT,T); RETURN LIST('REPEAT,BODY,XREAD T); END; PUT('REPEAT,'STAT,'REPEATSTAT); MACRO PROCEDURE REPEAT U; BEGIN SCALAR BODY,BOOL,LAB; BODY := CADR U; BOOL := CADDR U; LAB := GENSYM(); RETURN MKPROG(NIL,LIST(LAB,BODY, LIST('COND,LIST(LIST('NOT,BOOL),LIST('GO,LAB))))) END; FLAG('(REPEAT),'NOCHANGE); %********************************************************************* % WHILE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE FORMWHILE(U,VARS,MODE); LIST('WHILE,FORMBOOL(CAR U,VARS,MODE),FORMC(CADR U,VARS,MODE)); PUT('WHILE,'FORMFN,'FORMWHILE); SYMBOLIC PROCEDURE WHILSTAT; BEGIN SCALAR BOOL; BOOL := XREAD T; IF NOT CURSYM!* EQ 'DO THEN SYMERR('WHILE,T); RETURN LIST('WHILE,BOOL,XREAD T) END; PUT('WHILE,'STAT,'WHILSTAT); MACRO PROCEDURE WHILE U; BEGIN SCALAR BODY,BOOL,LAB; BOOL := CADR U; BODY := CADDR U; LAB := GENSYM(); RETURN MKPROG(NIL,LIST(LAB,LIST('COND,LIST(LIST('NOT,BOOL), LIST('RETURN,NIL))),BODY,LIST('GO,LAB))) END; FLAG('(WHILE),'NOCHANGE); %********************************************************************* % ARRAY STATEMENT %********************************************************************; SYMBOLIC PROCEDURE GETEL U; %returns the value of the array element U; GETEL1(GET(CAR U,'ARRAY),CDR U); SYMBOLIC PROCEDURE GETEL1(U,V); IF NULL V THEN U ELSE GETEL1(GETV(U,CAR V),CDR V); SYMBOLIC PROCEDURE SETEL(U,V); %Sets array element U to V and returns V; SETEL1(GET(CAR U,'ARRAY),CDR U,V); SYMBOLIC PROCEDURE SETEL1(U,V,W); IF NULL CDR V THEN PUTV(U,CAR V,W) ELSE SETEL1(GETV(U,CAR V),CDR V,W); SYMBOLIC PROCEDURE DIMENSION U; GET(U,'DIMENSION); COMMENT further support for REDUCE arrays; SYMBOLIC PROCEDURE TYPECHK(U,V); BEGIN SCALAR X; IF (X := GETTYPE U) EQ V OR X EQ 'PARAMETER THEN LPRIM LIST(V,U,"REDEFINED") ELSE IF X THEN TYPERR(LIST(X,U),V) END; SYMBOLIC PROCEDURE ARRAYFN(U,V); %U is the defining mode, V a list of lists, assumed syntactically %correct. %ARRAYFN declares each element as an array unless a semantic %mismatch occurs; BEGIN SCALAR Y; FOR EACH X IN V DO <<TYPECHK(CAR X,'ARRAY); Y := ADD1LIS FOR EACH Z IN CDR X COLLECT EVAL Z; IF ERFG!* THEN RETURN NIL; PUT(CAR X,'ARRAY,MKARRAY Y); PUT(CAR X,'DIMENSION,Y)>> END; SYMBOLIC PROCEDURE ADD1LIS U; IF NULL U THEN NIL ELSE (CAR U+1) . ADD1LIS CDR U; SYMBOLIC PROCEDURE MKARRAY U; %U is a list of positive integers representing array bounds. %Value is an array structure; IF NULL U THEN NIL ELSE BEGIN INTEGER N; SCALAR X; N := CAR U-1; X := MKVECT N; FOR I:=0:N DO PUTV(X,I,MKARRAY CDR U); RETURN X END; RLISTAT '(ARRAY); FLAG ('(ARRAY),'EVAL); SYMBOLIC PROCEDURE FORMARRAY(U,VARS,MODE); BEGIN SCALAR X; X := U; WHILE X DO <<IF ATOM X THEN TYPERR(X,"Array List") ELSE IF ATOM CAR X OR NOT IDP CAAR X OR NOT LISTP CDAR X THEN TYPERR(CAR X,"Array"); X := CDR X>>; U := FOR EACH Z IN U COLLECT INTARGFN(Z,VARS); %ARRAY arguments must be returned as quoted structures; RETURN LIST('ARRAYFN,MKQUOTE MODE,'LIST . U) END; SYMBOLIC PROCEDURE LISTP U; %returns T if U is a top level list; NULL U OR NOT ATOM U AND LISTP CDR U; PUT('ARRAY,'FORMFN,'FORMARRAY); %********************************************************************* % ON/OFF STATEMENTS %********************************************************************; SYMBOLIC PROCEDURE ON U; ONOFF(U,T); SYMBOLIC PROCEDURE OFF U; ONOFF(U,NIL); SYMBOLIC PROCEDURE ONOFF(U,BOOL); BEGIN SCALAR X; FOR EACH J IN U DO IF NOT IDP J THEN TYPERR(J,"ON/OFF argument") ELSE <<SET(INTERN COMPRESS APPEND(EXPLODE '!*,EXPLODE J),BOOL); IF X := ATSOC(BOOL,GET(J,'SIMPFG)) THEN EVAL MKPROG(NIL,CDR X)>> END; RLISTAT '(OFF ON); %********************************************************************* % DEFINE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE DEFSTAT; BEGIN SCALAR X,Y,Z; A: X := SCAN(); B: IF FLAGP!*!*(X,'DELIM) THEN RETURN MKPROG(NIL,Z) ELSE IF X EQ '!*COMMA!* THEN GO TO A ELSE IF NOT IDP X THEN GO TO ER; Y := SCAN(); IF NOT Y EQ 'EQUAL THEN GO TO ER; Z := ACONC(Z,LIST('PUT,MKQUOTE X,MKQUOTE 'NEWNAM, MKQUOTE XREAD T)); X := CURSYM!*; GO TO B; ER: SYMERR('DEFINE,T) END; PUT('DEFINE,'STAT,'DEFSTAT); FLAG('(DEFINE),'EVAL); %********************************************************************* % WRITE STATEMENT %********************************************************************; RLISTAT '(WRITE); SYMBOLIC PROCEDURE FORMWRITE(U,VARS,MODE); BEGIN SCALAR BOOL1,BOOL2,X,Y,Z; BOOL1 := MODE EQ 'SYMBOLIC; WHILE U DO <<X := FORMC(CAR U,VARS,MODE); Z := (IF BOOL1 THEN LIST('PRIN2,X) ELSE LIST('VARPRI,X,MKARG(SETVARS X,VARS), IF NOT CDR U THEN IF NOT BOOL2 THEN MKQUOTE 'ONLY ELSE T ELSE IF NOT BOOL2 THEN MKQUOTE 'FIRST ELSE NIL)) . Z; BOOL2 := T; U := CDR U>>; RETURN MKPROG(NIL,REVERSIP Z) END; PUT('WRITE,'FORMFN,'FORMWRITE); %********************************************************************* %********************************************************************* % REDUCE FUNCTIONS FOR HANDLING INPUT AND OUTPUT OF FILES %********************************************************************* %********************************************************************; GLOBAL '(CONTL!*); SYMBOLIC PROCEDURE IN U; BEGIN SCALAR CHAN,ECHO,ECHOP,TYPE; ECHOP := SEMIC!* EQ '!;; %record echo character from input; ECHO := !*ECHO; %save current echo status; IF NULL IFL!* THEN TECHO!* := !*ECHO; %terminal echo status; FOR EACH FL IN U DO <<IF FL EQ 'T THEN FL := NIL; IF NULL FL THEN <<!*ECHO := TECHO!*; IFL!* := NIL>> ELSE <<CHAN := OPEN(FL := MKFIL FL,'INPUT); IFL!* := FL . CHAN>>; IPL!* := IFL!* . IPL!*; %add to input file stack; RDS (IF IFL!* THEN CDR IFL!* ELSE NIL); !*ECHO := ECHOP; TYPE := FILETYPE FL; IF TYPE AND (TYPE := GET(TYPE,'ACTION)) THEN EVAL LIST TYPE ELSE BEGIN1(); IF CHAN THEN CLOSE CHAN; IF FL EQ CAAR IPL!* THEN IPL!* := CDR IPL!* ELSE ERRACH LIST("FILE STACK CONFUSION",FL,IPL!*)>>; !*ECHO := ECHO; %restore echo status; IF IPL!* AND NULL CONTL!* THEN IFL!* := CAR IPL!* ELSE IFL!* := NIL; RDS(IF IFL!* THEN CDR IFL!* ELSE NIL) END; SYMBOLIC PROCEDURE OUT U; %U is a list of one file; BEGIN INTEGER N; SCALAR CHAN,FL,X; N := LINELENGTH NIL; IF NULL U THEN RETURN NIL ELSE IF CAR U EQ 'T THEN RETURN <<WRS(OFL!* := NIL); NIL>>; FL := MKFIL CAR U; IF NOT (X := ASSOC(FL,OPL!*)) THEN <<CHAN := OPEN(FL,'OUTPUT); OFL!* := FL . CHAN; OPL!* := OFL!* . OPL!*>> ELSE OFL!* := X; WRS CDR OFL!*; LINELENGTH N END; SYMBOLIC PROCEDURE SHUT U; %U is a list of names of files to be shut; BEGIN SCALAR FL1; FOR EACH FL IN U DO <<IF FL1 := ASSOC((FL := MKFIL FL),OPL!*) THEN <<OPL!* := DELETE(FL1,OPL!*); IF FL1=OFL!* THEN <<OFL!* := NIL; WRS NIL>>; CLOSE CDR FL1>> ELSE IF NOT (FL1 := ASSOC(FL,IPL!*)) THEN REDERR LIST(FL,"not open") ELSE IF FL1 NEQ IFL!* THEN <<CLOSE CDR FL1; IPL!* := DELETE(FL1,IPL!*)>> ELSE REDERR LIST("Cannot shut current input file",CAR FL1)>> END; DEFLIST ('((IN RLIS) (OUT RLIS) (SHUT RLIS)),'STAT); %********************************************************************* % FUNCTIONS HANDLING INTERACTIVE FEATURES %********************************************************************; %GLOBAL Variables referenced in this Section; GLOBAL '(FLG!* CLOC!* EDIT!*); CONTL!* := NIL; SYMBOLIC PROCEDURE PAUSE; %Must appear at the top-most level; IF KEY!* EQ 'PAUSE THEN PAUSE1 NIL ELSE %TYPERR('PAUSE,"lower level command"); PAUSE1 NIL; %Allow at lower level for now; SYMBOLIC PROCEDURE PAUSE1 BOOL; BEGIN IF BOOL THEN % IF NULL IFL!* % THEN RETURN NIL ELSE; IF GETD 'EDIT1 AND ERFG!* AND CLOC!* AND YESP "Edit?" THEN RETURN <<CONTL!* := NIL; IF OFL!* THEN <<LPRIM LIST(CAR OFL!*,'SHUT); CLOSE CDR OFL!*; OPL!* := DELETE(OFL!*,OPL!*); OFL!* := NIL>>; EDIT1(CLOC!*,NIL)>> ELSE IF FLG!* THEN RETURN (EDIT!* := NIL); IF NULL IFL!* OR YESP "Cont?" THEN RETURN NIL; CONTL!* := IFL!* . !*ECHO . CONTL!*; RDS (IFL!* := NIL); !*ECHO := TECHO!* END; SYMBOLIC PROCEDURE YESP U; BEGIN SCALAR BOOL,IFL,OFL,X,Y,Z; IF IFL!* THEN <<IFL:= IFL!*; RDS NIL>>; IF OFL!* THEN <<OFL:= OFL!*; WRS NIL>>; TERPRI(); IF ATOM U THEN PRIN2 U ELSE LPRI U; PRIN2T " (Y or N)"; TERPRI(); Z := SETPCHAR '!?; A: X := READ(); IF (Y := (X EQ 'Y)) OR X EQ 'N THEN GO TO B; IF NULL BOOL THEN PRIN2T "TYPE Y OR N"; BOOL := T; GO TO A; B: SETPCHAR Z; IF OFL THEN WRS CDR OFL; IF IFL THEN RDS CDR IFL; CURSYM!* := '!*SEMICOL!*; RETURN Y END; SYMBOLIC PROCEDURE CONT; BEGIN SCALAR FL,TECHO; IF IFL!* THEN RETURN NIL %CONT only active from terminal; ELSE IF NULL CONTL!* THEN REDERR "No file open"; FL := CAR CONTL!*; TECHO := CADR CONTL!*; CONTL!* := CDDR CONTL!*; IF FL=CAR IPL!* THEN <<IFL!* := FL; RDS IF FL THEN CDR FL ELSE NIL; !*ECHO := TECHO>> ELSE <<EOF!* :=T; LPRIM LIST(FL,"not open"); ERROR1()>> END; DEFLIST ('((PAUSE ENDSTAT) (CONT ENDSTAT) (RETRY ENDSTAT)),'STAT); PUT('RETRY,'STAT,'ENDSTAT); FLAG ('(CONT),'IGNORE); END; |
Added r30/rprint.fap version [510a1561ae].
cannot compute difference between binary files
Added r30/rprint.red version [8c533d6911].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT MODULE RPRINT; COMMENT THE STANDARD LISP TO REDUCE PRETTY PRINTER; FLUID '(PRETOP PRETOPRINF); PRETOP := 'OP; PRETOPRINF := 'OPRINF; FLUID '(COMBUFF); FLUID '(CURMARK BUFFP RMAR !*N); SYMBOLIC PROCEDURE RPRINT U; BEGIN INTEGER !*N; SCALAR BUFF,BUFFP,CURMARK,RMAR,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); RMAR := LINELENGTH NIL; X := GET('!*SEMICOL!*,PRETOP); !*N := 0; MPRINO1(U,LIST(CAAR X,CADAR X)); PRIN2OX ";"; OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE RPRIN1 U; BEGIN SCALAR BUFF,BUFFP,CURMARK,X; CURMARK := 0; BUFF := BUFFP := LIST LIST(0,0); X := GET('!*SEMICOL!*,PRETOP); MPRINO1(U,LIST(CAAR X,CADAR X)); OMARKO CURMARK; PRINOS BUFF END; SYMBOLIC PROCEDURE MPRINO U; MPRINO1(U,LIST(0,0)); SYMBOLIC PROCEDURE MPRINO1(U,V); BEGIN SCALAR X; IF X := ATSOC(U,COMBUFF) THEN <<FOR EACH Y IN CDR X DO COMPROX Y; COMBUFF := DELETE(X,COMBUFF)>>; IF NUMBERP U AND U<0 AND (X := GET('DIFFERENCE,PRETOP)) THEN RETURN BEGIN SCALAR P; X := CAR X; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; PRINOX U; IF P THEN PRINOX ")" END ELSE IF ATOM U THEN RETURN PRINOX U ELSE IF NOT ATOM CAR U THEN <<CURMARK := CURMARK+1; PRIN2OX "("; MPRINO CAR U; PRIN2OX ")"; OMARK LIST(CURMARK,3); CURMARK := CURMARK-1>> ELSE IF X := GET(CAR U,PRETOPRINF) THEN RETURN BEGIN SCALAR P; P := CAR V>0 AND NOT CAR U MEMQ '(BLOCK PROG QUOTE STRING); IF P THEN PRIN2OX "("; APPLY(X,LIST CDR U); IF P THEN PRIN2OX ")" END ELSE IF X := GET(CAR U,PRETOP) THEN RETURN IF CAR X THEN INPRINOX(U,CAR X,V) ELSE IF CDDR U THEN REDERR "Syntax error" ELSE IF NULL CADR X THEN INPRINOX(U,LIST(100,1),V) ELSE INPRINOX(U,LIST(100,CADR X),V) ELSE PRINOX CAR U; IF RLISTATP CAR U THEN RETURN RLPRI(CDR U,V); U := CDR U; IF NULL U THEN PRIN2OX "()" ELSE MPRARGS(U,V) END; SYMBOLIC PROCEDURE MPRARGS(U,V); IF NULL CDR U THEN <<PRIN2OX " "; MPRINO1(CAR U,LIST(100,100))>> ELSE INPRINOX('!*COMMA!* . U,LIST(0,0),V); SYMBOLIC PROCEDURE INPRINOX(U,X,V); BEGIN SCALAR P; P := (NOT CAR X>CADR V) OR (NOT CADR X>CAR V); IF P THEN PRIN2OX "("; OMARK '(M U); INPRINO(CAR U,X,CDR U); IF P THEN PRIN2OX ")"; OMARK '(M D) END; SYMBOLIC PROCEDURE INPRINO(OPR,V,L); BEGIN SCALAR FLG,X; CURMARK := CURMARK+2; X := GET(OPR,PRETOP); IF X AND CAR X THEN <<MPRINO1(CAR L,LIST(CAR V,0)); L := CDR L; FLG := T>>; WHILE L DO <<IF OPR EQ '!*COMMA!* THEN <<PRIN2OX ","; OMARKO CURMARK>> ELSE IF OPR EQ 'SETQ THEN <<PRIN2OX " := "; OMARK LIST(CURMARK,1)>> ELSE IF ATOM CAR L OR NOT OPR EQ GET!*(CAAR L,'ALT) THEN <<OMARK LIST(CURMARK,1); OPRINO(OPR,FLG); FLG := T>>; MPRINO1(CAR L,LIST(IF NULL CDR L THEN 0 ELSE CAR V, IF NULL FLG THEN 0 ELSE CADR V)); L := CDR L>>; CURMARK := CURMARK-2 END; SYMBOLIC PROCEDURE OPRINO(OPR,B); (LAMBDA X; IF NULL X THEN <<IF B THEN PRIN2OX " "; PRINOX OPR; PRIN2OX " ">> ELSE PRIN2OX CAR X) GET(OPR,'PRTCH); SYMBOLIC PROCEDURE PRIN2OX U; <<RPLACD(BUFFP,EXPLODE2 U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE PRINOX U; <<RPLACD(BUFFP,EXPLODE U); WHILE CDR BUFFP DO BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE GET!*(U,V); IF NUMBERP U THEN NIL ELSE GET(U,V); SYMBOLIC PROCEDURE OMARK U; <<RPLACD(BUFFP,LIST U); BUFFP := CDR BUFFP>>; SYMBOLIC PROCEDURE OMARKO U; OMARK LIST(U,0); SYMBOLIC PROCEDURE COMPROX U; BEGIN SCALAR X; IF CAR BUFFP = '(0 0) THEN RETURN <<FOR EACH J IN U DO PRIN2OX J; OMARK '(0 0)>>; X := CAR BUFFP; RPLACA(BUFFP,LIST(CURMARK+1,3)); FOR EACH J IN U DO PRIN2OX J; OMARK X END; SYMBOLIC PROCEDURE RLISTATP U; GET(U,'STAT) MEMBER '(ENDSTAT RLIS); SYMBOLIC PROCEDURE RLPRI(U,V); IF NULL U THEN NIL ELSE BEGIN PRIN2OX " "; OMARK '(M U); INPRINO('!*COMMA!*,LIST(0,0),U); OMARK '(M D) END; SYMBOLIC PROCEDURE CONDOX U; BEGIN SCALAR X; OMARK '(M U); CURMARK := CURMARK+2; WHILE U DO <<PRIN2OX "IF "; MPRINO CAAR U; OMARK LIST(CURMARK,1); PRIN2OX " THEN "; IF CDR U AND EQCAR(CADAR U,'COND) AND NOT EQCAR(CAR REVERSE CADAR U,'T) THEN <<X := T; PRIN2OX "(">>; MPRINO CADAR U; IF X THEN PRIN2OX ")"; U := CDR U; IF U THEN <<OMARKO(CURMARK-1); PRIN2OX " ELSE ">>; IF U AND NULL CDR U AND CAAR U EQ 'T THEN <<MPRINO CADAR U; U := NIL>>>>; CURMARK := CURMARK-2; OMARK '(M D) END; PUT('COND,PRETOPRINF,'CONDOX); SYMBOLIC PROCEDURE BLOCKOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "BEGIN "; IF CAR U THEN VARPRX CAR U; U := LABCHK CDR U; OMARK LIST(CURMARK,IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3); WHILE U DO <<MPRINO CAR U; IF NOT EQCAR(CAR U,'!*LABEL) AND CDR U THEN PRIN2OX "; "; U := CDR U; IF U THEN OMARK LIST(CURMARK, IF EQCAR(CAR U,'!*LABEL) THEN 1 ELSE 3)>>; OMARK LIST(CURMARK-1,-1); PRIN2OX " END"; CURMARK := CURMARK-2; OMARK '(M D) END; SYMBOLIC PROCEDURE RETOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+2; PRIN2OX "RETURN "; OMARK '(M U); MPRINO CAR U; CURMARK := CURMARK-2; OMARK '(M D); OMARK '(M D) END; PUT('RETURN,PRETOPRINF,'RETOX); SYMBOLIC PROCEDURE VARPRX U; MAPC(CDR U,FUNCTION (LAMBDA J; <<PRIN2OX CAR J; PRIN2OX " "; INPRINO('!*COMMA!*,LIST(0,0),CDR J); PRIN2OX "; "; OMARK LIST(CURMARK,6)>>)); COMMENT a version for the old parser; SYMBOLIC PROCEDURE VARPRX U; BEGIN SCALAR TYP; U := REVERSE U; WHILE U DO <<IF CDAR U EQ TYP THEN <<PRIN2OX ","; OMARKO(CURMARK+1); PRINOX CAAR U>> ELSE <<IF TYP THEN <<PRIN2OX "; "; OMARK '(M D)>>; PRINOX (TYP := CDAR U); PRIN2OX " "; OMARK '(M U); PRINOX CAAR U>>; U := CDR U>>; PRIN2OX "; "; OMARK '(M D) END; PUT('BLOCK,PRETOPRINF,'BLOCKOX); SYMBOLIC PROCEDURE PROGOX U; BLOCKOX(MAPCAR(REVERSE CAR U,FUNCTION (LAMBDA J; J . 'SCALAR)) . CDR U); SYMBOLIC PROCEDURE LABCHK U; BEGIN SCALAR X; FOR EACH Z IN U DO IF ATOM Z THEN X := LIST('!*LABEL,Z) . X ELSE X := Z . X; RETURN REVERSIP X END; PUT('PROG,PRETOPRINF,'PROGOX); SYMBOLIC PROCEDURE GOX U; <<PRIN2OX "GO TO "; PRINOX CAR U>>; PUT('GO,PRETOPRINF,'GOX); SYMBOLIC PROCEDURE LABOX U; <<PRINOX CAR U; PRIN2OX ": ">>; PUT('!*LABEL,PRETOPRINF,'LABOX); SYMBOLIC PROCEDURE QUOTOX U; IF STRINGP U THEN PRINOX U ELSE <<PRIN2OX "'"; PRINSOX CAR U>>; SYMBOLIC PROCEDURE PRINSOX U; IF ATOM U THEN PRINOX U ELSE <<PRIN2OX "("; OMARK '(M U); CURMARK := CURMARK+1; WHILE U DO <<PRINSOX CAR U; U := CDR U; IF U THEN <<OMARK LIST(CURMARK,-1); IF ATOM U THEN <<PRIN2OX " . "; PRINSOX U; U := NIL>> ELSE PRIN2OX " ">>>>; CURMARK := CURMARK-1; OMARK '(M D); PRIN2OX ")">>; PUT('QUOTE,PRETOPRINF,'QUOTOX); SYMBOLIC PROCEDURE PROGNOX U; BEGIN CURMARK := CURMARK+1; PRIN2OX "<<"; OMARK '(M U); WHILE U DO <<MPRINO CAR U; U := CDR U; IF U THEN <<PRIN2OX "; "; OMARKO CURMARK>>>>; OMARK '(M D); PRIN2OX ">>"; CURMARK := CURMARK-1 END; PUT('PROG2,PRETOPRINF,'PROGNOX); PUT('PROGN,PRETOPRINF,'PROGNOX); SYMBOLIC PROCEDURE REPEATOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "REPEAT "; MPRINO CAR U; PRIN2OX " UNTIL "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('REPEAT,PRETOPRINF,'REPEATOX); SYMBOLIC PROCEDURE WHILEOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "WHILE "; MPRINO CAR U; PRIN2OX " DO "; OMARK LIST(CURMARK,3); MPRINO CADR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('WHILE,PRETOPRINF,'WHILEOX); SYMBOLIC PROCEDURE PROCOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; IF CADDDR CDR U THEN <<MPRINO CADDDR CDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCOX1(CAR U,CADR U,CADDR U) END; SYMBOLIC PROCEDURE PROCOX1(U,V,W); BEGIN PRINOX U; IF V THEN MPRARGS(V,LIST(0,0)); PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK-1; OMARK '(M D) END; PUT('PROC,PRETOPRINF,'PROCOX); SYMBOLIC PROCEDURE PROCEOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; MPRINO CADR U; PRIN2OX " "; IF NOT CADDR U EQ 'EXPR THEN <<MPRINO CADDR U; PRIN2OX " ">>; PRIN2OX "PROCEDURE "; PROCEOX1(CAR U,CADDDR U,CAR CDDDDR U) END; SYMBOLIC PROCEDURE PROCEOX1(U,V,W); BEGIN PRINOX U; IF V THEN <<IF NOT ATOM CAR V THEN V:= FOR EACH J IN V COLLECT CAR J; %allows for typing to be included with proc arguments; MPRARGS(V,LIST(0,0))>>; PRIN2OX "; "; OMARK LIST(CURMARK,3); MPRINO W; CURMARK := CURMARK -1; OMARK '(M D) END; PUT('PROCEDURE,PRETOPRINF,'PROCEOX); SYMBOLIC PROCEDURE PROCEOX0(U,V,W,X); PROCEOX LIST(U,'SYMBOLIC,V, MAPCAR(W,FUNCTION (LAMBDA J; J . 'SYMBOLIC)),X); SYMBOLIC PROCEDURE DEOX U; PROCEOX0(CAR U,'EXPR,CADR U,CADDR U); PUT('DE,PRETOPRINF,'DEOX); SYMBOLIC PROCEDURE DFOX U; PROCEOX0(CAR U,'FEXPR,CADR U,CADDR U); %PUT('DF,PRETOPRINF,'DFOX); %commented out because of confusion with %differentiation; SYMBOLIC PROCEDURE STRINGOX U; <<PRIN2OX '!"; PRIN2OX CAR U; PRIN2OX '!">>; PUT('STRING,PRETOPRINF,'STRINGOX); SYMBOLIC PROCEDURE LAMBDOX U; BEGIN OMARK '(M U); CURMARK := CURMARK+1; PROCOX1('LAMBDA,CAR U,CADR U) END; PUT('LAMBDA,PRETOPRINF,'LAMBDOX); SYMBOLIC PROCEDURE EACHOX U; <<PRIN2OX "FOR EACH "; WHILE CDR U DO <<MPRINO CAR U; PRIN2OX " "; U := CDR U>>; MPRINO CAR U>>; PUT('FOREACH,PRETOPRINF,'EACHOX); SYMBOLIC PROCEDURE FOROX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "FOR "; MPRINO CAR U; PRIN2OX " := "; MPRINO CAADR U; IF CADR CADR U NEQ 1 THEN <<PRIN2OX " STEP "; MPRINO CADR CADR U; PRIN2OX " UNTIL ">> ELSE PRIN2OX ":"; MPRINO CADDR CADR U; PRIN2OX " "; MPRINO CADDR U; PRIN2OX " "; OMARK LIST(CURMARK,3); MPRINO CADDDR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('FOR,PRETOPRINF,'FOROX); SYMBOLIC PROCEDURE FORALLOX U; BEGIN CURMARK := CURMARK+1; OMARK '(M U); PRIN2OX "FOR ALL "; INPRINO('!*COMMA!*,LIST(0,0),CAR U); IF CADR U THEN <<OMARK LIST(CURMARK,3); PRIN2OX " SUCH THAT "; MPRINO CADR U>>; PRIN2OX " "; OMARK LIST(CURMARK,3); MPRINO CADDR U; OMARK '(M D); CURMARK := CURMARK-1 END; PUT('FORALL,PRETOPRINF,'FORALLOX); COMMENT Declarations needed by old parser; IF NULL GET('!*SEMICOL!*,'OP) THEN <<PUT('!*SEMICOL!*,'OP,'((-1 0))); PUT('!*COMMA!*,'OP,'((5 6)))>>; COMMENT RPRINT MODULE, Part 2; FLUID '(ORIG CURPOS); SYMBOLIC PROCEDURE PRINOS U; BEGIN INTEGER CURPOS; SCALAR ORIG; ORIG := LIST POSN(); CURPOS := CAR ORIG; PRINOY(U,0); TERPRI0X() END; SYMBOLIC PROCEDURE PRINOY(U,N); BEGIN SCALAR X; IF CAR(X := SPACELEFT(U,N)) THEN RETURN PRINOM(U,N) ELSE IF NULL CDR X THEN RETURN IF CAR ORIG<10 THEN PRINOM(U,N) ELSE <<ORIG := 9 . CDR ORIG; TERPRI0X(); SPACES2(CURPOS := 9+CADAR U); PRINOY(U,N)>> ELSE BEGIN A: U := PRINOY(U,N+1); IF NULL CDR U OR CAAR U<=N THEN RETURN; TERPRI0X(); SPACES2(CURPOS := CAR ORIG+CADAR U); GO TO A END; RETURN U END; SYMBOLIC PROCEDURE SPACELEFT(U,MARK); %U is an expanded buffer of characters delimited by non-atom marks %of the form: '(M ...) or '(INT INT)) %MARK is an integer; BEGIN INTEGER N; SCALAR FLG,MFLG; N := RMAR - CURPOS; U := CDR U; %move over the first mark; WHILE U AND NOT FLG AND N>=0 DO <<IF ATOM CAR U THEN N := N-1 ELSE IF CAAR U EQ 'M THEN NIL ELSE IF MARK>=CAAR U THEN <<FLG := T; U := NIL . U>> ELSE MFLG := T; U := CDR U>>; RETURN ((N>=0) . MFLG) END; SYMBOLIC PROCEDURE PRINOM(U,MARK); BEGIN INTEGER N; SCALAR FLG,X; N := CURPOS; U := CDR U; WHILE U AND NOT FLG DO <<IF ATOM CAR U THEN <<X := PRIN20X CAR U; N := N+1>> ELSE IF CAAR U EQ 'M THEN IF CADAR U EQ 'U THEN ORIG := N . ORIG ELSE ORIG := CDR ORIG ELSE IF MARK>=CAAR U AND NOT(X='!, AND RMAR-N-6>CHARSPACE(U,X,MARK)) THEN <<FLG := T; U := NIL . U>>; U := CDR U>>; CURPOS := N; IF MARK=0 AND CDR U THEN <<TERPRI0X(); TERPRI0X(); ORIG := LIST 0; CURPOS := 0; PRINOY(U,MARK)>>; %must be a top level constant; RETURN U END; SYMBOLIC PROCEDURE CHARSPACE(U,CHAR,MARK); %determines if there is space until the next character CHAR; BEGIN INTEGER N; N := 0; WHILE U DO <<IF CAR U = CHAR THEN U := LIST NIL ELSE IF ATOM CAR U THEN N := N+1 ELSE IF CAR U='(M U) THEN <<N := 1000; U := LIST NIL>> ELSE IF NUMBERP CAAR U AND CAAR U<MARK THEN U := LIST NIL; U := CDR U>>; RETURN N END; SYMBOLIC PROCEDURE SPACES2 N; %FOR I := 1:N DO PRIN20X '! ; WHILE N>0 DO <<PRIN20X '! ; N := N-1>>; SYMBOLIC PROCEDURE PRIN2ROX U; BEGIN INTEGER M,N; SCALAR X,Y; M := RMAR-12; N := RMAR-1; WHILE U DO IF CAR U EQ '!" THEN <<IF NOT STRINGSPACE(CDR U,N-!*N) THEN <<TERPRI0X(); !*N := 0>> ELSE NIL; PRIN20X '!"; U := CDR U; WHILE NOT CAR U EQ '!" DO <<PRIN20X CAR U; U := CDR U; !*N := !*N+1>>; PRIN20X '!"; U := CDR U; !*N := !*N+2; X := Y := NIL>> ELSE IF ATOM CAR U AND NOT(CAR U EQ '! AND (!*N=0 OR NULL X OR CDR U AND BREAKP CADR U OR BREAKP X AND NOT Y EQ '!!)) THEN <<Y := X; PRIN20X(X := CAR U); !*N := !*N+1; U := CDR U; IF !*N=N OR !*N>M AND NOT BREAKP CAR U AND NOSPACE(U,N-!*N) THEN <<TERPRI0X(); X := Y := NIL>> ELSE NIL>> ELSE U := CDR U END; SYMBOLIC PROCEDURE NOSPACE(U,N); IF N<1 THEN T ELSE IF NULL U THEN NIL ELSE IF NOT ATOM CAR U THEN NOSPACE(CDR U,N) ELSE IF NOT CAR U EQ '!! AND (CADR U EQ '! OR BREAKP CADR U) THEN NIL ELSE NOSPACE(CDR U,N-1); SYMBOLIC PROCEDURE BREAKP U; U MEMBER '(!< !> !; !: != !) !+ !- !, !' !"); SYMBOLIC PROCEDURE STRINGSPACE(U,N); IF N<1 THEN NIL ELSE IF CAR U EQ '!" THEN T ELSE STRINGSPACE(CDR U,N-1); COMMENT Some interfaces needed; PUT('CONS,'PRTCH,'(! !.! !.)); GLOBAL '(RPRIFN!* RTERFN!*); COMMENT RPRIFN!* allows output from RPRINT to be handled differently, RTERFN!* allows end of lines to be handled differently; SYMBOLIC PROCEDURE PRIN20X U; IF RPRIFN!* THEN APPLY(RPRIFN!*,LIST U) ELSE PRIN2 U; SYMBOLIC PROCEDURE TERPRI0X; IF RTERFN!* THEN APPLY(RTERFN!*,NIL) ELSE TERPRI(); END; |
Added r30/sl.doc version [403b90d388].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 | UCP-60 January 1978 First Revision - August 1978 STANDARD LISP REPORT J. B. Marti A. C. Hearn M. L. Griss C. Griss University of Utah Salt Lake City, UT 84112 UUCS-78-101 ABSTRACT: A description of Standard LISP primitive data structures and functions is presented. Work supported in part by the National Science Foundation under Grant No. MCS76-15035 and by the Burroughs Corporation. Standard LISP Report. 1 1. Introduction. 1. Introduction. Although the programming language LISP was first formulated in 1960 [6], a widely accepted standard has never appeared. As a result, various dialects of LISP have been produced [4-12], in some cases several on the same machine! Consequently, a user often faces considerable difficulty in moving programs from one system to another. In addition, it is difficult to write and use programs which depend on the structure of the source code such as translators, editors and cross-reference programs. In 1969, a model for such a standard was produced [2] as part of a general effort to make a large LISP based algebraic manipulation program, REDUCE [3], as portable as possible. The goal of this work was to define a uniform subset of LISP 1.5 and its variants so that programs written in this subset could run on any reasonable LISP system. In the intervening years, two deficiencies in the approach taken in Ref. [2] have emerged. First in order to be as general as possible, the specific semantics and values of several key functions were left undefined. Consequently, programs built on this subset could not make any assumptions about the form of the values of such functions. The second deficiency related to the proposed method of implementation of this language. The model considered in effect two versions of LISP on any given machine, namely Standard LISP and the LISP of the host machine (which we shall refer to as Target LISP). This meant that if any definition was stored in interpretive form, it would vary from implementation to implementation, and consequently one could not write programs in Standard LISP which needed to assume any knowledge about the structure of such forms. This deficiency became apparent during recent work on the development of a portable compiler for LISP [1]. Clearly a compiler has to know precisely the structure of its source code; we concluded that the appropriate source was Standard LISP and not Target LISP. With these thoughts in mind we decided to attempt again a definition of Standard LISP. However, our approach this time is more aggressive. In this document we define a standard for a reasonably large subset of LISP with as precise as possible a statement about the semantics of each function. Secondly, we now require that the target machine interpreter be modified or written to support this standard, rather than mapping Standard LISP onto Target LISP as previously. We have spent countless hours in discussion over many of the definitions given in this report. We have also drawn on the help and advice of a lot of friends whose names are given in the Acknowledgements. Wherever possible, we have used the definition of a function as given in the LISP 1.5 Programmer's Manual [6] and have only deviated where we felt it desirable in the light of LISP programming experience since that time. In particular, we have given Standard LISP Report. 2 1. Introduction. considerable thought to the question of variable bindings and the definition of the evaluator functions EVAL and APPLY. We have also abandoned the previous definition of LISP arrays in favor of the more accepted idea of a vector which most modern LISP systems support. These are the places where we have strayed furthest from the conventional definitions, but we feel that the consistency which results from our approach is worth the redefinition. We have avoided entirely in this report problems which arise from environment passing, such as those represented by the FUNARG problem. We do not necessarily exclude these considerations from our standard, but in this report have decided to avoid the controversy which they create. The semantic differences between compiled and interpreted functions is the topic of another paper [1]. Only functions which affect the compiler in a general way make reference to it. This document is not intended as an introduction to LISP rather it is assumed that the reader is already familiar with some version. The document is thus intended as an arbiter of the syntax and semantics of Standard LISP. However, since it is not intended as an implementation description, we deliberately leave unspecified many of the details on which an actual implementation depends. For example, while we assume the existence of a symbol table for atoms (the "object list" in LISP terminology), we do not specify its structure, since conventional LISP programming does not require this information. Our ultimate goal, however, is to remedy this by defining an interpreter for Standard LISP which is sufficiently complete that its implementation on any given computer will be straightforward and precise. At that time, we shall produce an implementation level specification for Standard LISP which will extend the description of the primitive functions defined herein by introducing a new set of lower level primitive functions in which the structure of the symbol table, heap and so on may be defined. The plan of this paper is as follows. In Section 2 we describe the various data types used in Standard LISP. In Section 3, a description of all Standard LISP functions is presented, organized by type. These functions are defined in an ALGOL-like syntax which is easier to read than LISP S-expressions. Section 4 describes global variables which control the operation of Standard LISP. For completeness, a formal translation of the extended syntax to Standard LISP is given in Appendix A. In Appendix B is an alphabetical list of all defined LISP functions and their arguments and types for easy reference. A complete index of all functions and concepts concludes the report. Standard LISP Report. 3 2. Preliminaries. 2.1 Primitive Data Types. integer - Integers are also called "fixed" numbers. The magnitude of an integer is unrestricted. Integers in the LISP input stream are recognized by the grammar: <digit> ::= 0|1|2|3|4|5|6|7|8|9 <unsigned-integer> ::= <digit>|<unsigned-integer><digit> <integer> ::= <unsigned-integer> | +<unsigned-integer> | -<unsigned-integer> floating - Any floating point number. The precision of floating point numbers is determined solely by the implementation. In BNF floating point numbers are recognized by the grammar: <base> ::= <unsigned-integer>.|.<unsigned-integer>| <unsigned-integer>.<unsigned-integer> <unsigned-floating> ::= <base>| <base>E<unsigned-integer>| <base>E-<unsigned-integer>| <base>E+<unsigned-integer> <floating> ::= <unsigned-floating>| +<unsigned-floating>|-<unsigned-floating> id - An identifier is a string of characters which may have the following items associated with it. print name - The characters of the identifier. flags - An identifier may be tagged with a flag. Access is by the FLAG, REMFLAG, and FLAGP functions defined in the "Property List Functions" section. properties - An identifier may have an indicator-value pair associated with it. Access is by the PUT, GET, and REMPROP functions defined in the "Property List Functions" section. values/functions - An identifier may have a value associated with it. Access to values is by SET and SETQ defined in the "Variables and Bindings" section. The method by which the value is attached to the identifier is known as the binding type, being one of LOCAL, GLOBAL, or FLUID. Access to the binding type is by the GLOBAL, GLOBALP, FLUID, FLUIDP, and UNFLUID functions. An identifier may have a function or macro associated with it. Access is by the PUTD, GETD, and REMD functions defined in the "Function Definition" section. An identifier may not have both a function and a value associated with it. OBLIST entry - An identifier may be entered and removed from a Standard LISP Report. 4 2. Preliminaries. structure called the OBLIST. Its presence on the OBLIST does not directly affect the other properties. Access to the OBLIST is by INTERN, REMOB, and READ defined in the "Identifiers" and "Input and Output" sections. The maximum length of a Standard LISP identifier is 24 characters (excluding occurrences of the escape character !) but an implementation may allow more. Special characters (digits in the first position and punctuation) must be prefixed with an escape character, an ! in Standard LISP. In BNF identifiers are recognized by the grammar: <special-character> ::= !<any-character> <alphabetic> ::= 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| 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 <lead-character> ::= <special-character>|<alphabetic> <regular-character> ::= <lead-character>|<digit> <last-part> ::= <regular-character>| <last-part><regular-character> <id> ::= <lead-character>|<lead-character><last-part> Note: Using lower case letters in identifiers may cause portability problems. Lower case letters are automatically converted to upper case when the !*RAISE flag is T. See the "System GLOBAL Variables" section. string - A set of characters enclosed in double quotes as in "THIS IS A STRING". A quote is included by doubling it as in "HE SAID, ""LISP""". The maximum size of strings is 80 characters but an implementation may allow more. Strings are not part of the OBLIST and are considered constants like numbers, vectors, and function-pointers. dotted-pair - A primitive structure which has a left and right part. A notation called dot-notation is used for dotted pairs and takes the form: (<left-part> . <right-part>) The <left-part> is known as the CAR portion and the <right-part> as the CDR portion. The left and right parts may be of any type. Spaces are used to resolve ambiguity with floating point numbers. vector - A primitive uniform structure in which an integer index is used to access random values in the structure. The individual elements of a vector may be of any type. Access to vectors is restricted to functions defined in the "Vectors" section. A notation for vectors, vector-notation, has the elements of a vector separated by commas and surrounded by square brackets. Standard LISP Report. 5 2. Preliminaries. <elements> ::= <any>|<any>, <elements> <vector> ::= [<elements>] function-pointer - An implementation may have functions which deal with specific data types other than those listed. The use of these entities is to be avoided with the exception of a restricted use of the function-pointer, an access method to compiled EXPRs and FEXPRs. A particular function-pointer must remain valid throughout execution. Systems which change the location of a function must use either an indirect reference or change all occurrences of the associated value. There are two classes of use of function-pointers, those which are supported by Standard LISP but are not well defined, and those which are well defined. Not well defined - Function pointers may be displayed by the print functions or expanded by EXPLODE. The value appears in the convention of the implementation site. The value is not defined in Standard LISP. Function pointers may be created by COMPRESS in the format used for printing but the value used is not defined in Standard LISP. Function pointers may be created by functions which deal with compiled function loading. Again, the values created are not well defined in Standard LISP. Well defined - The function pointer associated with a EXPR or FEXPR may be retrieved by GETD and is valid as long as Standard LISP is in execution. Function pointers may be stored using PUTD, PUT, SETQ and the like or by being bound to variables. Function pointers may be checked for equivalence by EQ. The value may be checked for being a function pointer by the CODEP function. 2.2 Classes of Primitive Data Types. The classes of primitive types are a notational convenience for describing the properties of functions. boolean - The set of global variables {T,NIL}, or their respective values, {T, NIL}. (see the "System GLOBAL Variables" section). extra-boolean - Any value in the system. Anything that is not NIL has the boolean interpretation T. ftype - The class of definable function types. The set of ids {EXPR, FEXPR, MACRO}. number - The set of {integer, floating}. Standard LISP Report. 6 2. Preliminaries. constant - The set of {integer, floating, string, vector, function-pointer}. Constants evaluate to themselves (see the definition of EVAL in "The Interpreter" section). any - The set of {integer, floating, string, id, dotted-pair, vector, function-pointer}. An S-expression is another term for any. All Standard LISP entities have some value unless an ERROR occurs during evaluation. atom - The set {any}-{dotted-pair}. 2.3 Structures. Structures are entities created out of the primitive types by the use of dotted-pairs. Lists are structures very commonly required as actual parameters to functions. Where a list of homogeneous entities is required by a function this class will be denoted by xxx-list where xxx is the name of a class of primitives or structures. Thus a list of ids is an id-list, a list of integers an integer-list and so on. list - A list is recursively defined as NIL or the dotted-pair (any . list). A special notation called list-notation is used to represent lists. List-notation eliminates extra parentheses and dots. The list (a . (b . (c . NIL))) in list notation is (a b c). List-notation and dot-notation may be mixed as in (a b . c) or (a (b . c) d) which are (a . (b . c)) and (a . ((b . c) . (d . NIL))). In BNF lists are recognized by the grammar: <left-part> ::= ( | <left-part> <any> <list> ::= <left-part>) | <left-part> . <any>) Note: () is an alternate input representation of NIL. alist - An association list; each element of the list is a dotted-pair, the CAR part being a key associated with the value in the CDR part. cond-form - A cond-form is a list of 2 element lists of the form: (ANTECEDENT:any CONSEQUENT:any) The first element will henceforth be known as the antecedent and the second as the consequent. The antecedent must have a value. The consequent may have a value or an occurrence of GO or RETURN as described in the "Program Feature Functions" section. Standard LISP Report. 7 2. Preliminaries. lambda - A LAMBDA expression which must have the form (in list notation): (LAMBDA parameters body). "parameters" is a list of formal parameters for "body" an S-expression to be evaluated. The semantics of the evaluation are defined with the EVAL function (see "The Interpreter" section). function - A LAMBDA expression or a function-pointer to a function. A function is always evaluated as an EVAL, SPREAD form. 2.4 Function Descriptions. Each function is provided with a prototypical header line. Each formal parameter is given a name and suffixed with its allowed type. Lower case tokens are names of classes and upper case tokens are parameter names referred to in the definition. The type of the value returned by the function (if any) is suffixed to the parameter list. If it is not commonly used the parameter type may be a specific set enclosed in brackets {...}. For example: PUTD(FNAME:id, TYPE:ftype, BODY:{lambda, function-pointer}):id PUTD is a function with three parameters. The parameter FNAME is an id to be the name of the function being defined. TYPE is the type of the function being defined and BODY is a lambda expression or a function-pointer. PUTD returns the name of the function being defined. Functions which accept formal parameter lists of arbitrary length have the type class and parameter enclosed in square brackets indicating that zero or more occurrences of that argument are permitted. For example: AND([U:any]):extra-boolean AND is a function which accepts zero or more arguments which may be of any type. 2.5 Function Types. EVAL type functions are those which are invoked with evaluated arguments. NOEVAL functions are invoked with unevaluated arguments. SPREAD type functions have their arguments passed in one-to-one correspondence with their formal parameters. NOSPREAD functions receive their arguments as a single list. EVAL, SPREAD functions are associated with EXPRs and NOEVAL, NOSPREAD functions with FEXPRs. EVAL, NOSPREAD and NOEVAL, SPREAD functions can be simulated using NOEVAL, NOSPREAD functions or MACROs. Standard LISP Report. 8 2. Preliminaries. EVAL, SPREAD type functions may have a maximum of 15 parameters. There is no limit on the number of parameters a NOEVAL, NOSPREAD function or MACRO may have. In the context of the description of an EVAL, SPREAD function, when we speak of the formal parameters we mean their actual values. However, in a NOEVAL, NOSPREAD function it is the unevaluated actual parameters. A third function type, the MACRO, implements functions which create S-expressions based on actual parameters. When a macro invocation is encountered, the body of the macro, a lambda expression, is invoked as a NOEVAL, NOSPREAD function with the macro's invocation bound as a list to the macros single formal parameter. When the macro has been evaluated the resulting S-expression is reevaluated. The description of the EVAL and EXPAND functions provide precise details. 2.6 The Extended Syntax. Functions that may be conveniently defined in Standard LISP appear in a subset of the REDUCE syntax [3] which we believe is easier to read than Standard LISP. A formal translation scheme for the extended syntax to Standard LISP is presented in Appendix A. The definitions supplied are not intended as a rigorous implementation guide but rather as a precise definition of the function's semantics. 2.7 Error and Warning Messages. Many functions detect errors. The description of such functions will include these error conditions and suggested formats for display of the generated error messages. A call on the ERROR function is implied but the error number is not specified by Standard LISP. In some cases a warning message is sufficient. To distinguish between errors and warnings, errors are prefixed with five asterisks and warnings with only three. Primitive functions check arguments that must be of a certain primitive type for being of that type and display an error message if the argument is not correct. The type mismatch error always takes the form: ***** PARAMETER not TYPE for FN Here PARAMETER is the unacceptable actual parameter, TYPE is the type that PARAMETER was supposed to be. FN is the name of the function that detected the error. Standard LISP Report. 9 3.1 Elementary Predicates. 3.1 Elementary Predicates. Functions in this section return T when the condition defined is met and NIL when it is not. Defined are type checking functions and elementary comparisons. ATOM(U:any):boolean Type: EVAL, SPREAD Returns T if U is not a pair. EXPR PROCEDURE ATOM(U); NULL PAIRP U; CODEP(U:any):boolean TYPE: EVAL, SPREAD. Returns T if U is a function-pointer. CONSTANTP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a constant (a number, string, function-pointer, or vector). EXPR PROCEDURE CONSTANTP(U); NULL OR(PAIRP U, IDP U); EQ(U:any, V:any):boolean Type: EVAL, SPREAD Returns T if U points to the same object as V. EQ is not a reliable comparison between numeric arguments. EQN(U:any, V:any):boolean Type: EVAL, SPREAD Returns T if U and V are EQ or if U and V are numbers and have the same value and type. EQUAL(U:any, V:any):boolean Type: EVAL, SPREAD Returns T if U and V are the same. Dotted-pairs are compared recursively to the bottom levels of their trees. Vectors must have identical dimensions and EQUAL values in all positions. Strings must have identical characters. Function pointers must have EQ values. Other atoms must be EQN equal. Standard LISP Report. 10 3.1 Elementary Predicates. FIXP(U:any):boolean Type: EVAL, SPREAD Returns T if U is an integer (a fixed number). FLOATP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a floating point number. IDP(U:any):boolean Type: EVAL, SPREAD Returns T if U is an id. NULL(U:any):boolean Type: EVAL, SPREAD Returns T if U is NIL. EXPR PROCEDURE NULL(U); U EQ NIL; NUMBERP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a number (integer or floating). EXPR PROCEDURE NUMBERP(U); IF OR(FIXP U, FLOATP U) THEN T ELSE NIL; PAIRP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a dotted-pair. STRINGP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a string. VECTORP(U:any):boolean Type: EVAL, SPREAD Returns T if U is a vector. Standard LISP Report. 11 3.2 Functions on Dotted-Pairs. 3.2 Functions on Dotted-Pairs. The following are elementary functions on dotted-pairs. All functions in this section which require dotted-pairs as parameters detect a type mismatch error if the actual parameter is not a dotted-pair. CAR(U:dotted-pair):any Type: EVAL, SPREAD CAR(CONS a b) ==> a. The left part of U is returned. The type mismatch error occurs if U is not a dotted-pair. CDR(U:dotted-pair):any Type: EVAL, SPREAD CDR(CONS a b) ==> b. The right part of U is returned. The type mismatch error occurs if U is not a dotted-pair. The composites of CAR and CDR are supported up to 4 levels, namely: CAAAAR CAAAR CAAR CAAADR CAADR CADR CAADAR CADAR CDAR CAADDR CADDR CDDR CADAAR CDAAR CADADR CDADR CADDAR CDDAR CADDDR CDDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR CONS(U:any, V:any):dotted-pair Type: EVAL, SPREAD Returns a dotted-pair which is not EQ to anything and has U as its CAR part and V as its CDR part. LIST([U:any]):list Type: NOEVAL, NOSPREAD, or MACRO A list of the evaluation of each element of U is returned. FEXPR PROCEDURE LIST(U); EVLIS U; Standard LISP Report. 12 3.2 Functions on Dotted-Pairs. RPLACA(U:dotted-pair, V:any):dotted-pair Type: EVAL, SPREAD The CAR portion of the dotted-pair U is replaced by V. If dotted-pair U is (a . b) then (V . b) is returned. The type mismatch error occurs if U is not a dotted-pair. RPLACD(U:dotted-pair, V:any):dotted-pair Type: EVAL, SPREAD The CDR portion of the dotted-pair U is replaced by V. If dotted-pair U is (a . b) then (a . V) is returned. The type mismatch error occurs if U is not a dotted-pair. 3.3 Identifiers. The following functions deal with identifiers and the OBLIST, the structure of which is not defined. The function of the OBLIST is to provide a symbol table for identifiers created during input. Identifiers created by READ which have the same characters will therefore refer to the same object (see the EQ function in the "Elementary Predicates" section). COMPRESS(U:id-list):{atom}-{vector} Type: EVAL, SPREAD U is a list of single character identifiers which is built into a Standard LISP entity and returned. Recognized are numbers, strings, and identifiers with the escape character prefixing special characters. The formats of these items appear in the "Primitive Data Types" section. Identifiers are not interned on the OBLIST. Function pointers may be compressed but this is an undefined use. If an entity cannot be parsed out of U or characters are left over after parsing an error occurs: ***** Poorly formed atom in COMPRESS EXPLODE(U:{atom}-{vector}):id-list Type: EVAL, SPREAD Returned is a list of interned characters representing the characters to print of the value of U. The primitive data types have these formats: integer - Leading zeroes are suppressed and a minus sign prefixes the digits if the integer is negative. floating - The value appears in the format [-]0.nn...nnE[-]mm if the magnitude of the number is too large or small to display in [-]nnnn.nnnn format. The crossover point is determined by the implementation. Standard LISP Report. 13 3.3 Identifiers. id - The characters of the print name of the identifier are produced with special characters prefixed with the escape character. string - The characters of the string are produced surrounded by double quotes "...". function-pointer - The value of the function-pointer is created as a list of characters conforming to the conventions of the system site. The type mismatch error occurs if U is not a number, identifier, string, or function-pointer. GENSYM():id Creates an identifier which is not interned on the OBLIST and consequently not EQ to anything else. INTERN(U:{id,string}):id Type: EVAL, SPREAD INTERN searches the OBLIST for an identifier with the same print name as U and returns the identifier on the OBLIST if a match is found. Any properties and global values associated with U may be lost. If U does not match any entry, a new one is created and returned. If U has more than the maximum number of characters permitted by the implementation (the minimum number is 24) an error occurs: ***** Too many characters to INTERN REMOB(U:id):id Type: EVAL, SPREAD If U is present on the OBLIST it is removed. This does not affect U having properties, flags, functions and the like. U is returned. 3.4 Property List Functions. With each id in the system is a "property list", a set of entities which are associated with the id for fast access. These entities are called "flags" if their use gives the id a single valued property, and "properties" if the id is to have a multivalued attribute: an indicator with a property. Flags and indicators may clash, consequently care should be taken to avoid this occurrence. Flagging X with an id which already is an indicator for X may result in that indicator and associated Standard LISP Report. 14 3.4 Property List Functions. property being lost. Likewise, adding an indicator which is the same id as a flag may result in the flag being destroyed. FLAG(U:id-list, V:id):NIL Type: EVAL, SPREAD U is a list of ids which are flagged with V. The effect of FLAG is that FLAGP will have the value T for those ids of U which were flagged. Both V and all the elements of U must be identifiers or the type mismatch error occurs. FLAGP(U:any, V:any):boolean Type: EVAL, SPREAD Returns T if U has been previously flagged with V, else NIL. Returns NIL if either U or V is not an id. GET(U:any, IND:any):any Type: EVAL, SPREAD Returns the property associated with indicator IND from the property list of U. If U does not have indicator IND, NIL is returned. GET cannot be used to access functions (use GETD instead). PUT(U:id, IND:id, PROP:any):any Type: EVAL, SPREAD The indicator IND with the property PROP is placed on the property list of the id U. If the action of PUT occurs, the value of PROP is returned. If either of U and IND are not ids the type mismatch error will occur and no property will be placed. PUT cannot be used to define functions (use PUTD instead). REMFLAG(U:any-list, V:id):NIL Type: EVAL, SPREAD Removes the flag V from the property list of each member of the list U. Both V and all the elements of U must be ids or the type mismatch error will occur. REMPROP(U:any, IND:any):any Type: EVAL, SPREAD Removes the property with indicator IND from the property list of U. Returns the removed property or NIL if there was no such indicator. Standard LISP Report. 15 3.5 Function Definition. 3.5 Function Definition. Functions in Standard LISP are global entities. To avoid function-variable naming clashes no variable may have the same name as a function. DE(FNAME:id, PARAMS:id-list, FN:any):id Type: NOEVAL, NOSPREAD The function FN with the formal parameter list PARAMS is added to the set of defined functions with the name FNAME. Any previous definitions of the function are lost. The function created is of type EXPR unless the !*COMP variable is T in which case the EXPR is compiled. The name of the defined function is returned. FEXPR PROCEDURE DE(U); PUTD(CAR U, 'EXPR, LIST('LAMBDA, CADR U, CADDR U)); DF(FNAME:id, PARAM:id-list, FN:any):id Type: NOEVAL, NOSPREAD The function FN with formal parameter PARAM is added to the set of defined functions with the name FNAME. Any previous definitions of the function are lost. The function created is of type FEXPR unless the !*COMP variable is T in which case the FEXPR is compiled. The name of the defined function is returned. FEXPR PROCEDURE DF(U); PUTD(CAR U, 'FEXPR, LIST('LAMBDA, CADR U, CADDR U)); DM(MNAME:id, PARAM:id-list, FN:any):id Type: NOEVAL, NOSPREAD The macro FN with the formal parameter PARAM is added to the set of defined functions with the name MNAME. Any previous definitions of the function are overwritten. The function created is of type MACRO. The name of the macro is returned. FEXPR PROCEDURE DM(U); PUTD(CAR U, 'MACRO, LIST('LAMBDA, CADR U, CADDR U)); GETD(FNAME:any):{NIL, dotted-pair} Type: EVAL, SPREAD If FNAME is not the name of a defined function, NIL is returned. If FNAME is a defined function then the dotted-pair (TYPE:ftype . DEF:{function-pointer, lambda}) is returned. Standard LISP Report. 16 3.5 Function Definition. PUTD(FNAME:id, TYPE:ftype, BODY:function):id Type: EVAL, SPREAD Creates a function with name FNAME and definition BODY of type TYPE. If PUTD succeeds the name of the defined function is returned. The effect of PUTD is that GETD will return a dotted-pair with the functions type and definition. Likewise the GLOBALP predicate will return T when queried with the function name. If the function FNAME has already been declared as a GLOBAL or FLUID variable the error: ***** FNAME is a non-local variable occurs and the function will not be defined. If function FNAME already exists a warning message will appear: *** FNAME redefined The function defined by PUTD will be compiled before definition if the !*COMP global variable is non-NIL (see the "System GLOBAL Variables" section). REMD(FNAME:id):{NIL, dotted-pair} Type: EVAL, SPREAD Removes the function named FNAME from the set of defined functions. Returns the (ftype . function) dotted-pair or NIL as does GETD. The global/function attribute of FNAME is removed and the name may be used subsequently as a variable. 3.6 Variables and Bindings. A variable is a place holder for a Standard LISP entity which is said to be bound to the variable. The scope of a variable is the range over which the variable has a defined value. There are three different binding mechanisms in Standard LISP. Local Binding - This type of binding occurs only in compiled functions. Local variables occur as formal parameters in lambda expressions and as PROG form variables. The binding occurs when a lambda expression is evaluated or when a PROG form is executed. The scope of a local variable is the body of the function in which it is defined. Global Binding - Only one binding of a global variable exists at any time allowing direct access to the value bound to the variable. The scope of a global variable is universal. Variables declared GLOBAL may not appear as parameters in lambda expressions or as PROG form variables. A variable must be declared GLOBAL prior to its use as a global variable since the default type for undeclared variables is FLUID. Standard LISP Report. 17 3.6 Variables and Bindings. Fluid Binding - Fluid variables are global in scope but may occur as formal parameters or PROG form variables. In interpreted functions all formal parameters and PROG form variables are considered to have fluid binding until changed to local binding by compilation. When fluid variables are used as parameters they are rebound in such a way that the previous binding may be restored. All references to fluid variables are to the currently active binding. FLUID(IDLIST:id-list):NIL Type: EVAL, SPREAD The ids in IDLIST are declared as FLUID type variables (ids not previously declared are initialized to NIL). Variables in IDLIST already declared FLUID are ignored. Changing a variable's type from GLOBAL to FLUID is not permissible and results in the error: ***** ID cannot be changed to FLUID FLUIDP(U:any):boolean Type: EVAL, SPREAD If U has been declared FLUID (by declaration only) T is returned, otherwise NIL is returned. GLOBAL(IDLIST:id-list):NIL Type: EVAL, SPREAD The ids of IDLIST are declared global type variables. If an id has not been declared previously it is initialized to NIL. Variables already declared GLOBAL are ignored. Changing a variables type from FLUID to GLOBAL is not permissible and results in the error: ***** ID cannot be changed to GLOBAL GLOBALP(U:any):boolean Type: EVAL, SPREAD If U has been declared GLOBAL or is the name of a defined function, T is returned, else NIL is returned. Standard LISP Report. 18 3.6 Variables and Bindings. SET(EXP:id, VALUE:any):any Type: EVAL, SPREAD EXP must be an identifier or a type mismatch error occurs. The effect of SET is replacement of the item bound to the identifier by VALUE. If the identifier is not a local variable or has not been declared GLOBAL it is automatically declared FLUID with the resulting warning message: *** EXP declared FLUID EXP must not evaluate to T or NIL or an error occurs: ***** Cannot change T or NIL SETQ(VARIABLE:id, VALUE:any):any Type: NOEVAL, NOSPREAD If VARIABLE is not local or GLOBAL it is by default declared FLUID and the warning message: *** VARIABLE declared FLUID appears. The value of the current binding of VARIABLE is replaced by the value of VALUE. VARIABLE must not be T or NIL or an error occurs: ***** Cannot change T or NIL MACRO PROCEDURE SETQ(X); LIST('SET, LIST('QUOTE, CADR X), CADDR X); UNFLUID(IDLIST:id-list):NIL Type: EVAL, SPREAD The variables in IDLIST that have been declared as FLUID variables are no longer considered as fluid variables. Others are ignored. This affects only compiled functions as free variables in interpreted functions are automatically considered fluid (see Ref. [1]). 3.7 Program Feature Functions. These functions provide for explicit control sequencing, and the definition of blocks altering the scope of local variables. Standard LISP Report. 19 3.7 Program Feature Functions. GO(LABEL:id) Type: NOEVAL, NOSPREAD GO alters the normal flow of control within a PROG function. The next statement of a PROG function to be evaluated is immediately preceded by LABEL. A GO may only appear in the following situations: 1) At the top level of a PROG referencing a label which also appears at the top level of the same PROG. 2a) As the consequent of a COND item of a COND appearing on the top level of a PROG. 2b) As the consequent of a COND item which appears as the consequent of a COND item to any level. 3a) As the last statement of a PROGN which appears at the top level of a PROG or in a PROGN appearing in the consequent of a COND to any level subject to the restrictions of 2a,b. 3b) As the last statement of a PROGN within a PROGN or as the consequent of a COND in a PROGN to any level subject to the restrictions of 2a,b and 3a. If LABEL does not appear at the top level of the PROG in which the GO appears, an error occurs: ***** LABEL is not a known label If the GO has been placed in a position not defined by rules 1-3, another error is detected: ***** Illegal use of GO to LABEL PROG(VARS:id-list, [PROGRAM:{id, any}]):any Type: NOEVAL, NOSPREAD VARS is a list of ids which are considered fluid when the PROG is interpreted and local when compiled (see the "Variables and Bindings" section). The PROGs variables are allocated space when the PROG form is invoked and are deallocated when the PROG is exited. PROG variables are initialized to NIL. The PROGRAM is a set of expressions to be evaluated in order of their appearance in the PROG function. Identifiers appearing in the top level of the PROGRAM are labels which can be referenced by GO. The value returned by the PROG function is determined by a RETURN function or NIL if the PROG "falls through". PROGN([U:any]):any Type: NOEVAL, NOSPREAD U is a set of expressions which are executed sequentially. The value returned is the value of the last expression. Standard LISP Report. 20 3.7 Program Feature Functions. RETURN(U:any) Type: EVAL, SPREAD Within a PROG, RETURN terminates the evaluation of a PROG and returns U as the value of the PROG. The restrictions on the placement of RETURN are exactly those of GO. Improper placement of RETURN results in the error: ***** Illegal use of RETURN 3.8 Error Handling. ERROR(NUMBER:integer, MESSAGE:any) Type: EVAL, SPREAD NUMBER and MESSAGE are passed back to a surrounding ERRORSET (the Standard LISP reader has an ERRORSET). MESSAGE is placed in the global variable EMSG!* and the error number becomes the value of the surrounding ERRORSET. FLUID variables and local bindings are unbound to return to the environment of the ERRORSET. Global variables are not affected by the process. ERRORSET(U:any, MSGP:boolean, TR:boolean):any Type: EVAL, SPREAD If an error occurs during the evaluation of U, the value of NUMBER from the ERROR call is returned as the value of ERRORSET. In addition, if the value of MSGP is non-NIL, the MESSAGE from the ERROR call is displayed upon both the standard output device and the currently selected output device unless the standard output device is not open. The message appears prefixed with 5 asterisks. The MESSAGE list is displayed without top level parentheses. The MESSAGE from the ERROR call will be available in the global variable EMSG!*. The exact format of error messages generated by Standard LISP functions described in this document are not fixed and should not be relied upon to be in any particular form. Likewise, error numbers generated by Standard LISP functions are implementation dependent. If no error occurs during the evaluation of U, the value of (LIST (EVAL U)) is returned. If an error has been signaled and the value of TR is non-NIL a traceback sequence will be initiated on the selected output device. The traceback will display information such as unbindings of FLUID variables, argument lists and so on in an implementation dependent format. Standard LISP Report. 21 3.9 Vectors. 3.9 Vectors. Vectors are structured entities in which random elements may be accessed with an integer index. A vector has a single dimension. Its maximum size is determined by the implementation and available space. A suggested input output "vector notation" is defined (see "Classes of Primitive Data Types"). GETV(V:vector, INDEX:integer):any Type: EVAL, SPREAD Returns the value stored at position INDEX of the vector V. The type mismatch error may occur. An error occurs if the INDEX does not lie within 0...UPBV(V) inclusive: ***** INDEX subscript is out of range MKVECT(UPLIM:integer):vector Type: EVAL, SPREAD Defines and allocates space for a vector with UPLIM+1 elements accessed as 0...UPLIM. Each element is initialized to NIL. An error will occur if UPLIM is < 0 or there is not enough space for a vector of this size: ***** A vector of size UPLIM cannot be allocated PUTV(V:vector, INDEX:integer, VALUE:any):any Type: EVAL, SPREAD Stores VALUE into the vector V at position INDEX. VALUE is returned. The type mismatch error may occur. If INDEX does not lie in 0...UPBV(V) an error occurs: ***** INDEX subscript is out of range UPBV(U:any):{NIL,integer} Type: EVAL, SPREAD Returns the upper limit of U if U is a vector, or NIL if it is not. Standard LISP Report. 22 3.10 Boolean Functions and Conditionals. 3.10 Boolean Functions and Conditionals. AND([U:any]):extra-boolean Type: NOEVAL, NOSPREAD AND evaluates each U until a value of NIL is found or the end of the list is encountered. If a non-NIL value is the last value it is returned, or NIL is returned. FEXPR PROCEDURE AND(U); BEGIN IF NULL U THEN RETURN NIL; LOOP: IF NULL CDR U THEN RETURN EVAL CAR U ELSE IF NULL EVAL CAR U THEN RETURN NIL; U := CDR U; GO LOOP END; COND([U:cond-form]):any Type: NOEVAL, NOSPREAD The antecedents of all U's are evaluated in order of their appearance until a non-NIL value is encountered. The consequent of the selected U is evaluated and becomes the value of the COND. The consequent may also contain the special functions GO and RETURN subject to the restraints given for these functions in the "Program Feature Functions" section. In these cases COND does not have a defined value, but rather an effect. If no antecedent is non-NIL the value of COND is NIL. An error is detected if a U is improperly formed: ***** Improper cond-form as argument of COND NOT(U:any):boolean Type: EVAL, SPREAD If U is NIL, return T else return NIL (same as NULL function). EXPR PROCEDURE NOT(U); U EQ NIL; Standard LISP Report. 23 3.10 Boolean Functions and Conditionals. OR([U:any]):extra-boolean Type: NOEVAL, NOSPREAD U is any number of expressions which are evaluated in order of their appearance. When one is found to be non-NIL it is returned as the value of OR. If all are NIL, NIL is returned. FEXPR PROCEDURE OR(U); BEGIN SCALAR X; LOOP: IF NULL U THEN RETURN NIL ELSE IF (X := EVAL CAR U) THEN RETURN X; U := CDR U; GO LOOP END; 3.11 Arithmetic Functions. Conversions between numeric types are provided explicitly by the FIX and FLOAT functions and implicitly by any multi-parameter arithmetic function which receives mixed types of arguments. A conversion from fixed to floating point numbers may result in a loss of precision without a warning message being generated. Since integers may have a greater magnitude that that permitted for floating numbers, an error may be signaled when the attempted conversion cannot be done. Because the magnitude of integers is unlimited the conversion of a floating point number to a fixed number is always possible, the only loss of precision being the digits to the right of the decimal point which are truncated. If a function receives mixed types of arguments the general rule will have the fixed numbers converted to floating before arithmetic operations are performed. In all cases an error occurs if the parameter to an arithmetic function is not a number: ***** XXX parameter to FUNCTION is not a number XXX is the value of the parameter at fault and FUNCTION is the name of the function that detected the error. Exceptions to the rule are noted where they occur. ABS(U:number):number Type: EVAL, SPREAD Returns the absolute value of its argument. EXPR PROCEDURE ABS(U); IF LESSP(U, 0) THEN MINUS(U) ELSE U; Standard LISP Report. 24 3.11 Arithmetic Functions. DIFFERENCE(U:number, V:number):number Type: EVAL, SPREAD The value U - V is returned. DIVIDE(U:number, V:number):dotted-pair Type: EVAL, SPREAD The dotted-pair (quotient . remainder) is returned. The quotient part is computed the same as by QUOTIENT and the remainder the same as by REMAINDER. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in DIVIDE EXPR PROCEDURE DIVIDE(U, V); (QUOTIENT(U, V) . REMAINDER(U, V)); EXPT(U:number, V:integer):number Type: EVAL, SPREAD Returns U raised to the V power. A floating point U to an integer power V does not have V changed to a floating number before exponentiation. FIX(U:number):integer Type: EVAL, SPREAD Returns an integer which corresponds to the truncated value of U. The result of conversion must retain all significant portions of U. If U is an integer it is returned unchanged. FLOAT(U:number):floating Type: EVAL, SPREAD The floating point number corresponding to the value of the argument U is returned. Some of the least significant digits of an integer may be lost do to the implementaion of floating point numbers. FLOAT of a floating point number returns the number unchanged. If U is too large to represent in floating point an error occurs: ***** Argument to FLOAT is too large GREATERP(U:number, V:number):boolean Type: EVAL, SPREAD Returns T if U is strictly greater than V, otherwise returns NIL. LESSP(U:number, V:number):boolean Type: EVAL, SPREAD Returns T if U is strictly less than V, otherwise returns NIL. Standard LISP Report. 25 3.11 Arithmetic Functions. MAX([U:number]):number Type: NOEVAL, NOSPREAD, or MACRO Returns the largest of the values in U. If two or more values are the same the first is returned. MACRO PROCEDURE MAX(U); EXPAND(CDR U, 'MAX2); MAX2(U:number, V:number):number Type: EVAL, SPREAD Returns the larger of U and V. If U and V are the same value U is returned (U and V might be of different types). EXPR PROCEDURE MAX2(U, V); IF LESSP(U, V) THEN V ELSE U; MIN([U:number]):number Type: NOEVAL, NOSPREAD, or MACRO Returns the smallest of the values in U. If two ore more values are the same the first of these is returned. MACRO PROCEDURE MIN(U); EXPAND(CDR U, 'MIN2); MIN2(U:number, V:number):number Type: EVAL, SPREAD Returns the smaller of its arguments. If U and V are the same value, U is returned (U and V might be of different types). EXPR PROCEDURE MIN2(U, V); IF GREATERP(U, V) THEN V ELSE U; MINUS(U:number):number Type: EVAL, SPREAD Returns -U. EXPR PROCEDURE MINUS(U); DIFFERENCE(0, U); PLUS([U:number]):number Type: NOEVAL, NOSPREAD, or MACRO Forms the sum of all its arguments. MACRO PROCEDURE PLUS(U); EXPAND(CDR U, 'PLUS2); Standard LISP Report. 26 3.11 Arithmetic Functions. PLUS2(U:number, V:number):number Type: EVAL, SPREAD Returns the sum of U and V. QUOTIENT(U:number, V:number):number Type: EVAL, SPREAD The quotient of U divided by V is returned. Division of two positive or two negative integers is conventional. When both U and V are integers and exactly one of them is negative the value returned is the negative truncation of the absolute value of U divided by the absolute value of V. An error occurs if division by zero is attempted: ***** Attempt to divide by 0 in QUOTIENT REMAINDER(U:number, V:number):number Type: EVAL, SPREAD If both U and V are integers the result is the integer remainder of U divided by V. If either parameter is floating point, the result is the difference between U and V*(U/V) all in floating point. If either number is negative the remainder is negative. If both are positive or both are negative the remainder is positive. An error occurs if V is zero: ***** Attempt to divide by 0 in REMAINDER EXPR PROCEDURE REMAINDER(U, V); DIFFERENCE(U, TIMES2(QUOTIENT(U, V), V)); TIMES([U:number]):number Type: NOEVAL, NOSPREAD, or MACRO Returns the product of all its arguments. MACRO PROCEDURE TIMES(U); EXPAND(CDR U, 'TIMES2); TIMES2(U:number, V:number):number Type: EVAL, SPREAD Returns the product of U and V. Standard LISP Report. 27 3.12 MAP Composite Functions. 3.12 MAP Composite Functions. MAP(X:list, FN:function):any Type: EVAL, SPREAD Applies FN to successive CDR segments of X. NIL is returned. EXPR PROCEDURE MAP(X, FN); WHILE X DO << FN X; X := CDR X >>; MAPC(X:list, FN:function):any Type: EVAL, SPREAD FN is applied to successive CAR segments of list X. NIL is returned. EXPR PROCEDURE MAPC(X, FN); WHILE X DO << FN CAR X; X := CDR X >>; MAPCAN(X:list, FN:function):any Type: EVAL, SPREAD A concatenated list of FN applied to successive CAR elements of X is returned. EXPR PROCEDURE MAPCAN(X, FN); IF NULL X THEN NIL ELSE NCONC(FN CAR X, MAPCAN(CDR X, FN)); MAPCAR(X:list, FN:function):any Type: EVAL, SPREAD Returned is a constructed list of FN applied to each CAR of list X. EXPR PROCEDURE MAPCAR(X, FN); IF NULL X THEN NIL ELSE FN CAR X . MAPCAR(CDR X, FN); MAPCON(X:list, FN:function):any Type: EVAL, SPREAD Returned is a concatenated list of FN applied to successive CDR segments of X. EXPR PROCEDURE MAPCON(X, FN); IF NULL X THEN NIL ELSE NCONC(FN X, MAPCON(CDR X, FN)); Standard LISP Report. 28 3.12 MAP Composite Functions. MAPLIST(X:list, FN:function):any Type: EVAL, SPREAD Returns a constructed list of FN applied to successive CDR segments of X. EXPR PROCEDURE MAPLIST(X, FN); IF NULL X THEN NIL ELSE FN X . MAPLIST(CDR X, FN); 3.13 Composite Functions. APPEND(U:list, V:list):list Type: EVAL, SPREAD Returns a constructed list in which the last element of U is followed by the first element of V. The list U is copied, V is not. EXPR PROCEDURE APPEND(U, V); IF NULL U THEN V ELSE CAR U . APPEND(CDR U, V); ASSOC(U:any, V:alist):{dotted-pair, NIL} Type: EVAL, SPREAD If U occurs as the CAR portion of an element of the alist V, the dotted-pair in which U occurred is returned, else NIL is returned. ASSOC might not detect a poorly formed alist so an invalid construction may be detected by CAR or CDR. EXPR PROCEDURE ASSOC(U, V); IF NULL V THEN NIL ELSE IF ATOM CAR V THEN ERROR(000, LIST(V, "is a poorly formed alist")) ELSE IF U = CAAR V THEN CAR V ELSE ASSOC(U, CDR V); Standard LISP Report. 29 3.13 Composite Functions. DEFLIST(U:dlist, IND:id):list Type: EVAL, SPREAD A "dlist" is a list in which each element is a two element list: (ID:id PROP:any). Each ID in U has the indicator IND with property PROP placed on its property list by the PUT function. The value of DEFLIST is a list of the first elements of each two element list. Like PUT, DEFLIST may not be used to define functions. EXPR PROCEDURE DEFLIST(U, IND); IF NULL U THEN NIL ELSE <<PUT(CAAR U, IND, CADAR U); CAAR U >> . DEFLIST(CDR U, IND); DELETE(U:any, V:list):list Type: EVAL, SPREAD Returns V with the first top level occurrence of U removed from it. EXPR PROCEDURE DELETE(U, V); IF NULL V THEN NIL ELSE IF CAR V = U THEN CDR V ELSE CAR V . DELETE(U, CDR V); DIGIT(U:any):boolean Type: EVAL, SPREAD Returns T if U is a digit, otherwise NIL. EXPR PROCEDURE DIGIT(U); IF MEMQ(U, '(!0 !1 !2 !3 !4 !5 !6 !7 !8 !9)) THEN T ELSE NIL; LENGTH(X:any):integer Type: EVAL, SPREAD The top level length of the list X is returned. EXPR PROCEDURE LENGTH(X); IF ATOM X THEN 0 ELSE PLUS(1, LENGTH CDR X); LITER(U:any):boolean Type: EVAL, SPREAD Returns T if U is a character of the alphabet, NIL otherwise. EXPR PROCEDURE LITER(U); IF MEMQ(U, '(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 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)) THEN T ELSE NIL; Standard LISP Report. 30 3.13 Composite Functions. MEMBER(A:any, B:list):extra-boolean Type: EVAL, SPREAD Returns NIL if A is not a member of list B, returns the remainder of B whose first element is A. EXPR PROCEDURE MEMBER(A, B); IF NULL B THEN NIL ELSE IF A = CAR B THEN B ELSE MEMBER(A, CDR B); MEMQ(A:any, B:list):extra-boolean Type: EVAL, SPREAD Same as MEMBER but an EQ check is used for comparison. EXPR PROCEDURE MEMQ(A, B); IF NULL B THEN NIL ELSE IF A EQ CAR B THEN B ELSE MEMQ(A, CDR B); NCONC(U:list, V:list):list Type: EVAL, SPREAD Concatenates V to U without copying U. The last CDR of U is modified to point to V. EXPR PROCEDURE NCONC(U, V); BEGIN SCALAR W; IF NULL U THEN RETURN V; W := U; WHILE CDR W DO W := CDR W; RPLACD(W, V); RETURN U END; PAIR(U:list, V:list):alist Type: EVAL, SPREAD U and V are lists which must have an identical number of elements. If not, an error occurs (the 000 used in the ERROR call is arbitrary and need not be adhered to). Returned is a list where each element is a dotted-pair, the CAR of the pair being from U, and the CDR the corresponding element from V. EXPR PROCEDURE PAIR(U, V); IF AND(U, V) THEN (CAR U . CAR V) . PAIR(CDR U, CDR V) ELSE IF OR(U, V) THEN ERROR(000, "Different length lists in PAIR") ELSE NIL; Standard LISP Report. 31 3.13 Composite Functions. REVERSE(U:list):list Type: EVAL, SPREAD Returns a copy of the top level of U in reverse order. EXPR PROCEDURE REVERSE(U); BEGIN SCALAR W; WHILE U DO << W := CAR U . W; U := CDR U >>; RETURN W END; SASSOC(U:any, V:alist, FN:function):any Type: EVAL, SPREAD Searches the alist V for an occurrence of U. If U is not in the alist the evaluation of function FN is returned. EXPR PROCEDURE SASSOC(U, V, FN); IF NULL V THEN FN() ELSE IF U = CAAR V THEN CAR V ELSE SASSOC(U, CDR V, FN); SUBLIS(X:alist, Y:any):any Type: EVAL, SPREAD The value returned is the result of substituting the CDR of each element of the alist X for every occurrence of the CAR part of that element in Y. EXPR PROCEDURE SUBLIS(X, Y); IF NULL 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; SUBST(U:any, V:any, W:any):any Type: EVAL, SPREAD The value returned is the result of substituting U for all occurrences of V in W. EXPR PROCEDURE SUBST(U, V, W); IF NULL W THEN NIL ELSE IF V = W THEN U ELSE IF ATOM W THEN W ELSE SUBST(U, V, CAR W) . SUBST(U, V, CDR W); Standard LISP Report. 32 3.14 The Interpreter. 3.14 The Interpreter. APPLY(FN:{id,function}, ARGS:any-list):any Type: EVAL, SPREAD APPLY returns the value of FN with actual parameters ARGS. The actual parameters in ARGS are already in the form required for binding to the formal parameters of FN. EXPR PROCEDURE APPLY(FN, ARGS); BEGIN SCALAR DEFN; IF CODEP FN THEN RETURN {Spread the actual parameters in ARGS following the conventions for calling functions, transfer to the entry point of the function, and return the value returned by the function.}; IF IDP FN THEN RETURN IF NULL(DEFN := GETD FN) THEN ERROR(000, LIST(FN, "is an undefined function")) ELSE IF CAR DEFN EQ 'EXPR THEN APPLY(CDR DEFN, ARGS) ELSE ERROR(000, LIST(FN, "cannot be evaluated by APPLY")); IF OR(ATOM FN, NOT(CAR FN EQ 'LAMBDA)) THEN ERROR(000, LIST(FN, "cannot be evaluated by APPLY")); RETURN {Bind the actual parameters in ARGS to the formal parameters of the lambda expression. If the two lists are not of equal length then ERROR(000, "Number of parameters do not match"); The value returned is EVAL CADDR FN.} END; EVAL(U:any):any Type: EVAL, SPREAD The value of the expression U is computed. Error numbers are arbitrary. Portions of EVAL involving machine specific coding are expressed in English enclosed in brackets {...}. EXPR PROCEDURE EVAL(U); BEGIN SCALAR FN; IF CONSTANTP U THEN RETURN U; IF IDP U THEN RETURN {U is an id. Return the value most currently bound to U or if there is no such binding: ERROR(000, LIST("Unbound:", U))}; IF PAIRP CAR U THEN RETURN IF CAAR U EQ 'LAMBDA THEN APPLY(CAR U, EVLIS CDR U) ELSE ERROR(000, LIST(CAR U, "improperly formed LAMBDA expression")) ELSE IF CODEP CAR U THEN RETURN APPLY(CAR U, EVLIS CDR U); FN := GETD CAR U; IF NULL FN THEN ERROR(000, LIST(CAR U, "is an undefined function")) ELSE IF CAR FN EQ 'EXPR THEN Standard LISP Report. 33 3.14 The Interpreter. RETURN APPLY(CDR FN, EVLIS CDR U) ELSE IF CAR FN EQ 'FEXPR THEN RETURN APPLY(CDR FN, LIST CDR U) ELSE IF CAR FN EQ 'MACRO THEN RETURN EVAL APPLY(CDR FN, LIST U) END; EVLIS(U:any-list):any-list Type: EVAL, SPREAD EVLIS returns a list of the evaluation of each element of U. EXPR PROCEDURE EVLIS(U); IF NULL U THEN NIL ELSE EVAL CAR U . EVLIS CDR U; EXPAND(L:list, FN:function):list Type: EVAL, SPREAD FN is a defined function of two arguments to be used in the expansion of a MACRO. EXPAND returns a list in the form: (FN L[0] (FN L[1] ... (FN L[n-1] L[n]) ... )) "n" is the number of elements in L, L[i] is the ith element of L. EXPR PROCEDURE EXPAND(L,FN); IF NULL CDR L THEN CAR L ELSE LIST(FN, CAR L, EXPAND(CDR L, FN)); FUNCTION(FN:function):function Type: NOEVAL, NOSPREAD The function FN is to be passed to another function. If FN is to have side effects its free variables must be fluid or global. FUNCTION is like QUOTE but its argument may be affected by compilation. We do not consider FUNARGs in this report. QUOTE(U:any):any Type: NOEVAL, NOSPREAD Stops evaluation and returns U unevaluated. FEXPR PROCEDURE QUOTE(U); CAR U; Standard LISP Report. 34 3.15 Input and Output. 3.15 Input and Output. The user normally communicates with Standard LISP through "standard devices" . The default devices are selected in accordance with the conventions of the implementation site. Other input and output devices or files may be selected for reading and writing using the functions described herein. CLOSE(FILEHANDLE:any):any Type: EVAL, SPREAD Closes the file with the internal name FILEHANDLE writing any necessary end of file marks and such. The value of FILEHANDLE is that returned by the corresponding OPEN. The value returned is the value of FILEHANDLE. An error occurs if the file can not be closed. ***** FILEHANDLE could not be closed EJECT():NIL Causes a skip to the top of the next output page. Automatic EJECTs are executed by the print functions when the length set by the PAGELENGTH function is exceeded. LINELENGTH(LEN:{integer, NIL}):integer Type: EVAL, SPREAD If LEN is an integer the maximum line length to be printed before the print functions initiate an automatic TERPRI is set to the value LEN. No initial Standard LISP line length is assumed. The previous line length is returned except when LEN is NIL. This special case returns the current line length and does not cause it to be reset. An error occurs if the requested line length is too large for the currently selected output file or LEN is negative or zero. ***** LEN is an invalid line length LPOSN():integer Returns the number of lines printed on the current page. At the top of a page, 0 is returned. Standard LISP Report. 35 3.15 Input and Output. OPEN(FILE:any, HOW:id):any Type: EVAL, SPREAD Open the file with the system dependent name FILE for output if HOW is EQ to OUTPUT, or input if HOW is EQ to INPUT. If the file is opened successfully, a value which is internally associated with the file is returned. This value must be saved for use by RDS and WRS. An error occurs if HOW is something other than INPUT or OUTPUT or the file can't be opened. ***** HOW is not option for OPEN ***** FILE could not be opened PAGELENGTH(LEN:{integer, NIL}):integer Type: EVAL, SPREAD Sets the vertical length (in lines) of an output page. Automatic page EJECTs are executed by the print functions when this length is reached. The initial vertical length is implementation specific. The previous page length is returned. If LEN is 0, no automatic page ejects will occur. POSN():integer Returns the number of characters in the output buffer. When the buffer is empty, 0 is returned. PRINC(U:id):id Type: EVAL, SPREAD U must be a single character id such as produced by EXPLODE or read by READCH or the value of !$EOL!$. The effect is the character U displayed upon the currently selected output device. The value of !$EOL!$ causes termination of the current line like a call to TERPRI. PRINT(U:any):any Type: EVAL, SPREAD Displays U in READ readable format and terminates the print line. The value of U is returned. EXPR PROCEDURE PRINT(U); BEGIN PRIN1 U; TERPRI(); RETURN U END; Standard LISP Report. 36 3.15 Input and Output. PRIN1(U:any):any Type: EVAL, SPREAD U is displayed in a READ readable form. The format of display is the result of EXPLODE expansion; special characters are prefixed with the escape character !, and strings are enclosed in "...". Lists are displayed in list-notation and vectors in vector-notation . PRIN2(U:any):any Type: EVAL, SPREAD U is displayed upon the currently selected print device but output is not READ readable. The value of U is returned. Items are displayed as described in the EXPLODE function with the exceptions that the escape character does not prefix special characters and strings are not enclosed in "...". Lists are displayed in list-notation and vectors in vector-notation. The value of U is returned. RDS(FILEHANDLE:any):any Type: EVAL, SPREAD Input from the currently selected input file is suspended and further input comes from the file named. FILEHANDLE is a system dependent internal name which is a value returned by OPEN. If FILEHANDLE is NIL the standard input device is selected. When end of file is reached on a non-standard input device, the standard input device is reselected. When end of file occurs on the standard input device the Standard LISP reader terminates. RDS returns the internal name of the previously selected input file. ***** FILEHANDLE could not be selected for input READ():any Returns the next expression from the file currently selected for input. Valid input forms are: vector-notation, dot-notation, list-notation, numbers, function-pointers, strings, and identifiers with escape characters. Identifiers are interned on the OBLIST (see the INTERN function in the "Identifiers" section). READ returns the value of !$EOF!$ when the end of the currently selected input file is reached. READCH():id Returns the next interned character from the file currently selected for input. Two special cases occur. If all the characters in an input record have been read, the value of !$EOL!$ is returned. If the file selected for input has all been read the value of !$EOF!$ is returned. TERPRI():NIL The current print line is terminated. Standard LISP Report. 37 3.15 Input and Output. WRS(FILEHANDLE:any):any Type: EVAL, SPREAD Output to the currently active output file is suspended and further output is directed to the file named. FILEHANDLE is an internal name which is returned by OPEN. The file named must have been opened for output. If FILEHANDLE is NIL the standard output device is selected. WRS returns the internal name of the previously selected output file. ***** FILEHANDLE could not be selected for output 3.16 LISP Reader. An EVAL read loop has been chosen to drive a Standard LISP system to provide a continuity in functional syntax. Choices of messages and the amount of extra information displayed are decisions left to the implementor. EXPR PROCEDURE STANDARD!-LISP(); BEGIN SCALAR VALUE; RDS NIL; WRS NIL; PRIN2 "Standard LISP"; TERPRI(); WHILE T DO << PRIN2 "EVAL:"; TERPRI(); VALUE := ERRORSET(QUOTE EVAL READ(), T, T); IF NOT ATOM VALUE THEN PRINT CAR VALUE; TERPRI() >>; END; Standard LISP Report. 38 4. System GLOBAL Variables. 4. System GLOBAL Variables. These variables provide global control of the LISP system, or implement values which are constant throughout execution. !*COMP - Initial value = NIL. The value of !*COMP controls whether or not PUTD compiles the function defined in its arguments before defining it. If !*COMP is NIL the function is defined as an xEXPR. If !*COMP is something else the function is first compiled. Compilation will produce certain changes in the semantics of functions particularly FLUID type access. EMSG!* - Initial value = NIL. Will contain the MESSAGE generated by the last ERROR call (see the "Error Handling" section). !$EOF!$ - Value = an uninterned identifier The value of !$EOF!$ is returned by all input functions when the end of the currently selected input file is reached. !$EOL!$ - Value = an uninterned identifier The value of !$EOL!$ is returned by READCH when it reaches the end of a logical input record. Likewise PRINC will terminate its current line (like a call to TERPRI) when !$EOL!$ is its argument. NIL - Value = NIL NIL is a special global variable. It is protected from being modified by SET or SETQ. !*RAISE - Initial value = NIL If !*RAISE is T all characters input through Standard LISP input/output functions will be raised to upper case. If !*RAISE is NIL characters will be input as is. T - Value = T T is a special global variable. It is protected from being modified by SET or SETQ. Standard LISP Report. 39 Acknowledgment. The authors would like to thank the following persons whose helpful comments contributed to the completion of this document. J. Fitch, I. Frick, E. Goto, S. Harrington, R. Jenks, A. Lux, A. Norman, M. Rothstein, M. Wirth. Standard LISP Report. 40 List of References. List of References [1] M. L. Griss, A. C. Hearn, A Portable LISP Compiler, (in preparation). [2] A. C. Hearn, Standard LISP, SIGPLAN Notices, ACM, Vol. 4, No. 9, September 1966, Reprinted in SIGSAM Bulletin, ACM, Vol. 13, 1969, p. 28-49. [3] A. C. Hearn, REDUCE 2 Symbolic Mode Primer, Utah Computational Physics, Operating Note No. 5.1, October 1974. -, REDUCE 2 User's Manual, Utah Computational Physics, UCP-19, March 1973. [4] LISP Reference Manual, CDC-6000, Computation Center, The University of Texas at Austin. [5] LISP/360 Reference Manual, Stanford Center for Information Processing, Stanford University. [6] John McCarthy, Paul W. Abrahams, Daniel J. Edwards, Timothy P. Hart, Michael I. Levin, LISP 1.5 Programmers Manual, The Computation Center and Research Laboratory of Electronics, Massachusettes Institute of Technology, The M.I.T. Press, Cambridge, Massachusettes, 1965. [7] MACLISP Reference Manual, March 6, 1976. [8] J. Strother Moore II, The INTERLISP Virtual Machine Specification, CSL 76-5 September 1976, XEROX, Palo Alto Research Center. [9] Mats Nordstrom, Erik Sandewall, Diz Breslow, LISP F1: A FORTRAN Implementation of LISP 1.5, Uppsala University, Department of Computer Sciences. [10] Lynn H. Quam, Whitfield Diffie, Stanford LISP 1.6 Manual, Stanford Artificial Intelligence Laboratory, Operating Note 28.7. [11] Warren Teitelman, INTERLISP Reference Manual, XEROX, Palo Alto Research Center, 1974. [12] Clark Weissman, LISP 1.5 Primer, Dickenson Publishing Company, Inc., 1967. Standard LISP Report. 41 Appendix A. The Extended Syntax. The Extended Syntax. Whenever it is possible to define Standard LISP functions in LISP the text of the function will appear in an extended syntax. These definitions are supplied as an aid to understanding the behavior of functions and not as a strict implementation guide. A formal scheme for the translation of extended syntax to Standard LISP is presented to eliminate misinterpretation of the definitions. The goal of the transformation scheme is to produce a PUTD invocation which has the function translated from the extended syntax as its actual parameter. A rule has a name in brackets <...> by which it is known and is defined by what follows the meta symbol ::=. Each rule of the set consists of one or more "alternatives" separated by the | meta symbol, being the different ways in which the rule will be matched by source text. Each alternative is composed of a "recognizer" and a "generator" separated by the ==> meta symbol. The recognizer is a concatenation of any of three different forms. 1) Terminals - Upper case lexemes and punctuation which is not part of the meta syntax represent items which must appear as is in the source text for the rule to succeed. 2) Rules - Lower case lexemes enclosed in <...> are names of other rules. The source text is matched if the named rule succeeds. 3) Primitives - Lower case singletons not in brackets are names of primitives or primitive classes of Standard LISP. The syntax and semantics of the primitives are given in Part I. The recognizer portion of the following rule matches an extended syntax procedure: <function> ::= ftype PROCEDURE id (<id list>); <statement>; ==> A function is recognized as an "ftype" (one of the tokens EXPR, FEXPR, etc.) followed by the keyword PROCEDURE, followed by an "id" (the name of the function), followed by an "<id list>" (the formal parameter names) enclosed in parentheses. A semicolon terminates the title line. The body of the function is a <statement> followed by a semicolon. For example: EXPR PROCEDURE NULL(X); EQ(X, NIL); satisfies the recognizer, causes the generator to be activated and the rule to be matched successfully. The generator is a template into which generated items are substituted. The three syntactic entities have corresponding meanings when they appear in the generator portion. 1) Terminals - These lexemes are copied as is to the generated text. 2) Rules - If Standard LISP Report. 42 Appendix A. The Extended Syntax. a rule has succeeded in the recognizer section then the value of the rule is the result of the generator portion of that rule. 3) Primitives - When primitives are matched the primitive lexeme replaces its occurrence in the generator. If more than one occurrence of an item would cause ambiguity in the generator portion this entity appears with a bracketed subscript. Thus: <conditional> ::= IF <expression> THEN <statement[1]> ELSE <statement[2]>... has occurrences of two different <statement>s. The generator portion uses the subscripted entities to reference the proper generated value. The <function> rule appears in its entirety as: <function> ::= ftype PROCEDURE id (<id list>); <statement>; ==> (PUTD (QUOTE id) (QUOTE ftype) (QUOTE (LAMBDA (<id list>) <statement>))) If the recognizer succeeds (as it would in the case of the NULL procedure example) the generator returns: (PUTD (QUOTE NULL) (QUOTE EXPR) (QUOTE (LAMBDA (X) (EQ X NIL)))) The identifier in the template is replaced by the procedure name NULL, <id list> by the single formal parameter X, the <statement> by (EQ X NIL) which is the result of the <statement> generator. EXPR replaces ftype, the type of the defined procedure. The Extended Syntax Rules <function> ::= ftype PROCEDURE id (<id list>); <statement>; ==> (PUTD (QUOTE id) (QUOTE ftype) (QUOTE (LAMBDA (<id list>) <statement>))) <id list> ::= id ==> id | id, <id list> ==> id <id list> <statement> ::= <expression> ==> <expression> | <proper statement> ==> <proper statement> <proper statement> ::= Standard LISP Report. 43 Appendix A. The Extended Syntax. <assignment statement> ==> <assignment statement> | <conditional statement> ==> <conditional statement> | <while statement> ==> <while statement> | <compound statement> ==> <compound statement> <assignment statement> ::= id := <expression> ==> (SETQ id <expression>) <conditional statement> ::= IF <expression> THEN <statement[1]> ELSE <statement[2]> ==> (COND (<expression> <statement[1]>) (T <statement[2]>)) | IF <expression> THEN <statement> ==> (COND (<expression> <statement>)) <while statement> ::= WHILE <expression> DO <statement> ==> (PROG NIL LBL (COND ((NULL <expression>) (RETURN NIL))) <statement> (GO LBL)) <compound statement> ::= BEGIN SCALAR <id list>; <program list> END ==> (PROG (<id list>) <program list>) | BEGIN <program list> END ==> (PROG NIL <program list>) | << <statement list> >> ==> (PROGN <statement list>) <program list> ::= <full statement> ==> <full statement> | <full statement> <program list> ==> <full statement> <program list> <full statement> ::= <statement> ==> <statement> | id: ==> id <statement list> ::= <statement> ==> <statement> | <statement>; <statement list> ==> <statement> <statement list> <expression> ::= <expression[1]> . <expression[2]> ==> (CONS <expression[1]> <expression[2]> | <expression[1]> = <expression[2]> ==> (EQUAL <expression[1]> <expression[2]>) | <expression[1]> EQ <expression[2]> ==> (EQ <expression[1]> <expression[2]>) | '<expression> ==> (QUOTE <expression>) | function <expression> ==> (function <expression>) | function(<argument list>) ==> (function <argument list>) | number ==> number | id ==> id <argument list> ::= () ==> | <expression> ==> <expression> Standard LISP Report. 44 Appendix A. The Extended Syntax. | <expression>, <argument list> ==> <expression> <argument list> Notice the three infix operators . EQ and = which are translated into calls on CONS, EQ, and EQUAL respectively. Note also that a call on a function which has no formal parameters must have () as an argument list. The QUOTE function is abbreviated by '. Standard LISP Report. 45 Appendix B. Alphabetical List of Functions The following is an alphabetical list of the Standard LISP functions with formal parameters and the page on which they are defined. ABS(U:number):number 23 AND([U:any]):extra-boolean 22 APPEND(U:list, V:list):list 28 APPLY(FN:{id,function}, ARGS:any-list):any 32 ASSOC(U:any, V:alist):{dotted-pair,NIL} 28 ATOM(U:any):boolean 9 CAR(U:dotted-pair):any 11 CDR(U:dotted-pair):any 11 CLOSE(FILEHANDLE:any):any 34 CODEP(U:any):boolean 9 COMPRESS(U:id-list):{atom}-{vector} 12 COND([U:cond-form]):any 22 CONS(U:any, V:any):dotted-pair 11 CONSTANTP(U:any):boolean 9 DE(FNAME:id, PARAMS:id-list, FN:any):id 15 DEFLIST(U:dlist, IND:id):list 29 DELETE(U:any, V:list):list 29 DF(FNAME:id, PARAM:id-list, FN:any):id 15 DIFFERENCE(U:number, V:number):number 24 DIGIT(U:any):boolean 29 DIVIDE(U:number, V:number):dotted-pair 24 DM(MNAME:id, PARAM:id-list, FN:any):id 15 EJECT():NIL 34 EQ(U:any, V:any):boolean 9 EQN(U:any, V:any):boolean 9 EQUAL(U:any, V:any):boolean 9 ERROR(NUMBER:integer, MESSAGE:any) 20 ERRORSET(U:any, MSGP:boolean, TR:boolean):any 20 EVAL(U:any):any 32 EVLIS(U:any-list):any-list 33 EXPAND(L:list, FN:function):list 33 EXPLODE(U:{atom}-{vector}):id-list 12 EXPT(U:number, V:integer):number 24 FIX(U:number):integer 24 FIXP(U:any):boolean 10 FLAG(U:id-list, V:id):NIL 14 FLAGP(U:any, V:any):boolean 14 FLOAT(U:number):floating 24 FLOATP(U:any):boolean 10 FLUID(IDLIST:id-list):NIL 17 FLUIDP(U:any):boolean 17 FUNCTION(FN:function):function 33 Standard LISP Report. 46 Appendix B. Alphabetical List of Functions GENSYM():id 13 GET(U:any, IND:any):any 14 GETD(FNAME:any):{NIL, dotted-pair} 15 GETV(V:vector, INDEX:integer):any 21 GLOBAL(IDLIST:id-list):NIL 17 GLOBALP(U:any):boolean 17 GO(LABEL:id) 19 GREATERP(U:number, V:number):boolean 24 IDP(U:any):boolean 10 INTERN(U:{id,string}):id 13 LENGTH(X:any):integer 29 LESSP(U:number, V:number):boolean 24 LINELENGTH(LEN:{integer,NIL}):integer 34 LIST([U:any]):list 11 LITER(U:any):boolean 29 LPOSN():integer 34 MAP(X:list, FN:function):any 27 MAPC(X:list, FN:function):any 27 MAPCAN(X:list, FN:function):any 27 MAPCAR(X:list, FN:function):any 27 MAPCON(X:list, FN:function):any 27 MAPLIST(X:list, FN:function):any 28 MAX([U:number]):number 25 MAX2(U:number, V:number):number 25 MEMBER(A:any, B:list):extra-boolean 30 MEMQ(A:any, B:list):extra-boolean 30 MIN([U:number]):number 25 MINUS(U:number):number 25 MIN2(U:number, V:number):number 25 MKVECT(UPLIM:integer):vector 21 NCONC(U:list, V:list):list 30 NOT(U:any):boolean 22 NULL(U:any):boolean 10 NUMBERP(U:any):boolean 10 OPEN(FILE:any, HOW:id):any 35 OR([U:any]):extra-boolean 23 PAGELENGTH(LEN:{integer,NIL}):integer 35 PAIR(U:list, V:list):alist 30 PAIRP(U:any):boolean 10 PLUS([U:number]):number 25 PLUS2(U:number, V:number):number 26 POSN():integer 35 PRINC(U:id):id 35 PRINT(U:any):any 35 PRIN1(U:any):any 36 PRIN2(U:any):any 36 PROG(VARS:id-list, [PROGRAM:{id,any}]):any 19 PROGN([U:any]):any 19 Standard LISP Report. 47 Appendix B. Alphabetical List of Functions PUT(U:id, IND:id, PROP:any):any 14 PUTD(FNAME:id, TYPE:ftype, BODY:function):id 16 PUTV(V:vector, INDEX:integer, VALUE:any):any 21 QUOTE(U:any):any 33 QUOTIENT(U:number, V:number):number 26 RDS(FILEHANDLE:any):any 36 READ():any 36 READCH():id 36 REMAINDER(U:number, V:number):number 26 REMD(FNAME:id):{NIL, dotted-pair} 16 REMFLAG(U:any-list, V:id):NIL 14 REMOB(U:id):id 13 REMPROP(U:any, IND:any):any 14 RETURN(U:any) 20 REVERSE(U:list):list 31 RPLACA(U:dotted-pair, V:any):dotted-pair 12 RPLACD(U:dotted-pair, V:any):dotted-pair 12 SASSOC(U:any, V:alist, FN:function):any 31 SET(EXP:id, VALUE:any):any 18 SETQ(VARIABLE:id, VALUE:any):any 18 STRINGP(U:any):boolean 10 SUBLIS(X:alist, Y:any):any 31 SUBST(U:any, V:any, W:any):any 31 TERPRI():NIL 36 TIMES([U:number]):number 26 TIMES2(U:number, V:number):number 26 UNFLUID(IDLIST:id-list):NIL 18 UPBV(U:any):{NIL,integer} 21 VECTORP(U:any):boolean 10 WRS(FILEHANDLE:any):any 37 Standard LISP Report. 48 Index. Index. !$EOF!$, 36, 38 !$EOL!$, 36, 38 !*COMP, 15, 38 !*RAISE, 38 ABS, 23 alist, 6 AND, 22 antecedent, 6 any, 6 APPEND, 28 APPLY, 32 Arithmetic Functions, 23 ASSOC, 28 association list, 6 ATOM, 9 atom, 6 binding, 3 boolean, 5 Boolean Functions, 22 C...R composites, 11 CAR, 11 CDR, 11 CLOSE, 34 CODEP, 5, 9 Composite functions, 28 COMPRESS, 12 COND, 22 cond-form, 6 Conditional, 22 CONS, 11 consequent, 6 constant, 6 CONSTANTP, 9 DE, 15 DEFLIST, 29 DELETE, 29 DF, 15 DIFFERENCE, 24 DIGIT, 29 DIVIDE, 24 DM, 15 dot-notation, 4, 36 dotted-pair, 4 Standard LISP Report. 49 Index. EJECT, 34 Elementary Predicates, 9 EMSG!*, 20, 38 EQ, 9 EQN, 9 EQUAL, 9 ERROR, 20 ERROR handling, 8, 20 Error messages, 8 ERRORSET, 20 escape character, 4, 13 EVAL, 32 EVAL functions, 7 EVAL, SPREAD functions, 7 EVAL, SPREAD parameter limit, 7 EVLIS, 33 EXPAND, 33 EXPLODE, 12 EXPR, 5 EXPT, 24 extra-boolean, 5 FEXPR, 5 FIX, 24 FIXP, 10 FLAG, 14 FLAGP, 14 flags, 3, 13 FLOAT, 24 floating, 3, 12 FLOATP, 10 FLUID, 17 fluid binding, 17 FLUIDP, 17 ftype, 5 funargs, 33 FUNCTION, 33 function, 3, 7 Function Definition, 15 function-pointer, 5, 13 Functions on Dotted-Pairs, 11 GENSYM, 13 GET, 14 GETD, 15 GETV, 21 GLOBAL, 17 global binding, 16 GLOBALP, 17 GO, 19 GREATERP, 24 id, 3, 13 identifiers, 3, 12 Standard LISP Report. 50 Index. IDP, 10 indicator, 13 Input and output, 34 integer, 3, 12 INTERN, 13 Interpreter, 32 lambda, 6 LAMBDA expression, 6 LENGTH, 29 LESSP, 24 LINELENGTH, 34 LISP reader, 37 LIST, 11 list, 6 list-notation, 6, 36 LITER, 29 local binding, 16 LPOSN, 34 MACRO, 5 MAP, 27 MAPC, 27 MAPCAN, 27 MAPCAR, 27 MAPCON, 27 MAPLIST, 28 MAX, 25 MAX2, 25 MEMBER, 30 MEMQ, 30 MIN, 25 MINUS, 25 MIN2, 25 MKVECT, 21 NCONC, 30 NIL, 5, 38 NOEVAL functions, 7 NOSPREAD functions, 7 NOT, 22 NULL, 10 number, 5 NUMBERP, 10 object, 9, 12 OBLIST, 3, 12, 13 OPEN, 35 OR, 23 PAGELENGTH, 35 PAIR, 30 PAIRP, 10 PLUS, 25 Standard LISP Report. 51 Index. PLUS2, 26 POSN, 35 PRINC, 35 PRINT, 35 print name, 3, 13 PRIN1, 36 PRIN2, 36 PROG, 19 PROGN, 19 Program Feature Functions, 18 properties, 3, 13 Property List Functions, 13 PUT, 14 PUTD, 16 PUTV, 21 QUOTE, 33 QUOTIENT, 26 RDS, 36 READ, 36 READCH, 36 REMAINDER, 26 REMD, 16 REMFLAG, 14 REMOB, 13 REMPROP, 14 RETURN, 20 REVERSE, 31 RPLACA, 12 RPLACD, 12 S-expression, 6 SASSOC, 31 SET, 18 SETQ, 18 SPREAD functions, 7 standard devices, 34 string, 13 STRINGP, 10 strings, 4 structures, 6 SUBLIS, 31 SUBST, 31 System GLOBAL Variables, 38 T, 5, 38 TERPRI, 36 TIMES, 26 TIMES2, 26 type mismatch error, 8 UNFLUID, 18 UPBV, 21 Standard LISP Report. 52 Index. variable, 16 variables, 3 Variables and Bindings, 16 vector, 4 vector-notation, 4, 36 VECTORP, 10 Vectors, 21 Warning messages, 8 WRS, 37 Standard LISP Report. TABLE OF CONTENTS 1. Introduction .................................... 1 2. Preliminaries ................................... 3 2.1 Primitive Data Types ............................ 3 2.2 Classes of Primitive Data Types ................. 5 2.3 Structures ...................................... 6 2.4 Function Descriptions ........................... 7 2.5 Function Types .................................. 7 2.6 The Extended Syntax ............................. 8 2.7 Error and Warning Messages ...................... 8 3. Functions ....................................... 9 3.1 Elementary Predicates ........................... 9 3.2 Functions on Dotted-Pairs ....................... 11 3.3 Identifiers ..................................... 12 3.4 Property List Functions ......................... 13 3.5 Function Definition ............................. 15 3.6 Variables and Bindings ......................... 16 3.7 Program Feature Functions ....................... 18 3.8 Error Handling .................................. 20 3.9 Vectors ......................................... 21 3.10 Boolean Functions and Conditionals .............. 22 3.11 Arithmetic Functions ............................ 23 3.12 MAP Composite Functions ......................... 27 3.13 Composite Functions ............................. 28 3.14 The Interpreter ................................. 32 3.15 Input and Output ................................ 34 3.16 LISP Reader ..................................... 37 4. System GLOBAL Variables ......................... 38 List of References ................................... 40 Appendix A. The Extended Syntax ...................... 41 Appendix B. Alphabetical List of Functions ........... 45 Index ................................................ 48 |
Added r30/sldec.doc version [1e74229006].
cannot compute difference between binary files
Added r30/solve.fap version [3b119dfe9b].
cannot compute difference between binary files
Added r30/solve.red version [214be8515d].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | COMMENT SOLVE MODULE; %******************* Global Declarations ***************************; SYMBOLIC; FLAG('(!*SOLVEWRITE), 'SHARE); ARRAY !!CF(12), !!INTERVAL(10,2), !!EXACT(10); GLOBAL '(!!HIPOW !!GCD !*SOLVESINGULAR SM!* MP!* !*ALLBRANCH !*SOLVEWRITE !!ARBINT !*SOLVEINTERVAL !!INTERVALARRAY); !*SOLVESINGULAR := T; % Solves consistent, singular eqns (0=0) if T; !*ALLBRANCH := T; % Returns all branches of solutions if T; !*SOLVEWRITE := T; % Prints solutions if T; %!*SOLVEINTERVAL = NIL;% Attempts to isolate insoluble, real roots if T; !!INTERVALARRAY := '!!INTERVAL; % Value is the name of an array used to % pass args to RealRoot routines; !!ARBINT := 0; % Index for arbitrary constants; % !!HIPOW : SOLVECOEFF returns highest power of its arg in this % !!GCD : SOLVECOEFF returns GCD of powers of its arg in this % !!CF : Array of coeffs from SOLVECOEFF % % SM!* : List of solutions % MP!* : List of multiplicities; ALGEBRAIC MATRIX SOLN, MULTIPLICITY; %******************* Utility Functions *****************************; SYMBOLIC PROCEDURE RPLACX U; BEGIN SCALAR CARU; CARU := CAR U; RETURN RPLACD(RPLACA(U,CDR U),CARU) END; SYMBOLIC PROCEDURE UNIVARIATEP F; % F is a standard form. Non-nil iff F is univariate or a constant; DOMAINP F OR (DOMAINP LC F AND (DOMAINP RED F OR ((MVAR F = MVAR RED F) AND UNIVARIATEP RED F) )); SYMBOLIC SMACRO PROCEDURE SUBTRSQ(U,V); ADDSQ(U, NEGSQ V); SYMBOLIC SMACRO PROCEDURE VARLIS U; %U is an r-polynomial. %value is an ordered list of variables in U; VARLIS1(U,NIL); SYMBOLIC SMACRO PROCEDURE LFCTR U; COMMENT RETURNS LEFTFACTOR OF A PAIR. USED BY SUMFACTORS IN IEQN.RED; CAAR U; SYMBOLIC OPERATOR LCMD; SYMBOLIC PROCEDURE LCMD(C,D); COMMENT C and D are prefix rational numbers. Returns integer least-common-multiple of their denominators; LCM(DENR SIMP!* C, DENR SIMP!* D); SYMBOLIC PROCEDURE VARLIS1(U,V); IF DOMAINP U THEN V ELSE VARLIS1(CDR U,VARLIS1(CDAR U,ORDAS(CAAAR U,V))); SYMBOLIC PROCEDURE ORDAS(A,L); IF NULL L THEN LIST A ELSE IF A=CAR L THEN L ELSE IF ORDP(A,CAR L) THEN A . L ELSE CAR L . ORDAS(A,CDR L); SYMBOLIC PROCEDURE RATNUMP X; COMMENT Returns T iff any prefix expression X is a rational number; ATOM NUMR(X:=SIMP!* X) AND ATOM DENR X; FLAG ('(RATNUMP), 'DIRECT); SYMBOLIC PROCEDURE KARGLIS(KNAME, KLIS); COMMENT KNAME evaluates to an atom and KLIS to a list of kernels. Returns the list of kernels named KNAME in KLIS; IF NULL KLIS THEN NIL ELSE UNION(KARG1(KNAME, CAR KLIS), KARGLIS(KNAME,CDR KLIS)); SYMBOLIC PROCEDURE KARG1(KNAME, KRN); COMMENT KNAME evaluates to an atom and KRN to a kernel. Returns a list of kernels named KNAME in KRN; IF ATOM KRN THEN NIL ELSE IF CAR KRN=KNAME THEN UNION(KARGLIS(KNAME,CDR KRN), LIST(KRN)) ELSE KARGLIS(KNAME, CDR KRN); SYMBOLIC PROCEDURE ALLKERN ELST; COMMENT Returns list of all top-level kernels in the list of standard forms ELST; IF NULL ELST THEN NIL ELSE UNION(VARLIS CAR ELST, ALLKERN CDR ELST); SYMBOLIC OPERATOR FREEOFKERN; SYMBOLIC PROCEDURE FREEOFKERN(X,U); COMMENT Returns T iff any expression U is free of kernel X; IF ATOM X THEN FREEOF(U,X) ELSE FREEOF(SUBST('!!DUM,X,U),'!!DUM); FLAG('(FREEOFKERN),'DIRECT); SYMBOLIC PROCEDURE TOPKERN(EX, X); BEGIN COMMENT Returns list of toplevel kernels in the standard form EX that contain the kernel X; SCALAR ALLK, WITHX; ALLK := VARLIS EX; WHILE ALLK DO<< IF NOT FREEOFKERN(X,CAR ALLK) THEN WITHX:=CAR ALLK.WITHX; ALLK:=CDR ALLK>>; RETURN WITHX END; SYMBOLIC PROCEDURE COEFLIS(EX); % EX is a standard form. % Returns a list of the coefficients of the main variable % in ex in the form ((expon.coeff) (expon.coeff) ... ), % where the expon's occur in increasing order, and entries % do not occur of zero coefficients; BEGIN SCALAR X, ANS, OLDKORD, VAR; X := EX; IF DOMAINP(X) THEN RETURN (0 . X); VAR := MVAR(EX); WHILE (NOT DOMAINP(X)) AND MVAR(X)=VAR DO << ANS := (LDEG(X) . LC(X)) . ANS; X := RED(X) >>; IF X THEN ANS := (0 . X) . ANS; RETURN ANS END; %******************* Temporary Factoring Routine *******************; % The following square free factoring routine, based on the Reduce % function SQFRF, will eventually be replaced by the Norman-Moore % complete factorization technique.; FLUID '(!*GCD); SYMBOLIC PROCEDURE FACTLIS(EX, KLIST); % EX is a standard form. % KLIST is a list of kernels. % Returns a list of square free factors containing the elements of % KLIST in the form ((integer exponent . standard form factor) ...).; % Factors constant with respect to KLIST are discarded; BEGIN SCALAR FIRST, ANS, OLDGCD, OLDKORD; INTEGER EXPON; OLDGCD := !*GCD; !*GCD := T; % Must be on for SQFRF; OLDKORD := SETKORDER(KLIST); EX := REORDER(EX); WHILE (NOT DOMAINP(EX)) AND (MVAR(EX) MEMBER KLIST) DO << FIRST := PP(EX); IF NOT DOMAINP(FIRST) THEN << % Non-zero roots; EX := QUOTF(EX, FIRST); FIRST := SQFRF(FIRST); FOR EACH X IN FIRST DO IF NOT DOMAINP X THEN ANS := RPLACX X . ANS >> ELSE << % Zero root (possibly multiple); ANS := (LDEG(EX) . !*K2F(MVAR(EX))) . ANS; EX := QUOTF(EX, !*P2F(LPOW(EX))) >> >>; % Restore the state of the world; SETKORDER(OLDKORD); !*GCD := OLDGCD; RETURN ANS END; %******************* SOLVE Statement ******************************; SYMBOLIC PROCEDURE SIMPSOLVE ARGLIST; BEGIN INTEGER NARGS; NARGS := LENGTH(ARGLIST); RETURN !*F2Q IF NARGS=1 THEN SOLVE0(CAR ARGLIST,NIL) ELSE IF NARGS=2 THEN SOLVE0(CAR ARGLIST, CADR ARGLIST) ELSE SOLVE0(CAR ARGLIST,'LST . CDR ARGLIST) END; PUT ('SOLVE,'SIMPFN,'SIMPSOLVE); %******************* Fundamental SOLVE Procedures ******************; SYMBOLIC PROCEDURE SOLVE0(ELST, XLST); BEGIN COMMENT ELST is any prefix expression, including the kernel named LST with any number of arguments. XLST is a kernel, perhaps named LST with any number of arguments. Solves eqns in ELST for vars in XLST, putting solutions and multiplicities in SOLN and MULTIPLICITIES. Prints SOLN if !*SOLVEWRITE is non-nil. Returns number of rows in global matrix SOLN; SCALAR FLST, VARS, NONLIN; INTEGER NEQN, I; %/ MAYBELOADMATR(); ALGEBRAIC CLEAR SOLN, MULTIPLICITY; SM!* := MP!* := NIL; IF NOT ATOM ELST AND CAR ELST='LST THEN ELST:=CDR ELST ELSE ELST:=LIST ELST; NEQN:=0; WHILE ELST DO <<FLST:= NUMR SIMP!* CAR ELST . FLST; NEQN:=NEQN+1; ELST:= CDR ELST >>; % Note that ELST and XLST are reversed from the order entered; IF NULL XLST THEN <<VARS := ALLKERN FLST; WRITE "UNKNOWNS:"; MAPCAR(REVERSE VARS, FUNCTION MATHPRINT); TERPRI()>> ELSE<<IF ATOM XLST OR NOT(CAR XLST='LST)THEN XLST:=LIST(XLST) ELSE XLST:=CDR XLST; WHILE XLST DO<< VARS:=MVAR !*A2F CAR XLST.VARS; XLST:= CDR XLST>>>>; IF NOT(NEQN=LENGTH VARS) THEN REDERR "SOLVE CALLED WITH UNEQUAL NUMBER OF EXPRESSIONS AND UNKNOWNS"; IF NEQN=1 THEN IF NULL (FLST:=CAR FLST) THEN IF !*SOLVESINGULAR THEN <<!!ARBINT:=!!ARBINT+1; CONSSMMP(SIMP!* LIST('ARBCOMPLEX,!!ARBINT), 1) >> ELSE RETURN 0 ELSE <<VARS:=CAR VARS; SOLVE1(FLST./1, VARS, 1) >> COMMENT More than one equation; ELSE << SM!* := TP1(SOLVESYS(FLST, VARS)); MP!* := LIST(LIST(MK!*SQ(!*F2Q(1)))) >>; SM!* := MAPC2(SM!*, FUNCTION MK!*SQ); PUT('MULTIPLICITY, 'MATRIX, 'MAT . MP!*); PUT('SOLN, 'MATRIX, 'MAT . SM!*); IF !*SOLVEWRITE THEN MATPRI(SM!*, 'SOLN); RETURN LENGTH SM!* END; SYMBOLIC PROCEDURE CONSSMMP(S, M); BEGIN COMMENT S is a standard quotient and M is an integer. Conses (S) to global variable SM!* and (M) to global variable MP!*; SM!* := LIST(S) . SM!*; MP!* := LIST(MK!*SQ(M./1)) . MP!* END; SYMBOLIC PROCEDURE SOLVEF(F, V); % F is a standard form, V is a kernel. Returns a list of % pairs, each of which car is a standard quotient and cdr an % integer. If the integer is positive, the SQ is a zero of % F with multiplicity equal to the integer. Otherwise it is % an insoluble factor, with multiplicity the absolute value of % the integer; BEGIN SCALAR OLDSOLVEWRITE, ANS; OLDSOLVEWRITE := !*SOLVEWRITE; !*SOLVEWRITE := NIL; SOLVE0(MK!*SQ(!*F2Q(F)), V); ANS := PAIR(MAPCAR(SM!*, FUNCTION LAMBDA(X); SIMP!*(CAR(X))), MAPCAR(MP!*, FUNCTION CAR) ); !*SOLVEWRITE := OLDSOLVEWRITE; RETURN ANS END; %******************* Procedures for solving a single eqn ***********; SYMBOLIC PROCEDURE SOLVE1 (EX, X, MUL); BEGIN COMMENT Factors standard quotient EX with respect to toplevel occurrences of X and kernels containing variable X. Factors containing more than one such kernel are appended to SM!*, with a negative multiplicity indicating unsolvability, and SOLVE2 is applied to the other factors. Integer MUL is the multiplicity passed from any previous factorizations. Returns NIL; SCALAR E1, X1, TKLIST; INTEGER MU; EX := NUMR EX; TKLIST := TOPKERN(EX,X); IF NULL TKLIST THEN RETURN NIL; EX := FACTLIS(EX, TKLIST); WHILE EX DO << E1 := CDAR(EX); X1 := TOPKERN(E1, X); MU := MUL*CAAR EX; IF X1 THEN IF NULL CDR X1 THEN SOLVE2(E1,CAR X1,X,MU) ELSE IF SMEMQ('SOL, (X1:=SIMP!* LIST('SOL,MK!*SQ(E1./1), X))) THEN CONSSMMP(E1./1, -MU) ELSE SOLVE1(X1,X,MU); EX := CDR(EX) >> END; SYMBOLIC PROCEDURE SOLVE2(E1, X1, X, MU); BEGIN COMMENT E1 is a standard form, MU is an integer, X1 and X are kernels. Uses roots of unity, known inverses, together with quadratic, cubic and quartic formulas, treating other cases as unsolvable. Returns NIL; SCALAR B, C, D, F; INTEGER N; F:= ERRORSET(SOLVECOEFF(E1, X1),NIL,NIL); N:= !!GCD; COMMENT Test for single power of X1; IF ATOM(F) THEN CONSSMMP(E1./1, -MU) ELSE IF (F:=CAR F)=-1 THEN << B:= LIST('EXPT, MK!*SQ QUOTSQ(NEGSQ SIMP!* GETELV(LIST('!!CF,0)), SIMP!* GETELV(LIST('!!CF,1))), MK!*SQ(1 ./!!GCD)); FOR K := 0:N-1 DO << SETELV(LIST('!!CF,1), SIMP!* LIST('TIMES,B, MKEXP LIST('QUOTIENT,LIST('TIMES,K,2,'PI),N))); COMMENT x = b; IF X1=X THEN CONSSMMP(GETELV(LIST('!!CF, 1)), MU) COMMENT LOG(x) = b; ELSE IF CAR X1 = 'LOG THEN SOLVE1 (SUBTRSQ(SIMP!* CADR X1,SIMP!* LIST('EXPT,'E,MK!*SQ GETELV(LIST('!!CF, 1)))),X,MU) ELSE IF CAR X1 = 'EXPT THEN COMMENT c**(...) = b; IF FREEOF(CADR X1,X) THEN << IF !*ALLBRANCH THEN <<!!ARBINT:=!!ARBINT+1; C:=LIST('TIMES,2,'I,'PI,LIST('ARBINT,!!ARBINT)) >> ELSE C:=0; SOLVE1(SUBTRSQ(SIMP!* CADDR X1,QUOTSQ(ADDSQ( SIMP!* LIST('LOG,MK!*SQ GETELV(LIST('!!CF, 1))),SIMP!* C), SIMP!* LIST('LOG,CADR X1))),X,MU) >> ELSE IF FREEOF(CADDR X1,X) THEN COMMENT (...)**(m/n) = b; IF RATNUMP CADDR X1 THEN SOLVE1(SUBTRSQ( EXPTSQ(SIMP!* CADR X1,NUMR SIMP!* CADDR X1), SIMP!* LIST('EXPT,MK!*SQ GETELV(LIST('!!CF, 1)),MK!*SQ(DENR SIMP!* CADDR X1./1))),X,MU) COMMENT (...)**c = b; ELSE << IF !*ALLBRANCH THEN <<!!ARBINT:=!!ARBINT+1; C:=MKEXP LIST('TIMES,LIST ('ARBREAL,!!ARBINT)) >> ELSE C:=1; SOLVE1(SUBTRSQ(SIMP!* CADR X1,MULTSQ(SIMP!* LIST('EXPT,MK!*SQ GETELV(LIST('!!CF, 1)), MK!*SQ INVSQ SIMP!* CADDR X1),SIMP!* C)), X, MU) >> COMMENT (...)**(...) = b : transcendental; ELSE CONSSMMP(SUBTRSQ(SIMP!* X1,GETELV(LIST('!!CF, 1))), -MU) COMMENT SIN(...) = b; ELSE IF CAR X1='SIN THEN<< IF !*ALLBRANCH THEN << !!ARBINT:=!!ARBINT+1; F:=LIST('TIMES,2,'PI,LIST('ARBINT,!!ARBINT)) >> ELSE F:=0; C:=SIMP!* CADR X1; D:=LIST('ASIN,MK!*SQ GETELV(LIST('!!CF, 1))); SOLVE1(SUBTRSQ(C,SIMP!* LIST('PLUS,D,F)),X,MU); IF !*ALLBRANCH THEN SOLVE1(SUBTRSQ(C,SIMP!* LIST ('PLUS,'PI,MK!*SQ SUBTRSQ(SIMP!* F,SIMP!* D))), X, MU) >> COMMENT COS(...) = b; ELSE IF CAR X1='COS THEN<< IF !*ALLBRANCH THEN<<!!ARBINT:=!!ARBINT+1; C:=LIST('TIMES,2,'PI,LIST('ARBINT,!!ARBINT))>> ELSE C:=0; C:=SUBTRSQ(SIMP!* CADR X1,SIMP!* C); D:=SIMP!* LIST('ACOS,MK!*SQ GETELV(LIST('!!CF,1))); SOLVE1(SUBTRSQ(C,D), X, MU); IF !*ALLBRANCH THEN SOLVE1(ADDSQ(C,D), X, MU) >> COMMENT Unknown inverse; ELSE IF NULL(F:=GET(CAR X1,'INVERSE))THEN CONSSMMP(SUBTRSQ(SIMP!* X1,GETELV(LIST('!!CF,1))), -MU) COMMENT Other, known inverse; ELSE SOLVE1(SUBTRSQ(SIMP!* CADR X1,SIMP!* LIST(F,MK!*SQ GETELV(LIST('!!CF,1)))), X, MU)>> >> COMMENT Test for 2 powers of X1; ELSE IF F>=0 THEN << D:= SIMP!* GETELV(LIST('!!CF,2)); C := QUOTSQ(SIMP!* GETELV(LIST('!!CF,0)),D); D := QUOTSQ(SIMP!* GETELV(LIST('!!CF,1)),MULTSQ((2 ./1),D)); C:=SIMP!* LIST('EXPT, MK!*SQ SUBTRSQ(EXPTSQ(D,2),C), MK!*SQ(1 ./2)); D := ADDSQ(D, EXPTSQ(SIMP!* X1, N)); SOLVE1(SUBTRSQ(D,C), X, MU); SOLVE1(ADDSQ(D,C), X, MU) >> ELSE SOLVE22(E1,X1,X,MU) END; SYMBOLIC PROCEDURE SOLVE22(E1,X1,X,MU); BEGIN SCALAR B,C,D,F; INTEGER N; COMMENT Test for reciprocal equation, cubic, or quartic; F:=(!!HIPOW+1)/2; D:=EXPTSQ(SIMP!* X1,N); IF (FOR J:=0:F DO IF NOT(GETELV(LIST('!!CF,J)) =GETELV(LIST('!!CF,!!HIPOW-J)) ) THEN RETURN T) THEN IF (FOR J:=0:F DO IF NUMR ADDSQ(SIMP!* GETELV(LIST('!!CF,J)), SIMP!* GETELV(LIST('!!CF,!!HIPOW-J))) THEN RETURN T) THEN IF !!HIPOW=3 THEN SOLVECUBIC(D,X,MU,T) ELSE IF !!HIPOW=4 THEN SOLVEQUARTIC(D,X,MU) ELSE IF !*SOLVEINTERVAL AND UNIVARIATEP E1 THEN SOLVEINTERVAL(E1,MU) ELSE CONSSMMP(E1./1, -MU) COMMENT Antisymmetric reciprocal equation; ELSE << C:=ADDSQ(D,(-1 ./1)); SOLVE1(C, X, MU); E1:= QUOTSQ(E1./1, C); IF F+F = !!HIPOW THEN <<C:=ADDSQ(D,(1 ./1)); SOLVE1(C, X, MU); E1:= QUOTSQ(E1, C) >>; SOLVE1(E1, X, MU) >> COMMENT Symmetric reciprocal equation; ELSE IF F+F=!!HIPOW+1 THEN << C:=ADDSQ(D, 1 ./1); SOLVE1(C,X,MU); SOLVE1(QUOTSQ(E1./1, C), X, MU) >> ELSE << B:=SM!*; SETELV(LIST('!!CF, 0), SIMP!* 2); SETELV(LIST('!!CF, 1), SIMP!* '!!X); C:=ADDSQ(MULTSQ(SIMP!* GETELV(LIST('!!CF,F+1)), GETELV(LIST('!!CF,1))), SIMP!* GETELV(LIST('!!CF,F))); FOR J:=2:F DO << SETELV(LIST('!!CF, J), SUBTRSQ(MULTSQ(GETELV(LIST('!!CF,1)), GETELV(LIST('!!CF,J-1))), GETELV(LIST('!!CF,J-2)))); C:=ADDSQ(C,MULTSQ(GETELV(LIST('!!CF,J)), SIMP!* GETELV(LIST('!!CF,F+J)) )) >>; SOLVE1(C,'!!X,MU); C:=F:=NIL; WHILE NOT(SM!*=B) DO << C:=CAR SM!* . C; F:=CAR MP!* . F; SM!*:=CDR SM!*; MP!*:=CDR MP!* >>; WHILE C DO << SOLVE1(ADDSQ(1 ./1,MULTSQ(D,SUBTRSQ(D,CAAR C))), X, !*A2F CAAR F*MU); C:=CDR C >> >> END; SYMBOLIC PROCEDURE MKEXP U; (LAMBDA X; LIST('PLUS,LIST('COS,X),LIST('TIMES,'I,LIST('SIN,X)))) REVAL U; SYMBOLIC PROCEDURE SOLVECOEFF(EX, VAR); % EX is a standard form. % VAR is a kernel. % Puts the coefficients (as prefix standard quotients) of % VAR in EX into the elements of !!CF, with index equal % to the exponent divided by the GCD of all the % exponents. This GCD is put into !!GCD, and the % highest power divided by the GCD is put into % !!HIPOW. % Returns the lowest power if the highest is equal to 2; % -1 if the highest power is less than 2, or -1 if % the highest power is greater than 2. % This bizarre behaviour stems from the rewriting of the % Reduce COEFF function originally used by SOLVE. % Hopefully this will be rewritten someday without % the kludginess. % Note that !!CF (an array), !!GCD, and !!HIPOW are globals.; BEGIN SCALAR CLIST, X, OLDKORD; OLDKORD := SETKORDER(LIST(VAR)); CLIST := REORDER (EX); SETKORDER(OLDKORD); !!HIPOW := LDEG(CLIST); CLIST := COEFLIS(CLIST); !!GCD := 0; X := CLIST; WHILE X DO << !!GCD := GCDN(CAAR(X), !!GCD); X := CDR(X) >>; X := CLIST; FOR I := 0:(CAR(DIMENSION('!!CF))-1) DO SETELV(LIST('!!CF, I), NIL); WHILE X DO << SETELV(LIST('!!CF, CAAR(X)/!!GCD), MK!*SQ(CDAR(X) ./ 1)); X := CDR(X) >>; !!HIPOW := !!HIPOW/!!GCD; IF !!HIPOW=2 THEN RETURN CAAR(CLIST)/!!GCD ELSE IF !!HIPOW<2 THEN RETURN -1 ELSE RETURN -2 END; SYMBOLIC PROCEDURE SOLVEINTERVAL(EX, MUL); % EX is a standard form, MUL is an integer. Isolates % insoluble, real roots of EX in rational intervals, % stuffing result in the form INTERVL(Lowlim,Highlim) % into SM!* with multiplicity MUL put into MP!*.; BEGIN INTEGER I; REALROOT(PREPF EX,PREPSQ !*K2Q MVAR EX,!!INTERVALARRAY,'!!EXACT); FOR I := 1:GETELV LIST('!!EXACT,0) DO CONSSMMP(SIMP!* GETELV LIST('!!EXACT,I), MUL); FOR I := 1:GETELV LIST(!!INTERVALARRAY,0,0) DO CONSSMMP(SIMP!* LIST('INTERVL, GETELV LIST(!!INTERVALARRAY,I,1), GETELV LIST(!!INTERVALARRAY,I,2) ), MUL) END; SYMBOLIC PROCEDURE REALROOT(U,V,W,X); REDERR("Real root finding not yet implemented"); %***************** Procedures for solving Cubic and Quartic eqns ***; SYMBOLIC PROCEDURE SOLVECUBIC(X1, X, MU, CUBE3) ; BEGIN COMMENT Solves !!CF(3)*X1**3 + !!CF(2)*X1**2 ... X1 and X are kernels, M and MU are integers, CUBE3 is T or NIL. Returns NIL; SCALAR A,B,C,D; D:=SIMP!* GETELV(LIST('!!CF,3)); C:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,2)),D); B:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,1)),D); A:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,0)),D); A:=MULTSQ(ADDSQ(MULTSQ((9 ./1),MULTSQ(C,B)), ADDSQ(MULTSQ ((-27 ./1),A),MULTSQ((-2 ./1),EXPTSQ(C,3)))),(1 ./54)); B := MULTSQ((-1 ./9),ADDSQ(EXPTSQ(C,2),MULTSQ((-3 ./1),B))); D := SIMP!* LIST('EXPT, MK!*SQ ADDSQ(EXPTSQ(B,3), EXPTSQ(A,2)), MK!*SQ(1 ./2)); D := SIMP!* LIST('EXPT, MK!*SQ ADDSQ(A,D),MK!*SQ(1 ./3)); A := NEGSQ QUOTSQ(B,D); B := ADDSQ(D, A); C := ADDSQ(X1, MULTSQ(C,(1 ./3))); SOLVE1(SUBTRSQ(C,B), X, MU); IF CUBE3 THEN <<C := ADDSQ(MULTSQ(B,(1 ./2)), C); D := MULTSQ(SIMP!* LIST('EXPT,MK!*SQ(-3 ./4),MK!*SQ (1 ./2)), SUBTRSQ(D,A)); SOLVE1(ADDSQ(C,D), X, MU); SOLVE1(SUBTRSQ(C,D), X, MU)>> END; SYMBOLIC PROCEDURE SOLVEQUARTIC(X1,X,MU) ; BEGIN COMMENT Solves !!CF(4)*X1**4 + !!CF(3)*X1**3 + .... X1 is a standard quotient, X is a kernel, MU is an integer, CUBE3 is T or NIL. Returns NIL; SCALAR A,B,C,D,F; F:=SIMP!* GETELV(LIST('!!CF,4)); A:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,0)),F); B:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,1)),F); C:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,2)),F); D:=QUOTSQ(SIMP!* GETELV(LIST('!!CF,3)),F); F := ADDSQ(EXPTSQ(D,2), MULTSQ((-4 ./1),C)); SETELV(LIST('!!CF, 0), MK!*SQ NEGSQ ADDSQ(EXPTSQ(B,2),MULTSQ(A,F))); SETELV(LIST('!!CF, 1), MK!*SQ ADDSQ(MULTSQ(B,D),MULTSQ((-4 ./1),A))); SETELV(LIST('!!CF, 2), MK!*SQ NEGSQ C); SETELV(LIST('!!CF, 3), 1); SOLVECUBIC(SIMP!* X, X, MU, NIL); B := CAAR SM!*; SM!* := CDR SM!*; MP!*:= CDR MP!*; A := SIMP!* LIST('EXPT, MK!*SQ ADDSQ(EXPTSQ(B,2),MULTSQ(A, (-4 ./1))), MK!*SQ(1 ./2)); F := SIMP!* LIST('EXPT, MK!*SQ ADDSQ(F,MULTSQ(B,(4 ./1))), MK!*SQ(1 ./2)); SOLVE1(ADDSQ(EXPTSQ(X1,2),MULTSQ((1 ./2),ADDSQ(MULTSQ(X1,ADDSQ (D,F)), ADDSQ(B,A)))), X, MU); SOLVE1(ADDSQ(EXPTSQ(X1,2),MULTSQ((1 ./2),ADDSQ(MULTSQ(X1, SUBTRSQ(D,F)), SUBTRSQ(B,A)))), X, MU); END; %******************* Procedures for solving a system of eqns *******; SYMBOLIC PROCEDURE SOLVESYS(EXLIST,VARLIST); % EXLIST is a list of standard forms. % VARLIST is a list of kernels. % If EXLIST and VARLIST are of the same length and the % elements of VARLIST are linear in the elements of % exlist, and further the system of linear eqns so % defined is non-singular, then SOLVESYS returns a % list of standard quotients which are solutions of % the system, ordered as in VARLIST. % Otherwise an error results.; BEGIN SCALAR MTRX, RHS; % Coeffs and right side of system; SCALAR ROW, OLDKORD; IF LENGTH(EXLIST) NEQ LENGTH(VARLIST) THEN REDERR "SOLVESYS given unequal number of eqns & unknowns"; OLDKORD := SETKORDER(VARLIST); EXLIST := MAPCAR(EXLIST, 'REORDER); FOR EACH EX IN EXLIST DO << ROW := NIL; FOR EACH VAR IN VARLIST DO<< IF NOT DOMAINP(EX) AND (MVAR(EX)=VAR AND LDEG(EX)>1 OR (NOT FREEOFKERN(VAR, LC(EX))) OR (NOT FREEOFKERN(VAR, RED(EX))) ) THEN REDERR "SOLVE given system of non linear-fractional equations"; IF NOT DOMAINP(EX) AND MVAR(EX)=VAR THEN << ROW := !*F2Q(LC(EX)) . ROW; EX := RED(EX) >> ELSE ROW := !*F2Q(NIL) . ROW >>; RHS := LIST(!*F2Q(NEGF(EX))) . RHS; MTRX := ROW . MTRX >>; SETKORDER(OLDKORD); RETURN SOLVELNRSOLVE(MTRX, RHS) END; SYMBOLIC PROCEDURE SOLVELNRSOLVE(U,V); % U is a matrix canonical form, V a compatible matrix form. % Result is the solution,y, to the matrix equation U*y=V. % If !*SOLVESINGULAR is non-nil, introduces arbitrary constants % if necessary. Returns an error if the system represented is % inconsistent or if !*SOLVESINGULAR is nil and U is singular.; BEGIN INTEGER N, K; SCALAR X,!*S!*, PERM; X := !*EXP; !*EXP := T; N := LENGTH U; PERM := INDEXLIS(1, N); U := CAR NORMMAT AUGMENT(U,V); IF NOT !*SOLVESINGULAR THEN U := BAREISS U ELSE << U := SOLVEBAREISS(U, PERM); IF U THEN U := INSERTARBCONSTS(CDR(U), CAR(U)+1, FUNCTION MAKEARBCOMPLEX) >>; !*S!* := BACKSUB(U,N); U := MAPC2(RHSIDE(CAR !*S!*,N), FUNCTION (LAMBDA J; CANCEL(J . CDR !*S!*))); !*EXP := X; RETURN PERMUTE(U, PERM); END; SYMBOLIC PROCEDURE SOLVEBAREISS(U, PERM); %The 2-step integer preserving elimination method of Bareiss %based on the implementation of Lipson; %This is based on the Bareiss function in the Reduce matrix package, %modified to reduce singular matrices. If PERM is nil, behaves %as BAREISS, except a pair is returned for non-singular U, whose %cdr is the triangularized U. The car is the rank of U, which in %this case is always LENGTH(U). %Otherwise PERM is a list of the integers 1,2...length(U). %As columns are interchanged, then so are the elements of PERM. %In this case a pair is returned whose car is the rank of U and %whose cdr is the triangularized U. Note that, just as in BAREISS, the %lower triangular portion of the returned matrix standard form is only %implicitly all nils--the requisite RPLACAs are not performed. Also, %if PERM is non-nil and the rank,r, of U is less than the order of U, %only the first r rows of the upper triangular portion are explicitly %set. The all nil rows are only implicitly all nils. %U is a list of lists of standard forms (a matrix standard form) %corresponding to the appropriate augmented matrix. %If the value of procedure is NIL then U is singular, otherwise the %value is the triangularized form of U (in the same form); BEGIN SCALAR AA,C0,CI1,CI2,IK1,IJ,KK1,KJ,K1J,K1K1, UI,U1,X,K1COL,KIJ,FLG; INTEGER K,K1,COL,MAXCOL; %U1 points to K-1th row of U %UI points to Ith row of U %IJ points to U(I,J) %K1J points to U(K-1,J) %KJ points to U(K,J) %IK1 points to U(I,K-1) %KK1 points to U(K,K-1) %K1K1 points to U(K-1,K-1) %M in comments is number of rows in U %N in comments is number of columns in U; MAXCOL := LENGTH(U); AA:= 1; K:= 2; K1:=1; U1:=U; GO TO PIVOT; AGN: U1 := CDR U1; IF NULL CDR U1 OR NULL CDDR U1 THEN IF PERM AND CDR(U1) AND NULL(CAR(IJ := PNTH(NTH(U, MAXCOL), MAXCOL))) THEN << MAPC(CDR(IJ), FUNCTION LAMBDA(X); IF X THEN RETURN NIL); RETURN (MAXCOL-1).U >> ELSE RETURN MAXCOL.U; AA:=NTH(CAR U1,K); %AA := U(K,K); K:=K+2; K1:=K-1; U1:=CDR U1; PIVOT: %pivot algorithm; COL := K1; K1J:= K1K1 := PNTH(CAR U1,K1); PIV1: K1COL := PNTH(CAR(U1), COL); IF CAR K1COL THEN GO TO L2; UI:= CDR U1; %I := K; L: IF NULL UI THEN IF PERM THEN IF COL>=MAXCOL THEN RETURN (K1-1).U ELSE << COL := COL+1; GO TO PIV1 >> ELSE RETURN NIL ELSE IF NULL CAR(IJ := PNTH(CAR UI,COL)) THEN GO TO L1; L0: IF NULL IJ THEN GO TO L2; X := CAR IJ; RPLACA(IJ,NEGF CAR K1COL); RPLACA(K1COL,X); IJ:= CDR IJ; K1COL:= CDR K1COL; GO TO L0; L1: UI:= CDR UI; GO TO L; L2: SWAPCOLUMNS(U, K1, COL, PERM); COL := K; PIV2: UI:= CDR U1; %I:= K; L21: IF NULL UI THEN IF PERM THEN IF COL>=MAXCOL THEN << FLG := T; WHILE FLG AND U1 DO << IK1 := PNTH(CAR(U1), K1); IJ := PNTH(IK1, MAXCOL-K1+2); KIJ := PNTH(K1K1, MAXCOL-K1+2); WHILE FLG AND IJ DO IF ADDF(MULTF(CAR(K1K1), CAR(IJ)), MULTF(CAR(IK1), NEGF(CAR(KIJ))) ) THEN FLG := NIL ELSE IJ := CDR(IJ); U1 := CDR(U1) >>; IF FLG THEN RETURN (K-1).U ELSE RETURN NIL >> ELSE << COL := COL+1; GO TO PIV2 >> ELSE RETURN NIL; IJ:= PNTH(CAR UI,K1); C0:= ADDF(MULTF(CAR K1K1,NTH(IJ, COL-K+2)), MULTF(NTH(K1K1, COL-K+2),NEGF CAR IJ)); IF C0 THEN GO TO L3; UI:= CDR UI; %I:= I+1; GO TO L21; L3: SWAPCOLUMNS(U, K, COL, PERM); C0:= QUOTF!*(C0,AA); KK1 := KJ := PNTH(CADR U1,K1); %KK1 := U(K,K-1); IF CDR U1 AND NULL CDDR U1 THEN GO TO EV0 ELSE IF UI EQ CDR U1 THEN GO TO COMP; L31: IF NULL IJ THEN GO TO COMP; %IF I>N THEN GO TO COMP; X:= CAR IJ; RPLACA(IJ,NEGF CAR KJ); RPLACA(KJ,X); IJ:= CDR IJ; KJ:= CDR KJ; GO TO L31; %pivoting complete; COMP: IF NULL CDR U1 THEN GO TO EV; UI:= CDDR U1; %I:= K+1; COMP1: IF NULL UI THEN GO TO EV; %IF I>M THEN GO TO EV; IK1:= PNTH(CAR UI,K1); CI1:= QUOTF!*(ADDF(MULTF(CADR K1K1,CAR IK1), MULTF(CAR K1K1,NEGF CADR IK1)), AA); CI2:= QUOTF!*(ADDF(MULTF(CAR KK1,CADR IK1), MULTF(CADR KK1,NEGF CAR IK1)), AA); IF NULL CDDR K1K1 THEN GO TO COMP3;%IF J>N THEN GO TO COMP3; IJ:= CDDR IK1; %J:= K+1; KJ:= CDDR KK1; K1J:= CDDR K1K1; COMP2: IF NULL IJ THEN GO TO COMP3; RPLACA(IJ,QUOTF!*(ADDF(MULTF(CAR IJ,C0), ADDF(MULTF(CAR KJ,CI1), MULTF(CAR K1J,CI2))), AA)); IJ:= CDR IJ; KJ:= CDR KJ; K1J:= CDR K1J; GO TO COMP2; COMP3: UI:= CDR UI; GO TO COMP1; EV0:IF NULL C0 THEN RETURN; EV: KJ := CDR KK1; X := CDDR K1K1; %X := U(K-1,K+1); RPLACA(KJ,C0); EV1:KJ:= CDR KJ; IF NULL KJ THEN GO TO AGN; RPLACA(KJ,QUOTF!*(ADDF(MULTF(CAR K1K1,CAR KJ), MULTF(CAR KK1,NEGF CAR X)), AA)); X := CDR X; GO TO EV1 END; SYMBOLIC PROCEDURE SWAPCOLUMNS(MATRX, COL1, COL2, PERM); IF COL1=COL2 THEN MATRX ELSE << SWAPELEMENTS(PERM, COL1, COL2); FOR EACH U IN MATRX DO SWAPELEMENTS(U, COL1, COL2); MATRX >>; SYMBOLIC PROCEDURE SWAPELEMENTS(LST, I, J); % Swaps the Ith and Jth elements of the list LST al la % RPLACA and returns nil.; BEGIN SCALAR TEMP; IF I>J THEN << TEMP := I; I := J; J := TEMP >>; LST := PNTH(LST, I); I := J-I+1; TEMP := NTH(LST, I); RPLACA(PNTH(LST, I), CAR(LST)); RPLACA(LST, TEMP) END; SYMBOLIC PROCEDURE INDEXLIS(M, N); % M,N are integers. Returns the list (M M+1 M+2 ... N-1 N); IF M<=N THEN M . INDEXLIS(M+1,N); SYMBOLIC PROCEDURE INSERTARBCONSTS(M, ZEROROW, ARBFN); % M is a matrix standard form, representing a % matrix which has been row reduced. All elements below % the principal diagonal are implicitly nil, as are all % elements in row ZEROROW and below. It is such a form % as is returned by SOLVEBAREISS with a non-nil second % argument. It inserts approriate arbitrary constants in % the inhomogeneous portion, and 1's on the main diagonal % except for the last row, which gets the new determinant % of the square submatrix. Calls ARBFN to generate arbitrary % constants.; BEGIN SCALAR U, V, NEWDET; INTEGER N; N := LENGTH(M); IF ZEROROW<=N THEN << NEWDET := 1; U := M; FOR I := 1:(ZEROROW-1) DO << NEWDET := MULTF(NEWDET, NTH(CAR(U), I)); U := CDR(U) >>; FOR I := ZEROROW:(N-1) DO << V := PNTH(CAR(U), I); RPLACA(V, 1); V := CDR(V); FOR J := I+1:N DO << RPLACA(V, NIL); V := CDR(V) >>; WHILE V DO << RPLACA(V, !*K2F EVAL LIST ARBFN); V := CDR(V) >>; U := CDR(U) >>; V := PNTH(CAR(U), N); RPLACA(V, NEWDET); V := CDR(V); WHILE V DO << RPLACA(V, MULTF(NEWDET, !*K2F EVAL LIST ARBFN)); V := CDR(V) >> >>; RETURN M END; SYMBOLIC PROCEDURE PERMUTE(U, V); % U is a list. V is a list of the numbers 1,2,...LENGTH(U), permuted; % Returns a constructed list of the elements of U permuted by V.; IF V THEN NCONC(LIST(NTH(U,CAR(V))), PERMUTE(U, CDR(V))); SYMBOLIC PROCEDURE MAKEARBCOMPLEX(); BEGIN SCALAR ANS; ANS := NUMR(SIMP!*(LIST('ARBCOMPLEX, !!ARBINT))); !!ARBINT := !!ARBINT+1; RETURN ANS END; %******** Algebraic Let Statements and related declarations ********; PUT('ASIN, 'INVERSE, 'SIN); PUT('ACOS, 'INVERSE, 'COS); ALGEBRAIC << OPERATOR SOL, INTERVL, ARBCOMPLEX, ARBREAL, ARBINT, LST; COMMENT Supply missing argument and simplify 1/4 roots of unity; LET E**(I*PI/2) = I, E**(I*PI) = -1, E**(3*I*PI/2)=-I; FOR ALL N SUCH THAT FIXP N LET COS((N*PI)/2)= 0; LET COS(PI/2)=0; FOR ALL N SUCH THAT FIXP N LET SIN((N*PI)/2)= IF REMAINDER(ABS N,4)<2 THEN 1 ELSE -1; LET SIN(PI/2)=1; FOR ALL N SUCH THAT FIXP N LET COS((N*PI)/3)= (IF N=4 OR REMAINDER(ABS N+2,6)>3 THEN -1 ELSE 1)/2; LET COS(PI/3)=1/2; FOR ALL N SUCH THAT FIXP N LET SIN((N*PI)/3)= (IF REMAINDER(ABS N,6)<3 THEN 1 ELSE -1)*SQRT(3)/2; LET SIN(PI/3)=SQRT(3)/2; FOR ALL N SUCH THAT FIXP N LET COS((N*PI)/4)= (IF REMAINDER(ABS N+2,8)<4 THEN 1 ELSE -1)*SQRT(2)/2; LET COS(PI/4)=SQRT 2/2; FOR ALL N SUCH THAT FIXP N LET SIN((N*PI)/4)= (IF REMAINDER(ABS N,8)<4 THEN 1 ELSE -1)*SQRT(2)/2; LET SIN(PI/4)=SQRT(2)/2; FOR ALL N SUCH THAT FIXP N LET COS((N*PI)/6)= (IF REMAINDER(ABS N+2,12)<6 THEN 1 ELSE -1)*SQRT(3)/2; LET COS(PI/6)=SQRT 3/2; FOR ALL N SUCH THAT FIXP N LET SIN((N*PI)/6)= (IF REMAINDER(ABS N,12)<6 THEN 1 ELSE -1)/2; LET SIN(PI/6)=1/2; COMMENT Rules for reducing the number of distinct kernels in an equation; FOR ALL A,B,X SUCH THAT RATNUMP C AND RATNUMP D LET SOL(A**C-B**D, X) = A**(C*LCMD(C,D)) - B**(D*LCMD(C,D)); FOR ALL A,B,C,D,X SUCH THAT FREEOFKERN(X,A) AND FREEOFKERN(X,C) LET SOL(A**B-C**D, X) = E**(B*LOG A - D*LOG C); FOR ALL A,B,C,D,X SUCH THAT FREEOFKERN(X,A) AND FREEOFKERN(X,C) LET SOL(A*LOG B + C*LOG D, X) = B**A*D**C - 1, SOL(A*LOG B - C*LOG D, X) = B**A - D**C; FOR ALL A,B,C,D,F,X SUCH THAT FREEOFKERN(X,A) AND FREEOFKERN(X,C) LET SOL(A*LOG B + C*LOG D + F, X) = SOL(LOG(B**A*D**C) + F, X), SOL(A*LOG B + C*LOG D - F, X) = SOL(LOG(B**A*D**C) - F, X), SOL(A*LOG B - C*LOG D + F, X) = SOL(LOG(B**A/D**C) + F, X), SOL(A*LOG B - C*LOG D - F, X) = SOL(LOG(B**A/D**C) - F, X); FOR ALL A,B,D,F,X SUCH THAT FREEOFKERN(X,A) LET SOL(A*LOG B + LOG D + F, X) = SOL(LOG(B**A*D) + F, X), SOL(A*LOG B + LOG D - F, X) = SOL(LOG(B**A*D) - F, X), SOL(A*LOG B - LOG D + F, X) = SOL(LOG(B**A/D) + F, X), SOL(A*LOG B - LOG D - F, X) = SOL(LOG(B**A/D) - F, X), SOL(LOG D - A*LOG B + F, X) = SOL(LOG(D/B**A) + F, X), SOL(LOG D - A*LOG B - F, X) = SOL(LOG(D/B**A) - F, X); FOR ALL A,B,D,X SUCH THAT FREEOFKERN(X,A) LET SOL(A*LOG B + LOG D, X) = B**A*D - 1, SOL(A*LOG B - LOG D, X) = B**A - D, SOL(LOG D - A*LOG B, X) = D - B**A; FOR ALL A,B,C,X LET SOL(LOG A + LOG B + C, X) = SOL(LOG(A*B) + C, X), SOL(LOG A - LOG B + C, X) = SOL(LOG(A/B) + C, X), SOL(LOG A + LOG B - C, X) = SOL(LOG(A*B) - C, X), SOL(LOG A - LOG B - C, X) = SOL(LOG(A/B) - C, X); FOR ALL A,C,X SUCH THAT FREEOFKERN(X,C) LET SOL(LOG A + C, X) = A - E**C, SOL(LOG A - C, X) = A - E**(-C); FOR ALL A,B,X LET SOL(LOG A + LOG B, X) = A*B - 1, SOL(LOG A - LOG B, X) = A - B, SOL(COS A - SIN B, X) = SOL(COS A - COS(PI/2-B), X), SOL(SIN A + COS B, X) = SOL(SIN A - SIN(B-PI/2), X), SOL(SIN A - COS B, X) = SOL(SIN A - SIN(PI/2-B), X), SOL(SIN A + SIN B, X) = SOL(SIN A - SIN(-B), X), SOL(SIN A - SIN B, X) = IF !*ALLBRANCH THEN SIN((A-B)/2)* COS((A+B)/2) ELSE A-B, SOL(COS A + COS B, X) = IF !*ALLBRANCH THEN COS((A+B)/2)* COS((A-B)/2) ELSE A+B, SOL(COS A - COS B, X) = IF !*ALLBRANCH THEN SIN((A+B)/2)* SIN((A-B)/2) ELSE A-B, SOL(ASIN A - ASIN B, X) = A-B, SOL(ASIN A + ASIN B, X) = A+B, SOL(ACOS A - ACOS B, X) = A-B, SOL(ACOS A + ACOS B, X) = A+B; LET COS(PI/2)=0>>; END; |
Added r30/tops10.doc version [4b1c3b428e].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | RUNNING REDUCE ON A DECSYSTEM 10 SERIES COMPUTER Version 3.0 by Anthony C. Hearn The Rand Corporation Santa Monica, CA 90406 USA April 1983 ABSTRACT This document describes operating procedures specific to running REDUCE under TOPS-10 on a DECSYSTEM 10 series computer. Rand Publication CP80(4/83) Copyright (c) 1983 The Rand Corporation _T_A_B_L_E__O_F__C_O_N_T_E_N_T_S 1. PRELIMINARY ......................................................... 1 2. FILE HANDLING ....................................................... 1 3. AN INTRODUCTION TO REDUCE ........................................... 2 4. REDUCE DOCUMENTATION ................................................ 2 5. IMPLEMENTATION DEPENDENT PARAMETERS ................................. 2 5.1 Object sizes .............................................. 2 5.2 Special characters and interrupts ......................... 2 5.3 Memory Requirements ....................................... 3 5.4 Miscellaneous ............................................. 3 6. IMPLEMENTATION DEPENDENT ERROR MESSAGES ............................. 3 7. FURTHER HELP ........................................................ 4 Running REDUCE under TOPS-10 Page 1 1. _P_R_E_L_I_M_I_N_A_R_Y This document describes operating procedures for running REDUCE specific to the DECSYSTEM 10 series of computers. It supplements the REDUCE User's Manual, describing features, extension and limitations specific to this imple- mentation of REDUCE. REDUCE under TOPS-10 for a DECSYSTEM 10 series computer is stored as an exe- cutable binary disk file. The name of the directory that contains this file is identified in this document as "reduce:" . Other REDUCE related files are also stored in this directory. Unless reduce: is equivalent to sys: at your site, your command files should be modified to include reduce: in your sys: search path. An entry of the form: path sys:/search=reduce: is sufficient. To run REDUCE, you then type (in upper or lower case) reduce REDUCE will respond with a banner line and then prompt for the first line of input: reduce 3.0, 15-Apr-83 ... 1: You can now begin entering commands. 2. _F_I_L_E__H_A_N_D_L_I_N_G TOPS-10 REDUCE file names follow TOPS-10 conventions. In particular, the name and extension fields can be a maximum of six and three characters long respec- tively. As a result, the filenames that appear in IN, OUT and SHUT statements must follow this convention. Directory names can be of three forms: An identifier followed by a colon, e.g., reduce:. An identifier enclosed in angle brackets, e.g., <reduce>. (Normally only used with TOPS-20.) A project, programmer pair, enclosed in square brackets, e.g., [22,304]. (Normally only used with TOPS-10.) The first two styles of directory name must precede the file name, and the third follow it, as in "reduce:reduce.tst" "<reduce>reduce.tst" Running REDUCE under TOPS-10 Page 2 or "reduce.tst[22,304]". As a test of the system, you should try in "reduce:reduce.tst"; which will load the standard REDUCE test file. 3. _A_N__I_N_T_R_O_D_U_C_T_I_O_N__T_O__R_E_D_U_C_E New users of REDUCE are advised to process the seven REDUCE Lessons that are available as reduce:lessi. For example, to run Lesson 1, you would say: in "reduce:less1"; 4. _R_E_D_U_C_E__D_O_C_U_M_E_N_T_A_T_I_O_N REDUCE documents are also kept in the reduce: directory, with the extension doc. These include: instal.doc Installation instructions reduce.doc REDUCE User's Manual tops10.doc TOPS-10 specific operation notes (i.e., this document). 5. _I_M_P_L_E_M_E_N_T_A_T_I_O_N__D_E_P_E_N_D_E_N_T__P_A_R_A_M_E_T_E_R_S 5.1 _O_b_j_e_c_t__s_i_z_e_s The maximum string and identifier lengths are limited only by the total size of the memory partition for the names of such objects in the underlying LISP interpreter. This is usually several thousand characters long. However, we recommend that such names be limited to twenty-four characters or less for compatibility with other versions of REDUCE. Floating point numbers are printed with eight digit precision in either fixed notation or in a scientific notation with a two digit exponent depending on the size of the number. Arbitrary precision integer and real arithmetic is supported. Times (as reported by ON TIME or SHOWTIME) are given in milliseconds, and measure execution time including garbage collection time. They do not include operating system overhead (e.g., swapping time). 5.2 _S_p_e_c_i_a_l__c_h_a_r_a_c_t_e_r_s__a_n_d__i_n_t_e_r_r_u_p_t_s Lower case input is permitted. The end-of-file character is <control>Z. Running REDUCE under TOPS-10 Page 3 <del> deletes a single character from terminal input, <control>U the whole line. A command may be terminated by <escape> instead of $. This has the added advantage that a Return is then not needed to evaluate the line. <escape> is also used to terminate strings in the REDUCE interactive editor. ^ may be used instead of ** to represent exponentiation. 5.3 _M_e_m_o_r_y__R_e_q_u_i_r_e_m_e_n_t_s The distributed version of REDUCE requires a minimum of 193 pages of memory to run. This size will increase as additional facilities are automatically loaded by user actions. A default expression workspace of approximately 26000 cells is also provided, which may prove to be insufficient for some problems. A command CORE is available to increase the size of the workspace. This com- mand MUST be given at the top level and not from a file since it reinitializes all file buffers. CORE takes an integer as argument, representing the basic REDUCE program size in K words (exclusive of operating system increments). The minimum value is 60 (the default) and the maximum 124. For example, to increase the user workspace by 10K words, one would say: CORE 70; at the top level. In addition to the expression workspace, there is another memory partition called the binary program space (which holds compiled programs) that also requires top level adjustment. A command EXCORE is available to increase the size of this space. Its single argument is also an integer representing K words, but, unlike CORE, it causes the space to be incremented by that amount, not set to that amount. For system modules referenced at the top level, an automatic increase in binary program space occurs. Otherwise the user must increase this space manually, prompted by a system message telling how much extra space is needed. 5.4 _M_i_s_c_e_l_l_a_n_e_o_u_s There is no link currently to an external editor. The internal ordering on alphabetic characters is from A through Z followed by a through z. To exit REDUCE use either "bye;" or "quit;". These are equivalent. If no non-ephemeral processes have been invoked after this, such a job may be res- tarted by the operating system command CONTINUE. 6. _I_M_P_L_E_M_E_N_T_A_T_I_O_N__D_E_P_E_N_D_E_N_T__E_R_R_O_R__M_E_S_S_A_G_E_S A number of error messages from the underlying LISP system may be seen from time to time. These include: NO FREE STG LEFT Your problem is too large in its present form for the available Running REDUCE under TOPS-10 Page 4 workspace; either change your problem formulation or increase the amount of workspace by the CORE command REG PUSHDOWN CAPACITY EXCEEDED Your program probably contains a non-terminating loop that exhausts the system's space for recursive references. If you think your program is correct, ask your site consultant to build you a system with a bigger pushdown stack. For further details, the Manual for Standard LISP on DECSYSTEM 10 and 20 should be consulted. 7. _F_U_R_T_H_E_R__H_E_L_P For further help with REDUCE, please contact <list your site consultant here> |
Added r30/tops20.doc version [001073fe56].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | RUNNING REDUCE ON A DECSYSTEM 20 SERIES COMPUTER Version 3.0 by Anthony C. Hearn The Rand Corporation Santa Monica, CA 90406 USA April 1983 ABSTRACT This document describes operating procedures specific to running REDUCE under TOPS-20 on a DECSYSTEM 20 series computer. Rand Publication CP81(4/83) Copyright (c) 1983 The Rand Corporation _T_A_B_L_E__O_F__C_O_N_T_E_N_T_S 1. PRELIMINARY ......................................................... 1 2. FILE HANDLING ....................................................... 1 3. AN INTRODUCTION TO REDUCE ........................................... 2 4. REDUCE DOCUMENTATION ................................................ 2 5. FILE EDITING CAPABILITIES ........................................... 2 6. IMPLEMENTATION DEPENDENT PARAMETERS ................................. 3 6.1 Object sizes .............................................. 3 6.2 Special characters and interrupts ......................... 3 6.3 Memory Requirements ....................................... 4 6.4 Miscellaneous ............................................. 4 7. IMPLEMENTATION DEPENDENT ERROR MESSAGES ............................. 4 8. FURTHER HELP ........................................................ 4 Running REDUCE under TOPS-20 Page 1 1. _P_R_E_L_I_M_I_N_A_R_Y This document describes operating procedures for running REDUCE specific to the DECSYSTEM 20 series of computers. It supplements the REDUCE User's Manual, describing features, extension and limitations specific to this imple- mentation of REDUCE. REDUCE under TOPS-20 for a DECSYSTEM 20 series computer is stored as an exe- cutable binary disk file. The name of the directory that contains this file is identified in this document as "<reduce>" . Other REDUCE related files are also stored in this directory. Unless <reduce> is equivalent to sys: at your site, your command files should be modified to include <reduce> in your sys: search path. An entry of the form: def sys: <reduce>,sys: is sufficient. To run REDUCE, you then type (in upper or lower case) reduce REDUCE will respond with a banner line and then prompt for the first line of input: reduce 3.0, 15-Apr-83 ... 1: You can now begin entering commands. 2. _F_I_L_E__H_A_N_D_L_I_N_G The LISP interpreter currently in use with this version of REDUCE was origi- nally written for a TOPS-10 system. As a result, its file names follow TOPS-10 conventions. In particular, the name and extension fields can be a maximum of six and three characters long respectively. As a result, the filenames that appear in IN, OUT and SHUT statements must follow this convention. Directory names can be of three forms: An identifier followed by a colon, e.g., reduce:. An identifier enclosed in angle brackets, e.g., <reduce>. (Normally only used with TOPS-20.) A project, programmer pair, enclosed in square brackets, e.g., [22,304]. (Normally only used with TOPS-10.) The first two styles of directory name must precede the file name, and the third follow it, as in "reduce:reduce.tst" Running REDUCE under TOPS-20 Page 2 "<reduce>reduce.tst" or "reduce.tst[22,304]". As a test of the system, you should try in "<reduce>reduce.tst"; which will load the standard REDUCE test file. 3. _A_N__I_N_T_R_O_D_U_C_T_I_O_N__T_O__R_E_D_U_C_E New users of REDUCE are advised to process the seven REDUCE Lessons that are available as <reduce>lessi. For example, to run Lesson 1, you would say: in "<reduce>less1"; 4. _R_E_D_U_C_E__D_O_C_U_M_E_N_T_A_T_I_O_N REDUCE documents are also kept in the <reduce> directory, with the extension doc. These include: instal.doc Installation instructions reduce.doc REDUCE User's Manual tops20.doc TOPS-20 specific operation notes (i.e., this document). 5. _F_I_L_E__E_D_I_T_I_N_G__C_A_P_A_B_I_L_I_T_I_E_S The TOPS-20 version of REDUCE provides a link to the line-oriented system edi- tor "EDIT". There are two commands provided in this regard. EDIT <id>[,<integer>[,<integer>]] If <id> is a valid file name, then this command will invoke the editor on this file. If the optional integer arguments are omitted, then you will be posi- tioned at the first line in the file. On exiting from the editor, you will be returned to REDUCE. If the second argument is used, you will be positioned at that line in the file. If the third argument is used, that page will be referenced rather than the default page 1. For example, EDIT "foo.bah",100; will position the editor at line 100 on page 1 of the file "foo.bah". If the second or optional third arguments are specified, on exiting from the editor REDUCE will first load the command that starts at the line specified in the EDIT command before returning control to the user. If <id> is not a file name, but is the name of a function that has been loaded by the user from a file, then the editor will be positioned at the first line Running REDUCE under TOPS-20 Page 3 of that function. Thirdly, if <id> is the name of a function that has been defined at the termi- nal, EDIT will edit that function by a call to EDITDEF. In other words, EDIT and EDITDEF are equivalent in this case. If none of these conditions is satisfied, EDIT will abort with the error that <id> is not defined. There are two cautions to be observed in using this command to reference files. First, you must not renumber the file or save it without line numbers, since REDUCE depends on the explicit line numbers for its references. Secondly, if you do not position the editor at the beginning of a command for the second use of EDIT, then an error will obviously occur when REDUCE tries to read the expression. The same cautions apply to CMD defined below. CMD <id><integer>[,<integer>] This command causes the command defined at the line <integer1> in the file <id> to be loaded. <integer2> can be used to specify an optional page. 6. _I_M_P_L_E_M_E_N_T_A_T_I_O_N__D_E_P_E_N_D_E_N_T__P_A_R_A_M_E_T_E_R_S 6.1 _O_b_j_e_c_t__s_i_z_e_s The maximum string and identifier lengths are limited only by the total size of the memory partition for the names of such objects in the underlying LISP interpreter. This is usually several thousand characters long. However, we recommend that such names be limited to twenty-four characters or less for compatibility with other versions of REDUCE. Floating point numbers are printed with eight digit precision in either fixed notation or in a scientific notation with a two digit exponent depending on the size of the number. Arbitrary precision integer and real arithmetic is supported. Times (as reported by ON TIME or SHOWTIME) are given in milliseconds, and measure execution time including garbage collection time. They do not include operating system overhead (e.g., swapping time). 6.2 _S_p_e_c_i_a_l__c_h_a_r_a_c_t_e_r_s__a_n_d__i_n_t_e_r_r_u_p_t_s Lower case input is permitted. The end-of-file character is <control>Z. <del> deletes a single character from terminal input, <control>U the whole line. A command may be terminated by <escape> instead of $. This has the added advantage that a Return is then not needed to evaluate the line. <escape> is also used to terminate strings in the REDUCE interactive editor. Running REDUCE under TOPS-20 Page 4 ^ may be used instead of ** to represent exponentiation. 6.3 _M_e_m_o_r_y__R_e_q_u_i_r_e_m_e_n_t_s The distributed version of REDUCE requires a minimum of 193 pages of memory to run. This size will increase as additional facilities are automatically loaded by user actions. A default expression workspace of approximately 26000 cells is also provided, which may prove to be insufficient for some problems. A command CORE is available to increase the size of the workspace. This com- mand MUST be given at the top level and not from a file since it reinitializes all file buffers. CORE takes an integer as argument, representing the basic REDUCE program size in K words (exclusive of operating system increments). The minimum value is 60 (the default) and the maximum 124. For example, to increase the user workspace by 10K words, one would say: CORE 70; at the top level. 6.4 _M_i_s_c_e_l_l_a_n_e_o_u_s The internal ordering on alphabetic characters is from A through Z followed by a through z. To exit REDUCE use either "bye;" or "quit;". These are equivalent. If no non-ephemeral processes have been invoked after this, such a job may be res- tarted by the operating system command CONTINUE. 7. _I_M_P_L_E_M_E_N_T_A_T_I_O_N__D_E_P_E_N_D_E_N_T__E_R_R_O_R__M_E_S_S_A_G_E_S A number of error messages from the underlying LISP system may be seen from time to time. These include: NO FREE STG LEFT Your problem is too large in its present form for the available workspace; either change your problem formulation or increase the amount of workspace by the CORE command REG PUSHDOWN CAPACITY EXCEEDED Your program probably contains a non-terminating loop that exhausts the system's space for recursive references. If you think your program is correct, ask your site consultant to build you a system with a bigger pushdown stack. For further details, the Manual for Standard LISP on DECSYSTEM 10 and 20 should be consulted. 8. _F_U_R_T_H_E_R__H_E_L_P For further help with REDUCE, please contact <list your site consultant here> |
Added r33/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 r34.1/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 r34.3/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 r34/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 r35/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 r36/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 r37/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 r38/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 |